#ifdef RS6K
@PROCESS NOCHECK
#endif

SUBROUTINE TRACMF( PGMVS, PGMVT1S, PGFL, PGFLT1)
!
!     Purpose.   Correct global mass of gfl of tracer after SL Advection 
!     --------   
!
!*   Interface.
!     ----------
!
!        *CALL* *TRACMF (PGMVS,PGMVT1S, PGFLT, PGFLT1)
!
!     Explicit arguments :
!        --------------------
!
!
!!     INPUT:
!     -------------
!        PGMVS       : surface GMV variables at t and t-dt.
!        PGMVS       : surface GMV variables at t +dt 
!        PGFL       : GFL variables buffer t0 t1
!
!     OUTPUT:
!     -------
!        PGFLT1       : GFL variables buffer t + dt
!
!        Implicit arguments :  None.
!        --------------------
!
!     Method.
!     -------
!     - proportional mass fix 
!     - additive mass fix according to different diagnistics 
!        horizontal laplace, vertical laplace and absolute gradient
!     Externals.   See includes below.
!     ----------

!     Reference.
!     ----------
!        ECMWF Research Department documentation of the IFS

!     Author.
!     -------
!        Johannes Flemming   *ECMWF*

! Modifications
! -------------
!
USE PARKIND1 , ONLY : JPIM, JPRB
USE YOMHOOK  , ONLY : LHOOK, DR_HOOK
!USE CHEM_MIX , ONLY : SMASSCOR, LCHEM_DIA, LTRCMFP, LTRCMFA_LAP, LTRCMFA_VER, &
! &  LTRCMFA_DIF
USE YOM_YGFL , ONLY : YGFLC, YGFL, LTRCMFIX_PS
USE YOMGMV   , ONLY : YT1, YPH9, NDIMGMVS
USE YOMGEM   , ONLY : NGPTOT, VAH, VBH
USE YOMDIM   , ONLY : NPROMA, NGPBLKS, NSPEC2, NFLEVG, NFLSUR
USE YOMGC    , ONLY : GAW
USE YOMLAP   , ONLY : RLAPDI, NVALUE
USE YOMCST   , ONLY : RG
USE MPL_MODULE,ONLY : MPL_ALLREDUCE


IMPLICIT NONE

! arguments

REAL(KIND=JPRB)   ,INTENT(IN)    :: PGMVS(NPROMA,NDIMGMVS,NGPBLKS) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PGMVT1S(NPROMA,YT1%NDIMS,NGPBLKS) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PGFL(NPROMA,NFLEVG,YGFL%NDIM,NGPBLKS) 
REAL(KIND=JPRB)   ,INTENT(INOUT) :: PGFLT1(NPROMA,NFLEVG,YGFL%NDIM1,NGPBLKS) 

! Local variables

INTEGER(KIND=JPIM) :: IST, IEND, JLEV , JGFL
REAL(KIND=JPRB) :: ZPRE9(NPROMA,0:NFLEVG),ZPRE1(NPROMA,0:NFLEVG)

REAL(KIND=JPRB) :: ZSPT1(NPROMA),ZSPT9(NPROMA)

REAL(KIND=JPRB) :: ZFIELD3DT1(NPROMA,NFLEVG),ZFIELD3DT0(NPROMA,NFLEVG)
REAL(KIND=JPRB) :: ZFIELD2DT1(NPROMA,0:NFLEVG),ZFIELD2DT0(NPROMA,0:NFLEVG)

REAL(KIND=JPRB) :: ZFIELD1D(NPROMA,2,NGPBLKS) ,ZNORMS(3,2), ZBETA(NPROMA,NFLEVG,NGPBLKS), ZBETA_SUM(1) 

INTEGER(KIND=JPIM) :: IBL,ICEND,JKGLO,JROF

INTEGER(KIND=JPIM) :: JLEV1, JLEV2, JL, JSP, IGFLC
REAL(KIND=JPRB)    :: ZMASSD, ZMASSCOR, ZSCALE 
REAL(KIND=JPRB)    :: ZPRES1(NPROMA,0:NFLEVG,NGPBLKS), ZPRES9(NPROMA,0:NFLEVG,NGPBLKS) 
REAL(KIND=JPRB)    :: ZSP(NFLSUR,NSPEC2)
REAL(KIND=JPRB)    :: ZGP(NGPTOT,NFLEVG)
REAL(KIND=JPRB)    :: ZPRE1DT(NPROMA,2,NGPBLKS), ZPRENORMS(3,2), ZPSCOR

REAL(KIND=JPRB) :: ZHOOK_HANDLE

LOGICAL :: LTRCMFP, LCHEM_DIA, LTRCMFA_LAP, LTRCMFA_VER, LTRCMFA_DIF, LTRCMFA_DIA

INTERFACE
#include "dist_grid.h"
#include "gath_grid.h"
END INTERFACE

#include "gpnorm1.intfb.h"
#include "gppwc.intfb.h"
#include "gppreh.intfb.h"

#include "speree.intfb.h"
#include "reespe.intfb.h"

IF (LHOOK) CALL DR_HOOK('TRACMF',0,ZHOOK_HANDLE)

!! mass fixer type
LTRCMFP=.TRUE.  ! proportional 
LTRCMFA_LAP=.FALSE.  ! additive based on hor. Laplace
LTRCMFA_VER=.FALSE.  ! additive based on vert. Lapace
LTRCMFA_DIF=.FALSE.   ! additiva based on abs gradient
LTRCMFA_DIA=.FALSE.   ! diagnostics

!!SMASSCOR(:)=0.0_JPRB
IGFLC=0

! calculate pressure on interface for t & t + 1
DO JKGLO=1,NGPTOT,NPROMA
     ICEND=MIN(NPROMA,NGPTOT-JKGLO+1)
     IBL=(JKGLO-1)/NPROMA+1
     IST=1
     IEND=ICEND
! caluclation of the pressures  
  DO JROF=IST,IEND
        ZSPT9(JROF)=PGMVS(JROF,YPH9%MSP,IBL)
        ZPRE9 (JROF,NFLEVG) = EXP(ZSPT9(JROF))
        ZSPT1(JROF)=PGMVT1S(JROF,YT1%MSP,IBL)
        ZPRE1 (JROF,NFLEVG) = EXP(ZSPT1(JROF))
        ZPRE1DT(JROF,1,IBL)=ZPRE9(JROF,NFLEVG)
        ZPRE1DT(JROF,2,IBL)=ZPRE1(JROF,NFLEVG)
   ENDDO

   CALL GPPREH(NPROMA,IST,IEND,NFLEVG, VAH,VBH,ZPRE9)
   CALL GPPREH(NPROMA,IST,IEND,NFLEVG, VAH,VBH,ZPRE1)

   DO JLEV=0,NFLEVG
     DO JROF=IST,IEND
       ZPRES9(JROF,JLEV,IBL) = ZPRE9(JROF,JLEV)
       ZPRES1(JROF,JLEV,IBL) = ZPRE1(JROF,JLEV)
     ENDDO
  ENDDO 
ENDDO

! change surface pressure for t+1 to match integral  
IF (LTRCMFIX_PS ) THEN 
! mean surface pressure global fixer
! is it better to use the mass of the t=0 or from the start of the forecast
   CALL GPNORM1(ZPRE1DT,2,.FALSE.,PNORMS=ZPRENORMS)
   ZPSCOR=ZPRENORMS(1,1)/ZPRENORMS(1,2)

! re-calculate pressure for mass calculation at t + 1 
  DO JKGLO=1,NGPTOT,NPROMA
     ICEND=MIN(NPROMA,NGPTOT-JKGLO+1)
     IBL=(JKGLO-1)/NPROMA+1
     IST=1
     IEND=ICEND
      DO JROF=IST,IEND
        ZSPT1(JROF)=PGMVT1S(JROF,YT1%MSP,IBL)  
        ZPRE1 (JROF,NFLEVG) = EXP(ZSPT1(JROF)) * ZPSCOR
      ENDDO

      CALL GPPREH(NPROMA,IST,IEND,NFLEVG, VAH,VBH,ZPRE1)
      DO JLEV=0,NFLEVG
        DO JROF=IST,IEND
          ZPRES1(JROF,JLEV,IBL) = ZPRE1(JROF,JLEV)
        ENDDO
      ENDDO
   ENDDO
ENDIF
! end pressure fix         

! FIELD3DT0 AND FIELD3DT1 ARE RESP. THE FIELDS BEFORE AND AFTER ADVECTION
DO JGFL=1,YGFL%NUMFLDS

! apply correction if flag is set 
  IF ( YGFLC(JGFL)%LMASSFIX .AND. YGFLC(JGFL)%LADV ) THEN
! calculate total mass befoe and after advection
    DO JKGLO=1,NGPTOT,NPROMA
      ICEND=MIN(NPROMA,NGPTOT-JKGLO+1)
      IBL=(JKGLO-1)/NPROMA+1
      IST=1
      IEND=ICEND
      DO JLEV=1,NFLEVG
        DO JROF=IST,IEND
          ZFIELD3DT0(JROF,JLEV)=PGFL(JROF,JLEV,YGFLC(JGFL)%MP,IBL)
          ZFIELD3DT1(JROF,JLEV)=PGFLT1(JROF,JLEV,YGFLC(JGFL)%MP1,IBL)
          ZPRE9 (JROF,JLEV) =  ZPRES9(JROF,JLEV,IBL) 
          ZPRE1 (JROF,JLEV) =  ZPRES1(JROF,JLEV,IBL)
        ENDDO
      ENDDO

      CALL GPPWC(NPROMA,IST,IEND,NFLEVG,ZFIELD2DT0,ZFIELD3DT0,ZPRE9)
      CALL GPPWC(NPROMA,IST,IEND,NFLEVG,ZFIELD2DT1,ZFIELD3DT1,ZPRE1)

      DO JROF=IST,IEND
        ZFIELD1D(JROF,1,IBL)=ZFIELD2DT0(JROF,NFLEVG)
        ZFIELD1D(JROF,2,IBL)=ZFIELD2DT1(JROF,NFLEVG)
      ENDDO
   ENDDO 

! norms are broadcast already if PNORMS=ZNORMS specified
     CALL GPNORM1(ZFIELD1D,2,.FALSE.,PNORMS=ZNORMS)
    
     ZMASSCOR = (ZNORMS(1,1)-ZNORMS(1,2))  
    
    IF (LCHEM_DIA) THEN
      IGFLC=IGFLC+1 
 !  store mass change for budget in CHEM_massdia - note that is still kg/m2
!      SMASSCOR(IGFLC) = ZMASSCOR  
    ENDIF

! Calculate corrected Concentrations PGFLT1    

!  global proportional mass fixer 
      IF ( LTRCMFP ) THEN
       IF( ZNORMS(1,2) > 0.0_JPRB) THEN 
         ZSCALE= ZNORMS(1,1)/ZNORMS(1,2) 
         DO JKGLO=1,NGPTOT,NPROMA
          ICEND=MIN(NPROMA,NGPTOT-JKGLO+1)
          IBL=(JKGLO-1)/NPROMA+1
          IST=1
          IEND=ICEND
          DO JLEV=1,NFLEVG
            DO JROF=IST,IEND
             PGFLT1(JROF,JLEV,YGFLC(JGFL)%MP1,IBL)=PGFLT1(JROF,JLEV,YGFLC(JGFL)%MP1,IBL) * ZSCALE 
            ENDDO
          ENDDO   
         ENDDO
        ENDIF
      ENDIF


!    local additive mass fixer based on error measure ZBETA  
  IF ( LTRCMFA_DIF .OR. LTRCMFA_LAP .OR. LTRCMFA_VER ) THEN

! calculation of weight zbeta for the additive MF
   ZBETA_SUM(1)=0.0_JPRB

! MF based on square of laplace
    IF ( LTRCMFA_LAP ) THEN
      DO JKGLO=1,NGPTOT,NPROMA
        ICEND=MIN(NPROMA,NGPTOT-JKGLO+1)
        IBL=(JKGLO-1)/NPROMA+1
        IST=1
        IEND=ICEND
        DO JLEV=1,NFLEVG
          DO JROF=IST,IEND
            ZGP(JROF+JKGLO-1,JLEV) = PGFLT1(JROF,JLEV,YGFLC(JGFL)%MP1,IBL)
          ENDDO
        ENDDO
       ENDDO   

! calculate horizontal laplace
! for efficency this should be done for all species at once i.e. for NFLEVG*NCHEM
       CALL REESPE(NFLSUR,NFLEVG,ZSP,ZGP)

! calculate horizontal laplacian in spectral space
       DO JSP=1,NSPEC2
         DO JL=1,NFLSUR
           ZSP(JL,JSP) = RLAPDI( NVALUE(JSP) ) *  ZSP(JL,JSP) 
         ENDDO
      ENDDO
! transfer in gp space
      CALL SPEREE(NFLSUR,NFLEVG,ZSP,ZGP)

! calculate beta - without weight  
      DO JKGLO=1,NGPTOT,NPROMA
        ICEND=MIN(NPROMA,NGPTOT-JKGLO+1)
        IBL=(JKGLO-1)/NPROMA+1
        IST=1
        IEND=ICEND
         DO JLEV=1,NFLEVG
              DO JROF=IST,IEND
                ZBETA(JROF,JLEV,IBL) = ZGP(JROF+JKGLO-1,JLEV) * ZGP(JROF+JKGLO-1,JLEV) 
              ENDDO
           ENDDO
        ENDDO
     ENDIF

! zsed on abs(gradient)
     IF ( LTRCMFA_DIF ) THEN     
       DO JKGLO=1,NGPTOT,NPROMA
        ICEND=MIN(NPROMA,NGPTOT-JKGLO+1)
        IBL=(JKGLO-1)/NPROMA+1
        IST=1
        IEND=ICEND
! set error measure ZBETA 
           DO JLEV=1,NFLEVG
              DO JROF=IST,IEND
! define ZBETA: difference between t and t+1 is used as a measure for "error"
                ZBETA(JROF,JLEV,IBL) = ABS(PGFL(JROF,JLEV,YGFLC(JGFL)%MP,IBL) - PGFLT1(JROF,JLEV,YGFLC(JGFL)%MP1,IBL))
              ENDDO
           ENDDO
         ENDDO   
      ENDIF

      IF ( LTRCMFA_VER ) THEN     
        DO JKGLO=1,NGPTOT,NPROMA
        ICEND=MIN(NPROMA,NGPTOT-JKGLO+1)
        IBL=(JKGLO-1)/NPROMA+1
        IST=1
        IEND=ICEND
! set error measure ZBETA 
         DO JLEV=1,NFLEVG
           JLEV1 = MAX(JLEV-1,1)
           JLEV2 = MiN(JLEV+1,NFLEVG)
           DO JROF=IST,IEND
! define ZBETA: vertical laplacian square
             ZBETA(JROF,JLEV,IBL) =  ( PGFLT1(JROF,JLEV1,YGFLC(JGFL)%MP1,IBL) - 2.0_JPRB * PGFLT1(JROF,JLEV,YGFLC(JGFL)%MP1,IBL) & 
         &      +  PGFLT1(JROF,JLEV2,YGFLC(JGFL)%MP1,IBL)) / &
         &      ( (ZPRES9(JROF,JLEV-1,IBL) -  ZPRES9(JROF,JLEV,IBL)) * (ZPRES9(JROF,JLEV-1,IBL) -  ZPRES9(JROF,JLEV,IBL))    ) 
                ZBETA(JROF,JLEV,IBL) = ZBETA(JROF,JLEV,IBL) * ZBETA(JROF,JLEV,IBL) 
              ENDDO
            ENDDO
         ENDDO   
      ENDIF

! scale zbeta with grid box volume and sum up for norm
       DO JKGLO=1,NGPTOT,NPROMA
        ICEND=MIN(NPROMA,NGPTOT-JKGLO+1)
        IBL=(JKGLO-1)/NPROMA+1
        IST=1
        IEND=ICEND
! set error measure ZBETA 
           DO JLEV=1,NFLEVG
              DO JROF=IST,IEND
! account for gird box size
                ZBETA(JROF,JLEV,IBL) = ZBETA(JROF,JLEV,IBL)  * ABS (  GAW(JKGLO-1+JROF) & 
 &              * (ZPRES9(JROF,JLEV,IBL) -  ZPRES9(JROF,JLEV-1,IBL)) ) 
                ZBETA_SUM(1) = ZBETA_SUM(1) +  ZBETA(JROF,JLEV,IBL) 
              ENDDO
           ENDDO
         ENDDO   
! gather global sum  
!    this might be costly , try to have two loops over NCHEM and stor array of ZBETA_SUM(NCHEM)   
       CALL MPL_ALLREDUCE( ZBETA_SUM,'sum',LDREPROD=.FALSE.,CDSTRING='TRACMF')    

       IF (  ZBETA_SUM(1) > 0.0_JPRB ) THEN

        DO JKGLO=1,NGPTOT,NPROMA
          ICEND=MIN(NPROMA,NGPTOT-JKGLO+1)
          IBL=(JKGLO-1)/NPROMA+1
          IST=1
          IEND=ICEND
            DO JLEV=1,NFLEVG
              DO JROF=IST,IEND
               ! air mass density in kg/m2 
               ZMASSD = (( ZPRES9(JROF,JLEV,IBL) - ZPRES9(JROF,JLEV-1,IBL)) / RG ) *  GAW(JKGLO-1+JROF)  
               PGFLT1(JROF,JLEV,YGFLC(JGFL)%MP1,IBL) = PGFLT1(JROF,JLEV,YGFLC(JGFL)%MP1,IBL) + & 
 &                           ( ZBETA(JROF,JLEV,IBL) / ZBETA_SUM(1)) * ZMASSCOR / ZMASSD 

              ENDDO
            ENDDO 
          ENDDO

        ENDIF 

      ENDIF ! additiva mass fixer
  ENDIF     ! LMASSFIX 
 
ENDDO ! loop JGFL

!* END PART FOR TRACER MASS FIXER

IF (LHOOK) CALL DR_HOOK('TRACMF',1,ZHOOK_HANDLE)
END SUBROUTINE TRACMF
