subroutine sig2p USE mod_vrbls USE mod_extra implicit none include 'param_o.h' !! include 'extra.comm' include 'mapot.comm' include 'const.h' include 'dynam.comm' integer,parameter::im_jm_nm=(im+2)*(jm+2)*nm real,parameter::g=9.80616,RD1=287.04,GAMMA=6.5E-3, & RGAMOG=RD1*GAMMA/G integer::nhold,lp,i,j,n,lsl,nn,l,lmvij,lv real,dimension(0:im+1,0:jm+1,nm)::tsl,qsl,fsl integer,dimension(0:im+1,0:jm+1,nm)::nl1x real,dimension(0:im+1,0:jm+1,nm)::alpetux,alpet2x,usl,vsl integer,dimension(im_jm_nm)::ihold,jhold,nnhold real::pnl1,B,fac,pu,tu,tabv,pl,tl,tabo,ahf,tblo, & petal,petau,alpetl,alpetu,alpet2,fact,alpet1,trf open(1,file='../data_out/tmpfld.dat',form='unformatted') lsl=lsm DO 310 LP=1,LSL NHOLD=0 do 125 n=1,nm DO 125 J=1,jm DO 125 I=1,IM ! TSL(I,J,n)=-1.E6 QSL(I,J,n)=-1.E6 FSL(I,J,n)=-1.E6 TRF=2.*ALSL(LP) ! !*** LOCATE VERTICAL INDEX OF MODEL INTERFACE JUST BELOW !*** THE PRESSURE LEVEL TO WHICH WE ARE INTERPOLATING. ! DO 115 L=2,LP1 if(i.eq.10.and.j.eq.12.and.n.eq.1)then ! print *,l,alpint(i,j,n,l),alsl(lp) endif IF(ALPINT(I,J,n,L).GE.ALSL(LP))THEN NL1X(I,J,n)=L NHOLD=NHOLD+1 IHOLD(NHOLD)=I JHOLD(NHOLD)=J nnhold(nhold)=n GO TO 125 ELSEIF(ALPINT(I,J,n,LP1).LT.ALSL(LP))THEN NL1X(I,J,n)=LP1 NHOLD=NHOLD+1 IHOLD(NHOLD)=I JHOLD(NHOLD)=J nnhold(nhold)=n GO TO 125 ENDIF 115 CONTINUE ! 125 CONTINUE DO 220 NN=1,NHOLD I=IHOLD(NN) J=JHOLD(NN) n=nnHOLD(NN) PNL1=PINT(I,J,n,NL1X(I,J,n)) IF(NL1X(I,J,n).EQ.1)THEN !--------------------------------------------------------------------- !*** EXTRAPOLATE ABOVE THE TOPMOST MIDLAYER OF THE MODEL !--------------------------------------------------------------------- ! PU=PINT(I,J,n,2) TU=0.5*(T(I,J,n,1)+T(I,J,n,2)) TABV=TU*(SPL(LP)/PU)**RGAMOG B =TABV FAC =0. AHF =0. ELSEIF(NL1X(I,J,n).EQ.LP1)THEN !--------------------------------------------------------------------- !*** EXTRAPOLATE BELOW LOWEST MODEL MIDLAYER (BUT STILL ABOVE GROUND) !--------------------------------------------------------------------- ! PL=PINT(I,J,n,LM-1) TL=0.5*(T(I,J,n,LM-2)+T(I,J,n,LM-1)) TBLO=TL*(SPL(LP)/PL)**RGAMOG B =TBLO FAC =0. AHF =0. ELSE !--------------------------------------------------------------------- !*** INTERPOLATION BETWEEN NORMAL LOWER AND UPPER BOUNDS !--------------------------------------------------------------------- ! B =T(I,J,n,NL1X(I,J,n)) FAC =2.*ALOG(PT+PDSL(I,J,n)*AETA(NL1X(I,J,n))) AHF =(B-T(I,J,n,NL1X(I,J,n)-1))/ & (ALPINT(I,J,n,NL1X(I,J,n)+1)-ALPINT(I,J,n,NL1X(I,J,n)-1)) ENDIF TSL(I,J,n)=B+AHF*(TRF-FAC) FSL(I,J,n)=(PNL1-SPL(LP))/(SPL(LP)+PNL1) & *((ALSL(LP)+ALPINT(I,J,n,NL1X(I,J,n))-FAC)*AHF+B)*Rd*2. & +ZINT(I,J,n,NL1X(I,J,n))*G if(i.eq.30.and.j.eq.101.and.n.eq.3)then print *,i,j,n,tsl(i,j,n),t(i,j,n,37),t(i,j,n,38),spl(lp),pl endif 220 CONTINUE do 281 n=1,nm DO 281 J=1,jm-1 DO 281 I=1,IM-1 !NOTE !NOTE 29 JANUARY 1993, RUSS TREADON. !NOTE - AS FOR THE OTHER FIELDS WE INTERPOLATE ONLY !NOTE BETWEEN THE FAL AND THE MODEL TOP. BELOW !NOTE SURFACE VALUES ARE FAL VALUES. ! LMVIJ=LM ! DO 280 LV=2,LMVIJ+1 PETAL=PT+PDVP1(I,J,n)*ETA(LV) PETAU=PT+PDVP1(I,J,n)*ETA(LV-1) ALPETL=ALOG(PETAL) ALPETU=ALOG(PETAU) ALPET2=SQRT(0.5*(ALPETL*ALPETL+ALPETU*ALPETU)) ! !*** SEARCH FOR HIGHEST MID-LAYER MODEL SURFACE !*** THAT IS BELOW THE GIVEN STANDARD PRESSURE LEVEL. ! IF(ALSL(LP).LT.ALPET2)THEN NL1X(I,J,n)=LV-1 ALPETUX(I,J,n)=ALPETU ALPET2X(I,J,n)=ALPET2 GO TO 281 ENDIF 280 CONTINUE ! NL1X(I,J,n)=LMVIJ+1 ALPETUX(I,J,n)=ALPETU ALPET2X(I,J,n)=ALPET2 281 CONTINUE ! !--------------------------------------------------------------------- !*** BELOW GROUND USE WIND IN LOWEST LAYER !--------------------------------------------------------------------- ! do 290 n=1,nm DO 290 J=1,jm-1 DO 290 I=1,IM-1 LMVIJ=LM IF(NL1X(I,J,n).GT.LMVIJ)THEN USL(I,J,n)=U(I,J,n,LMVIJ) VSL(I,J,n)=V(I,J,n,LMVIJ) ! !--------------------------------------------------------------------- !*** IF REQUESTED PRESSURE LEVEL IS NOT BELOW THE LOCAL GROUND !*** THEN WE HAVE TWO POSSIBILITIES. IF THE REQUESTED PRESSURE !*** LEVEL IS BETWEEN THE LOCAL SURFACE PRESSURE AND TOP OF !*** MODEL PRESSURE, VERTICALLY INTERPOLATE BETWEEN NEAREST !*** BOUNDING ETA LEVELS TO GET THE WIND COMPONENTS. IF THE !*** REQUESTED PRESSURE LEVEL IS ABOVE THE MODEL TOP, USE !*** CONSTANT EXTRAPOLATION OF TOP ETA LAYER (L=1) WINDS. !--------------------------------------------------------------------- ! ELSE IF(NL1X(I,J,n).GT.1)THEN ALPETL=ALPETUX(I,J,n) PETAU=PT+PDVP1(I,J,n)*ETA(NL1X(I,J,n)-1) ALPETU=ALOG(PETAU) ALPET1=SQRT(0.5*(ALPETL*ALPETL+ALPETU*ALPETU)) FACT=(ALPET2X(I,J,n)-ALSL(LP))/(ALPET2X(I,J,n)-ALPET1) USL(I,J,n)=U(I,J,n,NL1X(I,J,n)) & +(U(I,J,n,NL1X(I,J,n)-1)-U(I,J,n,NL1X(I,J,n)))*FACT VSL(I,J,n)=V(I,J,n,NL1X(I,J,n))+(V(I,J,n,NL1X(I,J,n)-1) & -V(I,J,n,NL1X(I,J,n)))*FACT ELSE USL(I,J,n)=U(I,J,n,NL1X(I,J,n)) VSL(I,J,n)=V(I,J,n,NL1X(I,J,n)) ENDIF ! !--------------------------------------------------------------------- !*** ALPET2 IS MID-LAYER ETA SURFACE JUST BELOW STANDARD PRESSURE !*** LEVEL AND ALPET1 IS MID-LAYER ETA SURFACE JUST ABOVE. !*** NOTE THAT IF THE STANDARD PRESSURE SURFACE IS SUBMERGED, THEN !*** ALPET2 AND ALPET1 ARE THE LOWEST AND 2ND LOWEST MID-LAYER !*** ETA SURFACES ABOVE THE TOPOGRAPHY (WITH OLDRD=.TRUE., ZJ). !--------------------------------------------------------------------- ! ENDIF 290 CONTINUE call bocoh(fsl,im,jm,nm) call bocov(usl,vsl,im,jm,nm) write(1)fsl write(1)usl write(1)vsl write(1)tsl 310 continue do n=1,nm do j=1,jm do i=1,im ! print *,i,j,n,fsl(i,j,n,1) enddo enddo enddo close(1) end subroutine sig2p