NCEPLIBS-bufr 11.7.1
readbp.f90
1!-----------------------------------------------------------------------
2! READ AND DISPLAY AN ON29BUFR FILE ONE REPORT AT A TIME
3!-----------------------------------------------------------------------
4 PROGRAM readbp
5
6 character(120) :: FILE
7 character(50) :: optarg
8 character(40) :: HSTR,OSTR,QSTR
9 character(10) :: val
10 character(8) :: sid,sta,subset,msg,cmc(17)
11 character(3) :: vars(8)
12 integer :: iostat
13 real(8) :: hdr(10),obs(10,255),qms(10,255),qmc(17)
14 logical :: window,steam,level,dump,hedr,exist
15
16 equivalence(hdr(1),sid)
17 equivalence(qmc,cmc)
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','9','A','B','C','D','E','F','*'/
25
26 DATA bmiss /10d10/
27 DATA lubfr /8 /
28 DATA sta /' '/
29 data msg /' '/
30 DATA pob /0/
31 data irt /0/
32 data itp /0/
33 data ikx /0/
34 DATA window /.false./
35 DATA steam /.false./
36 DATA level /.false./
37 DATA dump /.false./
38 DATA hedr /.false./
39
40!-----------------------------------------------------------------------
41!-----------------------------------------------------------------------
42
43! check for filename argument
44
45 narg=iargc()
461 if(narg<1) THEN
47 call printx(' ')
48 call printx('Usage: readbp <-s> <-w> <m> <-k> <-r> <-d> <-n> <-h> prep bufrfile ')
49 call printx(' ')
50 call printx('Search filter and/or print prepbufr reports in various ways ')
51 call printx(' ')
52 call printx('-s "station_id " print reports where "station_id" matches the report id up to the len of "station_id" ')
53 call printx('-w "x1 x2 y1 y2" print reports within a lon/lat box ')
54 call printx('-m "subset " print reports with this subset name ')
55 call printx('-k "gsi rtype " print reports with this gsi report type ')
56 call printx('-r "on29 rtype " print reports with this on29 report type ')
57 call printx('-d print reports using ufdump - note: this works with any NCEP BUFR file ')
58 call printx('-n no pause between reports output ')
59 call printx('-h print only report headers ')
60 call printx(' ')
61 call printx('Only a filename is required in which case step through the reports one at a time using "enter" ')
62 call printx(' ')
63 call printx('Optional arguments can also be applied in the pause between reports output without using a dash ')
64 call printx(' ')
65 call printx('Optional arguments will be applied in concert in most cases ')
66 call printx(' ')
67 call exit(2)
68 ENDIF
69
70 iarg=1
71 do while(iarg<=narg)
72 call getarg(iarg,file)
73 if(file(1:1)=='-') then
74 if(file(2:2)=='s') then
75 iarg=iarg+1; call getarg(iarg,sta); nsta=len(trim(sta))
76 elseif(file(2:2)=='w') then
77 iarg=iarg+1; call getarg(iarg,val); read(val,*)x1
78 iarg=iarg+1; call getarg(iarg,val); read(val,*)x2
79 iarg=iarg+1; call getarg(iarg,val); read(val,*)y1
80 iarg=iarg+1; call getarg(iarg,val); read(val,*)y2
81 window=.true.
82 elseif(file(2:2)=='k') then
83 iarg=iarg+1; call getarg(iarg,val); read(val,*)ikx
84 elseif(file(2:2)=='r') then
85 iarg=iarg+1; call getarg(iarg,val); read(val,*)irt
86 elseif(file(2:2)=='m') then
87 iarg=iarg+1; call getarg(iarg,val); msg=val
88 elseif(file(2:2)=='d') then
89 iarg=iarg+1; dump=.true.
90 elseif(file(2:2)=='h') then
91 iarg=iarg+1; hedr=.true.
92 elseif(file(2:2)=='n') then
93 iarg=iarg+1; steam=.true.
94 else
95 iarg=iarg+1
96 endif
97 file='nofile'
98 cycle
99 endif
100 iarg=iarg+1
101 enddo
102
103
104! check if file exists, then open it, else abort
105
106 narg=0
107 if(file=='nofile') goto 1
108 file = trim(adjustl(file))
109 inquire(file=file,exist=exist)
110 if (.not.exist) call bort(trim(file)//' does not exist')
111
112! open the bufr input file
113! ------------------------
114
115 open(lubfr,file=file,form='unformatted')
116 call openbf(lubfr,'IN',lubfr)
117 call datelen(10)
118
119! READ A SUBSET - READ ANOTHER MESSAGE WHEN NO MORE SUBSETS
120! ---------------------------------------------------------
121
122 do while(ireadmg(lubfr,subset,idate)==0)
123 do while(ireadsb(lubfr)==0)
124 call ufbcnt(lubfr,irec,isub)
125
126 IF(msg.ne.' ' .and. msg.ne.subset) exit
127
128 if(dump) then
129 call ufdump(lubfr,6)
130 goto 99
131 endif
132
133! MOVE SUBSET CONTENTS INTO THIS PROGRAM
134! --------------------------------------
135
136 CALL ufbint(lubfr,hdr,10, 1,iret,hstr)
137 xob = hdr(2)
138 yob = hdr(3)
139 jrt = hdr(6)
140 jtp = hdr(7)
141 jkx = hdr(8)
142 IF(sta.NE.' ' .AND. sta.NE.sid(1:nsta)) cycle
143 IF(irt.ne.0 .and. irt.ne.jrt) cycle
144 IF(itp.ne.0 .and. itp.ne.jtp) cycle
145 IF(ikx.ne.0 .and. ikx.ne.jkx) cycle
146 IF(window) THEN
147 IF(.NOT.(xob.GE.x1 .AND. xob.LE.x2))cycle
148 IF(.NOT.(yob.GE.y1 .AND. yob.LE.y2))cycle
149 ENDIF
150
151 CALL ufbint(lubfr,obs,10,255,nlev,ostr)
152 CALL ufbint(lubfr,qms,10,255,nleq,qstr)
153 IF(nlev.NE.nleq) stop 'NLEV<>NLEQ'
154
155! MOVE CAT 8 DATA TO PRINT RANGE
156! ------------------------------
157 DO l=1,nlev
158 IF(obs(1,l).EQ.8) THEN
159 obs(2,l) = obs(9,l)
160 obs(3,l) = obs(10,l)
161 ENDIF
162 ENDDO
163
164! PRINT A REPORT 20 LINES AT A TIME
165! ---------------------------------
166
167 if(hedr) then
168 print'(a8,1x,a8,7(f8.2,1x))',subset,(hdr(i),i=1,8)
169 if(steam) cycle
170 goto 99
171
172 else
173
174 print'(80(''-''))'
175 print'(''MESSAGE: '',A8,2(2X,I4),i12 )' , subset,irec,isub,idate
176 print'(''STATION: '',A8,1X,2(F8.2,1X))' , (hdr(i),i= 1,3)
177 print'(''TIME: '',I10,2x,F8.2 )' , idate,hdr(4)
178 print'(''ELV: '',F8.2 )' , (hdr(5) )
179 print'(''TYPE: '',3(F8.0,1X) )' , (hdr(i),i= 6,8)
180 print'(''DATA: '' )'
181
182 endif
183
184 do l=1,nlev
185 do i=1,7
186 iqm = qms(i,l)
187 if(iqm<0)iqm=10e8
188 iqm = min(iqm,16)
189 qms(i,l) = qmc(iqm+1)
190 enddo
191 enddo
192
193 nlne = 7
194 print'(2(1X,A3),6(8X,A3))',vars
195 DO 12 l=1,nlev
196 nlne = nlne+1
197 print 11, l,nint(obs(1,l)),(obs(i,l),qms(min(i-1,5),l),i=2,7)
19811 FORMAT(2i4,6(1x,f7.1,'(',a1,')'))
19912 ENDDO
200 print'(80(''-''))'
201 if(steam) cycle
202
203! GO TO READ THE NEXT SUBSET IF NO 'Q' YOU
204! ----------------------------------------
205
20699 READ(5,'(a)',iostat=iostat) optarg
207 IF(optarg(1:1)=='q') then
208 stop
209 elseif(optarg(1:1)=='s') then
210 read(optarg(2:50),*) sta
211 nsta=len(trim(sta))
212 elseif(optarg(1:1)=='w') then
213 read(optarg(2:50),*) x1,x2,y1,y2
214 window=.true.
215 elseif(optarg(1:1)=='k') then
216 read(optarg(2:50),*) ikx
217 elseif(optarg(1:1)=='r') then
218 read(optarg(2:50),*) irt
219 elseif(optarg(1:1)=='m') then
220 read(optarg(2:50),*) msg
221 elseif(optarg(1:1)=='d') then
222 call ufdump(lubfr,6)
223 elseif(optarg(1:1)=='h') then
224 hedr=.true.
225 endif
226
227 enddo ! end of subset loop
228 enddo ! end of message loop
229
230! HERE WHEN ALL MESSAGES HAVE BEEN READ
231! -------------------------------------
232
233100 stop
234 END program
235!-----------------------------------------------------------------------
236! print long lines to stdout using advance=no format clause
237!-----------------------------------------------------------------------
238 subroutine printx(str)
239 character(*) :: str
240 lens=len(str)
241 do i=1,lens-1
242 write(*,'(a1)',advance="no")str(i:i)
243 enddo
244 write(*,'(a1)')str(lens:lens)
245 end subroutine
246
bort
subroutine bort(STR)
This subroutine calls subroutine errwrt() to log an error message, then calls subroutine bort_exit() ...
Definition: bort.f:23
datelen
subroutine datelen(LEN)
This subroutine is used to specify the format of Section 1 date-time values that will be output by fu...
Definition: datelen.f:36
ireadmg
function ireadmg(LUNIT, SUBSET, IDATE)
This function calls BUFRLIB subroutine readmg() and passes back its return code as the function value...
Definition: ireadmg.f:40
ireadsb
function ireadsb(LUNIT)
This function calls BUFRLIB subroutine readsb() and passes back its return code as the function value...
Definition: ireadsb.f:31
openbf
subroutine openbf(LUNIT, IO, LUNDX)
This subroutine connects a new file to the BUFRLIB software for input or output operations.
Definition: openbf.f:139
ufbcnt
subroutine ufbcnt(LUNIT, KMSG, KSUB)
This subroutine returns the current location of the file pointer within a BUFR file,...
Definition: ufbcnt.f:46
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:153
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:64