parutg.f

Go to the documentation of this file.

C> @file
C> @author WOOLLEN @date 1994-01-06
      
C> THIS SUBROUTINE PARSES A USER-SPECIFIED TAG (MNEMONIC)
C>   (UTG) THAT REPRESENTS A VALUE EITHER BEING DECODED FROM A BUFR FILE
C>   (IF IT IS BEING READ) OR ENCODED INTO A BUFR FILE (IF IT IS BEING
C>   WRITTEN).  THIS SUBROUTINE FIRST CHECKS TO SEE IF THE TAG CONTAINS
C>   A CONDITION CHARACTER ('=', '!', '<', '>', '^' OR '#').  IF IT DOES
C>   NOT, NOTHING HAPPENS AT THIS POINT.  IF IT DOES, THEN THE TYPE OF
C>   CONDITION CHARACTER IS NOTED AND THE TAG IS STRIPPED OF ALL
C>   CHARACTERS AT AND BEYOND THE CONDITION CHARACTER.  IN EITHER EVENT,
C>   THE RESULTANT TAG IS CHECKED AGAINST THOSE IN THE INTERNAL JUMP/
C>   LINK SUBSET TABLE (IN MODULE TABLES).  IF FOUND, THE NODE
C>   ASSOCIATED WITH THE TAG IS RETURNED (AND IT IS EITHER A "CONDITION"
C>   NODE OR A "STORE" NODE DEPENDING OF THE PRESENCE OR ABSENCE OF A
C>   CONDITION CHARACTER IN UTG).  OTHERWISE THE NODE IS RETURNED AS
C>   ZERO.  IF THE TAG REPRESENTS A CONDITION NODE, THEN THE CONDITION
C>   VALUE (NUMERIC CHARACTERS BEYOND THE CONDITION CHARACTER IN THE
C>   USER-SPECIFIED TAG INPUT HERE) IS RETURNED.
C>
C>   AS AN EXAMPLE OF CONDITION CHARACTER USAGE, CONSIDER THE FOLLOWING
C>   EXAMPLE OF A CALL TO UFBINT:
C>
C>      REAL*8 USR(4,50)
C>             ....
C>             ....
C>      CALL UFBINT(LUNIN,USR,4,50,IRET,'PRLC<50000 TMDB WDIR WSPD')
C>
C>   ASSUMING THAT LUNIN POINTS TO A BUFR FILE OPEN FOR INPUT (READING),
C>   THEN THE USR ARRAY NOW CONTAINS IRET LEVELS OF DATA (UP TO A MAXIMUM
C>   OF 50!) WHERE THE VALUE OF PRLC IS/WAS LESS THAN 50000, ALONG WITH
C>   THE CORRESPONDING VALUES FOR TMDB, WDIR AND WSPD AT THOSE LEVELS. 
C>
C>   AS ANOTHER EXAMPLE, CONSIDER THE FOLLOWING EXAMPLE OF A CALL TO
C>   READLC FOR A LONG CHARACTER STRING:
C>
C>      CHARACTER*200 LCHR
C>             ....
C>             ....
C>      CALL READLC(LUNIN,LCHR,'NUMID#3')
C>
C>   ASSUMING THAT LUNIN POINTS TO A BUFR FILE OPEN FOR INPUT (READING),
C>   THEN THE LCHR STRING NOW CONTAINS THE VALUE CORRESPONDING TO THE 
C>   THIRD OCCURRENCE OF NUMID WITHIN THE CURRENT SUBSET.
C>
C>   VALID CONDITION CODES INCLUDE:
C>  '<' - LESS THAN
C>       '>' - GREATER THAN
C>       '=' - EQUAL TO
C>       '!' - NOT EQUAL TO
C>       '#' - ORDINAL IDENTIFIER FOR A PARTICULAR OCCURRENCE OF A LONG
C>             CHARACTER STRING
C>
C> PROGRAM HISTORY LOG:
C> 1994-01-06  J. WOOLLEN -- ORIGINAL AUTHOR
C> 1998-07-08  J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE
C>                           "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB
C>                           ROUTINE "BORT"
C> 1999-11-18  J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE
C>                           OPENED AT ONE TIME INCREASED FROM 10 TO 32
C>                           (NECESSARY IN ORDER TO PROCESS MULTIPLE
C>                           BUFR FILES UNDER THE MPI)
C> 2003-11-04  S. BENDER  -- ADDED REMARKS/BUFRLIB ROUTINE
C>                           INTERDEPENDENCIES
C> 2003-11-04  D. KEYSER  -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES)
C>                           INCREASED FROM 15000 TO 16000 (WAS IN
C>                           VERIFICATION VERSION); UNIFIED/PORTABLE FOR
C>                           WRF; ADDED DOCUMENTATION (INCLUDING
C>                           HISTORY); OUTPUTS MORE COMPLETE DIAGNOSTIC
C>                           INFO WHEN ROUTINE TERMINATES ABNORMALLY;
C>                           CHANGED CALL FROM BORT TO BORT2 IN SOME
C>                           CASES; REPLACED PREVIOUS "RETURN 1"
C>                           STATEMENT WITH "GOTO 900" (AND CALL TO
C>                           BORT) SINCE THE ONLY ROUTINE THAT CALLS
C>                           THIS ROUTINE, PARUSR, USED THIS ALTERNATE
C>                           RETURN TO GO TO A STATEMENT WHICH CALLED
C>                           BORT
C> 2005-04-22  J. ATOR    -- HANDLED SITUATION WHERE INPUT TAG CONTAINS
C>                           1-BIT DELAYED REPLICATION, AND IMPROVED
C>                           DOCUMENTATION
C> 2009-03-23  J. ATOR    -- ADDED '#' CONDITION CODE
C> 2014-12-10  J. ATOR    -- USE MODULES INSTEAD OF COMMON BLOCKS
C>
C> USAGE:    CALL PARUTG (LUN, IO, UTG, NOD, KON, VAL)
C>   INPUT ARGUMENT LIST:
C>     LUN      - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS
C>     IO       - INTEGER: STATUS INDICATOR FOR BUFR FILE ASSOCIATED
C>                WITH LUN:
C>                       0 = input file
C>                       1 = output file
C>     UTG      CHARACTER*(*): USER-SUPPLIED TAG REPRESENTING A VALUE TO
C>              BE ENCODED/DECODED TO/FROM BUFR FILE
C>
C>   OUTPUT ARGUMENT LIST:
C>     NOD      - INTEGER: POSITIONAL INDEX IN INTERNAL JUMP/LINK SUBSET
C>                TABLE FOR TAG
C>                       0 = tag not found in table
C>     KON      - INTEGER: INDICATOR FOR TYPE OF CONDITION CHARACTER
C>                FOUND IN UTG:
C>                      0 = no condition character found (NOD is a store
C>                          node)
C>                      1 = character '=' found
C>                      2 = character '!' found
C>                      3 = character '<' found
C>                      4 = character '>' found
C>                      5 = character '^' found
C>                      6 = character '#' found
C>                      (1-6 means NOD is a condition node, and
C>                       specifically 5 is a "bump" node)
C>     VAL      - REAL: CONDITION VALUE ASSOCIATED WITH CONDITION
C>                CHARACTER FOUND IN UTG
C>                      0 = UTG does not have a condition character
C>
C> REMARKS:
C>    THIS ROUTINE CALLS:        BORT     BORT2    STRNUM
C>    THIS ROUTINE IS CALLED BY: PARUSR   READLC   WRITLC
C>                               Normally not called by any application
C>                               programs.
C>
      SUBROUTINE parutg(LUN,IO,UTG,NOD,KON,VAL)
 
      USE moda_msgcwd
      USE moda_tables
 
      COMMON /utgprm/ picky
 
      CHARACTER*(*) UTG
      CHARACTER*128 BORT_STR1,BORT_STR2
      CHARACTER*20  ATAG
      CHARACTER*3   ATYP,BTYP
      CHARACTER*1   COND(6)
      dimension     btyp(8),iok(8)
      LOGICAL       PICKY
 
      DATA nchk   / 8/
      DATA btyp   /'SUB','SEQ','REP','RPC','RPS','DRB','DRP','DRS'/
      DATA iok    /  -1 ,  -1 ,  -1 ,  -1 ,  -1 ,   0 ,   0 ,   0 /
 
C----------------------------------------------------------------------
C     For now, set PICKY (see below) to always be .FALSE.
      picky = .false.
      cond(1) = '='
      cond(2) = '!'
      cond(3) = '<'
      cond(4) = '>'
      cond(5) = '^'
      cond(6) = '#'
      ncond   = 6
C----------------------------------------------------------------------
 
      atag  = ' '
      atyp  = ' '
      kon   = 0
      nod   = 0
      val   = 0
      ltg   = min(20,len(utg))
 
C  PARSE UTG, SAVING INTO ATAG ONLY CHARACTERS PRIOR TO CONDITION CHAR.
C  --------------------------------------------------------------------
 
C     But first, take care of the special case where UTG denotes the
C     short (i.e. 1-bit) delayed replication of a Table D mnemonic.
C     This will prevent confusion later on since '<' and '>' are each
C     also valid as condition characters.
 
      IF((utg(1:1).EQ.'<').AND.(index(utg(3:),'>').NE.0)) THEN
         atag = utg
         GO TO 1
      ENDIF
 
      DO i=1,ltg
      IF(utg(i:i).EQ.' ') GOTO 1
      DO j=1,ncond
      IF(utg(i:i).EQ.cond(j)) THEN
         kon = j
         icv = i+1
         GOTO 1
      ENDIF
      ENDDO
      atag(i:i) = utg(i:i)
      ENDDO
 
C  FIND THE NODE ASSOCIATED WITH ATAG IN THE SUBSET TABLE
C  ------------------------------------------------------
 
1     inod = inode(lun)
      DO nod=inod,isc(inod)
      IF(atag.EQ.tag(nod)) GOTO 2
      ENDDO
 
C  ATAG NOT FOUND IN SUBSET TABLE
C  ------------------------------
 
C     So what do we want to do?  We could be "picky" and abort right
C     here, or we could allow for the possibility that, e.g. a user
C     application has been streamlined to always call UFBINT with the
C     same STR, even though some of the mnemonics contained within that
C     STR may not exist within the sequence definition of every
C     possible type/subtype that is being written by the application.
C     In such cases, by not being "picky", we could just allow BUFRLIB
C     to subsequently (and quietly, if IPRT happened to be set to -1
C     in COMMON /QUIET/!) not actually store the value corresponding
C     to such mnemonics, rather than loudly complaining and aborting. 
 
      IF(kon.EQ.0 .AND. (io.EQ.0.OR.atag.EQ.'NUL'.OR..NOT.picky)) THEN
C        i.e. (if this tag does not contain any condition characters)
C                 .AND.
C             ((either the file is open for input) .OR.
C              (the tag consists of 'NUL') .OR.
C              (we aren't being "picky"))
         nod = 0
         GOTO 100
      ELSE
C        abort...
         GOTO 900
      ENDIF
 
C  ATAG IS FOUND IN SUBSET TABLE, MAKE SURE IT HAS A VALID NODE TYPE
C  -----------------------------------------------------------------
 
2     IF(kon.EQ.5) THEN
c  .... Cond. char "^" must be assoc. with a delayed replication
c       sequence (this is a "bump" node) (Note: This is obsolete but
c       remains for "old" programs using the BUFR ARCHIVE LIBRARY)
         IF(typ(nod-1).NE.'DRP' .AND. typ(nod-1).NE.'DRS') GOTO 901
      ELSEIF(kon.NE.6) THEN
C        Allow reading (but not writing) of delayed replication factors.
         atyp = typ(nod)
         DO i=1,nchk
           IF(atyp.EQ.btyp(i) .AND. io.GT.iok(i)) GOTO 902
         ENDDO
      ENDIF
 
C  IF CONDITION NODE, GET CONDITION VALUE WHICH IS A NUMBER FOLLOWING IT
C  ---------------------------------------------------------------------
 
      IF(kon.NE.0) THEN
         CALL strnum(utg(icv:ltg),num)
         IF(num.LT.0) GOTO 903
         val = num
      ENDIF
 
C  EXITS
C  -----
 
100   RETURN
900   WRITE(bort_str1,'("BUFRLIB: PARUTG - TRYING TO WRITE A MNEMONIC'//
     . ' (",A,") WHICH DOES NOT EXIST IN SUBSET TABLE")') atag
      WRITE(bort_str2,'(18X,"(UPON INPUT, IT CONTAINED THE CONDITION '//
     . 'CHARACTER ",A,")")') utg(icv-1:icv-1)
      CALL bort2(bort_str1,bort_str2)
901   WRITE(bort_str1,'("BUFRLIB: PARUTG - BUMP NODE (MNEMONIC ",A,")'//
     . ' MUST REFER TO A DELAYED REPLICATION SEQUENCE, HERE TYPE IS "'//
     . ',A)') atag,typ(nod-1)
      CALL bort(bort_str1)
902   WRITE(bort_str1,'("BUFRLIB: PARUTG - ILLEGAL NODE TYPE: ",A," '//
     . 'FOR MNEMONIC ",A)') atyp,atag
      CALL bort(bort_str1)
903   WRITE(bort_str1,'("BUFRLIB: PARUTG - CONDITION VALUE IN '//
     . 'MNEMONIC ",A," ILLEGAL BECAUSE ALL OTHER CHARACTERS IN '//
     . 'MNEMONIC MUST BE NUMERIC")') utg
      CALL bort(bort_str1)
      END