NCEPLIBS-bufr  11.7.0
 All Data Structures Files Functions Variables Pages
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()
46 1 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)
198 11 FORMAT(2i4,6(1x,f7.1,'(',a1,')'))
199 12 ENDDO
200  print'(80(''-''))'
201  if(steam) cycle
202 
203 ! GO TO READ THE NEXT SUBSET IF NO 'Q' YOU
204 ! ----------------------------------------
205 
206 99 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 
233 100 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 
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:39
ireadsb
function ireadsb(LUNIT)
This function calls BUFRLIB subroutine readsb() and passes back its return code as the function value...
Definition: ireadsb.f:30
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:35
openbf
subroutine openbf(LUNIT, IO, LUNDX)
This subroutine connects a new file to the BUFRLIB software for input or output operations.
Definition: openbf.f:138
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:152
ufbcnt
subroutine ufbcnt(LUNIT, KMSG, KSUB)
This subroutine returns the current location of the file pointer within a BUFR file, in terms of a message number counting from the beginning of the file, and a data subset number counting from the beginning of that message.
Definition: ufbcnt.f:45
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:63
bort
subroutine bort(STR)
This subroutine calls subroutine errwrt() to log an error message, then calls subroutine bort_exit() ...
Definition: bort.f:22