SUBROUTINE PARUTG(LUN,IO,UTG,NOD,KON,VAL)
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C
C SUBPROGRAM: PARUTG
C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06
C
C ABSTRACT: 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 COMMON BLOCK /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
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
C ATTRIBUTES:
C LANGUAGE: FORTRAN 77
C MACHINE: PORTABLE TO ALL PLATFORMS
C
C$$$
INCLUDE 'bufrlib.prm'
COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES),
. INODE(NFILES),IDATE(NFILES)
COMMON /TABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL),
. JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL),
. IBT(MAXJL),IRF(MAXJL),ISC(MAXJL),
. ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL),
. ISEQ(MAXJL,2),JSEQ(MAXJL)
COMMON /UTGPRM/ PICKY
CHARACTER*(*) UTG
CHARACTER*128 BORT_STR1,BORT_STR2
CHARACTER*20 ATAG
CHARACTER*10 TAG
CHARACTER*3 TYP,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