NCEPLIBS-bufr  11.5.0
 All Data Structures Files Functions Variables Pages
seqsdx.f
Go to the documentation of this file.
1 C> @file
2 C> @author WOOLLEN @date 1994-01-06
3 
4 C> THIS SUBROUTINE DECODES THE TABLE D SEQUENCE INFORMATION
5 C> FROM A MNEMONIC DEFINITION CARD THAT WAS PREVIOUSLY READ FROM A
6 C> USER-SUPPLIED BUFR DICTIONARY TABLE IN CHARACTER FORMAT BY BUFR
7 C> ARCHIVE LIBRARY SUBROUTINE RDUSDX. THESE ARE THEN ADDED TO THE
8 C> ALREADY-EXISTING ENTRY FOR THAT MNEMONIC (BUILT IN RDUSDX) WITHIN
9 C> THE INTERNAL BUFR TABLE D ARRAY TABD(*,LUN) IN MODULE TABABD.
10 C>
11 C> PROGRAM HISTORY LOG:
12 C> 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR
13 C> 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE
14 C> "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB
15 C> ROUTINE "BORT"
16 C> 2003-11-04 J. ATOR -- ADDED DOCUMENTATION
17 C> 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE
18 C> INTERDEPENDENCIES
19 C> 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED HISTORY
20 C> DOCUMENTATION; OUTPUTS MORE COMPLETE
21 C> DIAGNOSTIC INFO WHEN ROUTINE TERMINATES
22 C> ABNORMALLY; CHANGED CALL FROM BORT TO BORT2
23 C> 2007-01-19 J. ATOR -- REPLACED CALL TO PARSEQ WITH CALL TO PARSTR
24 C>
25 C> USAGE: CALL SEQSDX (CARD, LUN)
26 C> INPUT ARGUMENT LIST:
27 C> CARD - CHARACTER*80: MNEMONIC DEFINITION CARD THAT WAS READ
28 C> FROM A USER-SUPPLIED BUFR DICTIONARY TABLE
29 C> LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS
30 C>
31 C> REMARKS:
32 C> THIS ROUTINE CALLS: ADN30 BORT2 NEMOCK NEMTAB
33 C> NUMTAB PARSTR PKTDD RSVFVM
34 C> STRNUM
35 C> THIS ROUTINE IS CALLED BY: RDUSDX
36 C> Normally not called by any application
37 C> programs.
38 C>
39  SUBROUTINE seqsdx(CARD,LUN)
40 
41 
42 
43  COMMON /reptab/ idnr(5,2),typs(5,2),reps(5,2),lens(5)
44 
45  CHARACTER*128 bort_str1,bort_str2
46  CHARACTER*80 card,seqs
47  CHARACTER*12 atag,tags(250)
48  CHARACTER*8 nemo,nema,nemb
49  CHARACTER*6 adn30,clemon
50  CHARACTER*3 typs
51  CHARACTER*1 reps,tab
52 
53  DATA maxtgs /250/
54  DATA maxtag /12/
55 
56 C-----------------------------------------------------------------------
57 C-----------------------------------------------------------------------
58 
59 C FIND THE SEQUENCE TAG IN TABLE D AND PARSE THE SEQUENCE STRING
60 C --------------------------------------------------------------
61 
62  nemo = card( 3:10)
63  seqs = card(14:78)
64 
65 C Note that an entry for this mnemonic should already exist within
66 C the internal BUFR Table D array TABD(*,LUN); this entry should
67 C have been created by subroutine RDUSDX when the mnemonic and its
68 C associated FXY value and description were initially defined
69 C within a card read from the "Descriptor Definition" section at
70 C the top of the user-supplied BUFR dictionary table in character
71 C format. Now, we need to retrieve the positional index for that
72 C entry within TABD(*,LUN) so that we can access the entry and then
73 C add the decoded sequence information to it.
74 
75  CALL nemtab(lun,nemo,idn,tab,iseq)
76  IF(tab.NE.'D') goto 900
77  CALL parstr(seqs,tags,maxtgs,ntag,' ',.true.)
78  IF(ntag.EQ.0 ) goto 901
79 
80  DO n=1,ntag
81  atag = tags(n)
82  irep = 0
83 
84 C CHECK FOR REPLICATOR
85 C --------------------
86 
87  DO i=1,5
88  IF(atag(1:1).EQ.reps(i,1)) THEN
89 
90 C Note that REPS(*,*), which contains all of the symbols used to
91 C denote all of the various replication schemes that are
92 C possible within a user-supplied BUFR dictionary table in
93 C character format, was previously defined within subroutine
94 C BFRINI.
95 
96  DO j=2,maxtag
97  IF(atag(j:j).EQ.reps(i,2)) THEN
98  IF(j.EQ.maxtag) goto 902
99 
100 C Note that subroutine STRNUM will return NUMR = 0 if the
101 C string passed to it contains all blanks (as *should* be the
102 C case whenever I = 2 '(' ')', 3 '{' '}', 4 '[' ']', or
103 C 5 '<' '>').
104 
105 C However, when I = 1 '"' '"', then subroutine STRNUM will
106 C return NUMR = (the number of replications for the mnemonic
107 C using F=1 "regular" (i.e. non-delayed) replication).
108 
109  CALL strnum(atag(j+1:maxtag),numr)
110  IF(i.EQ.1 .AND. numr.LE.0 ) goto 903
111  IF(i.EQ.1 .AND. numr.GT.255) goto 904
112  IF(i.NE.1 .AND. numr.NE.0 ) goto 905
113  atag = atag(2:j-1)
114  irep = i
115  goto 1
116  ENDIF
117  ENDDO
118  goto 902
119  ENDIF
120  ENDDO
121 
122 C CHECK FOR VALID TAG
123 C -------------------
124 
125 1 iret=nemock(atag)
126  IF(iret.EQ.-1) goto 906
127  IF(iret.EQ.-2) goto 907
128  CALL nemtab(lun,atag,idn,tab,iret)
129  IF(iret.GT.0) THEN
130 
131 C Note that the next code line checks that we are not trying to
132 C replicate a Table B mnemonic (which is currently not allowed).
133 C The logic works because, for replicated mnemonics, IREP = I =
134 C (the index within REPS(*,*) of the symbol associated with the
135 C type of replication in question (e.g. "{, "<", etc.))
136 
137  IF(tab.EQ.'B' .AND. irep.NE.0) goto 908
138  IF(atag(1:1).EQ.'.') THEN
139 
140 C This mnemonic is a "following value" mnemonic
141 C (i.e. it relates to the mnemonic that immediately
142 C follows it within the user-supplied character-format BUFR
143 C dictionary table sequence), so confirm that it contains, as
144 C a substring, this mnemonic that immediately follows it.
145 
146  nemb = tags(n+1)
147 c .... get NEMA from IDN
148  CALL numtab(lun,idn,nema,tab,itab)
149  CALL nemtab(lun,nemb,jdn,tab,iret)
150  CALL rsvfvm(nema,nemb)
151  IF(nema.NE.atag) goto 909
152 c .... DK: I don't think the next test can ever be satisfied
153 c .... should probably be IF(N.EQ.NTAG ) GOTO 910
154  IF(n.GT.ntag ) goto 910
155  IF(tab.NE.'B') goto 911
156  ENDIF
157  ELSE
158  goto 912
159  ENDIF
160 
161 C WRITE THE DESCRIPTOR STRING INTO TABD ARRAY
162 C -------------------------------------------
163 c .... first look for a replication descriptor
164  IF(irep.GT.0) CALL pktdd(iseq,lun,idnr(irep,1)+numr,iret)
165  IF(iret.LT.0) goto 913
166  CALL pktdd(iseq,lun,idn,iret)
167  IF(iret.LT.0) goto 914
168 
169  ENDDO
170 
171 C EXITS
172 C -----
173 
174  RETURN
175 900 WRITE(bort_str1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') card
176  WRITE(bort_str2,'(18X,"MNEMONIC ",A," IS NOT A TABLE D ENTRY '//
177  . '(UNDEFINED, TAB=",A,")")') nemo,tab
178  CALL bort2(bort_str1,bort_str2)
179 901 WRITE(bort_str1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') card
180  WRITE(bort_str2,'(18X,"TABLE D SEQUENCE (PARENT) MNEMONIC ",A,'//
181  . '" DOES NOT CONTAIN ANY CHILD MNEMONICS")') nemo
182  CALL bort2(bort_str1,bort_str2)
183 902 WRITE(bort_str1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') card
184  WRITE(bort_str2,'(18X,"TABLE D SEQUENCE (PARENT) MNEMONIC ",A,'//
185  . '" CONTAINS A BADLY FORMED CHILD MNEMONIC",A)') nemo,tags(n)
186  CALL bort2(bort_str1,bort_str2)
187 903 WRITE(bort_str1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') card
188  WRITE(bort_str2,'(9X,"TBL D MNEM. ",A," CONTAINS REG. REPL. '//
189  . 'CHILD MNEM. ",A," W/ INVALID # OF REPLICATIONS (",I3,") AFTER'//
190  . ' 2ND QUOTE")') nemo,tags(n),numr
191  CALL bort2(bort_str1,bort_str2)
192 904 WRITE(bort_str1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') card
193  WRITE(bort_str2,'(18X,"TBL D MNEM. ",A," CONTAINS REG. REPL. '//
194  . 'CHILD MNEM. ",A," W/ # OF REPLICATIONS (",I3,") > LIMIT OF '//
195  . '255")') nemo,tags(n),numr
196  CALL bort2(bort_str1,bort_str2)
197 905 WRITE(bort_str1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') card
198  WRITE(bort_str2,'(18X,"TBL D MNEM. ",A," CONTAINS DELAYED REPL.'//
199  . ' CHILD MNEM. ",A," W/ # OF REPL. (",I3,") SPECIFIED - A NO-'//
200  . 'NO")') nemo,tags(n),numr
201  CALL bort2(bort_str1,bort_str2)
202 906 WRITE(bort_str1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') card
203  WRITE(bort_str2,'(18X,"TABLE D (PARENT) MNEMONIC ",A," CONTAINS'//
204  .' A CHILD MNEMONIC ",A," NOT BETWEEN 1 & 8 CHARACTERS")')
205  . nemo,tags(n)
206  CALL bort2(bort_str1,bort_str2)
207 907 WRITE(bort_str1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') card
208  WRITE(bort_str2,'(18X,"TABLE D (PARENT) MNEMONIC ",A," CONTAINS'//
209  . ' A CHILD MNEMONIC ",A," WITH INVALID CHARACTERS")') nemo,tags(n)
210  CALL bort2(bort_str1,bort_str2)
211 908 WRITE(bort_str1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') card
212  WRITE(bort_str2,'(18X,"TABLE D (PARENT) MNEMONIC ",A," CONTAINS'//
213  . ' A REPLICATED CHILD TABLE B MNEMONIC ",A," - A NO-NO")')
214  . nemo,tags(n)
215  CALL bort2(bort_str1,bort_str2)
216 909 WRITE(bort_str1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') card
217  WRITE(bort_str2,'(18X,"TBL D (PARENT) MNEM. ",A," CONTAINS AN '//
218  . 'INVALID ''FOLLOWING VALUE'' MNEMONIC ",A,"(SHOULD BE ",A,")")')
219  . nemo,tags(n),nema
220  CALL bort2(bort_str1,bort_str2)
221 910 WRITE(bort_str1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') card
222  WRITE(bort_str2,'(18X,"TBL D (PARENT) MNEM. ",A," CONTAINS A '//
223  . '''FOLLOWING VALUE'' MNEMONIC ",A," WHICH IS LAST IN THE '//
224  . 'STRING")') nemo,nema
225  CALL bort2(bort_str1,bort_str2)
226 911 WRITE(bort_str1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') card
227  WRITE(bort_str2,'(18X,"TBL D (PARENT) MNEM. ",A,", THE MNEM. ",'//
228  . 'A," FOLLOWING A ''FOLLOWING VALUE'' MNEM. IS NOT A TBL B '//
229  . 'ENTRY")') nemo,nemb
230  CALL bort2(bort_str1,bort_str2)
231 912 WRITE(bort_str1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') card
232  WRITE(bort_str2,'(18X,"TABLE D SEQUENCE (PARENT) MNEMONIC ",A,'//
233  . '" CONTAINS A CHILD MNEMONIC ",A," NOT FOUND IN ANY TABLE")')
234  . nemo,tags(n)
235  CALL bort2(bort_str1,bort_str2)
236 913 clemon = adn30(idnr(irep,1)+numr,6)
237  WRITE(bort_str1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') card
238  WRITE(bort_str2,'(9X,"TBL D (PARENT) MNEM. ",A," - BAD RETURN '//
239  . 'FROM PKTDD TRYING TO STORE REPL. DESC. ",A,", SEE PREV. '//
240  . 'WARNING MSG")') nemo,clemon
241  CALL bort2(bort_str1,bort_str2)
242 914 WRITE(bort_str1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') card
243  WRITE(bort_str2,'(9X,"TBL D (PARENT) MNEM. ",A," - BAD RETURN '//
244  . 'FROM PKTDD TRYING TO STORE CHILD MNEM. ",A,", SEE PREV. '//
245  . 'WARNING MSG")') nemo,tags(n)
246  CALL bort2(bort_str1,bort_str2)
247  END
subroutine numtab(LUN, IDN, NEMO, TAB, IRET)
THIS SUBROUTINE FIRST SEARCHES FOR AN INTEGER IDN, CONTAINING THE BIT-WISE REPRESENTATION OF A DESCRI...
Definition: numtab.f:106
subroutine seqsdx(CARD, LUN)
THIS SUBROUTINE DECODES THE TABLE D SEQUENCE INFORMATION FROM A MNEMONIC DEFINITION CARD THAT WAS PRE...
Definition: seqsdx.f:39
subroutine parstr(STR, TAGS, MTAG, NTAG, SEP, LIMIT80)
THIS SUBROUTINE PARSES A STRING CONTAINING ONE OR MORE SUBSTRINGS INTO AN ARRAY OF SUBSTRINGS...
Definition: parstr.f:37
subroutine bort2(STR1, STR2)
This subroutine calls subroutine errwrt() to log two error messages, then calls subroutine bort_exit(...
Definition: bort2.f:20
function nemock(NEMO)
THIS FUNCTION CHECKS A MNEMONIC TO VERIFY THAT IT HAS A LENGTH OF BETWEEN ONE AND EIGHT CHARACTERS AN...
Definition: nemock.f:36
subroutine strnum(STR, NUM)
THIS SUBROUTINE DECODES AN INTEGER FROM A CHARACTER STRING.
Definition: strnum.f:33
subroutine rsvfvm(NEM1, NEM2)
THIS SUBROUTINE STEPS THROUGH THE &quot;FOLLOWING VALUE&quot; MNEMONIC NEM1 AND, FOR EACH &quot;.&quot; CHARACTER ENCOUNTERED (EXCEPT FOR THE INITIAL ONE), OVERWRITES IT WITH THE NEXT CORRESPONDING CHARACTER FROM NEM2 (SEE REMARKS).
Definition: rsvfvm.f:40
character *(*) function adn30(IDN, L30)
This function converts a descriptor from its bit-wise (integer) representation to its 5 or 6 characte...
Definition: adn30.f:27
subroutine pktdd(ID, LUN, IDN, IRET)
THIS SUBROUTINE STORES INFORMATION ABOUT A &quot;CHILD&quot; MNEMONIC WITHIN THE INTERNAL BUFR TABLE D ENTRY (I...
Definition: pktdd.f:54
subroutine nemtab(LUN, NEMO, IDN, TAB, IRET)
THIS SUBROUTINE SEARCHES FOR MNEMONIC NEMO WITHIN THE INTERNAL TABLE B AND D ARRAYS HOLDING THE DICTI...
Definition: nemtab.f:66