    SUBROUTINE HZADV_LM1
!>--------------------------------------------------------------------------------------------------
!> SUBROUTINE HZADV_LM1
!>
!> SUBPROGRAM: HZADV_LM1 - HORIZONTAL ADVECTION
!> PROGRAMMER: JANJIC
!> ORG: W/NP22
!> DATE: 93-10-28
!>
!> ABSTRACT:
!> HZADV CALCULATES THE CONTRIBUTION OF THE HORIZONTAL ADVECTION TO THE TENDENCIES OF TEMPERATURE,
!> WIND COMPONENTS, AND TURBULENT KINETIC ENERGY AND THEN UPDATES THOSE VARIABLES.
!> THE JANJIC ADVECTION SCHEME FOR THE ARAKAWA E GRID IS USED FOR ALL VARIABLES INSIDE THE FIFTH ROW
!> AN UPSTREAM SCHEME IS USED ON ALL VARIABLES IN THE THIRD, FOURTH, AND FIFTH OUTERMOST ROWS. 
!> A MODIFIED EULER-BACKWARD TIME SCHEME (HEUN) IS USED. UNDERGROUND WINDS MUST BE EQUAL TO ZERO 
!> SINCE THEY ARE USED EXPLICITLY WITHOUT THE VELOCITY MASK IN THE FLUX CALCULATIONS.
!>
!> PROGRAM HISTORY LOG:
!> 87-06-??  JANJIC     - ORIGINATOR
!> 95-03-25  BLACK      - CONVERSION FROM 1-D TO 2-D IN HORIZONTAL
!> 96-03-28  BLACK      - ADDED EXTERNAL EDGE
!> 98-10-30  BLACK      - MODIFIED FOR DISTRIBUTED MEMORY
!> 18-01-15  LUCCI      - MODERNIZATION OF THE CODE, INCLUDING:
!>                        * F77 TO F90/F95
!>                        * INDENTATION & UNIFORMIZATION CODE
!>                        * REPLACEMENT OF COMMONS BLOCK FOR MODULES
!>                        * DOCUMENTATION WITH DOXYGEN
!>                        * OPENMP FUNCTIONALITY
!>
!> INPUT ARGUMENT LIST:
!> NONE
!>
!> OUTPUT ARGUMENT LIST:
!> NONE
!>
!> INPUT/OUTPUT ARGUMENT LIST:
!> NONE
!> 
!> USE MODULES: CLDWTR
!>              CONTIN 
!>              CTLBLK 
!>              DYNAM 
!>              F77KINDS  
!>              GLB_TABLE    
!>              INDX  
!>              LOOPS
!>              MAPPINGS 
!>              MASKS
!>              MPPCOM
!>              PARMETA
!>              PVRBLS
!>              TEMPCOM
!>              TOPO
!>              VRBLS
!>
!> DRIVER     : EBU
!>
!> CALLS      : ZERO2
!>--------------------------------------------------------------------------------------------------
    USE CLDWTR
    USE CONTIN
    USE CTLBLK
    USE DYNAM
    USE F77KINDS
    USE GLB_TABLE
    USE INDX
    USE LOOPS
    USE MAPPINGS
    USE MASKS
    USE MPPCOM
    USE PARMETA
    USE PVRBLS
    USE TEMPCOM
    USE TOPO
    USE VRBLS
!
    IMPLICIT NONE
!
    INTEGER(KIND=I4KIND), PARAMETER :: TLC  = 2. * 0.703972477
!
#include "sp.h"
!
    INTEGER(KIND=I4KIND), PARAMETER :: IM1  = IM - 1
    INTEGER(KIND=I4KIND), PARAMETER :: IMJM = IM * JM - JM / 2
    INTEGER(KIND=I4KIND), PARAMETER :: JAMD = (JAM * 2 - 10) * 3
!
    LOGICAL(KIND=L4KIND)                                                                        ::&
    & ITER2
! 
    REAL   (KIND=R4KIND), DIMENSION(IDIM1:IDIM2, JDIM1:JDIM2)                                   ::&
    & HM      , VM      ,                                                                         &
    & RDPD    ,                                                                                   &
    & ADPDX   , ADPDY   ,                                                                         &
    & RDPDX   , RDPDY   ,                                                                         &
    & ADT     ,                                                                                   &
    & ADU     , ADV     ,                                                                         &
    & ADQ2M   , ADQ2L   ,                                                                         &
    & Q2MNS   , Q2LNS   ,                                                                         &
    & UDY     , VDX   
!
    REAL   (KIND=R4KIND), DIMENSION(IDIM1:IDIM2, JDIM1:JDIM2)                                   ::&
    & DPDE    ,                                                                                   &
    & TEMPA   , TEMPB   ,                                                                         &
    & TST     ,                                                                                   &
    & UST     , VST     ,                                                                         &
    & Q2M     , Q2L     ,                                                                         &
    & TEW     , TNS     ,                                                                         &
    & Q2MEW   , Q2LEW 
!
    REAL   (KIND=R4KIND), DIMENSION(IDIM1:IDIM2, JDIM1:JDIM2)                                   ::&
    & TNE     , TSE     ,                                                                         &
    & Q2MNE   , Q2MSE   ,                                                                         &
    & Q2LNE   , Q2LSE   ,                                                                         &
    & UEW     , UNS     ,                                                                         &
    & VEW     , VNS     ,                                                                         &
    & UNE     , USE     ,                                                                         &
    & VNE     , VSE     ,                                                                         &
    & FEW     , FNS     ,                                                                         &
    & FNE     , FSE   
!
    REAL   (KIND=R4KIND), DIMENSION(IDIM1:IDIM2, JDIM1:JDIM2 , LM)                              ::&
    & ADQ2HL
!
    REAL   (KIND=R4KIND), DIMENSION(IDIM1:IDIM2, JDIM1:JDIM2 , LM+1)                            ::&
    & Q2ML
!
    REAL   (KIND=R4KIND), DIMENSION(JAMD)                                                       ::&
    & ARRAY0  , ARRAY1  , ARRAY2  , ARRAY3 
!
    INTEGER(KIND=R4KIND), DIMENSION(JAMD)                                                       ::&
    & KHHAS   , IHLAS   , JHLAS   , KVHAS   , IVLAS   , JVLAS   , ISPA    , ISQA
!
    LOGICAL(KIND=L4KIND)                                                                        ::&
    & UPSTRM
!
    LOGICAL(KIND=L4KIND), DIMENSION(JAM)                                                        ::&
    & LJRA
!------------------------
! IMPLICIT NONE VARIABLES
!------------------------
    INTEGER(KIND=I4KIND)                                                                        ::&
    & IEND    , I       , J       , K       , JAKONE  , JA      , IHL     , IHH     , JAKTWO  ,   &
    & IVL     , IVH     , JAK     , IX      , JX      , ISP     , ISQ     , IFP     , IFQ     ,   &
    & IPQ        
!
    REAL   (KIND=R4KIND)                                                                        ::&
    & TTA     , TTB     , PP      , QP      , F0      , F1     , F2       , F3
!
    INCLUDE "CHECKIN"
!-------------------------------------------- 
! FIGURE OUT IF WE ARE IN THE UPSTREAM REGION
!-------------------------------------------- 
    UPSTRM = .FALSE. 
!
    IF (MYPE <= INPES-1)        UPSTRM = .TRUE. 
    IF (MYPE >= NPES-INPES)     UPSTRM = .TRUE. 
    IF (MOD(MYPE,INPES) == 0)   UPSTRM = .TRUE. 
    IF (MOD(MYPE+1,INPES) == 0) UPSTRM = .TRUE. 
!
    JAKONE = 0
!
    DO 25 JA=1,JAM
        IHL = IHLA(JA)
        IHH = IHHA(JA)
        J   =  JRA(JA)
!
        LJRA(JA) = .FALSE. 
!    
        IF (J >= MY_JS_GLB-JBPAD2 .AND. J <= MY_JE_GLB+JTPAD2) THEN
            LJRA(JA) = .TRUE. 
            DO I=IHL,IHH
                IF (I >= MY_IS_GLB-ILPAD2 .AND. I <= MY_IE_GLB+IRPAD2) THEN
                    JAKONE = JAKONE + 1
!
                    KHHAS(JAKONE) = JA
                    IHLAS(JAKONE) = I
                    JHLAS(JAKONE) = J
                END IF
            END DO
        END IF
!    
 25 END DO
!
    JAKTWO = 0
!
    DO 50 JA=1,JAM
        IVL = IVLA(JA)
        IVH = IVHA(JA)
        J   =  JRA(JA)
!    
        DO 50 I=IVL,IVH
            IF (I >= MY_IS_GLB-ILPAD2 .AND. I <= MY_IE_GLB+IRPAD2                                 &
    &                                 .AND.                                                       &
    &           J >= MY_JS_GLB-JBPAD2 .AND. J <= MY_JE_GLB+JTPAD2) THEN
                JAKTWO = JAKTWO + 1
!
                KVHAS(JAKTWO) = JA
                IVLAS(JAKTWO) = I
                JVLAS(JAKTWO) = J
            END IF
 50 END DO
!
    DO 70 J=MYJS_P5,MYJE_P5
        DO 70 I=MYIS_P4,MYIE_P4
            Q2ML(I,J,1) = 0.
 70 END DO
!------- 
! OPENMP
!------- 
!
!$omp parallel do
!
    DO 80 K=2,LM+1
        DO 80 J=MYJS_P5,MYJE_P5
            DO 80 I=MYIS_P4,MYIE_P4
                Q2ML(I,J,K) = Q2(I,J,K-1)
 80 END DO
!------- 
! OPENMP
!------- 
!
!$omp parallel do
!$omp private (ADPDX    , ADPDY   , ADQ     , ADQ2L   , ADQ2M   , ADT     , ADU     , ADV     ,   &
!$omp          ARRAY0   , ARRAY1  , ARRAY2  , ARRAY3  , DPDE    , F0      , F1      , F2      ,   &
!$omp          F3       , FEW     , FNE     , FNS     , FSE     , HM      , I       , IFP     ,   &
!$omp          IFQ      , IHH     , IHL     , IPQ     , ISP     , ISPA    , ISQ     , ISQA    ,   &
!$omp          ITER2    , IX      , IY      , J       , JA      , JAK     , K       , PP      ,   &
!$omp          Q2L      , Q2LEW   , Q2LNE   , Q2LNS   , Q2LSE   , Q2M     , Q2MEW   , Q2MNE   ,   &
!$omp          Q2MNS    , Q2MSE   , QEW     , QNE     , QNS     , QP      , QSE     , QST     ,   &
!$omp          RDPD     , RDPDX   , RDPDY   , TEMPA   , TEMPB   , TEW     , TNE     , TNS     ,   &
!$omp          TSE      , TST     , TTA     , TTB     , UDY     , UEW     , UNE     , UNS     ,   &
!$omp          USE      , UST     , VDX     , VEW     , VM      , VNE     , VNS     , VSE     ,   &
!$omp          VST      )
!
    DO 500 K=LM,1,-1
!
        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)
!
        ITER2 = .FALSE. 
!
        DO J=MYJS_P4,MYJE_P4
            DO I=MYIS_P4,MYIE_P4
                Q2M(I,J) = Q2ML(I,J,K)
            END DO
        END DO
!    
        DO 110 J=MYJS_P5,MYJE_P5
            DO 110 I=MYIS_P4,MYIE_P4
                  HM(I,J) =  HTM(I,J,K) * HBM2(I,J)
                DPDE(I,J) = PDSL(I,J)   * DETA(K)
                RDPD(I,J) = 1. / DPDE(I,J)
                 UST(I,J) =    U(I,J,K  )
                 VST(I,J) =    V(I,J,K  )
                 TST(I,J) =    T(I,J,K  )
                 Q2L(I,J) = Q2ML(I,J,K+1)
    110 END DO
!
        DO 120 J=MYJS1_P4,MYJE1_P4
            DO 120 I=MYIS_P4,MYIE_P4
                   VM(I,J) = VTM(I,J,K) * 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)
    120 END DO
!----------------------------------------------------------- 
! MASS FLUXES AND MASS POINTS ADVECTION COMPONENTS 
! 
! THE NS AND EW FLUXES IN THE FOLLOWING LOOP ARE ON V POINTS
!-----------------------------------------------------------
    125 DO 130 J=MYJS1_P4,MYJE1_P4
            DO 130 I=MYIS_P4,MYIE_P4
                  UDY(I,J) = UST(I,J) * DY
                  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  )
                  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 END DO
!-------------------------------------------------------------------------------------- 
! DIAGONAL FLUXES AND DIAGONALLY AVERAGED WIND 
! 
! THE NE AND SE FLUXES ARE ON H POINTS (ACTUALLY JUST TO THE NE AND SE OF EACH H POINT)
!--------------------------------------------------------------------------------------
        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 END DO
!    
        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)) * (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)) * (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 END DO
!---------------------------------------------- 
! THERMODYNAMIC EQUATION AND MOISTURE 
!
! THE AD ARRAYS IN THE 170 LOOP ARE ON H POINTS
!----------------------------------------------
        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)                               &
    &                      +  TNE(I+IHW(J),J-1) + TNE(I       ,J  )                               &
    &                      +  TSE(I       ,J  ) + TSE(I+IHW(J),J+1))                              &
    &                      * RDPD(I       ,J  ) * FAD(I       ,J   )
!
                ADQ2M(I,J) = (Q2MEW(I+IHW(J),J  ) + Q2MEW(I+IHE(J),J  )                           &
    &                      +  Q2MNS(I       ,J-1) + Q2MNS(I       ,J+1)                           &
    &                      +  Q2MNE(I+IHW(J),J-1) + Q2MNE(I       ,J  )                           &
    &                      +  Q2MSE(I       ,J  ) + Q2MSE(I+IHW(J),J+1))                          &
    &                      *   RDPD(I       ,J  ) *   FAD(I       ,J  )
!
                ADQ2L(I,J) = (Q2LEW(I+IHW(J),J  ) + Q2LEW(I+IHE(J),J  )                           &
    &                      +  Q2LNS(I       ,J-1) + Q2LNS(I       ,J+1)                           &
    &                      +  Q2LNE(I+IHW(J),J-1) + Q2LNE(I       ,J  )                           &
    &                      +  Q2LSE(I       ,J  ) + Q2LSE(I+IHW(J),J+1))                          &
    &                      *   RDPD(I       ,J  ) *   FAD(I       ,J  )
    170 END DO
!---------------------------------- 
! UPSTREAM ADVECTION OF T, Q AND Q2 
!---------------------------------- 
        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  )                      &
    &               +            UST(IX+IHE(JX),JX  ) + UST(IX        ,JX+1))
!
                TTB = ENT     * (VST(IX        ,JX-1) + VST(IX+IHW(JX),JX  )                      &
    &               +            VST(IX+IHE(JX),JX  ) + VST(IX        ,JX+1))
!
                PP = -TTA - TTB
                QP =  TTA - TTB
!            
                IF (PP < 0.) THEN
                    ISPA(JAK) = -1
                ELSE
                    ISPA(JAK) =  1
                END IF
!            
                IF (QP < 0.) THEN
                    ISQA(JAK) = -1
                ELSE
                    ISQA(JAK) =  1
                END IF
!            
                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 END DO
!        
            JAK = 0
!
            DO 173 JA=1,JAM
                IHL = IHLA(JA)
                IHH = IHHA(JA)
                J   =  JRA(JA)
!
                IF ( .NOT. LJRA(JA)) GOTO 173
!            
                DO I=IHL,IHH
                    IF (I >= MY_IS_GLB-ILPAD2 .AND. I <= 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
!                    
                        IX = I - MY_IS_GLB + 1
                        JX = J - MY_JS_GLB + 1
!                    
                        IF (HTM(IX+IHE(JX)+IFP,JX+ISP    ,K) *                                    &
    &                       HTM(IX+IHE(JX)+IFQ,JX    +ISQ,K) *                                    &
    &                       HTM(IX        +IPQ,JX+ISP+ISQ,K) > 0.1) GOTO 172
!                    
                        IF (HTM(IX+IHE(JX)+IFP,JX+ISP    ,K) +                                    &
    &                       HTM(IX+IHE(JX)+IFQ,JX    +ISQ,K) +                                    &
    &                       HTM(IX        +IPQ,JX+ISP+ISQ,K) < 0.1) THEN
!
                            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)
!
                        ELSE IF (HTM(IX+IHE(JX)+IFP,JX+ISP    ,K) +                               &
    &                            HTM(IX        +IPQ,JX+ISP+ISQ,K) < 0.99) THEN
!
                            TST(IX+IHE(JX)+IFP,JX+ISP    ) = TST(IX            ,JX    )
                            TST(IX        +IPQ,JX+ISP+ISQ) = TST(IX+IHE(JX)+IFQ,JX+ISQ)
!
                        ELSE IF (HTM(IX+IHE(JX)+IFQ,JX    +ISQ,K) +                               &
    &                            HTM(IX+IPQ        ,JX+ISP+ISQ,K) < 0.99) THEN

                            TST(IX+IHE(JX)+IFQ,JX    +ISQ) = TST(IX            ,JX    )
                            TST(IX        +IPQ,JX+ISP+ISQ) = TST(IX+IHE(JX)+IFP,JX+ISP)
!
                        ELSE IF (HTM(IX+IHE(JX)+IFP,JX+ISP    ,K) +                               &
    &                            HTM(IX+IHE(JX)+IFQ,JX    +ISQ,K) < 0.99) THEN
!
                            TST(IX+IHE(JX)+IFP,JX+ISP    ) = 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)
!
                        ELSE IF (HTM(IX+IHE(JX)+IFP,JX+ISP,K) < 0.99) THEN
!
                            TST(IX+IHE(JX)+IFP,JX+ISP) = TST(IX            ,JX        )           &
    &                                                  + TST(IX+IPQ        ,JX+ISP+ISQ)           &
    &                                                  - TST(IX+IHE(JX)+IFQ,JX    +ISQ)
!
                        ELSE IF (HTM(IX+IHE(JX)+IFQ,JX+ISQ,K) < 0.99) THEN
!
                            TST(IX+IHE(JX)+IFQ,JX+ISQ) = TST(IX            ,JX        )           &
    &                                                  + TST(IX+IPQ        ,JX+ISP+ISQ)           &
    &                                                  - TST(IX+IHE(JX)+IFP,JX+ISP    )
                        ELSE
                            TST(IX+IPQ,JX+ISP+ISQ) = TST(IX+IHE(JX)+IFP,JX+ISP    )               &
    &                                              + TST(IX+IHE(JX)+IFQ,JX    +ISQ)               &
    &                                              - TST(IX            ,JX        )
                        END IF
!                    
                    172 CONTINUE
!                    
                        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    )        &
    &                              +                   F2 * TST(IX+IHE(JX)+IFQ,JX    +ISQ)        &
    &                              +                   F3 * TST(IX+IPQ        ,JX+ISP+ISQ)
                    END IF
!
                END DO
        173 END DO
!        
            DO 175 JAK=1,JAKONE
                I = IHLAS(JAK)
                J = JHLAS(JAK)
!            
                IX = I - MY_IS_GLB + 1
                JX = J - MY_JS_GLB + 1
!            
                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    )             &
    &                        +                   F2 *  Q2M(IX+IHE(JX)+IFQ,JX    +ISQ)             &
    &                        +                   F3 *  Q2M(IX+IPQ        ,JX+ISP+ISQ)
!
                ADQ2L(IX,JX) = F0 * Q2L(IX,JX) + F1 * Q2L(IX+IHE(JX)+IFP,JX+ISP    )              &
    &                        +                   F2 * Q2L(IX+IHE(JX)+IFQ,JX    +ISQ)              &
    &                        +                   F3 * Q2L(IX+IPQ        ,JX+ISP+ISQ)
        175 END DO
!        
        END IF
!----------------------------------------------- 
! END OF THIS UPSTREAM REGION
!
! CALCULATION OF MOMENTUM ADVECTION COMPONENTS 
!
! THE FOLLOWING EW AND NS ARRAYS ARE ON H POINTS
!-----------------------------------------------
        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  ))                                 &
    &                   * (UST(I+IHE(J),J  ) - UST(I+IHW(J),J  ))
!
               UNS(I,J) = (FNS(I+IHW(J),J  ) + FNS(I+IHE(J),J  ))                                 &
    &                   * (UST(I       ,J+1) - UST(I       ,J-1))
!
               VEW(I,J) = (FEW(I       ,J-1) + FEW(I       ,J+1))                                 &
    &                   * (VST(I+IHE(J),J  ) - VST(I+IHW(J),J  ))
!
               VNS(I,J) = (FNS(I       ,J-1) + FNS(I       ,J+1))                                 &
    &                   * (VST(I       ,J+1) - VST(I       ,J-1))
!---------------------------------------------------- 
! THE FOLLOWING NE AND SE ARRAYS ARE TIED TO V POINTS
!---------------------------------------------------- 
               UNE(I,J) = (FNE(I+IVW(J),J  ) + FNE(I+IVE(J),J  ))                                 &
    &                   * (UST(I+IVE(J),J+1) - UST(I      ,J   ))
!
               USE(I,J) = (FSE(I+IVW(J),J  ) + FSE(I+IVE(J),J  ))                                 &
    &                   * (UST(I+IVE(J),J-1) - UST(I       ,J  ))
!
               VNE(I,J) = (FNE(I       ,J-1) + FNE(I       ,J+1))                                 &
    &                   * (VST(I+IVE(J),J+1) - VST(I       ,J  ))
!
               VSE(I,J) = (FSE(I       ,J-1) + FSE(I       ,J+1))                                 &
    &                   * (VST(I+IVE(J),J-1) - VST(I       ,  J))
    180 END DO
!----------------------------  
! EQUATION OF MOTION 
!
! ADU AND ADV ARE ON V POINTS
!----------------------------  
        DO 200 J=MYJS5_P2,MYJE5_P2
            DO 200 I=MYIS_P2,MYIE_P2
                ADU(I,J) =  (UEW(I+IVW(J),J  ) + UEW(I+IVE(J),J  )                                &
    &                    +   UNS(I       ,J-1) + UNS(I       ,J+1)                                &
    &                    +   UNE(I+IVW(J),J-1) + UNE(I       ,J  )                                &
    &                    +   USE(I       ,J  ) + USE(I+IVW(J),J+1))                               &
    &                    * 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)                                &
    &                    +   VNE(I+IVW(J),J-1) + VNE(I       ,J  )                                &
    &                    +   VSE(I       ,J  ) + VSE(I+IVW(J),J+1))                               &
    &                    * RDPDY(I       ,J  ) * FAD(I+IVW(J),J  )
    200 END DO
!------------------------------------------     
! UPSTREAM ADVECTION OF VELOCITY COMPONENTS 
!------------------------------------------    
        IF (UPSTRM) THEN
            DO 205 JAK=1,JAKTWO
                JA = KVHAS(JAK)
                I  = IVLAS(JAK)
                J  = JVLAS(JAK)
!            
                IX = I - MY_IS_GLB + 1
                JX = J - MY_JS_GLB + 1
!            
                TTA = EM(JA) * UST(IX,JX)
                TTB = EN     * VST(IX,JX)
!
                PP = -TTA - TTB
                QP =  TTA - TTB
!            
                IF (PP < 0.) THEN
                    ISP = -1
                ELSE
                    ISP =  1
                END IF
!            
                IF (QP < 0.) THEN
                    ISQ = -1
                ELSE
                    ISQ =  1
                END IF
!            
                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    )                &
    &                      +                   F2 * UST(IX+IVE(JX)+IFQ,JX    +ISQ)                &
    &                      +                   F3 * UST(IX        +IPQ,JX+ISP+ISQ)
!
                ADV(IX,JX) = F0 * VST(IX,JX) + F1 * VST(IX+IVE(JX)+IFP,JX+ISP    )                &
    &                                        + F2 * VST(IX+IVE(JX)+IFQ,JX    +ISQ)                &
    &                                        + F3 * VST(IX        +IPQ,JX+ISP+ISQ)
        205 END DO
        END IF
!---------------------------- 
! END OF THIS UPSTREAM REGION
!----------------------------
        IF (ITER2) GOTO 235
!
        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 END DO
!    
        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 END DO
!
        ITER2 = .TRUE.
! 
        GOTO 125
!
    235 DO 240 J=MYJS2,MYJE2
        DO 240 I=MYIS1,MYIE1
            T(I,J,K) = ADT(I,J) * (2.0*HM(I,J)) + T(I,J,K)
    240 END DO
!    
        DO 250 J=MYJS2,MYJE2
            DO 250 I=MYIS1,MYIE1
                U(I,J,K) = ADU(I,J) * (2.0*VM(I,J)) + U(I,J,K)
                V(I,J,K) = ADV(I,J) * (2.0*VM(I,J)) + V(I,J,K)
    250 END DO
!
        IF (K == LM) THEN
            DO 260 J=MYJS2,MYJE2
                DO 260 I=MYIS1,MYIE1
                    ADQ2HL(I,J,LM-1) = ADQ2M(I,J)
        260 END DO
!
        ELSE IF (K > 1 .AND. K < LM) THEN
            DO 270 J=MYJS2,MYJE2
                DO 270 I=MYIS1,MYIE1
                    ADQ2HL(I,J,K-1) = ADQ2M(I,J)
                        Q2(I,J,K  ) = ADQ2L(I,J) * HM(I,J) + Q2(I,J,K)
        270 END DO
!
        ELSE
            DO 280 J=MYJS2,MYJE2
                DO 280 I=MYIS1,MYIE1
                    Q2(I,J,K) = ADQ2L(I,J) * HM(I,J) + Q2(I,J,K)
        280 END DO
        END IF
!
500 END DO
!------- 
! OPENMP
!------- 
!
!$omp parallel do private (HM)
!
    DO 600 K=2,LM-1
        DO J=MYJS2,MYJE2
            DO I=MYIS1,MYIE1
                HM(I,J)   =    HTM(I,J,K) * HBM2(I,J)
                Q2(I,J,K) = ADQ2HL(I,J,K) *   HM(I,J) + Q2(I,J,K)
            END DO
        END DO
600 END DO
!
    RETURN
!
    END SUBROUTINE HZADV_LM1
