program read_prepbufr use kinds, only: r_single,r_kind,r_double,i_kind implicit none character(len=80) :: infile,obstype ! Declare local variables character(40) drift,hdstr,qcstr,oestr,sststr,satqcstr,levstr,hdstr2 character(40) metarcldstr,geoscldstr,metarvisstr,metarwthstr character(80) obstr character(10) date character(8) subset character(8) prvstr,sprvstr integer(i_kind) ireadmg,ireadsb,icntpnt,icntpnt2,icount,iiout integer(i_kind) lunin,i,maxobs,j,idomsfc,itemp,it29 integer(i_kind) metarcldlevs,metarwthlevs integer(i_kind) k,nmsg,kx, nreal,idate,iret,ncsave,levs integer(i_kind) ntb real(r_double) vtcd real(r_double),dimension(8):: hdr real(r_double),dimension(8,255):: drfdat,qcmark,obserr real(r_double),dimension(9,255):: obsdat real(r_double),dimension(8,1):: sstdat real(r_double),dimension(2,10):: metarcld real(r_double),dimension(1,10):: metarwth real(r_double),dimension(1,1) :: metarvis real(r_double),dimension(4,1) :: geoscld real(r_double),dimension(1):: satqc real(r_double),dimension(1,1):: r_prvstg,r_sprvstg real(r_double),dimension(1,255):: levdat real(r_double),dimension(255,20):: tpc real(r_double),dimension(2,255,20):: tobaux ! data statements data hdstr /'SID XOB YOB DHR TYP ELV SAID T29'/ data hdstr2 /'TYP SAID T29 SID'/ data obstr /'POB QOB TOB ZOB UOB VOB PWO CAT PRSS' / data drift /'XDR YDR HRDR '/ data sststr /'MSST DBSS SST1 SSTQM SSTOE '/ data qcstr /'PQM QQM TQM ZQM WQM NUL PWQ '/ data oestr /'POE QOE TOE NUL WOE NUL PWE '/ data satqcstr /'QIFN'/ data prvstr /'PRVSTG'/ data sprvstr /'SPRVSTG'/ data levstr /'POB'/ data metarcldstr /'CLAM HOCB'/ ! cloud amount and cloud base height data metarwthstr /'PRWE'/ ! present weather data metarvisstr /'HOVI'/ ! visibility data geoscldstr /'CDTP TOCC GCDTT CDTP_QM'/ ! NESDIS cloud products: cloud top pressure, temperature,amount logical tob,qob,uvob,spdob,sstob,pwob,psob logical metarcldobs,geosctpobs logical driftl,convobs data lunin / 13 / ! Initialize variables infile='prepbufr' nreal=0 satqc=0.0_r_kind obstype='t' tob = obstype == 't' uvob = obstype == 'uv' spdob = obstype == 'spd' psob = obstype == 'ps' qob = obstype == 'q' pwob = obstype == 'pw' sstob = obstype == 'sst' metarcldobs = obstype == 'mta_cld' geosctpobs = obstype == 'gos_ctp' convobs = tob .or. uvob .or. spdob .or. qob !------------------------------------------------------------------------ ! Open, then read date from bufr data call closbf(lunin) open(lunin,file=infile,form='unformatted') call openbf(lunin,'IN',lunin) call datelen(10) maxobs=0 nmsg=0 ntb = 0 msg_report: do while (ireadmg(lunin,subset,idate) == 0) nmsg=nmsg+1 loop_report: do while (ireadsb(lunin) == 0) ntb = ntb+1 ! Extract type information call ufbint(lunin,hdr,4,1,iret,hdstr2) kx=hdr(1) ! For the satellite wind to get quality information and check if it will be used if( kx ==243 .or. kx == 253 .or. kx ==254 ) then call ufbint(lunin,satqc,1,1,iret,satqcstr) if(satqc(1) < 85.0_r_double) cycle loop_report ! QI w/o fcst (su's setup endif ! Save information for next read if(ncsave /= 0) then call ufbint(lunin,levdat,1,255,levs,levstr) maxobs=maxobs+max(1,levs) end if end do loop_report enddo msg_report if (nmsg==0) goto 900 write(6,*)'READ_PREPBUFR: messages/reports = ',nmsg,'/',ntb !------------------------------------------------------------------------ ! Obtain program code (VTCD) associated with "VIRTMP" step if(tob)call ufbqcd(lunin,'VIRTMP',vtcd) ! loop over convinfo file entries; operate on matches !DTC comment out the loop loop_convinfo because we want to read all typies !DTC loop_convinfo: do nx=1, ntread call closbf(lunin) open(lunin,file=infile,form='unformatted') call openbf(lunin,'IN',lunin) call datelen(10) ! Big loop over prepbufr file ntb = 0 nmsg = 0 icntpnt=0 icntpnt2=0 loop_msg: do while (ireadmg(lunin,subset,idate)== 0) loop_readsb: do while(ireadsb(lunin) == 0) ! use msg lookup table to decide which messages to skip ! use report id lookup table to only process matching reports ntb = ntb+1 ! Extract type, date, and location information call ufbint(lunin,hdr,8,1,iret,hdstr) ! Balloon drift information available for these data !DTC driftl=kx==120.or.kx==220.or.kx==221 ! Extract data information on levels call ufbint(lunin,obsdat,9,255,levs,obstr) call ufbint(lunin,qcmark,8,255,levs,qcstr) call ufbint(lunin,obserr,8,255,levs,oestr) if(sstob)then sstdat=1.e11_r_kind call ufbint(lunin,sstdat,8,1,levs,sststr) else if(metarcldobs) then metarcld=1.e11_r_kind metarwth=1.e11_r_kind metarvis=1.e11_r_kind call ufbint(lunin,metarcld,2,10,metarcldlevs,metarcldstr) call ufbint(lunin,metarwth,1,10,metarwthlevs,metarwthstr) call ufbint(lunin,metarvis,1,1,iret,metarvisstr) if(levs /= 1 ) then write(6,*) 'READ_PREPBUFR: error in Metar observations, levs sould be 1 !!!' stop 110 endif else if(geosctpobs) then geoscld=1.e11_r_kind call ufbint(lunin,geoscld,4,1,levs,geoscldstr) endif ! If temperature ob, extract information regarding virtual ! versus sensible temperature ! if(tob) then ! call ufbevn(lunin,tpc,1,255,20,levs,'TPC') ! if (.not. twodvar_regional .or. .not.tsensible) then ! else !peel back events to store sensible temp in case temp is virtual ! call ufbevn(lunin,tobaux,2,255,20,levs,'TOB TQM') ! end if ! end if end do loop_readsb ! ! End of bufr read loop enddo loop_msg ! Close unit to bufr file call closbf(lunin) ! Normal exit !DTC enddo loop_convinfo! loops over convinfo entry matches 900 continue close(lunin) end program read_prepbufr