SUBROUTINE TURBL C ****************************************************************** C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . C SUBPROGRAM: TURBL VERTICAL TURBULENT EXCHANGE C PRGRMMR: JANJIC ORG: W/NP2 DATE: 95-03-20 C C ABSTRACT: C TURBL UPDATES THE TURBULENT KINETIC ENERGY WITH THE PROD- C UCTION/DISSIPATION TERM AND THE VERTICAL DIFFUSION TERM C DIFFUSION TERM (USING AN IMPLICIT FORMULATION). EXCHANGE C COEFFICIENTS FOR THE SURFACE AND FOR ALL LAYER INTERFACES C ARE THEN COMPUTED AND THE EXCHANGE IS EXECUTED. C C PROGRAM HISTORY LOG: C 95-03-15 JANJIC - ORIGINATOR of the subroutines called, ! black & janjic originators of the driver C 95-03-28 BLACK - CONVERSION FROM 1-D TO 2-D IN HORIZONTAL C 96-03-29 BLACK - ADDED EXTERNAL EDGE; REMOVED SCRCH COMMON C 96-07-19 MESINGER - ADDED Z0 EFFECTIVE C 98-??-?? TUCCILLO - MODIFIED FOR CLASS VIII PARALLELISM C 98-10-27 BLACK - PARALLEL CHANGES INTO MOST RECENT CODE ! 02-01-10 janjic - moist turbulence (driver, mixlen, vdifh) ! 02-01-10 janjic - vert. dif of q2 increased (grenier&bretherton) ! 02-02-02 janjic - new sfcdif ! 05-03-02 janjic - removal of supersaturation at 2m and 10m C C USAGE: CALL TURBL FROM MAIN PROGRAM EBU C INPUT ARGUMENT LIST: C NONE C C OUTPUT ARGUMENT LIST: C NONE C C OUTPUT FILES: C NONE C C SUBPROGRAMS CALLED: C UNIQUE: MIXLEN C PRODQ2 C DIFCOF C SFCDIF C VDIFH C VDIFQ C VDIFV C C LIBRARY: NONE C C COMMON BLOCKS: CTLBLK C LOOPS C MASKS C DYNAM C PHYS2 C VRBLS C PVRBLS C INDX C Z0EFFT C C ATTRIBUTES: C LANGUAGE: FORTRAN 90 C MACHINE : IBM SP C$$$ C*********************************************************************** C Janjic, Z. I., 1996: The Mellor-Yamada level 2.5 scheme in the C NCEP Eta Model Eleventh Conference on Numerical Weather C Prediction, Norfolk, VA, 19-23 August 1996; American C Meteorological Society, Boston, MA, 333-334. C C Janjic, Z. I., 1996: The surface layer in the NCEP Eta Model. C Eleventh Conference on Numerical Weather Prediction, Norfolk, C VA, 19-23 August 1996; American Meteorological Society, Boston, C MA, 354-355. ! ! Janjic, Z. I., 2001: Nonsingular Implementation of the ! Mellor-Yamada Level 2.5 Scheme in the NCEP Meso model. ! NCEP Office Note #437, 61 pp. C*********************************************************************** C----------------------------------------------------------------------- INCLUDE 'EXCHM.h' INCLUDE "parmeta" INCLUDE "mpp.h" C----------------------------------------------------------------------- P A R A M E T E R &(CAPA=0.28589641,G=9.806,RG=1./G,ROG=287.04/G &,EPSZ=1.E-4,EPSQ2=0.2 &,IMJM=IM*JM-JM/2,LM1=LM-1,LP1=LM+1,JAM=6+2*(JM-10) &,ITB=76,JTB=134,ITBQ=152,JTBQ=440 &,NHRZ=(IDIM2-IDIM1+1)*(JDIM2-JDIM1+1)) ! parameter &(gocp02=9.8/1004.6*2.,gocp10=9.8/1004.6*10.,rcap=1004.6/287.04 &,a2=17.2693882,a3=273.16,a4=35.86,pq0=379.90516) !----------------------------------------------------------------------- !zj p a r a m e t e r &(efimn=.20,efmnt=.70 !zj+++ &,rhfs=.80,rhss=.85,rhfl=.80,rhsl=.85 ! ! *** SLOW RH MUST BE BELOW GRID SCALE PREC. RH &,rhfs=.75,rhss=.87,rhfl=.75,rhsl=.87 &,slops=(rhfs-rhss)/(1.-efimn) &,slopl=(rhfl-rhsl)/(1.-efimn)) ! parameter &(elivw=2.72e6,elocp=elivw/1004.6) C----------------------------------------------------------------------- INCLUDE "CTLBLK.comm" C----------------------------------------------------------------------- INCLUDE "LOOPS.comm" C----------------------------------------------------------------------- INCLUDE "MASKS.comm" C----------------------------------------------------------------------- INCLUDE "DYNAM.comm" C----------------------------------------------------------------------- INCLUDE "PHYS2.comm" C----------------------------------------------------------------------- INCLUDE "VRBLS.comm" C----------------------------------------------------------------------- include "NHYDRO.comm" !----------------------------------------------------------------------- INCLUDE "PVRBLS.comm" C----------------------------------------------------------------------- INCLUDE "CLDWTR.comm" INCLUDE "DUST8.comm" C----------------------------------------------------------------------- INCLUDE "INDX.comm" C----------------------------------------------------------------------- INCLUDE "Z0EFFT.comm" !----------------------------------------------------------------------- include "parmsoil" include "SOIL.comm" !----------------------------------------------------------------------- L O G I C A L & RUN,FIRST,RESTRT,SIGMA !----------------------------------------------------------------------- dimension vz0tbl(30) !----------------------------------------------------------------------- R E A L & CKLQ(IDIM1:IDIM2,JDIM1:JDIM2) &,CT (IDIM1:IDIM2,JDIM1:JDIM2) &,APE (IDIM1:IDIM2,JDIM1:JDIM2,LM) &,AKH (IDIM1:IDIM2,JDIM1:JDIM2,LM1) &,AKM (IDIM1:IDIM2,JDIM1:JDIM2,LM1) &,ZINT(IDIM1:IDIM2,JDIM1:JDIM2,LP1) &,UZ0H(IDIM1:IDIM2,JDIM1:JDIM2) &,VZ0H(IDIM1:IDIM2,JDIM1:JDIM2) C R E A L & AKMCOL(IDIM1:IDIM2,JDIM1:JDIM2,LM1) &,AKHCOL(IDIM1:IDIM2,JDIM1:JDIM2,LM1) &,AKMSV (IDIM1:IDIM2,JDIM1:JDIM2) &,ZCOL (IDIM1:IDIM2,JDIM1:JDIM2,LP1) &,UCOL (IDIM1:IDIM2,JDIM1:JDIM2,LM) &,VCOL (IDIM1:IDIM2,JDIM1:JDIM2,LM) &,the (idim1:idim2,jdim1:jdim2,lm) &,rho (idim1:idim2,jdim1:jdim2,lm) &,rho2 (idim1:idim2,jdim1:jdim2,lm) C R E A L & AKH_T (LM1,IDIM1:IDIM2,JDIM1:JDIM2) &,AKM_T (LM1,IDIM1:IDIM2,JDIM1:JDIM2) &,ZCOL_T (LP1,IDIM1:IDIM2,JDIM1:JDIM2) &,ZCOL_T2 (LP1,IDIM1:IDIM2,JDIM1:JDIM2) &,UCOL_T (LM,IDIM1:IDIM2,JDIM1:JDIM2) &,VCOL_T (LM,IDIM1:IDIM2,JDIM1:JDIM2) &,TCOL_T (LM,IDIM1:IDIM2,JDIM1:JDIM2) &,QCOL_T (LM,IDIM1:IDIM2,JDIM1:JDIM2) &,Q2COL_T (LM,IDIM1:IDIM2,JDIM1:JDIM2) &,wcol_t (lm,idim1:idim2,jdim1:jdim2) &,scol_t (lm,idim1:idim2,jdim1:jdim2,KPS) &,rrcol_t (lm,idim1:idim2,jdim1:jdim2) &,apecol_t(lm,idim1:idim2,jdim1:jdim2) &,hcol_t (lm,idim1:idim2,jdim1:jdim2) &,rhcol_t (lm,idim1:idim2,jdim1:jdim2) &,rhcol_t2 (lm,idim1:idim2,jdim1:jdim2) C R E A L & GM(LM1),GH(LM1),EL(LM1),ZEFF(4) !----------------------------------------------------------------------- data vz0tbl &/2.653,0.826,0.563,1.089,0.854,0.856,0.035,0.238,0.065,0.076 &,0.011,0.035,0.011,0.000,0.000,0.000,0.000,0.000,0.000,0.000 &,0.000,0.000,0.000,0.000,0.000,0.000,0.000,0.000,0.000,0.000/ !----------------------------------------------------------------------- save ct !----------------------------------------------------------------------- C*** C*** THE FOLLOWING ARE USED FOR TIMIMG PURPOSES ONLY C*** real*8 timef real nhb_tim,mpp_tim,init_tim common/timing/surfce_tim,nhb_tim,res_tim,exch_tim C*********************************************************************** C----------------------------------------------------------------------- if(ntsd.lt.nphs) then !----------------------------------------------------------------------- call zero2(ct) ! do j=myjs2_p1,myje2_p1 do i=myis_p1,myie1_p1 if(sm(i,j)+sice(i,j).lt.0.5) then ! z0(i,j)=z0(i,j)+vz0tbl(ivgtyp(i,j)) ! z0(i,j)=vz0tbl(ivgtyp(i,j)) c z0(i,j)=vz0tbl(ivgtyp(i,j))+0.1 ! z0land endif enddo enddo !----------------------------------------------------------------------- endif !----------------------------------------------------------------------- CALL ZERO3(AKM,LM1) CALL ZERO3(ZINT,LP1) CALL ZERO3_T(AKH_T,LM1) CALL ZERO3_T(AKM_T,LM1) CALL ZERO2(UZ0H) CALL ZERO2(VZ0H) C----------------------------------------------------------------------- C*** C*** COMPUTE THE HEIGHTS OF THE LAYER INTERFACES AND THE EXNER FUNCTION C*** !$omp parallel do DO J=MYJS_P1,MYJE_P1 ! This line is correct c DO J=MYJS2_P1,MYJE2_P1 ! This line matches operations DO I=MYIS_P1,MYIE_P1 ZINT(I,J,LP1)=EPSZ IF(SIGMA)ZINT(I,J,LP1)=RG*FIS(I,J) ENDDO ENDDO AKNUDG=5*1.e-4 ! * dtq2/dt deltim = dtq2 xnudg=maxval(S8NUDG) if( NTSD*dt.le.6*3600) print *,"iz TURBL nudg:" + ,ntsd,NTSD*dt/3600.,xnudg ! do l=lm,1,-1 do j=myjs1_p1,myje1_p1 do i=myis_p1,myie_p1 pdslp=pd(i,j)*res(i,j) apests=(pint(i,j,l)+pint(i,j,l+1))*0.5 tl=t(i,j,l) cl=cwm(i,j,l) ! zl=(q(i,j,l)*0.608-cl+1.)*tl/apests 1 *(deta1(l)*pdtop+deta2(l)*pdslp)*rog 2 +zint(i,j,l+1) zint(i,j,l)=(zl-dfrlg(l))*htm(i,j,l)+dfrlg(l) apel=(1.e5/apests)**capa ape(i,j,l)=apel ! the(i,j,l)=(cl*(-elocp/tl)+1.)*tl*apel cpj rho(i,j,l) = apests/(rog*g*tl*(1.+.608*q(i,j,l)-cwm(i,j,l))) if( NTSD*DT.le.6*3600) then cboj ako necu nudging if( NTSD*DT.le.-4*DT) then c print *," nudge",xnudg*1.e+9,dtq2,NTSD*deltim/3500. AKNUDG=0. do k=1,8 cbojan S8(i,j,l,k)=S8(i,j,l,k) S8(i,j,l,k)=(S8(i,j,l,k)+ . AKNUDG*DELTIM*S8NUDG(i,j,l,k))/(1+AKNUDG*DELTIM) enddo endif enddo enddo enddo !!!! C----------------------------------------------------------------------- C*** C*** REMOVE NEGATIVE Q2 C*** !$omp parallel do DO 40 L=1,LM DO J=MYJS_P1,MYJE_P1 DO I=MYIS_P1,MYIE_P1 Q2(I,J,L)=AMAX1(Q2(I,J,L)*HBM2(I,J),EPSQ2) ENDDO ENDDO 40 CONTINUE print *,"TURBLrr8:",maxval(rr8) C----------------------------------------------------------------------- !$omp parallel do DO J=MYJS2_P1,MYJE2_P1 DO I=MYIS_P1,MYIE_P1 UZ0H(I,J)=(UZ0(I+IHE(J),J)+UZ0(I+IHW(J),J) 1 +UZ0(I,J+1)+UZ0(I,J-1))*HBM2(I,J)*0.25 VZ0H(I,J)=(VZ0(I+IHE(J),J)+VZ0(I+IHW(J),J) 1 +VZ0(I,J+1)+VZ0(I,J-1))*HBM2(I,J)*0.25 ENDDO ENDDO C !$omp parallel do DO J=MYJS,MYJE DO I=MYIS,MYIE LPBL(I,J)=LMH(I,J)-1 ENDDO ENDDO C----------------------------------------------------------------------- C----------------------------------------------------------------------- C*** PREPARE THE EXCHANGE COEFFICIENTS C----------------------------------------------------------------------- C----------------------------------------------------------------------- C*** C*** COMPUTE VELOCITY COMPONENTS AT H POINTS C*** !$omp parallel do private(rwmsk,wmsk) DO 60 L=1,LM C DO J=MYJS2_P1,MYJE2_P1 DO I=MYIS_P1,MYIE_P1 WMSK=VTM(I+IHE(J),J,L)+VTM(I+IHW(J),J,L) 1 +VTM(I,J+1,L)+VTM(I,J-1,L) IF(WMSK.GT.0.)THEN RWMSK=1./WMSK UCOL(I,J,L)=(U(I+IHE(J),J,L)*VTM(I+IHE(J),J,L) 1 +U(I+IHW(J),J,L)*VTM(I+IHW(J),J,L) 2 +U(I,J+1,L)*VTM(I,J+1,L)+U(I,J-1,L)*VTM(I,J-1,L)) 3 *RWMSK VCOL(I,J,L)=(V(I+IHE(J),J,L)*VTM(I+IHE(J),J,L) 1 +V(I+IHW(J),J,L)*VTM(I+IHW(J),J,L) 2 +V(I,J+1,L)*VTM(I,J+1,L)+V(I,J-1,L)*VTM(I,J-1,L)) 3 *RWMSK ELSE UCOL(I,J,L)=0. VCOL(I,J,L)=0. ENDIF ENDDO ENDDO 60 CONTINUE C*** C*** FILL TRANSPOSED ARRAYS C*** !$omp parallel sections !$omp section CALL SGETMO(T,NHRZ,NHRZ,LM,TCOL_T,LM) !$omp section CALL SGETMO(Q,NHRZ,NHRZ,LM,QCOL_T,LM) !$omp section do k1=1,KPS CALL SGETMO(S8(:,:,:,k1),NHRZ,NHRZ,LM,SCOL_T(:,:,:,k1),LM) enddo !$omp section CALL SGETMO(RR8,NHRZ,NHRZ,LM,RRCOL_T,LM) !$omp section call sgetmo(the,nhrz,nhrz,lm,hcol_t,lm) !$omp section call sgetmo(rho,nhrz,nhrz,lm,rhcol_t,lm) !$omp section call sgetmo(cwm,nhrz,nhrz,lm,wcol_t,lm) !$omp section call sgetmo(ape,nhrz,nhrz,lm,apecol_t,lm) !$omp section CALL SGETMO(Q2,NHRZ,NHRZ,LM,Q2COL_T,LM) !$omp section CALL SGETMO(ZINT,NHRZ,NHRZ,LP1,ZCOL_T,LP1) !$omp section CALL SGETMO(UCOL,NHRZ,NHRZ,LM,UCOL_T,LM) !$omp section CALL SGETMO(VCOL,NHRZ,NHRZ,LM,VCOL_T,LM) !$omp end parallel sections C---------------------------------------------------------------------- C*** C*** FIND THE MIXING LENGTH C*** !$omp parallel do private(el,gh,gm,hpbl,lmhk,lmhm,lmhp) !$omp& private(ulm,vlm,wstar,zeff) DO 100 J=MYJS2_P1,MYJE2_P1 DO 100 I=MYIS_P1,MYIE1_P1 LMHK=LMH(I,J) LMHP=LMHK+1 LMHM=LMHK-1 ! call mixlen &(lmhk,lpbl(i,j),hpbl,ct(i,j) &,ucol_t(1,i,j),vcol_t(1,i,j) &,tcol_t(1,i,j),hcol_t(1,i,j),qcol_t(1,i,j) &,wcol_t(1,i,j),q2col_t(1,i,j),zcol_t(1,i,j) &,gm,gh,el) ! C----------------------------------------------------------------------- C*** C*** SOLVE FOR THE PRODUCTION/DISSIPATION OF C*** THE TURBULENT KINETIC ENERGY C*** C call prodq2(lmhk,dtq2,ustar(i,j),gm,gh,el,q2col_t(1,i,j)) C C----------------------------------------------------------------------- C*** C*** FIND THE EXCHANGE COEFFICIENTS IN THE FREE ATMOSPHERE C*** CALL DIFCOF(LMHK,GM,GH,EL,Q2COL_T(1,I,J) 1, ZCOL_T(1,I,J),AKM_T(1,I,J),AKH_T(1,I,J)) C----------------------------------------------------------------------- C*** C*** CARRY OUT THE VERTICAL DIFFUSION OF C*** TURBULENT KINETIC ENERGY C*** C call vdifq(lmhk,dtq2,q2col_t(1,i,j),el,zcol_t(1,i,j)) C----------------------------------------------------------------------- C*** C*** FIND THE Z0 EFFECTIVE C*** ZEFF(1)=z0(i,j) ! ZEFFIJ(I,J,1) ZEFF(2)=z0(i,j) !ZEFFIJ(I,J,2) ZEFF(3)=z0(i,j) ! ZEFFIJ(I,J,3) ZEFF(4)=z0(i,j) ! ZEFFIJ(I,J,4) C----------------------------------------------------------------------- C*** C*** FIND THE SURFACE EXCHANGE COEFFICIENTS C*** rapa=(pint(i,j,lmhk+1)/100000.)**capa tz0=thz0(i,j)*rapa ! ulm=ucol(i,j,lmhk) vlm=vcol(i,j,lmhk) tlm=t(i,j,lmhk) thlm=tlm*ape(i,j,lmhk) thvlm=the(i,j,lmhk) qlm=q(i,j,lmhk) clm=cwm(i,j,lmhk) zsl=(zint(i,j,lmhk)-zint(i,j,lmhk+1))*0.5 plm=(pint(i,j,lmhk)+pint(i,j,lmhk+1))*0.5 fis1 = zint(i,j,lmhk+1) ! call sfcdif &(fis(i,j),sm(i,j),ths(i,j),qs(i,j) &,uz0h(i,j),vz0h(i,j),tz0,thz0(i,j),qz0(i,j) &,ustar(i,j),wstar &,z0(i,j),akms(i,j),akhs(i,j),hpbl,ct(i,j) &,u10(i,j),v10(i,j),tshltr(i,j),th10(i,j),qshltr(i,j),q10(i,j) &,ulm,vlm,tlm,thlm,thvlm,qlm,clm,zsl,akhsd(i,j)) ! th02p=tshltr(i,j) th10p=th10(i,j) ! rapa02=rapa-gocp02/th02p rapa10=rapa-gocp10/th10p ! t02p=th02p*rapa02 t10p=th10p*rapa10 ! p02p=(rapa02**rcap)*100000. p10p=(rapa10**rcap)*100000. ! qs02=pq0/p02p*exp(a2*(t02p-a3)/(t02p-a4)) qs10=pq0/p10p*exp(a2*(t10p-a3)/(t10p-a4)) ! if(qshltr(i,j).gt.qs02) qshltr(i,j)=qs02 if(q10 (i,j).gt.qs10) q10 (i,j)=qs10 ! cdepos dez = 2*zsl NTHS = isltyp(i,j) NTHV = ivgtyp(i,j) snd = snd8(i,j) btas= dlt8s(i,j) btac= dlt8c(i,j) smc1= smc(i,j,1) deltim = dtq2 c============================ do k1 = 1, KPS dload8 (i,j,k1) = 0 c============================ NTHP=k1 ! RDSTP depdx = 0 depwx = 0 call sfcddep(deltim,sm(i,j),snd,z0(i,j) + ,ustar(i,j),u10(i,j),v10(i,j) + ,NTHP,NTHS,NTHV,PLM,TLM,depdx,depwx + ,LM,rrcol_t(:,i,j),zint(i,j,:), scol_t(:,i,j,k1)) depd8(i,j,k1) = depd8(i,j,k1)+depdx depw8(i,j,k1) = depw8(i,j,k1)+depwx sz01 = sz0(i,j,k1) slm2 = scol_t(lmhk,i,j,k1) call sfcssz0(snd,z0(i,j),smc1,ustar(i,j),akhs(i,j) . ,NTHP,NTHS,slm2,sz01,btas,btac,fis1) sz0(i,j,k1) = sz01 c============================ c do l=1,lm c dload8(i,j,k1) = dload8(i,j,k1)+ c . (pint(i,j,l+1)-pint(i,j,l))/g*scol_t(l,i,j,k1) c enddo enddo ! KPS c============================ !zj !zj if(deep(i,j).gt.0.5) then !zj efi=cldefi(i,j) !zj fac=(1.-((efi-efimn)*slops+rhss))/(1.-rhfs)*sm(i,j) !zj & +(1.-((efi-efimn)*slopl+rhsl))/(1.-rhfl)*(1.-sm(i,j)) !zj fac=efi !zj fac=1. ! off ! !zj akms(i,j)=akms(i,j)*fac !zj akhs(i,j)=akhs(i,j)*fac !zj endif 100 CONTINUE C------------------------------------------------------------------------ C*** C*** FILL STANDARD ARRAYS FROM TRANSPOSED ARRAYS C*** !$omp parallel sections !$omp section CALL SGETMO(Q2COL_T,LM,LM,NHRZ,Q2,NHRZ) !$omp section CALL SGETMO(AKH_T,LM1,LM1,NHRZ,AKH,NHRZ) !$omp section CALL SGETMO(AKM_T,LM1,LM1,NHRZ,AKM,NHRZ) !$omp end parallel sections C----------------------------------------------------------------------- C*** C*** UNCOMPUTED LOCATIONS MUST BE FILLED IN FOR THE POST-PROCESSOR C*** IIM=IM-MY_IS_GLB+1 JJM=JM-MY_JS_GLB+1 C C*** EASTERN GLOBAL BOUNDARY C IF(MY_IE_GLB.EQ.IM)THEN DO J=1,JM IF(J.GE.MY_JS_GLB.AND.J.LE.MY_JE_GLB)THEN JJ=J-MY_JS_GLB+1 TH10(IIM,JJ)=TH10(IIM-1,JJ) Q10(IIM,JJ)=Q10(IIM-1,JJ) U10(IIM,JJ)=U10(IIM-1,JJ) V10(IIM,JJ)=V10(IIM-1,JJ) TSHLTR(IIM,JJ)=TSHLTR(IIM-1,JJ) QSHLTR(IIM,JJ)=QSHLTR(IIM-1,JJ) ENDIF ENDDO ENDIF C C*** SOUTHERN GLOBAL BOUNDARY C IF(MY_JS_GLB.EQ.1)THEN DO J=1,2 DO I=1,IM IF(I.GE.MY_IS_GLB.AND.I.LE.MY_IE_GLB)THEN II=I-MY_IS_GLB+1 TH10(II,J)=TH10(II,3) Q10(II,J)=Q10(II,3) U10(II,J)=U10(II,3) V10(II,J)=V10(II,3) TSHLTR(II,J)=TSHLTR(II,3) QSHLTR(II,J)=QSHLTR(II,3) ENDIF ENDDO ENDDO ENDIF C C*** NORTHERN GLOBAL BOUNDARY C IF(MY_JE_GLB.EQ.JM)THEN DO J=JM-1,JM JJ=J-MY_JS_GLB+1 DO I=1,IM IF(I.GE.MY_IS_GLB.AND.I.LE.MY_IE_GLB)THEN II=I-MY_IS_GLB+1 TH10(II,JJ)=TH10(II,JJM-2) Q10(II,JJ)=Q10(II,JJM-2) U10(II,JJ)=U10(II,JJM-2) V10(II,JJ)=V10(II,JJM-2) TSHLTR(II,JJ)=TSHLTR(II,JJM-2) QSHLTR(II,JJ)=QSHLTR(II,JJM-2) ENDIF ENDDO ENDDO ENDIF C----------------------------------------------------------------------- C----------------------------------------------------------------------- C----------------------------------------------------------------------- btim=timef() CALL EXCH(UZ0H,1,1,1) CALL EXCH(VZ0H,1,1,1) exch_tim=exch_tim+timef()-btim C*** C*** AVERAGE UZ0 AND VZ0 BACK TO V POINTS C*** !$omp parallel do DO 125 J=MYJS2,MYJE2 DO 125 I=MYIS,MYIE UZ0(I,J)=(UZ0H(I+IVE(J),J)*HBM2(I+IVE(J),J) 1 +UZ0H(I+IVW(J),J)*HBM2(I+IVW(J),J) 2 +UZ0H(I,J+1)*HBM2(I,J+1)+UZ0H(I,J-1)*HBM2(I,J-1))*0.25 VZ0(I,J)=(VZ0H(I+IVE(J),J)*HBM2(I+IVE(J),J) 1 +VZ0H(I+IVW(J),J)*HBM2(I+IVW(J),J) 2 +VZ0H(I,J+1)*HBM2(I,J+1)+VZ0H(I,J-1)*HBM2(I,J-1))*0.25 125 CONTINUE C----------------------------------------------------------------------- C*** C*** EXECUTE THE GROUND PROCESSES C*** cpjpazi CALL SURFCE(APE(IDIM1,JDIM1,1),ZINT(IDIM1,JDIM1,1) 1, CKLQ(IDIM1,JDIM1)) C C----------------------------------------------------------------------- C----------------------------------------------------------------------- C*** EXECUTE THE VERTICAL EXCHANGE C----------------------------------------------------------------------- C----------------------------------------------------------------------- btim=timef() CALL EXCH(AKM,LM1,1,1) CALL EXCH(AKMS,1,1,1) CALL EXCH(ZINT,LP1,1,1) exch_tim=exch_tim+timef()-btim C !$omp parallel do DO L=1,LM1 DO J=MYJS2,MYJE2 DO I=MYIS,MYIE AKMCOL(I,J,L)=(AKM(I+IVE(J),J,L)*HBM2(I+IVE(J),J) 1 +AKM(I+IVW(J),J,L)*HBM2(I+IVW(J),J) 2 +AKM(I,J+1,L)*HBM2(I,J+1)+AKM(I,J-1,L)*HBM2(I,J-1)) 3 *VTM(I,J,L)*VBM2(I,J)*0.25 AKHCOL(I,J,L)=AKH(I,J,L)*HTM(I,J,L)*HBM2(I,J) ENDDO ENDDO ENDDO C !$omp parallel do DO J=MYJS2,MYJE2 DO I=MYIS,MYIE THZ0(I,J)=(1.-SM(I,J))*THS(I,J)+SM(I,J)*THZ0(I,J) QZ0 (I,J)=(1.-SM(I,J))*QS (I,J)+SM(I,J)*QZ0 (I,J) AKMSV(I,J)=(AKMS(I+IVE(J),J)*HBM2(I+IVE(J),J) 1 +AKMS(I+IVW(J),J)*HBM2(I+IVW(J),J) 2 +AKMS(I,J+1)*HBM2(I,J+1)+AKMS(I,J-1)*HBM2(I,J-1)) 3 *VBM2(I,J)*0.25 ENDDO ENDDO C !$omp parallel do DO L=1,LP1 DO J=MYJS2,MYJE2 DO I=MYIS,MYIE ZCOL(I,J,L)=0.25*(ZINT(I+IVE(J),J,L)+ZINT(I+IVW(J),J,L) 1 +ZINT(I,J+1,L)+ZINT(I,J-1,L)) rho2(I,J,L)=0.25*(rho(I+IVE(J),J,L)+rho(I+IVW(J),J,L) 1 +rho(I,J+1,L)+rho(I,J-1,L)) ENDDO ENDDO ENDDO C*** C*** TRANSPOSE ARRAYS C*** !$omp parallel sections !$omp section CALL SGETMO(ZCOL,NHRZ,NHRZ,LP1,ZCOL_T2,LP1) !$omp section CALL SGETMO(U,NHRZ,NHRZ,LM,UCOL_T,LM) !$omp section CALL SGETMO(rho2,NHRZ,NHRZ,LM,rhcol_T2,LM) !$omp section CALL SGETMO(V,NHRZ,NHRZ,LM,VCOL_T,LM) !$omp section CALL SGETMO(AKHCOL,NHRZ,NHRZ,LM1,AKH_T,LM1) !$omp section CALL SGETMO(AKMCOL,NHRZ,NHRZ,LM1,AKM_T,LM1) !$omp end parallel sections C----------------------------------------------------------------------- !$omp parallel do private(lmhk,lmvk) DO 200 J=MYJS2,MYJE2 DO 200 I=MYIS,MYIE1 C LMHK=LMH(I,J) LMVK=LMV(I,J) C*** C*** CARRY OUT THE VERTICAL DIFFUSION OF C*** TEMPERATURE, WATER VAPOR and cloudwater C*** call vdifh(lmhk,dtq2,thz0(i,j),qz0(i,j),sz0(i,j,:),akhs(i,j) +, akhsd(i,j) 1, ct(i,j),cklq(i,j) c 2, hcol_t(1,i,j),qcol_t(1,i,j),wcol_t(1,i,j),akh_t(1,i,j) c 2, hcol_t(1,i,j),qcol_t(1,i,j),wcol_t(1,i,j),scol_t(1,i,j) c 3, akh_t(1,i,j),zcol_t(1,i,j)) 2, hcol_t(:,i,j),qcol_t(:,i,j),wcol_t(:,i,j),scol_t(:,i,j,:) 3, akh_t(:,i,j),zcol_t(:,i,j),rhcol_t(:,i,j)) ! C----------------------------------------------------------------------- C*** C*** CARRY OUT THE VERTICAL DIFFUSION OF C*** VELOCITY COMPONENTS C*** call vdifv(lmvk,dtq2,uz0(i,j),vz0(i,j) c 1, akmsv(i,j),ucol_t(1,i,j),vcol_t(1,i,j) c 2, akm_t(1,i,j),zcol_t2(1,i,j)) 1, akmsv(i,j),ucol_t(:,i,j),vcol_t(:,i,j) 2, akm_t(:,i,j),zcol_t2(:,i,j),rhcol_t2(:,i,j)) C C----------------------------------------------------------------------- 200 CONTINUE C----------------------------------------------------------------------- C----------------------------------------------------------------------- C*** C*** FILL STANDARD ARRAYS FROM TRANSPOSED ARRAYS C*** !$omp parallel sections !$omp section CALL SGETMO(QCOL_t,LM,LM,NHRZ,Q,NHRZ) !$omp section call sgetmo(hcol_t,lm,lm,nhrz,the,nhrz) !$omp section call sgetmo(wcol_t,lm,lm,nhrz,cwm,nhrz) !$omp section do k1=1, KPS call sgetmo(scol_t(:,:,:,k1),lm,lm,nhrz,S8(:,:,:,k1),nhrz) enddo !$omp section call sgetmo(rrcol_t,lm,lm,nhrz,rr8 ,nhrz) ! call sgetmo(rrcol_t,lm,lm,nhrz,arr8 ,nhrz) !$omp section CALL SGETMO(UCOL_t,LM,LM,NHRZ,U,NHRZ) !$omp section CALL SGETMO(VCOL_t,LM,LM,NHRZ,V,NHRZ) !$omp end parallel sections !------------unpack equivalent liquid potential temperature------------- do l=1,lmhk do j=myjs2,myje2 do i=myis,myie1 t(i,j,l)=cwm(i,j,l)*elocp+(the(i,j,l)/ape(i,j,l)) enddo enddo enddo !----------------------------------------------------------------------- C*** C*** REMOVE NEGATIVE Q2 C*** !$omp parallel do DO L=1,LM DO J=MYJS,MYJE DO I=MYIS,MYIE Q2(I,J,L)=AMAX1(Q2(I,J,L)*HBM2(I,J),EPSQ2) ENDDO ENDDO ENDDO print *,"depw:depd",maxval(depw8),maxval(depd8) C---------------------------------------------------------------------- RETURN END