NCEPLIBS-bufr  12.1.0
readbp.F90
Go to the documentation of this file.
1 
6 
14 
15 !-----------------------------------------------------------------------
16 ! READ AND DISPLAY AN ON29BUFR FILE ONE REPORT AT A TIME
17 !-----------------------------------------------------------------------
18  PROGRAM readbp
19 
20  character(120) :: file
21  character(50) :: optarg
22  character(40) :: hstr,ostr,qstr
23  character(10) :: val
24  character(8) :: sid,sta,subset,msg,cmc(17)
25  character(3) :: vars(8)
26  integer :: iostat
27  real(8) :: hdr(10),obs(10,255),qms(10,255),qmc(17),xob,yob
28  logical :: window,steam,level,dump,hedr,exist
29 
30  equivalence(hdr(1),sid)
31  equivalence(qmc,cmc)
32 
33  DATA hstr/'SID XOB YOB DHR ELV T29 ITP TYP SRC PRG '/
34  DATA ostr/'CAT POB QOB TOB ZOB UOB VOB PSL '/
35  DATA qstr/'PQM QQM TQM ZQM WQM PSQ '/
36 
37  DATA vars/'LVL','CAT','POB','SPH','TOB','ZOB','UOB','VOB'/
38  DATA cmc /'0','1','2','3','4','5','6','7','8','9','A','B','C','D','E','F','*'/
39 
40  DATA lubfr /8 /
41  DATA sta /' '/
42  data msg /' '/
43  DATA pob /0/
44  data irt /0/
45  data itp /0/
46  data ikx /0/
47  data window /.false./
48  data steam /.false./
49  data level /.false./
50  data dump /.false./
51  data hedr /.false./
52 
53 !-----------------------------------------------------------------------
54 !-----------------------------------------------------------------------
55 
56 ! check for filename argument
57 
58  narg=command_argument_count()
59 1 if(narg<1) THEN
60  call printx(' ')
61  call printx('Usage: readbp <-s> <-w> <m> <-k> <-r> <-d> <-n> <-h> prep bufrfile ')
62  call printx(' ')
63  call printx('Search filter and/or print prepbufr reports in various ways ')
64  call printx(' ')
65  call printx('-s "station_id " print reports where "station_id" matches the report id up to the len of "station_id" ')
66  call printx('-w "x1 x2 y1 y2" print reports within a lon/lat box ')
67  call printx('-m "subset " print reports with this subset name ')
68  call printx('-k "gsi rtype " print reports with this gsi report type ')
69  call printx('-r "on29 rtype " print reports with this on29 report type ')
70  call printx('-d print reports using ufdump - note: this works with any NCEP BUFR file ')
71  call printx('-n no pause between reports output ')
72  call printx('-h print only report headers ')
73  call printx(' ')
74  call printx('Only a filename is required in which case step through the reports one at a time using "enter" ')
75  call printx(' ')
76  call printx('Optional arguments can also be applied in the pause between reports output without using a dash ')
77  call printx(' ')
78  call printx('Optional arguments will be applied in concert in most cases ')
79  call printx(' ')
80  call exit(2)
81  ENDIF
82 
83  iarg=1
84  do while(iarg<=narg)
85  call get_command_argument(iarg,file)
86  if(file(1:1)=='-') then
87  if(file(2:2)=='s') then
88  iarg=iarg+1; call get_command_argument(iarg,sta); nsta=len(trim(sta))
89  elseif(file(2:2)=='w') then
90  iarg=iarg+1; call get_command_argument(iarg,val); read(val,*)x1
91  iarg=iarg+1; call get_command_argument(iarg,val); read(val,*)x2
92  iarg=iarg+1; call get_command_argument(iarg,val); read(val,*)y1
93  iarg=iarg+1; call get_command_argument(iarg,val); read(val,*)y2
94  window=.true.
95  elseif(file(2:2)=='k') then
96  iarg=iarg+1; call get_command_argument(iarg,val); read(val,*)ikx
97  elseif(file(2:2)=='r') then
98  iarg=iarg+1; call get_command_argument(iarg,val); read(val,*)irt
99  elseif(file(2:2)=='m') then
100  iarg=iarg+1; call get_command_argument(iarg,val); msg=val(1:8)
101  elseif(file(2:2)=='d') then
102  iarg=iarg+1; dump=.true.
103  elseif(file(2:2)=='h') then
104  iarg=iarg+1; hedr=.true.
105  elseif(file(2:2)=='n') then
106  iarg=iarg+1; steam=.true.
107  else
108  iarg=iarg+1
109  endif
110  file='nofile'
111  cycle
112  endif
113  iarg=iarg+1
114  enddo
115 
116 ! check if file exists, then open it, else exit
117 
118  narg=0
119  if(file=='nofile') goto 1
120  file = trim(adjustl(file))
121  inquire(file=file,exist=exist)
122  if (.not.exist) then
123  print *, trim(file)//' does not exist'
124  call exit(3)
125  endif
126 
127 ! open the bufr input file
128 ! ------------------------
129 
130  open(lubfr,file=file,form='unformatted')
131  call openbf(lubfr,'IN',lubfr)
132  call datelen(10)
133 
134 ! READ A SUBSET - READ ANOTHER MESSAGE WHEN NO MORE SUBSETS
135 ! ---------------------------------------------------------
136 
137  do while(ireadmg(lubfr,subset,idate)==0)
138  do while(ireadsb(lubfr)==0)
139  call ufbcnt(lubfr,irec,isub)
140 
141  IF(msg/=' ' .and. msg/=subset) exit
142 
143  if(dump) then
144  call ufdump(lubfr,6)
145  goto 99
146  endif
147 
148 ! MOVE SUBSET CONTENTS INTO THIS PROGRAM
149 ! --------------------------------------
150 
151  CALL ufbint(lubfr,hdr,10, 1,iret,hstr)
152  xob = hdr(2)
153  yob = hdr(3)
154  jrt = nint(hdr(6))
155  jtp = nint(hdr(7))
156  jkx = nint(hdr(8))
157  IF(sta/=' ' .AND. sta/=sid(1:nsta)) cycle
158  IF(irt/=0 .and. irt/=jrt) cycle
159  IF(itp/=0 .and. itp/=jtp) cycle
160  IF(ikx/=0 .and. ikx/=jkx) cycle
161  if(window) then
162  if(.not.(xob>=x1 .and. xob<=x2))cycle
163  if(.not.(yob>=y1 .and. yob<=y2))cycle
164  endif
165 
166  CALL ufbint(lubfr,obs,10,255,nlev,ostr)
167  CALL ufbint(lubfr,qms,10,255,nleq,qstr)
168  IF(nlev/=nleq) stop 'NLEV<>NLEQ'
169 
170 ! MOVE CAT 8 DATA TO PRINT RANGE
171 ! ------------------------------
172  DO l=1,nlev
173  IF(obs(1,l)==8) THEN
174  obs(2,l) = obs(9,l)
175  obs(3,l) = obs(10,l)
176  ENDIF
177  ENDDO
178 
179 ! PRINT A REPORT 20 LINES AT A TIME
180 ! ---------------------------------
181 
182  if(hedr) then
183  print'(a8,1x,a8,7(f8.2,1x))',subset,(hdr(i),i=1,8)
184  if(steam) cycle
185  goto 99
186 
187  else
188 
189  print'(80(''-''))'
190  print'(''MESSAGE: '',A8,2(2X,I4),i12 )' , subset,irec,isub,idate
191  print'(''STATION: '',A8,1X,2(F8.2,1X))' , (hdr(i),i= 1,3)
192  print'(''TIME: '',I10,2x,F8.2 )' , idate,hdr(4)
193  print'(''ELV: '',F8.2 )' , (hdr(5) )
194  print'(''TYPE: '',3(F8.0,1X) )' , (hdr(i),i= 6,8)
195  print'(''DATA: '' )'
196 
197  endif
198 
199  do l=1,nlev
200  do i=1,7
201  iqm = nint(qms(i,l))
202  if(iqm<0)iqm=10e8
203  iqm = min(iqm,16)
204  qms(i,l) = qmc(iqm+1)
205  enddo
206  enddo
207 
208  nlne = 7
209  print'(2(1X,A3),6(8X,A3))',vars
210  DO 12 l=1,nlev
211  nlne = nlne+1
212  print 11, l,nint(obs(1,l)),(obs(i,l),qms(min(i-1,5),l),i=2,7)
213 11 FORMAT(2i4,6(1x,f7.1,'(',a1,')'))
214 12 ENDDO
215  print'(80(''-''))'
216  if(steam) cycle
217 
218 ! GO TO READ THE NEXT SUBSET IF NO 'Q' YOU
219 ! ----------------------------------------
220 
221 99 READ(5,'(a)',iostat=iostat) optarg
222  IF(optarg(1:1)=='q') then
223  stop
224  elseif(optarg(1:1)=='s') then
225  read(optarg(2:50),*) sta
226  nsta=len(trim(sta))
227  elseif(optarg(1:1)=='w') then
228  read(optarg(2:50),*) x1,x2,y1,y2
229  window=.true.
230  elseif(optarg(1:1)=='k') then
231  read(optarg(2:50),*) ikx
232  elseif(optarg(1:1)=='r') then
233  read(optarg(2:50),*) irt
234  elseif(optarg(1:1)=='m') then
235  read(optarg(2:50),*) msg
236  elseif(optarg(1:1)=='d') then
237  call ufdump(lubfr,6)
238  elseif(optarg(1:1)=='h') then
239  hedr=.true.
240  endif
241 
242  enddo ! end of subset loop
243  enddo ! end of message loop
244 
245 ! HERE WHEN ALL MESSAGES HAVE BEEN READ
246 ! -------------------------------------
247 
248  stop
249  END program
250 
256  subroutine printx(str)
257  character(*) :: str
258  lens=len(str)
259  do i=1,lens-1
260  write(*,'(a1)',advance="no")str(i:i)
261  enddo
262  write(*,'(a1)')str(lens:lens)
263  end subroutine
264 
ufdump
recursive subroutine ufdump(lunit, luprt)
Print a verbose listing of the contents of a data subset, including all data values and replicated se...
Definition: dumpdata.F90:228
openbf
recursive subroutine openbf(lunit, io, lundx)
Connect a new file to the NCEPLIBS-bufr software for input or output operations, or initialize the li...
Definition: openclosebf.F90:169
ufbcnt
recursive subroutine ufbcnt(lunit, kmsg, ksub)
Get the current location of the file pointer within a BUFR file, in terms of a message number countin...
Definition: openclosebf.F90:586
printx
subroutine printx(str)
Print long lines to stdout using advance=no format clause.
Definition: readbp.F90:257
readbp
program readbp
Read PREPBUFR file containing embedded DX BUFR tables, and print each report one at a time.
Definition: readbp.F90:18
ireadmg
recursive integer function ireadmg(lunit, subset, idate)
Call subroutine readmg() and pass back its return code as the function value.
Definition: readwritemg.F90:144
ireadsb
recursive integer function ireadsb(lunit)
Call subroutine readsb() and pass back its return code as the function value.
Definition: readwritesb.F90:117
ufbint
recursive subroutine ufbint(lunin, usr, i1, i2, iret, str)
Read or write one or more data values from or to a data subset.
Definition: readwriteval.F90:646
datelen
recursive subroutine datelen(len)
Specify the format of Section 1 date-time values that will be output by future calls to any of the NC...
Definition: s013vals.F90:889