cmpbqm.f90

 
 
!-----------------------------------------------------------------------
!  MAIN PROGRAM CMPBQM
!-----------------------------------------------------------------------
      PROGRAM cmpbqm
 
      CHARACTER*255 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,exist
      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/
 
!-----------------------------------------------------------------------
!-----------------------------------------------------------------------
 
      irec = 0
      knt = 0
 
!  OPEN A FILE - GET A DATE
!  ------------------------
 
      call getarg(1,file); file=trim(adjustl(file)) 
      if (file == '') call bort('Usage: "cmpbqm prepbufrfile" will print prep inventory by variable, report type, and qc mark')
      inquire(file=file,exist=exist)
      if (.not.exist) call bort(trim(file)//' does not exist') 
 
      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
 
!  READ THRU THE PREPDA RECORDS
!  ----------------------------
 
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
 
!  FINISH UP
!  ---------
 
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) print 101,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