NCEPLIBS-bufr  11.5.0
 All Data Structures Files Functions Variables Pages
readbp.f
Go to the documentation of this file.
1 C> @file
2 C> @brief Read prepbufr file and print each report one at a time
3 
4 C-----------------------------------------------------------------------
5 C READ AND DISPLAY AN ON29BUFR FILE ONE REPORT AT A TIME
6 C-----------------------------------------------------------------------
7  PROGRAM readbp
8 
9  CHARACTER*120 file
10  CHARACTER*40 hstr,ostr,qstr
11  CHARACTER*8 you,sid,sta,subset,msg,cmc(17)
12  CHARACTER*3 vars(8)
13  dimension hdr(10),obs(10,255),qms(10,255),qmc(17)
14  equivalence(hdr(1),sid)
15  equivalence(qmc,cmc)
16  LOGICAL window,steam,level
17  real*8 hdr,obs,qms,qmc
18 
19  DATA hstr/'SID XOB YOB DHR ELV T29 ITP TYP SRC PRG '/
20  DATA ostr/'CAT POB QOB TOB ZOB UOB VOB PSL '/
21  DATA qstr/'PQM QQM TQM ZQM WQM PSQ '/
22 
23  DATA vars/'LVL','CAT','POB','SPH','TOB','ZOB','UOB','VOB'/
24  DATA cmc /'0','1','2','3','4','5','6','7','8',
25  . '9','A','B','C','D','E','F','*'/
26 
27  DATA bmiss /10e10/
28  DATA lubfr /8 /
29  DATA sta /' '/
30  data msg /' '/
31  DATA pob /0/
32  data irt /0/
33  data itp /0/
34  data ikx /0/
35  DATA window /.false./
36  DATA steam /.false./
37  DATA level /.false./
38 
39 C-----------------------------------------------------------------------
40 C-----------------------------------------------------------------------
41 
42  iprt = 0
43  nsta = 8
44 
45  READ(4,'(A)',end=100) file; print*,file
46  read(4,'(a8)',end=1) sta
47  read(4,* ,end=1) pob
48  read(4,* ,end=1) ikx
49 1 steam = sta.ne.' '
50  level = pob.ne.0
51 
52 C OPEN THE BUFR INPUT FILE
53 C ------------------------
54 
55  OPEN(lubfr,file=file,form='UNFORMATTED')
56 
57  CALL openbf(lubfr,'IN',lubfr)
58  CALL readmg(lubfr,subset,idate,iret)
59  IF(iret.NE.0) goto 100
60  IF(.NOT.steam) print*,'READING DATA FOR ',idate
61 
62 C READ A SUBSET - READ ANOTHER MESSAGE WHEN NO MORE SUBSETS
63 C ---------------------------------------------------------
64 
65 10 CALL readsb(lubfr,iret)
66  IF(iret.NE.0) THEN
67  CALL readmg(lubfr,subset,idate,iret)
68  IF(iret.NE.0) goto 100
69  goto 10
70  ENDIF
71  CALL ufbcnt(lubfr,irec,isub)
72 
73 C MOVE SUBSET CONTENTS INTO THIS PROGRAM
74 C --------------------------------------
75 
76  CALL ufbint(lubfr,hdr,10, 1,iret,hstr)
77  xob = hdr(2)
78  yob = hdr(3)
79  jrt = hdr(6)
80  jtp = hdr(7)
81  jkx = hdr(8)
82  IF(sta.NE.' ' .AND. sta.NE.sid(1:nsta)) goto 10
83  IF(irt.ne.0 .and. irt.ne.jrt) goto 10
84  IF(itp.ne.0 .and. itp.ne.jtp) goto 10
85  IF(ikx.ne.0 .and. ikx.ne.jkx) goto 10
86  IF(msg.ne.' ' .and. msg.ne.subset) goto 10
87  IF(window) THEN
88  IF(.NOT.(xob.GE.x1 .AND. xob.LE.x2))goto 10
89  IF(.NOT.(yob.GE.y1 .AND. yob.LE.y2))goto 10
90  ENDIF
91 
92  CALL ufbint(lubfr,obs,10,255,nlev,ostr)
93  CALL ufbint(lubfr,qms,10,255,nleq,qstr)
94  IF(nlev.NE.nleq) stop 'NLEV<>NLEQ'
95 
96 C MOVE CAT 8 DATA TO PRINT RANGE
97 C ------------------------------
98  DO l=1,nlev
99  IF(obs(1,l).EQ.8) THEN
100  obs(2,l) = obs(9,l)
101  obs(3,l) = obs(10,l)
102  ENDIF
103  ENDDO
104 
105 C PRINT A REPORT 20 LINES AT A TIME
106 C ---------------------------------
107 
108  print'(80(''-''))'
109 
110  if(level) then
111 
112  print'(1x,a8,7(f8.2,1x))',(hdr(i),i=1,8)
113 
114  else
115 
116  print'(''MESSAGE: '',A8,2(2X,I4),i12 )' , subset,irec,isub,idate
117  print'(''STATION: '',A8,1X,2(F8.2,1X))' , (hdr(i),i= 1,3)
118  print'(''TIME: '',I10,2x,F8.2 )' , idate,hdr(4)
119  print'(''ELV: '',F8.2 )' , (hdr(5) )
120  print'(''PSL: '',F8.2,1X,A1 )' , obs(8,1),qms(6,1)
121  print'(''TYPE: '',3(F8.0,1X) )' , (hdr(i),i= 6,8)
122  print'(''SOURCE: '',3a8 )' , (hdr(i),i= 9,9)
123  print'(''SEQUENCE '',F10.0 )' , (hdr(10) )
124  print'(''DATA: '' )'
125 
126  endif
127 
128  do l=1,nlev
129  do i=1,7
130  iqm = qms(i,l)
131  if(iqm<0)iqm=10e8
132  iqm = min(iqm,16)
133  qms(i,l) = qmc(iqm+1)
134  enddo
135  enddo
136 
137  nlne = 7
138  print'(2(1X,A3),6(8X,A3))',vars
139  DO 12 l=1,nlev
140  dif = abs(obs(2,l)-pob)
141  if(level .and. dif.gt..01) goto 12
142  nlne = nlne+1
143  print11, l,nint(obs(1,l)),(obs(i,l),qms(min(i-1,5),l),i=2,7)
144 11 FORMAT(2i4,6(1x,f7.1,'(',a1,')'))
145 c IF(NLNE.EQ.20 .and. .not.steam) THEN
146 c READ(5,'(A1)') YOU
147 c CALL CAPIT(YOU)
148 c IF(YOU.EQ.'Q') STOP
149 c PRINT'(2(1X,A3),6(8X,A3))',VARS
150 c NLNE = 0
151 c ENDIF
152 12 ENDDO
153  print'(80(''-''))'
154  if(steam) goto 10
155 
156 C GO TO READ THE NEXT SUBSET IF NO 'Q' YOU
157 C ----------------------------------------
158 
159 99 READ(5,'(A8)') you
160  CALL capit(you)
161  IF(you.EQ.'Q') stop
162  IF(you.EQ.'S') THEN
163  READ(5,'(A8)') sta
164  DO i=1,8
165  IF(sta(i:i).NE.' ') nsta = i
166  ENDDO
167  ENDIF
168  IF(you.EQ.'R') READ(5,'(i3,1x,i2)') irt,itp
169  IF(you.EQ.'K') READ(5,'(i3)') ikx
170  IF(you.EQ.'M') READ(5,'(a8)') msg
171  IF(you.EQ.'W') READ(5,*) x1,x2,y1,y2
172  IF(you.EQ.'W') window = .true.
173  IF(you.EQ.'D') THEN
174  CALL ufdump(lubfr,6)
175  goto 99
176  ENDIF
177  IF(you.EQ.'E') THEN
178  CALL ufbdmp(lubfr,6)
179  goto 99
180  ENDIF
181  goto 10
182 
183 C HERE WHEN ALL MESSAGES HAVE BEEN READ
184 C -------------------------------------
185 
186 100 stop
187  END
188 C-----------------------------------------------------------------------
189 C SUBROUTINE CAPIT CAPITALIZES A STRING OF CHARACTERS
190 C-----------------------------------------------------------------------
191  SUBROUTINE capit(STR)
192 
193  CHARACTER*(*) str
194  CHARACTER*26 ups,los
195 
196  DATA ups /'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
197  DATA los /'abcdefghijklmnopqrstuvwxyz'/
198 
199 C-----------------------------------------------------------------------
200 C-----------------------------------------------------------------------
201 
202  n = len(str)
203 
204  DO 20 i=1,n
205  DO 10 j=1,26
206  IF(str(i:i).EQ.los(j:j)) THEN
207  str(i:i) = ups(j:j)
208  goto 20
209  ENDIF
210 10 CONTINUE
211 20 CONTINUE
212 
213  RETURN
214  END
215 C----------------------------------------------------------------------
216 C----------------------------------------------------------------------
217  SUBROUTINE xfdump(LUNIT,LUPRT)
218 
219  parameter( maxtba = 120 )
220  parameter( maxtbb = 500 )
221  parameter( maxtbd = 500 )
222  parameter( maxcd = 250 )
223  parameter( maxjl = 20000)
224  parameter( nfiles = 32 )
225  parameter( nf = 32 )
226 
227  COMMON /msgcwd/ nmsg(nf),nsub(nf),msub(nf),inode(nf),idate(nf)
228  COMMON /tables/ maxtab,ntab,tag(maxjl),typ(maxjl),knt(maxjl),
229  . jump(maxjl),link(maxjl),jmpb(maxjl),
230  . ibt(maxjl),irf(maxjl),isc(maxjl),
231  . itp(maxjl),vali(maxjl),knti(maxjl),
232  . iseq(maxjl,2),jseq(maxjl)
233  COMMON /usrint/ nval(nf),inv(maxjl,nf),val(maxjl,nf)
234  COMMON /tababd/ ntba(0:nfiles),ntbb(0:nfiles),ntbd(0:nfiles),
235  . mtab(maxtba,nfiles),idna(maxtba,nfiles,2),
236  . idnb(maxtbb,nfiles),idnd(maxtbd,nfiles),
237  . taba(maxtba,nfiles),tabb(maxtbb,nfiles),
238  . tabd(maxtbd,nfiles)
239 
240  CHARACTER*600 tabd
241  CHARACTER*128 tabb
242  CHARACTER*128 taba
243 
244  CHARACTER*80 fmt
245  CHARACTER*64 desc
246  CHARACTER*24 unit
247  CHARACTER*8 lchr
248  CHARACTER*10 tag,nemo
249  CHARACTER*6 numb
250  CHARACTER*8 cval,pmiss
251  CHARACTER*3 typ
252  CHARACTER*1 tab
253  equivalence(rval,cval)
254  REAL*8 val,rval,bmiss
255 
256  DATA bmiss / 10e10 /
257  DATA pmiss /' MISSING'/
258 
259 C----------------------------------------------------------------------
260 C----------------------------------------------------------------------
261 
262  if(luprt.eq.0) luout = 6
263  if(luprt.ne.0) luout = luprt
264 
265 C CHECK THE FILE STATUS AND I-NODE
266 C --------------------------------
267 
268  CALL status(lunit,lun,il,im)
269  IF(il.EQ.0) goto 900
270  IF(im.EQ.0) goto 901
271  IF(inode(lun).NE.inv(1,lun)) goto 902
272 
273  WRITE(luout,*)
274  WRITE(luout,*) 'MESSAGE TYPE ',tag(inode(lun))
275  WRITE(luout,*)
276 
277 C DUMP THE CONTENTS OF COMMON /USRINT/ FOR UNIT LUNIT
278 C ---------------------------------------------------
279 
280  DO nv=1,nval(lun)
281  node = inv(nv,lun)
282  nemo = tag(node)
283  ityp = itp(node)
284  IF(ityp.GE.1.AND.ityp.LE.3) THEN
285  CALL nemtab(lun,nemo,idn,tab,n)
286 C if(ityp.eq.1) call NUMTBD(LUN,IDN,NEMO,TAB,N)
287 C IF(TAB.NE.'B') CALL BORT('UFBDMP - BAD ITYP!')
288  numb = tabb(n,lun)(1:6)
289  desc = tabb(n,lun)(16:70)
290  unit = tabb(n,lun)(71:94)
291  rval = val(nv,lun)
292  ENDIF
293  IF(ityp.EQ.1.OR.ityp.EQ.2) THEN
294  IF(rval.NE.bmiss) THEN
295  fmt = '(A6,2X,A8,2X,F18.00,2X,A12,2x,a28)'
296  WRITE(fmt(18:19),'(I2)') max(1,isc(node))
297  WRITE(luout,fmt) numb,nemo,rval,unit,desc
298  ELSE
299  fmt = '(A6,2X,A8,2X,A18,2X,A12,2x,a28)'
300  WRITE(luout,fmt) numb,nemo,pmiss,unit,desc
301  ENDIF
302  ELSEIF(ityp.EQ.3) THEN
303  lchr = ' '
304  nchr = ibt(node)/8
305  lchr = cval
306  iret = rjust(lchr)
307  fmt = '(A6,2X,A8,2X,A18,2X,"(",i2,")",A8,2x,a28)'
308  WRITE(luout,fmt) numb,nemo,lchr,nchr,unit,desc
309  ENDIF
310  ENDDO
311 
312 C EXITS
313 C -----
314 
315  RETURN
316 900 CALL bort('UFDUMP - FILE IS CLOSED ')
317 901 CALL bort('UFDUMP - NO MESSAGE OPEN ')
318 902 CALL bort('UFDUMP - I-NODE MISMATCH ')
319  END
rjust
function rjust(STR)
THIS FUNCTION RIGHT JUSTIFIES A CHARACTER STRING.
Definition: rjust.f:29
openbf
subroutine openbf(LUNIT, IO, LUNDX)
This subroutine connects a new file to the BUFRLIB software for input or output operations.
Definition: openbf.F:157
status
subroutine status(LUNIT, LUN, IL, IM)
This subroutine checks whether a specified Fortran logical unit number is currently connected to the ...
Definition: status.f:61
ufbdmp
subroutine ufbdmp(LUNIN, LUPRT)
This subroutine prints a verbose listing of the contents of a data subset, including all data values ...
Definition: ufbdmp.f:82
ufbint
subroutine ufbint(LUNIN, USR, I1, I2, IRET, STR)
This subroutine reads or writes one or more data values from or to the BUFR data subset that is curre...
Definition: ufbint.f:160
ufbcnt
subroutine ufbcnt(LUNIT, KMSG, KSUB)
THIS SUBROUTINE RETURNS A COUNT OF THE CURRENT MESSAGE NUMBER AND SUBSET NUMBER, WHERE THE MESSAGE NU...
Definition: ufbcnt.f:55
ufdump
subroutine ufdump(LUNIT, LUPRT)
This subroutine prints a verbose listing of the contents of a data subset, including all data values ...
Definition: ufdump.f:71
nemtab
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
bort
subroutine bort(STR)
This subroutine calls subroutine errwrt() to log an error message, then calls subroutine bort_exit() ...
Definition: bort.f:23
readmg
subroutine readmg(LUNXX, SUBSET, JDATE, IRET)
This subroutine reads the next BUFR message from logical unit ABS(LUNXX) into internal arrays...
Definition: readmg.f:99
ups
REAL *8 function ups(IVAL, NODE)
THIS FUNCTION UNPACKS A REAL*8 USER VALUE FROM A PACKED BUFR INTEGER BY APPLYING THE PROPER SCALE AND...
Definition: ups.f:31
readsb
subroutine readsb(LUNIT, IRET)
This subroutine reads the next data subset from a BUFR message into internal arrays.
Definition: readsb.f:59
capit
subroutine capit(STR)
THIS SUBROUTINE CAPITALIZES A STRING OF CHARACTERS.
Definition: capit.f:39