C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& 
                             SUBROUTINE HZADVS
C     ******************************************************************
C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .     
C SUBPROGRAM:    HZADV       HORIZONTAL ADVECTION
C   PRGRMMR: JANJIC          ORG: W/NP22     DATE: 93-10-28       
C     
C ABSTRACT:
C     HZADV CALCULATES THE CONTRIBUTION OF THE HORIZONTAL ADVECTION
C     TO THE TENDENCIES OF TEMPERATURE, WIND COMPONENTS, AND
C     TURBULENT KINETIC ENERGY AND THEN UPDATES THOSE VARIABLES.
C     THE JANJIC ADVECTION SCHEME FOR THE ARAKAWA E GRID IS USED
C     FOR ALL VARIABLES INSIDE THE FIFTH ROW.  AN UPSTREAM SCHEME
C     IS USED ON ALL VARIABLES IN THE THIRD, FOURTH, AND FIFTH
C     OUTERMOST ROWS.  A MODIFIED EULER-BACKWARD TIME SCHEME (HEUN)
C     IS USED.  UNDERGROUND WINDS MUST BE EQUAL TO ZERO SINCE THEY
C     ARE USED EXPLICITLY WITHOUT THE VELOCITY MASK IN THE FLUX
C     CALCULATIONS.
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 HZADV 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  
C     UNIQUE: NONE
C  
C     LIBRARY: NONE
C  
C   COMMON BLOCKS: CTLBLK
C                  LOOPS
C                  MASKS
C                  DYNAM
C                  VRBLS
C                  CONTIN
C                  PVRBLS
C                  INDX
C   
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE : IBM SP
C$$$  
C***********************************************************************
                             P A R A M E T E R
     & (TLC=2.*0.703972477)
C-----------------------------------------------------------------------
      INCLUDE "parmeta"
      INCLUDE "mpp.h"
#include "sp.h"
C-----------------------------------------------------------------------
                             P A R A M E T E R
     & (IM1=IM-1,JAM=6+2*(JM-10)
     &, IMJM=IM*JM-JM/2,LP1=LM+1
     &, JAMD=(JAM*2-10)*3)
C-----------------------------------------------------------------------
                             L O G I C A L
     & RUN,FIRST,RESTRT,ITER2,SIGMA
C----------------------------------------------------------------------
      INCLUDE "CTLBLK.comm"
C-----------------------------------------------------------------------
      INCLUDE "LOOPS.comm"
C-----------------------------------------------------------------------
      INCLUDE "MASKS.comm"
C-----------------------------------------------------------------------
      INCLUDE "DYNAM.comm"
C-----------------------------------------------------------------------
      INCLUDE "VRBLS.comm"
C-----------------------------------------------------------------------
      INCLUDE "CONTIN.comm"
C-----------------------------------------------------------------------
      INCLUDE "PVRBLS.comm"
      INCLUDE "CLDWTR.comm"
C-----------------------------------------------------------------------
      INCLUDE "INDX.comm"
C-----------------------------------------------------------------------
      INCLUDE "SLOPES.comm"
C-----------------------------------------------------------------------
                             D I M E N S I O N
     & HM    (IDIM1:IDIM2,JDIM1:JDIM2),VM    (IDIM1:IDIM2,JDIM1:JDIM2)
     &,RDPD  (IDIM1:IDIM2,JDIM1:JDIM2)
     &,ADPDX (IDIM1:IDIM2,JDIM1:JDIM2),ADPDY (IDIM1:IDIM2,JDIM1:JDIM2)
     &,RDPDX (IDIM1:IDIM2,JDIM1:JDIM2),RDPDY (IDIM1:IDIM2,JDIM1:JDIM2)
     &,ADT   (IDIM1:IDIM2,JDIM1:JDIM2)
     &,ADU   (IDIM1:IDIM2,JDIM1:JDIM2),ADV   (IDIM1:IDIM2,JDIM1:JDIM2)
     &,ADQ2M (IDIM1:IDIM2,JDIM1:JDIM2),ADQ2L (IDIM1:IDIM2,JDIM1:JDIM2)
     &,Q2MNS (IDIM1:IDIM2,JDIM1:JDIM2),Q2LNS (IDIM1:IDIM2,JDIM1:JDIM2)
     &,UDY   (IDIM1:IDIM2,JDIM1:JDIM2),VDX   (IDIM1:IDIM2,JDIM1:JDIM2)
C
                             D I M E N S I O N
     & DPDE  (IDIM1:IDIM2,JDIM1:JDIM2)
     &,TEMPA (IDIM1:IDIM2,JDIM1:JDIM2),TEMPB (IDIM1:IDIM2,JDIM1:JDIM2)
     &,TST   (IDIM1:IDIM2,JDIM1:JDIM2)
     &,UST   (IDIM1:IDIM2,JDIM1:JDIM2),VST   (IDIM1:IDIM2,JDIM1:JDIM2)
     &,Q2M   (IDIM1:IDIM2,JDIM1:JDIM2),Q2L   (IDIM1:IDIM2,JDIM1:JDIM2)
     &,TEW   (IDIM1:IDIM2,JDIM1:JDIM2),TNS   (IDIM1:IDIM2,JDIM1:JDIM2)
     &,Q2MEW (IDIM1:IDIM2,JDIM1:JDIM2),Q2LEW (IDIM1:IDIM2,JDIM1:JDIM2)
C
                             D I M E N S I O N
     & TNE   (IDIM1:IDIM2,JDIM1:JDIM2),TSE   (IDIM1:IDIM2,JDIM1:JDIM2)
     &,Q2MNE (IDIM1:IDIM2,JDIM1:JDIM2),Q2MSE (IDIM1:IDIM2,JDIM1:JDIM2)
     &,Q2LNE (IDIM1:IDIM2,JDIM1:JDIM2),Q2LSE (IDIM1:IDIM2,JDIM1:JDIM2)
     &,UEW   (IDIM1:IDIM2,JDIM1:JDIM2),UNS   (IDIM1:IDIM2,JDIM1:JDIM2)
     &,VEW   (IDIM1:IDIM2,JDIM1:JDIM2),VNS   (IDIM1:IDIM2,JDIM1:JDIM2)
     &,UNE   (IDIM1:IDIM2,JDIM1:JDIM2),USE   (IDIM1:IDIM2,JDIM1:JDIM2)
     &,VNE   (IDIM1:IDIM2,JDIM1:JDIM2),VSE   (IDIM1:IDIM2,JDIM1:JDIM2)
     &,FEW   (IDIM1:IDIM2,JDIM1:JDIM2),FNS   (IDIM1:IDIM2,JDIM1:JDIM2)
     &,FNE   (IDIM1:IDIM2,JDIM1:JDIM2),FSE   (IDIM1:IDIM2,JDIM1:JDIM2)
C
                             D I M E N S I O N
     & RDPDXS(IDIM1:IDIM2,JDIM1:JDIM2),RDPDYS(IDIM1:IDIM2,JDIM1:JDIM2)
     &,UEWS  (IDIM1:IDIM2,JDIM1:JDIM2),UNSS  (IDIM1:IDIM2,JDIM1:JDIM2)
     &,VEWS  (IDIM1:IDIM2,JDIM1:JDIM2),VNSS  (IDIM1:IDIM2,JDIM1:JDIM2)
     &,UNES  (IDIM1:IDIM2,JDIM1:JDIM2),USES  (IDIM1:IDIM2,JDIM1:JDIM2)
     &,VNES  (IDIM1:IDIM2,JDIM1:JDIM2),VSES  (IDIM1:IDIM2,JDIM1:JDIM2)
C
                             D I M E N S I O N
     & ADQ2HL(IDIM1:IDIM2,JDIM1:JDIM2,LM)
     &,Q2ML(IDIM1:IDIM2,JDIM1:JDIM2,LM+1)
C
      DIMENSION ARRAY0(JAMD)  
      DIMENSION ARRAY1(JAMD) 
      DIMENSION ARRAY2(JAMD)   
      DIMENSION ARRAY3(JAMD)  
      DIMENSION KHHAS(JAMD)  
      DIMENSION IHLAS(JAMD) 
      DIMENSION JHLAS(JAMD)
      DIMENSION KVHAS(JAMD)    
      DIMENSION IVLAS(JAMD)   
      DIMENSION JVLAS(JAMD)  
      DIMENSION ISPA(JAMD)  
      DIMENSION ISQA(JAMD) 
c
      LOGICAL UPSTRM,LJRA(JAM)

Candre      include "checkin"
C--------------------------------------------------------------------
C***********************************************************************
C-----------------------------------------------------------------------
      DO L=2,LM
      DO J=MYJS_P5,MYJE_P5
      DO I=MYIS_P4,MYIE_P4
        IF (VTMS(I,J,L).EQ.1) THEN
         U(I,J,L)=U(I,J,L-1)
         V(I,J,L)=V(I,J,L-1)
        END IF
      END DO
      END DO
      END DO
C-----------------------------------------------------------------------
C
C***  FIGURE OUT IF WE ARE IN THE UPSTREAM REGION
C
      UPSTRM=.FALSE.
      IF(MYPE.LE.INPES-1)UPSTRM=.TRUE.
      IF(MYPE.GE.NPES-INPES)UPSTRM=.TRUE.
      IF(MOD(MYPE,INPES).EQ.0)UPSTRM=.TRUE.
      IF(MOD(MYPE+1,INPES).EQ.0)UPSTRM=.TRUE.
C
      JAKONE=0 
C
      DO 25 JA=1,JAM
      IHL=IHLA(JA)
      IHH=IHHA(JA)
      J=JRA(JA)
      LJRA(JA)=.FALSE.
C
      IF(J.GE.MY_JS_GLB-JBPAD2.AND.J.LE.MY_JE_GLB+JTPAD2)THEN
        LJRA(JA)=.TRUE.
        DO I=IHL,IHH
          IF(I.GE.MY_IS_GLB-ILPAD2.AND.I.LE.MY_IE_GLB+IRPAD2)THEN
            JAKONE=JAKONE+1
            KHHAS(JAKONE)=JA
            IHLAS(JAKONE)=I
            JHLAS(JAKONE)=J
          ENDIF
        ENDDO
      ENDIF
C
   25 CONTINUE
C
      JAKTWO=0
      DO 50 JA=1,JAM
        IVL=IVLA(JA)
        IVH=IVHA(JA)
        J=JRA(JA)
C
      DO 50 I=IVL,IVH
      IF(I.GE.MY_IS_GLB-ILPAD2.AND.I.LE.MY_IE_GLB+IRPAD2.AND.
     1   J.GE.MY_JS_GLB-JBPAD2.AND.J.LE.MY_JE_GLB+JTPAD2)THEN
        JAKTWO=JAKTWO+1
        KVHAS(JAKTWO)=JA
        IVLAS(JAKTWO)=I
        JVLAS(JAKTWO)=J
      ENDIF
   50 CONTINUE
C
C
      DO 70 J=MYJS_P5,MYJE_P5
      DO 70 I=MYIS_P4,MYIE_P4
        Q2ML(I,J,1)=0.
   70 CONTINUE
C
!$omp parallel do 
      DO 80 L=2,LM+1 
      DO 80 J=MYJS_P5,MYJE_P5
      DO 80 I=MYIS_P4,MYIE_P4
        Q2ML(I,J,L)=Q2(I,J,L-1)
   80 CONTINUE
C***********************************************************************
!$omp parallel do
!$omp& private(adpdx,adpdy,adq,adq2l,adq2m,adt,adu,adv,
!$omp&         array0,array1,array2,array3,dpde,f0,f1,f2,f3,
!$omp&         few,fne,fns,fse,hm,i,ifp,ifq,ihh,ihl,ipq,isp,
!$omp&         ispa,isq,isqa,iter2,ix,iy,j,ja,jak,l,pp,q2l,
!$omp&         q2lew,q2lne,q2lns,q2lse,q2m,q2mew,q2mne,q2mns,
!$omp&         q2mse,qew,qne,qns,qp,qse,qst,rdpd,rdpdx,rdpdy,
!$omp&         tempa,tempb,tew,tne,tns,tse,tst,tta,ttb,udy,uew,une,
!$omp&         uns,use,ust,vdx,vew,vm,vne,vns,vse,vst)
C***********************************************************************
                             DO 500 L=LM,1,-1
C                             DO 500 L=1,LM
C***********************************************************************
      CALL ZERO2(ADT)
      CALL ZERO2(ADU)
      CALL ZERO2(ADV)
      CALL ZERO2(ADQ2M)
      CALL ZERO2(ADQ2L)
      CALL ZERO2(DPDE)
      CALL ZERO2(FEW)
      CALL ZERO2(FNE)
      CALL ZERO2(FNS)
      CALL ZERO2(FSE)
      CALL ZERO2(Q2L)
      CALL ZERO2(Q2LEW)
      CALL ZERO2(Q2LNE)
      CALL ZERO2(Q2LSE)
      CALL ZERO2(Q2M)
      CALL ZERO2(Q2MEW)
      CALL ZERO2(Q2MNE)
      CALL ZERO2(Q2MSE)
      CALL ZERO2(RDPD)
      CALL ZERO2(TEMPA)
      CALL ZERO2(TEMPB)
      CALL ZERO2(TEW)
      CALL ZERO2(TNE)
      CALL ZERO2(TNS)
      CALL ZERO2(TSE)
      CALL ZERO2(TST)
      CALL ZERO2(UDY)
      CALL ZERO2(UEW)
      CALL ZERO2(UNE)
      CALL ZERO2(UNS)
      CALL ZERO2(USE)
      CALL ZERO2(UST)
      CALL ZERO2(VEW)
      CALL ZERO2(VNE)
      CALL ZERO2(VNS)
      CALL ZERO2(VSE)
      CALL ZERO2(VST)
      CALL ZERO2(VM)
C***********************************************************************
                             ITER2=.FALSE.
C-----------------------------------------------------------------------
      DO J=MYJS_P4,MYJE_P4
      DO I=MYIS_P4,MYIE_P4
c       Q2M(I,J)=0.
        Q2M(I,J)=Q2ML(I,J,L)
      ENDDO
      ENDDO
C
      DO 110 J=MYJS_P5,MYJE_P5
      DO 110 I=MYIS_P4,MYIE_P4
      HM(I,J)=HTM(I,J,L)*HBM2(I,J)
      DPDE(I,J)=PDSL(I,J)*DETA(L)
      RDPD(I,J)=1./DPDE(I,J)
      UST(I,J)=U(I,J,L)
      VST(I,J)=V(I,J,L)
      TST(I,J)=T(I,J,L)
      Q2L(I,J)=Q2ML(I,J,L+1)
  110 CONTINUE
C-----------------------------------------------------------------------
      DO 120 J=MYJS1_P4,MYJE1_P4
      DO 120 I=MYIS_P4,MYIE_P4
      VM(I,J)=VTM(I,J,L)*VBM2(I,J)
      ADPDX(I,J)=DPDE(I+IVW(J),J)+DPDE(I+IVE(J),J)
      ADPDY(I,J)=DPDE(I,J-1)+DPDE(I,J+1)
      RDPDX(I,J)=1./ADPDX(I,J)
      RDPDY(I,J)=1./ADPDY(I,J)
      IF (L.LT.LM) THEN

CANDRE      RDPDXS(I,J)=H1/(ADPDX(I,J)*(DETA(L)+0.5*DETA(L+1))/DETA(L))
CANDRE      RDPDYS(I,J)=H1/(ADPDY(I,J)*(DETA(L)+0.5*DETA(L+1))/DETA(L))
CANDRE - Ivan Ristic suggest      
      RDPDXS(I,J)=1.0/(ADPDX(I,J)*(DETA(L)+0.5*DETA(L+1))/DETA(L))
      RDPDYS(I,J)=1.0/(ADPDY(I,J)*(DETA(L)+0.5*DETA(L+1))/DETA(L))

      END IF
  120 CONTINUE
C--------------MASS FLUXES AND MASS POINTS ADVECTION COMPONENTS---------
C***
C***  THE NS AND EW FLUXES IN THE FOLLOWING LOOP ARE ON V POINTS
C***
  125 DO 130 J=MYJS1_P4,MYJE1_P4
      DO 130 I=MYIS_P4,MYIE_P4
      UDY(I,J)=UST(I,J)*DY * VM(I,J)
      FEW(I,J)=UDY(I,J)*ADPDX(I,J)
      TEW(I,J)=FEW(I,J)*(TST(I+IVE(J),J)-TST(I+IVW(J),J))
      Q2MEW(I,J)=FEW(I,J)*(Q2M(I+IVE(J),J)-Q2M(I+IVW(J),J))
      Q2LEW(I,J)=FEW(I,J)*(Q2L(I+IVE(J),J)-Q2L(I+IVW(J),J))
      VDX(I,J)=VST(I,J)*DX(I,J) * VM(I,J)
      FNS(I,J)=VDX(I,J)*ADPDY(I,J)
      TNS(I,J)=FNS(I,J)*(TST(I,J+1)-TST(I,J-1))
      Q2MNS(I,J)=FNS(I,J)*(Q2M(I,J+1)-Q2M(I,J-1))
      Q2LNS(I,J)=FNS(I,J)*(Q2L(I,J+1)-Q2L(I,J-1))
  130 CONTINUE
C--------------DIAGONAL FLUXES AND DIAGONALLY AVERAGED WIND-------------
C***
C***  THE NE AND SE FLUXES ARE ON H POINTS
C***  (ACTUALLY JUST TO THE NE AND SE OF EACH H POINT)
C***
      DO 145 J=MYJS2_P4,MYJE2_P4
      DO 145 I=MYIS_P4,MYIE_P4
      TEMPA(I,J)=UDY(I,J)+VDX(I,J)
      TEMPB(I,J)=UDY(I,J)-VDX(I,J)
  145 CONTINUE
C
      DO 150 J=MYJS2_P4,MYJE2_P4
      DO 150 I=MYIS_P4,MYIE_P4
      FNE(I,J)=(TEMPA(I+IHE(J),J)+TEMPA(I,J+1))
     1         *(DPDE(I,J)+DPDE(I+IHE(J),J+1))
      TNE(I,J)=FNE(I,J)*(TST(I+IHE(J),J+1)-TST(I,J))
      Q2MNE(I,J)=FNE(I,J)*(Q2M(I+IHE(J),J+1)-Q2M(I,J))
      Q2LNE(I,J)=FNE(I,J)*(Q2L(I+IHE(J),J+1)-Q2L(I,J))
      FSE(I,J)=(TEMPB(I+IHE(J),J)+TEMPB(I,J-1))
     1         *(DPDE(I,J)+DPDE(I+IHE(J),J-1))
      TSE(I,J)=FSE(I,J)*(TST(I+IHE(J),J-1)-TST(I,J))
      Q2MSE(I,J)=FSE(I,J)*(Q2M(I+IHE(J),J-1)-Q2M(I,J))
      Q2LSE(I,J)=FSE(I,J)*(Q2L(I+IHE(J),J-1)-Q2L(I,J))
  150 CONTINUE
C--------------THERMODYNAMIC EQUATION & MOISTURE------------------------
C***
C***  THE AD ARRAYS IN THE 170 LOOP ARE ON H POINTS
C***
      DO 170 J=MYJS5_P2,MYJE5_P2
      DO 170 I=MYIS_P2,MYIE_P2
      ADT(I,J)=(TEW(I+IHW(J),J)+TEW(I+IHE(J),J)+TNS(I,J-1)+TNS(I,J+1)
     1         +TNE(I+IHW(J),J-1)+TNE(I,J)+TSE(I,J)+TSE(I+IHW(J),J+1))
     2         *RDPD(I,J)*FAD(I,J)
      ADQ2M(I,J)=(Q2MEW(I+IHW(J),J)+Q2MEW(I+IHE(J),J)
     1           +Q2MNS(I,J-1)+Q2MNS(I,J+1)
     2           +Q2MNE(I+IHW(J),J-1)+Q2MNE(I,J)
     3           +Q2MSE(I,J)+Q2MSE(I+IHW(J),J+1))
     4           *RDPD(I,J)*FAD(I,J)
      ADQ2L(I,J)=(Q2LEW(I+IHW(J),J)+Q2LEW(I+IHE(J),J)
     1           +Q2LNS(I,J-1)+Q2LNS(I,J+1)
     2           +Q2LNE(I+IHW(J),J-1)+Q2LNE(I,J)
     3           +Q2LSE(I,J)+Q2LSE(I+IHW(J),J+1))
     4           *RDPD(I,J)*FAD(I,J)
  170 CONTINUE
C-----------------------------------------------------------------------
C--------------UPSTREAM ADVECTION OF T, Q AND Q2------------------------
C-----------------------------------------------------------------------
      IF(UPSTRM)THEN
        DO 171 JAK=1,JAKONE
        JA=KHHAS(JAK)
        I =IHLAS(JAK)
        J =JHLAS(JAK)
        IX=I-MY_IS_GLB+1
        JX=J-MY_JS_GLB+1
        TTA=EMT(JA)*(UST(IX,JX-1)+UST(IX+IHW(JX),JX)
     1              +UST(IX+IHE(JX),JX)+UST(IX,JX+1))
        TTB=ENT    *(VST(IX,JX-1)+VST(IX+IHW(JX),JX)
     1              +VST(IX+IHE(JX),JX)+VST(IX,JX+1))
        PP=-TTA-TTB
        QP= TTA-TTB
C
        IF(PP.LT.0.)THEN
          ISPA(JAK)=-1
        ELSE
          ISPA(JAK)= 1
        ENDIF
C
        IF(QP.LT.0.)THEN
          ISQA(JAK)=-1
        ELSE
          ISQA(JAK)= 1
        ENDIF
C
        PP=ABS(PP)
        QP=ABS(QP)
        ARRAY3(JAK)=PP*QP
        ARRAY0(JAK)=ARRAY3(JAK)-PP-QP
        ARRAY1(JAK)=PP-ARRAY3(JAK)
        ARRAY2(JAK)=QP-ARRAY3(JAK)
  171   CONTINUE
C
        JAK=0
        DO 173 JA=1,JAM
        IHL=IHLA(JA)
        IHH=IHHA(JA)
        J=JRA(JA)
        IF(.NOT.LJRA(JA))GO TO 173
C
        DO I=IHL,IHH
        IF(I.GE.MY_IS_GLB-ILPAD2.AND.I.LE.MY_IE_GLB+IRPAD2)THEN
          JAK=JAK+1
          ISP=ISPA(JAK)
          ISQ=ISQA(JAK)
          IFP=(ISP-1)/2
          IFQ=(-ISQ-1)/2
          IPQ=(ISP-ISQ)/2
C
          IX=I-MY_IS_GLB+1
          JX=J-MY_JS_GLB+1
C
          IF(HTM(IX+IHE(JX)+IFP,JX+ISP,L)*HTM(IX+IHE(JX)+IFQ,JX+ISQ,L)
     1      *HTM(IX+IPQ,JX+ISP+ISQ,L).GT.0.1)GO TO 172
C
          IF(HTM(IX+IHE(JX)+IFP,JX+ISP,L)+HTM(IX+IHE(JX)+IFQ,JX+ISQ,L)
     1      +HTM(IX+IPQ,JX+ISP+ISQ,L).LT.0.1)THEN
C
            TST(IX+IHE(JX)+IFP,JX+ISP)=TST(IX,JX)
            TST(IX+IHE(JX)+IFQ,JX+ISQ)=TST(IX,JX)
            TST(IX+IPQ,JX+ISP+ISQ)    =TST(IX,JX)
C
          ELSEIF
     1     (HTM(IX+IHE(JX)+IFP,JX+ISP,L)+HTM(IX+IPQ,JX+ISP+ISQ,L)
     2      .LT.0.99)THEN
C
            TST(IX+IHE(JX)+IFP,JX+ISP)=TST(IX,JX)
            TST(IX+IPQ,JX+ISP+ISQ)    =TST(IX+IHE(JX)+IFQ,JX+ISQ)
C
          ELSEIF
     1     (HTM(IX+IHE(JX)+IFQ,JX+ISQ,L)+HTM(IX+IPQ,JX+ISP+ISQ,L)
     2      .LT.0.99)THEN
C
            TST(IX+IHE(JX)+IFQ,JX+ISQ)=TST(IX,JX)
            TST(IX+IPQ,JX+ISP+ISQ)    =TST(IX+IHE(JX)+IFP,JX+ISP)
C
          ELSEIF
     1     (HTM(IX+IHE(JX)+IFP,JX+ISP,L)+HTM(IX+IHE(JX)+IFQ,JX+ISQ,L)
     2      .LT.0.99)THEN
            TST(IX+IHE(JX)+IFP,JX+ISP)=
     1                    0.5*(TST(IX,JX)+TST(IX+IPQ,JX+ISP+ISQ))
            TST(IX+IHE(JX)+IFQ,JX+ISQ)=TST(IX+IHE(JX)+IFP,JX+ISP)
C
          ELSEIF(HTM(IX+IHE(JX)+IFP,JX+ISP,L).LT.0.99)THEN
            TST(IX+IHE(JX)+IFP,JX+ISP)=
     1        TST(IX,JX)+TST(IX+IPQ,JX+ISP+ISQ)
     2                  -TST(IX+IHE(JX)+IFQ,JX+ISQ)
C
          ELSEIF(HTM(IX+IHE(JX)+IFQ,JX+ISQ,L).LT.0.99)THEN
            TST(IX+IHE(JX)+IFQ,JX+ISQ)=
     1        TST(IX,JX)+TST(IX+IPQ,JX+ISP+ISQ)
     2                  -TST(IX+IHE(JX)+IFP,JX+ISP)
C
          ELSE
            TST(IX+IPQ,JX+ISP+ISQ)=
     1        TST(IX+IHE(JX)+IFP,JX+ISP)
     2       +TST(IX+IHE(JX)+IFQ,JX+ISQ)-TST(IX,JX)
C
          ENDIF
C
  172     CONTINUE
C
          F0=ARRAY0(JAK)
          F1=ARRAY1(JAK)
          F2=ARRAY2(JAK)
          F3=ARRAY3(JAK)
          ADT(IX,JX)=F0*TST(IX,JX)+F1*TST(IX+IHE(JX)+IFP,JX+ISP)
     1                            +F2*TST(IX+IHE(JX)+IFQ,JX+ISQ)
     2                            +F3*TST(IX+IPQ,JX+ISP+ISQ)
        ENDIF
C
        ENDDO
  173   CONTINUE
C
        DO 175 JAK=1,JAKONE
        I=IHLAS(JAK)
        J=JHLAS(JAK)
C
        IX=I-MY_IS_GLB+1
        JX=J-MY_JS_GLB+1
C
        ISP=ISPA(JAK)
        ISQ=ISQA(JAK)
        IFP=(ISP-1)/2
        IFQ=(-ISQ-1)/2
        IPQ=(ISP-ISQ)/2
        F0=ARRAY0(JAK)
        F1=ARRAY1(JAK)
        F2=ARRAY2(JAK)
        F3=ARRAY3(JAK)
        ADQ2M(IX,JX)=F0*Q2M(IX,JX)+F1*Q2M(IX+IHE(JX)+IFP,JX+ISP)
     1                            +F2*Q2M(IX+IHE(JX)+IFQ,JX+ISQ)
     2                            +F3*Q2M(IX+IPQ,JX+ISP+ISQ)
        ADQ2L(IX,JX)=F0*Q2L(IX,JX)+F1*Q2L(IX+IHE(JX)+IFP,JX+ISP)
     1                            +F2*Q2L(IX+IHE(JX)+IFQ,JX+ISQ)
     2                            +F3*Q2L(IX+IPQ,JX+ISP+ISQ)
 175    CONTINUE
c
      ENDIF
C***
C***  END OF THIS UPSTREAM REGION
C***
C--------------CALCULATION OF MOMENTUM ADVECTION COMPONENTS-------------







      DO 131 J=MYJS1_P4,MYJE1_P4
      DO 131 I=MYIS_P4,MYIE_P4
      UDY(I,J)=UST(I,J)*DY
      FEW(I,J)=UDY(I,J)*ADPDX(I,J)
      VDX(I,J)=VST(I,J)*DX(I,J)
      FNS(I,J)=VDX(I,J)*ADPDY(I,J)
  131 CONTINUE
C--------------DIAGONAL FLUXES AND DIAGONALLY AVERAGED WIND-------------
C***
C***  THE NE AND SE FLUXES ARE ON H POINTS
C***  (ACTUALLY JUST TO THE NE AND SE OF EACH H POINT)
C***
      DO 146 J=MYJS2_P4,MYJE2_P4
      DO 146 I=MYIS_P4,MYIE_P4
      TEMPA(I,J)=UDY(I,J)+VDX(I,J)
      TEMPB(I,J)=UDY(I,J)-VDX(I,J)
  146 CONTINUE
C
      DO 151 J=MYJS2_P4,MYJE2_P4
      DO 151 I=MYIS_P4,MYIE_P4
      FNE(I,J)=(TEMPA(I+IHE(J),J)+TEMPA(I,J+1))
     1         *(DPDE(I,J)+DPDE(I+IHE(J),J+1))
      FSE(I,J)=(TEMPB(I+IHE(J),J)+TEMPB(I,J-1))
     1         *(DPDE(I,J)+DPDE(I+IHE(J),J-1))
  151 CONTINUE







C***
C***  THE FOLLOWING EW AND NS ARRAYS ARE ON H POINTS
C***
      DO 180 J=MYJS4_P4,MYJE4_P4
      DO 180 I=MYIS_P4,MYIE_P4
      UEW(I,J)=(FEW(I+IHW(J),J)+FEW(I+IHE(J),J))
     1         *(UST(I+IHE(J),J)-UST(I+IHW(J),J))
      IF((VTMS(I+IHE(J),J,L)+VTMS(I+IHW(J),J,L)).EQ.1) THEN
          UEW(I,J)=UEW(I,J)*0.5
      END IF

      UNS(I,J)=(FNS(I+IHW(J),J)+FNS(I+IHE(J),J))
     1         *(UST(I,J+1)-UST(I,J-1))
      IF((VTMS(I,J+1,L)+VTMS(I,J-1,L)).EQ.1) THEN
          UNS(I,J)=UNS(I,J)*0.5
      END IF

      VEW(I,J)=(FEW(I,J-1)+FEW(I,J+1))
     1         *(VST(I+IHE(J),J)-VST(I+IHW(J),J))
      IF((VTMS(I+IHE(J),J,L)+VTMS(I+IHW(J),J,L)).EQ.1) THEN
          VEW(I,J)=VEW(I,J)*0.5
      END IF

      VNS(I,J)=(FNS(I,J-1)+FNS(I,J+1))*(VST(I,J+1)-VST(I,J-1))
      IF((VTMS(I,J+1,L)+VTMS(I,J-1,L)).EQ.1) THEN
          VNS(I,J)=VNS(I,J)*0.5
      END IF

C***
C***  THE FOLLOWING NE AND SE ARRAYS ARE TIED TO V POINTS
C***
      UNE(I,J)=(FNE(I+IVW(J),J)+FNE(I+IVE(J),J))
     1         *(UST(I+IVE(J),J+1)-UST(I,J))
      IF((VTMS(I+IVE(J),J+1,L)+VTMS(I,J,L)).EQ.1) THEN
          UNE(I,J)=UNE(I,J)*0.5
      END IF

      USE(I,J)=(FSE(I+IVW(J),J)+FSE(I+IVE(J),J))
     1         *(UST(I+IVE(J),J-1)-UST(I,J))
      IF((VTMS(I+IVE(J),J-1,L)+VTMS(I,J,L)).EQ.1) THEN
          USE(I,J)=USE(I,J)*0.5
      END IF

      VNE(I,J)=(FNE(I,J-1)+FNE(I,J+1))*(VST(I+IVE(J),J+1)-VST(I,J))
      IF((VTMS(I+IVE(J),J+1,L)+VTMS(I,J,L)).EQ.1) THEN
          VNE(I,J)=VNE(I,J)*0.5
      END IF

      VSE(I,J)=(FSE(I,J-1)+FSE(I,J+1))*(VST(I+IVE(J),J-1)-VST(I,J))
      IF((VTMS(I+IVE(J),J-1,L)+VTMS(I,J,L)).EQ.1) THEN
          VSE(I,J)=VSE(I,J)*0.5
      END IF

  180 CONTINUE
C--------------EQUATION OF MOTION---------------------------------------
C***
C***  ADU AND ADV ARE ON V POINTS
C***
      DO 200 J=MYJS5_P2,MYJE5_P2
      DO 200 I=MYIS_P2,MYIE_P2
      IF (.NOT.(L.LT.LM .AND. ITER2 .AND. (VTMS(I,J,L+1).EQ.1))) THEN
      ADU(I,J)=(UEW(I+IVW(J),J)+UEW(I+IVE(J),J)+UNS(I,J-1)+UNS(I,J+1)
     1       +UNE(I+IVW(J),J-1)+UNE(I,J)+USE(I,J)+USE(I+IVW(J),J+1))
     2       *RDPDX(I,J)*FAD(I+IVW(J),J)
      ADV(I,J)=(VEW(I+IVW(J),J)+VEW(I+IVE(J),J)+VNS(I,J-1)+VNS(I,J+1)
     1       +VNE(I+IVW(J),J-1)+VNE(I,J)+VSE(I,J)+VSE(I+IVW(J),J+1))
     2       *RDPDY(I,J)*FAD(I+IVW(J),J)
      ELSE
      ADU(I,J)=(UEW(I+IVW(J),J)+UEW(I+IVE(J),J)+UNS(I,J-1)+UNS(I,J+1)
     1       +UNE(I+IVW(J),J-1)+UNE(I,J)+USE(I,J)+USE(I+IVW(J),J+1)
     &       +UEWS(I+IVW(J),J)+UEWS(I+IVE(J),J)+UNSS(I,J-1)+UNSS(I,J+1)
     &       +UNES(I+IVW(J),J-1)+UNES(I,J)+USES(I,J)+USES(I+IVW(J),J+1))
     2       *RDPDXS(I,J)*FAD(I+IVW(J),J)
      ADV(I,J)=(VEW(I+IVW(J),J)+VEW(I+IVE(J),J)+VNS(I,J-1)+VNS(I,J+1)
     1       +VNE(I+IVW(J),J-1)+VNE(I,J)+VSE(I,J)+VSE(I+IVW(J),J+1)
     &       +VEWS(I+IVW(J),J)+VEWS(I+IVE(J),J)+VNSS(I,J-1)+VNSS(I,J+1)
     &       +VNES(I+IVW(J),J-1)+VNES(I,J)+VSES(I,J)+VSES(I+IVW(J),J+1))
     2       *RDPDYS(I,J)*FAD(I+IVW(J),J)
      END IF
  200 CONTINUE
      IF (ITER2) THEN
          DO 201 J=MYJS,MYJE
          DO 201 I=MYIS,MYIE
      UEWS(I,J)=0.0
      UNSS(I,J)=0.0
      VEWS(I,J)=0.0
      VNSS(I,J)=0.0
      UNES(I,J)=0.0
      USES(I,J)=0.0
      VNES(I,J)=0.0
      VSES(I,J)=0.0
  201 CONTINUE
      DO 202 J=MYJS4_P4,MYJE4_P4
      DO 202 I=MYIS_P4,MYIE_P4
      IF((VTMS(I+IHE(J),J,L)+VTMS(I+IHW(J),J,L)).EQ.1) THEN
          UEWS(I,J)=UEW(I,J)
      END IF
      IF((VTMS(I,J+1,L)+VTMS(I,J-1,L)).EQ.1) THEN
          UNSS(I,J)=UNS(I,J)
      END IF
      IF((VTMS(I+IHE(J),J,L)+VTMS(I+IHW(J),J,L)).EQ.1) THEN
          VEWS(I,J)=VEW(I,J)
      END IF
      IF((VTMS(I,J+1,L)+VTMS(I,J-1,L)).EQ.1) THEN
          VNSS(I,J)=VNS(I,J)
      END IF
      IF((VTMS(I+IVE(J),J+1,L)+VTMS(I,J,L)).EQ.1) THEN
          UNES(I,J)=UNE(I,J)
      END IF
      IF((VTMS(I+IVE(J),J-1,L)+VTMS(I,J,L)).EQ.1) THEN
          USES(I,J)=USE(I,J)
      END IF
      IF((VTMS(I+IVE(J),J+1,L)+VTMS(I,J,L)).EQ.1) THEN
          VNES(I,J)=VNE(I,J)
      END IF
      IF((VTMS(I+IVE(J),J-1,L)+VTMS(I,J,L)).EQ.1) THEN
          VSES(I,J)=VSE(I,J)
      END IF
  202 CONTINUE
      END IF
C
C--------------UPSTREAM ADVECTION OF VELOCITY COMPONENTS----------------
C
      IF(UPSTRM)THEN
        DO 205 JAK=1,JAKTWO
        JA=KVHAS(JAK)
        I=IVLAS(JAK)
        J=JVLAS(JAK)
C
        IX=I-MY_IS_GLB+1
        JX=J-MY_JS_GLB+1
C
        TTA=EM(JA)*UST(IX,JX)
        TTB=EN    *VST(IX,JX)
        PP=-TTA-TTB
        QP=TTA-TTB
C
        IF(PP.LT.0.)THEN
          ISP=-1
        ELSE
          ISP= 1
        ENDIF
C
        IF(QP.LT.0.)THEN
          ISQ=-1
        ELSE
          ISQ= 1
        ENDIF
C
        IFP=(ISP-1)/2
        IFQ=(-ISQ-1)/2
        IPQ=(ISP-ISQ)/2
        PP=ABS(PP)
        QP=ABS(QP)
        F3=PP*QP
        F0=F3-PP-QP
        F1=PP-F3
        F2=QP-F3
        ADU(IX,JX)=F0*UST(IX,JX)+F1*UST(IX+IVE(JX)+IFP,JX+ISP)
     1                          +F2*UST(IX+IVE(JX)+IFQ,JX+ISQ)
     2                          +F3*UST(IX+IPQ,JX+ISP+ISQ)
        ADV(IX,JX)=F0*VST(IX,JX)+F1*VST(IX+IVE(JX)+IFP,JX+ISP)
     1                          +F2*VST(IX+IVE(JX)+IFQ,JX+ISQ)
     2                          +F3*VST(IX+IPQ,JX+ISP+ISQ)
  205   CONTINUE
      ENDIF
C***
C***  END OF THIS UPSTREAM REGION
C***
C-----------------------------------------------------------------------
      IF(ITER2)GO TO 235
C-----------------------------------------------------------------------
      DO 220 J=MYJS2_P2,MYJE2_P2
      DO 220 I=MYIS1_P2,MYIE1_P2
      TST(I,J)=ADT  (I,J)*(HM(I,J)*TLC)+TST(I,J)
      Q2M(I,J)=ADQ2M(I,J)*(HM(I,J)*TLC)+Q2M(I,J)
      Q2L(I,J)=ADQ2L(I,J)*(HM(I,J)*TLC)+Q2L(I,J)
  220 CONTINUE
C
      DO 230 J=MYJS2_P2,MYJE2_P2
      DO 230 I=MYIS1_P2,MYIE1_P2
      UST(I,J)=ADU(I,J)*VM(I,J)*TLC+UST(I,J)
      VST(I,J)=ADV(I,J)*VM(I,J)*TLC+VST(I,J)
  230 CONTINUE
C-----------------------------------------------------------------------
      ITER2=.TRUE.
      GO TO 125
C-----------------------------------------------------------------------
  235 DO 240 J=MYJS2,MYJE2
      DO 240 I=MYIS1,MYIE1
      T(I,J,L)=ADT(I,J)*(2.0*HM(I,J))+T(I,J,L)  
  240 CONTINUE
C
      DO 250 J=MYJS2,MYJE2
      DO 250 I=MYIS1,MYIE1
      U(I,J,L)= ( ADU(I,J)*(2.0*VM(I,J))+ U(I,J,L) )*VTM(I,J,L)
      V(I,J,L)= ( ADV(I,J)*(2.0*VM(I,J))+ V(I,J,L) )*VTM(I,J,L)
  250 CONTINUE
C-----------------------------------------------------------------------
      IF(L.EQ.LM)THEN
        DO 260 J=MYJS2,MYJE2
        DO 260 I=MYIS1,MYIE1
        ADQ2HL(I,J,LM-1)=ADQ2M(I,J)
  260   CONTINUE
      ELSE IF (L.GT.1.AND.L.LT.LM) THEN
        DO 270 J=MYJS2,MYJE2
        DO 270 I=MYIS1,MYIE1
        ADQ2HL(I,J,L-1)=ADQ2M(I,J)
        Q2(I,J,L)=ADQ2L(I,J)*HM(I,J)+Q2(I,J,L)
  270   CONTINUE
      ELSE
        DO 280 J=MYJS2,MYJE2
        DO 280 I=MYIS1,MYIE1
        Q2(I,J,L)=ADQ2L(I,J)*HM(I,J)+Q2(I,J,L)
  280   CONTINUE
      ENDIF
C***********************************************************************
  500                        CONTINUE
C***********************************************************************
!$omp parallel do private(hm)
      DO 600 L=2,LM-1
      DO J=MYJS2,MYJE2
      DO I=MYIS1,MYIE1
        HM(I,J)=HTM(I,J,L)*HBM2(I,J)
        Q2(I,J,L)=ADQ2HL(I,J,L)*HM(I,J)+Q2(I,J,L)
      ENDDO
      ENDDO
  600 CONTINUE
C-----------------------------------------------------------------------
                             RETURN
                             END
