SUBROUTINE CORMASS2
USE PARKIND1  ,ONLY : JPIM     ,JPRB
USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK

USE YOMLUN   , ONLY : NULOUT   
USE YOMDIM   , ONLY : NDGLG     ,NFLEVG   ,&
 & NSPEC2 
USE YOMGEM   , ONLY : VBH      ,VAH      ,NGPTOT   ,NGPTOTG  ,&
 & NLOENG  
USE YOMSP    , ONLY :     SPSP     ,SPQ
USE YOMLEG   , ONLY : RW
USE YOMGC    , ONLY : GM

USE YOMMP    , ONLY : MYPROC   ,MY_REGION_NS   ,MY_REGION_EW   ,NONL     ,&
 & NLSTLAT  ,NPTRFLOFF,NFRSTLOFF,MYLATS    

!**** *CORMASS2*  - COMPUTE THE MASS CORRECTION FOR LONG CLIMATIC RUNS 

!     Purpose.
!     --------
!     This program computes the change in dry surface pressure
!     to maintain a constant global mean

!**   Interface.
!     ----------
!        *CALL* *CORMASS2

!        Explicit arguments :     NONE
!        --------------------

!        Implicit arguments :     NONE
!        --------------------

!     Method.
!     -------
!     - Go to grid point space (SPEREE) ;
!     -   Compute the total vapor water field (Pvap),
!         then the dry-air surface pressure field (Pdry = P - Pvap)
!     -   Uniformally apply the dry-air mass correction to the surface 
!         pressure field.
!     - Go back to spectral  space (REESPE) ;
!     Externals.
!     ----------

!     Reference.
!     ----------
!        CLIMAT-ARPEGE documentation (Meteo-France, CNRM/GMGEC/EAC)

!     Author.
!     -------
!        Jean Philippe Piedelievre and Michel Deque
!          (from CORMASS written by Pascal Marquet)  *Meteo-France*

!     Modifications.
!     --------------
!        Original : 05-02-04
!        M.Hamrud      01-Oct-2003 CY28 Cleaning
!        A.Alias       26-Oct-2006 MYSETA/MYSETB replaced by
!                                  MY_REGION_NS/MY_REGION_EW
!     Apr 2008  K. Yessad: use DISGRID instead of DISGRID_C + cleanings
!     ------------------------------------------------------------------

IMPLICIT NONE

REAL(KIND=JPRB):: ZSPS (NSPEC2),  ZSPQ  (NSPEC2)
REAL(KIND=JPRB):: ZREE  (NGPTOT)
REAL(KIND=JPRB):: ZRW   (NGPTOT)
REAL(KIND=JPRB):: ZPSF  (NGPTOT)
REAL(KIND=JPRB):: ZPVF  (NGPTOT)
REAL(KIND=JPRB):: ZDPF  (NGPTOT)
REAL(KIND=JPRB):: ZPDRYF(NGPTOT)

REAL(KIND=JPRB):: ZRWG   (NGPTOTG), ZNLG   (NGPTOTG), ZGMG (NGPTOTG)
REAL(KIND=JPRB):: ZPSFG  (NGPTOTG)
REAL(KIND=JPRB):: ZPDRYFG(NGPTOTG)

INTEGER(KIND=JPIM)::   &
 & IGLG,IOPROC,IFLD,JGL,JLEV,JLON,&
 & JROF, IROF  

REAL(KIND=JPRB)::   ZAPCORM, ZAPDRYF, ZAPDRYI,&
 & ZAPSF, ZDA,&
 & ZDB, ZZNEW, ZWEIG  
REAL(KIND=JPRB) :: ZHOOK_HANDLE

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

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

!     ------------------------------------------------------------------
IF (LHOOK) CALL DR_HOOK('CORMASS2',0,ZHOOK_HANDLE)
!     ------------------------------------------------------------------

!*       1.    START OF ROUTINE.
!              -----------------

!*       1.1   INITIALISISATIONS
!               - - - - - - - - 
WRITE(NULOUT,*) ' '
WRITE(NULOUT,*) '    ====================================== '
WRITE(NULOUT,*) '    =======  ENTRANCE IN CORMASS2 ======== '
WRITE(NULOUT,*) '    ====================================== '
WRITE(NULOUT,*) ' '

! IMPOSED DRY AIR MASS (PA)  
ZAPDRYI=98320.00000000_JPRB

IOPROC=1 

IFLD=0

! One proc for IO

!     ------------------------------------------------------------------
!*       3.    COMPUTE THE TOTAL MASS OF WATER VAPOR.  (see SUSPECA*)
!              ------------------------------------------------------

WRITE(NULOUT,*) '  '
WRITE(NULOUT,*) ' COMPUTE THE TOTAL WATER VAPOR MASS '

ZSPS(1:NSPEC2)=SPSP(1:NSPEC2)
CALL SPEREE(1,1,ZSPS,ZPSF)
ZPSF=EXP(ZPSF)
ZPVF= 0.0_JPRB
DO JLEV=1,NFLEVG

!        *** Compute pressure difference accross layers *** 

  ZDA=VAH(JLEV)-VAH(JLEV-1)
  ZDB=VBH(JLEV)-VBH(JLEV-1)
  DO JROF=1,NGPTOT
    ZDPF(JROF)=ZDA+ZDB*ZPSF(JROF)
  ENDDO

  ZSPQ(1:NSPEC2)=SPQ(JLEV,1:NSPEC2)
  CALL SPEREE(1,1,ZSPQ,ZREE)

  DO JROF=1,NGPTOT
    ZPVF(JROF) = ZPVF(JROF) + ZREE(JROF)*ZDPF(JROF)
  ENDDO

ENDDO !JLEV
DO JROF=1,NGPTOT
  ZPDRYF(JROF) = ZPSF(JROF) -  ZPVF(JROF)
ENDDO
WRITE (NULOUT,*)ZPDRYF(1),ZPSF(1)

!     ------------------------------------------------------------------
!*       5.    COMPUTE AVERAGE CORRECTION OF MASS. (see ZODIGI, ZODIA)
!      -------------------------------------------------------

! Local version of RW

IROF=0
DO JGL=1,NLSTLAT(MY_REGION_NS)-NFRSTLOFF
  IGLG=MYLATS(JGL)
  DO JLON=1,NONL(NPTRFLOFF+JGL,MY_REGION_EW)
    IROF=IROF+1
    ZRW(IROF)=RW(IGLG)
  ENDDO
ENDDO

IF (MYPROC == IOPROC) THEN

  WRITE(NULOUT,*) ' COMPUTE AVERAGE CORRECTION OF MASS '

! Global

  ZAPSF  = 0.0_JPRB
  ZAPDRYF= 0.0_JPRB

! Receive

  IFLD=IFLD+1
  ZPSFG(1:NGPTOT)=ZPSF
  CALL DIWRGRID (IOPROC,IFLD,1,NGPTOTG,ZPSFG)  
  IFLD=IFLD+1
  ZPDRYFG(1:NGPTOT)=ZPDRYF
  CALL DIWRGRID (IOPROC,IFLD,1,NGPTOTG,ZPDRYFG)  
  IFLD=IFLD+1
  ZRWG(1:NGPTOT)=ZRW
  CALL DIWRGRID (IOPROC,IFLD,1,NGPTOTG,ZRWG)
  IFLD=IFLD+1
  ZGMG(1:NGPTOT)=GM
  CALL DIWRGRID (IOPROC,IFLD,1,NGPTOTG,ZGMG)

  IROF=0
  DO JGL=1,NDGLG
    DO JLON=1,NLOENG(JGL)
      IROF=IROF+1
      ZNLG(IROF)=REAL(NLOENG(JGL),JPRB)
    ENDDO
  ENDDO

  DO JROF=1,NGPTOTG
    ZWEIG=ZRWG(JROF)/ZGMG(JROF)**2/ZNLG(JROF)
    ZAPSF  =ZAPSF   +   ZPSFG(JROF)*ZWEIG
    ZAPDRYF=ZAPDRYF + ZPDRYFG(JROF)*ZWEIG
  ENDDO

  ZAPCORM = - ZAPDRYF + ZAPDRYI
  ZZNEW   =   ZAPSF   + ZAPCORM

  WRITE (NULOUT,*) '  '
  WRITE (NULOUT,'(1X,'' MEAN IMPO. DRY PRESSURE '',f19.8)') ZAPDRYI
  WRITE (NULOUT,'(1X,'' MEAN FINAL DRY PRESSURE '',f19.8)') ZAPDRYF
  WRITE (NULOUT,*) '  '
  WRITE (NULOUT,'(1X,'' OLD MEAN FINAL TOT PRES '',f19.8)') ZAPSF
  WRITE (NULOUT,'(1X,'' MEAN CORR. OF  DRY PRES '',f19.8)') ZAPCORM
  WRITE (NULOUT,'(1X,'' NEW MEAN FINAL TOT PRES '',f19.8)') ZZNEW
  WRITE (NULOUT,*) '  '

!     ------------------------------------------------------------------
!*       6.    MAKE THE CORRECTION OF MASS AND WRITE ON *FA* FINAL FILE.
!              ---------------------------------------------------------

  DO JROF=1,NGPTOTG
    ZPSFG(JROF)=LOG(ZPSFG(JROF)+ZAPCORM)
  ENDDO

! Send

  IFLD=IFLD+1
  ZPSF=ZPSFG(1:NGPTOT)
  CALL DISGRID(IFLD,0,NGPTOTG,ZPSFG,LDC=.TRUE.,KIOPROC=IOPROC)
  
ELSE

! Send

  IFLD=IFLD+1
  CALL DIWRGRID (IOPROC,IFLD,0,NGPTOT,ZPSF)  
  IFLD=IFLD+1
  CALL DIWRGRID (IOPROC,IFLD,0,NGPTOT,ZPDRYF)
  IFLD=IFLD+1
  CALL DIWRGRID (IOPROC,IFLD,0,NGPTOT,ZRW)
  IFLD=IFLD+1
  CALL DIWRGRID (IOPROC,IFLD,0,NGPTOT,GM)

! Receive

  IFLD=IFLD+1
  CALL DISGRID(IFLD,1,NGPTOT,ZPSF,LDC=.TRUE.,KIOPROC=IOPROC)

ENDIF ! IOPROC

! Go back to spectral space

CALL REESPE(1,1,ZSPS,ZPSF)
SPSP(1:NSPEC2)=ZSPS(1:NSPEC2)

WRITE(NULOUT,*) ' '
WRITE(NULOUT,*) '    ====================================== '
WRITE(NULOUT,*) '    ==========  END OF CORMASS2  ========= '
WRITE(NULOUT,*) '    ====================================== '
WRITE(NULOUT,*) ' '
WRITE(NULOUT,*) ' '

!     ------------------------------------------------------------------
IF (LHOOK) CALL DR_HOOK('CORMASS2',1,ZHOOK_HANDLE)
END SUBROUTINE CORMASS2
