! ! Author: Suranjana Saha C----------------------------------------------------------------------- C MAIN PROGRAM SURUFIT C----------------------------------------------------------------------- PROGRAM SURUFIT PARAMETER (IDBUG=0,IPR=1) PARAMETER (FAC=984.0) PARAMETER (NSTC=6) PARAMETER (NREG=7) PARAMETER (NSUB=2) PARAMETER (NBAK=2) CHARACTER*80 HDSTR,PSTR CHARACTER*8 SUBSET real(8) HDR(14) real(8) POB(4) real(8) CNTO,CNTN,RAT1,RAT2,WT1,WT2 real(8) SPRS(NSTC,NREG,NSUB,NBAK) real(8) STC(NSTC,NBAK) real(4) GDATA(NREG,NSUB) LOGICAL REGION DATA HDSTR ./'SID XOB YOB DHR ELV TYP T29 ITP SQN RQM DUP PRG SRC RUD'/ DATA PSTR /'POB PAN PFC PQM'/ real(8) BMISS /10E10/ DATA RMISS /-9.99E+33/ DATA LUBFR/11/ C----------------------------------------------------------------------- C ZERO THE FIT ARRAYS C ------------------- SPRS = 0. STC=0. bmiss=10e10; call setbmiss(bmiss) ! this sets bufrlib missing value to 10e10 CALL OPENBF(LUBFR,'IN ',LUBFR) C READ AND "SURU-FIT" THE PREPDA/BUFR RECORDS C ------------------------------------------- 10 DO WHILE(IREADMG(LUBFR,SUBSET,IDATE).EQ.0) c... check for subset... IF(ITYP(SUBSET).EQ.0) GOTO 10 11 DO WHILE(IREADSB(LUBFR).EQ.0) CALL UFBINT(LUBFR,HDR,14, 1,NLEV,HDSTR) typx=hdr(6) c... check for region... XOB=hdr(2) YOB=hdr(3) c CALL UFBINT(LUBFR,XOB,1,1,IREC,'XOB') c CALL UFBINT(LUBFR,YOB,1,1,IREC,'YOB') IF(.NOT.REGION(XOB,YOB,0)) GOTO 11 C READ THE DATA C ------------- CALL UFBINT(LUBFR,POB, 4,1,NLEV,PSTR) PO=POB(1) PA=POB(2) PF=POB(3) PQ=POB(4) c C CREATE AND ACCUMULATE THE STATISTICS ARRAY FOR EACH REALIZATION C --------------------------------------------------------------- STC = 0. C if((pa.eq.bmiss).or.(pf.eq.bmiss)) go to 11 IF(PQ.LE.3) THEN if(idbug.eq.1) print *,'ob ',po,' ges ',pf, ' anl ',pa C c... start forecast-loop DO IB=1,2 C c count STC(1,IB) = 1. c f if(ib.eq.1) STC(2,IB) = PF-fac if(ib.eq.2) STC(2,IB) = PA-fac c o STC(3,IB) = PO-fac c f * o STC(4,IB) = STC(2,IB)*STC(3,IB) c f**2 STC(5,IB) = STC(2,IB)**2 c o**2 STC(6,IB) = STC(3,IB)**2 C if(idbug.eq.1) print *,' ib ',ib,' stc ',(stc(k,ib),k=1,6) c c... end forecast-loop ENDDO c ENDIF M = ITYP(SUBSET) if (m > 0) then DO N=1 ,NBAK DO LL=1 ,NREG C IF(REGION(XOB,YOB,LL)) THEN C cnto = SPRS(1,LL,M,N) SPRS(1,LL,M,N) = SPRS(1,LL,M,N) + STC(1,N) cntn = SPRS(1,LL,M,N) if(cntn.gt.cnto) then wt1 = cnto/cntn wt2 = 1.-wt1 c DO I=2,NSTC sprso = SPRS(I,LL,M,N) rat1 = wt1*SPRS(I,LL,M,N) rat2 = wt2*STC(I,N) c SPRS(I,LL,M,N) = rat1 + rat2 sprsn = SPRS(I,LL,M,N) c if((idbug.eq.1).and.(i.eq.2)) then if((m.eq.1).and.(n.eq.1)) then write(6,3000) ll,cnto,cntn,wt1,wt2,sprso,STC(I,N), * rat1,rat2,sprsn endif endif c c... end stat-loop ENDDO c endif ENDIF c... end region-loop ENDDO C c... end forecast-loop ENDDO endif ! if itype > 0 C ENDDO c... end subset-loop ENDDO CALL CLOSBF(LUBFR) C FINISH UP C --------- C write out grads data file... iw=50 do ibak=1,nbak iw=iw+1 c do nst=1,6 c do isub=1,nsub do ireg=1,nreg if((nst.eq.2).or.(nst.eq.3)) then gdata(ireg,isub)=sprs(nst,ireg,isub,ibak)+fac else gdata(ireg,isub)=sprs(nst,ireg,isub,ibak) endif enddo enddo c write(iw) gdata c if(ipr.eq.1) *write(6,1232) ibak,nst,(gdata(ireg,1),ireg=1,nreg) c c... end stat-loop enddo c close(iw) c... end forecast-loop enddo c 1232 format('p fcs=',i2,2x,'stat = ',i2,2x,7f12.2) 3000 format('reg ',i2,' cnto ',f7.0,' cntn ',f7.0, * ' wt1 ',f5.2,' wt2 ',f5.2,2x,5f12.2) c PRINT'("SURUFIT PROCESSING COMPLETED")' STOP END C----------------------------------------------------------------------- C----------------------------------------------------------------------- LOGICAL FUNCTION REGION(X,Y,I) PARAMETER(NREG=7) DIMENSION X1(NREG),X2(NREG),Y1(NREG),Y2(NREG) C.... X goes from east to west C.... Y goes from south to north DATA X1(1),X2(1),Y1(1),Y2(1) /0.,360.,-90.,90./ DATA X1(2),X2(2),Y1(2),Y2(2) /0.,360.,20.,80./ DATA X1(3),X2(3),Y1(3),Y2(3) /0.,360.,-80.,-20./ DATA X1(4),X2(4),Y1(4),Y2(4) /0.,360.,-20.,20./ DATA X1(5),X2(5),Y1(5),Y2(5) /235.,295.,25.,55./ DATA X1(6),X2(6),Y1(6),Y2(6) /350.,25.,35.,70./ DATA X1(7),X2(7),Y1(7),Y2(7) /65.,145.,5.,45./ C----------------------------------------------------------------------- C CHECK FOR A VALID REGION INDEX AND BE OPTIMISTIC C ------------------------------------------------ IF(I.LT.0.OR.I.GT.NREG) THEN REGION = .FALSE. RETURN ELSE REGION = .TRUE. ENDIF C SETUP THE SEARCH PARAMETERS C --------------------------- IF(I.EQ.0) THEN I1 = 1 I2 = NREG ELSE I1 = I I2 = I ENDIF C LOOK FOR A REGION MATCH C ----------------------- DO I0=I1,I2 IF(Y.GE.Y1(I0) .AND. Y.LE.Y2(I0)) THEN IF(X1(I0).LE.X2(I0)) THEN IF(X.GE.X1(I0) .AND. X.LE.X2(I0)) RETURN ELSEIF(X1(I0).GT.X2(I0)) THEN IF(X.GE.X1(I0) .OR. X.LE.X2(I0)) RETURN ENDIF ENDIF ENDDO C IF NO MATCH, RETURN FALSE C ------------------------- REGION = .FALSE. RETURN END C----------------------------------------------------------------------- C----------------------------------------------------------------------- INTEGER FUNCTION ITYP(SUBSET) PARAMETER(NSUB=2) CHARACTER*8 SUBSET,SUBTYP(2) DATA SUBTYP /'ADPSFC','SFCSHP'/ C C CHARACTER*8 SUBSET,SUBTYP(15) C DATA SUBTYP /'ADPUPA','AIRCAR','AIRCFT','SATWND','PROFLR', C . 'VADWND','SATBOG','SATEMP','ADPSFC','SFCSHP', C . 'SFCBOG','SPSSMI','SYNDAT','ERS1DA','GOESND'/ C LOOK FOR A MATCH TO RETURN NON-ZERO C ----------------------------------- DO I=1,NSUB ITYP = I IF(SUBSET.EQ.SUBTYP(I)) RETURN ENDDO C IF NO MATCH, RETURN ZERO C ------------------------ ITYP = 0 RETURN END