> C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& SUBROUTINE HDIFFS SUBROUTINE HDIFFS > C ****************************************************************** > C$$$ SUBPROGRAM DOCUMENTATION BLOCK > C . . . > C SUBPROGRAM: HDIFF HORIZONTAL DIFFUSION > C PRGRMMR: JANJIC ORG: W/NP22 DATE: 93-11-17 > C > C ABSTRACT: > C HDIFF CALCULATES THE CONTRIBUTION OF THE HORIZONTAL DIFFUSION > C TO THE TENDENCIES OF TEMPERATURE, SPECIFIC HUMIDITY, WIND > C COMPONENTS, AND TURBULENT KINETIC ENERGY AND THEN UPDATES THOSE > C VARIABLES. A SECOND-ORDER NONLINEAR SCHEME SIMILAR TO > C SMAGORINSKYS IS USED WHERE THE DIFFUSION COEFFICIENT IS > C A FUNCTION OF THE DEFORMATION FIELD AND OF THE TURBULENT > C KINETIC ENERGY. > C > C PROGRAM HISTORY LOG: > C 87-06-?? JANJIC - ORIGINATOR > C 95-03-25 BLACK - CONVERSION FROM 1-D TO 2-D IN HORIZONTAL > C 96-03-28 BLACK - ADDED EXTERNAL EDGE > C 98-10-30 BLACK - MODIFIED FOR DISTRIBUTED MEMORY > C > C USAGE: CALL HDIFF FROM MAIN PROGRAM EBU > C > C INPUT ARGUMENT LIST: > C NONE > C > C OUTPUT ARGUMENT LIST: > C NONE > C > C OUTPUT FILES: > C NONE > C > C SUBPROGRAMS CALLED: > C > C UNIQUE: NONE > C > C LIBRARY: NONE > C > C COMMON BLOCKS: CTLBLK > C MASKS > C PHYS > C VRBLS > C PVRBLS > C INDX > C > C ATTRIBUTES: > C LANGUAGE: FORTRAN 90 > C MACHINE : IBM SP > C$$$ C*********************************************************************** C*********************************************************************** Cfm Calculaton of hdiff v at points that have a neighboring "blocked" v Cfm Calculaton of hdiff v at points that have a neighboring "blocked" v C-- switched on (loops 410 and 420), using velocities at points on C-- switched on (loops 410 and 420), using velocities at points on C-- slopes, but only half of the diffusion coefficient (note Fig. 2 of C-- slopes, but only half of the diffusion coefficient (note Fig. 2 of C-- the "upgraded Eta" paper) C-- the "upgraded Eta" paper) C-- fm and Sandra Morelli, June-July 2013 C-- fm and Sandra Morelli, June-July 2013 C----------------------------------------------------------------------- < P A R A M E T E R < & (D00=0.E0,DEFC=08.0E0,DEFM=32.E0,SCQ2=050.E0 < &, EPSQ2=0.2,FCDIF=1.0E0, D50=.5E0,RFCP=.25E0/1004.6E0) < C----------------------------------------------------------------------- C----------------------------------------------------------------------- > C ****************************************************************** > P A R A M E T E R > & (DEFC=8.0,DEFM=32.0,SCQ2=50.0 > &, EPSQ2=0.2,FCDIF=1.0,RFCP=.25/1004.6) > C---------------------------------------------------------------------- INCLUDE "parmeta" INCLUDE "parmeta" INCLUDE "parm.tbl" INCLUDE "parm.tbl" INCLUDE "mpp.h" INCLUDE "mpp.h" C----------------------------------------------------------------------- | #include "sp.h" > C---------------------------------------------------------------------- P A R A M E T E R P A R A M E T E R & (LDA=LM+9,LA=13,KSMUD=01) | & (IMJM=IM*JM-JM/2,LP1=LM+1,KSMUD=1) C***WARNING*** IF LM.GT.16 THEN SET LDA=LM+9 < P A R A M E T E R P A R A M E T E R & (IMJM=IM*JM-JM/2 | &(JAM=6+2*(JM-10),JAMD=(JAM*2-10)*3) &, LP1=LM+1 < &, LSCRCH=4*LM+1+LA+1) < C----------------------------------------------------------------------- C----------------------------------------------------------------------- L O G I C A L L O G I C A L & RUN,FIRST,RESTRT,SIGMA & RUN,FIRST,RESTRT,SIGMA &,SECOND,HEAT | &,SECOND,HEAT,STTDF C----------------------------------------------------------------------- | C---------------------------------------------------------------------- INCLUDE "CTLBLK.comm" INCLUDE "CTLBLK.comm" C----------------------------------------------------------------------- C----------------------------------------------------------------------- INCLUDE "MASKS.comm" INCLUDE "MASKS.comm" C----------------------------------------------------------------------- C----------------------------------------------------------------------- > INCLUDE "DYNAMD.comm" > C----------------------------------------------------------------------- INCLUDE "PHYS.comm" INCLUDE "PHYS.comm" C----------------------------------------------------------------------- C----------------------------------------------------------------------- INCLUDE "VRBLS.comm" INCLUDE "VRBLS.comm" C----------------------------------------------------------------------- C----------------------------------------------------------------------- INCLUDE "PVRBLS.comm" INCLUDE "PVRBLS.comm" C----------------------------------------------------------------------- C----------------------------------------------------------------------- > INCLUDE "CLDWTR.comm" > C----------------------------------------------------------------------- INCLUDE "INDX.comm" INCLUDE "INDX.comm" Cfm--------------------------------------------------------------------- | CGSM----------------------------------------------------------------------- INCLUDE "SLOPES.comm" INCLUDE "SLOPES.comm" C----------------------------------------------------------------------- C----------------------------------------------------------------------- D I M E N S I O N D I M E N S I O N & Q2L (IDIM1:IDIM2,JDIM1:JDIM2) | & Q2L (IDIM1:IDIM2,JDIM1:JDIM2),UT (IDIM1:IDIM2,JDIM1:JDIM2) &,HKNE (IDIM1:IDIM2,JDIM1:JDIM2),HKSE (IDIM1:IDIM2,JDIM1:JDIM2) &,HKNE (IDIM1:IDIM2,JDIM1:JDIM2),HKSE (IDIM1:IDIM2,JDIM1:JDIM2) &,VKNE (IDIM1:IDIM2,JDIM1:JDIM2),VKSE (IDIM1:IDIM2,JDIM1:JDIM2) &,VKNE (IDIM1:IDIM2,JDIM1:JDIM2),VKSE (IDIM1:IDIM2,JDIM1:JDIM2) > &,HMASK(IDIM1:IDIM2,JDIM1:JDIM2),HMSKL(IDIM1:IDIM2,JDIM1:JDIM2) C C D I M E N S I O N D I M E N S I O N & TNE (IDIM1:IDIM2,JDIM1:JDIM2),TSE (IDIM1:IDIM2,JDIM1:JDIM2) & TNE (IDIM1:IDIM2,JDIM1:JDIM2),TSE (IDIM1:IDIM2,JDIM1:JDIM2) &,QNE (IDIM1:IDIM2,JDIM1:JDIM2),QSE (IDIM1:IDIM2,JDIM1:JDIM2) &,QNE (IDIM1:IDIM2,JDIM1:JDIM2),QSE (IDIM1:IDIM2,JDIM1:JDIM2) &,Q2NE (IDIM1:IDIM2,JDIM1:JDIM2),Q2SE (IDIM1:IDIM2,JDIM1:JDIM2) &,Q2NE (IDIM1:IDIM2,JDIM1:JDIM2),Q2SE (IDIM1:IDIM2,JDIM1:JDIM2) &,UNE (IDIM1:IDIM2,JDIM1:JDIM2),USE (IDIM1:IDIM2,JDIM1:JDIM2) &,UNE (IDIM1:IDIM2,JDIM1:JDIM2),USE (IDIM1:IDIM2,JDIM1:JDIM2) &,VNE (IDIM1:IDIM2,JDIM1:JDIM2),VSE (IDIM1:IDIM2,JDIM1:JDIM2) &,VNE (IDIM1:IDIM2,JDIM1:JDIM2),VSE (IDIM1:IDIM2,JDIM1:JDIM2) &,TDIF (IDIM1:IDIM2,JDIM1:JDIM2),QDIF (IDIM1:IDIM2,JDIM1:JDIM2) &,TDIF (IDIM1:IDIM2,JDIM1:JDIM2),QDIF (IDIM1:IDIM2,JDIM1:JDIM2) &,UDIF (IDIM1:IDIM2,JDIM1:JDIM2),VDIF (IDIM1:IDIM2,JDIM1:JDIM2) &,UDIF (IDIM1:IDIM2,JDIM1:JDIM2),VDIF (IDIM1:IDIM2,JDIM1:JDIM2) &,Q2DIF(IDIM1:IDIM2,JDIM1:JDIM2) &,Q2DIF(IDIM1:IDIM2,JDIM1:JDIM2) &,DEF (IDIM1:IDIM2,JDIM1:JDIM2),CKE (IDIM1:IDIM2,JDIM1:JDIM2) &,DEF (IDIM1:IDIM2,JDIM1:JDIM2),CKE (IDIM1:IDIM2,JDIM1:JDIM2) C----------------------------------------------------------------------- C----------------------------------------------------------------------- > C*** > C*** DIFFUSING Q2 AT GROUND LEVEL DOESNT MATTER, USTAR2 IS RECALCULATED > C*** > C----------------------------------------------------------------------- SECOND=.TRUE. SECOND=.TRUE. HEAT=.TRUE. | HEAT=.FALSE. > CGSM HEAT=.TRUE. > LUL=UL(1) > C----------------------------------------------------------------------- > DO J=MYJS_P1,MYJE_P2 > C-011115 DO I=MYIS_P1,MYIE_P2 > DO I=MYIS_P2,MYIE_P2 > HMASK(I,J)=1. > HMSKL(I,J)=1. > ENDDO > ENDDO > C----------------------------------------------------------------------- > IF(SIGMA)THEN > DO 100 J=MYJS2_P1,MYJE2_P1 > C > DO I=MYIS1_P1,MYIE1_P1 > DH1=ABS(FIS(I+IHW(J),J-1)-FIS(I,J)) > DH2=ABS(FIS(I+IHE(J),J-1)-FIS(I,J)) > DH3=ABS(FIS(I+IHW(J),J+1)-FIS(I,J)) > DH4=ABS(FIS(I+IHE(J),J+1)-FIS(I,J)) > C > DHM=AMAX1(DH1,DH2,DH3,DH4)/DY > C > IF(DHM.GT.0.100)THEN > HMASK(I,J)=0. > HMSKL(I,J)=0. > ENDIF > ENDDO > C > 100 CONTINUE > ENDIF C----------------------------------------------------------------------- C----------------------------------------------------------------------- DO 600 KS=1,KSMUD DO 600 KS=1,KSMUD C--------------MAIN VERTICAL INTEGRATION LOOP--------------------------- | C----------------------------------------------------------------------- > C---------------------MAIN VERTICAL INTEGRATION LOOP-------------------- > C----------------------------------------------------------------------- > !$omp parallel do > !$omp& private(cke,def,defsk,deftk,hkne,hkse,hmskl,q2dif,q2l,q2ne,q2se, > !$omp& qdif,qne,qse,tdif,tne,tse,udif,une,use,utk,vdif,vkne, > !$omp& vkse,vne,vse,vtk) > C----------------------------------------------------------------------- DO 500 L=1,LM DO 500 L=1,LM CVVVVDIFFUSING Q2 AT GROUND LEVEL DOESN'T MATTER, USTAR2 IS RECALCULATED < C----------------------------------------------------------------------- C----------------------------------------------------------------------- CALL ZERO2(TNE) | CALL ZERO2(DEF) CALL ZERO2(TSE) < CALL ZERO2(QNE) < CALL ZERO2(QSE) < CALL ZERO2(Q2NE) CALL ZERO2(Q2NE) CALL ZERO2(Q2SE) CALL ZERO2(Q2SE) > CALL ZERO2(QNE) > CALL ZERO2(QSE) > CALL ZERO2(TNE) > CALL ZERO2(TSE) CALL ZERO2(UNE) CALL ZERO2(UNE) CALL ZERO2(USE) CALL ZERO2(USE) CALL ZERO2(VNE) < CALL ZERO2(VSE) CALL ZERO2(VSE) > CALL ZERO2(VNE) > CGSM > CALL ZERO2(CKE) > CGSM CALL ZERO2(TDIF) CALL ZERO2(TDIF) CALL ZERO2(QDIF) CALL ZERO2(QDIF) CALL ZERO2(UDIF) CALL ZERO2(UDIF) CALL ZERO2(VDIF) CALL ZERO2(VDIF) CALL ZERO2(Q2DIF) CALL ZERO2(Q2DIF) CALL ZERO2(DEF) < CALL ZERO2(CKE) < C----------------------------------------------------------------------- C----------------------------------------------------------------------- C DO 210 J=1,JM < C DO 210 I=1,IM < DO 210 J=MYJS_P1,MYJE_P1 DO 210 J=MYJS_P1,MYJE_P1 DO 210 I=MYIS_P1,MYIE_P1 DO 210 I=MYIS_P1,MYIE_P1 Q2L(I,J)=AMAX1(Q2(I,J,L),EPSQ2) Q2L(I,J)=AMAX1(Q2(I,J,L),EPSQ2) 210 CONTINUE 210 CONTINUE C----------------------------------------------------------------------- C----------------------------------------------------------------------- Cfm Fill the v points at slopes with the wind above -------------------- Cfm Fill the v points at slopes with the wind above -------------------- IF (L.GT.1) THEN IF (L.GT.1) THEN DO 215 J=MYJS_P1,MYJE_P1 DO 215 J=MYJS_P1,MYJE_P1 DO 215 I=MYIS_P1,MYIE_P1 DO 215 I=MYIS_P1,MYIE_P1 IF (VTMS(I,J,L).EQ.1) THEN | IF (VTMS(I,J,L).EQ.1) THEN U(I,J,L)=U(I,J,L-1) | U(I,J,L)=U(I,J,L-1) V(I,J,L)=V(I,J,L-1) | V(I,J,L)=V(I,J,L-1) ENDIF | ENDIF 215 CONTINUE 215 CONTINUE ENDIF | END IF C--------------DEFORMATIONS--------------------------------------------- C--------------DEFORMATIONS--------------------------------------------- C DO 220 J=2,JM-1 < C DO 220 I=1,IM-1 < DO 220 J=MYJS1_P1,MYJE1_P1 DO 220 J=MYJS1_P1,MYJE1_P1 DO 220 I=MYIS_P1,MYIE1_P1 DO 220 I=MYIS_P1,MYIE1_P1 > C > IF(L.LT.LUL)THEN > !zj HMSKL(I,J)=1. > HMSKL(I,J)=HMASK(I,J) > ELSE > HMSKL(I,J)=HMASK(I,J) > ENDIF > C DEFTK =U(I+IHE(J),J,L)-U(I+IHW(J),J,L)-V(I,J+1,L)+V(I,J-1,L) DEFTK =U(I+IHE(J),J,L)-U(I+IHW(J),J,L)-V(I,J+1,L)+V(I,J-1,L) DEFSK =U(I,J+1,L)-U(I,J-1,L)+V(I+IHE(J),J,L)-V(I+IHW(J),J,L) DEFSK =U(I,J+1,L)-U(I,J-1,L)+V(I+IHE(J),J,L)-V(I+IHW(J),J,L) DEF (I,J)=DEFTK *DEFTK +DEFSK *DEFSK +SCQ2*Q2L(I,J) | DEF (I,J)=DEFTK*DEFTK+DEFSK*DEFSK DEF (I,J)=SQRT(DEF(I,J)+DEF(I,J))*HBM2(I,J) DEF (I,J)=SQRT(DEF(I,J)+DEF(I,J))*HBM2(I,J) c DEF(I,J)=AMAX1(DEF(I,J),DEFC) | DEF(I,J)=AMAX1(DEF(I,J),DEFC) c DEF(I,J)=AMIN1(DEF(I,J),DEFM) c DEF(I,J)=AMIN1(DEF(I,J),DEFM) > DEF(I,J)=DEF(I,J)*HMSKL(I,J) 220 CONTINUE 220 CONTINUE C--------------T,Q, Q2 DIAGONAL CONTRIBUTIONS--------------------------- C--------------T,Q, Q2 DIAGONAL CONTRIBUTIONS--------------------------- C DO 250 J=1,JM-1 < C DO 250 I=1,IM-1 < DO 250 J=MYJS_P1,MYJE1_P1 DO 250 J=MYJS_P1,MYJE1_P1 DO 250 I=MYIS_P1,MYIE1_P1 DO 250 I=MYIS_P1,MYIE1_P1 HKNE(I,J)=(DEF(I,J)+DEF(I+IHE(J),J+1)) HKNE(I,J)=(DEF(I,J)+DEF(I+IHE(J),J+1)) 1 *HTM(I,J,L)*HTM(I+IHE(J),J+1,L) 1 *HTM(I,J,L)*HTM(I+IHE(J),J+1,L) > 2 *HMSKL(I,J)*HMSKL(I+IHE(J),J+1) TNE (I,J)=(T (I+IHE(J),J+1,L)-T (I,J,L))*HKNE(I,J) TNE (I,J)=(T (I+IHE(J),J+1,L)-T (I,J,L))*HKNE(I,J) QNE (I,J)=(Q (I+IHE(J),J+1,L)-Q (I,J,L))*HKNE(I,J) QNE (I,J)=(Q (I+IHE(J),J+1,L)-Q (I,J,L))*HKNE(I,J) Q2NE(I,J)=(Q2(I+IHE(J),J+1,L)-Q2(I,J,L))*HKNE(I,J) Q2NE(I,J)=(Q2(I+IHE(J),J+1,L)-Q2(I,J,L))*HKNE(I,J) 250 CONTINUE 250 CONTINUE C C C DO 260 J=2,JM < C DO 260 I=1,IM-1 < DO 260 J=MYJS1_P1,MYJE_P1 DO 260 J=MYJS1_P1,MYJE_P1 DO 260 I=MYIS_P1,MYIE1_P1 DO 260 I=MYIS_P1,MYIE1_P1 HKSE(I,J)=(DEF(I+IHE(J),J-1)+DEF(I,J)) HKSE(I,J)=(DEF(I+IHE(J),J-1)+DEF(I,J)) 1 *HTM(I+IHE(J),J-1,L)*HTM(I,J,L) 1 *HTM(I+IHE(J),J-1,L)*HTM(I,J,L) > 2 *HMSKL(I+IHE(J),J-1)*HMSKL(I,J) TSE (I,J)=(T (I+IHE(J),J-1,L)-T (I,J,L))*HKSE(I,J) TSE (I,J)=(T (I+IHE(J),J-1,L)-T (I,J,L))*HKSE(I,J) QSE (I,J)=(Q (I+IHE(J),J-1,L)-Q (I,J,L))*HKSE(I,J) QSE (I,J)=(Q (I+IHE(J),J-1,L)-Q (I,J,L))*HKSE(I,J) Q2SE(I,J)=(Q2(I+IHE(J),J-1,L)-Q2(I,J,L))*HKSE(I,J) Q2SE(I,J)=(Q2(I+IHE(J),J-1,L)-Q2(I,J,L))*HKSE(I,J) 260 CONTINUE 260 CONTINUE C----------------------------------------------------------------------- C----------------------------------------------------------------------- C DO 270 J=2,JM-1 < C DO 270 I=2,IM < DO 270 J=MYJS1,MYJE1 DO 270 J=MYJS1,MYJE1 DO 270 I=MYIS1,MYIE DO 270 I=MYIS1,MYIE TDIF (I,J)=(TNE (I,J)-TNE (I+IHW(J),J-1) TDIF (I,J)=(TNE (I,J)-TNE (I+IHW(J),J-1) 1 +TSE (I,J)-TSE (I+IHW(J),J+1))*HDAC(I,J) 1 +TSE (I,J)-TSE (I+IHW(J),J+1))*HDAC(I,J) QDIF (I,J)=(QNE (I,J)-QNE (I+IHW(J),J-1) QDIF (I,J)=(QNE (I,J)-QNE (I+IHW(J),J-1) 1 +QSE (I,J)-QSE (I+IHW(J),J+1))*HDAC(I,J)*FCDIF 1 +QSE (I,J)-QSE (I+IHW(J),J+1))*HDAC(I,J)*FCDIF Q2DIF(I,J)=(Q2NE(I,J)-Q2NE(I+IHW(J),J-1) Q2DIF(I,J)=(Q2NE(I,J)-Q2NE(I+IHW(J),J-1) 1 +Q2SE(I,J)-Q2SE(I+IHW(J),J+1))*HDAC(I,J) 1 +Q2SE(I,J)-Q2SE(I+IHW(J),J+1))*HDAC(I,J) 270 CONTINUE 270 CONTINUE C--------------2-ND ORDER DIFFUSION------------------------------------- C--------------2-ND ORDER DIFFUSION------------------------------------- IF(SECOND)THEN IF(SECOND)THEN C DO 280 J=3,JM-2 < C DO 280 I=2,IM-1 < DO 280 J=MYJS2,MYJE2 DO 280 J=MYJS2,MYJE2 DO 280 I=MYIS1,MYIE1 DO 280 I=MYIS1,MYIE1 T (I,J,L)=T (I,J,L)+TDIF (I,J) T (I,J,L)=T (I,J,L)+TDIF (I,J) Q (I,J,L)=Q (I,J,L)+QDIF (I,J) Q (I,J,L)=Q (I,J,L)+QDIF (I,J) 280 CONTINUE 280 CONTINUE C C C----------------------------------------------------------------------- C----------------------------------------------------------------------- C IF(L.NE.LM)THEN | IF(L.NE.LM)THEN C DO 290 J=3,JM-2 < C DO 290 I=2,IM-1 < DO 290 J=MYJS2,MYJE2 DO 290 J=MYJS2,MYJE2 DO 290 I=MYIS1,MYIE1 DO 290 I=MYIS1,MYIE1 Q2(I,J,L)=Q2(I,J,L)+Q2DIF(I,J) | Q2(I,J,L)=Q2(I,J,L)+Q2DIF(I,J)*HTM(I,J,L+1) 290 CONTINUE 290 CONTINUE C ENDIF | ENDIF C C GO TO 360 GO TO 360 ENDIF ENDIF C--------------4-TH ORDER DIAGONAL CONTRIBUTIONS------------------------ C--------------4-TH ORDER DIAGONAL CONTRIBUTIONS------------------------ C DO 310 J=1,JM-1 < C DO 310 I=1,IM-1 < DO 310 J=MYJS,MYJE1 DO 310 J=MYJS,MYJE1 DO 310 I=MYIS,MYIE1 DO 310 I=MYIS,MYIE1 TNE (I,J)=(TDIF (I+IHE(J),J+1)-TDIF (I,J))*HKNE(I,J) TNE (I,J)=(TDIF (I+IHE(J),J+1)-TDIF (I,J))*HKNE(I,J) QNE (I,J)=(QDIF (I+IHE(J),J+1)-QDIF (I,J))*HKNE(I,J) QNE (I,J)=(QDIF (I+IHE(J),J+1)-QDIF (I,J))*HKNE(I,J) Q2NE(I,J)=(Q2DIF(I+IHE(J),J+1)-Q2DIF(I,J))*HKNE(I,J) Q2NE(I,J)=(Q2DIF(I+IHE(J),J+1)-Q2DIF(I,J))*HKNE(I,J) 310 CONTINUE 310 CONTINUE C C C DO 320 J=2,JM < C DO 320 I=1,IM-1 < DO 320 J=MYJS1,MYJE DO 320 J=MYJS1,MYJE DO 320 I=MYIS,MYIE1 DO 320 I=MYIS,MYIE1 TSE (I,J)=(TDIF (I+IHE(J),J-1)-TDIF (I,J))*HKSE(I,J) TSE (I,J)=(TDIF (I+IHE(J),J-1)-TDIF (I,J))*HKSE(I,J) QSE (I,J)=(QDIF (I+IHE(J),J-1)-QDIF (I,J))*HKSE(I,J) QSE (I,J)=(QDIF (I+IHE(J),J-1)-QDIF (I,J))*HKSE(I,J) Q2SE(I,J)=(Q2DIF(I+IHE(J),J-1)-Q2DIF(I,J))*HKSE(I,J) Q2SE(I,J)=(Q2DIF(I+IHE(J),J-1)-Q2DIF(I,J))*HKSE(I,J) 320 CONTINUE 320 CONTINUE C----------------------------------------------------------------------- C----------------------------------------------------------------------- C DO 330 J=3,JM-2 < C DO 330 I=2,IM-1 < DO 330 J=MYJS2,MYJE2 DO 330 J=MYJS2,MYJE2 DO 330 I=MYIS1,MYIE1 DO 330 I=MYIS1,MYIE1 T(I,J,L)=T(I,J,L)-(TNE (I,J)-TNE (I+IHW(J),J-1) T(I,J,L)=T(I,J,L)-(TNE (I,J)-TNE (I+IHW(J),J-1) 1 +TSE (I,J)-TSE (I+IHW(J),J+1))*HDAC(I,J) 1 +TSE (I,J)-TSE (I+IHW(J),J+1))*HDAC(I,J) Q(I,J,L)=Q(I,J,L)-(QNE (I,J)-QNE (I+IHW(J),J-1) Q(I,J,L)=Q(I,J,L)-(QNE (I,J)-QNE (I+IHW(J),J-1) 1 +QSE (I,J)-QSE (I+IHW(J),J+1))*HDAC(I,J) 1 +QSE (I,J)-QSE (I+IHW(J),J+1))*HDAC(I,J) 2 *FCDIF 2 *FCDIF 330 CONTINUE 330 CONTINUE C C C----------------------------------------------------------------------- C----------------------------------------------------------------------- C IF(L.NE.LM)THEN | IF(L.NE.LM)THEN C DO 340 J=3,JM-2 < C DO 340 I=2,IM-1 < DO 340 J=MYJS2,MYJE2 DO 340 J=MYJS2,MYJE2 DO 340 I=MYIS1,MYIE1 DO 340 I=MYIS1,MYIE1 Q2(I,J,L)=Q2(I,J,L)-(Q2NE(I,J)-Q2NE(I+IHW(J),J-1) | Q2(I,J,L)=Q2(I,J,L)-(Q2NE(I,J)-Q2NE(I+IHW(J),J-1) 1 +Q2SE(I,J)-Q2SE(I+IHW(J),J+1))*HDAC(I,J) | 1 +Q2SE(I,J)-Q2SE(I+IHW(J),J+1))*HDAC(I,J) 340 CONTINUE | 2 *HTM(I,J,L+1) C ENDIF | 340 CONTINUE > ENDIF C--------------U,V, DIAGONAL CONTRIBUTIONS------------------------------ C--------------U,V, DIAGONAL CONTRIBUTIONS------------------------------ C 360 DO 410 J=1,JM-1 < C DO 410 I=1,IM-1 < 360 DO 410 J=MYJS_P1,MYJE1_P1 360 DO 410 J=MYJS_P1,MYJE1_P1 DO 410 I=MYIS_P1,MYIE1_P1 DO 410 I=MYIS_P1,MYIE1_P1 VKNE(I,J)=(DEF(I+IVE(J),J)+DEF(I,J+1)) VKNE(I,J)=(DEF(I+IVE(J),J)+DEF(I,J+1)) Cfm 1 *VTM(I,J,L)*VTM(I+IVE(J),J+1,L) | CGSM 1 *VTM(I,J,L)*VTM(I+IVE(J),J+1,L) > CGSM 2 *HMASK(I+IVE(J),J)*HMASK(I,J+1) 1 *MAX(VTM(I+IVE(J),J+1,L),VTMS(I+IVE(J),J+1,L)) 1 *MAX(VTM(I+IVE(J),J+1,L),VTMS(I+IVE(J),J+1,L)) > > IF (MYPE.EQ.0.OR.L.EQ.LM) THEN > write(55,*) mype,i,j,l,VTM(I+IVE(J),J+1,L),VTMS(I+IVE(J),J+1,L) > ENDIF > UNE(I,J)=(U(I+IVE(J),J+1,L)-U(I,J,L))*VKNE(I,J) UNE(I,J)=(U(I+IVE(J),J+1,L)-U(I,J,L))*VKNE(I,J) VNE(I,J)=(V(I+IVE(J),J+1,L)-V(I,J,L))*VKNE(I,J) VNE(I,J)=(V(I+IVE(J),J+1,L)-V(I,J,L))*VKNE(I,J) 410 CONTINUE 410 CONTINUE C C C DO 420 J=2,JM < C DO 420 I=1,IM-1 < DO 420 J=MYJS1_P1,MYJE_P1 DO 420 J=MYJS1_P1,MYJE_P1 DO 420 I=MYIS_P1,MYIE1_P1 DO 420 I=MYIS_P1,MYIE1_P1 VKSE(I,J)=(DEF(I,J-1)+DEF(I+IVE(J),J)) VKSE(I,J)=(DEF(I,J-1)+DEF(I+IVE(J),J)) Cfm 1 *VTM(I+IVE(J),J-1,L)*VTM(I,J,L) | CGSM 1 *VTM(I+IVE(J),J-1,L)*VTM(I,J,L) > CGSM 2 *HMASK(I,J-1)*HMASK(I+IVE(J),J) 1 *MAX(VTM(I+IVE(J),J-1,L),VTMS(I+IVE(J),J-1,L)) 1 *MAX(VTM(I+IVE(J),J-1,L),VTMS(I+IVE(J),J-1,L)) > > IF (MYPE.EQ.0.OR.L.EQ.LM) THEN > write(56,*) mype,i,j,l,VTM(I+IVE(J),J-1,L),VTMS(I+IVE(J),J-1,L) > ENDIF > USE(I,J)=(U(I+IVE(J),J-1,L)-U(I,J,L))*VKSE(I,J) USE(I,J)=(U(I+IVE(J),J-1,L)-U(I,J,L))*VKSE(I,J) VSE(I,J)=(V(I+IVE(J),J-1,L)-V(I,J,L))*VKSE(I,J) VSE(I,J)=(V(I+IVE(J),J-1,L)-V(I,J,L))*VKSE(I,J) 420 CONTINUE 420 CONTINUE C----------------------------------------------------------------------- C----------------------------------------------------------------------- C DO 430 J=2,JM-1 < C DO 430 I=1,IM-1 < DO 430 J=MYJS1,MYJE1 DO 430 J=MYJS1,MYJE1 DO 430 I=MYIS,MYIE1 DO 430 I=MYIS,MYIE1 UDIF(I,J)=(UNE(I,J)-UNE(I+IVW(J),J-1) UDIF(I,J)=(UNE(I,J)-UNE(I+IVW(J),J-1) 1 +USE(I,J)-USE(I+IVW(J),J+1))*HDACV(I,J) 1 +USE(I,J)-USE(I+IVW(J),J+1))*HDACV(I,J) VDIF(I,J)=(VNE(I,J)-VNE(I+IVW(J),J-1) VDIF(I,J)=(VNE(I,J)-VNE(I+IVW(J),J-1) 1 +VSE(I,J)-VSE(I+IVW(J),J+1))*HDACV(I,J) 1 +VSE(I,J)-VSE(I+IVW(J),J+1))*HDACV(I,J) 430 CONTINUE 430 CONTINUE C--------------2-ND ORDER DIFFUSION------------------------------------- C--------------2-ND ORDER DIFFUSION------------------------------------- IF(SECOND)THEN IF(SECOND)THEN Cfm < C At points having a neighboring wind at a slope, reduce the < C diffusion coefficient to half of its value at fully open v points < C < C DO 440 J=3,JM-2 < C DO 440 I=2,IM-1 < DO 440 J=MYJS2,MYJE2 DO 440 J=MYJS2,MYJE2 DO 440 I=MYIS1,MYIE1 DO 440 I=MYIS1,MYIE1 > CGSM U(I,J,L)=U(I,J,L)+UDIF(I,J) > CGSM V(I,J,L)=V(I,J,L)+VDIF(I,J) NNTMP= VTM(I+IVW(J),J+1,L)*VTM(I+IVE(J),J+1,L) NNTMP= VTM(I+IVW(J),J+1,L)*VTM(I+IVE(J),J+1,L) 1 *VTM(I+IVW(J),J-1,L)*VTM(I+IVE(J),J-1,L) 1 *VTM(I+IVW(J),J-1,L)*VTM(I+IVE(J),J-1,L) DCMD=NNTMP+0.5*MOD(NNTMP+1,2) | DCMD=NNTMP+0.5*MOD(NNTMP+1,2) U(I,J,L)=U(I,J,L)+UDIF(I,J)*VTM(I,J,L)*DCMD U(I,J,L)=U(I,J,L)+UDIF(I,J)*VTM(I,J,L)*DCMD V(I,J,L)=V(I,J,L)+VDIF(I,J)*VTM(I,J,L)*DCMD V(I,J,L)=V(I,J,L)+VDIF(I,J)*VTM(I,J,L)*DCMD > CKE(I,J)=0.5*(U(I,J,L)*U(I,J,L)-UTK*UTK > 1 +V(I,J,L)*V(I,J,L)-VTK*VTK) 440 CONTINUE 440 CONTINUE C | ELSE else < c GO TO 500 c GO TO 500 c ENDIF c ENDIF C--------------4-TH ORDER DIAGONAL CONTRIBUTIONS------------------------ C--------------4-TH ORDER DIAGONAL CONTRIBUTIONS------------------------ C DO 450 J=1,JM-1 < C DO 450 I=1,IM-1 < DO 450 J=MYJS,MYJE1 DO 450 J=MYJS,MYJE1 DO 450 I=MYIS,MYIE1 DO 450 I=MYIS,MYIE1 UNE(I,J)=(UDIF(I+IVE(J),J+1)-UDIF(I,J))*VKNE(I,J) UNE(I,J)=(UDIF(I+IVE(J),J+1)-UDIF(I,J))*VKNE(I,J) VNE(I,J)=(VDIF(I+IVE(J),J+1)-VDIF(I,J))*VKNE(I,J) VNE(I,J)=(VDIF(I+IVE(J),J+1)-VDIF(I,J))*VKNE(I,J) 450 CONTINUE 450 CONTINUE C C C DO 460 J=2,JM < C DO 460 I=1,IM-1 < DO 460 J=MYJS1,MYJE DO 460 J=MYJS1,MYJE DO 460 I=MYIS,MYIE1 DO 460 I=MYIS,MYIE1 USE(I,J)=(UDIF(I+IVE(J),J-1)-UDIF(I,J))*VKSE(I,J) USE(I,J)=(UDIF(I+IVE(J),J-1)-UDIF(I,J))*VKSE(I,J) VSE(I,J)=(VDIF(I+IVE(J),J-1)-VDIF(I,J))*VKSE(I,J) VSE(I,J)=(VDIF(I+IVE(J),J-1)-VDIF(I,J))*VKSE(I,J) 460 CONTINUE 460 CONTINUE C----------------------------------------------------------------------- C----------------------------------------------------------------------- C DO 470 J=3,JM-2 < C DO 470 I=2,IM-1 < DO 470 J=MYJS2,MYJE2 DO 470 J=MYJS2,MYJE2 DO 470 I=MYIS1,MYIE1 DO 470 I=MYIS1,MYIE1 UTK=U(I,J,L) UTK=U(I,J,L) VTK=V(I,J,L) VTK=V(I,J,L) U(I,J,L)=U(I,J,L)-(UNE(I,J)-UNE(I+IVW(J),J-1) U(I,J,L)=U(I,J,L)-(UNE(I,J)-UNE(I+IVW(J),J-1) 1 +USE(I,J)-USE(I+IVW(J),J+1))*HDACV(I,J) 1 +USE(I,J)-USE(I+IVW(J),J+1))*HDACV(I,J) V(I,J,L)=V(I,J,L)-(VNE(I,J)-VNE(I+IVW(J),J-1) V(I,J,L)=V(I,J,L)-(VNE(I,J)-VNE(I+IVW(J),J-1) 1 +VSE(I,J)-VSE(I+IVW(J),J+1))*HDACV(I,J) 1 +VSE(I,J)-VSE(I+IVW(J),J+1))*HDACV(I,J) CKE(I,J)=D50*(U(I,J,L)*U(I,J,L)-UTK*UTK | CKE(I,J)=0.5*(U(I,J,L)*U(I,J,L)-UTK*UTK 1 +V(I,J,L)*V(I,J,L)-VTK*VTK) 1 +V(I,J,L)*V(I,J,L)-VTK*VTK) 470 CONTINUE 470 CONTINUE ENDIF ENDIF C----------------------------------------------------------------------- C----------------------------------------------------------------------- IF(HEAT)THEN | IF(HEAT)THEN C DO 480 J=3,JM-2 < C DO 480 I=2,IM-1 < DO 480 J=MYJS2,MYJE2 DO 480 J=MYJS2,MYJE2 DO 480 I=MYIS1,MYIE1 DO 480 I=MYIS1,MYIE1 T(I,J,L)=-RFCP*(CKE(I+IHE(J),J)+CKE(I,J+1) T(I,J,L)=-RFCP*(CKE(I+IHE(J),J)+CKE(I,J+1) 1 +CKE(I+IHW(J),J)+CKE(I,J-1))*HBM2(I,J) 1 +CKE(I+IHW(J),J)+CKE(I,J-1))*HBM2(I,J) 2 +T(I,J,L) 2 +T(I,J,L) > write(57,*) mype,i,j,l,CKE(I+IHE(J),J),CKE(I,J+1), > 1 CKE(I+IHW(J),J),CKE(I,J-1),T(I,J,L) > 480 CONTINUE 480 CONTINUE ENDIF | ENDIF C----------------------------------------------------------------------- C----------------------------------------------------------------------- Cfm Fill the v points at slopes back with zeros, in case it matters ---- Cfm Fill the v points at slopes back with zeros, in case it matters ---- IF (L.GT.1) THEN IF (L.GT.1) THEN C DO J=8,JM-7 | DO 485 J=MYJS_P1,MYJE_P1 C DO I=4+MOD(J+1,2),IM-4 < DO 485 J=MYJS_P1,MYJE_P1 < DO 485 I=MYIS_P1,MYIE_P1 DO 485 I=MYIS_P1,MYIE_P1 IF (VTMS(I,J,L).EQ.1) THEN | IF (VTMS(I,J,L).EQ.1) THEN U(I,J,L)=0. | U(I,J,L)=0. V(I,J,L)=0. | V(I,J,L)=0. ENDIF | ENDIF 485 CONTINUE 485 CONTINUE ENDIF | ENDIF C----------------------------------------------------------------------- C----------------------------------------------------------------------- 500 CONTINUE 500 CONTINUE 600 CONTINUE 600 CONTINUE C----------------------------------------------------------------------- C----------------------------------------------------------------------- RETURN RETURN END END