NCEPLIBS-bufr  12.1.0
cmpbqm.F90
Go to the documentation of this file.
1 
5 
11 PROGRAM cmpbqm
12 
13  CHARACTER*255 file
14  CHARACTER*50 headr,obstr,qmstr
15  CHARACTER*20 vars(7)
16  CHARACTER*8 subset,date
17  dimension knt(300,7,0:17),hdr(5),obs(8,255),qms(8,255)
18  LOGICAL exist
19  real*8 hdr,obs,qms
20 
21  DATA headr /'SID XOB YOB DHR TYP '/
22  DATA obstr /'POB QOB TOB ZOB UOB PWO RHO VOB '/
23  DATA qmstr /'PQM QQM TQM ZQM WQM PWQ RHQ '/
24 
25  DATA vars /'PRESSURE ',&
26  'SPECIFIC HUMIDTY',&
27  'TEMPERATURE ',&
28  'HEIGHT ',&
29  'WIND COMPONENTS ',&
30  'PRECIPITABLE H2O',&
31  'RELATIVE HUMIDTY'/
32 
33  DATA lubfr /8 /
34  DATA vmax /10e10/
35 
36  !-----------------------------------------------------------------------
37  !-----------------------------------------------------------------------
38 
39  irec = 0
40  knt = 0
41 
42  ! OPEN A FILE - GET A DATE
43  ! ------------------------
44 
45  call get_command_argument(1,file); file=trim(adjustl(file))
46  if (file == '') then
47  print *, 'Usage: Usage: cmpbqm <prepbufrfile> will print prep inventory by variable, report type, and qc mark'
48  call exit(2)
49  endif
50  inquire(file=file,exist=exist)
51  if (.not.exist) then
52  print *, trim(file)//' does not exist'
53  call exit(3)
54  endif
55 
56  open(lubfr,file=file,form='unformatted')
57  CALL openbf(lubfr,'IN',lubfr)
58  CALL readmg(lubfr,subset,idate,iret)
59  IF(iret/=0) GOTO 900
60  WRITE(date,'(I8)') idate
61  DO i=1,8
62  IF(date(i:i)==' ') date(i:i) = '0'
63  ENDDO
64  print'(''DATA VALID AT '',A8)',date
65 
66  ! READ THRU THE PREPDA RECORDS
67  ! ----------------------------
68 
69 10 CALL readsb(lubfr,iret)
70  IF(iret/=0) THEN
71  CALL readmg(lubfr,subset,idate,iret)
72  IF(iret/=0) GOTO 100
73  CALL ufbcnt(lubfr,irec,isub)
74  GOTO 10
75  ENDIF
76  qms = 10e10
77  CALL ufbint(lubfr,hdr,5,1,iret,headr)
78  CALL ufbint(lubfr,obs,8,255,nlev,obstr)
79  CALL ufbint(lubfr,qms,8,255,nlev,qmstr)
80 
81  kx = nint(hdr(5))
82 
83  DO l=1,nlev
84  DO k=1,7
85  iq = -1
86  IF(k==5) obs(5,l) = max(obs(5,l),obs(8,l))
87  IF(obs(k,l)<vmax .AND. qms(k,l)<vmax) THEN
88  iq = nint(qms(k,l))
89  ELSEIF(obs(k,l)<vmax .AND. qms(k,l)>=vmax) THEN
90  iq = 16
91  ELSEIF(obs(k,l)>=vmax .AND. qms(k,l)<vmax) THEN
92  iq = 17
93  ENDIF
94  IF(iq>=0) knt(kx,k,iq) = knt(kx,k,iq)+1
95  ENDDO
96  ENDDO
97 
98  GOTO 10
99 
100  ! FINISH UP
101  ! ---------
102 
103 100 DO k=1,7
104  print*,vars(k)
105  print*
106  DO kx=1,300
107  itot = 0; igood=0; ifail=0
108  DO iq=0,17
109  itot = itot+knt(kx,k,iq)
110  if(iq<=3) then
111  igood=igood+knt(kx,k,iq)
112  elseif(iq<=7) then
113  ifail=ifail+knt(kx,k,iq)
114  endif
115  ENDDO
116  IF(itot>0) print 101,kx,itot,igood,ifail,(knt(kx,k,iq),iq=8,17)
117 101 FORMAT(i3,i6,2('|', i6),&
118  2('|', i6),&
119  1('|',6i6),&
120  2('|', i6))
121  ENDDO
122  print*
123  ENDDO
124 
125  print*,'******CMPBQM PROCESSED ',irec,' BUFR RECORDS******'
126  stop
127 900 CALL bort('CMPBQM - ERROR READING BUFR FILE ')
128 END PROGRAM cmpbqm
subroutine bort(str)
Log an error message, then abort the application program.
Definition: borts.F90:15
program cmpbqm
Usage: cmpbqm <prepbufrfile> will print prep inventory by variable, report type, and qc mark.
Definition: cmpbqm.F90:11
recursive subroutine openbf(lunit, io, lundx)
Connect a new file to the NCEPLIBS-bufr software for input or output operations, or initialize the li...
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...
recursive subroutine readmg(lunxx, subset, jdate, iret)
Read the next BUFR message from logical unit abs(lunxx) into internal arrays.
Definition: readwritemg.F90:44
recursive subroutine readsb(lunit, iret)
Read the next data subset from a BUFR message.
Definition: readwritesb.F90:32
recursive subroutine ufbint(lunin, usr, i1, i2, iret, str)
Read or write one or more data values from or to a data subset.