SUBROUTINE ZSFED(TSTR,ZS,WATER,znot,wet,alb, a DXFINE,NGRNG,XLON1,XLAT1) PARAMETER (JNCX=150,INCX=150,KNMAX=42) PARAMETER (NNEST=3,NGRMMX=6,INFX=NGRMMX*INCX,JNFX=NGRMMX*JNCX) PARAMETER (IMXX=INFX,JMXX=JNFX) CHARACTER*12 IBLOCK CHARACTER*12 exp_n common/header/nstp_no,ic_date,exp_n DIMENSION NGRNG(3),XLON1(3),XLAT1(3) *, DS(JMXX), WATER(IMXX,JMXX) *,TSTR(IMXX,JMXX),ZS(IMXX,JMXX),znot(imxx,jmxx),wet(imxx,jmxx) dimension alb(imxx,jmxx) dimension zsc(imxx,jmxx),tstrc(imxx,jmxx),znotc(imxx,jmxx), a wetc(imxx,jmxx), albc(imxx,jmxx) C C THIS PROGRAM CREATES THE FIELDS OF ZSTAR , TSTAR , AND ZNOT FOR THE C RESOLUTION OF EACH NEST OF THE NESTED GRID MODEL. THESE FIELDS WILL BE C KEPT FIXED DURING THE LANDFALL SIMULATIONS, WITH THE FIELDS USED C IN THE MOVEMENT INTERPOLATION ROUTINES TO UPDATE THESE VARIABLES AS C THE GRIDS MOVE TO A NEW LATITUDE OR LONGITUDE C C CALL Q5MAPIN('DROPF','VBA=',ZS,'LEN=',2400,'LPAGE') .....NAVY TOPO CC CC THE FOLLOWING IS THE PRECENT OF WATER IN A GRID BOX ALLOWED UNTIL CC THAT POINT IS CONSIDERED AN OCEAN POINT PRECT=50.0 PI=4.*ATAN(1.0) RADN=PI/180. NSTM=NNEST-1 R=6.371E8 JMXM=JMX-1 IMXM=IMX-1 TLAPS=6.7/(980.*1.0E5) CC CC WRITE CONTROL BLOCK ON TOPOG. TAPE IBLOCK=exp_n NSTEP=nstp_no NONEST=NNEST ICDATE=ic_date WRITE(40) NSTEP,NONEST,IBLOCK,ICDATE CC WRITE(6,2117) (XLON1(NG),XLAT1(NG), NG=1,NNEST) 2117 FORMAT(2X,6E12.6) DYS=RADN*DXFINE YTLT=XLAT1(NNEST) DO 2085 J=1,JMXX DS(J)=2.0*R*R*SIN(.5*DYS)*COS(YTLT)*DYS YTLT=YTLT+DYS 2085 CONTINUE CC WE NOW DETERMINE THE % OF WATER FOR EACH POINT. THIS WILL BE STORED IN CC THE ARRAY CALLED WATER. A VALUE OF 100 MEANS ALL OCEAN. IN THIS TABLE CC ALL VALUES OF 49 OF LESS WILL BE CONSIDERED TO BE LAND POINTS CC CC CCC THE FINEST MESH TABLE HAS BEEN ESTABLISHED CCC C C NOW WE CREATE THE COARSER FIELDS USING THE FINEST RESOLUTION POINTS C THIS WILL BE DONE BE TAKING AN AREA WEIGHTED AVERAGE C C START WITH THE COARSEST MESH AND WORK INWARDLY C CC CC IF(NNEST.EQ.1) GO TO 701 NGRMG=1 DO 700 IB=1,NNEST-1 NGRMG=NGRMG*NGRNG(IB) NG=NGRMMX/NGRMG dxfin=dxfine*float(ng) toplat=xlat1(ib) toplon=xlon1(ib) IM1=IMXX/NG JM1=JMXX/NG JC=0 JCC=0 DO 319 J=1,JM1 ICC=0 IC=0 DO 317 I=1,IM1 JC=JCC SUMFL=0.0 ASUM=0.0 SUM=0.0 SUMW=0.0 sumzno=0.0 sumwet=0.0 sumalb=0.0 DO 507 JT=1,NG IC=ICC JC=JC+1 DO 505 IT=1,NG IC=IC+1 SUMFL = SUMFL + TSTR(IC,JC)*DS(JC) SUMW=SUMW+WATER(IC,JC)*DS(JC) ASUM=ASUM+DS(JC) znotp=znot(ic,jc) if(znot(ic,jc).lt.0.0) znotp=1.0 sumzno=sumzno+znotp *ds(jc) sumwet=sumwet+wet (ic,jc)*ds(jc) sumalb=sumalb+alb(ic,jc)*ds(jc) 505 SUM=SUM+zs(IC,JC)*DS(JC) 507 CONTINUE SUMW=SUMW/ASUM ICC=ICC+NG zsc(I,J)=SUM/ASUM tstrc(I,J)=SUMFL/ASUM znotc(I,J)=.1 * sumzno/asum wetc (I,J)=sumwet/asum albc (I,J)=sumalb/asum IF(SUMW.gt.PRECT) then znotc(I,J)=-99. wetc (I,J)=1.0 albc (I,J)=0.06 endif 317 CONTINUE JCC=JCC+NG 319 CONTINUE WRITE(40) XLON1(IB),XLAT1(IB) c c used to call vegetation here c DO 500 J=1,JM1 WRITE(40) (tstrc(I,J),I=1,im1), (zsc(i,j),i=1,im1), a (znotc(i,j),i=1,im1),(wetc (i,j),i=1,im1), b (albc(i,j),i=1,im1) 500 CONTINUE 700 CONTINUE 701 CONTINUE C END OF INNER NEST LOOP............................ WRITE(40) XLON1(NNEST),XLAT1(NNEST) toplat=xlat1(nnest) toplon=xlon1(nnest) DO 800 J=1,JMXX WRITE(40) (tstr(I,J),I=1,IMXX), (zs(i,j),i=1,imxx), a (znot(i,j),i=1,imxx),(wet (i,j),i=1,imxx), b (alb(i,j),i=1,imxx) 800 CONTINUE return END