SUBROUTINE CORMASS

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

USE YOMLUN   , ONLY : NULOUT   ,NTRJSH   ,NINISH
USE YOMCT0   , ONLY : CNMEXP   ,NSTOP
USE YOMCT1   , ONLY : LRFILAF
USE YOMCT3   , ONLY : NSTEP
USE YOMDIM   , ONLY : NDGLG    ,NFLEVG   ,NSEFRE   ,&
 & NSPEC2   ,NS3D     ,NS2D  
USE YOMLAP   , ONLY : NASM0
USE YOMGEM   , ONLY : NLOEN    ,NSTAGP   ,VBH      ,VAH      ,NGPTOT
USE YOMLEG   , ONLY : RW
USE YOMGC    , ONLY : GM

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

!     Purpose.
!     --------
!     This program computes the change in dry surface pressure
!     between two *FA* files at two different times. A uniform 
!     correction is apply to the second *FA* files in order to
!     keep the dry-air total mass constant : it becomes a new
!     starting files which is used for a new step of long 
!     climatic runs.

!**   Interface.
!     ----------
!        *CALL* *CORMASS

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

!        Implicit arguments :     Two names of field
!        --------------------

!     Method.
!     -------
!     - Open the initial and final *FA* history files 
!     - Extract surface pressure and upper-air specific humidity
!       spectral fields from the *FA1* and *FA2* (t2>t1) history files ;
!     - Go to grid point space (SPEREE) ;
!     -   Compute the total vapor water fields for the two files (Pvap),
!         then the dry-air surface pressure fields (Pdry = P - Pvap) for
!         the two files also ;
!     -   Uniformally apply the dry-air mass correction to the surface 
!         pressure field of the *FA2* files in order to cancel out the
!         mass tendency. Delta = (Pdry)2 - (Pdry)1  and the correction 
!         is : (P)2-new = (P)2-old - Delta.
!     - Go back to spectral  space (REESPE) ;
!     - Write the new surface pressure field on the *FA2* files.
!     - Close the initial and final *FA* history files 

!     Externals.
!     ----------
!          FAITOU
!          FADIES
!          FACILE
!          FAIRME

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

!     Author.
!     -------
!        Pascal MARQUET  *Meteo-France*

!     Modifications.
!     --------------
!        Original : 95-11-09
!        Modified : 96-05-29 M.Deque  P.Marquet (phasing to cycle 15)
!        98-03-17  R. El Khatib    SPREORD
!        Modified 98-08-10 by K. YESSAD: removal of LRPOLE option.
!         - removal of '.FALSE.' in 'CALL SPEREE'.
!        R. El Khatib : 01-08-07 Pruning options
!        M.Hamrud      01-Oct-2003 CY28 Cleaning
!      D. Paradis & R. El Khatib : 04-07-22 GRIBEX
!        R. El Khatib : 23-Oct-2008 use suofname
!     ------------------------------------------------------------------

IMPLICIT NONE

INTEGER(KIND=JPIM) ::   IDATEF(11)
CHARACTER :: CLLECI*16,  CLLECF*16
CHARACTER :: CLFNISH*16, CLFNSH*210
INTEGER(KIND=JPIM) ::   INLOPA(500),INOZPA(500)
REAL(KIND=JPRB) ::      ZSINLA(500),ZAHYBR(100),ZBHYBR(100)

REAL(KIND=JPRB) :: Z_PSPSPI(NSPEC2), Z_PSPSPF(NSPEC2)
REAL(KIND=JPRB) :: ZSPEC (NSPEC2), ZSPQ  (NSPEC2)

REAL(KIND=JPRB) :: ZREE  (NGPTOT)
REAL(KIND=JPRB) :: ZPSI  (NGPTOT), ZPSF  (NGPTOT)
REAL(KIND=JPRB) :: ZPVI  (NGPTOT), ZPVF  (NGPTOT)
REAL(KIND=JPRB) :: ZDPI  (NGPTOT), ZDPF  (NGPTOT)
REAL(KIND=JPRB) :: ZPDRYI(NGPTOT), ZPDRYF(NGPTOT)

INTEGER(KIND=JPIM) :: INBARI, INBARP, INIMES, INIVER,&
 & INLATI, INXLON, IOS, IREP, &
 & ITRONC, ITYPTR, JGL, JLEV, JLON
INTEGER(KIND=JPIM) :: INGRIB, INBITS, ISTRON, IPUILA,IDMOPL, INBCSP, INBPDG

LOGICAL :: LLEXIST, LLF, LLFICP, LLOPNED, LLT, LLTEST
LOGICAL :: LLCOSP

REAL(KIND=JPRB) :: ZALPSF, ZALPSI, ZAPCORM, ZAPDRYF, ZAPDRYI,&
 & ZAPSF, ZAPSI, ZAUN, ZCLOPO, ZCODIL, ZDA, &
 & ZDB, ZEPS2, ZREFER, ZSLAPO, ZSLOPO, ZZLPSF, &
 & ZZLPSI, ZZNEW  
REAL(KIND=JPRB) :: ZHOOK_HANDLE

#include "abor1.intfb.h"
#include "reespe.intfb.h"
#include "speree.intfb.h"
#include "spreord.intfb.h"
#include "suofname.intfb.h"

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

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

!*       1.1   INITIALISISATIONS
!               - - - - - - - - 
IF (LHOOK) CALL DR_HOOK('CORMASS',0,ZHOOK_HANDLE)
WRITE(NULOUT,*) ' '
WRITE(NULOUT,*) ' '
WRITE(NULOUT,*) '    ====================================== '
WRITE(NULOUT,*) '    =======  ENTRANCE IN CORMASS  ======== '
WRITE(NULOUT,*) '    ====================================== '
WRITE(NULOUT,*) ' '
NSTEP=NSTOP
LLT=.TRUE.
LLF=.FALSE.
IREP=0
INIMES=1
INBARP = NFLEVG * NS3D + NS2D
INBARI=0
IOS=0
LLEXIST=.FALSE.
LLOPNED=.FALSE.
CLLECI='CADRE LECTURE I'
CLLECF='CADRE LECTURE F'
INXLON=0
INLATI=0

!*       1.2   OPEN INITIAL TRAJECTORY FILE. (see UPDTIDE or WRSFP)
!               - - - - - - - - - - - - - - - - - - - - - - - - - 
CLFNISH='ICMSH'//CNMEXP(1:4)//'INIT'
INQUIRE(FILE=CLFNISH, IOSTAT=IOS, EXIST=LLEXIST, OPENED=LLOPNED)
IF (IOS == 0) THEN
  IF (LLEXIST) THEN
    IF (.NOT.LLOPNED) THEN
      CALL FAITOU(IREP,NINISH,.TRUE.,CLFNISH,'OLD',.TRUE.,&
       & .TRUE.,INIMES,INBARP,INBARI,CLLECI)  
    ELSE
      CALL FAIRME(IREP,NINISH,'UNKNOWN')
      CALL FAITOU(IREP,NINISH,.TRUE.,CLFNISH,'OLD',.TRUE.,&
       & .TRUE.,INIMES,INBARP,INBARI,CLLECI)  
    ENDIF
    CALL LFIMST(IREP,NINISH,.FALSE.)
    IF (LRFILAF) CALL LFILAF(IREP,NINISH,.FALSE.)
    CALL FADIES(IREP,NINISH,IDATEF)
    WRITE (NULOUT,'(1X,'' '')')
    WRITE (NULOUT,'(1X,'' INITIAL FILE : '')')
    WRITE (NULOUT,'(1X,'' YEAR     : '',I4,''  '')') IDATEF(1)
    WRITE (NULOUT,'(1X,'' MONTH    : '',I4,''  '')') IDATEF(2)
    WRITE (NULOUT,'(1X,'' DAY      : '',I4,''  '')') IDATEF(3)
    WRITE (NULOUT,'(1X,'' HOUR     : '',I4,'' h'')') IDATEF(4)
    WRITE (NULOUT,'(1X,'' SECOND   : '',I4,'' s'')') IDATEF(5)
    WRITE (NULOUT,'(1X,'' FORECAST : '',I4,'' h'')') IDATEF(7)
    WRITE (NULOUT,'(1X,'' '')')
  ELSE
    CALL ABOR1('NINISH FILE DOES NOT EXIST (IN CORMASS)')
  ENDIF
ELSE
  CALL ABOR1('ERROR IN INQUIRING NINISH FILE (IN CORMASS)')
ENDIF

!*       1.3   OPEN FINAL TRAJECTORY FILE
!              -------------------------- 

CALL SUOFNAME(KSTEP=NSTEP,CDLABEL='ICMSH',CDOFNAME=CLFNSH)

INQUIRE(FILE=CLFNSH, IOSTAT=IOS, EXIST=LLEXIST, OPENED=LLOPNED)
IF (IOS == 0) THEN
  IF (LLEXIST) THEN
    IF (.NOT.LLOPNED) THEN
      CALL FAITOU(IREP,NTRJSH,.TRUE.,CLFNSH,'OLD',.TRUE.,&
       & .TRUE.,INIMES,INBARP,INBARI,CLLECF)  
    ELSE
      CALL FAIRME(IREP,NTRJSH,'UNKNOWN')
      CALL FAITOU(IREP,NTRJSH,.TRUE.,CLFNSH,'OLD',.TRUE.,&
       & .TRUE.,INIMES,INBARP,INBARI,CLLECF)  
    ENDIF
    CALL LFIMST(IREP,NTRJSH,.FALSE.)
    IF (LRFILAF) CALL LFILAF(IREP,NTRJSH,.FALSE.)
    CALL FADIES(IREP,NTRJSH,IDATEF)
    WRITE (NULOUT,'(1X,'' '')')
    WRITE (NULOUT,'(1X,'' FINAL FILE : '')')
    WRITE (NULOUT,'(1X,'' YEAR     : '',I4,''  '')') IDATEF(1)
    WRITE (NULOUT,'(1X,'' MONTH    : '',I4,''  '')') IDATEF(2)
    WRITE (NULOUT,'(1X,'' DAY      : '',I4,''  '')') IDATEF(3)
    WRITE (NULOUT,'(1X,'' HOUR     : '',I4,'' h'')') IDATEF(4)
    WRITE (NULOUT,'(1X,'' SECOND   : '',I4,'' s'')') IDATEF(5)
    WRITE (NULOUT,'(1X,'' FORECAST : '',I4,'' h'')') IDATEF(7)
    WRITE (NULOUT,'(1X,'' '')')
  ELSE
    CALL ABOR1('NTRJSH FILE DOES NOT EXIST (IN CORMASS)')
  ENDIF
ELSE
  CALL ABOR1('ERROR IN INQUIRING NTRJSH FILE (IN CORMASS)')
ENDIF

!*       1.4   CHECK THE INITIAL TRAJECTORY FILE.  (see CPREP3)
!               - - - - - - - - - - - - - - - - - - - - - - -
WRITE(NULOUT,*) ' CHECK INITIAL FILE :  '

CALL FACIES(CLLECI,ITYPTR,ZSLAPO,ZCLOPO,ZSLOPO,ZCODIL,ITRONC,&
 & INLATI,INXLON,INLOPA,INOZPA,ZSINLA,INIVER,ZREFER,ZAHYBR,&
 & ZBHYBR,.FALSE.)  

ZEPS2=1.E-10_JPRB
IF (INLOPA(1) /= INXLON) THEN
  IF(INLOPA(1) == 16) THEN
    WRITE(NULOUT,*) '   FILE HAS REDUCED GRID '
  ELSE
    WRITE(NULOUT,*) '   FILE HAS REDUCED GRID - ECMWF'
  ENDIF
ELSE
  WRITE(NULOUT,*)    '   FILE HAS COMPLETE GRID '
ENDIF
IF (ZSINLA(1) > 1.0_JPRB-ZEPS2) THEN
  LLFICP=.TRUE.
  WRITE(NULOUT,*)    '   FILE CONTAINS POLES '
ELSE
  LLFICP=.FALSE.
  WRITE(NULOUT,*)    '   FILE DOES NOT CONTAIN POLES '
ENDIF
IF (LLFICP.AND.INLATI /= NDGLG+2) THEN
  CALL ABOR1('INTERNAL FILE INCONSISTENCY ')
ELSEIF (.NOT.LLFICP.AND.INLATI /= NDGLG) THEN
  CALL ABOR1('INTERNAL FILE INCONSISTENCY ')
ENDIF

!*       1.5   CHECK THE FINAL TRAJECTORY FILE.  (see CPREP2)
!               - - - - - - - - - - - - - - - - - - - - - - 
WRITE(NULOUT,*) ' CHECK FINAL FILE :  '

CALL FACIES(CLLECF,ITYPTR,ZSLAPO,ZCLOPO,ZSLOPO,ZCODIL,ITRONC,&
 & INLATI,INXLON,INLOPA,INOZPA,ZSINLA,INIVER,ZREFER,ZAHYBR,&
 & ZBHYBR,.FALSE.)  

ZEPS2=1.E-10_JPRB
IF (INLOPA(1) /= INXLON) THEN
  IF(INLOPA(1) == 16) THEN
    WRITE(NULOUT,*) '   FILE HAS REDUCED GRID '
  ELSE
    WRITE(NULOUT,*) '   FILE HAS REDUCED GRID - ECMWF'
  ENDIF
ELSE
  WRITE(NULOUT,*)    '   FILE HAS COMPLETE GRID '
ENDIF
IF (ZSINLA(1) > 1.0_JPRB-ZEPS2) THEN
  LLFICP=.TRUE.
  WRITE(NULOUT,*)    '   FILE CONTAINS POLES '
ELSE
  LLFICP=.FALSE.
  WRITE(NULOUT,*)    '   FILE DOES NOT CONTAIN POLES '
ENDIF
IF (LLFICP.AND.INLATI /= NDGLG+2) THEN
  CALL ABOR1('INTERNAL FILE INCONSISTENCY')
ELSEIF (.NOT.LLFICP.AND.INLATI /= NDGLG) THEN
  CALL ABOR1('INTERNAL FILE INCONSISTENCY')
ENDIF

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

!*       2.    EXTRACT THE SURFACE PRESSURE.  (see SUSPECA*)
!              ---------------------------------------------

CALL FANION(IREP,NINISH,'SURF',1,'PRESSION',LLEXIST,LLCOSP,INGRIB,INBITS, &
 & ISTRON,IPUILA)
IF (.NOT.(INGRIB==-1 .OR. INGRIB==3)) THEN
  CALL FACILE(IREP,NINISH,'SURF',1,'PRESSION',ZSPEC,.TRUE.)
  CALL SPREORD(1,ZSPEC,Z_PSPSPI,.TRUE.)
ELSE
  CALL FACILE(IREP,NINISH,'SURF',1,'PRESSION',Z_PSPSPI,.TRUE.)
ENDIF
CALL FANION(IREP,NTRJSH,'SURF',1,'PRESSION',LLEXIST,LLCOSP,INGRIB,INBITS, &
 & ISTRON,IPUILA)
IF (.NOT.(INGRIB==-1 .OR. INGRIB==3)) THEN
  CALL FACILE(IREP,NTRJSH,'SURF',1,'PRESSION',ZSPEC,.TRUE.)
  CALL SPREORD(1,ZSPEC,Z_PSPSPF,.TRUE.)
ELSE
  CALL FACILE(IREP,NTRJSH,'SURF',1,'PRESSION',Z_PSPSPF,.TRUE.)
ENDIF

!     CHANGE SURFACE PRESSURE VARIABLE IF NEEDED ACCORDING TO THE MEAN
!     VALUE : >80000 => SUFACE PRESSURE  ; <80000 => ITS LOGARITHM

WRITE(NULOUT,*) '  '
WRITE(NULOUT,*) ' READ SURF PRESSURE ON INITIAL FILE :  '

IF(Z_PSPSPI(NASM0(0)) > 8.E+4_JPRB) THEN
  WRITE(NULOUT,*) '   KEEP PS  '
  CALL SPEREE(1,1,Z_PSPSPI,ZPSI)
ELSE
  WRITE(NULOUT,*) '   CHANGE : LN(PS) --> PS  '
  CALL SPEREE(1,1,Z_PSPSPI,ZREE)
  DO JGL=1,NDGLG
    DO JLON=1,NLOEN(JGL)
      ZPSI(JLON+NSTAGP(JGL)) = EXP(ZREE(JLON+NSTAGP(JGL)))
    ENDDO
  ENDDO
ENDIF

WRITE(NULOUT,*) ' READ SURF PRESSURE ON FINAL FILE :  '

IF(Z_PSPSPF(NASM0(0)) > 8.E+4_JPRB) THEN
  WRITE(NULOUT,*) '   KEEP PS  '
  CALL SPEREE(1,1,Z_PSPSPF,ZPSF)
ELSE
  WRITE(NULOUT,*) '   CHANGE : LN(PS) --> PS  '
  CALL SPEREE(1,1,Z_PSPSPF,ZREE)
  DO JGL=1,NDGLG
    DO JLON=1,NLOEN(JGL)
      ZPSF(JLON+NSTAGP(JGL)) = EXP(ZREE(JLON+NSTAGP(JGL)))
    ENDDO
  ENDDO
ENDIF

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

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

DO JGL=1,NDGLG
  DO JLON=1,NLOEN(JGL)
    ZPVI(JLON+NSTAGP(JGL)) = 0.0_JPRB
    ZPVF(JLON+NSTAGP(JGL)) = 0.0_JPRB
  ENDDO
ENDDO

DO JLEV=1,NFLEVG

!        *** Compute pressure difference accross layers *** 
  ZDA=VAH(JLEV)-VAH(JLEV-1)
  ZDB=VBH(JLEV)-VBH(JLEV-1)
  DO JGL=1,NDGLG
    DO JLON=1,NLOEN(JGL)
      ZDPI(JLON+NSTAGP(JGL))=ZDA+ZDB*ZPSI(JLON+NSTAGP(JGL))
      ZDPF(JLON+NSTAGP(JGL))=ZDA+ZDB*ZPSF(JLON+NSTAGP(JGL))
    ENDDO
  ENDDO

!        *** Read the specific humidity for initial file *** 
!        *** Go to Gauss grid point space *** 
!        *** Sum the water vapor mass     *** 
  CALL FANION(IREP,NINISH,'S',JLEV,'HUMI.SPECIFIQUE',LLEXIST,LLCOSP,INGRIB, &
   & INBITS,ISTRON,IPUILA)
  IF (.NOT.(INGRIB==-1 .OR. INGRIB==3)) THEN
    CALL FACILE(IREP,NINISH,'S',JLEV,'HUMI.SPECIFIQUE',ZSPEC,LLT)
    CALL SPREORD(1,ZSPEC,ZSPQ,.TRUE.)
  ELSE
    CALL FACILE(IREP,NINISH,'S',JLEV,'HUMI.SPECIFIQUE',ZSPQ,LLT)
  ENDIF
  CALL SPEREE(1,1,ZSPQ,ZREE)
  DO JGL=1,NDGLG
    DO JLON=1,NLOEN(JGL)
      ZPVI(JLON+NSTAGP(JGL))=ZPVI(JLON+NSTAGP(JGL))&
       & +ZREE(JLON+NSTAGP(JGL))*ZDPI(JLON+NSTAGP(JGL))  
    ENDDO
  ENDDO

!        *** Read the specific humidity for final file ***  
!        *** Go to Gauss grid point space *** 
!        *** Sum the water vapor mass     ***
  CALL FANION(IREP,NTRJSH,'S',JLEV,'HUMI.SPECIFIQUE',LLEXIST,LLCOSP,INGRIB, &
   & INBITS,ISTRON,IPUILA)
  IF (.NOT.(INGRIB==-1 .OR. INGRIB==3)) THEN
    CALL FACILE(IREP,NTRJSH,'S',JLEV,'HUMI.SPECIFIQUE',ZSPEC,LLT)
    CALL SPREORD(1,ZSPEC,ZSPQ,.TRUE.)
  ELSE
    CALL FACILE(IREP,NTRJSH,'S',JLEV,'HUMI.SPECIFIQUE',ZSPQ,LLT)
  ENDIF
  CALL SPEREE(1,1,ZSPQ,ZREE)
  DO JGL=1,NDGLG
    DO JLON=1,NLOEN(JGL)
      ZPVF(JLON+NSTAGP(JGL))=ZPVF(JLON+NSTAGP(JGL))&
       & +ZREE(JLON+NSTAGP(JGL))*ZDPF(JLON+NSTAGP(JGL))  
    ENDDO
  ENDDO

ENDDO

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

!*       4.    COMPUTE THE MASS INTEGRAL OF DRY AIR.
!              -------------------------------------

WRITE(NULOUT,*) ' COMPUTE THE MASS INTEGRAL OF DRY AIR '

DO JGL=1,NDGLG
  DO JLON=1,NLOEN(JGL)
    ZPDRYI(JLON+NSTAGP(JGL)) = ZPSI(JLON+NSTAGP(JGL))&
     & - ZPVI(JLON+NSTAGP(JGL))  
    ZPDRYF(JLON+NSTAGP(JGL)) = ZPSF(JLON+NSTAGP(JGL))&
     & - ZPVF(JLON+NSTAGP(JGL))  
  ENDDO
ENDDO

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

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

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

ZAPSI=0.0_JPRB
ZAPSF=0.0_JPRB
ZAPDRYI=0.0_JPRB
ZAPDRYF=0.0_JPRB
DO JGL=1,NDGLG
  DO JLON=1,NLOEN(JGL)
    ZAPSI = ZAPSI + ZPSI(JLON+NSTAGP(JGL))&
     & * RW(JGL) / GM(JLON+NSTAGP(JGL))**2 / REAL(NLOEN(JGL),JPRB)   
    ZAPSF = ZAPSF + ZPSF(JLON+NSTAGP(JGL))&
     & * RW(JGL) / GM(JLON+NSTAGP(JGL))**2 / REAL(NLOEN(JGL),JPRB)  
    ZAPDRYI = ZAPDRYI + ZPDRYI(JLON+NSTAGP(JGL))&
     & * RW(JGL) / GM(JLON+NSTAGP(JGL))**2 / REAL(NLOEN(JGL),JPRB)  
    ZAPDRYF = ZAPDRYF + ZPDRYF(JLON+NSTAGP(JGL))&
     & * RW(JGL) / GM(JLON+NSTAGP(JGL))**2 / REAL(NLOEN(JGL),JPRB)  
  ENDDO
ENDDO

ZAPCORM = - ZAPDRYF + ZAPDRYI
ZZNEW   =   ZAPSF   + ZAPCORM

WRITE (NULOUT,*) '  '
WRITE (NULOUT,'(1X,'' MEAN INIT. TOT PRESSURE '',f19.8)') ZAPSI
WRITE (NULOUT,'(1X,'' MEAN FINAL TOT PRESSURE '',f19.8)') ZAPSF
WRITE (NULOUT,*) '  '
WRITE (NULOUT,'(1X,'' MEAN INIT. 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,*) '  '

!     ---------
LLTEST=LLF
!     ---------
ZAUN=0.0_JPRB
ZALPSI=0.0_JPRB
ZALPSF=0.0_JPRB
ZZLPSI = Z_PSPSPI(NASM0(0))
ZZLPSF = Z_PSPSPF(NASM0(0))
!     ---------------
IF (LLTEST) THEN
!     ---------------
  DO JGL=1,NDGLG
    DO JLON=1,NLOEN(JGL)
      ZAUN  = ZAUN  + 1.0_JPRB &
       & * RW(JGL) / GM(JLON+NSTAGP(JGL))**2 / REAL(NLOEN(JGL),JPRB)  
      ZALPSI  = ZALPSI  + LOG( ZPSI(JLON+NSTAGP(JGL)) )&
       & * RW(JGL) / GM(JLON+NSTAGP(JGL))**2 / REAL(NLOEN(JGL),JPRB)  
      ZALPSF  = ZALPSF  + LOG( ZPSF(JLON+NSTAGP(JGL)) )&
       & * RW(JGL) / GM(JLON+NSTAGP(JGL))**2 / REAL(NLOEN(JGL),JPRB)  
    ENDDO
  ENDDO
  ZALPSI=EXP(ZALPSI)
  ZALPSF=EXP(ZALPSF)
  ZZLPSI=EXP(ZZLPSI)
  ZZLPSF=EXP(ZZLPSF)
  WRITE (NULOUT,*) '  '
  WRITE (NULOUT,'(1X,'' 1. = ? '',f19.8)') ZAUN
  WRITE (NULOUT,*) '  '
  WRITE (NULOUT,'(1X,'' INIT. TOTAL PRESS 1 '',f19.8)') ZZLPSI
  WRITE (NULOUT,'(1X,'' INIT. TOTAL PRESS 2 '',f19.8)') ZALPSI
  WRITE (NULOUT,*) '  '
  WRITE (NULOUT,'(1X,'' FINAL TOTAL PRESS 1 '',f19.8)') ZZLPSF
  WRITE (NULOUT,'(1X,'' FINAL TOTAL PRESS 2 '',f19.8)') ZALPSF
  WRITE (NULOUT,*) '  '
!     -----
ENDIF
!     -----

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

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

WRITE(NULOUT,*) ' MAKE THE CORRECTION OF MASS '
WRITE(NULOUT,*) ' WRITE ON *FA* FINAL FILE '

DO JGL=1,NDGLG
  DO JLON=1,NLOEN(JGL)
    ZPSF(JLON+NSTAGP(JGL)) = LOG(ZPSF(JLON+NSTAGP(JGL))+ZAPCORM)
  ENDDO
ENDDO

!     Go back to spectral space (see WRMLPPA*)
CALL REESPE(1,1,ZSPEC,ZPSF)

CALL FAVEUR(IREP,NTRJSH,INGRIB,INBPDG,INBCSP,ISTRON,IPUILA,IDMOPL)
! data should be reordered only if packing type is not -1 and not 3
IF (INGRIB==-1 .OR. INGRIB==3) THEN
  CALL FAIENC(IREP,NTRJSH,'SURF',1,'PRESSION',ZSPEC,LLT)
ELSE
  CALL SPREORD(1,Z_PSPSPF,ZSPEC,.FALSE.)
  CALL FAIENC(IREP,NTRJSH,'SURF',1,'PRESSION',Z_PSPSPF,LLT)
ENDIF

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

!*       7.    CHECK THE RESULT.
!              -----------------

!     ---------------
IF (LLTEST) THEN
!     ---------------
  CALL FANION(IREP,NTRJSH,'SURF',1,'PRESSION',LLEXIST,LLCOSP,INGRIB,INBITS, &
   & ISTRON,IPUILA)
  IF (.NOT.(INGRIB==-1 .OR. INGRIB==3)) THEN
    CALL FACILE(IREP,NTRJSH,'SURF',1,'PRESSION',ZSPEC,LLT)
    CALL SPREORD(1,ZSPEC,Z_PSPSPF,.TRUE.)
  ELSE
    CALL FACILE(IREP,NTRJSH,'SURF',1,'PRESSION',Z_PSPSPF,LLT)
  ENDIF
  CALL SPEREE(1,1,Z_PSPSPF,ZREE)
  DO JGL=1,NDGLG
    DO JLON=1,NLOEN(JGL)
      ZPSF(JLON+NSTAGP(JGL)) = EXP(ZREE(JLON+NSTAGP(JGL)))
    ENDDO
  ENDDO
  ZAPSF=0.0_JPRB
  DO JGL=1,NDGLG
    DO JLON=1,NLOEN(JGL)
      ZAPSF = ZAPSF + ZPSF(JLON+NSTAGP(JGL))&
       & * RW(JGL) / GM(JLON+NSTAGP(JGL))**2 / REAL(NLOEN(JGL),JPRB)  
    ENDDO
  ENDDO
  WRITE (NULOUT,*) '  '
  WRITE (NULOUT,'(1X,'' NEW MEAN FINAL TOT PRES 1'',f19.8)') ZZNEW
  WRITE (NULOUT,'(1X,'' NEW MEAN FINAL TOT PRES 2'',f19.8)') ZAPSF
  WRITE (NULOUT,*) '  '
!     -----
ENDIF
!     -----

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

!*       8.    CLOSE FILES.
!              ------------

WRITE(NULOUT,*) ' '
CALL FAIRME(IREP,NINISH,'UNKNOWN')
CALL FAIRME(IREP,NTRJSH,'UNKNOWN')

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

!*       9.    WRITE THE RESULTS ON THE ASCII FILE.
!              ------------------------------------

WRITE(NULOUT,*) '  '
WRITE(NULOUT,*) '  WRITE THE RESULTS ON THE ASCII FILE '

OPEN(NTRJSH,FILE='CORMASS_ASCII',FORM='FORMATTED')

WRITE (NTRJSH,'(1X,'' MEAN INIT. TOT PRESSURE '',f19.8)') ZAPSI
WRITE (NTRJSH,'(1X,'' MEAN FINAL TOT PRESSURE '',f19.8)') ZAPSF

WRITE (NTRJSH,'(1X,'' MEAN INIT. DRY PRESSURE '',f19.8)') ZAPDRYI
WRITE (NTRJSH,'(1X,'' MEAN FINAL DRY PRESSURE '',f19.8)') ZAPDRYF

WRITE (NTRJSH,'(1X,'' OLD MEAN FINAL TOT PRES '',f19.8)') ZAPSF
WRITE (NTRJSH,'(1X,'' MEAN CORR. OF  DRY PRES '',f19.8)') ZAPCORM
WRITE (NTRJSH,'(1X,'' NEW MEAN FINAL TOT PRES '',f19.8)') ZZNEW

CLOSE(NTRJSH)

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

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

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