cmpbqm.F90

Go to the documentation of this file.

 
 
PROGRAM cmpbqm
 
  CHARACTER*255 file
  CHARACTER*50 headr,obstr,qmstr
  CHARACTER*20 vars(7)
  CHARACTER*8  subset,date
  dimension    knt(300,7,0:17),hdr(5),obs(8,255),qms(8,255)
  LOGICAL      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 == '') then 
     print *, 'Usage: Usage: cmpbqm <prepbufrfile> will print prep inventory by variable, report type, and qc mark'
     call exit(2)
  endif
  inquire(file=file,exist=exist)
  if (.not.exist) then
     print *, trim(file)//' does not exist'
     call exit(3)
  endif
 
  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 = nint(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 = nint(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 PROGRAM cmpbqm