cmpbqm.f

Go to the documentation of this file.

C> @file
C> @brief Print inventory of observations from prepbufr file by
C> variable, report type and quality mark

C-----------------------------------------------------------------------
C  MAIN PROGRAM CMPBQM
C-----------------------------------------------------------------------
      PROGRAM cmpbqm
 
      CHARACTER*200 file
      CHARACTER*50 headr,obstr,qmstr,fcstr,erstr,qmsfc
      CHARACTER*20 vars(7)
      CHARACTER*8  subset,date
      dimension    knt(300,7,0:17),hdr(5),obs(8,255),qms(8,255)
      LOGICAL      skip
      REAL*8       hdr,obs,qms
 
      DATA headr /'SID XOB YOB DHR TYP              '/
      DATA obstr /'POB QOB TOB ZOB UOB PWO RHO VOB  '/
      DATA qmstr /'PQM QQM TQM ZQM WQM PWQ RHQ      '/
 
      DATA vars   /'PRESSURE        ',
     .             'SPECIFIC HUMIDTY',
     .             'TEMPERATURE     ',
     .             'HEIGHT          ',
     .             'WIND COMPONENTS ',
     .             'PRECIPITABLE H2O',
     .             'RELATIVE HUMIDTY'/
 
      DATA lubfr /8    /
      DATA vmax  /10e10/
 
C-----------------------------------------------------------------------
C-----------------------------------------------------------------------
 
      irec = 0
      knt = 0
 
C  OPEN A FILE - GET A DATE
C  ------------------------
 
      read(5,'(a)',end=100) file
      open(lubfr,file=file,form='unformatted')
      CALL openbf(lubfr,'IN',lubfr)
      CALL readmg(lubfr,subset,idate,iret)
      IF(iret.NE.0) goto 900
      WRITE(date,'(I8)') idate
      DO i=1,8
      IF(date(i:i).EQ.' ') date(i:i) = '0'
      ENDDO
      print'(''DATA  VALID AT  '',A8)',date
 
C  READ THRU THE PREPDA RECORDS
C  ----------------------------
 
10    CALL readsb(lubfr,iret)
      IF(iret.NE.0) THEN
         CALL readmg(lubfr,subset,idate,iret)
         IF(iret.NE.0) goto 100
         CALL ufbcnt(lubfr,irec,isub)
         goto 10
      ENDIF
      qms = 10e10
      CALL ufbint(lubfr,hdr,5,1,iret,headr)
      CALL ufbint(lubfr,obs,8,255,nlev,obstr)
      CALL ufbint(lubfr,qms,8,255,nlev,qmstr)
 
      kx = hdr(5)
 
      DO l=1,nlev
      DO k=1,7
      iq = -1
      IF(k.EQ.5) obs(5,l) = max(obs(5,l),obs(8,l))
      IF(obs(k,l).LT.vmax .AND. qms(k,l).LT.vmax) THEN
         iq = qms(k,l)
      ELSEIF(obs(k,l).LT.vmax .AND. qms(k,l).GE.vmax) THEN
         iq = 16
      ELSEIF(obs(k,l).GE.vmax .AND. qms(k,l).LT.vmax) THEN
         iq = 17
      ENDIF
      IF(iq.GE.0) knt(kx,k,iq) = knt(kx,k,iq)+1
      ENDDO
      ENDDO
 
      goto 10
 
C  FINISH UP
C  ---------
 
100   DO k=1,7
      print*,vars(k)
      print*
      DO kx=1,300
      itot = 0; igood=0; ifail=0
      DO iq=0,17
      itot = itot+knt(kx,k,iq)
      if(iq.le.3) then 
         igood=igood+knt(kx,k,iq)
      elseif(iq.le.7) then
         ifail=ifail+knt(kx,k,iq)   
      endif
      ENDDO
      IF(itot.GT.0) print101,kx,itot,igood,ifail,(knt(kx,k,iq),iq=8,17)
101   FORMAT(i3,i6,2('|', i6),
     .             2('|', i6),
     .             1('|',6i6),
     .             2('|', i6))
      ENDDO
      print*
      ENDDO
 
      print*,'******CMPBQM PROCESSED ',irec,' BUFR RECORDS******'
      stop
900   CALL bort('CMPBQM - ERROR READING BUFR FILE ')
      END