SUBROUTINE CPREP5

! Purpose.
! --------
!   Conversion from MARS (un-gribbed) to FA (unrotated)
!   This is a simplified concatenation of conf 901 and 926

! **   Interface.
! ----------
! *CALL* *CPREP5

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

! Implicit arguments :
! --------------------
! None

! Method.
! -------
! The input are: 
!   1. a namelist in the source geometry
!   2. an arpege file in the target geometry containing the 
!    spectral orography, the index of the nearest point in the source grid
!    (preserving the land-sea origin),
!    and several climatological fields necessary to normalize the reservoirs
!   3. a few binary files containing the source data in the order:
!        land-sea mask, surf geopotential,surf temperature,
!        deep temperature,
!        log surf pressure (spectral),
!        temperature (from top to bottom in spectral coefficients), 
!        vorticity + divergence (idem temperature),
!        specific humidity (idem temperature but in grid points), 
!        surface moisture, deep moisture and snow amount

! The target orography is calculated on the source grid, then the source
! surface pressure (grid point) is corrected to this new orography.
! The spectral data are transformed into grid points, then they 
! are interpolated onto the new vertical levels and go back to the
! spectral space. Rotation or stretching being not allowed, the spectral
! expansion in simply truncated to the target geometry.
! The surface data are extracted by the nearest neighbour method (without
! mixing land and sea data). For temperature, a simple orography correction
! is applied. Additional fields with dummy values are written on the output.
! This procedure is repeated (max 9 times) for a few input/output pairs

! Externals.
! ----------

! Reference.
! ----------

! Author.
! -------
! Michel Deque

! Modifications.
! --------------
! Original : 97-02-20
!        98-03-17: R. EL KHATIB : SPREORD
! Modified 98-02-12 by M. Deque: add solid water reservoir and STOP
! Modified 98-08-10 by K. YESSAD: removal of LRPOLE option.
!  - removal of LRPOLE in YOMCT0 and code under LRPOLE.
!  - removal of argument .FALSE. in 'CALL SPEREE' and 'CALL SPEUV'.
!  - in the new configuration the two ARPEGE files must be without poles,
!    and the arrays dimensioned with NDLON*(NDGLG+2) do not contain polar
!    values and have their non polar values in elements 1 to NGPTOTG.
! Modified 98-02-12 by M. Deque: add solid water reservoir and STOP
! Modified 98-08-12 by M. Deque: uses ECMWF orography
! Modified 98-09-01 by M. Deque: homothetic temperature profile
!                                in PBL interpolation
!        M.Hamrud      01-Oct-2003 CY28 Cleaning
!      D. Paradis & R. El Khatib : 04-07-22 GRIBEX
! ---------------------------------------------------

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

USE YOMDIM   , ONLY : NDGLG    ,NDLON    ,NFLEVG   ,NSEFRE   ,NSPEC2G
USE YOMCST   , ONLY : RG       ,RD       ,RV       ,RCPV     ,&
 & RETV     ,RCW      ,RCS      ,RLVTT    ,RLSTT    ,&
 & RTT      ,RALPW    ,RBETW    ,RGAMW    ,RALPS    ,&
 & RBETS    ,RGAMS    ,RALPD    ,RBETD    ,RGAMD  
USE YOMSTA   , ONLY : RDTDZ1
USE YOMLUN   , ONLY : NULOUT   ,NPOSSH   ,NINISH   ,NULCL1
USE YOMGEM   , ONLY : NLOEN    ,NSTAGP   ,VBH      ,VAH      ,NGPTOT
USE YOMRIP   , ONLY : NINDAT   ,NSSSSS
USE YOMPHY1  , ONLY : EWFC     ,EWWILT   ,GWFC     ,GWWILT   ,&
 & RD1      ,NTVGLA   ,NTVMER  
USE YOMPHY   , ONLY : LNEIGE
USE YOMNUD   , ONLY : LNUDG

IMPLICIT NONE

!     * Remark: after removal of points at the poles, the dimension of
!       arrays dimensioned with NDLON*(NDGLG+2) can be lowered to NGPTOTG,
!       ITOGO1 and ITOGO2 have to be equal to NGPTOTG. That concerns
!       arrays ZZ,ZPS1,ZOROG1,ZPS2,ZTOGOS1,ZLPS1,ZLPS2,ZTS1,ZTS2,ZTL1,
!       ZTP1,ZTP2,ZVP1,ZWP1,ZPP1.

REAL(KIND=JPRB) :: ZAHYBR (0:999), ZBHYBR (0:999)
REAL(KIND=JPRB) :: ZAF2(999), ZBF2(999)
REAL(KIND=JPRB) :: ZSINLA(NDGLG+2)
INTEGER(KIND=JPIM) :: INOZPA(NDGLG+2),IDATEF(11),INIP(NDGLG+2)
REAL(KIND=JPRB) :: ZZ(NDLON*(NDGLG+2)),ZW(NSPEC2G)
REAL(KIND=JPRB) :: ZLNPS(NSEFRE),ZV(NSEFRE),ZX(NSEFRE)
REAL(KIND=JPRB) :: ZPS1(NDLON*(NDGLG+2)),ZOROG1(NDLON*(NDGLG+2))
REAL(KIND=JPRB) :: ZPS2(NDLON*(NDGLG+2)),ZTOGOS1(NDLON*(NDGLG+2))
REAL(KIND=JPRB) :: ZLPS1(NDLON*(NDGLG+2)),ZLPS2(NDLON*(NDGLG+2))
REAL(KIND=JPRB) :: ZTS1(NDLON*(NDGLG+2)),ZTS2(NDLON*(NDGLG+2))
REAL(KIND=JPRB) :: ZTL1(NDLON*(NDGLG+2))
REAL(KIND=JPRB) :: ZALT(NDLON*(NDGLG+2)),ZBET(NDLON*(NDGLG+2))
REAL(KIND=JPRB) :: ZALP(NDLON*(NDGLG+2)),ZBEP(NDLON*(NDGLG+2))
REAL(KIND=JPRB) :: ZTP1(NDLON*(NDGLG+2)),ZTP2(NDLON*(NDGLG+2))
REAL(KIND=JPRB) :: ZVP1(NDLON*(NDGLG+2),NFLEVG+1)
REAL(KIND=JPRB) :: ZWP1(NDLON*(NDGLG+2),NFLEVG+1)
REAL(KIND=JPRB) :: ZPP1(NDLON*(NDGLG+2),NFLEVG+1)
REAL(KIND=JPRB) :: ZPP2(NDLON)
REAL(KIND=JPRB) :: ZAF1(NFLEVG),ZBF1(NFLEVG)
REAL(KIND=JPRB) :: ZOROG2S(NSEFRE),ZOROG2B(NSPEC2G),ZOROG2C(NDLON*(NDGLG+2))
REAL(KIND=JPRB) :: ZFAGGS(NGPTOT),ZFBGGS(NGPTOT)
INTEGER(KIND=JPIM) :: ILEVB(NDLON)
CHARACTER (LEN = 16) ::  CLNIN,CLNOU

INTEGER(KIND=JPIM) :: IAB, IBL, ICOUNT, ILMX, INBARI, INBCLP, INDEX,&
 & INIVER, IPNIP, IPNJP, IREP, ITOGO1, ITOGO2, &
 & ITRONC, ITYPTR, J, JGL, JLEV, JLEV1, JLEV2, &
 & JLON
INTEGER(KIND=JPIM) :: INGRIB,INBPDG,INBCSP,ISTRON,IPUILA,IDMOPL,INGRIG,INBITS
INTEGER(KIND=JPIM) :: INGRIB2

LOGICAL :: LLECORO, LLGARD
LOGICAL :: LLEXIST, LLCOSP

REAL(KIND=JPRB) :: ZCLOPO, ZCO1, ZCO2, ZDELTAL, ZDELTAS, ZDTSDO,&
 & ZEPS2, ZESL, ZESS, ZFACDI, ZHP, ZHS, ZPL1, &
 & ZPL2, ZPREFR, ZRATP, ZSLAPO, ZSLOPO, ZTS, &
 & ZWBL, ZWFC, ZWMINSO, ZWPMAX, ZWPMIN, ZWSMAX, &
 & ZWSMIN, ZWSN, ZWWILT  
REAL(KIND=JPRB) :: ZHOOK_HANDLE

#include "abor1.intfb.h"
#include "reespe.intfb.h"
#include "speree.intfb.h"
#include "speuv.intfb.h"
#include "spreord.intfb.h"
#include "uvspe.intfb.h"

#include "fcttrm.h"

!     1. DESCRIPTION OF THE SOURCE GRID
IF (LHOOK) CALL DR_HOOK('CPREP5',0,ZHOOK_HANDLE)
ICOUNT=0
100 CONTINUE
ICOUNT=ICOUNT+1
WRITE(CLNIN,'(''Mars.data'',I1)')ICOUNT
OPEN(NINISH,FILE=CLNIN,ERR=9999,STATUS='OLD',FORM='UNFORMATTED')
WRITE(NULOUT,'('' New File '',A16)')CLNIN
!     Land-sea mask (no use)      
READ(NINISH)ILMX,(ZZ(J),J=1,ILMX)
ITOGO1=0
DO J=1,NDGLG
  ITOGO1=ITOGO1+NLOEN(J)
ENDDO
DO JLEV=1,NFLEVG
  ZAF1(JLEV)=(VAH(JLEV)+VAH(JLEV-1))*0.5_JPRB
  ZBF1(JLEV)=(VBH(JLEV)+VBH(JLEV-1))*0.5_JPRB
ENDDO

!     2. DESCRIPTION OF THE TARGET GRID

CALL FAITOU (IREP,NULCL1,.TRUE.,'Const.Clim2','OLD',.TRUE.,&
 & .FALSE.,1,200,INBARI,'Cadre.cible')  
WRITE(CLNOU,'(''Restart'',I1)')ICOUNT
CALL FAITOU (IREP,NPOSSH,.TRUE.,CLNOU,'NEW',.TRUE.,.FALSE.,&
 & 1,200,INBARI,'Cadre.cible')  
IDATEF(1)=NINDAT/10000
IDATEF(2)=MOD(NINDAT,10000)/100
IDATEF(3)=MOD(NINDAT,100)
IDATEF(4)=NSSSSS/3600
IDATEF(5)=0
IDATEF(6)=1
IDATEF(7)=0
IDATEF(8)=0
IDATEF(9)=0
IDATEF(10)=0
IDATEF(11)=0
CALL FANDAR (IREP,NPOSSH,IDATEF)
CALL LFILAF(IREP,NULCL1,.FALSE.)
IPNIP=0
IPNJP=0
INIVER=0
ITYPTR=0
ZPREFR=0.0_JPRB
CALL FACIES ('Cadre.cible',ITYPTR,ZSLAPO,ZCLOPO,ZSLOPO,ZFACDI,&
 & ITRONC,IPNJP,IPNIP,INIP(1),INOZPA(1),ZSINLA(1),&
 & INIVER,ZPREFR,ZAHYBR,ZBHYBR,LLGARD)  
IF(IPNIP > NDLON) THEN
  CALL ABOR1(' ERROR : TARGET GRID FINER THAN THE SOURCE ')
!     The problem is: the fields are dimensioned with the geometry
!     of the target grid      
ENDIF
IF(INIVER > 999) THEN
  CALL ABOR1(' ERROR : MORE THAN 999 LEVELS IN TARGET GRID ')
!     The problem is: the A and B fields are dimensioned with 999 levels
ENDIF
IF(ITYPTR > 1) THEN
  CALL ABOR1(' ERROR : TARGET GRID ROTATED')
!     The problem is: the spectral coefficients are simply truncated
!     to go from the source to the target and completed by zeros in
!     the inverse transform
ENDIF
ZEPS2=1.E-10_JPRB
IF (ZSINLA(1) > 1.0_JPRB-ZEPS2) THEN
  WRITE(NULOUT,FMT='(A)') ' FILE NULCL1 CONTAINS POLES '
  WRITE(NULOUT,FMT='(A)') ' FILE NPOSSH CONTAINS POLES '
  WRITE(NULOUT,FMT='(A)') ' UNITS NULCL1 AND NPOSSH MUST BE',&
   & ' WITHOUT POLES.'  
  CALL ABOR1(' CPREP5: NOT CODED FOR FILES WITH POLES')
ELSE
  WRITE(NULOUT,FMT='(A)') ' FILE NULCL1 DOES NOT CONTAIN POLES '
  WRITE(NULOUT,FMT='(A)') ' FILE NPOSSH DOES NOT CONTAIN POLES '
ENDIF
ITOGO2=0
DO J=1,IPNJP/2
  ITOGO2=ITOGO2+2*INIP(J)
  INIP(IPNJP+1-J)=INIP(J)
  ZSINLA(IPNJP+1-J)=-ZSINLA(J)
ENDDO
IF (ITOGO2 /= ITOGO1) THEN
  WRITE(NULOUT,FMT='(A)') ' ITOGO2 IS DIFFERENT FROM ITOGO1 '
  WRITE(NULOUT,FMT='(A)') ' CPREP5 CAN WORK ONLY IF ITOGO2=ITOGO1'
  CALL ABOR1(' CPREP5: INCONSISTENCY BETWEEN ITOGO1 AND ITOGO2')
ENDIF
DO JLEV=1,INIVER
  ZAF2(JLEV)=(ZAHYBR(JLEV)+ZAHYBR(JLEV-1))*0.5_JPRB*ZPREFR
  ZBF2(JLEV)=(ZBHYBR(JLEV)+ZBHYBR(JLEV-1))*0.5_JPRB
ENDDO

!     3. OROGRAPHY

!      THE MODEL MAY BE FORCED TO USE THE SAME OROGRAPHY AS THE SOURCE
!      (AFTER TRUNCATION)
LLECORO=.FALSE.
! THE TEMPERATURE OF THE INBCLP LOWEST LEVELS MAY BE MODIFIED SO THAT
! A HOMOTHETIC VERTICAL PROFILE IS OBTAINED
! WARNING: THEN THE WATER PROFILE IS NO MORE CONSISTENT WITH
! THE TEMPERATURE PROFILE IN THE PBL, BUT THE SURFACE TEMPERATURE IS
! MORE CONSISTENT WITH THE ATMOSPHERE ONE WHEN THE ELEVATIONS ARE !=
INBCLP=0
IF(LNUDG) THEN
  INBCLP=5
  LLECORO=.TRUE.
ENDIF
READ(NINISH)ILMX,(ZOROG1(J),J=1,ILMX)
IF(LLECORO)THEN
  INDEX=0
  DO JGL=1,NDGLG
    DO JLON=1,NLOEN(JGL)
      ZFAGGS(JLON+NSTAGP(JGL))=ZOROG1(INDEX+JLON)
    ENDDO
    INDEX=INDEX+NLOEN(JGL)
  ENDDO
  CALL REESPE(1,1,ZZ,ZFAGGS)
  CALL FAVEUR(IREP,NULCL1,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
    INGRIG=-1
  ELSE
    INGRIG=0
  ENDIF
  CALL FAGOTE(IREP,NULCL1,INGRIG,INBPDG,INBCSP,ISTRON,IPUILA,IDMOPL)
  IF (INGRIG==0) THEN
    CALL SPREORD(1,ZOROG2S,ZZ,.FALSE.)
    CALL FAIENC(IREP,NULCL1,'SPECSURF',0,'GEOPOTEN',ZOROG2S,.TRUE.)
  ELSE
    CALL FAIENC(IREP,NULCL1,'SPECSURF',0,'GEOPOTEN',ZZ,.TRUE.)
  ENDIF
  CALL FAGOTE(IREP,NULCL1,INGRIB,INBPDG,INBCSP,ISTRON,IPUILA,IDMOPL)
ENDIF
DO J=1,NSEFRE
  ZOROG2S(J)=0.0_JPRB
ENDDO
CALL FANION(IREP,NULCL1,'SPECSURF',0,'GEOPOTEN',LLEXIST,LLCOSP,INGRIB,INBITS, &
 & ISTRON,IPUILA)
IF (.NOT.(INGRIB==-1 .OR. INGRIB==3)) THEN
  INGRIB2=0
  CALL FACILE(IREP,NULCL1,'SPECSURF',0,'GEOPOTEN',ZOROG2S,.TRUE.)
ELSE
  INGRIB2=-1
  CALL FACILE(IREP,NULCL1,'SPECSURF',0,'GEOPOTEN',ZOROG2B,.TRUE.)
ENDIF
CALL FAVEUR(IREP,NPOSSH,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
  INGRIG=-1
ELSE
  INGRIG=0
ENDIF
CALL FAGOTE(IREP,NPOSSH,INGRIG,INBPDG,INBCSP,ISTRON,IPUILA,IDMOPL)
IF (INGRIG==0) THEN
  IF (INGRIB2==-1) THEN
    CALL SPREORD(1,ZOROG2S,ZOROG2B,.FALSE.)
  ENDIF
  CALL FAIENC(IREP,NPOSSH,'SPECSURF',0,'GEOPOTEN',ZOROG2S,.TRUE.)
ELSE
  IF (INGRIB2==0) THEN
    CALL SPREORD(1,ZOROG2S,ZOROG2B,.TRUE.)
  ENDIF
  CALL FAIENC(IREP,NPOSSH,'SPECSURF',0,'GEOPOTEN',ZOROG2B,.TRUE.)
ENDIF
CALL FAGOTE(IREP,NPOSSH,INGRIB,INBPDG,INBCSP,ISTRON,IPUILA,IDMOPL)
CALL SPEREE(1,1,ZOROG2B,ZFAGGS)
INDEX=0
DO JGL=1,NDGLG
  DO JLON=1,NLOEN(JGL)
    ZOROG2C(INDEX+JLON)=ZFAGGS(JLON+NSTAGP(JGL))-ZOROG1(INDEX+JLON)
  ENDDO
  INDEX=INDEX+NLOEN(JGL)
ENDDO
!     ZOROG2C IS THUS THE DELTA OROGRAPHY ON THE SOURCE GRID      

!     4. SURFACE TEMPERATURE

ZDTSDO=RDTDZ1/RG
CALL FACILE(IREP,NULCL1,'SURF',1,'VOISIN',ZTOGOS1,.FALSE.)
READ(NINISH)ILMX,(ZTS1(J),J=1,ILMX)
DO J=1,ITOGO2
  ZTS2(J)=ZTS1(NINT(ZTOGOS1(J)))+ZDTSDO*ZOROG2C(NINT(ZTOGOS1(J)))
ENDDO
CALL FAIENC(IREP,NPOSSH,'SURF',0,'TEMPERATURE ',ZTS2,.FALSE.)

!     5. DEEP TEMPERATURE

READ(NINISH)ILMX,(ZTP1(J),J=1,ILMX)
DO J=1,ITOGO2
  ZTP2(J)=ZTP1(NINT(ZTOGOS1(J)))+ZDTSDO*ZOROG2C(NINT(ZTOGOS1(J)))
ENDDO
CALL FAIENC(IREP,NPOSSH,'PROF',0,'TEMPERATURE ',ZTP2,.FALSE.)
CALL FACILE(IREP,NULCL1,'LEV3',0,'TEMPERATINC ',ZTP1,.FALSE.)
DO J=1,ITOGO2
  ZTP1(J)=ZTP1(J)+ZTP2(J)
ENDDO
CALL FAIENC(IREP,NPOSSH,'LEV3',0,'TEMPERATURE ',ZTP1,.FALSE.)
CALL FACILE(IREP,NULCL1,'LEV4',0,'TEMPERATINC ',ZTP1,.FALSE.)
DO J=1,ITOGO2
  ZTP1(J)=ZTP1(J)+ZTP2(J)
ENDDO
CALL FAIENC(IREP,NPOSSH,'LEV4',0,'TEMPERATURE ',ZTP1,.FALSE.)

!     6. LOG SURFACE PRESSURE

READ(NINISH)ILMX,(ZZ(J),J=1,ILMX)
CALL SPEREE(1,1,ZZ,ZFAGGS)
INDEX=0
DO JGL=1,NDGLG
  DO JLON=1,NLOEN(JGL)
    ZLPS1(INDEX+JLON)=ZFAGGS(JLON+NSTAGP(JGL))
  ENDDO
  INDEX=INDEX+NLOEN(JGL)
ENDDO
! UP TO 2000 m DIFFERENCE, ONE CAN LINEARIZE THE LOGARITHM IN
! THE ELEVATION CORRECTION WITH A SUFFICIENT ACCURACY
DO J=1,ITOGO1
  ZLPS2(J)=ZLPS1(J)-ZOROG2C(J)/(RD*ZTS1(J))
  ZPS1(J)=EXP(ZLPS1(J))
  ZPS2(J)=EXP(ZLPS2(J))
!          THIS ADDITIONAL BOTTOM LEVEL AVOIDS EXTRAPOLATION OF
!          TEMPERATURE AND MOISTURE BELOW THE LOWEST LEVEL OF
!          THE SOURCE GRID
  ZPP1(J,NFLEVG+1)=MAX(ZPS1(J),ZPS2(J))
ENDDO
INDEX=0
DO JGL=1,NDGLG
  DO JLON=1,NLOEN(JGL)
    ZFAGGS(JLON+NSTAGP(JGL))=ZLPS2(INDEX+JLON)
  ENDDO
  INDEX=INDEX+NLOEN(JGL)
ENDDO
CALL REESPE(1,1,ZZ,ZFAGGS)
IF (INGRIB==-1 .OR. INGRIB==3) THEN
  CALL FAIENC(IREP,NPOSSH,'SURF',0,'PRESSION',ZZ,.TRUE.)
ELSE
  CALL SPREORD(1,ZLNPS,ZZ,.FALSE.)
  CALL FAIENC(IREP,NPOSSH,'SURF',0,'PRESSION',ZLNPS,.TRUE.)
ENDIF
DO JLEV=1,NFLEVG
  DO J=1,ITOGO1
    ZPP1(J,JLEV)=ZAF1(JLEV)+ZBF1(JLEV)*ZPS1(J)
  ENDDO
ENDDO

!     7. TEMPERATURE

!      TO AVOID EXTRAPOLATING TEMPERATURE BELOW THE LOWEST LEVEL,
!      AN ADDITIONAL LEVEL IS INTRODUCED CORRESPONDING TO THE LOWER
!      SURFACE OF THE TWO GEOMETRIES. SO THE TEMPERATURE IS NOT
!      CONSTANT INSIDE THE MOUNTAINS OF THE SOURCE GEOMETRY

DO JLEV=1,NFLEVG
  READ(NINISH)ILMX,(ZZ(J),J=1,ILMX)
  CALL SPEREE(1,1,ZZ,ZFAGGS)
  INDEX=0
  DO JGL=1,NDGLG
    DO JLON=1,NLOEN(JGL)
      ZVP1(INDEX+JLON,JLEV)=ZFAGGS(JLON+NSTAGP(JGL))
    ENDDO
    INDEX=INDEX+NLOEN(JGL)
  ENDDO
ENDDO
DO J=1,ITOGO1
  ZVP1(J,NFLEVG+1)=ZTS1(J)+MAX(0.0_JPRB,+ZDTSDO*ZOROG2C(J))
  ZTL1(J)=ZVP1(J,NFLEVG)
ENDDO
!      ABOVE THE PBL:      
DO JLEV2=1,INIVER-INBCLP
  INDEX=0
  DO JGL=1,NDGLG
    DO JLON=1,NLOEN(JGL)
      ZPP2(JLON)=ZAF2(JLEV2)+ZBF2(JLEV2)*ZPS2(JLON+INDEX)
      ILEVB(JLON)=NFLEVG+1
    ENDDO
    DO JLEV1=NFLEVG,1,-1
      DO JLON=1,NLOEN(JGL)
        IF (ZPP1(JLON+INDEX,JLEV1) >= ZPP2(JLON))THEN
          ILEVB(JLON)=JLEV1
        ENDIF
      ENDDO
    ENDDO
    DO JLON=1,NLOEN(JGL)
      IBL=ILEVB(JLON)
      IAB=MAX(1,IBL-1)
      ZWBL=(ZPP2(JLON)-ZPP1(JLON+INDEX,IAB))/MAX(1.E-9_JPRB,&
       & ZPP1(JLON+INDEX,IBL)-ZPP1(JLON+INDEX,IAB))  
      ZFAGGS(JLON+NSTAGP(JGL))=ZVP1(JLON+INDEX,IBL)*ZWBL &
       & +ZVP1(JLON+INDEX,IAB)*(1.0_JPRB-ZWBL)  
      ZBET(JLON+INDEX)=ZFAGGS(JLON+NSTAGP(JGL))
    ENDDO
    INDEX=INDEX+NLOEN(JGL)
  ENDDO
  CALL REESPE(1,1,ZZ,ZFAGGS)
  IF (INGRIB==-1 .OR. INGRIB==3) THEN
    CALL FAIENC(IREP,NPOSSH,'S',JLEV2,'TEMPERATURE ',ZZ,.TRUE.)
  ELSE
    CALL SPREORD(1,ZV,ZZ,.FALSE.)
    CALL FAIENC(IREP,NPOSSH,'S',JLEV2,'TEMPERATURE ',ZV,.TRUE.)
  ENDIF
ENDDO
!      IN THE PBL:      
DO J=1,ITOGO1
  ZPL1=ZPP1(J,NFLEVG-INBCLP)
  ZPL2=ZAF2(INIVER-INBCLP)+ZBF2(INIVER-INBCLP)*ZPS2(J)
  ZALT(J)=(ZDTSDO*ZOROG2C(J)-ZBET(J)+ZVP1(J,NFLEVG-INBCLP))/(ZPS1(J)-ZPL1)
  ZBET(J)=ZDTSDO*ZOROG2C(J)-ZALT(J)*ZPS1(J)
  ZALP(J)=(ZPS1(J)-ZPL1)/(ZPS2(J)-ZPL2)
  ZBEP(J)=ZPS1(J)-ZALP(J)*ZPS2(J)
ENDDO
DO JLEV2=INIVER-INBCLP+1,INIVER
  INDEX=0
  DO JGL=1,NDGLG
    DO JLON=1,NLOEN(JGL)
      ZPP2(JLON)=ZALP(JLON+INDEX)*(ZAF2(JLEV2)+ZBF2(JLEV2)&
       & *ZPS2(JLON+INDEX))+ZBEP(JLON+INDEX)  
      ILEVB(JLON)=NFLEVG+1
    ENDDO
    DO JLEV1=NFLEVG,1,-1
      DO JLON=1,NLOEN(JGL)
        IF (ZPP1(JLON+INDEX,JLEV1) >= ZPP2(JLON))THEN
          ILEVB(JLON)=JLEV1
        ENDIF
      ENDDO
    ENDDO
    DO JLON=1,NLOEN(JGL)
      IBL=ILEVB(JLON)
      IAB=MAX(1,IBL-1)
      ZWBL=(ZPP2(JLON)-ZPP1(JLON+INDEX,IAB))/MAX(1.E-9_JPRB,&
       & ZPP1(JLON+INDEX,IBL)-ZPP1(JLON+INDEX,IAB))  
      ZFAGGS(JLON+NSTAGP(JGL))=&
       & ZVP1(JLON+INDEX,IBL)*ZWBL &
       & +ZVP1(JLON+INDEX,IAB)*(1.0_JPRB-ZWBL)&
       & +ZALT(JLON+INDEX)*ZPP2(JLON)+ZBET(JLON+INDEX)  
    ENDDO
    INDEX=INDEX+NLOEN(JGL)
  ENDDO
  CALL REESPE(1,1,ZZ,ZFAGGS)
  IF (INGRIB==-1 .OR. INGRIB==3) THEN
    CALL FAIENC(IREP,NPOSSH,'S',JLEV2,'TEMPERATURE ',ZZ,.TRUE.)
  ELSE
    CALL SPREORD(1,ZV,ZZ,.FALSE.)
    CALL FAIENC(IREP,NPOSSH,'S',JLEV2,'TEMPERATURE ',ZV,.TRUE.)
  ENDIF
ENDDO

!     8. VORTICITY AND DIVERGENCE

!      FOR VORTICITY AND DIVERGENCE THE ADDITIONAL BOTTOM LEVEL
!      IS SET TO ZERO. SETTING THE WIND CONSTANT INSIDE THE MOUNTAINS
!      DRIVES TO STRONG DIVERGENCE NEAR GREENLAND.

DO JLEV=1,NFLEVG
  READ(NINISH)ILMX,(ZZ(J),J=1,ILMX)
  READ(NINISH)ILMX,(ZW(J),J=1,ILMX)
  CALL SPEUV(ZZ,ZW,ZFAGGS,ZFBGGS,1,1,1)
  INDEX=0
  DO JGL=1,NDGLG
    DO JLON=1,NLOEN(JGL)
      ZVP1(INDEX+JLON,JLEV)=ZFAGGS(JLON+NSTAGP(JGL))
      ZWP1(INDEX+JLON,JLEV)=ZFBGGS(JLON+NSTAGP(JGL))
    ENDDO
    INDEX=INDEX+NLOEN(JGL)
  ENDDO
ENDDO
DO J=1,ITOGO1
  ZVP1(J,NFLEVG+1)=0.0_JPRB
  ZWP1(J,NFLEVG+1)=0.0_JPRB
ENDDO
DO JLEV2=1,INIVER
  INDEX=0
  DO JGL=1,NDGLG
    DO JLON=1,NLOEN(JGL)
      ZPP2(JLON)=ZAF2(JLEV2)+ZBF2(JLEV2)*ZPS2(JLON+INDEX)
      ILEVB(JLON)=NFLEVG+1
    ENDDO
    DO JLEV1=NFLEVG,1,-1
      DO JLON=1,NLOEN(JGL)
        IF (ZPP1(JLON+INDEX,JLEV1) >= ZPP2(JLON))THEN
          ILEVB(JLON)=JLEV1
        ENDIF
      ENDDO
    ENDDO
    DO JLON=1,NLOEN(JGL)
      IBL=ILEVB(JLON)
      IAB=MAX(1,IBL-1)
      ZWBL=(ZPP2(JLON)-ZPP1(JLON+INDEX,IAB))/MAX(1.E-9_JPRB,&
       & ZPP1(JLON+INDEX,IBL)-ZPP1(JLON+INDEX,IAB))  
      ZFAGGS(JLON+NSTAGP(JGL))=ZVP1(JLON+INDEX,IBL)*ZWBL &
       & +ZVP1(JLON+INDEX,IAB)*(1.0_JPRB-ZWBL)  
      ZFBGGS(JLON+NSTAGP(JGL))=ZWP1(JLON+INDEX,IBL)*ZWBL &
       & +ZWP1(JLON+INDEX,IAB)*(1.0_JPRB-ZWBL)  
    ENDDO
    INDEX=INDEX+NLOEN(JGL)
  ENDDO
  CALL UVSPE(ZZ,ZW,ZFAGGS,ZFBGGS,1,1,2)
  IF (INGRIB==-1 .OR. INGRIB==3) THEN
    CALL FAIENC(IREP,NPOSSH,'S',JLEV2,'FONC.COURANT',ZZ,.TRUE.)
    CALL FAIENC(IREP,NPOSSH,'S',JLEV2,'POT.VITESSE ',ZW,.TRUE.)
  ELSE
    CALL SPREORD(1,ZV,ZZ,.FALSE.)
    CALL SPREORD(1,ZX,ZW,.FALSE.)
    CALL FAIENC(IREP,NPOSSH,'S',JLEV2,'FONC.COURANT',ZV,.TRUE.)
    CALL FAIENC(IREP,NPOSSH,'S',JLEV2,'POT.VITESSE ',ZX,.TRUE.)
  ENDIF
ENDDO

!     9. HUMIDITY

!      TO AVOID EXTRAPOLATING HUMIDITY BELOW THE LOWEST LEVEL,
!      AN ADDITIONAL LEVEL IS INTRODUCED CORRESPONDING TO THE LOWER
!      SURFACE OF THE TWO GEOMETRIES. SO THE SPECIFIC HUMIDITY IS NOT
!      CONSTANT INSIDE THE MOUNTAINS OF THE SOURCE GEOMETRY

DO JLEV=1,NFLEVG
  READ(NINISH)ILMX,(ZVP1(J,JLEV),J=1,ILMX)
ENDDO
DO J=1,ITOGO1
!     THE SURFACE RELATIVE MOISTURE IS ASSUMED THAT OF THE LOWEST LEVEL
  ZTS=ZTS1(J)+MAX(0.0_JPRB,+ZDTSDO*ZOROG2C(J))
  IF(LNEIGE) THEN
    ZDELTAL=MAX(0.0_JPRB,SIGN(1.0_JPRB,RTT-ZTL1(J)))
    ZDELTAS=MAX(0.0_JPRB,SIGN(1.0_JPRB,RTT-ZTS))
  ELSE
    ZDELTAL=0.0_JPRB
    ZDELTAS=0.0_JPRB
  ENDIF
  ZESL=FOEW(ZTL1(J),ZDELTAL)
  ZESS=FOEW(ZTS,ZDELTAS)
  ZRATP=(ZESS*ZPP1(J,NFLEVG))/(ZESL*ZPP1(J,NFLEVG+1))
  ZVP1(J,NFLEVG+1)=ZRATP*ZVP1(J,NFLEVG)/&
   & (1.0_JPRB+(1.0_JPRB-ZRATP)*RETV*ZVP1(J,NFLEVG))  
ENDDO
DO JLEV2=1,INIVER
  INDEX=0
  DO JGL=1,NDGLG
    DO JLON=1,NLOEN(JGL)
      ZPP2(JLON)=ZAF2(JLEV2)+ZBF2(JLEV2)*ZPS2(JLON+INDEX)
      ILEVB(JLON)=NFLEVG+1
    ENDDO
    DO JLEV1=NFLEVG,1,-1
      DO JLON=1,NLOEN(JGL)
        IF (ZPP1(JLON+INDEX,JLEV1) >= ZPP2(JLON))THEN
          ILEVB(JLON)=JLEV1
        ENDIF
      ENDDO
    ENDDO
    DO JLON=1,NLOEN(JGL)
      IBL=ILEVB(JLON)
      IAB=MAX(1,IBL-1)
      ZWBL=(ZPP2(JLON)-ZPP1(JLON+INDEX,IAB))/MAX(1.E-9_JPRB,&
       & ZPP1(JLON+INDEX,IBL)-ZPP1(JLON+INDEX,IAB))  
      ZFAGGS(JLON+NSTAGP(JGL))=ZVP1(JLON+INDEX,IBL)*ZWBL &
       & +ZVP1(JLON+INDEX,IAB)*(1.0_JPRB-ZWBL)  
    ENDDO
    INDEX=INDEX+NLOEN(JGL)
  ENDDO
  CALL REESPE(1,1,ZZ,ZFAGGS)
  IF (INGRIB==-1 .OR. INGRIB==3) THEN
    CALL FAIENC(IREP,NPOSSH,'S',JLEV2,'HUMI.SPECIFI',ZZ,.TRUE.)
  ELSE
    CALL SPREORD(1,ZV,ZZ,.FALSE.)
    CALL FAIENC(IREP,NPOSSH,'S',JLEV2,'HUMI.SPECIFI',ZV,.TRUE.)
  ENDIF
ENDDO

!     10. SURF AND DEEP RESERVOIR

READ(NINISH)ILMX,(ZTS1(J),J=1,ILMX)
READ(NINISH)ILMX,(ZTP1(J),J=1,ILMX)
ZWPMAX=0.0_JPRB
ZWPMIN=ZTP1(1)
ZWSMAX=0.0_JPRB
ZWSMIN=ZTS1(1)
DO J=1,ITOGO1
  ZWPMAX=MAX(ZWPMAX,ZTP1(J))
  ZWPMIN=MIN(ZWPMIN,ZTP1(J))
  ZWSMAX=MAX(ZWSMAX,ZTS1(J))
  ZWSMIN=MIN(ZWSMIN,ZTS1(J))
ENDDO
!      MINIMAL MOISTURE OF THE BARE SOIL
ZWMINSO=0.02_JPRB
CALL FACILE(IREP,NULCL1,'SURF',1,'PROP.ARGILE',ZVP1(1,1),.FALSE.)
CALL FACILE(IREP,NULCL1,'SURF',1,'EPAIS.SOL',ZVP1(1,2),.FALSE.)
CALL FACILE(IREP,NULCL1,'SURF',1,'IND.VEG.DOMIN',ZVP1(1,3),.FALSE.)
CALL FACILE(IREP,NULCL1,'SURF',1,'PROP.VEGETATION',ZVP1(1,4),.FALSE.)
WRITE(NULOUT,*) '  MINI AND MAXI RESERVOIR BEFORE RESCALING '
WRITE(NULOUT,*) ' DEEP RESERVOIR MINI/MAXI  ',ZWPMIN,ZWPMAX
WRITE(NULOUT,*) ' SURFACE RESERVOIR MINI/MAXI  ',ZWSMIN,ZWSMAX
DO J=1,ITOGO2
  ZTS2(J)=ZTS1(NINT(ZTOGOS1(J)))
  ZTP2(J)=ZTP1(NINT(ZTOGOS1(J)))
  IF (NINT(ZVP1(J,3)) /= NTVGLA.AND.NINT(ZVP1(J,3)) /= NTVMER) THEN
    ZWFC=GWFC*(ZVP1(J,1)**EWFC)
    ZWWILT=GWWILT*(ZVP1(J,1)**EWWILT)
    ZWSN=MIN(ZWFC/2,ZWMINSO)
    ZCO1=ZVP1(J,4)/(ZWFC-ZWWILT)+(1-ZVP1(J,4))/(ZWFC-ZWSN)
    ZCO2=ZWWILT*ZVP1(J,4)/(ZWFC-ZWWILT)+ZWSN*(1-ZVP1(J,4))/(ZWFC-ZWSN)
!         HUMI=ZCO1*RESERV-ZCO2
    ZHS=(ZTS2(J)-ZWSMIN)/(ZWSMAX-ZWSMIN)
    ZHP=(ZTP2(J)-ZWPMIN)/(ZWPMAX-ZWPMIN)
    ZTS2(J)=(ZHS+ZCO2)/ZCO1*RD1*1000._JPRB
    ZTP2(J)=(ZHP+ZCO2)/ZCO1*ZVP1(J,2)*1000._JPRB
  ELSE
!         1000. CORRESPONDS TO THE CONVERSION OF M INTO KG/M**2
    ZTP2(J)=1000._JPRB*ZVP1(J,2)
    ZTS2(J)=1000._JPRB*RD1
    ZHP=0.0_JPRB
  ENDIF
ENDDO
CALL FAIENC(IREP,NPOSSH,'SURF',0,'RESERV.EAU  ',ZTS2,.FALSE.)
CALL FAIENC(IREP,NPOSSH,'PROF',0,'RESERV.EAU  ',ZTP2,.FALSE.)

!     11. SNOW DEPTH

READ(NINISH)ILMX,(ZTP1(J),J=1,ILMX)
DO J=1,ITOGO2
  ZTP2(J)=ZTP1(NINT(ZTOGOS1(J)))
ENDDO
CALL FAIENC(IREP,NPOSSH,'SURF',1,'RESERV.NEIGE',ZTP2,.FALSE.)

!     12. OTHER FIELDS

DO J=1,ITOGO2
  ZVP1(J,1)=0.0_JPRB
  ZVP1(J,2)=0.7_JPRB
  ZVP1(J,3)=0.3_JPRB
ENDDO
!     CALL FAIENC(IREP,NPOSSH,'SKIN',1,'RESERV.EAU',ZVP1(1,1),.FALSE.)
CALL FAIENC(IREP,NPOSSH,'SURF',1,'RESERV.INTER',ZVP1(1,1),.FALSE.)
CALL FAIENC(IREP,NPOSSH,'PROF',1,'RESERV.GLACE',ZVP1(1,1),.FALSE.)
CALL FAIENC(IREP,NPOSSH,'SURF',1,'ALBEDO NEIGE',ZVP1(1,2),.FALSE.)
CALL FAIENC(IREP,NPOSSH,'SURF',1,'DENSIT.NEIGE',ZVP1(1,3),.FALSE.)

CALL FAIRME(IREP,NULCL1,'UNKNOWN')
IF(ICOUNT == 1)THEN
  CALL LFILAF(IREP,NPOSSH,.FALSE.)
ENDIF
CALL FAIRME(IREP,NPOSSH,'UNKNOWN')
CLOSE(NINISH)
!      REPEAT THE PROGRAM UNTIL NO MORE INPUT FILES
GO TO 100
9999 CONTINUE
!      ON THE VPP, THE PROGRAM CRASHES UNEXPECTEDLY IN MATCLOSE
!      ALTHOUGH THERE IS NO MORE WORK TO DO
!      BEFORE AN EXPLANATION IS FOUND, WE STOP HERE
STOP
IF (LHOOK) CALL DR_HOOK('CPREP5',1,ZHOOK_HANDLE)
!     RETURN
END SUBROUTINE CPREP5
