NCEPLIBS-bufr  11.5.0
 All Data Structures Files Functions Variables Pages
cmpbqm.f
Go to the documentation of this file.
1 C> @file
2 C> @brief Print inventory of observations from prepbufr file by
3 C> variable, report type and quality mark
4 
5 C-----------------------------------------------------------------------
6 C MAIN PROGRAM CMPBQM
7 C-----------------------------------------------------------------------
8  PROGRAM cmpbqm
9 
10  CHARACTER*200 file
11  CHARACTER*50 headr,obstr,qmstr,fcstr,erstr,qmsfc
12  CHARACTER*20 vars(7)
13  CHARACTER*8 subset,date
14  dimension knt(300,7,0:17),hdr(5),obs(8,255),qms(8,255)
15  LOGICAL skip
16  REAL*8 hdr,obs,qms
17 
18  DATA headr /'SID XOB YOB DHR TYP '/
19  DATA obstr /'POB QOB TOB ZOB UOB PWO RHO VOB '/
20  DATA qmstr /'PQM QQM TQM ZQM WQM PWQ RHQ '/
21 
22  DATA vars /'PRESSURE ',
23  . 'SPECIFIC HUMIDTY',
24  . 'TEMPERATURE ',
25  . 'HEIGHT ',
26  . 'WIND COMPONENTS ',
27  . 'PRECIPITABLE H2O',
28  . 'RELATIVE HUMIDTY'/
29 
30  DATA lubfr /8 /
31  DATA vmax /10e10/
32 
33 C-----------------------------------------------------------------------
34 C-----------------------------------------------------------------------
35 
36  irec = 0
37  knt = 0
38 
39 C OPEN A FILE - GET A DATE
40 C ------------------------
41 
42  read(5,'(a)',end=100) file
43  open(lubfr,file=file,form='unformatted')
44  CALL openbf(lubfr,'IN',lubfr)
45  CALL readmg(lubfr,subset,idate,iret)
46  IF(iret.NE.0) goto 900
47  WRITE(date,'(I8)') idate
48  DO i=1,8
49  IF(date(i:i).EQ.' ') date(i:i) = '0'
50  ENDDO
51  print'(''DATA VALID AT '',A8)',date
52 
53 C READ THRU THE PREPDA RECORDS
54 C ----------------------------
55 
56 10 CALL readsb(lubfr,iret)
57  IF(iret.NE.0) THEN
58  CALL readmg(lubfr,subset,idate,iret)
59  IF(iret.NE.0) goto 100
60  CALL ufbcnt(lubfr,irec,isub)
61  goto 10
62  ENDIF
63  qms = 10e10
64  CALL ufbint(lubfr,hdr,5,1,iret,headr)
65  CALL ufbint(lubfr,obs,8,255,nlev,obstr)
66  CALL ufbint(lubfr,qms,8,255,nlev,qmstr)
67 
68  kx = hdr(5)
69 
70  DO l=1,nlev
71  DO k=1,7
72  iq = -1
73  IF(k.EQ.5) obs(5,l) = max(obs(5,l),obs(8,l))
74  IF(obs(k,l).LT.vmax .AND. qms(k,l).LT.vmax) THEN
75  iq = qms(k,l)
76  ELSEIF(obs(k,l).LT.vmax .AND. qms(k,l).GE.vmax) THEN
77  iq = 16
78  ELSEIF(obs(k,l).GE.vmax .AND. qms(k,l).LT.vmax) THEN
79  iq = 17
80  ENDIF
81  IF(iq.GE.0) knt(kx,k,iq) = knt(kx,k,iq)+1
82  ENDDO
83  ENDDO
84 
85  goto 10
86 
87 C FINISH UP
88 C ---------
89 
90 100 DO k=1,7
91  print*,vars(k)
92  print*
93  DO kx=1,300
94  itot = 0; igood=0; ifail=0
95  DO iq=0,17
96  itot = itot+knt(kx,k,iq)
97  if(iq.le.3) then
98  igood=igood+knt(kx,k,iq)
99  elseif(iq.le.7) then
100  ifail=ifail+knt(kx,k,iq)
101  endif
102  ENDDO
103  IF(itot.GT.0) print101,kx,itot,igood,ifail,(knt(kx,k,iq),iq=8,17)
104 101 FORMAT(i3,i6,2('|', i6),
105  . 2('|', i6),
106  . 1('|',6i6),
107  . 2('|', i6))
108  ENDDO
109  print*
110  ENDDO
111 
112  print*,'******CMPBQM PROCESSED ',irec,' BUFR RECORDS******'
113  stop
114 900 CALL bort('CMPBQM - ERROR READING BUFR FILE ')
115  END
subroutine openbf(LUNIT, IO, LUNDX)
This subroutine connects a new file to the BUFRLIB software for input or output operations.
Definition: openbf.F:157
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
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
subroutine bort(STR)
This subroutine calls subroutine errwrt() to log an error message, then calls subroutine bort_exit() ...
Definition: bort.f:23
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
subroutine readsb(LUNIT, IRET)
This subroutine reads the next data subset from a BUFR message into internal arrays.
Definition: readsb.f:59