                                                                                      > 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
