text:
C$Procedure      ZZEKPARS ( EK, parse tokenized EK query )

      SUBROUTINE ZZEKPARS (  QUERY,   NTOKEN,  LXBEGS,  LXENDS,
     .                       TOKENS,  VALUES,  NUMVLS,  CHRBUF,
     .                       CHBEGS,  CHENDS,  EQRYI,   EQRYC,
     .                       EQRYD,   ERROR,   PRSERR          )

      IMPLICIT NONE

C$ Abstract
C
C     Parse an EK query that has been scanned and tokenized.
C     Represent the result as an encoded EK query.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     EK
C
C$ Keywords
C
C     EK
C     PARSE
C
C$ Declarations

      INCLUDE 'ektokn.inc'
      INCLUDE 'ekkeyw.inc'
      INCLUDE 'ekbool.inc'
      INCLUDE 'ektype.inc'
      INCLUDE 'ekopcd.inc'
      INCLUDE 'ekquery.inc'
      INCLUDE 'ekqlimit.inc'

      INTEGER               LBCELL
      PARAMETER           ( LBCELL = -5 )

      CHARACTER*(*)         QUERY
      INTEGER               NTOKEN
      INTEGER               LXBEGS ( * )
      INTEGER               LXENDS ( * )
      INTEGER               TOKENS ( * )
      INTEGER               VALUES ( * )
      DOUBLE PRECISION      NUMVLS ( * )
      CHARACTER*(*)         CHRBUF
      INTEGER               CHBEGS ( * )
      INTEGER               CHENDS ( * )
      INTEGER               EQRYI  ( LBCELL : * )
      CHARACTER*(*)         EQRYC
      DOUBLE PRECISION      EQRYD  ( * )
      LOGICAL               ERROR
      CHARACTER*(*)         PRSERR

C$ Brief_I/O
C
C     Variable  I/O  Description
C     --------  ---  --------------------------------------------------
C     QUERY      I   Query in string form.
C     NTOKEN     I   Number of tokens in query.
C     LXBEGS,
C     LXENDS     I   Lexeme begin and end positions in QUERY.
C     TOKENS     I   Token codes.
C     VALUES     I   Values associated with tokens.
C     NUMVLS     I   Buffer containing numeric token values.
C     CHRBUF     I   Buffer containing string token values.
C     CHBEGS,
C     CHENDS     I   String token begin and end character positions.
C     EQRYI,
C     EQRYC,
C     EQRYD      O   Parsed query and string and number value buffers.
C     ERROR      O   Flag indicating whether query parsed correctly.
C     PRSERR     O   Parse error description.
C
C$ Detailed_Input
C
C     QUERY          is a string containing the original input query.
C                    QUERY is used only for creating error messages.
C
C     NTOKEN         is the number of tokens in the input query.
C
C     LXBEGS,
C     LXENDS         are lexeme begin and end pointers; the Ith
C                    lexeme in the query is
C
C                       QUERY ( LXBEGS(I) : LXENDS(I) )
C
C                    (Lexemes are strings that correspond to tokens
C                     in the language.)
C
C     TOKENS         is an array of token codes.  The Ith element of
C                    TOKENS represents the Ith token in the scanned
C                    query.
C
C     VALUES         is an array of values associated with tokens; the
C                    Ith element of VALUES corresponds to the Ith
C                    token.  Keywords, for example, are distinguished
C                    by codes in the VALUES array.  Literal numeric
C                    and string tokens use the VALUES array to point
C                    to elements of NUMVLS or CHBEGS and CHENDS,
C                    respectively.  Some tokens don't need to use
C                    VALUES, but to simplify indexing, each token gets
C                    an element of this array.
C
C     NUMVLS         is an array of double precision numbers used to
C                    store the values corresponding to literal numeric
C                    tokens.
C
C     CHRBUF         is a string used to store the values of literal
C                    string tokens.
C
C     CHBEGS,
C     CHENDS         are pairs of begin and end pointers into CHRBUF.
C                    These pointers delimit character values
C                    associated with literal string tokens.
C
C
C$ Detailed_Output
C
C     EQRYI,
C     EQRYC,
C     EQRYD          are the integer, character, and numeric portions
C                    of an encoded form of the input query.  The
C                    SELECT, FROM, WHERE, and ORDER BY clauses of the
C                    input query are all represented in this encoding.
C                    WHERE clause constraints have been normalized.
C
C                    Normalized queries have their constraints grouped
C                    into a disjunction of conjunctions of relational
C                    expressions, as symbolized below:
C
C                          ( <rel_exp_1_1> and <rel_exp_1_2> and ... )
C                       or ( <rel_exp_2_1> and <rel_exp_2_2> and ... )
C                                     .
C                                     .
C                                     .
C                       or ( <rel_exp_N_1> and <rel_exp_N_2> and ... )
C
C     ERROR,
C     PRSERR         are, respectively, a flag indicating whether the
C                    input query parsed correctly, and a message
C                    describing the parse error, if one occurred.  If
C                    no error occurred, ERROR is .FALSE. and PRSERR
C                    is blank.
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     1)  Most of the exceptions that can occur on a call to
C         ZZEKPARS are caused by errors in the input query.  ZZEKPARS
C         attempts to diagnose these via the output error flag and
C         error message, instead of signalling errors.  The
C         error messages that ZZEKPARS can return are listed below.
C         In the messages shown, the symbol # is used to designate
C         a marker for which a value can be substituted in an actual
C         message.
C
C
C            The BY keyword was not found following the
C            ORDER keyword.
C
C            Invalid keyword at location #.
C            Actual token was: #
C
C            Table or column name expected at location
C            #. Actual token was: #
C
C            Table name expected at location #.
C            Actual token was: #
C
C            Column name expected at location #.
C            Actual token was: #
C
C            Table alias, comma, or keyword expected at
C            location #. Actual token was: #
C
C            Comma or keyword expected at
C            location #. Actual token was: #
C
C            Comma expected at location #. Actual token was: #
C
C            PRSERR  =  More tokens were expected in query.
C
C            The keyword # was expected at location
C            #. Actual token was: #
C
C            Invalid token at location #. Token was: #
C
C            PRSERR  =  Number of tables in "FROM" clause exceeds
C            allowed maximum of #.
C
C            PRSERR  =  Number of order-by columns exceeds allowed
C            maximum of #.
C
C            PRSERR  =  Number of SELECT columns exceeds allowed
C            maximum of #.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     This routine determines whether a query is syntactically correct;
C     it tranforms correct queries into the EK system's encoded query
C     representation.
C
C     The encoded queries output by this routine are not ready for
C     execution; they still must undergo name resolution, time value
C     conversion, and semantic checking.  See EKFIND for an example of
C     the normal sequence of query processing.
C
C$ Examples
C
C     See the header of EKFIND for examples of valid and invalid
C     queries.
C
C$ Restrictions
C
C     None.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     N.J. Bachman   (JPL)
C
C$ Version
C
C-    SPICELIB Version 4.1.0, 15-OCT-1996 (NJB)
C
C        Bug fix: default order sense was not encoded when ORDER-BY
C        clause was not the last clause of the query.
C
C-    SPICELIB Version 4.0.0, 17-NOV-1995 (NJB)
C
C        Complete re-write for architecture 3.
C
C-&

C$ Index_Entries
C
C     parse EK query
C
C-&

C$ Revisions
C
C-    SPICELIB Version 4.1.0, 15-OCT-1996 (NJB)
C
C        Bug fix: default order sense was not encoded when ORDER-BY
C        clause was not the last clause of the query.  The old algorithm
C        assumed that no clauses followed the ORDER-BY clause, which
C        at one time was a limitation of the EK query language.
C
C-&

C
C     SPICELIB functions
C
      INTEGER               CARDI

      LOGICAL               FAILED
      LOGICAL               RETURN

C
C     Local parameters
C

C
C     State parameters
C
      INTEGER               FROM
      PARAMETER           ( FROM    =            0 )

      INTEGER               FRMTAB
      PARAMETER           ( FRMTAB  =   FROM   + 1 )

      INTEGER               FRMCNT
      PARAMETER           ( FRMCNT  =   FRMTAB + 1 )

      INTEGER               FRMALS
      PARAMETER           ( FRMALS  =   FRMCNT + 1 )

      INTEGER               WHERE
      PARAMETER           ( WHERE   =   FRMALS + 1 )

      INTEGER               ORDER
      PARAMETER           ( ORDER   =   WHERE  + 1 )

      INTEGER               ORDRBY
      PARAMETER           ( ORDRBY  =   ORDER  + 1 )

      INTEGER               ORDTAB
      PARAMETER           ( ORDTAB  =   ORDRBY + 1 )

      INTEGER               ORDNAM
      PARAMETER           ( ORDNAM  =   ORDTAB + 1 )

      INTEGER               ORDCOL
      PARAMETER           ( ORDCOL  =   ORDNAM + 1 )

      INTEGER               ORDSNS
      PARAMETER           ( ORDSNS  =   ORDCOL + 1 )

      INTEGER               SELKEY
      PARAMETER           ( SELKEY  =   ORDSNS + 1 )

      INTEGER               SELECT
      PARAMETER           ( SELECT  =   SELKEY + 1 )

      INTEGER               SELTAB
      PARAMETER           ( SELTAB  =   SELECT + 1 )

      INTEGER               SELNAM
      PARAMETER           ( SELNAM  =   SELTAB + 1 )

      INTEGER               SELCOL
      PARAMETER           ( SELCOL  =   SELNAM + 1 )

      INTEGER               TERM
      PARAMETER           ( TERM    =   SELCOL + 1 )

C
C     Other local parameters
C
      INTEGER               MAXREL
      PARAMETER           ( MAXREL =  200 )

      INTEGER               TYPLEN
      PARAMETER           ( TYPLEN =   32 )

      INTEGER               KEYLEN
      PARAMETER           ( KEYLEN =   32 )

C
C     Local variables
C
      CHARACTER*(TYPLEN)    ERRTYP
      CHARACTER*(KEYLEN)    EXPKEY

      INTEGER               ALSDSC ( EQVDSZ )
      INTEGER               B
      INTEGER               COLDSC ( EQVDSZ )
      INTEGER               E
      INTEGER               I
      INTEGER               J
      INTEGER               L
      INTEGER               LXB
      INTEGER               LXE
      INTEGER               NAMDSC ( EQVDSZ )
      INTEGER               NCNSTR
      INTEGER               NORDER
      INTEGER               NSEL
      INTEGER               NTABS
      INTEGER               STATE
      INTEGER               TABDSC ( EQVDSZ )
      INTEGER               TOKEN
      INTEGER               TOKNUM
      INTEGER               VALDSC ( EQVDSZ )

      LOGICAL               FND

C
C     Standard SPICE error handling.
C
      IF ( RETURN () ) THEN
         RETURN
      ELSE
         CALL CHKIN ( 'ZZEKPARS' )
      END IF

C
C     Initialize the encoded query each time, for safety.
C
      CALL ZZEKQINI ( EQIMIN, MAXQNM, EQRYI, EQRYC, EQRYD )

      IF ( FAILED() ) THEN
         ERROR  =  .TRUE.
         PRSERR =  'SPICE(BUG):  encoded query init failed.'
         CALL CHKOUT ( 'ZZEKPARS' )
         RETURN
      END IF

C
C     The structure of a query is
C
C        <QUERY>                 =>    <SELECT clause> <FROM clause>
C                                      <WHERE clause> <ORDER BY clause>
C
C        <SELECT clause>         =>    SELECT <select list>
C
C        <select list>           =>    <column entry>
C                                    | <select list>, <column entry>
C
C        <column entry>          =>    <table name>.<column name>
C                                    | <column name>
C
C        <FROM clause>           =>    <table name list>
C
C        <table name list>       =>    <table entry>
C                                    | <table name list>, <table entry>
C
C        <table entry>           =>    <table name>
C                                    | <table name> <table alias>
C
C        <WHERE clause>          =>    WHERE <constraint expression>
C                                    | <NIL>
C
C        <ORDER BY clause>       =>    ORDER BY <order-by list>
C                                    | <NIL>
C
C        <order-by list>         =>    <order-by column entry>
C                                    | <order-by list>,
C                                      <order-by column entry>
C
C        <order-by column entry> =>    <column entry> <order>
C
C        <order>                 =>    ASC
C                                    | DESC
C                                    | <NIL>
C
C
C
C     We'll parse the clauses of the query in the following order:
C
C        FROM
C        WHERE     (if present)
C        ORDER BY  (if present)
C        SELECT
C
C
      CALL ZZEKTLOC ( TKKEY,   KWFROM,  NTOKEN,  TOKENS,  VALUES,
     .                TOKNUM,  FND                                )

      IF ( .NOT. FND ) THEN

         ERROR   =  .TRUE.
         ERRTYP  =  'FROM_NOT_FOUND'
         STATE   =   TERM

      ELSE

         STATE   =  FROM
         NTABS   =  0
         NSEL    =  0
         NCNSTR  =  0
         NORDER  =  0
         ERROR   =  .FALSE.
         PRSERR  =  ' '
         ERRTYP  =  ' '

      END IF

      DO WHILE ( STATE .NE. TERM )
C
C        Advance to the next token, if there is one.
C
         TOKNUM  =  TOKNUM + 1

         IF ( TOKNUM .GT. NTOKEN ) THEN
C
C           We're out of tokens.  Set the token value to indicate
C           `end of query'.
C
            TOKEN  =  TKEOQ

         ELSE

            TOKEN  =  TOKENS(TOKNUM)

         END IF

C
C        Perform semantic actions based on the state and current token.
C
         IF ( STATE .EQ. FROM ) THEN
C
C           We expect to see an identifier representing a table name.
C           No other tokens are allowed.
C
            IF ( TOKEN .EQ. TKID ) THEN
C
C              We've found a table name (as far as we can tell at
C              this point).  Make sure we haven't exceeded the limit
C              for table names; if not, add the appropriate information
C              to the encoded query.
C
               NTABS  =   NTABS  +  1

               IF ( NTABS .GT. MAXTAB ) THEN

                  ERROR   =  .TRUE.
                  ERRTYP  =  'TOO_MANY_TABLES'
                  STATE   =  TERM

               ELSE

                  I       =   VALUES(TOKNUM)
                  B       =   CHBEGS(I)
                  E       =   CHENDS(I)
                  L       =   E  -  B   +  1
                  LXB     =   LXBEGS(TOKNUM)
                  LXE     =   LXENDS(TOKNUM)

                  CALL ZZEKINQC ( CHRBUF( B : E ),
     .                            L,
     .                            LXB,
     .                            LXE,
     .                            EQRYI,
     .                            EQRYC,
     .                            TABDSC          )

C
C                 Append the table descriptor to the integer part of the
C                 query.
C
                  DO J = 1, EQVDSZ
                     CALL APPNDI ( TABDSC(J), EQRYI )
                  END DO

C
C                 Add a place-holder value descriptor to reserve
C                 space for an alias descriptor for this table.  If an
C                 actual alias is supplied, we'll update this
C                 descriptor.
C
                  CALL CLEARI ( EQVDSZ, ALSDSC )
                  ALSDSC(EQDTYP)  =  CHR

                  DO J = 1, EQVDSZ
                     CALL APPNDI ( ALSDSC(J), EQRYI )
                  END DO

C
C                 Update the table count in the encoded query.
C
                  CALL ZZEKWEQI ( 'NUM_TABLES', NTABS, EQRYI )

                  STATE  =  FRMTAB

               END IF

            ELSE IF ( TOKEN .EQ. TKEOQ ) THEN

               ERROR   =  .TRUE.
               ERRTYP  =  'MORE_TOKENS_EXP'
               STATE   =  TERM

            ELSE
C
C              We've got the wrong kind of token here.
C
               ERROR   =  .TRUE.
               ERRTYP  =  'TABLE_EXP'
               STATE   =  TERM

            END IF
C
C           State is a member of {FRMTAB, TERM}.
C

         ELSE IF ( STATE .EQ. FRMTAB ) THEN
C
C           We should see a comma, an alias, one of the SELECT,
C           WHERE or ORDER keywords, or the end of the query.
C
            IF ( TOKEN .EQ. TKEOQ ) THEN
C
C              We're out of tokens.  It's time to parse the
C              WHERE clause.
C
               STATE   =  WHERE

            ELSE IF ( TOKEN .EQ. TKCOMA ) THEN
C
C              It's time to look for another table name.
C
               STATE  =  FROM

            ELSE IF ( TOKEN .EQ. TKID ) THEN
C
C              We've got an alias.  Add this string to the encoded
C              query.
C
               I   =   VALUES(TOKNUM)
               B   =   CHBEGS(I)
               E   =   CHENDS(I)
               L   =   E  -  B   +  1
               LXB =   LXBEGS(TOKNUM)
               LXE =   LXENDS(TOKNUM)

               CALL ZZEKINQC ( CHRBUF( B : E ),
     .                         L,
     .                         LXB,
     .                         LXE,
     .                         EQRYI,
     .                         EQRYC,
     .                         ALSDSC                        )

C
C              Update the place-holder alias descriptor in the integer
C              part of the query.
C
               CALL MOVEI ( ALSDSC,
     .                      EQVDSZ,
     .                      EQRYI(  CARDI(EQRYI) - EQVDSZ + 1  )   )

               STATE  =  FRMALS

            ELSE IF (  TOKEN .EQ.  TKKEY  )  THEN
C
C              The last table name in the FROM clause is followed by
C              a keyword.  SELECT, WHERE and ORDER are the only valid
C              possibilities.
C
               IF (       ( VALUES(TOKNUM) .NE. KWWHER )
     .              .AND. ( VALUES(TOKNUM) .NE. KWSEL  )
     .              .AND. ( VALUES(TOKNUM) .NE. KWORDR )  ) THEN
C
C                 We've got a keyword we don't want here.
C
                  ERROR  =  .TRUE.
                  ERRTYP =  'BAD_KEYWORD'
                  STATE  =  TERM

               ELSE
C
C                 Parse the WHERE clause.
C
                  STATE  =  WHERE

               END IF

            ELSE
C
C              We've got the wrong kind of token altogether.
C
               ERROR  =  .TRUE.
               ERRTYP =  'ALIAS_EXP'
               STATE  =  TERM

            END IF

C
C           STATE is a member of {FROM, FRMALS, WHERE, TERM}.
C

         ELSE IF ( STATE .EQ. FRMALS ) THEN
C
C           We should see a comma, the SELECT, WHERE or ORDER
C           keywords, or the end of the query.
C
            IF ( TOKEN .EQ. TKEOQ ) THEN
C
C              We're out of tokens.  It's time to parse the
C              WHERE clause.
C
               STATE   =  WHERE

            ELSE IF ( TOKEN .EQ. TKCOMA ) THEN
C
C              It's time to look for another table name.
C
               STATE  =  FROM

            ELSE IF (  TOKEN .EQ.  TKKEY  )  THEN
C
C              The last table name in the FROM clause is followed by
C              a keyword.  SELECT, WHERE and ORDER are the only valid
C              possibilities.
C
               IF (       ( VALUES(TOKNUM) .NE. KWWHER )
     .              .AND. ( VALUES(TOKNUM) .NE. KWSEL  )
     .              .AND. ( VALUES(TOKNUM) .NE. KWORDR )  ) THEN
C
C                 We've got a keyword we don't want here.
C
                  ERROR  =  .TRUE.
                  ERRTYP =  'BAD_KEYWORD'
                  STATE  =  TERM

               ELSE
C
C                 Parse the WHERE clause.
C
                  STATE  =  WHERE

               END IF

            ELSE
C
C              We've got the wrong kind of token altogether.
C
               ERROR  =  .TRUE.
               ERRTYP =  'COMMA_OR_KEY_EXP'
               STATE  =  TERM

            END IF
C
C           STATE is a member of {FROM, WHERE, TERM}.
C

         ELSE IF ( STATE .EQ. SELKEY ) THEN
C
C           It's time to parse the SELECT clause.  We'll need to
C           locate the SELECT keyword.
C
            CALL ZZEKTLOC ( TKKEY,   KWSEL,  NTOKEN,  TOKENS,  VALUES,
     .                      TOKNUM,  FND                               )

            IF ( .NOT. FND ) THEN

               ERROR   =  .TRUE.
               ERRTYP  =  'SELECT_NOT_FOUND'
               STATE   =   TERM

            ELSE

               STATE   =  SELECT

            END IF

         ELSE IF ( STATE .EQ. SELECT ) THEN
C
C           We must see either the * token, the ALL keyword,
C           or an identifier here.  The identifier may be a lone
C           column name, or it may be a column name qualified by a
C           table name or alias.
C
C           For the moment, we don't support the * or ALL options.
C
            IF ( TOKEN .EQ. TKID ) THEN
C
C              We've found a name (as far as we can tell at this point).
C              Make sure we haven't exceeded the limit for SELECT
C              column names; if not, store the name string in the
C              encoded query, and save the descriptor until we've
C              figured out whether we're looking at a column name or
C              table name.
C
               NSEL  =  NSEL  +  1

               IF ( NSEL.GT. MAXSEL ) THEN

                  ERROR   =  .TRUE.
                  ERRTYP  =  'TOO_MANY_SEL_COLS'
                  STATE   = TERM

               ELSE

                  I       =   VALUES(TOKNUM)
                  B       =   CHBEGS(I)
                  E       =   CHENDS(I)
                  L       =   E  -  B   +  1
                  LXB     =   LXBEGS(TOKNUM)
                  LXE     =   LXENDS(TOKNUM)

                  CALL ZZEKINQC ( CHRBUF( B : E ),
     .                            L,
     .                            LXB,
     .                            LXE,
     .                            EQRYI,
     .                            EQRYC,
     .                            NAMDSC          )

C
C                 Add a place-holder value descriptor to reserve
C                 space for a table descriptor for this name.  If it
C                 turns out that the current name is a table name, we'll
C                 update this descriptor.
C
                  CALL CLEARI ( EQVDSZ, VALDSC )
                  VALDSC(EQDTYP)  =  CHR

                  DO J = 1, EQVDSZ
                     CALL APPNDI ( VALDSC(J), EQRYI )
                  END DO

C
C                 Update the SELECT column count in the encoded query.
C
                  CALL ZZEKWEQI ( 'NUM_SELECT_COLS', NSEL, EQRYI )

                  STATE  =  SELNAM

               END IF

            ELSE IF ( TOKEN .EQ. TKEOQ ) THEN

               ERROR  =  .TRUE.
               ERRTYP =  'MORE_TOKENS_EXP'
               STATE  =  TERM

            ELSE
C
C              We've got the wrong kind of token here.
C
               ERROR  =  .TRUE.
               ERRTYP =  'TABLE_OR_COLUMN_EXP'
               STATE  =  TERM

            END IF
C
C           State is a member of {SELNAM, TERM}.
C

         ELSE IF ( STATE .EQ. SELNAM ) THEN
C
C           We've seen a SELECT column name, or else the name
C           of a table qualifying a SELECT column name.
C
            IF ( TOKEN .EQ. TKEOQ ) THEN
C
C              The name we picked up was an unqualified column
C              name.  Append the saved name descriptor to the encoded
C              query.
C
               DO J = 1, EQVDSZ
                  CALL APPNDI ( NAMDSC(J), EQRYI )
               END DO

               STATE   =   TERM

            ELSE IF ( TOKEN .EQ. TKCOMA ) THEN
C
C              The name we picked up was an unqualified column
C              name.  Append the saved name descriptor to the encoded
C              query.  Another name should follow.
C
               DO J = 1, EQVDSZ
                  CALL APPNDI ( NAMDSC(J), EQRYI )
               END DO

               STATE  =  SELECT

            ELSE IF ( TOKEN .EQ. TKDOT ) THEN
C
C              The name we picked up was a table name or alias.  A
C              column name should follow.
C
               STATE  =  SELTAB

            ELSE IF ( TOKEN .EQ. TKKEY ) THEN
C
C              We have the last column name in the SELECT clause.
C
C              Append the saved name descriptor to the encoded
C              query.
C
               DO J = 1, EQVDSZ
                  CALL APPNDI ( NAMDSC(J), EQRYI )
               END DO

C
C              The last column name in the SELECT clause is followed by
C              a keyword.  FROM, WHERE and ORDER are the only valid
C              possibilities.
C
               IF (      ( VALUES(TOKNUM) .EQ. KWWHER )
     .              .OR. ( VALUES(TOKNUM) .EQ. KWFROM )
     .              .OR. ( VALUES(TOKNUM) .EQ. KWORDR )  ) THEN
C
C                 We're done with the SELECT clause.
C
                  STATE  =  TERM

               ELSE
C
C                 We've got a keyword we don't want here.
C
                  ERROR  =  .TRUE.
                  ERRTYP =  'BAD_KEYWORD'
                  STATE  =  TERM

               END IF

            ELSE
C
C              We've got the wrong kind of token here.
C
               ERROR  =  .TRUE.
               ERRTYP =  'BAD_TOKEN'
               STATE  =  TERM

            END IF
C
C           STATE is a member of {SELECT, SELTAB, TERM}.
C

         ELSE IF ( STATE .EQ. SELTAB ) THEN
C
C           We've picked up a qualifying table name for a SELECT
C           column.  We must see a column name here.
C
            IF ( TOKEN .EQ. TKID ) THEN
C
C              Update the place-holder table name descriptor in the
C              encoded query.
C
               CALL MOVEI ( NAMDSC,
     .                      EQVDSZ,
     .                      EQRYI(  CARDI(EQRYI) - EQVDSZ + 1  )   )

C
C              Add the column name to the character part of the
C              encoded query.
C
               I   =   VALUES(TOKNUM)
               B   =   CHBEGS(I)
               E   =   CHENDS(I)
               L   =   E  -  B   +  1
               LXB =   LXBEGS(TOKNUM)
               LXE =   LXENDS(TOKNUM)

               CALL ZZEKINQC ( CHRBUF( B : E ),
     .                         L,
     .                         LXB,
     .                         LXE,
     .                         EQRYI,
     .                         EQRYC,
     .                         COLDSC           )

C
C              Add the descriptor for the column name to the encoded
C              query.
C
               DO J = 1, EQVDSZ
                  CALL APPNDI ( COLDSC(J), EQRYI )
               END DO

               STATE  =  SELCOL

            ELSE IF ( TOKEN .EQ. TKEOQ ) THEN

               ERROR  =  .TRUE.
               ERRTYP =  'MORE_TOKENS_EXP'
               STATE  =  TERM

            ELSE

               ERROR  =  .TRUE.
               ERRTYP =  'COLUMN_EXP'
               STATE  =  TERM

            END IF
C
C           STATE is a member of {SELCOL, TERM}.
C

         ELSE IF ( STATE .EQ. SELCOL ) THEN
C
C           We've picked up a qualified column name.  At this point,
C           we should see a keyword, a comma, or the end of the
C           query.
C
            IF ( TOKEN .EQ. TKKEY ) THEN
C
C              The last column name in the SELECT clause is followed by
C              a keyword.  FROM, WHERE and ORDER are the only valid
C              possibilities.
C
               IF (      ( VALUES(TOKNUM) .EQ. KWWHER )
     .              .OR. ( VALUES(TOKNUM) .EQ. KWFROM )
     .              .OR. ( VALUES(TOKNUM) .EQ. KWORDR )  ) THEN
C
C                 We're done with the SELECT clause.
C
                  STATE  =  TERM

               ELSE
C
C                 We've got a keyword we don't want here.
C
                  ERROR  =  .TRUE.
                  ERRTYP =  'BAD_KEYWORD'
                  STATE  =  TERM

               END IF

            ELSE IF ( TOKEN .EQ. TKCOMA ) THEN
C
C              We expect another SELECT column.
C
               STATE  =  SELECT

            ELSE IF ( TOKEN .EQ. TKEOQ ) THEN
C
C              We're done with the SELECT clause.
C
               STATE  =  TERM

            ELSE

               ERROR  =  .TRUE.
               ERRTYP =  'COMMA_OR_KEY_EXP'
               STATE  =  TERM

            END IF
C
C           STATE is a member of {SELECT, TERM}.
C

         ELSE IF ( STATE .EQ. WHERE ) THEN
C
C           The WHERE clause is optional.  See whether we have one.  The
C           clause is started by a WHERE keyword.
C
            CALL ZZEKTLOC ( TKKEY,   KWWHER,  NTOKEN,  TOKENS,  VALUES,
     .                      TOKNUM,  FND                               )

            IF ( FND ) THEN
C
C              We're going to hand off the list of tokens that comprise
C              the WHERE clause of the query to a routine that will
C              parse the tokens and form a list of relational
C              constraints.  Once this is done, all we have to do here
C              is check the validity of the column names and the values
C              used in the constraints.
C
               CALL ZZEKNRML ( QUERY,
     .                         NTOKEN,
     .                         LXBEGS,
     .                         LXENDS,
     .                         TOKENS,
     .                         VALUES,
     .                         NUMVLS,
     .                         CHRBUF,
     .                         CHBEGS,
     .                         CHENDS,
     .                         EQRYI,
     .                         EQRYC,
     .                         EQRYD,
     .                         ERROR,
     .                         PRSERR )

               IF ( ERROR ) THEN

                  ERRTYP  =   'WHERE_ERROR'
                  STATE   =   TERM

               ELSE
C
C                 Parse the ORDER BY clause, if one is present.
C
                  STATE   =   ORDER

               END IF

            ELSE
C
C              Parse the ORDER BY clause, if one is present.
C
               STATE   =   ORDER

            END IF
C
C           STATE is a member of {ORDER, TERM}.
C

         ELSE IF ( STATE .EQ. ORDER ) THEN
C
C           The ORDER BY clause is optional.  See whether we have one.
C           The clause is started by an ORDER keyword.
C
            CALL ZZEKTLOC ( TKKEY,   KWORDR,  NTOKEN,  TOKENS,  VALUES,
     .                      TOKNUM,  FND                               )

            IF ( FND ) THEN
C
C              The BY keyword should follow the ORDER keyword.
C
               IF ( TOKNUM .LT. NTOKEN ) THEN

                  TOKNUM  =  TOKNUM + 1

                  IF (       (  TOKENS(TOKNUM) .EQ. TKKEY )
     .                 .AND. (  VALUES(TOKNUM) .EQ. KWBY  )  ) THEN
C
C                    We're ready to parse the ORDER BY clause.
C
                     STATE  =  ORDRBY

                  ELSE
C
C                    No BY keyword followed the ORDER keyword.
C
                     ERROR  =  .TRUE.
                     ERRTYP =  'BY_EXPECTED'
                     STATE  =  TERM

                  END IF

               ELSE
C
C                 We're out of tokens where we shouldn't be.
C
                  ERROR  =  .TRUE.
                  ERRTYP =  'BY_EXPECTED'
                  STATE  =  TERM

               END IF

            ELSE
C
C              We're ready to go on to the SELECT clause.
C
               STATE  =  SELKEY

            END IF
C
C           STATE is a member of {ORDRBY, SELKEY, TERM}.
C

         ELSE IF ( STATE .EQ. ORDRBY ) THEN
C
C           We must see a name in the order column list here.
C           The name may be a lone column name, or it may be a column
C           name qualified by a table name or alias.
C
            IF ( TOKEN .EQ. TKID ) THEN
C
C              We've found a name (as far as we can tell at this point).
C              Make sure we haven't exceeded the limit for order-by
C              column names; if not, store the name string in the
C              encoded query, and save the descriptor until we've
C              figured out whether we're looking at a column name or
C              table name.
C
               NORDER  =  NORDER  +  1

               IF ( NORDER .GT. MAXORD ) THEN

                  ERROR   =  .TRUE.
                  ERRTYP  =  'TOO_MANY_ORD_COLS'
                  STATE   = TERM

               ELSE

                  I       =   VALUES(TOKNUM)
                  B       =   CHBEGS(I)
                  E       =   CHENDS(I)
                  L       =   E  -  B   +  1
                  LXB     =   LXBEGS(TOKNUM)
                  LXE     =   LXENDS(TOKNUM)

                  CALL ZZEKINQC ( CHRBUF( B : E ),
     .                            L,
     .                            LXB,
     .                            LXE,
     .                            EQRYI,
     .                            EQRYC,
     .                            NAMDSC          )

C
C                 Add a place-holder value descriptor to reserve
C                 space for a table descriptor for this name.  If it
C                 turns out that the current name is a table name, we'll
C                 update this descriptor.
C
                  CALL CLEARI ( EQVDSZ, VALDSC )
                  VALDSC(EQDTYP)  =  CHR

                  DO J = 1, EQVDSZ
                     CALL APPNDI ( VALDSC(J), EQRYI )
                  END DO

C
C                 Update the order-by column count in the encoded query.
C
                  CALL ZZEKWEQI ( 'NUM_ORDERBY_COLS', NORDER, EQRYI )

                  STATE  =  ORDNAM

               END IF

            ELSE IF ( TOKEN .EQ. TKEOQ ) THEN

               ERROR  =  .TRUE.
               ERRTYP =  'MORE_TOKENS_EXP'
               STATE  =  TERM

            ELSE
C
C              We've got the wrong kind of token here.
C
               ERROR  =  .TRUE.
               ERRTYP =  'TABLE_OR_COLUMN_EXP'
               STATE  =  TERM

            END IF
C
C           State is a member of {ORDNAM, TERM}.
C

         ELSE IF ( STATE .EQ. ORDNAM ) THEN
C
C           We've seen an order-by column name, or else the name
C           of a table qualifying an order-by column name.
C
            IF ( TOKEN .EQ. TKEOQ ) THEN
C
C              The name we picked up was an unqualified column
C              name.  Append the saved name descriptor to the encoded
C              query.
C
               DO J = 1, EQVDSZ
                  CALL APPNDI ( NAMDSC(J), EQRYI )
               END DO

C
C              Since no ASCENDING or DESCENDING sense keyword was
C              supplied, append the default value ASCENDING to the
C              order-by column descriptor in the encoded query.
C
               CALL APPNDI ( EQASND, EQRYI )

C
C              We're done with the ORDER BY clause; go on to parse the
C              SELECT clause.
C
               STATE   =  SELKEY

            ELSE IF ( TOKEN .EQ. TKCOMA ) THEN
C
C              The name we picked up was an unqualified column
C              name.  Append the saved name descriptor to the encoded
C              query.  Another name should follow.
C
               DO J = 1, EQVDSZ
                  CALL APPNDI ( NAMDSC(J), EQRYI )
               END DO

C
C              Since no ASCENDING or DESCENDING sense keyword was
C              supplied, append the default value ASCENDING to the
C              order-by column descriptor in the encoded query.
C
               CALL APPNDI ( EQASND, EQRYI )

               STATE  = ORDRBY

            ELSE IF ( TOKEN .EQ. TKDOT ) THEN
C
C              The name we picked up was a table name or alias.  A
C              column name should follow.
C
               STATE = ORDTAB

            ELSE IF ( TOKEN .EQ. TKKEY ) THEN
C
C              We have a column name, which may be followed by a
C              keyword indicating the sense of the ordering, or may
C              be followed by a keyword starting a new clause.
C
C              Append the saved name descriptor to the encoded
C              query.
C
               DO J = 1, EQVDSZ
                  CALL APPNDI ( NAMDSC(J), EQRYI )
               END DO

C
C              Set the sense descriptor according to the keyword we've
C              picked up.  After this, we're ready to look for another
C              order-by column.
C
               IF ( VALUES(TOKNUM) .EQ. KWASND ) THEN

                  CALL APPNDI ( EQASND, EQRYI )

                  STATE = ORDSNS

               ELSE IF ( VALUES(TOKNUM) .EQ. KWDSND ) THEN

                  CALL APPNDI ( EQDSND, EQRYI )

                  STATE = ORDSNS

               ELSE IF (      ( VALUES(TOKNUM) .EQ. KWWHER )
     .                   .OR. ( VALUES(TOKNUM) .EQ. KWFROM )
     .                   .OR. ( VALUES(TOKNUM) .EQ. KWSEL  )  ) THEN

C
C                 Since no ASCENDING or DESCENDING sense keyword was
C                 supplied, append the default value ASCENDING to the
C                 order-by column descriptor in the encoded query.
C
                  CALL APPNDI ( EQASND, EQRYI )

C
C                 We're done with the ORDER BY clause.  Go on to
C                 parse the SELECT clause.
C
                  STATE  =  SELKEY

               ELSE
C
C                 We've got a keyword we don't want here.
C
                  ERROR  =  .TRUE.
                  ERRTYP =  'BAD_KEYWORD'
                  STATE  =  TERM

               END IF

            ELSE
C
C              We've got the wrong kind of token here.
C
               ERROR  =  .TRUE.
               ERRTYP =  'BAD_TOKEN'
               STATE  =  TERM

            END IF
C
C           STATE is a member of {ORDRBY, ORDTAB, ORDSNS, SELKEY, TERM}.
C

         ELSE IF ( STATE .EQ. ORDTAB ) THEN
C
C           We've picked up a qualifying table name for an order-by
C           column.  We must see a column name here.
C
            IF ( TOKEN .EQ. TKID ) THEN
C
C              Update the place-holder table name descriptor in the
C              encoded query.
C
               CALL MOVEI ( NAMDSC,
     .                      EQVDSZ,
     .                      EQRYI(  CARDI(EQRYI) - EQVDSZ + 1  )   )

C
C              Add the column name to the character part of the
C              encoded query.
C
               I   =   VALUES(TOKNUM)
               B   =   CHBEGS(I)
               E   =   CHENDS(I)
               L   =   E  -  B   +  1
               LXB =   LXBEGS(TOKNUM)
               LXE =   LXENDS(TOKNUM)

               CALL ZZEKINQC ( CHRBUF( B : E ),
     .                         L,
     .                         LXB,
     .                         LXE,
     .                         EQRYI,
     .                         EQRYC,
     .                         COLDSC           )

C
C              Add the descriptor for the column name to the encoded
C              query.
C
               DO J = 1, EQVDSZ
                  CALL APPNDI ( COLDSC(J), EQRYI )
               END DO

               STATE  =  ORDCOL

            ELSE IF ( TOKEN .EQ. TKEOQ ) THEN

               ERROR  =  .TRUE.
               ERRTYP =  'MORE_TOKENS_EXP'
               STATE  =  TERM

            ELSE

               ERROR  =  .TRUE.
               ERRTYP =  'COLUMN_EXP'
               STATE  =  TERM

            END IF
C
C           STATE is a member of {ORDCOL, TERM}.
C

         ELSE IF ( STATE .EQ. ORDCOL ) THEN
C
C           We've picked up a qualified column name.  At this point,
C           we should see a sense keyword, a comma, the end of the
C           query, or one of the FROM, SELECT, or WHERE keywords.
C
            IF ( TOKEN .EQ. TKKEY ) THEN

               IF ( VALUES(TOKNUM) .EQ. KWASND ) THEN
C
C                 The ASCENDING keyword has been supplied.  After this,
C                 look for another column.
C
                  CALL APPNDI ( EQASND, EQRYI )

                  STATE  =  ORDSNS

               ELSE IF ( VALUES(TOKNUM) .EQ. KWDSND ) THEN
C
C                 The DESCENDING keyword has been supplied.  After this,
C                 look for another column.
C
                  CALL APPNDI ( EQDSND, EQRYI )

                  STATE  =  ORDSNS

               ELSE IF (      ( VALUES(TOKNUM) .EQ. KWWHER )
     .                   .OR. ( VALUES(TOKNUM) .EQ. KWFROM )
     .                   .OR. ( VALUES(TOKNUM) .EQ. KWSEL  )  ) THEN
C
C                 We're done with the ORDER BY clause.  Go on to
C                 parse the SELECT clause.
C
                  STATE  =  SELKEY

               ELSE

                  ERROR  =  .TRUE.
                  ERRTYP =  'BAD_KEYWORD'
                  STATE  =  TERM

               END IF

            ELSE IF ( TOKEN .EQ. TKCOMA ) THEN
C
C              The ASCENDING keyword is implied.
C
               CALL APPNDI ( EQASND, EQRYI )

               STATE  =  ORDRBY

            ELSE IF ( TOKEN .EQ. TKEOQ ) THEN
C
C              The ASCENDING keyword is implied.
C
               CALL APPNDI ( EQASND, EQRYI )

C
C              We're done with the ORDER BY clause.  Parse the SELECT
C              clause.
C
               STATE  =  SELKEY

            ELSE

               ERROR  =  .TRUE.
               ERRTYP =  'COMMA_OR_KEY_EXP'
               STATE  =  TERM

            END IF
C
C           STATE is a member of {ORDRBY, ORDSNS, SELKEY, TERM}.
C

         ELSE IF ( STATE .EQ. ORDSNS ) THEN
C
C           We've picked up an order sense keyword.  At this point,
C           we should see comma or the end of the query, or one of the
C           FROM, SELECT, or WHERE keywords.
C
            IF ( TOKEN .EQ. TKCOMA ) THEN
C
C              We're ready to look for another column.
C
               STATE  =  ORDRBY

            ELSE IF ( TOKEN .EQ. TKEOQ ) THEN
C
C              We're done with the ORDER BY clause.  Parse the SELECT
C              clause.
C
               STATE  =  SELKEY

            ELSE IF ( TOKEN .EQ. TKKEY ) THEN

               IF (      ( VALUES(TOKNUM) .EQ. KWWHER )
     .              .OR. ( VALUES(TOKNUM) .EQ. KWFROM )
     .              .OR. ( VALUES(TOKNUM) .EQ. KWSEL  )  ) THEN
C
C                 We're done with the ORDER BY clause.  Go on to
C                 parse the SELECT clause.
C
                  STATE  =  SELKEY

               ELSE

                  ERROR  =  .TRUE.
                  ERRTYP =  'BAD_KEYWORD'
                  STATE  =  TERM

               END IF

            ELSE

               ERROR  =  .TRUE.
               ERRTYP =  'COMMA_EXP'
               STATE  =  TERM

            END IF
C
C           STATE is a member of {ORDRBY, SELKEY, TERM}.
C

         ELSE
C
C           Somehow, we've reached an invalid state.
C
            ERROR  = .TRUE.
            PRSERR = 'SPICE(BUG) -- Invalid state reached in EK parser.'
            STATE  =  TERM

         END IF
C
C           STATE is a member of {ORDRBY, TERM}.
C

      END DO
C
C     At this point, either an error has been detected, or the query
C     has been parsed, and the query is represented in encoded form
C     in the outputs EQRYI, EQRYC, and EQRYD.
C

C
C     We centralize construction of error messages in the following
C     section.
C
      IF ( ERROR ) THEN

         IF ( ERRTYP .EQ. 'FROM_NOT_FOUND' ) THEN

            PRSERR = 'Every query must contain a FROM clause. ' //
     .               'The FROM keyword was not found.'

         ELSE IF ( ERRTYP .EQ. 'SELECT_NOT_FOUND' ) THEN

            PRSERR = 'Every query must contain a SELECT clause. ' //
     .               'The SELECT keyword was not found.'

         ELSE IF ( ERRTYP .EQ. 'BY_EXPECTED' ) THEN

            PRSERR = 'The BY keyword was not found following the ' //
     .               'ORDER keyword.'

         ELSE IF ( ERRTYP .EQ. 'BAD_KEYWORD' ) THEN

            LXB    =  LXBEGS(TOKNUM)
            LXE    =  LXENDS(TOKNUM)
            PRSERR = 'Invalid keyword at location #. '  //
     .               'Actual token was: #'
            CALL REPMI ( PRSERR, '#', LXB,            PRSERR )
            CALL REPMC ( PRSERR, '#', QUERY(LXB:LXE), PRSERR )

         ELSE IF ( ERRTYP .EQ. 'TABLE_OR_COLUMN_EXP' ) THEN

            LXB    =  LXBEGS(TOKNUM)
            LXE    =  LXENDS(TOKNUM)
            PRSERR = 'Table or column name expected at location ' //
     .               '#. Actual token was: #'
            CALL REPMI ( PRSERR, '#', LXB,            PRSERR )
            CALL REPMC ( PRSERR, '#', QUERY(LXB:LXE), PRSERR )

         ELSE IF ( ERRTYP .EQ. 'TABLE_EXP' ) THEN

            LXB    =  LXBEGS(TOKNUM)
            LXE    =  LXENDS(TOKNUM)
            PRSERR = 'Table name expected at location #. '  //
     .               'Actual token was: #'
            CALL REPMI ( PRSERR, '#', LXB,            PRSERR )
            CALL REPMC ( PRSERR, '#', QUERY(LXB:LXE), PRSERR )

         ELSE IF ( ERRTYP .EQ. 'COLUMN_EXP' ) THEN

            LXB    =  LXBEGS(TOKNUM)
            LXE    =  LXENDS(TOKNUM)
            PRSERR = 'Column name expected at location #. '  //
     .               'Actual token was: #'
            CALL REPMI ( PRSERR, '#', LXB,            PRSERR )
            CALL REPMC ( PRSERR, '#', QUERY(LXB:LXE), PRSERR )

         ELSE IF ( ERRTYP .EQ. 'ALIAS_EXP' ) THEN

            LXB    =  LXBEGS(TOKNUM)
            LXE    =  LXENDS(TOKNUM)
            PRSERR = 'Table alias, comma, or keyword expected at ' //
     .               'location #. Actual token was: #'
            CALL REPMI ( PRSERR, '#', LXB,            PRSERR )
            CALL REPMC ( PRSERR, '#', QUERY(LXB:LXE), PRSERR )

         ELSE IF ( ERRTYP .EQ. 'COMMA_OR_KEY_EXP' ) THEN

            LXB    =  LXBEGS(TOKNUM)
            LXE    =  LXENDS(TOKNUM)
            PRSERR = 'Comma or keyword expected at ' //
     .               'location #. Actual token was: #'
            CALL REPMI ( PRSERR, '#', LXB,            PRSERR )
            CALL REPMC ( PRSERR, '#', QUERY(LXB:LXE), PRSERR )

         ELSE IF ( ERRTYP .EQ. 'COMMA_EXP' ) THEN

            LXB    =  LXBEGS(TOKNUM)
            LXE    =  LXENDS(TOKNUM)
            PRSERR = 'Comma expected at location #. Actual token was: #'
            CALL REPMI ( PRSERR, '#', LXB,            PRSERR )
            CALL REPMC ( PRSERR, '#', QUERY(LXB:LXE), PRSERR )

         ELSE IF ( ERRTYP .EQ. 'MORE_TOKENS_EXP' ) THEN

            PRSERR  =  'More tokens were expected in query.'

         ELSE IF ( ERRTYP .EQ. 'KEYWORD_EXP' ) THEN

            PRSERR = 'The keyword # was expected at location ' //
     .               '#. Actual token was: #'
            CALL REPMC ( PRSERR, '#', EXPKEY,         PRSERR )
            CALL REPMI ( PRSERR, '#', LXB,            PRSERR )
            CALL REPMC ( PRSERR, '#', QUERY(LXB:LXE), PRSERR )

         ELSE IF ( ERRTYP .EQ. 'BAD_TOKEN' ) THEN

            LXB    =  LXBEGS(TOKNUM)
            LXE    =  LXENDS(TOKNUM)
            PRSERR = 'Invalid token at location #. Token was: #'
            CALL REPMI ( PRSERR, '#', LXB,            PRSERR )
            CALL REPMC ( PRSERR, '#', QUERY(LXB:LXE), PRSERR )

         ELSE IF ( ERRTYP .EQ. 'TOO_MANY_TABLES' ) THEN

            PRSERR  =  'Number of tables in "FROM" clause exceeds ' //
     .                 'allowed maximum of #.'
            CALL REPMI  ( PRSERR, '#', MAXTAB, PRSERR )

         ELSE IF ( ERRTYP .EQ. 'TOO_MANY_ORD_COLS' ) THEN

            PRSERR  =  'Number of order-by columns exceeds allowed ' //
     .                 'maximum of #.'
            CALL REPMI  ( PRSERR, '#', MAXTAB, PRSERR )

         ELSE IF ( ERRTYP .EQ. 'TOO_MANY_SEL_COLS' ) THEN

            PRSERR  =  'Number of SELECT columns exceeds allowed ' //
     .                 'maximum of #.'
            CALL REPMI  ( PRSERR, '#', MAXSEL, PRSERR )

         ELSE IF ( ERRTYP .NE. 'WHERE_ERROR' ) THEN

            PRSERR  =  'SPICE(BUG)--Unrecognized error type.  Type ' //
     .                 'was #.'
            CALL REPMC ( PRSERR, '#', ERRTYP, PRSERR )

         END IF

      ELSE
C
C        Indicate that parsing is complete.
C
         CALL ZZEKWEQI ( 'PARSED', ITRUE, EQRYI )

      END IF

      CALL CHKOUT ( 'ZZEKPARS' )
      RETURN
      END

max_stars_repo_name: agforero/FTFramework

max_issues_repo_name: agforero/fortran-testing-framework

max_forks_repo_name: agforero/fortran-testing-framework


text:
*DECK DGAMMA
      DOUBLE PRECISION FUNCTION DGAMMA (X)
C***BEGIN PROLOGUE  DGAMMA
C***PURPOSE  Compute the complete Gamma function.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C7A
C***TYPE      DOUBLE PRECISION (GAMMA-S, DGAMMA-D, CGAMMA-C)
C***KEYWORDS  COMPLETE GAMMA FUNCTION, FNLIB, SPECIAL FUNCTIONS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C DGAMMA(X) calculates the double precision complete Gamma function
C for double precision argument X.
C
C Series for GAM        on the interval  0.          to  1.00000E+00
C                                        with weighted error   5.79E-32
C                                         log weighted error  31.24
C                               significant figures required  30.00
C                                    decimal places required  32.05
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  D1MACH, D9LGMC, DCSEVL, DGAMLM, INITDS, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770601  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890911  Removed unnecessary intrinsics.  (WRB)
C   890911  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   920618  Removed space from variable name.  (RWC, WRB)
C***END PROLOGUE  DGAMMA
      DOUBLE PRECISION X, GAMCS(42), DXREL, PI, SINPIY, SQ2PIL, XMAX,
     1  XMIN, Y, D9LGMC, DCSEVL, D1MACH
      LOGICAL FIRST
C
      SAVE GAMCS, PI, SQ2PIL, NGAM, XMIN, XMAX, DXREL, FIRST
      DATA GAMCS(  1) / +.8571195590 9893314219 2006239994 2 D-2      /
      DATA GAMCS(  2) / +.4415381324 8410067571 9131577165 2 D-2      /
      DATA GAMCS(  3) / +.5685043681 5993633786 3266458878 9 D-1      /
      DATA GAMCS(  4) / -.4219835396 4185605010 1250018662 4 D-2      /
      DATA GAMCS(  5) / +.1326808181 2124602205 8400679635 2 D-2      /
      DATA GAMCS(  6) / -.1893024529 7988804325 2394702388 6 D-3      /
      DATA GAMCS(  7) / +.3606925327 4412452565 7808221722 5 D-4      /
      DATA GAMCS(  8) / -.6056761904 4608642184 8554829036 5 D-5      /
      DATA GAMCS(  9) / +.1055829546 3022833447 3182350909 3 D-5      /
      DATA GAMCS( 10) / -.1811967365 5423840482 9185589116 6 D-6      /
      DATA GAMCS( 11) / +.3117724964 7153222777 9025459316 9 D-7      /
      DATA GAMCS( 12) / -.5354219639 0196871408 7408102434 7 D-8      /
      DATA GAMCS( 13) / +.9193275519 8595889468 8778682594 0 D-9      /
      DATA GAMCS( 14) / -.1577941280 2883397617 6742327395 3 D-9      /
      DATA GAMCS( 15) / +.2707980622 9349545432 6654043308 9 D-10     /
      DATA GAMCS( 16) / -.4646818653 8257301440 8166105893 3 D-11     /
      DATA GAMCS( 17) / +.7973350192 0074196564 6076717535 9 D-12     /
      DATA GAMCS( 18) / -.1368078209 8309160257 9949917230 9 D-12     /
      DATA GAMCS( 19) / +.2347319486 5638006572 3347177168 8 D-13     /
      DATA GAMCS( 20) / -.4027432614 9490669327 6657053469 9 D-14     /
      DATA GAMCS( 21) / +.6910051747 3721009121 3833697525 7 D-15     /
      DATA GAMCS( 22) / -.1185584500 2219929070 5238712619 2 D-15     /
      DATA GAMCS( 23) / +.2034148542 4963739552 0102605193 2 D-16     /
      DATA GAMCS( 24) / -.3490054341 7174058492 7401294910 8 D-17     /
      DATA GAMCS( 25) / +.5987993856 4853055671 3505106602 6 D-18     /
      DATA GAMCS( 26) / -.1027378057 8722280744 9006977843 1 D-18     /
      DATA GAMCS( 27) / +.1762702816 0605298249 4275966074 8 D-19     /
      DATA GAMCS( 28) / -.3024320653 7353062609 5877211204 2 D-20     /
      DATA GAMCS( 29) / +.5188914660 2183978397 1783355050 6 D-21     /
      DATA GAMCS( 30) / -.8902770842 4565766924 4925160106 6 D-22     /
      DATA GAMCS( 31) / +.1527474068 4933426022 7459689130 6 D-22     /
      DATA GAMCS( 32) / -.2620731256 1873629002 5732833279 9 D-23     /
      DATA GAMCS( 33) / +.4496464047 8305386703 3104657066 6 D-24     /
      DATA GAMCS( 34) / -.7714712731 3368779117 0390152533 3 D-25     /
      DATA GAMCS( 35) / +.1323635453 1260440364 8657271466 6 D-25     /
      DATA GAMCS( 36) / -.2270999412 9429288167 0231381333 3 D-26     /
      DATA GAMCS( 37) / +.3896418998 0039914493 2081663999 9 D-27     /
      DATA GAMCS( 38) / -.6685198115 1259533277 9212799999 9 D-28     /
      DATA GAMCS( 39) / +.1146998663 1400243843 4761386666 6 D-28     /
      DATA GAMCS( 40) / -.1967938586 3451346772 9510399999 9 D-29     /
      DATA GAMCS( 41) / +.3376448816 5853380903 3489066666 6 D-30     /
      DATA GAMCS( 42) / -.5793070335 7821357846 2549333333 3 D-31     /
      DATA PI / 3.1415926535 8979323846 2643383279 50 D0 /
      DATA SQ2PIL / 0.9189385332 0467274178 0329736405 62 D0 /
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  DGAMMA
      IF (FIRST) THEN
         NGAM = INITDS (GAMCS, 42, 0.1*REAL(D1MACH(3)) )
C
         CALL DGAMLM (XMIN, XMAX)
         DXREL = SQRT(D1MACH(4))
      ENDIF
      FIRST = .FALSE.
C
      Y = ABS(X)
      IF (Y.GT.10.D0) GO TO 50
C
C COMPUTE GAMMA(X) FOR -XBND .LE. X .LE. XBND.  REDUCE INTERVAL AND FIND
C GAMMA(1+Y) FOR 0.0 .LE. Y .LT. 1.0 FIRST OF ALL.
C
      N = X
      IF (X.LT.0.D0) N = N - 1
      Y = X - N
      N = N - 1
      DGAMMA = 0.9375D0 + DCSEVL (2.D0*Y-1.D0, GAMCS, NGAM)
      IF (N.EQ.0) RETURN
C
      IF (N.GT.0) GO TO 30
C
C COMPUTE GAMMA(X) FOR X .LT. 1.0
C
      N = -N
      IF (X .EQ. 0.D0) CALL XERMSG ('SLATEC', 'DGAMMA', 'X IS 0', 4, 2)
      IF (X .LT. 0.0 .AND. X+N-2 .EQ. 0.D0) CALL XERMSG ('SLATEC',
     +   'DGAMMA', 'X IS A NEGATIVE INTEGER', 4, 2)
      IF (X .LT. (-0.5D0) .AND. ABS((X-AINT(X-0.5D0))/X) .LT. DXREL)
     +   CALL XERMSG ('SLATEC', 'DGAMMA',
     +   'ANSWER LT HALF PRECISION BECAUSE X TOO NEAR NEGATIVE INTEGER',
     +   1, 1)
C
      DO 20 I=1,N
        DGAMMA = DGAMMA/(X+I-1 )
 20   CONTINUE
      RETURN
C
C GAMMA(X) FOR X .GE. 2.0 AND X .LE. 10.0
C
 30   DO 40 I=1,N
        DGAMMA = (Y+I) * DGAMMA
 40   CONTINUE
      RETURN
C
C GAMMA(X) FOR ABS(X) .GT. 10.0.  RECALL Y = ABS(X).
C
 50   IF (X .GT. XMAX) CALL XERMSG ('SLATEC', 'DGAMMA',
     +   'X SO BIG GAMMA OVERFLOWS', 3, 2)
C
      DGAMMA = 0.D0
      IF (X .LT. XMIN) CALL XERMSG ('SLATEC', 'DGAMMA',
     +   'X SO SMALL GAMMA UNDERFLOWS', 2, 1)
      IF (X.LT.XMIN) RETURN
C
      DGAMMA = EXP ((Y-0.5D0)*LOG(Y) - Y + SQ2PIL + D9LGMC(Y) )
      IF (X.GT.0.D0) RETURN
C
      IF (ABS((X-AINT(X-0.5D0))/X) .LT. DXREL) CALL XERMSG ('SLATEC',
     +   'DGAMMA',
     +   'ANSWER LT HALF PRECISION, X TOO NEAR NEGATIVE INTEGER', 1, 1)
C
      SINPIY = SIN (PI*Y)
      IF (SINPIY .EQ. 0.D0) CALL XERMSG ('SLATEC', 'DGAMMA',
     +   'X IS A NEGATIVE INTEGER', 4, 2)
C
      DGAMMA = -PI/(Y*SINPIY*DGAMMA)
C
      RETURN
      END

ext: f


      INTEGER FUNCTION LA_WS_GELS( VER, M, N, NRHS, TRANS )
!
!  -- LAPACK95 interface driver routine (version 3.0) --
!     UNI-C, Denmark; Univ. of Tennessee, USA; NAG Ltd., UK
!     September, 2000
!
!   .. USE STATEMENTS ..
      USE LA_AUXMOD, ONLY: LSAME
      USE F77_LAPACK, ONLY: ILAENV_F77 => LA_ILAENV
!     .. IMPLICIT STATEMENT ..
      IMPLICIT NONE
!     .. SCALAR ARGUMENTS ..
      CHARACTER(LEN=1), INTENT(IN) :: TRANS, VER
      INTEGER, INTENT(IN) :: M, N, NRHS
!     .. PARAMETERS ..
      CHARACTER(LEN=5), PARAMETER :: NAME1='GEQRF', NAME2='ORMQR', NAME3='ORMLQ', NAME4='GELQF'
!     .. LOCAL SCALARS ..
      INTEGER :: NB, MN
      LOGICAL :: TPSD
!     .. INTRINSIC FUNCTIONS ..
      INTRINSIC MAX, MIN
!     .. EXECUTABLE STATEMENTS ..
      MN = MIN( M, N )
      IF( LSAME( TRANS, 'N' ) )THEN
        TPSD = .FALSE.
      ELSE
        TPSD = .TRUE.
      ENDIF
      IF( M.GE.N ) THEN
        NB = ILAENV_F77( 1, VER//NAME1, ' ', M, N, -1, -1 )
        IF( TPSD ) THEN
          NB = MAX( NB,ILAENV_F77( 1,VER//NAME2,'LN',M,NRHS,N,-1 ) )
        ELSE
          NB = MAX( NB, ILAENV_F77( 1,VER//NAME2,'LT',M,NRHS,N,-1 ) )
        END IF
      ELSE
        NB = ILAENV_F77( 1, VER//NAME4, ' ', M, N, -1, -1 )
        IF( TPSD ) THEN
          NB = MAX( NB, ILAENV_F77( 1,VER//NAME3,'LT',N,NRHS,M,-1 ) )
        ELSE
          NB = MAX( NB, ILAENV_F77( 1,VER//NAME3,'LN',N,NRHS,M,-1 ) )
        END IF
      END IF
      LA_WS_GELS = MN + MAX( M, N, NRHS )*NB
      END FUNCTION LA_WS_GELS


text:
module params

use grid, only: nzm

implicit none

!   Constants:

real, parameter :: cp = 1004.             ! Specific heat of air, J/kg/K
real, parameter :: ggr = 9.81             ! Gravity acceleration, m/s2
real, parameter :: lcond = 2.5104e+06     ! Latent heat of condensation, J/kg
real, parameter :: lfus = 0.3336e+06      ! Latent heat of fusion, J/kg
real, parameter :: lsub = 2.8440e+06      ! Latent heat of sublimation, J/kg
real, parameter :: rv = 461.              ! Gas constant for water vapor, J/kg/K
real, parameter :: rgas = 287.            ! Gas constant for dry air, J/kg/K
real, parameter :: diffelq = 2.21e-05     ! Diffusivity of water vapor, m2/s
real, parameter :: therco = 2.40e-02      ! Thermal conductivity of air, J/m/s/K
real, parameter :: muelq = 1.717e-05      ! Dynamic viscosity of air

real, parameter :: fac_cond = lcond/cp
real, parameter :: fac_fus = lfus/cp
real, parameter :: fac_sub = lsub/cp

real, parameter ::  pi = 3.141592653589793

!
! internally set parameters:

real   epsv     ! = (1-eps)/eps, where eps= Rv/Ra, or =0. if dosmoke=.true.
logical:: dosubsidence = .false.
real fcorz      ! Vertical Coriolis parameter
real coszrs
real salt_factor ! correction factor for water vapor saturation over sea-water

!bloss: options to allow a larger number of substeps and to keep a margin of safety away from the CFL limit
integer:: ncycle_max = 4  ! maximum number of subcycling within dt
integer:: ncycle_min = 1  ! minimum number of subcycling within dt
integer:: ncycle0 = 1     ! number of subcycles for first timestep of simulation.
real :: cfl_safety_factor = 1.5  ! ensure that CFL < CFL_stability_limit / cfl_safety_factor

!----------------------------------------------
! Parameters set by PARAMETERS namelist:
! Initialized to default values.
!----------------------------------------------

real:: ug = 0.        ! Velocity of the Domain's drift in x direction
real:: vg	= 0.        ! Velocity of the Domain's drift in y direction
real:: fcor = -999.   ! Coriolis parameter
real:: longitude0 = 0.    ! latitude of the domain's center
real:: latitude0  = 0.    ! longitude of the domain's center
real:: nxco2 = 1.         ! factor to modify co2 concentration
logical:: doradlat = .false.
logical:: doradlon = .false.

real(8):: tabs_s =0.	! surface temperature,K
real:: delta_sst = 0.   ! amplitude of sin-pattern of sst about tabs_s (ocean_type=1)
real:: depth_slab_ocean = 2. ! thickness of the slab-ocean (m)
real:: Szero = 0.  ! mean ocean transport (W/m2)
real:: deltaS = 0. ! amplitude of linear variation of ocean transport (W/m2)
real:: timesimpleocean = 0. ! time to start simple ocean

real::   fluxt0 =0.  ! surface sensible flux, Km/s
real::   fluxq0 =0.  ! surface latent flux, m/s
real::   tau0   =0.  ! surface stress, m2/s2
real::   z0     =0.035	! roughness length
real::   soil_wetness =1.! wetness coeff for soil (from 0 to 1.)
integer:: ocean_type =0 ! type of SST forcing
logical:: cem =.false.    ! flag for Cloud Ensemble Model
logical:: les =.false.    ! flag for Large-Eddy Simulation
logical:: ocean =.false.  ! flag indicating that surface is water
real :: min_anisotropy = 16.0
logical:: land =.false.   ! flag indicating that surface is land
logical:: sfc_flx_fxd =.false. ! surface sensible flux is fixed
logical:: sfc_tau_fxd =.false.! surface drag is fixed

real:: timelargescale =0. ! time to start large-scale forcing

! nudging boundaries (between z1 and z2, where z2 > z1):
real:: nudging_uv_z1 =-1., nudging_uv_z2 = 1000000.
real:: nudging_t_z1 =-1., nudging_t_z2 = 1000000.
real:: nudging_q_z1 =-1., nudging_q_z2 = 1000000.
real:: tauls = 99999999.    ! nudging-to-large-scaler-profile time-scale
real:: tautqls = 99999999.! nudging-to-large-scaler-profile time-scale for scalars

logical:: dodamping = .false.
logical:: doupperbound = .false.
logical:: docloud = .false.
logical:: doprecip = .false.
logical:: dolongwave = .false.
logical:: doshortwave = .false.
logical:: doheldsuarez = .false.
logical:: dosgs = .false.
logical:: docoriolis = .false.
logical:: docoriolisz = .false.
logical:: dofplane = .true.
logical:: dosurface = .false.
logical:: dolargescale = .false.
logical:: doradforcing = .false.
logical:: dosfcforcing = .false.
logical:: doradsimple = .false.
logical:: donudging_uv = .false.
logical:: donudging_tq = .false.
logical:: donudging_t = .false.
logical:: donudging_q = .false.
logical:: doensemble = .false.
logical:: dowallx = .false.
logical:: dowally = .false.
logical:: docolumn = .false.
logical:: docup = .false.
logical:: doperpetual = .false.
logical:: doseasons = .false.
logical:: doequinox = .false.  ! Noah added
logical:: dopython = .false. ! added by NDB
logical:: usepython = .false. ! added by NDB
! Controls whether to use the SGS scheme for the thermodynamic variables
! turn off if using explicit parametrizations of surface processes
logical:: dosgsthermo = .true. ! NDB
integer:: npython = 1 ! added by NDB
logical:: doradhomo = .false.
logical:: dosfchomo = .false.
logical:: dossthomo = .false.
logical:: dodynamicocean = .false.
logical:: dosolarconstant = .false.
logical:: dotracers = .false.
logical:: dosmoke = .false.
logical:: notracegases = .false.
logical:: doseawater = .true. !bloss(Set UW default to true!!) .false.
real :: khyp = 1.0e16 ! noah: hyper diffusion coefficient for coarse resolution

! Specify solar constant and zenith angle for perpetual insolation.
! Based onn Tompkins and Graig (1998)
! Note that if doperpetual=.true. and dosolarconstant=.false.
! the insolation will be set to the daily-averaged value on day0.
real:: solar_constant = 685. ! solar constant (in W/m2)
real:: zenith_angle = 51.7   ! zenith angle (in degrees)

integer:: nensemble =0   ! the number of subensemble set of perturbations
integer:: perturb_type  = 0 ! type of initial noise in setperturb()

! Initial bubble parameters. Activated when perturb_type = 2
  real:: bubble_x0 = 0.
  real:: bubble_y0 = 0.
  real:: bubble_z0 = 0.
  real:: bubble_radius_hor = 0.
  real:: bubble_radius_ver = 0.
  real:: bubble_dtemp = 0.
  real:: bubble_dq = 0.

! Option for simple treatment of aerosol radiative effect in RRTMG by Tak Yamaguchi
logical:: doradaerosimple = .false.

! Option for writing restart file only at end of simulation
logical:: dorestart_last_only = .false.

end module params

max_stars_repo_name: kbren/uwnet

max_issues_repo_name: kbren/uwnet

max_forks_repo_name: kbren/uwnet


text:
great_ne(cc1,m1).
great_ne(z1,ii1).
great_ne(ff1,i1).
great_ne(cc1,f1).
great_ne(kk1,w1).
great_ne(jj1,aa1).
great_ne(hh1,v1).
great_ne(u1,f1).
great_ne(p1,hh1).
great_ne(ee1,i1).
great_ne(cc1,ff1).
great_ne(jj1,k1).
great_ne(k1,x1).
great_ne(t1,b1).
great_ne(bb1,m1).
great_ne(ff1,c1).
great_ne(bb1,k1).
great_ne(ee1,v1).
great_ne(kk1,y1).
great_ne(bb1,b1).
great_ne(hh1,h1).
great_ne(ii1,ff1).
great_ne(k1,c1).
great_ne(hh1,dd1).
great_ne(f1,ff1).
great_ne(kk1,dd1).
great_ne(bb1,w1).
great_ne(u1,bb1).
great_ne(u1,ee1).
great_ne(m1,b1).
great_ne(y1,c1).
great_ne(m1,ff1).
great_ne(p1,w1).
great_ne(v1,ii1).
great_ne(z1,kk1).
great_ne(q1,jj1).
great_ne(ee1,ff1).
great_ne(cc1,dd1).
great_ne(hh1,y1).
great_ne(ee1,x1).
great_ne(x1,a1).
great_ne(kk1,h1).
great_ne(y1,h1).
great_ne(dd1,x1).
great_ne(cc1,v1).
great_ne(u1,aa1).
great_ne(t1,bb1).
great_ne(q1,hh1).
great_ne(k1,i1).
great_ne(q1,z1).
great_ne(ee1,m1).
great_ne(k1,y1).
great_ne(bb1,ii1).
great_ne(q1,u1).
great_ne(p1,ii1).
great_ne(aa1,bb1).
great_ne(p1,ff1).
great_ne(t1,ii1).
great_ne(k1,ff1).
great_ne(u1,k1).
great_ne(aa1,hh1).
great_ne(k1,b1).
great_ne(aa1,k1).
great_ne(q1,m1).
great_ne(t1,ee1).
great_ne(cc1,k1).
great_ne(q1,x1).
great_ne(q1,aa1).
great_ne(v1,b1).
great_ne(jj1,ee1).
great_ne(jj1,h1).
great_ne(jj1,ff1).
great_ne(kk1,b1).
great_ne(p1,dd1).
great_ne(x1,ff1).
great_ne(z1,hh1).
great_ne(t1,dd1).
great_ne(x1,v1).
great_ne(x1,ii1).
great_ne(v1,w1).
great_ne(w1,a1).
great_ne(cc1,u1).
great_ne(q1,ii1).
great_ne(m1,f1).
great_ne(p1,aa1).
great_ne(kk1,hh1).
great_ne(ii1,f1).
great_ne(aa1,f1).
great_ne(ii1,c1).
great_ne(t1,hh1).
great_ne(p1,y1).
great_ne(ee1,hh1).
great_ne(q1,i1).
great_ne(bb1,c1).
great_ne(hh1,i1).
great_ne(hh1,f1).
great_ne(t1,jj1).
great_ne(m1,i1).
great_ne(p1,i1).
great_ne(cc1,w1).
great_ne(z1,bb1).
great_ne(aa1,w1).
great_ne(u1,jj1).
great_ne(q1,w1).
great_ne(v1,h1).
great_ne(cc1,bb1).
great_ne(dd1,c1).
great_ne(p1,x1).
great_ne(bb1,x1).
great_ne(ii1,i1).
great_ne(u1,y1).
great_ne(k1,a1).
great_ne(y1,ff1).
great_ne(ee1,k1).
great_ne(z1,t1).
great_ne(jj1,w1).
great_ne(hh1,k1).
great_ne(ee1,a1).
great_ne(dd1,m1).
great_ne(hh1,bb1).
great_ne(hh1,c1).
great_ne(p1,kk1).
great_ne(ff1,a1).
great_ne(cc1,aa1).
great_ne(q1,cc1).
great_ne(b1,ff1).
great_ne(v1,y1).
great_ne(jj1,bb1).
great_ne(cc1,a1).
great_ne(z1,w1).
great_ne(aa1,c1).
great_ne(jj1,v1).
great_ne(kk1,f1).
great_ne(ee1,w1).
great_ne(k1,h1).
great_ne(w1,ff1).
great_ne(f1,i1).
great_ne(z1,cc1).
great_ne(y1,b1).
great_ne(w1,f1).
great_ne(aa1,ee1).
great_ne(p1,k1).
great_ne(x1,i1).
great_ne(x1,h1).
great_ne(jj1,ii1).
great_ne(dd1,f1).
great_ne(k1,f1).
great_ne(ee1,bb1).
great_ne(z1,u1).
great_ne(aa1,x1).
great_ne(cc1,ee1).
great_ne(m1,c1).
great_ne(m1,ii1).
great_ne(ii1,b1).
great_ne(v1,f1).
great_ne(dd1,ff1).
great_ne(cc1,i1).
great_ne(q1,dd1).
great_ne(u1,m1).
great_ne(w1,i1).
great_ne(cc1,h1).
great_ne(aa1,m1).
great_ne(x1,w1).
great_ne(cc1,kk1).
great_ne(aa1,ii1).
great_ne(q1,k1).
great_ne(u1,dd1).
great_ne(kk1,i1).
great_ne(t1,kk1).
great_ne(p1,jj1).
great_ne(cc1,ii1).
great_ne(hh1,ii1).
great_ne(p1,t1).
great_ne(p1,ee1).
great_ne(q1,y1).
great_ne(y1,w1).
great_ne(v1,ff1).
great_ne(bb1,h1).
great_ne(dd1,b1).
great_ne(aa1,v1).
great_ne(p1,v1).
great_ne(u1,ff1).
great_ne(bb1,ff1).
great_ne(kk1,ff1).
great_ne(jj1,kk1).
great_ne(q1,b1).
great_ne(z1,i1).
great_ne(aa1,ff1).
great_ne(aa1,b1).
great_ne(u1,hh1).
great_ne(u1,w1).
great_ne(jj1,hh1).
great_ne(q1,t1).
great_ne(aa1,dd1).
great_ne(b1,c1).
great_ne(y1,i1).
great_ne(p1,bb1).
great_ne(t1,f1).
great_ne(kk1,x1).
great_ne(aa1,kk1).
great_ne(dd1,ii1).
great_ne(t1,v1).
great_ne(kk1,bb1).
great_ne(z1,ff1).
great_ne(z1,jj1).
great_ne(cc1,c1).
great_ne(z1,v1).
great_ne(w1,h1).
great_ne(dd1,y1).
great_ne(jj1,b1).
great_ne(z1,aa1).
great_ne(kk1,ii1).
great_ne(q1,v1).
great_ne(cc1,x1).
great_ne(jj1,y1).
great_ne(y1,a1).
great_ne(m1,v1).
great_ne(z1,y1).
great_ne(q1,ff1).
great_ne(bb1,f1).
great_ne(w1,b1).
great_ne(q1,f1).
great_ne(ee1,b1).
great_ne(k1,w1).
great_ne(u1,ii1).
great_ne(z1,a1).
great_ne(t1,c1).
great_ne(z1,p1).
great_ne(hh1,b1).
great_ne(aa1,a1).
great_ne(t1,aa1).
great_ne(ff1,b1).
great_ne(y1,bb1).
great_ne(ii1,k1).
great_ne(w1,cc1).
great_ne(bb1,ee1).
great_ne(jj1,z1).
great_ne(a1,b1).
great_ne(i1,q1).
great_ne(dd1,aa1).
great_ne(ee1,z1).
great_ne(b1,kk1).
great_ne(v1,x1).
great_ne(dd1,p1).
great_ne(ee1,cc1).
great_ne(w1,m1).
great_ne(x1,cc1).
great_ne(c1,cc1).
great_ne(a1,t1).
great_ne(i1,cc1).
great_ne(ii1,v1).
great_ne(hh1,q1).
great_ne(ff1,m1).
great_ne(a1,w1).
great_ne(f1,y1).
great_ne(y1,ii1).
great_ne(k1,t1).
great_ne(kk1,cc1).
great_ne(i1,p1).
great_ne(aa1,q1).
great_ne(b1,z1).
great_ne(m1,bb1).
great_ne(y1,u1).
great_ne(k1,dd1).
great_ne(b1,ee1).
great_ne(a1,q1).
great_ne(b1,m1).
great_ne(bb1,hh1).
great_ne(a1,f1).
great_ne(hh1,jj1).
great_ne(h1,dd1).
great_ne(x1,bb1).
great_ne(ii1,bb1).
great_ne(y1,q1).
great_ne(c1,w1).
great_ne(ff1,v1).
great_ne(f1,m1).
great_ne(ii1,kk1).
great_ne(y1,cc1).
great_ne(dd1,jj1).
great_ne(hh1,u1).
great_ne(ff1,f1).
great_ne(ii1,q1).
great_ne(h1,ff1).
great_ne(k1,jj1).
great_ne(y1,aa1).
great_ne(b1,x1).
great_ne(hh1,kk1).
great_ne(bb1,dd1).
great_ne(i1,m1).
great_ne(aa1,z1).
great_ne(b1,hh1).
great_ne(x1,hh1).
great_ne(y1,hh1).
great_ne(i1,bb1).
great_ne(a1,k1).
great_ne(c1,f1).
great_ne(f1,kk1).
great_ne(c1,ee1).
great_ne(w1,p1).
great_ne(a1,jj1).
great_ne(c1,ii1).
great_ne(a1,bb1).
great_ne(w1,aa1).
great_ne(c1,k1).
great_ne(w1,u1).
great_ne(f1,t1).
great_ne(v1,q1).
great_ne(m1,q1).
great_ne(w1,t1).
great_ne(v1,dd1).
great_ne(y1,p1).
great_ne(h1,m1).
great_ne(a1,v1).

max_stars_repo_name: manoelfranca/cilppp

max_issues_repo_name: manoelfranca/cilppp

max_forks_repo_name: manoelfranca/cilppp


! { dg-do run }
! PR48615 Invalid UP/DOWN rounding with E and ES descriptors
! Test case provided by Thomas Henlich.
program pr48615
    call checkfmt("(RU,F17.0)", 2.5,     "               3.")
    call checkfmt("(RU,-1P,F17.1)", 2.5, "              0.3")
    call checkfmt("(RU,E17.1)", 2.5,     "          0.3E+01")
    call checkfmt("(RU,1P,E17.0)", 2.5,  "           3.E+00")
    call checkfmt("(RU,ES17.0)", 2.5,    "           3.E+00")
    call checkfmt("(RU,EN17.0)", 2.5,    "           3.E+00")
    call checkfmt("(RU,F2.0)",      2.0,  "2.")
    call checkfmt("(RU,F6.4)",      2.0,  "2.0000")
    call checkfmt("(RU,1P,E6.0E2)", 2.0,  "2.E+00")
    call checkfmt("(RU,1P,E7.1E2)", 2.5,  "2.5E+00")
    call checkfmt("(RU,1P,E10.4E2)", 2.5,  "2.5000E+00")
    call checkfmt("(RU,1P,G6.0E2)", 2.0,  "2.E+00")
    call checkfmt("(RU,1P,G10.4E2)", 2.3456e5,  "2.3456E+05")

    call checkfmt("(RC,G10.2)", 99.5,   "  0.10E+03") ! pr59774
    call checkfmt("(RC,G10.2)", 995.,   "  0.10E+04") ! pr59774
    call checkfmt("(RC,G10.3)", 999.5,  " 0.100E+04") ! pr59774
    call checkfmt("(RC,G10.3)", 9995.,  " 0.100E+05") ! pr59774
    call checkfmt("(RU,G10.2)", .099,   "  0.10    ") ! pr59774
    call checkfmt("(RC,G10.1)", .095,   "   0.1    ") ! pr59774
    call checkfmt("(RU,G10.3)", .0999,  " 0.100    ") ! pr59774
    call checkfmt("(RC,G10.2)", .0995,  "  0.10    ") ! pr59774

    call checkfmt("(RU,G9.3)",  891.1,  " 892.")      ! pr59836
    call checkfmt("(RD,G9.3)", -891.1,  "-892.")      ! pr59836

    call checkfmt("(RU,F6.4)",     0.00006,  "0.0001")! 0.
    call checkfmt("(RU,F5.3)",     0.0007,  "0.001")  ! 0.
    call checkfmt("(RU,F4.2)",     0.008,  "0.01")    ! 0.
    call checkfmt("(RU,F3.1)",     0.09,  "0.1")      ! 0.

    call checkfmt("(RU,F2.0)",     0.09,  "1.")       ! 0.
    call checkfmt("(RD,F3.0)",     -0.09,  "-1.")     ! -0.
    call checkfmt("(RU,F2.0)",     0.9,  "1.")        ! pr59836
    call checkfmt("(RC,F2.0)",     0.4,  "0.")        ! pr59836
    call checkfmt("(RC,F2.0)",     0.5,  "1.")        ! pr59836
    call checkfmt("(RC,F2.0)",     0.6,  "1.")        ! pr59836
    call checkfmt("(RD,F3.0)",     -0.9,  "-1.")      ! pr59836
    call checkfmt("(RC,F3.0)",     -0.4,  "-0.")      ! pr59836
    call checkfmt("(RC,F3.0)",     -0.5,  "-1.")      ! pr59836
    call checkfmt("(RC,F3.0)",     -0.6,  "-1.")      ! pr59836
    call checkfmt("(RU,F2.0)",      2.0,  "2.")       ! 3.
    call checkfmt("(RD,F3.0)",     -2.0,  "-2.")      ! -3.
    call checkfmt("(RU,F6.4)",      2.0,  "2.0000")   ! 2.0001
    call checkfmt("(RD,F7.4)",     -2.0,  "-2.0000")  ! -2.0001
    call checkfmt("(RU,1P,E6.0E2)", 2.0,  "2.E+00")   ! 3.E+00
    call checkfmt("(RD,1P,E7.0E2)", -2.0,  "-2.E+00") ! -3.E+00
    call checkfmt("(RU,1P,E7.1E2)", 2.5,  "2.5E+00")  ! 2.6E+00
    call checkfmt("(RD,1P,E8.1E2)", -2.5,  "-2.5E+00") ! -2.6E+00
    call checkfmt("(RU,1P,E10.4E2)", 2.5,  "2.5000E+00") ! 2.5001E+00
    call checkfmt("(RD,1P,E11.4E2)", -2.5,  "-2.5000E+00") ! -2.5001E+00
    call checkfmt("(RU,1P,G6.0E2)", 2.0,  "2.E+00")   ! 3.E+00
    call checkfmt("(RD,1P,G7.0E2)", -2.0,  "-2.E+00") ! -3.E+00
    call checkfmt("(RU,1P,G10.4E2)", 2.3456e5,  "2.3456E+05") ! 2.3457E+05
    call checkfmt("(RD,1P,G11.4E2)", -2.3456e5,  "-2.3456E+05") ! -2.3457E+05

    call checkfmt("(RD,F17.0)", 2.5,     "               2.")
    call checkfmt("(RD,-1P,F17.1)", 2.5, "              0.2")
    call checkfmt("(RD,E17.1)", 2.5,     "          0.2E+01")
    call checkfmt("(RD,1P,E17.0)", 2.5,  "           2.E+00")
    call checkfmt("(RD,ES17.0)", 2.5,    "           2.E+00")
    call checkfmt("(RD,EN17.0)", 2.5,    "           2.E+00")

    call checkfmt("(RC,F17.0)", 2.5,     "               3.")
    call checkfmt("(RC,-1P,F17.1)", 2.5, "              0.3")
    call checkfmt("(RC,E17.1)", 2.5,     "          0.3E+01")
    call checkfmt("(RC,1P,E17.0)", 2.5,  "           3.E+00")
    call checkfmt("(RC,ES17.0)", 2.5,    "           3.E+00")
    call checkfmt("(RC,EN17.0)", 2.5,    "           3.E+00")

    call checkfmt("(RN,F17.0)", 2.5,     "               2.")
    call checkfmt("(RN,-1P,F17.1)", 2.5, "              0.2")
    call checkfmt("(RN,E17.1)", 2.5,     "          0.2E+01")
    call checkfmt("(RN,1P,E17.0)", 2.5,  "           2.E+00")
    call checkfmt("(RN,ES17.0)", 2.5,    "           2.E+00")
    call checkfmt("(RN,EN17.0)", 2.5,    "           2.E+00")

    call checkfmt("(RZ,F17.0)", 2.5,     "               2.")
    call checkfmt("(RZ,-1P,F17.1)", 2.5, "              0.2")
    call checkfmt("(RZ,E17.1)", 2.5,     "          0.2E+01")
    call checkfmt("(RZ,1P,E17.0)", 2.5,  "           2.E+00")
    call checkfmt("(RZ,ES17.0)", 2.5,    "           2.E+00")
    call checkfmt("(RZ,EN17.0)", 2.5,    "           2.E+00")

    call checkfmt("(RZ,F17.0)", -2.5,     "              -2.")
    call checkfmt("(RZ,-1P,F17.1)", -2.5, "             -0.2")
    call checkfmt("(RZ,E17.1)", -2.5,     "         -0.2E+01")
    call checkfmt("(RZ,1P,E17.0)", -2.5,  "          -2.E+00")
    call checkfmt("(RZ,ES17.0)", -2.5,    "          -2.E+00")
    call checkfmt("(RZ,EN17.0)", -2.5,    "          -2.E+00")

    call checkfmt("(RN,F17.0)", -2.5,     "              -2.")
    call checkfmt("(RN,-1P,F17.1)", -2.5, "             -0.2")
    call checkfmt("(RN,E17.1)", -2.5,     "         -0.2E+01")
    call checkfmt("(RN,1P,E17.0)", -2.5,  "          -2.E+00")
    call checkfmt("(RN,ES17.0)", -2.5,    "          -2.E+00")
    call checkfmt("(RN,EN17.0)", -2.5,    "          -2.E+00")

    call checkfmt("(RC,F17.0)", -2.5,     "              -3.")
    call checkfmt("(RC,-1P,F17.1)", -2.5, "             -0.3")
    call checkfmt("(RC,E17.1)", -2.5,     "         -0.3E+01")
    call checkfmt("(RC,1P,E17.0)", -2.5,  "          -3.E+00")
    call checkfmt("(RC,ES17.0)", -2.5,    "          -3.E+00")
    call checkfmt("(RC,EN17.0)", -2.5,    "          -3.E+00")

    call checkfmt("(RU,E17.1)", nearest(2.0, 1.0),     "          0.3E+01")
    call checkfmt("(RD,E17.1)", nearest(3.0, -1.0),    "          0.2E+01")

contains
    subroutine checkfmt(fmt, x, cmp)
        character(len=*), intent(in) :: fmt
        real, intent(in) :: x
        character(len=*), intent(in) :: cmp
        character(len=20) :: s

        write(s, fmt) x
        if (s /= cmp) call abort
        !if (s /= cmp) print "(a,1x,a,' expected: ',1x)", fmt, s, cmp
    end subroutine
end program


text:
        subroutine verif_fcst_pt_3d(i4time_sys,a9time,laps_cycle_time,
     1                  ni,nj,
     1                  nk,
     1                  maxsta,max_obs,
     1                  r_missing_data,
     1                  model_verif_intvl,
     1                  n_fcst_times,
     1                  j_status)

        include 'barnesob.inc'
        include 'windparms.inc'
        include 'tempobs.inc'

        real var_anal_3d(ni,nj,nk)
        real var_fcst_3d(ni,nj,nk)
        real lat(ni,nj)
        real lon(ni,nj)
        real topo(ni,nj)
        real rlaps_land_frac(ni,nj)

        parameter (NTMIN=-1) ! read from namelist file?
        parameter (NTMAX=+1)

!       For call to get_wind_3d_obs
        real u_mdl_bkg_4d(ni,nj,nk,NTMIN:NTMAX)
        real v_mdl_bkg_4d(ni,nj,nk,NTMIN:NTMAX)
        real grid_laps_u(ni,nj,nk)
        real grid_laps_v(ni,nj,nk)
        real grid_laps_wt(ni,nj,nk)
        real heights_3d(ni,nj,nk)
        real heights_1d(nk)
        real pres_3d(ni,nj,nk)
        type (barnesob) :: obs_point(maxsta)

        real k_to_c

        integer       maxbgmodels
        parameter     (maxbgmodels=10)
        character*30  c_fdda_mdl_src(maxbgmodels)

        integer max_fcst_times
        parameter (max_fcst_times=200)

        integer max_regions
        parameter (max_regions=10)

        character EXT*31, directory*255, c_model*30

        character*10  units_2d
        character*125 comment_2d
        character*3 var_2d
        character*9 a9time,a9time_valid,a9time_init
        character*24 atime_s
        character*150 hist_dir, verif_dir
        character*150 hist_file

        integer n_vfields
        parameter (n_vfields=4)
        character*10 ext_anal_a(n_vfields), ext_fcst_a(n_vfields)
        character*10 var_a(n_vfields)

!       Specify what is being verified
        data ext_fcst_a /'fua','fua','   ','fua'/ ! 3-D
!       data ext_anal_a /'lps'/ ! 3-D reflectivity
        data var_a      /'U3','V3','W3','T3'/

        real rms_a (n_vfields,maxbgmodels,0:max_fcst_times)

        integer contable(0:1,0:1)

        integer maxthr
        parameter (maxthr=5)

!       Declarations from compare_analysis_to_rad
        real
     1                        cvr_max(ni,nj)
     1        ,dbz_max_2d(ni,nj),solar_alt(ni,nj)

!       How much the solar radiation varies with changes in cloud fraction
        real rad_clr(ni,nj)

        real airmass_2d(ni,nj)
        real pw_2d(ni,nj)
        real trans_h2o_2d(ni,nj)

        real dum_2d(ni,nj)

        character c_stations(maxsta)*3

        real lat_s(maxsta), lon_s(maxsta), elev_s(maxsta)
        real var_s(maxsta)
        real var_fcst_s(maxsta)

        real dum_s(maxsta)

        real ea(maxsta)

        integer ii_s(maxsta)
        integer jj_s(maxsta)
        integer doy

        character*3 c3_discrep
        character*1 c1_c
        character title*60, ver_file*256, filename*9

!       End Declarations

        write(6,*)' Start subroutine verif_fcst_pt_3d...'
        write(6,*)' i4time_sys a9time = ',i4time_sys,a9time

        call get_laps_domain_95(ni,nj,lat,lon,topo
     1           ,rlaps_land_frac,grid_spacing_cen_m,istatus)
        if(istatus .ne. 1)then
            write(6,*)' Error getting LAPS domain'
            return
        endif

        iwrite = 0

        u_mdl_bkg_4d = 0 ! Sets time term to zero when we call get_wind_3d_obs
        v_mdl_bkg_4d = 0

!       n_fcst_times = 2 ! 38

        thresh_var = 20. ! lowest threshold for this variable

        i4_initial = i4time_sys

        lun_in = 21

        rmiss = -99.9

        rms_a = r_missing_data

!       Get fdda_model_source from static file
        call get_fdda_model_source(c_fdda_mdl_src,n_fdda_models,istatus)

        write(6,*)' n_fdda_models = ',n_fdda_models
        write(6,*)' c_fdda_mdl_src = '
     1            ,(c_fdda_mdl_src(m),m=1,n_fdda_models)

!       if(n_fdda_models .ne. n_models + 1)then
!           write(6,*)' ERROR n_models differs from n_fdda_models '
!    1                       ,n_models,n_fdda_models
!           stop
!       endif

!       do ifield = 1,3
        do ifield = 1,n_vfields

          var_2d = var_a(ifield)
          call s_len(var_2d,lenvar)

          write(6,*)
          write(6,*)
          write(6,*)' Processing field ',trim(var_2d)

          call get_directory('verif',verif_dir,len_verif)

          istart = 0

          lun_out = 39

          hist_dir = verif_dir(1:len_verif)//var_2d(1:lenvar)
     1                                       //'/pt'
!    1                                       //c_model(1:len_model)
          len_hist = len_verif + 3 + lenvar ! + len_model

          call make_fnam_lp(i4_initial,a9time_init,istatus)

          hist_file = hist_dir(1:len_hist)//'/'//a9time_init
     1                                    //'.stats'

!         if(ifield .gt. 1)then
!           hist_file = trim(hist_file)//'_'//var_a(ifield)
!         endif

          call s_len(hist_file,len_histf)
          write(6,*)'hist_file = ',hist_file(1:len_histf)
          open(lun_out,file=hist_file(1:len_histf),status='unknown')

!         Write comment with model member names
          write(lun_out,902)(trim(c_fdda_mdl_src(imodel))
     1                     ,imodel=2,n_fdda_models)
902       format('# ',30(1x,a))

          do imodel = 1,n_fdda_models ! move this inside the time loop

            c_model = c_fdda_mdl_src(imodel)

            if(c_model(1:3) .ne. 'lga')then

              write(6,*)
              write(6,*)' Processing model ',c_model

              call s_len(c_model,len_model)

              if(istart .eq. 1)then
                  call cv_i4tim_asc_lp(i4_initial,atime_s,istatus)
                  write(lun_out,710)atime_s
              endif

              do itime_fcst = istart,n_fcst_times

                itime = itime_fcst + 1

                i4_valid = i4_initial
     1                   + itime_fcst * model_verif_intvl

                call make_fnam_lp(i4_valid,a9time_valid,istatus)

                write(6,*)
                write(6,*)' Processing time ',a9time_valid

                if(trim(var_2d) .eq. 'W3')then
!                   call cv_i4tim_asc_lp(i4_valid,atime_s,istatus)
                    goto 1200
                endif

                N_SAO = 100000      ! read from wind.nl or nest7grid.parms?
                N_PIREP = 100000    ! read from wind.nl or nest7grid.parms?
                MAX_PR = 3000       ! read from wind.nl?
                MAX_PR_LEVELS = 300 ! read from wind.nl?

                nobs_point = 0      ! initialize
                var_s = r_missing_data
                var_fcst_s = r_missing_data
                max_wind_obs = maxsta

                if(.true.)then
                  write(6,*)' Reading forecast field'

!                 Read forecast field
                  ext = ext_fcst_a(ifield)
                  call get_directory(ext,directory,len_dir)

                  DIRECTORY=directory(1:len_dir)//c_model(1:len_model)
     1                                          //'/'

                  call get_lapsdata_3d(i4_initial,i4_valid
     1                          ,ni,nj,nk
     1                          ,DIRECTORY,var_2d
     1                          ,units_2d,comment_2d
     1                          ,var_fcst_3d
     1                          ,istatus)
                  if(istatus .ne. 1)then
                       write(6,*)' Error reading 3D Forecast for '
     1                           ,var_2d
                       xbar = rmiss
                       ybar = rmiss
                       std = rmiss
                       goto 900
                  endif

                endif ! .true.

!               Read obs
                if(var_2d .eq. 'U3' .or. var_2d .eq. 'V3')then
                  write(6,*)' Reading analyzed height field'
                  call get_laps_3d(i4_valid
     1                          ,ni,nj,nk
     1                          ,'lt1'    ,'HT '
     1                          ,units_2d,comment_2d
     1                          ,heights_3d
     1                          ,istatus)
                  if(istatus .ne. 1)then
                       write(6,*)' Error reading analyzed height '
                       write(6,*)
     1                 ' It will try reading forecasted height '

                       call get_lapsdata_3d(i4_initial,i4_valid
     1                 ,ni,nj,nk,DIRECTORY,'HT ',units_2d,comment_2d
     1                 ,heights_3d,istatus)
                       if(istatus .ne. 1)then
                            write(6,*)' Error reading fcst height '
                            goto 990
                       endif
                  endif

                  write(6,*)' Reading 3D wind obs - i4_valid = '
     1                                             ,i4_valid
                  call get_wind_3d_obs(
     1            ni,nj,nk,                                       ! I
     1            r_missing_data,i2_missing_data,                 ! I
     1            i4_valid,heights_3d,heights_1d,                 ! I
     1            MAX_PR,MAX_PR_LEVELS,weight_prof,l_use_raob,    ! I
     1            l_use_cdw,                                      ! I
     1            N_SAO,N_PIREP,                                  ! I
     1            lat,lon,topo,                                   ! I
     1            NTMIN,NTMAX,                                    ! I
     1            u_mdl_bkg_4d, v_mdl_bkg_4d,                     ! I
     1            grid_laps_u,grid_laps_v,grid_laps_wt,           ! O
     1            max_wind_obs,obs_point,nobs_point,              ! I/O
     1            rlat_radar,rlon_radar,rheight_radar,            ! I
     1            istat_radar_vel,n_vel_grids,                    ! I
     1            istatus_remap_pro,                              ! O
     1            istatus                )                        ! O

                elseif(var_2d .eq. 'T3')then ! read temperature obs
                  write(6,*)' Reading analyzed height field'
                  call get_laps_3d(i4_valid
     1                          ,ni,nj,nk
     1                          ,'lt1'    ,'HT '
     1                          ,units_2d,comment_2d
     1                          ,heights_3d
     1                          ,istatus)
                  if(istatus .ne. 1)then
                       write(6,*)' Error reading analyzed height '
                       write(6,*)
     1                 ' It will try reading forecasted height '

                       call get_lapsdata_3d(i4_initial,i4_valid
     1                 ,ni,nj,nk,DIRECTORY,'HT ',units_2d,comment_2d
     1                 ,heights_3d,istatus)
                       if(istatus .ne. 1)then
                            write(6,*)' Error reading fcst height '
                            goto 990
                       endif
                  endif

                  call get_pres_3d(i4_valid,ni,nj,nk,pres_3d,istatus)
                  if(istatus .ne. 1)then
                    write(6,*)
     1                ' Error: Bad status returned from get_pres_3d'
                    goto 990
                  endif

                  call get_meso_sao_pirep(MAX_SFC,dum,MAX_ACARS,istatus)

                  nobs_point = 0 ! initialize

                  write(6,*)' Reading 3D ACARS temp obs - i4_valid = '
     1                                                   ,i4_valid
                  call rd_acars_t(i4_valid,heights_3d,var_fcst_3d   ! I
     1                       ,pres_3d                               ! I
     1                       ,MAX_ACARS                             ! I
     1                       ,n_good_acars                          ! O
     1                       ,'pin'                                 ! I
     1                       ,ni,nj,nk                              ! I
     1                       ,lat,lon,r_missing_data                ! I
     1                       ,temp_obs,max_obs,nobs_point           ! I/O
     1                       ,istatus)                              ! O
                  if(istatus .ne. 1)then
                    write(6,*)' bad status return from rd_acars_t'
                    return
                  endif

                endif

                write(6,*)' number of obs ',nobs_point

                cnt = 0.

                do ista = 1,nobs_point
                  if(var_2d .eq. 'U3')then
                    var_s(ista) = obs_point(ista)%valuef(1)
                  elseif(var_2d .eq. 'V3')then
                    var_s(ista) = obs_point(ista)%valuef(2)
                  elseif(var_2d .eq. 'T3')then
                    var_s(ista) = temp_obs(ista,i_ob_grid)
                  endif

                  var_fcst_s(ista) = r_missing_data

                  if(ista .le. 100 .or. ista .eq. (ista/100)*100)then
                      write(6,*)ista,var_s(ista)
                  endif

                  if(var_s(ista) .ne. r_missing_data)then
                    call latlon_to_rlapsgrid(lat_s(ista),lon_s(ista),lat
     1                          ,lon,ni,nj,ri,rj,istatus)

                    if(var_2d .eq. 'T3')then
                      i_g = temp_obs(ista,i_i)
                      j_g = temp_obs(ista,i_j)
                      k_g = temp_obs(ista,i_k)
                    else
                      i_g = obs_point(ista)%i
                      j_g = obs_point(ista)%j
                      k_g = obs_point(ista)%k
                    endif

                    ii_s(ista) = i_g
                    jj_s(ista) = j_g

                    if(i_g .ge. 3 .and. i_g .le. ni-2 .and.
     1                 j_g .ge. 3 .and. j_g .le. nj-2            )then

                      if(k_g .le. nk)then

!                       if(var_2d .eq. 'U3' .or. var_2d .eq. 'V3')then
                          var_fcst_s(ista) = var_fcst_3d(i_g,j_g,k_g)
!                       endif

                        sumobs = sumobs + var_s(ista)
                        sumanl = sumanl + var_fcst_s(ista)
                        cnt = cnt + 1.

                      else
                        iwrite = iwrite + 1
                        if(iwrite .le. 50)then
                          write(6,*)' WARNING: k is outside domain '
     1                             ,ista,k_g
                        endif

                      endif

1112                endif ! ob is in domain
                  endif ! non-missing observation (valid value)
                enddo ! ista

                write(6,*)
                write(6,*)' Generic stats, cnt = ',nint(cnt)

                if(nint(cnt) .eq. 0)then
                  write(6,*)' Skipping call to stats_1d'
                  xbar = rmiss
                  ybar = rmiss
                  std = rmiss
                  goto 900
                endif

1200            if(var_2d .eq. 'U3')then
                  call stats_1d(maxsta,var_fcst_s,var_s
     1                   ,'U Wind Component:       '
     1                   ,a_t,b_t,xbar,ybar
     1                   ,bias,std,r_missing_data,istatus)
                  if(istatus .eq. 1)then
                      rms_a(ifield,imodel,itime_fcst) = std
                  else
                      rms_a(ifield,imodel,itime_fcst) = r_missing_data
                  endif
                elseif(var_2d .eq. 'V3')then
                  call stats_1d(maxsta,var_fcst_s,var_s
     1                   ,'V Wind Component:       '
     1                   ,a_t,b_t,xbar,ybar
     1                   ,bias,std,r_missing_data,istatus)
                  if(istatus .eq. 1)then
                      rms_a(ifield,imodel,itime_fcst) = std
                  else
                      rms_a(ifield,imodel,itime_fcst) = r_missing_data
                  endif
                elseif(var_2d .eq. 'W3')then
                  xbar = rms_a(1,imodel,itime_fcst)
                  ybar = rms_a(2,imodel,itime_fcst)
                  if(xbar .ne. r_missing_data .AND.
     1               ybar .ne. r_missing_data       )then
                      std = sqrt(rms_a(1,imodel,itime_fcst)**2
     1                          +rms_a(2,imodel,itime_fcst)**2)
                  else
                      xbar = rmiss
                      ybar = rmiss
                      std = rmiss
                  endif
                  rms_a(ifield,imodel,itime_fcst) = std
                elseif(var_2d .eq. 'T3')then
                  call stats_1d(max_obs,var_fcst_s,var_s
     1                   ,'Temperature:            '
     1                   ,a_t,b_t,xbar_k,ybar_k
     1                   ,bias,std,r_missing_data,istatus)
                  if(istatus .eq. 1)then
                      xbar = k_to_c(xbar_k)
                      ybar = k_to_c(ybar_k)
                  else
                      xbar = rmiss
                      ybar = rmiss
                      std = rmiss
                  endif
                  rms_a(ifield,imodel,itime_fcst) = std
                endif

900             continue

990             continue

                write(6,*)
                write(6,*)' Writing to lun_out ',lun_out
                call cv_i4tim_asc_lp(i4_valid,atime_s,istatus)
                write(6,710)atime_s,xbar,ybar,std
                write(lun_out,710)atime_s,xbar,ybar,std
710             format(1x,a24,3f10.3)

              enddo ! itime_fcst

              write(lun_out,*)
              write(lun_out,*)

            endif ! c_model .ne. lga

          enddo ! model

          write(6,*)' Closing lun_out ',lun_out
          close (lun_out)

        enddo ! fields

 999    write(6,*)' End of subroutine verif_fcst_pt_3d'

        return

        end

max_stars_repo_name: maxinye/laps-mirror

max_stars_repo_licenses: Intel Unlicense OLDAP-2.2.1 NetCDF

max_issues_repo_name: longwosion/laps-mirror

max_issues_repo_licenses: Intel NetCDF OLDAP-2.2.1 Unlicense

max_forks_repo_name: longwosion/laps-mirror

max_forks_repo_licenses: Intel NetCDF OLDAP-2.2.1 Unlicense


text:
Describe Users/SuBarns here.
Welcome to the Wiki.  I reverted your changes to the Chateau Apartments page, then readded the new phone number you used.  Please take a moment to look over the Welcome to the Wiki/Business Owner business representative page.  Its bad form to delete other users commentsto say nothing of leaving a positive comment thats clearly intended to mislead readers into thinking youre just a visitor, rather than a representative of the apartment.  That business rep page has some useful info on how to constructively respond to negative comments and deal with other problems that may arise on the wiki.  If you have any questions, feel free to ask.  Users/TomGarberson

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search