!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
    SUBROUTINE HZADV2
!     ******************************************************************
!$$$  SUBPROGRAM DOCUMENTATION BLOCK
!                .      .    .
! SUBPROGRAM:    HZADV2      HORIZONTAL ADVECTION OF VAPOR AND CLOUD
!   PRGRMMR: JANJIC          ORG: W/NP22     DATE: 96-07-19

! ABSTRACT:
!     HZADV2 CALCULATES THE CONTRIBUTION OF THE HORIZONTAL ADVECTION
!     TO THE TENDENCIES OF SPECIFIC HUMIDITY AND CLOUD WATER AND
!     THEN UPDATES THOSE VARIABLES.  AN ANTI-FILTERING TECHNIQUE
!     IS USED.

! PROGRAM HISTORY LOG:
!   96-07-19  JANJIC   - ORIGINATOR
!   98-11-02  BLACK    - MODIFIED FOR DISTRIBUTED MEMORY
!   99-03-17  TUCCILLO - INCORPORATED MPI_ALLREDUCE FOR GLOBAL SUM

! USAGE: CALL HZADV1 FROM MAIN PROGRAM EBU
!   INPUT ARGUMENT LIST:
!       NONE

!   OUTPUT ARGUMENT LIST
!       NONE

!   OUTPUT FILES:
!       NONE
!   SUBPROGRAMS CALLED:

!     UNIQUE: NONE

!     LIBRARY: NONE

!   COMMON BLOCKS: CTLBLK
!                  LOOPS
!                  MASKS
!                  DYNAM
!                  CONTIN
!                  VRBLS
!                  PVRBLS
!                  CLDWTR
!                  INDX

! ATTRIBUTES:
!   LANGUAGE: FORTRAN 90
!   MACHINE : IBM SP
!$$$
!***********************************************************************
    PARAMETER &
    (EPSQ=2.E-12,CLIMIT=1.E-20 &
    ,FF1=0.52500,FF2=-0.64813,FF3=0.24520,FF4=-0.12189)
!-----------------------------------------------------------------------
    INCLUDE "parmeta.f90"
    INCLUDE "mpp.h"
    INCLUDE "mpif.h"
#include "sp.h"
!-----------------------------------------------------------------------
    PARAMETER &
    (IM1=IM-1,JAM=6+2*(JM-10) &
    , IMJM=IM*JM-JM/2 &
    , JAMD=(JAM*2-10)*3,LP1=LM+1)
!-----------------------------------------------------------------------
    LOGICAL :: &
    RUN,FIRST,RESTRT,SIGMA
!-----------------------------------------------------------------------
    INCLUDE "COMM_CTLBLK.f90"
!-----------------------------------------------------------------------
    INCLUDE "COMM_LOOPS.f90"
!-----------------------------------------------------------------------
    INCLUDE "COMM_MASKS.f90"
!-----------------------------------------------------------------------
    INCLUDE "COMM_DYNAM.f90"
!-----------------------------------------------------------------------
    INCLUDE "COMM_CONTIN.f90"
!-----------------------------------------------------------------------
    INCLUDE "COMM_VRBLS.f90"
!-----------------------------------------------------------------------
    INCLUDE "COMM_PVRBLS.f90"
!-----------------------------------------------------------------------
    INCLUDE "COMM_CLDWTR.f90"
!-----------------------------------------------------------------------
    INCLUDE "COMM_INDX.f90"
!-----------------------------------------------------------------------
    DIMENSION &
    IFPA(IDIM1:IDIM2,JDIM1:JDIM2,LM),IFQA(IDIM1:IDIM2,JDIM1:JDIM2,LM) &
    ,IFPF(IDIM1:IDIM2,JDIM1:JDIM2,LM),IFQF(IDIM1:IDIM2,JDIM1:JDIM2,LM) &
    ,JFPA(IDIM1:IDIM2,JDIM1:JDIM2,LM),JFQA(IDIM1:IDIM2,JDIM1:JDIM2,LM) &
    ,JFPF(IDIM1:IDIM2,JDIM1:JDIM2,LM),JFQF(IDIM1:IDIM2,JDIM1:JDIM2,LM) &
    ,AFP (IDIM1:IDIM2,JDIM1:JDIM2,LM),AFQ (IDIM1:IDIM2,JDIM1:JDIM2,LM) &
    ,Q1  (IDIM1:IDIM2,JDIM1:JDIM2,LM),DQST(IDIM1:IDIM2,JDIM1:JDIM2,LM) &
    ,W1  (IDIM1:IDIM2,JDIM1:JDIM2,LM),DWST(IDIM1:IDIM2,JDIM1:JDIM2,LM) &
    ,DARE(IDIM1:IDIM2,JDIM1:JDIM2),   DVOL(IDIM1:IDIM2,JDIM1:JDIM2,LM) &
    ,EMH (IDIM1:IDIM2,JDIM1:JDIM2)
!    &,QLIM(IDIM1:IDIM2,JDIM1:JDIM2),WLIM  (IDIM1:IDIM2,JDIM1:JDIM2)
!-----------------------------------------------------------------------
    REAL :: &
    GSUMS(4,LM),XSUMS(4,LM)

!-----------------------------------------------------------------------
    INTEGER :: &
    ISTAT(MPI_STATUS_SIZE)

!***********************************************************************
    ENH=FLOAT(IDTAD)*DT/(08.*DY)

    DO J=MYJS_P2,MYJE_P2
        DO I=MYIS_P1,MYIE_P1
            EMH (I,J)=FLOAT(IDTAD)*DT/(08.*DX(I,J))
            DARE(I,J)=HBM2(I,J)*DX(I,J)*DY
        ENDDO
    ENDDO

!***********************************************************************
!-----------------------------------------------------------------------
! omp  parallel do
! omp& private(dqstij,dvolp,dwstij,htmijl,jfp,jfq,pp,qp,
! omp&         sumnq,sumnw,sumpq,sumpw,tta,ttb)

!-----------------------------------------------------------------------
    DO L=1,LM
    !-----------------------------------------------------------------------
    !***********************************************************************
        DO 200 J=MYJS_P2,MYJE_P2
            DO 200 I=MYIS_P1,MYIE_P1
                DVOL(I,J,L)=DARE(I,J)*PDSL(I,J)*DETA(L)
                HTMIJL=HTM(I,J,L)
                Q  (I,J,L)=AMAX1(Q  (I,J,L),EPSQ)*HTMIJL
                CWM(I,J,L)=AMAX1(CWM(I,J,L),CLIMIT)*HTMIJL
                Q1  (I,J,L)=Q  (I,J,L)
                W1  (I,J,L)=CWM(I,J,L)
        200 END DO
    !-----------------------------------------------------------------------
        SUMPQ=0.
        SUMNQ=0.
        SUMPW=0.
        SUMNW=0.
    
        DO 300 J=MYJS2_P1,MYJE2_P1
            DO 300 I=MYIS1_P1,MYIE1_P1
            
                DVOLP=DVOL(I,J,L)*HBM3(I,J)
                TTA=(U(I,J-1,L)+U(I+IHW(J),J,L)+U(I+IHE(J),J,L)+U(I,J+1,L)) &
                *HBM2(I,J)*EMH(I,J)
                TTB=(V(I,J-1,L)+V(I+IHW(J),J,L)+V(I+IHE(J),J,L)+V(I,J+1,L)) &
                *HBM2(I,J)*ENH
            
                PP=-TTA-TTB
                QP= TTA-TTB
            
                JFP=INT(SIGN(1.,PP))
                JFQ=INT(SIGN(1.,QP))
            
                IFPA(I,J,L)=IHE(J)+I+( JFP-1  )/2
                IFQA(I,J,L)=IHE(J)+I+(-JFQ-1  )/2
            
                JFPA(I,J,L)=       J+JFP
                JFQA(I,J,L)=       J+JFQ
            
                IFPF(I,J,L)=IHE(J)+I+(-JFP-1  )/2
                IFQF(I,J,L)=IHE(J)+I+( JFQ-1  )/2
            
                JFPF(I,J,L)=       J-JFP
                JFQF(I,J,L)=       J-JFQ
            
                PP=ABS(PP)*HTM(I,J,L)*HTM(IFPA(I,J,L),JFPA(I,J,L),L)
                QP=ABS(QP)*HTM(I,J,L)*HTM(IFQA(I,J,L),JFQA(I,J,L),L)
            
                AFP (I,J,L)=(((FF4*PP+FF3)*PP+FF2)*PP+FF1)*PP
                AFQ (I,J,L)=(((FF4*QP+FF3)*QP+FF2)*QP+FF1)*QP
            
                DQSTIJ=(Q  (IFPA(I,J,L),JFPA(I,J,L),L)-Q  (I,J,L))*PP &
                +(Q  (IFQA(I,J,L),JFQA(I,J,L),L)-Q  (I,J,L))*QP
                DWSTIJ=(CWM(IFPA(I,J,L),JFPA(I,J,L),L)-CWM(I,J,L))*PP &
                +(CWM(IFQA(I,J,L),JFQA(I,J,L),L)-CWM(I,J,L))*QP
            
                DQST(I,J,L)=DQSTIJ
                DWST(I,J,L)=DWSTIJ
            
        300 END DO
    !***
    !***  GLOBAL SUM FOR CONSERVATION
    !***
        DO 310 J=MYJS2,MYJE2
            DO 310 I=MYIS1,MYIE1
            
                DVOLP=DVOL(I,J,L)*HBM3(I,J)
                DQSTIJ=DQST(I,J,L)*DVOLP
                DWSTIJ=DWST(I,J,L)*DVOLP
            
                IF(DQSTIJ > 0.)THEN
                    SUMPQ=SUMPQ+DQSTIJ
                ELSE
                    SUMNQ=SUMNQ+DQSTIJ
                ENDIF
            
                IF(DWSTIJ > 0.)THEN
                    SUMPW=SUMPW+DWSTIJ
                ELSE
                    SUMNW=SUMNW+DWSTIJ
                ENDIF
            
        310 END DO
    
    !-----------------------------------------------------------------------
        XSUMS(1,L)=SUMPQ
        XSUMS(2,L)=SUMNQ
        XSUMS(3,L)=SUMPW
        XSUMS(4,L)=SUMNW
    
    ENDDO               ! END OF LM LOOP
!-----------------------------------------------------------------------

!***  GLOBAL REDUCTION

    CALL MPI_ALLREDUCE(XSUMS,GSUMS,4*LM,MPI_REAL,MPI_SUM, &
    MPI_COMM_COMP,IRECV)

!***  END OF GLOBAL REDUCTION

!-----------------------------------------------------------------------
! omp  parallel do
! omp& private(d2pqq,d2pqw,dqstij,dvolp,dwstij,
! omp&         q00,q0q,q1ij,qp0,qstij,rfacq,rfacw,
! omp&         rfqij,rfwij,sumnq,sumnw,sumpq,sumpw,
! omp&         w00,w0q,w1ij,wp0,wstij)
!-----------------------------------------------------------------------
    DO L=1,LM
    !-----------------------------------------------------------------------
    
        SUMPQ=GSUMS(1,L)
        SUMNQ=GSUMS(2,L)
        SUMPW=GSUMS(3,L)
        SUMNW=GSUMS(4,L)
    
    !--------------FIRST MOMENT CONSERVING FACTOR---------------------------
        IF(SUMPQ > 1.)THEN
            RFACQ=-SUMNQ/SUMPQ
        ELSE
            RFACQ=1.
        ENDIF
    
        IF(SUMPW > 1.)THEN
            RFACW=-SUMNW/SUMPW
        ELSE
            RFACW=1.
        ENDIF
    
        IF(RFACQ < 0.9 .OR. RFACQ > 1.1)RFACQ=1.
        IF(RFACW < 0.9 .OR. RFACW > 1.1)RFACW=1.
    !--------------IMPOSE CONSERVATION ON ADVECTION-------------------------
        IF(RFACQ < 1.)THEN
            DO J=MYJS2_P1,MYJE2_P1
                DO I=MYIS1_P1,MYIE1_P1
                    DQSTIJ=DQST(I,J,L)
                    RFQIJ=HBM3(I,J)*(RFACQ-1.)+1.
                    IF(DQSTIJ < 0.)DQSTIJ=DQSTIJ/RFQIJ
                    Q1(I,J,L)=Q(I,J,L)+DQSTIJ
                ENDDO
            ENDDO
        ELSE
            DO J=MYJS2_P1,MYJE2_P1
                DO I=MYIS1_P1,MYIE1_P1
                    DQSTIJ=DQST(I,J,L)
                    RFQIJ=HBM3(I,J)*(RFACQ-1.)+1.
                    IF(DQSTIJ >= 0.)DQSTIJ=DQSTIJ*RFQIJ
                    Q1(I,J,L)=Q(I,J,L)+DQSTIJ
                ENDDO
            ENDDO
        ENDIF
    !-----------------------------------------------------------------------
        IF(RFACW < 1.)THEN
            DO J=MYJS2_P1,MYJE2_P1
                DO I=MYIS1_P1,MYIE1_P1
                    DWSTIJ=DWST(I,J,L)
                    RFWIJ=HBM3(I,J)*(RFACW-1.)+1.
                    IF(DWSTIJ < 0.)DWSTIJ=DWSTIJ/RFWIJ
                    W1(I,J,L)=CWM(I,J,L)+DWSTIJ
                ENDDO
            ENDDO
        ELSE
            DO J=MYJS2_P1,MYJE2_P1
                DO I=MYIS1_P1,MYIE1_P1
                    DWSTIJ=DWST(I,J,L)
                    RFWIJ=HBM3(I,J)*(RFACW-1.)+1.
                    IF(DWSTIJ >= 0.)DWSTIJ=DWSTIJ*RFWIJ
                    W1(I,J,L)=CWM(I,J,L)+DWSTIJ
                ENDDO
            ENDDO
        ENDIF
    !--------------ANTI-FILTERING STEP--------------------------------------
        SUMPQ=0.
        SUMNQ=0.
        SUMPW=0.
        SUMNW=0.
    !--------------ANTI-FILTERING LIMITERS----------------------------------
        DO 330 J=MYJS2,MYJE2
            DO 330 I=MYIS1,MYIE1
            
                DVOLP=DVOL(I,J,L)
                Q1IJ =Q1(I,J,L)
                W1IJ =W1(I,J,L)
            
                D2PQQ=((Q1(IFPA(I,J,L),JFPA(I,J,L),L)-Q1IJ                   ) &
                -(Q1IJ                   -Q1(IFPF(I,J,L),JFPF(I,J,L),L)) &
                *HTM(IFPF(I,J,L),JFPF(I,J,L),L))*AFP(I,J,L) &
                +((Q1(IFQA(I,J,L),JFQA(I,J,L),L)-Q1IJ                   ) &
                -(Q1IJ                   -Q1(IFQF(I,J,L),JFQF(I,J,L),L)) &
                *HTM(IFQF(I,J,L),JFQF(I,J,L),L))*AFQ(I,J,L)
            
                D2PQW=((W1(IFPA(I,J,L),JFPA(I,J,L),L)-W1IJ                   ) &
                -(W1IJ                   -W1(IFPF(I,J,L),JFPF(I,J,L),L)) &
                *HTM(IFPF(I,J,L),JFPF(I,J,L),L))*AFP(I,J,L) &
                +((W1(IFQA(I,J,L),JFQA(I,J,L),L)-W1IJ                   ) &
                -(W1IJ                   -W1(IFQF(I,J,L),JFQF(I,J,L),L)) &
                *HTM(IFQF(I,J,L),JFQF(I,J,L),L))*AFQ(I,J,L)
            
                QSTIJ=Q1IJ-D2PQQ
                WSTIJ=W1IJ-D2PQW
            
                Q00=Q  (I          ,J          ,L)
                QP0=Q  (IFPA(I,J,L),JFPA(I,J,L),L)
                Q0Q=Q  (IFQA(I,J,L),JFQA(I,J,L),L)
            
                W00=CWM(I          ,J          ,L)
                WP0=CWM(IFPA(I,J,L),JFPA(I,J,L),L)
                W0Q=CWM(IFQA(I,J,L),JFQA(I,J,L),L)
            
                QSTIJ=AMAX1(QSTIJ,AMIN1(Q00,QP0,Q0Q))
                QSTIJ=AMIN1(QSTIJ,AMAX1(Q00,QP0,Q0Q))
                WSTIJ=AMAX1(WSTIJ,AMIN1(W00,WP0,W0Q))
                WSTIJ=AMIN1(WSTIJ,AMAX1(W00,WP0,W0Q))
            
                DQSTIJ=QSTIJ-Q1IJ
                DWSTIJ=WSTIJ-W1IJ
            
                DQST(I,J,L)=DQSTIJ
                DWST(I,J,L)=DWSTIJ
            
                DQSTIJ=DQSTIJ*DVOLP
                DWSTIJ=DWSTIJ*DVOLP
            
                IF(DQSTIJ > 0.)THEN
                    SUMPQ =SUMPQ+DQSTIJ
                ELSE
                    SUMNQ =SUMNQ+DQSTIJ
                ENDIF
            
                IF(DWSTIJ > 0.)THEN
                    SUMPW =SUMPW+DWSTIJ
                ELSE
                    SUMNW =SUMNW+DWSTIJ
                ENDIF
            
        330 END DO
    !-----------------------------------------------------------------------
        XSUMS(1,L)=SUMPQ
        XSUMS(2,L)=SUMNQ
        XSUMS(3,L)=SUMPW
        XSUMS(4,L)=SUMNW
    
    ENDDO               ! END OF LM LOOP
!-----------------------------------------------------------------------

!***  GLOBAL REDUCTION

    CALL MPI_ALLREDUCE(XSUMS,GSUMS,4*LM,MPI_REAL,MPI_SUM, &
    MPI_COMM_COMP,IRECV)

!***  END OF GLOBAL REDUCTION

!-----------------------------------------------------------------------

! omp  parallel do
! omp& private(dqstij,dwstij,htmijl,rfacq,rfacw,rfqij,rfwij,
! omp&         sumnw,sumnq,sumpq,sumpw)
!-----------------------------------------------------------------------
    DO L=1,LM
    
        SUMPQ=GSUMS(1,L)
        SUMNQ=GSUMS(2,L)
        SUMPW=GSUMS(3,L)
        SUMNW=GSUMS(4,L)
    
    !--------------FIRST MOMENT CONSERVING FACTOR---------------------------
        IF(SUMPQ > 1.)THEN
            RFACQ=-SUMNQ/SUMPQ
        ELSE
            RFACQ=1.
        ENDIF
    
        IF(SUMPW > 1.)THEN
            RFACW=-SUMNW/SUMPW
        ELSE
            RFACW=1.
        ENDIF
    
        IF(RFACQ < 0.9 .OR. RFACQ > 1.1)RFACQ=1.
        IF(RFACW < 0.9 .OR. RFACW > 1.1)RFACW=1.
    !--------------IMPOSE CONSERVATION ON ANTI-FILTERING--------------------
        IF(RFACQ < 1.)THEN
            DO J=MYJS2,MYJE2
                DO I=MYIS1,MYIE1
                    DQSTIJ=DQST(I,J,L)
                    RFQIJ=HBM2(I,J)*(RFACQ-1.)+1.
                    IF(DQSTIJ >= 0.)   DQSTIJ=DQSTIJ*RFQIJ
                    Q  (I,J,L)=Q1(I,J,L)+DQSTIJ
                ENDDO
            ENDDO
        ELSE
            DO J=MYJS2,MYJE2
                DO I=MYIS1,MYIE1
                    DQSTIJ=DQST(I,J,L)
                    RFQIJ=HBM2(I,J)*(RFACQ-1.)+1.
                    IF(DQSTIJ < 0.)   DQSTIJ=DQSTIJ/RFQIJ
                    Q  (I,J,L)=Q1(I,J,L)+DQSTIJ
                ENDDO
            ENDDO
        ENDIF
    !-----------------------------------------------------------------------
        IF(RFACW < 1.)THEN
            DO J=MYJS2,MYJE2
                DO I=MYIS1,MYIE1
                    DWSTIJ=DWST(I,J,L)
                    RFWIJ=HBM2(I,J)*(RFACW-1.)+1.
                    IF(DWSTIJ >= 0.)   DWSTIJ=DWSTIJ*RFWIJ
                    CWM(I,J,L)=W1(I,J,L)+DWSTIJ
                ENDDO
            ENDDO
        ELSE
            DO J=MYJS2,MYJE2
                DO I=MYIS1,MYIE1
                    DWSTIJ=DWST(I,J,L)
                    RFWIJ=HBM2(I,J)*(RFACW-1.)+1.
                    IF(DWSTIJ < 0.)   DWSTIJ=DWSTIJ/RFWIJ
                    CWM(I,J,L)=W1(I,J,L)+DWSTIJ
                ENDDO
            ENDDO
        ENDIF
    
    !-----------------------------------------------------------------------
    
        DO J=MYJS,MYJE
            DO I=MYIS,MYIE
                HTMIJL=HTM(I,J,L)
                Q  (I,J,L)=AMAX1(Q  (I,J,L),EPSQ)*HTMIJL
                CWM(I,J,L)=AMAX1(CWM(I,J,L),CLIMIT)*HTMIJL
            ENDDO
        ENDDO
    !-----------------------------------------------------------------------
    
    ENDDO       ! END OF LM LOOP

!-----------------------------------------------------------------------
    RETURN
    END SUBROUTINE HZADV2
