NCEPLIBS-bufr  11.6.0
 All Data Structures Files Functions Variables Pages
rdusdx.f
Go to the documentation of this file.
1 C> @file
2 C> @author WOOLLEN @date 1994-01-06
3 
4 C> THIS SUBROUTINE READS AND PARSES A FILE CONTAINING A USER-
5 C> SUPPLIED BUFR DICTIONARY TABLE IN CHARACTER FORMAT, AND THEN STORES
6 C> THIS INFORMATION INTO INTERNAL ARRAYS IN MODULE TABABD (SEE REMARKS
7 C> FOR CONTENTS OF INTERNAL ARRAYS). THIS SUBROUTINE PERFORMS
8 C> A FUNCTION SIMILAR TO BUFR ARCHIVE LIBRARY SUBROUTINE RDBFDX,
9 C> EXECPT THAT RDBFDX READS THE BUFR TABLE DIRECTLY FROM MESSAGES AT
10 C> BEGINNING OF AN INPUT BUFR FILE.
11 C>
12 C> PROGRAM HISTORY LOG:
13 C> 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR
14 C> 1995-06-28 J. WOOLLEN -- INCREASED THE SIZE OF INTERNAL BUFR TABLE
15 C> ARRAYS IN ORDER TO HANDLE BIGGER FILES
16 C> 1996-12-17 J. WOOLLEN -- FIXED FOR SOME MVS COMPILER'S TREATMENT OF
17 C> INTERNAL READS (INCREASES PORTABILITY)
18 C> 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE
19 C> "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB
20 C> ROUTINE "BORT"; CORRECTED SOME MINOR ERRORS
21 C> 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE
22 C> OPENED AT ONE TIME INCREASED FROM 10 TO 32
23 C> (NECESSARY IN ORDER TO PROCESS MULTIPLE
24 C> BUFR FILES UNDER THE MPI)
25 C> 2003-11-04 J. ATOR -- ADDED DOCUMENTATION
26 C> 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE
27 C> INTERDEPENDENCIES
28 C> 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED HISTORY
29 C> DOCUMENTATION; OUTPUTS MORE COMPLETE
30 C> DIAGNOSTIC INFO WHEN ROUTINE TERMINATES
31 C> ABNORMALLY; CHANGED CALL FROM BORT TO BORT2
32 C> 2006-04-14 D. KEYSER -- ABORTS IF A USER-DEFINED MESSAGE TYPE "011"
33 C> IS READ (EITHER DIRECTLY FROM A TABLE A
34 C> MNEMONIC OR FROM THE "Y" VALUE OF A TABLE A
35 C> FXY SEQUENCE DESCRIPTOR), MESSAGE TYPE
36 C> "011" IS RESERVED FOR DICTIONARY MESSAGES
37 C> (PREVIOUSLY WOULD STORE DATA WITH MESSAGE
38 C> TYPE "011" BUT SUCH MESSAGES WOULD BE
39 C> SKIPPED OVER WHEN READ)
40 C> 2007-01-19 J. ATOR -- MODIFIED IN RESPONSE TO NUMBCK CHANGES
41 C> 2009-03-23 J. ATOR -- INCREASE SIZE OF BORT_STR2; USE STNTBIA
42 C> 2013-01-08 J. WHITING -- ADD ERR= OPTION TO READ STATEMENT
43 C> 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS
44 C>
45 C> USAGE: CALL RDUSDX (LUNDX, LUN)
46 C> INPUT ARGUMENT LIST:
47 C> LUNDX - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR USER-
48 C> SUPPLIED BUFR DICTIONARY TABLE IN CHARACTER FORMAT
49 C> LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS
50 C>
51 C> INPUT FILES:
52 C> UNIT "LUNDX" - USER-SUPPLIED BUFR DICTIONARY TABLE IN CHARACTER
53 C> FORMAT
54 C>
55 C> REMARKS:
56 C>
57 C> THIS ROUTINE CALLS: BORT2 DXINIT ELEMDX IGETNTBI
58 C> MAKESTAB NEMOCK NUMBCK SEQSDX
59 C> STNTBI STNTBIA
60 C> THIS ROUTINE IS CALLED BY: CKTABA READDX
61 C> Normally not called by any application
62 C> programs.
63 C>
64  SUBROUTINE rdusdx(LUNDX,LUN)
65 
66  USE moda_tababd
67 
68  CHARACTER*128 bort_str1
69  CHARACTER*156 bort_str2
70  CHARACTER*80 card
71  CHARACTER*8 nemo
72  CHARACTER*6 numb,nmb2
73 
74 C-----------------------------------------------------------------------
75 C-----------------------------------------------------------------------
76 
77 C INITIALIZE THE DICTIONARY TABLE CONTROL WORD PARTITION ARRAYS
78 C WITH APRIORI TABLE B AND D ENTRIES
79 C --------------------------------------------------------------
80 
81  CALL dxinit(lun,1)
82  rewind lundx
83 
84 C READ USER CARDS UNTIL THERE ARE NO MORE
85 C ---------------------------------------
86 
87 1 READ(lundx,'(A80)',end=200,err=200) card
88 
89 C REREAD IF NOT A DEFINITION CARD
90 C -------------------------------
91 
92 c .... This is a comment line
93  IF(card(1: 1).EQ. '*') goto 1
94 c .... This is a separation line
95  IF(card(3:10).EQ.'--------') goto 1
96 c .... This is a blank line
97  IF(card(3:10).EQ.' ') goto 1
98 c .... This is a header line
99  IF(card(3:10).EQ.'MNEMONIC') goto 1
100 c .... This is a header line
101  IF(card(3:10).EQ.'TABLE D') goto 1
102 c .... This is a header line
103  IF(card(3:10).EQ.'TABLE B') goto 1
104 
105 C PARSE A DESCRIPTOR DEFINITION CARD
106 C ----------------------------------
107 
108  IF(card(12:12).EQ.'|' .AND. card(21:21).EQ.'|') THEN
109 
110 c .... NEMO is the 8-character mnemonic name
111  nemo = card(3:10)
112  iret=nemock(nemo)
113  IF(iret.EQ.-1) goto 900
114  IF(iret.EQ.-2) goto 901
115 
116 c .... NUMB is the 6-character FXY value corresponding to NEMO
117  numb = card(14:19)
118  nmb2 = numb
119  IF(nmb2(1:1).EQ.'A') nmb2(1:1) = '3'
120  iret=numbck(nmb2)
121  IF(iret.EQ.-1) goto 902
122  IF(iret.EQ.-2) goto 903
123  IF(iret.EQ.-3) goto 904
124  IF(iret.EQ.-4) goto 905
125 
126 C TABLE A DESCRIPTOR FOUND
127 C ------------------------
128 
129  IF(numb(1:1).EQ.'A') THEN
130  n = igetntbi( lun, 'A' )
131  CALL stntbia( n, lun, numb, nemo, card(23:) )
132  IF ( idna(n,lun,1) .EQ. 11 ) goto 906
133 c .... Replace "A" with "3" so Table D descriptor will be found in
134 c .... card as well (see below)
135  numb(1:1) = '3'
136  ENDIF
137 
138 C TABLE B DESCRIPTOR FOUND
139 C ------------------------
140 
141  IF(numb(1:1).EQ.'0') THEN
142  CALL stntbi( igetntbi(lun,'B'), lun, numb, nemo, card(23:) )
143  goto 1
144  ENDIF
145 
146 C TABLE D DESCRIPTOR FOUND
147 C ------------------------
148 
149  IF(numb(1:1).EQ.'3') THEN
150  CALL stntbi( igetntbi(lun,'D'), lun, numb, nemo, card(23:) )
151  goto 1
152  ENDIF
153 
154 c .... First character of NUMB is not 'A', '0' or '3'
155  goto 902
156 
157  ENDIF
158 
159 C PARSE A SEQUENCE DEFINITION CARD
160 C --------------------------------
161 
162  IF(card(12:12).EQ.'|' .AND. card(19:19).NE.'|') THEN
163  CALL seqsdx(card,lun)
164  goto 1
165  ENDIF
166 
167 C PARSE AN ELEMENT DEFINITION CARD
168 C --------------------------------
169 
170  IF(card(12:12).EQ.'|' .AND. card(19:19).EQ.'|') THEN
171  CALL elemdx(card,lun)
172  goto 1
173  ENDIF
174 
175 C CAN'T FIGURE OUT WHAT KIND OF CARD IT IS
176 C ----------------------------------------
177 
178  goto 907
179 
180 C NORMAL ENDING
181 C -------------
182 
183 200 CALL makestab
184 
185 C EXITS
186 C -----
187 
188  RETURN
189 900 WRITE(bort_str1,'("BUFRLIB: RDUSDX - CARD READ IN IS: ",A)') card
190  WRITE(bort_str2,'(18X,"MNEMONIC ",A," IN USER DICTIONARY IS NOT'//
191  . ' BETWEEN 1 AND 8 CHARACTERS")') nemo
192  CALL bort2(bort_str1,bort_str2)
193 901 WRITE(bort_str1,'("BUFRLIB: RDUSDX - CARD READ IN IS: ",A)') card
194  WRITE(bort_str2,'(18X,"MNEMONIC ",A," IN USER DICTIONARY HAS '//
195  . 'INVALID CHARACTERS")') nemo
196  CALL bort2(bort_str1,bort_str2)
197 902 WRITE(bort_str1,'("BUFRLIB: RDUSDX - CARD READ IN IS: ",A)') card
198  WRITE(bort_str2,'(18X,"DESCRIPTOR NUMBER ",A," IN USER '//
199  . 'DICTIONARY HAS AN INVALID FIRST CHARACTER (F VALUE) - MUST BE'//
200  . ' A, 0 OR 3")') numb
201  CALL bort2(bort_str1,bort_str2)
202 903 WRITE(bort_str1,'("BUFRLIB: RDUSDX - CARD READ IN IS: ",A)') card
203  WRITE(bort_str2,'(18X,"DESCRIPTOR NUMBER ",A," IN USER '//
204  . 'DICTIONARY HAS NON-NUMERIC VALUES IN CHARACTERS 2-6 (X AND Y '//
205  . 'VALUES)")') numb
206  CALL bort2(bort_str1,bort_str2)
207 904 WRITE(bort_str1,'("BUFRLIB: RDUSDX - CARD READ IN IS: ",A)') card
208  WRITE(bort_str2,'(18X,"DESCRIPTOR NUMBER ",A," IN USER '//
209  . 'DICTIONARY HAS INVALID NUMBER IN CHARACTERS 2-3 (X VALUE) - '//
210  . 'MUST BE BETWEEN 00 AND 63")') numb
211  CALL bort2(bort_str1,bort_str2)
212 905 WRITE(bort_str1,'("BUFRLIB: RDUSDX - CARD READ IN IS: ",A)') card
213  WRITE(bort_str2,'(18X,"DESCRIPTOR NUMBER ",A," IN USER '//
214  . 'DICTIONARY HAS INVALID NUMBER IN CHARACTERS 4-6 (Y VALUE) - '//
215  . 'MUST BE BETWEEN 000 AND 255")') numb
216  CALL bort2(bort_str1,bort_str2)
217 906 WRITE(bort_str1,'("BUFRLIB: RDUSDX - CARD READ IN IS: ",A)') card
218  WRITE(bort_str2,'(18X,"USER-DEFINED MESSAGE TYPE ""011"" IS '//
219  . 'RESERVED FOR DICTIONARY MESSAGES")')
220  CALL bort2(bort_str1,bort_str2)
221 907 WRITE(bort_str1,'("BUFRLIB: RDUSDX - CARD READ IN IS: ",A)') card
222  WRITE(bort_str2,'(18X,"THIS CARD HAS A BAD FORMAT - IT IS NOT '//
223  . 'RECOGNIZED BY THIS SUBROUTINE")')
224  CALL bort2(bort_str1,bort_str2)
225 
226  END
subroutine seqsdx(CARD, LUN)
THIS SUBROUTINE DECODES THE TABLE D SEQUENCE INFORMATION FROM A MNEMONIC DEFINITION CARD THAT WAS PRE...
Definition: seqsdx.f:39
function numbck(NUMB)
THIS FUNCTION CHECKS THE INPUT CHARACTER STRING TO DETERMINE WHETHER IT CONTAINS A VALID FXY (DESCRIP...
Definition: numbck.f:46
subroutine bort2(STR1, STR2)
This subroutine calls subroutine errwrt() to log two error messages, then calls subroutine bort_exit(...
Definition: bort2.f:22
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
This module contains array and variable declarations used to store DX BUFR tables internally for mult...
Definition: moda_tababd.F:10
subroutine dxinit(LUN, IOI)
THIS SUBROUTINE INITIALIZES THE INTERNAL ARRAYS (IN MODULE TABABD) HOLDING THE DICTIONARY TABLE...
Definition: dxinit.f:40
subroutine makestab
THIS SUBROUTINE CONSTRUCTS AN INTERNAL JUMP/LINK TABLE WITHIN MODULE TABLES, USING THE INFORMATION WI...
Definition: makestab.f:74
function igetntbi(LUN, CTB)
This function returns the next available index for storing an entry within a specified internal DX BU...
Definition: igetntbi.f:27
subroutine stntbi(N, LUN, NUMB, NEMO, CELSQ)
THIS SUBROUTINE STORES A NEW ENTRY WITHIN INTERNAL BUFR TABLE B OR D, DEPENDING ON THE VALUE OF NUMB...
Definition: stntbi.f:27
subroutine rdusdx(LUNDX, LUN)
THIS SUBROUTINE READS AND PARSES A FILE CONTAINING A USER- SUPPLIED BUFR DICTIONARY TABLE IN CHARACTE...
Definition: rdusdx.f:64
subroutine elemdx(CARD, LUN)
THIS SUBROUTINE DECODES THE SCALE FACTOR, REFERENCE VALUE, BIT WIDTH AND UNITS (I.E., THE "ELEMENTS") FROM A TABLE B MNEMONIC DEFINITION CARD THAT WAS PREVIOUSLY READ FROM A USER-SUPPLIED BUFR DICTIONARY TABLE FILE IN CHARACTER FORMAT BY BUFR ARCHIVE LIBRARY SUBROUTINE RDUSDX.
Definition: elemdx.f:47
subroutine stntbia(N, LUN, NUMB, NEMO, CELSQ)
THIS SUBROUTINE STORES A NEW ENTRY WITHIN INTERNAL BUFR TABLE A.
Definition: stntbia.f:27