C$$$ MAIN PROGRAM DOCUMENTATION BLOCK C . . . . C MAIN PROGRAM: SREF_MEANSNDP C PRGMMR: MANIKIN ORG: NP22 DATE: 2012-01-10 C C ABSTRACT: THIS ROUTINE POSTS PROFILE DATA AND WRITES C OUTPUT IN BUFR FORMAT. C C PROGRAM HISTORY LOG: C 95-07-26 MIKE BALDWIN C 12-01-10 GEOFF MANIKIN - Adapted code to generate SREF bufr mean C C USAGE: C INPUT ARGUMENT LIST: C NONE C C OUTPUT FILES: C NONE C C SUBPROGRAMS CALLED: C UTILITIES: C CALWXT C CALHEL C BFRIZE C LIBRARY: C BUFRLIB C C ATTRIBUTES: C LANGUAGE: FORTRAN C MACHINE : CRAY C-90 C$$$ C C*** C*** SOUNDING POST PROCESSOR C*** PROGRAM TO READ THE PROFILE OUTPUT FILES C*** AND PRODUCE DIAGNOSTIC QUANTITIES AND PACK INTO BUFR C*** C-------------------------------------------------------------------- C C PARMS FOR HOURLY PROFILER OUTPUT C LM - MAX NUMBER OF VERTICAL LEVELS C NPNT - MAX NUMBER OF OUTPUT TIMES C C TO HOLD ALL VARIABLES FOR ANY CLASS OF OUTPUT C (MAX NO MULTI-LAYER VARIABLES*LM + NO OF SINGLE LAYER VARS) C LCL1ML1 - NUMBER OF MULTI-LAYER VARIABLES IN CLASS 1 OUTPUT C LCL1SL1 - NUMBER OF SINGLE LAYER VARIABLES IN CLASS 1 OUTPUT C LCL1ML - NUMBER OF MULTI-LAYER VARIABLES IN PROFILM C LCL1SL - NUMBER OF SINGLE LAYER VARIABLES IN PROFILM C LCL1SOIL - MAX NUMBER OF SOIL LAYER VARIABLES FOR CLASS 0 OR 1 C NSTAT - MAX NUMBER OF STATIONS C C NOTE: THESE NUMBERS WILL BE LARGER THAN THE NUMBERS C COMING OUT OF THE MODEL IN THE BINARY FILE SINCE C WE ARE COMPUTING SOME ADDITIONAL VARIABLES TO GO INTO C BUFR IN THIS PROGRAM. C C-------------------------------------------------------------------- INCLUDE "parmsref" C NSTAT MUST BE SET TO THE EXACT NUMBER OF STATIONS BEING PROCESSED c PARAMETER(NPNT=NSTP,NSTAT=1476 PARAMETER(NPNT=NSTP,NSTAT=1504 C THE EM PROFILM FILES HAVE 13 PROFILE VARIABLES, WHILE THE C NMM/NMMB PROFILM FILES HAVE 15 VARIABLES &, LCL1MLEM=13,LCL1MLNMM=15,LCL1SL=52,LCL1SOIL=2,NFCST=88 &, LCL1ML1=15,LCL1SL1=58 &, NWORD=(LCL1ML1)*LM+2*LCL1SL+NSOIL*LCL1SOIL) PARAMETER (SNOCON=1.4594E5,RAINCON=1.1787E4 &, ROG=287.04/9.8,NUMSREF=21) C LOGICAL LVLWSE,SEQFLG(8),NEED CHARACTER*16 SEQNM1(8), SBSET CHARACTER*80 CLIST1(8),FMTO,ASSIGN CHARACTER*8 CISTAT cwas DIMENSION FPACK(NWORD),PRODAT(NSTAT,NPNT,NWORD) DIMENSION FPACK(NWORD) REAL PRODAT(NWORD,NSTAT,NPNT) REAL PRODAT2(NWORD,NSTAT,NPNT) REAL*8 RTC, T1, T2, T3, T4, T5, T6 REAL SP1,SP2,SP3,SP4 C C THE PURPOSE OF LPRO IS TO HOLD THE VALUES OF RISTAT UNTIL C THEY ARE COPIED TO FRODAT. THIS ADDITION WILL ALLOW PRODAT C TO BE A REAL(4) ARRAY ( AND SAVE A CONSIDERABLE AMOUNT OF C MEMORY) . PRODAT CAN BE FURTHER REDUCED WITH SOME MORE EFFORT. C JIM TUCCILLO C REAL(8) LPRO(NSTAT,NPNT) REAL(8) RISTAT cwas REAL(8) PRODAT(NSTAT,NPNT,NWORD),RISTAT REAL(8) FRODAT(NWORD),WORKK(NWORD) DIMENSION P(LM),T(LM),U(LM),V(LM),Q(LM),PINT(LM+1),ZINT(LM+1) REAL CWTR(LM),IMXR(LM),RAIN(LM),HELI,UST,VST,CDBP,HOVI INTEGER IDATE(3),NP1(8),LLMH(NSTAT),NLVL(2) INTEGER MAXLEN(NSTAT),TOTALLEN,LMH,PROLENGTH REAL SNOWY,SLEETY,ICY,RAINY REAL SPVALTRACK(NWORD,NSTAT,NPNT) EQUIVALENCE (CISTAT,RISTAT) C-------------------------------------------------------------------- C C SET OUTPUT UNITS FOR CLASS 1 PROFILE FILE. C LCLAS1 - OUTPUT UNIT FOR CLASS 1 BINARY FILE C LTBCL1 - INPUT UNIT FOR CLASS 1 BUFR TABLE FILE C LUNCL1 - OUTPUT UNIT FOR CLASS 1 BUFR FILE C C-------------------------------------------------------------------- I N T E G E R & LCLAS1,LTBCL1,LUNCL1,STDOUT C-------------------------------------------------------------------- L O G I C A L & MONOL,BRKOUT C-------------------------------------------------------------------- D A T A & LCLAS1 / 76 / &,LTBCL1 / 32 / &,LUNCL1 / 84 / &,STDOUT / 6 / &,SEQNM1 /'HEADR','PROFILE','SURF','FLUX', & 'HYDR','D10M','SLYR','XTRA'/ &,SEQFLG /.FALSE.,.TRUE.,.FALSE.,.FALSE.,.FALSE.,.FALSE., & .TRUE.,.FALSE./ &,LVLWSE /.TRUE./ print *, 'into mean bufr code' PRODAT=0. PRODAT2=0. SPVALTRACK=0. SMISS=-9999. FMTO='("ln -s ${DIRD}",I5.5,".",I4.4,3I2.2,'// & '" fort.",I2.2)' C C GET MODEL TOP PRESSURE C PTOP=25.0*100.0 C THERE ARE 4 DIFFERENT VALUES USED FOR MISSING WITHIN C THE PROFILM FILES SP1=-9999. SP2=-999. SP3=-999900. SP4=-9999000. 12321 CONTINUE PTOP=ETOP*100.0 C C READ IN SWITCHES TO CONTROL WHETHER TO DO... C MONOL=.TRUE. DO MONOLITHIC FILE C BRKOUT=.TRUE. DO BREAKOUT FILES C MONOL=.TRUE. BRKOUT=.FALSE. C LUNIT=40 DO LL=1,NUMSREF print *, 'processing member ', LL C THE RECORD LENGTH IS DIFFERENT FOR EM AND NMM/NMMB MEMBERS IF (LL .LT. 8) THEN LRECPR=4*(8+9+(2+LCL1MLEM)*LM1EM+LCL1SL) LCL1ML=LCL1MLEM ETOP=50.0 ELSE LRECPR=4*(8+9+LCL1MLNMM*LM1NMM+LCL1SL) LCL1ML=LCL1MLNMM ETOP=50.0 ENDIF PTOP=ETOP*100.0 IFCSTL=-99 print *, 'LRECPR is ', LRECPR C---------------------------------------------------------------------- C---READ STATION DATA-------------------------------------------------- C---------------------------------------------------------------------- LUNIT=LUNIT+1 OPEN(UNIT=LUNIT,ACCESS='DIRECT',RECL=LRECPR,IOSTAT=IER) NREC=0 c In WRF, all stations are saved in one fcst hour (i.e. one file), so first c read fcst hour, and then read station - use DO 3000/4000 loop here DO 4000 JHR= 1,NFCST ! Forecast time loop DO 3000 NST = 1, NSTAT ! Station loop, one station on loop NREC=(JHR-1)*NSTAT + NST READ(LUNIT,REC=NREC,IOSTAT=IRR,ERR=998) IHRST,IDATE,IFCST,ISTAT, & CISTAT,(FPACK(N),N=1,9),(FPACK(N),N=10,FPACK(7)) IF(IRR.NE.0) THEN WRITE(*,*) NREC, ' read error, IRR=',IRR END IF INUMS=NST IYR=IDATE(3) IMON=IDATE(1) IDAY=IDATE(2) LLMH(INUMS)=NINT(FPACK(4)) LMH=NINT(FPACK(4)) MAXLEN(INUMS)=FPACK(7) DO 26 L=1,LMH C REVERSE ORDER SO THAT P(1) IS THE TOP AND P(LMH) IS THE BOTTOM LV=LMH-L+1 P(LV)=FPACK(L+9) T(LV)=FPACK(L+9+LMH) U(LV)=FPACK(L+9+LMH*2) V(LV)=FPACK(L+9+LMH*3) Q(LV)=FPACK(L+9+LMH*4) C CWTR, RAIN, AND IMXR NOW IN SEPARATE ARRAYS FOR NMM C ARW STILL STORES IMXR AS NEGATIVE CWTR VALUES CWTR(LV)=FPACK(L+9+LMH*6) IF (LL .LT. 8) THEN RAIN(LV)=0.0 IF (CWTR(LV).LT.0.) THEN IMXR(LV)= -1. * CWTR(LV) CWTR(LV)= 0. FPACK(L+9+LMH*6) = 0. ELSE IMXR(LV) = 0. ENDIF ELSE RAIN(LV)=FPACK(L+9+LMH*13) IMXR(LV)=FPACK(L+9+LMH*14) ENDIF 26 CONTINUE C USE SEA MASK TO SET SOIL/SFC VARIABLES TO MISSING VALUES C (IF SEA) C SM =FPACK(LCL1ML*LMH+54) IF (SM.GT.0.5) THEN C SMSTAV FPACK(LCL1ML*LMH+15)=SMISS C SUBSHX FPACK(LCL1ML*LMH+21)=SMISS C SNOPCX FPACK(LCL1ML*LMH+22)=SMISS C ACSNOW, SMSTOT, SNO, ACSNOM, SSROFF, BGROFF, SOILTB DO LKJ=20,26 FPACK(LCL1ML*LMH+LKJ+9)=SMISS ENDDO C SFCEXC, VEGFRC, CMC, SMC(1:4), STC(1:4) DO LKJ=34,44 FPACK(LCL1ML*LMH+LKJ+9)=SMISS ENDDO ENDIF C THE SMSTOT, SNO, AND SNOMELT FIELDS IN THE EM C MEMBERS HAVE SUSPICIOUS VALUES, SO SET TO SMISS IF (LL .LE. 7) THEN FPACK(LCL1ML*LMH+29)=SMISS FPACK(LCL1ML*LMH+31)=SMISS FPACK(LCL1ML*LMH+32)=SMISS ENDIF C C GET PPT FOR CALWXT C PPT=FPACK(LCL1ML*LMH+16) C COMPUTE PINT,ZINT C PINT(1)=PTOP DO L=1,LMH DP1=P(L)-PINT(L) PINT(L+1)=P(L)+DP1 ENDDO ZINT(LMH+1)=FPACK(3) DO L=LMH,1,-1 TV2=T(L)*(1.0+0.608*Q(L)) ZZ=ROG*TV2*ALOG(PINT(L+1)/PINT(L)) ZINT(L)=ZINT(L+1)+ZZ ENDDO C C CALL PRECIP TYPE SUBROUTINES. C RIME=FPACK(LCL1ML*LMH+61) SR=FPACK(LCL1ML*LMH+58) TSKIN=FPACK(LCL1ML*LMH+12) CALL CALWXT(T,Q,P,PINT,LMH,LM,PPT,IWX1) CALL CALWXT_RAMER(T,Q,P,PINT,LMH,LM,PPT,IWX2) CALL CALWXT_BOURG(T,Q,PINT,LMH,LM,PPT,ZINT,IWX3) CALL CALWXT_REVISED(T,Q,P,PINT,LMH,LM,PPT,IWX4) C WARNING: EXPLICIT ALGORITHM. UNDER 18 NOT ADMITTED C WITHOUT PARENT OR GUARDIAN CALL CALWXT_EXPLICIT(LMH,TSKIN,PPT,SR,RIME,IWX5) C DOMINANT PTYPE COMPUTED FOR EACH STATION AT EACH FCST HR CALL CALWXT_DOMINANT(PPT,IWX1,IWX2,IWX3,IWX4,IWX5, * CSNO,CICE,CFZR,CRAI) C COMPUTE HELICITY AND STORM MOTION C CALL CALHEL(U,V,P,ZINT,PINT,LMH,LM,HELI,UST,VST) C C COMPUTE VISIBILITY C FIRST, EXTRACT SEA LEVEL PRESSURE SR=FPACK(LCL1ML*LMH+58) SLP=FPACK(LCL1ML*LMH+10) CPRATE=FPACK(LCL1ML*LMH+60) !--- Convective precip rate !---##### Need grid-scale contributions to QRAIN and QSNO from the profilm file!! QRAIN=RAIN(LMH) QSNO=IMXR(LMH) !-- Nearly all grid-scale ice is snow IF (CPRATE .GT. 0.) THEN RAINRATE=(1-SR)*CPRATE + (1-(SR/100.))*PPT/3600. TERM1=(T(LMH)/SLP)**0.4167 TERM2=(T(LMH)/(P(LMH)))**0.5833 TERM3=RAINRATE**0.8333 QRAIN=QRAIN+RAINCON*TERM1*TERM2*TERM3 IF (SR .GT. 0.) THEN SNORATE=SR*CPRATE TERM1=(T(LMH)/SLP)**0.47 TERM2=(T(LMH)/(P(LMH)))**0.53 TERM3=SNORATE**0.94 QSNO=QSNO+SNOCON*TERM1*TERM2*TERM3 ENDIF ENDIF TT=T(LMH) QV=Q(LMH) QCD=CWTR(LMH) ! QICE=IMXR(LMH) !--- Nearly all of grid-scale ice is snow QICE=0. PPP=P(LMH) CALL CALVIS(QV,QCD,QRAIN,QICE,QSNO,TT,PPP,HOVI) C COMPUTE CLOUD BASE PRESSURE C FIRST, EXTRACT THE CONVECTIVE CLOUD BASE HBOT=FPACK(LCL1ML*LMH+59) CLIMIT =1.0E-06 NEED = .TRUE. CDBP = SMISS CBOT = 5000 DO L=LMH,1,-1 C GSM C START AT THE FIRST LAYER ABOVE GROUND, AND FIND THE C FIRST LAYER WITH A VALUE OF CLOUD WATER GREATER THAN C THE SIGNIFICANT LIMIT (VALUE DESIGNATED BY Q. ZHAO). C THIS LAYER WILL BE THE CLOUD BOTTOM UNLESS THE BOTTOM C OF THE CONVECTIVE CLOUD (HBOT) IS FOUND BELOW IN WHICH C CASE HBOT BECOMES THE CLOUD BASE LAYER. IF ((CWTR(L)+IMXR(L)).GT.CLIMIT.AND.NEED) THEN CBOT=L IF (HBOT.GT.CBOT) THEN CBOT = HBOT ENDIF NEED=.FALSE. ENDIF ENDDO IF (CBOT.GT.LMH) THEN CDBP=SMISS ELSE CDBP=P(INT(CBOT)) ENDIF C C C SET ACC/AVERAGED VARIABLES TO MISSING IF IFCST=0 C IF (IFCST.EQ.0) THEN DO L=1,LMH FPACK(L+9+LMH*7)=SMISS FPACK(L+9+LMH*8)=SMISS ENDDO DO JK=16,29 FPACK(LCL1ML*LMH+JK)=SMISS ENDDO DO JK=32,34 FPACK(LCL1ML*LMH+JK)=SMISS ENDDO ENDIF C C ADD 9 SINGLE LEVEL VARIABLES TO THE OUTPUT C TACK THEM ON TO THE END; WE DON'T NEED CONVECTIVE C CLOUD BASE OR RIME, THOUGH, SO WRITE OVER THOSE RECORDS C NLENF=MAXLEN(INUMS) NLENP = 7 + LCL1ML1*LMH + LCL1SL1 FPACK(NLENF-2) = CSNO FPACK(NLENF-1) = CICE FPACK(NLENF) = CFZR FPACK(NLENF+1) = CRAI FPACK(NLENF+2) = UST FPACK(NLENF+3) = VST FPACK(NLENF+4) = HELI FPACK(NLENF+5) = CDBP FPACK(NLENF+6) = HOVI FPACK(5) = FPACK(5) + 1 !add ice mixing ratio space FPACK(6) = FPACK(6) + 8 !add 8 variables which are done in this code, RSM:46+8=54,ETA:50+8=58 FPACK(7) = 9 + FPACK(5)*FPACK(4) + FPACK(6) TOTALLEN = 9 + LMH*FPACK(5) + FPACK(6) + 4 c do PP=NLENF+9,TOTALLEN c FPACK(PP)=0.0 c enddo C C PLACE DATA INTO PRODAT IN PROPER LOCATIONS PRODAT (1,INUMS,JHR) = FLOAT(IFCST) PRODAT (2,INUMS,JHR) = FLOAT(ISTAT) C RISTAT is a REAL(8) variable by virtue of the fact that it C is equivalenced to CISTAT. Everything else stored in PRODAT C is REAL(4). We have made PRODAT REAL(4) but need a REAL(8) C array for storing RISTAT - that is what LPRO is. Farther C down in the code, we will pull values out of LPRO and store C in FRODAT ( a REAL(8) array ). cwas PRODAT (3,INUMS,JHR) = RISTAT LPRO ( INUMS,JHR) = RISTAT PRODAT (4,INUMS,JHR) = FPACK (1) PRODAT (5,INUMS,JHR) = FPACK (2) PRODAT (6,INUMS,JHR) = FPACK (3) PRODAT (7,INUMS,JHR) = 1 C FPACK HAS 9 ENTRIES BEFORE THE 1ST VERTICAL PROFILE, WHILE PRODAT HAS C ONLY 7. THIS ACCOUNTS FOR THE IJ-2 C NEED SEPARATE BLOCKS FOR EM VS. NMM MEMBERS C SUM TOTALS FOR COMPUTING MEAN, BUT DO NOT ADD IN ANY VALUE THAT C IS ONE OF THE MISSING VALUES C USE SPVALTRACK TO DETERMINE HOW MANY MEMBERS HAVE NON-SPVAL C VALUES FOR EACH PARAMETER IF (LL .LT. 8) THEN ! EM MEMBERS C WE FIRST MOVE THE VERTICAL PROFILE FIELDS INTO PRODAT C HAVE TO STOP AFTER THAT TO ADD IN ICE WATER DO IJ = 10, LCL1ML*LMH+9 IF (FPACK(IJ) .NE. SP1 .AND. FPACK(IJ) .NE. SP2 x .AND. FPACK(IJ) .NE. SP3 .AND. FPACK(IJ) .NE. SP4) THEN PRODAT (IJ-2,INUMS,JHR) = PRODAT(IJ-2,INUMS,JHR) x + FPACK (IJ) SPVALTRACK(IJ-2,INUMS,JHR)=SPVALTRACK(IJ-2,INUMS,JHR) + 1.0 ENDIF ENDDO C TACK ON THE ICE WATER TO THE PROFILE SECTION !.......... C IT IS CURRENTLY WRITTEN IN REVERSE ORDER. DO L=1,LMH LV=LMH-L+1 PRODAT(L+7+LMH*LCL1ML,INUMS,JHR)=IMXR(LV) SPVALTRACK(L+7+LMH*LCL1ML,INUMS,JHR)= x SPVALTRACK(L+7+LMH*LCL1ML,INUMS,JHR) + 1.0 ENDDO DO IJ = LCL1ML*LMH+10,NLENF+6 !all other surface variables IF (FPACK(IJ) .NE. SP1 .AND. FPACK(IJ) .NE. SP2 x .AND. FPACK(IJ) .NE. SP3 .AND. FPACK(IJ) .NE. SP4) THEN PRODAT(IJ+LMH-2,INUMS,JHR) = PRODAT(IJ+LMH-2,INUMS,JHR) x + FPACK (IJ) SPVALTRACK(IJ+LMH-2,INUMS,JHR)= x SPVALTRACK(IJ+LMH-2,INUMS,JHR) + 1.0 ENDIF ENDDO ELSE ! NMM/NMMB MEMBERS C START BUILDING PRODAT FROM FPACK, BUT STOP WHEN WE GET TO THE RAIN C ARRAY WHICH IS NOT WRITTEN TO PRODAT DO IJ = 10, (LCL1ML1-2)*LMH+9 IF (FPACK(IJ) .NE. SP1 .AND. FPACK(IJ) .NE. SP2 x .AND. FPACK(IJ) .NE. SP3 .AND. FPACK(IJ) .NE. SP4) THEN PRODAT (IJ-2,INUMS,JHR) = PRODAT(IJ-2,INUMS,JHR) x + FPACK (IJ) SPVALTRACK(IJ-2,INUMS,JHR)=SPVALTRACK(IJ-2,INUMS,JHR) + 1.0 ENDIF ENDDO C CONVERSION FROM FPACK INDEX TO PRODAT INDEX HAS TO ADD IN LMH C SINCE WE'RE SKIPPING OVER THE RAIN VALUES FROM FPACK DO IJ = (LCL1ML1-2)*LMH+10,MAXLEN(INUMS)+LMH+8 !all other sfc variables INDEX=IJ+LMH IF (FPACK(INDEX) .NE. SP1 .AND. FPACK(INDEX) .NE. SP2 x .AND. FPACK(INDEX) .NE. SP3 x .AND. FPACK(INDEX) .NE. SP4) THEN PRODAT(IJ-2,INUMS,JHR)=PRODAT(IJ-2,INUMS,JHR)+FPACK(INDEX) SPVALTRACK(IJ-2,INUMS,JHR)=SPVALTRACK(IJ-2,INUMS,JHR) + 1.0 ENDIF ENDDO ENDIF 3000 CONTINUE 4000 CONTINUE 998 CONTINUE ENDDO ! end of NUMSREF loop PROLENGTH=7+(LCL1ML-1)*LMH+LCL1SL1 DO MM=1,NPNT DO SS=1,NST PRECIP=PRODAT((LCL1ML1-1)*LMH+7+7,SS,MM) TYPES=PRODAT((LCL1ML1-1)*LMH+7+50,SS,MM) TYPEP=PRODAT((LCL1ML1-1)*LMH+7+51,SS,MM) TYPEZ=PRODAT((LCL1ML1-1)*LMH+7+52,SS,MM) TYPER=PRODAT((LCL1ML1-1)*LMH+7+53,SS,MM) c WE HAVE THE TALLIES OF THE DIFFERENT PTYPES AMONG C ALL MEMBERS; FIND THE DOMINANT ONE FOR EACH STATION C AT EACH TIME CALL CALWXT_DOMINANT2(PRECIP,TYPES,TYPEP,TYPEZ, * TYPER,SNOWY,SLEETY,ICY,RAINY) PRODAT((LCL1ML-1)*LMH+7+50,SS,MM)=SNOWY*NUMSREF PRODAT((LCL1ML-1)*LMH+7+51,SS,MM)=SLEETY*NUMSREF PRODAT((LCL1ML-1)*LMH+7+52,SS,MM)=ICY*NUMSREF PRODAT((LCL1ML-1)*LMH+7+53,SS,MM)=RAINY*NUMSREF SPVALTRACK((LCL1ML-1)*LMH+7+50,SS,MM)=NUMSREF SPVALTRACK((LCL1ML-1)*LMH+7+51,SS,MM)=NUMSREF SPVALTRACK((LCL1ML-1)*LMH+7+52,SS,MM)=NUMSREF SPVALTRACK((LCL1ML-1)*LMH+7+53,SS,MM)=NUMSREF ENDDO ENDDO C DON'T DO ANY AVERAGING FOR THE FIRST 7 SET FIELDS DO MM=1,NPNT DO SS=1,NST DO LL=1,7 PRODAT2(LL,SS,MM)=PRODAT(LL,SS,MM) ENDDO C COMPUTE THE MEANS. IF ALL THE VALUES ARE MISSING, C SET THE MEAN TO MISSING DO NN=8,PROLENGTH IF (SPVALTRACK(NN,SS,MM) .NE. 0) THEN PRODAT2(NN,SS,MM)=PRODAT(NN,SS,MM) / x SPVALTRACK(NN,SS,MM) ELSE PRODAT2(NN,SS,MM)=-9999. ENDIF ENDDO ENDDO ENDDO IF (MONOL) THEN C C WRITE OUT ONE FILE FOR ALL STATIONS C C INITIALIZE BUFR LISTS SO BFRHDR WILL BE CALLED THE FIRST C TIME THROUGH. C CLIST1(1)=' ' print *, 'inums ', INUMS DO I=1,INUMS NLVL(1)=LLMH(I) NLVL(2)=NSOIL C DO J=1,NPNT DO IJ = 1,NWORD FRODAT(IJ) = PRODAT2(IJ,I,J) ENDDO if (I .eq. 1 .and. J .eq. 2) then do MM=1,PROLENGTH print *, 'frodat check ', MM, FRODAT(MM) enddo endif FRODAT(3) = LPRO(I,J) ISTAT=NINT(FRODAT(2)) C C CALL BUFR-IZING ROUTINE C NSEQ = 8 SBSET = 'ETACLS1' print *, 'bfrize ', IYR,IMON,IDAY,IHRST CALL BFRIZE(LTBCL1,LUNCL1,SBSET,IYR,IMON,IDAY,IHRST 1, SEQNM1,SEQFLG,NSEQ,LVLWSE,FRODAT,NLVL,CLIST1,NP1 2, WORKK,IER) IF(IER.NE.0)WRITE(6,1080)ISTAT,IER,FRODAT(1) 1080 FORMAT(' SOME SORT OF ERROR ',2I8,F9.1) C C ENDDO ENDDO C C FINISHED, CLOSE UP BUFR FILES C NSEQ = 8 CALL BFRIZE(0,LUNCL1,SBSET,IYR,IMON,IDAY,IHRST 1, SEQNM1,SEQFLG,NSEQ,LVLWSE,FRODAT,NLVL,CLIST1,NP1 2, WORKK,IER) ENDIF C WRITE(STDOUT,*) ' END OF SOUNDING POST ' STOP END