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