var/external/bufr/parutg.f

   1       SUBROUTINE PARUTG(LUN,IO,UTG,NOD,KON,VAL)
   2
   3 C$$$  SUBPROGRAM DOCUMENTATION BLOCK
   4 C
   5 C SUBPROGRAM:    PARUTG
   6 C   PRGMMR: WOOLLEN          ORG: NP20       DATE: 1994-01-06
   7 C
   8 C ABSTRACT: THIS SUBROUTINE PARSES A USER-SPECIFIED TAG (MNEMONIC)
   9 C   (UTG) THAT REPRESENTS A VALUE EITHER BEING DECODED FROM A BUFR FILE
  10 C   (IF IT IS BEING READ) OR ENCODED INTO A BUFR FILE (IF IT IS BEING
  11 C   WRITTEN).  THIS SUBROUTINE FIRST CHECKS TO SEE IF THE TAG CONTAINS
  12 C   A CONDITION CHARACTER ('=', '!', '<', '>', '^' OR '#').  IF IT DOES
  13 C   NOT, NOTHING HAPPENS AT THIS POINT.  IF IT DOES, THEN THE TYPE OF
  14 C   CONDITION CHARACTER IS NOTED AND THE TAG IS STRIPPED OF ALL
  15 C   CHARACTERS AT AND BEYOND THE CONDITION CHARACTER.  IN EITHER EVENT,
  16 C   THE RESULTANT TAG IS CHECKED AGAINST THOSE IN THE INTERNAL JUMP/
  17 C   LINK SUBSET TABLE (IN COMMON BLOCK /BTABLES/).  IF FOUND, THE NODE
  18 C   ASSOCIATED WITH THE TAG IS RETURNED (AND IT IS EITHER A "CONDITION"
  19 C   NODE OR A "STORE" NODE DEPENDING OF THE PRESENCE OR ABSENCE OF A
  20 C   CONDITION CHARACTER IN UTG).  OTHERWISE THE NODE IS RETURNED AS
  21 C   ZERO.  IF THE TAG REPRESENTS A CONDITION NODE, THEN THE CONDITION
  22 C   VALUE (NUMERIC CHARACTERS BEYOND THE CONDITION CHARACTER IN THE
  23 C   USER-SPECIFIED TAG INPUT HERE) IS RETURNED.
  24 C
  25 C   AS AN EXAMPLE OF CONDITION CHARACTER USAGE, CONSIDER THE FOLLOWING
  26 C   EXAMPLE OF A CALL TO UFBINT:
  27 C
  28 C      REAL*8 USR(4,50)
  29 C             ....
  30 C             ....
  31 C      CALL UFBINT(LUNIN,USR,4,50,IRET,'PRLC<50000 TMDB WDIR WSPD')
  32 C
  33 C   ASSUMING THAT LUNIN POINTS TO A BUFR FILE OPEN FOR INPUT (READING),
  34 C   THEN THE USR ARRAY NOW CONTAINS IRET LEVELS OF DATA (UP TO A MAXIMUM
  35 C   OF 50!) WHERE THE VALUE OF PRLC IS/WAS LESS THAN 50000, ALONG WITH
  36 C   THE CORRESPONDING VALUES FOR TMDB, WDIR AND WSPD AT THOSE LEVELS.
  37 C
  38 C   AS ANOTHER EXAMPLE, CONSIDER THE FOLLOWING EXAMPLE OF A CALL TO
  39 C   READLC FOR A LONG CHARACTER STRING:
  40 C
  41 C      CHARACTER*200 LCHR
  42 C             ....
  43 C             ....
  44 C      CALL READLC(LUNIN,LCHR,'NUMID#3')
  45 C
  46 C   ASSUMING THAT LUNIN POINTS TO A BUFR FILE OPEN FOR INPUT (READING),
  47 C   THEN THE LCHR STRING NOW CONTAINS THE VALUE CORRESPONDING TO THE
  48 C   THIRD OCCURRENCE OF NUMID WITHIN THE CURRENT SUBSET.
  49 C
  50 C   VALID CONDITION CODES INCLUDE:
  51 C       '<' - LESS THAN
  52 C       '>' - GREATER THAN
  53 C       '=' - EQUAL TO
  54 C       '!' - NOT EQUAL TO
  55 C       '#' - ORDINAL IDENTIFIER FOR A PARTICULAR OCCURRENCE OF A LONG
  56 C             CHARACTER STRING
  57 C
  58 C PROGRAM HISTORY LOG:
  59 C 1994-01-06  J. WOOLLEN -- ORIGINAL AUTHOR
  60 C 1998-07-08  J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE
  61 C                           "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB
  62 C                           ROUTINE "BORT"
  63 C 1999-11-18  J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE
  64 C                           OPENED AT ONE TIME INCREASED FROM 10 TO 32
  65 C                           (NECESSARY IN ORDER TO PROCESS MULTIPLE
  66 C                           BUFR FILES UNDER THE MPI)
  67 C 2003-11-04  S. BENDER  -- ADDED REMARKS/BUFRLIB ROUTINE
  68 C                           INTERDEPENDENCIES
  69 C 2003-11-04  D. KEYSER  -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES)
  70 C                           INCREASED FROM 15000 TO 16000 (WAS IN
  71 C                           VERIFICATION VERSION); UNIFIED/PORTABLE FOR
  72 C                           WRF; ADDED DOCUMENTATION (INCLUDING
  73 C                           HISTORY); OUTPUTS MORE COMPLETE DIAGNOSTIC
  74 C                           INFO WHEN ROUTINE TERMINATES ABNORMALLY;
  75 C                           CHANGED CALL FROM BORT TO BORT2 IN SOME
  76 C                           CASES; REPLACED PREVIOUS "RETURN 1"
  77 C                           STATEMENT WITH "GOTO 900" (AND CALL TO
  78 C                           BORT) SINCE THE ONLY ROUTINE THAT CALLS
  79 C                           THIS ROUTINE, PARUSR, USED THIS ALTERNATE
  80 C                           RETURN TO GO TO A STATEMENT WHICH CALLED
  81 C                           BORT
  82 C 2005-04-22  J. ATOR    -- HANDLED SITUATION WHERE INPUT TAG CONTAINS
  83 C                           1-BIT DELAYED REPLICATION, AND IMPROVED
  84 C                           DOCUMENTATION
  85 C 2009-03-23  J. ATOR    -- ADDED '#' CONDITION CODE
  86 C
  87 C USAGE:    CALL PARUTG (LUN, IO, UTG, NOD, KON, VAL)
  88 C   INPUT ARGUMENT LIST:
  89 C     LUN      - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS
  90 C     IO       - INTEGER: STATUS INDICATOR FOR BUFR FILE ASSOCIATED
  91 C                WITH LUN:
  92 C                       0 = input file
  93 C                       1 = output file
  94 C     UTG      CHARACTER*(*): USER-SUPPLIED TAG REPRESENTING A VALUE TO
  95 C              BE ENCODED/DECODED TO/FROM BUFR FILE
  96 C
  97 C   OUTPUT ARGUMENT LIST:
  98 C     NOD      - INTEGER: POSITIONAL INDEX IN INTERNAL JUMP/LINK SUBSET
  99 C                TABLE FOR TAG
 100 C                       0 = tag not found in table
 101 C     KON      - INTEGER: INDICATOR FOR TYPE OF CONDITION CHARACTER
 102 C                FOUND IN UTG:
 103 C                      0 = no condition character found (NOD is a store
 104 C                          node)
 105 C                      1 = character '=' found
 106 C                      2 = character '!' found
 107 C                      3 = character '<' found
 108 C                      4 = character '>' found
 109 C                      5 = character '^' found
 110 C                      6 = character '#' found
 111 C                      (1-6 means NOD is a condition node, and
 112 C                       specifically 5 is a "bump" node)
 113 C     VAL      - REAL: CONDITION VALUE ASSOCIATED WITH CONDITION
 114 C                CHARACTER FOUND IN UTG
 115 C                      0 = UTG does not have a condition character
 116 C
 117 C REMARKS:
 118 C    THIS ROUTINE CALLS:        BORT     BORT2    STRNUM
 119 C    THIS ROUTINE IS CALLED BY: PARUSR   READLC   WRITLC
 120 C                               Normally not called by any application
 121 C                               programs.
 122 C
 123 C ATTRIBUTES:
 124 C   LANGUAGE: FORTRAN 77
 125 C   MACHINE:  PORTABLE TO ALL PLATFORMS
 126 C
 127 C$$$
 128
 129       INCLUDE 'bufrlib.prm'
 130
 131       COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES),
 132      .                INODE(NFILES),IDATE(NFILES)
 133       COMMON /BTABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL),
 134      .                JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL),
 135      .                IBT(MAXJL),IRF(MAXJL),ISC(MAXJL),
 136      .                ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL),
 137      .                ISEQ(MAXJL,2),JSEQ(MAXJL)
 138       COMMON /UTGPRM/ PICKY
 139
 140       CHARACTER*(*) UTG
 141       CHARACTER*128 BORT_STR1,BORT_STR2
 142       CHARACTER*20  ATAG
 143       CHARACTER*10  TAG
 144       CHARACTER*3   TYP,ATYP,BTYP
 145       CHARACTER*1   COND(6)
 146       DIMENSION     BTYP(8),IOK(8)
 147       LOGICAL       PICKY
 148
 149       DATA NCHK   / 8/
 150       DATA BTYP   /'SUB','SEQ','REP','RPC','RPS','DRB','DRP','DRS'/
 151       DATA IOK    /  -1 ,  -1 ,  -1 ,  -1 ,  -1 ,   0 ,   0 ,   0 /
 152
 153 C----------------------------------------------------------------------
 154 C     For now, set PICKY (see below) to always be .FALSE.
 155       PICKY = .FALSE.
 156       COND(1) = '='
 157       COND(2) = '!'
 158       COND(3) = '<'
 159       COND(4) = '>'
 160       COND(5) = '^'
 161       COND(6) = '#'
 162       NCOND   = 6
 163 C----------------------------------------------------------------------
 164
 165       ATAG  = ' '
 166       ATYP  = ' '
 167       KON   = 0
 168       NOD   = 0
 169       VAL   = 0
 170       LTG   = MIN(20,LEN(UTG))
 171
 172 C  PARSE UTG, SAVING INTO ATAG ONLY CHARACTERS PRIOR TO CONDITION CHAR.
 173 C  --------------------------------------------------------------------
 174
 175 C     But first, take care of the special case where UTG denotes the
 176 C     short (i.e. 1-bit) delayed replication of a Table D mnemonic.
 177 C     This will prevent confusion later on since '<' and '>' are each
 178 C     also valid as condition characters.
 179
 180       IF((UTG(1:1).EQ.'<').AND.(INDEX(UTG(3:),'>').NE.0)) THEN
 181          ATAG = UTG
 182          GO TO 1
 183       ENDIF
 184
 185       DO I=1,LTG
 186       IF(UTG(I:I).EQ.' ') GOTO 1
 187       DO J=1,NCOND
 188       IF(UTG(I:I).EQ.COND(J)) THEN
 189          KON = J
 190          ICV = I+1
 191          GOTO 1
 192       ENDIF
 193       ENDDO
 194       ATAG(I:I) = UTG(I:I)
 195       ENDDO
 196
 197 C  FIND THE NODE ASSOCIATED WITH ATAG IN THE SUBSET TABLE
 198 C  ------------------------------------------------------
 199
 200 1     INOD = INODE(LUN)
 201       DO NOD=INOD,ISC(INOD)
 202       IF(ATAG.EQ.TAG(NOD)) GOTO 2
 203       ENDDO
 204
 205 C  ATAG NOT FOUND IN SUBSET TABLE
 206 C  ------------------------------
 207
 208 C     So what do we want to do?  We could be "picky" and abort right
 209 C     here, or we could allow for the possibility that, e.g. a user
 210 C     application has been streamlined to always call UFBINT with the
 211 C     same STR, even though some of the mnemonics contained within that
 212 C     STR may not exist within the sequence definition of every
 213 C     possible type/subtype that is being written by the application.
 214 C     In such cases, by not being "picky", we could just allow BUFRLIB
 215 C     to subsequently (and quietly, if IPRT happened to be set to -1
 216 C     in COMMON /QUIET/!) not actually store the value corresponding
 217 C     to such mnemonics, rather than loudly complaining and aborting.
 218
 219       IF(KON.EQ.0 .AND. (IO.EQ.0.OR.ATAG.EQ.'NUL'.OR..NOT.PICKY)) THEN
 220 C        i.e. (if this tag does not contain any condition characters)
 221 C                 .AND.
 222 C             ((either the file is open for input) .OR.
 223 C              (the tag consists of 'NUL') .OR.
 224 C              (we aren't being "picky"))
 225          NOD = 0
 226          GOTO 100
 227       ELSE
 228 C        abort...
 229          GOTO 900
 230       ENDIF
 231
 232 C  ATAG IS FOUND IN SUBSET TABLE, MAKE SURE IT HAS A VALID NODE TYPE
 233 C  -----------------------------------------------------------------
 234
 235 2     IF(KON.EQ.5) THEN
 236 c  .... Cond. char "^" must be assoc. with a delayed replication
 237 c       sequence (this is a "bump" node) (Note: This is obsolete but
 238 c       remains for "old" programs using the BUFR ARCHIVE LIBRARY)
 239          IF(TYP(NOD-1).NE.'DRP' .AND. TYP(NOD-1).NE.'DRS') GOTO 901
 240       ELSEIF(KON.NE.6) THEN
 241 C        Allow reading (but not writing) of delayed replication factors.
 242          ATYP = TYP(NOD)
 243          DO I=1,NCHK
 244            IF(ATYP.EQ.BTYP(I) .AND. IO.GT.IOK(I)) GOTO 902
 245          ENDDO
 246       ENDIF
 247
 248 C  IF CONDITION NODE, GET CONDITION VALUE WHICH IS A NUMBER FOLLOWING IT
 249 C  ---------------------------------------------------------------------
 250
 251       IF(KON.NE.0) THEN
 252          CALL STRNUM(UTG(ICV:LTG),NUM)
 253          IF(NUM.LT.0) GOTO 903
 254          VAL = NUM
 255       ENDIF
 256
 257 C  EXITS
 258 C  -----
 259
 260 100   RETURN
 261 900   WRITE(BORT_STR1,'("BUFRLIB: PARUTG - TRYING TO WRITE A MNEMONIC'//
 262      . ' (",A,") WHICH DOES NOT EXIST IN SUBSET TABLE")') ATAG
 263       WRITE(BORT_STR2,'(18X,"(UPON INPUT, IT CONTAINED THE CONDITION '//
 264      . 'CHARACTER ",A,")")') UTG(ICV-1:ICV-1)
 265       CALL BORT2(BORT_STR1,BORT_STR2)
 266 901   WRITE(BORT_STR1,'("BUFRLIB: PARUTG - BUMP NODE (MNEMONIC ",A,")'//
 267      . ' MUST REFER TO A DELAYED REPLICATION SEQUENCE, HERE TYPE IS "'//
 268      . ',A)') ATAG,TYP(NOD-1)
 269       CALL BORT(BORT_STR1)
 270 902   WRITE(BORT_STR1,'("BUFRLIB: PARUTG - ILLEGAL NODE TYPE: ",A," '//
 271      . 'FOR MNEMONIC ",A)') ATYP,ATAG
 272       CALL BORT(BORT_STR1)
 273 903   WRITE(BORT_STR1,'("BUFRLIB: PARUTG - CONDITION VALUE IN '//
 274      . 'MNEMONIC ",A," ILLEGAL BECAUSE ALL OTHER CHARACTERS IN '//
 275      . 'MNEMONIC MUST BE NUMERIC")') UTG
 276       CALL BORT(BORT_STR1)
 277       END