Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/ICE_SRC/ice.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/ICE_SRC/ice.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/ICE_SRC/ice.F90	(revision 9570)
@@ -0,0 +1,509 @@
+MODULE ice
+   !!======================================================================
+   !!                        ***  MODULE  ice  ***
+   !!   sea-ice:  ice variables defined in memory
+   !!======================================================================
+   !! History :  3.0  ! 2008-03  (M. Vancoppenolle) original code LIM-3
+   !!            4.0  ! 2011-02  (G. Madec) dynamical allocation
+   !!----------------------------------------------------------------------
+#if defined key_si3
+   !!----------------------------------------------------------------------
+   !!   'key_si3'                                       SI3 sea-ice model
+   !!----------------------------------------------------------------------
+   USE in_out_manager ! I/O manager
+   USE lib_mpp        ! MPP library
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   ice_alloc   ! called by icestp.F90
+
+   !!======================================================================
+   !! LIM3 by the use of sweat, agile fingers and sometimes brain juice, 
+   !!  was developed in Louvain-la-Neuve by : 
+   !!    * Martin Vancoppenolle (UCL-ASTR, Belgium)
+   !!    * Sylvain Bouillon (UCL-ASTR, Belgium)
+   !!    * Miguel Angel Morales Maqueda (NOC-L, UK)
+   !! 
+   !! Based on extremely valuable earlier work by
+   !!    * Thierry Fichefet
+   !!    * Hugues Goosse
+   !!
+   !! The following persons also contributed to the code in various ways
+   !!    * Gurvan Madec, Claude Talandier, Christian Ethe (LOCEAN, France)
+   !!    * Xavier Fettweis (UCL-ASTR), Ralph Timmermann (AWI, Germany)
+   !!    * Bill Lipscomb (LANL), Cecilia Bitz (UWa) 
+   !!      and Elisabeth Hunke (LANL), USA.
+   !! 
+   !! For more info, the interested user is kindly invited to consult the following references
+   !!    For model description and validation :
+   !!    * Vancoppenolle et al., Ocean Modelling, 2008a.
+   !!    * Vancoppenolle et al., Ocean Modelling, 2008b.
+   !!    For a specific description of EVP :
+   !!    * Bouillon et al., Ocean Modelling 2009.
+   !!
+   !!    Or the reference manual, that should be available by 2011
+   !!======================================================================
+   !!                                                                     |
+   !!              I C E   S T A T E   V A R I A B L E S                  |
+   !!                                                                     |
+   !! Introduction :                                                      |
+   !! --------------                                                      |
+   !! Every ice-covered grid cell is characterized by a series of state   |
+   !! variables. To account for unresolved spatial variability in ice     |
+   !! thickness, the ice cover in divided in ice thickness categories.    |
+   !!                                                                     |
+   !! Sea ice state variables depend on the ice thickness category        |
+   !!                                                                     |
+   !! Those variables are divided into two groups                         |
+   !! * Extensive (or global) variables.                                  |
+   !!   These are the variables that are transported by all means         |
+   !! * Intensive (or equivalent) variables.                              |
+   !!   These are the variables that are either physically more           |
+   !!   meaningful and/or used in ice thermodynamics                      |
+   !!                                                                     |
+   !! Routines in icevar.F90 perform conversions                          |
+   !!  - ice_var_glo2eqv  : from global to equivalent variables           |
+   !!  - ice_var_eqv2glo  : from equivalent to global variables           |
+   !!                                                                     |
+   !! For various purposes, the sea ice state variables have sometimes    |
+   !! to be aggregated over all ice thickness categories. This operation  |
+   !! is done in :                                                        |
+   !!  - ice_var_agg                                                      |
+   !!                                                                     |
+   !! in icestp.F90, the routines that compute the changes in the ice     |
+   !! state variables are called                                          |
+   !! - ice_rhg : ice dynamics                                            |
+   !! - ice_adv : ice advection                                           |
+   !! - ice_rdgrft : ice ridging and rafting                              |
+   !! - ice_thd : ice halo-thermodynamics and creation of new ice         |
+   !! - ice_itd : thermodynamic changes in ice thickness distribution     |
+   !!                                                                     |
+   !! See the associated routines for more information                    |
+   !!                                                                     |
+   !! List of ice state variables :                                       |
+   !! -----------------------------                                       |
+   !!                                                                     |
+   !!-------------|-------------|---------------------------------|-------|
+   !!   name in   |   name in   |              meaning            | units |
+   !! 2D routines | 1D routines |                                 |       |
+   !!-------------|-------------|---------------------------------|-------|
+   !!                                                                     |
+   !! ******************************************************************* |
+   !! ***         Dynamical variables (prognostic)                    *** |
+   !! ******************************************************************* |
+   !!                                                                     |
+   !! u_ice       |      -      |    Comp. U of the ice velocity  | m/s   |
+   !! v_ice       |      -      |    Comp. V of the ice velocity  | m/s   |
+   !!                                                                     |
+   !! ******************************************************************* |
+   !! ***         Category dependent state variables (prognostic)     *** |
+   !! ******************************************************************* |
+   !!                                                                     |
+   !! ** Global variables                                                 |
+   !!-------------|-------------|---------------------------------|-------|
+   !! a_i         | a_i_1d      |    Ice concentration            |       |
+   !! v_i         |      -      |    Ice volume per unit area     | m     |
+   !! v_s         |      -      |    Snow volume per unit area    | m     |
+   !! sv_i        |      -      |    Sea ice salt content         | ppt.m |
+   !! oa_i        !      -      !    Sea ice areal age content    | s     |
+   !! e_i         !      -      !    Ice enthalpy                 | J/m2  | 
+   !!      -      ! e_i_1d      !    Ice enthalpy per unit vol.   | J/m3  | 
+   !! e_s         !      -      !    Snow enthalpy                | J/m2  | 
+   !!      -      ! e_s_1d      !    Snow enthalpy per unit vol.  | J/m3  | 
+   !!                                                                     |
+   !!-------------|-------------|---------------------------------|-------|
+   !!                                                                     |
+   !! ** Equivalent variables                                             |
+   !!-------------|-------------|---------------------------------|-------|
+   !!                                                                     |
+   !! h_i         | h_i_1d      |    Ice thickness                | m     |
+   !! h_s         ! h_s_1d      |    Snow depth                   | m     |
+   !! s_i         ! s_i_1d      |    Sea ice bulk salinity        ! ppt   |
+   !! sz_i        ! sz_i_1d     |    Sea ice salinity profile     ! ppt   |
+   !! o_i         !      -      |    Sea ice Age                  ! s     |
+   !! t_i         ! t_i_1d      |    Sea ice temperature          ! K     |
+   !! t_s         ! t_s_1d      |    Snow temperature             ! K     |
+   !! t_su        ! t_su_1d     |    Sea ice surface temperature  ! K     |
+   !!                                                                     |
+   !! notes: the ice model only sees a bulk (i.e., vertically averaged)   |
+   !!        salinity, except in thermodynamic computations, for which    |
+   !!        the salinity profile is computed as a function of bulk       |
+   !!        salinity                                                     |
+   !!                                                                     |
+   !!        the sea ice surface temperature is not associated to any     |
+   !!        heat content. Therefore, it is not a state variable and      |
+   !!        does not have to be advected. Nevertheless, it has to be     |
+   !!        computed to determine whether the ice is melting or not      |
+   !!                                                                     |
+   !! ******************************************************************* |
+   !! ***         Category-summed state variables (diagnostic)        *** |
+   !! ******************************************************************* |
+   !! at_i        | at_i_1d     |    Total ice concentration      |       |
+   !! vt_i        |      -      |    Total ice vol. per unit area | m     |
+   !! vt_s        |      -      |    Total snow vol. per unit ar. | m     |
+   !! sm_i        |      -      |    Mean sea ice salinity        | ppt   |
+   !! tm_i        |      -      |    Mean sea ice temperature     | K     |
+   !! tm_s        |      -      |    Mean snow    temperature     | K     |
+   !! et_i        !      -      !    Total ice enthalpy           | J/m2  | 
+   !! et_s        !      -      !    Total snow enthalpy          | J/m2  | 
+   !! bv_i        !      -      !    relative brine volume        | ???   | 
+   !!=====================================================================
+
+   !!----------------------------------------------------------------------
+   !! * Share Module variables
+   !!----------------------------------------------------------------------
+   !                                     !!** ice-generic parameters namelist (nampar) **
+   INTEGER           , PUBLIC ::   jpl              !: number of ice  categories 
+   INTEGER           , PUBLIC ::   nlay_i           !: number of ice  layers 
+   INTEGER           , PUBLIC ::   nlay_s           !: number of snow layers 
+   INTEGER           , PUBLIC ::   nn_virtual_itd   !: virtual ITD mono-category parameterizations (1-3) or not (0)
+   LOGICAL           , PUBLIC ::   ln_icedyn        !: flag for ice dynamics (T) or not (F)
+   LOGICAL           , PUBLIC ::   ln_icethd        !: flag for ice thermo   (T) or not (F)
+   REAL(wp)          , PUBLIC ::   rn_amax_n        !: maximum ice concentration Northern hemisphere
+   REAL(wp)          , PUBLIC ::   rn_amax_s        !: maximum ice concentration Southern hemisphere
+   CHARACTER(len=256), PUBLIC ::   cn_icerst_in     !: suffix of ice restart name (input)
+   CHARACTER(len=256), PUBLIC ::   cn_icerst_out    !: suffix of ice restart name (output)
+   CHARACTER(len=256), PUBLIC ::   cn_icerst_indir  !: ice restart input directory
+   CHARACTER(len=256), PUBLIC ::   cn_icerst_outdir !: ice restart output directory
+
+   !                                     !!** ice-itd namelist (namitd) **
+   REAL(wp), PUBLIC ::   rn_himin         !: minimum ice thickness
+   
+   !                                     !!** ice-dynamics namelist (namdyn) **
+   REAL(wp), PUBLIC ::   rn_ishlat        !: lateral boundary condition for sea-ice
+   LOGICAL , PUBLIC ::   ln_landfast      !: landfast ice parameterization (T or F) 
+   REAL(wp), PUBLIC ::   rn_gamma         !:    fraction of ocean depth that ice must reach to initiate landfast ice
+   REAL(wp), PUBLIC ::   rn_icebfr        !:    maximum bottom stress per unit area of contact (landfast ice) 
+   REAL(wp), PUBLIC ::   rn_lfrelax       !:    relaxation time scale (s-1) to reach static friction (landfast ice) 
+   !
+   !                                     !!** ice-rheology namelist (namrhg) **
+   LOGICAL , PUBLIC ::   ln_aEVP          !: using adaptive EVP (T or F) 
+   REAL(wp), PUBLIC ::   rn_creepl        !: creep limit : has to be under 1.0e-9
+   REAL(wp), PUBLIC ::   rn_ecc           !: eccentricity of the elliptical yield curve
+   INTEGER , PUBLIC ::   nn_nevp          !: number of iterations for subcycling
+   REAL(wp), PUBLIC ::   rn_relast        !: ratio => telast/rdt_ice (1/3 or 1/9 depending on nb of subcycling nevp) 
+   !
+   !                                     !!** ice-surface forcing namelist (namforcing) **
+                                          ! -- icethd_dh -- !
+   REAL(wp), PUBLIC ::   rn_blow_s        !: coef. for partitioning of snowfall between leads and sea ice
+                                          ! -- icethd -- !
+   REAL(wp), PUBLIC ::   rn_cio           !: drag coefficient for oceanic stress
+   INTEGER , PUBLIC ::   nn_flxdist       !: Redistribute heat flux over ice categories
+   !                                      !   =-1  Do nothing (needs N(cat) fluxes)
+   !                                      !   = 0  Average N(cat) fluxes then apply the average over the N(cat) ice 
+   !                                      !   = 1  Average N(cat) fluxes then redistribute over the N(cat) ice using T-ice and albedo sensitivity
+   !                                      !   = 2  Redistribute a single flux over categories
+   INTEGER , PUBLIC            ::   nice_jules           !: Choice of jules coupling 
+   INTEGER , PUBLIC, PARAMETER ::   np_jules_OFF    = 0  !: no Jules coupling (ice thermodynamics forced via qsr and qns)
+   INTEGER , PUBLIC, PARAMETER ::   np_jules_EMULE  = 1  !: emulated Jules coupling via icethd_zdf.F90 (BL99) (1st round compute qcn and qsr_tr, 2nd round use it)
+   INTEGER , PUBLIC, PARAMETER ::   np_jules_ACTIVE = 2  !: active Jules coupling                      (SM0L) (compute qcn and qsr_tr via sbcblk.F90 or sbccpl.F90)
+
+   !                                     !!** ice-vertical diffusion namelist (namthd_zdf) **
+   LOGICAL , PUBLIC ::   ln_cndi_U64      !: thermal conductivity: Untersteiner (1964)
+   LOGICAL , PUBLIC ::   ln_cndi_P07      !: thermal conductivity: Pringle et al (2007)
+   REAL(wp), PUBLIC ::   rn_kappa_i       !: coef. for the extinction of radiation Grenfell et al. (2006) [1/m]
+   REAL(wp), PUBLIC ::   rn_cnd_s         !: thermal conductivity of the snow [W/m/K]   
+
+   !                                     !!** ice-salinity namelist (namthd_sal) **
+   INTEGER , PUBLIC ::   nn_icesal        !: salinity configuration used in the model
+   !                                      ! 1 - constant salinity in both space and time
+   !                                      ! 2 - prognostic salinity (s(z,t))
+   !                                      ! 3 - salinity profile, constant in time
+   REAL(wp), PUBLIC ::   rn_icesal        !: bulk salinity (ppt) in case of constant salinity
+   REAL(wp), PUBLIC ::   rn_simax         !: maximum ice salinity [PSU]
+   REAL(wp), PUBLIC ::   rn_simin         !: minimum ice salinity [PSU]
+
+   !                                     !!** ice-ponds namelist (namthd_pnd)
+   LOGICAL , PUBLIC ::   ln_pnd_H12       !: Melt ponds scheme from Holland et al 2012
+   LOGICAL , PUBLIC ::   ln_pnd_fwb       !: melt ponds store freshwater
+   LOGICAL , PUBLIC ::   ln_pnd_CST       !: Melt ponds scheme with constant fraction and depth
+   REAL(wp), PUBLIC ::   rn_apnd          !: prescribed pond fraction (0<rn_apnd<1)
+   REAL(wp), PUBLIC ::   rn_hpnd          !: prescribed pond depth    (0<rn_hpnd<1)
+   LOGICAL , PUBLIC ::   ln_pnd_alb       !: melt ponds affect albedo
+
+   !                                     !!** ice-diagnostics namelist (namdia) **
+   LOGICAL , PUBLIC ::   ln_icediachk     !: flag for ice diag (T) or not (F)
+   LOGICAL , PUBLIC ::   ln_icediahsb     !: flag for ice diag (T) or not (F)
+   LOGICAL , PUBLIC ::   ln_icectl        !: flag for sea-ice points output (T) or not (F)
+   INTEGER , PUBLIC ::   iiceprt          !: debug i-point
+   INTEGER , PUBLIC ::   jiceprt          !: debug j-point
+
+   !                                     !!** some other parameters 
+   INTEGER , PUBLIC ::   kt_ice           !: iteration number
+   REAL(wp), PUBLIC ::   rdt_ice          !: ice time step
+   REAL(wp), PUBLIC ::   r1_rdtice        !: = 1. / rdt_ice
+   REAL(wp), PUBLIC ::   r1_nlay_i        !: 1 / nlay_i
+   REAL(wp), PUBLIC ::   r1_nlay_s        !: 1 / nlay_s 
+   REAL(wp), PUBLIC ::   rswitch          !: switch for the presence of ice (1) or not (0)
+   REAL(wp), PUBLIC ::   rdiag_v, rdiag_s, rdiag_t, rdiag_fv, rdiag_fs, rdiag_ft   !: conservation diagnostics
+   REAL(wp), PUBLIC, PARAMETER ::   epsi06 = 1.e-06_wp  !: small number 
+   REAL(wp), PUBLIC, PARAMETER ::   epsi10 = 1.e-10_wp  !: small number 
+   REAL(wp), PUBLIC, PARAMETER ::   epsi20 = 1.e-20_wp  !: small number 
+
+
+   !                                     !!** define arrays
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   u_oce,v_oce !: surface ocean velocity used in ice dynamics
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   ht_i_new    !: ice collection thickness accreted in leads
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   strength    !: ice strength
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   stress1_i, stress2_i, stress12_i   !: 1st, 2nd & diagonal stress tensor element
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   delta_i     !: ice rheology elta factor (Flato & Hibler 95) [s-1]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   divu_i      !: Divergence of the velocity field [s-1]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   shear_i     !: Shear of the velocity field [s-1]
+   !
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   t_bo        !: Sea-Ice bottom temperature [Kelvin]     
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   qlead       !: heat balance of the lead (or of the open ocean)
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   fhtur       !: net downward heat flux from the ice to the ocean
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   fhld        !: heat flux from the lead used for bottom melting
+
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_snw     !: snow-ocean mass exchange   [kg.m-2.s-1]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_snw_sni !: snow ice growth component of wfx_snw [kg.m-2.s-1]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_snw_sum !: surface melt component of wfx_snw [kg.m-2.s-1]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_pnd     !: melt pond-ocean mass exchange   [kg.m-2.s-1]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_spr     !: snow precipitation on ice  [kg.m-2.s-1]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_sub     !: sublimation of snow/ice    [kg.m-2.s-1]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_snw_sub !: snow sublimation           [kg.m-2.s-1]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_ice_sub !: ice sublimation            [kg.m-2.s-1]
+
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_snw_dyn !: dynamical component of wfx_snw    [kg.m-2.s-1]
+
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_ice     !: ice-ocean mass exchange                   [kg.m-2.s-1]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_sni     !: snow ice growth component of wfx_ice      [kg.m-2.s-1]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_opw     !: lateral ice growth component of wfx_ice   [kg.m-2.s-1]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_bog     !: bottom ice growth component of wfx_ice    [kg.m-2.s-1]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_dyn     !: dynamical ice growth component of wfx_ice [kg.m-2.s-1]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_bom     !: bottom melt component of wfx_ice          [kg.m-2.s-1]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_sum     !: surface melt component of wfx_ice         [kg.m-2.s-1]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_lam     !: lateral melt component of wfx_ice         [kg.m-2.s-1]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_res     !: residual component of wfx_ice             [kg.m-2.s-1]
+
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   afx_tot     !: ice concentration tendency (total)          [s-1]
+
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   sfx_bog     !: salt flux due to ice growth/melt                      [PSU/m2/s]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   sfx_bom     !: salt flux due to ice growth/melt                      [PSU/m2/s]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   sfx_lam     !: salt flux due to ice growth/melt                      [PSU/m2/s]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   sfx_sum     !: salt flux due to ice growth/melt                      [PSU/m2/s]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   sfx_sni     !: salt flux due to ice growth/melt                      [PSU/m2/s]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   sfx_opw     !: salt flux due to ice growth/melt                      [PSU/m2/s]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   sfx_bri     !: salt flux due to brine rejection                      [PSU/m2/s]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   sfx_dyn     !: salt flux due to porous ridged ice formation          [PSU/m2/s]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   sfx_res     !: residual salt flux due to correction of ice thickness [PSU/m2/s]
+
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   sfx_sub     !: salt flux due to ice sublimation
+
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_bog     !: total heat flux causing bottom ice growth        [W.m-2]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_bom     !: total heat flux causing bottom ice melt          [W.m-2]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_sum     !: total heat flux causing surface ice melt         [W.m-2]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_opw     !: total heat flux causing open water ice formation [W.m-2]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_dif     !: total heat flux causing Temp change in the ice   [W.m-2]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_snw     !: heat flux for snow melt                          [W.m-2]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_err_dif !: heat flux remaining due to change in non-solar flux [W.m-2]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_err_rem !: heat flux error after heat remapping             [W.m-2]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_in      !: heat flux available for thermo transformations   [W.m-2]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_out     !: heat flux remaining at the end of thermo transformations  [W.m-2]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_err_sub !: mass flux error after sublimation [kg.m-2.s-1]
+   
+   ! heat flux associated with ice-atmosphere mass exchange
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_sub     !: heat flux for sublimation  [W.m-2]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_spr     !: heat flux of the snow precipitation  [W.m-2]
+
+   ! heat flux associated with ice-ocean mass exchange
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_thd     !: ice-ocean heat flux from thermo processes (icethd_dh) [W.m-2]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_dyn     !: ice-ocean heat flux from ridging                      [W.m-2]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_res     !: residual heat flux due to correction of ice thickness [W.m-2]
+
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   rn_amax_2d     !: maximum ice concentration 2d array
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   ftr_ice        !: transmitted solar radiation under ice
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   t1_ice         !: temperature of the first layer (Jules coupling) [K]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   cnd_ice        !: effective conductivity at the top of ice/snow (Jules coupling) [W.m-2.K-1]
+
+   !!----------------------------------------------------------------------
+   !! * Ice global state variables
+   !!----------------------------------------------------------------------
+   !! Variables defined for each ice category
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   h_i       !: Ice thickness (m)
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   a_i       !: Ice fractional areas (concentration)
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   v_i       !: Ice volume per unit area (m)
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   v_s       !: Snow volume per unit area(m)
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   h_s       !: Snow thickness (m)
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   t_su      !: Sea-Ice Surface Temperature (K)
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   s_i       !: Sea-Ice Bulk salinity (ppt)
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   sv_i      !: Sea-Ice Bulk salinity times volume per area (ppt.m)
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   o_i       !: Sea-Ice Age (s)
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   oa_i      !: Sea-Ice Age times ice area (s)
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   bv_i      !: brine volume
+
+   !! Variables summed over all categories, or associated to all the ice in a single grid cell
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   u_ice, v_ice !: components of the ice velocity (m/s)
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   vt_i , vt_s  !: ice and snow total volume per unit area (m)
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   at_i         !: ice total fractional area (ice concentration)
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   ato_i        !: =1-at_i ; total open water fractional area
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   et_i , et_s  !: ice and snow total heat content
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   tm_i         !: mean ice temperature over all categories
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   tm_s         !: mean snw temperature over all categories
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   bvm_i        !: brine volume averaged over all categories
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   sm_i         !: mean sea ice salinity averaged over all categories [PSU]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   tm_su        !: mean surface temperature over all categories
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hm_i         !: mean ice  thickness over all categories
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hm_s         !: mean snow thickness over all categories
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   om_i         !: mean ice age over all categories
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   tau_icebfr   !: ice friction with bathy (landfast param activated)
+
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) ::   t_s      !: Snow temperatures     [K]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) ::   e_s      !: Snow enthalpy         [J/m2]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) ::   t_i      !: ice temperatures      [K]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) ::   e_i      !: ice enthalpy          [J/m2]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) ::   sz_i     !: ice salinity          [PSU]
+
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   a_ip       !: melt pond fraction per grid cell area
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   v_ip       !: melt pond volume per grid cell area [m]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   a_ip_frac  !: melt pond volume per ice area
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   h_ip       !: melt pond thickness [m]
+
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   at_ip      !: total melt pond fraction
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   vt_ip      !: total melt pond volume per unit area [m]
+
+   !!----------------------------------------------------------------------
+   !! * Old values of global variables
+   !!----------------------------------------------------------------------
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)   ::   v_s_b, v_i_b, h_s_b, h_i_b    !: snow and ice volumes/thickness
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)   ::   a_i_b, sv_i_b, oa_i_b         !:
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) ::   e_s_b                         !: snow heat content
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) ::   e_i_b                         !: ice temperatures
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)     ::   u_ice_b, v_ice_b              !: ice velocity
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)     ::   at_i_b                        !: ice concentration (total)
+            
+   !!----------------------------------------------------------------------
+   !! * Ice thickness distribution variables
+   !!----------------------------------------------------------------------
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   hi_max         !: Boundary of ice thickness categories in thickness space
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   hi_mean        !: Mean ice thickness in catgories 
+   !
+   !!----------------------------------------------------------------------
+   !! * Ice diagnostics
+   !!----------------------------------------------------------------------
+   ! thd refers to changes induced by thermodynamics
+   ! trp   ''         ''     ''       advection (transport of ice)
+   !
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   diag_trp_vi   !: transport of ice volume
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   diag_trp_vs   !: transport of snw volume
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   diag_trp_ei   !: transport of ice enthalpy (W/m2)
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   diag_trp_es   !: transport of snw enthalpy (W/m2)
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   diag_trp_sv   !: transport of salt content
+   !
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   diag_heat     !: snw/ice heat content variation   [W/m2] 
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   diag_sice     !: ice salt content variation   [] 
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   diag_vice     !: ice volume variation   [m/s] 
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   diag_vsnw     !: snw volume variation   [m/s] 
+
+   !
+   !!----------------------------------------------------------------------
+   !! * SIMIP extra diagnostics
+   !!----------------------------------------------------------------------
+   ! Extra sea ice diagnostics to address the data request
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   t_si          !: Temperature at Snow-ice interface (K) 
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   tm_si         !: mean temperature at the snow-ice interface (K) 
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   diag_fc_bo    !: Bottom conduction flux (W/m2)
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   diag_fc_su    !: Surface conduction flux (W/m2)
+
+   !
+   !!----------------------------------------------------------------------
+   !! NEMO/ICE 4.0 , NEMO Consortium (2017)
+   !! $Id$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   FUNCTION ice_alloc()
+      !!-----------------------------------------------------------------
+      !!               *** Routine ice_alloc ***
+      !!-----------------------------------------------------------------
+      INTEGER :: ice_alloc
+      !
+      INTEGER :: ierr(18), ii
+      !!-----------------------------------------------------------------
+
+      ierr(:) = 0
+
+      ! What could be one huge allocate statement is broken-up to try to
+      ! stay within Fortran's max-line length limit.
+      ii = 1
+      ALLOCATE( u_oce   (jpi,jpj) , v_oce    (jpi,jpj) , ht_i_new (jpi,jpj) ,                        &
+         &      strength(jpi,jpj) , stress1_i(jpi,jpj) , stress2_i(jpi,jpj) , stress12_i(jpi,jpj) ,  &
+         &      delta_i (jpi,jpj) , divu_i   (jpi,jpj) , shear_i  (jpi,jpj) , STAT=ierr(ii) )
+
+      ii = ii + 1
+      ALLOCATE( t_bo   (jpi,jpj) , wfx_snw_sni(jpi,jpj) ,                                                &
+         &      wfx_snw(jpi,jpj) , wfx_snw_dyn(jpi,jpj) , wfx_snw_sum(jpi,jpj) , wfx_snw_sub(jpi,jpj) ,  &
+         &      wfx_ice(jpi,jpj) , wfx_sub    (jpi,jpj) , wfx_ice_sub(jpi,jpj) , wfx_lam    (jpi,jpj) ,  &
+         &      wfx_pnd(jpi,jpj) ,                                                              &
+         &      wfx_bog(jpi,jpj) , wfx_dyn(jpi,jpj) , wfx_bom(jpi,jpj) , wfx_sum(jpi,jpj) ,     &
+         &      wfx_res(jpi,jpj) , wfx_sni(jpi,jpj) , wfx_opw(jpi,jpj) , wfx_spr(jpi,jpj) ,     &
+         &      afx_tot(jpi,jpj) , rn_amax_2d(jpi,jpj),                                         &
+         &      fhtur  (jpi,jpj) , qlead  (jpi,jpj) ,                                           &
+         &      sfx_res(jpi,jpj) , sfx_bri(jpi,jpj) , sfx_dyn(jpi,jpj) , sfx_sub(jpi,jpj) , sfx_lam(jpi,jpj) ,  &
+         &      sfx_bog(jpi,jpj) , sfx_bom(jpi,jpj) , sfx_sum(jpi,jpj) , sfx_sni(jpi,jpj) , sfx_opw(jpi,jpj) ,  &
+         &      hfx_res(jpi,jpj) , hfx_snw(jpi,jpj) , hfx_sub(jpi,jpj) ,     & 
+         &      hfx_in (jpi,jpj) , hfx_out(jpi,jpj) , fhld   (jpi,jpj) ,                        &
+         &      hfx_sum(jpi,jpj) , hfx_bom(jpi,jpj) , hfx_bog(jpi,jpj) , hfx_dif(jpi,jpj) ,     &
+         &      hfx_opw(jpi,jpj) , hfx_thd(jpi,jpj) , hfx_dyn(jpi,jpj) , hfx_spr(jpi,jpj) ,     &
+         &      hfx_err_dif(jpi,jpj) , hfx_err_rem(jpi,jpj) , wfx_err_sub(jpi,jpj)        ,  STAT=ierr(ii) )
+
+      ! * Ice global state variables
+      ii = ii + 1
+      ALLOCATE( ftr_ice(jpi,jpj,jpl) , cnd_ice(jpi,jpj,jpl) , t1_ice(jpi,jpj,jpl) , &
+         &      h_i (jpi,jpj,jpl) , a_i (jpi,jpj,jpl) , v_i (jpi,jpj,jpl) ,     &
+         &      v_s (jpi,jpj,jpl) , h_s (jpi,jpj,jpl) , t_su(jpi,jpj,jpl) ,     &
+         &      s_i (jpi,jpj,jpl) , sv_i(jpi,jpj,jpl) , o_i (jpi,jpj,jpl) ,     &
+         &      oa_i(jpi,jpj,jpl) , bv_i(jpi,jpj,jpl) ,  STAT=ierr(ii) )
+      ii = ii + 1
+      ALLOCATE( u_ice(jpi,jpj) , v_ice(jpi,jpj) ,                                      &
+         &      vt_i (jpi,jpj) , vt_s (jpi,jpj) , at_i(jpi,jpj) , ato_i(jpi,jpj) ,     &
+         &      et_i (jpi,jpj) , et_s (jpi,jpj) , tm_i(jpi,jpj) , tm_s (jpi,jpj) , bvm_i(jpi,jpj) ,  &
+         &      sm_i (jpi,jpj) , tm_su(jpi,jpj) , hm_i(jpi,jpj) , hm_s (jpi,jpj) ,     &
+         &      om_i (jpi,jpj) , tau_icebfr(jpi,jpj)                             , STAT=ierr(ii) )
+      ii = ii + 1
+      ALLOCATE( t_s(jpi,jpj,nlay_s,jpl) , e_s(jpi,jpj,nlay_s,jpl) , STAT=ierr(ii) )
+      ii = ii + 1
+      ALLOCATE( t_i(jpi,jpj,nlay_i,jpl) , e_i(jpi,jpj,nlay_i,jpl) , sz_i(jpi,jpj,nlay_i,jpl) , STAT=ierr(ii) )
+
+      ii = ii + 1
+      ALLOCATE( a_ip(jpi,jpj,jpl) , v_ip(jpi,jpj,jpl) , a_ip_frac(jpi,jpj,jpl) , h_ip(jpi,jpj,jpl) , STAT = ierr(ii) )
+      ii = ii + 1
+      ALLOCATE( at_ip(jpi,jpj) , vt_ip(jpi,jpj) , STAT = ierr(ii) )
+
+      ! * Old values of global variables
+      ii = ii + 1
+      ALLOCATE( v_s_b  (jpi,jpj,jpl) , v_i_b (jpi,jpj,jpl) , h_s_b(jpi,jpj,jpl)        , h_i_b(jpi,jpj,jpl)        ,   &
+         &      a_i_b  (jpi,jpj,jpl) , sv_i_b(jpi,jpj,jpl) , e_i_b(jpi,jpj,nlay_i,jpl) , e_s_b(jpi,jpj,nlay_s,jpl) ,   &
+         &      oa_i_b (jpi,jpj,jpl)                                                   , STAT=ierr(ii) )
+      ii = ii + 1
+      ALLOCATE( u_ice_b(jpi,jpj) , v_ice_b(jpi,jpj) , at_i_b(jpi,jpj) , STAT=ierr(ii) )
+      
+      ! * Ice thickness distribution variables
+      ii = ii + 1
+      ALLOCATE( hi_max(0:jpl), hi_mean(jpl),  STAT=ierr(ii) )
+
+      ! * Ice diagnostics
+      ii = ii + 1
+      ALLOCATE( diag_trp_vi(jpi,jpj) , diag_trp_vs (jpi,jpj) , diag_trp_ei(jpi,jpj),   & 
+         &      diag_trp_es(jpi,jpj) , diag_trp_sv (jpi,jpj) , diag_heat  (jpi,jpj),   &
+         &      diag_sice  (jpi,jpj) , diag_vice   (jpi,jpj) , diag_vsnw  (jpi,jpj), STAT=ierr(ii) )
+
+      ! * SIMIP diagnostics
+      ii = ii + 1
+      ALLOCATE( t_si (jpi,jpj,jpl) , tm_si(jpi,jpj) , diag_fc_bo(jpi,jpj) , diag_fc_su(jpi,jpj) , STAT = ierr(ii) )
+
+      ice_alloc = MAXVAL( ierr(:) )
+      IF( ice_alloc /= 0 )   CALL ctl_warn('ice_alloc: failed to allocate arrays.')
+      !
+   END FUNCTION ice_alloc
+
+#else
+   !!----------------------------------------------------------------------
+   !!   Default option         Empty module           NO SI3 sea-ice model
+   !!----------------------------------------------------------------------
+#endif
+
+   !!======================================================================
+END MODULE ice
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/ICE_SRC/ice1d.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/ICE_SRC/ice1d.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/ICE_SRC/ice1d.F90	(revision 9570)
@@ -0,0 +1,245 @@
+MODULE ice1D
+   !!======================================================================
+   !!                       ***  MODULE ice1D  ***
+   !! sea-ice :   Ice thermodynamics variables in 1D
+   !!=====================================================================
+   !! History :  3.0  !  2002-11  (C. Ethe)  F90: Free form and module
+   !!----------------------------------------------------------------------
+#if defined key_si3
+   !!----------------------------------------------------------------------
+   !!   'key_si3'                                       SI3 sea-ice model
+   !!----------------------------------------------------------------------
+   USE ice     , ONLY :   nlay_i, nlay_s, jpl   ! number of ice/snow layers and categories
+   !
+   USE in_out_manager ! I/O manager
+   USE lib_mpp        ! MPP library
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   ice1D_alloc   ! called by icestp.F90
+
+   !!----------------------
+   !! * 1D Module variables
+   !!----------------------
+   !: In ice thermodynamics, to spare memory, the vectors are folded
+   !: from 1D to 2D vectors. The following variables, with ending _1d
+   !: are the variables corresponding to 2d vectors
+
+   INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   nptidx !: selected points for ice thermo
+   INTEGER , PUBLIC                                  ::   npti   !  number of selected points
+
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   qlead_1d     
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   ftr_ice_1d   
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   qsr_ice_1d  
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   qns_ice_1d  
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   t_bo_1d     
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   rn_amax_1d
+   
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   qml_ice_1d     !: heat available for snow / ice surface melting [W/m2] 
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   qcn_ice_1d     !: heat available for snow / ice surface sublimation [W/m2] 
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   qsr_ice_tr_1d  !: solar flux transmitted below the ice surface [W/m2] 
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   t1_ice_1d      !: temperature of the 1st layer (Jules coupling) [K]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   cnd_ice_1d     !: conductivity at the top of ice/snow (Jules coupling) [W/K/m2]
+
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   hfx_sum_1d
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   hfx_bom_1d
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   hfx_bog_1d
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   hfx_dif_1d
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   hfx_opw_1d
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   hfx_snw_1d
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   hfx_dyn_1d
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   hfx_err_rem_1d
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   hfx_err_dif_1d
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   hfx_out_1d
+
+   ! heat flux associated with ice-atmosphere mass exchange
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   hfx_sub_1d
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   hfx_spr_1d
+
+   ! heat flux associated with ice-ocean mass exchange
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   hfx_thd_1d
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   hfx_res_1d
+
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   wfx_snw_sni_1d 
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   wfx_snw_sum_1d
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   wfx_snw_dyn_1d
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   wfx_sub_1d
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   wfx_snw_sub_1d 
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   wfx_ice_sub_1d 
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   wfx_err_sub_1d 
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   wfx_lam_1d 
+
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   wfx_bog_1d    
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   wfx_bom_1d   
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   wfx_sum_1d  
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   wfx_sni_1d 
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   wfx_opw_1d
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   wfx_res_1d 
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   wfx_spr_1d
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   wfx_dyn_1d
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   wfx_pnd_1d
+
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   sfx_bri_1d
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   sfx_bog_1d    
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   sfx_bom_1d    
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   sfx_sum_1d    
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   sfx_sni_1d    
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   sfx_opw_1d   
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   sfx_res_1d  
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   sfx_sub_1d
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   sfx_lam_1d
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   sfx_dyn_1d
+
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   sprecip_1d    !: <==> the 2D  sprecip
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   at_i_1d       !: <==> the 2D  at_i
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   ato_i_1d      !: <==> the 2D  ato_i
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   fhtur_1d      !: <==> the 2D  fhtur
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   fhld_1d       !: <==> the 2D  fhld
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   dqns_ice_1d   !: <==> the 2D  dqns_ice
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   evap_ice_1d   !: <==> the 2D  evap_ice
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   qprec_ice_1d  !: <==> the 2D  qprec_ice
+
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   t_su_1d       !: <==> the 2D  t_su
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   t_si_1d       !: <==> the 2D  t_si
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   a_i_1d        !: <==> the 2D  a_i
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   a_ib_1d       !: <==> the 2D  a_i_b
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   h_i_1d        !:
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   h_ib_1d       !:
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   h_s_1d        !:
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   fc_su         !: Surface Conduction flux 
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   fc_bo_i       !: Bottom  Conduction flux 
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   dh_s_tot      !: Snow accretion/ablation        [m]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   dh_i_surf     !: Ice surface accretion/ablation [m]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   dh_i_sub      !: Ice surface sublimation [m]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   dh_i_bott     !: Ice bottom accretion/ablation  [m]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   dh_s_mlt      !: Snow melt [m]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   dh_snowice    !: Snow ice formation             [m of ice]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   s_i_1d        !: Ice bulk salinity [ppt]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   s_i_new       !: Salinity of new ice at the bottom
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   v_i_1d        !:
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   v_s_1d        !:
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   sv_i_1d       !:
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   oa_i_1d       !:
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   a_ip_1d       !:
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   v_ip_1d       !:
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   h_ip_1d       !:
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   a_ip_frac_1d  !:
+
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   t_s_1d      !: corresponding to the 2D var  t_s
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   t_i_1d      !: corresponding to the 2D var  t_i
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   sz_i_1d     !: profiled ice salinity
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   e_i_1d      !:    Ice  enthalpy per unit volume
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   e_s_1d      !:    Snow enthalpy per unit volume
+
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   eh_i_old    !: ice heat content (q*h, J.m-2)
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   h_i_old     !: ice thickness layer (m)
+
+   ! Conduction flux diagnostics (SIMIP)
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   diag_fc_bo_1d      !: <==> the 2D  diag_fc_bo
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   diag_fc_su_1d      !: <==> the 2D  diag_fc_su
+
+   ! surface fields from the ocean
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   sst_1d
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   sss_1d
+
+   ! 
+   !!----------------------
+   !! * 2D Module variables
+   !!----------------------
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   a_i_2d 
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   v_i_2d 
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   v_s_2d 
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   oa_i_2d 
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   sv_i_2d 
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   a_ip_2d
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   v_ip_2d 
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   t_su_2d 
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   h_i_2d
+
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   a_ib_2d
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   h_ib_2d
+   
+   !!----------------------------------------------------------------------
+   !! NEMO/ICE 4.0 , NEMO Consortium (2017)
+   !! $Id: ice1D.F90 8379 2017-07-26 15:35:49Z clem $
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   FUNCTION ice1D_alloc()
+      !!---------------------------------------------------------------------!
+      !!                ***  ROUTINE ice1D_alloc ***
+      !!---------------------------------------------------------------------!
+      INTEGER ::   ice1D_alloc   ! return value
+      INTEGER ::   ierr(7), ii
+      !!---------------------------------------------------------------------!
+      ierr(:) = 0
+
+      ii = 1
+      ALLOCATE( nptidx    (jpij) ,   &
+         &      qlead_1d  (jpij) , ftr_ice_1d(jpij) , qsr_ice_1d (jpij) ,   &
+         &      qns_ice_1d(jpij) ,   &
+         &      qml_ice_1d(jpij) , qcn_ice_1d(jpij) , qsr_ice_tr_1d(jpij) , &
+         &      cnd_ice_1d(jpij) , t1_ice_1d(jpij)  , t_bo_1d   (jpij) ,      &
+         &      hfx_sum_1d(jpij) , hfx_bom_1d(jpij) , hfx_bog_1d(jpij) ,    & 
+         &      hfx_dif_1d(jpij) , hfx_opw_1d(jpij) , hfx_dyn_1d(jpij) ,    &
+         &      rn_amax_1d(jpij) ,                                         &
+         &      hfx_thd_1d(jpij) , hfx_spr_1d(jpij) ,                      &
+         &      hfx_snw_1d(jpij) , hfx_sub_1d(jpij) ,                      &
+         &      hfx_res_1d(jpij) , hfx_err_rem_1d(jpij) , hfx_err_dif_1d(jpij) , hfx_out_1d(jpij), STAT=ierr(ii) )
+      !
+      ii = ii + 1
+      ALLOCATE( sprecip_1d (jpij) , at_i_1d    (jpij) , ato_i_1d(jpij) ,                    &
+         &      fhtur_1d   (jpij) , wfx_snw_sni_1d (jpij) , wfx_spr_1d (jpij) , wfx_snw_sum_1d(jpij) , &
+         &      fhld_1d    (jpij) , wfx_sub_1d (jpij) , wfx_bog_1d (jpij) , wfx_bom_1d(jpij) ,  &
+         &      wfx_sum_1d(jpij)  , wfx_sni_1d (jpij) , wfx_opw_1d (jpij) , wfx_res_1d(jpij) ,  &
+         &      wfx_snw_sub_1d(jpij), wfx_snw_dyn_1d(jpij), wfx_ice_sub_1d(jpij), wfx_err_sub_1d(jpij) ,   &
+         &      wfx_lam_1d(jpij)  , wfx_dyn_1d(jpij), wfx_pnd_1d(jpij),dqns_ice_1d(jpij) , evap_ice_1d (jpij),   &
+         &      qprec_ice_1d(jpij),                                                             &  
+         &      sfx_bri_1d (jpij) , sfx_bog_1d (jpij) , sfx_bom_1d (jpij) , sfx_sum_1d (jpij),  &
+         &      sfx_sni_1d (jpij) , sfx_opw_1d (jpij) , sfx_res_1d (jpij) , sfx_sub_1d (jpij),  &
+         &      sfx_lam_1d (jpij) , sfx_dyn_1d(jpij)  , STAT=ierr(ii) )
+      !
+      ii = ii + 1
+      ALLOCATE( t_su_1d  (jpij) , t_si_1d   (jpij) , a_i_1d  (jpij) , a_ib_1d(jpij) ,                  &
+         &      h_i_1d  (jpij) , h_ib_1d  (jpij) , h_s_1d (jpij) , fc_su  (jpij) , fc_bo_i(jpij) ,  &    
+         &      dh_s_tot (jpij) , dh_i_surf (jpij) , dh_i_sub(jpij) ,                                  &    
+         &      dh_i_bott(jpij) , dh_s_mlt(jpij), dh_snowice(jpij) , s_i_1d (jpij) , s_i_new(jpij) , &
+         &      a_ip_1d  (jpij) , v_ip_1d   (jpij) , v_i_1d  (jpij) , v_s_1d (jpij) , &
+         &      h_ip_1d  (jpij) , a_ip_frac_1d(jpij) , &
+         &      sv_i_1d (jpij) , oa_i_1d   (jpij) , STAT=ierr(ii) )
+      !
+      ii = ii + 1
+      ALLOCATE( t_s_1d  (jpij,nlay_s)     , t_i_1d (jpij,nlay_i)     , sz_i_1d(jpij,nlay_i) ,  &            
+         &      e_i_1d  (jpij,nlay_i)     , e_s_1d (jpij,nlay_s)     ,                        &
+         &      eh_i_old(jpij,0:nlay_i+1) , h_i_old(jpij,0:nlay_i+1) , STAT=ierr(ii) )
+      !
+      ii = ii + 1
+      ALLOCATE( diag_fc_bo_1d(jpij)      , diag_fc_su_1d(jpij)      , STAT=ierr(ii) )
+      !
+      ii = ii + 1
+      ALLOCATE( sst_1d(jpij) , sss_1d(jpij) , STAT=ierr(ii) )
+      !
+      ii = ii + 1
+      ALLOCATE( a_i_2d(jpij,jpl) , a_ib_2d(jpij,jpl) , h_i_2d(jpij,jpl) , h_ib_2d(jpij,jpl) , &
+         &      v_i_2d(jpij,jpl) ,v_s_2d(jpij,jpl) ,oa_i_2d(jpij,jpl) ,sv_i_2d(jpij,jpl) ,  &
+         &      a_ip_2d(jpij,jpl) ,v_ip_2d(jpij,jpl) ,t_su_2d(jpij,jpl) ,  &
+         &      STAT=ierr(ii) )
+
+      ice1D_alloc = MAXVAL( ierr(:) )
+      IF( ice1D_alloc /= 0 )   CALL ctl_warn( 'ice1D_alloc: failed to allocate arrays.' )
+      !
+   END FUNCTION ice1D_alloc
+   
+#else
+   !!----------------------------------------------------------------------
+   !!   Default option :         Empty module         NO SI3 sea-ice model
+   !!----------------------------------------------------------------------
+CONTAINS
+   SUBROUTINE ice1D_alloc          ! Empty routine
+   END SUBROUTINE ice1D_alloc
+#endif
+ 
+   !!======================================================================
+END MODULE ice1D
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/ICE_SRC/icealb.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/ICE_SRC/icealb.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/ICE_SRC/icealb.F90	(revision 9570)
@@ -0,0 +1,222 @@
+MODULE icealb
+   !!======================================================================
+   !!                       ***  MODULE  icealb  ***
+   !! Atmospheric forcing:  Albedo over sea ice
+   !!=====================================================================
+   !! History :  4.0  ! 2017-07  (C. Rousset) Split ice and ocean albedos
+   !!----------------------------------------------------------------------
+#if defined key_si3
+   !!----------------------------------------------------------------------
+   !!   'key_si3'                                       SI3 sea-ice model
+   !!----------------------------------------------------------------------
+   !!   ice_alb        : albedo for ice (clear and overcast skies)
+   !!   ice_alb_init   : initialisation of albedo computation
+   !!----------------------------------------------------------------------
+   USE ice, ONLY: jpl ! sea-ice: number of categories
+   USE phycst         ! physical constants
+   !
+   USE in_out_manager ! I/O manager
+   USE lib_mpp        ! MPP library
+   USE lib_fortran    ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined)  
+   USE timing         ! Timing
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   ice_alb_init   ! called in icestp
+   PUBLIC   ice_alb        ! called in iceforcing.F90 and iceupdate.F90
+
+   REAL(wp), PUBLIC, PARAMETER ::   rn_alb_oce = 0.066   !: ocean or lead albedo (Pegau and Paulson, Ann. Glac. 2001)
+
+   REAL(wp) , PARAMETER ::   ppc1    = 0.05    ! snow thickness (only for nn_ice_alb=0)
+   REAL(wp) , PARAMETER ::   ppc2    = 0.10    !  "        "
+   REAL(wp) , PARAMETER ::   ppcloud = 0.06    ! cloud effect on albedo (only-for nn_ice_alb=0)
+   REAL(wp) , PARAMETER ::   pp1_c1 = 1. / ppc1
+   REAL(wp) , PARAMETER ::   pp1_c2 = 1. / ppc2
+   !
+   !                             !!* albedo namelist (namalb)
+   REAL(wp) ::   rn_alb_sdry      ! dry snow albedo
+   REAL(wp) ::   rn_alb_smlt      ! melting snow albedo
+   REAL(wp) ::   rn_alb_idry      ! dry ice albedo
+   REAL(wp) ::   rn_alb_imlt      ! bare puddled ice albedo
+   REAL(wp) ::   rn_alb_dpnd      ! ponded ice albedo
+
+   !!----------------------------------------------------------------------
+   !! NEMO/ICE 4.0 , NEMO Consortium (2017)
+   !! $Id: icealb.F90 8268 2017-07-03 15:01:04Z clem $
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE ice_alb( pt_su, ph_ice, ph_snw, ld_pnd_alb, pafrac_pnd, ph_pnd, palb_cs, palb_os )
+      !!----------------------------------------------------------------------
+      !!               ***  ROUTINE ice_alb  ***
+      !!          
+      !! ** Purpose :   Computation of the albedo of the snow/ice system 
+      !!       
+      !! ** Method  :   The scheme is "home made" (for cloudy skies) and based on Brandt et al. (J. Climate 2005)
+      !!                                                                      and Grenfell & Perovich (JGR 2004)
+      !!                  1) Albedo dependency on ice thickness follows the findings from Brandt et al (2005)
+      !!                     which are an update of Allison et al. (JGR 1993) ; Brandt et al. 1999
+      !!                     0-5cm  : linear function of ice thickness
+      !!                     5-150cm: log    function of ice thickness
+      !!                     > 150cm: constant
+      !!                  2) Albedo dependency on snow thickness follows the findings from Grenfell & Perovich (2004)
+      !!                     i.e. it increases as -EXP(-snw_thick/0.02) during freezing and -EXP(-snw_thick/0.03) during melting
+      !!                  3) Albedo dependency on clouds is speculated from measurements of Grenfell and Perovich (2004)
+      !!                     i.e. cloudy-clear albedo depend on cloudy albedo following a 2d order polynomial law
+      !!                  4) The needed 4 parameters are: dry and melting snow, freezing ice and bare puddled ice
+      !!
+      !!                     compilation of values from literature (reference overcast sky values)
+      !!                        rn_alb_sdry = 0.85      ! dry snow
+      !!                        rn_alb_smlt = 0.75      ! melting snow
+      !!                        rn_alb_idry = 0.60      ! bare frozen ice
+      !!                        rn_alb_imlt = 0.50      ! bare puddled ice albedo
+      !!                        rn_alb_dpnd = 0.36      ! ponded-ice overcast albedo (Lecomte et al, 2015)
+      !!                                                ! early melt pnds 0.27, late melt ponds 0.14 Grenfell & Perovich
+      !!                     Perovich et al 2002 (Sheba) => the only dataset for which all types of ice/snow were retrieved
+      !!                        rn_alb_sdry = 0.85      ! dry snow
+      !!                        rn_alb_smlt = 0.72      ! melting snow
+      !!                        rn_alb_idry = 0.65      ! bare frozen ice
+      !!                     Brandt et al 2005 (East Antarctica)
+      !!                        rn_alb_sdry = 0.87      ! dry snow
+      !!                        rn_alb_smlt = 0.82      ! melting snow
+      !!                        rn_alb_idry = 0.54      ! bare frozen ice
+      !!
+      !! ** Note    :   The old parameterization from Shine & Henderson-Sellers (not here anymore) presented several misconstructions
+      !!                  1) ice albedo when ice thick. tends to 0 is different than ocean albedo
+      !!                  2) for small ice thick. covered with some snow (<3cm?), albedo is larger 
+      !!                     under melting conditions than under freezing conditions
+      !!                  3) the evolution of ice albedo as a function of ice thickness shows  
+      !!                     3 sharp inflexion points (at 5cm, 100cm and 150cm) that look highly unrealistic
+      !!
+      !! References :   Shine & Henderson-Sellers 1985, JGR, 90(D1), 2243-2250.
+      !!                Brandt et al. 2005, J. Climate, vol 18
+      !!                Grenfell & Perovich 2004, JGR, vol 109 
+      !!----------------------------------------------------------------------
+      REAL(wp), INTENT(in   ), DIMENSION(:,:,:) ::   pt_su        !  ice surface temperature (Kelvin)
+      REAL(wp), INTENT(in   ), DIMENSION(:,:,:) ::   ph_ice       !  sea-ice thickness
+      REAL(wp), INTENT(in   ), DIMENSION(:,:,:) ::   ph_snw       !  snow depth
+      LOGICAL , INTENT(in   )                   ::   ld_pnd_alb   !  effect of melt ponds on albedo
+      REAL(wp), INTENT(in   ), DIMENSION(:,:,:) ::   pafrac_pnd   !  melt pond relative fraction (per unit ice area)
+      REAL(wp), INTENT(in   ), DIMENSION(:,:,:) ::   ph_pnd       !  melt pond depth
+      REAL(wp), INTENT(  out), DIMENSION(:,:,:) ::   palb_cs      !  albedo of ice under clear    sky
+      REAL(wp), INTENT(  out), DIMENSION(:,:,:) ::   palb_os      !  albedo of ice under overcast sky
+      !
+      INTEGER  ::   ji, jj, jl                ! dummy loop indices
+      REAL(wp) ::   z1_c1, z1_c2,z1_c3, z1_c4 ! local scalar
+      REAL(wp) ::   z1_href_pnd               ! inverse of the characteristic length scale (Lecomte et al. 2015)
+      REAL(wp) ::   zalb_pnd, zafrac_pnd      ! ponded sea ice albedo & relative pound fraction
+      REAL(wp) ::   zalb_ice, zafrac_ice      ! bare sea ice albedo & relative ice fraction
+      REAL(wp) ::   zalb_snw, zafrac_snw      ! snow-covered sea ice albedo & relative snow fraction
+      !!---------------------------------------------------------------------
+      !
+      IF( ln_timing )   CALL timing_start('icealb')
+      !
+      z1_href_pnd = 0.05
+      z1_c1 = 1. / ( LOG(1.5) - LOG(0.05) ) 
+      z1_c2 = 1. / 0.05
+      z1_c3 = 1. / 0.02
+      z1_c4 = 1. / 0.03
+      !
+      DO jl = 1, jpl
+         DO jj = 1, jpj
+            DO ji = 1, jpi
+               !                       !--- Specific snow, ice and pond fractions (for now, we prevent melt ponds and snow at the same time)
+               IF( ph_snw(ji,jj,jl) == 0._wp ) THEN
+                  zafrac_snw = 0._wp
+                  IF( ld_pnd_alb ) THEN
+                     zafrac_pnd = pafrac_pnd(ji,jj,jl)
+                  ELSE
+                     zafrac_pnd = 0._wp
+                  ENDIF
+                  zafrac_ice = 1._wp - zafrac_pnd
+               ELSE
+                  zafrac_snw = 1._wp      ! Snow fully "shades" melt ponds and ice
+                  zafrac_pnd = 0._wp
+                  zafrac_ice = 0._wp
+               ENDIF
+               !
+               !                       !--- Bare ice albedo (for hi > 150cm)
+               IF( ld_pnd_alb ) THEN
+                  zalb_ice = rn_alb_idry
+               ELSE
+                  IF( ph_snw(ji,jj,jl) == 0._wp .AND. pt_su(ji,jj,jl) >= rt0 ) THEN  ;   zalb_ice = rn_alb_imlt
+                  ELSE                                                               ;   zalb_ice = rn_alb_idry   ;   ENDIF
+               ENDIF
+               !                       !--- Bare ice albedo (for hi < 150cm)
+               IF( 0.05 < ph_ice(ji,jj,jl) .AND. ph_ice(ji,jj,jl) <= 1.5 ) THEN      ! 5cm < hi < 150cm
+                  zalb_ice = zalb_ice    + ( 0.18 - zalb_ice   ) * z1_c1 * ( LOG(1.5) - LOG(ph_ice(ji,jj,jl)) )
+               ELSEIF( ph_ice(ji,jj,jl) <= 0.05 ) THEN                               ! 0cm < hi < 5cm
+                  zalb_ice = rn_alb_oce  + ( 0.18 - rn_alb_oce ) * z1_c2 * ph_ice(ji,jj,jl)
+               ENDIF
+               !
+               !                       !--- Snow-covered ice albedo (freezing, melting cases)
+               IF( pt_su(ji,jj,jl) < rt0_snow ) THEN
+                  zalb_snw = rn_alb_sdry - ( rn_alb_sdry - zalb_ice ) * EXP( - ph_snw(ji,jj,jl) * z1_c3 )
+               ELSE
+                  zalb_snw = rn_alb_smlt - ( rn_alb_smlt - zalb_ice ) * EXP( - ph_snw(ji,jj,jl) * z1_c4 )
+               ENDIF
+               !                       !--- Ponded ice albedo
+               IF( ld_pnd_alb ) THEN
+                  zalb_pnd = rn_alb_dpnd - ( rn_alb_dpnd - zalb_ice ) * EXP( - ph_pnd(ji,jj,jl) * z1_href_pnd ) 
+               ELSE
+                  zalb_pnd = rn_alb_dpnd
+               ENDIF
+               !                       !--- Surface albedo is weighted mean of snow, ponds and bare ice contributions
+               palb_os(ji,jj,jl) = zafrac_snw * zalb_snw + zafrac_pnd * zalb_pnd + zafrac_ice * zalb_ice
+               !
+            END DO
+         END DO
+      END DO
+      !
+      palb_cs(:,:,:) = palb_os(:,:,:) - ( - 0.1010 * palb_os(:,:,:) * palb_os(:,:,:) + 0.1933 * palb_os(:,:,:) - 0.0148 )
+      !
+      IF( ln_timing )   CALL timing_stop('icealb')
+      !
+   END SUBROUTINE ice_alb
+
+
+   SUBROUTINE ice_alb_init
+      !!----------------------------------------------------------------------
+      !!                 ***  ROUTINE alb_init  ***
+      !!
+      !! ** Purpose :   initializations for the albedo parameters
+      !!
+      !! ** Method  :   Read the namelist namalb
+      !!----------------------------------------------------------------------
+      INTEGER ::   ios   ! Local integer output status for namelist read
+      !!
+      NAMELIST/namalb/ rn_alb_sdry, rn_alb_smlt, rn_alb_idry, rn_alb_imlt, rn_alb_dpnd
+      !!----------------------------------------------------------------------
+      !
+      REWIND( numnam_ice_ref )              ! Namelist namalb in reference namelist : Albedo parameters
+      READ  ( numnam_ice_ref, namalb, IOSTAT = ios, ERR = 901)
+901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namalb in reference namelist', lwp )
+      REWIND( numnam_ice_cfg )              ! Namelist namalb in configuration namelist : Albedo parameters
+      READ  ( numnam_ice_cfg, namalb, IOSTAT = ios, ERR = 902 )
+902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namalb in configuration namelist', lwp )
+      IF(lwm) WRITE( numoni, namalb )
+      !
+      IF(lwp) THEN                      ! Control print
+         WRITE(numout,*)
+         WRITE(numout,*) 'ice_alb_init: set albedo parameters'
+         WRITE(numout,*) '~~~~~~~~~~~~'
+         WRITE(numout,*) '   Namelist namalb:'
+         WRITE(numout,*) '      albedo of dry snow                   rn_alb_sdry = ', rn_alb_sdry
+         WRITE(numout,*) '      albedo of melting snow               rn_alb_smlt = ', rn_alb_smlt
+         WRITE(numout,*) '      albedo of dry ice                    rn_alb_idry = ', rn_alb_idry
+         WRITE(numout,*) '      albedo of bare puddled ice           rn_alb_imlt = ', rn_alb_imlt
+         WRITE(numout,*) '      albedo of ponded ice                 rn_alb_dpnd = ', rn_alb_dpnd
+      ENDIF
+      !
+   END SUBROUTINE ice_alb_init
+
+#else
+   !!----------------------------------------------------------------------
+   !!   Default option           Dummy module         NO SI3 sea-ice model
+   !!----------------------------------------------------------------------
+#endif
+
+   !!======================================================================
+END MODULE icealb
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/ICE_SRC/icecor.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/ICE_SRC/icecor.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/ICE_SRC/icecor.F90	(revision 9570)
@@ -0,0 +1,189 @@
+MODULE icecor
+   !!======================================================================
+   !!                     ***  MODULE  icecor  ***
+   !!   SI3 : Corrections on sea-ice variables at the end of the time step
+   !!======================================================================
+   !! History :  3.0  !  2006-04  (M. Vancoppenolle) Original code
+   !!            3.5  !  2014-06  (C. Rousset)       Complete rewriting/cleaning
+   !!----------------------------------------------------------------------
+#if defined key_si3
+   !!----------------------------------------------------------------------
+   !!   'key_si3'                                       SI3 sea-ice model
+   !!----------------------------------------------------------------------
+   !!    ice_cor      : corrections on sea-ice variables
+   !!----------------------------------------------------------------------
+   USE dom_oce        ! ocean domain
+   USE phycst         ! physical constants
+   USE ice            ! sea-ice: variable
+   USE ice1D          ! sea-ice: thermodynamic sea-ice variables
+   USE iceitd         ! sea-ice: rebining
+   USE icevar         ! sea-ice: operations
+   USE icectl         ! sea-ice: control prints
+   !
+   USE in_out_manager ! I/O manager
+   USE iom            ! I/O manager library
+   USE lib_mpp        ! MPP library
+   USE lib_fortran    ! fortran utilities (glob_sum + no signed zero)
+   USE lbclnk         ! lateral boundary conditions (or mpp links)
+   USE timing         ! Timing
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   ice_cor   ! called by icestp.F90
+
+   !! * Substitutions
+#  include "vectopt_loop_substitute.h90"
+   !!----------------------------------------------------------------------
+   !! NEMO/ICE 4.0 , NEMO Consortium (2017)
+   !! $Id: icecor.F90 8378 2017-07-26 13:55:59Z clem $
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE ice_cor( kt, kn )
+      !!----------------------------------------------------------------------
+      !!               ***  ROUTINE ice_cor  ***
+      !!               
+      !! ** Purpose :   Computes corrections on sea-ice global variables at 
+      !!              the end of the dynamics (kn=1) and thermodynamics (kn=2)
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT(in) ::   kt    ! number of iteration
+      INTEGER, INTENT(in) ::   kn    ! 1 = after dyn ; 2 = after thermo
+      !
+      INTEGER  ::   ji, jj, jk, jl   ! dummy loop indices
+      REAL(wp) ::   zsal, zzc
+      REAL(wp), DIMENSION(jpi,jpj) ::   zafx   ! concentration trends diag
+      !!----------------------------------------------------------------------
+      ! controls
+      IF( ln_timing    )   CALL timing_start('icecor')                                                             ! timing
+      IF( ln_icediachk )   CALL ice_cons_hsm(0, 'icecor', rdiag_v, rdiag_s, rdiag_t, rdiag_fv, rdiag_fs, rdiag_ft) ! conservation
+      !
+      IF( kt == nit000 .AND. lwp .AND. kn == 2 ) THEN
+         WRITE(numout,*)
+         WRITE(numout,*) 'ice_cor:  correct sea ice variables if out of bounds ' 
+         WRITE(numout,*) '~~~~~~~'
+      ENDIF
+      !
+      !                             !-----------------------------------------------------
+      !                             !  ice thickness must exceed himin (for ice diff)    !
+      !                             !-----------------------------------------------------
+      WHERE( a_i(:,:,:) >= epsi20 )   ;   h_i(:,:,:) = v_i(:,:,:) / a_i(:,:,:)
+      ELSEWHERE                       ;   h_i(:,:,:) = 0._wp
+      END WHERE
+      WHERE( h_i(:,:,:) < rn_himin )      a_i(:,:,:) = a_i(:,:,:) * h_i(:,:,:) / rn_himin
+      !
+      !                             !-----------------------------------------------------
+      !                             !  ice concentration should not exceed amax          !
+      !                             !-----------------------------------------------------
+      at_i(:,:) = SUM( a_i(:,:,:), dim=3 )
+      DO jl  = 1, jpl
+         WHERE( at_i(:,:) > rn_amax_2d(:,:) )   a_i(:,:,jl) = a_i(:,:,jl) * rn_amax_2d(:,:) / at_i(:,:)
+      END DO
+    
+      !                             !-----------------------------------------------------
+      IF ( nn_icesal == 2 ) THEN    !  salinity must stay in bounds [Simin,Simax]        !
+      !                             !-----------------------------------------------------
+         zzc = rhoic * r1_rdtice
+         DO jl = 1, jpl
+            DO jj = 1, jpj 
+               DO ji = 1, jpi
+                  zsal = sv_i(ji,jj,jl)
+                  sv_i(ji,jj,jl) = MIN(  MAX( rn_simin*v_i(ji,jj,jl) , sv_i(ji,jj,jl) ) , rn_simax*v_i(ji,jj,jl)  )
+                  sfx_res(ji,jj) = sfx_res(ji,jj) - ( sv_i(ji,jj,jl) - zsal ) * zzc   ! associated salt flux
+               END DO
+            END DO
+         END DO
+      ENDIF
+
+      !                             !-----------------------------------------------------
+      !                             !  Rebin categories with thickness out of bounds     !
+      !                             !-----------------------------------------------------
+      IF ( jpl > 1 )   CALL ice_itd_reb( kt )
+
+      !                             !-----------------------------------------------------
+      CALL ice_var_zapsmall         !  Zap small values                                  !
+      !                             !-----------------------------------------------------
+
+      !                             !-----------------------------------------------------
+      IF( kn == 2 ) THEN            !  Ice drift case: Corrections to avoid wrong values !
+         DO jj = 2, jpjm1           !-----------------------------------------------------
+            DO ji = 2, jpim1
+               IF ( at_i(ji,jj) == 0._wp ) THEN    ! what to do if there is no ice
+                  IF ( at_i(ji+1,jj) == 0._wp )   u_ice(ji  ,jj) = 0._wp   ! right side
+                  IF ( at_i(ji-1,jj) == 0._wp )   u_ice(ji-1,jj) = 0._wp   ! left side
+                  IF ( at_i(ji,jj+1) == 0._wp )   v_ice(ji,jj  ) = 0._wp   ! upper side
+                  IF ( at_i(ji,jj-1) == 0._wp )   v_ice(ji,jj-1) = 0._wp   ! bottom side
+               ENDIF
+            END DO
+         END DO
+         CALL lbc_lnk_multi( u_ice, 'U', -1., v_ice, 'V', -1. )            ! lateral boundary conditions
+      ENDIF
+
+!!gm I guess the trends are only out on demand 
+!!   So please, only do this is it exite an iom_use of on a these variables
+!!   furthermore, only allocate the diag_ arrays in this case 
+!!   and do the iom_put here so that it is only a local allocation
+!!gm 
+      !                             !-----------------------------------------------------
+      SELECT CASE( kn )             !  Diagnostics                                       !
+      !                             !-----------------------------------------------------
+      CASE( 1 )                        !--- dyn trend diagnostics
+         !
+!!gm   here I think the number of ice cat is too small to use a SUM instruction...
+         DO jj = 1, jpj
+            DO ji = 1, jpi            
+               !                 ! heat content variation (W.m-2)
+               diag_heat(ji,jj) = - (  SUM( e_i(ji,jj,1:nlay_i,:) - e_i_b(ji,jj,1:nlay_i,:) )    & 
+                  &                  + SUM( e_s(ji,jj,1:nlay_s,:) - e_s_b(ji,jj,1:nlay_s,:) )  ) * r1_rdtice
+               !                 ! salt, volume
+               diag_sice(ji,jj) = SUM( sv_i(ji,jj,:) - sv_i_b(ji,jj,:) ) * rhoic * r1_rdtice
+               diag_vice(ji,jj) = SUM( v_i (ji,jj,:) - v_i_b (ji,jj,:) ) * rhoic * r1_rdtice
+               diag_vsnw(ji,jj) = SUM( v_s (ji,jj,:) - v_s_b (ji,jj,:) ) * rhosn * r1_rdtice
+            END DO
+         END DO
+         !                       ! concentration tendency (dynamics)
+         zafx   (:,:) = SUM( a_i(:,:,:) - a_i_b(:,:,:), dim=3 ) * r1_rdtice 
+         afx_tot(:,:) = zafx(:,:)
+         IF( iom_use('afxdyn') )   CALL iom_put( 'afxdyn' , zafx(:,:) )
+         !
+      CASE( 2 )                        !--- thermo trend diagnostics & ice aging
+         !
+         oa_i(:,:,:) = oa_i(:,:,:) + a_i(:,:,:) * rdt_ice   ! ice natural aging incrementation
+         !
+!!gm   here I think the number of ice cat is too small to use a SUM instruction...
+         DO jj = 1, jpj
+            DO ji = 1, jpi            
+               !                 ! heat content variation (W.m-2)
+               diag_heat(ji,jj) = diag_heat(ji,jj) - (  SUM( e_i(ji,jj,1:nlay_i,:) - e_i_b(ji,jj,1:nlay_i,:) )    & 
+                  &                                   + SUM( e_s(ji,jj,1:nlay_s,:) - e_s_b(ji,jj,1:nlay_s,:) )  ) * r1_rdtice
+               !                 ! salt, volume
+               diag_sice(ji,jj) = diag_sice(ji,jj) + SUM( sv_i(ji,jj,:) - sv_i_b(ji,jj,:) ) * rhoic * r1_rdtice
+               diag_vice(ji,jj) = diag_vice(ji,jj) + SUM( v_i (ji,jj,:) - v_i_b (ji,jj,:) ) * rhoic * r1_rdtice
+               diag_vsnw(ji,jj) = diag_vsnw(ji,jj) + SUM( v_s (ji,jj,:) - v_s_b (ji,jj,:) ) * rhosn * r1_rdtice
+            END DO
+         END DO
+         !                       ! concentration tendency (total + thermo)
+         zafx   (:,:) = SUM( a_i(:,:,:) - a_i_b(:,:,:), dim=3 ) * r1_rdtice
+         afx_tot(:,:) = afx_tot(:,:) + zafx(:,:)
+         IF( iom_use('afxthd') )   CALL iom_put( 'afxthd' , zafx(:,:) )
+         IF( iom_use('afxtot') )   CALL iom_put( 'afxtot' , afx_tot(:,:) )
+         !
+      END SELECT
+      !
+      ! controls
+      IF( ln_icediachk   )   CALL ice_cons_hsm(1, 'icecor', rdiag_v, rdiag_s, rdiag_t, rdiag_fv, rdiag_fs, rdiag_ft) ! conservation
+      IF( ln_ctl         )   CALL ice_prt3D   ('icecor')                                                             ! prints
+      IF( ln_icectl .AND. kn == 2 )   CALL ice_prt( kt, iiceprt, jiceprt, 2, ' - Final state - ' )                   ! prints
+      IF( ln_timing      )   CALL timing_stop ('icecor')                                                             ! timing
+      !
+   END SUBROUTINE ice_cor
+
+#else
+   !!----------------------------------------------------------------------
+   !!   Default option           Dummy module         NO SI3 sea-ice model
+   !!----------------------------------------------------------------------
+#endif
+
+   !!======================================================================
+END MODULE icecor
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/ICE_SRC/icectl.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/ICE_SRC/icectl.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/ICE_SRC/icectl.F90	(revision 9570)
@@ -0,0 +1,676 @@
+MODULE icectl
+   !!======================================================================
+   !!                     ***  MODULE  icectl  ***
+   !!   sea-ice : controls and prints
+   !!======================================================================
+   !! History :  3.5  !  2015-01  (M. Vancoppenolle) Original code
+   !!            3.7  !  2016-10  (C. Rousset)       Add routine ice_prt3D
+   !!----------------------------------------------------------------------
+#if defined key_si3
+   !!----------------------------------------------------------------------
+   !!   'key_si3'                                       SI3 sea-ice model
+   !!----------------------------------------------------------------------
+   !!    ice_cons_hsm     : conservation tests on heat, salt and mass
+   !!    ice_cons_final   : conservation tests on heat, salt and mass at end of time step
+   !!    ice_ctl          : control prints in case of crash
+   !!    ice_prt          : control prints at a given grid point
+   !!    ice_prt3D        : control prints of ice arrays
+   !!----------------------------------------------------------------------
+   USE phycst         ! physical constants
+   USE oce            ! ocean dynamics and tracers
+   USE dom_oce        ! ocean space and time domain
+   USE ice            ! sea-ice: variables
+   USE ice1D          ! sea-ice: thermodynamics variables
+   USE sbc_oce        ! Surface boundary condition: ocean fields
+   USE sbc_ice        ! Surface boundary condition: ice   fields
+   !
+   USE in_out_manager ! I/O manager
+   USE lib_mpp        ! MPP library
+   USE lib_fortran    ! fortran utilities (glob_sum + no signed zero)
+   USE timing         ! Timing
+   USE prtctl         ! Print control
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   ice_cons_hsm
+   PUBLIC   ice_cons_final
+   PUBLIC   ice_ctl
+   PUBLIC   ice_prt
+   PUBLIC   ice_prt3D
+
+   !! * Substitutions
+#  include "vectopt_loop_substitute.h90"
+   !!----------------------------------------------------------------------
+   !! NEMO/ICE 4.0 , NEMO Consortium (2017)
+   !! $Id: icectl.F90 5043 2015-01-28 16:44:18Z clem $
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE ice_cons_hsm( icount, cd_routine, pdiag_v, pdiag_s, pdiag_t, pdiag_fv, pdiag_fs, pdiag_ft )
+      !!-------------------------------------------------------------------
+      !!                       ***  ROUTINE ice_cons_hsm ***
+      !!
+      !! ** Purpose : Test the conservation of heat, salt and mass for each ice routine
+      !!                     + test if ice concentration and volume are > 0
+      !!
+      !! ** Method  : This is an online diagnostics which can be activated with ln_icediachk=true
+      !!              It prints in ocean.output if there is a violation of conservation at each time-step
+      !!              The thresholds (zv_sill, zs_sill, zt_sill) which determine violations are set to
+      !!              a minimum of 1 mm of ice (over the ice area) that is lost/gained spuriously during 100 years.
+      !!              For salt and heat thresholds, ice is considered to have a salinity of 10 
+      !!              and a heat content of 3e5 J/kg (=latent heat of fusion) 
+      !!-------------------------------------------------------------------
+      INTEGER         , INTENT(in)    ::   icount        ! called at: =0 the begining of the routine, =1  the end
+      CHARACTER(len=*), INTENT(in)    ::   cd_routine    ! name of the routine
+      REAL(wp)        , INTENT(inout) ::   pdiag_v, pdiag_s, pdiag_t, pdiag_fv, pdiag_fs, pdiag_ft
+      !!
+      REAL(wp) ::   zv, zs, zt, zfs, zfv, zft
+      REAL(wp) ::   zvmin, zamin, zamax 
+      REAL(wp) ::   zvtrp, zetrp
+      REAL(wp) ::   zarea, zv_sill, zs_sill, zt_sill
+      REAL(wp), PARAMETER ::   zconv = 1.e-9 ! convert W to GW and kg to Mt
+      !!-------------------------------------------------------------------
+      !
+      IF( icount == 0 ) THEN
+         !                          ! water flux
+         pdiag_fv = glob_sum( -( wfx_bog(:,:) + wfx_bom(:,:) + wfx_sum(:,:) + wfx_sni(:,:) +                  &
+            &                    wfx_opw(:,:) + wfx_res(:,:) + wfx_dyn(:,:) + wfx_lam(:,:) + wfx_pnd(:,:)  +  &
+            &                    wfx_snw_sni(:,:) + wfx_snw_sum(:,:) + wfx_snw_dyn(:,:) + wfx_snw_sub(:,:) +  &
+            &                    wfx_ice_sub(:,:) + wfx_spr(:,:)  &
+            &                  ) * e1e2t(:,:) ) * zconv
+         !
+         !                          ! salt flux
+         pdiag_fs = glob_sum(  ( sfx_bri(:,:) + sfx_bog(:,:) + sfx_bom(:,:) + sfx_sum(:,:) + sfx_sni(:,:) +  &
+            &                    sfx_opw(:,:) + sfx_res(:,:) + sfx_dyn(:,:) + sfx_sub(:,:) + sfx_lam(:,:)    &
+            &                  ) *  e1e2t(:,:) ) * zconv 
+         !
+         !                          ! heat flux
+         pdiag_ft = glob_sum(  ( hfx_sum(:,:) + hfx_bom(:,:) + hfx_bog(:,:) + hfx_dif(:,:) + hfx_opw(:,:) + hfx_snw(:,:)  & 
+            &                  - hfx_thd(:,:) - hfx_dyn(:,:) - hfx_res(:,:) - hfx_sub(:,:) - hfx_spr(:,:)   &
+            &                  ) *  e1e2t(:,:) ) * zconv
+
+         pdiag_v = glob_sum( SUM( v_i * rhoic + v_s * rhosn, dim=3 ) * e1e2t * zconv )
+
+         pdiag_s = glob_sum( SUM( sv_i * rhoic             , dim=3 ) * e1e2t * zconv )
+
+         pdiag_t = glob_sum( (  SUM( SUM( e_i(:,:,1:nlay_i,:), dim=4 ), dim=3 )     &
+            &                 + SUM( SUM( e_s(:,:,1:nlay_s,:), dim=4 ), dim=3 ) ) * e1e2t ) * zconv
+
+      ELSEIF( icount == 1 ) THEN
+
+         ! water flux
+         zfv  = glob_sum( -( wfx_bog(:,:) + wfx_bom(:,:) + wfx_sum(:,:) + wfx_sni(:,:) +                  &
+            &                wfx_opw(:,:) + wfx_res(:,:) + wfx_dyn(:,:) + wfx_lam(:,:) + wfx_pnd(:,:)  +  &
+            &                wfx_snw_sni(:,:) + wfx_snw_sum(:,:) + wfx_snw_dyn(:,:) + wfx_snw_sub(:,:) +  &
+            &                wfx_ice_sub(:,:) + wfx_spr(:,:)  &
+            &              ) * e1e2t(:,:) ) * zconv - pdiag_fv
+
+         ! salt flux
+         zfs  = glob_sum(  ( sfx_bri(:,:) + sfx_bog(:,:) + sfx_bom(:,:) + sfx_sum(:,:) + sfx_sni(:,:) +  &
+            &                sfx_opw(:,:) + sfx_res(:,:) + sfx_dyn(:,:) + sfx_sub(:,:) + sfx_lam(:,:)    & 
+            &              ) * e1e2t(:,:) ) * zconv - pdiag_fs
+
+         ! heat flux
+         zft  = glob_sum(  ( hfx_sum(:,:) + hfx_bom(:,:) + hfx_bog(:,:) + hfx_dif(:,:) + hfx_opw(:,:) + hfx_snw(:,:)  & 
+            &              - hfx_thd(:,:) - hfx_dyn(:,:) - hfx_res(:,:) - hfx_sub(:,:) - hfx_spr(:,:)   &
+            &              ) * e1e2t(:,:) ) * zconv - pdiag_ft
+ 
+         ! outputs
+         zv = ( ( glob_sum( SUM( v_i * rhoic + v_s * rhosn, dim=3 ) * e1e2t ) * zconv  &
+            &     - pdiag_v ) * r1_rdtice - zfv ) * rday
+
+         zs = ( ( glob_sum( SUM( sv_i * rhoic             , dim=3 ) * e1e2t ) * zconv  &
+            &     - pdiag_s ) * r1_rdtice + zfs ) * rday
+
+         zt = ( glob_sum( (  SUM( SUM( e_i(:,:,1:nlay_i,:), dim=4 ), dim=3 )   &
+            &              + SUM( SUM( e_s(:,:,1:nlay_s,:), dim=4 ), dim=3 ) ) * e1e2t ) * zconv   &
+            &   - pdiag_t ) * r1_rdtice + zft
+
+         ! zvtrp and zetrp must be close to 0 if the advection scheme is conservative
+         zvtrp = glob_sum( ( diag_trp_vi * rhoic + diag_trp_vs * rhosn ) * e1e2t  ) * zconv * rday 
+         zetrp = glob_sum( ( diag_trp_ei         + diag_trp_es         ) * e1e2t  ) * zconv
+
+         zvmin = glob_min( v_i )
+         zamax = glob_max( SUM( a_i, dim=3 ) )
+         zamin = glob_min( a_i )
+
+         ! set threshold values and calculate the ice area (+epsi10 to set a threshold > 0 when there is no ice) 
+         zarea   = glob_sum( SUM( a_i + epsi10, dim=3 ) * e1e2t ) * zconv ! in 1.e9 m2
+         zv_sill = zarea * 2.5e-5
+         zs_sill = zarea * 25.e-5
+         zt_sill = zarea * 10.e-5
+
+         IF(lwp) THEN
+            IF ( ABS( zv   ) > zv_sill )   WRITE(numout,*) 'violation volume [Mt/day]     (',cd_routine,') = ',zv
+            IF ( ABS( zs   ) > zs_sill )   WRITE(numout,*) 'violation saline [psu*Mt/day] (',cd_routine,') = ',zs
+            IF ( ABS( zt   ) > zt_sill )   WRITE(numout,*) 'violation enthalpy [GW]       (',cd_routine,') = ',zt
+            IF ( ABS(zvtrp ) > zv_sill .AND. cd_routine == 'icedyn_adv' ) THEN
+                                           WRITE(numout,*) 'violation vtrp [Mt/day]       (',cd_routine,') = ',zvtrp
+                                           WRITE(numout,*) 'violation etrp [GW]           (',cd_routine,') = ',zetrp
+            ENDIF
+            IF ( zvmin < -epsi10 )         WRITE(numout,*) 'violation v_i<0  [m]          (',cd_routine,') = ',zvmin
+            IF ( zamax > MAX(rn_amax_n,rn_amax_s)+epsi10 .AND. cd_routine /= 'icedyn_adv' .AND. cd_routine /= 'icedyn_rdgrft' )  &
+               &                           WRITE(numout,*) 'violation a_i>amax            (',cd_routine,') = ',zamax
+            IF ( zamin < -epsi10 )         WRITE(numout,*) 'violation a_i<0               (',cd_routine,') = ',zamin
+         ENDIF
+         !
+      ENDIF
+
+   END SUBROUTINE ice_cons_hsm
+
+
+   SUBROUTINE ice_cons_final( cd_routine )
+      !!-------------------------------------------------------------------
+      !!                     ***  ROUTINE ice_cons_final ***
+      !!
+      !! ** Purpose : Test the conservation of heat, salt and mass at the end of each ice time-step
+      !!
+      !! ** Method  : This is an online diagnostics which can be activated with ln_icediachk=true
+      !!              It prints in ocean.output if there is a violation of conservation at each time-step
+      !!              The thresholds (zv_sill, zs_sill, zt_sill) which determine the violation are set to
+      !!              a minimum of 1 mm of ice (over the ice area) that is lost/gained spuriously during 100 years.
+      !!              For salt and heat thresholds, ice is considered to have a salinity of 10 
+      !!              and a heat content of 3e5 J/kg (=latent heat of fusion) 
+      !!-------------------------------------------------------------------
+      CHARACTER(len=*), INTENT(in)    :: cd_routine    ! name of the routine
+      REAL(wp)                        :: zhfx, zsfx, zvfx
+      REAL(wp)                        :: zarea, zv_sill, zs_sill, zt_sill
+      REAL(wp), PARAMETER             :: zconv = 1.e-9 ! convert W to GW and kg to Mt
+      !!-------------------------------------------------------------------
+
+      ! water flux
+      zvfx  = glob_sum( ( wfx_ice + wfx_snw + wfx_spr + wfx_sub + diag_vice + diag_vsnw ) * e1e2t ) * zconv * rday
+
+      ! salt flux
+      zsfx  = glob_sum( ( sfx + diag_sice ) * e1e2t ) * zconv * rday
+
+      ! heat flux
+      zhfx  = glob_sum( ( hfx_in - hfx_out - diag_heat - diag_trp_ei - diag_trp_es   &
+      !  &              - SUM( qevap_ice * a_i_b, dim=3 )                           & !!clem: I think this line must be commented (but need check)
+         &              ) * e1e2t ) * zconv
+
+      ! set threshold values and calculate the ice area (+epsi10 to set a threshold > 0 when there is no ice) 
+      zarea   = glob_sum( SUM( a_i + epsi10, dim=3 ) * e1e2t ) * zconv ! in 1.e9 m2
+      zv_sill = zarea * 2.5e-5
+      zs_sill = zarea * 25.e-5
+      zt_sill = zarea * 10.e-5
+
+      IF(lwp) THEN
+         IF( ABS( zvfx ) > zv_sill )   WRITE(numout,*) 'violation vfx  [Mt/day]       (',cd_routine,') = ',zvfx
+         IF( ABS( zsfx ) > zs_sill )   WRITE(numout,*) 'violation sfx  [psu*Mt/day]   (',cd_routine,') = ',zsfx
+         IF( ABS( zhfx ) > zt_sill )   WRITE(numout,*) 'violation hfx  [GW]           (',cd_routine,') = ',zhfx
+      ENDIF
+      !
+   END SUBROUTINE ice_cons_final
+
+   
+   SUBROUTINE ice_ctl( kt )
+      !!-------------------------------------------------------------------
+      !!                   ***  ROUTINE ice_ctl *** 
+      !!                 
+      !! ** Purpose :   Alerts in case of model crash
+      !!-------------------------------------------------------------------
+      INTEGER, INTENT(in) ::   kt      ! ocean time step
+      INTEGER  ::   ji, jj, jk,  jl   ! dummy loop indices
+      INTEGER  ::   inb_altests       ! number of alert tests (max 20)
+      INTEGER  ::   ialert_id         ! number of the current alert
+      REAL(wp) ::   ztmelts           ! ice layer melting point
+      CHARACTER (len=30), DIMENSION(20) ::   cl_alname   ! name of alert
+      INTEGER           , DIMENSION(20) ::   inb_alp     ! number of alerts positive
+      !!-------------------------------------------------------------------
+
+      inb_altests = 10
+      inb_alp(:)  =  0
+
+      ! Alert if incompatible volume and concentration
+      ialert_id = 2 ! reference number of this alert
+      cl_alname(ialert_id) = ' Incompat vol and con         '    ! name of the alert
+
+      DO jl = 1, jpl
+         DO jj = 1, jpj
+            DO ji = 1, jpi
+               IF(  v_i(ji,jj,jl) /= 0._wp   .AND.   a_i(ji,jj,jl) == 0._wp   ) THEN
+                  !WRITE(numout,*) ' ALERTE 2 :   Incompatible volume and concentration '
+                  !WRITE(numout,*) ' at_i     ', at_i(ji,jj)
+                  !WRITE(numout,*) ' Point - category', ji, jj, jl
+                  !WRITE(numout,*) ' a_i *** a_i_b   ', a_i      (ji,jj,jl), a_i_b  (ji,jj,jl)
+                  !WRITE(numout,*) ' v_i *** v_i_b   ', v_i      (ji,jj,jl), v_i_b  (ji,jj,jl)
+                  inb_alp(ialert_id) = inb_alp(ialert_id) + 1
+               ENDIF
+            END DO
+         END DO
+      END DO
+
+      ! Alerte if very thick ice
+      ialert_id = 3 ! reference number of this alert
+      cl_alname(ialert_id) = ' Very thick ice               ' ! name of the alert
+      jl = jpl 
+      DO jj = 1, jpj
+         DO ji = 1, jpi
+            IF(   h_i(ji,jj,jl)  >  50._wp   ) THEN
+               !CALL ice_prt( kt, ji, jj, 2, ' ALERTE 3 :   Very thick ice ' )
+               inb_alp(ialert_id) = inb_alp(ialert_id) + 1
+            ENDIF
+         END DO
+      END DO
+
+      ! Alert if very fast ice
+      ialert_id = 4 ! reference number of this alert
+      cl_alname(ialert_id) = ' Very fast ice               ' ! name of the alert
+      DO jj = 1, jpj
+         DO ji = 1, jpi
+            IF(   MAX( ABS( u_ice(ji,jj) ), ABS( v_ice(ji,jj) ) ) > 1.5  .AND.  &
+               &  at_i(ji,jj) > 0._wp   ) THEN
+               !CALL ice_prt( kt, ji, jj, 1, ' ALERTE 4 :   Very fast ice ' )
+               !WRITE(numout,*) ' ice strength             : ', strength(ji,jj)
+               !WRITE(numout,*) ' oceanic stress utau      : ', utau(ji,jj) 
+               !WRITE(numout,*) ' oceanic stress vtau      : ', vtau(ji,jj)
+               !WRITE(numout,*) ' sea-ice stress utau_ice  : ', utau_ice(ji,jj) 
+               !WRITE(numout,*) ' sea-ice stress vtau_ice  : ', vtau_ice(ji,jj)
+               !WRITE(numout,*) ' sst                      : ', sst_m(ji,jj)
+               !WRITE(numout,*) ' sss                      : ', sss_m(ji,jj)
+               !WRITE(numout,*) 
+               inb_alp(ialert_id) = inb_alp(ialert_id) + 1
+            ENDIF
+         END DO
+      END DO
+
+      ! Alert if there is ice on continents
+      ialert_id = 6 ! reference number of this alert
+      cl_alname(ialert_id) = ' Ice on continents           ' ! name of the alert
+      DO jj = 1, jpj
+         DO ji = 1, jpi
+            IF(   tmask(ji,jj,1) <= 0._wp   .AND.   at_i(ji,jj) > 0._wp   ) THEN 
+               !CALL ice_prt( kt, ji, jj, 1, ' ALERTE 6 :   Ice on continents ' )
+               !WRITE(numout,*) ' masks s, u, v        : ', tmask(ji,jj,1), umask(ji,jj,1), vmask(ji,jj,1) 
+               !WRITE(numout,*) ' sst                  : ', sst_m(ji,jj)
+               !WRITE(numout,*) ' sss                  : ', sss_m(ji,jj)
+               !WRITE(numout,*) ' at_i(ji,jj)          : ', at_i(ji,jj)
+               !WRITE(numout,*) ' v_ice(ji,jj)         : ', v_ice(ji,jj)
+               !WRITE(numout,*) ' v_ice(ji,jj-1)       : ', v_ice(ji,jj-1)
+               !WRITE(numout,*) ' u_ice(ji-1,jj)       : ', u_ice(ji-1,jj)
+               !WRITE(numout,*) ' u_ice(ji,jj)         : ', v_ice(ji,jj)
+               !
+               inb_alp(ialert_id) = inb_alp(ialert_id) + 1
+            ENDIF
+         END DO
+      END DO
+
+!
+!     ! Alert if very fresh ice
+      ialert_id = 7 ! reference number of this alert
+      cl_alname(ialert_id) = ' Very fresh ice               ' ! name of the alert
+      DO jl = 1, jpl
+         DO jj = 1, jpj
+            DO ji = 1, jpi
+               IF( s_i(ji,jj,jl) < 0.1 .AND. a_i(ji,jj,jl) > 0._wp ) THEN
+!                 CALL ice_prt(kt,ji,jj,1, ' ALERTE 7 :   Very fresh ice ' )
+!                 WRITE(numout,*) ' sst                  : ', sst_m(ji,jj)
+!                 WRITE(numout,*) ' sss                  : ', sss_m(ji,jj)
+!                 WRITE(numout,*) 
+                  inb_alp(ialert_id) = inb_alp(ialert_id) + 1
+               ENDIF
+            END DO
+         END DO
+      END DO
+!
+
+!     ! Alert if too old ice
+      ialert_id = 9 ! reference number of this alert
+      cl_alname(ialert_id) = ' Very old   ice               ' ! name of the alert
+      DO jl = 1, jpl
+         DO jj = 1, jpj
+            DO ji = 1, jpi
+               IF ( ( ( ABS( o_i(ji,jj,jl) ) > rdt_ice ) .OR. &
+                      ( ABS( o_i(ji,jj,jl) ) < 0._wp) ) .AND. &
+                             ( a_i(ji,jj,jl) > 0._wp ) ) THEN
+                  !CALL ice_prt( kt, ji, jj, 1, ' ALERTE 9 :   Wrong ice age ')
+                  inb_alp(ialert_id) = inb_alp(ialert_id) + 1
+               ENDIF
+            END DO
+         END DO
+      END DO
+ 
+      ! Alert on salt flux
+      ialert_id = 5 ! reference number of this alert
+      cl_alname(ialert_id) = ' High salt flux               ' ! name of the alert
+      DO jj = 1, jpj
+         DO ji = 1, jpi
+            IF( ABS( sfx (ji,jj) ) > 1.0e-2 ) THEN  ! = 1 psu/day for 1m ocean depth
+               !CALL ice_prt( kt, ji, jj, 3, ' ALERTE 5 :   High salt flux ' )
+               !DO jl = 1, jpl
+                  !WRITE(numout,*) ' Category no: ', jl
+                  !WRITE(numout,*) ' a_i        : ', a_i      (ji,jj,jl) , ' a_i_b      : ', a_i_b  (ji,jj,jl)   
+                  !WRITE(numout,*) ' v_i        : ', v_i      (ji,jj,jl) , ' v_i_b      : ', v_i_b  (ji,jj,jl)   
+                  !WRITE(numout,*) ' '
+               !END DO
+               inb_alp(ialert_id) = inb_alp(ialert_id) + 1
+            ENDIF
+         END DO
+      END DO
+
+      ! Alert if qns very big
+      ialert_id = 8 ! reference number of this alert
+      cl_alname(ialert_id) = ' fnsolar very big             ' ! name of the alert
+      DO jj = 1, jpj
+         DO ji = 1, jpi
+            IF( ABS( qns(ji,jj) ) > 1500._wp .AND. at_i(ji,jj) > 0._wp ) THEN
+               !
+               !WRITE(numout,*) ' ALERTE 8 :   Very high non-solar heat flux'
+               !WRITE(numout,*) ' ji, jj    : ', ji, jj
+               !WRITE(numout,*) ' qns       : ', qns(ji,jj)
+               !WRITE(numout,*) ' sst       : ', sst_m(ji,jj)
+               !WRITE(numout,*) ' sss       : ', sss_m(ji,jj)
+               !
+               !CALL ice_prt( kt, ji, jj, 2, '   ')
+               inb_alp(ialert_id) = inb_alp(ialert_id) + 1
+               !
+            ENDIF
+         END DO
+      END DO
+      !+++++
+ 
+      ! Alert if very warm ice
+      ialert_id = 10 ! reference number of this alert
+      cl_alname(ialert_id) = ' Very warm ice                ' ! name of the alert
+      inb_alp(ialert_id) = 0
+      DO jl = 1, jpl
+         DO jk = 1, nlay_i
+            DO jj = 1, jpj
+               DO ji = 1, jpi
+                  ztmelts    =  -tmut * sz_i(ji,jj,jk,jl) + rt0
+                  IF( t_i(ji,jj,jk,jl) >= ztmelts  .AND.  v_i(ji,jj,jl) > 1.e-10   &
+                     &                             .AND.  a_i(ji,jj,jl) > 0._wp   ) THEN
+                     !WRITE(numout,*) ' ALERTE 10 :   Very warm ice'
+                     !WRITE(numout,*) ' ji, jj, jk, jl : ', ji, jj, jk, jl
+                     !WRITE(numout,*) ' t_i : ', t_i(ji,jj,jk,jl)
+                     !WRITE(numout,*) ' e_i : ', e_i(ji,jj,jk,jl)
+                     !WRITE(numout,*) ' sz_i: ', sz_i(ji,jj,jk,jl)
+                     !WRITE(numout,*) ' ztmelts : ', ztmelts
+                     inb_alp(ialert_id) = inb_alp(ialert_id) + 1
+                  ENDIF
+               END DO
+            END DO
+         END DO
+      END DO
+
+      ! sum of the alerts on all processors
+      IF( lk_mpp ) THEN
+         DO ialert_id = 1, inb_altests
+            CALL mpp_sum(inb_alp(ialert_id))
+         END DO
+      ENDIF
+
+      ! print alerts
+      IF( lwp ) THEN
+         ialert_id = 1                                 ! reference number of this alert
+         cl_alname(ialert_id) = ' NO alerte 1      '   ! name of the alert
+         WRITE(numout,*) ' time step ',kt
+         WRITE(numout,*) ' All alerts at the end of ice model '
+         DO ialert_id = 1, inb_altests
+            WRITE(numout,*) ialert_id, cl_alname(ialert_id)//' : ', inb_alp(ialert_id), ' times ! '
+         END DO
+      ENDIF
+     !
+   END SUBROUTINE ice_ctl
+ 
+   
+   SUBROUTINE ice_prt( kt, ki, kj, kn, cd1 )
+      !!-------------------------------------------------------------------
+      !!                   ***  ROUTINE ice_prt *** 
+      !!                 
+      !! ** Purpose :   Writes global ice state on the (i,j) point 
+      !!                in ocean.ouput 
+      !!                3 possibilities exist 
+      !!                n = 1/-1 -> simple ice state (plus Mechanical Check if -1)
+      !!                n = 2    -> exhaustive state
+      !!                n = 3    -> ice/ocean salt fluxes
+      !!
+      !! ** input   :   point coordinates (i,j) 
+      !!                n : number of the option
+      !!-------------------------------------------------------------------
+      INTEGER         , INTENT(in) ::   kt            ! ocean time step
+      INTEGER         , INTENT(in) ::   ki, kj, kn    ! ocean gridpoint indices
+      CHARACTER(len=*), INTENT(in) ::   cd1           !
+      !!
+      INTEGER :: jl, ji, jj
+      !!-------------------------------------------------------------------
+
+      DO ji = mi0(ki), mi1(ki)
+         DO jj = mj0(kj), mj1(kj)
+
+            WRITE(numout,*) ' time step ',kt,' ',cd1             ! print title
+
+            !----------------
+            !  Simple state
+            !----------------
+            
+            IF ( kn == 1 .OR. kn == -1 ) THEN
+               WRITE(numout,*) ' ice_prt - Point : ',ji,jj
+               WRITE(numout,*) ' ~~~~~~~~~~~~~~ '
+               WRITE(numout,*) ' Simple state '
+               WRITE(numout,*) ' masks s,u,v   : ', tmask(ji,jj,1), umask(ji,jj,1), vmask(ji,jj,1)
+               WRITE(numout,*) ' lat - long    : ', gphit(ji,jj), glamt(ji,jj)
+               WRITE(numout,*) ' - Ice drift   '
+               WRITE(numout,*) '   ~~~~~~~~~~~ '
+               WRITE(numout,*) ' u_ice(i-1,j)  : ', u_ice(ji-1,jj)
+               WRITE(numout,*) ' u_ice(i  ,j)  : ', u_ice(ji,jj)
+               WRITE(numout,*) ' v_ice(i  ,j-1): ', v_ice(ji,jj-1)
+               WRITE(numout,*) ' v_ice(i  ,j)  : ', v_ice(ji,jj)
+               WRITE(numout,*) ' strength      : ', strength(ji,jj)
+               WRITE(numout,*)
+               WRITE(numout,*) ' - Cell values '
+               WRITE(numout,*) '   ~~~~~~~~~~~ '
+               WRITE(numout,*) ' cell area     : ', e1e2t(ji,jj)
+               WRITE(numout,*) ' at_i          : ', at_i(ji,jj)       
+               WRITE(numout,*) ' vt_i          : ', vt_i(ji,jj)       
+               WRITE(numout,*) ' vt_s          : ', vt_s(ji,jj)       
+               DO jl = 1, jpl
+                  WRITE(numout,*) ' - Category (', jl,')'
+                  WRITE(numout,*) ' a_i           : ', a_i(ji,jj,jl)
+                  WRITE(numout,*) ' h_i           : ', h_i(ji,jj,jl)
+                  WRITE(numout,*) ' h_s           : ', h_s(ji,jj,jl)
+                  WRITE(numout,*) ' v_i           : ', v_i(ji,jj,jl)
+                  WRITE(numout,*) ' v_s           : ', v_s(ji,jj,jl)
+                  WRITE(numout,*) ' e_s           : ', e_s(ji,jj,1:nlay_s,jl)
+                  WRITE(numout,*) ' e_i           : ', e_i(ji,jj,1:nlay_i,jl)
+                  WRITE(numout,*) ' t_su          : ', t_su(ji,jj,jl)
+                  WRITE(numout,*) ' t_snow        : ', t_s(ji,jj,1:nlay_s,jl)
+                  WRITE(numout,*) ' t_i           : ', t_i(ji,jj,1:nlay_i,jl)
+                  WRITE(numout,*) ' s_i           : ', s_i(ji,jj,jl)
+                  WRITE(numout,*) ' sv_i          : ', sv_i(ji,jj,jl)
+                  WRITE(numout,*)
+               END DO
+            ENDIF
+            IF( kn == -1 ) THEN
+               WRITE(numout,*) ' Mechanical Check ************** '
+               WRITE(numout,*) ' Check what means ice divergence '
+               WRITE(numout,*) ' Total ice concentration ', at_i (ji,jj)
+               WRITE(numout,*) ' Total lead fraction     ', ato_i(ji,jj)
+               WRITE(numout,*) ' Sum of both             ', ato_i(ji,jj) + at_i(ji,jj)
+               WRITE(numout,*) ' Sum of both minus 1     ', ato_i(ji,jj) + at_i(ji,jj) - 1.00
+            ENDIF
+            
+
+            !--------------------
+            !  Exhaustive state
+            !--------------------
+            
+            IF ( kn .EQ. 2 ) THEN
+               WRITE(numout,*) ' ice_prt - Point : ',ji,jj
+               WRITE(numout,*) ' ~~~~~~~~~~~~~~ '
+               WRITE(numout,*) ' Exhaustive state '
+               WRITE(numout,*) ' lat - long ', gphit(ji,jj), glamt(ji,jj)
+               WRITE(numout,*) 
+               WRITE(numout,*) ' - Cell values '
+               WRITE(numout,*) '   ~~~~~~~~~~~ '
+               WRITE(numout,*) ' cell area     : ', e1e2t(ji,jj)
+               WRITE(numout,*) ' at_i          : ', at_i(ji,jj)       
+               WRITE(numout,*) ' vt_i          : ', vt_i(ji,jj)       
+               WRITE(numout,*) ' vt_s          : ', vt_s(ji,jj)       
+               WRITE(numout,*) ' u_ice(i-1,j)  : ', u_ice(ji-1,jj)
+               WRITE(numout,*) ' u_ice(i  ,j)  : ', u_ice(ji,jj)
+               WRITE(numout,*) ' v_ice(i  ,j-1): ', v_ice(ji,jj-1)
+               WRITE(numout,*) ' v_ice(i  ,j)  : ', v_ice(ji,jj)
+               WRITE(numout,*) ' strength      : ', strength(ji,jj)
+               WRITE(numout,*) ' u_ice_b       : ', u_ice_b(ji,jj)    , ' v_ice_b       : ', v_ice_b(ji,jj)  
+               WRITE(numout,*)
+               
+               DO jl = 1, jpl
+                  WRITE(numout,*) ' - Category (',jl,')'
+                  WRITE(numout,*) '   ~~~~~~~~         ' 
+                  WRITE(numout,*) ' h_i        : ', h_i(ji,jj,jl)              , ' h_s        : ', h_s(ji,jj,jl)
+                  WRITE(numout,*) ' t_i        : ', t_i(ji,jj,1:nlay_i,jl)
+                  WRITE(numout,*) ' t_su       : ', t_su(ji,jj,jl)             , ' t_s        : ', t_s(ji,jj,1:nlay_s,jl)
+                  WRITE(numout,*) ' s_i        : ', s_i(ji,jj,jl)              , ' o_i        : ', o_i(ji,jj,jl)
+                  WRITE(numout,*) ' a_i        : ', a_i(ji,jj,jl)              , ' a_i_b      : ', a_i_b(ji,jj,jl)   
+                  WRITE(numout,*) ' v_i        : ', v_i(ji,jj,jl)              , ' v_i_b      : ', v_i_b(ji,jj,jl)   
+                  WRITE(numout,*) ' v_s        : ', v_s(ji,jj,jl)              , ' v_s_b      : ', v_s_b(ji,jj,jl)  
+                  WRITE(numout,*) ' e_i1       : ', e_i(ji,jj,1,jl)            , ' ei1        : ', e_i_b(ji,jj,1,jl) 
+                  WRITE(numout,*) ' e_i2       : ', e_i(ji,jj,2,jl)            , ' ei2_b      : ', e_i_b(ji,jj,2,jl)  
+                  WRITE(numout,*) ' e_snow     : ', e_s(ji,jj,1,jl)            , ' e_snow_b   : ', e_s_b(ji,jj,1,jl) 
+                  WRITE(numout,*) ' sv_i       : ', sv_i(ji,jj,jl)             , ' sv_i_b     : ', sv_i_b(ji,jj,jl)   
+                  WRITE(numout,*) ' oa_i       : ', oa_i(ji,jj,jl)             , ' oa_i_b     : ', oa_i_b(ji,jj,jl)
+               END DO !jl
+               
+               WRITE(numout,*)
+               WRITE(numout,*) ' - Heat / FW fluxes '
+               WRITE(numout,*) '   ~~~~~~~~~~~~~~~~ '
+               WRITE(numout,*) ' - Heat fluxes in and out the ice ***'
+               WRITE(numout,*) ' qsr_ini       : ', (1._wp-at_i_b(ji,jj)) * qsr(ji,jj) + SUM( a_i_b(ji,jj,:) * qsr_ice(ji,jj,:) )
+               WRITE(numout,*) ' qns_ini       : ', (1._wp-at_i_b(ji,jj)) * qns(ji,jj) + SUM( a_i_b(ji,jj,:) * qns_ice(ji,jj,:) )
+               WRITE(numout,*)
+               WRITE(numout,*) 
+               WRITE(numout,*) ' sst        : ', sst_m(ji,jj)  
+               WRITE(numout,*) ' sss        : ', sss_m(ji,jj)  
+               WRITE(numout,*) 
+               WRITE(numout,*) ' - Stresses '
+               WRITE(numout,*) '   ~~~~~~~~ '
+               WRITE(numout,*) ' utau_ice   : ', utau_ice(ji,jj) 
+               WRITE(numout,*) ' vtau_ice   : ', vtau_ice(ji,jj)
+               WRITE(numout,*) ' utau       : ', utau    (ji,jj) 
+               WRITE(numout,*) ' vtau       : ', vtau    (ji,jj)
+            ENDIF
+            
+            !---------------------
+            ! Salt / heat fluxes
+            !---------------------
+            
+            IF ( kn .EQ. 3 ) THEN
+               WRITE(numout,*) ' ice_prt - Point : ',ji,jj
+               WRITE(numout,*) ' ~~~~~~~~~~~~~~ '
+               WRITE(numout,*) ' - Salt / Heat Fluxes '
+               WRITE(numout,*) '   ~~~~~~~~~~~~~~~~ '
+               WRITE(numout,*) ' lat - long ', gphit(ji,jj), glamt(ji,jj)
+               WRITE(numout,*)
+               WRITE(numout,*) ' - Heat fluxes at bottom interface ***'
+               WRITE(numout,*) ' qsr       : ', qsr(ji,jj)
+               WRITE(numout,*) ' qns       : ', qns(ji,jj)
+               WRITE(numout,*)
+               WRITE(numout,*) ' hfx_mass     : ', hfx_thd(ji,jj) + hfx_dyn(ji,jj) + hfx_snw(ji,jj) + hfx_res(ji,jj)
+               WRITE(numout,*) ' hfx_in       : ', hfx_in(ji,jj)
+               WRITE(numout,*) ' hfx_out      : ', hfx_out(ji,jj)
+               WRITE(numout,*) ' dhc          : ', diag_heat(ji,jj)              
+               WRITE(numout,*)
+               WRITE(numout,*) ' hfx_dyn      : ', hfx_dyn(ji,jj)
+               WRITE(numout,*) ' hfx_thd      : ', hfx_thd(ji,jj)
+               WRITE(numout,*) ' hfx_res      : ', hfx_res(ji,jj)
+               WRITE(numout,*) ' fhtur        : ', fhtur(ji,jj) 
+               WRITE(numout,*) ' qlead        : ', qlead(ji,jj) * r1_rdtice
+               WRITE(numout,*)
+               WRITE(numout,*) ' - Salt fluxes at bottom interface ***'
+               WRITE(numout,*) ' emp       : ', emp    (ji,jj)
+               WRITE(numout,*) ' sfx       : ', sfx    (ji,jj)
+               WRITE(numout,*) ' sfx_res   : ', sfx_res(ji,jj)
+               WRITE(numout,*) ' sfx_bri   : ', sfx_bri(ji,jj)
+               WRITE(numout,*) ' sfx_dyn   : ', sfx_dyn(ji,jj)
+               WRITE(numout,*)
+               WRITE(numout,*) ' - Momentum fluxes '
+               WRITE(numout,*) ' utau      : ', utau(ji,jj) 
+               WRITE(numout,*) ' vtau      : ', vtau(ji,jj)
+            ENDIF 
+            WRITE(numout,*) ' '
+            !
+         END DO
+      END DO
+      !
+   END SUBROUTINE ice_prt
+
+   SUBROUTINE ice_prt3D( cd_routine )
+      !!-------------------------------------------------------------------
+      !!                  ***  ROUTINE ice_prt3D ***
+      !!
+      !! ** Purpose : CTL prints of ice arrays in case ln_ctl is activated 
+      !!
+      !!-------------------------------------------------------------------
+      CHARACTER(len=*), INTENT(in)  :: cd_routine    ! name of the routine
+      INTEGER                       :: jk, jl        ! dummy loop indices
+      
+      CALL prt_ctl_info(' ========== ')
+      CALL prt_ctl_info( cd_routine )
+      CALL prt_ctl_info(' ========== ')
+      CALL prt_ctl_info(' - Cell values : ')
+      CALL prt_ctl_info('   ~~~~~~~~~~~~~ ')
+      CALL prt_ctl(tab2d_1=e1e2t      , clinfo1=' cell area   :')
+      CALL prt_ctl(tab2d_1=at_i       , clinfo1=' at_i        :')
+      CALL prt_ctl(tab2d_1=ato_i      , clinfo1=' ato_i       :')
+      CALL prt_ctl(tab2d_1=vt_i       , clinfo1=' vt_i        :')
+      CALL prt_ctl(tab2d_1=vt_s       , clinfo1=' vt_s        :')
+      CALL prt_ctl(tab2d_1=divu_i     , clinfo1=' divu_i      :')
+      CALL prt_ctl(tab2d_1=delta_i    , clinfo1=' delta_i     :')
+      CALL prt_ctl(tab2d_1=stress1_i  , clinfo1=' stress1_i   :')
+      CALL prt_ctl(tab2d_1=stress2_i  , clinfo1=' stress2_i   :')
+      CALL prt_ctl(tab2d_1=stress12_i , clinfo1=' stress12_i  :')
+      CALL prt_ctl(tab2d_1=strength   , clinfo1=' strength    :')
+      CALL prt_ctl(tab2d_1=delta_i    , clinfo1=' delta_i     :')
+      CALL prt_ctl(tab2d_1=u_ice      , clinfo1=' u_ice       :', tab2d_2=v_ice      , clinfo2=' v_ice       :')
+       
+      DO jl = 1, jpl
+         CALL prt_ctl_info(' ')
+         CALL prt_ctl_info(' - Category : ', ivar1=jl)
+         CALL prt_ctl_info('   ~~~~~~~~~~')
+         CALL prt_ctl(tab2d_1=h_i        (:,:,jl)        , clinfo1= ' h_i         : ')
+         CALL prt_ctl(tab2d_1=h_s        (:,:,jl)        , clinfo1= ' h_s         : ')
+         CALL prt_ctl(tab2d_1=t_su       (:,:,jl)        , clinfo1= ' t_su        : ')
+         CALL prt_ctl(tab2d_1=t_s        (:,:,1,jl)      , clinfo1= ' t_snow      : ')
+         CALL prt_ctl(tab2d_1=s_i        (:,:,jl)        , clinfo1= ' s_i         : ')
+         CALL prt_ctl(tab2d_1=o_i        (:,:,jl)        , clinfo1= ' o_i         : ')
+         CALL prt_ctl(tab2d_1=a_i        (:,:,jl)        , clinfo1= ' a_i         : ')
+         CALL prt_ctl(tab2d_1=v_i        (:,:,jl)        , clinfo1= ' v_i         : ')
+         CALL prt_ctl(tab2d_1=v_s        (:,:,jl)        , clinfo1= ' v_s         : ')
+         CALL prt_ctl(tab2d_1=e_i        (:,:,1,jl)      , clinfo1= ' e_i1        : ')
+         CALL prt_ctl(tab2d_1=e_s        (:,:,1,jl)      , clinfo1= ' e_snow      : ')
+         CALL prt_ctl(tab2d_1=sv_i       (:,:,jl)        , clinfo1= ' sv_i        : ')
+         CALL prt_ctl(tab2d_1=oa_i       (:,:,jl)        , clinfo1= ' oa_i        : ')
+         
+         DO jk = 1, nlay_i
+            CALL prt_ctl_info(' - Layer : ', ivar1=jk)
+            CALL prt_ctl(tab2d_1=t_i(:,:,jk,jl) , clinfo1= ' t_i       : ')
+         END DO
+      END DO
+      
+      CALL prt_ctl_info(' ')
+      CALL prt_ctl_info(' - Heat / FW fluxes : ')
+      CALL prt_ctl_info('   ~~~~~~~~~~~~~~~~~~ ')
+      CALL prt_ctl(tab2d_1=sst_m  , clinfo1= ' sst   : ', tab2d_2=sss_m     , clinfo2= ' sss       : ')
+      CALL prt_ctl(tab2d_1=qsr    , clinfo1= ' qsr   : ', tab2d_2=qns       , clinfo2= ' qns       : ')
+      CALL prt_ctl(tab2d_1=emp    , clinfo1= ' emp   : ', tab2d_2=sfx       , clinfo2= ' sfx       : ')
+      
+      CALL prt_ctl_info(' ')
+      CALL prt_ctl_info(' - Stresses : ')
+      CALL prt_ctl_info('   ~~~~~~~~~~ ')
+      CALL prt_ctl(tab2d_1=utau       , clinfo1= ' utau      : ', tab2d_2=vtau       , clinfo2= ' vtau      : ')
+      CALL prt_ctl(tab2d_1=utau_ice   , clinfo1= ' utau_ice  : ', tab2d_2=vtau_ice   , clinfo2= ' vtau_ice  : ')
+      
+   END SUBROUTINE ice_prt3D
+
+#else
+   !!----------------------------------------------------------------------
+   !!   Default option         Empty Module           No SI3 sea-ice model
+   !!----------------------------------------------------------------------
+#endif
+
+   !!======================================================================
+END MODULE icectl
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/ICE_SRC/icedia.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/ICE_SRC/icedia.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/ICE_SRC/icedia.F90	(revision 9570)
@@ -0,0 +1,285 @@
+MODULE icedia
+   !!======================================================================
+   !!                       ***  MODULE icedia  ***
+   !!  Sea-Ice model :   global budgets 
+   !!======================================================================
+   !! History :  3.4  ! 2012-10  (C. Rousset)  original code
+   !!            4.0  ! 2017-08  (C. Rousset)  fits nemo4.0 standards
+   !!----------------------------------------------------------------------
+#if defined key_si3
+   !!----------------------------------------------------------------------
+   !!   'key_si3'                                       SI3 sea-ice model
+   !!----------------------------------------------------------------------
+   !!    ice_dia      : diagnostic of the sea-ice global heat content, salt content and volume conservation
+   !!    ice_dia_init : initialization of budget calculation
+   !!    ice_dia_rst  : read/write budgets restart
+   !!----------------------------------------------------------------------
+   USE dom_oce        ! ocean domain
+   USE phycst         ! physical constant
+   USE daymod         ! model calendar
+   USE sbc_oce , ONLY : sfx, nn_fsbc   ! surface boundary condition: ocean fields
+   USE ice            ! sea-ice: variables
+   USE icerst         ! sea-ice: restart
+   !
+   USE in_out_manager ! I/O manager
+   USE iom            ! I/O manager library
+   USE lib_mpp        ! MPP library
+   USE lib_fortran    ! fortran utilities (glob_sum + no signed zero)
+   USE timing         ! Timing
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   ice_dia        ! called by icestp.F90
+   PUBLIC   ice_dia_init   ! called in icestp.F90
+
+   REAL(wp), DIMENSION(:,:), ALLOCATABLE ::   vol_loc_ini, sal_loc_ini, tem_loc_ini ! initial volume, salt and heat contents
+   REAL(wp)                              ::   frc_sal, frc_voltop, frc_volbot, frc_temtop, frc_tembot  ! global forcing trends
+   
+   !! * Substitutions
+#  include "vectopt_loop_substitute.h90"
+   !!----------------------------------------------------------------------
+   !! NEMO/ICE 4.0 , NEMO Consortium (2017)
+   !! $Id: icedia.F90 8413 2017-08-07 17:05:39Z clem $
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   INTEGER FUNCTION ice_dia_alloc()
+      !!---------------------------------------------------------------------!
+      !!                ***  ROUTINE ice_dia_alloc ***
+      !!---------------------------------------------------------------------!
+      ALLOCATE( vol_loc_ini(jpi,jpj), sal_loc_ini(jpi,jpj), tem_loc_ini(jpi,jpj), STAT=ice_dia_alloc )
+
+      IF( lk_mpp             )   CALL mpp_sum ( ice_dia_alloc )
+      IF( ice_dia_alloc /= 0 )   CALL ctl_warn( 'ice_dia_alloc: failed to allocate arrays' )
+      !
+   END FUNCTION ice_dia_alloc
+
+   SUBROUTINE ice_dia( kt )
+      !!---------------------------------------------------------------------------
+      !!                  ***  ROUTINE ice_dia  ***
+      !!     
+      !! ** Purpose:   Compute the sea-ice global heat content, salt content 
+      !!             and volume conservation
+      !!---------------------------------------------------------------------------
+      INTEGER, INTENT(in) ::   kt   ! ocean time step 
+      !!
+      REAL(wp)   ::   zbg_ivol, zbg_item, zbg_area, zbg_isal
+      REAL(wp)   ::   zbg_svol, zbg_stem
+      REAL(wp)   ::   z_frc_voltop, z_frc_temtop, z_frc_sal
+      REAL(wp)   ::   z_frc_volbot, z_frc_tembot  
+      REAL(wp)   ::   zdiff_vol, zdiff_sal, zdiff_tem  
+      !!---------------------------------------------------------------------------
+      IF( ln_timing )   CALL timing_start('ice_dia')
+
+      IF( kt == nit000 .AND. lwp ) THEN
+         WRITE(numout,*)
+         WRITE(numout,*)'icedia: output ice diagnostics (integrated over the domain)'
+         WRITE(numout,*)'~~~~~~'
+      ENDIF
+
+!!gm glob_sum includes a " * tmask_i ", so remove  " * tmask(:,:,1) "
+
+      ! ----------------------- !
+      ! 1 -  Contents !
+      ! ----------------------- !
+      zbg_ivol = glob_sum( vt_i(:,:) * e1e2t(:,:) ) * 1.e-9                  ! ice volume (km3)
+      zbg_svol = glob_sum( vt_s(:,:) * e1e2t(:,:) ) * 1.e-9                  ! snow volume (km3)
+      zbg_area = glob_sum( at_i(:,:) * e1e2t(:,:) ) * 1.e-6                  ! area (km2)
+      zbg_isal = glob_sum( SUM( sv_i(:,:,:), dim=3 ) * e1e2t(:,:) ) * 1.e-9 ! salt content (pss*km3)
+      zbg_item = glob_sum( et_i * e1e2t(:,:) ) * 1.e-20                      ! heat content (1.e20 J)
+      zbg_stem = glob_sum( et_s * e1e2t(:,:) ) * 1.e-20                      ! heat content (1.e20 J)
+      
+      ! ---------------------------!
+      ! 2 - Trends due to forcing  !
+      ! ---------------------------!
+      z_frc_volbot = r1_rau0 * glob_sum( - ( wfx_ice(:,:) + wfx_snw(:,:) + wfx_err_sub(:,:) ) * e1e2t(:,:) ) * 1.e-9  ! freshwater flux ice/snow-ocean 
+      z_frc_voltop = r1_rau0 * glob_sum( - ( wfx_sub(:,:) + wfx_spr(:,:) ) * e1e2t(:,:) ) * 1.e-9                     ! freshwater flux ice/snow-atm
+      z_frc_sal    = r1_rau0 * glob_sum(   - sfx(:,:) * e1e2t(:,:) ) * 1.e-9                                          ! salt fluxes ice/snow-ocean
+      z_frc_tembot =           glob_sum( hfx_out(:,:) * e1e2t(:,:) ) * 1.e-20                                         ! heat on top of ocean (and below ice)
+      z_frc_temtop =           glob_sum( hfx_in (:,:) * e1e2t(:,:) ) * 1.e-20                                         ! heat on top of ice-coean
+      !
+      frc_voltop  = frc_voltop  + z_frc_voltop  * rdt_ice ! km3
+      frc_volbot  = frc_volbot  + z_frc_volbot  * rdt_ice ! km3
+      frc_sal     = frc_sal     + z_frc_sal     * rdt_ice ! km3*pss
+      frc_temtop  = frc_temtop  + z_frc_temtop  * rdt_ice ! 1.e20 J
+      frc_tembot  = frc_tembot  + z_frc_tembot  * rdt_ice ! 1.e20 J
+            
+      ! ----------------------- !
+      ! 3 -  Content variations !
+      ! ----------------------- !
+      zdiff_vol = r1_rau0 * glob_sum( ( rhoic*vt_i(:,:) + rhosn*vt_s(:,:) - vol_loc_ini(:,:) ) * e1e2t(:,:) ) * 1.e-9 ! freshwater trend (km3) 
+      zdiff_sal = r1_rau0 * glob_sum( ( rhoic* SUM( sv_i(:,:,:), dim=3 ) - sal_loc_ini(:,:) ) * e1e2t(:,:) ) * 1.e-9 ! salt content trend (km3*pss)
+      zdiff_tem =           glob_sum( ( et_i(:,:) + et_s(:,:)             - tem_loc_ini(:,:) ) * e1e2t(:,:) ) * 1.e-20 ! heat content trend (1.e20 J)
+      !                               + SUM( qevap_ice * a_i_b, dim=3 )       !! clem: I think this term should not be there (but needs a check)
+
+      ! ----------------------- !
+      ! 4 -  Drifts             !
+      ! ----------------------- !
+      zdiff_vol = zdiff_vol - ( frc_voltop + frc_volbot )
+      zdiff_sal = zdiff_sal - frc_sal
+      zdiff_tem = zdiff_tem - ( frc_tembot - frc_temtop )
+
+      ! ----------------------- !
+      ! 5 - Diagnostics writing !
+      ! ----------------------- !
+!!gm I don't understand the division by the ocean surface (i.e. glob_sum( e1e2t(:,:) ) * 1.e-20 * kt*rdt )
+!!   and its multiplication bu kt ! is it really what we want ? what is this quantity ?
+!!   IF it is really what we want, compute it at kt=nit000, not 3 time by time-step !
+!!   kt*rdt  : you mean rdtice ?
+!!gm
+      !
+      IF( iom_use('ibgvolume')    )   CALL iom_put( 'ibgvolume' , zdiff_vol     )   ! ice/snow volume  drift            (km3 equivalent ocean water)         
+      IF( iom_use('ibgsaltco')    )   CALL iom_put( 'ibgsaltco' , zdiff_sal     )   ! ice salt content drift            (psu*km3 equivalent ocean water)
+      IF( iom_use('ibgheatco')    )   CALL iom_put( 'ibgheatco' , zdiff_tem     )   ! ice/snow heat content drift       (1.e20 J)
+      IF( iom_use('ibgheatfx')    )   CALL iom_put( 'ibgheatfx' ,               &   ! ice/snow heat flux drift          (W/m2)
+         &                                                     zdiff_tem /glob_sum( e1e2t(:,:) * 1.e-20 * kt*rdt ) )
+
+      IF( iom_use('ibgfrcvoltop') )   CALL iom_put( 'ibgfrcvoltop' , frc_voltop )   ! vol  forcing ice/snw-atm          (km3 equivalent ocean water) 
+      IF( iom_use('ibgfrcvolbot') )   CALL iom_put( 'ibgfrcvolbot' , frc_volbot )   ! vol  forcing ice/snw-ocean        (km3 equivalent ocean water) 
+      IF( iom_use('ibgfrcsal')    )   CALL iom_put( 'ibgfrcsal'    , frc_sal    )   ! sal - forcing                     (psu*km3 equivalent ocean water)   
+      IF( iom_use('ibgfrctemtop') )   CALL iom_put( 'ibgfrctemtop' , frc_temtop )   ! heat on top of ice/snw/ocean      (1.e20 J)   
+      IF( iom_use('ibgfrctembot') )   CALL iom_put( 'ibgfrctembot' , frc_tembot )   ! heat on top of ocean(below ice)   (1.e20 J)   
+      IF( iom_use('ibgfrchfxtop') )   CALL iom_put( 'ibgfrchfxtop' ,            &   ! heat on top of ice/snw/ocean      (W/m2) 
+         &                                                          frc_temtop / glob_sum( e1e2t(:,:) ) * 1.e-20 * kt*rdt  )
+      IF( iom_use('ibgfrchfxbot') )   CALL iom_put( 'ibgfrchfxbot' ,            &   ! heat on top of ocean(below ice)   (W/m2) 
+         &                                                          frc_tembot / glob_sum( e1e2t(:,:) ) * 1.e-20 * kt*rdt  )
+
+      IF( iom_use('ibgvol_tot' )  )   CALL iom_put( 'ibgvol_tot'  , zbg_ivol     )   ! ice volume                       (km3)
+      IF( iom_use('sbgvol_tot' )  )   CALL iom_put( 'sbgvol_tot'  , zbg_svol     )   ! snow volume                      (km3)
+      IF( iom_use('ibgarea_tot')  )   CALL iom_put( 'ibgarea_tot' , zbg_area     )   ! ice area                         (km2)
+      IF( iom_use('ibgsalt_tot')  )   CALL iom_put( 'ibgsalt_tot' , zbg_isal     )   ! ice salinity content             (pss*km3)
+      IF( iom_use('ibgheat_tot')  )   CALL iom_put( 'ibgheat_tot' , zbg_item     )   ! ice heat content                 (1.e20 J)
+      IF( iom_use('sbgheat_tot')  )   CALL iom_put( 'sbgheat_tot' , zbg_stem     )   ! snow heat content                (1.e20 J)
+      !
+      IF( lrst_ice )   CALL ice_dia_rst( 'WRITE', kt_ice )
+      !
+      IF( ln_timing )   CALL timing_stop('ice_dia')
+      !
+   END SUBROUTINE ice_dia
+
+
+   SUBROUTINE ice_dia_init
+      !!---------------------------------------------------------------------------
+      !!                  ***  ROUTINE ice_dia_init  ***
+      !!     
+      !! ** Purpose: Initialization for the heat salt volume budgets
+      !!	
+      !! ** Method : Compute initial heat content, salt content and volume
+      !!
+      !! ** Action : - Compute initial heat content, salt content and volume
+      !!             - Initialize forcing trends
+      !!             - Compute coefficients for conversion
+      !!---------------------------------------------------------------------------
+      INTEGER            ::   ios, ierror   ! local integer
+      !!
+      NAMELIST/namdia/ ln_icediachk, ln_icediahsb, ln_icectl, iiceprt, jiceprt  
+      !!----------------------------------------------------------------------
+      !
+      REWIND( numnam_ice_ref )      ! Namelist namdia in reference namelist : Parameters for ice
+      READ  ( numnam_ice_ref, namdia, IOSTAT = ios, ERR = 901)
+901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namdia in reference namelist', lwp )
+      REWIND( numnam_ice_cfg )      ! Namelist namdia in configuration namelist : Parameters for ice
+      READ  ( numnam_ice_cfg, namdia, IOSTAT = ios, ERR = 902 )
+902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namdia in configuration namelist', lwp )
+      IF(lwm) WRITE ( numoni, namdia )
+      !
+      IF(lwp) THEN                  ! control print
+         WRITE(numout,*)
+         WRITE(numout,*) 'ice_dia_init: ice diagnostics'
+         WRITE(numout,*) ' ~~~~~~~~~~~'
+         WRITE(numout,*) '   Namelist namdia:'
+         WRITE(numout,*) '      Diagnose online heat/mass/salt budget      ln_icediachk = ', ln_icediachk
+         WRITE(numout,*) '      Output          heat/mass/salt budget      ln_icediahsb = ', ln_icediahsb
+         WRITE(numout,*) '      control prints for a given grid point      ln_icectl    = ', ln_icectl
+         WRITE(numout,*) '         chosen grid point position         (iiceprt,jiceprt) = (', iiceprt,',', jiceprt,')'
+      ENDIF
+      !      
+      IF( ln_icediahsb ) THEN
+         IF( ice_dia_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'ice_dia_init : unable to allocate arrays' )   ! allocate tke arrays
+         CALL ice_dia_rst( 'READ' )   ! read or initialize all required files
+      ENDIF
+      !
+   END SUBROUTINE ice_dia_init
+
+
+   SUBROUTINE ice_dia_rst( cdrw, kt )
+      !!---------------------------------------------------------------------
+      !!                   ***  ROUTINE icedia_rst  ***
+      !!                     
+      !! ** Purpose :   Read or write DIA file in restart file
+      !!
+      !! ** Method  :   use of IOM library
+      !!----------------------------------------------------------------------
+      CHARACTER(len=*) , INTENT(in) ::   cdrw   ! "READ"/"WRITE" flag
+      INTEGER, OPTIONAL, INTENT(in) ::   kt     ! ice time-step
+      !
+      INTEGER  ::   iter    ! local integer
+      REAL(wp) ::   ziter   ! local scalar
+      !!----------------------------------------------------------------------
+      !
+      IF( TRIM(cdrw) == 'READ' ) THEN        ! Read/initialise 
+         IF( ln_rstart ) THEN                   !* Read the restart file
+            !
+            CALL iom_get( numrir, 'kt_ice' , ziter )
+            IF(lwp) WRITE(numout,*)
+            IF(lwp) WRITE(numout,*) 'ice_dia_rst read at time step = ', ziter
+            IF(lwp) WRITE(numout,*) '~~~~~~~~~~'
+            CALL iom_get( numrir, 'frc_voltop' , frc_voltop  )
+            CALL iom_get( numrir, 'frc_volbot' , frc_volbot  )
+            CALL iom_get( numrir, 'frc_temtop' , frc_temtop  )
+            CALL iom_get( numrir, 'frc_tembot' , frc_tembot  )
+            CALL iom_get( numrir, 'frc_sal'    , frc_sal     )
+            CALL iom_get( numrir, jpdom_autoglo, 'vol_loc_ini', vol_loc_ini )
+            CALL iom_get( numrir, jpdom_autoglo, 'tem_loc_ini', tem_loc_ini )
+            CALL iom_get( numrir, jpdom_autoglo, 'sal_loc_ini', sal_loc_ini )
+         ELSE
+            IF(lwp) WRITE(numout,*)
+            IF(lwp) WRITE(numout,*) ' ice_dia at initial state '
+            IF(lwp) WRITE(numout,*) '~~~~~~~'
+            ! set trends to 0
+            frc_voltop  = 0._wp                                          
+            frc_volbot  = 0._wp                                          
+            frc_temtop  = 0._wp                                                 
+            frc_tembot  = 0._wp                                                 
+            frc_sal     = 0._wp                                                 
+            ! record initial ice volume, salt and temp
+            vol_loc_ini(:,:) = rhoic * vt_i(:,:) + rhosn * vt_s(:,:)  ! ice/snow volume (kg/m2)
+            tem_loc_ini(:,:) = et_i(:,:) + et_s(:,:)                  ! ice/snow heat content (J)
+            sal_loc_ini(:,:) = rhoic * SUM( sv_i(:,:,:), dim=3 )      ! ice salt content (pss*kg/m2)
+         ENDIF
+         !
+      ELSEIF( TRIM(cdrw) == 'WRITE' ) THEN   ! Create restart file
+         !                                   ! -------------------
+         iter = kt + nn_fsbc - 1   ! ice restarts are written at kt == nitrst - nn_fsbc + 1
+         !
+         IF( iter == nitrst ) THEN
+            IF(lwp) WRITE(numout,*)
+            IF(lwp) WRITE(numout,*) 'ice_dia_rst write at time step = ', kt
+            IF(lwp) WRITE(numout,*) '~~~~~~~~~~~'
+         ENDIF
+         !
+         ! Write in numriw (if iter == nitrst)
+         ! ------------------ 
+         CALL iom_rstput( iter, nitrst, numriw, 'frc_voltop' , frc_voltop  )
+         CALL iom_rstput( iter, nitrst, numriw, 'frc_volbot' , frc_volbot  )
+         CALL iom_rstput( iter, nitrst, numriw, 'frc_temtop' , frc_temtop  )
+         CALL iom_rstput( iter, nitrst, numriw, 'frc_tembot' , frc_tembot  )
+         CALL iom_rstput( iter, nitrst, numriw, 'frc_sal'    , frc_sal     )
+         CALL iom_rstput( iter, nitrst, numriw, 'vol_loc_ini', vol_loc_ini )
+         CALL iom_rstput( iter, nitrst, numriw, 'tem_loc_ini', tem_loc_ini )
+         CALL iom_rstput( iter, nitrst, numriw, 'sal_loc_ini', sal_loc_ini )
+         !
+      ENDIF
+      !
+   END SUBROUTINE ice_dia_rst
+ 
+#else
+   !!----------------------------------------------------------------------
+   !!   Default option :         Empty module         NO SI3 sea-ice model
+   !!----------------------------------------------------------------------
+#endif
+
+   !!======================================================================
+END MODULE icedia
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/ICE_SRC/icedyn.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/ICE_SRC/icedyn.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/ICE_SRC/icedyn.F90	(revision 9570)
@@ -0,0 +1,276 @@
+MODULE icedyn
+   !!======================================================================
+   !!                     ***  MODULE  icedyn  ***
+   !!   Sea-Ice dynamics : master routine for sea ice dynamics 
+   !!======================================================================
+   !! history :  4.0  ! 2017-09  (C. Rousset)  original code 
+   !!----------------------------------------------------------------------
+#if defined key_si3
+   !!----------------------------------------------------------------------
+   !!   'key_si3'                                       SI3 sea-ice model
+   !!----------------------------------------------------------------------
+   !!   ice_dyn       : dynamics of sea ice
+   !!   ice_dyn_init  : initialization and namelist read
+   !!----------------------------------------------------------------------
+   USE phycst         ! physical constants
+   USE dom_oce        ! ocean space and time domain
+   USE ice            ! sea-ice: variables
+   USE icedyn_rhg     ! sea-ice: rheology
+   USE icedyn_adv     ! sea-ice: advection
+   USE icedyn_rdgrft  ! sea-ice: ridging/rafting
+   USE icecor         ! sea-ice: corrections
+   USE icevar         ! sea-ice: operations
+   !
+   USE in_out_manager ! I/O manager
+   USE iom            ! I/O manager library
+   USE lib_mpp        ! MPP library
+   USE lib_fortran    ! fortran utilities (glob_sum + no signed zero)
+   USE lbclnk         ! lateral boundary conditions (or mpp links)
+   USE timing         ! Timing
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   ice_dyn        ! called by icestp.F90
+   PUBLIC   ice_dyn_init   ! called by icestp.F90
+   
+   INTEGER ::              nice_dyn   ! choice of the type of dynamics
+   !                                        ! associated indices:
+   INTEGER, PARAMETER ::   np_dynFULL    = 1   ! full ice dynamics               (rheology + advection + ridging/rafting + correction)
+   INTEGER, PARAMETER ::   np_dynRHGADV  = 2   ! pure dynamics                   (rheology + advection) 
+   INTEGER, PARAMETER ::   np_dynADV     = 3   ! only advection w prescribed vel.(rn_uvice + advection)
+   !
+   ! ** namelist (namdyn) **
+   LOGICAL  ::   ln_dynFULL       ! full ice dynamics               (rheology + advection + ridging/rafting + correction)
+   LOGICAL  ::   ln_dynRHGADV     ! no ridge/raft & no corrections  (rheology + advection)
+   LOGICAL  ::   ln_dynADV        ! only advection w prescribed vel.(rn_uvice + advection)
+   REAL(wp) ::   rn_uice          !    prescribed u-vel (case np_dynADV)
+   REAL(wp) ::   rn_vice          !    prescribed v-vel (case np_dynADV)
+   
+   !! * Substitutions
+#  include "vectopt_loop_substitute.h90"
+   !!----------------------------------------------------------------------
+   !! NEMO/ICE 4.0 , NEMO Consortium (2017)
+   !! $Id: icedyn.F90 8378 2017-07-26 13:55:59Z clem $
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE ice_dyn( kt )
+      !!-------------------------------------------------------------------
+      !!               ***  ROUTINE ice_dyn  ***
+      !!               
+      !! ** Purpose :   this routine manages sea ice dynamics
+      !!
+      !! ** Action : - Initialisation of some variables
+      !!             - call ice_rhg
+      !!--------------------------------------------------------------------
+      INTEGER, INTENT(in) ::   kt     ! ice time step
+      !!
+      INTEGER ::   ji, jj, jl         ! dummy loop indices
+      REAL(wp), DIMENSION(jpi,jpj,jpl) ::   zhmax
+      !!--------------------------------------------------------------------
+      !
+      IF( ln_timing )   CALL timing_start('icedyn')
+      !
+      IF( kt == nit000 .AND. lwp ) THEN
+         WRITE(numout,*)
+         WRITE(numout,*)'ice_dyn: sea-ice dynamics'
+         WRITE(numout,*)'~~~~~~~'
+      ENDIF
+
+      !                      
+      IF( ln_landfast ) THEN            !-- Landfast ice parameterization: define max bottom friction
+         tau_icebfr(:,:) = 0._wp
+         DO jl = 1, jpl
+            WHERE( h_i(:,:,jl) > ht_n(:,:) * rn_gamma )   tau_icebfr(:,:) = tau_icebfr(:,:) + a_i(:,:,jl) * rn_icebfr
+         END DO
+         IF( iom_use('tau_icebfr') )   CALL iom_put( 'tau_icebfr', tau_icebfr )  
+      ENDIF
+
+      zhmax(:,:,:) = h_i_b(:,:,:)      !-- Record max of the surrounding 9-pts ice thick. (for CALL Hbig)
+      DO jl = 1, jpl
+         DO jj = 2, jpjm1
+            DO ji = 2, jpim1
+!!gm use of MAXVAL here is very probably less efficient than expending the 9 values
+               zhmax(ji,jj,jl) = MAX( epsi20, MAXVAL( h_i_b(ji-1:ji+1,jj-1:jj+1,jl) ) )
+            END DO
+         END DO
+      END DO
+      CALL lbc_lnk( zhmax(:,:,:), 'T', 1. )
+      !
+      !
+      SELECT CASE( nice_dyn )           !-- Set which dynamics is running
+
+      CASE ( np_dynFULL )          !==  all dynamical processes  ==!
+         CALL ice_dyn_rhg   ( kt )                            ! -- rheology  
+         CALL ice_dyn_adv   ( kt )   ;   CALL Hbig( zhmax )   ! -- advection of ice + correction on ice thickness
+         CALL ice_dyn_rdgrft( kt )                            ! -- ridging/rafting 
+         CALL ice_cor       ( kt , 1 )                        ! -- Corrections
+
+      CASE ( np_dynRHGADV  )       !==  no ridge/raft & no corrections ==!
+         CALL ice_dyn_rhg   ( kt )                            ! -- rheology  
+         CALL ice_dyn_adv   ( kt )                            ! -- advection of ice
+         CALL Hpiling                                         ! -- simple pile-up (replaces ridging/rafting)
+
+      CASE ( np_dynADV )           !==  pure advection ==!   (prescribed velocities)
+         u_ice(:,:) = rn_uice * umask(:,:,1)
+         v_ice(:,:) = rn_vice * vmask(:,:,1)
+         !!CALL RANDOM_NUMBER(u_ice(:,:))
+         !!CALL RANDOM_NUMBER(v_ice(:,:))
+         CALL ice_dyn_adv   ( kt )                            ! -- advection of ice
+
+      END SELECT
+      !
+      IF( ln_timing )   CALL timing_stop('icedyn')
+      !
+   END SUBROUTINE ice_dyn
+
+
+   SUBROUTINE Hbig( phmax )
+      !!-------------------------------------------------------------------
+      !!                  ***  ROUTINE Hbig  ***
+      !!
+      !! ** Purpose : Thickness correction in case advection scheme creates
+      !!              abnormally tick ice
+      !!
+      !! ** Method  : 1- check whether ice thickness resulting from advection is
+      !!                 larger than the surrounding 9-points before advection
+      !!                 and reduce it if a) divergence or b) convergence & at_i>0.8
+      !!              2- bound ice thickness with hi_max (99m)
+      !!
+      !! ** input   : Max thickness of the surrounding 9-points
+      !!-------------------------------------------------------------------
+      REAL(wp), DIMENSION(:,:,:), INTENT(in) ::   phmax   ! max ice thick from surrounding 9-pts
+      !
+      INTEGER  ::   ji, jj, jl         ! dummy loop indices
+      REAL(wp) ::   zh, zdv
+      !!-------------------------------------------------------------------
+      !
+      CALL ice_var_zapsmall                       !-- zap small areas
+      !
+      DO jl = 1, jpl
+         DO jj = 1, jpj
+            DO ji = 1, jpi
+               IF ( v_i(ji,jj,jl) > 0._wp ) THEN  !-- bound to hmax
+                  !
+                  zh  = v_i (ji,jj,jl) / a_i(ji,jj,jl)
+                  zdv = v_i(ji,jj,jl) - v_i_b(ji,jj,jl)  
+                  !
+                  IF ( ( zdv >  0.0 .AND. zh > phmax(ji,jj,jl) .AND. at_i_b(ji,jj) < 0.80 ) .OR. &
+                     & ( zdv <= 0.0 .AND. zh > phmax(ji,jj,jl) ) ) THEN
+                     a_i (ji,jj,jl) = v_i(ji,jj,jl) / MIN( phmax(ji,jj,jl), hi_max(jpl) )   !-- bound h_i to hi_max (99 m)
+                  ENDIF
+                  !
+               ENDIF
+            END DO
+         END DO
+      END DO 
+      !                                           !-- correct pond fraction to avoid a_ip > a_i
+      WHERE( a_ip(:,:,:) > a_i(:,:,:) )   a_ip(:,:,:) = a_i(:,:,:)
+      !
+   END SUBROUTINE Hbig
+
+
+   SUBROUTINE Hpiling
+      !!-------------------------------------------------------------------
+      !!                  ***  ROUTINE Hpiling  ***
+      !!
+      !! ** Purpose : Simple conservative piling comparable with 1-cat models
+      !!
+      !! ** Method  : pile-up ice when no ridging/rafting
+      !!
+      !! ** input   : a_i
+      !!-------------------------------------------------------------------
+      INTEGER ::   jl         ! dummy loop indices
+      !!-------------------------------------------------------------------
+      !
+      CALL ice_var_zapsmall                       !-- zap small areas
+      !
+      at_i(:,:) = SUM( a_i(:,:,:), dim=3 )
+      DO jl = 1, jpl
+         WHERE( at_i(:,:) > epsi20 )
+            a_i(:,:,jl) = a_i(:,:,jl) * (  1._wp + MIN( rn_amax_2d(:,:) - at_i(:,:) , 0._wp ) / at_i(:,:)  )
+         END WHERE
+      END DO
+      !
+   END SUBROUTINE Hpiling
+
+
+   SUBROUTINE ice_dyn_init
+      !!-------------------------------------------------------------------
+      !!                  ***  ROUTINE ice_dyn_init  ***
+      !!
+      !! ** Purpose : Physical constants and parameters linked to the ice
+      !!      dynamics
+      !!
+      !! ** Method  :  Read the namdyn namelist and check the ice-dynamic
+      !!       parameter values called at the first timestep (nit000)
+      !!
+      !! ** input   :   Namelist namdyn
+      !!-------------------------------------------------------------------
+      INTEGER ::   ios, ioptio   ! Local integer output status for namelist read
+      !!
+      NAMELIST/namdyn/ ln_dynFULL, ln_dynRHGADV, ln_dynADV, rn_uice, rn_vice,  &
+         &             rn_ishlat  ,                                            &
+         &             ln_landfast, rn_gamma , rn_icebfr, rn_lfrelax
+      !!-------------------------------------------------------------------
+      !
+      REWIND( numnam_ice_ref )         ! Namelist namdyn in reference namelist : Ice dynamics
+      READ  ( numnam_ice_ref, namdyn, IOSTAT = ios, ERR = 901)
+901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namdyn in reference namelist', lwp )
+      REWIND( numnam_ice_cfg )         ! Namelist namdyn in configuration namelist : Ice dynamics
+      READ  ( numnam_ice_cfg, namdyn, IOSTAT = ios, ERR = 902 )
+902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namdyn in configuration namelist', lwp )
+      IF(lwm) WRITE( numoni, namdyn )
+      !
+      IF(lwp) THEN                     ! control print
+         WRITE(numout,*)
+         WRITE(numout,*) 'ice_dyn_init: ice parameters for ice dynamics '
+         WRITE(numout,*) '~~~~~~~~~~~~'
+         WRITE(numout,*) '   Namelist namdyn:'
+         WRITE(numout,*) '      Full ice dynamics      (rhg + adv + ridge/raft + corr)  ln_dynFULL   = ', ln_dynFULL
+         WRITE(numout,*) '      No ridge/raft & No cor (rhg + adv)                      ln_dynRHGADV = ', ln_dynRHGADV
+         WRITE(numout,*) '      Advection only         (rn_uvice + adv)                 ln_dynADV    = ', ln_dynADV
+         WRITE(numout,*) '         with prescribed velocity given by   (u,v)_ice = (rn_uice,rn_vice) = (', rn_uice,',', rn_vice,')'
+         WRITE(numout,*) '      lateral boundary condition for sea ice dynamics         rn_ishlat    = ', rn_ishlat
+         WRITE(numout,*) '      Landfast: param (T or F)                                ln_landfast  = ', ln_landfast
+         WRITE(numout,*) '         fraction of ocean depth that ice must reach          rn_gamma     = ', rn_gamma
+         WRITE(numout,*) '         maximum bottom stress per unit area of contact       rn_icebfr    = ', rn_icebfr
+         WRITE(numout,*) '         relax time scale (s-1) to reach static friction      rn_lfrelax   = ', rn_lfrelax
+         WRITE(numout,*)
+      ENDIF
+      !                             !== set the choice of ice dynamics ==!
+      ioptio = 0 
+      !      !--- full dynamics                               (rheology + advection + ridging/rafting + correction)
+      IF( ln_dynFULL   ) THEN   ;   ioptio = ioptio + 1   ;   nice_dyn = np_dynFULL      ;   ENDIF
+      !      !--- dynamics without ridging/rafting and corr   (rheology + advection)
+      IF( ln_dynRHGADV ) THEN   ;   ioptio = ioptio + 1   ;   nice_dyn = np_dynRHGADV    ;   ENDIF
+      !      !--- advection only with prescribed ice velocities (from namelist)
+      IF( ln_dynADV    ) THEN   ;   ioptio = ioptio + 1   ;   nice_dyn = np_dynADV       ;   ENDIF
+      !
+      IF( ioptio /= 1 )    CALL ctl_stop( 'ice_dyn_init: one and only one ice dynamics option has to be defined ' )
+      !
+      !                                      !--- Lateral boundary conditions
+      IF     (      rn_ishlat == 0.                ) THEN   ;   IF(lwp) WRITE(numout,*) '   ===>>>   ice lateral  free-slip'
+      ELSEIF (      rn_ishlat == 2.                ) THEN   ;   IF(lwp) WRITE(numout,*) '   ===>>>   ice lateral  no-slip'
+      ELSEIF ( 0. < rn_ishlat .AND. rn_ishlat < 2. ) THEN   ;   IF(lwp) WRITE(numout,*) '   ===>>>   ice lateral  partial-slip'
+      ELSEIF ( 2. < rn_ishlat                      ) THEN   ;   IF(lwp) WRITE(numout,*) '   ===>>>   ice lateral  strong-slip'
+      ENDIF
+      !                                      !--- NO Landfast ice : set to zero once for all
+      IF( .NOT.ln_landfast )   tau_icebfr(:,:) = 0._wp
+      !
+      CALL ice_dyn_rdgrft_init          ! set ice ridging/rafting parameters
+      CALL ice_dyn_rhg_init             ! set ice rheology parameters
+      CALL ice_dyn_adv_init             ! set ice advection parameters
+      !
+   END SUBROUTINE ice_dyn_init
+
+#else
+   !!----------------------------------------------------------------------
+   !!   Default option         Empty module           NO SI3 sea-ice model
+   !!----------------------------------------------------------------------
+#endif 
+
+   !!======================================================================
+END MODULE icedyn
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/ICE_SRC/icedyn_adv.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/ICE_SRC/icedyn_adv.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/ICE_SRC/icedyn_adv.F90	(revision 9570)
@@ -0,0 +1,174 @@
+MODULE icedyn_adv
+   !!======================================================================
+   !!                       ***  MODULE icedyn_adv   ***
+   !!   SI3 : sea-ice advection
+   !!======================================================================
+   !! History : LIM-2 ! 2000-01 (M.A. Morales Maqueda, H. Goosse, and T. Fichefet)  Original code
+   !!            3.0  ! 2005-11 (M. Vancoppenolle)   Multi-layer sea ice, salinity variations
+   !!            4.0  ! 2011-02 (G. Madec) dynamical allocation
+   !!----------------------------------------------------------------------
+#if defined key_si3
+   !!----------------------------------------------------------------------
+   !!   'key_si3'                                       SI3 sea-ice model
+   !!----------------------------------------------------------------------
+   !!   ice_dyn_adv   : advection of sea ice variables
+   !!----------------------------------------------------------------------
+   USE phycst         ! physical constant
+   USE dom_oce        ! ocean domain
+   USE sbc_oce , ONLY : nn_fsbc   ! frequency of sea-ice call
+   USE ice            ! sea-ice: variables
+   USE icevar         ! sea-ice: operations
+   USE icedyn_adv_pra ! sea-ice: advection scheme (Prather)
+   USE icedyn_adv_umx ! sea-ice: advection scheme (ultimate-macho)
+   USE icectl         ! sea-ice: control prints
+   !
+   USE in_out_manager ! I/O manager
+   USE iom            ! I/O manager library
+   USE lib_mpp        ! MPP library
+   USE lib_fortran    ! fortran utilities (glob_sum + no signed zero)
+   USE timing         ! Timing
+   USE prtctl         ! Print control
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   ice_dyn_adv        ! called by icestp
+   PUBLIC   ice_dyn_adv_init   ! called by icedyn
+
+   INTEGER ::              nice_adv   ! choice of the type of advection scheme
+   !                                        ! associated indices:
+   INTEGER, PARAMETER ::   np_advPRA = 1   ! Prather scheme
+   INTEGER, PARAMETER ::   np_advUMx = 2   ! Ultimate-Macho scheme
+   !
+   ! ** namelist (namdyn_adv) **
+   LOGICAL ::   ln_adv_Pra   ! Prather        advection scheme
+   LOGICAL ::   ln_adv_UMx   ! Ultimate-Macho advection scheme
+   INTEGER ::   nn_UMx       ! order of the UMx advection scheme   
+   !
+   !! * Substitution
+#  include "vectopt_loop_substitute.h90"
+   !!----------------------------------------------------------------------
+   !! NEMO/ICE 4.0 , NEMO Consortium (2017)
+   !! $Id: icedyn_adv.F90 8373 2017-07-25 17:44:54Z clem $
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE ice_dyn_adv( kt ) 
+      !!----------------------------------------------------------------------
+      !!                   ***  ROUTINE ice_dyn_adv ***
+      !!                    
+      !! ** purpose : advection of sea ice
+      !!
+      !! ** method  : One can choose between 
+      !!     a) an Ultimate-Macho scheme (with order defined by nn_UMx) => ln_adv_UMx
+      !!     b) and a second order Prather scheme => ln_adv_Pra
+      !!
+      !! ** action :
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT(in) ::   kt   ! number of iteration
+      !!---------------------------------------------------------------------
+      !
+      IF( ln_timing )   CALL timing_start('icedyn_adv')
+      !
+      IF( kt == nit000 .AND. lwp ) THEN
+         WRITE(numout,*)
+         WRITE(numout,*) 'ice_dyn_adv: sea-ice advection'
+         WRITE(numout,*) '~~~~~~~~~~~'
+      ENDIF
+      
+      ! conservation test
+      IF( ln_icediachk )   CALL ice_cons_hsm(0, 'icedyn_adv', rdiag_v, rdiag_s, rdiag_t, rdiag_fv, rdiag_fs, rdiag_ft)
+                     
+      !----------
+      ! Advection
+      !----------
+      SELECT CASE( nice_adv )
+      !                                !-----------------------!
+      CASE( np_advUMx )                ! ULTIMATE-MACHO scheme !
+         !                             !-----------------------!
+         CALL ice_dyn_adv_umx( nn_UMx, kt, u_ice, v_ice,  &
+            &                  ato_i, v_i, v_s, sv_i, oa_i, a_i, a_ip, v_ip, e_s, e_i )
+      !                                !-----------------------!
+      CASE( np_advPRA )                ! PRATHER scheme        !
+         !                             !-----------------------!
+         CALL ice_dyn_adv_pra( kt, u_ice, v_ice,  &
+            &                  ato_i, v_i, v_s, sv_i, oa_i, a_i, a_ip, v_ip, e_s, e_i )
+      END SELECT
+
+      !------------
+      ! diagnostics
+      !------------
+      diag_trp_ei(:,:) = SUM(SUM( e_i (:,:,1:nlay_i,:) - e_i_b (:,:,1:nlay_i,:), dim=4 ), dim=3 ) * r1_rdtice
+      diag_trp_es(:,:) = SUM(SUM( e_s (:,:,1:nlay_s,:) - e_s_b (:,:,1:nlay_s,:), dim=4 ), dim=3 ) * r1_rdtice
+      diag_trp_sv(:,:) = SUM(     sv_i(:,:,:)          - sv_i_b(:,:,:)                  , dim=3 ) * r1_rdtice
+      diag_trp_vi(:,:) = SUM(     v_i (:,:,:)          - v_i_b (:,:,:)                  , dim=3 ) * r1_rdtice
+      diag_trp_vs(:,:) = SUM(     v_s (:,:,:)          - v_s_b (:,:,:)                  , dim=3 ) * r1_rdtice
+      IF( iom_use('icemtrp') )   CALL iom_put( "icemtrp" , diag_trp_vi * rhoic          )   ! ice mass transport
+      IF( iom_use('snwmtrp') )   CALL iom_put( "snwmtrp" , diag_trp_vs * rhosn          )   ! snw mass transport
+      IF( iom_use('salmtrp') )   CALL iom_put( "salmtrp" , diag_trp_sv * rhoic * 1.e-03 )   ! salt mass transport (kg/m2/s)
+      IF( iom_use('dihctrp') )   CALL iom_put( "dihctrp" , -diag_trp_ei                 )   ! advected ice heat content (W/m2)
+      IF( iom_use('dshctrp') )   CALL iom_put( "dshctrp" , -diag_trp_es                 )   ! advected snw heat content (W/m2)
+
+      ! controls
+      IF( ln_icediachk )   CALL ice_cons_hsm(1, 'icedyn_adv', rdiag_v, rdiag_s, rdiag_t, rdiag_fv, rdiag_fs, rdiag_ft) ! conservation
+      IF( ln_icectl    )   CALL ice_prt     (kt, iiceprt, jiceprt,-1, ' - ice dyn & trp - ')                           ! prints
+      IF( ln_timing    )   CALL timing_stop ('icedyn_adv')                                                             ! timing
+      !
+   END SUBROUTINE ice_dyn_adv
+
+
+   SUBROUTINE ice_dyn_adv_init
+      !!-------------------------------------------------------------------
+      !!                  ***  ROUTINE ice_dyn_adv_init  ***
+      !!
+      !! ** Purpose :   Physical constants and parameters linked to the ice
+      !!                dynamics
+      !!
+      !! ** Method  :   Read the namdyn_adv namelist and check the ice-dynamic
+      !!                parameter values called at the first timestep (nit000)
+      !!
+      !! ** input   :   Namelist namdyn_adv
+      !!-------------------------------------------------------------------
+      INTEGER ::   ios, ioptio   ! Local integer output status for namelist read
+      !!
+      NAMELIST/namdyn_adv/ ln_adv_Pra, ln_adv_UMx, nn_UMx
+      !!-------------------------------------------------------------------
+      !
+      REWIND( numnam_ice_ref )         ! Namelist namdyn_adv in reference namelist : Ice dynamics
+      READ  ( numnam_ice_ref, namdyn_adv, IOSTAT = ios, ERR = 901)
+901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namdyn_adv in reference namelist', lwp )
+      REWIND( numnam_ice_cfg )         ! Namelist namdyn_adv in configuration namelist : Ice dynamics
+      READ  ( numnam_ice_cfg, namdyn_adv, IOSTAT = ios, ERR = 902 )
+902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namdyn_adv in configuration namelist', lwp )
+      IF(lwm) WRITE( numoni, namdyn_adv )
+      !
+      IF(lwp) THEN                     ! control print
+         WRITE(numout,*)
+         WRITE(numout,*) 'ice_dyn_adv_init: ice parameters for ice dynamics '
+         WRITE(numout,*) '~~~~~~~~~~~~~~~~'
+         WRITE(numout,*) '   Namelist namdyn_adv:'
+         WRITE(numout,*) '      type of advection scheme (Prather)             ln_adv_Pra = ', ln_adv_Pra 
+         WRITE(numout,*) '      type of advection scheme (Ulimate-Macho)       ln_adv_UMx = ', ln_adv_UMx 
+         WRITE(numout,*) '         order of the Ultimate-Macho scheme          nn_UMx     = ', nn_UMx
+      ENDIF
+      !
+      !                             !== set the choice of ice advection ==!
+      ioptio = 0 
+      IF( ln_adv_Pra ) THEN   ;   ioptio = ioptio + 1   ;   nice_adv = np_advPRA    ;   ENDIF
+      IF( ln_adv_UMx ) THEN   ;   ioptio = ioptio + 1   ;   nice_adv = np_advUMx    ;   ENDIF
+      IF( ioptio /= 1 )   CALL ctl_stop( 'ice_dyn_adv_init: choose one and only one ice adv. scheme (ln_adv_Pra or ln_adv_UMx)' )
+      !
+      IF( ln_adv_Pra )   CALL adv_pra_init  !* read or initialize all required files
+      !
+   END SUBROUTINE ice_dyn_adv_init
+
+#else
+   !!----------------------------------------------------------------------
+   !!   Default option         Empty Module           NO SI3 sea-ice model
+   !!----------------------------------------------------------------------
+#endif
+
+   !!======================================================================
+END MODULE icedyn_adv
+
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/ICE_SRC/icedyn_adv_pra.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/ICE_SRC/icedyn_adv_pra.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/ICE_SRC/icedyn_adv_pra.F90	(revision 9570)
@@ -0,0 +1,857 @@
+MODULE icedyn_adv_pra 
+   !!======================================================================
+   !!                       ***  MODULE icedyn_adv_pra   ***
+   !!   sea-ice : advection => Prather scheme
+   !!======================================================================
+   !! History :  LIM  ! 2008-03 (M. Vancoppenolle)  LIM-3 from LIM-2 code
+   !!            3.2  ! 2009-06 (F. Dupont)  correct a error in the North fold b.c.
+   !!            4.0  ! 2011-02 (G. Madec) dynamical allocation
+   !!--------------------------------------------------------------------
+#if defined key_si3
+   !!----------------------------------------------------------------------
+   !!   'key_si3'                                       SI3 sea-ice model
+   !!----------------------------------------------------------------------
+   !!   ice_dyn_adv_pra : advection of sea ice using Prather scheme
+   !!   adv_x, adv_y    : Prather scheme applied in i- and j-direction, resp.
+   !!   adv_pra_init    : initialisation of the Prather scheme
+   !!   adv_pra_rst     : read/write Prather field in ice restart file, or initialized to zero
+   !!----------------------------------------------------------------------
+   USE dom_oce        ! ocean domain
+   USE ice            ! sea-ice variables
+   USE sbc_oce , ONLY : nn_fsbc   ! frequency of sea-ice call
+   !
+   USE in_out_manager ! I/O manager
+   USE iom            ! I/O manager library
+   USE lib_mpp        ! MPP library
+   USE lib_fortran    ! fortran utilities (glob_sum + no signed zero)
+   USE lbclnk         ! lateral boundary conditions (or mpp links)
+   USE prtctl         ! Print control
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   ice_dyn_adv_pra   ! called by icedyn_adv
+   PUBLIC   adv_pra_init      ! called by icedyn_adv
+
+   ! Moments for advection
+   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:)   ::   sxice, syice, sxxice, syyice, sxyice   ! ice thickness 
+   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:)   ::   sxsn , sysn , sxxsn , syysn , sxysn    ! snow thickness
+   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:)   ::   sxa  , sya  , sxxa  , syya  , sxya     ! lead fraction
+   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:)   ::   sxsal, sysal, sxxsal, syysal, sxysal   ! ice salinity
+   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:)   ::   sxage, syage, sxxage, syyage, sxyage   ! ice age
+   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:)     ::   sxopw, syopw, sxxopw, syyopw, sxyopw   ! open water in sea ice
+   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) ::   sxc0 , syc0 , sxxc0 , syyc0 , sxyc0    ! snow layers heat content
+   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) ::   sxe  , sye  , sxxe  , syye  , sxye     ! ice layers heat content
+   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:)   ::   sxap , syap , sxxap , syyap , sxyap    ! melt pond fraction
+   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:)   ::   sxvp , syvp , sxxvp , syyvp , sxyvp    ! melt pond volume
+
+   !! * Substitutions
+#  include "vectopt_loop_substitute.h90"
+   !!----------------------------------------------------------------------
+   !! NEMO/ICE 4.0 , NEMO Consortium (2017)
+   !! $Id: icedyn_adv_pra.F90 6746 2016-06-27 17:20:57Z clem $
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE ice_dyn_adv_pra( kt, pu_ice, pv_ice,  &
+      &                        pato_i, pv_i, pv_s, psv_i, poa_i, pa_i, pa_ip, pv_ip, pe_s, pe_i )
+      !!----------------------------------------------------------------------
+      !!                **  routine ice_dyn_adv_pra  **
+      !!  
+      !! ** purpose :   Computes and adds the advection trend to sea-ice
+      !!
+      !! ** method  :   Uses Prather second order scheme that advects tracers
+      !!                but also their quadratic forms. The method preserves
+      !!                tracer structures by conserving second order moments.
+      !!
+      !! Reference:  Prather, 1986, JGR, 91, D6. 6671-6681.
+      !!----------------------------------------------------------------------
+      INTEGER                     , INTENT(in   ) ::   kt         ! time step
+      REAL(wp), DIMENSION(:,:)    , INTENT(in   ) ::   pu_ice     ! ice i-velocity
+      REAL(wp), DIMENSION(:,:)    , INTENT(in   ) ::   pv_ice     ! ice j-velocity
+      REAL(wp), DIMENSION(:,:)    , INTENT(inout) ::   pato_i     ! open water area
+      REAL(wp), DIMENSION(:,:,:)  , INTENT(inout) ::   pv_i       ! ice volume
+      REAL(wp), DIMENSION(:,:,:)  , INTENT(inout) ::   pv_s       ! snw volume
+      REAL(wp), DIMENSION(:,:,:)  , INTENT(inout) ::   psv_i      ! salt content
+      REAL(wp), DIMENSION(:,:,:)  , INTENT(inout) ::   poa_i      ! age content
+      REAL(wp), DIMENSION(:,:,:)  , INTENT(inout) ::   pa_i       ! ice concentration
+      REAL(wp), DIMENSION(:,:,:)  , INTENT(inout) ::   pa_ip      ! melt pond fraction
+      REAL(wp), DIMENSION(:,:,:)  , INTENT(inout) ::   pv_ip      ! melt pond volume
+      REAL(wp), DIMENSION(:,:,:,:), INTENT(inout) ::   pe_s       ! snw heat content
+      REAL(wp), DIMENSION(:,:,:,:), INTENT(inout) ::   pe_i       ! ice heat content
+      !
+      INTEGER  ::   jk, jl, jt              ! dummy loop indices
+      INTEGER  ::   initad                  ! number of sub-timestep for the advection
+      REAL(wp) ::   zcfl , zusnit           !   -      -
+      REAL(wp), ALLOCATABLE, DIMENSION(:,:)     ::   zarea
+      REAL(wp), ALLOCATABLE, DIMENSION(:,:,:)   ::   z0opw
+      REAL(wp), ALLOCATABLE, DIMENSION(:,:,:)   ::   z0ice, z0snw, z0ai, z0smi, z0oi
+      REAL(wp), ALLOCATABLE, DIMENSION(:,:,:)   ::   z0ap , z0vp
+      REAL(wp), ALLOCATABLE, DIMENSION(:,:,:,:) ::   z0es
+      REAL(wp), ALLOCATABLE, DIMENSION(:,:,:,:) ::   z0ei
+      !!----------------------------------------------------------------------
+      !
+      IF( kt == nit000 .AND. lwp )   WRITE(numout,*) '-- ice_dyn_adv_pra: Prather advection scheme'
+      !
+      ALLOCATE( zarea(jpi,jpj)    , z0opw(jpi,jpj, 1 ) , z0ice(jpi,jpj,jpl) , z0snw(jpi,jpj,jpl) ,                       &
+         &      z0ai(jpi,jpj,jpl) , z0smi(jpi,jpj,jpl) , z0oi (jpi,jpj,jpl) , z0ap (jpi,jpj,jpl) , z0vp(jpi,jpj,jpl) ,   &
+         &      z0es (jpi,jpj,nlay_s,jpl), z0ei(jpi,jpj,nlay_i,jpl) )
+      !
+      ! --- If ice drift field is too fast, use an appropriate time step for advection (CFL test for stability) --- !        
+      zcfl  =            MAXVAL( ABS( pu_ice(:,:) ) * rdt_ice * r1_e1u(:,:) )
+      zcfl  = MAX( zcfl, MAXVAL( ABS( pv_ice(:,:) ) * rdt_ice * r1_e2v(:,:) ) )
+      IF( lk_mpp )   CALL mpp_max( zcfl )
+      
+      IF( zcfl > 0.5 ) THEN   ;   initad = 2   ;   zusnit = 0.5_wp
+      ELSE                    ;   initad = 1   ;   zusnit = 1.0_wp
+      ENDIF
+      
+      zarea(:,:) = e1e2t(:,:)
+      !-------------------------
+      ! transported fields                                        
+      !-------------------------
+      z0opw(:,:,1) = pato_i(:,:) * e1e2t(:,:)              ! Open water area 
+      DO jl = 1, jpl
+         z0snw(:,:,jl) = pv_s (:,:,  jl) * e1e2t(:,:)     ! Snow volume
+         z0ice(:,:,jl) = pv_i (:,:,  jl) * e1e2t(:,:)     ! Ice  volume
+         z0ai (:,:,jl) = pa_i (:,:,  jl) * e1e2t(:,:)     ! Ice area
+         z0smi(:,:,jl) = psv_i(:,:,  jl) * e1e2t(:,:)     ! Salt content
+         z0oi (:,:,jl) = poa_i(:,:,  jl) * e1e2t(:,:)     ! Age content
+         DO jk = 1, nlay_s
+            z0es(:,:,jk,jl) = pe_s(:,:,jk,jl) * e1e2t(:,:) ! Snow heat content
+         END DO
+         DO jk = 1, nlay_i
+            z0ei(:,:,jk,jl) = pe_i(:,:,jk,jl) * e1e2t(:,:) ! Ice  heat content
+         END DO
+         IF ( ln_pnd_H12 ) THEN
+            z0ap(:,:,jl)  = pa_ip(:,:,jl) * e1e2t(:,:)     ! Melt pond fraction
+            z0vp(:,:,jl)  = pv_ip(:,:,jl) * e1e2t(:,:)     ! Melt pond volume
+         ENDIF
+      END DO
+
+      !                                                    !--------------------------------------------!
+      IF( MOD( ( kt - 1) / nn_fsbc , 2 ) == 0 ) THEN       !==  odd ice time step:  adv_x then adv_y  ==!
+         !                                                 !--------------------------------------------!
+         DO jt = 1, initad
+            CALL adv_x( zusnit, pu_ice, 1._wp, zarea, z0opw (:,:,1), sxopw(:,:),   &             !--- ice open water area
+               &                                      sxxopw(:,:)  , syopw(:,:), syyopw(:,:), sxyopw(:,:)  )
+            CALL adv_y( zusnit, pv_ice, 0._wp, zarea, z0opw (:,:,1), sxopw(:,:),   &
+               &                                      sxxopw(:,:)  , syopw(:,:), syyopw(:,:), sxyopw(:,:)  )
+            DO jl = 1, jpl
+               CALL adv_x( zusnit, pu_ice, 1._wp, zarea, z0ice (:,:,jl), sxice(:,:,jl),   &    !--- ice volume  ---
+                  &                                      sxxice(:,:,jl), syice(:,:,jl), syyice(:,:,jl), sxyice(:,:,jl)  )
+               CALL adv_y( zusnit, pv_ice, 0._wp, zarea, z0ice (:,:,jl), sxice(:,:,jl),   &
+                  &                                      sxxice(:,:,jl), syice(:,:,jl), syyice(:,:,jl), sxyice(:,:,jl)  )
+               CALL adv_x( zusnit, pu_ice, 1._wp, zarea, z0snw (:,:,jl), sxsn (:,:,jl),   &    !--- snow volume  ---
+                  &                                      sxxsn (:,:,jl), sysn (:,:,jl), syysn (:,:,jl), sxysn (:,:,jl)  )
+               CALL adv_y( zusnit, pv_ice, 0._wp, zarea, z0snw (:,:,jl), sxsn (:,:,jl),   &
+                  &                                      sxxsn (:,:,jl), sysn (:,:,jl), syysn (:,:,jl), sxysn (:,:,jl)  )
+               CALL adv_x( zusnit, pu_ice, 1._wp, zarea, z0smi (:,:,jl), sxsal(:,:,jl),   &    !--- ice salinity ---
+                  &                                      sxxsal(:,:,jl), sysal(:,:,jl), syysal(:,:,jl), sxysal(:,:,jl)  )
+               CALL adv_y( zusnit, pv_ice, 0._wp, zarea, z0smi (:,:,jl), sxsal(:,:,jl),   &
+                  &                                      sxxsal(:,:,jl), sysal(:,:,jl), syysal(:,:,jl), sxysal(:,:,jl)  )
+               CALL adv_x( zusnit, pu_ice, 1._wp, zarea, z0oi  (:,:,jl), sxage(:,:,jl),   &    !--- ice age      ---     
+                  &                                      sxxage(:,:,jl), syage(:,:,jl), syyage(:,:,jl), sxyage(:,:,jl)  )
+               CALL adv_y( zusnit, pv_ice, 0._wp, zarea, z0oi  (:,:,jl), sxage(:,:,jl),   &
+                  &                                      sxxage(:,:,jl), syage(:,:,jl), syyage(:,:,jl), sxyage(:,:,jl)  )
+               CALL adv_x( zusnit, pu_ice, 1._wp, zarea, z0ai  (:,:,jl), sxa  (:,:,jl),   &    !--- ice concentrations ---
+                  &                                      sxxa  (:,:,jl), sya  (:,:,jl), syya  (:,:,jl), sxya  (:,:,jl)  )
+               CALL adv_y( zusnit, pv_ice, 0._wp, zarea, z0ai  (:,:,jl), sxa  (:,:,jl),   & 
+                  &                                      sxxa  (:,:,jl), sya  (:,:,jl), syya  (:,:,jl), sxya  (:,:,jl)  )
+               DO jk = 1, nlay_s                                                               !--- snow heat contents ---
+                  CALL adv_x( zusnit, pu_ice, 1._wp, zarea, z0es (:,:,jk,jl), sxc0(:,:,jk,jl),   &
+                     &                                      sxxc0(:,:,jk,jl), syc0(:,:,jk,jl), syyc0(:,:,jk,jl), sxyc0(:,:,jk,jl) )
+                  CALL adv_y( zusnit, pv_ice, 0._wp, zarea, z0es (:,:,jk,jl), sxc0(:,:,jk,jl),   &
+                     &                                      sxxc0(:,:,jk,jl), syc0(:,:,jk,jl), syyc0(:,:,jk,jl), sxyc0(:,:,jk,jl) )
+               END DO
+               DO jk = 1, nlay_i                                                               !--- ice heat contents ---
+                  CALL adv_x( zusnit, pu_ice, 1._wp, zarea, z0ei(:,:,jk,jl), sxe(:,:,jk,jl),   & 
+                     &                                      sxxe(:,:,jk,jl), sye(:,:,jk,jl), syye(:,:,jk,jl), sxye(:,:,jk,jl) )
+                  CALL adv_y( zusnit, pv_ice, 0._wp, zarea, z0ei(:,:,jk,jl), sxe(:,:,jk,jl),   & 
+                     &                                      sxxe(:,:,jk,jl), sye(:,:,jk,jl), syye(:,:,jk,jl), sxye(:,:,jk,jl) )
+               END DO
+               IF ( ln_pnd_H12 ) THEN
+                  CALL adv_x( zusnit, pu_ice, 1._wp, zarea, z0ap  (:,:,jl), sxap (:,:,jl),   &    !--- melt pond fraction --
+                     &                                      sxxap (:,:,jl), syap (:,:,jl), syyap (:,:,jl), sxyap (:,:,jl)  )
+                  CALL adv_y( zusnit, pv_ice, 0._wp, zarea, z0ap  (:,:,jl), sxap (:,:,jl),   & 
+                     &                                      sxxap (:,:,jl), syap (:,:,jl), syyap (:,:,jl), sxyap (:,:,jl)  )
+                  CALL adv_x( zusnit, pu_ice, 1._wp, zarea, z0vp  (:,:,jl), sxvp (:,:,jl),   &    !--- melt pond volume   --
+                     &                                      sxxvp (:,:,jl), syvp (:,:,jl), syyvp (:,:,jl), sxyvp (:,:,jl)  )
+                  CALL adv_y( zusnit, pv_ice, 0._wp, zarea, z0vp  (:,:,jl), sxvp (:,:,jl),   & 
+                     &                                      sxxvp (:,:,jl), syvp (:,:,jl), syyvp (:,:,jl), sxyvp (:,:,jl)  )
+               ENDIF
+            END DO
+         END DO
+      !                                                    !--------------------------------------------!
+      ELSE                                                 !== even ice time step:  adv_y then adv_x  ==!
+         !                                                 !--------------------------------------------!
+         DO jt = 1, initad
+            CALL adv_y( zusnit, pv_ice, 1._wp, zarea, z0opw (:,:,1), sxopw(:,:),   &             !--- ice open water area
+               &                                      sxxopw(:,:)  , syopw(:,:), syyopw(:,:), sxyopw(:,:)  )
+            CALL adv_x( zusnit, pu_ice, 0._wp, zarea, z0opw (:,:,1), sxopw(:,:),   &
+               &                                      sxxopw(:,:)  , syopw(:,:), syyopw(:,:), sxyopw(:,:)  )
+            DO jl = 1, jpl
+               CALL adv_y( zusnit, pv_ice, 1._wp, zarea, z0ice (:,:,jl), sxice(:,:,jl),   &    !--- ice volume  ---
+                  &                                      sxxice(:,:,jl), syice(:,:,jl), syyice(:,:,jl), sxyice(:,:,jl)  )
+               CALL adv_x( zusnit, pu_ice, 0._wp, zarea, z0ice (:,:,jl), sxice(:,:,jl),   &
+                  &                                      sxxice(:,:,jl), syice(:,:,jl), syyice(:,:,jl), sxyice(:,:,jl)  )
+               CALL adv_y( zusnit, pv_ice, 1._wp, zarea, z0snw (:,:,jl), sxsn (:,:,jl),   &    !--- snow volume  ---
+                  &                                      sxxsn (:,:,jl), sysn (:,:,jl), syysn (:,:,jl), sxysn (:,:,jl)  )
+               CALL adv_x( zusnit, pu_ice, 0._wp, zarea, z0snw (:,:,jl), sxsn (:,:,jl),   &
+                  &                                      sxxsn (:,:,jl), sysn (:,:,jl), syysn (:,:,jl), sxysn (:,:,jl)  )
+               CALL adv_y( zusnit, pv_ice, 1._wp, zarea, z0smi (:,:,jl), sxsal(:,:,jl),   &    !--- ice salinity ---
+                  &                                      sxxsal(:,:,jl), sysal(:,:,jl), syysal(:,:,jl), sxysal(:,:,jl)  )
+               CALL adv_x( zusnit, pu_ice, 0._wp, zarea, z0smi (:,:,jl), sxsal(:,:,jl),   &
+                  &                                      sxxsal(:,:,jl), sysal(:,:,jl), syysal(:,:,jl), sxysal(:,:,jl)  )
+               CALL adv_y( zusnit, pv_ice, 1._wp, zarea, z0oi  (:,:,jl), sxage(:,:,jl),   &   !--- ice age      ---
+                  &                                      sxxage(:,:,jl), syage(:,:,jl), syyage(:,:,jl), sxyage(:,:,jl)  )
+               CALL adv_x( zusnit, pu_ice, 0._wp, zarea, z0oi  (:,:,jl), sxage(:,:,jl),   &
+                  &                                      sxxage(:,:,jl), syage(:,:,jl), syyage(:,:,jl), sxyage(:,:,jl)  )
+               CALL adv_y( zusnit, pv_ice, 1._wp, zarea, z0ai  (:,:,jl), sxa  (:,:,jl),   &   !--- ice concentrations ---
+                  &                                      sxxa  (:,:,jl), sya  (:,:,jl), syya  (:,:,jl), sxya  (:,:,jl)  )
+               CALL adv_x( zusnit, pu_ice, 0._wp, zarea, z0ai  (:,:,jl), sxa  (:,:,jl),   &
+                  &                                      sxxa  (:,:,jl), sya  (:,:,jl), syya  (:,:,jl), sxya  (:,:,jl)  )
+               DO jk = 1, nlay_s                                                             !--- snow heat contents ---
+                  CALL adv_y( zusnit, pv_ice, 1._wp, zarea, z0es (:,:,jk,jl), sxc0(:,:,jk,jl),   &
+                     &                                      sxxc0(:,:,jk,jl), syc0(:,:,jk,jl), syyc0(:,:,jk,jl), sxyc0(:,:,jk,jl) )
+                  CALL adv_x( zusnit, pu_ice, 0._wp, zarea, z0es (:,:,jk,jl), sxc0(:,:,jk,jl),   &
+                     &                                      sxxc0(:,:,jk,jl), syc0(:,:,jk,jl), syyc0(:,:,jk,jl), sxyc0(:,:,jk,jl) )
+               END DO
+               DO jk = 1, nlay_i                                                             !--- ice heat contents ---
+                  CALL adv_y( zusnit, pv_ice, 1._wp, zarea, z0ei(:,:,jk,jl), sxe(:,:,jk,jl),   & 
+                     &                                      sxxe(:,:,jk,jl), sye(:,:,jk,jl), syye(:,:,jk,jl), sxye(:,:,jk,jl) )
+                  CALL adv_x( zusnit, pu_ice, 0._wp, zarea, z0ei(:,:,jk,jl), sxe(:,:,jk,jl),   & 
+                     &                                      sxxe(:,:,jk,jl), sye(:,:,jk,jl), syye(:,:,jk,jl), sxye(:,:,jk,jl) )
+               END DO
+               IF ( ln_pnd_H12 ) THEN
+                  CALL adv_y( zusnit, pv_ice, 1._wp, zarea, z0ap  (:,:,jl), sxap (:,:,jl),   &   !--- melt pond fraction ---
+                     &                                      sxxap (:,:,jl), syap (:,:,jl), syyap (:,:,jl), sxyap (:,:,jl)  )
+                  CALL adv_x( zusnit, pu_ice, 0._wp, zarea, z0ap  (:,:,jl), sxap (:,:,jl),   &
+                     &                                      sxxap (:,:,jl), syap (:,:,jl), syyap (:,:,jl), sxyap (:,:,jl)  )
+                  CALL adv_y( zusnit, pv_ice, 1._wp, zarea, z0vp  (:,:,jl), sxvp (:,:,jl),   &   !--- melt pond volume   ---
+                     &                                      sxxvp (:,:,jl), syvp (:,:,jl), syyvp (:,:,jl), sxyvp (:,:,jl)  )
+                  CALL adv_x( zusnit, pu_ice, 0._wp, zarea, z0vp  (:,:,jl), sxvp (:,:,jl),   &
+                     &                                      sxxvp (:,:,jl), syvp (:,:,jl), syyvp (:,:,jl), sxyvp (:,:,jl)  )
+               ENDIF
+            END DO
+         END DO
+      ENDIF
+
+      !-------------------------------------------
+      ! Recover the properties from their contents
+      !-------------------------------------------
+      pato_i(:,:) = z0opw(:,:,1) * r1_e1e2t(:,:)
+      DO jl = 1, jpl
+         pv_i (:,:,  jl) = z0ice(:,:,jl) * r1_e1e2t(:,:)
+         pv_s (:,:,  jl) = z0snw(:,:,jl) * r1_e1e2t(:,:)
+         psv_i(:,:,  jl) = z0smi(:,:,jl) * r1_e1e2t(:,:)
+         poa_i(:,:,  jl) = z0oi (:,:,jl) * r1_e1e2t(:,:)
+         pa_i (:,:,  jl) = z0ai (:,:,jl) * r1_e1e2t(:,:)
+         DO jk = 1, nlay_s
+            pe_s(:,:,jk,jl) = z0es(:,:,jk,jl) * r1_e1e2t(:,:)
+         END DO
+         DO jk = 1, nlay_i
+            pe_i(:,:,jk,jl) = z0ei(:,:,jk,jl) * r1_e1e2t(:,:)
+         END DO
+         IF ( ln_pnd_H12 ) THEN
+            pa_ip  (:,:,jl) = z0ap (:,:,jl) * r1_e1e2t(:,:)
+            pv_ip  (:,:,jl) = z0vp (:,:,jl) * r1_e1e2t(:,:)
+         ENDIF
+      END DO
+      !
+      DEALLOCATE( zarea , z0opw , z0ice, z0snw , z0ai , z0smi , z0oi , z0ap , z0vp , z0es, z0ei )
+      !
+      IF( lrst_ice )   CALL adv_pra_rst( 'WRITE', kt )   !* write Prather fields in the restart file
+      !
+   END SUBROUTINE ice_dyn_adv_pra
+   
+   
+   SUBROUTINE adv_x( pdf, put , pcrh, psm , ps0 ,   &
+      &              psx, psxx, psy , psyy, psxy )
+      !!----------------------------------------------------------------------
+      !!                **  routine adv_x  **
+      !!  
+      !! ** purpose :   Computes and adds the advection trend to sea-ice
+      !!                variable on x axis
+      !!----------------------------------------------------------------------
+      REAL(wp)                    , INTENT(in   ) ::   pdf                ! reduction factor for the time step
+      REAL(wp)                    , INTENT(in   ) ::   pcrh               ! call adv_x then adv_y (=1) or the opposite (=0)
+      REAL(wp), DIMENSION(jpi,jpj), INTENT(in   ) ::   put                ! i-direction ice velocity at U-point [m/s]
+      REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) ::   psm                ! area
+      REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) ::   ps0                ! field to be advected
+      REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) ::   psx , psy          ! 1st moments 
+      REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) ::   psxx, psyy, psxy   ! 2nd moments
+      !! 
+      INTEGER  ::   ji, jj                               ! dummy loop indices
+      REAL(wp) ::   zs1max, zrdt, zslpmax, ztemp         ! local scalars
+      REAL(wp) ::   zs1new, zalf , zalfq , zbt           !   -      -
+      REAL(wp) ::   zs2new, zalf1, zalf1q, zbt1          !   -      -
+      REAL(wp), DIMENSION(jpi,jpj) ::   zf0 , zfx  , zfy   , zbet   ! 2D workspace
+      REAL(wp), DIMENSION(jpi,jpj) ::   zfm , zfxx , zfyy  , zfxy   !  -      -
+      REAL(wp), DIMENSION(jpi,jpj) ::   zalg, zalg1, zalg1q         !  -      -
+      !-----------------------------------------------------------------------
+
+      ! Limitation of moments.                                           
+
+      zrdt = rdt_ice * pdf      ! If ice drift field is too fast, use an appropriate time step for advection.
+
+      DO jj = 1, jpj
+         DO ji = 1, jpi
+            zslpmax = MAX( 0._wp, ps0(ji,jj) )
+            zs1max  = 1.5 * zslpmax
+            zs1new  = MIN( zs1max, MAX( -zs1max, psx(ji,jj) ) )
+            zs2new  = MIN(  2.0 * zslpmax - 0.3334 * ABS( zs1new ),      &
+               &            MAX( ABS( zs1new ) - zslpmax, psxx(ji,jj) )  )
+            rswitch = ( 1.0 - MAX( 0._wp, SIGN( 1._wp, -zslpmax) ) ) * tmask(ji,jj,1)   ! Case of empty boxes & Apply mask
+
+            ps0 (ji,jj) = zslpmax  
+            psx (ji,jj) = zs1new      * rswitch
+            psxx(ji,jj) = zs2new      * rswitch
+            psy (ji,jj) = psy (ji,jj) * rswitch
+            psyy(ji,jj) = psyy(ji,jj) * rswitch
+            psxy(ji,jj) = MIN( zslpmax, MAX( -zslpmax, psxy(ji,jj) ) ) * rswitch
+         END DO
+      END DO
+
+      !  Initialize volumes of boxes  (=area if adv_x first called, =psm otherwise)                                     
+      psm (:,:)  = MAX( pcrh * e1e2t(:,:) + ( 1.0 - pcrh ) * psm(:,:) , epsi20 )
+
+      !  Calculate fluxes and moments between boxes i<-->i+1              
+      DO jj = 1, jpj                      !  Flux from i to i+1 WHEN u GT 0 
+         DO ji = 1, jpi
+            zbet(ji,jj)  =  MAX( 0._wp, SIGN( 1._wp, put(ji,jj) ) )
+            zalf         =  MAX( 0._wp, put(ji,jj) ) * zrdt * e2u(ji,jj) / psm(ji,jj)
+            zalfq        =  zalf * zalf
+            zalf1        =  1.0 - zalf
+            zalf1q       =  zalf1 * zalf1
+            !
+            zfm (ji,jj)  =  zalf  *   psm (ji,jj)
+            zf0 (ji,jj)  =  zalf  * ( ps0 (ji,jj) + zalf1 * ( psx(ji,jj) + (zalf1 - zalf) * psxx(ji,jj) )  )
+            zfx (ji,jj)  =  zalfq * ( psx (ji,jj) + 3.0 * zalf1 * psxx(ji,jj) )
+            zfxx(ji,jj)  =  zalf  *   psxx(ji,jj) * zalfq
+            zfy (ji,jj)  =  zalf  * ( psy (ji,jj) + zalf1 * psxy(ji,jj) )
+            zfxy(ji,jj)  =  zalfq *   psxy(ji,jj)
+            zfyy(ji,jj)  =  zalf  *   psyy(ji,jj)
+
+            !  Readjust moments remaining in the box.
+            psm (ji,jj)  =  psm (ji,jj) - zfm(ji,jj)
+            ps0 (ji,jj)  =  ps0 (ji,jj) - zf0(ji,jj)
+            psx (ji,jj)  =  zalf1q * ( psx(ji,jj) - 3.0 * zalf * psxx(ji,jj) )
+            psxx(ji,jj)  =  zalf1  * zalf1q * psxx(ji,jj)
+            psy (ji,jj)  =  psy (ji,jj) - zfy(ji,jj)
+            psyy(ji,jj)  =  psyy(ji,jj) - zfyy(ji,jj)
+            psxy(ji,jj)  =  zalf1q * psxy(ji,jj)
+         END DO
+      END DO
+
+      DO jj = 1, jpjm1                      !  Flux from i+1 to i when u LT 0.
+         DO ji = 1, fs_jpim1
+            zalf          = MAX( 0._wp, -put(ji,jj) ) * zrdt * e2u(ji,jj) / psm(ji+1,jj) 
+            zalg  (ji,jj) = zalf
+            zalfq         = zalf * zalf
+            zalf1         = 1.0 - zalf
+            zalg1 (ji,jj) = zalf1
+            zalf1q        = zalf1 * zalf1
+            zalg1q(ji,jj) = zalf1q
+            !
+            zfm   (ji,jj) = zfm (ji,jj) + zalf  *   psm (ji+1,jj)
+            zf0   (ji,jj) = zf0 (ji,jj) + zalf  * ( ps0 (ji+1,jj) - zalf1 * ( psx(ji+1,jj) - (zalf1 - zalf ) * psxx(ji+1,jj) ) )
+            zfx   (ji,jj) = zfx (ji,jj) + zalfq * ( psx (ji+1,jj) - 3.0 * zalf1 * psxx(ji+1,jj) )
+            zfxx  (ji,jj) = zfxx(ji,jj) + zalf  *   psxx(ji+1,jj) * zalfq
+            zfy   (ji,jj) = zfy (ji,jj) + zalf  * ( psy (ji+1,jj) - zalf1 * psxy(ji+1,jj) )
+            zfxy  (ji,jj) = zfxy(ji,jj) + zalfq *   psxy(ji+1,jj)
+            zfyy  (ji,jj) = zfyy(ji,jj) + zalf  *   psyy(ji+1,jj)
+         END DO
+      END DO
+
+      DO jj = 2, jpjm1                     !  Readjust moments remaining in the box. 
+         DO ji = fs_2, fs_jpim1
+            zbt  =       zbet(ji-1,jj)
+            zbt1 = 1.0 - zbet(ji-1,jj)
+            !
+            psm (ji,jj) = zbt * psm(ji,jj) + zbt1 * ( psm(ji,jj) - zfm(ji-1,jj) )
+            ps0 (ji,jj) = zbt * ps0(ji,jj) + zbt1 * ( ps0(ji,jj) - zf0(ji-1,jj) )
+            psx (ji,jj) = zalg1q(ji-1,jj) * ( psx(ji,jj) + 3.0 * zalg(ji-1,jj) * psxx(ji,jj) )
+            psxx(ji,jj) = zalg1 (ji-1,jj) * zalg1q(ji-1,jj) * psxx(ji,jj)
+            psy (ji,jj) = zbt * psy (ji,jj) + zbt1 * ( psy (ji,jj) - zfy (ji-1,jj) )
+            psyy(ji,jj) = zbt * psyy(ji,jj) + zbt1 * ( psyy(ji,jj) - zfyy(ji-1,jj) )
+            psxy(ji,jj) = zalg1q(ji-1,jj) * psxy(ji,jj)
+         END DO
+      END DO
+
+      !   Put the temporary moments into appropriate neighboring boxes.    
+      DO jj = 2, jpjm1                     !   Flux from i to i+1 IF u GT 0.
+         DO ji = fs_2, fs_jpim1
+            zbt  =       zbet(ji-1,jj)
+            zbt1 = 1.0 - zbet(ji-1,jj)
+            psm(ji,jj)  = zbt * ( psm(ji,jj) + zfm(ji-1,jj) ) + zbt1 * psm(ji,jj)
+            zalf        = zbt * zfm(ji-1,jj) / psm(ji,jj)
+            zalf1       = 1.0 - zalf
+            ztemp       = zalf * ps0(ji,jj) - zalf1 * zf0(ji-1,jj)
+            !
+            ps0 (ji,jj) = zbt * ( ps0(ji,jj) + zf0(ji-1,jj) ) + zbt1 * ps0(ji,jj)
+            psx (ji,jj) = zbt * ( zalf * zfx(ji-1,jj) + zalf1 * psx(ji,jj) + 3.0 * ztemp ) + zbt1 * psx(ji,jj)
+            psxx(ji,jj) = zbt * ( zalf * zalf * zfxx(ji-1,jj) + zalf1 * zalf1 * psxx(ji,jj)                               &
+               &                + 5.0 * ( zalf * zalf1 * ( psx (ji,jj) - zfx(ji-1,jj) ) - ( zalf1 - zalf ) * ztemp )  )   &
+               &                                                + zbt1 * psxx(ji,jj)
+            psxy(ji,jj) = zbt * ( zalf * zfxy(ji-1,jj) + zalf1 * psxy(ji,jj)             &
+               &                + 3.0 * (- zalf1*zfy(ji-1,jj)  + zalf * psy(ji,jj) ) )   &
+               &                                                + zbt1 * psxy(ji,jj)
+            psy (ji,jj) = zbt * ( psy (ji,jj) + zfy (ji-1,jj) ) + zbt1 * psy (ji,jj)
+            psyy(ji,jj) = zbt * ( psyy(ji,jj) + zfyy(ji-1,jj) ) + zbt1 * psyy(ji,jj)
+         END DO
+      END DO
+
+      DO jj = 2, jpjm1                     !  Flux from i+1 to i IF u LT 0.
+         DO ji = fs_2, fs_jpim1
+            zbt  =       zbet(ji,jj)
+            zbt1 = 1.0 - zbet(ji,jj)
+            psm(ji,jj)  = zbt * psm(ji,jj)  + zbt1 * ( psm(ji,jj) + zfm(ji,jj) )
+            zalf        = zbt1 * zfm(ji,jj) / psm(ji,jj)
+            zalf1       = 1.0 - zalf
+            ztemp       = - zalf * ps0(ji,jj) + zalf1 * zf0(ji,jj)
+            !
+            ps0(ji,jj)  = zbt * ps0 (ji,jj) + zbt1 * ( ps0(ji,jj) + zf0(ji,jj) )
+            psx(ji,jj)  = zbt * psx (ji,jj) + zbt1 * ( zalf * zfx(ji,jj) + zalf1 * psx(ji,jj) + 3.0 * ztemp )
+            psxx(ji,jj) = zbt * psxx(ji,jj) + zbt1 * ( zalf * zalf * zfxx(ji,jj)  + zalf1 * zalf1 * psxx(ji,jj)  &
+               &                                      + 5.0 *( zalf * zalf1 * ( - psx(ji,jj) + zfx(ji,jj) )      &
+               &                                      + ( zalf1 - zalf ) * ztemp ) )
+            psxy(ji,jj) = zbt * psxy(ji,jj) + zbt1 * (  zalf * zfxy(ji,jj) + zalf1 * psxy(ji,jj)  &
+               &                                      + 3.0 * ( zalf1 * zfy(ji,jj) - zalf * psy(ji,jj) )  )
+            psy(ji,jj)  = zbt * psy (ji,jj)  + zbt1 * ( psy (ji,jj) + zfy (ji,jj) )
+            psyy(ji,jj) = zbt * psyy(ji,jj)  + zbt1 * ( psyy(ji,jj) + zfyy(ji,jj) )
+         END DO
+      END DO
+
+      !-- Lateral boundary conditions
+      CALL lbc_lnk_multi( psm , 'T',  1., ps0 , 'T',  1.   &
+         &              , psx , 'T', -1., psy , 'T', -1.   &   ! caution gradient ==> the sign changes
+         &              , psxx, 'T',  1., psyy, 'T',  1.   &
+         &              , psxy, 'T',  1. )
+
+      IF(ln_ctl) THEN
+         CALL prt_ctl(tab2d_1=psm  , clinfo1=' adv_x: psm  :', tab2d_2=ps0 , clinfo2=' ps0  : ')
+         CALL prt_ctl(tab2d_1=psx  , clinfo1=' adv_x: psx  :', tab2d_2=psxx, clinfo2=' psxx : ')
+         CALL prt_ctl(tab2d_1=psy  , clinfo1=' adv_x: psy  :', tab2d_2=psyy, clinfo2=' psyy : ')
+         CALL prt_ctl(tab2d_1=psxy , clinfo1=' adv_x: psxy :')
+      ENDIF
+      !
+   END SUBROUTINE adv_x
+
+
+   SUBROUTINE adv_y( pdf, pvt , pcrh, psm , ps0 ,   &
+      &              psx, psxx, psy , psyy, psxy )
+      !!---------------------------------------------------------------------
+      !!                **  routine adv_y  **
+      !!            
+      !! ** purpose :   Computes and adds the advection trend to sea-ice 
+      !!                variable on y axis
+      !!---------------------------------------------------------------------
+      REAL(wp)                    , INTENT(in   ) ::   pdf                ! reduction factor for the time step
+      REAL(wp)                    , INTENT(in   ) ::   pcrh               ! call adv_x then adv_y (=1) or the opposite (=0)
+      REAL(wp), DIMENSION(jpi,jpj), INTENT(in   ) ::   pvt                ! j-direction ice velocity at V-point [m/s]
+      REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) ::   psm                ! area
+      REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) ::   ps0                ! field to be advected
+      REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) ::   psx , psy          ! 1st moments 
+      REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) ::   psxx, psyy, psxy   ! 2nd moments
+      !!
+      INTEGER  ::   ji, jj                               ! dummy loop indices
+      REAL(wp) ::   zs1max, zrdt, zslpmax, ztemp         ! temporary scalars
+      REAL(wp) ::   zs1new, zalf , zalfq , zbt           !    -         -
+      REAL(wp) ::   zs2new, zalf1, zalf1q, zbt1          !    -         -
+      REAL(wp), DIMENSION(jpi,jpj) ::   zf0, zfx , zfy , zbet   ! 2D workspace
+      REAL(wp), DIMENSION(jpi,jpj) ::   zfm, zfxx, zfyy, zfxy   !  -      -
+      REAL(wp), DIMENSION(jpi,jpj) ::   zalg, zalg1, zalg1q     !  -      -
+      !---------------------------------------------------------------------
+
+      ! Limitation of moments.
+
+      zrdt = rdt_ice * pdf ! If ice drift field is too fast, use an appropriate time step for advection.
+
+      DO jj = 1, jpj
+         DO ji = 1, jpi
+            zslpmax = MAX( 0._wp, ps0(ji,jj) )
+            zs1max  = 1.5 * zslpmax
+            zs1new  = MIN( zs1max, MAX( -zs1max, psy(ji,jj) ) )
+            zs2new  = MIN(  ( 2.0 * zslpmax - 0.3334 * ABS( zs1new ) ),   &
+               &             MAX( ABS( zs1new )-zslpmax, psyy(ji,jj) )  )
+            rswitch = ( 1.0 - MAX( 0._wp, SIGN( 1._wp, -zslpmax) ) ) * tmask(ji,jj,1)   ! Case of empty boxes & Apply mask
+            !
+            ps0 (ji,jj) = zslpmax  
+            psx (ji,jj) = psx (ji,jj) * rswitch
+            psxx(ji,jj) = psxx(ji,jj) * rswitch
+            psy (ji,jj) = zs1new * rswitch
+            psyy(ji,jj) = zs2new * rswitch
+            psxy(ji,jj) = MIN( zslpmax, MAX( -zslpmax, psxy(ji,jj) ) ) * rswitch
+         END DO
+      END DO
+
+      !  Initialize volumes of boxes (=area if adv_x first called, =psm otherwise)
+      psm(:,:)  = MAX(  pcrh * e1e2t(:,:) + ( 1.0 - pcrh ) * psm(:,:) , epsi20  )
+
+      !  Calculate fluxes and moments between boxes j<-->j+1              
+      DO jj = 1, jpj                     !  Flux from j to j+1 WHEN v GT 0   
+         DO ji = 1, jpi
+            zbet(ji,jj)  =  MAX( 0._wp, SIGN( 1._wp, pvt(ji,jj) ) )
+            zalf         =  MAX( 0._wp, pvt(ji,jj) ) * zrdt * e1v(ji,jj) / psm(ji,jj)
+            zalfq        =  zalf * zalf
+            zalf1        =  1.0 - zalf
+            zalf1q       =  zalf1 * zalf1
+            !
+            zfm (ji,jj)  =  zalf  * psm(ji,jj)
+            zf0 (ji,jj)  =  zalf  * ( ps0(ji,jj) + zalf1 * ( psy(ji,jj)  + (zalf1-zalf) * psyy(ji,jj)  ) ) 
+            zfy (ji,jj)  =  zalfq *( psy(ji,jj) + 3.0*zalf1*psyy(ji,jj) )
+            zfyy(ji,jj)  =  zalf  * zalfq * psyy(ji,jj)
+            zfx (ji,jj)  =  zalf  * ( psx(ji,jj) + zalf1 * psxy(ji,jj) )
+            zfxy(ji,jj)  =  zalfq * psxy(ji,jj)
+            zfxx(ji,jj)  =  zalf  * psxx(ji,jj)
+            !
+            !  Readjust moments remaining in the box.
+            psm (ji,jj)  =  psm (ji,jj) - zfm(ji,jj)
+            ps0 (ji,jj)  =  ps0 (ji,jj) - zf0(ji,jj)
+            psy (ji,jj)  =  zalf1q * ( psy(ji,jj) -3.0 * zalf * psyy(ji,jj) )
+            psyy(ji,jj)  =  zalf1 * zalf1q * psyy(ji,jj)
+            psx (ji,jj)  =  psx (ji,jj) - zfx(ji,jj)
+            psxx(ji,jj)  =  psxx(ji,jj) - zfxx(ji,jj)
+            psxy(ji,jj)  =  zalf1q * psxy(ji,jj)
+         END DO
+      END DO
+      !
+      DO jj = 1, jpjm1                   !  Flux from j+1 to j when v LT 0.
+         DO ji = 1, jpi
+            zalf          = ( MAX(0._wp, -pvt(ji,jj) ) * zrdt * e1v(ji,jj) ) / psm(ji,jj+1) 
+            zalg  (ji,jj) = zalf
+            zalfq         = zalf * zalf
+            zalf1         = 1.0 - zalf
+            zalg1 (ji,jj) = zalf1
+            zalf1q        = zalf1 * zalf1
+            zalg1q(ji,jj) = zalf1q
+            !
+            zfm   (ji,jj) = zfm (ji,jj) + zalf  *   psm (ji,jj+1)
+            zf0   (ji,jj) = zf0 (ji,jj) + zalf  * ( ps0 (ji,jj+1) - zalf1 * (psy(ji,jj+1) - (zalf1 - zalf ) * psyy(ji,jj+1) ) )
+            zfy   (ji,jj) = zfy (ji,jj) + zalfq * ( psy (ji,jj+1) - 3.0 * zalf1 * psyy(ji,jj+1) )
+            zfyy  (ji,jj) = zfyy(ji,jj) + zalf  *   psyy(ji,jj+1) * zalfq
+            zfx   (ji,jj) = zfx (ji,jj) + zalf  * ( psx (ji,jj+1) - zalf1 * psxy(ji,jj+1) )
+            zfxy  (ji,jj) = zfxy(ji,jj) + zalfq *   psxy(ji,jj+1)
+            zfxx  (ji,jj) = zfxx(ji,jj) + zalf  *   psxx(ji,jj+1)
+         END DO
+      END DO
+
+      !  Readjust moments remaining in the box. 
+      DO jj = 2, jpj
+         DO ji = 1, jpi
+            zbt  =         zbet(ji,jj-1)
+            zbt1 = ( 1.0 - zbet(ji,jj-1) )
+            !
+            psm (ji,jj) = zbt * psm(ji,jj) + zbt1 * ( psm(ji,jj) - zfm(ji,jj-1) )
+            ps0 (ji,jj) = zbt * ps0(ji,jj) + zbt1 * ( ps0(ji,jj) - zf0(ji,jj-1) )
+            psy (ji,jj) = zalg1q(ji,jj-1) * ( psy(ji,jj) + 3.0 * zalg(ji,jj-1) * psyy(ji,jj) )
+            psyy(ji,jj) = zalg1 (ji,jj-1) * zalg1q(ji,jj-1) * psyy(ji,jj)
+            psx (ji,jj) = zbt * psx (ji,jj) + zbt1 * ( psx (ji,jj) - zfx (ji,jj-1) )
+            psxx(ji,jj) = zbt * psxx(ji,jj) + zbt1 * ( psxx(ji,jj) - zfxx(ji,jj-1) )
+            psxy(ji,jj) = zalg1q(ji,jj-1) * psxy(ji,jj)
+         END DO
+      END DO
+
+      !   Put the temporary moments into appropriate neighboring boxes.    
+      DO jj = 2, jpjm1                    !   Flux from j to j+1 IF v GT 0.
+         DO ji = 1, jpi
+            zbt  =         zbet(ji,jj-1)
+            zbt1 = ( 1.0 - zbet(ji,jj-1) )
+            psm(ji,jj)  = zbt * ( psm(ji,jj) + zfm(ji,jj-1) ) + zbt1 * psm(ji,jj) 
+            zalf        = zbt * zfm(ji,jj-1) / psm(ji,jj) 
+            zalf1       = 1.0 - zalf
+            ztemp       = zalf * ps0(ji,jj) - zalf1 * zf0(ji,jj-1)
+            !
+            ps0(ji,jj)  = zbt  * ( ps0(ji,jj) + zf0(ji,jj-1) ) + zbt1 * ps0(ji,jj)
+            psy(ji,jj)  = zbt  * ( zalf * zfy(ji,jj-1) + zalf1 * psy(ji,jj) + 3.0 * ztemp )   &
+               &                                               + zbt1 * psy(ji,jj)  
+            psyy(ji,jj) = zbt  * ( zalf * zalf * zfyy(ji,jj-1) + zalf1 * zalf1 * psyy(ji,jj)                             &
+               &                 + 5.0 * ( zalf * zalf1 * ( psy(ji,jj) - zfy(ji,jj-1) ) - ( zalf1 - zalf ) * ztemp ) )   & 
+               &                                               + zbt1 * psyy(ji,jj)
+            psxy(ji,jj) = zbt  * (  zalf * zfxy(ji,jj-1) + zalf1 * psxy(ji,jj)               &
+               &                  + 3.0 * (- zalf1 * zfx(ji,jj-1) + zalf * psx(ji,jj) )  )   &
+               &                                                + zbt1 * psxy(ji,jj)
+            psx (ji,jj) = zbt * ( psx (ji,jj) + zfx (ji,jj-1) ) + zbt1 * psx (ji,jj)
+            psxx(ji,jj) = zbt * ( psxx(ji,jj) + zfxx(ji,jj-1) ) + zbt1 * psxx(ji,jj)
+         END DO
+      END DO
+
+      DO jj = 2, jpjm1                   !  Flux from j+1 to j IF v LT 0.
+         DO ji = 1, jpi
+            zbt  =         zbet(ji,jj)
+            zbt1 = ( 1.0 - zbet(ji,jj) )
+            psm(ji,jj)  = zbt * psm(ji,jj) + zbt1 * ( psm(ji,jj) + zfm(ji,jj) )
+            zalf        = zbt1 * zfm(ji,jj) / psm(ji,jj)
+            zalf1       = 1.0 - zalf
+            ztemp       = - zalf * ps0 (ji,jj) + zalf1 * zf0(ji,jj)
+            ps0 (ji,jj) =   zbt  * ps0 (ji,jj) + zbt1  * ( ps0(ji,jj) + zf0(ji,jj) )
+            psy (ji,jj) =   zbt  * psy (ji,jj) + zbt1  * ( zalf * zfy(ji,jj) + zalf1 * psy(ji,jj) + 3.0 * ztemp )
+            psyy(ji,jj) =   zbt  * psyy(ji,jj) + zbt1 * (  zalf * zalf * zfyy(ji,jj) + zalf1 * zalf1 * psyy(ji,jj)   &
+               &                                         + 5.0 *( zalf *zalf1 *( -psy(ji,jj) + zfy(ji,jj) )          &
+               &                                         + ( zalf1 - zalf ) * ztemp )                                )
+            psxy(ji,jj) =   zbt  * psxy(ji,jj) + zbt1 * (  zalf * zfxy(ji,jj) + zalf1 * psxy(ji,jj)       &
+               &                                         + 3.0 * ( zalf1 * zfx(ji,jj) - zalf * psx(ji,jj) )  )
+            psx (ji,jj) =   zbt  * psx (ji,jj) + zbt1 * ( psx (ji,jj) + zfx (ji,jj) )
+            psxx(ji,jj) =   zbt  * psxx(ji,jj) + zbt1 * ( psxx(ji,jj) + zfxx(ji,jj) )
+         END DO
+      END DO
+
+      !-- Lateral boundary conditions
+      CALL lbc_lnk_multi( psm , 'T',  1.,  ps0 , 'T',  1.   &
+         &              , psx , 'T', -1.,  psy , 'T', -1.   &   ! caution gradient ==> the sign changes
+         &              , psxx, 'T',  1.,  psyy, 'T',  1.   &
+         &              , psxy, 'T',  1. )
+
+      IF(ln_ctl) THEN
+         CALL prt_ctl(tab2d_1=psm  , clinfo1=' adv_y: psm  :', tab2d_2=ps0 , clinfo2=' ps0  : ')
+         CALL prt_ctl(tab2d_1=psx  , clinfo1=' adv_y: psx  :', tab2d_2=psxx, clinfo2=' psxx : ')
+         CALL prt_ctl(tab2d_1=psy  , clinfo1=' adv_y: psy  :', tab2d_2=psyy, clinfo2=' psyy : ')
+         CALL prt_ctl(tab2d_1=psxy , clinfo1=' adv_y: psxy :')
+      ENDIF
+      !
+   END SUBROUTINE adv_y
+
+
+   SUBROUTINE adv_pra_init
+      !!-------------------------------------------------------------------
+      !!                  ***  ROUTINE adv_pra_init  ***
+      !!
+      !! ** Purpose :   allocate and initialize arrays for Prather advection 
+      !!-------------------------------------------------------------------
+      INTEGER ::   ierr
+      !!-------------------------------------------------------------------
+      !
+      !                             !* allocate prather fields
+      ALLOCATE( sxopw(jpi,jpj)     , syopw(jpi,jpj)     , sxxopw(jpi,jpj)     , syyopw(jpi,jpj)     , sxyopw(jpi,jpj)     ,   &
+         &      sxice(jpi,jpj,jpl) , syice(jpi,jpj,jpl) , sxxice(jpi,jpj,jpl) , syyice(jpi,jpj,jpl) , sxyice(jpi,jpj,jpl) ,   &
+         &      sxsn (jpi,jpj,jpl) , sysn (jpi,jpj,jpl) , sxxsn (jpi,jpj,jpl) , syysn (jpi,jpj,jpl) , sxysn (jpi,jpj,jpl) ,   &
+         &      sxa  (jpi,jpj,jpl) , sya  (jpi,jpj,jpl) , sxxa  (jpi,jpj,jpl) , syya  (jpi,jpj,jpl) , sxya  (jpi,jpj,jpl) ,   &
+         &      sxsal(jpi,jpj,jpl) , sysal(jpi,jpj,jpl) , sxxsal(jpi,jpj,jpl) , syysal(jpi,jpj,jpl) , sxysal(jpi,jpj,jpl) ,   &
+         &      sxage(jpi,jpj,jpl) , syage(jpi,jpj,jpl) , sxxage(jpi,jpj,jpl) , syyage(jpi,jpj,jpl) , sxyage(jpi,jpj,jpl) ,   &
+         &      sxap(jpi,jpj,jpl)  , syap (jpi,jpj,jpl) , sxxap (jpi,jpj,jpl) , syyap (jpi,jpj,jpl) , sxyap (jpi,jpj,jpl) ,   &
+         &      sxvp(jpi,jpj,jpl)  , syvp (jpi,jpj,jpl) , sxxvp (jpi,jpj,jpl) , syyvp (jpi,jpj,jpl) , sxyvp (jpi,jpj,jpl) ,   &
+         !
+         &      sxc0 (jpi,jpj,nlay_s,jpl) , syc0 (jpi,jpj,nlay_s,jpl) , sxxc0(jpi,jpj,nlay_s,jpl) , &
+         &      syyc0(jpi,jpj,nlay_s,jpl) , sxyc0(jpi,jpj,nlay_s,jpl)                             , &
+         !
+         &      sxe  (jpi,jpj,nlay_i,jpl) , sye  (jpi,jpj,nlay_i,jpl) , sxxe (jpi,jpj,nlay_i,jpl) , &
+         &      syye (jpi,jpj,nlay_i,jpl) , sxye (jpi,jpj,nlay_i,jpl)                             , &
+         &      STAT = ierr )
+      !
+      IF( lk_mpp    )   CALL mpp_sum( ierr )
+      IF( ierr /= 0 )   CALL ctl_stop('STOP', 'adv_pra_init : unable to allocate ice arrays for Prather advection scheme')
+      !
+      CALL adv_pra_rst( 'READ' )    !* read or initialize all required files
+      !
+   END SUBROUTINE adv_pra_init
+
+
+   SUBROUTINE adv_pra_rst( cdrw, kt )
+      !!---------------------------------------------------------------------
+      !!                   ***  ROUTINE adv_pra_rst  ***
+      !!                     
+      !! ** Purpose :   Read or write RHG file in restart file
+      !!
+      !! ** Method  :   use of IOM library
+      !!----------------------------------------------------------------------
+      CHARACTER(len=*) , INTENT(in) ::   cdrw   ! "READ"/"WRITE" flag
+      INTEGER, OPTIONAL, INTENT(in) ::   kt     ! ice time-step
+      !
+      INTEGER ::   jk, jl   ! dummy loop indices
+      INTEGER ::   iter     ! local integer
+      INTEGER ::   id1      ! local integer
+      CHARACTER(len=25) ::   znam
+      CHARACTER(len=2)  ::   zchar, zchar1
+      REAL(wp), DIMENSION(jpi,jpj,jpl) ::   z3d   ! 3D workspace
+      !!----------------------------------------------------------------------
+      !
+      !                                      !==========================!
+      IF( TRIM(cdrw) == 'READ' ) THEN        !==  Read or initialize  ==!
+         !                                   !==========================!
+         !
+         IF( ln_rstart ) THEN   ;   id1 = iom_varid( numrir, 'sxopw' , ldstop = .FALSE. )    ! file exist: id1>0
+         ELSE                   ;   id1 = 0                                                  ! no restart: id1=0
+         ENDIF
+         !
+         IF( id1 > 0 ) THEN                     !**  Read the restart file  **!
+            !
+            !                                                        ! ice thickness
+            CALL iom_get( numrir, jpdom_autoglo, 'sxice' , sxice  )
+            CALL iom_get( numrir, jpdom_autoglo, 'syice' , syice  )
+            CALL iom_get( numrir, jpdom_autoglo, 'sxxice', sxxice )
+            CALL iom_get( numrir, jpdom_autoglo, 'syyice', syyice )
+            CALL iom_get( numrir, jpdom_autoglo, 'sxyice', sxyice )
+            !                                                        ! snow thickness
+            CALL iom_get( numrir, jpdom_autoglo, 'sxsn'  , sxsn   )
+            CALL iom_get( numrir, jpdom_autoglo, 'sysn'  , sysn   )
+            CALL iom_get( numrir, jpdom_autoglo, 'sxxsn' , sxxsn  )
+            CALL iom_get( numrir, jpdom_autoglo, 'syysn' , syysn  )
+            CALL iom_get( numrir, jpdom_autoglo, 'sxysn' , sxysn  )
+            !                                                        ! lead fraction
+            CALL iom_get( numrir, jpdom_autoglo, 'sxa'   , sxa    )
+            CALL iom_get( numrir, jpdom_autoglo, 'sya'   , sya    )
+            CALL iom_get( numrir, jpdom_autoglo, 'sxxa'  , sxxa   )
+            CALL iom_get( numrir, jpdom_autoglo, 'syya'  , syya   )
+            CALL iom_get( numrir, jpdom_autoglo, 'sxya'  , sxya   )
+            !                                                        ! ice salinity
+            CALL iom_get( numrir, jpdom_autoglo, 'sxsal' , sxsal  )
+            CALL iom_get( numrir, jpdom_autoglo, 'sysal' , sysal  )
+            CALL iom_get( numrir, jpdom_autoglo, 'sxxsal', sxxsal )
+            CALL iom_get( numrir, jpdom_autoglo, 'syysal', syysal )
+            CALL iom_get( numrir, jpdom_autoglo, 'sxysal', sxysal )
+            !                                                        ! ice age
+            CALL iom_get( numrir, jpdom_autoglo, 'sxage' , sxage  )
+            CALL iom_get( numrir, jpdom_autoglo, 'syage' , syage  )
+            CALL iom_get( numrir, jpdom_autoglo, 'sxxage', sxxage )
+            CALL iom_get( numrir, jpdom_autoglo, 'syyage', syyage )
+            CALL iom_get( numrir, jpdom_autoglo, 'sxyage', sxyage )
+            !                                                        ! open water in sea ice
+            CALL iom_get( numrir, jpdom_autoglo, 'sxopw' , sxopw  )
+            CALL iom_get( numrir, jpdom_autoglo, 'syopw' , syopw  )
+            CALL iom_get( numrir, jpdom_autoglo, 'sxxopw', sxxopw )
+            CALL iom_get( numrir, jpdom_autoglo, 'syyopw', syyopw )
+            CALL iom_get( numrir, jpdom_autoglo, 'sxyopw', sxyopw )
+            !                                                        ! snow layers heat content
+            DO jk = 1, nlay_s
+               WRITE(zchar1,'(I2.2)') jk
+               znam = 'sxc0'//'_l'//zchar1  ;   CALL iom_get( numrir, jpdom_autoglo, znam , z3d )   ;   sxc0 (:,:,jk,:) = z3d(:,:,:)
+               znam = 'syc0'//'_l'//zchar1  ;   CALL iom_get( numrir, jpdom_autoglo, znam , z3d )   ;   syc0 (:,:,jk,:) = z3d(:,:,:)
+               znam = 'sxxc0'//'_l'//zchar1 ;   CALL iom_get( numrir, jpdom_autoglo, znam , z3d )   ;   sxxc0(:,:,jk,:) = z3d(:,:,:)
+               znam = 'syyc0'//'_l'//zchar1 ;   CALL iom_get( numrir, jpdom_autoglo, znam , z3d )   ;   syyc0(:,:,jk,:) = z3d(:,:,:)
+               znam = 'sxyc0'//'_l'//zchar1 ;   CALL iom_get( numrir, jpdom_autoglo, znam , z3d )   ;   sxyc0(:,:,jk,:) = z3d(:,:,:)
+            END DO
+            !                                                        ! ice layers heat content
+            DO jk = 1, nlay_i
+               WRITE(zchar1,'(I2.2)') jk
+               znam = 'sxe'//'_l'//zchar1   ;   CALL iom_get( numrir, jpdom_autoglo, znam , z3d )   ;   sxe (:,:,jk,:) = z3d(:,:,:)
+               znam = 'sye'//'_l'//zchar1   ;   CALL iom_get( numrir, jpdom_autoglo, znam , z3d )   ;   sye (:,:,jk,:) = z3d(:,:,:)
+               znam = 'sxxe'//'_l'//zchar1  ;   CALL iom_get( numrir, jpdom_autoglo, znam , z3d )   ;   sxxe(:,:,jk,:) = z3d(:,:,:)
+               znam = 'syye'//'_l'//zchar1  ;   CALL iom_get( numrir, jpdom_autoglo, znam , z3d )   ;   syye(:,:,jk,:) = z3d(:,:,:)
+               znam = 'sxye'//'_l'//zchar1  ;   CALL iom_get( numrir, jpdom_autoglo, znam , z3d )   ;   sxye(:,:,jk,:) = z3d(:,:,:)
+            END DO
+            !
+            IF( ln_pnd_H12 ) THEN                                    ! melt pond fraction
+               CALL iom_get( numrir, jpdom_autoglo, 'sxap' , sxap  )
+               CALL iom_get( numrir, jpdom_autoglo, 'syap' , syap  )
+               CALL iom_get( numrir, jpdom_autoglo, 'sxxap', sxxap )
+               CALL iom_get( numrir, jpdom_autoglo, 'syyap', syyap )
+               CALL iom_get( numrir, jpdom_autoglo, 'sxyap', sxyap )
+               !                                                     ! melt pond volume
+               CALL iom_get( numrir, jpdom_autoglo, 'sxvp' , sxvp  )
+               CALL iom_get( numrir, jpdom_autoglo, 'syvp' , syvp  )
+               CALL iom_get( numrir, jpdom_autoglo, 'sxxvp', sxxvp )
+               CALL iom_get( numrir, jpdom_autoglo, 'syyvp', syyvp )
+               CALL iom_get( numrir, jpdom_autoglo, 'sxyvp', sxyvp )
+            ENDIF
+            !
+         ELSE                                   !**  start rheology from rest  **!
+            !
+            IF(lwp) WRITE(numout,*) '   ==>>   start from rest OR previous run without Prather, set moments to 0'
+            !
+            sxice = 0._wp   ;   syice = 0._wp   ;   sxxice = 0._wp   ;   syyice = 0._wp   ;   sxyice = 0._wp      ! ice thickness
+            sxsn  = 0._wp   ;   sysn  = 0._wp   ;   sxxsn  = 0._wp   ;   syysn  = 0._wp   ;   sxysn  = 0._wp      ! snow thickness
+            sxa   = 0._wp   ;   sya   = 0._wp   ;   sxxa   = 0._wp   ;   syya   = 0._wp   ;   sxya   = 0._wp      ! lead fraction
+            sxsal = 0._wp   ;   sysal = 0._wp   ;   sxxsal = 0._wp   ;   syysal = 0._wp   ;   sxysal = 0._wp      ! ice salinity
+            sxage = 0._wp   ;   syage = 0._wp   ;   sxxage = 0._wp   ;   syyage = 0._wp   ;   sxyage = 0._wp      ! ice age
+            sxopw = 0._wp   ;   syopw = 0._wp   ;   sxxopw = 0._wp   ;   syyopw = 0._wp   ;   sxyopw = 0._wp      ! open water in sea ice
+            sxc0  = 0._wp   ;   syc0  = 0._wp   ;   sxxc0  = 0._wp   ;   syyc0  = 0._wp   ;   sxyc0  = 0._wp      ! snow layers heat content
+            sxe   = 0._wp   ;   sye   = 0._wp   ;   sxxe   = 0._wp   ;   syye   = 0._wp   ;   sxye   = 0._wp      ! ice layers heat content
+            IF( ln_pnd_H12 ) THEN
+               sxap  = 0._wp   ;   syap  = 0._wp   ;   sxxap  = 0._wp   ;   syyap  = 0._wp   ;   sxyap  = 0._wp   ! melt pond fraction
+               sxvp  = 0._wp   ;   syvp  = 0._wp   ;   sxxvp  = 0._wp   ;   syyvp  = 0._wp   ;   sxyvp  = 0._wp   ! melt pond volume
+            ENDIF
+         ENDIF
+         !
+         !                                   !=====================================!
+      ELSEIF( TRIM(cdrw) == 'WRITE' ) THEN   !==  write in the ice restart file  ==!
+         !                                   !=====================================!
+         IF(lwp) WRITE(numout,*) '----  ice-adv-rst  ----'
+         iter = kt + nn_fsbc - 1             ! ice restarts are written at kt == nitrst - nn_fsbc + 1
+         !
+         !
+         ! In case Prather scheme is used for advection, write second order moments
+         ! ------------------------------------------------------------------------
+         !
+         !                                                           ! ice thickness
+         CALL iom_rstput( iter, nitrst, numriw, 'sxice' , sxice  )
+         CALL iom_rstput( iter, nitrst, numriw, 'syice' , syice  )
+         CALL iom_rstput( iter, nitrst, numriw, 'sxxice', sxxice )
+         CALL iom_rstput( iter, nitrst, numriw, 'syyice', syyice )
+         CALL iom_rstput( iter, nitrst, numriw, 'sxyice', sxyice )
+         !                                                           ! snow thickness
+         CALL iom_rstput( iter, nitrst, numriw, 'sxsn'  , sxsn   )
+         CALL iom_rstput( iter, nitrst, numriw, 'sysn'  , sysn   )
+         CALL iom_rstput( iter, nitrst, numriw, 'sxxsn' , sxxsn  )
+         CALL iom_rstput( iter, nitrst, numriw, 'syysn' , syysn  )
+         CALL iom_rstput( iter, nitrst, numriw, 'sxysn' , sxysn  )
+         !                                                           ! lead fraction
+         CALL iom_rstput( iter, nitrst, numriw, 'sxa'   , sxa    )
+         CALL iom_rstput( iter, nitrst, numriw, 'sya'   , sya    )
+         CALL iom_rstput( iter, nitrst, numriw, 'sxxa'  , sxxa   )
+         CALL iom_rstput( iter, nitrst, numriw, 'syya'  , syya   )
+         CALL iom_rstput( iter, nitrst, numriw, 'sxya'  , sxya   )
+         !                                                           ! ice salinity
+         CALL iom_rstput( iter, nitrst, numriw, 'sxsal' , sxsal  )
+         CALL iom_rstput( iter, nitrst, numriw, 'sysal' , sysal  )
+         CALL iom_rstput( iter, nitrst, numriw, 'sxxsal', sxxsal )
+         CALL iom_rstput( iter, nitrst, numriw, 'syysal', syysal )
+         CALL iom_rstput( iter, nitrst, numriw, 'sxysal', sxysal )
+         !                                                           ! ice age
+         CALL iom_rstput( iter, nitrst, numriw, 'sxage' , sxage  )
+         CALL iom_rstput( iter, nitrst, numriw, 'syage' , syage  )
+         CALL iom_rstput( iter, nitrst, numriw, 'sxxage', sxxage )
+         CALL iom_rstput( iter, nitrst, numriw, 'syyage', syyage )
+         CALL iom_rstput( iter, nitrst, numriw, 'sxyage', sxyage )
+         !                                                           ! open water in sea ice
+         CALL iom_rstput( iter, nitrst, numriw, 'sxopw' , sxopw  )
+         CALL iom_rstput( iter, nitrst, numriw, 'syopw' , syopw  )
+         CALL iom_rstput( iter, nitrst, numriw, 'sxxopw', sxxopw )
+         CALL iom_rstput( iter, nitrst, numriw, 'syyopw', syyopw )
+         CALL iom_rstput( iter, nitrst, numriw, 'sxyopw', sxyopw )
+         !                                                           ! snow layers heat content
+         DO jk = 1, nlay_s
+            WRITE(zchar1,'(I2.2)') jk
+            znam = 'sxc0'//'_l'//zchar1  ;   z3d(:,:,:) = sxc0 (:,:,jk,:)  ;   CALL iom_rstput( iter, nitrst, numriw, znam , z3d )
+            znam = 'syc0'//'_l'//zchar1  ;   z3d(:,:,:) = syc0 (:,:,jk,:)  ;   CALL iom_rstput( iter, nitrst, numriw, znam , z3d )
+            znam = 'sxxc0'//'_l'//zchar1 ;   z3d(:,:,:) = sxxc0(:,:,jk,:)  ;   CALL iom_rstput( iter, nitrst, numriw, znam , z3d )
+            znam = 'syyc0'//'_l'//zchar1 ;   z3d(:,:,:) = syyc0(:,:,jk,:)  ;   CALL iom_rstput( iter, nitrst, numriw, znam , z3d )
+            znam = 'sxyc0'//'_l'//zchar1 ;   z3d(:,:,:) = sxyc0(:,:,jk,:)  ;   CALL iom_rstput( iter, nitrst, numriw, znam , z3d )
+         END DO
+         !                                                           ! ice layers heat content
+         DO jk = 1, nlay_i
+            WRITE(zchar1,'(I2.2)') jk
+            znam = 'sxe'//'_l'//zchar1   ;   z3d(:,:,:) = sxe (:,:,jk,:)   ;   CALL iom_rstput( iter, nitrst, numriw, znam , z3d )
+            znam = 'sye'//'_l'//zchar1   ;   z3d(:,:,:) = sye (:,:,jk,:)   ;   CALL iom_rstput( iter, nitrst, numriw, znam , z3d )
+            znam = 'sxxe'//'_l'//zchar1  ;   z3d(:,:,:) = sxxe(:,:,jk,:)   ;   CALL iom_rstput( iter, nitrst, numriw, znam , z3d )
+            znam = 'syye'//'_l'//zchar1  ;   z3d(:,:,:) = syye(:,:,jk,:)   ;   CALL iom_rstput( iter, nitrst, numriw, znam , z3d )
+            znam = 'sxye'//'_l'//zchar1  ;   z3d(:,:,:) = sxye(:,:,jk,:)   ;   CALL iom_rstput( iter, nitrst, numriw, znam , z3d )
+         END DO
+         !
+         IF( ln_pnd_H12 ) THEN                                       ! melt pond fraction
+            CALL iom_rstput( iter, nitrst, numriw, 'sxap' , sxap  )
+            CALL iom_rstput( iter, nitrst, numriw, 'syap' , syap  )
+            CALL iom_rstput( iter, nitrst, numriw, 'sxxap', sxxap )
+            CALL iom_rstput( iter, nitrst, numriw, 'syyap', syyap )
+            CALL iom_rstput( iter, nitrst, numriw, 'sxyap', sxyap )
+            !                                                        ! melt pond volume
+            CALL iom_rstput( iter, nitrst, numriw, 'sxvp' , sxvp  )
+            CALL iom_rstput( iter, nitrst, numriw, 'syvp' , syvp  )
+            CALL iom_rstput( iter, nitrst, numriw, 'sxxvp', sxxvp )
+            CALL iom_rstput( iter, nitrst, numriw, 'syyvp', syyvp )
+            CALL iom_rstput( iter, nitrst, numriw, 'sxyvp', sxyvp )
+         ENDIF
+         !
+      ENDIF
+      !
+   END SUBROUTINE adv_pra_rst
+
+#else
+   !!----------------------------------------------------------------------
+   !!   Default option            Dummy module        NO SI3 sea-ice model
+   !!----------------------------------------------------------------------
+#endif
+
+   !!======================================================================
+END MODULE icedyn_adv_pra
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/ICE_SRC/icedyn_adv_umx.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/ICE_SRC/icedyn_adv_umx.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/ICE_SRC/icedyn_adv_umx.F90	(revision 9570)
@@ -0,0 +1,644 @@
+MODULE icedyn_adv_umx
+   !!==============================================================================
+   !!                       ***  MODULE  icedyn_adv_umx  ***
+   !! sea-ice : advection using the ULTIMATE-MACHO scheme
+   !!==============================================================================
+   !! History :  3.6  !  2014-11  (C. Rousset, G. Madec)  Original code
+   !!----------------------------------------------------------------------
+#if defined key_si3
+   !!----------------------------------------------------------------------
+   !!   'key_si3'                                       SI3 sea-ice model
+   !!----------------------------------------------------------------------
+   !!   ice_dyn_adv_umx   : update the tracer trend with the 3D advection trends using a TVD scheme
+   !!   ultimate_x(_y)    : compute a tracer value at velocity points using ULTIMATE scheme at various orders
+   !!   macho             : ???
+   !!   nonosc_2d         : compute monotonic tracer fluxes by a non-oscillatory algorithm 
+   !!----------------------------------------------------------------------
+   USE phycst         ! physical constant
+   USE dom_oce        ! ocean domain
+   USE sbc_oce , ONLY : nn_fsbc   ! update frequency of surface boundary condition
+   USE ice            ! sea-ice variables
+   !
+   USE in_out_manager ! I/O manager
+   USE lib_mpp        ! MPP library
+   USE lib_fortran    ! fortran utilities (glob_sum + no signed zero)
+   USE lbclnk         ! lateral boundary conditions (or mpp links)
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   ice_dyn_adv_umx   ! called by icedyn_adv.F90
+      
+   REAL(wp) ::   z1_6   = 1._wp /   6._wp   ! =1/6
+   REAL(wp) ::   z1_120 = 1._wp / 120._wp   ! =1/120
+
+   !! * Substitutions
+#  include "vectopt_loop_substitute.h90"
+   !!----------------------------------------------------------------------
+   !! NEMO/ICE 4.0 , NEMO Consortium (2017)
+   !! $Id: icedyn_adv_umx.F90 4499 2014-02-18 15:14:31Z timgraham $
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE ice_dyn_adv_umx( k_order, kt, pu_ice, pv_ice,  &
+      &                    pato_i, pv_i, pv_s, psv_i, poa_i, pa_i, pa_ip, pv_ip, pe_s, pe_i )
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE ice_dyn_adv_umx  ***
+      !! 
+      !! **  Purpose :   Compute the now trend due to total advection of 
+      !!                 tracers and add it to the general trend of tracer equations
+      !!                 using an "Ultimate-Macho" scheme
+      !!
+      !! Reference : Leonard, B.P., 1991, Comput. Methods Appl. Mech. Eng., 88, 17-74. 
+      !!----------------------------------------------------------------------
+      INTEGER                     , INTENT(in   ) ::   k_order    ! order of the scheme (1-5 or 20)
+      INTEGER                     , INTENT(in   ) ::   kt         ! time step
+      REAL(wp), DIMENSION(:,:)    , INTENT(in   ) ::   pu_ice     ! ice i-velocity
+      REAL(wp), DIMENSION(:,:)    , INTENT(in   ) ::   pv_ice     ! ice j-velocity
+      REAL(wp), DIMENSION(:,:)    , INTENT(inout) ::   pato_i     ! open water area
+      REAL(wp), DIMENSION(:,:,:)  , INTENT(inout) ::   pv_i       ! ice volume
+      REAL(wp), DIMENSION(:,:,:)  , INTENT(inout) ::   pv_s       ! snw volume
+      REAL(wp), DIMENSION(:,:,:)  , INTENT(inout) ::   psv_i      ! salt content
+      REAL(wp), DIMENSION(:,:,:)  , INTENT(inout) ::   poa_i      ! age content
+      REAL(wp), DIMENSION(:,:,:)  , INTENT(inout) ::   pa_i       ! ice concentration
+      REAL(wp), DIMENSION(:,:,:)  , INTENT(inout) ::   pa_ip      ! melt pond fraction
+      REAL(wp), DIMENSION(:,:,:)  , INTENT(inout) ::   pv_ip      ! melt pond volume
+      REAL(wp), DIMENSION(:,:,:,:), INTENT(inout) ::   pe_s       ! snw heat content
+      REAL(wp), DIMENSION(:,:,:,:), INTENT(inout) ::   pe_i       ! ice heat content
+      !
+      INTEGER  ::   ji, jj, jk, jl, jt      ! dummy loop indices
+      INTEGER  ::   initad                  ! number of sub-timestep for the advection
+      REAL(wp) ::   zcfl , zusnit, zdt      !   -      -
+      REAL(wp), ALLOCATABLE, DIMENSION(:,:) ::   zudy, zvdx, zcu_box, zcv_box
+      !!----------------------------------------------------------------------
+      !
+      IF( kt == nit000 .AND. lwp )   WRITE(numout,*) '-- ice_dyn_adv_umx: Ultimate-Macho advection scheme'
+      !
+      ALLOCATE( zudy(jpi,jpj) , zvdx(jpi,jpj) , zcu_box(jpi,jpj) , zcv_box(jpi,jpj) )
+      !
+      ! --- If ice drift field is too fast, use an appropriate time step for advection (CFL test for stability) --- !        
+      zcfl  =            MAXVAL( ABS( pu_ice(:,:) ) * rdt_ice * r1_e1u(:,:) )
+      zcfl  = MAX( zcfl, MAXVAL( ABS( pv_ice(:,:) ) * rdt_ice * r1_e2v(:,:) ) )
+      IF( lk_mpp )   CALL mpp_max( zcfl )
+
+      IF( zcfl > 0.5 ) THEN   ;   initad = 2   ;   zusnit = 0.5_wp
+      ELSE                    ;   initad = 1   ;   zusnit = 1.0_wp
+      ENDIF
+
+      zdt = rdt_ice / REAL(initad)
+
+      ! --- transport --- !
+      zudy(:,:) = pu_ice(:,:) * e2u(:,:)
+      zvdx(:,:) = pv_ice(:,:) * e1v(:,:)
+
+      ! --- define velocity for advection: u*grad(H) --- !
+      DO jj = 2, jpjm1
+         DO ji = fs_2, fs_jpim1
+            IF    ( pu_ice(ji,jj) * pu_ice(ji-1,jj) <= 0._wp ) THEN   ;   zcu_box(ji,jj) = 0._wp
+            ELSEIF( pu_ice(ji,jj)                   >  0._wp ) THEN   ;   zcu_box(ji,jj) = pu_ice(ji-1,jj)
+            ELSE                                                      ;   zcu_box(ji,jj) = pu_ice(ji  ,jj)
+            ENDIF
+
+            IF    ( pv_ice(ji,jj) * pv_ice(ji,jj-1) <= 0._wp ) THEN   ;   zcv_box(ji,jj) = 0._wp
+            ELSEIF( pv_ice(ji,jj)                   >  0._wp ) THEN   ;   zcv_box(ji,jj) = pv_ice(ji,jj-1)
+            ELSE                                                      ;   zcv_box(ji,jj) = pv_ice(ji,jj  )
+            ENDIF
+         END DO
+      END DO
+
+      !---------------!
+      !== advection ==!
+      !---------------!
+      DO jt = 1, initad
+         CALL adv_umx( k_order, kt, zdt, zudy, zvdx, zcu_box, zcv_box, pato_i(:,:) )             ! Open water area 
+         DO jl = 1, jpl
+            CALL adv_umx( k_order, kt, zdt, zudy, zvdx, zcu_box, zcv_box, pa_i(:,:,jl) )         ! Ice area
+            CALL adv_umx( k_order, kt, zdt, zudy, zvdx, zcu_box, zcv_box, pv_i(:,:,jl) )         ! Ice  volume
+            CALL adv_umx( k_order, kt, zdt, zudy, zvdx, zcu_box, zcv_box, psv_i(:,:,jl) )        ! Salt content
+            CALL adv_umx( k_order, kt, zdt, zudy, zvdx, zcu_box, zcv_box, poa_i(:,:,jl) )        ! Age content
+            DO jk = 1, nlay_i
+               CALL adv_umx( k_order, kt, zdt, zudy, zvdx, zcu_box, zcv_box, pe_i(:,:,jk,jl) )   ! Ice  heat content
+            END DO
+            CALL adv_umx( k_order, kt, zdt, zudy, zvdx, zcu_box, zcv_box, pv_s(:,:,jl) )         ! Snow volume
+            DO jk = 1, nlay_s
+               CALL adv_umx( k_order, kt, zdt, zudy, zvdx, zcu_box, zcv_box, pe_s(:,:,jk,jl) )   ! Snow heat content
+            END DO
+            IF ( ln_pnd_H12 ) THEN
+               CALL adv_umx( k_order, kt, zdt, zudy, zvdx, zcu_box, zcv_box, pa_ip(:,:,jl) )     ! Melt pond fraction
+               CALL adv_umx( k_order, kt, zdt, zudy, zvdx, zcu_box, zcv_box, pv_ip(:,:,jl) )     ! Melt pond volume
+            ENDIF
+         END DO
+      END DO
+      !
+      DEALLOCATE( zudy, zvdx, zcu_box, zcv_box )
+      !
+   END SUBROUTINE ice_dyn_adv_umx
+   
+   SUBROUTINE adv_umx( k_order, kt, pdt, puc, pvc, pubox, pvbox, ptc )
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE adv_umx  ***
+      !! 
+      !! **  Purpose :   Compute the now trend due to total advection of 
+      !!       tracers and add it to the general trend of tracer equations
+      !!
+      !! **  Method  :   TVD scheme, i.e. 2nd order centered scheme with
+      !!       corrected flux (monotonic correction)
+      !!       note: - this advection scheme needs a leap-frog time scheme
+      !!
+      !! ** Action : - pt  the after advective tracer
+      !!----------------------------------------------------------------------
+      INTEGER                     , INTENT(in   ) ::   k_order        ! order of the ULTIMATE scheme
+      INTEGER                     , INTENT(in   ) ::   kt             ! number of iteration
+      REAL(wp)                    , INTENT(in   ) ::   pdt            ! tracer time-step
+      REAL(wp), DIMENSION(jpi,jpj), INTENT(in   ) ::   puc  , pvc     ! 2 ice velocity components => u*e2
+      REAL(wp), DIMENSION(jpi,jpj), INTENT(in   ) ::   pubox, pvbox   ! upstream velocity
+      REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) ::   ptc            ! tracer content field
+      !
+      INTEGER  ::   ji, jj           ! dummy loop indices  
+      REAL(wp) ::   ztra             ! local scalar
+      REAL(wp) ::   zfp_ui, zfp_vj   !   -      -
+      REAL(wp) ::   zfm_ui, zfm_vj   !   -      -
+      REAL(wp), DIMENSION(jpi,jpj) ::   zfu_ups, zfu_ho, zt_u, zt_ups
+      REAL(wp), DIMENSION(jpi,jpj) ::   zfv_ups, zfv_ho, zt_v, ztrd
+      !!----------------------------------------------------------------------
+      !
+      !  upstream advection with initial mass fluxes & intermediate update
+      ! --------------------------------------------------------------------
+      DO jj = 1, jpjm1         ! upstream tracer flux in the i and j direction
+         DO ji = 1, fs_jpim1   ! vector opt.
+            zfp_ui = puc(ji,jj) + ABS( puc(ji,jj) )
+            zfm_ui = puc(ji,jj) - ABS( puc(ji,jj) )
+            zfp_vj = pvc(ji,jj) + ABS( pvc(ji,jj) )
+            zfm_vj = pvc(ji,jj) - ABS( pvc(ji,jj) )
+            zfu_ups(ji,jj) = 0.5_wp * ( zfp_ui * ptc(ji,jj) + zfm_ui * ptc(ji+1,jj  ) )
+            zfv_ups(ji,jj) = 0.5_wp * ( zfp_vj * ptc(ji,jj) + zfm_vj * ptc(ji  ,jj+1) )
+         END DO
+      END DO
+      
+      DO jj = 2, jpjm1            ! total intermediate advective trends
+         DO ji = fs_2, fs_jpim1   ! vector opt.
+            ztra = - (   zfu_ups(ji,jj) - zfu_ups(ji-1,jj  )   &
+               &       + zfv_ups(ji,jj) - zfv_ups(ji  ,jj-1)   ) * r1_e1e2t(ji,jj)
+            !
+            ztrd(ji,jj) =                         ztra                         ! upstream trend [ -div(uh) or -div(uhT) ]  
+            zt_ups (ji,jj) = ( ptc(ji,jj) + pdt * ztra ) * tmask(ji,jj,1)      ! guess after content field with monotonic scheme
+         END DO
+      END DO
+      CALL lbc_lnk( zt_ups, 'T', 1. )        ! Lateral boundary conditions   (unchanged sign)
+      
+      ! High order (_ho) fluxes 
+      ! -----------------------
+      SELECT CASE( k_order )
+      CASE ( 20 )                          ! centered second order
+         DO jj = 1, jpjm1
+            DO ji = 1, fs_jpim1   ! vector opt.
+               zfu_ho(ji,jj) = 0.5 * puc(ji,jj) * ( ptc(ji,jj) + ptc(ji+1,jj) )
+               zfv_ho(ji,jj) = 0.5 * pvc(ji,jj) * ( ptc(ji,jj) + ptc(ji,jj+1) )
+            END DO
+         END DO
+         !
+      CASE ( 1:5 )                      ! 1st to 5th order ULTIMATE-MACHO scheme
+         CALL macho( k_order, kt, pdt, ptc, puc, pvc, pubox, pvbox, zt_u, zt_v )
+         !
+         DO jj = 1, jpjm1
+            DO ji = 1, fs_jpim1   ! vector opt.
+               zfu_ho(ji,jj) = puc(ji,jj) * zt_u(ji,jj)
+               zfv_ho(ji,jj) = pvc(ji,jj) * zt_v(ji,jj)
+            END DO
+         END DO
+         !
+      END SELECT
+         
+      ! antidiffusive flux : high order minus low order
+      ! --------------------------------------------------
+      DO jj = 1, jpjm1
+         DO ji = 1, fs_jpim1   ! vector opt.
+            zfu_ho(ji,jj) = zfu_ho(ji,jj) - zfu_ups(ji,jj)
+            zfv_ho(ji,jj) = zfv_ho(ji,jj) - zfv_ups(ji,jj)
+         END DO
+      END DO
+      
+      ! monotonicity algorithm
+      ! -------------------------
+      CALL nonosc_2d( ptc, zfu_ho, zfv_ho, zt_ups, pdt )
+      
+      ! final trend with corrected fluxes
+      ! ------------------------------------
+      DO jj = 2, jpjm1
+         DO ji = fs_2, fs_jpim1   ! vector opt.  
+            ztra       = ztrd(ji,jj)  - (  zfu_ho(ji,jj) - zfu_ho(ji-1,jj  )   &
+               &                         + zfv_ho(ji,jj) - zfv_ho(ji  ,jj-1) ) * r1_e1e2t(ji,jj)  
+            ptc(ji,jj) = ptc(ji,jj) + pdt * ztra
+         END DO
+      END DO
+      CALL lbc_lnk( ptc, 'T',  1. )
+      !
+   END SUBROUTINE adv_umx
+
+
+   SUBROUTINE macho( k_order, kt, pdt, ptc, puc, pvc, pubox, pvbox, pt_u, pt_v )
+      !!---------------------------------------------------------------------
+      !!                    ***  ROUTINE ultimate_x  ***
+      !!     
+      !! **  Purpose :   compute  
+      !!
+      !! **  Method  :   ... ???
+      !!                 TIM = transient interpolation Modeling 
+      !!
+      !! Reference : Leonard, B.P., 1991, Comput. Methods Appl. Mech. Eng., 88, 17-74. 
+      !!----------------------------------------------------------------------
+      INTEGER                     , INTENT(in   ) ::   k_order    ! order of the ULTIMATE scheme
+      INTEGER                     , INTENT(in   ) ::   kt         ! number of iteration
+      REAL(wp)                    , INTENT(in   ) ::   pdt        ! tracer time-step
+      REAL(wp), DIMENSION(jpi,jpj), INTENT(in   ) ::   ptc        ! tracer fields
+      REAL(wp), DIMENSION(jpi,jpj), INTENT(in   ) ::   puc, pvc   ! 2 ice velocity components
+      REAL(wp), DIMENSION(jpi,jpj), INTENT(in   ) ::   pubox, pvbox   ! upstream velocity
+      REAL(wp), DIMENSION(jpi,jpj), INTENT(  out) ::   pt_u, pt_v ! tracer at u- and v-points 
+      !
+      INTEGER  ::   ji, jj    ! dummy loop indices
+      REAL(wp) ::   zc_box    !   -      -
+      REAL(wp), DIMENSION(jpi,jpj) :: zzt
+      !!----------------------------------------------------------------------
+      !
+      IF( MOD( (kt - 1) / nn_fsbc , 2 ) == 0 ) THEN         !==  odd ice time step:  adv_x then adv_y  ==!
+         !
+         !                                                           !--  ultimate interpolation of pt at u-point  --!
+         CALL ultimate_x( k_order, pdt, ptc, puc, pt_u )
+         !
+         !                                                           !--  advective form update in zzt  --!
+         DO jj = 2, jpjm1
+            DO ji = fs_2, fs_jpim1   ! vector opt.
+               zzt(ji,jj) = ptc(ji,jj) - pubox(ji,jj) * pdt * ( pt_u(ji,jj) - pt_u(ji-1,jj) ) * r1_e1t(ji,jj)  &
+                  &                    - ptc  (ji,jj) * pdt * ( puc (ji,jj) - puc (ji-1,jj) ) * r1_e1e2t(ji,jj)
+               zzt(ji,jj) = zzt(ji,jj) * tmask(ji,jj,1)
+            END DO
+         END DO
+         CALL lbc_lnk( zzt, 'T', 1. )
+         !
+         !                                                           !--  ultimate interpolation of pt at v-point  --!
+         CALL ultimate_y( k_order, pdt, zzt, pvc, pt_v )
+         !
+      ELSE                                                  !==  even ice time step:  adv_y then adv_x  ==!
+         !
+         !                                                           !--  ultimate interpolation of pt at v-point  --!
+         CALL ultimate_y( k_order, pdt, ptc, pvc, pt_v )
+         !
+         !                                                           !--  advective form update in zzt  --!
+         DO jj = 2, jpjm1
+            DO ji = fs_2, fs_jpim1
+               zzt(ji,jj) = ptc(ji,jj) - pvbox(ji,jj) * pdt * ( pt_v(ji,jj) - pt_v(ji,jj-1) ) * r1_e2t(ji,jj)  &
+                  &                    - ptc  (ji,jj) * pdt * ( pvc (ji,jj) - pvc (ji,jj-1) ) * r1_e1e2t(ji,jj)
+               zzt(ji,jj) = zzt(ji,jj) * tmask(ji,jj,1)
+            END DO
+         END DO
+         CALL lbc_lnk( zzt, 'T', 1. )
+         !
+         !                                                           !--  ultimate interpolation of pt at u-point  --!
+         CALL ultimate_x( k_order, pdt, zzt, puc, pt_u )
+         !      
+      ENDIF      
+      !
+   END SUBROUTINE macho
+
+
+   SUBROUTINE ultimate_x( k_order, pdt, pt, puc, pt_u )
+      !!---------------------------------------------------------------------
+      !!                    ***  ROUTINE ultimate_x  ***
+      !!     
+      !! **  Purpose :   compute  
+      !!
+      !! **  Method  :   ... ???
+      !!                 TIM = transient interpolation Modeling 
+      !!
+      !! Reference : Leonard, B.P., 1991, Comput. Methods Appl. Mech. Eng., 88, 17-74. 
+      !!----------------------------------------------------------------------
+      INTEGER                     , INTENT(in   ) ::   k_order   ! ocean time-step index
+      REAL(wp)                    , INTENT(in   ) ::   pdt       ! tracer time-step
+      REAL(wp), DIMENSION(jpi,jpj), INTENT(in   ) ::   puc       ! ice i-velocity component
+      REAL(wp), DIMENSION(jpi,jpj), INTENT(in   ) ::   pt        ! tracer fields
+      REAL(wp), DIMENSION(jpi,jpj), INTENT(  out) ::   pt_u      ! tracer at u-point 
+      !
+      INTEGER  ::   ji, jj       ! dummy loop indices
+      REAL(wp) ::   zcu, zdx2, zdx4    !   -      -
+      REAL(wp), DIMENSION(jpi,jpj) :: ztu1, ztu2, ztu3, ztu4
+      !!----------------------------------------------------------------------
+      !
+      !                                                     !--  Laplacian in i-direction  --!
+      DO jj = 2, jpjm1         ! First derivative (gradient)
+         DO ji = 1, fs_jpim1
+            ztu1(ji,jj) = ( pt(ji+1,jj) - pt(ji,jj) ) * r1_e1u(ji,jj) * umask(ji,jj,1)
+         END DO
+         !                     ! Second derivative (Laplacian)
+         DO ji = fs_2, fs_jpim1
+            ztu2(ji,jj) = ( ztu1(ji,jj) - ztu1(ji-1,jj) ) * r1_e1t(ji,jj)
+         END DO
+      END DO
+      CALL lbc_lnk( ztu2, 'T', 1. )
+      !
+      !                                                     !--  BiLaplacian in i-direction  --!
+      DO jj = 2, jpjm1         ! Third derivative
+         DO ji = 1, fs_jpim1
+            ztu3(ji,jj) = ( ztu2(ji+1,jj) - ztu2(ji,jj) ) * r1_e1u(ji,jj) * umask(ji,jj,1)
+         END DO
+         !                     ! Fourth derivative
+         DO ji = fs_2, fs_jpim1
+            ztu4(ji,jj) = ( ztu3(ji,jj) - ztu3(ji-1,jj) ) * r1_e1t(ji,jj)
+         END DO
+      END DO
+      CALL lbc_lnk( ztu4, 'T', 1. )
+      !
+      !
+      SELECT CASE (k_order )
+      !
+      CASE( 1 )                                                   !==  1st order central TIM  ==! (Eq. 21)
+         !        
+         DO jj = 2, jpjm1
+            DO ji = 1, fs_jpim1   ! vector opt.
+               pt_u(ji,jj) = 0.5_wp * umask(ji,jj,1) * (                               pt(ji+1,jj) + pt(ji,jj)   &
+                  &                                    - SIGN( 1._wp, puc(ji,jj) ) * ( pt(ji+1,jj) - pt(ji,jj) ) )
+            END DO
+         END DO
+         !
+      CASE( 2 )                                                   !==  2nd order central TIM  ==! (Eq. 23)
+         !
+         DO jj = 2, jpjm1
+            DO ji = 1, fs_jpim1   ! vector opt.
+               zcu  = puc(ji,jj) * r1_e2u(ji,jj) * pdt * r1_e1u(ji,jj)
+               pt_u(ji,jj) = 0.5_wp * umask(ji,jj,1) * (                                   pt(ji+1,jj) + pt(ji,jj)   &
+                  &                                               -              zcu   * ( pt(ji+1,jj) - pt(ji,jj) ) ) 
+            END DO
+         END DO
+         !  
+      CASE( 3 )                                                   !==  3rd order central TIM  ==! (Eq. 24)
+         !
+         DO jj = 2, jpjm1
+            DO ji = 1, fs_jpim1   ! vector opt.
+               zcu  = puc(ji,jj) * r1_e2u(ji,jj) * pdt * r1_e1u(ji,jj)
+               zdx2 = e1u(ji,jj) * e1u(ji,jj)
+!!rachid       zdx2 = e1u(ji,jj) * e1t(ji,jj)
+               pt_u(ji,jj) = 0.5_wp * umask(ji,jj,1) * (         (                         pt  (ji+1,jj) + pt  (ji,jj)        &
+                  &                                               -              zcu   * ( pt  (ji+1,jj) - pt  (ji,jj) )  )   &
+                  &        + z1_6 * zdx2 * ( zcu*zcu - 1._wp ) * (                         ztu2(ji+1,jj) + ztu2(ji,jj)        &
+                  &                                               - SIGN( 1._wp, zcu ) * ( ztu2(ji+1,jj) - ztu2(ji,jj) )  )   )
+            END DO
+         END DO
+         !
+      CASE( 4 )                                                   !==  4th order central TIM  ==! (Eq. 27)
+         !
+         DO jj = 2, jpjm1
+            DO ji = 1, fs_jpim1   ! vector opt.
+               zcu  = puc(ji,jj) * r1_e2u(ji,jj) * pdt * r1_e1u(ji,jj)
+               zdx2 = e1u(ji,jj) * e1u(ji,jj)
+!!rachid       zdx2 = e1u(ji,jj) * e1t(ji,jj)
+               pt_u(ji,jj) = 0.5_wp * umask(ji,jj,1) * (         (                   pt  (ji+1,jj) + pt  (ji,jj)        &
+                  &                                               -          zcu * ( pt  (ji+1,jj) - pt  (ji,jj) )  )   &
+                  &        + z1_6 * zdx2 * ( zcu*zcu - 1._wp ) * (                   ztu2(ji+1,jj) + ztu2(ji,jj)        &
+                  &                                               - 0.5_wp * zcu * ( ztu2(ji+1,jj) - ztu2(ji,jj) )  )   )
+            END DO
+         END DO
+         !
+      CASE( 5 )                                                   !==  5th order central TIM  ==! (Eq. 29)
+         !
+         DO jj = 2, jpjm1
+            DO ji = 1, fs_jpim1   ! vector opt.
+               zcu  = puc(ji,jj) * r1_e2u(ji,jj) * pdt * r1_e1u(ji,jj)
+               zdx2 = e1u(ji,jj) * e1u(ji,jj)
+!!rachid       zdx2 = e1u(ji,jj) * e1t(ji,jj)
+               zdx4 = zdx2 * zdx2
+               pt_u(ji,jj) = 0.5_wp * umask(ji,jj,1) * (               (                   pt  (ji+1,jj) + pt  (ji,jj)       &
+                  &                                                     -          zcu * ( pt  (ji+1,jj) - pt  (ji,jj) ) )   &
+                  &        + z1_6   * zdx2 * ( zcu*zcu - 1._wp ) *     (                   ztu2(ji+1,jj) + ztu2(ji,jj)       &
+                  &                                                     - 0.5_wp * zcu * ( ztu2(ji+1,jj) - ztu2(ji,jj) ) )   &
+                  &        + z1_120 * zdx4 * ( zcu*zcu - 1._wp ) * ( zcu*zcu - 4._wp ) * ( ztu4(ji+1,jj) + ztu4(ji,jj)       &
+                  &                                               - SIGN( 1._wp, zcu ) * ( ztu4(ji+1,jj) - ztu4(ji,jj) ) ) )
+            END DO
+         END DO
+         !
+      END SELECT
+      !
+   END SUBROUTINE ultimate_x
+   
+ 
+   SUBROUTINE ultimate_y( k_order, pdt, pt, pvc, pt_v )
+      !!---------------------------------------------------------------------
+      !!                    ***  ROUTINE ultimate_y  ***
+      !!     
+      !! **  Purpose :   compute  
+      !!
+      !! **  Method  :   ... ???
+      !!                 TIM = transient interpolation Modeling 
+      !!
+      !! Reference : Leonard, B.P., 1991, Comput. Methods Appl. Mech. Eng., 88, 17-74. 
+      !!----------------------------------------------------------------------
+      INTEGER                     , INTENT(in   ) ::   k_order   ! ocean time-step index
+      REAL(wp)                    , INTENT(in   ) ::   pdt       ! tracer time-step
+      REAL(wp), DIMENSION(jpi,jpj), INTENT(in   ) ::   pvc       ! ice j-velocity component
+      REAL(wp), DIMENSION(jpi,jpj), INTENT(in   ) ::   pt        ! tracer fields
+      REAL(wp), DIMENSION(jpi,jpj), INTENT(  out) ::   pt_v      ! tracer at v-point 
+      !
+      INTEGER  ::   ji, jj       ! dummy loop indices
+      REAL(wp) ::   zcv, zdy2, zdy4    !   -      -
+      REAL(wp), DIMENSION(jpi,jpj) :: ztv1, ztv2, ztv3, ztv4
+      !!----------------------------------------------------------------------
+      !
+      !                                                     !--  Laplacian in j-direction  --!
+      DO jj = 1, jpjm1         ! First derivative (gradient)
+         DO ji = fs_2, fs_jpim1
+            ztv1(ji,jj) = ( pt(ji,jj+1) - pt(ji,jj) ) * r1_e2v(ji,jj) * vmask(ji,jj,1)
+         END DO
+      END DO
+      DO jj = 2, jpjm1         ! Second derivative (Laplacian)
+         DO ji = fs_2, fs_jpim1
+            ztv2(ji,jj) = ( ztv1(ji,jj) - ztv1(ji,jj-1) ) * r1_e2t(ji,jj)
+         END DO
+      END DO
+      CALL lbc_lnk( ztv2, 'T', 1. )
+      !
+      !                                                     !--  BiLaplacian in j-direction  --!
+      DO jj = 1, jpjm1         ! First derivative
+         DO ji = fs_2, fs_jpim1
+            ztv3(ji,jj) = ( ztv2(ji,jj+1) - ztv2(ji,jj) ) * r1_e2v(ji,jj) * vmask(ji,jj,1)
+         END DO
+      END DO
+      DO jj = 2, jpjm1         ! Second derivative
+         DO ji = fs_2, fs_jpim1
+            ztv4(ji,jj) = ( ztv3(ji,jj) - ztv3(ji,jj-1) ) * r1_e2t(ji,jj)
+         END DO
+      END DO
+      CALL lbc_lnk( ztv4, 'T', 1. )
+      !
+      !
+      SELECT CASE (k_order )
+      !
+      CASE( 1 )                                                !==  1st order central TIM  ==! (Eq. 21)
+         DO jj = 1, jpjm1
+            DO ji = fs_2, fs_jpim1
+               pt_v(ji,jj) = 0.5_wp * vmask(ji,jj,1) * (                              ( pt(ji,jj+1) + pt(ji,jj) )  &
+                  &                                     - SIGN( 1._wp, pvc(ji,jj) ) * ( pt(ji,jj+1) - pt(ji,jj) ) )
+            END DO
+         END DO
+         !
+      CASE( 2 )                                                !==  2nd order central TIM  ==! (Eq. 23)
+         DO jj = 1, jpjm1
+            DO ji = fs_2, fs_jpim1
+               zcv  = pvc(ji,jj) * r1_e1v(ji,jj) * pdt * r1_e2v(ji,jj)
+               pt_v(ji,jj) = 0.5_wp * vmask(ji,jj,1) * (        ( pt(ji,jj+1) + pt(ji,jj) )  &
+                  &                                     - zcv * ( pt(ji,jj+1) - pt(ji,jj) ) )
+            END DO
+         END DO
+         CALL lbc_lnk( pt_v, 'V',  1. )
+         !
+      CASE( 3 )                                                !==  3rd order central TIM  ==! (Eq. 24)
+         DO jj = 1, jpjm1
+            DO ji = fs_2, fs_jpim1
+               zcv  = pvc(ji,jj) * r1_e1v(ji,jj) * pdt * r1_e2v(ji,jj)
+               zdy2 = e2v(ji,jj) * e2v(ji,jj)
+!!rachid       zdy2 = e2v(ji,jj) * e2t(ji,jj)
+               pt_v(ji,jj) = 0.5_wp * vmask(ji,jj,1) * (                                 ( pt  (ji,jj+1) + pt  (ji,jj)       &
+                  &                                     -                        zcv   * ( pt  (ji,jj+1) - pt  (ji,jj) ) )   &
+                  &        + z1_6 * zdy2 * ( zcv*zcv - 1._wp ) * (                         ztv2(ji,jj+1) + ztv2(ji,jj)       &
+                  &                                               - SIGN( 1._wp, zcv ) * ( ztv2(ji,jj+1) - ztv2(ji,jj) ) ) )
+            END DO
+         END DO
+         !
+      CASE( 4 )                                                !==  4th order central TIM  ==! (Eq. 27)
+         DO jj = 1, jpjm1
+            DO ji = fs_2, fs_jpim1
+               zcv  = pvc(ji,jj) * r1_e1v(ji,jj) * pdt * r1_e2v(ji,jj)
+               zdy2 = e2v(ji,jj) * e2v(ji,jj)
+!!rachid       zdy2 = e2v(ji,jj) * e2t(ji,jj)
+               pt_v(ji,jj) = 0.5_wp * vmask(ji,jj,1) * (                           ( pt  (ji,jj+1) + pt  (ji,jj)       &
+                  &                                               -          zcv * ( pt  (ji,jj+1) - pt  (ji,jj) ) )   &
+                  &        + z1_6 * zdy2 * ( zcv*zcv - 1._wp ) * (                   ztv2(ji,jj+1) + ztv2(ji,jj)       &
+                  &                                               - 0.5_wp * zcv * ( ztv2(ji,jj+1) - ztv2(ji,jj) ) ) )
+            END DO
+         END DO
+         !
+      CASE( 5 )                                                !==  5th order central TIM  ==! (Eq. 29)
+         DO jj = 1, jpjm1
+            DO ji = fs_2, fs_jpim1
+               zcv  = pvc(ji,jj) * r1_e1v(ji,jj) * pdt * r1_e2v(ji,jj)
+               zdy2 = e2v(ji,jj) * e2v(ji,jj)
+!!rachid       zdy2 = e2v(ji,jj) * e2t(ji,jj)
+               zdy4 = zdy2 * zdy2
+               pt_v(ji,jj) = 0.5_wp * vmask(ji,jj,1) * (                                 ( pt  (ji,jj+1) + pt  (ji,jj)      &
+                  &                                                     -          zcv * ( pt  (ji,jj+1) - pt  (ji,jj) ) )  &
+                  &        + z1_6   * zdy2 * ( zcv*zcv - 1._wp ) *     (                   ztv2(ji,jj+1) + ztv2(ji,jj)      &
+                  &                                                     - 0.5_wp * zcv * ( ztv2(ji,jj+1) - ztv2(ji,jj) ) )  &
+                  &        + z1_120 * zdy4 * ( zcv*zcv - 1._wp ) * ( zcv*zcv - 4._wp ) * ( ztv4(ji,jj+1) + ztv4(ji,jj)      &
+                  &                                               - SIGN( 1._wp, zcv ) * ( ztv4(ji,jj+1) - ztv4(ji,jj) ) ) )
+            END DO
+         END DO
+         !
+      END SELECT
+      !
+   END SUBROUTINE ultimate_y
+   
+  
+   SUBROUTINE nonosc_2d( pbef, paa, pbb, paft, pdt )
+      !!---------------------------------------------------------------------
+      !!                    ***  ROUTINE nonosc  ***
+      !!     
+      !! **  Purpose :   compute monotonic tracer fluxes from the upstream 
+      !!       scheme and the before field by a nonoscillatory algorithm 
+      !!
+      !! **  Method  :   ... ???
+      !!       warning : pbef and paft must be masked, but the boundaries
+      !!       conditions on the fluxes are not necessary zalezak (1979)
+      !!       drange (1995) multi-dimensional forward-in-time and upstream-
+      !!       in-space based differencing for fluid
+      !!----------------------------------------------------------------------
+      REAL(wp)                     , INTENT(in   ) ::   pdt          ! tracer time-step
+      REAL(wp), DIMENSION (jpi,jpj), INTENT(in   ) ::   pbef, paft   ! before & after field
+      REAL(wp), DIMENSION (jpi,jpj), INTENT(inout) ::   paa, pbb     ! monotonic fluxes in the 2 directions
+      !
+      INTEGER  ::   ji, jj    ! dummy loop indices
+      INTEGER  ::   ikm1      ! local integer
+      REAL(wp) ::   zpos, zneg, zbt, za, zb, zc, zbig, zsml, z1_dt   ! local scalars
+      REAL(wp) ::   zau, zbu, zcu, zav, zbv, zcv, zup, zdo            !   -      -
+      REAL(wp), DIMENSION(jpi,jpj) :: zbetup, zbetdo, zbup, zbdo, zmsk, zdiv
+      !!----------------------------------------------------------------------
+      !
+      zbig = 1.e+40_wp
+      zsml = 1.e-15_wp
+
+      ! test on divergence
+      DO jj = 2, jpjm1
+         DO ji = fs_2, fs_jpim1   ! vector opt.  
+            zdiv(ji,jj) =  - (  paa(ji,jj) - paa(ji-1,jj  )   &
+               &              + pbb(ji,jj) - pbb(ji  ,jj-1) )  
+         END DO
+      END DO
+      CALL lbc_lnk( zdiv, 'T', 1. )        ! Lateral boundary conditions   (unchanged sign)
+
+      ! Determine ice masks for before and after tracers 
+      WHERE( pbef(:,:) == 0._wp .AND. paft(:,:) == 0._wp .AND. zdiv(:,:) == 0._wp )   ;   zmsk(:,:) = 0._wp
+      ELSEWHERE                                                                       ;   zmsk(:,:) = 1._wp * tmask(:,:,1)
+      END WHERE
+
+      ! Search local extrema
+      ! --------------------
+      ! max/min of pbef & paft with large negative/positive value (-/+zbig) inside land
+!      zbup(:,:) = MAX( pbef(:,:) * tmask(:,:,1) - zbig * ( 1.e0 - tmask(:,:,1) ),   &
+!         &             paft(:,:) * tmask(:,:,1) - zbig * ( 1.e0 - tmask(:,:,1) )  )
+!      zbdo(:,:) = MIN( pbef(:,:) * tmask(:,:,1) + zbig * ( 1.e0 - tmask(:,:,1) ),   &
+!         &             paft(:,:) * tmask(:,:,1) + zbig * ( 1.e0 - tmask(:,:,1) )  )
+      zbup(:,:) = MAX( pbef(:,:) * zmsk(:,:) - zbig * ( 1.e0 - zmsk(:,:) ),   &
+         &             paft(:,:) * zmsk(:,:) - zbig * ( 1.e0 - zmsk(:,:) )  )
+      zbdo(:,:) = MIN( pbef(:,:) * zmsk(:,:) + zbig * ( 1.e0 - zmsk(:,:) ),   &
+         &             paft(:,:) * zmsk(:,:) + zbig * ( 1.e0 - zmsk(:,:) )  )
+
+      z1_dt = 1._wp / pdt
+      DO jj = 2, jpjm1
+         DO ji = fs_2, fs_jpim1   ! vector opt.
+            !
+            zup  = MAX(   zbup(ji,jj), zbup(ji-1,jj  ), zbup(ji+1,jj  ),   &        ! search max/min in neighbourhood
+               &                       zbup(ji  ,jj-1), zbup(ji  ,jj+1)    )
+            zdo  = MIN(   zbdo(ji,jj), zbdo(ji-1,jj  ), zbdo(ji+1,jj  ),   &
+               &                       zbdo(ji  ,jj-1), zbdo(ji  ,jj+1)    )
+               !
+            zpos = MAX( 0., paa(ji-1,jj  ) ) - MIN( 0., paa(ji  ,jj  ) )   &        ! positive/negative  part of the flux
+               & + MAX( 0., pbb(ji  ,jj-1) ) - MIN( 0., pbb(ji  ,jj  ) )
+            zneg = MAX( 0., paa(ji  ,jj  ) ) - MIN( 0., paa(ji-1,jj  ) )   &
+               & + MAX( 0., pbb(ji  ,jj  ) ) - MIN( 0., pbb(ji  ,jj-1) )
+               !
+            zbt = e1e2t(ji,jj) * z1_dt                                   ! up & down beta terms
+            zbetup(ji,jj) = ( zup         - paft(ji,jj) ) / ( zpos + zsml ) * zbt
+            zbetdo(ji,jj) = ( paft(ji,jj) - zdo         ) / ( zneg + zsml ) * zbt
+         END DO
+      END DO
+      CALL lbc_lnk_multi( zbetup, 'T', 1., zbetdo, 'T', 1. )   ! lateral boundary cond. (unchanged sign)
+
+      ! monotonic flux in the i & j direction (paa & pbb)
+      ! -------------------------------------
+      DO jj = 2, jpjm1
+         DO ji = 1, fs_jpim1   ! vector opt.
+            zau = MIN( 1._wp , zbetdo(ji,jj) , zbetup(ji+1,jj) )
+            zbu = MIN( 1._wp , zbetup(ji,jj) , zbetdo(ji+1,jj) )
+            zcu = 0.5  + SIGN( 0.5 , paa(ji,jj) )
+            !
+            paa(ji,jj) = paa(ji,jj) * ( zcu * zau + ( 1._wp - zcu) * zbu )
+         END DO
+      END DO
+      !
+      DO jj = 1, jpjm1
+         DO ji = fs_2, fs_jpim1   ! vector opt.
+            zav = MIN( 1._wp , zbetdo(ji,jj) , zbetup(ji,jj+1) )
+            zbv = MIN( 1._wp , zbetup(ji,jj) , zbetdo(ji,jj+1) )
+            zcv = 0.5  + SIGN( 0.5 , pbb(ji,jj) )
+            !
+            pbb(ji,jj) = pbb(ji,jj) * ( zcv * zav + ( 1._wp - zcv) * zbv )
+         END DO
+      END DO
+      !
+   END SUBROUTINE nonosc_2d
+
+#else
+   !!----------------------------------------------------------------------
+   !!   Default option           Dummy module         NO SI3 sea-ice model
+   !!----------------------------------------------------------------------
+#endif
+
+   !!======================================================================
+END MODULE icedyn_adv_umx
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/ICE_SRC/icedyn_rdgrft.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/ICE_SRC/icedyn_rdgrft.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/ICE_SRC/icedyn_rdgrft.F90	(revision 9570)
@@ -0,0 +1,961 @@
+MODULE icedyn_rdgrft
+   !!======================================================================
+   !!                       ***  MODULE icedyn_rdgrft ***
+   !!    sea-ice : Mechanical impact on ice thickness distribution      
+   !!======================================================================
+   !! History :  LIM  ! 2006-02  (M. Vancoppenolle) Original code 
+   !!            3.2  ! 2009-07  (M. Vancoppenolle, Y. Aksenov, G. Madec) bug correction in smsw & sfx_dyn
+   !!            4.0  ! 2011-02  (G. Madec) dynamical allocation
+   !!----------------------------------------------------------------------
+#if defined key_si3
+   !!----------------------------------------------------------------------
+   !!   'key_si3'                                       SI3 sea-ice model
+   !!----------------------------------------------------------------------
+   !!   ice_dyn_rdgrft       : ridging/rafting of sea ice
+   !!   ice_dyn_rdgrft_init  : initialization of ridging/rafting of sea ice
+   !!   ice_strength         : ice strength calculation
+   !!----------------------------------------------------------------------
+   USE dom_oce        ! ocean domain
+   USE phycst         ! physical constants (ocean directory) 
+   USE sbc_oce , ONLY : sss_m, sst_m   ! surface boundary condition: ocean fields
+   USE ice1D          ! sea-ice: thermodynamics
+   USE ice            ! sea-ice: variables
+   USE icetab         ! sea-ice: 1D <==> 2D transformation
+   USE icevar         ! sea-ice: operations
+   USE icectl         ! sea-ice: control prints
+   !
+   USE in_out_manager ! I/O manager
+   USE iom            ! I/O manager library
+   USE lib_mpp        ! MPP library
+   USE lib_fortran    ! fortran utilities (glob_sum + no signed zero)
+   USE lbclnk         ! lateral boundary conditions (or mpp links)
+   USE timing         ! Timing
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   ice_dyn_rdgrft        ! called by icestp
+   PUBLIC   ice_dyn_rdgrft_init   ! called by icedyn
+   PUBLIC   ice_strength          ! called by icedyn_rhg_evp
+
+   ! Variables shared among ridging subroutines
+   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) ::   closing_net     ! net rate at which area is removed    (1/s)
+      !                                                 ! (ridging ice area - area of new ridges) / dt
+   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:)   ::   opning         ! rate of opening due to divergence/shear
+   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:)   ::   closing_gross  ! rate at which area removed, not counting area of new ridges
+   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   apartf   ! participation function; fraction of ridging/closing associated w/ category n
+   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hrmin    ! minimum ridge thickness
+   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hrmax    ! maximum ridge thickness
+   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hraft    ! thickness of rafted ice
+   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hi_hrdg  ! thickness of ridging ice / mean ridge thickness
+   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   aridge   ! participating ice ridging
+   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   araft    ! participating ice rafting
+   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   ze_i_2d
+   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   ze_s_2d
+   !
+   REAL(wp), PARAMETER ::   hrdg_hi_min = 1.1_wp    ! min ridge thickness multiplier: min(hrdg/hi)
+   REAL(wp), PARAMETER ::   hi_hrft     = 0.5_wp    ! rafting multipliyer: (hi/hraft)
+   !
+   ! ** namelist (namdyn_rdgrft) **
+   LOGICAL  ::   ln_str_H79       ! ice strength parameterization (Hibler79)
+   REAL(wp) ::   rn_pstar         ! determines ice strength, Hibler JPO79
+   REAL(wp) ::   rn_crhg          ! determines changes in ice strength
+   REAL(wp) ::   rn_csrdg         ! fraction of shearing energy contributing to ridging            
+   LOGICAL  ::   ln_partf_lin     ! participation function linear (Thorndike et al. (1975))
+   REAL(wp) ::   rn_gstar         !    fractional area of young ice contributing to ridging
+   LOGICAL  ::   ln_partf_exp     ! participation function exponential (Lipscomb et al. (2007))
+   REAL(wp) ::   rn_astar         !    equivalent of G* for an exponential participation function
+   LOGICAL  ::   ln_ridging       ! ridging of ice or not                        
+   REAL(wp) ::   rn_hstar         !    thickness that determines the maximal thickness of ridged ice
+   REAL(wp) ::   rn_porordg       !    initial porosity of ridges (0.3 regular value)
+   REAL(wp) ::   rn_fsnwrdg       !    fractional snow loss to the ocean during ridging
+   REAL(wp) ::   rn_fpndrdg       !    fractional pond loss to the ocean during ridging
+   LOGICAL  ::   ln_rafting       ! rafting of ice or not                        
+   REAL(wp) ::   rn_hraft         !    threshold thickness (m) for rafting / ridging 
+   REAL(wp) ::   rn_craft         !    coefficient for smoothness of the hyperbolic tangent in rafting
+   REAL(wp) ::   rn_fsnwrft       !    fractional snow loss to the ocean during rafting
+   REAL(wp) ::   rn_fpndrft       !    fractional pond loss to the ocean during rafting
+   !
+   !!----------------------------------------------------------------------
+   !! NEMO/ICE 4.0 , NEMO Consortium (2017)
+   !! $Id: icedyn_rdgrft.F90 8378 2017-07-26 13:55:59Z clem $
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   INTEGER FUNCTION ice_dyn_rdgrft_alloc()
+      !!-------------------------------------------------------------------
+      !!                ***  ROUTINE ice_dyn_rdgrft_alloc ***
+      !!-------------------------------------------------------------------
+      ALLOCATE( closing_net(jpij), opning(jpij)   , closing_gross(jpij),   &
+         &      apartf(jpij,0:jpl), hrmin(jpij,jpl), hraft(jpij,jpl)    , aridge(jpij,jpl),   &
+         &      hrmax(jpij,jpl), hi_hrdg(jpij,jpl)  , araft (jpij,jpl),  &
+         &      ze_i_2d(jpij,nlay_i,jpl), ze_s_2d(jpij,nlay_s,jpl), STAT=ice_dyn_rdgrft_alloc )
+
+      IF( lk_mpp                    )   CALL mpp_sum ( ice_dyn_rdgrft_alloc )
+      IF( ice_dyn_rdgrft_alloc /= 0 )   CALL ctl_warn( 'ice_dyn_rdgrft_alloc: failed to allocate arrays' )
+      !
+   END FUNCTION ice_dyn_rdgrft_alloc
+
+
+   SUBROUTINE ice_dyn_rdgrft( kt )
+      !!-------------------------------------------------------------------
+      !!                ***  ROUTINE ice_dyn_rdgrft ***
+      !!
+      !! ** Purpose :   computes the mechanical redistribution of ice thickness
+      !!
+      !! ** Method  :   Steps :
+      !!       0) Identify grid cells with ice
+      !!       1) Calculate closing rate, divergence and opening
+      !!       2) Identify grid cells with ridging
+      !!       3) Start ridging iterations
+      !!          - prep = ridged and rafted ice + closing_gross
+      !!          - shift = move ice from one category to another
+      !!
+      !! ** Details
+      !!    step1: The net rate of closing is due to convergence and shear, based on Flato and Hibler (1995).
+      !!           The energy dissipation rate is equal to the net closing rate times the ice strength.
+      !!
+      !!    step3: The gross closing rate is equal to the first two terms (open
+      !!           water closing and thin ice ridging) without the third term
+      !!           (thick, newly ridged ice).
+      !!
+      !! References :   Flato, G. M., and W. D. Hibler III, 1995, JGR, 100, 18,611-18,626.
+      !!                Hibler, W. D. III, 1980, MWR, 108, 1943-1973, 1980.
+      !!                Rothrock, D. A., 1975: JGR, 80, 4514-4519.
+      !!                Thorndike et al., 1975, JGR, 80, 4501-4513. 
+      !!                Bitz et al., JGR, 2001
+      !!                Amundrud and Melling, JGR 2005
+      !!                Babko et al., JGR 2002 
+      !!
+      !!     This routine is based on CICE code and authors William H. Lipscomb,
+      !!     and Elizabeth C. Hunke, LANL are gratefully acknowledged
+      !!-------------------------------------------------------------------
+      INTEGER, INTENT(in) ::   kt     ! number of iteration
+      !!
+      INTEGER  ::   ji, jj, jk, jl             ! dummy loop index
+      INTEGER  ::   iter, iterate_ridging      ! local integer 
+      INTEGER  ::   ipti                       ! local integer
+      REAL(wp) ::   zfac                       ! local scalar
+      INTEGER , DIMENSION(jpij) ::   iptidx        ! compute ridge/raft or not
+      REAL(wp), DIMENSION(jpij) ::   zdivu_adv     ! divu as implied by transport scheme  (1/s)
+      REAL(wp), DIMENSION(jpij) ::   zdivu, zdelt  ! 1D divu_i & delta_i
+      !
+      INTEGER, PARAMETER ::   jp_itermax = 20    
+      !!-------------------------------------------------------------------
+      ! controls
+      IF( ln_timing    )   CALL timing_start('icedyn_rdgrft')                                                             ! timing
+      IF( ln_icediachk )   CALL ice_cons_hsm(0, 'icedyn_rdgrft', rdiag_v, rdiag_s, rdiag_t, rdiag_fv, rdiag_fs, rdiag_ft) ! conservation
+
+      IF( kt == nit000 ) THEN
+         IF(lwp) WRITE(numout,*)
+         IF(lwp) WRITE(numout,*)'ice_dyn_rdgrft: ice ridging and rafting'
+         IF(lwp) WRITE(numout,*)'~~~~~~~~~~~~~~'
+      ENDIF      
+
+      CALL ice_var_zapsmall   ! Zero out categories with very small areas
+
+      !--------------------------------
+      ! 0) Identify grid cells with ice
+      !--------------------------------
+      npti = 0   ;   nptidx(:) = 0
+      ipti = 0   ;   iptidx(:) = 0
+      DO jj = 1, jpj
+         DO ji = 1, jpi
+            IF ( at_i(ji,jj) > 0._wp ) THEN
+               npti           = npti + 1
+               nptidx( npti ) = (jj - 1) * jpi + ji
+            ENDIF
+         END DO
+      END DO
+      
+      !--------------------------------------------------------
+      ! 1) Dynamical inputs (closing rate, divergence, opening)
+      !--------------------------------------------------------
+      IF( npti > 0 ) THEN
+        
+         ! just needed here
+         CALL tab_2d_1d( npti, nptidx(1:npti), zdivu(1:npti), divu_i(:,:) )
+         CALL tab_2d_1d( npti, nptidx(1:npti), zdelt(1:npti), delta_i(:,:) )
+         ! needed here and in the iteration loop
+         CALL tab_3d_2d( npti, nptidx(1:npti), a_i_2d  (1:npti,1:jpl), a_i(:,:,:) )
+         CALL tab_3d_2d( npti, nptidx(1:npti), v_i_2d  (1:npti,1:jpl), v_i(:,:,:) )
+         CALL tab_2d_1d( npti, nptidx(1:npti), ato_i_1d(1:npti)      , ato_i(:,:) )
+
+         DO ji = 1, npti
+            ! closing_net = rate at which open water area is removed + ice area removed by ridging 
+            !                                                        - ice area added in new ridges
+            closing_net(ji) = rn_csrdg * 0.5_wp * ( zdelt(ji) - ABS( zdivu(ji) ) ) - MIN( zdivu(ji), 0._wp )
+            !
+            ! divergence given by the advection scheme
+            !   (which may not be equal to divu as computed from the velocity field)
+            zdivu_adv(ji) = ( 1._wp - ato_i_1d(ji) - SUM( a_i_2d(ji,:) ) ) * r1_rdtice
+            !
+            IF( zdivu_adv(ji) < 0._wp )   closing_net(ji) = MAX( closing_net(ji), -zdivu_adv(ji) )   ! make sure the closing rate is large enough
+            !                                                                                        ! to give asum = 1.0 after ridging
+            ! Opening rate (non-negative) that will give asum = 1.0 after ridging.
+            opning(ji) = closing_net(ji) + zdivu_adv(ji)
+         END DO
+         !
+         !------------------------------------
+         ! 2) Identify grid cells with ridging
+         !------------------------------------
+         CALL rdgrft_prep( a_i_2d, v_i_2d, ato_i_1d, closing_net )
+
+         DO ji = 1, npti
+            IF( SUM( apartf(ji,1:jpl) ) > 0._wp .AND. closing_gross(ji) > 0._wp ) THEN
+               ipti = ipti + 1
+               iptidx     (ipti)   = nptidx     (ji)
+               ! adjust to new indices
+               a_i_2d     (ipti,:) = a_i_2d     (ji,:)
+               v_i_2d     (ipti,:) = v_i_2d     (ji,:)
+               ato_i_1d   (ipti)   = ato_i_1d   (ji)
+               closing_net(ipti)   = closing_net(ji)
+               zdivu_adv  (ipti)   = zdivu_adv  (ji)
+               opning     (ipti)   = opning     (ji)
+            ENDIF
+         END DO
+
+      ENDIF
+
+      ! grid cells with ridging
+      nptidx(:) = iptidx(:)
+      npti      = ipti
+
+      !-----------------
+      ! 3) Start ridging
+      !-----------------
+      IF( npti > 0 ) THEN
+         
+         CALL ice_dyn_1d2d( 1 )            ! --- Move to 1D arrays --- !
+
+         iter            = 1
+         iterate_ridging = 1      
+         !                                                        !----------------------!
+         DO WHILE( iterate_ridging > 0 .AND. iter < jp_itermax )  !  ridging iterations  !
+            !                                                     !----------------------!
+            ! Calculate participation function (apartf)
+            !       and transfer      function
+            !       and closing_gross (+correction on opening)
+            CALL rdgrft_prep( a_i_2d, v_i_2d, ato_i_1d, closing_net )
+
+            ! Redistribute area, volume, and energy between categories
+            CALL rdgrft_shift
+
+            ! Do we keep on iterating?
+            !-------------------------
+            ! Check whether a_i + ato_i = 0
+            ! If not, because the closing and opening rates were reduced above, ridge again with new rates
+            iterate_ridging = 0
+            DO ji = 1, npti
+               zfac = 1._wp - ( ato_i_1d(ji) + SUM( a_i_2d(ji,:) ) )
+               IF( ABS( zfac ) < epsi10 ) THEN
+                  closing_net(ji) = 0._wp
+                  opning     (ji) = 0._wp
+                  ato_i_1d   (ji) = MAX( 0._wp, 1._wp - SUM( a_i_2d(ji,:) ) )
+               ELSE
+                  iterate_ridging  = 1
+                  zdivu_adv  (ji) = zfac * r1_rdtice
+                  closing_net(ji) = MAX( 0._wp, -zdivu_adv(ji) )
+                  opning     (ji) = MAX( 0._wp,  zdivu_adv(ji) )
+               ENDIF
+            END DO
+            !
+            iter = iter + 1
+            IF( iter  >  jp_itermax )    CALL ctl_warn( 'icedyn_rdgrft: non-converging ridging scheme' )
+            !
+         END DO
+
+         CALL ice_dyn_1d2d( 2 )            ! --- Move to 2D arrays --- !
+
+      ENDIF
+   
+      CALL ice_var_agg( 1 ) 
+
+      ! controls
+      IF( ln_icediachk )   CALL ice_cons_hsm(1, 'icedyn_rdgrft', rdiag_v, rdiag_s, rdiag_t, rdiag_fv, rdiag_fs, rdiag_ft) ! conservation
+      IF( ln_ctl       )   CALL ice_prt3D   ('icedyn_rdgrft')                                                             ! prints
+      IF( ln_timing    )   CALL timing_stop ('icedyn_rdgrft')                                                             ! timing
+      !
+   END SUBROUTINE ice_dyn_rdgrft
+
+
+   SUBROUTINE rdgrft_prep( pa_i, pv_i, pato_i, pclosing_net )
+      !!-------------------------------------------------------------------
+      !!                ***  ROUTINE rdgrft_prep ***
+      !!
+      !! ** Purpose :   preparation for ridging calculations
+      !!
+      !! ** Method  :   Compute the thickness distribution of the ice and open water 
+      !!                participating in ridging and of the resulting ridges.
+      !!-------------------------------------------------------------------
+      REAL(wp), DIMENSION(:)  , INTENT(in) ::   pato_i, pclosing_net 
+      REAL(wp), DIMENSION(:,:), INTENT(in) ::   pa_i, pv_i 
+      !!
+      INTEGER  ::   ji, jl                     ! dummy loop indices
+      REAL(wp) ::   z1_gstar, z1_astar, zhmean, zfac   ! local scalar
+      REAL(wp), DIMENSION(jpij)        ::   zasum, z1_asum, zaksum   ! sum of a_i+ato_i and reverse 
+      REAL(wp), DIMENSION(jpij,jpl)    ::   zhi                      ! ice thickness
+      REAL(wp), DIMENSION(jpij,-1:jpl) ::   zGsum                    ! zGsum(n) = sum of areas in categories 0 to n
+      !--------------------------------------------------------------------
+
+      z1_gstar = 1._wp / rn_gstar
+      z1_astar = 1._wp / rn_astar
+
+      !                       ! Ice thickness needed for rafting
+      WHERE( pa_i(1:npti,:) > 0._wp )   ;   zhi(1:npti,:) = pv_i(1:npti,:) / pa_i(1:npti,:)
+      ELSEWHERE                         ;   zhi(1:npti,:) = 0._wp
+      END WHERE
+
+      ! 1) Participation function (apartf): a(h) = b(h).g(h)
+      !-----------------------------------------------------------------
+      ! Compute the participation function = total area lost due to ridging/closing
+      ! This is analogous to
+      !   a(h) = b(h)g(h) as defined in Thorndike et al. (1975).
+      !   assuming b(h) = (2/Gstar) * (1 - G(h)/Gstar). 
+      !
+      ! apartf = integrating b(h)g(h) between the category boundaries
+      ! apartf is always >= 0 and SUM(apartf(0:jpl))=1
+      !-----------------------------------------------------------------
+      !
+      ! Compute total area of ice plus open water.
+      ! This is in general not equal to one because of divergence during transport
+      zasum(1:npti) = pato_i(1:npti) + SUM( pa_i(1:npti,:), dim=2 )
+      !
+      WHERE( zasum(1:npti) > 0._wp )   ;   z1_asum(1:npti) = 1._wp / zasum(1:npti)
+      ELSEWHERE                        ;   z1_asum(1:npti) = 0._wp
+      END WHERE
+      !
+      ! Compute cumulative thickness distribution function
+      ! Compute the cumulative thickness distribution function zGsum,
+      ! where zGsum(n) is the fractional area in categories 0 to n.
+      ! initial value (in h = 0) = open water area
+      zGsum(1:npti,-1) = 0._wp
+      zGsum(1:npti,0 ) = pato_i(1:npti) * z1_asum(1:npti)
+      DO jl = 1, jpl
+         zGsum(1:npti,jl) = ( pato_i(1:npti) + SUM( pa_i(1:npti,1:jl), dim=2 ) ) * z1_asum(1:npti)  ! sum(1:jl) is ok (and not jpl)
+      END DO
+      !
+      IF( ln_partf_lin ) THEN          !--- Linear formulation (Thorndike et al., 1975)
+         DO jl = 0, jpl    
+            DO ji = 1, npti
+               IF    ( zGsum(ji,jl)   < rn_gstar ) THEN
+                  apartf(ji,jl) = z1_gstar * ( zGsum(ji,jl) - zGsum(ji,jl-1) ) * &
+                     &                       ( 2._wp - ( zGsum(ji,jl-1) + zGsum(ji,jl) ) * z1_gstar )
+               ELSEIF( zGsum(ji,jl-1) < rn_gstar ) THEN
+                  apartf(ji,jl) = z1_gstar * ( rn_gstar     - zGsum(ji,jl-1) ) *  &
+                     &                       ( 2._wp - ( zGsum(ji,jl-1) + rn_gstar        ) * z1_gstar )
+               ELSE
+                  apartf(ji,jl) = 0._wp
+               ENDIF
+            END DO
+         END DO
+         !
+      ELSEIF( ln_partf_exp ) THEN      !--- Exponential, more stable formulation (Lipscomb et al, 2007)
+         !                        
+         zfac = 1._wp / ( 1._wp - EXP(-z1_astar) )
+         DO jl = -1, jpl
+            DO ji = 1, npti
+               zGsum(ji,jl) = EXP( -zGsum(ji,jl) * z1_astar ) * zfac
+            END DO
+         END DO
+         DO jl = 0, jpl
+            DO ji = 1, npti
+               apartf(ji,jl) = zGsum(ji,jl-1) - zGsum(ji,jl)
+            END DO
+         END DO
+         !
+      ENDIF
+
+      !                                !--- Ridging and rafting participation concentrations
+      IF( ln_rafting .AND. ln_ridging ) THEN             !- ridging & rafting
+         DO jl = 1, jpl
+            DO ji = 1, npti
+               aridge(ji,jl) = ( 1._wp + TANH ( rn_craft * ( zhi(ji,jl) - rn_hraft ) ) ) * 0.5_wp * apartf(ji,jl)
+               araft (ji,jl) = apartf(ji,jl) - aridge(ji,jl)
+            END DO
+         END DO
+      ELSEIF( ln_ridging .AND. .NOT. ln_rafting ) THEN   !- ridging alone
+         DO jl = 1, jpl
+            DO ji = 1, npti
+               aridge(ji,jl) = apartf(ji,jl)
+               araft (ji,jl) = 0._wp
+            END DO
+         END DO
+      ELSEIF( ln_rafting .AND. .NOT. ln_ridging ) THEN   !- rafting alone   
+         DO jl = 1, jpl
+            DO ji = 1, npti
+               aridge(ji,jl) = 0._wp
+               araft (ji,jl) = apartf(ji,jl)
+            END DO
+         END DO
+      ELSE                                               !- no ridging & no rafting
+         DO jl = 1, jpl
+            DO ji = 1, npti
+               aridge(ji,jl) = 0._wp
+               araft (ji,jl) = 0._wp         
+            END DO
+         END DO
+      ENDIF
+
+      ! 2) Transfer function
+      !-----------------------------------------------------------------
+      ! Compute max and min ridged ice thickness for each ridging category.
+      ! Assume ridged ice is uniformly distributed between hrmin and hrmax.
+      ! 
+      ! This parameterization is a modified version of Hibler (1980).
+      ! The mean ridging thickness, zhmean, is proportional to hi^(0.5)
+      !  and for very thick ridging ice must be >= hrdg_hi_min*hi
+      !
+      ! The minimum ridging thickness, hrmin, is equal to 2*hi 
+      !  (i.e., rafting) and for very thick ridging ice is
+      !  constrained by hrmin <= (zhmean + hi)/2.
+      ! 
+      ! The maximum ridging thickness, hrmax, is determined by zhmean and hrmin.
+      !
+      ! These modifications have the effect of reducing the ice strength
+      ! (relative to the Hibler formulation) when very thick ice is ridging.
+      !
+      ! zaksum = net area removed/ total area removed
+      ! where total area removed = area of ice that ridges
+      !         net area removed = total area removed - area of new ridges
+      !-----------------------------------------------------------------
+      zfac = 1._wp / hi_hrft
+      zaksum(1:npti) = apartf(1:npti,0)
+      !
+      DO jl = 1, jpl
+         DO ji = 1, npti
+            IF ( apartf(ji,jl) > 0._wp ) THEN
+               zhmean         = MAX( SQRT( rn_hstar * zhi(ji,jl) ), zhi(ji,jl) * hrdg_hi_min )
+               hrmin  (ji,jl) = MIN( 2._wp * zhi(ji,jl), 0.5_wp * ( zhmean + zhi(ji,jl) ) )
+               hrmax  (ji,jl) = 2._wp * zhmean - hrmin(ji,jl)
+               hraft  (ji,jl) = zhi(ji,jl) * zfac
+               hi_hrdg(ji,jl) = zhi(ji,jl) / MAX( zhmean, epsi20 )
+               !
+               ! Normalization factor : zaksum, ensures mass conservation
+               zaksum(ji) = zaksum(ji) + aridge(ji,jl) * ( 1._wp - hi_hrdg(ji,jl) )    &
+                  &                    + araft (ji,jl) * ( 1._wp - hi_hrft )
+            ELSE
+               hrmin  (ji,jl) = 0._wp 
+               hrmax  (ji,jl) = 0._wp 
+               hraft  (ji,jl) = 0._wp 
+               hi_hrdg(ji,jl) = 1._wp
+            ENDIF
+         END DO
+      END DO
+      !
+      ! 3) closing_gross
+      !-----------------
+      ! Based on the ITD of ridging and ridged ice, convert the net closing rate to a gross closing rate.  
+      ! NOTE: 0 < aksum <= 1
+      WHERE( zaksum(1:npti) > 0._wp )   ;   closing_gross(1:npti) = pclosing_net(1:npti) / zaksum(1:npti)
+      ELSEWHERE                         ;   closing_gross(1:npti) = 0._wp
+      END WHERE
+      
+      ! correction to closing rate if excessive ice removal
+      !----------------------------------------------------
+      ! Reduce the closing rate if more than 100% of any ice category would be removed
+      ! Reduce the opening rate in proportion
+      DO jl = 1, jpl
+         DO ji = 1, npti
+            zfac = apartf(ji,jl) * closing_gross(ji) * rdt_ice
+            IF( zfac > pa_i(ji,jl) ) THEN
+               closing_gross(ji) = pa_i(ji,jl) / apartf(ji,jl) * r1_rdtice
+            ENDIF
+         END DO
+      END DO      
+
+      ! 4) correction to opening if excessive open water removal
+      !---------------------------------------------------------
+      ! Reduce the closing rate if more than 100% of the open water would be removed
+      ! Reduce the opening rate in proportion
+      DO ji = 1, npti  
+         zfac = pato_i(ji) + ( opning(ji) - apartf(ji,0) * closing_gross(ji) ) * rdt_ice
+         IF( zfac < 0._wp ) THEN           ! would lead to negative ato_i
+            opning(ji) = apartf(ji,0) * closing_gross(ji) - pato_i(ji) * r1_rdtice 
+         ELSEIF( zfac > zasum(ji) ) THEN   ! would lead to ato_i > asum
+            opning(ji) = apartf(ji,0) * closing_gross(ji) + ( zasum(ji) - pato_i(ji) ) * r1_rdtice 
+         ENDIF
+      END DO
+      !
+   END SUBROUTINE rdgrft_prep
+
+
+   SUBROUTINE rdgrft_shift
+      !!-------------------------------------------------------------------
+      !!                ***  ROUTINE rdgrft_shift ***
+      !!
+      !! ** Purpose :   shift ridging ice among thickness categories of ice thickness
+      !!
+      !! ** Method  :   Remove area, volume, and energy from each ridging category
+      !!                and add to thicker ice categories.
+      !!-------------------------------------------------------------------
+      !
+      INTEGER  ::   ji, jj, jl, jl1, jl2, jk   ! dummy loop indices
+      REAL(wp) ::   hL, hR, farea              ! left and right limits of integration and new area going to jl2
+      REAL(wp) ::   vsw                        ! vol of water trapped into ridges
+      REAL(wp) ::   afrdg, afrft               ! fraction of category area ridged/rafted 
+      REAL(wp)                  ::   airdg1, oirdg1, aprdg1, virdg1, sirdg1
+      REAL(wp)                  ::   airft1, oirft1, aprft1
+      REAL(wp), DIMENSION(jpij) ::   airdg2, oirdg2, aprdg2, virdg2, sirdg2, vsrdg, vprdg  ! area etc of new ridges
+      REAL(wp), DIMENSION(jpij) ::   airft2, oirft2, aprft2, virft , sirft , vsrft, vprft  ! area etc of rafted ice
+      !
+      REAL(wp), DIMENSION(jpij) ::   ersw             ! enth of water trapped into ridges
+      REAL(wp), DIMENSION(jpij) ::   zswitch, fvol    ! new ridge volume going to jl2
+      REAL(wp), DIMENSION(jpij) ::   z1_ai            ! 1 / a
+      !
+      REAL(wp), DIMENSION(jpij,nlay_s) ::   esrft     ! snow energy of rafting ice
+      REAL(wp), DIMENSION(jpij,nlay_i) ::   eirft     ! ice  energy of rafting ice
+      REAL(wp), DIMENSION(jpij,nlay_s) ::   esrdg     ! enth*volume of new ridges      
+      REAL(wp), DIMENSION(jpij,nlay_i) ::   eirdg     ! enth*volume of new ridges
+      !
+      INTEGER , DIMENSION(jpij) ::   itest_rdg, itest_rft   ! test for conservation
+      !!-------------------------------------------------------------------
+
+      ! 1) Change in open water area due to closing and opening
+      !--------------------------------------------------------
+      DO ji = 1, npti
+         ato_i_1d(ji) = MAX( 0._wp, ato_i_1d(ji) + ( opning(ji) - apartf(ji,0) * closing_gross(ji) ) * rdt_ice )
+      END DO
+      
+      ! 2) compute categories in which ice is removed (jl1) 
+      !----------------------------------------------------
+      DO jl1 = 1, jpl
+
+         CALL tab_2d_1d( npti, nptidx(1:npti), s_i_1d(1:npti), s_i(:,:,jl1) )
+
+         DO ji = 1, npti
+
+            IF( apartf(ji,jl1) > 0._wp .AND. closing_gross(ji) > 0._wp ) THEN   ! only if ice is ridging
+
+               z1_ai(ji) = 1._wp / a_i_2d(ji,jl1)
+
+               ! area of ridging / rafting ice (airdg1) and of new ridge (airdg2)
+               airdg1 = aridge(ji,jl1) * closing_gross(ji) * rdt_ice
+               airft1 = araft (ji,jl1) * closing_gross(ji) * rdt_ice
+
+               airdg2(ji) = airdg1 * hi_hrdg(ji,jl1)
+               airft2(ji) = airft1 * hi_hrft
+
+               ! ridging /rafting fractions
+               afrdg = airdg1 * z1_ai(ji)
+               afrft = airft1 * z1_ai(ji)
+
+               ! volume and enthalpy (J/m2, >0) of seawater trapped into ridges
+               vsw = v_i_2d(ji,jl1) * afrdg * rn_porordg
+               ersw(ji) = -rhoic * vsw * rcp * sst_1d(ji)   ! clem: if sst>0, then ersw <0 (is that possible?)
+
+               ! volume etc of ridging / rafting ice and new ridges (vi, vs, sm, oi, es, ei)
+               virdg1     = v_i_2d (ji,jl1)   * afrdg
+               virdg2(ji) = v_i_2d (ji,jl1)   * afrdg * ( 1. + rn_porordg )
+               vsrdg(ji)  = v_s_2d (ji,jl1)   * afrdg
+               sirdg1     = sv_i_2d(ji,jl1)   * afrdg
+               sirdg2(ji) = sv_i_2d(ji,jl1)   * afrdg + vsw * sss_1d(ji)
+               oirdg1     = oa_i_2d(ji,jl1)   * afrdg
+               oirdg2(ji) = oa_i_2d(ji,jl1)   * afrdg * hi_hrdg(ji,jl1) 
+
+               virft(ji)  = v_i_2d (ji,jl1)   * afrft
+               vsrft(ji)  = v_s_2d (ji,jl1)   * afrft
+               sirft(ji)  = sv_i_2d(ji,jl1)   * afrft 
+               oirft1     = oa_i_2d(ji,jl1)   * afrft 
+               oirft2(ji) = oa_i_2d(ji,jl1)   * afrft * hi_hrft 
+
+               IF ( ln_pnd_H12 ) THEN
+                  aprdg1     = a_ip_2d(ji,jl1) * afrdg
+                  aprdg2(ji) = a_ip_2d(ji,jl1) * afrdg * hi_hrdg(ji,jl1)
+                  vprdg (ji) = v_ip_2d(ji,jl1) * afrdg
+                  aprft1     = a_ip_2d(ji,jl1) * afrft
+                  aprft2(ji) = a_ip_2d(ji,jl1) * afrft * hi_hrft
+                  vprft (ji) = v_ip_2d(ji,jl1) * afrft
+               ENDIF
+
+               ! Ice-ocean exchanges associated with ice porosity
+               wfx_dyn_1d(ji) = wfx_dyn_1d(ji) - vsw * rhoic * r1_rdtice   ! increase in ice volume due to seawater frozen in voids
+               sfx_dyn_1d(ji) = sfx_dyn_1d(ji) - vsw * sss_1d(ji) * rhoic * r1_rdtice
+               hfx_dyn_1d(ji) = hfx_dyn_1d(ji) + ersw(ji) * r1_rdtice          ! > 0 [W.m-2] 
+
+               ! Put the snow lost by ridging into the ocean
+               !  Note that esrdg > 0; the ocean must cool to melt snow. If the ocean temp = Tf already, new ice must grow.
+               wfx_snw_dyn_1d(ji) = wfx_snw_dyn_1d(ji) + ( rhosn * vsrdg(ji) * ( 1._wp - rn_fsnwrdg )   &   ! fresh water source for ocean
+                  &                                      + rhosn * vsrft(ji) * ( 1._wp - rn_fsnwrft ) ) * r1_rdtice
+
+               ! Put the melt pond water into the ocean
+               ! clem: I think the following lines must be commented since there
+               !       is no net mass flux between melt ponds and the ocean (see icethd_pnd.F90 for ex.)
+               !IF ( ln_pnd_fwb ) THEN
+               !   wfx_pnd_1d(ji) = wfx_pnd_1d(ji) + ( rhofw * vprdg(ji) * ( 1._wp - rn_fpndrdg )   &        ! fresh water source for ocean
+               !      &                              + rhofw * vprft(ji) * ( 1._wp - rn_fpndrft ) ) * r1_rdtice
+               !ENDIF
+
+               ! virtual salt flux to keep salinity constant
+               IF( nn_icesal /= 2 )  THEN
+                  sirdg2(ji)     = sirdg2(ji)     - vsw * ( sss_1d(ji) - s_i_1d(ji) )        ! ridge salinity = s_i
+                  sfx_bri_1d(ji) = sfx_bri_1d(ji) + sss_1d(ji) * vsw * rhoic * r1_rdtice  &  ! put back sss_m into the ocean
+                     &                            - s_i_1d(ji) * vsw * rhoic * r1_rdtice     ! and get  s_i  from the ocean 
+               ENDIF
+
+               ! Remove area, volume of new ridge to each category jl1
+               !------------------------------------------------------
+               a_i_2d (ji,jl1) = a_i_2d (ji,jl1) - airdg1    - airft1
+               v_i_2d (ji,jl1) = v_i_2d (ji,jl1) - virdg1    - virft(ji)
+               v_s_2d (ji,jl1) = v_s_2d (ji,jl1) - vsrdg(ji) - vsrft(ji)
+               sv_i_2d(ji,jl1) = sv_i_2d(ji,jl1) - sirdg1    - sirft(ji)
+               oa_i_2d(ji,jl1) = oa_i_2d(ji,jl1) - oirdg1    - oirft1
+               IF ( ln_pnd_H12 ) THEN
+                  a_ip_2d(ji,jl1) = a_ip_2d(ji,jl1) - aprdg1    - aprft1
+                  v_ip_2d(ji,jl1) = v_ip_2d(ji,jl1) - vprdg(ji) - vprft(ji)
+               ENDIF
+            ENDIF
+
+         END DO ! ji
+
+         ! special loop for e_s because of layers jk
+         DO jk = 1, nlay_s
+            DO ji = 1, npti
+               IF( apartf(ji,jl1) > 0._wp .AND. closing_gross(ji) > 0._wp ) THEN
+                  ! Compute ridging /rafting fractions
+                  afrdg = aridge(ji,jl1) * closing_gross(ji) * rdt_ice * z1_ai(ji)
+                  afrft = araft (ji,jl1) * closing_gross(ji) * rdt_ice * z1_ai(ji)
+                  ! Compute ridging /rafting ice and new ridges for es
+                  esrdg(ji,jk) = ze_s_2d (ji,jk,jl1) * afrdg
+                  esrft(ji,jk) = ze_s_2d (ji,jk,jl1) * afrft
+                  ! Put the snow lost by ridging into the ocean
+                  hfx_dyn_1d(ji) = hfx_dyn_1d(ji) + ( - esrdg(ji,jk) * ( 1._wp - rn_fsnwrdg )   &                 ! heat sink for ocean (<0, W.m-2)
+                     &                                - esrft(ji,jk) * ( 1._wp - rn_fsnwrft ) ) * r1_rdtice
+                  !
+                  ! Remove energy of new ridge to each category jl1
+                  !-------------------------------------------------
+                  ze_s_2d(ji,jk,jl1) = ze_s_2d(ji,jk,jl1) * ( 1._wp - afrdg - afrft ) 
+               ENDIF
+            END DO
+         END DO
+                  
+         ! special loop for e_i because of layers jk
+         DO jk = 1, nlay_i
+            DO ji = 1, npti
+               IF( apartf(ji,jl1) > 0._wp .AND. closing_gross(ji) > 0._wp ) THEN
+                  ! Compute ridging /rafting fractions
+                  afrdg = aridge(ji,jl1) * closing_gross(ji) * rdt_ice * z1_ai(ji)
+                  afrft = araft (ji,jl1) * closing_gross(ji) * rdt_ice * z1_ai(ji)
+                  ! Compute ridging ice and new ridges for ei
+                  eirdg(ji,jk) = ze_i_2d (ji,jk,jl1) * afrdg + ersw(ji) * r1_nlay_i
+                  eirft(ji,jk) = ze_i_2d (ji,jk,jl1) * afrft
+                  !
+                  ! Remove energy of new ridge to each category jl1
+                  !-------------------------------------------------
+                  ze_i_2d(ji,jk,jl1) = ze_i_2d(ji,jk,jl1) * ( 1._wp - afrdg - afrft ) 
+               ENDIF
+            END DO
+         END DO
+         
+         ! 3) compute categories in which ice is added (jl2) 
+         !--------------------------------------------------
+         itest_rdg(1:npti) = 0
+         itest_rft(1:npti) = 0
+         DO jl2  = 1, jpl 
+            !
+            DO ji = 1, npti
+
+               IF( apartf(ji,jl1) > 0._wp .AND. closing_gross(ji) > 0._wp ) THEN
+
+                  ! Compute the fraction of ridged ice area and volume going to thickness category jl2
+                  IF( hrmin(ji,jl1) <= hi_max(jl2) .AND. hrmax(ji,jl1) > hi_max(jl2-1) ) THEN
+                     hL = MAX( hrmin(ji,jl1), hi_max(jl2-1) )
+                     hR = MIN( hrmax(ji,jl1), hi_max(jl2)   )
+                     farea    = ( hR      - hL      ) / ( hrmax(ji,jl1)                 - hrmin(ji,jl1)                 )
+                     fvol(ji) = ( hR * hR - hL * hL ) / ( hrmax(ji,jl1) * hrmax(ji,jl1) - hrmin(ji,jl1) * hrmin(ji,jl1) )
+                     !
+                     itest_rdg(ji) = 1   ! test for conservation
+                  ELSE
+                     farea    = 0._wp 
+                     fvol(ji) = 0._wp                  
+                  ENDIF
+
+                  ! Compute the fraction of rafted ice area and volume going to thickness category jl2
+                  IF( hraft(ji,jl1) <= hi_max(jl2) .AND. hraft(ji,jl1) >  hi_max(jl2-1) ) THEN
+                     zswitch(ji) = 1._wp
+                     !
+                     itest_rft(ji) = 1   ! test for conservation
+                  ELSE
+                     zswitch(ji) = 0._wp
+                  ENDIF
+                  !
+                  ! Patch to ensure perfect conservation if ice thickness goes mad
+                  ! Sometimes thickness is larger than hi_max(jpl) because of advection scheme (for very small areas)
+                  ! Then ice volume is removed from one category but the ridging/rafting scheme
+                  ! does not know where to move it, leading to a conservation issue.  
+                  IF( itest_rdg(ji) == 0 .AND. jl2 == jpl ) THEN   ;   farea = 1._wp   ;   fvol(ji) = 1._wp   ;   ENDIF
+                  IF( itest_rft(ji) == 0 .AND. jl2 == jpl )      zswitch(ji) = 1._wp
+                  !
+                  ! Add area, volume of new ridge to category jl2
+                  !----------------------------------------------
+                  a_i_2d (ji,jl2) = a_i_2d (ji,jl2) + ( airdg2(ji) * farea    + airft2(ji) * zswitch(ji) )
+                  oa_i_2d(ji,jl2) = oa_i_2d(ji,jl2) + ( oirdg2(ji) * farea    + oirft2(ji) * zswitch(ji) )
+                  v_i_2d (ji,jl2) = v_i_2d (ji,jl2) + ( virdg2(ji) * fvol(ji) + virft (ji) * zswitch(ji) )
+                  sv_i_2d(ji,jl2) = sv_i_2d(ji,jl2) + ( sirdg2(ji) * fvol(ji) + sirft (ji) * zswitch(ji) )
+                  v_s_2d (ji,jl2) = v_s_2d (ji,jl2) + ( vsrdg (ji) * rn_fsnwrdg * fvol(ji)  +  &
+                     &                                  vsrft (ji) * rn_fsnwrft * zswitch(ji) )
+                  IF ( ln_pnd_H12 ) THEN
+                     v_ip_2d (ji,jl2) = v_ip_2d(ji,jl2) + (   vprdg (ji) * rn_fpndrdg * fvol   (ji)   &
+                        &                                   + vprft (ji) * rn_fpndrft * zswitch(ji)   )
+                     a_ip_2d (ji,jl2) = a_ip_2d(ji,jl2) + (   aprdg2(ji) * rn_fpndrdg * farea         & 
+                        &                                   + aprft2(ji) * rn_fpndrft * zswitch(ji)   )
+                  ENDIF
+                  
+               ENDIF
+
+            END DO
+            ! Add snow energy of new ridge to category jl2
+            !---------------------------------------------
+            DO jk = 1, nlay_s
+               DO ji = 1, npti
+                  IF( apartf(ji,jl1) > 0._wp .AND. closing_gross(ji) > 0._wp )   &
+                     &   ze_s_2d(ji,jk,jl2) = ze_s_2d(ji,jk,jl2) + ( esrdg(ji,jk) * rn_fsnwrdg * fvol(ji)  +  &
+                     &                                               esrft(ji,jk) * rn_fsnwrft * zswitch(ji) )
+               END DO
+            END DO
+            ! Add ice energy of new ridge to category jl2
+            !--------------------------------------------
+            DO jk = 1, nlay_i
+               DO ji = 1, npti
+                  IF( apartf(ji,jl1) > 0._wp .AND. closing_gross(ji) > 0._wp )   &
+                     &   ze_i_2d(ji,jk,jl2) = ze_i_2d(ji,jk,jl2) + eirdg(ji,jk) * fvol(ji) + eirft(ji,jk) * zswitch(ji)                  
+               END DO
+            END DO
+            !
+         END DO ! jl2
+         !
+      END DO ! jl1
+      !
+      ! In case ridging/rafting lead to very small negative values (sometimes it happens)
+      WHERE( a_i_2d(1:npti,:) < 0._wp )   a_i_2d(1:npti,:) = 0._wp
+      WHERE( v_i_2d(1:npti,:) < 0._wp )   v_i_2d(1:npti,:) = 0._wp
+      !
+   END SUBROUTINE rdgrft_shift
+
+
+   SUBROUTINE ice_strength
+      !!----------------------------------------------------------------------
+      !!                ***  ROUTINE ice_strength ***
+      !!
+      !! ** Purpose :   computes ice strength used in dynamics routines of ice thickness
+      !!
+      !! ** Method  :   Compute the strength of the ice pack, defined as the energy (J m-2) 
+      !!              dissipated per unit area removed from the ice pack under compression,
+      !!              and assumed proportional to the change in potential energy caused
+      !!              by ridging. Note that only Hibler's formulation is stable and that
+      !!              ice strength has to be smoothed
+      !!----------------------------------------------------------------------
+      INTEGER             ::   ji, jj, jl  ! dummy loop indices
+      INTEGER             ::   ismooth     ! smoothing the resistance to deformation
+      INTEGER             ::   itframe     ! number of time steps for the P smoothing
+      REAL(wp)            ::   zp, z1_3    ! local scalars
+      REAL(wp), DIMENSION(jpi,jpj) ::   zworka           ! temporary array used here
+      REAL(wp), DIMENSION(jpi,jpj) ::   zstrp1, zstrp2   ! strength at previous time steps
+      !!----------------------------------------------------------------------
+      !                              !--------------------------------------------------!
+      IF( ln_str_H79 ) THEN          ! Ice strength => Hibler (1979) method             !
+      !                              !--------------------------------------------------!
+         strength(:,:) = rn_pstar * SUM( v_i(:,:,:), dim=3 ) * EXP( -rn_crhg * ( 1._wp - SUM( a_i(:,:,:), dim=3 ) ) )
+         ismooth = 1
+         !                           !--------------------------------------------------!
+      ELSE                           ! Zero strength                                    !
+         !                           !--------------------------------------------------!
+         strength(:,:) = 0._wp
+         ismooth = 0
+      ENDIF
+      !                              !--------------------------------------------------!
+      SELECT CASE( ismooth )         ! Smoothing ice strength                           !
+      !                              !--------------------------------------------------!
+      CASE( 1 )               !--- Spatial smoothing
+         DO jj = 2, jpjm1
+            DO ji = 2, jpim1
+               IF ( SUM( a_i(ji,jj,:) ) > 0._wp ) THEN 
+                  zworka(ji,jj) = ( 4.0 * strength(ji,jj)              &
+                     &                  + strength(ji-1,jj) * tmask(ji-1,jj,1) + strength(ji+1,jj) * tmask(ji+1,jj,1) &  
+                     &                  + strength(ji,jj-1) * tmask(ji,jj-1,1) + strength(ji,jj+1) * tmask(ji,jj+1,1) &
+                     &            ) / ( 4.0 + tmask(ji-1,jj,1) + tmask(ji+1,jj,1) + tmask(ji,jj-1,1) + tmask(ji,jj+1,1) )
+               ELSE
+                  zworka(ji,jj) = 0._wp
+               ENDIF
+            END DO
+         END DO
+         
+         DO jj = 2, jpjm1
+            DO ji = 2, jpim1
+               strength(ji,jj) = zworka(ji,jj)
+            END DO
+         END DO
+         CALL lbc_lnk( strength, 'T', 1. )
+         !
+      CASE( 2 )               !--- Temporal smoothing
+         IF ( kt_ice == nit000 ) THEN
+            zstrp1(:,:) = 0._wp
+            zstrp2(:,:) = 0._wp
+         ENDIF
+         !
+         DO jj = 2, jpjm1
+            DO ji = 2, jpim1
+               IF ( SUM( a_i(ji,jj,:) ) > 0._wp ) THEN 
+                  itframe = 1 ! number of time steps for the running mean
+                  IF ( zstrp1(ji,jj) > 0._wp ) itframe = itframe + 1
+                  IF ( zstrp2(ji,jj) > 0._wp ) itframe = itframe + 1
+                  zp = ( strength(ji,jj) + zstrp1(ji,jj) + zstrp2(ji,jj) ) / itframe
+                  zstrp2  (ji,jj) = zstrp1  (ji,jj)
+                  zstrp1  (ji,jj) = strength(ji,jj)
+                  strength(ji,jj) = zp
+               ENDIF
+            END DO
+         END DO
+         CALL lbc_lnk( strength, 'T', 1. )
+         !
+      END SELECT
+      !
+   END SUBROUTINE ice_strength
+
+   
+   SUBROUTINE ice_dyn_1d2d( kn )
+      !!-----------------------------------------------------------------------
+      !!                   ***  ROUTINE ice_dyn_1d2d *** 
+      !!                 
+      !! ** Purpose :   move arrays from 1d to 2d and the reverse
+      !!-----------------------------------------------------------------------
+      INTEGER, INTENT(in) ::   kn   ! 1= from 2D to 1D   ;   2= from 1D to 2D
+      !
+      INTEGER ::   jl, jk   ! dummy loop indices
+      !!-----------------------------------------------------------------------
+      !
+      SELECT CASE( kn )
+      !                    !---------------------!
+      CASE( 1 )            !==  from 2D to 1D  ==!
+         !                 !---------------------!
+         ! fields used but not modified
+         CALL tab_2d_1d( npti, nptidx(1:npti), sss_1d(1:npti), sss_m(:,:) )
+         CALL tab_2d_1d( npti, nptidx(1:npti), sst_1d(1:npti), sst_m(:,:) )
+         ! the following fields are modified in this routine
+         !!CALL tab_2d_1d( npti, nptidx(1:npti), ato_i_1d(1:npti), ato_i(:,:) )
+         !!CALL tab_3d_2d( npti, nptidx(1:npti), a_i_2d(1:npti,1:jpl), a_i(:,:,:) )
+         !!CALL tab_3d_2d( npti, nptidx(1:npti), v_i_2d  (1:npti,1:jpl), v_i  (:,:,:) )
+         CALL tab_3d_2d( npti, nptidx(1:npti), v_s_2d (1:npti,1:jpl), v_s (:,:,:) )
+         CALL tab_3d_2d( npti, nptidx(1:npti), sv_i_2d(1:npti,1:jpl), sv_i(:,:,:) )
+         CALL tab_3d_2d( npti, nptidx(1:npti), oa_i_2d(1:npti,1:jpl), oa_i(:,:,:) )
+         CALL tab_3d_2d( npti, nptidx(1:npti), a_ip_2d(1:npti,1:jpl), a_ip(:,:,:) )
+         CALL tab_3d_2d( npti, nptidx(1:npti), v_ip_2d(1:npti,1:jpl), v_ip(:,:,:) )
+         DO jl = 1, jpl
+            DO jk = 1, nlay_s
+               CALL tab_2d_1d( npti, nptidx(1:npti), ze_s_2d(1:npti,jk,jl), e_s(:,:,jk,jl) )
+            END DO
+            DO jk = 1, nlay_i
+               CALL tab_2d_1d( npti, nptidx(1:npti), ze_i_2d(1:npti,jk,jl), e_i(:,:,jk,jl) )
+            END DO
+         END DO
+         CALL tab_2d_1d( npti, nptidx(1:npti), sfx_dyn_1d    (1:npti), sfx_dyn    (:,:) )
+         CALL tab_2d_1d( npti, nptidx(1:npti), sfx_bri_1d    (1:npti), sfx_bri    (:,:) )
+         CALL tab_2d_1d( npti, nptidx(1:npti), wfx_dyn_1d    (1:npti), wfx_dyn    (:,:) )
+         CALL tab_2d_1d( npti, nptidx(1:npti), hfx_dyn_1d    (1:npti), hfx_dyn    (:,:) )
+         CALL tab_2d_1d( npti, nptidx(1:npti), wfx_snw_dyn_1d(1:npti), wfx_snw_dyn(:,:) )
+         CALL tab_2d_1d( npti, nptidx(1:npti), wfx_pnd_1d(1:npti), wfx_pnd(:,:) )
+
+         !                 !---------------------!
+      CASE( 2 )            !==  from 1D to 2D  ==!
+         !                 !---------------------!
+         CALL tab_1d_2d( npti, nptidx(1:npti), ato_i_1d(1:npti), ato_i(:,:) )
+         CALL tab_2d_3d( npti, nptidx(1:npti), a_i_2d (1:npti,1:jpl), a_i (:,:,:) )
+         CALL tab_2d_3d( npti, nptidx(1:npti), v_i_2d (1:npti,1:jpl), v_i (:,:,:) )
+         CALL tab_2d_3d( npti, nptidx(1:npti), v_s_2d (1:npti,1:jpl), v_s (:,:,:) )
+         CALL tab_2d_3d( npti, nptidx(1:npti), sv_i_2d(1:npti,1:jpl), sv_i(:,:,:) )
+         CALL tab_2d_3d( npti, nptidx(1:npti), oa_i_2d(1:npti,1:jpl), oa_i(:,:,:) )
+         CALL tab_2d_3d( npti, nptidx(1:npti), a_ip_2d(1:npti,1:jpl), a_ip(:,:,:) )
+         CALL tab_2d_3d( npti, nptidx(1:npti), v_ip_2d(1:npti,1:jpl), v_ip(:,:,:) )
+         DO jl = 1, jpl
+            DO jk = 1, nlay_s
+               CALL tab_1d_2d( npti, nptidx(1:npti), ze_s_2d(1:npti,jk,jl), e_s(:,:,jk,jl) )
+            END DO
+            DO jk = 1, nlay_i
+               CALL tab_1d_2d( npti, nptidx(1:npti), ze_i_2d(1:npti,jk,jl), e_i(:,:,jk,jl) )
+            END DO
+         END DO
+         CALL tab_1d_2d( npti, nptidx(1:npti), sfx_dyn_1d    (1:npti), sfx_dyn    (:,:) )
+         CALL tab_1d_2d( npti, nptidx(1:npti), sfx_bri_1d    (1:npti), sfx_bri    (:,:) )
+         CALL tab_1d_2d( npti, nptidx(1:npti), wfx_dyn_1d    (1:npti), wfx_dyn    (:,:) )
+         CALL tab_1d_2d( npti, nptidx(1:npti), hfx_dyn_1d    (1:npti), hfx_dyn    (:,:) )
+         CALL tab_1d_2d( npti, nptidx(1:npti), wfx_snw_dyn_1d(1:npti), wfx_snw_dyn(:,:) )
+         CALL tab_1d_2d( npti, nptidx(1:npti), wfx_pnd_1d(1:npti), wfx_pnd(:,:) )
+         !
+      END SELECT
+      !
+   END SUBROUTINE ice_dyn_1d2d
+   
+
+   SUBROUTINE ice_dyn_rdgrft_init
+      !!-------------------------------------------------------------------
+      !!                  ***  ROUTINE ice_dyn_rdgrft_init ***
+      !!
+      !! ** Purpose :   Physical constants and parameters linked 
+      !!                to the mechanical ice redistribution
+      !!
+      !! ** Method  :   Read the namdyn_rdgrft namelist 
+      !!                and check the parameters values 
+      !!                called at the first timestep (nit000)
+      !!
+      !! ** input   :   Namelist namdyn_rdgrft
+      !!-------------------------------------------------------------------
+      INTEGER :: ios                 ! Local integer output status for namelist read
+      !!
+      NAMELIST/namdyn_rdgrft/ ln_str_H79, rn_pstar, rn_crhg, &
+         &                    rn_csrdg  ,                    &
+         &                    ln_partf_lin, rn_gstar,        &
+         &                    ln_partf_exp, rn_astar,        & 
+         &                    ln_ridging, rn_hstar, rn_porordg, rn_fsnwrdg, rn_fpndrdg,  & 
+         &                    ln_rafting, rn_hraft, rn_craft  , rn_fsnwrft, rn_fpndrft
+      !!-------------------------------------------------------------------
+      !
+      REWIND( numnam_ice_ref )              ! Namelist namicetdme in reference namelist : Ice mechanical ice redistribution
+      READ  ( numnam_ice_ref, namdyn_rdgrft, IOSTAT = ios, ERR = 901)
+901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namdyn_rdgrft in reference namelist', lwp )
+      REWIND( numnam_ice_cfg )              ! Namelist namdyn_rdgrft in configuration namelist : Ice mechanical ice redistribution
+      READ  ( numnam_ice_cfg, namdyn_rdgrft, IOSTAT = ios, ERR = 902 )
+902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namdyn_rdgrft in configuration namelist', lwp )
+      IF(lwm) WRITE ( numoni, namdyn_rdgrft )
+      !
+      IF (lwp) THEN                          ! control print
+         WRITE(numout,*)
+         WRITE(numout,*) 'ice_dyn_rdgrft_init: ice parameters for ridging/rafting '
+         WRITE(numout,*) '~~~~~~~~~~~~~~~~~~'
+         WRITE(numout,*) '   Namelist namdyn_rdgrft:'
+         WRITE(numout,*) '      ice strength parameterization Hibler (1979)              ln_str_H79   = ', ln_str_H79 
+         WRITE(numout,*) '            1st bulk-rheology parameter                        rn_pstar     = ', rn_pstar
+         WRITE(numout,*) '            2nd bulk-rhelogy parameter                         rn_crhg      = ', rn_crhg
+         WRITE(numout,*) '      Fraction of shear energy contributing to ridging         rn_csrdg     = ', rn_csrdg 
+         WRITE(numout,*) '      linear ridging participation function                    ln_partf_lin = ', ln_partf_lin
+         WRITE(numout,*) '            Fraction of ice coverage contributing to ridging   rn_gstar     = ', rn_gstar
+         WRITE(numout,*) '      Exponential ridging participation function               ln_partf_exp = ', ln_partf_exp
+         WRITE(numout,*) '            Equivalent to G* for an exponential function       rn_astar     = ', rn_astar
+         WRITE(numout,*) '      Ridging of ice sheets or not                             ln_ridging   = ', ln_ridging
+         WRITE(numout,*) '            max ridged ice thickness                           rn_hstar     = ', rn_hstar
+         WRITE(numout,*) '            Initial porosity of ridges                         rn_porordg   = ', rn_porordg
+         WRITE(numout,*) '            Fraction of snow volume conserved during ridging   rn_fsnwrdg   = ', rn_fsnwrdg 
+         WRITE(numout,*) '            Fraction of pond volume conserved during ridging   rn_fpndrdg   = ', rn_fpndrdg 
+         WRITE(numout,*) '      Rafting of ice sheets or not                             ln_rafting   = ', ln_rafting
+         WRITE(numout,*) '            Parmeter thickness (threshold between ridge-raft)  rn_hraft     = ', rn_hraft
+         WRITE(numout,*) '            Rafting hyperbolic tangent coefficient             rn_craft     = ', rn_craft  
+         WRITE(numout,*) '            Fraction of snow volume conserved during rafting   rn_fsnwrft   = ', rn_fsnwrft 
+         WRITE(numout,*) '            Fraction of pond volume conserved during rafting   rn_fpndrft   = ', rn_fpndrft 
+      ENDIF
+      !
+      IF ( ( ln_partf_lin .AND. ln_partf_exp ) .OR. ( .NOT.ln_partf_lin .AND. .NOT.ln_partf_exp ) ) THEN
+         CALL ctl_stop( 'ice_dyn_rdgrft_init: choose one and only one participation function (ln_partf_lin or ln_partf_exp)' )
+      ENDIF
+      !                              ! allocate tke arrays
+      IF( ice_dyn_rdgrft_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'ice_dyn_rdgrft_init: unable to allocate arrays' )
+      !
+  END SUBROUTINE ice_dyn_rdgrft_init
+
+#else
+   !!----------------------------------------------------------------------
+   !!   Default option         Empty module           NO SI3 sea-ice model
+   !!----------------------------------------------------------------------
+#endif
+
+   !!======================================================================
+END MODULE icedyn_rdgrft
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/ICE_SRC/icedyn_rhg.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/ICE_SRC/icedyn_rhg.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/ICE_SRC/icedyn_rhg.F90	(revision 9570)
@@ -0,0 +1,151 @@
+MODULE icedyn_rhg
+   !!======================================================================
+   !!                     ***  MODULE  icedyn_rhg  ***
+   !!   Sea-Ice dynamics : master routine for rheology 
+   !!======================================================================
+   !! history :  1.0  ! 2002-08  (C. Ethe, G. Madec)  original VP code 
+   !!            3.0  ! 2007-03  (MA Morales Maqueda, S. Bouillon, M. Vancoppenolle)  LIM3: EVP-Cgrid
+   !!            3.5  ! 2011-02  (G. Madec) dynamical allocation
+   !!----------------------------------------------------------------------
+#if defined key_si3
+   !!----------------------------------------------------------------------
+   !!   'key_si3'                                       SI3 sea-ice model
+   !!----------------------------------------------------------------------
+   !!    ice_dyn_rhg      : computes ice velocities
+   !!    ice_dyn_rhg_init : initialization and namelist read
+   !!----------------------------------------------------------------------
+   USE phycst         ! physical constants
+   USE dom_oce        ! ocean space and time domain
+   USE ice            ! sea-ice: variables
+   USE icedyn_rhg_evp ! sea-ice: EVP rheology
+   USE icectl         ! sea-ice: control prints
+   !
+   USE in_out_manager ! I/O manager
+   USE lib_mpp        ! MPP library
+   USE lib_fortran    ! fortran utilities (glob_sum + no signed zero)
+   USE timing         ! Timing
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   ice_dyn_rhg        ! called by icestp.F90
+   PUBLIC   ice_dyn_rhg_init   ! called by icestp.F90
+
+   INTEGER ::              nice_rhg   ! choice of the type of rheology
+   !                                        ! associated indices:
+   INTEGER, PARAMETER ::   np_rhgEVP = 1   ! EVP rheology
+!! INTEGER, PARAMETER ::   np_rhgEAP = 2   ! EAP rheology
+
+   ! ** namelist (namrhg) **
+   LOGICAL ::   ln_rhg_EVP       ! EVP rheology
+   !
+   !! * Substitutions
+#  include "vectopt_loop_substitute.h90"
+   !!----------------------------------------------------------------------
+   !! NEMO/ICE 4.0 , NEMO Consortium (2017)
+   !! $Id: icedyn_rhg.F90 8378 2017-07-26 13:55:59Z clem $
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE ice_dyn_rhg( kt )
+      !!-------------------------------------------------------------------
+      !!               ***  ROUTINE ice_dyn_rhg  ***
+      !!               
+      !! ** Purpose :   compute ice velocity
+      !!
+      !! ** Action  : comupte - ice velocity (u_ice, v_ice)
+      !!                      - 3 components of the stress tensor (stress1_i, stress2_i, stress12_i)
+      !!                      - shear, divergence and delta (shear_i, divu_i, delta_i)
+      !!--------------------------------------------------------------------
+      INTEGER, INTENT(in) ::   kt     ! ice time step
+      !!--------------------------------------------------------------------
+      ! controls
+      IF( ln_timing    )   CALL timing_start('icedyn_rhg')                                                             ! timing
+      IF( ln_icediachk )   CALL ice_cons_hsm(0, 'icedyn_rhg', rdiag_v, rdiag_s, rdiag_t, rdiag_fv, rdiag_fs, rdiag_ft) ! conservation
+      !
+      IF( kt == nit000 .AND. lwp ) THEN
+         WRITE(numout,*)
+         WRITE(numout,*)'ice_dyn_rhg: sea-ice rheology'
+         WRITE(numout,*)'~~~~~~~~~~~'
+      ENDIF
+
+      ! --------
+      ! Rheology
+      ! --------   
+      SELECT CASE( nice_rhg )
+      !                                !------------------------!
+      CASE( np_rhgEVP )                ! Elasto-Viscous-Plastic !
+         !                             !------------------------!
+         CALL ice_dyn_rhg_evp( kt, stress1_i, stress2_i, stress12_i, shear_i, divu_i, delta_i )
+         !         
+      END SELECT
+      !
+      IF( lrst_ice ) THEN                       !* write EVP fields in the restart file
+         IF( ln_rhg_EVP )   CALL rhg_evp_rst( 'WRITE', kt )
+      ENDIF
+      !
+      ! controls
+      IF( ln_icediachk )   CALL ice_cons_hsm(1, 'icedyn_rhg', rdiag_v, rdiag_s, rdiag_t, rdiag_fv, rdiag_fs, rdiag_ft) ! conservation
+      IF( ln_ctl       )   CALL ice_prt3D   ('icedyn_rhg')                                                             ! prints
+      IF( ln_timing    )   CALL timing_stop ('icedyn_rhg')                                                             ! timing
+      !
+   END SUBROUTINE ice_dyn_rhg
+
+
+   SUBROUTINE ice_dyn_rhg_init
+      !!-------------------------------------------------------------------
+      !!                  ***  ROUTINE ice_dyn_rhg_init  ***
+      !!
+      !! ** Purpose : Physical constants and parameters linked to the ice
+      !!      dynamics
+      !!
+      !! ** Method  :  Read the namdyn_rhg namelist and check the ice-dynamic
+      !!       parameter values called at the first timestep (nit000)
+      !!
+      !! ** input   :   Namelist namdyn_rhg
+      !!-------------------------------------------------------------------
+      INTEGER ::   ios, ioptio   ! Local integer output status for namelist read
+      !!
+      NAMELIST/namdyn_rhg/  ln_rhg_EVP, ln_aEVP, rn_creepl, rn_ecc , nn_nevp, rn_relast
+      !!-------------------------------------------------------------------
+      !
+      REWIND( numnam_ice_ref )         ! Namelist namdyn_rhg in reference namelist : Ice dynamics
+      READ  ( numnam_ice_ref, namdyn_rhg, IOSTAT = ios, ERR = 901)
+901   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namdyn_rhg in reference namelist', lwp )
+      REWIND( numnam_ice_cfg )         ! Namelist namdyn_rhg in configuration namelist : Ice dynamics
+      READ  ( numnam_ice_cfg, namdyn_rhg, IOSTAT = ios, ERR = 902 )
+902   IF( ios >  0 ) CALL ctl_nam ( ios , 'namdyn_rhg in configuration namelist', lwp )
+      IF(lwm) WRITE ( numoni, namdyn_rhg )
+      !
+      IF(lwp) THEN                     ! control print
+         WRITE(numout,*)
+         WRITE(numout,*) 'ice_dyn_rhg_init: ice parameters for ice dynamics '
+         WRITE(numout,*) '~~~~~~~~~~~~~~~'
+         WRITE(numout,*) '   Namelist : namdyn_rhg:'
+         WRITE(numout,*) '      rheology EVP (icedyn_rhg_evp)                        ln_rhg_EVP = ', ln_rhg_EVP
+         WRITE(numout,*) '         use adaptive EVP (aEVP)                           ln_aEVP    = ', ln_aEVP
+         WRITE(numout,*) '         creep limit                                       rn_creepl  = ', rn_creepl
+         WRITE(numout,*) '         eccentricity of the elliptical yield curve        rn_ecc     = ', rn_ecc
+         WRITE(numout,*) '         number of iterations for subcycling               nn_nevp    = ', nn_nevp
+         WRITE(numout,*) '         ratio of elastic timescale over ice time step     rn_relast  = ', rn_relast
+      ENDIF
+      !
+      !                             !== set the choice of ice advection ==!
+      ioptio = 0 
+      IF( ln_rhg_EVP ) THEN   ;   ioptio = ioptio + 1   ;   nice_rhg = np_rhgEVP    ;   ENDIF
+!!    IF( ln_rhg_EAP ) THEN   ;   ioptio = ioptio + 1   ;   nice_rhg = np_rhgEAP    ;   ENDIF
+      IF( ioptio /= 1 )   CALL ctl_stop( 'ice_dyn_rhg_init: choose one and only one ice rheology' )
+      !
+      IF( ln_rhg_EVP  )   CALL rhg_evp_rst( 'READ' )  !* read or initialize all required files
+      !
+   END SUBROUTINE ice_dyn_rhg_init
+
+#else
+   !!----------------------------------------------------------------------
+   !!   Default option         Empty module           NO SI3 sea-ice model
+   !!----------------------------------------------------------------------
+#endif 
+
+   !!======================================================================
+END MODULE icedyn_rhg
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/ICE_SRC/icedyn_rhg_evp.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/ICE_SRC/icedyn_rhg_evp.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/ICE_SRC/icedyn_rhg_evp.F90	(revision 9570)
@@ -0,0 +1,906 @@
+MODULE icedyn_rhg_evp
+   !!======================================================================
+   !!                     ***  MODULE  icedyn_rhg_evp  ***
+   !!   Sea-Ice dynamics : rheology Elasto-Viscous-Plastic
+   !!======================================================================
+   !! History :   -   !  2007-03  (M.A. Morales Maqueda, S. Bouillon) Original code
+   !!            3.0  !  2008-03  (M. Vancoppenolle) LIM3
+   !!             -   !  2008-11  (M. Vancoppenolle, S. Bouillon, Y. Aksenov) add surface tilt in ice rheolohy 
+   !!            3.3  !  2009-05  (G.Garric) addition of the evp cas
+   !!            3.4  !  2011-01  (A. Porter)  dynamical allocation 
+   !!            3.5  !  2012-08  (R. Benshila)  AGRIF
+   !!            3.6  !  2016-06  (C. Rousset) Rewriting + landfast ice + possibility to use mEVP (Bouillon 2013)
+   !!----------------------------------------------------------------------
+#if defined key_si3
+   !!----------------------------------------------------------------------
+   !!   'key_si3'                                       SI3 sea-ice model
+   !!----------------------------------------------------------------------
+   !!   ice_dyn_rhg_evp : computes ice velocities from EVP rheology
+   !!   rhg_evp_rst     : read/write EVP fields in ice restart
+   !!----------------------------------------------------------------------
+   USE phycst         ! Physical constant
+   USE dom_oce        ! Ocean domain
+   USE sbc_oce , ONLY : ln_ice_embd, nn_fsbc, ssh_m
+   USE sbc_ice , ONLY : utau_ice, vtau_ice, snwice_mass, snwice_mass_b
+   USE ice            ! sea-ice: ice variables
+   USE icedyn_rdgrft  ! sea-ice: ice strength
+   USE bdy_oce , ONLY : ln_bdy 
+   USE bdyice 
+#if defined key_agrif
+   USE agrif_si3_interp
+#endif
+   !
+   USE in_out_manager ! I/O manager
+   USE iom            ! I/O manager library
+   USE lib_mpp        ! MPP library
+   USE lib_fortran    ! fortran utilities (glob_sum + no signed zero)
+   USE lbclnk         ! lateral boundary conditions (or mpp links)
+   USE prtctl         ! Print control
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   ice_dyn_rhg_evp   ! called by icedyn_rhg.F90
+   PUBLIC   rhg_evp_rst       ! called by icedyn_rhg.F90
+
+   !! * Substitutions
+#  include "vectopt_loop_substitute.h90"
+   !!----------------------------------------------------------------------
+   !! NEMO/ICE 4.0 , NEMO Consortium (2017)
+   !! $Id: icedyn_rhg_evp.F90 8378 2017-07-26 13:55:59Z clem $
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE ice_dyn_rhg_evp( kt, pstress1_i, pstress2_i, pstress12_i, pshear_i, pdivu_i, pdelta_i )
+      !!-------------------------------------------------------------------
+      !!                 ***  SUBROUTINE ice_dyn_rhg_evp  ***
+      !!                             EVP-C-grid
+      !!
+      !! ** purpose : determines sea ice drift from wind stress, ice-ocean
+      !!  stress and sea-surface slope. Ice-ice interaction is described by 
+      !!  a non-linear elasto-viscous-plastic (EVP) law including shear 
+      !!  strength and a bulk rheology (Hunke and Dukowicz, 2002).	
+      !!
+      !!  The points in the C-grid look like this, dear reader
+      !!
+      !!                              (ji,jj)
+      !!                                 |
+      !!                                 |
+      !!                      (ji-1,jj)  |  (ji,jj)
+      !!                             ---------   
+      !!                            |         |
+      !!                            | (ji,jj) |------(ji,jj)
+      !!                            |         |
+      !!                             ---------   
+      !!                     (ji-1,jj-1)     (ji,jj-1)
+      !!
+      !! ** Inputs  : - wind forcing (stress), oceanic currents
+      !!                ice total volume (vt_i) per unit area
+      !!                snow total volume (vt_s) per unit area
+      !!
+      !! ** Action  : - compute u_ice, v_ice : the components of the 
+      !!                sea-ice velocity vector
+      !!              - compute delta_i, shear_i, divu_i, which are inputs
+      !!                of the ice thickness distribution
+      !!
+      !! ** Steps   : 0) compute mask at F point
+      !!              1) Compute ice snow mass, ice strength 
+      !!              2) Compute wind, oceanic stresses, mass terms and
+      !!                 coriolis terms of the momentum equation
+      !!              3) Solve the momentum equation (iterative procedure)
+      !!              4) Recompute delta, shear and divergence
+      !!                 (which are inputs of the ITD) & store stress
+      !!                 for the next time step
+      !!              5) Diagnostics including charge ellipse
+      !!
+      !! ** Notes   : There is the possibility to use aEVP from the nice work of Kimmritz et al. (2016 & 2017)
+      !!              by setting up ln_aEVP=T (i.e. changing alpha and beta parameters).
+      !!              This is an upgraded version of mEVP from Bouillon et al. 2013
+      !!              (i.e. more stable and better convergence)
+      !!
+      !! References : Hunke and Dukowicz, JPO97
+      !!              Bouillon et al., Ocean Modelling 2009
+      !!              Bouillon et al., Ocean Modelling 2013
+      !!              Kimmritz et al., Ocean Modelling 2016 & 2017
+      !!-------------------------------------------------------------------
+      INTEGER                 , INTENT(in   ) ::   kt                                    ! time step
+      REAL(wp), DIMENSION(:,:), INTENT(inout) ::   pstress1_i, pstress2_i, pstress12_i   !
+      REAL(wp), DIMENSION(:,:), INTENT(  out) ::   pshear_i  , pdivu_i   , pdelta_i      !
+      !!
+      INTEGER ::   ji, jj       ! dummy loop indices
+      INTEGER ::   jter         ! local integers
+      !
+      REAL(wp) ::   zrhoco                                              ! rau0 * rn_cio
+      REAL(wp) ::   zdtevp, z1_dtevp                                    ! time step for subcycling
+      REAL(wp) ::   ecc2, z1_ecc2                                       ! square of yield ellipse eccenticity
+      REAL(wp) ::   zalph1, z1_alph1, zalph2, z1_alph2                  ! alpha coef from Bouillon 2009 or Kimmritz 2017
+      REAL(wp) ::   zm1, zm2, zm3, zmassU, zmassV                       ! ice/snow mass
+      REAL(wp) ::   zdelta, zp_delf, zds2, zdt, zdt2, zdiv, zdiv2       ! temporary scalars
+      REAL(wp) ::   zTauO, zTauB, zTauE, zvel                           ! temporary scalars
+      !
+      REAL(wp) ::   zresm                                               ! Maximal error on ice velocity
+      REAL(wp) ::   zintb, zintn                                        ! dummy argument
+      REAL(wp) ::   zfac_x, zfac_y
+      REAL(wp) ::   zshear, zdum1, zdum2
+      !
+      REAL(wp), DIMENSION(jpi,jpj) ::   z1_e1t0, z1_e2t0                ! scale factors
+      REAL(wp), DIMENSION(jpi,jpj) ::   zp_delt                         ! P/delta at T points
+      REAL(wp), DIMENSION(jpi,jpj) ::   zbeta                           ! beta coef from Kimmritz 2017
+      !
+      REAL(wp), DIMENSION(jpi,jpj) ::   zdt_m                           ! (dt / ice-snow_mass) on T points
+      REAL(wp), DIMENSION(jpi,jpj) ::   zaU   , zaV                     ! ice fraction on U/V points
+      REAL(wp), DIMENSION(jpi,jpj) ::   zmU_t, zmV_t                    ! (ice-snow_mass / dt) on U/V points
+      REAL(wp), DIMENSION(jpi,jpj) ::   zmf                             ! coriolis parameter at T points
+      REAL(wp), DIMENSION(jpi,jpj) ::   zTauU_ia , ztauV_ia             ! ice-atm. stress at U-V points
+      REAL(wp), DIMENSION(jpi,jpj) ::   zspgU , zspgV                   ! surface pressure gradient at U/V points
+      REAL(wp), DIMENSION(jpi,jpj) ::   v_oceU, u_oceV, v_iceU, u_iceV  ! ocean/ice u/v component on V/U points                           
+      REAL(wp), DIMENSION(jpi,jpj) ::   zfU   , zfV                     ! internal stresses
+      !
+      REAL(wp), DIMENSION(jpi,jpj) ::   zds                             ! shear
+      REAL(wp), DIMENSION(jpi,jpj) ::   zs1, zs2, zs12                  ! stress tensor components
+      REAL(wp), DIMENSION(jpi,jpj) ::   zu_ice, zv_ice, zresr           ! check convergence
+      REAL(wp), DIMENSION(jpi,jpj) ::   zpice                           ! array used for the calculation of ice surface slope:
+      !                                                                 !    ocean surface (ssh_m) if ice is not embedded
+      !                                                                 !    ice top surface if ice is embedded   
+      REAL(wp), DIMENSION(jpi,jpj) ::   zCorx, zCory                    ! Coriolis stress array
+      REAL(wp), DIMENSION(jpi,jpj) ::   ztaux_oi, ztauy_oi              ! Ocean-to-ice stress array
+      !
+      REAL(wp), DIMENSION(jpi,jpj) ::   zswitchU, zswitchV              ! dummy arrays
+      REAL(wp), DIMENSION(jpi,jpj) ::   zmaskU, zmaskV                  ! mask for ice presence
+      REAL(wp), DIMENSION(jpi,jpj) ::   zfmask, zwf                     ! mask at F points for the ice
+
+      REAL(wp), PARAMETER          ::   zepsi  = 1.0e-20_wp             ! tolerance parameter
+      REAL(wp), PARAMETER          ::   zmmin  = 1._wp                  ! ice mass (kg/m2) below which ice velocity equals ocean velocity
+      !! --- diags
+      REAL(wp), DIMENSION(jpi,jpj) ::   zswi
+      REAL(wp), ALLOCATABLE, DIMENSION(:,:) ::   zsig1, zsig2, zsig3
+      !! --- SIMIP diags
+      REAL(wp), ALLOCATABLE, DIMENSION(:,:) ::   zdiag_sig1      ! Average normal stress in sea ice   
+      REAL(wp), ALLOCATABLE, DIMENSION(:,:) ::   zdiag_sig2      ! Maximum shear stress in sea ice
+      REAL(wp), ALLOCATABLE, DIMENSION(:,:) ::   zdiag_dssh_dx   ! X-direction sea-surface tilt term (N/m2)
+      REAL(wp), ALLOCATABLE, DIMENSION(:,:) ::   zdiag_dssh_dy   ! X-direction sea-surface tilt term (N/m2)
+      REAL(wp), ALLOCATABLE, DIMENSION(:,:) ::   zdiag_corstrx   ! X-direction coriolis stress (N/m2)
+      REAL(wp), ALLOCATABLE, DIMENSION(:,:) ::   zdiag_corstry   ! Y-direction coriolis stress (N/m2)
+      REAL(wp), ALLOCATABLE, DIMENSION(:,:) ::   zdiag_intstrx   ! X-direction internal stress (N/m2)
+      REAL(wp), ALLOCATABLE, DIMENSION(:,:) ::   zdiag_intstry   ! Y-direction internal stress (N/m2)
+      REAL(wp), ALLOCATABLE, DIMENSION(:,:) ::   zdiag_utau_oi   ! X-direction ocean-ice stress
+      REAL(wp), ALLOCATABLE, DIMENSION(:,:) ::   zdiag_vtau_oi   ! Y-direction ocean-ice stress  
+      REAL(wp), ALLOCATABLE, DIMENSION(:,:) ::   zdiag_xmtrp_ice ! X-component of ice mass transport (kg/s)
+      REAL(wp), ALLOCATABLE, DIMENSION(:,:) ::   zdiag_ymtrp_ice ! Y-component of ice mass transport (kg/s)
+      REAL(wp), ALLOCATABLE, DIMENSION(:,:) ::   zdiag_xmtrp_snw ! X-component of snow mass transport (kg/s)
+      REAL(wp), ALLOCATABLE, DIMENSION(:,:) ::   zdiag_ymtrp_snw ! Y-component of snow mass transport (kg/s)
+      REAL(wp), ALLOCATABLE, DIMENSION(:,:) ::   zdiag_xatrp     ! X-component of area transport (m2/s)
+      REAL(wp), ALLOCATABLE, DIMENSION(:,:) ::   zdiag_yatrp     ! Y-component of area transport (m2/s)      
+      !!-------------------------------------------------------------------
+
+      IF( kt == nit000 .AND. lwp )   WRITE(numout,*) '-- ice_dyn_rhg_evp: EVP sea-ice rheology'
+      !
+!!gm for Clem:  OPTIMIZATION:  I think zfmask can be computed one for all at the initialization....
+      !------------------------------------------------------------------------------!
+      ! 0) mask at F points for the ice
+      !------------------------------------------------------------------------------!
+      ! ocean/land mask
+      DO jj = 1, jpjm1
+         DO ji = 1, jpim1      ! NO vector opt.
+            zfmask(ji,jj) = tmask(ji,jj,1) * tmask(ji+1,jj,1) * tmask(ji,jj+1,1) * tmask(ji+1,jj+1,1)
+         END DO
+      END DO
+      CALL lbc_lnk( zfmask, 'F', 1._wp )
+
+      ! Lateral boundary conditions on velocity (modify zfmask)
+      zwf(:,:) = zfmask(:,:)
+      DO jj = 2, jpjm1
+         DO ji = fs_2, fs_jpim1   ! vector opt.
+            IF( zfmask(ji,jj) == 0._wp ) THEN
+               zfmask(ji,jj) = rn_ishlat * MIN( 1._wp , MAX( zwf(ji+1,jj), zwf(ji,jj+1), zwf(ji-1,jj), zwf(ji,jj-1) ) )
+            ENDIF
+         END DO
+      END DO
+      DO jj = 2, jpjm1
+         IF( zfmask(1,jj) == 0._wp ) THEN
+            zfmask(1  ,jj) = rn_ishlat * MIN( 1._wp , MAX( zwf(2,jj), zwf(1,jj+1), zwf(1,jj-1) ) )
+         ENDIF
+         IF( zfmask(jpi,jj) == 0._wp ) THEN
+            zfmask(jpi,jj) = rn_ishlat * MIN( 1._wp , MAX( zwf(jpi,jj+1), zwf(jpim1,jj), zwf(jpi,jj-1) ) )
+         ENDIF
+      END DO
+      DO ji = 2, jpim1
+         IF( zfmask(ji,1) == 0._wp ) THEN
+            zfmask(ji,1  ) = rn_ishlat * MIN( 1._wp , MAX( zwf(ji+1,1), zwf(ji,2), zwf(ji-1,1) ) )
+         ENDIF
+         IF( zfmask(ji,jpj) == 0._wp ) THEN
+            zfmask(ji,jpj) = rn_ishlat * MIN( 1._wp , MAX( zwf(ji+1,jpj), zwf(ji-1,jpj), zwf(ji,jpjm1) ) )
+         ENDIF
+      END DO
+      CALL lbc_lnk( zfmask, 'F', 1._wp )
+
+      !------------------------------------------------------------------------------!
+      ! 1) define some variables and initialize arrays
+      !------------------------------------------------------------------------------!
+      zrhoco = rau0 * rn_cio 
+
+      ! ecc2: square of yield ellipse eccenticrity
+      ecc2    = rn_ecc * rn_ecc
+      z1_ecc2 = 1._wp / ecc2
+
+      ! Time step for subcycling
+      zdtevp   = rdt_ice / REAL( nn_nevp )
+      z1_dtevp = 1._wp / zdtevp
+
+      ! alpha parameters (Bouillon 2009)
+      IF( .NOT. ln_aEVP ) THEN
+         zalph1 = ( 2._wp * rn_relast * rdt_ice ) * z1_dtevp
+         zalph2 = zalph1 * z1_ecc2
+
+         z1_alph1 = 1._wp / ( zalph1 + 1._wp )
+         z1_alph2 = 1._wp / ( zalph2 + 1._wp )
+      ENDIF
+         
+      ! Initialise stress tensor 
+      zs1 (:,:) = pstress1_i (:,:) 
+      zs2 (:,:) = pstress2_i (:,:)
+      zs12(:,:) = pstress12_i(:,:)
+
+      ! Ice strength
+      CALL ice_strength
+
+      ! scale factors
+      DO jj = 2, jpjm1
+         DO ji = fs_2, fs_jpim1
+            z1_e1t0(ji,jj) = 1._wp / ( e1t(ji+1,jj  ) + e1t(ji,jj  ) )
+            z1_e2t0(ji,jj) = 1._wp / ( e2t(ji  ,jj+1) + e2t(ji,jj  ) )
+         END DO
+      END DO
+            
+      !
+      !------------------------------------------------------------------------------!
+      ! 2) Wind / ocean stress, mass terms, coriolis terms
+      !------------------------------------------------------------------------------!
+
+      IF( ln_ice_embd ) THEN             !== embedded sea ice: compute representative ice top surface ==!
+         !                                            
+         ! average interpolation coeff as used in dynspg = (1/nn_fsbc)   * {SUM[n/nn_fsbc], n=0,nn_fsbc-1}
+         !                                               = (1/nn_fsbc)^2 * {SUM[n]        , n=0,nn_fsbc-1}
+         zintn = REAL( nn_fsbc - 1 ) / REAL( nn_fsbc ) * 0.5_wp     
+         !
+         ! average interpolation coeff as used in dynspg = (1/nn_fsbc)   *    {SUM[1-n/nn_fsbc], n=0,nn_fsbc-1}
+         !                                               = (1/nn_fsbc)^2 * (nn_fsbc^2 - {SUM[n], n=0,nn_fsbc-1})
+         zintb = REAL( nn_fsbc + 1 ) / REAL( nn_fsbc ) * 0.5_wp
+         !
+         zpice(:,:) = ssh_m(:,:) + ( zintn * snwice_mass(:,:) + zintb * snwice_mass_b(:,:) ) * r1_rau0
+         !
+      ELSE                                    !== non-embedded sea ice: use ocean surface for slope calculation ==!
+         zpice(:,:) = ssh_m(:,:)
+      ENDIF
+
+      DO jj = 2, jpjm1
+         DO ji = fs_2, fs_jpim1
+
+            ! ice fraction at U-V points
+            zaU(ji,jj) = 0.5_wp * ( at_i(ji,jj) * e1e2t(ji,jj) + at_i(ji+1,jj) * e1e2t(ji+1,jj) ) * r1_e1e2u(ji,jj) * umask(ji,jj,1)
+            zaV(ji,jj) = 0.5_wp * ( at_i(ji,jj) * e1e2t(ji,jj) + at_i(ji,jj+1) * e1e2t(ji,jj+1) ) * r1_e1e2v(ji,jj) * vmask(ji,jj,1)
+
+            ! Ice/snow mass at U-V points
+            zm1 = ( rhosn * vt_s(ji  ,jj  ) + rhoic * vt_i(ji  ,jj  ) )
+            zm2 = ( rhosn * vt_s(ji+1,jj  ) + rhoic * vt_i(ji+1,jj  ) )
+            zm3 = ( rhosn * vt_s(ji  ,jj+1) + rhoic * vt_i(ji  ,jj+1) )
+            zmassU = 0.5_wp * ( zm1 * e1e2t(ji,jj) + zm2 * e1e2t(ji+1,jj) ) * r1_e1e2u(ji,jj) * umask(ji,jj,1)
+            zmassV = 0.5_wp * ( zm1 * e1e2t(ji,jj) + zm3 * e1e2t(ji,jj+1) ) * r1_e1e2v(ji,jj) * vmask(ji,jj,1)
+
+            ! Ocean currents at U-V points
+            v_oceU(ji,jj)   = 0.5_wp * ( ( v_oce(ji  ,jj) + v_oce(ji  ,jj-1) ) * e1t(ji+1,jj)    &
+               &                       + ( v_oce(ji+1,jj) + v_oce(ji+1,jj-1) ) * e1t(ji  ,jj) ) * z1_e1t0(ji,jj) * umask(ji,jj,1)
+            
+            u_oceV(ji,jj)   = 0.5_wp * ( ( u_oce(ji,jj  ) + u_oce(ji-1,jj  ) ) * e2t(ji,jj+1)    &
+               &                       + ( u_oce(ji,jj+1) + u_oce(ji-1,jj+1) ) * e2t(ji,jj  ) ) * z1_e2t0(ji,jj) * vmask(ji,jj,1)
+
+            ! Coriolis at T points (m*f)
+            zmf(ji,jj)      = zm1 * ff_t(ji,jj)
+
+            ! dt/m at T points (for alpha and beta coefficients)
+            zdt_m(ji,jj)    = zdtevp / MAX( zm1, zmmin )
+            
+            ! m/dt
+            zmU_t(ji,jj)    = zmassU * z1_dtevp
+            zmV_t(ji,jj)    = zmassV * z1_dtevp
+            
+            ! Drag ice-atm.
+            zTauU_ia(ji,jj) = zaU(ji,jj) * utau_ice(ji,jj)
+            zTauV_ia(ji,jj) = zaV(ji,jj) * vtau_ice(ji,jj)
+
+            ! Surface pressure gradient (- m*g*GRAD(ssh)) at U-V points
+            zspgU(ji,jj)    = - zmassU * grav * ( zpice(ji+1,jj) - zpice(ji,jj) ) * r1_e1u(ji,jj)
+            zspgV(ji,jj)    = - zmassV * grav * ( zpice(ji,jj+1) - zpice(ji,jj) ) * r1_e2v(ji,jj)
+
+            ! masks
+            zmaskU(ji,jj) = 1._wp - MAX( 0._wp, SIGN( 1._wp, -zmassU ) )  ! 0 if no ice
+            zmaskV(ji,jj) = 1._wp - MAX( 0._wp, SIGN( 1._wp, -zmassV ) )  ! 0 if no ice
+
+            ! switches
+            zswitchU(ji,jj) = MAX( 0._wp, SIGN( 1._wp, zmassU - zmmin ) ) ! 0 if ice mass < zmmin
+            zswitchV(ji,jj) = MAX( 0._wp, SIGN( 1._wp, zmassV - zmmin ) ) ! 0 if ice mass < zmmin
+
+         END DO
+      END DO
+      CALL lbc_lnk_multi( zmf, 'T', 1., zdt_m, 'T', 1. )
+      !
+      !------------------------------------------------------------------------------!
+      ! 3) Solution of the momentum equation, iterative procedure
+      !------------------------------------------------------------------------------!
+      !
+      !                                               !----------------------!
+      DO jter = 1 , nn_nevp                           !    loop over jter    !
+         !                                            !----------------------!        
+         IF(ln_ctl) THEN   ! Convergence test
+            DO jj = 1, jpjm1
+               zu_ice(:,jj) = u_ice(:,jj) ! velocity at previous time step
+               zv_ice(:,jj) = v_ice(:,jj)
+            END DO
+         ENDIF
+
+         ! --- divergence, tension & shear (Appendix B of Hunke & Dukowicz, 2002) --- !
+         DO jj = 1, jpjm1         ! loops start at 1 since there is no boundary condition (lbc_lnk) at i=1 and j=1 for F points
+            DO ji = 1, jpim1
+
+               ! shear at F points
+               zds(ji,jj) = ( ( u_ice(ji,jj+1) * r1_e1u(ji,jj+1) - u_ice(ji,jj) * r1_e1u(ji,jj) ) * e1f(ji,jj) * e1f(ji,jj)   &
+                  &         + ( v_ice(ji+1,jj) * r1_e2v(ji+1,jj) - v_ice(ji,jj) * r1_e2v(ji,jj) ) * e2f(ji,jj) * e2f(ji,jj)   &
+                  &         ) * r1_e1e2f(ji,jj) * zfmask(ji,jj)
+
+            END DO
+         END DO
+         CALL lbc_lnk( zds, 'F', 1. )
+
+         DO jj = 2, jpj    ! loop to jpi,jpj to avoid making a communication for zs1,zs2,zs12
+            DO ji = 2, jpi ! no vector loop
+
+               ! shear**2 at T points (doc eq. A16)
+               zds2 = ( zds(ji,jj  ) * zds(ji,jj  ) * e1e2f(ji,jj  ) + zds(ji-1,jj  ) * zds(ji-1,jj  ) * e1e2f(ji-1,jj  )  &
+                  &   + zds(ji,jj-1) * zds(ji,jj-1) * e1e2f(ji,jj-1) + zds(ji-1,jj-1) * zds(ji-1,jj-1) * e1e2f(ji-1,jj-1)  &
+                  &   ) * 0.25_wp * r1_e1e2t(ji,jj)
+              
+               ! divergence at T points
+               zdiv  = ( e2u(ji,jj) * u_ice(ji,jj) - e2u(ji-1,jj) * u_ice(ji-1,jj)   &
+                  &    + e1v(ji,jj) * v_ice(ji,jj) - e1v(ji,jj-1) * v_ice(ji,jj-1)   &
+                  &    ) * r1_e1e2t(ji,jj)
+               zdiv2 = zdiv * zdiv
+               
+               ! tension at T points
+               zdt  = ( ( u_ice(ji,jj) * r1_e2u(ji,jj) - u_ice(ji-1,jj) * r1_e2u(ji-1,jj) ) * e2t(ji,jj) * e2t(ji,jj)   &
+                  &   - ( v_ice(ji,jj) * r1_e1v(ji,jj) - v_ice(ji,jj-1) * r1_e1v(ji,jj-1) ) * e1t(ji,jj) * e1t(ji,jj)   &
+                  &   ) * r1_e1e2t(ji,jj)
+               zdt2 = zdt * zdt
+               
+               ! delta at T points
+               zdelta = SQRT( zdiv2 + ( zdt2 + zds2 ) * z1_ecc2 )  
+
+               ! P/delta at T points
+               zp_delt(ji,jj) = strength(ji,jj) / ( zdelta + rn_creepl )
+
+               ! alpha & beta for aEVP
+               !   gamma = 0.5*P/(delta+creepl) * (c*pi)**2/Area * dt/m
+               !   alpha = beta = sqrt(4*gamma)
+               IF( ln_aEVP ) THEN
+                  zalph1   = MAX( 50._wp, rpi * SQRT( 0.5_wp * zp_delt(ji,jj) * r1_e1e2t(ji,jj) * zdt_m(ji,jj) ) )
+                  z1_alph1 = 1._wp / ( zalph1 + 1._wp )
+                  zalph2   = zalph1
+                  z1_alph2 = z1_alph1
+               ENDIF
+               
+               ! stress at T points
+               zs1(ji,jj) = ( zs1(ji,jj) * zalph1 + zp_delt(ji,jj) * ( zdiv - zdelta ) ) * z1_alph1
+               zs2(ji,jj) = ( zs2(ji,jj) * zalph2 + zp_delt(ji,jj) * ( zdt * z1_ecc2 ) ) * z1_alph2
+             
+            END DO
+         END DO
+         CALL lbc_lnk( zp_delt, 'T', 1. )
+
+         DO jj = 1, jpjm1
+            DO ji = 1, jpim1
+
+               ! alpha & beta for aEVP
+               IF( ln_aEVP ) THEN
+                  zalph2   = MAX( 50._wp, rpi * SQRT( 0.5_wp * zp_delt(ji,jj) * r1_e1e2t(ji,jj) * zdt_m(ji,jj) ) )
+                  z1_alph2 = 1._wp / ( zalph2 + 1._wp )
+                  zbeta(ji,jj) = zalph2
+               ENDIF
+               
+               ! P/delta at F points
+               zp_delf = 0.25_wp * ( zp_delt(ji,jj) + zp_delt(ji+1,jj) + zp_delt(ji,jj+1) + zp_delt(ji+1,jj+1) )
+               
+               ! stress at F points
+               zs12(ji,jj)= ( zs12(ji,jj) * zalph2 + zp_delf * ( zds(ji,jj) * z1_ecc2 ) * 0.5_wp ) * z1_alph2
+
+            END DO
+         END DO
+
+         ! --- Ice internal stresses (Appendix C of Hunke and Dukowicz, 2002) --- !
+         DO jj = 2, jpjm1
+            DO ji = fs_2, fs_jpim1               
+               !                   !--- U points
+               zfU(ji,jj) = 0.5_wp * ( ( zs1(ji+1,jj) - zs1(ji,jj) ) * e2u(ji,jj)                                             &
+                  &                  + ( zs2(ji+1,jj) * e2t(ji+1,jj) * e2t(ji+1,jj) - zs2(ji,jj) * e2t(ji,jj) * e2t(ji,jj)    &
+                  &                    ) * r1_e2u(ji,jj)                                                                      &
+                  &                  + ( zs12(ji,jj) * e1f(ji,jj) * e1f(ji,jj) - zs12(ji,jj-1) * e1f(ji,jj-1) * e1f(ji,jj-1)  &
+                  &                    ) * 2._wp * r1_e1u(ji,jj)                                                              &
+                  &                  ) * r1_e1e2u(ji,jj)
+               !
+               !                !--- V points
+               zfV(ji,jj) = 0.5_wp * ( ( zs1(ji,jj+1) - zs1(ji,jj) ) * e1v(ji,jj)                                             &
+                  &                  - ( zs2(ji,jj+1) * e1t(ji,jj+1) * e1t(ji,jj+1) - zs2(ji,jj) * e1t(ji,jj) * e1t(ji,jj)    &
+                  &                    ) * r1_e1v(ji,jj)                                                                      &
+                  &                  + ( zs12(ji,jj) * e2f(ji,jj) * e2f(ji,jj) - zs12(ji-1,jj) * e2f(ji-1,jj) * e2f(ji-1,jj)  &
+                  &                    ) * 2._wp * r1_e2v(ji,jj)                                                              &
+                  &                  ) * r1_e1e2v(ji,jj)
+               !
+               !                !--- u_ice at V point
+               u_iceV(ji,jj) = 0.5_wp * ( ( u_ice(ji,jj  ) + u_ice(ji-1,jj  ) ) * e2t(ji,jj+1)     &
+                  &                     + ( u_ice(ji,jj+1) + u_ice(ji-1,jj+1) ) * e2t(ji,jj  ) ) * z1_e2t0(ji,jj) * vmask(ji,jj,1)
+               !
+               !                !--- v_ice at U point
+               v_iceU(ji,jj) = 0.5_wp * ( ( v_ice(ji  ,jj) + v_ice(ji  ,jj-1) ) * e1t(ji+1,jj)     &
+                  &                     + ( v_ice(ji+1,jj) + v_ice(ji+1,jj-1) ) * e1t(ji  ,jj) ) * z1_e1t0(ji,jj) * umask(ji,jj,1)
+            END DO
+         END DO
+         !
+         ! --- Computation of ice velocity --- !
+         !  Bouillon et al. 2013 (eq 47-48) => unstable unless alpha, beta vary as in Kimmritz 2016 & 2017
+         !  Bouillon et al. 2009 (eq 34-35) => stable
+         IF( MOD(jter,2) == 0 ) THEN ! even iterations
+            !
+            DO jj = 2, jpjm1
+               DO ji = fs_2, fs_jpim1
+                  !                 !--- tau_io/(v_oce - v_ice)
+                  zTauO = zaV(ji,jj) * zrhoco * SQRT( ( v_ice (ji,jj) - v_oce (ji,jj) ) * ( v_ice (ji,jj) - v_oce (ji,jj) )  &
+                     &                              + ( u_iceV(ji,jj) - u_oceV(ji,jj) ) * ( u_iceV(ji,jj) - u_oceV(ji,jj) ) )
+                  !                 !--- Ocean-to-Ice stress
+                  ztauy_oi(ji,jj) = zTauO * ( v_oce(ji,jj) - v_ice(ji,jj) )
+                  !
+                  !                 !--- tau_bottom/v_ice
+                  zvel  = MAX( zepsi, SQRT( v_ice(ji,jj) * v_ice(ji,jj) + u_iceV(ji,jj) * u_iceV(ji,jj) ) )
+                  zTauB = - tau_icebfr(ji,jj) / zvel
+                  !
+                  !                 !--- Coriolis at V-points (energy conserving formulation)
+                  zCory(ji,jj)  = - 0.25_wp * r1_e2v(ji,jj) *  &
+                     &    ( zmf(ji,jj  ) * ( e2u(ji,jj  ) * u_ice(ji,jj  ) + e2u(ji-1,jj  ) * u_ice(ji-1,jj  ) )  &
+                     &    + zmf(ji,jj+1) * ( e2u(ji,jj+1) * u_ice(ji,jj+1) + e2u(ji-1,jj+1) * u_ice(ji-1,jj+1) ) )
+                  !
+                  !                 !--- Sum of external forces (explicit solution) = F + tau_ia + Coriolis + spg + tau_io
+                  zTauE = zfV(ji,jj) + zTauV_ia(ji,jj) + zCory(ji,jj) + zspgV(ji,jj) + ztauy_oi(ji,jj)
+                  !
+                  !                 !--- landfast switch => 0 = static friction ; 1 = sliding friction
+                  rswitch = 1._wp - MIN( 1._wp, ABS( SIGN( 1._wp, ztauE - tau_icebfr(ji,jj) ) - SIGN( 1._wp, zTauE ) ) )
+                  !
+                  IF( ln_aEVP ) THEN !--- ice velocity using aEVP (Kimmritz et al 2016 & 2017)
+                  v_ice(ji,jj) = ( (          rswitch * ( zmV_t(ji,jj) * ( zbeta(ji,jj) * v_ice(ji,jj) + v_ice_b(ji,jj) )         & ! previous velocity
+                     &                                  + zTauE + zTauO * v_ice(ji,jj)                                            & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part)
+                     &                                  ) / MAX( zepsi, zmV_t(ji,jj) * ( zbeta(ji,jj) + 1._wp ) + zTauO - zTauB ) & ! m/dt + tau_io(only ice part) + landfast
+                     &                 + ( 1._wp - rswitch ) * v_ice(ji,jj) * MAX( 0._wp, 1._wp - zdtevp * rn_lfrelax )           & ! static friction => slow decrease to v=0
+                     &             ) * zswitchV(ji,jj) + v_oce(ji,jj) * ( 1._wp - zswitchV(ji,jj) )                               & ! v_ice = v_oce if mass < zmmin
+                     &           ) * zmaskV(ji,jj)
+                  ELSE               !--- ice velocity using EVP implicit formulation (cf Madec doc & Bouillon 2009)
+                  v_ice(ji,jj) = ( (           rswitch   * ( zmV_t(ji,jj)  * v_ice(ji,jj)                             &  ! previous velocity
+                     &                                     + zTauE + zTauO * v_ice(ji,jj)                             &  ! F + tau_ia + Coriolis + spg + tau_io(only ocean part)
+                     &                                     ) / MAX( zepsi, zmV_t(ji,jj) + zTauO - zTauB )             &  ! m/dt + tau_io(only ice part) + landfast
+                     &              + ( 1._wp - rswitch ) * v_ice(ji,jj) * MAX( 0._wp, 1._wp - zdtevp * rn_lfrelax )  &  ! static friction => slow decrease to v=0
+                     &              ) * zswitchV(ji,jj) + v_oce(ji,jj) * ( 1._wp - zswitchV(ji,jj) )                  &  ! v_ice = v_oce if mass < zmmin
+                     &            ) * zmaskV(ji,jj)
+                  ENDIF
+               END DO
+            END DO
+            CALL lbc_lnk( v_ice, 'V', -1. )
+            !
+#if defined key_agrif
+!!            CALL agrif_interp_si3( 'V', jter, nn_nevp )
+            CALL agrif_interp_si3( 'V' )
+#endif
+            IF( ln_bdy ) CALL bdy_ice_dyn( 'V' )
+            !
+            DO jj = 2, jpjm1
+               DO ji = fs_2, fs_jpim1          
+                  !                 !--- tau_io/(u_oce - u_ice)
+                  zTauO = zaU(ji,jj) * zrhoco * SQRT( ( u_ice (ji,jj) - u_oce (ji,jj) ) * ( u_ice (ji,jj) - u_oce (ji,jj) )  &
+                     &                              + ( v_iceU(ji,jj) - v_oceU(ji,jj) ) * ( v_iceU(ji,jj) - v_oceU(ji,jj) ) )
+                  !                 !--- Ocean-to-Ice stress
+                  ztaux_oi(ji,jj) = zTauO * ( u_oce(ji,jj) - u_ice(ji,jj) )
+                  !
+                  !                 !--- tau_bottom/u_ice
+                  zvel  = MAX( zepsi, SQRT( v_iceU(ji,jj) * v_iceU(ji,jj) + u_ice(ji,jj) * u_ice(ji,jj) ) )
+                  zTauB = - tau_icebfr(ji,jj) / zvel
+                  !
+                  !                 !--- Coriolis at U-points (energy conserving formulation)
+                  zCorx(ji,jj)  =   0.25_wp * r1_e1u(ji,jj) *  &
+                     &    ( zmf(ji  ,jj) * ( e1v(ji  ,jj) * v_ice(ji  ,jj) + e1v(ji  ,jj-1) * v_ice(ji  ,jj-1) )  &
+                     &    + zmf(ji+1,jj) * ( e1v(ji+1,jj) * v_ice(ji+1,jj) + e1v(ji+1,jj-1) * v_ice(ji+1,jj-1) ) )
+                  !
+                  !                 !--- Sum of external forces (explicit solution) = F + tau_ia + Coriolis + spg + tau_io
+                  zTauE = zfU(ji,jj) + zTauU_ia(ji,jj) + zCorx(ji,jj) + zspgU(ji,jj) + ztaux_oi(ji,jj)
+                  !
+                  !                 !--- landfast switch => 0 = static friction ; 1 = sliding friction
+                  rswitch = 1._wp - MIN( 1._wp, ABS( SIGN( 1._wp, ztauE - tau_icebfr(ji,jj) ) - SIGN( 1._wp, zTauE ) ) )
+                  !
+                  IF( ln_aEVP ) THEN !--- ice velocity using aEVP (Kimmritz et al 2016 & 2017)
+                  u_ice(ji,jj) = ( (          rswitch * ( zmU_t(ji,jj) * ( zbeta(ji,jj) * u_ice(ji,jj) + u_ice_b(ji,jj) )         & ! previous velocity
+                     &                                     + zTauE + zTauO * u_ice(ji,jj)                                         & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part)
+                     &                                  ) / MAX( zepsi, zmU_t(ji,jj) * ( zbeta(ji,jj) + 1._wp ) + zTauO - zTauB ) & ! m/dt + tau_io(only ice part) + landfast
+                     &              + ( 1._wp - rswitch ) * u_ice(ji,jj) * MAX( 0._wp, 1._wp - zdtevp * rn_lfrelax )              & ! static friction => slow decrease to v=0
+                     &              ) * zswitchU(ji,jj) + u_oce(ji,jj) * ( 1._wp - zswitchU(ji,jj) )                              & ! v_ice = v_oce if mass < zmmin 
+                     &            ) * zmaskU(ji,jj)
+                  ELSE               !--- ice velocity using EVP implicit formulation (cf Madec doc & Bouillon 2009)
+                  u_ice(ji,jj) = ( (           rswitch   * ( zmU_t(ji,jj)  * u_ice(ji,jj)                             &  ! previous velocity
+                     &                                     + zTauE + zTauO * u_ice(ji,jj)                             &  ! F + tau_ia + Coriolis + spg + tau_io(only ocean part)
+                     &                                     ) / MAX( zepsi, zmU_t(ji,jj) + zTauO - zTauB )             &  ! m/dt + tau_io(only ice part) + landfast
+                     &              + ( 1._wp - rswitch ) * u_ice(ji,jj) * MAX( 0._wp, 1._wp - zdtevp * rn_lfrelax )  &  ! static friction => slow decrease to v=0
+                     &              ) * zswitchU(ji,jj) + u_oce(ji,jj) * ( 1._wp - zswitchU(ji,jj) )                  &  ! v_ice = v_oce if mass < zmmin 
+                     &            ) * zmaskU(ji,jj)
+                  ENDIF
+               END DO
+            END DO
+            CALL lbc_lnk( u_ice, 'U', -1. )
+            !
+#if defined key_agrif
+!!            CALL agrif_interp_si3( 'U', jter, nn_nevp )
+            CALL agrif_interp_si3( 'U' )
+#endif
+            IF( ln_bdy ) CALL bdy_ice_dyn( 'U' )
+            !
+         ELSE ! odd iterations
+            !
+            DO jj = 2, jpjm1
+               DO ji = fs_2, fs_jpim1
+                  !                 !--- tau_io/(u_oce - u_ice)
+                  zTauO = zaU(ji,jj) * zrhoco * SQRT( ( u_ice (ji,jj) - u_oce (ji,jj) ) * ( u_ice (ji,jj) - u_oce (ji,jj) )  &
+                     &                              + ( v_iceU(ji,jj) - v_oceU(ji,jj) ) * ( v_iceU(ji,jj) - v_oceU(ji,jj) ) )
+                  !                 !--- Ocean-to-Ice stress
+                  ztaux_oi(ji,jj) = zTauO * ( u_oce(ji,jj) - u_ice(ji,jj) )
+                  !
+                  !                 !--- tau_bottom/u_ice
+                  zvel  = MAX( zepsi, SQRT( v_iceU(ji,jj) * v_iceU(ji,jj) + u_ice(ji,jj) * u_ice(ji,jj) ) )
+                  zTauB = - tau_icebfr(ji,jj) / zvel
+                  !
+                  !                 !--- Coriolis at U-points (energy conserving formulation)
+                  zCorx(ji,jj)  =   0.25_wp * r1_e1u(ji,jj) *  &
+                     &    ( zmf(ji  ,jj) * ( e1v(ji  ,jj) * v_ice(ji  ,jj) + e1v(ji  ,jj-1) * v_ice(ji  ,jj-1) )  &
+                     &    + zmf(ji+1,jj) * ( e1v(ji+1,jj) * v_ice(ji+1,jj) + e1v(ji+1,jj-1) * v_ice(ji+1,jj-1) ) )
+                  !
+                  !                 !--- Sum of external forces (explicit solution) = F + tau_ia + Coriolis + spg + tau_io
+                  zTauE = zfU(ji,jj) + zTauU_ia(ji,jj) + zCorx(ji,jj) + zspgU(ji,jj) + ztaux_oi(ji,jj)
+                  !
+                  !                 !--- landfast switch => 0 = static friction ; 1 = sliding friction
+                  rswitch = 1._wp - MIN( 1._wp, ABS( SIGN( 1._wp, ztauE - tau_icebfr(ji,jj) ) - SIGN( 1._wp, zTauE ) ) )
+                  !
+                  IF( ln_aEVP ) THEN !--- ice velocity using aEVP (Kimmritz et al 2016 & 2017)
+                  u_ice(ji,jj) = ( (          rswitch * ( zmU_t(ji,jj) * ( zbeta(ji,jj) * u_ice(ji,jj) + u_ice_b(ji,jj) )         & ! previous velocity
+                     &                                     + zTauE + zTauO * u_ice(ji,jj)                                         & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part)
+                     &                                  ) / MAX( zepsi, zmU_t(ji,jj) * ( zbeta(ji,jj) + 1._wp ) + zTauO - zTauB ) & ! m/dt + tau_io(only ice part) + landfast
+                     &              + ( 1._wp - rswitch ) * u_ice(ji,jj) * MAX( 0._wp, 1._wp - zdtevp * rn_lfrelax )              & ! static friction => slow decrease to v=0
+                     &              ) * zswitchU(ji,jj) + u_oce(ji,jj) * ( 1._wp - zswitchU(ji,jj) )                              & ! v_ice = v_oce if mass < zmmin 
+                     &            ) * zmaskU(ji,jj)
+                  ELSE               !--- ice velocity using EVP implicit formulation (cf Madec doc & Bouillon 2009)
+                  u_ice(ji,jj) = ( (           rswitch   * ( zmU_t(ji,jj)  * u_ice(ji,jj)                             &  ! previous velocity
+                     &                                     + zTauE + zTauO * u_ice(ji,jj)                             &  ! F + tau_ia + Coriolis + spg + tau_io(only ocean part)
+                     &                                     ) / MAX( zepsi, zmU_t(ji,jj) + zTauO - zTauB )             &  ! m/dt + tau_io(only ice part) + landfast
+                     &              + ( 1._wp - rswitch ) * u_ice(ji,jj) * MAX( 0._wp, 1._wp - zdtevp * rn_lfrelax )  &  ! static friction => slow decrease to v=0
+                     &              ) * zswitchU(ji,jj) + u_oce(ji,jj) * ( 1._wp - zswitchU(ji,jj) )                  &  ! v_ice = v_oce if mass < zmmin 
+                     &            ) * zmaskU(ji,jj)
+                  ENDIF
+               END DO
+            END DO
+            CALL lbc_lnk( u_ice, 'U', -1. )
+            !
+#if defined key_agrif
+!!            CALL agrif_interp_si3( 'U', jter, nn_nevp )
+            CALL agrif_interp_si3( 'U' )
+#endif
+            IF( ln_bdy ) CALL bdy_ice_dyn( 'U' )
+            !
+            DO jj = 2, jpjm1
+               DO ji = fs_2, fs_jpim1
+                  !                 !--- tau_io/(v_oce - v_ice)
+                  zTauO = zaV(ji,jj) * zrhoco * SQRT( ( v_ice (ji,jj) - v_oce (ji,jj) ) * ( v_ice (ji,jj) - v_oce (ji,jj) )  &
+                     &                              + ( u_iceV(ji,jj) - u_oceV(ji,jj) ) * ( u_iceV(ji,jj) - u_oceV(ji,jj) ) )
+                  !                 !--- Ocean-to-Ice stress
+                  ztauy_oi(ji,jj) = zTauO * ( v_oce(ji,jj) - v_ice(ji,jj) )
+                  !
+                  !                 !--- tau_bottom/v_ice
+                  zvel  = MAX( zepsi, SQRT( v_ice(ji,jj) * v_ice(ji,jj) + u_iceV(ji,jj) * u_iceV(ji,jj) ) )
+                  ztauB = - tau_icebfr(ji,jj) / zvel
+                  !
+                  !                 !--- Coriolis at v-points (energy conserving formulation)
+                  zCory(ji,jj)  = - 0.25_wp * r1_e2v(ji,jj) *  &
+                     &    ( zmf(ji,jj  ) * ( e2u(ji,jj  ) * u_ice(ji,jj  ) + e2u(ji-1,jj  ) * u_ice(ji-1,jj  ) )  &
+                     &    + zmf(ji,jj+1) * ( e2u(ji,jj+1) * u_ice(ji,jj+1) + e2u(ji-1,jj+1) * u_ice(ji-1,jj+1) ) )
+                  !
+                  !                 !--- Sum of external forces (explicit solution) = F + tau_ia + Coriolis + spg + tau_io
+                  zTauE = zfV(ji,jj) + zTauV_ia(ji,jj) + zCory(ji,jj) + zspgV(ji,jj) + ztauy_oi(ji,jj)
+                  !
+                  !                 !--- landfast switch => 0 = static friction ; 1 = sliding friction
+                  rswitch = 1._wp - MIN( 1._wp, ABS( SIGN( 1._wp, zTauE - tau_icebfr(ji,jj) ) - SIGN( 1._wp, zTauE ) ) )
+                  !
+                  IF( ln_aEVP ) THEN !--- ice velocity using aEVP (Kimmritz et al 2016 & 2017)
+                  v_ice(ji,jj) = ( (          rswitch * ( zmV_t(ji,jj) * ( zbeta(ji,jj) * v_ice(ji,jj) + v_ice_b(ji,jj) )         & ! previous velocity
+                     &                                  + zTauE + zTauO * v_ice(ji,jj)                                            & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part)
+                     &                                  ) / MAX( zepsi, zmV_t(ji,jj) * ( zbeta(ji,jj) + 1._wp ) + zTauO - zTauB ) & ! m/dt + tau_io(only ice part) + landfast
+                     &                 + ( 1._wp - rswitch ) * v_ice(ji,jj) * MAX( 0._wp, 1._wp - zdtevp * rn_lfrelax )           & ! static friction => slow decrease to v=0
+                     &             ) * zswitchV(ji,jj) + v_oce(ji,jj) * ( 1._wp - zswitchV(ji,jj) )                               & ! v_ice = v_oce if mass < zmmin
+                     &           ) * zmaskV(ji,jj)
+                  ELSE               !--- ice velocity using EVP implicit formulation (cf Madec doc & Bouillon 2009)
+                  v_ice(ji,jj) = ( (           rswitch   * ( zmV_t(ji,jj)  * v_ice(ji,jj)                             &  ! previous velocity
+                     &                                     + zTauE + zTauO * v_ice(ji,jj)                             &  ! F + tau_ia + Coriolis + spg + tau_io(only ocean part)
+                     &                                     ) / MAX( zepsi, zmV_t(ji,jj) + zTauO - zTauB )             &  ! m/dt + tau_io(only ice part) + landfast
+                     &              + ( 1._wp - rswitch ) * v_ice(ji,jj) * MAX( 0._wp, 1._wp - zdtevp * rn_lfrelax )  &  ! static friction => slow decrease to v=0
+                     &              ) * zswitchV(ji,jj) + v_oce(ji,jj) * ( 1._wp - zswitchV(ji,jj) )                  &  ! v_ice = v_oce if mass < zmmin
+                     &            ) * zmaskV(ji,jj)
+                  ENDIF
+               END DO
+            END DO
+            CALL lbc_lnk( v_ice, 'V', -1. )
+            !
+#if defined key_agrif
+!!            CALL agrif_interp_si3( 'V', jter, nn_nevp )
+            CALL agrif_interp_si3( 'V' )
+#endif
+            IF( ln_bdy ) CALL bdy_ice_dyn( 'V' )
+            !
+         ENDIF
+         
+         IF(ln_ctl) THEN   ! Convergence test
+            DO jj = 2 , jpjm1
+               zresr(:,jj) = MAX( ABS( u_ice(:,jj) - zu_ice(:,jj) ), ABS( v_ice(:,jj) - zv_ice(:,jj) ) )
+            END DO
+            zresm = MAXVAL( zresr( 1:jpi, 2:jpjm1 ) )
+            IF( lk_mpp )   CALL mpp_max( zresm )   ! max over the global domain
+         ENDIF
+         !
+         !                                                ! ==================== !
+      END DO                                              !  end loop over jter  !
+      !                                                   ! ==================== !
+      !
+      !------------------------------------------------------------------------------!
+      ! 4) Recompute delta, shear and div (inputs for mechanical redistribution) 
+      !------------------------------------------------------------------------------!
+      DO jj = 1, jpjm1
+         DO ji = 1, jpim1
+
+            ! shear at F points
+            zds(ji,jj) = ( ( u_ice(ji,jj+1) * r1_e1u(ji,jj+1) - u_ice(ji,jj) * r1_e1u(ji,jj) ) * e1f(ji,jj) * e1f(ji,jj)   &
+               &         + ( v_ice(ji+1,jj) * r1_e2v(ji+1,jj) - v_ice(ji,jj) * r1_e2v(ji,jj) ) * e2f(ji,jj) * e2f(ji,jj)   &
+               &         ) * r1_e1e2f(ji,jj) * zfmask(ji,jj)
+
+         END DO
+      END DO           
+      
+      DO jj = 2, jpjm1
+         DO ji = 2, jpim1 ! no vector loop
+            
+            ! tension**2 at T points
+            zdt  = ( ( u_ice(ji,jj) * r1_e2u(ji,jj) - u_ice(ji-1,jj) * r1_e2u(ji-1,jj) ) * e2t(ji,jj) * e2t(ji,jj)   &
+               &   - ( v_ice(ji,jj) * r1_e1v(ji,jj) - v_ice(ji,jj-1) * r1_e1v(ji,jj-1) ) * e1t(ji,jj) * e1t(ji,jj)   &
+               &   ) * r1_e1e2t(ji,jj)
+            zdt2 = zdt * zdt
+            
+            ! shear**2 at T points (doc eq. A16)
+            zds2 = ( zds(ji,jj  ) * zds(ji,jj  ) * e1e2f(ji,jj  ) + zds(ji-1,jj  ) * zds(ji-1,jj  ) * e1e2f(ji-1,jj  )  &
+               &   + zds(ji,jj-1) * zds(ji,jj-1) * e1e2f(ji,jj-1) + zds(ji-1,jj-1) * zds(ji-1,jj-1) * e1e2f(ji-1,jj-1)  &
+               &   ) * 0.25_wp * r1_e1e2t(ji,jj)
+            
+            ! shear at T points
+            pshear_i(ji,jj) = SQRT( zdt2 + zds2 )
+
+            ! divergence at T points
+            pdivu_i(ji,jj) = ( e2u(ji,jj) * u_ice(ji,jj) - e2u(ji-1,jj) * u_ice(ji-1,jj)   &
+               &             + e1v(ji,jj) * v_ice(ji,jj) - e1v(ji,jj-1) * v_ice(ji,jj-1)   &
+               &             ) * r1_e1e2t(ji,jj)
+            
+            ! delta at T points
+            zdelta         = SQRT( pdivu_i(ji,jj) * pdivu_i(ji,jj) + ( zdt2 + zds2 ) * z1_ecc2 )  
+            rswitch        = 1._wp - MAX( 0._wp, SIGN( 1._wp, -zdelta ) ) ! 0 if delta=0
+            pdelta_i(ji,jj) = zdelta + rn_creepl * rswitch
+
+         END DO
+      END DO
+      CALL lbc_lnk_multi( pshear_i, 'T', 1., pdivu_i, 'T', 1., pdelta_i, 'T', 1. )
+      
+      ! --- Store the stress tensor for the next time step --- !
+      CALL lbc_lnk_multi( zs1, 'T', 1., zs2, 'T', 1., zs12, 'F', 1. )
+      pstress1_i (:,:) = zs1 (:,:)
+      pstress2_i (:,:) = zs2 (:,:)
+      pstress12_i(:,:) = zs12(:,:)
+      !
+
+      !------------------------------------------------------------------------------!
+      ! 5) diagnostics
+      !------------------------------------------------------------------------------!
+      DO jj = 1, jpj
+         DO ji = 1, jpi
+            zswi(ji,jj) = MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) - epsi06 ) ) ! 1 if ice, 0 if no ice
+         END DO
+      END DO
+
+      ! --- divergence, shear and strength --- !
+      IF( iom_use('icediv') )   CALL iom_put( "icediv" , pdivu_i (:,:) * zswi(:,:) )   ! divergence
+      IF( iom_use('iceshe') )   CALL iom_put( "iceshe" , pshear_i(:,:) * zswi(:,:) )   ! shear
+      IF( iom_use('icestr') )   CALL iom_put( "icestr" , strength(:,:) * zswi(:,:) )   ! Ice strength
+
+      ! --- charge ellipse --- !
+      IF( iom_use('isig1') .OR. iom_use('isig2') .OR. iom_use('isig3') ) THEN
+         !
+         ALLOCATE( zsig1(jpi,jpj) , zsig2(jpi,jpj) , zsig3(jpi,jpj) )
+         !         
+         DO jj = 2, jpjm1
+            DO ji = 2, jpim1
+               zdum1 = ( zswi(ji-1,jj) * pstress12_i(ji-1,jj) + zswi(ji  ,jj-1) * pstress12_i(ji  ,jj-1) +  &  ! stress12_i at T-point
+                  &      zswi(ji  ,jj) * pstress12_i(ji  ,jj) + zswi(ji-1,jj-1) * pstress12_i(ji-1,jj-1) )  &
+                  &    / MAX( 1._wp, zswi(ji-1,jj) + zswi(ji,jj-1) + zswi(ji,jj) + zswi(ji-1,jj-1) )
+
+               zshear = SQRT( pstress2_i(ji,jj) * pstress2_i(ji,jj) + 4._wp * zdum1 * zdum1 ) ! shear stress  
+
+               zdum2 = zswi(ji,jj) / MAX( 1._wp, strength(ji,jj) )
+
+!!               zsig1(ji,jj) = 0.5_wp * zdum2 * ( pstress1_i(ji,jj) + zshear ) ! principal stress (y-direction, see Hunke & Dukowicz 2002)
+!!               zsig2(ji,jj) = 0.5_wp * zdum2 * ( pstress1_i(ji,jj) - zshear ) ! principal stress (x-direction, see Hunke & Dukowicz 2002)
+!!               zsig3(ji,jj) = zdum2**2 * ( ( pstress1_i(ji,jj) + strength(ji,jj) )**2 + ( rn_ecc * zshear )**2 ) ! quadratic relation linking compressive stress to shear stress
+!!                                                                                                               ! (scheme converges if this value is ~1, see Bouillon et al 2009 (eq. 11))
+               zsig1(ji,jj) = 0.5_wp * zdum2 * ( pstress1_i(ji,jj) )          ! compressive stress, see Bouillon et al. 2015
+               zsig2(ji,jj) = 0.5_wp * zdum2 * ( zshear )                     ! shear stress
+               zsig3(ji,jj) = zdum2**2 * ( ( pstress1_i(ji,jj) + strength(ji,jj) )**2 + ( rn_ecc * zshear )**2 )
+            END DO
+         END DO
+         CALL lbc_lnk_multi( zsig1, 'T', 1., zsig2, 'T', 1., zsig3, 'T', 1. )
+         !
+         IF( iom_use('isig1') )   CALL iom_put( "isig1" , zsig1 )
+         IF( iom_use('isig2') )   CALL iom_put( "isig2" , zsig2 )
+         IF( iom_use('isig3') )   CALL iom_put( "isig3" , zsig3 )
+         !
+         DEALLOCATE( zsig1 , zsig2 , zsig3 )
+      ENDIF
+      
+      ! --- SIMIP --- !
+      IF ( iom_use( 'normstr'  ) .OR. iom_use( 'sheastr'  ) .OR. iom_use( 'dssh_dx'  ) .OR. iom_use( 'dssh_dy'  ) .OR. &
+         & iom_use( 'corstrx'  ) .OR. iom_use( 'corstry'  ) .OR. iom_use( 'intstrx'  ) .OR. iom_use( 'intstry'  ) .OR. &
+         & iom_use( 'utau_oi'  ) .OR. iom_use( 'vtau_oi'  ) .OR. iom_use( 'xmtrpice' ) .OR. iom_use( 'ymtrpice' ) .OR. &
+         & iom_use( 'xmtrpsnw' ) .OR. iom_use( 'ymtrpsnw' ) .OR. iom_use( 'xatrp'    ) .OR. iom_use( 'yatrp'    ) ) THEN
+
+         ALLOCATE( zdiag_sig1     (jpi,jpj) , zdiag_sig2     (jpi,jpj) , zdiag_dssh_dx  (jpi,jpj) , zdiag_dssh_dy  (jpi,jpj) ,  &
+            &      zdiag_corstrx  (jpi,jpj) , zdiag_corstry  (jpi,jpj) , zdiag_intstrx  (jpi,jpj) , zdiag_intstry  (jpi,jpj) ,  &
+            &      zdiag_utau_oi  (jpi,jpj) , zdiag_vtau_oi  (jpi,jpj) , zdiag_xmtrp_ice(jpi,jpj) , zdiag_ymtrp_ice(jpi,jpj) ,  &
+            &      zdiag_xmtrp_snw(jpi,jpj) , zdiag_ymtrp_snw(jpi,jpj) , zdiag_xatrp    (jpi,jpj) , zdiag_yatrp    (jpi,jpj) )
+         
+         DO jj = 2, jpjm1
+            DO ji = 2, jpim1
+               rswitch  = MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) - epsi06 ) ) ! 1 if ice, 0 if no ice
+               
+               ! Stress tensor invariants (normal and shear stress N/m)
+               zdiag_sig1(ji,jj) = ( zs1(ji,jj) + zs2(ji,jj) ) * rswitch                                 ! normal stress
+               zdiag_sig2(ji,jj) = SQRT( ( zs1(ji,jj) - zs2(ji,jj) )**2 + 4*zs12(ji,jj)**2 ) * rswitch   ! shear stress
+               
+               ! Stress terms of the momentum equation (N/m2)
+               zdiag_dssh_dx(ji,jj) = zspgU(ji,jj) * rswitch     ! sea surface slope stress term
+               zdiag_dssh_dy(ji,jj) = zspgV(ji,jj) * rswitch
+               
+               zdiag_corstrx(ji,jj) = zCorx(ji,jj) * rswitch     ! Coriolis stress term
+               zdiag_corstry(ji,jj) = zCory(ji,jj) * rswitch
+               
+               zdiag_intstrx(ji,jj) = zfU(ji,jj)   * rswitch     ! internal stress term
+               zdiag_intstry(ji,jj) = zfV(ji,jj)   * rswitch
+               
+               zdiag_utau_oi(ji,jj) = ztaux_oi(ji,jj) * rswitch  ! oceanic stress
+               zdiag_vtau_oi(ji,jj) = ztauy_oi(ji,jj) * rswitch
+               
+               ! 2D ice mass, snow mass, area transport arrays (X, Y)
+               zfac_x = 0.5 * u_ice(ji,jj) * e2u(ji,jj) * rswitch
+               zfac_y = 0.5 * v_ice(ji,jj) * e1v(ji,jj) * rswitch
+               
+               zdiag_xmtrp_ice(ji,jj) = rhoic * zfac_x * ( vt_i(ji+1,jj) + vt_i(ji,jj) ) ! ice mass transport, X-component
+               zdiag_ymtrp_ice(ji,jj) = rhoic * zfac_y * ( vt_i(ji,jj+1) + vt_i(ji,jj) ) !        ''           Y-   ''
+               
+               zdiag_xmtrp_snw(ji,jj) = rhosn * zfac_x * ( vt_s(ji+1,jj) + vt_s(ji,jj) ) ! snow mass transport, X-component
+               zdiag_ymtrp_snw(ji,jj) = rhosn * zfac_y * ( vt_s(ji,jj+1) + vt_s(ji,jj) ) !          ''          Y-   ''
+               
+               zdiag_xatrp(ji,jj)     = zfac_x * ( at_i(ji+1,jj) + at_i(ji,jj) )         ! area transport,      X-component
+               zdiag_yatrp(ji,jj)     = zfac_y * ( at_i(ji,jj+1) + at_i(ji,jj) )         !        ''            Y-   ''
+               
+            END DO
+         END DO
+         
+         CALL lbc_lnk_multi( zdiag_sig1   , 'T',  1., zdiag_sig2   , 'T',  1.,   &
+            &                zdiag_dssh_dx, 'U', -1., zdiag_dssh_dy, 'V', -1.,   &
+            &                zdiag_corstrx, 'U', -1., zdiag_corstry, 'V', -1.,   & 
+            &                zdiag_intstrx, 'U', -1., zdiag_intstry, 'V', -1.    )
+                  
+         CALL lbc_lnk_multi( zdiag_utau_oi  , 'U', -1., zdiag_vtau_oi  , 'V', -1.,   &
+            &                zdiag_xmtrp_ice, 'U', -1., zdiag_xmtrp_snw, 'U', -1.,   &
+            &                zdiag_xatrp    , 'U', -1., zdiag_ymtrp_ice, 'V', -1.,   &
+            &                zdiag_ymtrp_snw, 'V', -1., zdiag_yatrp    , 'V', -1.    )
+         
+         IF( iom_use('normstr' ) )   CALL iom_put( 'normstr'  ,  zdiag_sig1(:,:)      )   ! Normal stress
+         IF( iom_use('sheastr' ) )   CALL iom_put( 'sheastr'  ,  zdiag_sig2(:,:)      )   ! Shear stress
+         IF( iom_use('dssh_dx' ) )   CALL iom_put( 'dssh_dx'  ,  zdiag_dssh_dx(:,:)   )   ! Sea-surface tilt term in force balance (x)
+         IF( iom_use('dssh_dy' ) )   CALL iom_put( 'dssh_dy'  ,  zdiag_dssh_dy(:,:)   )   ! Sea-surface tilt term in force balance (y)
+         IF( iom_use('corstrx' ) )   CALL iom_put( 'corstrx'  ,  zdiag_corstrx(:,:)   )   ! Coriolis force term in force balance (x)
+         IF( iom_use('corstry' ) )   CALL iom_put( 'corstry'  ,  zdiag_corstry(:,:)   )   ! Coriolis force term in force balance (y)
+         IF( iom_use('intstrx' ) )   CALL iom_put( 'intstrx'  ,  zdiag_intstrx(:,:)   )   ! Internal force term in force balance (x)
+         IF( iom_use('intstry' ) )   CALL iom_put( 'intstry'  ,  zdiag_intstry(:,:)   )   ! Internal force term in force balance (y)
+         IF( iom_use('utau_oi' ) )   CALL iom_put( 'utau_oi'  ,  zdiag_utau_oi(:,:)   )   ! Ocean stress term in force balance (x)
+         IF( iom_use('vtau_oi' ) )   CALL iom_put( 'vtau_oi'  ,  zdiag_vtau_oi(:,:)   )   ! Ocean stress term in force balance (y)
+         IF( iom_use('xmtrpice') )   CALL iom_put( 'xmtrpice' ,  zdiag_xmtrp_ice(:,:) )   ! X-component of sea-ice mass transport (kg/s)
+         IF( iom_use('ymtrpice') )   CALL iom_put( 'ymtrpice' ,  zdiag_ymtrp_ice(:,:) )   ! Y-component of sea-ice mass transport 
+         IF( iom_use('xmtrpsnw') )   CALL iom_put( 'xmtrpsnw' ,  zdiag_xmtrp_snw(:,:) )   ! X-component of snow mass transport (kg/s)
+         IF( iom_use('ymtrpsnw') )   CALL iom_put( 'ymtrpsnw' ,  zdiag_ymtrp_snw(:,:) )   ! Y-component of snow mass transport
+         IF( iom_use('xatrp'   ) )   CALL iom_put( 'xatrp'    ,  zdiag_xatrp(:,:)     )   ! X-component of ice area transport
+         IF( iom_use('yatrp'   ) )   CALL iom_put( 'yatrp'    ,  zdiag_yatrp(:,:)     )   ! Y-component of ice area transport
+
+         DEALLOCATE( zdiag_sig1      , zdiag_sig2      , zdiag_dssh_dx   , zdiag_dssh_dy   ,  &
+            &        zdiag_corstrx   , zdiag_corstry   , zdiag_intstrx   , zdiag_intstry   ,  &
+            &        zdiag_utau_oi   , zdiag_vtau_oi   , zdiag_xmtrp_ice , zdiag_ymtrp_ice ,  &
+            &        zdiag_xmtrp_snw , zdiag_ymtrp_snw , zdiag_xatrp     , zdiag_yatrp     )
+
+      ENDIF
+      !
+   END SUBROUTINE ice_dyn_rhg_evp
+
+
+   SUBROUTINE rhg_evp_rst( cdrw, kt )
+      !!---------------------------------------------------------------------
+      !!                   ***  ROUTINE rhg_evp_rst  ***
+      !!                     
+      !! ** Purpose :   Read or write RHG file in restart file
+      !!
+      !! ** Method  :   use of IOM library
+      !!----------------------------------------------------------------------
+      CHARACTER(len=*) , INTENT(in) ::   cdrw   ! "READ"/"WRITE" flag
+      INTEGER, OPTIONAL, INTENT(in) ::   kt     ! ice time-step
+      !
+      INTEGER  ::   iter            ! local integer
+      INTEGER  ::   id1, id2, id3   ! local integers
+      !!----------------------------------------------------------------------
+      !
+      IF( TRIM(cdrw) == 'READ' ) THEN        ! Read/initialize
+         !                                   ! ---------------
+         IF( ln_rstart ) THEN                   !* Read the restart file
+            !
+            id1 = iom_varid( numrir, 'stress1_i' , ldstop = .FALSE. )
+            id2 = iom_varid( numrir, 'stress2_i' , ldstop = .FALSE. )
+            id3 = iom_varid( numrir, 'stress12_i', ldstop = .FALSE. )
+            !
+            IF( MIN( id1, id2, id3 ) > 0 ) THEN      ! fields exist
+               CALL iom_get( numrir, jpdom_autoglo, 'stress1_i' , stress1_i  )
+               CALL iom_get( numrir, jpdom_autoglo, 'stress2_i' , stress2_i  )
+               CALL iom_get( numrir, jpdom_autoglo, 'stress12_i', stress12_i )
+            ELSE                                     ! start rheology from rest
+               IF(lwp) WRITE(numout,*)
+               IF(lwp) WRITE(numout,*) '   ==>>>   previous run without rheology, set stresses to 0'
+               stress1_i (:,:) = 0._wp
+               stress2_i (:,:) = 0._wp
+               stress12_i(:,:) = 0._wp
+            ENDIF
+         ELSE                                   !* Start from rest
+            IF(lwp) WRITE(numout,*)
+            IF(lwp) WRITE(numout,*) '   ==>>>   start from rest: set stresses to 0'
+            stress1_i (:,:) = 0._wp
+            stress2_i (:,:) = 0._wp
+            stress12_i(:,:) = 0._wp
+         ENDIF
+         !
+      ELSEIF( TRIM(cdrw) == 'WRITE' ) THEN   ! Create restart file
+         !                                   ! -------------------
+         IF(lwp) WRITE(numout,*) '---- rhg-rst ----'
+         iter = kt + nn_fsbc - 1             ! ice restarts are written at kt == nitrst - nn_fsbc + 1
+         !
+         CALL iom_rstput( iter, nitrst, numriw, 'stress1_i' , stress1_i  )
+         CALL iom_rstput( iter, nitrst, numriw, 'stress2_i' , stress2_i  )
+         CALL iom_rstput( iter, nitrst, numriw, 'stress12_i', stress12_i )
+         !
+      ENDIF
+      !
+   END SUBROUTINE rhg_evp_rst
+
+#else
+   !!----------------------------------------------------------------------
+   !!   Default option         Empty module           NO SI3 sea-ice model
+   !!----------------------------------------------------------------------
+#endif
+
+   !!==============================================================================
+END MODULE icedyn_rhg_evp
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/ICE_SRC/iceforcing.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/ICE_SRC/iceforcing.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/ICE_SRC/iceforcing.F90	(revision 9570)
@@ -0,0 +1,316 @@
+MODULE iceforcing
+   !!======================================================================
+   !!                       ***  MODULE  iceforcing  ***
+   !! Sea-Ice :   air-ice forcing fields
+   !!=====================================================================
+   !! History :  4.0  ! 2017-08  (C. Rousset) Original code
+   !!----------------------------------------------------------------------
+#if defined key_si3
+   !!----------------------------------------------------------------------
+   !!   'key_si3' :                                     SI3 sea-ice model
+   !!----------------------------------------------------------------------
+   USE oce            ! ocean dynamics and tracers
+   USE dom_oce        ! ocean space and time domain
+   USE ice            ! sea-ice: variables
+   USE sbc_oce        ! Surface boundary condition: ocean fields
+   USE sbc_ice        ! Surface boundary condition: ice   fields
+   USE usrdef_sbc     ! Surface boundary condition: user defined
+   USE sbcblk         ! Surface boundary condition: bulk
+   USE sbccpl         ! Surface boundary condition: coupled interface
+   USE icealb         ! sea-ice: albedo
+   !
+   USE in_out_manager ! I/O manager
+   USE iom            ! I/O manager library
+   USE lib_mpp        ! MPP library
+   USE lib_fortran    ! fortran utilities (glob_sum + no signed zero)
+   USE lbclnk         ! lateral boundary conditions (or mpp links)
+   USE timing         ! Timing
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC ice_forcing_tau   ! called by icestp.F90
+   PUBLIC ice_forcing_flx   ! called by icestp.F90
+   PUBLIC ice_forcing_init  ! called by icestp.F90
+
+   !! * Substitutions
+#  include "vectopt_loop_substitute.h90"
+   !!----------------------------------------------------------------------
+   !! NEMO/ICE 4.0 , UCL NEMO Consortium (2017)
+   !! $Id: icestp.F90 8319 2017-07-11 15:00:44Z clem $
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE ice_forcing_tau( kt, ksbc, utau_ice, vtau_ice )
+      !!-------------------------------------------------------------------
+      !!                  ***  ROUTINE ice_forcing_tau  ***
+      !!
+      !! ** Purpose : provide surface boundary condition for sea ice (momentum)
+      !!
+      !! ** Action  : It provides the following fields:
+      !!              utau_ice, vtau_ice : surface ice stress (U- & V-points) [N/m2]
+      !!-------------------------------------------------------------------
+      INTEGER                     , INTENT(in   ) ::   kt                   ! ocean time step
+      INTEGER                     , INTENT(in   ) ::   ksbc                 ! type of sbc flux
+      REAL(wp), DIMENSION(jpi,jpj), INTENT(  out) ::   utau_ice, vtau_ice   ! air-ice stress   [N/m2]
+      !!
+      INTEGER  ::   ji, jj                 ! dummy loop index
+      REAL(wp), DIMENSION(jpi,jpj) ::   zutau_ice, zvtau_ice 
+      !!-------------------------------------------------------------------
+      !
+      IF( ln_timing )   CALL timing_start('ice_forcing')
+      !
+      IF( kt == nit000 .AND. lwp ) THEN
+         WRITE(numout,*)
+         WRITE(numout,*)'ice_forcing_tau: Surface boundary condition for sea ice (momentum)'
+         WRITE(numout,*)'~~~~~~~~~~~~~~~'
+      ENDIF
+      !
+      SELECT CASE( ksbc )
+         CASE( jp_usr     )   ;    CALL usrdef_sbc_ice_tau( kt )                 ! user defined formulation
+         CASE( jp_blk     )   ;    CALL blk_ice_tau                              ! Bulk         formulation
+         CASE( jp_purecpl )   ;    CALL sbc_cpl_ice_tau( utau_ice , vtau_ice )   ! Coupled      formulation
+      END SELECT
+      !
+      IF( ln_mixcpl) THEN                                                        ! Case of a mixed Bulk/Coupled formulation
+                                   CALL sbc_cpl_ice_tau( zutau_ice , zvtau_ice )
+         DO jj = 2, jpjm1
+            DO ji = 2, jpim1
+               utau_ice(ji,jj) = utau_ice(ji,jj) * xcplmask(ji,jj,0) + zutau_ice(ji,jj) * ( 1. - xcplmask(ji,jj,0) )
+               vtau_ice(ji,jj) = vtau_ice(ji,jj) * xcplmask(ji,jj,0) + zvtau_ice(ji,jj) * ( 1. - xcplmask(ji,jj,0) )
+            END DO
+         END DO
+         CALL lbc_lnk_multi( utau_ice, 'U', -1., vtau_ice, 'V', -1. )
+      ENDIF
+      !
+      IF( ln_timing )   CALL timing_stop('ice_forcing')
+      !
+   END SUBROUTINE ice_forcing_tau
+
+   
+   SUBROUTINE ice_forcing_flx( kt, ksbc )
+      !!-------------------------------------------------------------------
+      !!                  ***  ROUTINE ice_forcing_flx  ***
+      !!
+      !! ** Purpose : provide surface boundary condition for sea ice (flux)
+      !!
+      !! ** Action  : It provides the following fields used in sea ice model:
+      !!                emp_oce , emp_ice                        = E-P over ocean and sea ice                    [Kg/m2/s]
+      !!                sprecip                                  = solid precipitation                           [Kg/m2/s]
+      !!                evap_ice                                 = sublimation                                   [Kg/m2/s]
+      !!                qsr_tot , qns_tot                        = solar & non solar heat flux (total)           [W/m2]
+      !!                qsr_ice , qns_ice                        = solar & non solar heat flux over ice          [W/m2]
+      !!                dqns_ice                                 = non solar  heat sensistivity                  [W/m2]
+      !!                qemp_oce, qemp_ice, qprec_ice, qevap_ice = sensible heat (associated with evap & precip) [W/m2]
+      !!            + some fields that are not used outside this module: 
+      !!                qla_ice                                  = latent heat flux over ice                     [W/m2]
+      !!                dqla_ice                                 = latent heat sensistivity                      [W/m2]
+      !!                tprecip                                  = total  precipitation                          [Kg/m2/s]
+      !!                alb_ice                                  = albedo above sea ice
+      !!-------------------------------------------------------------------
+      INTEGER, INTENT(in) ::   kt     ! ocean time step
+      INTEGER, INTENT(in) ::   ksbc   ! flux formulation (user defined, bulk or Pure Coupled)
+      !
+      INTEGER  ::   ji, jj, jl                                ! dummy loop index
+      REAL(wp), DIMENSION(jpi,jpj,jpl) ::   zalb_os, zalb_cs  ! ice albedo under overcast/clear sky
+      REAL(wp), DIMENSION(jpi,jpj)     ::   zalb              ! 2D workspace
+      !!--------------------------------------------------------------------
+      !
+      IF( ln_timing )   CALL timing_start('ice_forcing_flx')
+
+      IF( kt == nit000 .AND. lwp ) THEN
+         WRITE(numout,*)
+         WRITE(numout,*)'ice_forcing_flx: Surface boundary condition for sea ice (flux)'
+         WRITE(numout,*)'~~~~~~~~~~~~~~~'
+      ENDIF
+
+      ! --- cloud-sky and overcast-sky ice albedos --- !
+      CALL ice_alb( t_su, h_i, h_s, ln_pnd_alb, a_ip_frac, h_ip, zalb_cs, zalb_os )
+
+      ! albedo depends on cloud fraction because of non-linear spectral effects
+!!gm cldf_ice is a real, DOCTOR naming rule: start with cd means CHARACTER passed in argument !
+      alb_ice(:,:,:) = ( 1. - cldf_ice ) * zalb_cs(:,:,:) + cldf_ice * zalb_os(:,:,:)
+      !
+      !
+      SELECT CASE( ksbc )   !== fluxes over sea ice ==!
+      !
+      CASE( jp_usr )              !--- user defined formulation
+                                  CALL usrdef_sbc_ice_flx( kt, h_s, h_i )
+      CASE( jp_blk )              !--- bulk formulation
+                                  CALL blk_ice_flx    ( t_su, h_s, h_i, alb_ice )    ! 
+         IF( ln_mixcpl        )   CALL sbc_cpl_ice_flx( picefr=at_i_b, palbi=alb_ice, psst=sst_m, pist=t_su, phs=h_s, phi=h_i )
+         IF( nn_flxdist /= -1 )   CALL ice_flx_dist   ( t_su, alb_ice, qns_ice, qsr_ice, dqns_ice, evap_ice, devap_ice, nn_flxdist )
+         SELECT CASE( nice_jules )
+         CASE( np_jules_ACTIVE )  !    compute conduction flux and surface temperature (as in Jules surface module)
+                                  CALL blk_ice_qcn    ( nn_virtual_itd, t_su, t_bo, h_s, h_i )
+         END SELECT
+      CASE ( jp_purecpl )         !--- coupled formulation
+                                  CALL sbc_cpl_ice_flx( picefr=at_i_b, palbi=alb_ice, psst=sst_m, pist=t_su, phs=h_s, phi=h_i )
+         IF( nn_flxdist /= -1 )   CALL ice_flx_dist   ( t_su, alb_ice, qns_ice, qsr_ice, dqns_ice, evap_ice, devap_ice, nn_flxdist )
+      END SELECT
+
+      !--- output ice albedo and surface albedo ---!
+      IF( iom_use('icealb') ) THEN
+         WHERE( at_i_b <= epsi06 )   ;   zalb(:,:) = rn_alb_oce
+         ELSEWHERE                   ;   zalb(:,:) = SUM( alb_ice * a_i_b, dim=3 ) / at_i_b
+         END WHERE
+         CALL iom_put( "icealb" , zalb(:,:) )
+      ENDIF
+      IF( iom_use('albedo') ) THEN
+         zalb(:,:) = SUM( alb_ice * a_i_b, dim=3 ) + rn_alb_oce * ( 1._wp - at_i_b )
+         CALL iom_put( "albedo" , zalb(:,:) )
+      ENDIF
+      !
+      IF( ln_timing )   CALL timing_stop('ice_forcing_flx')
+      !
+   END SUBROUTINE ice_forcing_flx
+
+
+   SUBROUTINE ice_flx_dist( ptn_ice, palb_ice, pqns_ice, pqsr_ice, pdqn_ice, pevap_ice, pdevap_ice, k_iceflx )
+      !!-------------------------------------------------------------------
+      !!                  ***  ROUTINE ice_flx_dist  ***
+      !!
+      !! ** Purpose :   update the ice surface boundary condition by averaging 
+      !!              and/or redistributing fluxes on ice categories
+      !!
+      !! ** Method  :   average then redistribute
+      !!
+      !! ** Action  :   depends on k_iceflx
+      !!                = -1  Do nothing (needs N(cat) fluxes)
+      !!                =  0  Average N(cat) fluxes then apply the average over the N(cat) ice 
+      !!                =  1  Average N(cat) fluxes then redistribute over the N(cat) ice
+      !!                                                 using T-ice and albedo sensitivity
+      !!                =  2  Redistribute a single flux over categories
+      !!-------------------------------------------------------------------
+      INTEGER                   , INTENT(in   ) ::   k_iceflx   ! redistributor
+      REAL(wp), DIMENSION(:,:,:), INTENT(in   ) ::   ptn_ice    ! ice surface temperature
+      REAL(wp), DIMENSION(:,:,:), INTENT(in   ) ::   palb_ice   ! ice albedo
+      REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   pqns_ice   ! non solar flux
+      REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   pqsr_ice   ! net solar flux
+      REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   pdqn_ice   ! non solar flux sensitivity
+      REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   pevap_ice  ! sublimation
+      REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   pdevap_ice ! sublimation sensitivity
+      !
+      INTEGER  ::   jl      ! dummy loop index
+      !
+      REAL(wp), DIMENSION(jpi,jpj) ::   z1_at_i   ! inverse of concentration
+      !
+      REAL(wp), ALLOCATABLE, DIMENSION(:,:) ::   z_qsr_m   ! Mean solar heat flux over all categories
+      REAL(wp), ALLOCATABLE, DIMENSION(:,:) ::   z_qns_m   ! Mean non solar heat flux over all categories
+      REAL(wp), ALLOCATABLE, DIMENSION(:,:) ::   z_evap_m  ! Mean sublimation over all categories
+      REAL(wp), ALLOCATABLE, DIMENSION(:,:) ::   z_dqn_m   ! Mean d(qns)/dT over all categories
+      REAL(wp), ALLOCATABLE, DIMENSION(:,:) ::   z_devap_m ! Mean d(evap)/dT over all categories
+      REAL(wp), ALLOCATABLE, DIMENSION(:,:) ::   zalb_m    ! Mean albedo over all categories
+      REAL(wp), ALLOCATABLE, DIMENSION(:,:) ::   ztem_m    ! Mean temperature over all categories
+      !!----------------------------------------------------------------------
+      !
+      WHERE ( at_i (:,:) > 0._wp )   ; z1_at_i(:,:) = 1._wp / at_i (:,:)
+      ELSEWHERE                      ; z1_at_i(:,:) = 0._wp
+      END WHERE
+      
+      SELECT CASE( k_iceflx )       !==  averaged on all ice categories  ==!
+      !
+      CASE( 0 , 1 )
+         !
+         ALLOCATE( z_qns_m(jpi,jpj), z_qsr_m(jpi,jpj), z_dqn_m(jpi,jpj), z_evap_m(jpi,jpj), z_devap_m(jpi,jpj) )  
+         !
+         z_qns_m  (:,:) = SUM( a_i(:,:,:) * pqns_ice  (:,:,:) , dim=3 ) * z1_at_i(:,:)
+         z_qsr_m  (:,:) = SUM( a_i(:,:,:) * pqsr_ice  (:,:,:) , dim=3 ) * z1_at_i(:,:)
+         z_dqn_m  (:,:) = SUM( a_i(:,:,:) * pdqn_ice  (:,:,:) , dim=3 ) * z1_at_i(:,:)
+         z_evap_m (:,:) = SUM( a_i(:,:,:) * pevap_ice (:,:,:) , dim=3 ) * z1_at_i(:,:)
+         z_devap_m(:,:) = SUM( a_i(:,:,:) * pdevap_ice(:,:,:) , dim=3 ) * z1_at_i(:,:)
+         DO jl = 1, jpl
+            pqns_ice  (:,:,jl) = z_qns_m (:,:)
+            pqsr_ice  (:,:,jl) = z_qsr_m (:,:)
+            pdqn_ice  (:,:,jl) = z_dqn_m  (:,:)
+            pevap_ice (:,:,jl) = z_evap_m(:,:)
+            pdevap_ice(:,:,jl) = z_devap_m(:,:)
+         END DO
+         !
+         DEALLOCATE( z_qns_m, z_qsr_m, z_dqn_m, z_evap_m, z_devap_m )  
+         !
+      END SELECT
+      !
+      SELECT CASE( k_iceflx )       !==  redistribution on all ice categories  ==!
+      !
+      CASE( 1 , 2 )
+         !
+         ALLOCATE( zalb_m(jpi,jpj), ztem_m(jpi,jpj) )  
+         !
+         zalb_m(:,:) = SUM( a_i(:,:,:) * palb_ice(:,:,:) , dim=3 ) * z1_at_i(:,:)
+         ztem_m(:,:) = SUM( a_i(:,:,:) * ptn_ice (:,:,:) , dim=3 ) * z1_at_i(:,:)
+         DO jl = 1, jpl
+            pqns_ice (:,:,jl) = pqns_ice (:,:,jl) + pdqn_ice  (:,:,jl) * ( ptn_ice(:,:,jl) - ztem_m(:,:) )
+            pevap_ice(:,:,jl) = pevap_ice(:,:,jl) + pdevap_ice(:,:,jl) * ( ptn_ice(:,:,jl) - ztem_m(:,:) )
+            pqsr_ice (:,:,jl) = pqsr_ice (:,:,jl) * ( 1._wp - palb_ice(:,:,jl) ) / ( 1._wp - zalb_m(:,:) )
+         END DO
+         !
+         DEALLOCATE( zalb_m, ztem_m )  
+         !
+      END SELECT
+      !
+   END SUBROUTINE ice_flx_dist
+
+
+   SUBROUTINE ice_forcing_init
+      !!-------------------------------------------------------------------
+      !!                  ***  ROUTINE ice_forcing_init  ***
+      !!
+      !! ** Purpose :   Physical constants and parameters linked to the ice dynamics
+      !!      
+      !! ** Method  :   Read the namforcing namelist and check the ice-dynamic
+      !!              parameter values called at the first timestep (nit000)
+      !!
+      !! ** input   :   Namelist namforcing
+      !!-------------------------------------------------------------------
+      INTEGER ::   ios, ioptio   ! Local integer
+      !!
+      NAMELIST/namforcing/ rn_cio, rn_blow_s, nn_flxdist, nice_jules
+      !!-------------------------------------------------------------------
+      !
+      REWIND( numnam_ice_ref )         ! Namelist namforcing in reference namelist : Ice dynamics
+      READ  ( numnam_ice_ref, namforcing, IOSTAT = ios, ERR = 901)
+901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namforcing in reference namelist', lwp )
+      REWIND( numnam_ice_cfg )         ! Namelist namforcing in configuration namelist : Ice dynamics
+      READ  ( numnam_ice_cfg, namforcing, IOSTAT = ios, ERR = 902 )
+902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namforcing in configuration namelist', lwp )
+      IF(lwm) WRITE( numoni, namforcing )
+      !
+      IF(lwp) THEN                     ! control print
+         WRITE(numout,*)
+         WRITE(numout,*) 'ice_forcing_init: ice parameters for ice dynamics '
+         WRITE(numout,*) '~~~~~~~~~~~~~~~~'
+         WRITE(numout,*) '   Namelist namforcing:'
+         WRITE(numout,*) '      drag coefficient for oceanic stress              rn_cio     = ', rn_cio
+         WRITE(numout,*) '      coefficient for ice-lead partition of snowfall   rn_blow_s  = ', rn_blow_s
+         WRITE(numout,*) '      Multicategory heat flux formulation              nn_flxdist = ', nn_flxdist
+         WRITE(numout,*) '      Jules coupling (0=no, 1=emulated, 2=active)      nice_jules = ', nice_jules
+      ENDIF
+      !
+      IF(lwp) WRITE(numout,*)
+      SELECT CASE( nn_flxdist )         ! SI3 Multi-category heat flux formulation
+      CASE( -1  )
+         IF(lwp) WRITE(numout,*) '   SI3: use per-category fluxes (nn_flxdist = -1) '
+      CASE(  0  )
+         IF(lwp) WRITE(numout,*) '   SI3: use average per-category fluxes (nn_flxdist = 0) '
+      CASE(  1  )
+         IF(lwp) WRITE(numout,*) '   SI3: use average then redistribute per-category fluxes (nn_flxdist = 1) '
+         IF( ln_cpl )         CALL ctl_stop( 'ice_thd_init: the chosen nn_flxdist for SI3 in coupled mode must be /=1' )
+      CASE(  2  )
+         IF(lwp) WRITE(numout,*) '   SI3: Redistribute a single flux over categories (nn_flxdist = 2) '
+         IF( .NOT. ln_cpl )   CALL ctl_stop( 'ice_thd_init: the chosen nn_flxdist for SI3 in forced mode must be /=2' )
+      CASE DEFAULT
+         CALL ctl_stop( 'ice_thd_init: SI3 option, nn_flxdist, should be between -1 and 2' )
+      END SELECT
+      !
+   END SUBROUTINE ice_forcing_init
+
+#else
+   !!----------------------------------------------------------------------
+   !!   Default option :         Empty module         NO SI3 sea-ice model
+   !!----------------------------------------------------------------------
+#endif
+
+   !!======================================================================
+END MODULE iceforcing
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/ICE_SRC/iceistate.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/ICE_SRC/iceistate.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/ICE_SRC/iceistate.F90	(revision 9570)
@@ -0,0 +1,571 @@
+MODULE iceistate
+   !!======================================================================
+   !!                     ***  MODULE  iceistate  ***
+   !!   sea-ice : Initialization of ice variables
+   !!======================================================================
+   !! History :  2.0  ! 2004-01 (C. Ethe, G. Madec)  Original code
+   !!            3.0  ! 2007    (M. Vancoppenolle)  Rewrite for ice cats
+   !!            3.0  ! 2009-11 (M. Vancoppenolle)  Enhanced version for ice cats
+   !!            3.0  ! 2011-02 (G. Madec)  dynamical allocation
+   !!             -   ! 2014    (C. Rousset)  add N/S initializations
+   !!----------------------------------------------------------------------
+#if defined key_si3
+   !!----------------------------------------------------------------------
+   !!   'key_si3'                                       SI3 sea-ice model
+   !!----------------------------------------------------------------------
+   !!   ice_istate       :  initialization of diagnostics ice variables
+   !!   ice_istate_init  :  initialization of ice state and namelist read
+   !!----------------------------------------------------------------------
+   USE phycst         ! physical constant
+   USE oce            ! dynamics and tracers variables
+   USE dom_oce        ! ocean domain
+   USE sbc_oce , ONLY : sst_m, sss_m, ln_ice_embd 
+   USE sbc_ice , ONLY : tn_ice, snwice_mass, snwice_mass_b
+   USE eosbn2         ! equation of state
+   USE domvvl         ! Variable volume
+   USE ice            ! sea-ice variables
+   USE icevar         ! ice_var_salprof
+   !
+   USE in_out_manager ! I/O manager
+   USE iom            ! I/O manager library
+   USE lib_mpp        ! MPP library
+   USE lib_fortran    ! fortran utilities (glob_sum + no signed zero)
+   USE fldread        ! read input fields
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   ice_istate        ! called by icestp.F90
+   PUBLIC   ice_istate_init   ! called by icestp.F90
+
+   INTEGER , PARAMETER ::   jpfldi = 6           ! maximum number of files to read
+   INTEGER , PARAMETER ::   jp_hti = 1           ! index of ice thickness (m)    at T-point
+   INTEGER , PARAMETER ::   jp_hts = 2           ! index of snow thicknes (m)    at T-point
+   INTEGER , PARAMETER ::   jp_ati = 3           ! index of ice fraction (%) at T-point
+   INTEGER , PARAMETER ::   jp_tsu = 4           ! index of ice surface temp (K)    at T-point
+   INTEGER , PARAMETER ::   jp_tmi = 5           ! index of ice temp at T-point
+   INTEGER , PARAMETER ::   jp_smi = 6           ! index of ice sali at T-point
+   TYPE(FLD), ALLOCATABLE, DIMENSION(:) ::   si  ! structure of input fields (file informations, fields read)
+   !
+   !                             !! ** namelist (namini) **
+   LOGICAL  ::   ln_iceini        ! initialization or not
+   LOGICAL  ::   ln_iceini_file   ! Ice initialization state from 2D netcdf file
+   REAL(wp) ::   rn_thres_sst     ! threshold water temperature for initial sea ice
+   REAL(wp) ::   rn_hts_ini_n     ! initial snow thickness in the north
+   REAL(wp) ::   rn_hts_ini_s     ! initial snow thickness in the south
+   REAL(wp) ::   rn_hti_ini_n     ! initial ice thickness in the north
+   REAL(wp) ::   rn_hti_ini_s     ! initial ice thickness in the south
+   REAL(wp) ::   rn_ati_ini_n     ! initial leads area in the north
+   REAL(wp) ::   rn_ati_ini_s     ! initial leads area in the south
+   REAL(wp) ::   rn_smi_ini_n     ! initial salinity 
+   REAL(wp) ::   rn_smi_ini_s     ! initial salinity
+   REAL(wp) ::   rn_tmi_ini_n     ! initial temperature
+   REAL(wp) ::   rn_tmi_ini_s     ! initial temperature
+   
+   !!----------------------------------------------------------------------
+   !! NEMO/ICE 4.0 , NEMO Consortium (2017)
+   !! $Id: iceistate.F90 8378 2017-07-26 13:55:59Z clem $
+   !! Software governed by the CeCILL licence (modipsl/doc/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE ice_istate
+      !!-------------------------------------------------------------------
+      !!                    ***  ROUTINE ice_istate  ***
+      !!
+      !! ** Purpose :   defined the sea-ice initial state
+      !!
+      !! ** Method  :   This routine will put some ice where ocean
+      !!                is at the freezing point, then fill in ice 
+      !!                state variables using prescribed initial 
+      !!                values in the namelist            
+      !!
+      !! ** Steps   :   1) Set initial surface and basal temperatures
+      !!                2) Recompute or read sea ice state variables
+      !!                3) Fill in the ice thickness distribution using gaussian
+      !!                4) Fill in space-dependent arrays for state variables
+      !!                5) snow-ice mass computation
+      !!                6) store before fields
+      !!
+      !! ** Notes   : o_i, t_su, t_s, t_i, sz_i must be filled everywhere, even
+      !!              where there is no ice (clem: I do not know why, is it mandatory?) 
+      !!--------------------------------------------------------------------
+      INTEGER  ::   ji, jj, jk, jl         ! dummy loop indices
+      INTEGER  ::   i_hemis, i_fill, jl0   ! local integers
+      REAL(wp) ::   ztmelts, zdh
+      REAL(wp) ::   zarg, zV, zconv, zdv, zfac
+      INTEGER , DIMENSION(4)           ::   itest
+      REAL(wp), DIMENSION(jpi,jpj)     ::   z2d
+      REAL(wp), DIMENSION(jpi,jpj)     ::   zswitch    ! ice indicator
+      REAL(wp), DIMENSION(jpi,jpj)     ::   zht_i_ini, zat_i_ini, zvt_i_ini            !data from namelist or nc file
+      REAL(wp), DIMENSION(jpi,jpj)     ::   zts_u_ini, zht_s_ini, zsm_i_ini, ztm_i_ini !data from namelist or nc file
+      REAL(wp), DIMENSION(jpi,jpj,jpl) ::   zh_i_ini , za_i_ini                        !data by cattegories to fill
+      !--------------------------------------------------------------------
+
+      IF(lwp) WRITE(numout,*)
+      IF(lwp) WRITE(numout,*) 'ice_istate: sea-ice initialization '
+      IF(lwp) WRITE(numout,*) '~~~~~~~~~~'
+
+      !--------------------------------------------------------------------
+      ! 1) Set surface and bottom temperatures to initial values
+      !--------------------------------------------------------------------
+      !
+      ! init surface temperature
+      DO jl = 1, jpl
+         t_su   (:,:,jl) = rt0 * tmask(:,:,1)  ! temp at the surface
+         cnd_ice(:,:,jl) = 0._wp               ! initialisation of the effective conductivity at the top of ice/snow (Jules coupling)
+      END DO
+      !
+      ! init basal temperature (considered at freezing point)   [Kelvin]
+      CALL eos_fzp( sss_m(:,:), t_bo(:,:) )
+      t_bo(:,:) = ( t_bo(:,:) + rt0 ) * tmask(:,:,1) 
+
+      IF( ln_iceini ) THEN
+         !-----------------------------------------------------------
+         ! 2) Compute or read sea ice variables ===> single category
+         !-----------------------------------------------------------
+         !
+         !                             !---------------!
+         IF( ln_iceini_file )THEN      ! Read a file   !
+            !                          !---------------!
+            !
+            zht_i_ini(:,:)  = si(jp_hti)%fnow(:,:,1)
+            zht_s_ini(:,:)  = si(jp_hts)%fnow(:,:,1)
+            zat_i_ini(:,:)  = si(jp_ati)%fnow(:,:,1)
+            zts_u_ini(:,:)  = si(jp_tsu)%fnow(:,:,1)
+            ztm_i_ini(:,:)  = si(jp_tmi)%fnow(:,:,1)
+            zsm_i_ini(:,:)  = si(jp_smi)%fnow(:,:,1)
+            !
+            WHERE( zat_i_ini(:,:) > 0._wp ) ; zswitch(:,:) = tmask(:,:,1) 
+            ELSEWHERE                       ; zswitch(:,:) = 0._wp
+            END WHERE
+            zvt_i_ini(:,:) = zht_i_ini(:,:) * zat_i_ini(:,:)
+            !
+            !                          !---------------!
+         ELSE                          ! Read namelist !
+            !                          !---------------!
+            ! no ice if sst <= t-freez + ttest
+            WHERE( ( sst_m(:,:) - (t_bo(:,:) - rt0) ) * tmask(:,:,1) >= rn_thres_sst )   ;   zswitch(:,:) = 0._wp 
+            ELSEWHERE                                                                    ;   zswitch(:,:) = tmask(:,:,1)
+            END WHERE
+            !
+            ! assign initial thickness, concentration, snow depth and salinity to an hemisphere-dependent array
+            WHERE( ff_t(:,:) >= 0._wp )
+               zht_i_ini(:,:) = rn_hti_ini_n * zswitch(:,:)
+               zht_s_ini(:,:) = rn_hts_ini_n * zswitch(:,:)
+               zat_i_ini(:,:) = rn_ati_ini_n * zswitch(:,:)
+               zts_u_ini(:,:) = rn_tmi_ini_n * zswitch(:,:)
+               zsm_i_ini(:,:) = rn_smi_ini_n * zswitch(:,:)
+               ztm_i_ini(:,:) = rn_tmi_ini_n * zswitch(:,:)
+            ELSEWHERE
+               zht_i_ini(:,:) = rn_hti_ini_s * zswitch(:,:)
+               zht_s_ini(:,:) = rn_hts_ini_s * zswitch(:,:)
+               zat_i_ini(:,:) = rn_ati_ini_s * zswitch(:,:)
+               zts_u_ini(:,:) = rn_tmi_ini_s * zswitch(:,:)
+               zsm_i_ini(:,:) = rn_smi_ini_s * zswitch(:,:)
+               ztm_i_ini(:,:) = rn_tmi_ini_s * zswitch(:,:)
+            END WHERE
+            zvt_i_ini(:,:) = zht_i_ini(:,:) * zat_i_ini(:,:)
+            !
+         ENDIF
+         
+         !------------------------------------------------------------------
+         ! 3) Distribute ice concentration and thickness into the categories
+         !------------------------------------------------------------------
+         ! a gaussian distribution for ice concentration is used
+         ! then we check whether the distribution fullfills
+         ! volume and area conservation, positivity and ice categories bounds
+         zh_i_ini(:,:,:) = 0._wp 
+         za_i_ini(:,:,:) = 0._wp
+         !
+         DO jj = 1, jpj
+            DO ji = 1, jpi
+               !
+               IF( zat_i_ini(ji,jj) > 0._wp .AND. zht_i_ini(ji,jj) > 0._wp )THEN
+
+                  ! find which category (jl0) the input ice thickness falls into
+                  jl0 = jpl
+                  DO jl = 1, jpl
+                     IF ( ( zht_i_ini(ji,jj) >  hi_max(jl-1) ) .AND. ( zht_i_ini(ji,jj) <= hi_max(jl) ) ) THEN
+                        jl0 = jl
+                        CYCLE
+                     ENDIF
+                  END DO
+                  !
+                  itest(:) = 0
+                  i_fill   = jpl + 1                                            !------------------------------------
+                  DO WHILE ( ( SUM( itest(:) ) /= 4 ) .AND. ( i_fill >= 2 ) )   ! iterative loop on i_fill categories
+                     !                                                          !------------------------------------
+                     i_fill = i_fill - 1
+                     !
+                     zh_i_ini(ji,jj,:) = 0._wp 
+                     za_i_ini(ji,jj,:) = 0._wp
+                     itest(:) = 0
+                     !
+                     IF ( i_fill == 1 ) THEN      !-- case very thin ice: fill only category 1
+                        zh_i_ini(ji,jj,1) = zht_i_ini(ji,jj)
+                        za_i_ini(ji,jj,1) = zat_i_ini(ji,jj)
+                     ELSE                         !-- case ice is thicker: fill categories >1
+                        ! thickness
+                        DO jl = 1, i_fill-1
+                           zh_i_ini(ji,jj,jl) = hi_mean(jl)
+                        END DO
+                        !
+                        ! concentration
+                        za_i_ini(ji,jj,jl0) = zat_i_ini(ji,jj) / SQRT(REAL(jpl))
+                        DO jl = 1, i_fill - 1
+                           IF( jl /= jl0 )THEN
+                              zarg               = ( zh_i_ini(ji,jj,jl) - zht_i_ini(ji,jj) ) / ( 0.5_wp * zht_i_ini(ji,jj) )
+                              za_i_ini(ji,jj,jl) = za_i_ini(ji,jj,jl0) * EXP(-zarg**2)
+                           ENDIF
+                        END DO
+
+                        ! last category
+                        za_i_ini(ji,jj,i_fill) = zat_i_ini(ji,jj) - SUM( za_i_ini(ji,jj,1:i_fill-1) )
+                        zV = SUM( za_i_ini(ji,jj,1:i_fill-1) * zh_i_ini(ji,jj,1:i_fill-1) )
+                        zh_i_ini(ji,jj,i_fill) = ( zvt_i_ini(ji,jj) - zV ) / MAX( za_i_ini(ji,jj,i_fill), epsi10 ) 
+
+                        ! correction if concentration of upper cat is greater than lower cat
+                        !   (it should be a gaussian around jl0 but sometimes it is not)
+                        IF ( jl0 /= jpl ) THEN
+                           DO jl = jpl, jl0+1, -1
+                              IF ( za_i_ini(ji,jj,jl) > za_i_ini(ji,jj,jl-1) ) THEN
+                                 zdv = zh_i_ini(ji,jj,jl) * za_i_ini(ji,jj,jl)
+                                 zh_i_ini(ji,jj,jl    ) = 0._wp
+                                 za_i_ini(ji,jj,jl    ) = 0._wp
+                                 za_i_ini(ji,jj,1:jl-1) = za_i_ini(ji,jj,1:jl-1)  &
+                                    &                     + zdv / MAX( REAL(jl-1) * zht_i_ini(ji,jj), epsi10 )
+                              END IF
+                           ENDDO
+                        ENDIF
+                        !
+                     ENDIF
+                     !
+                     ! Compatibility tests
+                     zconv = ABS( zat_i_ini(ji,jj) - SUM( za_i_ini(ji,jj,1:jpl) ) )           ! Test 1: area conservation
+                     IF ( zconv < epsi06 ) itest(1) = 1
+                     !
+                     zconv = ABS(       zat_i_ini(ji,jj)       * zht_i_ini(ji,jj)   &         ! Test 2: volume conservation
+                        &        - SUM( za_i_ini (ji,jj,1:jpl) * zh_i_ini (ji,jj,1:jpl) ) )
+                     IF ( zconv < epsi06 ) itest(2) = 1
+                     !
+                     IF ( zh_i_ini(ji,jj,i_fill) >= hi_max(i_fill-1) ) itest(3) = 1           ! Test 3: thickness of the last category is in-bounds ?
+                     !
+                     itest(4) = 1
+                     DO jl = 1, i_fill
+                        IF ( za_i_ini(ji,jj,jl) < 0._wp ) itest(4) = 0                        ! Test 4: positivity of ice concentrations
+                     END DO
+                     !                                                          !----------------------------
+                  END DO                                                        ! end iteration on categories
+                  !                                                             !----------------------------
+                  IF( lwp .AND. SUM(itest) /= 4 ) THEN 
+                     WRITE(numout,*)
+                     WRITE(numout,*) ' !!!! ALERT itest is not equal to 4      !!! '
+                     WRITE(numout,*) ' !!!! Something is wrong in the LIM3 initialization procedure '
+                     WRITE(numout,*)
+                     WRITE(numout,*) ' *** itest_i (i=1,4) = ', itest(:)
+                     WRITE(numout,*) ' zat_i_ini : ', zat_i_ini(ji,jj)
+                     WRITE(numout,*) ' zht_i_ini : ', zht_i_ini(ji,jj)
+                  ENDIF
+                  !
+               ENDIF
+               !
+            END DO   
+         END DO   
+
+         !---------------------------------------------------------------------
+         ! 4) Fill in sea ice arrays
+         !---------------------------------------------------------------------
+         !
+         ! Ice concentration, thickness and volume, ice salinity, ice age, surface temperature
+         DO jl = 1, jpl ! loop over categories
+            DO jj = 1, jpj
+               DO ji = 1, jpi
+                  a_i(ji,jj,jl)  = zswitch(ji,jj) * za_i_ini(ji,jj,jl)                       ! concentration
+                  h_i(ji,jj,jl)  = zswitch(ji,jj) * zh_i_ini(ji,jj,jl)                       ! ice thickness
+                  s_i(ji,jj,jl)  = zswitch(ji,jj) * zsm_i_ini(ji,jj)                         ! salinity
+                  o_i(ji,jj,jl)  = 0._wp                                                     ! age (0 day)
+                  t_su(ji,jj,jl) = zswitch(ji,jj) * zts_u_ini(ji,jj) + ( 1._wp - zswitch(ji,jj) ) * rt0 ! surf temp
+                  !
+                  IF( zht_i_ini(ji,jj) > 0._wp )THEN
+                    h_s(ji,jj,jl)= h_i(ji,jj,jl) * ( zht_s_ini(ji,jj) / zht_i_ini(ji,jj) )  ! snow depth
+                  ELSE
+                    h_s(ji,jj,jl)= 0._wp
+                  ENDIF
+                  !
+                  ! This case below should not be used if (h_s/h_i) is ok in namelist
+                  ! In case snow load is in excess that would lead to transformation from snow to ice
+                  ! Then, transfer the snow excess into the ice (different from icethd_dh)
+                  zdh = MAX( 0._wp, ( rhosn * h_s(ji,jj,jl) + ( rhoic - rau0 ) * h_i(ji,jj,jl) ) * r1_rau0 ) 
+                  ! recompute h_i, h_s avoiding out of bounds values
+                  h_i(ji,jj,jl) = MIN( hi_max(jl), h_i(ji,jj,jl) + zdh )
+                  h_s(ji,jj,jl) = MAX( 0._wp, h_s(ji,jj,jl) - zdh * rhoic * r1_rhosn )
+                  !
+                  ! ice volume, salt content, age content
+                  v_i (ji,jj,jl) = h_i(ji,jj,jl) * a_i(ji,jj,jl)              ! ice volume
+                  v_s (ji,jj,jl) = h_s(ji,jj,jl) * a_i(ji,jj,jl)              ! snow volume
+                  sv_i(ji,jj,jl) = MIN( s_i(ji,jj,jl) , sss_m(ji,jj) ) * v_i(ji,jj,jl) ! salt content
+                  oa_i(ji,jj,jl) = o_i(ji,jj,jl) * a_i(ji,jj,jl)               ! age content
+               END DO
+            END DO
+         END DO
+         !
+         IF( nn_icesal /= 2 )  THEN         ! for constant salinity in time
+            CALL ice_var_salprof
+            sv_i = s_i * v_i
+         ENDIF
+         !  
+         ! Snow temperature and heat content
+         DO jk = 1, nlay_s
+            DO jl = 1, jpl ! loop over categories
+               DO jj = 1, jpj
+                  DO ji = 1, jpi
+                     t_s(ji,jj,jk,jl) = zswitch(ji,jj) * ztm_i_ini(ji,jj) + ( 1._wp - zswitch(ji,jj) ) * rt0
+                     ! Snow energy of melting
+                     e_s(ji,jj,jk,jl) = zswitch(ji,jj) * rhosn * ( cpic * ( rt0 - t_s(ji,jj,jk,jl) ) + lfus )
+                     !
+                     ! Mutliply by volume, and divide by number of layers to get heat content in J/m2
+                     e_s(ji,jj,jk,jl) = e_s(ji,jj,jk,jl) * v_s(ji,jj,jl) * r1_nlay_s
+                  END DO
+               END DO
+            END DO
+         END DO
+         !
+         ! Ice salinity, temperature and heat content
+         DO jk = 1, nlay_i
+            DO jl = 1, jpl ! loop over categories
+               DO jj = 1, jpj
+                  DO ji = 1, jpi
+                     t_i (ji,jj,jk,jl) = zswitch(ji,jj) * ztm_i_ini(ji,jj) + ( 1._wp - zswitch(ji,jj) ) * rt0 
+                     sz_i(ji,jj,jk,jl) = zswitch(ji,jj) * zsm_i_ini(ji,jj) + ( 1._wp - zswitch(ji,jj) ) * rn_simin
+                     ztmelts          = - tmut * sz_i(ji,jj,jk,jl) + rt0 !Melting temperature in K
+                     !
+                     ! heat content per unit volume
+                     e_i(ji,jj,jk,jl) = zswitch(ji,jj) * rhoic * (   cpic    * ( ztmelts - t_i(ji,jj,jk,jl) )         &
+                        &             + lfus * ( 1._wp - (ztmelts-rt0) / MIN( (t_i(ji,jj,jk,jl)-rt0) , -epsi20 )  )   &
+                        &             - rcp  * ( ztmelts - rt0 ) )
+                     !
+                     ! Mutliply by ice volume, and divide by number of layers to get heat content in J/m2
+                     e_i(ji,jj,jk,jl) = e_i(ji,jj,jk,jl) * v_i(ji,jj,jl) * r1_nlay_i
+                  END DO
+               END DO
+            END DO
+         END DO
+         !
+         tn_ice (:,:,:) = t_su (:,:,:)
+         t1_ice (:,:,:) = t_i (:,:,1,:)   ! initialisation of 1st layer temp for coupled simu
+
+         ! Melt pond volume and fraction
+         IF ( ln_pnd_CST .OR. ln_pnd_H12 ) THEN   ;   zfac = 1._wp
+         ELSE                                     ;   zfac = 0._wp
+         ENDIF 
+         DO jl = 1, jpl
+            a_ip_frac(:,:,jl) = rn_apnd * zswitch(:,:) * zfac
+            h_ip     (:,:,jl) = rn_hpnd * zswitch(:,:) * zfac
+         END DO
+         a_ip(:,:,:) = a_ip_frac(:,:,:) * a_i (:,:,:) 
+         v_ip(:,:,:) = h_ip     (:,:,:) * a_ip(:,:,:)
+         !
+      ELSE ! if ln_iceini=false
+         a_i  (:,:,:) = 0._wp
+         v_i  (:,:,:) = 0._wp
+         v_s  (:,:,:) = 0._wp
+         sv_i (:,:,:) = 0._wp
+         oa_i (:,:,:) = 0._wp
+         h_i  (:,:,:) = 0._wp
+         h_s  (:,:,:) = 0._wp
+         s_i  (:,:,:) = 0._wp
+         o_i  (:,:,:) = 0._wp
+         !
+         e_i(:,:,:,:) = 0._wp
+         e_s(:,:,:,:) = 0._wp
+         !
+         DO jl = 1, jpl
+            DO jk = 1, nlay_i
+               t_i(:,:,jk,jl) = rt0 * tmask(:,:,1)
+            END DO
+            DO jk = 1, nlay_s
+               t_s(:,:,jk,jl) = rt0 * tmask(:,:,1)
+            END DO
+         END DO
+
+         tn_ice (:,:,:) = t_i (:,:,1,:)
+         t1_ice (:,:,:) = t_i (:,:,1,:)   ! initialisation of 1st layer temp for coupled simu
+         
+         a_ip(:,:,:)      = 0._wp
+         v_ip(:,:,:)      = 0._wp
+         a_ip_frac(:,:,:) = 0._wp
+         h_ip     (:,:,:) = 0._wp
+         !
+      ENDIF ! ln_iceini
+      !
+      at_i (:,:) = 0.0_wp
+      DO jl = 1, jpl
+         at_i (:,:) = at_i (:,:) + a_i (:,:,jl)
+      END DO
+      !
+      ! --- set ice velocities --- !
+      u_ice (:,:) = 0._wp
+      v_ice (:,:) = 0._wp
+      !
+      !----------------------------------------------
+      ! 5) Snow-ice mass (case ice is fully embedded)
+      !----------------------------------------------
+      snwice_mass  (:,:) = tmask(:,:,1) * SUM( rhosn * v_s(:,:,:) + rhoic * v_i(:,:,:), dim=3  )   ! snow+ice mass
+      snwice_mass_b(:,:) = snwice_mass(:,:)
+      !
+      IF( ln_ice_embd ) THEN            ! embedded sea-ice: deplete the initial ssh below sea-ice area
+         !
+         sshn(:,:) = sshn(:,:) - snwice_mass(:,:) * r1_rau0
+         sshb(:,:) = sshb(:,:) - snwice_mass(:,:) * r1_rau0
+         !
+         IF( .NOT.ln_linssh ) THEN
+            !
+            WHERE( ht_0(:,:) > 0 )   ;   z2d(:,:) = 1._wp + sshn(:,:)*tmask(:,:,1) / ht_0(:,:)
+            ELSEWHERE                ;   z2d(:,:) = 1._wp   ;   END WHERE
+            !
+            DO jk = 1,jpkm1                     ! adjust initial vertical scale factors                
+               e3t_n(:,:,jk) = e3t_0(:,:,jk) * z2d(:,:)
+               e3t_b(:,:,jk) = e3t_n(:,:,jk)
+               e3t_a(:,:,jk) = e3t_n(:,:,jk)
+            END DO
+            !
+            ! Reconstruction of all vertical scale factors at now and before time-steps
+            ! =========================================================================
+            ! Horizontal scale factor interpolations
+            ! --------------------------------------
+            CALL dom_vvl_interpol( e3t_b(:,:,:), e3u_b(:,:,:), 'U' )
+            CALL dom_vvl_interpol( e3t_b(:,:,:), e3v_b(:,:,:), 'V' )
+            CALL dom_vvl_interpol( e3t_n(:,:,:), e3u_n(:,:,:), 'U' )
+            CALL dom_vvl_interpol( e3t_n(:,:,:), e3v_n(:,:,:), 'V' )
+            CALL dom_vvl_interpol( e3u_n(:,:,:), e3f_n(:,:,:), 'F' )
+            ! Vertical scale factor interpolations
+            ! ------------------------------------
+            CALL dom_vvl_interpol( e3t_n(:,:,:), e3w_n (:,:,:), 'W'  )
+            CALL dom_vvl_interpol( e3u_n(:,:,:), e3uw_n(:,:,:), 'UW' )
+            CALL dom_vvl_interpol( e3v_n(:,:,:), e3vw_n(:,:,:), 'VW' )
+            CALL dom_vvl_interpol( e3u_b(:,:,:), e3uw_b(:,:,:), 'UW' )
+            CALL dom_vvl_interpol( e3v_b(:,:,:), e3vw_b(:,:,:), 'VW' )
+            ! t- and w- points depth
+            ! ----------------------
+            !!gm not sure of that....
+            gdept_n(:,:,1) = 0.5_wp * e3w_n(:,:,1)
+            gdepw_n(:,:,1) = 0.0_wp
+            gde3w_n(:,:,1) = gdept_n(:,:,1) - sshn(:,:)
+            DO jk = 2, jpk
+               gdept_n(:,:,jk) = gdept_n(:,:,jk-1) + e3w_n(:,:,jk  )
+               gdepw_n(:,:,jk) = gdepw_n(:,:,jk-1) + e3t_n(:,:,jk-1)
+               gde3w_n(:,:,jk) = gdept_n(:,:,jk  ) - sshn (:,:)
+            END DO
+         ENDIF
+      ENDIF
+      
+      !------------------------------------
+      ! 6) store fields at before time-step
+      !------------------------------------
+      ! it is only necessary for the 1st interpolation by Agrif
+      a_i_b  (:,:,:)   = a_i  (:,:,:)
+      e_i_b  (:,:,:,:) = e_i  (:,:,:,:)
+      v_i_b  (:,:,:)   = v_i  (:,:,:)
+      v_s_b  (:,:,:)   = v_s  (:,:,:)
+      e_s_b  (:,:,:,:) = e_s  (:,:,:,:)
+      sv_i_b (:,:,:)   = sv_i (:,:,:)
+      oa_i_b (:,:,:)   = oa_i (:,:,:)
+      u_ice_b(:,:)     = u_ice(:,:)
+      v_ice_b(:,:)     = v_ice(:,:)
+
+!!clem: output of initial state should be written here but it is impossible because
+!!      the ocean and ice are in the same file
+!!      CALL dia_wri_state( 'output.init', nit000 )
+      !
+   END SUBROUTINE ice_istate
+
+
+   SUBROUTINE ice_istate_init
+      !!-------------------------------------------------------------------
+      !!                   ***  ROUTINE ice_istate_init  ***
+      !!        
+      !! ** Purpose :   Definition of initial state of the ice 
+      !!
+      !! ** Method  :   Read the namini namelist and check the parameter 
+      !!              values called at the first timestep (nit000)
+      !!
+      !! ** input   :  Namelist namini
+      !!
+      !!-----------------------------------------------------------------------------
+      INTEGER ::   ji, jj
+      INTEGER ::   ios, ierr, inum_ice   ! Local integer output status for namelist read
+      INTEGER ::   ifpr, ierror
+      !
+      CHARACTER(len=256) ::  cn_dir          ! Root directory for location of ice files
+      TYPE(FLD_N)                    ::   sn_hti, sn_hts, sn_ati, sn_tsu, sn_tmi, sn_smi
+      TYPE(FLD_N), DIMENSION(jpfldi) ::   slf_i                 ! array of namelist informations on the fields to read
+      !
+      NAMELIST/namini/ ln_iceini, ln_iceini_file, rn_thres_sst, rn_hts_ini_n, rn_hts_ini_s,  &
+         &             rn_hti_ini_n, rn_hti_ini_s, rn_ati_ini_n, rn_ati_ini_s, rn_smi_ini_n, &
+         &             rn_smi_ini_s, rn_tmi_ini_n, rn_tmi_ini_s,                             &
+         &             sn_hti, sn_hts, sn_ati, sn_tsu, sn_tmi, sn_smi, cn_dir
+      !!-----------------------------------------------------------------------------
+      !
+      REWIND( numnam_ice_ref )              ! Namelist namini in reference namelist : Ice initial state
+      READ  ( numnam_ice_ref, namini, IOSTAT = ios, ERR = 901)
+901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namini in reference namelist', lwp )
+      REWIND( numnam_ice_cfg )              ! Namelist namini in configuration namelist : Ice initial state
+      READ  ( numnam_ice_cfg, namini, IOSTAT = ios, ERR = 902 )
+902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namini in configuration namelist', lwp )
+      IF(lwm) WRITE ( numoni, namini )
+      !
+      slf_i(jp_hti) = sn_hti  ;  slf_i(jp_hts) = sn_hts
+      slf_i(jp_ati) = sn_ati  ;  slf_i(jp_tsu) = sn_tsu
+      slf_i(jp_tmi) = sn_tmi  ;  slf_i(jp_smi) = sn_smi
+      !
+      IF(lwp) THEN                          ! control print
+         WRITE(numout,*)
+         WRITE(numout,*) 'ice_istate_init: ice parameters inititialisation '
+         WRITE(numout,*) '~~~~~~~~~~~~~~~'
+         WRITE(numout,*) '   Namelist namini:'
+         WRITE(numout,*) '      initialization with ice (T) or not (F)                 ln_iceini       = ', ln_iceini
+         WRITE(numout,*) '      ice initialization from a netcdf file                  ln_iceini_file  = ', ln_iceini_file
+         WRITE(numout,*) '      max delta ocean temp. above Tfreeze with initial ice   rn_thres_sst    = ', rn_thres_sst
+         WRITE(numout,*) '      initial snow thickness in the north                    rn_hts_ini_n    = ', rn_hts_ini_n
+         WRITE(numout,*) '      initial snow thickness in the south                    rn_hts_ini_s    = ', rn_hts_ini_s 
+         WRITE(numout,*) '      initial ice thickness  in the north                    rn_hti_ini_n    = ', rn_hti_ini_n
+         WRITE(numout,*) '      initial ice thickness  in the south                    rn_hti_ini_s    = ', rn_hti_ini_s
+         WRITE(numout,*) '      initial ice concentr.  in the north                    rn_ati_ini_n    = ', rn_ati_ini_n
+         WRITE(numout,*) '      initial ice concentr.  in the north                    rn_ati_ini_s    = ', rn_ati_ini_s
+         WRITE(numout,*) '      initial  ice salinity  in the north                    rn_smi_ini_n    = ', rn_smi_ini_n
+         WRITE(numout,*) '      initial  ice salinity  in the south                    rn_smi_ini_s    = ', rn_smi_ini_s
+         WRITE(numout,*) '      initial  ice/snw temp  in the north                    rn_tmi_ini_n    = ', rn_tmi_ini_n
+         WRITE(numout,*) '      initial  ice/snw temp  in the south                    rn_tmi_ini_s    = ', rn_tmi_ini_s
+      ENDIF
+      !
+      IF( ln_iceini_file ) THEN                      ! Ice initialization using input file
+         !
+         ! set si structure
+         ALLOCATE( si(jpfldi), STAT=ierror )
+         IF( ierror > 0 ) THEN
+            CALL ctl_stop( 'Ice_ini in iceistate: unable to allocate si structure' )   ;   RETURN
+         ENDIF
+         !
+         DO ifpr = 1, jpfldi
+            ALLOCATE( si(ifpr)%fnow(jpi,jpj,1) )
+            ALLOCATE( si(ifpr)%fdta(jpi,jpj,1,2) )
+         END DO
+         !
+         ! fill si with slf_i and control print
+         CALL fld_fill( si, slf_i, cn_dir, 'ice_istate', 'ice istate ini', 'numnam_ice' )
+         !
+         CALL fld_read( nit000, 1, si )                ! input fields provided at the current time-step
+         !
+      ENDIF
+      !
+   END SUBROUTINE ice_istate_init
+
+#else
+   !!----------------------------------------------------------------------
+   !!   Default option :         Empty module         NO SI3 sea-ice model
+   !!----------------------------------------------------------------------
+#endif
+
+   !!======================================================================
+END MODULE iceistate
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/ICE_SRC/iceitd.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/ICE_SRC/iceitd.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/ICE_SRC/iceitd.F90	(revision 9570)
@@ -0,0 +1,726 @@
+MODULE iceitd
+   !!======================================================================
+   !!                       ***  MODULE iceitd ***
+   !!   sea-ice : ice thickness distribution
+   !!======================================================================
+   !! History :   -   !          (W. H. Lipscomb and E.C. Hunke) CICE (c) original code
+   !!            3.0  ! 2005-12  (M. Vancoppenolle) adaptation to LIM-3
+   !!             -   ! 2006-06  (M. Vancoppenolle) adaptation to include salt, age
+   !!             -   ! 2007-04  (M. Vancoppenolle) Mass conservation checked
+   !!----------------------------------------------------------------------
+#if defined key_si3
+   !!----------------------------------------------------------------------
+   !!   'key_si3'                                       SI3 sea-ice model
+   !!----------------------------------------------------------------------
+   !!   ice_itd_rem   : redistribute ice thicknesses after thermo growth and melt
+   !!   itd_glinear   : build g(h) satisfying area and volume constraints
+   !!   itd_shiftice  : shift ice across category boundaries, conserving everything
+   !!   ice_itd_reb   : rebin ice thicknesses into bounded categories
+   !!   ice_itd_init  : read ice thicknesses mean and min from namelist
+   !!----------------------------------------------------------------------
+   USE dom_oce        ! ocean domain
+   USE phycst         ! physical constants 
+   USE ice1D          ! sea-ice: thermodynamic variables
+   USE ice            ! sea-ice: variables
+   USE icectl         ! sea-ice: conservation tests
+   USE icetab         ! sea-ice: convert 1D<=>2D
+   !
+   USE in_out_manager ! I/O manager
+   USE lib_mpp        ! MPP library
+   USE lib_fortran    ! fortran utilities (glob_sum + no signed zero)
+   USE prtctl         ! Print control
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   ice_itd_init  ! called in icestp
+   PUBLIC   ice_itd_rem   ! called in icethd
+   PUBLIC   ice_itd_reb   ! called in icecor
+
+   INTEGER            ::   nice_catbnd     ! choice of the type of ice category function
+   !                                       ! associated indices:
+   INTEGER, PARAMETER ::   np_cathfn = 1   ! categories defined by a function
+   INTEGER, PARAMETER ::   np_catusr = 2   ! categories defined by the user
+   !
+   !                                           !! ** namelist (namitd) **
+   LOGICAL                    ::   ln_cat_hfn   ! ice categories are defined by function like rn_himean**(-0.05)
+   REAL(wp)                   ::   rn_himean    ! mean thickness of the domain
+   LOGICAL                    ::   ln_cat_usr   ! ice categories are defined by rn_catbnd
+   REAL(wp), DIMENSION(0:100) ::   rn_catbnd    ! ice categories bounds
+   !
+   !!----------------------------------------------------------------------
+   !! NEMO/ICE 4.0 , NEMO Consortium (2017)
+   !! $Id: iceitd.F90 8420 2017-08-08 12:18:46Z clem $
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE ice_itd_rem( kt )
+      !!------------------------------------------------------------------
+      !!                ***  ROUTINE ice_itd_rem ***
+      !!
+      !! ** Purpose :   computes the redistribution of ice thickness
+      !!                after thermodynamic growth of ice thickness
+      !!
+      !! ** Method  :   Linear remapping 
+      !!
+      !! References :   W.H. Lipscomb, JGR 2001
+      !!------------------------------------------------------------------
+      INTEGER , INTENT (in) ::   kt      ! Ocean time step 
+      !
+      INTEGER  ::   ji, jj, jl, jcat     ! dummy loop index
+      INTEGER  ::   ipti                 ! local integer
+      REAL(wp) ::   zx1, zwk1, zdh0, zetamin, zdamax   ! local scalars
+      REAL(wp) ::   zx2, zwk2, zda0, zetamax           !   -      -
+      REAL(wp) ::   zx3        
+      REAL(wp) ::   zslope          ! used to compute local thermodynamic "speeds"
+      !
+      INTEGER , DIMENSION(jpij)       ::   iptidx          ! compute remapping or not
+      INTEGER , DIMENSION(jpij,jpl-1) ::   jdonor          ! donor category index
+      REAL(wp), DIMENSION(jpij,jpl)   ::   zdhice          ! ice thickness increment
+      REAL(wp), DIMENSION(jpij,jpl)   ::   g0, g1          ! coefficients for fitting the line of the ITD
+      REAL(wp), DIMENSION(jpij,jpl)   ::   hL, hR          ! left and right boundary for the ITD for each thickness
+      REAL(wp), DIMENSION(jpij,jpl-1) ::   zdaice, zdvice  ! local increment of ice area and volume
+      REAL(wp), DIMENSION(jpij)       ::   zhb0, zhb1      ! category boundaries for thinnes categories
+      REAL(wp), DIMENSION(jpij,0:jpl) ::   zhbnew          ! new boundaries of ice categories
+      !!------------------------------------------------------------------
+
+      IF( kt == nit000 .AND. lwp )   WRITE(numout,*) '-- ice_itd_rem: remapping ice thickness distribution' 
+
+      IF( ln_icediachk )   CALL ice_cons_hsm(0, 'iceitd_rem', rdiag_v, rdiag_s, rdiag_t, rdiag_fv, rdiag_fs, rdiag_ft)
+
+      !-----------------------------------------------------------------------------------------------
+      !  1) Identify grid cells with ice
+      !-----------------------------------------------------------------------------------------------
+      npti = 0   ;   nptidx(:) = 0
+      DO jj = 1, jpj
+         DO ji = 1, jpi
+            IF ( at_i(ji,jj) > epsi10 ) THEN
+               npti         = npti + 1
+               nptidx( npti ) = (jj - 1) * jpi + ji
+            ENDIF
+         END DO
+      END DO
+      
+      !-----------------------------------------------------------------------------------------------
+      !  2) Compute new category boundaries
+      !-----------------------------------------------------------------------------------------------
+      IF( npti > 0 ) THEN
+         !
+         zdhice(:,:) = 0._wp
+         zhbnew(:,:) = 0._wp
+         !
+         CALL tab_3d_2d( npti, nptidx(1:npti), h_i_2d (1:npti,1:jpl), h_i   )
+         CALL tab_3d_2d( npti, nptidx(1:npti), h_ib_2d(1:npti,1:jpl), h_i_b )
+         CALL tab_3d_2d( npti, nptidx(1:npti), a_i_2d  (1:npti,1:jpl), a_i    )
+         CALL tab_3d_2d( npti, nptidx(1:npti), a_ib_2d (1:npti,1:jpl), a_i_b  )
+         !
+         DO jl = 1, jpl
+            ! Compute thickness change in each ice category
+            DO ji = 1, npti
+               IF( a_i_2d(ji,jl) > epsi10 )   zdhice(ji,jl) = h_i_2d(ji,jl) - h_ib_2d(ji,jl)   ! clem: if statement is necessary for repro
+            END DO
+         END DO
+         !
+         ! --- New boundaries for category 1:jpl-1 --- !
+         DO jl = 1, jpl - 1
+            !
+            DO ji = 1, npti
+               !
+               ! --- New boundary: Hn* = Hn + Fn*dt --- !
+               !     Fn*dt = ( fn + (fn+1 - fn)/(hn+1 - hn) * (Hn - hn) ) * dt = zdhice + zslope * (Hmax - h_i_b)
+               !
+               IF    ( a_ib_2d(ji,jl) >  epsi10 .AND. a_ib_2d(ji,jl+1) >  epsi10 ) THEN   ! a(jl+1) & a(jl) /= 0
+                  zslope           = ( zdhice(ji,jl+1) - zdhice(ji,jl) ) / ( h_ib_2d(ji,jl+1) - h_ib_2d(ji,jl) )
+                  zhbnew(ji,jl) = hi_max(jl) + zdhice(ji,jl) + zslope * ( hi_max(jl) - h_ib_2d(ji,jl) )
+               ELSEIF( a_ib_2d(ji,jl) >  epsi10 .AND. a_ib_2d(ji,jl+1) <= epsi10 ) THEN   ! a(jl+1)=0 => Hn* = Hn + fn*dt
+                  zhbnew(ji,jl) = hi_max(jl) + zdhice(ji,jl)
+               ELSEIF( a_ib_2d(ji,jl) <= epsi10 .AND. a_ib_2d(ji,jl+1) >  epsi10 ) THEN   ! a(jl)=0 => Hn* = Hn + fn+1*dt
+                  zhbnew(ji,jl) = hi_max(jl) + zdhice(ji,jl+1)
+               ELSE                                                                       ! a(jl+1) & a(jl) = 0 
+                  zhbnew(ji,jl) = hi_max(jl)
+               ENDIF
+               !
+               ! --- 2 conditions for remapping --- !
+               ! 1) hn(t+1)+espi < Hn* < hn+1(t+1)-epsi               
+               !    Note: hn(t+1) must not be too close to either HR or HL otherwise a division by nearly 0 is possible 
+               !          in itd_glinear in the case (HR-HL) = 3(Hice - HL) or = 3(HR - Hice)
+               IF( a_i_2d(ji,jl  ) > epsi10 .AND. h_i_2d(ji,jl  ) > ( zhbnew(ji,jl) - epsi10 ) )   nptidx(ji) = 0
+               IF( a_i_2d(ji,jl+1) > epsi10 .AND. h_i_2d(ji,jl+1) < ( zhbnew(ji,jl) + epsi10 ) )   nptidx(ji) = 0
+               !
+               ! 2) Hn-1 < Hn* < Hn+1  
+               IF( zhbnew(ji,jl) < hi_max(jl-1) )   nptidx(ji) = 0
+               IF( zhbnew(ji,jl) > hi_max(jl+1) )   nptidx(ji) = 0
+               !
+            END DO
+         END DO
+         !
+         ! --- New boundaries for category jpl --- !
+         DO ji = 1, npti
+            IF( a_i_2d(ji,jpl) > epsi10 ) THEN
+               zhbnew(ji,jpl) = MAX( hi_max(jpl-1), 3._wp * h_i_2d(ji,jpl) - 2._wp * zhbnew(ji,jpl-1) )
+            ELSE
+               zhbnew(ji,jpl) = hi_max(jpl)  
+            ENDIF
+            !
+            ! --- 1 additional condition for remapping (1st category) --- !
+            ! H0+epsi < h1(t) < H1-epsi 
+            !    h1(t) must not be too close to either HR or HL otherwise a division by nearly 0 is possible 
+            !    in itd_glinear in the case (HR-HL) = 3(Hice - HL) or = 3(HR - Hice)
+            IF( h_ib_2d(ji,1) < ( hi_max(0) + epsi10 ) )   nptidx(ji) = 0
+            IF( h_ib_2d(ji,1) > ( hi_max(1) - epsi10 ) )   nptidx(ji) = 0
+         END DO
+         !
+         !-----------------------------------------------------------------------------------------------
+         !  3) Identify cells where remapping
+         !-----------------------------------------------------------------------------------------------
+         ipti = 0   ;   iptidx(:) = 0
+         DO ji = 1, npti
+            IF( nptidx(ji) /= 0 ) THEN
+               ipti = ipti + 1
+               iptidx(ipti)   = nptidx(ji)
+               zhbnew(ipti,:) = zhbnew(ji,:)  ! adjust zhbnew to new indices
+            ENDIF
+         END DO
+         nptidx(:) = iptidx(:)
+         npti      = ipti
+         !
+      ENDIF
+   
+      !-----------------------------------------------------------------------------------------------
+      !  4) Compute g(h) 
+      !-----------------------------------------------------------------------------------------------
+      IF( npti > 0 ) THEN
+         !
+         zhb0(:) = hi_max(0)   ;   zhb1(:) = hi_max(1)
+         g0(:,:) = 0._wp       ;   g1(:,:) = 0._wp 
+         hL(:,:) = 0._wp       ;   hR(:,:) = 0._wp 
+         !
+         DO jl = 1, jpl
+            !
+            CALL tab_2d_1d( npti, nptidx(1:npti), h_ib_1d(1:npti), h_i_b(:,:,jl) )
+            CALL tab_2d_1d( npti, nptidx(1:npti), h_i_1d (1:npti), h_i(:,:,jl)   )
+            CALL tab_2d_1d( npti, nptidx(1:npti), a_i_1d  (1:npti), a_i(:,:,jl)    )
+            CALL tab_2d_1d( npti, nptidx(1:npti), v_i_1d  (1:npti), v_i(:,:,jl)    )
+            !
+            IF( jl == 1 ) THEN
+               !  
+               ! --- g(h) for category 1 --- !
+               CALL itd_glinear( zhb0(1:npti)  , zhb1(1:npti)  , h_ib_1d(1:npti)  , a_i_1d(1:npti)  ,  &   ! in
+                  &              g0  (1:npti,1), g1  (1:npti,1), hL      (1:npti,1), hR    (1:npti,1)   )   ! out
+                  !
+               ! Area lost due to melting of thin ice
+               DO ji = 1, npti
+                  !
+                  IF( a_i_1d(ji) > epsi10 ) THEN
+                     !
+                     zdh0 =  h_i_1d(ji) - h_ib_1d(ji)                
+                     IF( zdh0 < 0.0 ) THEN      !remove area from category 1
+                        zdh0 = MIN( -zdh0, hi_max(1) )
+                        !Integrate g(1) from 0 to dh0 to estimate area melted
+                        zetamax = MIN( zdh0, hR(ji,1) ) - hL(ji,1)
+                        !
+                        IF( zetamax > 0.0 ) THEN
+                           zx1    = zetamax
+                           zx2    = 0.5 * zetamax * zetamax 
+                           zda0   = g1(ji,1) * zx2 + g0(ji,1) * zx1                        ! ice area removed
+                           zdamax = a_i_1d(ji) * (1.0 - h_i_1d(ji) / h_ib_1d(ji) ) ! Constrain new thickness <= h_i                
+                           zda0   = MIN( zda0, zdamax )                                                  ! ice area lost due to melting 
+                           !     of thin ice (zdamax > 0)
+                           ! Remove area, conserving volume
+                           h_i_1d(ji) = h_i_1d(ji) * a_i_1d(ji) / ( a_i_1d(ji) - zda0 )
+                           a_i_1d(ji)  = a_i_1d(ji) - zda0
+                           v_i_1d(ji)  = a_i_1d(ji) * h_i_1d(ji) ! useless ?
+                        ENDIF
+                        !
+                     ELSE ! if ice accretion zdh0 > 0
+                        ! zhbnew was 0, and is shifted to the right to account for thin ice growth in openwater (F0 = f1)
+                        zhbnew(ji,0) = MIN( zdh0, hi_max(1) ) 
+                     ENDIF
+                     !
+                  ENDIF
+                  !
+               END DO
+               !
+               CALL tab_1d_2d( npti, nptidx(1:npti), h_i_1d (1:npti), h_i(:,:,jl)   )
+               CALL tab_1d_2d( npti, nptidx(1:npti), a_i_1d  (1:npti), a_i(:,:,jl)    )
+               CALL tab_1d_2d( npti, nptidx(1:npti), v_i_1d  (1:npti), v_i(:,:,jl)    )
+               !
+            ENDIF ! jl=1
+            !
+            ! --- g(h) for each thickness category --- !  
+            CALL itd_glinear( zhbnew(1:npti,jl-1), zhbnew(1:npti,jl), h_i_1d(1:npti)   , a_i_1d(1:npti)   ,  &   ! in
+               &              g0    (1:npti,jl  ), g1    (1:npti,jl), hL     (1:npti,jl), hR    (1:npti,jl)   )   ! out
+            !
+         END DO
+         
+         !-----------------------------------------------------------------------------------------------
+         !  5) Compute area and volume to be shifted across each boundary (Eq. 18)
+         !-----------------------------------------------------------------------------------------------
+         DO jl = 1, jpl - 1
+            !
+            DO ji = 1, npti
+               !
+               ! left and right integration limits in eta space
+               IF (zhbnew(ji,jl) > hi_max(jl)) THEN ! Hn* > Hn => transfer from jl to jl+1
+                  zetamin = MAX( hi_max(jl)   , hL(ji,jl) ) - hL(ji,jl)   ! hi_max(jl) - hL 
+                  zetamax = MIN( zhbnew(ji,jl), hR(ji,jl) ) - hL(ji,jl)   ! hR - hL
+                  jdonor(ji,jl) = jl
+               ELSE                                 ! Hn* <= Hn => transfer from jl+1 to jl
+                  zetamin = 0.0
+                  zetamax = MIN( hi_max(jl), hR(ji,jl+1) ) - hL(ji,jl+1)  ! hi_max(jl) - hL
+                  jdonor(ji,jl) = jl + 1
+               ENDIF
+               zetamax = MAX( zetamax, zetamin ) ! no transfer if etamax < etamin
+               !
+               zx1  = zetamax - zetamin
+               zwk1 = zetamin * zetamin
+               zwk2 = zetamax * zetamax
+               zx2  = 0.5 * ( zwk2 - zwk1 )
+               zwk1 = zwk1 * zetamin
+               zwk2 = zwk2 * zetamax
+               zx3  = 1.0 / 3.0 * ( zwk2 - zwk1 )
+               jcat = jdonor(ji,jl)
+               zdaice(ji,jl) = g1(ji,jcat)*zx2 + g0(ji,jcat)*zx1
+               zdvice(ji,jl) = g1(ji,jcat)*zx3 + g0(ji,jcat)*zx2 + zdaice(ji,jl)*hL(ji,jcat)
+               !
+            END DO
+         END DO
+         
+         !----------------------------------------------------------------------------------------------
+         ! 6) Shift ice between categories
+         !----------------------------------------------------------------------------------------------
+         CALL itd_shiftice ( jdonor(1:npti,:), zdaice(1:npti,:), zdvice(1:npti,:) )
+         
+         !----------------------------------------------------------------------------------------------
+         ! 7) Make sure h_i >= minimum ice thickness hi_min
+         !----------------------------------------------------------------------------------------------
+         CALL tab_2d_1d( npti, nptidx(1:npti), h_i_1d (1:npti), h_i (:,:,1) )
+         CALL tab_2d_1d( npti, nptidx(1:npti), a_i_1d (1:npti), a_i (:,:,1) )
+         CALL tab_2d_1d( npti, nptidx(1:npti), a_ip_1d(1:npti), a_ip(:,:,1) )
+         !
+         DO ji = 1, npti
+            IF ( a_i_1d(ji) > epsi10 .AND. h_i_1d(ji) < rn_himin ) THEN
+               a_i_1d (ji) = a_i_1d(ji) * h_i_1d(ji) / rn_himin 
+               IF( ln_pnd_H12 )   a_ip_1d(ji) = a_ip_1d(ji) * h_i_1d(ji) / rn_himin
+               h_i_1d(ji) = rn_himin
+            ENDIF
+         END DO
+         !
+         CALL tab_1d_2d( npti, nptidx(1:npti), h_i_1d (1:npti), h_i (:,:,1) )
+         CALL tab_1d_2d( npti, nptidx(1:npti), a_i_1d (1:npti), a_i (:,:,1) )
+         CALL tab_1d_2d( npti, nptidx(1:npti), a_ip_1d(1:npti), a_ip(:,:,1) )
+         !
+      ENDIF
+      !
+      IF( ln_icediachk )   CALL ice_cons_hsm(1, 'iceitd_rem', rdiag_v, rdiag_s, rdiag_t, rdiag_fv, rdiag_fs, rdiag_ft)
+      !
+   END SUBROUTINE ice_itd_rem
+
+
+   SUBROUTINE itd_glinear( HbL, Hbr, phice, paice, pg0, pg1, phL, phR )
+      !!------------------------------------------------------------------
+      !!                ***  ROUTINE itd_glinear ***
+      !!
+      !! ** Purpose :   build g(h) satisfying area and volume constraints (Eq. 6 and 9)
+      !!
+      !! ** Method  :   g(h) is linear and written as: g(eta) = g1(eta) + g0
+      !!                with eta = h - HL
+      !!------------------------------------------------------------------
+      REAL(wp), DIMENSION(:), INTENT(in   ) ::   HbL, HbR      ! left and right category boundaries
+      REAL(wp), DIMENSION(:), INTENT(in   ) ::   phice, paice  ! ice thickness and concentration
+      REAL(wp), DIMENSION(:), INTENT(inout) ::   pg0, pg1      ! coefficients in linear equation for g(eta)
+      REAL(wp), DIMENSION(:), INTENT(inout) ::   phL, phR      ! min and max value of range over which g(h) > 0
+      !
+      INTEGER  ::   ji           ! horizontal indices
+      REAL(wp) ::   z1_3 , z2_3  ! 1/3 , 2/3
+      REAL(wp) ::   zh13         ! HbL + 1/3 * (HbR - HbL)
+      REAL(wp) ::   zh23         ! HbL + 2/3 * (HbR - HbL)
+      REAL(wp) ::   zdhr         ! 1 / (hR - hL)
+      REAL(wp) ::   zwk1, zwk2   ! temporary variables
+      !!------------------------------------------------------------------
+      !
+      z1_3 = 1._wp / 3._wp
+      z2_3 = 2._wp / 3._wp
+      !
+      DO ji = 1, npti
+         !
+         IF( paice(ji) > epsi10  .AND. phice(ji) > 0._wp )  THEN
+            !
+            ! Initialize hL and hR
+            phL(ji) = HbL(ji)
+            phR(ji) = HbR(ji)
+            !
+            ! Change hL or hR if hice falls outside central third of range,
+            ! so that hice is in the central third of the range [HL HR]
+            zh13 = z1_3 * ( 2._wp * phL(ji) +         phR(ji) )
+            zh23 = z1_3 * (         phL(ji) + 2._wp * phR(ji) )
+            !
+            IF    ( phice(ji) < zh13 ) THEN   ;   phR(ji) = 3._wp * phice(ji) - 2._wp * phL(ji) ! move HR to the left
+            ELSEIF( phice(ji) > zh23 ) THEN   ;   phL(ji) = 3._wp * phice(ji) - 2._wp * phR(ji) ! move HL to the right
+            ENDIF
+            !
+            ! Compute coefficients of g(eta) = g0 + g1*eta
+            zdhr = 1._wp / (phR(ji) - phL(ji))
+            zwk1 = 6._wp * paice(ji) * zdhr
+            zwk2 = ( phice(ji) - phL(ji) ) * zdhr
+            pg0(ji) = zwk1 * ( z2_3 - zwk2 )                    ! Eq. 14
+            pg1(ji) = 2._wp * zdhr * zwk1 * ( zwk2 - 0.5_wp )   ! Eq. 14
+            !
+         ELSE  ! remap_flag = .false. or a_i < epsi10 
+            phL(ji) = 0._wp
+            phR(ji) = 0._wp
+            pg0(ji) = 0._wp
+            pg1(ji) = 0._wp
+         ENDIF
+         !
+      END DO
+      !
+   END SUBROUTINE itd_glinear
+
+
+   SUBROUTINE itd_shiftice( kdonor, pdaice, pdvice )
+      !!------------------------------------------------------------------
+      !!                ***  ROUTINE itd_shiftice ***
+      !!
+      !! ** Purpose :   shift ice across category boundaries, conserving everything
+      !!              ( area, volume, energy, age*vol, and mass of salt )
+      !!------------------------------------------------------------------
+      INTEGER , DIMENSION(:,:), INTENT(in) ::   kdonor   ! donor category index
+      REAL(wp), DIMENSION(:,:), INTENT(in) ::   pdaice   ! ice area transferred across boundary
+      REAL(wp), DIMENSION(:,:), INTENT(in) ::   pdvice   ! ice volume transferred across boundary
+      !
+      INTEGER  ::   ji, jj, jl, jk     ! dummy loop indices
+      INTEGER  ::   ii, ij, jl2, jl1   ! local integers
+      REAL(wp) ::   ztrans             ! ice/snow transferred
+      REAL(wp), DIMENSION(jpij)     ::   zworka, zworkv   ! workspace
+      REAL(wp), DIMENSION(jpij,jpl) ::   zaTsfn           !  -    -
+      !!------------------------------------------------------------------
+         
+      CALL tab_3d_2d( npti, nptidx(1:npti), h_i_2d (1:npti,1:jpl), h_i  )
+      CALL tab_3d_2d( npti, nptidx(1:npti), a_i_2d (1:npti,1:jpl), a_i  )
+      CALL tab_3d_2d( npti, nptidx(1:npti), v_i_2d (1:npti,1:jpl), v_i  )
+      CALL tab_3d_2d( npti, nptidx(1:npti), v_s_2d (1:npti,1:jpl), v_s  )
+      CALL tab_3d_2d( npti, nptidx(1:npti), oa_i_2d(1:npti,1:jpl), oa_i )
+      CALL tab_3d_2d( npti, nptidx(1:npti), sv_i_2d(1:npti,1:jpl), sv_i )
+      CALL tab_3d_2d( npti, nptidx(1:npti), a_ip_2d(1:npti,1:jpl), a_ip )
+      CALL tab_3d_2d( npti, nptidx(1:npti), v_ip_2d(1:npti,1:jpl), v_ip )
+      CALL tab_3d_2d( npti, nptidx(1:npti), t_su_2d(1:npti,1:jpl), t_su )
+
+      !----------------------------------------------------------------------------------------------
+      ! 1) Define a variable equal to a_i*T_su
+      !----------------------------------------------------------------------------------------------
+      DO jl = 1, jpl
+         DO ji = 1, npti
+            zaTsfn(ji,jl) = a_i_2d(ji,jl) * t_su_2d(ji,jl)
+         END DO
+      END DO
+      
+      !-------------------------------------------------------------------------------
+      ! 2) Transfer volume and energy between categories
+      !-------------------------------------------------------------------------------
+      DO jl = 1, jpl - 1
+         DO ji = 1, npti
+            !
+            jl1 = kdonor(ji,jl)
+            !
+            IF( jl1 > 0 ) THEN
+               !
+               IF ( jl1 == jl  ) THEN   ;   jl2 = jl1+1
+               ELSE                     ;   jl2 = jl 
+               ENDIF
+               !
+               IF( v_i_2d(ji,jl1) >= epsi10 ) THEN   ;   zworkv(ji) = pdvice(ji,jl) / v_i_2d(ji,jl1)
+               ELSE                                  ;   zworkv(ji) = 0._wp
+               ENDIF
+               IF( a_i_2d(ji,jl1) >= epsi10 ) THEN   ;   zworka(ji) = pdaice(ji,jl) / a_i_2d(ji,jl1)
+               ELSE                                  ;   zworka(ji) = 0._wp
+               ENDIF
+               !
+               a_i_2d(ji,jl1) = a_i_2d(ji,jl1) - pdaice(ji,jl)       ! Ice areas
+               a_i_2d(ji,jl2) = a_i_2d(ji,jl2) + pdaice(ji,jl)
+               !
+               v_i_2d(ji,jl1) = v_i_2d(ji,jl1) - pdvice(ji,jl)       ! Ice volumes
+               v_i_2d(ji,jl2) = v_i_2d(ji,jl2) + pdvice(ji,jl)
+               !
+               ztrans         = v_s_2d(ji,jl1) * zworkv(ji)          ! Snow volumes
+               v_s_2d(ji,jl1) = v_s_2d(ji,jl1) - ztrans
+               v_s_2d(ji,jl2) = v_s_2d(ji,jl2) + ztrans 
+               !          
+               !                                                     ! Ice age 
+               ztrans          = oa_i_2d(ji,jl1) * zworka(ji)
+               oa_i_2d(ji,jl1) = oa_i_2d(ji,jl1) - ztrans
+               oa_i_2d(ji,jl2) = oa_i_2d(ji,jl2) + ztrans
+               !
+               ztrans          = sv_i_2d(ji,jl1) * zworkv(ji)        ! Ice salinity
+               sv_i_2d(ji,jl1) = sv_i_2d(ji,jl1) - ztrans
+               sv_i_2d(ji,jl2) = sv_i_2d(ji,jl2) + ztrans
+               !
+               !                                                     ! Surface temperature
+               ztrans          = zaTsfn(ji,jl1) * zworka(ji)
+               zaTsfn(ji,jl1)  = zaTsfn(ji,jl1) - ztrans
+               zaTsfn(ji,jl2)  = zaTsfn(ji,jl2) + ztrans
+               !  
+               IF ( ln_pnd_H12 ) THEN
+                  !                                                  ! Pond fraction
+                  ztrans          = a_ip_2d(ji,jl1) * zworka(ji)
+                  a_ip_2d(ji,jl1) = a_ip_2d(ji,jl1) - ztrans
+                  a_ip_2d(ji,jl2) = a_ip_2d(ji,jl2) + ztrans
+                  !                                                  ! Pond volume (also proportional to da/a)
+                  ztrans          = v_ip_2d(ji,jl1) * zworka(ji)
+                  v_ip_2d(ji,jl1) = v_ip_2d(ji,jl1) - ztrans
+                  v_ip_2d(ji,jl2) = v_ip_2d(ji,jl2) + ztrans
+               ENDIF
+               !
+            ENDIF   ! jl1 >0
+         END DO
+         !
+         DO jk = 1, nlay_s         !--- Snow heat content
+            !
+            DO ji = 1, npti
+               ii = MOD( nptidx(ji) - 1, jpi ) + 1
+               ij = ( nptidx(ji) - 1 ) / jpi + 1
+               !
+               jl1 = kdonor(ji,jl)
+               !
+               IF( jl1 > 0 ) THEN
+                  IF(jl1 == jl) THEN  ;  jl2 = jl+1
+                  ELSE                ;  jl2 = jl
+                  ENDIF
+                  !
+                  ztrans            = e_s(ii,ij,jk,jl1) * zworkv(ji)
+                  e_s(ii,ij,jk,jl1) = e_s(ii,ij,jk,jl1) - ztrans
+                  e_s(ii,ij,jk,jl2) = e_s(ii,ij,jk,jl2) + ztrans
+               ENDIF
+            END DO
+         END DO
+         !
+         DO jk = 1, nlay_i         !--- Ice heat content
+            DO ji = 1, npti
+               ii = MOD( nptidx(ji) - 1, jpi ) + 1
+               ij = ( nptidx(ji) - 1 ) / jpi + 1
+               !
+               jl1 = kdonor(ji,jl)
+               !
+               IF( jl1 > 0 ) THEN
+                  IF(jl1 == jl) THEN  ;  jl2 = jl+1
+                  ELSE                ;  jl2 = jl
+                  ENDIF
+                  !
+                  ztrans            = e_i(ii,ij,jk,jl1) * zworkv(ji)
+                  e_i(ii,ij,jk,jl1) = e_i(ii,ij,jk,jl1) - ztrans
+                  e_i(ii,ij,jk,jl2) = e_i(ii,ij,jk,jl2) + ztrans
+               ENDIF
+            END DO
+         END DO
+         !
+      END DO                   ! boundaries, 1 to jpl-1
+      
+      !-------------------------------------------------------------------------------
+      ! 3) Update ice thickness and temperature
+      !-------------------------------------------------------------------------------
+      WHERE( a_i_2d(1:npti,:) >= epsi20 )
+         h_i_2d(1:npti,:)  =  v_i_2d(1:npti,:) / a_i_2d(1:npti,:) 
+         t_su_2d(1:npti,:)  =  zaTsfn(1:npti,:) / a_i_2d(1:npti,:) 
+      ELSEWHERE
+         h_i_2d(1:npti,:)  = 0._wp
+         t_su_2d(1:npti,:)  = rt0
+      END WHERE
+      !
+      CALL tab_2d_3d( npti, nptidx(1:npti), h_i_2d (1:npti,1:jpl), h_i  )
+      CALL tab_2d_3d( npti, nptidx(1:npti), a_i_2d (1:npti,1:jpl), a_i  )
+      CALL tab_2d_3d( npti, nptidx(1:npti), v_i_2d (1:npti,1:jpl), v_i  )
+      CALL tab_2d_3d( npti, nptidx(1:npti), v_s_2d (1:npti,1:jpl), v_s  )
+      CALL tab_2d_3d( npti, nptidx(1:npti), oa_i_2d(1:npti,1:jpl), oa_i )
+      CALL tab_2d_3d( npti, nptidx(1:npti), sv_i_2d(1:npti,1:jpl), sv_i )
+      CALL tab_2d_3d( npti, nptidx(1:npti), a_ip_2d(1:npti,1:jpl), a_ip )
+      CALL tab_2d_3d( npti, nptidx(1:npti), v_ip_2d(1:npti,1:jpl), v_ip )
+      CALL tab_2d_3d( npti, nptidx(1:npti), t_su_2d(1:npti,1:jpl), t_su )
+      !
+   END SUBROUTINE itd_shiftice
+   
+
+   SUBROUTINE ice_itd_reb( kt )
+      !!------------------------------------------------------------------
+      !!                ***  ROUTINE ice_itd_reb ***
+      !!
+      !! ** Purpose : rebin - rebins thicknesses into defined categories
+      !!
+      !! ** Method  : If a category thickness is out of bounds, shift part (for down to top)
+      !!              or entire (for top to down) area, volume, and energy
+      !!              to the neighboring category
+      !!------------------------------------------------------------------
+      INTEGER , INTENT (in) ::   kt      ! Ocean time step 
+      INTEGER ::   ji, jj, jl   ! dummy loop indices
+      !
+      INTEGER , DIMENSION(jpij,jpl-1) ::   jdonor           ! donor category index
+      REAL(wp), DIMENSION(jpij,jpl-1) ::   zdaice, zdvice   ! ice area and volume transferred
+      !!------------------------------------------------------------------
+      !
+      IF( kt == nit000 .AND. lwp )   WRITE(numout,*) '-- ice_itd_reb: rebining ice thickness distribution' 
+      !
+      jdonor(:,:) = 0
+      zdaice(:,:) = 0._wp
+      zdvice(:,:) = 0._wp
+      !
+      !                       !---------------------------------------
+      DO jl = 1, jpl-1        ! identify thicknesses that are too big
+         !                    !---------------------------------------
+         npti = 0   ;   nptidx(:) = 0
+         DO jj = 1, jpj
+            DO ji = 1, jpi
+               IF( a_i(ji,jj,jl) > epsi10 .AND. v_i(ji,jj,jl) > (a_i(ji,jj,jl) * hi_max(jl)) ) THEN
+                  npti = npti + 1
+                  nptidx( npti ) = (jj - 1) * jpi + ji                  
+               ENDIF
+            END DO
+         END DO
+         !
+!!clem   CALL tab_2d_1d( npti, nptidx(1:npti), h_i_1d (1:npti), h_i(:,:,jl)   )
+         CALL tab_2d_1d( npti, nptidx(1:npti), a_i_1d  (1:npti), a_i(:,:,jl)    )
+         CALL tab_2d_1d( npti, nptidx(1:npti), v_i_1d  (1:npti), v_i(:,:,jl)    )
+         !
+         DO ji = 1, npti
+            jdonor(ji,jl)  = jl 
+            ! how much of a_i you send in cat sup is somewhat arbitrary
+!!clem: these do not work properly after a restart (I do not know why)
+!!          zdaice(ji,jl)  = a_i_1d(ji) * ( h_i_1d(ji) - hi_max(jl) + epsi10 ) / h_i_1d(ji)  
+!!          zdvice(ji,jl)  = v_i_1d(ji) - ( a_i_1d(ji) - zdaice(ji,jl) ) * ( hi_max(jl) - epsi10 )
+!!clem: these do not work properly after a restart (I do not know why)
+!!            zdaice(ji,jl)  = a_i_1d(ji)
+!!            zdvice(ji,jl)  = v_i_1d(ji)
+!!clem: these are from UCL and work ok
+            zdaice(ji,jl)  = a_i_1d(ji) * 0.5_wp
+            zdvice(ji,jl)  = v_i_1d(ji) - zdaice(ji,jl) * ( hi_max(jl) + hi_max(jl-1) ) * 0.5_wp
+         END DO
+         !
+         IF( npti > 0 ) THEN
+            CALL itd_shiftice( jdonor(1:npti,:), zdaice(1:npti,:), zdvice(1:npti,:) )  ! Shift jl=>jl+1
+            ! Reset shift parameters
+            jdonor(1:npti,jl) = 0
+            zdaice(1:npti,jl) = 0._wp
+            zdvice(1:npti,jl) = 0._wp
+         ENDIF
+         !
+      END DO
+
+      !                       !-----------------------------------------
+      DO jl = jpl-1, 1, -1    ! Identify thicknesses that are too small
+         !                    !-----------------------------------------
+         npti = 0 ; nptidx(:) = 0
+         DO jj = 1, jpj
+            DO ji = 1, jpi
+               IF( a_i(ji,jj,jl+1) > epsi10 .AND. v_i(ji,jj,jl+1) <= (a_i(ji,jj,jl+1) * hi_max(jl)) ) THEN
+                  npti = npti + 1
+                  nptidx( npti ) = (jj - 1) * jpi + ji                  
+               ENDIF
+            END DO
+         END DO
+         !
+         CALL tab_2d_1d( npti, nptidx(1:npti), a_i_1d  (1:npti), a_i(:,:,jl+1)    ) ! jl+1 is ok
+         CALL tab_2d_1d( npti, nptidx(1:npti), v_i_1d  (1:npti), v_i(:,:,jl+1)    ) ! jl+1 is ok
+         DO ji = 1, npti
+            jdonor(ji,jl) = jl + 1
+            zdaice(ji,jl) = a_i_1d(ji) 
+            zdvice(ji,jl) = v_i_1d(ji)
+         END DO
+         !
+         IF( npti > 0 ) THEN
+            CALL itd_shiftice( jdonor(1:npti,:), zdaice(1:npti,:), zdvice(1:npti,:) )  ! Shift jl+1=>jl
+            ! Reset shift parameters
+            jdonor(1:npti,jl) = 0
+            zdaice(1:npti,jl) = 0._wp
+            zdvice(1:npti,jl) = 0._wp
+         ENDIF
+         !
+      END DO
+      !
+   END SUBROUTINE ice_itd_reb
+
+
+   SUBROUTINE ice_itd_init
+      !!------------------------------------------------------------------
+      !!                ***  ROUTINE ice_itd_init ***
+      !!
+      !! ** Purpose :   Initializes the ice thickness distribution
+      !! ** Method  :   ...
+      !! ** input   :   Namelist namitd
+      !!-------------------------------------------------------------------
+      INTEGER  ::   jl            ! dummy loop index
+      INTEGER  ::   ios, ioptio   ! Local integer output status for namelist read
+      REAL(wp) ::   zhmax, znum, zden, zalpha   !   -      -
+      !
+      NAMELIST/namitd/ ln_cat_hfn, rn_himean, ln_cat_usr, rn_catbnd, rn_himin
+      !!------------------------------------------------------------------
+      !
+      REWIND( numnam_ice_ref )      ! Namelist namitd in reference namelist : Parameters for ice
+      READ  ( numnam_ice_ref, namitd, IOSTAT = ios, ERR = 901)
+901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namitd in reference namelist', lwp )
+      REWIND( numnam_ice_cfg )      ! Namelist namitd in configuration namelist : Parameters for ice
+      READ  ( numnam_ice_cfg, namitd, IOSTAT = ios, ERR = 902 )
+902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namitd in configuration namelist', lwp )
+      IF(lwm) WRITE( numoni, namitd )
+      !
+      IF(lwp) THEN                  ! control print
+         WRITE(numout,*)
+         WRITE(numout,*) 'ice_itd_init: Initialization of ice cat distribution '
+         WRITE(numout,*) '~~~~~~~~~~~~'
+         WRITE(numout,*) '   Namelist namitd: '
+         WRITE(numout,*) '      Ice categories are defined by a function of rn_himean**(-0.05)    ln_cat_hfn = ', ln_cat_hfn
+         WRITE(numout,*) '         mean ice thickness in the domain                               rn_himean  = ', rn_himean
+         WRITE(numout,*) '      Ice categories are defined by rn_catbnd                           ln_cat_usr = ', ln_cat_usr
+         WRITE(numout,*) '      minimum ice thickness                                             rn_himin   = ', rn_himin 
+      ENDIF
+      !
+      !-----------------------------------!
+      !  Thickness categories boundaries  !
+      !-----------------------------------!
+      !                             !== set the choice of ice categories ==!
+      ioptio = 0 
+      IF( ln_cat_hfn ) THEN   ;   ioptio = ioptio + 1   ;   nice_catbnd = np_cathfn    ;   ENDIF
+      IF( ln_cat_usr ) THEN   ;   ioptio = ioptio + 1   ;   nice_catbnd = np_catusr    ;   ENDIF
+      IF( ioptio /= 1 )   CALL ctl_stop( 'ice_itd_init: choose one and only one ice categories boundaries' )
+      !
+      SELECT CASE( nice_catbnd )
+      !                                !------------------------!
+      CASE( np_cathfn )                ! h^(-alpha) function
+         !                             !------------------------!
+         zalpha = 0.05_wp
+         zhmax  = 3._wp * rn_himean
+         hi_max(0) = 0._wp
+         DO jl = 1, jpl
+            znum = jpl * ( zhmax+1 )**zalpha
+            zden = REAL( jpl-jl , wp ) * ( zhmax + 1._wp )**zalpha + REAL( jl , wp )
+            hi_max(jl) = ( znum / zden )**(1./zalpha) - 1
+         END DO
+         !                             !------------------------!
+      CASE( np_catusr )                ! user defined
+         !                             !------------------------!
+         DO jl = 0, jpl
+            hi_max(jl) = rn_catbnd(jl)
+         END DO
+         !
+      END SELECT
+      !
+      DO jl = 1, jpl                ! mean thickness by category
+         hi_mean(jl) = ( hi_max(jl) + hi_max(jl-1) ) * 0.5_wp
+      END DO
+      !
+      hi_max(jpl) = 99._wp          ! set to a big value to ensure that all ice is thinner than hi_max(jpl)
+      !
+      IF(lwp) WRITE(numout,*)
+      IF(lwp) WRITE(numout,*) '   ===>>>   resulting thickness category boundaries :'
+      IF(lwp) WRITE(numout,*) '            hi_max(:)= ', hi_max(0:jpl)
+      !
+      IF( hi_max(1) < rn_himin )   CALL ctl_stop('ice_itd_init: the upper bound of the 1st category must be bigger than rn_himin')
+      !
+   END SUBROUTINE ice_itd_init
+
+#else
+   !!----------------------------------------------------------------------
+   !!   Default option :         Empty module         NO SI3 sea-ice model
+   !!----------------------------------------------------------------------
+#endif
+
+   !!======================================================================
+END MODULE iceitd
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/ICE_SRC/icerst.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/ICE_SRC/icerst.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/ICE_SRC/icerst.F90	(revision 9570)
@@ -0,0 +1,256 @@
+MODULE icerst
+   !!======================================================================
+   !!                     ***  MODULE  icerst  ***
+   !!   sea-ice :  write/read the ice restart file
+   !!======================================================================
+   !! History:   3.0  ! 2005-04 (M. Vancoppenolle) Original code
+   !!             -   ! 2008-03 (C. Ethe) restart files in using IOM interface
+   !!            3.4  ! 2011-02 (G. Madec) dynamical allocation
+   !!            4.0  ! 2017-11 (M. Andrejczuk) Extend IOM interface to write 3D ice fields
+   !!----------------------------------------------------------------------
+#if defined key_si3
+   !!----------------------------------------------------------------------
+   !!   'key_si3'                                       SI3 sea-ice model
+   !!----------------------------------------------------------------------
+   !!   ice_rst_opn   : open  restart file
+   !!   ice_rst_write : write restart file 
+   !!   ice_rst_read  : read  restart file 
+   !!----------------------------------------------------------------------
+   USE ice            ! sea-ice variables
+   USE dom_oce        ! ocean domain
+   USE sbc_oce , ONLY : nn_fsbc, ln_cpl
+   USE icectl
+   !
+   USE in_out_manager ! I/O manager
+   USE iom            ! I/O manager library
+   USE lib_mpp        ! MPP library
+   USE lib_fortran    ! fortran utilities (glob_sum + no signed zero)
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   ice_rst_opn     ! called by icestp
+   PUBLIC   ice_rst_write   ! called by icestp
+   PUBLIC   ice_rst_read    ! called by ice_init
+
+   !!----------------------------------------------------------------------
+   !! NEMO/ICE 4.0 , NEMO Consortium (2017)
+   !! $Id: icerst.F90 8411 2017-08-07 16:09:12Z clem $
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE ice_rst_opn( kt )
+      !!----------------------------------------------------------------------
+      !!                    ***  ice_rst_opn  ***
+      !!
+      !! ** purpose  :   open restart file
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT(in) ::   kt       ! number of iteration
+      !
+      CHARACTER(len=20)   ::   clkt     ! ocean time-step define as a character
+      CHARACTER(len=50)   ::   clname   ! ice output restart file name
+      CHARACTER(len=256)  ::   clpath   ! full path to ice output restart file 
+      !!----------------------------------------------------------------------
+      !
+      IF( kt == nit000 )   lrst_ice = .FALSE.   ! default definition
+
+      ! in order to get better performances with NetCDF format, we open and define the ice restart file 
+      ! one ice time step before writing the data (-> at nitrst - 2*nn_fsbc + 1), except if we write ice 
+      ! restart files every ice time step or if an ice restart file was writen at nitend - 2*nn_fsbc + 1
+      IF( kt == nitrst - 2*nn_fsbc + 1 .OR. nstock == nn_fsbc    &
+         &                             .OR. ( kt == nitend - nn_fsbc + 1 .AND. .NOT. lrst_ice ) ) THEN
+         IF( nitrst <= nitend .AND. nitrst > 0 ) THEN
+            ! beware of the format used to write kt (default is i8.8, that should be large enough...)
+            IF( nitrst > 99999999 ) THEN   ;   WRITE(clkt, *       ) nitrst
+            ELSE                           ;   WRITE(clkt, '(i8.8)') nitrst
+            ENDIF
+            ! create the file
+            clname = TRIM(cexper)//"_"//TRIM(ADJUSTL(clkt))//"_"//TRIM(cn_icerst_out)
+            clpath = TRIM(cn_icerst_outdir) 
+            IF( clpath(LEN_TRIM(clpath):) /= '/' ) clpath = TRIM(clpath)//'/'
+            IF(lwp) THEN
+               WRITE(numout,*)
+               SELECT CASE ( jprstlib )
+               CASE DEFAULT
+                  WRITE(numout,*) '             open ice restart NetCDF file: ',TRIM(clpath)//clname
+               END SELECT
+               IF( kt == nitrst - 2*nn_fsbc + 1 ) THEN
+                  WRITE(numout,*) '             kt = nitrst - 2*nn_fsbc + 1 = ', kt,' date= ', ndastp
+               ELSE
+                  WRITE(numout,*) '             kt = '                         , kt,' date= ', ndastp
+               ENDIF
+            ENDIF
+            !
+            CALL iom_open( TRIM(clpath)//TRIM(clname), numriw, ldwrt = .TRUE., kiolib = jprstlib, kdlev = jpl )
+            lrst_ice = .TRUE.
+         ENDIF
+      ENDIF
+      !
+      IF( ln_icectl )   CALL ice_prt( kt, iiceprt, jiceprt, 1, ' - Beginning the time step - ' )   ! control print
+      !
+   END SUBROUTINE ice_rst_opn
+
+
+   SUBROUTINE ice_rst_write( kt )
+      !!----------------------------------------------------------------------
+      !!                    ***  ice_rst_write  ***
+      !!
+      !! ** purpose  :   write restart file
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT(in) ::   kt     ! number of iteration
+      !!
+      INTEGER ::   jk ,jl   ! dummy loop indices
+      INTEGER ::   iter
+      CHARACTER(len=25) ::   znam
+      CHARACTER(len=2)  ::   zchar, zchar1
+      REAL(wp), DIMENSION(jpi,jpj,jpl) ::   z3d   ! 3D workspace
+      !!----------------------------------------------------------------------
+
+      iter = kt + nn_fsbc - 1   ! ice restarts are written at kt == nitrst - nn_fsbc + 1
+
+      IF( iter == nitrst ) THEN
+         IF(lwp) WRITE(numout,*)
+         IF(lwp) WRITE(numout,*) 'ice_rst_write : write ice restart file  kt =', kt
+         IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~~'         
+      ENDIF
+
+      ! Write in numriw (if iter == nitrst)
+      ! ------------------ 
+      !                                                                        ! calendar control
+      CALL iom_rstput( iter, nitrst, numriw, 'nn_fsbc', REAL( nn_fsbc, wp ) )      ! time-step 
+      CALL iom_rstput( iter, nitrst, numriw, 'kt_ice' , REAL( iter   , wp ) )      ! date
+
+      ! Prognostic variables
+      CALL iom_rstput( iter, nitrst, numriw, 'v_i' , v_i  )
+      CALL iom_rstput( iter, nitrst, numriw, 'v_s' , v_s  )
+      CALL iom_rstput( iter, nitrst, numriw, 'sv_i', sv_i )
+      CALL iom_rstput( iter, nitrst, numriw, 'oa_i', oa_i )
+      CALL iom_rstput( iter, nitrst, numriw, 'a_i' , a_i  )
+      CALL iom_rstput( iter, nitrst, numriw, 't_su', t_su )
+      ! Melt ponds
+      CALL iom_rstput( iter, nitrst, numriw, 'a_ip', a_ip )
+      CALL iom_rstput( iter, nitrst, numriw, 'v_ip', v_ip )
+      ! Snow enthalpy
+      DO jk = 1, nlay_s 
+         WRITE(zchar1,'(I2.2)') jk
+         znam = 'e_s'//'_l'//zchar1
+         z3d(:,:,:) = e_s(:,:,jk,:)
+         CALL iom_rstput( iter, nitrst, numriw, znam , z3d )
+      END DO
+      ! Ice enthalpy
+      DO jk = 1, nlay_i 
+         WRITE(zchar1,'(I2.2)') jk
+         znam = 'e_i'//'_l'//zchar1
+         z3d(:,:,:) = e_i(:,:,jk,:)
+         CALL iom_rstput( iter, nitrst, numriw, znam , z3d )
+      END DO
+      ! ice velocity
+      CALL iom_rstput( iter, nitrst, numriw, 'u_ice', u_ice ) ! u_ice
+      CALL iom_rstput( iter, nitrst, numriw, 'v_ice', v_ice ) ! v_ice
+      ! fields needed for Met Office (Jules) coupling
+      IF( ln_cpl ) THEN
+         CALL iom_rstput( iter, nitrst, numriw, 'cnd_ice', cnd_ice )
+         CALL iom_rstput( iter, nitrst, numriw, 't1_ice' , t1_ice  )
+      ENDIF
+      !
+
+      ! close restart file
+      ! ------------------
+      IF( iter == nitrst ) THEN
+         CALL iom_close( numriw )
+         lrst_ice = .FALSE.
+      ENDIF
+      !
+   END SUBROUTINE ice_rst_write
+
+
+   SUBROUTINE ice_rst_read
+      !!----------------------------------------------------------------------
+      !!                    ***  ice_rst_read  ***
+      !!
+      !! ** purpose  :   read restart file
+      !!----------------------------------------------------------------------
+      INTEGER           ::   jk, jl
+      LOGICAL           ::   llok
+      INTEGER           ::   id1            ! local integer
+      INTEGER           ::   jlibalt = jprstlib
+      CHARACTER(len=25) ::   znam
+      CHARACTER(len=2)  ::   zchar, zchar1
+      REAL(wp)          ::   zfice, ziter
+      REAL(wp), DIMENSION(jpi,jpj,jpl) ::   z3d   ! 3D workspace
+      !!----------------------------------------------------------------------
+
+      IF(lwp) THEN
+         WRITE(numout,*)
+         WRITE(numout,*) 'ice_rst_read: read ice NetCDF restart file'
+         WRITE(numout,*) '~~~~~~~~~~~~'
+      ENDIF
+
+      CALL iom_open ( TRIM(cn_icerst_indir)//'/'//cn_icerst_in, numrir, kiolib = jprstlib, kdlev = jpl )
+
+      CALL iom_get( numrir, 'nn_fsbc', zfice )
+      CALL iom_get( numrir, 'kt_ice' , ziter )    
+      IF(lwp) WRITE(numout,*) '   read ice restart file at time step    : ', ziter
+      IF(lwp) WRITE(numout,*) '   in any case we force it to nit000 - 1 : ', nit000 - 1
+
+      ! Control of date
+      IF( ( nit000 - NINT(ziter) ) /= 1 .AND. ABS( nrstdt ) == 1 )   &
+         &     CALL ctl_stop( 'ice_rst_read ===>>>> : problem with nit000 in ice restart',  &
+         &                   '   verify the file or rerun with the value 0 for the',        &
+         &                   '   control of time parameter  nrstdt' )
+      IF( NINT(zfice) /= nn_fsbc          .AND. ABS( nrstdt ) == 1 )   &
+         &     CALL ctl_stop( 'ice_rst_read ===>>>> : problem with nn_fsbc in ice restart',  &
+         &                   '   verify the file or rerun with the value 0 for the',         &
+         &                   '   control of time parameter  nrstdt' )
+
+      ! Prognostic variables 
+      CALL iom_get( numrir, jpdom_autoglo, 'v_i' , v_i  )
+      CALL iom_get( numrir, jpdom_autoglo, 'v_s' , v_s  )
+      CALL iom_get( numrir, jpdom_autoglo, 'sv_i', sv_i )
+      CALL iom_get( numrir, jpdom_autoglo, 'oa_i', oa_i )
+      CALL iom_get( numrir, jpdom_autoglo, 'a_i' , a_i  )
+      CALL iom_get( numrir, jpdom_autoglo, 't_su', t_su )
+      ! Melt ponds
+      id1 = iom_varid( numrir, 'a_ip' , ldstop = .FALSE. )
+      IF( id1 > 0 ) THEN                       ! fields exist (melt ponds)
+         CALL iom_get( numrir, jpdom_autoglo, 'a_ip' , a_ip )
+         CALL iom_get( numrir, jpdom_autoglo, 'v_ip' , v_ip )
+      ELSE                                     ! start from rest
+         IF(lwp) WRITE(numout,*) '   ==>>   previous run without melt ponds output then set it to zero'
+         a_ip(:,:,:) = 0._wp
+         v_ip(:,:,:) = 0._wp
+      ENDIF
+      ! Snow enthalpy
+      DO jk = 1, nlay_s
+         WRITE(zchar1,'(I2.2)') jk
+         znam = 'e_s'//'_l'//zchar1
+         CALL iom_get( numrir, jpdom_autoglo, znam , z3d )
+         e_s(:,:,jk,:) = z3d(:,:,:)
+      END DO
+      ! Ice enthalpy
+      DO jk = 1, nlay_i
+         WRITE(zchar1,'(I2.2)') jk
+         znam = 'e_i'//'_l'//zchar1
+         CALL iom_get( numrir, jpdom_autoglo, znam , z3d )
+         e_i(:,:,jk,:) = z3d(:,:,:)
+      END DO
+      ! ice velocity
+      CALL iom_get( numrir, jpdom_autoglo, 'u_ice', u_ice )
+      CALL iom_get( numrir, jpdom_autoglo, 'v_ice', v_ice )
+      ! fields needed for Met Office (Jules) coupling
+      IF( ln_cpl ) THEN
+         CALL iom_get( numrir, jpdom_autoglo, 'cnd_ice', cnd_ice )
+         CALL iom_get( numrir, jpdom_autoglo, 't1_ice' , t1_ice  )
+      ENDIF
+
+   END SUBROUTINE ice_rst_read
+
+#else
+   !!----------------------------------------------------------------------
+   !!   Default option :       Empty module           NO SI3 sea-ice model
+   !!----------------------------------------------------------------------
+#endif
+
+   !!======================================================================
+END MODULE icerst
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/ICE_SRC/icestp.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/ICE_SRC/icestp.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/ICE_SRC/icestp.F90	(revision 9570)
@@ -0,0 +1,436 @@
+MODULE icestp
+   !!======================================================================
+   !!                       ***  MODULE  icestp  ***
+   !! Surface module :  update the ocean surface boundary condition over ice
+   !!                   covered area using SI3 sea-ice model
+   !!=====================================================================
+   !! History :  2.0  ! 2006-12  (M. Vancoppenolle) Original code
+   !!            3.0  ! 2008-02  (C. Talandier)  Surface module from icestp.F90
+   !!             -   ! 2008-04  (G. Madec)  sltyle and ice_ctl routine
+   !!            3.3  ! 2010-11  (G. Madec) ice-ocean stress always computed at each ocean time-step
+   !!            3.4  ! 2011-01  (A Porter)  dynamical allocation
+   !!             -   ! 2012-10  (C. Rousset)  add ice_dia
+   !!            3.6  ! 2014-07  (M. Vancoppenolle, G. Madec, O. Marti) revise coupled interface
+   !!            4.0  ! 2016-06  (L. Brodeau) new unified bulk routine (based on AeroBulk)
+   !!----------------------------------------------------------------------
+#if defined key_si3
+   !!----------------------------------------------------------------------
+   !!   'key_si3'                                       SI3 sea-ice model
+   !!----------------------------------------------------------------------
+   !!   ice_stp       : sea-ice model time-stepping and update ocean SBC over ice-covered area
+   !!   ice_init      : initialize sea-ice
+   !!----------------------------------------------------------------------
+   USE oce            ! ocean dynamics and tracers
+   USE dom_oce        ! ocean space and time domain
+   USE c1d            ! 1D vertical configuration
+   USE ice            ! sea-ice: variables
+   USE ice1D          ! sea-ice: thermodynamical 1D variables
+   !
+   USE phycst         ! Define parameters for the routines
+   USE eosbn2         ! equation of state
+   USE sbc_oce        ! Surface boundary condition: ocean fields
+   USE sbc_ice        ! Surface boundary condition: ice   fields
+   !
+   USE iceforcing     ! sea-ice: Surface boundary condition       !!gm why not icesbc module name
+   USE icedyn         ! sea-ice: dynamics
+   USE icethd         ! sea-ice: thermodynamics
+   USE icecor         ! sea-ice: corrections
+   USE iceupdate      ! sea-ice: sea surface boundary condition update
+   USE icedia         ! sea-ice: budget diagnostics
+   USE icewri         ! sea-ice: outputs
+   USE icerst         ! sea-ice: restarts
+   USE icevar         ! sea-ice: operations
+   USE icectl         ! sea-ice: control
+   USE iceistate      ! sea-ice: initial state
+   USE iceitd         ! sea-ice: remapping thickness distribution
+   USE icealb         ! sea-ice: albedo
+   !
+   USE bdy_oce , ONLY : ln_bdy   ! flag for bdy
+   USE bdyice         ! unstructured open boundary data for sea-ice
+# if defined key_agrif
+   USE agrif_ice
+   USE agrif_si3_interp
+# endif
+   !
+   USE in_out_manager ! I/O manager
+   USE iom            ! I/O manager library
+   USE lib_mpp        ! MPP library
+   USE lib_fortran    ! fortran utilities (glob_sum + no signed zero)
+   USE timing         ! Timing
+   USE prtctl         ! Print control
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   ice_stp    ! called by sbcmod.F90
+   PUBLIC   ice_init   ! called by sbcmod.F90
+
+   !! * Substitutions
+#  include "vectopt_loop_substitute.h90"
+   !!----------------------------------------------------------------------
+   !! NEMO/ICE 4.0 , NEMO Consortium (2017)
+   !! $Id: icestp.F90 8319 2017-07-11 15:00:44Z clem $
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE ice_stp( kt, ksbc )
+      !!---------------------------------------------------------------------
+      !!                  ***  ROUTINE ice_stp  ***
+      !!
+      !! ** Purpose :   sea-ice model time-stepping and update ocean surface
+      !!              boundary condition over ice-covered area
+      !!
+      !! ** Method  :   ice model time stepping
+      !!              - call the ice dynamics routine
+      !!              - call the ice advection/diffusion routine
+      !!              - call the ice thermodynamics routine
+      !!              - call the routine that computes mass and
+      !!                heat fluxes at the ice/ocean interface
+      !!              - save the outputs
+      !!              - save the outputs for restart when necessary
+      !!
+      !! ** Action  : - time evolution of the LIM sea-ice model
+      !!              - update all sbc variables below sea-ice:
+      !!                utau, vtau, taum, wndm, qns , qsr, emp , sfx
+      !!---------------------------------------------------------------------
+      INTEGER, INTENT(in) ::   kt      ! ocean time step
+      INTEGER, INTENT(in) ::   ksbc    ! flux formulation (user defined, bulk, or Pure Coupled)
+      !
+      INTEGER ::   jl   ! dummy loop index
+      !!----------------------------------------------------------------------
+      !
+      IF( ln_timing )   CALL timing_start('ice_stp')
+      !
+      !                                      !-----------------------!
+      IF( MOD( kt-1, nn_fsbc ) == 0 ) THEN   ! --- Ice time step --- !
+         !                                   !-----------------------!
+         !
+         kt_ice = kt                              ! -- Ice model time step
+         !
+         u_oce(:,:) = ssu_m(:,:)                  ! -- mean surface ocean current
+         v_oce(:,:) = ssv_m(:,:)
+         !
+         CALL eos_fzp( sss_m(:,:) , t_bo(:,:) )   ! -- freezing temperature [Kelvin] (set to rt0 over land)
+         t_bo(:,:) = ( t_bo(:,:) + rt0 ) * tmask(:,:,1) + rt0 * ( 1._wp - tmask(:,:,1) )
+         !
+         !                          !==  AGRIF Parent to Child  ==!
+#if defined key_agrif
+         !                              ! lim_nbstep ranges from 1 to the nb of child ocean steps inside one parent ice step
+         IF( .NOT. Agrif_Root() )       lim_nbstep = MOD( lim_nbstep, Agrif_irhot() * Agrif_Parent(nn_fsbc) / nn_fsbc ) + 1
+         !                              ! these calls must remain here for restartability purposes
+                                        CALL agrif_interp_si3( 'T' ) 
+                                        CALL agrif_interp_si3( 'U' )
+                                        CALL agrif_interp_si3( 'V' )
+#endif
+                                        CALL store_fields             ! Store now ice values
+         !
+         !------------------------------------------------!
+         ! --- Dynamical coupling with the atmosphere --- !
+         !------------------------------------------------!
+         ! It provides the following fields used in sea ice model:
+         !    utau_ice, vtau_ice = surface ice stress [N/m2]
+         !------------------------------------------------!
+                                        CALL ice_forcing_tau( kt, ksbc, utau_ice, vtau_ice )          
+         !-------------------------------------!
+         ! --- ice dynamics and advection  --- !
+         !-------------------------------------!
+                                        CALL diag_set0                ! set diag of mass, heat and salt fluxes to 0
+                                        CALL ice_rst_opn( kt )        ! Open Ice restart file (if necessary) 
+         !
+         IF( ln_icedyn .AND. .NOT.lk_c1d )   &
+            &                           CALL ice_dyn( kt )            ! -- Ice dynamics
+         !
+         !                          !==  lateral boundary conditions  ==!
+         IF( ln_icethd .AND. ln_bdy )   CALL bdy_ice( kt )            ! -- bdy ice thermo
+         !
+         !                          !==  previous lead fraction and ice volume for flux calculations
+                                        CALL ice_var_glo2eqv          ! h_i and h_s for ice albedo calculation
+                                        CALL ice_var_agg(1)           ! at_i for coupling 
+                                        CALL store_fields             ! Store now ice values
+         !
+         !------------------------------------------------------!
+         ! --- Thermodynamical coupling with the atmosphere --- !
+         !------------------------------------------------------!
+         ! It provides the following fields used in sea ice model:
+         !    emp_oce , emp_ice    = E-P over ocean and sea ice                    [Kg/m2/s]
+         !    sprecip              = solid precipitation                           [Kg/m2/s]
+         !    evap_ice             = sublimation                                   [Kg/m2/s]
+         !    qsr_tot , qns_tot    = solar & non solar heat flux (total)           [W/m2]
+         !    qsr_ice , qns_ice    = solar & non solar heat flux over ice          [W/m2]
+         !    dqns_ice             = non solar  heat sensistivity                  [W/m2]
+         !    qemp_oce, qemp_ice,  = sensible heat (associated with evap & precip) [W/m2]
+         !    qprec_ice, qevap_ice
+         !------------------------------------------------------!
+                                        CALL ice_forcing_flx( kt, ksbc )
+         !----------------------------!
+         ! --- ice thermodynamics --- !
+         !----------------------------!
+         IF( ln_icethd )                CALL ice_thd( kt )            ! -- Ice thermodynamics      
+         !
+         !
+         IF( ln_icethd )                CALL ice_cor( kt , 2 )        ! -- Corrections
+         !
+                                        CALL ice_var_glo2eqv          ! necessary calls (at least for coupling)
+                                        CALL ice_var_agg( 2 )         ! necessary calls (at least for coupling)
+         !
+!! clem: one should switch the calculation of the fluxes onto the parent grid but the following calls do not work
+!!       moreover it should only be called at the update frequency (as in agrif_si3_update.F90)
+!# if defined key_agrif
+!         IF( .NOT. Agrif_Root() )     CALL Agrif_ChildGrid_To_ParentGrid()
+!# endif
+                                        CALL ice_update_flx( kt )     ! -- Update ocean surface mass, heat and salt fluxes
+!# if defined key_agrif
+!         IF( .NOT. Agrif_Root() )     CALL Agrif_ParentGrid_To_ChildGrid()
+!# endif
+         IF( ln_icediahsb )             CALL ice_dia( kt )            ! -- Diagnostics outputs 
+         !
+                                        CALL ice_wri( kt )            ! -- Ice outputs 
+         !
+         IF( lrst_ice )                 CALL ice_rst_write( kt )      ! -- Ice restart file 
+         !
+         IF( ln_icectl )                CALL ice_ctl( kt )            ! -- alerts in case of model crash
+         !
+      ENDIF   ! End sea-ice time step only
+
+      !-------------------------!
+      ! --- Ocean time step --- !
+      !-------------------------!
+      IF( ln_icedyn )                   CALL ice_update_tau( kt, ub(:,:,1), vb(:,:,1) )   ! -- update surface ocean stresses
+!!gm   remark, the ocean-ice stress is not saved in ice diag call above .....  find a solution!!!
+      !
+      IF( ln_timing )   CALL timing_stop('ice_stp')
+      !
+   END SUBROUTINE ice_stp
+
+
+   SUBROUTINE ice_init
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE ice_init  ***
+      !!
+      !! ** purpose :   Initialize sea-ice parameters
+      !!----------------------------------------------------------------------
+      INTEGER :: ji, jj, ierr
+      !!----------------------------------------------------------------------
+      IF(lwp) WRITE(numout,*)
+      IF(lwp) WRITE(numout,*) 'ice_init: Arrays allocation & Initialization off all routines & init state' 
+      IF(lwp) WRITE(numout,*) '~~~~~~~~'
+      !
+      !                                ! Open the reference and configuration namelist files and namelist output file
+      CALL ctl_opn( numnam_ice_ref, 'namelist_ice_ref',    'OLD',     'FORMATTED', 'SEQUENTIAL', -1, numout, lwp )
+      CALL ctl_opn( numnam_ice_cfg, 'namelist_ice_cfg',    'OLD',     'FORMATTED', 'SEQUENTIAL', -1, numout, lwp )
+      IF(lwm) CALL ctl_opn( numoni, 'output.namelist.ice', 'UNKNOWN', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp, 1 )
+      !
+      CALL par_init                ! set some ice run parameters
+      !
+      !                                ! Allocate the ice arrays (sbc_ice already allocated in sbc_init)
+      ierr =        ice_alloc        ()      ! ice variables
+      ierr = ierr + sbc_ice_alloc    ()      ! surface forcing 
+      ierr = ierr + ice1D_alloc      ()      ! thermodynamics
+      !
+      IF( lk_mpp    )   CALL mpp_sum( ierr )
+      IF( ierr /= 0 )   CALL ctl_stop('STOP', 'ice_init : unable to allocate ice arrays')
+      !
+      CALL ice_itd_init                ! ice thickness distribution initialization
+      !
+      CALL ice_thd_init                ! set ice thermodynics parameters (clem: important to call it first for melt ponds)
+      !
+      !                                ! Initial sea-ice state
+      IF( .NOT. ln_rstart ) THEN              ! start from rest: sea-ice deduced from sst
+         CALL ice_istate_init
+         CALL ice_istate
+      ELSE                                    ! start from a restart file
+         CALL ice_rst_read
+      ENDIF
+      CALL ice_var_glo2eqv
+      CALL ice_var_agg(2)
+      !
+      CALL ice_forcing_init            ! set ice-ocean and ice-atm. coupling parameters
+      !
+      CALL ice_dyn_init                ! set ice dynamics parameters
+      !
+      CALL ice_update_init             ! ice surface boundary condition
+      !
+      CALL ice_alb_init                ! ice surface albedo
+      !
+      CALL ice_dia_init                ! initialization for diags
+      !
+      fr_i  (:,:)   = at_i(:,:)        ! initialisation of sea-ice fraction
+      tn_ice(:,:,:) = t_su(:,:,:)      ! initialisation of surface temp for coupled simu
+      !
+      !                                ! set max concentration in both hemispheres
+      WHERE( gphit(:,:) > 0._wp )   ;   rn_amax_2d(:,:) = rn_amax_n  ! NH
+      ELSEWHERE                     ;   rn_amax_2d(:,:) = rn_amax_s  ! SH
+      END WHERE
+
+      IF( ln_rstart )   CALL iom_close( numrir )  ! close input ice restart file
+      !
+   END SUBROUTINE ice_init
+
+
+   SUBROUTINE par_init
+      !!-------------------------------------------------------------------
+      !!                  ***  ROUTINE par_init ***
+      !!
+      !! ** Purpose :   Definition generic parameters for ice model
+      !!
+      !! ** Method  :   Read namelist and check the parameter
+      !!                values called at the first timestep (nit000)
+      !!
+      !! ** input   :   Namelist nampar
+      !!-------------------------------------------------------------------
+      INTEGER  ::   ios                 ! Local integer
+      !!
+      NAMELIST/nampar/ jpl, nlay_i, nlay_s, nn_virtual_itd, ln_icedyn, ln_icethd, rn_amax_n, rn_amax_s,  &
+         &             cn_icerst_in, cn_icerst_indir, cn_icerst_out, cn_icerst_outdir
+      !!-------------------------------------------------------------------
+      !
+      REWIND( numnam_ice_ref )      ! Namelist nampar in reference namelist : Parameters for ice
+      READ  ( numnam_ice_ref, nampar, IOSTAT = ios, ERR = 901)
+901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'nampar in reference namelist', lwp )
+      REWIND( numnam_ice_cfg )      ! Namelist nampar in configuration namelist : Parameters for ice
+      READ  ( numnam_ice_cfg, nampar, IOSTAT = ios, ERR = 902 )
+902   IF( ios > 0 )   CALL ctl_nam ( ios , 'nampar in configuration namelist', lwp )
+      IF(lwm) WRITE( numoni, nampar )
+      !
+      IF(lwp) THEN                  ! control print
+         WRITE(numout,*)
+         WRITE(numout,*) '   par_init: ice parameters shared among all the routines'
+         WRITE(numout,*) '   ~~~~~~~~'
+         WRITE(numout,*) '      Namelist nampar: '
+         WRITE(numout,*) '         number of ice  categories                           jpl       = ', jpl
+         WRITE(numout,*) '         number of ice  layers                               nlay_i    = ', nlay_i
+         WRITE(numout,*) '         number of snow layers                               nlay_s    = ', nlay_s
+         WRITE(numout,*) '         virtual ITD param for jpl=1 (1-3) or not (0)   nn_virtual_itd = ', nn_virtual_itd
+         WRITE(numout,*) '         Ice dynamics       (T) or not (F)                   ln_icedyn = ', ln_icedyn
+         WRITE(numout,*) '         Ice thermodynamics (T) or not (F)                   ln_icethd = ', ln_icethd
+         WRITE(numout,*) '         maximum ice concentration for NH                              = ', rn_amax_n 
+         WRITE(numout,*) '         maximum ice concentration for SH                              = ', rn_amax_s
+      ENDIF
+      !                                        !--- check consistency
+      IF ( jpl > 1 .AND. nn_virtual_itd == 1 ) THEN
+         nn_virtual_itd = 0
+         IF(lwp) WRITE(numout,*)
+         IF(lwp) WRITE(numout,*) '   nn_virtual_itd forced to 0 as jpl>1, no need with multiple categories to emulate them'
+      ENDIF
+      !
+	  IF( ln_cpl .AND. nn_cats_cpl /= 1 .AND. nn_cats_cpl /= jpl ) THEN
+	     CALL ctl_stop( 'STOP', 'par_init: in coupled mode, nn_cats_cpl should be either 1 or jpl' )
+	  ENDIF
+      !
+      IF( ln_bdy .AND. ln_icediachk )   CALL ctl_warn('par_init: online conservation check does not work with BDY')
+      !
+      rdt_ice   = REAL(nn_fsbc) * rdt          !--- sea-ice timestep and its inverse
+      r1_rdtice = 1._wp / rdt_ice
+      IF(lwp) WRITE(numout,*)
+      IF(lwp) WRITE(numout,*) '      ice timestep rdt_ice = nn_fsbc*rdt = ', rdt_ice
+      !
+      r1_nlay_i = 1._wp / REAL( nlay_i, wp )   !--- inverse of nlay_i and nlay_s
+      r1_nlay_s = 1._wp / REAL( nlay_s, wp )
+      !
+   END SUBROUTINE par_init
+
+
+   SUBROUTINE store_fields
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE store_fields  ***
+      !!
+      !! ** purpose :  store ice variables at "before" time step
+      !!----------------------------------------------------------------------
+      INTEGER  ::   ji, jj, jl      ! dummy loop index
+      !!----------------------------------------------------------------------
+      !
+      a_i_b (:,:,:)   = a_i (:,:,:)     ! ice area
+      v_i_b (:,:,:)   = v_i (:,:,:)     ! ice volume
+      v_s_b (:,:,:)   = v_s (:,:,:)     ! snow volume
+      sv_i_b(:,:,:)   = sv_i(:,:,:)     ! salt content
+      oa_i_b(:,:,:)   = oa_i(:,:,:)     ! areal age content
+      e_s_b (:,:,:,:) = e_s (:,:,:,:)   ! snow thermal energy
+      e_i_b (:,:,:,:) = e_i (:,:,:,:)   ! ice thermal energy
+      WHERE( a_i_b(:,:,:) >= epsi20 )
+         h_i_b(:,:,:) = v_i_b (:,:,:) / a_i_b(:,:,:)   ! ice thickness
+         h_s_b(:,:,:) = v_s_b (:,:,:) / a_i_b(:,:,:)   ! snw thickness
+      ELSEWHERE
+         h_i_b(:,:,:) = 0._wp
+         h_s_b(:,:,:) = 0._wp
+      END WHERE
+      !
+      ! ice velocities & total concentration
+      at_i_b(:,:)  = SUM( a_i_b(:,:,:), dim=3 )
+      u_ice_b(:,:) = u_ice(:,:)
+      v_ice_b(:,:) = v_ice(:,:)
+      !
+   END SUBROUTINE store_fields
+
+
+   SUBROUTINE diag_set0
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE diag_set0  ***
+      !!
+      !! ** purpose :  set ice-ocean and ice-atm. fluxes to zeros at the beggining
+      !!               of the time step
+      !!----------------------------------------------------------------------
+      INTEGER  ::   ji, jj      ! dummy loop index
+      !!----------------------------------------------------------------------
+      sfx    (:,:) = 0._wp   ;
+      sfx_bri(:,:) = 0._wp   ;   sfx_lam(:,:) = 0._wp
+      sfx_sni(:,:) = 0._wp   ;   sfx_opw(:,:) = 0._wp
+      sfx_bog(:,:) = 0._wp   ;   sfx_dyn(:,:) = 0._wp
+      sfx_bom(:,:) = 0._wp   ;   sfx_sum(:,:) = 0._wp
+      sfx_res(:,:) = 0._wp   ;   sfx_sub(:,:) = 0._wp
+      !
+      wfx_snw(:,:) = 0._wp   ;   wfx_ice(:,:) = 0._wp
+      wfx_sni(:,:) = 0._wp   ;   wfx_opw(:,:) = 0._wp
+      wfx_bog(:,:) = 0._wp   ;   wfx_dyn(:,:) = 0._wp
+      wfx_bom(:,:) = 0._wp   ;   wfx_sum(:,:) = 0._wp
+      wfx_res(:,:) = 0._wp   ;   wfx_sub(:,:) = 0._wp
+      wfx_spr(:,:) = 0._wp   ;   wfx_lam(:,:) = 0._wp  
+      wfx_snw_dyn(:,:) = 0._wp ; wfx_snw_sum(:,:) = 0._wp
+      wfx_snw_sub(:,:) = 0._wp ; wfx_ice_sub(:,:) = 0._wp
+      wfx_snw_sni(:,:) = 0._wp 
+      wfx_pnd(:,:) = 0._wp
+
+      hfx_thd(:,:) = 0._wp   ;
+      hfx_snw(:,:) = 0._wp   ;   hfx_opw(:,:) = 0._wp
+      hfx_bog(:,:) = 0._wp   ;   hfx_dyn(:,:) = 0._wp
+      hfx_bom(:,:) = 0._wp   ;   hfx_sum(:,:) = 0._wp
+      hfx_res(:,:) = 0._wp   ;   hfx_sub(:,:) = 0._wp
+      hfx_spr(:,:) = 0._wp   ;   hfx_dif(:,:) = 0._wp
+      hfx_err_rem(:,:) = 0._wp
+      hfx_err_dif(:,:) = 0._wp
+      wfx_err_sub(:,:) = 0._wp
+      !
+      afx_tot(:,:) = 0._wp   ;
+      !
+      diag_heat(:,:) = 0._wp ;   diag_sice(:,:) = 0._wp
+      diag_vice(:,:) = 0._wp ;   diag_vsnw(:,:) = 0._wp
+
+      ! SIMIP diagnostics
+      diag_fc_bo(:,:) = 0._wp ; diag_fc_su(:,:) = 0._wp
+      t_si(:,:,:) = rt0       ! temp at the ice-snow interface
+
+      tau_icebfr(:,:)   = 0._wp   ! landfast ice param only (clem: important to keep the init here)
+      cnd_ice   (:,:,:) = 0._wp   ! initialisation of the effective conductivity at the top of ice/snow (Jules coupling)
+      !
+      ! for control checks (ln_icediachk)
+      diag_trp_vi(:,:) = 0._wp   ;   diag_trp_vs(:,:) = 0._wp
+      diag_trp_ei(:,:) = 0._wp   ;   diag_trp_es(:,:) = 0._wp
+      diag_trp_sv(:,:) = 0._wp
+
+   END SUBROUTINE diag_set0
+
+#else
+   !!----------------------------------------------------------------------
+   !!   Default option           Dummy module         NO SI3 sea-ice model
+   !!----------------------------------------------------------------------
+CONTAINS
+   SUBROUTINE ice_stp ( kt, ksbc )     ! Dummy routine
+      INTEGER, INTENT(in) ::   kt, ksbc
+      WRITE(*,*) 'ice_stp: You should not have seen this print! error?', kt
+   END SUBROUTINE ice_stp
+   SUBROUTINE ice_init                 ! Dummy routine
+   END SUBROUTINE ice_init
+#endif
+
+   !!======================================================================
+END MODULE icestp
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/ICE_SRC/icetab.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/ICE_SRC/icetab.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/ICE_SRC/icetab.F90	(revision 9570)
@@ -0,0 +1,119 @@
+MODULE icetab
+   !!======================================================================
+   !!                       ***  MODULE icetab   ***
+   !!   sea-ice : transform 1D (2D) array to a 2D (1D) table
+   !!======================================================================
+#if defined key_si3
+   !!----------------------------------------------------------------------
+   !!   'key_si3'                                       SI3 sea-ice model
+   !!----------------------------------------------------------------------
+   !!   tab_3d_2d  : 3-D <==> 2-D
+   !!   tab_2d_3d  : 2-D <==> 3-D
+   !!   tab_2d_1d  : 2-D <==> 1-D
+   !!   tab_1d_2d  : 1-D <==> 2-D
+   !!----------------------------------------------------------------------
+   USE par_oce
+   USE ice, ONLY : jpl
+   
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   tab_3d_2d
+   PUBLIC   tab_2d_1d
+   PUBLIC   tab_2d_3d
+   PUBLIC   tab_1d_2d
+
+   !!----------------------------------------------------------------------
+   !! NEMO/ICE 4.0 , NEMO Consortium (2017)
+   !! $Id: icetab.F90 8369 2017-07-25 14:38:38Z clem $
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE tab_3d_2d( ndim1d, tab_ind, tab1d, tab2d )
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE tab_2d_1d  ***
+      !!----------------------------------------------------------------------
+      INTEGER                         , INTENT(in   ) ::   ndim1d   ! 1d size
+      INTEGER , DIMENSION(ndim1d)     , INTENT(in   ) ::   tab_ind  ! input index
+      REAL(wp), DIMENSION(jpi,jpj,jpl), INTENT(in   ) ::   tab2d    ! input 2D field
+      REAL(wp), DIMENSION(ndim1d,jpl) , INTENT(  out) ::   tab1d    ! output 1D field
+      !
+      INTEGER ::   jl, jn, jid, jjd
+      !!----------------------------------------------------------------------
+      DO jl = 1, jpl
+         DO jn = 1, ndim1d
+            jid          = MOD( tab_ind(jn) - 1 , jpi ) + 1
+            jjd          =    ( tab_ind(jn) - 1 ) / jpi + 1
+            tab1d(jn,jl) = tab2d(jid,jjd,jl)
+         END DO
+      END DO
+   END SUBROUTINE tab_3d_2d
+
+
+   SUBROUTINE tab_2d_1d( ndim1d, tab_ind, tab1d, tab2d )
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE tab_2d_1d  ***
+      !!----------------------------------------------------------------------
+      INTEGER                     , INTENT(in   ) ::   ndim1d   ! 1d size
+      INTEGER , DIMENSION(ndim1d) , INTENT(in   ) ::   tab_ind  ! input index
+      REAL(wp), DIMENSION(jpi,jpj), INTENT(in   ) ::   tab2d    ! input 2D field
+      REAL(wp), DIMENSION(ndim1d) , INTENT(  out) ::   tab1d    ! output 1D field
+      !
+      INTEGER ::   jn , jid, jjd
+      !!----------------------------------------------------------------------
+      DO jn = 1, ndim1d
+         jid        = MOD( tab_ind(jn) - 1 , jpi ) + 1
+         jjd        =    ( tab_ind(jn) - 1 ) / jpi + 1
+         tab1d( jn) = tab2d( jid, jjd)
+      END DO
+   END SUBROUTINE tab_2d_1d
+
+
+   SUBROUTINE tab_2d_3d( ndim1d, tab_ind, tab1d, tab2d )
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE tab_2d_1d  ***
+      !!----------------------------------------------------------------------
+      INTEGER                         , INTENT(in   ) ::   ndim1d    ! 1D size
+      INTEGER , DIMENSION(ndim1d)     , INTENT(in   ) ::   tab_ind   ! input index
+      REAL(wp), DIMENSION(ndim1d,jpl) , INTENT(in   ) ::   tab1d     ! input 1D field
+      REAL(wp), DIMENSION(jpi,jpj,jpl), INTENT(  out) ::   tab2d     ! output 2D field
+      !
+      INTEGER ::   jl, jn, jid, jjd
+      !!----------------------------------------------------------------------
+      DO jl = 1, jpl
+         DO jn = 1, ndim1d
+            jid               = MOD( tab_ind(jn) - 1 ,  jpi ) + 1
+            jjd               =    ( tab_ind(jn) - 1 ) / jpi  + 1
+            tab2d(jid,jjd,jl) = tab1d(jn,jl)
+         END DO
+      END DO
+   END SUBROUTINE tab_2d_3d
+
+
+   SUBROUTINE tab_1d_2d( ndim1d, tab_ind, tab1d, tab2d )
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE tab_2d_1d  ***
+      !!----------------------------------------------------------------------
+      INTEGER                     , INTENT(in   ) ::   ndim1d    ! 1D size
+      INTEGER , DIMENSION(ndim1d) , INTENT(in   ) ::   tab_ind   ! input index
+      REAL(wp), DIMENSION(ndim1d) , INTENT(in   ) ::   tab1d     ! input 1D field
+      REAL(wp), DIMENSION(jpi,jpj), INTENT(  out) ::   tab2d     ! output 2D field
+      !
+      INTEGER ::   jn , jid, jjd
+      !!----------------------------------------------------------------------
+      DO jn = 1, ndim1d
+         jid             = MOD( tab_ind(jn) - 1 ,  jpi ) + 1
+         jjd             =    ( tab_ind(jn) - 1 ) / jpi  + 1
+         tab2d(jid, jjd) = tab1d( jn)
+      END DO
+   END SUBROUTINE tab_1d_2d
+
+#else
+   !!----------------------------------------------------------------------
+   !!   Default option           Dummy module         NO SI3 sea-ice model
+   !!----------------------------------------------------------------------
+#endif
+
+   !!======================================================================
+END MODULE icetab
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/ICE_SRC/icethd.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/ICE_SRC/icethd.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/ICE_SRC/icethd.F90	(revision 9570)
@@ -0,0 +1,598 @@
+MODULE icethd
+   !!======================================================================
+   !!                  ***  MODULE icethd   ***
+   !!   sea-ice : master routine for thermodynamics
+   !!======================================================================
+   !! History :  LIM  ! 2000-01 (M.A. Morales Maqueda, H. Goosse, T. Fichefet) LIM-1
+   !!            2.0  ! 2002-07 (C. Ethe, G. Madec)  LIM-2 (F90 rewriting)
+   !!            3.0  ! 2005-11 (M. Vancoppenolle)  LIM-3 : Multi-layer thermodynamics + salinity variations
+   !!             -   ! 2007-04 (M. Vancoppenolle) add ice_thd_glohec, ice_thd_con_dh and ice_thd_con_dif
+   !!            3.2  ! 2009-07 (M. Vancoppenolle, Y. Aksenov, G. Madec) bug correction in wfx_snw
+   !!            3.3  ! 2010-11 (G. Madec) corrected snow melting heat (due to factor betas)
+   !!            4.0  ! 2011-02 (G. Madec) dynamical allocation
+   !!             -   ! 2012-05 (C. Rousset) add penetration solar flux
+   !!----------------------------------------------------------------------
+#if defined key_si3
+   !!----------------------------------------------------------------------
+   !!   'key_si3'                                       SI3 sea-ice model
+   !!----------------------------------------------------------------------
+   !!   ice_thd       : thermodynamics of sea ice
+   !!   ice_thd_init  : initialisation of sea-ice thermodynamics
+   !!----------------------------------------------------------------------
+   USE phycst         ! physical constants
+   USE dom_oce        ! ocean space and time domain variables
+   USE ice            ! sea-ice: variables
+!!gm list trop longue ==>>> why not passage en argument d'appel ?
+   USE sbc_oce , ONLY : sss_m, sst_m, e3t_m, utau, vtau, ssu_m, ssv_m, frq_m, qns_tot, qsr_tot, sprecip, ln_cpl
+   USE sbc_ice , ONLY : qsr_oce, qns_oce, qemp_oce, qsr_ice, qns_ice, dqns_ice, evap_ice, qprec_ice, qevap_ice, &
+      &                 qml_ice, qcn_ice, qsr_ice_tr
+   USE ice1D          ! sea-ice: thermodynamics variables
+   USE icethd_zdf     ! sea-ice: vertical heat diffusion
+   USE icethd_dh      ! sea-ice: ice-snow growth and melt
+   USE icethd_da      ! sea-ice: lateral melting
+   USE icethd_sal     ! sea-ice: salinity
+   USE icethd_ent     ! sea-ice: enthalpy redistribution
+   USE icethd_do      ! sea-ice: growth in open water
+   USE icethd_pnd     ! sea-ice: melt ponds
+   USE iceitd         ! sea-ice: remapping thickness distribution
+   USE icetab         ! sea-ice: 1D <==> 2D transformation
+   USE icevar         ! sea-ice: operations
+   USE icectl         ! sea-ice: control print
+   !
+   USE in_out_manager ! I/O manager
+   USE lib_mpp        ! MPP library
+   USE lib_fortran    ! fortran utilities (glob_sum + no signed zero)
+   USE lbclnk         ! lateral boundary conditions (or mpp links)
+   USE timing         ! Timing
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   ice_thd         ! called by limstp module
+   PUBLIC   ice_thd_init    ! called by ice_init
+
+   !!** namelist (namthd) **
+   LOGICAL ::   ln_icedH         ! activate ice thickness change from growing/melting (T) or not (F)
+   LOGICAL ::   ln_icedA         ! activate lateral melting param. (T) or not (F)
+   LOGICAL ::   ln_icedO         ! activate ice growth in open-water (T) or not (F)
+   LOGICAL ::   ln_icedS         ! activate gravity drainage and flushing (T) or not (F)
+
+   !! * Substitutions
+#  include "vectopt_loop_substitute.h90"
+   !!----------------------------------------------------------------------
+   !! NEMO/ICE 4.0 , NEMO Consortium (2017)
+   !! $Id: icethd.F90 8420 2017-08-08 12:18:46Z clem $
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE ice_thd( kt )
+      !!-------------------------------------------------------------------
+      !!                ***  ROUTINE ice_thd  ***       
+      !!  
+      !! ** Purpose : This routine manages ice thermodynamics
+      !!         
+      !! ** Action : - Initialisation of some variables
+      !!             - Some preliminary computation (oceanic heat flux
+      !!               at the ice base, snow acc.,heat budget of the leads)
+      !!             - selection of the icy points and put them in an array
+      !!             - call ice_thd_zdf  for vertical heat diffusion
+      !!             - call ice_thd_dh   for vertical ice growth and melt
+      !!             - call ice_thd_ent  for enthalpy remapping
+      !!             - call ice_thd_sal  for ice desalination
+      !!             - call ice_thd_temp to  retrieve temperature from ice enthalpy
+      !!             - call ice_thd_lam  for extra lateral ice melt if active virtual thickness distribution
+      !!             - call ice_thd_da   for lateral ice melt
+      !!             - back to the geographic grid
+      !!             - call ice_thd_rem  for remapping thickness distribution
+      !!             - call ice_thd_do   for ice growth in leads
+      !!-------------------------------------------------------------------
+      INTEGER, INTENT(in) :: kt    ! number of iteration
+      !
+      INTEGER  :: ji, jj, jk, jl   ! dummy loop indices
+      REAL(wp) :: zfric_u, zqld, zqfr, zqfr_neg
+      REAL(wp), PARAMETER :: zfric_umin = 0._wp           ! lower bound for the friction velocity (cice value=5.e-04)
+      REAL(wp), PARAMETER :: zch        = 0.0057_wp       ! heat transfer coefficient
+      REAL(wp), DIMENSION(jpi,jpj) ::   zu_io, zv_io, zfric   ! ice-ocean velocity (m/s) and frictional velocity (m2/s2)
+      !
+      !!-------------------------------------------------------------------
+      ! controls
+      IF( ln_timing    )   CALL timing_start('icethd')                                                             ! timing
+      IF( ln_icediachk )   CALL ice_cons_hsm(0, 'icethd', rdiag_v, rdiag_s, rdiag_t, rdiag_fv, rdiag_fs, rdiag_ft) ! conservation
+
+      IF( kt == nit000 .AND. lwp ) THEN
+         WRITE(numout,*)
+         WRITE(numout,*) 'ice_thd: sea-ice thermodynamics'
+         WRITE(numout,*) '~~~~~~~'
+      ENDIF
+      
+      CALL ice_var_glo2eqv
+
+      !---------------------------------------------!
+      ! computation of friction velocity at T points
+      !---------------------------------------------!
+      IF( ln_icedyn ) THEN
+         zu_io(:,:) = u_ice(:,:) - ssu_m(:,:)
+         zv_io(:,:) = v_ice(:,:) - ssv_m(:,:)
+         DO jj = 2, jpjm1 
+            DO ji = fs_2, fs_jpim1
+               zfric(ji,jj) = rn_cio * ( 0.5_wp *  &
+                  &                    (  zu_io(ji,jj) * zu_io(ji,jj) + zu_io(ji-1,jj) * zu_io(ji-1,jj)   &
+                  &                     + zv_io(ji,jj) * zv_io(ji,jj) + zv_io(ji,jj-1) * zv_io(ji,jj-1) ) ) * tmask(ji,jj,1)
+            END DO
+         END DO
+      ELSE      !  if no ice dynamics => transmit directly the atmospheric stress to the ocean
+         DO jj = 2, jpjm1
+            DO ji = fs_2, fs_jpim1
+               zfric(ji,jj) = r1_rau0 * SQRT( 0.5_wp *  &
+                  &                         (  utau(ji,jj) * utau(ji,jj) + utau(ji-1,jj) * utau(ji-1,jj)   &
+                  &                          + vtau(ji,jj) * vtau(ji,jj) + vtau(ji,jj-1) * vtau(ji,jj-1) ) ) * tmask(ji,jj,1)
+            END DO
+         END DO
+      ENDIF
+      CALL lbc_lnk( zfric, 'T',  1. )
+      !
+      ftr_ice(:,:,:) = 0._wp  ! initialization (part of solar radiation transmitted through the ice)
+
+      !--------------------------------------------------------------------!
+      ! Partial computation of forcing for the thermodynamic sea ice model
+      !--------------------------------------------------------------------!
+      DO jj = 1, jpj
+         DO ji = 1, jpi
+            rswitch  = tmask(ji,jj,1) * MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) - epsi10 ) ) ! 0 if no ice
+            !
+            !           !  solar irradiance transmission at the mixed layer bottom and used in the lead heat budget
+            !           !  practically no "direct lateral ablation"
+            !           
+            !           !  net downward heat flux from the ice to the ocean, expressed as a function of ocean 
+            !           !  temperature and turbulent mixing (McPhee, 1992)
+            !
+            ! --- Energy received in the lead, zqld is defined everywhere (J.m-2) --- !
+            zqld =  tmask(ji,jj,1) * rdt_ice *  &
+               &    ( ( 1._wp - at_i_b(ji,jj) ) * qsr_oce(ji,jj) * frq_m(ji,jj) +  &
+               &      ( 1._wp - at_i_b(ji,jj) ) * qns_oce(ji,jj) + qemp_oce(ji,jj) )
+
+            ! --- Energy needed to bring ocean surface layer until its freezing (<0, J.m-2) --- !
+            ! includes supercooling potential energy (>0) or "above-freezing" energy (<0)
+            zqfr = tmask(ji,jj,1) * rau0 * rcp * e3t_m(ji,jj) * ( t_bo(ji,jj) - ( sst_m(ji,jj) + rt0 ) )
+
+            ! --- Above-freezing sensible heat content (J/m2 grid)
+            zqfr_neg = tmask(ji,jj,1) * rau0 * rcp * e3t_m(ji,jj) * MIN( ( t_bo(ji,jj) - ( sst_m(ji,jj) + rt0 ) ), 0._wp )
+
+            ! --- Sensible ocean-to-ice heat flux (W/m2)
+            zfric_u      = MAX( SQRT( zfric(ji,jj) ), zfric_umin ) 
+            fhtur(ji,jj) = rswitch * rau0 * rcp * zch  * zfric_u * ( ( sst_m(ji,jj) + rt0 ) - t_bo(ji,jj) ) ! W.m-2
+
+            fhtur(ji,jj) = rswitch * MIN( fhtur(ji,jj), - zqfr_neg * r1_rdtice / MAX( at_i(ji,jj), epsi10 ) )
+            ! upper bound for fhtur: the heat retrieved from the ocean must be smaller than the heat necessary to reach 
+            !                        the freezing point, so that we do not have SST < T_freeze
+            !                        This implies: - ( fhtur(ji,jj) * at_i(ji,jj) * rtdice ) - zqfr >= 0
+
+            !-- Energy Budget of the leads (J.m-2), source of lateral accretion. Must be < 0 to form ice
+            qlead(ji,jj) = MIN( 0._wp , zqld - ( fhtur(ji,jj) * at_i(ji,jj) * rdt_ice ) - zqfr )
+
+            ! If there is ice and leads are warming, then transfer energy from the lead budget and use it for bottom melting 
+            IF( zqld > 0._wp ) THEN
+               fhld (ji,jj) = rswitch * zqld * r1_rdtice / MAX( at_i(ji,jj), epsi10 ) ! divided by at_i since this is (re)multiplied by a_i in icethd_dh.F90
+               qlead(ji,jj) = 0._wp
+            ELSE
+               fhld (ji,jj) = 0._wp
+            ENDIF
+            !
+            ! Net heat flux on top of the ice-ocean [W.m-2]
+            ! ---------------------------------------------
+            hfx_in(ji,jj) = qns_tot(ji,jj) + qsr_tot(ji,jj) 
+         END DO
+      END DO
+      
+      ! In case we bypass open-water ice formation
+      IF( .NOT. ln_icedO )  qlead(:,:) = 0._wp
+      ! In case we bypass growing/melting from top and bottom: we suppose ice is impermeable => ocean is isolated from atmosphere
+      IF( .NOT. ln_icedH ) THEN
+         hfx_in(:,:) = ( 1._wp - at_i_b(:,:) ) * ( qns_oce(:,:) + qsr_oce(:,:) ) + qemp_oce(:,:)
+         fhtur (:,:) = 0._wp
+         fhld  (:,:) = 0._wp
+      ENDIF
+
+      ! ---------------------------------------------------------------------
+      ! Net heat flux on top of the ocean after ice thermo (1st step) [W.m-2]
+      ! ---------------------------------------------------------------------
+      !     First  step here              :  non solar + precip - qlead - qturb
+      !     Second step in icethd_dh      :  heat remaining if total melt (zq_rema) 
+      !     Third  step in iceupdate.F90  :  heat from ice-ocean mass exchange (zf_mass) + solar
+      hfx_out(:,:) = ( 1._wp - at_i_b(:,:) ) * qns_oce(:,:) + qemp_oce(:,:)  &  ! Non solar heat flux received by the ocean               
+         &           - qlead(:,:) * r1_rdtice                                &  ! heat flux taken from the ocean where there is open water ice formation
+         &           - at_i (:,:) * fhtur(:,:)                               &  ! heat flux taken by turbulence
+         &           - at_i (:,:) *  fhld(:,:)                                  ! heat flux taken during bottom growth/melt 
+                                                                                !    (fhld should be 0 while bott growth)
+      !-------------------------------------------------------------------------------------------!
+      ! Thermodynamic computation (only on grid points covered by ice) => loop over ice categories
+      !-------------------------------------------------------------------------------------------!
+      DO jl = 1, jpl
+
+         ! select ice covered grid points
+         npti = 0 ; nptidx(:) = 0
+         DO jj = 1, jpj
+            DO ji = 1, jpi
+               IF ( a_i(ji,jj,jl) > epsi10 ) THEN     
+                  npti         = npti  + 1
+                  nptidx(npti) = (jj - 1) * jpi + ji
+               ENDIF
+            END DO
+         END DO
+
+         IF( lk_mpp )         CALL mpp_ini_ice( npti , numout )
+
+         IF( npti > 0 ) THEN  ! If there is no ice, do nothing.
+            !                                                                
+                              CALL ice_thd_1d2d( jl, 1 )            ! --- Move to 1D arrays --- !
+            !                                                       ! --- & Change units of e_i, e_s from J/m2 to J/m3 --- !
+            !
+            s_i_new   (1:npti) = 0._wp ; dh_s_tot (1:npti) = 0._wp  ! --- some init --- !  (important to have them here) 
+            dh_i_surf (1:npti) = 0._wp ; dh_i_bott(1:npti) = 0._wp
+            dh_snowice(1:npti) = 0._wp ; dh_i_sub (1:npti) = 0._wp ; dh_s_mlt(1:npti) = 0._wp
+            !
+            IF( ln_icedH ) THEN                                     ! --- growing/melting --- !
+                              CALL ice_thd_zdf                             ! Ice/Snow Temperature profile
+                              CALL ice_thd_dh                              ! Ice/Snow thickness   
+                              CALL ice_thd_pnd                             ! Melt ponds formation
+                              CALL ice_thd_ent( e_i_1d(1:npti,:) )         ! Ice enthalpy remapping
+            ENDIF
+            !
+                              CALL ice_thd_sal( ln_icedS )          ! --- Ice salinity --- !    
+            !
+                              CALL ice_thd_temp                     ! --- temperature update --- !
+            !
+!!gm please create a new logical (l_thd_lam or a better explicit name) set one for all in icestp.F90 module
+!!gm        l_thd_lam = ln_icedH .AND. ( ( nn_virtual_itd == 1 .OR. nn_virtual_itd == 4 ) .AND. jpl == 1 )
+!!gm        by the way, the different options associated with nn_virtual_itd =1 to 4  are quite impossible to identify
+!!gm        more comment to add when ready the namelist, with an explicit print in the ocean.output
+            IF( ln_icedH ) THEN
+               IF ( ( nn_virtual_itd == 1 .OR. nn_virtual_itd == 3 ) .AND. jpl == 1 ) THEN
+                              CALL ice_thd_lam                      ! --- extra lateral melting if virtual_itd --- !
+               END IF
+            END IF
+            !
+            IF( ln_icedA )    CALL ice_thd_da                       ! --- lateral melting --- !
+            !
+                              CALL ice_thd_1d2d( jl, 2 )            ! --- Change units of e_i, e_s from J/m3 to J/m2 --- !
+            !                                                       ! --- & Move to 2D arrays --- !
+            !
+            IF( lk_mpp )      CALL mpp_comm_free( ncomm_ice ) !RB necessary ??
+         ENDIF
+         !
+      END DO
+      ! update ice age (in case a_i changed, i.e. becomes 0 or lateral melting)
+      oa_i(:,:,:) = o_i(:,:,:) * a_i(:,:,:)
+
+      IF( ln_icediachk )   CALL ice_cons_hsm(1, 'icethd', rdiag_v, rdiag_s, rdiag_t, rdiag_fv, rdiag_fs, rdiag_ft)
+      !
+                           CALL ice_var_zapsmall           ! --- remove very small ice concentration (<1e-10) --- !
+      !                                                    !     & make sure at_i=SUM(a_i) & ato_i=1 where at_i=0
+      !                   
+      IF( jpl > 1      )   CALL ice_itd_rem( kt )          ! --- Transport ice between thickness categories --- !
+      !
+      IF( ln_icedO     )   CALL ice_thd_do                 ! --- frazil ice growing in leads --- !
+      !
+      ! controls
+      IF( ln_icectl )   CALL ice_prt    (kt, iiceprt, jiceprt, 1, ' - ice thermodyn. - ') ! prints
+      IF( ln_ctl    )   CALL ice_prt3D  ('icethd')                                        ! prints
+      IF( ln_timing )   CALL timing_stop('icethd')                                        ! timing
+      !
+   END SUBROUTINE ice_thd 
+
+ 
+   SUBROUTINE ice_thd_temp
+      !!-----------------------------------------------------------------------
+      !!                   ***  ROUTINE ice_thd_temp *** 
+      !!                 
+      !! ** Purpose :   Computes sea ice temperature (Kelvin) from enthalpy
+      !!
+      !! ** Method  :   Formula (Bitz and Lipscomb, 1999)
+      !!-------------------------------------------------------------------
+      INTEGER  ::   ji, jk   ! dummy loop indices
+      REAL(wp) ::   ztmelts, zbbb, zccc  ! local scalar 
+      !!-------------------------------------------------------------------
+      ! Recover ice temperature
+      DO jk = 1, nlay_i
+         DO ji = 1, npti
+            ztmelts       = -tmut * sz_i_1d(ji,jk)
+            ! Conversion q(S,T) -> T (second order equation)
+            zbbb          = ( rcp - cpic ) * ztmelts + e_i_1d(ji,jk) * r1_rhoic - lfus
+            zccc          = SQRT( MAX( zbbb * zbbb - 4._wp * cpic * lfus * ztmelts, 0._wp ) )
+            t_i_1d(ji,jk) = rt0 - ( zbbb + zccc ) * 0.5_wp * r1_cpic
+            
+            ! mask temperature
+            rswitch       = 1._wp - MAX( 0._wp , SIGN( 1._wp , - h_i_1d(ji) ) ) 
+            t_i_1d(ji,jk) = rswitch * t_i_1d(ji,jk) + ( 1._wp - rswitch ) * rt0
+         END DO 
+      END DO 
+      !
+   END SUBROUTINE ice_thd_temp
+
+
+   SUBROUTINE ice_thd_lam
+      !!-----------------------------------------------------------------------
+      !!                   ***  ROUTINE ice_thd_lam *** 
+      !!                 
+      !! ** Purpose :   Lateral melting in case virtual_itd
+      !!                          ( dA = A/2h dh )
+      !!-----------------------------------------------------------------------
+      INTEGER  ::   ji                 ! dummy loop indices
+      REAL(wp) ::   zhi_bef            ! ice thickness before thermo
+      REAL(wp) ::   zdh_mel, zda_mel   ! net melting
+      REAL(wp) ::   zvi, zvs           ! ice/snow volumes 
+      !!-----------------------------------------------------------------------
+      !
+      DO ji = 1, npti
+         zdh_mel = MIN( 0._wp, dh_i_surf(ji) + dh_i_bott(ji) + dh_snowice(ji) + dh_i_sub(ji) )
+         IF( zdh_mel < 0._wp .AND. a_i_1d(ji) > 0._wp )  THEN
+            zvi          = a_i_1d(ji) * h_i_1d(ji)
+            zvs          = a_i_1d(ji) * h_s_1d(ji)
+            ! lateral melting = concentration change
+            zhi_bef     = h_i_1d(ji) - zdh_mel
+            rswitch     = MAX( 0._wp , SIGN( 1._wp , zhi_bef - epsi20 ) )
+            zda_mel     = rswitch * a_i_1d(ji) * zdh_mel / ( 2._wp * MAX( zhi_bef, epsi20 ) )
+            a_i_1d(ji)  = MAX( epsi20, a_i_1d(ji) + zda_mel ) 
+            ! adjust thickness
+            h_i_1d(ji) = zvi / a_i_1d(ji)            
+            h_s_1d(ji) = zvs / a_i_1d(ji)            
+            ! retrieve total concentration
+            at_i_1d(ji) = a_i_1d(ji)
+         END IF
+      END DO
+      !
+   END SUBROUTINE ice_thd_lam
+
+
+   SUBROUTINE ice_thd_1d2d( kl, kn )
+      !!-----------------------------------------------------------------------
+      !!                   ***  ROUTINE ice_thd_1d2d *** 
+      !!                 
+      !! ** Purpose :   move arrays from 1d to 2d and the reverse
+      !!-----------------------------------------------------------------------
+      INTEGER, INTENT(in) ::   kl   ! index of the ice category 
+      INTEGER, INTENT(in) ::   kn   ! 1= from 2D to 1D   ;   2= from 1D to 2D
+      !
+      INTEGER ::   jk   ! dummy loop indices
+      !!-----------------------------------------------------------------------
+      !
+      SELECT CASE( kn )
+      !                    !---------------------!
+      CASE( 1 )            !==  from 2D to 1D  ==!
+         !                 !---------------------!
+         CALL tab_2d_1d( npti, nptidx(1:npti), at_i_1d(1:npti), at_i             )
+         CALL tab_2d_1d( npti, nptidx(1:npti), a_i_1d (1:npti), a_i (:,:,kl)     )
+         CALL tab_2d_1d( npti, nptidx(1:npti), h_i_1d (1:npti), h_i (:,:,kl)     )
+         CALL tab_2d_1d( npti, nptidx(1:npti), h_s_1d (1:npti), h_s (:,:,kl)     )
+         CALL tab_2d_1d( npti, nptidx(1:npti), t_su_1d(1:npti), t_su(:,:,kl)     )
+         CALL tab_2d_1d( npti, nptidx(1:npti), s_i_1d (1:npti), s_i (:,:,kl)     )
+         DO jk = 1, nlay_s
+            CALL tab_2d_1d( npti, nptidx(1:npti), t_s_1d(1:npti,jk), t_s(:,:,jk,kl)    )
+            CALL tab_2d_1d( npti, nptidx(1:npti), e_s_1d(1:npti,jk), e_s(:,:,jk,kl)    )
+         END DO
+         DO jk = 1, nlay_i
+            CALL tab_2d_1d( npti, nptidx(1:npti), t_i_1d (1:npti,jk), t_i (:,:,jk,kl)  )
+            CALL tab_2d_1d( npti, nptidx(1:npti), e_i_1d (1:npti,jk), e_i (:,:,jk,kl)  )
+            CALL tab_2d_1d( npti, nptidx(1:npti), sz_i_1d(1:npti,jk), sz_i(:,:,jk,kl)  )
+         END DO
+         CALL tab_2d_1d( npti, nptidx(1:npti), a_ip_1d     (1:npti), a_ip     (:,:,kl) )
+         CALL tab_2d_1d( npti, nptidx(1:npti), h_ip_1d     (1:npti), h_ip     (:,:,kl) )
+         CALL tab_2d_1d( npti, nptidx(1:npti), a_ip_frac_1d(1:npti), a_ip_frac(:,:,kl) )
+         !
+         CALL tab_2d_1d( npti, nptidx(1:npti), qprec_ice_1d(1:npti), qprec_ice        )
+         CALL tab_2d_1d( npti, nptidx(1:npti), qsr_ice_1d  (1:npti), qsr_ice (:,:,kl) )
+         CALL tab_2d_1d( npti, nptidx(1:npti), qns_ice_1d  (1:npti), qns_ice (:,:,kl) )
+         CALL tab_2d_1d( npti, nptidx(1:npti), ftr_ice_1d  (1:npti), ftr_ice (:,:,kl) )
+         CALL tab_2d_1d( npti, nptidx(1:npti), evap_ice_1d (1:npti), evap_ice(:,:,kl) )
+         CALL tab_2d_1d( npti, nptidx(1:npti), dqns_ice_1d (1:npti), dqns_ice(:,:,kl) )
+         CALL tab_2d_1d( npti, nptidx(1:npti), t_bo_1d     (1:npti), t_bo             )
+         CALL tab_2d_1d( npti, nptidx(1:npti), sprecip_1d  (1:npti), sprecip          ) 
+         CALL tab_2d_1d( npti, nptidx(1:npti), fhtur_1d    (1:npti), fhtur            )
+         CALL tab_2d_1d( npti, nptidx(1:npti), fhld_1d     (1:npti), fhld             )
+         
+         CALL tab_2d_1d( npti, nptidx(1:npti), qml_ice_1d   (1:npti), qml_ice      (:,:,kl)  )
+         CALL tab_2d_1d( npti, nptidx(1:npti), qcn_ice_1d   (1:npti), qcn_ice      (:,:,kl) )
+         CALL tab_2d_1d( npti, nptidx(1:npti), qsr_ice_tr_1d(1:npti), qsr_ice_tr   (:,:,kl) )
+         !
+         CALL tab_2d_1d( npti, nptidx(1:npti), wfx_snw_sni_1d(1:npti), wfx_snw_sni   )
+         CALL tab_2d_1d( npti, nptidx(1:npti), wfx_snw_sum_1d(1:npti), wfx_snw_sum   )
+         CALL tab_2d_1d( npti, nptidx(1:npti), wfx_sub_1d    (1:npti), wfx_sub       )
+         CALL tab_2d_1d( npti, nptidx(1:npti), wfx_snw_sub_1d(1:npti), wfx_snw_sub   )
+         CALL tab_2d_1d( npti, nptidx(1:npti), wfx_ice_sub_1d(1:npti), wfx_ice_sub   )
+         CALL tab_2d_1d( npti, nptidx(1:npti), wfx_err_sub_1d(1:npti), wfx_err_sub   )
+         !
+         CALL tab_2d_1d( npti, nptidx(1:npti), wfx_bog_1d (1:npti), wfx_bog          )
+         CALL tab_2d_1d( npti, nptidx(1:npti), wfx_bom_1d (1:npti), wfx_bom          )
+         CALL tab_2d_1d( npti, nptidx(1:npti), wfx_sum_1d (1:npti), wfx_sum          )
+         CALL tab_2d_1d( npti, nptidx(1:npti), wfx_sni_1d (1:npti), wfx_sni          )
+         CALL tab_2d_1d( npti, nptidx(1:npti), wfx_res_1d (1:npti), wfx_res          )
+         CALL tab_2d_1d( npti, nptidx(1:npti), wfx_spr_1d (1:npti), wfx_spr          )
+         CALL tab_2d_1d( npti, nptidx(1:npti), wfx_lam_1d (1:npti), wfx_lam          )
+         CALL tab_2d_1d( npti, nptidx(1:npti), wfx_pnd_1d (1:npti), wfx_pnd          )
+         !
+         CALL tab_2d_1d( npti, nptidx(1:npti), sfx_bog_1d (1:npti), sfx_bog          )
+         CALL tab_2d_1d( npti, nptidx(1:npti), sfx_bom_1d (1:npti), sfx_bom          )
+         CALL tab_2d_1d( npti, nptidx(1:npti), sfx_sum_1d (1:npti), sfx_sum          )
+         CALL tab_2d_1d( npti, nptidx(1:npti), sfx_sni_1d (1:npti), sfx_sni          )
+         CALL tab_2d_1d( npti, nptidx(1:npti), sfx_bri_1d (1:npti), sfx_bri          )
+         CALL tab_2d_1d( npti, nptidx(1:npti), sfx_res_1d (1:npti), sfx_res          )
+         CALL tab_2d_1d( npti, nptidx(1:npti), sfx_sub_1d (1:npti), sfx_sub          )
+         CALL tab_2d_1d( npti, nptidx(1:npti), sfx_lam_1d (1:npti), sfx_lam          )
+         !
+         CALL tab_2d_1d( npti, nptidx(1:npti), hfx_thd_1d (1:npti), hfx_thd          )
+         CALL tab_2d_1d( npti, nptidx(1:npti), hfx_spr_1d (1:npti), hfx_spr          )
+         CALL tab_2d_1d( npti, nptidx(1:npti), hfx_sum_1d (1:npti), hfx_sum          )
+         CALL tab_2d_1d( npti, nptidx(1:npti), hfx_bom_1d (1:npti), hfx_bom          )
+         CALL tab_2d_1d( npti, nptidx(1:npti), hfx_bog_1d (1:npti), hfx_bog          )
+         CALL tab_2d_1d( npti, nptidx(1:npti), hfx_dif_1d (1:npti), hfx_dif          )
+         CALL tab_2d_1d( npti, nptidx(1:npti), hfx_opw_1d (1:npti), hfx_opw          )
+         CALL tab_2d_1d( npti, nptidx(1:npti), hfx_snw_1d (1:npti), hfx_snw          )
+         CALL tab_2d_1d( npti, nptidx(1:npti), hfx_sub_1d (1:npti), hfx_sub          )
+         CALL tab_2d_1d( npti, nptidx(1:npti), hfx_res_1d (1:npti), hfx_res          )
+         CALL tab_2d_1d( npti, nptidx(1:npti), hfx_err_dif_1d(1:npti), hfx_err_dif   )
+         CALL tab_2d_1d( npti, nptidx(1:npti), hfx_err_rem_1d(1:npti), hfx_err_rem   )
+         CALL tab_2d_1d( npti, nptidx(1:npti), hfx_out_1d (1:npti), hfx_out          )
+         !
+         ! SIMIP diagnostics
+         CALL tab_2d_1d( npti, nptidx(1:npti), diag_fc_bo_1d(1:npti), diag_fc_bo   )
+         CALL tab_2d_1d( npti, nptidx(1:npti), diag_fc_su_1d(1:npti), diag_fc_su   )
+         ! ocean surface fields
+         CALL tab_2d_1d( npti, nptidx(1:npti), sst_1d(1:npti), sst_m )
+         CALL tab_2d_1d( npti, nptidx(1:npti), sss_1d(1:npti), sss_m )
+
+         ! --- Change units of e_i, e_s from J/m2 to J/m3 --- !
+         DO jk = 1, nlay_i
+            WHERE( h_i_1d(1:npti)>0._wp ) e_i_1d(1:npti,jk) = e_i_1d(1:npti,jk) / (h_i_1d(1:npti) * a_i_1d(1:npti)) * nlay_i
+         END DO
+         DO jk = 1, nlay_s
+            WHERE( h_s_1d(1:npti)>0._wp ) e_s_1d(1:npti,jk) = e_s_1d(1:npti,jk) / (h_s_1d(1:npti) * a_i_1d(1:npti)) * nlay_s
+         END DO
+         !
+         !                 !---------------------!
+      CASE( 2 )            !==  from 1D to 2D  ==!
+         !                 !---------------------!
+         ! --- Change units of e_i, e_s from J/m3 to J/m2 --- !
+         DO jk = 1, nlay_i
+            e_i_1d(1:npti,jk) = e_i_1d(1:npti,jk) * h_i_1d(1:npti) * a_i_1d(1:npti) * r1_nlay_i
+         END DO
+         DO jk = 1, nlay_s
+            e_s_1d(1:npti,jk) = e_s_1d(1:npti,jk) * h_s_1d(1:npti) * a_i_1d(1:npti) * r1_nlay_s
+         END DO
+         !
+         ! Change thickness to volume (replaces routine ice_var_eqv2glo)
+         v_i_1d (1:npti) = h_i_1d (1:npti) * a_i_1d (1:npti)
+         v_s_1d (1:npti) = h_s_1d (1:npti) * a_i_1d (1:npti)
+         sv_i_1d(1:npti) = s_i_1d (1:npti) * v_i_1d (1:npti)
+         v_ip_1d(1:npti) = h_ip_1d(1:npti) * a_ip_1d(1:npti)
+         
+         CALL tab_1d_2d( npti, nptidx(1:npti), at_i_1d(1:npti), at_i             )
+         CALL tab_1d_2d( npti, nptidx(1:npti), a_i_1d (1:npti), a_i (:,:,kl)     )
+         CALL tab_1d_2d( npti, nptidx(1:npti), h_i_1d (1:npti), h_i (:,:,kl)     )
+         CALL tab_1d_2d( npti, nptidx(1:npti), h_s_1d (1:npti), h_s (:,:,kl)     )
+         CALL tab_1d_2d( npti, nptidx(1:npti), t_su_1d(1:npti), t_su(:,:,kl)     )
+         CALL tab_1d_2d( npti, nptidx(1:npti), s_i_1d (1:npti), s_i (:,:,kl)     )
+         DO jk = 1, nlay_s
+            CALL tab_1d_2d( npti, nptidx(1:npti), t_s_1d(1:npti,jk), t_s(:,:,jk,kl)    )
+            CALL tab_1d_2d( npti, nptidx(1:npti), e_s_1d(1:npti,jk), e_s(:,:,jk,kl)    )
+         END DO
+         DO jk = 1, nlay_i
+            CALL tab_1d_2d( npti, nptidx(1:npti), t_i_1d (1:npti,jk), t_i (:,:,jk,kl)  )
+            CALL tab_1d_2d( npti, nptidx(1:npti), e_i_1d (1:npti,jk), e_i (:,:,jk,kl)  )
+            CALL tab_1d_2d( npti, nptidx(1:npti), sz_i_1d(1:npti,jk), sz_i(:,:,jk,kl)  )
+         END DO
+         CALL tab_1d_2d( npti, nptidx(1:npti), a_ip_1d     (1:npti), a_ip     (:,:,kl) )
+         CALL tab_1d_2d( npti, nptidx(1:npti), h_ip_1d     (1:npti), h_ip     (:,:,kl) )
+         CALL tab_1d_2d( npti, nptidx(1:npti), a_ip_frac_1d(1:npti), a_ip_frac(:,:,kl) )
+         !
+         CALL tab_1d_2d( npti, nptidx(1:npti), wfx_snw_sni_1d(1:npti), wfx_snw_sni )
+         CALL tab_1d_2d( npti, nptidx(1:npti), wfx_snw_sum_1d(1:npti), wfx_snw_sum )
+         CALL tab_1d_2d( npti, nptidx(1:npti), wfx_sub_1d    (1:npti), wfx_sub     )
+         CALL tab_1d_2d( npti, nptidx(1:npti), wfx_snw_sub_1d(1:npti), wfx_snw_sub )
+         CALL tab_1d_2d( npti, nptidx(1:npti), wfx_ice_sub_1d(1:npti), wfx_ice_sub )
+         CALL tab_1d_2d( npti, nptidx(1:npti), wfx_err_sub_1d(1:npti), wfx_err_sub )
+         !
+         CALL tab_1d_2d( npti, nptidx(1:npti), wfx_bog_1d (1:npti), wfx_bog        )
+         CALL tab_1d_2d( npti, nptidx(1:npti), wfx_bom_1d (1:npti), wfx_bom        )
+         CALL tab_1d_2d( npti, nptidx(1:npti), wfx_sum_1d (1:npti), wfx_sum        )
+         CALL tab_1d_2d( npti, nptidx(1:npti), wfx_sni_1d (1:npti), wfx_sni        )
+         CALL tab_1d_2d( npti, nptidx(1:npti), wfx_res_1d (1:npti), wfx_res        )
+         CALL tab_1d_2d( npti, nptidx(1:npti), wfx_spr_1d (1:npti), wfx_spr        )
+         CALL tab_1d_2d( npti, nptidx(1:npti), wfx_lam_1d (1:npti), wfx_lam        )
+         CALL tab_1d_2d( npti, nptidx(1:npti), wfx_pnd_1d (1:npti), wfx_pnd        )
+         !
+         CALL tab_1d_2d( npti, nptidx(1:npti), sfx_bog_1d (1:npti), sfx_bog        )
+         CALL tab_1d_2d( npti, nptidx(1:npti), sfx_bom_1d (1:npti), sfx_bom        )
+         CALL tab_1d_2d( npti, nptidx(1:npti), sfx_sum_1d (1:npti), sfx_sum        )
+         CALL tab_1d_2d( npti, nptidx(1:npti), sfx_sni_1d (1:npti), sfx_sni        )
+         CALL tab_1d_2d( npti, nptidx(1:npti), sfx_bri_1d (1:npti), sfx_bri        )
+         CALL tab_1d_2d( npti, nptidx(1:npti), sfx_res_1d (1:npti), sfx_res        )
+         CALL tab_1d_2d( npti, nptidx(1:npti), sfx_sub_1d (1:npti), sfx_sub        )
+         CALL tab_1d_2d( npti, nptidx(1:npti), sfx_lam_1d (1:npti), sfx_lam        )
+         !
+         CALL tab_1d_2d( npti, nptidx(1:npti), hfx_thd_1d (1:npti), hfx_thd        )
+         CALL tab_1d_2d( npti, nptidx(1:npti), hfx_spr_1d (1:npti), hfx_spr        )
+         CALL tab_1d_2d( npti, nptidx(1:npti), hfx_sum_1d (1:npti), hfx_sum        )
+         CALL tab_1d_2d( npti, nptidx(1:npti), hfx_bom_1d (1:npti), hfx_bom        )
+         CALL tab_1d_2d( npti, nptidx(1:npti), hfx_bog_1d (1:npti), hfx_bog        )
+         CALL tab_1d_2d( npti, nptidx(1:npti), hfx_dif_1d (1:npti), hfx_dif        )
+         CALL tab_1d_2d( npti, nptidx(1:npti), hfx_opw_1d (1:npti), hfx_opw        )
+         CALL tab_1d_2d( npti, nptidx(1:npti), hfx_snw_1d (1:npti), hfx_snw        )
+         CALL tab_1d_2d( npti, nptidx(1:npti), hfx_sub_1d (1:npti), hfx_sub        )
+         CALL tab_1d_2d( npti, nptidx(1:npti), hfx_res_1d (1:npti), hfx_res        )
+         CALL tab_1d_2d( npti, nptidx(1:npti), hfx_err_dif_1d(1:npti), hfx_err_dif )
+         CALL tab_1d_2d( npti, nptidx(1:npti), hfx_err_rem_1d(1:npti), hfx_err_rem )
+         CALL tab_1d_2d( npti, nptidx(1:npti), hfx_out_1d (1:npti), hfx_out        )
+         !
+         CALL tab_1d_2d( npti, nptidx(1:npti), qns_ice_1d(1:npti), qns_ice(:,:,kl) )
+         CALL tab_1d_2d( npti, nptidx(1:npti), ftr_ice_1d(1:npti), ftr_ice(:,:,kl) )
+         ! effective conductivity and 1st layer temperature (for Jules coupling)
+         CALL tab_1d_2d( npti, nptidx(1:npti), cnd_ice_1d(1:npti), cnd_ice(:,:,kl) )
+         CALL tab_1d_2d( npti, nptidx(1:npti), t1_ice_1d (1:npti), t1_ice (:,:,kl) )
+         ! SIMIP diagnostics         
+         CALL tab_1d_2d( npti, nptidx(1:npti), t_si_1d      (1:npti), t_si(:,:,kl) )
+         CALL tab_1d_2d( npti, nptidx(1:npti), diag_fc_bo_1d(1:npti), diag_fc_bo   )
+         CALL tab_1d_2d( npti, nptidx(1:npti), diag_fc_su_1d(1:npti), diag_fc_su   )
+         ! extensive variables
+         CALL tab_1d_2d( npti, nptidx(1:npti), v_i_1d (1:npti), v_i (:,:,kl) )
+         CALL tab_1d_2d( npti, nptidx(1:npti), v_s_1d (1:npti), v_s (:,:,kl) )
+         CALL tab_1d_2d( npti, nptidx(1:npti), sv_i_1d(1:npti), sv_i(:,:,kl) )
+         CALL tab_1d_2d( npti, nptidx(1:npti), v_ip_1d(1:npti), v_ip(:,:,kl) )
+         !
+      END SELECT
+      !
+   END SUBROUTINE ice_thd_1d2d
+
+
+   SUBROUTINE ice_thd_init
+      !!-------------------------------------------------------------------
+      !!                   ***  ROUTINE ice_thd_init *** 
+      !!                 
+      !! ** Purpose :   Physical constants and parameters associated with
+      !!                ice thermodynamics
+      !!
+      !! ** Method  :   Read the namthd namelist and check the parameters
+      !!                called at the first timestep (nit000)
+      !!
+      !! ** input   :   Namelist namthd
+      !!-------------------------------------------------------------------
+      INTEGER  ::   ios   ! Local integer output status for namelist read
+      !!
+      NAMELIST/namthd/ ln_icedH, ln_icedA, ln_icedO, ln_icedS
+      !!-------------------------------------------------------------------
+      !
+      REWIND( numnam_ice_ref )              ! Namelist namthd in reference namelist : Ice thermodynamics
+      READ  ( numnam_ice_ref, namthd, IOSTAT = ios, ERR = 901)
+901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namthd in reference namelist', lwp )
+      REWIND( numnam_ice_cfg )              ! Namelist namthd in configuration namelist : Ice thermodynamics
+      READ  ( numnam_ice_cfg, namthd, IOSTAT = ios, ERR = 902 )
+902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namthd in configuration namelist', lwp )
+      IF(lwm) WRITE( numoni, namthd )
+      !
+      IF(lwp) THEN                          ! control print
+         WRITE(numout,*)
+         WRITE(numout,*) 'ice_thd_init: Ice Thermodynamics'
+         WRITE(numout,*) '~~~~~~~~~~~~'
+         WRITE(numout,*) '   Namelist namthd:'
+         WRITE(numout,*) '      activate ice thick change from top/bot (T) or not (F)   ln_icedH  = ', ln_icedH
+         WRITE(numout,*) '      activate lateral melting (T) or not (F)                 ln_icedA  = ', ln_icedA
+         WRITE(numout,*) '      activate ice growth in open-water (T) or not (F)        ln_icedO  = ', ln_icedO
+         WRITE(numout,*) '      activate gravity drainage and flushing (T) or not (F)   ln_icedS  = ', ln_icedS
+     ENDIF
+      !
+                       CALL ice_thd_zdf_init   ! set ice heat diffusion parameters
+      IF( ln_icedA )   CALL ice_thd_da_init    ! set ice lateral melting parameters
+      IF( ln_icedO )   CALL ice_thd_do_init    ! set ice growth in open water parameters
+                       CALL ice_thd_sal_init   ! set ice salinity parameters
+                       CALL ice_thd_pnd_init   ! set melt ponds parameters
+      !
+   END SUBROUTINE ice_thd_init
+
+#else
+   !!----------------------------------------------------------------------
+   !!   Default option         Dummy module          NO  SI3 sea-ice model
+   !!----------------------------------------------------------------------
+#endif
+
+   !!======================================================================
+END MODULE icethd
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/ICE_SRC/icethd_da.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/ICE_SRC/icethd_da.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/ICE_SRC/icethd_da.F90	(revision 9570)
@@ -0,0 +1,204 @@
+MODULE icethd_da
+   !!======================================================================
+   !!                       ***  MODULE icethd_da ***
+   !!   sea-ice : lateral melting
+   !!======================================================================
+   !! History :  4.0  ! 2016-03 (C. Rousset)  original code
+   !!---------------------------------------------------------------------
+#if defined key_si3
+   !!----------------------------------------------------------------------
+   !!   'key_si3'                                       SI3 sea-ice model
+   !!----------------------------------------------------------------------
+   !!   ice_thd_da      : sea ice lateral melting
+   !!   ice_thd_da_init : sea ice lateral melting initialization
+   !!----------------------------------------------------------------------
+   USE par_oce        ! ocean parameters
+   USE phycst         ! physical constants (ocean directory)
+   USE ice            ! sea-ice: variables
+   USE ice1D          ! sea-ice: thermodynamic 1D variables
+   !
+   USE in_out_manager ! I/O manager
+   USE lib_mpp        ! MPP library
+   USE lib_fortran    ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined)  
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   ice_thd_da        ! called by icethd.F90
+   PUBLIC   ice_thd_da_init   ! called by icestp.F90
+
+   !                      !!** namelist (namthd_da) **
+   REAL(wp) ::   rn_beta   ! coef. beta for lateral melting param.
+   REAL(wp) ::   rn_dmin   ! minimum floe diameter for lateral melting param.
+
+   !!----------------------------------------------------------------------
+   !! NEMO/ICE 4.0 , NEMO Consortium (2017)
+   !! $Id: icethd_da.F90 5123 2015-03-04 16:06:03Z clem $
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE ice_thd_da
+      !!-------------------------------------------------------------------
+      !!                ***  ROUTINE ice_thd_da  ***    
+      !!   
+      !! ** Purpose :   computes sea ice lateral melting
+      !!
+      !! ** Method  :   dA/dt = - P * W   [s-1]
+      !!                   W = melting velocity [m.s-1]
+      !!                   P = perimeter of ice-ocean lateral interface normalized by grid cell area [m.m-2]
+      !!
+      !!                   W = m1 * (Tw -Tf)**m2                    --- originally from Josberger 1979 ---
+      !!                      (Tw - Tf) = elevation of water temp above freezing
+      !!                      m1 and m2 = (1.6e-6 , 1.36) best fit from field experiment near the coast of Prince Patrick Island
+      !!                                                                                           (Perovich 1983) => static ice
+      !!                      m1 and m2 = (3.0e-6 , 1.36) best fit from MIZEX 84 experiment
+      !!                                                                                (Maykut and Perovich 1987) => moving ice
+      !!
+      !!                   P = N * pi * D                           --- from Rothrock and Thorndike 1984 ---
+      !!                      D = mean floe caliper diameter
+      !!                      N = number of floes = ice area / floe area(average) = A / (Cs * D**2)
+      !!                         A = ice concentration
+      !!                         Cs = deviation from a square (square:Cs=1 ; circle:Cs=pi/4 ; floe:Cs=0.66)
+      !!
+      !!                   D = Dmin * ( Astar / (Astar-A) )**beta   --- from Lupkes et al., 2012 (eq. 26-27) ---
+      !!                                                             
+      !!                      Astar = 1 / ( 1 - (Dmin/Dmax)**(1/beta) )
+      !!                      Dmin = minimum floe diameter (recommended to be 8m +- 20%)
+      !!                      Dmax = maximum floe diameter (recommended to be 300m,
+      !!                                                    but it does not impact melting much except for Dmax<100m)
+      !!                      beta = 1.0 +-20% (recommended value)
+      !!                           = 0.3 best fit for western Fram Strait and Antarctica
+      !!                           = 1.4 best fit for eastern Fram Strait
+      !!
+      !! ** Tunable parameters  :   We propose to tune the lateral melting via 2 parameters
+      !!                               Dmin [6-10m]   => 6  vs 8m = +40% melting at the peak (A~0.5)
+      !!                                                 10 vs 8m = -20% melting
+      !!                               beta [0.8-1.2] => decrease = more melt and melt peaks toward higher concentration
+      !!                                                                  (A~0.5 for beta=1 ; A~0.8 for beta=0.2)
+      !!                                                 0.3 = best fit for western Fram Strait and Antarctica
+      !!                                                 1.4 = best fit for eastern Fram Strait
+      !!
+      !! ** Note   :   Former and more simple formulations for floe diameters can be found in Mai (1995), 
+      !!               Birnbaum and Lupkes (2002), Lupkes and Birnbaum (2005). They are reviewed in Lupkes et al 2012
+      !!               A simpler implementation for CICE can be found in Bitz et al (2001) and Tsamados et al (2015)
+      !!
+      !! ** References
+      !!    Bitz, C. M., Holland, M. M., Weaver, A. J., & Eby, M. (2001).
+      !!              Simulating the ice‐thickness distribution in a coupled climate model.
+      !!              Journal of Geophysical Research: Oceans, 106(C2), 2441-2463.
+      !!    Josberger, E. G. (1979).
+      !!              Laminar and turbulent boundary layers adjacent to melting vertical ice walls in salt water
+      !!              (No. SCIENTIFIC-16). WASHINGTON UNIV SEATTLE DEPT OF ATMOSPHERIC SCIENCES.
+      !!    Lüpkes, C., Gryanik, V. M., Hartmann, J., & Andreas, E. L. (2012).
+      !!              A parametrization, based on sea ice morphology, of the neutral atmospheric drag coefficients
+      !!              for weather prediction and climate models.
+      !!              Journal of Geophysical Research: Atmospheres, 117(D13).
+      !!    Maykut, G. A., & Perovich, D. K. (1987).
+      !!              The role of shortwave radiation in the summer decay of a sea ice cover.
+      !!              Journal of Geophysical Research: Oceans, 92(C7), 7032-7044.
+      !!    Perovich, D. K. (1983).
+      !!              On the summer decay of a sea ice cover. (Doctoral dissertation, University of Washington).
+      !!    Rothrock, D. A., & Thorndike, A. S. (1984).
+      !!              Measuring the sea ice floe size distribution.
+      !!              Journal of Geophysical Research: Oceans, 89(C4), 6477-6486.
+      !!    Tsamados, M., Feltham, D., Petty, A., Schroeder, D., & Flocco, D. (2015).
+      !!              Processes controlling surface, bottom and lateral melt of Arctic sea ice in a state of the art sea ice model.
+      !!              Phil. Trans. R. Soc. A, 373(2052), 20140167.
+      !!---------------------------------------------------------------------
+      INTEGER  ::   ji     ! dummy loop indices
+      REAL(wp)            ::   zastar, zdfloe, zperi, zwlat, zda
+      REAL(wp), PARAMETER ::   zdmax = 300._wp
+      REAL(wp), PARAMETER ::   zcs   = 0.66_wp
+      REAL(wp), PARAMETER ::   zm1   = 3.e-6_wp
+      REAL(wp), PARAMETER ::   zm2   = 1.36_wp
+      !
+      REAL(wp), DIMENSION(jpij) ::   zda_tot
+      !!---------------------------------------------------------------------
+      !
+      zastar = 1._wp / ( 1._wp - (rn_dmin / zdmax)**(1._wp/rn_beta) )
+      !
+      DO ji = 1, npti   
+         ! --- Calculate reduction of total sea ice concentration --- !
+         zdfloe = rn_dmin * ( zastar / ( zastar - at_i_1d(ji) ) )**rn_beta         ! Mean floe caliper diameter [m]
+         !
+         zperi  = at_i_1d(ji) * rpi / ( zcs * zdfloe )                             ! Mean perimeter of the floe [m.m-2]
+         !                                                                         !    = N*pi*D = (A/cs*D^2)*pi*D
+         zwlat  = zm1 * ( MAX( 0._wp, sst_1d(ji) - ( t_bo_1d(ji) - rt0 ) ) )**zm2  ! Melt speed rate [m/s]
+         !
+         zda_tot(ji) = MIN( zwlat * zperi * rdt_ice, at_i_1d(ji) )                 ! sea ice concentration decrease (>0)
+      
+         ! --- Distribute reduction among ice categories and calculate associated ice-ocean fluxes --- !
+         IF( a_i_1d(ji) > 0._wp ) THEN
+            ! decrease of concentration for the category jl
+            !    each category contributes to melting in proportion to its concentration
+            zda = MIN( a_i_1d(ji), zda_tot(ji) * a_i_1d(ji) / at_i_1d(ji) )
+            
+            ! Contribution to salt flux
+            sfx_lam_1d(ji) = sfx_lam_1d(ji) + rhoic *  h_i_1d(ji) * zda * s_i_1d(ji) * r1_rdtice
+            
+            ! Contribution to heat flux into the ocean [W.m-2], (<0)  
+            hfx_thd_1d(ji) = hfx_thd_1d(ji) - zda * r1_rdtice * ( h_i_1d(ji) * r1_nlay_i * SUM( e_i_1d(ji,1:nlay_i) )  &
+                                                                + h_s_1d(ji) * r1_nlay_s * SUM( e_s_1d(ji,1:nlay_s) ) ) 
+            
+            ! Contribution to mass flux
+            wfx_lam_1d(ji) =  wfx_lam_1d(ji) + zda * r1_rdtice * ( rhoic * h_i_1d(ji) + rhosn * h_s_1d(ji) )
+            
+            ! new concentration
+            a_i_1d(ji) = a_i_1d(ji) - zda
+
+            ! ensure that h_i = 0 where a_i = 0
+            IF( a_i_1d(ji) == 0._wp ) THEN
+               h_i_1d(ji) = 0._wp
+               h_s_1d(ji) = 0._wp
+            ENDIF
+         ENDIF
+      END DO
+      !
+   END SUBROUTINE ice_thd_da
+
+
+   SUBROUTINE ice_thd_da_init
+      !!-----------------------------------------------------------------------
+      !!                   ***  ROUTINE ice_thd_da_init *** 
+      !!                 
+      !! ** Purpose :   Physical constants and parameters associated with
+      !!                ice thermodynamics
+      !!
+      !! ** Method  :   Read the namthd_da namelist and check the parameters
+      !!                called at the first timestep (nit000)
+      !!
+      !! ** input   :   Namelist namthd_da
+      !!-------------------------------------------------------------------
+      INTEGER  ::   ios   ! Local integer
+      !!
+      NAMELIST/namthd_da/ rn_beta, rn_dmin
+      !!-------------------------------------------------------------------
+      !
+      REWIND( numnam_ice_ref )              ! Namelist namthd_da in reference namelist : Ice thermodynamics
+      READ  ( numnam_ice_ref, namthd_da, IOSTAT = ios, ERR = 901)
+901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namthd_da in reference namelist', lwp )
+      REWIND( numnam_ice_cfg )              ! Namelist namthd_da in configuration namelist : Ice thermodynamics
+      READ  ( numnam_ice_cfg, namthd_da, IOSTAT = ios, ERR = 902 )
+902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namthd_da in configuration namelist', lwp )
+      IF(lwm) WRITE( numoni, namthd_da )
+      !
+      IF(lwp) THEN                          ! control print
+         WRITE(numout,*)
+         WRITE(numout,*) 'ice_thd_da_init: Ice lateral melting'
+         WRITE(numout,*) '~~~~~~~~~~~~~~~'
+         WRITE(numout,*) '   Namelist namthd_da:'
+         WRITE(numout,*) '      Coef. beta for lateral melting param.               rn_beta = ', rn_beta
+         WRITE(numout,*) '      Minimum floe diameter for lateral melting param.    rn_dmin = ', rn_dmin
+      ENDIF
+      !
+   END SUBROUTINE ice_thd_da_init
+  
+#else
+   !!----------------------------------------------------------------------
+   !!   Default option         Dummy Module           NO SI3 sea-ice model
+   !!----------------------------------------------------------------------
+#endif
+
+   !!======================================================================
+END MODULE icethd_da
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/ICE_SRC/icethd_dh.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/ICE_SRC/icethd_dh.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/ICE_SRC/icethd_dh.F90	(revision 9570)
@@ -0,0 +1,677 @@
+MODULE icethd_dh
+   !!======================================================================
+   !!                       ***  MODULE icethd_dh ***
+   !!   seaice : thermodynamic growth and melt 
+   !!======================================================================
+   !! History :  LIM  ! 2003-05 (M. Vancoppenolle) Original code in 1D
+   !!                 ! 2005-06 (M. Vancoppenolle) 3D version 
+   !!            3.2  ! 2009-07 (M. Vancoppenolle, Y. Aksenov, G. Madec) bug correction in wfx_snw & wfx_ice
+   !!            3.4  ! 2011-02 (G. Madec) dynamical allocation
+   !!            3.5  ! 2012-10 (G. Madec & co) salt flux + bug fixes 
+   !!----------------------------------------------------------------------
+#if defined key_si3
+   !!----------------------------------------------------------------------
+   !!   'key_si3'                                       SI3 sea-ice model
+   !!----------------------------------------------------------------------
+   !!   ice_thd_dh        : vertical sea-ice growth and melt
+   !!   ice_thd_snwblow   : distribute snow fall between ice and ocean
+  !!----------------------------------------------------------------------
+   USE dom_oce        ! ocean space and time domain
+   USE phycst         ! physical constants
+   USE ice            ! sea-ice: variables
+   USE ice1D          ! sea-ice: thermodynamics variables
+   USE icethd_sal     ! sea-ice: salinity profiles
+   !
+   USE in_out_manager ! I/O manager
+   USE lib_mpp        ! MPP library
+   USE lib_fortran    ! fortran utilities (glob_sum + no signed zero)
+   
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   ice_thd_dh        ! called by ice_thd
+   PUBLIC   ice_thd_snwblow   ! called in sbcblk/sbccpl and here
+
+   INTERFACE ice_thd_snwblow
+      MODULE PROCEDURE ice_thd_snwblow_1d, ice_thd_snwblow_2d
+   END INTERFACE
+
+   !!----------------------------------------------------------------------
+   !! NEMO/ICE 4.0 , NEMO Consortium (2017)
+   !! $Id: icethd_dh.F90 8420 2017-08-08 12:18:46Z clem $
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE ice_thd_dh
+      !!------------------------------------------------------------------
+      !!                ***  ROUTINE ice_thd_dh  ***
+      !!
+      !! ** Purpose :   compute ice and snow thickness changes due to growth/melting
+      !!
+      !! ** Method  :   Ice/Snow surface melting arises from imbalance in surface fluxes
+      !!                Bottom accretion/ablation arises from flux budget
+      !!                Snow thickness can increase by precipitation and decrease by sublimation
+      !!                If snow load excesses Archmiede limit, snow-ice is formed by
+      !!                the flooding of sea-water in the snow
+      !!
+      !!                - Compute available flux of heat for surface ablation
+      !!                - Compute snow and sea ice enthalpies
+      !!                - Surface ablation and sublimation
+      !!                - Bottom accretion/ablation
+      !!                - Snow ice formation
+      !!
+      !! References : Bitz and Lipscomb, 1999, J. Geophys. Res.
+      !!              Fichefet T. and M. Maqueda 1997, J. Geophys. Res., 102(C6), 12609-12646   
+      !!              Vancoppenolle, Fichefet and Bitz, 2005, Geophys. Res. Let. 
+      !!              Vancoppenolle et al.,2009, Ocean Modelling
+      !!------------------------------------------------------------------
+      INTEGER  ::   ji, jk       ! dummy loop indices
+      INTEGER  ::   iter         ! local integer
+
+      REAL(wp) ::   ztmelts      ! local scalar
+      REAL(wp) ::   zdum       
+      REAL(wp) ::   zfracs       ! fractionation coefficient for bottom salt entrapment
+      REAL(wp) ::   zswi1        ! switch for computation of bottom salinity
+      REAL(wp) ::   zswi12       ! switch for computation of bottom salinity
+      REAL(wp) ::   zswi2        ! switch for computation of bottom salinity
+      REAL(wp) ::   zgrr         ! bottom growth rate
+      REAL(wp) ::   zt_i_new     ! bottom formation temperature
+      REAL(wp) ::   z1_rho       ! 1/(rhosn+rau0-rhoic)
+
+      REAL(wp) ::   zQm          ! enthalpy exchanged with the ocean (J/m2), >0 towards the ocean
+      REAL(wp) ::   zEi          ! specific enthalpy of sea ice (J/kg)
+      REAL(wp) ::   zEw          ! specific enthalpy of exchanged water (J/kg)
+      REAL(wp) ::   zdE          ! specific enthalpy difference (J/kg)
+      REAL(wp) ::   zfmdt        ! exchange mass flux x time step (J/m2), >0 towards the ocean
+
+      REAL(wp), DIMENSION(jpij) ::   zqprec      ! energy of fallen snow                       (J.m-3)
+      REAL(wp), DIMENSION(jpij) ::   zq_su       ! heat for surface ablation                   (J.m-2)
+      REAL(wp), DIMENSION(jpij) ::   zq_bo       ! heat for bottom ablation                    (J.m-2)
+      REAL(wp), DIMENSION(jpij) ::   zq_rema     ! remaining heat at the end of the routine    (J.m-2)
+      REAL(wp), DIMENSION(jpij) ::   zf_tt       ! Heat budget to determine melting or freezing(W.m-2)
+      REAL(wp), DIMENSION(jpij) ::   zevap_rema  ! remaining mass flux from sublimation        (kg.m-2)
+
+      REAL(wp), DIMENSION(jpij) ::   zdh_s_mel   ! snow melt 
+      REAL(wp), DIMENSION(jpij) ::   zdh_s_pre   ! snow precipitation 
+      REAL(wp), DIMENSION(jpij) ::   zdh_s_sub   ! snow sublimation
+
+      REAL(wp), DIMENSION(jpij,nlay_s) ::   zh_s      ! snw layer thickness
+      REAL(wp), DIMENSION(jpij,nlay_i) ::   zh_i      ! ice layer thickness
+      REAL(wp), DIMENSION(jpij,nlay_i) ::   zdeltah
+      INTEGER , DIMENSION(jpij,nlay_i) ::   icount    ! number of layers vanished by melting 
+
+      REAL(wp), DIMENSION(jpij) ::   zsnw        ! distribution of snow after wind blowing
+
+      REAL(wp) ::   zswitch_sal
+
+      INTEGER  ::   num_iter_max      ! Heat conservation 
+      !!------------------------------------------------------------------
+
+      ! Discriminate between time varying salinity and constant
+      SELECT CASE( nn_icesal )                  ! varying salinity or not
+         CASE( 1 , 3 )   ;   zswitch_sal = 0._wp   ! prescribed salinity profile
+         CASE( 2 )       ;   zswitch_sal = 1._wp   ! varying salinity profile
+      END SELECT
+
+      ! initialize layer thicknesses and enthalpies
+      h_i_old (1:npti,0:nlay_i+1) = 0._wp
+      eh_i_old(1:npti,0:nlay_i+1) = 0._wp
+      DO jk = 1, nlay_i
+         DO ji = 1, npti
+            h_i_old (ji,jk) = h_i_1d(ji) * r1_nlay_i
+            eh_i_old(ji,jk) = e_i_1d(ji,jk) * h_i_old(ji,jk)
+         END DO
+      END DO
+      !
+      ! ---------------------------------------------- !
+      ! Available heat for surface and bottom ablation !
+      ! ---------------------------------------------- !
+      !
+      SELECT CASE( nice_jules )
+      !
+      CASE( np_jules_ACTIVE )
+         !
+         DO ji = 1, npti
+            zq_su(ji)      = MAX( 0._wp, qml_ice_1d(ji) * rdt_ice )
+         END DO
+         !
+      CASE( np_jules_EMULE )
+         !
+         DO ji = 1, npti
+            zdum           = qns_ice_1d(ji) + qsr_ice_1d(ji) - qsr_ice_tr_1d(ji) - fc_su(ji)
+            qml_ice_1d(ji) = zdum * MAX( 0._wp , SIGN( 1._wp, t_su_1d(ji) - rt0 ) )
+            zq_su(ji)      = MAX( 0._wp, qml_ice_1d(ji) * rdt_ice )
+         END DO
+         !
+      CASE( np_jules_OFF ) 
+         !
+         DO ji = 1, npti
+            zdum           = qns_ice_1d(ji) + qsr_ice_1d(ji) - qsr_ice_tr_1d(ji) - fc_su(ji) 
+            zdum           = zdum * MAX( 0._wp , SIGN( 1._wp, t_su_1d(ji) - rt0 ) )
+            zq_su(ji)      = MAX( 0._wp, zdum * rdt_ice )
+         END DO
+         !
+      END SELECT
+      !
+      DO ji = 1, npti
+         zf_tt(ji)         = fc_bo_i(ji) + fhtur_1d(ji) + fhld_1d(ji) 
+         zq_bo(ji)         = MAX( 0._wp, zf_tt(ji) * rdt_ice )
+      END DO
+
+      ! Ice and snow layer thicknesses
+      !-------------------------------
+      DO jk = 1, nlay_i
+         DO ji = 1, npti
+            zh_i(ji,jk) = h_i_1d(ji) * r1_nlay_i
+         END DO
+      END DO
+
+      DO jk = 1, nlay_s
+         DO ji = 1, npti
+            zh_s(ji,jk) = h_s_1d(ji) * r1_nlay_s
+         END DO
+      END DO
+
+      !                       ! ============ !
+      !                       !     Snow     !
+      !                       ! ============ !
+      !
+      ! Internal melting
+      ! ----------------
+      ! IF snow temperature is above freezing point, THEN snow melts (should not happen but sometimes it does)
+      DO jk = 1, nlay_s
+         DO ji = 1, npti
+            IF( t_s_1d(ji,jk) > rt0 ) THEN
+               hfx_res_1d    (ji) = hfx_res_1d    (ji) + e_s_1d(ji,jk) * zh_s(ji,jk) * a_i_1d(ji) * r1_rdtice   ! heat flux to the ocean [W.m-2], < 0
+               wfx_snw_sum_1d(ji) = wfx_snw_sum_1d(ji) + rhosn         * zh_s(ji,jk) * a_i_1d(ji) * r1_rdtice   ! mass flux
+               ! updates
+               dh_s_mlt(ji)    = dh_s_mlt(ji) - zh_s(ji,jk)
+               h_s_1d  (ji)    = h_s_1d(ji) - zh_s(ji,jk)
+               zh_s    (ji,jk) = 0._wp
+               e_s_1d  (ji,jk) = 0._wp
+               t_s_1d  (ji,jk) = rt0
+            END IF
+         END DO
+      END DO         
+
+      ! Snow precipitation
+      !-------------------
+      CALL ice_thd_snwblow( 1. - at_i_1d(1:npti), zsnw(1:npti) )   ! snow distribution over ice after wind blowing
+
+      zdeltah(1:npti,:) = 0._wp
+      DO ji = 1, npti
+         IF( sprecip_1d(ji) > 0._wp ) THEN
+            !
+            ! --- precipitation ---
+            zdh_s_pre (ji) = zsnw(ji) * sprecip_1d(ji) * rdt_ice * r1_rhosn / at_i_1d(ji)   ! thickness change
+            zqprec    (ji) = - qprec_ice_1d(ji)                                             ! enthalpy of the precip (>0, J.m-3)
+            !
+            hfx_spr_1d(ji) = hfx_spr_1d(ji) + zdh_s_pre(ji) * a_i_1d(ji) * zqprec(ji)    * r1_rdtice   ! heat flux from snow precip (>0, W.m-2)
+            wfx_spr_1d(ji) = wfx_spr_1d(ji) - rhosn         * a_i_1d(ji) * zdh_s_pre(ji) * r1_rdtice   ! mass flux, <0
+            
+            ! --- melt of falling snow ---
+            rswitch              = MAX( 0._wp , SIGN( 1._wp , zqprec(ji) - epsi20 ) )
+            zdeltah       (ji,1) = - rswitch * zq_su(ji) / MAX( zqprec(ji) , epsi20 )   ! thickness change
+            zdeltah       (ji,1) = MAX( - zdh_s_pre(ji), zdeltah(ji,1) )                ! bound melting 
+            hfx_snw_1d    (ji)   = hfx_snw_1d    (ji) - zdeltah(ji,1) * a_i_1d(ji) * zqprec(ji)    * r1_rdtice   ! heat used to melt snow (W.m-2, >0)
+            wfx_snw_sum_1d(ji)   = wfx_snw_sum_1d(ji) - rhosn         * a_i_1d(ji) * zdeltah(ji,1) * r1_rdtice   ! snow melting only = water into the ocean (then without snow precip), >0
+            
+            ! updates available heat + precipitations after melting
+            dh_s_mlt (ji) = dh_s_mlt(ji) + zdeltah(ji,1)
+            zq_su    (ji) = MAX( 0._wp , zq_su (ji) + zdeltah(ji,1) * zqprec(ji) )      
+            zdh_s_pre(ji) = zdh_s_pre(ji) + zdeltah(ji,1)
+            
+            ! update thickness
+            h_s_1d(ji) = MAX( 0._wp , h_s_1d(ji) + zdh_s_pre(ji) )
+            !
+         ELSE
+            !
+            zdh_s_pre(ji) = 0._wp
+            zqprec   (ji) = 0._wp
+            !
+         ENDIF
+      END DO
+
+      ! recalculate snow layers
+      DO jk = 1, nlay_s
+         DO ji = 1, npti
+            zh_s(ji,jk) = h_s_1d(ji) * r1_nlay_s
+         END DO
+      END DO
+
+      ! Snow melting
+      ! ------------
+      ! If heat still available (zq_su > 0), then melt more snow
+      zdeltah(1:npti,:) = 0._wp
+      zdh_s_mel(1:npti) = 0._wp
+      DO jk = 1, nlay_s
+         DO ji = 1, npti
+            IF( zh_s(ji,jk) > 0._wp .AND. zq_su(ji) > 0._wp ) THEN
+               !
+               rswitch          = MAX( 0._wp, SIGN( 1._wp, e_s_1d(ji,jk) - epsi20 ) )
+               zdeltah  (ji,jk) = - rswitch * zq_su(ji) / MAX( e_s_1d(ji,jk), epsi20 )   ! thickness change
+               zdeltah  (ji,jk) = MAX( zdeltah(ji,jk) , - zh_s(ji,jk) )                  ! bound melting
+               zdh_s_mel(ji)    = zdh_s_mel(ji) + zdeltah(ji,jk)
+               
+               hfx_snw_1d(ji)     = hfx_snw_1d(ji)     - zdeltah(ji,jk) * a_i_1d(ji) * e_s_1d (ji,jk) * r1_rdtice   ! heat used to melt snow(W.m-2, >0)
+               wfx_snw_sum_1d(ji) = wfx_snw_sum_1d(ji) - rhosn          * a_i_1d(ji) * zdeltah(ji,jk) * r1_rdtice   ! snow melting only = water into the ocean (then without snow precip)
+               
+               ! updates available heat + thickness
+               dh_s_mlt(ji)    = dh_s_mlt(ji) + zdeltah(ji,jk)
+               zq_su   (ji)    = MAX( 0._wp , zq_su (ji) + zdeltah(ji,jk) * e_s_1d(ji,jk) )
+               h_s_1d  (ji)    = MAX( 0._wp , h_s_1d(ji) + zdeltah(ji,jk) )
+               zh_s    (ji,jk) = MAX( 0._wp , zh_s(ji,jk) + zdeltah(ji,jk) )
+               !
+            ENDIF
+         END DO
+      END DO
+
+      ! Snow sublimation 
+      !-----------------
+      ! qla_ice is always >=0 (upwards), heat goes to the atmosphere, therefore snow sublimates
+      !    comment: not counted in mass/heat exchange in iceupdate.F90 since this is an exchange with atm. (not ocean)
+      zdeltah(1:npti,:) = 0._wp
+      DO ji = 1, npti
+         IF( evap_ice_1d(ji) > 0._wp ) THEN
+            !
+            zdh_s_sub (ji)   = MAX( - h_s_1d(ji) , - evap_ice_1d(ji) * r1_rhosn * rdt_ice )
+            zevap_rema(ji)   = evap_ice_1d(ji) * rdt_ice + zdh_s_sub(ji) * rhosn   ! remaining evap in kg.m-2 (used for ice melting later on)
+            zdeltah   (ji,1) = MAX( zdh_s_sub(ji), - zdh_s_pre(ji) )
+            
+            hfx_sub_1d    (ji) = hfx_sub_1d(ji) + &   ! Heat flux by sublimation [W.m-2], < 0 (sublimate snow that had fallen, then pre-existing snow)
+               &                 ( zdeltah(ji,1) * zqprec(ji) + ( zdh_s_sub(ji) - zdeltah(ji,1) ) * e_s_1d(ji,1) )  &
+               &                 * a_i_1d(ji) * r1_rdtice
+            wfx_snw_sub_1d(ji) = wfx_snw_sub_1d(ji) - rhosn * a_i_1d(ji) * zdh_s_sub(ji) * r1_rdtice   ! Mass flux by sublimation
+            
+            ! new snow thickness
+            h_s_1d(ji)    =  MAX( 0._wp , h_s_1d(ji) + zdh_s_sub(ji) )
+            ! update precipitations after sublimation and correct sublimation
+            zdh_s_pre(ji) = zdh_s_pre(ji) + zdeltah(ji,1)
+            zdh_s_sub(ji) = zdh_s_sub(ji) - zdeltah(ji,1)
+            !
+         ELSE
+            !
+            zdh_s_sub (ji) = 0._wp
+            zevap_rema(ji) = 0._wp
+            !
+         ENDIF
+      END DO
+      
+      ! --- Update snow diags --- !
+      DO ji = 1, npti
+         dh_s_tot(ji) = zdh_s_mel(ji) + zdh_s_pre(ji) + zdh_s_sub(ji)
+      END DO
+
+      ! Update temperature, energy
+      !---------------------------
+      ! new temp and enthalpy of the snow (remaining snow precip + remaining pre-existing snow)
+      DO jk = 1, nlay_s
+         DO ji = 1,npti
+            rswitch       = MAX( 0._wp , SIGN( 1._wp, h_s_1d(ji) - epsi20 ) )
+            e_s_1d(ji,jk) = rswitch / MAX( h_s_1d(ji), epsi20 ) *            &
+              &             ( ( zdh_s_pre(ji)              ) * zqprec(ji) +  &
+              &               ( h_s_1d(ji) - zdh_s_pre(ji) ) * rhosn * ( cpic * ( rt0 - t_s_1d(ji,jk) ) + lfus ) )
+         END DO
+      END DO
+      
+      !                       ! ============ !
+      !                       !     Ice      !
+      !                       ! ============ !
+
+      ! Surface ice melting 
+      !--------------------
+      zdeltah(1:npti,:) = 0._wp ! important
+      DO jk = 1, nlay_i
+         DO ji = 1, npti
+            ztmelts = - tmut * sz_i_1d(ji,jk)   ! Melting point of layer k [C]
+            
+            IF( t_i_1d(ji,jk) >= (ztmelts+rt0) ) THEN   !-- Internal melting
+
+               zEi            = - e_i_1d(ji,jk) * r1_rhoic            ! Specific enthalpy of layer k [J/kg, <0]       
+               zdE            = 0._wp                                 ! Specific enthalpy difference (J/kg, <0)
+                                                                      ! set up at 0 since no energy is needed to melt water...(it is already melted)
+               zdeltah(ji,jk) = MIN( 0._wp , - zh_i(ji,jk) )          ! internal melting occurs when the internal temperature is above freezing     
+                                                                      ! this should normally not happen, but sometimes, heat diffusion leads to this
+               zfmdt          = - zdeltah(ji,jk) * rhoic              ! Mass flux x time step > 0
+                         
+               dh_i_surf(ji)  = dh_i_surf(ji) + zdeltah(ji,jk)        ! Cumulate surface melt
+               
+               zfmdt          = - rhoic * zdeltah(ji,jk)              ! Recompute mass flux [kg/m2, >0]
+
+               hfx_res_1d(ji) = hfx_res_1d(ji) + zfmdt * a_i_1d(ji) * zEi * r1_rdtice                           ! Heat flux to the ocean [W.m-2], <0
+               !                                                                                                  ice enthalpy zEi is "sent" to the ocean
+               sfx_res_1d(ji) = sfx_res_1d(ji) - rhoic * a_i_1d(ji) * zdeltah(ji,jk) * s_i_1d(ji) * r1_rdtice   ! Salt flux
+               !                                                                                                  using s_i_1d and not sz_i_1d(jk) is ok
+               wfx_res_1d(ji) = wfx_res_1d(ji) - rhoic * a_i_1d(ji) * zdeltah(ji,jk) * r1_rdtice                ! Mass flux
+
+            ELSE                                        !-- Surface melting
+               
+               zEi            = - e_i_1d(ji,jk) * r1_rhoic            ! Specific enthalpy of layer k [J/kg, <0]
+               zEw            =    rcp * ztmelts                      ! Specific enthalpy of resulting meltwater [J/kg, <0]
+               zdE            =    zEi - zEw                          ! Specific enthalpy difference < 0
+               
+               zfmdt          = - zq_su(ji) / zdE                     ! Mass flux to the ocean [kg/m2, >0]
+               
+               zdeltah(ji,jk) = - zfmdt * r1_rhoic                    ! Melt of layer jk [m, <0]
+               
+               zdeltah(ji,jk) = MIN( 0._wp , MAX( zdeltah(ji,jk) , - zh_i(ji,jk) ) )    ! Melt of layer jk cannot exceed the layer thickness [m, <0]
+               
+               zq_su(ji)      = MAX( 0._wp , zq_su(ji) - zdeltah(ji,jk) * rhoic * zdE ) ! update available heat
+               
+               dh_i_surf(ji)  = dh_i_surf(ji) + zdeltah(ji,jk)        ! Cumulate surface melt
+               
+               zfmdt          = - rhoic * zdeltah(ji,jk)              ! Recompute mass flux [kg/m2, >0]
+               
+               zQm            = zfmdt * zEw                           ! Energy of the melt water sent to the ocean [J/m2, <0]
+               
+               sfx_sum_1d(ji) = sfx_sum_1d(ji) - rhoic * a_i_1d(ji) * zdeltah(ji,jk) * s_i_1d(ji) * r1_rdtice   ! Salt flux >0
+               !                                                                                                  using s_i_1d and not sz_i_1d(jk) is ok)
+               hfx_thd_1d(ji) = hfx_thd_1d(ji) + zfmdt * a_i_1d(ji) * zEw * r1_rdtice                           ! Heat flux [W.m-2], < 0
+               hfx_sum_1d(ji) = hfx_sum_1d(ji) - zfmdt * a_i_1d(ji) * zdE * r1_rdtice                           ! Heat flux used in this process [W.m-2], > 0  
+               ! 
+               wfx_sum_1d(ji) = wfx_sum_1d(ji) - rhoic * a_i_1d(ji) * zdeltah(ji,jk) * r1_rdtice                ! Mass flux
+               
+            END IF
+            
+            ! Ice sublimation
+            ! ---------------
+            zdum            = MAX( - ( zh_i(ji,jk) + zdeltah(ji,jk) ) , - zevap_rema(ji) * r1_rhoic )
+            zdeltah (ji,jk) = zdeltah (ji,jk) + zdum
+            dh_i_sub(ji)    = dh_i_sub(ji)    + zdum
+            
+            sfx_sub_1d(ji)     = sfx_sub_1d(ji) - rhoic * a_i_1d(ji) * zdum * s_i_1d(ji) * r1_rdtice ! Salt flux >0
+            !                                                                                          clem: flux is sent to the ocean for simplicity
+            !                                                                                                but salt should remain in the ice except
+            !                                                                                                if all ice is melted. => must be corrected
+            hfx_sub_1d(ji)     = hfx_sub_1d(ji) + zdum * e_i_1d(ji,jk) * a_i_1d(ji) * r1_rdtice      ! Heat flux [W.m-2], < 0
+
+            wfx_ice_sub_1d(ji) = wfx_ice_sub_1d(ji) - rhoic * a_i_1d(ji) * zdum * r1_rdtice          ! Mass flux > 0
+
+            ! update remaining mass flux
+            zevap_rema(ji)  = zevap_rema(ji) + zdum * rhoic
+            
+            ! record which layers have disappeared (for bottom melting) 
+            !    => icount=0 : no layer has vanished
+            !    => icount=5 : 5 layers have vanished
+            rswitch       = MAX( 0._wp , SIGN( 1._wp , - ( zh_i(ji,jk) + zdeltah(ji,jk) ) ) ) 
+            icount(ji,jk) = NINT( rswitch )
+            zh_i(ji,jk)   = MAX( 0._wp , zh_i(ji,jk) + zdeltah(ji,jk) )
+                        
+            ! update heat content (J.m-2) and layer thickness
+            eh_i_old(ji,jk) = eh_i_old(ji,jk) + zdeltah(ji,jk) * e_i_1d(ji,jk)
+            h_i_old (ji,jk) = h_i_old (ji,jk) + zdeltah(ji,jk)
+         END DO
+      END DO
+      
+      ! update ice thickness
+      DO ji = 1, npti
+         h_i_1d(ji) =  MAX( 0._wp , h_i_1d(ji) + dh_i_surf(ji) + dh_i_sub(ji) )
+      END DO
+
+      ! remaining "potential" evap is sent to ocean
+      DO ji = 1, npti
+         wfx_err_sub_1d(ji) = wfx_err_sub_1d(ji) - zevap_rema(ji) * a_i_1d(ji) * r1_rdtice  ! <=0 (net evap for the ocean in kg.m-2.s-1)
+      END DO
+
+
+      ! Ice Basal growth 
+      !------------------
+      ! Basal growth is driven by heat imbalance at the ice-ocean interface,
+      ! between the inner conductive flux  (fc_bo_i), from the open water heat flux 
+      ! (fhld) and the turbulent ocean flux (fhtur). 
+      ! fc_bo_i is positive downwards. fhtur and fhld are positive to the ice 
+
+      ! If salinity varies in time, an iterative procedure is required, because
+      ! the involved quantities are inter-dependent.
+      ! Basal growth (dh_i_bott) depends upon new ice specific enthalpy (zEi),
+      ! which depends on forming ice salinity (s_i_new), which depends on dh/dt (dh_i_bott)
+      ! -> need for an iterative procedure, which converges quickly
+
+      num_iter_max = 1
+      IF( nn_icesal == 2 )   num_iter_max = 5  ! salinity varying in time
+      
+      DO ji = 1, npti
+         IF(  zf_tt(ji) < 0._wp  ) THEN
+            DO iter = 1, num_iter_max   ! iterations
+
+               ! New bottom ice salinity (Cox & Weeks, JGR88 )
+               !--- zswi1  if dh/dt < 2.0e-8
+               !--- zswi12 if 2.0e-8 < dh/dt < 3.6e-7 
+               !--- zswi2  if dh/dt > 3.6e-7
+               zgrr     = MIN( 1.0e-3, MAX ( dh_i_bott(ji) * r1_rdtice , epsi10 ) )
+               zswi2    = MAX( 0._wp , SIGN( 1._wp , zgrr - 3.6e-7 ) )
+               zswi12   = MAX( 0._wp , SIGN( 1._wp , zgrr - 2.0e-8 ) ) * ( 1.0 - zswi2 )
+               zswi1    = 1. - zswi2 * zswi12
+               zfracs   = MIN( zswi1  * 0.12 + zswi12 * ( 0.8925 + 0.0568 * LOG( 100.0 * zgrr ) )   &
+                  &          + zswi2  * 0.26 / ( 0.26 + 0.74 * EXP ( - 724300.0 * zgrr ) )  , 0.5 )
+
+               s_i_new(ji)   = zswitch_sal * zfracs * sss_1d(ji) + ( 1. - zswitch_sal ) * s_i_1d(ji)  ! New ice salinity
+
+               ztmelts       = - tmut * s_i_new(ji)                                                   ! New ice melting point (C)
+
+               zt_i_new      = zswitch_sal * t_bo_1d(ji) + ( 1. - zswitch_sal) * t_i_1d(ji, nlay_i)
+               
+               zEi           = cpic * ( zt_i_new - (ztmelts+rt0) ) &                                  ! Specific enthalpy of forming ice (J/kg, <0)
+                  &            - lfus * ( 1.0 - ztmelts / ( zt_i_new - rt0 ) ) + rcp  * ztmelts
+
+               zEw           = rcp  * ( t_bo_1d(ji) - rt0 )                                           ! Specific enthalpy of seawater (J/kg, < 0)
+
+               zdE           = zEi - zEw                                                              ! Specific enthalpy difference (J/kg, <0)
+
+               dh_i_bott(ji) = rdt_ice * MAX( 0._wp , zf_tt(ji) / ( zdE * rhoic ) )
+               
+            END DO
+            ! Contribution to Energy and Salt Fluxes                                    
+            zfmdt          = - rhoic * dh_i_bott(ji)                                                  ! Mass flux x time step (kg/m2, < 0)
+            
+            hfx_thd_1d(ji) = hfx_thd_1d(ji) + zfmdt * a_i_1d(ji) * zEw * r1_rdtice                           ! Heat flux to the ocean [W.m-2], >0
+            hfx_bog_1d(ji) = hfx_bog_1d(ji) - zfmdt * a_i_1d(ji) * zdE * r1_rdtice                           ! Heat flux used in this process [W.m-2], <0
+            
+            sfx_bog_1d(ji) = sfx_bog_1d(ji) - rhoic * a_i_1d(ji) * dh_i_bott(ji) * s_i_new(ji) * r1_rdtice   ! Salt flux, <0
+
+            wfx_bog_1d(ji) = wfx_bog_1d(ji) - rhoic * a_i_1d(ji) * dh_i_bott(ji) * r1_rdtice                 ! Mass flux, <0
+
+            ! update heat content (J.m-2) and layer thickness
+            eh_i_old(ji,nlay_i+1) = eh_i_old(ji,nlay_i+1) + dh_i_bott(ji) * (-zEi * rhoic)
+            h_i_old (ji,nlay_i+1) = h_i_old (ji,nlay_i+1) + dh_i_bott(ji)
+
+         ENDIF
+
+      END DO
+
+      ! Ice Basal melt
+      !---------------
+      zdeltah(1:npti,:) = 0._wp ! important
+      DO jk = nlay_i, 1, -1
+         DO ji = 1, npti
+            IF(  zf_tt(ji)  >  0._wp  .AND. jk > icount(ji,jk) ) THEN   ! do not calculate where layer has already disappeared by surface melting 
+
+               ztmelts = - tmut * sz_i_1d(ji,jk)  ! Melting point of layer jk (C)
+
+               IF( t_i_1d(ji,jk) >= (ztmelts+rt0) ) THEN   !-- Internal melting
+
+                  zEi               = - e_i_1d(ji,jk) * r1_rhoic    ! Specific enthalpy of melting ice (J/kg, <0)
+                  zdE               = 0._wp                         ! Specific enthalpy difference   (J/kg, <0)
+                                                                    !    set up at 0 since no energy is needed to melt water...(it is already melted)
+                  zdeltah   (ji,jk) = MIN( 0._wp , - zh_i(ji,jk) )  ! internal melting occurs when the internal temperature is above freezing     
+                                                                    ! this should normally not happen, but sometimes, heat diffusion leads to this
+
+                  dh_i_bott (ji)    = dh_i_bott(ji) + zdeltah(ji,jk)
+
+                  zfmdt             = - zdeltah(ji,jk) * rhoic      ! Mass flux x time step > 0
+
+                  hfx_res_1d(ji) = hfx_res_1d(ji) + zfmdt * a_i_1d(ji) * zEi * r1_rdtice                           ! Heat flux to the ocean [W.m-2], <0
+                  !                                                                                                  ice enthalpy zEi is "sent" to the ocean
+                  sfx_res_1d(ji) = sfx_res_1d(ji) - rhoic * a_i_1d(ji) * zdeltah(ji,jk) * s_i_1d(ji) * r1_rdtice   ! Salt flux
+                  !                                                                                                  using s_i_1d and not sz_i_1d(jk) is ok
+                  wfx_res_1d(ji) = wfx_res_1d(ji) - rhoic * a_i_1d(ji) * zdeltah(ji,jk) * r1_rdtice                ! Mass flux
+
+                  ! update heat content (J.m-2) and layer thickness
+                  eh_i_old(ji,jk) = eh_i_old(ji,jk) + zdeltah(ji,jk) * e_i_1d(ji,jk)
+                  h_i_old (ji,jk) = h_i_old (ji,jk) + zdeltah(ji,jk)
+
+               ELSE                                        !-- Basal melting
+
+                  zEi             = - e_i_1d(ji,jk) * r1_rhoic                                ! Specific enthalpy of melting ice (J/kg, <0)
+                  zEw             = rcp * ztmelts                                             ! Specific enthalpy of meltwater (J/kg, <0)
+                  zdE             = zEi - zEw                                                 ! Specific enthalpy difference   (J/kg, <0)
+
+                  zfmdt           = - zq_bo(ji) / zdE                                         ! Mass flux x time step (kg/m2, >0)
+
+                  zdeltah(ji,jk)  = - zfmdt * r1_rhoic                                        ! Gross thickness change
+
+                  zdeltah(ji,jk)  = MIN( 0._wp , MAX( zdeltah(ji,jk), - zh_i(ji,jk) ) )       ! bound thickness change
+                  
+                  zq_bo(ji)       = MAX( 0._wp , zq_bo(ji) - zdeltah(ji,jk) * rhoic * zdE )   ! update available heat. MAX is necessary for roundup errors
+
+                  dh_i_bott(ji)   = dh_i_bott(ji) + zdeltah(ji,jk)                            ! Update basal melt
+
+                  zfmdt           = - zdeltah(ji,jk) * rhoic                                  ! Mass flux x time step > 0
+
+                  zQm             = zfmdt * zEw                                               ! Heat exchanged with ocean
+
+                  hfx_thd_1d(ji)  = hfx_thd_1d(ji) + zfmdt * a_i_1d(ji) * zEw * r1_rdtice                           ! Heat flux to the ocean [W.m-2], <0  
+                  hfx_bom_1d(ji)  = hfx_bom_1d(ji) - zfmdt * a_i_1d(ji) * zdE * r1_rdtice                           ! Heat used in this process [W.m-2], >0  
+
+                  sfx_bom_1d(ji)  = sfx_bom_1d(ji) - rhoic *  a_i_1d(ji) * zdeltah(ji,jk) * s_i_1d(ji) * r1_rdtice  ! Salt flux
+                  !                                                                                                   using s_i_1d and not sz_i_1d(jk) is ok
+                  
+                  wfx_bom_1d(ji)  = wfx_bom_1d(ji) - rhoic * a_i_1d(ji) * zdeltah(ji,jk) * r1_rdtice                ! Mass flux
+
+                  ! update heat content (J.m-2) and layer thickness
+                  eh_i_old(ji,jk) = eh_i_old(ji,jk) + zdeltah(ji,jk) * e_i_1d(ji,jk)
+                  h_i_old (ji,jk) = h_i_old (ji,jk) + zdeltah(ji,jk)
+               ENDIF
+           
+            ENDIF
+         END DO
+      END DO
+
+      ! Update temperature, energy
+      ! --------------------------
+      DO ji = 1, npti
+         h_i_1d(ji) = MAX( 0._wp , h_i_1d(ji) + dh_i_bott(ji) )
+      END DO  
+
+      ! If heat still available then melt more snow
+      !-------------------------------------------
+      zdeltah(1:npti,:) = 0._wp ! important
+      DO ji = 1, npti
+         zq_rema (ji)   = zq_su(ji) + zq_bo(ji) 
+         rswitch        = 1._wp - MAX( 0._wp, SIGN( 1._wp, - h_s_1d(ji) ) )   ! =1 if snow
+         rswitch        = rswitch * MAX( 0._wp, SIGN( 1._wp, e_s_1d(ji,1) - epsi20 ) )
+         zdeltah (ji,1) = - rswitch * zq_rema(ji) / MAX( e_s_1d(ji,1), epsi20 )
+         zdeltah (ji,1) = MIN( 0._wp , MAX( zdeltah(ji,1) , - h_s_1d(ji) ) ) ! bound melting
+         dh_s_tot(ji)   = dh_s_tot(ji) + zdeltah(ji,1)
+         h_s_1d  (ji)   = h_s_1d  (ji) + zdeltah(ji,1)
+        
+         zq_rema(ji)        = zq_rema(ji) + zdeltah(ji,1) * e_s_1d(ji,1)                               ! update available heat (J.m-2)
+         hfx_snw_1d(ji)     = hfx_snw_1d(ji) - zdeltah(ji,1) * a_i_1d(ji) * e_s_1d(ji,1) * r1_rdtice   ! Heat used to melt snow, W.m-2 (>0)
+         wfx_snw_sum_1d(ji) = wfx_snw_sum_1d(ji) - rhosn * a_i_1d(ji) * zdeltah(ji,1) * r1_rdtice      ! Mass flux
+         dh_s_mlt(ji)       = dh_s_mlt(ji) + zdeltah(ji,1)
+         !    
+         ! Remaining heat flux (W.m-2) is sent to the ocean heat budget
+         hfx_out_1d(ji) = hfx_out_1d(ji) + ( zq_rema(ji) * a_i_1d(ji) ) * r1_rdtice
+
+         IF( ln_icectl .AND. zq_rema(ji) < 0. .AND. lwp ) WRITE(numout,*) 'ALERTE zq_rema <0 = ', zq_rema(ji)
+      END DO
+
+      !
+      ! Snow-Ice formation
+      ! ------------------
+      ! When snow load excesses Archimede's limit, snow-ice interface goes down under sea-level, 
+      ! flooding of seawater transforms snow into ice dh_snowice is positive for the ice
+      z1_rho = 1._wp / ( rhosn+rau0-rhoic )
+      DO ji = 1, npti
+         !
+         dh_snowice(ji) = MAX(  0._wp , ( rhosn * h_s_1d(ji) + (rhoic-rau0) * h_i_1d(ji) ) * z1_rho )
+
+         h_i_1d(ji)    = h_i_1d(ji) + dh_snowice(ji)
+         h_s_1d(ji)    = h_s_1d(ji) - dh_snowice(ji)
+
+         ! Contribution to energy flux to the ocean [J/m2], >0 (if sst<0)
+         zfmdt          = ( rhosn - rhoic ) * dh_snowice(ji)    ! <0
+         zEw            = rcp * sst_1d(ji)
+         zQm            = zfmdt * zEw 
+         
+         hfx_thd_1d(ji) = hfx_thd_1d(ji) + zfmdt * a_i_1d(ji) * zEw * r1_rdtice ! Heat flux
+
+         sfx_sni_1d(ji) = sfx_sni_1d(ji) + sss_1d(ji) * a_i_1d(ji) * zfmdt * r1_rdtice ! Salt flux
+
+         ! Case constant salinity in time: virtual salt flux to keep salinity constant
+         IF( nn_icesal /= 2 )  THEN
+            sfx_bri_1d(ji) = sfx_bri_1d(ji) - sss_1d (ji) * a_i_1d(ji) * zfmdt                  * r1_rdtice  & ! put back sss_m     into the ocean
+               &                            - s_i_1d(ji)  * a_i_1d(ji) * dh_snowice(ji) * rhoic * r1_rdtice    ! and get  rn_icesal from the ocean 
+         ENDIF
+
+         ! Mass flux: All snow is thrown in the ocean, and seawater is taken to replace the volume
+         wfx_sni_1d(ji)     = wfx_sni_1d(ji)     - a_i_1d(ji) * dh_snowice(ji) * rhoic * r1_rdtice
+         wfx_snw_sni_1d(ji) = wfx_snw_sni_1d(ji) + a_i_1d(ji) * dh_snowice(ji) * rhosn * r1_rdtice
+
+         ! update heat content (J.m-2) and layer thickness
+         eh_i_old(ji,0) = eh_i_old(ji,0) + dh_snowice(ji) * e_s_1d(ji,1) + zfmdt * zEw
+         h_i_old (ji,0) = h_i_old (ji,0) + dh_snowice(ji)
+         
+      END DO
+
+      !
+      ! Update temperature, energy
+      ! --------------------------
+      DO ji = 1, npti
+         rswitch     = 1._wp - MAX( 0._wp , SIGN( 1._wp , - h_i_1d(ji) ) ) 
+         t_su_1d(ji) = rswitch * t_su_1d(ji) + ( 1._wp - rswitch ) * rt0
+      END DO
+
+      DO jk = 1, nlay_s
+         DO ji = 1,npti
+            ! mask enthalpy
+            rswitch       = 1._wp - MAX(  0._wp , SIGN( 1._wp, - h_s_1d(ji) )  )
+            e_s_1d(ji,jk) = rswitch * e_s_1d(ji,jk)
+            ! recalculate t_s_1d from e_s_1d
+            t_s_1d(ji,jk) = rt0 + rswitch * ( - e_s_1d(ji,jk) * r1_rhosn * r1_cpic + lfus * r1_cpic )
+         END DO
+      END DO
+
+      ! --- ensure that a_i = 0 where h_i = 0 ---
+      WHERE( h_i_1d(1:npti) == 0._wp )   a_i_1d(1:npti) = 0._wp
+      !
+   END SUBROUTINE ice_thd_dh
+
+
+   !!--------------------------------------------------------------------------
+   !! INTERFACE ice_thd_snwblow
+   !!
+   !! ** Purpose :   Compute distribution of precip over the ice
+   !!
+   !!                Snow accumulation in one thermodynamic time step
+   !!                snowfall is partitionned between leads and ice.
+   !!                If snow fall was uniform, a fraction (1-at_i) would fall into leads
+   !!                but because of the winds, more snow falls on leads than on sea ice
+   !!                and a greater fraction (1-at_i)^beta of the total mass of snow 
+   !!                (beta < 1) falls in leads.
+   !!                In reality, beta depends on wind speed, 
+   !!                and should decrease with increasing wind speed but here, it is 
+   !!                considered as a constant. an average value is 0.66
+   !!--------------------------------------------------------------------------
+!!gm  I think it can be usefull to set this as a FUNCTION, not a SUBROUTINE....
+   SUBROUTINE ice_thd_snwblow_2d( pin, pout )
+      REAL(wp), DIMENSION(:,:), INTENT(in   ) :: pin   ! previous fraction lead ( 1. - a_i_b )
+      REAL(wp), DIMENSION(:,:), INTENT(inout) :: pout
+      pout = ( 1._wp - ( pin )**rn_blow_s )
+   END SUBROUTINE ice_thd_snwblow_2d
+
+   SUBROUTINE ice_thd_snwblow_1d( pin, pout )
+      REAL(wp), DIMENSION(:), INTENT(in   ) :: pin
+      REAL(wp), DIMENSION(:), INTENT(inout) :: pout
+      pout = ( 1._wp - ( pin )**rn_blow_s )
+   END SUBROUTINE ice_thd_snwblow_1d
+
+#else
+   !!----------------------------------------------------------------------
+   !!   Default option                                NO SI3 sea-ice model
+   !!----------------------------------------------------------------------
+#endif
+
+   !!======================================================================
+END MODULE icethd_dh
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/ICE_SRC/icethd_do.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/ICE_SRC/icethd_do.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/ICE_SRC/icethd_do.F90	(revision 9570)
@@ -0,0 +1,526 @@
+MODULE icethd_do
+   !!======================================================================
+   !!                       ***  MODULE icethd_do   ***
+   !!   sea-ice: sea ice growth in the leads (open water)  
+   !!======================================================================
+   !! History :  LIM  ! 2005-12 (M. Vancoppenolle)  Original code
+   !!             -   ! 2006-01 (M. Vancoppenolle)  add ITD
+   !!            3.0  ! 2007-07 (M. Vancoppenolle)  Mass and energy conservation tested
+   !!            4.0  ! 2011-02 (G. Madec) dynamical allocation
+   !!----------------------------------------------------------------------
+#if defined key_si3
+   !!----------------------------------------------------------------------
+   !!   'key_si3'                                       SI3 sea-ice model
+   !!----------------------------------------------------------------------
+   !!   ice_thd_do        : ice growth in open water (=lateral accretion of ice)
+   !!   ice_thd_do_init   : initialization
+   !!----------------------------------------------------------------------
+   USE dom_oce        ! ocean space and time domain
+   USE phycst         ! physical constants
+   USE sbc_oce , ONLY : sss_m
+   USE sbc_ice , ONLY : utau_ice, vtau_ice
+   USE ice1D          ! sea-ice: thermodynamics variables
+   USE ice            ! sea-ice: variables
+   USE icetab         ! sea-ice: 2D <==> 1D
+   USE icectl         ! sea-ice: conservation
+   USE icethd_ent     ! sea-ice: thermodynamics, enthalpy
+   USE icevar         ! sea-ice: operations
+   USE icethd_sal     ! sea-ice: salinity profiles
+   !
+   USE in_out_manager ! I/O manager
+   USE lib_mpp        ! MPP library
+   USE lib_fortran    ! fortran utilities (glob_sum + no signed zero)
+   USE lbclnk         ! lateral boundary conditions (or mpp links)
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   ice_thd_do        ! called by ice_thd
+   PUBLIC   ice_thd_do_init   ! called by ice_stp
+
+   !                          !!** namelist (namthd_do) **
+   REAL(wp) ::   rn_hinew      ! thickness for new ice formation (m)
+   LOGICAL  ::   ln_frazil     ! use of frazil ice collection as function of wind (T) or not (F)
+   REAL(wp) ::   rn_maxfraz    ! maximum portion of frazil ice collecting at the ice bottom
+   REAL(wp) ::   rn_vfraz      ! threshold drift speed for collection of bottom frazil ice
+   REAL(wp) ::   rn_Cfraz      ! squeezing coefficient for collection of bottom frazil ice
+
+   !!----------------------------------------------------------------------
+   !! NEMO/ICE 4.0 , NEMO Consortium (2017)
+   !! $Id: icethd_do.F90 8420 2017-08-08 12:18:46Z clem $
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE ice_thd_do
+      !!-------------------------------------------------------------------
+      !!               ***   ROUTINE ice_thd_do  ***
+      !!  
+      !! ** Purpose : Computation of the evolution of the ice thickness and 
+      !!      concentration as a function of the heat balance in the leads.
+      !!       
+      !! ** Method  : Ice is formed in the open water when ocean lose heat
+      !!      (heat budget of open water Bl is negative) .
+      !!      Computation of the increase of 1-A (ice concentration) fol-
+      !!      lowing the law :
+      !!      (dA/dt)acc = F[ (1-A)/(1-a) ] * [ Bl / (Li*h0) ]
+      !!       where - h0 is the thickness of ice created in the lead
+      !!             - a is a minimum fraction for leads
+      !!             - F is a monotonic non-increasing function defined as:
+      !!                  F(X)=( 1 - X**exld )**(1.0/exld)
+      !!             - exld is the exponent closure rate (=2 default val.)
+      !! 
+      !! ** Action : - Adjustment of snow and ice thicknesses and heat
+      !!                content in brine pockets
+      !!             - Updating ice internal temperature
+      !!             - Computation of variation of ice volume and mass
+      !!             - Computation of a_i after lateral accretion and 
+      !!               update h_s_1d, h_i_1d      
+      !!------------------------------------------------------------------------
+      INTEGER  ::   ji, jj, jk, jl   ! dummy loop indices
+      INTEGER  ::   iter     !   -       -
+      REAL(wp) ::   ztmelts, zfrazb, zweight, zde                          ! local scalars
+      REAL(wp) ::   zgamafr, zvfrx, zvgx, ztaux, ztwogp, zf                     !   -      -
+      REAL(wp) ::   ztenagm, zvfry, zvgy, ztauy, zvrel2, zfp, zsqcd , zhicrit   !   -      -
+      !
+      REAL(wp) ::   zQm          ! enthalpy exchanged with the ocean (J/m2, >0 towards ocean)
+      REAL(wp) ::   zEi          ! sea ice specific enthalpy (J/kg)
+      REAL(wp) ::   zEw          ! seawater specific enthalpy (J/kg)
+      REAL(wp) ::   zfmdt        ! mass flux x time step (kg/m2, >0 towards ocean)
+      !
+      REAL(wp) ::   zv_newfra
+      !
+      INTEGER , DIMENSION(jpij) ::   jcat        ! indexes of categories where new ice grows
+      REAL(wp), DIMENSION(jpij) ::   zswinew     ! switch for new ice or not
+      !
+      REAL(wp), DIMENSION(jpij) ::   zv_newice   ! volume of accreted ice
+      REAL(wp), DIMENSION(jpij) ::   za_newice   ! fractional area of accreted ice
+      REAL(wp), DIMENSION(jpij) ::   zh_newice   ! thickness of accreted ice
+      REAL(wp), DIMENSION(jpij) ::   ze_newice   ! heat content of accreted ice
+      REAL(wp), DIMENSION(jpij) ::   zs_newice   ! salinity of accreted ice
+      REAL(wp), DIMENSION(jpij) ::   zo_newice   ! age of accreted ice
+      REAL(wp), DIMENSION(jpij) ::   zdv_res     ! residual volume in case of excessive heat budget
+      REAL(wp), DIMENSION(jpij) ::   zda_res     ! residual area in case of excessive heat budget
+      REAL(wp), DIMENSION(jpij) ::   zv_frazb    ! accretion of frazil ice at the ice bottom
+      REAL(wp), DIMENSION(jpij) ::   zvrel_1d    ! relative ice / frazil velocity (1D vector)
+      !
+      REAL(wp), DIMENSION(jpij,jpl) ::   zv_b      ! old volume of ice in category jl
+      REAL(wp), DIMENSION(jpij,jpl) ::   za_b      ! old area of ice in category jl
+      !
+      REAL(wp), DIMENSION(jpij,nlay_i,jpl) ::   ze_i_2d !: 1-D version of e_i
+      !
+      REAL(wp), DIMENSION(jpi,jpj) ::   zvrel     ! relative ice / frazil velocity
+      !
+      REAL(wp) :: zcai = 1.4e-3_wp                     ! ice-air drag (clem: should be dependent on coupling/forcing used)
+      !!-----------------------------------------------------------------------!
+
+      IF( ln_icediachk )   CALL ice_cons_hsm( 0, 'icethd_do', rdiag_v, rdiag_s, rdiag_t, rdiag_fv, rdiag_fs, rdiag_ft )
+
+      CALL ice_var_agg(1)
+      CALL ice_var_glo2eqv
+
+      !------------------------------------------------------------------------------!
+      ! 3) Collection thickness of ice formed in leads and polynyas
+      !------------------------------------------------------------------------------!    
+      ! ht_i_new is the thickness of new ice formed in open water
+      ! ht_i_new can be either prescribed (frazswi = 0) or computed (frazswi = 1)
+      ! Frazil ice forms in open water, is transported by wind
+      ! accumulates at the edge of the consolidated ice edge
+      ! where it forms aggregates of a specific thickness called
+      ! collection thickness.
+
+      ! Note : the following algorithm currently breaks vectorization
+      ! 
+
+      zvrel(:,:) = 0._wp
+
+      ! Default new ice thickness
+      WHERE( qlead(:,:) < 0._wp )   ;   ht_i_new(:,:) = rn_hinew
+      ELSEWHERE                     ;   ht_i_new(:,:) = 0._wp
+      END WHERE
+
+      IF( ln_frazil ) THEN
+         !
+         !--------------------
+         ! Physical constants
+         !--------------------
+         ht_i_new(:,:) = 0._wp
+         !
+         zhicrit = 0.04 ! frazil ice thickness
+         ztwogp  = 2. * rau0 / ( grav * 0.3 * ( rau0 - rhoic ) ) ! reduced grav
+         zsqcd   = 1.0 / SQRT( 1.3 * zcai ) ! 1/SQRT(airdensity*drag)
+         zgamafr = 0.03
+         !
+         DO jj = 2, jpjm1
+            DO ji = 2, jpim1
+               IF ( qlead(ji,jj) < 0._wp .AND. tau_icebfr(ji,jj) == 0._wp ) THEN ! activated if cooling and no landfast
+                  !-------------
+                  ! Wind stress
+                  !-------------
+                  ! C-grid wind stress components
+                  ztaux         = ( utau_ice(ji-1,jj  ) * umask(ji-1,jj  ,1)   &
+                     &          +   utau_ice(ji  ,jj  ) * umask(ji  ,jj  ,1) ) * 0.5_wp
+                  ztauy         = ( vtau_ice(ji  ,jj-1) * vmask(ji  ,jj-1,1)   &
+                     &          +   vtau_ice(ji  ,jj  ) * vmask(ji  ,jj  ,1) ) * 0.5_wp
+                  ! Square root of wind stress
+                  ztenagm       =  SQRT( SQRT( ztaux * ztaux + ztauy * ztauy ) )
+
+                  !---------------------
+                  ! Frazil ice velocity
+                  !---------------------
+                  rswitch = MAX( 0._wp, SIGN( 1._wp , ztenagm - epsi10 ) )
+                  zvfrx   = rswitch * zgamafr * zsqcd * ztaux / MAX( ztenagm, epsi10 )
+                  zvfry   = rswitch * zgamafr * zsqcd * ztauy / MAX( ztenagm, epsi10 )
+
+                  !-------------------
+                  ! Pack ice velocity
+                  !-------------------
+                  ! C-grid ice velocity
+                  zvgx    = ( u_ice(ji-1,jj  ) * umask(ji-1,jj  ,1)  + u_ice(ji,jj) * umask(ji,jj,1) ) * 0.5_wp
+                  zvgy    = ( v_ice(ji  ,jj-1) * vmask(ji  ,jj-1,1)  + v_ice(ji,jj) * vmask(ji,jj,1) ) * 0.5_wp
+
+                  !-----------------------------------
+                  ! Relative frazil/pack ice velocity
+                  !-----------------------------------
+                  ! absolute relative velocity
+                  rswitch      = MAX( 0._wp, SIGN( 1._wp , at_i(ji,jj) - epsi10 ) )
+                  zvrel2       = MAX(  ( zvfrx - zvgx ) * ( zvfrx - zvgx )   &
+                     &               + ( zvfry - zvgy ) * ( zvfry - zvgy ) , 0.15 * 0.15 ) * rswitch
+                  zvrel(ji,jj) = SQRT( zvrel2 )
+
+                  !---------------------
+                  ! Iterative procedure
+                  !---------------------
+                  ht_i_new(ji,jj) = zhicrit +   ( zhicrit + 0.1 )    &
+                     &                   / ( ( zhicrit + 0.1 ) * ( zhicrit + 0.1 ) -  zhicrit * zhicrit ) * ztwogp * zvrel2
+
+                  iter = 1
+                  DO WHILE ( iter < 20 ) 
+                     zf  = ( ht_i_new(ji,jj) - zhicrit ) * ( ht_i_new(ji,jj) * ht_i_new(ji,jj) - zhicrit * zhicrit ) -   &
+                        &    ht_i_new(ji,jj) * zhicrit * ztwogp * zvrel2
+                     zfp = ( ht_i_new(ji,jj) - zhicrit ) * ( 3.0 * ht_i_new(ji,jj) + zhicrit ) - zhicrit * ztwogp * zvrel2
+
+                     ht_i_new(ji,jj) = ht_i_new(ji,jj) - zf / MAX( zfp, epsi20 )
+                     iter = iter + 1
+                  END DO
+                  !
+               ENDIF ! end of selection of pixels where ice forms
+               !
+            END DO 
+         END DO 
+         ! 
+         CALL lbc_lnk_multi( zvrel, 'T', 1., ht_i_new, 'T', 1.  )
+
+      ENDIF ! End of computation of frazil ice collection thickness
+
+      !------------------------------------------------------------------------------!
+      ! 4) Identify grid points where new ice forms
+      !------------------------------------------------------------------------------!
+
+      !-------------------------------------
+      ! Select points for new ice formation
+      !-------------------------------------
+      ! This occurs if open water energy budget is negative (cooling) and there is no landfast ice
+      npti = 0   ;   nptidx(:) = 0
+      DO jj = 1, jpj
+         DO ji = 1, jpi
+            IF ( qlead(ji,jj)  <  0._wp .AND. tau_icebfr(ji,jj) == 0._wp ) THEN
+               npti = npti + 1
+               nptidx( npti ) = (jj - 1) * jpi + ji
+            ENDIF
+         END DO
+      END DO
+
+      !------------------------------
+      ! Move from 2-D to 1-D vectors
+      !------------------------------
+      ! If ocean gains heat do nothing. Otherwise compute new ice formation
+
+      IF ( npti > 0 ) THEN
+
+         CALL tab_2d_1d( npti, nptidx(1:npti), at_i_1d(1:npti)      , at_i        )
+         CALL tab_3d_2d( npti, nptidx(1:npti), a_i_2d (1:npti,1:jpl), a_i (:,:,:) )
+         CALL tab_3d_2d( npti, nptidx(1:npti), v_i_2d (1:npti,1:jpl), v_i (:,:,:) )
+         CALL tab_3d_2d( npti, nptidx(1:npti), sv_i_2d(1:npti,1:jpl), sv_i(:,:,:) )
+         DO jl = 1, jpl
+            DO jk = 1, nlay_i
+               CALL tab_2d_1d( npti, nptidx(1:npti), ze_i_2d(1:npti,jk,jl), e_i(:,:,jk,jl) )
+            END DO
+         END DO
+         CALL tab_2d_1d( npti, nptidx(1:npti), qlead_1d  (1:npti) , qlead       )
+         CALL tab_2d_1d( npti, nptidx(1:npti), t_bo_1d   (1:npti) , t_bo        )
+         CALL tab_2d_1d( npti, nptidx(1:npti), sfx_opw_1d(1:npti) , sfx_opw     )
+         CALL tab_2d_1d( npti, nptidx(1:npti), wfx_opw_1d(1:npti) , wfx_opw     )
+         CALL tab_2d_1d( npti, nptidx(1:npti), zh_newice (1:npti) , ht_i_new    )
+         CALL tab_2d_1d( npti, nptidx(1:npti), zvrel_1d  (1:npti) , zvrel       )
+
+         CALL tab_2d_1d( npti, nptidx(1:npti), hfx_thd_1d(1:npti) , hfx_thd     )
+         CALL tab_2d_1d( npti, nptidx(1:npti), hfx_opw_1d(1:npti) , hfx_opw     )
+         CALL tab_2d_1d( npti, nptidx(1:npti), rn_amax_1d(1:npti) , rn_amax_2d  )
+         CALL tab_2d_1d( npti, nptidx(1:npti), sss_1d    (1:npti) , sss_m       )
+
+         !------------------------------------------------------------------------------|
+         ! 2) Convert units for ice internal energy
+         !------------------------------------------------------------------------------|
+         DO jl = 1, jpl
+            DO jk = 1, nlay_i               
+               WHERE( v_i_2d(1:npti,jl) > 0._wp )
+                  ze_i_2d(1:npti,jk,jl) = ze_i_2d(1:npti,jk,jl) / v_i_2d(1:npti,jl) * REAL( nlay_i )
+               ELSEWHERE
+                  ze_i_2d(1:npti,jk,jl) = 0._wp
+               END WHERE
+            END DO
+         END DO
+         !------------------------------------------------------------------------------!
+         ! 5) Compute thickness, salinity, enthalpy, age, area and volume of new ice
+         !------------------------------------------------------------------------------!
+
+         !-----------------------------------------
+         ! Keep old ice areas and volume in memory
+         !-----------------------------------------
+         zv_b(1:npti,:) = v_i_2d(1:npti,:) 
+         za_b(1:npti,:) = a_i_2d(1:npti,:)
+
+         !----------------------
+         ! Salinity of new ice 
+         !----------------------
+         SELECT CASE ( nn_icesal )
+         CASE ( 1 )                    ! Sice = constant 
+            zs_newice(1:npti) = rn_icesal
+         CASE ( 2 )                    ! Sice = F(z,t) [Vancoppenolle et al (2005)]
+            DO ji = 1, npti
+               zs_newice(ji) = MIN(  4.606 + 0.91 / zh_newice(ji) , rn_simax , 0.5 * sss_1d(ji) )
+            END DO
+         CASE ( 3 )                    ! Sice = F(z) [multiyear ice]
+            zs_newice(1:npti) =   2.3
+         END SELECT
+
+         !-------------------------
+         ! Heat content of new ice
+         !-------------------------
+         ! We assume that new ice is formed at the seawater freezing point
+         DO ji = 1, npti
+            ztmelts       = - tmut * zs_newice(ji)                  ! Melting point (C)
+            ze_newice(ji) =   rhoic * (  cpic * ( ztmelts - ( t_bo_1d(ji) - rt0 ) )                     &
+               &                       + lfus * ( 1.0 - ztmelts / MIN( t_bo_1d(ji) - rt0, -epsi10 ) )   &
+               &                       - rcp  *         ztmelts )
+         END DO
+
+         !----------------
+         ! Age of new ice
+         !----------------
+         zo_newice(1:npti) = 0._wp
+
+         !-------------------
+         ! Volume of new ice
+         !-------------------
+         DO ji = 1, npti
+
+            zEi           = - ze_newice(ji) * r1_rhoic             ! specific enthalpy of forming ice [J/kg]
+
+            zEw           = rcp * ( t_bo_1d(ji) - rt0 )            ! specific enthalpy of seawater at t_bo_1d [J/kg]
+                                                                   ! clem: we suppose we are already at the freezing point (condition qlead<0 is satisfyied) 
+                                                                   
+            zdE           = zEi - zEw                              ! specific enthalpy difference [J/kg]
+                                              
+            zfmdt         = - qlead_1d(ji) / zdE                   ! Fm.dt [kg/m2] (<0) 
+                                                                   ! clem: we use qlead instead of zqld (icethd) because we suppose we are at the freezing point   
+            zv_newice(ji) = - zfmdt * r1_rhoic
+
+            zQm           = zfmdt * zEw                            ! heat to the ocean >0 associated with mass flux  
+
+            ! Contribution to heat flux to the ocean [W.m-2], >0  
+            hfx_thd_1d(ji) = hfx_thd_1d(ji) + zfmdt * zEw * r1_rdtice
+            ! Total heat flux used in this process [W.m-2]  
+            hfx_opw_1d(ji) = hfx_opw_1d(ji) - zfmdt * zdE * r1_rdtice
+            ! mass flux
+            wfx_opw_1d(ji) = wfx_opw_1d(ji) - zv_newice(ji) * rhoic * r1_rdtice
+            ! salt flux
+            sfx_opw_1d(ji) = sfx_opw_1d(ji) - zv_newice(ji) * rhoic * zs_newice(ji) * r1_rdtice
+         END DO
+         
+         zv_frazb(1:npti) = 0._wp
+         IF( ln_frazil ) THEN
+            ! A fraction zfrazb of frazil ice is accreted at the ice bottom
+            DO ji = 1, npti
+               rswitch       = 1._wp - MAX( 0._wp, SIGN( 1._wp , - at_i_1d(ji) ) )
+               zfrazb        = rswitch * ( TANH( rn_Cfraz * ( zvrel_1d(ji) - rn_vfraz ) ) + 1.0 ) * 0.5 * rn_maxfraz
+               zv_frazb(ji)  =         zfrazb   * zv_newice(ji)
+               zv_newice(ji) = ( 1.0 - zfrazb ) * zv_newice(ji)
+            END DO
+         END IF
+         
+         !-----------------
+         ! Area of new ice
+         !-----------------
+         DO ji = 1, npti
+            za_newice(ji) = zv_newice(ji) / zh_newice(ji)
+         END DO
+
+         !------------------------------------------------------------------------------!
+         ! 6) Redistribute new ice area and volume into ice categories                  !
+         !------------------------------------------------------------------------------!
+
+         !------------------------
+         ! 6.1) lateral ice growth
+         !------------------------
+         ! If lateral ice growth gives an ice concentration gt 1, then
+         ! we keep the excessive volume in memory and attribute it later to bottom accretion
+         DO ji = 1, npti
+            IF ( za_newice(ji) >  ( rn_amax_1d(ji) - at_i_1d(ji) ) ) THEN
+               zda_res(ji)   = za_newice(ji) - ( rn_amax_1d(ji) - at_i_1d(ji) )
+               zdv_res(ji)   = zda_res  (ji) * zh_newice(ji) 
+               za_newice(ji) = za_newice(ji) - zda_res  (ji)
+               zv_newice(ji) = zv_newice(ji) - zdv_res  (ji)
+            ELSE
+               zda_res(ji) = 0._wp
+               zdv_res(ji) = 0._wp
+            ENDIF
+         END DO
+
+         ! find which category to fill
+         DO jl = 1, jpl
+            DO ji = 1, npti
+               IF( zh_newice(ji) > hi_max(jl-1) .AND. zh_newice(ji) <= hi_max(jl) ) THEN
+                  a_i_2d(ji,jl) = a_i_2d(ji,jl) + za_newice(ji)
+                  v_i_2d(ji,jl) = v_i_2d(ji,jl) + zv_newice(ji)
+                  jcat(ji) = jl
+               ENDIF
+            END DO
+         END DO
+         at_i_1d(1:npti) = SUM( a_i_2d(1:npti,:), dim=2 )
+
+         ! Heat content
+         DO ji = 1, npti
+            jl = jcat(ji)                                                    ! categroy in which new ice is put
+            zswinew  (ji) = MAX( 0._wp , SIGN( 1._wp , - za_b(ji,jl) ) )   ! 0 if old ice
+         END DO
+
+         DO jk = 1, nlay_i
+            DO ji = 1, npti
+               jl = jcat(ji)
+               rswitch = MAX( 0._wp, SIGN( 1._wp , v_i_2d(ji,jl) - epsi20 ) )
+               ze_i_2d(ji,jk,jl) = zswinew(ji)   *   ze_newice(ji) +                                                    &
+                  &        ( 1.0 - zswinew(ji) ) * ( ze_newice(ji) * zv_newice(ji) + ze_i_2d(ji,jk,jl) * zv_b(ji,jl) )  &
+                  &        * rswitch / MAX( v_i_2d(ji,jl), epsi20 )
+            END DO
+         END DO
+
+         !------------------------------------------------
+         ! 6.2) bottom ice growth + ice enthalpy remapping
+         !------------------------------------------------
+         DO jl = 1, jpl
+
+            ! for remapping
+            h_i_old (1:npti,0:nlay_i+1) = 0._wp
+            eh_i_old(1:npti,0:nlay_i+1) = 0._wp
+            DO jk = 1, nlay_i
+               DO ji = 1, npti
+                  h_i_old (ji,jk) = v_i_2d(ji,jl) * r1_nlay_i
+                  eh_i_old(ji,jk) = ze_i_2d(ji,jk,jl) * h_i_old(ji,jk)
+               END DO
+            END DO
+
+            ! new volumes including lateral/bottom accretion + residual
+            DO ji = 1, npti
+               rswitch        = MAX( 0._wp, SIGN( 1._wp , at_i_1d(ji) - epsi20 ) )
+               zv_newfra     = rswitch * ( zdv_res(ji) + zv_frazb(ji) ) * a_i_2d(ji,jl) / MAX( at_i_1d(ji) , epsi20 )
+               a_i_2d(ji,jl) = rswitch * a_i_2d(ji,jl)               
+               v_i_2d(ji,jl) = v_i_2d(ji,jl) + zv_newfra
+               ! for remapping
+               h_i_old (ji,nlay_i+1) = zv_newfra
+               eh_i_old(ji,nlay_i+1) = ze_newice(ji) * zv_newfra
+            END DO
+            ! --- Ice enthalpy remapping --- !
+            CALL ice_thd_ent( ze_i_2d(1:npti,:,jl) ) 
+         END DO
+
+         !-----------------
+         ! Update salinity
+         !-----------------
+         DO jl = 1, jpl
+            DO ji = 1, npti
+               sv_i_2d(ji,jl) = sv_i_2d(ji,jl) + zs_newice(ji) * ( v_i_2d(ji,jl) - zv_b(ji,jl) )
+            END DO
+         END DO
+
+         !------------------------------------------------------------------------------!
+         ! 8) Change units for e_i
+         !------------------------------------------------------------------------------!    
+         DO jl = 1, jpl
+            DO jk = 1, nlay_i
+               ze_i_2d(1:npti,jk,jl) = ze_i_2d(1:npti,jk,jl) * v_i_2d(1:npti,jl) * r1_nlay_i 
+            END DO
+         END DO
+         !------------------------------------------------------------------------------!
+         ! 7) Change 2D vectors to 1D vectors 
+         !------------------------------------------------------------------------------!
+         CALL tab_2d_3d( npti, nptidx(1:npti), a_i_2d (1:npti,1:jpl), a_i (:,:,:) )
+         CALL tab_2d_3d( npti, nptidx(1:npti), v_i_2d (1:npti,1:jpl), v_i (:,:,:) )
+         CALL tab_2d_3d( npti, nptidx(1:npti), sv_i_2d(1:npti,1:jpl), sv_i(:,:,:) )
+          DO jl = 1, jpl
+            DO jk = 1, nlay_i
+               CALL tab_1d_2d( npti, nptidx(1:npti), ze_i_2d(1:npti,jk,jl), e_i(:,:,jk,jl) )
+            END DO
+         END DO
+         CALL tab_1d_2d( npti, nptidx(1:npti), sfx_opw_1d(1:npti), sfx_opw )
+         CALL tab_1d_2d( npti, nptidx(1:npti), wfx_opw_1d(1:npti), wfx_opw )
+         CALL tab_1d_2d( npti, nptidx(1:npti), hfx_thd_1d(1:npti), hfx_thd )
+         CALL tab_1d_2d( npti, nptidx(1:npti), hfx_opw_1d(1:npti), hfx_opw )
+         !
+      ENDIF ! npti > 0
+      !
+      IF( ln_icediachk )   CALL ice_cons_hsm(1, 'icethd_do', rdiag_v, rdiag_s, rdiag_t, rdiag_fv, rdiag_fs, rdiag_ft)
+      !
+   END SUBROUTINE ice_thd_do
+
+
+   SUBROUTINE ice_thd_do_init
+      !!-----------------------------------------------------------------------
+      !!                   ***  ROUTINE ice_thd_do_init *** 
+      !!                 
+      !! ** Purpose :   Physical constants and parameters associated with
+      !!                ice growth in the leads
+      !!
+      !! ** Method  :   Read the namthd_do namelist and check the parameters
+      !!                called at the first timestep (nit000)
+      !!
+      !! ** input   :   Namelist namthd_do
+      !!-------------------------------------------------------------------
+      INTEGER  ::   ios   ! Local integer 
+      !!
+      NAMELIST/namthd_do/ rn_hinew, ln_frazil, rn_maxfraz, rn_vfraz, rn_Cfraz
+      !!-------------------------------------------------------------------
+      !
+      REWIND( numnam_ice_ref )              ! Namelist namthd_do in reference namelist : Ice thermodynamics
+      READ  ( numnam_ice_ref, namthd_do, IOSTAT = ios, ERR = 901)
+901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namthd_do in reference namelist', lwp )
+      REWIND( numnam_ice_cfg )              ! Namelist namthd_do in configuration namelist : Ice thermodynamics
+      READ  ( numnam_ice_cfg, namthd_do, IOSTAT = ios, ERR = 902 )
+902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namthd_do in configuration namelist', lwp )
+      IF(lwm) WRITE( numoni, namthd_do )
+      !
+      IF(lwp) THEN                          ! control print
+         WRITE(numout,*)
+         WRITE(numout,*) 'ice_thd_do_init: Ice growth in open water'
+         WRITE(numout,*) '~~~~~~~~~~~~~~~'
+         WRITE(numout,*) '   Namelist namthd_do:'
+         WRITE(numout,*) '      ice thickness for lateral accretion                       rn_hinew   = ', rn_hinew
+         WRITE(numout,*) '      Frazil ice thickness as a function of wind or not         ln_frazil  = ', ln_frazil
+         WRITE(numout,*) '      Maximum proportion of frazil ice collecting at bottom     rn_maxfraz = ', rn_maxfraz
+         WRITE(numout,*) '      Threshold relative drift speed for collection of frazil   rn_vfraz   = ', rn_vfraz
+         WRITE(numout,*) '      Squeezing coefficient for collection of frazil            rn_Cfraz   = ', rn_Cfraz
+      ENDIF
+      !
+      IF ( rn_hinew < rn_himin )   CALL ctl_stop( 'ice_thd_do_init : rn_hinew should be >= rn_himin' )
+      !
+   END SUBROUTINE ice_thd_do_init
+   
+#else
+   !!----------------------------------------------------------------------
+   !!   Default option                                NO SI3 sea-ice model
+   !!----------------------------------------------------------------------
+#endif
+
+   !!======================================================================
+END MODULE icethd_do
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/ICE_SRC/icethd_ent.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/ICE_SRC/icethd_ent.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/ICE_SRC/icethd_ent.F90	(revision 9570)
@@ -0,0 +1,146 @@
+MODULE icethd_ent
+   !!======================================================================
+   !!                       ***  MODULE icethd_ent   ***
+   !!   sea-ice: redistribution of enthalpy in the ice on the new vertical grid
+   !!                       after vertical growth/melt
+   !!======================================================================
+   !! History :  LIM  ! 2003-05 (M. Vancoppenolle) Original code in 1D
+   !!                 ! 2005-07 (M. Vancoppenolle) 3D version 
+   !!                 ! 2006-11 (X. Fettweis) Vectorized 
+   !!            3.0  ! 2008-03 (M. Vancoppenolle) Energy conservation and clean code
+   !!            3.4  ! 2011-02 (G. Madec) dynamical allocation
+   !!             -   ! 2014-05 (C. Rousset) complete rewriting
+   !!----------------------------------------------------------------------
+#if defined key_si3
+   !!----------------------------------------------------------------------
+   !!   'key_si3'                                       SI3 sea-ice model
+   !!----------------------------------------------------------------------
+   !!   ice_thd_ent   : ice redistribution of enthalpy
+   !!----------------------------------------------------------------------
+   USE dom_oce        ! domain variables
+   USE domain         !
+   USE phycst         ! physical constants
+   USE ice            ! sea-ice: variables
+   USE ice1D          ! sea-ice: thermodynamics variables
+   !
+   USE in_out_manager ! I/O manager
+   USE lib_mpp        ! MPP library
+   USE lib_fortran    ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined)  
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   ice_thd_ent         ! called by icethd and icethd_do
+
+   !!----------------------------------------------------------------------
+   !! NEMO/ICE 4.0 , NEMO Consortium (2017)
+   !! $Id: icethd_ent.F90 8420 2017-08-08 12:18:46Z clem $
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+ 
+   SUBROUTINE ice_thd_ent( qnew )
+      !!-------------------------------------------------------------------
+      !!               ***   ROUTINE ice_thd_ent  ***
+      !!
+      !! ** Purpose :
+      !!           This routine computes new vertical grids in the ice, 
+      !!           and consistently redistributes temperatures. 
+      !!           Redistribution is made so as to ensure to energy conservation
+      !!
+      !!
+      !! ** Method  : linear conservative remapping
+      !!           
+      !! ** Steps : 1) cumulative integrals of old enthalpies/thicknesses
+      !!            2) linear remapping on the new layers
+      !!
+      !! ------------ cum0(0)                        ------------- cum1(0)
+      !!                                    NEW      -------------
+      !! ------------ cum0(1)               ==>      -------------
+      !!     ...                                     -------------
+      !! ------------                                -------------
+      !! ------------ cum0(nlay_i+2)                 ------------- cum1(nlay_i)
+      !!
+      !!
+      !! References : Bitz & Lipscomb, JGR 99; Vancoppenolle et al., GRL, 2005
+      !!-------------------------------------------------------------------
+      REAL(wp), DIMENSION(:,:), INTENT(inout) ::   qnew             ! new enthlapies (J.m-3, remapped)
+      !
+      INTEGER  :: ji         !  dummy loop indices
+      INTEGER  :: jk0, jk1   !  old/new layer indices
+      !
+      REAL(wp), DIMENSION(jpij,0:nlay_i+2) ::   zeh_cum0, zh_cum0   ! old cumulative enthlapies and layers interfaces
+      REAL(wp), DIMENSION(jpij,0:nlay_i)   ::   zeh_cum1, zh_cum1   ! new cumulative enthlapies and layers interfaces
+      REAL(wp), DIMENSION(jpij)            ::   zhnew               ! new layers thicknesses
+      !!-------------------------------------------------------------------
+
+      !--------------------------------------------------------------------------
+      !  1) Cumulative integral of old enthalpy * thickness and layers interfaces
+      !--------------------------------------------------------------------------
+      zeh_cum0(1:npti,0) = 0._wp 
+      zh_cum0 (1:npti,0) = 0._wp
+      DO jk0 = 1, nlay_i+2
+         DO ji = 1, npti
+            zeh_cum0(ji,jk0) = zeh_cum0(ji,jk0-1) + eh_i_old(ji,jk0-1)
+            zh_cum0 (ji,jk0) = zh_cum0 (ji,jk0-1) + h_i_old (ji,jk0-1)
+         END DO
+      END DO
+
+      !------------------------------------
+      !  2) Interpolation on the new layers
+      !------------------------------------
+      ! new layer thickesses
+      DO ji = 1, npti
+         zhnew(ji) = SUM( h_i_old(ji,0:nlay_i+1) ) * r1_nlay_i  
+      END DO
+
+      ! new layers interfaces
+      zh_cum1(1:npti,0) = 0._wp
+      DO jk1 = 1, nlay_i
+         DO ji = 1, npti
+            zh_cum1(ji,jk1) = zh_cum1(ji,jk1-1) + zhnew(ji)
+         END DO
+      END DO
+
+      zeh_cum1(1:npti,0:nlay_i) = 0._wp 
+      ! new cumulative q*h => linear interpolation
+      DO jk0 = 1, nlay_i+1
+         DO jk1 = 1, nlay_i-1
+            DO ji = 1, npti
+               IF( zh_cum1(ji,jk1) <= zh_cum0(ji,jk0) .AND. zh_cum1(ji,jk1) > zh_cum0(ji,jk0-1) ) THEN
+                  zeh_cum1(ji,jk1) = ( zeh_cum0(ji,jk0-1) * ( zh_cum0(ji,jk0) - zh_cum1(ji,jk1  ) ) +  &
+                     &                 zeh_cum0(ji,jk0  ) * ( zh_cum1(ji,jk1) - zh_cum0(ji,jk0-1) ) )  &
+                     &             / ( zh_cum0(ji,jk0) - zh_cum0(ji,jk0-1) )
+               ENDIF
+            END DO
+         END DO
+      END DO
+      ! to ensure that total heat content is strictly conserved, set:
+      zeh_cum1(1:npti,nlay_i) = zeh_cum0(1:npti,nlay_i+2) 
+
+      ! new enthalpies
+      DO jk1 = 1, nlay_i
+         DO ji = 1, npti
+            rswitch      = MAX( 0._wp , SIGN( 1._wp , zhnew(ji) - epsi20 ) ) 
+            qnew(ji,jk1) = rswitch * ( zeh_cum1(ji,jk1) - zeh_cum1(ji,jk1-1) ) / MAX( zhnew(ji), epsi20 )
+         END DO
+      END DO
+
+      ! --- diag error on heat remapping --- !
+      ! comment: if input h_i_old and eh_i_old are already multiplied by a_i (as in icethd_do), 
+      ! then we should not (* a_i) again but not important since this is just to check that remap error is ~0
+      DO ji = 1, npti
+         hfx_err_rem_1d(ji) = hfx_err_rem_1d(ji) + a_i_1d(ji) * r1_rdtice *  &
+            &               ( SUM( qnew(ji,1:nlay_i) ) * zhnew(ji) - SUM( eh_i_old(ji,0:nlay_i+1) ) ) 
+      END DO
+      
+   END SUBROUTINE ice_thd_ent
+
+#else
+   !!----------------------------------------------------------------------
+   !!   Default option                                NO SI3 sea-ice model
+   !!----------------------------------------------------------------------
+#endif
+
+   !!======================================================================
+END MODULE icethd_ent
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/ICE_SRC/icethd_pnd.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/ICE_SRC/icethd_pnd.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/ICE_SRC/icethd_pnd.F90	(revision 9570)
@@ -0,0 +1,256 @@
+MODULE icethd_pnd 
+   !!======================================================================
+   !!                     ***  MODULE  icethd_pnd   ***
+   !!   Melt ponds
+   !!======================================================================
+   !! history :       ! Original code by Daniela Flocco and Adrian Turner
+   !!            1.0  ! 2012    (O. Lecomte) Adaptation for scientific tests (NEMO3.1)
+   !!            2.0  ! 2017    (M. Vancoppenolle, O. Lecomte, C. Rousset) Implementation in NEMO4
+   !!----------------------------------------------------------------------
+#if defined key_si3
+   !!----------------------------------------------------------------------
+   !!   'key_si3' :                                     SI3 sea-ice model
+   !!----------------------------------------------------------------------
+   !!   ice_thd_pnd_init : some initialization and namelist read
+   !!   ice_thd_pnd      : main calling routine
+   !!----------------------------------------------------------------------
+   USE phycst         ! physical constants
+   USE dom_oce        ! ocean space and time domain
+   USE ice            ! sea-ice: variables
+   USE ice1D          ! sea-ice: thermodynamics variables
+   USE icetab         ! sea-ice: 1D <==> 2D transformation
+   !
+   USE in_out_manager ! I/O manager
+   USE lib_mpp        ! MPP library
+   USE lib_fortran    ! fortran utilities (glob_sum + no signed zero)
+   USE timing         ! Timing
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   ice_thd_pnd_init    ! routine called by icestp.F90
+   PUBLIC   ice_thd_pnd         ! routine called by icestp.F90
+
+   INTEGER ::              nice_pnd    ! choice of the type of pond scheme
+   !                                   ! associated indices:
+   INTEGER, PARAMETER ::   np_pndNO  = 0   ! No pond scheme
+   INTEGER, PARAMETER ::   np_pndCST = 1   ! Constant pond scheme
+   INTEGER, PARAMETER ::   np_pndH12 = 2   ! Evolutive pond scheme (Holland et al. 2012)
+
+   !! * Substitutions
+#  include "vectopt_loop_substitute.h90"
+   !!----------------------------------------------------------------------
+   !! NEMO/ICE 4.0 , NEMO Consortium (2017)
+   !! $Id: icethd_pnd.F90 8420 2017-10-05 13:07:10Z clem $
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE ice_thd_pnd
+      !!-------------------------------------------------------------------
+      !!               ***  ROUTINE ice_thd_pnd   ***
+      !!               
+      !! ** Purpose :   change melt pond fraction
+      !!                
+      !! ** Method  :   brut force
+      !!-------------------------------------------------------------------
+      !
+      SELECT CASE ( nice_pnd )
+      !
+      CASE (np_pndCST)   ;   CALL pnd_CST    !==  Constant melt ponds  ==!
+         !
+      CASE (np_pndH12)   ;   CALL pnd_H12    !==  Holland et al 2012 melt ponds  ==!
+         !
+      END SELECT
+      !
+   END SUBROUTINE ice_thd_pnd 
+
+
+   SUBROUTINE pnd_CST 
+      !!-------------------------------------------------------------------
+      !!                ***  ROUTINE pnd_CST  ***
+      !!
+      !! ** Purpose :   Compute melt pond evolution
+      !!
+      !! ** Method  :   Melt pond fraction and thickness are prescribed 
+      !!              to non-zero values when t_su = 0C
+      !!
+      !! ** Tunable parameters : pond fraction (rn_apnd), pond depth (rn_hpnd)
+      !!                
+      !! ** Note   : Coupling with such melt ponds is only radiative
+      !!         Advection, ridging, rafting... are bypassed
+      !!
+      !! ** References : Bush, G.W., and Trump, D.J. (2017)
+      !!-------------------------------------------------------------------
+      INTEGER  ::   ji        ! loop indices
+      !!-------------------------------------------------------------------
+      DO ji = 1, npti
+         !
+         IF( a_i_1d(ji) > 0._wp .AND. t_su_1d(ji) >= rt0 ) THEN
+            a_ip_frac_1d(ji) = rn_apnd
+            h_ip_1d(ji)      = rn_hpnd    
+            a_ip_1d(ji)      = a_ip_frac_1d(ji) * a_i_1d(ji)
+         ELSE
+            a_ip_frac_1d(ji) = 0._wp
+            h_ip_1d(ji)      = 0._wp    
+            a_ip_1d(ji)      = 0._wp
+         ENDIF
+         !
+      END DO
+      !
+   END SUBROUTINE pnd_CST
+
+
+   SUBROUTINE pnd_H12
+      !!-------------------------------------------------------------------
+      !!                ***  ROUTINE pnd_H12  ***
+      !!
+      !! ** Purpose    : Compute melt pond evolution
+      !!
+      !! ** Method     : Empirical method. A fraction of meltwater is accumulated in ponds 
+      !!                 and sent to ocean when surface is freezing
+      !!
+      !!                 pond growth:      Vp = Vp + dVmelt
+      !!                    with dVmelt = R/rhow * ( rhoi*dh_i + rhos*dh_s ) * a_i
+      !!                 pond contraction: Vp = Vp * exp(0.01*MAX(Tp-Tsu,0)/Tp)
+      !!                    with Tp = -2degC
+      !!  
+      !! ** Tunable parameters : (no real expertise yet, ideas?)
+      !! 
+      !! ** Note       : Stolen from CICE for quick test of the melt pond
+      !!                 radiation and freshwater interfaces
+      !!                 Coupling can be radiative AND freshwater
+      !!                 Advection, ridging, rafting are called
+      !!
+      !! ** References : Holland, M. M. et al (J Clim 2012)
+      !!-------------------------------------------------------------------
+      REAL(wp), PARAMETER ::   zrmin       = 0.15_wp  ! minimum fraction of available meltwater retained for melt ponding
+      REAL(wp), PARAMETER ::   zrmax       = 0.70_wp  ! maximum     -           -         -         -            -
+      REAL(wp), PARAMETER ::   zpnd_aspect = 0.8_wp   ! pond aspect ratio
+      REAL(wp), PARAMETER ::   zTp         = -2._wp   ! reference temperature
+      !
+      REAL(wp) ::   zfr_mlt          ! fraction of available meltwater retained for melt ponding
+      REAL(wp) ::   zdv_mlt          ! available meltwater for melt ponding
+      REAL(wp) ::   z1_Tp            ! inverse reference temperature
+      REAL(wp) ::   z1_rhofw         ! inverse freshwater density
+      REAL(wp) ::   z1_zpnd_aspect   ! inverse pond aspect ratio
+      REAL(wp) ::   zfac, zdum
+      !
+      INTEGER  ::   ji   ! loop indices
+      !!-------------------------------------------------------------------
+      z1_rhofw       = 1._wp / rhofw 
+      z1_zpnd_aspect = 1._wp / zpnd_aspect
+      z1_Tp          = 1._wp / zTp 
+
+      DO ji = 1, npti
+         !                                                        !--------------------------------!
+         IF( h_i_1d(ji) < rn_himin) THEN                          ! Case ice thickness < rn_himin  !
+            !                                                     !--------------------------------!
+            !--- Remove ponds on thin ice
+            a_ip_1d(ji)      = 0._wp
+            a_ip_frac_1d(ji) = 0._wp
+            h_ip_1d(ji)      = 0._wp
+            !                                                     !--------------------------------!
+         ELSE                                                     ! Case ice thickness >= rn_himin !
+            !                                                     !--------------------------------!
+            v_ip_1d(ji) = h_ip_1d(ji) * a_ip_1d(ji)   ! record pond volume at previous time step
+            !
+            ! available meltwater for melt ponding [m, >0] and fraction
+            zdv_mlt = -( dh_i_surf(ji)*rhoic + dh_s_mlt(ji)*rhosn ) * z1_rhofw * a_i_1d(ji)
+            zfr_mlt = zrmin + ( zrmax - zrmin ) * a_i_1d(ji)  ! from CICE doc
+            !zfr_mlt = zrmin + zrmax * a_i_1d(ji)             ! from Holland paper 
+            !
+            !--- Pond gowth ---!
+            ! v_ip should never be negative, otherwise code crashes
+            ! MV: as far as I saw, UM5 can create very small negative v_ip values (not Prather)
+            v_ip_1d(ji) = MAX( 0._wp, v_ip_1d(ji) + zfr_mlt * zdv_mlt )
+            !
+            ! melt pond mass flux (<0)
+            IF( ln_pnd_fwb .AND. zdv_mlt > 0._wp ) THEN
+               zfac = zfr_mlt * zdv_mlt * rhofw * r1_rdtice
+               wfx_pnd_1d(ji) = wfx_pnd_1d(ji) - zfac
+               !
+               ! adjust ice/snow melting flux to balance melt pond flux (>0)
+               zdum = zfac / ( wfx_snw_sum_1d(ji) + wfx_sum_1d(ji) )
+               wfx_snw_sum_1d(ji) = wfx_snw_sum_1d(ji) * (1._wp + zdum)
+               wfx_sum_1d(ji)     = wfx_sum_1d(ji)     * (1._wp + zdum)
+            ENDIF
+            !
+            !--- Pond contraction (due to refreezing) ---!
+            v_ip_1d(ji) = v_ip_1d(ji) * EXP( 0.01_wp * MAX( zTp+rt0 - t_su_1d(ji), 0._wp ) * z1_Tp )
+            !
+            ! Set new pond area and depth assuming linear relation between h_ip and a_ip_frac
+            !    h_ip = zpnd_aspect * a_ip_frac = zpnd_aspect * a_ip/a_i
+            a_ip_1d(ji)      = SQRT( v_ip_1d(ji) * z1_zpnd_aspect * a_i_1d(ji) )
+            a_ip_frac_1d(ji) = a_ip_1d(ji) / a_i_1d(ji)
+            h_ip_1d(ji)      = zpnd_aspect * a_ip_frac_1d(ji)
+            !
+         ENDIF
+      END DO
+      !
+   END SUBROUTINE pnd_H12
+
+
+   SUBROUTINE ice_thd_pnd_init 
+      !!-------------------------------------------------------------------
+      !!                  ***  ROUTINE ice_thd_pnd_init   ***
+      !!
+      !! ** Purpose : Physical constants and parameters linked to melt ponds
+      !!              over sea ice
+      !!
+      !! ** Method  :  Read the namthd_pnd  namelist and check the melt pond  
+      !!               parameter values called at the first timestep (nit000)
+      !!
+      !! ** input   :   Namelist namthd_pnd  
+      !!-------------------------------------------------------------------
+      INTEGER  ::   ios, ioptio   ! Local integer
+      !!
+      NAMELIST/namthd_pnd/  ln_pnd_H12, ln_pnd_fwb, ln_pnd_CST, rn_apnd, rn_hpnd, ln_pnd_alb
+      !!-------------------------------------------------------------------
+      !
+      REWIND( numnam_ice_ref )              ! Namelist namthd_pnd  in reference namelist : Melt Ponds  
+      READ  ( numnam_ice_ref, namthd_pnd, IOSTAT = ios, ERR = 901)
+901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namthd_pnd  in reference namelist', lwp )
+      REWIND( numnam_ice_cfg )              ! Namelist namthd_pnd  in configuration namelist : Melt Ponds
+      READ  ( numnam_ice_cfg, namthd_pnd, IOSTAT = ios, ERR = 902 )
+902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namthd_pnd in configuration namelist', lwp )
+      IF(lwm) WRITE ( numoni, namthd_pnd )
+      !
+      IF(lwp) THEN                        ! control print
+         WRITE(numout,*)
+         WRITE(numout,*) 'ice_thd_pnd_init: ice parameters for melt ponds'
+         WRITE(numout,*) '~~~~~~~~~~~~~~~~'
+         WRITE(numout,*) '   Namelist namicethd_pnd:'
+         WRITE(numout,*) '      Evolutive melt pond fraction and depth (Holland et al 2012)  ln_pnd_H12 = ', ln_pnd_H12
+         WRITE(numout,*) '         Melt ponds store fresh water or not                       ln_pnd_fwb = ', ln_pnd_fwb
+         WRITE(numout,*) '      Prescribed melt pond fraction and depth                      ln_pnd_Cst = ', ln_pnd_CST
+         WRITE(numout,*) '         Prescribed pond fraction                                  rn_apnd    = ', rn_apnd
+         WRITE(numout,*) '         Prescribed pond depth                                     rn_hpnd    = ', rn_hpnd
+         WRITE(numout,*) '      Melt ponds affect albedo or not                              ln_pnd_alb = ', ln_pnd_alb
+      ENDIF
+      !
+      !                             !== set the choice of ice pond scheme ==!
+      ioptio = 0
+                                                            nice_pnd = np_pndNO
+      IF( ln_pnd_CST ) THEN   ;   ioptio = ioptio + 1   ;   nice_pnd = np_pndCST    ;   ENDIF
+      IF( ln_pnd_H12 ) THEN   ;   ioptio = ioptio + 1   ;   nice_pnd = np_pndH12    ;   ENDIF
+      IF( ioptio > 1 )   CALL ctl_stop( 'ice_thd_pnd_init: choose one and only one pond scheme (ln_pnd_H12 or ln_pnd_CST)' )
+      !
+      SELECT CASE( nice_pnd )
+      CASE( np_pndNO )         
+         IF(ln_pnd_fwb) THEN ; ln_pnd_fwb = .FALSE. ; CALL ctl_warn( 'ln_pnd_fwb=false when no ponds' ) ; ENDIF
+         IF(ln_pnd_alb) THEN ; ln_pnd_alb = .FALSE. ; CALL ctl_warn( 'ln_pnd_alb=false when no ponds' ) ; ENDIF
+      CASE( np_pndCST)
+         IF(ln_pnd_fwb) THEN ; ln_pnd_fwb = .FALSE. ; CALL ctl_warn( 'ln_pnd_fwb=false when ln_pnd_CST=true' ) ; ENDIF
+      END SELECT
+      !
+   END SUBROUTINE ice_thd_pnd_init
+   
+#else
+   !!----------------------------------------------------------------------
+   !!   Default option          Empty module          NO SI3 sea-ice model
+   !!----------------------------------------------------------------------
+#endif 
+
+   !!======================================================================
+END MODULE icethd_pnd 
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/ICE_SRC/icethd_sal.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/ICE_SRC/icethd_sal.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/ICE_SRC/icethd_sal.F90	(revision 9570)
@@ -0,0 +1,166 @@
+MODULE icethd_sal
+   !!======================================================================
+   !!                       ***  MODULE icethd_sal ***
+   !!   sea-ice : computation of salinity variations in the ice
+   !!======================================================================
+   !! History :   -   ! 2003-05 (M. Vancoppenolle) UCL-ASTR first coding for LIM3-1D
+   !!            3.0  ! 2005-12 (M. Vancoppenolle) adapted to the 3-D version
+   !!            4.0  ! 2011-02 (G. Madec) dynamical allocation
+   !!---------------------------------------------------------------------
+#if defined key_si3
+   !!----------------------------------------------------------------------
+   !!   'key_si3'                                       SI3 sea-ice model
+   !!----------------------------------------------------------------------
+   !!   ice_thd_sal      : salinity variations in the ice
+   !!   ice_thd_sal_init : initialization
+   !!----------------------------------------------------------------------
+   USE dom_oce        ! ocean space and time domain
+   USE phycst         ! physical constants
+   USE ice            ! sea-ice: variables
+   USE ice1D          ! sea-ice: thermodynamics variables
+   USE icevar         ! sea-ice: operations
+   !
+   USE in_out_manager ! I/O manager
+   USE lib_mpp        ! MPP library
+   USE lib_fortran    ! fortran utilities (glob_sum + no signed zero)
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   ice_thd_sal        ! called by icethd
+   PUBLIC   ice_thd_sal_init   ! called by ice_init
+   
+   ! ** namelist (namthd_sal) **
+   REAL(wp) ::   rn_sal_gd     ! restoring salinity for gravity drainage [PSU]
+   REAL(wp) ::   rn_time_gd    ! restoring time constant for gravity drainage (= 20 days) [s]
+   REAL(wp) ::   rn_sal_fl     ! restoring salinity for flushing [PSU]
+   REAL(wp) ::   rn_time_fl    ! restoring time constant for gravity drainage (= 10 days) [s]
+
+   !!----------------------------------------------------------------------
+   !! NEMO/ICE 4.0 , NEMO Consortium (2017)
+   !! $Id: icethd_sal.F90 8420 2017-08-08 12:18:46Z clem $
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE ice_thd_sal( ld_sal )
+      !!-------------------------------------------------------------------
+      !!                ***  ROUTINE ice_thd_sal  ***    
+      !!   
+      !! ** Purpose :   computes new salinities in the ice
+      !!
+      !! ** Method  :  3 possibilities
+      !!               -> nn_icesal = 1 -> Sice = cst    [ice salinity constant in both time & space] 
+      !!               -> nn_icesal = 2 -> Sice = S(z,t) [Vancoppenolle et al. 2005]
+      !!               -> nn_icesal = 3 -> Sice = S(z)   [multiyear ice]
+      !!---------------------------------------------------------------------
+      LOGICAL, INTENT(in) ::   ld_sal            ! gravity drainage and flushing or not 
+      !
+      INTEGER  ::   ji, jk                       ! dummy loop indices 
+      REAL(wp) ::   iflush, igravdr              ! local scalars
+      REAL(wp) ::   zs_sni, zs_i_gd, zs_i_fl, zs_i_si, zs_i_bg   ! local scalars
+      REAL(wp) ::   z1_time_gd, z1_time_fl
+      !!---------------------------------------------------------------------
+
+      SELECT CASE ( nn_icesal )
+      !
+      !               !---------------------------------------------!
+      CASE( 2 )       !  time varying salinity with linear profile  !
+         !            !---------------------------------------------!
+         z1_time_gd = 1._wp / rn_time_gd * rdt_ice
+         z1_time_fl = 1._wp / rn_time_fl * rdt_ice
+         !
+         DO ji = 1, npti
+            !
+            !---------------------------------------------------------
+            !  Update ice salinity from snow-ice and bottom growth
+            !---------------------------------------------------------
+            IF( h_i_1d(ji) > 0._wp ) THEN
+               zs_sni   = sss_1d(ji) * ( rhoic - rhosn ) * r1_rhoic                                 ! Salinity of snow ice
+               zs_i_si = ( zs_sni      - s_i_1d(ji) ) *             dh_snowice(ji)  / h_i_1d(ji) ! snow-ice    
+               zs_i_bg = ( s_i_new(ji) - s_i_1d(ji) ) * MAX( 0._wp, dh_i_bott(ji) ) / h_i_1d(ji) ! bottom growth
+               ! Update salinity (nb: salt flux already included in icethd_dh)
+               s_i_1d(ji) = s_i_1d(ji) + zs_i_bg + zs_i_si
+            ENDIF
+            !
+            IF( ld_sal ) THEN
+               !---------------------------------------------------------
+               !  Update ice salinity from brine drainage and flushing
+               !---------------------------------------------------------
+               iflush   = MAX( 0._wp , SIGN( 1._wp , t_su_1d(ji) - rt0         ) )  ! =1 if summer 
+               igravdr  = MAX( 0._wp , SIGN( 1._wp , t_bo_1d(ji) - t_su_1d(ji) ) )  ! =1 if t_su < t_bo
+
+               zs_i_gd = - igravdr * MAX( s_i_1d(ji) - rn_sal_gd , 0._wp ) * z1_time_gd  ! gravity drainage 
+               zs_i_fl = - iflush  * MAX( s_i_1d(ji) - rn_sal_fl , 0._wp ) * z1_time_fl  ! flushing
+               
+               ! Update salinity   
+               s_i_1d(ji) = s_i_1d(ji) + zs_i_fl + zs_i_gd
+               
+               ! Salt flux
+               sfx_bri_1d(ji) = sfx_bri_1d(ji) - rhoic * a_i_1d(ji) * h_i_1d(ji) * ( zs_i_fl + zs_i_gd ) * r1_rdtice
+            ENDIF
+         END DO
+         !
+         ! Salinity profile
+         CALL ice_var_salprof1d
+         !
+         !             !----------------------------------------!
+      CASE( 3 )        ! constant salinity with a fixed profile ! (Schwarzacher (1959) multiyear salinity profile (mean = 2.30)
+         !             !----------------------------------------!
+         CALL ice_var_salprof1d
+         !
+      END SELECT
+      !
+   END SUBROUTINE ice_thd_sal
+
+
+   SUBROUTINE ice_thd_sal_init
+      !!-------------------------------------------------------------------
+      !!                  ***  ROUTINE ice_thd_sal_init  ***
+      !!
+      !! ** Purpose :   initialization of ice salinity parameters
+      !!
+      !! ** Method  :   Read the namthd_sal namelist and check the parameter
+      !!                values called at the first timestep (nit000)
+      !!
+      !! ** input   :   Namelist namthd_sal
+      !!-------------------------------------------------------------------
+      INTEGER  ::   ios   ! Local integer
+      !!
+      NAMELIST/namthd_sal/ nn_icesal, rn_icesal, rn_sal_gd, rn_time_gd,   &
+         &                 rn_sal_fl, rn_time_fl, rn_simax , rn_simin 
+      !!-------------------------------------------------------------------
+      !
+      REWIND( numnam_ice_ref )              ! Namelist namthd_sal in reference namelist : Ice salinity
+      READ  ( numnam_ice_ref, namthd_sal, IOSTAT = ios, ERR = 901)
+901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namthd_sal in reference namelist', lwp )
+      REWIND( numnam_ice_cfg )              ! Namelist namthd_sal in configuration namelist : Ice salinity
+      READ  ( numnam_ice_cfg, namthd_sal, IOSTAT = ios, ERR = 902 )
+902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namthd_sal in configuration namelist', lwp )
+      IF(lwm) WRITE ( numoni, namthd_sal )
+      !
+      IF(lwp) THEN                           ! control print
+         WRITE(numout,*)
+         WRITE(numout,*) 'ice_thd_sal_init : Ice parameters for salinity '
+         WRITE(numout,*) '~~~~~~~~~~~~~~~~'
+         WRITE(numout,*) '   Namelist namthd_sal:'
+         WRITE(numout,*) '      switch for salinity                                     nn_icesal  = ', nn_icesal
+         WRITE(numout,*) '      bulk salinity value if nn_icesal = 1                    rn_icesal  = ', rn_icesal
+         WRITE(numout,*) '      restoring salinity for gravity drainage                 rn_sal_gd  = ', rn_sal_gd
+         WRITE(numout,*) '      restoring time for for gravity drainage                 rn_time_gd = ', rn_time_gd
+         WRITE(numout,*) '      restoring salinity for flushing                         rn_sal_fl  = ', rn_sal_fl
+         WRITE(numout,*) '      restoring time for flushing                             rn_time_fl = ', rn_time_fl
+         WRITE(numout,*) '      Maximum tolerated ice salinity                          rn_simax   = ', rn_simax
+         WRITE(numout,*) '      Minimum tolerated ice salinity                          rn_simin   = ', rn_simin
+      ENDIF
+      !
+   END SUBROUTINE ice_thd_sal_init
+
+#else
+   !!----------------------------------------------------------------------
+   !!   Default option         Dummy Module           No SI3 sea-ice model
+   !!----------------------------------------------------------------------
+#endif
+
+   !!======================================================================
+END MODULE icethd_sal
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/ICE_SRC/icethd_zdf.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/ICE_SRC/icethd_zdf.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/ICE_SRC/icethd_zdf.F90	(revision 9570)
@@ -0,0 +1,138 @@
+MODULE icethd_zdf
+   !!======================================================================
+   !!                       ***  MODULE icethd_zdf ***
+   !!   sea-ice: vertical heat diffusion in sea ice (computation of temperatures) 
+   !!======================================================================
+   !! History :  LIM  ! 02-2003 (M. Vancoppenolle) original 1D code
+   !!                 ! 06-2005 (M. Vancoppenolle) 3d version
+   !!                 ! 11-2006 (X Fettweis) Vectorization by Xavier
+   !!                 ! 04-2007 (M. Vancoppenolle) Energy conservation
+   !!            4.0  ! 2011-02 (G. Madec) dynamical allocation
+   !!             -   ! 2012-05 (C. Rousset) add penetration solar flux
+   !!----------------------------------------------------------------------
+#if defined key_si3
+   !!----------------------------------------------------------------------
+   !!   'key_si3'                                       SI3 sea-ice model
+   !!----------------------------------------------------------------------
+   !!  ice_thd_zdf      : select the appropriate routine for vertical heat diffusion calculation
+   !!  ice_thd_zdf_BL99 : 
+   !!  ice_thd_zdf_init :
+   !!----------------------------------------------------------------------
+   USE dom_oce         ! ocean space and time domain
+   USE phycst          ! physical constants (ocean directory) 
+   USE ice             ! sea-ice: variables
+   USE icethd_zdf_BL99 ! sea-ice: vertical diffusion (Bitz and Lipscomb, 1999) 
+   !
+   USE in_out_manager  ! I/O manager
+   USE lib_mpp         ! MPP library
+   USE lib_fortran     ! fortran utilities (glob_sum + no signed zero)
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   ice_thd_zdf        ! called by icethd
+   PUBLIC   ice_thd_zdf_init   ! called by icestp
+
+   INTEGER ::   nice_zdf       ! Choice of the type of vertical heat diffusion formulation
+   !                                 ! associated indices:
+   INTEGER, PARAMETER ::   np_BL99 = 1   ! Bitz and Lipscomb (1999)
+!! INTEGER, PARAMETER ::   np_XXXX = 2
+
+   !!** namelist (namthd_zdf) **
+   LOGICAL ::   ln_zdf_BL99    ! Heat diffusion follows Bitz and Lipscomb (1999)
+
+   !!----------------------------------------------------------------------
+   !! NEMO/ICE 4.0 , NEMO Consortium (2017)
+   !! $Id: icethd_zdf.F90 8420 2017-08-08 12:18:46Z clem $
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE ice_thd_zdf
+      !!-------------------------------------------------------------------
+      !!                ***  ROUTINE ice_thd_zdf  ***
+      !!
+      !! ** Purpose :   select the appropriate routine for the computation
+      !!              of vertical diffusion
+      !!-------------------------------------------------------------------
+      !
+      SELECT CASE ( nice_zdf )      ! Choose the vertical heat diffusion solver
+      !
+      !                             !-------------!      
+      CASE( np_BL99 )               ! BL99 solver !
+         !                          !-------------!
+         SELECT CASE( nice_jules )
+         !                         ! No Jules coupler ==> default option
+         CASE( np_jules_OFF    )   ;   CALL ice_thd_zdf_BL99 ( np_jules_OFF    )
+         !
+         !                         ! Jules coupler is emulated => 1st call to get the needed fields (conduction...)
+         !                                                        2nd call to use these fields to calculate heat diffusion   
+         CASE( np_jules_EMULE  )   ;   CALL ice_thd_zdf_BL99 ( np_jules_EMULE  )
+                                       CALL ice_thd_zdf_BL99 ( np_jules_ACTIVE )
+         !
+         !                         ! Jules coupler is active ==> Met Office default option
+         CASE( np_jules_ACTIVE )   ;   CALL ice_thd_zdf_BL99 ( np_jules_ACTIVE )
+         !
+         END SELECT
+         !
+      END SELECT
+      !
+   END SUBROUTINE ice_thd_zdf
+   
+   
+   SUBROUTINE ice_thd_zdf_init
+      !!-----------------------------------------------------------------------
+      !!                   ***  ROUTINE ice_thd_zdf_init *** 
+      !!                 
+      !! ** Purpose :   Physical constants and parameters associated with
+      !!                ice thermodynamics
+      !!
+      !! ** Method  :   Read the namthd_zdf namelist and check the parameters
+      !!                called at the first timestep (nit000)
+      !!
+      !! ** input   :   Namelist namthd_zdf
+      !!-------------------------------------------------------------------
+      INTEGER  ::   ios, ioptio   ! Local integer
+      !!
+      NAMELIST/namthd_zdf/ ln_zdf_BL99, ln_cndi_U64, ln_cndi_P07, rn_cnd_s, rn_kappa_i
+      !!-------------------------------------------------------------------
+      !
+      REWIND( numnam_ice_ref )              ! Namelist namthd_zdf in reference namelist : Ice thermodynamics
+      READ  ( numnam_ice_ref, namthd_zdf, IOSTAT = ios, ERR = 901)
+901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namthd_zdf in reference namelist', lwp )
+      REWIND( numnam_ice_cfg )              ! Namelist namthd_zdf in configuration namelist : Ice thermodynamics
+      READ  ( numnam_ice_cfg, namthd_zdf, IOSTAT = ios, ERR = 902 )
+902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namthd_zdf in configuration namelist', lwp )
+      IF(lwm) WRITE( numoni, namthd_zdf )
+      !
+      IF(lwp) THEN                          ! control print
+         WRITE(numout,*)
+         WRITE(numout,*) 'ice_thd_zdf_init: Ice vertical heat diffusion'
+         WRITE(numout,*) '~~~~~~~~~~~~~~~~'
+         WRITE(numout,*) '   Namelist namthd_zdf:'
+         WRITE(numout,*) '      Bitz and Lipscomb (1999) formulation                    ln_zdf_BL99  = ', ln_zdf_BL99
+         WRITE(numout,*) '      thermal conductivity in the ice (Untersteiner 1964)     ln_cndi_U64  = ', ln_cndi_U64
+         WRITE(numout,*) '      thermal conductivity in the ice (Pringle et al 2007)    ln_cndi_P07  = ', ln_cndi_P07
+         WRITE(numout,*) '      thermal conductivity in the snow                        rn_cnd_s     = ', rn_cnd_s
+         WRITE(numout,*) '      extinction radiation parameter in sea ice               rn_kappa_i   = ', rn_kappa_i
+      ENDIF
+      !
+      IF ( ( ln_cndi_U64 .AND. ln_cndi_P07 ) .OR. ( .NOT. ln_cndi_U64 .AND. .NOT. ln_cndi_P07 ) ) THEN
+         CALL ctl_stop( 'ice_thd_zdf_init: choose 1 and only 1 formulation for thermal conduction (ln_cndi_U64 or ln_cndi_P07)' )
+      ENDIF
+      !                             !== set the choice of ice vertical thermodynamic formulation ==!
+      ioptio = 0 
+      IF( ln_zdf_BL99 ) THEN   ;   ioptio = ioptio + 1   ;   nice_zdf = np_BL99   ;   ENDIF   ! BL99 thermodynamics (linear liquidus + constant thermal properties)
+!!    IF( ln_zdf_XXXX ) THEN   ;   ioptio = ioptio + 1   ;   nice_zdf = np_XXXX   ;   ENDIF
+      IF( ioptio /= 1 )   CALL ctl_stop( 'ice_thd_init: one and only one ice thermo option has to be defined ' )
+      !
+   END SUBROUTINE ice_thd_zdf_init
+
+#else
+   !!----------------------------------------------------------------------
+   !!   Default option       Dummy Module             No SI3 sea-ice model
+   !!----------------------------------------------------------------------
+#endif
+
+   !!======================================================================
+END MODULE icethd_zdf
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/ICE_SRC/icethd_zdf_bl99.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/ICE_SRC/icethd_zdf_bl99.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/ICE_SRC/icethd_zdf_bl99.F90	(revision 9570)
@@ -0,0 +1,847 @@
+MODULE icethd_zdf_BL99
+   !!======================================================================
+   !!                       ***  MODULE icethd_zdf_BL99 ***
+   !!   sea-ice: vertical heat diffusion in sea ice (computation of temperatures) 
+   !!======================================================================
+   !! History :  LIM  ! 02-2003 (M. Vancoppenolle) original 1D code
+   !!                 ! 06-2005 (M. Vancoppenolle) 3d version
+   !!                 ! 11-2006 (X Fettweis) Vectorization by Xavier
+   !!                 ! 04-2007 (M. Vancoppenolle) Energy conservation
+   !!            4.0  ! 2011-02 (G. Madec) dynamical allocation
+   !!             -   ! 2012-05 (C. Rousset) add penetration solar flux
+   !!----------------------------------------------------------------------
+#if defined key_si3
+   !!----------------------------------------------------------------------
+   !!   'key_si3'                                       SI3 sea-ice model
+   !!----------------------------------------------------------------------
+   !!  ice_thd_zdf_BL99 : vertical diffusion computation
+   !!----------------------------------------------------------------------
+   USE dom_oce        ! ocean space and time domain
+   USE phycst         ! physical constants (ocean directory) 
+   USE ice            ! sea-ice: variables
+   USE ice1D          ! sea-ice: thermodynamics variables
+   USE icevar         ! sea-ice: operations
+   !
+   USE in_out_manager ! I/O manager
+   USE lib_mpp        ! MPP library
+   USE lib_fortran    ! fortran utilities (glob_sum + no signed zero)
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   ice_thd_zdf_BL99   ! called by icethd_zdf
+
+   !!----------------------------------------------------------------------
+   !! NEMO/ICE 4.0 , NEMO Consortium (2017)
+   !! $Id: icethd_zdf.F90 8420 2017-08-08 12:18:46Z clem $
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE ice_thd_zdf_BL99( k_jules )
+      !!-------------------------------------------------------------------
+      !!                ***  ROUTINE ice_thd_zdf_BL99  ***
+      !!
+      !! ** Purpose : computes the time evolution of snow and sea-ice temperature
+      !!              profiles, using the original Bitz and Lipscomb (1999) algorithm
+      !!
+      !! ** Method  : solves the heat equation diffusion with a Neumann boundary
+      !!              condition at the surface and a Dirichlet one at the bottom. 
+      !!              Solar radiation is partially absorbed into the ice.
+      !!              The specific heat and thermal conductivities depend on ice 
+      !!              salinity and temperature to take into account brine pocket   
+      !!              melting. The numerical scheme is an iterative Crank-Nicolson
+      !!              on a non-uniform multilayer grid in the ice and snow system.
+      !!
+      !!           The successive steps of this routine are
+      !!           1.  initialization of ice-snow layers thicknesses
+      !!           2.  Internal absorbed and transmitted radiation
+      !!           Then iterative procedure begins
+      !!           3.  Thermal conductivity
+      !!           4.  Kappa factors
+      !!           5.  specific heat in the ice
+      !!           6.  eta factors
+      !!           7.  surface flux computation
+      !!           8.  tridiagonal system terms
+      !!           9.  solving the tridiagonal system with Gauss elimination
+      !!           Iterative procedure ends according to a criterion on evolution
+      !!           of temperature
+      !!           10. Fluxes at the interfaces
+      !!
+      !! ** Inputs / Ouputs : (global commons)
+      !!           surface temperature              : t_su_1d
+      !!           ice/snow temperatures            : t_i_1d, t_s_1d
+      !!           ice salinities                   : sz_i_1d
+      !!           number of layers in the ice/snow : nlay_i, nlay_s
+      !!           total ice/snow thickness         : h_i_1d, h_s_1d
+      !!-------------------------------------------------------------------
+      INTEGER, INTENT(in) ::   k_jules     ! Jules coupling (0=OFF, 1=EMULATED, 2=ACTIVE)
+      !
+      INTEGER ::   ji, jk         ! spatial loop index
+      INTEGER ::   jm             ! current reference number of equation
+      INTEGER ::   jm_mint, jm_maxt
+      INTEGER ::   iconv          ! number of iterations in iterative procedure
+      INTEGER ::   iconv_max = 50 ! max number of iterations in iterative procedure
+      !
+      INTEGER, DIMENSION(jpij) ::   jm_min    ! reference number of top equation
+      INTEGER, DIMENSION(jpij) ::   jm_max    ! reference number of bottom equation
+      !
+      REAL(wp) ::   zg1s      =  2._wp        ! for the tridiagonal system
+      REAL(wp) ::   zg1       =  2._wp        !
+      REAL(wp) ::   zgamma    =  18009._wp    ! for specific heat
+      REAL(wp) ::   zbeta     =  0.117_wp     ! for thermal conductivity (could be 0.13)
+      REAL(wp) ::   zraext_s  =  10._wp       ! extinction coefficient of radiation in the snow
+      REAL(wp) ::   zkimin    =  0.10_wp      ! minimum ice thermal conductivity
+      REAL(wp) ::   ztsu_err  =  1.e-5_wp     ! range around which t_su is considered at 0C 
+      REAL(wp) ::   zdti_bnd  =  1.e-4_wp     ! maximal authorized error on temperature 
+      REAL(wp) ::   zhs_min   =  0.01_wp      ! minimum snow thickness for conductivity calculation 
+      REAL(wp) ::   ztmelt_i                  ! ice melting temperature
+      REAL(wp) ::   zdti_max                  ! current maximal error on temperature 
+      REAL(wp) ::   zcpi                      ! Ice specific heat
+      REAL(wp) ::   zhfx_err, zdq             ! diag errors on heat
+      REAL(wp) ::   zfac                      ! dummy factor
+      !
+      REAL(wp), DIMENSION(jpij) ::   isnow        ! switch for presence (1) or absence (0) of snow
+      REAL(wp), DIMENSION(jpij) ::   ztsub        ! surface temperature at previous iteration
+      REAL(wp), DIMENSION(jpij) ::   zh_i, z1_h_i ! ice layer thickness
+      REAL(wp), DIMENSION(jpij) ::   zh_s, z1_h_s ! snow layer thickness
+      REAL(wp), DIMENSION(jpij) ::   zqns_ice_b   ! solar radiation absorbed at the surface
+      REAL(wp), DIMENSION(jpij) ::   zfnet        ! surface flux function
+      REAL(wp), DIMENSION(jpij) ::   zdqns_ice_b  ! derivative of the surface flux function
+      !
+      REAL(wp), DIMENSION(jpij       )     ::   ztsuold     ! Old surface temperature in the ice
+      REAL(wp), DIMENSION(jpij,nlay_i)     ::   ztiold      ! Old temperature in the ice
+      REAL(wp), DIMENSION(jpij,nlay_s)     ::   ztsold      ! Old temperature in the snow
+      REAL(wp), DIMENSION(jpij,nlay_i)     ::   ztib        ! Temporary temperature in the ice to check the convergence
+      REAL(wp), DIMENSION(jpij,nlay_s)     ::   ztsb        ! Temporary temperature in the snow to check the convergence
+      REAL(wp), DIMENSION(jpij,0:nlay_i)   ::   ztcond_i    ! Ice thermal conductivity
+      REAL(wp), DIMENSION(jpij,0:nlay_i)   ::   zradtr_i    ! Radiation transmitted through the ice
+      REAL(wp), DIMENSION(jpij,0:nlay_i)   ::   zradab_i    ! Radiation absorbed in the ice
+      REAL(wp), DIMENSION(jpij,0:nlay_i)   ::   zkappa_i    ! Kappa factor in the ice
+      REAL(wp), DIMENSION(jpij,0:nlay_i)   ::   zeta_i      ! Eta factor in the ice
+      REAL(wp), DIMENSION(jpij,0:nlay_s)   ::   zradtr_s    ! Radiation transmited through the snow
+      REAL(wp), DIMENSION(jpij,0:nlay_s)   ::   zradab_s    ! Radiation absorbed in the snow
+      REAL(wp), DIMENSION(jpij,0:nlay_s)   ::   zkappa_s    ! Kappa factor in the snow
+      REAL(wp), DIMENSION(jpij,0:nlay_s)   ::   zeta_s      ! Eta factor in the snow
+      REAL(wp), DIMENSION(jpij,nlay_i+3)   ::   zindterm    ! 'Ind'ependent term
+      REAL(wp), DIMENSION(jpij,nlay_i+3)   ::   zindtbis    ! Temporary 'ind'ependent term
+      REAL(wp), DIMENSION(jpij,nlay_i+3)   ::   zdiagbis    ! Temporary 'dia'gonal term
+      REAL(wp), DIMENSION(jpij,nlay_i+3,3) ::   ztrid       ! Tridiagonal system terms
+      REAL(wp), DIMENSION(jpij)            ::   zq_ini      ! diag errors on heat
+      REAL(wp), DIMENSION(jpij)            ::   zghe        ! G(he), th. conduct enhancement factor, mono-cat
+      !
+      ! Mono-category
+      REAL(wp) ::   zepsilon   ! determines thres. above which computation of G(h) is done
+      REAL(wp) ::   zhe        ! dummy factor
+      REAL(wp) ::   zcnd_i     ! mean sea ice thermal conductivity
+      !!------------------------------------------------------------------     
+
+      ! --- diag error on heat diffusion - PART 1 --- !
+      DO ji = 1, npti
+         zq_ini(ji) = ( SUM( e_i_1d(ji,1:nlay_i) ) * h_i_1d(ji) * r1_nlay_i +  &
+            &           SUM( e_s_1d(ji,1:nlay_s) ) * h_s_1d(ji) * r1_nlay_s ) 
+      END DO
+
+      !------------------
+      ! 1) Initialization
+      !------------------
+      DO ji = 1, npti
+         isnow(ji) = 1._wp - MAX( 0._wp , SIGN(1._wp, - h_s_1d(ji) ) )  ! is there snow or not
+         ! layer thickness
+         zh_i(ji) = h_i_1d(ji) * r1_nlay_i
+         zh_s(ji) = h_s_1d(ji) * r1_nlay_s
+      END DO
+      !
+      WHERE( zh_i(1:npti) >= epsi10 )   ;   z1_h_i(1:npti) = 1._wp / zh_i(1:npti)
+      ELSEWHERE                         ;   z1_h_i(1:npti) = 0._wp
+      END WHERE
+      !
+      WHERE( zh_s(1:npti) > 0._wp   )       zh_s(1:npti) = MAX( zhs_min * r1_nlay_s, zh_s(1:npti) )
+      !
+      WHERE( zh_s(1:npti) > 0._wp   )   ;   z1_h_s(1:npti) = 1._wp / zh_s(1:npti)
+      ELSEWHERE                         ;   z1_h_s(1:npti) = 0._wp
+      END WHERE
+      !
+      ! Store initial temperatures and non solar heat fluxes
+      IF( k_jules == np_jules_OFF .OR. k_jules == np_jules_EMULE ) THEN
+         !
+         ztsub      (1:npti) = t_su_1d(1:npti)                          ! surface temperature at iteration n-1
+         ztsuold    (1:npti) = t_su_1d(1:npti)                          ! surface temperature initial value
+         t_su_1d    (1:npti) = MIN( t_su_1d(1:npti), rt0 - ztsu_err )   ! required to leave the choice between melting or not
+         zdqns_ice_b(1:npti) = dqns_ice_1d(1:npti)                      ! derivative of incoming nonsolar flux 
+         zqns_ice_b (1:npti) = qns_ice_1d(1:npti)                       ! store previous qns_ice_1d value
+         !
+      ENDIF
+      !
+      ztsold (1:npti,:) = t_s_1d(1:npti,:)   ! Old snow temperature
+      ztiold (1:npti,:) = t_i_1d(1:npti,:)   ! Old ice temperature
+
+      !-------------
+      ! 2) Radiation
+      !-------------
+      ! --- Transmission/absorption of solar radiation in the ice --- !
+      zradtr_s(1:npti,0) = qsr_ice_tr_1d(1:npti)
+      DO jk = 1, nlay_s
+         DO ji = 1, npti
+            !                             ! radiation transmitted below the layer-th snow layer
+            zradtr_s(ji,jk) = zradtr_s(ji,0) * EXP( - zraext_s * h_s_1d(ji) * r1_nlay_s * REAL(jk) )
+            !                             ! radiation absorbed by the layer-th snow layer
+            zradab_s(ji,jk) = zradtr_s(ji,jk-1) - zradtr_s(ji,jk)
+         END DO
+      END DO
+      !
+      zradtr_i(1:npti,0) = zradtr_s(1:npti,nlay_s) * isnow(1:npti) + qsr_ice_tr_1d(1:npti) * ( 1._wp - isnow(1:npti) )
+      DO jk = 1, nlay_i 
+         DO ji = 1, npti
+            !                             ! radiation transmitted below the layer-th ice layer
+            zradtr_i(ji,jk) = zradtr_i(ji,0) * EXP( - rn_kappa_i * zh_i(ji) * REAL(jk) )
+            !                             ! radiation absorbed by the layer-th ice layer
+            zradab_i(ji,jk) = zradtr_i(ji,jk-1) - zradtr_i(ji,jk)
+         END DO
+      END DO
+      !
+      ftr_ice_1d(1:npti) = zradtr_i(1:npti,nlay_i)   ! record radiation transmitted below the ice
+      !
+      iconv    = 0          ! number of iterations
+      zdti_max = 1000._wp   ! maximal value of error on all points
+      !
+      !                                                          !============================!
+      DO WHILE ( zdti_max > zdti_bnd .AND. iconv < iconv_max )   ! Iterative procedure begins !
+         !                                                       !============================!
+         iconv = iconv + 1
+         !
+         ztib(1:npti,:) = t_i_1d(1:npti,:)
+         ztsb(1:npti,:) = t_s_1d(1:npti,:)
+         !
+         !--------------------------------
+         ! 3) Sea ice thermal conductivity
+         !--------------------------------
+         IF( ln_cndi_U64 ) THEN         !-- Untersteiner (1964) formula: k = k0 + beta.S/T
+            !
+            DO ji = 1, npti
+               ztcond_i(ji,0)      = rcdic + zbeta * sz_i_1d(ji,1)      / MIN( -epsi10, t_i_1d(ji,1) - rt0 )
+               ztcond_i(ji,nlay_i) = rcdic + zbeta * sz_i_1d(ji,nlay_i) / MIN( -epsi10, t_bo_1d(ji)  - rt0 )
+            END DO
+            DO jk = 1, nlay_i-1
+               DO ji = 1, npti
+                  ztcond_i(ji,jk) = rcdic + zbeta * 0.5_wp * ( sz_i_1d(ji,jk) + sz_i_1d(ji,jk+1) ) /  &
+                     &                      MIN( -epsi10, 0.5_wp * (t_i_1d(ji,jk) + t_i_1d(ji,jk+1)) - rt0 )
+               END DO
+            END DO
+            !
+         ELSEIF( ln_cndi_P07 ) THEN     !-- Pringle et al formula: k = k0 + beta1.S/T - beta2.T
+            !
+            DO ji = 1, npti
+               ztcond_i(ji,0)      = rcdic + 0.09_wp  *  sz_i_1d(ji,1)      / MIN( -epsi10, t_i_1d(ji,1) - rt0 )  &
+                  &                        - 0.011_wp * ( t_i_1d(ji,1) - rt0 )
+               ztcond_i(ji,nlay_i) = rcdic + 0.09_wp  *  sz_i_1d(ji,nlay_i) / MIN( -epsi10, t_bo_1d(ji)  - rt0 )  &
+                  &                        - 0.011_wp * ( t_bo_1d(ji) - rt0 )
+            END DO
+            DO jk = 1, nlay_i-1
+               DO ji = 1, npti
+                  ztcond_i(ji,jk) = rcdic + 0.09_wp  *   0.5_wp * ( sz_i_1d(ji,jk) + sz_i_1d(ji,jk+1) ) /        &
+                     &                     MIN( -epsi10, 0.5_wp * ( t_i_1d (ji,jk) + t_i_1d (ji,jk+1) ) - rt0 )  &
+                     &                    - 0.011_wp * ( 0.5_wp * ( t_i_1d (ji,jk) + t_i_1d (ji,jk+1) ) - rt0 )
+               END DO
+            END DO
+            !
+         ENDIF
+         ztcond_i(1:npti,:) = MAX( zkimin, ztcond_i(1:npti,:) )        
+         !
+         !--- G(he) : enhancement of thermal conductivity in mono-category case
+         ! Computation of effective thermal conductivity G(h)
+         ! Used in mono-category case only to simulate an ITD implicitly
+         ! Fichefet and Morales Maqueda, JGR 1997
+         zghe(1:npti) = 1._wp
+         !
+         SELECT CASE ( nn_virtual_itd )
+         !
+         CASE ( 1 , 2 )
+            !
+            zepsilon = 0.1_wp
+            DO ji = 1, npti
+               zcnd_i = SUM( ztcond_i(ji,:) ) / REAL( nlay_i+1, wp )                                ! Mean sea ice thermal conductivity
+               zhe = ( rn_cnd_s * h_i_1d(ji) + zcnd_i * h_s_1d(ji) ) / ( rn_cnd_s + zcnd_i )        ! Effective thickness he (zhe)
+               IF( zhe >=  zepsilon * 0.5_wp * EXP(1._wp) )  &
+                  &   zghe(ji) = MIN( 2._wp, 0.5_wp * ( 1._wp + LOG( 2._wp * zhe / zepsilon ) ) )   ! G(he)
+            END DO
+            !
+         END SELECT
+         !
+         !-----------------
+         ! 4) kappa factors
+         !-----------------
+         !--- Snow
+         DO jk = 0, nlay_s-1
+            DO ji = 1, npti
+               zkappa_s(ji,jk) = zghe(ji) * rn_cnd_s * z1_h_s(ji)
+            END DO
+         END DO
+         DO ji = 1, npti   ! Snow-ice interface
+            zfac = 0.5_wp * ( ztcond_i(ji,0) * zh_s(ji) + rn_cnd_s * zh_i(ji) )
+            IF( zfac > epsi10 ) THEN
+               zkappa_s(ji,nlay_s) = zghe(ji) * rn_cnd_s * ztcond_i(ji,0) / zfac
+            ELSE
+               zkappa_s(ji,nlay_s) = 0._wp
+            ENDIF
+         END DO
+
+         !--- Ice
+         DO jk = 0, nlay_i
+            DO ji = 1, npti
+               zkappa_i(ji,jk) = zghe(ji) * ztcond_i(ji,jk) * z1_h_i(ji)
+            END DO
+         END DO
+         DO ji = 1, npti   ! Snow-ice interface
+            zkappa_i(ji,0) = zkappa_s(ji,nlay_s) * isnow(ji) + zkappa_i(ji,0) * ( 1._wp - isnow(ji) )
+         END DO
+         !
+         !--------------------------------------
+         ! 5) Sea ice specific heat, eta factors
+         !--------------------------------------
+         DO jk = 1, nlay_i
+            DO ji = 1, npti
+               zcpi = cpic + zgamma * sz_i_1d(ji,jk) / MAX( ( t_i_1d(ji,jk) - rt0 ) * ( ztiold(ji,jk) - rt0 ), epsi10 )
+               zeta_i(ji,jk) = rdt_ice * r1_rhoic * z1_h_i(ji) / MAX( epsi10, zcpi ) 
+            END DO
+         END DO
+
+         DO jk = 1, nlay_s
+            DO ji = 1, npti
+               zeta_s(ji,jk) = rdt_ice * r1_rhosn * r1_cpic * z1_h_s(ji)
+            END DO
+         END DO
+         !
+         !----------------------------------------!
+         !                                        !
+         !   JULES COUPLING IS OFF OR EMULATED    !
+         !                                        !
+         !----------------------------------------!
+         !
+         IF( k_jules == np_jules_OFF .OR. k_jules == np_jules_EMULE ) THEN
+            !
+            ! ==> The original BL99 temperature computation is used
+            !       (with qsr_ice, qns_ice and dqns_ice as inputs)
+            !
+            !----------------------------
+            ! 6) surface flux computation
+            !----------------------------
+            ! update of the non solar flux according to the update in T_su
+            DO ji = 1, npti
+               qns_ice_1d(ji) = qns_ice_1d(ji) + dqns_ice_1d(ji) * ( t_su_1d(ji) - ztsub(ji) )
+            END DO
+
+            DO ji = 1, npti
+               zfnet(ji) = qsr_ice_1d(ji) - qsr_ice_tr_1d(ji) + qns_ice_1d(ji) ! net heat flux = net - transmitted solar + non solar
+            END DO
+            !
+            !----------------------------
+            ! 7) tridiagonal system terms
+            !----------------------------
+            ! layer denotes the number of the layer in the snow or in the ice
+            ! jm denotes the reference number of the equation in the tridiagonal
+            ! system, terms of tridiagonal system are indexed as following :
+            ! 1 is subdiagonal term, 2 is diagonal and 3 is superdiagonal one
+
+            ! ice interior terms (top equation has the same form as the others)
+            ztrid   (1:npti,:,:) = 0._wp
+            zindterm(1:npti,:)   = 0._wp
+            zindtbis(1:npti,:)   = 0._wp
+            zdiagbis(1:npti,:)   = 0._wp
+
+            DO jm = nlay_s + 2, nlay_s + nlay_i 
+               DO ji = 1, npti
+                  jk = jm - nlay_s - 1
+                  ztrid   (ji,jm,1) =       - zeta_i(ji,jk) *   zkappa_i(ji,jk-1)
+                  ztrid   (ji,jm,2) = 1._wp + zeta_i(ji,jk) * ( zkappa_i(ji,jk-1) + zkappa_i(ji,jk) )
+                  ztrid   (ji,jm,3) =       - zeta_i(ji,jk) *                       zkappa_i(ji,jk)
+                  zindterm(ji,jm)   = ztiold(ji,jk) + zeta_i(ji,jk) * zradab_i(ji,jk)
+               END DO
+            END DO
+
+            jm =  nlay_s + nlay_i + 1
+            DO ji = 1, npti
+               ! ice bottom term
+               ztrid   (ji,jm,1) =       - zeta_i(ji,nlay_i) *   zkappa_i(ji,nlay_i-1)   
+               ztrid   (ji,jm,2) = 1._wp + zeta_i(ji,nlay_i) * ( zkappa_i(ji,nlay_i-1) + zkappa_i(ji,nlay_i) * zg1 )
+               ztrid   (ji,jm,3) = 0._wp
+               zindterm(ji,jm)   = ztiold(ji,nlay_i) + zeta_i(ji,nlay_i) *  &
+                  &              ( zradab_i(ji,nlay_i) + zkappa_i(ji,nlay_i) * zg1 * t_bo_1d(ji) ) 
+            END DO
+
+            DO ji = 1, npti
+               !                               !---------------------!
+               IF( h_s_1d(ji) > 0._wp ) THEN   !  snow-covered cells !
+                  !                            !---------------------!
+                  ! snow interior terms (bottom equation has the same form as the others)
+                  DO jm = 3, nlay_s + 1
+                     jk = jm - 1
+                     ztrid   (ji,jm,1) =       - zeta_s(ji,jk) *   zkappa_s(ji,jk-1)
+                     ztrid   (ji,jm,2) = 1._wp + zeta_s(ji,jk) * ( zkappa_s(ji,jk-1) + zkappa_s(ji,jk) )
+                     ztrid   (ji,jm,3) =       - zeta_s(ji,jk) *                       zkappa_s(ji,jk)
+                     zindterm(ji,jm)   = ztsold(ji,jk) + zeta_s(ji,jk) * zradab_s(ji,jk)
+                  END DO
+                  
+                  ! case of only one layer in the ice (ice equation is altered)
+                  IF( nlay_i == 1 ) THEN
+                     ztrid   (ji,nlay_s+2,3) = 0._wp
+                     zindterm(ji,nlay_s+2)   = zindterm(ji,nlay_s+2) + zeta_i(ji,1) * zkappa_i(ji,1) * t_bo_1d(ji) 
+                  ENDIF
+                  
+                  IF( t_su_1d(ji) < rt0 ) THEN   !--  case 1 : no surface melting
+                     
+                     jm_min(ji) = 1
+                     jm_max(ji) = nlay_i + nlay_s + 1
+                     
+                     ! surface equation
+                     ztrid   (ji,1,1) = 0._wp
+                     ztrid   (ji,1,2) = zdqns_ice_b(ji) - zg1s * zkappa_s(ji,0)
+                     ztrid   (ji,1,3) =                   zg1s * zkappa_s(ji,0)
+                     zindterm(ji,1)   = zdqns_ice_b(ji) * t_su_1d(ji) - zfnet(ji)
+                     
+                     ! first layer of snow equation
+                     ztrid   (ji,2,1) =       - zeta_s(ji,1) *                    zkappa_s(ji,0) * zg1s
+                     ztrid   (ji,2,2) = 1._wp + zeta_s(ji,1) * ( zkappa_s(ji,1) + zkappa_s(ji,0) * zg1s )
+                     ztrid   (ji,2,3) =       - zeta_s(ji,1) *   zkappa_s(ji,1)
+                     zindterm(ji,2)   = ztsold(ji,1) + zeta_s(ji,1) * zradab_s(ji,1)
+                     
+                  ELSE                            !--  case 2 : surface is melting
+                     !
+                     jm_min(ji) = 2
+                     jm_max(ji) = nlay_i + nlay_s + 1
+                     
+                     ! first layer of snow equation
+                     ztrid   (ji,2,1) = 0._wp
+                     ztrid   (ji,2,2) = 1._wp + zeta_s(ji,1) * ( zkappa_s(ji,1) + zkappa_s(ji,0) * zg1s )
+                     ztrid   (ji,2,3) =       - zeta_s(ji,1) *   zkappa_s(ji,1) 
+                     zindterm(ji,2)   = ztsold(ji,1) + zeta_s(ji,1) * ( zradab_s(ji,1) + zkappa_s(ji,0) * zg1s * t_su_1d(ji) ) 
+                  ENDIF
+                  !                            !---------------------!
+               ELSE                            ! cells without snow  !
+                  !                            !---------------------!
+                  !
+                  IF( t_su_1d(ji) < rt0 ) THEN   !--  case 1 : no surface melting
+                     !
+                     jm_min(ji) = nlay_s + 1
+                     jm_max(ji) = nlay_i + nlay_s + 1
+                     
+                     ! surface equation	
+                     ztrid   (ji,jm_min(ji),1) = 0._wp
+                     ztrid   (ji,jm_min(ji),2) = zdqns_ice_b(ji) - zkappa_i(ji,0) * zg1    
+                     ztrid   (ji,jm_min(ji),3) =                   zkappa_i(ji,0) * zg1
+                     zindterm(ji,jm_min(ji))   = zdqns_ice_b(ji) * t_su_1d(ji) - zfnet(ji)
+                     
+                     ! first layer of ice equation
+                     ztrid   (ji,jm_min(ji)+1,1) =       - zeta_i(ji,1) *                    zkappa_i(ji,0) * zg1
+                     ztrid   (ji,jm_min(ji)+1,2) = 1._wp + zeta_i(ji,1) * ( zkappa_i(ji,1) + zkappa_i(ji,0) * zg1 )
+                     ztrid   (ji,jm_min(ji)+1,3) =       - zeta_i(ji,1) *   zkappa_i(ji,1)  
+                     zindterm(ji,jm_min(ji)+1)   = ztiold(ji,1) + zeta_i(ji,1) * zradab_i(ji,1)  
+                     
+                     ! case of only one layer in the ice (surface & ice equations are altered)
+                     IF( nlay_i == 1 ) THEN
+                        ztrid   (ji,jm_min(ji),1)   = 0._wp
+                        ztrid   (ji,jm_min(ji),2)   = zdqns_ice_b(ji)      -   zkappa_i(ji,0) * 2._wp
+                        ztrid   (ji,jm_min(ji),3)   =                          zkappa_i(ji,0) * 2._wp
+                        ztrid   (ji,jm_min(ji)+1,1) =       - zeta_i(ji,1) *   zkappa_i(ji,0) * 2._wp
+                        ztrid   (ji,jm_min(ji)+1,2) = 1._wp + zeta_i(ji,1) * ( zkappa_i(ji,0) * 2._wp + zkappa_i(ji,1) )
+                        ztrid   (ji,jm_min(ji)+1,3) = 0._wp
+                        zindterm(ji,jm_min(ji)+1)   = ztiold(ji,1) + zeta_i(ji,1) * (zradab_i(ji,1) + zkappa_i(ji,1) * t_bo_1d(ji))
+                     ENDIF
+                     
+                  ELSE                            !--  case 2 : surface is melting
+                     
+                     jm_min(ji) = nlay_s + 2
+                     jm_max(ji) = nlay_i + nlay_s + 1
+                     
+                     ! first layer of ice equation
+                     ztrid   (ji,jm_min(ji),1) = 0._wp
+                     ztrid   (ji,jm_min(ji),2) = 1._wp + zeta_i(ji,1) * ( zkappa_i(ji,1) + zkappa_i(ji,0) * zg1 )  
+                     ztrid   (ji,jm_min(ji),3) =       - zeta_i(ji,1) *   zkappa_i(ji,1)
+                     zindterm(ji,jm_min(ji))   = ztiold(ji,1) + zeta_i(ji,1) * (zradab_i(ji,1) + zkappa_i(ji,0) * zg1 * t_su_1d(ji)) 
+                     
+                     ! case of only one layer in the ice (surface & ice equations are altered)
+                     IF( nlay_i == 1 ) THEN
+                        ztrid   (ji,jm_min(ji),1) = 0._wp
+                        ztrid   (ji,jm_min(ji),2) = 1._wp + zeta_i(ji,1) * ( zkappa_i(ji,0) * 2._wp + zkappa_i(ji,1) )
+                        ztrid   (ji,jm_min(ji),3) = 0._wp
+                        zindterm(ji,jm_min(ji))   = ztiold(ji,1) + zeta_i(ji,1) * ( zradab_i(ji,1) + zkappa_i(ji,1) * t_bo_1d(ji) ) &
+                           &                      + t_su_1d(ji) * zeta_i(ji,1) * zkappa_i(ji,0) * 2._wp
+                     ENDIF
+                     
+                  ENDIF
+               ENDIF
+               !
+               zindtbis(ji,jm_min(ji)) = zindterm(ji,jm_min(ji))
+               zdiagbis(ji,jm_min(ji)) = ztrid   (ji,jm_min(ji),2)
+               !
+            END DO
+            !
+            !------------------------------
+            ! 8) tridiagonal system solving
+            !------------------------------
+            ! Solve the tridiagonal system with Gauss elimination method.
+            ! Thomas algorithm, from Computational fluid Dynamics, J.D. ANDERSON, McGraw-Hill 1984
+            jm_maxt = 0
+            jm_mint = nlay_i+5
+            DO ji = 1, npti
+               jm_mint = MIN(jm_min(ji),jm_mint)
+               jm_maxt = MAX(jm_max(ji),jm_maxt)
+            END DO
+
+            DO jk = jm_mint+1, jm_maxt
+               DO ji = 1, npti
+                  jm = MIN(MAX(jm_min(ji)+1,jk),jm_max(ji))
+                  zdiagbis(ji,jm) = ztrid   (ji,jm,2) - ztrid(ji,jm,1) * ztrid   (ji,jm-1,3) / zdiagbis(ji,jm-1)
+                  zindtbis(ji,jm) = zindterm(ji,jm  ) - ztrid(ji,jm,1) * zindtbis(ji,jm-1  ) / zdiagbis(ji,jm-1)
+               END DO
+            END DO
+
+            ! ice temperatures
+            DO ji = 1, npti
+               t_i_1d(ji,nlay_i) = zindtbis(ji,jm_max(ji)) / zdiagbis(ji,jm_max(ji))
+            END DO
+
+            DO jm = nlay_i + nlay_s, nlay_s + 2, -1
+               DO ji = 1, npti
+                  jk = jm - nlay_s - 1
+                  t_i_1d(ji,jk) = ( zindtbis(ji,jm) - ztrid(ji,jm,3) * t_i_1d(ji,jk+1) ) / zdiagbis(ji,jm)
+               END DO
+            END DO
+
+            DO ji = 1, npti
+               ! snow temperatures      
+               IF( h_s_1d(ji) > 0._wp ) THEN
+                  t_s_1d(ji,nlay_s) = ( zindtbis(ji,nlay_s+1) - ztrid(ji,nlay_s+1,3) * t_i_1d(ji,1) ) / zdiagbis(ji,nlay_s+1)
+               ENDIF
+               ! surface temperature
+               ztsub(ji) = t_su_1d(ji)
+               IF( t_su_1d(ji) < rt0 ) THEN
+                  t_su_1d(ji) = ( zindtbis(ji,jm_min(ji)) - ztrid(ji,jm_min(ji),3) *  &
+                     &          ( isnow(ji) * t_s_1d(ji,1) + ( 1._wp - isnow(ji) ) * t_i_1d(ji,1) ) ) / zdiagbis(ji,jm_min(ji))
+               ENDIF
+            END DO
+            !
+            !--------------------------------------------------------------
+            ! 9) Has the scheme converged?, end of the iterative procedure
+            !--------------------------------------------------------------
+            ! check that nowhere it has started to melt
+            ! zdti_max is a measure of error, it has to be under zdti_bnd
+            zdti_max = 0._wp
+            DO ji = 1, npti
+               t_su_1d(ji) = MAX( MIN( t_su_1d(ji) , rt0 ) , rt0 - 100._wp )
+               zdti_max    = MAX( zdti_max, ABS( t_su_1d(ji) - ztsub(ji) ) )     
+            END DO
+
+            DO jk = 1, nlay_s
+               DO ji = 1, npti
+                  t_s_1d(ji,jk) = MAX( MIN( t_s_1d(ji,jk), rt0 ), rt0 - 100._wp )
+                  zdti_max      = MAX( zdti_max, ABS( t_s_1d(ji,jk) - ztsb(ji,jk) ) )
+               END DO
+            END DO
+
+            DO jk = 1, nlay_i
+               DO ji = 1, npti
+                  ztmelt_i      = -tmut * sz_i_1d(ji,jk) + rt0 
+                  t_i_1d(ji,jk) =  MAX( MIN( t_i_1d(ji,jk), ztmelt_i ), rt0 - 100._wp )
+                  zdti_max      =  MAX( zdti_max, ABS( t_i_1d(ji,jk) - ztib(ji,jk) ) )
+               END DO
+            END DO
+
+            ! Compute spatial maximum over all errors
+            ! note that this could be optimized substantially by iterating only the non-converging points
+            IF( lk_mpp ) CALL mpp_max( zdti_max, kcom=ncomm_ice )
+         !
+         !----------------------------------------!
+         !                                        !
+         !      JULES COUPLING IS ACTIVE          !
+         !                                        !
+         !----------------------------------------!
+         !
+         ELSEIF( k_jules == np_jules_ACTIVE ) THEN
+            !
+            ! ==> we use a modified BL99 solver with conduction flux (qcn_ice) as forcing term
+            !
+            !----------------------------
+            ! 7) tridiagonal system terms
+            !----------------------------
+            ! layer denotes the number of the layer in the snow or in the ice
+            ! jm denotes the reference number of the equation in the tridiagonal
+            ! system, terms of tridiagonal system are indexed as following :
+            ! 1 is subdiagonal term, 2 is diagonal and 3 is superdiagonal one
+
+            ! ice interior terms (top equation has the same form as the others)
+            ztrid   (1:npti,:,:) = 0._wp
+            zindterm(1:npti,:)   = 0._wp
+            zindtbis(1:npti,:)   = 0._wp
+            zdiagbis(1:npti,:)   = 0._wp
+
+            DO jm = nlay_s + 2, nlay_s + nlay_i 
+               DO ji = 1, npti
+                  jk = jm - nlay_s - 1
+                  ztrid   (ji,jm,1) =       - zeta_i(ji,jk) *   zkappa_i(ji,jk-1)
+                  ztrid   (ji,jm,2) = 1._wp + zeta_i(ji,jk) * ( zkappa_i(ji,jk-1) + zkappa_i(ji,jk) )
+                  ztrid   (ji,jm,3) =       - zeta_i(ji,jk) *                       zkappa_i(ji,jk)
+                  zindterm(ji,jm)   = ztiold(ji,jk) + zeta_i(ji,jk) * zradab_i(ji,jk)
+               END DO
+            ENDDO
+
+            jm =  nlay_s + nlay_i + 1
+            DO ji = 1, npti
+               ! ice bottom term
+               ztrid   (ji,jm,1) =       - zeta_i(ji,nlay_i) *   zkappa_i(ji,nlay_i-1)   
+               ztrid   (ji,jm,2) = 1._wp + zeta_i(ji,nlay_i) * ( zkappa_i(ji,nlay_i-1) + zkappa_i(ji,nlay_i) * zg1 )
+               ztrid   (ji,jm,3) = 0._wp
+               zindterm(ji,jm)   = ztiold(ji,nlay_i) + zeta_i(ji,nlay_i) *  &
+                  &              ( zradab_i(ji,nlay_i) + zkappa_i(ji,nlay_i) * zg1 * t_bo_1d(ji) ) 
+            ENDDO
+
+            DO ji = 1, npti
+               !                               !---------------------!
+               IF( h_s_1d(ji) > 0._wp ) THEN   !  snow-covered cells !
+                  !                            !---------------------!
+                  ! snow interior terms (bottom equation has the same form as the others)
+                  DO jm = 3, nlay_s + 1
+                     jk = jm - 1
+                     ztrid   (ji,jm,1) =       - zeta_s(ji,jk) *   zkappa_s(ji,jk-1)
+                     ztrid   (ji,jm,2) = 1._wp + zeta_s(ji,jk) * ( zkappa_s(ji,jk-1) + zkappa_s(ji,jk) )
+                     ztrid   (ji,jm,3) =       - zeta_s(ji,jk) *                       zkappa_s(ji,jk)
+                     zindterm(ji,jm)   = ztsold(ji,jk) + zeta_s(ji,jk) * zradab_s(ji,jk)
+                  END DO
+                  
+                  ! case of only one layer in the ice (ice equation is altered)
+                  IF ( nlay_i == 1 ) THEN
+                     ztrid   (ji,nlay_s+2,3) = 0._wp
+                     zindterm(ji,nlay_s+2)   = zindterm(ji,nlay_s+2) + zeta_i(ji,1) * zkappa_i(ji,1) * t_bo_1d(ji) 
+                  ENDIF
+                  
+                  jm_min(ji) = 2
+                  jm_max(ji) = nlay_i + nlay_s + 1
+                  
+                  ! first layer of snow equation
+                  ztrid   (ji,2,1) = 0._wp
+                  ztrid   (ji,2,2) = 1._wp + zeta_s(ji,1) * zkappa_s(ji,1)
+                  ztrid   (ji,2,3) =       - zeta_s(ji,1) * zkappa_s(ji,1) 
+                  zindterm(ji,2)   = ztsold(ji,1) + zeta_s(ji,1) * ( zradab_s(ji,1) + qcn_ice_1d(ji) ) 
+                  
+                  !                            !---------------------!
+               ELSE                            ! cells without snow  !
+                  !                            !---------------------!
+                  jm_min(ji) = nlay_s + 2
+                  jm_max(ji) = nlay_i + nlay_s + 1
+                  
+                  ! first layer of ice equation
+                  ztrid   (ji,jm_min(ji),1) = 0._wp
+                  ztrid   (ji,jm_min(ji),2) = 1._wp + zeta_i(ji,1) * zkappa_i(ji,1)  
+                  ztrid   (ji,jm_min(ji),3) =       - zeta_i(ji,1) * zkappa_i(ji,1)
+                  zindterm(ji,jm_min(ji))   = ztiold(ji,1) + zeta_i(ji,1) * ( zradab_i(ji,1) + qcn_ice_1d(ji) )
+                  
+                  ! case of only one layer in the ice (surface & ice equations are altered)
+                  IF( nlay_i == 1 ) THEN
+                     ztrid   (ji,jm_min(ji),1) = 0._wp
+                     ztrid   (ji,jm_min(ji),2) = 1._wp + zeta_i(ji,1) * zkappa_i(ji,1)
+                     ztrid   (ji,jm_min(ji),3) = 0._wp
+                     zindterm(ji,jm_min(ji))   = ztiold(ji,1) + zeta_i(ji,1) *  &
+                        &                                     ( zradab_i(ji,1) + zkappa_i(ji,1) * t_bo_1d(ji) + qcn_ice_1d(ji) )
+                  ENDIF
+                  
+               ENDIF
+               !
+               zindtbis(ji,jm_min(ji)) = zindterm(ji,jm_min(ji))
+               zdiagbis(ji,jm_min(ji)) = ztrid   (ji,jm_min(ji),2)
+               !
+            END DO
+            !
+            !------------------------------
+            ! 8) tridiagonal system solving
+            !------------------------------
+            ! Solve the tridiagonal system with Gauss elimination method.
+            ! Thomas algorithm, from Computational fluid Dynamics, J.D. ANDERSON, McGraw-Hill 1984
+            jm_maxt = 0
+            jm_mint = nlay_i+5
+            DO ji = 1, npti
+               jm_mint = MIN(jm_min(ji),jm_mint)
+               jm_maxt = MAX(jm_max(ji),jm_maxt)
+            END DO
+            
+            DO jk = jm_mint+1, jm_maxt
+               DO ji = 1, npti
+                  jm = MIN(MAX(jm_min(ji)+1,jk),jm_max(ji))
+                  zdiagbis(ji,jm) = ztrid   (ji,jm,2) - ztrid(ji,jm,1) * ztrid   (ji,jm-1,3) / zdiagbis(ji,jm-1)
+                  zindtbis(ji,jm) = zindterm(ji,jm)   - ztrid(ji,jm,1) * zindtbis(ji,jm-1)   / zdiagbis(ji,jm-1)
+               END DO
+            END DO
+            
+            ! ice temperatures
+           DO ji = 1, npti
+               t_i_1d(ji,nlay_i) = zindtbis(ji,jm_max(ji)) / zdiagbis(ji,jm_max(ji))
+            END DO
+
+            DO jm = nlay_i + nlay_s, nlay_s + 2, -1
+               DO ji = 1, npti
+                  jk = jm - nlay_s - 1
+                  t_i_1d(ji,jk) = ( zindtbis(ji,jm) - ztrid(ji,jm,3) * t_i_1d(ji,jk+1) ) / zdiagbis(ji,jm)
+               END DO
+            END DO
+            
+            ! snow temperatures      
+            DO ji = 1, npti
+               IF( h_s_1d(ji) > 0._wp ) THEN
+                  t_s_1d(ji,nlay_s) = ( zindtbis(ji,nlay_s+1) - ztrid(ji,nlay_s+1,3) * t_i_1d(ji,1) ) / zdiagbis(ji,nlay_s+1)
+               ENDIF
+            END DO
+            !
+            !--------------------------------------------------------------
+            ! 9) Has the scheme converged?, end of the iterative procedure
+            !--------------------------------------------------------------
+            ! check that nowhere it has started to melt
+            ! zdti_max is a measure of error, it has to be under zdti_bnd
+            zdti_max = 0._wp
+
+            DO jk = 1, nlay_s
+               DO ji = 1, npti
+                  t_s_1d(ji,jk) = MAX( MIN( t_s_1d(ji,jk), rt0 ), rt0 - 100._wp )
+                  zdti_max = MAX( zdti_max, ABS( t_s_1d(ji,jk) - ztsb(ji,jk) ) )
+               END DO
+            END DO
+            
+            DO jk = 1, nlay_i
+               DO ji = 1, npti
+                  ztmelt_i      = -tmut * sz_i_1d(ji,jk) + rt0 
+                  t_i_1d(ji,jk) =  MAX( MIN( t_i_1d(ji,jk), ztmelt_i ), rt0 - 100._wp )
+                  zdti_max      =  MAX( zdti_max, ABS( t_i_1d(ji,jk) - ztib(ji,jk) ) )
+               END DO
+            END DO
+
+            ! Compute spatial maximum over all errors
+            ! note that this could be optimized substantially by iterating only the non-converging points
+            IF( lk_mpp )   CALL mpp_max( zdti_max, kcom=ncomm_ice )
+
+         ENDIF ! k_jules
+         
+      END DO  ! End of the do while iterative procedure
+      
+      IF( ln_icectl .AND. lwp ) THEN
+         WRITE(numout,*) ' zdti_max : ', zdti_max
+         WRITE(numout,*) ' iconv    : ', iconv
+      ENDIF
+      
+      !
+      !-----------------------------
+      ! 10) Fluxes at the interfaces
+      !-----------------------------
+      !
+      ! --- update conduction fluxes
+      !
+      DO ji = 1, npti
+         !                                ! surface ice conduction flux
+         fc_su(ji)   =  -           isnow(ji)   * zkappa_s(ji,0) * zg1s * ( t_s_1d(ji,1) - t_su_1d(ji) )  &
+            &           - ( 1._wp - isnow(ji) ) * zkappa_i(ji,0) * zg1  * ( t_i_1d(ji,1) - t_su_1d(ji) )
+         !                                ! bottom ice conduction flux
+         fc_bo_i(ji) =  - zkappa_i(ji,nlay_i) * zg1 * ( t_bo_1d(ji) - t_i_1d(ji,nlay_i) )
+      END DO
+      
+      !
+      ! --- Diagnose the heat loss due to changing non-solar / conduction flux --- !
+      !
+      IF( k_jules == np_jules_OFF .OR. k_jules == np_jules_EMULE ) THEN
+         !
+         DO ji = 1, npti
+            hfx_err_dif_1d(ji) = hfx_err_dif_1d(ji) - ( qns_ice_1d(ji) - zqns_ice_b(ji) ) * a_i_1d(ji) 
+         END DO
+         !
+      ELSEIF( k_jules == np_jules_ACTIVE ) THEN
+         !
+         DO ji = 1, npti
+            hfx_err_dif_1d(ji) = hfx_err_dif_1d(ji) - ( fc_su(ji)      - qcn_ice_1d(ji) ) * a_i_1d(ji) 
+         END DO
+         !
+      ENDIF
+      
+      !
+      ! --- Diagnose the heat loss due to non-fully converged temperature solution (should not be above 10-4 W-m2) --- !
+      !
+      IF( k_jules == np_jules_OFF .OR. k_jules == np_jules_ACTIVE ) THEN
+         
+         CALL ice_var_enthalpy       
+         
+         ! zhfx_err = correction on the diagnosed heat flux due to non-convergence of the algorithm used to solve heat equation
+         DO ji = 1, npti
+            zdq = - zq_ini(ji) + ( SUM( e_i_1d(ji,1:nlay_i) ) * h_i_1d(ji) * r1_nlay_i +  &
+               &                   SUM( e_s_1d(ji,1:nlay_s) ) * h_s_1d(ji) * r1_nlay_s )
+            
+            IF( k_jules == np_jules_OFF ) THEN
+               
+               IF( t_su_1d(ji) < rt0 ) THEN  ! case T_su < 0degC
+                  zhfx_err = ( qns_ice_1d(ji) + qsr_ice_1d(ji)    - zradtr_i(ji,nlay_i) - fc_bo_i(ji) + zdq * r1_rdtice )*a_i_1d(ji)
+               ELSE                          ! case T_su = 0degC
+                  zhfx_err = ( fc_su(ji)      + qsr_ice_tr_1d(ji) - zradtr_i(ji,nlay_i) - fc_bo_i(ji) + zdq * r1_rdtice )*a_i_1d(ji)
+               ENDIF
+               
+            ELSEIF( k_jules == np_jules_ACTIVE ) THEN
+            
+               zhfx_err = ( fc_su(ji) + qsr_ice_tr_1d(ji) - zradtr_i(ji,nlay_i) - fc_bo_i(ji) + zdq * r1_rdtice ) * a_i_1d(ji)
+            
+            ENDIF
+            !
+            ! total heat sink to be sent to the ocean
+            hfx_err_dif_1d(ji) = hfx_err_dif_1d(ji) + zhfx_err
+            !
+            ! hfx_dif = Heat flux diagnostic of sensible heat used to warm/cool ice in W.m-2   
+            hfx_dif_1d(ji) = hfx_dif_1d(ji) - zdq * r1_rdtice * a_i_1d(ji)
+            !
+         END DO
+         !
+         ! --- SIMIP diagnostics
+         !
+         DO ji = 1, npti
+            !--- Conduction fluxes (positive downwards)
+            diag_fc_bo_1d(ji) = diag_fc_bo_1d(ji) + fc_bo_i(ji) * a_i_1d(ji) / at_i_1d(ji)
+            diag_fc_su_1d(ji) = diag_fc_su_1d(ji) + fc_su  (ji) * a_i_1d(ji) / at_i_1d(ji)
+   
+            !--- Snow-ice interfacial temperature (diagnostic SIMIP)
+            zfac = rn_cnd_s * zh_i(ji) + ztcond_i(ji,1) * zh_s(ji)
+            IF( h_s_1d(ji) >= zhs_min ) THEN
+               t_si_1d(ji) = ( rn_cnd_s       * zh_i(ji) * t_s_1d(ji,1) +   &
+                  &            ztcond_i(ji,1) * zh_s(ji) * t_i_1d(ji,1) ) / MAX( epsi10, zfac )
+            ELSE
+               t_si_1d(ji) = t_su_1d(ji)
+            ENDIF
+         END DO
+         !
+      ENDIF
+      !
+      !---------------------------------------------------------------------------------------
+      ! 11) Jules coupling: reset inner snow and ice temperatures, update conduction fluxes
+      !---------------------------------------------------------------------------------------
+      ! effective conductivity and 1st layer temperature (needed by Met Office)
+      DO ji = 1, npti
+         IF( h_s_1d(ji) > 0.1_wp ) THEN 
+            cnd_ice_1d(ji) = 2._wp * zkappa_s(ji,0)
+         ELSE
+            IF( h_i_1d(ji) > 0.1_wp ) THEN
+               cnd_ice_1d(ji) = 2._wp * zkappa_i(ji,0)
+            ELSE
+               cnd_ice_1d(ji) = 2._wp * ztcond_i(ji,0) / 0.1_wp
+            ENDIF
+         ENDIF
+         t1_ice_1d(ji) = isnow(ji) * t_s_1d(ji,1) + ( 1._wp - isnow(ji) ) * t_i_1d(ji,1)
+      END DO
+      !
+      IF( k_jules == np_jules_EMULE ) THEN
+         ! Restore temperatures to their initial values
+         t_s_1d    (1:npti,:) = ztsold(1:npti,:)
+         t_i_1d    (1:npti,:) = ztiold(1:npti,:)
+         qcn_ice_1d(1:npti)   = fc_su (1:npti)
+      ENDIF
+      !
+   END SUBROUTINE ice_thd_zdf_BL99
+
+
+#else
+   !!----------------------------------------------------------------------
+   !!   Default option       Dummy Module             No SI3 sea-ice model
+   !!----------------------------------------------------------------------
+#endif
+
+   !!======================================================================
+END MODULE icethd_zdf_BL99
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/ICE_SRC/iceupdate.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/ICE_SRC/iceupdate.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/ICE_SRC/iceupdate.F90	(revision 9570)
@@ -0,0 +1,466 @@
+MODULE iceupdate
+   !!======================================================================
+   !!                       ***  MODULE iceupdate   ***
+   !!  Sea-ice :   computation of the flux at the sea ice/ocean interface
+   !!======================================================================
+   !! History :   -   ! 2006-07 (M. Vancoppelle)  LIM3 original code
+   !!            3.0  ! 2008-03 (C. Tallandier)  surface module
+   !!             -   ! 2008-04 (C. Tallandier)  split in 2 + new ice-ocean coupling
+   !!            3.3  ! 2010-05 (G. Madec) decrease ocean & ice reference salinities in the Baltic sea
+   !!                 !                  + simplification of the ice-ocean stress calculation
+   !!            3.4  ! 2011-02 (G. Madec) dynamical allocation
+   !!             -   ! 2012    (D. Iovino) salt flux change
+   !!             -   ! 2012-05 (C. Rousset) add penetration solar flux
+   !!            3.5  ! 2012-10 (A. Coward, G. Madec) salt fluxes ; ice+snow mass
+   !!----------------------------------------------------------------------
+#if defined key_si3
+   !!----------------------------------------------------------------------
+   !!   'key_si3'                                       SI3 sea-ice model
+   !!----------------------------------------------------------------------
+   !!   ice_update_alloc : allocate the iceupdate arrays
+   !!   ice_update_init  : initialisation
+   !!   ice_update_flx   : updates mass, heat and salt fluxes at the ocean surface
+   !!   ice_update_tau   : update i- and j-stresses, and its modulus at the ocean surface
+   !!----------------------------------------------------------------------
+   USE oce     , ONLY : sshn, sshb
+   USE phycst         ! physical constants
+   USE dom_oce        ! ocean domain
+   USE ice            ! sea-ice: variables
+   USE sbc_ice        ! Surface boundary condition: ice   fields
+   USE sbc_oce        ! Surface boundary condition: ocean fields
+   USE sbccpl         ! Surface boundary condition: coupled interface
+   USE icealb         ! sea-ice: albedo parameters
+   USE traqsr         ! add penetration of solar flux in the calculation of heat budget
+   USE icectl         ! sea-ice: control prints
+   USE bdy_oce , ONLY : ln_bdy
+   !
+   USE in_out_manager ! I/O manager
+   USE iom            ! I/O manager library
+   USE lib_mpp        ! MPP library
+   USE lib_fortran    ! fortran utilities (glob_sum + no signed zero)
+   USE lbclnk         ! lateral boundary conditions (or mpp links)
+   USE timing         ! Timing
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   ice_update_init   ! called by ice_init
+   PUBLIC   ice_update_flx    ! called by ice_stp
+   PUBLIC   ice_update_tau    ! called by ice_stp
+
+   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   utau_oce, vtau_oce   ! air-ocean surface i- & j-stress     [N/m2]
+   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   tmod_io              ! modulus of the ice-ocean velocity   [m/s]
+
+   !! * Substitutions
+#  include "vectopt_loop_substitute.h90"
+   !!----------------------------------------------------------------------
+   !! NEMO/ICE 4.0 , NEMO Consortium (2017)
+   !! $Id: iceupdate.F90 8411 2017-08-07 16:09:12Z clem $
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   INTEGER FUNCTION ice_update_alloc()
+      !!-------------------------------------------------------------------
+      !!             ***  ROUTINE ice_update_alloc ***
+      !!-------------------------------------------------------------------
+      ALLOCATE( utau_oce(jpi,jpj), vtau_oce(jpi,jpj), tmod_io(jpi,jpj), STAT=ice_update_alloc )
+      !
+      IF( lk_mpp                )   CALL mpp_sum( ice_update_alloc )
+      IF( ice_update_alloc /= 0 )   CALL ctl_warn('ice_update_alloc: failed to allocate arrays')
+      !
+   END FUNCTION ice_update_alloc
+
+
+   SUBROUTINE ice_update_flx( kt )
+      !!-------------------------------------------------------------------
+      !!                ***  ROUTINE ice_update_flx ***
+      !!  
+      !! ** Purpose :   Update the surface ocean boundary condition for heat 
+      !!                salt and mass over areas where sea-ice is non-zero
+      !!         
+      !! ** Action  : - computes the heat and freshwater/salt fluxes
+      !!                at the ice-ocean interface.
+      !!              - Update the ocean sbc
+      !!     
+      !! ** Outputs : - qsr     : sea heat flux:     solar 
+      !!              - qns     : sea heat flux: non solar
+      !!              - emp     : freshwater budget: volume flux 
+      !!              - sfx     : salt flux 
+      !!              - fr_i    : ice fraction
+      !!              - tn_ice  : sea-ice surface temperature
+      !!              - alb_ice : sea-ice albedo (recomputed only for coupled mode)
+      !!
+      !! References : Goosse, H. et al. 1996, Bul. Soc. Roy. Sc. Liege, 65, 87-90.
+      !!              Tartinville et al. 2001 Ocean Modelling, 3, 95-108.
+      !!              These refs are now obsolete since everything has been revised
+      !!              The ref should be Rousset et al., 2015
+      !!---------------------------------------------------------------------
+      INTEGER, INTENT(in) ::   kt   ! number of iteration
+      !
+      INTEGER  ::   ji, jj, jl, jk   ! dummy loop indices
+      REAL(wp) ::   zqmass           ! Heat flux associated with mass exchange ice->ocean (W.m-2)
+      REAL(wp) ::   zqsr             ! New solar flux received by the ocean
+      REAL(wp), DIMENSION(jpi,jpj)     ::   z2d                  ! 2D workspace
+      REAL(wp), DIMENSION(jpi,jpj,jpl) ::   zalb_cs, zalb_os     ! 3D workspace
+      !!---------------------------------------------------------------------
+      IF( ln_timing )   CALL timing_start('ice_update')
+
+      IF( kt == nit000 .AND. lwp ) THEN
+         WRITE(numout,*)
+         WRITE(numout,*)'ice_update_flx: update fluxes (mass, salt and heat) at the ice-ocean interface'
+         WRITE(numout,*)'~~~~~~~~~~~~~~'
+      ENDIF
+
+      ! --- case we bypass ice thermodynamics --- !
+      IF( .NOT. ln_icethd ) THEN   ! we suppose ice is impermeable => ocean is isolated from atmosphere
+         hfx_in   (:,:)   = ( 1._wp - at_i_b(:,:) ) * ( qns_oce(:,:) + qsr_oce(:,:) ) + qemp_oce(:,:)
+         hfx_out  (:,:)   = ( 1._wp - at_i_b(:,:) ) *   qns_oce(:,:)                  + qemp_oce(:,:)
+         ftr_ice  (:,:,:) = 0._wp
+         emp_ice  (:,:)   = 0._wp
+         qemp_ice (:,:)   = 0._wp
+         qevap_ice(:,:,:) = 0._wp
+      ENDIF
+      
+      DO jj = 1, jpj
+         DO ji = 1, jpi
+
+            ! Solar heat flux reaching the ocean = zqsr (W.m-2) 
+            !---------------------------------------------------
+            zqsr = qsr_tot(ji,jj) - SUM( a_i_b(ji,jj,:) * ( qsr_ice(ji,jj,:) - ftr_ice(ji,jj,:) ) )
+
+            ! Total heat flux reaching the ocean = hfx_out (W.m-2) 
+            !---------------------------------------------------
+            zqmass         = hfx_thd(ji,jj) + hfx_dyn(ji,jj) + hfx_res(ji,jj) ! heat flux from snow is 0 (T=0 degC)
+            hfx_out(ji,jj) = hfx_out(ji,jj) + zqmass + zqsr
+
+            ! Add the residual from heat diffusion equation and sublimation (W.m-2)
+            !----------------------------------------------------------------------
+            hfx_out(ji,jj) = hfx_out(ji,jj) + hfx_err_dif(ji,jj) +   &
+               &           ( hfx_sub(ji,jj) - SUM( qevap_ice(ji,jj,:) * a_i_b(ji,jj,:) ) )
+
+            ! New qsr and qns used to compute the oceanic heat flux at the next time step
+            !----------------------------------------------------------------------------
+            qsr(ji,jj) = zqsr                                      
+            qns(ji,jj) = hfx_out(ji,jj) - zqsr              
+
+            ! Mass flux at the atm. surface       
+            !-----------------------------------
+            wfx_sub(ji,jj) = wfx_snw_sub(ji,jj) + wfx_ice_sub(ji,jj)
+
+            ! Mass flux at the ocean surface      
+            !------------------------------------
+            !  case of realistic freshwater flux (Tartinville et al., 2001) (presently ACTIVATED)
+            !  ------------------------------------------------------------------------------------- 
+            !  The idea of this approach is that the system that we consider is the ICE-OCEAN system
+            !  Thus  FW  flux  =  External ( E-P+snow melt)
+            !       Salt flux  =  Exchanges in the ice-ocean system then converted into FW
+            !                     Associated to Ice formation AND Ice melting
+            !                     Even if i see Ice melting as a FW and SALT flux
+            !        
+            ! mass flux from ice/ocean
+            wfx_ice(ji,jj) = wfx_bog(ji,jj) + wfx_bom(ji,jj) + wfx_sum(ji,jj) + wfx_sni(ji,jj)   &
+               &           + wfx_opw(ji,jj) + wfx_dyn(ji,jj) + wfx_res(ji,jj) + wfx_lam(ji,jj) + wfx_pnd(ji,jj)
+
+            ! add the snow melt water to snow mass flux to the ocean
+            wfx_snw(ji,jj) = wfx_snw_sni(ji,jj) + wfx_snw_dyn(ji,jj) + wfx_snw_sum(ji,jj)
+
+            ! mass flux at the ocean/ice interface
+            fmmflx(ji,jj) = - ( wfx_ice(ji,jj) + wfx_snw(ji,jj) + wfx_err_sub(ji,jj) )              ! F/M mass flux save at least for biogeochemical model
+            emp(ji,jj)    = emp_oce(ji,jj) - wfx_ice(ji,jj) - wfx_snw(ji,jj) - wfx_err_sub(ji,jj)   ! mass flux + F/M mass flux (always ice/ocean mass exchange)
+
+
+            ! Salt flux at the ocean surface      
+            !------------------------------------------
+            sfx(ji,jj) = sfx_bog(ji,jj) + sfx_bom(ji,jj) + sfx_sum(ji,jj) + sfx_sni(ji,jj) + sfx_opw(ji,jj)   &
+               &       + sfx_res(ji,jj) + sfx_dyn(ji,jj) + sfx_bri(ji,jj) + sfx_sub(ji,jj) + sfx_lam(ji,jj)
+            
+            ! Mass of snow and ice per unit area   
+            !----------------------------------------
+            snwice_mass_b(ji,jj) = snwice_mass(ji,jj)       ! save mass from the previous ice time step
+            !                                               ! new mass per unit area
+            snwice_mass  (ji,jj) = tmask(ji,jj,1) * ( rhosn * vt_s(ji,jj) + rhoic * vt_i(ji,jj)  ) 
+            !                                               ! time evolution of snow+ice mass
+            snwice_fmass (ji,jj) = ( snwice_mass(ji,jj) - snwice_mass_b(ji,jj) ) * r1_rdtice
+            
+         END DO
+      END DO
+
+      ! Storing the transmitted variables
+      !----------------------------------
+      fr_i  (:,:)   = at_i(:,:)             ! Sea-ice fraction            
+      tn_ice(:,:,:) = t_su(:,:,:)           ! Ice surface temperature                      
+
+      ! Snow/ice albedo (only if sent to coupler, useless in forced mode)
+      !------------------------------------------------------------------
+      CALL ice_alb( t_su, h_i, h_s, ln_pnd_alb, a_ip_frac, h_ip, zalb_cs, zalb_os ) ! cloud-sky and overcast-sky ice albedos
+      !
+      alb_ice(:,:,:) = ( 1._wp - cldf_ice ) * zalb_cs(:,:,:) + cldf_ice * zalb_os(:,:,:)
+      !
+      IF( lrst_ice ) THEN                       !* write snwice_mass fields in the restart file
+         CALL update_rst( 'WRITE', kt )
+      ENDIF
+      !
+      ! output all fluxes
+      !------------------
+      !
+      ! --- salt fluxes [kg/m2/s] --- !
+      !                           ! sfxice =  sfxbog + sfxbom + sfxsum + sfxsni + sfxopw + sfxres + sfxdyn + sfxbri + sfxsub + sfxlam
+      IF( iom_use('sfxice'  ) )   CALL iom_put( "sfxice", sfx     * 1.e-03 )   ! salt flux from total ice growth/melt
+      IF( iom_use('sfxbog'  ) )   CALL iom_put( "sfxbog", sfx_bog * 1.e-03 )   ! salt flux from bottom growth
+      IF( iom_use('sfxbom'  ) )   CALL iom_put( "sfxbom", sfx_bom * 1.e-03 )   ! salt flux from bottom melting
+      IF( iom_use('sfxsum'  ) )   CALL iom_put( "sfxsum", sfx_sum * 1.e-03 )   ! salt flux from surface melting
+      IF( iom_use('sfxlam'  ) )   CALL iom_put( "sfxlam", sfx_lam * 1.e-03 )   ! salt flux from lateral melting
+      IF( iom_use('sfxsni'  ) )   CALL iom_put( "sfxsni", sfx_sni * 1.e-03 )   ! salt flux from snow ice formation
+      IF( iom_use('sfxopw'  ) )   CALL iom_put( "sfxopw", sfx_opw * 1.e-03 )   ! salt flux from open water formation
+      IF( iom_use('sfxdyn'  ) )   CALL iom_put( "sfxdyn", sfx_dyn * 1.e-03 )   ! salt flux from ridging rafting
+      IF( iom_use('sfxbri'  ) )   CALL iom_put( "sfxbri", sfx_bri * 1.e-03 )   ! salt flux from brines
+      IF( iom_use('sfxres'  ) )   CALL iom_put( "sfxres", sfx_res * 1.e-03 )   ! salt flux from undiagnosed processes
+      IF( iom_use('sfxsub'  ) )   CALL iom_put( "sfxsub", sfx_sub * 1.e-03 )   ! salt flux from sublimation
+
+      ! --- mass fluxes [kg/m2/s] --- !
+      IF( iom_use('emp_oce' ) )   CALL iom_put( "emp_oce", emp_oce )   ! emp over ocean (taking into account the snow blown away from the ice)
+      IF( iom_use('emp_ice' ) )   CALL iom_put( "emp_ice", emp_ice )   ! emp over ice   (taking into account the snow blown away from the ice)
+
+      !                           ! vfxice = vfxbog + vfxbom + vfxsum + vfxsni + vfxopw + vfxdyn + vfxres + vfxlam + vfxpnd
+      IF( iom_use('vfxice'  ) )   CALL iom_put( "vfxice" , wfx_ice )   ! mass flux from total ice growth/melt
+      IF( iom_use('vfxbog'  ) )   CALL iom_put( "vfxbog" , wfx_bog )   ! mass flux from bottom growth
+      IF( iom_use('vfxbom'  ) )   CALL iom_put( "vfxbom" , wfx_bom )   ! mass flux from bottom melt 
+      IF( iom_use('vfxsum'  ) )   CALL iom_put( "vfxsum" , wfx_sum )   ! mass flux from surface melt 
+      IF( iom_use('vfxlam'  ) )   CALL iom_put( "vfxlam" , wfx_lam )   ! mass flux from lateral melt 
+      IF( iom_use('vfxsni'  ) )   CALL iom_put( "vfxsni" , wfx_sni )   ! mass flux from snow-ice formation
+      IF( iom_use('vfxopw'  ) )   CALL iom_put( "vfxopw" , wfx_opw )   ! mass flux from growth in open water
+      IF( iom_use('vfxdyn'  ) )   CALL iom_put( "vfxdyn" , wfx_dyn )   ! mass flux from dynamics (ridging)
+      IF( iom_use('vfxres'  ) )   CALL iom_put( "vfxres" , wfx_res )   ! mass flux from undiagnosed processes 
+      IF( iom_use('vfxpnd'  ) )   CALL iom_put( "vfxpnd" , wfx_pnd )   ! mass flux from melt ponds
+      IF( iom_use('vfxsub'  ) )   CALL iom_put( "vfxsub" , wfx_ice_sub )   ! mass flux from ice sublimation (ice-atm.)
+      IF( iom_use('vfxsub_err') ) CALL iom_put( "vfxsub_err", wfx_err_sub )   ! "excess" of sublimation sent to ocean      
+
+      IF ( iom_use( "vfxthin" ) ) THEN   ! mass flux from ice growth in open water + thin ice (<20cm) => comparable to observations  
+         WHERE( hm_i(:,:) < 0.2 .AND. hm_i(:,:) > 0. ) ; z2d = wfx_bog
+         ELSEWHERE                                     ; z2d = 0._wp
+         END WHERE
+         CALL iom_put( "vfxthin", wfx_opw + z2d )
+      ENDIF
+
+      !                              ! vfxsnw = vfxsnw_sni + vfxsnw_dyn + vfxsnw_sum
+      IF( iom_use('vfxsnw'     ) )   CALL iom_put( "vfxsnw"     , wfx_snw     )   ! mass flux from total snow growth/melt
+      IF( iom_use('vfxsnw_sum' ) )   CALL iom_put( "vfxsnw_sum" , wfx_snw_sum )   ! mass flux from snow melt at the surface
+      IF( iom_use('vfxsnw_sni' ) )   CALL iom_put( "vfxsnw_sni" , wfx_snw_sni )   ! mass flux from snow melt during snow-ice formation 
+      IF( iom_use('vfxsnw_dyn' ) )   CALL iom_put( "vfxsnw_dyn" , wfx_snw_dyn )   ! mass flux from dynamics (ridging) 
+      IF( iom_use('vfxsnw_sub' ) )   CALL iom_put( "vfxsnw_sub" , wfx_snw_sub )   ! mass flux from snow sublimation (ice-atm.) 
+      IF( iom_use('vfxsnw_pre' ) )   CALL iom_put( "vfxsnw_pre" , wfx_spr     )   ! snow precip
+
+      ! --- heat fluxes [W/m2] --- !
+      !                              ! qt_atm_oi - qt_oce_ai = hfxdhc - ( dihctrp + dshctrp )
+      IF( iom_use('qsr_oce'    ) )   CALL iom_put( "qsr_oce"    , qsr_oce * ( 1._wp - at_i_b )                               )   !     solar flux at ocean surface
+      IF( iom_use('qns_oce'    ) )   CALL iom_put( "qns_oce"    , qns_oce * ( 1._wp - at_i_b ) + qemp_oce                    )   ! non-solar flux at ocean surface
+      IF( iom_use('qsr_ice'    ) )   CALL iom_put( "qsr_ice"    , SUM( qsr_ice * a_i_b, dim=3 )                              )   !     solar flux at ice surface
+      IF( iom_use('qns_ice'    ) )   CALL iom_put( "qns_ice"    , SUM( qns_ice * a_i_b, dim=3 ) + qemp_ice                   )   ! non-solar flux at ice surface
+      IF( iom_use('qtr_ice_bot') )   CALL iom_put( "qtr_ice_bot", SUM( ftr_ice * a_i_b, dim=3 )                              )   !     solar flux transmitted thru ice
+      IF( iom_use('qtr_ice_top') )   CALL iom_put( "qtr_ice_top", SUM( qsr_ice_tr * a_i_b, dim=3 )                           )   !     solar flux transmitted thru ice surface
+      IF( iom_use('qt_oce'     ) )   CALL iom_put( "qt_oce"     ,      ( qsr_oce + qns_oce ) * ( 1._wp - at_i_b ) + qemp_oce )
+      IF( iom_use('qt_ice'     ) )   CALL iom_put( "qt_ice"     , SUM( ( qns_ice + qsr_ice ) * a_i_b, dim=3 )     + qemp_ice )
+      IF( iom_use('qt_oce_ai'  ) )   CALL iom_put( "qt_oce_ai"  , hfx_out * tmask(:,:,1)                                     )   ! total heat flux at the ocean   surface: interface oce-(ice+atm) 
+      IF( iom_use('qt_atm_oi'  ) )   CALL iom_put( "qt_atm_oi"  , hfx_in * tmask(:,:,1)                                      )   ! total heat flux at the oce-ice surface: interface atm-(ice+oce) 
+      IF( iom_use('qemp_oce'   ) )   CALL iom_put( "qemp_oce"   , qemp_oce                                                   )   ! Downward Heat Flux from E-P over ocean
+      IF( iom_use('qemp_ice'   ) )   CALL iom_put( "qemp_ice"   , qemp_ice                                                   )   ! Downward Heat Flux from E-P over ice
+
+      ! heat fluxes from ice transformations
+      !                              ! hfxdhc = hfxbog + hfxbom + hfxsum + hfxopw + hfxdif + hfxsnw - ( hfxthd + hfxdyn + hfxres + hfxsub + hfxspr )
+      IF( iom_use('hfxbog'     ) )   CALL iom_put ("hfxbog"     , hfx_bog             )   ! heat flux used for ice bottom growth 
+      IF( iom_use('hfxbom'     ) )   CALL iom_put ("hfxbom"     , hfx_bom             )   ! heat flux used for ice bottom melt
+      IF( iom_use('hfxsum'     ) )   CALL iom_put ("hfxsum"     , hfx_sum             )   ! heat flux used for ice surface growth
+      IF( iom_use('hfxopw'     ) )   CALL iom_put ("hfxopw"     , hfx_opw             )   ! heat flux used for ice formation in open water
+      IF( iom_use('hfxdif'     ) )   CALL iom_put ("hfxdif"     , hfx_dif             )   ! heat flux used for ice temperature change
+      IF( iom_use('hfxsnw'     ) )   CALL iom_put ("hfxsnw"     , hfx_snw             )   ! heat flux used for snow melt 
+      IF( iom_use('hfxerr'     ) )   CALL iom_put ("hfxerr"     , hfx_err_dif         )   ! heat flux error after heat diffusion (included in hfx_out)
+
+      ! heat fluxes associated with mass exchange (freeze/melt/precip...)
+      IF( iom_use('hfxthd'     ) )   CALL iom_put ("hfxthd"     , hfx_thd             )   !  
+      IF( iom_use('hfxdyn'     ) )   CALL iom_put ("hfxdyn"     , hfx_dyn             )   !  
+      IF( iom_use('hfxres'     ) )   CALL iom_put ("hfxres"     , hfx_res             )   !  
+      IF( iom_use('hfxsub'     ) )   CALL iom_put ("hfxsub"     , hfx_sub             )   !  
+      IF( iom_use('hfxspr'     ) )   CALL iom_put ("hfxspr"     , hfx_spr             )   ! Heat flux from snow precip heat content 
+
+      ! other heat fluxes
+      IF( iom_use('hfxsensib'  ) )   CALL iom_put( "hfxsensib"  , -fhtur     * at_i_b )   ! Sensible oceanic heat flux
+      IF( iom_use('hfxcndbot'  ) )   CALL iom_put( "hfxcndbot"  , diag_fc_bo * at_i_b )   ! Bottom conduction flux
+      IF( iom_use('hfxcndtop'  ) )   CALL iom_put( "hfxcndtop"  , diag_fc_su * at_i_b )   ! Surface conduction flux
+
+      ! diags
+      IF( iom_use('hfxdhc'     ) )   CALL iom_put ("hfxdhc"     , diag_heat           )   ! Heat content variation in snow and ice 
+      !
+      ! controls
+      !---------
+#if ! defined key_agrif
+      IF( ln_icediachk .AND. .NOT. ln_bdy)   CALL ice_cons_final('iceupdate')                                       ! conservation
+#endif
+      IF( ln_icectl                      )   CALL ice_prt       (kt, iiceprt, jiceprt, 3, 'Final state ice_update') ! prints
+      IF( ln_ctl                         )   CALL ice_prt3D     ('iceupdate')                                       ! prints
+      IF( ln_timing                      )   CALL timing_stop   ('ice_update')                                      ! timing
+      !
+   END SUBROUTINE ice_update_flx
+
+
+   SUBROUTINE ice_update_tau( kt, pu_oce, pv_oce )
+      !!-------------------------------------------------------------------
+      !!                ***  ROUTINE ice_update_tau ***
+      !!  
+      !! ** Purpose : Update the ocean surface stresses due to the ice
+      !!         
+      !! ** Action  : * at each ice time step (every nn_fsbc time step):
+      !!                - compute the modulus of ice-ocean relative velocity 
+      !!                  (*rho*Cd) at T-point (C-grid) or I-point (B-grid)
+      !!                      tmod_io = rhoco * | U_ice-U_oce |
+      !!                - update the modulus of stress at ocean surface
+      !!                      taum = (1-a) * taum + a * tmod_io * | U_ice-U_oce |
+      !!              * at each ocean time step (every kt): 
+      !!                  compute linearized ice-ocean stresses as
+      !!                      Utau = tmod_io * | U_ice - pU_oce |
+      !!                using instantaneous current ocean velocity (usually before)
+      !!
+      !!    NB: - ice-ocean rotation angle no more allowed
+      !!        - here we make an approximation: taum is only computed every ice time step
+      !!          This avoids mutiple average to pass from T -> U,V grids and next from U,V grids 
+      !!          to T grid. taum is used in TKE and GLS, which should not be too sensitive to this approximaton...
+      !!
+      !! ** Outputs : - utau, vtau   : surface ocean i- and j-stress (u- & v-pts) updated with ice-ocean fluxes
+      !!              - taum         : modulus of the surface ocean stress (T-point) updated with ice-ocean fluxes
+      !!---------------------------------------------------------------------
+      INTEGER ,                     INTENT(in) ::   kt               ! ocean time-step index
+      REAL(wp), DIMENSION(jpi,jpj), INTENT(in) ::   pu_oce, pv_oce   ! surface ocean currents
+      !
+      INTEGER  ::   ji, jj   ! dummy loop indices
+      REAL(wp) ::   zat_u, zutau_ice, zu_t, zmodt   ! local scalar
+      REAL(wp) ::   zat_v, zvtau_ice, zv_t, zrhoco  !   -      -
+      !!---------------------------------------------------------------------
+      IF( ln_timing )   CALL timing_start('ice_update_tau')
+
+      IF( kt == nit000 .AND. lwp ) THEN
+         WRITE(numout,*)
+         WRITE(numout,*)'ice_update_tau: update stress at the ice-ocean interface'
+         WRITE(numout,*)'~~~~~~~~~~~~~~'
+      ENDIF
+
+      zrhoco = rau0 * rn_cio
+      !
+      IF( MOD( kt-1, nn_fsbc ) == 0 ) THEN     !==  Ice time-step only  ==!   (i.e. surface module time-step)
+         DO jj = 2, jpjm1                             !* update the modulus of stress at ocean surface (T-point)
+            DO ji = fs_2, fs_jpim1
+               !                                               ! 2*(U_ice-U_oce) at T-point
+               zu_t = u_ice(ji,jj) + u_ice(ji-1,jj) - u_oce(ji,jj) - u_oce(ji-1,jj)   
+               zv_t = v_ice(ji,jj) + v_ice(ji,jj-1) - v_oce(ji,jj) - v_oce(ji,jj-1) 
+               !                                              ! |U_ice-U_oce|^2
+               zmodt =  0.25_wp * (  zu_t * zu_t + zv_t * zv_t  )
+               !                                               ! update the ocean stress modulus
+               taum(ji,jj) = ( 1._wp - at_i(ji,jj) ) * taum(ji,jj) + at_i(ji,jj) * zrhoco * zmodt
+               tmod_io(ji,jj) = zrhoco * SQRT( zmodt )          ! rhoco * |U_ice-U_oce| at T-point
+            END DO
+         END DO
+         CALL lbc_lnk_multi( taum, 'T', 1., tmod_io, 'T', 1. )
+         !
+         utau_oce(:,:) = utau(:,:)                    !* save the air-ocean stresses at ice time-step
+         vtau_oce(:,:) = vtau(:,:)
+         !
+      ENDIF
+      !
+      !                                      !==  every ocean time-step  ==!
+      !
+      DO jj = 2, jpjm1                                !* update the stress WITHOUT an ice-ocean rotation angle
+         DO ji = fs_2, fs_jpim1   ! Vect. Opt.
+            zat_u  = ( at_i(ji,jj) + at_i(ji+1,jj) ) * 0.5_wp   ! ice area at u and V-points
+            zat_v  = ( at_i(ji,jj) + at_i(ji,jj+1) ) * 0.5_wp
+            !                                                   ! linearized quadratic drag formulation
+            zutau_ice   = 0.5_wp * ( tmod_io(ji,jj) + tmod_io(ji+1,jj) ) * ( u_ice(ji,jj) - pu_oce(ji,jj) )
+            zvtau_ice   = 0.5_wp * ( tmod_io(ji,jj) + tmod_io(ji,jj+1) ) * ( v_ice(ji,jj) - pv_oce(ji,jj) )
+            !                                                   ! stresses at the ocean surface
+            utau(ji,jj) = ( 1._wp - zat_u ) * utau_oce(ji,jj) + zat_u * zutau_ice
+            vtau(ji,jj) = ( 1._wp - zat_v ) * vtau_oce(ji,jj) + zat_v * zvtau_ice
+         END DO
+      END DO
+      CALL lbc_lnk_multi( utau, 'U', -1., vtau, 'V', -1. )   ! lateral boundary condition
+      !
+      IF( ln_timing )   CALL timing_stop('ice_update_tau')
+      !  
+   END SUBROUTINE ice_update_tau
+
+
+   SUBROUTINE ice_update_init
+      !!-------------------------------------------------------------------
+      !!                  ***  ROUTINE ice_update_init  ***
+      !!             
+      !! ** Purpose :   ???
+      !!
+      !!-------------------------------------------------------------------
+      INTEGER  ::   ji, jj, jk               ! dummy loop indices
+      REAL(wp) ::   zcoefu, zcoefv, zcoeff   ! local scalar
+      !!-------------------------------------------------------------------
+      !
+      IF(lwp) WRITE(numout,*)
+      IF(lwp) WRITE(numout,*) 'ice_update_init: ???? '
+      IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~~~'
+      !
+      !                                      ! allocate ice_update array
+      IF( ice_update_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'ice_update_init : unable to allocate standard arrays' )
+      !
+      CALL update_rst( 'READ' )  !* read or initialize all required files
+      !
+   END SUBROUTINE ice_update_init
+
+
+   SUBROUTINE update_rst( cdrw, kt )
+      !!---------------------------------------------------------------------
+      !!                   ***  ROUTINE rhg_evp_rst  ***
+      !!                     
+      !! ** Purpose :   Read or write RHG file in restart file
+      !!
+      !! ** Method  :   use of IOM library
+      !!----------------------------------------------------------------------
+      CHARACTER(len=*) , INTENT(in) ::   cdrw   ! "READ"/"WRITE" flag
+      INTEGER, OPTIONAL, INTENT(in) ::   kt     ! ice time-step
+      !
+      INTEGER  ::   iter   ! local integer
+      INTEGER  ::   id1    ! local integer
+      !!----------------------------------------------------------------------
+      !
+      IF( TRIM(cdrw) == 'READ' ) THEN        ! Read/initialize
+         !                                   ! ---------------
+         IF( ln_rstart ) THEN                   !* Read the restart file
+            !
+            id1 = iom_varid( numrir, 'snwice_mass' , ldstop = .FALSE. )
+            !
+            IF( id1 > 0 ) THEN                       ! fields exist
+               CALL iom_get( numrir, jpdom_autoglo, 'snwice_mass'  , snwice_mass   )
+               CALL iom_get( numrir, jpdom_autoglo, 'snwice_mass_b', snwice_mass_b )
+            ELSE                                     ! start from rest
+               IF(lwp) WRITE(numout,*) '   ==>>   previous run without snow-ice mass output then set it'
+               snwice_mass  (:,:) = tmask(:,:,1) * ( rhosn * vt_s(:,:) + rhoic * vt_i(:,:) )
+               snwice_mass_b(:,:) = snwice_mass(:,:)
+            ENDIF
+         ELSE                                   !* Start from rest
+            IF(lwp) WRITE(numout,*) '   ==>>   start from rest: set the snow-ice mass'
+            snwice_mass  (:,:) = tmask(:,:,1) * ( rhosn * vt_s(:,:) + rhoic * vt_i(:,:) )
+            snwice_mass_b(:,:) = snwice_mass(:,:)
+         ENDIF
+         !
+      ELSEIF( TRIM(cdrw) == 'WRITE' ) THEN   ! Create restart file
+         !                                   ! -------------------
+         IF(lwp) WRITE(numout,*) '---- update-rst ----'
+         iter = kt + nn_fsbc - 1             ! ice restarts are written at kt == nitrst - nn_fsbc + 1
+         !
+         CALL iom_rstput( iter, nitrst, numriw, 'snwice_mass'  , snwice_mass   )
+         CALL iom_rstput( iter, nitrst, numriw, 'snwice_mass_b', snwice_mass_b )
+         !
+      ENDIF
+      !
+   END SUBROUTINE update_rst
+
+#else
+   !!----------------------------------------------------------------------
+   !!   Default option         Dummy module           NO SI3 sea-ice model
+   !!----------------------------------------------------------------------
+#endif 
+
+   !!======================================================================
+END MODULE iceupdate
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/ICE_SRC/icevar.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/ICE_SRC/icevar.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/ICE_SRC/icevar.F90	(revision 9570)
@@ -0,0 +1,876 @@
+MODULE icevar
+   !!======================================================================
+   !!                       ***  MODULE icevar ***
+   !!   sea-ice:     Different sets of ice model variables 
+   !!                   how to switch from one to another
+   !!
+   !!                 There are three sets of variables
+   !!                 VGLO : global variables of the model
+   !!                        - v_i (jpi,jpj,jpl)
+   !!                        - v_s (jpi,jpj,jpl)
+   !!                        - a_i (jpi,jpj,jpl)
+   !!                        - t_s (jpi,jpj,jpl)
+   !!                        - e_i (jpi,jpj,nlay_i,jpl)
+   !!                        - sv_i(jpi,jpj,jpl)
+   !!                        - oa_i(jpi,jpj,jpl)
+   !!                 VEQV : equivalent variables sometimes used in the model
+   !!                        - h_i(jpi,jpj,jpl)
+   !!                        - h_s(jpi,jpj,jpl)
+   !!                        - t_i(jpi,jpj,nlay_i,jpl)
+   !!                        ...
+   !!                 VAGG : aggregate variables, averaged/summed over all
+   !!                        thickness categories
+   !!                        - vt_i(jpi,jpj)
+   !!                        - vt_s(jpi,jpj)
+   !!                        - at_i(jpi,jpj)
+   !!                        - et_s(jpi,jpj)  total snow heat content
+   !!                        - et_i(jpi,jpj)  total ice thermal content 
+   !!                        - sm_i(jpi,jpj)  mean ice salinity
+   !!                        - tm_i(jpi,jpj)  mean ice temperature
+   !!                        - tm_s(jpi,jpj)  mean snw temperature
+   !!======================================================================
+   !! History :   -   ! 2006-01 (M. Vancoppenolle) Original code
+   !!            3.4  ! 2011-02 (G. Madec) dynamical allocation
+   !!            3.5  ! 2012    (M. Vancoppenolle)  add ice_var_itd
+   !!            3.6  ! 2014-01 (C. Rousset) add ice_var_zapsmall, rewrite ice_var_itd
+   !!----------------------------------------------------------------------
+#if defined key_si3
+   !!----------------------------------------------------------------------
+   !!   'key_si3'                                       SI3 sea-ice model
+   !!----------------------------------------------------------------------
+   !!   ice_var_agg       : integrate variables over layers and categories
+   !!   ice_var_glo2eqv   : transform from VGLO to VEQV
+   !!   ice_var_eqv2glo   : transform from VEQV to VGLO
+   !!   ice_var_salprof   : salinity profile in the ice
+   !!   ice_var_salprof1d : salinity profile in the ice 1D
+   !!   ice_var_zapsmall  : remove very small area and volume
+   !!   ice_var_itd       : convert 1-cat to jpl-cat
+   !!   ice_var_itd2      : convert N-cat to jpl-cat
+   !!   ice_var_bv        : brine volume
+   !!   ice_var_enthalpy  : compute ice and snow enthalpies from temperature
+   !!----------------------------------------------------------------------
+   USE dom_oce        ! ocean space and time domain
+   USE phycst         ! physical constants (ocean directory) 
+   USE sbc_oce , ONLY : sss_m
+   USE ice            ! sea-ice: variables
+   USE ice1D          ! sea-ice: thermodynamics variables
+   !
+   USE in_out_manager ! I/O manager
+   USE lib_mpp        ! MPP library
+   USE lib_fortran    ! fortran utilities (glob_sum + no signed zero)
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   ice_var_agg          
+   PUBLIC   ice_var_glo2eqv      
+   PUBLIC   ice_var_eqv2glo      
+   PUBLIC   ice_var_salprof      
+   PUBLIC   ice_var_salprof1d    
+   PUBLIC   ice_var_zapsmall
+   PUBLIC   ice_var_itd
+   PUBLIC   ice_var_itd2
+   PUBLIC   ice_var_bv           
+   PUBLIC   ice_var_enthalpy           
+
+   !!----------------------------------------------------------------------
+   !! NEMO/ICE 4.0 , NEMO Consortium (2017)
+   !! $Id: icevar.F90 8422 2017-08-08 13:58:05Z clem $
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE ice_var_agg( kn )
+      !!-------------------------------------------------------------------
+      !!                ***  ROUTINE ice_var_agg  ***
+      !!
+      !! ** Purpose :   aggregates ice-thickness-category variables to 
+      !!              all-ice variables, i.e. it turns VGLO into VAGG
+      !!-------------------------------------------------------------------
+      INTEGER, INTENT( in ) ::   kn     ! =1 state variables only
+      !                                 ! >1 state variables + others
+      !
+      INTEGER ::   ji, jj, jk, jl   ! dummy loop indices
+      REAL(wp), ALLOCATABLE, DIMENSION(:,:) ::   z1_at_i, z1_vt_i, z1_vt_s
+      !!-------------------------------------------------------------------
+      !
+      !                                      ! integrated values
+      vt_i(:,:) =       SUM( v_i(:,:,:)           , dim=3 )
+      vt_s(:,:) =       SUM( v_s(:,:,:)           , dim=3 )
+      at_i(:,:) =       SUM( a_i(:,:,:)           , dim=3 )
+      et_s(:,:)  = SUM( SUM( e_s(:,:,:,:), dim=4 ), dim=3 )
+      et_i(:,:)  = SUM( SUM( e_i(:,:,:,:), dim=4 ), dim=3 )
+      !
+      at_ip(:,:) = SUM( a_ip(:,:,:), dim=3 ) ! melt ponds
+      vt_ip(:,:) = SUM( v_ip(:,:,:), dim=3 )
+      !
+      ato_i(:,:) = 1._wp - at_i(:,:)         ! open water fraction  
+
+      IF( kn > 1 ) THEN
+         !
+         ALLOCATE( z1_at_i(jpi,jpj) , z1_vt_i(jpi,jpj) , z1_vt_s(jpi,jpj) )
+         WHERE( at_i(:,:) > epsi20 )   ;   z1_at_i(:,:) = 1._wp / at_i(:,:)
+         ELSEWHERE                     ;   z1_at_i(:,:) = 0._wp
+         END WHERE
+         WHERE( vt_i(:,:) > epsi20 )   ;   z1_vt_i(:,:) = 1._wp / vt_i(:,:)
+         ELSEWHERE                     ;   z1_vt_i(:,:) = 0._wp
+         END WHERE
+         WHERE( vt_s(:,:) > epsi20 )   ;   z1_vt_s(:,:) = 1._wp / vt_s(:,:)
+         ELSEWHERE                     ;   z1_vt_s(:,:) = 0._wp
+         END WHERE
+         !
+         !                          ! mean ice/snow thickness
+         hm_i(:,:) = vt_i(:,:) * z1_at_i(:,:)
+         hm_s(:,:) = vt_s(:,:) * z1_at_i(:,:)
+         !         
+         !                          ! mean temperature (K), salinity and age
+         tm_su(:,:) = SUM( t_su(:,:,:) * a_i(:,:,:) , dim=3 ) * z1_at_i(:,:)
+         tm_si(:,:) = SUM( t_si(:,:,:) * a_i(:,:,:) , dim=3 ) * z1_at_i(:,:)
+         om_i (:,:) = SUM( oa_i(:,:,:)              , dim=3 ) * z1_at_i(:,:)
+         sm_i (:,:) = SUM( sv_i(:,:,:)              , dim=3 ) * z1_vt_i(:,:)
+         !
+         tm_i(:,:) = 0._wp
+         tm_s(:,:) = 0._wp
+         DO jl = 1, jpl
+            DO jk = 1, nlay_i
+               tm_i(:,:) = tm_i(:,:) + r1_nlay_i * t_i (:,:,jk,jl) * v_i(:,:,jl) * z1_vt_i(:,:)
+            END DO
+            DO jk = 1, nlay_s
+               tm_s(:,:) = tm_s(:,:) + r1_nlay_s * t_s (:,:,jk,jl) * v_s(:,:,jl) * z1_vt_s(:,:)
+            END DO
+         END DO
+         !
+         !                           ! put rt0 where there is no ice
+         WHERE( at_i(:,:)<=epsi20 )
+            tm_su(:,:) = rt0
+            tm_si(:,:) = rt0
+            tm_i (:,:) = rt0
+            tm_s (:,:) = rt0
+         END WHERE
+
+         DEALLOCATE( z1_at_i , z1_vt_i , z1_vt_s )
+      ENDIF
+      !
+   END SUBROUTINE ice_var_agg
+
+
+   SUBROUTINE ice_var_glo2eqv
+      !!-------------------------------------------------------------------
+      !!                ***  ROUTINE ice_var_glo2eqv ***
+      !!
+      !! ** Purpose :   computes equivalent variables as function of  
+      !!              global variables, i.e. it turns VGLO into VEQV
+      !!-------------------------------------------------------------------
+      INTEGER  ::   ji, jj, jk, jl   ! dummy loop indices
+      REAL(wp) ::   ze_i             ! local scalars
+      REAL(wp) ::   ze_s, ztmelts, zbbb, zccc       !   -      -
+      REAL(wp) ::   zhmax, z1_zhmax                 !   -      -
+      REAL(wp) ::   zlay_i, zlay_s                  !   -      -
+      REAL(wp), DIMENSION(jpi,jpj,jpl) ::   z1_a_i, z1_v_i
+      !!-------------------------------------------------------------------
+
+!!gm Question 2:  It is possible to define existence of sea-ice in a common way between 
+!!                ice area and ice volume ?
+!!                the idea is to be able to define one for all at the begining of this routine
+!!                a criteria for icy area (i.e. a_i > epsi20 and v_i > epsi20 )
+
+      !---------------------------------------------------------------
+      ! Ice thickness, snow thickness, ice salinity, ice age and ponds
+      !---------------------------------------------------------------
+      !                                            !--- inverse of the ice area
+      WHERE( a_i(:,:,:) > epsi20 )   ;   z1_a_i(:,:,:) = 1._wp / a_i(:,:,:)
+      ELSEWHERE                      ;   z1_a_i(:,:,:) = 0._wp
+      END WHERE
+      !
+      WHERE( v_i(:,:,:) > epsi20 )   ;   z1_v_i(:,:,:) = 1._wp / v_i(:,:,:)
+      ELSEWHERE                      ;   z1_v_i(:,:,:) = 0._wp
+      END WHERE
+      !                                           !--- ice thickness
+      h_i(:,:,:) = v_i (:,:,:) * z1_a_i(:,:,:)
+
+      zhmax    =          hi_max(jpl)
+      z1_zhmax =  1._wp / hi_max(jpl)               
+      WHERE( h_i(:,:,jpl) > zhmax )   ! bound h_i by hi_max (i.e. 99 m) with associated update of ice area
+         h_i  (:,:,jpl) = zhmax
+         a_i   (:,:,jpl) = v_i(:,:,jpl) * z1_zhmax 
+         z1_a_i(:,:,jpl) = zhmax * z1_v_i(:,:,jpl)
+      END WHERE
+      !                                           !--- snow thickness
+      h_s(:,:,:) = v_s (:,:,:) * z1_a_i(:,:,:)
+      !                                           !--- ice age      
+      o_i(:,:,:) = oa_i(:,:,:) * z1_a_i(:,:,:)
+      !                                           !--- pond fraction and thickness      
+      a_ip_frac(:,:,:) = a_ip(:,:,:) * z1_a_i(:,:,:)
+      WHERE( a_ip_frac(:,:,:) > epsi20 )   ;   h_ip(:,:,:) = v_ip(:,:,:) * z1_a_i(:,:,:) / a_ip_frac(:,:,:)
+      ELSEWHERE                            ;   h_ip(:,:,:) = 0._wp
+      END WHERE
+      !
+      !                                           !---  salinity (with a minimum value imposed everywhere)     
+      IF( nn_icesal == 2 ) THEN
+         WHERE( v_i(:,:,:) > epsi20 )   ;   s_i(:,:,:) = MAX( rn_simin , MIN( rn_simax, sv_i(:,:,:) * z1_v_i(:,:,:) ) )
+         ELSEWHERE                      ;   s_i(:,:,:) = rn_simin
+         END WHERE
+      ENDIF
+      CALL ice_var_salprof   ! salinity profile
+
+      !-------------------
+      ! Ice temperature   [K]   (with a minimum value (rt0 - 100.))
+      !-------------------
+      zlay_i   = REAL( nlay_i , wp )    ! number of layers
+      DO jl = 1, jpl
+         DO jk = 1, nlay_i
+            DO jj = 1, jpj
+               DO ji = 1, jpi
+                  IF ( v_i(ji,jj,jl) > epsi20 ) THEN     !--- icy area 
+                     !
+                     ze_i             =   e_i (ji,jj,jk,jl) * z1_v_i(ji,jj,jl) * zlay_i               ! Energy of melting e(S,T) [J.m-3]
+                     ztmelts          = - sz_i(ji,jj,jk,jl) * tmut                                 ! Ice layer melt temperature [C]
+                     ! Conversion q(S,T) -> T (second order equation)
+                     zbbb             = ( rcp - cpic ) * ztmelts + ze_i * r1_rhoic - lfus
+                     zccc             = SQRT( MAX( zbbb * zbbb - 4._wp * cpic * lfus * ztmelts , 0._wp) )
+                     t_i(ji,jj,jk,jl) = MAX( -100._wp , MIN( -( zbbb + zccc ) * 0.5_wp * r1_cpic , ztmelts ) ) + rt0   ! [K] with bounds: -100 < t_i < ztmelts
+                     !
+                  ELSE                                !--- no ice
+                     t_i(ji,jj,jk,jl) = rt0
+                  ENDIF
+               END DO
+            END DO
+         END DO
+      END DO
+
+      !--------------------
+      ! Snow temperature   [K]   (with a minimum value (rt0 - 100.))
+      !--------------------
+      zlay_s = REAL( nlay_s , wp )
+      DO jk = 1, nlay_s
+         WHERE( v_s(:,:,:) > epsi20 )        !--- icy area
+            t_s(:,:,jk,:) = rt0 + MAX( -100._wp ,  &
+                 &                MIN( r1_cpic * ( -r1_rhosn * ( e_s(:,:,jk,:) / v_s(:,:,:) * zlay_s ) + lfus ) , 0._wp ) )
+         ELSEWHERE                           !--- no ice
+            t_s(:,:,jk,:) = rt0
+         END WHERE
+      END DO
+      !
+      ! integrated values 
+      vt_i (:,:) = SUM( v_i, dim=3 )
+      vt_s (:,:) = SUM( v_s, dim=3 )
+      at_i (:,:) = SUM( a_i, dim=3 )
+      !
+   END SUBROUTINE ice_var_glo2eqv
+
+
+   SUBROUTINE ice_var_eqv2glo
+      !!-------------------------------------------------------------------
+      !!                ***  ROUTINE ice_var_eqv2glo ***
+      !!
+      !! ** Purpose :   computes global variables as function of 
+      !!              equivalent variables,  i.e. it turns VEQV into VGLO
+      !!-------------------------------------------------------------------
+      !
+      v_i (:,:,:) = h_i (:,:,:) * a_i (:,:,:)
+      v_s (:,:,:) = h_s (:,:,:) * a_i (:,:,:)
+      sv_i(:,:,:) = s_i (:,:,:) * v_i (:,:,:)
+      v_ip(:,:,:) = h_ip(:,:,:) * a_ip(:,:,:)
+      !
+   END SUBROUTINE ice_var_eqv2glo
+
+
+   SUBROUTINE ice_var_salprof
+      !!-------------------------------------------------------------------
+      !!                ***  ROUTINE ice_var_salprof ***
+      !!
+      !! ** Purpose :   computes salinity profile in function of bulk salinity     
+      !!
+      !! ** Method  : If bulk salinity greater than zsi1, 
+      !!              the profile is assumed to be constant (S_inf)
+      !!              If bulk salinity lower than zsi0,
+      !!              the profile is linear with 0 at the surface (S_zero)
+      !!              If it is between zsi0 and zsi1, it is a
+      !!              alpha-weighted linear combination of s_inf and s_zero
+      !!
+      !! ** References : Vancoppenolle et al., 2007
+      !!-------------------------------------------------------------------
+      INTEGER  ::   ji, jj, jk, jl   ! dummy loop index
+      REAL(wp) ::   zsal, z1_dS
+      REAL(wp) ::   zargtemp , zs0, zs
+      REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) ::   z_slope_s, zalpha    ! case 2 only
+      REAL(wp), PARAMETER :: zsi0 = 3.5_wp
+      REAL(wp), PARAMETER :: zsi1 = 4.5_wp
+      !!-------------------------------------------------------------------
+
+!!gm Question: Remove the option 3 ?  How many years since it last use ? 
+
+      SELECT CASE ( nn_icesal )
+      !
+      !               !---------------------------------------!
+      CASE( 1 )       !  constant salinity in time and space  !
+         !            !---------------------------------------!
+         sz_i(:,:,:,:) = rn_icesal
+         s_i (:,:,:)   = rn_icesal
+         !
+         !            !---------------------------------------------!
+      CASE( 2 )       !  time varying salinity with linear profile  !
+         !            !---------------------------------------------!
+         !
+         ALLOCATE( z_slope_s(jpi,jpj,jpl) , zalpha(jpi,jpj,jpl) )
+         !
+         DO jl = 1, jpl
+            DO jk = 1, nlay_i
+               sz_i(:,:,jk,jl)  = s_i(:,:,jl)
+            END DO
+         END DO
+         !                                      ! Slope of the linear profile 
+         WHERE( h_i(:,:,:) > epsi20 )   ;   z_slope_s(:,:,:) = 2._wp * s_i(:,:,:) / h_i(:,:,:)
+         ELSEWHERE                      ;   z_slope_s(:,:,:) = 0._wp
+         END WHERE
+         !
+         z1_dS = 1._wp / ( zsi1 - zsi0 )
+         DO jl = 1, jpl
+            DO jj = 1, jpj
+               DO ji = 1, jpi
+                  zalpha(ji,jj,jl) = MAX(  0._wp , MIN( ( zsi1 - s_i(ji,jj,jl) ) * z1_dS , 1._wp )  )
+                  !                             ! force a constant profile when SSS too low (Baltic Sea)
+                  IF( 2._wp * s_i(ji,jj,jl) >= sss_m(ji,jj) )   zalpha(ji,jj,jl) = 0._wp  
+               END DO
+            END DO
+         END DO
+         !
+         ! Computation of the profile
+         DO jl = 1, jpl
+            DO jk = 1, nlay_i
+               DO jj = 1, jpj
+                  DO ji = 1, jpi
+                     !                          ! linear profile with 0 surface value
+                     zs0 = z_slope_s(ji,jj,jl) * ( REAL(jk,wp) - 0.5_wp ) * h_i(ji,jj,jl) * r1_nlay_i
+                     zs  = zalpha(ji,jj,jl) * zs0 + ( 1._wp - zalpha(ji,jj,jl) ) * s_i(ji,jj,jl)     ! weighting the profile
+                     sz_i(ji,jj,jk,jl) = MIN( rn_simax, MAX( zs, rn_simin ) )
+                  END DO
+               END DO
+            END DO
+         END DO
+         !
+         DEALLOCATE( z_slope_s , zalpha )
+         !
+         !            !-------------------------------------------!
+      CASE( 3 )       ! constant salinity with a fix profile      ! (Schwarzacher (1959) multiyear salinity profile
+         !            !-------------------------------------------!                                   (mean = 2.30)
+         !
+         s_i(:,:,:) = 2.30_wp
+!!gm Remark: if we keep the case 3, then compute an store one for all time-step
+!!           a array  S_prof(1:nlay_i) containing the calculation and just do:
+!         DO jk = 1, nlay_i
+!            sz_i(:,:,jk,:) = S_prof(jk)
+!         END DO
+!!gm end
+         !
+         DO jl = 1, jpl
+            DO jk = 1, nlay_i
+               zargtemp  = ( REAL(jk,wp) - 0.5_wp ) * r1_nlay_i
+               sz_i(:,:,jk,jl) =  1.6_wp * (  1._wp - COS( rpi * zargtemp**(0.407_wp/(0.573_wp+zargtemp)) )  )
+            END DO
+         END DO
+         !
+      END SELECT
+      !
+   END SUBROUTINE ice_var_salprof
+
+
+   SUBROUTINE ice_var_salprof1d
+      !!-------------------------------------------------------------------
+      !!                  ***  ROUTINE ice_var_salprof1d  ***
+      !!
+      !! ** Purpose :   1d computation of the sea ice salinity profile
+      !!                Works with 1d vectors and is used by thermodynamic modules
+      !!-------------------------------------------------------------------
+      INTEGER  ::   ji, jk    ! dummy loop indices
+      REAL(wp) ::   zargtemp, zsal, z1_dS   ! local scalars
+      REAL(wp) ::   zs, zs0              !   -      -
+      !
+      REAL(wp), ALLOCATABLE, DIMENSION(:) ::   z_slope_s, zalpha   !
+      REAL(wp), PARAMETER :: zsi0 = 3.5_wp
+      REAL(wp), PARAMETER :: zsi1 = 4.5_wp
+      !!-------------------------------------------------------------------
+      !
+      SELECT CASE ( nn_icesal )
+      !
+      !               !---------------------------------------!
+      CASE( 1 )       !  constant salinity in time and space  !
+         !            !---------------------------------------!
+         sz_i_1d(1:npti,:) = rn_icesal
+         !
+         !            !---------------------------------------------!
+      CASE( 2 )       !  time varying salinity with linear profile  !
+         !            !---------------------------------------------!
+         !
+         ALLOCATE( z_slope_s(jpij), zalpha(jpij) )
+         !
+         !                                      ! Slope of the linear profile 
+         WHERE( h_i_1d(1:npti) > epsi20 )   ;   z_slope_s(1:npti) = 2._wp * s_i_1d(1:npti) / h_i_1d(1:npti)
+         ELSEWHERE                          ;   z_slope_s(1:npti) = 0._wp
+         END WHERE
+         
+         z1_dS = 1._wp / ( zsi1 - zsi0 )
+         DO ji = 1, npti
+            zalpha(ji) = MAX(  0._wp , MIN(  ( zsi1 - s_i_1d(ji) ) * z1_dS , 1._wp  )  )
+            !                             ! force a constant profile when SSS too low (Baltic Sea)
+            IF( 2._wp * s_i_1d(ji) >= sss_1d(ji) )   zalpha(ji) = 0._wp
+         END DO
+         !
+         ! Computation of the profile
+         DO jk = 1, nlay_i
+            DO ji = 1, npti
+               !                          ! linear profile with 0 surface value
+               zs0 = z_slope_s(ji) * ( REAL(jk,wp) - 0.5_wp ) * h_i_1d(ji) * r1_nlay_i
+               zs  = zalpha(ji) * zs0 + ( 1._wp - zalpha(ji) ) * s_i_1d(ji)
+               sz_i_1d(ji,jk) = MIN( rn_simax , MAX( zs , rn_simin ) )
+            END DO
+         END DO
+         !
+         DEALLOCATE( z_slope_s, zalpha )
+
+         !            !-------------------------------------------!
+      CASE( 3 )       ! constant salinity with a fix profile      ! (Schwarzacher (1959) multiyear salinity profile
+         !            !-------------------------------------------!                                   (mean = 2.30)
+         !
+         s_i_1d(1:npti) = 2.30_wp
+         !
+!!gm cf remark in ice_var_salprof routine, CASE( 3 )
+         DO jk = 1, nlay_i
+            zargtemp  = ( REAL(jk,wp) - 0.5_wp ) * r1_nlay_i
+            zsal =  1.6_wp * ( 1._wp - COS( rpi * zargtemp**( 0.407_wp / ( 0.573_wp + zargtemp ) ) ) )
+            DO ji = 1, npti
+               sz_i_1d(ji,jk) = zsal
+            END DO
+         END DO
+         !
+      END SELECT
+      !
+   END SUBROUTINE ice_var_salprof1d
+
+
+   SUBROUTINE ice_var_zapsmall
+      !!-------------------------------------------------------------------
+      !!                   ***  ROUTINE ice_var_zapsmall ***
+      !!
+      !! ** Purpose :   Remove too small sea ice areas and correct fluxes
+      !!-------------------------------------------------------------------
+      INTEGER  ::   ji, jj, jl, jk   ! dummy loop indices
+      REAL(wp), DIMENSION(jpi,jpj) ::   zswitch
+      !!-------------------------------------------------------------------
+      !
+      DO jl = 1, jpl       !==  loop over the categories  ==!
+         !
+         !-----------------------------------------------------------------
+         ! Zap ice energy and use ocean heat to melt ice
+         !-----------------------------------------------------------------
+         WHERE( a_i(:,:,jl) > epsi10 )   ;   h_i(:,:,jl) = v_i(:,:,jl) / a_i(:,:,jl)
+         ELSEWHERE                       ;   h_i(:,:,jl) = 0._wp
+         END WHERE
+         !
+         WHERE( a_i(:,:,jl) < epsi10 .OR. v_i(:,:,jl) < epsi10 .OR. h_i(:,:,jl) < epsi10 )   ;   zswitch(:,:) = 0._wp
+         ELSEWHERE                                                                           ;   zswitch(:,:) = 1._wp
+         END WHERE
+         !
+         DO jk = 1, nlay_i
+            DO jj = 1 , jpj
+               DO ji = 1 , jpi
+                  ! update exchanges with ocean
+                  hfx_res(ji,jj)   = hfx_res(ji,jj) - (1._wp - zswitch(ji,jj) ) * e_i(ji,jj,jk,jl) * r1_rdtice ! W.m-2 <0
+                  e_i(ji,jj,jk,jl) = e_i(ji,jj,jk,jl) * zswitch(ji,jj)
+                  t_i(ji,jj,jk,jl) = t_i(ji,jj,jk,jl) * zswitch(ji,jj) + rt0 * ( 1._wp - zswitch(ji,jj) )
+               END DO
+            END DO
+         END DO
+         !
+         DO jk = 1, nlay_s
+            DO jj = 1 , jpj
+               DO ji = 1 , jpi
+                  ! update exchanges with ocean
+                  hfx_res(ji,jj)   = hfx_res(ji,jj) - (1._wp - zswitch(ji,jj) ) * e_s(ji,jj,jk,jl) * r1_rdtice ! W.m-2 <0
+                  e_s(ji,jj,jk,jl) = e_s(ji,jj,jk,jl) * zswitch(ji,jj)
+                  t_s(ji,jj,jk,jl) = t_s(ji,jj,jk,jl) * zswitch(ji,jj) + rt0 * ( 1._wp - zswitch(ji,jj) )
+               END DO
+            END DO
+         END DO
+         !
+         DO jj = 1 , jpj
+            DO ji = 1 , jpi
+               ! update exchanges with ocean
+               sfx_res(ji,jj)  = sfx_res(ji,jj) + (1._wp - zswitch(ji,jj) ) * sv_i(ji,jj,jl)   * rhoic * r1_rdtice
+               wfx_res(ji,jj)  = wfx_res(ji,jj) + (1._wp - zswitch(ji,jj) ) * v_i (ji,jj,jl)   * rhoic * r1_rdtice
+               wfx_res(ji,jj)  = wfx_res(ji,jj) + (1._wp - zswitch(ji,jj) ) * v_s (ji,jj,jl)   * rhosn * r1_rdtice
+               !
+               !-----------------------------------------------------------------
+               ! zap ice and snow volume, add water and salt to ocean
+               !-----------------------------------------------------------------
+               a_i  (ji,jj,jl) = a_i (ji,jj,jl) * zswitch(ji,jj)
+               v_i  (ji,jj,jl) = v_i (ji,jj,jl) * zswitch(ji,jj)
+               v_s  (ji,jj,jl) = v_s (ji,jj,jl) * zswitch(ji,jj)
+               t_su (ji,jj,jl) = t_su(ji,jj,jl) * zswitch(ji,jj) + t_bo(ji,jj) * ( 1._wp - zswitch(ji,jj) )
+               oa_i (ji,jj,jl) = oa_i(ji,jj,jl) * zswitch(ji,jj)
+               sv_i (ji,jj,jl) = sv_i(ji,jj,jl) * zswitch(ji,jj)
+               !
+               h_i (ji,jj,jl) = h_i (ji,jj,jl) * zswitch(ji,jj)
+               h_s (ji,jj,jl) = h_s (ji,jj,jl) * zswitch(ji,jj)
+               !
+               a_ip (ji,jj,jl) = a_ip (ji,jj,jl) * zswitch(ji,jj)
+               v_ip (ji,jj,jl) = v_ip (ji,jj,jl) * zswitch(ji,jj)
+               !
+            END DO
+         END DO
+         !
+      END DO 
+
+      ! to be sure that at_i is the sum of a_i(jl)
+      at_i (:,:) = SUM( a_i(:,:,:), dim=3 )
+      vt_i (:,:) = SUM( v_i(:,:,:), dim=3 )
+
+      ! open water = 1 if at_i=0
+      WHERE( at_i(:,:) == 0._wp )   ato_i(:,:) = 1._wp
+      !
+   END SUBROUTINE ice_var_zapsmall
+
+
+   SUBROUTINE ice_var_itd( zhti, zhts, zati, zh_i, zh_s, za_i )
+      !!-------------------------------------------------------------------
+      !!                ***  ROUTINE ice_var_itd   ***
+      !!
+      !! ** Purpose :  converting 1-cat ice to multiple ice categories
+      !!
+      !!                  ice thickness distribution follows a gaussian law
+      !!               around the concentration of the most likely ice thickness
+      !!                           (similar as iceistate.F90)
+      !!
+      !! ** Method:   Iterative procedure
+      !!                
+      !!               1) Try to fill the jpl ice categories (bounds hi_max(0:jpl)) with a gaussian
+      !!
+      !!               2) Check whether the distribution conserves area and volume, positivity and
+      !!                  category boundaries
+      !!              
+      !!               3) If not (input ice is too thin), the last category is empty and
+      !!                  the number of categories is reduced (jpl-1)
+      !!
+      !!               4) Iterate until ok (SUM(itest(:) = 4)
+      !!
+      !! ** Arguments : zhti: 1-cat ice thickness
+      !!                zhts: 1-cat snow depth
+      !!                zati: 1-cat ice concentration
+      !!
+      !! ** Output    : jpl-cat 
+      !!
+      !!  (Example of application: BDY forcings when input are cell averaged)  
+      !!-------------------------------------------------------------------
+      INTEGER  :: ji, jk, jl             ! dummy loop indices
+      INTEGER  :: idim, i_fill, jl0  
+      REAL(wp) :: zarg, zV, zconv, zdh, zdv
+      REAL(wp), DIMENSION(:),   INTENT(in)    ::   zhti, zhts, zati    ! input ice/snow variables
+      REAL(wp), DIMENSION(:,:), INTENT(inout) ::   zh_i, zh_s, za_i ! output ice/snow variables
+      INTEGER , DIMENSION(4)                  ::   itest
+      !!-------------------------------------------------------------------
+      !
+      ! ----------------------------------------
+      ! distribution over the jpl ice categories
+      ! ----------------------------------------
+      ! a gaussian distribution for ice concentration is used
+      ! then we check whether the distribution fullfills
+      ! volume and area conservation, positivity and ice categories bounds
+      idim = SIZE( zhti , 1 )
+      zh_i(1:idim,1:jpl) = 0._wp
+      zh_s(1:idim,1:jpl) = 0._wp
+      za_i(1:idim,1:jpl) = 0._wp
+      !
+      DO ji = 1, idim
+         !
+         IF( zhti(ji) > 0._wp ) THEN
+            !
+            ! find which category (jl0) the input ice thickness falls into
+            jl0 = jpl
+            DO jl = 1, jpl
+               IF ( ( zhti(ji) >= hi_max(jl-1) ) .AND. ( zhti(ji) < hi_max(jl) ) ) THEN
+                  jl0 = jl
+                  CYCLE
+               ENDIF
+            END DO
+            !
+            itest(:) = 0
+            i_fill   = jpl + 1                                            !------------------------------------
+            DO WHILE ( ( SUM( itest(:) ) /= 4 ) .AND. ( i_fill >= 2 ) )   ! iterative loop on i_fill categories
+               !                                                          !------------------------------------
+               i_fill = i_fill - 1
+               !
+               zh_i(ji,1:jpl) = 0._wp
+               za_i(ji,1:jpl) = 0._wp
+               itest(:)       = 0      
+               !
+               IF ( i_fill == 1 ) THEN      !-- case very thin ice: fill only category 1
+                  zh_i(ji,1) = zhti(ji)
+                  za_i (ji,1) = zati (ji)
+               ELSE                         !-- case ice is thicker: fill categories >1
+                  ! thickness
+                  DO jl = 1, i_fill - 1
+                     zh_i(ji,jl) = hi_mean(jl)
+                  END DO
+                  !
+                  ! concentration
+                  za_i(ji,jl0) = zati(ji) / SQRT(REAL(jpl))
+                  DO jl = 1, i_fill - 1
+                     IF ( jl /= jl0 ) THEN
+                        zarg        = ( zh_i(ji,jl) - zhti(ji) ) / ( zhti(ji) * 0.5_wp )
+                        za_i(ji,jl) =   za_i (ji,jl0) * EXP(-zarg**2)
+                     ENDIF
+                  END DO
+                  !
+                  ! last category
+                  za_i(ji,i_fill) = zati(ji) - SUM( za_i(ji,1:i_fill-1) )
+                  zV = SUM( za_i(ji,1:i_fill-1) * zh_i(ji,1:i_fill-1) )
+                  zh_i(ji,i_fill) = ( zhti(ji) * zati(ji) - zV ) / MAX( za_i(ji,i_fill), epsi10 ) 
+                  !
+                  ! correction if concentration of upper cat is greater than lower cat
+                  !    (it should be a gaussian around jl0 but sometimes it is not)
+                  IF ( jl0 /= jpl ) THEN
+                     DO jl = jpl, jl0+1, -1
+                        IF ( za_i(ji,jl) > za_i(ji,jl-1) ) THEN
+                           zdv = zh_i(ji,jl) * za_i(ji,jl)
+                           zh_i(ji,jl    ) = 0._wp
+                           za_i (ji,jl    ) = 0._wp
+                           za_i (ji,1:jl-1) = za_i(ji,1:jl-1) + zdv / MAX( REAL(jl-1) * zhti(ji), epsi10 )
+                        END IF
+                     END DO
+                  ENDIF
+                  !
+               ENDIF
+               !
+               ! Compatibility tests
+               zconv = ABS( zati(ji) - SUM( za_i(ji,1:jpl) ) ) 
+               IF ( zconv < epsi06 )   itest(1) = 1                                        ! Test 1: area conservation
+               !
+               zconv = ABS( zhti(ji)*zati(ji) - SUM( za_i(ji,1:jpl)*zh_i(ji,1:jpl) ) )
+               IF ( zconv < epsi06 )   itest(2) = 1                                        ! Test 2: volume conservation
+               !
+               IF ( zh_i(ji,i_fill) >= hi_max(i_fill-1) )   itest(3) = 1                  ! Test 3: thickness of the last category is in-bounds ?
+               !
+               itest(4) = 1
+               DO jl = 1, i_fill
+                  IF ( za_i(ji,jl) < 0._wp ) itest(4) = 0                                ! Test 4: positivity of ice concentrations
+               END DO
+               !                                         !----------------------------
+            END DO                                       ! end iteration on categories
+            !                                            !----------------------------
+         ENDIF
+      END DO
+
+      ! Add Snow in each category where za_i is not 0
+      DO jl = 1, jpl
+         DO ji = 1, idim
+            IF( za_i(ji,jl) > 0._wp ) THEN
+               zh_s(ji,jl) = zh_i(ji,jl) * ( zhts(ji) / zhti(ji) )
+               ! In case snow load is in excess that would lead to transformation from snow to ice
+               ! Then, transfer the snow excess into the ice (different from icethd_dh)
+               zdh = MAX( 0._wp, ( rhosn * zh_s(ji,jl) + ( rhoic - rau0 ) * zh_i(ji,jl) ) * r1_rau0 ) 
+               ! recompute h_i, h_s avoiding out of bounds values
+               zh_i(ji,jl) = MIN( hi_max(jl), zh_i(ji,jl) + zdh )
+               zh_s(ji,jl) = MAX( 0._wp, zh_s(ji,jl) - zdh * rhoic * r1_rhosn )
+            ENDIF
+         END DO
+      END DO
+      !
+   END SUBROUTINE ice_var_itd
+
+
+   SUBROUTINE ice_var_itd2( zhti, zhts, zati, zh_i, zh_s, za_i )
+      !!-------------------------------------------------------------------
+      !!                ***  ROUTINE ice_var_itd2   ***
+      !!
+      !! ** Purpose :  converting N-cat ice to jpl ice categories
+      !!
+      !!                  ice thickness distribution follows a gaussian law
+      !!               around the concentration of the most likely ice thickness
+      !!                           (similar as iceistate.F90)
+      !!
+      !! ** Method:   Iterative procedure
+      !!                
+      !!               1) Fill ice cat that correspond to input thicknesses
+      !!                  Find the lowest(jlmin) and highest(jlmax) cat that are filled
+      !!
+      !!               2) Expand the filling to the cat jlmin-1 and jlmax+1
+      !!                   by removing 25% ice area from jlmin and jlmax (resp.) 
+      !!              
+      !!               3) Expand the filling to the empty cat between jlmin and jlmax 
+      !!                   by a) removing 25% ice area from the lower cat (ascendant loop jlmin=>jlmax)
+      !!                      b) removing 25% ice area from the higher cat (descendant loop jlmax=>jlmin)
+      !!
+      !! ** Arguments : zhti: N-cat ice thickness
+      !!                zhts: N-cat snow depth
+      !!                zati: N-cat ice concentration
+      !!
+      !! ** Output    : jpl-cat 
+      !!
+      !!  (Example of application: BDY forcings when inputs have N-cat /= jpl)  
+      !!-------------------------------------------------------------------
+      INTEGER  ::   ji, jl, jl1, jl2             ! dummy loop indices
+      INTEGER  ::   idim, icat  
+      INTEGER, PARAMETER ::   ztrans = 0.25_wp
+      REAL(wp), DIMENSION(:,:), INTENT(in)    ::   zhti, zhts, zati    ! input ice/snow variables
+      REAL(wp), DIMENSION(:,:), INTENT(inout) ::   zh_i, zh_s, za_i    ! output ice/snow variables
+      INTEGER , DIMENSION(:,:), ALLOCATABLE   ::   jlfil, jlfil2
+      INTEGER , DIMENSION(:)  , ALLOCATABLE   ::   jlmax, jlmin
+      !!-------------------------------------------------------------------
+      !
+      idim = SIZE( zhti, 1 )
+      icat = SIZE( zhti, 2 )
+      !
+      ALLOCATE( jlfil(idim,jpl), jlfil2(idim,jpl) )       ! allocate arrays
+      ALLOCATE( jlmin(idim), jlmax(idim) )
+
+      ! --- initialize output fields to 0 --- !
+      zh_i(1:idim,1:jpl) = 0._wp
+      zh_s(1:idim,1:jpl) = 0._wp
+      za_i(1:idim,1:jpl) = 0._wp
+      !
+      ! --- fill the categories --- !
+      !     find where cat-input = cat-output and fill cat-output fields  
+      jlmax(:) = 0
+      jlmin(:) = 999
+      jlfil(:,:) = 0
+      DO jl1 = 1, jpl
+         DO jl2 = 1, icat
+            DO ji = 1, idim
+               IF( hi_max(jl1-1) <= zhti(ji,jl2) .AND. hi_max(jl1) > zhti(ji,jl2) ) THEN
+                  ! fill the right category
+                  zh_i(ji,jl1) = zhti(ji,jl2)
+                  zh_s(ji,jl1) = zhts(ji,jl2)
+                  za_i(ji,jl1) = zati(ji,jl2)
+                  ! record categories that are filled
+                  jlmax(ji) = MAX( jlmax(ji), jl1 )
+                  jlmin(ji) = MIN( jlmin(ji), jl1 )
+                  jlfil(ji,jl1) = jl1
+               ENDIF
+            END DO
+         END DO
+      END DO
+      !
+      ! --- fill the gaps between categories --- !  
+      !     transfer from categories filled at the previous step to the empty ones in between
+      DO ji = 1, idim
+         jl1 = jlmin(ji)
+         jl2 = jlmax(ji)
+         IF( jl1 > 1 ) THEN
+            ! fill the lower cat (jl1-1)
+            za_i(ji,jl1-1) = ztrans * za_i(ji,jl1)
+            zh_i(ji,jl1-1) = hi_mean(jl1-1)
+            ! remove from cat jl1
+            za_i(ji,jl1  ) = ( 1._wp - ztrans ) * za_i(ji,jl1)
+         ENDIF
+         IF( jl2 < jpl ) THEN
+            ! fill the upper cat (jl2+1)
+            za_i(ji,jl2+1) = ztrans * za_i(ji,jl2)
+            zh_i(ji,jl2+1) = hi_mean(jl2+1)
+            ! remove from cat jl2
+            za_i(ji,jl2  ) = ( 1._wp - ztrans ) * za_i(ji,jl2)
+         ENDIF
+      END DO
+      !
+      jlfil2(:,:) = jlfil(:,:) 
+      ! fill categories from low to high
+      DO jl = 2, jpl-1
+         DO ji = 1, idim
+            IF( jlfil(ji,jl-1) /= 0 .AND. jlfil(ji,jl) == 0 ) THEN
+               ! fill high
+               za_i(ji,jl) = ztrans * za_i(ji,jl-1)
+               zh_i(ji,jl) = hi_mean(jl)
+               jlfil(ji,jl) = jl
+               ! remove low
+               za_i(ji,jl-1) = ( 1._wp - ztrans ) * za_i(ji,jl-1)
+            ENDIF
+         END DO
+      END DO
+      !
+      ! fill categories from high to low
+      DO jl = jpl-1, 2, -1
+         DO ji = 1, idim
+            IF( jlfil2(ji,jl+1) /= 0 .AND. jlfil2(ji,jl) == 0 ) THEN
+               ! fill low
+               za_i(ji,jl) = za_i(ji,jl) + ztrans * za_i(ji,jl+1)
+               zh_i(ji,jl) = hi_mean(jl) 
+               jlfil2(ji,jl) = jl
+               ! remove high
+               za_i(ji,jl+1) = ( 1._wp - ztrans ) * za_i(ji,jl+1)
+            ENDIF
+         END DO
+      END DO
+      !
+      DEALLOCATE( jlfil, jlfil2 )      ! deallocate arrays
+      DEALLOCATE( jlmin, jlmax )
+      !
+   END SUBROUTINE ice_var_itd2
+
+
+   SUBROUTINE ice_var_bv
+      !!-------------------------------------------------------------------
+      !!                ***  ROUTINE ice_var_bv ***
+      !!
+      !! ** Purpose :   computes mean brine volume (%) in sea ice
+      !!
+      !! ** Method  : e = - 0.054 * S (ppt) / T (C)
+      !!
+      !! References : Vancoppenolle et al., JGR, 2007
+      !!-------------------------------------------------------------------
+      INTEGER  ::   ji, jj, jk, jl   ! dummy loop indices
+      !!-------------------------------------------------------------------
+      !
+!!gm I prefere to use WHERE / ELSEWHERE  to set it to zero only where needed   <<<=== to be done
+!!   instead of setting everything to zero as just below
+      bv_i (:,:,:) = 0._wp
+      DO jl = 1, jpl
+         DO jk = 1, nlay_i
+            WHERE( t_i(:,:,jk,jl) < rt0 - epsi10 )   
+               bv_i(:,:,jl) = bv_i(:,:,jl) - tmut * sz_i(:,:,jk,jl) * r1_nlay_i / ( t_i(:,:,jk,jl) - rt0 )
+            END WHERE
+         END DO
+      END DO
+      WHERE( vt_i(:,:) > epsi20 )   ;   bvm_i(:,:) = SUM( bv_i(:,:,:) * v_i(:,:,:) , dim=3 ) / vt_i(:,:)
+      ELSEWHERE                     ;   bvm_i(:,:) = 0._wp
+      END WHERE
+      !
+   END SUBROUTINE ice_var_bv
+
+
+   SUBROUTINE ice_var_enthalpy
+      !!-------------------------------------------------------------------
+      !!                   ***  ROUTINE ice_var_enthalpy *** 
+      !!                 
+      !! ** Purpose :   Computes sea ice energy of melting q_i (J.m-3) from temperature
+      !!
+      !! ** Method  :   Formula (Bitz and Lipscomb, 1999)
+      !!-------------------------------------------------------------------
+      INTEGER  ::   ji, jk   ! dummy loop indices
+      REAL(wp) ::   ztmelts  ! local scalar 
+      !!-------------------------------------------------------------------
+      !
+      DO jk = 1, nlay_i             ! Sea ice energy of melting
+         DO ji = 1, npti
+            ztmelts      = - tmut  * sz_i_1d(ji,jk)
+            t_i_1d(ji,jk) = MIN( t_i_1d(ji,jk), ztmelts + rt0 ) ! Force t_i_1d to be lower than melting point
+                                                                !   (sometimes zdf scheme produces abnormally high temperatures)   
+            e_i_1d(ji,jk) = rhoic * ( cpic * ( ztmelts - ( t_i_1d(ji,jk) - rt0 ) )           &
+               &                    + lfus * ( 1._wp - ztmelts / ( t_i_1d(ji,jk) - rt0 ) )   &
+               &                    - rcp  *   ztmelts )
+         END DO
+      END DO
+      DO jk = 1, nlay_s             ! Snow energy of melting
+         DO ji = 1, npti
+            e_s_1d(ji,jk) = rhosn * ( cpic * ( rt0 - t_s_1d(ji,jk) ) + lfus )
+         END DO
+      END DO
+      !
+   END SUBROUTINE ice_var_enthalpy
+
+#else
+   !!----------------------------------------------------------------------
+   !!   Default option         Dummy module           NO SI3 sea-ice model
+   !!----------------------------------------------------------------------
+#endif
+
+   !!======================================================================
+END MODULE icevar
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/ICE_SRC/icewri.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/ICE_SRC/icewri.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/ICE_SRC/icewri.F90	(revision 9570)
@@ -0,0 +1,310 @@
+MODULE icewri
+   !!======================================================================
+   !!                     ***  MODULE  icewri  ***
+   !!   sea-ice : output ice variables
+   !!======================================================================
+#if defined key_si3
+   !!----------------------------------------------------------------------
+   !!   'key_si3'                                       SI3 sea-ice model
+   !!----------------------------------------------------------------------
+   !!   ice_wri       : write of the diagnostics variables in ouput file 
+   !!   ice_wri_state : write for initial state or/and abandon
+   !!----------------------------------------------------------------------
+   USE dianam         ! build name of file (routine)
+   USE phycst         ! physical constant
+   USE dom_oce        ! domain: ocean
+   USE sbc_oce        ! surf. boundary cond.: ocean
+   USE sbc_ice        ! Surface boundary condition: ice fields
+   USE ice            ! sea-ice: variables
+   USE icevar         ! sea-ice: operations
+   !
+   USE ioipsl         !
+   USE in_out_manager ! I/O manager
+   USE iom            ! I/O manager library
+   USE lib_mpp        ! MPP library
+   USE lib_fortran    ! fortran utilities (glob_sum + no signed zero)
+   USE lbclnk         ! lateral boundary conditions (or mpp links)
+   USE timing         ! Timing
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC ice_wri        ! called by ice_stp
+   PUBLIC ice_wri_state  ! called by dia_wri_state 
+
+   !!----------------------------------------------------------------------
+   !! NEMO/ICE 4.0 , NEMO Consortium (2017)
+   !! $Id: icewri.F90 8409 2017-08-07 15:29:21Z clem $
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE ice_wri( kt )
+      !!-------------------------------------------------------------------
+      !!  This routine computes the average of some variables and write it
+      !!  on the ouput files.
+      !!-------------------------------------------------------------------
+      INTEGER, INTENT(in) ::   kt   ! time-step
+      !
+      INTEGER  ::   ji, jj, jk, jl  ! dummy loop indices
+      REAL(wp) ::   z2da, z2db, zrho1, zrho2
+      REAL(wp), DIMENSION(jpi,jpj)     ::   z2d !  2D workspace
+      REAL(wp), DIMENSION(jpi,jpj)     ::   zmsk00, zmsk05, zmsk15, zmsksn ! O%, 5% and 15% concentration mask and snow mask
+      REAL(wp), DIMENSION(jpi,jpj,jpl) ::   zmsk00l, zmsksnl               ! cat masks
+      !
+      ! Global ice diagnostics (SIMIP)
+      REAL(wp) ::   zdiag_area_nh, zdiag_extt_nh, zdiag_volu_nh   ! area, extent, volume
+      REAL(wp) ::   zdiag_area_sh, zdiag_extt_sh, zdiag_volu_sh 
+      !!-------------------------------------------------------------------
+
+      IF( ln_timing )   CALL timing_start('icewri')
+
+      !----------------------------------------
+      ! Brine volume, switches, missing values
+      !----------------------------------------
+
+      CALL ice_var_bv      ! brine volume
+
+      ! tresholds for outputs
+      DO jj = 1, jpj
+         DO ji = 1, jpi
+            zmsk00(ji,jj) = MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) - epsi06  ) ) ! 1 if ice    , 0 if no ice
+            zmsk05(ji,jj) = MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) - 0.05_wp ) ) ! 1 if 5% ice , 0 if less
+            zmsk15(ji,jj) = MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) - 0.15_wp ) ) ! 1 if 15% ice, 0 if less
+            zmsksn(ji,jj) = MAX( 0._wp , SIGN( 1._wp , vt_s(ji,jj) - epsi06  ) ) ! 1 if snow   , 0 if no snow
+         END DO
+      END DO
+      DO jl = 1, jpl
+         DO jj = 1, jpj
+            DO ji = 1, jpi
+               zmsk00l(ji,jj,jl)  = MAX( 0._wp , SIGN( 1._wp , a_i(ji,jj,jl) - epsi06 ) )
+               zmsksnl(ji,jj,jl)  = MAX( 0._wp , SIGN( 1._wp , v_s(ji,jj,jl) - epsi06 ) )
+            END DO
+         END DO
+      END DO
+
+      !-----------------
+      ! Standard outputs
+      !-----------------
+      zrho1 = ( rau0 - rhoic ) * r1_rau0; zrho2 = rhosn * r1_rau0
+      ! masks
+      IF( iom_use('icemask'  ) )   CALL iom_put( "icemask"  , zmsk00              )   ! ice mask 0%
+      IF( iom_use('icemask05') )   CALL iom_put( "icemask05", zmsk05              )   ! ice mask 5%
+      IF( iom_use('icemask15') )   CALL iom_put( "icemask15", zmsk15              )   ! ice mask 15%
+      !
+      ! general fields
+      IF( iom_use('icemass'  ) )   CALL iom_put( "icemass", rhoic * vt_i * zmsk00 )   ! Ice mass per cell area 
+      IF( iom_use('snwmass'  ) )   CALL iom_put( "snwmass", rhosn * vt_s * zmsksn )   ! Snow mass per cell area
+      IF( iom_use('icepres'  ) )   CALL iom_put( "icepres", zmsk00                )   ! Ice presence (1 or 0) 
+      IF( iom_use('iceconc'  ) )   CALL iom_put( "iceconc", at_i  * zmsk00        )   ! ice concentration
+      IF( iom_use('icevolu'  ) )   CALL iom_put( "icevolu", vt_i  * zmsk00        )   ! ice volume = mean ice thickness over the cell
+      IF( iom_use('icethic'  ) )   CALL iom_put( "icethic", hm_i  * zmsk00        )   ! ice thickness
+      IF( iom_use('snwthic'  ) )   CALL iom_put( "snwthic", hm_s  * zmsk00        )   ! snw thickness
+      IF( iom_use('icebrv'   ) )   CALL iom_put( "icebrv" , bvm_i * zmsk00 * 100. )   ! brine volume
+      IF( iom_use('iceage'   ) )   CALL iom_put( "iceage" , om_i  * zmsk00 / rday )   ! ice age
+      IF( iom_use('icehnew'  ) )   CALL iom_put( "icehnew", ht_i_new              )   ! new ice thickness formed in the leads
+      IF( iom_use('snwvolu'  ) )   CALL iom_put( "snwvolu", vt_s  * zmsksn        )   ! snow volume
+      IF( iom_use('icefrb') ) THEN
+         z2d(:,:) = ( zrho1 * hm_i(:,:) - zrho2 * hm_s(:,:) )                                         
+         WHERE( z2d < 0._wp )   z2d = 0._wp
+                                   CALL iom_put( "icefrb" , z2d * zmsk00          )   ! Ice freeboard
+      ENDIF
+      !
+      ! melt ponds
+      IF( iom_use('iceapnd'  ) )   CALL iom_put( "iceapnd", at_ip  * zmsk00       )   ! melt pond total fraction
+      IF( iom_use('icevpnd'  ) )   CALL iom_put( "icevpnd", vt_ip  * zmsk00       )   ! melt pond total volume per unit area
+      !
+      ! salt
+      IF( iom_use('icesalt'  ) )   CALL iom_put( "icesalt", sm_i  * zmsk00        )   ! mean ice salinity
+      IF( iom_use('icesalm'  ) )   CALL iom_put( "icesalm", SUM( sv_i, DIM = 3 ) * rhoic * 1.0e-3 * zmsk00 )   ! Mass of salt in sea ice per cell area
+
+      ! heat
+      IF( iom_use('icetemp'  ) )   CALL iom_put( "icetemp", ( tm_i  - rt0 ) * zmsk00 )   ! ice mean temperature
+      IF( iom_use('snwtemp'  ) )   CALL iom_put( "snwtemp", ( tm_s  - rt0 ) * zmsksn )   ! snw mean temperature
+      IF( iom_use('icettop'  ) )   CALL iom_put( "icettop", ( tm_su - rt0 ) * zmsk00 )   ! temperature at the ice surface
+      IF( iom_use('icetbot'  ) )   CALL iom_put( "icetbot", ( t_bo  - rt0 ) * zmsk00 )   ! temperature at the ice bottom
+      IF( iom_use('icetsni'  ) )   CALL iom_put( "icetsni", ( tm_si - rt0 ) * zmsk00 )   ! temperature at the snow-ice interface
+      IF( iom_use('icehc'    ) )   CALL iom_put( "icehc"  ,  -et_i          * zmsk00 )   ! ice heat content
+      IF( iom_use('snwhc'    ) )   CALL iom_put( "snwhc"  ,  -et_s          * zmsksn )   ! snow heat content
+
+      ! momentum
+      IF( iom_use('uice'     ) )   CALL iom_put( "uice"   , u_ice                 )   ! ice velocity u component
+      IF( iom_use('vice'     ) )   CALL iom_put( "vice"   , v_ice                 )   ! ice velocity v component
+      IF( iom_use('utau_ai'  ) )   CALL iom_put( "utau_ai", utau_ice * zmsk00     )   ! Wind stress term in force balance (x)
+      IF( iom_use('vtau_ai'  ) )   CALL iom_put( "vtau_ai", vtau_ice * zmsk00     )   ! Wind stress term in force balance (y)
+
+      IF( iom_use('icevel') ) THEN 
+         DO jj = 2 , jpjm1
+            DO ji = 2 , jpim1
+               z2da  = ( u_ice(ji,jj) + u_ice(ji-1,jj) )
+               z2db  = ( v_ice(ji,jj) + v_ice(ji,jj-1) )
+               z2d(ji,jj) = 0.5_wp * SQRT( z2da * z2da + z2db * z2db )
+           END DO
+         END DO
+         CALL lbc_lnk( z2d, 'T', 1. )
+         IF( iom_use('icevel') )   CALL iom_put( "icevel" , z2d                   )   ! ice velocity module
+      ENDIF
+
+      ! --- category-dependent fields --- !
+      IF( iom_use('icemask_cat' ) )   CALL iom_put( "icemask_cat" , zmsk00l                                                    )   ! ice mask 0%
+      IF( iom_use('iceconc_cat' ) )   CALL iom_put( "iceconc_cat" , a_i * zmsk00l                                              )   ! area for categories
+      IF( iom_use('icethic_cat' ) )   CALL iom_put( "icethic_cat" , h_i * zmsk00l                                              )   ! thickness for categories
+      IF( iom_use('snwthic_cat' ) )   CALL iom_put( "snwthic_cat" , h_s * zmsksnl                                              )   ! snow depth for categories
+      IF( iom_use('icesalt_cat' ) )   CALL iom_put( "icesalt_cat" , s_i * zmsk00l                                              )   ! salinity for categories
+      IF( iom_use('iceage_cat'  ) )   CALL iom_put( "iceage_cat"  , o_i * zmsk00l / rday                                       )   ! ice age
+      IF( iom_use('icetemp_cat' ) )   CALL iom_put( "icetemp_cat" , ( SUM( t_i(:,:,:,:), dim=3 ) * r1_nlay_i - rt0 ) * zmsk00l )   ! ice temperature
+      IF( iom_use('snwtemp_cat' ) )   CALL iom_put( "snwtemp_cat" , ( SUM( t_s(:,:,:,:), dim=3 ) * r1_nlay_s - rt0 ) * zmsksnl )   ! snow temperature
+      IF( iom_use('icettop_cat' ) )   CALL iom_put( "icettop_cat" , ( t_su - rt0 ) * zmsk00l                                   )   ! surface temperature
+      IF( iom_use('icebrv_cat'  ) )   CALL iom_put( "icebrv_cat"  ,   bv_i * 100.  * zmsk00l                                   )   ! brine volume
+      IF( iom_use('iceapnd_cat' ) )   CALL iom_put( "iceapnd_cat" ,   a_ip         * zmsk00l                                   )   ! melt pond frac for categories
+      IF( iom_use('icehpnd_cat' ) )   CALL iom_put( "icehpnd_cat" ,   h_ip         * zmsk00l                                   )   ! melt pond frac for categories
+      IF( iom_use('iceafpnd_cat') )   CALL iom_put( "iceafpnd_cat",   a_ip_frac    * zmsk00l                                   )   ! melt pond frac for categories
+
+      !------------------
+      ! Add-ons for SIMIP
+      !------------------
+      ! trends
+      IF( iom_use('dmithd') )   CALL iom_put( "dmithd", - wfx_bog - wfx_bom - wfx_sum - wfx_sni - wfx_opw - wfx_lam - wfx_res ) ! Sea-ice mass change from thermodynamics
+      IF( iom_use('dmidyn') )   CALL iom_put( "dmidyn", - wfx_dyn + rhoic * diag_trp_vi     )   ! Sea-ice mass change from dynamics(kg/m2/s)
+      IF( iom_use('dmiopw') )   CALL iom_put( "dmiopw", - wfx_opw                           )   ! Sea-ice mass change through growth in open water
+      IF( iom_use('dmibog') )   CALL iom_put( "dmibog", - wfx_bog                           )   ! Sea-ice mass change through basal growth
+      IF( iom_use('dmisni') )   CALL iom_put( "dmisni", - wfx_sni                           )   ! Sea-ice mass change through snow-to-ice conversion
+      IF( iom_use('dmisum') )   CALL iom_put( "dmisum", - wfx_sum                           )   ! Sea-ice mass change through surface melting
+      IF( iom_use('dmibom') )   CALL iom_put( "dmibom", - wfx_bom                           )   ! Sea-ice mass change through bottom melting
+      IF( iom_use('dmtsub') )   CALL iom_put( "dmtsub", - wfx_sub                           )   ! Sea-ice mass change through evaporation and sublimation
+      IF( iom_use('dmssub') )   CALL iom_put( "dmssub", - wfx_snw_sub                       )   ! Snow mass change through sublimation
+      IF( iom_use('dmisub') )   CALL iom_put( "dmisub", - wfx_ice_sub                       )   ! Sea-ice mass change through sublimation
+      IF( iom_use('dmsspr') )   CALL iom_put( "dmsspr", - wfx_spr                           )   ! Snow mass change through snow fall
+      IF( iom_use('dmsssi') )   CALL iom_put( "dmsssi",   wfx_sni*rhosn*r1_rhoic            )   ! Snow mass change through snow-to-ice conversion
+      IF( iom_use('dmsmel') )   CALL iom_put( "dmsmel", - wfx_snw_sum                       )   ! Snow mass change through melt
+      IF( iom_use('dmsdyn') )   CALL iom_put( "dmsdyn", - wfx_snw_dyn + rhosn * diag_trp_vs )   ! Snow mass change through dynamics(kg/m2/s)
+
+      ! Global ice diagnostics
+      IF( iom_use('NH_icearea') .OR. iom_use('NH_icevolu') .OR. iom_use('NH_iceextt') )   THEN   ! NH diagnostics
+         !
+         WHERE( ff_t > 0._wp )   ;   zmsk00(:,:) = 1.0e-12
+         ELSEWHERE               ;   zmsk00(:,:) = 0.
+         END WHERE 
+         zdiag_area_nh = glob_sum( at_i(:,:) * zmsk00(:,:) * e1e2t(:,:) )
+         zdiag_volu_nh = glob_sum( vt_i(:,:) * zmsk00(:,:) * e1e2t(:,:) )
+         !
+         WHERE( ff_t > 0._wp .AND. at_i > 0.15 )   ; zmsk00(:,:) = 1.0e-12
+         ELSEWHERE                                 ; zmsk00(:,:) = 0.
+         END WHERE 
+         zdiag_extt_nh = glob_sum( zmsk00(:,:) * e1e2t(:,:) )
+         !
+         IF( iom_use('NH_icearea') )   CALL iom_put( "NH_icearea" ,  zdiag_area_nh )
+         IF( iom_use('NH_icevolu') )   CALL iom_put( "NH_icevolu" ,  zdiag_volu_nh )
+         IF( iom_use('NH_iceextt') )   CALL iom_put( "NH_iceextt" ,  zdiag_extt_nh )
+         !
+      ENDIF
+      !
+      IF( iom_use('SH_icearea') .OR. iom_use('SH_icevolu') .OR. iom_use('SH_iceextt') )   THEN   ! SH diagnostics
+         !
+         WHERE( ff_t < 0._wp ); zmsk00(:,:) = 1.0e-12; 
+         ELSEWHERE            ; zmsk00(:,:) = 0.
+         END WHERE 
+         zdiag_area_sh = glob_sum( at_i(:,:) * zmsk00(:,:) * e1e2t(:,:) ) 
+         zdiag_volu_sh = glob_sum( vt_i(:,:) * zmsk00(:,:) * e1e2t(:,:) )
+         !
+         WHERE( ff_t < 0._wp .AND. at_i > 0.15 ); zmsk00(:,:) = 1.0e-12
+         ELSEWHERE                              ; zmsk00(:,:) = 0.
+         END WHERE 
+         zdiag_extt_sh = glob_sum( zmsk00(:,:) * e1e2t(:,:) )
+         !
+         IF( iom_use('SH_icearea') ) CALL iom_put( "SH_icearea", zdiag_area_sh )
+         IF( iom_use('SH_icevolu') ) CALL iom_put( "SH_icevolu", zdiag_volu_sh )
+         IF( iom_use('SH_iceextt') ) CALL iom_put( "SH_iceextt", zdiag_extt_sh )
+         !
+      ENDIF 
+      !
+!!CR      !     !  Create an output files (output.lim.abort.nc) if S < 0 or u > 20 m/s
+!!CR      !     IF( kindic < 0 )   CALL ice_wri_state( 'output.abort' )
+!!CR      !     not yet implemented
+!!gm  idem for the ocean...  Ask Seb how to get read of ioipsl....
+      !
+      IF( ln_timing )  CALL timing_stop('icewri')
+      !
+   END SUBROUTINE ice_wri
+
+ 
+   SUBROUTINE ice_wri_state( kt, kid, kh_i )
+      !!---------------------------------------------------------------------
+      !!                 ***  ROUTINE ice_wri_state  ***
+      !!        
+      !! ** Purpose :   create a NetCDF file named cdfile_name which contains 
+      !!      the instantaneous ice state and forcing fields for ice model
+      !!        Used to find errors in the initial state or save the last
+      !!      ocean state in case of abnormal end of a simulation
+      !!
+      !! History :   4.0  !  2013-06  (C. Rousset)
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT( in ) ::   kt               ! ocean time-step index
+      INTEGER, INTENT( in ) ::   kid , kh_i
+      INTEGER               ::   nz_i, jl
+      REAL(wp), DIMENSION(jpl) ::   jcat
+      !!----------------------------------------------------------------------
+      !
+      DO jl = 1, jpl
+         jcat(jl) = REAL(jl)
+      END DO
+      
+      CALL histvert( kid, "ncatice", "Ice Categories","", jpl, jcat, nz_i, "up")
+
+      CALL histdef( kid, "sithic", "Ice thickness"          , "m"      , jpi,jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt )
+      CALL histdef( kid, "siconc", "Ice concentration"      , "%"      , jpi,jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt )
+      CALL histdef( kid, "sitemp", "Ice temperature"        , "C"      , jpi,jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt )
+      CALL histdef( kid, "sivelu", "i-Ice speed "           , "m/s"    , jpi,jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt )
+      CALL histdef( kid, "sivelv", "j-Ice speed "           , "m/s"    , jpi,jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt ) 
+      CALL histdef( kid, "sistru", "i-Wind stress over ice" , "Pa"     , jpi,jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt )
+      CALL histdef( kid, "sistrv", "j-Wind stress over ice" , "Pa"     , jpi,jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt ) 
+      CALL histdef( kid, "sisflx", "Solar flx over ocean"   , "W/m2"   , jpi,jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt ) 
+      CALL histdef( kid, "sinflx", "NonSolar flx over ocean", "W/m2"   , jpi,jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt )
+      CALL histdef( kid, "snwpre", "Snow precipitation"     , "kg/m2/s", jpi,jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt ) 
+      CALL histdef( kid, "sisali", "Ice salinity"           , "PSU"    , jpi,jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt ) 
+      CALL histdef( kid, "sivolu", "Ice volume"             , "m"      , jpi,jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt ) 
+      CALL histdef( kid, "sidive", "Ice divergence"         , "10-8s-1", jpi,jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt ) 
+      CALL histdef( kid, "si_amp", "Melt pond fraction"     , "%"      , jpi,jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt )
+      CALL histdef( kid, "si_vmp", "Melt pond volume"       ,  "m"     , jpi,jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt )
+      !
+      CALL histdef( kid, "sithicat", "Ice thickness"        , "m"      , jpi,jpj, kh_i, jpl, 1, jpl, nz_i, 32, "inst(x)", rdt, rdt )
+      CALL histdef( kid, "siconcat", "Ice concentration"    , "%"      , jpi,jpj, kh_i, jpl, 1, jpl, nz_i, 32, "inst(x)", rdt, rdt )
+      CALL histdef( kid, "sisalcat", "Ice salinity"         , ""       , jpi,jpj, kh_i, jpl, 1, jpl, nz_i, 32, "inst(x)", rdt, rdt )
+      CALL histdef( kid, "snthicat", "Snw thickness"        , "m"      , jpi,jpj, kh_i, jpl, 1, jpl, nz_i, 32, "inst(x)", rdt, rdt )
+
+      CALL histend( kid, snc4set )   ! end of the file definition
+
+      CALL histwrite( kid, "sithic", kt, hm_i          , jpi*jpj, (/1/) )    
+      CALL histwrite( kid, "siconc", kt, at_i          , jpi*jpj, (/1/) )
+      CALL histwrite( kid, "sitemp", kt, tm_i - rt0    , jpi*jpj, (/1/) )
+      CALL histwrite( kid, "sivelu", kt, u_ice         , jpi*jpj, (/1/) )
+      CALL histwrite( kid, "sivelv", kt, v_ice         , jpi*jpj, (/1/) )
+      CALL histwrite( kid, "sistru", kt, utau_ice      , jpi*jpj, (/1/) )
+      CALL histwrite( kid, "sistrv", kt, vtau_ice      , jpi*jpj, (/1/) )
+      CALL histwrite( kid, "sisflx", kt, qsr           , jpi*jpj, (/1/) )
+      CALL histwrite( kid, "sinflx", kt, qns           , jpi*jpj, (/1/) )
+      CALL histwrite( kid, "snwpre", kt, sprecip       , jpi*jpj, (/1/) )
+      CALL histwrite( kid, "sisali", kt, sm_i          , jpi*jpj, (/1/) )
+      CALL histwrite( kid, "sivolu", kt, vt_i          , jpi*jpj, (/1/) )
+      CALL histwrite( kid, "sidive", kt, divu_i*1.0e8  , jpi*jpj, (/1/) )
+      CALL histwrite( kid, "si_amp", kt, at_ip         , jpi*jpj, (/1/) )
+      CALL histwrite( kid, "si_vmp", kt, vt_ip         , jpi*jpj, (/1/) )
+      !
+      CALL histwrite( kid, "sithicat", kt, h_i         , jpi*jpj*jpl, (/1/) )    
+      CALL histwrite( kid, "siconcat", kt, a_i         , jpi*jpj*jpl, (/1/) )    
+      CALL histwrite( kid, "sisalcat", kt, s_i         , jpi*jpj*jpl, (/1/) )    
+      CALL histwrite( kid, "snthicat", kt, h_s         , jpi*jpj*jpl, (/1/) )    
+
+      !! The file is closed in dia_wri_state (ocean routine)
+      !! CALL histclo( kid )
+      !
+    END SUBROUTINE ice_wri_state
+
+#else
+   !!----------------------------------------------------------------------
+   !!   Default option :         Empty module         NO SI3 sea-ice model
+   !!----------------------------------------------------------------------
+#endif
+
+   !!======================================================================
+END MODULE icewri
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/NST_SRC/agrif_ice.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/NST_SRC/agrif_ice.F90	(revision 9569)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/NST_SRC/agrif_ice.F90	(revision 9570)
@@ -7,8 +7,8 @@
    !!            3.6  ! 2016-05  (C. Rousset)   Add LIM3 compatibility
    !!----------------------------------------------------------------------
-#if defined key_agrif && defined key_lim3
+#if defined key_agrif && defined key_si3
    !!----------------------------------------------------------------------
    !!   'key_agrif'                                              AGRIF zoom
-   !!   'key_lim3'                                       LIM3 sea-ice model
+   !!   'key_si3'                                       SI3 sea-ice model
    !!----------------------------------------------------------------------   
    IMPLICIT NONE
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/NST_SRC/agrif_lim3_interp.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/NST_SRC/agrif_lim3_interp.F90	(revision 9569)
+++ 	(revision )
@@ -1,379 +1,0 @@
-MODULE agrif_lim3_interp
-   !!=====================================================================================
-   !!                       ***  MODULE agrif_lim3_interp ***
-   !! Nesting module :  interp surface ice boundary condition from a parent grid
-   !! Sea-Ice model  :  LIM 3.6 Sea ice model time-stepping
-   !!=====================================================================================
-   !! History :  2.0   !  04-2008  (F. Dupont)  initial version
-   !!            3.4   !  09-2012  (R. Benshila, C. Herbaut) update and EVP
-   !!            3.6   !  05-2016  (C. Rousset)  Add LIM3 compatibility
-   !!----------------------------------------------------------------------
-#if defined key_agrif && defined key_lim3 
-   !!----------------------------------------------------------------------
-   !!   'key_lim3'  :                                 LIM 3.6 sea-ice model
-   !!   'key_agrif' :                                 AGRIF library
-   !!----------------------------------------------------------------------
-   !!  agrif_interp_lim3    : interpolation of ice at "after" sea-ice time step
-   !!  agrif_interp_u_ice   : atomic routine to interpolate u_ice 
-   !!  agrif_interp_v_ice   : atomic routine to interpolate v_ice 
-   !!  agrif_interp_tra_ice : atomic routine to interpolate ice properties 
-   !!----------------------------------------------------------------------
-   USE par_oce
-   USE dom_oce
-   USE sbc_oce
-   USE ice
-   USE agrif_ice
-   USE phycst , ONLY: rt0
-   
-   IMPLICIT NONE
-   PRIVATE
-
-   PUBLIC   agrif_interp_lim3   ! called by agrif_user.F90
-
-   !!----------------------------------------------------------------------
-   !! NEMO/NST 3.6 , NEMO Consortium (2016)
-   !! $Id: agrif_lim3_interp.F90 6204 2016-01-04 13:47:06Z cetlod $
-   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
-   !!----------------------------------------------------------------------
-
-CONTAINS
-
-   SUBROUTINE agrif_interp_lim3( cd_type, kiter, kitermax )
-      !!-----------------------------------------------------------------------
-      !!                 *** ROUTINE agrif_rhg_lim3  ***
-      !!
-      !!  ** Method  : simple call to atomic routines using stored values to
-      !!  fill the boundaries depending of the position of the point and
-      !!  computing factor for time interpolation
-      !!-----------------------------------------------------------------------
-      CHARACTER(len=1), INTENT(in   )           ::   cd_type
-      INTEGER         , INTENT(in   ), OPTIONAL ::   kiter, kitermax
-      !!
-      REAL(wp) ::   zbeta   ! local scalar
-      !!-----------------------------------------------------------------------
-      !
-      IF( Agrif_Root() .OR. nn_ice==0 )  RETURN   ! do not interpolate if inside Parent Grid or if child domain does not have ice
-      !
-      SELECT CASE( cd_type )
-      CASE('U','V')
-         IF( PRESENT( kiter ) ) THEN  ! interpolation at the child ice sub-time step (only for ice rheology)
-            zbeta = ( REAL(lim_nbstep) - REAL(kitermax - kiter) / REAL(kitermax) ) /  &
-               &    ( Agrif_Rhot() * REAL(Agrif_Parent(nn_fsbc)) / REAL(nn_fsbc) )
-         ELSE                         ! interpolation at the child ice time step
-            zbeta = REAL(lim_nbstep) / ( Agrif_Rhot() * REAL(Agrif_Parent(nn_fsbc)) / REAL(nn_fsbc) )
-         ENDIF
-      CASE('T')
-            zbeta = REAL(lim_nbstep) / ( Agrif_Rhot() * REAL(Agrif_Parent(nn_fsbc)) / REAL(nn_fsbc) )
-      END SELECT
-      !
-      Agrif_SpecialValue    = -9999.
-      Agrif_UseSpecialValue = .TRUE.
-      SELECT CASE( cd_type )
-      CASE('U')   ;   CALL Agrif_Bc_variable( u_ice_id  , procname=interp_u_ice  , calledweight=zbeta )
-      CASE('V')   ;   CALL Agrif_Bc_variable( v_ice_id  , procname=interp_v_ice  , calledweight=zbeta )
-      CASE('T')   ;   CALL Agrif_Bc_variable( tra_ice_id, procname=interp_tra_ice, calledweight=zbeta )
-      END SELECT
-      Agrif_SpecialValue    = 0._wp
-      Agrif_UseSpecialValue = .FALSE.
-      !
-   END SUBROUTINE agrif_interp_lim3
-
-
-   SUBROUTINE interp_u_ice( ptab, i1, i2, j1, j2, before )
-      !!-----------------------------------------------------------------------
-      !!                     *** ROUTINE interp_u_ice ***
-      !!
-      !! i1 i2 j1 j2 are the index of the boundaries parent(when before) and child (when after)
-      !! To solve issues when parent grid is "land" masked but not all the corresponding child 
-      !! grid points, put Agrif_SpecialValue WHERE the parent grid is masked. 
-      !! The child solution will be found in the 9(?) points around
-      !!-----------------------------------------------------------------------
-      INTEGER                         , INTENT(in   ) ::   i1, i2, j1, j2
-      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) ::   ptab
-      LOGICAL                         , INTENT(in   ) ::   before
-      !!
-      REAL(wp) ::   zrhoy   ! local scalar
-      !!-----------------------------------------------------------------------
-      !
-      IF( before ) THEN  ! parent grid
-         ptab(:,:) = e2u(i1:i2,j1:j2) * u_ice(i1:i2,j1:j2)
-         WHERE( umask(i1:i2,j1:j2,1) == 0. )   ptab(i1:i2,j1:j2) = Agrif_SpecialValue
-      ELSE               ! child grid
-         zrhoy = Agrif_Rhoy()
-         u_ice(i1:i2,j1:j2) = ptab(i1:i2,j1:j2) / ( e2u(i1:i2,j1:j2) * zrhoy ) * umask(i1:i2,j1:j2,1)
-      ENDIF
-      !
-   END SUBROUTINE interp_u_ice
-
-
-   SUBROUTINE interp_v_ice( ptab, i1, i2, j1, j2, before )
-      !!-----------------------------------------------------------------------
-      !!                    *** ROUTINE interp_v_ice ***
-      !!
-      !! i1 i2 j1 j2 are the index of the boundaries parent(when before) and child (when after)
-      !! To solve issues when parent grid is "land" masked but not all the corresponding child 
-      !! grid points, put Agrif_SpecialValue WHERE the parent grid is masked. 
-      !! The child solution will be found in the 9(?) points around
-      !!-----------------------------------------------------------------------      
-      INTEGER                         , INTENT(in   ) ::   i1, i2, j1, j2
-      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) ::   ptab
-      LOGICAL                         , INTENT(in   ) ::   before
-      !!
-      REAL(wp) ::   zrhox   ! local scalar
-      !!-----------------------------------------------------------------------
-      !
-      IF( before ) THEN  ! parent grid
-         ptab(:,:) = e1v(i1:i2,j1:j2) * v_ice(i1:i2,j1:j2)
-         WHERE( vmask(i1:i2,j1:j2,1) == 0. )   ptab(i1:i2,j1:j2) = Agrif_SpecialValue
-      ELSE               ! child grid
-         zrhox = Agrif_Rhox()
-         v_ice(i1:i2,j1:j2) = ptab(i1:i2,j1:j2) / ( e1v(i1:i2,j1:j2) * zrhox ) * vmask(i1:i2,j1:j2,1)
-      ENDIF
-      !
-   END SUBROUTINE interp_v_ice
-
-
-   SUBROUTINE interp_tra_ice( ptab, i1, i2, j1, j2, k1, k2, before, nb, ndir )
-      !!-----------------------------------------------------------------------
-      !!                    *** ROUTINE interp_tra_ice ***                           
-      !!
-      !! i1 i2 j1 j2 are the index of the boundaries parent(when before) and child (when after)
-      !! To solve issues when parent grid is "land" masked but not all the corresponding child 
-      !! grid points, put Agrif_SpecialValue WHERE the parent grid is masked. 
-      !! The child solution will be found in the 9(?) points around
-      !!-----------------------------------------------------------------------
-      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) ::   ptab
-      INTEGER                               , INTENT(in   ) ::   i1, i2, j1, j2, k1, k2
-      LOGICAL                               , INTENT(in   ) ::   before
-      INTEGER                               , INTENT(in   ) ::   nb, ndir
-      !!
-      INTEGER  ::   ji, jj, jk, jl, jm
-      INTEGER  ::   imin, imax, jmin, jmax
-      LOGICAL  ::   western_side, eastern_side, northern_side, southern_side
-      REAL(wp) ::   zrhox, z1, z2, z3, z4, z5, z6, z7
-      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::   ztab
-      !!-----------------------------------------------------------------------
-      ! tracers are not multiplied by grid cell here => before: * e1e2t ; after: * r1_e1e2t / rhox / rhoy
-      ! and it is ok since we conserve tracers (same as in the ocean).
-      ALLOCATE( ztab(SIZE(a_i,1),SIZE(a_i,2),SIZE(ptab,3)) )
-     
-      IF( before ) THEN  ! parent grid
-         jm = 1
-         DO jl = 1, jpl
-            ptab(i1:i2,j1:j2,jm  ) = a_i (i1:i2,j1:j2,jl)
-            ptab(i1:i2,j1:j2,jm+1) = v_i (i1:i2,j1:j2,jl)
-            ptab(i1:i2,j1:j2,jm+2) = v_s (i1:i2,j1:j2,jl)
-            ptab(i1:i2,j1:j2,jm+3) = sv_i(i1:i2,j1:j2,jl)
-            ptab(i1:i2,j1:j2,jm+4) = oa_i(i1:i2,j1:j2,jl)
-            ptab(i1:i2,j1:j2,jm+5) = a_ip(i1:i2,j1:j2,jl)
-            ptab(i1:i2,j1:j2,jm+6) = v_ip(i1:i2,j1:j2,jl)
-            ptab(i1:i2,j1:j2,jm+7) = t_su(i1:i2,j1:j2,jl)
-            jm = jm + 8
-            DO jk = 1, nlay_s
-               ptab(i1:i2,j1:j2,jm) = e_s(i1:i2,j1:j2,jk,jl)   ;   jm = jm + 1
-            END DO
-            DO jk = 1, nlay_i
-               ptab(i1:i2,j1:j2,jm) = e_i(i1:i2,j1:j2,jk,jl)   ;   jm = jm + 1
-            END DO
-         END DO
-         
-         DO jk = k1, k2
-            WHERE( tmask(i1:i2,j1:j2,1) == 0._wp )   ptab(i1:i2,j1:j2,jk) = Agrif_SpecialValue
-         END DO
-         !
-      ELSE               ! child grid
-         !
-!         IF( nbghostcells > 1 ) THEN   ! ==> The easiest interpolation is used
-            !
-            jm = 1
-            DO jl = 1, jpl
-               !
-               DO jj = j1, j2
-                  DO ji = i1, i2
-                     a_i (ji,jj,jl) = ptab(ji,jj,jm  ) * tmask(ji,jj,1)
-                     v_i (ji,jj,jl) = ptab(ji,jj,jm+1) * tmask(ji,jj,1)
-                     v_s (ji,jj,jl) = ptab(ji,jj,jm+2) * tmask(ji,jj,1)
-                     sv_i(ji,jj,jl) = ptab(ji,jj,jm+3) * tmask(ji,jj,1)
-                     oa_i(ji,jj,jl) = ptab(ji,jj,jm+4) * tmask(ji,jj,1)
-                     a_ip(ji,jj,jl) = ptab(ji,jj,jm+5) * tmask(ji,jj,1)
-                     v_ip(ji,jj,jl) = ptab(ji,jj,jm+6) * tmask(ji,jj,1)
-                     t_su(ji,jj,jl) = ptab(ji,jj,jm+7) * tmask(ji,jj,1)
-                  END DO
-               END DO
-               jm = jm + 8
-               !
-               DO jk = 1, nlay_s
-                  e_s(i1:i2,j1:j2,jk,jl) = ptab(i1:i2,j1:j2,jm) * tmask(i1:i2,j1:j2,1)
-                  jm = jm + 1
-               END DO
-               !
-               DO jk = 1, nlay_i
-                  e_i(i1:i2,j1:j2,jk,jl) = ptab(i1:i2,j1:j2,jm) * tmask(i1:i2,j1:j2,1)
-                  jm = jm + 1
-               END DO
-               !
-            END DO
-            !
-!!==> clem: this interpolation does not work because it creates negative values, due
-!!          to negative coefficients when mixing points (for ex. z7)
-!!
-!         ELSE                          ! ==> complex interpolation (only one ghost cell available)
-!            !! Use a more complex interpolation since we mix solutions over a couple of grid points
-!            !! it is advised to use it for fields modified by high order schemes (e.g. advection UM5...)
-!            ! record ztab
-!            jm = 1
-!            DO jl = 1, jpl
-!               ztab(:,:,jm  ) = a_i (:,:,jl)
-!               ztab(:,:,jm+1) = v_i (:,:,jl)
-!               ztab(:,:,jm+2) = v_s (:,:,jl)
-!               ztab(:,:,jm+3) = sv_i(:,:,jl)
-!               ztab(:,:,jm+4) = oa_i(:,:,jl)
-!               ztab(:,:,jm+5) = a_ip(:,:,jl)
-!               ztab(:,:,jm+6) = v_ip(:,:,jl)
-!               ztab(:,:,jm+7) = t_su(:,:,jl)
-!               jm = jm + 8
-!               DO jk = 1, nlay_s
-!                  ztab(:,:,jm) = e_s(:,:,jk,jl)
-!                  jm = jm + 1
-!               END DO
-!               DO jk = 1, nlay_i
-!                  ztab(:,:,jm) = e_i(:,:,jk,jl)
-!                  jm = jm + 1
-!               END DO
-!               !
-!            END DO
-!            !
-!            ! borders of the domain
-!            western_side  = (nb == 1).AND.(ndir == 1)  ;  eastern_side  = (nb == 1).AND.(ndir == 2)
-!            southern_side = (nb == 2).AND.(ndir == 1)  ;  northern_side = (nb == 2).AND.(ndir == 2)
-!            !
-!            ! spatial smoothing
-!            zrhox = Agrif_Rhox()
-!            z1 =      ( zrhox - 1. ) * 0.5 
-!            z3 =      ( zrhox - 1. ) / ( zrhox + 1. )
-!            z6 = 2. * ( zrhox - 1. ) / ( zrhox + 1. )
-!            z7 =    - ( zrhox - 1. ) / ( zrhox + 3. )
-!            z2 = 1. - z1
-!            z4 = 1. - z3
-!            z5 = 1. - z6 - z7
-!            !
-!            ! Remove corners
-!            imin = i1  ;  imax = i2  ;  jmin = j1  ;  jmax = j2
-!            IF( (nbondj == -1) .OR. (nbondj == 2) )   jmin = 3
-!            IF( (nbondj == +1) .OR. (nbondj == 2) )   jmax = nlcj-2
-!            IF( (nbondi == -1) .OR. (nbondi == 2) )   imin = 3
-!            IF( (nbondi == +1) .OR. (nbondi == 2) )   imax = nlci-2
-!
-!            ! smoothed fields
-!            IF( eastern_side ) THEN
-!               ztab(nlci,j1:j2,:) = z1 * ptab(nlci,j1:j2,:) + z2 * ptab(nlci-1,j1:j2,:)
-!               DO jj = jmin, jmax
-!                  rswitch = 0.
-!                  IF( u_ice(nlci-2,jj) > 0._wp ) rswitch = 1.
-!                  ztab(nlci-1,jj,:) = ( 1. - umask(nlci-2,jj,1) ) * ztab(nlci,jj,:)  &
-!                     &                +      umask(nlci-2,jj,1)   *  &
-!                     &                ( ( 1. - rswitch ) * ( z4 * ztab(nlci,jj,:)   + z3 * ztab(nlci-2,jj,:) )  &
-!                     &                  +      rswitch   * ( z6 * ztab(nlci-2,jj,:) + z5 * ztab(nlci,jj,:) + z7 * ztab(nlci-3,jj,:) ) )
-!                  ztab(nlci-1,jj,:) = ztab(nlci-1,jj,:) * tmask(nlci-1,jj,1)
-!               END DO
-!            ENDIF
-!            ! 
-!            IF( northern_side ) THEN
-!               ztab(i1:i2,nlcj,:) = z1 * ptab(i1:i2,nlcj,:) + z2 * ptab(i1:i2,nlcj-1,:)
-!               DO ji = imin, imax
-!                  rswitch = 0.
-!                  IF( v_ice(ji,nlcj-2) > 0._wp ) rswitch = 1.
-!                  ztab(ji,nlcj-1,:) = ( 1. - vmask(ji,nlcj-2,1) ) * ztab(ji,nlcj,:)  &
-!                     &                +      vmask(ji,nlcj-2,1)   *  &
-!                     &                ( ( 1. - rswitch ) * ( z4 * ztab(ji,nlcj,:)   + z3 * ztab(ji,nlcj-2,:) ) &
-!                     &                  +      rswitch   * ( z6 * ztab(ji,nlcj-2,:) + z5 * ztab(ji,nlcj,:) + z7 * ztab(ji,nlcj-3,:) ) )
-!                  ztab(ji,nlcj-1,:) = ztab(ji,nlcj-1,:) * tmask(ji,nlcj-1,1)
-!               END DO
-!            END IF
-!            !
-!            IF( western_side) THEN
-!               ztab(1,j1:j2,:) = z1 * ptab(1,j1:j2,:) + z2 * ptab(2,j1:j2,:)
-!               DO jj = jmin, jmax
-!                  rswitch = 0.
-!                  IF( u_ice(2,jj) < 0._wp ) rswitch = 1.
-!                  ztab(2,jj,:) = ( 1. - umask(2,jj,1) ) * ztab(1,jj,:)  &
-!                     &           +      umask(2,jj,1)   *   &
-!                     &           ( ( 1. - rswitch ) * ( z4 * ztab(1,jj,:) + z3 * ztab(3,jj,:) ) &
-!                     &             +      rswitch   * ( z6 * ztab(3,jj,:) + z5 * ztab(1,jj,:) + z7 * ztab(4,jj,:) ) )
-!                  ztab(2,jj,:) = ztab(2,jj,:) * tmask(2,jj,1)
-!               END DO
-!            ENDIF
-!            !
-!            IF( southern_side ) THEN
-!               ztab(i1:i2,1,:) = z1 * ptab(i1:i2,1,:) + z2 * ptab(i1:i2,2,:)
-!               DO ji = imin, imax
-!                  rswitch = 0.
-!                  IF( v_ice(ji,2) < 0._wp ) rswitch = 1.
-!                  ztab(ji,2,:) = ( 1. - vmask(ji,2,1) ) * ztab(ji,1,:)  &
-!                     &           +      vmask(ji,2,1)   *  &
-!                     &           ( ( 1. - rswitch ) * ( z4 * ztab(ji,1,:) + z3 * ztab(ji,3,:) ) &
-!                     &             +      rswitch   * ( z6 * ztab(ji,3,:) + z5 * ztab(ji,1,:) + z7 * ztab(ji,4,:) ) )
-!                  ztab(ji,2,:) = ztab(ji,2,:) * tmask(ji,2,1)
-!               END DO
-!            END IF
-!            !
-!            ! Treatment of corners
-!            IF( (eastern_side) .AND. ((nbondj == -1).OR.(nbondj == 2)) )  ztab(nlci-1,2,:)      = ptab(nlci-1,2,:)      ! East south
-!            IF( (eastern_side) .AND. ((nbondj ==  1).OR.(nbondj == 2)) )  ztab(nlci-1,nlcj-1,:) = ptab(nlci-1,nlcj-1,:) ! East north
-!            IF( (western_side) .AND. ((nbondj == -1).OR.(nbondj == 2)) )  ztab(2,2,:)           = ptab(2,2,:)           ! West south
-!            IF( (western_side) .AND. ((nbondj ==  1).OR.(nbondj == 2)) )  ztab(2,nlcj-1,:)      = ptab(2,nlcj-1,:)      ! West north
-!            
-!            ! retrieve ice tracers
-!            jm = 1
-!            DO jl = 1, jpl
-!               !
-!               DO jj = j1, j2
-!                  DO ji = i1, i2
-!                     a_i (ji,jj,jl) = ztab(ji,jj,jm  ) * tmask(ji,jj,1)
-!                     v_i (ji,jj,jl) = ztab(ji,jj,jm+1) * tmask(ji,jj,1)
-!                     v_s (ji,jj,jl) = ztab(ji,jj,jm+2) * tmask(ji,jj,1)
-!                     sv_i(ji,jj,jl) = ztab(ji,jj,jm+3) * tmask(ji,jj,1)
-!                     oa_i(ji,jj,jl) = ztab(ji,jj,jm+4) * tmask(ji,jj,1)
-!                     a_ip(ji,jj,jl) = ztab(ji,jj,jm+5) * tmask(ji,jj,1)
-!                     v_ip(ji,jj,jl) = ztab(ji,jj,jm+6) * tmask(ji,jj,1)
-!                     t_su(ji,jj,jl) = ztab(ji,jj,jm+7) * tmask(ji,jj,1)
-!                  END DO
-!               END DO
-!               jm = jm + 8
-!               !
-!               DO jk = 1, nlay_s
-!                  e_s(i1:i2,j1:j2,jk,jl) = ztab(i1:i2,j1:j2,jm) * tmask(i1:i2,j1:j2,1)
-!                  jm = jm + 1
-!               END DO
-!               !
-!               DO jk = 1, nlay_i
-!                  e_i(i1:i2,j1:j2,jk,jl) = ztab(i1:i2,j1:j2,jm) * tmask(i1:i2,j1:j2,1)
-!                  jm = jm + 1
-!               END DO
-!               !
-!            END DO
-!          
-!         ENDIF  ! nbghostcells=1
-         
-         DO jl = 1, jpl
-            WHERE( tmask(i1:i2,j1:j2,1) == 0._wp )   t_su(i1:i2,j1:j2,jl) = rt0   ! to avoid a division by 0 in sbcblk.F90
-         END DO
-         !
-      ENDIF
-      
-      DEALLOCATE( ztab )
-      !
-   END SUBROUTINE interp_tra_ice
-
-#else
-   !!----------------------------------------------------------------------
-   !!   Empty module                                             no sea-ice
-   !!----------------------------------------------------------------------
-CONTAINS
-   SUBROUTINE agrif_lim3_interp_empty
-      WRITE(*,*)  'agrif_lim3_interp : You should not have seen this print! error?'
-   END SUBROUTINE agrif_lim3_interp_empty
-#endif
-
-   !!======================================================================
-END MODULE agrif_lim3_interp
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/NST_SRC/agrif_lim3_update.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/NST_SRC/agrif_lim3_update.F90	(revision 9569)
+++ 	(revision )
@@ -1,218 +1,0 @@
-#define TWO_WAY
-!!#undef TWO_WAY
-
-MODULE agrif_lim3_update
-   !!=====================================================================================
-   !!                       ***  MODULE agrif_lim3_update ***
-   !! Nesting module :  update surface ocean boundary condition over ice from a child grid
-   !! Sea-Ice model  :  LIM 3.6 Sea ice model time-stepping
-   !!=====================================================================================
-   !! History :  2.0   !  04-2008  (F. Dupont)  initial version
-   !!            3.4   !  08-2012  (R. Benshila, C. Herbaut) update and EVP
-   !!            3.6   !  05-2016  (C. Rousset)  Add LIM3 compatibility
-   !!----------------------------------------------------------------------
-#if defined key_agrif && defined key_lim3
-   !!----------------------------------------------------------------------
-   !!   'key_lim3'  :                                 LIM 3.6 sea-ice model
-   !!   'key_agrif' :                                 AGRIF library 
-   !!----------------------------------------------------------------------
-   !!   agrif_update_lim3  : update sea-ice on boundaries or total
-   !!                        child domain for velocities and ice properties
-   !!   update_tra_ice     : sea-ice properties
-   !!   update_u_ice       : zonal      ice velocity
-   !!   update_v_ice       : meridional ice velocity
-   !!----------------------------------------------------------------------
-   USE dom_oce
-   USE sbc_oce
-   USE agrif_oce
-   USE ice
-   USE agrif_ice 
-   USE phycst , ONLY: rt0
-
-   IMPLICIT NONE
-   PRIVATE
-
-   PUBLIC   agrif_update_lim3   ! called by agrif_user.F90 and icestp.F90
-
-   !!----------------------------------------------------------------------
-   !! NEMO/NST 4.0 , LOCEAN-IPSL (2017)
-   !! $Id: agrif_lim3_update.F90 6204 2016-01-04 13:47:06Z cetlod $
-   !! Software governed by the CeCILL licence (modipsl/doc/NEMO_CeCILL.txt)
-   !!----------------------------------------------------------------------
-CONTAINS
-
-   SUBROUTINE agrif_update_lim3( kt )
-      !!----------------------------------------------------------------------
-      !!                     *** ROUTINE agrif_update_lim3 ***
-      !! ** Method  :   Call the hydrostaticupdate pressure at the boundary or the entire domain 
-      !!
-      !! ** Action : - Update (u_ice,v_ice) and ice tracers
-      !!----------------------------------------------------------------------
-      INTEGER, INTENT(in) :: kt
-      !!----------------------------------------------------------------------
-      !
-      IF( Agrif_Root() .OR. nn_ice == 0 ) RETURN   ! do not update if inside Parent Grid or if child domain does not have ice
-      !
-      IF( ( MOD( (kt-nit000)/nn_fsbc + 1, Agrif_irhot() * Agrif_Parent(nn_fsbc)/nn_fsbc ) /=0 ) .AND. (kt /= 0) ) RETURN   ! update only at the parent ice time step
-      !
-      Agrif_SpecialValueFineGrid    = -9999.
-      Agrif_UseSpecialValueInUpdate = .TRUE.
-# if defined TWO_WAY
-      CALL Agrif_Update_Variable( tra_ice_id , procname = update_tra_ice  )
-      CALL Agrif_Update_Variable( u_ice_id   , procname = update_u_ice    )
-      CALL Agrif_Update_Variable( v_ice_id   , procname = update_v_ice    )
-
-!      CALL Agrif_Update_Variable( tra_ice_id , locupdate=(/0,2/), procname = update_tra_ice  )
-!      CALL Agrif_Update_Variable( u_ice_id   , locupdate=(/0,1/), procname = update_u_ice    )
-!      CALL Agrif_Update_Variable( v_ice_id   , locupdate=(/0,1/), procname = update_v_ice    )
-# endif
-      Agrif_SpecialValueFineGrid    = 0.
-      Agrif_UseSpecialValueInUpdate = .FALSE.
-      !
-   END SUBROUTINE agrif_update_lim3
-
-
-   SUBROUTINE update_tra_ice( ptab, i1, i2, j1, j2, k1, k2, before )
-      !!-----------------------------------------------------------------------
-      !!                        *** ROUTINE update_tra_ice ***
-      !! ** Method  : Compute the mass properties on the fine grid and recover
-      !!              the properties per mass on the coarse grid
-      !!-----------------------------------------------------------------------
-      INTEGER                               , INTENT(in   ) ::   i1, i2, j1, j2, k1, k2
-      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) ::   ptab
-      LOGICAL                               , INTENT(in   ) ::   before
-      !!
-      INTEGER  :: ji, jj, jk, jl, jm
-      !!-----------------------------------------------------------------------
-      ! it is ok not to multiply by e1*e2 since we conserve tracers here (same as in the ocean).
-      IF( before ) THEN
-         jm = 1
-         DO jl = 1, jpl
-            ptab(i1:i2,j1:j2,jm  ) = a_i (i1:i2,j1:j2,jl)
-            ptab(i1:i2,j1:j2,jm+1) = v_i (i1:i2,j1:j2,jl)
-            ptab(i1:i2,j1:j2,jm+2) = v_s (i1:i2,j1:j2,jl)
-            ptab(i1:i2,j1:j2,jm+3) = sv_i(i1:i2,j1:j2,jl)
-            ptab(i1:i2,j1:j2,jm+4) = oa_i(i1:i2,j1:j2,jl)
-            ptab(i1:i2,j1:j2,jm+5) = a_ip(i1:i2,j1:j2,jl)
-            ptab(i1:i2,j1:j2,jm+6) = v_ip(i1:i2,j1:j2,jl)
-            ptab(i1:i2,j1:j2,jm+7) = t_su(i1:i2,j1:j2,jl)
-            jm = jm + 8
-            DO jk = 1, nlay_s
-               ptab(i1:i2,j1:j2,jm) = e_s(i1:i2,j1:j2,jk,jl)   ;   jm = jm + 1
-            END DO
-            DO jk = 1, nlay_i
-               ptab(i1:i2,j1:j2,jm) = e_i(i1:i2,j1:j2,jk,jl)   ;   jm = jm + 1
-            END DO
-         END DO
-         !
-         DO jk = k1, k2
-            WHERE( tmask(i1:i2,j1:j2,1) == 0. )   ptab(i1:i2,j1:j2,jk) = Agrif_SpecialValueFineGrid 
-         END DO
-         !
-      ELSE
-         !
-         jm = 1
-         DO jl = 1, jpl
-            !
-            DO jj = j1, j2
-               DO ji = i1, i2
-                  IF( ptab(ji,jj,jm) /= Agrif_SpecialValueFineGrid ) THEN
-                     a_i (ji,jj,jl) = ptab(ji,jj,jm  ) * tmask(ji,jj,1)
-                     v_i (ji,jj,jl) = ptab(ji,jj,jm+1) * tmask(ji,jj,1)
-                     v_s (ji,jj,jl) = ptab(ji,jj,jm+2) * tmask(ji,jj,1)
-                     sv_i(ji,jj,jl) = ptab(ji,jj,jm+3) * tmask(ji,jj,1)
-                     oa_i(ji,jj,jl) = ptab(ji,jj,jm+4) * tmask(ji,jj,1)
-                     a_ip(ji,jj,jl) = ptab(ji,jj,jm+5) * tmask(ji,jj,1)
-                     v_ip(ji,jj,jl) = ptab(ji,jj,jm+6) * tmask(ji,jj,1)
-                     t_su(ji,jj,jl) = ptab(ji,jj,jm+7) * tmask(ji,jj,1)
-                  ENDIF
-               END DO
-            END DO
-            jm = jm + 8
-            !
-            DO jk = 1, nlay_s
-               WHERE( ptab(i1:i2,j1:j2,jm) /= Agrif_SpecialValueFineGrid )
-                  e_s(i1:i2,j1:j2,jk,jl) = ptab(i1:i2,j1:j2,jm) * tmask(i1:i2,j1:j2,1)
-               ENDWHERE
-               jm = jm + 1
-            END DO
-            !
-            DO jk = 1, nlay_i
-               WHERE( ptab(i1:i2,j1:j2,jm) /= Agrif_SpecialValueFineGrid )
-                  e_i(i1:i2,j1:j2,jk,jl) = ptab(i1:i2,j1:j2,jm) * tmask(i1:i2,j1:j2,1)
-               ENDWHERE
-               jm = jm + 1
-            END DO
-            !
-         END DO
-         !
-         DO jl = 1, jpl
-            WHERE( tmask(i1:i2,j1:j2,1) == 0._wp )   t_su(i1:i2,j1:j2,jl) = rt0   ! to avoid a division by 0 in sbcblk.F90
-         END DO
-         
-      ENDIF
-      !
-   END SUBROUTINE update_tra_ice
-
-
-   SUBROUTINE update_u_ice( ptab, i1, i2, j1, j2, before )
-      !!-----------------------------------------------------------------------
-      !!                        *** ROUTINE update_u_ice ***
-      !! ** Method  : Update the fluxes and recover the properties (C-grid)
-      !!-----------------------------------------------------------------------
-      INTEGER                         , INTENT(in   ) ::   i1, i2, j1, j2
-      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) ::   ptab
-      LOGICAL                         , INTENT(in   ) ::   before
-      !!
-      REAL(wp) ::   zrhoy   ! local scalar
-      !!-----------------------------------------------------------------------
-      !
-      IF( before ) THEN
-         zrhoy = Agrif_Rhoy()
-         ptab(:,:) = e2u(i1:i2,j1:j2) * u_ice(i1:i2,j1:j2) * zrhoy
-         WHERE( umask(i1:i2,j1:j2,1) == 0._wp )   ptab(:,:) = Agrif_SpecialValueFineGrid
-      ELSE
-         WHERE( ptab(i1:i2,j1:j2) /= Agrif_SpecialValueFineGrid )
-            u_ice(i1:i2,j1:j2) = ptab(i1:i2,j1:j2) / e2u(i1:i2,j1:j2) * umask(i1:i2,j1:j2,1)
-         ENDWHERE
-      ENDIF
-      ! 
-   END SUBROUTINE update_u_ice
-
-
-   SUBROUTINE update_v_ice( ptab, i1, i2, j1, j2, before )
-      !!-----------------------------------------------------------------------
-      !!                    *** ROUTINE update_v_ice ***
-      !! ** Method  : Update the fluxes and recover the properties (C-grid)
-      !!-----------------------------------------------------------------------
-      INTEGER                         , INTENT(in   ) ::   i1, i2, j1, j2
-      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) ::   ptab
-      LOGICAL                         , INTENT(in   ) ::   before
-      !!
-      REAL(wp) ::   zrhox   ! local scalar
-      !!-----------------------------------------------------------------------
-      !
-      IF( before ) THEN
-         zrhox = Agrif_Rhox()
-         ptab(:,:) = e1v(i1:i2,j1:j2) * v_ice(i1:i2,j1:j2) * zrhox
-         WHERE( vmask(i1:i2,j1:j2,1) == 0._wp )   ptab(:,:) = Agrif_SpecialValueFineGrid
-      ELSE
-         WHERE( ptab(i1:i2,j1:j2) /= Agrif_SpecialValueFineGrid )
-            v_ice(i1:i2,j1:j2) = ptab(i1:i2,j1:j2) / e1v(i1:i2,j1:j2) * vmask(i1:i2,j1:j2,1)
-         ENDWHERE
-      ENDIF
-      !
-   END SUBROUTINE update_v_ice
-
-#else
-   !!----------------------------------------------------------------------
-   !!   Empty module                                             no sea-ice
-   !!----------------------------------------------------------------------
-CONTAINS
-   SUBROUTINE agrif_lim3_update_empty
-      WRITE(*,*)  'agrif_lim3_update : You should not have seen this print! error?'
-   END SUBROUTINE agrif_lim3_update_empty
-#endif
-
-   !!======================================================================
-END MODULE agrif_lim3_update
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/NST_SRC/agrif_oce_interp.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/NST_SRC/agrif_oce_interp.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/NST_SRC/agrif_oce_interp.F90	(revision 9570)
@@ -0,0 +1,1414 @@
+MODULE agrif_oce_interp
+   !!======================================================================
+   !!                   ***  MODULE  agrif_oce_interp  ***
+   !! AGRIF: interpolation package for the ocean dynamics (OPA)
+   !!======================================================================
+   !! History :  2.0  !  2002-06  (L. Debreu)  Original cade
+   !!            3.2  !  2009-04  (R. Benshila) 
+   !!            3.6  !  2014-09  (R. Benshila) 
+   !!----------------------------------------------------------------------
+#if defined key_agrif
+   !!----------------------------------------------------------------------
+   !!   'key_agrif'                                              AGRIF zoom
+   !!----------------------------------------------------------------------
+   !!   Agrif_tra     :
+   !!   Agrif_dyn     : 
+   !!   Agrif_ssh     :
+   !!   Agrif_dyn_ts  :
+   !!   Agrif_dta_ts  :
+   !!   Agrif_ssh_ts  :
+   !!   Agrif_avm     : 
+   !!   interpu       :
+   !!   interpv       :
+   !!----------------------------------------------------------------------
+   USE par_oce
+   USE oce
+   USE dom_oce      
+   USE zdf_oce
+   USE agrif_oce
+   USE phycst
+   USE dynspg_ts, ONLY: un_adv, vn_adv
+   !
+   USE in_out_manager
+   USE agrif_oce_sponge
+   USE lib_mpp
+ 
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   Agrif_dyn, Agrif_ssh, Agrif_dyn_ts, Agrif_ssh_ts, Agrif_dta_ts
+   PUBLIC   Agrif_tra, Agrif_avm
+   PUBLIC   interpun , interpvn
+   PUBLIC   interptsn, interpsshn, interpavm
+   PUBLIC   interpunb, interpvnb , interpub2b, interpvb2b
+   PUBLIC   interpe3t, interpumsk, interpvmsk
+
+   INTEGER ::   bdy_tinterp = 0
+
+#  include "vectopt_loop_substitute.h90"
+   !!----------------------------------------------------------------------
+   !! NEMO/NST 4.0 , NEMO Consortium (2017)
+   !! $Id$
+   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE Agrif_tra
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE Agrif_tra  ***
+      !!----------------------------------------------------------------------
+      !
+      IF( Agrif_Root() )   RETURN
+      !
+      Agrif_SpecialValue    = 0._wp
+      Agrif_UseSpecialValue = .TRUE.
+      !
+      CALL Agrif_Bc_variable( tsn_id, procname=interptsn )
+      !
+      Agrif_UseSpecialValue = .FALSE.
+      !
+   END SUBROUTINE Agrif_tra
+
+
+   SUBROUTINE Agrif_dyn( kt )
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE Agrif_DYN  ***
+      !!----------------------------------------------------------------------  
+      INTEGER, INTENT(in) ::   kt
+      !
+      INTEGER ::   ji, jj, jk       ! dummy loop indices
+      INTEGER ::   j1, j2, i1, i2
+      INTEGER ::   ibdy1, jbdy1, ibdy2, jbdy2
+      REAL(wp), DIMENSION(jpi,jpj) ::   zub, zvb
+      !!----------------------------------------------------------------------  
+      !
+      IF( Agrif_Root() )   RETURN
+      !
+      Agrif_SpecialValue    = 0._wp
+      Agrif_UseSpecialValue = ln_spc_dyn
+      !
+      CALL Agrif_Bc_variable( un_interp_id, procname=interpun )
+      CALL Agrif_Bc_variable( vn_interp_id, procname=interpvn )
+      !
+      Agrif_UseSpecialValue = .FALSE.
+      !
+      ! prevent smoothing in ghost cells
+      i1 =  1   ;   i2 = jpi
+      j1 =  1   ;   j2 = jpj
+      IF( nbondj == -1 .OR. nbondj == 2 )   j1 = 2 + nbghostcells
+      IF( nbondj == +1 .OR. nbondj == 2 )   j2 = nlcj - nbghostcells - 1
+      IF( nbondi == -1 .OR. nbondi == 2 )   i1 = 2 + nbghostcells 
+      IF( nbondi == +1 .OR. nbondi == 2 )   i2 = nlci - nbghostcells - 1
+
+      ! --- West --- !
+      IF( nbondi == -1 .OR. nbondi == 2 ) THEN
+         ibdy1 = 2
+         ibdy2 = 1+nbghostcells 
+         !
+         IF( .NOT.ln_dynspg_ts ) THEN  ! Store transport
+            ua_b(ibdy1:ibdy2,:) = 0._wp
+            DO jk = 1, jpkm1
+               DO jj = 1, jpj
+                  ua_b(ibdy1:ibdy2,jj) = ua_b(ibdy1:ibdy2,jj) & 
+                      & + e3u_a(ibdy1:ibdy2,jj,jk) * ua(ibdy1:ibdy2,jj,jk) * umask(ibdy1:ibdy2,jj,jk)
+               END DO
+            END DO
+            DO jj = 1, jpj
+               ua_b(ibdy1:ibdy2,jj) = ua_b(ibdy1:ibdy2,jj) * r1_hu_a(ibdy1:ibdy2,jj)
+            END DO
+         ENDIF
+         !
+         IF( .NOT.lk_agrif_clp ) THEN
+            DO jk=1,jpkm1              ! Smooth
+               DO jj=j1,j2
+                  ua(ibdy2,jj,jk) = 0.25_wp*(ua(ibdy2-1,jj,jk)+2._wp*ua(ibdy2,jj,jk)+ua(ibdy2+1,jj,jk))
+               END DO
+            END DO
+         ENDIF
+         !
+         zub(ibdy1:ibdy2,:) = 0._wp    ! Correct transport
+         DO jk = 1, jpkm1
+            DO jj = 1, jpj
+               zub(ibdy1:ibdy2,jj) = zub(ibdy1:ibdy2,jj) & 
+                  & + e3u_a(ibdy1:ibdy2,jj,jk)  * ua(ibdy1:ibdy2,jj,jk)*umask(ibdy1:ibdy2,jj,jk)
+            END DO
+         END DO
+         DO jj=1,jpj
+            zub(ibdy1:ibdy2,jj) = zub(ibdy1:ibdy2,jj) * r1_hu_a(ibdy1:ibdy2,jj)
+         END DO
+            
+         DO jk = 1, jpkm1
+            DO jj = 1, jpj
+               ua(ibdy1:ibdy2,jj,jk) = ( ua(ibdy1:ibdy2,jj,jk) &
+                 & + ua_b(ibdy1:ibdy2,jj)-zub(ibdy1:ibdy2,jj)) * umask(ibdy1:ibdy2,jj,jk)
+            END DO
+         END DO
+            
+         IF( ln_dynspg_ts ) THEN       ! Set tangential velocities to time splitting estimate
+            zvb(ibdy1:ibdy2,:) = 0._wp
+            DO jk = 1, jpkm1
+               DO jj = 1, jpj
+                  zvb(ibdy1:ibdy2,jj) = zvb(ibdy1:ibdy2,jj) & 
+                     & + e3v_a(ibdy1:ibdy2,jj,jk) * va(ibdy1:ibdy2,jj,jk) * vmask(ibdy1:ibdy2,jj,jk)
+               END DO
+            END DO
+            DO jj = 1, jpj
+               zvb(ibdy1:ibdy2,jj) = zvb(ibdy1:ibdy2,jj) * r1_hv_a(ibdy1:ibdy2,jj)
+            END DO
+            DO jk = 1, jpkm1
+               DO jj = 1, jpj
+                  va(ibdy1:ibdy2,jj,jk) = ( va(ibdy1:ibdy2,jj,jk) & 
+                    & + va_b(ibdy1:ibdy2,jj)-zvb(ibdy1:ibdy2,jj))*vmask(ibdy1:ibdy2,jj,jk)
+               END DO
+            END DO
+         ENDIF
+         !
+         DO jk = 1, jpkm1              ! Mask domain edges
+            DO jj = 1, jpj
+               ua(1,jj,jk) = 0._wp
+               va(1,jj,jk) = 0._wp
+            END DO
+         END DO 
+      ENDIF
+
+      ! --- East --- !
+      IF( nbondi ==  1 .OR. nbondi == 2 ) THEN
+         ibdy1 = nlci-1-nbghostcells
+         ibdy2 = nlci-2 
+         !
+         IF( .NOT.ln_dynspg_ts ) THEN  ! Store transport
+            ua_b(ibdy1:ibdy2,:) = 0._wp
+            DO jk = 1, jpkm1
+               DO jj = 1, jpj
+                  ua_b(ibdy1:ibdy2,jj) = ua_b(ibdy1:ibdy2,jj) & 
+                      & + e3u_a(ibdy1:ibdy2,jj,jk) * ua(ibdy1:ibdy2,jj,jk) * umask(ibdy1:ibdy2,jj,jk)
+               END DO
+            END DO
+            DO jj = 1, jpj
+               ua_b(ibdy1:ibdy2,jj) = ua_b(ibdy1:ibdy2,jj) * r1_hu_a(ibdy1:ibdy2,jj)
+            END DO
+         ENDIF
+         !
+         IF( .NOT.lk_agrif_clp ) THEN
+            DO jk=1,jpkm1              ! Smooth
+               DO jj=j1,j2
+                  ua(ibdy1,jj,jk) = 0.25_wp*(ua(ibdy1-1,jj,jk)+2._wp*ua(ibdy1,jj,jk)+ua(ibdy1+1,jj,jk))
+               END DO
+            END DO
+         ENDIF
+         !
+         zub(ibdy1:ibdy2,:) = 0._wp    ! Correct transport
+         DO jk = 1, jpkm1
+            DO jj = 1, jpj
+               zub(ibdy1:ibdy2,jj) = zub(ibdy1:ibdy2,jj) & 
+                  & + e3u_a(ibdy1:ibdy2,jj,jk)  * ua(ibdy1:ibdy2,jj,jk) * umask(ibdy1:ibdy2,jj,jk)
+            END DO
+         END DO
+         DO jj=1,jpj
+            zub(ibdy1:ibdy2,jj) = zub(ibdy1:ibdy2,jj) * r1_hu_a(ibdy1:ibdy2,jj)
+         END DO
+            
+         DO jk = 1, jpkm1
+            DO jj = 1, jpj
+               ua(ibdy1:ibdy2,jj,jk) = ( ua(ibdy1:ibdy2,jj,jk) & 
+                 & + ua_b(ibdy1:ibdy2,jj)-zub(ibdy1:ibdy2,jj))*umask(ibdy1:ibdy2,jj,jk)
+            END DO
+         END DO
+            
+         IF( ln_dynspg_ts ) THEN       ! Set tangential velocities to time splitting estimate
+            ibdy1 = ibdy1 + 1
+            ibdy2 = ibdy2 + 1 
+            zvb(ibdy1:ibdy2,:) = 0._wp
+            DO jk = 1, jpkm1
+               DO jj = 1, jpj
+                  zvb(ibdy1:ibdy2,jj) = zvb(ibdy1:ibdy2,jj) &
+                     & + e3v_a(ibdy1:ibdy2,jj,jk) * va(ibdy1:ibdy2,jj,jk) * vmask(ibdy1:ibdy2,jj,jk)
+               END DO
+            END DO
+            DO jj = 1, jpj
+               zvb(ibdy1:ibdy2,jj) = zvb(ibdy1:ibdy2,jj) * r1_hv_a(ibdy1:ibdy2,jj)
+            END DO
+            DO jk = 1, jpkm1
+               DO jj = 1, jpj
+                  va(ibdy1:ibdy2,jj,jk) = ( va(ibdy1:ibdy2,jj,jk) & 
+                      & + va_b(ibdy1:ibdy2,jj)-zvb(ibdy1:ibdy2,jj)) * vmask(ibdy1:ibdy2,jj,jk)
+               END DO
+            END DO
+         ENDIF
+         !
+         DO jk = 1, jpkm1              ! Mask domain edges
+            DO jj = 1, jpj
+               ua(nlci-1,jj,jk) = 0._wp
+               va(nlci  ,jj,jk) = 0._wp
+            END DO
+         END DO 
+      ENDIF
+
+      ! --- South --- !
+      IF( nbondj == -1 .OR. nbondj == 2 ) THEN
+         jbdy1 = 2
+         jbdy2 = 1+nbghostcells 
+         !
+         IF( .NOT.ln_dynspg_ts ) THEN  ! Store transport
+            va_b(:,jbdy1:jbdy2) = 0._wp
+            DO jk = 1, jpkm1
+               DO ji = 1, jpi
+                  va_b(ji,jbdy1:jbdy2) = va_b(ji,jbdy1:jbdy2) & 
+                      & + e3v_a(ji,jbdy1:jbdy2,jk) * va(ji,jbdy1:jbdy2,jk) * vmask(ji,jbdy1:jbdy2,jk)
+               END DO
+            END DO
+            DO ji=1,jpi
+               va_b(ji,jbdy1:jbdy2) = va_b(ji,jbdy1:jbdy2) * r1_hv_a(ji,jbdy1:jbdy2)
+            END DO
+         ENDIF
+         !
+         IF ( .NOT.lk_agrif_clp ) THEN
+            DO jk = 1, jpkm1           ! Smooth
+               DO ji = i1, i2
+                  va(ji,jbdy2,jk) = 0.25_wp*(va(ji,jbdy2-1,jk)+2._wp*va(ji,jbdy2,jk)+va(ji,jbdy2+1,jk))
+               END DO
+            END DO
+         ENDIF
+         !
+         zvb(:,jbdy1:jbdy2) = 0._wp    ! Correct transport
+         DO jk=1,jpkm1
+            DO ji=1,jpi
+               zvb(ji,jbdy1:jbdy2) = zvb(ji,jbdy1:jbdy2) & 
+                  & + e3v_a(ji,jbdy1:jbdy2,jk) * va(ji,jbdy1:jbdy2,jk) * vmask(ji,jbdy1:jbdy2,jk)
+            END DO
+         END DO
+         DO ji = 1, jpi
+            zvb(ji,jbdy1:jbdy2) = zvb(ji,jbdy1:jbdy2) * r1_hv_a(ji,jbdy1:jbdy2)
+         END DO
+
+         DO jk = 1, jpkm1
+            DO ji = 1, jpi
+               va(ji,jbdy1:jbdy2,jk) = ( va(ji,jbdy1:jbdy2,jk) & 
+                 & + va_b(ji,jbdy1:jbdy2) - zvb(ji,jbdy1:jbdy2) ) * vmask(ji,jbdy1:jbdy2,jk)
+            END DO
+         END DO
+            
+         IF( ln_dynspg_ts ) THEN       ! Set tangential velocities to time splitting estimate
+            zub(:,jbdy1:jbdy2) = 0._wp
+            DO jk = 1, jpkm1
+               DO ji = 1, jpi
+                  zub(ji,jbdy1:jbdy2) = zub(ji,jbdy1:jbdy2) & 
+                     & + e3u_a(ji,jbdy1:jbdy2,jk) * ua(ji,jbdy1:jbdy2,jk) * umask(ji,jbdy1:jbdy2,jk)
+               END DO
+            END DO
+            DO ji = 1, jpi
+               zub(ji,jbdy1:jbdy2) = zub(ji,jbdy1:jbdy2) * r1_hu_a(ji,jbdy1:jbdy2)
+            END DO
+               
+            DO jk = 1, jpkm1
+               DO ji = 1, jpi
+                  ua(ji,jbdy1:jbdy2,jk) = ( ua(ji,jbdy1:jbdy2,jk) & 
+                    & + ua_b(ji,jbdy1:jbdy2) - zub(ji,jbdy1:jbdy2) ) * umask(ji,jbdy1:jbdy2,jk)
+               END DO
+            END DO
+         ENDIF
+         !
+         DO jk = 1, jpkm1              ! Mask domain edges
+            DO ji = 1, jpi
+               ua(ji,1,jk) = 0._wp
+               va(ji,1,jk) = 0._wp
+            END DO
+         END DO 
+      ENDIF
+
+      ! --- North --- !
+      IF( nbondj ==  1 .OR. nbondj == 2 ) THEN
+         jbdy1 = nlcj-1-nbghostcells
+         jbdy2 = nlcj-2 
+         !
+         IF( .NOT.ln_dynspg_ts ) THEN  ! Store transport
+            va_b(:,jbdy1:jbdy2) = 0._wp
+            DO jk = 1, jpkm1
+               DO ji = 1, jpi
+                  va_b(ji,jbdy1:jbdy2) = va_b(ji,jbdy1:jbdy2) & 
+                      & + e3v_a(ji,jbdy1:jbdy2,jk) * va(ji,jbdy1:jbdy2,jk) * vmask(ji,jbdy1:jbdy2,jk)
+               END DO
+            END DO
+            DO ji=1,jpi
+               va_b(ji,jbdy1:jbdy2) = va_b(ji,jbdy1:jbdy2) * r1_hv_a(ji,jbdy1:jbdy2)
+            END DO
+         ENDIF
+         !
+         IF ( .NOT.lk_agrif_clp ) THEN
+            DO jk = 1, jpkm1           ! Smooth
+               DO ji = i1, i2
+                  va(ji,jbdy1,jk) = 0.25_wp*(va(ji,jbdy1-1,jk)+2._wp*va(ji,jbdy1,jk)+va(ji,jbdy1+1,jk))
+               END DO
+            END DO
+         ENDIF
+         !
+         zvb(:,jbdy1:jbdy2) = 0._wp    ! Correct transport
+         DO jk=1,jpkm1
+            DO ji=1,jpi
+               zvb(ji,jbdy1:jbdy2) = zvb(ji,jbdy1:jbdy2) & 
+                  & + e3v_a(ji,jbdy1:jbdy2,jk) * va(ji,jbdy1:jbdy2,jk) * vmask(ji,jbdy1:jbdy2,jk)
+            END DO
+         END DO
+         DO ji = 1, jpi
+            zvb(ji,jbdy1:jbdy2) = zvb(ji,jbdy1:jbdy2) * r1_hv_a(ji,jbdy1:jbdy2)
+         END DO
+
+         DO jk = 1, jpkm1
+            DO ji = 1, jpi
+               va(ji,jbdy1:jbdy2,jk) = ( va(ji,jbdy1:jbdy2,jk) & 
+                 & + va_b(ji,jbdy1:jbdy2) - zvb(ji,jbdy1:jbdy2) ) * vmask(ji,jbdy1:jbdy2,jk)
+            END DO
+         END DO
+            
+         IF( ln_dynspg_ts ) THEN       ! Set tangential velocities to time splitting estimate
+            jbdy1 = jbdy1 + 1
+            jbdy2 = jbdy2 + 1 
+            zub(:,jbdy1:jbdy2) = 0._wp
+            DO jk = 1, jpkm1
+               DO ji = 1, jpi
+                  zub(ji,jbdy1:jbdy2) = zub(ji,jbdy1:jbdy2) & 
+                     & + e3u_a(ji,jbdy1:jbdy2,jk) * ua(ji,jbdy1:jbdy2,jk) * umask(ji,jbdy1:jbdy2,jk)
+               END DO
+            END DO
+            DO ji = 1, jpi
+               zub(ji,jbdy1:jbdy2) = zub(ji,jbdy1:jbdy2) * r1_hu_a(ji,jbdy1:jbdy2)
+            END DO
+               
+            DO jk = 1, jpkm1
+               DO ji = 1, jpi
+                  ua(ji,jbdy1:jbdy2,jk) = ( ua(ji,jbdy1:jbdy2,jk) & 
+                    & + ua_b(ji,jbdy1:jbdy2) - zub(ji,jbdy1:jbdy2) ) * umask(ji,jbdy1:jbdy2,jk)
+               END DO
+            END DO
+         ENDIF
+         !
+         DO jk = 1, jpkm1              ! Mask domain edges
+            DO ji = 1, jpi
+               ua(ji,nlcj  ,jk) = 0._wp
+               va(ji,nlcj-1,jk) = 0._wp
+            END DO
+         END DO 
+      ENDIF
+      !
+   END SUBROUTINE Agrif_dyn
+
+
+   SUBROUTINE Agrif_dyn_ts( jn )
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE Agrif_dyn_ts  ***
+      !!----------------------------------------------------------------------  
+      INTEGER, INTENT(in) ::   jn
+      !!
+      INTEGER :: ji, jj
+      !!----------------------------------------------------------------------  
+      !
+      IF( Agrif_Root() )   RETURN
+      !
+      IF((nbondi == -1).OR.(nbondi == 2)) THEN
+         DO jj=1,jpj
+            va_e(2:nbghostcells+1,jj) = vbdy_w(1:nbghostcells,jj) * hvr_e(2:nbghostcells+1,jj)
+            ! Specified fluxes:
+            ua_e(2:nbghostcells+1,jj) = ubdy_w(1:nbghostcells,jj) * hur_e(2:nbghostcells+1,jj)
+            ! Characteristics method (only if ghostcells=1):
+            !alt            ua_e(2,jj) = 0.5_wp * ( ubdy_w(jj) * hur_e(2,jj) + ua_e(3,jj) &
+            !alt                       &           - sqrt(grav * hur_e(2,jj)) * (sshn_e(3,jj) - hbdy_w(jj)) )
+         END DO
+      ENDIF
+      !
+      IF((nbondi == 1).OR.(nbondi == 2)) THEN
+         DO jj=1,jpj
+            va_e(nlci-nbghostcells:nlci-1,jj)   = vbdy_e(1:nbghostcells,jj) * hvr_e(nlci-nbghostcells:nlci-1,jj)
+            ! Specified fluxes:
+            ua_e(nlci-nbghostcells-1:nlci-2,jj) = ubdy_e(1:nbghostcells,jj) * hur_e(nlci-nbghostcells-1:nlci-2,jj)
+            ! Characteristics method (only if ghostcells=1):
+            !alt            ua_e(nlci-2,jj) = 0.5_wp * ( ubdy_e(jj) * hur_e(nlci-2,jj) + ua_e(nlci-3,jj) &
+            !alt                            &           + sqrt(grav * hur_e(nlci-2,jj)) * (sshn_e(nlci-2,jj) - hbdy_e(jj)) )
+         END DO
+      ENDIF
+      !
+      IF((nbondj == -1).OR.(nbondj == 2)) THEN
+         DO ji=1,jpi
+            ua_e(ji,2:nbghostcells+1) = ubdy_s(ji,1:nbghostcells) * hur_e(ji,2:nbghostcells+1)
+            ! Specified fluxes:
+            va_e(ji,2:nbghostcells+1) = vbdy_s(ji,1:nbghostcells) * hvr_e(ji,2:nbghostcells+1)
+            ! Characteristics method (only if ghostcells=1):
+            !alt            va_e(ji,2) = 0.5_wp * ( vbdy_s(ji) * hvr_e(ji,2) + va_e(ji,3) &
+            !alt                       &           - sqrt(grav * hvr_e(ji,2)) * (sshn_e(ji,3) - hbdy_s(ji)) )
+         END DO
+      ENDIF
+      !
+      IF((nbondj == 1).OR.(nbondj == 2)) THEN
+         DO ji=1,jpi
+            ua_e(ji,nlcj-nbghostcells:nlcj-1)   = ubdy_n(ji,1:nbghostcells) * hur_e(ji,nlcj-nbghostcells:nlcj-1)
+            ! Specified fluxes:
+            va_e(ji,nlcj-nbghostcells-1:nlcj-2) = vbdy_n(ji,1:nbghostcells) * hvr_e(ji,nlcj-nbghostcells-1:nlcj-2)
+            ! Characteristics method (only if ghostcells=1):
+            !alt            va_e(ji,nlcj-2) = 0.5_wp * ( vbdy_n(ji) * hvr_e(ji,nlcj-2)  + va_e(ji,nlcj-3) &
+            !alt                            &           + sqrt(grav * hvr_e(ji,nlcj-2)) * (sshn_e(ji,nlcj-2) - hbdy_n(ji)) )
+         END DO
+      ENDIF
+      !
+   END SUBROUTINE Agrif_dyn_ts
+
+
+   SUBROUTINE Agrif_dta_ts( kt )
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE Agrif_dta_ts  ***
+      !!----------------------------------------------------------------------  
+      INTEGER, INTENT(in) ::   kt
+      !!
+      INTEGER :: ji, jj
+      LOGICAL :: ll_int_cons
+      !!----------------------------------------------------------------------  
+      !
+      IF( Agrif_Root() )   RETURN
+      !
+      ll_int_cons = ln_bt_fw ! Assume conservative temporal integration in the forward case only
+      !
+      ! Enforce volume conservation if no time refinement:  
+      IF ( Agrif_rhot()==1 ) ll_int_cons=.TRUE.  
+      !
+      ! Interpolate barotropic fluxes
+      Agrif_SpecialValue=0._wp
+      Agrif_UseSpecialValue = ln_spc_dyn
+      !
+      IF( ll_int_cons ) THEN  ! Conservative interpolation
+         ! order matters here !!!!!!
+         CALL Agrif_Bc_variable( ub2b_interp_id, calledweight=1._wp, procname=interpub2b ) ! Time integrated
+         CALL Agrif_Bc_variable( vb2b_interp_id, calledweight=1._wp, procname=interpvb2b )
+         bdy_tinterp = 1
+         CALL Agrif_Bc_variable( unb_id        , calledweight=1._wp, procname=interpunb  ) ! After
+         CALL Agrif_Bc_variable( vnb_id        , calledweight=1._wp, procname=interpvnb  )
+         bdy_tinterp = 2
+         CALL Agrif_Bc_variable( unb_id        , calledweight=0._wp, procname=interpunb  ) ! Before
+         CALL Agrif_Bc_variable( vnb_id        , calledweight=0._wp, procname=interpvnb  )         
+      ELSE ! Linear interpolation
+         bdy_tinterp = 0
+         ubdy_w(:,:) = 0._wp   ;   vbdy_w(:,:) = 0._wp 
+         ubdy_e(:,:) = 0._wp   ;   vbdy_e(:,:) = 0._wp 
+         ubdy_n(:,:) = 0._wp   ;   vbdy_n(:,:) = 0._wp 
+         ubdy_s(:,:) = 0._wp   ;   vbdy_s(:,:) = 0._wp
+         CALL Agrif_Bc_variable( unb_id, procname=interpunb )
+         CALL Agrif_Bc_variable( vnb_id, procname=interpvnb )
+      ENDIF
+      Agrif_UseSpecialValue = .FALSE.
+      ! 
+   END SUBROUTINE Agrif_dta_ts
+
+
+   SUBROUTINE Agrif_ssh( kt )
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE Agrif_ssh  ***
+      !!----------------------------------------------------------------------  
+      INTEGER, INTENT(in) ::   kt
+      !
+      INTEGER  :: ji, jj, indx, indy
+      !!----------------------------------------------------------------------  
+      !
+      IF( Agrif_Root() )   RETURN
+      !      
+      ! Linear time interpolation of sea level
+      !
+      Agrif_SpecialValue    = 0._wp
+      Agrif_UseSpecialValue = .TRUE.
+      CALL Agrif_Bc_variable(sshn_id, procname=interpsshn )
+      Agrif_UseSpecialValue = .FALSE.
+      !
+      ! --- West --- !
+      IF((nbondi == -1).OR.(nbondi == 2)) THEN
+         indx = 1+nbghostcells
+         DO jj = 1, jpj
+            DO ji = 2, indx
+               ssha(ji,jj) = hbdy_w(ji-1,jj)
+            ENDDO
+         ENDDO
+      ENDIF
+      !
+      ! --- East --- !
+      IF((nbondi == 1).OR.(nbondi == 2)) THEN
+         indx = nlci-nbghostcells
+         DO jj = 1, jpj
+            DO ji = indx, nlci-1
+               ssha(ji,jj) = hbdy_e(ji-indx+1,jj)
+            ENDDO
+         ENDDO
+      ENDIF
+      !
+      ! --- South --- !
+      IF((nbondj == -1).OR.(nbondj == 2)) THEN
+         indy = 1+nbghostcells
+         DO jj = 2, indy
+            DO ji = 1, jpi
+               ssha(ji,jj) = hbdy_s(ji,jj-1)
+            ENDDO
+         ENDDO
+      ENDIF
+      !
+      ! --- North --- !
+      IF((nbondj == 1).OR.(nbondj == 2)) THEN
+         indy = nlcj-nbghostcells
+         DO jj = indy, nlcj-1
+            DO ji = 1, jpi
+               ssha(ji,jj) = hbdy_n(ji,jj-indy+1)
+            ENDDO
+         ENDDO
+      ENDIF
+      !
+   END SUBROUTINE Agrif_ssh
+
+
+   SUBROUTINE Agrif_ssh_ts( jn )
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE Agrif_ssh_ts  ***
+      !!----------------------------------------------------------------------  
+      INTEGER, INTENT(in) ::   jn
+      !!
+      INTEGER :: ji, jj, indx, indy
+      !!----------------------------------------------------------------------  
+      !! clem ghost (starting at i,j=1 is important I think otherwise you introduce a grad(ssh)/=0 at point 2)
+      !
+      IF( Agrif_Root() )   RETURN
+      !
+      ! --- West --- !
+      IF((nbondi == -1).OR.(nbondi == 2)) THEN
+         indx = 1+nbghostcells
+         DO jj = 1, jpj
+            DO ji = 2, indx
+               ssha_e(ji,jj) = hbdy_w(ji-1,jj)
+            ENDDO
+         ENDDO
+      ENDIF
+      !
+      ! --- East --- !
+      IF((nbondi == 1).OR.(nbondi == 2)) THEN
+         indx = nlci-nbghostcells
+         DO jj = 1, jpj
+            DO ji = indx, nlci-1
+               ssha_e(ji,jj) = hbdy_e(ji-indx+1,jj)
+            ENDDO
+         ENDDO
+      ENDIF
+      !
+      ! --- South --- !
+      IF((nbondj == -1).OR.(nbondj == 2)) THEN
+         indy = 1+nbghostcells
+         DO jj = 2, indy
+            DO ji = 1, jpi
+               ssha_e(ji,jj) = hbdy_s(ji,jj-1)
+            ENDDO
+         ENDDO
+      ENDIF
+      !
+      ! --- North --- !
+      IF((nbondj == 1).OR.(nbondj == 2)) THEN
+         indy = nlcj-nbghostcells
+         DO jj = indy, nlcj-1
+            DO ji = 1, jpi
+               ssha_e(ji,jj) = hbdy_n(ji,jj-indy+1)
+            ENDDO
+         ENDDO
+      ENDIF
+      !
+   END SUBROUTINE Agrif_ssh_ts
+
+   SUBROUTINE Agrif_avm
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE Agrif_avm  ***
+      !!----------------------------------------------------------------------  
+      REAL(wp) ::   zalpha
+      !!----------------------------------------------------------------------  
+      !
+      IF( Agrif_Root() )   RETURN
+      !
+      zalpha = 1._wp ! JC: proper time interpolation impossible  
+                     ! => use last available value from parent 
+      !
+      Agrif_SpecialValue    = 0.e0
+      Agrif_UseSpecialValue = .TRUE.
+      !
+      CALL Agrif_Bc_variable( avm_id, calledweight=zalpha, procname=interpavm )       
+      !
+      Agrif_UseSpecialValue = .FALSE.
+      !
+   END SUBROUTINE Agrif_avm
+   
+
+   SUBROUTINE interptsn( ptab, i1, i2, j1, j2, k1, k2, n1, n2, before, nb, ndir )
+      !!----------------------------------------------------------------------
+      !!                  *** ROUTINE interptsn ***
+      !!----------------------------------------------------------------------
+      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) ::   ptab
+      INTEGER                                     , INTENT(in   ) ::   i1, i2, j1, j2, k1, k2, n1, n2
+      LOGICAL                                     , INTENT(in   ) ::   before
+      INTEGER                                     , INTENT(in   ) ::   nb , ndir
+      !
+      INTEGER  ::   ji, jj, jk, jn, iref, jref, ibdy, jbdy   ! dummy loop indices
+      INTEGER  ::   imin, imax, jmin, jmax, N_in, N_out
+      REAL(wp) ::   zrhox, z1, z2, z3, z4, z5, z6, z7
+      LOGICAL :: western_side, eastern_side,northern_side,southern_side
+      ! vertical interpolation:
+      REAL(wp), DIMENSION(i1:i2,j1:j2,1:jpk,n1:n2) :: ptab_child
+      REAL(wp), DIMENSION(k1:k2,n1:n2-1) :: tabin
+      REAL(wp), DIMENSION(k1:k2) :: h_in
+      REAL(wp), DIMENSION(1:jpk) :: h_out
+      REAL(wp) :: h_diff
+
+      IF( before ) THEN         
+         DO jn = 1,jpts
+            DO jk=k1,k2
+               DO jj=j1,j2
+                 DO ji=i1,i2
+                       ptab(ji,jj,jk,jn) = tsn(ji,jj,jk,jn)
+                 END DO
+              END DO
+           END DO
+        END DO
+
+# if defined key_vertical
+        DO jk=k1,k2
+           DO jj=j1,j2
+              DO ji=i1,i2
+                 ptab(ji,jj,jk,jpts+1) = tmask(ji,jj,jk) * e3t_n(ji,jj,jk) 
+              END DO
+           END DO
+        END DO
+# endif
+      ELSE 
+
+         western_side  = (nb == 1).AND.(ndir == 1)   ;   eastern_side  = (nb == 1).AND.(ndir == 2)
+         southern_side = (nb == 2).AND.(ndir == 1)   ;   northern_side = (nb == 2).AND.(ndir == 2)
+
+# if defined key_vertical              
+         DO jj=j1,j2
+            DO ji=i1,i2
+               iref = ji
+               jref = jj
+               if(western_side) iref=MAX(2,ji)
+               if(eastern_side) iref=MIN(nlci-1,ji)
+               if(southern_side) jref=MAX(2,jj)
+               if(northern_side) jref=MIN(nlcj-1,jj)
+               N_in = 0
+               DO jk=k1,k2 !k2 = jpk of parent grid
+                  IF (ptab(ji,jj,jk,n2) == 0) EXIT
+                  N_in = N_in + 1
+                  tabin(jk,:) = ptab(ji,jj,jk,n1:n2-1)
+                  h_in(N_in) = ptab(ji,jj,jk,n2)
+               END DO
+               N_out = 0
+               DO jk=1,jpk ! jpk of child grid
+                  IF (tmask(iref,jref,jk) == 0) EXIT 
+                  N_out = N_out + 1
+                  h_out(jk) = e3t_n(iref,jref,jk)
+               ENDDO
+               IF (N_in > 0) THEN
+                  DO jn=1,jpts
+                     call reconstructandremap(tabin(1:N_in,jn),h_in,ptab_child(ji,jj,1:N_out,jn),h_out,N_in,N_out)
+                  ENDDO
+               ENDIF
+            ENDDO
+         ENDDO
+# else
+         ptab_child(i1:i2,j1:j2,1:jpk,1:jpts) = ptab(i1:i2,j1:j2,1:jpk,1:jpts)
+# endif
+         !
+         tsa(i1:i2,j1:j2,1:jpk,1:jpts) = ptab_child(i1:i2,j1:j2,1:jpk,1:jpts)
+
+         IF ( .NOT.lk_agrif_clp ) THEN 
+            !
+            zrhox = Agrif_Rhox()
+            z1 = ( zrhox - 1. ) * 0.5
+            z3 = ( zrhox - 1. ) / ( zrhox + 1. )
+            z6 = 2. * ( zrhox - 1. ) / ( zrhox + 1. )
+            z7 =    - ( zrhox - 1. ) / ( zrhox + 3. )
+            !
+            z2 = 1. - z1
+            z4 = 1. - z3
+            z5 = 1. - z6 - z7
+            !
+            imin = i1 ; imax = i2
+            jmin = j1 ; jmax = j2
+            ! 
+            ! Remove CORNERS
+            IF((nbondj == -1).OR.(nbondj == 2)) jmin = 2 + nbghostcells
+            IF((nbondj == +1).OR.(nbondj == 2)) jmax = nlcj - nbghostcells - 1
+            IF((nbondi == -1).OR.(nbondi == 2)) imin = 1 + nbghostcells
+            IF((nbondi == +1).OR.(nbondi == 2)) imax = nlci - nbghostcells - 1      
+            !
+            IF( eastern_side ) THEN
+               ibdy = nlci-nbghostcells
+               DO jn = 1, jpts
+                  tsa(ibdy+1,jmin:jmax,k1:k2,jn) = z1 * ptab_child(ibdy+1,jmin:jmax,k1:k2,jn) + z2 * ptab_child(ibdy,jmin:jmax,k1:k2,jn)
+                  DO jk = 1, jpkm1
+                     DO jj = jmin,jmax
+                        IF( umask(ibdy-1,jj,jk) == 0._wp ) THEN
+                           tsa(ibdy,jj,jk,jn) = tsa(ibdy+1,jj,jk,jn) * tmask(ibdy,jj,jk)
+                        ELSE
+                           tsa(ibdy,jj,jk,jn)=(z4*tsa(ibdy+1,jj,jk,jn)+z3*tsa(ibdy-1,jj,jk,jn))*tmask(ibdy,jj,jk)
+                           IF( un(ibdy-1,jj,jk) > 0._wp ) THEN
+                              tsa(ibdy,jj,jk,jn)=( z6*tsa(ibdy-1,jj,jk,jn)+z5*tsa(ibdy+1,jj,jk,jn) & 
+                                                 + z7*tsa(ibdy-2,jj,jk,jn) ) * tmask(ibdy,jj,jk)
+                           ENDIF
+                        ENDIF
+                     END DO
+                  END DO
+                  ! Restore ghost points:
+                  tsa(ibdy+1,jmin:jmax,k1:k2,jn) = ptab_child(ibdy+1,jmin:jmax,k1:k2,jn) * tmask(ibdy+1,jmin:jmax,k1:k2)
+               END DO
+            ENDIF
+            ! 
+            IF( northern_side ) THEN
+               jbdy = nlcj-nbghostcells         
+               DO jn = 1, jpts
+                  tsa(imin:imax,jbdy+1,k1:k2,jn) = z1 * ptab_child(imin:imax,jbdy+1,k1:k2,jn) + z2 * ptab_child(imin:imax,jbdy,k1:k2,jn)
+                  DO jk = 1, jpkm1
+                     DO ji = imin,imax
+                        IF( vmask(ji,jbdy-1,jk) == 0._wp ) THEN
+                           tsa(ji,jbdy,jk,jn) = tsa(ji,jbdy+1,jk,jn) * tmask(ji,jbdy,jk)
+                        ELSE
+                           tsa(ji,jbdy,jk,jn)=(z4*tsa(ji,jbdy+1,jk,jn)+z3*tsa(ji,jbdy-1,jk,jn))*tmask(ji,jbdy,jk)        
+                           IF (vn(ji,jbdy-1,jk) > 0._wp ) THEN
+                              tsa(ji,jbdy,jk,jn)=( z6*tsa(ji,jbdy-1,jk,jn)+z5*tsa(ji,jbdy+1,jk,jn)  &
+                                                 + z7*tsa(ji,jbdy-2,jk,jn) ) * tmask(ji,jbdy,jk)
+                           ENDIF
+                        ENDIF
+                     END DO
+                  END DO
+                  ! Restore ghost points:
+                  tsa(imin:imax,jbdy+1,k1:k2,jn) = ptab_child(imin:imax,jbdy+1,k1:k2,jn) * tmask(imin:imax,jbdy+1,k1:k2)
+               END DO
+            ENDIF
+            !
+            IF( western_side ) THEN    
+               ibdy = 1+nbghostcells       
+               DO jn = 1, jpts
+                  tsa(ibdy-1,jmin:jmax,k1:k2,jn) = z1 * ptab_child(ibdy-1,jmin:jmax,k1:k2,jn) + z2 * ptab_child(ibdy,jmin:jmax,k1:k2,jn)
+                  DO jk = 1, jpkm1
+                     DO jj = jmin,jmax
+                        IF( umask(ibdy,jj,jk) == 0._wp ) THEN
+                           tsa(ibdy,jj,jk,jn) = tsa(ibdy-1,jj,jk,jn) * tmask(ibdy,jj,jk)
+                        ELSE
+                           tsa(ibdy,jj,jk,jn)=(z4*tsa(ibdy-1,jj,jk,jn)+z3*tsa(ibdy+1,jj,jk,jn))*tmask(ibdy,jj,jk)        
+                           IF( un(ibdy,jj,jk) < 0._wp ) THEN
+                              tsa(ibdy,jj,jk,jn)=(z6*tsa(ibdy+1,jj,jk,jn)+z5*tsa(ibdy-1,jj,jk,jn)+z7*tsa(ibdy+2,jj,jk,jn))*tmask(ibdy,jj,jk)
+                           ENDIF
+                        ENDIF
+                     END DO
+                  END DO
+                  ! Restore ghost points:
+                  tsa(ibdy-1,jmin:jmax,k1:k2,jn) = ptab_child(ibdy-1,jmin:jmax,k1:k2,jn) * tmask(ibdy-1,jmin:jmax,k1:k2)
+               END DO
+            ENDIF
+            !
+            IF( southern_side ) THEN  
+               jbdy=1+nbghostcells        
+               DO jn = 1, jpts
+                  tsa(imin:imax,jbdy-1,k1:k2,jn) = z1 * ptab_child(imin:imax,jbdy-1,k1:k2,jn) + z2 * ptab_child(imin:imax,jbdy,k1:k2,jn)
+                  DO jk = 1, jpk      
+                     DO ji=imin,imax
+                        IF( vmask(ji,jbdy,jk) == 0._wp ) THEN
+                           tsa(ji,jbdy,jk,jn)=tsa(ji,jbdy-1,jk,jn) * tmask(ji,jbdy,jk)
+                        ELSE
+                           tsa(ji,jbdy,jk,jn)=(z4*tsa(ji,jbdy-1,jk,jn)+z3*tsa(ji,jbdy+1,jk,jn))*tmask(ji,jbdy,jk)
+                           IF( vn(ji,jbdy,jk) < 0._wp ) THEN
+                              tsa(ji,jbdy,jk,jn)=(z6*tsa(ji,jbdy+1,jk,jn)+z5*tsa(ji,jbdy-1,jk,jn)+z7*tsa(ji,jbdy+2,jk,jn))*tmask(ji,jbdy,jk)
+                           ENDIF
+                        ENDIF
+                     END DO
+                  END DO
+                  ! Restore ghost points:
+                  tsa(imin:imax,jbdy-1,k1:k2,jn) = tsa(imin:imax,jbdy-1,k1:k2,jn) * tmask(imin:imax,jbdy-1,k1:k2)
+               END DO
+            ENDIF
+            !
+         ENDIF
+      ENDIF
+      !
+   END SUBROUTINE interptsn
+
+   SUBROUTINE interpsshn( ptab, i1, i2, j1, j2, before, nb, ndir )
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE interpsshn  ***
+      !!----------------------------------------------------------------------  
+      INTEGER                         , INTENT(in   ) ::   i1, i2, j1, j2
+      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) ::   ptab
+      LOGICAL                         , INTENT(in   ) ::   before
+      INTEGER                         , INTENT(in   ) ::   nb , ndir
+      !
+      LOGICAL :: western_side, eastern_side,northern_side,southern_side
+      !!----------------------------------------------------------------------  
+      !
+      IF( before) THEN
+         ptab(i1:i2,j1:j2) = sshn(i1:i2,j1:j2)
+      ELSE
+         western_side  = (nb == 1).AND.(ndir == 1)
+         eastern_side  = (nb == 1).AND.(ndir == 2)
+         southern_side = (nb == 2).AND.(ndir == 1)
+         northern_side = (nb == 2).AND.(ndir == 2)
+         !! clem ghost
+         IF(western_side)  hbdy_w(1:nbghostcells,j1:j2) = ptab(i1:i2,j1:j2) * tmask(i1:i2,j1:j2,1)
+         IF(eastern_side)  hbdy_e(1:nbghostcells,j1:j2) = ptab(i1:i2,j1:j2) * tmask(i1:i2,j1:j2,1)
+         IF(southern_side) hbdy_s(i1:i2,1:nbghostcells) = ptab(i1:i2,j1:j2) * tmask(i1:i2,j1:j2,1) 
+         IF(northern_side) hbdy_n(i1:i2,1:nbghostcells) = ptab(i1:i2,j1:j2) * tmask(i1:i2,j1:j2,1)
+      ENDIF
+      !
+   END SUBROUTINE interpsshn
+
+   SUBROUTINE interpun( ptab, i1, i2, j1, j2, k1, k2, m1, m2, before, nb, ndir )
+      !!----------------------------------------------------------------------
+      !!                  *** ROUTINE interpun ***
+      !!---------------------------------------------    
+      !!
+      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,m1,m2
+      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,m1:m2), INTENT(inout) :: ptab
+      LOGICAL, INTENT(in) :: before
+      INTEGER, INTENT(in) :: nb , ndir
+      !!
+      INTEGER :: ji,jj,jk
+      REAL(wp) :: zrhoy
+      ! vertical interpolation:
+      REAL(wp), DIMENSION(k1:k2) :: tabin, h_in
+      REAL(wp), DIMENSION(1:jpk) :: h_out
+      INTEGER  :: N_in, N_out, iref
+      REAL(wp) :: h_diff
+      LOGICAL  :: western_side, eastern_side
+      !!---------------------------------------------    
+      !
+      IF (before) THEN 
+         DO jk=1,jpk
+            DO jj=j1,j2
+               DO ji=i1,i2
+                  ptab(ji,jj,jk,1) = (e2u(ji,jj) * e3u_n(ji,jj,jk) * un(ji,jj,jk)*umask(ji,jj,jk)) 
+# if defined key_vertical
+                  ptab(ji,jj,jk,2) = (umask(ji,jj,jk) * e2u(ji,jj) * e3u_n(ji,jj,jk))
+# endif
+               END DO
+            END DO
+         END DO
+      ELSE
+         zrhoy = Agrif_rhoy()
+# if defined key_vertical
+! VERTICAL REFINEMENT BEGIN
+         western_side  = (nb == 1).AND.(ndir == 1)
+         eastern_side  = (nb == 1).AND.(ndir == 2)
+
+         DO ji=i1,i2
+            iref = ji
+            IF (western_side) iref = MAX(2,ji)
+            IF (eastern_side) iref = MIN(nlci-2,ji)
+            DO jj=j1,j2
+               N_in = 0
+               DO jk=k1,k2
+                  IF (ptab(ji,jj,jk,2) == 0) EXIT
+                  N_in = N_in + 1
+                  tabin(jk) = ptab(ji,jj,jk,1)/ptab(ji,jj,jk,2)
+                  h_in(N_in) = ptab(ji,jj,jk,2)/(e2u(ji,jj)*zrhoy) 
+              ENDDO
+         
+              IF (N_in == 0) THEN
+                 ua(ji,jj,:) = 0._wp
+                 CYCLE
+              ENDIF
+         
+              N_out = 0
+              DO jk=1,jpk
+                 if (umask(iref,jj,jk) == 0) EXIT
+                 N_out = N_out + 1
+                 h_out(N_out) = e3u_a(iref,jj,jk)
+              ENDDO
+         
+              IF (N_out == 0) THEN
+                 ua(ji,jj,:) = 0._wp
+                 CYCLE
+              ENDIF
+         
+              IF (N_in * N_out > 0) THEN
+                 h_diff = sum(h_out(1:N_out))-sum(h_in(1:N_in))
+! Should be able to remove the next IF/ELSEIF statement once scale factors are dealt with properly
+                 if (h_diff < -1.e4) then
+                    print *,'CHECK YOUR BATHY ...', h_diff, sum(h_out(1:N_out)), sum(h_in(1:N_in))
+!                    stop
+                 endif
+              ENDIF
+              call reconstructandremap(tabin(1:N_in),h_in(1:N_in),ua(ji,jj,1:N_out),h_out(1:N_out),N_in,N_out)
+            ENDDO
+         ENDDO
+
+# else
+         DO jk = 1, jpkm1
+            DO jj=j1,j2
+               ua(i1:i2,jj,jk) = ptab(i1:i2,jj,jk,1) / ( zrhoy * e2u(i1:i2,jj) * e3u_a(i1:i2,jj,jk) )
+            END DO
+         END DO
+# endif
+
+      ENDIF
+      ! 
+   END SUBROUTINE interpun
+
+   SUBROUTINE interpvn( ptab, i1, i2, j1, j2, k1, k2, m1, m2, before, nb, ndir )
+      !!----------------------------------------------------------------------
+      !!                  *** ROUTINE interpvn ***
+      !!----------------------------------------------------------------------
+      !
+      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,m1,m2
+      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,m1:m2), INTENT(inout) :: ptab
+      LOGICAL, INTENT(in) :: before
+      INTEGER, INTENT(in) :: nb , ndir
+      !
+      INTEGER :: ji,jj,jk
+      REAL(wp) :: zrhox
+      ! vertical interpolation:
+      REAL(wp), DIMENSION(k1:k2) :: tabin, h_in
+      REAL(wp), DIMENSION(1:jpk) :: h_out
+      INTEGER  :: N_in, N_out, jref
+      REAL(wp) :: h_diff
+      LOGICAL  :: northern_side,southern_side
+      !!---------------------------------------------    
+      !      
+      IF (before) THEN          
+         DO jk=k1,k2
+            DO jj=j1,j2
+               DO ji=i1,i2
+                  ptab(ji,jj,jk,1) = (e1v(ji,jj) * e3v_n(ji,jj,jk) * vn(ji,jj,jk)*vmask(ji,jj,jk))
+# if defined key_vertical
+                  ptab(ji,jj,jk,2) = vmask(ji,jj,jk) * e1v(ji,jj) * e3v_n(ji,jj,jk)
+# endif
+               END DO
+            END DO
+         END DO
+      ELSE       
+         zrhox = Agrif_rhox()
+# if defined key_vertical
+
+         southern_side = (nb == 2).AND.(ndir == 1)
+         northern_side = (nb == 2).AND.(ndir == 2)
+
+         DO jj=j1,j2
+            jref = jj
+            IF (southern_side) jref = MAX(2,jj)
+            IF (northern_side) jref = MIN(nlcj-2,jj)
+            DO ji=i1,i2
+               N_in = 0
+               DO jk=k1,k2
+                  if (ptab(ji,jj,jk,2) == 0) EXIT
+                  N_in = N_in + 1
+                  tabin(jk) = ptab(ji,jj,jk,1)/ptab(ji,jj,jk,2)
+                  h_in(N_in) = ptab(ji,jj,jk,2)/(e1v(ji,jj)*zrhox)
+               END DO
+               IF (N_in == 0) THEN
+                  va(ji,jj,:) = 0._wp
+                  CYCLE
+               ENDIF
+         
+               N_out = 0
+               DO jk=1,jpk
+                  if (vmask(ji,jref,jk) == 0) EXIT
+                  N_out = N_out + 1
+                  h_out(N_out) = e3v_a(ji,jref,jk)
+               END DO
+               IF (N_out == 0) THEN
+                 va(ji,jj,:) = 0._wp
+                 CYCLE
+               ENDIF
+               call reconstructandremap(tabin(1:N_in),h_in(1:N_in),va(ji,jj,1:N_out),h_out(1:N_out),N_in,N_out)
+            END DO
+         END DO
+# else
+         DO jk = 1, jpkm1
+            va(i1:i2,j1:j2,jk) = ptab(i1:i2,j1:j2,jk,1) / ( zrhox * e1v(i1:i2,j1:j2) * e3v_a(i1:i2,j1:j2,jk) )
+         END DO
+# endif
+      ENDIF
+      !        
+   END SUBROUTINE interpvn
+
+   SUBROUTINE interpunb( ptab, i1, i2, j1, j2, before, nb, ndir )
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE interpunb  ***
+      !!----------------------------------------------------------------------  
+      INTEGER                         , INTENT(in   ) ::   i1, i2, j1, j2
+      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) ::   ptab
+      LOGICAL                         , INTENT(in   ) ::   before
+      INTEGER                         , INTENT(in   ) ::   nb , ndir
+      !
+      INTEGER  ::   ji, jj
+      REAL(wp) ::   zrhoy, zrhot, zt0, zt1, ztcoeff
+      LOGICAL  ::   western_side, eastern_side,northern_side,southern_side
+      !!----------------------------------------------------------------------  
+      !
+      IF( before ) THEN 
+         ptab(i1:i2,j1:j2) = e2u(i1:i2,j1:j2) * hu_n(i1:i2,j1:j2) * un_b(i1:i2,j1:j2)
+      ELSE
+         western_side  = (nb == 1).AND.(ndir == 1)
+         eastern_side  = (nb == 1).AND.(ndir == 2)
+         southern_side = (nb == 2).AND.(ndir == 1)
+         northern_side = (nb == 2).AND.(ndir == 2)
+         zrhoy = Agrif_Rhoy()
+         zrhot = Agrif_rhot()
+         ! Time indexes bounds for integration
+         zt0 = REAL(Agrif_NbStepint()  , wp) / zrhot
+         zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot      
+         ! Polynomial interpolation coefficients:
+         IF( bdy_tinterp == 1 ) THEN
+            ztcoeff = zrhot * (  zt1**2._wp * (       zt1 - 1._wp)        &
+               &               - zt0**2._wp * (       zt0 - 1._wp)        )
+         ELSEIF( bdy_tinterp == 2 ) THEN
+            ztcoeff = zrhot * (  zt1        * (       zt1 - 1._wp)**2._wp &
+               &               - zt0        * (       zt0 - 1._wp)**2._wp )
+         ELSE
+            ztcoeff = 1
+         ENDIF
+         !   
+         IF(western_side)   ubdy_w(1:nbghostcells,j1:j2) = ubdy_w(1:nbghostcells,j1:j2) + ztcoeff * ptab(i1:i2,j1:j2)  
+         IF(eastern_side)   ubdy_e(1:nbghostcells,j1:j2) = ubdy_e(1:nbghostcells,j1:j2) + ztcoeff * ptab(i1:i2,j1:j2)  
+         IF(southern_side)  ubdy_s(i1:i2,1:nbghostcells) = ubdy_s(i1:i2,1:nbghostcells) + ztcoeff * ptab(i1:i2,j1:j2)
+         IF(northern_side)  ubdy_n(i1:i2,1:nbghostcells) = ubdy_n(i1:i2,1:nbghostcells) + ztcoeff * ptab(i1:i2,j1:j2) 
+         !            
+         IF( bdy_tinterp == 0 .OR. bdy_tinterp == 2) THEN
+            IF(western_side)   ubdy_w(1:nbghostcells,j1:j2) = ubdy_w(1:nbghostcells,j1:j2) / (zrhoy*e2u(i1:i2,j1:j2)) * umask(i1:i2,j1:j2,1)
+            IF(eastern_side)   ubdy_e(1:nbghostcells,j1:j2) = ubdy_e(1:nbghostcells,j1:j2) / (zrhoy*e2u(i1:i2,j1:j2)) * umask(i1:i2,j1:j2,1)
+            IF(southern_side)  ubdy_s(i1:i2,1:nbghostcells) = ubdy_s(i1:i2,1:nbghostcells) / (zrhoy*e2u(i1:i2,j1:j2)) * umask(i1:i2,j1:j2,1)
+            IF(northern_side)  ubdy_n(i1:i2,1:nbghostcells) = ubdy_n(i1:i2,1:nbghostcells) / (zrhoy*e2u(i1:i2,j1:j2)) * umask(i1:i2,j1:j2,1)
+         ENDIF
+      ENDIF
+      ! 
+   END SUBROUTINE interpunb
+
+
+   SUBROUTINE interpvnb( ptab, i1, i2, j1, j2, before, nb, ndir )
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE interpvnb  ***
+      !!----------------------------------------------------------------------  
+      INTEGER                         , INTENT(in   ) ::   i1, i2, j1, j2
+      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) ::   ptab
+      LOGICAL                         , INTENT(in   ) ::   before
+      INTEGER                         , INTENT(in   ) ::   nb , ndir
+      !
+      INTEGER  ::   ji,jj
+      REAL(wp) ::   zrhox, zrhot, zt0, zt1, ztcoeff   
+      LOGICAL  ::   western_side, eastern_side,northern_side,southern_side
+      !!----------------------------------------------------------------------  
+      ! 
+      IF( before ) THEN 
+         ptab(i1:i2,j1:j2) = e1v(i1:i2,j1:j2) * hv_n(i1:i2,j1:j2) * vn_b(i1:i2,j1:j2)
+      ELSE
+         western_side  = (nb == 1).AND.(ndir == 1)
+         eastern_side  = (nb == 1).AND.(ndir == 2)
+         southern_side = (nb == 2).AND.(ndir == 1)
+         northern_side = (nb == 2).AND.(ndir == 2)
+         zrhox = Agrif_Rhox()
+         zrhot = Agrif_rhot()
+         ! Time indexes bounds for integration
+         zt0 = REAL(Agrif_NbStepint()  , wp) / zrhot
+         zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot      
+         IF( bdy_tinterp == 1 ) THEN
+            ztcoeff = zrhot * (  zt1**2._wp * (       zt1 - 1._wp)        &
+               &               - zt0**2._wp * (       zt0 - 1._wp)        )
+         ELSEIF( bdy_tinterp == 2 ) THEN
+            ztcoeff = zrhot * (  zt1        * (       zt1 - 1._wp)**2._wp &
+               &               - zt0        * (       zt0 - 1._wp)**2._wp ) 
+         ELSE
+            ztcoeff = 1
+         ENDIF
+         !! clem ghost
+         IF(western_side)   vbdy_w(1:nbghostcells,j1:j2) = vbdy_w(1:nbghostcells,j1:j2) + ztcoeff * ptab(i1:i2,j1:j2)  
+         IF(eastern_side)   vbdy_e(1:nbghostcells,j1:j2) = vbdy_e(1:nbghostcells,j1:j2) + ztcoeff * ptab(i1:i2,j1:j2)   
+         IF(southern_side)  vbdy_s(i1:i2,1:nbghostcells) = vbdy_s(i1:i2,1:nbghostcells) + ztcoeff * ptab(i1:i2,j1:j2)
+         IF(northern_side)  vbdy_n(i1:i2,1:nbghostcells) = vbdy_n(i1:i2,1:nbghostcells) + ztcoeff * ptab(i1:i2,j1:j2) 
+         !            
+         IF( bdy_tinterp == 0 .OR. bdy_tinterp == 2) THEN
+            IF(western_side)   vbdy_w(1:nbghostcells,j1:j2) = vbdy_w(1:nbghostcells,j1:j2) / (zrhox*e1v(i1:i2,j1:j2)) * vmask(i1:i2,j1:j2,1)
+            IF(eastern_side)   vbdy_e(1:nbghostcells,j1:j2) = vbdy_e(1:nbghostcells,j1:j2) / (zrhox*e1v(i1:i2,j1:j2)) * vmask(i1:i2,j1:j2,1)
+            IF(southern_side)  vbdy_s(i1:i2,1:nbghostcells) = vbdy_s(i1:i2,1:nbghostcells) / (zrhox*e1v(i1:i2,j1:j2)) * vmask(i1:i2,j1:j2,1)
+            IF(northern_side)  vbdy_n(i1:i2,1:nbghostcells) = vbdy_n(i1:i2,1:nbghostcells) / (zrhox*e1v(i1:i2,j1:j2)) * vmask(i1:i2,j1:j2,1)
+         ENDIF
+      ENDIF
+      !
+   END SUBROUTINE interpvnb
+
+
+   SUBROUTINE interpub2b( ptab, i1, i2, j1, j2, before, nb, ndir )
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE interpub2b  ***
+      !!----------------------------------------------------------------------  
+      INTEGER                         , INTENT(in   ) ::   i1, i2, j1, j2
+      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) ::   ptab
+      LOGICAL                         , INTENT(in   ) ::   before
+      INTEGER                         , INTENT(in   ) ::   nb , ndir
+      !
+      INTEGER  ::   ji,jj
+      REAL(wp) ::   zrhot, zt0, zt1,zat
+      LOGICAL  ::   western_side, eastern_side,northern_side,southern_side
+      !!----------------------------------------------------------------------  
+      IF( before ) THEN
+         IF ( ln_bt_fw ) THEN
+            ptab(i1:i2,j1:j2) = e2u(i1:i2,j1:j2) * ub2_b(i1:i2,j1:j2)
+         ELSE
+            ptab(i1:i2,j1:j2) = e2u(i1:i2,j1:j2) * un_adv(i1:i2,j1:j2)
+         ENDIF
+      ELSE
+         western_side  = (nb == 1).AND.(ndir == 1)
+         eastern_side  = (nb == 1).AND.(ndir == 2)
+         southern_side = (nb == 2).AND.(ndir == 1)
+         northern_side = (nb == 2).AND.(ndir == 2)
+         zrhot = Agrif_rhot()
+         ! Time indexes bounds for integration
+         zt0 = REAL(Agrif_NbStepint()  , wp) / zrhot
+         zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot
+         ! Polynomial interpolation coefficients:
+         zat = zrhot * (  zt1**2._wp * (-2._wp*zt1 + 3._wp)    &
+            &           - zt0**2._wp * (-2._wp*zt0 + 3._wp)    ) 
+         !! clem ghost
+         IF(western_side ) ubdy_w(1:nbghostcells,j1:j2) = zat * ptab(i1:i2,j1:j2)  
+         IF(eastern_side ) ubdy_e(1:nbghostcells,j1:j2) = zat * ptab(i1:i2,j1:j2)  
+         IF(southern_side) ubdy_s(i1:i2,1:nbghostcells) = zat * ptab(i1:i2,j1:j2)
+         IF(northern_side) ubdy_n(i1:i2,1:nbghostcells) = zat * ptab(i1:i2,j1:j2) 
+      ENDIF
+      ! 
+   END SUBROUTINE interpub2b
+   
+
+   SUBROUTINE interpvb2b( ptab, i1, i2, j1, j2, before, nb, ndir )
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE interpvb2b  ***
+      !!----------------------------------------------------------------------  
+      INTEGER                         , INTENT(in   ) ::   i1, i2, j1, j2
+      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) ::   ptab
+      LOGICAL                         , INTENT(in   ) ::   before
+      INTEGER                         , INTENT(in   ) ::   nb , ndir
+      !
+      INTEGER ::   ji,jj
+      REAL(wp) ::   zrhot, zt0, zt1,zat
+      LOGICAL ::   western_side, eastern_side,northern_side,southern_side
+      !!----------------------------------------------------------------------  
+      !
+      IF( before ) THEN
+         IF ( ln_bt_fw ) THEN
+            ptab(i1:i2,j1:j2) = e1v(i1:i2,j1:j2) * vb2_b(i1:i2,j1:j2)
+         ELSE
+            ptab(i1:i2,j1:j2) = e1v(i1:i2,j1:j2) * vn_adv(i1:i2,j1:j2)
+         ENDIF
+      ELSE      
+         western_side  = (nb == 1).AND.(ndir == 1)
+         eastern_side  = (nb == 1).AND.(ndir == 2)
+         southern_side = (nb == 2).AND.(ndir == 1)
+         northern_side = (nb == 2).AND.(ndir == 2)
+         zrhot = Agrif_rhot()
+         ! Time indexes bounds for integration
+         zt0 = REAL(Agrif_NbStepint()  , wp) / zrhot
+         zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot
+         ! Polynomial interpolation coefficients:
+         zat = zrhot * (  zt1**2._wp * (-2._wp*zt1 + 3._wp)    &
+            &           - zt0**2._wp * (-2._wp*zt0 + 3._wp)    ) 
+         !
+         IF(western_side )   vbdy_w(1:nbghostcells,j1:j2) = zat * ptab(i1:i2,j1:j2)  
+         IF(eastern_side )   vbdy_e(1:nbghostcells,j1:j2) = zat * ptab(i1:i2,j1:j2)  
+         IF(southern_side)   vbdy_s(i1:i2,1:nbghostcells) = zat * ptab(i1:i2,j1:j2)
+         IF(northern_side)   vbdy_n(i1:i2,1:nbghostcells) = zat * ptab(i1:i2,j1:j2) 
+      ENDIF
+      !      
+   END SUBROUTINE interpvb2b
+
+
+   SUBROUTINE interpe3t( ptab, i1, i2, j1, j2, k1, k2, before, nb, ndir )
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE interpe3t  ***
+      !!----------------------------------------------------------------------  
+      INTEGER                              , INTENT(in   ) :: i1, i2, j1, j2, k1, k2
+      REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab
+      LOGICAL                              , INTENT(in   ) :: before
+      INTEGER                              , INTENT(in   ) :: nb , ndir
+      !
+      INTEGER :: ji, jj, jk
+      LOGICAL :: western_side, eastern_side, northern_side, southern_side
+      !!----------------------------------------------------------------------  
+      !    
+      IF( before ) THEN
+         ptab(i1:i2,j1:j2,k1:k2) = tmask(i1:i2,j1:j2,k1:k2) * e3t_0(i1:i2,j1:j2,k1:k2)
+      ELSE
+         western_side  = (nb == 1).AND.(ndir == 1)
+         eastern_side  = (nb == 1).AND.(ndir == 2)
+         southern_side = (nb == 2).AND.(ndir == 1)
+         northern_side = (nb == 2).AND.(ndir == 2)
+         !
+         DO jk = k1, k2
+            DO jj = j1, j2
+               DO ji = i1, i2
+                  !
+                  IF( ABS( ptab(ji,jj,jk) - tmask(ji,jj,jk) * e3t_0(ji,jj,jk) ) > 1.D-2) THEN
+                     IF (western_side) THEN
+                        WRITE(numout,*) 'ERROR bathymetry merge at the western border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk
+                     ELSEIF (eastern_side) THEN
+                        WRITE(numout,*) 'ERROR bathymetry merge at the eastern border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk
+                     ELSEIF (southern_side) THEN
+                        WRITE(numout,*) 'ERROR bathymetry merge at the southern border ji,jj,jk', ji+nimpp-1,jj+njmpp-1,jk
+                     ELSEIF (northern_side) THEN
+                        WRITE(numout,*) 'ERROR bathymetry merge at the northen border ji,jj,jk', ji+nimpp-1,jj+njmpp-1,jk
+                     ENDIF
+                     WRITE(numout,*) '      ptab(ji,jj,jk), e3t(ji,jj,jk) ', ptab(ji,jj,jk), e3t_0(ji,jj,jk)
+                     kindic_agr = kindic_agr + 1
+                  ENDIF
+               END DO
+            END DO
+         END DO
+         !
+      ENDIF
+      ! 
+   END SUBROUTINE interpe3t
+
+
+   SUBROUTINE interpumsk( ptab, i1, i2, j1, j2, k1, k2, before, nb, ndir )
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE interpumsk  ***
+      !!----------------------------------------------------------------------  
+      INTEGER                              , INTENT(in   ) ::   i1, i2, j1, j2, k1, k2
+      REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) ::   ptab
+      LOGICAL                              , INTENT(in   ) ::   before
+      INTEGER                              , INTENT(in   ) ::   nb , ndir
+      !
+      INTEGER ::   ji, jj, jk
+      LOGICAL ::   western_side, eastern_side   
+      !!----------------------------------------------------------------------  
+      !    
+      IF( before ) THEN
+         ptab(i1:i2,j1:j2,k1:k2) = umask(i1:i2,j1:j2,k1:k2)
+      ELSE
+         western_side = (nb == 1).AND.(ndir == 1)
+         eastern_side = (nb == 1).AND.(ndir == 2)
+         DO jk = k1, k2
+            DO jj = j1, j2
+               DO ji = i1, i2
+                   ! Velocity mask at boundary edge points:
+                  IF (ABS(ptab(ji,jj,jk) - umask(ji,jj,jk)) > 1.D-2) THEN
+                     IF (western_side) THEN
+                        WRITE(numout,*) 'ERROR with umask at the western border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk
+                        WRITE(numout,*) '      masks: parent, child ', ptab(ji,jj,jk), umask(ji,jj,jk)
+                        kindic_agr = kindic_agr + 1
+                     ELSEIF (eastern_side) THEN
+                        WRITE(numout,*) 'ERROR with umask at the eastern border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk
+                        WRITE(numout,*) '      masks: parent, child ', ptab(ji,jj,jk), umask(ji,jj,jk)
+                        kindic_agr = kindic_agr + 1
+                     ENDIF
+                  ENDIF
+               END DO
+            END DO
+         END DO
+         !
+      ENDIF
+      ! 
+   END SUBROUTINE interpumsk
+
+
+   SUBROUTINE interpvmsk( ptab, i1, i2, j1, j2, k1, k2, before, nb, ndir )
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE interpvmsk  ***
+      !!----------------------------------------------------------------------  
+      INTEGER                              , INTENT(in   ) ::   i1,i2,j1,j2,k1,k2
+      REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) ::   ptab
+      LOGICAL                              , INTENT(in   ) ::   before
+      INTEGER                              , INTENT(in   ) :: nb , ndir
+      !
+      INTEGER ::   ji, jj, jk
+      LOGICAL ::   northern_side, southern_side     
+      !!----------------------------------------------------------------------  
+      !    
+      IF( before ) THEN
+         ptab(i1:i2,j1:j2,k1:k2) = vmask(i1:i2,j1:j2,k1:k2)
+      ELSE
+         southern_side = (nb == 2).AND.(ndir == 1)
+         northern_side = (nb == 2).AND.(ndir == 2)
+         DO jk = k1, k2
+            DO jj = j1, j2
+               DO ji = i1, i2
+                   ! Velocity mask at boundary edge points:
+                  IF (ABS(ptab(ji,jj,jk) - vmask(ji,jj,jk)) > 1.D-2) THEN
+                     IF (southern_side) THEN
+                        WRITE(numout,*) 'ERROR with vmask at the southern border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk
+                        WRITE(numout,*) '      masks: parent, child ', ptab(ji,jj,jk), vmask(ji,jj,jk)
+                        kindic_agr = kindic_agr + 1
+                     ELSEIF (northern_side) THEN
+                        WRITE(numout,*) 'ERROR with vmask at the northern border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk
+                        WRITE(numout,*) '      masks: parent, child ', ptab(ji,jj,jk), vmask(ji,jj,jk)
+                        kindic_agr = kindic_agr + 1
+                     ENDIF
+                  ENDIF
+               END DO
+            END DO
+         END DO
+         !
+      ENDIF
+      ! 
+   END SUBROUTINE interpvmsk
+
+
+   SUBROUTINE interpavm( ptab, i1, i2, j1, j2, k1, k2, m1, m2, before )
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE interavm  ***
+      !!----------------------------------------------------------------------  
+      INTEGER                                    , INTENT(in   ) ::   i1, i2, j1, j2, k1, k2, m1, m2
+      REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2,m1:m2), INTENT(inout) ::   ptab
+      LOGICAL                                    , INTENT(in   ) ::   before
+      REAL(wp), DIMENSION(k1:k2) :: tabin, h_in
+      REAL(wp), DIMENSION(1:jpk) :: h_out
+      INTEGER  :: N_in, N_out, ji, jj, jk
+      !!----------------------------------------------------------------------  
+      !      
+      IF (before) THEN         
+         DO jk=k1,k2
+            DO jj=j1,j2
+              DO ji=i1,i2
+                    ptab(ji,jj,jk,1) = avm_k(ji,jj,jk)
+              END DO
+           END DO
+        END DO
+#ifdef key_vertical         
+        DO jk=k1,k2
+           DO jj=j1,j2
+              DO ji=i1,i2
+                 ptab(ji,jj,jk,2) = wmask(ji,jj,jk) * e3w_n(ji,jj,jk) 
+              END DO
+           END DO
+        END DO
+#endif
+      ELSE 
+#ifdef key_vertical         
+         avm_k(i1:i2,j1:j2,1:jpk) = 0.
+         DO jj=j1,j2
+            DO ji=i1,i2
+               N_in = 0
+               DO jk=k1,k2 !k2 = jpk of parent grid
+                  IF (ptab(ji,jj,jk,2) == 0) EXIT
+                  N_in = N_in + 1
+                  tabin(jk) = ptab(ji,jj,jk,1)
+                  h_in(N_in) = ptab(ji,jj,jk,2)
+               END DO
+               N_out = 0
+               DO jk=1,jpk ! jpk of child grid
+                  IF (wmask(ji,jj,jk) == 0) EXIT 
+                  N_out = N_out + 1
+                  h_out(jk) = e3t_n(ji,jj,jk)
+               ENDDO
+               IF (N_in > 0) THEN
+                  CALL reconstructandremap(tabin(1:N_in),h_in,avm_k(ji,jj,1:N_out),h_out,N_in,N_out)
+               ENDIF
+            ENDDO
+         ENDDO
+#else
+         avm_k(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2,1)
+#endif
+      ENDIF
+      !
+   END SUBROUTINE interpavm
+
+#else
+   !!----------------------------------------------------------------------
+   !!   Empty module                                          no AGRIF zoom
+   !!----------------------------------------------------------------------
+CONTAINS
+   SUBROUTINE Agrif_OCE_Interp_empty
+      WRITE(*,*)  'agrif_oce_interp : You should not have seen this print! error?'
+   END SUBROUTINE Agrif_OCE_Interp_empty
+#endif
+
+   !!======================================================================
+END MODULE agrif_oce_interp
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/NST_SRC/agrif_oce_sponge.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/NST_SRC/agrif_oce_sponge.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/NST_SRC/agrif_oce_sponge.F90	(revision 9570)
@@ -0,0 +1,619 @@
+#define SPONGE && define SPONGE_TOP
+
+MODULE agrif_oce_sponge
+   !!======================================================================
+   !!                   ***  MODULE  agrif_oce_interp  ***
+   !! AGRIF: sponge package for the ocean dynamics (OPA)
+   !!======================================================================
+   !! History :  2.0  !  2002-06  (XXX)  Original cade
+   !!             -   !  2005-11  (XXX) 
+   !!            3.2  !  2009-04  (R. Benshila) 
+   !!            3.6  !  2014-09  (R. Benshila) 
+   !!----------------------------------------------------------------------
+#if defined key_agrif
+   !!----------------------------------------------------------------------
+   !!   'key_agrif'                                              AGRIF zoom
+   !!----------------------------------------------------------------------
+   USE par_oce
+   USE oce
+   USE dom_oce
+   !
+   USE in_out_manager
+   USE agrif_oce
+   USE lbclnk          ! ocean lateral boundary conditions (or mpp link)
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC Agrif_Sponge, Agrif_Sponge_Tra, Agrif_Sponge_Dyn
+   PUBLIC interptsn_sponge, interpun_sponge, interpvn_sponge
+
+   !!----------------------------------------------------------------------
+   !! NEMO/NST 4.0 , NEMO Consortium (2017)
+   !! $Id$
+   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE Agrif_Sponge_Tra
+      !!----------------------------------------------------------------------
+      !!                 *** ROUTINE Agrif_Sponge_Tra ***
+      !!----------------------------------------------------------------------
+      REAL(wp) ::   zcoef   ! local scalar
+      
+      !!----------------------------------------------------------------------
+      !
+#if defined SPONGE
+      !! Assume persistence:
+      zcoef = REAL(Agrif_rhot()-1,wp)/REAL(Agrif_rhot())
+
+      CALL Agrif_Sponge
+      Agrif_SpecialValue    = 0._wp
+      Agrif_UseSpecialValue = .TRUE.
+      tabspongedone_tsn     = .FALSE.
+      !
+      CALL Agrif_Bc_Variable( tsn_sponge_id, calledweight=zcoef, procname=interptsn_sponge )
+      !
+      Agrif_UseSpecialValue = .FALSE.
+#endif
+      !
+   END SUBROUTINE Agrif_Sponge_Tra
+
+
+   SUBROUTINE Agrif_Sponge_dyn
+      !!----------------------------------------------------------------------
+      !!                 *** ROUTINE Agrif_Sponge_dyn ***
+      !!----------------------------------------------------------------------
+      REAL(wp) ::   zcoef   ! local scalar
+      !!----------------------------------------------------------------------
+      !
+#if defined SPONGE
+      zcoef = REAL(Agrif_rhot()-1,wp)/REAL(Agrif_rhot())
+
+      Agrif_SpecialValue=0.
+      Agrif_UseSpecialValue = ln_spc_dyn
+      !
+      tabspongedone_u = .FALSE.
+      tabspongedone_v = .FALSE.         
+      CALL Agrif_Bc_Variable( un_sponge_id, calledweight=zcoef, procname=interpun_sponge )
+      !
+      tabspongedone_u = .FALSE.
+      tabspongedone_v = .FALSE.
+      CALL Agrif_Bc_Variable( vn_sponge_id, calledweight=zcoef, procname=interpvn_sponge )
+      !
+      Agrif_UseSpecialValue = .FALSE.
+#endif
+      !
+   END SUBROUTINE Agrif_Sponge_dyn
+
+
+   SUBROUTINE Agrif_Sponge
+      !!----------------------------------------------------------------------
+      !!                 *** ROUTINE  Agrif_Sponge ***
+      !!----------------------------------------------------------------------
+      INTEGER  ::   ji, jj, ind1, ind2
+      INTEGER  ::   ispongearea
+      REAL(wp) ::   z1_spongearea
+      REAL(wp), DIMENSION(jpi,jpj) :: ztabramp
+      !!----------------------------------------------------------------------
+      !
+#if defined SPONGE || defined SPONGE_TOP
+      IF (( .NOT. spongedoneT ).OR.( .NOT. spongedoneU )) THEN
+         ! Define ramp from boundaries towards domain interior at T-points
+         ! Store it in ztabramp
+
+         ispongearea  = 2 + nn_sponge_len * Agrif_irhox()
+         z1_spongearea = 1._wp / REAL( ispongearea - 1 )
+         
+         ztabramp(:,:) = 0._wp
+
+         ! --- West --- !
+         IF( (nbondi == -1) .OR. (nbondi == 2) ) THEN
+            ind1 = 1+nbghostcells
+            ind2 = 1+nbghostcells + (ispongearea-1)
+            DO jj = 1, jpj
+               DO ji = ind1, ind2                  
+                  ztabramp(ji,jj) = REAL( ind2 - ji ) * z1_spongearea * umask(ind1,jj,1)
+               END DO
+            ENDDO
+         ENDIF
+
+         ! --- East --- !
+         IF( (nbondi == 1) .OR. (nbondi == 2) ) THEN
+            ind1 = nlci - (1+nbghostcells) - (ispongearea-1)
+            ind2 = nlci - (1+nbghostcells)
+            DO jj = 1, jpj
+               DO ji = ind1, ind2
+                  ztabramp(ji,jj) = MAX( ztabramp(ji,jj), REAL( ji - ind2 ) * z1_spongearea * umask(ind2-1,jj,1) )
+               ENDDO
+            ENDDO
+         ENDIF
+
+         ! --- South --- !
+         IF( (nbondj == -1) .OR. (nbondj == 2) ) THEN
+            ind1 = 1+nbghostcells
+            ind2 = 1+nbghostcells + (ispongearea-1)
+            DO jj = ind1, ind2
+               DO ji = 1, jpi
+                  ztabramp(ji,jj) = MAX( ztabramp(ji,jj), REAL( ind2 - jj ) * z1_spongearea * vmask(ji,ind1,1) )
+               END DO
+            ENDDO
+         ENDIF
+
+         ! --- North --- !
+         IF( (nbondj == 1) .OR. (nbondj == 2) ) THEN
+            ind1 = nlcj - (1+nbghostcells) - (ispongearea-1)
+            ind2 = nlcj - (1+nbghostcells)
+            DO jj = ind1, ind2
+               DO ji = 1, jpi
+                  ztabramp(ji,jj) = MAX( ztabramp(ji,jj), REAL( jj - ind2 ) * z1_spongearea * vmask(ji,ind2-1,1) )
+               END DO
+            ENDDO
+         ENDIF
+
+      ENDIF
+
+      ! Tracers
+      IF( .NOT. spongedoneT ) THEN
+         fsaht_spu(:,:) = 0._wp
+         fsaht_spv(:,:) = 0._wp
+         DO jj = 2, jpjm1
+            DO ji = 2, jpim1   ! vector opt.
+               fsaht_spu(ji,jj) = 0.5_wp * visc_tra * ( ztabramp(ji,jj) + ztabramp(ji+1,jj  ) )
+               fsaht_spv(ji,jj) = 0.5_wp * visc_tra * ( ztabramp(ji,jj) + ztabramp(ji  ,jj+1) )
+            END DO
+         END DO
+         CALL lbc_lnk( fsaht_spu, 'U', 1. )   ! Lateral boundary conditions
+         CALL lbc_lnk( fsaht_spv, 'V', 1. )
+         
+         spongedoneT = .TRUE.
+      ENDIF
+
+      ! Dynamics
+      IF( .NOT. spongedoneU ) THEN
+         fsahm_spt(:,:) = 0._wp
+         fsahm_spf(:,:) = 0._wp
+         DO jj = 2, jpjm1
+            DO ji = 2, jpim1   ! vector opt.
+               fsahm_spt(ji,jj) = visc_dyn * ztabramp(ji,jj)
+               fsahm_spf(ji,jj) = 0.25_wp * visc_dyn * ( ztabramp(ji,jj) + ztabramp(ji  ,jj+1) &
+                                                     &  +ztabramp(ji,jj) + ztabramp(ji+1,jj  ) )
+            END DO
+         END DO
+         CALL lbc_lnk( fsahm_spt, 'T', 1. )   ! Lateral boundary conditions
+         CALL lbc_lnk( fsahm_spf, 'F', 1. )
+         
+         spongedoneU = .TRUE.
+      ENDIF
+      !
+#endif
+      !
+   END SUBROUTINE Agrif_Sponge
+
+   SUBROUTINE interptsn_sponge( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before )
+      !!----------------------------------------------------------------------
+      !!                 *** ROUTINE interptsn_sponge ***
+      !!----------------------------------------------------------------------
+      INTEGER                                     , INTENT(in   ) ::   i1, i2, j1, j2, k1, k2, n1, n2
+      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) ::   tabres
+      LOGICAL                                     , INTENT(in   ) ::   before
+      !
+      INTEGER  ::   ji, jj, jk, jn   ! dummy loop indices
+      INTEGER  ::   iku, ikv
+      REAL(wp) :: ztsa, zabe1, zabe2, zbtr
+      REAL(wp), DIMENSION(i1:i2,j1:j2,jpk) :: ztu, ztv
+      REAL(wp), DIMENSION(i1:i2,j1:j2,jpk,n1:n2) ::tsbdiff
+      ! vertical interpolation:
+      REAL(wp), DIMENSION(i1:i2,j1:j2,jpk,n1:n2) ::tabres_child
+      REAL(wp), DIMENSION(k1:k2,n1:n2-1) :: tabin
+      REAL(wp), DIMENSION(k1:k2) :: h_in
+      REAL(wp), DIMENSION(1:jpk) :: h_out
+      INTEGER :: N_in, N_out
+      REAL(wp) :: h_diff
+      !!----------------------------------------------------------------------
+      !
+      IF( before ) THEN
+         DO jn = 1, jpts
+            DO jk=k1,k2
+               DO jj=j1,j2
+                  DO ji=i1,i2
+                     tabres(ji,jj,jk,jn) = tsb(ji,jj,jk,jn)
+                  END DO
+               END DO
+            END DO
+         END DO
+
+# if defined key_vertical
+         DO jk=k1,k2
+            DO jj=j1,j2
+               DO ji=i1,i2
+                  tabres(ji,jj,jk,jpts+1) = tmask(ji,jj,jk) * e3t_n(ji,jj,jk) 
+               END DO
+            END DO
+         END DO
+# endif
+
+      ELSE   
+         !
+# if defined key_vertical
+         tabres_child(:,:,:,:) = 0.
+         DO jj=j1,j2
+            DO ji=i1,i2
+               N_in = 0
+               DO jk=k1,k2 !k2 = jpk of parent grid
+                  IF (tabres(ji,jj,jk,n2) == 0) EXIT
+                  N_in = N_in + 1
+                  tabin(jk,:) = tabres(ji,jj,jk,n1:n2-1)
+                  h_in(N_in) = tabres(ji,jj,jk,n2)
+               END DO
+               N_out = 0
+               DO jk=1,jpk ! jpk of child grid
+                  IF (tmask(ji,jj,jk) == 0) EXIT 
+                  N_out = N_out + 1
+                  h_out(jk) = e3t_n(ji,jj,jk) !Child grid scale factors. Could multiply by e1e2t here instead of division above
+               ENDDO
+               IF (N_in > 0) THEN
+                  h_diff = sum(h_out(1:N_out))-sum(h_in(1:N_in))
+                  tabres(ji,jj,k2,:) = tabres(ji,jj,k2-1,:) !what is this line for?????
+                  DO jn=1,jpts
+                     call reconstructandremap(tabin(1:N_in,jn),h_in,tabres_child(ji,jj,1:N_out,jn),h_out,N_in,N_out)
+                  ENDDO
+               ENDIF
+            ENDDO
+         ENDDO
+# endif
+
+         DO jj=j1,j2
+            DO ji=i1,i2
+               DO jk=1,jpkm1
+# if defined key_vertical
+                  tsbdiff(ji,jj,jk,1:jpts) = tsb(ji,jj,jk,1:jpts) - tabres_child(ji,jj,jk,1:jpts)
+# else
+                  tsbdiff(ji,jj,jk,1:jpts) = tsb(ji,jj,jk,1:jpts) - tabres(ji,jj,jk,1:jpts)
+# endif
+               ENDDO
+            ENDDO
+         ENDDO
+
+         DO jn = 1, jpts            
+            DO jk = 1, jpkm1
+               DO jj = j1,j2-1
+                  DO ji = i1,i2-1
+                     zabe1 = fsaht_spu(ji,jj) * umask(ji,jj,jk) * e2_e1u(ji,jj) * e3u_n(ji,jj,jk)
+                     zabe2 = fsaht_spv(ji,jj) * vmask(ji,jj,jk) * e1_e2v(ji,jj) * e3v_n(ji,jj,jk)
+                     ztu(ji,jj,jk) = zabe1 * ( tsbdiff(ji+1,jj  ,jk,jn) - tsbdiff(ji,jj,jk,jn) ) 
+                     ztv(ji,jj,jk) = zabe2 * ( tsbdiff(ji  ,jj+1,jk,jn) - tsbdiff(ji,jj,jk,jn) )
+                  END DO
+               END DO
+               !
+               IF( ln_zps ) THEN      ! set gradient at partial step level
+                  DO jj = j1,j2-1
+                     DO ji = i1,i2-1
+                        ! last level
+                        iku = mbku(ji,jj)
+                        ikv = mbkv(ji,jj)
+                        IF( iku == jk )   ztu(ji,jj,jk) = 0._wp
+                        IF( ikv == jk )   ztv(ji,jj,jk) = 0._wp
+                     END DO
+                  END DO
+               ENDIF
+            END DO
+            !
+            DO jk = 1, jpkm1
+               DO jj = j1+1,j2-1
+                  DO ji = i1+1,i2-1
+                     IF (.NOT. tabspongedone_tsn(ji,jj)) THEN 
+                        zbtr = r1_e1e2t(ji,jj) / e3t_n(ji,jj,jk)
+                        ! horizontal diffusive trends
+                        ztsa = zbtr * (  ztu(ji,jj,jk) - ztu(ji-1,jj,jk) + ztv(ji,jj,jk) - ztv(ji,jj-1,jk)  )
+                        ! add it to the general tracer trends
+                        tsa(ji,jj,jk,jn) = tsa(ji,jj,jk,jn) + ztsa
+                     ENDIF
+                  END DO
+               END DO
+            END DO
+            !
+         END DO
+         !
+         tabspongedone_tsn(i1+1:i2-1,j1+1:j2-1) = .TRUE.
+         !
+      ENDIF
+      !
+   END SUBROUTINE interptsn_sponge
+
+   SUBROUTINE interpun_sponge(tabres,i1,i2,j1,j2,k1,k2,m1,m2, before)
+      !!---------------------------------------------
+      !!   *** ROUTINE interpun_sponge ***
+      !!---------------------------------------------    
+      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,m1,m2
+      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,m1:m2), INTENT(inout) :: tabres
+      LOGICAL, INTENT(in) :: before
+
+      INTEGER :: ji,jj,jk,jmax
+
+      ! sponge parameters 
+      REAL(wp) :: ze2u, ze1v, zua, zva, zbtr, h_diff
+      REAL(wp), DIMENSION(i1:i2,j1:j2,1:jpk) :: ubdiff
+      REAL(wp), DIMENSION(i1:i2,j1:j2,1:jpk) :: rotdiff, hdivdiff
+      ! vertical interpolation:
+      REAL(wp), DIMENSION(i1:i2,j1:j2,1:jpk) :: tabres_child
+      REAL(wp), DIMENSION(k1:k2) :: tabin, h_in
+      REAL(wp), DIMENSION(1:jpk) :: h_out
+      INTEGER ::N_in,N_out
+      !!---------------------------------------------    
+      !
+      IF( before ) THEN
+         DO jk=1,jpkm1
+            DO jj=j1,j2
+               DO ji=i1,i2
+                  tabres(ji,jj,jk,m1) = ub(ji,jj,jk)
+# if defined key_vertical
+                  tabres(ji,jj,jk,m2) = e3u_n(ji,jj,jk)*umask(ji,jj,jk)
+# endif
+               END DO
+            END DO
+         END DO
+
+      ELSE
+
+# if defined key_vertical
+         tabres_child(:,:,:) = 0._wp
+         DO jj=j1,j2
+            DO ji=i1,i2
+               N_in = 0
+               DO jk=k1,k2
+                  IF (tabres(ji,jj,jk,m2) == 0) EXIT
+                  N_in = N_in + 1
+                  tabin(jk) = tabres(ji,jj,jk,m1)
+                  h_in(N_in) = tabres(ji,jj,jk,m2)
+              ENDDO
+              !
+              IF (N_in == 0) THEN
+                 tabres_child(ji,jj,:) = 0.
+                 CYCLE
+              ENDIF
+         
+              N_out = 0
+              DO jk=1,jpk
+                 if (umask(ji,jj,jk) == 0) EXIT
+                 N_out = N_out + 1
+                 h_out(N_out) = e3u_n(ji,jj,jk)
+              ENDDO
+         
+              IF (N_out == 0) THEN
+                 tabres_child(ji,jj,:) = 0.
+                 CYCLE
+              ENDIF
+         
+              IF (N_in * N_out > 0) THEN
+                 h_diff = sum(h_out(1:N_out))-sum(h_in(1:N_in))
+                 if (h_diff < -1.e4) then
+                    print *,'CHECK YOUR BATHY ...', h_diff, sum(h_out(1:N_out)), sum(h_in(1:N_in))
+                 endif
+              ENDIF
+              call reconstructandremap(tabin(1:N_in),h_in(1:N_in),tabres_child(ji,jj,1:N_out),h_out(1:N_out),N_in,N_out)
+         
+            ENDDO
+         ENDDO
+
+         ubdiff(i1:i2,j1:j2,:) = (ub(i1:i2,j1:j2,:) - tabres_child(i1:i2,j1:j2,:))*umask(i1:i2,j1:j2,:)
+#else
+         ubdiff(i1:i2,j1:j2,:) = (ub(i1:i2,j1:j2,:) - tabres(i1:i2,j1:j2,:,1))*umask(i1:i2,j1:j2,:)
+#endif
+         !
+         DO jk = 1, jpkm1                                 ! Horizontal slab
+            !                                             ! ===============
+
+            !                                             ! --------
+            ! Horizontal divergence                       !   div
+            !                                             ! --------
+            DO jj = j1,j2
+               DO ji = i1+1,i2   ! vector opt.
+                  zbtr = r1_e1e2t(ji,jj) / e3t_n(ji,jj,jk) * fsahm_spt(ji,jj)
+                  hdivdiff(ji,jj,jk) = (  e2u(ji  ,jj)*e3u_n(ji  ,jj,jk) * ubdiff(ji  ,jj,jk) &
+                                     &   -e2u(ji-1,jj)*e3u_n(ji-1,jj,jk) * ubdiff(ji-1,jj,jk) ) * zbtr
+               END DO
+            END DO
+
+            DO jj = j1,j2-1
+               DO ji = i1,i2   ! vector opt.
+                  zbtr = r1_e1e2f(ji,jj) * e3f_n(ji,jj,jk) * fsahm_spf(ji,jj)
+                  rotdiff(ji,jj,jk) = ( -e1u(ji,jj+1) * ubdiff(ji,jj+1,jk)   &
+                                    &   +e1u(ji,jj  ) * ubdiff(ji,jj  ,jk) ) * fmask(ji,jj,jk) * zbtr 
+               END DO
+            END DO
+         END DO
+         !
+         DO jj = j1+1, j2-1
+            DO ji = i1+1, i2-1   ! vector opt.
+
+               IF (.NOT. tabspongedone_u(ji,jj)) THEN
+                  DO jk = 1, jpkm1                                 ! Horizontal slab
+                     ze2u = rotdiff (ji,jj,jk)
+                     ze1v = hdivdiff(ji,jj,jk)
+                     ! horizontal diffusive trends
+                     zua = - ( ze2u - rotdiff (ji,jj-1,jk) ) / ( e2u(ji,jj) * e3u_n(ji,jj,jk) )   &
+                           + ( hdivdiff(ji+1,jj,jk) - ze1v ) * r1_e1u(ji,jj)
+
+                     ! add it to the general momentum trends
+                     ua(ji,jj,jk) = ua(ji,jj,jk) + zua
+
+                  END DO
+               ENDIF
+
+            END DO
+         END DO
+
+         tabspongedone_u(i1+1:i2-1,j1+1:j2-1) = .TRUE.
+
+         jmax = j2-1
+         IF ((nbondj == 1).OR.(nbondj == 2)) jmax = MIN(jmax,nlcj-nbghostcells-2)   ! North
+
+         DO jj = j1+1, jmax
+            DO ji = i1+1, i2   ! vector opt.
+
+               IF (.NOT. tabspongedone_v(ji,jj)) THEN
+                  DO jk = 1, jpkm1                                 ! Horizontal slab
+                     ze2u = rotdiff (ji,jj,jk)
+                     ze1v = hdivdiff(ji,jj,jk)
+
+                     ! horizontal diffusive trends
+                     zva = + ( ze2u - rotdiff (ji-1,jj,jk) ) / ( e1v(ji,jj) * e3v_n(ji,jj,jk) )   &
+                           + ( hdivdiff(ji,jj+1,jk) - ze1v ) * r1_e2v(ji,jj)
+
+                     ! add it to the general momentum trends
+                     va(ji,jj,jk) = va(ji,jj,jk) + zva
+                  END DO
+               ENDIF
+               !
+            END DO
+         END DO
+         !
+         tabspongedone_v(i1+1:i2,j1+1:jmax) = .TRUE.
+         !
+      ENDIF
+      !
+   END SUBROUTINE interpun_sponge
+
+   SUBROUTINE interpvn_sponge(tabres,i1,i2,j1,j2,k1,k2,m1,m2, before,nb,ndir)
+      !!---------------------------------------------
+      !!   *** ROUTINE interpvn_sponge ***
+      !!--------------------------------------------- 
+      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,m1,m2
+      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,m1:m2), INTENT(inout) :: tabres
+      LOGICAL, INTENT(in) :: before
+      INTEGER, INTENT(in) :: nb , ndir
+      !
+      INTEGER  ::   ji, jj, jk, imax
+      REAL(wp) ::   ze2u, ze1v, zua, zva, zbtr, h_diff
+      REAL(wp), DIMENSION(i1:i2,j1:j2,1:jpk) :: vbdiff
+      REAL(wp), DIMENSION(i1:i2,j1:j2,1:jpk) :: rotdiff, hdivdiff
+      ! vertical interpolation:
+      REAL(wp), DIMENSION(i1:i2,j1:j2,1:jpk) :: tabres_child
+      REAL(wp), DIMENSION(k1:k2) :: tabin, h_in
+      REAL(wp), DIMENSION(1:jpk) :: h_out
+      INTEGER :: N_in, N_out
+      !!--------------------------------------------- 
+      
+      IF( before ) THEN 
+         DO jk=1,jpkm1
+            DO jj=j1,j2
+               DO ji=i1,i2
+                  tabres(ji,jj,jk,m1) = vb(ji,jj,jk)
+# if defined key_vertical
+                  tabres(ji,jj,jk,m2) = vmask(ji,jj,jk) * e3v_n(ji,jj,jk)
+# endif
+               END DO
+            END DO
+         END DO
+      ELSE
+
+# if defined key_vertical
+         tabres_child(:,:,:) = 0._wp
+         DO jj=j1,j2
+            DO ji=i1,i2
+               N_in = 0
+               DO jk=k1,k2
+                  IF (tabres(ji,jj,jk,m2) == 0) EXIT
+                  N_in = N_in + 1
+                  tabin(jk) = tabres(ji,jj,jk,m1)
+                  h_in(N_in) = tabres(ji,jj,jk,m2)
+              ENDDO
+         
+              IF (N_in == 0) THEN
+                 tabres_child(ji,jj,:) = 0.
+                 CYCLE
+              ENDIF
+         
+              N_out = 0
+              DO jk=1,jpk
+                 if (vmask(ji,jj,jk) == 0) EXIT
+                 N_out = N_out + 1
+                 h_out(N_out) = e3v_n(ji,jj,jk)
+              ENDDO
+         
+              IF (N_in * N_out > 0) THEN
+                 h_diff = sum(h_out(1:N_out))-sum(h_in(1:N_in))
+                 if (h_diff < -1.e4) then
+                    print *,'CHECK YOUR BATHY ...', h_diff, sum(h_out(1:N_out)), sum(h_in(1:N_in))
+                 endif
+              ENDIF
+              call reconstructandremap(tabin(1:N_in),h_in(1:N_in),tabres_child(ji,jj,1:N_out),h_out(1:N_out),N_in,N_out)
+            ENDDO
+         ENDDO
+
+         vbdiff(i1:i2,j1:j2,:) = (vb(i1:i2,j1:j2,:) - tabres_child(i1:i2,j1:j2,:))*vmask(i1:i2,j1:j2,:)  
+# else
+         vbdiff(i1:i2,j1:j2,:) = (vb(i1:i2,j1:j2,:) - tabres(i1:i2,j1:j2,:,1))*vmask(i1:i2,j1:j2,:)
+# endif
+         !
+         DO jk = 1, jpkm1                                 ! Horizontal slab
+            !                                             ! ===============
+
+            !                                             ! --------
+            ! Horizontal divergence                       !   div
+            !                                             ! --------
+            DO jj = j1+1,j2
+               DO ji = i1,i2   ! vector opt.
+                  zbtr = r1_e1e2t(ji,jj) / e3t_n(ji,jj,jk) * fsahm_spt(ji,jj)
+                  hdivdiff(ji,jj,jk) = ( e1v(ji,jj  ) * e3v_n(ji,jj  ,jk) * vbdiff(ji,jj  ,jk)  &
+                                     &  -e1v(ji,jj-1) * e3v_n(ji,jj-1,jk) * vbdiff(ji,jj-1,jk)  ) * zbtr
+               END DO
+            END DO
+            DO jj = j1,j2
+               DO ji = i1,i2-1   ! vector opt.
+                  zbtr = r1_e1e2f(ji,jj) * e3f_n(ji,jj,jk) * fsahm_spf(ji,jj)
+                  rotdiff(ji,jj,jk) = ( e2v(ji+1,jj) * vbdiff(ji+1,jj,jk) & 
+                                    &  -e2v(ji  ,jj) * vbdiff(ji  ,jj,jk)  ) * fmask(ji,jj,jk) * zbtr
+               END DO
+            END DO
+         END DO
+
+         !                                                ! ===============
+         !                                                
+
+         imax = i2 - 1
+         IF ((nbondi == 1).OR.(nbondi == 2))   imax = MIN(imax,nlci-nbghostcells-2)   ! East
+
+         DO jj = j1+1, j2
+            DO ji = i1+1, imax   ! vector opt.
+               IF( .NOT. tabspongedone_u(ji,jj) ) THEN
+                  DO jk = 1, jpkm1
+                     ua(ji,jj,jk) = ua(ji,jj,jk)                                                               &
+                        & - ( rotdiff (ji  ,jj,jk) - rotdiff (ji,jj-1,jk)) / ( e2u(ji,jj) * e3u_n(ji,jj,jk) )  &
+                        & + ( hdivdiff(ji+1,jj,jk) - hdivdiff(ji,jj  ,jk)) * r1_e1u(ji,jj)
+                  END DO
+               ENDIF
+            END DO
+         END DO
+         !
+         tabspongedone_u(i1+1:imax,j1+1:j2) = .TRUE.
+         !
+         DO jj = j1+1, j2-1
+            DO ji = i1+1, i2-1   ! vector opt.
+               IF( .NOT. tabspongedone_v(ji,jj) ) THEN
+                  DO jk = 1, jpkm1
+                     va(ji,jj,jk) = va(ji,jj,jk)                                                                  &
+                        &  + ( rotdiff (ji,jj  ,jk) - rotdiff (ji-1,jj,jk) ) / ( e1v(ji,jj) * e3v_n(ji,jj,jk) )   &
+                        &  + ( hdivdiff(ji,jj+1,jk) - hdivdiff(ji  ,jj,jk) ) * r1_e2v(ji,jj)
+                  END DO
+               ENDIF
+            END DO
+         END DO
+         tabspongedone_v(i1+1:i2-1,j1+1:j2-1) = .TRUE.
+      ENDIF
+      !
+   END SUBROUTINE interpvn_sponge
+
+#else
+   !!----------------------------------------------------------------------
+   !!   Empty module                                          no AGRIF zoom
+   !!----------------------------------------------------------------------
+CONTAINS
+   SUBROUTINE agrif_oce_sponge_empty
+      WRITE(*,*)  'agrif_oce_sponge : You should not have seen this print! error?'
+   END SUBROUTINE agrif_oce_sponge_empty
+#endif
+
+   !!======================================================================
+END MODULE agrif_oce_sponge
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/NST_SRC/agrif_oce_update.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/NST_SRC/agrif_oce_update.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/NST_SRC/agrif_oce_update.F90	(revision 9570)
@@ -0,0 +1,1421 @@
+#define TWO_WAY        /* TWO WAY NESTING */
+#undef DECAL_FEEDBACK  /* SEPARATION of INTERFACES*/
+#undef VOL_REFLUX      /* VOLUME REFLUXING*/
+ 
+MODULE agrif_oce_update
+   !!======================================================================
+   !!                   ***  MODULE  agrif_oce_interp  ***
+   !! AGRIF: update package for the ocean dynamics (OPA)
+   !!======================================================================
+   !! History :  2.0  !  2002-06  (L. Debreu)  Original code
+   !!            3.2  !  2009-04  (R. Benshila) 
+   !!            3.6  !  2014-09  (R. Benshila) 
+   !!----------------------------------------------------------------------
+#if defined key_agrif 
+   !!----------------------------------------------------------------------
+   !!   'key_agrif'                                              AGRIF zoom
+   !!----------------------------------------------------------------------
+   USE par_oce
+   USE oce
+   USE dom_oce
+   USE zdf_oce        ! vertical physics: ocean variables 
+   USE agrif_oce
+   !
+   USE in_out_manager ! I/O manager
+   USE lib_mpp        ! MPP library
+   USE domvvl         ! Need interpolation routines 
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   Agrif_Update_Tra, Agrif_Update_Dyn, Agrif_Update_vvl, Agrif_Update_ssh
+   PUBLIC   Update_Scales
+
+   !!----------------------------------------------------------------------
+   !! NEMO/NST 4.0 , NEMO Consortium (2017)
+   !! $Id$
+   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE Agrif_Update_Tra( )
+      !!----------------------------------------------------------------------
+      !!                   *** ROUTINE Agrif_Update_Tra ***
+      !!----------------------------------------------------------------------
+      ! 
+      IF (Agrif_Root()) RETURN
+      !
+#if defined TWO_WAY  
+      IF (lwp.AND.lk_agrif_debug) Write(*,*) 'Update tracers  from grid Number',Agrif_Fixed()
+
+      Agrif_UseSpecialValueInUpdate = .TRUE.
+      Agrif_SpecialValueFineGrid    = 0._wp
+      ! 
+# if ! defined DECAL_FEEDBACK
+      CALL Agrif_Update_Variable(tsn_id, procname=updateTS)
+! near boundary update:
+!      CALL Agrif_Update_Variable(tsn_id,locupdate=(/0,2/), procname=updateTS)
+# else
+      CALL Agrif_Update_Variable(tsn_id, locupdate=(/1,0/),procname=updateTS)
+! near boundary update:
+!      CALL Agrif_Update_Variable(tsn_id,locupdate=(/1,2/), procname=updateTS)
+# endif
+      !
+      Agrif_UseSpecialValueInUpdate = .FALSE.
+      !
+#endif
+      !
+   END SUBROUTINE Agrif_Update_Tra
+
+   SUBROUTINE Agrif_Update_Dyn( )
+      !!----------------------------------------------------------------------
+      !!                   *** ROUTINE Agrif_Update_Dyn ***
+      !!----------------------------------------------------------------------
+      ! 
+      IF (Agrif_Root()) RETURN
+      !
+#if defined TWO_WAY
+      IF (lwp.AND.lk_agrif_debug) Write(*,*) 'Update momentum from grid Number',Agrif_Fixed()
+
+      Agrif_UseSpecialValueInUpdate = .FALSE.
+      Agrif_SpecialValueFineGrid = 0.
+      !     
+# if ! defined DECAL_FEEDBACK
+      CALL Agrif_Update_Variable(un_update_id,procname = updateU)
+      CALL Agrif_Update_Variable(vn_update_id,procname = updateV)
+! near boundary update:
+!      CALL Agrif_Update_Variable(un_update_id,locupdate=(/0,1/),procname = updateU)
+!      CALL Agrif_Update_Variable(vn_update_id,locupdate=(/0,1/),procname = updateV)
+# else
+      CALL Agrif_Update_Variable(un_update_id,locupdate1=(/0,-1/),locupdate2=(/1,-2/),procname = updateU)
+      CALL Agrif_Update_Variable(vn_update_id,locupdate1=(/1,-2/),locupdate2=(/0,-1/),procname = updateV)
+! near boundary update:
+!      CALL Agrif_Update_Variable(un_update_id,locupdate1=(/0,1/),locupdate2=(/1,1/),procname = updateU)
+!      CALL Agrif_Update_Variable(vn_update_id,locupdate1=(/1,1/),locupdate2=(/0,1/),procname = updateV)
+# endif
+
+# if ! defined DECAL_FEEDBACK
+      CALL Agrif_Update_Variable(e1u_id,procname = updateU2d)
+      CALL Agrif_Update_Variable(e2v_id,procname = updateV2d)  
+# else
+      CALL Agrif_Update_Variable(e1u_id,locupdate1=(/0,-1/),locupdate2=(/1,-2/),procname = updateU2d)
+      CALL Agrif_Update_Variable(e2v_id,locupdate1=(/1,-2/),locupdate2=(/0,-1/),procname = updateV2d)  
+# endif
+      !
+# if ! defined DECAL_FEEDBACK
+      ! Account for updated thicknesses at boundary edges
+      IF (.NOT.ln_linssh) THEN
+!         CALL Agrif_Update_Variable(un_update_id,locupdate1=(/0,0/),locupdate2=(/0,0/),procname = correct_u_bdy)
+!         CALL Agrif_Update_Variable(vn_update_id,locupdate1=(/0,0/),locupdate2=(/0,0/),procname = correct_v_bdy)
+      ENDIF
+# endif
+      ! 
+      IF ( ln_dynspg_ts .AND. ln_bt_fw ) THEN
+         ! Update time integrated transports
+#  if ! defined DECAL_FEEDBACK
+         CALL Agrif_Update_Variable(ub2b_update_id,procname = updateub2b)
+         CALL Agrif_Update_Variable(vb2b_update_id,procname = updatevb2b)
+#  else
+         CALL Agrif_Update_Variable(ub2b_update_id,locupdate1=(/0,-1/),locupdate2=(/1,-2/),procname = updateub2b)
+         CALL Agrif_Update_Variable(vb2b_update_id,locupdate1=(/1,-2/),locupdate2=(/0,-1/),procname = updatevb2b)
+#  endif
+      END IF
+#endif
+      !
+   END SUBROUTINE Agrif_Update_Dyn
+
+   SUBROUTINE Agrif_Update_ssh( )
+      !!---------------------------------------------
+      !!   *** ROUTINE Agrif_Update_ssh ***
+      !!---------------------------------------------
+      ! 
+      IF (Agrif_Root()) RETURN
+      !
+#if defined TWO_WAY
+      !
+      Agrif_UseSpecialValueInUpdate = .TRUE.
+      Agrif_SpecialValueFineGrid = 0.
+# if ! defined DECAL_FEEDBACK
+      CALL Agrif_Update_Variable(sshn_id,procname = updateSSH)
+# else
+      CALL Agrif_Update_Variable(sshn_id,locupdate=(/1,0/),procname = updateSSH)
+# endif
+      !
+      Agrif_UseSpecialValueInUpdate = .FALSE.
+      !
+#  if defined DECAL_FEEDBACK && defined VOL_REFLUX
+      IF ( ln_dynspg_ts.AND.ln_bt_fw ) THEN
+         ! Refluxing on ssh:
+         CALL Agrif_Update_Variable(ub2b_update_id,locupdate1=(/0, 0/),locupdate2=(/1, 1/),procname = reflux_sshu)
+         CALL Agrif_Update_Variable(vb2b_update_id,locupdate1=(/1, 1/),locupdate2=(/0, 0/),procname = reflux_sshv)
+      END IF
+#  endif
+      !
+#endif
+      !
+   END SUBROUTINE Agrif_Update_ssh
+
+
+   SUBROUTINE Agrif_Update_Tke( kt )
+      !!---------------------------------------------
+      !!   *** ROUTINE Agrif_Update_Tke ***
+      !!---------------------------------------------
+      !!
+      INTEGER, INTENT(in) :: kt 
+      ! 
+      IF (Agrif_Root()) RETURN
+      !       
+      IF( ( Agrif_NbStepint() .NE. 0 ) .AND. (kt /= 0) ) RETURN
+#  if defined TWO_WAY
+
+      Agrif_UseSpecialValueInUpdate = .TRUE.
+      Agrif_SpecialValueFineGrid = 0.
+
+      CALL Agrif_Update_Variable( en_id, locupdate=(/0,0/), procname=updateEN  )
+      CALL Agrif_Update_Variable(avt_id, locupdate=(/0,0/), procname=updateAVT )
+      CALL Agrif_Update_Variable(avm_id, locupdate=(/0,0/), procname=updateAVM )
+
+      Agrif_UseSpecialValueInUpdate = .FALSE.
+
+#  endif
+      
+   END SUBROUTINE Agrif_Update_Tke
+
+
+   SUBROUTINE Agrif_Update_vvl( )
+      !!---------------------------------------------
+      !!   *** ROUTINE Agrif_Update_vvl ***
+      !!---------------------------------------------
+      !
+      IF (Agrif_Root()) RETURN
+      !
+#if defined TWO_WAY  
+      !
+      IF (lwp.AND.lk_agrif_debug) Write(*,*) 'Update e3 from grid Number',Agrif_Fixed(), 'Step', Agrif_Nb_Step()
+      !
+      Agrif_UseSpecialValueInUpdate = .TRUE.
+      Agrif_SpecialValueFineGrid = 0.
+      ! 
+      ! No interface separation here, update vertical grid at T points 
+      ! everywhere over the overlapping regions (one account for refluxing in that case):
+      CALL Agrif_Update_Variable(e3t_id, procname=updatee3t) 
+      !
+      Agrif_UseSpecialValueInUpdate = .FALSE.
+      !
+      CALL Agrif_ChildGrid_To_ParentGrid()
+      CALL dom_vvl_update_UVF
+      CALL Agrif_ParentGrid_To_ChildGrid()
+      !
+#endif
+      !
+   END SUBROUTINE Agrif_Update_vvl
+
+   SUBROUTINE dom_vvl_update_UVF
+      !!---------------------------------------------
+      !!       *** ROUTINE dom_vvl_update_UVF ***
+      !!---------------------------------------------
+      !!
+      INTEGER :: jk
+      REAL(wp):: zcoef
+      !!---------------------------------------------
+
+      IF (lwp.AND.lk_agrif_debug) Write(*,*) 'Finalize e3 on grid Number', &
+                  & Agrif_Fixed(), 'Step', Agrif_Nb_Step()
+
+      ! Save "old" scale factor (prior update) for subsequent asselin correction
+      ! of prognostic variables
+      ! -----------------------
+      !
+      e3u_a(:,:,:) = e3u_n(:,:,:)
+      e3v_a(:,:,:) = e3v_n(:,:,:)
+!      ua(:,:,:) = e3u_b(:,:,:)
+!      va(:,:,:) = e3v_b(:,:,:)
+      hu_a(:,:) = hu_n(:,:)
+      hv_a(:,:) = hv_n(:,:)
+
+      ! 1) NOW fields
+      !--------------
+      
+         ! Vertical scale factor interpolations
+         ! ------------------------------------
+      CALL dom_vvl_interpol( e3t_n(:,:,:), e3u_n(:,:,:) ,  'U' )
+      CALL dom_vvl_interpol( e3t_n(:,:,:), e3v_n(:,:,:) ,  'V' )
+      CALL dom_vvl_interpol( e3u_n(:,:,:), e3f_n(:,:,:) ,  'F' )
+
+      CALL dom_vvl_interpol( e3u_n(:,:,:), e3uw_n(:,:,:), 'UW' )
+      CALL dom_vvl_interpol( e3v_n(:,:,:), e3vw_n(:,:,:), 'VW' )
+
+         ! Update total depths:
+         ! --------------------
+      hu_n(:,:) = 0._wp                        ! Ocean depth at U-points
+      hv_n(:,:) = 0._wp                        ! Ocean depth at V-points
+      DO jk = 1, jpkm1
+         hu_n(:,:) = hu_n(:,:) + e3u_n(:,:,jk) * umask(:,:,jk)
+         hv_n(:,:) = hv_n(:,:) + e3v_n(:,:,jk) * vmask(:,:,jk)
+      END DO
+      !                                        ! Inverse of the local depth
+      r1_hu_n(:,:) = ssumask(:,:) / ( hu_n(:,:) + 1._wp - ssumask(:,:) )
+      r1_hv_n(:,:) = ssvmask(:,:) / ( hv_n(:,:) + 1._wp - ssvmask(:,:) )
+
+
+      ! 2) BEFORE fields:
+      !------------------
+      IF (.NOT.(lk_agrif_fstep.AND.(neuler==0) )) THEN
+         !
+         ! Vertical scale factor interpolations
+         ! ------------------------------------
+         CALL dom_vvl_interpol( e3t_b(:,:,:), e3u_b(:,:,:),  'U'  )
+         CALL dom_vvl_interpol( e3t_b(:,:,:), e3v_b(:,:,:),  'V'  )
+
+         CALL dom_vvl_interpol( e3u_b(:,:,:), e3uw_b(:,:,:), 'UW' )
+         CALL dom_vvl_interpol( e3v_b(:,:,:), e3vw_b(:,:,:), 'VW' )
+
+         ! Update total depths:
+         ! --------------------
+         hu_b(:,:) = 0._wp                     ! Ocean depth at U-points
+         hv_b(:,:) = 0._wp                     ! Ocean depth at V-points
+         DO jk = 1, jpkm1
+            hu_b(:,:) = hu_b(:,:) + e3u_b(:,:,jk) * umask(:,:,jk)
+            hv_b(:,:) = hv_b(:,:) + e3v_b(:,:,jk) * vmask(:,:,jk)
+         END DO
+         !                                     ! Inverse of the local depth
+         r1_hu_b(:,:) = ssumask(:,:) / ( hu_b(:,:) + 1._wp - ssumask(:,:) )
+         r1_hv_b(:,:) = ssvmask(:,:) / ( hv_b(:,:) + 1._wp - ssvmask(:,:) )
+      ENDIF
+      !
+   END SUBROUTINE dom_vvl_update_UVF
+
+#if defined key_vertical
+
+   SUBROUTINE updateTS( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before )
+      !!----------------------------------------------------------------------
+      !!           *** ROUTINE updateT ***
+      !!---------------------------------------------
+      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2
+      REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres
+      LOGICAL, INTENT(in) :: before
+      !!
+      INTEGER :: ji,jj,jk,jn
+      REAL(wp), DIMENSION(i1:i2,j1:j2,1:jpk,n1:n2) :: tabres_child
+      REAL(wp) :: h_in(k1:k2)
+      REAL(wp) :: h_out(1:jpk)
+      INTEGER  :: N_in, N_out
+      REAL(wp) :: h_diff
+      REAL(wp) :: tabin(k1:k2,n1:n2)
+      !!---------------------------------------------
+      !
+      IF (before) THEN
+         AGRIF_SpecialValue = -999._wp
+         zrho_xy = Agrif_rhox() * Agrif_rhoy() 
+         DO jn = n1,n2-1
+            DO jk=k1,k2
+               DO jj=j1,j2
+                  DO ji=i1,i2
+                     tabres(ji,jj,jk,jn) = (tsn(ji,jj,jk,jn) * e3t_n(ji,jj,jk) ) &
+                                           * tmask(ji,jj,jk) + (tmask(ji,jj,jk)-1)*999._wp
+                  END DO
+               END DO
+            END DO
+         END DO
+         DO jk=k1,k2
+            DO jj=j1,j2
+               DO ji=i1,i2
+                  tabres(ji,jj,jk,n2) = tmask(ji,jj,jk) * e3t_n(ji,jj,jk) &
+                                           + (tmask(ji,jj,jk)-1)*999._wp
+               END DO
+            END DO
+         END DO
+      ELSE
+         tabres_child(:,:,:,:) = 0.
+         AGRIF_SpecialValue = 0._wp
+         DO jj=j1,j2
+            DO ji=i1,i2
+               N_in = 0
+               DO jk=k1,k2 !k2 = jpk of child grid
+                  IF (tabres(ji,jj,jk,n2) == 0  ) EXIT
+                  N_in = N_in + 1
+                  tabin(jk,:) = tabres(ji,jj,jk,n1:n2-1)/tabres(ji,jj,jk,n2)
+                  h_in(N_in) = tabres(ji,jj,jk,n2)
+               ENDDO
+               N_out = 0
+               DO jk=1,jpk ! jpk of parent grid
+                  IF (tmask(ji,jj,jk) < -900) EXIT ! TODO: Will not work with ISF
+                  N_out = N_out + 1
+                  h_out(N_out) = e3t_n(ji,jj,jk) 
+               ENDDO
+               IF (N_in > 0) THEN !Remove this?
+                  h_diff = sum(h_out(1:N_out))-sum(h_in(1:N_in))
+                  IF (h_diff < -1.e-4) THEN
+                     print *,'CHECK YOUR bathy T points ...',ji,jj,h_diff,sum(h_in(1:N_in)),sum(h_out(1:N_out))
+                     print *,h_in(1:N_in)
+                     print *,h_out(1:N_out)
+                     STOP
+                  ENDIF
+                  DO jn=n1,n2-1
+                     CALL reconstructandremap(tabin(1:N_in,jn),h_in(1:N_in),tabres_child(ji,jj,1:N_out,jn),h_out(1:N_out),N_in,N_out)
+                  ENDDO
+               ENDIF
+            ENDDO
+         ENDDO
+
+         IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN
+            ! Add asselin part
+            DO jn = n1,n2-1
+               DO jk=1,jpk
+                  DO jj=j1,j2
+                     DO ji=i1,i2
+                        IF( tabres_child(ji,jj,jk,jn) .NE. 0. ) THEN
+                           tsb(ji,jj,jk,jn) = tsb(ji,jj,jk,jn) & 
+                                 & + atfp * ( tabres_child(ji,jj,jk,jn) &
+                                 &          - tsn(ji,jj,jk,jn) ) * tmask(ji,jj,jk)
+                        ENDIF
+                     ENDDO
+                  ENDDO
+               ENDDO
+            ENDDO
+         ENDIF
+         DO jn = n1,n2-1
+            DO jk=1,jpk
+               DO jj=j1,j2
+                  DO ji=i1,i2
+                     IF( tabres_child(ji,jj,jk,jn) .NE. 0. ) THEN 
+                        tsn(ji,jj,jk,jn) = tabres_child(ji,jj,jk,jn) * tmask(ji,jj,jk)
+                     END IF
+                  END DO
+               END DO
+            END DO
+         END DO
+      ENDIF
+      ! 
+   END SUBROUTINE updateTS
+
+# else
+
+   SUBROUTINE updateTS( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before )
+      !!---------------------------------------------
+      !!           *** ROUTINE updateT ***
+      !!---------------------------------------------
+      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2
+      REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres
+      LOGICAL, INTENT(in) :: before
+      !!
+      INTEGER :: ji,jj,jk,jn
+      REAL(wp) :: ztb, ztnu, ztno
+      !!---------------------------------------------
+      !
+      IF (before) THEN
+         DO jn = 1,jpts
+            DO jk=k1,k2
+               DO jj=j1,j2
+                  DO ji=i1,i2
+!> jc tmp
+                     tabres(ji,jj,jk,jn) = tsn(ji,jj,jk,jn)  * e3t_n(ji,jj,jk) / e3t_0(ji,jj,jk)
+!                     tabres(ji,jj,jk,jn) = tsn(ji,jj,jk,jn)  * e3t_n(ji,jj,jk)
+!< jc tmp
+                  END DO
+               END DO
+            END DO
+         END DO
+      ELSE
+!> jc tmp
+         DO jn = 1,jpts
+            tabres(i1:i2,j1:j2,k1:k2,jn) =  tabres(i1:i2,j1:j2,k1:k2,jn) * e3t_0(i1:i2,j1:j2,k1:k2) &
+                                         & * tmask(i1:i2,j1:j2,k1:k2)
+         ENDDO
+!< jc tmp
+         IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN
+            ! Add asselin part
+            DO jn = 1,jpts
+               DO jk = k1, k2
+                  DO jj = j1, j2
+                     DO ji = i1, i2
+                        IF( tabres(ji,jj,jk,jn) /= 0._wp ) THEN
+                           ztb  = tsb(ji,jj,jk,jn) * e3t_b(ji,jj,jk) ! fse3t_b prior update should be used
+                           ztnu = tabres(ji,jj,jk,jn)
+                           ztno = tsn(ji,jj,jk,jn) * e3t_a(ji,jj,jk)
+                           tsb(ji,jj,jk,jn) = ( ztb + atfp * ( ztnu - ztno) )  & 
+                                     &        * tmask(ji,jj,jk) / e3t_b(ji,jj,jk)
+                        ENDIF
+                     END DO
+                  END DO
+               END DO
+            END DO
+         ENDIF
+         DO jn = 1,jpts
+            DO jk=k1,k2
+               DO jj=j1,j2
+                  DO ji=i1,i2
+                     IF( tabres(ji,jj,jk,jn) /= 0._wp ) THEN 
+                        tsn(ji,jj,jk,jn) = tabres(ji,jj,jk,jn) / e3t_n(ji,jj,jk)
+                     END IF
+                  END DO
+               END DO
+            END DO
+         END DO
+         !
+         IF  ((neuler==0).AND.(Agrif_Nb_Step()==0) ) THEN
+            tsb(i1:i2,j1:j2,k1:k2,1:jpts)  = tsn(i1:i2,j1:j2,k1:k2,1:jpts)
+         ENDIF
+         !
+      ENDIF
+      ! 
+   END SUBROUTINE updateTS
+
+# endif
+
+# if defined key_vertical
+
+   SUBROUTINE updateu( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before )
+      !!---------------------------------------------
+      !!           *** ROUTINE updateu ***
+      !!---------------------------------------------
+      INTEGER                                     , INTENT(in   ) :: i1, i2, j1, j2, k1, k2, n1, n2
+      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres
+      LOGICAL                                     , INTENT(in   ) :: before
+      !
+      INTEGER ::   ji, jj, jk
+      REAL(wp)::   zrhoy
+! VERTICAL REFINEMENT BEGIN
+      REAL(wp), DIMENSION(i1:i2,j1:j2,1:jpk) :: tabres_child
+      REAL(wp) :: h_in(k1:k2)
+      REAL(wp) :: h_out(1:jpk)
+      INTEGER  :: N_in, N_out
+      REAL(wp) :: h_diff, excess, thick
+      REAL(wp) :: tabin(k1:k2)
+! VERTICAL REFINEMENT END
+      !!---------------------------------------------
+      ! 
+      IF( before ) THEN
+         zrhoy = Agrif_Rhoy()
+         AGRIF_SpecialValue = -999._wp
+         DO jk=k1,k2
+            DO jj=j1,j2
+               DO ji=i1,i2
+                  tabres(ji,jj,jk,1) = zrhoy * e2u(ji,jj) * e3u_n(ji,jj,jk) * umask(ji,jj,jk) * un(ji,jj,jk)  &
+                                       + (umask(ji,jj,jk)-1)*999._wp
+                  tabres(ji,jj,jk,2) = zrhoy * umask(ji,jj,jk) * e2u(ji,jj) * e3u_n(ji,jj,jk)  &
+                                       + (umask(ji,jj,jk)-1)*999._wp
+               END DO
+            END DO
+         END DO
+      ELSE
+         tabres_child(:,:,:) = 0.
+         AGRIF_SpecialValue = 0._wp
+         DO jj=j1,j2
+            DO ji=i1,i2
+               N_in = 0
+               h_in(:) = 0._wp
+               tabin(:) = 0._wp
+               DO jk=k1,k2 !k2=jpk of child grid
+                  IF( tabres(ji,jj,jk,2) < -900) EXIT
+                  N_in = N_in + 1
+                  tabin(jk) = tabres(ji,jj,jk,1)/tabres(ji,jj,jk,2)
+                  h_in(N_in) = tabres(ji,jj,jk,2)/e2u(ji,jj)
+               ENDDO
+               N_out = 0
+               DO jk=1,jpk
+                  IF (umask(ji,jj,jk) == 0) EXIT
+                  N_out = N_out + 1
+                  h_out(N_out) = e3u_n(ji,jj,jk)
+               ENDDO
+               IF (N_in * N_out > 0) THEN
+                  h_diff = sum(h_out(1:N_out))-sum(h_in(1:N_in))
+                  IF (h_diff < -1.e-4) THEN
+!Even if bathy at T points match it's possible for the U points to be deeper in the child grid. 
+!In this case we need to move transport from the child grid cells below bed of parent grid into the bottom cell.
+                     excess = 0._wp
+                     DO jk=N_in,1,-1
+                        thick = MIN(-1*h_diff, h_in(jk))
+                        excess = excess + tabin(jk)*thick*e2u(ji,jj)
+                        tabin(jk) = tabin(jk)*(1. - thick/h_in(jk))
+                        h_diff = h_diff + thick
+                        IF ( h_diff == 0) THEN
+                           N_in = jk
+                           h_in(jk) = h_in(jk) - thick
+                           EXIT
+                        ENDIF
+                     ENDDO
+                  ENDIF
+                  CALL reconstructandremap(tabin(1:N_in),h_in(1:N_in),tabres_child(ji,jj,1:N_out),h_out(1:N_out),N_in,N_out)
+                  tabres_child(ji,jj,N_out) = tabres_child(ji,jj,N_out) + excess/(e2u(ji,jj)*h_out(N_out))
+               ENDIF
+            ENDDO
+         ENDDO
+
+         DO jk=1,jpk
+            DO jj=j1,j2
+               DO ji=i1,i2
+                  IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN ! Add asselin part
+                     ub(ji,jj,jk) = ub(ji,jj,jk) & 
+                           & + atfp * ( tabres_child(ji,jj,jk) - un(ji,jj,jk) ) * umask(ji,jj,jk)
+                  ENDIF
+                  !
+                  un(ji,jj,jk) = tabres_child(ji,jj,jk) * umask(ji,jj,jk)
+               END DO
+            END DO
+         END DO
+      ENDIF
+      ! 
+   END SUBROUTINE updateu
+
+#else
+
+   SUBROUTINE updateu( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before )
+      !!---------------------------------------------
+      !!           *** ROUTINE updateu ***
+      !!---------------------------------------------
+      INTEGER                               , INTENT(in   ) :: i1, i2, j1, j2, k1, k2, n1, n2
+      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres
+      LOGICAL                                     , INTENT(in   ) :: before
+      !
+      INTEGER  :: ji, jj, jk
+      REAL(wp) :: zrhoy, zub, zunu, zuno
+      !!---------------------------------------------
+      ! 
+      IF( before ) THEN
+         zrhoy = Agrif_Rhoy()
+         DO jk = k1, k2
+            tabres(i1:i2,j1:j2,jk,1) = zrhoy * e2u(i1:i2,j1:j2) * e3u_n(i1:i2,j1:j2,jk) * un(i1:i2,j1:j2,jk)
+         END DO
+      ELSE
+         DO jk=k1,k2
+            DO jj=j1,j2
+               DO ji=i1,i2
+                  tabres(ji,jj,jk,1) = tabres(ji,jj,jk,1) * r1_e2u(ji,jj) 
+                  !
+                  IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN ! Add asselin part
+                     zub  = ub(ji,jj,jk) * e3u_b(ji,jj,jk)  ! fse3t_b prior update should be used
+                     zuno = un(ji,jj,jk) * e3u_a(ji,jj,jk)
+                     zunu = tabres(ji,jj,jk,1)
+                     ub(ji,jj,jk) = ( zub + atfp * ( zunu - zuno) ) &      
+                                    & * umask(ji,jj,jk) / e3u_b(ji,jj,jk)
+                  ENDIF
+                  !
+                  un(ji,jj,jk) = tabres(ji,jj,jk,1) * umask(ji,jj,jk) / e3u_n(ji,jj,jk)
+               END DO
+            END DO
+         END DO
+         !
+         IF  ((neuler==0).AND.(Agrif_Nb_Step()==0) ) THEN
+            ub(i1:i2,j1:j2,k1:k2)  = un(i1:i2,j1:j2,k1:k2)
+         ENDIF
+         !
+      ENDIF
+      ! 
+   END SUBROUTINE updateu
+
+# endif
+
+   SUBROUTINE correct_u_bdy( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before, nb, ndir )
+      !!---------------------------------------------
+      !!           *** ROUTINE correct_u_bdy ***
+      !!---------------------------------------------
+      INTEGER                                     , INTENT(in   ) :: i1, i2, j1, j2, k1, k2, n1, n2
+      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres
+      LOGICAL                                     , INTENT(in   ) :: before
+      INTEGER                                     , INTENT(in)    :: nb, ndir
+      !!
+      LOGICAL :: western_side, eastern_side 
+      !
+      INTEGER  :: jj, jk
+      REAL(wp) :: zcor
+      !!---------------------------------------------
+      ! 
+      IF( .NOT.before ) THEN
+         !
+         western_side  = (nb == 1).AND.(ndir == 1)
+         eastern_side  = (nb == 1).AND.(ndir == 2)
+         !
+         IF (western_side) THEN
+            DO jj=j1,j2
+               zcor = un_b(i1-1,jj) * hu_a(i1-1,jj) * r1_hu_n(i1-1,jj) - un_b(i1-1,jj)
+               un_b(i1-1,jj) = un_b(i1-1,jj) + zcor
+               DO jk=1,jpkm1
+                  un(i1-1,jj,jk) = un(i1-1,jj,jk) + zcor * umask(i1-1,jj,jk)
+               END DO 
+            END DO
+         ENDIF
+         !
+         IF (eastern_side) THEN
+            DO jj=j1,j2
+               zcor = un_b(i2+1,jj) * hu_a(i2+1,jj) * r1_hu_n(i2+1,jj) - un_b(i2+1,jj)
+               un_b(i2+1,jj) = un_b(i2+1,jj) + zcor
+               DO jk=1,jpkm1
+                  un(i2+1,jj,jk) = un(i2+1,jj,jk) + zcor * umask(i2+1,jj,jk)
+               END DO 
+            END DO
+         ENDIF
+         !
+      ENDIF
+      ! 
+   END SUBROUTINE correct_u_bdy
+
+# if  defined key_vertical
+
+   SUBROUTINE updatev( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before )
+      !!---------------------------------------------
+      !!           *** ROUTINE updatev ***
+      !!---------------------------------------------
+      INTEGER                                     , INTENT(in   ) :: i1, i2, j1, j2, k1, k2, n1, n2
+      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres
+      LOGICAL                                     , INTENT(in   ) :: before
+      !
+      INTEGER  ::   ji, jj, jk
+      REAL(wp) ::   zrhox
+! VERTICAL REFINEMENT BEGIN
+      REAL(wp), DIMENSION(i1:i2,j1:j2,1:jpk) :: tabres_child
+      REAL(wp) :: h_in(k1:k2)
+      REAL(wp) :: h_out(1:jpk)
+      INTEGER :: N_in, N_out
+      REAL(wp) :: h_diff, excess, thick
+      REAL(wp) :: tabin(k1:k2)
+! VERTICAL REFINEMENT END
+      !!---------------------------------------------      
+      !
+      IF( before ) THEN
+         zrhox = Agrif_Rhox()
+         AGRIF_SpecialValue = -999._wp
+         DO jk=k1,k2
+            DO jj=j1,j2
+               DO ji=i1,i2
+                  tabres(ji,jj,jk,1) = zrhox * e1v(ji,jj) * e3v_n(ji,jj,jk) * vmask(ji,jj,jk) * vn(ji,jj,jk) &
+                                       + (vmask(ji,jj,jk)-1)*999._wp
+                  tabres(ji,jj,jk,2) = vmask(ji,jj,jk) * zrhox * e1v(ji,jj) * e3v_n(ji,jj,jk) &
+                                       + (vmask(ji,jj,jk)-1)*999._wp
+               END DO
+            END DO
+         END DO
+      ELSE
+         tabres_child(:,:,:) = 0.
+         AGRIF_SpecialValue = 0._wp
+         DO jj=j1,j2
+            DO ji=i1,i2
+               N_in = 0
+               DO jk=k1,k2
+                  IF (tabres(ji,jj,jk,2) < -900) EXIT
+                  N_in = N_in + 1
+                  tabin(jk) = tabres(ji,jj,jk,1)/tabres(ji,jj,jk,2)
+                  h_in(N_in) = tabres(ji,jj,jk,2)/e1v(ji,jj)
+               ENDDO
+               N_out = 0
+               DO jk=1,jpk
+                  IF (vmask(ji,jj,jk) == 0) EXIT
+                  N_out = N_out + 1
+                  h_out(N_out) = e3v_n(ji,jj,jk)
+               ENDDO
+               IF (N_in * N_out > 0) THEN
+                  h_diff = sum(h_out(1:N_out))-sum(h_in(1:N_in))
+                  IF (h_diff < -1.e-4) then
+!Even if bathy at T points match it's possible for the U points to be deeper in the child grid. 
+!In this case we need to move transport from the child grid cells below bed of parent grid into the bottom cell.
+                     excess = 0._wp
+                     DO jk=N_in,1,-1
+                        thick = MIN(-1*h_diff, h_in(jk))
+                        excess = excess + tabin(jk)*thick*e2u(ji,jj)
+                        tabin(jk) = tabin(jk)*(1. - thick/h_in(jk))
+                        h_diff = h_diff + thick
+                        IF ( h_diff == 0) THEN
+                           N_in = jk
+                           h_in(jk) = h_in(jk) - thick
+                           EXIT
+                        ENDIF
+                     ENDDO
+                  ENDIF
+                  CALL reconstructandremap(tabin(1:N_in),h_in(1:N_in),tabres_child(ji,jj,1:N_out),h_out(1:N_out),N_in,N_out)
+                  tabres_child(ji,jj,N_out) = tabres_child(ji,jj,N_out) + excess/(e1v(ji,jj)*h_out(N_out))
+               ENDIF
+            ENDDO
+         ENDDO
+
+         DO jk=1,jpk
+            DO jj=j1,j2
+               DO ji=i1,i2
+                  !
+                  IF( .NOT.(lk_agrif_fstep.AND.(neuler==0)) ) THEN ! Add asselin part
+                     vb(ji,jj,jk) = vb(ji,jj,jk) & 
+                           & + atfp * ( tabres_child(ji,jj,jk) - vn(ji,jj,jk) ) * vmask(ji,jj,jk)
+                  ENDIF
+                  !
+                  vn(ji,jj,jk) = tabres_child(ji,jj,jk) * vmask(ji,jj,jk)
+               END DO
+            END DO
+         END DO
+      ENDIF
+      ! 
+   END SUBROUTINE updatev
+
+# else
+
+   SUBROUTINE updatev( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before)
+      !!---------------------------------------------
+      !!           *** ROUTINE updatev ***
+      !!---------------------------------------------
+      INTEGER                                     , INTENT(in   ) :: i1, i2, j1, j2, k1, k2, n1, n2
+      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres
+      LOGICAL                                     , INTENT(in   ) :: before
+      !
+      INTEGER  :: ji, jj, jk
+      REAL(wp) :: zrhox, zvb, zvnu, zvno
+      !!---------------------------------------------      
+      !
+      IF (before) THEN
+         zrhox = Agrif_Rhox()
+         DO jk=k1,k2
+            DO jj=j1,j2
+               DO ji=i1,i2
+                  tabres(ji,jj,jk,1) = zrhox * e1v(ji,jj) * e3v_n(ji,jj,jk) * vn(ji,jj,jk)
+               END DO
+            END DO
+         END DO
+      ELSE
+         DO jk=k1,k2
+            DO jj=j1,j2
+               DO ji=i1,i2
+                  tabres(ji,jj,jk,1) = tabres(ji,jj,jk,1) * r1_e1v(ji,jj)
+                  !
+                  IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN ! Add asselin part
+                     zvb  = vb(ji,jj,jk) * e3v_b(ji,jj,jk) ! fse3t_b prior update should be used
+                     zvno = vn(ji,jj,jk) * e3v_a(ji,jj,jk)
+                     zvnu = tabres(ji,jj,jk,1)
+                     vb(ji,jj,jk) = ( zvb + atfp * ( zvnu - zvno) ) &      
+                                    & * vmask(ji,jj,jk) / e3v_b(ji,jj,jk)
+                  ENDIF
+                  !
+                  vn(ji,jj,jk) = tabres(ji,jj,jk,1) * vmask(ji,jj,jk) / e3v_n(ji,jj,jk)
+               END DO
+            END DO
+         END DO
+         !
+         IF  ((neuler==0).AND.(Agrif_Nb_Step()==0) ) THEN
+            vb(i1:i2,j1:j2,k1:k2)  = vn(i1:i2,j1:j2,k1:k2)
+         ENDIF
+         !
+      ENDIF
+      ! 
+   END SUBROUTINE updatev
+
+# endif
+
+   SUBROUTINE correct_v_bdy( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before, nb, ndir )
+      !!---------------------------------------------
+      !!           *** ROUTINE correct_u_bdy ***
+      !!---------------------------------------------
+      INTEGER                                     , INTENT(in   ) :: i1, i2, j1, j2, k1, k2, n1, n2
+      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres
+      LOGICAL                                     , INTENT(in   ) :: before
+      INTEGER                                     , INTENT(in)    :: nb, ndir
+      !!
+      LOGICAL :: southern_side, northern_side 
+      !
+      INTEGER  :: ji, jk
+      REAL(wp) :: zcor
+      !!---------------------------------------------
+      ! 
+      IF( .NOT.before ) THEN
+         !
+         southern_side = (nb == 2).AND.(ndir == 1)
+         northern_side = (nb == 2).AND.(ndir == 2)
+         !
+         IF (southern_side) THEN
+            DO ji=i1,i2
+               zcor = vn_b(ji,j1-1) * hv_a(ji,j1-1) * r1_hv_n(ji,j1-1) - vn_b(ji,j1-1)
+               vn_b(ji,j1-1) = vn_b(ji,j1-1) + zcor
+               DO jk=1,jpkm1
+                  vn(ji,j1-1,jk) = vn(ji,j1-1,jk) + zcor * vmask(ji,j1-1,jk)
+               END DO 
+            END DO
+         ENDIF
+         !
+         IF (northern_side) THEN
+            DO ji=i1,i2
+               zcor = vn_b(ji,j2+1) * hv_a(ji,j2+1) * r1_hv_n(ji,j2+1) - vn_b(ji,j2+1)
+               vn_b(ji,j2+1) = vn_b(ji,j2+1) + zcor
+               DO jk=1,jpkm1
+                  vn(ji,j2+1,jk) = vn(ji,j2+1,jk) + zcor * vmask(ji,j2+1,jk)
+               END DO 
+            END DO
+         ENDIF
+         !
+      ENDIF
+      ! 
+   END SUBROUTINE correct_v_bdy
+
+
+   SUBROUTINE updateu2d( tabres, i1, i2, j1, j2, before )
+      !!----------------------------------------------------------------------
+      !!                      *** ROUTINE updateu2d ***
+      !!----------------------------------------------------------------------
+      INTEGER                         , INTENT(in   ) ::   i1, i2, j1, j2
+      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) ::   tabres
+      LOGICAL                         , INTENT(in   ) ::   before
+      !! 
+      INTEGER  :: ji, jj, jk
+      REAL(wp) :: zrhoy
+      REAL(wp) :: zcorr
+      !!---------------------------------------------
+      !
+      IF( before ) THEN
+         zrhoy = Agrif_Rhoy()
+         DO jj=j1,j2
+            DO ji=i1,i2
+               tabres(ji,jj) = zrhoy * un_b(ji,jj) * hu_n(ji,jj) * e2u(ji,jj)
+            END DO
+         END DO
+      ELSE
+         DO jj=j1,j2
+            DO ji=i1,i2
+               tabres(ji,jj) =  tabres(ji,jj) * r1_e2u(ji,jj)  
+               !    
+               ! Update "now" 3d velocities:
+               spgu(ji,jj) = 0._wp
+               DO jk=1,jpkm1
+                  spgu(ji,jj) = spgu(ji,jj) + e3u_n(ji,jj,jk) * un(ji,jj,jk)
+               END DO
+               !
+               zcorr = (tabres(ji,jj) - spgu(ji,jj)) * r1_hu_n(ji,jj)
+               DO jk=1,jpkm1              
+                  un(ji,jj,jk) = un(ji,jj,jk) + zcorr * umask(ji,jj,jk)           
+               END DO
+               !
+               ! Update barotropic velocities:
+               IF ( .NOT.ln_dynspg_ts .OR. (ln_dynspg_ts.AND.(.NOT.ln_bt_fw)) ) THEN
+                  IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN ! Add asselin part
+                     zcorr = (tabres(ji,jj) - un_b(ji,jj) * hu_a(ji,jj)) * r1_hu_b(ji,jj)
+                     ub_b(ji,jj) = ub_b(ji,jj) + atfp * zcorr * umask(ji,jj,1)
+                  END IF
+               ENDIF    
+               un_b(ji,jj) = tabres(ji,jj) * r1_hu_n(ji,jj) * umask(ji,jj,1)
+               !       
+               ! Correct "before" velocities to hold correct bt component:
+               spgu(ji,jj) = 0.e0
+               DO jk=1,jpkm1
+                  spgu(ji,jj) = spgu(ji,jj) + e3u_b(ji,jj,jk) * ub(ji,jj,jk)
+               END DO
+               !
+               zcorr = ub_b(ji,jj) - spgu(ji,jj) * r1_hu_b(ji,jj)
+               DO jk=1,jpkm1              
+                  ub(ji,jj,jk) = ub(ji,jj,jk) + zcorr * umask(ji,jj,jk)           
+               END DO
+               !
+            END DO
+         END DO
+         !
+         IF  ((neuler==0).AND.(Agrif_Nb_Step()==0) ) THEN
+            ub_b(i1:i2,j1:j2)  = un_b(i1:i2,j1:j2)
+         ENDIF
+      ENDIF
+      !
+   END SUBROUTINE updateu2d
+
+
+   SUBROUTINE updatev2d( tabres, i1, i2, j1, j2, before )
+      !!----------------------------------------------------------------------
+      !!                   *** ROUTINE updatev2d ***
+      !!----------------------------------------------------------------------
+      INTEGER                         , INTENT(in   ) ::   i1, i2, j1, j2
+      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) ::   tabres
+      LOGICAL                         , INTENT(in   ) ::   before
+      ! 
+      INTEGER  :: ji, jj, jk
+      REAL(wp) :: zrhox, zcorr
+      !!----------------------------------------------------------------------
+      !
+      IF( before ) THEN
+         zrhox = Agrif_Rhox()
+         DO jj=j1,j2
+            DO ji=i1,i2
+               tabres(ji,jj) = zrhox * vn_b(ji,jj) * hv_n(ji,jj) * e1v(ji,jj) 
+            END DO
+         END DO
+      ELSE
+         DO jj=j1,j2
+            DO ji=i1,i2
+               tabres(ji,jj) =  tabres(ji,jj) * r1_e1v(ji,jj)  
+               !    
+               ! Update "now" 3d velocities:
+               spgv(ji,jj) = 0.e0
+               DO jk=1,jpkm1
+                  spgv(ji,jj) = spgv(ji,jj) + e3v_n(ji,jj,jk) * vn(ji,jj,jk)
+               END DO
+               !
+               zcorr = (tabres(ji,jj) - spgv(ji,jj)) * r1_hv_n(ji,jj)
+               DO jk=1,jpkm1              
+                  vn(ji,jj,jk) = vn(ji,jj,jk) + zcorr * vmask(ji,jj,jk)           
+               END DO
+               !
+               ! Update barotropic velocities:
+               IF ( .NOT.ln_dynspg_ts .OR. (ln_dynspg_ts.AND.(.NOT.ln_bt_fw)) ) THEN
+                  IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN ! Add asselin part
+                     zcorr = (tabres(ji,jj) - vn_b(ji,jj) * hv_a(ji,jj)) * r1_hv_b(ji,jj)
+                     vb_b(ji,jj) = vb_b(ji,jj) + atfp * zcorr * vmask(ji,jj,1)
+                  END IF
+               ENDIF              
+               vn_b(ji,jj) = tabres(ji,jj) * r1_hv_n(ji,jj) * vmask(ji,jj,1)
+               !       
+               ! Correct "before" velocities to hold correct bt component:
+               spgv(ji,jj) = 0.e0
+               DO jk=1,jpkm1
+                  spgv(ji,jj) = spgv(ji,jj) + e3v_b(ji,jj,jk) * vb(ji,jj,jk)
+               END DO
+               !
+               zcorr = vb_b(ji,jj) - spgv(ji,jj) * r1_hv_b(ji,jj)
+               DO jk=1,jpkm1              
+                  vb(ji,jj,jk) = vb(ji,jj,jk) + zcorr * vmask(ji,jj,jk)           
+               END DO
+               !
+            END DO
+         END DO
+         !
+         IF  ((neuler==0).AND.(Agrif_Nb_Step()==0) ) THEN
+            vb_b(i1:i2,j1:j2)  = vn_b(i1:i2,j1:j2)
+         ENDIF
+         !
+      ENDIF
+      ! 
+   END SUBROUTINE updatev2d
+
+
+   SUBROUTINE updateSSH( tabres, i1, i2, j1, j2, before )
+      !!----------------------------------------------------------------------
+      !!                   *** ROUTINE updateSSH ***
+      !!----------------------------------------------------------------------
+      INTEGER                         , INTENT(in   ) ::   i1, i2, j1, j2
+      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) ::   tabres
+      LOGICAL                         , INTENT(in   ) ::   before
+      !!
+      INTEGER :: ji, jj
+      !!----------------------------------------------------------------------
+      ! 
+      IF( before ) THEN
+         DO jj=j1,j2
+            DO ji=i1,i2
+               tabres(ji,jj) = sshn(ji,jj)
+            END DO
+         END DO
+      ELSE
+         IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN
+            DO jj=j1,j2
+               DO ji=i1,i2
+                  sshb(ji,jj) =   sshb(ji,jj) &
+                        & + atfp * ( tabres(ji,jj) - sshn(ji,jj) ) * tmask(ji,jj,1)
+               END DO
+            END DO
+         ENDIF
+         !
+         DO jj=j1,j2
+            DO ji=i1,i2
+               sshn(ji,jj) = tabres(ji,jj) * tmask(ji,jj,1)
+            END DO
+         END DO
+         !
+         IF  ((neuler==0).AND.(Agrif_Nb_Step()==0) ) THEN
+            sshb(i1:i2,j1:j2)  = sshn(i1:i2,j1:j2)
+         ENDIF
+         !
+
+      ENDIF
+      !
+   END SUBROUTINE updateSSH
+
+
+   SUBROUTINE updateub2b( tabres, i1, i2, j1, j2, before )
+      !!----------------------------------------------------------------------
+      !!                      *** ROUTINE updateub2b ***
+      !!----------------------------------------------------------------------
+      INTEGER                            , INTENT(in) ::   i1, i2, j1, j2
+      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) ::   tabres
+      LOGICAL                            , INTENT(in) ::   before
+      !!
+      INTEGER :: ji, jj
+      REAL(wp) :: zrhoy, za1, zcor
+      !!---------------------------------------------
+      !
+      IF (before) THEN
+         zrhoy = Agrif_Rhoy()
+         DO jj=j1,j2
+            DO ji=i1,i2
+               tabres(ji,jj) = ub2_i_b(ji,jj) * e2u(ji,jj)
+            END DO
+         END DO
+         tabres = zrhoy * tabres
+      ELSE
+         ! 
+         tabres(i1:i2,j1:j2) = tabres(i1:i2,j1:j2) * r1_e2u(i1:i2,j1:j2)
+         !
+         za1 = 1._wp / REAL(Agrif_rhot(), wp)
+         DO jj=j1,j2
+            DO ji=i1,i2
+               zcor=tabres(ji,jj) - ub2_b(ji,jj)
+               ! Update time integrated fluxes also in case of multiply nested grids:
+               ub2_i_b(ji,jj) = ub2_i_b(ji,jj) + za1 * zcor 
+               ! Update corrective fluxes:
+               un_bf(ji,jj)  = un_bf(ji,jj) + zcor
+               ! Update half step back fluxes:
+               ub2_b(ji,jj) = tabres(ji,jj)
+            END DO
+         END DO
+      ENDIF
+      !
+   END SUBROUTINE updateub2b
+
+   SUBROUTINE reflux_sshu( tabres, i1, i2, j1, j2, before, nb, ndir )
+      !!---------------------------------------------
+      !!          *** ROUTINE reflux_sshu ***
+      !!---------------------------------------------
+      INTEGER, INTENT(in) :: i1, i2, j1, j2
+      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres
+      LOGICAL, INTENT(in) :: before
+      INTEGER, INTENT(in) :: nb, ndir
+      !!
+      LOGICAL :: western_side, eastern_side 
+      INTEGER :: ji, jj
+      REAL(wp) :: zrhoy, za1, zcor
+      !!---------------------------------------------
+      !
+      IF (before) THEN
+         zrhoy = Agrif_Rhoy()
+         DO jj=j1,j2
+            DO ji=i1,i2
+               tabres(ji,jj) = ub2_i_b(ji,jj) * e2u(ji,jj)
+            END DO
+         END DO
+         tabres = zrhoy * tabres
+      ELSE
+         ! 
+         tabres(i1:i2,j1:j2) = tabres(i1:i2,j1:j2) * r1_e2u(i1:i2,j1:j2)
+         !
+         western_side  = (nb == 1).AND.(ndir == 1)
+         eastern_side  = (nb == 1).AND.(ndir == 2)
+         !
+         IF (western_side) THEN
+            DO jj=j1,j2
+               zcor = rdt * r1_e1e2t(i1  ,jj) * e2u(i1,jj) * (ub2_b(i1,jj)-tabres(i1,jj)) 
+               sshn(i1  ,jj) = sshn(i1  ,jj) + zcor
+               IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) sshb(i1  ,jj) = sshb(i1  ,jj) + atfp * zcor
+            END DO
+         ENDIF
+         IF (eastern_side) THEN
+            DO jj=j1,j2
+               zcor = - rdt * r1_e1e2t(i2+1,jj) * e2u(i2,jj) * (ub2_b(i2,jj)-tabres(i2,jj))
+               sshn(i2+1,jj) = sshn(i2+1,jj) + zcor
+               IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) sshb(i2+1,jj) = sshb(i2+1,jj) + atfp * zcor
+            END DO
+         ENDIF
+         !
+      ENDIF
+      !
+   END SUBROUTINE reflux_sshu
+
+   SUBROUTINE updatevb2b( tabres, i1, i2, j1, j2, before )
+      !!----------------------------------------------------------------------
+      !!                      *** ROUTINE updatevb2b ***
+      !!----------------------------------------------------------------------
+      INTEGER                         , INTENT(in   ) ::   i1, i2, j1, j2
+      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) ::   tabres
+      LOGICAL                         , INTENT(in   ) ::   before
+      !!
+      INTEGER :: ji, jj
+      REAL(wp) :: zrhox, za1, zcor
+      !!---------------------------------------------
+      !
+      IF( before ) THEN
+         zrhox = Agrif_Rhox()
+         DO jj=j1,j2
+            DO ji=i1,i2
+               tabres(ji,jj) = vb2_i_b(ji,jj) * e1v(ji,jj) 
+            END DO
+         END DO
+         tabres = zrhox * tabres
+      ELSE
+         ! 
+         tabres(i1:i2,j1:j2) = tabres(i1:i2,j1:j2) * r1_e1v(i1:i2,j1:j2)
+         !
+         za1 = 1._wp / REAL(Agrif_rhot(), wp)
+         DO jj=j1,j2
+            DO ji=i1,i2
+               zcor=tabres(ji,jj) - vb2_b(ji,jj)
+               ! Update time integrated fluxes also in case of multiply nested grids:
+               vb2_i_b(ji,jj) = vb2_i_b(ji,jj) + za1 * zcor 
+               ! Update corrective fluxes:
+               vn_bf(ji,jj)  = vn_bf(ji,jj) + zcor
+               ! Update half step back fluxes:
+               vb2_b(ji,jj) = tabres(ji,jj)
+            END DO
+         END DO
+      ENDIF
+      !
+   END SUBROUTINE updatevb2b
+
+   SUBROUTINE reflux_sshv( tabres, i1, i2, j1, j2, before, nb, ndir )
+      !!---------------------------------------------
+      !!          *** ROUTINE reflux_sshv ***
+      !!---------------------------------------------
+      INTEGER, INTENT(in) :: i1, i2, j1, j2
+      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres
+      LOGICAL, INTENT(in) :: before
+      INTEGER, INTENT(in) :: nb, ndir
+      !!
+      LOGICAL :: southern_side, northern_side 
+      INTEGER :: ji, jj
+      REAL(wp) :: zrhox, za1, zcor
+      !!---------------------------------------------
+      !
+      IF (before) THEN
+         zrhox = Agrif_Rhox()
+         DO jj=j1,j2
+            DO ji=i1,i2
+               tabres(ji,jj) = vb2_i_b(ji,jj) * e1v(ji,jj) 
+            END DO
+         END DO
+         tabres = zrhox * tabres
+      ELSE
+         ! 
+         tabres(i1:i2,j1:j2) = tabres(i1:i2,j1:j2) * r1_e1v(i1:i2,j1:j2)
+         !
+         southern_side = (nb == 2).AND.(ndir == 1)
+         northern_side = (nb == 2).AND.(ndir == 2)
+         !
+         IF (southern_side) THEN
+            DO ji=i1,i2
+               zcor = rdt * r1_e1e2t(ji,j1  ) * e1v(ji,j1  ) * (vb2_b(ji,j1)-tabres(ji,j1))
+               sshn(ji,j1  ) = sshn(ji,j1  ) + zcor
+               IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) sshb(ji,j1  ) = sshb(ji,j1) + atfp * zcor
+            END DO
+         ENDIF
+         IF (northern_side) THEN               
+            DO ji=i1,i2
+               zcor = - rdt * r1_e1e2t(ji,j2+1) * e1v(ji,j2  ) * (vb2_b(ji,j2)-tabres(ji,j2))
+               sshn(ji,j2+1) = sshn(ji,j2+1) + zcor
+               IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) sshb(ji,j2+1) = sshb(ji,j2+1) + atfp * zcor
+            END DO
+         ENDIF
+         ! 
+      ENDIF
+      !
+   END SUBROUTINE reflux_sshv
+
+   SUBROUTINE update_scales( tabres, i1, i2, j1, j2, k1, k2, n1,n2, before )
+      !
+      ! ====>>>>>>>>>>    currently not used
+      !
+      !!----------------------------------------------------------------------
+      !!                      *** ROUTINE updateT ***
+      !!----------------------------------------------------------------------
+      INTEGER                                    , INTENT(in   ) ::   i1, i2, j1, j2, k1, k2, n1, n2
+      REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) ::   tabres
+      LOGICAL                                    , INTENT(in   ) ::   before
+      !!
+      INTEGER :: ji,jj,jk
+      REAL(wp) :: ztemp
+      !!----------------------------------------------------------------------
+
+      IF (before) THEN
+         DO jk=k1,k2
+            DO jj=j1,j2
+               DO ji=i1,i2
+                  tabres(ji,jj,jk,1) = e1t(ji,jj)*e2t(ji,jj)*tmask(ji,jj,jk)
+                  tabres(ji,jj,jk,2) = e1t(ji,jj)*tmask(ji,jj,jk)
+                  tabres(ji,jj,jk,3) = e2t(ji,jj)*tmask(ji,jj,jk)
+               END DO
+            END DO
+         END DO
+         tabres(:,:,:,1)=tabres(:,:,:,1)*Agrif_Rhox()*Agrif_Rhoy()
+         tabres(:,:,:,2)=tabres(:,:,:,2)*Agrif_Rhox()
+         tabres(:,:,:,3)=tabres(:,:,:,3)*Agrif_Rhoy()
+      ELSE
+         DO jk=k1,k2
+            DO jj=j1,j2
+               DO ji=i1,i2
+                  IF( tabres(ji,jj,jk,1) .NE. 0. ) THEN 
+                     print *,'VAL = ',ji,jj,jk,tabres(ji,jj,jk,1),e1t(ji,jj)*e2t(ji,jj)*tmask(ji,jj,jk)
+                     print *,'VAL2 = ',ji,jj,jk,tabres(ji,jj,jk,2),e1t(ji,jj)*tmask(ji,jj,jk)
+                     print *,'VAL3 = ',ji,jj,jk,tabres(ji,jj,jk,3),e2t(ji,jj)*tmask(ji,jj,jk)
+                     ztemp = sqrt(tabres(ji,jj,jk,1)/(tabres(ji,jj,jk,2)*tabres(ji,jj,jk,3)))
+                     print *,'CORR = ',ztemp-1.
+                     print *,'NEW VALS = ',tabres(ji,jj,jk,2)*ztemp,tabres(ji,jj,jk,3)*ztemp, &
+                           tabres(ji,jj,jk,2)*ztemp*tabres(ji,jj,jk,3)*ztemp
+                     e1t(ji,jj) = tabres(ji,jj,jk,2)*ztemp
+                     e2t(ji,jj) = tabres(ji,jj,jk,3)*ztemp
+                  END IF
+               END DO
+            END DO
+         END DO
+      ENDIF
+      !
+   END SUBROUTINE update_scales
+
+
+   SUBROUTINE updateEN( ptab, i1, i2, j1, j2, k1, k2, before )
+      !!----------------------------------------------------------------------
+      !!                      *** ROUTINE updateen ***
+      !!----------------------------------------------------------------------
+      INTEGER                               , INTENT(in   ) ::   i1, i2, j1, j2, k1, k2
+      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) ::   ptab
+      LOGICAL                               , INTENT(in   ) ::   before
+      !!----------------------------------------------------------------------
+      !
+      IF( before ) THEN
+         ptab (i1:i2,j1:j2,k1:k2) = en(i1:i2,j1:j2,k1:k2)
+      ELSE
+         en(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2) 
+      ENDIF
+      !
+   END SUBROUTINE updateEN
+
+
+   SUBROUTINE updateAVT( ptab, i1, i2, j1, j2, k1, k2, before )
+      !!----------------------------------------------------------------------
+      !!                      *** ROUTINE updateavt ***
+      !!----------------------------------------------------------------------
+      INTEGER                               , INTENT(in   ) ::   i1, i2, j1, j2, k1, k2
+      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) ::   ptab
+      LOGICAL                               , INTENT(in   ) ::   before
+      !!----------------------------------------------------------------------
+      !
+      IF( before ) THEN   ;   ptab (i1:i2,j1:j2,k1:k2) = avt_k(i1:i2,j1:j2,k1:k2)
+      ELSE                ;   avt_k(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2) 
+      ENDIF
+      !
+   END SUBROUTINE updateAVT
+
+
+   SUBROUTINE updateAVM( ptab, i1, i2, j1, j2, k1, k2, before )
+      !!---------------------------------------------
+      !!           *** ROUTINE updateavm ***
+      !!----------------------------------------------------------------------
+      INTEGER                               , INTENT(in   ) ::   i1, i2, j1, j2, k1, k2
+      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) ::   ptab
+      LOGICAL                               , INTENT(in   ) ::   before
+      !!----------------------------------------------------------------------
+      !
+      IF( before ) THEN   ;   ptab (i1:i2,j1:j2,k1:k2) = avm_k(i1:i2,j1:j2,k1:k2)
+      ELSE                ;   avm_k(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2) 
+      ENDIF
+      !
+   END SUBROUTINE updateAVM
+
+   SUBROUTINE updatee3t(ptab_dum, i1, i2, j1, j2, k1, k2, before )
+      !!---------------------------------------------
+      !!           *** ROUTINE updatee3t ***
+      !!---------------------------------------------
+      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2) :: ptab_dum
+      INTEGER, INTENT(in) :: i1, i2, j1, j2, k1, k2
+      LOGICAL, INTENT(in) :: before
+      !
+      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: ptab
+      INTEGER :: ji,jj,jk
+      REAL(wp) :: zcoef
+      !!---------------------------------------------
+      !
+      IF (.NOT.before) THEN
+         !
+         ALLOCATE(ptab(i1:i2,j1:j2,1:jpk)) 
+         !
+         ! Update e3t from ssh (z* case only)
+         DO jk = 1, jpkm1
+            DO jj=j1,j2
+               DO ji=i1,i2
+                  ptab(ji,jj,jk) = e3t_0(ji,jj,jk) * (1._wp + sshn(ji,jj) &
+                                     & *ssmask(ji,jj)/(ht_0(ji,jj)-1._wp + ssmask(ji,jj)))
+               END DO
+            END DO
+         END DO
+         !
+         ! 1) Updates at BEFORE time step:
+         ! -------------------------------
+         !
+         ! Save "old" scale factor (prior update) for subsequent asselin correction
+         ! of prognostic variables
+         e3t_a(i1:i2,j1:j2,1:jpkm1) = e3t_n(i1:i2,j1:j2,1:jpkm1)
+
+         ! One should also save e3t_b, but lacking of workspace...
+!         hdivn(i1:i2,j1:j2,1:jpkm1)   = e3t_b(i1:i2,j1:j2,1:jpkm1)
+
+         IF (.NOT.(lk_agrif_fstep.AND.(neuler==0) )) THEN
+            DO jk = 1, jpkm1
+               DO jj=j1,j2
+                  DO ji=i1,i2
+                     e3t_b(ji,jj,jk) =  e3t_b(ji,jj,jk) &
+                           & + atfp * ( ptab(ji,jj,jk) - e3t_n(ji,jj,jk) )
+                  END DO
+               END DO
+            END DO
+            !
+            e3w_b  (i1:i2,j1:j2,1) = e3w_0(i1:i2,j1:j2,1) + e3t_b(i1:i2,j1:j2,1) - e3t_0(i1:i2,j1:j2,1)
+            gdepw_b(i1:i2,j1:j2,1) = 0.0_wp
+            gdept_b(i1:i2,j1:j2,1) = 0.5_wp * e3w_b(i1:i2,j1:j2,1)
+            !
+            DO jk = 2, jpk
+               DO jj = j1,j2
+                  DO ji = i1,i2            
+                     zcoef = (tmask(ji,jj,jk) - wmask(ji,jj,jk))
+                     e3w_b(ji,jj,jk)  = e3w_0(ji,jj,jk) + ( 1.0_wp - 0.5_wp * tmask(ji,jj,jk) ) *        & 
+                     &                                        ( e3t_b(ji,jj,jk-1) - e3t_0(ji,jj,jk-1) )  &
+                     &                                  +            0.5_wp * tmask(ji,jj,jk)   *        &
+                     &                                        ( e3t_b(ji,jj,jk  ) - e3t_0(ji,jj,jk  ) )
+                     gdepw_b(ji,jj,jk) = gdepw_b(ji,jj,jk-1) + e3t_b(ji,jj,jk-1)
+                     gdept_b(ji,jj,jk) =      zcoef  * ( gdepw_b(ji,jj,jk  ) + 0.5 * e3w_b(ji,jj,jk))  &
+                         &               + (1-zcoef) * ( gdept_b(ji,jj,jk-1) +       e3w_b(ji,jj,jk)) 
+                  END DO
+               END DO
+            END DO
+            !
+         ENDIF        
+         !
+         ! 2) Updates at NOW time step:
+         ! ----------------------------
+         !
+         ! Update vertical scale factor at T-points:
+         e3t_n(i1:i2,j1:j2,1:jpkm1) = ptab(i1:i2,j1:j2,1:jpkm1)
+         !
+         ! Update total depth:
+         ht_n(i1:i2,j1:j2) = 0._wp
+         DO jk = 1, jpkm1
+            ht_n(i1:i2,j1:j2) = ht_n(i1:i2,j1:j2) + e3t_n(i1:i2,j1:j2,jk) * tmask(i1:i2,j1:j2,jk)
+         END DO
+         !
+         ! Update vertical scale factor at W-points and depths:
+         e3w_n (i1:i2,j1:j2,1) = e3w_0(i1:i2,j1:j2,1) + e3t_n(i1:i2,j1:j2,1) - e3t_0(i1:i2,j1:j2,1)
+         gdept_n(i1:i2,j1:j2,1) = 0.5_wp * e3w_n(i1:i2,j1:j2,1)
+         gdepw_n(i1:i2,j1:j2,1) = 0.0_wp
+         gde3w_n(i1:i2,j1:j2,1) = gdept_n(i1:i2,j1:j2,1) - (ht_n(i1:i2,j1:j2)-ht_0(i1:i2,j1:j2)) ! Last term in the rhs is ssh
+         !
+         DO jk = 2, jpk
+            DO jj = j1,j2
+               DO ji = i1,i2            
+               zcoef = (tmask(ji,jj,jk) - wmask(ji,jj,jk))
+               e3w_n(ji,jj,jk)  = e3w_0(ji,jj,jk) + ( 1.0_wp - 0.5_wp * tmask(ji,jj,jk) ) * ( e3t_n(ji,jj,jk-1) - e3t_0(ji,jj,jk-1) )   &
+               &                                  +            0.5_wp * tmask(ji,jj,jk)   * ( e3t_n(ji,jj,jk  ) - e3t_0(ji,jj,jk  ) )
+               gdepw_n(ji,jj,jk) = gdepw_n(ji,jj,jk-1) + e3t_n(ji,jj,jk-1)
+               gdept_n(ji,jj,jk) =      zcoef  * ( gdepw_n(ji,jj,jk  ) + 0.5 * e3w_n(ji,jj,jk))  &
+                   &               + (1-zcoef) * ( gdept_n(ji,jj,jk-1) +       e3w_n(ji,jj,jk)) 
+               gde3w_n(ji,jj,jk) = gdept_n(ji,jj,jk) - (ht_n(ji,jj)-ht_0(ji,jj)) ! Last term in the rhs is ssh
+               END DO
+            END DO
+         END DO
+         !
+         IF  ((neuler==0).AND.(Agrif_Nb_Step()==0) ) THEN
+            e3t_b (i1:i2,j1:j2,1:jpk)  = e3t_n (i1:i2,j1:j2,1:jpk)
+            e3w_b (i1:i2,j1:j2,1:jpk)  = e3w_n (i1:i2,j1:j2,1:jpk)
+            gdepw_b(i1:i2,j1:j2,1:jpk) = gdepw_n(i1:i2,j1:j2,1:jpk)
+            gdept_b(i1:i2,j1:j2,1:jpk) = gdept_n(i1:i2,j1:j2,1:jpk)
+         ENDIF
+         !
+         DEALLOCATE(ptab)
+      ENDIF
+      !
+   END SUBROUTINE updatee3t
+
+#else
+   !!----------------------------------------------------------------------
+   !!   Empty module                                          no AGRIF zoom
+   !!----------------------------------------------------------------------
+CONTAINS
+   SUBROUTINE agrif_oce_update_empty
+      WRITE(*,*)  'agrif_oce_update : You should not have seen this print! error?'
+   END SUBROUTINE agrif_oce_update_empty
+#endif
+
+   !!======================================================================
+END MODULE agrif_oce_update
+
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/NST_SRC/agrif_opa_interp.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/NST_SRC/agrif_opa_interp.F90	(revision 9569)
+++ 	(revision )
@@ -1,1414 +1,0 @@
-MODULE agrif_opa_interp
-   !!======================================================================
-   !!                   ***  MODULE  agrif_opa_interp  ***
-   !! AGRIF: interpolation package for the ocean dynamics (OPA)
-   !!======================================================================
-   !! History :  2.0  !  2002-06  (L. Debreu)  Original cade
-   !!            3.2  !  2009-04  (R. Benshila) 
-   !!            3.6  !  2014-09  (R. Benshila) 
-   !!----------------------------------------------------------------------
-#if defined key_agrif
-   !!----------------------------------------------------------------------
-   !!   'key_agrif'                                              AGRIF zoom
-   !!----------------------------------------------------------------------
-   !!   Agrif_tra     :
-   !!   Agrif_dyn     : 
-   !!   Agrif_ssh     :
-   !!   Agrif_dyn_ts  :
-   !!   Agrif_dta_ts  :
-   !!   Agrif_ssh_ts  :
-   !!   Agrif_avm     : 
-   !!   interpu       :
-   !!   interpv       :
-   !!----------------------------------------------------------------------
-   USE par_oce
-   USE oce
-   USE dom_oce      
-   USE zdf_oce
-   USE agrif_oce
-   USE phycst
-   USE dynspg_ts, ONLY: un_adv, vn_adv
-   !
-   USE in_out_manager
-   USE agrif_opa_sponge
-   USE lib_mpp
- 
-   IMPLICIT NONE
-   PRIVATE
-
-   PUBLIC   Agrif_dyn, Agrif_ssh, Agrif_dyn_ts, Agrif_ssh_ts, Agrif_dta_ts
-   PUBLIC   Agrif_tra, Agrif_avm
-   PUBLIC   interpun , interpvn
-   PUBLIC   interptsn, interpsshn, interpavm
-   PUBLIC   interpunb, interpvnb , interpub2b, interpvb2b
-   PUBLIC   interpe3t, interpumsk, interpvmsk
-
-   INTEGER ::   bdy_tinterp = 0
-
-#  include "vectopt_loop_substitute.h90"
-   !!----------------------------------------------------------------------
-   !! NEMO/NST 4.0 , NEMO Consortium (2017)
-   !! $Id$
-   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
-   !!----------------------------------------------------------------------
-CONTAINS
-
-   SUBROUTINE Agrif_tra
-      !!----------------------------------------------------------------------
-      !!                  ***  ROUTINE Agrif_tra  ***
-      !!----------------------------------------------------------------------
-      !
-      IF( Agrif_Root() )   RETURN
-      !
-      Agrif_SpecialValue    = 0._wp
-      Agrif_UseSpecialValue = .TRUE.
-      !
-      CALL Agrif_Bc_variable( tsn_id, procname=interptsn )
-      !
-      Agrif_UseSpecialValue = .FALSE.
-      !
-   END SUBROUTINE Agrif_tra
-
-
-   SUBROUTINE Agrif_dyn( kt )
-      !!----------------------------------------------------------------------
-      !!                  ***  ROUTINE Agrif_DYN  ***
-      !!----------------------------------------------------------------------  
-      INTEGER, INTENT(in) ::   kt
-      !
-      INTEGER ::   ji, jj, jk       ! dummy loop indices
-      INTEGER ::   j1, j2, i1, i2
-      INTEGER ::   ibdy1, jbdy1, ibdy2, jbdy2
-      REAL(wp), DIMENSION(jpi,jpj) ::   zub, zvb
-      !!----------------------------------------------------------------------  
-      !
-      IF( Agrif_Root() )   RETURN
-      !
-      Agrif_SpecialValue    = 0._wp
-      Agrif_UseSpecialValue = ln_spc_dyn
-      !
-      CALL Agrif_Bc_variable( un_interp_id, procname=interpun )
-      CALL Agrif_Bc_variable( vn_interp_id, procname=interpvn )
-      !
-      Agrif_UseSpecialValue = .FALSE.
-      !
-      ! prevent smoothing in ghost cells
-      i1 =  1   ;   i2 = jpi
-      j1 =  1   ;   j2 = jpj
-      IF( nbondj == -1 .OR. nbondj == 2 )   j1 = 2 + nbghostcells
-      IF( nbondj == +1 .OR. nbondj == 2 )   j2 = nlcj - nbghostcells - 1
-      IF( nbondi == -1 .OR. nbondi == 2 )   i1 = 2 + nbghostcells 
-      IF( nbondi == +1 .OR. nbondi == 2 )   i2 = nlci - nbghostcells - 1
-
-      ! --- West --- !
-      IF( nbondi == -1 .OR. nbondi == 2 ) THEN
-         ibdy1 = 2
-         ibdy2 = 1+nbghostcells 
-         !
-         IF( .NOT.ln_dynspg_ts ) THEN  ! Store transport
-            ua_b(ibdy1:ibdy2,:) = 0._wp
-            DO jk = 1, jpkm1
-               DO jj = 1, jpj
-                  ua_b(ibdy1:ibdy2,jj) = ua_b(ibdy1:ibdy2,jj) & 
-                      & + e3u_a(ibdy1:ibdy2,jj,jk) * ua(ibdy1:ibdy2,jj,jk) * umask(ibdy1:ibdy2,jj,jk)
-               END DO
-            END DO
-            DO jj = 1, jpj
-               ua_b(ibdy1:ibdy2,jj) = ua_b(ibdy1:ibdy2,jj) * r1_hu_a(ibdy1:ibdy2,jj)
-            END DO
-         ENDIF
-         !
-         IF( .NOT.lk_agrif_clp ) THEN
-            DO jk=1,jpkm1              ! Smooth
-               DO jj=j1,j2
-                  ua(ibdy2,jj,jk) = 0.25_wp*(ua(ibdy2-1,jj,jk)+2._wp*ua(ibdy2,jj,jk)+ua(ibdy2+1,jj,jk))
-               END DO
-            END DO
-         ENDIF
-         !
-         zub(ibdy1:ibdy2,:) = 0._wp    ! Correct transport
-         DO jk = 1, jpkm1
-            DO jj = 1, jpj
-               zub(ibdy1:ibdy2,jj) = zub(ibdy1:ibdy2,jj) & 
-                  & + e3u_a(ibdy1:ibdy2,jj,jk)  * ua(ibdy1:ibdy2,jj,jk)*umask(ibdy1:ibdy2,jj,jk)
-            END DO
-         END DO
-         DO jj=1,jpj
-            zub(ibdy1:ibdy2,jj) = zub(ibdy1:ibdy2,jj) * r1_hu_a(ibdy1:ibdy2,jj)
-         END DO
-            
-         DO jk = 1, jpkm1
-            DO jj = 1, jpj
-               ua(ibdy1:ibdy2,jj,jk) = ( ua(ibdy1:ibdy2,jj,jk) &
-                 & + ua_b(ibdy1:ibdy2,jj)-zub(ibdy1:ibdy2,jj)) * umask(ibdy1:ibdy2,jj,jk)
-            END DO
-         END DO
-            
-         IF( ln_dynspg_ts ) THEN       ! Set tangential velocities to time splitting estimate
-            zvb(ibdy1:ibdy2,:) = 0._wp
-            DO jk = 1, jpkm1
-               DO jj = 1, jpj
-                  zvb(ibdy1:ibdy2,jj) = zvb(ibdy1:ibdy2,jj) & 
-                     & + e3v_a(ibdy1:ibdy2,jj,jk) * va(ibdy1:ibdy2,jj,jk) * vmask(ibdy1:ibdy2,jj,jk)
-               END DO
-            END DO
-            DO jj = 1, jpj
-               zvb(ibdy1:ibdy2,jj) = zvb(ibdy1:ibdy2,jj) * r1_hv_a(ibdy1:ibdy2,jj)
-            END DO
-            DO jk = 1, jpkm1
-               DO jj = 1, jpj
-                  va(ibdy1:ibdy2,jj,jk) = ( va(ibdy1:ibdy2,jj,jk) & 
-                    & + va_b(ibdy1:ibdy2,jj)-zvb(ibdy1:ibdy2,jj))*vmask(ibdy1:ibdy2,jj,jk)
-               END DO
-            END DO
-         ENDIF
-         !
-         DO jk = 1, jpkm1              ! Mask domain edges
-            DO jj = 1, jpj
-               ua(1,jj,jk) = 0._wp
-               va(1,jj,jk) = 0._wp
-            END DO
-         END DO 
-      ENDIF
-
-      ! --- East --- !
-      IF( nbondi ==  1 .OR. nbondi == 2 ) THEN
-         ibdy1 = nlci-1-nbghostcells
-         ibdy2 = nlci-2 
-         !
-         IF( .NOT.ln_dynspg_ts ) THEN  ! Store transport
-            ua_b(ibdy1:ibdy2,:) = 0._wp
-            DO jk = 1, jpkm1
-               DO jj = 1, jpj
-                  ua_b(ibdy1:ibdy2,jj) = ua_b(ibdy1:ibdy2,jj) & 
-                      & + e3u_a(ibdy1:ibdy2,jj,jk) * ua(ibdy1:ibdy2,jj,jk) * umask(ibdy1:ibdy2,jj,jk)
-               END DO
-            END DO
-            DO jj = 1, jpj
-               ua_b(ibdy1:ibdy2,jj) = ua_b(ibdy1:ibdy2,jj) * r1_hu_a(ibdy1:ibdy2,jj)
-            END DO
-         ENDIF
-         !
-         IF( .NOT.lk_agrif_clp ) THEN
-            DO jk=1,jpkm1              ! Smooth
-               DO jj=j1,j2
-                  ua(ibdy1,jj,jk) = 0.25_wp*(ua(ibdy1-1,jj,jk)+2._wp*ua(ibdy1,jj,jk)+ua(ibdy1+1,jj,jk))
-               END DO
-            END DO
-         ENDIF
-         !
-         zub(ibdy1:ibdy2,:) = 0._wp    ! Correct transport
-         DO jk = 1, jpkm1
-            DO jj = 1, jpj
-               zub(ibdy1:ibdy2,jj) = zub(ibdy1:ibdy2,jj) & 
-                  & + e3u_a(ibdy1:ibdy2,jj,jk)  * ua(ibdy1:ibdy2,jj,jk) * umask(ibdy1:ibdy2,jj,jk)
-            END DO
-         END DO
-         DO jj=1,jpj
-            zub(ibdy1:ibdy2,jj) = zub(ibdy1:ibdy2,jj) * r1_hu_a(ibdy1:ibdy2,jj)
-         END DO
-            
-         DO jk = 1, jpkm1
-            DO jj = 1, jpj
-               ua(ibdy1:ibdy2,jj,jk) = ( ua(ibdy1:ibdy2,jj,jk) & 
-                 & + ua_b(ibdy1:ibdy2,jj)-zub(ibdy1:ibdy2,jj))*umask(ibdy1:ibdy2,jj,jk)
-            END DO
-         END DO
-            
-         IF( ln_dynspg_ts ) THEN       ! Set tangential velocities to time splitting estimate
-            ibdy1 = ibdy1 + 1
-            ibdy2 = ibdy2 + 1 
-            zvb(ibdy1:ibdy2,:) = 0._wp
-            DO jk = 1, jpkm1
-               DO jj = 1, jpj
-                  zvb(ibdy1:ibdy2,jj) = zvb(ibdy1:ibdy2,jj) &
-                     & + e3v_a(ibdy1:ibdy2,jj,jk) * va(ibdy1:ibdy2,jj,jk) * vmask(ibdy1:ibdy2,jj,jk)
-               END DO
-            END DO
-            DO jj = 1, jpj
-               zvb(ibdy1:ibdy2,jj) = zvb(ibdy1:ibdy2,jj) * r1_hv_a(ibdy1:ibdy2,jj)
-            END DO
-            DO jk = 1, jpkm1
-               DO jj = 1, jpj
-                  va(ibdy1:ibdy2,jj,jk) = ( va(ibdy1:ibdy2,jj,jk) & 
-                      & + va_b(ibdy1:ibdy2,jj)-zvb(ibdy1:ibdy2,jj)) * vmask(ibdy1:ibdy2,jj,jk)
-               END DO
-            END DO
-         ENDIF
-         !
-         DO jk = 1, jpkm1              ! Mask domain edges
-            DO jj = 1, jpj
-               ua(nlci-1,jj,jk) = 0._wp
-               va(nlci  ,jj,jk) = 0._wp
-            END DO
-         END DO 
-      ENDIF
-
-      ! --- South --- !
-      IF( nbondj == -1 .OR. nbondj == 2 ) THEN
-         jbdy1 = 2
-         jbdy2 = 1+nbghostcells 
-         !
-         IF( .NOT.ln_dynspg_ts ) THEN  ! Store transport
-            va_b(:,jbdy1:jbdy2) = 0._wp
-            DO jk = 1, jpkm1
-               DO ji = 1, jpi
-                  va_b(ji,jbdy1:jbdy2) = va_b(ji,jbdy1:jbdy2) & 
-                      & + e3v_a(ji,jbdy1:jbdy2,jk) * va(ji,jbdy1:jbdy2,jk) * vmask(ji,jbdy1:jbdy2,jk)
-               END DO
-            END DO
-            DO ji=1,jpi
-               va_b(ji,jbdy1:jbdy2) = va_b(ji,jbdy1:jbdy2) * r1_hv_a(ji,jbdy1:jbdy2)
-            END DO
-         ENDIF
-         !
-         IF ( .NOT.lk_agrif_clp ) THEN
-            DO jk = 1, jpkm1           ! Smooth
-               DO ji = i1, i2
-                  va(ji,jbdy2,jk) = 0.25_wp*(va(ji,jbdy2-1,jk)+2._wp*va(ji,jbdy2,jk)+va(ji,jbdy2+1,jk))
-               END DO
-            END DO
-         ENDIF
-         !
-         zvb(:,jbdy1:jbdy2) = 0._wp    ! Correct transport
-         DO jk=1,jpkm1
-            DO ji=1,jpi
-               zvb(ji,jbdy1:jbdy2) = zvb(ji,jbdy1:jbdy2) & 
-                  & + e3v_a(ji,jbdy1:jbdy2,jk) * va(ji,jbdy1:jbdy2,jk) * vmask(ji,jbdy1:jbdy2,jk)
-            END DO
-         END DO
-         DO ji = 1, jpi
-            zvb(ji,jbdy1:jbdy2) = zvb(ji,jbdy1:jbdy2) * r1_hv_a(ji,jbdy1:jbdy2)
-         END DO
-
-         DO jk = 1, jpkm1
-            DO ji = 1, jpi
-               va(ji,jbdy1:jbdy2,jk) = ( va(ji,jbdy1:jbdy2,jk) & 
-                 & + va_b(ji,jbdy1:jbdy2) - zvb(ji,jbdy1:jbdy2) ) * vmask(ji,jbdy1:jbdy2,jk)
-            END DO
-         END DO
-            
-         IF( ln_dynspg_ts ) THEN       ! Set tangential velocities to time splitting estimate
-            zub(:,jbdy1:jbdy2) = 0._wp
-            DO jk = 1, jpkm1
-               DO ji = 1, jpi
-                  zub(ji,jbdy1:jbdy2) = zub(ji,jbdy1:jbdy2) & 
-                     & + e3u_a(ji,jbdy1:jbdy2,jk) * ua(ji,jbdy1:jbdy2,jk) * umask(ji,jbdy1:jbdy2,jk)
-               END DO
-            END DO
-            DO ji = 1, jpi
-               zub(ji,jbdy1:jbdy2) = zub(ji,jbdy1:jbdy2) * r1_hu_a(ji,jbdy1:jbdy2)
-            END DO
-               
-            DO jk = 1, jpkm1
-               DO ji = 1, jpi
-                  ua(ji,jbdy1:jbdy2,jk) = ( ua(ji,jbdy1:jbdy2,jk) & 
-                    & + ua_b(ji,jbdy1:jbdy2) - zub(ji,jbdy1:jbdy2) ) * umask(ji,jbdy1:jbdy2,jk)
-               END DO
-            END DO
-         ENDIF
-         !
-         DO jk = 1, jpkm1              ! Mask domain edges
-            DO ji = 1, jpi
-               ua(ji,1,jk) = 0._wp
-               va(ji,1,jk) = 0._wp
-            END DO
-         END DO 
-      ENDIF
-
-      ! --- North --- !
-      IF( nbondj ==  1 .OR. nbondj == 2 ) THEN
-         jbdy1 = nlcj-1-nbghostcells
-         jbdy2 = nlcj-2 
-         !
-         IF( .NOT.ln_dynspg_ts ) THEN  ! Store transport
-            va_b(:,jbdy1:jbdy2) = 0._wp
-            DO jk = 1, jpkm1
-               DO ji = 1, jpi
-                  va_b(ji,jbdy1:jbdy2) = va_b(ji,jbdy1:jbdy2) & 
-                      & + e3v_a(ji,jbdy1:jbdy2,jk) * va(ji,jbdy1:jbdy2,jk) * vmask(ji,jbdy1:jbdy2,jk)
-               END DO
-            END DO
-            DO ji=1,jpi
-               va_b(ji,jbdy1:jbdy2) = va_b(ji,jbdy1:jbdy2) * r1_hv_a(ji,jbdy1:jbdy2)
-            END DO
-         ENDIF
-         !
-         IF ( .NOT.lk_agrif_clp ) THEN
-            DO jk = 1, jpkm1           ! Smooth
-               DO ji = i1, i2
-                  va(ji,jbdy1,jk) = 0.25_wp*(va(ji,jbdy1-1,jk)+2._wp*va(ji,jbdy1,jk)+va(ji,jbdy1+1,jk))
-               END DO
-            END DO
-         ENDIF
-         !
-         zvb(:,jbdy1:jbdy2) = 0._wp    ! Correct transport
-         DO jk=1,jpkm1
-            DO ji=1,jpi
-               zvb(ji,jbdy1:jbdy2) = zvb(ji,jbdy1:jbdy2) & 
-                  & + e3v_a(ji,jbdy1:jbdy2,jk) * va(ji,jbdy1:jbdy2,jk) * vmask(ji,jbdy1:jbdy2,jk)
-            END DO
-         END DO
-         DO ji = 1, jpi
-            zvb(ji,jbdy1:jbdy2) = zvb(ji,jbdy1:jbdy2) * r1_hv_a(ji,jbdy1:jbdy2)
-         END DO
-
-         DO jk = 1, jpkm1
-            DO ji = 1, jpi
-               va(ji,jbdy1:jbdy2,jk) = ( va(ji,jbdy1:jbdy2,jk) & 
-                 & + va_b(ji,jbdy1:jbdy2) - zvb(ji,jbdy1:jbdy2) ) * vmask(ji,jbdy1:jbdy2,jk)
-            END DO
-         END DO
-            
-         IF( ln_dynspg_ts ) THEN       ! Set tangential velocities to time splitting estimate
-            jbdy1 = jbdy1 + 1
-            jbdy2 = jbdy2 + 1 
-            zub(:,jbdy1:jbdy2) = 0._wp
-            DO jk = 1, jpkm1
-               DO ji = 1, jpi
-                  zub(ji,jbdy1:jbdy2) = zub(ji,jbdy1:jbdy2) & 
-                     & + e3u_a(ji,jbdy1:jbdy2,jk) * ua(ji,jbdy1:jbdy2,jk) * umask(ji,jbdy1:jbdy2,jk)
-               END DO
-            END DO
-            DO ji = 1, jpi
-               zub(ji,jbdy1:jbdy2) = zub(ji,jbdy1:jbdy2) * r1_hu_a(ji,jbdy1:jbdy2)
-            END DO
-               
-            DO jk = 1, jpkm1
-               DO ji = 1, jpi
-                  ua(ji,jbdy1:jbdy2,jk) = ( ua(ji,jbdy1:jbdy2,jk) & 
-                    & + ua_b(ji,jbdy1:jbdy2) - zub(ji,jbdy1:jbdy2) ) * umask(ji,jbdy1:jbdy2,jk)
-               END DO
-            END DO
-         ENDIF
-         !
-         DO jk = 1, jpkm1              ! Mask domain edges
-            DO ji = 1, jpi
-               ua(ji,nlcj  ,jk) = 0._wp
-               va(ji,nlcj-1,jk) = 0._wp
-            END DO
-         END DO 
-      ENDIF
-      !
-   END SUBROUTINE Agrif_dyn
-
-
-   SUBROUTINE Agrif_dyn_ts( jn )
-      !!----------------------------------------------------------------------
-      !!                  ***  ROUTINE Agrif_dyn_ts  ***
-      !!----------------------------------------------------------------------  
-      INTEGER, INTENT(in) ::   jn
-      !!
-      INTEGER :: ji, jj
-      !!----------------------------------------------------------------------  
-      !
-      IF( Agrif_Root() )   RETURN
-      !
-      IF((nbondi == -1).OR.(nbondi == 2)) THEN
-         DO jj=1,jpj
-            va_e(2:nbghostcells+1,jj) = vbdy_w(1:nbghostcells,jj) * hvr_e(2:nbghostcells+1,jj)
-            ! Specified fluxes:
-            ua_e(2:nbghostcells+1,jj) = ubdy_w(1:nbghostcells,jj) * hur_e(2:nbghostcells+1,jj)
-            ! Characteristics method (only if ghostcells=1):
-            !alt            ua_e(2,jj) = 0.5_wp * ( ubdy_w(jj) * hur_e(2,jj) + ua_e(3,jj) &
-            !alt                       &           - sqrt(grav * hur_e(2,jj)) * (sshn_e(3,jj) - hbdy_w(jj)) )
-         END DO
-      ENDIF
-      !
-      IF((nbondi == 1).OR.(nbondi == 2)) THEN
-         DO jj=1,jpj
-            va_e(nlci-nbghostcells:nlci-1,jj)   = vbdy_e(1:nbghostcells,jj) * hvr_e(nlci-nbghostcells:nlci-1,jj)
-            ! Specified fluxes:
-            ua_e(nlci-nbghostcells-1:nlci-2,jj) = ubdy_e(1:nbghostcells,jj) * hur_e(nlci-nbghostcells-1:nlci-2,jj)
-            ! Characteristics method (only if ghostcells=1):
-            !alt            ua_e(nlci-2,jj) = 0.5_wp * ( ubdy_e(jj) * hur_e(nlci-2,jj) + ua_e(nlci-3,jj) &
-            !alt                            &           + sqrt(grav * hur_e(nlci-2,jj)) * (sshn_e(nlci-2,jj) - hbdy_e(jj)) )
-         END DO
-      ENDIF
-      !
-      IF((nbondj == -1).OR.(nbondj == 2)) THEN
-         DO ji=1,jpi
-            ua_e(ji,2:nbghostcells+1) = ubdy_s(ji,1:nbghostcells) * hur_e(ji,2:nbghostcells+1)
-            ! Specified fluxes:
-            va_e(ji,2:nbghostcells+1) = vbdy_s(ji,1:nbghostcells) * hvr_e(ji,2:nbghostcells+1)
-            ! Characteristics method (only if ghostcells=1):
-            !alt            va_e(ji,2) = 0.5_wp * ( vbdy_s(ji) * hvr_e(ji,2) + va_e(ji,3) &
-            !alt                       &           - sqrt(grav * hvr_e(ji,2)) * (sshn_e(ji,3) - hbdy_s(ji)) )
-         END DO
-      ENDIF
-      !
-      IF((nbondj == 1).OR.(nbondj == 2)) THEN
-         DO ji=1,jpi
-            ua_e(ji,nlcj-nbghostcells:nlcj-1)   = ubdy_n(ji,1:nbghostcells) * hur_e(ji,nlcj-nbghostcells:nlcj-1)
-            ! Specified fluxes:
-            va_e(ji,nlcj-nbghostcells-1:nlcj-2) = vbdy_n(ji,1:nbghostcells) * hvr_e(ji,nlcj-nbghostcells-1:nlcj-2)
-            ! Characteristics method (only if ghostcells=1):
-            !alt            va_e(ji,nlcj-2) = 0.5_wp * ( vbdy_n(ji) * hvr_e(ji,nlcj-2)  + va_e(ji,nlcj-3) &
-            !alt                            &           + sqrt(grav * hvr_e(ji,nlcj-2)) * (sshn_e(ji,nlcj-2) - hbdy_n(ji)) )
-         END DO
-      ENDIF
-      !
-   END SUBROUTINE Agrif_dyn_ts
-
-
-   SUBROUTINE Agrif_dta_ts( kt )
-      !!----------------------------------------------------------------------
-      !!                  ***  ROUTINE Agrif_dta_ts  ***
-      !!----------------------------------------------------------------------  
-      INTEGER, INTENT(in) ::   kt
-      !!
-      INTEGER :: ji, jj
-      LOGICAL :: ll_int_cons
-      !!----------------------------------------------------------------------  
-      !
-      IF( Agrif_Root() )   RETURN
-      !
-      ll_int_cons = ln_bt_fw ! Assume conservative temporal integration in the forward case only
-      !
-      ! Enforce volume conservation if no time refinement:  
-      IF ( Agrif_rhot()==1 ) ll_int_cons=.TRUE.  
-      !
-      ! Interpolate barotropic fluxes
-      Agrif_SpecialValue=0._wp
-      Agrif_UseSpecialValue = ln_spc_dyn
-      !
-      IF( ll_int_cons ) THEN  ! Conservative interpolation
-         ! order matters here !!!!!!
-         CALL Agrif_Bc_variable( ub2b_interp_id, calledweight=1._wp, procname=interpub2b ) ! Time integrated
-         CALL Agrif_Bc_variable( vb2b_interp_id, calledweight=1._wp, procname=interpvb2b )
-         bdy_tinterp = 1
-         CALL Agrif_Bc_variable( unb_id        , calledweight=1._wp, procname=interpunb  ) ! After
-         CALL Agrif_Bc_variable( vnb_id        , calledweight=1._wp, procname=interpvnb  )
-         bdy_tinterp = 2
-         CALL Agrif_Bc_variable( unb_id        , calledweight=0._wp, procname=interpunb  ) ! Before
-         CALL Agrif_Bc_variable( vnb_id        , calledweight=0._wp, procname=interpvnb  )         
-      ELSE ! Linear interpolation
-         bdy_tinterp = 0
-         ubdy_w(:,:) = 0._wp   ;   vbdy_w(:,:) = 0._wp 
-         ubdy_e(:,:) = 0._wp   ;   vbdy_e(:,:) = 0._wp 
-         ubdy_n(:,:) = 0._wp   ;   vbdy_n(:,:) = 0._wp 
-         ubdy_s(:,:) = 0._wp   ;   vbdy_s(:,:) = 0._wp
-         CALL Agrif_Bc_variable( unb_id, procname=interpunb )
-         CALL Agrif_Bc_variable( vnb_id, procname=interpvnb )
-      ENDIF
-      Agrif_UseSpecialValue = .FALSE.
-      ! 
-   END SUBROUTINE Agrif_dta_ts
-
-
-   SUBROUTINE Agrif_ssh( kt )
-      !!----------------------------------------------------------------------
-      !!                  ***  ROUTINE Agrif_ssh  ***
-      !!----------------------------------------------------------------------  
-      INTEGER, INTENT(in) ::   kt
-      !
-      INTEGER  :: ji, jj, indx, indy
-      !!----------------------------------------------------------------------  
-      !
-      IF( Agrif_Root() )   RETURN
-      !      
-      ! Linear time interpolation of sea level
-      !
-      Agrif_SpecialValue    = 0._wp
-      Agrif_UseSpecialValue = .TRUE.
-      CALL Agrif_Bc_variable(sshn_id, procname=interpsshn )
-      Agrif_UseSpecialValue = .FALSE.
-      !
-      ! --- West --- !
-      IF((nbondi == -1).OR.(nbondi == 2)) THEN
-         indx = 1+nbghostcells
-         DO jj = 1, jpj
-            DO ji = 2, indx
-               ssha(ji,jj) = hbdy_w(ji-1,jj)
-            ENDDO
-         ENDDO
-      ENDIF
-      !
-      ! --- East --- !
-      IF((nbondi == 1).OR.(nbondi == 2)) THEN
-         indx = nlci-nbghostcells
-         DO jj = 1, jpj
-            DO ji = indx, nlci-1
-               ssha(ji,jj) = hbdy_e(ji-indx+1,jj)
-            ENDDO
-         ENDDO
-      ENDIF
-      !
-      ! --- South --- !
-      IF((nbondj == -1).OR.(nbondj == 2)) THEN
-         indy = 1+nbghostcells
-         DO jj = 2, indy
-            DO ji = 1, jpi
-               ssha(ji,jj) = hbdy_s(ji,jj-1)
-            ENDDO
-         ENDDO
-      ENDIF
-      !
-      ! --- North --- !
-      IF((nbondj == 1).OR.(nbondj == 2)) THEN
-         indy = nlcj-nbghostcells
-         DO jj = indy, nlcj-1
-            DO ji = 1, jpi
-               ssha(ji,jj) = hbdy_n(ji,jj-indy+1)
-            ENDDO
-         ENDDO
-      ENDIF
-      !
-   END SUBROUTINE Agrif_ssh
-
-
-   SUBROUTINE Agrif_ssh_ts( jn )
-      !!----------------------------------------------------------------------
-      !!                  ***  ROUTINE Agrif_ssh_ts  ***
-      !!----------------------------------------------------------------------  
-      INTEGER, INTENT(in) ::   jn
-      !!
-      INTEGER :: ji, jj, indx, indy
-      !!----------------------------------------------------------------------  
-      !! clem ghost (starting at i,j=1 is important I think otherwise you introduce a grad(ssh)/=0 at point 2)
-      !
-      IF( Agrif_Root() )   RETURN
-      !
-      ! --- West --- !
-      IF((nbondi == -1).OR.(nbondi == 2)) THEN
-         indx = 1+nbghostcells
-         DO jj = 1, jpj
-            DO ji = 2, indx
-               ssha_e(ji,jj) = hbdy_w(ji-1,jj)
-            ENDDO
-         ENDDO
-      ENDIF
-      !
-      ! --- East --- !
-      IF((nbondi == 1).OR.(nbondi == 2)) THEN
-         indx = nlci-nbghostcells
-         DO jj = 1, jpj
-            DO ji = indx, nlci-1
-               ssha_e(ji,jj) = hbdy_e(ji-indx+1,jj)
-            ENDDO
-         ENDDO
-      ENDIF
-      !
-      ! --- South --- !
-      IF((nbondj == -1).OR.(nbondj == 2)) THEN
-         indy = 1+nbghostcells
-         DO jj = 2, indy
-            DO ji = 1, jpi
-               ssha_e(ji,jj) = hbdy_s(ji,jj-1)
-            ENDDO
-         ENDDO
-      ENDIF
-      !
-      ! --- North --- !
-      IF((nbondj == 1).OR.(nbondj == 2)) THEN
-         indy = nlcj-nbghostcells
-         DO jj = indy, nlcj-1
-            DO ji = 1, jpi
-               ssha_e(ji,jj) = hbdy_n(ji,jj-indy+1)
-            ENDDO
-         ENDDO
-      ENDIF
-      !
-   END SUBROUTINE Agrif_ssh_ts
-
-   SUBROUTINE Agrif_avm
-      !!----------------------------------------------------------------------
-      !!                  ***  ROUTINE Agrif_avm  ***
-      !!----------------------------------------------------------------------  
-      REAL(wp) ::   zalpha
-      !!----------------------------------------------------------------------  
-      !
-      IF( Agrif_Root() )   RETURN
-      !
-      zalpha = 1._wp ! JC: proper time interpolation impossible  
-                     ! => use last available value from parent 
-      !
-      Agrif_SpecialValue    = 0.e0
-      Agrif_UseSpecialValue = .TRUE.
-      !
-      CALL Agrif_Bc_variable( avm_id, calledweight=zalpha, procname=interpavm )       
-      !
-      Agrif_UseSpecialValue = .FALSE.
-      !
-   END SUBROUTINE Agrif_avm
-   
-
-   SUBROUTINE interptsn( ptab, i1, i2, j1, j2, k1, k2, n1, n2, before, nb, ndir )
-      !!----------------------------------------------------------------------
-      !!                  *** ROUTINE interptsn ***
-      !!----------------------------------------------------------------------
-      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) ::   ptab
-      INTEGER                                     , INTENT(in   ) ::   i1, i2, j1, j2, k1, k2, n1, n2
-      LOGICAL                                     , INTENT(in   ) ::   before
-      INTEGER                                     , INTENT(in   ) ::   nb , ndir
-      !
-      INTEGER  ::   ji, jj, jk, jn, iref, jref, ibdy, jbdy   ! dummy loop indices
-      INTEGER  ::   imin, imax, jmin, jmax, N_in, N_out
-      REAL(wp) ::   zrhox, z1, z2, z3, z4, z5, z6, z7
-      LOGICAL :: western_side, eastern_side,northern_side,southern_side
-      ! vertical interpolation:
-      REAL(wp), DIMENSION(i1:i2,j1:j2,1:jpk,n1:n2) :: ptab_child
-      REAL(wp), DIMENSION(k1:k2,n1:n2-1) :: tabin
-      REAL(wp), DIMENSION(k1:k2) :: h_in
-      REAL(wp), DIMENSION(1:jpk) :: h_out
-      REAL(wp) :: h_diff
-
-      IF( before ) THEN         
-         DO jn = 1,jpts
-            DO jk=k1,k2
-               DO jj=j1,j2
-                 DO ji=i1,i2
-                       ptab(ji,jj,jk,jn) = tsn(ji,jj,jk,jn)
-                 END DO
-              END DO
-           END DO
-        END DO
-
-# if defined key_vertical
-        DO jk=k1,k2
-           DO jj=j1,j2
-              DO ji=i1,i2
-                 ptab(ji,jj,jk,jpts+1) = tmask(ji,jj,jk) * e3t_n(ji,jj,jk) 
-              END DO
-           END DO
-        END DO
-# endif
-      ELSE 
-
-         western_side  = (nb == 1).AND.(ndir == 1)   ;   eastern_side  = (nb == 1).AND.(ndir == 2)
-         southern_side = (nb == 2).AND.(ndir == 1)   ;   northern_side = (nb == 2).AND.(ndir == 2)
-
-# if defined key_vertical              
-         DO jj=j1,j2
-            DO ji=i1,i2
-               iref = ji
-               jref = jj
-               if(western_side) iref=MAX(2,ji)
-               if(eastern_side) iref=MIN(nlci-1,ji)
-               if(southern_side) jref=MAX(2,jj)
-               if(northern_side) jref=MIN(nlcj-1,jj)
-               N_in = 0
-               DO jk=k1,k2 !k2 = jpk of parent grid
-                  IF (ptab(ji,jj,jk,n2) == 0) EXIT
-                  N_in = N_in + 1
-                  tabin(jk,:) = ptab(ji,jj,jk,n1:n2-1)
-                  h_in(N_in) = ptab(ji,jj,jk,n2)
-               END DO
-               N_out = 0
-               DO jk=1,jpk ! jpk of child grid
-                  IF (tmask(iref,jref,jk) == 0) EXIT 
-                  N_out = N_out + 1
-                  h_out(jk) = e3t_n(iref,jref,jk)
-               ENDDO
-               IF (N_in > 0) THEN
-                  DO jn=1,jpts
-                     call reconstructandremap(tabin(1:N_in,jn),h_in,ptab_child(ji,jj,1:N_out,jn),h_out,N_in,N_out)
-                  ENDDO
-               ENDIF
-            ENDDO
-         ENDDO
-# else
-         ptab_child(i1:i2,j1:j2,1:jpk,1:jpts) = ptab(i1:i2,j1:j2,1:jpk,1:jpts)
-# endif
-         !
-         tsa(i1:i2,j1:j2,1:jpk,1:jpts) = ptab_child(i1:i2,j1:j2,1:jpk,1:jpts)
-
-         IF ( .NOT.lk_agrif_clp ) THEN 
-            !
-            zrhox = Agrif_Rhox()
-            z1 = ( zrhox - 1. ) * 0.5
-            z3 = ( zrhox - 1. ) / ( zrhox + 1. )
-            z6 = 2. * ( zrhox - 1. ) / ( zrhox + 1. )
-            z7 =    - ( zrhox - 1. ) / ( zrhox + 3. )
-            !
-            z2 = 1. - z1
-            z4 = 1. - z3
-            z5 = 1. - z6 - z7
-            !
-            imin = i1 ; imax = i2
-            jmin = j1 ; jmax = j2
-            ! 
-            ! Remove CORNERS
-            IF((nbondj == -1).OR.(nbondj == 2)) jmin = 2 + nbghostcells
-            IF((nbondj == +1).OR.(nbondj == 2)) jmax = nlcj - nbghostcells - 1
-            IF((nbondi == -1).OR.(nbondi == 2)) imin = 1 + nbghostcells
-            IF((nbondi == +1).OR.(nbondi == 2)) imax = nlci - nbghostcells - 1      
-            !
-            IF( eastern_side ) THEN
-               ibdy = nlci-nbghostcells
-               DO jn = 1, jpts
-                  tsa(ibdy+1,jmin:jmax,k1:k2,jn) = z1 * ptab_child(ibdy+1,jmin:jmax,k1:k2,jn) + z2 * ptab_child(ibdy,jmin:jmax,k1:k2,jn)
-                  DO jk = 1, jpkm1
-                     DO jj = jmin,jmax
-                        IF( umask(ibdy-1,jj,jk) == 0._wp ) THEN
-                           tsa(ibdy,jj,jk,jn) = tsa(ibdy+1,jj,jk,jn) * tmask(ibdy,jj,jk)
-                        ELSE
-                           tsa(ibdy,jj,jk,jn)=(z4*tsa(ibdy+1,jj,jk,jn)+z3*tsa(ibdy-1,jj,jk,jn))*tmask(ibdy,jj,jk)
-                           IF( un(ibdy-1,jj,jk) > 0._wp ) THEN
-                              tsa(ibdy,jj,jk,jn)=( z6*tsa(ibdy-1,jj,jk,jn)+z5*tsa(ibdy+1,jj,jk,jn) & 
-                                                 + z7*tsa(ibdy-2,jj,jk,jn) ) * tmask(ibdy,jj,jk)
-                           ENDIF
-                        ENDIF
-                     END DO
-                  END DO
-                  ! Restore ghost points:
-                  tsa(ibdy+1,jmin:jmax,k1:k2,jn) = ptab_child(ibdy+1,jmin:jmax,k1:k2,jn) * tmask(ibdy+1,jmin:jmax,k1:k2)
-               END DO
-            ENDIF
-            ! 
-            IF( northern_side ) THEN
-               jbdy = nlcj-nbghostcells         
-               DO jn = 1, jpts
-                  tsa(imin:imax,jbdy+1,k1:k2,jn) = z1 * ptab_child(imin:imax,jbdy+1,k1:k2,jn) + z2 * ptab_child(imin:imax,jbdy,k1:k2,jn)
-                  DO jk = 1, jpkm1
-                     DO ji = imin,imax
-                        IF( vmask(ji,jbdy-1,jk) == 0._wp ) THEN
-                           tsa(ji,jbdy,jk,jn) = tsa(ji,jbdy+1,jk,jn) * tmask(ji,jbdy,jk)
-                        ELSE
-                           tsa(ji,jbdy,jk,jn)=(z4*tsa(ji,jbdy+1,jk,jn)+z3*tsa(ji,jbdy-1,jk,jn))*tmask(ji,jbdy,jk)        
-                           IF (vn(ji,jbdy-1,jk) > 0._wp ) THEN
-                              tsa(ji,jbdy,jk,jn)=( z6*tsa(ji,jbdy-1,jk,jn)+z5*tsa(ji,jbdy+1,jk,jn)  &
-                                                 + z7*tsa(ji,jbdy-2,jk,jn) ) * tmask(ji,jbdy,jk)
-                           ENDIF
-                        ENDIF
-                     END DO
-                  END DO
-                  ! Restore ghost points:
-                  tsa(imin:imax,jbdy+1,k1:k2,jn) = ptab_child(imin:imax,jbdy+1,k1:k2,jn) * tmask(imin:imax,jbdy+1,k1:k2)
-               END DO
-            ENDIF
-            !
-            IF( western_side ) THEN    
-               ibdy = 1+nbghostcells       
-               DO jn = 1, jpts
-                  tsa(ibdy-1,jmin:jmax,k1:k2,jn) = z1 * ptab_child(ibdy-1,jmin:jmax,k1:k2,jn) + z2 * ptab_child(ibdy,jmin:jmax,k1:k2,jn)
-                  DO jk = 1, jpkm1
-                     DO jj = jmin,jmax
-                        IF( umask(ibdy,jj,jk) == 0._wp ) THEN
-                           tsa(ibdy,jj,jk,jn) = tsa(ibdy-1,jj,jk,jn) * tmask(ibdy,jj,jk)
-                        ELSE
-                           tsa(ibdy,jj,jk,jn)=(z4*tsa(ibdy-1,jj,jk,jn)+z3*tsa(ibdy+1,jj,jk,jn))*tmask(ibdy,jj,jk)        
-                           IF( un(ibdy,jj,jk) < 0._wp ) THEN
-                              tsa(ibdy,jj,jk,jn)=(z6*tsa(ibdy+1,jj,jk,jn)+z5*tsa(ibdy-1,jj,jk,jn)+z7*tsa(ibdy+2,jj,jk,jn))*tmask(ibdy,jj,jk)
-                           ENDIF
-                        ENDIF
-                     END DO
-                  END DO
-                  ! Restore ghost points:
-                  tsa(ibdy-1,jmin:jmax,k1:k2,jn) = ptab_child(ibdy-1,jmin:jmax,k1:k2,jn) * tmask(ibdy-1,jmin:jmax,k1:k2)
-               END DO
-            ENDIF
-            !
-            IF( southern_side ) THEN  
-               jbdy=1+nbghostcells        
-               DO jn = 1, jpts
-                  tsa(imin:imax,jbdy-1,k1:k2,jn) = z1 * ptab_child(imin:imax,jbdy-1,k1:k2,jn) + z2 * ptab_child(imin:imax,jbdy,k1:k2,jn)
-                  DO jk = 1, jpk      
-                     DO ji=imin,imax
-                        IF( vmask(ji,jbdy,jk) == 0._wp ) THEN
-                           tsa(ji,jbdy,jk,jn)=tsa(ji,jbdy-1,jk,jn) * tmask(ji,jbdy,jk)
-                        ELSE
-                           tsa(ji,jbdy,jk,jn)=(z4*tsa(ji,jbdy-1,jk,jn)+z3*tsa(ji,jbdy+1,jk,jn))*tmask(ji,jbdy,jk)
-                           IF( vn(ji,jbdy,jk) < 0._wp ) THEN
-                              tsa(ji,jbdy,jk,jn)=(z6*tsa(ji,jbdy+1,jk,jn)+z5*tsa(ji,jbdy-1,jk,jn)+z7*tsa(ji,jbdy+2,jk,jn))*tmask(ji,jbdy,jk)
-                           ENDIF
-                        ENDIF
-                     END DO
-                  END DO
-                  ! Restore ghost points:
-                  tsa(imin:imax,jbdy-1,k1:k2,jn) = tsa(imin:imax,jbdy-1,k1:k2,jn) * tmask(imin:imax,jbdy-1,k1:k2)
-               END DO
-            ENDIF
-            !
-         ENDIF
-      ENDIF
-      !
-   END SUBROUTINE interptsn
-
-   SUBROUTINE interpsshn( ptab, i1, i2, j1, j2, before, nb, ndir )
-      !!----------------------------------------------------------------------
-      !!                  ***  ROUTINE interpsshn  ***
-      !!----------------------------------------------------------------------  
-      INTEGER                         , INTENT(in   ) ::   i1, i2, j1, j2
-      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) ::   ptab
-      LOGICAL                         , INTENT(in   ) ::   before
-      INTEGER                         , INTENT(in   ) ::   nb , ndir
-      !
-      LOGICAL :: western_side, eastern_side,northern_side,southern_side
-      !!----------------------------------------------------------------------  
-      !
-      IF( before) THEN
-         ptab(i1:i2,j1:j2) = sshn(i1:i2,j1:j2)
-      ELSE
-         western_side  = (nb == 1).AND.(ndir == 1)
-         eastern_side  = (nb == 1).AND.(ndir == 2)
-         southern_side = (nb == 2).AND.(ndir == 1)
-         northern_side = (nb == 2).AND.(ndir == 2)
-         !! clem ghost
-         IF(western_side)  hbdy_w(1:nbghostcells,j1:j2) = ptab(i1:i2,j1:j2) * tmask(i1:i2,j1:j2,1)
-         IF(eastern_side)  hbdy_e(1:nbghostcells,j1:j2) = ptab(i1:i2,j1:j2) * tmask(i1:i2,j1:j2,1)
-         IF(southern_side) hbdy_s(i1:i2,1:nbghostcells) = ptab(i1:i2,j1:j2) * tmask(i1:i2,j1:j2,1) 
-         IF(northern_side) hbdy_n(i1:i2,1:nbghostcells) = ptab(i1:i2,j1:j2) * tmask(i1:i2,j1:j2,1)
-      ENDIF
-      !
-   END SUBROUTINE interpsshn
-
-   SUBROUTINE interpun( ptab, i1, i2, j1, j2, k1, k2, m1, m2, before, nb, ndir )
-      !!----------------------------------------------------------------------
-      !!                  *** ROUTINE interpun ***
-      !!---------------------------------------------    
-      !!
-      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,m1,m2
-      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,m1:m2), INTENT(inout) :: ptab
-      LOGICAL, INTENT(in) :: before
-      INTEGER, INTENT(in) :: nb , ndir
-      !!
-      INTEGER :: ji,jj,jk
-      REAL(wp) :: zrhoy
-      ! vertical interpolation:
-      REAL(wp), DIMENSION(k1:k2) :: tabin, h_in
-      REAL(wp), DIMENSION(1:jpk) :: h_out
-      INTEGER  :: N_in, N_out, iref
-      REAL(wp) :: h_diff
-      LOGICAL  :: western_side, eastern_side
-      !!---------------------------------------------    
-      !
-      IF (before) THEN 
-         DO jk=1,jpk
-            DO jj=j1,j2
-               DO ji=i1,i2
-                  ptab(ji,jj,jk,1) = (e2u(ji,jj) * e3u_n(ji,jj,jk) * un(ji,jj,jk)*umask(ji,jj,jk)) 
-# if defined key_vertical
-                  ptab(ji,jj,jk,2) = (umask(ji,jj,jk) * e2u(ji,jj) * e3u_n(ji,jj,jk))
-# endif
-               END DO
-            END DO
-         END DO
-      ELSE
-         zrhoy = Agrif_rhoy()
-# if defined key_vertical
-! VERTICAL REFINEMENT BEGIN
-         western_side  = (nb == 1).AND.(ndir == 1)
-         eastern_side  = (nb == 1).AND.(ndir == 2)
-
-         DO ji=i1,i2
-            iref = ji
-            IF (western_side) iref = MAX(2,ji)
-            IF (eastern_side) iref = MIN(nlci-2,ji)
-            DO jj=j1,j2
-               N_in = 0
-               DO jk=k1,k2
-                  IF (ptab(ji,jj,jk,2) == 0) EXIT
-                  N_in = N_in + 1
-                  tabin(jk) = ptab(ji,jj,jk,1)/ptab(ji,jj,jk,2)
-                  h_in(N_in) = ptab(ji,jj,jk,2)/(e2u(ji,jj)*zrhoy) 
-              ENDDO
-         
-              IF (N_in == 0) THEN
-                 ua(ji,jj,:) = 0._wp
-                 CYCLE
-              ENDIF
-         
-              N_out = 0
-              DO jk=1,jpk
-                 if (umask(iref,jj,jk) == 0) EXIT
-                 N_out = N_out + 1
-                 h_out(N_out) = e3u_a(iref,jj,jk)
-              ENDDO
-         
-              IF (N_out == 0) THEN
-                 ua(ji,jj,:) = 0._wp
-                 CYCLE
-              ENDIF
-         
-              IF (N_in * N_out > 0) THEN
-                 h_diff = sum(h_out(1:N_out))-sum(h_in(1:N_in))
-! Should be able to remove the next IF/ELSEIF statement once scale factors are dealt with properly
-                 if (h_diff < -1.e4) then
-                    print *,'CHECK YOUR BATHY ...', h_diff, sum(h_out(1:N_out)), sum(h_in(1:N_in))
-!                    stop
-                 endif
-              ENDIF
-              call reconstructandremap(tabin(1:N_in),h_in(1:N_in),ua(ji,jj,1:N_out),h_out(1:N_out),N_in,N_out)
-            ENDDO
-         ENDDO
-
-# else
-         DO jk = 1, jpkm1
-            DO jj=j1,j2
-               ua(i1:i2,jj,jk) = ptab(i1:i2,jj,jk,1) / ( zrhoy * e2u(i1:i2,jj) * e3u_a(i1:i2,jj,jk) )
-            END DO
-         END DO
-# endif
-
-      ENDIF
-      ! 
-   END SUBROUTINE interpun
-
-   SUBROUTINE interpvn( ptab, i1, i2, j1, j2, k1, k2, m1, m2, before, nb, ndir )
-      !!----------------------------------------------------------------------
-      !!                  *** ROUTINE interpvn ***
-      !!----------------------------------------------------------------------
-      !
-      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,m1,m2
-      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,m1:m2), INTENT(inout) :: ptab
-      LOGICAL, INTENT(in) :: before
-      INTEGER, INTENT(in) :: nb , ndir
-      !
-      INTEGER :: ji,jj,jk
-      REAL(wp) :: zrhox
-      ! vertical interpolation:
-      REAL(wp), DIMENSION(k1:k2) :: tabin, h_in
-      REAL(wp), DIMENSION(1:jpk) :: h_out
-      INTEGER  :: N_in, N_out, jref
-      REAL(wp) :: h_diff
-      LOGICAL  :: northern_side,southern_side
-      !!---------------------------------------------    
-      !      
-      IF (before) THEN          
-         DO jk=k1,k2
-            DO jj=j1,j2
-               DO ji=i1,i2
-                  ptab(ji,jj,jk,1) = (e1v(ji,jj) * e3v_n(ji,jj,jk) * vn(ji,jj,jk)*vmask(ji,jj,jk))
-# if defined key_vertical
-                  ptab(ji,jj,jk,2) = vmask(ji,jj,jk) * e1v(ji,jj) * e3v_n(ji,jj,jk)
-# endif
-               END DO
-            END DO
-         END DO
-      ELSE       
-         zrhox = Agrif_rhox()
-# if defined key_vertical
-
-         southern_side = (nb == 2).AND.(ndir == 1)
-         northern_side = (nb == 2).AND.(ndir == 2)
-
-         DO jj=j1,j2
-            jref = jj
-            IF (southern_side) jref = MAX(2,jj)
-            IF (northern_side) jref = MIN(nlcj-2,jj)
-            DO ji=i1,i2
-               N_in = 0
-               DO jk=k1,k2
-                  if (ptab(ji,jj,jk,2) == 0) EXIT
-                  N_in = N_in + 1
-                  tabin(jk) = ptab(ji,jj,jk,1)/ptab(ji,jj,jk,2)
-                  h_in(N_in) = ptab(ji,jj,jk,2)/(e1v(ji,jj)*zrhox)
-               END DO
-               IF (N_in == 0) THEN
-                  va(ji,jj,:) = 0._wp
-                  CYCLE
-               ENDIF
-         
-               N_out = 0
-               DO jk=1,jpk
-                  if (vmask(ji,jref,jk) == 0) EXIT
-                  N_out = N_out + 1
-                  h_out(N_out) = e3v_a(ji,jref,jk)
-               END DO
-               IF (N_out == 0) THEN
-                 va(ji,jj,:) = 0._wp
-                 CYCLE
-               ENDIF
-               call reconstructandremap(tabin(1:N_in),h_in(1:N_in),va(ji,jj,1:N_out),h_out(1:N_out),N_in,N_out)
-            END DO
-         END DO
-# else
-         DO jk = 1, jpkm1
-            va(i1:i2,j1:j2,jk) = ptab(i1:i2,j1:j2,jk,1) / ( zrhox * e1v(i1:i2,j1:j2) * e3v_a(i1:i2,j1:j2,jk) )
-         END DO
-# endif
-      ENDIF
-      !        
-   END SUBROUTINE interpvn
-
-   SUBROUTINE interpunb( ptab, i1, i2, j1, j2, before, nb, ndir )
-      !!----------------------------------------------------------------------
-      !!                  ***  ROUTINE interpunb  ***
-      !!----------------------------------------------------------------------  
-      INTEGER                         , INTENT(in   ) ::   i1, i2, j1, j2
-      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) ::   ptab
-      LOGICAL                         , INTENT(in   ) ::   before
-      INTEGER                         , INTENT(in   ) ::   nb , ndir
-      !
-      INTEGER  ::   ji, jj
-      REAL(wp) ::   zrhoy, zrhot, zt0, zt1, ztcoeff
-      LOGICAL  ::   western_side, eastern_side,northern_side,southern_side
-      !!----------------------------------------------------------------------  
-      !
-      IF( before ) THEN 
-         ptab(i1:i2,j1:j2) = e2u(i1:i2,j1:j2) * hu_n(i1:i2,j1:j2) * un_b(i1:i2,j1:j2)
-      ELSE
-         western_side  = (nb == 1).AND.(ndir == 1)
-         eastern_side  = (nb == 1).AND.(ndir == 2)
-         southern_side = (nb == 2).AND.(ndir == 1)
-         northern_side = (nb == 2).AND.(ndir == 2)
-         zrhoy = Agrif_Rhoy()
-         zrhot = Agrif_rhot()
-         ! Time indexes bounds for integration
-         zt0 = REAL(Agrif_NbStepint()  , wp) / zrhot
-         zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot      
-         ! Polynomial interpolation coefficients:
-         IF( bdy_tinterp == 1 ) THEN
-            ztcoeff = zrhot * (  zt1**2._wp * (       zt1 - 1._wp)        &
-               &               - zt0**2._wp * (       zt0 - 1._wp)        )
-         ELSEIF( bdy_tinterp == 2 ) THEN
-            ztcoeff = zrhot * (  zt1        * (       zt1 - 1._wp)**2._wp &
-               &               - zt0        * (       zt0 - 1._wp)**2._wp )
-         ELSE
-            ztcoeff = 1
-         ENDIF
-         !   
-         IF(western_side)   ubdy_w(1:nbghostcells,j1:j2) = ubdy_w(1:nbghostcells,j1:j2) + ztcoeff * ptab(i1:i2,j1:j2)  
-         IF(eastern_side)   ubdy_e(1:nbghostcells,j1:j2) = ubdy_e(1:nbghostcells,j1:j2) + ztcoeff * ptab(i1:i2,j1:j2)  
-         IF(southern_side)  ubdy_s(i1:i2,1:nbghostcells) = ubdy_s(i1:i2,1:nbghostcells) + ztcoeff * ptab(i1:i2,j1:j2)
-         IF(northern_side)  ubdy_n(i1:i2,1:nbghostcells) = ubdy_n(i1:i2,1:nbghostcells) + ztcoeff * ptab(i1:i2,j1:j2) 
-         !            
-         IF( bdy_tinterp == 0 .OR. bdy_tinterp == 2) THEN
-            IF(western_side)   ubdy_w(1:nbghostcells,j1:j2) = ubdy_w(1:nbghostcells,j1:j2) / (zrhoy*e2u(i1:i2,j1:j2)) * umask(i1:i2,j1:j2,1)
-            IF(eastern_side)   ubdy_e(1:nbghostcells,j1:j2) = ubdy_e(1:nbghostcells,j1:j2) / (zrhoy*e2u(i1:i2,j1:j2)) * umask(i1:i2,j1:j2,1)
-            IF(southern_side)  ubdy_s(i1:i2,1:nbghostcells) = ubdy_s(i1:i2,1:nbghostcells) / (zrhoy*e2u(i1:i2,j1:j2)) * umask(i1:i2,j1:j2,1)
-            IF(northern_side)  ubdy_n(i1:i2,1:nbghostcells) = ubdy_n(i1:i2,1:nbghostcells) / (zrhoy*e2u(i1:i2,j1:j2)) * umask(i1:i2,j1:j2,1)
-         ENDIF
-      ENDIF
-      ! 
-   END SUBROUTINE interpunb
-
-
-   SUBROUTINE interpvnb( ptab, i1, i2, j1, j2, before, nb, ndir )
-      !!----------------------------------------------------------------------
-      !!                  ***  ROUTINE interpvnb  ***
-      !!----------------------------------------------------------------------  
-      INTEGER                         , INTENT(in   ) ::   i1, i2, j1, j2
-      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) ::   ptab
-      LOGICAL                         , INTENT(in   ) ::   before
-      INTEGER                         , INTENT(in   ) ::   nb , ndir
-      !
-      INTEGER  ::   ji,jj
-      REAL(wp) ::   zrhox, zrhot, zt0, zt1, ztcoeff   
-      LOGICAL  ::   western_side, eastern_side,northern_side,southern_side
-      !!----------------------------------------------------------------------  
-      ! 
-      IF( before ) THEN 
-         ptab(i1:i2,j1:j2) = e1v(i1:i2,j1:j2) * hv_n(i1:i2,j1:j2) * vn_b(i1:i2,j1:j2)
-      ELSE
-         western_side  = (nb == 1).AND.(ndir == 1)
-         eastern_side  = (nb == 1).AND.(ndir == 2)
-         southern_side = (nb == 2).AND.(ndir == 1)
-         northern_side = (nb == 2).AND.(ndir == 2)
-         zrhox = Agrif_Rhox()
-         zrhot = Agrif_rhot()
-         ! Time indexes bounds for integration
-         zt0 = REAL(Agrif_NbStepint()  , wp) / zrhot
-         zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot      
-         IF( bdy_tinterp == 1 ) THEN
-            ztcoeff = zrhot * (  zt1**2._wp * (       zt1 - 1._wp)        &
-               &               - zt0**2._wp * (       zt0 - 1._wp)        )
-         ELSEIF( bdy_tinterp == 2 ) THEN
-            ztcoeff = zrhot * (  zt1        * (       zt1 - 1._wp)**2._wp &
-               &               - zt0        * (       zt0 - 1._wp)**2._wp ) 
-         ELSE
-            ztcoeff = 1
-         ENDIF
-         !! clem ghost
-         IF(western_side)   vbdy_w(1:nbghostcells,j1:j2) = vbdy_w(1:nbghostcells,j1:j2) + ztcoeff * ptab(i1:i2,j1:j2)  
-         IF(eastern_side)   vbdy_e(1:nbghostcells,j1:j2) = vbdy_e(1:nbghostcells,j1:j2) + ztcoeff * ptab(i1:i2,j1:j2)   
-         IF(southern_side)  vbdy_s(i1:i2,1:nbghostcells) = vbdy_s(i1:i2,1:nbghostcells) + ztcoeff * ptab(i1:i2,j1:j2)
-         IF(northern_side)  vbdy_n(i1:i2,1:nbghostcells) = vbdy_n(i1:i2,1:nbghostcells) + ztcoeff * ptab(i1:i2,j1:j2) 
-         !            
-         IF( bdy_tinterp == 0 .OR. bdy_tinterp == 2) THEN
-            IF(western_side)   vbdy_w(1:nbghostcells,j1:j2) = vbdy_w(1:nbghostcells,j1:j2) / (zrhox*e1v(i1:i2,j1:j2)) * vmask(i1:i2,j1:j2,1)
-            IF(eastern_side)   vbdy_e(1:nbghostcells,j1:j2) = vbdy_e(1:nbghostcells,j1:j2) / (zrhox*e1v(i1:i2,j1:j2)) * vmask(i1:i2,j1:j2,1)
-            IF(southern_side)  vbdy_s(i1:i2,1:nbghostcells) = vbdy_s(i1:i2,1:nbghostcells) / (zrhox*e1v(i1:i2,j1:j2)) * vmask(i1:i2,j1:j2,1)
-            IF(northern_side)  vbdy_n(i1:i2,1:nbghostcells) = vbdy_n(i1:i2,1:nbghostcells) / (zrhox*e1v(i1:i2,j1:j2)) * vmask(i1:i2,j1:j2,1)
-         ENDIF
-      ENDIF
-      !
-   END SUBROUTINE interpvnb
-
-
-   SUBROUTINE interpub2b( ptab, i1, i2, j1, j2, before, nb, ndir )
-      !!----------------------------------------------------------------------
-      !!                  ***  ROUTINE interpub2b  ***
-      !!----------------------------------------------------------------------  
-      INTEGER                         , INTENT(in   ) ::   i1, i2, j1, j2
-      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) ::   ptab
-      LOGICAL                         , INTENT(in   ) ::   before
-      INTEGER                         , INTENT(in   ) ::   nb , ndir
-      !
-      INTEGER  ::   ji,jj
-      REAL(wp) ::   zrhot, zt0, zt1,zat
-      LOGICAL  ::   western_side, eastern_side,northern_side,southern_side
-      !!----------------------------------------------------------------------  
-      IF( before ) THEN
-         IF ( ln_bt_fw ) THEN
-            ptab(i1:i2,j1:j2) = e2u(i1:i2,j1:j2) * ub2_b(i1:i2,j1:j2)
-         ELSE
-            ptab(i1:i2,j1:j2) = e2u(i1:i2,j1:j2) * un_adv(i1:i2,j1:j2)
-         ENDIF
-      ELSE
-         western_side  = (nb == 1).AND.(ndir == 1)
-         eastern_side  = (nb == 1).AND.(ndir == 2)
-         southern_side = (nb == 2).AND.(ndir == 1)
-         northern_side = (nb == 2).AND.(ndir == 2)
-         zrhot = Agrif_rhot()
-         ! Time indexes bounds for integration
-         zt0 = REAL(Agrif_NbStepint()  , wp) / zrhot
-         zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot
-         ! Polynomial interpolation coefficients:
-         zat = zrhot * (  zt1**2._wp * (-2._wp*zt1 + 3._wp)    &
-            &           - zt0**2._wp * (-2._wp*zt0 + 3._wp)    ) 
-         !! clem ghost
-         IF(western_side ) ubdy_w(1:nbghostcells,j1:j2) = zat * ptab(i1:i2,j1:j2)  
-         IF(eastern_side ) ubdy_e(1:nbghostcells,j1:j2) = zat * ptab(i1:i2,j1:j2)  
-         IF(southern_side) ubdy_s(i1:i2,1:nbghostcells) = zat * ptab(i1:i2,j1:j2)
-         IF(northern_side) ubdy_n(i1:i2,1:nbghostcells) = zat * ptab(i1:i2,j1:j2) 
-      ENDIF
-      ! 
-   END SUBROUTINE interpub2b
-   
-
-   SUBROUTINE interpvb2b( ptab, i1, i2, j1, j2, before, nb, ndir )
-      !!----------------------------------------------------------------------
-      !!                  ***  ROUTINE interpvb2b  ***
-      !!----------------------------------------------------------------------  
-      INTEGER                         , INTENT(in   ) ::   i1, i2, j1, j2
-      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) ::   ptab
-      LOGICAL                         , INTENT(in   ) ::   before
-      INTEGER                         , INTENT(in   ) ::   nb , ndir
-      !
-      INTEGER ::   ji,jj
-      REAL(wp) ::   zrhot, zt0, zt1,zat
-      LOGICAL ::   western_side, eastern_side,northern_side,southern_side
-      !!----------------------------------------------------------------------  
-      !
-      IF( before ) THEN
-         IF ( ln_bt_fw ) THEN
-            ptab(i1:i2,j1:j2) = e1v(i1:i2,j1:j2) * vb2_b(i1:i2,j1:j2)
-         ELSE
-            ptab(i1:i2,j1:j2) = e1v(i1:i2,j1:j2) * vn_adv(i1:i2,j1:j2)
-         ENDIF
-      ELSE      
-         western_side  = (nb == 1).AND.(ndir == 1)
-         eastern_side  = (nb == 1).AND.(ndir == 2)
-         southern_side = (nb == 2).AND.(ndir == 1)
-         northern_side = (nb == 2).AND.(ndir == 2)
-         zrhot = Agrif_rhot()
-         ! Time indexes bounds for integration
-         zt0 = REAL(Agrif_NbStepint()  , wp) / zrhot
-         zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot
-         ! Polynomial interpolation coefficients:
-         zat = zrhot * (  zt1**2._wp * (-2._wp*zt1 + 3._wp)    &
-            &           - zt0**2._wp * (-2._wp*zt0 + 3._wp)    ) 
-         !
-         IF(western_side )   vbdy_w(1:nbghostcells,j1:j2) = zat * ptab(i1:i2,j1:j2)  
-         IF(eastern_side )   vbdy_e(1:nbghostcells,j1:j2) = zat * ptab(i1:i2,j1:j2)  
-         IF(southern_side)   vbdy_s(i1:i2,1:nbghostcells) = zat * ptab(i1:i2,j1:j2)
-         IF(northern_side)   vbdy_n(i1:i2,1:nbghostcells) = zat * ptab(i1:i2,j1:j2) 
-      ENDIF
-      !      
-   END SUBROUTINE interpvb2b
-
-
-   SUBROUTINE interpe3t( ptab, i1, i2, j1, j2, k1, k2, before, nb, ndir )
-      !!----------------------------------------------------------------------
-      !!                  ***  ROUTINE interpe3t  ***
-      !!----------------------------------------------------------------------  
-      INTEGER                              , INTENT(in   ) :: i1, i2, j1, j2, k1, k2
-      REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab
-      LOGICAL                              , INTENT(in   ) :: before
-      INTEGER                              , INTENT(in   ) :: nb , ndir
-      !
-      INTEGER :: ji, jj, jk
-      LOGICAL :: western_side, eastern_side, northern_side, southern_side
-      !!----------------------------------------------------------------------  
-      !    
-      IF( before ) THEN
-         ptab(i1:i2,j1:j2,k1:k2) = tmask(i1:i2,j1:j2,k1:k2) * e3t_0(i1:i2,j1:j2,k1:k2)
-      ELSE
-         western_side  = (nb == 1).AND.(ndir == 1)
-         eastern_side  = (nb == 1).AND.(ndir == 2)
-         southern_side = (nb == 2).AND.(ndir == 1)
-         northern_side = (nb == 2).AND.(ndir == 2)
-         !
-         DO jk = k1, k2
-            DO jj = j1, j2
-               DO ji = i1, i2
-                  !
-                  IF( ABS( ptab(ji,jj,jk) - tmask(ji,jj,jk) * e3t_0(ji,jj,jk) ) > 1.D-2) THEN
-                     IF (western_side) THEN
-                        WRITE(numout,*) 'ERROR bathymetry merge at the western border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk
-                     ELSEIF (eastern_side) THEN
-                        WRITE(numout,*) 'ERROR bathymetry merge at the eastern border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk
-                     ELSEIF (southern_side) THEN
-                        WRITE(numout,*) 'ERROR bathymetry merge at the southern border ji,jj,jk', ji+nimpp-1,jj+njmpp-1,jk
-                     ELSEIF (northern_side) THEN
-                        WRITE(numout,*) 'ERROR bathymetry merge at the northen border ji,jj,jk', ji+nimpp-1,jj+njmpp-1,jk
-                     ENDIF
-                     WRITE(numout,*) '      ptab(ji,jj,jk), e3t(ji,jj,jk) ', ptab(ji,jj,jk), e3t_0(ji,jj,jk)
-                     kindic_agr = kindic_agr + 1
-                  ENDIF
-               END DO
-            END DO
-         END DO
-         !
-      ENDIF
-      ! 
-   END SUBROUTINE interpe3t
-
-
-   SUBROUTINE interpumsk( ptab, i1, i2, j1, j2, k1, k2, before, nb, ndir )
-      !!----------------------------------------------------------------------
-      !!                  ***  ROUTINE interpumsk  ***
-      !!----------------------------------------------------------------------  
-      INTEGER                              , INTENT(in   ) ::   i1, i2, j1, j2, k1, k2
-      REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) ::   ptab
-      LOGICAL                              , INTENT(in   ) ::   before
-      INTEGER                              , INTENT(in   ) ::   nb , ndir
-      !
-      INTEGER ::   ji, jj, jk
-      LOGICAL ::   western_side, eastern_side   
-      !!----------------------------------------------------------------------  
-      !    
-      IF( before ) THEN
-         ptab(i1:i2,j1:j2,k1:k2) = umask(i1:i2,j1:j2,k1:k2)
-      ELSE
-         western_side = (nb == 1).AND.(ndir == 1)
-         eastern_side = (nb == 1).AND.(ndir == 2)
-         DO jk = k1, k2
-            DO jj = j1, j2
-               DO ji = i1, i2
-                   ! Velocity mask at boundary edge points:
-                  IF (ABS(ptab(ji,jj,jk) - umask(ji,jj,jk)) > 1.D-2) THEN
-                     IF (western_side) THEN
-                        WRITE(numout,*) 'ERROR with umask at the western border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk
-                        WRITE(numout,*) '      masks: parent, child ', ptab(ji,jj,jk), umask(ji,jj,jk)
-                        kindic_agr = kindic_agr + 1
-                     ELSEIF (eastern_side) THEN
-                        WRITE(numout,*) 'ERROR with umask at the eastern border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk
-                        WRITE(numout,*) '      masks: parent, child ', ptab(ji,jj,jk), umask(ji,jj,jk)
-                        kindic_agr = kindic_agr + 1
-                     ENDIF
-                  ENDIF
-               END DO
-            END DO
-         END DO
-         !
-      ENDIF
-      ! 
-   END SUBROUTINE interpumsk
-
-
-   SUBROUTINE interpvmsk( ptab, i1, i2, j1, j2, k1, k2, before, nb, ndir )
-      !!----------------------------------------------------------------------
-      !!                  ***  ROUTINE interpvmsk  ***
-      !!----------------------------------------------------------------------  
-      INTEGER                              , INTENT(in   ) ::   i1,i2,j1,j2,k1,k2
-      REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) ::   ptab
-      LOGICAL                              , INTENT(in   ) ::   before
-      INTEGER                              , INTENT(in   ) :: nb , ndir
-      !
-      INTEGER ::   ji, jj, jk
-      LOGICAL ::   northern_side, southern_side     
-      !!----------------------------------------------------------------------  
-      !    
-      IF( before ) THEN
-         ptab(i1:i2,j1:j2,k1:k2) = vmask(i1:i2,j1:j2,k1:k2)
-      ELSE
-         southern_side = (nb == 2).AND.(ndir == 1)
-         northern_side = (nb == 2).AND.(ndir == 2)
-         DO jk = k1, k2
-            DO jj = j1, j2
-               DO ji = i1, i2
-                   ! Velocity mask at boundary edge points:
-                  IF (ABS(ptab(ji,jj,jk) - vmask(ji,jj,jk)) > 1.D-2) THEN
-                     IF (southern_side) THEN
-                        WRITE(numout,*) 'ERROR with vmask at the southern border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk
-                        WRITE(numout,*) '      masks: parent, child ', ptab(ji,jj,jk), vmask(ji,jj,jk)
-                        kindic_agr = kindic_agr + 1
-                     ELSEIF (northern_side) THEN
-                        WRITE(numout,*) 'ERROR with vmask at the northern border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk
-                        WRITE(numout,*) '      masks: parent, child ', ptab(ji,jj,jk), vmask(ji,jj,jk)
-                        kindic_agr = kindic_agr + 1
-                     ENDIF
-                  ENDIF
-               END DO
-            END DO
-         END DO
-         !
-      ENDIF
-      ! 
-   END SUBROUTINE interpvmsk
-
-
-   SUBROUTINE interpavm( ptab, i1, i2, j1, j2, k1, k2, m1, m2, before )
-      !!----------------------------------------------------------------------
-      !!                  ***  ROUTINE interavm  ***
-      !!----------------------------------------------------------------------  
-      INTEGER                                    , INTENT(in   ) ::   i1, i2, j1, j2, k1, k2, m1, m2
-      REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2,m1:m2), INTENT(inout) ::   ptab
-      LOGICAL                                    , INTENT(in   ) ::   before
-      REAL(wp), DIMENSION(k1:k2) :: tabin, h_in
-      REAL(wp), DIMENSION(1:jpk) :: h_out
-      INTEGER  :: N_in, N_out, ji, jj, jk
-      !!----------------------------------------------------------------------  
-      !      
-      IF (before) THEN         
-         DO jk=k1,k2
-            DO jj=j1,j2
-              DO ji=i1,i2
-                    ptab(ji,jj,jk,1) = avm_k(ji,jj,jk)
-              END DO
-           END DO
-        END DO
-#ifdef key_vertical         
-        DO jk=k1,k2
-           DO jj=j1,j2
-              DO ji=i1,i2
-                 ptab(ji,jj,jk,2) = wmask(ji,jj,jk) * e3w_n(ji,jj,jk) 
-              END DO
-           END DO
-        END DO
-#endif
-      ELSE 
-#ifdef key_vertical         
-         avm_k(i1:i2,j1:j2,1:jpk) = 0.
-         DO jj=j1,j2
-            DO ji=i1,i2
-               N_in = 0
-               DO jk=k1,k2 !k2 = jpk of parent grid
-                  IF (ptab(ji,jj,jk,2) == 0) EXIT
-                  N_in = N_in + 1
-                  tabin(jk) = ptab(ji,jj,jk,1)
-                  h_in(N_in) = ptab(ji,jj,jk,2)
-               END DO
-               N_out = 0
-               DO jk=1,jpk ! jpk of child grid
-                  IF (wmask(ji,jj,jk) == 0) EXIT 
-                  N_out = N_out + 1
-                  h_out(jk) = e3t_n(ji,jj,jk)
-               ENDDO
-               IF (N_in > 0) THEN
-                  CALL reconstructandremap(tabin(1:N_in),h_in,avm_k(ji,jj,1:N_out),h_out,N_in,N_out)
-               ENDIF
-            ENDDO
-         ENDDO
-#else
-         avm_k(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2,1)
-#endif
-      ENDIF
-      !
-   END SUBROUTINE interpavm
-
-#else
-   !!----------------------------------------------------------------------
-   !!   Empty module                                          no AGRIF zoom
-   !!----------------------------------------------------------------------
-CONTAINS
-   SUBROUTINE Agrif_OPA_Interp_empty
-      WRITE(*,*)  'agrif_opa_interp : You should not have seen this print! error?'
-   END SUBROUTINE Agrif_OPA_Interp_empty
-#endif
-
-   !!======================================================================
-END MODULE agrif_opa_interp
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/NST_SRC/agrif_opa_sponge.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/NST_SRC/agrif_opa_sponge.F90	(revision 9569)
+++ 	(revision )
@@ -1,619 +1,0 @@
-#define SPONGE && define SPONGE_TOP
-
-MODULE agrif_opa_sponge
-   !!======================================================================
-   !!                   ***  MODULE  agrif_opa_interp  ***
-   !! AGRIF: sponge package for the ocean dynamics (OPA)
-   !!======================================================================
-   !! History :  2.0  !  2002-06  (XXX)  Original cade
-   !!             -   !  2005-11  (XXX) 
-   !!            3.2  !  2009-04  (R. Benshila) 
-   !!            3.6  !  2014-09  (R. Benshila) 
-   !!----------------------------------------------------------------------
-#if defined key_agrif
-   !!----------------------------------------------------------------------
-   !!   'key_agrif'                                              AGRIF zoom
-   !!----------------------------------------------------------------------
-   USE par_oce
-   USE oce
-   USE dom_oce
-   !
-   USE in_out_manager
-   USE agrif_oce
-   USE lbclnk          ! ocean lateral boundary conditions (or mpp link)
-
-   IMPLICIT NONE
-   PRIVATE
-
-   PUBLIC Agrif_Sponge, Agrif_Sponge_Tra, Agrif_Sponge_Dyn
-   PUBLIC interptsn_sponge, interpun_sponge, interpvn_sponge
-
-   !!----------------------------------------------------------------------
-   !! NEMO/NST 4.0 , NEMO Consortium (2017)
-   !! $Id$
-   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
-   !!----------------------------------------------------------------------
-CONTAINS
-
-   SUBROUTINE Agrif_Sponge_Tra
-      !!----------------------------------------------------------------------
-      !!                 *** ROUTINE Agrif_Sponge_Tra ***
-      !!----------------------------------------------------------------------
-      REAL(wp) ::   zcoef   ! local scalar
-      
-      !!----------------------------------------------------------------------
-      !
-#if defined SPONGE
-      !! Assume persistence:
-      zcoef = REAL(Agrif_rhot()-1,wp)/REAL(Agrif_rhot())
-
-      CALL Agrif_Sponge
-      Agrif_SpecialValue    = 0._wp
-      Agrif_UseSpecialValue = .TRUE.
-      tabspongedone_tsn     = .FALSE.
-      !
-      CALL Agrif_Bc_Variable( tsn_sponge_id, calledweight=zcoef, procname=interptsn_sponge )
-      !
-      Agrif_UseSpecialValue = .FALSE.
-#endif
-      !
-   END SUBROUTINE Agrif_Sponge_Tra
-
-
-   SUBROUTINE Agrif_Sponge_dyn
-      !!----------------------------------------------------------------------
-      !!                 *** ROUTINE Agrif_Sponge_dyn ***
-      !!----------------------------------------------------------------------
-      REAL(wp) ::   zcoef   ! local scalar
-      !!----------------------------------------------------------------------
-      !
-#if defined SPONGE
-      zcoef = REAL(Agrif_rhot()-1,wp)/REAL(Agrif_rhot())
-
-      Agrif_SpecialValue=0.
-      Agrif_UseSpecialValue = ln_spc_dyn
-      !
-      tabspongedone_u = .FALSE.
-      tabspongedone_v = .FALSE.         
-      CALL Agrif_Bc_Variable( un_sponge_id, calledweight=zcoef, procname=interpun_sponge )
-      !
-      tabspongedone_u = .FALSE.
-      tabspongedone_v = .FALSE.
-      CALL Agrif_Bc_Variable( vn_sponge_id, calledweight=zcoef, procname=interpvn_sponge )
-      !
-      Agrif_UseSpecialValue = .FALSE.
-#endif
-      !
-   END SUBROUTINE Agrif_Sponge_dyn
-
-
-   SUBROUTINE Agrif_Sponge
-      !!----------------------------------------------------------------------
-      !!                 *** ROUTINE  Agrif_Sponge ***
-      !!----------------------------------------------------------------------
-      INTEGER  ::   ji, jj, ind1, ind2
-      INTEGER  ::   ispongearea
-      REAL(wp) ::   z1_spongearea
-      REAL(wp), DIMENSION(jpi,jpj) :: ztabramp
-      !!----------------------------------------------------------------------
-      !
-#if defined SPONGE || defined SPONGE_TOP
-      IF (( .NOT. spongedoneT ).OR.( .NOT. spongedoneU )) THEN
-         ! Define ramp from boundaries towards domain interior at T-points
-         ! Store it in ztabramp
-
-         ispongearea  = 2 + nn_sponge_len * Agrif_irhox()
-         z1_spongearea = 1._wp / REAL( ispongearea - 1 )
-         
-         ztabramp(:,:) = 0._wp
-
-         ! --- West --- !
-         IF( (nbondi == -1) .OR. (nbondi == 2) ) THEN
-            ind1 = 1+nbghostcells
-            ind2 = 1+nbghostcells + (ispongearea-1)
-            DO jj = 1, jpj
-               DO ji = ind1, ind2                  
-                  ztabramp(ji,jj) = REAL( ind2 - ji ) * z1_spongearea * umask(ind1,jj,1)
-               END DO
-            ENDDO
-         ENDIF
-
-         ! --- East --- !
-         IF( (nbondi == 1) .OR. (nbondi == 2) ) THEN
-            ind1 = nlci - (1+nbghostcells) - (ispongearea-1)
-            ind2 = nlci - (1+nbghostcells)
-            DO jj = 1, jpj
-               DO ji = ind1, ind2
-                  ztabramp(ji,jj) = MAX( ztabramp(ji,jj), REAL( ji - ind2 ) * z1_spongearea * umask(ind2-1,jj,1) )
-               ENDDO
-            ENDDO
-         ENDIF
-
-         ! --- South --- !
-         IF( (nbondj == -1) .OR. (nbondj == 2) ) THEN
-            ind1 = 1+nbghostcells
-            ind2 = 1+nbghostcells + (ispongearea-1)
-            DO jj = ind1, ind2
-               DO ji = 1, jpi
-                  ztabramp(ji,jj) = MAX( ztabramp(ji,jj), REAL( ind2 - jj ) * z1_spongearea * vmask(ji,ind1,1) )
-               END DO
-            ENDDO
-         ENDIF
-
-         ! --- North --- !
-         IF( (nbondj == 1) .OR. (nbondj == 2) ) THEN
-            ind1 = nlcj - (1+nbghostcells) - (ispongearea-1)
-            ind2 = nlcj - (1+nbghostcells)
-            DO jj = ind1, ind2
-               DO ji = 1, jpi
-                  ztabramp(ji,jj) = MAX( ztabramp(ji,jj), REAL( jj - ind2 ) * z1_spongearea * vmask(ji,ind2-1,1) )
-               END DO
-            ENDDO
-         ENDIF
-
-      ENDIF
-
-      ! Tracers
-      IF( .NOT. spongedoneT ) THEN
-         fsaht_spu(:,:) = 0._wp
-         fsaht_spv(:,:) = 0._wp
-         DO jj = 2, jpjm1
-            DO ji = 2, jpim1   ! vector opt.
-               fsaht_spu(ji,jj) = 0.5_wp * visc_tra * ( ztabramp(ji,jj) + ztabramp(ji+1,jj  ) )
-               fsaht_spv(ji,jj) = 0.5_wp * visc_tra * ( ztabramp(ji,jj) + ztabramp(ji  ,jj+1) )
-            END DO
-         END DO
-         CALL lbc_lnk( fsaht_spu, 'U', 1. )   ! Lateral boundary conditions
-         CALL lbc_lnk( fsaht_spv, 'V', 1. )
-         
-         spongedoneT = .TRUE.
-      ENDIF
-
-      ! Dynamics
-      IF( .NOT. spongedoneU ) THEN
-         fsahm_spt(:,:) = 0._wp
-         fsahm_spf(:,:) = 0._wp
-         DO jj = 2, jpjm1
-            DO ji = 2, jpim1   ! vector opt.
-               fsahm_spt(ji,jj) = visc_dyn * ztabramp(ji,jj)
-               fsahm_spf(ji,jj) = 0.25_wp * visc_dyn * ( ztabramp(ji,jj) + ztabramp(ji  ,jj+1) &
-                                                     &  +ztabramp(ji,jj) + ztabramp(ji+1,jj  ) )
-            END DO
-         END DO
-         CALL lbc_lnk( fsahm_spt, 'T', 1. )   ! Lateral boundary conditions
-         CALL lbc_lnk( fsahm_spf, 'F', 1. )
-         
-         spongedoneU = .TRUE.
-      ENDIF
-      !
-#endif
-      !
-   END SUBROUTINE Agrif_Sponge
-
-   SUBROUTINE interptsn_sponge( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before )
-      !!----------------------------------------------------------------------
-      !!                 *** ROUTINE interptsn_sponge ***
-      !!----------------------------------------------------------------------
-      INTEGER                                     , INTENT(in   ) ::   i1, i2, j1, j2, k1, k2, n1, n2
-      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) ::   tabres
-      LOGICAL                                     , INTENT(in   ) ::   before
-      !
-      INTEGER  ::   ji, jj, jk, jn   ! dummy loop indices
-      INTEGER  ::   iku, ikv
-      REAL(wp) :: ztsa, zabe1, zabe2, zbtr
-      REAL(wp), DIMENSION(i1:i2,j1:j2,jpk) :: ztu, ztv
-      REAL(wp), DIMENSION(i1:i2,j1:j2,jpk,n1:n2) ::tsbdiff
-      ! vertical interpolation:
-      REAL(wp), DIMENSION(i1:i2,j1:j2,jpk,n1:n2) ::tabres_child
-      REAL(wp), DIMENSION(k1:k2,n1:n2-1) :: tabin
-      REAL(wp), DIMENSION(k1:k2) :: h_in
-      REAL(wp), DIMENSION(1:jpk) :: h_out
-      INTEGER :: N_in, N_out
-      REAL(wp) :: h_diff
-      !!----------------------------------------------------------------------
-      !
-      IF( before ) THEN
-         DO jn = 1, jpts
-            DO jk=k1,k2
-               DO jj=j1,j2
-                  DO ji=i1,i2
-                     tabres(ji,jj,jk,jn) = tsb(ji,jj,jk,jn)
-                  END DO
-               END DO
-            END DO
-         END DO
-
-# if defined key_vertical
-         DO jk=k1,k2
-            DO jj=j1,j2
-               DO ji=i1,i2
-                  tabres(ji,jj,jk,jpts+1) = tmask(ji,jj,jk) * e3t_n(ji,jj,jk) 
-               END DO
-            END DO
-         END DO
-# endif
-
-      ELSE   
-         !
-# if defined key_vertical
-         tabres_child(:,:,:,:) = 0.
-         DO jj=j1,j2
-            DO ji=i1,i2
-               N_in = 0
-               DO jk=k1,k2 !k2 = jpk of parent grid
-                  IF (tabres(ji,jj,jk,n2) == 0) EXIT
-                  N_in = N_in + 1
-                  tabin(jk,:) = tabres(ji,jj,jk,n1:n2-1)
-                  h_in(N_in) = tabres(ji,jj,jk,n2)
-               END DO
-               N_out = 0
-               DO jk=1,jpk ! jpk of child grid
-                  IF (tmask(ji,jj,jk) == 0) EXIT 
-                  N_out = N_out + 1
-                  h_out(jk) = e3t_n(ji,jj,jk) !Child grid scale factors. Could multiply by e1e2t here instead of division above
-               ENDDO
-               IF (N_in > 0) THEN
-                  h_diff = sum(h_out(1:N_out))-sum(h_in(1:N_in))
-                  tabres(ji,jj,k2,:) = tabres(ji,jj,k2-1,:) !what is this line for?????
-                  DO jn=1,jpts
-                     call reconstructandremap(tabin(1:N_in,jn),h_in,tabres_child(ji,jj,1:N_out,jn),h_out,N_in,N_out)
-                  ENDDO
-               ENDIF
-            ENDDO
-         ENDDO
-# endif
-
-         DO jj=j1,j2
-            DO ji=i1,i2
-               DO jk=1,jpkm1
-# if defined key_vertical
-                  tsbdiff(ji,jj,jk,1:jpts) = tsb(ji,jj,jk,1:jpts) - tabres_child(ji,jj,jk,1:jpts)
-# else
-                  tsbdiff(ji,jj,jk,1:jpts) = tsb(ji,jj,jk,1:jpts) - tabres(ji,jj,jk,1:jpts)
-# endif
-               ENDDO
-            ENDDO
-         ENDDO
-
-         DO jn = 1, jpts            
-            DO jk = 1, jpkm1
-               DO jj = j1,j2-1
-                  DO ji = i1,i2-1
-                     zabe1 = fsaht_spu(ji,jj) * umask(ji,jj,jk) * e2_e1u(ji,jj) * e3u_n(ji,jj,jk)
-                     zabe2 = fsaht_spv(ji,jj) * vmask(ji,jj,jk) * e1_e2v(ji,jj) * e3v_n(ji,jj,jk)
-                     ztu(ji,jj,jk) = zabe1 * ( tsbdiff(ji+1,jj  ,jk,jn) - tsbdiff(ji,jj,jk,jn) ) 
-                     ztv(ji,jj,jk) = zabe2 * ( tsbdiff(ji  ,jj+1,jk,jn) - tsbdiff(ji,jj,jk,jn) )
-                  END DO
-               END DO
-               !
-               IF( ln_zps ) THEN      ! set gradient at partial step level
-                  DO jj = j1,j2-1
-                     DO ji = i1,i2-1
-                        ! last level
-                        iku = mbku(ji,jj)
-                        ikv = mbkv(ji,jj)
-                        IF( iku == jk )   ztu(ji,jj,jk) = 0._wp
-                        IF( ikv == jk )   ztv(ji,jj,jk) = 0._wp
-                     END DO
-                  END DO
-               ENDIF
-            END DO
-            !
-            DO jk = 1, jpkm1
-               DO jj = j1+1,j2-1
-                  DO ji = i1+1,i2-1
-                     IF (.NOT. tabspongedone_tsn(ji,jj)) THEN 
-                        zbtr = r1_e1e2t(ji,jj) / e3t_n(ji,jj,jk)
-                        ! horizontal diffusive trends
-                        ztsa = zbtr * (  ztu(ji,jj,jk) - ztu(ji-1,jj,jk) + ztv(ji,jj,jk) - ztv(ji,jj-1,jk)  )
-                        ! add it to the general tracer trends
-                        tsa(ji,jj,jk,jn) = tsa(ji,jj,jk,jn) + ztsa
-                     ENDIF
-                  END DO
-               END DO
-            END DO
-            !
-         END DO
-         !
-         tabspongedone_tsn(i1+1:i2-1,j1+1:j2-1) = .TRUE.
-         !
-      ENDIF
-      !
-   END SUBROUTINE interptsn_sponge
-
-   SUBROUTINE interpun_sponge(tabres,i1,i2,j1,j2,k1,k2,m1,m2, before)
-      !!---------------------------------------------
-      !!   *** ROUTINE interpun_sponge ***
-      !!---------------------------------------------    
-      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,m1,m2
-      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,m1:m2), INTENT(inout) :: tabres
-      LOGICAL, INTENT(in) :: before
-
-      INTEGER :: ji,jj,jk,jmax
-
-      ! sponge parameters 
-      REAL(wp) :: ze2u, ze1v, zua, zva, zbtr, h_diff
-      REAL(wp), DIMENSION(i1:i2,j1:j2,1:jpk) :: ubdiff
-      REAL(wp), DIMENSION(i1:i2,j1:j2,1:jpk) :: rotdiff, hdivdiff
-      ! vertical interpolation:
-      REAL(wp), DIMENSION(i1:i2,j1:j2,1:jpk) :: tabres_child
-      REAL(wp), DIMENSION(k1:k2) :: tabin, h_in
-      REAL(wp), DIMENSION(1:jpk) :: h_out
-      INTEGER ::N_in,N_out
-      !!---------------------------------------------    
-      !
-      IF( before ) THEN
-         DO jk=1,jpkm1
-            DO jj=j1,j2
-               DO ji=i1,i2
-                  tabres(ji,jj,jk,m1) = ub(ji,jj,jk)
-# if defined key_vertical
-                  tabres(ji,jj,jk,m2) = e3u_n(ji,jj,jk)*umask(ji,jj,jk)
-# endif
-               END DO
-            END DO
-         END DO
-
-      ELSE
-
-# if defined key_vertical
-         tabres_child(:,:,:) = 0._wp
-         DO jj=j1,j2
-            DO ji=i1,i2
-               N_in = 0
-               DO jk=k1,k2
-                  IF (tabres(ji,jj,jk,m2) == 0) EXIT
-                  N_in = N_in + 1
-                  tabin(jk) = tabres(ji,jj,jk,m1)
-                  h_in(N_in) = tabres(ji,jj,jk,m2)
-              ENDDO
-              !
-              IF (N_in == 0) THEN
-                 tabres_child(ji,jj,:) = 0.
-                 CYCLE
-              ENDIF
-         
-              N_out = 0
-              DO jk=1,jpk
-                 if (umask(ji,jj,jk) == 0) EXIT
-                 N_out = N_out + 1
-                 h_out(N_out) = e3u_n(ji,jj,jk)
-              ENDDO
-         
-              IF (N_out == 0) THEN
-                 tabres_child(ji,jj,:) = 0.
-                 CYCLE
-              ENDIF
-         
-              IF (N_in * N_out > 0) THEN
-                 h_diff = sum(h_out(1:N_out))-sum(h_in(1:N_in))
-                 if (h_diff < -1.e4) then
-                    print *,'CHECK YOUR BATHY ...', h_diff, sum(h_out(1:N_out)), sum(h_in(1:N_in))
-                 endif
-              ENDIF
-              call reconstructandremap(tabin(1:N_in),h_in(1:N_in),tabres_child(ji,jj,1:N_out),h_out(1:N_out),N_in,N_out)
-         
-            ENDDO
-         ENDDO
-
-         ubdiff(i1:i2,j1:j2,:) = (ub(i1:i2,j1:j2,:) - tabres_child(i1:i2,j1:j2,:))*umask(i1:i2,j1:j2,:)
-#else
-         ubdiff(i1:i2,j1:j2,:) = (ub(i1:i2,j1:j2,:) - tabres(i1:i2,j1:j2,:,1))*umask(i1:i2,j1:j2,:)
-#endif
-         !
-         DO jk = 1, jpkm1                                 ! Horizontal slab
-            !                                             ! ===============
-
-            !                                             ! --------
-            ! Horizontal divergence                       !   div
-            !                                             ! --------
-            DO jj = j1,j2
-               DO ji = i1+1,i2   ! vector opt.
-                  zbtr = r1_e1e2t(ji,jj) / e3t_n(ji,jj,jk) * fsahm_spt(ji,jj)
-                  hdivdiff(ji,jj,jk) = (  e2u(ji  ,jj)*e3u_n(ji  ,jj,jk) * ubdiff(ji  ,jj,jk) &
-                                     &   -e2u(ji-1,jj)*e3u_n(ji-1,jj,jk) * ubdiff(ji-1,jj,jk) ) * zbtr
-               END DO
-            END DO
-
-            DO jj = j1,j2-1
-               DO ji = i1,i2   ! vector opt.
-                  zbtr = r1_e1e2f(ji,jj) * e3f_n(ji,jj,jk) * fsahm_spf(ji,jj)
-                  rotdiff(ji,jj,jk) = ( -e1u(ji,jj+1) * ubdiff(ji,jj+1,jk)   &
-                                    &   +e1u(ji,jj  ) * ubdiff(ji,jj  ,jk) ) * fmask(ji,jj,jk) * zbtr 
-               END DO
-            END DO
-         END DO
-         !
-         DO jj = j1+1, j2-1
-            DO ji = i1+1, i2-1   ! vector opt.
-
-               IF (.NOT. tabspongedone_u(ji,jj)) THEN
-                  DO jk = 1, jpkm1                                 ! Horizontal slab
-                     ze2u = rotdiff (ji,jj,jk)
-                     ze1v = hdivdiff(ji,jj,jk)
-                     ! horizontal diffusive trends
-                     zua = - ( ze2u - rotdiff (ji,jj-1,jk) ) / ( e2u(ji,jj) * e3u_n(ji,jj,jk) )   &
-                           + ( hdivdiff(ji+1,jj,jk) - ze1v ) * r1_e1u(ji,jj)
-
-                     ! add it to the general momentum trends
-                     ua(ji,jj,jk) = ua(ji,jj,jk) + zua
-
-                  END DO
-               ENDIF
-
-            END DO
-         END DO
-
-         tabspongedone_u(i1+1:i2-1,j1+1:j2-1) = .TRUE.
-
-         jmax = j2-1
-         IF ((nbondj == 1).OR.(nbondj == 2)) jmax = MIN(jmax,nlcj-nbghostcells-2)   ! North
-
-         DO jj = j1+1, jmax
-            DO ji = i1+1, i2   ! vector opt.
-
-               IF (.NOT. tabspongedone_v(ji,jj)) THEN
-                  DO jk = 1, jpkm1                                 ! Horizontal slab
-                     ze2u = rotdiff (ji,jj,jk)
-                     ze1v = hdivdiff(ji,jj,jk)
-
-                     ! horizontal diffusive trends
-                     zva = + ( ze2u - rotdiff (ji-1,jj,jk) ) / ( e1v(ji,jj) * e3v_n(ji,jj,jk) )   &
-                           + ( hdivdiff(ji,jj+1,jk) - ze1v ) * r1_e2v(ji,jj)
-
-                     ! add it to the general momentum trends
-                     va(ji,jj,jk) = va(ji,jj,jk) + zva
-                  END DO
-               ENDIF
-               !
-            END DO
-         END DO
-         !
-         tabspongedone_v(i1+1:i2,j1+1:jmax) = .TRUE.
-         !
-      ENDIF
-      !
-   END SUBROUTINE interpun_sponge
-
-   SUBROUTINE interpvn_sponge(tabres,i1,i2,j1,j2,k1,k2,m1,m2, before,nb,ndir)
-      !!---------------------------------------------
-      !!   *** ROUTINE interpvn_sponge ***
-      !!--------------------------------------------- 
-      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,m1,m2
-      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,m1:m2), INTENT(inout) :: tabres
-      LOGICAL, INTENT(in) :: before
-      INTEGER, INTENT(in) :: nb , ndir
-      !
-      INTEGER  ::   ji, jj, jk, imax
-      REAL(wp) ::   ze2u, ze1v, zua, zva, zbtr, h_diff
-      REAL(wp), DIMENSION(i1:i2,j1:j2,1:jpk) :: vbdiff
-      REAL(wp), DIMENSION(i1:i2,j1:j2,1:jpk) :: rotdiff, hdivdiff
-      ! vertical interpolation:
-      REAL(wp), DIMENSION(i1:i2,j1:j2,1:jpk) :: tabres_child
-      REAL(wp), DIMENSION(k1:k2) :: tabin, h_in
-      REAL(wp), DIMENSION(1:jpk) :: h_out
-      INTEGER :: N_in, N_out
-      !!--------------------------------------------- 
-      
-      IF( before ) THEN 
-         DO jk=1,jpkm1
-            DO jj=j1,j2
-               DO ji=i1,i2
-                  tabres(ji,jj,jk,m1) = vb(ji,jj,jk)
-# if defined key_vertical
-                  tabres(ji,jj,jk,m2) = vmask(ji,jj,jk) * e3v_n(ji,jj,jk)
-# endif
-               END DO
-            END DO
-         END DO
-      ELSE
-
-# if defined key_vertical
-         tabres_child(:,:,:) = 0._wp
-         DO jj=j1,j2
-            DO ji=i1,i2
-               N_in = 0
-               DO jk=k1,k2
-                  IF (tabres(ji,jj,jk,m2) == 0) EXIT
-                  N_in = N_in + 1
-                  tabin(jk) = tabres(ji,jj,jk,m1)
-                  h_in(N_in) = tabres(ji,jj,jk,m2)
-              ENDDO
-         
-              IF (N_in == 0) THEN
-                 tabres_child(ji,jj,:) = 0.
-                 CYCLE
-              ENDIF
-         
-              N_out = 0
-              DO jk=1,jpk
-                 if (vmask(ji,jj,jk) == 0) EXIT
-                 N_out = N_out + 1
-                 h_out(N_out) = e3v_n(ji,jj,jk)
-              ENDDO
-         
-              IF (N_in * N_out > 0) THEN
-                 h_diff = sum(h_out(1:N_out))-sum(h_in(1:N_in))
-                 if (h_diff < -1.e4) then
-                    print *,'CHECK YOUR BATHY ...', h_diff, sum(h_out(1:N_out)), sum(h_in(1:N_in))
-                 endif
-              ENDIF
-              call reconstructandremap(tabin(1:N_in),h_in(1:N_in),tabres_child(ji,jj,1:N_out),h_out(1:N_out),N_in,N_out)
-            ENDDO
-         ENDDO
-
-         vbdiff(i1:i2,j1:j2,:) = (vb(i1:i2,j1:j2,:) - tabres_child(i1:i2,j1:j2,:))*vmask(i1:i2,j1:j2,:)  
-# else
-         vbdiff(i1:i2,j1:j2,:) = (vb(i1:i2,j1:j2,:) - tabres(i1:i2,j1:j2,:,1))*vmask(i1:i2,j1:j2,:)
-# endif
-         !
-         DO jk = 1, jpkm1                                 ! Horizontal slab
-            !                                             ! ===============
-
-            !                                             ! --------
-            ! Horizontal divergence                       !   div
-            !                                             ! --------
-            DO jj = j1+1,j2
-               DO ji = i1,i2   ! vector opt.
-                  zbtr = r1_e1e2t(ji,jj) / e3t_n(ji,jj,jk) * fsahm_spt(ji,jj)
-                  hdivdiff(ji,jj,jk) = ( e1v(ji,jj  ) * e3v_n(ji,jj  ,jk) * vbdiff(ji,jj  ,jk)  &
-                                     &  -e1v(ji,jj-1) * e3v_n(ji,jj-1,jk) * vbdiff(ji,jj-1,jk)  ) * zbtr
-               END DO
-            END DO
-            DO jj = j1,j2
-               DO ji = i1,i2-1   ! vector opt.
-                  zbtr = r1_e1e2f(ji,jj) * e3f_n(ji,jj,jk) * fsahm_spf(ji,jj)
-                  rotdiff(ji,jj,jk) = ( e2v(ji+1,jj) * vbdiff(ji+1,jj,jk) & 
-                                    &  -e2v(ji  ,jj) * vbdiff(ji  ,jj,jk)  ) * fmask(ji,jj,jk) * zbtr
-               END DO
-            END DO
-         END DO
-
-         !                                                ! ===============
-         !                                                
-
-         imax = i2 - 1
-         IF ((nbondi == 1).OR.(nbondi == 2))   imax = MIN(imax,nlci-nbghostcells-2)   ! East
-
-         DO jj = j1+1, j2
-            DO ji = i1+1, imax   ! vector opt.
-               IF( .NOT. tabspongedone_u(ji,jj) ) THEN
-                  DO jk = 1, jpkm1
-                     ua(ji,jj,jk) = ua(ji,jj,jk)                                                               &
-                        & - ( rotdiff (ji  ,jj,jk) - rotdiff (ji,jj-1,jk)) / ( e2u(ji,jj) * e3u_n(ji,jj,jk) )  &
-                        & + ( hdivdiff(ji+1,jj,jk) - hdivdiff(ji,jj  ,jk)) * r1_e1u(ji,jj)
-                  END DO
-               ENDIF
-            END DO
-         END DO
-         !
-         tabspongedone_u(i1+1:imax,j1+1:j2) = .TRUE.
-         !
-         DO jj = j1+1, j2-1
-            DO ji = i1+1, i2-1   ! vector opt.
-               IF( .NOT. tabspongedone_v(ji,jj) ) THEN
-                  DO jk = 1, jpkm1
-                     va(ji,jj,jk) = va(ji,jj,jk)                                                                  &
-                        &  + ( rotdiff (ji,jj  ,jk) - rotdiff (ji-1,jj,jk) ) / ( e1v(ji,jj) * e3v_n(ji,jj,jk) )   &
-                        &  + ( hdivdiff(ji,jj+1,jk) - hdivdiff(ji  ,jj,jk) ) * r1_e2v(ji,jj)
-                  END DO
-               ENDIF
-            END DO
-         END DO
-         tabspongedone_v(i1+1:i2-1,j1+1:j2-1) = .TRUE.
-      ENDIF
-      !
-   END SUBROUTINE interpvn_sponge
-
-#else
-   !!----------------------------------------------------------------------
-   !!   Empty module                                          no AGRIF zoom
-   !!----------------------------------------------------------------------
-CONTAINS
-   SUBROUTINE agrif_opa_sponge_empty
-      WRITE(*,*)  'agrif_opa_sponge : You should not have seen this print! error?'
-   END SUBROUTINE agrif_opa_sponge_empty
-#endif
-
-   !!======================================================================
-END MODULE agrif_opa_sponge
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/NST_SRC/agrif_opa_update.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/NST_SRC/agrif_opa_update.F90	(revision 9569)
+++ 	(revision )
@@ -1,1421 +1,0 @@
-#define TWO_WAY        /* TWO WAY NESTING */
-#undef DECAL_FEEDBACK  /* SEPARATION of INTERFACES*/
-#undef VOL_REFLUX      /* VOLUME REFLUXING*/
- 
-MODULE agrif_opa_update
-   !!======================================================================
-   !!                   ***  MODULE  agrif_opa_interp  ***
-   !! AGRIF: update package for the ocean dynamics (OPA)
-   !!======================================================================
-   !! History :  2.0  !  2002-06  (L. Debreu)  Original code
-   !!            3.2  !  2009-04  (R. Benshila) 
-   !!            3.6  !  2014-09  (R. Benshila) 
-   !!----------------------------------------------------------------------
-#if defined key_agrif 
-   !!----------------------------------------------------------------------
-   !!   'key_agrif'                                              AGRIF zoom
-   !!----------------------------------------------------------------------
-   USE par_oce
-   USE oce
-   USE dom_oce
-   USE zdf_oce        ! vertical physics: ocean variables 
-   USE agrif_oce
-   !
-   USE in_out_manager ! I/O manager
-   USE lib_mpp        ! MPP library
-   USE domvvl         ! Need interpolation routines 
-
-   IMPLICIT NONE
-   PRIVATE
-
-   PUBLIC   Agrif_Update_Tra, Agrif_Update_Dyn, Agrif_Update_vvl, Agrif_Update_ssh
-   PUBLIC   Update_Scales
-
-   !!----------------------------------------------------------------------
-   !! NEMO/NST 4.0 , NEMO Consortium (2017)
-   !! $Id$
-   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
-   !!----------------------------------------------------------------------
-CONTAINS
-
-   SUBROUTINE Agrif_Update_Tra( )
-      !!----------------------------------------------------------------------
-      !!                   *** ROUTINE Agrif_Update_Tra ***
-      !!----------------------------------------------------------------------
-      ! 
-      IF (Agrif_Root()) RETURN
-      !
-#if defined TWO_WAY  
-      IF (lwp.AND.lk_agrif_debug) Write(*,*) 'Update tracers  from grid Number',Agrif_Fixed()
-
-      Agrif_UseSpecialValueInUpdate = .TRUE.
-      Agrif_SpecialValueFineGrid    = 0._wp
-      ! 
-# if ! defined DECAL_FEEDBACK
-      CALL Agrif_Update_Variable(tsn_id, procname=updateTS)
-! near boundary update:
-!      CALL Agrif_Update_Variable(tsn_id,locupdate=(/0,2/), procname=updateTS)
-# else
-      CALL Agrif_Update_Variable(tsn_id, locupdate=(/1,0/),procname=updateTS)
-! near boundary update:
-!      CALL Agrif_Update_Variable(tsn_id,locupdate=(/1,2/), procname=updateTS)
-# endif
-      !
-      Agrif_UseSpecialValueInUpdate = .FALSE.
-      !
-#endif
-      !
-   END SUBROUTINE Agrif_Update_Tra
-
-   SUBROUTINE Agrif_Update_Dyn( )
-      !!----------------------------------------------------------------------
-      !!                   *** ROUTINE Agrif_Update_Dyn ***
-      !!----------------------------------------------------------------------
-      ! 
-      IF (Agrif_Root()) RETURN
-      !
-#if defined TWO_WAY
-      IF (lwp.AND.lk_agrif_debug) Write(*,*) 'Update momentum from grid Number',Agrif_Fixed()
-
-      Agrif_UseSpecialValueInUpdate = .FALSE.
-      Agrif_SpecialValueFineGrid = 0.
-      !     
-# if ! defined DECAL_FEEDBACK
-      CALL Agrif_Update_Variable(un_update_id,procname = updateU)
-      CALL Agrif_Update_Variable(vn_update_id,procname = updateV)
-! near boundary update:
-!      CALL Agrif_Update_Variable(un_update_id,locupdate=(/0,1/),procname = updateU)
-!      CALL Agrif_Update_Variable(vn_update_id,locupdate=(/0,1/),procname = updateV)
-# else
-      CALL Agrif_Update_Variable(un_update_id,locupdate1=(/0,-1/),locupdate2=(/1,-2/),procname = updateU)
-      CALL Agrif_Update_Variable(vn_update_id,locupdate1=(/1,-2/),locupdate2=(/0,-1/),procname = updateV)
-! near boundary update:
-!      CALL Agrif_Update_Variable(un_update_id,locupdate1=(/0,1/),locupdate2=(/1,1/),procname = updateU)
-!      CALL Agrif_Update_Variable(vn_update_id,locupdate1=(/1,1/),locupdate2=(/0,1/),procname = updateV)
-# endif
-
-# if ! defined DECAL_FEEDBACK
-      CALL Agrif_Update_Variable(e1u_id,procname = updateU2d)
-      CALL Agrif_Update_Variable(e2v_id,procname = updateV2d)  
-# else
-      CALL Agrif_Update_Variable(e1u_id,locupdate1=(/0,-1/),locupdate2=(/1,-2/),procname = updateU2d)
-      CALL Agrif_Update_Variable(e2v_id,locupdate1=(/1,-2/),locupdate2=(/0,-1/),procname = updateV2d)  
-# endif
-      !
-# if ! defined DECAL_FEEDBACK
-      ! Account for updated thicknesses at boundary edges
-      IF (.NOT.ln_linssh) THEN
-!         CALL Agrif_Update_Variable(un_update_id,locupdate1=(/0,0/),locupdate2=(/0,0/),procname = correct_u_bdy)
-!         CALL Agrif_Update_Variable(vn_update_id,locupdate1=(/0,0/),locupdate2=(/0,0/),procname = correct_v_bdy)
-      ENDIF
-# endif
-      ! 
-      IF ( ln_dynspg_ts .AND. ln_bt_fw ) THEN
-         ! Update time integrated transports
-#  if ! defined DECAL_FEEDBACK
-         CALL Agrif_Update_Variable(ub2b_update_id,procname = updateub2b)
-         CALL Agrif_Update_Variable(vb2b_update_id,procname = updatevb2b)
-#  else
-         CALL Agrif_Update_Variable(ub2b_update_id,locupdate1=(/0,-1/),locupdate2=(/1,-2/),procname = updateub2b)
-         CALL Agrif_Update_Variable(vb2b_update_id,locupdate1=(/1,-2/),locupdate2=(/0,-1/),procname = updatevb2b)
-#  endif
-      END IF
-#endif
-      !
-   END SUBROUTINE Agrif_Update_Dyn
-
-   SUBROUTINE Agrif_Update_ssh( )
-      !!---------------------------------------------
-      !!   *** ROUTINE Agrif_Update_ssh ***
-      !!---------------------------------------------
-      ! 
-      IF (Agrif_Root()) RETURN
-      !
-#if defined TWO_WAY
-      !
-      Agrif_UseSpecialValueInUpdate = .TRUE.
-      Agrif_SpecialValueFineGrid = 0.
-# if ! defined DECAL_FEEDBACK
-      CALL Agrif_Update_Variable(sshn_id,procname = updateSSH)
-# else
-      CALL Agrif_Update_Variable(sshn_id,locupdate=(/1,0/),procname = updateSSH)
-# endif
-      !
-      Agrif_UseSpecialValueInUpdate = .FALSE.
-      !
-#  if defined DECAL_FEEDBACK && defined VOL_REFLUX
-      IF ( ln_dynspg_ts.AND.ln_bt_fw ) THEN
-         ! Refluxing on ssh:
-         CALL Agrif_Update_Variable(ub2b_update_id,locupdate1=(/0, 0/),locupdate2=(/1, 1/),procname = reflux_sshu)
-         CALL Agrif_Update_Variable(vb2b_update_id,locupdate1=(/1, 1/),locupdate2=(/0, 0/),procname = reflux_sshv)
-      END IF
-#  endif
-      !
-#endif
-      !
-   END SUBROUTINE Agrif_Update_ssh
-
-
-   SUBROUTINE Agrif_Update_Tke( kt )
-      !!---------------------------------------------
-      !!   *** ROUTINE Agrif_Update_Tke ***
-      !!---------------------------------------------
-      !!
-      INTEGER, INTENT(in) :: kt 
-      ! 
-      IF (Agrif_Root()) RETURN
-      !       
-      IF( ( Agrif_NbStepint() .NE. 0 ) .AND. (kt /= 0) ) RETURN
-#  if defined TWO_WAY
-
-      Agrif_UseSpecialValueInUpdate = .TRUE.
-      Agrif_SpecialValueFineGrid = 0.
-
-      CALL Agrif_Update_Variable( en_id, locupdate=(/0,0/), procname=updateEN  )
-      CALL Agrif_Update_Variable(avt_id, locupdate=(/0,0/), procname=updateAVT )
-      CALL Agrif_Update_Variable(avm_id, locupdate=(/0,0/), procname=updateAVM )
-
-      Agrif_UseSpecialValueInUpdate = .FALSE.
-
-#  endif
-      
-   END SUBROUTINE Agrif_Update_Tke
-
-
-   SUBROUTINE Agrif_Update_vvl( )
-      !!---------------------------------------------
-      !!   *** ROUTINE Agrif_Update_vvl ***
-      !!---------------------------------------------
-      !
-      IF (Agrif_Root()) RETURN
-      !
-#if defined TWO_WAY  
-      !
-      IF (lwp.AND.lk_agrif_debug) Write(*,*) 'Update e3 from grid Number',Agrif_Fixed(), 'Step', Agrif_Nb_Step()
-      !
-      Agrif_UseSpecialValueInUpdate = .TRUE.
-      Agrif_SpecialValueFineGrid = 0.
-      ! 
-      ! No interface separation here, update vertical grid at T points 
-      ! everywhere over the overlapping regions (one account for refluxing in that case):
-      CALL Agrif_Update_Variable(e3t_id, procname=updatee3t) 
-      !
-      Agrif_UseSpecialValueInUpdate = .FALSE.
-      !
-      CALL Agrif_ChildGrid_To_ParentGrid()
-      CALL dom_vvl_update_UVF
-      CALL Agrif_ParentGrid_To_ChildGrid()
-      !
-#endif
-      !
-   END SUBROUTINE Agrif_Update_vvl
-
-   SUBROUTINE dom_vvl_update_UVF
-      !!---------------------------------------------
-      !!       *** ROUTINE dom_vvl_update_UVF ***
-      !!---------------------------------------------
-      !!
-      INTEGER :: jk
-      REAL(wp):: zcoef
-      !!---------------------------------------------
-
-      IF (lwp.AND.lk_agrif_debug) Write(*,*) 'Finalize e3 on grid Number', &
-                  & Agrif_Fixed(), 'Step', Agrif_Nb_Step()
-
-      ! Save "old" scale factor (prior update) for subsequent asselin correction
-      ! of prognostic variables
-      ! -----------------------
-      !
-      e3u_a(:,:,:) = e3u_n(:,:,:)
-      e3v_a(:,:,:) = e3v_n(:,:,:)
-!      ua(:,:,:) = e3u_b(:,:,:)
-!      va(:,:,:) = e3v_b(:,:,:)
-      hu_a(:,:) = hu_n(:,:)
-      hv_a(:,:) = hv_n(:,:)
-
-      ! 1) NOW fields
-      !--------------
-      
-         ! Vertical scale factor interpolations
-         ! ------------------------------------
-      CALL dom_vvl_interpol( e3t_n(:,:,:), e3u_n(:,:,:) ,  'U' )
-      CALL dom_vvl_interpol( e3t_n(:,:,:), e3v_n(:,:,:) ,  'V' )
-      CALL dom_vvl_interpol( e3u_n(:,:,:), e3f_n(:,:,:) ,  'F' )
-
-      CALL dom_vvl_interpol( e3u_n(:,:,:), e3uw_n(:,:,:), 'UW' )
-      CALL dom_vvl_interpol( e3v_n(:,:,:), e3vw_n(:,:,:), 'VW' )
-
-         ! Update total depths:
-         ! --------------------
-      hu_n(:,:) = 0._wp                        ! Ocean depth at U-points
-      hv_n(:,:) = 0._wp                        ! Ocean depth at V-points
-      DO jk = 1, jpkm1
-         hu_n(:,:) = hu_n(:,:) + e3u_n(:,:,jk) * umask(:,:,jk)
-         hv_n(:,:) = hv_n(:,:) + e3v_n(:,:,jk) * vmask(:,:,jk)
-      END DO
-      !                                        ! Inverse of the local depth
-      r1_hu_n(:,:) = ssumask(:,:) / ( hu_n(:,:) + 1._wp - ssumask(:,:) )
-      r1_hv_n(:,:) = ssvmask(:,:) / ( hv_n(:,:) + 1._wp - ssvmask(:,:) )
-
-
-      ! 2) BEFORE fields:
-      !------------------
-      IF (.NOT.(lk_agrif_fstep.AND.(neuler==0) )) THEN
-         !
-         ! Vertical scale factor interpolations
-         ! ------------------------------------
-         CALL dom_vvl_interpol( e3t_b(:,:,:), e3u_b(:,:,:),  'U'  )
-         CALL dom_vvl_interpol( e3t_b(:,:,:), e3v_b(:,:,:),  'V'  )
-
-         CALL dom_vvl_interpol( e3u_b(:,:,:), e3uw_b(:,:,:), 'UW' )
-         CALL dom_vvl_interpol( e3v_b(:,:,:), e3vw_b(:,:,:), 'VW' )
-
-         ! Update total depths:
-         ! --------------------
-         hu_b(:,:) = 0._wp                     ! Ocean depth at U-points
-         hv_b(:,:) = 0._wp                     ! Ocean depth at V-points
-         DO jk = 1, jpkm1
-            hu_b(:,:) = hu_b(:,:) + e3u_b(:,:,jk) * umask(:,:,jk)
-            hv_b(:,:) = hv_b(:,:) + e3v_b(:,:,jk) * vmask(:,:,jk)
-         END DO
-         !                                     ! Inverse of the local depth
-         r1_hu_b(:,:) = ssumask(:,:) / ( hu_b(:,:) + 1._wp - ssumask(:,:) )
-         r1_hv_b(:,:) = ssvmask(:,:) / ( hv_b(:,:) + 1._wp - ssvmask(:,:) )
-      ENDIF
-      !
-   END SUBROUTINE dom_vvl_update_UVF
-
-#if defined key_vertical
-
-   SUBROUTINE updateTS( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before )
-      !!----------------------------------------------------------------------
-      !!           *** ROUTINE updateT ***
-      !!---------------------------------------------
-      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2
-      REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres
-      LOGICAL, INTENT(in) :: before
-      !!
-      INTEGER :: ji,jj,jk,jn
-      REAL(wp), DIMENSION(i1:i2,j1:j2,1:jpk,n1:n2) :: tabres_child
-      REAL(wp) :: h_in(k1:k2)
-      REAL(wp) :: h_out(1:jpk)
-      INTEGER  :: N_in, N_out
-      REAL(wp) :: h_diff
-      REAL(wp) :: tabin(k1:k2,n1:n2)
-      !!---------------------------------------------
-      !
-      IF (before) THEN
-         AGRIF_SpecialValue = -999._wp
-         zrho_xy = Agrif_rhox() * Agrif_rhoy() 
-         DO jn = n1,n2-1
-            DO jk=k1,k2
-               DO jj=j1,j2
-                  DO ji=i1,i2
-                     tabres(ji,jj,jk,jn) = (tsn(ji,jj,jk,jn) * e3t_n(ji,jj,jk) ) &
-                                           * tmask(ji,jj,jk) + (tmask(ji,jj,jk)-1)*999._wp
-                  END DO
-               END DO
-            END DO
-         END DO
-         DO jk=k1,k2
-            DO jj=j1,j2
-               DO ji=i1,i2
-                  tabres(ji,jj,jk,n2) = tmask(ji,jj,jk) * e3t_n(ji,jj,jk) &
-                                           + (tmask(ji,jj,jk)-1)*999._wp
-               END DO
-            END DO
-         END DO
-      ELSE
-         tabres_child(:,:,:,:) = 0.
-         AGRIF_SpecialValue = 0._wp
-         DO jj=j1,j2
-            DO ji=i1,i2
-               N_in = 0
-               DO jk=k1,k2 !k2 = jpk of child grid
-                  IF (tabres(ji,jj,jk,n2) == 0  ) EXIT
-                  N_in = N_in + 1
-                  tabin(jk,:) = tabres(ji,jj,jk,n1:n2-1)/tabres(ji,jj,jk,n2)
-                  h_in(N_in) = tabres(ji,jj,jk,n2)
-               ENDDO
-               N_out = 0
-               DO jk=1,jpk ! jpk of parent grid
-                  IF (tmask(ji,jj,jk) < -900) EXIT ! TODO: Will not work with ISF
-                  N_out = N_out + 1
-                  h_out(N_out) = e3t_n(ji,jj,jk) 
-               ENDDO
-               IF (N_in > 0) THEN !Remove this?
-                  h_diff = sum(h_out(1:N_out))-sum(h_in(1:N_in))
-                  IF (h_diff < -1.e-4) THEN
-                     print *,'CHECK YOUR bathy T points ...',ji,jj,h_diff,sum(h_in(1:N_in)),sum(h_out(1:N_out))
-                     print *,h_in(1:N_in)
-                     print *,h_out(1:N_out)
-                     STOP
-                  ENDIF
-                  DO jn=n1,n2-1
-                     CALL reconstructandremap(tabin(1:N_in,jn),h_in(1:N_in),tabres_child(ji,jj,1:N_out,jn),h_out(1:N_out),N_in,N_out)
-                  ENDDO
-               ENDIF
-            ENDDO
-         ENDDO
-
-         IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN
-            ! Add asselin part
-            DO jn = n1,n2-1
-               DO jk=1,jpk
-                  DO jj=j1,j2
-                     DO ji=i1,i2
-                        IF( tabres_child(ji,jj,jk,jn) .NE. 0. ) THEN
-                           tsb(ji,jj,jk,jn) = tsb(ji,jj,jk,jn) & 
-                                 & + atfp * ( tabres_child(ji,jj,jk,jn) &
-                                 &          - tsn(ji,jj,jk,jn) ) * tmask(ji,jj,jk)
-                        ENDIF
-                     ENDDO
-                  ENDDO
-               ENDDO
-            ENDDO
-         ENDIF
-         DO jn = n1,n2-1
-            DO jk=1,jpk
-               DO jj=j1,j2
-                  DO ji=i1,i2
-                     IF( tabres_child(ji,jj,jk,jn) .NE. 0. ) THEN 
-                        tsn(ji,jj,jk,jn) = tabres_child(ji,jj,jk,jn) * tmask(ji,jj,jk)
-                     END IF
-                  END DO
-               END DO
-            END DO
-         END DO
-      ENDIF
-      ! 
-   END SUBROUTINE updateTS
-
-# else
-
-   SUBROUTINE updateTS( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before )
-      !!---------------------------------------------
-      !!           *** ROUTINE updateT ***
-      !!---------------------------------------------
-      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2
-      REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres
-      LOGICAL, INTENT(in) :: before
-      !!
-      INTEGER :: ji,jj,jk,jn
-      REAL(wp) :: ztb, ztnu, ztno
-      !!---------------------------------------------
-      !
-      IF (before) THEN
-         DO jn = 1,jpts
-            DO jk=k1,k2
-               DO jj=j1,j2
-                  DO ji=i1,i2
-!> jc tmp
-                     tabres(ji,jj,jk,jn) = tsn(ji,jj,jk,jn)  * e3t_n(ji,jj,jk) / e3t_0(ji,jj,jk)
-!                     tabres(ji,jj,jk,jn) = tsn(ji,jj,jk,jn)  * e3t_n(ji,jj,jk)
-!< jc tmp
-                  END DO
-               END DO
-            END DO
-         END DO
-      ELSE
-!> jc tmp
-         DO jn = 1,jpts
-            tabres(i1:i2,j1:j2,k1:k2,jn) =  tabres(i1:i2,j1:j2,k1:k2,jn) * e3t_0(i1:i2,j1:j2,k1:k2) &
-                                         & * tmask(i1:i2,j1:j2,k1:k2)
-         ENDDO
-!< jc tmp
-         IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN
-            ! Add asselin part
-            DO jn = 1,jpts
-               DO jk = k1, k2
-                  DO jj = j1, j2
-                     DO ji = i1, i2
-                        IF( tabres(ji,jj,jk,jn) /= 0._wp ) THEN
-                           ztb  = tsb(ji,jj,jk,jn) * e3t_b(ji,jj,jk) ! fse3t_b prior update should be used
-                           ztnu = tabres(ji,jj,jk,jn)
-                           ztno = tsn(ji,jj,jk,jn) * e3t_a(ji,jj,jk)
-                           tsb(ji,jj,jk,jn) = ( ztb + atfp * ( ztnu - ztno) )  & 
-                                     &        * tmask(ji,jj,jk) / e3t_b(ji,jj,jk)
-                        ENDIF
-                     END DO
-                  END DO
-               END DO
-            END DO
-         ENDIF
-         DO jn = 1,jpts
-            DO jk=k1,k2
-               DO jj=j1,j2
-                  DO ji=i1,i2
-                     IF( tabres(ji,jj,jk,jn) /= 0._wp ) THEN 
-                        tsn(ji,jj,jk,jn) = tabres(ji,jj,jk,jn) / e3t_n(ji,jj,jk)
-                     END IF
-                  END DO
-               END DO
-            END DO
-         END DO
-         !
-         IF  ((neuler==0).AND.(Agrif_Nb_Step()==0) ) THEN
-            tsb(i1:i2,j1:j2,k1:k2,1:jpts)  = tsn(i1:i2,j1:j2,k1:k2,1:jpts)
-         ENDIF
-         !
-      ENDIF
-      ! 
-   END SUBROUTINE updateTS
-
-# endif
-
-# if defined key_vertical
-
-   SUBROUTINE updateu( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before )
-      !!---------------------------------------------
-      !!           *** ROUTINE updateu ***
-      !!---------------------------------------------
-      INTEGER                                     , INTENT(in   ) :: i1, i2, j1, j2, k1, k2, n1, n2
-      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres
-      LOGICAL                                     , INTENT(in   ) :: before
-      !
-      INTEGER ::   ji, jj, jk
-      REAL(wp)::   zrhoy
-! VERTICAL REFINEMENT BEGIN
-      REAL(wp), DIMENSION(i1:i2,j1:j2,1:jpk) :: tabres_child
-      REAL(wp) :: h_in(k1:k2)
-      REAL(wp) :: h_out(1:jpk)
-      INTEGER  :: N_in, N_out
-      REAL(wp) :: h_diff, excess, thick
-      REAL(wp) :: tabin(k1:k2)
-! VERTICAL REFINEMENT END
-      !!---------------------------------------------
-      ! 
-      IF( before ) THEN
-         zrhoy = Agrif_Rhoy()
-         AGRIF_SpecialValue = -999._wp
-         DO jk=k1,k2
-            DO jj=j1,j2
-               DO ji=i1,i2
-                  tabres(ji,jj,jk,1) = zrhoy * e2u(ji,jj) * e3u_n(ji,jj,jk) * umask(ji,jj,jk) * un(ji,jj,jk)  &
-                                       + (umask(ji,jj,jk)-1)*999._wp
-                  tabres(ji,jj,jk,2) = zrhoy * umask(ji,jj,jk) * e2u(ji,jj) * e3u_n(ji,jj,jk)  &
-                                       + (umask(ji,jj,jk)-1)*999._wp
-               END DO
-            END DO
-         END DO
-      ELSE
-         tabres_child(:,:,:) = 0.
-         AGRIF_SpecialValue = 0._wp
-         DO jj=j1,j2
-            DO ji=i1,i2
-               N_in = 0
-               h_in(:) = 0._wp
-               tabin(:) = 0._wp
-               DO jk=k1,k2 !k2=jpk of child grid
-                  IF( tabres(ji,jj,jk,2) < -900) EXIT
-                  N_in = N_in + 1
-                  tabin(jk) = tabres(ji,jj,jk,1)/tabres(ji,jj,jk,2)
-                  h_in(N_in) = tabres(ji,jj,jk,2)/e2u(ji,jj)
-               ENDDO
-               N_out = 0
-               DO jk=1,jpk
-                  IF (umask(ji,jj,jk) == 0) EXIT
-                  N_out = N_out + 1
-                  h_out(N_out) = e3u_n(ji,jj,jk)
-               ENDDO
-               IF (N_in * N_out > 0) THEN
-                  h_diff = sum(h_out(1:N_out))-sum(h_in(1:N_in))
-                  IF (h_diff < -1.e-4) THEN
-!Even if bathy at T points match it's possible for the U points to be deeper in the child grid. 
-!In this case we need to move transport from the child grid cells below bed of parent grid into the bottom cell.
-                     excess = 0._wp
-                     DO jk=N_in,1,-1
-                        thick = MIN(-1*h_diff, h_in(jk))
-                        excess = excess + tabin(jk)*thick*e2u(ji,jj)
-                        tabin(jk) = tabin(jk)*(1. - thick/h_in(jk))
-                        h_diff = h_diff + thick
-                        IF ( h_diff == 0) THEN
-                           N_in = jk
-                           h_in(jk) = h_in(jk) - thick
-                           EXIT
-                        ENDIF
-                     ENDDO
-                  ENDIF
-                  CALL reconstructandremap(tabin(1:N_in),h_in(1:N_in),tabres_child(ji,jj,1:N_out),h_out(1:N_out),N_in,N_out)
-                  tabres_child(ji,jj,N_out) = tabres_child(ji,jj,N_out) + excess/(e2u(ji,jj)*h_out(N_out))
-               ENDIF
-            ENDDO
-         ENDDO
-
-         DO jk=1,jpk
-            DO jj=j1,j2
-               DO ji=i1,i2
-                  IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN ! Add asselin part
-                     ub(ji,jj,jk) = ub(ji,jj,jk) & 
-                           & + atfp * ( tabres_child(ji,jj,jk) - un(ji,jj,jk) ) * umask(ji,jj,jk)
-                  ENDIF
-                  !
-                  un(ji,jj,jk) = tabres_child(ji,jj,jk) * umask(ji,jj,jk)
-               END DO
-            END DO
-         END DO
-      ENDIF
-      ! 
-   END SUBROUTINE updateu
-
-#else
-
-   SUBROUTINE updateu( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before )
-      !!---------------------------------------------
-      !!           *** ROUTINE updateu ***
-      !!---------------------------------------------
-      INTEGER                               , INTENT(in   ) :: i1, i2, j1, j2, k1, k2, n1, n2
-      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres
-      LOGICAL                                     , INTENT(in   ) :: before
-      !
-      INTEGER  :: ji, jj, jk
-      REAL(wp) :: zrhoy, zub, zunu, zuno
-      !!---------------------------------------------
-      ! 
-      IF( before ) THEN
-         zrhoy = Agrif_Rhoy()
-         DO jk = k1, k2
-            tabres(i1:i2,j1:j2,jk,1) = zrhoy * e2u(i1:i2,j1:j2) * e3u_n(i1:i2,j1:j2,jk) * un(i1:i2,j1:j2,jk)
-         END DO
-      ELSE
-         DO jk=k1,k2
-            DO jj=j1,j2
-               DO ji=i1,i2
-                  tabres(ji,jj,jk,1) = tabres(ji,jj,jk,1) * r1_e2u(ji,jj) 
-                  !
-                  IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN ! Add asselin part
-                     zub  = ub(ji,jj,jk) * e3u_b(ji,jj,jk)  ! fse3t_b prior update should be used
-                     zuno = un(ji,jj,jk) * e3u_a(ji,jj,jk)
-                     zunu = tabres(ji,jj,jk,1)
-                     ub(ji,jj,jk) = ( zub + atfp * ( zunu - zuno) ) &      
-                                    & * umask(ji,jj,jk) / e3u_b(ji,jj,jk)
-                  ENDIF
-                  !
-                  un(ji,jj,jk) = tabres(ji,jj,jk,1) * umask(ji,jj,jk) / e3u_n(ji,jj,jk)
-               END DO
-            END DO
-         END DO
-         !
-         IF  ((neuler==0).AND.(Agrif_Nb_Step()==0) ) THEN
-            ub(i1:i2,j1:j2,k1:k2)  = un(i1:i2,j1:j2,k1:k2)
-         ENDIF
-         !
-      ENDIF
-      ! 
-   END SUBROUTINE updateu
-
-# endif
-
-   SUBROUTINE correct_u_bdy( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before, nb, ndir )
-      !!---------------------------------------------
-      !!           *** ROUTINE correct_u_bdy ***
-      !!---------------------------------------------
-      INTEGER                                     , INTENT(in   ) :: i1, i2, j1, j2, k1, k2, n1, n2
-      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres
-      LOGICAL                                     , INTENT(in   ) :: before
-      INTEGER                                     , INTENT(in)    :: nb, ndir
-      !!
-      LOGICAL :: western_side, eastern_side 
-      !
-      INTEGER  :: jj, jk
-      REAL(wp) :: zcor
-      !!---------------------------------------------
-      ! 
-      IF( .NOT.before ) THEN
-         !
-         western_side  = (nb == 1).AND.(ndir == 1)
-         eastern_side  = (nb == 1).AND.(ndir == 2)
-         !
-         IF (western_side) THEN
-            DO jj=j1,j2
-               zcor = un_b(i1-1,jj) * hu_a(i1-1,jj) * r1_hu_n(i1-1,jj) - un_b(i1-1,jj)
-               un_b(i1-1,jj) = un_b(i1-1,jj) + zcor
-               DO jk=1,jpkm1
-                  un(i1-1,jj,jk) = un(i1-1,jj,jk) + zcor * umask(i1-1,jj,jk)
-               END DO 
-            END DO
-         ENDIF
-         !
-         IF (eastern_side) THEN
-            DO jj=j1,j2
-               zcor = un_b(i2+1,jj) * hu_a(i2+1,jj) * r1_hu_n(i2+1,jj) - un_b(i2+1,jj)
-               un_b(i2+1,jj) = un_b(i2+1,jj) + zcor
-               DO jk=1,jpkm1
-                  un(i2+1,jj,jk) = un(i2+1,jj,jk) + zcor * umask(i2+1,jj,jk)
-               END DO 
-            END DO
-         ENDIF
-         !
-      ENDIF
-      ! 
-   END SUBROUTINE correct_u_bdy
-
-# if  defined key_vertical
-
-   SUBROUTINE updatev( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before )
-      !!---------------------------------------------
-      !!           *** ROUTINE updatev ***
-      !!---------------------------------------------
-      INTEGER                                     , INTENT(in   ) :: i1, i2, j1, j2, k1, k2, n1, n2
-      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres
-      LOGICAL                                     , INTENT(in   ) :: before
-      !
-      INTEGER  ::   ji, jj, jk
-      REAL(wp) ::   zrhox
-! VERTICAL REFINEMENT BEGIN
-      REAL(wp), DIMENSION(i1:i2,j1:j2,1:jpk) :: tabres_child
-      REAL(wp) :: h_in(k1:k2)
-      REAL(wp) :: h_out(1:jpk)
-      INTEGER :: N_in, N_out
-      REAL(wp) :: h_diff, excess, thick
-      REAL(wp) :: tabin(k1:k2)
-! VERTICAL REFINEMENT END
-      !!---------------------------------------------      
-      !
-      IF( before ) THEN
-         zrhox = Agrif_Rhox()
-         AGRIF_SpecialValue = -999._wp
-         DO jk=k1,k2
-            DO jj=j1,j2
-               DO ji=i1,i2
-                  tabres(ji,jj,jk,1) = zrhox * e1v(ji,jj) * e3v_n(ji,jj,jk) * vmask(ji,jj,jk) * vn(ji,jj,jk) &
-                                       + (vmask(ji,jj,jk)-1)*999._wp
-                  tabres(ji,jj,jk,2) = vmask(ji,jj,jk) * zrhox * e1v(ji,jj) * e3v_n(ji,jj,jk) &
-                                       + (vmask(ji,jj,jk)-1)*999._wp
-               END DO
-            END DO
-         END DO
-      ELSE
-         tabres_child(:,:,:) = 0.
-         AGRIF_SpecialValue = 0._wp
-         DO jj=j1,j2
-            DO ji=i1,i2
-               N_in = 0
-               DO jk=k1,k2
-                  IF (tabres(ji,jj,jk,2) < -900) EXIT
-                  N_in = N_in + 1
-                  tabin(jk) = tabres(ji,jj,jk,1)/tabres(ji,jj,jk,2)
-                  h_in(N_in) = tabres(ji,jj,jk,2)/e1v(ji,jj)
-               ENDDO
-               N_out = 0
-               DO jk=1,jpk
-                  IF (vmask(ji,jj,jk) == 0) EXIT
-                  N_out = N_out + 1
-                  h_out(N_out) = e3v_n(ji,jj,jk)
-               ENDDO
-               IF (N_in * N_out > 0) THEN
-                  h_diff = sum(h_out(1:N_out))-sum(h_in(1:N_in))
-                  IF (h_diff < -1.e-4) then
-!Even if bathy at T points match it's possible for the U points to be deeper in the child grid. 
-!In this case we need to move transport from the child grid cells below bed of parent grid into the bottom cell.
-                     excess = 0._wp
-                     DO jk=N_in,1,-1
-                        thick = MIN(-1*h_diff, h_in(jk))
-                        excess = excess + tabin(jk)*thick*e2u(ji,jj)
-                        tabin(jk) = tabin(jk)*(1. - thick/h_in(jk))
-                        h_diff = h_diff + thick
-                        IF ( h_diff == 0) THEN
-                           N_in = jk
-                           h_in(jk) = h_in(jk) - thick
-                           EXIT
-                        ENDIF
-                     ENDDO
-                  ENDIF
-                  CALL reconstructandremap(tabin(1:N_in),h_in(1:N_in),tabres_child(ji,jj,1:N_out),h_out(1:N_out),N_in,N_out)
-                  tabres_child(ji,jj,N_out) = tabres_child(ji,jj,N_out) + excess/(e1v(ji,jj)*h_out(N_out))
-               ENDIF
-            ENDDO
-         ENDDO
-
-         DO jk=1,jpk
-            DO jj=j1,j2
-               DO ji=i1,i2
-                  !
-                  IF( .NOT.(lk_agrif_fstep.AND.(neuler==0)) ) THEN ! Add asselin part
-                     vb(ji,jj,jk) = vb(ji,jj,jk) & 
-                           & + atfp * ( tabres_child(ji,jj,jk) - vn(ji,jj,jk) ) * vmask(ji,jj,jk)
-                  ENDIF
-                  !
-                  vn(ji,jj,jk) = tabres_child(ji,jj,jk) * vmask(ji,jj,jk)
-               END DO
-            END DO
-         END DO
-      ENDIF
-      ! 
-   END SUBROUTINE updatev
-
-# else
-
-   SUBROUTINE updatev( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before)
-      !!---------------------------------------------
-      !!           *** ROUTINE updatev ***
-      !!---------------------------------------------
-      INTEGER                                     , INTENT(in   ) :: i1, i2, j1, j2, k1, k2, n1, n2
-      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres
-      LOGICAL                                     , INTENT(in   ) :: before
-      !
-      INTEGER  :: ji, jj, jk
-      REAL(wp) :: zrhox, zvb, zvnu, zvno
-      !!---------------------------------------------      
-      !
-      IF (before) THEN
-         zrhox = Agrif_Rhox()
-         DO jk=k1,k2
-            DO jj=j1,j2
-               DO ji=i1,i2
-                  tabres(ji,jj,jk,1) = zrhox * e1v(ji,jj) * e3v_n(ji,jj,jk) * vn(ji,jj,jk)
-               END DO
-            END DO
-         END DO
-      ELSE
-         DO jk=k1,k2
-            DO jj=j1,j2
-               DO ji=i1,i2
-                  tabres(ji,jj,jk,1) = tabres(ji,jj,jk,1) * r1_e1v(ji,jj)
-                  !
-                  IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN ! Add asselin part
-                     zvb  = vb(ji,jj,jk) * e3v_b(ji,jj,jk) ! fse3t_b prior update should be used
-                     zvno = vn(ji,jj,jk) * e3v_a(ji,jj,jk)
-                     zvnu = tabres(ji,jj,jk,1)
-                     vb(ji,jj,jk) = ( zvb + atfp * ( zvnu - zvno) ) &      
-                                    & * vmask(ji,jj,jk) / e3v_b(ji,jj,jk)
-                  ENDIF
-                  !
-                  vn(ji,jj,jk) = tabres(ji,jj,jk,1) * vmask(ji,jj,jk) / e3v_n(ji,jj,jk)
-               END DO
-            END DO
-         END DO
-         !
-         IF  ((neuler==0).AND.(Agrif_Nb_Step()==0) ) THEN
-            vb(i1:i2,j1:j2,k1:k2)  = vn(i1:i2,j1:j2,k1:k2)
-         ENDIF
-         !
-      ENDIF
-      ! 
-   END SUBROUTINE updatev
-
-# endif
-
-   SUBROUTINE correct_v_bdy( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before, nb, ndir )
-      !!---------------------------------------------
-      !!           *** ROUTINE correct_u_bdy ***
-      !!---------------------------------------------
-      INTEGER                                     , INTENT(in   ) :: i1, i2, j1, j2, k1, k2, n1, n2
-      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres
-      LOGICAL                                     , INTENT(in   ) :: before
-      INTEGER                                     , INTENT(in)    :: nb, ndir
-      !!
-      LOGICAL :: southern_side, northern_side 
-      !
-      INTEGER  :: ji, jk
-      REAL(wp) :: zcor
-      !!---------------------------------------------
-      ! 
-      IF( .NOT.before ) THEN
-         !
-         southern_side = (nb == 2).AND.(ndir == 1)
-         northern_side = (nb == 2).AND.(ndir == 2)
-         !
-         IF (southern_side) THEN
-            DO ji=i1,i2
-               zcor = vn_b(ji,j1-1) * hv_a(ji,j1-1) * r1_hv_n(ji,j1-1) - vn_b(ji,j1-1)
-               vn_b(ji,j1-1) = vn_b(ji,j1-1) + zcor
-               DO jk=1,jpkm1
-                  vn(ji,j1-1,jk) = vn(ji,j1-1,jk) + zcor * vmask(ji,j1-1,jk)
-               END DO 
-            END DO
-         ENDIF
-         !
-         IF (northern_side) THEN
-            DO ji=i1,i2
-               zcor = vn_b(ji,j2+1) * hv_a(ji,j2+1) * r1_hv_n(ji,j2+1) - vn_b(ji,j2+1)
-               vn_b(ji,j2+1) = vn_b(ji,j2+1) + zcor
-               DO jk=1,jpkm1
-                  vn(ji,j2+1,jk) = vn(ji,j2+1,jk) + zcor * vmask(ji,j2+1,jk)
-               END DO 
-            END DO
-         ENDIF
-         !
-      ENDIF
-      ! 
-   END SUBROUTINE correct_v_bdy
-
-
-   SUBROUTINE updateu2d( tabres, i1, i2, j1, j2, before )
-      !!----------------------------------------------------------------------
-      !!                      *** ROUTINE updateu2d ***
-      !!----------------------------------------------------------------------
-      INTEGER                         , INTENT(in   ) ::   i1, i2, j1, j2
-      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) ::   tabres
-      LOGICAL                         , INTENT(in   ) ::   before
-      !! 
-      INTEGER  :: ji, jj, jk
-      REAL(wp) :: zrhoy
-      REAL(wp) :: zcorr
-      !!---------------------------------------------
-      !
-      IF( before ) THEN
-         zrhoy = Agrif_Rhoy()
-         DO jj=j1,j2
-            DO ji=i1,i2
-               tabres(ji,jj) = zrhoy * un_b(ji,jj) * hu_n(ji,jj) * e2u(ji,jj)
-            END DO
-         END DO
-      ELSE
-         DO jj=j1,j2
-            DO ji=i1,i2
-               tabres(ji,jj) =  tabres(ji,jj) * r1_e2u(ji,jj)  
-               !    
-               ! Update "now" 3d velocities:
-               spgu(ji,jj) = 0._wp
-               DO jk=1,jpkm1
-                  spgu(ji,jj) = spgu(ji,jj) + e3u_n(ji,jj,jk) * un(ji,jj,jk)
-               END DO
-               !
-               zcorr = (tabres(ji,jj) - spgu(ji,jj)) * r1_hu_n(ji,jj)
-               DO jk=1,jpkm1              
-                  un(ji,jj,jk) = un(ji,jj,jk) + zcorr * umask(ji,jj,jk)           
-               END DO
-               !
-               ! Update barotropic velocities:
-               IF ( .NOT.ln_dynspg_ts .OR. (ln_dynspg_ts.AND.(.NOT.ln_bt_fw)) ) THEN
-                  IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN ! Add asselin part
-                     zcorr = (tabres(ji,jj) - un_b(ji,jj) * hu_a(ji,jj)) * r1_hu_b(ji,jj)
-                     ub_b(ji,jj) = ub_b(ji,jj) + atfp * zcorr * umask(ji,jj,1)
-                  END IF
-               ENDIF    
-               un_b(ji,jj) = tabres(ji,jj) * r1_hu_n(ji,jj) * umask(ji,jj,1)
-               !       
-               ! Correct "before" velocities to hold correct bt component:
-               spgu(ji,jj) = 0.e0
-               DO jk=1,jpkm1
-                  spgu(ji,jj) = spgu(ji,jj) + e3u_b(ji,jj,jk) * ub(ji,jj,jk)
-               END DO
-               !
-               zcorr = ub_b(ji,jj) - spgu(ji,jj) * r1_hu_b(ji,jj)
-               DO jk=1,jpkm1              
-                  ub(ji,jj,jk) = ub(ji,jj,jk) + zcorr * umask(ji,jj,jk)           
-               END DO
-               !
-            END DO
-         END DO
-         !
-         IF  ((neuler==0).AND.(Agrif_Nb_Step()==0) ) THEN
-            ub_b(i1:i2,j1:j2)  = un_b(i1:i2,j1:j2)
-         ENDIF
-      ENDIF
-      !
-   END SUBROUTINE updateu2d
-
-
-   SUBROUTINE updatev2d( tabres, i1, i2, j1, j2, before )
-      !!----------------------------------------------------------------------
-      !!                   *** ROUTINE updatev2d ***
-      !!----------------------------------------------------------------------
-      INTEGER                         , INTENT(in   ) ::   i1, i2, j1, j2
-      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) ::   tabres
-      LOGICAL                         , INTENT(in   ) ::   before
-      ! 
-      INTEGER  :: ji, jj, jk
-      REAL(wp) :: zrhox, zcorr
-      !!----------------------------------------------------------------------
-      !
-      IF( before ) THEN
-         zrhox = Agrif_Rhox()
-         DO jj=j1,j2
-            DO ji=i1,i2
-               tabres(ji,jj) = zrhox * vn_b(ji,jj) * hv_n(ji,jj) * e1v(ji,jj) 
-            END DO
-         END DO
-      ELSE
-         DO jj=j1,j2
-            DO ji=i1,i2
-               tabres(ji,jj) =  tabres(ji,jj) * r1_e1v(ji,jj)  
-               !    
-               ! Update "now" 3d velocities:
-               spgv(ji,jj) = 0.e0
-               DO jk=1,jpkm1
-                  spgv(ji,jj) = spgv(ji,jj) + e3v_n(ji,jj,jk) * vn(ji,jj,jk)
-               END DO
-               !
-               zcorr = (tabres(ji,jj) - spgv(ji,jj)) * r1_hv_n(ji,jj)
-               DO jk=1,jpkm1              
-                  vn(ji,jj,jk) = vn(ji,jj,jk) + zcorr * vmask(ji,jj,jk)           
-               END DO
-               !
-               ! Update barotropic velocities:
-               IF ( .NOT.ln_dynspg_ts .OR. (ln_dynspg_ts.AND.(.NOT.ln_bt_fw)) ) THEN
-                  IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN ! Add asselin part
-                     zcorr = (tabres(ji,jj) - vn_b(ji,jj) * hv_a(ji,jj)) * r1_hv_b(ji,jj)
-                     vb_b(ji,jj) = vb_b(ji,jj) + atfp * zcorr * vmask(ji,jj,1)
-                  END IF
-               ENDIF              
-               vn_b(ji,jj) = tabres(ji,jj) * r1_hv_n(ji,jj) * vmask(ji,jj,1)
-               !       
-               ! Correct "before" velocities to hold correct bt component:
-               spgv(ji,jj) = 0.e0
-               DO jk=1,jpkm1
-                  spgv(ji,jj) = spgv(ji,jj) + e3v_b(ji,jj,jk) * vb(ji,jj,jk)
-               END DO
-               !
-               zcorr = vb_b(ji,jj) - spgv(ji,jj) * r1_hv_b(ji,jj)
-               DO jk=1,jpkm1              
-                  vb(ji,jj,jk) = vb(ji,jj,jk) + zcorr * vmask(ji,jj,jk)           
-               END DO
-               !
-            END DO
-         END DO
-         !
-         IF  ((neuler==0).AND.(Agrif_Nb_Step()==0) ) THEN
-            vb_b(i1:i2,j1:j2)  = vn_b(i1:i2,j1:j2)
-         ENDIF
-         !
-      ENDIF
-      ! 
-   END SUBROUTINE updatev2d
-
-
-   SUBROUTINE updateSSH( tabres, i1, i2, j1, j2, before )
-      !!----------------------------------------------------------------------
-      !!                   *** ROUTINE updateSSH ***
-      !!----------------------------------------------------------------------
-      INTEGER                         , INTENT(in   ) ::   i1, i2, j1, j2
-      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) ::   tabres
-      LOGICAL                         , INTENT(in   ) ::   before
-      !!
-      INTEGER :: ji, jj
-      !!----------------------------------------------------------------------
-      ! 
-      IF( before ) THEN
-         DO jj=j1,j2
-            DO ji=i1,i2
-               tabres(ji,jj) = sshn(ji,jj)
-            END DO
-         END DO
-      ELSE
-         IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN
-            DO jj=j1,j2
-               DO ji=i1,i2
-                  sshb(ji,jj) =   sshb(ji,jj) &
-                        & + atfp * ( tabres(ji,jj) - sshn(ji,jj) ) * tmask(ji,jj,1)
-               END DO
-            END DO
-         ENDIF
-         !
-         DO jj=j1,j2
-            DO ji=i1,i2
-               sshn(ji,jj) = tabres(ji,jj) * tmask(ji,jj,1)
-            END DO
-         END DO
-         !
-         IF  ((neuler==0).AND.(Agrif_Nb_Step()==0) ) THEN
-            sshb(i1:i2,j1:j2)  = sshn(i1:i2,j1:j2)
-         ENDIF
-         !
-
-      ENDIF
-      !
-   END SUBROUTINE updateSSH
-
-
-   SUBROUTINE updateub2b( tabres, i1, i2, j1, j2, before )
-      !!----------------------------------------------------------------------
-      !!                      *** ROUTINE updateub2b ***
-      !!----------------------------------------------------------------------
-      INTEGER                            , INTENT(in) ::   i1, i2, j1, j2
-      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) ::   tabres
-      LOGICAL                            , INTENT(in) ::   before
-      !!
-      INTEGER :: ji, jj
-      REAL(wp) :: zrhoy, za1, zcor
-      !!---------------------------------------------
-      !
-      IF (before) THEN
-         zrhoy = Agrif_Rhoy()
-         DO jj=j1,j2
-            DO ji=i1,i2
-               tabres(ji,jj) = ub2_i_b(ji,jj) * e2u(ji,jj)
-            END DO
-         END DO
-         tabres = zrhoy * tabres
-      ELSE
-         ! 
-         tabres(i1:i2,j1:j2) = tabres(i1:i2,j1:j2) * r1_e2u(i1:i2,j1:j2)
-         !
-         za1 = 1._wp / REAL(Agrif_rhot(), wp)
-         DO jj=j1,j2
-            DO ji=i1,i2
-               zcor=tabres(ji,jj) - ub2_b(ji,jj)
-               ! Update time integrated fluxes also in case of multiply nested grids:
-               ub2_i_b(ji,jj) = ub2_i_b(ji,jj) + za1 * zcor 
-               ! Update corrective fluxes:
-               un_bf(ji,jj)  = un_bf(ji,jj) + zcor
-               ! Update half step back fluxes:
-               ub2_b(ji,jj) = tabres(ji,jj)
-            END DO
-         END DO
-      ENDIF
-      !
-   END SUBROUTINE updateub2b
-
-   SUBROUTINE reflux_sshu( tabres, i1, i2, j1, j2, before, nb, ndir )
-      !!---------------------------------------------
-      !!          *** ROUTINE reflux_sshu ***
-      !!---------------------------------------------
-      INTEGER, INTENT(in) :: i1, i2, j1, j2
-      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres
-      LOGICAL, INTENT(in) :: before
-      INTEGER, INTENT(in) :: nb, ndir
-      !!
-      LOGICAL :: western_side, eastern_side 
-      INTEGER :: ji, jj
-      REAL(wp) :: zrhoy, za1, zcor
-      !!---------------------------------------------
-      !
-      IF (before) THEN
-         zrhoy = Agrif_Rhoy()
-         DO jj=j1,j2
-            DO ji=i1,i2
-               tabres(ji,jj) = ub2_i_b(ji,jj) * e2u(ji,jj)
-            END DO
-         END DO
-         tabres = zrhoy * tabres
-      ELSE
-         ! 
-         tabres(i1:i2,j1:j2) = tabres(i1:i2,j1:j2) * r1_e2u(i1:i2,j1:j2)
-         !
-         western_side  = (nb == 1).AND.(ndir == 1)
-         eastern_side  = (nb == 1).AND.(ndir == 2)
-         !
-         IF (western_side) THEN
-            DO jj=j1,j2
-               zcor = rdt * r1_e1e2t(i1  ,jj) * e2u(i1,jj) * (ub2_b(i1,jj)-tabres(i1,jj)) 
-               sshn(i1  ,jj) = sshn(i1  ,jj) + zcor
-               IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) sshb(i1  ,jj) = sshb(i1  ,jj) + atfp * zcor
-            END DO
-         ENDIF
-         IF (eastern_side) THEN
-            DO jj=j1,j2
-               zcor = - rdt * r1_e1e2t(i2+1,jj) * e2u(i2,jj) * (ub2_b(i2,jj)-tabres(i2,jj))
-               sshn(i2+1,jj) = sshn(i2+1,jj) + zcor
-               IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) sshb(i2+1,jj) = sshb(i2+1,jj) + atfp * zcor
-            END DO
-         ENDIF
-         !
-      ENDIF
-      !
-   END SUBROUTINE reflux_sshu
-
-   SUBROUTINE updatevb2b( tabres, i1, i2, j1, j2, before )
-      !!----------------------------------------------------------------------
-      !!                      *** ROUTINE updatevb2b ***
-      !!----------------------------------------------------------------------
-      INTEGER                         , INTENT(in   ) ::   i1, i2, j1, j2
-      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) ::   tabres
-      LOGICAL                         , INTENT(in   ) ::   before
-      !!
-      INTEGER :: ji, jj
-      REAL(wp) :: zrhox, za1, zcor
-      !!---------------------------------------------
-      !
-      IF( before ) THEN
-         zrhox = Agrif_Rhox()
-         DO jj=j1,j2
-            DO ji=i1,i2
-               tabres(ji,jj) = vb2_i_b(ji,jj) * e1v(ji,jj) 
-            END DO
-         END DO
-         tabres = zrhox * tabres
-      ELSE
-         ! 
-         tabres(i1:i2,j1:j2) = tabres(i1:i2,j1:j2) * r1_e1v(i1:i2,j1:j2)
-         !
-         za1 = 1._wp / REAL(Agrif_rhot(), wp)
-         DO jj=j1,j2
-            DO ji=i1,i2
-               zcor=tabres(ji,jj) - vb2_b(ji,jj)
-               ! Update time integrated fluxes also in case of multiply nested grids:
-               vb2_i_b(ji,jj) = vb2_i_b(ji,jj) + za1 * zcor 
-               ! Update corrective fluxes:
-               vn_bf(ji,jj)  = vn_bf(ji,jj) + zcor
-               ! Update half step back fluxes:
-               vb2_b(ji,jj) = tabres(ji,jj)
-            END DO
-         END DO
-      ENDIF
-      !
-   END SUBROUTINE updatevb2b
-
-   SUBROUTINE reflux_sshv( tabres, i1, i2, j1, j2, before, nb, ndir )
-      !!---------------------------------------------
-      !!          *** ROUTINE reflux_sshv ***
-      !!---------------------------------------------
-      INTEGER, INTENT(in) :: i1, i2, j1, j2
-      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres
-      LOGICAL, INTENT(in) :: before
-      INTEGER, INTENT(in) :: nb, ndir
-      !!
-      LOGICAL :: southern_side, northern_side 
-      INTEGER :: ji, jj
-      REAL(wp) :: zrhox, za1, zcor
-      !!---------------------------------------------
-      !
-      IF (before) THEN
-         zrhox = Agrif_Rhox()
-         DO jj=j1,j2
-            DO ji=i1,i2
-               tabres(ji,jj) = vb2_i_b(ji,jj) * e1v(ji,jj) 
-            END DO
-         END DO
-         tabres = zrhox * tabres
-      ELSE
-         ! 
-         tabres(i1:i2,j1:j2) = tabres(i1:i2,j1:j2) * r1_e1v(i1:i2,j1:j2)
-         !
-         southern_side = (nb == 2).AND.(ndir == 1)
-         northern_side = (nb == 2).AND.(ndir == 2)
-         !
-         IF (southern_side) THEN
-            DO ji=i1,i2
-               zcor = rdt * r1_e1e2t(ji,j1  ) * e1v(ji,j1  ) * (vb2_b(ji,j1)-tabres(ji,j1))
-               sshn(ji,j1  ) = sshn(ji,j1  ) + zcor
-               IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) sshb(ji,j1  ) = sshb(ji,j1) + atfp * zcor
-            END DO
-         ENDIF
-         IF (northern_side) THEN               
-            DO ji=i1,i2
-               zcor = - rdt * r1_e1e2t(ji,j2+1) * e1v(ji,j2  ) * (vb2_b(ji,j2)-tabres(ji,j2))
-               sshn(ji,j2+1) = sshn(ji,j2+1) + zcor
-               IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) sshb(ji,j2+1) = sshb(ji,j2+1) + atfp * zcor
-            END DO
-         ENDIF
-         ! 
-      ENDIF
-      !
-   END SUBROUTINE reflux_sshv
-
-   SUBROUTINE update_scales( tabres, i1, i2, j1, j2, k1, k2, n1,n2, before )
-      !
-      ! ====>>>>>>>>>>    currently not used
-      !
-      !!----------------------------------------------------------------------
-      !!                      *** ROUTINE updateT ***
-      !!----------------------------------------------------------------------
-      INTEGER                                    , INTENT(in   ) ::   i1, i2, j1, j2, k1, k2, n1, n2
-      REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) ::   tabres
-      LOGICAL                                    , INTENT(in   ) ::   before
-      !!
-      INTEGER :: ji,jj,jk
-      REAL(wp) :: ztemp
-      !!----------------------------------------------------------------------
-
-      IF (before) THEN
-         DO jk=k1,k2
-            DO jj=j1,j2
-               DO ji=i1,i2
-                  tabres(ji,jj,jk,1) = e1t(ji,jj)*e2t(ji,jj)*tmask(ji,jj,jk)
-                  tabres(ji,jj,jk,2) = e1t(ji,jj)*tmask(ji,jj,jk)
-                  tabres(ji,jj,jk,3) = e2t(ji,jj)*tmask(ji,jj,jk)
-               END DO
-            END DO
-         END DO
-         tabres(:,:,:,1)=tabres(:,:,:,1)*Agrif_Rhox()*Agrif_Rhoy()
-         tabres(:,:,:,2)=tabres(:,:,:,2)*Agrif_Rhox()
-         tabres(:,:,:,3)=tabres(:,:,:,3)*Agrif_Rhoy()
-      ELSE
-         DO jk=k1,k2
-            DO jj=j1,j2
-               DO ji=i1,i2
-                  IF( tabres(ji,jj,jk,1) .NE. 0. ) THEN 
-                     print *,'VAL = ',ji,jj,jk,tabres(ji,jj,jk,1),e1t(ji,jj)*e2t(ji,jj)*tmask(ji,jj,jk)
-                     print *,'VAL2 = ',ji,jj,jk,tabres(ji,jj,jk,2),e1t(ji,jj)*tmask(ji,jj,jk)
-                     print *,'VAL3 = ',ji,jj,jk,tabres(ji,jj,jk,3),e2t(ji,jj)*tmask(ji,jj,jk)
-                     ztemp = sqrt(tabres(ji,jj,jk,1)/(tabres(ji,jj,jk,2)*tabres(ji,jj,jk,3)))
-                     print *,'CORR = ',ztemp-1.
-                     print *,'NEW VALS = ',tabres(ji,jj,jk,2)*ztemp,tabres(ji,jj,jk,3)*ztemp, &
-                           tabres(ji,jj,jk,2)*ztemp*tabres(ji,jj,jk,3)*ztemp
-                     e1t(ji,jj) = tabres(ji,jj,jk,2)*ztemp
-                     e2t(ji,jj) = tabres(ji,jj,jk,3)*ztemp
-                  END IF
-               END DO
-            END DO
-         END DO
-      ENDIF
-      !
-   END SUBROUTINE update_scales
-
-
-   SUBROUTINE updateEN( ptab, i1, i2, j1, j2, k1, k2, before )
-      !!----------------------------------------------------------------------
-      !!                      *** ROUTINE updateen ***
-      !!----------------------------------------------------------------------
-      INTEGER                               , INTENT(in   ) ::   i1, i2, j1, j2, k1, k2
-      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) ::   ptab
-      LOGICAL                               , INTENT(in   ) ::   before
-      !!----------------------------------------------------------------------
-      !
-      IF( before ) THEN
-         ptab (i1:i2,j1:j2,k1:k2) = en(i1:i2,j1:j2,k1:k2)
-      ELSE
-         en(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2) 
-      ENDIF
-      !
-   END SUBROUTINE updateEN
-
-
-   SUBROUTINE updateAVT( ptab, i1, i2, j1, j2, k1, k2, before )
-      !!----------------------------------------------------------------------
-      !!                      *** ROUTINE updateavt ***
-      !!----------------------------------------------------------------------
-      INTEGER                               , INTENT(in   ) ::   i1, i2, j1, j2, k1, k2
-      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) ::   ptab
-      LOGICAL                               , INTENT(in   ) ::   before
-      !!----------------------------------------------------------------------
-      !
-      IF( before ) THEN   ;   ptab (i1:i2,j1:j2,k1:k2) = avt_k(i1:i2,j1:j2,k1:k2)
-      ELSE                ;   avt_k(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2) 
-      ENDIF
-      !
-   END SUBROUTINE updateAVT
-
-
-   SUBROUTINE updateAVM( ptab, i1, i2, j1, j2, k1, k2, before )
-      !!---------------------------------------------
-      !!           *** ROUTINE updateavm ***
-      !!----------------------------------------------------------------------
-      INTEGER                               , INTENT(in   ) ::   i1, i2, j1, j2, k1, k2
-      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) ::   ptab
-      LOGICAL                               , INTENT(in   ) ::   before
-      !!----------------------------------------------------------------------
-      !
-      IF( before ) THEN   ;   ptab (i1:i2,j1:j2,k1:k2) = avm_k(i1:i2,j1:j2,k1:k2)
-      ELSE                ;   avm_k(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2) 
-      ENDIF
-      !
-   END SUBROUTINE updateAVM
-
-   SUBROUTINE updatee3t(ptab_dum, i1, i2, j1, j2, k1, k2, before )
-      !!---------------------------------------------
-      !!           *** ROUTINE updatee3t ***
-      !!---------------------------------------------
-      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2) :: ptab_dum
-      INTEGER, INTENT(in) :: i1, i2, j1, j2, k1, k2
-      LOGICAL, INTENT(in) :: before
-      !
-      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: ptab
-      INTEGER :: ji,jj,jk
-      REAL(wp) :: zcoef
-      !!---------------------------------------------
-      !
-      IF (.NOT.before) THEN
-         !
-         ALLOCATE(ptab(i1:i2,j1:j2,1:jpk)) 
-         !
-         ! Update e3t from ssh (z* case only)
-         DO jk = 1, jpkm1
-            DO jj=j1,j2
-               DO ji=i1,i2
-                  ptab(ji,jj,jk) = e3t_0(ji,jj,jk) * (1._wp + sshn(ji,jj) &
-                                     & *ssmask(ji,jj)/(ht_0(ji,jj)-1._wp + ssmask(ji,jj)))
-               END DO
-            END DO
-         END DO
-         !
-         ! 1) Updates at BEFORE time step:
-         ! -------------------------------
-         !
-         ! Save "old" scale factor (prior update) for subsequent asselin correction
-         ! of prognostic variables
-         e3t_a(i1:i2,j1:j2,1:jpkm1) = e3t_n(i1:i2,j1:j2,1:jpkm1)
-
-         ! One should also save e3t_b, but lacking of workspace...
-!         hdivn(i1:i2,j1:j2,1:jpkm1)   = e3t_b(i1:i2,j1:j2,1:jpkm1)
-
-         IF (.NOT.(lk_agrif_fstep.AND.(neuler==0) )) THEN
-            DO jk = 1, jpkm1
-               DO jj=j1,j2
-                  DO ji=i1,i2
-                     e3t_b(ji,jj,jk) =  e3t_b(ji,jj,jk) &
-                           & + atfp * ( ptab(ji,jj,jk) - e3t_n(ji,jj,jk) )
-                  END DO
-               END DO
-            END DO
-            !
-            e3w_b  (i1:i2,j1:j2,1) = e3w_0(i1:i2,j1:j2,1) + e3t_b(i1:i2,j1:j2,1) - e3t_0(i1:i2,j1:j2,1)
-            gdepw_b(i1:i2,j1:j2,1) = 0.0_wp
-            gdept_b(i1:i2,j1:j2,1) = 0.5_wp * e3w_b(i1:i2,j1:j2,1)
-            !
-            DO jk = 2, jpk
-               DO jj = j1,j2
-                  DO ji = i1,i2            
-                     zcoef = (tmask(ji,jj,jk) - wmask(ji,jj,jk))
-                     e3w_b(ji,jj,jk)  = e3w_0(ji,jj,jk) + ( 1.0_wp - 0.5_wp * tmask(ji,jj,jk) ) *        & 
-                     &                                        ( e3t_b(ji,jj,jk-1) - e3t_0(ji,jj,jk-1) )  &
-                     &                                  +            0.5_wp * tmask(ji,jj,jk)   *        &
-                     &                                        ( e3t_b(ji,jj,jk  ) - e3t_0(ji,jj,jk  ) )
-                     gdepw_b(ji,jj,jk) = gdepw_b(ji,jj,jk-1) + e3t_b(ji,jj,jk-1)
-                     gdept_b(ji,jj,jk) =      zcoef  * ( gdepw_b(ji,jj,jk  ) + 0.5 * e3w_b(ji,jj,jk))  &
-                         &               + (1-zcoef) * ( gdept_b(ji,jj,jk-1) +       e3w_b(ji,jj,jk)) 
-                  END DO
-               END DO
-            END DO
-            !
-         ENDIF        
-         !
-         ! 2) Updates at NOW time step:
-         ! ----------------------------
-         !
-         ! Update vertical scale factor at T-points:
-         e3t_n(i1:i2,j1:j2,1:jpkm1) = ptab(i1:i2,j1:j2,1:jpkm1)
-         !
-         ! Update total depth:
-         ht_n(i1:i2,j1:j2) = 0._wp
-         DO jk = 1, jpkm1
-            ht_n(i1:i2,j1:j2) = ht_n(i1:i2,j1:j2) + e3t_n(i1:i2,j1:j2,jk) * tmask(i1:i2,j1:j2,jk)
-         END DO
-         !
-         ! Update vertical scale factor at W-points and depths:
-         e3w_n (i1:i2,j1:j2,1) = e3w_0(i1:i2,j1:j2,1) + e3t_n(i1:i2,j1:j2,1) - e3t_0(i1:i2,j1:j2,1)
-         gdept_n(i1:i2,j1:j2,1) = 0.5_wp * e3w_n(i1:i2,j1:j2,1)
-         gdepw_n(i1:i2,j1:j2,1) = 0.0_wp
-         gde3w_n(i1:i2,j1:j2,1) = gdept_n(i1:i2,j1:j2,1) - (ht_n(i1:i2,j1:j2)-ht_0(i1:i2,j1:j2)) ! Last term in the rhs is ssh
-         !
-         DO jk = 2, jpk
-            DO jj = j1,j2
-               DO ji = i1,i2            
-               zcoef = (tmask(ji,jj,jk) - wmask(ji,jj,jk))
-               e3w_n(ji,jj,jk)  = e3w_0(ji,jj,jk) + ( 1.0_wp - 0.5_wp * tmask(ji,jj,jk) ) * ( e3t_n(ji,jj,jk-1) - e3t_0(ji,jj,jk-1) )   &
-               &                                  +            0.5_wp * tmask(ji,jj,jk)   * ( e3t_n(ji,jj,jk  ) - e3t_0(ji,jj,jk  ) )
-               gdepw_n(ji,jj,jk) = gdepw_n(ji,jj,jk-1) + e3t_n(ji,jj,jk-1)
-               gdept_n(ji,jj,jk) =      zcoef  * ( gdepw_n(ji,jj,jk  ) + 0.5 * e3w_n(ji,jj,jk))  &
-                   &               + (1-zcoef) * ( gdept_n(ji,jj,jk-1) +       e3w_n(ji,jj,jk)) 
-               gde3w_n(ji,jj,jk) = gdept_n(ji,jj,jk) - (ht_n(ji,jj)-ht_0(ji,jj)) ! Last term in the rhs is ssh
-               END DO
-            END DO
-         END DO
-         !
-         IF  ((neuler==0).AND.(Agrif_Nb_Step()==0) ) THEN
-            e3t_b (i1:i2,j1:j2,1:jpk)  = e3t_n (i1:i2,j1:j2,1:jpk)
-            e3w_b (i1:i2,j1:j2,1:jpk)  = e3w_n (i1:i2,j1:j2,1:jpk)
-            gdepw_b(i1:i2,j1:j2,1:jpk) = gdepw_n(i1:i2,j1:j2,1:jpk)
-            gdept_b(i1:i2,j1:j2,1:jpk) = gdept_n(i1:i2,j1:j2,1:jpk)
-         ENDIF
-         !
-         DEALLOCATE(ptab)
-      ENDIF
-      !
-   END SUBROUTINE updatee3t
-
-#else
-   !!----------------------------------------------------------------------
-   !!   Empty module                                          no AGRIF zoom
-   !!----------------------------------------------------------------------
-CONTAINS
-   SUBROUTINE agrif_opa_update_empty
-      WRITE(*,*)  'agrif_opa_update : You should not have seen this print! error?'
-   END SUBROUTINE agrif_opa_update_empty
-#endif
-
-   !!======================================================================
-END MODULE agrif_opa_update
-
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/NST_SRC/agrif_si3_interp.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/NST_SRC/agrif_si3_interp.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/NST_SRC/agrif_si3_interp.F90	(revision 9570)
@@ -0,0 +1,379 @@
+MODULE agrif_si3_interp
+   !!=====================================================================================
+   !!                       ***  MODULE agrif_si3_interp ***
+   !! Nesting module :  interp surface ice boundary condition from a parent grid
+   !! Sea-Ice model  :  LIM 3.6 Sea ice model time-stepping
+   !!=====================================================================================
+   !! History :  2.0   !  04-2008  (F. Dupont)  initial version
+   !!            3.4   !  09-2012  (R. Benshila, C. Herbaut) update and EVP
+   !!            3.6   !  05-2016  (C. Rousset)  Add LIM3 compatibility
+   !!----------------------------------------------------------------------
+#if defined key_agrif && defined key_si3 
+   !!----------------------------------------------------------------------
+   !!   'key_si3'  :                                 LIM 3.6 sea-ice model
+   !!   'key_agrif' :                                 AGRIF library
+   !!----------------------------------------------------------------------
+   !!  agrif_interp_si3    : interpolation of ice at "after" sea-ice time step
+   !!  agrif_interp_u_ice   : atomic routine to interpolate u_ice 
+   !!  agrif_interp_v_ice   : atomic routine to interpolate v_ice 
+   !!  agrif_interp_tra_ice : atomic routine to interpolate ice properties 
+   !!----------------------------------------------------------------------
+   USE par_oce
+   USE dom_oce
+   USE sbc_oce
+   USE ice
+   USE agrif_ice
+   USE phycst , ONLY: rt0
+   
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   agrif_interp_si3   ! called by agrif_user.F90
+
+   !!----------------------------------------------------------------------
+   !! NEMO/NST 3.6 , NEMO Consortium (2016)
+   !! $Id: agrif_si3_interp.F90 6204 2016-01-04 13:47:06Z cetlod $
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+
+CONTAINS
+
+   SUBROUTINE agrif_interp_si3( cd_type, kiter, kitermax )
+      !!-----------------------------------------------------------------------
+      !!                 *** ROUTINE agrif_rhg_lim3  ***
+      !!
+      !!  ** Method  : simple call to atomic routines using stored values to
+      !!  fill the boundaries depending of the position of the point and
+      !!  computing factor for time interpolation
+      !!-----------------------------------------------------------------------
+      CHARACTER(len=1), INTENT(in   )           ::   cd_type
+      INTEGER         , INTENT(in   ), OPTIONAL ::   kiter, kitermax
+      !!
+      REAL(wp) ::   zbeta   ! local scalar
+      !!-----------------------------------------------------------------------
+      !
+      IF( Agrif_Root() .OR. nn_ice==0 )  RETURN   ! do not interpolate if inside Parent Grid or if child domain does not have ice
+      !
+      SELECT CASE( cd_type )
+      CASE('U','V')
+         IF( PRESENT( kiter ) ) THEN  ! interpolation at the child ice sub-time step (only for ice rheology)
+            zbeta = ( REAL(lim_nbstep) - REAL(kitermax - kiter) / REAL(kitermax) ) /  &
+               &    ( Agrif_Rhot() * REAL(Agrif_Parent(nn_fsbc)) / REAL(nn_fsbc) )
+         ELSE                         ! interpolation at the child ice time step
+            zbeta = REAL(lim_nbstep) / ( Agrif_Rhot() * REAL(Agrif_Parent(nn_fsbc)) / REAL(nn_fsbc) )
+         ENDIF
+      CASE('T')
+            zbeta = REAL(lim_nbstep) / ( Agrif_Rhot() * REAL(Agrif_Parent(nn_fsbc)) / REAL(nn_fsbc) )
+      END SELECT
+      !
+      Agrif_SpecialValue    = -9999.
+      Agrif_UseSpecialValue = .TRUE.
+      SELECT CASE( cd_type )
+      CASE('U')   ;   CALL Agrif_Bc_variable( u_ice_id  , procname=interp_u_ice  , calledweight=zbeta )
+      CASE('V')   ;   CALL Agrif_Bc_variable( v_ice_id  , procname=interp_v_ice  , calledweight=zbeta )
+      CASE('T')   ;   CALL Agrif_Bc_variable( tra_ice_id, procname=interp_tra_ice, calledweight=zbeta )
+      END SELECT
+      Agrif_SpecialValue    = 0._wp
+      Agrif_UseSpecialValue = .FALSE.
+      !
+   END SUBROUTINE agrif_interp_si3
+
+
+   SUBROUTINE interp_u_ice( ptab, i1, i2, j1, j2, before )
+      !!-----------------------------------------------------------------------
+      !!                     *** ROUTINE interp_u_ice ***
+      !!
+      !! i1 i2 j1 j2 are the index of the boundaries parent(when before) and child (when after)
+      !! To solve issues when parent grid is "land" masked but not all the corresponding child 
+      !! grid points, put Agrif_SpecialValue WHERE the parent grid is masked. 
+      !! The child solution will be found in the 9(?) points around
+      !!-----------------------------------------------------------------------
+      INTEGER                         , INTENT(in   ) ::   i1, i2, j1, j2
+      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) ::   ptab
+      LOGICAL                         , INTENT(in   ) ::   before
+      !!
+      REAL(wp) ::   zrhoy   ! local scalar
+      !!-----------------------------------------------------------------------
+      !
+      IF( before ) THEN  ! parent grid
+         ptab(:,:) = e2u(i1:i2,j1:j2) * u_ice(i1:i2,j1:j2)
+         WHERE( umask(i1:i2,j1:j2,1) == 0. )   ptab(i1:i2,j1:j2) = Agrif_SpecialValue
+      ELSE               ! child grid
+         zrhoy = Agrif_Rhoy()
+         u_ice(i1:i2,j1:j2) = ptab(i1:i2,j1:j2) / ( e2u(i1:i2,j1:j2) * zrhoy ) * umask(i1:i2,j1:j2,1)
+      ENDIF
+      !
+   END SUBROUTINE interp_u_ice
+
+
+   SUBROUTINE interp_v_ice( ptab, i1, i2, j1, j2, before )
+      !!-----------------------------------------------------------------------
+      !!                    *** ROUTINE interp_v_ice ***
+      !!
+      !! i1 i2 j1 j2 are the index of the boundaries parent(when before) and child (when after)
+      !! To solve issues when parent grid is "land" masked but not all the corresponding child 
+      !! grid points, put Agrif_SpecialValue WHERE the parent grid is masked. 
+      !! The child solution will be found in the 9(?) points around
+      !!-----------------------------------------------------------------------      
+      INTEGER                         , INTENT(in   ) ::   i1, i2, j1, j2
+      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) ::   ptab
+      LOGICAL                         , INTENT(in   ) ::   before
+      !!
+      REAL(wp) ::   zrhox   ! local scalar
+      !!-----------------------------------------------------------------------
+      !
+      IF( before ) THEN  ! parent grid
+         ptab(:,:) = e1v(i1:i2,j1:j2) * v_ice(i1:i2,j1:j2)
+         WHERE( vmask(i1:i2,j1:j2,1) == 0. )   ptab(i1:i2,j1:j2) = Agrif_SpecialValue
+      ELSE               ! child grid
+         zrhox = Agrif_Rhox()
+         v_ice(i1:i2,j1:j2) = ptab(i1:i2,j1:j2) / ( e1v(i1:i2,j1:j2) * zrhox ) * vmask(i1:i2,j1:j2,1)
+      ENDIF
+      !
+   END SUBROUTINE interp_v_ice
+
+
+   SUBROUTINE interp_tra_ice( ptab, i1, i2, j1, j2, k1, k2, before, nb, ndir )
+      !!-----------------------------------------------------------------------
+      !!                    *** ROUTINE interp_tra_ice ***                           
+      !!
+      !! i1 i2 j1 j2 are the index of the boundaries parent(when before) and child (when after)
+      !! To solve issues when parent grid is "land" masked but not all the corresponding child 
+      !! grid points, put Agrif_SpecialValue WHERE the parent grid is masked. 
+      !! The child solution will be found in the 9(?) points around
+      !!-----------------------------------------------------------------------
+      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) ::   ptab
+      INTEGER                               , INTENT(in   ) ::   i1, i2, j1, j2, k1, k2
+      LOGICAL                               , INTENT(in   ) ::   before
+      INTEGER                               , INTENT(in   ) ::   nb, ndir
+      !!
+      INTEGER  ::   ji, jj, jk, jl, jm
+      INTEGER  ::   imin, imax, jmin, jmax
+      LOGICAL  ::   western_side, eastern_side, northern_side, southern_side
+      REAL(wp) ::   zrhox, z1, z2, z3, z4, z5, z6, z7
+      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::   ztab
+      !!-----------------------------------------------------------------------
+      ! tracers are not multiplied by grid cell here => before: * e1e2t ; after: * r1_e1e2t / rhox / rhoy
+      ! and it is ok since we conserve tracers (same as in the ocean).
+      ALLOCATE( ztab(SIZE(a_i,1),SIZE(a_i,2),SIZE(ptab,3)) )
+     
+      IF( before ) THEN  ! parent grid
+         jm = 1
+         DO jl = 1, jpl
+            ptab(i1:i2,j1:j2,jm  ) = a_i (i1:i2,j1:j2,jl)
+            ptab(i1:i2,j1:j2,jm+1) = v_i (i1:i2,j1:j2,jl)
+            ptab(i1:i2,j1:j2,jm+2) = v_s (i1:i2,j1:j2,jl)
+            ptab(i1:i2,j1:j2,jm+3) = sv_i(i1:i2,j1:j2,jl)
+            ptab(i1:i2,j1:j2,jm+4) = oa_i(i1:i2,j1:j2,jl)
+            ptab(i1:i2,j1:j2,jm+5) = a_ip(i1:i2,j1:j2,jl)
+            ptab(i1:i2,j1:j2,jm+6) = v_ip(i1:i2,j1:j2,jl)
+            ptab(i1:i2,j1:j2,jm+7) = t_su(i1:i2,j1:j2,jl)
+            jm = jm + 8
+            DO jk = 1, nlay_s
+               ptab(i1:i2,j1:j2,jm) = e_s(i1:i2,j1:j2,jk,jl)   ;   jm = jm + 1
+            END DO
+            DO jk = 1, nlay_i
+               ptab(i1:i2,j1:j2,jm) = e_i(i1:i2,j1:j2,jk,jl)   ;   jm = jm + 1
+            END DO
+         END DO
+         
+         DO jk = k1, k2
+            WHERE( tmask(i1:i2,j1:j2,1) == 0._wp )   ptab(i1:i2,j1:j2,jk) = Agrif_SpecialValue
+         END DO
+         !
+      ELSE               ! child grid
+         !
+!         IF( nbghostcells > 1 ) THEN   ! ==> The easiest interpolation is used
+            !
+            jm = 1
+            DO jl = 1, jpl
+               !
+               DO jj = j1, j2
+                  DO ji = i1, i2
+                     a_i (ji,jj,jl) = ptab(ji,jj,jm  ) * tmask(ji,jj,1)
+                     v_i (ji,jj,jl) = ptab(ji,jj,jm+1) * tmask(ji,jj,1)
+                     v_s (ji,jj,jl) = ptab(ji,jj,jm+2) * tmask(ji,jj,1)
+                     sv_i(ji,jj,jl) = ptab(ji,jj,jm+3) * tmask(ji,jj,1)
+                     oa_i(ji,jj,jl) = ptab(ji,jj,jm+4) * tmask(ji,jj,1)
+                     a_ip(ji,jj,jl) = ptab(ji,jj,jm+5) * tmask(ji,jj,1)
+                     v_ip(ji,jj,jl) = ptab(ji,jj,jm+6) * tmask(ji,jj,1)
+                     t_su(ji,jj,jl) = ptab(ji,jj,jm+7) * tmask(ji,jj,1)
+                  END DO
+               END DO
+               jm = jm + 8
+               !
+               DO jk = 1, nlay_s
+                  e_s(i1:i2,j1:j2,jk,jl) = ptab(i1:i2,j1:j2,jm) * tmask(i1:i2,j1:j2,1)
+                  jm = jm + 1
+               END DO
+               !
+               DO jk = 1, nlay_i
+                  e_i(i1:i2,j1:j2,jk,jl) = ptab(i1:i2,j1:j2,jm) * tmask(i1:i2,j1:j2,1)
+                  jm = jm + 1
+               END DO
+               !
+            END DO
+            !
+!!==> clem: this interpolation does not work because it creates negative values, due
+!!          to negative coefficients when mixing points (for ex. z7)
+!!
+!         ELSE                          ! ==> complex interpolation (only one ghost cell available)
+!            !! Use a more complex interpolation since we mix solutions over a couple of grid points
+!            !! it is advised to use it for fields modified by high order schemes (e.g. advection UM5...)
+!            ! record ztab
+!            jm = 1
+!            DO jl = 1, jpl
+!               ztab(:,:,jm  ) = a_i (:,:,jl)
+!               ztab(:,:,jm+1) = v_i (:,:,jl)
+!               ztab(:,:,jm+2) = v_s (:,:,jl)
+!               ztab(:,:,jm+3) = sv_i(:,:,jl)
+!               ztab(:,:,jm+4) = oa_i(:,:,jl)
+!               ztab(:,:,jm+5) = a_ip(:,:,jl)
+!               ztab(:,:,jm+6) = v_ip(:,:,jl)
+!               ztab(:,:,jm+7) = t_su(:,:,jl)
+!               jm = jm + 8
+!               DO jk = 1, nlay_s
+!                  ztab(:,:,jm) = e_s(:,:,jk,jl)
+!                  jm = jm + 1
+!               END DO
+!               DO jk = 1, nlay_i
+!                  ztab(:,:,jm) = e_i(:,:,jk,jl)
+!                  jm = jm + 1
+!               END DO
+!               !
+!            END DO
+!            !
+!            ! borders of the domain
+!            western_side  = (nb == 1).AND.(ndir == 1)  ;  eastern_side  = (nb == 1).AND.(ndir == 2)
+!            southern_side = (nb == 2).AND.(ndir == 1)  ;  northern_side = (nb == 2).AND.(ndir == 2)
+!            !
+!            ! spatial smoothing
+!            zrhox = Agrif_Rhox()
+!            z1 =      ( zrhox - 1. ) * 0.5 
+!            z3 =      ( zrhox - 1. ) / ( zrhox + 1. )
+!            z6 = 2. * ( zrhox - 1. ) / ( zrhox + 1. )
+!            z7 =    - ( zrhox - 1. ) / ( zrhox + 3. )
+!            z2 = 1. - z1
+!            z4 = 1. - z3
+!            z5 = 1. - z6 - z7
+!            !
+!            ! Remove corners
+!            imin = i1  ;  imax = i2  ;  jmin = j1  ;  jmax = j2
+!            IF( (nbondj == -1) .OR. (nbondj == 2) )   jmin = 3
+!            IF( (nbondj == +1) .OR. (nbondj == 2) )   jmax = nlcj-2
+!            IF( (nbondi == -1) .OR. (nbondi == 2) )   imin = 3
+!            IF( (nbondi == +1) .OR. (nbondi == 2) )   imax = nlci-2
+!
+!            ! smoothed fields
+!            IF( eastern_side ) THEN
+!               ztab(nlci,j1:j2,:) = z1 * ptab(nlci,j1:j2,:) + z2 * ptab(nlci-1,j1:j2,:)
+!               DO jj = jmin, jmax
+!                  rswitch = 0.
+!                  IF( u_ice(nlci-2,jj) > 0._wp ) rswitch = 1.
+!                  ztab(nlci-1,jj,:) = ( 1. - umask(nlci-2,jj,1) ) * ztab(nlci,jj,:)  &
+!                     &                +      umask(nlci-2,jj,1)   *  &
+!                     &                ( ( 1. - rswitch ) * ( z4 * ztab(nlci,jj,:)   + z3 * ztab(nlci-2,jj,:) )  &
+!                     &                  +      rswitch   * ( z6 * ztab(nlci-2,jj,:) + z5 * ztab(nlci,jj,:) + z7 * ztab(nlci-3,jj,:) ) )
+!                  ztab(nlci-1,jj,:) = ztab(nlci-1,jj,:) * tmask(nlci-1,jj,1)
+!               END DO
+!            ENDIF
+!            ! 
+!            IF( northern_side ) THEN
+!               ztab(i1:i2,nlcj,:) = z1 * ptab(i1:i2,nlcj,:) + z2 * ptab(i1:i2,nlcj-1,:)
+!               DO ji = imin, imax
+!                  rswitch = 0.
+!                  IF( v_ice(ji,nlcj-2) > 0._wp ) rswitch = 1.
+!                  ztab(ji,nlcj-1,:) = ( 1. - vmask(ji,nlcj-2,1) ) * ztab(ji,nlcj,:)  &
+!                     &                +      vmask(ji,nlcj-2,1)   *  &
+!                     &                ( ( 1. - rswitch ) * ( z4 * ztab(ji,nlcj,:)   + z3 * ztab(ji,nlcj-2,:) ) &
+!                     &                  +      rswitch   * ( z6 * ztab(ji,nlcj-2,:) + z5 * ztab(ji,nlcj,:) + z7 * ztab(ji,nlcj-3,:) ) )
+!                  ztab(ji,nlcj-1,:) = ztab(ji,nlcj-1,:) * tmask(ji,nlcj-1,1)
+!               END DO
+!            END IF
+!            !
+!            IF( western_side) THEN
+!               ztab(1,j1:j2,:) = z1 * ptab(1,j1:j2,:) + z2 * ptab(2,j1:j2,:)
+!               DO jj = jmin, jmax
+!                  rswitch = 0.
+!                  IF( u_ice(2,jj) < 0._wp ) rswitch = 1.
+!                  ztab(2,jj,:) = ( 1. - umask(2,jj,1) ) * ztab(1,jj,:)  &
+!                     &           +      umask(2,jj,1)   *   &
+!                     &           ( ( 1. - rswitch ) * ( z4 * ztab(1,jj,:) + z3 * ztab(3,jj,:) ) &
+!                     &             +      rswitch   * ( z6 * ztab(3,jj,:) + z5 * ztab(1,jj,:) + z7 * ztab(4,jj,:) ) )
+!                  ztab(2,jj,:) = ztab(2,jj,:) * tmask(2,jj,1)
+!               END DO
+!            ENDIF
+!            !
+!            IF( southern_side ) THEN
+!               ztab(i1:i2,1,:) = z1 * ptab(i1:i2,1,:) + z2 * ptab(i1:i2,2,:)
+!               DO ji = imin, imax
+!                  rswitch = 0.
+!                  IF( v_ice(ji,2) < 0._wp ) rswitch = 1.
+!                  ztab(ji,2,:) = ( 1. - vmask(ji,2,1) ) * ztab(ji,1,:)  &
+!                     &           +      vmask(ji,2,1)   *  &
+!                     &           ( ( 1. - rswitch ) * ( z4 * ztab(ji,1,:) + z3 * ztab(ji,3,:) ) &
+!                     &             +      rswitch   * ( z6 * ztab(ji,3,:) + z5 * ztab(ji,1,:) + z7 * ztab(ji,4,:) ) )
+!                  ztab(ji,2,:) = ztab(ji,2,:) * tmask(ji,2,1)
+!               END DO
+!            END IF
+!            !
+!            ! Treatment of corners
+!            IF( (eastern_side) .AND. ((nbondj == -1).OR.(nbondj == 2)) )  ztab(nlci-1,2,:)      = ptab(nlci-1,2,:)      ! East south
+!            IF( (eastern_side) .AND. ((nbondj ==  1).OR.(nbondj == 2)) )  ztab(nlci-1,nlcj-1,:) = ptab(nlci-1,nlcj-1,:) ! East north
+!            IF( (western_side) .AND. ((nbondj == -1).OR.(nbondj == 2)) )  ztab(2,2,:)           = ptab(2,2,:)           ! West south
+!            IF( (western_side) .AND. ((nbondj ==  1).OR.(nbondj == 2)) )  ztab(2,nlcj-1,:)      = ptab(2,nlcj-1,:)      ! West north
+!            
+!            ! retrieve ice tracers
+!            jm = 1
+!            DO jl = 1, jpl
+!               !
+!               DO jj = j1, j2
+!                  DO ji = i1, i2
+!                     a_i (ji,jj,jl) = ztab(ji,jj,jm  ) * tmask(ji,jj,1)
+!                     v_i (ji,jj,jl) = ztab(ji,jj,jm+1) * tmask(ji,jj,1)
+!                     v_s (ji,jj,jl) = ztab(ji,jj,jm+2) * tmask(ji,jj,1)
+!                     sv_i(ji,jj,jl) = ztab(ji,jj,jm+3) * tmask(ji,jj,1)
+!                     oa_i(ji,jj,jl) = ztab(ji,jj,jm+4) * tmask(ji,jj,1)
+!                     a_ip(ji,jj,jl) = ztab(ji,jj,jm+5) * tmask(ji,jj,1)
+!                     v_ip(ji,jj,jl) = ztab(ji,jj,jm+6) * tmask(ji,jj,1)
+!                     t_su(ji,jj,jl) = ztab(ji,jj,jm+7) * tmask(ji,jj,1)
+!                  END DO
+!               END DO
+!               jm = jm + 8
+!               !
+!               DO jk = 1, nlay_s
+!                  e_s(i1:i2,j1:j2,jk,jl) = ztab(i1:i2,j1:j2,jm) * tmask(i1:i2,j1:j2,1)
+!                  jm = jm + 1
+!               END DO
+!               !
+!               DO jk = 1, nlay_i
+!                  e_i(i1:i2,j1:j2,jk,jl) = ztab(i1:i2,j1:j2,jm) * tmask(i1:i2,j1:j2,1)
+!                  jm = jm + 1
+!               END DO
+!               !
+!            END DO
+!          
+!         ENDIF  ! nbghostcells=1
+         
+         DO jl = 1, jpl
+            WHERE( tmask(i1:i2,j1:j2,1) == 0._wp )   t_su(i1:i2,j1:j2,jl) = rt0   ! to avoid a division by 0 in sbcblk.F90
+         END DO
+         !
+      ENDIF
+      
+      DEALLOCATE( ztab )
+      !
+   END SUBROUTINE interp_tra_ice
+
+#else
+   !!----------------------------------------------------------------------
+   !!   Empty module                                             no sea-ice
+   !!----------------------------------------------------------------------
+CONTAINS
+   SUBROUTINE agrif_si3_interp_empty
+      WRITE(*,*)  'agrif_si3_interp : You should not have seen this print! error?'
+   END SUBROUTINE agrif_si3_interp_empty
+#endif
+
+   !!======================================================================
+END MODULE agrif_si3_interp
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/NST_SRC/agrif_si3_update.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/NST_SRC/agrif_si3_update.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/NST_SRC/agrif_si3_update.F90	(revision 9570)
@@ -0,0 +1,218 @@
+#define TWO_WAY
+!!#undef TWO_WAY
+
+MODULE agrif_si3_update
+   !!=====================================================================================
+   !!                       ***  MODULE agrif_si3_update ***
+   !! Nesting module :  update surface ocean boundary condition over ice from a child grid
+   !! Sea-Ice model  :  LIM 3.6 Sea ice model time-stepping
+   !!=====================================================================================
+   !! History :  2.0   !  04-2008  (F. Dupont)  initial version
+   !!            3.4   !  08-2012  (R. Benshila, C. Herbaut) update and EVP
+   !!            3.6   !  05-2016  (C. Rousset)  Add LIM3 compatibility
+   !!----------------------------------------------------------------------
+#if defined key_agrif && defined key_si3
+   !!----------------------------------------------------------------------
+   !!   'key_si3'  :                                 LIM 3.6 sea-ice model
+   !!   'key_agrif' :                                 AGRIF library 
+   !!----------------------------------------------------------------------
+   !!   agrif_update_si3  : update sea-ice on boundaries or total
+   !!                        child domain for velocities and ice properties
+   !!   update_tra_ice     : sea-ice properties
+   !!   update_u_ice       : zonal      ice velocity
+   !!   update_v_ice       : meridional ice velocity
+   !!----------------------------------------------------------------------
+   USE dom_oce
+   USE sbc_oce
+   USE agrif_oce
+   USE ice
+   USE agrif_ice 
+   USE phycst , ONLY: rt0
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   agrif_update_si3   ! called by agrif_user.F90 and icestp.F90
+
+   !!----------------------------------------------------------------------
+   !! NEMO/NST 4.0 , LOCEAN-IPSL (2017)
+   !! $Id: agrif_si3_update.F90 6204 2016-01-04 13:47:06Z cetlod $
+   !! Software governed by the CeCILL licence (modipsl/doc/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE agrif_update_si3( kt )
+      !!----------------------------------------------------------------------
+      !!                     *** ROUTINE agrif_update_si3 ***
+      !! ** Method  :   Call the hydrostaticupdate pressure at the boundary or the entire domain 
+      !!
+      !! ** Action : - Update (u_ice,v_ice) and ice tracers
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT(in) :: kt
+      !!----------------------------------------------------------------------
+      !
+      IF( Agrif_Root() .OR. nn_ice == 0 ) RETURN   ! do not update if inside Parent Grid or if child domain does not have ice
+      !
+      IF( ( MOD( (kt-nit000)/nn_fsbc + 1, Agrif_irhot() * Agrif_Parent(nn_fsbc)/nn_fsbc ) /=0 ) .AND. (kt /= 0) ) RETURN   ! update only at the parent ice time step
+      !
+      Agrif_SpecialValueFineGrid    = -9999.
+      Agrif_UseSpecialValueInUpdate = .TRUE.
+# if defined TWO_WAY
+      CALL Agrif_Update_Variable( tra_ice_id , procname = update_tra_ice  )
+      CALL Agrif_Update_Variable( u_ice_id   , procname = update_u_ice    )
+      CALL Agrif_Update_Variable( v_ice_id   , procname = update_v_ice    )
+
+!      CALL Agrif_Update_Variable( tra_ice_id , locupdate=(/0,2/), procname = update_tra_ice  )
+!      CALL Agrif_Update_Variable( u_ice_id   , locupdate=(/0,1/), procname = update_u_ice    )
+!      CALL Agrif_Update_Variable( v_ice_id   , locupdate=(/0,1/), procname = update_v_ice    )
+# endif
+      Agrif_SpecialValueFineGrid    = 0.
+      Agrif_UseSpecialValueInUpdate = .FALSE.
+      !
+   END SUBROUTINE agrif_update_si3
+
+
+   SUBROUTINE update_tra_ice( ptab, i1, i2, j1, j2, k1, k2, before )
+      !!-----------------------------------------------------------------------
+      !!                        *** ROUTINE update_tra_ice ***
+      !! ** Method  : Compute the mass properties on the fine grid and recover
+      !!              the properties per mass on the coarse grid
+      !!-----------------------------------------------------------------------
+      INTEGER                               , INTENT(in   ) ::   i1, i2, j1, j2, k1, k2
+      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) ::   ptab
+      LOGICAL                               , INTENT(in   ) ::   before
+      !!
+      INTEGER  :: ji, jj, jk, jl, jm
+      !!-----------------------------------------------------------------------
+      ! it is ok not to multiply by e1*e2 since we conserve tracers here (same as in the ocean).
+      IF( before ) THEN
+         jm = 1
+         DO jl = 1, jpl
+            ptab(i1:i2,j1:j2,jm  ) = a_i (i1:i2,j1:j2,jl)
+            ptab(i1:i2,j1:j2,jm+1) = v_i (i1:i2,j1:j2,jl)
+            ptab(i1:i2,j1:j2,jm+2) = v_s (i1:i2,j1:j2,jl)
+            ptab(i1:i2,j1:j2,jm+3) = sv_i(i1:i2,j1:j2,jl)
+            ptab(i1:i2,j1:j2,jm+4) = oa_i(i1:i2,j1:j2,jl)
+            ptab(i1:i2,j1:j2,jm+5) = a_ip(i1:i2,j1:j2,jl)
+            ptab(i1:i2,j1:j2,jm+6) = v_ip(i1:i2,j1:j2,jl)
+            ptab(i1:i2,j1:j2,jm+7) = t_su(i1:i2,j1:j2,jl)
+            jm = jm + 8
+            DO jk = 1, nlay_s
+               ptab(i1:i2,j1:j2,jm) = e_s(i1:i2,j1:j2,jk,jl)   ;   jm = jm + 1
+            END DO
+            DO jk = 1, nlay_i
+               ptab(i1:i2,j1:j2,jm) = e_i(i1:i2,j1:j2,jk,jl)   ;   jm = jm + 1
+            END DO
+         END DO
+         !
+         DO jk = k1, k2
+            WHERE( tmask(i1:i2,j1:j2,1) == 0. )   ptab(i1:i2,j1:j2,jk) = Agrif_SpecialValueFineGrid 
+         END DO
+         !
+      ELSE
+         !
+         jm = 1
+         DO jl = 1, jpl
+            !
+            DO jj = j1, j2
+               DO ji = i1, i2
+                  IF( ptab(ji,jj,jm) /= Agrif_SpecialValueFineGrid ) THEN
+                     a_i (ji,jj,jl) = ptab(ji,jj,jm  ) * tmask(ji,jj,1)
+                     v_i (ji,jj,jl) = ptab(ji,jj,jm+1) * tmask(ji,jj,1)
+                     v_s (ji,jj,jl) = ptab(ji,jj,jm+2) * tmask(ji,jj,1)
+                     sv_i(ji,jj,jl) = ptab(ji,jj,jm+3) * tmask(ji,jj,1)
+                     oa_i(ji,jj,jl) = ptab(ji,jj,jm+4) * tmask(ji,jj,1)
+                     a_ip(ji,jj,jl) = ptab(ji,jj,jm+5) * tmask(ji,jj,1)
+                     v_ip(ji,jj,jl) = ptab(ji,jj,jm+6) * tmask(ji,jj,1)
+                     t_su(ji,jj,jl) = ptab(ji,jj,jm+7) * tmask(ji,jj,1)
+                  ENDIF
+               END DO
+            END DO
+            jm = jm + 8
+            !
+            DO jk = 1, nlay_s
+               WHERE( ptab(i1:i2,j1:j2,jm) /= Agrif_SpecialValueFineGrid )
+                  e_s(i1:i2,j1:j2,jk,jl) = ptab(i1:i2,j1:j2,jm) * tmask(i1:i2,j1:j2,1)
+               ENDWHERE
+               jm = jm + 1
+            END DO
+            !
+            DO jk = 1, nlay_i
+               WHERE( ptab(i1:i2,j1:j2,jm) /= Agrif_SpecialValueFineGrid )
+                  e_i(i1:i2,j1:j2,jk,jl) = ptab(i1:i2,j1:j2,jm) * tmask(i1:i2,j1:j2,1)
+               ENDWHERE
+               jm = jm + 1
+            END DO
+            !
+         END DO
+         !
+         DO jl = 1, jpl
+            WHERE( tmask(i1:i2,j1:j2,1) == 0._wp )   t_su(i1:i2,j1:j2,jl) = rt0   ! to avoid a division by 0 in sbcblk.F90
+         END DO
+         
+      ENDIF
+      !
+   END SUBROUTINE update_tra_ice
+
+
+   SUBROUTINE update_u_ice( ptab, i1, i2, j1, j2, before )
+      !!-----------------------------------------------------------------------
+      !!                        *** ROUTINE update_u_ice ***
+      !! ** Method  : Update the fluxes and recover the properties (C-grid)
+      !!-----------------------------------------------------------------------
+      INTEGER                         , INTENT(in   ) ::   i1, i2, j1, j2
+      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) ::   ptab
+      LOGICAL                         , INTENT(in   ) ::   before
+      !!
+      REAL(wp) ::   zrhoy   ! local scalar
+      !!-----------------------------------------------------------------------
+      !
+      IF( before ) THEN
+         zrhoy = Agrif_Rhoy()
+         ptab(:,:) = e2u(i1:i2,j1:j2) * u_ice(i1:i2,j1:j2) * zrhoy
+         WHERE( umask(i1:i2,j1:j2,1) == 0._wp )   ptab(:,:) = Agrif_SpecialValueFineGrid
+      ELSE
+         WHERE( ptab(i1:i2,j1:j2) /= Agrif_SpecialValueFineGrid )
+            u_ice(i1:i2,j1:j2) = ptab(i1:i2,j1:j2) / e2u(i1:i2,j1:j2) * umask(i1:i2,j1:j2,1)
+         ENDWHERE
+      ENDIF
+      ! 
+   END SUBROUTINE update_u_ice
+
+
+   SUBROUTINE update_v_ice( ptab, i1, i2, j1, j2, before )
+      !!-----------------------------------------------------------------------
+      !!                    *** ROUTINE update_v_ice ***
+      !! ** Method  : Update the fluxes and recover the properties (C-grid)
+      !!-----------------------------------------------------------------------
+      INTEGER                         , INTENT(in   ) ::   i1, i2, j1, j2
+      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) ::   ptab
+      LOGICAL                         , INTENT(in   ) ::   before
+      !!
+      REAL(wp) ::   zrhox   ! local scalar
+      !!-----------------------------------------------------------------------
+      !
+      IF( before ) THEN
+         zrhox = Agrif_Rhox()
+         ptab(:,:) = e1v(i1:i2,j1:j2) * v_ice(i1:i2,j1:j2) * zrhox
+         WHERE( vmask(i1:i2,j1:j2,1) == 0._wp )   ptab(:,:) = Agrif_SpecialValueFineGrid
+      ELSE
+         WHERE( ptab(i1:i2,j1:j2) /= Agrif_SpecialValueFineGrid )
+            v_ice(i1:i2,j1:j2) = ptab(i1:i2,j1:j2) / e1v(i1:i2,j1:j2) * vmask(i1:i2,j1:j2,1)
+         ENDWHERE
+      ENDIF
+      !
+   END SUBROUTINE update_v_ice
+
+#else
+   !!----------------------------------------------------------------------
+   !!   Empty module                                             no sea-ice
+   !!----------------------------------------------------------------------
+CONTAINS
+   SUBROUTINE agrif_si3_update_empty
+      WRITE(*,*)  'agrif_si3_update : You should not have seen this print! error?'
+   END SUBROUTINE agrif_si3_update_empty
+#endif
+
+   !!======================================================================
+END MODULE agrif_si3_update
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/NST_SRC/agrif_top_sponge.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/NST_SRC/agrif_top_sponge.F90	(revision 9569)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/NST_SRC/agrif_top_sponge.F90	(revision 9570)
@@ -19,5 +19,5 @@
    USE dom_oce
    USE agrif_oce
-   USE agrif_opa_sponge
+   USE agrif_oce_sponge
    !
    USE in_out_manager
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/NST_SRC/agrif_user.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/NST_SRC/agrif_user.F90	(revision 9569)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/NST_SRC/agrif_user.F90	(revision 9570)
@@ -61,6 +61,6 @@
    CALL Agrif_InitValues_cont_top
 # endif
-# if defined key_lim3
-   CALL Agrif_InitValues_cont_lim3
+# if defined key_si3
+   CALL Agrif_InitValues_cont_si3
 # endif
    !
@@ -83,7 +83,7 @@
    USE nemogcm
    USE in_out_manager
-   USE agrif_opa_update
-   USE agrif_opa_interp
-   USE agrif_opa_sponge
+   USE agrif_oce_update
+   USE agrif_oce_interp
+   USE agrif_oce_sponge
    !
    IMPLICIT NONE
@@ -149,7 +149,7 @@
    !! ** Purpose ::   Declaration of variables to be interpolated
    !!----------------------------------------------------------------------
-   USE agrif_opa_update
-   USE agrif_opa_interp
-   USE agrif_opa_sponge
+   USE agrif_oce_update
+   USE agrif_oce_interp
+   USE agrif_oce_sponge
    USE Agrif_Util
    USE oce 
@@ -303,10 +303,10 @@
    !!----------------------------------------------------------------------
    USE dom_oce
-   USE agrif_opa_update
+   USE agrif_oce_update
 #if defined key_top
    USE agrif_top_update
 #endif
-#if defined key_lim3
-   USE agrif_lim3_update
+#if defined key_si3
+   USE agrif_si3_update
 #endif
    !
@@ -326,6 +326,6 @@
 !!   CALL Agrif_Update_tke(0)
 
-#if defined key_lim3
-   CALL agrif_update_lim3(0)
+#if defined key_si3
+   CALL agrif_update_si3(0)
 #endif
    
@@ -492,8 +492,8 @@
 END SUBROUTINE agrif_declare_var
 
-#if defined key_lim3
-SUBROUTINE Agrif_InitValues_cont_lim3
-   !!----------------------------------------------------------------------
-   !!                 *** ROUTINE Agrif_InitValues_cont_lim3 ***
+#if defined key_si3
+SUBROUTINE Agrif_InitValues_cont_si3
+   !!----------------------------------------------------------------------
+   !!                 *** ROUTINE Agrif_InitValues_cont_si3 ***
    !!
    !! ** Purpose :: Initialisation of variables to be interpolated for LIM3
@@ -504,5 +504,5 @@
    USE agrif_ice
    USE in_out_manager
-   USE agrif_lim3_interp
+   USE agrif_si3_interp
    USE lib_mpp
    !
@@ -512,5 +512,5 @@
    ! Declaration of the type of variable which have to be interpolated (parent=>child)
    !----------------------------------------------------------------------------------
-   CALL agrif_declare_var_lim3
+   CALL agrif_declare_var_si3
 
    ! Controls
@@ -529,15 +529,15 @@
    !----------------------------------------------------------------------
    lim_nbstep = ( Agrif_irhot() * Agrif_Parent(nn_fsbc) / nn_fsbc ) ! clem: to have calledweight=1 in interp (otherwise the western border of the zoom is wrong)
-   CALL agrif_interp_lim3('U') ! interpolation of ice velocities
-   CALL agrif_interp_lim3('V') ! interpolation of ice velocities
-   CALL agrif_interp_lim3('T') ! interpolation of ice tracers 
+   CALL agrif_interp_si3('U') ! interpolation of ice velocities
+   CALL agrif_interp_si3('V') ! interpolation of ice velocities
+   CALL agrif_interp_si3('T') ! interpolation of ice tracers 
    lim_nbstep = 0
    
    !
-END SUBROUTINE Agrif_InitValues_cont_lim3
-
-SUBROUTINE agrif_declare_var_lim3
-   !!----------------------------------------------------------------------
-   !!                 *** ROUTINE agrif_declare_var_lim3 ***
+END SUBROUTINE Agrif_InitValues_cont_si3
+
+SUBROUTINE agrif_declare_var_si3
+   !!----------------------------------------------------------------------
+   !!                 *** ROUTINE agrif_declare_var_si3 ***
    !!
    !! ** Purpose :: Declaration of variables to be interpolated for LIM3
@@ -590,5 +590,5 @@
 #endif
 
-END SUBROUTINE agrif_declare_var_lim3
+END SUBROUTINE agrif_declare_var_si3
 #endif
 
@@ -609,5 +609,5 @@
    USE trc
    USE in_out_manager
-   USE agrif_opa_sponge
+   USE agrif_oce_sponge
    USE agrif_top_update
    USE agrif_top_interp
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/ASM/asmbkg.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/ASM/asmbkg.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/ASM/asmbkg.F90	(revision 9570)
@@ -0,0 +1,160 @@
+MODULE asmbkg
+   !!======================================================================
+   !!                       ***  MODULE asmtrj -> asmbkg  ***
+   !! Assimilation trajectory interface: Write to file the background state and the model state trajectory
+   !!======================================================================
+   !! History :       ! 2007-03 (M. Martin)  Met. Office version
+   !!                 ! 2007-04 (A. Weaver)  asm_trj_wri, original code
+   !!                 ! 2007-03 (K. Mogensen)  Adapt to NEMOVAR and use IOM instead of IOIPSL
+   !!                 ! 2007-04 (A. Weaver)  Name change (formally asmbkg.F90). Distinguish
+   !!                                        background states in Jb term and at analysis time.
+   !!                                        Include state trajectory routine (currently empty)
+   !!                 ! 2007-07 (A. Weaver)  Add tke_rst and flt_rst for case nitbkg=0 
+   !!                 ! 2009-03 (F. Vigilant)  Add hmlp (zdfmxl) for no tracer nmldp=2 
+   !!                 ! 2009-06 (F. Vigilant) asm_trj_wri: special case when kt=nit000-1
+   !!                 ! 2009-07 (F. Vigilant) asm_trj_wri: add computation of eiv at restart
+   !!                 ! 2010-01 (A. Vidard) split asm_trj_wri into tam_trj_wri and asm_bkg_wri
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   asm_bkg_wri  : Write out the background state
+   !!   asm_trj_wri  : Write out the model state trajectory (used with 4D-Var)
+   !!----------------------------------------------------------------------
+   USE oce                ! Dynamics and active tracers defined in memory
+   USE sbc_oce            ! Ocean surface boundary conditions
+   USE zdf_oce            ! Vertical mixing variables
+   USE zdfddm             ! Double diffusion mixing parameterization
+   USE ldftra             ! Lateral diffusion: eddy diffusivity coefficients
+   USE ldfslp             ! Lateral diffusion: slopes of neutral surfaces
+   USE tradmp             ! Tracer damping
+   USE zdftke             ! TKE vertical physics
+   USE eosbn2             ! Equation of state (eos_bn2 routine)
+   USE zdfmxl             ! Mixed layer depth
+   USE dom_oce     , ONLY :   ndastp
+   USE in_out_manager     ! I/O manager
+   USE iom                ! I/O module
+   USE asmpar             ! Parameters for the assmilation interface
+   USE zdfmxl             ! mixed layer depth
+#if defined key_si3
+   USE ice
+#endif
+
+   IMPLICIT NONE
+   PRIVATE
+   
+   PUBLIC   asm_bkg_wri   !: Write out the background state
+
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO Consortium (2010)
+   !! $Id$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE asm_bkg_wri( kt )
+      !!-----------------------------------------------------------------------
+      !!                  ***  ROUTINE asm_bkg_wri ***
+      !!
+      !! ** Purpose : Write to file the background state for later use in the
+      !!              inner loop of data assimilation or for direct initialization
+      !!              in the outer loop.
+      !!
+      !! ** Method  : Write out the background state for use in the Jb term
+      !!              in the cost function and for use with direct initialization
+      !!              at analysis time.
+      !!-----------------------------------------------------------------------
+      INTEGER, INTENT( IN ) :: kt               ! Current time-step
+      !
+      CHARACTER (LEN=50) :: cl_asmbkg
+      CHARACTER (LEN=50) :: cl_asmdin
+      LOGICAL :: llok          ! Check if file exists
+      INTEGER :: inum          ! File unit number
+      REAL(wp) :: zdate        ! Date
+      !!-----------------------------------------------------------------------
+
+      !                                !-------------------------------------------
+      IF( kt == nitbkg_r ) THEN        ! Write out background at time step nitbkg_r
+         !                             !-----------------------------------========
+         !
+         WRITE(cl_asmbkg, FMT='(A,".nc")' ) TRIM( c_asmbkg )
+         cl_asmbkg = TRIM( cl_asmbkg )
+         INQUIRE( FILE = cl_asmbkg, EXIST = llok )
+         !
+         IF( .NOT. llok ) THEN
+            IF(lwp) WRITE(numout,*) ' Setting up assimilation background file '// TRIM( c_asmbkg )
+            !
+            !                                      ! Define the output file        
+            CALL iom_open( c_asmbkg, inum, ldwrt = .TRUE., kiolib = jprstlib)
+            !
+            IF( nitbkg_r == nit000 - 1 ) THEN      ! Treat special case when nitbkg = 0
+               zdate = REAL( ndastp )
+               IF( ln_zdftke ) THEN                   ! read turbulent kinetic energy ( en )
+                  IF(lwp) WRITE(numout,*) ' Reading TKE (en) from restart...'
+                  CALL tke_rst( nit000, 'READ' )
+               ENDIF
+            ELSE
+               zdate = REAL( ndastp )
+            ENDIF
+            !
+            !                                      ! Write the information
+            CALL iom_rstput( kt, nitbkg_r, inum, 'rdastp' , zdate             )
+            CALL iom_rstput( kt, nitbkg_r, inum, 'un'     , un                )
+            CALL iom_rstput( kt, nitbkg_r, inum, 'vn'     , vn                )
+            CALL iom_rstput( kt, nitbkg_r, inum, 'tn'     , tsn(:,:,:,jp_tem) )
+            CALL iom_rstput( kt, nitbkg_r, inum, 'sn'     , tsn(:,:,:,jp_sal) )
+            CALL iom_rstput( kt, nitbkg_r, inum, 'sshn'   , sshn              )
+            IF( ln_zdftke )   CALL iom_rstput( kt, nitbkg_r, inum, 'en'     , en                )
+            !
+            CALL iom_close( inum )
+         ENDIF
+         !
+      ENDIF
+
+      !                                !-------------------------------------------
+      IF( kt == nitdin_r ) THEN        ! Write out background at time step nitdin_r
+         !                             !-----------------------------------========
+         !
+         WRITE(cl_asmdin, FMT='(A,".nc")' ) TRIM( c_asmdin )
+         cl_asmdin = TRIM( cl_asmdin )
+         INQUIRE( FILE = cl_asmdin, EXIST = llok )
+         !
+         IF( .NOT. llok ) THEN
+            IF(lwp) WRITE(numout,*) ' Setting up assimilation background file '// TRIM( c_asmdin )
+            !
+            !                                      ! Define the output file        
+            CALL iom_open( c_asmdin, inum, ldwrt = .TRUE., kiolib = jprstlib)
+            !
+            IF( nitdin_r == nit000 - 1 ) THEN      ! Treat special case when nitbkg = 0
+
+               zdate = REAL( ndastp )
+            ELSE
+               zdate = REAL( ndastp )
+            ENDIF
+            !
+            !                                      ! Write the information
+            CALL iom_rstput( kt, nitdin_r, inum, 'rdastp' , zdate             )
+            CALL iom_rstput( kt, nitdin_r, inum, 'un'     , un                )
+            CALL iom_rstput( kt, nitdin_r, inum, 'vn'     , vn                )
+            CALL iom_rstput( kt, nitdin_r, inum, 'tn'     , tsn(:,:,:,jp_tem) )
+            CALL iom_rstput( kt, nitdin_r, inum, 'sn'     , tsn(:,:,:,jp_sal) )
+            CALL iom_rstput( kt, nitdin_r, inum, 'sshn'   , sshn              )
+#if defined key_si3
+            IF( nn_ice == 2 ) THEN
+	            IF( ALLOCATED(at_i) ) THEN
+                  CALL iom_rstput( kt, nitdin_r, inum, 'iceconc', at_i(:,:)   )
+               ELSE
+		            CALL ctl_warn('asm_bkg_wri: Ice concentration not written to background ',   &
+		               &          'as ice variable at_i not allocated on this timestep')
+	            ENDIF
+            ENDIF
+#endif
+            !
+            CALL iom_close( inum )
+         ENDIF
+         !
+      ENDIF
+      !                    
+   END SUBROUTINE asm_bkg_wri
+
+   !!======================================================================
+END MODULE asmbkg
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/ASM/asminc.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/ASM/asminc.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/ASM/asminc.F90	(revision 9570)
@@ -0,0 +1,1020 @@
+MODULE asminc
+   !!======================================================================
+   !!                       ***  MODULE asminc  ***
+   !! Assimilation increment : Apply an increment generated by data
+   !!                          assimilation
+   !!======================================================================
+   !! History :       ! 2007-03  (M. Martin)  Met Office version
+   !!                 ! 2007-04  (A. Weaver)  calc_date original code
+   !!                 ! 2007-04  (A. Weaver)  Merge with OPAVAR/NEMOVAR
+   !!   NEMO     3.3  ! 2010-05  (D. Lea)  Update to work with NEMO v3.2
+   !!             -   ! 2010-05  (D. Lea)  add calc_month_len routine based on day_init 
+   !!            3.4  ! 2012-10  (A. Weaver and K. Mogensen) Fix for direct initialization
+   !!                 ! 2014-09  (D. Lea)  Local calc_date removed use routine from OBS
+   !!                 ! 2015-11  (D. Lea)  Handle non-zero initial time of day
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   asm_inc_init   : Initialize the increment arrays and IAU weights
+   !!   tra_asm_inc    : Apply the tracer (T and S) increments
+   !!   dyn_asm_inc    : Apply the dynamic (u and v) increments
+   !!   ssh_asm_inc    : Apply the SSH increment
+   !!   ssh_asm_div    : Apply divergence associated with SSH increment
+   !!   seaice_asm_inc : Apply the seaice increment
+   !!----------------------------------------------------------------------
+   USE oce             ! Dynamics and active tracers defined in memory
+   USE par_oce         ! Ocean space and time domain variables
+   USE dom_oce         ! Ocean space and time domain
+   USE domvvl          ! domain: variable volume level
+   USE ldfdyn          ! lateral diffusion: eddy viscosity coefficients
+   USE eosbn2          ! Equation of state - in situ and potential density
+   USE zpshde          ! Partial step : Horizontal Derivative
+   USE asmpar          ! Parameters for the assmilation interface
+   USE asmbkg          ! 
+   USE c1d             ! 1D initialization
+   USE sbc_oce         ! Surface boundary condition variables.
+   USE diaobs   , ONLY : calc_date     ! Compute the calendar date on a given step
+#if defined key_si3
+   USE ice      , ONLY : hm_i, at_i, at_i_b
+#endif
+   !
+   USE in_out_manager  ! I/O manager
+   USE iom             ! Library to read input files
+   USE lib_mpp         ! MPP library
+
+   IMPLICIT NONE
+   PRIVATE
+   
+   PUBLIC   asm_inc_init   !: Initialize the increment arrays and IAU weights
+   PUBLIC   tra_asm_inc    !: Apply the tracer (T and S) increments
+   PUBLIC   dyn_asm_inc    !: Apply the dynamic (u and v) increments
+   PUBLIC   ssh_asm_inc    !: Apply the SSH increment
+   PUBLIC   ssh_asm_div    !: Apply the SSH divergence
+   PUBLIC   seaice_asm_inc !: Apply the seaice increment
+
+#if defined key_asminc
+    LOGICAL, PUBLIC, PARAMETER :: lk_asminc = .TRUE.   !: Logical switch for assimilation increment interface
+#else
+    LOGICAL, PUBLIC, PARAMETER :: lk_asminc = .FALSE.  !: No assimilation increments
+#endif
+   LOGICAL, PUBLIC :: ln_bkgwri     !: No output of the background state fields
+   LOGICAL, PUBLIC :: ln_asmiau     !: No applying forcing with an assimilation increment
+   LOGICAL, PUBLIC :: ln_asmdin     !: No direct initialization
+   LOGICAL, PUBLIC :: ln_trainc     !: No tracer (T and S) assimilation increments
+   LOGICAL, PUBLIC :: ln_dyninc     !: No dynamics (u and v) assimilation increments
+   LOGICAL, PUBLIC :: ln_sshinc     !: No sea surface height assimilation increment
+   LOGICAL, PUBLIC :: ln_seaiceinc  !: No sea ice concentration increment
+   LOGICAL, PUBLIC :: ln_salfix     !: Apply minimum salinity check
+   LOGICAL, PUBLIC :: ln_temnofreeze = .FALSE. !: Don't allow the temperature to drop below freezing
+   INTEGER, PUBLIC :: nn_divdmp     !: Apply divergence damping filter nn_divdmp times
+
+   REAL(wp), PUBLIC, DIMENSION(:,:,:), ALLOCATABLE ::   t_bkg   , s_bkg      !: Background temperature and salinity
+   REAL(wp), PUBLIC, DIMENSION(:,:,:), ALLOCATABLE ::   u_bkg   , v_bkg      !: Background u- & v- velocity components
+   REAL(wp), PUBLIC, DIMENSION(:,:,:), ALLOCATABLE ::   t_bkginc, s_bkginc   !: Increment to the background T & S
+   REAL(wp), PUBLIC, DIMENSION(:,:,:), ALLOCATABLE ::   u_bkginc, v_bkginc   !: Increment to the u- & v-components 
+   REAL(wp), PUBLIC, DIMENSION(:)    , ALLOCATABLE ::   wgtiau               !: IAU weights for each time step
+#if defined key_asminc
+   REAL(wp), PUBLIC, DIMENSION(:,:)  , ALLOCATABLE ::   ssh_iau              !: IAU-weighted sea surface height increment
+#endif
+   !                                !!! time steps relative to the cycle interval [0,nitend-nit000-1]
+   INTEGER , PUBLIC ::   nitbkg      !: Time step of the background state used in the Jb term
+   INTEGER , PUBLIC ::   nitdin      !: Time step of the background state for direct initialization
+   INTEGER , PUBLIC ::   nitiaustr   !: Time step of the start of the IAU interval 
+   INTEGER , PUBLIC ::   nitiaufin   !: Time step of the end of the IAU interval
+   ! 
+   INTEGER , PUBLIC ::   niaufn      !: Type of IAU weighing function: = 0   Constant weighting
+   !                                 !: = 1   Linear hat-like, centred in middle of IAU interval 
+   REAL(wp), PUBLIC ::   salfixmin   !: Ensure that the salinity is larger than this  value if (ln_salfix)
+
+   REAL(wp), DIMENSION(:,:), ALLOCATABLE ::   ssh_bkg, ssh_bkginc   ! Background sea surface height and its increment
+   REAL(wp), DIMENSION(:,:), ALLOCATABLE ::   seaice_bkginc         ! Increment to the background sea ice conc
+#if defined key_cice && defined key_asminc
+   REAL(wp), DIMENSION(:,:), ALLOCATABLE ::   ndaice_da             ! ice increment tendency into CICE
+#endif
+
+   !! * Substitutions
+#  include "vectopt_loop_substitute.h90"
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.7 , NEMO Consortium (2015)
+   !! $Id$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE asm_inc_init
+      !!----------------------------------------------------------------------
+      !!                    ***  ROUTINE asm_inc_init  ***
+      !!          
+      !! ** Purpose : Initialize the assimilation increment and IAU weights.
+      !!
+      !! ** Method  : Initialize the assimilation increment and IAU weights.
+      !!
+      !! ** Action  : 
+      !!----------------------------------------------------------------------
+      INTEGER :: ji, jj, jk, jt  ! dummy loop indices
+      INTEGER :: imid, inum      ! local integers
+      INTEGER :: ios             ! Local integer output status for namelist read
+      INTEGER :: iiauper         ! Number of time steps in the IAU period
+      INTEGER :: icycper         ! Number of time steps in the cycle
+      REAL(KIND=dp) :: ditend_date     ! Date YYYYMMDD.HHMMSS of final time step
+      REAL(KIND=dp) :: ditbkg_date     ! Date YYYYMMDD.HHMMSS of background time step for Jb term
+      REAL(KIND=dp) :: ditdin_date     ! Date YYYYMMDD.HHMMSS of background time step for DI
+      REAL(KIND=dp) :: ditiaustr_date  ! Date YYYYMMDD.HHMMSS of IAU interval start time step
+      REAL(KIND=dp) :: ditiaufin_date  ! Date YYYYMMDD.HHMMSS of IAU interval final time step
+
+      REAL(wp) :: znorm        ! Normalization factor for IAU weights
+      REAL(wp) :: ztotwgt      ! Value of time-integrated IAU weights (should be equal to one)
+      REAL(wp) :: z_inc_dateb  ! Start date of interval on which increment is valid
+      REAL(wp) :: z_inc_datef  ! End date of interval on which increment is valid
+      REAL(wp) :: zdate_bkg    ! Date in background state file for DI
+      REAL(wp) :: zdate_inc    ! Time axis in increments file
+      !
+      REAL(wp), ALLOCATABLE, DIMENSION(:,:) ::   zhdiv   ! 2D workspace
+      !!
+      NAMELIST/nam_asminc/ ln_bkgwri,                                      &
+         &                 ln_trainc, ln_dyninc, ln_sshinc,                &
+         &                 ln_asmdin, ln_asmiau,                           &
+         &                 nitbkg, nitdin, nitiaustr, nitiaufin, niaufn,   &
+         &                 ln_salfix, salfixmin, nn_divdmp
+      !!----------------------------------------------------------------------
+
+      !-----------------------------------------------------------------------
+      ! Read Namelist nam_asminc : assimilation increment interface
+      !-----------------------------------------------------------------------
+      ln_seaiceinc   = .FALSE.
+      ln_temnofreeze = .FALSE.
+
+      REWIND( numnam_ref )              ! Namelist nam_asminc in reference namelist : Assimilation increment
+      READ  ( numnam_ref, nam_asminc, IOSTAT = ios, ERR = 901)
+901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'nam_asminc in reference namelist', lwp )
+      REWIND( numnam_cfg )              ! Namelist nam_asminc in configuration namelist : Assimilation increment
+      READ  ( numnam_cfg, nam_asminc, IOSTAT = ios, ERR = 902 )
+902   IF( ios >  0 )   CALL ctl_nam ( ios , 'nam_asminc in configuration namelist', lwp )
+      IF(lwm) WRITE ( numond, nam_asminc )
+
+      ! Control print
+      IF(lwp) THEN
+         WRITE(numout,*)
+         WRITE(numout,*) 'asm_inc_init : Assimilation increment initialization :'
+         WRITE(numout,*) '~~~~~~~~~~~~'
+         WRITE(numout,*) '   Namelist namasm : set assimilation increment parameters'
+         WRITE(numout,*) '      Logical switch for writing out background state          ln_bkgwri = ', ln_bkgwri
+         WRITE(numout,*) '      Logical switch for applying tracer increments            ln_trainc = ', ln_trainc
+         WRITE(numout,*) '      Logical switch for applying velocity increments          ln_dyninc = ', ln_dyninc
+         WRITE(numout,*) '      Logical switch for applying SSH increments               ln_sshinc = ', ln_sshinc
+         WRITE(numout,*) '      Logical switch for Direct Initialization (DI)            ln_asmdin = ', ln_asmdin
+         WRITE(numout,*) '      Logical switch for applying sea ice increments        ln_seaiceinc = ', ln_seaiceinc
+         WRITE(numout,*) '      Logical switch for Incremental Analysis Updating (IAU)   ln_asmiau = ', ln_asmiau
+         WRITE(numout,*) '      Timestep of background in [0,nitend-nit000-1]            nitbkg    = ', nitbkg
+         WRITE(numout,*) '      Timestep of background for DI in [0,nitend-nit000-1]     nitdin    = ', nitdin
+         WRITE(numout,*) '      Timestep of start of IAU interval in [0,nitend-nit000-1] nitiaustr = ', nitiaustr
+         WRITE(numout,*) '      Timestep of end of IAU interval in [0,nitend-nit000-1]   nitiaufin = ', nitiaufin
+         WRITE(numout,*) '      Type of IAU weighting function                           niaufn    = ', niaufn
+         WRITE(numout,*) '      Logical switch for ensuring that the sa > salfixmin      ln_salfix = ', ln_salfix
+         WRITE(numout,*) '      Minimum salinity after applying the increments           salfixmin = ', salfixmin
+      ENDIF
+
+      nitbkg_r    = nitbkg    + nit000 - 1            ! Background time referenced to nit000
+      nitdin_r    = nitdin    + nit000 - 1            ! Background time for DI referenced to nit000
+      nitiaustr_r = nitiaustr + nit000 - 1            ! Start of IAU interval referenced to nit000
+      nitiaufin_r = nitiaufin + nit000 - 1            ! End of IAU interval referenced to nit000
+
+      iiauper     = nitiaufin_r - nitiaustr_r + 1     ! IAU interval length
+      icycper     = nitend      - nit000      + 1     ! Cycle interval length
+
+      CALL calc_date( nitend     , ditend_date    )   ! Date of final time step
+      CALL calc_date( nitbkg_r   , ditbkg_date    )   ! Background time for Jb referenced to ndate0
+      CALL calc_date( nitdin_r   , ditdin_date    )   ! Background time for DI referenced to ndate0
+      CALL calc_date( nitiaustr_r, ditiaustr_date )   ! IAU start time referenced to ndate0
+      CALL calc_date( nitiaufin_r, ditiaufin_date )   ! IAU end time referenced to ndate0
+
+      IF(lwp) THEN
+         WRITE(numout,*)
+         WRITE(numout,*) '   Time steps referenced to current cycle:'
+         WRITE(numout,*) '       iitrst      = ', nit000 - 1
+         WRITE(numout,*) '       nit000      = ', nit000
+         WRITE(numout,*) '       nitend      = ', nitend
+         WRITE(numout,*) '       nitbkg_r    = ', nitbkg_r
+         WRITE(numout,*) '       nitdin_r    = ', nitdin_r
+         WRITE(numout,*) '       nitiaustr_r = ', nitiaustr_r
+         WRITE(numout,*) '       nitiaufin_r = ', nitiaufin_r
+         WRITE(numout,*)
+         WRITE(numout,*) '   Dates referenced to current cycle:'
+         WRITE(numout,*) '       ndastp         = ', ndastp
+         WRITE(numout,*) '       ndate0         = ', ndate0
+         WRITE(numout,*) '       nn_time0       = ', nn_time0
+         WRITE(numout,*) '       ditend_date    = ', ditend_date
+         WRITE(numout,*) '       ditbkg_date    = ', ditbkg_date
+         WRITE(numout,*) '       ditdin_date    = ', ditdin_date
+         WRITE(numout,*) '       ditiaustr_date = ', ditiaustr_date
+         WRITE(numout,*) '       ditiaufin_date = ', ditiaufin_date
+      ENDIF
+
+
+      IF ( ( ln_asmdin ).AND.( ln_asmiau ) )   &
+         & CALL ctl_stop( ' ln_asmdin and ln_asmiau :', &
+         &                ' Choose Direct Initialization OR Incremental Analysis Updating')
+
+      IF (      ( ( .NOT. ln_asmdin ).AND.( .NOT. ln_asmiau ) ) &
+           .AND.( ( ln_trainc ).OR.( ln_dyninc ).OR.( ln_sshinc ) .OR. ( ln_seaiceinc) )) &
+         & CALL ctl_stop( ' One or more of ln_trainc, ln_dyninc, ln_sshinc and ln_seaiceinc is set to .true.', &
+         &                ' but ln_asmdin and ln_asmiau are both set to .false. :', &
+         &                ' Inconsistent options')
+
+      IF ( ( niaufn /= 0 ).AND.( niaufn /= 1 ) ) &
+         & CALL ctl_stop( ' niaufn /= 0 or niaufn /=1 :',  &
+         &                ' Type IAU weighting function is invalid')
+
+      IF ( ( .NOT. ln_trainc ).AND.( .NOT. ln_dyninc ).AND.( .NOT. ln_sshinc ).AND.( .NOT. ln_seaiceinc ) &
+         &                     )  &
+         & CALL ctl_warn( ' ln_trainc, ln_dyninc, ln_sshinc and ln_seaiceinc are set to .false. :', &
+         &                ' The assimilation increments are not applied')
+
+      IF ( ( ln_asmiau ).AND.( nitiaustr == nitiaufin ) ) &
+         & CALL ctl_stop( ' nitiaustr = nitiaufin :',  &
+         &                ' IAU interval is of zero length')
+
+      IF ( ( ln_asmiau ).AND.( ( nitiaustr_r < nit000 ).OR.( nitiaufin_r > nitend ) ) ) &
+         & CALL ctl_stop( ' nitiaustr or nitiaufin :',  &
+         &                ' IAU starting or final time step is outside the cycle interval', &
+         &                 ' Valid range nit000 to nitend')
+
+      IF ( ( nitbkg_r < nit000 - 1 ).OR.( nitbkg_r > nitend ) ) &
+         & CALL ctl_stop( ' nitbkg :',  &
+         &                ' Background time step is outside the cycle interval')
+
+      IF ( ( nitdin_r < nit000 - 1 ).OR.( nitdin_r > nitend ) ) &
+         & CALL ctl_stop( ' nitdin :',  &
+         &                ' Background time step for Direct Initialization is outside', &
+         &                ' the cycle interval')
+
+      IF ( nstop > 0 ) RETURN       ! if there are any errors then go no further
+
+      !--------------------------------------------------------------------
+      ! Initialize the Incremental Analysis Updating weighting function
+      !--------------------------------------------------------------------
+
+      IF( ln_asmiau ) THEN
+         !
+         ALLOCATE( wgtiau( icycper ) )
+         !
+         wgtiau(:) = 0._wp
+         !
+         !                                !---------------------------------------------------------
+         IF( niaufn == 0 ) THEN           ! Constant IAU forcing 
+            !                             !---------------------------------------------------------
+            DO jt = 1, iiauper
+               wgtiau(jt+nitiaustr-1) = 1.0 / REAL( iiauper )
+            END DO
+            !                             !---------------------------------------------------------
+         ELSEIF ( niaufn == 1 ) THEN      ! Linear hat-like, centred in middle of IAU interval 
+            !                             !---------------------------------------------------------
+            ! Compute the normalization factor
+            znorm = 0._wp
+            IF( MOD( iiauper, 2 ) == 0 ) THEN   ! Even number of time steps in IAU interval
+               imid = iiauper / 2 
+               DO jt = 1, imid
+                  znorm = znorm + REAL( jt )
+               END DO
+               znorm = 2.0 * znorm
+            ELSE                                ! Odd number of time steps in IAU interval
+               imid = ( iiauper + 1 ) / 2        
+               DO jt = 1, imid - 1
+                  znorm = znorm + REAL( jt )
+               END DO
+               znorm = 2.0 * znorm + REAL( imid )
+            ENDIF
+            znorm = 1.0 / znorm
+            !
+            DO jt = 1, imid - 1
+               wgtiau(jt+nitiaustr-1) = REAL( jt ) * znorm
+            END DO
+            DO jt = imid, iiauper
+               wgtiau(jt+nitiaustr-1) = REAL( iiauper - jt + 1 ) * znorm
+            END DO
+            !
+         ENDIF
+
+         ! Test that the integral of the weights over the weighting interval equals 1
+          IF(lwp) THEN
+             WRITE(numout,*)
+             WRITE(numout,*) 'asm_inc_init : IAU weights'
+             WRITE(numout,*) '~~~~~~~~~~~~'
+             WRITE(numout,*) '             time step         IAU  weight'
+             WRITE(numout,*) '             =========     ====================='
+             ztotwgt = 0.0
+             DO jt = 1, icycper
+                ztotwgt = ztotwgt + wgtiau(jt)
+                WRITE(numout,*) '         ', jt, '       ', wgtiau(jt) 
+             END DO   
+             WRITE(numout,*) '         ==================================='
+             WRITE(numout,*) '         Time-integrated weight = ', ztotwgt
+             WRITE(numout,*) '         ==================================='
+          ENDIF
+         
+      ENDIF
+
+      !--------------------------------------------------------------------
+      ! Allocate and initialize the increment arrays
+      !--------------------------------------------------------------------
+
+      ALLOCATE( t_bkginc     (jpi,jpj,jpk) )   ;   t_bkginc     (:,:,:) = 0._wp
+      ALLOCATE( s_bkginc     (jpi,jpj,jpk) )   ;   s_bkginc     (:,:,:) = 0._wp
+      ALLOCATE( u_bkginc     (jpi,jpj,jpk) )   ;   u_bkginc     (:,:,:) = 0._wp
+      ALLOCATE( v_bkginc     (jpi,jpj,jpk) )   ;   v_bkginc     (:,:,:) = 0._wp
+      ALLOCATE( ssh_bkginc   (jpi,jpj)     )   ;   ssh_bkginc   (:,:)   = 0._wp
+      ALLOCATE( seaice_bkginc(jpi,jpj)     )   ;   seaice_bkginc(:,:)   = 0._wp
+#if defined key_asminc
+      ALLOCATE( ssh_iau      (jpi,jpj)     )   ;   ssh_iau      (:,:)   = 0._wp
+#endif
+#if defined key_cice && defined key_asminc
+      ALLOCATE( ndaice_da    (jpi,jpj)     )   ;   ndaice_da    (:,:)   = 0._wp
+#endif
+      !
+      IF ( ln_trainc .OR. ln_dyninc .OR.   &       !--------------------------------------
+         & ln_sshinc .OR. ln_seaiceinc   ) THEN    ! Read the increments from file
+         !                                         !--------------------------------------
+         CALL iom_open( c_asminc, inum )
+         !
+         CALL iom_get( inum, 'time'       , zdate_inc   ) 
+         CALL iom_get( inum, 'z_inc_dateb', z_inc_dateb )
+         CALL iom_get( inum, 'z_inc_datef', z_inc_datef )
+         z_inc_dateb = zdate_inc
+         z_inc_datef = zdate_inc
+         !
+         IF(lwp) THEN
+            WRITE(numout,*) 
+            WRITE(numout,*) 'asm_inc_init : Assimilation increments valid between dates ', z_inc_dateb,' and ', z_inc_datef
+            WRITE(numout,*) '~~~~~~~~~~~~'
+         ENDIF
+         !
+         IF ( ( z_inc_dateb < ndastp + nn_time0*0.0001_wp ) .OR.   &
+            & ( z_inc_datef > ditend_date ) ) &
+            &    CALL ctl_warn( ' Validity time of assimilation increments is ', &
+            &                   ' outside the assimilation interval' )
+
+         IF ( ( ln_asmdin ).AND.( zdate_inc /= ditdin_date ) ) &
+            & CALL ctl_warn( ' Validity time of assimilation increments does ', &
+            &                ' not agree with Direct Initialization time' )
+
+         IF ( ln_trainc ) THEN   
+            CALL iom_get( inum, jpdom_autoglo, 'bckint', t_bkginc, 1 )
+            CALL iom_get( inum, jpdom_autoglo, 'bckins', s_bkginc, 1 )
+            ! Apply the masks
+            t_bkginc(:,:,:) = t_bkginc(:,:,:) * tmask(:,:,:)
+            s_bkginc(:,:,:) = s_bkginc(:,:,:) * tmask(:,:,:)
+            ! Set missing increments to 0.0 rather than 1e+20
+            ! to allow for differences in masks
+            WHERE( ABS( t_bkginc(:,:,:) ) > 1.0e+10 ) t_bkginc(:,:,:) = 0.0
+            WHERE( ABS( s_bkginc(:,:,:) ) > 1.0e+10 ) s_bkginc(:,:,:) = 0.0
+         ENDIF
+
+         IF ( ln_dyninc ) THEN   
+            CALL iom_get( inum, jpdom_autoglo, 'bckinu', u_bkginc, 1 )              
+            CALL iom_get( inum, jpdom_autoglo, 'bckinv', v_bkginc, 1 )              
+            ! Apply the masks
+            u_bkginc(:,:,:) = u_bkginc(:,:,:) * umask(:,:,:)
+            v_bkginc(:,:,:) = v_bkginc(:,:,:) * vmask(:,:,:)
+            ! Set missing increments to 0.0 rather than 1e+20
+            ! to allow for differences in masks
+            WHERE( ABS( u_bkginc(:,:,:) ) > 1.0e+10 ) u_bkginc(:,:,:) = 0.0
+            WHERE( ABS( v_bkginc(:,:,:) ) > 1.0e+10 ) v_bkginc(:,:,:) = 0.0
+         ENDIF
+        
+         IF ( ln_sshinc ) THEN
+            CALL iom_get( inum, jpdom_autoglo, 'bckineta', ssh_bkginc, 1 )
+            ! Apply the masks
+            ssh_bkginc(:,:) = ssh_bkginc(:,:) * tmask(:,:,1)
+            ! Set missing increments to 0.0 rather than 1e+20
+            ! to allow for differences in masks
+            WHERE( ABS( ssh_bkginc(:,:) ) > 1.0e+10 ) ssh_bkginc(:,:) = 0.0
+         ENDIF
+
+         IF ( ln_seaiceinc ) THEN
+            CALL iom_get( inum, jpdom_autoglo, 'bckinseaice', seaice_bkginc, 1 )
+            ! Apply the masks
+            seaice_bkginc(:,:) = seaice_bkginc(:,:) * tmask(:,:,1)
+            ! Set missing increments to 0.0 rather than 1e+20
+            ! to allow for differences in masks
+            WHERE( ABS( seaice_bkginc(:,:) ) > 1.0e+10 ) seaice_bkginc(:,:) = 0.0
+         ENDIF
+         !
+         CALL iom_close( inum )
+         !
+      ENDIF
+      !
+      !                                            !--------------------------------------
+      IF ( ln_dyninc .AND. nn_divdmp > 0 ) THEN    ! Apply divergence damping filter
+         !                                         !--------------------------------------
+         ALLOCATE( zhdiv(jpi,jpj) ) 
+         !
+         DO jt = 1, nn_divdmp
+            !
+            DO jk = 1, jpkm1           ! zhdiv = e1e1 * div
+               zhdiv(:,:) = 0._wp
+               DO jj = 2, jpjm1
+                  DO ji = fs_2, fs_jpim1   ! vector opt.
+                     zhdiv(ji,jj) = (  e2u(ji  ,jj) * e3u_n(ji  ,jj,jk) * u_bkginc(ji  ,jj,jk)    &
+                        &            - e2u(ji-1,jj) * e3u_n(ji-1,jj,jk) * u_bkginc(ji-1,jj,jk)    &
+                        &            + e1v(ji,jj  ) * e3v_n(ji,jj  ,jk) * v_bkginc(ji,jj  ,jk)    &
+                        &            - e1v(ji,jj-1) * e3v_n(ji,jj-1,jk) * v_bkginc(ji,jj-1,jk)  ) / e3t_n(ji,jj,jk)
+                  END DO
+               END DO
+               CALL lbc_lnk( zhdiv, 'T', 1. )   ! lateral boundary cond. (no sign change)
+               !
+               DO jj = 2, jpjm1
+                  DO ji = fs_2, fs_jpim1   ! vector opt.
+                     u_bkginc(ji,jj,jk) = u_bkginc(ji,jj,jk)                         &
+                        &               + 0.2_wp * ( zhdiv(ji+1,jj) - zhdiv(ji  ,jj) ) * r1_e1u(ji,jj) * umask(ji,jj,jk)
+                     v_bkginc(ji,jj,jk) = v_bkginc(ji,jj,jk)                         &
+                        &               + 0.2_wp * ( zhdiv(ji,jj+1) - zhdiv(ji,jj  ) ) * r1_e2v(ji,jj) * vmask(ji,jj,jk) 
+                  END DO
+               END DO
+            END DO
+            !
+         END DO
+         !
+         DEALLOCATE( zhdiv ) 
+         !
+      ENDIF
+      !
+      !                             !-----------------------------------------------------
+      IF ( ln_asmdin ) THEN         ! Allocate and initialize the background state arrays
+         !                          !-----------------------------------------------------
+         !
+         ALLOCATE( t_bkg  (jpi,jpj,jpk) )   ;   t_bkg  (:,:,:) = 0._wp
+         ALLOCATE( s_bkg  (jpi,jpj,jpk) )   ;   s_bkg  (:,:,:) = 0._wp
+         ALLOCATE( u_bkg  (jpi,jpj,jpk) )   ;   u_bkg  (:,:,:) = 0._wp
+         ALLOCATE( v_bkg  (jpi,jpj,jpk) )   ;   v_bkg  (:,:,:) = 0._wp
+         ALLOCATE( ssh_bkg(jpi,jpj)     )   ;   ssh_bkg(:,:)   = 0._wp
+         !
+         !
+         !--------------------------------------------------------------------
+         ! Read from file the background state at analysis time
+         !--------------------------------------------------------------------
+         !
+         CALL iom_open( c_asmdin, inum )
+         !
+         CALL iom_get( inum, 'rdastp', zdate_bkg ) 
+         !
+         IF(lwp) THEN
+            WRITE(numout,*) 
+            WRITE(numout,*) '   ==>>>  Assimilation background state valid at : ', zdate_bkg
+            WRITE(numout,*)
+         ENDIF
+         !
+         IF ( zdate_bkg /= ditdin_date )   &
+            & CALL ctl_warn( ' Validity time of assimilation background state does', &
+            &                ' not agree with Direct Initialization time' )
+         !
+         IF ( ln_trainc ) THEN   
+            CALL iom_get( inum, jpdom_autoglo, 'tn', t_bkg )
+            CALL iom_get( inum, jpdom_autoglo, 'sn', s_bkg )
+            t_bkg(:,:,:) = t_bkg(:,:,:) * tmask(:,:,:)
+            s_bkg(:,:,:) = s_bkg(:,:,:) * tmask(:,:,:)
+         ENDIF
+         !
+         IF ( ln_dyninc ) THEN   
+            CALL iom_get( inum, jpdom_autoglo, 'un', u_bkg )
+            CALL iom_get( inum, jpdom_autoglo, 'vn', v_bkg )
+            u_bkg(:,:,:) = u_bkg(:,:,:) * umask(:,:,:)
+            v_bkg(:,:,:) = v_bkg(:,:,:) * vmask(:,:,:)
+         ENDIF
+         !
+         IF ( ln_sshinc ) THEN
+            CALL iom_get( inum, jpdom_autoglo, 'sshn', ssh_bkg )
+            ssh_bkg(:,:) = ssh_bkg(:,:) * tmask(:,:,1)
+         ENDIF
+         !
+         CALL iom_close( inum )
+         !
+      ENDIF
+      !
+      IF(lwp) WRITE(numout,*) '   ==>>>   Euler time step switch is ', neuler
+      !
+      IF( lk_asminc ) THEN                            !==  data assimilation  ==!
+         IF( ln_bkgwri )   CALL asm_bkg_wri( nit000 - 1 )      ! Output background fields
+         IF( ln_asmdin ) THEN                                  ! Direct initialization
+            IF( ln_trainc )   CALL tra_asm_inc( nit000 - 1 )      ! Tracers
+            IF( ln_dyninc )   CALL dyn_asm_inc( nit000 - 1 )      ! Dynamics
+            IF( ln_sshinc )   CALL ssh_asm_inc( nit000 - 1 )      ! SSH
+         ENDIF
+      ENDIF
+      !
+   END SUBROUTINE asm_inc_init
+   
+   
+   SUBROUTINE tra_asm_inc( kt )
+      !!----------------------------------------------------------------------
+      !!                    ***  ROUTINE tra_asm_inc  ***
+      !!          
+      !! ** Purpose : Apply the tracer (T and S) assimilation increments
+      !!
+      !! ** Method  : Direct initialization or Incremental Analysis Updating
+      !!
+      !! ** Action  : 
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT(IN) ::   kt   ! Current time step
+      !
+      INTEGER  :: ji, jj, jk
+      INTEGER  :: it
+      REAL(wp) :: zincwgt  ! IAU weight for current time step
+      REAL (wp), DIMENSION(jpi,jpj,jpk) :: fzptnz ! 3d freezing point values
+      !!----------------------------------------------------------------------
+      !
+      ! freezing point calculation taken from oc_fz_pt (but calculated for all depths) 
+      ! used to prevent the applied increments taking the temperature below the local freezing point 
+      DO jk = 1, jpkm1
+        CALL eos_fzp( tsn(:,:,jk,jp_sal), fzptnz(:,:,jk), gdept_n(:,:,jk) )
+      END DO
+         !
+         !                             !--------------------------------------
+      IF ( ln_asmiau ) THEN            ! Incremental Analysis Updating
+         !                             !--------------------------------------
+         !
+         IF ( ( kt >= nitiaustr_r ).AND.( kt <= nitiaufin_r ) ) THEN
+            !
+            it = kt - nit000 + 1
+            zincwgt = wgtiau(it) / rdt   ! IAU weight for the current time step
+            !
+            IF(lwp) THEN
+               WRITE(numout,*) 
+               WRITE(numout,*) 'tra_asm_inc : Tracer IAU at time step = ', kt,' with IAU weight = ', wgtiau(it)
+               WRITE(numout,*) '~~~~~~~~~~~~'
+            ENDIF
+            !
+            ! Update the tracer tendencies
+            DO jk = 1, jpkm1
+               IF (ln_temnofreeze) THEN
+                  ! Do not apply negative increments if the temperature will fall below freezing
+                  WHERE(t_bkginc(:,:,jk) > 0.0_wp .OR. &
+                     &   tsn(:,:,jk,jp_tem) + tsa(:,:,jk,jp_tem) + t_bkginc(:,:,jk) * wgtiau(it) > fzptnz(:,:,jk) ) 
+                     tsa(:,:,jk,jp_tem) = tsa(:,:,jk,jp_tem) + t_bkginc(:,:,jk) * zincwgt  
+                  END WHERE
+               ELSE
+                  tsa(:,:,jk,jp_tem) = tsa(:,:,jk,jp_tem) + t_bkginc(:,:,jk) * zincwgt  
+               ENDIF
+               IF (ln_salfix) THEN
+                  ! Do not apply negative increments if the salinity will fall below a specified
+                  ! minimum value salfixmin
+                  WHERE(s_bkginc(:,:,jk) > 0.0_wp .OR. &
+                     &   tsn(:,:,jk,jp_sal) + tsa(:,:,jk,jp_sal) + s_bkginc(:,:,jk) * wgtiau(it) > salfixmin ) 
+                     tsa(:,:,jk,jp_sal) = tsa(:,:,jk,jp_sal) + s_bkginc(:,:,jk) * zincwgt
+                  END WHERE
+               ELSE
+                  tsa(:,:,jk,jp_sal) = tsa(:,:,jk,jp_sal) + s_bkginc(:,:,jk) * zincwgt
+               ENDIF
+            END DO
+            !
+         ENDIF
+         !
+         IF ( kt == nitiaufin_r + 1  ) THEN   ! For bias crcn to work
+            DEALLOCATE( t_bkginc )
+            DEALLOCATE( s_bkginc )
+         ENDIF
+         !                             !--------------------------------------
+      ELSEIF ( ln_asmdin ) THEN        ! Direct Initialization
+         !                             !--------------------------------------
+         !            
+         IF ( kt == nitdin_r ) THEN
+            !
+            neuler = 0  ! Force Euler forward step
+            !
+            ! Initialize the now fields with the background + increment
+            IF (ln_temnofreeze) THEN
+               ! Do not apply negative increments if the temperature will fall below freezing
+               WHERE( t_bkginc(:,:,:) > 0.0_wp .OR. tsn(:,:,:,jp_tem) + t_bkginc(:,:,:) > fzptnz(:,:,:) ) 
+                  tsn(:,:,:,jp_tem) = t_bkg(:,:,:) + t_bkginc(:,:,:)   
+               END WHERE
+            ELSE
+               tsn(:,:,:,jp_tem) = t_bkg(:,:,:) + t_bkginc(:,:,:)   
+            ENDIF
+            IF (ln_salfix) THEN
+               ! Do not apply negative increments if the salinity will fall below a specified
+               ! minimum value salfixmin
+               WHERE( s_bkginc(:,:,:) > 0.0_wp .OR. tsn(:,:,:,jp_sal) + s_bkginc(:,:,:) > salfixmin ) 
+                  tsn(:,:,:,jp_sal) = s_bkg(:,:,:) + s_bkginc(:,:,:)   
+               END WHERE
+            ELSE
+               tsn(:,:,:,jp_sal) = s_bkg(:,:,:) + s_bkginc(:,:,:)   
+            ENDIF
+
+            tsb(:,:,:,:) = tsn(:,:,:,:)                 ! Update before fields
+
+            CALL eos( tsb, rhd, rhop, gdept_0(:,:,:) )  ! Before potential and in situ densities
+!!gm  fabien
+!            CALL eos( tsb, rhd, rhop )                ! Before potential and in situ densities
+!!gm
+
+            IF( ln_zps .AND. .NOT. lk_c1d .AND. .NOT. ln_isfcav)      &
+               &  CALL zps_hde    ( kt, jpts, tsb, gtsu, gtsv,        &  ! Partial steps: before horizontal gradient
+               &                              rhd, gru , grv          )  ! of t, s, rd at the last ocean level
+            IF( ln_zps .AND. .NOT. lk_c1d .AND.       ln_isfcav)      &
+               &  CALL zps_hde_isf( nit000, jpts, tsb, gtsu, gtsv, gtui, gtvi,    &    ! Partial steps for top cell (ISF)
+               &                                  rhd, gru , grv , grui, grvi     )    ! of t, s, rd at the last ocean level
+
+            DEALLOCATE( t_bkginc )
+            DEALLOCATE( s_bkginc )
+            DEALLOCATE( t_bkg    )
+            DEALLOCATE( s_bkg    )
+         ENDIF
+         !  
+      ENDIF
+      ! Perhaps the following call should be in step
+      IF ( ln_seaiceinc  )   CALL seaice_asm_inc ( kt )   ! apply sea ice concentration increment
+      !
+   END SUBROUTINE tra_asm_inc
+
+
+   SUBROUTINE dyn_asm_inc( kt )
+      !!----------------------------------------------------------------------
+      !!                    ***  ROUTINE dyn_asm_inc  ***
+      !!          
+      !! ** Purpose : Apply the dynamics (u and v) assimilation increments.
+      !!
+      !! ** Method  : Direct initialization or Incremental Analysis Updating.
+      !!
+      !! ** Action  : 
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT(IN) :: kt   ! Current time step
+      !
+      INTEGER :: jk
+      INTEGER :: it
+      REAL(wp) :: zincwgt  ! IAU weight for current time step
+      !!----------------------------------------------------------------------
+      !
+      !                          !--------------------------------------------
+      IF ( ln_asmiau ) THEN      ! Incremental Analysis Updating
+         !                       !--------------------------------------------
+         !
+         IF ( ( kt >= nitiaustr_r ).AND.( kt <= nitiaufin_r ) ) THEN
+            !
+            it = kt - nit000 + 1
+            zincwgt = wgtiau(it) / rdt   ! IAU weight for the current time step
+            !
+            IF(lwp) THEN
+               WRITE(numout,*) 
+               WRITE(numout,*) 'dyn_asm_inc : Dynamics IAU at time step = ', kt,' with IAU weight = ', wgtiau(it)
+               WRITE(numout,*) '~~~~~~~~~~~~'
+            ENDIF
+            !
+            ! Update the dynamic tendencies
+            DO jk = 1, jpkm1
+               ua(:,:,jk) = ua(:,:,jk) + u_bkginc(:,:,jk) * zincwgt
+               va(:,:,jk) = va(:,:,jk) + v_bkginc(:,:,jk) * zincwgt
+            END DO
+            !
+            IF ( kt == nitiaufin_r ) THEN
+               DEALLOCATE( u_bkginc )
+               DEALLOCATE( v_bkginc )
+            ENDIF
+            !
+         ENDIF
+         !                          !-----------------------------------------
+      ELSEIF ( ln_asmdin ) THEN     ! Direct Initialization
+         !                          !-----------------------------------------
+         !         
+         IF ( kt == nitdin_r ) THEN
+            !
+            neuler = 0                    ! Force Euler forward step
+            !
+            ! Initialize the now fields with the background + increment
+            un(:,:,:) = u_bkg(:,:,:) + u_bkginc(:,:,:)
+            vn(:,:,:) = v_bkg(:,:,:) + v_bkginc(:,:,:)  
+            !
+            ub(:,:,:) = un(:,:,:)         ! Update before fields
+            vb(:,:,:) = vn(:,:,:)
+            !
+            DEALLOCATE( u_bkg    )
+            DEALLOCATE( v_bkg    )
+            DEALLOCATE( u_bkginc )
+            DEALLOCATE( v_bkginc )
+         ENDIF
+         !
+      ENDIF
+      !
+   END SUBROUTINE dyn_asm_inc
+
+
+   SUBROUTINE ssh_asm_inc( kt )
+      !!----------------------------------------------------------------------
+      !!                    ***  ROUTINE ssh_asm_inc  ***
+      !!          
+      !! ** Purpose : Apply the sea surface height assimilation increment.
+      !!
+      !! ** Method  : Direct initialization or Incremental Analysis Updating.
+      !!
+      !! ** Action  : 
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT(IN) :: kt   ! Current time step
+      !
+      INTEGER :: it
+      INTEGER :: jk
+      REAL(wp) :: zincwgt  ! IAU weight for current time step
+      !!----------------------------------------------------------------------
+      !
+      !                             !-----------------------------------------
+      IF ( ln_asmiau ) THEN         ! Incremental Analysis Updating
+         !                          !-----------------------------------------
+         !
+         IF ( ( kt >= nitiaustr_r ).AND.( kt <= nitiaufin_r ) ) THEN
+            !
+            it = kt - nit000 + 1
+            zincwgt = wgtiau(it) / rdt   ! IAU weight for the current time step
+            !
+            IF(lwp) THEN
+               WRITE(numout,*) 
+               WRITE(numout,*) 'ssh_asm_inc : SSH IAU at time step = ', &
+                  &  kt,' with IAU weight = ', wgtiau(it)
+               WRITE(numout,*) '~~~~~~~~~~~~'
+            ENDIF
+            !
+            ! Save the tendency associated with the IAU weighted SSH increment
+            ! (applied in dynspg.*)
+#if defined key_asminc
+            ssh_iau(:,:) = ssh_bkginc(:,:) * zincwgt
+#endif
+            !
+         ELSE IF( kt == nitiaufin_r+1 ) THEN
+            !
+            ! test on ssh_bkginc needed as ssh_asm_inc is called twice by time step
+            IF (ALLOCATED(ssh_bkginc)) DEALLOCATE( ssh_bkginc )
+            !
+#if defined key_asminc
+            ssh_iau(:,:) = 0._wp
+#endif
+            !
+         ENDIF
+         !                          !-----------------------------------------
+      ELSEIF ( ln_asmdin ) THEN     ! Direct Initialization
+         !                          !-----------------------------------------
+         !
+         IF ( kt == nitdin_r ) THEN
+            !
+            neuler = 0                                   ! Force Euler forward step
+            !
+            sshn(:,:) = ssh_bkg(:,:) + ssh_bkginc(:,:)   ! Initialize the now fields the background + increment
+            !
+            sshb(:,:) = sshn(:,:)                        ! Update before fields
+            e3t_b(:,:,:) = e3t_n(:,:,:)
+!!gm why not e3u_b, e3v_b, gdept_b ????
+            !
+            DEALLOCATE( ssh_bkg    )
+            DEALLOCATE( ssh_bkginc )
+            !
+         ENDIF
+         !
+      ENDIF
+      !
+   END SUBROUTINE ssh_asm_inc
+
+
+   SUBROUTINE ssh_asm_div( kt, phdivn )
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE ssh_asm_div  ***
+      !!
+      !! ** Purpose :   ssh increment with z* is incorporated via a correction of the local divergence          
+      !!                across all the water column
+      !!
+      !! ** Method  :
+      !!                CAUTION : sshiau is positive (inflow) decreasing the
+      !!                          divergence and expressed in m/s
+      !!
+      !! ** Action  :   phdivn   decreased by the ssh increment
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT(IN) :: kt                               ! ocean time-step index
+      REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   phdivn   ! horizontal divergence
+      !!
+      INTEGER  ::   jk                                        ! dummy loop index
+      REAL(wp), DIMENSION(:,:)  , POINTER       ::   ztim     ! local array
+      !!----------------------------------------------------------------------
+      ! 
+#if defined key_asminc
+      CALL ssh_asm_inc( kt ) !==   (calculate increments)
+      !
+      IF( ln_linssh ) THEN 
+         phdivn(:,:,1) = phdivn(:,:,1) - ssh_iau(:,:) / e3t_n(:,:,1) * tmask(:,:,1)
+      ELSE 
+         ALLOCATE( ztim(jpi,jpj) )
+         ztim(:,:) = ssh_iau(:,:) / ( ht_n(:,:) + 1.0 - ssmask(:,:) )
+         DO jk = 1, jpkm1                                 
+            phdivn(:,:,jk) = phdivn(:,:,jk) - ztim(:,:) * tmask(:,:,jk) 
+         END DO
+         !
+         DEALLOCATE(ztim)
+      ENDIF
+#endif
+      !
+   END SUBROUTINE ssh_asm_div
+
+
+   SUBROUTINE seaice_asm_inc( kt, kindic )
+      !!----------------------------------------------------------------------
+      !!                    ***  ROUTINE seaice_asm_inc  ***
+      !!          
+      !! ** Purpose : Apply the sea ice assimilation increment.
+      !!
+      !! ** Method  : Direct initialization or Incremental Analysis Updating.
+      !!
+      !! ** Action  : 
+      !!
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT(in)           ::   kt       ! Current time step
+      INTEGER, INTENT(in), OPTIONAL ::   kindic   ! flag for disabling the deallocation
+      !
+      INTEGER  ::   it
+      REAL(wp) ::   zincwgt   ! IAU weight for current time step
+#if defined key_si3
+      REAL(wp), DIMENSION(jpi,jpj) ::   zofrld, zohicif, zseaicendg, zhicifinc  ! LIM
+      REAL(wp) ::   zhicifmin = 0.5_wp      ! ice minimum depth in metres
+#endif
+      !!----------------------------------------------------------------------
+      !
+      !                             !-----------------------------------------
+      IF ( ln_asmiau ) THEN         ! Incremental Analysis Updating
+         !                          !-----------------------------------------
+         !
+         IF ( ( kt >= nitiaustr_r ).AND.( kt <= nitiaufin_r ) ) THEN
+            !
+            it = kt - nit000 + 1
+            zincwgt = wgtiau(it)      ! IAU weight for the current time step 
+            ! note this is not a tendency so should not be divided by rdt (as with the tracer and other increments)
+            !
+            IF(lwp) THEN
+               WRITE(numout,*) 
+               WRITE(numout,*) 'seaice_asm_inc : sea ice conc IAU at time step = ', kt,' with IAU weight = ', wgtiau(it)
+               WRITE(numout,*) '~~~~~~~~~~~~'
+            ENDIF
+            !
+            ! Sea-ice : LIM-3 case
+            !
+#if defined key_si3
+            zofrld (:,:) = 1._wp - at_i(:,:)
+            zohicif(:,:) = hm_i(:,:)
+            !
+            at_i  (:,:) = 1. - MIN( MAX( 1.-at_i  (:,:) - seaice_bkginc(:,:) * zincwgt, 0.0_wp), 1.0_wp)
+            at_i_b(:,:) = 1. - MIN( MAX( 1.-at_i_b(:,:) - seaice_bkginc(:,:) * zincwgt, 0.0_wp), 1.0_wp)
+            fr_i(:,:) = at_i(:,:)        ! adjust ice fraction
+            !
+            zseaicendg(:,:) = zofrld(:,:) - (1. - at_i(:,:))   ! find out actual sea ice nudge applied
+            !
+            ! Nudge sea ice depth to bring it up to a required minimum depth
+            WHERE( zseaicendg(:,:) > 0.0_wp .AND. hm_i(:,:) < zhicifmin ) 
+               zhicifinc(:,:) = (zhicifmin - hm_i(:,:)) * zincwgt    
+            ELSEWHERE
+               zhicifinc(:,:) = 0.0_wp
+            END WHERE
+            !
+            ! nudge ice depth
+            hm_i (:,:) = hm_i (:,:) + zhicifinc(:,:)
+            !
+            ! seaice salinity balancing (to add)
+#endif
+            !
+#if defined key_cice && defined key_asminc
+            ! Sea-ice : CICE case. Pass ice increment tendency into CICE
+            ndaice_da(:,:) = seaice_bkginc(:,:) * zincwgt / rdt
+#endif
+            !
+            IF ( kt == nitiaufin_r ) THEN
+               DEALLOCATE( seaice_bkginc )
+            ENDIF
+            !
+         ELSE
+            !
+#if defined key_cice && defined key_asminc
+            ndaice_da(:,:) = 0._wp        ! Sea-ice : CICE case. Zero ice increment tendency into CICE
+#endif
+            !
+         ENDIF
+         !                          !-----------------------------------------
+      ELSEIF ( ln_asmdin ) THEN     ! Direct Initialization
+         !                          !-----------------------------------------
+         !
+         IF ( kt == nitdin_r ) THEN
+            !
+            neuler = 0                    ! Force Euler forward step
+            !
+            ! Sea-ice : LIM-3 case
+            !
+#if defined key_si3
+            zofrld (:,:) = 1._wp - at_i(:,:)
+            zohicif(:,:) = hm_i(:,:)
+            ! 
+            ! Initialize the now fields the background + increment
+            at_i(:,:) = 1. - MIN( MAX( 1.-at_i(:,:) - seaice_bkginc(:,:), 0.0_wp), 1.0_wp)
+            at_i_b(:,:) = at_i(:,:) 
+            fr_i(:,:) = at_i(:,:)        ! adjust ice fraction
+            !
+            zseaicendg(:,:) = zofrld(:,:) - (1. - at_i(:,:))   ! find out actual sea ice nudge applied
+            !
+            ! Nudge sea ice depth to bring it up to a required minimum depth
+            WHERE( zseaicendg(:,:) > 0.0_wp .AND. hm_i(:,:) < zhicifmin ) 
+               zhicifinc(:,:) = (zhicifmin - hm_i(:,:)) * zincwgt    
+            ELSEWHERE
+               zhicifinc(:,:) = 0.0_wp
+            END WHERE
+            !
+            ! nudge ice depth
+            hm_i (:,:) = hm_i (:,:) + zhicifinc(:,:)
+            !
+            ! seaice salinity balancing (to add)
+#endif
+            !
+#if defined key_cice && defined key_asminc
+            ! Sea-ice : CICE case. Pass ice increment tendency into CICE
+           ndaice_da(:,:) = seaice_bkginc(:,:) / rdt
+#endif
+            IF ( .NOT. PRESENT(kindic) ) THEN
+               DEALLOCATE( seaice_bkginc )
+            END IF
+            !
+         ELSE
+            !
+#if defined key_cice && defined key_asminc
+            ndaice_da(:,:) = 0._wp     ! Sea-ice : CICE case. Zero ice increment tendency into CICE
+#endif
+            !
+         ENDIF
+
+!#if defined defined key_si3 || defined key_cice
+!
+!            IF (ln_seaicebal ) THEN       
+!             !! balancing salinity increments
+!             !! simple case from limflx.F90 (doesn't include a mass flux)
+!             !! assumption is that as ice concentration is reduced or increased
+!             !! the snow and ice depths remain constant
+!             !! note that snow is being created where ice concentration is being increased
+!             !! - could be more sophisticated and
+!             !! not do this (but would need to alter h_snow)
+!
+!             usave(:,:,:)=sb(:,:,:)   ! use array as a temporary store
+!
+!             DO jj = 1, jpj
+!               DO ji = 1, jpi 
+!           ! calculate change in ice and snow mass per unit area
+!           ! positive values imply adding salt to the ocean (results from ice formation)
+!           ! fwf : ice formation and melting
+!
+!                 zfons = ( -nfresh_da(ji,jj)*soce + nfsalt_da(ji,jj) )*rdt
+!
+!           ! change salinity down to mixed layer depth
+!                 mld=hmld_kara(ji,jj)
+!
+!           ! prevent small mld
+!           ! less than 10m can cause salinity instability 
+!                 IF (mld < 10) mld=10
+!
+!           ! set to bottom of a level 
+!                 DO jk = jpk-1, 2, -1
+!                   IF ((mld > gdepw(ji,jj,jk)) .and. (mld < gdepw(ji,jj,jk+1))) THEN 
+!                     mld=gdepw(ji,jj,jk+1)
+!                     jkmax=jk
+!                   ENDIF
+!                 ENDDO
+!
+!            ! avoid applying salinity balancing in shallow water or on land
+!            ! 
+!
+!            ! dsal_ocn (psu kg m^-2) / (kg m^-3 * m)
+!
+!                 dsal_ocn=0.0_wp
+!                 sal_thresh=5.0_wp        ! minimum salinity threshold for salinity balancing
+!
+!                 if (tmask(ji,jj,1) > 0 .AND. tmask(ji,jj,jkmax) > 0 ) &
+!                              dsal_ocn = zfons / (rhop(ji,jj,1) * mld)
+!
+!           ! put increments in for levels in the mixed layer
+!           ! but prevent salinity below a threshold value 
+!
+!                   DO jk = 1, jkmax              
+!
+!                     IF (dsal_ocn > 0.0_wp .or. sb(ji,jj,jk)+dsal_ocn > sal_thresh) THEN 
+!                           sb(ji,jj,jk) = sb(ji,jj,jk) + dsal_ocn
+!                           sn(ji,jj,jk) = sn(ji,jj,jk) + dsal_ocn
+!                     ENDIF
+!
+!                   ENDDO
+!
+!      !            !  salt exchanges at the ice/ocean interface
+!      !            zpmess         = zfons / rdt_ice    ! rdt_ice is ice timestep
+!      !
+!      !! Adjust fsalt. A +ve fsalt means adding salt to ocean
+!      !!           fsalt(ji,jj) =  fsalt(ji,jj) + zpmess     ! adjust fsalt  
+!      !!               
+!      !!           emps(ji,jj) = emps(ji,jj) + zpmess        ! or adjust emps (see icestp1d) 
+!      !!                                                     ! E-P (kg m-2 s-2)
+!      !            emp(ji,jj) = emp(ji,jj) + zpmess          ! E-P (kg m-2 s-2)
+!               ENDDO !ji
+!             ENDDO !jj!
+!
+!            ENDIF !ln_seaicebal
+!
+!#endif
+         !
+      ENDIF
+      !
+   END SUBROUTINE seaice_asm_inc
+   
+   !!======================================================================
+END MODULE asminc
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/ASM/asmpar.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/ASM/asmpar.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/ASM/asmpar.F90	(revision 9570)
@@ -0,0 +1,29 @@
+MODULE asmpar
+   !!======================================================================
+   !!                       ***  MODULE asmpar  ***
+   !! Assimilation increment : Parameters for assimilation interface
+   !!======================================================================
+
+   IMPLICIT NONE
+   PRIVATE
+
+   CHARACTER(LEN=40), PUBLIC, PARAMETER ::   c_asmbkg = 'assim_background_state_Jb'   !: Filename for storing the background state
+   !                                                                                  !  for use in the Jb term
+   CHARACTER(LEN=40), PUBLIC, PARAMETER ::   c_asmdin = 'assim_background_state_DI'   !: Filename for storing the background state
+   !                                                                                  !  for direct initialization
+   CHARACTER(LEN=40), PUBLIC, PARAMETER ::   c_asmtrj = 'assim_trj'                   !: Filename for storing the reference trajectory
+   CHARACTER(LEN=40), PUBLIC, PARAMETER ::   c_asminc = 'assim_background_increments' !: Filename for storing the increments 
+   !                                                                                  !  to the background state
+
+   INTEGER, PUBLIC ::   nitbkg_r      !: Background time step referenced to nit000
+   INTEGER, PUBLIC ::   nitdin_r      !: Direct Initialization time step referenced to nit000
+   INTEGER, PUBLIC ::   nitiaustr_r   !: IAU starting time step referenced to nit000
+   INTEGER, PUBLIC ::   nitiaufin_r   !: IAU final time step referenced to nit000
+   INTEGER, PUBLIC ::   nittrjfrq     !: Frequency of trajectory output for 4D-VAR
+
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO Consortium (2010)
+   !! $Id$
+   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
+   !!======================================================================
+END MODULE asmpar
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/BDY/bdy_oce.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/BDY/bdy_oce.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/BDY/bdy_oce.F90	(revision 9570)
@@ -0,0 +1,169 @@
+MODULE bdy_oce
+   !!======================================================================
+   !!                       ***  MODULE bdy_oce   ***
+   !! Unstructured Open Boundary Cond. :   define related variables
+   !!======================================================================
+   !! History :  1.0  !  2001-05  (J. Chanut, A. Sellar)  Original code
+   !!            3.0  !  2008-04  (NEMO team)  add in the reference version     
+   !!            3.3  !  2010-09  (D. Storkey) add ice boundary conditions
+   !!            3.4  !  2011     (D. Storkey) rewrite in preparation for OBC-BDY merge
+   !!            3.6  !  2014-01  (C. Rousset) add ice boundary conditions for lim3
+   !!----------------------------------------------------------------------
+   USE par_oce         ! ocean parameters
+   USE lib_mpp         ! distributed memory computing
+
+   IMPLICIT NONE
+   PUBLIC
+
+   INTEGER, PUBLIC, PARAMETER ::   jp_bdy  = 10       !: Maximum number of bdy sets
+   INTEGER, PUBLIC, PARAMETER ::   jpbgrd  = 3        !: Number of horizontal grid types used  (T, U, V)
+
+   TYPE, PUBLIC ::   OBC_INDEX    !: Indices and weights which define the open boundary
+      INTEGER ,          DIMENSION(jpbgrd) ::  nblen
+      INTEGER ,          DIMENSION(jpbgrd) ::  nblenrim
+      INTEGER , POINTER, DIMENSION(:,:)    ::  nbi
+      INTEGER , POINTER, DIMENSION(:,:)    ::  nbj
+      INTEGER , POINTER, DIMENSION(:,:)    ::  nbr
+      INTEGER , POINTER, DIMENSION(:,:)    ::  nbmap
+      REAL(wp), POINTER, DIMENSION(:,:)    ::  nbw
+      REAL(wp), POINTER, DIMENSION(:,:)    ::  nbd
+      REAL(wp), POINTER, DIMENSION(:,:)    ::  nbdout
+      REAL(wp), POINTER, DIMENSION(:,:)    ::  flagu
+      REAL(wp), POINTER, DIMENSION(:,:)    ::  flagv
+   END TYPE OBC_INDEX
+
+   !! Logicals in OBC_DATA structure are true if the chosen algorithm requires this
+   !! field as external data. If true the data can come from external files
+   !! or model initial conditions. If false then no "external" data array
+   !! is required for this field. 
+
+   TYPE, PUBLIC ::   OBC_DATA     !: Storage for external data
+      INTEGER          , DIMENSION(2)   ::  nread
+      LOGICAL                           ::  ll_ssh
+      LOGICAL                           ::  ll_u2d
+      LOGICAL                           ::  ll_v2d
+      LOGICAL                           ::  ll_u3d
+      LOGICAL                           ::  ll_v3d
+      LOGICAL                           ::  ll_tem
+      LOGICAL                           ::  ll_sal
+      LOGICAL                           ::  ll_fvl
+      REAL(wp), POINTER, DIMENSION(:)   ::  ssh
+      REAL(wp), POINTER, DIMENSION(:)   ::  u2d
+      REAL(wp), POINTER, DIMENSION(:)   ::  v2d
+      REAL(wp), POINTER, DIMENSION(:,:) ::  u3d
+      REAL(wp), POINTER, DIMENSION(:,:) ::  v3d
+      REAL(wp), POINTER, DIMENSION(:,:) ::  tem
+      REAL(wp), POINTER, DIMENSION(:,:) ::  sal
+#if defined key_si3
+      LOGICAL                           ::   ll_a_i
+      LOGICAL                           ::   ll_h_i
+      LOGICAL                           ::   ll_h_s
+      REAL(wp), POINTER, DIMENSION(:,:) ::   a_i    !: now ice leads fraction climatology
+      REAL(wp), POINTER, DIMENSION(:,:) ::   h_i    !: Now ice  thickness climatology
+      REAL(wp), POINTER, DIMENSION(:,:) ::   h_s    !: now snow thickness
+#endif
+#if defined key_top
+      CHARACTER(LEN=20)                   :: cn_obc  !: type of boundary condition to apply
+      REAL(wp)                            :: rn_fac  !: multiplicative scaling factor
+      REAL(wp), POINTER, DIMENSION(:,:)   :: trc     !: now field of the tracer
+      LOGICAL                             :: dmp     !: obc damping term
+#endif
+   END TYPE OBC_DATA
+
+   !!----------------------------------------------------------------------
+   !! Namelist variables
+   !!----------------------------------------------------------------------
+   LOGICAL, PUBLIC            ::   ln_bdy                   !: Unstructured Ocean Boundary Condition
+
+   CHARACTER(len=80), DIMENSION(jp_bdy) ::   cn_coords_file !: Name of bdy coordinates file
+   CHARACTER(len=80)                    ::   cn_mask_file   !: Name of bdy mask file
+   !
+   LOGICAL, DIMENSION(jp_bdy) ::   ln_coords_file           !: =T read bdy coordinates from file; 
+   !                                                        !: =F read bdy coordinates from namelist
+   LOGICAL                    ::   ln_mask_file             !: =T read bdymask from file
+   LOGICAL                    ::   ln_vol                   !: =T volume correction             
+   !
+   INTEGER                    ::   nb_bdy                   !: number of open boundary sets
+   INTEGER                    ::   nb_jpk_bdy               !: number of levels in the bdy data (set < 0 if consistent with planned run)
+   INTEGER, DIMENSION(jp_bdy) ::   nn_rimwidth              !: boundary rim width for Flow Relaxation Scheme
+   INTEGER                    ::   nn_volctl                !: = 0 the total volume will have the variability of the surface Flux E-P 
+   !                                                        !  = 1 the volume will be constant during all the integration.
+   CHARACTER(len=20), DIMENSION(jp_bdy) ::   cn_dyn2d       ! Choice of boundary condition for barotropic variables (U,V,SSH)
+   INTEGER, DIMENSION(jp_bdy)           ::   nn_dyn2d_dta   !: = 0 use the initial state as bdy dta ; 
+                                                            !: = 1 read it in a NetCDF file
+                                                            !: = 2 read tidal harmonic forcing from a NetCDF file
+                                                            !: = 3 read external data AND tidal harmonic forcing from NetCDF files
+   CHARACTER(len=20), DIMENSION(jp_bdy) ::   cn_dyn3d       ! Choice of boundary condition for baroclinic velocities 
+   INTEGER, DIMENSION(jp_bdy)           ::   nn_dyn3d_dta   !: = 0 use the initial state as bdy dta ; 
+                                                            !: = 1 read it in a NetCDF file
+   CHARACTER(len=20), DIMENSION(jp_bdy) ::   cn_tra         ! Choice of boundary condition for active tracers (T and S)
+   INTEGER, DIMENSION(jp_bdy)           ::   nn_tra_dta     !: = 0 use the initial state as bdy dta ; 
+                                                            !: = 1 read it in a NetCDF file
+   LOGICAL , DIMENSION(jp_bdy) ::   ln_tra_dmp              !: =T Tracer damping
+   LOGICAL , DIMENSION(jp_bdy) ::   ln_dyn3d_dmp            !: =T Baroclinic velocity damping
+   REAL(wp), DIMENSION(jp_bdy) ::   rn_time_dmp             !: Damping time scale in days
+   REAL(wp), DIMENSION(jp_bdy) ::   rn_time_dmp_out         !: Damping time scale in days at radiation outflow points
+
+   CHARACTER(len=20), DIMENSION(jp_bdy) ::   cn_ice_lim       ! Choice of boundary condition for sea ice variables 
+   INTEGER , DIMENSION(jp_bdy)          ::   nn_ice_lim_dta   !: = 0 use the initial state as bdy dta ; 
+                                                              !: = 1 read it in a NetCDF file
+   REAL(wp), DIMENSION(jp_bdy) ::   rn_ice_tem              !: choice of the temperature of incoming sea ice
+   REAL(wp), DIMENSION(jp_bdy) ::   rn_ice_sal              !: choice of the salinity    of incoming sea ice
+   REAL(wp), DIMENSION(jp_bdy) ::   rn_ice_age              !: choice of the age         of incoming sea ice
+   !
+   
+   !!----------------------------------------------------------------------
+   !! Global variables
+   !!----------------------------------------------------------------------
+   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), TARGET ::   bdytmask   !: Mask defining computational domain at T-points
+   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), TARGET ::   bdyumask   !: Mask defining computational domain at U-points
+   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), TARGET ::   bdyvmask   !: Mask defining computational domain at V-points
+
+   REAL(wp)                                    ::   bdysurftot !: Lateral surface of unstructured open boundary
+
+   !!----------------------------------------------------------------------
+   !! open boundary data variables
+   !!----------------------------------------------------------------------
+
+   INTEGER,  DIMENSION(jp_bdy)                     ::   nn_dta            !: =0 => *all* data is set to initial conditions
+                                                                          !: =1 => some data to be read in from data files
+   REAL(wp), ALLOCATABLE, DIMENSION(:,:,:), TARGET ::   dta_global        !: workspace for reading in global data arrays (unstr.  bdy)
+   REAL(wp), ALLOCATABLE, DIMENSION(:,:,:), TARGET ::   dta_global_z      !: workspace for reading in global depth arrays (unstr.  bdy)
+   REAL(wp), ALLOCATABLE, DIMENSION(:,:,:), TARGET ::   dta_global_dz     !: workspace for reading in global depth arrays (unstr.  bdy)
+   REAL(wp), ALLOCATABLE, DIMENSION(:,:,:), TARGET ::   dta_global2       !: workspace for reading in global data arrays (struct. bdy)
+   REAL(wp), ALLOCATABLE, DIMENSION(:,:,:), TARGET ::   dta_global2_z     !: workspace for reading in global depth arrays (struct. bdy)
+   REAL(wp), ALLOCATABLE, DIMENSION(:,:,:), TARGET ::   dta_global2_dz    !: workspace for reading in global depth arrays (struct. bdy)
+!$AGRIF_DO_NOT_TREAT
+   TYPE(OBC_INDEX), DIMENSION(jp_bdy), TARGET      ::   idx_bdy           !: bdy indices (local process)
+   TYPE(OBC_DATA) , DIMENSION(jp_bdy), TARGET      ::   dta_bdy           !: bdy external data (local process)
+!$AGRIF_END_DO_NOT_TREAT
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 4.0 , NEMO Consortium (2011)
+   !! $Id$ 
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   FUNCTION bdy_oce_alloc()
+      !!----------------------------------------------------------------------
+      USE lib_mpp, ONLY: ctl_warn, mpp_sum
+      !
+      INTEGER :: bdy_oce_alloc
+      !!----------------------------------------------------------------------
+      !
+      ALLOCATE( bdytmask(jpi,jpj) , bdyumask(jpi,jpj), bdyvmask(jpi,jpj),     &  
+         &      STAT=bdy_oce_alloc )
+      !
+      ! Initialize masks 
+      bdytmask(:,:) = 1._wp
+      bdyumask(:,:) = 1._wp
+      bdyvmask(:,:) = 1._wp
+      ! 
+      IF( lk_mpp             )   CALL mpp_sum ( bdy_oce_alloc )
+      IF( bdy_oce_alloc /= 0 )   CALL ctl_warn('bdy_oce_alloc: failed to allocate arrays.')
+      !
+   END FUNCTION bdy_oce_alloc
+
+   !!======================================================================
+END MODULE bdy_oce
+
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/BDY/bdydta.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/BDY/bdydta.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/BDY/bdydta.F90	(revision 9570)
@@ -0,0 +1,829 @@
+MODULE bdydta
+   !!======================================================================
+   !!                       ***  MODULE bdydta  ***
+   !! Open boundary data : read the data for the unstructured open boundaries.
+   !!======================================================================
+   !! History :  1.0  !  2005-01  (J. Chanut, A. Sellar)  Original code
+   !!             -   !  2007-01  (D. Storkey) Update to use IOM module
+   !!             -   !  2007-07  (D. Storkey) add bdy_dta_fla
+   !!            3.0  !  2008-04  (NEMO team)  add in the reference version
+   !!            3.3  !  2010-09  (E.O'Dea) modifications for Shelf configurations 
+   !!            3.3  !  2010-09  (D.Storkey) add ice boundary conditions
+   !!            3.4  !  2011     (D. Storkey) rewrite in preparation for OBC-BDY merge
+   !!            3.6  !  2012-01  (C. Rousset) add ice boundary conditions for lim3
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!    bdy_dta      : read external data along open boundaries from file
+   !!    bdy_dta_init : initialise arrays etc for reading of external data
+   !!----------------------------------------------------------------------
+   USE oce            ! ocean dynamics and tracers
+   USE dom_oce        ! ocean space and time domain
+   USE phycst         ! physical constants
+   USE sbcapr         ! atmospheric pressure forcing
+   USE sbctide        ! Tidal forcing or not
+   USE bdy_oce        ! ocean open boundary conditions  
+   USE bdytides       ! tidal forcing at boundaries
+#if defined key_si3
+   USE ice            ! sea-ice variables
+   USE icevar         ! redistribute ice input into categories
+#endif
+   !
+   USE fldread        ! read input fields
+   USE iom            ! IOM library
+   USE in_out_manager ! I/O logical units
+   USE timing         ! Timing
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   bdy_dta          ! routine called by step.F90 and dynspg_ts.F90
+   PUBLIC   bdy_dta_init     ! routine called by nemogcm.F90
+
+   INTEGER, ALLOCATABLE, DIMENSION(:)   ::   nb_bdy_fld        ! Number of fields to update for each boundary set.
+   INTEGER                              ::   nb_bdy_fld_sum    ! Total number of fields to update for all boundary sets.
+   LOGICAL,           DIMENSION(jp_bdy) ::   ln_full_vel_array ! =T => full velocities in 3D boundary conditions
+                                                               ! =F => baroclinic velocities in 3D boundary conditions
+!$AGRIF_DO_NOT_TREAT
+   TYPE(FLD), PUBLIC, ALLOCATABLE, DIMENSION(:), TARGET ::   bf        ! structure of input fields (file informations, fields read)
+!$AGRIF_END_DO_NOT_TREAT
+   TYPE(MAP_POINTER), ALLOCATABLE, DIMENSION(:) :: nbmap_ptr   ! array of pointers to nbmap
+
+#if defined key_si3
+   INTEGER ::   nice_cat                      ! number of categories in the input file
+   INTEGER ::   jfld_hti, jfld_hts, jfld_ai   ! indices of ice thickness, snow thickness and concentration in bf structure
+#endif
+
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 4.0 , NEMO Consortium (2017)
+   !! $Id$ 
+   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+      SUBROUTINE bdy_dta( kt, jit, time_offset )
+      !!----------------------------------------------------------------------
+      !!                   ***  SUBROUTINE bdy_dta  ***
+      !!                    
+      !! ** Purpose :   Update external data for open boundary conditions
+      !!
+      !! ** Method  :   Use fldread.F90
+      !!                
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT(in)           ::   kt           ! ocean time-step index 
+      INTEGER, INTENT(in), OPTIONAL ::   jit          ! subcycle time-step index (for timesplitting option)
+      INTEGER, INTENT(in), OPTIONAL ::   time_offset  ! time offset in units of timesteps. NB. if jit
+      !                                               ! is present then units = subcycle timesteps.
+      !                                               ! time_offset = 0 => get data at "now" time level
+      !                                               ! time_offset = -1 => get data at "before" time level
+      !                                               ! time_offset = +1 => get data at "after" time level
+      !                                               ! etc.
+      !
+      INTEGER ::  jbdy, jfld, jstart, jend, ib, jl  ! dummy loop indices
+      INTEGER ::  ii, ij, ik, igrd                  ! local integers
+      INTEGER,          DIMENSION(jpbgrd) ::   ilen1 
+      INTEGER, POINTER, DIMENSION(:)      ::   nblen, nblenrim  ! short cuts
+      TYPE(OBC_DATA), POINTER             ::   dta              ! short cut
+      !!---------------------------------------------------------------------------
+      !
+      IF( ln_timing )   CALL timing_start('bdy_dta')
+      !
+      ! Initialise data arrays once for all from initial conditions where required
+      !---------------------------------------------------------------------------
+      IF( kt == nit000 .AND. .NOT.PRESENT(jit) ) THEN
+
+         ! Calculate depth-mean currents
+         !-----------------------------
+         
+         DO jbdy = 1, nb_bdy
+            !
+            nblen    => idx_bdy(jbdy)%nblen
+            nblenrim => idx_bdy(jbdy)%nblenrim
+            dta      => dta_bdy(jbdy)
+            !
+            IF( nn_dyn2d_dta(jbdy) == 0 ) THEN 
+               ilen1(:) = nblen(:)
+               IF( dta%ll_ssh ) THEN 
+                  igrd = 1
+                  DO ib = 1, ilen1(igrd)
+                     ii = idx_bdy(jbdy)%nbi(ib,igrd)
+                     ij = idx_bdy(jbdy)%nbj(ib,igrd)
+                     dta_bdy(jbdy)%ssh(ib) = sshn(ii,ij) * tmask(ii,ij,1)         
+                  END DO 
+               ENDIF
+               IF( dta%ll_u2d ) THEN 
+                  igrd = 2
+                  DO ib = 1, ilen1(igrd)
+                     ii = idx_bdy(jbdy)%nbi(ib,igrd)
+                     ij = idx_bdy(jbdy)%nbj(ib,igrd)
+                     dta_bdy(jbdy)%u2d(ib) = un_b(ii,ij) * umask(ii,ij,1)         
+                  END DO 
+               ENDIF
+               IF( dta%ll_v2d ) THEN 
+                  igrd = 3
+                  DO ib = 1, ilen1(igrd)
+                     ii = idx_bdy(jbdy)%nbi(ib,igrd)
+                     ij = idx_bdy(jbdy)%nbj(ib,igrd)
+                     dta_bdy(jbdy)%v2d(ib) = vn_b(ii,ij) * vmask(ii,ij,1)         
+                  END DO 
+               ENDIF
+            ENDIF
+            !
+            IF( nn_dyn3d_dta(jbdy) == 0 ) THEN 
+               ilen1(:) = nblen(:)
+               IF( dta%ll_u3d ) THEN 
+                  igrd = 2 
+                  DO ib = 1, ilen1(igrd)
+                     DO ik = 1, jpkm1
+                        ii = idx_bdy(jbdy)%nbi(ib,igrd)
+                        ij = idx_bdy(jbdy)%nbj(ib,igrd)
+                        dta_bdy(jbdy)%u3d(ib,ik) =  ( un(ii,ij,ik) - un_b(ii,ij) ) * umask(ii,ij,ik)         
+                     END DO
+                  END DO 
+               ENDIF
+               IF( dta%ll_v3d ) THEN 
+                  igrd = 3 
+                  DO ib = 1, ilen1(igrd)
+                     DO ik = 1, jpkm1
+                        ii = idx_bdy(jbdy)%nbi(ib,igrd)
+                        ij = idx_bdy(jbdy)%nbj(ib,igrd)
+                        dta_bdy(jbdy)%v3d(ib,ik) =  ( vn(ii,ij,ik) - vn_b(ii,ij) ) * vmask(ii,ij,ik)         
+                        END DO
+                  END DO 
+               ENDIF
+            ENDIF
+
+            IF( nn_tra_dta(jbdy) == 0 ) THEN 
+               ilen1(:) = nblen(:)
+               IF( dta%ll_tem ) THEN
+                  igrd = 1 
+                  DO ib = 1, ilen1(igrd)
+                     DO ik = 1, jpkm1
+                        ii = idx_bdy(jbdy)%nbi(ib,igrd)
+                        ij = idx_bdy(jbdy)%nbj(ib,igrd)
+                        dta_bdy(jbdy)%tem(ib,ik) = tsn(ii,ij,ik,jp_tem) * tmask(ii,ij,ik)         
+                     END DO
+                  END DO 
+               ENDIF
+               IF( dta%ll_sal ) THEN
+                  igrd = 1 
+                  DO ib = 1, ilen1(igrd)
+                     DO ik = 1, jpkm1
+                        ii = idx_bdy(jbdy)%nbi(ib,igrd)
+                        ij = idx_bdy(jbdy)%nbj(ib,igrd)
+                        dta_bdy(jbdy)%sal(ib,ik) = tsn(ii,ij,ik,jp_sal) * tmask(ii,ij,ik)         
+                     END DO
+                  END DO 
+               ENDIF
+            ENDIF
+
+#if defined key_si3
+            IF( nn_ice_lim_dta(jbdy) == 0 ) THEN    ! set ice to initial values
+               ilen1(:) = nblen(:)
+               IF( dta%ll_a_i ) THEN
+                  igrd = 1   
+                  DO jl = 1, jpl
+                     DO ib = 1, ilen1(igrd)
+                        ii = idx_bdy(jbdy)%nbi(ib,igrd)
+                        ij = idx_bdy(jbdy)%nbj(ib,igrd)
+                        dta_bdy(jbdy)%a_i (ib,jl) =  a_i(ii,ij,jl) * tmask(ii,ij,1) 
+                     END DO
+                  END DO
+               ENDIF
+               IF( dta%ll_h_i ) THEN
+                  igrd = 1   
+                  DO jl = 1, jpl
+                     DO ib = 1, ilen1(igrd)
+                        ii = idx_bdy(jbdy)%nbi(ib,igrd)
+                        ij = idx_bdy(jbdy)%nbj(ib,igrd)
+                        dta_bdy(jbdy)%h_i (ib,jl) =  h_i(ii,ij,jl) * tmask(ii,ij,1) 
+                     END DO
+                  END DO
+               ENDIF
+               IF( dta%ll_h_s ) THEN
+                  igrd = 1   
+                  DO jl = 1, jpl
+                     DO ib = 1, ilen1(igrd)
+                        ii = idx_bdy(jbdy)%nbi(ib,igrd)
+                        ij = idx_bdy(jbdy)%nbj(ib,igrd)
+                        dta_bdy(jbdy)%h_s (ib,jl) =  h_s(ii,ij,jl) * tmask(ii,ij,1) 
+                     END DO
+                  END DO
+               ENDIF
+            ENDIF
+#endif
+         END DO ! jbdy
+         !
+      ENDIF ! kt == nit000
+
+      ! update external data from files
+      !--------------------------------
+     
+      jstart = 1
+      DO jbdy = 1, nb_bdy   
+         dta => dta_bdy(jbdy)
+         IF( nn_dta(jbdy) == 1 ) THEN ! skip this bit if no external data required
+      
+            IF( PRESENT(jit) ) THEN
+               ! Update barotropic boundary conditions only
+               ! jit is optional argument for fld_read and bdytide_update
+               IF( cn_dyn2d(jbdy) /= 'none' ) THEN
+                  IF( nn_dyn2d_dta(jbdy) == 2 ) THEN ! tidal harmonic forcing ONLY: initialise arrays
+                     IF( dta%ll_ssh ) dta%ssh(:) = 0._wp
+                     IF( dta%ll_u2d ) dta%u2d(:) = 0._wp
+                     IF( dta%ll_u3d ) dta%v2d(:) = 0._wp
+                  ENDIF
+                  IF (cn_tra(jbdy) /= 'runoff') THEN
+                     IF( nn_dyn2d_dta(jbdy) == 1 .OR. nn_dyn2d_dta(jbdy) == 3 ) THEN
+
+                        jend = jstart + dta%nread(2) - 1
+                        IF( ln_full_vel_array(jbdy) ) THEN
+                           CALL fld_read( kt=kt, kn_fsbc=1, sd=bf(jstart:jend), map=nbmap_ptr(jstart:jend),  &
+                                     & kit=jit, kt_offset=time_offset , jpk_bdy=nb_jpk_bdy,   &
+                                     & fvl=ln_full_vel_array(jbdy)  )
+                        ELSE
+                           CALL fld_read( kt=kt, kn_fsbc=1, sd=bf(jstart:jend), map=nbmap_ptr(jstart:jend),  &
+                                     & kit=jit, kt_offset=time_offset  )
+                        ENDIF
+
+                        ! If full velocities in boundary data then extract barotropic velocities from 3D fields
+                        IF( ln_full_vel_array(jbdy) .AND.                                             &
+                          &    ( nn_dyn2d_dta(jbdy) == 1 .OR. nn_dyn2d_dta(jbdy) == 3 .OR.  &
+                          &      nn_dyn3d_dta(jbdy) == 1 ) )THEN
+
+                           igrd = 2                      ! zonal velocity
+                           dta%u2d(:) = 0._wp
+                           DO ib = 1, idx_bdy(jbdy)%nblen(igrd)
+                              ii   = idx_bdy(jbdy)%nbi(ib,igrd)
+                              ij   = idx_bdy(jbdy)%nbj(ib,igrd)
+                              DO ik = 1, jpkm1
+                                 dta%u2d(ib) = dta%u2d(ib) &
+                       &                          + e3u_n(ii,ij,ik) * umask(ii,ij,ik) * dta%u3d(ib,ik)
+                              END DO
+                              dta%u2d(ib) =  dta%u2d(ib) * r1_hu_n(ii,ij)
+                           END DO
+                           igrd = 3                      ! meridional velocity
+                           dta%v2d(:) = 0._wp
+                           DO ib = 1, idx_bdy(jbdy)%nblen(igrd)
+                              ii   = idx_bdy(jbdy)%nbi(ib,igrd)
+                              ij   = idx_bdy(jbdy)%nbj(ib,igrd)
+                              DO ik = 1, jpkm1
+                                 dta%v2d(ib) = dta%v2d(ib) &
+                       &                       + e3v_n(ii,ij,ik) * vmask(ii,ij,ik) * dta%v3d(ib,ik)
+                              END DO
+                              dta%v2d(ib) =  dta%v2d(ib) * r1_hv_n(ii,ij)
+                           END DO
+                        ENDIF                    
+                     ENDIF
+                     IF( nn_dyn2d_dta(jbdy) .ge. 2 ) THEN ! update tidal harmonic forcing
+                        CALL bdytide_update( kt=kt, idx=idx_bdy(jbdy), dta=dta, td=tides(jbdy),   & 
+                          &                 jit=jit, time_offset=time_offset )
+                     ENDIF
+                  ENDIF
+               ENDIF
+            ELSE
+               IF (cn_tra(jbdy) == 'runoff') then      ! runoff condition
+                  jend = nb_bdy_fld(jbdy)
+                  CALL fld_read( kt=kt, kn_fsbc=1, sd=bf(jstart:jend),  &
+                               & map=nbmap_ptr(jstart:jend), kt_offset=time_offset )
+                  !
+                  igrd = 2                      ! zonal velocity
+                  DO ib = 1, idx_bdy(jbdy)%nblen(igrd)
+                     ii   = idx_bdy(jbdy)%nbi(ib,igrd)
+                     ij   = idx_bdy(jbdy)%nbj(ib,igrd)
+                     dta%u2d(ib) = dta%u2d(ib) / ( e2u(ii,ij) * hu_0(ii,ij) )
+                  END DO
+                  !
+                  igrd = 3                      ! meridional velocity
+                  DO ib = 1, idx_bdy(jbdy)%nblen(igrd)
+                     ii   = idx_bdy(jbdy)%nbi(ib,igrd)
+                     ij   = idx_bdy(jbdy)%nbj(ib,igrd)
+                     dta%v2d(ib) = dta%v2d(ib) / ( e1v(ii,ij) * hv_0(ii,ij) )
+                  END DO
+               ELSE
+                  IF( nn_dyn2d_dta(jbdy) == 2 ) THEN ! tidal harmonic forcing ONLY: initialise arrays
+                     IF( dta%ll_ssh ) dta%ssh(:) = 0._wp
+                     IF( dta%ll_u2d ) dta%u2d(:) = 0._wp
+                     IF( dta%ll_v2d ) dta%v2d(:) = 0._wp
+                  ENDIF
+                  IF( dta%nread(1) .gt. 0 ) THEN ! update external data
+                     jend = jstart + dta%nread(1) - 1
+                     CALL fld_read( kt=kt, kn_fsbc=1, sd=bf(jstart:jend), &
+                                  & map=nbmap_ptr(jstart:jend), kt_offset=time_offset, jpk_bdy=nb_jpk_bdy,   &
+                                  & fvl=ln_full_vel_array(jbdy) )
+                  ENDIF
+                  ! If full velocities in boundary data then split into barotropic and baroclinic data
+                  IF( ln_full_vel_array(jbdy) .and.                                             &
+                    & ( nn_dyn2d_dta(jbdy) == 1 .OR. nn_dyn2d_dta(jbdy) == 3 .OR. &
+                    &   nn_dyn3d_dta(jbdy) == 1 ) ) THEN
+                     igrd = 2                      ! zonal velocity
+                     dta%u2d(:) = 0._wp
+                     DO ib = 1, idx_bdy(jbdy)%nblen(igrd)
+                        ii   = idx_bdy(jbdy)%nbi(ib,igrd)
+                        ij   = idx_bdy(jbdy)%nbj(ib,igrd)
+                        DO ik = 1, jpkm1
+                           dta%u2d(ib) = dta%u2d(ib) &
+                 &                       + e3u_n(ii,ij,ik) * umask(ii,ij,ik) * dta%u3d(ib,ik)
+                        END DO
+                        dta%u2d(ib) =  dta%u2d(ib) * r1_hu_n(ii,ij)
+                        DO ik = 1, jpkm1
+                           dta%u3d(ib,ik) = dta%u3d(ib,ik) - dta%u2d(ib)
+                        END DO
+                     END DO
+                     igrd = 3                      ! meridional velocity
+                     dta%v2d(:) = 0._wp
+                     DO ib = 1, idx_bdy(jbdy)%nblen(igrd)
+                        ii   = idx_bdy(jbdy)%nbi(ib,igrd)
+                        ij   = idx_bdy(jbdy)%nbj(ib,igrd)
+                        DO ik = 1, jpkm1
+                           dta%v2d(ib) = dta%v2d(ib) &
+                 &                       + e3v_n(ii,ij,ik) * vmask(ii,ij,ik) * dta%v3d(ib,ik)
+                        END DO
+                        dta%v2d(ib) =  dta%v2d(ib) * r1_hv_n(ii,ij)
+                        DO ik = 1, jpkm1
+                           dta%v3d(ib,ik) = dta%v3d(ib,ik) - dta%v2d(ib)
+                        END DO
+                     END DO
+                  ENDIF
+
+               ENDIF
+#if defined key_si3
+               IF( cn_ice_lim(jbdy) /= 'none' .AND. nn_ice_lim_dta(jbdy) == 1 ) THEN
+                  IF( nice_cat == 1 ) THEN ! case input cat = 1
+                     CALL ice_var_itd ( bf(jfld_hti)%fnow(:,1,1), bf(jfld_hts)%fnow(:,1,1), bf(jfld_ai)%fnow(:,1,1), &
+                        &               dta_bdy(jbdy)%h_i     , dta_bdy(jbdy)%h_s     , dta_bdy(jbdy)%a_i    )
+                  ELSEIF( nice_cat /= 1 .AND. nice_cat /= jpl ) THEN ! case input cat /=1 and /=jpl
+                     CALL ice_var_itd2( bf(jfld_hti)%fnow(:,1,:), bf(jfld_hts)%fnow(:,1,:), bf(jfld_ai)%fnow(:,1,:), &
+                        &               dta_bdy(jbdy)%h_i     , dta_bdy(jbdy)%h_s     , dta_bdy(jbdy)%a_i    )
+                  ENDIF
+               ENDIF
+#endif
+            ENDIF
+            jstart = jstart + dta%nread(1)
+         ENDIF    ! nn_dta(jbdy) = 1
+      END DO  ! jbdy
+
+      IF ( ln_tide ) THEN
+         IF (ln_dynspg_ts) THEN      ! Fill temporary arrays with slow-varying bdy data                           
+            DO jbdy = 1, nb_bdy    ! Tidal component added in ts loop
+               IF ( nn_dyn2d_dta(jbdy) .ge. 2 ) THEN
+                  nblen => idx_bdy(jbdy)%nblen
+                  nblenrim => idx_bdy(jbdy)%nblenrim
+                  IF( cn_dyn2d(jbdy) == 'frs' ) THEN; ilen1(:)=nblen(:) ; ELSE ; ilen1(:)=nblenrim(:) ; ENDIF 
+                  IF ( dta_bdy(jbdy)%ll_ssh ) dta_bdy_s(jbdy)%ssh(1:ilen1(1)) = dta_bdy(jbdy)%ssh(1:ilen1(1))
+                  IF ( dta_bdy(jbdy)%ll_u2d ) dta_bdy_s(jbdy)%u2d(1:ilen1(2)) = dta_bdy(jbdy)%u2d(1:ilen1(2))
+                  IF ( dta_bdy(jbdy)%ll_v2d ) dta_bdy_s(jbdy)%v2d(1:ilen1(3)) = dta_bdy(jbdy)%v2d(1:ilen1(3))
+               ENDIF
+            END DO
+         ELSE ! Add tides if not split-explicit free surface else this is done in ts loop
+            !
+            CALL bdy_dta_tides( kt=kt, time_offset=time_offset )
+         ENDIF
+      ENDIF
+
+      IF ( ln_apr_obc ) THEN
+         DO jbdy = 1, nb_bdy
+            IF (cn_tra(jbdy) /= 'runoff')THEN
+               igrd = 1                      ! meridional velocity
+               DO ib = 1, idx_bdy(jbdy)%nblenrim(igrd)
+                  ii   = idx_bdy(jbdy)%nbi(ib,igrd)
+                  ij   = idx_bdy(jbdy)%nbj(ib,igrd)
+                  dta_bdy(jbdy)%ssh(ib) = dta_bdy(jbdy)%ssh(ib) + ssh_ib(ii,ij)
+               END DO
+            ENDIF
+         END DO
+      ENDIF
+      !
+      IF( ln_timing )   CALL timing_stop('bdy_dta')
+      !
+   END SUBROUTINE bdy_dta
+
+
+   SUBROUTINE bdy_dta_init
+      !!----------------------------------------------------------------------
+      !!                   ***  SUBROUTINE bdy_dta_init  ***
+      !!                    
+      !! ** Purpose :   Initialise arrays for reading of external data 
+      !!                for open boundary conditions
+      !!
+      !! ** Method  :   
+      !!                
+      !!----------------------------------------------------------------------
+      INTEGER ::   jbdy, jfld, jstart, jend, ierror, ios     ! Local integers
+      !
+      CHARACTER(len=100)                     ::   cn_dir        ! Root directory for location of data files
+      CHARACTER(len=100), DIMENSION(nb_bdy)  ::   cn_dir_array  ! Root directory for location of data files
+      CHARACTER(len = 256)::   clname                           ! temporary file name
+      LOGICAL                                ::   ln_full_vel   ! =T => full velocities in 3D boundary data
+      !                                                         ! =F => baroclinic velocities in 3D boundary data
+      INTEGER                                ::   ilen_global   ! Max length required for global bdy dta arrays
+      INTEGER, ALLOCATABLE, DIMENSION(:)     ::   ilen1, ilen3  ! size of 1st and 3rd dimensions of local arrays
+      INTEGER, ALLOCATABLE, DIMENSION(:)     ::   ibdy           ! bdy set for a particular jfld
+      INTEGER, ALLOCATABLE, DIMENSION(:)     ::   igrid         ! index for grid type (1,2,3 = T,U,V)
+      INTEGER, POINTER, DIMENSION(:)         ::   nblen, nblenrim  ! short cuts
+      TYPE(OBC_DATA), POINTER                ::   dta           ! short cut
+#if defined key_si3
+      INTEGER               ::   kndims   ! number of dimensions in an array (i.e. 3 = wo ice cat; 4 = w ice cat)
+      INTEGER, DIMENSION(4) ::   kdimsz   ! size   of dimensions
+      INTEGER               ::   inum,id1 ! local integer
+#endif
+      TYPE(FLD_N), ALLOCATABLE, DIMENSION(:) ::   blf_i         !  array of namelist information structures
+      TYPE(FLD_N) ::   bn_tem, bn_sal, bn_u3d, bn_v3d   ! 
+      TYPE(FLD_N) ::   bn_ssh, bn_u2d, bn_v2d           ! informations about the fields to be read
+#if defined key_si3
+      TYPE(FLD_N) ::   bn_a_i, bn_h_i, bn_h_s      
+#endif
+      NAMELIST/nambdy_dta/ cn_dir, bn_tem, bn_sal, bn_u3d, bn_v3d, bn_ssh, bn_u2d, bn_v2d 
+#if defined key_si3
+      NAMELIST/nambdy_dta/ bn_a_i, bn_h_i, bn_h_s
+#endif
+      NAMELIST/nambdy_dta/ ln_full_vel, nb_jpk_bdy
+      !!---------------------------------------------------------------------------
+      !
+      IF(lwp) WRITE(numout,*)
+      IF(lwp) WRITE(numout,*) 'bdy_dta_ini : initialization of data at the open boundaries'
+      IF(lwp) WRITE(numout,*) '~~~~~~~~~~'
+      IF(lwp) WRITE(numout,*) ''
+
+      ! Set nn_dta
+      DO jbdy = 1, nb_bdy
+         nn_dta(jbdy) = MAX(   nn_dyn2d_dta  (jbdy)    &
+            &                , nn_dyn3d_dta  (jbdy)    &
+            &                , nn_tra_dta    (jbdy)    &
+#if defined key_si3
+            &                , nn_ice_lim_dta(jbdy)    &
+#endif
+                              )
+         IF(nn_dta(jbdy) > 1)   nn_dta(jbdy) = 1
+      END DO
+
+      ! Work out upper bound of how many fields there are to read in and allocate arrays
+      ! ---------------------------------------------------------------------------
+      ALLOCATE( nb_bdy_fld(nb_bdy) )
+      nb_bdy_fld(:) = 0
+      DO jbdy = 1, nb_bdy         
+         IF( cn_dyn2d(jbdy) /= 'none' .AND. ( nn_dyn2d_dta(jbdy) == 1 .or. nn_dyn2d_dta(jbdy) == 3 ) ) THEN
+            nb_bdy_fld(jbdy) = nb_bdy_fld(jbdy) + 3
+         ENDIF
+         IF( cn_dyn3d(jbdy) /= 'none' .AND. nn_dyn3d_dta(jbdy) == 1 ) THEN
+            nb_bdy_fld(jbdy) = nb_bdy_fld(jbdy) + 2
+         ENDIF
+         IF( cn_tra(jbdy) /= 'none' .AND. nn_tra_dta(jbdy) == 1  ) THEN
+            nb_bdy_fld(jbdy) = nb_bdy_fld(jbdy) + 2
+         ENDIF
+#if defined key_si3
+         IF( cn_ice_lim(jbdy) /= 'none' .AND. nn_ice_lim_dta(jbdy) == 1  ) THEN
+            nb_bdy_fld(jbdy) = nb_bdy_fld(jbdy) + 3
+         ENDIF
+#endif               
+         IF(lwp) WRITE(numout,*) 'Maximum number of files to open =', nb_bdy_fld(jbdy)
+      END DO            
+
+      nb_bdy_fld_sum = SUM( nb_bdy_fld )
+
+      ALLOCATE( bf(nb_bdy_fld_sum), STAT=ierror )
+      IF( ierror > 0 ) THEN   
+         CALL ctl_stop( 'bdy_dta: unable to allocate bf structure' )   ;   RETURN  
+      ENDIF
+      ALLOCATE( blf_i(nb_bdy_fld_sum), STAT=ierror )
+      IF( ierror > 0 ) THEN   
+         CALL ctl_stop( 'bdy_dta: unable to allocate blf_i structure' )   ;   RETURN  
+      ENDIF
+      ALLOCATE( nbmap_ptr(nb_bdy_fld_sum), STAT=ierror )
+      IF( ierror > 0 ) THEN   
+         CALL ctl_stop( 'bdy_dta: unable to allocate nbmap_ptr structure' )   ;   RETURN  
+      ENDIF
+      ALLOCATE( ilen1(nb_bdy_fld_sum), ilen3(nb_bdy_fld_sum) ) 
+      ALLOCATE( ibdy(nb_bdy_fld_sum) ) 
+      ALLOCATE( igrid(nb_bdy_fld_sum) ) 
+
+      ! Read namelists
+      ! --------------
+      REWIND(numnam_ref)
+      REWIND(numnam_cfg)
+      jfld = 0 
+      DO jbdy = 1, nb_bdy         
+         IF( nn_dta(jbdy) == 1 ) THEN
+            READ  ( numnam_ref, nambdy_dta, IOSTAT = ios, ERR = 901)
+901         IF( ios /= 0 )   CALL ctl_nam ( ios , 'nambdy_dta in reference namelist', lwp )
+            READ  ( numnam_cfg, nambdy_dta, IOSTAT = ios, ERR = 902 )
+902         IF( ios >  0 )   CALL ctl_nam ( ios , 'nambdy_dta in configuration namelist', lwp )
+            IF(lwm) WRITE( numond, nambdy_dta )
+
+            cn_dir_array(jbdy) = cn_dir
+            ln_full_vel_array(jbdy) = ln_full_vel
+
+            nblen => idx_bdy(jbdy)%nblen
+            nblenrim => idx_bdy(jbdy)%nblenrim
+            dta => dta_bdy(jbdy)
+            dta%nread(2) = 0
+
+            ! Only read in necessary fields for this set.
+            ! Important that barotropic variables come first.
+            IF( nn_dyn2d_dta(jbdy) == 1 .or. nn_dyn2d_dta(jbdy) == 3 ) THEN 
+
+               IF( dta%ll_ssh ) THEN 
+                  if(lwp) write(numout,*) '++++++ reading in ssh field'
+                  jfld = jfld + 1
+                  blf_i(jfld) = bn_ssh
+                  ibdy(jfld) = jbdy
+                  igrid(jfld) = 1
+                  ilen1(jfld) = nblen(igrid(jfld))
+                  ilen3(jfld) = 1
+                  dta%nread(2) = dta%nread(2) + 1
+               ENDIF
+
+               IF( dta%ll_u2d .and. .not. ln_full_vel_array(jbdy) ) THEN
+                  if(lwp) write(numout,*) '++++++ reading in u2d field'
+                  jfld = jfld + 1
+                  blf_i(jfld) = bn_u2d
+                  ibdy(jfld) = jbdy
+                  igrid(jfld) = 2
+                  ilen1(jfld) = nblen(igrid(jfld))
+                  ilen3(jfld) = 1
+                  dta%nread(2) = dta%nread(2) + 1
+               ENDIF
+
+               IF( dta%ll_v2d .and. .not. ln_full_vel_array(jbdy) ) THEN
+                  if(lwp) write(numout,*) '++++++ reading in v2d field'
+                  jfld = jfld + 1
+                  blf_i(jfld) = bn_v2d
+                  ibdy(jfld) = jbdy
+                  igrid(jfld) = 3
+                  ilen1(jfld) = nblen(igrid(jfld))
+                  ilen3(jfld) = 1
+                  dta%nread(2) = dta%nread(2) + 1
+               ENDIF
+
+            ENDIF
+
+            ! read 3D velocities if baroclinic velocities require OR if
+            ! barotropic velocities required and ln_full_vel set to .true.
+            IF( nn_dyn3d_dta(jbdy) == 1 .OR. &
+           &  ( ln_full_vel_array(jbdy) .AND. ( nn_dyn2d_dta(jbdy) == 1 .OR. nn_dyn2d_dta(jbdy) == 3 ) ) ) THEN
+
+               IF( dta%ll_u3d .OR. ( ln_full_vel_array(jbdy) .and. dta%ll_u2d ) ) THEN
+                  if(lwp) write(numout,*) '++++++ reading in u3d field'
+                  jfld = jfld + 1
+                  blf_i(jfld) = bn_u3d
+                  ibdy(jfld) = jbdy
+                  igrid(jfld) = 2
+                  ilen1(jfld) = nblen(igrid(jfld))
+                  ilen3(jfld) = jpk
+                  IF( ln_full_vel_array(jbdy) .and. dta%ll_u2d ) dta%nread(2) = dta%nread(2) + 1
+               ENDIF
+
+               IF( dta%ll_v3d .OR. ( ln_full_vel_array(jbdy) .and. dta%ll_v2d ) ) THEN
+                  if(lwp) write(numout,*) '++++++ reading in v3d field'
+                  jfld = jfld + 1
+                  blf_i(jfld) = bn_v3d
+                  ibdy(jfld) = jbdy
+                  igrid(jfld) = 3
+                  ilen1(jfld) = nblen(igrid(jfld))
+                  ilen3(jfld) = jpk
+                  IF( ln_full_vel_array(jbdy) .and. dta%ll_v2d ) dta%nread(2) = dta%nread(2) + 1
+               ENDIF
+
+            ENDIF
+
+            ! temperature and salinity
+            IF( nn_tra_dta(jbdy) == 1 ) THEN
+
+               IF( dta%ll_tem ) THEN
+                  if(lwp) write(numout,*) '++++++ reading in tem field'
+                  jfld = jfld + 1
+                  blf_i(jfld) = bn_tem
+                  ibdy(jfld) = jbdy
+                  igrid(jfld) = 1
+                  ilen1(jfld) = nblen(igrid(jfld))
+                  ilen3(jfld) = jpk
+               ENDIF
+
+               IF( dta%ll_sal ) THEN
+                  if(lwp) write(numout,*) '++++++ reading in sal field'
+                  jfld = jfld + 1
+                  blf_i(jfld) = bn_sal
+                  ibdy(jfld) = jbdy
+                  igrid(jfld) = 1
+                  ilen1(jfld) = nblen(igrid(jfld))
+                  ilen3(jfld) = jpk
+               ENDIF
+
+            ENDIF
+
+#if defined key_si3
+            ! sea ice
+            IF( nn_ice_lim_dta(jbdy) == 1 ) THEN
+               ! Test for types of ice input (1cat or Xcat) 
+               ! Build file name to find dimensions 
+               clname=TRIM( cn_dir )//TRIM(bn_a_i%clname)
+               IF( .NOT. bn_a_i%ln_clim ) THEN   
+                                                  WRITE(clname, '(a,"_y",i4.4)' ) TRIM( clname ), nyear    ! add year
+                  IF( bn_a_i%cltype /= 'yearly' ) WRITE(clname, '(a,"m" ,i2.2)' ) TRIM( clname ), nmonth   ! add month
+               ELSE
+                  IF( bn_a_i%cltype /= 'yearly' ) WRITE(clname, '(a,"_m",i2.2)' ) TRIM( clname ), nmonth   ! add month
+               ENDIF
+               IF( bn_a_i%cltype == 'daily' .OR. bn_a_i%cltype(1:4) == 'week' ) &
+               &                                  WRITE(clname, '(a,"d" ,i2.2)' ) TRIM( clname ), nday     ! add day
+               !
+               CALL iom_open  ( clname, inum )
+               id1 = iom_varid( inum, bn_a_i%clvar, kdimsz=kdimsz, kndims=kndims, ldstop = .FALSE. )
+               CALL iom_close ( inum )
+
+      	       IF ( kndims == 4 ) THEN
+                 nice_cat = kdimsz(4)   ! Xcat input
+               ELSE
+                 nice_cat = 1           ! 1cat input      
+               ENDIF
+               ! End test
+
+               IF( dta%ll_a_i ) THEN
+                  jfld = jfld + 1
+                  blf_i(jfld) = bn_a_i
+                  ibdy(jfld)  = jbdy
+                  igrid(jfld) = 1
+                  ilen1(jfld) = nblen(igrid(jfld))
+                  ilen3(jfld) = nice_cat
+               ENDIF
+
+               IF( dta%ll_h_i ) THEN
+                  jfld = jfld + 1
+                  blf_i(jfld) = bn_h_i
+                  ibdy(jfld)  = jbdy
+                  igrid(jfld) = 1
+                  ilen1(jfld) = nblen(igrid(jfld))
+                  ilen3(jfld) = nice_cat
+               ENDIF
+
+               IF( dta%ll_h_s ) THEN
+                  jfld = jfld + 1
+                  blf_i(jfld) = bn_h_s
+                  ibdy(jfld)  = jbdy
+                  igrid(jfld) = 1
+                  ilen1(jfld) = nblen(igrid(jfld))
+                  ilen3(jfld) = nice_cat
+               ENDIF
+
+            ENDIF
+#endif
+            ! Recalculate field counts
+            !-------------------------
+            IF( jbdy == 1 ) THEN 
+               nb_bdy_fld_sum = 0
+               nb_bdy_fld(jbdy) = jfld
+               nb_bdy_fld_sum     = jfld              
+            ELSE
+               nb_bdy_fld(jbdy) = jfld - nb_bdy_fld_sum
+               nb_bdy_fld_sum = nb_bdy_fld_sum + nb_bdy_fld(jbdy)
+            ENDIF
+
+            dta%nread(1) = nb_bdy_fld(jbdy)
+
+         ENDIF ! nn_dta == 1
+      ENDDO ! jbdy
+
+      DO jfld = 1, nb_bdy_fld_sum
+         ALLOCATE( bf(jfld)%fnow(ilen1(jfld),1,ilen3(jfld)) )
+         IF( blf_i(jfld)%ln_tint ) ALLOCATE( bf(jfld)%fdta(ilen1(jfld),1,ilen3(jfld),2) )
+         nbmap_ptr(jfld)%ptr => idx_bdy(ibdy(jfld))%nbmap(:,igrid(jfld))
+         nbmap_ptr(jfld)%ll_unstruc = ln_coords_file(ibdy(jfld))
+      ENDDO
+
+      ! fill bf with blf_i and control print
+      !-------------------------------------
+      jstart = 1
+      DO jbdy = 1, nb_bdy
+         jend = jstart - 1 + nb_bdy_fld(jbdy) 
+         CALL fld_fill( bf(jstart:jend), blf_i(jstart:jend), cn_dir_array(jbdy), 'bdy_dta',   &
+         &              'open boundary conditions', 'nambdy_dta' )
+         jstart = jend + 1
+      ENDDO
+
+      ! Initialise local boundary data arrays
+      ! nn_xxx_dta=0 : allocate space - will be filled from initial conditions later
+      ! nn_xxx_dta=1 : point to "fnow" arrays
+      !-------------------------------------
+
+      jfld = 0
+      DO jbdy=1, nb_bdy
+
+         nblen => idx_bdy(jbdy)%nblen
+         dta => dta_bdy(jbdy)
+
+         if(lwp) then
+            write(numout,*) '++++++ dta%ll_ssh = ',dta%ll_ssh
+            write(numout,*) '++++++ dta%ll_u2d = ',dta%ll_u2d
+            write(numout,*) '++++++ dta%ll_v2d = ',dta%ll_v2d
+            write(numout,*) '++++++ dta%ll_u3d = ',dta%ll_u3d
+            write(numout,*) '++++++ dta%ll_v3d = ',dta%ll_v3d
+            write(numout,*) '++++++ dta%ll_tem = ',dta%ll_tem
+            write(numout,*) '++++++ dta%ll_sal = ',dta%ll_sal
+         endif
+
+         IF ( nn_dyn2d_dta(jbdy) == 0 .or. nn_dyn2d_dta(jbdy) == 2 ) THEN
+            if(lwp) write(numout,*) '++++++ dta%ssh/u2d/u3d allocated space'
+            IF( dta%ll_ssh ) ALLOCATE( dta%ssh(nblen(1)) )
+            IF( dta%ll_u2d ) ALLOCATE( dta%u2d(nblen(2)) )
+            IF( dta%ll_v2d ) ALLOCATE( dta%v2d(nblen(3)) )
+         ENDIF
+         IF ( nn_dyn2d_dta(jbdy) == 1 .or. nn_dyn2d_dta(jbdy) == 3 ) THEN
+            IF( dta%ll_ssh ) THEN
+               if(lwp) write(numout,*) '++++++ dta%ssh pointing to fnow'
+               jfld = jfld + 1
+               dta%ssh => bf(jfld)%fnow(:,1,1)
+            ENDIF
+            IF ( dta%ll_u2d ) THEN
+               IF ( ln_full_vel_array(jbdy) ) THEN
+                  if(lwp) write(numout,*) '++++++ dta%u2d allocated space'
+                  ALLOCATE( dta%u2d(nblen(2)) )
+               ELSE
+                  if(lwp) write(numout,*) '++++++ dta%u2d pointing to fnow'
+                  jfld = jfld + 1
+                  dta%u2d => bf(jfld)%fnow(:,1,1)
+               ENDIF
+            ENDIF
+            IF ( dta%ll_v2d ) THEN
+               IF ( ln_full_vel_array(jbdy) ) THEN
+                  if(lwp) write(numout,*) '++++++ dta%v2d allocated space'
+                  ALLOCATE( dta%v2d(nblen(3)) )
+               ELSE
+                  if(lwp) write(numout,*) '++++++ dta%v2d pointing to fnow'
+                  jfld = jfld + 1
+                  dta%v2d => bf(jfld)%fnow(:,1,1)
+               ENDIF
+            ENDIF
+         ENDIF
+
+         IF ( nn_dyn3d_dta(jbdy) == 0 ) THEN
+            if(lwp) write(numout,*) '++++++ dta%u3d/v3d allocated space'
+            IF( dta%ll_u3d ) ALLOCATE( dta_bdy(jbdy)%u3d(nblen(2),jpk) )
+            IF( dta%ll_v3d ) ALLOCATE( dta_bdy(jbdy)%v3d(nblen(3),jpk) )
+         ENDIF
+         IF ( nn_dyn3d_dta(jbdy) == 1 .or. &
+           &  ( ln_full_vel_array(jbdy) .and. ( nn_dyn2d_dta(jbdy) == 1 .or. nn_dyn2d_dta(jbdy) == 3 ) ) ) THEN
+            IF ( dta%ll_u3d .or. ( ln_full_vel_array(jbdy) .and. dta%ll_u2d ) ) THEN
+               if(lwp) write(numout,*) '++++++ dta%u3d pointing to fnow'
+               jfld = jfld + 1
+               dta_bdy(jbdy)%u3d => bf(jfld)%fnow(:,1,:)
+            ENDIF
+            IF ( dta%ll_v3d .or. ( ln_full_vel_array(jbdy) .and. dta%ll_v2d ) ) THEN
+               if(lwp) write(numout,*) '++++++ dta%v3d pointing to fnow'
+               jfld = jfld + 1
+               dta_bdy(jbdy)%v3d => bf(jfld)%fnow(:,1,:)
+            ENDIF
+         ENDIF
+
+         IF( nn_tra_dta(jbdy) == 0 ) THEN
+            if(lwp) write(numout,*) '++++++ dta%tem/sal allocated space'
+            IF( dta%ll_tem ) ALLOCATE( dta_bdy(jbdy)%tem(nblen(1),jpk) )
+            IF( dta%ll_sal ) ALLOCATE( dta_bdy(jbdy)%sal(nblen(1),jpk) )
+         ELSE
+            IF( dta%ll_tem ) THEN
+               if(lwp) write(numout,*) '++++++ dta%tem pointing to fnow'
+               jfld = jfld + 1
+               dta_bdy(jbdy)%tem => bf(jfld)%fnow(:,1,:)
+            ENDIF
+            IF( dta%ll_sal ) THEN 
+               if(lwp) write(numout,*) '++++++ dta%sal pointing to fnow'
+               jfld = jfld + 1
+               dta_bdy(jbdy)%sal => bf(jfld)%fnow(:,1,:)
+            ENDIF
+         ENDIF
+
+#if defined key_si3
+         IF (cn_ice_lim(jbdy) /= 'none') THEN
+            IF( nn_ice_lim_dta(jbdy) == 0 ) THEN
+               ALLOCATE( dta_bdy(jbdy)%a_i(nblen(1),jpl) )
+               ALLOCATE( dta_bdy(jbdy)%h_i(nblen(1),jpl) )
+               ALLOCATE( dta_bdy(jbdy)%h_s(nblen(1),jpl) )
+            ELSE
+               IF ( nice_cat == jpl ) THEN ! case input cat = jpl
+                  jfld = jfld + 1
+                  dta_bdy(jbdy)%a_i => bf(jfld)%fnow(:,1,:)
+                  jfld = jfld + 1
+                  dta_bdy(jbdy)%h_i => bf(jfld)%fnow(:,1,:)
+                  jfld = jfld + 1
+                  dta_bdy(jbdy)%h_s => bf(jfld)%fnow(:,1,:)
+               ELSE                        ! case input cat = 1 OR (/=1 and /=jpl)
+                  jfld_ai  = jfld + 1
+                  jfld_hti = jfld + 2
+                  jfld_hts = jfld + 3
+                  jfld     = jfld + 3
+                  ALLOCATE( dta_bdy(jbdy)%a_i(nblen(1),jpl) )
+                  ALLOCATE( dta_bdy(jbdy)%h_i(nblen(1),jpl) )
+                  ALLOCATE( dta_bdy(jbdy)%h_s(nblen(1),jpl) )
+                  dta_bdy(jbdy)%a_i(:,:) = 0._wp
+                  dta_bdy(jbdy)%h_i(:,:) = 0._wp
+                  dta_bdy(jbdy)%h_s(:,:) = 0._wp
+               ENDIF
+
+            ENDIF
+         ENDIF
+#endif
+         !
+      END DO ! jbdy 
+      !
+   END SUBROUTINE bdy_dta_init
+
+   !!==============================================================================
+END MODULE bdydta
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/BDY/bdydyn.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/BDY/bdydyn.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/BDY/bdydyn.F90	(revision 9570)
@@ -0,0 +1,122 @@
+MODULE bdydyn
+   !!======================================================================
+   !!                       ***  MODULE  bdydyn  ***
+   !! Unstructured Open Boundary Cond. :   Apply boundary conditions to velocities
+   !!======================================================================
+   !! History :  1.0  !  2005-02  (J. Chanut, A. Sellar)  Original code
+   !!             -   !  2007-07  (D. Storkey) Move Flather implementation to separate routine.
+   !!            3.0  !  2008-04  (NEMO team)  add in the reference version
+   !!            3.2  !  2008-04  (R. Benshila) consider velocity instead of transport 
+   !!            3.3  !  2010-09  (E.O'Dea) modifications for Shelf configurations 
+   !!            3.3  !  2010-09  (D.Storkey) add ice boundary conditions
+   !!            3.4  !  2011     (D. Storkey) rewrite in preparation for OBC-BDY merge
+   !!----------------------------------------------------------------------
+   !!   bdy_dyn        : split velocities into barotropic and baroclinic parts
+   !!                    and call bdy_dyn2d and bdy_dyn3d to apply boundary
+   !!                    conditions
+   !!----------------------------------------------------------------------
+   USE oce             ! ocean dynamics and tracers 
+   USE dom_oce         ! ocean space and time domain
+   USE bdy_oce         ! ocean open boundary conditions
+   USE bdydyn2d        ! open boundary conditions for barotropic solution
+   USE bdydyn3d        ! open boundary conditions for baroclinic velocities
+   USE lbclnk          ! ocean lateral boundary conditions (or mpp link)
+   USE in_out_manager  !
+   USE domvvl          ! variable volume
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   bdy_dyn    ! routine called in dyn_nxt
+
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO Consortium (2010)
+   !! $Id$ 
+   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE bdy_dyn( kt, dyn3d_only )
+      !!----------------------------------------------------------------------
+      !!                  ***  SUBROUTINE bdy_dyn  ***
+      !!
+      !! ** Purpose : - Wrapper routine for bdy_dyn2d and bdy_dyn3d.
+      !!
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT(in)           ::   kt           ! Main time step counter
+      LOGICAL, INTENT(in), OPTIONAL ::   dyn3d_only   ! T => only update baroclinic velocities
+      !
+      INTEGER ::   jk, ii, ij, ib_bdy, ib, igrd     ! Loop counter
+      LOGICAL ::   ll_dyn2d, ll_dyn3d, ll_orlanski
+      REAL(wp), DIMENSION(jpi,jpj) :: pua2d, pva2d     ! after barotropic velocities
+      !!----------------------------------------------------------------------
+      !
+      ll_dyn2d = .true.
+      ll_dyn3d = .true.
+      !
+      IF( PRESENT(dyn3d_only) ) THEN
+         IF( dyn3d_only )   ll_dyn2d = .false.
+      ENDIF
+      !
+      ll_orlanski = .false.
+      DO ib_bdy = 1, nb_bdy
+         IF ( cn_dyn2d(ib_bdy) == 'orlanski' .OR. cn_dyn2d(ib_bdy) == 'orlanski_npo' &
+     &   .OR. cn_dyn3d(ib_bdy) == 'orlanski' .OR. cn_dyn3d(ib_bdy) == 'orlanski_npo')   ll_orlanski = .true.
+      END DO
+
+      !-------------------------------------------------------
+      ! Split velocities into barotropic and baroclinic parts
+      !-------------------------------------------------------
+
+      !                          ! "After" velocities: 
+      pua2d(:,:) = 0._wp
+      pva2d(:,:) = 0._wp     
+      DO jk = 1, jpkm1
+         pua2d(:,:) = pua2d(:,:) + e3u_a(:,:,jk) * ua(:,:,jk) * umask(:,:,jk)
+         pva2d(:,:) = pva2d(:,:) + e3v_a(:,:,jk) * va(:,:,jk) * vmask(:,:,jk)
+      END DO
+      pua2d(:,:) = pua2d(:,:) * r1_hu_a(:,:)
+      pva2d(:,:) = pva2d(:,:) * r1_hv_a(:,:)
+
+      DO jk = 1 , jpkm1
+         ua(:,:,jk) = ( ua(:,:,jk) - pua2d(:,:) ) * umask(:,:,jk)
+         va(:,:,jk) = ( va(:,:,jk) - pva2d(:,:) ) * vmask(:,:,jk)
+      END DO
+
+
+      IF( ll_orlanski ) THEN     ! "Before" velocities (Orlanski condition only) 
+         DO jk = 1 , jpkm1
+            ub(:,:,jk) = ( ub(:,:,jk) - ub_b(:,:) ) * umask(:,:,jk)
+            vb(:,:,jk) = ( vb(:,:,jk) - vb_b(:,:) ) * vmask(:,:,jk)
+         END DO
+      ENDIF
+
+      !-------------------------------------------------------
+      ! Apply boundary conditions to barotropic and baroclinic
+      ! parts separately
+      !-------------------------------------------------------
+
+      IF( ll_dyn2d )   CALL bdy_dyn2d( kt, pua2d, pva2d, ub_b, vb_b, r1_hu_a(:,:), r1_hv_a(:,:), ssha )
+
+      IF( ll_dyn3d )   CALL bdy_dyn3d( kt )
+
+      !-------------------------------------------------------
+      ! Recombine velocities
+      !-------------------------------------------------------
+      !
+      DO jk = 1 , jpkm1
+         ua(:,:,jk) = ( ua(:,:,jk) + pua2d(:,:) ) * umask(:,:,jk)
+         va(:,:,jk) = ( va(:,:,jk) + pva2d(:,:) ) * vmask(:,:,jk)
+      END DO
+      !
+      IF ( ll_orlanski ) THEN
+         DO jk = 1 , jpkm1
+            ub(:,:,jk) = ( ub(:,:,jk) + ub_b(:,:) ) * umask(:,:,jk)
+            vb(:,:,jk) = ( vb(:,:,jk) + vb_b(:,:) ) * vmask(:,:,jk)
+         END DO
+      END IF
+      !
+   END SUBROUTINE bdy_dyn
+
+   !!======================================================================
+END MODULE bdydyn
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/BDY/bdydyn2d.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/BDY/bdydyn2d.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/BDY/bdydyn2d.F90	(revision 9570)
@@ -0,0 +1,300 @@
+MODULE bdydyn2d
+   !!======================================================================
+   !!                       ***  MODULE  bdydyn  ***
+   !! Unstructured Open Boundary Cond. :   Apply boundary conditions to barotropic solution
+   !!======================================================================
+   !! History :  3.4  !  2011     (D. Storkey) new module as part of BDY rewrite
+   !!            3.5  !  2012     (S. Mocavero, I. Epicoco) Optimization of BDY communications
+   !!            3.5  !  2013-07  (J. Chanut) Compliant with time splitting changes
+   !!----------------------------------------------------------------------
+   !!   bdy_dyn2d          : Apply open boundary conditions to barotropic variables.
+   !!   bdy_dyn2d_frs      : Apply Flow Relaxation Scheme 
+   !!   bdy_dyn2d_fla      : Apply Flather condition
+   !!   bdy_dyn2d_orlanski : Orlanski Radiation
+   !!   bdy_ssh            : Duplicate sea level across open boundaries
+   !!----------------------------------------------------------------------
+   USE oce             ! ocean dynamics and tracers 
+   USE dom_oce         ! ocean space and time domain
+   USE bdy_oce         ! ocean open boundary conditions
+   USE bdylib          ! BDY library routines
+   USE phycst          ! physical constants
+   USE lbclnk          ! ocean lateral boundary conditions (or mpp link)
+   USE wet_dry         ! Use wet dry to get reference ssh level
+   USE in_out_manager  !
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   bdy_dyn2d   ! routine called in dynspg_ts and bdy_dyn
+   PUBLIC   bdy_ssh       ! routine called in dynspg_ts or sshwzv
+
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO Consortium (2010)
+   !! $Id$ 
+   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE bdy_dyn2d( kt, pua2d, pva2d, pub2d, pvb2d, phur, phvr, pssh  )
+      !!----------------------------------------------------------------------
+      !!                  ***  SUBROUTINE bdy_dyn2d  ***
+      !!
+      !! ** Purpose : - Apply open boundary conditions for barotropic variables
+      !!
+      !!----------------------------------------------------------------------
+      INTEGER,                      INTENT(in) ::   kt   ! Main time step counter
+      REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pua2d, pva2d 
+      REAL(wp), DIMENSION(jpi,jpj), INTENT(in   ) :: pub2d, pvb2d
+      REAL(wp), DIMENSION(jpi,jpj), INTENT(in   ) :: phur, phvr
+      REAL(wp), DIMENSION(jpi,jpj), INTENT(in   ) :: pssh
+      !!
+      INTEGER                                  ::   ib_bdy ! Loop counter
+
+      DO ib_bdy=1, nb_bdy
+
+         SELECT CASE( cn_dyn2d(ib_bdy) )
+         CASE('none')
+            CYCLE
+         CASE('frs')
+            CALL bdy_dyn2d_frs( idx_bdy(ib_bdy), dta_bdy(ib_bdy), ib_bdy, pua2d, pva2d )
+         CASE('flather')
+            CALL bdy_dyn2d_fla( idx_bdy(ib_bdy), dta_bdy(ib_bdy), ib_bdy, pua2d, pva2d, pssh, phur, phvr )
+         CASE('orlanski')
+            CALL bdy_dyn2d_orlanski( idx_bdy(ib_bdy), dta_bdy(ib_bdy), ib_bdy, &
+                                     & pua2d, pva2d, pub2d, pvb2d, ll_npo=.false.)
+         CASE('orlanski_npo')
+            CALL bdy_dyn2d_orlanski( idx_bdy(ib_bdy), dta_bdy(ib_bdy), ib_bdy, &
+                                     & pua2d, pva2d, pub2d, pvb2d, ll_npo=.true. )
+         CASE DEFAULT
+            CALL ctl_stop( 'bdy_dyn2d : unrecognised option for open boundaries for barotropic variables' )
+         END SELECT
+      ENDDO
+
+   END SUBROUTINE bdy_dyn2d
+
+   SUBROUTINE bdy_dyn2d_frs( idx, dta, ib_bdy, pua2d, pva2d )
+      !!----------------------------------------------------------------------
+      !!                  ***  SUBROUTINE bdy_dyn2d_frs  ***
+      !!
+      !! ** Purpose : - Apply the Flow Relaxation Scheme for barotropic velocities
+      !!                at open boundaries.
+      !!
+      !! References :- Engedahl H., 1995: Use of the flow relaxation scheme in 
+      !!               a three-dimensional baroclinic ocean model with realistic
+      !!               topography. Tellus, 365-382.
+      !!----------------------------------------------------------------------
+      TYPE(OBC_INDEX), INTENT(in) ::   idx  ! OBC indices
+      TYPE(OBC_DATA),  INTENT(in) ::   dta  ! OBC external data
+      INTEGER,         INTENT(in) ::   ib_bdy  ! BDY set index
+      REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pua2d, pva2d 
+      !!
+      INTEGER  ::   jb, jk         ! dummy loop indices
+      INTEGER  ::   ii, ij, igrd   ! local integers
+      REAL(wp) ::   zwgt           ! boundary weight
+      !!----------------------------------------------------------------------
+      !
+      igrd = 2                      ! Relaxation of zonal velocity
+      DO jb = 1, idx%nblen(igrd)
+         ii   = idx%nbi(jb,igrd)
+         ij   = idx%nbj(jb,igrd)
+         zwgt = idx%nbw(jb,igrd)
+         pua2d(ii,ij) = ( pua2d(ii,ij) + zwgt * ( dta%u2d(jb) - pua2d(ii,ij) ) ) * umask(ii,ij,1)
+      END DO
+      !
+      igrd = 3                      ! Relaxation of meridional velocity
+      DO jb = 1, idx%nblen(igrd)
+         ii   = idx%nbi(jb,igrd)
+         ij   = idx%nbj(jb,igrd)
+         zwgt = idx%nbw(jb,igrd)
+         pva2d(ii,ij) = ( pva2d(ii,ij) + zwgt * ( dta%v2d(jb) - pva2d(ii,ij) ) ) * vmask(ii,ij,1)
+      END DO 
+      CALL lbc_bdy_lnk( pua2d, 'U', -1., ib_bdy ) 
+      CALL lbc_bdy_lnk( pva2d, 'V', -1., ib_bdy)   ! Boundary points should be updated
+      !
+   END SUBROUTINE bdy_dyn2d_frs
+
+
+   SUBROUTINE bdy_dyn2d_fla( idx, dta, ib_bdy, pua2d, pva2d, pssh, phur, phvr )
+      !!----------------------------------------------------------------------
+      !!                 ***  SUBROUTINE bdy_dyn2d_fla  ***
+      !!             
+      !!              - Apply Flather boundary conditions on normal barotropic velocities 
+      !!
+      !! ** WARNINGS about FLATHER implementation:
+      !!1. According to Palma and Matano, 1998 "after ssh" is used. 
+      !!   In ROMS and POM implementations, it is "now ssh". In the current 
+      !!   implementation (tested only in the EEL-R5 conf.), both cases were unstable. 
+      !!   So I use "before ssh" in the following.
+      !!
+      !!2. We assume that the normal ssh gradient at the bdy is zero. As a matter of 
+      !!   fact, the model ssh just inside the dynamical boundary is used (the outside  
+      !!   ssh in the code is not updated).
+      !!
+      !! References:  Flather, R. A., 1976: A tidal model of the northwest European
+      !!              continental shelf. Mem. Soc. R. Sci. Liege, Ser. 6,10, 141-164.     
+      !!----------------------------------------------------------------------
+      TYPE(OBC_INDEX),              INTENT(in) ::   idx  ! OBC indices
+      TYPE(OBC_DATA),               INTENT(in) ::   dta  ! OBC external data
+      INTEGER,                      INTENT(in) ::   ib_bdy  ! BDY set index
+      REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pua2d, pva2d
+      REAL(wp), DIMENSION(jpi,jpj), INTENT(in) ::   pssh, phur, phvr 
+
+      INTEGER  ::   jb, igrd                         ! dummy loop indices
+      INTEGER  ::   ii, ij, iim1, iip1, ijm1, ijp1   ! 2D addresses
+      REAL(wp), POINTER :: flagu, flagv              ! short cuts
+      REAL(wp) ::   zcorr                            ! Flather correction
+      REAL(wp) ::   zforc                            ! temporary scalar
+      REAL(wp) ::   zflag, z1_2                      !    "        "
+      !!----------------------------------------------------------------------
+
+      z1_2 = 0.5_wp
+
+      ! ---------------------------------!
+      ! Flather boundary conditions     :!
+      ! ---------------------------------! 
+     
+!!! REPLACE spgu with nemo_wrk work space
+
+      ! Fill temporary array with ssh data (here spgu):
+      igrd = 1
+      spgu(:,:) = 0.0
+      DO jb = 1, idx%nblenrim(igrd)
+         ii = idx%nbi(jb,igrd)
+         ij = idx%nbj(jb,igrd)
+         IF( ll_wd ) THEN
+            spgu(ii, ij) = dta%ssh(jb)  - ssh_ref 
+         ELSE
+            spgu(ii, ij) = dta%ssh(jb)
+         ENDIF
+      END DO
+
+      CALL lbc_bdy_lnk( spgu(:,:), 'T', 1., ib_bdy )
+      !
+      igrd = 2      ! Flather bc on u-velocity; 
+      !             ! remember that flagu=-1 if normal velocity direction is outward
+      !             ! I think we should rather use after ssh ?
+      DO jb = 1, idx%nblenrim(igrd)
+         ii  = idx%nbi(jb,igrd)
+         ij  = idx%nbj(jb,igrd) 
+         flagu => idx%flagu(jb,igrd)
+         iim1 = ii + MAX( 0, INT( flagu ) )   ! T pts i-indice inside the boundary
+         iip1 = ii - MIN( 0, INT( flagu ) )   ! T pts i-indice outside the boundary 
+         !
+         zcorr = - flagu * SQRT( grav * phur(ii, ij) ) * ( pssh(iim1, ij) - spgu(iip1,ij) )
+
+         ! jchanut tschanges: Set zflag to 0 below to revert to Flather scheme
+         ! Use characteristics method instead
+         zflag = ABS(flagu)
+         zforc = dta%u2d(jb) * (1._wp - z1_2*zflag) + z1_2 * zflag * pua2d(iim1,ij)
+         pua2d(ii,ij) = zforc + (1._wp - z1_2*zflag) * zcorr * umask(ii,ij,1) 
+      END DO
+      !
+      igrd = 3      ! Flather bc on v-velocity
+      !             ! remember that flagv=-1 if normal velocity direction is outward
+      DO jb = 1, idx%nblenrim(igrd)
+         ii  = idx%nbi(jb,igrd)
+         ij  = idx%nbj(jb,igrd) 
+         flagv => idx%flagv(jb,igrd)
+         ijm1 = ij + MAX( 0, INT( flagv ) )   ! T pts j-indice inside the boundary
+         ijp1 = ij - MIN( 0, INT( flagv ) )   ! T pts j-indice outside the boundary 
+         !
+         zcorr = - flagv * SQRT( grav * phvr(ii, ij) ) * ( pssh(ii, ijm1) - spgu(ii,ijp1) )
+
+         ! jchanut tschanges: Set zflag to 0 below to revert to std Flather scheme
+         ! Use characteristics method instead
+         zflag = ABS(flagv)
+         zforc  = dta%v2d(jb) * (1._wp - z1_2*zflag) + z1_2 * zflag * pva2d(ii,ijm1)
+         pva2d(ii,ij) = zforc + (1._wp - z1_2*zflag) * zcorr * vmask(ii,ij,1)
+      END DO
+      CALL lbc_bdy_lnk( pua2d, 'U', -1., ib_bdy )   ! Boundary points should be updated
+      CALL lbc_bdy_lnk( pva2d, 'V', -1., ib_bdy )   !
+      !
+   END SUBROUTINE bdy_dyn2d_fla
+
+
+   SUBROUTINE bdy_dyn2d_orlanski( idx, dta, ib_bdy, pua2d, pva2d, pub2d, pvb2d, ll_npo )
+      !!----------------------------------------------------------------------
+      !!                 ***  SUBROUTINE bdy_dyn2d_orlanski  ***
+      !!             
+      !!              - Apply Orlanski radiation condition adaptively:
+      !!                  - radiation plus weak nudging at outflow points
+      !!                  - no radiation and strong nudging at inflow points
+      !! 
+      !!
+      !! References:  Marchesiello, McWilliams and Shchepetkin, Ocean Modelling vol. 3 (2001)    
+      !!----------------------------------------------------------------------
+      TYPE(OBC_INDEX),              INTENT(in) ::   idx  ! OBC indices
+      TYPE(OBC_DATA),               INTENT(in) ::   dta  ! OBC external data
+      INTEGER,                      INTENT(in) ::   ib_bdy  ! number of current open boundary set
+      REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pua2d, pva2d
+      REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pub2d, pvb2d 
+      LOGICAL,                      INTENT(in) ::   ll_npo  ! flag for NPO version
+
+      INTEGER  ::   ib, igrd                               ! dummy loop indices
+      INTEGER  ::   ii, ij, iibm1, ijbm1                   ! indices
+      !!----------------------------------------------------------------------
+      !
+      igrd = 2      ! Orlanski bc on u-velocity; 
+      !            
+      CALL bdy_orlanski_2d( idx, igrd, pub2d, pua2d, dta%u2d, ll_npo )
+
+      igrd = 3      ! Orlanski bc on v-velocity
+      !  
+      CALL bdy_orlanski_2d( idx, igrd, pvb2d, pva2d, dta%v2d, ll_npo )
+      !
+      CALL lbc_bdy_lnk( pua2d, 'U', -1., ib_bdy )   ! Boundary points should be updated
+      CALL lbc_bdy_lnk( pva2d, 'V', -1., ib_bdy )   !
+      !
+   END SUBROUTINE bdy_dyn2d_orlanski
+
+
+   SUBROUTINE bdy_ssh( zssh )
+      !!----------------------------------------------------------------------
+      !!                  ***  SUBROUTINE bdy_ssh  ***
+      !!
+      !! ** Purpose : Duplicate sea level across open boundaries
+      !!
+      !!----------------------------------------------------------------------
+      REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) ::   zssh ! Sea level
+      !!
+      INTEGER  ::   ib_bdy, ib, igrd                        ! local integers
+      INTEGER  ::   ii, ij, zcoef, zcoef1, zcoef2, ip, jp   !   "       "
+
+      igrd = 1                       ! Everything is at T-points here
+
+      DO ib_bdy = 1, nb_bdy
+         DO ib = 1, idx_bdy(ib_bdy)%nblenrim(igrd)
+            ii = idx_bdy(ib_bdy)%nbi(ib,igrd)
+            ij = idx_bdy(ib_bdy)%nbj(ib,igrd)
+            ! Set gradient direction:
+            zcoef1 = bdytmask(ii-1,ij  ) +  bdytmask(ii+1,ij  )
+            zcoef2 = bdytmask(ii  ,ij-1) +  bdytmask(ii  ,ij+1)
+            IF ( zcoef1+zcoef2 == 0 ) THEN
+               ! corner
+!               zcoef = tmask(ii-1,ij,1) + tmask(ii+1,ij,1) +  tmask(ii,ij-1,1) +  tmask(ii,ij+1,1)
+!               zssh(ii,ij) = zssh(ii-1,ij  ) * tmask(ii-1,ij  ,1) + &
+!                 &           zssh(ii+1,ij  ) * tmask(ii+1,ij  ,1) + &
+!                 &           zssh(ii  ,ij-1) * tmask(ii  ,ij-1,1) + &
+!                 &           zssh(ii  ,ij+1) * tmask(ii  ,ij+1,1)
+               zcoef = bdytmask(ii-1,ij) + bdytmask(ii+1,ij) +  bdytmask(ii,ij-1) +  bdytmask(ii,ij+1)
+               zssh(ii,ij) = zssh(ii-1,ij  ) * bdytmask(ii-1,ij  ) + &
+                 &           zssh(ii+1,ij  ) * bdytmask(ii+1,ij  ) + &
+                 &           zssh(ii  ,ij-1) * bdytmask(ii  ,ij-1) + &
+                 &           zssh(ii  ,ij+1) * bdytmask(ii  ,ij+1)
+               zssh(ii,ij) = ( zssh(ii,ij) / MAX( 1, zcoef) ) * tmask(ii,ij,1)
+            ELSE
+               ip = bdytmask(ii+1,ij  ) - bdytmask(ii-1,ij  )
+               jp = bdytmask(ii  ,ij+1) - bdytmask(ii  ,ij-1)
+               zssh(ii,ij) = zssh(ii+ip,ij+jp) * tmask(ii+ip,ij+jp,1)
+            ENDIF
+         END DO
+
+         ! Boundary points should be updated
+         CALL lbc_bdy_lnk( zssh(:,:), 'T', 1., ib_bdy )
+      END DO
+
+   END SUBROUTINE bdy_ssh
+
+   !!======================================================================
+END MODULE bdydyn2d
+
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/BDY/bdydyn3d.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/BDY/bdydyn3d.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/BDY/bdydyn3d.F90	(revision 9570)
@@ -0,0 +1,359 @@
+MODULE bdydyn3d
+   !!======================================================================
+   !!                       ***  MODULE  bdydyn3d  ***
+   !! Unstructured Open Boundary Cond. :   Flow relaxation scheme on baroclinic velocities
+   !!======================================================================
+   !! History :  3.4  !  2011     (D. Storkey) new module as part of BDY rewrite 
+   !!            3.5  !  2012     (S. Mocavero, I. Epicoco) Optimization of BDY communications
+   !!----------------------------------------------------------------------
+   !!   bdy_dyn3d        : apply open boundary conditions to baroclinic velocities
+   !!   bdy_dyn3d_frs    : apply Flow Relaxation Scheme
+   !!----------------------------------------------------------------------
+   USE timing          ! Timing
+   USE oce             ! ocean dynamics and tracers 
+   USE dom_oce         ! ocean space and time domain
+   USE bdy_oce         ! ocean open boundary conditions
+   USE bdylib          ! for orlanski library routines
+   USE lbclnk          ! ocean lateral boundary conditions (or mpp link)
+   USE in_out_manager  !
+   Use phycst
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   bdy_dyn3d     ! routine called by bdy_dyn
+   PUBLIC   bdy_dyn3d_dmp ! routine called by step
+
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO Consortium (2010)
+   !! $Id$ 
+   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE bdy_dyn3d( kt )
+      !!----------------------------------------------------------------------
+      !!                  ***  SUBROUTINE bdy_dyn3d  ***
+      !!
+      !! ** Purpose : - Apply open boundary conditions for baroclinic velocities
+      !!
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT(in) ::   kt   ! Main time step counter
+      !
+      INTEGER ::   ib_bdy   ! loop index
+      !!----------------------------------------------------------------------
+      !
+      DO ib_bdy=1, nb_bdy
+         !
+         SELECT CASE( cn_dyn3d(ib_bdy) )
+         CASE('none')        ;   CYCLE
+         CASE('frs' )        ;   CALL bdy_dyn3d_frs( idx_bdy(ib_bdy), dta_bdy(ib_bdy), kt, ib_bdy )
+         CASE('specified')   ;   CALL bdy_dyn3d_spe( idx_bdy(ib_bdy), dta_bdy(ib_bdy), kt, ib_bdy )
+         CASE('zero')        ;   CALL bdy_dyn3d_zro( idx_bdy(ib_bdy), dta_bdy(ib_bdy), kt, ib_bdy )
+         CASE('orlanski' )   ;   CALL bdy_dyn3d_orlanski( idx_bdy(ib_bdy), dta_bdy(ib_bdy), ib_bdy, ll_npo=.false. )
+         CASE('orlanski_npo');   CALL bdy_dyn3d_orlanski( idx_bdy(ib_bdy), dta_bdy(ib_bdy), ib_bdy, ll_npo=.true. )
+         CASE('zerograd')    ;   CALL bdy_dyn3d_zgrad( idx_bdy(ib_bdy), dta_bdy(ib_bdy), kt, ib_bdy )
+         CASE('neumann')     ;   CALL bdy_dyn3d_nmn( idx_bdy(ib_bdy), ib_bdy )
+         CASE DEFAULT        ;   CALL ctl_stop( 'bdy_dyn3d : unrecognised option for open boundaries for baroclinic velocities' )
+         END SELECT
+      END DO
+      !
+   END SUBROUTINE bdy_dyn3d
+
+
+   SUBROUTINE bdy_dyn3d_spe( idx, dta, kt , ib_bdy )
+      !!----------------------------------------------------------------------
+      !!                  ***  SUBROUTINE bdy_dyn3d_spe  ***
+      !!
+      !! ** Purpose : - Apply a specified value for baroclinic velocities
+      !!                at open boundaries.
+      !!
+      !!----------------------------------------------------------------------
+      INTEGER        , INTENT(in) ::   kt      ! time step index
+      TYPE(OBC_INDEX), INTENT(in) ::   idx     ! OBC indices
+      TYPE(OBC_DATA) , INTENT(in) ::   dta     ! OBC external data
+      INTEGER        , INTENT(in) ::   ib_bdy  ! BDY set index
+      !
+      INTEGER  ::   jb, jk         ! dummy loop indices
+      INTEGER  ::   ii, ij, igrd   ! local integers
+      REAL(wp) ::   zwgt           ! boundary weight
+      !!----------------------------------------------------------------------
+      !
+      igrd = 2                      ! Relaxation of zonal velocity
+      DO jb = 1, idx%nblenrim(igrd)
+         DO jk = 1, jpkm1
+            ii   = idx%nbi(jb,igrd)
+            ij   = idx%nbj(jb,igrd)
+            ua(ii,ij,jk) = dta%u3d(jb,jk) * umask(ii,ij,jk)
+         END DO
+      END DO
+      !
+      igrd = 3                      ! Relaxation of meridional velocity
+      DO jb = 1, idx%nblenrim(igrd)
+         DO jk = 1, jpkm1
+            ii   = idx%nbi(jb,igrd)
+            ij   = idx%nbj(jb,igrd)
+            va(ii,ij,jk) = dta%v3d(jb,jk) * vmask(ii,ij,jk)
+         END DO
+      END DO
+      CALL lbc_bdy_lnk( ua, 'U', -1., ib_bdy )   ! Boundary points should be updated  
+      CALL lbc_bdy_lnk( va, 'V', -1., ib_bdy )   
+      !
+      IF( kt == nit000 )   CLOSE( unit = 102 )
+      !
+   END SUBROUTINE bdy_dyn3d_spe
+
+
+   SUBROUTINE bdy_dyn3d_zgrad( idx, dta, kt , ib_bdy )
+      !!----------------------------------------------------------------------
+      !!                  ***  SUBROUTINE bdy_dyn3d_zgrad  ***
+      !!
+      !! ** Purpose : - Enforce a zero gradient of normal velocity
+      !!
+      !!----------------------------------------------------------------------
+      INTEGER                     ::   kt
+      TYPE(OBC_INDEX), INTENT(in) ::   idx  ! OBC indices
+      TYPE(OBC_DATA),  INTENT(in) ::   dta  ! OBC external data
+      INTEGER,         INTENT(in) ::   ib_bdy  ! BDY set index
+      !!
+      INTEGER  ::   jb, jk         ! dummy loop indices
+      INTEGER  ::   ii, ij, igrd   ! local integers
+      REAL(wp) ::   zwgt           ! boundary weight
+      INTEGER  ::   fu, fv
+      !!----------------------------------------------------------------------
+      !
+      igrd = 2                      ! Copying tangential velocity into bdy points
+      DO jb = 1, idx%nblenrim(igrd)
+         DO jk = 1, jpkm1
+            ii   = idx%nbi(jb,igrd)
+            ij   = idx%nbj(jb,igrd)
+            fu   = ABS( ABS (NINT( idx%flagu(jb,igrd) ) ) - 1 )
+            ua(ii,ij,jk) = ua(ii,ij,jk) * REAL( 1 - fu) + ( ua(ii,ij+fu,jk) * umask(ii,ij+fu,jk) &
+                        &+ ua(ii,ij-fu,jk) * umask(ii,ij-fu,jk) ) * umask(ii,ij,jk) * REAL( fu )
+         END DO
+      END DO
+      !
+      igrd = 3                      ! Copying tangential velocity into bdy points
+      DO jb = 1, idx%nblenrim(igrd)
+         DO jk = 1, jpkm1
+            ii   = idx%nbi(jb,igrd)
+            ij   = idx%nbj(jb,igrd)
+            fv   = ABS( ABS (NINT( idx%flagv(jb,igrd) ) ) - 1 )
+            va(ii,ij,jk) = va(ii,ij,jk) * REAL( 1 - fv ) + ( va(ii+fv,ij,jk) * vmask(ii+fv,ij,jk) &
+                        &+ va(ii-fv,ij,jk) * vmask(ii-fv,ij,jk) ) * vmask(ii,ij,jk) * REAL( fv )
+         END DO
+      END DO
+      CALL lbc_bdy_lnk( ua, 'U', -1., ib_bdy )   ! Boundary points should be updated  
+      CALL lbc_bdy_lnk( va, 'V', -1., ib_bdy )   
+      !
+      IF( kt == nit000 )   CLOSE( unit = 102 )
+      !
+   END SUBROUTINE bdy_dyn3d_zgrad
+
+
+   SUBROUTINE bdy_dyn3d_zro( idx, dta, kt, ib_bdy )
+      !!----------------------------------------------------------------------
+      !!                  ***  SUBROUTINE bdy_dyn3d_zro  ***
+      !!
+      !! ** Purpose : - baroclinic velocities = 0. at open boundaries.
+      !!
+      !!----------------------------------------------------------------------
+      INTEGER        , INTENT(in) ::   kt      ! time step index
+      TYPE(OBC_INDEX), INTENT(in) ::   idx     ! OBC indices
+      TYPE(OBC_DATA) , INTENT(in) ::   dta     ! OBC external data
+      INTEGER,         INTENT(in) ::   ib_bdy  ! BDY set index
+      !
+      INTEGER  ::   ib, ik         ! dummy loop indices
+      INTEGER  ::   ii, ij, igrd   ! local integers
+      REAL(wp) ::   zwgt           ! boundary weight
+      !!----------------------------------------------------------------------
+      !
+      igrd = 2                       ! Everything is at T-points here
+      DO ib = 1, idx%nblenrim(igrd)
+         ii = idx%nbi(ib,igrd)
+         ij = idx%nbj(ib,igrd)
+         DO ik = 1, jpkm1
+            ua(ii,ij,ik) = 0._wp
+         END DO
+      END DO
+
+      igrd = 3                       ! Everything is at T-points here
+      DO ib = 1, idx%nblenrim(igrd)
+         ii = idx%nbi(ib,igrd)
+         ij = idx%nbj(ib,igrd)
+         DO ik = 1, jpkm1
+            va(ii,ij,ik) = 0._wp
+         END DO
+      END DO
+      !
+      CALL lbc_bdy_lnk( ua, 'U', -1., ib_bdy )   ;   CALL lbc_bdy_lnk( va, 'V', -1.,ib_bdy )   ! Boundary points should be updated
+      !
+      IF( kt == nit000 )   CLOSE( unit = 102 )
+      !
+   END SUBROUTINE bdy_dyn3d_zro
+
+
+   SUBROUTINE bdy_dyn3d_frs( idx, dta, kt, ib_bdy )
+      !!----------------------------------------------------------------------
+      !!                  ***  SUBROUTINE bdy_dyn3d_frs  ***
+      !!
+      !! ** Purpose : - Apply the Flow Relaxation Scheme for baroclinic velocities
+      !!                at open boundaries.
+      !!
+      !! References :- Engedahl H., 1995: Use of the flow relaxation scheme in 
+      !!               a three-dimensional baroclinic ocean model with realistic
+      !!               topography. Tellus, 365-382.
+      !!----------------------------------------------------------------------
+      INTEGER        , INTENT(in) ::   kt      ! time step index
+      TYPE(OBC_INDEX), INTENT(in) ::   idx     ! OBC indices
+      TYPE(OBC_DATA) , INTENT(in) ::   dta     ! OBC external data
+      INTEGER,         INTENT(in) ::   ib_bdy  ! BDY set index
+      !
+      INTEGER  ::   jb, jk         ! dummy loop indices
+      INTEGER  ::   ii, ij, igrd   ! local integers
+      REAL(wp) ::   zwgt           ! boundary weight
+      !!----------------------------------------------------------------------
+      !
+      igrd = 2                      ! Relaxation of zonal velocity
+      DO jb = 1, idx%nblen(igrd)
+         DO jk = 1, jpkm1
+            ii   = idx%nbi(jb,igrd)
+            ij   = idx%nbj(jb,igrd)
+            zwgt = idx%nbw(jb,igrd)
+            ua(ii,ij,jk) = ( ua(ii,ij,jk) + zwgt * ( dta%u3d(jb,jk) - ua(ii,ij,jk) ) ) * umask(ii,ij,jk)
+         END DO
+      END DO
+      !
+      igrd = 3                      ! Relaxation of meridional velocity
+      DO jb = 1, idx%nblen(igrd)
+         DO jk = 1, jpkm1
+            ii   = idx%nbi(jb,igrd)
+            ij   = idx%nbj(jb,igrd)
+            zwgt = idx%nbw(jb,igrd)
+            va(ii,ij,jk) = ( va(ii,ij,jk) + zwgt * ( dta%v3d(jb,jk) - va(ii,ij,jk) ) ) * vmask(ii,ij,jk)
+         END DO
+      END DO 
+      CALL lbc_bdy_lnk( ua, 'U', -1., ib_bdy )    ! Boundary points should be updated
+      CALL lbc_bdy_lnk( va, 'V', -1., ib_bdy )   
+      !
+      IF( kt == nit000 )   CLOSE( unit = 102 )
+      !
+   END SUBROUTINE bdy_dyn3d_frs
+
+
+   SUBROUTINE bdy_dyn3d_orlanski( idx, dta, ib_bdy, ll_npo )
+      !!----------------------------------------------------------------------
+      !!                 ***  SUBROUTINE bdy_dyn3d_orlanski  ***
+      !!             
+      !!              - Apply Orlanski radiation to baroclinic velocities. 
+      !!              - Wrapper routine for bdy_orlanski_3d
+      !! 
+      !!
+      !! References:  Marchesiello, McWilliams and Shchepetkin, Ocean Modelling vol. 3 (2001)    
+      !!----------------------------------------------------------------------
+      TYPE(OBC_INDEX),              INTENT(in) ::   idx  ! OBC indices
+      TYPE(OBC_DATA),               INTENT(in) ::   dta  ! OBC external data
+      INTEGER,                      INTENT(in) ::   ib_bdy  ! BDY set index
+      LOGICAL,                      INTENT(in) ::   ll_npo  ! switch for NPO version
+
+      INTEGER  ::   jb, igrd                               ! dummy loop indices
+      !!----------------------------------------------------------------------
+      !
+      !! Note that at this stage the ub and ua arrays contain the baroclinic velocities. 
+      !
+      igrd = 2      ! Orlanski bc on u-velocity; 
+      !            
+      CALL bdy_orlanski_3d( idx, igrd, ub, ua, dta%u3d, ll_npo )
+
+      igrd = 3      ! Orlanski bc on v-velocity
+      !  
+      CALL bdy_orlanski_3d( idx, igrd, vb, va, dta%v3d, ll_npo )
+      !
+      CALL lbc_bdy_lnk( ua, 'U', -1., ib_bdy )    ! Boundary points should be updated
+      CALL lbc_bdy_lnk( va, 'V', -1., ib_bdy )   
+      !
+   END SUBROUTINE bdy_dyn3d_orlanski
+
+
+   SUBROUTINE bdy_dyn3d_dmp( kt )
+      !!----------------------------------------------------------------------
+      !!                  ***  SUBROUTINE bdy_dyn3d_dmp  ***
+      !!
+      !! ** Purpose : Apply damping for baroclinic velocities at open boundaries.
+      !!
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT(in) ::   kt   ! time step index
+      !
+      INTEGER  ::   jb, jk         ! dummy loop indices
+      INTEGER  ::   ib_bdy         ! loop index
+      INTEGER  ::   ii, ij, igrd   ! local integers
+      REAL(wp) ::   zwgt           ! boundary weight
+      !!----------------------------------------------------------------------
+      !
+      IF( ln_timing )   CALL timing_start('bdy_dyn3d_dmp')
+      !
+      DO ib_bdy=1, nb_bdy
+         IF ( ln_dyn3d_dmp(ib_bdy) .and. cn_dyn3d(ib_bdy) /= 'none' ) THEN
+            igrd = 2                      ! Relaxation of zonal velocity
+            DO jb = 1, idx_bdy(ib_bdy)%nblen(igrd)
+               ii   = idx_bdy(ib_bdy)%nbi(jb,igrd)
+               ij   = idx_bdy(ib_bdy)%nbj(jb,igrd)
+               zwgt = idx_bdy(ib_bdy)%nbd(jb,igrd)
+               DO jk = 1, jpkm1
+                  ua(ii,ij,jk) = ( ua(ii,ij,jk) + zwgt * ( dta_bdy(ib_bdy)%u3d(jb,jk) - &
+                                   ub(ii,ij,jk) + ub_b(ii,ij)) ) * umask(ii,ij,jk)
+               END DO
+            END DO
+            !
+            igrd = 3                      ! Relaxation of meridional velocity
+            DO jb = 1, idx_bdy(ib_bdy)%nblen(igrd)
+               ii   = idx_bdy(ib_bdy)%nbi(jb,igrd)
+               ij   = idx_bdy(ib_bdy)%nbj(jb,igrd)
+               zwgt = idx_bdy(ib_bdy)%nbd(jb,igrd)
+               DO jk = 1, jpkm1
+                  va(ii,ij,jk) = ( va(ii,ij,jk) + zwgt * ( dta_bdy(ib_bdy)%v3d(jb,jk) -  &
+                                   vb(ii,ij,jk) + vb_b(ii,ij)) ) * vmask(ii,ij,jk)
+               END DO
+            END DO
+         ENDIF
+      END DO
+      !
+      CALL lbc_lnk_multi( ua, 'U', -1.,  va, 'V', -1. )   ! Boundary points should be updated
+      !
+      IF( ln_timing )   CALL timing_stop('bdy_dyn3d_dmp')
+      !
+   END SUBROUTINE bdy_dyn3d_dmp
+
+
+   SUBROUTINE bdy_dyn3d_nmn( idx, ib_bdy )
+      !!----------------------------------------------------------------------
+      !!                 ***  SUBROUTINE bdy_dyn3d_nmn  ***
+      !!             
+      !!              - Apply Neumann condition to baroclinic velocities. 
+      !!              - Wrapper routine for bdy_nmn
+      !! 
+      !!
+      !!----------------------------------------------------------------------
+      TYPE(OBC_INDEX),              INTENT(in) ::   idx  ! OBC indices
+      INTEGER,                      INTENT(in) ::   ib_bdy  ! BDY set index
+
+      INTEGER  ::   jb, igrd                               ! dummy loop indices
+      !!----------------------------------------------------------------------
+      !
+      !! Note that at this stage the ub and ua arrays contain the baroclinic velocities. 
+      !
+      igrd = 2      ! Neumann bc on u-velocity; 
+      !            
+      CALL bdy_nmn( idx, igrd, ua )
+
+      igrd = 3      ! Neumann bc on v-velocity
+      !  
+      CALL bdy_nmn( idx, igrd, va )
+      !
+      CALL lbc_bdy_lnk( ua, 'U', -1., ib_bdy )    ! Boundary points should be updated
+      CALL lbc_bdy_lnk( va, 'V', -1., ib_bdy )
+      !
+   END SUBROUTINE bdy_dyn3d_nmn
+
+   !!======================================================================
+END MODULE bdydyn3d
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/BDY/bdyice.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/BDY/bdyice.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/BDY/bdyice.F90	(revision 9570)
@@ -0,0 +1,366 @@
+MODULE bdyice
+   !!======================================================================
+   !!                       ***  MODULE  bdyice  ***
+   !! Unstructured Open Boundary Cond. :  Open boundary conditions for sea-ice (LIM3)
+   !!======================================================================
+   !!  History :  3.3  !  2010-09 (D. Storkey)  Original code
+   !!             3.4  !  2011    (D. Storkey)  rewrite in preparation for OBC-BDY merge
+   !!              -   !  2012-01 (C. Rousset)  add lim3 and remove useless jk loop 
+   !!----------------------------------------------------------------------
+#if defined key_si3
+   !!----------------------------------------------------------------------
+   !!   'key_si3'                                                 LIM-3 sea ice model
+   !!----------------------------------------------------------------------
+   !!   bdy_ice        : Application of open boundaries to ice
+   !!   bdy_ice_frs    : Application of Flow Relaxation Scheme
+   !!----------------------------------------------------------------------
+   USE oce             ! ocean dynamics and tracers variables
+   USE ice             ! sea-ice: variables
+   USE icevar          ! sea-ice: operations
+   USE iceitd          ! sea-ice: rebining
+   USE icectl          ! sea-ice: control prints
+   USE phycst          ! physical constant
+   USE eosbn2          ! equation of state
+   USE par_oce         ! ocean parameters
+   USE dom_oce         ! ocean space and time domain variables 
+   USE sbc_oce         ! Surface boundary condition: ocean fields
+   USE bdy_oce         ! ocean open boundary conditions
+   !
+   USE lbclnk          ! ocean lateral boundary conditions (or mpp link)
+   USE in_out_manager  ! write to numout file
+   USE lib_mpp         ! distributed memory computing
+   USE lib_fortran     ! to use key_nosignedzero
+   USE timing          ! Timing
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   bdy_ice     ! routine called in sbcmod
+   PUBLIC   bdy_ice_dyn ! routine called in limrhg
+
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 4.0 , NEMO Consortium (2017)
+   !! $Id: bdyice.F90 8306 2017-07-10 10:18:03Z clem $
+   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE bdy_ice( kt )
+      !!----------------------------------------------------------------------
+      !!                  ***  SUBROUTINE bdy_ice  ***
+      !!
+      !! ** Purpose : - Apply open boundary conditions for ice (LIM3)
+      !!
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT(in) ::   kt   ! Main time step counter
+      !
+      INTEGER ::   ib_bdy   ! Loop index
+      !!----------------------------------------------------------------------
+      !
+      IF( ln_timing )   CALL timing_start('bdy_ice')
+      !
+      CALL ice_var_glo2eqv
+      !
+      DO ib_bdy = 1, nb_bdy
+         !
+         SELECT CASE( cn_ice_lim(ib_bdy) )
+         CASE('none')   ;   CYCLE
+         CASE('frs' )   ;   CALL bdy_ice_frs( idx_bdy(ib_bdy), dta_bdy(ib_bdy), kt, ib_bdy )
+         CASE DEFAULT
+            CALL ctl_stop( 'bdy_ice : unrecognised option for open boundaries for ice fields' )
+         END SELECT
+         !
+      END DO
+      !
+      CALL ice_var_zapsmall
+      CALL ice_var_agg(1)
+      !
+      IF( ln_icectl )   CALL ice_prt( kt, iiceprt, jiceprt, 1, ' - ice thermo bdy - ' )
+      IF( ln_timing )   CALL timing_stop('bdy_ice')
+      !
+   END SUBROUTINE bdy_ice
+
+
+   SUBROUTINE bdy_ice_frs( idx, dta, kt, ib_bdy )
+      !!------------------------------------------------------------------------------
+      !!                 ***  SUBROUTINE bdy_ice_frs  ***
+      !!                    
+      !! ** Purpose : Apply the Flow Relaxation Scheme for sea-ice fields in the case 
+      !!              of unstructured open boundaries.
+      !! 
+      !! Reference : Engedahl H., 1995: Use of the flow relaxation scheme in a three-
+      !!             dimensional baroclinic ocean model with realistic topography. Tellus, 365-382.
+      !!------------------------------------------------------------------------------
+      TYPE(OBC_INDEX), INTENT(in) ::   idx     ! OBC indices
+      TYPE(OBC_DATA),  INTENT(in) ::   dta     ! OBC external data
+      INTEGER,         INTENT(in) ::   kt      ! main time-step counter
+      INTEGER,         INTENT(in) ::   ib_bdy  ! BDY set index
+      !
+      INTEGER  ::   jpbound            ! 0 = incoming ice
+      !                                ! 1 = outgoing ice
+      INTEGER  ::   jb, jk, jgrd, jl   ! dummy loop indices
+      INTEGER  ::   ji, jj, ii, ij     ! local scalar
+      REAL(wp) ::   zwgt, zwgt1        ! local scalar
+      REAL(wp) ::   ztmelts, zdh
+      !!------------------------------------------------------------------------------
+      !
+      jgrd = 1      ! Everything is at T-points here
+      !
+      DO jl = 1, jpl
+         DO jb = 1, idx%nblenrim(jgrd)
+            ji    = idx%nbi(jb,jgrd)
+            jj    = idx%nbj(jb,jgrd)
+            zwgt  = idx%nbw(jb,jgrd)
+            zwgt1 = 1.e0 - idx%nbw(jb,jgrd)
+            a_i(ji,jj,jl) = ( a_i(ji,jj,jl) * zwgt1 + dta%a_i(jb,jl) * zwgt ) * tmask(ji,jj,1)  ! Leads fraction 
+            h_i(ji,jj,jl) = ( h_i(ji,jj,jl) * zwgt1 + dta%h_i(jb,jl) * zwgt ) * tmask(ji,jj,1)  ! Ice depth 
+            h_s(ji,jj,jl) = ( h_s(ji,jj,jl) * zwgt1 + dta%h_s(jb,jl) * zwgt ) * tmask(ji,jj,1)  ! Snow depth
+
+            ! -----------------
+            ! Pathological case
+            ! -----------------
+            ! In case a) snow load would be in excess or b) ice is coming into a warmer environment that would lead to 
+            ! very large transformation from snow to ice (see icethd_dh.F90)
+
+            ! Then, a) transfer the snow excess into the ice (different from icethd_dh)
+            zdh = MAX( 0._wp, ( rhosn * h_s(ji,jj,jl) + ( rhoic - rau0 ) * h_i(ji,jj,jl) ) * r1_rau0 )
+            ! Or, b) transfer all the snow into ice (if incoming ice is likely to melt as it comes into a warmer environment)
+            !zdh = MAX( 0._wp, h_s(ji,jj,jl) * rhosn / rhoic )
+
+            ! recompute h_i, h_s
+            h_i(ji,jj,jl) = MIN( hi_max(jl), h_i(ji,jj,jl) + zdh )
+            h_s(ji,jj,jl) = MAX( 0._wp, h_s(ji,jj,jl) - zdh * rhoic / rhosn ) 
+
+         ENDDO
+         CALL lbc_bdy_lnk( a_i(:,:,jl), 'T', 1., ib_bdy )
+         CALL lbc_bdy_lnk( h_i(:,:,jl), 'T', 1., ib_bdy )
+         CALL lbc_bdy_lnk( h_s(:,:,jl), 'T', 1., ib_bdy )
+      ENDDO
+      ! retrieve at_i
+      at_i(:,:) = 0._wp
+      DO jl = 1, jpl
+         at_i(:,:) = a_i(:,:,jl) + at_i(:,:)
+      END DO
+
+      DO jl = 1, jpl
+         DO jb = 1, idx%nblenrim(jgrd)
+            ji    = idx%nbi(jb,jgrd)
+            jj    = idx%nbj(jb,jgrd)
+
+            ! condition on ice thickness depends on the ice velocity
+            ! if velocity is outward (strictly), then ice thickness, volume... must be equal to adjacent values
+            jpbound = 0   ;   ii = ji   ;   ij = jj
+            !
+            IF( u_ice(ji+1,jj  ) < 0. .AND. umask(ji-1,jj  ,1) == 0. ) jpbound = 1; ii = ji+1; ij = jj
+            IF( u_ice(ji-1,jj  ) > 0. .AND. umask(ji+1,jj  ,1) == 0. ) jpbound = 1; ii = ji-1; ij = jj
+            IF( v_ice(ji  ,jj+1) < 0. .AND. vmask(ji  ,jj-1,1) == 0. ) jpbound = 1; ii = ji  ; ij = jj+1
+            IF( v_ice(ji  ,jj-1) > 0. .AND. vmask(ji  ,jj+1,1) == 0. ) jpbound = 1; ii = ji  ; ij = jj-1
+            !
+            IF( nn_ice_lim_dta(ib_bdy) == 0 ) jpbound = 0; ii = ji; ij = jj   ! case ice boundaries = initial conditions
+            !                                                                 !      do not make state variables dependent on velocity
+            !
+            rswitch = MAX( 0.0_wp , SIGN ( 1.0_wp , at_i(ii,ij) - 0.01 ) ) ! 0 if no ice
+            !
+            ! concentration and thickness
+            a_i(ji,jj,jl) = a_i(ii,ij,jl) * rswitch
+            h_i(ji,jj,jl) = h_i(ii,ij,jl) * rswitch
+            h_s(ji,jj,jl) = h_s(ii,ij,jl) * rswitch
+            !
+            ! Ice and snow volumes
+            v_i(ji,jj,jl) = h_i(ji,jj,jl) * a_i(ji,jj,jl)
+            v_s(ji,jj,jl) = h_s(ji,jj,jl) * a_i(ji,jj,jl)
+            !
+            SELECT CASE( jpbound )
+            !
+            CASE( 0 )   ! velocity is inward
+               !
+               ! Ice salinity, age, temperature
+               s_i (ji,jj,jl)   = rswitch * rn_ice_sal(ib_bdy)  + ( 1.0 - rswitch ) * rn_simin
+               oa_i(ji,jj,jl)   = rswitch * rn_ice_age(ib_bdy) * a_i(ji,jj,jl)
+               t_su(ji,jj,jl)   = rswitch * rn_ice_tem(ib_bdy)  + ( 1.0 - rswitch ) * rn_ice_tem(ib_bdy)
+               DO jk = 1, nlay_s
+                  t_s(ji,jj,jk,jl) = rswitch * rn_ice_tem(ib_bdy) + ( 1.0 - rswitch ) * rt0
+               END DO
+               DO jk = 1, nlay_i
+                  t_i (ji,jj,jk,jl) = rswitch * rn_ice_tem(ib_bdy) + ( 1.0 - rswitch ) * rt0 
+                  sz_i(ji,jj,jk,jl) = rswitch * rn_ice_sal(ib_bdy) + ( 1.0 - rswitch ) * rn_simin
+               END DO
+               !
+            CASE( 1 )   ! velocity is outward
+               !
+               ! Ice salinity, age, temperature
+               s_i (ji,jj,jl)   = rswitch * s_i (ii,ij,jl)  + ( 1.0 - rswitch ) * rn_simin
+               oa_i(ji,jj,jl)   = rswitch * oa_i(ii,ij,jl)
+               t_su(ji,jj,jl)   = rswitch * t_su(ii,ij,jl)  + ( 1.0 - rswitch ) * rt0
+               DO jk = 1, nlay_s
+                  t_s(ji,jj,jk,jl) = rswitch * t_s(ii,ij,jk,jl) + ( 1.0 - rswitch ) * rt0
+               END DO
+               DO jk = 1, nlay_i
+                  t_i (ji,jj,jk,jl) = rswitch * t_i (ii,ij,jk,jl) + ( 1.0 - rswitch ) * rt0
+                  sz_i(ji,jj,jk,jl) = rswitch * sz_i(ii,ij,jk,jl) + ( 1.0 - rswitch ) * rn_simin
+               END DO
+               !
+            END SELECT
+            !
+            IF( nn_icesal == 1 ) THEN     ! constant salinity : overwrite rn_icesal
+               s_i (ji,jj  ,jl) = rn_icesal
+               sz_i(ji,jj,:,jl) = rn_icesal
+            ENDIF
+            !
+            ! contents
+            sv_i(ji,jj,jl)  = MIN( s_i(ji,jj,jl) , sss_m(ji,jj) ) * v_i(ji,jj,jl)
+            DO jk = 1, nlay_s
+               ! Snow energy of melting
+               e_s(ji,jj,jk,jl) = rswitch * rhosn * ( cpic * ( rt0 - t_s(ji,jj,jk,jl) ) + lfus )
+               ! Multiply by volume, so that heat content in J/m2
+               e_s(ji,jj,jk,jl) = e_s(ji,jj,jk,jl) * v_s(ji,jj,jl) * r1_nlay_s
+            END DO
+            DO jk = 1, nlay_i
+               ztmelts          = - tmut * sz_i(ji,jj,jk,jl) + rt0 !Melting temperature in K                  
+               ! heat content per unit volume
+               e_i(ji,jj,jk,jl) = rswitch * rhoic * &
+                  (   cpic    * ( ztmelts - t_i(ji,jj,jk,jl) ) &
+                  +   lfus    * ( 1.0 - (ztmelts-rt0) / MIN((t_i(ji,jj,jk,jl)-rt0),-epsi20) ) &
+                  - rcp      * ( ztmelts - rt0 ) )
+               ! Mutliply by ice volume, and divide by number of layers to get heat content in J/m2
+               e_i(ji,jj,jk,jl) = e_i(ji,jj,jk,jl) * a_i(ji,jj,jl) * h_i(ji,jj,jl) * r1_nlay_i
+            END DO
+            !
+         END DO
+         !
+         CALL lbc_bdy_lnk( a_i(:,:,jl), 'T', 1., ib_bdy )
+         CALL lbc_bdy_lnk( h_i(:,:,jl), 'T', 1., ib_bdy )
+         CALL lbc_bdy_lnk( h_s(:,:,jl), 'T', 1., ib_bdy )
+         CALL lbc_bdy_lnk( v_i(:,:,jl), 'T', 1., ib_bdy )
+         CALL lbc_bdy_lnk( v_s(:,:,jl), 'T', 1., ib_bdy )
+         !
+         CALL lbc_bdy_lnk( sv_i(:,:,jl), 'T', 1., ib_bdy )
+         CALL lbc_bdy_lnk(  s_i(:,:,jl), 'T', 1., ib_bdy )
+         CALL lbc_bdy_lnk( oa_i(:,:,jl), 'T', 1., ib_bdy )
+         CALL lbc_bdy_lnk( t_su(:,:,jl), 'T', 1., ib_bdy )
+         DO jk = 1, nlay_s
+            CALL lbc_bdy_lnk(t_s(:,:,jk,jl), 'T', 1., ib_bdy )
+            CALL lbc_bdy_lnk(e_s(:,:,jk,jl), 'T', 1., ib_bdy )
+         END DO
+         DO jk = 1, nlay_i
+            CALL lbc_bdy_lnk(t_i(:,:,jk,jl), 'T', 1., ib_bdy )
+            CALL lbc_bdy_lnk(e_i(:,:,jk,jl), 'T', 1., ib_bdy )
+         END DO
+         !
+      END DO !jl
+      !
+      ! --- In case categories are out of bounds, do a remapping --- !
+      !     i.e. inputs have not the same ice thickness distribution 
+      !          (set by rn_himean) than the regional simulation
+      IF( jpl > 1 )   CALL ice_itd_reb( kt )
+      !      
+   END SUBROUTINE bdy_ice_frs
+
+
+   SUBROUTINE bdy_ice_dyn( cd_type )
+      !!------------------------------------------------------------------------------
+      !!                 ***  SUBROUTINE bdy_ice_dyn  ***
+      !!                    
+      !! ** Purpose : Apply dynamics boundary conditions for sea-ice in the cas of unstructured open boundaries.
+      !!              u_ice and v_ice are equal to the value of the adjacent grid point if this latter is not ice free
+      !!              if adjacent grid point is ice free, then u_ice and v_ice are equal to ocean velocities
+      !!
+      !! 2013-06 : C. Rousset
+      !!------------------------------------------------------------------------------
+      CHARACTER(len=1), INTENT(in)  ::   cd_type   ! nature of velocity grid-points
+      !
+      INTEGER  ::   jb, jgrd           ! dummy loop indices
+      INTEGER  ::   ji, jj             ! local scalar
+      INTEGER  ::   ib_bdy             ! Loop index
+      REAL(wp) ::   zmsk1, zmsk2, zflag
+      !!------------------------------------------------------------------------------
+      !
+      DO ib_bdy=1, nb_bdy
+         !
+         SELECT CASE( cn_ice_lim(ib_bdy) )
+         !
+         CASE('none')
+            CYCLE
+            !
+         CASE('frs')
+            !
+            IF( nn_ice_lim_dta(ib_bdy) == 0 ) CYCLE            ! case ice boundaries = initial conditions 
+            !                                                  !      do not change ice velocity (it is only computed by rheology)
+            SELECT CASE ( cd_type )
+            !     
+            CASE ( 'U' )  
+               jgrd = 2      ! u velocity
+               DO jb = 1, idx_bdy(ib_bdy)%nblenrim(jgrd)
+                  ji    = idx_bdy(ib_bdy)%nbi(jb,jgrd)
+                  jj    = idx_bdy(ib_bdy)%nbj(jb,jgrd)
+                  zflag = idx_bdy(ib_bdy)%flagu(jb,jgrd)
+                  !
+                  IF ( ABS( zflag ) == 1. ) THEN  ! eastern and western boundaries
+                     ! one of the two zmsk is always 0 (because of zflag)
+                     zmsk1 = 1._wp - MAX( 0.0_wp, SIGN ( 1.0_wp , - vt_i(ji+1,jj) ) ) ! 0 if no ice
+                     zmsk2 = 1._wp - MAX( 0.0_wp, SIGN ( 1.0_wp , - vt_i(ji-1,jj) ) ) ! 0 if no ice
+                     !  
+                     ! u_ice = u_ice of the adjacent grid point except if this grid point is ice-free (then u_ice = u_oce)
+                     u_ice (ji,jj) = u_ice(ji+1,jj) * 0.5_wp * ABS( zflag + 1._wp ) * zmsk1 + &
+                        &            u_ice(ji-1,jj) * 0.5_wp * ABS( zflag - 1._wp ) * zmsk2 + &
+                        &            u_oce(ji  ,jj) * ( 1._wp - MIN( 1._wp, zmsk1 + zmsk2 ) )
+                  ELSE                             ! everywhere else
+                     !u_ice(ji,jj) = u_oce(ji,jj)
+                     u_ice(ji,jj) = 0._wp
+                  ENDIF
+                  ! mask ice velocities
+                  rswitch = MAX( 0.0_wp , SIGN ( 1.0_wp , at_i(ji,jj) - 0.01_wp ) ) ! 0 if no ice
+                  u_ice(ji,jj) = rswitch * u_ice(ji,jj)
+                  !
+               END DO
+               CALL lbc_bdy_lnk( u_ice(:,:), 'U', -1., ib_bdy )
+               !
+            CASE ( 'V' )
+               jgrd = 3      ! v velocity
+               DO jb = 1, idx_bdy(ib_bdy)%nblenrim(jgrd)
+                  ji    = idx_bdy(ib_bdy)%nbi(jb,jgrd)
+                  jj    = idx_bdy(ib_bdy)%nbj(jb,jgrd)
+                  zflag = idx_bdy(ib_bdy)%flagv(jb,jgrd)
+                  !
+                  IF ( ABS( zflag ) == 1. ) THEN  ! northern and southern boundaries
+                     ! one of the two zmsk is always 0 (because of zflag)
+                     zmsk1 = 1._wp - MAX( 0.0_wp, SIGN ( 1.0_wp , - vt_i(ji,jj+1) ) ) ! 0 if no ice
+                     zmsk2 = 1._wp - MAX( 0.0_wp, SIGN ( 1.0_wp , - vt_i(ji,jj-1) ) ) ! 0 if no ice
+                     !  
+                     ! u_ice = u_ice of the adjacent grid point except if this grid point is ice-free (then u_ice = u_oce)
+                     v_ice (ji,jj) = v_ice(ji,jj+1) * 0.5_wp * ABS( zflag + 1._wp ) * zmsk1 + &
+                        &            v_ice(ji,jj-1) * 0.5_wp * ABS( zflag - 1._wp ) * zmsk2 + &
+                        &            v_oce(ji,jj  ) * ( 1._wp - MIN( 1._wp, zmsk1 + zmsk2 ) )
+                  ELSE                             ! everywhere else
+                     !v_ice(ji,jj) = v_oce(ji,jj)
+                     v_ice(ji,jj) = 0._wp
+                  ENDIF
+                  ! mask ice velocities
+                  rswitch = MAX( 0.0_wp , SIGN ( 1.0_wp , at_i(ji,jj) - 0.01 ) ) ! 0 if no ice
+                  v_ice(ji,jj) = rswitch * v_ice(ji,jj)
+                  !
+               END DO
+               CALL lbc_bdy_lnk( v_ice(:,:), 'V', -1., ib_bdy )
+               !
+            END SELECT
+            !
+         CASE DEFAULT
+            CALL ctl_stop( 'bdy_ice_dyn : unrecognised option for open boundaries for ice fields' )
+         END SELECT
+         !
+      END DO
+      !
+    END SUBROUTINE bdy_ice_dyn
+
+#else
+   !!---------------------------------------------------------------------------------
+   !!   Default option                                                    Empty module
+   !!---------------------------------------------------------------------------------
+CONTAINS
+   SUBROUTINE bdy_ice( kt )      ! Empty routine
+      WRITE(*,*) 'bdy_ice: You should not have seen this print! error?', kt
+   END SUBROUTINE bdy_ice
+#endif
+
+   !!=================================================================================
+END MODULE bdyice
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/BDY/bdyini.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/BDY/bdyini.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/BDY/bdyini.F90	(revision 9570)
@@ -0,0 +1,1719 @@
+MODULE bdyini
+   !!======================================================================
+   !!                       ***  MODULE  bdyini  ***
+   !! Unstructured open boundaries : initialisation
+   !!======================================================================
+   !! History :  1.0  !  2005-01  (J. Chanut, A. Sellar)  Original code
+   !!             -   !  2007-01  (D. Storkey) Update to use IOM module
+   !!             -   !  2007-01  (D. Storkey) Tidal forcing
+   !!            3.0  !  2008-04  (NEMO team)  add in the reference version
+   !!            3.3  !  2010-09  (E.O'Dea) updates for Shelf configurations
+   !!            3.3  !  2010-09  (D.Storkey) add ice boundary conditions
+   !!            3.4  !  2011     (D. Storkey) rewrite in preparation for OBC-BDY merge
+   !!            3.4  !  2012     (J. Chanut) straight open boundary case update
+   !!            3.5  !  2012     (S. Mocavero, I. Epicoco) optimization of BDY communications
+   !!            3.7  !  2016     (T. Lovato) Remove bdy macro, call here init for dta and tides
+   !!----------------------------------------------------------------------
+   !!   bdy_init      : Initialization of unstructured open boundaries
+   !!----------------------------------------------------------------------
+   USE oce            ! ocean dynamics and tracers variables
+   USE dom_oce        ! ocean space and time domain
+   USE bdy_oce        ! unstructured open boundary conditions
+   USE bdydta         ! open boundary cond. setting   (bdy_dta_init routine)
+   USE bdytides       ! open boundary cond. setting   (bdytide_init routine)
+   USE sbctide        ! Tidal forcing or not
+   USE phycst   , ONLY: rday
+   !
+   USE in_out_manager ! I/O units
+   USE lbclnk         ! ocean lateral boundary conditions (or mpp link)
+   USE lib_mpp        ! for mpp_sum  
+   USE iom            ! I/O
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   bdy_init   ! routine called in nemo_init
+
+   INTEGER, PARAMETER ::   jp_nseg = 100   ! 
+   INTEGER, PARAMETER ::   nrimmax =  20   ! maximum rimwidth in structured
+                                               ! open boundary data files
+   ! Straight open boundary segment parameters:
+   INTEGER  ::   nbdysege, nbdysegw, nbdysegn, nbdysegs 
+   INTEGER, DIMENSION(jp_nseg) ::   jpieob, jpjedt, jpjeft, npckge   !
+   INTEGER, DIMENSION(jp_nseg) ::   jpiwob, jpjwdt, jpjwft, npckgw   !
+   INTEGER, DIMENSION(jp_nseg) ::   jpjnob, jpindt, jpinft, npckgn   !
+   INTEGER, DIMENSION(jp_nseg) ::   jpjsob, jpisdt, jpisft, npckgs   !
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.7 , NEMO Consortium (2015)
+   !! $Id$ 
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE bdy_init
+      !!----------------------------------------------------------------------
+      !!                 ***  ROUTINE bdy_init  ***
+      !!
+      !! ** Purpose :   Initialization of the dynamics and tracer fields with
+      !!              unstructured open boundaries.
+      !!
+      !! ** Method  :   Read initialization arrays (mask, indices) to identify
+      !!              an unstructured open boundary
+      !!
+      !! ** Input   :  bdy_init.nc, input file for unstructured open boundaries
+      !!----------------------------------------------------------------------
+      NAMELIST/nambdy/ ln_bdy, nb_bdy, ln_coords_file, cn_coords_file,         &
+         &             ln_mask_file, cn_mask_file, cn_dyn2d, nn_dyn2d_dta,     &
+         &             cn_dyn3d, nn_dyn3d_dta, cn_tra, nn_tra_dta,             &
+         &             ln_tra_dmp, ln_dyn3d_dmp, rn_time_dmp, rn_time_dmp_out, &
+         &             cn_ice_lim, nn_ice_lim_dta,                             &
+         &             rn_ice_tem, rn_ice_sal, rn_ice_age,                     &
+         &             ln_vol, nn_volctl, nn_rimwidth, nb_jpk_bdy
+         !
+      INTEGER  ::   ios                 ! Local integer output status for namelist read
+      !!----------------------------------------------------------------------
+
+      ! ------------------------
+      ! Read namelist parameters
+      ! ------------------------
+      REWIND( numnam_ref )              ! Namelist nambdy in reference namelist :Unstructured open boundaries
+      READ  ( numnam_ref, nambdy, IOSTAT = ios, ERR = 901)
+901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'nambdy in reference namelist', lwp )
+      REWIND( numnam_cfg )              ! Namelist nambdy in configuration namelist :Unstructured open boundaries
+      READ  ( numnam_cfg, nambdy, IOSTAT = ios, ERR = 902 )
+902   IF( ios >  0 )   CALL ctl_nam ( ios , 'nambdy in configuration namelist', lwp )
+      IF(lwm) WRITE ( numond, nambdy )
+
+      IF( .NOT. Agrif_Root() ) ln_bdy = .FALSE.   ! forced for Agrif children
+      
+      ! -----------------------------------------
+      ! unstructured open boundaries use control
+      ! -----------------------------------------
+      IF ( ln_bdy ) THEN
+         IF(lwp) WRITE(numout,*)
+         IF(lwp) WRITE(numout,*) 'bdy_init : initialization of open boundaries'
+         IF(lwp) WRITE(numout,*) '~~~~~~~~'
+         !
+         ! Open boundaries definition (arrays and masks)
+         CALL bdy_segs
+         !
+         ! Open boundaries initialisation of external data arrays
+         CALL bdy_dta_init
+         !
+         ! Open boundaries initialisation of tidal harmonic forcing
+         IF( ln_tide ) CALL bdytide_init
+         !
+      ELSE
+         IF(lwp) WRITE(numout,*)
+         IF(lwp) WRITE(numout,*) 'bdy_init : open boundaries not used (ln_bdy = F)'
+         IF(lwp) WRITE(numout,*) '~~~~~~~~'
+         !
+      ENDIF
+      !
+   END SUBROUTINE bdy_init
+
+
+   SUBROUTINE bdy_segs
+      !!----------------------------------------------------------------------
+      !!                 ***  ROUTINE bdy_init  ***
+      !!         
+      !! ** Purpose :   Definition of unstructured open boundaries.
+      !!
+      !! ** Method  :   Read initialization arrays (mask, indices) to identify 
+      !!              an unstructured open boundary
+      !!
+      !! ** Input   :  bdy_init.nc, input file for unstructured open boundaries
+      !!----------------------------------------------------------------------      
+      INTEGER  ::   ib_bdy, ii, ij, ik, igrd, ib, ir, iseg ! dummy loop indices
+      INTEGER  ::   icount, icountr, ibr_max, ilen1, ibm1  ! local integers
+      INTEGER  ::   iwe, ies, iso, ino, inum, id_dummy     !   -       -
+      INTEGER  ::   igrd_start, igrd_end, jpbdta           !   -       -
+      INTEGER  ::   jpbdtau, jpbdtas                       !   -       -
+      INTEGER  ::   ib_bdy1, ib_bdy2, ib1, ib2             !   -       -
+      INTEGER  ::   i_offset, j_offset                     !   -       -
+      INTEGER , POINTER  ::  nbi, nbj, nbr                 ! short cuts
+      REAL(wp), POINTER  ::  flagu, flagv                  !    -   -
+      REAL(wp), POINTER, DIMENSION(:,:)       ::   pmask    ! pointer to 2D mask fields
+      REAL(wp) ::   zefl, zwfl, znfl, zsfl                 ! local scalars
+      INTEGER, DIMENSION (2)                  ::   kdimsz
+      INTEGER, DIMENSION(jpbgrd,jp_bdy)       ::   nblendta         ! Length of index arrays 
+      INTEGER, ALLOCATABLE, DIMENSION(:,:,:)  ::   nbidta, nbjdta   ! Index arrays: i and j indices of bdy dta
+      INTEGER, ALLOCATABLE, DIMENSION(:,:,:)  ::   nbrdta           ! Discrete distance from rim points
+      CHARACTER(LEN=1),DIMENSION(jpbgrd)      ::   cgrid
+      INTEGER :: com_east, com_west, com_south, com_north          ! Flags for boundaries sending
+      INTEGER :: com_east_b, com_west_b, com_south_b, com_north_b  ! Flags for boundaries receiving
+      INTEGER :: iw_b(4), ie_b(4), is_b(4), in_b(4)                ! Arrays for neighbours coordinates
+      REAL(wp), TARGET, DIMENSION(jpi,jpj) ::   zfmask  ! temporary fmask array excluding coastal boundary condition (shlat)
+      !!
+      CHARACTER(LEN=1)                     ::   ctypebdy   !     -        - 
+      INTEGER                              ::   nbdyind, nbdybeg, nbdyend
+      !!
+      NAMELIST/nambdy_index/ ctypebdy, nbdyind, nbdybeg, nbdyend
+      INTEGER  ::   ios                 ! Local integer output status for namelist read
+      !!----------------------------------------------------------------------
+      !
+      cgrid = (/'t','u','v'/)
+
+      ! -----------------------------------------
+      ! Check and write out namelist parameters
+      ! -----------------------------------------
+      IF( jperio /= 0 )   CALL ctl_stop( 'bdy_segs: Cyclic or symmetric,',   &
+         &                               ' and general open boundary condition are not compatible' )
+
+      IF( nb_bdy == 0 ) THEN 
+        IF(lwp) WRITE(numout,*) 'nb_bdy = 0, NO OPEN BOUNDARIES APPLIED.'
+      ELSE
+        IF(lwp) WRITE(numout,*) 'Number of open boundary sets : ', nb_bdy
+      ENDIF
+
+      DO ib_bdy = 1,nb_bdy
+        IF(lwp) WRITE(numout,*) ' ' 
+        IF(lwp) WRITE(numout,*) '------ Open boundary data set ',ib_bdy,'------' 
+
+        IF( ln_coords_file(ib_bdy) ) THEN
+           IF(lwp) WRITE(numout,*) 'Boundary definition read from file '//TRIM(cn_coords_file(ib_bdy))
+        ELSE
+           IF(lwp) WRITE(numout,*) 'Boundary defined in namelist.'
+        ENDIF
+        IF(lwp) WRITE(numout,*)
+
+        IF(lwp) WRITE(numout,*) 'Boundary conditions for barotropic solution:  '
+        SELECT CASE( cn_dyn2d(ib_bdy) )                  
+          CASE( 'none' )         
+             IF(lwp) WRITE(numout,*) '      no open boundary condition'        
+             dta_bdy(ib_bdy)%ll_ssh = .false.
+             dta_bdy(ib_bdy)%ll_u2d = .false.
+             dta_bdy(ib_bdy)%ll_v2d = .false.
+          CASE( 'frs' )          
+             IF(lwp) WRITE(numout,*) '      Flow Relaxation Scheme'
+             dta_bdy(ib_bdy)%ll_ssh = .false.
+             dta_bdy(ib_bdy)%ll_u2d = .true.
+             dta_bdy(ib_bdy)%ll_v2d = .true.
+          CASE( 'flather' )      
+             IF(lwp) WRITE(numout,*) '      Flather radiation condition'
+             dta_bdy(ib_bdy)%ll_ssh = .true.
+             dta_bdy(ib_bdy)%ll_u2d = .true.
+             dta_bdy(ib_bdy)%ll_v2d = .true.
+          CASE( 'orlanski' )     
+             IF(lwp) WRITE(numout,*) '      Orlanski (fully oblique) radiation condition with adaptive nudging'
+             dta_bdy(ib_bdy)%ll_ssh = .false.
+             dta_bdy(ib_bdy)%ll_u2d = .true.
+             dta_bdy(ib_bdy)%ll_v2d = .true.
+          CASE( 'orlanski_npo' ) 
+             IF(lwp) WRITE(numout,*) '      Orlanski (NPO) radiation condition with adaptive nudging'
+             dta_bdy(ib_bdy)%ll_ssh = .false.
+             dta_bdy(ib_bdy)%ll_u2d = .true.
+             dta_bdy(ib_bdy)%ll_v2d = .true.
+          CASE DEFAULT   ;   CALL ctl_stop( 'unrecognised value for cn_dyn2d' )
+        END SELECT
+        IF( cn_dyn2d(ib_bdy) /= 'none' ) THEN
+           SELECT CASE( nn_dyn2d_dta(ib_bdy) )                   ! 
+              CASE( 0 )      ;   IF(lwp) WRITE(numout,*) '      initial state used for bdy data'        
+              CASE( 1 )      ;   IF(lwp) WRITE(numout,*) '      boundary data taken from file'
+              CASE( 2 )      ;   IF(lwp) WRITE(numout,*) '      tidal harmonic forcing taken from file'
+              CASE( 3 )      ;   IF(lwp) WRITE(numout,*) '      boundary data AND tidal harmonic forcing taken from files'
+              CASE DEFAULT   ;   CALL ctl_stop( 'nn_dyn2d_dta must be between 0 and 3' )
+           END SELECT
+           IF (( nn_dyn2d_dta(ib_bdy) .ge. 2 ).AND.(.NOT.ln_tide)) THEN
+             CALL ctl_stop( 'You must activate with ln_tide to add tidal forcing at open boundaries' )
+           ENDIF
+        ENDIF
+        IF(lwp) WRITE(numout,*)
+
+        IF(lwp) WRITE(numout,*) 'Boundary conditions for baroclinic velocities:  '
+        SELECT CASE( cn_dyn3d(ib_bdy) )                  
+          CASE('none')
+             IF(lwp) WRITE(numout,*) '      no open boundary condition'        
+             dta_bdy(ib_bdy)%ll_u3d = .false.
+             dta_bdy(ib_bdy)%ll_v3d = .false.
+          CASE('frs')       
+             IF(lwp) WRITE(numout,*) '      Flow Relaxation Scheme'
+             dta_bdy(ib_bdy)%ll_u3d = .true.
+             dta_bdy(ib_bdy)%ll_v3d = .true.
+          CASE('specified')
+             IF(lwp) WRITE(numout,*) '      Specified value'
+             dta_bdy(ib_bdy)%ll_u3d = .true.
+             dta_bdy(ib_bdy)%ll_v3d = .true.
+          CASE('neumann')
+             IF(lwp) WRITE(numout,*) '      Neumann conditions'
+             dta_bdy(ib_bdy)%ll_u3d = .false.
+             dta_bdy(ib_bdy)%ll_v3d = .false.
+          CASE('zerograd')
+             IF(lwp) WRITE(numout,*) '      Zero gradient for baroclinic velocities'
+             dta_bdy(ib_bdy)%ll_u3d = .false.
+             dta_bdy(ib_bdy)%ll_v3d = .false.
+          CASE('zero')
+             IF(lwp) WRITE(numout,*) '      Zero baroclinic velocities (runoff case)'
+             dta_bdy(ib_bdy)%ll_u3d = .false.
+             dta_bdy(ib_bdy)%ll_v3d = .false.
+          CASE('orlanski')
+             IF(lwp) WRITE(numout,*) '      Orlanski (fully oblique) radiation condition with adaptive nudging'
+             dta_bdy(ib_bdy)%ll_u3d = .true.
+             dta_bdy(ib_bdy)%ll_v3d = .true.
+          CASE('orlanski_npo')
+             IF(lwp) WRITE(numout,*) '      Orlanski (NPO) radiation condition with adaptive nudging'
+             dta_bdy(ib_bdy)%ll_u3d = .true.
+             dta_bdy(ib_bdy)%ll_v3d = .true.
+          CASE DEFAULT   ;   CALL ctl_stop( 'unrecognised value for cn_dyn3d' )
+        END SELECT
+        IF( cn_dyn3d(ib_bdy) /= 'none' ) THEN
+           SELECT CASE( nn_dyn3d_dta(ib_bdy) )                   ! 
+              CASE( 0 )      ;   IF(lwp) WRITE(numout,*) '      initial state used for bdy data'        
+              CASE( 1 )      ;   IF(lwp) WRITE(numout,*) '      boundary data taken from file'
+              CASE DEFAULT   ;   CALL ctl_stop( 'nn_dyn3d_dta must be 0 or 1' )
+           END SELECT
+        ENDIF
+
+        IF ( ln_dyn3d_dmp(ib_bdy) ) THEN
+           IF ( cn_dyn3d(ib_bdy) == 'none' ) THEN
+              IF(lwp) WRITE(numout,*) 'No open boundary condition for baroclinic velocities: ln_dyn3d_dmp is set to .false.'
+              ln_dyn3d_dmp(ib_bdy)=.false.
+           ELSEIF ( cn_dyn3d(ib_bdy) == 'frs' ) THEN
+              CALL ctl_stop( 'Use FRS OR relaxation' )
+           ELSE
+              IF(lwp) WRITE(numout,*) '      + baroclinic velocities relaxation zone'
+              IF(lwp) WRITE(numout,*) '      Damping time scale: ',rn_time_dmp(ib_bdy),' days'
+              IF((lwp).AND.rn_time_dmp(ib_bdy)<0) CALL ctl_stop( 'Time scale must be positive' )
+              dta_bdy(ib_bdy)%ll_u3d = .true.
+              dta_bdy(ib_bdy)%ll_v3d = .true.
+           ENDIF
+        ELSE
+           IF(lwp) WRITE(numout,*) '      NO relaxation on baroclinic velocities'
+        ENDIF
+        IF(lwp) WRITE(numout,*)
+
+        IF(lwp) WRITE(numout,*) 'Boundary conditions for temperature and salinity:  '
+        SELECT CASE( cn_tra(ib_bdy) )                  
+          CASE('none')
+             IF(lwp) WRITE(numout,*) '      no open boundary condition'        
+             dta_bdy(ib_bdy)%ll_tem = .false.
+             dta_bdy(ib_bdy)%ll_sal = .false.
+          CASE('frs')
+             IF(lwp) WRITE(numout,*) '      Flow Relaxation Scheme'
+             dta_bdy(ib_bdy)%ll_tem = .true.
+             dta_bdy(ib_bdy)%ll_sal = .true.
+          CASE('specified')
+             IF(lwp) WRITE(numout,*) '      Specified value'
+             dta_bdy(ib_bdy)%ll_tem = .true.
+             dta_bdy(ib_bdy)%ll_sal = .true.
+          CASE('neumann')
+             IF(lwp) WRITE(numout,*) '      Neumann conditions'
+             dta_bdy(ib_bdy)%ll_tem = .false.
+             dta_bdy(ib_bdy)%ll_sal = .false.
+          CASE('runoff')
+             IF(lwp) WRITE(numout,*) '      Runoff conditions : Neumann for T and specified to 0.1 for salinity'
+             dta_bdy(ib_bdy)%ll_tem = .false.
+             dta_bdy(ib_bdy)%ll_sal = .false.
+          CASE('orlanski')
+             IF(lwp) WRITE(numout,*) '      Orlanski (fully oblique) radiation condition with adaptive nudging'
+             dta_bdy(ib_bdy)%ll_tem = .true.
+             dta_bdy(ib_bdy)%ll_sal = .true.
+          CASE('orlanski_npo')
+             IF(lwp) WRITE(numout,*) '      Orlanski (NPO) radiation condition with adaptive nudging'
+             dta_bdy(ib_bdy)%ll_tem = .true.
+             dta_bdy(ib_bdy)%ll_sal = .true.
+          CASE DEFAULT   ;   CALL ctl_stop( 'unrecognised value for cn_tra' )
+        END SELECT
+        IF( cn_tra(ib_bdy) /= 'none' ) THEN
+           SELECT CASE( nn_tra_dta(ib_bdy) )                   ! 
+              CASE( 0 )      ;   IF(lwp) WRITE(numout,*) '      initial state used for bdy data'        
+              CASE( 1 )      ;   IF(lwp) WRITE(numout,*) '      boundary data taken from file'
+              CASE DEFAULT   ;   CALL ctl_stop( 'nn_tra_dta must be 0 or 1' )
+           END SELECT
+        ENDIF
+
+        IF ( ln_tra_dmp(ib_bdy) ) THEN
+           IF ( cn_tra(ib_bdy) == 'none' ) THEN
+              IF(lwp) WRITE(numout,*) 'No open boundary condition for tracers: ln_tra_dmp is set to .false.'
+              ln_tra_dmp(ib_bdy)=.false.
+           ELSEIF ( cn_tra(ib_bdy) == 'frs' ) THEN
+              CALL ctl_stop( 'Use FRS OR relaxation' )
+           ELSE
+              IF(lwp) WRITE(numout,*) '      + T/S relaxation zone'
+              IF(lwp) WRITE(numout,*) '      Damping time scale: ',rn_time_dmp(ib_bdy),' days'
+              IF(lwp) WRITE(numout,*) '      Outflow damping time scale: ',rn_time_dmp_out(ib_bdy),' days'
+              IF((lwp).AND.rn_time_dmp(ib_bdy)<0) CALL ctl_stop( 'Time scale must be positive' )
+              dta_bdy(ib_bdy)%ll_tem = .true.
+              dta_bdy(ib_bdy)%ll_sal = .true.
+           ENDIF
+        ELSE
+           IF(lwp) WRITE(numout,*) '      NO T/S relaxation'
+        ENDIF
+        IF(lwp) WRITE(numout,*)
+
+#if defined key_si3
+         IF(lwp) WRITE(numout,*) 'Boundary conditions for sea ice:  '
+         SELECT CASE( cn_ice_lim(ib_bdy) )                  
+         CASE('none')
+             IF(lwp) WRITE(numout,*) '      no open boundary condition'        
+             dta_bdy(ib_bdy)%ll_a_i = .false.
+             dta_bdy(ib_bdy)%ll_h_i = .false.
+             dta_bdy(ib_bdy)%ll_h_s = .false.
+         CASE('frs')
+             IF(lwp) WRITE(numout,*) '      Flow Relaxation Scheme'
+             dta_bdy(ib_bdy)%ll_a_i = .true.
+             dta_bdy(ib_bdy)%ll_h_i = .true.
+             dta_bdy(ib_bdy)%ll_h_s = .true.
+         CASE DEFAULT   ;   CALL ctl_stop( 'unrecognised value for cn_ice_lim' )
+         END SELECT
+        IF( cn_ice_lim(ib_bdy) /= 'none' ) THEN 
+           SELECT CASE( nn_ice_lim_dta(ib_bdy) )                   ! 
+              CASE( 0 )      ;   IF(lwp) WRITE(numout,*) '      initial state used for bdy data'        
+              CASE( 1 )      ;   IF(lwp) WRITE(numout,*) '      boundary data taken from file'
+              CASE DEFAULT   ;   CALL ctl_stop( 'nn_ice_lim_dta must be 0 or 1' )
+           END SELECT
+        ENDIF
+        IF(lwp) WRITE(numout,*)
+        IF(lwp) WRITE(numout,*) '      tem of bdy sea-ice = ', rn_ice_tem(ib_bdy)         
+        IF(lwp) WRITE(numout,*) '      sal of bdy sea-ice = ', rn_ice_sal(ib_bdy)         
+        IF(lwp) WRITE(numout,*) '      age of bdy sea-ice = ', rn_ice_age(ib_bdy)         
+#endif
+
+        IF(lwp) WRITE(numout,*) '      Width of relaxation zone = ', nn_rimwidth(ib_bdy)
+        IF(lwp) WRITE(numout,*)
+         !
+      END DO
+
+     IF( nb_bdy > 0 ) THEN
+        IF( ln_vol ) THEN                     ! check volume conservation (nn_volctl value)
+          IF(lwp) WRITE(numout,*) 'Volume correction applied at open boundaries'
+          IF(lwp) WRITE(numout,*)
+          SELECT CASE ( nn_volctl )
+            CASE( 1 )      ;   IF(lwp) WRITE(numout,*) '      The total volume will be constant'
+            CASE( 0 )      ;   IF(lwp) WRITE(numout,*) '      The total volume will vary according to the surface E-P flux'
+            CASE DEFAULT   ;   CALL ctl_stop( 'nn_volctl must be 0 or 1' )
+          END SELECT
+          IF(lwp) WRITE(numout,*)
+        ELSE
+          IF(lwp) WRITE(numout,*) 'No volume correction applied at open boundaries'
+          IF(lwp) WRITE(numout,*)
+        ENDIF
+        IF( nb_jpk_bdy > 0 ) THEN
+           IF(lwp) WRITE(numout,*) '*** open boundary will be interpolate in the vertical onto the native grid ***'
+        ELSE
+           IF(lwp) WRITE(numout,*) '*** open boundary will be read straight onto the native grid without vertical interpolation ***'
+        ENDIF
+     ENDIF
+
+      ! -------------------------------------------------
+      ! Initialise indices arrays for open boundaries
+      ! -------------------------------------------------
+
+      ! Work out global dimensions of boundary data
+      ! ---------------------------------------------
+      REWIND( numnam_cfg )     
+
+      nblendta(:,:) = 0
+      nbdysege = 0
+      nbdysegw = 0
+      nbdysegn = 0
+      nbdysegs = 0
+      icount   = 0 ! count user defined segments
+      ! Dimensions below are used to allocate arrays to read external data
+      jpbdtas = 1 ! Maximum size of boundary data (structured case)
+      jpbdtau = 1 ! Maximum size of boundary data (unstructured case)
+
+      DO ib_bdy = 1, nb_bdy
+
+         IF( .NOT. ln_coords_file(ib_bdy) ) THEN ! Work out size of global arrays from namelist parameters
+ 
+            icount = icount + 1
+            ! No REWIND here because may need to read more than one nambdy_index namelist.
+            ! Read only namelist_cfg to avoid unseccessfull overwrite 
+            ! keep full control of the configuration namelist
+            READ  ( numnam_cfg, nambdy_index, IOSTAT = ios, ERR = 904 )
+904         IF( ios /= 0 )   CALL ctl_nam ( ios , 'nambdy_index in configuration namelist', lwp )
+            IF(lwm) WRITE ( numond, nambdy_index )
+
+            SELECT CASE ( TRIM(ctypebdy) )
+              CASE( 'N' )
+                 IF( nbdyind == -1 ) THEN  ! Automatic boundary definition: if nbdysegX = -1
+                    nbdyind  = jpjglo - 2  ! set boundary to whole side of model domain.
+                    nbdybeg  = 2
+                    nbdyend  = jpiglo - 1
+                 ENDIF
+                 nbdysegn = nbdysegn + 1
+                 npckgn(nbdysegn) = ib_bdy ! Save bdy package number
+                 jpjnob(nbdysegn) = nbdyind
+                 jpindt(nbdysegn) = nbdybeg
+                 jpinft(nbdysegn) = nbdyend
+                 !
+              CASE( 'S' )
+                 IF( nbdyind == -1 ) THEN  ! Automatic boundary definition: if nbdysegX = -1
+                    nbdyind  = 2           ! set boundary to whole side of model domain.
+                    nbdybeg  = 2
+                    nbdyend  = jpiglo - 1
+                 ENDIF
+                 nbdysegs = nbdysegs + 1
+                 npckgs(nbdysegs) = ib_bdy ! Save bdy package number
+                 jpjsob(nbdysegs) = nbdyind
+                 jpisdt(nbdysegs) = nbdybeg
+                 jpisft(nbdysegs) = nbdyend
+                 !
+              CASE( 'E' )
+                 IF( nbdyind == -1 ) THEN  ! Automatic boundary definition: if nbdysegX = -1
+                    nbdyind  = jpiglo - 2  ! set boundary to whole side of model domain.
+                    nbdybeg  = 2
+                    nbdyend  = jpjglo - 1
+                 ENDIF
+                 nbdysege = nbdysege + 1 
+                 npckge(nbdysege) = ib_bdy ! Save bdy package number
+                 jpieob(nbdysege) = nbdyind
+                 jpjedt(nbdysege) = nbdybeg
+                 jpjeft(nbdysege) = nbdyend
+                 !
+              CASE( 'W' )
+                 IF( nbdyind == -1 ) THEN  ! Automatic boundary definition: if nbdysegX = -1
+                    nbdyind  = 2           ! set boundary to whole side of model domain.
+                    nbdybeg  = 2
+                    nbdyend  = jpjglo - 1
+                 ENDIF
+                 nbdysegw = nbdysegw + 1
+                 npckgw(nbdysegw) = ib_bdy ! Save bdy package number
+                 jpiwob(nbdysegw) = nbdyind
+                 jpjwdt(nbdysegw) = nbdybeg
+                 jpjwft(nbdysegw) = nbdyend
+                 !
+              CASE DEFAULT   ;   CALL ctl_stop( 'ctypebdy must be N, S, E or W' )
+            END SELECT
+
+            ! For simplicity we assume that in case of straight bdy, arrays have the same length
+            ! (even if it is true that last tangential velocity points
+            ! are useless). This simplifies a little bit boundary data format (and agrees with format
+            ! used so far in obc package)
+
+            nblendta(1:jpbgrd,ib_bdy) =  (nbdyend - nbdybeg + 1) * nn_rimwidth(ib_bdy)
+            jpbdtas = MAX(jpbdtas, (nbdyend - nbdybeg + 1))
+            IF (lwp.and.(nn_rimwidth(ib_bdy)>nrimmax)) &
+            & CALL ctl_stop( 'rimwidth must be lower than nrimmax' )
+
+         ELSE            ! Read size of arrays in boundary coordinates file.
+            CALL iom_open( cn_coords_file(ib_bdy), inum )
+            DO igrd = 1, jpbgrd
+               id_dummy = iom_varid( inum, 'nbi'//cgrid(igrd), kdimsz=kdimsz )  
+               nblendta(igrd,ib_bdy) = MAXVAL(kdimsz)
+               jpbdtau = MAX(jpbdtau, MAXVAL(kdimsz))
+            END DO
+            CALL iom_close( inum )
+            !
+         ENDIF 
+         !
+      END DO ! ib_bdy
+
+      IF (nb_bdy>0) THEN
+         jpbdta = MAXVAL(nblendta(1:jpbgrd,1:nb_bdy))
+
+         ! Allocate arrays
+         !---------------
+         ALLOCATE( nbidta(jpbdta, jpbgrd, nb_bdy), nbjdta(jpbdta, jpbgrd, nb_bdy),    &
+            &      nbrdta(jpbdta, jpbgrd, nb_bdy) )
+
+         IF( nb_jpk_bdy>0 ) THEN
+            ALLOCATE( dta_global(jpbdtau, 1, nb_jpk_bdy) )
+            ALLOCATE( dta_global_z(jpbdtau, 1, nb_jpk_bdy) )
+            ALLOCATE( dta_global_dz(jpbdtau, 1, nb_jpk_bdy) )
+         ELSE
+            ALLOCATE( dta_global(jpbdtau, 1, jpk) )
+            ALLOCATE( dta_global_z(jpbdtau, 1, jpk) ) ! needed ?? TODO
+            ALLOCATE( dta_global_dz(jpbdtau, 1, jpk) )! needed ?? TODO
+         ENDIF
+
+         IF ( icount>0 ) THEN
+            IF( nb_jpk_bdy>0 ) THEN
+               ALLOCATE( dta_global2(jpbdtas, nrimmax, nb_jpk_bdy) )
+               ALLOCATE( dta_global2_z(jpbdtas, nrimmax, nb_jpk_bdy) )
+               ALLOCATE( dta_global2_dz(jpbdtas, nrimmax, nb_jpk_bdy) )
+            ELSE
+               ALLOCATE( dta_global2(jpbdtas, nrimmax, jpk) )
+               ALLOCATE( dta_global2_z(jpbdtas, nrimmax, jpk) ) ! needed ?? TODO
+               ALLOCATE( dta_global2_dz(jpbdtas, nrimmax, jpk) )! needed ?? TODO  
+            ENDIF
+         ENDIF
+         ! 
+      ENDIF
+
+      ! Now look for crossings in user (namelist) defined open boundary segments:
+      !--------------------------------------------------------------------------
+      IF( icount>0 )   CALL bdy_ctl_seg
+
+      ! Calculate global boundary index arrays or read in from file
+      !------------------------------------------------------------               
+      ! 1. Read global index arrays from boundary coordinates file.
+      DO ib_bdy = 1, nb_bdy
+         !
+         IF( ln_coords_file(ib_bdy) ) THEN
+            !
+            CALL iom_open( cn_coords_file(ib_bdy), inum )
+            DO igrd = 1, jpbgrd
+               CALL iom_get( inum, jpdom_unknown, 'nbi'//cgrid(igrd), dta_global(1:nblendta(igrd,ib_bdy),:,1) )
+               DO ii = 1,nblendta(igrd,ib_bdy)
+                  nbidta(ii,igrd,ib_bdy) = INT( dta_global(ii,1,1) )
+               END DO
+               CALL iom_get( inum, jpdom_unknown, 'nbj'//cgrid(igrd), dta_global(1:nblendta(igrd,ib_bdy),:,1) )
+               DO ii = 1,nblendta(igrd,ib_bdy)
+                  nbjdta(ii,igrd,ib_bdy) = INT( dta_global(ii,1,1) )
+               END DO
+               CALL iom_get( inum, jpdom_unknown, 'nbr'//cgrid(igrd), dta_global(1:nblendta(igrd,ib_bdy),:,1) )
+               DO ii = 1,nblendta(igrd,ib_bdy)
+                  nbrdta(ii,igrd,ib_bdy) = INT( dta_global(ii,1,1) )
+               END DO
+               !
+               ibr_max = MAXVAL( nbrdta(:,igrd,ib_bdy) )
+               IF(lwp) WRITE(numout,*)
+               IF(lwp) WRITE(numout,*) ' Maximum rimwidth in file is ', ibr_max
+               IF(lwp) WRITE(numout,*) ' nn_rimwidth from namelist is ', nn_rimwidth(ib_bdy)
+               IF (ibr_max < nn_rimwidth(ib_bdy))   &
+                     CALL ctl_stop( 'nn_rimwidth is larger than maximum rimwidth in file',cn_coords_file(ib_bdy) )
+            END DO
+            CALL iom_close( inum )
+            !
+         ENDIF 
+         !
+      END DO      
+    
+      ! 2. Now fill indices corresponding to straight open boundary arrays:
+      ! East
+      !-----
+      DO iseg = 1, nbdysege
+         ib_bdy = npckge(iseg)
+         !
+         ! ------------ T points -------------
+         igrd=1
+         icount=0
+         DO ir = 1, nn_rimwidth(ib_bdy)
+            DO ij = jpjedt(iseg), jpjeft(iseg)
+               icount = icount + 1
+               nbidta(icount, igrd, ib_bdy) = jpieob(iseg) + 2 - ir
+               nbjdta(icount, igrd, ib_bdy) = ij
+               nbrdta(icount, igrd, ib_bdy) = ir
+            ENDDO
+         ENDDO
+         !
+         ! ------------ U points -------------
+         igrd=2
+         icount=0
+         DO ir = 1, nn_rimwidth(ib_bdy)
+            DO ij = jpjedt(iseg), jpjeft(iseg)
+               icount = icount + 1
+               nbidta(icount, igrd, ib_bdy) = jpieob(iseg) + 1 - ir
+               nbjdta(icount, igrd, ib_bdy) = ij
+               nbrdta(icount, igrd, ib_bdy) = ir
+            ENDDO
+         ENDDO
+         !
+         ! ------------ V points -------------
+         igrd=3
+         icount=0
+         DO ir = 1, nn_rimwidth(ib_bdy)
+!            DO ij = jpjedt(iseg), jpjeft(iseg) - 1
+            DO ij = jpjedt(iseg), jpjeft(iseg)
+               icount = icount + 1
+               nbidta(icount, igrd, ib_bdy) = jpieob(iseg) + 2 - ir
+               nbjdta(icount, igrd, ib_bdy) = ij
+               nbrdta(icount, igrd, ib_bdy) = ir
+            ENDDO
+            nbidta(icount, igrd, ib_bdy) = -ib_bdy ! Discount this point
+            nbjdta(icount, igrd, ib_bdy) = -ib_bdy ! Discount this point
+         ENDDO
+      ENDDO
+      !
+      ! West
+      !-----
+      DO iseg = 1, nbdysegw
+         ib_bdy = npckgw(iseg)
+         !
+         ! ------------ T points -------------
+         igrd=1
+         icount=0
+         DO ir = 1, nn_rimwidth(ib_bdy)
+            DO ij = jpjwdt(iseg), jpjwft(iseg)
+               icount = icount + 1
+               nbidta(icount, igrd, ib_bdy) = jpiwob(iseg) + ir - 1
+               nbjdta(icount, igrd, ib_bdy) = ij
+               nbrdta(icount, igrd, ib_bdy) = ir
+            ENDDO
+         ENDDO
+         !
+         ! ------------ U points -------------
+         igrd=2
+         icount=0
+         DO ir = 1, nn_rimwidth(ib_bdy)
+            DO ij = jpjwdt(iseg), jpjwft(iseg)
+               icount = icount + 1
+               nbidta(icount, igrd, ib_bdy) = jpiwob(iseg) + ir - 1
+               nbjdta(icount, igrd, ib_bdy) = ij
+               nbrdta(icount, igrd, ib_bdy) = ir
+            ENDDO
+         ENDDO
+         !
+         ! ------------ V points -------------
+         igrd=3
+         icount=0
+         DO ir = 1, nn_rimwidth(ib_bdy)
+!            DO ij = jpjwdt(iseg), jpjwft(iseg) - 1
+            DO ij = jpjwdt(iseg), jpjwft(iseg)
+               icount = icount + 1
+               nbidta(icount, igrd, ib_bdy) = jpiwob(iseg) + ir - 1
+               nbjdta(icount, igrd, ib_bdy) = ij
+               nbrdta(icount, igrd, ib_bdy) = ir
+            ENDDO
+            nbidta(icount, igrd, ib_bdy) = -ib_bdy ! Discount this point
+            nbjdta(icount, igrd, ib_bdy) = -ib_bdy ! Discount this point
+         ENDDO
+      ENDDO
+      !
+      ! North
+      !-----
+      DO iseg = 1, nbdysegn
+         ib_bdy = npckgn(iseg)
+         !
+         ! ------------ T points -------------
+         igrd=1
+         icount=0
+         DO ir = 1, nn_rimwidth(ib_bdy)
+            DO ii = jpindt(iseg), jpinft(iseg)
+               icount = icount + 1
+               nbidta(icount, igrd, ib_bdy) = ii
+               nbjdta(icount, igrd, ib_bdy) = jpjnob(iseg) + 2 - ir 
+               nbrdta(icount, igrd, ib_bdy) = ir
+            ENDDO
+         ENDDO
+         !
+         ! ------------ U points -------------
+         igrd=2
+         icount=0
+         DO ir = 1, nn_rimwidth(ib_bdy)
+!            DO ii = jpindt(iseg), jpinft(iseg) - 1
+            DO ii = jpindt(iseg), jpinft(iseg)
+               icount = icount + 1
+               nbidta(icount, igrd, ib_bdy) = ii
+               nbjdta(icount, igrd, ib_bdy) = jpjnob(iseg) + 2 - ir
+               nbrdta(icount, igrd, ib_bdy) = ir
+            ENDDO
+            nbidta(icount, igrd, ib_bdy) = -ib_bdy ! Discount this point
+            nbjdta(icount, igrd, ib_bdy) = -ib_bdy ! Discount this point
+         ENDDO
+         !
+         ! ------------ V points -------------
+         igrd=3
+         icount=0
+         DO ir = 1, nn_rimwidth(ib_bdy)
+            DO ii = jpindt(iseg), jpinft(iseg)
+               icount = icount + 1
+               nbidta(icount, igrd, ib_bdy) = ii
+               nbjdta(icount, igrd, ib_bdy) = jpjnob(iseg) + 1 - ir
+               nbrdta(icount, igrd, ib_bdy) = ir
+            ENDDO
+         ENDDO
+      ENDDO
+      !
+      ! South
+      !-----
+      DO iseg = 1, nbdysegs
+         ib_bdy = npckgs(iseg)
+         !
+         ! ------------ T points -------------
+         igrd=1
+         icount=0
+         DO ir = 1, nn_rimwidth(ib_bdy)
+            DO ii = jpisdt(iseg), jpisft(iseg)
+               icount = icount + 1
+               nbidta(icount, igrd, ib_bdy) = ii
+               nbjdta(icount, igrd, ib_bdy) = jpjsob(iseg) + ir - 1
+               nbrdta(icount, igrd, ib_bdy) = ir
+            ENDDO
+         ENDDO
+         !
+         ! ------------ U points -------------
+         igrd=2
+         icount=0
+         DO ir = 1, nn_rimwidth(ib_bdy)
+!            DO ii = jpisdt(iseg), jpisft(iseg) - 1
+            DO ii = jpisdt(iseg), jpisft(iseg)
+               icount = icount + 1
+               nbidta(icount, igrd, ib_bdy) = ii
+               nbjdta(icount, igrd, ib_bdy) = jpjsob(iseg) + ir - 1
+               nbrdta(icount, igrd, ib_bdy) = ir
+            ENDDO
+            nbidta(icount, igrd, ib_bdy) = -ib_bdy ! Discount this point
+            nbjdta(icount, igrd, ib_bdy) = -ib_bdy ! Discount this point
+         ENDDO
+         !
+         ! ------------ V points -------------
+         igrd=3
+         icount=0
+         DO ir = 1, nn_rimwidth(ib_bdy)
+            DO ii = jpisdt(iseg), jpisft(iseg)
+               icount = icount + 1
+               nbidta(icount, igrd, ib_bdy) = ii
+               nbjdta(icount, igrd, ib_bdy) = jpjsob(iseg) + ir - 1
+               nbrdta(icount, igrd, ib_bdy) = ir
+            ENDDO
+         ENDDO
+      ENDDO
+
+      !  Deal with duplicated points
+      !-----------------------------
+      ! We assign negative indices to duplicated points (to remove them from bdy points to be updated)
+      ! if their distance to the bdy is greater than the other
+      ! If their distance are the same, just keep only one to avoid updating a point twice
+      DO igrd = 1, jpbgrd
+         DO ib_bdy1 = 1, nb_bdy
+            DO ib_bdy2 = 1, nb_bdy
+               IF (ib_bdy1/=ib_bdy2) THEN
+                  DO ib1 = 1, nblendta(igrd,ib_bdy1)
+                     DO ib2 = 1, nblendta(igrd,ib_bdy2)
+                        IF ((nbidta(ib1, igrd, ib_bdy1)==nbidta(ib2, igrd, ib_bdy2)).AND. &
+                        &   (nbjdta(ib1, igrd, ib_bdy1)==nbjdta(ib2, igrd, ib_bdy2))) THEN
+!                           IF ((lwp).AND.(igrd==1)) WRITE(numout,*) ' found coincident point ji, jj:', & 
+!                                                       &              nbidta(ib1, igrd, ib_bdy1),      & 
+!                                                       &              nbjdta(ib2, igrd, ib_bdy2)
+                           ! keep only points with the lowest distance to boundary:
+                           IF (nbrdta(ib1, igrd, ib_bdy1)<nbrdta(ib2, igrd, ib_bdy2)) THEN
+                             nbidta(ib2, igrd, ib_bdy2) =-ib_bdy2
+                             nbjdta(ib2, igrd, ib_bdy2) =-ib_bdy2
+                           ELSEIF (nbrdta(ib1, igrd, ib_bdy1)>nbrdta(ib2, igrd, ib_bdy2)) THEN
+                             nbidta(ib1, igrd, ib_bdy1) =-ib_bdy1
+                             nbjdta(ib1, igrd, ib_bdy1) =-ib_bdy1
+                           ! Arbitrary choice if distances are the same:
+                           ELSE
+                             nbidta(ib1, igrd, ib_bdy1) =-ib_bdy1
+                             nbjdta(ib1, igrd, ib_bdy1) =-ib_bdy1
+                           ENDIF
+                        END IF
+                     END DO
+                  END DO
+               ENDIF
+            END DO
+         END DO
+      END DO
+
+      ! Work out dimensions of boundary data on each processor
+      ! ------------------------------------------------------
+
+      ! Rather assume that boundary data indices are given on global domain
+      ! TO BE DISCUSSED ?
+!      iw = mig(1) + 1            ! if monotasking and no zoom, iw=2
+!      ie = mig(1) + nlci-1 - 1   ! if monotasking and no zoom, ie=jpim1
+!      is = mjg(1) + 1            ! if monotasking and no zoom, is=2
+!      in = mjg(1) + nlcj-1 - 1   ! if monotasking and no zoom, in=jpjm1      
+      iwe = mig(1) - 1 + 2         ! if monotasking and no zoom, iw=2
+      ies = mig(1) + nlci-1 - 1  ! if monotasking and no zoom, ie=jpim1
+      iso = mjg(1) - 1 + 2         ! if monotasking and no zoom, is=2
+      ino = mjg(1) + nlcj-1 - 1  ! if monotasking and no zoom, in=jpjm1
+
+      ALLOCATE( nbondi_bdy(nb_bdy))
+      ALLOCATE( nbondj_bdy(nb_bdy))
+      nbondi_bdy(:)=2
+      nbondj_bdy(:)=2
+      ALLOCATE( nbondi_bdy_b(nb_bdy))
+      ALLOCATE( nbondj_bdy_b(nb_bdy))
+      nbondi_bdy_b(:)=2
+      nbondj_bdy_b(:)=2
+
+      ! Work out dimensions of boundary data on each neighbour process
+      IF(nbondi == 0) THEN
+         iw_b(1) = 1 + nimppt(nowe+1)
+         ie_b(1) = 1 + nimppt(nowe+1)+nlcit(nowe+1)-3
+         is_b(1) = 1 + njmppt(nowe+1)
+         in_b(1) = 1 + njmppt(nowe+1)+nlcjt(nowe+1)-3
+
+         iw_b(2) = 1 + nimppt(noea+1)
+         ie_b(2) = 1 + nimppt(noea+1)+nlcit(noea+1)-3
+         is_b(2) = 1 + njmppt(noea+1)
+         in_b(2) = 1 + njmppt(noea+1)+nlcjt(noea+1)-3
+      ELSEIF(nbondi == 1) THEN
+         iw_b(1) = 1 + nimppt(nowe+1)
+         ie_b(1) = 1 + nimppt(nowe+1)+nlcit(nowe+1)-3
+         is_b(1) = 1 + njmppt(nowe+1)
+         in_b(1) = 1 + njmppt(nowe+1)+nlcjt(nowe+1)-3
+      ELSEIF(nbondi == -1) THEN
+         iw_b(2) = 1 + nimppt(noea+1)
+         ie_b(2) = 1 + nimppt(noea+1)+nlcit(noea+1)-3
+         is_b(2) = 1 + njmppt(noea+1)
+         in_b(2) = 1 + njmppt(noea+1)+nlcjt(noea+1)-3
+      ENDIF
+
+      IF(nbondj == 0) THEN
+         iw_b(3) = 1 + nimppt(noso+1)
+         ie_b(3) = 1 + nimppt(noso+1)+nlcit(noso+1)-3
+         is_b(3) = 1 + njmppt(noso+1)
+         in_b(3) = 1 + njmppt(noso+1)+nlcjt(noso+1)-3
+
+         iw_b(4) = 1 + nimppt(nono+1)
+         ie_b(4) = 1 + nimppt(nono+1)+nlcit(nono+1)-3
+         is_b(4) = 1 + njmppt(nono+1)
+         in_b(4) = 1 + njmppt(nono+1)+nlcjt(nono+1)-3
+      ELSEIF(nbondj == 1) THEN
+         iw_b(3) = 1 + nimppt(noso+1)
+         ie_b(3) = 1 + nimppt(noso+1)+nlcit(noso+1)-3
+         is_b(3) = 1 + njmppt(noso+1)
+         in_b(3) = 1 + njmppt(noso+1)+nlcjt(noso+1)-3
+      ELSEIF(nbondj == -1) THEN
+         iw_b(4) = 1 + nimppt(nono+1)
+         ie_b(4) = 1 + nimppt(nono+1)+nlcit(nono+1)-3
+         is_b(4) = 1 + njmppt(nono+1)
+         in_b(4) = 1 + njmppt(nono+1)+nlcjt(nono+1)-3
+      ENDIF
+
+      DO ib_bdy = 1, nb_bdy
+         DO igrd = 1, jpbgrd
+            icount  = 0
+            icountr = 0
+            idx_bdy(ib_bdy)%nblen(igrd)    = 0
+            idx_bdy(ib_bdy)%nblenrim(igrd) = 0
+            DO ib = 1, nblendta(igrd,ib_bdy)
+               ! check that data is in correct order in file
+               ibm1 = MAX(1,ib-1)
+               IF(lwp) THEN         ! Since all procs read global data only need to do this check on one proc...
+                  IF( nbrdta(ib,igrd,ib_bdy) < nbrdta(ibm1,igrd,ib_bdy) ) THEN
+                     CALL ctl_stop('bdy_segs : ERROR : boundary data in file must be defined ', &
+                          &        ' in order of distance from edge nbr A utility for re-ordering ', &
+                          &        ' boundary coordinates and data files exists in the TOOLS/OBC directory')
+                  ENDIF    
+               ENDIF
+               ! check if point is in local domain
+               IF(  nbidta(ib,igrd,ib_bdy) >= iwe .AND. nbidta(ib,igrd,ib_bdy) <= ies .AND.   &
+                  & nbjdta(ib,igrd,ib_bdy) >= iso .AND. nbjdta(ib,igrd,ib_bdy) <= ino      ) THEN
+                  !
+                  icount = icount  + 1
+                  !
+                  IF( nbrdta(ib,igrd,ib_bdy) == 1 )   icountr = icountr+1
+               ENDIF
+            END DO
+            idx_bdy(ib_bdy)%nblenrim(igrd) = icountr !: length of rim boundary data on each proc
+            idx_bdy(ib_bdy)%nblen   (igrd) = icount  !: length of boundary data on each proc        
+         END DO  ! igrd
+
+         ! Allocate index arrays for this boundary set
+         !--------------------------------------------
+         ilen1 = MAXVAL( idx_bdy(ib_bdy)%nblen(:) )
+         ALLOCATE( idx_bdy(ib_bdy)%nbi   (ilen1,jpbgrd) ,   &
+            &      idx_bdy(ib_bdy)%nbj   (ilen1,jpbgrd) ,   &
+            &      idx_bdy(ib_bdy)%nbr   (ilen1,jpbgrd) ,   &
+            &      idx_bdy(ib_bdy)%nbd   (ilen1,jpbgrd) ,   &
+            &      idx_bdy(ib_bdy)%nbdout(ilen1,jpbgrd) ,   &
+            &      idx_bdy(ib_bdy)%nbmap (ilen1,jpbgrd) ,   &
+            &      idx_bdy(ib_bdy)%nbw   (ilen1,jpbgrd) ,   &
+            &      idx_bdy(ib_bdy)%flagu (ilen1,jpbgrd) ,   &
+            &      idx_bdy(ib_bdy)%flagv (ilen1,jpbgrd) )
+
+         ! Dispatch mapping indices and discrete distances on each processor
+         ! -----------------------------------------------------------------
+
+         com_east  = 0
+         com_west  = 0
+         com_south = 0
+         com_north = 0
+
+         com_east_b  = 0
+         com_west_b  = 0
+         com_south_b = 0
+         com_north_b = 0
+
+         DO igrd = 1, jpbgrd
+            icount  = 0
+            ! Loop on rimwidth to ensure outermost points come first in the local arrays.
+            DO ir=1, nn_rimwidth(ib_bdy)
+               DO ib = 1, nblendta(igrd,ib_bdy)
+                  ! check if point is in local domain and equals ir
+                  IF(  nbidta(ib,igrd,ib_bdy) >= iwe .AND. nbidta(ib,igrd,ib_bdy) <= ies .AND.   &
+                     & nbjdta(ib,igrd,ib_bdy) >= iso .AND. nbjdta(ib,igrd,ib_bdy) <= ino .AND.   &
+                     & nbrdta(ib,igrd,ib_bdy) == ir  ) THEN
+                     !
+                     icount = icount  + 1
+
+                     ! Rather assume that boundary data indices are given on global domain
+                     ! TO BE DISCUSSED ?
+!                     idx_bdy(ib_bdy)%nbi(icount,igrd)   = nbidta(ib,igrd,ib_bdy)- mig(1)+1
+!                     idx_bdy(ib_bdy)%nbj(icount,igrd)   = nbjdta(ib,igrd,ib_bdy)- mjg(1)+1
+                     idx_bdy(ib_bdy)%nbi(icount,igrd)   = nbidta(ib,igrd,ib_bdy)- mig(1)+1
+                     idx_bdy(ib_bdy)%nbj(icount,igrd)   = nbjdta(ib,igrd,ib_bdy)- mjg(1)+1
+                     ! check if point has to be sent
+                     ii = idx_bdy(ib_bdy)%nbi(icount,igrd)
+                     ij = idx_bdy(ib_bdy)%nbj(icount,igrd)
+                     if((com_east .ne. 1) .and. (ii == (nlci-1)) .and. (nbondi .le. 0)) then
+                        com_east = 1
+                     elseif((com_west .ne. 1) .and. (ii == 2) .and. (nbondi .ge. 0) .and. (nbondi .ne. 2)) then
+                        com_west = 1
+                     endif 
+                     if((com_south .ne. 1) .and. (ij == 2) .and. (nbondj .ge. 0) .and. (nbondj .ne. 2)) then
+                        com_south = 1
+                     elseif((com_north .ne. 1) .and. (ij == (nlcj-1)) .and. (nbondj .le. 0)) then
+                        com_north = 1
+                     endif 
+                     idx_bdy(ib_bdy)%nbr(icount,igrd)   = nbrdta(ib,igrd,ib_bdy)
+                     idx_bdy(ib_bdy)%nbmap(icount,igrd) = ib
+                  ENDIF
+                  ! check if point has to be received from a neighbour
+                  IF(nbondi == 0) THEN
+                     IF( nbidta(ib,igrd,ib_bdy) >= iw_b(1) .AND. nbidta(ib,igrd,ib_bdy) <= ie_b(1) .AND.   &
+                       & nbjdta(ib,igrd,ib_bdy) >= is_b(1) .AND. nbjdta(ib,igrd,ib_bdy) <= in_b(1) .AND.   &
+                       & nbrdta(ib,igrd,ib_bdy) == ir  ) THEN
+                       ii = nbidta(ib,igrd,ib_bdy)- iw_b(1)+2
+                       if((com_west_b .ne. 1) .and. (ii == (nlcit(nowe+1)-1))) then
+                          ij = nbjdta(ib,igrd,ib_bdy) - is_b(1)+2
+                          if((ij == 2) .and. (nbondj == 0 .or. nbondj == 1)) then
+                            com_south = 1
+                          elseif((ij == nlcjt(nowe+1)-1) .and. (nbondj == 0 .or. nbondj == -1)) then
+                            com_north = 1
+                          endif
+                          com_west_b = 1
+                       endif 
+                     ENDIF
+                     IF( nbidta(ib,igrd,ib_bdy) >= iw_b(2) .AND. nbidta(ib,igrd,ib_bdy) <= ie_b(2) .AND.   &
+                       & nbjdta(ib,igrd,ib_bdy) >= is_b(2) .AND. nbjdta(ib,igrd,ib_bdy) <= in_b(2) .AND.   &
+                       & nbrdta(ib,igrd,ib_bdy) == ir  ) THEN
+                       ii = nbidta(ib,igrd,ib_bdy)- iw_b(2)+2
+                       if((com_east_b .ne. 1) .and. (ii == 2)) then
+                          ij = nbjdta(ib,igrd,ib_bdy) - is_b(2)+2
+                          if((ij == 2) .and. (nbondj == 0 .or. nbondj == 1)) then
+                            com_south = 1
+                          elseif((ij == nlcjt(noea+1)-1) .and. (nbondj == 0 .or. nbondj == -1)) then
+                            com_north = 1
+                          endif
+                          com_east_b = 1
+                       endif 
+                     ENDIF
+                  ELSEIF(nbondi == 1) THEN
+                     IF( nbidta(ib,igrd,ib_bdy) >= iw_b(1) .AND. nbidta(ib,igrd,ib_bdy) <= ie_b(1) .AND.   &
+                       & nbjdta(ib,igrd,ib_bdy) >= is_b(1) .AND. nbjdta(ib,igrd,ib_bdy) <= in_b(1) .AND.   &
+                       & nbrdta(ib,igrd,ib_bdy) == ir  ) THEN
+                       ii = nbidta(ib,igrd,ib_bdy)- iw_b(1)+2
+                       if((com_west_b .ne. 1) .and. (ii == (nlcit(nowe+1)-1))) then
+                          ij = nbjdta(ib,igrd,ib_bdy) - is_b(1)+2
+                          if((ij == 2) .and. (nbondj == 0 .or. nbondj == 1)) then
+                            com_south = 1
+                          elseif((ij == nlcjt(nowe+1)-1) .and. (nbondj == 0 .or. nbondj == -1)) then
+                            com_north = 1
+                          endif
+                          com_west_b = 1
+                       endif 
+                     ENDIF
+                  ELSEIF(nbondi == -1) THEN
+                     IF( nbidta(ib,igrd,ib_bdy) >= iw_b(2) .AND. nbidta(ib,igrd,ib_bdy) <= ie_b(2) .AND.   &
+                       & nbjdta(ib,igrd,ib_bdy) >= is_b(2) .AND. nbjdta(ib,igrd,ib_bdy) <= in_b(2) .AND.   &
+                       & nbrdta(ib,igrd,ib_bdy) == ir  ) THEN
+                       ii = nbidta(ib,igrd,ib_bdy)- iw_b(2)+2
+                       if((com_east_b .ne. 1) .and. (ii == 2)) then
+                          ij = nbjdta(ib,igrd,ib_bdy) - is_b(2)+2
+                          if((ij == 2) .and. (nbondj == 0 .or. nbondj == 1)) then
+                            com_south = 1
+                          elseif((ij == nlcjt(noea+1)-1) .and. (nbondj == 0 .or. nbondj == -1)) then
+                            com_north = 1
+                          endif
+                          com_east_b = 1
+                       endif 
+                     ENDIF
+                  ENDIF
+                  IF(nbondj == 0) THEN
+                     IF(com_north_b .ne. 1 .AND. (nbidta(ib,igrd,ib_bdy) == iw_b(4)-1  &
+                       & .OR. nbidta(ib,igrd,ib_bdy) == ie_b(4)+1) .AND. &
+                       & nbjdta(ib,igrd,ib_bdy) == is_b(4) .AND. nbrdta(ib,igrd,ib_bdy) == ir) THEN
+                       com_north_b = 1 
+                     ENDIF
+                     IF(com_south_b .ne. 1 .AND. (nbidta(ib,igrd,ib_bdy) == iw_b(3)-1  &
+                       &.OR. nbidta(ib,igrd,ib_bdy) == ie_b(3)+1) .AND. &
+                       & nbjdta(ib,igrd,ib_bdy) == in_b(3) .AND. nbrdta(ib,igrd,ib_bdy) == ir) THEN
+                       com_south_b = 1 
+                     ENDIF
+                     IF( nbidta(ib,igrd,ib_bdy) >= iw_b(3) .AND. nbidta(ib,igrd,ib_bdy) <= ie_b(3) .AND.   &
+                       & nbjdta(ib,igrd,ib_bdy) >= is_b(3) .AND. nbjdta(ib,igrd,ib_bdy) <= in_b(3) .AND.   &
+                       & nbrdta(ib,igrd,ib_bdy) == ir  ) THEN
+                       ij = nbjdta(ib,igrd,ib_bdy)- is_b(3)+2
+                       if((com_south_b .ne. 1) .and. (ij == (nlcjt(noso+1)-1))) then
+                          com_south_b = 1
+                       endif 
+                     ENDIF
+                     IF( nbidta(ib,igrd,ib_bdy) >= iw_b(4) .AND. nbidta(ib,igrd,ib_bdy) <= ie_b(4) .AND.   &
+                       & nbjdta(ib,igrd,ib_bdy) >= is_b(4) .AND. nbjdta(ib,igrd,ib_bdy) <= in_b(4) .AND.   &
+                       & nbrdta(ib,igrd,ib_bdy) == ir  ) THEN
+                       ij = nbjdta(ib,igrd,ib_bdy)- is_b(4)+2
+                       if((com_north_b .ne. 1) .and. (ij == 2)) then
+                          com_north_b = 1
+                       endif 
+                     ENDIF
+                  ELSEIF(nbondj == 1) THEN
+                     IF( com_south_b .ne. 1 .AND. (nbidta(ib,igrd,ib_bdy) == iw_b(3)-1 .OR. &
+                       & nbidta(ib,igrd,ib_bdy) == ie_b(3)+1) .AND. &
+                       & nbjdta(ib,igrd,ib_bdy) == in_b(3) .AND. nbrdta(ib,igrd,ib_bdy) == ir) THEN
+                       com_south_b = 1 
+                     ENDIF
+                     IF( nbidta(ib,igrd,ib_bdy) >= iw_b(3) .AND. nbidta(ib,igrd,ib_bdy) <= ie_b(3) .AND.   &
+                       & nbjdta(ib,igrd,ib_bdy) >= is_b(3) .AND. nbjdta(ib,igrd,ib_bdy) <= in_b(3) .AND.   &
+                       & nbrdta(ib,igrd,ib_bdy) == ir  ) THEN
+                       ij = nbjdta(ib,igrd,ib_bdy)- is_b(3)+2
+                       if((com_south_b .ne. 1) .and. (ij == (nlcjt(noso+1)-1))) then
+                          com_south_b = 1
+                       endif 
+                     ENDIF
+                  ELSEIF(nbondj == -1) THEN
+                     IF(com_north_b .ne. 1 .AND. (nbidta(ib,igrd,ib_bdy) == iw_b(4)-1  &
+                       & .OR. nbidta(ib,igrd,ib_bdy) == ie_b(4)+1) .AND. &
+                       & nbjdta(ib,igrd,ib_bdy) == is_b(4) .AND. nbrdta(ib,igrd,ib_bdy) == ir) THEN
+                       com_north_b = 1 
+                     ENDIF
+                     IF( nbidta(ib,igrd,ib_bdy) >= iw_b(4) .AND. nbidta(ib,igrd,ib_bdy) <= ie_b(4) .AND.   &
+                       & nbjdta(ib,igrd,ib_bdy) >= is_b(4) .AND. nbjdta(ib,igrd,ib_bdy) <= in_b(4) .AND.   &
+                       & nbrdta(ib,igrd,ib_bdy) == ir  ) THEN
+                       ij = nbjdta(ib,igrd,ib_bdy)- is_b(4)+2
+                       if((com_north_b .ne. 1) .and. (ij == 2)) then
+                          com_north_b = 1
+                       endif 
+                     ENDIF
+                  ENDIF
+               ENDDO
+            ENDDO
+         ENDDO 
+
+         ! definition of the i- and j- direction local boundaries arrays used for sending the boundaries
+         IF(     (com_east  == 1) .and. (com_west  == 1) ) THEN   ;   nbondi_bdy(ib_bdy) =  0
+         ELSEIF( (com_east  == 1) .and. (com_west  == 0) ) THEN   ;   nbondi_bdy(ib_bdy) = -1
+         ELSEIF( (com_east  == 0) .and. (com_west  == 1) ) THEN   ;   nbondi_bdy(ib_bdy) =  1
+         ENDIF
+         IF(     (com_north == 1) .and. (com_south == 1) ) THEN   ;   nbondj_bdy(ib_bdy) =  0
+         ELSEIF( (com_north == 1) .and. (com_south == 0) ) THEN   ;   nbondj_bdy(ib_bdy) = -1
+         ELSEIF( (com_north == 0) .and. (com_south == 1) ) THEN   ;   nbondj_bdy(ib_bdy) =  1
+         ENDIF
+
+         ! definition of the i- and j- direction local boundaries arrays used for receiving the boundaries
+         IF(     (com_east_b  == 1) .and. (com_west_b  == 1) ) THEN   ;   nbondi_bdy_b(ib_bdy) =  0
+         ELSEIF( (com_east_b  == 1) .and. (com_west_b  == 0) ) THEN   ;   nbondi_bdy_b(ib_bdy) = -1
+         ELSEIF( (com_east_b  == 0) .and. (com_west_b  == 1) ) THEN   ;   nbondi_bdy_b(ib_bdy) =  1
+         ENDIF
+         IF(     (com_north_b == 1) .and. (com_south_b == 1) ) THEN   ;   nbondj_bdy_b(ib_bdy) =  0
+         ELSEIF( (com_north_b == 1) .and. (com_south_b == 0) ) THEN   ;   nbondj_bdy_b(ib_bdy) = -1
+         ELSEIF( (com_north_b == 0) .and. (com_south_b == 1) ) THEN   ;   nbondj_bdy_b(ib_bdy) =  1
+         ENDIF
+
+         ! Compute rim weights for FRS scheme
+         ! ----------------------------------
+         DO igrd = 1, jpbgrd
+            DO ib = 1, idx_bdy(ib_bdy)%nblen(igrd)
+               nbr => idx_bdy(ib_bdy)%nbr(ib,igrd)
+               idx_bdy(ib_bdy)%nbw(ib,igrd) = 1.- TANH( REAL( nbr - 1 ) *0.5 )      ! tanh formulation
+!               idx_bdy(ib_bdy)%nbw(ib,igrd) = (REAL(nn_rimwidth(ib_bdy)+1-nbr)/REAL(nn_rimwidth(ib_bdy)))**2.  ! quadratic
+!               idx_bdy(ib_bdy)%nbw(ib,igrd) =  REAL(nn_rimwidth(ib_bdy)+1-nbr)/REAL(nn_rimwidth(ib_bdy))       ! linear
+            END DO
+         END DO 
+
+         ! Compute damping coefficients
+         ! ----------------------------
+         DO igrd = 1, jpbgrd
+            DO ib = 1, idx_bdy(ib_bdy)%nblen(igrd)
+               nbr => idx_bdy(ib_bdy)%nbr(ib,igrd)
+               idx_bdy(ib_bdy)%nbd(ib,igrd) = 1. / ( rn_time_dmp(ib_bdy) * rday ) & 
+               & *(REAL(nn_rimwidth(ib_bdy)+1-nbr)/REAL(nn_rimwidth(ib_bdy)))**2.   ! quadratic
+               idx_bdy(ib_bdy)%nbdout(ib,igrd) = 1. / ( rn_time_dmp_out(ib_bdy) * rday ) & 
+               & *(REAL(nn_rimwidth(ib_bdy)+1-nbr)/REAL(nn_rimwidth(ib_bdy)))**2.   ! quadratic
+            END DO
+         END DO 
+
+      END DO
+
+      ! ------------------------------------------------------
+      ! Initialise masks and find normal/tangential directions
+      ! ------------------------------------------------------
+
+      ! Read global 2D mask at T-points: bdytmask
+      ! -----------------------------------------
+      ! bdytmask = 1  on the computational domain AND on open boundaries
+      !          = 0  elsewhere   
+ 
+      bdytmask(:,:) = ssmask(:,:)
+
+      IF( ln_mask_file ) THEN
+         CALL iom_open( cn_mask_file, inum )
+         CALL iom_get ( inum, jpdom_data, 'bdy_msk', bdytmask(:,:) )
+         CALL iom_close( inum )
+
+         ! Derive mask on U and V grid from mask on T grid
+         bdyumask(:,:) = 0._wp
+         bdyvmask(:,:) = 0._wp
+         DO ij=1, jpjm1
+            DO ii=1, jpim1
+               bdyumask(ii,ij) = bdytmask(ii,ij) * bdytmask(ii+1, ij )
+               bdyvmask(ii,ij) = bdytmask(ii,ij) * bdytmask(ii  ,ij+1)  
+            END DO
+         END DO
+         CALL lbc_lnk_multi( bdyumask, 'U', 1., bdyvmask, 'V', 1. )      ! Lateral boundary cond.
+      ENDIF ! ln_mask_file=.TRUE.
+      
+      IF( .NOT.ln_mask_file ) THEN
+         ! If .not. ln_mask_file then we need to derive mask on U and V grid from mask on T grid here.
+         bdyumask(:,:) = 0._wp
+         bdyvmask(:,:) = 0._wp
+         DO ij = 1, jpjm1
+            DO ii = 1, jpim1
+               bdyumask(ii,ij) = bdytmask(ii,ij) * bdytmask(ii+1, ij )
+               bdyvmask(ii,ij) = bdytmask(ii,ij) * bdytmask(ii  ,ij+1)  
+            END DO
+         END DO
+         CALL lbc_lnk_multi( bdyumask, 'U', 1. , bdyvmask, 'V', 1. )   ! Lateral boundary cond. 
+      ENDIF
+
+      ! bdy masks are now set to zero on boundary points:
+      !
+      igrd = 1
+      DO ib_bdy = 1, nb_bdy
+        DO ib = 1, idx_bdy(ib_bdy)%nblenrim(igrd)      
+          bdytmask(idx_bdy(ib_bdy)%nbi(ib,igrd), idx_bdy(ib_bdy)%nbj(ib,igrd)) = 0._wp
+        END DO
+      END DO
+      !
+      igrd = 2
+      DO ib_bdy = 1, nb_bdy
+        DO ib = 1, idx_bdy(ib_bdy)%nblenrim(igrd)
+          bdyumask(idx_bdy(ib_bdy)%nbi(ib,igrd), idx_bdy(ib_bdy)%nbj(ib,igrd)) = 0._wp
+        END DO
+      END DO
+      !
+      igrd = 3
+      DO ib_bdy = 1, nb_bdy
+        DO ib = 1, idx_bdy(ib_bdy)%nblenrim(igrd)
+          bdyvmask(idx_bdy(ib_bdy)%nbi(ib,igrd), idx_bdy(ib_bdy)%nbj(ib,igrd)) = 0._wp
+        END DO
+      END DO
+
+      ! For the flagu/flagv calculation below we require a version of fmask without
+      ! the land boundary condition (shlat) included:
+      DO ij = 2, jpjm1
+         DO ii = 2, jpim1
+            zfmask(ii,ij) = tmask(ii,ij  ,1) * tmask(ii+1,ij  ,1)   &
+           &              * tmask(ii,ij+1,1) * tmask(ii+1,ij+1,1)
+         END DO      
+      END DO
+
+      ! Lateral boundary conditions
+      CALL lbc_lnk( zfmask, 'F', 1. ) 
+      CALL lbc_lnk_multi( bdyumask, 'U', 1. , bdyvmask, 'V', 1., bdytmask, 'T', 1. )
+      DO ib_bdy = 1, nb_bdy       ! Indices and directions of rim velocity components
+
+         idx_bdy(ib_bdy)%flagu(:,:) = 0._wp
+         idx_bdy(ib_bdy)%flagv(:,:) = 0._wp
+         icount = 0 
+
+         ! Calculate relationship of U direction to the local orientation of the boundary
+         ! flagu = -1 : u component is normal to the dynamical boundary and its direction is outward
+         ! flagu =  0 : u is tangential
+         ! flagu =  1 : u is normal to the boundary and is direction is inward
+  
+         DO igrd = 1, jpbgrd 
+            SELECT CASE( igrd )
+               CASE( 1 )   ;   pmask => umask   (:,:,1)   ;   i_offset = 0
+               CASE( 2 )   ;   pmask => bdytmask(:,:)     ;   i_offset = 1
+               CASE( 3 )   ;   pmask => zfmask  (:,:)     ;   i_offset = 0
+            END SELECT 
+            icount = 0
+            DO ib = 1, idx_bdy(ib_bdy)%nblenrim(igrd)  
+               nbi => idx_bdy(ib_bdy)%nbi(ib,igrd)
+               nbj => idx_bdy(ib_bdy)%nbj(ib,igrd)
+               zefl = pmask(nbi+i_offset-1,nbj)
+               zwfl = pmask(nbi+i_offset,nbj)
+               ! This error check only works if you are using the bdyXmask arrays
+               IF( i_offset == 1 .and. zefl + zwfl == 2 ) THEN
+                  icount = icount + 1
+                  IF(lwp) WRITE(numout,*) 'Problem with igrd = ',igrd,' at (global) nbi, nbj : ',mig(nbi),mjg(nbj)
+               ELSE
+                  idx_bdy(ib_bdy)%flagu(ib,igrd) = -zefl + zwfl
+               ENDIF
+            END DO
+            IF( icount /= 0 ) THEN
+               IF(lwp) WRITE(numout,*)
+               IF(lwp) WRITE(numout,*) ' E R R O R : Some ',cgrid(igrd),' grid points,',   &
+                  ' are not boundary points (flagu calculation). Check nbi, nbj, indices for boundary set ',ib_bdy
+               IF(lwp) WRITE(numout,*) ' ========== '
+               IF(lwp) WRITE(numout,*)
+               nstop = nstop + 1
+            ENDIF 
+         END DO
+
+         ! Calculate relationship of V direction to the local orientation of the boundary
+         ! flagv = -1 : v component is normal to the dynamical boundary but its direction is outward
+         ! flagv =  0 : v is tangential
+         ! flagv =  1 : v is normal to the boundary and is direction is inward
+
+         DO igrd = 1, jpbgrd 
+            SELECT CASE( igrd )
+               CASE( 1 )   ;   pmask => vmask (:,:,1)   ;   j_offset = 0
+               CASE( 2 )   ;   pmask => zfmask(:,:)     ;   j_offset = 0
+               CASE( 3 )   ;   pmask => bdytmask        ;   j_offset = 1
+            END SELECT 
+            icount = 0
+            DO ib = 1, idx_bdy(ib_bdy)%nblenrim(igrd)  
+               nbi => idx_bdy(ib_bdy)%nbi(ib,igrd)
+               nbj => idx_bdy(ib_bdy)%nbj(ib,igrd)
+               znfl = pmask(nbi,nbj+j_offset-1)
+               zsfl = pmask(nbi,nbj+j_offset  )
+               ! This error check only works if you are using the bdyXmask arrays
+               IF( j_offset == 1 .and. znfl + zsfl == 2 ) THEN
+                  IF(lwp) WRITE(numout,*) 'Problem with igrd = ',igrd,' at (global) nbi, nbj : ',mig(nbi),mjg(nbj)
+                  icount = icount + 1
+               ELSE
+                  idx_bdy(ib_bdy)%flagv(ib,igrd) = -znfl + zsfl
+               END IF
+            END DO
+            IF( icount /= 0 ) THEN
+               IF(lwp) WRITE(numout,*)
+               IF(lwp) WRITE(numout,*) ' E R R O R : Some ',cgrid(igrd),' grid points,',   &
+                  ' are not boundary points (flagv calculation). Check nbi, nbj, indices for boundary set ',ib_bdy
+               IF(lwp) WRITE(numout,*) ' ========== '
+               IF(lwp) WRITE(numout,*)
+               nstop = nstop + 1
+            ENDIF 
+         END DO
+         !
+      END DO
+
+      ! Compute total lateral surface for volume correction:
+      ! ----------------------------------------------------
+      ! JC: this must be done at each time step with non-linear free surface
+      bdysurftot = 0._wp 
+      IF( ln_vol ) THEN  
+         igrd = 2      ! Lateral surface at U-points
+         DO ib_bdy = 1, nb_bdy
+            DO ib = 1, idx_bdy(ib_bdy)%nblenrim(igrd)
+               nbi => idx_bdy(ib_bdy)%nbi(ib,igrd)
+               nbj => idx_bdy(ib_bdy)%nbj(ib,igrd)
+               flagu => idx_bdy(ib_bdy)%flagu(ib,igrd)
+               bdysurftot = bdysurftot + hu_n   (nbi  , nbj)                           &
+                  &                    * e2u    (nbi  , nbj) * ABS( flagu ) &
+                  &                    * tmask_i(nbi  , nbj)                           &
+                  &                    * tmask_i(nbi+1, nbj)                   
+            END DO
+         END DO
+
+         igrd=3 ! Add lateral surface at V-points
+         DO ib_bdy = 1, nb_bdy
+            DO ib = 1, idx_bdy(ib_bdy)%nblenrim(igrd)
+               nbi => idx_bdy(ib_bdy)%nbi(ib,igrd)
+               nbj => idx_bdy(ib_bdy)%nbj(ib,igrd)
+               flagv => idx_bdy(ib_bdy)%flagv(ib,igrd)
+               bdysurftot = bdysurftot + hv_n   (nbi, nbj  )                           &
+                  &                    * e1v    (nbi, nbj  ) * ABS( flagv ) &
+                  &                    * tmask_i(nbi, nbj  )                           &
+                  &                    * tmask_i(nbi, nbj+1)
+            END DO
+         END DO
+         !
+         IF( lk_mpp )   CALL mpp_sum( bdysurftot )      ! sum over the global domain
+      END IF   
+      !
+      ! Tidy up
+      !--------
+      IF( nb_bdy>0 )   DEALLOCATE( nbidta, nbjdta, nbrdta )
+      !
+   END SUBROUTINE bdy_segs
+
+
+   SUBROUTINE bdy_ctl_seg
+      !!----------------------------------------------------------------------
+      !!                 ***  ROUTINE bdy_ctl_seg  ***
+      !!
+      !! ** Purpose :   Check straight open boundary segments location
+      !!
+      !! ** Method  :   - Look for open boundary corners
+      !!                - Check that segments start or end on land 
+      !!----------------------------------------------------------------------
+      INTEGER  ::   ib, ib1, ib2, ji ,jj, itest  
+      INTEGER, DIMENSION(jp_nseg,2) :: icorne, icornw, icornn, icorns  
+      REAL(wp), DIMENSION(2) ::   ztestmask
+      !!----------------------------------------------------------------------
+      !
+      IF (lwp) WRITE(numout,*) ' '
+      IF (lwp) WRITE(numout,*) 'bdy_ctl_seg: Check analytical segments'
+      IF (lwp) WRITE(numout,*) '~~~~~~~~~~~~'
+      !
+      IF(lwp) WRITE(numout,*) 'Number of east  segments     : ', nbdysege
+      IF(lwp) WRITE(numout,*) 'Number of west  segments     : ', nbdysegw
+      IF(lwp) WRITE(numout,*) 'Number of north segments     : ', nbdysegn
+      IF(lwp) WRITE(numout,*) 'Number of south segments     : ', nbdysegs
+      ! 1. Check bounds
+      !----------------
+      DO ib = 1, nbdysegn
+         IF (lwp) WRITE(numout,*) '**check north seg bounds pckg: ', npckgn(ib)
+         IF ((jpjnob(ib).ge.jpjglo-1).or.& 
+            &(jpjnob(ib).le.1))        CALL ctl_stop( 'nbdyind out of domain' )
+         IF (jpindt(ib).ge.jpinft(ib)) CALL ctl_stop( 'Bdy start index is greater than end index' )
+         IF (jpindt(ib).le.1     )     CALL ctl_stop( 'Start index out of domain' )
+         IF (jpinft(ib).ge.jpiglo)     CALL ctl_stop( 'End index out of domain' )
+      END DO
+      !
+      DO ib = 1, nbdysegs
+         IF (lwp) WRITE(numout,*) '**check south seg bounds pckg: ', npckgs(ib)
+         IF ((jpjsob(ib).ge.jpjglo-1).or.& 
+            &(jpjsob(ib).le.1))        CALL ctl_stop( 'nbdyind out of domain' )
+         IF (jpisdt(ib).ge.jpisft(ib)) CALL ctl_stop( 'Bdy start index is greater than end index' )
+         IF (jpisdt(ib).le.1     )     CALL ctl_stop( 'Start index out of domain' )
+         IF (jpisft(ib).ge.jpiglo)     CALL ctl_stop( 'End index out of domain' )
+      END DO
+      !
+      DO ib = 1, nbdysege
+         IF (lwp) WRITE(numout,*) '**check east  seg bounds pckg: ', npckge(ib)
+         IF ((jpieob(ib).ge.jpiglo-1).or.& 
+            &(jpieob(ib).le.1))        CALL ctl_stop( 'nbdyind out of domain' )
+         IF (jpjedt(ib).ge.jpjeft(ib)) CALL ctl_stop( 'Bdy start index is greater than end index' )
+         IF (jpjedt(ib).le.1     )     CALL ctl_stop( 'Start index out of domain' )
+         IF (jpjeft(ib).ge.jpjglo)     CALL ctl_stop( 'End index out of domain' )
+      END DO
+      !
+      DO ib = 1, nbdysegw
+         IF (lwp) WRITE(numout,*) '**check west  seg bounds pckg: ', npckgw(ib)
+         IF ((jpiwob(ib).ge.jpiglo-1).or.& 
+            &(jpiwob(ib).le.1))        CALL ctl_stop( 'nbdyind out of domain' )
+         IF (jpjwdt(ib).ge.jpjwft(ib)) CALL ctl_stop( 'Bdy start index is greater than end index' )
+         IF (jpjwdt(ib).le.1     )     CALL ctl_stop( 'Start index out of domain' )
+         IF (jpjwft(ib).ge.jpjglo)     CALL ctl_stop( 'End index out of domain' )
+      ENDDO
+      !
+      !      
+      ! 2. Look for segment crossings
+      !------------------------------ 
+      IF (lwp) WRITE(numout,*) '**Look for segments corners  :'
+      !
+      itest = 0 ! corner number
+      !
+      ! flag to detect if start or end of open boundary belongs to a corner
+      ! if not (=0), it must be on land.
+      ! if a corner is detected, save bdy package number for further tests
+      icorne(:,:)=0. ; icornw(:,:)=0. ; icornn(:,:)=0. ; icorns(:,:)=0.
+      ! South/West crossings
+      IF ((nbdysegw > 0).AND.(nbdysegs > 0)) THEN
+         DO ib1 = 1, nbdysegw        
+            DO ib2 = 1, nbdysegs
+               IF (( jpisdt(ib2)<=jpiwob(ib1)).AND. &
+                &  ( jpisft(ib2)>=jpiwob(ib1)).AND. &
+                &  ( jpjwdt(ib1)<=jpjsob(ib2)).AND. &
+                &  ( jpjwft(ib1)>=jpjsob(ib2))) THEN
+                  IF ((jpjwdt(ib1)==jpjsob(ib2)).AND.(jpisdt(ib2)==jpiwob(ib1))) THEN 
+                     ! We have a possible South-West corner                      
+!                     WRITE(numout,*) ' Found a South-West corner at (i,j): ', jpisdt(ib2), jpjwdt(ib1) 
+!                     WRITE(numout,*) ' between segments: ', npckgw(ib1), npckgs(ib2)
+                     icornw(ib1,1) = npckgs(ib2)
+                     icorns(ib2,1) = npckgw(ib1)
+                  ELSEIF ((jpisft(ib2)==jpiwob(ib1)).AND.(jpjwft(ib1)==jpjsob(ib2))) THEN
+                     IF(lwp) WRITE(numout,*)
+                     IF(lwp) WRITE(numout,*) ' E R R O R : Found an acute open boundary corner at point (i,j)= ', &
+                     &                                     jpisft(ib2), jpjwft(ib1)
+                     IF(lwp) WRITE(numout,*) ' ==========  Not allowed yet'
+                     IF(lwp) WRITE(numout,*) '             Crossing problem with West segment: ',npckgw(ib1), & 
+                     &                                                    ' and South segment: ',npckgs(ib2)
+                     IF(lwp) WRITE(numout,*)
+                     nstop = nstop + 1
+                  ELSE
+                     IF(lwp) WRITE(numout,*)
+                     IF(lwp) WRITE(numout,*) ' E R R O R : Check South and West Open boundary indices'
+                     IF(lwp) WRITE(numout,*) ' ==========  Crossing problem with West segment: ',npckgw(ib1) , &
+                     &                                                    ' and South segment: ',npckgs(ib2)
+                     IF(lwp) WRITE(numout,*)
+                     nstop = nstop+1
+                  END IF
+               END IF
+            END DO
+         END DO
+      END IF
+      !
+      ! South/East crossings
+      IF ((nbdysege > 0).AND.(nbdysegs > 0)) THEN
+         DO ib1 = 1, nbdysege
+            DO ib2 = 1, nbdysegs
+               IF (( jpisdt(ib2)<=jpieob(ib1)+1).AND. &
+                &  ( jpisft(ib2)>=jpieob(ib1)+1).AND. &
+                &  ( jpjedt(ib1)<=jpjsob(ib2)  ).AND. &
+                &  ( jpjeft(ib1)>=jpjsob(ib2)  )) THEN
+                  IF ((jpjedt(ib1)==jpjsob(ib2)).AND.(jpisft(ib2)==jpieob(ib1)+1)) THEN
+                     ! We have a possible South-East corner 
+!                     WRITE(numout,*) ' Found a South-East corner at (i,j): ', jpisft(ib2), jpjedt(ib1) 
+!                     WRITE(numout,*) ' between segments: ', npckge(ib1), npckgs(ib2)
+                     icorne(ib1,1) = npckgs(ib2)
+                     icorns(ib2,2) = npckge(ib1)
+                  ELSEIF ((jpjeft(ib1)==jpjsob(ib2)).AND.(jpisdt(ib2)==jpieob(ib1)+1)) THEN
+                     IF(lwp) WRITE(numout,*)
+                     IF(lwp) WRITE(numout,*) ' E R R O R : Found an acute open boundary corner at point (i,j)= ', &
+                     &                                     jpisdt(ib2), jpjeft(ib1)
+                     IF(lwp) WRITE(numout,*) ' ==========  Not allowed yet'
+                     IF(lwp) WRITE(numout,*) '             Crossing problem with East segment: ',npckge(ib1), &
+                     &                                                    ' and South segment: ',npckgs(ib2)
+                     IF(lwp) WRITE(numout,*)
+                     nstop = nstop + 1
+                  ELSE
+                     IF(lwp) WRITE(numout,*)
+                     IF(lwp) WRITE(numout,*) ' E R R O R : Check South and East Open boundary indices'
+                     IF(lwp) WRITE(numout,*) ' ==========  Crossing problem with East segment: ',npckge(ib1), &
+                     &                                                    ' and South segment: ',npckgs(ib2)
+                     IF(lwp) WRITE(numout,*)
+                     nstop = nstop + 1
+                  END IF
+               END IF
+            END DO
+         END DO
+      END IF
+      !
+      ! North/West crossings
+      IF ((nbdysegn > 0).AND.(nbdysegw > 0)) THEN
+         DO ib1 = 1, nbdysegw        
+            DO ib2 = 1, nbdysegn
+               IF (( jpindt(ib2)<=jpiwob(ib1)  ).AND. &
+                &  ( jpinft(ib2)>=jpiwob(ib1)  ).AND. &
+                &  ( jpjwdt(ib1)<=jpjnob(ib2)+1).AND. &
+                &  ( jpjwft(ib1)>=jpjnob(ib2)+1)) THEN
+                  IF ((jpjwft(ib1)==jpjnob(ib2)+1).AND.(jpindt(ib2)==jpiwob(ib1))) THEN
+                     ! We have a possible North-West corner 
+!                     WRITE(numout,*) ' Found a North-West corner at (i,j): ', jpindt(ib2), jpjwft(ib1) 
+!                     WRITE(numout,*) ' between segments: ', npckgw(ib1), npckgn(ib2)
+                     icornw(ib1,2) = npckgn(ib2)
+                     icornn(ib2,1) = npckgw(ib1)
+                  ELSEIF ((jpjwdt(ib1)==jpjnob(ib2)+1).AND.(jpinft(ib2)==jpiwob(ib1))) THEN
+                     IF(lwp) WRITE(numout,*)
+                     IF(lwp) WRITE(numout,*) ' E R R O R : Found an acute open boundary corner at point (i,j)= ', &
+                     &                                     jpinft(ib2), jpjwdt(ib1)
+                     IF(lwp) WRITE(numout,*) ' ==========  Not allowed yet'
+                     IF(lwp) WRITE(numout,*) '             Crossing problem with West segment: ',npckgw(ib1), &
+                     &                                                    ' and North segment: ',npckgn(ib2)
+                     IF(lwp) WRITE(numout,*)
+                     nstop = nstop + 1
+                  ELSE
+                     IF(lwp) WRITE(numout,*)
+                     IF(lwp) WRITE(numout,*) ' E R R O R : Check North and West Open boundary indices'
+                     IF(lwp) WRITE(numout,*) ' ==========  Crossing problem with West segment: ',npckgw(ib1), &
+                     &                                                    ' and North segment: ',npckgn(ib2)
+                     IF(lwp) WRITE(numout,*)
+                     nstop = nstop + 1
+                  END IF
+               END IF
+            END DO
+         END DO
+      END IF
+      !
+      ! North/East crossings
+      IF ((nbdysegn > 0).AND.(nbdysege > 0)) THEN
+         DO ib1 = 1, nbdysege        
+            DO ib2 = 1, nbdysegn
+               IF (( jpindt(ib2)<=jpieob(ib1)+1).AND. &
+                &  ( jpinft(ib2)>=jpieob(ib1)+1).AND. &
+                &  ( jpjedt(ib1)<=jpjnob(ib2)+1).AND. &
+                &  ( jpjeft(ib1)>=jpjnob(ib2)+1)) THEN
+                  IF ((jpjeft(ib1)==jpjnob(ib2)+1).AND.(jpinft(ib2)==jpieob(ib1)+1)) THEN
+                     ! We have a possible North-East corner 
+!                     WRITE(numout,*) ' Found a North-East corner at (i,j): ', jpinft(ib2), jpjeft(ib1)
+!                     WRITE(numout,*) ' between segments: ', npckge(ib1), npckgn(ib2)
+                     icorne(ib1,2) = npckgn(ib2)
+                     icornn(ib2,2) = npckge(ib1)
+                  ELSEIF ((jpjedt(ib1)==jpjnob(ib2)+1).AND.(jpindt(ib2)==jpieob(ib1)+1)) THEN
+                     IF(lwp) WRITE(numout,*)
+                     IF(lwp) WRITE(numout,*) ' E R R O R : Found an acute open boundary corner at point (i,j)= ', &
+                     &                                     jpindt(ib2), jpjedt(ib1)
+                     IF(lwp) WRITE(numout,*) ' ==========  Not allowed yet'
+                     IF(lwp) WRITE(numout,*) '             Crossing problem with East segment: ',npckge(ib1), &
+                     &                                                    ' and North segment: ',npckgn(ib2)
+                     IF(lwp) WRITE(numout,*)
+                     nstop = nstop + 1
+                  ELSE
+                     IF(lwp) WRITE(numout,*)
+                     IF(lwp) WRITE(numout,*) ' E R R O R : Check North and East Open boundary indices'
+                     IF(lwp) WRITE(numout,*) ' ==========  Crossing problem with East segment: ',npckge(ib1), &
+                     &                                                    ' and North segment: ',npckgn(ib2)
+                     IF(lwp) WRITE(numout,*)
+                     nstop = nstop + 1
+                  END IF
+               END IF
+            END DO
+         END DO
+      END IF
+      !
+      ! 3. Check if segment extremities are on land
+      !-------------------------------------------- 
+      !
+      ! West segments
+      DO ib = 1, nbdysegw
+         ! get mask at boundary extremities:
+         ztestmask(1:2)=0.
+         DO ji = 1, jpi
+            DO jj = 1, jpj             
+              IF (((ji + nimpp - 1) == jpiwob(ib)).AND. & 
+               &  ((jj + njmpp - 1) == jpjwdt(ib))) ztestmask(1)=tmask(ji,jj,1)
+              IF (((ji + nimpp - 1) == jpiwob(ib)).AND. & 
+               &  ((jj + njmpp - 1) == jpjwft(ib))) ztestmask(2)=tmask(ji,jj,1)  
+            END DO
+         END DO
+         IF( lk_mpp )   CALL mpp_sum( ztestmask, 2 )   ! sum over the global domain
+
+         IF (ztestmask(1)==1) THEN 
+            IF (icornw(ib,1)==0) THEN
+               IF(lwp) WRITE(numout,*)
+               IF(lwp) WRITE(numout,*) ' E R R O R : Open boundary segment ', npckgw(ib)
+               IF(lwp) WRITE(numout,*) ' ==========  does not start on land or on a corner'                                                  
+               IF(lwp) WRITE(numout,*)
+               nstop = nstop + 1
+            ELSE
+               ! This is a corner
+               IF(lwp) WRITE(numout,*) 'Found a South-West corner at (i,j): ', jpiwob(ib), jpjwdt(ib)
+               CALL bdy_ctl_corn(npckgw(ib), icornw(ib,1))
+               itest=itest+1
+            ENDIF
+         ENDIF
+         IF (ztestmask(2)==1) THEN
+            IF (icornw(ib,2)==0) THEN
+               IF(lwp) WRITE(numout,*)
+               IF(lwp) WRITE(numout,*) ' E R R O R : Open boundary segment ', npckgw(ib)
+               IF(lwp) WRITE(numout,*) ' ==========  does not end on land or on a corner'                                                  
+               IF(lwp) WRITE(numout,*)
+               nstop = nstop + 1
+            ELSE
+               ! This is a corner
+               IF(lwp) WRITE(numout,*) 'Found a North-West corner at (i,j): ', jpiwob(ib), jpjwft(ib)
+               CALL bdy_ctl_corn(npckgw(ib), icornw(ib,2))
+               itest=itest+1
+            ENDIF
+         ENDIF
+      END DO
+      !
+      ! East segments
+      DO ib = 1, nbdysege
+         ! get mask at boundary extremities:
+         ztestmask(1:2)=0.
+         DO ji = 1, jpi
+            DO jj = 1, jpj             
+              IF (((ji + nimpp - 1) == jpieob(ib)+1).AND. & 
+               &  ((jj + njmpp - 1) == jpjedt(ib))) ztestmask(1)=tmask(ji,jj,1)
+              IF (((ji + nimpp - 1) == jpieob(ib)+1).AND. & 
+               &  ((jj + njmpp - 1) == jpjeft(ib))) ztestmask(2)=tmask(ji,jj,1)  
+            END DO
+         END DO
+         IF( lk_mpp )   CALL mpp_sum( ztestmask, 2 )   ! sum over the global domain
+
+         IF (ztestmask(1)==1) THEN
+            IF (icorne(ib,1)==0) THEN
+               IF(lwp) WRITE(numout,*)
+               IF(lwp) WRITE(numout,*) ' E R R O R : Open boundary segment ', npckge(ib)
+               IF(lwp) WRITE(numout,*) ' ==========  does not start on land or on a corner'                                                  
+               IF(lwp) WRITE(numout,*)
+               nstop = nstop + 1 
+            ELSE
+               ! This is a corner
+               IF(lwp) WRITE(numout,*) 'Found a South-East corner at (i,j): ', jpieob(ib)+1, jpjedt(ib)
+               CALL bdy_ctl_corn(npckge(ib), icorne(ib,1))
+               itest=itest+1
+            ENDIF
+         ENDIF
+         IF (ztestmask(2)==1) THEN
+            IF (icorne(ib,2)==0) THEN
+               IF(lwp) WRITE(numout,*)
+               IF(lwp) WRITE(numout,*) ' E R R O R : Open boundary segment ', npckge(ib)
+               IF(lwp) WRITE(numout,*) ' ==========  does not end on land or on a corner'                                                  
+               IF(lwp) WRITE(numout,*)
+               nstop = nstop + 1
+            ELSE
+               ! This is a corner
+               IF(lwp) WRITE(numout,*) 'Found a North-East corner at (i,j): ', jpieob(ib)+1, jpjeft(ib)
+               CALL bdy_ctl_corn(npckge(ib), icorne(ib,2))
+               itest=itest+1
+            ENDIF
+         ENDIF
+      END DO
+      !
+      ! South segments
+      DO ib = 1, nbdysegs
+         ! get mask at boundary extremities:
+         ztestmask(1:2)=0.
+         DO ji = 1, jpi
+            DO jj = 1, jpj             
+              IF (((jj + njmpp - 1) == jpjsob(ib)).AND. & 
+               &  ((ji + nimpp - 1) == jpisdt(ib))) ztestmask(1)=tmask(ji,jj,1)
+              IF (((jj + njmpp - 1) == jpjsob(ib)).AND. & 
+               &  ((ji + nimpp - 1) == jpisft(ib))) ztestmask(2)=tmask(ji,jj,1)  
+            END DO
+         END DO
+         IF( lk_mpp )   CALL mpp_sum( ztestmask, 2 )   ! sum over the global domain
+
+         IF ((ztestmask(1)==1).AND.(icorns(ib,1)==0)) THEN
+            IF(lwp) WRITE(numout,*)
+            IF(lwp) WRITE(numout,*) ' E R R O R : Open boundary segment ', npckgs(ib)
+            IF(lwp) WRITE(numout,*) ' ==========  does not start on land or on a corner'                                                  
+            IF(lwp) WRITE(numout,*)
+            nstop = nstop + 1
+         ENDIF
+         IF ((ztestmask(2)==1).AND.(icorns(ib,2)==0)) THEN
+            IF(lwp) WRITE(numout,*)
+            IF(lwp) WRITE(numout,*) ' E R R O R : Open boundary segment ', npckgs(ib)
+            IF(lwp) WRITE(numout,*) ' ==========  does not end on land or on a corner'                                                  
+            IF(lwp) WRITE(numout,*)
+            nstop = nstop + 1
+         ENDIF
+      END DO
+      !
+      ! North segments
+      DO ib = 1, nbdysegn
+         ! get mask at boundary extremities:
+         ztestmask(1:2)=0.
+         DO ji = 1, jpi
+            DO jj = 1, jpj             
+              IF (((jj + njmpp - 1) == jpjnob(ib)+1).AND. & 
+               &  ((ji + nimpp - 1) == jpindt(ib))) ztestmask(1)=tmask(ji,jj,1)
+              IF (((jj + njmpp - 1) == jpjnob(ib)+1).AND. & 
+               &  ((ji + nimpp - 1) == jpinft(ib))) ztestmask(2)=tmask(ji,jj,1)  
+            END DO
+         END DO
+         IF( lk_mpp )   CALL mpp_sum( ztestmask, 2 )   ! sum over the global domain
+
+         IF ((ztestmask(1)==1).AND.(icornn(ib,1)==0)) THEN
+            IF(lwp) WRITE(numout,*)
+            IF(lwp) WRITE(numout,*) ' E R R O R : Open boundary segment ', npckgn(ib)
+            IF(lwp) WRITE(numout,*) ' ==========  does not start on land'                                                  
+            IF(lwp) WRITE(numout,*)
+            nstop = nstop + 1
+         ENDIF
+         IF ((ztestmask(2)==1).AND.(icornn(ib,2)==0)) THEN
+            IF(lwp) WRITE(numout,*)
+            IF(lwp) WRITE(numout,*) ' E R R O R : Open boundary segment ', npckgn(ib)
+            IF(lwp) WRITE(numout,*) ' ==========  does not end on land'                                                  
+            IF(lwp) WRITE(numout,*)
+            nstop = nstop + 1
+         ENDIF
+      END DO
+      !
+      IF ((itest==0).AND.(lwp)) WRITE(numout,*) 'NO open boundary corner found'
+      !
+      ! Other tests TBD: 
+      ! segments completly on land
+      ! optimized open boundary array length according to landmask
+      ! Nudging layers that overlap with interior domain
+      !
+   END SUBROUTINE bdy_ctl_seg
+
+
+   SUBROUTINE bdy_ctl_corn( ib1, ib2 )
+      !!----------------------------------------------------------------------
+      !!                 ***  ROUTINE bdy_ctl_corn  ***
+      !!
+      !! ** Purpose :   Check numerical schemes consistency between
+      !!                segments having a common corner
+      !!
+      !! ** Method  :   
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT(in)  ::   ib1, ib2
+      INTEGER :: itest
+      !!----------------------------------------------------------------------
+      itest = 0
+
+      IF( cn_dyn2d(ib1) /= cn_dyn2d(ib2) )   itest = itest + 1
+      IF( cn_dyn3d(ib1) /= cn_dyn3d(ib2) )   itest = itest + 1
+      IF( cn_tra  (ib1) /= cn_tra  (ib2) )   itest = itest + 1
+      !
+      IF( nn_dyn2d_dta(ib1) /= nn_dyn2d_dta(ib2) )   itest = itest + 1
+      IF( nn_dyn3d_dta(ib1) /= nn_dyn3d_dta(ib2) )   itest = itest + 1
+      IF( nn_tra_dta  (ib1) /= nn_tra_dta  (ib2) )   itest = itest + 1
+      !
+      IF( nn_rimwidth(ib1) /= nn_rimwidth(ib2) )   itest = itest + 1   
+      !
+      IF( itest>0 ) THEN
+         IF(lwp) WRITE(numout,*) ' E R R O R : Segments ', ib1, 'and ', ib2
+         IF(lwp) WRITE(numout,*) ' ==========  have different open bdy schemes'                                                  
+         IF(lwp) WRITE(numout,*)
+         nstop = nstop + 1
+      ENDIF
+      !
+   END SUBROUTINE bdy_ctl_corn
+
+   !!=================================================================================
+END MODULE bdyini
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/BDY/bdylib.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/BDY/bdylib.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/BDY/bdylib.F90	(revision 9570)
@@ -0,0 +1,499 @@
+MODULE bdylib
+   !!======================================================================
+   !!                       ***  MODULE  bdylib  ***
+   !! Unstructured Open Boundary Cond. :  Library module of generic boundary algorithms.
+   !!======================================================================
+   !! History :  3.6  !  2013     (D. Storkey) original code
+   !!            4.0  !  2014     (T. Lovato) Generalize OBC structure
+   !!----------------------------------------------------------------------
+   !!----------------------------------------------------------------------
+   !!   bdy_orlanski_2d
+   !!   bdy_orlanski_3d
+   !!----------------------------------------------------------------------
+   USE oce            ! ocean dynamics and tracers 
+   USE dom_oce        ! ocean space and time domain
+   USE bdy_oce        ! ocean open boundary conditions
+   USE phycst         ! physical constants
+   !
+   USE in_out_manager !
+   USE lbclnk         ! ocean lateral boundary conditions (or mpp link)
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   bdy_frs, bdy_spe, bdy_nmn, bdy_orl
+   PUBLIC   bdy_orlanski_2d
+   PUBLIC   bdy_orlanski_3d
+
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 4.0 , NEMO Consortium (2016)
+   !! $Id$ 
+   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE bdy_frs( idx, pta, dta )
+      !!----------------------------------------------------------------------
+      !!                 ***  SUBROUTINE bdy_frs  ***
+      !!
+      !! ** Purpose : Apply the Flow Relaxation Scheme for tracers at open boundaries.
+      !!
+      !! Reference : Engedahl H., 1995, Tellus, 365-382.
+      !!----------------------------------------------------------------------
+      TYPE(OBC_INDEX),                     INTENT(in) ::   idx  ! OBC indices
+      REAL(wp), DIMENSION(:,:),            INTENT(in) ::   dta  ! OBC external data
+      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pta  ! tracer trend
+      !!
+      REAL(wp) ::   zwgt           ! boundary weight
+      INTEGER  ::   ib, ik, igrd   ! dummy loop indices
+      INTEGER  ::   ii, ij         ! 2D addresses
+      !!----------------------------------------------------------------------
+      !
+      igrd = 1                       ! Everything is at T-points here
+      DO ib = 1, idx%nblen(igrd)
+         DO ik = 1, jpkm1
+            ii = idx%nbi(ib,igrd) 
+            ij = idx%nbj(ib,igrd)
+            zwgt = idx%nbw(ib,igrd)
+            pta(ii,ij,ik) = ( pta(ii,ij,ik) + zwgt * (dta(ib,ik) - pta(ii,ij,ik) ) ) * tmask(ii,ij,ik)
+         END DO
+      END DO
+      !
+   END SUBROUTINE bdy_frs
+
+
+   SUBROUTINE bdy_spe( idx, pta, dta )
+      !!----------------------------------------------------------------------
+      !!                 ***  SUBROUTINE bdy_spe  ***
+      !!
+      !! ** Purpose : Apply a specified value for tracers at open boundaries.
+      !!
+      !!----------------------------------------------------------------------
+      TYPE(OBC_INDEX),                     INTENT(in) ::   idx  ! OBC indices
+      REAL(wp), DIMENSION(:,:),            INTENT(in) ::   dta  ! OBC external data
+      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pta  ! tracer trend
+      !!
+      REAL(wp) ::   zwgt           ! boundary weight
+      INTEGER  ::   ib, ik, igrd   ! dummy loop indices
+      INTEGER  ::   ii, ij         ! 2D addresses
+      !!----------------------------------------------------------------------
+      !
+      igrd = 1                       ! Everything is at T-points here
+      DO ib = 1, idx%nblenrim(igrd)
+         ii = idx%nbi(ib,igrd)
+         ij = idx%nbj(ib,igrd)
+         DO ik = 1, jpkm1
+            pta(ii,ij,ik) = dta(ib,ik) * tmask(ii,ij,ik)
+         END DO
+      END DO
+      !
+   END SUBROUTINE bdy_spe
+
+
+   SUBROUTINE bdy_orl( idx, ptb, pta, dta, ll_npo )
+      !!----------------------------------------------------------------------
+      !!                 ***  SUBROUTINE bdy_orl  ***
+      !!
+      !! ** Purpose : Apply Orlanski radiation for tracers at open boundaries.
+      !!              This is a wrapper routine for bdy_orlanski_3d below
+      !!
+      !!----------------------------------------------------------------------
+      TYPE(OBC_INDEX),                     INTENT(in) ::   idx  ! OBC indices
+      REAL(wp), DIMENSION(:,:),            INTENT(in) ::   dta  ! OBC external data
+      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   ptb  ! before tracer field
+      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pta  ! tracer trend
+      LOGICAL,                             INTENT(in) ::   ll_npo  ! switch for NPO version
+      !!
+      INTEGER  ::   igrd                                    ! grid index
+      !!----------------------------------------------------------------------
+      !
+      igrd = 1                       ! Everything is at T-points here
+      !
+      CALL bdy_orlanski_3d( idx, igrd, ptb(:,:,:), pta(:,:,:), dta, ll_npo )
+      !
+   END SUBROUTINE bdy_orl
+
+
+   SUBROUTINE bdy_orlanski_2d( idx, igrd, phib, phia, phi_ext, ll_npo )
+      !!----------------------------------------------------------------------
+      !!                 ***  SUBROUTINE bdy_orlanski_2d  ***
+      !!             
+      !!              - Apply Orlanski radiation condition adaptively to 2D fields:
+      !!                  - radiation plus weak nudging at outflow points
+      !!                  - no radiation and strong nudging at inflow points
+      !! 
+      !!
+      !! References:  Marchesiello, McWilliams and Shchepetkin, Ocean Modelling vol. 3 (2001)    
+      !!----------------------------------------------------------------------
+      TYPE(OBC_INDEX),          INTENT(in   ) ::   idx      ! BDY indices
+      INTEGER ,                 INTENT(in   ) ::   igrd     ! grid index
+      REAL(wp), DIMENSION(:,:), INTENT(in   ) ::   phib     ! model before 2D field
+      REAL(wp), DIMENSION(:,:), INTENT(inout) ::   phia     ! model after 2D field (to be updated)
+      REAL(wp), DIMENSION(:)  , INTENT(in   ) ::   phi_ext  ! external forcing data
+      LOGICAL ,                 INTENT(in   ) ::   ll_npo   ! switch for NPO version
+      !
+      INTEGER  ::   jb                                     ! dummy loop indices
+      INTEGER  ::   ii, ij, iibm1, iibm2, ijbm1, ijbm2     ! 2D addresses
+      INTEGER  ::   iijm1, iijp1, ijjm1, ijjp1             ! 2D addresses
+      INTEGER  ::   iibm1jp1, iibm1jm1, ijbm1jp1, ijbm1jm1 ! 2D addresses
+      INTEGER  ::   ii_offset, ij_offset                   ! offsets for mask indices
+      INTEGER  ::   flagu, flagv                           ! short cuts
+      REAL(wp) ::   zmask_x, zmask_y1, zmask_y2
+      REAL(wp) ::   zex1, zex2, zey, zey1, zey2
+      REAL(wp) ::   zdt, zdx, zdy, znor2, zrx, zry         ! intermediate calculations
+      REAL(wp) ::   zout, zwgt, zdy_centred
+      REAL(wp) ::   zdy_1, zdy_2, zsign_ups
+      REAL(wp), PARAMETER :: zepsilon = 1.e-30                 ! local small value
+      REAL(wp), POINTER, DIMENSION(:,:)          :: pmask      ! land/sea mask for field
+      REAL(wp), POINTER, DIMENSION(:,:)          :: pmask_xdif ! land/sea mask for x-derivatives
+      REAL(wp), POINTER, DIMENSION(:,:)          :: pmask_ydif ! land/sea mask for y-derivatives
+      REAL(wp), POINTER, DIMENSION(:,:)          :: pe_xdif    ! scale factors for x-derivatives
+      REAL(wp), POINTER, DIMENSION(:,:)          :: pe_ydif    ! scale factors for y-derivatives
+      !!----------------------------------------------------------------------
+      !
+      ! ----------------------------------!
+      ! Orlanski boundary conditions     :!
+      ! ----------------------------------! 
+     
+      SELECT CASE(igrd)
+         CASE(1)
+            pmask      => tmask(:,:,1)
+            pmask_xdif => umask(:,:,1)
+            pmask_ydif => vmask(:,:,1)
+            pe_xdif    => e1u(:,:)
+            pe_ydif    => e2v(:,:)
+            ii_offset = 0
+            ij_offset = 0
+         CASE(2)
+            pmask      => umask(:,:,1)
+            pmask_xdif => tmask(:,:,1)
+            pmask_ydif => fmask(:,:,1)
+            pe_xdif    => e1t(:,:)
+            pe_ydif    => e2f(:,:)
+            ii_offset = 1
+            ij_offset = 0
+         CASE(3)
+            pmask      => vmask(:,:,1)
+            pmask_xdif => fmask(:,:,1)
+            pmask_ydif => tmask(:,:,1)
+            pe_xdif    => e1f(:,:)
+            pe_ydif    => e2t(:,:)
+            ii_offset = 0
+            ij_offset = 1
+         CASE DEFAULT ;   CALL ctl_stop( 'unrecognised value for igrd in bdy_orlanksi_2d' )
+      END SELECT
+      !
+      DO jb = 1, idx%nblenrim(igrd)
+         ii  = idx%nbi(jb,igrd)
+         ij  = idx%nbj(jb,igrd) 
+         flagu = int( idx%flagu(jb,igrd) )
+         flagv = int( idx%flagv(jb,igrd) )
+         !
+         ! Calculate positions of b-1 and b-2 points for this rim point
+         ! also (b-1,j-1) and (b-1,j+1) points
+         iibm1 = ii + flagu ; iibm2 = ii + 2*flagu 
+         ijbm1 = ij + flagv ; ijbm2 = ij + 2*flagv
+          !
+         iijm1 = ii - abs(flagv) ; iijp1 = ii + abs(flagv) 
+         ijjm1 = ij - abs(flagu) ; ijjp1 = ij + abs(flagu)
+         !
+         iibm1jm1 = ii + flagu - abs(flagv) ; iibm1jp1 = ii + flagu + abs(flagv) 
+         ijbm1jm1 = ij + flagv - abs(flagu) ; ijbm1jp1 = ij + flagv + abs(flagu) 
+         !
+         ! Calculate scale factors for calculation of spatial derivatives.        
+         zex1 = ( abs(iibm1-iibm2) * pe_xdif(iibm1+ii_offset,ijbm1          )         &
+        &       + abs(ijbm1-ijbm2) * pe_ydif(iibm1          ,ijbm1+ij_offset) ) 
+         zex2 = ( abs(iibm1-iibm2) * pe_xdif(iibm2+ii_offset,ijbm2          )         &
+        &       + abs(ijbm1-ijbm2) * pe_ydif(iibm2          ,ijbm2+ij_offset) ) 
+         zey1 = ( (iibm1-iibm1jm1) * pe_xdif(iibm1jm1+ii_offset,ijbm1jm1          )  & 
+        &      +  (ijbm1-ijbm1jm1) * pe_ydif(iibm1jm1          ,ijbm1jm1+ij_offset) ) 
+         zey2 = ( (iibm1jp1-iibm1) * pe_xdif(iibm1+ii_offset,ijbm1)                  &
+        &      +  (ijbm1jp1-ijbm1) * pe_ydif(iibm1          ,ijbm1+ij_offset) ) 
+         ! make sure scale factors are nonzero
+         if( zey1 .lt. rsmall ) zey1 = zey2
+         if( zey2 .lt. rsmall ) zey2 = zey1
+         zex1 = max(zex1,rsmall); zex2 = max(zex2,rsmall)
+         zey1 = max(zey1,rsmall); zey2 = max(zey2,rsmall); 
+         !
+         ! Calculate masks for calculation of spatial derivatives.        
+         zmask_x = ( abs(iibm1-iibm2) * pmask_xdif(iibm2+ii_offset,ijbm2          )         &
+        &          + abs(ijbm1-ijbm2) * pmask_ydif(iibm2          ,ijbm2+ij_offset) ) 
+         zmask_y1 = ( (iibm1-iibm1jm1) * pmask_xdif(iibm1jm1+ii_offset,ijbm1jm1          )  & 
+        &          +  (ijbm1-ijbm1jm1) * pmask_ydif(iibm1jm1          ,ijbm1jm1+ij_offset) ) 
+         zmask_y2 = ( (iibm1jp1-iibm1) * pmask_xdif(iibm1+ii_offset,ijbm1)                  &
+        &          +  (ijbm1jp1-ijbm1) * pmask_ydif(iibm1          ,ijbm1+ij_offset) ) 
+
+         ! Calculation of terms required for both versions of the scheme. 
+         ! Mask derivatives to ensure correct land boundary conditions for each variable.
+         ! Centred derivative is calculated as average of "left" and "right" derivatives for 
+         ! this reason. 
+         ! Note no rdt factor in expression for zdt because it cancels in the expressions for 
+         ! zrx and zry.
+         zdt = phia(iibm1,ijbm1) - phib(iibm1,ijbm1)
+         zdx = ( ( phia(iibm1,ijbm1) - phia(iibm2,ijbm2) ) / zex2 ) * zmask_x 
+         zdy_1 = ( ( phib(iibm1   ,ijbm1   ) - phib(iibm1jm1,ijbm1jm1) ) / zey1 ) * zmask_y1    
+         zdy_2 = ( ( phib(iibm1jp1,ijbm1jp1) - phib(iibm1   ,ijbm1)    ) / zey2 ) * zmask_y2 
+         zdy_centred = 0.5 * ( zdy_1 + zdy_2 )
+!!$         zdy_centred = phib(iibm1jp1,ijbm1jp1) - phib(iibm1jm1,ijbm1jm1)
+         ! upstream differencing for tangential derivatives
+         zsign_ups = sign( 1., zdt * zdy_centred )
+         zsign_ups = 0.5*( zsign_ups + abs(zsign_ups) )
+         zdy = zsign_ups * zdy_1 + (1. - zsign_ups) * zdy_2
+         znor2 = zdx * zdx + zdy * zdy
+         znor2 = max(znor2,zepsilon)
+         !
+         zrx = zdt * zdx / ( zex1 * znor2 ) 
+!!$         zrx = min(zrx,2.0_wp)
+         zout = sign( 1., zrx )
+         zout = 0.5*( zout + abs(zout) )
+         zwgt = 2.*rdt*( (1.-zout) * idx%nbd(jb,igrd) + zout * idx%nbdout(jb,igrd) )
+         ! only apply radiation on outflow points 
+         if( ll_npo ) then     !! NPO version !!
+            phia(ii,ij) = (1.-zout) * ( phib(ii,ij) + zwgt * ( phi_ext(jb) - phib(ii,ij) ) )        &
+           &            + zout      * ( phib(ii,ij) + zrx*phia(iibm1,ijbm1)                         &
+           &                            + zwgt * ( phi_ext(jb) - phib(ii,ij) ) ) / ( 1. + zrx ) 
+         else                  !! full oblique radiation !!
+            zsign_ups = sign( 1., zdt * zdy )
+            zsign_ups = 0.5*( zsign_ups + abs(zsign_ups) )
+            zey = zsign_ups * zey1 + (1.-zsign_ups) * zey2 
+            zry = zdt * zdy / ( zey * znor2 ) 
+            phia(ii,ij) = (1.-zout) * ( phib(ii,ij) + zwgt * ( phi_ext(jb) - phib(ii,ij) ) )        &
+           &            + zout      * ( phib(ii,ij) + zrx*phia(iibm1,ijbm1)                         &
+           &                    - zsign_ups      * zry * ( phib(ii   ,ij   ) - phib(iijm1,ijjm1 ) ) &
+           &                    - (1.-zsign_ups) * zry * ( phib(iijp1,ijjp1) - phib(ii   ,ij    ) ) &
+           &                    + zwgt * ( phi_ext(jb) - phib(ii,ij) ) ) / ( 1. + zrx ) 
+         end if
+         phia(ii,ij) = phia(ii,ij) * pmask(ii,ij)
+      END DO
+      !
+   END SUBROUTINE bdy_orlanski_2d
+
+
+   SUBROUTINE bdy_orlanski_3d( idx, igrd, phib, phia, phi_ext, ll_npo )
+      !!----------------------------------------------------------------------
+      !!                 ***  SUBROUTINE bdy_orlanski_3d  ***
+      !!             
+      !!              - Apply Orlanski radiation condition adaptively to 3D fields:
+      !!                  - radiation plus weak nudging at outflow points
+      !!                  - no radiation and strong nudging at inflow points
+      !! 
+      !!
+      !! References:  Marchesiello, McWilliams and Shchepetkin, Ocean Modelling vol. 3 (2001)    
+      !!----------------------------------------------------------------------
+      TYPE(OBC_INDEX),            INTENT(in   ) ::   idx      ! BDY indices
+      INTEGER ,                   INTENT(in   ) ::   igrd     ! grid index
+      REAL(wp), DIMENSION(:,:,:), INTENT(in   ) ::   phib     ! model before 3D field
+      REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   phia     ! model after 3D field (to be updated)
+      REAL(wp), DIMENSION(:,:)  , INTENT(in   ) ::   phi_ext  ! external forcing data
+      LOGICAL ,                   INTENT(in   ) ::   ll_npo   ! switch for NPO version
+      !
+      INTEGER  ::   jb, jk                                 ! dummy loop indices
+      INTEGER  ::   ii, ij, iibm1, iibm2, ijbm1, ijbm2     ! 2D addresses
+      INTEGER  ::   iijm1, iijp1, ijjm1, ijjp1             ! 2D addresses
+      INTEGER  ::   iibm1jp1, iibm1jm1, ijbm1jp1, ijbm1jm1 ! 2D addresses
+      INTEGER  ::   ii_offset, ij_offset                   ! offsets for mask indices
+      INTEGER  ::   flagu, flagv                           ! short cuts
+      REAL(wp) ::   zmask_x, zmask_y1, zmask_y2
+      REAL(wp) ::   zex1, zex2, zey, zey1, zey2
+      REAL(wp) ::   zdt, zdx, zdy, znor2, zrx, zry         ! intermediate calculations
+      REAL(wp) ::   zout, zwgt, zdy_centred
+      REAL(wp) ::   zdy_1, zdy_2,  zsign_ups
+      REAL(wp), PARAMETER :: zepsilon = 1.e-30                 ! local small value
+      REAL(wp), POINTER, DIMENSION(:,:,:)        :: pmask      ! land/sea mask for field
+      REAL(wp), POINTER, DIMENSION(:,:,:)        :: pmask_xdif ! land/sea mask for x-derivatives
+      REAL(wp), POINTER, DIMENSION(:,:,:)        :: pmask_ydif ! land/sea mask for y-derivatives
+      REAL(wp), POINTER, DIMENSION(:,:)          :: pe_xdif    ! scale factors for x-derivatives
+      REAL(wp), POINTER, DIMENSION(:,:)          :: pe_ydif    ! scale factors for y-derivatives
+      !!----------------------------------------------------------------------
+      !
+      ! ----------------------------------!
+      ! Orlanski boundary conditions     :!
+      ! ----------------------------------! 
+      !
+      SELECT CASE(igrd)
+         CASE(1)
+            pmask      => tmask(:,:,:)
+            pmask_xdif => umask(:,:,:)
+            pmask_ydif => vmask(:,:,:)
+            pe_xdif    => e1u(:,:)
+            pe_ydif    => e2v(:,:)
+            ii_offset = 0
+            ij_offset = 0
+         CASE(2)
+            pmask      => umask(:,:,:)
+            pmask_xdif => tmask(:,:,:)
+            pmask_ydif => fmask(:,:,:)
+            pe_xdif    => e1t(:,:)
+            pe_ydif    => e2f(:,:)
+            ii_offset = 1
+            ij_offset = 0
+         CASE(3)
+            pmask      => vmask(:,:,:)
+            pmask_xdif => fmask(:,:,:)
+            pmask_ydif => tmask(:,:,:)
+            pe_xdif    => e1f(:,:)
+            pe_ydif    => e2t(:,:)
+            ii_offset = 0
+            ij_offset = 1
+         CASE DEFAULT ;   CALL ctl_stop( 'unrecognised value for igrd in bdy_orlanksi_2d' )
+      END SELECT
+
+      DO jk = 1, jpk
+         !            
+         DO jb = 1, idx%nblenrim(igrd)
+            ii  = idx%nbi(jb,igrd)
+            ij  = idx%nbj(jb,igrd) 
+            flagu = int( idx%flagu(jb,igrd) )
+            flagv = int( idx%flagv(jb,igrd) )
+            !
+            ! calculate positions of b-1 and b-2 points for this rim point
+            ! also (b-1,j-1) and (b-1,j+1) points
+            iibm1 = ii + flagu ; iibm2 = ii + 2*flagu 
+            ijbm1 = ij + flagv ; ijbm2 = ij + 2*flagv
+            !
+            iijm1 = ii - abs(flagv) ; iijp1 = ii + abs(flagv) 
+            ijjm1 = ij - abs(flagu) ; ijjp1 = ij + abs(flagu)
+            !
+            iibm1jm1 = ii + flagu - abs(flagv) ; iibm1jp1 = ii + flagu + abs(flagv) 
+            ijbm1jm1 = ij + flagv - abs(flagu) ; ijbm1jp1 = ij + flagv + abs(flagu) 
+            !
+            ! Calculate scale factors for calculation of spatial derivatives.        
+            zex1 = ( abs(iibm1-iibm2) * pe_xdif(iibm1+ii_offset,ijbm1          )         &
+           &       + abs(ijbm1-ijbm2) * pe_ydif(iibm1          ,ijbm1+ij_offset) ) 
+            zex2 = ( abs(iibm1-iibm2) * pe_xdif(iibm2+ii_offset,ijbm2          )         &
+           &       + abs(ijbm1-ijbm2) * pe_ydif(iibm2          ,ijbm2+ij_offset) ) 
+            zey1 = ( (iibm1-iibm1jm1) * pe_xdif(iibm1jm1+ii_offset,ijbm1jm1          )  & 
+           &      +  (ijbm1-ijbm1jm1) * pe_ydif(iibm1jm1          ,ijbm1jm1+ij_offset) ) 
+            zey2 = ( (iibm1jp1-iibm1) * pe_xdif(iibm1+ii_offset,ijbm1)                  &
+           &      +  (ijbm1jp1-ijbm1) * pe_ydif(iibm1          ,ijbm1+ij_offset) ) 
+            ! make sure scale factors are nonzero
+            if( zey1 .lt. rsmall ) zey1 = zey2
+            if( zey2 .lt. rsmall ) zey2 = zey1
+            zex1 = max(zex1,rsmall); zex2 = max(zex2,rsmall); 
+            zey1 = max(zey1,rsmall); zey2 = max(zey2,rsmall); 
+            !
+            ! Calculate masks for calculation of spatial derivatives.        
+            zmask_x = ( abs(iibm1-iibm2) * pmask_xdif(iibm2+ii_offset,ijbm2          ,jk)          &
+           &          + abs(ijbm1-ijbm2) * pmask_ydif(iibm2          ,ijbm2+ij_offset,jk) ) 
+            zmask_y1 = ( (iibm1-iibm1jm1) * pmask_xdif(iibm1jm1+ii_offset,ijbm1jm1          ,jk)   & 
+           &          +  (ijbm1-ijbm1jm1) * pmask_ydif(iibm1jm1          ,ijbm1jm1+ij_offset,jk) ) 
+            zmask_y2 = ( (iibm1jp1-iibm1) * pmask_xdif(iibm1+ii_offset,ijbm1          ,jk)         &
+           &          +  (ijbm1jp1-ijbm1) * pmask_ydif(iibm1          ,ijbm1+ij_offset,jk) ) 
+            !
+            ! Calculate normal (zrx) and tangential (zry) components of radiation velocities.
+            ! Mask derivatives to ensure correct land boundary conditions for each variable.
+            ! Centred derivative is calculated as average of "left" and "right" derivatives for 
+            ! this reason. 
+            zdt = phia(iibm1,ijbm1,jk) - phib(iibm1,ijbm1,jk)
+            zdx = ( ( phia(iibm1,ijbm1,jk) - phia(iibm2,ijbm2,jk) ) / zex2 ) * zmask_x                  
+            zdy_1 = ( ( phib(iibm1   ,ijbm1   ,jk) - phib(iibm1jm1,ijbm1jm1,jk) ) / zey1 ) * zmask_y1  
+            zdy_2 = ( ( phib(iibm1jp1,ijbm1jp1,jk) - phib(iibm1   ,ijbm1   ,jk) ) / zey2 ) * zmask_y2      
+            zdy_centred = 0.5 * ( zdy_1 + zdy_2 )
+!!$            zdy_centred = phib(iibm1jp1,ijbm1jp1,jk) - phib(iibm1jm1,ijbm1jm1,jk)
+            ! upstream differencing for tangential derivatives
+            zsign_ups = sign( 1., zdt * zdy_centred )
+            zsign_ups = 0.5*( zsign_ups + abs(zsign_ups) )
+            zdy = zsign_ups * zdy_1 + (1. - zsign_ups) * zdy_2
+            znor2 = zdx * zdx + zdy * zdy
+            znor2 = max(znor2,zepsilon)
+            !
+            ! update boundary value:
+            zrx = zdt * zdx / ( zex1 * znor2 )
+!!$            zrx = min(zrx,2.0_wp)
+            zout = sign( 1., zrx )
+            zout = 0.5*( zout + abs(zout) )
+            zwgt = 2.*rdt*( (1.-zout) * idx%nbd(jb,igrd) + zout * idx%nbdout(jb,igrd) )
+            ! only apply radiation on outflow points 
+            if( ll_npo ) then     !! NPO version !!
+               phia(ii,ij,jk) = (1.-zout) * ( phib(ii,ij,jk) + zwgt * ( phi_ext(jb,jk) - phib(ii,ij,jk) ) ) &
+              &               + zout      * ( phib(ii,ij,jk) + zrx*phia(iibm1,ijbm1,jk)                     &
+              &                            + zwgt * ( phi_ext(jb,jk) - phib(ii,ij,jk) ) ) / ( 1. + zrx ) 
+            else                  !! full oblique radiation !!
+               zsign_ups = sign( 1., zdt * zdy )
+               zsign_ups = 0.5*( zsign_ups + abs(zsign_ups) )
+               zey = zsign_ups * zey1 + (1.-zsign_ups) * zey2 
+               zry = zdt * zdy / ( zey * znor2 ) 
+               phia(ii,ij,jk) = (1.-zout) * ( phib(ii,ij,jk) + zwgt * ( phi_ext(jb,jk) - phib(ii,ij,jk) ) )    &
+              &               + zout      * ( phib(ii,ij,jk) + zrx*phia(iibm1,ijbm1,jk)                        &
+              &                       - zsign_ups      * zry * ( phib(ii   ,ij   ,jk) - phib(iijm1,ijjm1,jk) ) &
+              &                       - (1.-zsign_ups) * zry * ( phib(iijp1,ijjp1,jk) - phib(ii   ,ij   ,jk) ) &
+              &                       + zwgt * ( phi_ext(jb,jk) - phib(ii,ij,jk) ) ) / ( 1. + zrx ) 
+            end if
+            phia(ii,ij,jk) = phia(ii,ij,jk) * pmask(ii,ij,jk)
+         END DO
+         !
+      END DO
+      !
+   END SUBROUTINE bdy_orlanski_3d
+
+   SUBROUTINE bdy_nmn( idx, igrd, phia )
+      !!----------------------------------------------------------------------
+      !!                 ***  SUBROUTINE bdy_nmn  ***
+      !!                    
+      !! ** Purpose : Duplicate the value at open boundaries, zero gradient.
+      !! 
+      !!----------------------------------------------------------------------
+      INTEGER,                    INTENT(in)     ::   igrd     ! grid index
+      REAL(wp), DIMENSION(:,:,:), INTENT(inout)  ::   phia     ! model after 3D field (to be updated)
+      TYPE(OBC_INDEX), INTENT(in) ::   idx  ! OBC indices
+      !! 
+      REAL(wp) ::   zcoef, zcoef1, zcoef2
+      REAL(wp), POINTER, DIMENSION(:,:,:)        :: pmask      ! land/sea mask for field
+      REAL(wp), POINTER, DIMENSION(:,:)        :: bdypmask      ! land/sea mask for field
+      INTEGER  ::   ib, ik   ! dummy loop indices
+      INTEGER  ::   ii, ij, ip, jp   ! 2D addresses
+      !!----------------------------------------------------------------------
+      !
+      SELECT CASE(igrd)
+         CASE(1)
+            pmask => tmask(:,:,:)
+            bdypmask => bdytmask(:,:)
+         CASE(2)
+            pmask => umask(:,:,:)
+            bdypmask => bdyumask(:,:)
+         CASE(3)
+            pmask => vmask(:,:,:)
+            bdypmask => bdyvmask(:,:)
+         CASE DEFAULT ;   CALL ctl_stop( 'unrecognised value for igrd in bdy_nmn' )
+      END SELECT
+      DO ib = 1, idx%nblenrim(igrd)
+         ii = idx%nbi(ib,igrd)
+         ij = idx%nbj(ib,igrd)
+         DO ik = 1, jpkm1
+            ! search the sense of the gradient
+            zcoef1 = bdypmask(ii-1,ij  )*pmask(ii-1,ij,ik) +  bdypmask(ii+1,ij  )*pmask(ii+1,ij,ik)
+            zcoef2 = bdypmask(ii  ,ij-1)*pmask(ii,ij-1,ik) +  bdypmask(ii  ,ij+1)*pmask(ii,ij+1,ik)
+            IF ( nint(zcoef1+zcoef2) == 0) THEN
+               ! corner **** we probably only want to set the tangentail component for the dynamics here
+               zcoef = pmask(ii-1,ij,ik) + pmask(ii+1,ij,ik) +  pmask(ii,ij-1,ik) +  pmask(ii,ij+1,ik)
+               IF (zcoef > .5_wp) THEN ! Only set none isolated points.
+                 phia(ii,ij,ik) = phia(ii-1,ij  ,ik) * pmask(ii-1,ij  ,ik) + &
+                   &              phia(ii+1,ij  ,ik) * pmask(ii+1,ij  ,ik) + &
+                   &              phia(ii  ,ij-1,ik) * pmask(ii  ,ij-1,ik) + &
+                   &              phia(ii  ,ij+1,ik) * pmask(ii  ,ij+1,ik)
+                 phia(ii,ij,ik) = ( phia(ii,ij,ik) / zcoef ) * pmask(ii,ij,ik)
+               ELSE
+                 phia(ii,ij,ik) = phia(ii,ij  ,ik) * pmask(ii,ij  ,ik)
+               ENDIF
+            ELSEIF ( nint(zcoef1+zcoef2) == 2) THEN
+               ! oblique corner **** we probably only want to set the normal component for the dynamics here
+               zcoef = pmask(ii-1,ij,ik)*bdypmask(ii-1,ij  ) + pmask(ii+1,ij,ik)*bdypmask(ii+1,ij  ) + &
+                   &   pmask(ii,ij-1,ik)*bdypmask(ii,ij -1 ) +  pmask(ii,ij+1,ik)*bdypmask(ii,ij+1  )
+               phia(ii,ij,ik) = phia(ii-1,ij  ,ik) * pmask(ii-1,ij  ,ik)*bdypmask(ii-1,ij  ) + &
+                   &            phia(ii+1,ij  ,ik) * pmask(ii+1,ij  ,ik)*bdypmask(ii+1,ij  )  + &
+                   &            phia(ii  ,ij-1,ik) * pmask(ii  ,ij-1,ik)*bdypmask(ii,ij -1 ) + &
+                   &            phia(ii  ,ij+1,ik) * pmask(ii  ,ij+1,ik)*bdypmask(ii,ij+1  )
+ 
+               phia(ii,ij,ik) = ( phia(ii,ij,ik) / MAX(1._wp, zcoef) ) * pmask(ii,ij,ik)
+            ELSE
+               ip = nint(bdypmask(ii+1,ij  )*pmask(ii+1,ij,ik) - bdypmask(ii-1,ij  )*pmask(ii-1,ij,ik))
+               jp = nint(bdypmask(ii  ,ij+1)*pmask(ii,ij+1,ik) - bdypmask(ii  ,ij-1)*pmask(ii,ij-1,ik))
+               phia(ii,ij,ik) = phia(ii+ip,ij+jp,ik) * pmask(ii+ip,ij+jp,ik)
+            ENDIF
+         END DO
+      END DO
+      !
+   END SUBROUTINE bdy_nmn
+
+   !!======================================================================
+END MODULE bdylib
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/BDY/bdytides.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/BDY/bdytides.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/BDY/bdytides.F90	(revision 9570)
@@ -0,0 +1,578 @@
+MODULE bdytides
+   !!======================================================================
+   !!                       ***  MODULE  bdytides  ***
+   !! Ocean dynamics:   Tidal forcing at open boundaries
+   !!======================================================================
+   !! History :  2.0  !  2007-01  (D.Storkey)  Original code
+   !!            2.3  !  2008-01  (J.Holt)  Add date correction. Origins POLCOMS v6.3 2007
+   !!            3.0  !  2008-04  (NEMO team)  add in the reference version
+   !!            3.3  !  2010-09  (D.Storkey and E.O'Dea)  bug fixes
+   !!            3.4  !  2012-09  (G. Reffray and J. Chanut) New inputs + mods
+   !!            3.5  !  2013-07  (J. Chanut) Compliant with time splitting changes
+   !!----------------------------------------------------------------------
+   !!   bdytide_init  : read of namelist and initialisation of tidal harmonics data
+   !!   tide_update   : calculation of tidal forcing at each timestep
+   !!----------------------------------------------------------------------
+   USE oce            ! ocean dynamics and tracers 
+   USE dom_oce        ! ocean space and time domain
+   USE phycst         ! physical constants
+   USE bdy_oce        ! ocean open boundary conditions
+   USE tideini        ! 
+   USE daymod         ! calendar
+   !
+   USE in_out_manager ! I/O units
+   USE iom            ! xIO server
+   USE fldread        !
+   USE lbclnk         ! ocean lateral boundary conditions (or mpp link)
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   bdytide_init     ! routine called in bdy_init
+   PUBLIC   bdytide_update   ! routine called in bdy_dta
+   PUBLIC   bdy_dta_tides    ! routine called in dyn_spg_ts
+
+   TYPE, PUBLIC ::   TIDES_DATA     !: Storage for external tidal harmonics data
+      REAL(wp), POINTER, DIMENSION(:,:,:)    ::   ssh0     !: Tidal constituents : SSH0   (read in file)
+      REAL(wp), POINTER, DIMENSION(:,:,:)    ::   u0, v0   !: Tidal constituents : U0, V0 (read in file)
+      REAL(wp), POINTER, DIMENSION(:,:,:)    ::   ssh      !: Tidal constituents : SSH    (after nodal cor.)
+      REAL(wp), POINTER, DIMENSION(:,:,:)    ::   u , v    !: Tidal constituents : U , V  (after nodal cor.)
+   END TYPE TIDES_DATA
+
+!$AGRIF_DO_NOT_TREAT
+   TYPE(TIDES_DATA), PUBLIC, DIMENSION(jp_bdy), TARGET :: tides  !: External tidal harmonics data
+!$AGRIF_END_DO_NOT_TREAT
+   TYPE(OBC_DATA)  , PUBLIC, DIMENSION(jp_bdy) :: dta_bdy_s  !: bdy external data (slow component)
+
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO Consortium (2010)
+   !! $Id$
+   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE bdytide_init
+      !!----------------------------------------------------------------------
+      !!                    ***  SUBROUTINE bdytide_init  ***
+      !!                     
+      !! ** Purpose : - Read in namelist for tides and initialise external
+      !!                tidal harmonics data
+      !!
+      !!----------------------------------------------------------------------
+      !! namelist variables
+      !!-------------------
+      CHARACTER(len=80)                         ::   filtide             !: Filename root for tidal input files
+      LOGICAL                                   ::   ln_bdytide_2ddta    !: If true, read 2d harmonic data
+      LOGICAL                                   ::   ln_bdytide_conj     !: If true, assume complex conjugate tidal data
+      !!
+      INTEGER                                   ::   ib_bdy, itide, ib   !: dummy loop indices
+      INTEGER                                   ::   ii, ij              !: dummy loop indices
+      INTEGER                                   ::   inum, igrd
+      INTEGER, DIMENSION(3)                     ::   ilen0       !: length of boundary data (from OBC arrays)
+      INTEGER, POINTER, DIMENSION(:)            ::   nblen, nblenrim     ! short cuts
+      INTEGER                                   ::   ios                 ! Local integer output status for namelist read
+      CHARACTER(len=80)                         ::   clfile              !: full file name for tidal input file 
+      REAL(wp),ALLOCATABLE, DIMENSION(:,:,:)    ::   dta_read            !: work space to read in tidal harmonics data
+      REAL(wp),ALLOCATABLE, DIMENSION(:,:)      ::   ztr, zti            !:  "     "    "   "   "   "        "      " 
+      !!
+      TYPE(TIDES_DATA),  POINTER                ::   td                  !: local short cut   
+      TYPE(MAP_POINTER), DIMENSION(jpbgrd)      ::   ibmap_ptr           !: array of pointers to nbmap
+      !!
+      NAMELIST/nambdy_tide/filtide, ln_bdytide_2ddta, ln_bdytide_conj
+      !!----------------------------------------------------------------------
+      !
+      IF (nb_bdy>0) THEN
+         IF(lwp) WRITE(numout,*)
+         IF(lwp) WRITE(numout,*) 'bdytide_init : initialization of tidal harmonic forcing at open boundaries'
+         IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~'
+      ENDIF
+
+      REWIND(numnam_cfg)
+
+      DO ib_bdy = 1, nb_bdy
+         IF( nn_dyn2d_dta(ib_bdy) >= 2 ) THEN
+            !
+            td => tides(ib_bdy)
+            nblen => idx_bdy(ib_bdy)%nblen
+            nblenrim => idx_bdy(ib_bdy)%nblenrim
+
+            ! Namelist nambdy_tide : tidal harmonic forcing at open boundaries
+            filtide(:) = ''
+
+            ! Don't REWIND here - may need to read more than one of these namelists. 
+            READ  ( numnam_ref, nambdy_tide, IOSTAT = ios, ERR = 901)
+901         IF( ios /= 0 )   CALL ctl_nam ( ios , 'nambdy_tide in reference namelist', lwp )
+            READ  ( numnam_cfg, nambdy_tide, IOSTAT = ios, ERR = 902 )
+902         IF( ios >  0 )   CALL ctl_nam ( ios , 'nambdy_tide in configuration namelist', lwp )
+            IF(lwm) WRITE ( numond, nambdy_tide )
+            !                                               ! Parameter control and print
+            IF(lwp) WRITE(numout,*) '  '
+            IF(lwp) WRITE(numout,*) '          Namelist nambdy_tide : tidal harmonic forcing at open boundaries'
+            IF(lwp) WRITE(numout,*) '             read tidal data in 2d files: ', ln_bdytide_2ddta
+            IF(lwp) WRITE(numout,*) '             assume complex conjugate   : ', ln_bdytide_conj
+            IF(lwp) WRITE(numout,*) '             Number of tidal components to read: ', nb_harmo
+            IF(lwp) THEN 
+                    WRITE(numout,*) '             Tidal components: ' 
+               DO itide = 1, nb_harmo
+                  WRITE(numout,*)  '                 ', Wave(ntide(itide))%cname_tide 
+               END DO
+            ENDIF 
+            IF(lwp) WRITE(numout,*) ' '
+
+            ! Allocate space for tidal harmonics data - get size from OBC data arrays
+            ! -----------------------------------------------------------------------
+
+            ! JC: If FRS scheme is used, we assume that tidal is needed over the whole
+            ! relaxation area      
+            IF( cn_dyn2d(ib_bdy) == 'frs' ) THEN   ;   ilen0(:) = nblen   (:)
+            ELSE                                   ;   ilen0(:) = nblenrim(:)
+            ENDIF
+
+            ALLOCATE( td%ssh0( ilen0(1), nb_harmo, 2 ) )
+            ALLOCATE( td%ssh ( ilen0(1), nb_harmo, 2 ) )
+
+            ALLOCATE( td%u0( ilen0(2), nb_harmo, 2 ) )
+            ALLOCATE( td%u ( ilen0(2), nb_harmo, 2 ) )
+
+            ALLOCATE( td%v0( ilen0(3), nb_harmo, 2 ) )
+            ALLOCATE( td%v ( ilen0(3), nb_harmo, 2 ) )
+
+            td%ssh0(:,:,:) = 0._wp
+            td%ssh (:,:,:) = 0._wp
+            td%u0  (:,:,:) = 0._wp
+            td%u   (:,:,:) = 0._wp
+            td%v0  (:,:,:) = 0._wp
+            td%v   (:,:,:) = 0._wp
+
+            IF( ln_bdytide_2ddta ) THEN
+               ! It is assumed that each data file contains all complex harmonic amplitudes
+               ! given on the global domain (ie global, jpiglo x jpjglo)
+               !
+               ALLOCATE( zti(jpi,jpj), ztr(jpi,jpj) )
+               !
+               ! SSH fields
+               clfile = TRIM(filtide)//'_grid_T.nc'
+               CALL iom_open( clfile , inum ) 
+               igrd = 1                       ! Everything is at T-points here
+               DO itide = 1, nb_harmo
+                  CALL iom_get( inum, jpdom_autoglo, TRIM(Wave(ntide(itide))%cname_tide)//'_z1', ztr(:,:) )
+                  CALL iom_get( inum, jpdom_autoglo, TRIM(Wave(ntide(itide))%cname_tide)//'_z2', zti(:,:) ) 
+                  DO ib = 1, ilen0(igrd)
+                     ii = idx_bdy(ib_bdy)%nbi(ib,igrd)
+                     ij = idx_bdy(ib_bdy)%nbj(ib,igrd)
+                     td%ssh0(ib,itide,1) = ztr(ii,ij)
+                     td%ssh0(ib,itide,2) = zti(ii,ij)
+                  END DO
+               END DO 
+               CALL iom_close( inum )
+               !
+               ! U fields
+               clfile = TRIM(filtide)//'_grid_U.nc'
+               CALL iom_open( clfile , inum ) 
+               igrd = 2                       ! Everything is at U-points here
+               DO itide = 1, nb_harmo
+                  CALL iom_get  ( inum, jpdom_autoglo, TRIM(Wave(ntide(itide))%cname_tide)//'_u1', ztr(:,:) )
+                  CALL iom_get  ( inum, jpdom_autoglo, TRIM(Wave(ntide(itide))%cname_tide)//'_u2', zti(:,:) )
+                  DO ib = 1, ilen0(igrd)
+                     ii = idx_bdy(ib_bdy)%nbi(ib,igrd)
+                     ij = idx_bdy(ib_bdy)%nbj(ib,igrd)
+                     td%u0(ib,itide,1) = ztr(ii,ij)
+                     td%u0(ib,itide,2) = zti(ii,ij)
+                  END DO
+               END DO
+               CALL iom_close( inum )
+               !
+               ! V fields
+               clfile = TRIM(filtide)//'_grid_V.nc'
+               CALL iom_open( clfile , inum ) 
+               igrd = 3                       ! Everything is at V-points here
+               DO itide = 1, nb_harmo
+                  CALL iom_get  ( inum, jpdom_autoglo, TRIM(Wave(ntide(itide))%cname_tide)//'_v1', ztr(:,:) )
+                  CALL iom_get  ( inum, jpdom_autoglo, TRIM(Wave(ntide(itide))%cname_tide)//'_v2', zti(:,:) )
+                  DO ib = 1, ilen0(igrd)
+                     ii = idx_bdy(ib_bdy)%nbi(ib,igrd)
+                     ij = idx_bdy(ib_bdy)%nbj(ib,igrd)
+                     td%v0(ib,itide,1) = ztr(ii,ij)
+                     td%v0(ib,itide,2) = zti(ii,ij)
+                  END DO
+               END DO  
+               CALL iom_close( inum )
+               !
+               DEALLOCATE( ztr, zti ) 
+               !
+            ELSE            
+               !
+               ! Read tidal data only on bdy segments
+               ! 
+               ALLOCATE( dta_read( MAXVAL(ilen0(1:3)), 1, 1 ) )
+               !
+               ! Set map structure
+               ibmap_ptr(1)%ptr => idx_bdy(ib_bdy)%nbmap(:,1)   ;   ibmap_ptr(1)%ll_unstruc = ln_coords_file(ib_bdy)
+               ibmap_ptr(2)%ptr => idx_bdy(ib_bdy)%nbmap(:,2)   ;   ibmap_ptr(2)%ll_unstruc = ln_coords_file(ib_bdy)
+               ibmap_ptr(3)%ptr => idx_bdy(ib_bdy)%nbmap(:,3)   ;   ibmap_ptr(3)%ll_unstruc = ln_coords_file(ib_bdy)
+
+               ! Open files and read in tidal forcing data
+               ! -----------------------------------------
+
+               DO itide = 1, nb_harmo
+                  !                                                              ! SSH fields
+                  clfile = TRIM(filtide)//TRIM(Wave(ntide(itide))%cname_tide)//'_grid_T.nc'
+                  CALL iom_open( clfile, inum )
+                  CALL fld_map( inum, 'z1' , dta_read(1:ilen0(1),1:1,1:1) , 1,  ibmap_ptr(1) )
+                  td%ssh0(:,itide,1) = dta_read(1:ilen0(1),1,1)
+                  CALL fld_map( inum, 'z2' , dta_read(1:ilen0(1),1:1,1:1) , 1,  ibmap_ptr(1) )
+                  td%ssh0(:,itide,2) = dta_read(1:ilen0(1),1,1)
+                  CALL iom_close( inum )
+                  !                                                              ! U fields
+                  clfile = TRIM(filtide)//TRIM(Wave(ntide(itide))%cname_tide)//'_grid_U.nc'
+                  CALL iom_open( clfile, inum )
+                  CALL fld_map( inum, 'u1' , dta_read(1:ilen0(2),1:1,1:1) , 1, ibmap_ptr(2) )
+                  td%u0(:,itide,1) = dta_read(1:ilen0(2),1,1)
+                  CALL fld_map( inum, 'u2' , dta_read(1:ilen0(2),1:1,1:1) , 1, ibmap_ptr(2) )
+                  td%u0(:,itide,2) = dta_read(1:ilen0(2),1,1)
+                  CALL iom_close( inum )
+                  !                                                              ! V fields
+                  clfile = TRIM(filtide)//TRIM(Wave(ntide(itide))%cname_tide)//'_grid_V.nc'
+                  CALL iom_open( clfile, inum )
+                  CALL fld_map( inum, 'v1' , dta_read(1:ilen0(3),1:1,1:1) , 1, ibmap_ptr(3) )
+                  td%v0(:,itide,1) = dta_read(1:ilen0(3),1,1)
+                  CALL fld_map( inum, 'v2' , dta_read(1:ilen0(3),1:1,1:1) , 1, ibmap_ptr(3) )
+                  td%v0(:,itide,2) = dta_read(1:ilen0(3),1,1)
+                  CALL iom_close( inum )
+                  !
+               END DO ! end loop on tidal components
+               !
+               DEALLOCATE( dta_read )
+               !
+            ENDIF ! ln_bdytide_2ddta=.true.
+            !
+            IF( ln_bdytide_conj ) THEN    ! assume complex conjugate in data files
+               td%ssh0(:,:,2) = - td%ssh0(:,:,2)
+               td%u0  (:,:,2) = - td%u0  (:,:,2)
+               td%v0  (:,:,2) = - td%v0  (:,:,2)
+            ENDIF
+            !
+            ! Allocate slow varying data in the case of time splitting:
+            ! Do it anyway because at this stage knowledge of free surface scheme is unknown
+            ALLOCATE( dta_bdy_s(ib_bdy)%ssh ( ilen0(1) ) )
+            ALLOCATE( dta_bdy_s(ib_bdy)%u2d ( ilen0(2) ) )
+            ALLOCATE( dta_bdy_s(ib_bdy)%v2d ( ilen0(3) ) )
+            dta_bdy_s(ib_bdy)%ssh(:) = 0._wp
+            dta_bdy_s(ib_bdy)%u2d(:) = 0._wp
+            dta_bdy_s(ib_bdy)%v2d(:) = 0._wp
+            !
+         ENDIF ! nn_dyn2d_dta(ib_bdy) >= 2
+         !
+      END DO ! loop on ib_bdy
+      !
+   END SUBROUTINE bdytide_init
+
+
+   SUBROUTINE bdytide_update( kt, idx, dta, td, jit, time_offset )
+      !!----------------------------------------------------------------------
+      !!                 ***  SUBROUTINE bdytide_update  ***
+      !!                
+      !! ** Purpose : - Add tidal forcing to ssh, u2d and v2d OBC data arrays. 
+      !!                
+      !!----------------------------------------------------------------------
+      INTEGER          , INTENT(in   ) ::   kt          ! Main timestep counter
+      TYPE(OBC_INDEX)  , INTENT(in   ) ::   idx         ! OBC indices
+      TYPE(OBC_DATA)   , INTENT(inout) ::   dta         ! OBC external data
+      TYPE(TIDES_DATA) , INTENT(inout) ::   td          ! tidal harmonics data
+      INTEGER, OPTIONAL, INTENT(in   ) ::   jit         ! Barotropic timestep counter (for timesplitting option)
+      INTEGER, OPTIONAL, INTENT(in   ) ::   time_offset ! time offset in units of timesteps. NB. if jit
+      !                                                 ! is present then units = subcycle timesteps.
+      !                                                 ! time_offset = 0  => get data at "now"    time level
+      !                                                 ! time_offset = -1 => get data at "before" time level
+      !                                                 ! time_offset = +1 => get data at "after"  time level
+      !                                                 ! etc.
+      !
+      INTEGER  ::   itide, igrd, ib       ! dummy loop indices
+      INTEGER  ::   time_add              ! time offset in units of timesteps
+      INTEGER, DIMENSION(3) ::   ilen0    ! length of boundary data (from OBC arrays)
+      REAL(wp) ::   z_arg, z_sarg, zflag, zramp   ! local scalars    
+      REAL(wp), DIMENSION(jpmax_harmo) :: z_sist, z_cost
+      !!----------------------------------------------------------------------
+      !
+      ilen0(1) =  SIZE(td%ssh(:,1,1))
+      ilen0(2) =  SIZE(td%u(:,1,1))
+      ilen0(3) =  SIZE(td%v(:,1,1))
+
+      zflag=1
+      IF ( PRESENT(jit) ) THEN
+        IF ( jit /= 1 ) zflag=0
+      ENDIF
+
+      IF ( (nsec_day == NINT(0.5_wp * rdt) .OR. kt==nit000) .AND. zflag==1 ) THEN
+        !
+        kt_tide = kt - (nsec_day - 0.5_wp * rdt)/rdt
+        !
+        IF(lwp) THEN
+           WRITE(numout,*)
+           WRITE(numout,*) 'bdytide_update : (re)Initialization of the tidal bdy forcing at kt=',kt
+           WRITE(numout,*) '~~~~~~~~~~~~~~ '
+        ENDIF
+        !
+        CALL tide_init_elevation ( idx, td )
+        CALL tide_init_velocities( idx, td )
+        !
+      ENDIF 
+
+      time_add = 0
+      IF( PRESENT(time_offset) ) THEN
+         time_add = time_offset
+      ENDIF
+         
+      IF( PRESENT(jit) ) THEN  
+         z_arg = ((kt-kt_tide) * rdt + (jit+0.5_wp*(time_add-1)) * rdt / REAL(nn_baro,wp) )
+      ELSE                              
+         z_arg = ((kt-kt_tide)+time_add) * rdt
+      ENDIF
+
+      ! Linear ramp on tidal component at open boundaries 
+      zramp = 1._wp
+      IF (ln_tide_ramp) zramp = MIN(MAX( (z_arg + (kt_tide-nit000)*rdt)/(rdttideramp*rday),0._wp),1._wp)
+
+      DO itide = 1, nb_harmo
+         z_sarg = z_arg * omega_tide(itide)
+         z_cost(itide) = COS( z_sarg )
+         z_sist(itide) = SIN( z_sarg )
+      END DO
+
+      DO itide = 1, nb_harmo
+         igrd=1                              ! SSH on tracer grid
+         DO ib = 1, ilen0(igrd)
+            dta%ssh(ib) = dta%ssh(ib) + zramp*(td%ssh(ib,itide,1)*z_cost(itide) + td%ssh(ib,itide,2)*z_sist(itide))
+         END DO
+         igrd=2                              ! U grid
+         DO ib = 1, ilen0(igrd)
+            dta%u2d(ib) = dta%u2d(ib) + zramp*(td%u  (ib,itide,1)*z_cost(itide) + td%u  (ib,itide,2)*z_sist(itide))
+         END DO
+         igrd=3                              ! V grid
+         DO ib = 1, ilen0(igrd) 
+            dta%v2d(ib) = dta%v2d(ib) + zramp*(td%v  (ib,itide,1)*z_cost(itide) + td%v  (ib,itide,2)*z_sist(itide))
+         END DO
+      END DO
+      !
+   END SUBROUTINE bdytide_update
+
+
+   SUBROUTINE bdy_dta_tides( kt, kit, time_offset )
+      !!----------------------------------------------------------------------
+      !!                 ***  SUBROUTINE bdy_dta_tides  ***
+      !!                
+      !! ** Purpose : - Add tidal forcing to ssh, u2d and v2d OBC data arrays. 
+      !!                
+      !!----------------------------------------------------------------------
+      INTEGER,           INTENT(in) ::   kt          ! Main timestep counter
+      INTEGER, OPTIONAL, INTENT(in) ::   kit         ! Barotropic timestep counter (for timesplitting option)
+      INTEGER, OPTIONAL, INTENT(in) ::   time_offset ! time offset in units of timesteps. NB. if kit
+      !                                              ! is present then units = subcycle timesteps.
+      !                                              ! time_offset = 0  => get data at "now"    time level
+      !                                              ! time_offset = -1 => get data at "before" time level
+      !                                              ! time_offset = +1 => get data at "after"  time level
+      !                                              ! etc.
+      !
+      LOGICAL  ::   lk_first_btstp            ! =.TRUE. if time splitting and first barotropic step
+      INTEGER  ::   itide, ib_bdy, ib, igrd   ! loop indices
+      INTEGER  ::   time_add                  ! time offset in units of timesteps
+      INTEGER, DIMENSION(jpbgrd)   ::   ilen0 
+      INTEGER, DIMENSION(1:jpbgrd) ::   nblen, nblenrim  ! short cuts
+      REAL(wp) ::   z_arg, z_sarg, zramp, zoff, z_cost, z_sist      
+      !!----------------------------------------------------------------------
+      !
+      lk_first_btstp=.TRUE.
+      IF ( PRESENT(kit).AND.( kit /= 1 ) ) THEN ; lk_first_btstp=.FALSE. ; ENDIF
+
+      time_add = 0
+      IF( PRESENT(time_offset) ) THEN
+         time_add = time_offset
+      ENDIF
+      
+      ! Absolute time from model initialization:   
+      IF( PRESENT(kit) ) THEN  
+         z_arg = ( kt + (kit+time_add-1) / REAL(nn_baro,wp) ) * rdt
+      ELSE                              
+         z_arg = ( kt + time_add ) * rdt
+      ENDIF
+
+      ! Linear ramp on tidal component at open boundaries 
+      zramp = 1.
+      IF (ln_tide_ramp) zramp = MIN(MAX( (z_arg - nit000*rdt)/(rdttideramp*rday),0.),1.)
+
+      DO ib_bdy = 1,nb_bdy
+         !
+         IF( nn_dyn2d_dta(ib_bdy) >= 2 ) THEN
+            !
+            nblen(1:jpbgrd) = idx_bdy(ib_bdy)%nblen(1:jpbgrd)
+            nblenrim(1:jpbgrd) = idx_bdy(ib_bdy)%nblenrim(1:jpbgrd)
+            !
+            IF( cn_dyn2d(ib_bdy) == 'frs' ) THEN   ;   ilen0(:) = nblen   (:)
+            ELSE                                   ;   ilen0(:) = nblenrim(:)
+            ENDIF     
+            !
+            ! We refresh nodal factors every day below
+            ! This should be done somewhere else
+            IF ( ( nsec_day == NINT(0.5_wp * rdt) .OR. kt==nit000 ) .AND. lk_first_btstp ) THEN
+               !
+               kt_tide = kt - (nsec_day - 0.5_wp * rdt)/rdt
+               !
+               IF(lwp) THEN
+               WRITE(numout,*)
+               WRITE(numout,*) 'bdy_tide_dta : Refresh nodal factors for tidal open bdy data at kt=',kt
+               WRITE(numout,*) '~~~~~~~~~~~~~~ '
+               ENDIF
+               !
+               CALL tide_init_elevation ( idx=idx_bdy(ib_bdy), td=tides(ib_bdy) )
+               CALL tide_init_velocities( idx=idx_bdy(ib_bdy), td=tides(ib_bdy) )
+               !
+            ENDIF
+            zoff = -kt_tide * rdt ! time offset relative to nodal factor computation time
+            !
+            ! If time splitting, initialize arrays from slow varying open boundary data:
+            IF ( PRESENT(kit) ) THEN           
+               IF ( dta_bdy(ib_bdy)%ll_ssh ) dta_bdy(ib_bdy)%ssh(1:ilen0(1)) = dta_bdy_s(ib_bdy)%ssh(1:ilen0(1))
+               IF ( dta_bdy(ib_bdy)%ll_u2d ) dta_bdy(ib_bdy)%u2d(1:ilen0(2)) = dta_bdy_s(ib_bdy)%u2d(1:ilen0(2))
+               IF ( dta_bdy(ib_bdy)%ll_v2d ) dta_bdy(ib_bdy)%v2d(1:ilen0(3)) = dta_bdy_s(ib_bdy)%v2d(1:ilen0(3))
+            ENDIF
+            !
+            ! Update open boundary data arrays:
+            DO itide = 1, nb_harmo
+               !
+               z_sarg = (z_arg + zoff) * omega_tide(itide)
+               z_cost = zramp * COS( z_sarg )
+               z_sist = zramp * SIN( z_sarg )
+               !
+               IF ( dta_bdy(ib_bdy)%ll_ssh ) THEN
+                  igrd=1                              ! SSH on tracer grid
+                  DO ib = 1, ilen0(igrd)
+                     dta_bdy(ib_bdy)%ssh(ib) = dta_bdy(ib_bdy)%ssh(ib) + &
+                        &                      ( tides(ib_bdy)%ssh(ib,itide,1)*z_cost + &
+                        &                        tides(ib_bdy)%ssh(ib,itide,2)*z_sist )
+                  END DO
+               ENDIF
+               !
+               IF ( dta_bdy(ib_bdy)%ll_u2d ) THEN
+                  igrd=2                              ! U grid
+                  DO ib = 1, ilen0(igrd)
+                     dta_bdy(ib_bdy)%u2d(ib) = dta_bdy(ib_bdy)%u2d(ib) + &
+                        &                      ( tides(ib_bdy)%u(ib,itide,1)*z_cost + &
+                        &                        tides(ib_bdy)%u(ib,itide,2)*z_sist )
+                  END DO
+               ENDIF
+               !
+               IF ( dta_bdy(ib_bdy)%ll_v2d ) THEN
+                  igrd=3                              ! V grid
+                  DO ib = 1, ilen0(igrd) 
+                     dta_bdy(ib_bdy)%v2d(ib) = dta_bdy(ib_bdy)%v2d(ib) + &
+                        &                      ( tides(ib_bdy)%v(ib,itide,1)*z_cost + &
+                        &                        tides(ib_bdy)%v(ib,itide,2)*z_sist )
+                  END DO
+               ENDIF
+            END DO             
+         END IF
+      END DO
+      !
+   END SUBROUTINE bdy_dta_tides
+
+
+   SUBROUTINE tide_init_elevation( idx, td )
+      !!----------------------------------------------------------------------
+      !!                 ***  ROUTINE tide_init_elevation  ***
+      !!----------------------------------------------------------------------
+      TYPE(OBC_INDEX) , INTENT(in   ) ::   idx   ! OBC indices
+      TYPE(TIDES_DATA), INTENT(inout) ::   td    ! tidal harmonics data
+      !
+      INTEGER ::   itide, igrd, ib       ! dummy loop indices
+      INTEGER, DIMENSION(1) ::   ilen0   ! length of boundary data (from OBC arrays)
+      REAL(wp),ALLOCATABLE, DIMENSION(:) ::   mod_tide, phi_tide
+      !!----------------------------------------------------------------------
+      !
+      igrd=1   
+                              ! SSH on tracer grid.
+      ilen0(1) =  SIZE(td%ssh0(:,1,1))
+      !
+      ALLOCATE( mod_tide(ilen0(igrd)), phi_tide(ilen0(igrd)) )
+      !
+      DO itide = 1, nb_harmo
+         DO ib = 1, ilen0(igrd)
+            mod_tide(ib)=SQRT(td%ssh0(ib,itide,1)**2.+td%ssh0(ib,itide,2)**2.)
+            phi_tide(ib)=ATAN2(-td%ssh0(ib,itide,2),td%ssh0(ib,itide,1))
+         END DO
+         DO ib = 1 , ilen0(igrd)
+            mod_tide(ib)=mod_tide(ib)*ftide(itide)
+            phi_tide(ib)=phi_tide(ib)+v0tide(itide)+utide(itide)
+         ENDDO
+         DO ib = 1 , ilen0(igrd)
+            td%ssh(ib,itide,1)= mod_tide(ib)*COS(phi_tide(ib))
+            td%ssh(ib,itide,2)=-mod_tide(ib)*SIN(phi_tide(ib))
+         ENDDO
+      END DO
+      !
+      DEALLOCATE( mod_tide, phi_tide )
+      !
+   END SUBROUTINE tide_init_elevation
+
+
+   SUBROUTINE tide_init_velocities( idx, td )
+      !!----------------------------------------------------------------------
+      !!                 ***  ROUTINE tide_init_elevation  ***
+      !!----------------------------------------------------------------------
+      TYPE(OBC_INDEX) , INTENT(in   ) ::   idx   ! OBC indices
+      TYPE(TIDES_DATA), INTENT(inout) ::   td    ! tidal harmonics data
+      !
+      INTEGER ::   itide, igrd, ib       ! dummy loop indices
+      INTEGER, DIMENSION(3) ::   ilen0   ! length of boundary data (from OBC arrays)
+      REAL(wp),ALLOCATABLE, DIMENSION(:) ::   mod_tide, phi_tide
+      !!----------------------------------------------------------------------
+      !
+      ilen0(2) =  SIZE(td%u0(:,1,1))
+      ilen0(3) =  SIZE(td%v0(:,1,1))
+      !
+      igrd=2                                 ! U grid.
+      !
+      ALLOCATE( mod_tide(ilen0(igrd)) , phi_tide(ilen0(igrd)) )
+      !
+      DO itide = 1, nb_harmo
+         DO ib = 1, ilen0(igrd)
+            mod_tide(ib)=SQRT(td%u0(ib,itide,1)**2.+td%u0(ib,itide,2)**2.)
+            phi_tide(ib)=ATAN2(-td%u0(ib,itide,2),td%u0(ib,itide,1))
+         END DO
+         DO ib = 1, ilen0(igrd)
+            mod_tide(ib)=mod_tide(ib)*ftide(itide)
+            phi_tide(ib)=phi_tide(ib)+v0tide(itide)+utide(itide)
+         ENDDO
+         DO ib = 1, ilen0(igrd)
+            td%u(ib,itide,1)= mod_tide(ib)*COS(phi_tide(ib))
+            td%u(ib,itide,2)=-mod_tide(ib)*SIN(phi_tide(ib))
+         ENDDO
+      END DO
+      !
+      DEALLOCATE( mod_tide , phi_tide )
+      !
+      igrd=3                                 ! V grid.
+      !
+      ALLOCATE( mod_tide(ilen0(igrd)) , phi_tide(ilen0(igrd)) )
+
+      DO itide = 1, nb_harmo
+         DO ib = 1, ilen0(igrd)
+            mod_tide(ib)=SQRT(td%v0(ib,itide,1)**2.+td%v0(ib,itide,2)**2.)
+            phi_tide(ib)=ATAN2(-td%v0(ib,itide,2),td%v0(ib,itide,1))
+         END DO
+         DO ib = 1, ilen0(igrd)
+            mod_tide(ib)=mod_tide(ib)*ftide(itide)
+            phi_tide(ib)=phi_tide(ib)+v0tide(itide)+utide(itide)
+         ENDDO
+         DO ib = 1, ilen0(igrd)
+            td%v(ib,itide,1)= mod_tide(ib)*COS(phi_tide(ib))
+            td%v(ib,itide,2)=-mod_tide(ib)*SIN(phi_tide(ib))
+         ENDDO
+      END DO
+      !
+      DEALLOCATE( mod_tide, phi_tide )
+      !
+  END SUBROUTINE tide_init_velocities
+
+   !!======================================================================
+END MODULE bdytides
+
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/BDY/bdytra.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/BDY/bdytra.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/BDY/bdytra.F90	(revision 9570)
@@ -0,0 +1,154 @@
+MODULE bdytra
+   !!======================================================================
+   !!                       ***  MODULE  bdytra  ***
+   !! Ocean tracers:   Apply boundary conditions for tracers
+   !!======================================================================
+   !! History :  1.0  !  2005-01  (J. Chanut, A. Sellar)  Original code
+   !!            3.0  !  2008-04  (NEMO team)  add in the reference version
+   !!            3.4  !  2011     (D. Storkey) rewrite in preparation for OBC-BDY merge
+   !!            3.5  !  2012     (S. Mocavero, I. Epicoco) Optimization of BDY communications
+   !!            4.0  !  2016     (T. Lovato) Generalize OBC structure
+   !!----------------------------------------------------------------------
+   !!   bdy_tra       : Apply open boundary conditions & damping to T and S
+   !!----------------------------------------------------------------------
+   USE oce            ! ocean dynamics and tracers variables
+   USE dom_oce        ! ocean space and time domain variables 
+   USE bdy_oce        ! ocean open boundary conditions
+   USE bdylib         ! for orlanski library routines
+   !
+   USE in_out_manager ! I/O manager
+   USE lbclnk         ! ocean lateral boundary conditions (or mpp link)
+   USE timing         ! Timing
+
+   IMPLICIT NONE
+   PRIVATE
+
+   ! Local structure to rearrange tracers data
+   TYPE, PUBLIC ::   ztrabdy
+      REAL(wp), POINTER, DIMENSION(:,:) ::  tra
+   END TYPE
+
+   PUBLIC   bdy_tra      ! called in tranxt.F90 
+   PUBLIC   bdy_tra_dmp  ! called in step.F90 
+
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 4.0, NEMO Consortium (2016)
+   !! $Id$ 
+   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE bdy_tra( kt )
+      !!----------------------------------------------------------------------
+      !!                  ***  SUBROUTINE bdy_tra  ***
+      !!
+      !! ** Purpose : - Apply open boundary conditions for temperature and salinity
+      !!
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT(in) ::   kt   ! Main time step counter
+      !
+      INTEGER                        :: ib_bdy, jn, igrd   ! Loop indeces
+      TYPE(ztrabdy), DIMENSION(jpts) :: zdta               ! Temporary data structure
+      !!----------------------------------------------------------------------
+      igrd = 1 
+
+      DO ib_bdy=1, nb_bdy
+         !
+         zdta(1)%tra => dta_bdy(ib_bdy)%tem
+         zdta(2)%tra => dta_bdy(ib_bdy)%sal
+         !
+         DO jn = 1, jpts
+            !
+            SELECT CASE( TRIM(cn_tra(ib_bdy)) )
+            CASE('none'        )   ;   CYCLE
+            CASE('frs'         )   ;   CALL bdy_frs ( idx_bdy(ib_bdy),                tsa(:,:,:,jn), zdta(jn)%tra )
+            CASE('specified'   )   ;   CALL bdy_spe ( idx_bdy(ib_bdy),                tsa(:,:,:,jn), zdta(jn)%tra )
+            CASE('neumann'     )   ;   CALL bdy_nmn ( idx_bdy(ib_bdy), igrd         , tsa(:,:,:,jn)               )
+            CASE('orlanski'    )   ;   CALL bdy_orl ( idx_bdy(ib_bdy), tsb(:,:,:,jn), tsa(:,:,:,jn), zdta(jn)%tra, ll_npo=.false. )
+            CASE('orlanski_npo')   ;   CALL bdy_orl ( idx_bdy(ib_bdy), tsb(:,:,:,jn), tsa(:,:,:,jn), zdta(jn)%tra, ll_npo=.true. )
+            CASE('runoff'      )   ;   CALL bdy_rnf ( idx_bdy(ib_bdy),                tsa(:,:,:,jn),               jn )
+            CASE DEFAULT           ;   CALL ctl_stop( 'bdy_tra : unrecognised option for open boundaries for T and S' )
+            END SELECT
+            ! Boundary points should be updated
+            CALL lbc_bdy_lnk( tsa(:,:,:,jn), 'T', 1., ib_bdy )
+            ! 
+         END DO
+      END DO
+      !
+   END SUBROUTINE bdy_tra
+
+
+   SUBROUTINE bdy_rnf( idx, pta, jpa )
+      !!----------------------------------------------------------------------
+      !!                 ***  SUBROUTINE bdy_rnf  ***
+      !!                    
+      !! ** Purpose : Specialized routine to apply TRA runoff values at OBs:
+      !!                  - duplicate the neighbour value for the temperature
+      !!                  - specified to 0.1 PSU for the salinity
+      !! 
+      !!----------------------------------------------------------------------
+      TYPE(OBC_INDEX),                     INTENT(in) ::   idx  ! OBC indices
+      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pta  ! tracer trend
+      INTEGER,                             INTENT(in) ::   jpa  ! TRA index
+      !
+      REAL(wp) ::   zwgt           ! boundary weight
+      INTEGER  ::   ib, ik, igrd   ! dummy loop indices
+      INTEGER  ::   ii, ij, ip, jp ! 2D addresses
+      !!----------------------------------------------------------------------
+      !
+      igrd = 1                       ! Everything is at T-points here
+      DO ib = 1, idx%nblenrim(igrd)
+         ii = idx%nbi(ib,igrd)
+         ij = idx%nbj(ib,igrd)
+         DO ik = 1, jpkm1
+            ip = bdytmask(ii+1,ij  ) - bdytmask(ii-1,ij  )
+            jp = bdytmask(ii  ,ij+1) - bdytmask(ii  ,ij-1)
+            if (jpa == jp_tem) pta(ii,ij,ik) = pta(ii+ip,ij+jp,ik) * tmask(ii,ij,ik)
+            if (jpa == jp_sal) pta(ii,ij,ik) =                 0.1 * tmask(ii,ij,ik)
+         END DO
+      END DO
+      !
+   END SUBROUTINE bdy_rnf
+
+
+   SUBROUTINE bdy_tra_dmp( kt )
+      !!----------------------------------------------------------------------
+      !!                 ***  SUBROUTINE bdy_tra_dmp  ***
+      !!                    
+      !! ** Purpose : Apply damping for tracers at open boundaries.
+      !! 
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT(in) ::   kt   !
+      !
+      REAL(wp) ::   zwgt           ! boundary weight
+      REAL(wp) ::   zta, zsa, ztime
+      INTEGER  ::   ib, ik, igrd   ! dummy loop indices
+      INTEGER  ::   ii, ij         ! 2D addresses
+      INTEGER  ::   ib_bdy         ! Loop index
+      !!----------------------------------------------------------------------
+      !
+      IF( ln_timing )   CALL timing_start('bdy_tra_dmp')
+      !
+      DO ib_bdy = 1, nb_bdy
+         IF( ln_tra_dmp(ib_bdy) ) THEN
+            igrd = 1                       ! Everything is at T-points here
+            DO ib = 1, idx_bdy(ib_bdy)%nblen(igrd)
+               ii = idx_bdy(ib_bdy)%nbi(ib,igrd)
+               ij = idx_bdy(ib_bdy)%nbj(ib,igrd)
+               zwgt = idx_bdy(ib_bdy)%nbd(ib,igrd)
+               DO ik = 1, jpkm1
+                  zta = zwgt * ( dta_bdy(ib_bdy)%tem(ib,ik) - tsb(ii,ij,ik,jp_tem) ) * tmask(ii,ij,ik)
+                  zsa = zwgt * ( dta_bdy(ib_bdy)%sal(ib,ik) - tsb(ii,ij,ik,jp_sal) ) * tmask(ii,ij,ik)
+                  tsa(ii,ij,ik,jp_tem) = tsa(ii,ij,ik,jp_tem) + zta
+                  tsa(ii,ij,ik,jp_sal) = tsa(ii,ij,ik,jp_sal) + zsa
+               END DO
+            END DO
+         ENDIF
+      END DO
+      !
+      IF( ln_timing )   CALL timing_stop('bdy_tra_dmp')
+      !
+   END SUBROUTINE bdy_tra_dmp
+ 
+   !!======================================================================
+END MODULE bdytra
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/BDY/bdyvol.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/BDY/bdyvol.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/BDY/bdyvol.F90	(revision 9570)
@@ -0,0 +1,169 @@
+MODULE bdyvol
+   !!======================================================================
+   !!                       ***  MODULE  bdyvol  ***
+   !! Ocean dynamic :  Volume constraint when unstructured boundary 
+   !!                  and filtered free surface are used
+   !!======================================================================
+   !! History :  1.0  !  2005-01  (J. Chanut, A. Sellar)  Original code
+   !!             -   !  2006-01  (J. Chanut) Bug correction
+   !!            3.0  !  2008-04  (NEMO team)  add in the reference version
+   !!            3.4  !  2011     (D. Storkey) rewrite in preparation for OBC-BDY merge
+   !!----------------------------------------------------------------------
+   USE oce            ! ocean dynamics and tracers 
+   USE bdy_oce        ! ocean open boundary conditions
+   USE sbc_oce        ! ocean surface boundary conditions
+   USE dom_oce        ! ocean space and time domain 
+   USE phycst         ! physical constants
+   USE sbcisf         ! ice shelf
+   !
+   USE in_out_manager ! I/O manager
+   USE lib_mpp        ! for mppsum
+   USE lib_fortran    ! Fortran routines library
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   bdy_vol    ! called by ???
+
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.7 , NEMO Consortium (2015)
+   !! $Id$ 
+   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE bdy_vol( kt )
+      !!----------------------------------------------------------------------
+      !!                      ***  ROUTINE bdyvol  ***
+      !!
+      !! ** Purpose :   This routine controls the volume of the system. 
+      !!      A correction velocity is calculated to correct the total transport 
+      !!      through the unstructured OBC. 
+      !!      The total depth used is constant (H0) to be consistent with the 
+      !!      linear free surface coded in OPA 8.2    <<<=== !!gm  ???? true ????
+      !!
+      !! ** Method  :   The correction velocity (zubtpecor here) is defined calculating
+      !!      the total transport through all open boundaries (trans_bdy) minus
+      !!      the cumulate E-P flux (z_cflxemp) divided by the total lateral 
+      !!      surface (bdysurftot) of the unstructured boundary. 
+      !!         zubtpecor = [trans_bdy - z_cflxemp ]*(1./bdysurftot)
+      !!      with z_cflxemp => sum of (Evaporation minus Precipitation)
+      !!                       over all the domain in m3/s at each time step.
+      !!      z_cflxemp < 0 when precipitation dominate
+      !!      z_cflxemp > 0 when evaporation dominate
+      !!
+      !!      There are 2 options (user's desiderata): 
+      !!         1/ The volume changes according to E-P, this is the default
+      !!            option. In this case the cumulate E-P flux are setting to
+      !!            zero (z_cflxemp=0) to calculate the correction velocity. So
+      !!            it will only balance the flux through open boundaries.
+      !!            (set nn_volctl to 0 in tne namelist for this option)
+      !!         2/ The volume is constant even with E-P flux. In this case
+      !!            the correction velocity must balance both the flux 
+      !!            through open boundaries and the ones through the free
+      !!            surface. 
+      !!            (set nn_volctl to 1 in tne namelist for this option)
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT(in) ::   kt   ! ocean time-step index
+      !
+      INTEGER  ::   ji, jj, jk, jb, jgrd
+      INTEGER  ::   ib_bdy, ii, ij
+      REAL(wp) ::   zubtpecor, z_cflxemp, ztranst
+      TYPE(OBC_INDEX), POINTER :: idx
+      !!-----------------------------------------------------------------------------
+      !
+      IF( ln_vol ) THEN
+      !
+      IF( kt == nit000 ) THEN 
+         IF(lwp) WRITE(numout,*)
+         IF(lwp) WRITE(numout,*)'bdy_vol : Correction of velocities along unstructured OBC'
+         IF(lwp) WRITE(numout,*)'~~~~~~~'
+      END IF 
+
+      ! Calculate the cumulate surface Flux z_cflxemp (m3/s) over all the domain
+      ! -----------------------------------------------------------------------
+!!gm replace these lines :
+      z_cflxemp = SUM ( ( emp(:,:) - rnf(:,:) + fwfisf(:,:) ) * bdytmask(:,:) * e1e2t(:,:) ) / rau0
+      IF( lk_mpp )   CALL mpp_sum( z_cflxemp )     ! sum over the global domain
+!!gm   by :
+!!gm      z_cflxemp = glob_sum(  ( emp(:,:)-rnf(:,:)+fwfisf(:,:) ) * bdytmask(:,:) * e1e2t(:,:)  ) / rau0
+!!gm
+
+      ! Transport through the unstructured open boundary
+      ! ------------------------------------------------
+      zubtpecor = 0._wp
+      DO ib_bdy = 1, nb_bdy
+         idx => idx_bdy(ib_bdy)
+         !
+         jgrd = 2                               ! cumulate u component contribution first 
+         DO jb = 1, idx%nblenrim(jgrd)
+            DO jk = 1, jpkm1
+               ii = idx%nbi(jb,jgrd)
+               ij = idx%nbj(jb,jgrd)
+               zubtpecor = zubtpecor + idx%flagu(jb,jgrd) * ua(ii,ij, jk) * e2u(ii,ij) * e3u_n(ii,ij,jk)
+            END DO
+         END DO
+         jgrd = 3                               ! then add v component contribution
+         DO jb = 1, idx%nblenrim(jgrd)
+            DO jk = 1, jpkm1
+               ii = idx%nbi(jb,jgrd)
+               ij = idx%nbj(jb,jgrd)
+               zubtpecor = zubtpecor + idx%flagv(jb,jgrd) * va(ii,ij, jk) * e1v(ii,ij) * e3v_n(ii,ij,jk) 
+            END DO
+         END DO
+         !
+      END DO
+      IF( lk_mpp )   CALL mpp_sum( zubtpecor )   ! sum over the global domain
+
+      ! The normal velocity correction
+      ! ------------------------------
+      IF( nn_volctl==1 ) THEN   ;   zubtpecor = ( zubtpecor - z_cflxemp ) / bdysurftot 
+      ELSE                      ;   zubtpecor =   zubtpecor               / bdysurftot
+      END IF
+
+      ! Correction of the total velocity on the unstructured boundary to respect the mass flux conservation
+      ! -------------------------------------------------------------
+      ztranst = 0._wp
+      DO ib_bdy = 1, nb_bdy
+         idx => idx_bdy(ib_bdy)
+         !
+         jgrd = 2                               ! correct u component
+         DO jb = 1, idx%nblenrim(jgrd)
+            DO jk = 1, jpkm1
+               ii = idx%nbi(jb,jgrd)
+               ij = idx%nbj(jb,jgrd)
+               ua(ii,ij,jk) = ua(ii,ij,jk) - idx%flagu(jb,jgrd) * zubtpecor * umask(ii,ij,jk)
+               ztranst = ztranst + idx%flagu(jb,jgrd) * ua(ii,ij,jk) * e2u(ii,ij) * e3u_n(ii,ij,jk)
+            END DO
+         END DO
+         jgrd = 3                              ! correct v component
+         DO jb = 1, idx%nblenrim(jgrd)
+            DO jk = 1, jpkm1
+               ii = idx%nbi(jb,jgrd)
+               ij = idx%nbj(jb,jgrd)
+               va(ii,ij,jk) = va(ii,ij,jk) -idx%flagv(jb,jgrd) * zubtpecor * vmask(ii,ij,jk)
+               ztranst = ztranst + idx%flagv(jb,jgrd) * va(ii,ij,jk) * e1v(ii,ij) * e3v_n(ii,ij,jk)
+            END DO
+         END DO
+         !
+      END DO
+      IF( lk_mpp )   CALL mpp_sum( ztranst )   ! sum over the global domain
+ 
+      ! Check the cumulated transport through unstructured OBC once barotropic velocities corrected
+      ! ------------------------------------------------------
+      IF( lwp .AND. MOD( kt, nwrite ) == 0 ) THEN
+         IF(lwp) WRITE(numout,*)
+         IF(lwp) WRITE(numout,*)'bdy_vol : time step :', kt
+         IF(lwp) WRITE(numout,*)'~~~~~~~ '
+         IF(lwp) WRITE(numout,*)'          cumulate flux EMP             =', z_cflxemp  , ' (m3/s)'
+         IF(lwp) WRITE(numout,*)'          total lateral surface of OBC  =', bdysurftot, '(m2)'
+         IF(lwp) WRITE(numout,*)'          correction velocity zubtpecor =', zubtpecor , '(m/s)'
+         IF(lwp) WRITE(numout,*)'          cumulated transport ztranst   =', ztranst   , '(m3/s)'
+      END IF 
+      !
+      END IF ! ln_vol
+      !
+   END SUBROUTINE bdy_vol
+
+   !!======================================================================
+END MODULE bdyvol
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/C1D/c1d.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/C1D/c1d.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/C1D/c1d.F90	(revision 9570)
@@ -0,0 +1,87 @@
+MODULE c1d
+   !!======================================================================
+   !!                     ***  MODULE  c1d  ***
+   !! Ocean domain  :  1D configuration
+   !!=====================================================================
+   !! History :  2.0  !  2004-09 (C. Ethe)     Original code
+   !!            3.0  !  2008-04 (G. Madec)    adaptation to SBC
+   !!            3.5  !  2013-10 (D. Calvert)  add namelist
+   !!----------------------------------------------------------------------
+#if defined key_c1d
+   !!----------------------------------------------------------------------
+   !!   'key_c1d'                                   1D column configuration
+   !!----------------------------------------------------------------------
+   !!   c1d_init      : read in the C1D namelist
+   !!----------------------------------------------------------------------
+   USE par_kind       ! kind parameters
+   !
+   USE in_out_manager ! I/O manager
+   USE lib_mpp        ! MPP library
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   c1d_init   ! called by nemogcm.F90
+
+   LOGICAL , PUBLIC, PARAMETER ::  lk_c1d = .TRUE.   ! 1D config. flag
+
+   REAL(wp), PUBLIC ::  rn_lat1d     !: Column latitude
+   REAL(wp), PUBLIC ::  rn_lon1d     !: Column longitude
+   LOGICAL , PUBLIC ::  ln_c1d_locpt !: Localization (or not) of 1D column in a grid
+
+   !!----------------------------------------------------------------------
+   !! NEMO/C1D 3.7 , NEMO Consortium (2015)
+   !! $Id$ 
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!======================================================================
+CONTAINS
+
+   SUBROUTINE c1d_init
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE c1d_init  ***
+      !! 
+      !! ** Purpose :   Initialization of C1D options
+      !!
+      !! ** Method  :   Read namelist namc1d 
+      !!----------------------------------------------------------------------
+      INTEGER ::   ios   ! Local integer
+      !!
+      NAMELIST/namc1d/ rn_lat1d, rn_lon1d , ln_c1d_locpt
+      !!----------------------------------------------------------------------
+      !
+      REWIND( numnam_ref )              ! Namelist namc1d in reference namelist : Tracer advection scheme
+      READ  ( numnam_ref, namc1d, IOSTAT = ios, ERR = 901)
+901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namc1d in reference namelist', lwp )
+      !
+      REWIND( numnam_cfg )              ! Namelist namtra_adv in configuration namelist : Tracer advection scheme
+      READ  ( numnam_cfg, namc1d, IOSTAT = ios, ERR = 902 )
+902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namc1d in configuration namelist', lwp )
+      IF(lwm) WRITE ( numond, namc1d )
+      !
+      IF(lwp) THEN                    ! Control print
+         WRITE(numout,*)
+         WRITE(numout,*) 'c1d_init : Initialize 1D model configuration options'
+         WRITE(numout,*) '~~~~~~~~'
+         WRITE(numout,*) '   Namelist namc1d : set options for the C1D model'
+         WRITE(numout,*) '      column latitude                 rn_lat1d     = ', rn_lat1d
+         WRITE(numout,*) '      column longitude                rn_lon1d     = ', rn_lon1d
+         WRITE(numout,*) '      column localization in a grid   ln_c1d_locpt = ', ln_c1d_locpt
+      ENDIF
+      !
+   END SUBROUTINE c1d_init
+
+#else
+   !!----------------------------------------------------------------------
+   !!   Dummy module :                           No use of 1D configuration
+   !!----------------------------------------------------------------------
+   USE par_kind         ! kind parameters
+   LOGICAL, PUBLIC, PARAMETER ::   lk_c1d = .FALSE.   !: 1D config. flag de-activated
+   REAL(wp)                   ::   rn_lat1d, rn_lon1d
+   LOGICAL , PUBLIC           ::   ln_c1d_locpt = .FALSE. 
+CONTAINS
+   SUBROUTINE c1d_init               ! Dummy routine
+   END SUBROUTINE c1d_init
+#endif
+
+   !!======================================================================
+END MODULE c1d
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/C1D/domc1d.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/C1D/domc1d.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/C1D/domc1d.F90	(revision 9570)
@@ -0,0 +1,206 @@
+MODULE domc1d
+   !!======================================================================
+   !!                     ***  MODULE  domc1d  ***
+   !! Ocean Domain : 1D column position from lat/lon namelist specification
+   !!======================================================================
+   !! History :  3.5  !  2013-04  (D. Calvert)  Original code
+   !!----------------------------------------------------------------------
+#if defined key_c1d
+   !!----------------------------------------------------------------------
+   !!   'key_c1d'   :                                      1D Configuration
+   !!----------------------------------------------------------------------
+   !!   dom_c1d     : Determine jpizoom/jpjzoom from a given lat/lon
+   !!----------------------------------------------------------------------
+   USE phycst         ! Physical constants (and par_oce)
+   USE dom_oce , ONLY : nimpp, njmpp ! Shared/distributed memory setting
+   !
+   USE iom            ! I/O library (iom_get)
+   USE in_out_manager ! I/O manager (ctmp1)
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   dom_c1d   ! called in domcfg.F90
+
+   INTEGER ::   jpizoom = 1      !: left bottom (i,j) indices of the zoom
+   INTEGER ::   jpjzoom = 1      !: in data domain indices
+
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.7 , NEMO Consortium (2015)
+   !! $Id$ 
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+   
+   SUBROUTINE dom_c1d( plat, plon )
+      !!----------------------------------------------------------------------
+      !!                   ***  ROUTINE dom_c1d  ***
+      !! 
+      !! ** Purpose : Recalculate jpizoom/jpjzoom indices from lat/lon point
+      !!
+      !! ** Method  : Calculate global gphit and glamt as for dom_hgr.
+      !!              After, find closest grid point to lat/lon point as for 
+      !!              dom_ngb on T grid. From this infer jpizoom and jpjzoom.
+      !!
+      !! ** Action  : Recalculate jpizoom, jpjzoom (indices of C1D zoom)
+      !!----------------------------------------------------------------------
+      REAL(wp), INTENT(in) ::  plat, plon    ! Column latitude &  longitude
+      !
+      INTEGER  ::  ji, jj   ! Dummy loop indices
+      INTEGER  ::  inum     ! Coordinate file handle (case 0)
+      INTEGER  ::  ijeq     ! Index of equator T point (case 4)
+      INTEGER  ::  ios      ! Local integer output status for namelist read
+      INTEGER , DIMENSION(2) ::   iloc   ! Minloc returned indices
+      REAL(wp) ::  zlon                            ! Wraparound longitude
+      REAL(wp) ::  zti, ztj, zarg                  ! Local scalars
+      REAL(wp) ::  glam0, gphi0                    ! Variables corresponding to parameters ppglam0 ppgphi0 set in par_oce
+      REAL(wp) ::  zlam1, zcos_alpha, ze1, ze1deg  ! Case 5 local scalars
+      REAL(wp) ::  zphi1, zsin_alpha, zim05, zjm05 !          
+      REAL(wp) , DIMENSION(jpidta,jpjdta) ::  gphidta, glamdta, zdist ! Global lat/lon
+      !!
+      NAMELIST/namdom/ nn_bathy, rn_bathy , rn_e3zps_min, rn_e3zps_rat, ln_meshmask, rn_hmin,   &
+         &             rn_atfp     , rn_rdt , ln_crs,  jphgr_msh, &
+         &             ppglam0, ppgphi0, ppe1_deg, ppe2_deg, ppe1_m, ppe2_m, &
+         &             ppsur, ppa0, ppa1, ppkth, ppacr, ppdzmin, pphmax, ldbletanh, &
+         &             ppa2, ppkth2, ppacr2
+      !!----------------------------------------------------------------------
+
+      REWIND( numnam_ref )              ! Namelist namdom in reference namelist : space & time domain (bathymetry, mesh, timestep)
+      READ  ( numnam_ref, namdom, IOSTAT = ios, ERR = 901 )
+901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namdom in reference namelist', lwp )
+      REWIND( numnam_cfg )              ! Namelist namdom in configuration namelist : space & time domain (bathymetry, mesh, timestep)
+      READ  ( numnam_cfg, namdom, IOSTAT = ios, ERR = 902 )
+902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namdom in configuration namelist', lwp )
+
+
+      ! ============================= !
+      !  Code from dom_hgr:           !
+      !  Calculate global horizontal  !
+      !  mesh, only glamt and gphit   !
+      ! ============================= !
+      !
+      SELECT CASE( jphgr_msh )   ! type of horizontal mesh
+      !
+      CASE ( 0 )                 !  curvilinear coordinate on the sphere read in coordinate.nc file
+         !
+         CALL iom_open( 'coordinates', inum )
+         CALL iom_get( inum, jpdom_unknown, 'glamt', glamdta ) ! mig, mjg undefined at this point
+         CALL iom_get( inum, jpdom_unknown, 'gphit', gphidta ) ! so use jpdom_unknown not jpdom_data
+         CALL iom_close ( inum )
+         !
+      CASE ( 1 )                 ! geographical mesh on the sphere with regular grid-spacing
+         !
+         DO jj = 1, jpjdta
+            DO ji = 1, jpidta
+               zti = FLOAT( ji - 1 + nimpp - 1 )
+               ztj = FLOAT( jj - 1 + njmpp - 1 )
+               !
+               glamdta(ji,jj) = ppglam0 + ppe1_deg * zti
+               gphidta(ji,jj) = ppgphi0 + ppe2_deg * ztj
+            END DO
+         END DO
+         !
+      CASE ( 2:3 )               ! f- or beta-plane with regular grid-spacing
+         !
+         glam0 = 0.e0
+         gphi0 = - ppe2_m * 1.e-3
+         !
+         DO jj = 1, jpjdta
+            DO ji = 1, jpidta
+               glamdta(ji,jj) = glam0 + ppe1_m * 1.e-3 * FLOAT( ji - 1 + nimpp - 1 )
+               gphidta(ji,jj) = gphi0 + ppe2_m * 1.e-3 * FLOAT( jj - 1 + njmpp - 1 )
+            END DO
+         END DO
+         !
+      CASE ( 4 )                 ! geographical mesh on the sphere, isotropic MERCATOR type
+         !
+         IF( ppgphi0 == -90 )   CALL ctl_stop( ' Mercator grid cannot start at south pole !!!! ' )
+         !
+         zarg = rpi / 4. - rpi / 180. * ppgphi0 / 2.
+         ijeq = ABS( 180. / rpi * LOG( COS( zarg ) / SIN( zarg ) ) / ppe1_deg )
+         IF( ppgphi0 > 0 )   ijeq = -ijeq
+         !
+         DO jj = 1, jpjdta
+            DO ji = 1, jpidta
+               zti = FLOAT( ji - 1    + nimpp - 1 )
+               ztj = FLOAT( jj - ijeq + njmpp - 1 )
+               !
+               glamdta(ji,jj) = ppglam0 + ppe1_deg * zti
+               gphidta(ji,jj) = 1. / rad * ASIN ( TANH( ppe1_deg * rad * ztj ) )
+            END DO
+         END DO
+         !
+      CASE ( 5 )                 ! beta-plane with regular grid-spacing and rotated domain (GYRE configuration)
+         !
+         zlam1 = -85
+         zphi1 = 29
+         ze1 = 106000. / REAL( nn_cfg , wp )
+         !
+         zsin_alpha = - SQRT( 2. ) / 2.
+         zcos_alpha =   SQRT( 2. ) / 2.
+         ze1deg = ze1 / (ra * rad)
+         !
+         glam0 = zlam1 + zcos_alpha * ze1deg * FLOAT( jpjdta-2 ) ! Force global
+         gphi0 = zphi1 + zsin_alpha * ze1deg * FLOAT( jpjdta-2 )
+         !
+         DO jj = 1, jpjdta
+            DO ji = 1, jpidta
+               zim05 = FLOAT( ji + nimpp - 1 ) - 1.5
+               zjm05 = FLOAT( jj + njmpp - 1 ) - 1.5
+
+               glamdta(ji,jj) = glam0 + zim05 * ze1deg * zcos_alpha + zjm05 * ze1deg * zsin_alpha
+               gphidta(ji,jj) = gphi0 - zim05 * ze1deg * zsin_alpha + zjm05 * ze1deg * zcos_alpha
+            END DO
+         END DO
+         !
+      CASE DEFAULT
+         !
+         WRITE(ctmp1,*) '          bad flag value for jphgr_msh = ', jphgr_msh
+         CALL ctl_stop( ctmp1 )
+         !
+      END SELECT
+
+      ! ============================== !
+      !  Code from dom_ngb:            !
+      !  Calculate the nearest grid    !
+      !  point to the given lat/lon &  !
+      !  update jpizoom and jpjzoom    !
+      ! ============================== !
+
+      zlon         = MOD( plon         + 720., 360. )                                      ! plon    between    0 and 360
+      glamdta(:,:) = MOD( glamdta(:,:) + 720., 360. )                                      ! glamdta between    0 and 360
+      IF( zlon > 270. )   zlon = zlon - 360.                                               ! zlon    between  -90 and 270
+      IF( zlon <  90. )   WHERE( glamdta(:,:) > 180. ) glamdta(:,:) = glamdta(:,:) - 360.  ! glamdta between -180 and 180
+
+      glamdta(:,:) = glamdta(:,:) - zlon
+      gphidta(:,:) = gphidta(:,:) - plat
+      zdist(:,:)   = glamdta(:,:) * glamdta(:,:) + gphidta(:,:) * gphidta(:,:)
+      
+      iloc(:) = MINLOC( zdist(:,:) ) ! No mask; zoom indices freely defined
+      jpizoom = iloc(1) + nimpp - 2  ! Minloc index - 1; want the bottom-left
+      jpjzoom = iloc(2) + njmpp - 2  ! corner index of the zoom domain.
+
+      IF(lwp) THEN
+         WRITE(numout,*)
+         WRITE(numout,*) 'dom_c1d : compute jpizoom & jpjzoom from global mesh and given coordinates'
+         WRITE(numout,*) '~~~~~~~'
+         WRITE(numout,*) '      column i zoom index             jpizoom = ', jpizoom
+         WRITE(numout,*) '      column j zoom index             jpjzoom = ', jpjzoom
+         WRITE(numout,*)
+      ENDIF
+      !
+   END SUBROUTINE dom_c1d
+
+#else
+   !!----------------------------------------------------------------------
+   !!   Default option                                  NO 1D Configuration
+   !!----------------------------------------------------------------------
+CONTAINS  
+   SUBROUTINE dom_c1d( plat, plon )     ! Empty routine
+      REAL :: plat, plon
+      WRITE(*,*) 'dom_c1d: You should not have seen this print! error?',plat,plon
+   END SUBROUTINE dom_c1d
+#endif
+
+   !!======================================================================
+END MODULE domc1d
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/C1D/dtauvd.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/C1D/dtauvd.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/C1D/dtauvd.F90	(revision 9570)
@@ -0,0 +1,225 @@
+MODULE dtauvd
+   !!======================================================================
+   !!                     ***  MODULE  dtauvd  ***
+   !! Ocean data  :  read ocean U & V current data from gridded data
+   !!======================================================================
+   !! History :  3.5  ! 2013-08  (D. Calvert)  Original code
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   dta_uvd_init  : read namelist and allocate data structures
+   !!   dta_uvd       : read and time-interpolate ocean U & V current data
+   !!----------------------------------------------------------------------
+   USE oce            ! ocean dynamics and tracers
+   USE phycst         ! physical constants
+   USE dom_oce        ! ocean space and time domain
+   !
+   USE in_out_manager ! I/O manager
+   USE fldread        ! read input fields
+   USE lib_mpp        ! MPP library
+   USE timing         ! Timing
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   dta_uvd_init   ! called by nemogcm.F90
+   PUBLIC   dta_uvd        ! called by istate.F90 and dyndmp.90
+
+   LOGICAL , PUBLIC ::   ln_uvd_init     ! Flag to initialise with U & V current data
+   LOGICAL , PUBLIC ::   ln_uvd_dyndmp   ! Flag for Newtonian damping toward U & V current data
+
+   TYPE(FLD), ALLOCATABLE, DIMENSION(:) ::   sf_uvd   ! structure for input U & V current (file information and data)
+
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.7 , NEMO Consortium (2015)
+   !! $Id$ 
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE dta_uvd_init( ld_dyndmp )
+      !!----------------------------------------------------------------------
+      !!                   ***  ROUTINE dta_uvd_init  ***
+      !!                    
+      !! ** Purpose :   initialization of U & V current input data 
+      !! 
+      !! ** Method  : - read namc1d_uvd namelist
+      !!              - allocate U & V current data structure
+      !!              - fld_fill data structure with namelist information
+      !!----------------------------------------------------------------------
+      LOGICAL, INTENT(in), OPTIONAL ::   ld_dyndmp   ! force the initialization when dyndmp is used
+      !
+      INTEGER ::   ios, ierr0, ierr1, ierr2, ierr3     ! local integers
+      CHARACTER(len=100)        ::   cn_dir            ! Root directory for location of files to be used
+      TYPE(FLD_N), DIMENSION(2) ::   suv_i             ! Combined U & V namelist information
+      TYPE(FLD_N)               ::   sn_ucur, sn_vcur  ! U & V data namelist information
+      !!
+      NAMELIST/namc1d_uvd/ ln_uvd_init, ln_uvd_dyndmp, cn_dir, sn_ucur, sn_vcur
+      !!----------------------------------------------------------------------
+      !
+      ierr0 = 0   ;   ierr1 = 0   ;   ierr2 = 0  ;   ierr3 = 0
+
+      REWIND( numnam_ref )              ! Namelist namc1d_uvd in reference namelist : 
+      READ  ( numnam_ref, namc1d_uvd, IOSTAT = ios, ERR = 901)
+901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namc1d_uvd in reference namelist', lwp )
+      !
+      REWIND( numnam_cfg )              ! Namelist namc1d_uvd in configuration namelist : Parameters of the run
+      READ  ( numnam_cfg, namc1d_uvd, IOSTAT = ios, ERR = 902 )
+902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namc1d_uvd in configuration namelist', lwp )
+      IF(lwm) WRITE ( numond, namc1d_uvd )
+
+      !                             ! force the initialization when dyndmp is used
+      IF( PRESENT( ld_dyndmp ) )   ln_uvd_dyndmp = .TRUE.
+      
+      IF(lwp) THEN                  ! control print
+         WRITE(numout,*)
+         WRITE(numout,*) 'dta_uvd_init : U & V current data '
+         WRITE(numout,*) '~~~~~~~~~~~~ '
+         WRITE(numout,*) '   Namelist namc1d_uvd : Set flags'
+         WRITE(numout,*) '      Initialization of ocean U & V current with input data   ln_uvd_init   = ', ln_uvd_init
+         WRITE(numout,*) '      Damping of ocean U & V current toward input data        ln_uvd_dyndmp = ', ln_uvd_dyndmp
+         WRITE(numout,*)
+         IF( .NOT. ln_uvd_init .AND. .NOT. ln_uvd_dyndmp ) THEN
+            WRITE(numout,*)
+            WRITE(numout,*) '   U & V current data not used'
+         ENDIF
+      ENDIF
+      !                             ! no initialization when restarting
+      IF( ln_rstart .AND. ln_uvd_init ) THEN
+         CALL ctl_warn( 'dta_uvd_init: ocean restart and U & V current data initialization, ',   &
+            &           'we keep the restart U & V current values and set ln_uvd_init to FALSE' )
+         ln_uvd_init = .FALSE.
+      ENDIF
+
+      !
+      IF(  ln_uvd_init .OR. ln_uvd_dyndmp  ) THEN
+         !                          !==   allocate the data arrays   ==!
+         ALLOCATE( sf_uvd(2), STAT=ierr0 )
+         IF( ierr0 > 0 ) THEN
+            CALL ctl_stop( 'dta_uvd_init: unable to allocate sf_uvd structure' )             ;   RETURN
+         ENDIF
+         !
+                                 ALLOCATE( sf_uvd(1)%fnow(jpi,jpj,jpk)   , STAT=ierr0 )
+         IF( sn_ucur%ln_tint )   ALLOCATE( sf_uvd(1)%fdta(jpi,jpj,jpk,2) , STAT=ierr1 )
+                                 ALLOCATE( sf_uvd(2)%fnow(jpi,jpj,jpk)   , STAT=ierr2 )
+         IF( sn_vcur%ln_tint )   ALLOCATE( sf_uvd(2)%fdta(jpi,jpj,jpk,2) , STAT=ierr3 )
+         !
+         IF( ierr0 + ierr1 + ierr2 + ierr3 > 0 ) THEN
+            CALL ctl_stop( 'dta_uvd_init : unable to allocate U & V current data arrays' )   ;   RETURN
+         ENDIF
+         !                          !==   fill sf_uvd with sn_ucur, sn_vcur and control print   ==!
+         suv_i(1) = sn_ucur   ;   suv_i(2) = sn_vcur
+         CALL fld_fill( sf_uvd, suv_i, cn_dir, 'dta_uvd', 'U & V current data', 'namc1d_uvd' )
+         !
+      ENDIF
+      !
+   END SUBROUTINE dta_uvd_init
+
+
+   SUBROUTINE dta_uvd( kt, puvd )
+      !!----------------------------------------------------------------------
+      !!                   ***  ROUTINE dta_uvd  ***
+      !!                    
+      !! ** Purpose :   provides U & V current data at time step kt
+      !! 
+      !! ** Method  : - call fldread routine
+      !!              - ORCA_R2: make some hand made alterations to the data (EMPTY)
+      !!              - s- or mixed s-zps coordinate: vertical interpolation onto model mesh
+      !!              - zps coordinate: vertical interpolation onto last partial level
+      !!              - ln_uvd_dyndmp=False: deallocate the U & V current data structure,
+      !!                                     as the data is no longer used
+      !!
+      !! ** Action  :   puvd,  U & V current data interpolated onto model mesh at time-step kt
+      !!----------------------------------------------------------------------
+      INTEGER                           , INTENT(in   ) ::   kt     ! ocean time-step
+      REAL(wp), DIMENSION(jpi,jpj,jpk,2), INTENT(  out) ::   puvd   ! U & V current data
+      !
+      INTEGER ::   ji, jj, jk, jl, jkk               ! dummy loop indicies
+      INTEGER ::   ik, il0, il1, ii0, ii1, ij0, ij1  ! local integers
+      REAL(wp)::   zl, zi                            ! local floats
+      REAL(wp), ALLOCATABLE, DIMENSION(:) ::  zup, zvp   ! 1D workspace
+      !!----------------------------------------------------------------------
+      !
+      IF( ln_timing )   CALL timing_start('dta_uvd')
+      !
+      CALL fld_read( kt, 1, sf_uvd )      !==   read U & V current data at time step kt   ==!
+      !
+      puvd(:,:,:,1) = sf_uvd(1)%fnow(:,:,:)                 ! NO mask
+      puvd(:,:,:,2) = sf_uvd(2)%fnow(:,:,:) 
+      !
+      IF( ln_sco ) THEN                   !==   s- or mixed s-zps-coordinate   ==!
+         !
+         ALLOCATE( zup(jpk), zvp(jpk) )
+         !
+         IF( kt == nit000 .AND. lwp )THEN
+            WRITE(numout,*)
+            WRITE(numout,*) 'dta_uvd: interpolate U & V current data onto the s- or mixed s-z-coordinate mesh'
+         ENDIF
+         !
+         DO jj = 1, jpj                   ! vertical interpolation of U & V current:
+            DO ji = 1, jpi                ! determines the interpolated U & V current profiles at each (i,j) point
+               DO jk = 1, jpk
+                  zl = gdept_n(ji,jj,jk)
+                  IF    ( zl < gdept_1d(1  ) ) THEN          ! extrapolate above the first level of data
+                     zup(jk) =  puvd(ji,jj,1    ,1)
+                     zvp(jk) =  puvd(ji,jj,1    ,2)
+                  ELSEIF( zl > gdept_1d(jpk) ) THEN          ! extrapolate below the last level of data
+                     zup(jk) =  puvd(ji,jj,jpkm1,1)
+                     zvp(jk) =  puvd(ji,jj,jpkm1,2)
+                  ELSE                                      ! inbetween : vertical interpolation between jkk & jkk+1
+                     DO jkk = 1, jpkm1                      ! when  gdept(jkk) < zl < gdept(jkk+1)
+                        IF( (zl-gdept_1d(jkk)) * (zl-gdept_1d(jkk+1)) <= 0._wp ) THEN
+                           zi = ( zl - gdept_1d(jkk) ) / (gdept_1d(jkk+1)-gdept_1d(jkk))
+                           zup(jk) = puvd(ji,jj,jkk,1) + ( puvd(ji,jj,jkk+1,1 ) - puvd(ji,jj,jkk,1) ) * zi 
+                           zvp(jk) = puvd(ji,jj,jkk,2) + ( puvd(ji,jj,jkk+1,2 ) - puvd(ji,jj,jkk,2) ) * zi
+                        ENDIF
+                     END DO
+                  ENDIF
+               END DO
+               DO jk = 1, jpkm1           ! apply mask
+                  puvd(ji,jj,jk,1) = zup(jk) * umask(ji,jj,jk)
+                  puvd(ji,jj,jk,2) = zvp(jk) * vmask(ji,jj,jk)
+               END DO
+               puvd(ji,jj,jpk,1) = 0._wp
+               puvd(ji,jj,jpk,2) = 0._wp
+            END DO
+         END DO
+         ! 
+         DEALLOCATE( zup, zvp )
+         ! 
+      ELSE                                !==   z- or zps- coordinate   ==!
+         !                             
+         puvd(:,:,:,1) = puvd(:,:,:,1) * umask(:,:,:)       ! apply mask
+         puvd(:,:,:,2) = puvd(:,:,:,2) * vmask(:,:,:)
+         !
+         IF( ln_zps ) THEN                ! zps-coordinate (partial steps) interpolation at the last ocean level
+            DO jj = 1, jpj
+               DO ji = 1, jpi
+                  ik = mbkt(ji,jj) 
+                  IF( ik > 1 ) THEN
+                     zl = ( gdept_1d(ik) - gdept_0(ji,jj,ik) ) / ( gdept_1d(ik) - gdept_1d(ik-1) )
+                     puvd(ji,jj,ik,1) = (1.-zl) * puvd(ji,jj,ik,1) + zl * puvd(ji,jj,ik-1,1)
+                     puvd(ji,jj,ik,2) = (1.-zl) * puvd(ji,jj,ik,2) + zl * puvd(ji,jj,ik-1,2)
+                  ENDIF
+               END DO
+            END DO
+         ENDIF
+         !
+      ENDIF
+      !
+      IF( .NOT. ln_uvd_dyndmp    ) THEN   !==   deallocate U & V current structure   ==! 
+         !                                !==   (data used only for initialization)  ==!
+         IF(lwp) WRITE(numout,*) 'dta_uvd: deallocate U & V current arrays as they are only used to initialize the run'
+                                   DEALLOCATE( sf_uvd(1)%fnow )     ! U current arrays in the structure
+         IF( sf_uvd(1)%ln_tint )   DEALLOCATE( sf_uvd(1)%fdta )
+                                   DEALLOCATE( sf_uvd(2)%fnow )     ! V current arrays in the structure
+         IF( sf_uvd(2)%ln_tint )   DEALLOCATE( sf_uvd(2)%fdta )
+                                   DEALLOCATE( sf_uvd         )     ! the structure itself
+      ENDIF
+      !
+      IF( ln_timing )   CALL timing_stop('dta_uvd')
+      !
+   END SUBROUTINE dta_uvd
+
+   !!======================================================================
+END MODULE dtauvd
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/C1D/dyncor_c1d.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/C1D/dyncor_c1d.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/C1D/dyncor_c1d.F90	(revision 9570)
@@ -0,0 +1,115 @@
+MODULE dyncor_c1d
+   !!======================================================================
+   !!                     ***  MODULE  dyncor_c1d  ***
+   !! Ocean Dynamics :   Coriolis term in 1D configuration
+   !!=====================================================================
+   !! History :  2.0  !  2004-09  (C. Ethe)  Original code
+   !!            3.0  !  2008-04  (G. Madec)  style only
+   !!----------------------------------------------------------------------
+#if defined key_c1d
+   !!----------------------------------------------------------------------
+   !!   'key_c1d'                                          1D Configuration
+   !!----------------------------------------------------------------------
+   !!   cor_c1d       : Coriolis factor at T-point (1D configuration)
+   !!   dyn_cor_c1d   : vorticity trend due to Coriolis at T-point
+   !!----------------------------------------------------------------------
+   USE oce            ! ocean dynamics and tracers
+   USE dom_oce        ! ocean space and time domain
+   USE phycst         ! physical constants
+   !
+   USE in_out_manager ! I/O manager
+   USE prtctl         ! Print control
+
+   USE sbcwave        ! Surface Waves (add Stokes-Coriolis force)
+   USE sbc_oce , ONLY : ln_stcor    ! use Stoke-Coriolis force
+   
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   cor_c1d      ! called by nemogcm.F90
+   PUBLIC   dyn_cor_c1d  ! called by step1d.F90
+
+   !! * Substitutions
+#  include "vectopt_loop_substitute.h90"
+   !!----------------------------------------------------------------------
+   !! NEMO/C1D 3.7 , NEMO Consortium (2015)
+   !! $Id$ 
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE cor_c1d
+      !!----------------------------------------------------------------------
+      !!                   ***  ROUTINE cor_c1d  ***
+      !! 
+      !! ** Purpose : set the Coriolis factor at T-point
+      !!----------------------------------------------------------------------
+      REAL(wp) ::   zphi0, zbeta, zf0   ! local scalars
+      !!----------------------------------------------------------------------
+
+      IF(lwp) WRITE(numout,*)
+      IF(lwp) WRITE(numout,*) 'cor_c1d : Coriolis factor at T-point'
+      IF(lwp) WRITE(numout,*) '~~~~~~~'
+
+      !
+   END SUBROUTINE cor_c1d
+
+
+   SUBROUTINE dyn_cor_c1d( kt )
+      !!----------------------------------------------------------------------
+      !!                   ***  ROUTINE dyn_cor_c1d  ***
+      !! 
+      !! ** Purpose :   Compute the now Coriolis trend and add it to 
+      !!               the general trend of the momentum equation in 1D case.
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT( in ) ::   kt   ! ocean time-step index
+      !!
+      INTEGER ::   ji, jj, jk   ! dummy loop indices
+      !!----------------------------------------------------------------------
+      !
+      IF( kt == nit000 ) THEN
+         IF(lwp) WRITE(numout,*)
+         IF(lwp) WRITE(numout,*) 'dyn_cor_c1d : total vorticity trend in 1D'
+         IF(lwp) WRITE(numout,*) '~~~~~~~~~~'
+      ENDIF
+      !
+      IF( ln_stcor ) THEN
+         DO jk = 1, jpkm1
+            DO jj = 2, jpjm1
+               DO ji = fs_2, fs_jpim1   ! vector opt.
+                  ua(ji,jj,jk) = ua(ji,jj,jk) + ff_t(ji,jj) * (vn(ji,jj,jk) + vsd(ji,jj,jk))
+                  va(ji,jj,jk) = va(ji,jj,jk) - ff_t(ji,jj) * (un(ji,jj,jk) + usd(ji,jj,jk))
+               END DO
+            END DO
+         END DO
+      ELSE
+         DO jk = 1, jpkm1
+            DO jj = 2, jpjm1
+               DO ji = fs_2, fs_jpim1   ! vector opt.
+                  ua(ji,jj,jk) = ua(ji,jj,jk) + ff_t(ji,jj) * vn(ji,jj,jk)
+                  va(ji,jj,jk) = va(ji,jj,jk) - ff_t(ji,jj) * un(ji,jj,jk)
+               END DO
+            END DO
+         END DO
+      END IF
+      
+      !
+      IF(ln_ctl)   CALL prt_ctl( tab3d_1=ua, clinfo1=' cor  - Ua: ', mask1=umask,  &
+         &                       tab3d_2=va, clinfo2=' Va: '       , mask2=vmask )
+      !
+   END SUBROUTINE dyn_cor_c1d
+
+#else
+   !!----------------------------------------------------------------------
+   !!   Default key                                     NO 1D Configuration
+   !!----------------------------------------------------------------------
+CONTAINS
+   SUBROUTINE cor_c1d              ! Empty routine
+   END SUBROUTINE cor_c1d   
+   SUBROUTINE dyn_cor_c1d ( kt )      ! Empty routine
+      WRITE(*,*) 'dyn_cor_c1d: You should not have seen this print! error?', kt
+   END SUBROUTINE dyn_cor_c1d
+#endif
+
+   !!=====================================================================
+END MODULE dyncor_c1d
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/C1D/dyndmp.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/C1D/dyndmp.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/C1D/dyndmp.F90	(revision 9570)
@@ -0,0 +1,230 @@
+MODULE dyndmp
+   !!======================================================================
+   !!                       ***  MODULE  dyndmp  ***
+   !! Ocean dynamics: internal restoring trend on momentum (U and V current)
+   !!                 This should only be used for C1D case in current form
+   !!======================================================================
+   !! History :  3.5  ! 2013-08  (D. Calvert)  Original code
+   !!            3.6  ! 2014-08  (T. Graham) Modified to use netcdf file of
+   !!                             restoration coefficients supplied to tradmp
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   dyn_dmp_alloc : allocate dyndmp arrays
+   !!   dyn_dmp_init  : namelist read, parameter control and resto coeff.
+   !!   dyn_dmp       : update the momentum trend with the internal damping
+   !!----------------------------------------------------------------------
+   USE oce            ! ocean: variables
+   USE dom_oce        ! ocean: domain variables
+   USE c1d            ! 1D vertical configuration
+   USE tradmp         ! ocean: internal damping
+   USE zdf_oce        ! ocean: vertical physics
+   USE phycst         ! physical constants
+   USE dtauvd         ! data: U & V current
+   USE zdfmxl         ! vertical physics: mixed layer depth
+   !
+   USE in_out_manager ! I/O manager
+   USE lib_mpp        ! MPP library
+   USE prtctl         ! Print control
+   USE timing         ! Timing
+   USE iom            ! I/O manager
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   dyn_dmp_init ! routine called by nemogcm.F90
+   PUBLIC   dyn_dmp      ! routine called by step_c1d.F90
+
+   LOGICAL, PUBLIC ::   ln_dyndmp   !: Flag for Newtonian damping
+
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::  utrdmp    !: damping U current trend (m/s2)
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::  vtrdmp    !: damping V current trend (m/s2)
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::  resto_uv  !: restoring coeff. on U & V current
+
+   !! * Substitutions
+#  include "vectopt_loop_substitute.h90"
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.7 , NEMO Consortium (2015)
+   !! $Id$ 
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   INTEGER FUNCTION dyn_dmp_alloc()
+      !!----------------------------------------------------------------------
+      !!                ***  FUNCTION dyn_dmp_alloc  ***
+      !!----------------------------------------------------------------------
+      ALLOCATE( utrdmp(jpi,jpj,jpk), vtrdmp(jpi,jpj,jpk), resto_uv(jpi,jpj,jpk), STAT= dyn_dmp_alloc )
+      !
+      IF( lk_mpp            )   CALL mpp_sum ( dyn_dmp_alloc )
+      IF( dyn_dmp_alloc > 0 )   CALL ctl_warn('dyn_dmp_alloc: allocation of arrays failed')
+      !
+   END FUNCTION dyn_dmp_alloc
+
+
+   SUBROUTINE dyn_dmp_init
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE dyn_dmp_init  ***
+      !! 
+      !! ** Purpose :   Initialization for the Newtonian damping 
+      !!
+      !! ** Method  : - read the ln_dyndmp parameter from the namc1d_dyndmp namelist
+      !!              - allocate damping arrays
+      !!              - check the parameters of the namtra_dmp namelist
+      !!              - calculate damping coefficient
+      !!----------------------------------------------------------------------
+      INTEGER ::   ios, imask   ! local integers
+      !!
+      NAMELIST/namc1d_dyndmp/ ln_dyndmp
+      !!----------------------------------------------------------------------
+      !
+      REWIND( numnam_ref )              ! Namelist namc1d_dyndmp in reference namelist : 
+      READ  ( numnam_ref, namc1d_dyndmp, IOSTAT = ios, ERR = 901)
+901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namc1d_dyndmp in reference namelist', lwp )
+      REWIND( numnam_cfg )              ! Namelist namc1d_dyndmp in configuration namelist : Parameters of the run
+      READ  ( numnam_cfg, namc1d_dyndmp, IOSTAT = ios, ERR = 902 )
+902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namc1d_dyndmp in configuration namelist', lwp )
+      IF(lwm) WRITE ( numond, namc1d_dyndmp )
+      !
+      IF(lwp) THEN                           ! control print
+         WRITE(numout,*)
+         WRITE(numout,*) 'dyn_dmp_init : U and V current Newtonian damping'
+         WRITE(numout,*) '~~~~~~~~~~~~'
+         WRITE(numout,*) '   Namelist namc1d_dyndmp : Set damping flag'
+         WRITE(numout,*) '      add a damping term or not       ln_dyndmp = ', ln_dyndmp
+         WRITE(numout,*) '   Namelist namtra_dmp    : Set damping parameters'
+         WRITE(numout,*) '      Apply relaxation   or not       ln_tradmp = ', ln_tradmp
+         WRITE(numout,*) '      mixed layer damping option      nn_zdmp   = ', nn_zdmp
+         WRITE(numout,*) '      Damping file name               cn_resto  = ', cn_resto
+         WRITE(numout,*)
+      ENDIF
+      !
+      IF( ln_dyndmp ) THEN
+         !                                   !==   allocate the data arrays   ==!
+         IF( dyn_dmp_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'dyn_dmp_init: unable to allocate arrays' )
+         !
+         SELECT CASE ( nn_zdmp )             !==   control print of vertical option   ==!
+         CASE ( 0    )   ;   IF(lwp) WRITE(numout,*) '   momentum damping throughout the water column'
+         CASE ( 1    )   ;   IF(lwp) WRITE(numout,*) '   no momentum damping in the turbocline (avt > 5 cm2/s)'
+         CASE ( 2    )   ;   IF(lwp) WRITE(numout,*) '   no momentum damping in the mixed layer'
+         CASE DEFAULT
+            WRITE(ctmp1,*) '          bad flag value for nn_zdmp = ', nn_zdmp
+            CALL ctl_stop(ctmp1)
+         END SELECT
+         !
+         IF( .NOT. ln_uvd_dyndmp ) THEN      ! force the initialization of U & V current data for damping
+            CALL ctl_warn( 'dyn_dmp_init: U & V current read data not initialized, we force ln_uvd_dyndmp=T' )
+            CALL dta_uvd_init( ld_dyndmp=ln_dyndmp )
+         ENDIF
+         !
+         utrdmp(:,:,:) = 0._wp               ! internal damping trends
+         vtrdmp(:,:,:) = 0._wp
+         !
+         !Read in mask from file
+         CALL iom_open ( cn_resto, imask)
+         CALL iom_get  ( imask, jpdom_autoglo, 'resto', resto)
+         CALL iom_close( imask )
+      ENDIF
+      !
+   END SUBROUTINE dyn_dmp_init
+
+
+   SUBROUTINE dyn_dmp( kt )
+      !!----------------------------------------------------------------------
+      !!                   ***  ROUTINE dyn_dmp  ***
+      !!                  
+      !! ** Purpose :   Compute the momentum trends due to a newtonian damping
+      !!      of the ocean velocities towards the given data and add it to the 
+      !!      general momentum trends.
+      !!
+      !! ** Method  :   Compute Newtonian damping towards u_dta and v_dta 
+      !!      and add to the general momentum trends:
+      !!                     ua = ua + resto_uv * (u_dta - ub)
+      !!                     va = va + resto_uv * (v_dta - vb)
+      !!      The trend is computed either throughout the water column
+      !!      (nn_zdmp=0), where the vertical mixing is weak (nn_zdmp=1) or
+      !!      below the well mixed layer (nn_zdmp=2)
+      !!
+      !! ** Action  : - (ua,va)   momentum trends updated with the damping trend
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT(in) ::   kt   ! ocean time-step index
+      !!
+      INTEGER  ::   ji, jj, jk   ! dummy loop indices
+      REAL(wp) ::   zua, zva     ! local scalars
+      REAL(wp), DIMENSION(jpi,jpj,jpk,2) ::   zuv_dta   ! Read in data 
+      !!----------------------------------------------------------------------
+      !
+      IF( ln_timing )   CALL timing_start( 'dyn_dmp' )
+      !
+      !
+      !                           !==   read and interpolate U & V current data at kt   ==!
+      CALL dta_uvd( kt, zuv_dta ) !!! NOTE: This subroutine must be altered for use outside
+                                  !!!       the C1D context (use of U,V grid variables)
+      !
+      SELECT CASE ( nn_zdmp )     !==   Calculate/add Newtonian damping to the momentum trend   ==!
+      !
+      CASE( 0 )                   ! Newtonian damping throughout the water column
+         DO jk = 1, jpkm1
+            DO jj = 2, jpjm1
+               DO ji = fs_2, fs_jpim1   ! vector opt.
+                  zua = resto_uv(ji,jj,jk) * ( zuv_dta(ji,jj,jk,1) - ub(ji,jj,jk) )
+                  zva = resto_uv(ji,jj,jk) * ( zuv_dta(ji,jj,jk,2) - vb(ji,jj,jk) )
+                  ua(ji,jj,jk) = ua(ji,jj,jk) + zua
+                  va(ji,jj,jk) = va(ji,jj,jk) + zva
+                  utrdmp(ji,jj,jk) = zua           ! save the trends
+                  vtrdmp(ji,jj,jk) = zva      
+               END DO
+            END DO
+         END DO
+         !
+      CASE ( 1 )                  ! no damping above the turbocline (avt > 5 cm2/s)
+         DO jk = 1, jpkm1
+            DO jj = 2, jpjm1
+               DO ji = fs_2, fs_jpim1   ! vector opt.
+                  IF( avt(ji,jj,jk) <= 5.e-4_wp ) THEN
+                     zua = resto_uv(ji,jj,jk) * ( zuv_dta(ji,jj,jk,1) - ub(ji,jj,jk) )
+                     zva = resto_uv(ji,jj,jk) * ( zuv_dta(ji,jj,jk,2) - vb(ji,jj,jk) )
+                  ELSE
+                     zua = 0._wp
+                     zva = 0._wp  
+                  ENDIF
+                  ua(ji,jj,jk) = ua(ji,jj,jk) + zua
+                  va(ji,jj,jk) = va(ji,jj,jk) + zva
+                  utrdmp(ji,jj,jk) = zua           ! save the trends
+                  vtrdmp(ji,jj,jk) = zva
+               END DO
+            END DO
+         END DO
+         !
+      CASE ( 2 )                  ! no damping in the mixed layer
+         DO jk = 1, jpkm1
+            DO jj = 2, jpjm1
+               DO ji = fs_2, fs_jpim1   ! vector opt.
+                  IF( gdept_n(ji,jj,jk) >= hmlp (ji,jj) ) THEN
+                     zua = resto_uv(ji,jj,jk) * ( zuv_dta(ji,jj,jk,1) - ub(ji,jj,jk) )
+                     zva = resto_uv(ji,jj,jk) * ( zuv_dta(ji,jj,jk,2) - vb(ji,jj,jk) )
+                  ELSE
+                     zua = 0._wp
+                     zva = 0._wp  
+                  ENDIF
+                  ua(ji,jj,jk) = ua(ji,jj,jk) + zua
+                  va(ji,jj,jk) = va(ji,jj,jk) + zva
+                  utrdmp(ji,jj,jk) = zua           ! save the trends
+                  vtrdmp(ji,jj,jk) = zva
+               END DO
+            END DO
+         END DO
+         !
+      END SELECT
+      !
+      !                           ! Control print
+      IF( ln_ctl   )   CALL prt_ctl( tab3d_1=ua(:,:,:), clinfo1=' dmp  - Ua: ', mask1=umask,   &
+         &                           tab3d_2=va(:,:,:), clinfo2=       ' Va: ', mask2=vmask, clinfo3='dyn' )
+      !
+      !
+      IF( ln_timing )   CALL timing_stop( 'dyn_dmp')
+      !
+   END SUBROUTINE dyn_dmp
+
+   !!======================================================================
+END MODULE dyndmp
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/C1D/step_c1d.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/C1D/step_c1d.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/C1D/step_c1d.F90	(revision 9570)
@@ -0,0 +1,154 @@
+MODULE step_c1d
+   !!======================================================================
+   !!                       ***  MODULE step_c1d  ***
+   !! Time-stepping    : manager of the ocean, tracer and ice time stepping - c1d case
+   !!======================================================================
+   !! History :   2.0  !  2004-04  (C. Ethe)  adapted from step.F90 for C1D
+   !!             3.0  !  2008-04  (G. Madec)  redo the adaptation to include SBC
+   !!----------------------------------------------------------------------
+#if defined key_c1d
+   !!----------------------------------------------------------------------
+   !!   'key_c1d'                                       1D Configuration
+   !!----------------------------------------------------------------------  
+   !!   stp_c1d        : NEMO system time-stepping in c1d case
+   !!----------------------------------------------------------------------
+   USE step_oce        ! time stepping definition modules 
+#if defined key_top
+   USE trcstp          ! passive tracer time-stepping      (trc_stp routine)
+#endif
+   USE dyncor_c1d      ! Coriolis term (c1d case)         (dyn_cor_1d     )
+   USE dynnxt          ! time-stepping                    (dyn_nxt routine)
+   USE dyndmp          ! U & V momentum damping           (dyn_dmp routine)
+   USE restart         ! restart 
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC stp_c1d      ! called by opa.F90
+
+   !!----------------------------------------------------------------------
+   !! NEMO/C1D 3.7 , NEMO Consortium (2015)
+   !! $Id$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE stp_c1d( kstp )
+      !!----------------------------------------------------------------------
+      !!                     ***  ROUTINE stp_c1d  ***
+      !!                      
+      !! ** Purpose :  - Time stepping of SBC including LIM (dynamic and thermodynamic eqs.)
+      !!               - Time stepping of OPA (momentum and active tracer eqs.)
+      !!               - Time stepping of TOP (passive tracer eqs.)
+      !! 
+      !! ** Method  : -1- Update forcings and data  
+      !!              -2- Update vertical ocean physics 
+      !!              -3- Compute the t and s trends 
+      !!              -4- Update t and s 
+      !!              -5- Compute the momentum trends
+      !!              -6- Update the horizontal velocity
+      !!              -7- Compute the diagnostics variables (rd,N2, div,cur,w)
+      !!              -8- Outputs and diagnostics
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT(in) ::   kstp   ! ocean time-step index
+      !
+      INTEGER ::   jk       ! dummy loop indice
+      INTEGER ::   indic    ! error indicator if < 0
+      !! ---------------------------------------------------------------------
+
+                             indic = 0                ! reset to no error condition
+      IF( kstp == nit000 )   CALL iom_init( "nemo")   ! iom_put initialization (must be done after nemo_init for AGRIF+XIOS+OASIS)
+      IF( kstp /= nit000 )   CALL day( kstp )         ! Calendar (day was already called at nit000 in day_init)
+                             CALL iom_setkt( kstp - nit000 + 1, "nemo" )   ! say to iom that we are at time step kstp
+
+      !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+      ! Update data, open boundaries, surface boundary condition (including sea-ice)
+      !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+                         CALL sbc    ( kstp )         ! Sea Boundary Condition (including sea-ice)
+
+      !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+      ! Ocean physics update                (ua, va, ta, sa used as workspace)
+      !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+                         CALL eos_rab( tsb, rab_b )   ! before local thermal/haline expension ratio at T-points
+                         CALL eos_rab( tsn, rab_n )   ! now    local thermal/haline expension ratio at T-points
+                         CALL bn2( tsb, rab_b, rn2b ) ! before Brunt-Vaisala frequency
+                         CALL bn2( tsn, rab_n, rn2  ) ! now    Brunt-Vaisala frequency
+      
+      !  VERTICAL PHYSICS
+                         CALL zdf_phy( kstp )         ! vertical physics update (bfr, avt, avs, avm + MLD)
+
+      IF(.NOT.ln_linssh )   CALL ssh_nxt       ( kstp )  ! after ssh (includes call to div_hor)
+      IF(.NOT.ln_linssh )   CALL dom_vvl_sf_nxt( kstp )  ! after vertical scale factors 
+
+      IF(.NOT.ln_linssh )   CALL wzv           ( kstp )  ! now cross-level velocity 
+      !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+      ! diagnostics and outputs             (ua, va, ta, sa used as workspace)
+      !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+                         CALL dia_wri( kstp )       ! ocean model: outputs
+      IF( lk_diahth  )   CALL dia_hth( kstp )       ! Thermocline depth (20°C)
+
+
+#if defined key_top
+      !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+      ! Passive Tracer Model
+      !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+                        CALL trc_stp( kstp )       ! time-stepping
+#endif
+
+      !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+      ! Active tracers                              (ua, va used as workspace)
+      !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+                        tsa(:,:,:,:) = 0._wp       ! set tracer trends to zero
+
+                        CALL tra_sbc( kstp )       ! surface boundary condition
+      IF( ln_traqsr )   CALL tra_qsr( kstp )       ! penetrative solar radiation qsr
+      IF( ln_tradmp )   CALL tra_dmp( kstp )       ! internal damping trends- tracers
+      IF(.NOT.ln_linssh)CALL tra_adv( kstp )       ! horizontal & vertical advection
+      IF( ln_zdfosm  )  CALL tra_osm( kstp )       ! OSMOSIS non-local tracer fluxes
+                        CALL tra_zdf( kstp )       ! vertical mixing
+                        CALL eos( tsn, rhd, rhop, gdept_0(:,:,:) )   ! now potential density for zdfmxl
+      IF( ln_zdfnpc )   CALL tra_npc( kstp )       ! applied non penetrative convective adjustment on (t,s)
+                        CALL tra_nxt( kstp )       ! tracer fields at next time step
+
+
+
+      !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+      ! Dynamics                                    (ta, sa used as workspace)
+      !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+                        ua(:,:,:) = 0._wp          ! set dynamics trends to zero
+                        va(:,:,:) = 0._wp
+
+      IF( ln_dyndmp )   CALL dyn_dmp    ( kstp )   ! internal damping trends- momentum
+                        CALL dyn_cor_c1d( kstp )   ! vorticity term including Coriolis
+      IF( ln_zdfosm  )  CALL dyn_osm    ( kstp )   ! OSMOSIS non-local velocity fluxes
+                        CALL dyn_zdf    ( kstp )   ! vertical diffusion
+                        CALL dyn_nxt    ( kstp )   ! lateral velocity at next time step
+      IF(.NOT.ln_linssh)CALL ssh_swp    ( kstp )   ! swap of sea surface height
+
+      IF(.NOT.ln_linssh)CALL dom_vvl_sf_swp( kstp )! swap of vertical scale factors
+
+      !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+      ! Control and restarts
+      !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+                             CALL stp_ctl( kstp, indic )
+      IF( kstp == nit000 )   CALL iom_close( numror )      ! close input  ocean restart file
+      IF( lrst_oce       )   CALL rst_write( kstp )        ! write output ocean restart file
+      !
+#if defined key_iomput
+      IF( kstp == nitend .OR. indic < 0 )   CALL xios_context_finalize()   ! needed for XIOS
+      !
+#endif
+   END SUBROUTINE stp_c1d
+
+#else
+   !!----------------------------------------------------------------------
+   !!   Default key                                            NO 1D Config
+   !!----------------------------------------------------------------------
+CONTAINS
+   SUBROUTINE stp_c1d ( kt )      ! dummy routine
+      WRITE(*,*) 'stp_c1d: You should not have seen this print! error?', kt
+   END SUBROUTINE stp_c1d
+#endif
+
+   !!======================================================================
+END MODULE step_c1d
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/CRS/crs.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/CRS/crs.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/CRS/crs.F90	(revision 9570)
@@ -0,0 +1,346 @@
+MODULE crs   
+   !!======================================================================
+   !!                         ***  MODULE crs_dom  ***
+   !!        Declare the coarse grid domain and other public variables 
+   !!        then allocate them if needed.
+   !!======================================================================
+   !!  History     2012-06  Editing  (J. Simeon, G. Madec, C. Ethe, C. Calone) Original code
+   !!----------------------------------------------------------------------
+   USE par_oce  
+   USE dom_oce
+   USE in_out_manager
+
+   IMPLICIT NONE
+   PUBLIC
+
+   PUBLIC crs_dom_alloc  ! Called from crsini.F90
+   PUBLIC crs_dom_alloc2  ! Called from crsini.F90
+   PUBLIC dom_grid_glo   
+   PUBLIC dom_grid_crs 
+
+      ! Domain variables
+      INTEGER  ::  jpiglo_crs ,   &             !: 1st dimension of global coarse grid domain
+                   jpjglo_crs                   !: 2nd dimension of global coarse grid domain
+      INTEGER  ::  jpi_crs ,   &                !: 1st dimension of local coarse grid domain
+                   jpj_crs                      !: 2nd dimension of local coarse grid domain
+      INTEGER  ::  jpi_full ,  &                !: 1st dimension of local parent grid domain
+                   jpj_full                     !: 2nd dimension of local parent grid domain
+
+      INTEGER  ::  nistr , njstr
+      INTEGER  ::  niend , njend
+
+      INTEGER  ::  jpi_crsm1, jpj_crsm1         !: loop indices      
+      INTEGER  ::  jpiglo_crsm1, jpjglo_crsm1   !: loop indices      
+      INTEGER  ::  nperio_full, nperio_crs      !: jperio of parent and coarse grids
+      INTEGER  ::  npolj_full, npolj_crs        !: north fold mark
+      INTEGER  ::  jpiglo_full, jpjglo_full     !: jpiglo / jpjglo
+      INTEGER  ::  npiglo, npjglo               !: jpjglo
+      INTEGER  ::  nlci_full, nlcj_full         !: i-, j-dimension of local or sub domain on parent grid
+      INTEGER  ::  nldi_full, nldj_full         !: starting indices of internal sub-domain on parent grid
+      INTEGER  ::  nlei_full, nlej_full         !: ending indices of internal sub-domain on parent grid
+      INTEGER  ::  nlci_crs, nlcj_crs           !: i-, j-dimension of local or sub domain on coarse grid
+      INTEGER  ::  nldi_crs, nldj_crs           !: starting indices of internal sub-domain on coarse grid
+      INTEGER  ::  nlei_crs, nlej_crs           !: ending indices of internal sub-domain on coarse grid
+
+      INTEGER  ::  narea_full, narea_crs        !: node
+      INTEGER  ::  jpnij_full, jpnij_crs        !: =jpni*jpnj, the pe decomposition
+      INTEGER  ::  jpim1_full, jpjm1_full       !: 
+      INTEGER  ::  nimpp_full, njmpp_full       !: global position of point (1,1) of subdomain on parent grid
+      INTEGER  ::  nimpp_crs, njmpp_crs         !: set to 1,1 for now .  Valid only for monoproc
+      INTEGER  ::  nreci_full, nrecj_full
+      INTEGER  ::  nreci_crs, nrecj_crs
+      !cc
+      INTEGER ::   noea_full, nowe_full        !: index of the local neighboring processors in
+      INTEGER ::   noso_full, nono_full        !: east, west, south and north directions
+      INTEGER ::   npne_full, npnw_full        !: index of north east and north west processor
+      INTEGER ::   npse_full, npsw_full        !: index of south east and south west processor
+      INTEGER ::   nbne_full, nbnw_full        !: logical of north east & north west processor
+      INTEGER ::   nbse_full, nbsw_full        !: logical of south east & south west processor
+      INTEGER ::   nidom_full                  !: ???
+      INTEGER ::   nproc_full                  !:number for local processor
+      INTEGER ::   nbondi_full, nbondj_full    !: mark of i- and j-direction local boundaries
+      INTEGER ::   noea_crs, nowe_crs          !: index of the local neighboring processors in
+      INTEGER ::   noso_crs, nono_crs          !: east, west, south and north directions
+      INTEGER ::   npne_crs, npnw_crs          !: index of north east and north west processor
+      INTEGER ::   npse_crs, npsw_crs          !: index of south east and south west processor
+      INTEGER ::   nbne_crs, nbnw_crs          !: logical of north east & north west processor
+      INTEGER ::   nbse_crs, nbsw_crs          !: logical of south east & south west processor
+      INTEGER ::   nidom_crs                   !: ???
+      INTEGER ::   nproc_crs                   !:number for local processor
+      INTEGER ::   nbondi_crs, nbondj_crs      !: mark of i- and j-direction local boundaries
+      
+
+      INTEGER, DIMENSION(:), ALLOCATABLE :: mis_crs, mie_crs, mis2_crs, mie2_crs  ! starting and ending i-indices of parent subset
+      INTEGER, DIMENSION(:), ALLOCATABLE :: mjs_crs, mje_crs, mjs2_crs, mje2_crs ! starting and ending  j-indices of parent subset
+      INTEGER, DIMENSION(:), ALLOCATABLE :: mjg_crs, mig_crs
+      INTEGER, DIMENSION(:), ALLOCATABLE :: mi0_crs, mi1_crs, mj0_crs, mj1_crs
+      INTEGER  :: mxbinctr, mybinctr            ! central point in grid box
+      INTEGER, DIMENSION(:), ALLOCATABLE ::   nlcit_crs, nlcit_full  !: dimensions of every subdomain
+      INTEGER, DIMENSION(:), ALLOCATABLE ::   nldit_crs, nldit_full     !: first, last indoor index for each i-domain
+      INTEGER, DIMENSION(:), ALLOCATABLE ::   nleit_crs, nleit_full    !: first, last indoor index for each j-domain
+      INTEGER, DIMENSION(:), ALLOCATABLE ::   nimppt_crs, nimppt_full    !: first, last indoor index for each j-domain
+      INTEGER, DIMENSION(:), ALLOCATABLE ::   nlcjt_crs, nlcjt_full  !: dimensions of every subdomain
+      INTEGER, DIMENSION(:), ALLOCATABLE ::   nldjt_crs, nldjt_full     !: first, last indoor index for each i-domain
+      INTEGER, DIMENSION(:), ALLOCATABLE ::   nlejt_crs, nlejt_full    !: first, last indoor index for each j-domain
+      INTEGER, DIMENSION(:), ALLOCATABLE ::   njmppt_crs, njmppt_full    !: first, last indoor index for each j-domain
+
+ 
+      ! Masks
+      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: tmask_crs, umask_crs, vmask_crs, fmask_crs
+      REAL(wp), DIMENSION(:,:)  , ALLOCATABLE :: tmask_i_crs, rnfmsk_crs, tpol_crs, fpol_crs
+      
+  !    REAL(wp), DIMENSION(:,:),   ALLOCATABLE :: tmask_i_crs, tpol, fpol      
+
+      ! Scale factors
+      REAL(wp), DIMENSION(:,:),   ALLOCATABLE :: e1t_crs, e2t_crs, e1e2t_crs ! horizontal scale factors grid type T
+      REAL(wp), DIMENSION(:,:),   ALLOCATABLE :: e1u_crs, e2u_crs ! horizontal scale factors grid type U
+      REAL(wp), DIMENSION(:,:),   ALLOCATABLE :: e1v_crs, e2v_crs ! horizontal scale factors grid type V
+      REAL(wp), DIMENSION(:,:),   ALLOCATABLE :: e1f_crs, e2f_crs ! horizontal scale factors grid type F
+      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: e3t_crs, e3u_crs, e3v_crs, e3f_crs, e3w_crs
+      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: e3t_max_crs, e3u_max_crs, e3v_max_crs, e3f_max_crs, e3w_max_crs
+      
+      ! Surface
+      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: e1e2w_crs, e2e3u_crs, e1e3v_crs
+      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: e1e2w_msk, e2e3u_msk, e1e3v_msk
+                                                                  ! vertical scale factors 
+      ! Coordinates
+      REAL(wp), DIMENSION(:,:),   ALLOCATABLE :: gphit_crs, glamt_crs, gphif_crs, glamf_crs 
+      REAL(wp), DIMENSION(:,:),   ALLOCATABLE :: gphiu_crs, glamu_crs, gphiv_crs, glamv_crs 
+      REAL(wp), DIMENSION(:,:),   ALLOCATABLE :: ff_crs
+      INTEGER,  DIMENSION(:,:),   ALLOCATABLE :: mbathy_crs, mbkt_crs, mbku_crs, mbkv_crs
+      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: gdept_crs, gdepu_crs, gdepv_crs, gdepw_crs
+
+      ! Weights
+      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: facsurfv, facsurfu, facvol_t, facvol_w
+      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: ocean_volume_crs_t, ocean_volume_crs_w, bt_crs, r1_bt_crs
+      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: crs_surfu_wgt, crs_surfv_wgt, crs_surfw_wgt, crs_volt_wgt
+
+      ! CRS Namelist
+      INTEGER           :: nn_factx   = 3       !: reduction factor of x-dimension of the parent grid
+      INTEGER           :: nn_facty   = 3       !: reduction factor of y-dimension of the parent grid
+      INTEGER           :: nn_binref  = 0       !: 0 = binning starts north fold (equator could be asymmetric)
+                                                !: 1 = binning centers at equator (north fold my have artifacts)     
+                                                !:    for even reduction factors, equator placed in bin biased south
+      LOGICAL           :: ln_msh_crs   = .TRUE.   !: =T Create a meshmask file for CRS
+      INTEGER           :: nn_crs_kz    =    0     !: type of Kz coarsening ( =0->VOL ; =1->MAX ; =2->MIN) 
+      LOGICAL           :: ln_crs_wn    = .FALSE.  !: coarsening wn or computation using horizontal divergence 
+      !
+      INTEGER           :: nrestx, nresty       !: for determining odd or even reduction factor
+
+
+      ! Grid reduction factors
+      REAL(wp)     ::  rfactx_r                !: inverse of x-dim reduction factor
+      REAL(wp)     ::  rfacty_r                !: inverse of y-dim reduction factor
+      REAL(wp)     ::  rfactxy 
+
+      ! Physical and dynamical ocean fields for output or passing to TOP, time-mean fields
+      REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE      :: tsn_crs
+      REAL(wp), DIMENSION(:,:,:)  , ALLOCATABLE      :: un_crs, vn_crs, wn_crs
+      REAL(wp), DIMENSION(:,:,:)  , ALLOCATABLE      :: hdivn_crs    
+      REAL(wp), DIMENSION(:,:)    , ALLOCATABLE      :: sshn_crs    
+      ! 
+      ! Surface fluxes to pass to TOP
+      REAL(wp), PUBLIC, DIMENSION(:,:)  , ALLOCATABLE :: qsr_crs, fr_i_crs, wndm_crs
+      REAL(wp), PUBLIC, DIMENSION(:,:)  , ALLOCATABLE :: emp_crs, emp_b_crs, sfx_crs
+      REAL(wp), PUBLIC, DIMENSION(:,:)  , ALLOCATABLE :: utau_crs, vtau_crs
+      REAL(wp), PUBLIC, DIMENSION(:,:)  , ALLOCATABLE :: rnf_crs
+
+      ! Vertical diffusion
+      REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:)  ::  avt_crs           !: temperature vertical diffusivity coeff. [m2/s] at w-point
+      REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:)  ::  avs_crs           !: salinity    vertical diffusivity coeff. [m2/s] at w-point
+
+      ! Mixing and Mixed Layer Depth
+      INTEGER,  PUBLIC, ALLOCATABLE, DIMENSION(:,:)    ::  nmln_crs, hmld_crs, hmlp_crs, hmlpt_crs                       
+
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO Consortium (2010)
+   !! $Id$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+   
+   INTEGER FUNCTION crs_dom_alloc()
+      !!-------------------------------------------------------------------
+      !!                     *** FUNCTION crs_dom_alloc ***
+      !!  ** Purpose :   Allocate public crs arrays  
+      !!-------------------------------------------------------------------
+      !! Local variables
+      INTEGER, DIMENSION(17) :: ierr
+
+      ierr(:) = 0
+
+      ! Set up bins for coarse grid, horizontal only.
+     ALLOCATE( mis2_crs(jpiglo_crs), mie2_crs(jpiglo_crs),  &
+       &       mjs2_crs(jpjglo_crs), mje2_crs(jpjglo_crs),  &
+       &       mi0_crs (jpiglo_crs), mi1_crs (jpiglo_crs),  &
+       &       mj0_crs (jpjglo_crs), mj1_crs (jpjglo_crs),  &
+       &       mig_crs (jpi_crs)   , mjg_crs (jpj_crs)   ,  STAT=ierr(1) ) 
+
+
+      ! Set up Mask and Mesh
+      ALLOCATE( tmask_crs(jpi_crs,jpj_crs,jpk) , fmask_crs(jpi_crs,jpj_crs,jpk) ,  &
+         &      umask_crs(jpi_crs,jpj_crs,jpk) , vmask_crs(jpi_crs,jpj_crs,jpk) , STAT=ierr(2))
+
+      ALLOCATE( tmask_i_crs(jpi_crs,jpj_crs)   , rnfmsk_crs(jpi_crs,jpj_crs), &
+      &         tpol_crs(jpiglo_crs,jpjglo_crs), fpol_crs(jpiglo_crs,jpjglo_crs), STAT=ierr(3) )
+
+      ALLOCATE( gphit_crs(jpi_crs,jpj_crs) , glamt_crs(jpi_crs,jpj_crs) , & 
+         &      gphiu_crs(jpi_crs,jpj_crs) , glamu_crs(jpi_crs,jpj_crs) , &
+         &      gphiv_crs(jpi_crs,jpj_crs) , glamv_crs(jpi_crs,jpj_crs) , &
+         &      gphif_crs(jpi_crs,jpj_crs) , glamf_crs(jpi_crs,jpj_crs) , &
+         &      ff_crs(jpi_crs,jpj_crs)    , STAT=ierr(4))
+
+      ALLOCATE( e1t_crs(jpi_crs,jpj_crs) , e2t_crs(jpi_crs,jpj_crs) , & 
+         &      e1u_crs(jpi_crs,jpj_crs) , e2u_crs(jpi_crs,jpj_crs) , & 
+         &      e1v_crs(jpi_crs,jpj_crs) , e2v_crs(jpi_crs,jpj_crs) , &
+         &      e1f_crs(jpi_crs,jpj_crs) , e2f_crs(jpi_crs,jpj_crs) , &
+         &      e1e2t_crs(jpi_crs,jpj_crs), STAT=ierr(5))
+
+      ALLOCATE( e3t_crs(jpi_crs,jpj_crs,jpk)    , e3w_crs(jpi_crs,jpj_crs,jpk)    , & 
+         &      e3u_crs(jpi_crs,jpj_crs,jpk)    , e3v_crs(jpi_crs,jpj_crs,jpk)    , &
+         &      e3f_crs(jpi_crs,jpj_crs,jpk)    , e1e2w_msk(jpi_crs,jpj_crs,jpk)  , & 
+         &      e2e3u_msk(jpi_crs,jpj_crs,jpk)  , e1e3v_msk(jpi_crs,jpj_crs,jpk)  , &
+         &      e1e2w_crs(jpi_crs,jpj_crs,jpk)  , e2e3u_crs(jpi_crs,jpj_crs,jpk)  , &
+         &      e1e3v_crs(jpi_crs,jpj_crs,jpk)  , e3t_max_crs(jpi_crs,jpj_crs,jpk), &
+         &      e3w_max_crs(jpi_crs,jpj_crs,jpk), e3u_max_crs(jpi_crs,jpj_crs,jpk), &
+         &      e3v_max_crs(jpi_crs,jpj_crs,jpk), STAT=ierr(6))
+
+
+      ALLOCATE( facsurfv(jpi_crs,jpj_crs,jpk), facsurfu(jpi_crs,jpj_crs,jpk) , & 
+         &      facvol_t(jpi_crs,jpj_crs,jpk), facvol_w(jpi_crs,jpj_crs,jpk) , &
+         &      ocean_volume_crs_t(jpi_crs,jpj_crs,jpk), ocean_volume_crs_w(jpi_crs,jpj_crs,jpk), &
+         &      bt_crs(jpi_crs,jpj_crs,jpk)  , r1_bt_crs(jpi_crs,jpj_crs,jpk) , STAT=ierr(7))
+
+
+      ALLOCATE( crs_surfu_wgt(jpi_crs,jpj_crs,jpk), crs_surfv_wgt(jpi_crs,jpj_crs,jpk) , & 
+         &      crs_surfw_wgt(jpi_crs,jpj_crs,jpk), crs_volt_wgt(jpi_crs,jpj_crs,jpk) , STAT=ierr(8))
+
+
+      ALLOCATE( mbathy_crs(jpi_crs,jpj_crs), mbkt_crs(jpi_crs,jpj_crs) , &
+         &      mbku_crs(jpi_crs,jpj_crs)  , mbkv_crs(jpi_crs,jpj_crs) , STAT=ierr(9))
+
+      ALLOCATE( gdept_crs(jpi_crs,jpj_crs,jpk), gdepu_crs(jpi_crs,jpj_crs,jpk) , &
+         &      gdepv_crs(jpi_crs,jpj_crs,jpk), gdepw_crs(jpi_crs,jpj_crs,jpk) , STAT=ierr(10) )
+
+
+      ALLOCATE( un_crs(jpi_crs,jpj_crs,jpk) , vn_crs   (jpi_crs,jpj_crs,jpk) ,     &
+         &      wn_crs(jpi_crs,jpj_crs,jpk) , hdivn_crs(jpi_crs,jpj_crs,jpk) , STAT=ierr(11))
+
+     ALLOCATE( sshn_crs(jpi_crs,jpj_crs), emp_crs (jpi_crs,jpj_crs), emp_b_crs(jpi_crs,jpj_crs), &
+         &     qsr_crs(jpi_crs ,jpj_crs), wndm_crs(jpi_crs,jpj_crs), utau_crs(jpi_crs,jpj_crs) , &
+         &     vtau_crs(jpi_crs,jpj_crs), rnf_crs(jpi_crs ,jpj_crs), &
+         &     fr_i_crs(jpi_crs,jpj_crs), sfx_crs(jpi_crs ,jpj_crs),  STAT=ierr(12)  )
+
+     ALLOCATE( tsn_crs(jpi_crs,jpj_crs,jpk,jpts), avt_crs(jpi_crs,jpj_crs,jpk),   &
+         &                                        avs_crs(jpi_crs,jpj_crs,jpk), STAT=ierr(13) )
+
+      ALLOCATE( nmln_crs(jpi_crs,jpj_crs) , hmld_crs(jpi_crs,jpj_crs) , &
+         &      hmlp_crs(jpi_crs,jpj_crs) , hmlpt_crs(jpi_crs,jpj_crs) , STAT=ierr(14) )
+         
+      ALLOCATE( nimppt_crs (jpnij) , nlcit_crs (jpnij) , nldit_crs (jpnij) , nleit_crs (jpnij),   &
+         &      nimppt_full(jpnij) , nlcit_full(jpnij) , nldit_full(jpnij) , nleit_full(jpnij),   &
+                njmppt_crs (jpnij) , nlcjt_crs (jpnij) , nldjt_crs (jpnij) , nlejt_crs (jpnij),   &
+         &      njmppt_full(jpnij) , nlcjt_full(jpnij) , nldjt_full(jpnij) , nlejt_full(jpnij)  , STAT=ierr(15) )
+   
+      crs_dom_alloc = MAXVAL(ierr)
+      !
+   END FUNCTION crs_dom_alloc
+
+
+   INTEGER FUNCTION crs_dom_alloc2()
+      !!-------------------------------------------------------------------
+      !!                     *** FUNCTION crs_dom_alloc ***
+      !!  ** Purpose :   Allocate public crs arrays  
+      !!-------------------------------------------------------------------
+      !! Local variables
+      INTEGER, DIMENSION(1) :: ierr
+
+      ierr(:) = 0
+      
+      ALLOCATE( mjs_crs(nlej_crs) , mje_crs(nlej_crs), mis_crs(nlei_crs) , mie_crs(nlei_crs), STAT=ierr(1) )
+      crs_dom_alloc2 = MAXVAL(ierr)
+
+   END FUNCTION crs_dom_alloc2
+
+
+   SUBROUTINE dom_grid_glo
+      !!--------------------------------------------------------------------
+      !!                       ***  MODULE dom_grid_glo  ***
+      !!
+      !! ** Purpose : +Return back to parent grid domain 
+      !!---------------------------------------------------------------------
+
+      !                         Return to parent grid domain
+      jpi    = jpi_full
+      jpj    = jpj_full
+      jpim1  = jpim1_full
+      jpjm1  = jpjm1_full
+      nperio = nperio_full
+
+      npolj  = npolj_full
+      jpiglo = jpiglo_full
+      jpjglo = jpjglo_full
+
+      nlci   = nlci_full
+      nlcj   = nlcj_full
+      nldi   = nldi_full
+      nldj   = nldj_full
+      nlei   = nlei_full
+      nlej   = nlej_full
+      nimpp  = nimpp_full
+      njmpp  = njmpp_full
+      
+      nlcit(:)  = nlcit_full(:)
+      nldit(:)  = nldit_full(:)
+      nleit(:)  = nleit_full(:)
+      nimppt(:) = nimppt_full(:)
+      nlcjt(:)  = nlcjt_full(:)
+      nldjt(:)  = nldjt_full(:)
+      nlejt(:)  = nlejt_full(:)
+      njmppt(:) = njmppt_full(:)
+
+   END SUBROUTINE dom_grid_glo
+
+
+   SUBROUTINE dom_grid_crs
+      !!--------------------------------------------------------------------
+      !!                       ***  MODULE dom_grid_crs  ***
+      !!
+      !! ** Purpose :  Save the parent grid information & Switch to coarse grid domain
+      !!---------------------------------------------------------------------
+      !
+      !                        Switch to coarse grid domain
+      jpi    = jpi_crs
+      jpj    = jpj_crs
+      jpim1  = jpi_crsm1
+      jpjm1  = jpj_crsm1
+      nperio = nperio_crs
+
+      npolj  = npolj_crs
+      jpiglo = jpiglo_crs
+      jpjglo = jpjglo_crs
+
+
+      nlci   = nlci_crs
+      nlcj   = nlcj_crs
+      nldi   = nldi_crs
+      nlei   = nlei_crs
+      nlej   = nlej_crs
+      nldj   = nldj_crs
+      nimpp  = nimpp_crs
+      njmpp  = njmpp_crs
+      
+      nlcit(:)  = nlcit_crs(:)
+      nldit(:)  = nldit_crs(:)
+      nleit(:)  = nleit_crs(:)
+      nimppt(:) = nimppt_crs(:)
+      nlcjt(:)  = nlcjt_crs(:)
+      nldjt(:)  = nldjt_crs(:)
+      nlejt(:)  = nlejt_crs(:)
+      njmppt(:) = njmppt_crs(:)
+      !
+   END SUBROUTINE dom_grid_crs
+   
+   !!======================================================================
+END MODULE crs
+
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/CRS/crsdom.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/CRS/crsdom.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/CRS/crsdom.F90	(revision 9570)
@@ -0,0 +1,2274 @@
+MODULE crsdom
+   !!===================================================================
+   !!                  ***  crs.F90 ***
+   !!  Purpose: Interface for calculating quantities from a  
+   !!           higher-resolution grid for the coarse grid.
+   !!
+   !!  Method:  Given the user-defined reduction factor, 
+   !!           the averaging bins are set: 
+   !!           - nn_binref = 0, starting from the north 
+   !!           to the south in the model interior domain, 
+   !!           in this way the north fold and redundant halo cells  
+   !!           could be handled in a consistent manner and 
+   !!           the irregularities of bin size can be handled
+   !!           more naturally by the presence of land
+   !!           in the southern boundary.  Thus the southernmost bin 
+   !!           could be of an irregular bin size.
+   !!           Information on the parent grid is retained, specifically,
+   !!           each coarse grid cell's volume and ocean surface 
+   !!           at the faces, relative to the parent grid.
+   !!           - nn_binref = 1 (not yet available), starting
+   !!           at a centralized bin at the equator, being only
+   !!           truly centered for odd-numbered j-direction reduction 
+   !!           factors.
+   !!  References:  Aumont, O., J.C. Orr, D. Jamous, P. Monfray
+   !!               O. Marti and G. Madec, 1998. A degradation 
+   !!               approach to accelerate simulations to steady-state 
+   !!               in a 3-D tracer transport model of the global ocean.
+   !!               Climate Dynamics, 14:101-116.
+   !!  History: 
+   !!       Original.   May 2012.  (J. Simeon, C. Calone, G. Madec, C. Ethe)
+   !!===================================================================
+   USE dom_oce        ! ocean space and time domain and to get jperio
+   USE crs            ! domain for coarse grid
+   !
+   USE in_out_manager 
+   USE par_kind
+   USE crslbclnk
+   USE lib_mpp
+
+   IMPLICIT NONE
+
+   PRIVATE 
+
+   PUBLIC crs_dom_ope
+   PUBLIC crs_dom_e3, crs_dom_sfc, crs_dom_msk, crs_dom_hgr, crs_dom_coordinates
+   PUBLIC crs_dom_facvol, crs_dom_def, crs_dom_bat
+
+   INTERFACE crs_dom_ope
+      MODULE PROCEDURE crs_dom_ope_3d, crs_dom_ope_2d
+   END INTERFACE
+
+   REAL(wp) :: r_inf = 1e+36
+
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO Consortium (2010)
+   !! $Id$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE crs_dom_msk
+      
+      INTEGER  ::  ji, jj, jk                   ! dummy loop indices
+      INTEGER  ::  ijie,ijis,ijje,ijjs,ij,je_2
+      REAL(wp) ::  zmask
+      
+      ! Initialize
+
+      tmask_crs(:,:,:) = 0.0
+      vmask_crs(:,:,:) = 0.0
+      umask_crs(:,:,:) = 0.0
+      fmask_crs(:,:,:) = 0.0
+  
+            
+      IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN     !!cc bande du sud style ORCA2
+         IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN
+            je_2 = mje_crs(2)   ;  ij = je_2
+         ENDIF
+      ELSE
+         je_2 = mje_crs(2)      ;  ij = mjs_crs(2) 
+      ENDIF
+      DO jk = 1, jpkm1
+         DO ji = 2, nlei_crs  
+            ijis = mis_crs(ji)  ;  ijie = mie_crs(ji)    
+            !          
+            zmask = 0.0
+            zmask = SUM( tmask(ijis:ijie,ij:je_2,jk) ) 
+            IF ( zmask > 0.0 ) tmask_crs(ji,2,jk) = 1.0
+               
+            zmask = 0.0
+            zmask = SUM( vmask(ijis:ijie,je_2     ,jk) )  
+            IF ( zmask > 0.0 ) vmask_crs(ji,2,jk) = 1.0
+               
+            zmask = 0.0
+            zmask = SUM(umask(ijie,ij:je_2,jk))   
+            IF ( zmask > 0.0 ) umask_crs(ji,2,jk) = 1.0
+               
+            fmask_crs(ji,je_2,jk) = fmask(ijie,2,jk)
+         ENDDO
+      ENDDO
+      !
+      DO jk = 1, jpkm1
+         DO ji = 2, nlei_crs  
+            ijis = mis_crs(ji)     ;   ijie = mie_crs(ji)       
+            DO jj = 3, nlej_crs
+               ijjs = mjs_crs(jj)  ;   ijje = mje_crs(jj)
+                          
+               zmask = 0.0
+               zmask = SUM( tmask(ijis:ijie,ijjs:ijje,jk) ) 
+               IF ( zmask > 0.0 ) tmask_crs(ji,jj,jk) = 1.0
+               
+               zmask = 0.0
+               zmask = SUM( vmask(ijis:ijie,ijje     ,jk) )  
+               IF ( zmask > 0.0 ) vmask_crs(ji,jj,jk) = 1.0
+               
+               zmask = 0.0
+               zmask = SUM( umask(ijie     ,ijjs:ijje,jk) )  
+               IF ( zmask > 0.0 ) umask_crs(ji,jj,jk) = 1.0
+               
+               fmask_crs(ji,jj,jk) = fmask(ijie,ijje,jk)  
+            ENDDO
+         ENDDO
+      ENDDO
+
+      !
+      CALL crs_lbc_lnk( tmask_crs, 'T', 1.0 )
+      CALL crs_lbc_lnk( vmask_crs, 'V', 1.0 )
+      CALL crs_lbc_lnk( umask_crs, 'U', 1.0 )
+      CALL crs_lbc_lnk( fmask_crs, 'F', 1.0 )
+      !
+   END SUBROUTINE crs_dom_msk
+
+
+   SUBROUTINE crs_dom_coordinates( p_gphi, p_glam, cd_type, p_gphi_crs, p_glam_crs )
+      !!----------------------------------------------------------------
+      !!               *** SUBROUTINE crs_coordinates ***
+      !! ** Purpose :  Determine the coordinates for the coarse grid
+      !! 
+      !! ** Method  :  From the parent grid subset, search for the central
+      !!               point.  For an odd-numbered reduction factor,
+      !!               the coordinate will be that of the central T-cell.
+      !!               For an even-numbered reduction factor, of a non-square
+      !!               coarse grid box, the coordinate will be that of 
+      !!               the east or north face or more likely.  For a square
+      !!               coarse grid box, the coordinate will be that of
+      !!               the central f-corner.
+      !!
+      !! ** Input   :  p_gphi = parent grid gphi[t|u|v|f]
+      !!               p_glam = parent grid glam[t|u|v|f]
+      !!               cd_type  = grid type (T,U,V,F)
+      !! ** Output  :  p_gphi_crs = coarse grid gphi[t|u|v|f]
+      !!               p_glam_crs = coarse grid glam[t|u|v|f]
+      !!              
+      !! History. 1 Jun.
+      !!----------------------------------------------------------------
+      !! Arguments
+      REAL(wp), DIMENSION(jpi,jpj)        , INTENT(in)  :: p_gphi  ! Parent grid latitude
+      REAL(wp), DIMENSION(jpi,jpj)        , INTENT(in)  :: p_glam  ! Parent grid longitude
+      CHARACTER(len=1),                     INTENT(in)  :: cd_type   ! grid type (T,U,V,F) 
+      REAL(wp), DIMENSION(jpi_crs,jpj_crs), INTENT(out) :: p_gphi_crs  ! Coarse grid latitude
+      REAL(wp), DIMENSION(jpi_crs,jpj_crs), INTENT(out) :: p_glam_crs  ! Coarse grid longitude
+
+      !! Local variables
+      INTEGER :: ji, jj, jk                   ! dummy loop indices
+      INTEGER :: ijis, ijjs
+
+  
+      SELECT CASE ( cd_type )
+         CASE ( 'T' )
+            DO jj =  nldj_crs, nlej_crs
+               ijjs = mjs_crs(jj) + mybinctr
+               DO ji = 2, nlei_crs
+                  ijis = mis_crs(ji) + mxbinctr 
+                  p_gphi_crs(ji,jj) = p_gphi(ijis,ijjs)
+                  p_glam_crs(ji,jj) = p_glam(ijis,ijjs)
+               ENDDO
+            ENDDO
+         CASE ( 'U' )
+            DO jj =  nldj_crs, nlej_crs
+               ijjs = mjs_crs(jj) + mybinctr                  
+               DO ji = 2, nlei_crs
+                  ijis = mis_crs(ji)
+                  p_gphi_crs(ji,jj) = p_gphi(ijis,ijjs)
+                  p_glam_crs(ji,jj) = p_glam(ijis,ijjs)
+               ENDDO
+            ENDDO
+         CASE ( 'V' )
+            DO jj =  nldj_crs, nlej_crs
+               ijjs = mjs_crs(jj)
+               DO ji = 2, nlei_crs
+                  ijis = mis_crs(ji) + mxbinctr 
+                  p_gphi_crs(ji,jj) = p_gphi(ijis,ijjs)
+                  p_glam_crs(ji,jj) = p_glam(ijis,ijjs)
+               ENDDO
+            ENDDO
+         CASE ( 'F' )
+            DO jj =  nldj_crs, nlej_crs
+               ijjs = mjs_crs(jj)
+               DO ji = 2, nlei_crs
+                  ijis = mis_crs(ji)
+                  p_gphi_crs(ji,jj) = p_gphi(ijis,ijjs)
+                  p_glam_crs(ji,jj) = p_glam(ijis,ijjs)
+               ENDDO
+            ENDDO
+      END SELECT
+
+      ! Retroactively add back the boundary halo cells.
+      CALL crs_lbc_lnk( p_gphi_crs, cd_type, 1.0 )
+      CALL crs_lbc_lnk( p_glam_crs, cd_type, 1.0 )
+         
+      ! Fill up jrow=1 which is zeroed out or not handled by lbc_lnk and lbc_nfd
+      SELECT CASE ( cd_type )
+         CASE ( 'T', 'V' )
+            DO ji = 2, nlei_crs
+               ijis = mis_crs(ji) + mxbinctr 
+               p_gphi_crs(ji,1) = p_gphi(ijis,1)
+               p_glam_crs(ji,1) = p_glam(ijis,1)
+            ENDDO
+         CASE ( 'U', 'F' )
+            DO ji = 2, nlei_crs
+               ijis = mis_crs(ji) 
+               p_gphi_crs(ji,1) = p_gphi(ijis,1)
+               p_glam_crs(ji,1) = p_glam(ijis,1)
+            ENDDO
+      END SELECT
+      !
+   END SUBROUTINE crs_dom_coordinates
+
+  SUBROUTINE crs_dom_hgr( p_e1, p_e2, cd_type, p_e1_crs, p_e2_crs )
+      !!----------------------------------------------------------------
+      !!               *** SUBROUTINE crs_dom_hgr ***
+      !!
+      !! ** Purpose :  Get coarse grid horizontal scale factors and unmasked fraction
+      !!
+      !! ** Method  :  For grid types T,U,V,Fthe 2D scale factors of 
+      !!               the coarse grid are the sum of the east or north faces of the 
+      !!               parent grid subset comprising the coarse grid box.     
+      !!               - e1,e2 Scale factors
+      !!                 Valid arguments: 
+      !! ** Inputs  : p_e1, p_e2  = parent grid e1 or e2 (t,u,v,f)
+      !!              cd_type     = grid type (T,U,V,F) for scale factors; for velocities (U or V)
+      !! ** Outputs : p_e1_crs, p_e2_crs  = parent grid e1 or e2 (t,u,v,f)
+      !!
+      !! History.     4 Jun.  Write for WGT and scale factors only
+      !!----------------------------------------------------------------
+      !! 
+      !!  Arguments
+      REAL(wp), DIMENSION(jpi,jpj)        , INTENT(in)  :: p_e1     ! Parent grid U,V scale factors (e1)
+      REAL(wp), DIMENSION(jpi,jpj)        , INTENT(in)  :: p_e2     ! Parent grid U,V scale factors (e2)
+      CHARACTER(len=1)                    , INTENT(in)  :: cd_type  ! grid type U,V 
+
+      REAL(wp), DIMENSION(jpi_crs,jpj_crs), INTENT(out) :: p_e1_crs ! Coarse grid box 2D quantity
+      REAL(wp), DIMENSION(jpi_crs,jpj_crs), INTENT(out) :: p_e2_crs ! Coarse grid box 2D quantity
+
+      !! Local variables
+      INTEGER :: ji, jj, jk     ! dummy loop indices
+      INTEGER :: ijie,ijje,ijrs
+  
+      !!----------------------------------------------------------------  
+      ! Initialize      
+
+      DO jk = 1, jpk    
+         DO ji = 2, nlei_crs
+            ijie = mie_crs(ji)
+            DO jj = nldj_crs, nlej_crs
+               ijje = mje_crs(jj)   ;   ijrs =  mje_crs(jj) - mjs_crs(jj)
+               ! Only for a factro 3 coarsening
+               SELECT CASE ( cd_type )
+                   CASE ( 'T' )
+                      IF( ijrs == 0 .OR. ijrs == 1 ) THEN
+                        ! Si à la frontière sud on a pas assez de maille de la grille mère
+                         p_e1_crs(ji,jj) = p_e1(ijie-1,ijje) * nn_factx
+                         p_e2_crs(ji,jj) = p_e2(ijie-1,ijje) * nn_facty
+                      ELSE
+                         p_e1_crs(ji,jj) = p_e1(ijie-1,ijje-1) * nn_factx
+                         p_e2_crs(ji,jj) = p_e2(ijie-1,ijje-1) * nn_facty
+                      ENDIF
+                   CASE ( 'U' )
+                      IF( ijrs == 0 .OR. ijrs == 1 ) THEN
+                         ! Si à la frontière sud on a pas assez de maille de la grille mère
+                         p_e1_crs(ji,jj) = p_e1(ijie,ijje) * nn_factx                            
+                         p_e2_crs(ji,jj) = p_e2(ijie,ijje) * nn_facty
+                      ELSE
+                         p_e1_crs(ji,jj) = p_e1(ijie,ijje-1) * nn_factx
+                         p_e2_crs(ji,jj) = p_e2(ijie,ijje-1) * nn_facty
+                      ENDIF
+                   CASE ( 'V' )
+                         p_e1_crs(ji,jj) = p_e1(ijie-1,ijje) * nn_factx                            
+                         p_e2_crs(ji,jj) = p_e2(ijie-1,ijje) * nn_facty
+                   CASE ( 'F' )
+                         p_e1_crs(ji,jj) = p_e1(ijie,ijje) * nn_factx                            
+                         p_e2_crs(ji,jj) = p_e2(ijie,ijje) * nn_facty
+               END SELECT
+            ENDDO
+         ENDDO
+      ENDDO
+
+      CALL crs_lbc_lnk( p_e1_crs, cd_type, 1.0, pval=1.0 )
+      CALL crs_lbc_lnk( p_e2_crs, cd_type, 1.0, pval=1.0 )
+
+   END SUBROUTINE crs_dom_hgr
+
+
+   SUBROUTINE crs_dom_facvol( p_mask, cd_type, p_e1, p_e2, p_e3, p_fld1_crs, p_fld2_crs )
+      !!----------------------------------------------------------------
+      !!               *** SUBROUTINE crsfun_wgt ***
+      !! ** Purpose :  Three applications.
+      !!               1) SUM. Get coarse grid horizontal scale factors and unmasked fraction
+      !!               2) VOL. Get coarse grid box volumes
+      !!               3) WGT. Weighting multiplier for volume-weighted and/or
+      !!                       area-weighted averages.
+      !!                       Weights (i.e. the denominator) calculated here 
+      !!                       to avoid IF-tests and division.
+      !! ** Method  :  1) SUM.  For grid types T,U,V,F (and W) the 2D scale factors of 
+      !!               the coarse grid are the sum of the east or north faces of the 
+      !!               parent grid subset comprising the coarse grid box.  
+      !!               The fractions of masked:total surface (3D) on the east, 
+      !!               north and top faces is, optionally, also output.
+      !!               - Top face area sum
+      !!                 Valid arguments: cd_type, cd_op='W', p_pmask, p_e1, p_e2 
+      !!               - Top face ocean surface fraction
+      !!                 Valid arguments: cd_type, cd_op='W', p_pmask, p_e1, p_e2       
+      !!               - e1,e2 Scale factors
+      !!                 Valid arguments: 
+      !!               2) VOL.  For grid types W and T, the coarse grid box
+      !!               volumes are output. Also optionally, the fraction of  
+      !!               masked:total volume of the parent grid subset is output (i.e. facvol).
+      !!               3) WGT. Based on the grid type, the denominator is pre-determined here to  
+      !!               perform area- or volume- weighted averages, 
+      !!               to avoid IF-tests and divisions.
+      !! ** Inputs  : p_e1, p_e2  = parent grid e1 or e2 (t,u,v,f)
+      !!              p_pmask     = parent grid mask (T,U,V,F) 
+      !!              cd_type     = grid type (T,U,V,F) for scale factors; for velocities (U or V)
+      !!              cd_op       = applied operation (SUM, VOL, WGT)
+      !!              p_e3      = (Optional) parent grid vertical level thickness (e3u or e3v)
+      !! ** Outputs : p_cfield2d_1 = (Optional) 2D field on coarse grid
+      !!              p_cfield2d_2 = (Optional) 2D field on coarse grid
+      !!              p_cfield3d_1 = (Optional) 3D field on coarse grid
+      !!              p_cfield3d_2 = (Optional) 3D field on coarse grid
+      !!
+      !! History.     4 Jun.  Write for WGT and scale factors only
+      !!----------------------------------------------------------------
+      CHARACTER(len=1),                         INTENT(in   ) ::   cd_type    ! grid type U,V 
+      REAL(wp), DIMENSION(jpi,jpj,jpk)        , INTENT(in   ) ::   p_mask     ! Parent grid U,V mask
+      REAL(wp), DIMENSION(jpi,jpj)            , INTENT(in   ) ::   p_e1       ! Parent grid U,V scale factors (e1)
+      REAL(wp), DIMENSION(jpi,jpj)            , INTENT(in   ) ::   p_e2       ! Parent grid U,V scale factors (e2)
+      REAL(wp), DIMENSION(jpi,jpj,jpk)        , INTENT(in   ) ::   p_e3       ! Parent grid vertical level thickness (e3u, e3v)
+      REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(  out) ::   p_fld1_crs ! Coarse grid box 3D quantity 
+      REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(  out) ::   p_fld2_crs ! Coarse grid box 3D quantity 
+      !
+      INTEGER  ::   ji, jj, jk , ii, ij, je_2
+      REAL(wp) ::   zdAm
+      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zvol, zmask      
+      !!----------------------------------------------------------------  
+      !
+      !
+      p_fld1_crs(:,:,:) = 0._wp
+      p_fld2_crs(:,:,:) = 0._wp
+
+      DO jk = 1, jpk
+         zvol(:,:,jk) =  p_e1(:,:) * p_e2(:,:) * p_e3(:,:,jk) 
+      END DO
+
+      zmask(:,:,:) = 0._wp
+      IF( cd_type == 'W' ) THEN
+         zmask(:,:,1) = p_mask(:,:,1) 
+         DO jk = 2, jpk
+            zmask(:,:,jk) = p_mask(:,:,jk-1) 
+         ENDDO
+      ELSE
+         DO jk = 1, jpk
+             zmask(:,:,jk) = p_mask(:,:,jk) 
+         ENDDO
+      ENDIF
+
+      IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN     !!cc bande du sud style ORCA2
+         IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN
+            je_2 = mje_crs(2)
+            DO jk = 1, jpk           
+               DO ji = nistr, niend, nn_factx
+                  ii   = ( ji - mis_crs(2) ) * rfactx_r + 2                 ! cordinate in parent grid
+                  p_fld1_crs(ii,2,jk) =  zvol(ji,je_2  ,jk) + zvol(ji+1,je_2  ,jk) + zvol(ji+2,je_2  ,jk)  &
+                     &                 + zvol(ji,je_2-1,jk) + zvol(ji+1,je_2-1,jk) + zvol(ji+2,je_2-1,jk) 
+                  !
+                  zdAm =  zvol(ji  ,je_2,jk) * zmask(ji  ,je_2,jk)  &
+                    &   + zvol(ji+1,je_2,jk) * zmask(ji+1,je_2,jk)  &
+                    &   + zvol(ji+2,je_2,jk) * zmask(ji+2,je_2,jk) 
+                  ! 
+                  p_fld2_crs(ii,2,jk) = zdAm / p_fld1_crs(ii,2,jk) 
+               ENDDO
+            ENDDO
+         ENDIF
+      ELSE
+         je_2 = mjs_crs(2)
+         DO jk = 1, jpk           
+            DO ji = nistr, niend, nn_factx
+               ii   = ( ji - mis_crs(2) ) * rfactx_r + 2    
+               p_fld1_crs(ii,2,jk) =  zvol(ji,je_2  ,jk) + zvol(ji+1,je_2  ,jk) + zvol(ji+2,je_2  ,jk)  &
+                   &                + zvol(ji,je_2+1,jk) + zvol(ji+1,je_2+1,jk) + zvol(ji+2,je_2+1,jk)  &
+                   &                + zvol(ji,je_2+2,jk) + zvol(ji+1,je_2+2,jk) + zvol(ji+2,je_2+2,jk)  
+              !
+               zdAm = zvol(ji  ,je_2  ,jk) * zmask(ji  ,je_2  ,jk)  &
+                 &  + zvol(ji+1,je_2  ,jk) * zmask(ji+1,je_2  ,jk)  &
+                 &  + zvol(ji+2,je_2  ,jk) * zmask(ji+2,je_2  ,jk)  &
+                 &  + zvol(ji  ,je_2+1,jk) * zmask(ji  ,je_2+1,jk)  &
+                 &  + zvol(ji+1,je_2+1,jk) * zmask(ji+1,je_2+1,jk)  &
+                 &  + zvol(ji+2,je_2+1,jk) * zmask(ji+2,je_2+1,jk)  &
+                 &  + zvol(ji  ,je_2+2,jk) * zmask(ji  ,je_2+2,jk)  &
+                 &  + zvol(ji+1,je_2+2,jk) * zmask(ji+1,je_2+2,jk)  &
+                 &  + zvol(ji+2,je_2+2,jk) * zmask(ji+2,je_2+2,jk)
+                 ! 
+                 p_fld2_crs(ii,2,jk) = zdAm / p_fld1_crs(ii,2,jk) 
+            ENDDO
+         ENDDO
+      ENDIF
+
+      DO jk = 1, jpk           
+         DO jj  = njstr, njend, nn_facty
+            DO ji = nistr, niend, nn_factx
+               ii  = ( ji - mis_crs(2) ) * rfactx_r + 2                 ! cordinate in parent grid
+               ij  = ( jj - njstr ) * rfacty_r + 3
+               !
+               p_fld1_crs(ii,ij,jk) =  zvol(ji,jj  ,jk) + zvol(ji+1,jj  ,jk) + zvol(ji+2,jj  ,jk)  &
+                   &                 + zvol(ji,jj+1,jk) + zvol(ji+1,jj+1,jk) + zvol(ji+2,jj+1,jk)  &
+                   &                 + zvol(ji,jj+2,jk) + zvol(ji+1,jj+2,jk) + zvol(ji+2,jj+2,jk) 
+               !
+               zdAm =  zvol(ji  ,jj  ,jk) * zmask(ji  ,jj  ,jk)  &
+                 &   + zvol(ji+1,jj  ,jk) * zmask(ji+1,jj  ,jk)  &
+                 &   + zvol(ji+2,jj  ,jk) * zmask(ji+2,jj  ,jk)  &
+                 &   + zvol(ji  ,jj+1,jk) * zmask(ji  ,jj+1,jk)  &
+                 &   + zvol(ji+1,jj+1,jk) * zmask(ji+1,jj+1,jk)  &
+                 &   + zvol(ji+2,jj+1,jk) * zmask(ji+2,jj+1,jk)  &
+                 &   + zvol(ji  ,jj+2,jk) * zmask(ji  ,jj+2,jk)  &
+                 &   + zvol(ji+1,jj+2,jk) * zmask(ji+1,jj+2,jk)  &
+                 &   + zvol(ji+2,jj+2,jk) * zmask(ji+2,jj+2,jk)
+                 ! 
+                p_fld2_crs(ii,ij,jk) = zdAm / p_fld1_crs(ii,ij,jk) 
+            ENDDO
+         ENDDO
+      ENDDO
+      !                                             !  Retroactively add back the boundary halo cells.
+      CALL crs_lbc_lnk( p_fld1_crs, cd_type, 1.0 ) 
+      CALL crs_lbc_lnk( p_fld2_crs, cd_type, 1.0 ) 
+      !
+      !
+   END SUBROUTINE crs_dom_facvol
+
+
+   SUBROUTINE crs_dom_ope_3d( p_fld, cd_op, cd_type, p_mask, p_fld_crs, p_e12, p_e3, p_surf_crs, p_mask_crs, psgn )
+      !!----------------------------------------------------------------
+      !!               *** SUBROUTINE crsfun_UV ***
+      !! ** Purpose :  Average, area-weighted, of U or V on the east and north faces 
+      !!
+      !! ** Method  :  The U and V velocities (3D) are determined as the area-weighted averages
+      !!               on the east and north faces, respectively,
+      !!               of the parent grid subset comprising the coarse grid box. 
+      !!               In the case of the V and F grid, the last jrow minus 1 is spurious.
+      !! ** Inputs  : p_e1_e2     = parent grid e1 or e2 (t,u,v,f)
+      !!              cd_type     = grid type (T,U,V,F) for scale factors; for velocities (U or V)
+      !!              psgn        = sign change over north fold (See lbclnk.F90)
+      !!              p_pmask     = parent grid mask (T,U,V,F) for scale factors; 
+      !!                                       for velocities (U or V)
+      !!              p_e3      = parent grid vertical level thickness (e3u or e3v)
+      !!              p_pfield    = U or V on the parent grid
+      !!              p_surf_crs  = (Optional) Coarse grid weight for averaging
+      !! ** Outputs : p_cfield3d = 3D field on coarse grid
+      !!
+      !! History.  29 May.  completed draft.
+      !!            4 Jun.  Revision for WGT
+      !!            5 Jun.  Streamline for area-weighted average only ; separate scale factor and weights.
+      !!----------------------------------------------------------------
+      REAL(wp), DIMENSION(jpi,jpj,jpk),         INTENT(in)           :: p_fld      ! T, U, V or W on parent grid
+      CHARACTER(len=3),                         INTENT(in)           :: cd_op      ! Operation SUM, MAX or MIN
+      CHARACTER(len=1),                         INTENT(in)           :: cd_type    ! grid type U,V 
+      REAL(wp), DIMENSION(jpi,jpj,jpk),         INTENT(in)           :: p_mask     ! Parent grid T,U,V mask
+      REAL(wp), DIMENSION(jpi,jpj),             INTENT(in), OPTIONAL :: p_e12      ! Parent grid T,U,V scale factors (e1 or e2)
+      REAL(wp), DIMENSION(jpi,jpj,jpk),         INTENT(in), OPTIONAL :: p_e3       ! Parent grid vertical level thickness (e3u, e3v)
+      REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(in), OPTIONAL :: p_surf_crs ! Coarse grid area-weighting denominator    
+      REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(in), OPTIONAL :: p_mask_crs ! Coarse grid T,U,V maska
+      REAL(wp),                                 INTENT(in)           :: psgn       ! sign 
+      REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(  out)        :: p_fld_crs  ! Coarse grid box 3D quantity 
+      !
+      INTEGER  ::   ji, jj, jk 
+      INTEGER  ::   ii, ij, ijie, ijje, je_2
+      REAL(wp) ::   zflcrs, zsfcrs   
+      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::   zsurf, zsurfmsk, zmask  
+      !!----------------------------------------------------------------  
+      !
+      p_fld_crs(:,:,:) = 0._wp
+      !
+      SELECT CASE ( cd_op )
+      !
+      CASE ( 'VOL' )
+         !
+         ALLOCATE( zsurf(jpi,jpj,jpk), zsurfmsk(jpi,jpj,jpk) )
+         !   
+         SELECT CASE ( cd_type )
+         !   
+         CASE( 'T', 'W' )
+               IF( cd_type == 'T' ) THEN
+                     DO jk = 1, jpk
+                        zsurf   (:,:,jk) =  p_e12(:,:) * p_e3(:,:,jk) *  p_mask(:,:,jk) 
+                        zsurfmsk(:,:,jk) =  zsurf(:,:,jk) 
+                    ENDDO
+                  ELSE
+                     zsurf   (:,:,1) =  p_e12(:,:) * p_e3(:,:,1)
+                     zsurfmsk(:,:,1) =  zsurf(:,:,1) *  p_mask(:,:,1) 
+                     DO jk = 2, jpk
+                        zsurf   (:,:,jk) =  p_e12(:,:) * p_e3(:,:,jk)
+                        zsurfmsk(:,:,jk) =  zsurf(:,:,jk) * p_mask(:,:,jk-1) 
+                     ENDDO
+                  ENDIF
+         
+                  IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN     !!cc bande du sud style ORCA2
+                     IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN
+                        je_2 = mje_crs(2)
+                        DO jk = 1, jpk           
+                           DO ji = nistr, niend, nn_factx
+                              ii   = ( ji - mis_crs(2) ) * rfactx_r + 2       
+                              zflcrs =  p_fld(ji  ,je_2,jk) * zsurfmsk(ji  ,je_2,jk)   &
+                                &     + p_fld(ji+1,je_2,jk) * zsurfmsk(ji+1,je_2,jk)   &
+                                &     + p_fld(ji+2,je_2,jk) * zsurfmsk(ji+2,je_2,jk) 
+ 
+                              zsfcrs =  zsurf(ji,je_2,jk) + zsurf(ji+1,je_2,jk) + zsurf(ji+2,je_2,jk) 
+                              !
+                              p_fld_crs(ii,2,jk) = zflcrs
+                              IF( zsfcrs /= 0.0 )  p_fld_crs(ii,2,jk) = zflcrs / zsfcrs
+                           ENDDO
+                        ENDDO
+                     ENDIF
+                  ELSE
+                     je_2 = mjs_crs(2)
+                     DO jk = 1, jpk           
+                        DO ji = nistr, niend, nn_factx
+                           ii   = ( ji - mis_crs(2) ) * rfactx_r + 2   
+                           zflcrs =  p_fld(ji  ,je_2  ,jk) * zsurfmsk(ji  ,je_2  ,jk) &
+                             &     + p_fld(ji+1,je_2  ,jk) * zsurfmsk(ji+1,je_2  ,jk) &
+                             &     + p_fld(ji+2,je_2  ,jk) * zsurfmsk(ji+2,je_2  ,jk) &
+                             &     + p_fld(ji  ,je_2+1,jk) * zsurfmsk(ji  ,je_2+1,jk) &
+                             &     + p_fld(ji+1,je_2+1,jk) * zsurfmsk(ji+1,je_2+1,jk) &
+                             &     + p_fld(ji+2,je_2+1,jk) * zsurfmsk(ji+2,je_2+1,jk) &
+                             &     + p_fld(ji  ,je_2+2,jk) * zsurfmsk(ji  ,je_2+2,jk) &
+                             &     + p_fld(ji+1,je_2+2,jk) * zsurfmsk(ji+1,je_2+2,jk) &
+                             &     + p_fld(ji+2,je_2+2,jk) * zsurfmsk(ji+2,je_2+2,jk) 
+
+                           zsfcrs =  zsurf(ji,je_2  ,jk) + zsurf(ji+1,je_2  ,jk) + zsurf(ji+2,je_2  ,jk) &
+                             &     + zsurf(ji,je_2+1,jk) + zsurf(ji+1,je_2+1,jk) + zsurf(ji+2,je_2+1,jk) &
+                             &     + zsurf(ji,je_2+2,jk) + zsurf(ji+1,je_2+2,jk) + zsurf(ji+2,je_2+2,jk) 
+                            !
+                            p_fld_crs(ii,2,jk) = zflcrs
+                            IF( zsfcrs /= 0.0 )  p_fld_crs(ii,2,jk) = zflcrs / zsfcrs
+                        ENDDO
+                     ENDDO
+                  ENDIF
+                  !
+                  DO jk = 1, jpk           
+                     DO jj  = njstr, njend, nn_facty
+                        DO ji = nistr, niend, nn_factx
+                           ii = ( ji - mis_crs(2) ) * rfactx_r + 2                 ! cordinate in parent grid
+                           ij = ( jj - njstr ) * rfacty_r + 3
+                           zflcrs =  p_fld(ji  ,jj  ,jk) * zsurfmsk(ji  ,jj  ,jk) &
+                             &     + p_fld(ji+1,jj  ,jk) * zsurfmsk(ji+1,jj  ,jk) &
+                             &     + p_fld(ji+2,jj  ,jk) * zsurfmsk(ji+2,jj  ,jk) &
+                             &     + p_fld(ji  ,jj+1,jk) * zsurfmsk(ji  ,jj+1,jk) &
+                             &     + p_fld(ji+1,jj+1,jk) * zsurfmsk(ji+1,jj+1,jk) &
+                             &     + p_fld(ji+2,jj+1,jk) * zsurfmsk(ji+2,jj+1,jk) &
+                             &     + p_fld(ji  ,jj+2,jk) * zsurfmsk(ji  ,jj+2,jk) &
+                             &     + p_fld(ji+1,jj+2,jk) * zsurfmsk(ji+1,jj+2,jk) &
+                             &     + p_fld(ji+2,jj+2,jk) * zsurfmsk(ji+2,jj+2,jk) 
+
+                           zsfcrs =  zsurf(ji,jj  ,jk) + zsurf(ji+1,jj  ,jk) + zsurf(ji+2,jj  ,jk) &
+                             &     + zsurf(ji,jj+1,jk) + zsurf(ji+1,jj+1,jk) + zsurf(ji+2,jj+1,jk) &
+                             &     + zsurf(ji,jj+2,jk) + zsurf(ji+1,jj+2,jk) + zsurf(ji+2,jj+2,jk) 
+                            !
+                           p_fld_crs(ii,ij,jk) = zflcrs
+                           IF( zsfcrs /= 0.0 )  p_fld_crs(ii,ij,jk) = zflcrs / zsfcrs
+                        ENDDO      
+                     ENDDO
+                  ENDDO  
+               CASE DEFAULT
+                    STOP
+               END SELECT
+
+              DEALLOCATE( zsurf, zsurfmsk )
+
+         CASE ( 'SUM' )
+         
+            ALLOCATE( zsurfmsk(jpi,jpj,jpk) )
+
+            SELECT CASE ( cd_type )
+              CASE( 'W' )
+                  IF( PRESENT( p_e3 ) ) THEN
+                    zsurfmsk(:,:,1) =  p_e12(:,:) * p_e3(:,:,1) * p_mask(:,:,1) 
+                    DO jk = 2, jpk
+                      zsurfmsk(:,:,jk) =  p_e12(:,:) * p_e3(:,:,jk) * p_mask(:,:,jk-1) 
+                    ENDDO
+                 ELSE
+                    zsurfmsk(:,:,1) =  p_e12(:,:) * p_mask(:,:,1) 
+                    DO jk = 2, jpk
+                      zsurfmsk(:,:,jk) =  p_e12(:,:) * p_mask(:,:,jk-1) 
+                    ENDDO
+                 ENDIF
+              CASE DEFAULT
+                 IF( PRESENT( p_e3 ) ) THEN
+                    DO jk = 1, jpk
+                      zsurfmsk(:,:,jk) =  p_e12(:,:) * p_e3(:,:,jk) * p_mask(:,:,jk) 
+                    ENDDO
+                 ELSE
+                    DO jk = 1, jpk
+                      zsurfmsk(:,:,jk) =  p_e12(:,:) * p_mask(:,:,jk) 
+                    ENDDO
+                 ENDIF
+              END SELECT
+
+            SELECT CASE ( cd_type )
+            
+               CASE( 'T', 'W' )
+         
+                  IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN     !!cc bande du sud style ORCA2
+                     IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN
+                        je_2 = mje_crs(2)
+                        DO jk = 1, jpk           
+                           DO ji = nistr, niend, nn_factx
+                              ii   = ( ji - mis_crs(2) ) * rfactx_r + 2          
+                              zflcrs  =  p_fld(ji  ,je_2,jk) * zsurfmsk(ji  ,je_2,jk) &
+                                &      + p_fld(ji+1,je_2,jk) * zsurfmsk(ji+1,je_2,jk) &
+                                &      + p_fld(ji+2,je_2,jk) * zsurfmsk(ji+2,je_2,jk) 
+                               !
+                              p_fld_crs(ii,2,jk) = zflcrs
+                           ENDDO
+                        ENDDO
+                      ENDIF
+                  ELSE
+                     je_2 = mjs_crs(2)
+                     DO jk = 1, jpk           
+                        DO ji = nistr, niend, nn_factx
+                           ii   = ( ji - mis_crs(2) ) * rfactx_r + 2   
+                           zflcrs  =  p_fld(ji  ,je_2  ,jk) * zsurfmsk(ji  ,je_2  ,jk)  &
+                             &      + p_fld(ji+1,je_2  ,jk) * zsurfmsk(ji+1,je_2  ,jk)  &
+                             &      + p_fld(ji+2,je_2  ,jk) * zsurfmsk(ji+2,je_2  ,jk)  &
+                             &      + p_fld(ji  ,je_2+1,jk) * zsurfmsk(ji  ,je_2+1,jk)  &
+                             &      + p_fld(ji+1,je_2+1,jk) * zsurfmsk(ji+1,je_2+1,jk)  &
+                             &      + p_fld(ji+2,je_2+1,jk) * zsurfmsk(ji+2,je_2+1,jk)  &
+                             &      + p_fld(ji  ,je_2+2,jk) * zsurfmsk(ji  ,je_2+2,jk)  &
+                             &      + p_fld(ji+1,je_2+2,jk) * zsurfmsk(ji+1,je_2+2,jk)  &
+                             &      + p_fld(ji+2,je_2+2,jk) * zsurfmsk(ji+2,je_2+2,jk)  
+                            !
+                            p_fld_crs(ii,2,jk) = zflcrs
+                        ENDDO
+                     ENDDO
+                  ENDIF
+                  !
+                  DO jk = 1, jpk           
+                     DO jj  = njstr, njend, nn_facty
+                        DO ji = nistr, niend, nn_factx
+                           ii  = ( ji - mis_crs(2) ) * rfactx_r + 2                 ! cordinate in parent grid
+                           ij  = ( jj - njstr ) * rfacty_r + 3
+                           zflcrs  =  p_fld(ji  ,jj  ,jk) * zsurfmsk(ji  ,jj  ,jk)  &
+                             &      + p_fld(ji+1,jj  ,jk) * zsurfmsk(ji+1,jj  ,jk)  &
+                             &      + p_fld(ji+2,jj  ,jk) * zsurfmsk(ji+2,jj  ,jk)  &
+                             &      + p_fld(ji  ,jj+1,jk) * zsurfmsk(ji  ,jj+1,jk)  &
+                             &      + p_fld(ji+1,jj+1,jk) * zsurfmsk(ji+1,jj+1,jk)  &
+                             &      + p_fld(ji+2,jj+1,jk) * zsurfmsk(ji+2,jj+1,jk)  &
+                             &      + p_fld(ji  ,jj+2,jk) * zsurfmsk(ji  ,jj+2,jk)  &
+                             &      + p_fld(ji+1,jj+2,jk) * zsurfmsk(ji+1,jj+2,jk)  &
+                             &      + p_fld(ji+2,jj+2,jk) * zsurfmsk(ji+2,jj+2,jk)  
+                            !
+                            p_fld_crs(ii,ij,jk) = zflcrs
+                            ! 
+                        ENDDO      
+                     ENDDO
+                  ENDDO   
+            
+               CASE( 'V' )
+
+                  IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN     !!cc bande du sud style ORCA2
+                     IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN
+                        ijje = mje_crs(2)
+                     ENDIF
+                  ELSE
+                     ijje = mjs_crs(2)
+                  ENDIF
+                  !
+                  DO jk = 1, jpk           
+                     DO ji = nistr, niend, nn_factx
+                        ii   = ( ji - mis_crs(2) ) * rfactx_r + 2    
+                        zflcrs  =  p_fld(ji  ,ijje,jk) * zsurfmsk(ji  ,ijje,jk) &
+                          &      + p_fld(ji+1,ijje,jk) * zsurfmsk(ji+1,ijje,jk) &
+                          &      + p_fld(ji+2,ijje,jk) * zsurfmsk(ji+2,ijje,jk) 
+                          !
+                        p_fld_crs(ii,2,jk) = zflcrs
+                     ENDDO
+                  ENDDO
+                  !
+                  DO jk = 1, jpk           
+                     DO jj  = njstr, njend, nn_facty
+                        DO ji = nistr, niend, nn_factx
+                           ii   = ( ji - mis_crs(2) ) * rfactx_r + 2                 ! cordinate in parent grid
+                           ij   = ( jj - njstr ) * rfacty_r + 3
+                           ijje = mje_crs(ij)
+                           zflcrs  =  p_fld(ji  ,ijje,jk) * zsurfmsk(ji  ,ijje,jk) &
+                             &      + p_fld(ji+1,ijje,jk) * zsurfmsk(ji+1,ijje,jk) &
+                             &      + p_fld(ji+2,ijje,jk) * zsurfmsk(ji+2,ijje,jk) 
+                             !
+                           p_fld_crs(ii,ij,jk) = zflcrs
+                           ! 
+                        ENDDO      
+                     ENDDO
+                  ENDDO   
+            
+               CASE( 'U' )
+
+                  IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN     !!cc bande du sud style ORCA2
+                     IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN
+                        je_2 = mje_crs(2)
+                        DO jk = 1, jpk           
+                           DO ji = nistr, niend, nn_factx
+                              ii   = ( ji - mis_crs(2) ) * rfactx_r + 2  
+                              ijie = mie_crs(ii)
+                              zflcrs  =  p_fld(ijie,je_2,jk) * zsurfmsk(ijie,je_2,jk)  
+                              p_fld_crs(ii,2,jk) = zflcrs
+                           ENDDO
+                        ENDDO
+                      ENDIF
+                  ELSE
+                     je_2 = mjs_crs(2)
+                     DO jk = 1, jpk           
+                        DO ji = nistr, niend, nn_factx
+                           ii   = ( ji - mis_crs(2) ) * rfactx_r + 2   
+                           ijie = mie_crs(ii)
+                           zflcrs =  p_fld(ijie,je_2  ,jk) * zsurfmsk(ijie,je_2  ,jk)  &
+                             &     + p_fld(ijie,je_2+1,jk) * zsurfmsk(ijie,je_2+1,jk)  &
+                             &     + p_fld(ijie,je_2+2,jk) * zsurfmsk(ijie,je_2+2,jk) 
+
+                           p_fld_crs(ii,2,jk) = zflcrs
+                        ENDDO
+                     ENDDO
+                  ENDIF
+                  !
+                  DO jk = 1, jpk           
+                     DO jj  = njstr, njend, nn_facty
+                        DO ji = nistr, niend, nn_factx
+                           ii   = ( ji - mis_crs(2) ) * rfactx_r + 2     
+                           ij   = ( jj - njstr ) * rfacty_r + 3
+                           ijie = mie_crs(ii)
+                           zflcrs =  p_fld(ijie,jj  ,jk) * zsurfmsk(ijie,jj  ,jk)  &
+                              &    + p_fld(ijie,jj+1,jk) * zsurfmsk(ijie,jj+1,jk)  &
+                              &    + p_fld(ijie,jj+2,jk) * zsurfmsk(ijie,jj+2,jk) 
+                             !
+                           p_fld_crs(ii,ij,jk) = zflcrs
+                           ! 
+                        ENDDO      
+                     ENDDO
+                  ENDDO   
+
+              END SELECT
+
+              IF( PRESENT( p_surf_crs ) ) THEN
+                 WHERE ( p_surf_crs /= 0.0 ) p_fld_crs(:,:,:) = p_fld_crs(:,:,:) / p_surf_crs(:,:,:)
+              ENDIF
+
+              DEALLOCATE( zsurfmsk )
+
+         CASE ( 'MAX' )    !  search the max of unmasked grid cells
+
+            ALLOCATE( zmask(jpi,jpj,jpk) )
+
+            SELECT CASE ( cd_type )
+              CASE( 'W' )
+                  zmask(:,:,1) = p_mask(:,:,1) 
+                  DO jk = 2, jpk
+                     zmask(:,:,jk) = p_mask(:,:,jk-1) 
+                  ENDDO
+              CASE ( 'T' )
+                  DO jk = 1, jpk
+                     zmask(:,:,jk) = p_mask(:,:,jk) 
+                  ENDDO
+            END SELECT
+
+            SELECT CASE ( cd_type )
+            
+               CASE( 'T', 'W' )
+         
+                  IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN     !!cc bande du sud style ORCA2
+                     IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN
+                        je_2 = mje_crs(2)
+                        DO jk = 1, jpk           
+                           DO ji = nistr, niend, nn_factx
+                              ii   = ( ji - mis_crs(2) ) * rfactx_r + 2        
+                              zflcrs =  &
+                                & MAX( p_fld(ji  ,je_2,jk) * zmask(ji  ,je_2,jk) - ( 1.- zmask(ji  ,je_2,jk) ) * r_inf ,  &
+                                &      p_fld(ji+1,je_2,jk) * zmask(ji+1,je_2,jk) - ( 1.- zmask(ji+1,je_2,jk) ) * r_inf ,  &
+                                &      p_fld(ji+2,je_2,jk) * zmask(ji+2,je_2,jk) - ( 1.- zmask(ji+2,je_2,jk) ) * r_inf  )
+                              !
+                              p_fld_crs(ii,2,jk) = zflcrs
+                           ENDDO
+                        ENDDO
+                      ENDIF
+                  ELSE
+                     je_2 = mjs_crs(2)
+                     DO jk = 1, jpk           
+                        DO ji = nistr, niend, nn_factx
+                           ii   = ( ji - mis_crs(2) ) * rfactx_r + 2   
+                           zflcrs =  &
+                             & MAX( p_fld(ji  ,je_2  ,jk) * zmask(ji  ,je_2  ,jk) - ( 1.- zmask(ji  ,je_2  ,jk) ) * r_inf ,  &
+                             &      p_fld(ji+1,je_2  ,jk) * zmask(ji+1,je_2  ,jk) - ( 1.- zmask(ji+1,je_2  ,jk) ) * r_inf ,  &
+                             &      p_fld(ji+2,je_2  ,jk) * zmask(ji+2,je_2  ,jk) - ( 1.- zmask(ji+2,je_2  ,jk) ) * r_inf ,  &
+                             &      p_fld(ji  ,je_2+1,jk) * zmask(ji  ,je_2+1,jk) - ( 1.- zmask(ji  ,je_2+1,jk) ) * r_inf ,  &
+                             &      p_fld(ji+1,je_2+1,jk) * zmask(ji+1,je_2+1,jk) - ( 1.- zmask(ji+1,je_2+1,jk) ) * r_inf ,  &
+                             &      p_fld(ji+2,je_2+1,jk) * zmask(ji+2,je_2+1,jk) - ( 1.- zmask(ji+2,je_2+1,jk) ) * r_inf ,  &
+                             &      p_fld(ji  ,je_2+2,jk) * zmask(ji  ,je_2+2,jk) - ( 1.- zmask(ji  ,je_2+2,jk) ) * r_inf ,  &
+                             &      p_fld(ji+1,je_2+2,jk) * zmask(ji+1,je_2+2,jk) - ( 1.- zmask(ji+1,je_2+2,jk) ) * r_inf ,  &
+                             &      p_fld(ji+2,je_2+2,jk) * zmask(ji+2,je_2+2,jk) - ( 1.- zmask(ji+2,je_2+2,jk) ) * r_inf   )
+                           !
+                           p_fld_crs(ii,2,jk) = zflcrs
+                        ENDDO
+                     ENDDO
+                  ENDIF
+                  !
+                  DO jk = 1, jpk           
+                     DO jj  = njstr, njend, nn_facty
+                        DO ji = nistr, niend, nn_factx
+                           ii  = ( ji - mis_crs(2) ) * rfactx_r + 2                 ! cordinate in parent grid
+                           ij  = ( jj - njstr ) * rfacty_r + 3
+                           zflcrs =  &
+                             & MAX( p_fld(ji  ,jj  ,jk) * zmask(ji  ,jj  ,jk) - ( 1.- zmask(ji  ,jj  ,jk) ) * r_inf ,  &
+                             &      p_fld(ji+1,jj  ,jk) * zmask(ji+1,jj  ,jk) - ( 1.- zmask(ji+1,jj  ,jk) ) * r_inf ,  &
+                             &      p_fld(ji+2,jj  ,jk) * zmask(ji+2,jj  ,jk) - ( 1.- zmask(ji+2,jj  ,jk) ) * r_inf ,  &
+                             &      p_fld(ji  ,jj+1,jk) * zmask(ji  ,jj+1,jk) - ( 1.- zmask(ji  ,jj+1,jk) ) * r_inf ,  &
+                             &      p_fld(ji+1,jj+1,jk) * zmask(ji+1,jj+1,jk) - ( 1.- zmask(ji+1,jj+1,jk) ) * r_inf ,  &
+                             &      p_fld(ji+2,jj+1,jk) * zmask(ji+2,jj+1,jk) - ( 1.- zmask(ji+2,jj+1,jk) ) * r_inf ,  &
+                             &      p_fld(ji  ,jj+2,jk) * zmask(ji  ,jj+2,jk) - ( 1.- zmask(ji  ,jj+2,jk) ) * r_inf ,  &
+                             &      p_fld(ji+1,jj+2,jk) * zmask(ji+1,jj+2,jk) - ( 1.- zmask(ji+1,jj+2,jk) ) * r_inf ,  &
+                             &      p_fld(ji+2,jj+2,jk) * zmask(ji+2,jj+2,jk) - ( 1.- zmask(ji+2,jj+2,jk) ) * r_inf   )
+                           !
+                           p_fld_crs(ii,ij,jk) = zflcrs
+                           !
+                        ENDDO      
+                     ENDDO
+                  ENDDO   
+            
+               CASE( 'V' )
+
+                 IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN     !!cc bande du sud style ORCA2
+                     IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN
+                        ijje = mje_crs(2)
+                      ENDIF
+                  ELSE
+                     ijje = mjs_crs(2)
+                  ENDIF
+
+                  DO jk = 1, jpk
+                     DO ji = nistr, niend, nn_factx
+                        ii   = ( ji - mis_crs(2) ) * rfactx_r + 2     
+                        zflcrs = &
+                          & MAX( p_fld(ji  ,ijje,jk) * p_mask(ji  ,ijje,jk) - ( 1.- p_mask(ji,ijje,jk) ) * r_inf ,  &
+                          &      p_fld(ji+1,ijje,jk) * p_mask(ji+1,ijje,jk) - ( 1.- p_mask(ji,ijje,jk) ) * r_inf ,  &
+                          &      p_fld(ji+2,ijje,jk) * p_mask(ji+2,ijje,jk) - ( 1.- p_mask(ji,ijje,jk) ) * r_inf )
+                          !
+                        p_fld_crs(ii,2,jk) = zflcrs
+                     ENDDO
+                  ENDDO
+                  !
+                  DO jk = 1, jpk           
+                     DO jj  = njstr, njend, nn_facty
+                        DO ji = nistr, niend, nn_factx
+                           ii  = ( ji - mis_crs(2) ) * rfactx_r + 2                 ! cordinate in parent grid
+                           ij  = ( jj - njstr ) * rfacty_r + 3
+                           ijje = mje_crs(ij)
+                           !                  
+                           zflcrs = &
+                             & MAX( p_fld(ji  ,ijje,jk) * p_mask(ji  ,ijje,jk) - ( 1.- p_mask(ji,ijje,jk) ) * r_inf ,  &
+                             &      p_fld(ji+1,ijje,jk) * p_mask(ji+1,ijje,jk) - ( 1.- p_mask(ji,ijje,jk) ) * r_inf ,  &
+                             &      p_fld(ji+2,ijje,jk) * p_mask(ji+2,ijje,jk) - ( 1.- p_mask(ji,ijje,jk) ) * r_inf )
+                           !
+                           p_fld_crs(ii,ij,jk) = zflcrs
+                           !
+                        ENDDO      
+                     ENDDO
+                  ENDDO   
+
+            
+               CASE( 'U' )
+
+                 IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN     !!cc bande du sud style ORCA2
+                     IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN
+                        je_2 = mje_crs(2)
+                        DO jk = 1, jpk           
+                           DO ji = nistr, niend, nn_factx
+                              ii   = ( ji - mis_crs(2) ) * rfactx_r + 2  
+                              ijie = mie_crs(ii)
+                              zflcrs = p_fld(ijie,je_2,jk) * p_mask(ijie,je_2,jk) - ( 1.- p_mask(ijie,je_2,jk) ) * r_inf 
+                              !
+                              p_fld_crs(ii,2,jk) = zflcrs
+                            ENDDO
+                        ENDDO
+                      ENDIF
+                  ELSE
+                     je_2 = mjs_crs(2)
+                     DO jk = 1, jpk           
+                        DO ji = nistr, niend, nn_factx
+                           ii   = ( ji - mis_crs(2) ) * rfactx_r + 2   
+                           ijie = mie_crs(ii)
+                           zflcrs = &
+                             & MAX( p_fld(ijie,je_2  ,jk) * p_mask(ijie,je_2  ,jk) - ( 1.- p_mask(ijie,je_2,jk) ) * r_inf ,  &
+                             &      p_fld(ijie,je_2+1,jk) * p_mask(ijie,je_2+1,jk) - ( 1.- p_mask(ijie,je_2,jk) ) * r_inf ,  &
+                             &      p_fld(ijie,je_2+2,jk) * p_mask(ijie,je_2+2,jk) - ( 1.- p_mask(ijie,je_2,jk) ) * r_inf  )
+                            !
+                           p_fld_crs(ii,2,jk) = zflcrs
+                        ENDDO
+                     ENDDO
+                  ENDIF
+                  !
+                  DO jk = 1, jpk           
+                     DO jj  = njstr, njend, nn_facty
+                        DO ji = nistr, niend, nn_factx
+                           ii   = ( ji - mis_crs(2) ) * rfactx_r + 2     
+                           ij   = ( jj - njstr ) * rfacty_r + 3
+                           ijie = mie_crs(ii)
+                           zflcrs =  &
+                             & MAX( p_fld(ijie,jj  ,jk) * p_mask(ijie,jj  ,jk) - ( 1.- p_mask(ijie,jj,jk) ) * r_inf ,  &
+                             &      p_fld(ijie,jj+1,jk) * p_mask(ijie,jj+1,jk) - ( 1.- p_mask(ijie,jj,jk) ) * r_inf ,  &
+                             &      p_fld(ijie,jj+2,jk) * p_mask(ijie,jj+2,jk) - ( 1.- p_mask(ijie,jj,jk) ) * r_inf  )
+                           ! 
+                           p_fld_crs(ii,ij,jk) = zflcrs
+                           ! 
+                        ENDDO      
+                     ENDDO
+                  ENDDO   
+
+              END SELECT
+
+              DEALLOCATE( zmask )
+
+         CASE ( 'MIN' )      !   Search the min of unmasked grid cells
+
+            ALLOCATE( zmask(jpi,jpj,jpk) )
+
+            SELECT CASE ( cd_type )
+              CASE( 'W' )
+                  zmask(:,:,1) = p_mask(:,:,1) 
+                  DO jk = 2, jpk
+                     zmask(:,:,jk) = p_mask(:,:,jk-1) 
+                  ENDDO
+              CASE ( 'T' )
+                  DO jk = 1, jpk
+                     zmask(:,:,jk) = p_mask(:,:,jk) 
+                  ENDDO
+            END SELECT
+
+            SELECT CASE ( cd_type )
+
+               CASE( 'T', 'W' )
+         
+                  IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN     !!cc bande du sud style ORCA2
+                     IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN
+                        je_2 = mje_crs(2)
+                        DO jk = 1, jpk           
+                           DO ji = nistr, niend, nn_factx
+                              ii   = ( ji - mis_crs(2) ) * rfactx_r + 2        
+                              zflcrs =  &
+                                & MIN( p_fld(ji  ,je_2,jk) * zmask(ji  ,je_2,jk) + ( 1.- zmask(ji  ,je_2,jk) ) * r_inf ,  &
+                                &      p_fld(ji+1,je_2,jk) * zmask(ji+1,je_2,jk) + ( 1.- zmask(ji+1,je_2,jk) ) * r_inf ,  &
+                                &      p_fld(ji+2,je_2,jk) * zmask(ji+2,je_2,jk) + ( 1.- zmask(ji+2,je_2,jk) ) * r_inf  )
+                              !
+                              p_fld_crs(ii,2,jk) = zflcrs
+                           ENDDO
+                        ENDDO
+                      ENDIF
+                  ELSE
+                     je_2 = mjs_crs(2)
+                     DO jk = 1, jpk           
+                        DO ji = nistr, niend, nn_factx
+                           ii   = ( ji - mis_crs(2) ) * rfactx_r + 2   
+                           zflcrs =  &
+                             & MIN( p_fld(ji  ,je_2  ,jk) * zmask(ji  ,je_2  ,jk) + ( 1.- zmask(ji  ,je_2  ,jk) ) * r_inf ,  &
+                             &      p_fld(ji+1,je_2  ,jk) * zmask(ji+1,je_2  ,jk) + ( 1.- zmask(ji+1,je_2  ,jk) ) * r_inf ,  &
+                             &      p_fld(ji+2,je_2  ,jk) * zmask(ji+2,je_2  ,jk) + ( 1.- zmask(ji+2,je_2  ,jk) ) * r_inf ,  &
+                             &      p_fld(ji  ,je_2+1,jk) * zmask(ji  ,je_2+1,jk) + ( 1.- zmask(ji  ,je_2+1,jk) ) * r_inf ,  &
+                             &      p_fld(ji+1,je_2+1,jk) * zmask(ji+1,je_2+1,jk) + ( 1.- zmask(ji+1,je_2+1,jk) ) * r_inf ,  &
+                             &      p_fld(ji+2,je_2+1,jk) * zmask(ji+2,je_2+1,jk) + ( 1.- zmask(ji+2,je_2+1,jk) ) * r_inf ,  &
+                             &      p_fld(ji  ,je_2+2,jk) * zmask(ji  ,je_2+2,jk) + ( 1.- zmask(ji  ,je_2+2,jk) ) * r_inf ,  &
+                             &      p_fld(ji+1,je_2+2,jk) * zmask(ji+1,je_2+2,jk) + ( 1.- zmask(ji+1,je_2+2,jk) ) * r_inf ,  &
+                             &      p_fld(ji+2,je_2+2,jk) * zmask(ji+2,je_2+2,jk) + ( 1.- zmask(ji+2,je_2+2,jk) ) * r_inf   )
+                           !
+                           p_fld_crs(ii,2,jk) = zflcrs
+                        ENDDO
+                     ENDDO
+                  ENDIF
+                  !
+                  DO jk = 1, jpk           
+                     DO jj  = njstr, njend, nn_facty
+                        DO ji = nistr, niend, nn_factx
+                           ii  = ( ji - mis_crs(2) ) * rfactx_r + 2                 ! cordinate in parent grid
+                           ij  = ( jj - njstr ) * rfacty_r + 3
+                           zflcrs =  &
+                             & MIN( p_fld(ji  ,jj  ,jk) * zmask(ji  ,jj  ,jk) + ( 1.- zmask(ji  ,jj  ,jk) ) * r_inf ,  &
+                             &      p_fld(ji+1,jj  ,jk) * zmask(ji+1,jj  ,jk) + ( 1.- zmask(ji+1,jj  ,jk) ) * r_inf ,  &
+                             &      p_fld(ji+2,jj  ,jk) * zmask(ji+2,jj  ,jk) + ( 1.- zmask(ji+2,jj  ,jk) ) * r_inf ,  &
+                             &      p_fld(ji  ,jj+1,jk) * zmask(ji  ,jj+1,jk) + ( 1.- zmask(ji  ,jj+1,jk) ) * r_inf ,  &
+                             &      p_fld(ji+1,jj+1,jk) * zmask(ji+1,jj+1,jk) + ( 1.- zmask(ji+1,jj+1,jk) ) * r_inf ,  &
+                             &      p_fld(ji+2,jj+1,jk) * zmask(ji+2,jj+1,jk) + ( 1.- zmask(ji+2,jj+1,jk) ) * r_inf ,  &
+                             &      p_fld(ji  ,jj+2,jk) * zmask(ji  ,jj+2,jk) + ( 1.- zmask(ji  ,jj+2,jk) ) * r_inf ,  &
+                             &      p_fld(ji+1,jj+2,jk) * zmask(ji+1,jj+2,jk) + ( 1.- zmask(ji+1,jj+2,jk) ) * r_inf ,  &
+                             &      p_fld(ji+2,jj+2,jk) * zmask(ji+2,jj+2,jk) + ( 1.- zmask(ji+2,jj+2,jk) ) * r_inf   )
+                           !
+                           p_fld_crs(ii,ij,jk) = zflcrs
+                           !
+                        ENDDO      
+                     ENDDO
+                  ENDDO   
+            
+               CASE( 'V' )
+
+                  IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN     !!cc bande du sud style ORCA2
+                     IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN
+                        ijje = mje_crs(2)
+                      ENDIF
+                  ELSE
+                     ijje = mjs_crs(2)
+                  ENDIF
+
+                  DO jk = 1, jpk
+                     DO ji = nistr, niend, nn_factx
+                        ii   = ( ji - mis_crs(2) ) * rfactx_r + 2     
+                        zflcrs = &
+                          & MIN( p_fld(ji  ,ijje,jk) * p_mask(ji  ,ijje,jk) + ( 1.- p_mask(ji,ijje,jk) ) * r_inf ,  &
+                          &      p_fld(ji+1,ijje,jk) * p_mask(ji+1,ijje,jk) + ( 1.- p_mask(ji,ijje,jk) ) * r_inf ,  &
+                          &      p_fld(ji+2,ijje,jk) * p_mask(ji+2,ijje,jk) + ( 1.- p_mask(ji,ijje,jk) ) * r_inf )
+                          !
+                        p_fld_crs(ii,2,jk) = zflcrs
+                     ENDDO
+                  ENDDO
+                  !
+                  DO jk = 1, jpk           
+                     DO jj  = njstr, njend, nn_facty
+                        DO ji = nistr, niend, nn_factx
+                           ii  = ( ji - mis_crs(2) ) * rfactx_r + 2                 ! cordinate in parent grid
+                           ij  = ( jj - njstr ) * rfacty_r + 3
+                           ijje = mje_crs(ij)
+                           zflcrs = &
+                             & MIN( p_fld(ji  ,ijje,jk) * p_mask(ji  ,ijje,jk) + ( 1.- p_mask(ji,ijje,jk) ) * r_inf ,  &
+                             &      p_fld(ji+1,ijje,jk) * p_mask(ji+1,ijje,jk) + ( 1.- p_mask(ji,ijje,jk) ) * r_inf ,  &
+                             &      p_fld(ji+2,ijje,jk) * p_mask(ji+2,ijje,jk) + ( 1.- p_mask(ji,ijje,jk) ) * r_inf )
+                           !
+                           p_fld_crs(ii,ij,jk) = zflcrs
+                           !
+                        ENDDO      
+                     ENDDO
+                  ENDDO   
+
+            
+               CASE( 'U' )
+
+                 IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN     !!cc bande du sud style ORCA2
+                     IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN
+                        je_2 = mje_crs(2)
+                        DO jk = 1, jpk           
+                           DO ji = nistr, niend, nn_factx
+                              ii   = ( ji - mis_crs(2) ) * rfactx_r + 2  
+                              ijie = mie_crs(ii)
+                              zflcrs = p_fld(ijie,je_2,jk) * p_mask(ijie,je_2,jk) + ( 1.- p_mask(ijie,je_2,jk) ) * r_inf 
+                              !
+                              p_fld_crs(ii,2,jk) = zflcrs
+                            ENDDO
+                        ENDDO
+                      ENDIF
+                  ELSE
+                     je_2 = mjs_crs(2)
+                     DO jk = 1, jpk           
+                        DO ji = nistr, niend, nn_factx
+                           ii   = ( ji - mis_crs(2) ) * rfactx_r + 2   
+                           ijie = mie_crs(ii)
+                           zflcrs = &
+                             & MIN( p_fld(ijie,je_2  ,jk) * p_mask(ijie,je_2  ,jk) + ( 1.- p_mask(ijie,je_2,jk) ) * r_inf ,  &
+                             &      p_fld(ijie,je_2+1,jk) * p_mask(ijie,je_2+1,jk) + ( 1.- p_mask(ijie,je_2,jk) ) * r_inf ,  &
+                             &      p_fld(ijie,je_2+2,jk) * p_mask(ijie,je_2+2,jk) + ( 1.- p_mask(ijie,je_2,jk) ) * r_inf  )
+                            !
+                           p_fld_crs(ii,2,jk) = zflcrs
+                        ENDDO
+                     ENDDO
+                  ENDIF
+                  !
+                  DO jk = 1, jpk           
+                     DO jj  = njstr, njend, nn_facty
+                        DO ji = nistr, niend, nn_factx
+                           ii   = ( ji - mis_crs(2) ) * rfactx_r + 2     
+                           ij   = ( jj - njstr ) * rfacty_r + 3
+                           ijie = mie_crs(ii)
+                           zflcrs = &
+                             & MIN( p_fld(ijie,jj  ,jk) * p_mask(ijie,jj  ,jk) + ( 1.- p_mask(ijie,jj,jk) ) * r_inf ,  &
+                             &      p_fld(ijie,jj+1,jk) * p_mask(ijie,jj+1,jk) + ( 1.- p_mask(ijie,jj,jk) ) * r_inf ,  &
+                             &      p_fld(ijie,jj+2,jk) * p_mask(ijie,jj+2,jk) + ( 1.- p_mask(ijie,jj,jk) ) * r_inf  )
+                           ! 
+                           p_fld_crs(ii,ij,jk) = zflcrs
+                           ! 
+                        ENDDO      
+                     ENDDO
+                  ENDDO   
+          
+            END SELECT
+            !
+            DEALLOCATE( zmask )
+            !
+         END SELECT
+         !
+         CALL crs_lbc_lnk( p_fld_crs, cd_type, psgn )
+         !
+    END SUBROUTINE crs_dom_ope_3d
+
+    SUBROUTINE crs_dom_ope_2d( p_fld, cd_op, cd_type, p_mask, p_fld_crs, p_e12, p_e3, p_surf_crs, p_mask_crs, psgn )
+      !!----------------------------------------------------------------
+      !!               *** SUBROUTINE crsfun_UV ***
+      !! ** Purpose :  Average, area-weighted, of U or V on the east and north faces 
+      !!
+      !! ** Method  :  The U and V velocities (3D) are determined as the area-weighted averages
+      !!               on the east and north faces, respectively,
+      !!               of the parent grid subset comprising the coarse grid box. 
+      !!               In the case of the V and F grid, the last jrow minus 1 is spurious.
+      !! ** Inputs  : p_e1_e2     = parent grid e1 or e2 (t,u,v,f)
+      !!              cd_type     = grid type (T,U,V,F) for scale factors; for velocities (U or V)
+      !!              psgn        = sign change over north fold (See lbclnk.F90)
+      !!              p_pmask     = parent grid mask (T,U,V,F) for scale factors; 
+      !!                                       for velocities (U or V)
+      !!              p_e3      = parent grid vertical level thickness (e3u or e3v)
+      !!              p_pfield    = U or V on the parent grid
+      !!              p_surf_crs  = (Optional) Coarse grid weight for averaging
+      !! ** Outputs : p_cfield3d = 3D field on coarse grid
+      !!
+      !! History.  29 May.  completed draft.
+      !!            4 Jun.  Revision for WGT
+      !!            5 Jun.  Streamline for area-weighted average only ; separate scale factor and weights.
+      !!----------------------------------------------------------------
+      REAL(wp), DIMENSION(jpi,jpj),             INTENT(in)           :: p_fld   ! T, U, V or W on parent grid
+      CHARACTER(len=3),                         INTENT(in)           :: cd_op    ! Operation SUM, MAX or MIN
+      CHARACTER(len=1),                         INTENT(in)           :: cd_type    ! grid type U,V 
+      REAL(wp), DIMENSION(jpi,jpj,jpk),         INTENT(in)           :: p_mask    ! Parent grid T,U,V mask
+      REAL(wp), DIMENSION(jpi,jpj),             INTENT(in), OPTIONAL :: p_e12    ! Parent grid T,U,V scale factors (e1 or e2)
+      REAL(wp), DIMENSION(jpi,jpj,jpk),         INTENT(in), OPTIONAL :: p_e3     ! Parent grid vertical level thickness (e3u, e3v)
+      REAL(wp), DIMENSION(jpi_crs,jpj_crs)    , INTENT(in), OPTIONAL :: p_surf_crs ! Coarse grid area-weighting denominator    
+      REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(in), OPTIONAL :: p_mask_crs    ! Coarse grid T,U,V mask
+      REAL(wp),                                 INTENT(in)           :: psgn   
+      REAL(wp), DIMENSION(jpi_crs,jpj_crs)    , INTENT(out)          :: p_fld_crs ! Coarse grid box 3D quantity 
+      !
+      INTEGER  :: ji, jj, jk                 ! dummy loop indices
+      INTEGER  :: ijie, ijje, ii, ij, je_2
+      REAL(wp) :: zflcrs, zsfcrs   
+      REAL(wp), DIMENSION(:,:), ALLOCATABLE :: zsurfmsk   
+      !!----------------------------------------------------------------  
+      !
+      p_fld_crs(:,:) = 0._wp
+      !
+      SELECT CASE ( cd_op )
+      
+        CASE ( 'VOL' )
+      
+            ALLOCATE( zsurfmsk(jpi,jpj) )
+            zsurfmsk(:,:) =  p_e12(:,:) * p_e3(:,:,1) * p_mask(:,:,1)
+
+            IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN     !!cc bande du sud style ORCA2
+               IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN
+                  je_2 = mje_crs(2)
+                  DO ji = nistr, niend, nn_factx
+                     ii   = ( ji - mis_crs(2) ) * rfactx_r + 2       
+                     zflcrs =  p_fld(ji  ,je_2) * zsurfmsk(ji  ,je_2)   &
+                       &     + p_fld(ji+1,je_2) * zsurfmsk(ji+1,je_2)   &
+                       &     + p_fld(ji+2,je_2) * zsurfmsk(ji+2,je_2) 
+
+                     zsfcrs =  zsurfmsk(ji,je_2) + zsurfmsk(ji+1,je_2) + zsurfmsk(ji+2,je_2) 
+                     !
+                     p_fld_crs(ii,2) = zflcrs
+                     IF( zsfcrs /= 0.0 )  p_fld_crs(ii,2) = zflcrs / zsfcrs
+                  ENDDO
+               ENDIF
+            ELSE
+               je_2 = mjs_crs(2)
+               DO ji = nistr, niend, nn_factx
+                  ii   = ( ji - mis_crs(2) ) * rfactx_r + 2   
+                  zflcrs =  p_fld(ji  ,je_2  ) * zsurfmsk(ji  ,je_2  ) &
+                    &     + p_fld(ji+1,je_2  ) * zsurfmsk(ji+1,je_2  ) &
+                    &     + p_fld(ji+2,je_2  ) * zsurfmsk(ji+2,je_2  ) &
+                    &     + p_fld(ji  ,je_2+1) * zsurfmsk(ji  ,je_2+1) &
+                    &     + p_fld(ji+1,je_2+1) * zsurfmsk(ji+1,je_2+1) &
+                    &     + p_fld(ji+2,je_2+1) * zsurfmsk(ji+2,je_2+1) &
+                    &     + p_fld(ji  ,je_2+2) * zsurfmsk(ji  ,je_2+2) &
+                    &     + p_fld(ji+1,je_2+2) * zsurfmsk(ji+1,je_2+2) &
+                    &     + p_fld(ji+2,je_2+2) * zsurfmsk(ji+2,je_2+2) 
+
+                   zsfcrs =  zsurfmsk(ji,je_2  ) + zsurfmsk(ji+1,je_2  ) + zsurfmsk(ji+2,je_2  ) &
+                     &     + zsurfmsk(ji,je_2+1) + zsurfmsk(ji+1,je_2+1) + zsurfmsk(ji+2,je_2+1) &
+                     &     + zsurfmsk(ji,je_2+2) + zsurfmsk(ji+1,je_2+2) + zsurfmsk(ji+2,je_2+2) 
+                    !
+                    p_fld_crs(ii,2) = zflcrs
+                    IF( zsfcrs /= 0.0 )  p_fld_crs(ii,2) = zflcrs / zsfcrs
+                ENDDO
+            ENDIF
+                  !
+            DO jj  = njstr, njend, nn_facty
+               DO ji = nistr, niend, nn_factx
+                  ii  = ( ji - mis_crs(2) ) * rfactx_r + 2                 ! cordinate in parent grid
+                  ij  = ( jj - njstr ) * rfacty_r + 3
+                  zflcrs =  p_fld(ji  ,jj  ) * zsurfmsk(ji  ,jj  ) &
+                    &     + p_fld(ji+1,jj  ) * zsurfmsk(ji+1,jj  ) &
+                    &     + p_fld(ji+2,jj  ) * zsurfmsk(ji+2,jj  ) &
+                    &     + p_fld(ji  ,jj+1) * zsurfmsk(ji  ,jj+1) &
+                    &     + p_fld(ji+1,jj+1) * zsurfmsk(ji+1,jj+1) &
+                    &     + p_fld(ji+2,jj+1) * zsurfmsk(ji+2,jj+1) &
+                    &     + p_fld(ji  ,jj+2) * zsurfmsk(ji  ,jj+2) &
+                    &     + p_fld(ji+1,jj+2) * zsurfmsk(ji+1,jj+2) &
+                    &     + p_fld(ji+2,jj+2) * zsurfmsk(ji+2,jj+2) 
+  
+                  zsfcrs =  zsurfmsk(ji,jj  ) + zsurfmsk(ji+1,jj  ) + zsurfmsk(ji+2,jj  ) &
+                    &     + zsurfmsk(ji,jj+1) + zsurfmsk(ji+1,jj+1) + zsurfmsk(ji+2,jj+1) &
+                    &     + zsurfmsk(ji,jj+2) + zsurfmsk(ji+1,jj+2) + zsurfmsk(ji+2,jj+2) 
+                   !
+                  p_fld_crs(ii,ij) = zflcrs
+                  IF( zsfcrs /= 0.0 )  p_fld_crs(ii,ij) = zflcrs / zsfcrs
+               ENDDO      
+            ENDDO
+
+            DEALLOCATE( zsurfmsk )
+
+         CASE ( 'SUM' )
+         
+            ALLOCATE( zsurfmsk(jpi,jpj) )
+            IF( PRESENT( p_e3 ) ) THEN
+               zsurfmsk(:,:) =  p_e12(:,:) * p_e3(:,:,1) * p_mask(:,:,1)
+            ELSE
+               zsurfmsk(:,:) =  p_e12(:,:) * p_mask(:,:,1)
+            ENDIF
+
+            SELECT CASE ( cd_type )
+
+               CASE( 'T', 'W' )
+
+                   IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN     !!cc bande du sud style ORCA2
+                      IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN
+                         je_2 = mje_crs(2)
+                         DO ji = nistr, niend, nn_factx
+                            ii   = ( ji - mis_crs(2) ) * rfactx_r + 2     
+                            zflcrs  =  p_fld(ji  ,je_2) * zsurfmsk(ji  ,je_2) &
+                              &      + p_fld(ji+1,je_2) * zsurfmsk(ji+1,je_2) &
+                              &      + p_fld(ji+2,je_2) * zsurfmsk(ji+2,je_2) 
+                              !
+                             p_fld_crs(ii,2) = zflcrs
+                         ENDDO
+                      ENDIF
+                   ELSE
+                      je_2 = mjs_crs(2)
+                      DO ji = nistr, niend, nn_factx
+                         ii   = ( ji - mis_crs(2) ) * rfactx_r + 2     
+                         zflcrs  =  p_fld(ji  ,je_2  ) * zsurfmsk(ji  ,je_2  )  &
+                           &      + p_fld(ji+1,je_2  ) * zsurfmsk(ji+1,je_2  )  &
+                           &      + p_fld(ji+2,je_2  ) * zsurfmsk(ji+2,je_2  )  &
+                           &      + p_fld(ji  ,je_2+1) * zsurfmsk(ji  ,je_2+1)  &
+                           &      + p_fld(ji+1,je_2+1) * zsurfmsk(ji+1,je_2+1)  &
+                           &      + p_fld(ji+2,je_2+1) * zsurfmsk(ji+2,je_2+1)  &
+                           &      + p_fld(ji  ,je_2+2) * zsurfmsk(ji  ,je_2+2)  &
+                           &      + p_fld(ji+1,je_2+2) * zsurfmsk(ji+1,je_2+2)  &
+                           &      + p_fld(ji+2,je_2+2) * zsurfmsk(ji+2,je_2+2)  
+                            !
+                            p_fld_crs(ii,2) = zflcrs
+                      ENDDO
+                   ENDIF
+                     !
+                   DO jj = njstr, njend, nn_facty
+                      DO ji = nistr, niend, nn_factx
+                         ii   = ( ji - mis_crs(2) ) * rfactx_r + 2    
+                         ij   = ( jj - njstr ) * rfacty_r + 3
+                         zflcrs  =  p_fld(ji  ,jj  ) * zsurfmsk(ji  ,jj  )  &
+                           &      + p_fld(ji+1,jj  ) * zsurfmsk(ji+1,jj  )  &
+                           &      + p_fld(ji+2,jj  ) * zsurfmsk(ji+2,jj  )  &
+                           &      + p_fld(ji  ,jj+1) * zsurfmsk(ji  ,jj+1)  &
+                           &      + p_fld(ji+1,jj+1) * zsurfmsk(ji+1,jj+1)  &
+                           &      + p_fld(ji+2,jj+1) * zsurfmsk(ji+2,jj+1)  &
+                           &      + p_fld(ji  ,jj+2) * zsurfmsk(ji  ,jj+2)  &
+                           &      + p_fld(ji+1,jj+2) * zsurfmsk(ji+1,jj+2)  &
+                           &      + p_fld(ji+2,jj+2) * zsurfmsk(ji+2,jj+2)  
+                           !
+                          p_fld_crs(ii,ij) = zflcrs
+                          ! 
+                      ENDDO      
+                   ENDDO
+            
+               CASE( 'V' )
+
+                  IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN     !!cc bande du sud style ORCA2
+                     IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN
+                        ijje = mje_crs(2)
+                      ENDIF
+                  ELSE
+                     ijje = mjs_crs(2)
+                  ENDIF
+
+                  DO ji = nistr, niend, nn_factx
+                     ii   = ( ji - mis_crs(2) ) * rfactx_r + 2     
+                     zflcrs  =  p_fld(ji  ,ijje) * zsurfmsk(ji  ,ijje) &
+                       &      + p_fld(ji+1,ijje) * zsurfmsk(ji+1,ijje) &
+                       &      + p_fld(ji+2,ijje) * zsurfmsk(ji+2,ijje) 
+                            !
+                     p_fld_crs(ii,2) = zflcrs
+                  ENDDO
+
+                  DO jj = njstr, njend, nn_facty
+                     DO ji = nistr, niend, nn_factx
+                        ii   = ( ji - mis_crs(2) ) * rfactx_r + 2     
+                        ij   = ( jj - njstr ) * rfacty_r + 3
+                        ijje = mje_crs(ij)
+                        zflcrs  =  p_fld(ji  ,ijje) * zsurfmsk(ji  ,ijje) &
+                          &      + p_fld(ji+1,ijje) * zsurfmsk(ji+1,ijje) &
+                          &      + p_fld(ji+2,ijje) * zsurfmsk(ji+2,ijje) 
+                          !
+                        p_fld_crs(ii,ij) = zflcrs
+                        ! 
+                     ENDDO      
+                  ENDDO
+            
+               CASE( 'U' )
+
+                  IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN     !!cc bande du sud style ORCA2
+                     IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN
+                        je_2 = mje_crs(2)
+                        DO ji = nistr, niend, nn_factx
+                           ii   = ( ji - mis_crs(2) ) * rfactx_r + 2    
+                           ijie = mie_crs(ii)
+                           zflcrs  =  p_fld(ijie,je_2) * zsurfmsk(ijie,je_2)  
+                           p_fld_crs(ii,2) = zflcrs
+                        ENDDO
+                     ENDIF
+                  ELSE
+                     je_2 = mjs_crs(2)
+                     DO ji = nistr, niend, nn_factx
+                        ii   = ( ji - mis_crs(2) ) * rfactx_r + 2    
+                        ijie = mie_crs(ii)
+                        zflcrs =  p_fld(ijie,je_2  ) * zsurfmsk(ijie,je_2  )  &
+                          &     + p_fld(ijie,je_2+1) * zsurfmsk(ijie,je_2+1)  &
+                          &     + p_fld(ijie,je_2+2) * zsurfmsk(ijie,je_2+2) 
+   
+                        p_fld_crs(ii,2) = zflcrs
+                     ENDDO
+                 ENDIF
+
+                 DO jj = njstr, njend, nn_facty
+                    DO ji = nistr, niend, nn_factx
+                       ii   = ( ji - mis_crs(2) ) * rfactx_r + 2     
+                       ij   = ( jj - njstr ) * rfacty_r + 3
+                       ijie = mie_crs(ii)
+                       zflcrs =  p_fld(ijie,jj  ) * zsurfmsk(ijie,jj  )  &
+                          &    + p_fld(ijie,jj+1) * zsurfmsk(ijie,jj+1)  &
+                          &    + p_fld(ijie,jj+2) * zsurfmsk(ijie,jj+2) 
+                         !
+                       p_fld_crs(ii,ij) = zflcrs
+                       ! 
+                    ENDDO      
+                 ENDDO
+
+              END SELECT
+
+              IF( PRESENT( p_surf_crs ) ) THEN
+                 WHERE ( p_surf_crs /= 0.0 ) p_fld_crs(:,:) = p_fld_crs(:,:) / p_surf_crs(:,:)
+              ENDIF
+
+              DEALLOCATE( zsurfmsk )
+
+         CASE ( 'MAX' )
+
+            SELECT CASE ( cd_type )
+            
+               CASE( 'T', 'W' )
+  
+                   IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN     !!cc bande du sud style ORCA2
+                      IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN
+                         je_2 = mje_crs(2)
+                         DO ji = nistr, niend, nn_factx
+                            ii   = ( ji - mis_crs(2) ) * rfactx_r + 2     
+                            zflcrs =  &
+                              & MAX( p_fld(ji  ,je_2) * p_mask(ji  ,je_2,1) - ( 1.- p_mask(ji  ,je_2,1) ) * r_inf ,  &
+                             &       p_fld(ji+1,je_2) * p_mask(ji+1,je_2,1) - ( 1.- p_mask(ji+1,je_2,1) ) * r_inf ,  &
+                             &       p_fld(ji+2,je_2) * p_mask(ji+2,je_2,1) - ( 1.- p_mask(ji+2,je_2,1) ) * r_inf  )
+                            !
+                            p_fld_crs(ii,2) = zflcrs
+                         ENDDO
+                      ENDIF
+                   ELSE
+                      je_2 = mjs_crs(2) 
+                      zflcrs =  &
+                        &  MAX( p_fld(ji  ,je_2  ) * p_mask(ji  ,je_2  ,1) - ( 1.- p_mask(ji  ,je_2  ,1) ) * r_inf ,  &
+                        &       p_fld(ji+1,je_2  ) * p_mask(ji+1,je_2  ,1) - ( 1.- p_mask(ji+1,je_2  ,1) ) * r_inf ,  &
+                        &       p_fld(ji+2,je_2  ) * p_mask(ji+2,je_2  ,1) - ( 1.- p_mask(ji+2,je_2  ,1) ) * r_inf ,  &
+                        &       p_fld(ji  ,je_2+1) * p_mask(ji  ,je_2+1,1) - ( 1.- p_mask(ji  ,je_2+1,1) ) * r_inf ,  &
+                        &       p_fld(ji+1,je_2+1) * p_mask(ji+1,je_2+1,1) - ( 1.- p_mask(ji+1,je_2+1,1) ) * r_inf ,  &
+                        &       p_fld(ji+2,je_2+1) * p_mask(ji+2,je_2+1,1) - ( 1.- p_mask(ji+2,je_2+1,1) ) * r_inf ,  &
+                        &       p_fld(ji  ,je_2+2) * p_mask(ji  ,je_2+2,1) - ( 1.- p_mask(ji  ,je_2+2,1) ) * r_inf ,  &
+                        &       p_fld(ji+1,je_2+2) * p_mask(ji+1,je_2+2,1) - ( 1.- p_mask(ji+1,je_2+2,1) ) * r_inf ,  &
+                        &       p_fld(ji+2,je_2+2) * p_mask(ji+2,je_2+2,1) - ( 1.- p_mask(ji+2,je_2+2,1) ) * r_inf   )
+                      !
+                      p_fld_crs(ii,2) = zflcrs
+                   ENDIF
+
+                   DO jj = njstr, njend, nn_facty
+                      DO ji = nistr, niend, nn_factx
+                         ii   = ( ji - mis_crs(2) ) * rfactx_r + 2     
+                         ij   = ( jj - njstr ) * rfacty_r + 3
+                         zflcrs = &
+                          &  MAX( p_fld(ji  ,jj  ) * p_mask(ji  ,jj  ,1) - ( 1.- p_mask(ji  ,jj  ,1) ) * r_inf ,  &
+                          &       p_fld(ji+1,jj  ) * p_mask(ji+1,jj  ,1) - ( 1.- p_mask(ji+1,jj  ,1) ) * r_inf ,  &
+                          &       p_fld(ji+2,jj  ) * p_mask(ji+2,jj  ,1) - ( 1.- p_mask(ji+2,jj  ,1) ) * r_inf ,  &
+                          &       p_fld(ji  ,jj+1) * p_mask(ji  ,jj+1,1) - ( 1.- p_mask(ji  ,jj+1,1) ) * r_inf ,  &
+                          &       p_fld(ji+1,jj+1) * p_mask(ji+1,jj+1,1) - ( 1.- p_mask(ji+1,jj+1,1) ) * r_inf ,  &
+                          &       p_fld(ji+2,jj+1) * p_mask(ji+2,jj+1,1) - ( 1.- p_mask(ji+2,jj+1,1) ) * r_inf ,  &
+                          &       p_fld(ji  ,jj+2) * p_mask(ji  ,jj+2,1) - ( 1.- p_mask(ji  ,jj+2,1) ) * r_inf ,  &
+                          &       p_fld(ji+1,jj+2) * p_mask(ji+1,jj+2,1) - ( 1.- p_mask(ji+1,jj+2,1) ) * r_inf ,  &
+                          &       p_fld(ji+2,jj+2) * p_mask(ji+2,jj+2,1) - ( 1.- p_mask(ji+2,jj+2,1) ) * r_inf   )
+                         !
+                         p_fld_crs(ii,ij) = zflcrs
+                         !
+                      ENDDO      
+                   ENDDO
+            
+               CASE( 'V' )
+
+                  IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN     !!cc bande du sud style ORCA2
+                     IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN
+                        ijje = mje_crs(2)
+                      ENDIF
+                  ELSE
+                     ijje = mjs_crs(2)
+                  ENDIF
+
+                  DO ji = nistr, niend, nn_factx
+                     ii   = ( ji - mis_crs(2) ) * rfactx_r + 2    
+                     zflcrs = MAX( p_fld(ji  ,ijje) * p_mask(ji  ,ijje,1) - ( 1.- p_mask(ji,ijje,1) ) * r_inf ,  &
+                       &           p_fld(ji+1,ijje) * p_mask(ji+1,ijje,1) - ( 1.- p_mask(ji,ijje,1) ) * r_inf ,  &
+                       &           p_fld(ji+2,ijje) * p_mask(ji+2,ijje,1) - ( 1.- p_mask(ji,ijje,1) ) * r_inf )
+                       !
+                     p_fld_crs(ii,2) = zflcrs
+                  ENDDO      
+                  DO jj = njstr, njend, nn_facty
+                     DO ji = nistr, niend, nn_factx
+                        ii   = ( ji - mis_crs(2) ) * rfactx_r + 2    
+                        ij   = ( jj - njstr ) * rfacty_r + 3               
+                        ijje = mje_crs(ij) 
+                        !                  
+                        zflcrs = MAX( p_fld(ji  ,ijje) * p_mask(ji  ,ijje,1) - ( 1.- p_mask(ji,ijje,1) ) * r_inf ,  &
+                          &           p_fld(ji+1,ijje) * p_mask(ji+1,ijje,1) - ( 1.- p_mask(ji,ijje,1) ) * r_inf ,  &
+                          &           p_fld(ji+2,ijje) * p_mask(ji+2,ijje,1) - ( 1.- p_mask(ji,ijje,1) ) * r_inf )
+                        !
+                        p_fld_crs(ii,ij) = zflcrs
+                        !
+                     ENDDO      
+                  ENDDO
+            
+               CASE( 'U' )
+
+                 IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN     !!cc bande du sud style ORCA2
+                     IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN
+                        je_2 = mje_crs(2)
+                        DO ji = nistr, niend, nn_factx
+                           ii   = ( ji - mis_crs(2) ) * rfactx_r + 2    
+                           ijie = mie_crs(ii)
+                           zflcrs  =  p_fld(ijie,je_2) * p_mask(ijie,je_2,1) - ( 1.- p_mask(ijie,je_2,1) ) * r_inf 
+                           p_fld_crs(ii,2) = zflcrs
+                        ENDDO
+                     ENDIF
+                 ELSE
+                     je_2 = mjs_crs(2)
+                     DO ji = nistr, niend, nn_factx
+                        ii   = ( ji - mis_crs(2) ) * rfactx_r + 2    
+                        ijie = mie_crs(ii)
+                        zflcrs =  &
+                          &  MAX( p_fld(ijie,je_2  ) * p_mask(ijie,je_2  ,1) - ( 1.- p_mask(ijie,je_2,1) ) * r_inf ,  &
+                          &       p_fld(ijie,je_2+1) * p_mask(ijie,je_2+1,1) - ( 1.- p_mask(ijie,je_2,1) ) * r_inf ,  &
+                          &       p_fld(ijie,je_2+2) * p_mask(ijie,je_2+2,1) - ( 1.- p_mask(ijie,je_2,1) ) * r_inf  )
+                        p_fld_crs(ii,2) = zflcrs
+                     ENDDO
+                 ENDIF
+                 DO jj = njstr, njend, nn_facty
+                    DO ji = nistr, niend, nn_factx
+                       ii   = ( ji - mis_crs(2) ) * rfactx_r + 2     
+                       ij   = ( jj - njstr ) * rfacty_r + 3
+                       ijie = mie_crs(ii)
+                       zflcrs =  &
+                         &  MAX( p_fld(ijie,jj  ) * p_mask(ijie,jj  ,1) - ( 1.- p_mask(ijie,jj,1) ) * r_inf ,  &
+                         &       p_fld(ijie,jj+1) * p_mask(ijie,jj+1,1) - ( 1.- p_mask(ijie,jj,1) ) * r_inf ,  &
+                          &      p_fld(ijie,jj+2) * p_mask(ijie,jj+2,1) - ( 1.- p_mask(ijie,jj,1) ) * r_inf  )
+                        p_fld_crs(ii,ij) = zflcrs
+                        ! 
+                     ENDDO      
+                  ENDDO
+
+              END SELECT
+
+         CASE ( 'MIN' )      !   Search the min of unmasked grid cells
+
+           SELECT CASE ( cd_type )
+
+              CASE( 'T', 'W' )
+  
+                   IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN     !!cc bande du sud style ORCA2
+                      IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN
+                         je_2 = mje_crs(2)
+                         DO ji = nistr, niend, nn_factx
+                            ii   = ( ji - mis_crs(2) ) * rfactx_r + 2     
+                            zflcrs =  &
+                              & MIN( p_fld(ji  ,je_2) * p_mask(ji  ,je_2,1) + ( 1.- p_mask(ji  ,je_2,1) ) * r_inf ,  &
+                             &       p_fld(ji+1,je_2) * p_mask(ji+1,je_2,1) + ( 1.- p_mask(ji+1,je_2,1) ) * r_inf ,  &
+                             &       p_fld(ji+2,je_2) * p_mask(ji+2,je_2,1) + ( 1.- p_mask(ji+2,je_2,1) ) * r_inf  )
+                            !
+                            p_fld_crs(ii,2) = zflcrs
+                         ENDDO
+                      ENDIF
+                   ELSE
+                      je_2 = mjs_crs(2) 
+                      zflcrs =  &
+                        &  MIN( p_fld(ji  ,je_2  ) * p_mask(ji  ,je_2  ,1) + ( 1.- p_mask(ji  ,je_2  ,1) ) * r_inf ,  &
+                        &       p_fld(ji+1,je_2  ) * p_mask(ji+1,je_2  ,1) + ( 1.- p_mask(ji+1,je_2  ,1) ) * r_inf ,  &
+                        &       p_fld(ji+2,je_2  ) * p_mask(ji+2,je_2  ,1) + ( 1.- p_mask(ji+2,je_2  ,1) ) * r_inf ,  &
+                        &       p_fld(ji  ,je_2+1) * p_mask(ji  ,je_2+1,1) + ( 1.- p_mask(ji  ,je_2+1,1) ) * r_inf ,  &
+                        &       p_fld(ji+1,je_2+1) * p_mask(ji+1,je_2+1,1) + ( 1.- p_mask(ji+1,je_2+1,1) ) * r_inf ,  &
+                        &       p_fld(ji+2,je_2+1) * p_mask(ji+2,je_2+1,1) + ( 1.- p_mask(ji+2,je_2+1,1) ) * r_inf ,  &
+                        &       p_fld(ji  ,je_2+2) * p_mask(ji  ,je_2+2,1) + ( 1.- p_mask(ji  ,je_2+2,1) ) * r_inf ,  &
+                        &       p_fld(ji+1,je_2+2) * p_mask(ji+1,je_2+2,1) + ( 1.- p_mask(ji+1,je_2+2,1) ) * r_inf ,  &
+                        &       p_fld(ji+2,je_2+2) * p_mask(ji+2,je_2+2,1) + ( 1.- p_mask(ji+2,je_2+2,1) ) * r_inf   )
+                      !
+                      p_fld_crs(ii,2) = zflcrs
+                   ENDIF
+
+                   DO jj = njstr, njend, nn_facty
+                      DO ji = nistr, niend, nn_factx
+                         ii   = ( ji - mis_crs(2) ) * rfactx_r + 2     
+                         ij   = ( jj - njstr ) * rfacty_r + 3
+                         zflcrs = &
+                          &  MIN( p_fld(ji  ,jj  ) * p_mask(ji  ,jj  ,1) + ( 1.- p_mask(ji  ,jj  ,1) ) * r_inf ,  &
+                          &       p_fld(ji+1,jj  ) * p_mask(ji+1,jj  ,1) + ( 1.- p_mask(ji+1,jj  ,1) ) * r_inf ,  &
+                          &       p_fld(ji+2,jj  ) * p_mask(ji+2,jj  ,1) + ( 1.- p_mask(ji+2,jj  ,1) ) * r_inf ,  &
+                          &       p_fld(ji  ,jj+1) * p_mask(ji  ,jj+1,1) + ( 1.- p_mask(ji  ,jj+1,1) ) * r_inf ,  &
+                          &       p_fld(ji+1,jj+1) * p_mask(ji+1,jj+1,1) + ( 1.- p_mask(ji+1,jj+1,1) ) * r_inf ,  &
+                          &       p_fld(ji+2,jj+1) * p_mask(ji+2,jj+1,1) + ( 1.- p_mask(ji+2,jj+1,1) ) * r_inf ,  &
+                          &       p_fld(ji  ,jj+2) * p_mask(ji  ,jj+2,1) + ( 1.- p_mask(ji  ,jj+2,1) ) * r_inf ,  &
+                          &       p_fld(ji+1,jj+2) * p_mask(ji+1,jj+2,1) + ( 1.- p_mask(ji+1,jj+2,1) ) * r_inf ,  &
+                          &       p_fld(ji+2,jj+2) * p_mask(ji+2,jj+2,1) + ( 1.- p_mask(ji+2,jj+2,1) ) * r_inf   )
+                         !
+                         p_fld_crs(ii,ij) = zflcrs
+                         !
+                      ENDDO      
+                   ENDDO
+            
+               CASE( 'V' )
+
+                  IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN     !!cc bande du sud style ORCA2
+                     IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN
+                        ijje = mje_crs(2)
+                      ENDIF
+                  ELSE
+                     ijje = mjs_crs(2)
+                  ENDIF
+
+                  DO ji = nistr, niend, nn_factx
+                     ii   = ( ji - mis_crs(2) ) * rfactx_r + 2    
+                     zflcrs = MIN( p_fld(ji  ,ijje) * p_mask(ji  ,ijje,1) + ( 1.- p_mask(ji,ijje,1) ) * r_inf ,  &
+                       &           p_fld(ji+1,ijje) * p_mask(ji+1,ijje,1) + ( 1.- p_mask(ji,ijje,1) ) * r_inf ,  &
+                       &           p_fld(ji+2,ijje) * p_mask(ji+2,ijje,1) + ( 1.- p_mask(ji,ijje,1) ) * r_inf )
+                       !
+                     p_fld_crs(ii,2) = zflcrs
+                  ENDDO      
+                  DO jj = njstr, njend, nn_facty
+                     DO ji = nistr, niend, nn_factx
+                        ii   = ( ji - mis_crs(2) ) * rfactx_r + 2    
+                        ij   = ( jj - njstr ) * rfacty_r + 3               
+                        ijje = mje_crs(ij) 
+                        !                  
+                        zflcrs = MIN( p_fld(ji  ,ijje) * p_mask(ji  ,ijje,1) + ( 1.- p_mask(ji,ijje,1) ) * r_inf ,  &
+                          &           p_fld(ji+1,ijje) * p_mask(ji+1,ijje,1) + ( 1.- p_mask(ji,ijje,1) ) * r_inf ,  &
+                          &           p_fld(ji+2,ijje) * p_mask(ji+2,ijje,1) + ( 1.- p_mask(ji,ijje,1) ) * r_inf )
+                        !
+                        p_fld_crs(ii,ij) = zflcrs
+                        !
+                     ENDDO      
+                  ENDDO
+            
+               CASE( 'U' )
+
+                 IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN     !!cc bande du sud style ORCA2
+                     IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN
+                        je_2 = mje_crs(2)
+                        DO ji = nistr, niend, nn_factx
+                           ii   = ( ji - mis_crs(2) ) * rfactx_r + 2    
+                           ijie = mie_crs(ii)
+                           zflcrs  =  p_fld(ijie,je_2) * p_mask(ijie,je_2,1) + ( 1.- p_mask(ijie,je_2,1) ) * r_inf 
+ 
+                           p_fld_crs(ii,2) = zflcrs
+                        ENDDO
+                     ENDIF
+                 ELSE
+                     je_2 = mjs_crs(2)
+                     DO ji = nistr, niend, nn_factx
+                        ii   = ( ji - mis_crs(2) ) * rfactx_r + 2    
+                        ijie = mie_crs(ii)
+                        zflcrs =  &
+                          &  MIN( p_fld(ijie,je_2  ) * p_mask(ijie,je_2  ,1) + ( 1.- p_mask(ijie,je_2,1) ) * r_inf ,  &
+                          &       p_fld(ijie,je_2+1) * p_mask(ijie,je_2+1,1) + ( 1.- p_mask(ijie,je_2,1) ) * r_inf ,  &
+                          &       p_fld(ijie,je_2+2) * p_mask(ijie,je_2+2,1) + ( 1.- p_mask(ijie,je_2,1) ) * r_inf  )
+                        p_fld_crs(ii,2) = zflcrs
+                     ENDDO
+                 ENDIF
+                 DO jj = njstr, njend, nn_facty
+                    DO ji = nistr, niend, nn_factx
+                       ii   = ( ji - mis_crs(2) ) * rfactx_r + 2     
+                       ij   = ( jj - njstr ) * rfacty_r + 3
+                       ijie = mie_crs(ii)
+                       zflcrs =  &
+                         &  MIN( p_fld(ijie,jj  ) * p_mask(ijie,jj  ,1) + ( 1.- p_mask(ijie,jj,1) ) * r_inf ,  &
+                         &       p_fld(ijie,jj+1) * p_mask(ijie,jj+1,1) + ( 1.- p_mask(ijie,jj,1) ) * r_inf ,  &
+                          &      p_fld(ijie,jj+2) * p_mask(ijie,jj+2,1) + ( 1.- p_mask(ijie,jj,1) ) * r_inf  )
+                        p_fld_crs(ii,ij) = zflcrs
+                        ! 
+                     ENDDO      
+                  ENDDO
+
+              END SELECT
+             !
+         END SELECT
+         !
+         CALL crs_lbc_lnk( p_fld_crs, cd_type, psgn )
+         !
+   END SUBROUTINE crs_dom_ope_2d
+
+   SUBROUTINE crs_dom_e3( p_e1, p_e2, p_e3, p_sfc_crs, cd_type, p_mask, p_e3_crs, p_e3_max_crs)
+      !!----------------------------------------------------------------  
+      !!  Arguments
+      CHARACTER(len=1),                         INTENT(in) :: cd_type      ! grid type T, W ( U, V, F)
+      REAL(wp), DIMENSION(jpi,jpj,jpk),         INTENT(in) :: p_mask       ! Parent grid T mask
+      REAL(wp), DIMENSION(jpi,jpj)    ,         INTENT(in) :: p_e1, p_e2   ! 2D tracer T or W on parent grid
+      REAL(wp), DIMENSION(jpi,jpj,jpk),         INTENT(in) :: p_e3         ! 3D tracer T or W on parent grid
+      REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(in) :: p_sfc_crs ! Coarse grid box east or north face quantity
+      REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(inout) :: p_e3_crs ! Coarse grid box east or north face quantity 
+      REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(inout) :: p_e3_max_crs ! Coarse grid box east or north face quantity 
+
+      !! Local variables
+      INTEGER ::  ji, jj, jk                   ! dummy loop indices
+      INTEGER ::  ijie, ijje, ii, ij, je_2
+      REAL(wp) :: ze3crs  
+      REAL(wp), DIMENSION(jpi,jpj,jpk) :: zmask, zsurf   
+
+      !!----------------------------------------------------------------  
+
+       p_e3_crs    (:,:,:) = 0.
+       p_e3_max_crs(:,:,:) = 1.
+   
+
+       SELECT CASE ( cd_type )
+          CASE( 'W' )
+              zmask(:,:,1) = p_mask(:,:,1) 
+              DO jk = 2, jpk
+                 zmask(:,:,jk) = p_mask(:,:,jk-1) 
+              ENDDO
+           CASE DEFAULT
+              DO jk = 1, jpk
+                 zmask(:,:,jk) = p_mask(:,:,jk) 
+              ENDDO
+       END SELECT
+
+       DO jk = 1, jpk
+          zsurf(:,:,jk) = p_e1(:,:) * p_e2(:,:) * p_e3(:,:,jk) 
+       ENDDO
+
+       IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN     !!cc bande du sud style ORCA2
+          IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN
+             je_2 = mje_crs(2)
+             DO jk = 1 , jpk
+                DO ji = nistr, niend, nn_factx
+                   ii   = ( ji - mis_crs(2) ) * rfactx_r + 2     
+                   ze3crs =   zsurf(ji  ,je_2,jk) * zmask(ji  ,je_2,jk)   &
+                        &   + zsurf(ji+1,je_2,jk) * zmask(ji+1,je_2,jk)   &
+                        &   + zsurf(ji+2,je_2,jk) * zmask(ji+2,je_2,jk) 
+
+                   p_e3_crs(ii,2,jk) = ze3crs / p_sfc_crs(ii,ij,jk)
+                   !
+                   ze3crs = MAX( p_e3(ji  ,je_2,jk) * zmask(ji  ,je_2,jk),  &
+                      &          p_e3(ji+1,je_2,jk) * zmask(ji+1,je_2,jk),  &
+                      &          p_e3(ji+2,je_2,jk) * zmask(ji+2,je_2,jk)  )
+                   !
+                   p_e3_max_crs(ii,2,jk) = ze3crs
+                ENDDO
+             ENDDO
+          ENDIF
+       ELSE
+          je_2 = mjs_crs(2)
+          DO jk = 1 , jpk
+             DO ji = nistr, niend, nn_factx
+                ii   = ( ji - mis_crs(2) ) * rfactx_r + 2     
+                ze3crs =  zsurf(ji  ,je_2  ,jk) * zmask(ji  ,je_2  ,jk)   &
+                   &    + zsurf(ji+1,je_2  ,jk) * zmask(ji+1,je_2  ,jk)   &
+                   &    + zsurf(ji+2,je_2  ,jk) * zmask(ji+2,je_2  ,jk)   &
+                   &    + zsurf(ji  ,je_2+1,jk) * zmask(ji  ,je_2+1,jk)   &
+                   &    + zsurf(ji+1,je_2+1,jk) * zmask(ji+1,je_2+1,jk)   &
+                   &    + zsurf(ji+2,je_2+1,jk) * zmask(ji+2,je_2+1,jk)   &
+                   &    + zsurf(ji  ,je_2+2,jk) * zmask(ji  ,je_2+2,jk)   &
+                   &    + zsurf(ji+1,je_2+2,jk) * zmask(ji+1,je_2+2,jk)   &
+                   &    + zsurf(ji+2,je_2+2,jk) * zmask(ji+2,je_2+2,jk)
+
+                p_e3_crs(ii,2,jk) = ze3crs / p_sfc_crs(ii,2,jk)
+                !
+                ze3crs = MAX( p_e3(ji  ,je_2  ,jk) * zmask(ji  ,je_2  ,jk),  &
+                   &          p_e3(ji+1,je_2  ,jk) * zmask(ji+1,je_2  ,jk),  &
+                   &          p_e3(ji+2,je_2  ,jk) * zmask(ji+2,je_2  ,jk),  &
+                   &          p_e3(ji  ,je_2+1,jk) * zmask(ji  ,je_2+1,jk),  &
+                   &          p_e3(ji+1,je_2+1,jk) * zmask(ji+1,je_2+1,jk),  &
+                   &          p_e3(ji+2,je_2+1,jk) * zmask(ji+2,je_2+1,jk),  &
+                   &          p_e3(ji  ,je_2+2,jk) * zmask(ji  ,je_2+2,jk),  &
+                   &          p_e3(ji+1,je_2+2,jk) * zmask(ji+1,je_2+2,jk),  &
+                   &          p_e3(ji+2,je_2+2,jk) * zmask(ji+2,je_2+2,jk) )
+               
+                p_e3_max_crs(ii,2,jk) = ze3crs
+                ENDDO
+             ENDDO
+          ENDIF
+          DO jk = 1 , jpk
+             DO jj = njstr, njend, nn_facty
+                DO ji = nistr, niend, nn_factx
+                   ii   = ( ji - mis_crs(2) ) * rfactx_r + 2          
+                   ij   = ( jj - njstr ) * rfacty_r + 3
+                   ze3crs =   zsurf(ji  ,jj  ,jk) * zmask(ji  ,jj  ,jk)   &
+                   &        + zsurf(ji+1,jj  ,jk) * zmask(ji+1,jj  ,jk)   &
+                   &        + zsurf(ji+2,jj  ,jk) * zmask(ji+2,jj  ,jk)   &
+                   &        + zsurf(ji  ,jj+1,jk) * zmask(ji  ,jj+1,jk)   &
+                   &        + zsurf(ji+1,jj+1,jk) * zmask(ji+1,jj+1,jk)   &
+                   &        + zsurf(ji+2,jj+1,jk) * zmask(ji+2,jj+1,jk)   &
+                   &        + zsurf(ji  ,jj+2,jk) * zmask(ji  ,jj+2,jk)   &
+                   &        + zsurf(ji+1,jj+2,jk) * zmask(ji+1,jj+2,jk)   &
+                   &        + zsurf(ji+2,jj+2,jk) * zmask(ji+2,jj+2,jk)
+
+                p_e3_crs(ii,ij,jk) = ze3crs / p_sfc_crs(ii,ij,jk)
+                !
+                ze3crs = MAX( p_e3(ji  ,jj  ,jk) * zmask(ji  ,jj  ,jk),  &
+                   &          p_e3(ji+1,jj  ,jk) * zmask(ji+1,jj  ,jk),  &
+                   &          p_e3(ji+2,jj  ,jk) * zmask(ji+2,jj  ,jk),  &
+                   &          p_e3(ji  ,jj+1,jk) * zmask(ji  ,jj+1,jk),  &
+                   &          p_e3(ji+1,jj+1,jk) * zmask(ji+1,jj+1,jk),  &
+                   &          p_e3(ji+2,jj+1,jk) * zmask(ji+2,jj+1,jk),  &
+                   &          p_e3(ji  ,jj+2,jk) * zmask(ji  ,jj+2,jk),  &
+                   &          p_e3(ji+1,jj+2,jk) * zmask(ji+1,jj+2,jk),  &
+                   &          p_e3(ji+2,jj+2,jk) * zmask(ji+2,jj+2,jk) )
+               
+                p_e3_max_crs(ii,ij,jk) = ze3crs
+             ENDDO
+          ENDDO
+       ENDDO
+                  
+       CALL crs_lbc_lnk( p_e3_crs    , cd_type, 1.0, pval=1.0 )  
+       CALL crs_lbc_lnk( p_e3_max_crs, cd_type, 1.0, pval=1.0 )  
+       !              
+       !
+   END SUBROUTINE crs_dom_e3
+
+   SUBROUTINE crs_dom_sfc( p_mask, cd_type, p_surf_crs, p_surf_crs_msk,  p_e1, p_e2, p_e3 )
+
+      !!  Arguments
+      CHARACTER(len=1),                         INTENT(in)           :: cd_type      ! grid type T, W ( U, V, F)
+      REAL(wp), DIMENSION(jpi,jpj,jpk)        , INTENT(in)           :: p_mask       ! Parent grid T mask
+      REAL(wp), DIMENSION(jpi,jpj)            , INTENT(in), OPTIONAL :: p_e1, p_e2         ! 3D tracer T or W on parent grid
+      REAL(wp), DIMENSION(jpi,jpj,jpk)        , INTENT(in), OPTIONAL :: p_e3         ! 3D tracer T or W on parent grid
+      REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(out)          :: p_surf_crs ! Coarse grid box east or north face quantity 
+      REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(out)          :: p_surf_crs_msk ! Coarse grid box east or north face quantity 
+
+      !! Local variables
+      INTEGER  :: ji, jj, jk                   ! dummy loop indices
+      INTEGER  :: ii, ij, je_2
+      REAL(wp), DIMENSION(jpi,jpj,jpk) :: zsurf, zsurfmsk   
+      !!----------------------------------------------------------------  
+      ! Initialize
+
+      !
+      SELECT CASE ( cd_type )
+      
+         CASE ('W')    
+            DO jk = 1, jpk
+               zsurf(:,:,jk) = p_e1(:,:) * p_e2(:,:) 
+            ENDDO
+            zsurfmsk(:,:,1) = zsurf(:,:,1) * p_mask(:,:,1) 
+            DO jk = 2, jpk
+               zsurfmsk(:,:,jk) = zsurf(:,:,jk) * p_mask(:,:,jk-1) 
+            ENDDO
+
+         CASE ('V')     
+            DO jk = 1, jpk
+               zsurf(:,:,jk) = p_e1(:,:) * p_e3(:,:,jk) 
+            ENDDO
+            DO jk = 1, jpk
+               zsurfmsk(:,:,jk) = zsurf(:,:,jk) * p_mask(:,:,jk) 
+            ENDDO
+
+         CASE ('U')     
+            DO jk = 1, jpk
+               zsurf(:,:,jk) = p_e2(:,:) * p_e3(:,:,jk) 
+            ENDDO
+            DO jk = 1, jpk
+               zsurfmsk(:,:,jk) = zsurf(:,:,jk) * p_mask(:,:,jk) 
+            ENDDO
+
+         CASE DEFAULT
+            DO jk = 1, jpk
+               zsurf(:,:,jk) = p_e1(:,:) * p_e2(:,:) 
+            ENDDO
+            DO jk = 1, jpk
+               zsurfmsk(:,:,jk) = zsurf(:,:,jk) * p_mask(:,:,jk) 
+            ENDDO
+      END SELECT
+
+      IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN     !!cc bande du sud style ORCA2
+         IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN
+            je_2 = mje_crs(2)
+            DO jk = 1, jpk
+               DO ji = nistr, niend, nn_factx
+                  ii   = ( ji - mis_crs(2) ) * rfactx_r + 2 
+                  !    
+                  p_surf_crs    (ii,2,jk) =  zsurf(ji,je_2  ,jk) + zsurf(ji+1,je_2  ,jk) + zsurf(ji+2,je_2  ,jk) &
+                    &                      + zsurf(ji,je_2-1,jk) + zsurf(ji+1,je_2-1,jk) + zsurf(ji+2,je_2-1,jk)  ! Why ?????
+                  !
+                  p_surf_crs_msk(ii,2,jk) =  zsurfmsk(ji,je_2,jk) + zsurfmsk(ji+1,je_2,jk) + zsurfmsk(ji+2,je_2,jk) 
+                  !
+               ENDDO
+            ENDDO
+         ENDIF
+      ELSE
+         je_2 = mjs_crs(2)
+         DO jk = 1, jpk
+            DO ji = nistr, niend, nn_factx
+               ii   = ( ji - mis_crs(2) ) * rfactx_r + 2 
+               !  
+               p_surf_crs    (ii,2,jk) =  zsurf(ji,je_2  ,jk) + zsurf(ji+1,je_2  ,jk) + zsurf(ji+2,je_2  ,jk)  &
+                    &                   + zsurf(ji,je_2+1,jk) + zsurf(ji+1,je_2+1,jk) + zsurf(ji+2,je_2+1,jk)  &
+                    &                   + zsurf(ji,je_2+2,jk) + zsurf(ji+1,je_2+2,jk) + zsurf(ji+2,je_2+2,jk)  
+
+               p_surf_crs_msk(ii,2,jk) =  zsurfmsk(ji,je_2  ,jk) + zsurfmsk(ji+1,je_2  ,jk) + zsurfmsk(ji+2,je_2  ,jk)  &
+                    &                   + zsurfmsk(ji,je_2+1,jk) + zsurfmsk(ji+1,je_2+1,jk) + zsurfmsk(ji+2,je_2+1,jk)  &
+                    &                   + zsurfmsk(ji,je_2+2,jk) + zsurfmsk(ji+1,je_2+2,jk) + zsurfmsk(ji+2,je_2+2,jk)  
+                ENDDO
+            ENDDO
+      ENDIF
+         
+      DO jk = 1, jpk
+         DO jj = njstr, njend, nn_facty
+            DO ji = nistr, niend, nn_factx
+               ii = ( ji - mis_crs(2) ) * rfactx_r + 2  
+               ij = ( jj - njstr ) * rfacty_r + 3
+               !
+               p_surf_crs    (ii,ij,jk) =  zsurf(ji,jj  ,jk) + zsurf(ji+1,jj  ,jk) + zsurf(ji+2,jj  ,jk)  &
+                    &                    + zsurf(ji,jj+1,jk) + zsurf(ji+1,jj+1,jk) + zsurf(ji+2,jj+1,jk)  &
+                    &                    + zsurf(ji,jj+2,jk) + zsurf(ji+1,jj+2,jk) + zsurf(ji+2,jj+2,jk)  
+
+               p_surf_crs_msk(ii,ij,jk) =  zsurfmsk(ji,jj  ,jk) + zsurfmsk(ji+1,jj  ,jk) + zsurfmsk(ji+2,jj  ,jk)  &
+                    &                    + zsurfmsk(ji,jj+1,jk) + zsurfmsk(ji+1,jj+1,jk) + zsurfmsk(ji+2,jj+1,jk)  &
+                    &                    + zsurfmsk(ji,jj+2,jk) + zsurfmsk(ji+1,jj+2,jk) + zsurfmsk(ji+2,jj+2,jk)  
+            ENDDO      
+         ENDDO
+      ENDDO   
+
+      CALL crs_lbc_lnk( p_surf_crs    , cd_type, 1.0, pval=1.0 )
+      CALL crs_lbc_lnk( p_surf_crs_msk, cd_type, 1.0, pval=1.0 )
+
+   END SUBROUTINE crs_dom_sfc
+   
+   SUBROUTINE crs_dom_def
+      !!----------------------------------------------------------------
+      !!               *** SUBROUTINE crs_dom_def ***
+      !! ** Purpose :  Three applications.
+      !!               1) Define global domain indice of the croasening grid
+      !!               2) Define local domain indice of the croasening grid
+      !!               3) Define the processor domain indice for a croasening grid
+      !!----------------------------------------------------------------
+      !! 
+      !!  local variables
+   
+      INTEGER  :: ji,jj,jk,ijjgloT,ijis,ijie,ijjs,ijje,jn      ! dummy indices
+      INTEGER  :: ierr                                ! allocation error status
+ 
+  
+     ! 1.a. Define global domain indices  : take into account the interior domain only ( removes i/j=1 , i/j=jpiglo/jpjglo ) then add 2/3 grid points 
+      jpiglo_crs   = INT( (jpiglo - 2) / nn_factx ) + 2
+  !    jpjglo_crs   = INT( (jpjglo - 2) / nn_facty ) + 2  ! the -2 removes j=1, j=jpj
+  !    jpjglo_crs   = INT( (jpjglo - 2) / nn_facty ) + 3
+      jpjglo_crs   = INT( (jpjglo - MOD(jpjglo, nn_facty)) / nn_facty ) + 3
+      jpiglo_crsm1 = jpiglo_crs - 1
+      jpjglo_crsm1 = jpjglo_crs - 1  
+
+      jpi_crs = ( jpiglo_crs   - 2 * nn_hls + (jpni-1) ) / jpni + 2 * nn_hls
+      jpj_crs = ( jpjglo_crsm1 - 2 * nn_hls + (jpnj-1) ) / jpnj + 2 * nn_hls   
+              
+      IF( noso < 0 ) jpj_crs = jpj_crs + 1    ! add a local band on southern processors  
+       
+      jpi_crsm1   = jpi_crs - 1
+      jpj_crsm1   = jpj_crs - 1
+      nperio_crs  = jperio
+      npolj_crs   = npolj
+      
+      ierr = crs_dom_alloc()          ! allocate most coarse grid arrays
+
+      ! 2.a Define processor domain
+      IF( .NOT. lk_mpp ) THEN
+         nimpp_crs  = 1
+         njmpp_crs  = 1
+         nlci_crs   = jpi_crs
+         nlcj_crs   = jpj_crs
+         nldi_crs   = 1
+         nldj_crs   = 1
+         nlei_crs   = jpi_crs
+         nlej_crs   = jpj_crs
+      ELSE
+         ! Initialisation of most local variables -
+         nimpp_crs  = 1
+         njmpp_crs  = 1
+         nlci_crs   = jpi_crs
+         nlcj_crs   = jpj_crs
+         nldi_crs   = 1
+         nldj_crs   = 1
+         nlei_crs   = jpi_crs
+         nlej_crs   = jpj_crs
+         
+        ! Calculs suivant une découpage en j
+        DO jn = 1, jpnij, jpni
+           IF( jn < ( jpnij - jpni + 1 ) ) THEN
+              nlejt_crs(jn) = AINT( REAL( ( jpjglo - (njmppt(jn     ) - 1) ) / nn_facty, wp ) ) &
+                       &    - AINT( REAL( ( jpjglo - (njmppt(jn+jpni) - 1) ) / nn_facty, wp ) )
+           ELSE                                             
+              nlejt_crs(jn) = AINT( REAL(  nlejt(jn) / nn_facty, wp ) ) + 1            
+           ENDIF
+           IF( noso < 0 ) nlejt_crs(jn) = nlejt_crs(jn) + 1             
+           SELECT CASE( ibonjt(jn) )
+              CASE ( -1 )
+                IF( MOD( jpjglo - njmppt(jn), nn_facty) > 0 )  nlejt_crs(jn) = nlejt_crs(jn) + 1
+                nlcjt_crs(jn) = nlejt_crs(jn) + nn_hls
+                nldjt_crs(jn) = nldjt(jn)
+              
+              CASE ( 0 )
+              
+                nldjt_crs(jn) = nldjt(jn)
+                IF( nldjt(jn) == 1 )  nlejt_crs(jn) = nlejt_crs(jn) + 1
+                nlejt_crs(jn) = nlejt_crs(jn) + nn_hls
+                nlcjt_crs(jn) = nlejt_crs(jn) + nn_hls
+                
+              CASE ( 1, 2 )
+              
+                nlejt_crs(jn) = nlejt_crs(jn) + nn_hls
+                nlcjt_crs(jn) = nlejt_crs(jn)
+                nldjt_crs(jn) = nldjt(jn)
+                
+              CASE DEFAULT
+                 STOP
+           END SELECT
+           IF( nlcjt_crs(jn) > jpj_crs )     jpj_crs = jpj_crs + 1
+
+           IF(nldjt_crs(jn) == 1 ) THEN
+              njmppt_crs(jn) = 1
+           ELSE
+              njmppt_crs(jn) = 2 + ANINT(REAL((njmppt(jn) + 1 - MOD( jpjglo , nn_facty )) / nn_facty, wp ) )
+           ENDIF           
+           
+           DO jj = jn + 1, jn + jpni - 1
+              nlejt_crs(jj) = nlejt_crs(jn) 
+              nlcjt_crs(jj) = nlcjt_crs(jn)
+              nldjt_crs(jj) = nldjt_crs(jn)
+              njmppt_crs(jj)= njmppt_crs(jn)
+           ENDDO
+        ENDDO 
+        nlej_crs  = nlejt_crs(nproc + 1) 
+        nlcj_crs  = nlcjt_crs(nproc + 1)
+        nldj_crs  = nldjt_crs(nproc + 1)
+        njmpp_crs = njmppt_crs(nproc + 1)
+
+        ! Calcul suivant un decoupage en i
+        DO jn = 1, jpni
+           IF( jn == 1 ) THEN          
+              nleit_crs(jn) = AINT( REAL( ( nimppt(jn  ) - 1 + nlcit(jn  ) )  / nn_factx, wp) )
+           ELSE
+              nleit_crs(jn) = AINT( REAL( ( nimppt(jn  ) - 1 + nlcit(jn  ) )  / nn_factx, wp) ) &
+                 &          - AINT( REAL( ( nimppt(jn-1) - 1 + nlcit(jn-1) )  / nn_factx, wp) )
+           ENDIF
+
+           SELECT CASE( ibonit(jn) )
+              CASE ( -1 )
+                 nleit_crs(jn) = nleit_crs(jn) + nn_hls           
+                 nlcit_crs(jn) = nleit_crs(jn) + nn_hls
+                 nldit_crs(jn) = nldit(jn) 
+              
+              CASE ( 0 )
+                 nleit_crs(jn) = nleit_crs(jn) + nn_hls
+                 nlcit_crs(jn) = nleit_crs(jn) + nn_hls
+                 nldit_crs(jn) = nldit(jn) 
+                
+              CASE ( 1, 2 )
+                 IF( MOD( jpiglo - nimppt(jn), nn_factx) > 0 )  nleit_crs(jn) = nleit_crs(jn) + 1
+                 nleit_crs(jn) = nleit_crs(jn) + nn_hls
+                 nlcit_crs(jn) = nleit_crs(jn)
+                 nldit_crs(jn) = nldit(jn) 
+
+              CASE DEFAULT
+                 STOP
+           END SELECT
+
+           nimppt_crs(jn) = ANINT( REAL( (nimppt(jn) + 1 ) / nn_factx, wp ) ) + 1
+           DO jj = jn + jpni , jpnij, jpni
+              nleit_crs(jj) = nleit_crs(jn) 
+              nlcit_crs(jj) = nlcit_crs(jn)
+              nldit_crs(jj) = nldit_crs(jn)
+              nimppt_crs(jj)= nimppt_crs(jn)
+           ENDDO
+         ENDDO 
+        
+         nlei_crs  = nleit_crs(nproc + 1) 
+         nlci_crs  = nlcit_crs(nproc + 1)
+         nldi_crs  = nldit_crs(nproc + 1)
+         nimpp_crs = nimppt_crs(nproc + 1)
+
+         DO ji = 1, jpi_crs
+            mig_crs(ji) = ji + nimpp_crs - 1
+         ENDDO
+         DO jj = 1, jpj_crs
+            mjg_crs(jj) = jj + njmpp_crs - 1!
+         ENDDO
+       
+         DO ji = 1, jpiglo_crs
+            mi0_crs(ji) = MAX( 1, MIN( ji - nimpp_crs + 1 , jpi_crs + 1 ) )
+            mi1_crs(ji) = MAX( 0, MIN( ji - nimpp_crs + 1 , jpi_crs     ) )
+         ENDDO
+         
+         DO jj = 1, jpjglo_crs
+            mj0_crs(jj) = MAX( 1, MIN( jj - njmpp_crs + 1 , jpj_crs + 1 ) )
+            mj1_crs(jj) = MAX( 0, MIN( jj - njmpp_crs + 1 , jpj_crs     ) )
+         ENDDO
+
+      ENDIF
+      
+      !                         Save the parent grid information
+      jpi_full    = jpi
+      jpj_full    = jpj
+      jpim1_full  = jpim1
+      jpjm1_full  = jpjm1
+      nperio_full = nperio
+
+      npolj_full  = npolj
+      jpiglo_full = jpiglo
+      jpjglo_full = jpjglo
+
+      nlcj_full   = nlcj
+      nlci_full   = nlci
+      nldi_full   = nldi
+      nldj_full   = nldj
+      nlei_full   = nlei
+      nlej_full   = nlej
+      nimpp_full  = nimpp     
+      njmpp_full  = njmpp
+      
+      nlcit_full(:)  = nlcit(:)
+      nldit_full(:)  = nldit(:)
+      nleit_full(:)  = nleit(:)
+      nimppt_full(:) = nimppt(:)
+      nlcjt_full(:)  = nlcjt(:)
+      nldjt_full(:)  = nldjt(:)
+      nlejt_full(:)  = nlejt(:)
+      njmppt_full(:) = njmppt(:)
+      
+      CALL dom_grid_crs  !swich de grille
+     
+
+      IF(lwp) THEN
+         WRITE(numout,*)
+         WRITE(numout,*) 'crs_init : coarse grid dimensions'
+         WRITE(numout,*) '~~~~~~~   coarse domain global j-dimension           jpjglo = ', jpjglo
+         WRITE(numout,*) '~~~~~~~   coarse domain global i-dimension           jpiglo = ', jpiglo
+         WRITE(numout,*) '~~~~~~~   coarse domain local  i-dimension              jpi = ', jpi
+         WRITE(numout,*) '~~~~~~~   coarse domain local  j-dimension              jpj = ', jpj
+         WRITE(numout,*)
+         WRITE(numout,*) ' nproc  = '     , nproc
+         WRITE(numout,*) ' nlci   = '     , nlci
+         WRITE(numout,*) ' nlcj   = '     , nlcj
+         WRITE(numout,*) ' nldi   = '     , nldi
+         WRITE(numout,*) ' nldj   = '     , nldj
+         WRITE(numout,*) ' nlei   = '     , nlei
+         WRITE(numout,*) ' nlej   = '     , nlej
+         WRITE(numout,*) ' nlei_full='    , nlei_full
+         WRITE(numout,*) ' nldi_full='    , nldi_full
+         WRITE(numout,*) ' nimpp  = '     , nimpp
+         WRITE(numout,*) ' njmpp  = '     , njmpp
+         WRITE(numout,*) ' njmpp_full  = ', njmpp_full
+         WRITE(numout,*)
+      ENDIF
+      
+      CALL dom_grid_glo
+      
+      mxbinctr   = INT( nn_factx * 0.5 )
+      mybinctr   = INT( nn_facty * 0.5 )
+
+      nrestx = MOD( nn_factx, 2 )   ! check if even- or odd- numbered reduction factor
+      nresty = MOD( nn_facty, 2 )
+
+      IF ( nrestx == 0 ) THEN
+         mxbinctr = mxbinctr - 1
+      ENDIF
+
+      IF ( nresty == 0 ) THEN
+         mybinctr = mybinctr - 1
+         IF ( jperio == 3 .OR. jperio == 4 )  nperio_crs = jperio + 2
+         IF ( jperio == 5 .OR. jperio == 6 )  nperio_crs = jperio - 2 
+
+         IF ( npolj == 3 ) npolj_crs = 5
+         IF ( npolj == 5 ) npolj_crs = 3
+      ENDIF     
+      
+      rfactxy = nn_factx * nn_facty
+      
+      ! 2.b. Set up bins for coarse grid, horizontal only.
+      ierr = crs_dom_alloc2()
+     
+      mis2_crs(:) = 0      ;      mie2_crs(:) = 0
+      mjs2_crs(:) = 0      ;      mje2_crs(:) = 0
+
+      
+      SELECT CASE ( nn_binref )
+
+      CASE ( 0 ) 
+
+         SELECT CASE ( nperio )
+     
+ 
+        CASE ( 0, 1, 3, 4 )    !   3, 4 : T-Pivot at North Fold
+        
+            DO ji = 2, jpiglo_crsm1
+               ijie = ( ji * nn_factx ) - nn_factx   !cc
+               ijis = ijie - nn_factx + 1
+               mis2_crs(ji) = ijis
+               mie2_crs(ji) = ijie
+            ENDDO
+            IF ( jpiglo - 1 - mie2_crs(jpiglo_crsm1) <= nn_factx ) mie2_crs(jpiglo_crsm1) = jpiglo - 2  
+
+            ! Handle first the northernmost bin
+            IF ( nn_facty == 2 ) THEN   ;    ijjgloT = jpjglo - 1 
+            ELSE                        ;    ijjgloT = jpjglo
+            ENDIF
+
+            DO jj = 2, jpjglo_crs
+                ijje = ijjgloT - nn_facty * ( jj - 3 )
+                ijjs = ijje - nn_facty + 1                   
+                mjs2_crs(jpjglo_crs-jj+2) = ijjs
+                mje2_crs(jpjglo_crs-jj+2) = ijje
+            ENDDO
+
+         CASE ( 2 ) 
+            WRITE(numout,*)  'crs_init, jperio=2 not supported' 
+        
+         CASE ( 5, 6 )    ! F-pivot at North Fold
+
+            DO ji = 2, jpiglo_crsm1
+               ijie = ( ji * nn_factx ) - nn_factx 
+               ijis = ijie - nn_factx + 1
+               mis2_crs(ji) = ijis
+               mie2_crs(ji) = ijie
+            ENDDO
+            IF ( jpiglo - 1 - mie2_crs(jpiglo_crsm1) <= nn_factx ) mie_crs(jpiglo_crsm1)  = jpiglo - 2 
+
+            ! Treat the northernmost bin separately.
+            jj = 2
+            ijje = jpj - nn_facty * ( jj - 2 )
+            IF ( nn_facty == 3 ) THEN   ;  ijjs = ijje - 1 
+            ELSE                        ;  ijjs = ijje - nn_facty + 1
+            ENDIF
+            mjs2_crs(jpj_crs-jj+1) = ijjs
+            mje2_crs(jpj_crs-jj+1) = ijje
+
+            ! Now bin the rest, any remainder at the south is lumped in the southern bin
+            DO jj = 3, jpjglo_crsm1
+                ijje = jpjglo - nn_facty * ( jj - 2 )
+                ijjs = ijje - nn_facty + 1                  
+                IF ( ijjs <= nn_facty )  ijjs = 2
+                mjs2_crs(jpj_crs-jj+1)   = ijjs
+                mje2_crs(jpj_crs-jj+1)   = ijje
+            ENDDO
+
+         CASE DEFAULT
+            WRITE(numout,*) 'crs_init. Only jperio = 0, 1, 3, 4, 5, 6 supported' 
+ 
+         END SELECT
+
+      CASE (1 )
+         WRITE(numout,*) 'crs_init.  Equator-centered bins option not yet available' 
+
+      END SELECT
+
+     ! Pad the boundaries, do not know if it is necessary
+      mis2_crs(2) = 1             ;  mis2_crs(jpiglo_crs) = mie2_crs(jpiglo_crs - 1) + 1   
+      mie2_crs(2) = nn_factx      ;  mie2_crs(jpiglo_crs) = jpiglo                         
+      !
+      mjs2_crs(1) = 1
+      mje2_crs(1) = 1
+      !
+      mje2_crs(2) = mjs2_crs(3)-1 ;  mje2_crs(jpjglo_crs) = jpjglo
+      mjs2_crs(2) = 1             ;  mjs2_crs(jpjglo_crs) = mje2_crs(jpjglo_crs) - nn_facty + 1 
+ 
+      IF( .NOT. lk_mpp ) THEN     
+        mis_crs(:) = mis2_crs(:) 
+        mie_crs(:) = mie2_crs(:)
+        mjs_crs(:) = mjs2_crs(:) 
+        mje_crs(:) = mje2_crs(:) 
+      ELSE
+        DO jj = 1, nlej_crs
+           mjs_crs(jj) = mjs2_crs(mjg_crs(jj)) - njmpp + 1
+           mje_crs(jj) = mje2_crs(mjg_crs(jj)) - njmpp + 1
+        ENDDO
+        DO ji = 1, nlei_crs
+           mis_crs(ji) = mis2_crs(mig_crs(ji)) - nimpp + 1
+           mie_crs(ji) = mie2_crs(mig_crs(ji)) - nimpp + 1
+        ENDDO
+      ENDIF
+      !
+      nistr = mis_crs(2)  ;   niend = mis_crs(nlci_crs - 1)
+      njstr = mjs_crs(3)  ;   njend = mjs_crs(nlcj_crs - 1)
+      !
+   END SUBROUTINE crs_dom_def
+   
+   SUBROUTINE crs_dom_bat
+      !!----------------------------------------------------------------
+      !!               *** SUBROUTINE crs_dom_bat ***
+      !! ** Purpose :  coarsenig bathy
+      !!----------------------------------------------------------------
+      !! 
+      !!  local variables
+      INTEGER  :: ji,jj,jk      ! dummy indices
+      REAL(wp), DIMENSION(jpi_crs, jpj_crs) :: zmbk
+      !!----------------------------------------------------------------
+   
+      mbathy_crs(:,:) = jpkm1
+      mbkt_crs(:,:) = 1
+      mbku_crs(:,:) = 1
+      mbkv_crs(:,:) = 1
+
+
+      DO jj = 1, jpj_crs
+         DO ji = 1, jpi_crs
+            jk = 0
+            DO WHILE( tmask_crs(ji,jj,jk+1) > 0.)
+               jk = jk + 1
+            ENDDO
+            mbathy_crs(ji,jj) = float( jk )
+         ENDDO
+      ENDDO
+     
+      zmbk(:,:) = 0.0
+      zmbk(:,:) = REAL( mbathy_crs(:,:), wp ) ;   CALL crs_lbc_lnk(zmbk,'T',1.0)   ;   mbathy_crs(:,:) = INT( zmbk(:,:) )
+
+
+      !
+      IF(lwp) WRITE(numout,*)
+      IF(lwp) WRITE(numout,*) '    crsini : mbkt is ocean bottom k-index of T-, U-, V- and W-levels '
+      IF(lwp) WRITE(numout,*) '    ~~~~~~~~~~~~~'
+      !
+      mbkt_crs(:,:) = MAX( mbathy_crs(:,:) , 1 )    ! bottom k-index of T-level (=1 over land)
+      !                                     ! bottom k-index of W-level = mbkt+1
+
+      DO jj = 1, jpj_crsm1                      ! bottom k-index of u- (v-) level
+         DO ji = 1, jpi_crsm1
+            mbku_crs(ji,jj) = MIN(  mbkt_crs(ji+1,jj  ) , mbkt_crs(ji,jj)  )
+            mbkv_crs(ji,jj) = MIN(  mbkt_crs(ji  ,jj+1) , mbkt_crs(ji,jj)  )
+         END DO
+      END DO
+
+      ! convert into REAL to use lbc_lnk ; impose a min value of 1 as a zero can be set in lbclnk
+      zmbk(:,:) = 1.e0;    
+      zmbk(:,:) = REAL( mbku_crs(:,:), wp )   ;   CALL crs_lbc_lnk(zmbk,'U',1.0) ; mbku_crs  (:,:) = MAX( INT( zmbk(:,:) ), 1 ) 
+      zmbk(:,:) = REAL( mbkv_crs(:,:), wp )   ;   CALL crs_lbc_lnk(zmbk,'V',1.0) ; mbkv_crs  (:,:) = MAX( INT( zmbk(:,:) ), 1 ) 
+      !
+   END SUBROUTINE crs_dom_bat
+
+
+END MODULE crsdom
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/CRS/crsdomwri.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/CRS/crsdomwri.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/CRS/crsdomwri.F90	(revision 9570)
@@ -0,0 +1,237 @@
+MODULE crsdomwri
+   !!======================================================================
+   !! Coarse Ocean initialization : write the coarse ocean domain mesh and mask files
+   !!======================================================================
+   !! History :  3.6   ! 2012-06  (J. Simeon, C. Calone, C Ethe )  from domwri, reduced and modified for coarse grid
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   crs_dom_wri    : create and write mesh and mask file(s)
+   !!----------------------------------------------------------------------
+   USE timing          ! Timing
+   USE dom_oce         ! ocean space and time domain
+   USE in_out_manager  ! I/O manager
+   USE par_kind, ONLY: wp
+   USE lib_mpp         ! MPP library
+   USE iom_def
+   USE iom
+   USE crs         ! coarse grid domain
+   USE crsdom         ! coarse grid domain
+   USE crslbclnk       ! crs mediator to lbclnk
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC crs_dom_wri        ! routine called by crsini.F90
+
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO Consortium (2010)
+   !! $Id$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE crs_dom_wri
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE crs_dom_wri  ***
+      !!
+      !! ** Purpose :   Create the NetCDF file(s) which contain(s) all the
+      !!      ocean domain informations (mesh and mask arrays). This (these)
+      !!      file(s) is (are) used for visualisation (SAXO software) and
+      !!      diagnostic computation.
+      !!
+      !! ** Method  :   Write in a file all the arrays generated in routines
+      !!      crsini for meshes and mask. In three separate files: 
+      !!      domain size, horizontal grid-point position,
+      !!      masks, depth and vertical scale factors
+      !!      
+      !! ** Output files :   mesh_hgr_crs.nc, mesh_zgr_crs.nc, mesh_mask.nc
+      !!----------------------------------------------------------------------
+      INTEGER           ::   ji, jj, jk   ! dummy loop indices
+      INTEGER           ::   inum         ! local units for 'mesh_mask.nc' file
+      INTEGER           ::   iif, iil, ijf, ijl
+      CHARACTER(len=21) ::   clnam        ! filename (mesh and mask informations)
+      !                                   !  workspace
+      REAL(wp), DIMENSION(jpi_crs,jpj_crs    ) ::   zprt, zprw 
+      REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk) ::   zdepu, zdepv
+      !!----------------------------------------------------------------------
+      !
+      !
+      IF(lwp) WRITE(numout,*)
+      IF(lwp) WRITE(numout,*) 'crs_dom_wri : create NetCDF mesh and mask file'
+      IF(lwp) WRITE(numout,*) '~~~~~~~~~~~'
+      
+      clnam = 'mesh_mask_crs'  ! filename (mesh and mask informations)
+      
+
+      !                            ! ============================
+      !                            !  create 'mesh_mask.nc' file
+      !                            ! ============================
+      !
+      CALL iom_open( TRIM(clnam), inum, ldwrt = .TRUE., kiolib = jprstlib )
+ 
+      CALL iom_rstput( 0, 0, inum, 'tmask', tmask_crs, ktype = jp_i1 )    ! land-sea mask
+      CALL iom_rstput( 0, 0, inum, 'umask', umask_crs, ktype = jp_i1 )
+      CALL iom_rstput( 0, 0, inum, 'vmask', vmask_crs, ktype = jp_i1 )
+      CALL iom_rstput( 0, 0, inum, 'fmask', fmask_crs, ktype = jp_i1 )
+      
+      
+      tmask_i_crs(:,:) = tmask_crs(:,:,1)
+      iif = nn_hls
+      iil = nlci_crs - nn_hls + 1
+      ijf = nn_hls
+      ijl = nlcj_crs - nn_hls + 1
+     
+      tmask_i_crs( 1:iif ,    :  ) = 0._wp
+      tmask_i_crs(iil:jpi_crs,    :  ) = 0._wp
+      tmask_i_crs(   :   , 1:ijf ) = 0._wp
+      tmask_i_crs(   :   ,ijl:jpj_crs) = 0._wp
+      
+      
+      tpol_crs(1:jpiglo_crs,:) = 1._wp
+      fpol_crs(1:jpiglo_crs,:) = 1._wp
+      IF( jperio == 3 .OR. jperio == 4 ) THEN
+         tpol_crs(jpiglo_crs/2+1:jpiglo_crs,:) = 0._wp
+         fpol_crs(       1      :jpiglo_crs,:) = 0._wp
+         IF( mjg_crs(nlej_crs) == jpiglo_crs ) THEN
+            DO ji = iif+1, iil-1
+               tmask_i_crs(ji,nlej_crs-1) = tmask_i_crs(ji,nlej_crs-1) &
+               & * tpol_crs(mig_crs(ji),1)
+            ENDDO
+         ENDIF
+      ENDIF
+      IF( jperio == 5 .OR. jperio == 6 ) THEN
+         tpol_crs(      1       :jpiglo_crs,:)=0._wp
+         fpol_crs(jpiglo_crs/2+1:jpiglo_crs,:)=0._wp
+      ENDIF
+      
+      CALL iom_rstput( 0, 0, inum, 'tmaskutil', tmask_i_crs, ktype = jp_i1 )
+                                   !    ! unique point mask
+      CALL dom_uniq_crs( zprw, 'U' )
+      zprt = umask_crs(:,:,1) * zprw
+      CALL iom_rstput( 0, 0, inum, 'umaskutil', zprt, ktype = jp_i1 )  
+      CALL dom_uniq_crs( zprw, 'V' )
+      zprt = vmask_crs(:,:,1) * zprw
+      CALL iom_rstput( 0, 0, inum, 'vmaskutil', zprt, ktype = jp_i1 )  
+      CALL dom_uniq_crs( zprw, 'F' )
+      zprt = fmask_crs(:,:,1) * zprw
+      CALL iom_rstput( 0, 0, inum, 'fmaskutil', zprt, ktype = jp_i1 )  
+      !========================================================
+      !                                                         ! horizontal mesh
+      CALL iom_rstput( 0, 0, inum, 'glamt', glamt_crs, ktype = jp_r4 )     !    ! latitude
+      CALL iom_rstput( 0, 0, inum, 'glamu', glamu_crs, ktype = jp_r4 )
+      CALL iom_rstput( 0, 0, inum, 'glamv', glamv_crs, ktype = jp_r4 )
+      CALL iom_rstput( 0, 0, inum, 'glamf', glamf_crs, ktype = jp_r4 )
+      
+      CALL iom_rstput( 0, 0, inum, 'gphit', gphit_crs, ktype = jp_r4 )     !    ! longitude
+      CALL iom_rstput( 0, 0, inum, 'gphiu', gphiu_crs, ktype = jp_r4 )
+      CALL iom_rstput( 0, 0, inum, 'gphiv', gphiv_crs, ktype = jp_r4 )
+      CALL iom_rstput( 0, 0, inum, 'gphif', gphif_crs, ktype = jp_r4 )
+      
+      CALL iom_rstput( 0, 0, inum, 'e1t', e1t_crs, ktype = jp_r8 )         !    ! e1 scale factors
+      CALL iom_rstput( 0, 0, inum, 'e1u', e1u_crs, ktype = jp_r8 )
+      CALL iom_rstput( 0, 0, inum, 'e1v', e1v_crs, ktype = jp_r8 )
+      CALL iom_rstput( 0, 0, inum, 'e1f', e1f_crs, ktype = jp_r8 )
+      
+      CALL iom_rstput( 0, 0, inum, 'e2t', e2t_crs, ktype = jp_r8 )         !    ! e2 scale factors
+      CALL iom_rstput( 0, 0, inum, 'e2u', e2u_crs, ktype = jp_r8 )
+      CALL iom_rstput( 0, 0, inum, 'e2v', e2v_crs, ktype = jp_r8 )
+      CALL iom_rstput( 0, 0, inum, 'e2f', e2f_crs, ktype = jp_r8 )
+      
+      CALL iom_rstput( 0, 0, inum, 'ff', ff_crs, ktype = jp_r8 )           !    ! coriolis factor
+
+      !========================================================
+      !                                                         ! vertical mesh
+!     ! note that mbkt is set to 1 over land ==> use surface tmask_crs
+      zprt(:,:) = tmask_crs(:,:,1) * REAL( mbkt_crs(:,:) , wp )
+      CALL iom_rstput( 0, 0, inum, 'mbathy', zprt, ktype = jp_i2 )     !    ! nb of ocean T-points
+      !
+      CALL iom_rstput( 0, 0, inum, 'e3t', e3t_crs )      
+      CALL iom_rstput( 0, 0, inum, 'e3w', e3w_crs )      
+      CALL iom_rstput( 0, 0, inum, 'e3u', e3u_crs )      
+      CALL iom_rstput( 0, 0, inum, 'e3v', e3v_crs )      
+      !
+      CALL iom_rstput( 0, 0, inum, 'gdept', gdept_crs, ktype = jp_r4 ) 
+      DO jk = 1,jpk   
+         DO jj = 1, jpj_crsm1   
+            DO ji = 1, jpi_crsm1  ! jes what to do for fs_jpim1??vector opt.
+               zdepu(ji,jj,jk) = MIN( gdept_crs(ji,jj,jk) , gdept_crs(ji+1,jj  ,jk) ) * umask_crs(ji,jj,jk)
+               zdepv(ji,jj,jk) = MIN( gdept_crs(ji,jj,jk) , gdept_crs(ji  ,jj+1,jk) ) * vmask_crs(ji,jj,jk)
+            END DO   
+         END DO   
+      END DO
+      CALL crs_lbc_lnk( zdepu,'U', 1. )   ;   CALL crs_lbc_lnk( zdepv,'V', 1. ) 
+      !
+      CALL iom_rstput( 0, 0, inum, 'gdepu', zdepu, ktype = jp_r4 )
+      CALL iom_rstput( 0, 0, inum, 'gdepv', zdepv, ktype = jp_r4 )
+      CALL iom_rstput( 0, 0, inum, 'gdepw', gdepw_crs, ktype = jp_r4 )
+      !
+      CALL iom_rstput( 0, 0, inum, 'gdept_1d', gdept_1d )     !    ! reference z-coord.
+      CALL iom_rstput( 0, 0, inum, 'gdepw_1d', gdepw_1d )
+      CALL iom_rstput( 0, 0, inum, 'e3t_1d'  , e3t_1d   )
+      CALL iom_rstput( 0, 0, inum, 'e3w_1d'  , e3w_1d   )
+      !
+      CALL iom_rstput(  0, 0, inum, 'ocean_volume_t', ocean_volume_crs_t ) 
+      CALL iom_rstput(  0, 0, inum, 'facvol_t' , facvol_t  ) 
+      CALL iom_rstput(  0, 0, inum, 'facvol_w' , facvol_w  ) 
+      CALL iom_rstput(  0, 0, inum, 'facsurfu' , facsurfu  ) 
+      CALL iom_rstput(  0, 0, inum, 'facsurfv' , facsurfv  ) 
+      CALL iom_rstput(  0, 0, inum, 'e1e2w_msk', e1e2w_msk ) 
+      CALL iom_rstput(  0, 0, inum, 'e2e3u_msk', e2e3u_msk ) 
+      CALL iom_rstput(  0, 0, inum, 'e1e3v_msk', e1e3v_msk )
+      CALL iom_rstput(  0, 0, inum, 'e1e2w'    , e1e2w_crs ) 
+      CALL iom_rstput(  0, 0, inum, 'e2e3u'    , e2e3u_crs ) 
+      CALL iom_rstput(  0, 0, inum, 'e1e3v'    , e1e3v_crs )
+      CALL iom_rstput(  0, 0, inum, 'bt'       , bt_crs    )
+      CALL iom_rstput(  0, 0, inum, 'r1_bt'    , r1_bt_crs )
+      !
+      CALL iom_rstput(  0, 0, inum, 'crs_surfu_wgt', crs_surfu_wgt ) 
+      CALL iom_rstput(  0, 0, inum, 'crs_surfv_wgt', crs_surfv_wgt ) 
+      CALL iom_rstput(  0, 0, inum, 'crs_volt_wgt' , crs_volt_wgt  ) 
+      !                                     ! ============================
+      !                                     !        close the files 
+      !                                     ! ============================
+      CALL iom_close( inum )
+      !
+   END SUBROUTINE crs_dom_wri
+
+
+   SUBROUTINE dom_uniq_crs( puniq, cdgrd )
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE crs_dom_uniq_crs  ***
+      !!                   
+      !! ** Purpose :   identify unique point of a grid (TUVF)
+      !!
+      !! ** Method  :   1) apply crs_lbc_lnk on an array with different values for each element
+      !!                2) check which elements have been changed
+      !!----------------------------------------------------------------------
+      CHARACTER(len=1)        , INTENT(in   ) ::   cdgrd   ! 
+      REAL(wp), DIMENSION(:,:), INTENT(inout) ::   puniq   ! 
+      !
+      REAL(wp) ::  zshift   ! shift value link to the process number
+      INTEGER  ::  ji       ! dummy loop indices
+      LOGICAL, DIMENSION(SIZE(puniq,1),SIZE(puniq,2),1) ::  lldbl  ! store whether each point is unique or not
+      REAL(wp), DIMENSION(jpi_crs,jpj_crs) :: ztstref
+      !!----------------------------------------------------------------------
+      !
+      ! build an array with different values for each element 
+      ! in mpp: make sure that these values are different even between process
+      ! -> apply a shift value according to the process number
+      zshift = jpi_crs * jpj_crs * ( narea - 1 )
+      ztstref(:,:) = RESHAPE( (/ (zshift + REAL(ji,wp), ji = 1, jpi_crs*jpj_crs) /), (/ jpi_crs, jpj_crs /) )
+      !
+      puniq(:,:) = ztstref(:,:)                   ! default definition
+      CALL crs_lbc_lnk( puniq,cdgrd, 1. )            ! apply boundary conditions
+      lldbl(:,:,1) = puniq(:,:) == ztstref(:,:)   ! check which values have been changed 
+      !
+      puniq(:,:) = 1.                             ! default definition
+      ! fill only the inner part of the cpu with llbl converted into real 
+      puniq(nldi_crs:nlei_crs,nldj_crs:nlej_crs) = REAL( COUNT( lldbl(nldi_crs:nlei_crs,nldj_crs:nlej_crs,:), dim = 3 ) , wp )
+      !
+   END SUBROUTINE dom_uniq_crs
+
+   !!======================================================================
+
+END MODULE crsdomwri
+
+
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/CRS/crsfld.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/CRS/crsfld.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/CRS/crsfld.F90	(revision 9570)
@@ -0,0 +1,250 @@
+MODULE crsfld
+   !!======================================================================
+   !!                     ***  MODULE  crsdfld  ***
+   !!  Ocean coarsening :  coarse ocean fields
+   !!=====================================================================
+   !!   2012-07  (J. Simeon, C. Calone, G. Madec, C. Ethe)
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   crs_fld       : create the standard output files for coarse grid and prep
+   !!                       other variables needed to be passed to TOP
+   !!----------------------------------------------------------------------
+   USE crs
+   USE crsdom
+   USE crslbclnk
+   USE oce             ! ocean dynamics and tracers 
+   USE dom_oce         ! ocean space and time domain
+   USE sbc_oce         ! Surface boundary condition: ocean fields
+   USE zdf_oce         ! vertical  physics: ocean fields
+   USE ldftra          ! ocean active tracers: lateral diffusivity & EIV coefficients
+   USE zdfddm          ! vertical  physics: double diffusion
+   !
+   USE in_out_manager  ! I/O manager
+   USE iom             ! 
+   USE lbclnk          ! ocean lateral boundary conditions (or mpp link)
+   USE timing          ! preformance summary
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   crs_fld                 ! routines called by step.F90
+
+   !! * Substitutions
+#  include "vectopt_loop_substitute.h90"
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.7 , NEMO Consortium (2015)
+   !! $Id$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE crs_fld( kt )
+      !!---------------------------------------------------------------------
+      !!                  ***  ROUTINE crs_fld  ***
+      !!                   
+      !! ** Purpose :   Basic output of coarsened dynamics and tracer fields 
+      !!      NETCDF format is used by default 
+      !!      1. Accumulate in time the dimensionally-weighted fields
+      !!      2. At time of output, rescale [1] by dimension and time
+      !!         to yield the spatial and temporal average.
+      !!  See. sbcmod.F90
+      !!
+      !! ** Method  :  
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT(in) ::   kt   ! ocean time-step index
+      !
+      INTEGER  ::   ji, jj, jk        ! dummy loop indices
+      REAL(wp) ::   z2dcrsu, z2dcrsv  ! local scalars
+      REAL(wp) ::   zztmp             !   -      -
+      !
+      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   ze3t, ze3u, ze3v, ze3w   ! 3D workspace for e3
+      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zt  , zs  , z3d
+      REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk) ::   zt_crs, zs_crs  
+      !!----------------------------------------------------------------------
+      ! 
+      IF( ln_timing )   CALL timing_start('crs_fld')
+
+      ! Depth work arrrays
+      ze3t(:,:,:) = e3t_n(:,:,:)
+      ze3u(:,:,:) = e3u_n(:,:,:)
+      ze3v(:,:,:) = e3v_n(:,:,:)
+      ze3w(:,:,:) = e3w_n(:,:,:)
+
+      IF( kt == nit000  ) THEN
+         tsn_crs  (:,:,:,:) = 0._wp    ! temp/sal  array, now 
+         un_crs   (:,:,:  ) = 0._wp    ! u-velocity
+         vn_crs   (:,:,:  ) = 0._wp    ! v-velocity
+         wn_crs   (:,:,:  ) = 0._wp    ! w
+         avs_crs  (:,:,:  ) = 0._wp    ! avt
+         hdivn_crs(:,:,:  ) = 0._wp    ! hdiv
+         sshn_crs (:,:    ) = 0._wp    ! ssh
+         utau_crs (:,:    ) = 0._wp    ! taux
+         vtau_crs (:,:    ) = 0._wp    ! tauy
+         wndm_crs (:,:    ) = 0._wp    ! wind speed
+         qsr_crs  (:,:    ) = 0._wp    ! qsr
+         emp_crs  (:,:    ) = 0._wp    ! emp
+         emp_b_crs(:,:    ) = 0._wp    ! emp
+         rnf_crs  (:,:    ) = 0._wp    ! runoff
+         fr_i_crs (:,:    ) = 0._wp    ! ice cover
+      ENDIF
+
+      CALL iom_swap( "nemo_crs" )    ! swap on the coarse grid
+
+      ! 2. Coarsen fields at each time step
+      ! --------------------------------------------------------
+
+      !  Temperature
+      zt(:,:,:) = tsn(:,:,:,jp_tem)  ;      zt_crs(:,:,:) = 0._wp
+      CALL crs_dom_ope( zt, 'VOL', 'T', tmask, zt_crs, p_e12=e1e2t, p_e3=ze3t, psgn=1.0 )
+      tsn_crs(:,:,:,jp_tem) = zt_crs(:,:,:)
+
+      CALL iom_put( "toce", tsn_crs(:,:,:,jp_tem) )    ! temp
+      CALL iom_put( "sst" , tsn_crs(:,:,1,jp_tem) )    ! sst
+
+      
+      !  Salinity
+      zs(:,:,:) = tsn(:,:,:,jp_sal)  ;      zs_crs(:,:,:) = 0._wp
+      CALL crs_dom_ope( zs, 'VOL', 'T', tmask, zs_crs, p_e12=e1e2t, p_e3=ze3t, psgn=1.0 )
+      tsn_crs(:,:,:,jp_sal) = zt_crs(:,:,:)
+
+      CALL iom_put( "soce" , tsn_crs(:,:,:,jp_sal) )    ! sal
+      CALL iom_put( "sss"  , tsn_crs(:,:,1,jp_sal) )    ! sss
+
+      !  U-velocity
+      CALL crs_dom_ope( un, 'SUM', 'U', umask, un_crs, p_e12=e2u, p_e3=ze3u, p_surf_crs=e2e3u_msk, psgn=-1.0 )
+      !
+      zt(:,:,:) = 0._wp     ;    zs(:,:,:) = 0._wp  ;   zt_crs(:,:,:) = 0._wp   ;    zs_crs(:,:,:) = 0._wp
+      DO jk = 1, jpkm1
+         DO jj = 2, jpjm1
+            DO ji = 2, jpim1   
+               zt(ji,jj,jk)  = un(ji,jj,jk) * 0.5 * ( tsn(ji,jj,jk,jp_tem) + tsn(ji+1,jj,jk,jp_tem) ) 
+               zs(ji,jj,jk)  = un(ji,jj,jk) * 0.5 * ( tsn(ji,jj,jk,jp_sal) + tsn(ji+1,jj,jk,jp_sal) ) 
+            END DO
+         END DO
+      END DO
+      CALL crs_dom_ope( zt, 'SUM', 'U', umask, zt_crs, p_e12=e2u, p_e3=ze3u, p_surf_crs=e2e3u_msk, psgn=-1.0 )
+      CALL crs_dom_ope( zs, 'SUM', 'U', umask, zs_crs, p_e12=e2u, p_e3=ze3u, p_surf_crs=e2e3u_msk, psgn=-1.0 )
+
+      CALL iom_put( "uoce"  , un_crs )   ! i-current 
+      CALL iom_put( "uocet" , zt_crs )   ! uT
+      CALL iom_put( "uoces" , zs_crs )   ! uS
+
+      !  V-velocity
+      CALL crs_dom_ope( vn, 'SUM', 'V', vmask, vn_crs, p_e12=e1v, p_e3=ze3v, p_surf_crs=e1e3v_msk, psgn=-1.0 )
+      !                                                                                 
+      zt(:,:,:) = 0._wp     ;    zs(:,:,:) = 0._wp  ;   zt_crs(:,:,:) = 0._wp   ;    zs_crs(:,:,:) = 0._wp
+      DO jk = 1, jpkm1
+         DO jj = 2, jpjm1
+            DO ji = 2, jpim1   
+               zt(ji,jj,jk)  = vn(ji,jj,jk) * 0.5 * ( tsn(ji,jj,jk,jp_tem) + tsn(ji,jj+1,jk,jp_tem) ) 
+               zs(ji,jj,jk)  = vn(ji,jj,jk) * 0.5 * ( tsn(ji,jj,jk,jp_sal) + tsn(ji,jj+1,jk,jp_sal) ) 
+            END DO
+         END DO
+      END DO
+      CALL crs_dom_ope( zt, 'SUM', 'V', vmask, zt_crs, p_e12=e1v, p_e3=ze3v, p_surf_crs=e1e3v_msk, psgn=-1.0 )
+      CALL crs_dom_ope( zs, 'SUM', 'V', vmask, zs_crs, p_e12=e1v, p_e3=ze3v, p_surf_crs=e1e3v_msk, psgn=-1.0 )
+ 
+      CALL iom_put( "voce"  , vn_crs )   ! i-current 
+      CALL iom_put( "vocet" , zt_crs )   ! vT
+      CALL iom_put( "voces" , zs_crs )   ! vS
+
+      IF( iom_use( "eken") ) THEN     !      kinetic energy
+         z3d(:,:,jk) = 0._wp 
+         DO jk = 1, jpkm1
+            DO jj = 2, jpjm1
+               DO ji = fs_2, fs_jpim1   ! vector opt.
+                  zztmp  = r1_e1e2t(ji,jj) / e3t_n(ji,jj,jk)
+                  z3d(ji,jj,jk) = 0.25_wp * zztmp * (                                    &
+                     &            un(ji-1,jj,jk)**2 * e2u(ji-1,jj) * e3u_n(ji-1,jj,jk)   &
+                     &          + un(ji  ,jj,jk)**2 * e2u(ji  ,jj) * e3u_n(ji  ,jj,jk)   &
+                     &          + vn(ji,jj-1,jk)**2 * e1v(ji,jj-1) * e3v_n(ji,jj-1,jk)   &
+                     &          + vn(ji,jj  ,jk)**2 * e1v(ji,jj  ) * e3v_n(ji,jj  ,jk)   )
+               END DO
+            END DO
+         END DO
+         CALL lbc_lnk( z3d, 'T', 1. )
+         !
+         CALL crs_dom_ope( z3d, 'VOL', 'T', tmask, zt_crs, p_e12=e1e2t, p_e3=ze3t, psgn=1.0 )
+         CALL iom_put( "eken", zt_crs )
+      ENDIF
+      !  Horizontal divergence ( following OCE_SRC/DYN/divhor.F90 ) 
+      DO jk = 1, jpkm1
+         DO ji = 2, jpi_crsm1
+            DO jj = 2, jpj_crsm1
+               IF( tmask_crs(ji,jj,jk ) > 0 ) THEN
+                   z2dcrsu =  ( un_crs(ji  ,jj  ,jk) * crs_surfu_wgt(ji  ,jj  ,jk) ) &
+                      &     - ( un_crs(ji-1,jj  ,jk) * crs_surfu_wgt(ji-1,jj  ,jk) )
+                   z2dcrsv =  ( vn_crs(ji  ,jj  ,jk) * crs_surfv_wgt(ji  ,jj  ,jk) ) &
+                      &     - ( vn_crs(ji  ,jj-1,jk) * crs_surfv_wgt(ji  ,jj-1,jk) )
+                   !
+                   hdivn_crs(ji,jj,jk) = ( z2dcrsu + z2dcrsv ) / crs_volt_wgt(ji,jj,jk) 
+               ENDIF
+            END DO
+         END DO
+      END DO
+      CALL crs_lbc_lnk( hdivn_crs, 'T', 1.0 )
+      !
+      CALL iom_put( "hdiv", hdivn_crs )  
+
+
+      !  W-velocity
+      IF( ln_crs_wn ) THEN
+         CALL crs_dom_ope( wn, 'SUM', 'W', tmask, wn_crs, p_e12=e1e2t, p_surf_crs=e1e2w_msk, psgn=1.0 )
+       !  CALL crs_dom_ope( wn, 'VOL', 'W', tmask, wn_crs, p_e12=e1e2t, p_e3=ze3w )
+      ELSE
+        wn_crs(:,:,jpk) = 0._wp
+        DO jk = jpkm1, 1, -1
+           wn_crs(:,:,jk) = wn_crs(:,:,jk+1) - e3t_crs(:,:,jk) * hdivn_crs(:,:,jk)
+        ENDDO
+      ENDIF
+      CALL iom_put( "woce", wn_crs  )   ! vertical velocity
+      !  free memory
+
+      !  avs
+      SELECT CASE ( nn_crs_kz )
+         CASE ( 0 )
+            CALL crs_dom_ope( avt, 'VOL', 'W', tmask, avt_crs, p_e12=e1e2t, p_e3=ze3w, psgn=1.0 )
+            CALL crs_dom_ope( avs, 'VOL', 'W', tmask, avs_crs, p_e12=e1e2t, p_e3=ze3w, psgn=1.0 )
+         CASE ( 1 )
+            CALL crs_dom_ope( avt, 'MAX', 'W', tmask, avt_crs, p_e12=e1e2t, p_e3=ze3w, psgn=1.0 )
+            CALL crs_dom_ope( avs, 'MAX', 'W', tmask, avs_crs, p_e12=e1e2t, p_e3=ze3w, psgn=1.0 )
+         CASE ( 2 )
+            CALL crs_dom_ope( avt, 'MIN', 'W', tmask, avt_crs, p_e12=e1e2t, p_e3=ze3w, psgn=1.0 )
+            CALL crs_dom_ope( avs, 'MIN', 'W', tmask, avs_crs, p_e12=e1e2t, p_e3=ze3w, psgn=1.0 )
+      END SELECT
+      !
+      CALL iom_put( "avt", avt_crs )   !  Kz on T
+      CALL iom_put( "avs", avs_crs )   !  Kz on S
+      
+      !  sbc fields  
+      CALL crs_dom_ope( sshn , 'VOL', 'T', tmask, sshn_crs , p_e12=e1e2t, p_e3=ze3t           , psgn=1.0 )  
+      CALL crs_dom_ope( utau , 'SUM', 'U', umask, utau_crs , p_e12=e2u  , p_surf_crs=e2u_crs  , psgn=1.0 )
+      CALL crs_dom_ope( vtau , 'SUM', 'V', vmask, vtau_crs , p_e12=e1v  , p_surf_crs=e1v_crs  , psgn=1.0 )
+      CALL crs_dom_ope( wndm , 'SUM', 'T', tmask, wndm_crs , p_e12=e1e2t, p_surf_crs=e1e2t_crs, psgn=1.0 )
+      CALL crs_dom_ope( rnf  , 'MAX', 'T', tmask, rnf_crs                                     , psgn=1.0 )
+      CALL crs_dom_ope( qsr  , 'SUM', 'T', tmask, qsr_crs  , p_e12=e1e2t, p_surf_crs=e1e2t_crs, psgn=1.0 )
+      CALL crs_dom_ope( emp_b, 'SUM', 'T', tmask, emp_b_crs, p_e12=e1e2t, p_surf_crs=e1e2t_crs, psgn=1.0 )
+      CALL crs_dom_ope( emp  , 'SUM', 'T', tmask, emp_crs  , p_e12=e1e2t, p_surf_crs=e1e2t_crs, psgn=1.0 )
+      CALL crs_dom_ope( sfx  , 'SUM', 'T', tmask, sfx_crs  , p_e12=e1e2t, p_surf_crs=e1e2t_crs, psgn=1.0 )
+      CALL crs_dom_ope( fr_i , 'SUM', 'T', tmask, fr_i_crs , p_e12=e1e2t, p_surf_crs=e1e2t_crs, psgn=1.0 )
+
+      CALL iom_put( "ssh"      , sshn_crs )   ! ssh output 
+      CALL iom_put( "utau"     , utau_crs )   ! i-tau output 
+      CALL iom_put( "vtau"     , vtau_crs )   ! j-tau output 
+      CALL iom_put( "wspd"     , wndm_crs )   ! wind speed output 
+      CALL iom_put( "runoffs"  , rnf_crs  )   ! runoff output 
+      CALL iom_put( "qsr"      , qsr_crs  )   ! qsr output 
+      CALL iom_put( "empmr"    , emp_crs  )   ! water flux output 
+      CALL iom_put( "saltflx"  , sfx_crs  )   ! salt flux output 
+      CALL iom_put( "ice_cover", fr_i_crs )   ! ice cover output 
+
+      !
+      CALL iom_swap( "nemo" )     ! return back on high-resolution grid
+      !
+      IF( ln_timing )   CALL timing_stop('crs_fld')
+      !
+   END SUBROUTINE crs_fld
+
+   !!======================================================================
+END MODULE crsfld
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/CRS/crsini.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/CRS/crsini.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/CRS/crsini.F90	(revision 9570)
@@ -0,0 +1,243 @@
+MODULE crsini   
+   !!======================================================================
+   !!                         ***  MODULE crsini  ***
+   !!            Manage the grid coarsening module initialization
+   !!======================================================================
+   !!  History     2012-05   (J. Simeon, G. Madec, C. Ethe, C. Calone) Original code
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!  crs_init    : 
+   !!----------------------------------------------------------------------
+   USE par_kind, ONLY: wp
+   USE par_oce                  ! For parameter jpi,jpj
+   USE dom_oce                  ! For parameters in par_oce
+   USE crs                      ! Coarse grid domain
+   USE phycst, ONLY: omega, rad ! physical constants
+   USE crsdom
+   USE crsdomwri
+   USE crslbclnk
+   !
+   USE iom
+   USE in_out_manager
+   USE lib_mpp
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   crs_init   ! called by nemogcm.F90 module
+
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO Consortium (2010)
+   !! $Id$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+   
+   SUBROUTINE crs_init 
+      !!-------------------------------------------------------------------
+      !!                     *** SUBROUTINE crs_init
+      !!  ** Purpose : Initialization of the grid coarsening module  
+      !!               1. Read namelist
+      !!               X2. MOVE TO crs_dom.F90 Set the domain definitions for coarse grid
+      !!                 a. Define the coarse grid starting/ending indices on parent grid
+      !!                    Here is where the T-pivot or F-pivot grids are discerned
+      !!                 b. TODO.  Include option for north-centric or equator-centric binning.
+      !!                 (centered only for odd reduction factors; even reduction bins bias equator to the south)
+      !!               3. Mask and mesh creation. => calls to crsfun
+      !!                  a. Use crsfun_mask to generate tmask,umask, vmask, fmask.
+      !!                  b. Use crsfun_coordinates to get coordinates
+      !!                  c. Use crsfun_UV to get horizontal scale factors
+      !!                  d. Use crsfun_TW to get initial vertical scale factors   
+      !!               4. Volumes and weights jes.... TODO. Updates for vvl? Where to do this? crsstp.F90?
+      !!                  a. Calculate initial coarse grid box volumes: pvol_T, pvol_W
+      !!                  b. Calculate initial coarse grid surface-averaging weights
+      !!                  c. Calculate initial coarse grid volume-averaging weights
+      !!                  
+      !!               X5. MOVE TO crs_dom_wri.F90 Using iom_rstput output the initial meshmask.
+      !!               ?. Another set of "masks" to generate
+      !!                  are the u- and v- surface areas for U- and V- area-weighted means.
+      !!                  Need to put this somewhere in section 3?
+      !! jes. What do to about the vvl?  GM.  could separate the weighting (denominator), so
+      !! output C*dA or C*dV as summation not mran, then do mean (division) at moment of output.
+      !! As is, crsfun takes into account vvl.   
+      !!      Talked about pre-setting the surface array to avoid IF/ENDIF and division.
+      !!      But have then to make that preset array here and elsewhere.
+      !!      that is called every timestep...
+      !! 
+      !!               - Read in pertinent data ?
+      !!-------------------------------------------------------------------
+      INTEGER  :: ji,jj,jk      ! dummy indices
+      INTEGER  :: ierr                                ! allocation error status
+      INTEGER  ::   ios                 ! Local integer output status for namelist read
+      REAL(wp), DIMENSION(jpi,jpj,jpk) :: ze3t, ze3u, ze3v, ze3w
+
+      NAMELIST/namcrs/ nn_factx, nn_facty, nn_binref, ln_msh_crs, nn_crs_kz, ln_crs_wn
+      !!----------------------------------------------------------------------
+      !
+     !---------------------------------------------------------
+     ! 1. Read Namelist file
+     !---------------------------------------------------------
+     !
+      REWIND( numnam_ref )              ! Namelist namrun in reference namelist : Parameters of the run
+      READ  ( numnam_ref, namcrs, IOSTAT = ios, ERR = 901)
+901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namcrs in reference namelist', lwp )
+      REWIND( numnam_cfg )              ! Namelist namrun in configuration namelist : Parameters of the run
+      READ  ( numnam_cfg, namcrs, IOSTAT = ios, ERR = 902 )
+902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namcrs in configuration namelist', lwp )
+      IF(lwm) WRITE ( numond, namcrs )
+
+     IF(lwp) THEN
+        WRITE(numout,*)
+        WRITE(numout,*) 'crs_init : Initializing the grid coarsening module'
+        WRITE(numout,*) '~~~~~~~~'
+        WRITE(numout,*) '   Namelist namcrs '
+        WRITE(numout,*) '      coarsening factor in i-direction      nn_factx   = ', nn_factx
+        WRITE(numout,*) '      coarsening factor in j-direction      nn_facty   = ', nn_facty
+        WRITE(numout,*) '      bin centering preference              nn_binref  = ', nn_binref
+        WRITE(numout,*) '      create a mesh file (=T)               ln_msh_crs = ', ln_msh_crs
+        WRITE(numout,*) '      type of Kz coarsening (0,1,2)         nn_crs_kz  = ', nn_crs_kz
+        WRITE(numout,*) '      wn coarsened or computed using hdivn  ln_crs_wn  = ', ln_crs_wn
+     ENDIF
+              
+     rfactx_r = 1. / nn_factx
+     rfacty_r = 1. / nn_facty
+
+     !---------------------------------------------------------
+     ! 2. Define Global Dimensions of the coarsened grid
+     !---------------------------------------------------------
+     CALL crs_dom_def      
+
+     !---------------------------------------------------------
+     ! 3. Mask and Mesh
+     !---------------------------------------------------------
+
+     !     Set up the masks and meshes     
+
+     !  3.a. Get the masks   
+ 
+     CALL crs_dom_msk
+
+
+     !  3.b. Get the coordinates
+     !      Odd-numbered reduction factor, center coordinate on T-cell
+     !      Even-numbered reduction factor, center coordinate on U-,V- faces or f-corner.
+     !      
+     IF ( nresty /= 0 .AND. nrestx /= 0 ) THEN
+        CALL crs_dom_coordinates( gphit, glamt, 'T', gphit_crs, glamt_crs ) 
+        CALL crs_dom_coordinates( gphiu, glamu, 'U', gphiu_crs, glamu_crs )       
+        CALL crs_dom_coordinates( gphiv, glamv, 'V', gphiv_crs, glamv_crs ) 
+        CALL crs_dom_coordinates( gphif, glamf, 'F', gphif_crs, glamf_crs ) 
+     ELSEIF ( nresty /= 0 .AND. nrestx == 0 ) THEN
+        CALL crs_dom_coordinates( gphiu, glamu, 'T', gphit_crs, glamt_crs )
+        CALL crs_dom_coordinates( gphiu, glamu, 'U', gphiu_crs, glamu_crs )
+        CALL crs_dom_coordinates( gphif, glamf, 'V', gphiv_crs, glamv_crs )
+        CALL crs_dom_coordinates( gphif, glamf, 'F', gphif_crs, glamf_crs )
+     ELSEIF ( nresty == 0 .AND. nrestx /= 0 ) THEN
+        CALL crs_dom_coordinates( gphiv, glamv, 'T', gphit_crs, glamt_crs )
+        CALL crs_dom_coordinates( gphif, glamf, 'U', gphiu_crs, glamu_crs )
+        CALL crs_dom_coordinates( gphiv, glamv, 'V', gphiv_crs, glamv_crs )
+        CALL crs_dom_coordinates( gphif, glamf, 'F', gphif_crs, glamf_crs )
+     ELSE 
+        CALL crs_dom_coordinates( gphif, glamf, 'T', gphit_crs, glamt_crs )
+        CALL crs_dom_coordinates( gphif, glamf, 'U', gphiu_crs, glamu_crs )
+        CALL crs_dom_coordinates( gphif, glamf, 'V', gphiv_crs, glamv_crs )
+        CALL crs_dom_coordinates( gphif, glamf, 'F', gphif_crs, glamf_crs )
+     ENDIF
+
+
+     !  3.c. Get the horizontal mesh
+
+     !      3.c.1 Horizontal scale factors
+
+     CALL crs_dom_hgr( e1t, e2t, 'T', e1t_crs, e2t_crs )
+     CALL crs_dom_hgr( e1u, e2u, 'U', e1u_crs, e2u_crs )
+     CALL crs_dom_hgr( e1v, e2v, 'V', e1v_crs, e2v_crs )
+     CALL crs_dom_hgr( e1f, e2f, 'F', e1f_crs, e2f_crs )
+
+     e1e2t_crs(:,:) = e1t_crs(:,:) * e2t_crs(:,:)
+     
+     
+     !      3.c.2 Coriolis factor  
+
+!!gm  Not sure CRS needs Coriolis parameter....
+!!gm  If needed, then update this to have Coriolis at both f- and t-points
+
+      ff_crs(:,:) = 2. * omega * SIN( rad * gphif_crs(:,:) )
+
+      CALL ctl_warn( 'crsini: CAUTION, CRS only designed for Coriolis defined on the sphere' ) 
+ 
+
+     !    3.d.1 mbathy ( vertical k-levels of bathymetry )     
+
+     CALL crs_dom_bat
+     
+     !
+     ze3t(:,:,:) = e3t_n(:,:,:)
+     ze3u(:,:,:) = e3u_n(:,:,:)
+     ze3v(:,:,:) = e3v_n(:,:,:)
+     ze3w(:,:,:) = e3w_n(:,:,:)
+
+     !    3.d.2   Surfaces 
+     CALL crs_dom_sfc( tmask, 'W', e1e2w_crs, e1e2w_msk, p_e1=e1t, p_e2=e2t  )
+     CALL crs_dom_sfc( umask, 'U', e2e3u_crs, e2e3u_msk, p_e2=e2u, p_e3=ze3u )
+     CALL crs_dom_sfc( vmask, 'V', e1e3v_crs, e1e3v_msk, p_e1=e1v, p_e3=ze3v )
+   
+     facsurfu(:,:,:) = umask_crs(:,:,:) * e2e3u_msk(:,:,:) / e2e3u_crs(:,:,:)
+     facsurfv(:,:,:) = vmask_crs(:,:,:) * e1e3v_msk(:,:,:) / e1e3v_crs(:,:,:)
+
+     !    3.d.3   Vertical scale factors
+     !
+     CALL crs_dom_e3( e1t, e2t, ze3t, e1e2w_crs, 'T', tmask, e3t_crs, e3t_max_crs)
+     CALL crs_dom_e3( e1u, e2u, ze3u, e2e3u_crs, 'U', umask, e3u_crs, e3u_max_crs)
+     CALL crs_dom_e3( e1v, e2v, ze3v, e1e3v_crs, 'V', vmask, e3v_crs, e3v_max_crs)
+     CALL crs_dom_e3( e1t, e2t, ze3w, e1e2w_crs, 'W', tmask, e3w_crs, e3w_max_crs)
+
+     ! Replace 0 by e3t_0 or e3w_0
+     DO jk = 1, jpk
+        DO ji = 1, jpi_crs
+           DO jj = 1, jpj_crs
+              IF( e3t_crs(ji,jj,jk) == 0._wp ) e3t_crs(ji,jj,jk) = e3t_1d(jk)
+              IF( e3w_crs(ji,jj,jk) == 0._wp ) e3w_crs(ji,jj,jk) = e3w_1d(jk)
+              IF( e3u_crs(ji,jj,jk) == 0._wp ) e3u_crs(ji,jj,jk) = e3t_1d(jk)
+              IF( e3v_crs(ji,jj,jk) == 0._wp ) e3v_crs(ji,jj,jk) = e3t_1d(jk)
+           ENDDO
+        ENDDO
+     ENDDO
+
+     !    3.d.3   Vertical depth (meters)
+     CALL crs_dom_ope( gdept_0, 'MAX', 'T', tmask, gdept_crs, p_e3=ze3t, psgn=1.0 ) 
+     CALL crs_dom_ope( gdepw_0, 'MAX', 'W', tmask, gdepw_crs, p_e3=ze3w, psgn=1.0 )
+
+
+     !---------------------------------------------------------
+     ! 4.  Coarse grid ocean volume and averaging weights
+     !---------------------------------------------------------
+     ! 4.a. Ocean volume or area unmasked and masked
+     CALL crs_dom_facvol( tmask, 'T', e1t, e2t, ze3t, ocean_volume_crs_t, facvol_t )
+     !
+     bt_crs(:,:,:) = ocean_volume_crs_t(:,:,:) * facvol_t(:,:,:)
+     !
+     r1_bt_crs(:,:,:) = 0._wp 
+     WHERE( bt_crs /= 0._wp ) r1_bt_crs(:,:,:) = 1._wp / bt_crs(:,:,:)
+
+     CALL crs_dom_facvol( tmask, 'W', e1t, e2t, ze3w, ocean_volume_crs_w, facvol_w )
+     !
+     !---------------------------------------------------------
+     ! 5.  Write out coarse meshmask  (see OCE_SRC/DOM/domwri.F90 for ideas later)
+     !---------------------------------------------------------
+
+     IF( ln_msh_crs ) THEN 
+        CALL dom_grid_crs   ! Save the parent grid information  & Switch to coarse grid domain
+        CALL crs_dom_wri     
+        CALL dom_grid_glo   ! Return to parent grid domain
+     ENDIF
+     
+      !---------------------------------------------------------
+      ! 7. Finish and clean-up
+      !---------------------------------------------------------
+      !
+   END SUBROUTINE crs_init
+    
+   !!======================================================================
+END MODULE crsini
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/CRS/crslbclnk.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/CRS/crslbclnk.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/CRS/crslbclnk.F90	(revision 9570)
@@ -0,0 +1,103 @@
+MODULE crslbclnk
+   !!======================================================================
+   !!                       ***  MODULE  crslbclnk  ***
+   !!               A temporary solution for lbclnk for coarsened grid.
+   !! Ocean        : lateral boundary conditions for grid coarsening
+   !!=====================================================================
+   !! History :   ! 2012-06  (J. Simeon, G. Madec, C. Ethe, C. Calone)     Original code
+   !!----------------------------------------------------------------------
+   USE par_kind, ONLY: wp
+   USE dom_oce
+   USE crs
+   !
+   USE lbclnk
+   USE in_out_manager
+   
+   INTERFACE crs_lbc_lnk
+      MODULE PROCEDURE crs_lbc_lnk_3d, crs_lbc_lnk_2d
+   END INTERFACE
+   
+   PUBLIC crs_lbc_lnk
+   
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO Consortium (2010)
+   !! $Id$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE crs_lbc_lnk_3d( pt3d1, cd_type1, psgn, cd_mpp, pval )
+      !!---------------------------------------------------------------------
+      !!                  ***  SUBROUTINE crs_lbc_lnk  ***
+      !!
+      !! ** Purpose :   set lateral boundary conditions for coarsened grid
+      !!
+      !! ** Method  :   Swap domain indices from full to coarse domain
+      !!                before arguments are passed directly to lbc_lnk.
+      !!                Upon exiting, switch back to full domain indices.
+      !!----------------------------------------------------------------------
+      CHARACTER(len=1)                        , INTENT(in   ) ::   cd_type1 ! grid type
+      REAL(wp)                                , INTENT(in   ) ::   psgn     ! control of the sign
+      REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(inout) ::   pt3d1    ! 3D array on which the lbc is applied
+      REAL(wp)                      , OPTIONAL, INTENT(in   ) ::   pval     ! valeur sur les halo
+      CHARACTER(len=3)              , OPTIONAL, INTENT(in   ) ::   cd_mpp   ! MPP only (here do nothing)
+      !
+      LOGICAL  ::   ll_grid_crs
+      REAL(wp) ::   zval   ! valeur sur les halo
+      !!----------------------------------------------------------------------
+      !
+      ll_grid_crs = ( jpi == jpi_crs )
+      !
+      IF( PRESENT(pval) ) THEN   ;   zval = pval
+      ELSE                       ;   zval = 0._wp
+      ENDIF
+      !
+      IF( .NOT.ll_grid_crs )   CALL dom_grid_crs   ! Save the parent grid information  & Switch to coarse grid domain
+      !
+      IF( PRESENT( cd_mpp ) ) THEN   ;   CALL lbc_lnk( pt3d1, cd_type1, psgn, cd_mpp, pval=zval  )
+      ELSE                           ;   CALL lbc_lnk( pt3d1, cd_type1, psgn        , pval=zval  )
+      ENDIF
+      !
+      IF( .NOT.ll_grid_crs )   CALL dom_grid_glo   ! Return to parent grid domain
+      !
+   END SUBROUTINE crs_lbc_lnk_3d
+   
+   
+   SUBROUTINE crs_lbc_lnk_2d(pt2d, cd_type, psgn, cd_mpp, pval)
+      !!---------------------------------------------------------------------
+      !!                  ***  SUBROUTINE crs_lbc_lnk  ***
+      !!
+      !! ** Purpose :   set lateral boundary conditions for coarsened grid
+      !!
+      !! ** Method  :   Swap domain indices from full to coarse domain
+      !!                before arguments are passed directly to lbc_lnk.
+      !!                Upon exiting, switch back to full domain indices.
+      !!----------------------------------------------------------------------
+      CHARACTER(len=1)                    , INTENT(in   ) ::   cd_type  ! grid type
+      REAL(wp)                            , INTENT(in   ) ::   psgn     ! control of the sign
+      REAL(wp), DIMENSION(jpi_crs,jpj_crs), INTENT(inout) ::   pt2d     ! 2D array on which the lbc is applied
+      REAL(wp)                  , OPTIONAL, INTENT(in   ) ::   pval     ! valeur sur les halo
+      CHARACTER(len=3)          , OPTIONAL, INTENT(in   ) ::   cd_mpp   ! MPP only (here do nothing)
+      !      
+      LOGICAL  ::   ll_grid_crs
+      REAL(wp) ::   zval     ! valeur sur les halo
+      !!----------------------------------------------------------------------
+      !
+      ll_grid_crs = ( jpi == jpi_crs )
+      !
+      IF( PRESENT(pval) ) THEN   ;   zval = pval
+      ELSE                       ;   zval = 0._wp
+      ENDIF
+      !
+      IF( .NOT.ll_grid_crs )   CALL dom_grid_crs   ! Save the parent grid information  & Switch to coarse grid domain
+      !
+      IF( PRESENT( cd_mpp ) ) THEN   ;   CALL lbc_lnk( pt2d, cd_type, psgn, cd_mpp, pval=zval  )
+      ELSE                           ;   CALL lbc_lnk( pt2d, cd_type, psgn        , pval=zval  )
+      ENDIF
+      !
+      IF( .NOT.ll_grid_crs )   CALL dom_grid_glo   ! Return to parent grid domain
+      !
+   END SUBROUTINE crs_lbc_lnk_2d
+
+   !!======================================================================
+END MODULE crslbclnk
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DIA/dia25h.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DIA/dia25h.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DIA/dia25h.F90	(revision 9570)
@@ -0,0 +1,261 @@
+MODULE dia25h 
+   !!======================================================================
+   !!                       ***  MODULE  diaharm  ***
+   !! Harmonic analysis of tidal constituents 
+   !!======================================================================
+   !! History :  3.6  !  2014  (E O'Dea)  Original code
+   !!----------------------------------------------------------------------
+   USE oce             ! ocean dynamics and tracers variables
+   USE dom_oce         ! ocean space and time domain
+   USE zdf_oce         ! ocean vertical physics    
+   USE zdfgls   , ONLY : hmxl_n
+   !
+   USE in_out_manager  ! I/O units
+   USE iom             ! I/0 library
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   dia_25h_init               ! routine called by nemogcm.F90
+   PUBLIC   dia_25h                    ! routine called by diawri.F90
+
+   LOGICAL, PUBLIC ::   ln_dia25h      !:  25h mean output
+
+   ! variables for calculating 25-hourly means
+   INTEGER , SAVE ::   cnt_25h           ! Counter for 25 hour means
+   REAL(wp), SAVE ::   r1_25 = 0.04_wp   ! =1/25 
+   REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:,:) ::   tn_25h  , sn_25h
+   REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:)   ::   sshn_25h 
+   REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:,:) ::   un_25h  , vn_25h  , wn_25h
+   REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:,:) ::   avt_25h , avm_25h
+   REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:,:) ::   en_25h  , rmxln_25h
+
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.6 , NEMO Consortium (2014)
+   !! $Id:$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE dia_25h_init 
+      !!---------------------------------------------------------------------------
+      !!                  ***  ROUTINE dia_25h_init  ***
+      !!     
+      !! ** Purpose: Initialization of 25h mean namelist 
+      !!        
+      !! ** Method : Read namelist
+      !!---------------------------------------------------------------------------
+      INTEGER ::   ios                 ! Local integer output status for namelist read
+      INTEGER ::   ierror              ! Local integer for memory allocation
+      !
+      NAMELIST/nam_dia25h/ ln_dia25h
+      !!----------------------------------------------------------------------
+      !
+      REWIND ( numnam_ref )              ! Read Namelist nam_dia25h in reference namelist : 25hour mean diagnostics
+      READ   ( numnam_ref, nam_dia25h, IOSTAT=ios, ERR= 901 )
+901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'nam_dia25h in reference namelist', lwp )
+      REWIND( numnam_cfg )              ! Namelist nam_dia25h in configuration namelist  25hour diagnostics
+      READ  ( numnam_cfg, nam_dia25h, IOSTAT = ios, ERR = 902 )
+902   IF( ios >  0 )   CALL ctl_nam ( ios , 'nam_dia25h in configuration namelist', lwp )
+      IF(lwm) WRITE ( numond, nam_dia25h )
+
+      IF(lwp) THEN                   ! Control print
+         WRITE(numout,*)
+         WRITE(numout,*) 'dia_25h_init : Output 25 hour mean diagnostics'
+         WRITE(numout,*) '~~~~~~~~~~~~'
+         WRITE(numout,*) '   Namelist nam_dia25h : set 25h outputs '
+         WRITE(numout,*) '      Switch for 25h diagnostics (T) or not (F)  ln_dia25h  = ', ln_dia25h
+      ENDIF
+      IF( .NOT. ln_dia25h )   RETURN
+      ! ------------------- !
+      ! 1 - Allocate memory !
+      ! ------------------- !
+      !                                ! ocean arrays
+      ALLOCATE( tn_25h (jpi,jpj,jpk), sn_25h (jpi,jpj,jpk), sshn_25h(jpi,jpj)  ,     &
+         &      un_25h (jpi,jpj,jpk), vn_25h (jpi,jpj,jpk), wn_25h(jpi,jpj,jpk),     &
+         &      avt_25h(jpi,jpj,jpk), avm_25h(jpi,jpj,jpk),                      STAT=ierror )
+      IF( ierror > 0 ) THEN
+         CALL ctl_stop( 'dia_25h: unable to allocate ocean arrays' )   ;   RETURN
+      ENDIF
+      IF( ln_zdftke ) THEN             ! TKE physics
+         ALLOCATE( en_25h(jpi,jpj,jpk), STAT=ierror )
+         IF( ierror > 0 ) THEN
+            CALL ctl_stop( 'dia_25h: unable to allocate en_25h' )   ;   RETURN
+         ENDIF
+      ENDIF
+      IF( ln_zdfgls ) THEN             ! GLS physics
+         ALLOCATE( en_25h(jpi,jpj,jpk), rmxln_25h(jpi,jpj,jpk), STAT=ierror )
+         IF( ierror > 0 ) THEN
+            CALL ctl_stop( 'dia_25h: unable to allocate en_25h and rmxln_25h' )   ;   RETURN
+         ENDIF
+      ENDIF
+      ! ------------------------- !
+      ! 2 - Assign Initial Values !
+      ! ------------------------- !
+      cnt_25h = 1  ! sets the first value of sum at timestep 1 (note - should strictly be at timestep zero so before values used where possible) 
+      tn_25h  (:,:,:) = tsb (:,:,:,jp_tem)
+      sn_25h  (:,:,:) = tsb (:,:,:,jp_sal)
+      sshn_25h(:,:)   = sshb(:,:)
+      un_25h  (:,:,:) = ub  (:,:,:)
+      vn_25h  (:,:,:) = vb  (:,:,:)
+      wn_25h  (:,:,:) = wn  (:,:,:)
+      avt_25h (:,:,:) = avt (:,:,:)
+      avm_25h (:,:,:) = avm (:,:,:)
+      IF( ln_zdftke ) THEN
+         en_25h(:,:,:) = en(:,:,:)
+      ENDIF
+      IF( ln_zdfgls ) THEN
+         en_25h   (:,:,:) = en    (:,:,:)
+         rmxln_25h(:,:,:) = hmxl_n(:,:,:)
+      ENDIF
+#if defined key_si3
+      CALL ctl_stop('STOP', 'dia_25h not setup yet to do tidemean ice')
+#endif 
+      !
+   END SUBROUTINE dia_25h_init
+
+
+   SUBROUTINE dia_25h( kt )  
+      !!----------------------------------------------------------------------
+      !!                 ***  ROUTINE dia_25h  ***
+      !!         
+      !! ** Purpose :   Write diagnostics with M2/S2 tide removed
+      !!
+      !! ** Method  :   25hr mean outputs for shelf seas
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT(in) ::   kt   ! ocean time-step index
+      !!
+      INTEGER ::   ji, jj, jk
+      INTEGER                          ::   iyear0, nimonth0,iday0            ! start year,imonth,day
+      LOGICAL ::   ll_print = .FALSE.    ! =T print and flush numout
+      REAL(wp)                         ::   zsto, zout, zmax, zjulian, zmdi   ! local scalars
+      INTEGER                          ::   i_steps                           ! no of timesteps per hour
+      REAL(wp), DIMENSION(jpi,jpj    ) ::   zw2d, un_dm, vn_dm                ! workspace
+      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zw3d                              ! workspace
+      REAL(wp), DIMENSION(jpi,jpj,3)   ::   zwtmb                             ! workspace
+      !!----------------------------------------------------------------------
+
+      ! 0. Initialisation
+      ! -----------------
+      ! Define frequency of summing to create 25 h mean
+      IF( MOD( 3600,INT(rdt) ) == 0 ) THEN
+         i_steps = 3600/INT(rdt)
+      ELSE
+         CALL ctl_stop('STOP', 'dia_wri_tide: timestep must give MOD(3600,rdt) = 0 otherwise no hourly values are possible')
+      ENDIF
+
+      ! local variable for debugging
+      ll_print = ll_print .AND. lwp
+
+      ! Sum of 25 hourly instantaneous values to give a 25h mean from 24hours every day
+      IF( MOD( kt, i_steps ) == 0  .AND. kt /= nn_it000 ) THEN
+
+         IF (lwp) THEN
+              WRITE(numout,*) 'dia_wri_tide : Summing instantaneous hourly diagnostics at timestep ',kt
+              WRITE(numout,*) '~~~~~~~~~~~~ '
+         ENDIF
+
+         tn_25h  (:,:,:)     = tn_25h  (:,:,:) + tsn (:,:,:,jp_tem)
+         sn_25h  (:,:,:)     = sn_25h  (:,:,:) + tsn (:,:,:,jp_sal)
+         sshn_25h(:,:)       = sshn_25h(:,:)   + sshn(:,:)
+         un_25h  (:,:,:)     = un_25h  (:,:,:) + un  (:,:,:)
+         vn_25h  (:,:,:)     = vn_25h  (:,:,:) + vn  (:,:,:)
+         wn_25h  (:,:,:)     = wn_25h  (:,:,:) + wn  (:,:,:)
+         avt_25h (:,:,:)     = avt_25h (:,:,:) + avt (:,:,:)
+         avm_25h (:,:,:)     = avm_25h (:,:,:) + avm (:,:,:)
+         IF( ln_zdftke ) THEN
+            en_25h(:,:,:)    = en_25h  (:,:,:) + en(:,:,:)
+         ENDIF
+         IF( ln_zdfgls ) THEN
+            en_25h   (:,:,:) = en_25h   (:,:,:) + en    (:,:,:)
+            rmxln_25h(:,:,:) = rmxln_25h(:,:,:) + hmxl_n(:,:,:)
+         ENDIF
+         cnt_25h = cnt_25h + 1
+         !
+         IF (lwp) THEN
+            WRITE(numout,*) 'dia_tide : Summed the following number of hourly values so far',cnt_25h
+         ENDIF
+         !
+      ENDIF ! MOD( kt, i_steps ) == 0
+
+      ! Write data for 25 hour mean output streams
+      IF( cnt_25h == 25 .AND.  MOD( kt, i_steps*24) == 0 .AND. kt /= nn_it000 ) THEN
+         !
+         IF(lwp) THEN
+            WRITE(numout,*) 'dia_wri_tide : Writing 25 hour mean tide diagnostics at timestep', kt
+            WRITE(numout,*) '~~~~~~~~~~~~ '
+         ENDIF
+         !
+         tn_25h  (:,:,:) = tn_25h  (:,:,:) * r1_25
+         sn_25h  (:,:,:) = sn_25h  (:,:,:) * r1_25
+         sshn_25h(:,:)   = sshn_25h(:,:)   * r1_25
+         un_25h  (:,:,:) = un_25h  (:,:,:) * r1_25
+         vn_25h  (:,:,:) = vn_25h  (:,:,:) * r1_25
+         wn_25h  (:,:,:) = wn_25h  (:,:,:) * r1_25
+         avt_25h (:,:,:) = avt_25h (:,:,:) * r1_25
+         avm_25h (:,:,:) = avm_25h (:,:,:) * r1_25
+         IF( ln_zdftke ) THEN
+            en_25h(:,:,:) = en_25h(:,:,:) * r1_25
+         ENDIF
+         IF( ln_zdfgls ) THEN
+            en_25h   (:,:,:) = en_25h   (:,:,:) * r1_25
+            rmxln_25h(:,:,:) = rmxln_25h(:,:,:) * r1_25
+         ENDIF
+         !
+         IF(lwp)  WRITE(numout,*) 'dia_wri_tide : Mean calculated by dividing 25 hour sums and writing output'
+         zmdi=1.e+20 !missing data indicator for masking
+         ! write tracers (instantaneous)
+         zw3d(:,:,:) = tn_25h(:,:,:)*tmask(:,:,:) + zmdi*(1.0-tmask(:,:,:))
+         CALL iom_put("temper25h", zw3d)   ! potential temperature
+         zw3d(:,:,:) = sn_25h(:,:,:)*tmask(:,:,:) + zmdi*(1.0-tmask(:,:,:))
+         CALL iom_put( "salin25h", zw3d  )   ! salinity
+         zw2d(:,:) = sshn_25h(:,:)*tmask(:,:,1) + zmdi*(1.0-tmask(:,:,1))
+         CALL iom_put( "ssh25h", zw2d )   ! sea surface 
+         ! Write velocities (instantaneous)
+         zw3d(:,:,:) = un_25h(:,:,:)*umask(:,:,:) + zmdi*(1.0-umask(:,:,:))
+         CALL iom_put("vozocrtx25h", zw3d)    ! i-current
+         zw3d(:,:,:) = vn_25h(:,:,:)*vmask(:,:,:) + zmdi*(1.0-vmask(:,:,:))
+         CALL iom_put("vomecrty25h", zw3d  )   ! j-current
+         zw3d(:,:,:) = wn_25h(:,:,:)*wmask(:,:,:) + zmdi*(1.0-tmask(:,:,:))
+         CALL iom_put("vomecrtz25h", zw3d )   ! k-current
+         ! Write vertical physics
+         zw3d(:,:,:) = avt_25h(:,:,:)*wmask(:,:,:) + zmdi*(1.0-tmask(:,:,:))
+         CALL iom_put("avt25h", zw3d )   ! diffusivity
+         zw3d(:,:,:) = avm_25h(:,:,:)*wmask(:,:,:) + zmdi*(1.0-tmask(:,:,:))
+         CALL iom_put("avm25h", zw3d)   ! viscosity
+         IF( ln_zdftke ) THEN
+            zw3d(:,:,:) = en_25h(:,:,:)*wmask(:,:,:) + zmdi*(1.0-tmask(:,:,:))
+            CALL iom_put("tke25h", zw3d)   ! tke
+         ENDIF
+         IF( ln_zdfgls ) THEN
+            zw3d(:,:,:) = en_25h(:,:,:)*wmask(:,:,:) + zmdi*(1.0-tmask(:,:,:))
+            CALL iom_put("tke25h", zw3d)   ! tke
+            zw3d(:,:,:) = rmxln_25h(:,:,:)*wmask(:,:,:) + zmdi*(1.0-tmask(:,:,:))
+            CALL iom_put( "mxln25h",zw3d)
+         ENDIF
+         !
+         ! After the write reset the values to cnt=1 and sum values equal current value 
+         tn_25h  (:,:,:) = tsn (:,:,:,jp_tem)
+         sn_25h  (:,:,:) = tsn (:,:,:,jp_sal)
+         sshn_25h(:,:)   = sshn(:,:)
+         un_25h  (:,:,:) = un  (:,:,:)
+         vn_25h  (:,:,:) = vn  (:,:,:)
+         wn_25h  (:,:,:) = wn  (:,:,:)
+         avt_25h (:,:,:) = avt (:,:,:)
+         avm_25h (:,:,:) = avm (:,:,:)
+         IF( ln_zdftke ) THEN
+            en_25h(:,:,:) = en(:,:,:)
+         ENDIF
+         IF( ln_zdfgls ) THEN
+            en_25h   (:,:,:) = en    (:,:,:)
+            rmxln_25h(:,:,:) = hmxl_n(:,:,:)
+         ENDIF
+         cnt_25h = 1
+         IF(lwp)  WRITE(numout,*) 'dia_wri_tide :   &
+            &    After 25hr mean write, reset sum to current value and cnt_25h to one for overlapping average', cnt_25h
+      ENDIF !  cnt_25h .EQ. 25 .AND.  MOD( kt, i_steps * 24) == 0 .AND. kt .NE. nn_it000
+      !
+   END SUBROUTINE dia_25h 
+
+   !!======================================================================
+END MODULE dia25h
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DIA/diaar5.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DIA/diaar5.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DIA/diaar5.F90	(revision 9570)
@@ -0,0 +1,383 @@
+MODULE diaar5
+   !!======================================================================
+   !!                       ***  MODULE  diaar5  ***
+   !! AR5 diagnostics
+   !!======================================================================
+   !! History :  3.2  !  2009-11  (S. Masson)  Original code
+   !!            3.3  !  2010-10  (C. Ethe, G. Madec) reorganisation of initialisation phase + merge TRC-TRA
+   !!----------------------------------------------------------------------
+   !!   dia_ar5       : AR5 diagnostics
+   !!   dia_ar5_init  : initialisation of AR5 diagnostics
+   !!----------------------------------------------------------------------
+   USE oce            ! ocean dynamics and active tracers 
+   USE dom_oce        ! ocean space and time domain
+   USE eosbn2         ! equation of state                (eos_bn2 routine)
+   USE phycst         ! physical constant
+   USE in_out_manager  ! I/O manager
+   USE zdfddm
+   USE zdf_oce
+   !
+   USE lib_mpp        ! distribued memory computing library
+   USE iom            ! I/O manager library
+   USE fldread        ! type FLD_N
+   USE timing         ! preformance summary
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   dia_ar5        ! routine called in step.F90 module
+   PUBLIC   dia_ar5_alloc  ! routine called in nemogcm.F90 module
+   PUBLIC   dia_ar5_hst    ! heat/salt transport
+
+   REAL(wp)                         ::   vol0         ! ocean volume (interior domain)
+   REAL(wp)                         ::   area_tot     ! total ocean surface (interior domain)
+   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:  ) ::   area         ! cell surface (interior domain)
+   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:  ) ::   thick0       ! ocean thickness (interior domain)
+   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   sn0          ! initial salinity
+
+   LOGICAL  :: l_ar5
+      
+   !! * Substitutions
+#  include "vectopt_loop_substitute.h90"
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO Consortium (2010)
+   !! $Id$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   FUNCTION dia_ar5_alloc()
+      !!----------------------------------------------------------------------
+      !!                    ***  ROUTINE dia_ar5_alloc  ***
+      !!----------------------------------------------------------------------
+      INTEGER :: dia_ar5_alloc
+      !!----------------------------------------------------------------------
+      !
+      ALLOCATE( area(jpi,jpj), thick0(jpi,jpj) , sn0(jpi,jpj,jpk) , STAT=dia_ar5_alloc )
+      !
+      IF( lk_mpp             )   CALL mpp_sum ( dia_ar5_alloc )
+      IF( dia_ar5_alloc /= 0 )   CALL ctl_warn('dia_ar5_alloc: failed to allocate arrays')
+      !
+   END FUNCTION dia_ar5_alloc
+
+
+   SUBROUTINE dia_ar5( kt )
+      !!----------------------------------------------------------------------
+      !!                    ***  ROUTINE dia_ar5  ***
+      !!
+      !! ** Purpose :   compute and output some AR5 diagnostics
+      !!----------------------------------------------------------------------
+      !
+      INTEGER, INTENT( in ) ::   kt   ! ocean time-step index
+      !
+      INTEGER  ::   ji, jj, jk                      ! dummy loop arguments
+      REAL(wp) ::   zvolssh, zvol, zssh_steric, zztmp, zarho, ztemp, zsal, zmass
+      REAL(wp) ::   zaw, zbw, zrw
+      !
+      REAL(wp), ALLOCATABLE, DIMENSION(:,:)     :: zarea_ssh , zbotpres       ! 2D workspace 
+      REAL(wp), ALLOCATABLE, DIMENSION(:,:)     :: zpe                         ! 2D workspace 
+      REAL(wp), ALLOCATABLE, DIMENSION(:,:,:)   :: zrhd , zrhop               ! 3D workspace
+      REAL(wp), ALLOCATABLE, DIMENSION(:,:,:,:) :: ztsn                       ! 4D workspace
+
+      !!--------------------------------------------------------------------
+      IF( ln_timing )   CALL timing_start('dia_ar5')
+ 
+      IF( kt == nit000 )     CALL dia_ar5_init
+
+      IF( l_ar5 ) THEN 
+         ALLOCATE( zarea_ssh(jpi,jpj) , zbotpres(jpi,jpj) )
+         ALLOCATE( zrhd(jpi,jpj,jpk) , zrhop(jpi,jpj,jpk) )
+         ALLOCATE( ztsn(jpi,jpj,jpk,jpts) )
+         zarea_ssh(:,:) = area(:,:) * sshn(:,:)
+      ENDIF
+      !
+      IF( iom_use( 'voltot' ) .OR. iom_use( 'sshtot' )  .OR. iom_use( 'sshdyn' )  ) THEN    
+         !                                         ! total volume of liquid seawater
+         zvolssh = SUM( zarea_ssh(:,:) ) 
+         IF( lk_mpp )   CALL mpp_sum( zvolssh )
+         zvol = vol0 + zvolssh
+      
+         CALL iom_put( 'voltot', zvol               )
+         CALL iom_put( 'sshtot', zvolssh / area_tot )
+         CALL iom_put( 'sshdyn', sshn(:,:) - (zvolssh / area_tot) )
+         !
+      ENDIF
+
+      IF( iom_use( 'botpres' ) .OR. iom_use( 'sshthster' )  .OR. iom_use( 'sshsteric' )  ) THEN    
+         !                     
+         ztsn(:,:,:,jp_tem) = tsn(:,:,:,jp_tem)                    ! thermosteric ssh
+         ztsn(:,:,:,jp_sal) = sn0(:,:,:)
+         CALL eos( ztsn, zrhd, gdept_n(:,:,:) )                       ! now in situ density using initial salinity
+         !
+         zbotpres(:,:) = 0._wp                        ! no atmospheric surface pressure, levitating sea-ice
+         DO jk = 1, jpkm1
+            zbotpres(:,:) = zbotpres(:,:) + e3t_n(:,:,jk) * zrhd(:,:,jk)
+         END DO
+         IF( ln_linssh ) THEN
+            IF( ln_isfcav ) THEN
+               DO ji = 1, jpi
+                  DO jj = 1, jpj
+                     zbotpres(ji,jj) = zbotpres(ji,jj) + sshn(ji,jj) * zrhd(ji,jj,mikt(ji,jj)) + riceload(ji,jj)
+                  END DO
+               END DO
+            ELSE
+               zbotpres(:,:) = zbotpres(:,:) + sshn(:,:) * zrhd(:,:,1)
+            END IF
+!!gm
+!!gm   riceload should be added in both ln_linssh=T or F, no?
+!!gm
+         END IF
+         !                                         
+         zarho = SUM( area(:,:) * zbotpres(:,:) ) 
+         IF( lk_mpp )   CALL mpp_sum( zarho )
+         zssh_steric = - zarho / area_tot
+         CALL iom_put( 'sshthster', zssh_steric )
+      
+         !                                         ! steric sea surface height
+         CALL eos( tsn, zrhd, zrhop, gdept_n(:,:,:) )                 ! now in situ and potential density
+         zrhop(:,:,jpk) = 0._wp
+         CALL iom_put( 'rhop', zrhop )
+         !
+         zbotpres(:,:) = 0._wp                        ! no atmospheric surface pressure, levitating sea-ice
+         DO jk = 1, jpkm1
+            zbotpres(:,:) = zbotpres(:,:) + e3t_n(:,:,jk) * zrhd(:,:,jk)
+         END DO
+         IF( ln_linssh ) THEN
+            IF ( ln_isfcav ) THEN
+               DO ji = 1,jpi
+                  DO jj = 1,jpj
+                     zbotpres(ji,jj) = zbotpres(ji,jj) + sshn(ji,jj) * zrhd(ji,jj,mikt(ji,jj)) + riceload(ji,jj)
+                  END DO
+               END DO
+            ELSE
+               zbotpres(:,:) = zbotpres(:,:) + sshn(:,:) * zrhd(:,:,1)
+            END IF
+         END IF
+         !    
+         zarho = SUM( area(:,:) * zbotpres(:,:) ) 
+         IF( lk_mpp )   CALL mpp_sum( zarho )
+         zssh_steric = - zarho / area_tot
+         CALL iom_put( 'sshsteric', zssh_steric )
+      
+         !                                         ! ocean bottom pressure
+         zztmp = rau0 * grav * 1.e-4_wp               ! recover pressure from pressure anomaly and cover to dbar = 1.e4 Pa
+         zbotpres(:,:) = zztmp * ( zbotpres(:,:) + sshn(:,:) + thick0(:,:) )
+         CALL iom_put( 'botpres', zbotpres )
+         !
+      ENDIF
+
+      IF( iom_use( 'masstot' ) .OR. iom_use( 'temptot' )  .OR. iom_use( 'saltot' )  ) THEN    
+         !                                         ! Mean density anomalie, temperature and salinity
+         ztemp = 0._wp
+         zsal  = 0._wp
+         DO jk = 1, jpkm1
+            DO jj = 1, jpj
+               DO ji = 1, jpi
+                  zztmp = area(ji,jj) * e3t_n(ji,jj,jk)
+                  ztemp = ztemp + zztmp * tsn(ji,jj,jk,jp_tem)
+                  zsal  = zsal  + zztmp * tsn(ji,jj,jk,jp_sal)
+               END DO
+            END DO
+         END DO
+         IF( ln_linssh ) THEN
+            IF( ln_isfcav ) THEN
+               DO ji = 1, jpi
+                  DO jj = 1, jpj
+                     ztemp = ztemp + zarea_ssh(ji,jj) * tsn(ji,jj,mikt(ji,jj),jp_tem) 
+                     zsal  = zsal  + zarea_ssh(ji,jj) * tsn(ji,jj,mikt(ji,jj),jp_sal) 
+                  END DO
+               END DO
+            ELSE
+               ztemp = ztemp + SUM( zarea_ssh(:,:) * tsn(:,:,1,jp_tem) )
+               zsal  = zsal  + SUM( zarea_ssh(:,:) * tsn(:,:,1,jp_sal) )
+            END IF
+         ENDIF
+         IF( lk_mpp ) THEN  
+            CALL mpp_sum( ztemp )
+            CALL mpp_sum( zsal  )
+         END IF
+         !
+         zmass = rau0 * ( zarho + zvol )                 ! total mass of liquid seawater
+         ztemp = ztemp / zvol                            ! potential temperature in liquid seawater
+         zsal  = zsal  / zvol                            ! Salinity of liquid seawater
+         !
+         CALL iom_put( 'masstot', zmass )
+         CALL iom_put( 'temptot', ztemp )
+         CALL iom_put( 'saltot' , zsal  )
+         !
+      ENDIF
+
+      IF( iom_use( 'tnpeo' )) THEN    
+      ! Work done against stratification by vertical mixing
+      ! Exclude points where rn2 is negative as convection kicks in here and
+      ! work is not being done against stratification
+         ALLOCATE( zpe(jpi,jpj) )
+         zpe(:,:) = 0._wp
+         IF( ln_zdfddm ) THEN
+            DO jk = 2, jpk
+               DO jj = 1, jpj
+                  DO ji = 1, jpi
+                     IF( rn2(ji,jj,jk) > 0._wp ) THEN
+                        zrw =   ( gdepw_n(ji,jj,jk  ) - gdept_n(ji,jj,jk) )   &
+                           &  / ( gdept_n(ji,jj,jk-1) - gdept_n(ji,jj,jk) )
+!!gm  this can be reduced to :  (depw-dept) / e3w   (NB idem dans bn2 !)
+!                        zrw =   ( gdept_n(ji,jj,jk) - gdepw_n(ji,jj,jk) ) / e3w_n(ji,jj,jk)
+!!gm end
+                        !
+                        zaw = rab_n(ji,jj,jk,jp_tem) * (1. - zrw) + rab_n(ji,jj,jk-1,jp_tem)* zrw
+                        zbw = rab_n(ji,jj,jk,jp_sal) * (1. - zrw) + rab_n(ji,jj,jk-1,jp_sal)* zrw
+                        !
+                        zpe(ji, jj) = zpe(ji, jj)            &
+                           &        -  grav * (  avt(ji,jj,jk) * zaw * (tsn(ji,jj,jk-1,jp_tem) - tsn(ji,jj,jk,jp_tem) )  &
+                           &                   - avs(ji,jj,jk) * zbw * (tsn(ji,jj,jk-1,jp_sal) - tsn(ji,jj,jk,jp_sal) ) )
+                     ENDIF
+                  END DO
+               END DO
+             END DO
+          ELSE
+            DO jk = 1, jpk
+               DO ji = 1, jpi
+                  DO jj = 1, jpj
+                     zpe(ji,jj) = zpe(ji,jj) + avt(ji, jj, jk) * MIN(0._wp,rn2(ji, jj, jk)) * rau0 * e3w_n(ji, jj, jk)
+                  END DO
+               END DO
+            END DO
+         ENDIF
+!!gm useless lbc_lnk since the computation above is performed over 1:jpi & 1:jpj
+!!gm           CALL lbc_lnk( zpe, 'T', 1._wp)         
+          CALL iom_put( 'tnpeo', zpe )
+          DEALLOCATE( zpe )
+      ENDIF
+
+      IF( l_ar5 ) THEN
+        DEALLOCATE( zarea_ssh , zbotpres )
+        DEALLOCATE( zrhd      , zrhop    )
+        DEALLOCATE( ztsn                 )
+      ENDIF
+      !
+      IF( ln_timing )   CALL timing_stop('dia_ar5')
+      !
+   END SUBROUTINE dia_ar5
+
+
+   SUBROUTINE dia_ar5_hst( ktra, cptr, pua, pva ) 
+      !!----------------------------------------------------------------------
+      !!                    ***  ROUTINE dia_ar5_htr ***
+      !!----------------------------------------------------------------------
+      !! Wrapper for heat transport calculations
+      !! Called from all advection and/or diffusion routines
+      !!----------------------------------------------------------------------
+      INTEGER                         , INTENT(in )  :: ktra  ! tracer index
+      CHARACTER(len=3)                , INTENT(in)   :: cptr  ! transport type  'adv'/'ldf'
+      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in)   :: pua   ! 3D input array of advection/diffusion
+      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in)   :: pva   ! 3D input array of advection/diffusion
+      !
+      INTEGER    ::  ji, jj, jk
+      REAL(wp), DIMENSION(jpi,jpj)  :: z2d
+
+    
+      z2d(:,:) = pua(:,:,1) 
+      DO jk = 1, jpkm1
+         DO jj = 2, jpjm1
+            DO ji = fs_2, fs_jpim1   ! vector opt.
+               z2d(ji,jj) = z2d(ji,jj) + pua(ji,jj,jk) 
+            END DO
+         END DO
+       END DO
+       CALL lbc_lnk( z2d, 'U', -1. )
+       IF( cptr == 'adv' ) THEN
+          IF( ktra == jp_tem ) CALL iom_put( "uadv_heattr" , rau0_rcp * z2d )  ! advective heat transport in i-direction
+          IF( ktra == jp_sal ) CALL iom_put( "uadv_salttr" , rau0     * z2d )  ! advective salt transport in i-direction
+       ENDIF
+       IF( cptr == 'ldf' ) THEN
+          IF( ktra == jp_tem ) CALL iom_put( "udiff_heattr" , rau0_rcp * z2d ) ! diffusive heat transport in i-direction
+          IF( ktra == jp_sal ) CALL iom_put( "udiff_salttr" , rau0     * z2d ) ! diffusive salt transport in i-direction
+       ENDIF
+       !
+       z2d(:,:) = pva(:,:,1) 
+       DO jk = 1, jpkm1
+          DO jj = 2, jpjm1
+             DO ji = fs_2, fs_jpim1   ! vector opt.
+                z2d(ji,jj) = z2d(ji,jj) + pva(ji,jj,jk) 
+             END DO
+          END DO
+       END DO
+       CALL lbc_lnk( z2d, 'V', -1. )
+       IF( cptr == 'adv' ) THEN
+          IF( ktra == jp_tem ) CALL iom_put( "vadv_heattr" , rau0_rcp * z2d )  ! advective heat transport in j-direction
+          IF( ktra == jp_sal ) CALL iom_put( "vadv_salttr" , rau0     * z2d )  ! advective salt transport in j-direction
+       ENDIF
+       IF( cptr == 'ldf' ) THEN
+          IF( ktra == jp_tem ) CALL iom_put( "vdiff_heattr" , rau0_rcp * z2d ) ! diffusive heat transport in j-direction
+          IF( ktra == jp_sal ) CALL iom_put( "vdiff_salttr" , rau0     * z2d ) ! diffusive salt transport in j-direction
+       ENDIF
+          
+   END SUBROUTINE dia_ar5_hst
+
+
+   SUBROUTINE dia_ar5_init
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE dia_ar5_init  ***
+      !!                   
+      !! ** Purpose :   initialization for AR5 diagnostic computation
+      !!----------------------------------------------------------------------
+      INTEGER  ::   inum
+      INTEGER  ::   ik
+      INTEGER  ::   ji, jj, jk  ! dummy loop indices
+      REAL(wp) ::   zztmp  
+      REAL(wp), ALLOCATABLE, DIMENSION(:,:,:,:) ::   zsaldta   ! Jan/Dec levitus salinity
+      !
+      !!----------------------------------------------------------------------
+      !
+      l_ar5 = .FALSE.
+      IF(   iom_use( 'voltot'  ) .OR. iom_use( 'sshtot'    )  .OR. iom_use( 'sshdyn' )  .OR.  & 
+         &  iom_use( 'masstot' ) .OR. iom_use( 'temptot'   )  .OR. iom_use( 'saltot' ) .OR.  &    
+         &  iom_use( 'botpres' ) .OR. iom_use( 'sshthster' )  .OR. iom_use( 'sshsteric' )  ) L_ar5 = .TRUE.
+  
+      IF( l_ar5 ) THEN
+         !
+         !                                      ! allocate dia_ar5 arrays
+         IF( dia_ar5_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'dia_ar5_init : unable to allocate arrays' )
+
+         area(:,:) = e1e2t(:,:) * tmask_i(:,:)
+
+         area_tot = SUM( area(:,:) )   ;   IF( lk_mpp )   CALL mpp_sum( area_tot )
+
+         vol0        = 0._wp
+         thick0(:,:) = 0._wp
+         DO jk = 1, jpkm1
+            vol0        = vol0        + SUM( area (:,:) * tmask(:,:,jk) * e3t_0(:,:,jk) )
+            thick0(:,:) = thick0(:,:) +    tmask_i(:,:) * tmask(:,:,jk) * e3t_0(:,:,jk)
+         END DO
+         IF( lk_mpp )   CALL mpp_sum( vol0 )
+
+         IF( iom_use( 'sshthster' ) ) THEN
+            ALLOCATE( zsaldta(jpi,jpj,jpj,jpts) )
+            CALL iom_open ( 'sali_ref_clim_monthly', inum )
+            CALL iom_get  ( inum, jpdom_data, 'vosaline' , zsaldta(:,:,:,1), 1  )
+            CALL iom_get  ( inum, jpdom_data, 'vosaline' , zsaldta(:,:,:,2), 12 )
+            CALL iom_close( inum )
+
+            sn0(:,:,:) = 0.5_wp * ( zsaldta(:,:,:,1) + zsaldta(:,:,:,2) )        
+            sn0(:,:,:) = sn0(:,:,:) * tmask(:,:,:)
+            IF( ln_zps ) THEN               ! z-coord. partial steps
+               DO jj = 1, jpj               ! interpolation of salinity at the last ocean level (i.e. the partial step)
+                  DO ji = 1, jpi
+                     ik = mbkt(ji,jj)
+                     IF( ik > 1 ) THEN
+                        zztmp = ( gdept_1d(ik) - gdept_0(ji,jj,ik) ) / ( gdept_1d(ik) - gdept_1d(ik-1) )
+                        sn0(ji,jj,ik) = ( 1._wp - zztmp ) * sn0(ji,jj,ik) + zztmp * sn0(ji,jj,ik-1)
+                     ENDIF
+                  END DO
+               END DO
+            ENDIF
+            !
+            DEALLOCATE( zsaldta )
+         ENDIF
+         !
+      ENDIF
+      !
+   END SUBROUTINE dia_ar5_init
+
+   !!======================================================================
+END MODULE diaar5
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DIA/diacfl.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DIA/diacfl.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DIA/diacfl.F90	(revision 9570)
@@ -0,0 +1,175 @@
+MODULE diacfl
+   !!======================================================================
+   !!                       ***  MODULE  diacfl  ***
+   !! Output CFL diagnostics to ascii file
+   !!======================================================================
+   !! History :  3.4  !  2010-03  (E. Blockley)  Original code
+   !!            3.6  !  2014-06  (T. Graham)  Removed CPP key & Updated to vn3.6
+   !!            4.0  !  2017-09  (G. Madec)  style + comments
+   !!----------------------------------------------------------------------
+   !!   dia_cfl        : Compute and output Courant numbers at each timestep
+   !!----------------------------------------------------------------------
+   USE oce             ! ocean dynamics and active tracers
+   USE dom_oce         ! ocean space and time domain
+   USE domvvl          ! 
+   !
+   USE lib_mpp         ! distribued memory computing
+   USE lbclnk          ! ocean lateral boundary condition (or mpp link)
+   USE in_out_manager  ! I/O manager
+   USE timing          ! Performance output
+
+   IMPLICIT NONE
+   PRIVATE
+
+   CHARACTER(LEN=50) :: clname="cfl_diagnostics.ascii"    ! ascii filename
+   INTEGER           :: numcfl                            ! outfile unit
+   !
+   INTEGER, DIMENSION(3) ::   nCu_loc, nCv_loc, nCw_loc   ! U, V, and W run max locations in the global domain
+   REAL(wp)              ::   rCu_max, rCv_max, rCw_max   ! associated run max Courant number 
+
+!!gm CAUTION: need to declare these arrays here, otherwise the calculation fails in multi-proc !
+!!gm          I don't understand why.
+   REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) ::   zCu_cfl, zCv_cfl, zCw_cfl         ! workspace
+!!gm end
+
+   PUBLIC   dia_cfl       ! routine called by step.F90
+   PUBLIC   dia_cfl_init  ! routine called by nemogcm
+
+   !! * Substitutions
+#  include "vectopt_loop_substitute.h90"
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.2 , LOCEAN-IPSL (2009) 
+   !! $Id$
+   !! Software governed by the CeCILL licence (modipsl/doc/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE dia_cfl ( kt )
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE dia_cfl  ***
+      !!
+      !! ** Purpose :  Compute the Courant numbers Cu=u*dt/dx and Cv=v*dt/dy
+      !!               and output to ascii file 'cfl_diagnostics.ascii'
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT(in) ::   kt   ! ocean time-step index
+      !
+      INTEGER :: ji, jj, jk   ! dummy loop indices
+      REAL(wp)::   z2dt, zCu_max, zCv_max, zCw_max       ! local scalars
+      INTEGER , DIMENSION(3)           ::   iloc_u , iloc_v , iloc_w , iloc   ! workspace
+!!gm this does not work      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zCu_cfl, zCv_cfl, zCw_cfl         ! workspace
+      !!----------------------------------------------------------------------
+      !
+      IF( ln_timing )   CALL timing_start('dia_cfl')
+      !
+      !                       ! setup timestep multiplier to account for initial Eulerian timestep
+      IF( neuler == 0 .AND. kt == nit000 ) THEN   ;    z2dt = rdt
+      ELSE                                        ;    z2dt = rdt * 2._wp
+      ENDIF
+      !
+      !                
+      DO jk = 1, jpk       ! calculate Courant numbers
+         DO jj = 1, jpj
+            DO ji = 1, fs_jpim1   ! vector opt.
+               zCu_cfl(ji,jj,jk) = ABS( un(ji,jj,jk) ) * z2dt / e1u  (ji,jj)      ! for i-direction
+               zCv_cfl(ji,jj,jk) = ABS( vn(ji,jj,jk) ) * z2dt / e2v  (ji,jj)      ! for j-direction
+               zCw_cfl(ji,jj,jk) = ABS( wn(ji,jj,jk) ) * z2dt / e3w_n(ji,jj,jk)   ! for k-direction
+            END DO
+         END DO         
+      END DO
+      !
+      !                    ! calculate maximum values and locations
+      IF( lk_mpp ) THEN
+         CALL mpp_maxloc( zCu_cfl, umask, zCu_max, iloc_u(1), iloc_u(2), iloc_u(3) )
+         CALL mpp_maxloc( zCv_cfl, vmask, zCv_max, iloc_v(1), iloc_v(2), iloc_v(3) )
+         CALL mpp_maxloc( zCw_cfl, wmask, zCw_max, iloc_w(1), iloc_w(2), iloc_w(3) )
+      ELSE
+         iloc = MAXLOC( ABS( zcu_cfl(:,:,:) ) )
+         iloc_u(1) = iloc(1) + nimpp - 1
+         iloc_u(2) = iloc(2) + njmpp - 1
+         iloc_u(3) = iloc(3)
+         zCu_max = zCu_cfl(iloc(1),iloc(2),iloc(3))
+         !
+         iloc = MAXLOC( ABS( zcv_cfl(:,:,:) ) )
+         iloc_v(1) = iloc(1) + nimpp - 1
+         iloc_v(2) = iloc(2) + njmpp - 1
+         iloc_v(3) = iloc(3)
+         zCv_max = zCv_cfl(iloc(1),iloc(2),iloc(3))
+         !
+         iloc = MAXLOC( ABS( zcw_cfl(:,:,:) ) )
+         iloc_w(1) = iloc(1) + nimpp - 1
+         iloc_w(2) = iloc(2) + njmpp - 1
+         iloc_w(3) = iloc(3)
+         zCw_max = zCw_cfl(iloc(1),iloc(2),iloc(3))
+      ENDIF
+      !
+      !                    ! write out to file
+      IF( lwp ) THEN
+         WRITE(numcfl,FMT='(2x,i4,5x,a6,4x,f7.4,1x,i4,1x,i4,1x,i4)') kt, 'Max Cu', zCu_max, iloc_u(1), iloc_u(2), iloc_u(3)
+         WRITE(numcfl,FMT='(11x,     a6,4x,f7.4,1x,i4,1x,i4,1x,i4)')     'Max Cv', zCv_max, iloc_v(1), iloc_v(2), iloc_v(3)
+         WRITE(numcfl,FMT='(11x,     a6,4x,f7.4,1x,i4,1x,i4,1x,i4)')     'Max Cw', zCw_max, iloc_w(1), iloc_w(2), iloc_w(3)
+      ENDIF
+      !
+      !                    ! update maximum Courant numbers from whole run if applicable
+      IF( zCu_max > rCu_max ) THEN   ;   rCu_max = zCu_max   ;   nCu_loc(:) = iloc_u(:)   ;   ENDIF
+      IF( zCv_max > rCv_max ) THEN   ;   rCv_max = zCv_max   ;   nCv_loc(:) = iloc_v(:)   ;   ENDIF
+      IF( zCw_max > rCw_max ) THEN   ;   rCw_max = zCw_max   ;   nCw_loc(:) = iloc_w(:)   ;   ENDIF
+
+      !                    ! at end of run output max Cu and Cv and close ascii file
+      IF( kt == nitend .AND. lwp ) THEN
+         ! to ascii file
+         WRITE(numcfl,*) '******************************************'
+         WRITE(numcfl,FMT='(3x,a12,6x,f7.4,1x,i4,1x,i4,1x,i4)') 'Run Max Cu', rCu_max, nCu_loc(1), nCu_loc(2), nCu_loc(3)
+         WRITE(numcfl,FMT='(3x,a8,11x,f15.1)') ' => dt/C', z2dt/rCu_max
+         WRITE(numcfl,*) '******************************************'
+         WRITE(numcfl,FMT='(3x,a12,6x,f7.4,1x,i4,1x,i4,1x,i4)') 'Run Max Cv', rCv_max, nCv_loc(1), nCv_loc(2), nCv_loc(3)
+         WRITE(numcfl,FMT='(3x,a8,11x,f15.1)') ' => dt/C', z2dt/rCv_max
+         WRITE(numcfl,*) '******************************************'
+         WRITE(numcfl,FMT='(3x,a12,6x,f7.4,1x,i4,1x,i4,1x,i4)') 'Run Max Cw', rCw_max, nCw_loc(1), nCw_loc(2), nCw_loc(3)
+         WRITE(numcfl,FMT='(3x,a8,11x,f15.1)') ' => dt/C', z2dt/rCw_max
+         CLOSE( numcfl ) 
+         !
+         ! to ocean output
+         WRITE(numout,*)
+         WRITE(numout,*) 'dia_cfl : Maximum Courant number information for the run '
+         WRITE(numout,*) '~~~~~~~'
+         WRITE(numout,*) '   Max Cu = ', rCu_max, ' at (i,j,k) = (',nCu_loc(1),nCu_loc(2),nCu_loc(3),') => dt/C = ', z2dt/rCu_max
+         WRITE(numout,*) '   Max Cv = ', rCv_max, ' at (i,j,k) = (',nCv_loc(1),nCv_loc(2),nCv_loc(3),') => dt/C = ', z2dt/rCv_max
+         WRITE(numout,*) '   Max Cw = ', rCw_max, ' at (i,j,k) = (',nCw_loc(1),nCw_loc(2),nCw_loc(3),') => dt/C = ', z2dt/rCw_max
+      ENDIF
+      !
+      IF( ln_timing )   CALL timing_stop('dia_cfl')
+      !
+   END SUBROUTINE dia_cfl
+
+
+   SUBROUTINE dia_cfl_init
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE dia_cfl_init  ***
+      !!                   
+      !! ** Purpose :   create output file, initialise arrays
+      !!----------------------------------------------------------------------
+      !
+      IF(lwp) THEN
+         WRITE(numout,*)
+         WRITE(numout,*) 'dia_cfl : Outputting CFL diagnostics to ',TRIM(clname), ' file'
+         WRITE(numout,*) '~~~~~~~'
+         WRITE(numout,*)
+         !
+         ! create output ascii file
+         CALL ctl_opn( numcfl, clname, 'UNKNOWN', 'FORMATTED', 'SEQUENTIAL', 1, numout, lwp, 1 )
+         WRITE(numcfl,*) 'Timestep  Direction  Max C     i    j    k'
+         WRITE(numcfl,*) '******************************************'
+      ENDIF
+      !
+      rCu_max = 0._wp
+      rCv_max = 0._wp
+      rCw_max = 0._wp
+      !
+!!gm required to work
+      ALLOCATE ( zCu_cfl(jpi,jpj,jpk), zCv_cfl(jpi,jpj,jpk), zCw_cfl(jpi,jpj,jpk) )
+!!gm end
+      !      
+   END SUBROUTINE dia_cfl_init
+
+   !!======================================================================
+END MODULE diacfl
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DIA/diadct.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DIA/diadct.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DIA/diadct.F90	(revision 9570)
@@ -0,0 +1,1261 @@
+MODULE diadct
+   !!======================================================================
+   !!                       ***  MODULE  diadct  ***
+   !! Ocean diagnostics: Compute the transport trough a sec.
+   !!======================================================================
+   !! History :  OPA  ! 02/1999 (Y Drillet)  original code
+   !!                 ! 10/2001 (Y Drillet, R Bourdalle Badie)
+   !!   NEMO     1.0  ! 10/2005 (M Laborie) F90
+   !!            3.0  ! 04/2007 (G Garric) Ice sections
+   !!             -   ! 04/2007 (C Bricaud) test on sec%nb_point, initialisation of ztransp1,ztransp2,...
+   !!            3.4  ! 09/2011 (C Bricaud)
+   !!----------------------------------------------------------------------
+#if defined key_diadct
+   !!----------------------------------------------------------------------
+   !!   'key_diadct' :
+   !!----------------------------------------------------------------------
+   !!----------------------------------------------------------------------
+   !!   dia_dct      :  Compute the transport through a sec.
+   !!   dia_dct_init :  Read namelist.
+   !!   readsec      :  Read sections description and pathway
+   !!   removepoints :  Remove points which are common to 2 procs
+   !!   transport    :  Compute transport for each sections
+   !!   dia_dct_wri  :  Write tranports results in ascii files
+   !!   interp       :  Compute temperature/salinity/density at U-point or V-point
+   !!   
+   !!----------------------------------------------------------------------
+   USE oce             ! ocean dynamics and tracers
+   USE dom_oce         ! ocean space and time domain
+   USE phycst          ! physical constants
+   USE in_out_manager  ! I/O manager
+   USE daymod          ! calendar
+   USE dianam          ! build name of file
+   USE lib_mpp         ! distributed memory computing library
+#if defined key_si3
+   USE ice
+#endif
+   USE domvvl
+   USE timing          ! preformance summary
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   dia_dct      ! routine called by step.F90
+   PUBLIC   dia_dct_init ! routine called by opa.F90
+   PUBLIC   diadct_alloc ! routine called by nemo_init in nemogcm.F90 
+   PRIVATE  readsec
+   PRIVATE  removepoints
+   PRIVATE  transport
+   PRIVATE  dia_dct_wri
+
+   LOGICAL, PUBLIC, PARAMETER ::   lk_diadct = .TRUE.   !: model-data diagnostics flag
+
+   INTEGER :: nn_dct        ! Frequency of computation
+   INTEGER :: nn_dctwri     ! Frequency of output
+   INTEGER :: nn_secdebug   ! Number of the section to debug
+   
+   INTEGER, PARAMETER :: nb_class_max  = 10
+   INTEGER, PARAMETER :: nb_sec_max    = 150
+   INTEGER, PARAMETER :: nb_point_max  = 2000
+   INTEGER, PARAMETER :: nb_type_class = 10
+   INTEGER, PARAMETER :: nb_3d_vars    = 3 
+   INTEGER, PARAMETER :: nb_2d_vars    = 2 
+   INTEGER            :: nb_sec 
+
+   TYPE POINT_SECTION
+      INTEGER :: I,J
+   END TYPE POINT_SECTION
+
+   TYPE COORD_SECTION
+      REAL(wp) :: lon,lat
+   END TYPE COORD_SECTION
+
+   TYPE SECTION
+      CHARACTER(len=60)                            :: name              ! name of the sec
+      LOGICAL                                      :: llstrpond         ! true if you want the computation of salt and
+                                                                       ! heat transports
+      LOGICAL                                      :: ll_ice_section    ! ice surface and ice volume computation
+      LOGICAL                                      :: ll_date_line      ! = T if the section crosses the date-line
+      TYPE(COORD_SECTION), DIMENSION(2)            :: coordSec          ! longitude and latitude of the extremities of the sec
+      INTEGER                                      :: nb_class          ! number of boundaries for density classes
+      INTEGER, DIMENSION(nb_point_max)             :: direction         ! vector direction of the point in the section
+      CHARACTER(len=40),DIMENSION(nb_class_max)    :: classname         ! characteristics of the class
+      REAL(wp), DIMENSION(nb_class_max)            :: zsigi           ,&! in-situ   density classes    (99 if you don't want)
+                                                      zsigp           ,&! potential density classes    (99 if you don't want)
+                                                      zsal            ,&! salinity classes   (99 if you don't want)
+                                                      ztem            ,&! temperature classes(99 if you don't want)
+                                                      zlay              ! level classes      (99 if you don't want)
+      REAL(wp), DIMENSION(nb_type_class,nb_class_max)  :: transport     ! transport output
+      REAL(wp)                                         :: slopeSection  ! slope of the section
+      INTEGER                                          :: nb_point      ! number of points in the section
+      TYPE(POINT_SECTION),DIMENSION(nb_point_max)      :: listPoint     ! list of points in the sections
+   END TYPE SECTION
+
+   TYPE(SECTION),DIMENSION(nb_sec_max) :: secs ! Array of sections
+ 
+   REAL(wp), ALLOCATABLE, DIMENSION(:,:,:,:) ::  transports_3d 
+   REAL(wp), ALLOCATABLE, DIMENSION(:,:,:)   ::  transports_2d  
+
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO Consortium (2010)
+   !! $Id$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+ 
+  INTEGER FUNCTION diadct_alloc() 
+     !!---------------------------------------------------------------------- 
+     !!                   ***  FUNCTION diadct_alloc  *** 
+     !!---------------------------------------------------------------------- 
+     INTEGER :: ierr(2) 
+     !!---------------------------------------------------------------------- 
+
+     ALLOCATE(transports_3d(nb_3d_vars,nb_sec_max,nb_point_max,jpk), STAT=ierr(1) ) 
+     ALLOCATE(transports_2d(nb_2d_vars,nb_sec_max,nb_point_max)    , STAT=ierr(2) ) 
+
+     diadct_alloc = MAXVAL( ierr ) 
+     IF( diadct_alloc /= 0 )   CALL ctl_warn('diadct_alloc: failed to allocate arrays') 
+ 
+  END FUNCTION diadct_alloc 
+
+
+   SUBROUTINE dia_dct_init
+      !!---------------------------------------------------------------------
+      !!               ***  ROUTINE diadct  ***  
+      !!
+      !!  ** Purpose: Read the namelist parameters
+      !!              Open output files
+      !!
+      !!---------------------------------------------------------------------
+      INTEGER  ::   ios                 ! Local integer output status for namelist read
+      !!
+      NAMELIST/namdct/nn_dct,nn_dctwri,nn_secdebug
+      !!---------------------------------------------------------------------
+
+     REWIND( numnam_ref )              ! Namelist namdct in reference namelist : Diagnostic: transport through sections
+     READ  ( numnam_ref, namdct, IOSTAT = ios, ERR = 901)
+901  IF( ios /= 0 ) CALL ctl_nam ( ios , 'namdct in reference namelist', lwp )
+
+     REWIND( numnam_cfg )              ! Namelist namdct in configuration namelist : Diagnostic: transport through sections
+     READ  ( numnam_cfg, namdct, IOSTAT = ios, ERR = 902 )
+902  IF( ios >  0 ) CALL ctl_nam ( ios , 'namdct in configuration namelist', lwp )
+     IF(lwm) WRITE ( numond, namdct )
+
+     IF( lwp ) THEN
+        WRITE(numout,*) " "
+        WRITE(numout,*) "diadct_init: compute transports through sections "
+        WRITE(numout,*) "~~~~~~~~~~~~~~~~~~~~~"
+        WRITE(numout,*) "       Frequency of computation: nn_dct    = ",nn_dct
+        WRITE(numout,*) "       Frequency of write:       nn_dctwri = ",nn_dctwri
+
+        IF      ( nn_secdebug .GE. 1 .AND. nn_secdebug .LE. nb_sec_max )THEN
+                                            WRITE(numout,*)"       Debug section number: ", nn_secdebug 
+        ELSE IF ( nn_secdebug ==  0 )THEN ; WRITE(numout,*)"       No section to debug"
+        ELSE IF ( nn_secdebug == -1 )THEN ; WRITE(numout,*)"       Debug all sections"
+        ELSE                              ; WRITE(numout,*)"       Wrong value for nn_secdebug : ",nn_secdebug
+        ENDIF
+
+        IF(nn_dct .GE. nn_dctwri .AND. MOD(nn_dct,nn_dctwri) .NE. 0)  &
+          &  CALL ctl_stop( 'diadct: nn_dct should be smaller and a multiple of nn_dctwri' )
+
+     ENDIF
+
+     !Read section_ijglobal.diadct
+     CALL readsec
+
+     !open output file
+     IF( lwm ) THEN
+        CALL ctl_opn( numdct_vol,  'volume_transport', 'NEW', 'FORMATTED', 'SEQUENTIAL', -1, numout,  .FALSE. )
+        CALL ctl_opn( numdct_heat, 'heat_transport'  , 'NEW', 'FORMATTED', 'SEQUENTIAL', -1, numout,  .FALSE. )
+        CALL ctl_opn( numdct_salt, 'salt_transport'  , 'NEW', 'FORMATTED', 'SEQUENTIAL', -1, numout,  .FALSE. )
+     ENDIF
+
+     ! Initialise arrays to zero 
+     transports_3d(:,:,:,:)=0.0 
+     transports_2d(:,:,:)  =0.0 
+     !
+  END SUBROUTINE dia_dct_init
+ 
+ 
+  SUBROUTINE dia_dct( kt )
+     !!---------------------------------------------------------------------
+     !!               ***  ROUTINE diadct  ***  
+     !!
+     !!  Purpose :: Compute section transports and write it in numdct files 
+     !!   
+     !!  Method  :: All arrays initialised to zero in dct_init 
+     !!             Each nn_dct time step call subroutine 'transports' for 
+     !!               each section to sum the transports over each grid cell. 
+     !!             Each nn_dctwri time step: 
+     !!               Divide the arrays by the number of summations to gain 
+     !!               an average value 
+     !!               Call dia_dct_sum to sum relevant grid boxes to obtain 
+     !!               totals for each class (density, depth, temp or sal) 
+     !!               Call dia_dct_wri to write the transports into file 
+     !!               Reinitialise all relevant arrays to zero 
+     !!---------------------------------------------------------------------
+     INTEGER, INTENT(in) ::   kt
+     !
+     INTEGER ::   jsec              ! loop on sections
+     INTEGER ::   itotal            ! nb_sec_max*nb_type_class*nb_class_max
+     LOGICAL ::   lldebug =.FALSE.  ! debug a section  
+     INTEGER              , DIMENSION(1)    ::   ish     ! work array for mpp_sum
+     INTEGER              , DIMENSION(3)    ::   ish2    !   "
+     REAL(wp), ALLOCATABLE, DIMENSION(:)    ::   zwork   !   "  
+     REAL(wp), ALLOCATABLE, DIMENSION(:,:,:)::   zsum    !   "
+     !!---------------------------------------------------------------------    
+     !
+     IF( ln_timing )   CALL timing_start('dia_dct')
+
+     IF( lk_mpp )THEN
+        itotal = nb_sec_max*nb_type_class*nb_class_max
+        ALLOCATE( zwork(itotal) , zsum(nb_sec_max,nb_type_class,nb_class_max) )
+     ENDIF    
+ 
+     ! Initialise arrays
+     zwork(:) = 0.0 
+     zsum(:,:,:) = 0.0
+
+     IF( lwp .AND. kt==nit000+nn_dct-1 ) THEN
+         WRITE(numout,*) " "
+         WRITE(numout,*) "diadct: compute transport"
+         WRITE(numout,*) "~~~~~~~~~~~~~~~~~~~~~~~~~"
+         WRITE(numout,*) "nb_sec = ",nb_sec
+     ENDIF
+
+ 
+     ! Compute transport and write only at nn_dctwri
+     IF( MOD(kt,nn_dct)==0 ) THEN 
+
+        DO jsec=1,nb_sec
+
+           !debug this section computing ?
+           lldebug=.FALSE.
+           IF( (jsec==nn_secdebug .OR. nn_secdebug==-1) .AND.  kt==nit000+nn_dct-1 ) lldebug=.TRUE. 
+
+           !Compute transport through section  
+           CALL transport(secs(jsec),lldebug,jsec) 
+
+        ENDDO
+             
+        IF( MOD(kt,nn_dctwri)==0 )THEN
+
+           IF( kt==nit000+nn_dctwri-1 )WRITE(numout,*)"      diadct: average transports and write at kt = ",kt         
+  
+           !! divide arrays by nn_dctwri/nn_dct to obtain average 
+           transports_3d(:,:,:,:)=transports_3d(:,:,:,:)/(nn_dctwri/nn_dct) 
+           transports_2d(:,:,:)  =transports_2d(:,:,:)  /(nn_dctwri/nn_dct) 
+ 
+           ! Sum over each class 
+           DO jsec=1,nb_sec 
+              CALL dia_dct_sum(secs(jsec),jsec) 
+           ENDDO 
+
+           !Sum on all procs 
+           IF( lk_mpp )THEN
+              ish(1)  =  nb_sec_max*nb_type_class*nb_class_max 
+              ish2    = (/nb_sec_max,nb_type_class,nb_class_max/)
+              DO jsec=1,nb_sec ; zsum(jsec,:,:) = secs(jsec)%transport(:,:) ; ENDDO
+              zwork(:)= RESHAPE(zsum(:,:,:), ish )
+              CALL mpp_sum(zwork, ish(1))
+              zsum(:,:,:)= RESHAPE(zwork,ish2)
+              DO jsec=1,nb_sec ; secs(jsec)%transport(:,:) = zsum(jsec,:,:) ; ENDDO
+           ENDIF
+
+           !Write the transport
+           DO jsec=1,nb_sec
+
+              IF( lwm )CALL dia_dct_wri(kt,jsec,secs(jsec))
+            
+              !nullify transports values after writing
+              transports_3d(:,jsec,:,:)=0.
+              transports_2d(:,jsec,:  )=0.
+              secs(jsec)%transport(:,:)=0.  
+
+           ENDDO
+
+        ENDIF 
+
+     ENDIF
+
+     IF( lk_mpp )THEN
+        itotal = nb_sec_max*nb_type_class*nb_class_max
+        DEALLOCATE( zwork , zsum  )
+     ENDIF    
+
+     IF( ln_timing )   CALL timing_stop('dia_dct')
+     !
+  END SUBROUTINE dia_dct
+
+
+  SUBROUTINE readsec 
+     !!---------------------------------------------------------------------
+     !!               ***  ROUTINE readsec  ***
+     !!
+     !!  ** Purpose:
+     !!            Read a binary file(section_ijglobal.diadct) 
+     !!            generated by the tools "NEMOGCM/TOOLS/SECTIONS_DIADCT"
+     !!
+     !!
+     !!---------------------------------------------------------------------
+     INTEGER :: iptglo , iptloc                               ! Global and local number of points for a section
+     INTEGER :: isec, iiglo, ijglo, iiloc, ijloc,iost,i1 ,i2  ! temporary  integer
+     INTEGER :: jsec, jpt                                     ! dummy loop indices
+     INTEGER, DIMENSION(2) :: icoord 
+     LOGICAL               :: llbon, lldebug   ! local logical
+     CHARACTER(len=160)    :: clname           ! filename
+     CHARACTER(len=200)    :: cltmp
+     CHARACTER(len=200)    :: clformat                          !automatic format
+     TYPE(POINT_SECTION),DIMENSION(nb_point_max)  ::coordtemp   !contains listpoints coordinates read in the file
+     INTEGER, DIMENSION(nb_point_max) :: directemp              !contains listpoints directions read in the files
+     !!-------------------------------------------------------------------------------------
+
+     !open input file
+     !---------------
+     CALL ctl_opn( numdct_in, 'section_ijglobal.diadct', 'OLD', 'UNFORMATTED', 'SEQUENTIAL', -1, numout, .FALSE. )
+ 
+     !---------------
+     !Read input file
+     !---------------
+     
+     DO jsec=1,nb_sec_max      !loop on the nb_sec sections
+
+        IF (  jsec==nn_secdebug .OR. nn_secdebug==-1  ) &
+           & WRITE(numout,*)'debuging for section number: ',jsec 
+
+        !initialization
+        !---------------
+        secs(jsec)%name=''
+        secs(jsec)%llstrpond    = .FALSE.  ; secs(jsec)%ll_ice_section = .FALSE.
+        secs(jsec)%ll_date_line = .FALSE.  ; secs(jsec)%nb_class       = 0
+        secs(jsec)%zsigi        = 99._wp   ; secs(jsec)%zsigp          = 99._wp
+        secs(jsec)%zsal         = 99._wp   ; secs(jsec)%ztem           = 99._wp
+        secs(jsec)%zlay         = 99._wp         
+        secs(jsec)%transport    =  0._wp   ; secs(jsec)%nb_point       = 0
+
+        !read section's number / name / computing choices / classes / slopeSection / points number
+        !-----------------------------------------------------------------------------------------
+        READ(numdct_in,iostat=iost)isec
+        IF (iost .NE. 0 )EXIT !end of file 
+        WRITE(cltmp,'(a,i4.4,a,i4.4)')'diadct: read sections : Problem of section number: isec= ',isec,' and jsec= ',jsec
+        IF( jsec .NE. isec )  CALL ctl_stop( cltmp )
+
+        IF( jsec==nn_secdebug .OR. nn_secdebug==-1 )WRITE(numout,*)"isec ",isec 
+
+        READ(numdct_in)secs(jsec)%name
+        READ(numdct_in)secs(jsec)%llstrpond
+        READ(numdct_in)secs(jsec)%ll_ice_section
+        READ(numdct_in)secs(jsec)%ll_date_line
+        READ(numdct_in)secs(jsec)%coordSec
+        READ(numdct_in)secs(jsec)%nb_class
+        READ(numdct_in)secs(jsec)%zsigi
+        READ(numdct_in)secs(jsec)%zsigp
+        READ(numdct_in)secs(jsec)%zsal
+        READ(numdct_in)secs(jsec)%ztem
+        READ(numdct_in)secs(jsec)%zlay
+        READ(numdct_in)secs(jsec)%slopeSection
+        READ(numdct_in)iptglo
+
+        !debug
+        !-----
+
+        IF( jsec==nn_secdebug .OR. nn_secdebug==-1 )THEN
+          
+            WRITE(clformat,'(a,i2,a)') '(A40,', nb_class_max,'(f8.3,1X))' 
+
+            WRITE(numout,*)       "   Section name :                       ",TRIM(secs(jsec)%name)
+            WRITE(numout,*)       "      Compute heat and salt transport ? ",secs(jsec)%llstrpond
+            WRITE(numout,*)       "      Compute ice transport ?           ",secs(jsec)%ll_ice_section
+            WRITE(numout,*)       "      Section crosses date-line ?       ",secs(jsec)%ll_date_line
+            WRITE(numout,*)       "      Slope section :                   ",secs(jsec)%slopeSection
+            WRITE(numout,*)       "      Number of points in the section:  ",iptglo
+            WRITE(numout,*)       "      Number of classes                 ",secs(jsec)%nb_class
+            WRITE(numout,clformat)"      Insitu density classes :          ",secs(jsec)%zsigi
+            WRITE(numout,clformat)"      Potential density classes :       ",secs(jsec)%zsigp
+            WRITE(numout,clformat)"      Salinity classes :                ",secs(jsec)%zsal
+            WRITE(numout,clformat)"      Temperature classes :             ",secs(jsec)%ztem
+            WRITE(numout,clformat)"      Depth classes :                   ",secs(jsec)%zlay
+        ENDIF               
+
+        IF( iptglo /= 0 )THEN
+             
+           !read points'coordinates and directions 
+           !--------------------------------------
+           coordtemp(:) = POINT_SECTION(0,0) !list of points read
+           directemp(:) = 0                  !value of directions of each points
+           DO jpt=1,iptglo
+              READ(numdct_in) i1, i2
+              coordtemp(jpt)%I = i1 
+              coordtemp(jpt)%J = i2
+           ENDDO
+           READ(numdct_in) directemp(1:iptglo)
+    
+           !debug
+           !-----
+           IF( jsec==nn_secdebug .OR. nn_secdebug==-1 )THEN
+              WRITE(numout,*)"      List of points in global domain:"
+              DO jpt=1,iptglo
+                 WRITE(numout,*)'        # I J ',jpt,coordtemp(jpt),directemp(jpt)
+              ENDDO                  
+           ENDIF
+ 
+           !Now each proc selects only points that are in its domain:
+           !--------------------------------------------------------
+           iptloc = 0                    ! initialize number of points selected
+           DO jpt = 1, iptglo            ! loop on listpoint read in the file
+              !      
+              iiglo=coordtemp(jpt)%I          ! global coordinates of the point
+              ijglo=coordtemp(jpt)%J          !  " 
+
+              IF( iiglo==jpiglo .AND. nimpp==1 )   iiglo = 2         !!gm BUG: Hard coded periodicity !
+
+              iiloc=iiglo-nimpp+1   ! local coordinates of the point
+              ijloc=ijglo-njmpp+1   !  "
+
+              !verify if the point is on the local domain:(1,nlei)*(1,nlej)
+              IF( iiloc >= 1 .AND. iiloc <= nlei .AND. &
+                  ijloc >= 1 .AND. ijloc <= nlej       )THEN
+                 iptloc = iptloc + 1                                                 ! count local points
+                 secs(jsec)%listPoint(iptloc) = POINT_SECTION(mi0(iiglo),mj0(ijglo)) ! store local coordinates
+                 secs(jsec)%direction(iptloc) = directemp(jpt)                       ! store local direction
+              ENDIF
+              !
+           END DO
+     
+           secs(jsec)%nb_point=iptloc !store number of section's points
+
+           !debug
+           !-----
+           IF( jsec==nn_secdebug .OR. nn_secdebug==-1 )THEN
+              WRITE(numout,*)"      List of points selected by the proc:"
+              DO jpt = 1,iptloc
+                 iiglo = secs(jsec)%listPoint(jpt)%I + nimpp - 1
+                 ijglo = secs(jsec)%listPoint(jpt)%J + njmpp - 1
+                 WRITE(numout,*)'         # I J : ',iiglo,ijglo
+              ENDDO
+           ENDIF
+
+              IF(jsec==nn_secdebug .AND. secs(jsec)%nb_point .NE. 0)THEN
+              DO jpt = 1,iptloc
+                 iiglo = secs(jsec)%listPoint(jpt)%I + nimpp - 1
+                 ijglo = secs(jsec)%listPoint(jpt)%J + njmpp - 1
+              ENDDO
+              ENDIF
+
+           !remove redundant points between processors
+           !------------------------------------------
+           lldebug = .FALSE. ; IF ( jsec==nn_secdebug .OR. nn_secdebug==-1 ) lldebug = .TRUE.
+           IF( iptloc .NE. 0 )THEN
+              CALL removepoints(secs(jsec),'I','top_list',lldebug)
+              CALL removepoints(secs(jsec),'I','bot_list',lldebug)
+              CALL removepoints(secs(jsec),'J','top_list',lldebug)
+              CALL removepoints(secs(jsec),'J','bot_list',lldebug)
+           ENDIF
+           IF(jsec==nn_secdebug .AND. secs(jsec)%nb_point .NE. 0)THEN
+              DO jpt = 1,secs(jsec)%nb_point
+                 iiglo = secs(jsec)%listPoint(jpt)%I + nimpp - 1
+                 ijglo = secs(jsec)%listPoint(jpt)%J + njmpp - 1
+              ENDDO
+           ENDIF
+
+           !debug
+           !-----
+           IF( jsec==nn_secdebug .OR. nn_secdebug==-1 )THEN
+              WRITE(numout,*)"      List of points after removepoints:"
+              iptloc = secs(jsec)%nb_point
+              DO jpt = 1,iptloc
+                 iiglo = secs(jsec)%listPoint(jpt)%I + nimpp - 1
+                 ijglo = secs(jsec)%listPoint(jpt)%J + njmpp - 1
+                 WRITE(numout,*)'         # I J : ',iiglo,ijglo
+                 CALL FLUSH(numout)
+              ENDDO
+           ENDIF
+
+        ELSE  ! iptglo = 0
+           IF( jsec==nn_secdebug .OR. nn_secdebug==-1 )&
+              WRITE(numout,*)'   No points for this section.'
+        ENDIF
+
+     ENDDO !end of the loop on jsec
+ 
+     nb_sec = jsec-1   !number of section read in the file
+     !
+  END SUBROUTINE readsec
+
+
+  SUBROUTINE removepoints(sec,cdind,cdextr,ld_debug)
+     !!---------------------------------------------------------------------------
+     !!             *** function removepoints
+     !!
+     !!   ** Purpose :: Remove points which are common to 2 procs
+     !!
+     !----------------------------------------------------------------------------
+     !! * arguments
+     TYPE(SECTION),INTENT(INOUT) :: sec
+     CHARACTER(len=1),INTENT(IN) :: cdind   ! = 'I'/'J'
+     CHARACTER(len=8),INTENT(IN) :: cdextr  ! = 'top_list'/'bot_list'
+     LOGICAL,INTENT(IN)          :: ld_debug                     
+
+     !! * Local variables
+     INTEGER :: iextr         ,& !extremity of listpoint that we verify
+                iind          ,& !coord     of listpoint that we verify
+                itest         ,& !indice value of the side of the domain 
+                                 !where points could be redundant
+                isgn          ,& ! isgn= 1 : scan listpoint from start to end
+                                 ! isgn=-1 : scan listpoint from end to start 
+                istart,iend      !first and last points selected in listpoint
+     INTEGER :: jpoint           !loop on list points
+     INTEGER, DIMENSION(nb_point_max)   :: idirec !contains temporary sec%direction
+     INTEGER, DIMENSION(2,nb_point_max) :: icoord !contains temporary sec%listpoint
+     !----------------------------------------------------------------------------
+     !
+     IF( ld_debug )WRITE(numout,*)'      -------------------------'
+     IF( ld_debug )WRITE(numout,*)'      removepoints in listpoint'
+
+     !iextr=extremity of list_point that we verify
+     IF      ( cdextr=='bot_list' )THEN ; iextr=1            ; isgn=1
+     ELSE IF ( cdextr=='top_list' )THEN ; iextr=sec%nb_point ; isgn=-1
+     ELSE    ; CALL ctl_stop("removepoints :Wrong value for cdextr")
+     ENDIF
+ 
+     !which coordinate shall we verify ?
+     IF      ( cdind=='I' )THEN   ; itest=nlei ; iind=1
+     ELSE IF ( cdind=='J' )THEN   ; itest=nlej ; iind=2
+     ELSE    ; CALL ctl_stop("removepoints :Wrong value for cdind") 
+     ENDIF
+
+     IF( ld_debug )THEN
+        WRITE(numout,*)'      case: coord/list extr/domain side'
+        WRITE(numout,*)'      ', cdind,' ',cdextr,' ',itest
+        WRITE(numout,*)'      Actual number of points: ',sec%nb_point
+     ENDIF
+
+     icoord(1,1:nb_point_max) = sec%listPoint%I
+     icoord(2,1:nb_point_max) = sec%listPoint%J
+     idirec                   = sec%direction
+     sec%listPoint            = POINT_SECTION(0,0)
+     sec%direction            = 0
+
+     jpoint=iextr+isgn
+     DO WHILE( jpoint .GE. 1 .AND. jpoint .LE. sec%nb_point )
+         IF( icoord( iind,jpoint-isgn ) == itest .AND. icoord( iind,jpoint ) == itest )THEN ; jpoint=jpoint+isgn
+         ELSE                                                                               ; EXIT
+         ENDIF
+     ENDDO 
+
+     IF( cdextr=='bot_list')THEN ; istart=jpoint-1 ; iend=sec%nb_point
+     ELSE                        ; istart=1        ; iend=jpoint+1
+     ENDIF
+
+     sec%listPoint(1:1+iend-istart)%I = icoord(1,istart:iend)
+     sec%listPoint(1:1+iend-istart)%J = icoord(2,istart:iend)
+     sec%direction(1:1+iend-istart)   = idirec(istart:iend)
+     sec%nb_point                     = iend-istart+1
+     
+     IF( ld_debug )THEN
+        WRITE(numout,*)'      Number of points after removepoints :',sec%nb_point
+        WRITE(numout,*)'      sec%direction after removepoints :',sec%direction(1:sec%nb_point)
+     ENDIF
+      !
+   END SUBROUTINE removepoints
+
+
+   SUBROUTINE transport(sec,ld_debug,jsec)
+     !!-------------------------------------------------------------------------------------------
+     !!                     ***  ROUTINE transport  ***
+     !!
+     !!  Purpose ::  Compute the transport for each point in a section 
+     !! 
+     !!  Method  ::  Loop over each segment, and each vertical level and add the transport 
+     !!              Be aware :           
+     !!              One section is a sum of segments 
+     !!              One segment is defined by 2 consecutive points in sec%listPoint 
+     !!              All points of sec%listPoint are positioned on the F-point of the cell 
+     !! 
+     !!              There are two loops:                  
+     !!              loop on the segment between 2 nodes 
+     !!              loop on the level jk !!
+     !! 
+     !!  Output  ::  Arrays containing the volume,density,heat,salt transports for each i
+     !!              point in a section, summed over each nn_dct. 
+     !!
+     !!-------------------------------------------------------------------------------------------
+     TYPE(SECTION),INTENT(INOUT) :: sec
+     LOGICAL      ,INTENT(IN)    :: ld_debug
+     INTEGER      ,INTENT(IN)    :: jsec        ! numeric identifier of section
+     !
+     INTEGER ::   jk, jseg, jclass,jl, isgnu, isgnv    ! loop on level/segment/classes/ice categories
+     REAL(wp)::   zumid, zvmid, zumid_ice, zvmid_ice   ! U/V ocean & ice velocity on a cell segment 
+     REAL(wp)::   zTnorm                               ! transport of velocity through one cell's sides 
+     REAL(wp)::   ztn, zsn, zrhoi, zrhop, zsshn, zdep  ! temperature/salinity/potential density/ssh/depth at u/v point
+     TYPE(POINT_SECTION) ::   k
+      !!--------------------------------------------------------
+      !
+      IF( ld_debug )WRITE(numout,*)'      Compute transport'
+
+      !---------------------------!
+      !  COMPUTE TRANSPORT        !
+      !---------------------------!
+      IF(sec%nb_point .NE. 0)THEN   
+
+         !----------------------------------------------------------------------------------------------------
+         !Compute sign for velocities:
+         !
+         !convention:
+         !   non horizontal section: direction + is toward left hand of section
+         !       horizontal section: direction + is toward north of section
+         !
+         !
+         !       slopeSection < 0     slopeSection > 0       slopeSection=inf            slopeSection=0
+         !       ----------------      -----------------     ---------------             --------------
+         !
+         !   isgnv=1         direction +      
+         !  ______         _____             ______                                                   
+         !        |           //|            |                  |                         direction +   
+         !        | isgnu=1  // |            |isgnu=1           |isgnu=1                     /|\
+         !        |_______  //         ______|    \\            | ---\                        |
+         !               |             | isgnv=-1  \\ |         | ---/ direction +       ____________
+         !               |             |          __\\|         |                    
+         !               |             |     direction +        |                      isgnv=1                                 
+         !                                                      
+         !----------------------------------------------------------------------------------------------------
+         isgnu = 1
+         IF( sec%slopeSection .GT. 0 ) THEN  ; isgnv = -1 
+         ELSE                                ; isgnv =  1
+         ENDIF
+         IF( sec%slopeSection .GE. 9999. )     isgnv =  1
+
+         IF( ld_debug )write(numout,*)"sec%slopeSection isgnu isgnv ",sec%slopeSection,isgnu,isgnv
+
+         !--------------------------------------!
+         ! LOOP ON THE SEGMENT BETWEEN 2 NODES  !
+         !--------------------------------------!
+         DO jseg=1,MAX(sec%nb_point-1,0)
+              
+            !-------------------------------------------------------------------------------------------
+            ! Select the appropriate coordinate for computing the velocity of the segment
+            !
+            !                      CASE(0)                                    Case (2)
+            !                      -------                                    --------
+            !  listPoint(jseg)                 listPoint(jseg+1)       listPoint(jseg)  F(i,j)      
+            !      F(i,j)----------V(i+1,j)-------F(i+1,j)                               |
+            !                                                                            |
+            !                                                                            |
+            !                                                                            |
+            !                      Case (3)                                            U(i,j)
+            !                      --------                                              |
+            !                                                                            |
+            !  listPoint(jseg+1) F(i,j+1)                                                |
+            !                        |                                                   |
+            !                        |                                                   |
+            !                        |                                 listPoint(jseg+1) F(i,j-1)
+            !                        |                                            
+            !                        |                                            
+            !                     U(i,j+1)                                            
+            !                        |                                       Case(1)     
+            !                        |                                       ------      
+            !                        |                                            
+            !                        |                 listPoint(jseg+1)             listPoint(jseg)                           
+            !                        |                 F(i-1,j)-----------V(i,j) -------f(jseg)                           
+            ! listPoint(jseg)     F(i,j)
+            ! 
+            !-------------------------------------------------------------------------------------------
+
+            SELECT CASE( sec%direction(jseg) )
+            CASE(0)   ;    k = sec%listPoint(jseg)
+            CASE(1)   ;    k = POINT_SECTION(sec%listPoint(jseg)%I+1,sec%listPoint(jseg)%J)
+            CASE(2)   ;    k = sec%listPoint(jseg)
+            CASE(3)   ;    k = POINT_SECTION(sec%listPoint(jseg)%I,sec%listPoint(jseg)%J+1)
+            END SELECT
+
+            !---------------------------| 
+            !     LOOP ON THE LEVEL     | 
+            !---------------------------| 
+            DO jk = 1, mbkt(k%I,k%J)            !Sum of the transport on the vertical
+            !           ! compute temperature, salinity, insitu & potential density, ssh and depth at U/V point 
+            SELECT CASE( sec%direction(jseg) )
+               CASE(0,1) 
+                  ztn   = interp(k%I,k%J,jk,'V',tsn(:,:,:,jp_tem) ) 
+                  zsn   = interp(k%I,k%J,jk,'V',tsn(:,:,:,jp_sal) ) 
+                  zrhop = interp(k%I,k%J,jk,'V',rhop) 
+                  zrhoi = interp(k%I,k%J,jk,'V',rhd*rau0+rau0) 
+                  zsshn =  0.5*( sshn(k%I,k%J) + sshn(k%I,k%J+1)    ) * vmask(k%I,k%J,1) 
+               CASE(2,3) 
+                  ztn   = interp(k%I,k%J,jk,'U',tsn(:,:,:,jp_tem) ) 
+                  zsn   = interp(k%I,k%J,jk,'U',tsn(:,:,:,jp_sal) ) 
+                  zrhop = interp(k%I,k%J,jk,'U',rhop) 
+                  zrhoi = interp(k%I,k%J,jk,'U',rhd*rau0+rau0) 
+                  zsshn =  0.5*( sshn(k%I,k%J) + sshn(k%I+1,k%J)    ) * umask(k%I,k%J,1)  
+               END SELECT 
+               !
+               zdep= gdept_n(k%I,k%J,jk) 
+  
+               SELECT CASE( sec%direction(jseg) )                !compute velocity with the correct direction 
+               CASE(0,1)   
+                  zumid=0._wp
+                  zvmid=isgnv*vn(k%I,k%J,jk)*vmask(k%I,k%J,jk) 
+               CASE(2,3) 
+                  zumid=isgnu*un(k%I,k%J,jk)*umask(k%I,k%J,jk) 
+                  zvmid=0._wp
+               END SELECT 
+ 
+               !zTnorm=transport through one cell; 
+               !velocity* cell's length * cell's thickness 
+               zTnorm = zumid*e2u(k%I,k%J) * e3u_n(k%I,k%J,jk)     & 
+                  &   + zvmid*e1v(k%I,k%J) * e3v_n(k%I,k%J,jk) 
+
+!!gm  THIS is WRONG  no transport due to ssh in linear free surface case !!!!!
+               IF( ln_linssh ) THEN              !add transport due to free surface 
+                  IF( jk==1 ) THEN 
+                     zTnorm = zTnorm + zumid* e2u(k%I,k%J) * zsshn * umask(k%I,k%J,jk)   & 
+                        &            + zvmid* e1v(k%I,k%J) * zsshn * vmask(k%I,k%J,jk) 
+                  ENDIF 
+               ENDIF
+!!gm end
+              !COMPUTE TRANSPORT  
+ 
+              transports_3d(1,jsec,jseg,jk) = transports_3d(1,jsec,jseg,jk) + zTnorm 
+  
+              IF( sec%llstrpond ) THEN 
+                 transports_3d(2,jsec,jseg,jk) = transports_3d(2,jsec,jseg,jk)  + zTnorm * ztn * zrhop * rcp
+                 transports_3d(3,jsec,jseg,jk) = transports_3d(3,jsec,jseg,jk)  + zTnorm * zsn * zrhop * 0.001
+              ENDIF
+   
+           END DO !end of loop on the level
+
+#if defined key_si3
+
+           !ICE CASE    
+           !------------
+           IF( sec%ll_ice_section )THEN
+              SELECT CASE (sec%direction(jseg))
+              CASE(0)
+                 zumid_ice = 0
+                 zvmid_ice =  isgnv*0.5*(v_ice(k%I,k%J+1)+v_ice(k%I+1,k%J+1))
+              CASE(1)
+                 zumid_ice = 0
+                 zvmid_ice =  isgnv*0.5*(v_ice(k%I,k%J+1)+v_ice(k%I+1,k%J+1))
+              CASE(2)
+                 zvmid_ice = 0
+                 zumid_ice =  isgnu*0.5*(u_ice(k%I+1,k%J)+u_ice(k%I+1,k%J+1))
+              CASE(3)
+                 zvmid_ice = 0
+                 zumid_ice =  isgnu*0.5*(u_ice(k%I+1,k%J)+u_ice(k%I+1,k%J+1))
+              END SELECT
+   
+              zTnorm=zumid_ice*e2u(k%I,k%J)+zvmid_ice*e1v(k%I,k%J)
+
+#if defined key_si3
+              DO jl=1,jpl
+                 transports_2d(1,jsec,jseg) = transports_2d(1,jsec,jseg) + (zTnorm)*       &
+                                    a_i(sec%listPoint(jseg)%I,sec%listPoint(jseg)%J,jl) *  &
+                                  ( h_i(sec%listPoint(jseg)%I,sec%listPoint(jseg)%J,jl) +  &
+                                    h_s(sec%listPoint(jseg)%I,sec%listPoint(jseg)%J,jl) )
+                                   
+                 transports_2d(2,jsec,jseg) = transports_2d(2,jsec,jseg) + (zTnorm)*   &
+                                    a_i(sec%listPoint(jseg)%I,sec%listPoint(jseg)%J,jl)
+              END DO
+#endif
+   
+           ENDIF !end of ice case
+#endif
+ 
+        END DO !end of loop on the segment
+
+     ENDIF !end of sec%nb_point =0 case
+     !
+  END SUBROUTINE transport
+
+
+  SUBROUTINE dia_dct_sum(sec,jsec) 
+     !!------------------------------------------------------------- 
+     !! Purpose: Average the transport over nn_dctwri time steps  
+     !! and sum over the density/salinity/temperature/depth classes 
+     !! 
+     !! Method:   Sum over relevant grid cells to obtain values  
+     !!           for each class
+     !!              There are several loops:                  
+     !!              loop on the segment between 2 nodes 
+     !!              loop on the level jk 
+     !!              loop on the density/temperature/salinity/level classes 
+     !!              test on the density/temperature/salinity/level 
+     !! 
+     !!  Note:    Transport through a given section is equal to the sum of transports 
+     !!           computed on each proc. 
+     !!           On each proc,transport is equal to the sum of transport computed through 
+     !!           segments linking each point of sec%listPoint  with the next one.    
+     !! 
+     !!------------------------------------------------------------- 
+     TYPE(SECTION),INTENT(INOUT) :: sec 
+     INTEGER      ,INTENT(IN)    :: jsec        ! numeric identifier of section 
+ 
+     TYPE(POINT_SECTION) :: k 
+     INTEGER  :: jk,jseg,jclass                        ! dummy variables for looping on level/segment/classes  
+     REAL(wp) :: ztn, zsn, zrhoi, zrhop, zsshn, zdep ! temperature/salinity/ssh/potential density /depth at u/v point 
+     !!------------------------------------------------------------- 
+ 
+     !! Sum the relevant segments to obtain values for each class 
+     IF(sec%nb_point .NE. 0)THEN    
+ 
+        !--------------------------------------! 
+        ! LOOP ON THE SEGMENT BETWEEN 2 NODES  ! 
+        !--------------------------------------! 
+        DO jseg=1,MAX(sec%nb_point-1,0) 
+            
+           !------------------------------------------------------------------------------------------- 
+           ! Select the appropriate coordinate for computing the velocity of the segment 
+           ! 
+           !                      CASE(0)                                    Case (2) 
+           !                      -------                                    -------- 
+           !  listPoint(jseg)                 listPoint(jseg+1)       listPoint(jseg)  F(i,j)       
+           !      F(i,j)----------V(i+1,j)-------F(i+1,j)                               | 
+           !                                                                            | 
+           !                                                                            | 
+           !                                                                            | 
+           !                      Case (3)                                            U(i,j) 
+           !                      --------                                              | 
+           !                                                                            | 
+           !  listPoint(jseg+1) F(i,j+1)                                                | 
+           !                        |                                                   | 
+           !                        |                                                   | 
+           !                        |                                 listPoint(jseg+1) F(i,j-1) 
+           !                        |                                             
+           !                        |                                             
+           !                     U(i,j+1)                                             
+           !                        |                                       Case(1)      
+           !                        |                                       ------       
+           !                        |                                             
+           !                        |                 listPoint(jseg+1)             listPoint(jseg)                            
+           !                        |                 F(i-1,j)-----------V(i,j) -------f(jseg)                            
+           ! listPoint(jseg)     F(i,j) 
+           !  
+           !------------------------------------------------------------------------------------------- 
+ 
+           SELECT CASE( sec%direction(jseg) ) 
+           CASE(0)  ;   k = sec%listPoint(jseg) 
+           CASE(1)  ;   k = POINT_SECTION(sec%listPoint(jseg)%I+1,sec%listPoint(jseg)%J) 
+           CASE(2)  ;   k = sec%listPoint(jseg) 
+           CASE(3)  ;   k = POINT_SECTION(sec%listPoint(jseg)%I,sec%listPoint(jseg)%J+1) 
+           END SELECT 
+ 
+           !---------------------------| 
+           !     LOOP ON THE LEVEL     | 
+           !---------------------------| 
+           !Sum of the transport on the vertical  
+           DO jk=1,mbkt(k%I,k%J) 
+ 
+              ! compute temperature, salinity, insitu & potential density, ssh and depth at U/V point 
+              SELECT CASE( sec%direction(jseg) ) 
+              CASE(0,1) 
+                 ztn   = interp(k%I,k%J,jk,'V',tsn(:,:,:,jp_tem) ) 
+                 zsn   = interp(k%I,k%J,jk,'V',tsn(:,:,:,jp_sal) ) 
+                 zrhop = interp(k%I,k%J,jk,'V',rhop) 
+                 zrhoi = interp(k%I,k%J,jk,'V',rhd*rau0+rau0) 
+
+              CASE(2,3) 
+                 ztn   = interp(k%I,k%J,jk,'U',tsn(:,:,:,jp_tem) ) 
+                 zsn   = interp(k%I,k%J,jk,'U',tsn(:,:,:,jp_sal) ) 
+                 zrhop = interp(k%I,k%J,jk,'U',rhop) 
+                 zrhoi = interp(k%I,k%J,jk,'U',rhd*rau0+rau0) 
+                 zsshn =  0.5*( sshn(k%I,k%J)    + sshn(k%I+1,k%J)    ) * umask(k%I,k%J,1)  
+              END SELECT 
+ 
+              zdep= gdept_n(k%I,k%J,jk) 
+  
+              !------------------------------- 
+              !  LOOP ON THE DENSITY CLASSES | 
+              !------------------------------- 
+              !The computation is made for each density/temperature/salinity/depth class 
+              DO jclass=1,MAX(1,sec%nb_class-1) 
+ 
+                 !----------------------------------------------! 
+                 !TEST ON THE DENSITY/SALINITY/TEMPERATURE/LEVEL!  
+                 !----------------------------------------------! 
+
+                 IF ( (                                                    & 
+                    ((( zrhop .GE. (sec%zsigp(jclass)+1000.  )) .AND.      & 
+                    (   zrhop .LE. (sec%zsigp(jclass+1)+1000. ))) .OR.     & 
+                    ( sec%zsigp(jclass) .EQ. 99.)) .AND.                   & 
+ 
+                    ((( zrhoi .GE. (sec%zsigi(jclass) + 1000.  )) .AND.    & 
+                    (   zrhoi .LE. (sec%zsigi(jclass+1)+1000. ))) .OR.     & 
+                    ( sec%zsigi(jclass) .EQ. 99.)) .AND.                   & 
+ 
+                    ((( zsn .GT. sec%zsal(jclass)) .AND.                   & 
+                    (   zsn .LE. sec%zsal(jclass+1))) .OR.                 & 
+                    ( sec%zsal(jclass) .EQ. 99.)) .AND.                    & 
+ 
+                    ((( ztn .GE. sec%ztem(jclass)) .AND.                   & 
+                    (   ztn .LE. sec%ztem(jclass+1))) .OR.                 & 
+                    ( sec%ztem(jclass) .EQ.99.)) .AND.                     & 
+ 
+                    ((( zdep .GE. sec%zlay(jclass)) .AND.                & 
+                    (   zdep .LE. sec%zlay(jclass+1))) .OR.              & 
+                    ( sec%zlay(jclass) .EQ. 99. ))                         & 
+                                                                   ))   THEN 
+ 
+                    !SUM THE TRANSPORTS FOR EACH CLASSES FOR THE POSITIVE AND NEGATIVE DIRECTIONS 
+                    !---------------------------------------------------------------------------- 
+                    IF (transports_3d(1,jsec,jseg,jk) .GE. 0.0) THEN  
+                       sec%transport(1,jclass) = sec%transport(1,jclass)+transports_3d(1,jsec,jseg,jk)*1.E-6 
+                    ELSE 
+                       sec%transport(2,jclass) = sec%transport(2,jclass)+transports_3d(1,jsec,jseg,jk)*1.E-6 
+                    ENDIF 
+                    IF( sec%llstrpond )THEN 
+ 
+                       IF ( transports_3d(2,jsec,jseg,jk) .GE. 0.0 ) THEN 
+                          sec%transport(3,jclass) = sec%transport(3,jclass)+transports_3d(2,jsec,jseg,jk) 
+                       ELSE 
+                          sec%transport(4,jclass) = sec%transport(4,jclass)+transports_3d(2,jsec,jseg,jk) 
+                       ENDIF 
+ 
+                       IF ( transports_3d(3,jsec,jseg,jk) .GE. 0.0 ) THEN 
+                          sec%transport(5,jclass) = sec%transport(5,jclass)+transports_3d(3,jsec,jseg,jk) 
+                       ELSE 
+                          sec%transport(6,jclass) = sec%transport(6,jclass)+transports_3d(3,jsec,jseg,jk) 
+                       ENDIF 
+ 
+                    ELSE 
+                       sec%transport( 3,jclass) = 0._wp 
+                       sec%transport( 4,jclass) = 0._wp 
+                       sec%transport( 5,jclass) = 0._wp 
+                       sec%transport( 6,jclass) = 0._wp 
+                    ENDIF 
+ 
+                 ENDIF ! end of test if point is in class 
+    
+              END DO ! end of loop on the classes 
+ 
+           END DO ! loop over jk 
+ 
+#if defined key_si3 
+ 
+           !ICE CASE     
+           IF( sec%ll_ice_section )THEN 
+ 
+              IF ( transports_2d(1,jsec,jseg) .GE. 0.0 ) THEN 
+                 sec%transport( 7,1) = sec%transport( 7,1)+transports_2d(1,jsec,jseg)*1.E-6 
+              ELSE 
+                 sec%transport( 8,1) = sec%transport( 8,1)+transports_2d(1,jsec,jseg)*1.E-6 
+              ENDIF 
+ 
+              IF ( transports_2d(3,jsec,jseg) .GE. 0.0 ) THEN 
+                 sec%transport( 9,1) = sec%transport( 9,1)+transports_2d(2,jsec,jseg)*1.E-6 
+              ELSE 
+                 sec%transport(10,1) = sec%transport(10,1)+transports_2d(2,jsec,jseg)*1.E-6 
+              ENDIF 
+ 
+           ENDIF !end of ice case 
+#endif 
+  
+        END DO !end of loop on the segment 
+ 
+     ELSE  !if sec%nb_point =0 
+        sec%transport(1:2,:)=0. 
+        IF (sec%llstrpond) sec%transport(3:6,:)=0. 
+        IF (sec%ll_ice_section) sec%transport(7:10,:)=0. 
+     ENDIF !end of sec%nb_point =0 case 
+ 
+  END SUBROUTINE dia_dct_sum 
+
+
+  SUBROUTINE dia_dct_wri(kt,ksec,sec)
+     !!-------------------------------------------------------------
+     !! Write transport output in numdct 
+     !! 
+     !! Purpose: Write  transports in ascii files
+     !! 
+     !! Method:
+     !!        1. Write volume transports in "volume_transport"
+     !!           Unit: Sv : area * Velocity / 1.e6 
+     !! 
+     !!        2. Write heat transports in "heat_transport"
+     !!           Unit: Peta W : area * Velocity * T * rhop * Cp * 1.e-15
+     !! 
+     !!        3. Write salt transports in "salt_transport"
+     !!           Unit: 10^9 Kg/m^2/s : area * Velocity * S * rhop * 1.e-9 
+     !!
+     !!------------------------------------------------------------- 
+     !!arguments
+     INTEGER, INTENT(IN)          :: kt          ! time-step
+     TYPE(SECTION), INTENT(INOUT) :: sec         ! section to write   
+     INTEGER ,INTENT(IN)          :: ksec        ! section number
+
+     !!local declarations
+     INTEGER               :: jclass             ! Dummy loop
+     CHARACTER(len=2)      :: classe             ! Classname 
+     REAL(wp)              :: zbnd1,zbnd2        ! Class bounds
+     REAL(wp)              :: zslope             ! section's slope coeff
+     !
+     REAL(wp), DIMENSION(nb_type_class)::   zsumclasses   ! 1D workspace 
+     !!------------------------------------------------------------- 
+
+     zsumclasses(:)=0._wp
+     zslope = sec%slopeSection       
+
+ 
+     DO jclass=1,MAX(1,sec%nb_class-1)
+
+        classe   = 'N       '
+        zbnd1   = 0._wp
+        zbnd2   = 0._wp
+        zsumclasses(1:nb_type_class)=zsumclasses(1:nb_type_class)+sec%transport(1:nb_type_class,jclass)
+
+   
+        !insitu density classes transports
+        IF( ( sec%zsigi(jclass)   .NE. 99._wp ) .AND. &
+            ( sec%zsigi(jclass+1) .NE. 99._wp )       )THEN
+           classe = 'DI       '
+           zbnd1 = sec%zsigi(jclass)
+           zbnd2 = sec%zsigi(jclass+1)
+        ENDIF
+        !potential density classes transports
+        IF( ( sec%zsigp(jclass)   .NE. 99._wp ) .AND. &
+            ( sec%zsigp(jclass+1) .NE. 99._wp )       )THEN
+           classe = 'DP      '
+           zbnd1 = sec%zsigp(jclass)
+           zbnd2 = sec%zsigp(jclass+1)
+        ENDIF
+        !depth classes transports
+        IF( ( sec%zlay(jclass)    .NE. 99._wp ) .AND. &
+            ( sec%zlay(jclass+1)  .NE. 99._wp )       )THEN 
+           classe = 'Z       '
+           zbnd1 = sec%zlay(jclass)
+           zbnd2 = sec%zlay(jclass+1)
+        ENDIF
+        !salinity classes transports
+        IF( ( sec%zsal(jclass) .NE. 99._wp    ) .AND. &
+            ( sec%zsal(jclass+1) .NE. 99._wp  )       )THEN
+           classe = 'S       '
+           zbnd1 = sec%zsal(jclass)
+           zbnd2 = sec%zsal(jclass+1)   
+        ENDIF
+        !temperature classes transports
+        IF( ( sec%ztem(jclass) .NE. 99._wp     ) .AND. &
+            ( sec%ztem(jclass+1) .NE. 99._wp     )       ) THEN
+           classe = 'T       '
+           zbnd1 = sec%ztem(jclass)
+           zbnd2 = sec%ztem(jclass+1)
+        ENDIF
+                  
+        !write volume transport per class
+        WRITE(numdct_vol,118) ndastp,kt,ksec,sec%name,zslope, &
+                              jclass,classe,zbnd1,zbnd2,&
+                              sec%transport(1,jclass),sec%transport(2,jclass), &
+                              sec%transport(1,jclass)+sec%transport(2,jclass)
+
+        IF( sec%llstrpond )THEN
+
+           !write heat transport per class:
+           WRITE(numdct_heat,119) ndastp,kt,ksec,sec%name,zslope,  &
+                              jclass,classe,zbnd1,zbnd2,&
+                              sec%transport(3,jclass)*1.e-15,sec%transport(4,jclass)*1.e-15, &
+                              ( sec%transport(3,jclass)+sec%transport(4,jclass) )*1.e-15
+           !write salt transport per class
+           WRITE(numdct_salt,119) ndastp,kt,ksec,sec%name,zslope,  &
+                              jclass,classe,zbnd1,zbnd2,&
+                              sec%transport(5,jclass)*1.e-9,sec%transport(6,jclass)*1.e-9,&
+                              (sec%transport(5,jclass)+sec%transport(6,jclass))*1.e-9
+        ENDIF
+
+     ENDDO
+
+     zbnd1 = 0._wp
+     zbnd2 = 0._wp
+     jclass=0
+
+     !write total volume transport
+     WRITE(numdct_vol,118) ndastp,kt,ksec,sec%name,zslope, &
+                           jclass,"total",zbnd1,zbnd2,&
+                           zsumclasses(1),zsumclasses(2),zsumclasses(1)+zsumclasses(2)
+
+     IF( sec%llstrpond )THEN
+
+        !write total heat transport
+        WRITE(numdct_heat,119) ndastp,kt,ksec,sec%name,zslope, &
+                           jclass,"total",zbnd1,zbnd2,&
+                           zsumclasses(3)*1.e-15,zsumclasses(4)*1.e-15,&
+                           (zsumclasses(3)+zsumclasses(4) )*1.e-15
+        !write total salt transport
+        WRITE(numdct_salt,119) ndastp,kt,ksec,sec%name,zslope, &
+                           jclass,"total",zbnd1,zbnd2,&
+                           zsumclasses(5)*1.e-9,zsumclasses(6)*1.e-9,&
+                           (zsumclasses(5)+zsumclasses(6))*1.e-9
+     ENDIF
+
+      
+     IF ( sec%ll_ice_section) THEN
+        !write total ice volume transport
+        WRITE(numdct_vol,118) ndastp,kt,ksec,sec%name,zslope,&
+                              jclass,"ice_vol",zbnd1,zbnd2,&
+                              sec%transport(7,1),sec%transport(8,1),&
+                              sec%transport(7,1)+sec%transport(8,1)
+        !write total ice surface transport
+        WRITE(numdct_vol,118) ndastp,kt,ksec,sec%name,zslope,&
+                              jclass,"ice_surf",zbnd1,zbnd2,&
+                              sec%transport(9,1),sec%transport(10,1), &
+                              sec%transport(9,1)+sec%transport(10,1) 
+      ENDIF
+                                              
+118   FORMAT(I8,1X,I8,1X,I4,1X,A30,1X,f9.2,1X,I4,3X,A8,1X,2F12.4,5X,3F12.4)
+119   FORMAT(I8,1X,I8,1X,I4,1X,A30,1X,f9.2,1X,I4,3X,A8,1X,2F12.4,5X,3E15.6)
+      !
+   END SUBROUTINE dia_dct_wri
+
+
+   FUNCTION interp(ki, kj, kk, cd_point, ptab)
+  !!----------------------------------------------------------------------
+  !!
+  !!   Purpose: compute temperature/salinity/density at U-point or V-point
+  !!   --------
+  !!
+  !!   Method:
+  !!   ------
+  !!
+  !!   ====> full step and partial step
+  !! 
+  !!
+  !!    |    I          |    I+1           |    Z=temperature/salinity/density at U-poinT
+  !!    |               |                  |
+  !!  ----------------------------------------  1. Veritcal interpolation: compute zbis
+  !!    |               |                  |       interpolation between ptab(I,J,K) and ptab(I,J,K+1)
+  !!    |               |                  |       zbis = 
+  !!    |               |                  |      [ e3w(I+1,J,K)*ptab(I,J,K) + ( e3w(I,J,K) - e3w(I+1,J,K) ) * ptab(I,J,K-1) ]
+  !!    |               |                  |      /[ e3w(I+1,J,K) + e3w(I,J,K) - e3w(I+1,J,K) ] 
+  !!    |               |                  | 
+  !!    |               |                  |    2. Horizontal interpolation: compute value at U/V point
+  !!K-1 | ptab(I,J,K-1) |                  |       interpolation between zbis and ptab(I+1,J,K)  
+  !!    |     .         |                  |
+  !!    |     .         |                  |       interp = ( 0.5*zet2*zbis + 0.5*zet1*ptab(I+1,J,K) )/(0.5*zet2+0.5*zet1) 
+  !!    |     .         |                  |
+  !!  ------------------------------------------
+  !!    |     .         |                  |
+  !!    |     .         |                  |
+  !!    |     .         |                  |
+  !!K   |    zbis.......U...ptab(I+1,J,K)  |
+  !!    |     .         |                  |
+  !!    | ptab(I,J,K)   |                  |
+  !!    |               |------------------|
+  !!    |               | partials         |
+  !!    |               |  steps           |
+  !!  -------------------------------------------
+  !!    <----zet1------><----zet2--------->
+  !!
+  !!
+  !!   ====>  s-coordinate
+  !!     
+  !!    |                |                  |   1. Compute distance between T1 and U points: SQRT( zdep1^2 + (0.5 * zet1 )^2
+  !!    |                |                  |      Compute distance between T2 and U points: SQRT( zdep2^2 + (0.5 * zet2 )^2
+  !!    |                | ptab(I+1,J,K)    | 
+  !!    |                |      T2          |   2. Interpolation between  T1 and T2 values at U point 
+  !!    |                |      ^           |    
+  !!    |                |      | zdep2     |    
+  !!    |                |      |           |    
+  !!    |       ^        U      v           |
+  !!    |       |        |                  |
+  !!    |       | zdep1  |                  |    
+  !!    |       v        |                  |
+  !!    |      T1        |                  |
+  !!    | ptab(I,J,K)    |                  | 
+  !!    |                |                  | 
+  !!    |                |                  | 
+  !!
+  !!    <----zet1--------><----zet2--------->
+  !!
+  !!----------------------------------------------------------------------
+  !*arguments
+  INTEGER, INTENT(IN)                          :: ki, kj, kk   ! coordinate of point
+  CHARACTER(len=1), INTENT(IN)                 :: cd_point     ! type of point (U, V)
+  REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(IN) :: ptab         ! variable to compute at (ki, kj, kk )
+  REAL(wp)                                     :: interp       ! interpolated variable 
+
+  !*local declations
+  INTEGER :: ii1, ij1, ii2, ij2                                ! local integer
+  REAL(wp):: ze3t, ze3, zwgt1, zwgt2, zbis, zdepu            ! local real
+  REAL(wp):: zet1, zet2                                        ! weight for interpolation 
+  REAL(wp):: zdep1,zdep2                                       ! differences of depth
+  REAL(wp):: zmsk                                              ! mask value
+  !!----------------------------------------------------------------------
+
+  IF( cd_point=='U' )THEN 
+     ii1 = ki    ; ij1 = kj 
+     ii2 = ki+1  ; ij2 = kj 
+
+     zet1=e1t(ii1,ij1)
+     zet2=e1t(ii2,ij2)
+     zmsk=umask(ii1,ij1,kk)
+  
+
+  ELSE ! cd_point=='V' 
+     ii1 = ki    ; ij1 = kj 
+     ii2 = ki    ; ij2 = kj+1  
+
+     zet1=e2t(ii1,ij1)
+     zet2=e2t(ii2,ij2)
+     zmsk=vmask(ii1,ij1,kk)
+
+  ENDIF
+
+  IF( ln_sco )THEN   ! s-coordinate case
+
+     zdepu = ( gdept_n(ii1,ij1,kk) +  gdept_n(ii2,ij2,kk) ) * 0.5_wp 
+     zdep1 = gdept_n(ii1,ij1,kk) - zdepu
+     zdep2 = gdept_n(ii2,ij2,kk) - zdepu
+
+     ! weights
+     zwgt1 = SQRT( ( 0.5 * zet1 ) * ( 0.5 * zet1 ) + ( zdep1 * zdep1 ) )
+     zwgt2 = SQRT( ( 0.5 * zet2 ) * ( 0.5 * zet2 ) + ( zdep2 * zdep2 ) )
+  
+     ! result
+     interp = zmsk * ( zwgt2 *  ptab(ii1,ij1,kk) + zwgt1 *  ptab(ii1,ij1,kk) ) / ( zwgt2 + zwgt1 )   
+
+
+  ELSE       ! full step or partial step case 
+
+     ze3t  = e3t_n(ii2,ij2,kk) - e3t_n(ii1,ij1,kk) 
+     zwgt1 = ( e3w_n(ii2,ij2,kk) - e3w_n(ii1,ij1,kk) ) / e3w_n(ii2,ij2,kk)
+     zwgt2 = ( e3w_n(ii1,ij1,kk) - e3w_n(ii2,ij2,kk) ) / e3w_n(ii1,ij1,kk)
+
+     IF(kk .NE. 1)THEN
+
+        IF( ze3t >= 0. )THEN 
+           ! zbis
+           zbis = ptab(ii2,ij2,kk) + zwgt1 * ( ptab(ii2,ij2,kk-1) - ptab(ii2,ij2,kk) ) 
+           ! result
+            interp = zmsk * ( zet2 * ptab(ii1,ij1,kk) + zet1 * zbis )/( zet1 + zet2 )
+        ELSE
+           ! zbis
+           zbis = ptab(ii1,ij1,kk) + zwgt2 * ( ptab(ii1,ij1,kk-1) - ptab(ii1,ij2,kk) )
+           ! result
+           interp = zmsk * ( zet2 * zbis + zet1 * ptab(ii2,ij2,kk) )/( zet1 + zet2 )
+        ENDIF    
+
+     ELSE
+        interp = zmsk * (  zet2 * ptab(ii1,ij1,kk) + zet1 * ptab(ii2,ij2,kk) )/( zet1 + zet2 )
+     ENDIF
+
+  ENDIF
+      !
+   END FUNCTION interp
+
+#else
+   !!----------------------------------------------------------------------
+   !!   Default option :                                       Dummy module
+   !!----------------------------------------------------------------------
+   LOGICAL, PUBLIC, PARAMETER ::   lk_diadct = .FALSE.    !: diamht flag
+   PUBLIC 
+   !! $Id$
+CONTAINS
+
+   SUBROUTINE dia_dct_init          ! Dummy routine
+      WRITE(*,*) 'dia_dct_init: You should not have seen this print! error?', kt
+   END SUBROUTINE dia_dct_init
+
+   SUBROUTINE dia_dct( kt )         ! Dummy routine
+      INTEGER, INTENT( in ) :: kt   ! ocean time-step index
+      WRITE(*,*) 'dia_dct: You should not have seen this print! error?', kt
+   END SUBROUTINE dia_dct
+#endif
+
+   !!======================================================================
+END MODULE diadct
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DIA/diaharm.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DIA/diaharm.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DIA/diaharm.F90	(revision 9570)
@@ -0,0 +1,529 @@
+MODULE diaharm 
+   !!======================================================================
+   !!                       ***  MODULE  diaharm  ***
+   !! Harmonic analysis of tidal constituents 
+   !!======================================================================
+   !! History :  3.1  !  2007  (O. Le Galloudec, J. Chanut)  Original code
+   !!----------------------------------------------------------------------
+#if defined key_diaharm
+   !!----------------------------------------------------------------------
+   !!   'key_diaharm'
+   !!----------------------------------------------------------------------
+   USE oce             ! ocean dynamics and tracers variables
+   USE dom_oce         ! ocean space and time domain
+   USE phycst
+   USE daymod
+   USE tide_mod
+   USE sbctide         ! Tidal forcing or not
+   !
+   USE in_out_manager  ! I/O units
+   USE iom             ! I/0 library
+   USE ioipsl          ! NetCDF IPSL library
+   USE lbclnk          ! ocean lateral boundary conditions (or mpp link)
+   USE timing          ! preformance summary
+
+   IMPLICIT NONE
+   PRIVATE
+
+   LOGICAL, PUBLIC, PARAMETER :: lk_diaharm  = .TRUE.
+   
+   INTEGER, PARAMETER :: jpincomax    = 2.*jpmax_harmo
+   INTEGER, PARAMETER :: jpdimsparse  = jpincomax*300*24
+
+   !                         !!** namelist variables **
+   INTEGER ::   nit000_han    ! First time step used for harmonic analysis
+   INTEGER ::   nitend_han    ! Last time step used for harmonic analysis
+   INTEGER ::   nstep_han     ! Time step frequency for harmonic analysis
+   INTEGER ::   nb_ana        ! Number of harmonics to analyse
+
+   INTEGER , ALLOCATABLE, DIMENSION(:)       ::   name
+   REAL(wp), ALLOCATABLE, DIMENSION(:,:,:,:) ::   ana_temp
+   REAL(wp), ALLOCATABLE, DIMENSION(:)       ::   ana_freq, ut   , vt   , ft
+   REAL(wp), ALLOCATABLE, DIMENSION(:,:,:)   ::   out_eta , out_u, out_v
+
+   INTEGER ::   ninco, nsparse
+   INTEGER ,       DIMENSION(jpdimsparse)         ::   njsparse, nisparse
+   INTEGER , SAVE, DIMENSION(jpincomax)           ::   ipos1
+   REAL(wp),       DIMENSION(jpdimsparse)         ::   valuesparse
+   REAL(wp),       DIMENSION(jpincomax)           ::   ztmp4 , ztmp7
+   REAL(wp), SAVE, DIMENSION(jpincomax,jpincomax) ::   ztmp3 , zpilier
+   REAL(wp), SAVE, DIMENSION(jpincomax)           ::   zpivot
+
+   CHARACTER (LEN=4), DIMENSION(jpmax_harmo) ::   tname   ! Names of tidal constituents ('M2', 'K1',...)
+
+   PUBLIC   dia_harm   ! routine called by step.F90
+
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.5 , NEMO Consortium (2013)
+   !! $Id$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE dia_harm_init 
+      !!----------------------------------------------------------------------
+      !!                 ***  ROUTINE dia_harm_init  ***
+      !!         
+      !! ** Purpose :   Initialization of tidal harmonic analysis
+      !!
+      !! ** Method  :   Initialize frequency array and  nodal factor for nit000_han
+      !!
+      !!--------------------------------------------------------------------
+      INTEGER :: jh, nhan, jk, ji
+      INTEGER ::   ios                 ! Local integer output status for namelist read
+
+      NAMELIST/nam_diaharm/ nit000_han, nitend_han, nstep_han, tname
+      !!----------------------------------------------------------------------
+
+      IF(lwp) THEN
+         WRITE(numout,*)
+         WRITE(numout,*) 'dia_harm_init: Tidal harmonic analysis initialization'
+         WRITE(numout,*) '~~~~~~~ '
+      ENDIF
+      !
+      IF( .NOT. ln_tide )   CALL ctl_stop( 'dia_harm_init : ln_tide must be true for harmonic analysis')
+      !
+      CALL tide_init_Wave
+      !
+      REWIND( numnam_ref )              ! Namelist nam_diaharm in reference namelist : Tidal harmonic analysis
+      READ  ( numnam_ref, nam_diaharm, IOSTAT = ios, ERR = 901)
+901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'nam_diaharm in reference namelist', lwp )
+      REWIND( numnam_cfg )              ! Namelist nam_diaharm in configuration namelist : Tidal harmonic analysis
+      READ  ( numnam_cfg, nam_diaharm, IOSTAT = ios, ERR = 902 )
+902   IF( ios >  0 )   CALL ctl_nam ( ios , 'nam_diaharm in configuration namelist', lwp )
+      IF(lwm) WRITE ( numond, nam_diaharm )
+      !
+      IF(lwp) THEN
+         WRITE(numout,*) 'First time step used for analysis:  nit000_han= ', nit000_han
+         WRITE(numout,*) 'Last  time step used for analysis:  nitend_han= ', nitend_han
+         WRITE(numout,*) 'Time step frequency for harmonic analysis:  nstep_han= ', nstep_han
+      ENDIF
+
+      ! Basic checks on harmonic analysis time window:
+      ! ----------------------------------------------
+      IF( nit000 > nit000_han )   CALL ctl_stop( 'dia_harm_init : nit000_han must be greater than nit000',   &
+         &                                       ' restart capability not implemented' )
+      IF( nitend < nitend_han )   CALL ctl_stop( 'dia_harm_init : nitend_han must be lower than nitend',   &
+         &                                       'restart capability not implemented' )
+
+      IF( MOD( nitend_han-nit000_han+1 , nstep_han ) /= 0 )   &
+         &                        CALL ctl_stop( 'dia_harm_init : analysis time span must be a multiple of nstep_han' )
+
+      nb_ana = 0
+      DO jk=1,jpmax_harmo
+         DO ji=1,jpmax_harmo
+            IF(TRIM(tname(jk)) == Wave(ji)%cname_tide) THEN
+               nb_ana=nb_ana+1
+            ENDIF
+         END DO
+      END DO
+      !
+      IF(lwp) THEN
+         WRITE(numout,*) '        Namelist nam_diaharm'
+         WRITE(numout,*) '        nb_ana    = ', nb_ana
+         CALL flush(numout)
+      ENDIF
+      !
+      IF (nb_ana > jpmax_harmo) THEN
+        IF(lwp) WRITE(numout,*) ' E R R O R dia_harm_init : nb_ana must be lower than jpmax_harmo, stop'
+        IF(lwp) WRITE(numout,*) ' jpmax_harmo= ', jpmax_harmo
+        nstop = nstop + 1
+      ENDIF
+
+      ALLOCATE(name    (nb_ana))
+      DO jk=1,nb_ana
+       DO ji=1,jpmax_harmo
+          IF (TRIM(tname(jk)) ==  Wave(ji)%cname_tide) THEN
+             name(jk) = ji
+             EXIT
+          END IF
+       END DO
+      END DO
+
+      ! Initialize frequency array:
+      ! ---------------------------
+      ALLOCATE( ana_freq(nb_ana), ut(nb_ana), vt(nb_ana), ft(nb_ana) )
+
+      CALL tide_harmo( ana_freq, vt, ut, ft, name, nb_ana )
+
+      IF(lwp) WRITE(numout,*) 'Analysed frequency  : ',nb_ana ,'Frequency '
+
+      DO jh = 1, nb_ana
+        IF(lwp) WRITE(numout,*) '                    : ',tname(jh),' ',ana_freq(jh)
+      END DO
+
+      ! Initialize temporary arrays:
+      ! ----------------------------
+      ALLOCATE( ana_temp(jpi,jpj,2*nb_ana,3) )
+      ana_temp(:,:,:,:) = 0._wp
+
+   END SUBROUTINE dia_harm_init
+
+
+   SUBROUTINE dia_harm ( kt )
+      !!----------------------------------------------------------------------
+      !!                 ***  ROUTINE dia_harm  ***
+      !!         
+      !! ** Purpose :   Tidal harmonic analysis main routine
+      !!
+      !! ** Action  :   Sums ssh/u/v over time analysis [nit000_han,nitend_han]
+      !!
+      !!--------------------------------------------------------------------
+      INTEGER, INTENT( IN ) :: kt
+      !
+      INTEGER  :: ji, jj, jh, jc, nhc
+      REAL(wp) :: ztime, ztemp
+      !!--------------------------------------------------------------------
+      IF( ln_timing )   CALL timing_start('dia_harm')
+      !
+      IF( kt == nit000 )   CALL dia_harm_init
+      !
+      IF( kt >= nit000_han .AND. kt <= nitend_han .AND. MOD(kt,nstep_han) == 0 ) THEN
+         !
+         ztime = (kt-nit000+1) * rdt 
+         !
+         nhc = 0
+         DO jh = 1, nb_ana
+            DO jc = 1, 2
+               nhc = nhc+1
+               ztemp =(     MOD(jc,2) * ft(jh) *COS(ana_freq(jh)*ztime + vt(jh) + ut(jh))  &
+                  &    +(1.-MOD(jc,2))* ft(jh) *SIN(ana_freq(jh)*ztime + vt(jh) + ut(jh)))
+                  !
+               DO jj = 1,jpj
+                  DO ji = 1,jpi
+                     ! Elevation
+                     ana_temp(ji,jj,nhc,1) = ana_temp(ji,jj,nhc,1) + ztemp*sshn(ji,jj)*ssmask (ji,jj)        
+                     ana_temp(ji,jj,nhc,2) = ana_temp(ji,jj,nhc,2) + ztemp*un_b(ji,jj)*ssumask(ji,jj)
+                     ana_temp(ji,jj,nhc,3) = ana_temp(ji,jj,nhc,3) + ztemp*vn_b(ji,jj)*ssvmask(ji,jj)
+                  END DO
+               END DO
+               !
+            END DO
+         END DO
+         !       
+      END IF
+      !
+      IF( kt == nitend_han )   CALL dia_harm_end
+      !
+      IF( ln_timing )   CALL timing_stop('dia_harm')
+      !
+   END SUBROUTINE dia_harm
+
+
+   SUBROUTINE dia_harm_end
+      !!----------------------------------------------------------------------
+      !!                 ***  ROUTINE diaharm_end  ***
+      !!         
+      !! ** Purpose :  Compute the Real and Imaginary part of tidal constituents
+      !!
+      !! ** Action  :  Decompose the signal on the harmonic constituents 
+      !!
+      !!--------------------------------------------------------------------
+      INTEGER :: ji, jj, jh, jc, jn, nhan, jl
+      INTEGER :: ksp, kun, keq
+      REAL(wp) :: ztime, ztime_ini, ztime_end
+      REAL(wp) :: X1, X2
+      REAL(wp), DIMENSION(jpi,jpj,jpmax_harmo,2) ::   ana_amp   ! workspace
+      !!--------------------------------------------------------------------
+      !
+      IF(lwp) WRITE(numout,*)
+      IF(lwp) WRITE(numout,*) 'anharmo_end: kt=nitend_han: Perform harmonic analysis'
+      IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~'
+
+      ztime_ini = nit000_han*rdt                 ! Initial time in seconds at the beginning of analysis
+      ztime_end = nitend_han*rdt                 ! Final time in seconds at the end of analysis
+      nhan = (nitend_han-nit000_han+1)/nstep_han ! Number of dumps used for analysis
+
+      ninco = 2*nb_ana
+
+      ksp = 0
+      keq = 0        
+      DO jn = 1, nhan
+         ztime=( (nhan-jn)*ztime_ini + (jn-1)*ztime_end )/FLOAT(nhan-1)
+         keq = keq + 1
+         kun = 0
+         DO jh = 1, nb_ana
+            DO jc = 1, 2
+               kun = kun + 1
+               ksp = ksp + 1
+               nisparse(ksp) = keq
+               njsparse(ksp) = kun
+               valuesparse(ksp) = (   MOD(jc,2) * ft(jh) * COS(ana_freq(jh)*ztime + vt(jh) + ut(jh))   &
+                  &             + (1.-MOD(jc,2))* ft(jh) * SIN(ana_freq(jh)*ztime + vt(jh) + ut(jh)) )
+            END DO
+         END DO
+      END DO
+
+      nsparse = ksp
+
+      ! Elevation:
+      DO jj = 1, jpj
+         DO ji = 1, jpi
+            ! Fill input array
+            kun = 0
+            DO jh = 1, nb_ana
+               DO jc = 1, 2
+                  kun = kun + 1
+                  ztmp4(kun)=ana_temp(ji,jj,kun,1)
+               END DO
+            END DO
+
+            CALL SUR_DETERMINE(jj)
+
+            ! Fill output array
+            DO jh = 1, nb_ana
+               ana_amp(ji,jj,jh,1)=ztmp7((jh-1)*2+1)
+               ana_amp(ji,jj,jh,2)=ztmp7((jh-1)*2+2)
+            END DO
+         END DO
+      END DO
+
+      ALLOCATE( out_eta(jpi,jpj,2*nb_ana),   & 
+         &      out_u  (jpi,jpj,2*nb_ana),   &
+         &      out_v  (jpi,jpj,2*nb_ana)  )
+
+      DO jj = 1, jpj
+         DO ji = 1, jpi
+            DO jh = 1, nb_ana 
+               X1 = ana_amp(ji,jj,jh,1)
+               X2 =-ana_amp(ji,jj,jh,2)
+               out_eta(ji,jj,jh       ) = X1 * tmask_i(ji,jj)
+               out_eta(ji,jj,jh+nb_ana) = X2 * tmask_i(ji,jj)
+            END DO
+         END DO
+      END DO
+
+      ! ubar:
+      DO jj = 1, jpj
+         DO ji = 1, jpi
+            ! Fill input array
+            kun=0
+            DO jh = 1,nb_ana
+               DO jc = 1,2
+                  kun = kun + 1
+                  ztmp4(kun)=ana_temp(ji,jj,kun,2)
+               END DO
+            END DO
+
+            CALL SUR_DETERMINE(jj+1)
+
+            ! Fill output array
+            DO jh = 1, nb_ana
+               ana_amp(ji,jj,jh,1) = ztmp7((jh-1)*2+1)
+               ana_amp(ji,jj,jh,2) = ztmp7((jh-1)*2+2)
+            END DO
+
+         END DO
+      END DO
+
+      DO jj = 1, jpj
+         DO ji = 1, jpi
+            DO jh = 1, nb_ana 
+               X1= ana_amp(ji,jj,jh,1)
+               X2=-ana_amp(ji,jj,jh,2)
+               out_u(ji,jj,       jh) = X1 * ssumask(ji,jj)
+               out_u(ji,jj,nb_ana+jh) = X2 * ssumask(ji,jj)
+            ENDDO
+         ENDDO
+      ENDDO
+
+      ! vbar:
+      DO jj = 1, jpj
+         DO ji = 1, jpi
+            ! Fill input array
+            kun=0
+            DO jh = 1,nb_ana
+               DO jc = 1,2
+                  kun = kun + 1
+                  ztmp4(kun)=ana_temp(ji,jj,kun,3)
+               END DO
+            END DO
+
+            CALL SUR_DETERMINE(jj+1)
+
+            ! Fill output array
+            DO jh = 1, nb_ana
+               ana_amp(ji,jj,jh,1)=ztmp7((jh-1)*2+1)
+               ana_amp(ji,jj,jh,2)=ztmp7((jh-1)*2+2)
+            END DO
+
+         END DO
+      END DO
+
+      DO jj = 1, jpj
+         DO ji = 1, jpi
+            DO jh = 1, nb_ana 
+               X1=ana_amp(ji,jj,jh,1)
+               X2=-ana_amp(ji,jj,jh,2)
+               out_v(ji,jj,       jh)=X1 * ssvmask(ji,jj)
+               out_v(ji,jj,nb_ana+jh)=X2 * ssvmask(ji,jj)
+            END DO
+         END DO
+      END DO
+      !
+      CALL dia_wri_harm ! Write results in files
+      !
+   END SUBROUTINE dia_harm_end
+
+
+   SUBROUTINE dia_wri_harm
+      !!--------------------------------------------------------------------
+      !!                 ***  ROUTINE dia_wri_harm  ***
+      !!         
+      !! ** Purpose : Write tidal harmonic analysis results in a netcdf file
+      !!--------------------------------------------------------------------
+      CHARACTER(LEN=lc) :: cltext
+      CHARACTER(LEN=lc) ::   &
+         cdfile_name_T   ,   & ! name of the file created (T-points)
+         cdfile_name_U   ,   & ! name of the file created (U-points)
+         cdfile_name_V         ! name of the file created (V-points)
+      INTEGER  ::   jh
+      !!----------------------------------------------------------------------
+
+      IF(lwp) WRITE(numout,*) '  '
+      IF(lwp) WRITE(numout,*) 'dia_wri_harm : Write harmonic analysis results'
+      IF(lwp) WRITE(numout,*) '  '
+
+      ! A) Elevation
+      !/////////////
+      !
+      DO jh = 1, nb_ana
+      CALL iom_put( TRIM(tname(jh))//'x', out_eta(:,:,jh) )
+      CALL iom_put( TRIM(tname(jh))//'y', out_eta(:,:,nb_ana+jh) )
+      END DO
+
+      ! B) ubar
+      !/////////
+      !
+      DO jh = 1, nb_ana
+      CALL iom_put( TRIM(tname(jh))//'x_u', out_u(:,:,jh) )
+      CALL iom_put( TRIM(tname(jh))//'y_u', out_u(:,:,nb_ana+jh) )
+      END DO
+
+      ! C) vbar
+      !/////////
+      !
+      DO jh = 1, nb_ana
+         CALL iom_put( TRIM(tname(jh))//'x_v', out_v(:,:,jh       ) )
+         CALL iom_put( TRIM(tname(jh))//'y_v', out_v(:,:,jh+nb_ana) )
+      END DO
+      !
+   END SUBROUTINE dia_wri_harm
+
+
+   SUBROUTINE SUR_DETERMINE(init)
+      !!---------------------------------------------------------------------------------
+      !!                      *** ROUTINE SUR_DETERMINE ***
+      !!    
+      !!    
+      !!       
+      !!---------------------------------------------------------------------------------
+      INTEGER, INTENT(in) ::   init 
+      !
+      INTEGER                         :: ji_sd, jj_sd, ji1_sd, ji2_sd, jk1_sd, jk2_sd
+      REAL(wp)                        :: zval1, zval2, zx1
+      REAL(wp), DIMENSION(jpincomax) :: ztmpx, zcol1, zcol2
+      INTEGER , DIMENSION(jpincomax) :: ipos2, ipivot
+      !---------------------------------------------------------------------------------
+      !            
+      IF( init == 1 ) THEN
+         IF( nsparse > jpdimsparse )   CALL ctl_stop( 'STOP', 'SUR_DETERMINE : nsparse .GT. jpdimsparse')
+         IF( ninco   > jpincomax   )   CALL ctl_stop( 'STOP', 'SUR_DETERMINE : ninco .GT. jpincomax')
+         !
+         ztmp3(:,:) = 0._wp
+         !
+         DO jk1_sd = 1, nsparse
+            DO jk2_sd = 1, nsparse
+               nisparse(jk2_sd) = nisparse(jk2_sd)
+               njsparse(jk2_sd) = njsparse(jk2_sd)
+               IF( nisparse(jk2_sd) == nisparse(jk1_sd) ) THEN
+                  ztmp3(njsparse(jk1_sd),njsparse(jk2_sd)) = ztmp3(njsparse(jk1_sd),njsparse(jk2_sd))  &
+                     &                                     + valuesparse(jk1_sd)*valuesparse(jk2_sd)
+               ENDIF
+            END DO
+         END DO
+         !
+         DO jj_sd = 1 ,ninco
+            ipos1(jj_sd) = jj_sd
+            ipos2(jj_sd) = jj_sd
+         END DO
+         !
+         DO ji_sd = 1 , ninco
+            !
+            !find greatest non-zero pivot:
+            zval1 = ABS(ztmp3(ji_sd,ji_sd))
+            !
+            ipivot(ji_sd) = ji_sd
+            DO jj_sd = ji_sd, ninco
+               zval2 = ABS(ztmp3(ji_sd,jj_sd))
+               IF( zval2 >= zval1 )THEN
+                  ipivot(ji_sd) = jj_sd
+                  zval1         = zval2
+               ENDIF
+            END DO
+            !
+            DO ji1_sd = 1, ninco
+               zcol1(ji1_sd)               = ztmp3(ji1_sd,ji_sd)
+               zcol2(ji1_sd)               = ztmp3(ji1_sd,ipivot(ji_sd))
+               ztmp3(ji1_sd,ji_sd)         = zcol2(ji1_sd)
+               ztmp3(ji1_sd,ipivot(ji_sd)) = zcol1(ji1_sd)
+            END DO
+            !
+            ipos2(ji_sd)         = ipos1(ipivot(ji_sd))
+            ipos2(ipivot(ji_sd)) = ipos1(ji_sd)
+            ipos1(ji_sd)         = ipos2(ji_sd)
+            ipos1(ipivot(ji_sd)) = ipos2(ipivot(ji_sd))
+            zpivot(ji_sd)        = ztmp3(ji_sd,ji_sd)
+            DO jj_sd = 1, ninco
+               ztmp3(ji_sd,jj_sd) = ztmp3(ji_sd,jj_sd) / zpivot(ji_sd)
+            END DO
+            !
+            DO ji2_sd = ji_sd+1, ninco
+               zpilier(ji2_sd,ji_sd)=ztmp3(ji2_sd,ji_sd)
+               DO jj_sd=1,ninco
+                  ztmp3(ji2_sd,jj_sd)=  ztmp3(ji2_sd,jj_sd) - ztmp3(ji_sd,jj_sd) * zpilier(ji2_sd,ji_sd)
+               END DO
+            END DO
+            !
+         END DO
+         !
+      ENDIF ! End init==1
+
+      DO ji_sd = 1, ninco
+         ztmp4(ji_sd) = ztmp4(ji_sd) / zpivot(ji_sd)
+         DO ji2_sd = ji_sd+1, ninco
+            ztmp4(ji2_sd) = ztmp4(ji2_sd) - ztmp4(ji_sd) * zpilier(ji2_sd,ji_sd)
+         END DO
+      END DO
+
+      !system solving: 
+      ztmpx(ninco) = ztmp4(ninco) / ztmp3(ninco,ninco)
+      ji_sd = ninco
+      DO ji_sd = ninco-1, 1, -1
+         zx1 = 0._wp
+         DO jj_sd = ji_sd+1, ninco
+            zx1 = zx1 + ztmpx(jj_sd) * ztmp3(ji_sd,jj_sd)
+         END DO
+         ztmpx(ji_sd) = ztmp4(ji_sd)-zx1
+      END DO
+
+      DO jj_sd =1, ninco
+         ztmp7(ipos1(jj_sd))=ztmpx(jj_sd)
+      END DO
+      !
+   END SUBROUTINE SUR_DETERMINE
+
+#else
+   !!----------------------------------------------------------------------
+   !!   Default case :   Empty module
+   !!----------------------------------------------------------------------
+   LOGICAL, PUBLIC, PARAMETER ::   lk_diaharm = .FALSE.
+CONTAINS
+   SUBROUTINE dia_harm ( kt )     ! Empty routine
+      INTEGER, INTENT( IN ) :: kt  
+      WRITE(*,*) 'dia_harm: you should not have seen this print'
+   END SUBROUTINE dia_harm
+#endif
+
+   !!======================================================================
+END MODULE diaharm
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DIA/diahsb.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DIA/diahsb.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DIA/diahsb.F90	(revision 9570)
@@ -0,0 +1,424 @@
+MODULE diahsb
+   !!======================================================================
+   !!                       ***  MODULE  diahsb  ***
+   !! Ocean diagnostics: Heat, salt and volume budgets
+   !!======================================================================
+   !! History :  3.3  ! 2010-09  (M. Leclair)  Original code 
+   !!                 ! 2012-10  (C. Rousset)  add iom_put
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   dia_hsb       : Diagnose the conservation of ocean heat and salt contents, and volume
+   !!   dia_hsb_rst   : Read or write DIA file in restart file
+   !!   dia_hsb_init  : Initialization of the conservation diagnostic
+   !!----------------------------------------------------------------------
+   USE oce            ! ocean dynamics and tracers
+   USE dom_oce        ! ocean space and time domain
+   USE phycst         ! physical constants
+   USE sbc_oce        ! surface thermohaline fluxes
+   USE sbcrnf         ! river runoff
+   USE sbcisf         ! ice shelves
+   USE domvvl         ! vertical scale factors
+   USE traqsr         ! penetrative solar radiation
+   USE trabbc         ! bottom boundary condition 
+   USE trabbc         ! bottom boundary condition
+   USE restart        ! ocean restart
+   USE bdy_oce , ONLY : ln_bdy
+   !
+   USE iom            ! I/O manager
+   USE in_out_manager ! I/O manager
+   USE lib_fortran    ! glob_sum
+   USE lib_mpp        ! distributed memory computing library
+   USE timing         ! preformance summary
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   dia_hsb        ! routine called by step.F90
+   PUBLIC   dia_hsb_init   ! routine called by nemogcm.F90
+
+   LOGICAL, PUBLIC ::   ln_diahsb   !: check the heat and salt budgets
+
+   REAL(wp) ::   surf_tot              ! ocean surface
+   REAL(wp) ::   frc_t, frc_s, frc_v   ! global forcing trends
+   REAL(wp) ::   frc_wn_t, frc_wn_s    ! global forcing trends
+   !
+   REAL(wp), DIMENSION(:,:)  , ALLOCATABLE ::   surf 
+   REAL(wp), DIMENSION(:,:)  , ALLOCATABLE ::   surf_ini      , ssh_ini          !
+   REAL(wp), DIMENSION(:,:)  , ALLOCATABLE ::   ssh_hc_loc_ini, ssh_sc_loc_ini   !
+   REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::   hc_loc_ini, sc_loc_ini, e3t_ini  !
+
+   !! * Substitutions
+#  include "vectopt_loop_substitute.h90"
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO Consortium (2010)
+   !! $Id$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE dia_hsb( kt )
+      !!---------------------------------------------------------------------------
+      !!                  ***  ROUTINE dia_hsb  ***
+      !!     
+      !! ** Purpose: Compute the ocean global heat content, salt content and volume conservation
+      !!	
+      !! ** Method : - Compute the deviation of heat content, salt content and volume
+      !!	            at the current time step from their values at nit000
+      !!	            - Compute the contribution of forcing and remove it from these deviations
+      !!
+      !!---------------------------------------------------------------------------
+      INTEGER, INTENT(in) ::   kt   ! ocean time-step index
+      !
+      INTEGER    ::   ji, jj, jk                  ! dummy loop indice
+      REAL(wp)   ::   zdiff_hc    , zdiff_sc      ! heat and salt content variations
+      REAL(wp)   ::   zdiff_hc1   , zdiff_sc1     !  -         -     -        - 
+      REAL(wp)   ::   zdiff_v1    , zdiff_v2      ! volume variation
+      REAL(wp)   ::   zerr_hc1    , zerr_sc1      ! heat and salt content misfit
+      REAL(wp)   ::   zvol_tot                    ! volume
+      REAL(wp)   ::   z_frc_trd_t , z_frc_trd_s   !    -     -
+      REAL(wp)   ::   z_frc_trd_v                 !    -     -
+      REAL(wp)   ::   z_wn_trd_t , z_wn_trd_s     !    -     -
+      REAL(wp)   ::   z_ssh_hc , z_ssh_sc         !    -     -
+      REAL(wp), DIMENSION(jpi,jpj)       ::   z2d0, z2d1   ! 2D workspace
+      REAL(wp), DIMENSION(jpi,jpj,jpkm1) ::   zwrk         ! 3D workspace
+      !!---------------------------------------------------------------------------
+      IF( ln_timing )   CALL timing_start('dia_hsb')      
+      !
+      tsn(:,:,:,1) = tsn(:,:,:,1) * tmask(:,:,:) ; tsb(:,:,:,1) = tsb(:,:,:,1) * tmask(:,:,:) ;
+      tsn(:,:,:,2) = tsn(:,:,:,2) * tmask(:,:,:) ; tsb(:,:,:,2) = tsb(:,:,:,2) * tmask(:,:,:) ;
+      ! ------------------------- !
+      ! 1 - Trends due to forcing !
+      ! ------------------------- !
+      z_frc_trd_v = r1_rau0 * glob_sum( - ( emp(:,:) - rnf(:,:) + fwfisf(:,:) ) * surf(:,:) )   ! volume fluxes
+      z_frc_trd_t =           glob_sum( sbc_tsc(:,:,jp_tem) * surf(:,:) )                       ! heat fluxes
+      z_frc_trd_s =           glob_sum( sbc_tsc(:,:,jp_sal) * surf(:,:) )                       ! salt fluxes
+      !                    !  Add runoff    heat & salt input
+      IF( ln_rnf    )   z_frc_trd_t = z_frc_trd_t + glob_sum( rnf_tsc(:,:,jp_tem) * surf(:,:) )
+      IF( ln_rnf_sal)   z_frc_trd_s = z_frc_trd_s + glob_sum( rnf_tsc(:,:,jp_sal) * surf(:,:) )
+      !                    ! Add ice shelf heat & salt input
+      IF( ln_isf    )   z_frc_trd_t = z_frc_trd_t + glob_sum( risf_tsc(:,:,jp_tem) * surf(:,:) )
+      !                    ! Add penetrative solar radiation
+      IF( ln_traqsr )   z_frc_trd_t = z_frc_trd_t + r1_rau0_rcp * glob_sum( qsr     (:,:) * surf(:,:) )
+      !                    ! Add geothermal heat flux
+      IF( ln_trabbc )   z_frc_trd_t = z_frc_trd_t +               glob_sum( qgh_trd0(:,:) * surf(:,:) )
+      !
+      IF( ln_linssh ) THEN
+         IF( ln_isfcav ) THEN
+            DO ji=1,jpi
+               DO jj=1,jpj
+                  z2d0(ji,jj) = surf(ji,jj) * wn(ji,jj,mikt(ji,jj)) * tsb(ji,jj,mikt(ji,jj),jp_tem)
+                  z2d1(ji,jj) = surf(ji,jj) * wn(ji,jj,mikt(ji,jj)) * tsb(ji,jj,mikt(ji,jj),jp_sal)
+               END DO
+            END DO
+         ELSE
+            z2d0(:,:) = surf(:,:) * wn(:,:,1) * tsb(:,:,1,jp_tem)
+            z2d1(:,:) = surf(:,:) * wn(:,:,1) * tsb(:,:,1,jp_sal)
+         END IF
+         z_wn_trd_t = - glob_sum( z2d0 ) 
+         z_wn_trd_s = - glob_sum( z2d1 )
+      ENDIF
+
+      frc_v = frc_v + z_frc_trd_v * rdt
+      frc_t = frc_t + z_frc_trd_t * rdt
+      frc_s = frc_s + z_frc_trd_s * rdt
+      !                                          ! Advection flux through fixed surface (z=0)
+      IF( ln_linssh ) THEN
+         frc_wn_t = frc_wn_t + z_wn_trd_t * rdt
+         frc_wn_s = frc_wn_s + z_wn_trd_s * rdt
+      ENDIF
+
+      ! ------------------------ !
+      ! 2 -  Content variations  !
+      ! ------------------------ !
+      ! glob_sum_full is needed because you keep the full interior domain to compute the sum (iscpl)
+
+      !                    ! volume variation (calculated with ssh)
+      zdiff_v1 = glob_sum_full( surf(:,:)*sshn(:,:) - surf_ini(:,:)*ssh_ini(:,:) )
+
+      !                    ! heat & salt content variation (associated with ssh)
+      IF( ln_linssh ) THEN       ! linear free surface case
+         IF( ln_isfcav ) THEN          ! ISF case
+            DO ji = 1, jpi
+               DO jj = 1, jpj
+                  z2d0(ji,jj) = surf(ji,jj) * ( tsn(ji,jj,mikt(ji,jj),jp_tem) * sshn(ji,jj) - ssh_hc_loc_ini(ji,jj) ) 
+                  z2d1(ji,jj) = surf(ji,jj) * ( tsn(ji,jj,mikt(ji,jj),jp_sal) * sshn(ji,jj) - ssh_sc_loc_ini(ji,jj) ) 
+               END DO
+            END DO
+         ELSE                          ! no under ice-shelf seas
+            z2d0(:,:) = surf(:,:) * ( tsn(:,:,1,jp_tem) * sshn(:,:) - ssh_hc_loc_ini(:,:) ) 
+            z2d1(:,:) = surf(:,:) * ( tsn(:,:,1,jp_sal) * sshn(:,:) - ssh_sc_loc_ini(:,:) ) 
+         END IF
+         z_ssh_hc = glob_sum_full( z2d0 ) 
+         z_ssh_sc = glob_sum_full( z2d1 ) 
+      ENDIF
+      !
+      DO jk = 1, jpkm1     ! volume variation (calculated with scale factors)
+         zwrk(:,:,jk) = ( surf(:,:)*e3t_n(:,:,jk) - surf_ini(:,:)*e3t_ini(:,:,jk) ) * tmask(:,:,jk)
+      END DO
+      zdiff_v2 = glob_sum_full( zwrk(:,:,:) )
+      DO jk = 1, jpkm1           ! heat content variation
+         zwrk(:,:,jk) = ( surf(:,:)*e3t_n(:,:,jk)*tsn(:,:,jk,jp_tem) - surf_ini(:,:)*hc_loc_ini(:,:,jk) ) * tmask(:,:,jk)
+      END DO
+      zdiff_hc = glob_sum_full( zwrk(:,:,:) )
+      DO jk = 1, jpkm1           ! salt content variation
+         zwrk(:,:,jk) = ( surf(:,:)*e3t_n(:,:,jk)*tsn(:,:,jk,jp_sal) - surf_ini(:,:)*sc_loc_ini(:,:,jk) ) * tmask(:,:,jk)
+      END DO
+      zdiff_sc = glob_sum_full( zwrk(:,:,:) )
+
+      ! ------------------------ !
+      ! 3 -  Drifts              !
+      ! ------------------------ !
+      zdiff_v1 = zdiff_v1 - frc_v
+      IF( .NOT.ln_linssh )   zdiff_v2 = zdiff_v2 - frc_v
+      zdiff_hc = zdiff_hc - frc_t
+      zdiff_sc = zdiff_sc - frc_s
+      IF( ln_linssh ) THEN
+         zdiff_hc1 = zdiff_hc + z_ssh_hc 
+         zdiff_sc1 = zdiff_sc + z_ssh_sc
+         zerr_hc1  = z_ssh_hc - frc_wn_t
+         zerr_sc1  = z_ssh_sc - frc_wn_s
+      ENDIF
+
+      ! ----------------------- !
+      ! 4 - Diagnostics writing !
+      ! ----------------------- !
+      DO jk = 1, jpkm1           ! total ocean volume (calculated with scale factors)
+         zwrk(:,:,jk) = surf(:,:) * e3t_n(:,:,jk) * tmask(:,:,jk)
+      END DO
+      zvol_tot = glob_sum_full( zwrk(:,:,:) )
+
+!!gm to be added ?
+!      IF( ln_linssh ) THEN            ! fixed volume, add the ssh contribution
+!        zvol_tot = zvol_tot + glob_sum( surf(:,:) * sshn(:,:) )
+!      ENDIF
+!!gm end
+
+      CALL iom_put(   'bgfrcvol' , frc_v    * 1.e-9    )              ! vol - surface forcing (km3) 
+      CALL iom_put(   'bgfrctem' , frc_t    * rau0 * rcp * 1.e-20 )   ! hc  - surface forcing (1.e20 J) 
+      CALL iom_put(   'bgfrchfx' , frc_t    * rau0 * rcp /  &         ! hc  - surface forcing (W/m2) 
+         &                       ( surf_tot * kt * rdt )        )
+      CALL iom_put(   'bgfrcsal' , frc_s    * 1.e-9    )              ! sc  - surface forcing (psu*km3) 
+
+      IF( .NOT. ln_linssh ) THEN
+         CALL iom_put( 'bgtemper' , zdiff_hc / zvol_tot )              ! Temperature drift     (C) 
+         CALL iom_put( 'bgsaline' , zdiff_sc / zvol_tot )              ! Salinity    drift     (PSU)
+         CALL iom_put( 'bgheatco' , zdiff_hc * 1.e-20 * rau0 * rcp )   ! Heat content drift    (1.e20 J) 
+         CALL iom_put( 'bgheatfx' , zdiff_hc * rau0 * rcp /  &         ! Heat flux drift       (W/m2) 
+            &                       ( surf_tot * kt * rdt )        )
+         CALL iom_put( 'bgsaltco' , zdiff_sc * 1.e-9    )              ! Salt content drift    (psu*km3)
+         CALL iom_put( 'bgvolssh' , zdiff_v1 * 1.e-9    )              ! volume ssh drift      (km3)  
+         CALL iom_put( 'bgvole3t' , zdiff_v2 * 1.e-9    )              ! volume e3t drift      (km3)  
+         !
+         IF( kt == nitend .AND. lwp ) THEN
+            WRITE(numout,*)
+            WRITE(numout,*) 'dia_hsb : last time step hsb diagnostics: at it= ', kt,' date= ', ndastp
+            WRITE(numout,*) '~~~~~~~'
+            WRITE(numout,*) '   Temperature drift = ', zdiff_hc / zvol_tot, ' C'
+            WRITE(numout,*) '   Salinity    drift = ', zdiff_sc / zvol_tot, ' PSU'
+            WRITE(numout,*) '   volume ssh  drift = ', zdiff_v1 * 1.e-9   , ' km^3'
+            WRITE(numout,*) '   volume e3t  drift = ', zdiff_v2 * 1.e-9   , ' km^3'
+         ENDIF
+         !
+      ELSE
+         CALL iom_put( 'bgtemper' , zdiff_hc1 / zvol_tot)              ! Heat content drift    (C) 
+         CALL iom_put( 'bgsaline' , zdiff_sc1 / zvol_tot)              ! Salt content drift    (PSU)
+         CALL iom_put( 'bgheatco' , zdiff_hc1 * 1.e-20 * rau0 * rcp )  ! Heat content drift    (1.e20 J) 
+         CALL iom_put( 'bgheatfx' , zdiff_hc1 * rau0 * rcp /  &        ! Heat flux drift       (W/m2) 
+            &                       ( surf_tot * kt * rdt )         )
+         CALL iom_put( 'bgsaltco' , zdiff_sc1 * 1.e-9    )             ! Salt content drift    (psu*km3)
+         CALL iom_put( 'bgvolssh' , zdiff_v1 * 1.e-9    )              ! volume ssh drift      (km3)  
+         CALL iom_put( 'bgmistem' , zerr_hc1 / zvol_tot )              ! hc  - error due to free surface (C)
+         CALL iom_put( 'bgmissal' , zerr_sc1 / zvol_tot )              ! sc  - error due to free surface (psu)
+      ENDIF
+      !
+      IF( lrst_oce )   CALL dia_hsb_rst( kt, 'WRITE' )
+      !
+      IF( ln_timing )   CALL timing_stop('dia_hsb')
+      !
+   END SUBROUTINE dia_hsb
+
+
+   SUBROUTINE dia_hsb_rst( kt, cdrw )
+      !!---------------------------------------------------------------------
+      !!                   ***  ROUTINE dia_hsb_rst  ***
+      !!                     
+      !! ** Purpose :   Read or write DIA file in restart file
+      !!
+      !! ** Method  :   use of IOM library
+      !!----------------------------------------------------------------------
+      INTEGER         , INTENT(in) ::   kt     ! ocean time-step
+      CHARACTER(len=*), INTENT(in) ::   cdrw   ! "READ"/"WRITE" flag
+      !
+      INTEGER ::   ji, jj, jk   ! dummy loop indices
+      !!----------------------------------------------------------------------
+      !
+      IF( TRIM(cdrw) == 'READ' ) THEN        ! Read/initialise 
+         IF( ln_rstart ) THEN                   !* Read the restart file
+            !
+            IF(lwp) WRITE(numout,*)
+            IF(lwp) WRITE(numout,*) '   dia_hsb_rst : read hsb restart at it= ', kt,' date= ', ndastp
+            IF(lwp) WRITE(numout,*)
+            CALL iom_get( numror, 'frc_v', frc_v, ldxios = lrxios )
+            CALL iom_get( numror, 'frc_t', frc_t, ldxios = lrxios )
+            CALL iom_get( numror, 'frc_s', frc_s, ldxios = lrxios )
+            IF( ln_linssh ) THEN
+               CALL iom_get( numror, 'frc_wn_t', frc_wn_t, ldxios = lrxios )
+               CALL iom_get( numror, 'frc_wn_s', frc_wn_s, ldxios = lrxios )
+            ENDIF
+            CALL iom_get( numror, jpdom_autoglo, 'surf_ini'  , surf_ini  , ldxios = lrxios ) ! ice sheet coupling
+            CALL iom_get( numror, jpdom_autoglo, 'ssh_ini'   , ssh_ini   , ldxios = lrxios )
+            CALL iom_get( numror, jpdom_autoglo, 'e3t_ini'   , e3t_ini   , ldxios = lrxios )
+            CALL iom_get( numror, jpdom_autoglo, 'hc_loc_ini', hc_loc_ini, ldxios = lrxios )
+            CALL iom_get( numror, jpdom_autoglo, 'sc_loc_ini', sc_loc_ini, ldxios = lrxios )
+            IF( ln_linssh ) THEN
+               CALL iom_get( numror, jpdom_autoglo, 'ssh_hc_loc_ini', ssh_hc_loc_ini, ldxios = lrxios )
+               CALL iom_get( numror, jpdom_autoglo, 'ssh_sc_loc_ini', ssh_sc_loc_ini, ldxios = lrxios )
+            ENDIF
+         ELSE
+            IF(lwp) WRITE(numout,*)
+            IF(lwp) WRITE(numout,*) '   dia_hsb_rst : initialise hsb at initial state '
+            IF(lwp) WRITE(numout,*)
+            surf_ini(:,:) = e1e2t(:,:) * tmask_i(:,:)         ! initial ocean surface
+            ssh_ini(:,:) = sshn(:,:)                          ! initial ssh
+            DO jk = 1, jpk
+              ! if ice sheet/oceqn coupling, need to mask ini variables here (mask could change at the next NEMO instance).
+               e3t_ini   (:,:,jk) = e3t_n(:,:,jk)                      * tmask(:,:,jk)  ! initial vertical scale factors
+               hc_loc_ini(:,:,jk) = tsn(:,:,jk,jp_tem) * e3t_n(:,:,jk) * tmask(:,:,jk)  ! initial heat content
+               sc_loc_ini(:,:,jk) = tsn(:,:,jk,jp_sal) * e3t_n(:,:,jk) * tmask(:,:,jk)  ! initial salt content
+            END DO
+            frc_v = 0._wp                                           ! volume       trend due to forcing
+            frc_t = 0._wp                                           ! heat content   -    -   -    -   
+            frc_s = 0._wp                                           ! salt content   -    -   -    -        
+            IF( ln_linssh ) THEN
+               IF( ln_isfcav ) THEN
+                  DO ji = 1, jpi
+                     DO jj = 1, jpj
+                        ssh_hc_loc_ini(ji,jj) = tsn(ji,jj,mikt(ji,jj),jp_tem) * sshn(ji,jj)   ! initial heat content in ssh
+                        ssh_sc_loc_ini(ji,jj) = tsn(ji,jj,mikt(ji,jj),jp_sal) * sshn(ji,jj)   ! initial salt content in ssh
+                     END DO
+                   END DO
+                ELSE
+                  ssh_hc_loc_ini(:,:) = tsn(:,:,1,jp_tem) * sshn(:,:)   ! initial heat content in ssh
+                  ssh_sc_loc_ini(:,:) = tsn(:,:,1,jp_sal) * sshn(:,:)   ! initial salt content in ssh
+               END IF
+               frc_wn_t = 0._wp                                       ! initial heat content misfit due to free surface
+               frc_wn_s = 0._wp                                       ! initial salt content misfit due to free surface
+            ENDIF
+         ENDIF
+         !
+      ELSEIF( TRIM(cdrw) == 'WRITE' ) THEN   ! Create restart file
+         !                                   ! -------------------
+         IF(lwp) WRITE(numout,*)
+         IF(lwp) WRITE(numout,*) '   dia_hsb_rst : write restart at it= ', kt,' date= ', ndastp
+         IF(lwp) WRITE(numout,*)
+         !
+         IF( lwxios ) CALL iom_swap(      cwxios_context          )
+         CALL iom_rstput( kt, nitrst, numrow, 'frc_v', frc_v, ldxios = lwxios )
+         CALL iom_rstput( kt, nitrst, numrow, 'frc_t', frc_t, ldxios = lwxios )
+         CALL iom_rstput( kt, nitrst, numrow, 'frc_s', frc_s, ldxios = lwxios )
+         IF( ln_linssh ) THEN
+            CALL iom_rstput( kt, nitrst, numrow, 'frc_wn_t', frc_wn_t, ldxios = lwxios )
+            CALL iom_rstput( kt, nitrst, numrow, 'frc_wn_s', frc_wn_s, ldxios = lwxios )
+         ENDIF
+         CALL iom_rstput( kt, nitrst, numrow, 'surf_ini'  , surf_ini  , ldxios = lwxios )      ! ice sheet coupling
+         CALL iom_rstput( kt, nitrst, numrow, 'ssh_ini'   , ssh_ini   , ldxios = lwxios )
+         CALL iom_rstput( kt, nitrst, numrow, 'e3t_ini'   , e3t_ini   , ldxios = lwxios )
+         CALL iom_rstput( kt, nitrst, numrow, 'hc_loc_ini', hc_loc_ini, ldxios = lwxios )
+         CALL iom_rstput( kt, nitrst, numrow, 'sc_loc_ini', sc_loc_ini, ldxios = lwxios )
+         IF( ln_linssh ) THEN
+            CALL iom_rstput( kt, nitrst, numrow, 'ssh_hc_loc_ini', ssh_hc_loc_ini, ldxios = lwxios )
+            CALL iom_rstput( kt, nitrst, numrow, 'ssh_sc_loc_ini', ssh_sc_loc_ini, ldxios = lwxios )
+         ENDIF
+         IF( lwxios ) CALL iom_swap(      cxios_context          )
+         !
+      ENDIF
+      !
+   END SUBROUTINE dia_hsb_rst
+
+
+   SUBROUTINE dia_hsb_init
+      !!---------------------------------------------------------------------------
+      !!                  ***  ROUTINE dia_hsb  ***
+      !!     
+      !! ** Purpose: Initialization for the heat salt volume budgets
+      !!	
+      !! ** Method : Compute initial heat content, salt content and volume
+      !!
+      !! ** Action : - Compute initial heat content, salt content and volume
+      !!             - Initialize forcing trends
+      !!             - Compute coefficients for conversion
+      !!---------------------------------------------------------------------------
+      INTEGER ::   ierror, ios   ! local integer
+      !!
+      NAMELIST/namhsb/ ln_diahsb
+      !!----------------------------------------------------------------------
+      !
+      IF(lwp) THEN
+         WRITE(numout,*)
+         WRITE(numout,*) 'dia_hsb_init : heat and salt budgets diagnostics'
+         WRITE(numout,*) '~~~~~~~~~~~~ '
+      ENDIF
+      REWIND( numnam_ref )              ! Namelist namhsb in reference namelist
+      READ  ( numnam_ref, namhsb, IOSTAT = ios, ERR = 901)
+901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namhsb in reference namelist', lwp )
+      REWIND( numnam_cfg )              ! Namelist namhsb in configuration namelist
+      READ  ( numnam_cfg, namhsb, IOSTAT = ios, ERR = 902 )
+902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namhsb in configuration namelist', lwp )
+      IF(lwm) WRITE( numond, namhsb )
+
+      IF(lwp) THEN
+         WRITE(numout,*) '   Namelist  namhsb :'
+         WRITE(numout,*) '      check the heat and salt budgets (T) or not (F)       ln_diahsb = ', ln_diahsb
+      ENDIF
+      !
+      IF( .NOT. ln_diahsb )   RETURN
+
+      IF(lwxios) THEN
+! define variables in restart file when writing with XIOS
+        CALL iom_set_rstw_var_active('frc_v')
+        CALL iom_set_rstw_var_active('frc_t')
+        CALL iom_set_rstw_var_active('frc_s')
+        CALL iom_set_rstw_var_active('surf_ini')
+        CALL iom_set_rstw_var_active('ssh_ini')
+        CALL iom_set_rstw_var_active('e3t_ini')
+        CALL iom_set_rstw_var_active('hc_loc_ini')
+        CALL iom_set_rstw_var_active('sc_loc_ini')
+        IF( ln_linssh ) THEN
+           CALL iom_set_rstw_var_active('ssh_hc_loc_ini')
+           CALL iom_set_rstw_var_active('ssh_sc_loc_ini')
+           CALL iom_set_rstw_var_active('frc_wn_t')
+           CALL iom_set_rstw_var_active('frc_wn_s')
+        ENDIF
+      ENDIF
+      ! ------------------- !
+      ! 1 - Allocate memory !
+      ! ------------------- !
+      ALLOCATE( hc_loc_ini(jpi,jpj,jpk), sc_loc_ini(jpi,jpj,jpk), surf_ini(jpi,jpj), &
+         &      e3t_ini(jpi,jpj,jpk), surf(jpi,jpj),  ssh_ini(jpi,jpj), STAT=ierror  )
+      IF( ierror > 0 ) THEN
+         CALL ctl_stop( 'dia_hsb_init: unable to allocate hc_loc_ini' )   ;   RETURN
+      ENDIF
+
+      IF( ln_linssh )   ALLOCATE( ssh_hc_loc_ini(jpi,jpj), ssh_sc_loc_ini(jpi,jpj),STAT=ierror )
+      IF( ierror > 0 ) THEN
+         CALL ctl_stop( 'dia_hsb: unable to allocate ssh_hc_loc_ini' )   ;   RETURN
+      ENDIF
+
+      ! ----------------------------------------------- !
+      ! 2 - Time independant variables and file opening !
+      ! ----------------------------------------------- !
+      surf(:,:) = e1e2t(:,:) * tmask_i(:,:)     ! masked surface grid cell area
+      surf_tot  = glob_sum( surf(:,:) )         ! total ocean surface area
+
+      IF( ln_bdy ) CALL ctl_warn( 'dia_hsb_init: heat/salt budget does not consider open boundary fluxes' )         
+      !
+      ! ---------------------------------- !
+      ! 4 - initial conservation variables !
+      ! ---------------------------------- !
+      CALL dia_hsb_rst( nit000, 'READ' )  !* read or initialize all required files
+      !
+   END SUBROUTINE dia_hsb_init
+
+   !!======================================================================
+END MODULE diahsb
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DIA/diahth.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DIA/diahth.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DIA/diahth.F90	(revision 9570)
@@ -0,0 +1,350 @@
+MODULE diahth
+   !!======================================================================
+   !!                       ***  MODULE  diahth  ***
+   !! Ocean diagnostics: thermocline and 20 degree depth
+   !!======================================================================
+   !! History :  OPA  !  1994-09  (J.-P. Boulanger)  Original code
+   !!                 !  1996-11  (E. Guilyardi)  OPA8 
+   !!                 !  1997-08  (G. Madec)  optimization
+   !!                 !  1999-07  (E. Guilyardi)  hd28 + heat content 
+   !!   NEMO     1.0  !  2002-06  (G. Madec)  F90: Free form and module
+   !!            3.2  !  2009-07  (S. Masson) hc300 bugfix + cleaning + add new diag
+   !!----------------------------------------------------------------------
+#if   defined key_diahth
+   !!----------------------------------------------------------------------
+   !!   'key_diahth' :                              thermocline depth diag.
+   !!----------------------------------------------------------------------
+   !!   dia_hth      : Compute varius diagnostics associated with the mixed layer
+   !!----------------------------------------------------------------------
+   USE oce             ! ocean dynamics and tracers
+   USE dom_oce         ! ocean space and time domain
+   USE phycst          ! physical constants
+   !
+   USE in_out_manager  ! I/O manager
+   USE lib_mpp         ! MPP library
+   USE iom             ! I/O library
+   USE timing          ! preformance summary
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   dia_hth       ! routine called by step.F90
+   PUBLIC   dia_hth_alloc ! routine called by nemogcm.F90
+
+   LOGICAL , PUBLIC, PARAMETER ::   lk_diahth = .TRUE.    !: thermocline-20d depths flag
+   
+   ! note: following variables should move to local variables once iom_put is always used 
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hth    !: depth of the max vertical temperature gradient [m]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hd20   !: depth of 20 C isotherm                         [m]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hd28   !: depth of 28 C isotherm                         [m]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   htc3   !: heat content of first 300 m                    [W]
+
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 4.0 , NEMO Consortium (2011)
+   !! $Id$ 
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   FUNCTION dia_hth_alloc()
+      !!---------------------------------------------------------------------
+      INTEGER :: dia_hth_alloc
+      !!---------------------------------------------------------------------
+      !
+      ALLOCATE( hth(jpi,jpj), hd20(jpi,jpj), hd28(jpi,jpj), htc3(jpi,jpj), STAT=dia_hth_alloc )
+      !
+      IF( lk_mpp           )   CALL mpp_sum ( dia_hth_alloc )
+      IF(dia_hth_alloc /= 0)   CALL ctl_warn('dia_hth_alloc: failed to allocate arrays.')
+      !
+   END FUNCTION dia_hth_alloc
+
+
+   SUBROUTINE dia_hth( kt )
+      !!---------------------------------------------------------------------
+      !!                  ***  ROUTINE dia_hth  ***
+      !!
+      !! ** Purpose : Computes
+      !!      the mixing layer depth (turbocline): avt = 5.e-4
+      !!      the depth of strongest vertical temperature gradient
+      !!      the mixed layer depth with density     criteria: rho = rho(10m or surf) + 0.03(or 0.01)
+      !!      the mixed layer depth with temperature criteria: abs( tn - tn(10m) ) = 0.2       
+      !!      the top of the thermochine: tn = tn(10m) - ztem2 
+      !!      the pycnocline depth with density criteria equivalent to a temperature variation 
+      !!                rho = rho10m + (dr/dT)(T,S,10m)*(-0.2 degC) 
+      !!      the barrier layer thickness
+      !!      the maximal verical inversion of temperature and its depth max( 0, max of tn - tn(10m) )
+      !!      the depth of the 20 degree isotherm (linear interpolation)
+      !!      the depth of the 28 degree isotherm (linear interpolation)
+      !!      the heat content of first 300 m
+      !!
+      !! ** Method : 
+      !!-------------------------------------------------------------------
+      INTEGER, INTENT( in ) ::   kt      ! ocean time-step index
+      !!
+      INTEGER                          ::   ji, jj, jk            ! dummy loop arguments
+      INTEGER                          ::   iid, ilevel           ! temporary integers
+      INTEGER, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   ik20, ik28  ! levels
+      REAL(wp)                         ::   zavt5 = 5.e-4_wp      ! Kz criterion for the turbocline depth
+      REAL(wp)                         ::   zrho3 = 0.03_wp       ! density     criterion for mixed layer depth
+      REAL(wp)                         ::   zrho1 = 0.01_wp       ! density     criterion for mixed layer depth
+      REAL(wp)                         ::   ztem2 = 0.2_wp        ! temperature criterion for mixed layer depth
+      REAL(wp)                         ::   zthick_0, zcoef       ! temporary scalars
+      REAL(wp)                         ::   zztmp, zzdep          ! temporary scalars inside do loop
+      REAL(wp)                         ::   zu, zv, zw, zut, zvt  ! temporary workspace
+      REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   zabs2      ! MLD: abs( tn - tn(10m) ) = ztem2 
+      REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   ztm2       ! Top of thermocline: tn = tn(10m) - ztem2     
+      REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   zrho10_3   ! MLD: rho = rho10m + zrho3      
+      REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   zpycn      ! pycnocline: rho = rho10m + (dr/dT)(T,S,10m)*(-0.2 degC)
+      REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   ztinv      ! max of temperature inversion
+      REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   zdepinv    ! depth of temperature inversion
+      REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   zrho0_3    ! MLD rho = rho(surf) = 0.03
+      REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   zrho0_1    ! MLD rho = rho(surf) = 0.01
+      REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   zmaxdzT    ! max of dT/dz
+      REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   zthick     ! vertical integration thickness 
+      REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   zdelr      ! delta rho equivalent to deltaT = 0.2
+      !!----------------------------------------------------------------------
+      IF( ln_timing )   CALL timing_start('dia_hth')
+
+      IF( kt == nit000 ) THEN
+         !                                      ! allocate dia_hth array
+         IF( dia_hth_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'dia_hth : unable to allocate standard arrays' )
+
+         IF(.NOT. ALLOCATED(ik20) ) THEN
+            ALLOCATE(ik20(jpi,jpj), ik28(jpi,jpj), &
+               &      zabs2(jpi,jpj),   &
+               &      ztm2(jpi,jpj),    &
+               &      zrho10_3(jpi,jpj),&
+               &      zpycn(jpi,jpj),   &
+               &      ztinv(jpi,jpj),   &
+               &      zdepinv(jpi,jpj), &
+               &      zrho0_3(jpi,jpj), &
+               &      zrho0_1(jpi,jpj), &
+               &      zmaxdzT(jpi,jpj), &
+               &      zthick(jpi,jpj),  &
+               &      zdelr(jpi,jpj), STAT=ji)
+            IF( lk_mpp  )   CALL mpp_sum(ji)
+            IF( ji /= 0 )   CALL ctl_stop( 'STOP', 'dia_hth : unable to allocate standard ocean arrays' )
+         END IF
+
+         IF(lwp) WRITE(numout,*)
+         IF(lwp) WRITE(numout,*) 'dia_hth : diagnostics of the thermocline depth'
+         IF(lwp) WRITE(numout,*) '~~~~~~~ '
+         IF(lwp) WRITE(numout,*)
+      ENDIF
+
+      ! initialization
+      ztinv  (:,:) = 0._wp  
+      zdepinv(:,:) = 0._wp  
+      zmaxdzT(:,:) = 0._wp  
+      DO jj = 1, jpj
+         DO ji = 1, jpi
+            zztmp = gdepw_n(ji,jj,mbkt(ji,jj)+1) 
+            hth     (ji,jj) = zztmp
+            zabs2   (ji,jj) = zztmp
+            ztm2    (ji,jj) = zztmp
+            zrho10_3(ji,jj) = zztmp
+            zpycn   (ji,jj) = zztmp
+        END DO
+      END DO
+      IF( nla10 > 1 ) THEN 
+         DO jj = 1, jpj
+            DO ji = 1, jpi
+               zztmp = gdepw_n(ji,jj,mbkt(ji,jj)+1) 
+               zrho0_3(ji,jj) = zztmp
+               zrho0_1(ji,jj) = zztmp
+            END DO
+         END DO
+      ENDIF
+      
+      ! Preliminary computation
+      ! computation of zdelr = (dr/dT)(T,S,10m)*(-0.2 degC)
+      DO jj = 1, jpj
+         DO ji = 1, jpi
+            IF( tmask(ji,jj,nla10) == 1. ) THEN
+               zu  =  1779.50 + 11.250 * tsn(ji,jj,nla10,jp_tem) - 3.80   * tsn(ji,jj,nla10,jp_sal)                             &
+                  &                                              - 0.0745 * tsn(ji,jj,nla10,jp_tem) * tsn(ji,jj,nla10,jp_tem)   &
+                  &                                              - 0.0100 * tsn(ji,jj,nla10,jp_tem) * tsn(ji,jj,nla10,jp_sal)
+               zv  =  5891.00 + 38.000 * tsn(ji,jj,nla10,jp_tem) + 3.00   * tsn(ji,jj,nla10,jp_sal)                             &
+                  &                                              - 0.3750 * tsn(ji,jj,nla10,jp_tem) * tsn(ji,jj,nla10,jp_tem)
+               zut =    11.25 -  0.149 * tsn(ji,jj,nla10,jp_tem) - 0.01   * tsn(ji,jj,nla10,jp_sal)
+               zvt =    38.00 -  0.750 * tsn(ji,jj,nla10,jp_tem)
+               zw  = (zu + 0.698*zv) * (zu + 0.698*zv)
+               zdelr(ji,jj) = ztem2 * (1000.*(zut*zv - zvt*zu)/zw)
+            ELSE
+               zdelr(ji,jj) = 0._wp
+            ENDIF
+         END DO
+      END DO
+
+      ! ------------------------------------------------------------- !
+      ! thermocline depth: strongest vertical gradient of temperature !
+      ! turbocline depth (mixing layer depth): avt = zavt5            !
+      ! MLD: rho = rho(1) + zrho3                                     !
+      ! MLD: rho = rho(1) + zrho1                                     !
+      ! ------------------------------------------------------------- !
+      DO jk = jpkm1, 2, -1   ! loop from bottom to 2
+         DO jj = 1, jpj
+            DO ji = 1, jpi
+               !
+               zzdep = gdepw_n(ji,jj,jk)
+               zztmp = ( tsn(ji,jj,jk-1,jp_tem) - tsn(ji,jj,jk,jp_tem) ) / zzdep * tmask(ji,jj,jk)   ! vertical gradient of temperature (dT/dz)
+               zzdep = zzdep * tmask(ji,jj,1)
+
+               IF( zztmp > zmaxdzT(ji,jj) ) THEN                        
+                  zmaxdzT(ji,jj) = zztmp   ;   hth    (ji,jj) = zzdep                ! max and depth of dT/dz
+               ENDIF
+               
+               IF( nla10 > 1 ) THEN 
+                  zztmp = rhop(ji,jj,jk) - rhop(ji,jj,1)                             ! delta rho(1)
+                  IF( zztmp > zrho3 )          zrho0_3(ji,jj) = zzdep                ! > 0.03
+                  IF( zztmp > zrho1 )          zrho0_1(ji,jj) = zzdep                ! > 0.01
+               ENDIF
+
+            END DO
+         END DO
+      END DO
+      
+      CALL iom_put( "mlddzt", hth )            ! depth of the thermocline
+      IF( nla10 > 1 ) THEN 
+         CALL iom_put( "mldr0_3", zrho0_3 )   ! MLD delta rho(surf) = 0.03
+         CALL iom_put( "mldr0_1", zrho0_1 )   ! MLD delta rho(surf) = 0.01
+      ENDIF
+
+      ! ------------------------------------------------------------- !
+      ! MLD: abs( tn - tn(10m) ) = ztem2                              !
+      ! Top of thermocline: tn = tn(10m) - ztem2                      !
+      ! MLD: rho = rho10m + zrho3                                     !
+      ! pycnocline: rho = rho10m + (dr/dT)(T,S,10m)*(-0.2 degC)       !
+      ! temperature inversion: max( 0, max of tn - tn(10m) )          !
+      ! depth of temperature inversion                                !
+      ! ------------------------------------------------------------- !
+      DO jk = jpkm1, nlb10, -1   ! loop from bottom to nlb10
+         DO jj = 1, jpj
+            DO ji = 1, jpi
+               !
+               zzdep = gdepw_n(ji,jj,jk) * tmask(ji,jj,1)
+               !
+               zztmp = tsn(ji,jj,nla10,jp_tem) - tsn(ji,jj,jk,jp_tem)  ! - delta T(10m)
+               IF( ABS(zztmp) > ztem2 )      zabs2   (ji,jj) = zzdep   ! abs > 0.2
+               IF(     zztmp  > ztem2 )      ztm2    (ji,jj) = zzdep   ! > 0.2
+               zztmp = -zztmp                                          ! delta T(10m)
+               IF( zztmp >  ztinv(ji,jj) ) THEN                        ! temperature inversion
+                  ztinv(ji,jj) = zztmp   ;   zdepinv (ji,jj) = zzdep   ! max value and depth
+               ENDIF
+
+               zztmp = rhop(ji,jj,jk) - rhop(ji,jj,nla10)              ! delta rho(10m)
+               IF( zztmp > zrho3        )    zrho10_3(ji,jj) = zzdep   ! > 0.03
+               IF( zztmp > zdelr(ji,jj) )    zpycn   (ji,jj) = zzdep   ! > equi. delta T(10m) - 0.2
+               !
+            END DO
+         END DO
+      END DO
+
+      CALL iom_put( "mld_dt02", zabs2        )   ! MLD abs(delta t) - 0.2
+      CALL iom_put( "topthdep", ztm2         )   ! T(10) - 0.2
+      CALL iom_put( "mldr10_3", zrho10_3     )   ! MLD delta rho(10m) = 0.03
+      CALL iom_put( "pycndep" , zpycn        )   ! MLD delta rho equi. delta T(10m) = 0.2
+      CALL iom_put( "tinv"    , ztinv        )   ! max. temp. inv. (t10 ref) 
+      CALL iom_put( "depti"   , zdepinv      )   ! depth of max. temp. inv. (t10 ref) 
+
+
+      ! ----------------------------------- !
+      ! search deepest level above 20C/28C  !
+      ! ----------------------------------- !
+      ik20(:,:) = 1
+      ik28(:,:) = 1
+      DO jk = 1, jpkm1   ! beware temperature is not always decreasing with depth => loop from top to bottom
+         DO jj = 1, jpj
+            DO ji = 1, jpi
+               zztmp = tsn(ji,jj,jk,jp_tem)
+               IF( zztmp >= 20. )   ik20(ji,jj) = jk
+               IF( zztmp >= 28. )   ik28(ji,jj) = jk
+            END DO
+         END DO
+      END DO
+
+      ! --------------------------- !
+      !  Depth of 20C/28C isotherm  !
+      ! --------------------------- !
+      DO jj = 1, jpj
+         DO ji = 1, jpi
+            !
+            zzdep = gdepw_n(ji,jj,mbkt(ji,jj)+1)       ! depth of the oean bottom
+            !
+            iid = ik20(ji,jj)
+            IF( iid /= 1 ) THEN 
+               zztmp =      gdept_n(ji,jj,iid  )   &                     ! linear interpolation
+                  &  + (    gdept_n(ji,jj,iid+1) - gdept_n(ji,jj,iid)                       )   &
+                  &  * ( 20.*tmask(ji,jj,iid+1) - tsn(ji,jj,iid,jp_tem)                       )   &
+                  &  / ( tsn(ji,jj,iid+1,jp_tem) - tsn(ji,jj,iid,jp_tem) + (1.-tmask(ji,jj,1)) )
+               hd20(ji,jj) = MIN( zztmp , zzdep) * tmask(ji,jj,1)       ! bound by the ocean depth
+            ELSE 
+               hd20(ji,jj) = 0._wp
+            ENDIF
+            !
+            iid = ik28(ji,jj)
+            IF( iid /= 1 ) THEN 
+               zztmp =      gdept_n(ji,jj,iid  )   &                     ! linear interpolation
+                  &  + (    gdept_n(ji,jj,iid+1) - gdept_n(ji,jj,iid)                       )   &
+                  &  * ( 28.*tmask(ji,jj,iid+1) -    tsn(ji,jj,iid,jp_tem)                       )   &
+                  &  / (  tsn(ji,jj,iid+1,jp_tem) -    tsn(ji,jj,iid,jp_tem) + (1.-tmask(ji,jj,1)) )
+               hd28(ji,jj) = MIN( zztmp , zzdep ) * tmask(ji,jj,1)      ! bound by the ocean depth
+            ELSE 
+               hd28(ji,jj) = 0._wp
+            ENDIF
+
+         END DO
+      END DO
+      CALL iom_put( "20d", hd20 )   ! depth of the 20 isotherm
+      CALL iom_put( "28d", hd28 )   ! depth of the 28 isotherm
+
+      ! ----------------------------- !
+      !  Heat content of first 300 m  !
+      ! ----------------------------- !
+
+      ! find ilevel with (ilevel+1) the deepest W-level above 300m (we assume we can use e3t_1d to do this search...)
+      ilevel   = 0
+      zthick_0 = 0._wp
+      DO jk = 1, jpkm1                      
+         zthick_0 = zthick_0 + e3t_1d(jk)
+         IF( zthick_0 < 300. )   ilevel = jk
+      END DO
+      ! surface boundary condition
+      IF( ln_linssh ) THEN   ;   zthick(:,:) = sshn(:,:)   ;   htc3(:,:) = tsn(:,:,1,jp_tem) * sshn(:,:) * tmask(:,:,1)  
+      ELSE                   ;   zthick(:,:) = 0._wp       ;   htc3(:,:) = 0._wp                                   
+      ENDIF
+      ! integration down to ilevel
+      DO jk = 1, ilevel
+         zthick(:,:) = zthick(:,:) + e3t_n(:,:,jk)
+         htc3  (:,:) = htc3  (:,:) + e3t_n(:,:,jk) * tsn(:,:,jk,jp_tem) * tmask(:,:,jk)
+      END DO
+      ! deepest layer
+      zthick(:,:) = 300. - zthick(:,:)   !   remaining thickness to reach 300m
+      DO jj = 1, jpj
+         DO ji = 1, jpi
+            htc3(ji,jj) = htc3(ji,jj) + tsn(ji,jj,ilevel+1,jp_tem)                  &
+               &                      * MIN( e3t_n(ji,jj,ilevel+1), zthick(ji,jj) ) * tmask(ji,jj,ilevel+1)
+         END DO
+      END DO
+      ! from temperature to heat contain
+      zcoef = rau0 * rcp
+      htc3(:,:) = zcoef * htc3(:,:)
+      CALL iom_put( "hc300", htc3 )      ! first 300m heat content
+      !
+      IF( ln_timing )   CALL timing_stop('dia_hth')
+      !
+   END SUBROUTINE dia_hth
+
+#else
+   !!----------------------------------------------------------------------
+   !!   Default option :                                       Empty module
+   !!----------------------------------------------------------------------
+   LOGICAL , PUBLIC, PARAMETER ::   lk_diahth = .FALSE.  !: thermocline-20d depths flag
+CONTAINS
+   SUBROUTINE dia_hth( kt )         ! Empty routine
+      WRITE(*,*) 'dia_hth: You should not have seen this print! error?', kt
+   END SUBROUTINE dia_hth
+#endif
+
+   !!======================================================================
+END MODULE diahth
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DIA/dianam.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DIA/dianam.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DIA/dianam.F90	(revision 9570)
@@ -0,0 +1,136 @@
+MODULE dianam
+   !!======================================================================
+   !!                       ***  MODULE  dianam  ***
+   !! Ocean diagnostics:  Builds output file name
+   !!=====================================================================
+   !! History :  OPA  ! 1999-02  (E. Guilyardi)  Creation for 30 days/month
+   !!   NEMO     1.0  ! 2002-06  (G. Madec)  F90: Free form and module
+   !!            3.2  ! 2009-11  (S. Masson) complete rewriting, works for all calendars...
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   dia_nam       : Builds output file name
+   !!----------------------------------------------------------------------
+   USE dom_oce         ! ocean space and time domain
+   USE phycst          ! physical constants
+   USE in_out_manager  ! I/O manager
+   USE ioipsl, ONLY :  ju2ymds    ! for calendar
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC dia_nam
+
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO Consortium (2010)
+   !! $Id$ 
+   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+
+CONTAINS
+
+   SUBROUTINE dia_nam( cdfnam, kfreq, cdsuff, ldfsec )
+      !!---------------------------------------------------------------------
+      !!                  ***  ROUTINE dia_nam  ***
+      !!                   
+      !! ** Purpose :   Builds output file name
+      !!
+      !! ** Method  :   File name is a function of date and output frequency
+      !!      cdfnam=<cexper>_<clave>_<idtbeg>_<idtend>_<cdsuff>
+      !!      <clave> = averaging frequency (DA, MO, etc...)
+      !!      <idtbeg>,<idtend> date of beginning and end of run
+      !!
+      !!----------------------------------------------------------------------
+      CHARACTER (len=*), INTENT(  out)           ::   cdfnam   ! file name
+      CHARACTER (len=*), INTENT(in   )           ::   cdsuff   ! to be added at the end of the file name
+      INTEGER          , INTENT(in   )           ::   kfreq    ! output frequency: > 0 in time-step (or seconds see ldfsec)
+      !                                                                            < 0 in months
+      !                                                                            = 0 no frequency
+      LOGICAL          , INTENT(in   ), OPTIONAL ::   ldfsec   ! kfreq in second(in time-step) if .true.(.false. default)
+      !
+      CHARACTER (len=20) ::   clfmt, clfmt0                    ! writing format
+      CHARACTER (len=20) ::   clave                            ! name for output frequency
+      CHARACTER (len=20) ::   cldate1                          ! date of the beginning of run
+      CHARACTER (len=20) ::   cldate2                          ! date of the end       of run
+      LOGICAL            ::   llfsec                           ! local value of ldfsec
+      INTEGER            ::   iyear1, imonth1, iday1           ! year, month, day of the first day of the run
+      INTEGER            ::   iyear2, imonth2, iday2           ! year, month, day of the last  day of the run
+      INTEGER            ::   indg                             ! number of digits needed to write a number     
+      INTEGER            ::   inbsec, inbmn, inbhr             ! output frequency in seconds, minutes and hours
+      INTEGER            ::   inbday, inbmo, inbyr             ! output frequency in days, months and years
+      INTEGER            ::   iyyss, iddss, ihhss, immss       ! number of seconds in 1 year, 1 day, 1 hour and 1 minute
+      INTEGER            ::   iyymo                            ! number of months in 1 year
+      REAL(wp)           ::   zsec1, zsec2                     ! not used
+      REAL(wp)           ::   zdrun, zjul                      ! temporary scalars
+      !!----------------------------------------------------------------------
+
+      ! name for output frequency
+
+      IF( PRESENT(ldfsec) ) THEN   ;   llfsec = ldfsec
+      ELSE                         ;   llfsec = .FALSE.
+      ENDIF
+
+      IF( llfsec .OR. kfreq < 0 ) THEN   ;   inbsec = kfreq                       ! output frequency already in seconds
+      ELSE                               ;   inbsec = kfreq * NINT( rdt )   ! from time-step to seconds
+      ENDIF
+      iddss = NINT( rday          )                                         ! number of seconds in 1 day
+      ihhss = NINT( rmmss * rhhmm )                                         ! number of seconds in 1 hour
+      immss = NINT( rmmss         )                                         ! number of seconds in 1 minute
+      iyymo = NINT( raamo         )                                         ! number of months  in 1 year
+      iyyss = iddss * nyear_len(1)                                          ! seconds in 1 year (not good: multi years with leap)
+      clfmt0 = "('(a,i',i1,',a)')"                                          ! format '(a,ix,a)' with x to be defined
+      ! 
+      IF(          inbsec == 0           ) THEN   ;   clave = ''            ! no frequency
+      ELSEIF(      inbsec <  0           ) THEN        
+         inbmo = -inbsec                                                    ! frequency in month
+         IF( MOD( inbmo, iyymo  ) == 0 ) THEN                               ! frequency in years
+            inbyr  = inbmo / iyymo
+            indg   = INT(LOG10(REAL(inbyr,wp))) + 1                         ! number of digits needed to write years   frequency
+            WRITE(clfmt, clfmt0) indg             ;   WRITE(clave, clfmt) '_', inbyr , 'y'
+         ELSE                                                               ! frequency in month
+            indg   = INT(LOG10(REAL(inbmo,wp))) + 1                         ! number of digits needed to write months  frequency
+            WRITE(clfmt, clfmt0) indg             ;   WRITE(clave, clfmt) '_', inbmo, 'm'
+         ENDIF
+      ELSEIF( MOD( inbsec, iyyss  ) == 0 ) THEN                             ! frequency in years
+         inbyr  = inbsec / iyyss
+         indg   = INT(LOG10(REAL(inbyr ,wp))) + 1                           ! number of digits needed to write years   frequency
+         WRITE(clfmt, clfmt0) indg                ;   WRITE(clave, clfmt) '_', inbyr , 'y'
+      ELSEIF( MOD( inbsec, iddss  ) == 0 ) THEN                             ! frequency in days
+         inbday = inbsec / iddss
+         indg   = INT(LOG10(REAL(inbday,wp))) + 1                           ! number of digits needed to write days    frequency
+         WRITE(clfmt, clfmt0) indg                ;   WRITE(clave, clfmt) '_', inbday, 'd'
+         IF( inbday == nmonth_len(nmonth) )           clave = '_1m'
+      ELSEIF( MOD( inbsec, ihhss ) == 0 ) THEN                              ! frequency in hours
+         inbhr  = inbsec / ihhss
+         indg   = INT(LOG10(REAL(inbhr ,wp))) + 1                           ! number of digits needed to write hours   frequency
+         WRITE(clfmt, clfmt0) indg                ;   WRITE(clave, clfmt) '_', inbhr , 'h'
+      ELSEIF( MOD( inbsec, immss ) == 0 ) THEN                              ! frequency in minutes
+         inbmn  = inbsec / immss
+         indg   = INT(LOG10(REAL(inbmn ,wp))) + 1                           ! number of digits needed to write minutes frequency
+         WRITE(clfmt, clfmt0) indg                ;   WRITE(clave, clfmt) '_', inbmn , 'mn'
+      ELSE                                                                  ! frequency in seconds
+         indg   = INT(LOG10(REAL(inbsec,wp))) + 1                           ! number of digits needed to write seconds frequency
+         WRITE(clfmt, clfmt0) indg                ;   WRITE(clave, clfmt) '_', inbsec, 's'
+      ENDIF
+
+      ! date of the beginning and the end of the run
+
+      zdrun = rdt / rday * REAL( nitend - nit000, wp )                ! length of the run in days
+      zjul  = fjulday - rdt / rday
+      CALL ju2ymds( zjul        , iyear1, imonth1, iday1, zsec1 )           ! year/month/day of the beginning of run
+      CALL ju2ymds( zjul + zdrun, iyear2, imonth2, iday2, zsec2 )           ! year/month/day of the end       of run
+
+      IF( iyear2 < 10000 ) THEN   ;   clfmt = "(i4.4,2i2.2)"                ! format used to write the date 
+      ELSE                        ;   WRITE(clfmt, "('(i',i1,',2i2.2)')") INT(LOG10(REAL(iyear2,wp))) + 1
+      ENDIF
+
+      WRITE(cldate1, clfmt) iyear1, imonth1, iday1                          ! date of the beginning of run
+      WRITE(cldate2, clfmt) iyear2, imonth2, iday2                          ! date of the end       of run
+ 
+      cdfnam = TRIM(cexper)//TRIM(clave)//"_"//TRIM(cldate1)//"_"//TRIM(cldate2)//"_"//TRIM(cdsuff)
+      IF( .NOT. Agrif_Root() ) cdfnam = TRIM(Agrif_CFixed())//'_'//TRIM(cdfnam)
+
+   END SUBROUTINE dia_nam
+
+   !!======================================================================
+END MODULE dianam
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DIA/diaptr.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DIA/diaptr.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DIA/diaptr.F90	(revision 9570)
@@ -0,0 +1,706 @@
+MODULE diaptr
+   !!======================================================================
+   !!                       ***  MODULE  diaptr  ***
+   !! Ocean physics:  Computes meridonal transports and zonal means
+   !!=====================================================================
+   !! History :  1.0  ! 2003-09  (C. Talandier, G. Madec)  Original code
+   !!            2.0  ! 2006-01  (A. Biastoch)  Allow sub-basins computation
+   !!            3.2  ! 2010-03  (O. Marti, S. Flavoni) Add fields
+   !!            3.3  ! 2010-10  (G. Madec)  dynamical allocation
+   !!            3.6  ! 2014-12  (C. Ethe) use of IOM
+   !!            3.6  ! 2016-06  (T. Graham) Addition of diagnostics for CMIP6
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   dia_ptr      : Poleward Transport Diagnostics module
+   !!   dia_ptr_init : Initialization, namelist read
+   !!   ptr_sjk      : "zonal" mean computation of a field - tracer or flux array
+   !!   ptr_sj       : "zonal" and vertical sum computation of a "meridional" flux array
+   !!                   (Generic interface to ptr_sj_3d, ptr_sj_2d)
+   !!----------------------------------------------------------------------
+   USE oce              ! ocean dynamics and active tracers
+   USE dom_oce          ! ocean space and time domain
+   USE phycst           ! physical constants
+   !
+   USE iom              ! IOM library
+   USE in_out_manager   ! I/O manager
+   USE lib_mpp          ! MPP library
+   USE timing           ! preformance summary
+
+   IMPLICIT NONE
+   PRIVATE
+
+   INTERFACE ptr_sj
+      MODULE PROCEDURE ptr_sj_3d, ptr_sj_2d
+   END INTERFACE
+
+   PUBLIC   ptr_sj         ! call by tra_ldf & tra_adv routines
+   PUBLIC   ptr_sjk        ! 
+   PUBLIC   dia_ptr_init   ! call in memogcm
+   PUBLIC   dia_ptr        ! call in step module
+   PUBLIC   dia_ptr_hst    ! called from tra_ldf/tra_adv routines
+
+   !                                  !!** namelist  namptr  **
+   REAL(wp), ALLOCATABLE, SAVE, PUBLIC, DIMENSION(:,:) ::   htr_adv, htr_ldf, htr_eiv   !: Heat TRansports (adv, diff, Bolus.)
+   REAL(wp), ALLOCATABLE, SAVE, PUBLIC, DIMENSION(:,:) ::   str_adv, str_ldf, str_eiv   !: Salt TRansports (adv, diff, Bolus.)
+   REAL(wp), ALLOCATABLE, SAVE, PUBLIC, DIMENSION(:,:) ::   htr_ove, str_ove   !: heat Salt TRansports ( overturn.)
+   REAL(wp), ALLOCATABLE, SAVE, PUBLIC, DIMENSION(:,:) ::   htr_btr, str_btr   !: heat Salt TRansports ( barotropic )
+
+   LOGICAL, PUBLIC ::   ln_diaptr   !  Poleward transport flag (T) or not (F)
+   LOGICAL, PUBLIC ::   ln_subbas   !  Atlantic/Pacific/Indian basins calculation
+   INTEGER, PUBLIC ::   nptr        ! = 1 (l_subbas=F) or = 5 (glo, atl, pac, ind, ipc) (l_subbas=T) 
+
+   REAL(wp) ::   rc_sv    = 1.e-6_wp   ! conversion from m3/s to Sverdrup
+   REAL(wp) ::   rc_pwatt = 1.e-15_wp  ! conversion from W    to PW (further x rau0 x Cp)
+   REAL(wp) ::   rc_ggram = 1.e-6_wp   ! conversion from g    to Pg
+
+   CHARACTER(len=3), ALLOCATABLE, SAVE, DIMENSION(:)     :: clsubb
+   REAL(wp),         ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: btmsk   ! T-point basin interior masks
+   REAL(wp),         ALLOCATABLE, SAVE, DIMENSION(:,:)   :: btm30   ! mask out Southern Ocean (=0 south of 30°S)
+
+   REAL(wp), TARGET, ALLOCATABLE, SAVE, DIMENSION(:)     :: p_fval1d
+   REAL(wp), TARGET, ALLOCATABLE, SAVE, DIMENSION(:,:)   :: p_fval2d
+
+   !! * Substitutions
+#  include "vectopt_loop_substitute.h90"
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO Consortium (2010)
+   !! $Id$ 
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE dia_ptr( pvtr )
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE dia_ptr  ***
+      !!----------------------------------------------------------------------
+      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in), OPTIONAL ::   pvtr   ! j-effective transport
+      !
+      INTEGER  ::   ji, jj, jk, jn   ! dummy loop indices
+      REAL(wp) ::   zsfc,zvfc               ! local scalar
+      REAL(wp), DIMENSION(jpi,jpj)     ::  z2d   ! 2D workspace
+      REAL(wp), DIMENSION(jpi,jpj,jpk) ::  z3d   ! 3D workspace
+      REAL(wp), DIMENSION(jpi,jpj,jpk) ::  zmask   ! 3D workspace
+      REAL(wp), DIMENSION(jpi,jpj,jpk,jpts) ::  zts   ! 3D workspace
+      REAL(wp), DIMENSION(jpj)     ::  vsum   ! 1D workspace
+      REAL(wp), DIMENSION(jpj,jpts)     ::  tssum   ! 1D workspace
+ 
+      !
+      !overturning calculation
+      REAL(wp), DIMENSION(jpj,jpk,nptr) ::   sjk  , r1_sjk ! i-mean i-k-surface and its inverse
+      REAL(wp), DIMENSION(jpj,jpk,nptr) ::   v_msf, sn_jk  , tn_jk ! i-mean T and S, j-Stream-Function
+      REAL(wp), DIMENSION(jpi,jpj,jpk) ::  zvn   ! 3D workspace
+
+
+      CHARACTER( len = 12 )  :: cl1
+      !!----------------------------------------------------------------------
+      !
+      IF( ln_timing )   CALL timing_start('dia_ptr')
+
+      !
+      IF( PRESENT( pvtr ) ) THEN
+         IF( iom_use("zomsfglo") ) THEN    ! effective MSF
+            z3d(1,:,:) = ptr_sjk( pvtr(:,:,:) )  ! zonal cumulative effective transport
+            DO jk = 2, jpkm1 
+              z3d(1,:,jk) = z3d(1,:,jk-1) + z3d(1,:,jk)   ! effective j-Stream-Function (MSF)
+            END DO
+            DO ji = 1, jpi
+               z3d(ji,:,:) = z3d(1,:,:)
+            ENDDO
+            cl1 = TRIM('zomsf'//clsubb(1) )
+            CALL iom_put( cl1, z3d * rc_sv )
+            DO jn = 2, nptr                                    ! by sub-basins
+               z3d(1,:,:) =  ptr_sjk( pvtr(:,:,:), btmsk(:,:,jn)*btm30(:,:) ) 
+               DO jk = 2, jpkm1 
+                  z3d(1,:,jk) = z3d(1,:,jk-1) + z3d(1,:,jk)    ! effective j-Stream-Function (MSF)
+               END DO
+               DO ji = 1, jpi
+                  z3d(ji,:,:) = z3d(1,:,:)
+               ENDDO
+               cl1 = TRIM('zomsf'//clsubb(jn) )
+               CALL iom_put( cl1, z3d * rc_sv )
+            END DO
+         ENDIF
+         IF( iom_use("sopstove") .OR. iom_use("sophtove") .OR. iom_use("sopstbtr") .OR. iom_use("sophtbtr") ) THEN
+            ! define fields multiplied by scalar
+            zmask(:,:,:) = 0._wp
+            zts(:,:,:,:) = 0._wp
+            zvn(:,:,:) = 0._wp
+            DO jk = 1, jpkm1
+               DO jj = 1, jpjm1
+                  DO ji = 1, jpi
+                     zvfc = e1v(ji,jj) * e3v_n(ji,jj,jk)
+                     zmask(ji,jj,jk)      = vmask(ji,jj,jk)      * zvfc
+                     zts(ji,jj,jk,jp_tem) = (tsn(ji,jj,jk,jp_tem)+tsn(ji,jj+1,jk,jp_tem)) * 0.5 * zvfc  !Tracers averaged onto V grid
+                     zts(ji,jj,jk,jp_sal) = (tsn(ji,jj,jk,jp_sal)+tsn(ji,jj+1,jk,jp_sal)) * 0.5 * zvfc
+                     zvn(ji,jj,jk)        = vn(ji,jj,jk)         * zvfc
+                  ENDDO
+               ENDDO
+             ENDDO
+         ENDIF
+         IF( iom_use("sopstove") .OR. iom_use("sophtove") ) THEN
+             sjk(:,:,1) = ptr_sjk( zmask(:,:,:), btmsk(:,:,1) )
+             r1_sjk(:,:,1) = 0._wp
+             WHERE( sjk(:,:,1) /= 0._wp )   r1_sjk(:,:,1) = 1._wp / sjk(:,:,1)
+
+             ! i-mean T and S, j-Stream-Function, global
+             tn_jk(:,:,1) = ptr_sjk( zts(:,:,:,jp_tem) ) * r1_sjk(:,:,1)
+             sn_jk(:,:,1) = ptr_sjk( zts(:,:,:,jp_sal) ) * r1_sjk(:,:,1)
+             v_msf(:,:,1) = ptr_sjk( zvn(:,:,:) )
+
+             htr_ove(:,1) = SUM( v_msf(:,:,1)*tn_jk(:,:,1) ,2 )
+             str_ove(:,1) = SUM( v_msf(:,:,1)*sn_jk(:,:,1) ,2 )
+
+             z2d(1,:) = htr_ove(:,1) * rc_pwatt        !  (conversion in PW)
+             DO ji = 1, jpi
+               z2d(ji,:) = z2d(1,:)
+             ENDDO
+             cl1 = 'sophtove'
+             CALL iom_put( TRIM(cl1), z2d )
+             z2d(1,:) = str_ove(:,1) * rc_ggram        !  (conversion in Gg)
+             DO ji = 1, jpi
+               z2d(ji,:) = z2d(1,:)
+             ENDDO
+             cl1 = 'sopstove'
+             CALL iom_put( TRIM(cl1), z2d )
+             IF( ln_subbas ) THEN
+                DO jn = 2, nptr
+                    sjk(:,:,jn) = ptr_sjk( zmask(:,:,:), btmsk(:,:,jn) )
+                    r1_sjk(:,:,jn) = 0._wp
+                    WHERE( sjk(:,:,jn) /= 0._wp )   r1_sjk(:,:,jn) = 1._wp / sjk(:,:,jn)
+
+                    ! i-mean T and S, j-Stream-Function, basin
+                    tn_jk(:,:,jn) = ptr_sjk( zts(:,:,:,jp_tem), btmsk(:,:,jn) ) * r1_sjk(:,:,jn)
+                    sn_jk(:,:,jn) = ptr_sjk( zts(:,:,:,jp_sal), btmsk(:,:,jn) ) * r1_sjk(:,:,jn)
+                    v_msf(:,:,jn) = ptr_sjk( zvn(:,:,:), btmsk(:,:,jn) ) 
+                    htr_ove(:,jn) = SUM( v_msf(:,:,jn)*tn_jk(:,:,jn) ,2 )
+                    str_ove(:,jn) = SUM( v_msf(:,:,jn)*sn_jk(:,:,jn) ,2 )
+
+                    z2d(1,:) = htr_ove(:,jn) * rc_pwatt !  (conversion in PW)
+                    DO ji = 1, jpi
+                        z2d(ji,:) = z2d(1,:)
+                    ENDDO
+                    cl1 = TRIM('sophtove_'//clsubb(jn))
+                    CALL iom_put( cl1, z2d )
+                    z2d(1,:) = str_ove(:,jn) * rc_ggram        ! (conversion in Gg)
+                    DO ji = 1, jpi
+                        z2d(ji,:) = z2d(1,:)
+                    ENDDO
+                    cl1 = TRIM('sopstove_'//clsubb(jn))
+                    CALL iom_put( cl1, z2d )
+                END DO
+             ENDIF
+         ENDIF
+         IF( iom_use("sopstbtr") .OR. iom_use("sophtbtr") ) THEN
+         ! Calculate barotropic heat and salt transport here 
+             sjk(:,1,1) = ptr_sj( zmask(:,:,:), btmsk(:,:,1) )
+             r1_sjk(:,1,1) = 0._wp
+             WHERE( sjk(:,1,1) /= 0._wp )   r1_sjk(:,1,1) = 1._wp / sjk(:,1,1)
+            
+            vsum = ptr_sj( zvn(:,:,:), btmsk(:,:,1))
+            tssum(:,jp_tem) = ptr_sj( zts(:,:,:,jp_tem), btmsk(:,:,1) )
+            tssum(:,jp_sal) = ptr_sj( zts(:,:,:,jp_sal), btmsk(:,:,1) )
+            htr_btr(:,1) = vsum * tssum(:,jp_tem) * r1_sjk(:,1,1)
+            str_btr(:,1) = vsum * tssum(:,jp_sal) * r1_sjk(:,1,1)
+            z2d(1,:) = htr_btr(:,1) * rc_pwatt        !  (conversion in PW)
+            DO ji = 2, jpi
+               z2d(ji,:) = z2d(1,:)
+            ENDDO
+            cl1 = 'sophtbtr'
+            CALL iom_put( TRIM(cl1), z2d )
+            z2d(1,:) = str_btr(:,1) * rc_ggram        !  (conversion in Gg)
+            DO ji = 2, jpi
+              z2d(ji,:) = z2d(1,:)
+            ENDDO
+            cl1 = 'sopstbtr'
+            CALL iom_put( TRIM(cl1), z2d )
+            IF( ln_subbas ) THEN
+                DO jn = 2, nptr
+                    sjk(:,1,jn) = ptr_sj( zmask(:,:,:), btmsk(:,:,jn) )
+                    r1_sjk(:,1,jn) = 0._wp
+                    WHERE( sjk(:,1,jn) /= 0._wp )   r1_sjk(:,1,jn) = 1._wp / sjk(:,1,jn)
+                    vsum = ptr_sj( zvn(:,:,:), btmsk(:,:,jn))
+                    tssum(:,jp_tem) = ptr_sj( zts(:,:,:,jp_tem), btmsk(:,:,jn) )
+                    tssum(:,jp_sal) = ptr_sj( zts(:,:,:,jp_sal), btmsk(:,:,jn) )
+                    htr_btr(:,jn) = vsum * tssum(:,jp_tem) * r1_sjk(:,1,jn)
+                    str_btr(:,jn) = vsum * tssum(:,jp_sal) * r1_sjk(:,1,jn)
+                    z2d(1,:) = htr_btr(:,jn) * rc_pwatt !  (conversion in PW)
+                    DO ji = 1, jpi
+                        z2d(ji,:) = z2d(1,:)
+                    ENDDO
+                    cl1 = TRIM('sophtbtr_'//clsubb(jn))
+                    CALL iom_put( cl1, z2d )
+                    z2d(1,:) = str_btr(:,jn) * rc_ggram        ! (conversion in Gg)
+                    DO ji = 1, jpi
+                        z2d(ji,:) = z2d(1,:)
+                    ENDDO
+                    cl1 = TRIM('sopstbtr_'//clsubb(jn))
+                    CALL iom_put( cl1, z2d )
+               ENDDO
+            ENDIF !ln_subbas
+         ENDIF !iom_use("sopstbtr....)
+         !
+      ELSE
+         !
+         IF( iom_use("zotemglo") ) THEN    ! i-mean i-k-surface 
+            DO jk = 1, jpkm1
+               DO jj = 1, jpj
+                  DO ji = 1, jpi
+                     zsfc = e1t(ji,jj) * e3t_n(ji,jj,jk)
+                     zmask(ji,jj,jk)      = tmask(ji,jj,jk)      * zsfc
+                     zts(ji,jj,jk,jp_tem) = tsn(ji,jj,jk,jp_tem) * zsfc
+                     zts(ji,jj,jk,jp_sal) = tsn(ji,jj,jk,jp_sal) * zsfc
+                  END DO
+               END DO
+            END DO
+            DO jn = 1, nptr
+               zmask(1,:,:) = ptr_sjk( zmask(:,:,:), btmsk(:,:,jn) )
+               cl1 = TRIM('zosrf'//clsubb(jn) )
+               CALL iom_put( cl1, zmask )
+               !
+               z3d(1,:,:) = ptr_sjk( zts(:,:,:,jp_tem), btmsk(:,:,jn) ) &
+                  &            / MAX( zmask(1,:,:), 10.e-15 )
+               DO ji = 1, jpi
+                  z3d(ji,:,:) = z3d(1,:,:)
+               ENDDO
+               cl1 = TRIM('zotem'//clsubb(jn) )
+               CALL iom_put( cl1, z3d )
+               !
+               z3d(1,:,:) = ptr_sjk( zts(:,:,:,jp_sal), btmsk(:,:,jn) ) &
+                  &            / MAX( zmask(1,:,:), 10.e-15 )
+               DO ji = 1, jpi
+                  z3d(ji,:,:) = z3d(1,:,:)
+               ENDDO
+               cl1 = TRIM('zosal'//clsubb(jn) )
+               CALL iom_put( cl1, z3d )
+            END DO
+         ENDIF
+         !
+         !                                ! Advective and diffusive heat and salt transport
+         IF( iom_use("sophtadv") .OR. iom_use("sopstadv") ) THEN   
+            z2d(1,:) = htr_adv(:,1) * rc_pwatt        !  (conversion in PW)
+            DO ji = 1, jpi
+               z2d(ji,:) = z2d(1,:)
+            ENDDO
+            cl1 = 'sophtadv'                 
+            CALL iom_put( TRIM(cl1), z2d )
+            z2d(1,:) = str_adv(:,1) * rc_ggram        ! (conversion in Gg)
+            DO ji = 1, jpi
+               z2d(ji,:) = z2d(1,:)
+            ENDDO
+            cl1 = 'sopstadv'
+            CALL iom_put( TRIM(cl1), z2d )
+            IF( ln_subbas ) THEN
+              DO jn=2,nptr
+               z2d(1,:) = htr_adv(:,jn) * rc_pwatt        !  (conversion in PW)
+               DO ji = 1, jpi
+                 z2d(ji,:) = z2d(1,:)
+               ENDDO
+               cl1 = TRIM('sophtadv_'//clsubb(jn))                 
+               CALL iom_put( cl1, z2d )
+               z2d(1,:) = str_adv(:,jn) * rc_ggram        ! (conversion in Gg)
+               DO ji = 1, jpi
+                  z2d(ji,:) = z2d(1,:)
+               ENDDO
+               cl1 = TRIM('sopstadv_'//clsubb(jn))                 
+               CALL iom_put( cl1, z2d )              
+              ENDDO
+            ENDIF
+         ENDIF
+         !
+         IF( iom_use("sophtldf") .OR. iom_use("sopstldf") ) THEN   
+            z2d(1,:) = htr_ldf(:,1) * rc_pwatt        !  (conversion in PW) 
+            DO ji = 1, jpi
+               z2d(ji,:) = z2d(1,:)
+            ENDDO
+            cl1 = 'sophtldf'
+            CALL iom_put( TRIM(cl1), z2d )
+            z2d(1,:) = str_ldf(:,1) * rc_ggram        !  (conversion in Gg)
+            DO ji = 1, jpi
+               z2d(ji,:) = z2d(1,:)
+            ENDDO
+            cl1 = 'sopstldf'
+            CALL iom_put( TRIM(cl1), z2d )
+            IF( ln_subbas ) THEN
+              DO jn=2,nptr
+               z2d(1,:) = htr_ldf(:,jn) * rc_pwatt        !  (conversion in PW)
+               DO ji = 1, jpi
+                 z2d(ji,:) = z2d(1,:)
+               ENDDO
+               cl1 = TRIM('sophtldf_'//clsubb(jn))                 
+               CALL iom_put( cl1, z2d )
+               z2d(1,:) = str_ldf(:,jn) * rc_ggram        ! (conversion in Gg)
+               DO ji = 1, jpi
+                  z2d(ji,:) = z2d(1,:)
+               ENDDO
+               cl1 = TRIM('sopstldf_'//clsubb(jn))                 
+               CALL iom_put( cl1, z2d )              
+              ENDDO
+            ENDIF
+         ENDIF
+
+         IF( iom_use("sophteiv") .OR. iom_use("sopsteiv") ) THEN 
+            z2d(1,:) = htr_eiv(:,1) * rc_pwatt        !  (conversion in PW) 
+            DO ji = 1, jpi
+               z2d(ji,:) = z2d(1,:)
+            ENDDO
+            cl1 = 'sophteiv'
+            CALL iom_put( TRIM(cl1), z2d )
+            z2d(1,:) = str_eiv(:,1) * rc_ggram        !  (conversion in Gg)
+            DO ji = 1, jpi
+               z2d(ji,:) = z2d(1,:)
+            ENDDO
+            cl1 = 'sopsteiv'
+            CALL iom_put( TRIM(cl1), z2d )
+            IF( ln_subbas ) THEN
+               DO jn=2,nptr
+                  z2d(1,:) = htr_eiv(:,jn) * rc_pwatt        !  (conversion in PW)
+                  DO ji = 1, jpi
+                     z2d(ji,:) = z2d(1,:)
+                  ENDDO
+                  cl1 = TRIM('sophteiv_'//clsubb(jn))                 
+                  CALL iom_put( cl1, z2d )
+                  z2d(1,:) = str_eiv(:,jn) * rc_ggram        ! (conversion in Gg)
+                  DO ji = 1, jpi
+                     z2d(ji,:) = z2d(1,:)
+                  ENDDO
+                  cl1 = TRIM('sopsteiv_'//clsubb(jn)) 
+                  CALL iom_put( cl1, z2d )              
+               ENDDO
+            ENDIF
+         ENDIF
+         !
+      ENDIF
+      !
+      IF( ln_timing )   CALL timing_stop('dia_ptr')
+      !
+   END SUBROUTINE dia_ptr
+
+
+   SUBROUTINE dia_ptr_init
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE dia_ptr_init  ***
+      !!                   
+      !! ** Purpose :   Initialization, namelist read
+      !!----------------------------------------------------------------------
+      INTEGER ::  jn           ! local integers
+      INTEGER ::  inum, ierr   ! local integers
+      INTEGER ::  ios          ! Local integer output status for namelist read
+      !!
+      NAMELIST/namptr/ ln_diaptr, ln_subbas
+      !!----------------------------------------------------------------------
+
+      REWIND( numnam_ref )              ! Namelist namptr in reference namelist : Poleward transport
+      READ  ( numnam_ref, namptr, IOSTAT = ios, ERR = 901)
+901   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namptr in reference namelist', lwp )
+
+      REWIND( numnam_cfg )              ! Namelist namptr in configuration namelist : Poleward transport
+      READ  ( numnam_cfg, namptr, IOSTAT = ios, ERR = 902 )
+902   IF( ios >  0 ) CALL ctl_nam ( ios , 'namptr in configuration namelist', lwp )
+      IF(lwm) WRITE ( numond, namptr )
+
+      IF(lwp) THEN                     ! Control print
+         WRITE(numout,*)
+         WRITE(numout,*) 'dia_ptr_init : poleward transport and msf initialization'
+         WRITE(numout,*) '~~~~~~~~~~~~'
+         WRITE(numout,*) '   Namelist namptr : set ptr parameters'
+         WRITE(numout,*) '      Poleward heat & salt transport (T) or not (F)      ln_diaptr  = ', ln_diaptr
+         WRITE(numout,*) '      Global (F) or glo/Atl/Pac/Ind/Indo-Pac basins      ln_subbas  = ', ln_subbas
+      ENDIF
+
+      IF( ln_diaptr ) THEN  
+         !
+         IF( ln_subbas ) THEN 
+            nptr = 5            ! Global, Atlantic, Pacific, Indian, Indo-Pacific
+            ALLOCATE( clsubb(nptr) )
+            clsubb(1) = 'glo' ;  clsubb(2) = 'atl'  ;  clsubb(3) = 'pac'  ;  clsubb(4) = 'ind'  ;  clsubb(5) = 'ipc'
+         ELSE               
+            nptr = 1       ! Global only
+            ALLOCATE( clsubb(nptr) )
+            clsubb(1) = 'glo' 
+         ENDIF
+
+         !                                      ! allocate dia_ptr arrays
+         IF( dia_ptr_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'dia_ptr_init : unable to allocate arrays' )
+
+         rc_pwatt = rc_pwatt * rau0_rcp          ! conversion from K.s-1 to PetaWatt
+
+         IF( lk_mpp )   CALL mpp_ini_znl( numout )     ! Define MPI communicator for zonal sum
+
+         IF( ln_subbas ) THEN                ! load sub-basin mask
+            CALL iom_open( 'subbasins', inum,  ldstop = .FALSE.  )
+            CALL iom_get( inum, jpdom_data, 'atlmsk', btmsk(:,:,2) )   ! Atlantic basin
+            CALL iom_get( inum, jpdom_data, 'pacmsk', btmsk(:,:,3) )   ! Pacific  basin
+            CALL iom_get( inum, jpdom_data, 'indmsk', btmsk(:,:,4) )   ! Indian   basin
+            CALL iom_close( inum )
+            btmsk(:,:,5) = MAX ( btmsk(:,:,3), btmsk(:,:,4) )          ! Indo-Pacific basin
+            WHERE( gphit(:,:) < -30._wp)   ;   btm30(:,:) = 0._wp      ! mask out Southern Ocean
+            ELSE WHERE                     ;   btm30(:,:) = ssmask(:,:)
+            END WHERE
+         ENDIF
+   
+         btmsk(:,:,1) = tmask_i(:,:)                                   ! global ocean
+      
+         DO jn = 1, nptr
+            btmsk(:,:,jn) = btmsk(:,:,jn) * tmask_i(:,:)               ! interior domain only
+         END DO
+
+         ! Initialise arrays to zero because diatpr is called before they are first calculated
+         ! Note that this means diagnostics will not be exactly correct when model run is restarted.
+         htr_adv(:,:) = 0._wp  ;  str_adv(:,:) =  0._wp 
+         htr_ldf(:,:) = 0._wp  ;  str_ldf(:,:) =  0._wp 
+         htr_eiv(:,:) = 0._wp  ;  str_eiv(:,:) =  0._wp 
+         htr_ove(:,:) = 0._wp  ;   str_ove(:,:) =  0._wp
+         htr_btr(:,:) = 0._wp  ;   str_btr(:,:) =  0._wp
+         !
+      ENDIF 
+      ! 
+   END SUBROUTINE dia_ptr_init
+
+
+   SUBROUTINE dia_ptr_hst( ktra, cptr, pva ) 
+      !!----------------------------------------------------------------------
+      !!                    ***  ROUTINE dia_ptr_hst ***
+      !!----------------------------------------------------------------------
+      !! Wrapper for heat and salt transport calculations to calculate them for each basin
+      !! Called from all advection and/or diffusion routines
+      !!----------------------------------------------------------------------
+      INTEGER                         , INTENT(in )  :: ktra  ! tracer index
+      CHARACTER(len=3)                , INTENT(in)   :: cptr  ! transport type  'adv'/'ldf'/'eiv'
+      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in)   :: pva   ! 3D input array of advection/diffusion
+      INTEGER                                        :: jn    !
+
+      IF( cptr == 'adv' ) THEN
+         IF( ktra == jp_tem )  htr_adv(:,1) = ptr_sj( pva(:,:,:) )
+         IF( ktra == jp_sal )  str_adv(:,1) = ptr_sj( pva(:,:,:) )
+      ENDIF
+      IF( cptr == 'ldf' ) THEN
+         IF( ktra == jp_tem )  htr_ldf(:,1) = ptr_sj( pva(:,:,:) )
+         IF( ktra == jp_sal )  str_ldf(:,1) = ptr_sj( pva(:,:,:) )
+      ENDIF
+      IF( cptr == 'eiv' ) THEN
+         IF( ktra == jp_tem )  htr_eiv(:,1) = ptr_sj( pva(:,:,:) )
+         IF( ktra == jp_sal )  str_eiv(:,1) = ptr_sj( pva(:,:,:) )
+      ENDIF
+      !
+      IF( ln_subbas ) THEN
+         !
+         IF( cptr == 'adv' ) THEN
+             IF( ktra == jp_tem ) THEN 
+                DO jn = 2, nptr
+                   htr_adv(:,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) )
+                END DO
+             ENDIF
+             IF( ktra == jp_sal ) THEN 
+                DO jn = 2, nptr
+                   str_adv(:,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) )
+                END DO
+             ENDIF
+         ENDIF
+         IF( cptr == 'ldf' ) THEN
+             IF( ktra == jp_tem ) THEN 
+                DO jn = 2, nptr
+                    htr_ldf(:,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) )
+                 END DO
+             ENDIF
+             IF( ktra == jp_sal ) THEN 
+                DO jn = 2, nptr
+                   str_ldf(:,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) )
+                END DO
+             ENDIF
+         ENDIF
+         IF( cptr == 'eiv' ) THEN
+             IF( ktra == jp_tem ) THEN 
+                DO jn = 2, nptr
+                    htr_eiv(:,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) )
+                 END DO
+             ENDIF
+             IF( ktra == jp_sal ) THEN 
+                DO jn = 2, nptr
+                   str_eiv(:,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) )
+                END DO
+             ENDIF
+         ENDIF
+         !
+      ENDIF
+   END SUBROUTINE dia_ptr_hst
+
+
+   FUNCTION dia_ptr_alloc()
+      !!----------------------------------------------------------------------
+      !!                    ***  ROUTINE dia_ptr_alloc  ***
+      !!----------------------------------------------------------------------
+      INTEGER               ::   dia_ptr_alloc   ! return value
+      INTEGER, DIMENSION(3) ::   ierr
+      !!----------------------------------------------------------------------
+      ierr(:) = 0
+      !
+      ALLOCATE( btmsk(jpi,jpj,nptr) ,              &
+         &      htr_adv(jpj,nptr) , str_adv(jpj,nptr) ,   &
+         &      htr_eiv(jpj,nptr) , str_eiv(jpj,nptr) ,   &
+         &      htr_ove(jpj,nptr) , str_ove(jpj,nptr) ,   &
+         &      htr_btr(jpj,nptr) , str_btr(jpj,nptr) ,   &
+         &      htr_ldf(jpj,nptr) , str_ldf(jpj,nptr) , STAT=ierr(1)  )
+         !
+      ALLOCATE( p_fval1d(jpj), p_fval2d(jpj,jpk), Stat=ierr(2))
+      !
+      ALLOCATE( btm30(jpi,jpj), STAT=ierr(3)  )
+
+         !
+      dia_ptr_alloc = MAXVAL( ierr )
+      IF(lk_mpp)   CALL mpp_sum( dia_ptr_alloc )
+      !
+   END FUNCTION dia_ptr_alloc
+
+
+   FUNCTION ptr_sj_3d( pva, pmsk )   RESULT ( p_fval )
+      !!----------------------------------------------------------------------
+      !!                    ***  ROUTINE ptr_sj_3d  ***
+      !!
+      !! ** Purpose :   i-k sum computation of a j-flux array
+      !!
+      !! ** Method  : - i-k sum of pva using the interior 2D vmask (vmask_i).
+      !!              pva is supposed to be a masked flux (i.e. * vmask*e1v*e3v)
+      !!
+      !! ** Action  : - p_fval: i-k-mean poleward flux of pva
+      !!----------------------------------------------------------------------
+      REAL(wp), INTENT(in), DIMENSION(jpi,jpj,jpk)       ::   pva   ! mask flux array at V-point
+      REAL(wp), INTENT(in), DIMENSION(jpi,jpj), OPTIONAL ::   pmsk   ! Optional 2D basin mask
+      !
+      INTEGER                  ::   ji, jj, jk   ! dummy loop arguments
+      INTEGER                  ::   ijpj         ! ???
+      REAL(wp), POINTER, DIMENSION(:) :: p_fval  ! function value
+      !!--------------------------------------------------------------------
+      !
+      p_fval => p_fval1d
+
+      ijpj = jpj
+      p_fval(:) = 0._wp
+      IF( PRESENT( pmsk ) ) THEN 
+         DO jk = 1, jpkm1
+            DO jj = 2, jpjm1
+               DO ji = fs_2, fs_jpim1   ! Vector opt.
+                  p_fval(jj) = p_fval(jj) + pva(ji,jj,jk) * tmask_i(ji,jj) * pmsk(ji,jj)
+               END DO
+            END DO
+         END DO
+      ELSE
+         DO jk = 1, jpkm1
+            DO jj = 2, jpjm1
+               DO ji = fs_2, fs_jpim1   ! Vector opt.
+                  p_fval(jj) = p_fval(jj) + pva(ji,jj,jk) * tmask_i(ji,jj) 
+               END DO
+            END DO
+         END DO
+      ENDIF
+#if defined key_mpp_mpi
+      IF(lk_mpp)   CALL mpp_sum( p_fval, ijpj, ncomm_znl)
+#endif
+      !
+   END FUNCTION ptr_sj_3d
+
+
+   FUNCTION ptr_sj_2d( pva, pmsk )   RESULT ( p_fval )
+      !!----------------------------------------------------------------------
+      !!                    ***  ROUTINE ptr_sj_2d  ***
+      !!
+      !! ** Purpose :   "zonal" and vertical sum computation of a i-flux array
+      !!
+      !! ** Method  : - i-k sum of pva using the interior 2D vmask (vmask_i).
+      !!      pva is supposed to be a masked flux (i.e. * vmask*e1v*e3v)
+      !!
+      !! ** Action  : - p_fval: i-k-mean poleward flux of pva
+      !!----------------------------------------------------------------------
+      REAL(wp) , INTENT(in), DIMENSION(jpi,jpj)           ::   pva   ! mask flux array at V-point
+      REAL(wp) , INTENT(in), DIMENSION(jpi,jpj), OPTIONAL ::   pmsk   ! Optional 2D basin mask
+      !
+      INTEGER                  ::   ji,jj       ! dummy loop arguments
+      INTEGER                  ::   ijpj        ! ???
+      REAL(wp), POINTER, DIMENSION(:) :: p_fval ! function value
+      !!--------------------------------------------------------------------
+      ! 
+      p_fval => p_fval1d
+
+      ijpj = jpj
+      p_fval(:) = 0._wp
+      IF( PRESENT( pmsk ) ) THEN 
+         DO jj = 2, jpjm1
+            DO ji = nldi, nlei   ! No vector optimisation here. Better use a mask ?
+               p_fval(jj) = p_fval(jj) + pva(ji,jj) * tmask_i(ji,jj) * pmsk(ji,jj)
+            END DO
+         END DO
+      ELSE
+         DO jj = 2, jpjm1
+            DO ji = nldi, nlei   ! No vector optimisation here. Better use a mask ?
+               p_fval(jj) = p_fval(jj) + pva(ji,jj) * tmask_i(ji,jj)
+            END DO
+         END DO
+      ENDIF
+#if defined key_mpp_mpi
+      CALL mpp_sum( p_fval, ijpj, ncomm_znl )
+#endif
+      ! 
+   END FUNCTION ptr_sj_2d
+
+
+   FUNCTION ptr_sjk( pta, pmsk )   RESULT ( p_fval )
+      !!----------------------------------------------------------------------
+      !!                    ***  ROUTINE ptr_sjk  ***
+      !!
+      !! ** Purpose :   i-sum computation of an array
+      !!
+      !! ** Method  : - i-sum of pva using the interior 2D vmask (vmask_i).
+      !!
+      !! ** Action  : - p_fval: i-mean poleward flux of pva
+      !!----------------------------------------------------------------------
+      !!
+      IMPLICIT none
+      REAL(wp) , INTENT(in), DIMENSION(jpi,jpj,jpk)           ::   pta    ! mask flux array at V-point
+      REAL(wp) , INTENT(in), DIMENSION(jpi,jpj)    , OPTIONAL ::   pmsk   ! Optional 2D basin mask
+      !!
+      INTEGER                           :: ji, jj, jk ! dummy loop arguments
+      REAL(wp), POINTER, DIMENSION(:,:) :: p_fval     ! return function value
+#if defined key_mpp_mpi
+      INTEGER, DIMENSION(1) ::   ish
+      INTEGER, DIMENSION(2) ::   ish2
+      INTEGER               ::   ijpjjpk
+      REAL(wp), DIMENSION(jpj*jpk) ::   zwork    ! mask flux array at V-point
+#endif
+      !!--------------------------------------------------------------------
+      !
+      p_fval => p_fval2d
+
+      p_fval(:,:) = 0._wp
+      !
+      IF( PRESENT( pmsk ) ) THEN 
+         DO jk = 1, jpkm1
+            DO jj = 2, jpjm1
+!!gm here, use of tmask_i  ==> no need of loop over nldi, nlei....
+               DO ji =  nldi, nlei   ! No vector optimisation here. Better use a mask ?
+                  p_fval(jj,jk) = p_fval(jj,jk) + pta(ji,jj,jk) * pmsk(ji,jj)
+               END DO
+            END DO
+         END DO
+      ELSE 
+         DO jk = 1, jpkm1
+            DO jj = 2, jpjm1
+               DO ji =  nldi, nlei   ! No vector optimisation here. Better use a mask ?
+                  p_fval(jj,jk) = p_fval(jj,jk) + pta(ji,jj,jk) * tmask_i(ji,jj)
+               END DO
+            END DO
+         END DO
+      END IF
+      !
+#if defined key_mpp_mpi
+      ijpjjpk = jpj*jpk
+      ish(1) = ijpjjpk  ;   ish2(1) = jpj   ;   ish2(2) = jpk
+      zwork(1:ijpjjpk) = RESHAPE( p_fval, ish )
+      CALL mpp_sum( zwork, ijpjjpk, ncomm_znl )
+      p_fval(:,:) = RESHAPE( zwork, ish2 )
+#endif
+      !
+   END FUNCTION ptr_sjk
+
+
+   !!======================================================================
+END MODULE diaptr
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DIA/diatmb.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DIA/diatmb.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DIA/diatmb.F90	(revision 9570)
@@ -0,0 +1,133 @@
+MODULE diatmb 
+   !!======================================================================
+   !!                       ***  MODULE  diaharm  ***
+   !! Harmonic analysis of tidal constituents 
+   !!======================================================================
+   !! History :  3.6  !  08-2014  (E O'Dea)  Original code
+   !!            3.7  !  05-2016  (G. Madec)  use mbkt, mikt to account for ocean cavities
+   !!----------------------------------------------------------------------
+   USE oce             ! ocean dynamics and tracers variables
+   USE dom_oce         ! ocean space and time domain
+   !
+   USE in_out_manager  ! I/O units
+   USE iom             ! I/0 library
+
+   IMPLICIT NONE
+   PRIVATE
+
+   LOGICAL , PUBLIC ::   ln_diatmb     !: Top Middle and Bottom output 
+   PUBLIC   dia_tmb_init            ! routine called by nemogcm.F90
+   PUBLIC   dia_tmb                 ! routine called by diawri.F90
+
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.6 , NEMO Consortium (2014)
+   !! $Id:$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE dia_tmb_init 
+      !!---------------------------------------------------------------------------
+      !!                  ***  ROUTINE dia_tmb_init  ***
+      !!     
+      !! ** Purpose :   Initialization of tmb namelist 
+      !!        
+      !! ** Method  :   Read namelist
+      !!---------------------------------------------------------------------------
+      INTEGER ::   ios                 ! Local integer output status for namelist read
+      !
+      NAMELIST/nam_diatmb/ ln_diatmb
+      !!----------------------------------------------------------------------
+      !
+      REWIND( numnam_ref )              ! Read Namelist nam_diatmb in reference namelist : TMB diagnostics
+      READ  ( numnam_ref, nam_diatmb, IOSTAT=ios, ERR= 901 )
+901   IF( ios /= 0 ) CALL ctl_nam ( ios , 'nam_diatmb in reference namelist', lwp )
+ 
+      REWIND( numnam_cfg )              ! Namelist nam_diatmb in configuration namelist  TMB diagnostics
+      READ  ( numnam_cfg, nam_diatmb, IOSTAT = ios, ERR = 902 )
+902   IF( ios >  0 ) CALL ctl_nam ( ios , 'nam_diatmb in configuration namelist', lwp )
+      IF(lwm) WRITE ( numond, nam_diatmb )
+
+      IF(lwp) THEN                   ! Control print
+         WRITE(numout,*)
+         WRITE(numout,*) 'dia_tmb_init : Output Top, Middle, Bottom Diagnostics'
+         WRITE(numout,*) '~~~~~~~~~~~~'
+         WRITE(numout,*) '   Namelist nam_diatmb : set tmb outputs '
+         WRITE(numout,*) '      Switch for TMB diagnostics (T) or not (F)  ln_diatmb  = ', ln_diatmb
+      ENDIF
+      !
+   END SUBROUTINE dia_tmb_init
+
+
+   SUBROUTINE dia_calctmb( pfield, ptmb )
+      !!---------------------------------------------------------------------
+      !!                  ***  ROUTINE dia_tmb  ***
+      !!                   
+      !! ** Purpose :    Find the Top, Mid and Bottom fields of water Column
+      !!
+      !! ** Method  :    use mbkt, mikt to find surface, mid and bottom of 
+      !!              model levels due to potential existence of ocean cavities
+      !!
+      !!----------------------------------------------------------------------
+      REAL(wp), DIMENSION(jpi, jpj, jpk), INTENT(in   ) ::   pfield   ! Input 3D field and mask
+      REAL(wp), DIMENSION(jpi, jpj,  3 ), INTENT(  out) ::   ptmb     ! top, middle, bottom extracted from pfield
+      !
+      INTEGER ::   ji, jj   ! Dummy loop indices
+      INTEGER ::   itop, imid, ibot   ! local integers
+      REAL(wp)::   zmdi = 1.e+20_wp   ! land value
+      !!---------------------------------------------------------------------
+      !
+      DO jj = 1, jpj
+         DO ji = 1, jpi
+            itop = mikt(ji,jj)                        ! top    ocean 
+            ibot = mbkt(ji,jj)                        ! bottom ocean 
+            imid =  itop + ( ibot - itop + 1 ) / 2    ! middle ocean          
+            !                    
+            ptmb(ji,jj,1) = pfield(ji,jj,itop)*tmask(ji,jj,itop) + zmdi*( 1._wp-tmask(ji,jj,itop) )
+            ptmb(ji,jj,2) = pfield(ji,jj,imid)*tmask(ji,jj,imid) + zmdi*( 1._wp-tmask(ji,jj,imid) )
+            ptmb(ji,jj,3) = pfield(ji,jj,ibot)*tmask(ji,jj,ibot) + zmdi*( 1._wp-tmask(ji,jj,ibot) )
+         END DO
+      END DO
+      !
+   END SUBROUTINE dia_calctmb
+
+
+   SUBROUTINE dia_tmb
+      !!----------------------------------------------------------------------
+      !!                 ***  ROUTINE dia_tmb  ***
+      !! ** Purpose :   Write diagnostics for Top, Mid and Bottom of water Column
+      !!
+      !! ** Method  :  use mikt,mbkt to find surface, mid and bottom of model levels
+      !!      calls calctmb to retrieve TMB values before sending to iom_put
+      !!
+      !!--------------------------------------------------------------------
+      REAL(wp) ::   zmdi =1.e+20     ! land value
+      REAL(wp), DIMENSION(jpi,jpj,3) :: zwtmb    ! workspace 
+      !!--------------------------------------------------------------------
+      !
+      CALL dia_calctmb( tsn(:,:,:,jp_tem), zwtmb )
+      !ssh already output but here we output it masked
+      CALL iom_put( "sshnmasked", sshn(:,:)*tmask(:,:,1) + zmdi*(1.0 - tmask(:,:,1)) )
+      CALL iom_put( "top_temp"  , zwtmb(:,:,1) )    ! tmb Temperature
+      CALL iom_put( "mid_temp"  , zwtmb(:,:,2) )    ! tmb Temperature
+      CALL iom_put( "bot_temp"  , zwtmb(:,:,3) )    ! tmb Temperature
+      !
+      CALL dia_calctmb( tsn(:,:,:,jp_sal), zwtmb )
+      CALL iom_put( "top_sal"   , zwtmb(:,:,1) )    ! tmb Salinity 
+      CALL iom_put( "mid_sal"   , zwtmb(:,:,2) )    ! tmb Salinity
+      CALL iom_put( "bot_sal"   , zwtmb(:,:,3) )    ! tmb Salinity
+      !
+      CALL dia_calctmb( un(:,:,:), zwtmb )
+      CALL iom_put( "top_u"     , zwtmb(:,:,1) )    ! tmb  U Velocity
+      CALL iom_put( "mid_u"     , zwtmb(:,:,2) )    ! tmb  U Velocity
+      CALL iom_put( "bot_u"     , zwtmb(:,:,3) )    ! tmb  U Velocity
+      !
+      CALL dia_calctmb( vn(:,:,:), zwtmb )
+      CALL iom_put( "top_v"     , zwtmb(:,:,1) )    ! tmb  V Velocity
+      CALL iom_put( "mid_v"     , zwtmb(:,:,2) )    ! tmb  V Velocity
+      CALL iom_put( "bot_v"     , zwtmb(:,:,3) )    ! tmb  V Velocity
+      !
+   END SUBROUTINE dia_tmb
+
+   !!======================================================================
+END MODULE diatmb
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DIA/diawri.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DIA/diawri.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DIA/diawri.F90	(revision 9570)
@@ -0,0 +1,1038 @@
+MODULE diawri
+   !!======================================================================
+   !!                     ***  MODULE  diawri  ***
+   !! Ocean diagnostics :  write ocean output files
+   !!=====================================================================
+   !! History :  OPA  ! 1991-03  (M.-A. Foujols)  Original code
+   !!            4.0  ! 1991-11  (G. Madec)
+   !!                 ! 1992-06  (M. Imbard)  correction restart file
+   !!                 ! 1992-07  (M. Imbard)  split into diawri and rstwri
+   !!                 ! 1993-03  (M. Imbard)  suppress writibm
+   !!                 ! 1998-01  (C. Levy)  NETCDF format using ioipsl INTERFACE
+   !!                 ! 1999-02  (E. Guilyardi)  name of netCDF files + variables
+   !!            8.2  ! 2000-06  (M. Imbard)  Original code (diabort.F)
+   !!   NEMO     1.0  ! 2002-06  (A.Bozec, E. Durand)  Original code (diainit.F)
+   !!             -   ! 2002-09  (G. Madec)  F90: Free form and module
+   !!             -   ! 2002-12  (G. Madec)  merge of diabort and diainit, F90
+   !!                 ! 2005-11  (V. Garnier) Surface pressure gradient organization
+   !!            3.2  ! 2008-11  (B. Lemaire) creation from old diawri
+   !!            3.7  ! 2014-01  (G. Madec) remove eddy induced velocity from no-IOM output
+   !!                 !                     change name of output variables in dia_wri_state
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   dia_wri       : create the standart output files
+   !!   dia_wri_state : create an output NetCDF file for a single instantaeous ocean state and forcing fields
+   !!----------------------------------------------------------------------
+   USE oce            ! ocean dynamics and tracers 
+   USE dom_oce        ! ocean space and time domain
+   USE phycst         ! physical constants
+   USE dianam         ! build name of file (routine)
+   USE diahth         ! thermocline diagnostics
+   USE dynadv   , ONLY: ln_dynadv_vec
+   USE icb_oce        ! Icebergs
+   USE icbdia         ! Iceberg budgets
+   USE ldftra         ! lateral physics: eddy diffusivity coef.
+   USE ldfdyn         ! lateral physics: eddy viscosity   coef.
+   USE sbc_oce        ! Surface boundary condition: ocean fields
+   USE sbc_ice        ! Surface boundary condition: ice fields
+   USE sbcssr         ! restoring term toward SST/SSS climatology
+   USE sbcwave        ! wave parameters
+   USE wet_dry        ! wetting and drying
+   USE zdf_oce        ! ocean vertical physics
+   USE zdfdrg         ! ocean vertical physics: top/bottom friction
+   USE zdfmxl         ! mixed layer
+   !
+   USE lbclnk         ! ocean lateral boundary conditions (or mpp link)
+   USE in_out_manager ! I/O manager
+   USE diatmb         ! Top,middle,bottom output
+   USE dia25h         ! 25h Mean output
+   USE iom            ! 
+   USE ioipsl         ! 
+
+#if defined key_si3
+   USE icewri 
+#endif
+   USE lib_mpp         ! MPP library
+   USE timing          ! preformance summary
+   USE diurnal_bulk    ! diurnal warm layer
+   USE cool_skin       ! Cool skin
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   dia_wri                 ! routines called by step.F90
+   PUBLIC   dia_wri_state
+   PUBLIC   dia_wri_alloc           ! Called by nemogcm module
+
+   INTEGER ::   nid_T, nz_T, nh_T, ndim_T, ndim_hT   ! grid_T file
+   INTEGER ::          nb_T              , ndim_bT   ! grid_T file
+   INTEGER ::   nid_U, nz_U, nh_U, ndim_U, ndim_hU   ! grid_U file
+   INTEGER ::   nid_V, nz_V, nh_V, ndim_V, ndim_hV   ! grid_V file
+   INTEGER ::   nid_W, nz_W, nh_W                    ! grid_W file
+   INTEGER ::   ndex(1)                              ! ???
+   INTEGER, SAVE, ALLOCATABLE, DIMENSION(:) :: ndex_hT, ndex_hU, ndex_hV
+   INTEGER, SAVE, ALLOCATABLE, DIMENSION(:) :: ndex_T, ndex_U, ndex_V
+   INTEGER, SAVE, ALLOCATABLE, DIMENSION(:) :: ndex_bT
+
+   !! * Substitutions
+#  include "vectopt_loop_substitute.h90"
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO Consortium (2010)
+   !! $Id$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   INTEGER FUNCTION dia_wri_alloc()
+      !!----------------------------------------------------------------------
+      INTEGER, DIMENSION(2) :: ierr
+      !!----------------------------------------------------------------------
+      ierr = 0
+      ALLOCATE( ndex_hT(jpi*jpj) , ndex_T(jpi*jpj*jpk) ,     &
+         &      ndex_hU(jpi*jpj) , ndex_U(jpi*jpj*jpk) ,     &
+         &      ndex_hV(jpi*jpj) , ndex_V(jpi*jpj*jpk) , STAT=ierr(1) )
+         !
+      dia_wri_alloc = MAXVAL(ierr)
+      IF( lk_mpp )   CALL mpp_sum( dia_wri_alloc )
+      !
+  END FUNCTION dia_wri_alloc
+
+   !!----------------------------------------------------------------------
+   !!   Default option                                   NetCDF output file
+   !!----------------------------------------------------------------------
+#if defined key_iomput
+   !!----------------------------------------------------------------------
+   !!   'key_iomput'                                        use IOM library
+   !!----------------------------------------------------------------------
+
+   SUBROUTINE dia_wri( kt )
+      !!---------------------------------------------------------------------
+      !!                  ***  ROUTINE dia_wri  ***
+      !!                   
+      !! ** Purpose :   Standard output of opa: dynamics and tracer fields 
+      !!      NETCDF format is used by default 
+      !!
+      !! ** Method  :  use iom_put
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT( in ) ::   kt      ! ocean time-step index
+      !!
+      INTEGER ::   ji, jj, jk       ! dummy loop indices
+      INTEGER ::   ikbot            ! local integer
+      REAL(wp)::   zztmp , zztmpx   ! local scalar
+      REAL(wp)::   zztmp2, zztmpy   !   -      -
+      REAL(wp), DIMENSION(jpi,jpj)     ::   z2d   ! 2D workspace
+      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   z3d   ! 3D workspace
+      !!----------------------------------------------------------------------
+      ! 
+      IF( ln_timing )   CALL timing_start('dia_wri')
+      ! 
+      ! Output the initial state and forcings
+      IF( ninist == 1 ) THEN                       
+         CALL dia_wri_state( 'output.init', kt )
+         ninist = 0
+      ENDIF
+
+      ! Output of initial vertical scale factor
+      CALL iom_put("e3t_0", e3t_0(:,:,:) )
+      CALL iom_put("e3u_0", e3t_0(:,:,:) )
+      CALL iom_put("e3v_0", e3t_0(:,:,:) )
+      !
+      CALL iom_put( "e3t" , e3t_n(:,:,:) )
+      CALL iom_put( "e3u" , e3u_n(:,:,:) )
+      CALL iom_put( "e3v" , e3v_n(:,:,:) )
+      CALL iom_put( "e3w" , e3w_n(:,:,:) )
+      IF( iom_use("e3tdef") )   &
+         CALL iom_put( "e3tdef"  , ( ( e3t_n(:,:,:) - e3t_0(:,:,:) ) / e3t_0(:,:,:) * 100 * tmask(:,:,:) ) ** 2 )
+
+      IF( ll_wd ) THEN
+         CALL iom_put( "ssh" , (sshn+ssh_ref)*tmask(:,:,1) )   ! sea surface height (brought back to the reference used for wetting and drying)
+      ELSE
+         CALL iom_put( "ssh" , sshn )              ! sea surface height
+      ENDIF
+
+      IF( iom_use("wetdep") )   &                  ! wet depth
+         CALL iom_put( "wetdep" , ht_0(:,:) + sshn(:,:) )
+      
+      CALL iom_put( "toce", tsn(:,:,:,jp_tem) )    ! 3D temperature
+      CALL iom_put(  "sst", tsn(:,:,1,jp_tem) )    ! surface temperature
+      IF ( iom_use("sbt") ) THEN
+         DO jj = 1, jpj
+            DO ji = 1, jpi
+               ikbot = mbkt(ji,jj)
+               z2d(ji,jj) = tsn(ji,jj,ikbot,jp_tem)
+            END DO
+         END DO
+         CALL iom_put( "sbt", z2d )                ! bottom temperature
+      ENDIF
+      
+      CALL iom_put( "soce", tsn(:,:,:,jp_sal) )    ! 3D salinity
+      CALL iom_put(  "sss", tsn(:,:,1,jp_sal) )    ! surface salinity
+      IF ( iom_use("sbs") ) THEN
+         DO jj = 1, jpj
+            DO ji = 1, jpi
+               ikbot = mbkt(ji,jj)
+               z2d(ji,jj) = tsn(ji,jj,ikbot,jp_sal)
+            END DO
+         END DO
+         CALL iom_put( "sbs", z2d )                ! bottom salinity
+      ENDIF
+
+      IF ( iom_use("taubot") ) THEN                ! bottom stress
+         zztmp = rau0 * 0.25
+         z2d(:,:) = 0._wp
+         DO jj = 2, jpjm1
+            DO ji = fs_2, fs_jpim1   ! vector opt.
+               zztmp2 = (  ( rCdU_bot(ji+1,jj)+rCdU_bot(ji  ,jj) ) * un(ji  ,jj,mbku(ji  ,jj))  )**2   &
+                  &   + (  ( rCdU_bot(ji  ,jj)+rCdU_bot(ji-1,jj) ) * un(ji-1,jj,mbku(ji-1,jj))  )**2   &
+                  &   + (  ( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj  ) ) * vn(ji,jj  ,mbkv(ji,jj  ))  )**2   &
+                  &   + (  ( rCdU_bot(ji,jj  )+rCdU_bot(ji,jj-1) ) * vn(ji,jj-1,mbkv(ji,jj-1))  )**2
+               z2d(ji,jj) = zztmp * SQRT( zztmp2 ) * tmask(ji,jj,1) 
+               !
+            END DO
+         END DO
+         CALL lbc_lnk( z2d, 'T', 1. )
+         CALL iom_put( "taubot", z2d )           
+      ENDIF
+         
+      CALL iom_put( "uoce", un(:,:,:) )            ! 3D i-current
+      CALL iom_put(  "ssu", un(:,:,1) )            ! surface i-current
+      IF ( iom_use("sbu") ) THEN
+         DO jj = 1, jpj
+            DO ji = 1, jpi
+               ikbot = mbku(ji,jj)
+               z2d(ji,jj) = un(ji,jj,ikbot)
+            END DO
+         END DO
+         CALL iom_put( "sbu", z2d )                ! bottom i-current
+      ENDIF
+      
+      CALL iom_put( "voce", vn(:,:,:) )            ! 3D j-current
+      CALL iom_put(  "ssv", vn(:,:,1) )            ! surface j-current
+      IF ( iom_use("sbv") ) THEN
+         DO jj = 1, jpj
+            DO ji = 1, jpi
+               ikbot = mbkv(ji,jj)
+               z2d(ji,jj) = vn(ji,jj,ikbot)
+            END DO
+         END DO
+         CALL iom_put( "sbv", z2d )                ! bottom j-current
+      ENDIF
+
+      CALL iom_put( "woce", wn )                   ! vertical velocity
+      IF( iom_use('w_masstr') .OR. iom_use('w_masstr2') ) THEN   ! vertical mass transport & its square value
+         ! Caution: in the VVL case, it only correponds to the baroclinic mass transport.
+         z2d(:,:) = rau0 * e1e2t(:,:)
+         DO jk = 1, jpk
+            z3d(:,:,jk) = wn(:,:,jk) * z2d(:,:)
+         END DO
+         CALL iom_put( "w_masstr" , z3d )  
+         IF( iom_use('w_masstr2') )   CALL iom_put( "w_masstr2", z3d(:,:,:) * z3d(:,:,:) )
+      ENDIF
+
+      CALL iom_put( "avt" , avt )                  ! T vert. eddy diff. coef.
+      CALL iom_put( "avs" , avs )                  ! S vert. eddy diff. coef.
+      CALL iom_put( "avm" , avm )                  ! T vert. eddy visc. coef.
+
+      IF( iom_use('logavt') )   CALL iom_put( "logavt", LOG( MAX( 1.e-20_wp, avt(:,:,:) ) ) )
+      IF( iom_use('logavs') )   CALL iom_put( "logavs", LOG( MAX( 1.e-20_wp, avs(:,:,:) ) ) )
+
+      IF ( iom_use("sstgrad") .OR. iom_use("sstgrad2") ) THEN
+         DO jj = 2, jpjm1                                    ! sst gradient
+            DO ji = fs_2, fs_jpim1   ! vector opt.
+               zztmp  = tsn(ji,jj,1,jp_tem)
+               zztmpx = ( tsn(ji+1,jj,1,jp_tem) - zztmp ) * r1_e1u(ji,jj) + ( zztmp - tsn(ji-1,jj  ,1,jp_tem) ) * r1_e1u(ji-1,jj)
+               zztmpy = ( tsn(ji,jj+1,1,jp_tem) - zztmp ) * r1_e2v(ji,jj) + ( zztmp - tsn(ji  ,jj-1,1,jp_tem) ) * r1_e2v(ji,jj-1)
+               z2d(ji,jj) = 0.25 * ( zztmpx * zztmpx + zztmpy * zztmpy )   &
+                  &              * umask(ji,jj,1) * umask(ji-1,jj,1) * vmask(ji,jj,1) * umask(ji,jj-1,1)
+            END DO
+         END DO
+         CALL lbc_lnk( z2d, 'T', 1. )
+         CALL iom_put( "sstgrad2",  z2d )          ! square of module of sst gradient
+         z2d(:,:) = SQRT( z2d(:,:) )
+         CALL iom_put( "sstgrad" ,  z2d )          ! module of sst gradient
+      ENDIF
+         
+      ! heat and salt contents
+      IF( iom_use("heatc") ) THEN
+         z2d(:,:)  = 0._wp 
+         DO jk = 1, jpkm1
+            DO jj = 1, jpj
+               DO ji = 1, jpi
+                  z2d(ji,jj) = z2d(ji,jj) + e3t_n(ji,jj,jk) * tsn(ji,jj,jk,jp_tem) * tmask(ji,jj,jk)
+               END DO
+            END DO
+         END DO
+         CALL iom_put( "heatc", rau0_rcp * z2d )   ! vertically integrated heat content (J/m2)
+      ENDIF
+
+      IF( iom_use("saltc") ) THEN
+         z2d(:,:)  = 0._wp 
+         DO jk = 1, jpkm1
+            DO jj = 1, jpj
+               DO ji = 1, jpi
+                  z2d(ji,jj) = z2d(ji,jj) + e3t_n(ji,jj,jk) * tsn(ji,jj,jk,jp_sal) * tmask(ji,jj,jk)
+               END DO
+            END DO
+         END DO
+         CALL iom_put( "saltc", rau0 * z2d )          ! vertically integrated salt content (PSU*kg/m2)
+      ENDIF
+      !
+      IF ( iom_use("eken") ) THEN
+         z3d(:,:,jpk) = 0._wp 
+         DO jk = 1, jpkm1
+            DO jj = 2, jpjm1
+               DO ji = fs_2, fs_jpim1   ! vector opt.
+                  zztmp  = 0.25_wp * r1_e1e2t(ji,jj) / e3t_n(ji,jj,jk)
+                  z3d(ji,jj,jk) = zztmp * (  un(ji-1,jj,jk)**2 * e2u(ji-1,jj) * e3u_n(ji-1,jj,jk)   &
+                     &                     + un(ji  ,jj,jk)**2 * e2u(ji  ,jj) * e3u_n(ji  ,jj,jk)   &
+                     &                     + vn(ji,jj-1,jk)**2 * e1v(ji,jj-1) * e3v_n(ji,jj-1,jk)   &
+                     &                     + vn(ji,jj  ,jk)**2 * e1v(ji,jj  ) * e3v_n(ji,jj  ,jk)   )
+               END DO
+            END DO
+         END DO
+         CALL lbc_lnk( z3d, 'T', 1. )
+         CALL iom_put( "eken", z3d )                 ! kinetic energy
+      ENDIF
+      !
+      CALL iom_put( "hdiv", hdivn )                  ! Horizontal divergence
+      !
+      IF( iom_use("u_masstr") .OR. iom_use("u_masstr_vint") .OR. iom_use("u_heattr") .OR. iom_use("u_salttr") ) THEN
+         z3d(:,:,jpk) = 0.e0
+         z2d(:,:) = 0.e0
+         DO jk = 1, jpkm1
+            z3d(:,:,jk) = rau0 * un(:,:,jk) * e2u(:,:) * e3u_n(:,:,jk) * umask(:,:,jk)
+            z2d(:,:) = z2d(:,:) + z3d(:,:,jk)
+         END DO
+         CALL iom_put( "u_masstr"     , z3d )         ! mass transport in i-direction
+         CALL iom_put( "u_masstr_vint", z2d )         ! mass transport in i-direction vertical sum
+      ENDIF
+      
+      IF( iom_use("u_heattr") ) THEN
+         z2d(:,:) = 0._wp 
+         DO jk = 1, jpkm1
+            DO jj = 2, jpjm1
+               DO ji = fs_2, fs_jpim1   ! vector opt.
+                  z2d(ji,jj) = z2d(ji,jj) + z3d(ji,jj,jk) * ( tsn(ji,jj,jk,jp_tem) + tsn(ji+1,jj,jk,jp_tem) )
+               END DO
+            END DO
+         END DO
+         CALL lbc_lnk( z2d, 'U', -1. )
+         CALL iom_put( "u_heattr", 0.5*rcp * z2d )    ! heat transport in i-direction
+      ENDIF
+
+      IF( iom_use("u_salttr") ) THEN
+         z2d(:,:) = 0.e0 
+         DO jk = 1, jpkm1
+            DO jj = 2, jpjm1
+               DO ji = fs_2, fs_jpim1   ! vector opt.
+                  z2d(ji,jj) = z2d(ji,jj) + z3d(ji,jj,jk) * ( tsn(ji,jj,jk,jp_sal) + tsn(ji+1,jj,jk,jp_sal) )
+               END DO
+            END DO
+         END DO
+         CALL lbc_lnk( z2d, 'U', -1. )
+         CALL iom_put( "u_salttr", 0.5 * z2d )        ! heat transport in i-direction
+      ENDIF
+
+      
+      IF( iom_use("v_masstr") .OR. iom_use("v_heattr") .OR. iom_use("v_salttr") ) THEN
+         z3d(:,:,jpk) = 0.e0
+         DO jk = 1, jpkm1
+            z3d(:,:,jk) = rau0 * vn(:,:,jk) * e1v(:,:) * e3v_n(:,:,jk) * vmask(:,:,jk)
+         END DO
+         CALL iom_put( "v_masstr", z3d )              ! mass transport in j-direction
+      ENDIF
+      
+      IF( iom_use("v_heattr") ) THEN
+         z2d(:,:) = 0.e0 
+         DO jk = 1, jpkm1
+            DO jj = 2, jpjm1
+               DO ji = fs_2, fs_jpim1   ! vector opt.
+                  z2d(ji,jj) = z2d(ji,jj) + z3d(ji,jj,jk) * ( tsn(ji,jj,jk,jp_tem) + tsn(ji,jj+1,jk,jp_tem) )
+               END DO
+            END DO
+         END DO
+         CALL lbc_lnk( z2d, 'V', -1. )
+         CALL iom_put( "v_heattr", 0.5*rcp * z2d )    !  heat transport in j-direction
+      ENDIF
+
+      IF( iom_use("v_salttr") ) THEN
+         z2d(:,:) = 0._wp 
+         DO jk = 1, jpkm1
+            DO jj = 2, jpjm1
+               DO ji = fs_2, fs_jpim1   ! vector opt.
+                  z2d(ji,jj) = z2d(ji,jj) + z3d(ji,jj,jk) * ( tsn(ji,jj,jk,jp_sal) + tsn(ji,jj+1,jk,jp_sal) )
+               END DO
+            END DO
+         END DO
+         CALL lbc_lnk( z2d, 'V', -1. )
+         CALL iom_put( "v_salttr", 0.5 * z2d )        !  heat transport in j-direction
+      ENDIF
+
+      IF( iom_use("tosmint") ) THEN
+         z2d(:,:) = 0._wp
+         DO jk = 1, jpkm1
+            DO jj = 2, jpjm1
+               DO ji = fs_2, fs_jpim1   ! vector opt.
+                  z2d(ji,jj) = z2d(ji,jj) + e3t_n(ji,jj,jk) *  tsn(ji,jj,jk,jp_tem)
+               END DO
+            END DO
+         END DO
+         CALL lbc_lnk( z2d, 'T', -1. )
+         CALL iom_put( "tosmint", rau0 * z2d )        ! Vertical integral of temperature
+      ENDIF
+      IF( iom_use("somint") ) THEN
+         z2d(:,:)=0._wp
+         DO jk = 1, jpkm1
+            DO jj = 2, jpjm1
+               DO ji = fs_2, fs_jpim1   ! vector opt.
+                  z2d(ji,jj) = z2d(ji,jj) + e3t_n(ji,jj,jk) * tsn(ji,jj,jk,jp_sal)
+               END DO
+            END DO
+         END DO
+         CALL lbc_lnk( z2d, 'T', -1. )
+         CALL iom_put( "somint", rau0 * z2d )         ! Vertical integral of salinity
+      ENDIF
+
+      CALL iom_put( "bn2", rn2 )                      ! Brunt-Vaisala buoyancy frequency (N^2)
+      !
+
+      IF (ln_diatmb)   CALL dia_tmb                   ! tmb values 
+          
+      IF (ln_dia25h)   CALL dia_25h( kt )             ! 25h averaging
+
+      IF( ln_timing )   CALL timing_stop('dia_wri')
+      !
+   END SUBROUTINE dia_wri
+
+#else
+   !!----------------------------------------------------------------------
+   !!   Default option                                  use IOIPSL  library
+   !!----------------------------------------------------------------------
+
+   SUBROUTINE dia_wri( kt )
+      !!---------------------------------------------------------------------
+      !!                  ***  ROUTINE dia_wri  ***
+      !!                   
+      !! ** Purpose :   Standard output of opa: dynamics and tracer fields 
+      !!      NETCDF format is used by default 
+      !!
+      !! ** Method  :   At the beginning of the first time step (nit000), 
+      !!      define all the NETCDF files and fields
+      !!      At each time step call histdef to compute the mean if ncessary
+      !!      Each nwrite time step, output the instantaneous or mean fields
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT( in ) ::   kt   ! ocean time-step index
+      !
+      LOGICAL ::   ll_print = .FALSE.                        ! =T print and flush numout
+      CHARACTER (len=40) ::   clhstnam, clop, clmx           ! local names
+      INTEGER  ::   inum = 11                                ! temporary logical unit
+      INTEGER  ::   ji, jj, jk                               ! dummy loop indices
+      INTEGER  ::   ierr                                     ! error code return from allocation
+      INTEGER  ::   iimi, iima, ipk, it, itmod, ijmi, ijma   ! local integers
+      INTEGER  ::   jn, ierror                               ! local integers
+      REAL(wp) ::   zsto, zout, zmax, zjulian                ! local scalars
+      !
+      REAL(wp), DIMENSION(jpi,jpj)   :: zw2d       ! 2D workspace
+      REAL(wp), DIMENSION(jpi,jpj,jpk) :: zw3d       ! 3D workspace
+      !!----------------------------------------------------------------------
+      ! 
+      IF( ln_timing )   CALL timing_start('dia_wri')
+      !
+      IF( ninist == 1 ) THEN     !==  Output the initial state and forcings  ==!
+         CALL dia_wri_state( 'output.init', kt )
+         ninist = 0
+      ENDIF
+      !
+      ! 0. Initialisation
+      ! -----------------
+
+      ll_print = .FALSE.                  ! local variable for debugging
+      ll_print = ll_print .AND. lwp
+
+      ! Define frequency of output and means
+      clop = "x"         ! no use of the mask value (require less cpu time and otherwise the model crashes)
+#if defined key_diainstant
+      zsto = nwrite * rdt
+      clop = "inst("//TRIM(clop)//")"
+#else
+      zsto=rdt
+      clop = "ave("//TRIM(clop)//")"
+#endif
+      zout = nwrite * rdt
+      zmax = ( nitend - nit000 + 1 ) * rdt
+
+      ! Define indices of the horizontal output zoom and vertical limit storage
+      iimi = 1      ;      iima = jpi
+      ijmi = 1      ;      ijma = jpj
+      ipk = jpk
+
+      ! define time axis
+      it = kt
+      itmod = kt - nit000 + 1
+
+
+      ! 1. Define NETCDF files and fields at beginning of first time step
+      ! -----------------------------------------------------------------
+
+      IF( kt == nit000 ) THEN
+
+         ! Define the NETCDF files (one per grid)
+
+         ! Compute julian date from starting date of the run
+         CALL ymds2ju( nyear, nmonth, nday, rdt, zjulian )
+         zjulian = zjulian - adatrj   !   set calendar origin to the beginning of the experiment
+         IF(lwp)WRITE(numout,*)
+         IF(lwp)WRITE(numout,*) 'Date 0 used :', nit000, ' YEAR ', nyear,   &
+            &                    ' MONTH ', nmonth, ' DAY ', nday, 'Julian day : ', zjulian
+         IF(lwp)WRITE(numout,*) ' indexes of zoom = ', iimi, iima, ijmi, ijma,   &
+                                 ' limit storage in depth = ', ipk
+
+         ! WRITE root name in date.file for use by postpro
+         IF(lwp) THEN
+            CALL dia_nam( clhstnam, nwrite,' ' )
+            CALL ctl_opn( inum, 'date.file', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp, narea )
+            WRITE(inum,*) clhstnam
+            CLOSE(inum)
+         ENDIF
+
+         ! Define the T grid FILE ( nid_T )
+
+         CALL dia_nam( clhstnam, nwrite, 'grid_T' )
+         IF(lwp) WRITE(numout,*) " Name of NETCDF file ", clhstnam    ! filename
+         CALL histbeg( clhstnam, jpi, glamt, jpj, gphit,           &  ! Horizontal grid: glamt and gphit
+            &          iimi, iima-iimi+1, ijmi, ijma-ijmi+1,       &
+            &          nit000-1, zjulian, rdt, nh_T, nid_T, domain_id=nidom, snc4chunks=snc4set )
+         CALL histvert( nid_T, "deptht", "Vertical T levels",      &  ! Vertical grid: gdept
+            &           "m", ipk, gdept_1d, nz_T, "down" )
+         !                                                            ! Index of ocean points
+         CALL wheneq( jpi*jpj*ipk, tmask, 1, 1., ndex_T , ndim_T  )      ! volume
+         CALL wheneq( jpi*jpj    , tmask, 1, 1., ndex_hT, ndim_hT )      ! surface
+         !
+         IF( ln_icebergs ) THEN
+            !
+            !! allocation cant go in dia_wri_alloc because ln_icebergs is only set after 
+            !! that routine is called from nemogcm, so do it here immediately before its needed
+            ALLOCATE( ndex_bT(jpi*jpj*nclasses), STAT=ierror )
+            IF( lk_mpp )   CALL mpp_sum( ierror )
+            IF( ierror /= 0 ) THEN
+               CALL ctl_stop('dia_wri: failed to allocate iceberg diagnostic array')
+               RETURN
+            ENDIF
+            !
+            !! iceberg vertical coordinate is class number
+            CALL histvert( nid_T, "class", "Iceberg class",      &  ! Vertical grid: class
+               &           "number", nclasses, class_num, nb_T )
+            !
+            !! each class just needs the surface index pattern
+            ndim_bT = 3
+            DO jn = 1,nclasses
+               ndex_bT((jn-1)*jpi*jpj+1:jn*jpi*jpj) = ndex_hT(1:jpi*jpj)
+            ENDDO
+            !
+         ENDIF
+
+         ! Define the U grid FILE ( nid_U )
+
+         CALL dia_nam( clhstnam, nwrite, 'grid_U' )
+         IF(lwp) WRITE(numout,*) " Name of NETCDF file ", clhstnam    ! filename
+         CALL histbeg( clhstnam, jpi, glamu, jpj, gphiu,           &  ! Horizontal grid: glamu and gphiu
+            &          iimi, iima-iimi+1, ijmi, ijma-ijmi+1,       &
+            &          nit000-1, zjulian, rdt, nh_U, nid_U, domain_id=nidom, snc4chunks=snc4set )
+         CALL histvert( nid_U, "depthu", "Vertical U levels",      &  ! Vertical grid: gdept
+            &           "m", ipk, gdept_1d, nz_U, "down" )
+         !                                                            ! Index of ocean points
+         CALL wheneq( jpi*jpj*ipk, umask, 1, 1., ndex_U , ndim_U  )      ! volume
+         CALL wheneq( jpi*jpj    , umask, 1, 1., ndex_hU, ndim_hU )      ! surface
+
+         ! Define the V grid FILE ( nid_V )
+
+         CALL dia_nam( clhstnam, nwrite, 'grid_V' )                   ! filename
+         IF(lwp) WRITE(numout,*) " Name of NETCDF file ", clhstnam
+         CALL histbeg( clhstnam, jpi, glamv, jpj, gphiv,           &  ! Horizontal grid: glamv and gphiv
+            &          iimi, iima-iimi+1, ijmi, ijma-ijmi+1,       &
+            &          nit000-1, zjulian, rdt, nh_V, nid_V, domain_id=nidom, snc4chunks=snc4set )
+         CALL histvert( nid_V, "depthv", "Vertical V levels",      &  ! Vertical grid : gdept
+            &          "m", ipk, gdept_1d, nz_V, "down" )
+         !                                                            ! Index of ocean points
+         CALL wheneq( jpi*jpj*ipk, vmask, 1, 1., ndex_V , ndim_V  )      ! volume
+         CALL wheneq( jpi*jpj    , vmask, 1, 1., ndex_hV, ndim_hV )      ! surface
+
+         ! Define the W grid FILE ( nid_W )
+
+         CALL dia_nam( clhstnam, nwrite, 'grid_W' )                   ! filename
+         IF(lwp) WRITE(numout,*) " Name of NETCDF file ", clhstnam
+         CALL histbeg( clhstnam, jpi, glamt, jpj, gphit,           &  ! Horizontal grid: glamt and gphit
+            &          iimi, iima-iimi+1, ijmi, ijma-ijmi+1,       &
+            &          nit000-1, zjulian, rdt, nh_W, nid_W, domain_id=nidom, snc4chunks=snc4set )
+         CALL histvert( nid_W, "depthw", "Vertical W levels",      &  ! Vertical grid: gdepw
+            &          "m", ipk, gdepw_1d, nz_W, "down" )
+
+
+         ! Declare all the output fields as NETCDF variables
+
+         !                                                                                      !!! nid_T : 3D
+         CALL histdef( nid_T, "votemper", "Temperature"                        , "C"      ,   &  ! tn
+            &          jpi, jpj, nh_T, ipk, 1, ipk, nz_T, 32, clop, zsto, zout )
+         CALL histdef( nid_T, "vosaline", "Salinity"                           , "PSU"    ,   &  ! sn
+            &          jpi, jpj, nh_T, ipk, 1, ipk, nz_T, 32, clop, zsto, zout )
+         IF(  .NOT.ln_linssh  ) THEN
+            CALL histdef( nid_T, "vovvle3t", "Level thickness"                    , "m"      ,&  ! e3t_n
+            &             jpi, jpj, nh_T, ipk, 1, ipk, nz_T, 32, clop, zsto, zout )
+            CALL histdef( nid_T, "vovvldep", "T point depth"                      , "m"      ,&  ! e3t_n
+            &             jpi, jpj, nh_T, ipk, 1, ipk, nz_T, 32, clop, zsto, zout )
+            CALL histdef( nid_T, "vovvldef", "Squared level deformation"          , "%^2"    ,&  ! e3t_n
+            &             jpi, jpj, nh_T, ipk, 1, ipk, nz_T, 32, clop, zsto, zout )
+         ENDIF
+         !                                                                                      !!! nid_T : 2D
+         CALL histdef( nid_T, "sosstsst", "Sea Surface temperature"            , "C"      ,   &  ! sst
+            &          jpi, jpj, nh_T, 1  , 1, 1  , -99 , 32, clop, zsto, zout )
+         CALL histdef( nid_T, "sosaline", "Sea Surface Salinity"               , "PSU"    ,   &  ! sss
+            &          jpi, jpj, nh_T, 1  , 1, 1  , -99 , 32, clop, zsto, zout )
+         CALL histdef( nid_T, "sossheig", "Sea Surface Height"                 , "m"      ,   &  ! ssh
+            &          jpi, jpj, nh_T, 1  , 1, 1  , -99 , 32, clop, zsto, zout )
+         CALL histdef( nid_T, "sowaflup", "Net Upward Water Flux"              , "Kg/m2/s",   &  ! (emp-rnf)
+            &          jpi, jpj, nh_T, 1  , 1, 1  , -99 , 32, clop, zsto, zout )
+         CALL histdef( nid_T, "sorunoff", "River runoffs"                      , "Kg/m2/s",   &  ! runoffs
+            &          jpi, jpj, nh_T, 1  , 1, 1  , -99 , 32, clop, zsto, zout )
+         CALL histdef( nid_T, "sosfldow", "downward salt flux"                 , "PSU/m2/s",  &  ! sfx
+            &          jpi, jpj, nh_T, 1  , 1, 1  , -99 , 32, clop, zsto, zout )
+         IF(  ln_linssh  ) THEN
+            CALL histdef( nid_T, "sosst_cd", "Concentration/Dilution term on temperature"     &  ! emp * tsn(:,:,1,jp_tem)
+            &                                                                  , "KgC/m2/s",  &  ! sosst_cd
+            &             jpi, jpj, nh_T, 1  , 1, 1  , -99 , 32, clop, zsto, zout )
+            CALL histdef( nid_T, "sosss_cd", "Concentration/Dilution term on salinity"        &  ! emp * tsn(:,:,1,jp_sal)
+            &                                                                  , "KgPSU/m2/s",&  ! sosss_cd
+            &             jpi, jpj, nh_T, 1  , 1, 1  , -99 , 32, clop, zsto, zout )
+         ENDIF
+         CALL histdef( nid_T, "sohefldo", "Net Downward Heat Flux"             , "W/m2"   ,   &  ! qns + qsr
+            &          jpi, jpj, nh_T, 1  , 1, 1  , -99 , 32, clop, zsto, zout )
+         CALL histdef( nid_T, "soshfldo", "Shortwave Radiation"                , "W/m2"   ,   &  ! qsr
+            &          jpi, jpj, nh_T, 1  , 1, 1  , -99 , 32, clop, zsto, zout )
+         CALL histdef( nid_T, "somixhgt", "Turbocline Depth"                   , "m"      ,   &  ! hmld
+            &          jpi, jpj, nh_T, 1  , 1, 1  , -99 , 32, clop, zsto, zout )
+         CALL histdef( nid_T, "somxl010", "Mixed Layer Depth 0.01"             , "m"      ,   &  ! hmlp
+            &          jpi, jpj, nh_T, 1  , 1, 1  , -99 , 32, clop, zsto, zout )
+         CALL histdef( nid_T, "soicecov", "Ice fraction"                       , "[0,1]"  ,   &  ! fr_i
+            &          jpi, jpj, nh_T, 1  , 1, 1  , -99 , 32, clop, zsto, zout )
+         CALL histdef( nid_T, "sowindsp", "wind speed at 10m"                  , "m/s"    ,   &  ! wndm
+            &          jpi, jpj, nh_T, 1  , 1, 1  , -99 , 32, clop, zsto, zout )
+!
+         IF( ln_icebergs ) THEN
+            CALL histdef( nid_T, "calving"             , "calving mass input"                       , "kg/s"   , &
+               &          jpi, jpj, nh_T, 1  , 1, 1  , -99 , 32, clop, zsto, zout )
+            CALL histdef( nid_T, "calving_heat"        , "calving heat flux"                        , "XXXX"   , &
+               &          jpi, jpj, nh_T, 1  , 1, 1  , -99 , 32, clop, zsto, zout )
+            CALL histdef( nid_T, "berg_floating_melt"  , "Melt rate of icebergs + bits"             , "kg/m2/s", &
+               &          jpi, jpj, nh_T, 1  , 1, 1  , -99 , 32, clop, zsto, zout )
+            CALL histdef( nid_T, "berg_stored_ice"     , "Accumulated ice mass by class"            , "kg"     , &
+               &          jpi, jpj, nh_T, nclasses  , 1, nclasses  , nb_T , 32, clop, zsto, zout )
+            IF( ln_bergdia ) THEN
+               CALL histdef( nid_T, "berg_melt"           , "Melt rate of icebergs"                    , "kg/m2/s", &
+                  &          jpi, jpj, nh_T, 1  , 1, 1  , -99 , 32, clop, zsto, zout )
+               CALL histdef( nid_T, "berg_buoy_melt"      , "Buoyancy component of iceberg melt rate"  , "kg/m2/s", &
+                  &          jpi, jpj, nh_T, 1  , 1, 1  , -99 , 32, clop, zsto, zout )
+               CALL histdef( nid_T, "berg_eros_melt"      , "Erosion component of iceberg melt rate"   , "kg/m2/s", &
+                  &          jpi, jpj, nh_T, 1  , 1, 1  , -99 , 32, clop, zsto, zout )
+               CALL histdef( nid_T, "berg_conv_melt"      , "Convective component of iceberg melt rate", "kg/m2/s", &
+                  &          jpi, jpj, nh_T, 1  , 1, 1  , -99 , 32, clop, zsto, zout )
+               CALL histdef( nid_T, "berg_virtual_area"   , "Virtual coverage by icebergs"             , "m2"     , &
+                  &          jpi, jpj, nh_T, 1  , 1, 1  , -99 , 32, clop, zsto, zout )
+               CALL histdef( nid_T, "bits_src"           , "Mass source of bergy bits"                , "kg/m2/s", &
+                  &          jpi, jpj, nh_T, 1  , 1, 1  , -99 , 32, clop, zsto, zout )
+               CALL histdef( nid_T, "bits_melt"          , "Melt rate of bergy bits"                  , "kg/m2/s", &
+                  &          jpi, jpj, nh_T, 1  , 1, 1  , -99 , 32, clop, zsto, zout )
+               CALL histdef( nid_T, "bits_mass"          , "Bergy bit density field"                  , "kg/m2"  , &
+                  &          jpi, jpj, nh_T, 1  , 1, 1  , -99 , 32, clop, zsto, zout )
+               CALL histdef( nid_T, "berg_mass"           , "Iceberg density field"                    , "kg/m2"  , &
+                  &          jpi, jpj, nh_T, 1  , 1, 1  , -99 , 32, clop, zsto, zout )
+               CALL histdef( nid_T, "berg_real_calving"   , "Calving into iceberg class"               , "kg/s"   , &
+                  &          jpi, jpj, nh_T, nclasses  , 1, nclasses  , nb_T , 32, clop, zsto, zout )
+            ENDIF
+         ENDIF
+
+         IF( .NOT. ln_cpl ) THEN
+            CALL histdef( nid_T, "sohefldp", "Surface Heat Flux: Damping"         , "W/m2"   ,   &  ! qrp
+               &          jpi, jpj, nh_T, 1  , 1, 1  , -99 , 32, clop, zsto, zout )
+            CALL histdef( nid_T, "sowafldp", "Surface Water Flux: Damping"        , "Kg/m2/s",   &  ! erp
+               &          jpi, jpj, nh_T, 1  , 1, 1  , -99 , 32, clop, zsto, zout )
+            CALL histdef( nid_T, "sosafldp", "Surface salt flux: damping"         , "Kg/m2/s",   &  ! erp * sn
+               &          jpi, jpj, nh_T, 1  , 1, 1  , -99 , 32, clop, zsto, zout )
+         ENDIF
+
+         IF( ln_cpl .AND. nn_ice <= 1 ) THEN
+            CALL histdef( nid_T, "sohefldp", "Surface Heat Flux: Damping"         , "W/m2"   ,   &  ! qrp
+               &          jpi, jpj, nh_T, 1  , 1, 1  , -99 , 32, clop, zsto, zout )
+            CALL histdef( nid_T, "sowafldp", "Surface Water Flux: Damping"        , "Kg/m2/s",   &  ! erp
+               &          jpi, jpj, nh_T, 1  , 1, 1  , -99 , 32, clop, zsto, zout )
+            CALL histdef( nid_T, "sosafldp", "Surface salt flux: Damping"         , "Kg/m2/s",   &  ! erp * sn
+               &          jpi, jpj, nh_T, 1  , 1, 1  , -99 , 32, clop, zsto, zout )
+         ENDIF
+         
+         clmx ="l_max(only(x))"    ! max index on a period
+!         CALL histdef( nid_T, "sobowlin", "Bowl Index"                         , "W-point",   &  ! bowl INDEX 
+!            &          jpi, jpj, nh_T, 1  , 1, 1  , -99 , 32, clmx, zsto, zout )
+#if defined key_diahth
+         CALL histdef( nid_T, "sothedep", "Thermocline Depth"                  , "m"      ,   & ! hth
+            &          jpi, jpj, nh_T, 1  , 1, 1  , -99 , 32, clop, zsto, zout )
+         CALL histdef( nid_T, "so20chgt", "Depth of 20C isotherm"              , "m"      ,   & ! hd20
+            &          jpi, jpj, nh_T, 1  , 1, 1  , -99 , 32, clop, zsto, zout )
+         CALL histdef( nid_T, "so28chgt", "Depth of 28C isotherm"              , "m"      ,   & ! hd28
+            &          jpi, jpj, nh_T, 1  , 1, 1  , -99 , 32, clop, zsto, zout )
+         CALL histdef( nid_T, "sohtc300", "Heat content 300 m"                 , "J/m2"   ,   & ! htc3
+            &          jpi, jpj, nh_T, 1  , 1, 1  , -99 , 32, clop, zsto, zout )
+#endif
+
+         CALL histend( nid_T, snc4chunks=snc4set )
+
+         !                                                                                      !!! nid_U : 3D
+         CALL histdef( nid_U, "vozocrtx", "Zonal Current"                      , "m/s"    ,   &  ! un
+            &          jpi, jpj, nh_U, ipk, 1, ipk, nz_U, 32, clop, zsto, zout )
+         IF( ln_wave .AND. ln_sdw) THEN
+            CALL histdef( nid_U, "sdzocrtx", "Stokes Drift Zonal Current"         , "m/s"    ,   &  ! usd
+               &          jpi, jpj, nh_U, ipk, 1, ipk, nz_U, 32, clop, zsto, zout )
+         ENDIF
+         !                                                                                      !!! nid_U : 2D
+         CALL histdef( nid_U, "sozotaux", "Wind Stress along i-axis"           , "N/m2"   ,   &  ! utau
+            &          jpi, jpj, nh_U, 1  , 1, 1  , - 99, 32, clop, zsto, zout )
+
+         CALL histend( nid_U, snc4chunks=snc4set )
+
+         !                                                                                      !!! nid_V : 3D
+         CALL histdef( nid_V, "vomecrty", "Meridional Current"                 , "m/s"    ,   &  ! vn
+            &          jpi, jpj, nh_V, ipk, 1, ipk, nz_V, 32, clop, zsto, zout )
+         IF( ln_wave .AND. ln_sdw) THEN
+            CALL histdef( nid_V, "sdmecrty", "Stokes Drift Meridional Current"    , "m/s"    ,   &  ! vsd
+               &          jpi, jpj, nh_V, ipk, 1, ipk, nz_V, 32, clop, zsto, zout )
+         ENDIF
+         !                                                                                      !!! nid_V : 2D
+         CALL histdef( nid_V, "sometauy", "Wind Stress along j-axis"           , "N/m2"   ,   &  ! vtau
+            &          jpi, jpj, nh_V, 1  , 1, 1  , - 99, 32, clop, zsto, zout )
+
+         CALL histend( nid_V, snc4chunks=snc4set )
+
+         !                                                                                      !!! nid_W : 3D
+         CALL histdef( nid_W, "vovecrtz", "Vertical Velocity"                  , "m/s"    ,   &  ! wn
+            &          jpi, jpj, nh_W, ipk, 1, ipk, nz_W, 32, clop, zsto, zout )
+         CALL histdef( nid_W, "votkeavt", "Vertical Eddy Diffusivity"          , "m2/s"   ,   &  ! avt
+            &          jpi, jpj, nh_W, ipk, 1, ipk, nz_W, 32, clop, zsto, zout )
+         CALL histdef( nid_W, "votkeavm", "Vertical Eddy Viscosity"             , "m2/s"  ,   &  ! avm
+            &          jpi, jpj, nh_W, ipk, 1, ipk, nz_W, 32, clop, zsto, zout )
+
+         IF( ln_zdfddm ) THEN
+            CALL histdef( nid_W,"voddmavs","Salt Vertical Eddy Diffusivity"    , "m2/s"   ,   &  ! avs
+               &          jpi, jpj, nh_W, ipk, 1, ipk, nz_W, 32, clop, zsto, zout )
+         ENDIF
+         
+         IF( ln_wave .AND. ln_sdw) THEN
+            CALL histdef( nid_W, "sdvecrtz", "Stokes Drift Vertical Current"   , "m/s"    ,   &  ! wsd
+               &          jpi, jpj, nh_W, ipk, 1, ipk, nz_W, 32, clop, zsto, zout )
+         ENDIF
+         !                                                                                      !!! nid_W : 2D
+         CALL histend( nid_W, snc4chunks=snc4set )
+
+         IF(lwp) WRITE(numout,*)
+         IF(lwp) WRITE(numout,*) 'End of NetCDF Initialization'
+         IF(ll_print) CALL FLUSH(numout )
+
+      ENDIF
+
+      ! 2. Start writing data
+      ! ---------------------
+
+      ! ndex(1) est utilise ssi l'avant dernier argument est different de 
+      ! la taille du tableau en sortie. Dans ce cas , l'avant dernier argument
+      ! donne le nombre d'elements, et ndex la liste des indices a sortir
+
+      IF( lwp .AND. MOD( itmod, nwrite ) == 0 ) THEN 
+         WRITE(numout,*) 'dia_wri : write model outputs in NetCDF files at ', kt, 'time-step'
+         WRITE(numout,*) '~~~~~~ '
+      ENDIF
+
+      IF( .NOT.ln_linssh ) THEN
+         CALL histwrite( nid_T, "votemper", it, tsn(:,:,:,jp_tem) * e3t_n(:,:,:) , ndim_T , ndex_T  )   ! heat content
+         CALL histwrite( nid_T, "vosaline", it, tsn(:,:,:,jp_sal) * e3t_n(:,:,:) , ndim_T , ndex_T  )   ! salt content
+         CALL histwrite( nid_T, "sosstsst", it, tsn(:,:,1,jp_tem) * e3t_n(:,:,1) , ndim_hT, ndex_hT )   ! sea surface heat content
+         CALL histwrite( nid_T, "sosaline", it, tsn(:,:,1,jp_sal) * e3t_n(:,:,1) , ndim_hT, ndex_hT )   ! sea surface salinity content
+      ELSE
+         CALL histwrite( nid_T, "votemper", it, tsn(:,:,:,jp_tem) , ndim_T , ndex_T  )   ! temperature
+         CALL histwrite( nid_T, "vosaline", it, tsn(:,:,:,jp_sal) , ndim_T , ndex_T  )   ! salinity
+         CALL histwrite( nid_T, "sosstsst", it, tsn(:,:,1,jp_tem) , ndim_hT, ndex_hT )   ! sea surface temperature
+         CALL histwrite( nid_T, "sosaline", it, tsn(:,:,1,jp_sal) , ndim_hT, ndex_hT )   ! sea surface salinity
+      ENDIF
+      IF( .NOT.ln_linssh ) THEN
+         zw3d(:,:,:) = ( ( e3t_n(:,:,:) - e3t_0(:,:,:) ) / e3t_0(:,:,:) * 100 * tmask(:,:,:) ) ** 2
+         CALL histwrite( nid_T, "vovvle3t", it, e3t_n (:,:,:) , ndim_T , ndex_T  )   ! level thickness
+         CALL histwrite( nid_T, "vovvldep", it, gdept_n(:,:,:) , ndim_T , ndex_T  )   ! t-point depth
+         CALL histwrite( nid_T, "vovvldef", it, zw3d             , ndim_T , ndex_T  )   ! level thickness deformation
+      ENDIF
+      CALL histwrite( nid_T, "sossheig", it, sshn          , ndim_hT, ndex_hT )   ! sea surface height
+      CALL histwrite( nid_T, "sowaflup", it, ( emp-rnf )   , ndim_hT, ndex_hT )   ! upward water flux
+      CALL histwrite( nid_T, "sorunoff", it, rnf           , ndim_hT, ndex_hT )   ! river runoffs
+      CALL histwrite( nid_T, "sosfldow", it, sfx           , ndim_hT, ndex_hT )   ! downward salt flux 
+                                                                                  ! (includes virtual salt flux beneath ice 
+                                                                                  ! in linear free surface case)
+      IF( ln_linssh ) THEN
+         zw2d(:,:) = emp (:,:) * tsn(:,:,1,jp_tem)
+         CALL histwrite( nid_T, "sosst_cd", it, zw2d, ndim_hT, ndex_hT )          ! c/d term on sst
+         zw2d(:,:) = emp (:,:) * tsn(:,:,1,jp_sal)
+         CALL histwrite( nid_T, "sosss_cd", it, zw2d, ndim_hT, ndex_hT )          ! c/d term on sss
+      ENDIF
+      CALL histwrite( nid_T, "sohefldo", it, qns + qsr     , ndim_hT, ndex_hT )   ! total heat flux
+      CALL histwrite( nid_T, "soshfldo", it, qsr           , ndim_hT, ndex_hT )   ! solar heat flux
+      CALL histwrite( nid_T, "somixhgt", it, hmld          , ndim_hT, ndex_hT )   ! turbocline depth
+      CALL histwrite( nid_T, "somxl010", it, hmlp          , ndim_hT, ndex_hT )   ! mixed layer depth
+      CALL histwrite( nid_T, "soicecov", it, fr_i          , ndim_hT, ndex_hT )   ! ice fraction   
+      CALL histwrite( nid_T, "sowindsp", it, wndm          , ndim_hT, ndex_hT )   ! wind speed   
+!
+      IF( ln_icebergs ) THEN
+         !
+         CALL histwrite( nid_T, "calving"             , it, berg_grid%calving      , ndim_hT, ndex_hT )  
+         CALL histwrite( nid_T, "calving_heat"        , it, berg_grid%calving_hflx , ndim_hT, ndex_hT )         
+         CALL histwrite( nid_T, "berg_floating_melt"  , it, berg_grid%floating_melt, ndim_hT, ndex_hT )  
+         !
+         CALL histwrite( nid_T, "berg_stored_ice"     , it, berg_grid%stored_ice   , ndim_bT, ndex_bT )
+         !
+         IF( ln_bergdia ) THEN
+            CALL histwrite( nid_T, "berg_melt"           , it, berg_melt        , ndim_hT, ndex_hT   )  
+            CALL histwrite( nid_T, "berg_buoy_melt"      , it, buoy_melt        , ndim_hT, ndex_hT   )  
+            CALL histwrite( nid_T, "berg_eros_melt"      , it, eros_melt        , ndim_hT, ndex_hT   )  
+            CALL histwrite( nid_T, "berg_conv_melt"      , it, conv_melt        , ndim_hT, ndex_hT   )  
+            CALL histwrite( nid_T, "berg_virtual_area"   , it, virtual_area     , ndim_hT, ndex_hT   )  
+            CALL histwrite( nid_T, "bits_src"            , it, bits_src         , ndim_hT, ndex_hT   )  
+            CALL histwrite( nid_T, "bits_melt"           , it, bits_melt        , ndim_hT, ndex_hT   )  
+            CALL histwrite( nid_T, "bits_mass"           , it, bits_mass        , ndim_hT, ndex_hT   )  
+            CALL histwrite( nid_T, "berg_mass"           , it, berg_mass        , ndim_hT, ndex_hT   )  
+            !
+            CALL histwrite( nid_T, "berg_real_calving"   , it, real_calving     , ndim_bT, ndex_bT   )
+         ENDIF
+      ENDIF
+
+      IF( .NOT. ln_cpl ) THEN
+         CALL histwrite( nid_T, "sohefldp", it, qrp           , ndim_hT, ndex_hT )   ! heat flux damping
+         CALL histwrite( nid_T, "sowafldp", it, erp           , ndim_hT, ndex_hT )   ! freshwater flux damping
+         IF( ln_ssr ) zw2d(:,:) = erp(:,:) * tsn(:,:,1,jp_sal) * tmask(:,:,1)
+         CALL histwrite( nid_T, "sosafldp", it, zw2d          , ndim_hT, ndex_hT )   ! salt flux damping
+      ENDIF
+      IF( ln_cpl .AND. nn_ice <= 1 ) THEN
+         CALL histwrite( nid_T, "sohefldp", it, qrp           , ndim_hT, ndex_hT )   ! heat flux damping
+         CALL histwrite( nid_T, "sowafldp", it, erp           , ndim_hT, ndex_hT )   ! freshwater flux damping
+         IF( ln_ssr ) zw2d(:,:) = erp(:,:) * tsn(:,:,1,jp_sal) * tmask(:,:,1)
+         CALL histwrite( nid_T, "sosafldp", it, zw2d          , ndim_hT, ndex_hT )   ! salt flux damping
+      ENDIF
+!      zw2d(:,:) = FLOAT( nmln(:,:) ) * tmask(:,:,1)
+!      CALL histwrite( nid_T, "sobowlin", it, zw2d          , ndim_hT, ndex_hT )   ! ???
+
+#if defined key_diahth
+      CALL histwrite( nid_T, "sothedep", it, hth           , ndim_hT, ndex_hT )   ! depth of the thermocline
+      CALL histwrite( nid_T, "so20chgt", it, hd20          , ndim_hT, ndex_hT )   ! depth of the 20 isotherm
+      CALL histwrite( nid_T, "so28chgt", it, hd28          , ndim_hT, ndex_hT )   ! depth of the 28 isotherm
+      CALL histwrite( nid_T, "sohtc300", it, htc3          , ndim_hT, ndex_hT )   ! first 300m heaat content
+#endif
+
+      CALL histwrite( nid_U, "vozocrtx", it, un            , ndim_U , ndex_U )    ! i-current
+      CALL histwrite( nid_U, "sozotaux", it, utau          , ndim_hU, ndex_hU )   ! i-wind stress
+
+      CALL histwrite( nid_V, "vomecrty", it, vn            , ndim_V , ndex_V  )   ! j-current
+      CALL histwrite( nid_V, "sometauy", it, vtau          , ndim_hV, ndex_hV )   ! j-wind stress
+
+      CALL histwrite( nid_W, "vovecrtz", it, wn             , ndim_T, ndex_T )    ! vert. current
+      CALL histwrite( nid_W, "votkeavt", it, avt            , ndim_T, ndex_T )    ! T vert. eddy diff. coef.
+      CALL histwrite( nid_W, "votkeavm", it, avm            , ndim_T, ndex_T )    ! T vert. eddy visc. coef.
+      IF( ln_zdfddm ) THEN
+         CALL histwrite( nid_W, "voddmavs", it, avs         , ndim_T, ndex_T )    ! S vert. eddy diff. coef.
+      ENDIF
+
+      IF( ln_wave .AND. ln_sdw ) THEN
+         CALL histwrite( nid_U, "sdzocrtx", it, usd         , ndim_U , ndex_U )    ! i-StokesDrift-current
+         CALL histwrite( nid_V, "sdmecrty", it, vsd         , ndim_V , ndex_V )    ! j-StokesDrift-current
+         CALL histwrite( nid_W, "sdvecrtz", it, wsd         , ndim_T , ndex_T )    ! StokesDrift vert. current
+      ENDIF
+
+      ! 3. Close all files
+      ! ---------------------------------------
+      IF( kt == nitend ) THEN
+         CALL histclo( nid_T )
+         CALL histclo( nid_U )
+         CALL histclo( nid_V )
+         CALL histclo( nid_W )
+      ENDIF
+      !
+      IF( ln_timing )   CALL timing_stop('dia_wri')
+      !
+   END SUBROUTINE dia_wri
+#endif
+
+   SUBROUTINE dia_wri_state( cdfile_name, kt )
+      !!---------------------------------------------------------------------
+      !!                 ***  ROUTINE dia_wri_state  ***
+      !!        
+      !! ** Purpose :   create a NetCDF file named cdfile_name which contains 
+      !!      the instantaneous ocean state and forcing fields.
+      !!        Used to find errors in the initial state or save the last
+      !!      ocean state in case of abnormal end of a simulation
+      !!
+      !! ** Method  :   NetCDF files using ioipsl
+      !!      File 'output.init.nc'  is created if ninist = 1 (namelist)
+      !!      File 'output.abort.nc' is created in case of abnormal job end
+      !!----------------------------------------------------------------------
+      CHARACTER (len=* ), INTENT( in ) ::   cdfile_name      ! name of the file created
+      INTEGER           , INTENT( in ) ::   kt               ! ocean time-step index
+      !! 
+      CHARACTER (len=32) :: clname
+      CHARACTER (len=40) :: clop
+      INTEGER  ::   id_i , nz_i, nh_i       
+      INTEGER, DIMENSION(1) ::   idex             ! local workspace
+      REAL(wp) ::   zsto, zout, zmax, zjulian
+      !!----------------------------------------------------------------------
+      ! 
+      ! 0. Initialisation
+      ! -----------------
+
+      ! Define name, frequency of output and means
+      clname = cdfile_name
+      IF( .NOT. Agrif_Root() ) clname = TRIM(Agrif_CFixed())//'_'//TRIM(clname)
+      zsto = rdt
+      clop = "inst(x)"           ! no use of the mask value (require less cpu time)
+      zout = rdt
+      zmax = ( nitend - nit000 + 1 ) * rdt
+
+      IF(lwp) WRITE(numout,*)
+      IF(lwp) WRITE(numout,*) 'dia_wri_state : single instantaneous ocean state'
+      IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~   and forcing fields file created '
+      IF(lwp) WRITE(numout,*) '                and named :', clname, '.nc'
+
+
+      ! 1. Define NETCDF files and fields at beginning of first time step
+      ! -----------------------------------------------------------------
+
+      ! Compute julian date from starting date of the run
+      CALL ymds2ju( nyear, nmonth, nday, rdt, zjulian )         ! time axis 
+      zjulian = zjulian - adatrj   !   set calendar origin to the beginning of the experiment
+      CALL histbeg( clname, jpi, glamt, jpj, gphit,   &
+          1, jpi, 1, jpj, nit000-1, zjulian, rdt, nh_i, id_i, domain_id=nidom, snc4chunks=snc4set ) ! Horizontal grid : glamt and gphit
+      CALL histvert( id_i, "deptht", "Vertical T levels",   &    ! Vertical grid : gdept
+          "m", jpk, gdept_1d, nz_i, "down")
+
+      ! Declare all the output fields as NetCDF variables
+
+      CALL histdef( id_i, "vosaline", "Salinity"              , "PSU"    ,   &   ! salinity
+         &          jpi, jpj, nh_i, jpk, 1, jpk, nz_i, 32, clop, zsto, zout )
+      CALL histdef( id_i, "votemper", "Temperature"           , "C"      ,   &   ! temperature
+         &          jpi, jpj, nh_i, jpk, 1, jpk, nz_i, 32, clop, zsto, zout )
+      CALL histdef( id_i, "sossheig", "Sea Surface Height"    , "m"      ,   &  ! ssh
+         &          jpi, jpj, nh_i, 1  , 1, 1  , nz_i, 32, clop, zsto, zout )
+      CALL histdef( id_i, "vozocrtx", "Zonal Current"         , "m/s"    ,   &   ! zonal current
+         &          jpi, jpj, nh_i, jpk, 1, jpk, nz_i, 32, clop, zsto, zout )
+      CALL histdef( id_i, "vomecrty", "Meridional Current"    , "m/s"    ,   &   ! meridonal current
+         &          jpi, jpj, nh_i, jpk, 1, jpk, nz_i, 32, clop, zsto, zout ) 
+      CALL histdef( id_i, "vovecrtz", "Vertical Velocity"     , "m/s"    ,   &   ! vertical current
+         &          jpi, jpj, nh_i, jpk, 1, jpk, nz_i, 32, clop, zsto, zout ) 
+         !
+      IF( ALLOCATED(ahtu) ) THEN
+         CALL histdef( id_i, "ahtu"    , "u-eddy diffusivity"    , "m2/s"    ,   &   ! zonal current
+            &          jpi, jpj, nh_i, jpk, 1, jpk, nz_i, 32, clop, zsto, zout )
+         CALL histdef( id_i, "ahtv"    , "v-eddy diffusivity"    , "m2/s"    ,   &   ! meridonal current
+            &          jpi, jpj, nh_i, jpk, 1, jpk, nz_i, 32, clop, zsto, zout ) 
+      ENDIF
+      IF( ALLOCATED(ahmt) ) THEN 
+         CALL histdef( id_i, "ahmt"    , "t-eddy viscosity"      , "m2/s"    ,   &   ! zonal current
+            &          jpi, jpj, nh_i, jpk, 1, jpk, nz_i, 32, clop, zsto, zout )
+         CALL histdef( id_i, "ahmf"    , "f-eddy viscosity"      , "m2/s"    ,   &   ! meridonal current
+            &          jpi, jpj, nh_i, jpk, 1, jpk, nz_i, 32, clop, zsto, zout ) 
+      ENDIF
+         !
+      CALL histdef( id_i, "sowaflup", "Net Upward Water Flux" , "Kg/m2/S",   &   ! net freshwater 
+         &          jpi, jpj, nh_i, 1  , 1, 1  , -99 , 32, clop, zsto, zout )
+      CALL histdef( id_i, "sohefldo", "Net Downward Heat Flux", "W/m2"   ,   &   ! net heat flux
+         &          jpi, jpj, nh_i, 1  , 1, 1  , -99 , 32, clop, zsto, zout )
+      CALL histdef( id_i, "soshfldo", "Shortwave Radiation"   , "W/m2"   ,   &   ! solar flux
+         &          jpi, jpj, nh_i, 1  , 1, 1  , -99 , 32, clop, zsto, zout )
+      CALL histdef( id_i, "soicecov", "Ice fraction"          , "[0,1]"  ,   &   ! fr_i
+         &          jpi, jpj, nh_i, 1  , 1, 1  , -99 , 32, clop, zsto, zout )
+      CALL histdef( id_i, "sozotaux", "Zonal Wind Stress"     , "N/m2"   ,   &   ! i-wind stress
+         &          jpi, jpj, nh_i, 1  , 1, 1  , -99 , 32, clop, zsto, zout )
+      CALL histdef( id_i, "sometauy", "Meridional Wind Stress", "N/m2"   ,   &   ! j-wind stress
+         &          jpi, jpj, nh_i, 1  , 1, 1  , -99 , 32, clop, zsto, zout )
+      IF( .NOT.ln_linssh ) THEN
+         CALL histdef( id_i, "vovvldep", "T point depth"         , "m"      , &   ! t-point depth
+            &          jpi, jpj, nh_i, jpk, 1, jpk, nz_i, 32, clop, zsto, zout )
+         CALL histdef( id_i, "vovvle3t", "T point thickness"     , "m"      , &   ! t-point depth
+            &          jpi, jpj, nh_i, jpk, 1, jpk, nz_i, 32, clop, zsto, zout )
+      ENDIF
+      !
+      IF( ln_wave .AND. ln_sdw ) THEN
+         CALL histdef( id_i, "sdzocrtx", "Stokes Drift Zonal"    , "m/s"    , &   ! StokesDrift zonal current
+            &          jpi, jpj, nh_i, jpk, 1, jpk, nz_i, 32, clop, zsto, zout )
+         CALL histdef( id_i, "sdmecrty", "Stokes Drift Merid"    , "m/s"    , &   ! StokesDrift meridonal current
+            &          jpi, jpj, nh_i, jpk, 1, jpk, nz_i, 32, clop, zsto, zout )
+         CALL histdef( id_i, "sdvecrtz", "Stokes Drift Vert"     , "m/s"    , &   ! StokesDrift vertical current
+            &          jpi, jpj, nh_i, jpk, 1, jpk, nz_i, 32, clop, zsto, zout )
+      ENDIF
+
+#if defined key_si3
+      IF( nn_ice == 2 ) THEN   ! condition needed in case agrif + ice-model but no-ice in child grid
+         CALL ice_wri_state( kt, id_i, nh_i )
+      ENDIF
+#else
+      CALL histend( id_i, snc4chunks=snc4set )
+#endif
+
+      ! 2. Start writing data
+      ! ---------------------
+      ! idex(1) est utilise ssi l'avant dernier argument est diffferent de 
+      ! la taille du tableau en sortie. Dans ce cas , l'avant dernier argument
+      ! donne le nombre d'elements, et idex la liste des indices a sortir
+      idex(1) = 1   ! init to avoid compil warning
+
+      ! Write all fields on T grid
+      CALL histwrite( id_i, "votemper", kt, tsn(:,:,:,jp_tem), jpi*jpj*jpk, idex )    ! now temperature
+      CALL histwrite( id_i, "vosaline", kt, tsn(:,:,:,jp_sal), jpi*jpj*jpk, idex )    ! now salinity
+      CALL histwrite( id_i, "sossheig", kt, sshn             , jpi*jpj    , idex )    ! sea surface height
+      CALL histwrite( id_i, "vozocrtx", kt, un               , jpi*jpj*jpk, idex )    ! now i-velocity
+      CALL histwrite( id_i, "vomecrty", kt, vn               , jpi*jpj*jpk, idex )    ! now j-velocity
+      CALL histwrite( id_i, "vovecrtz", kt, wn               , jpi*jpj*jpk, idex )    ! now k-velocity
+      !
+      IF( ALLOCATED(ahtu) ) THEN
+         CALL histwrite( id_i, "ahtu"    , kt, ahtu             , jpi*jpj*jpk, idex )    ! aht at u-point
+         CALL histwrite( id_i, "ahtv"    , kt, ahtv             , jpi*jpj*jpk, idex )    !  -  at v-point
+      ENDIF
+      IF( ALLOCATED(ahmt) ) THEN
+         CALL histwrite( id_i, "ahmt"    , kt, ahmt             , jpi*jpj*jpk, idex )    ! ahm at t-point
+         CALL histwrite( id_i, "ahmf"    , kt, ahmf             , jpi*jpj*jpk, idex )    !  -  at f-point
+      ENDIF
+      !
+      CALL histwrite( id_i, "sowaflup", kt, emp - rnf        , jpi*jpj    , idex )    ! freshwater budget
+      CALL histwrite( id_i, "sohefldo", kt, qsr + qns        , jpi*jpj    , idex )    ! total heat flux
+      CALL histwrite( id_i, "soshfldo", kt, qsr              , jpi*jpj    , idex )    ! solar heat flux
+      CALL histwrite( id_i, "soicecov", kt, fr_i             , jpi*jpj    , idex )    ! ice fraction
+      CALL histwrite( id_i, "sozotaux", kt, utau             , jpi*jpj    , idex )    ! i-wind stress
+      CALL histwrite( id_i, "sometauy", kt, vtau             , jpi*jpj    , idex )    ! j-wind stress
+
+      IF(  .NOT.ln_linssh  ) THEN             
+         CALL histwrite( id_i, "vovvldep", kt, gdept_n(:,:,:), jpi*jpj*jpk, idex )!  T-cell depth 
+         CALL histwrite( id_i, "vovvle3t", kt, e3t_n (:,:,:) , jpi*jpj*jpk, idex )!  T-cell thickness  
+      END IF 
+ 
+      IF( ln_wave .AND. ln_sdw ) THEN
+         CALL histwrite( id_i, "sdzocrtx", kt, usd           , jpi*jpj*jpk, idex)     ! now StokesDrift i-velocity
+         CALL histwrite( id_i, "sdmecrty", kt, vsd           , jpi*jpj*jpk, idex)     ! now StokesDrift j-velocity
+         CALL histwrite( id_i, "sdvecrtz", kt, wsd           , jpi*jpj*jpk, idex)     ! now StokesDrift k-velocity
+      ENDIF
+
+      ! 3. Close the file
+      ! -----------------
+      CALL histclo( id_i )
+#if ! defined key_iomput
+      IF( ninist /= 1  ) THEN
+         CALL histclo( nid_T )
+         CALL histclo( nid_U )
+         CALL histclo( nid_V )
+         CALL histclo( nid_W )
+      ENDIF
+#endif
+      ! 
+   END SUBROUTINE dia_wri_state
+
+   !!======================================================================
+END MODULE diawri
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DIU/cool_skin.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DIU/cool_skin.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DIU/cool_skin.F90	(revision 9570)
@@ -0,0 +1,146 @@
+MODULE cool_skin
+   !!======================================================================
+   !!                    ***  MODULE  cool_skin  ***
+   !!     Cool skin thickness and delta T correction using Artele et al. (2002)
+   !!     [see also Tu and Tsuang (2005)]
+   !!
+   !!=====================================================================
+   !! History :        !  2012-01  (P. Sykes)  Original code
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   diurnal_sst_coolskin_init : initialisation of the cool skin
+   !!   diurnal_sst_coolskin_step : time-stepping  of the cool skin corrections
+   !!----------------------------------------------------------------------
+   USE par_kind
+   USE phycst
+   USE dom_oce
+   USE in_out_manager
+   USE sbc_oce
+   USE lib_mpp
+   USE lbclnk          ! ocean lateral boundary conditions (or mpp link)
+   
+   IMPLICIT NONE
+   PRIVATE
+
+   ! Namelist parameters
+
+   ! Parameters
+   REAL(wp), PRIVATE, PARAMETER :: pp_k = 0.596_wp          ! Thermal conductivity of seawater
+   REAL(wp), PRIVATE, PARAMETER :: pp_v = 1.05e-6_wp        ! Kinematic viscosity of seawater
+   REAL(wp), PRIVATE, PARAMETER :: pp_C = 86400             ! seconds [see Tu and Tsuang (2005)]
+   REAL(wp), PRIVATE, PARAMETER :: pp_cw = 3993._wp         ! specific heat capacity of seawater
+   REAL(wp), PRIVATE, PARAMETER :: pp_h = 10._wp            ! reference depth [using 10m from Artale et al. (2002)]
+   REAL(wp), PRIVATE, PARAMETER :: pp_rhoa = 1.20421_wp     ! density of air (at 20C)
+   REAL(wp), PRIVATE, PARAMETER :: pp_cda = 1.45e-3_wp      ! assumed air-sea drag coefficient for calculating wind speed
+   
+   ! Key variables
+   REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: x_csdsst    ! Cool skin delta SST
+   REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: x_csthick   ! Cool skin thickness
+
+   PUBLIC diurnal_sst_coolskin_step, diurnal_sst_coolskin_init
+
+      !! * Substitutions
+#  include "vectopt_loop_substitute.h90"
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 4.0 , NEMO-consortium (2016) 
+   !! $Id:  $
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------   
+   CONTAINS 
+   
+   SUBROUTINE diurnal_sst_coolskin_init
+      !!----------------------------------------------------------------------
+      !! *** ROUTINE diurnal_sst_coolskin_init ***
+      !!
+      !! ** Purpose :   initialise the cool skin model
+      !!
+      !! ** Method : 
+      !!
+      !! ** Reference :
+      !! 
+      !!----------------------------------------------------------------------
+      ALLOCATE( x_csdsst(jpi,jpj), x_csthick(jpi,jpj) )
+      x_csdsst = 0.
+      x_csthick = 0.
+      !
+   END SUBROUTINE diurnal_sst_coolskin_init
+
+
+   SUBROUTINE diurnal_sst_coolskin_step(psqflux, pstauflux, psrho, rdt)
+      !!----------------------------------------------------------------------
+      !! *** ROUTINE diurnal_sst_takaya_step ***
+      !!
+      !! ** Purpose :   Time-step the Artale cool skin model
+      !!
+      !! ** Method : 
+      !!
+      !! ** Reference : 
+      !!----------------------------------------------------------------------
+      ! Dummy variables
+      REAL(wp), INTENT(IN), DIMENSION(jpi,jpj) :: psqflux     ! Heat (non-solar)(Watts)
+      REAL(wp), INTENT(IN), DIMENSION(jpi,jpj) :: pstauflux   ! Wind stress (kg/ m s^2)
+      REAL(wp), INTENT(IN), DIMENSION(jpi,jpj) :: psrho       ! Water density (kg/m^3)
+      REAL(wp), INTENT(IN) :: rdt                             ! Time-step
+     
+      ! Local variables
+      REAL(wp), DIMENSION(jpi,jpj) :: z_fv                    ! Friction velocity     
+      REAL(wp), DIMENSION(jpi,jpj) :: z_gamma                 ! Dimensionless function of wind speed
+      REAL(wp), DIMENSION(jpi,jpj) :: z_lamda                 ! Sauders (dimensionless) proportionality constant
+      REAL(wp), DIMENSION(jpi,jpj) :: z_wspd                  ! Wind speed (m/s)
+      REAL(wp) :: z_ztx                                       ! Temporary u wind stress
+      REAL(wp) :: z_zty                                       ! Temporary v wind stress
+      REAL(wp) :: z_zmod                                      ! Temporary total wind stress
+     
+      INTEGER :: ji,jj
+      !!----------------------------------------------------------------------
+      !
+      IF( .NOT. ln_blk )   CALL ctl_stop("cool_skin.f90: diurnal flux processing only implemented for bulk forcing")
+      !
+      DO jj = 1,jpj
+         DO ji = 1,jpi
+            !
+            ! Calcualte wind speed from wind stress and friction velocity
+            IF( tmask(ji,jj,1) == 1. .AND. pstauflux(ji,jj) /= 0 .AND. psrho(ji,jj) /=0 ) THEN
+               z_fv(ji,jj) = SQRT( pstauflux(ji,jj) / psrho(ji,jj) )
+               z_wspd(ji,jj) = SQRT( pstauflux(ji,jj) / ( pp_cda * pp_rhoa ) )
+            ELSE
+               z_fv(ji,jj) = 0.
+               z_wspd(ji,jj) = 0.     
+            ENDIF
+            !
+            ! Calculate gamma function which is dependent upon wind speed
+            IF( tmask(ji,jj,1) == 1. ) THEN
+               IF( ( z_wspd(ji,jj) <= 7.5 ) ) z_gamma(ji,jj) = ( 0.2 * z_wspd(ji,jj) ) + 0.5
+               IF( ( z_wspd(ji,jj) > 7.5 ) .AND. ( z_wspd(ji,jj) < 10. ) ) z_gamma(ji,jj) = ( 1.6 * z_wspd(ji,jj) ) - 10.
+               IF( ( z_wspd(ji,jj) >= 10. ) ) z_gamma(ji,jj) = 6.
+            ENDIF
+            !
+            ! Calculate lamda function
+            IF( tmask(ji,jj,1) == 1. .AND. z_fv(ji,jj) /= 0 ) THEN
+               z_lamda(ji,jj) = ( z_fv(ji,jj) * pp_k * pp_C ) / ( z_gamma(ji,jj) * psrho(ji,jj) * pp_cw * pp_h * pp_v )
+            ELSE
+               z_lamda(ji,jj) = 0.
+            ENDIF
+            !
+            ! Calculate the cool skin thickness - only when heat flux is out of the ocean
+            IF( tmask(ji,jj,1) == 1. .AND. z_fv(ji,jj) /= 0 .AND. psqflux(ji,jj) < 0 ) THEN
+               x_csthick(ji,jj) = ( z_lamda(ji,jj) * pp_v ) / z_fv(ji,jj)
+            ELSE
+               x_csthick(ji,jj) = 0.
+            ENDIF
+            !
+            ! Calculate the cool skin correction - only when the heat flux is out of the ocean
+            IF( tmask(ji,jj,1) == 1. .AND. x_csthick(ji,jj) /= 0. .AND. psqflux(ji,jj) < 0. ) THEN
+               x_csdsst(ji,jj) = ( psqflux(ji,jj) * x_csthick(ji,jj) ) / pp_k
+             ELSE
+               x_csdsst(ji,jj) = 0.
+            ENDIF
+            !
+         END DO
+      END DO
+      !
+   END SUBROUTINE diurnal_sst_coolskin_step
+
+   !!======================================================================
+END MODULE cool_skin
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DIU/diurnal_bulk.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DIU/diurnal_bulk.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DIU/diurnal_bulk.F90	(revision 9570)
@@ -0,0 +1,267 @@
+MODULE diurnal_bulk
+   !!======================================================================
+   !!                    ***  MODULE  diurnal_bulk  ***
+   !!     Takaya model of diurnal warming (Takaya, 2010)
+   !!=====================================================================
+   !! History :        !  11-10  (J. While)  Original code
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   diurnal_sst_bulk_init  : initialise diurnal model
+   !!   diurnal_sst_bulk_step  : time-step the diurnal model
+   !!----------------------------------------------------------------------
+   USE par_kind
+   USE phycst
+   USE dom_oce
+   USE lib_mpp
+   USE solfrac_mod
+   USE in_out_manager
+   
+   IMPLICIT NONE
+   PRIVATE
+   
+   ! Namelist parameters
+   LOGICAL, PUBLIC :: ln_diurnal
+   LOGICAL, PUBLIC :: ln_diurnal_only
+
+   ! Parameters
+   REAL(wp), PRIVATE, PARAMETER :: pp_alpha = 2.0e-4_wp
+   REAL(wp), PRIVATE, PARAMETER :: pp_veltol = 0._wp
+   REAL(wp), PRIVATE, PARAMETER :: pp_min_fvel = 1.e-10_wp 
+   
+   ! Key variables
+   REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: x_dsst     ! Delta SST
+   REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: x_solfrac  ! Fraction of 
+   !                                                           ! absorbed radiation
+
+   PUBLIC diurnal_sst_bulk_init, diurnal_sst_takaya_step
+   
+   !!----------------------------------------------------------------------
+CONTAINS 
+   
+   SUBROUTINE diurnal_sst_bulk_init
+      !!----------------------------------------------------------------------
+      !! *** ROUTINE diurnal_sst_init ***
+      !!
+      !! ** Purpose : Initialise the Takaya diurnal model   
+      !!----------------------------------------------------------------------      
+      INTEGER ::   ios   ! local integer
+      !!
+      NAMELIST /namdiu/ ln_diurnal, ln_diurnal_only
+      !!----------------------------------------------------------------------      
+
+      ! Read the namelist
+      REWIND( numnam_ref )
+      READ  ( numnam_ref, namdiu, IOSTAT = ios, ERR = 901 )
+901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namdiu in reference namelist', lwp )
+      REWIND( numnam_cfg )
+      READ  ( numnam_cfg, namdiu, IOSTAT = ios, ERR = 902 )
+902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namdiu in configuration namelist', lwp )      
+      !
+      IF( ln_diurnal_only .AND. ( .NOT. ln_diurnal ) ) THEN
+         CALL ctl_stop( "ln_diurnal_only set, but ln_diurnal = FALSE !" )
+      ENDIF
+      
+      IF( ln_diurnal ) THEN      
+         !         
+         ALLOCATE( x_dsst(jpi,jpj), x_solfrac(jpi,jpj) )
+         !
+         x_solfrac = 0._wp         ! Initialise the solar fraction
+         x_dsst    = 0._wp
+         !
+         IF( ln_diurnal_only ) THEN
+            CALL ctl_warn( "ln_diurnal_only set; only the diurnal component of SST will be calculated" )
+         ENDIF
+      ENDIF
+      
+   END SUBROUTINE diurnal_sst_bulk_init
+
+
+   SUBROUTINE diurnal_sst_takaya_step(kt, psolflux, pqflux, ptauflux, prho, p_rdt,   &
+            &                  pla, pthick, pcoolthick, pmu, &
+            &                  p_fvel_bkginc, p_hflux_bkginc)
+      !!----------------------------------------------------------------------
+      !! *** ROUTINE diurnal_sst_takaya_step ***
+      !!
+      !! ** Purpose :   Time-step the Takaya diurnal model
+      !!
+      !! ** Method :    1) Calculate the Obukhov length
+      !!                2) Calculate the Similarity function
+      !!                2) Calculate the increment to dsst
+      !!                3) Apply the increment
+      !! ** Reference : Refinements to a prognostic scheme of skin sea surface
+      !!                temperature, Takaya et al, JGR, 2010 
+      !!----------------------------------------------------------------------
+      INTEGER                               , INTENT(in) ::   kt             ! time step
+      REAL(wp), DIMENSION(jpi,jpj)          , INTENT(in) ::   psolflux       ! solar flux (Watts)
+      REAL(wp), DIMENSION(jpi,jpj)          , INTENT(in) ::   pqflux         ! heat (non-solar) flux (Watts)
+      REAL(wp), DIMENSION(jpi,jpj)          , INTENT(in) ::   ptauflux       ! wind stress  (kg/ m s^2)
+      REAL(wp), DIMENSION(jpi,jpj)          , INTENT(in) ::   prho           ! water density  (kg/m^3)
+      REAL(wp)                              , INTENT(in) ::   p_rdt          ! time-step
+      REAL(wp), DIMENSION(jpi,jpj), OPTIONAL, INTENT(in) ::   pLa            ! Langmuir number
+      REAL(wp), DIMENSION(jpi,jpj), OPTIONAL, INTENT(in) ::   pthick         ! warm layer thickness (m)
+      REAL(wp), DIMENSION(jpi,jpj), OPTIONAL, INTENT(in) ::   pcoolthick     ! cool skin thickness (m)
+      REAL(wp), DIMENSION(jpi,jpj), OPTIONAL, INTENT(in) ::   pmu            ! mu parameter
+      REAL(wp), DIMENSION(jpi,jpj), OPTIONAL, INTENT(in) ::   p_hflux_bkginc ! increment to the heat flux
+      REAL(wp), DIMENSION(jpi,jpj), OPTIONAL, INTENT(in) ::   p_fvel_bkginc  ! increment to the friction velocity
+      !
+      INTEGER :: ji,jj
+      LOGICAL  :: ll_calcfrac
+      REAL(wp), DIMENSION(jpi,jpj) :: z_fvel              ! friction velocity     
+      REAL(wp), DIMENSION(jpi,jpj) :: zthick, zcoolthick, zmu, zla
+      REAL(wp), DIMENSION(jpi,jpj) :: z_abflux            ! absorbed flux           
+      REAL(wp), DIMENSION(jpi,jpj) :: z_fla               ! Langmuir function value 
+      !!----------------------------------------------------------------------
+
+      ! Set optional arguments to their defaults
+      IF( .NOT. PRESENT( pthick )   ) THEN   ;   zthick(:,:) = 3._wp
+      ELSE                                   ;   zthick(:,:) = pthick(:,:)
+      ENDIF
+      IF( .NOT. PRESENT(pcoolthick) ) THEN   ;   zcoolthick(:,:) = 0._wp
+      ELSE                                   ;   zcoolthick(:,:) = pcoolthick(:,:)
+      ENDIF
+      IF( .NOT. PRESENT( pmu )      ) THEN   ;   zmu(:,:) = 0.3_wp
+      ELSE                                   ;   zmu(:,:) = pmu(:,:)
+      ENDIF
+      IF( .NOT. PRESENT(pla) ) THEN          ;   zla(:,:) = 0.3_wp
+      ELSE                                   ;   zla(:,:) = pla(:,:)
+      ENDIF
+      
+      ! If not done already, calculate the solar fraction
+      IF ( kt==nit000 ) THEN
+         DO jj = 1,jpj
+            DO ji = 1, jpi
+               IF(  ( x_solfrac(ji,jj) == 0._wp ) .AND. ( tmask(ji,jj,1) == 1._wp ) ) &
+                  &   x_solfrac(ji,jj) = solfrac( zcoolthick(ji,jj),zthick(ji,jj) )
+            END DO
+         END DO   
+      ENDIF   
+
+      ! convert solar flux and heat flux to absorbed flux   
+      WHERE ( tmask(:,:,1) == 1._wp) 
+         z_abflux(:,:) = (  x_solfrac(:,:) *  psolflux (:,:)) + pqflux(:,:)     
+      ELSEWHERE
+         z_abflux(:,:) = 0._wp
+      ENDWHERE
+      IF( PRESENT(p_hflux_bkginc) ) z_abflux(:,:) = z_abflux(:,:) + p_hflux_bkginc   ! Optional increment
+      WHERE ( ABS( z_abflux(:,:) ) < rsmall )
+         z_abflux(:,:) = rsmall
+      ENDWHERE 
+      
+      ! Calculate the friction velocity
+      WHERE ( (ptauflux /= 0) .AND. ( tmask(:,:,1) == 1.) )   
+         z_fvel(:,:) = SQRT( ptauflux(:,:) / prho(:,:) )
+      ELSEWHERE
+         z_fvel(:,:) = 0._wp
+      ENDWHERE
+      IF( PRESENT(p_fvel_bkginc) ) z_fvel(:,:) = z_fvel(:,:) + p_fvel_bkginc   ! Optional increment
+      
+       
+       
+      ! Calculate the Langmuir function value
+      WHERE ( tmask(:,:,1) == 1.)
+         z_fla(:,:) = MAX( 1._wp, zla(:,:)**( -2._wp / 3._wp ) )  
+      ELSEWHERE
+         z_fla(:,:) = 0._wp
+      ENDWHERE     
+      
+      ! Increment the temperature using the implicit solution
+      x_dsst(:,:) = t_imp( x_dsst(:,:), p_rdt, z_abflux(:,:), z_fvel(:,:),   &
+         &                       z_fla(:,:), zmu(:,:), zthick(:,:), prho(:,:) )
+      !
+   END SUBROUTINE diurnal_sst_takaya_step
+
+   
+   FUNCTION t_imp(p_dsst, p_rdt, p_abflux, p_fvel, &
+                          p_fla, pmu, pthick, prho )
+                          
+      IMPLICIT NONE
+      
+      ! Function definition
+      REAL(wp), DIMENSION(jpi,jpj) :: t_imp
+      ! Dummy variables
+      REAL(wp), DIMENSION(jpi,jpj), INTENT(IN) :: p_dsst     ! Delta SST
+      REAL(wp), INTENT(IN)                     :: p_rdt      ! Time-step
+      REAL(wp), DIMENSION(jpi,jpj), INTENT(IN) :: p_abflux   ! Heat forcing
+      REAL(wp), DIMENSION(jpi,jpj), INTENT(IN) :: p_fvel     ! Friction velocity
+      REAL(wp), DIMENSION(jpi,jpj), INTENT(IN) :: p_fla      ! Langmuir number
+      REAL(wp), DIMENSION(jpi,jpj), INTENT(IN) :: pmu        ! Structure parameter
+      REAL(wp), DIMENSION(jpi,jpj), INTENT(IN) :: pthick     ! Layer thickness
+      REAL(wp), DIMENSION(jpi,jpj), INTENT(IN) :: prho       ! Water density
+   
+      ! Local variables
+      REAL(wp) :: z_olength          ! Obukhov length
+      REAL(wp) :: z_sigma, z_sigma2
+      REAL(wp) :: z_term1, z_term2     
+      REAL(wp) :: z_stabfunc         ! stability function value
+      REAL(wp) :: z_fvel      
+      
+      CHARACTER(200) :: warn_string
+       
+      INTEGER :: ji,jj
+                     
+      DO jj = 1, jpj
+         DO ji = 1, jpi   
+            
+            ! Only calculate outside tmask
+            IF ( tmask(ji,jj,1) /= 1._wp ) THEN
+               t_imp(ji,jj) = 0._wp
+               CYCLE   
+            END IF
+            
+            IF (p_fvel(ji,jj) < pp_min_fvel) THEN
+               z_fvel = pp_min_fvel
+               WRITE(warn_string,*) "diurnal_sst_takaya step: "&
+               &//"friction velocity < minimum\n" &
+               &//"Setting friction velocity =",pp_min_fvel
+               CALL ctl_warn(warn_string)
+               
+            ELSE
+               z_fvel = p_fvel(ji,jj)
+            ENDIF
+                 
+            ! Calculate the Obukhov length
+            IF ( (z_fvel < pp_veltol ) .AND. &
+            &    (p_dsst(ji,jj) > 0._wp) ) THEN
+               z_olength =  z_fvel  / &
+               &     SQRT( p_dsst(ji,jj) * vkarmn * grav * &
+               &             pp_alpha / ( 5._wp * pthick(ji,jj) ) )
+            ELSE
+               z_olength = &
+               &   ( prho(ji,jj) * rcp * z_fvel**3._wp ) / &
+               &   ( vkarmn * grav * pp_alpha *&
+               &     p_abflux(ji,jj) )
+            ENDIF
+             
+            ! Calculate the stability function          
+            z_sigma = pthick(ji,jj) / z_olength
+            z_sigma2 = z_sigma * z_sigma
+  
+            IF ( z_sigma >= 0. ) THEN
+               z_stabfunc = 1._wp + &
+               &  ( ( 5._wp * z_sigma + 4._wp * z_sigma2 ) / &
+               &  ( 1._wp + 3._wp * z_sigma + 0.25_wp * &
+               &    z_sigma2 ) )
+            ELSE
+               z_stabfunc = 1._wp / &
+               &                   SQRT( 1._wp - 16._wp * z_sigma )
+            ENDIF
+
+            ! Calculate the T increment
+            z_term1 = ( p_abflux(ji,jj) * ( pmu(ji,jj) + 1._wp)  / &
+            & ( pmu(ji,jj) * pthick(ji,jj) * prho(ji,jj) * rcp ) )
+            
+             
+            z_term2 = -( ( pmu(ji,jj) + 1._wp) * &
+            &                       ( vkarmn * z_fvel * p_fla(ji,jj) ) / &
+            &      ( pthick(ji,jj) * z_stabfunc ) )     
+          
+            t_imp(ji,jj) = ( p_dsst(ji,jj) + p_rdt * z_term1 ) / &
+                           ( 1._wp - p_rdt * z_term2 )
+
+         END DO
+      END DO
+      
+      END FUNCTION t_imp
+
+END MODULE diurnal_bulk
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DIU/solfrac_mod.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DIU/solfrac_mod.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DIU/solfrac_mod.F90	(revision 9570)
@@ -0,0 +1,56 @@
+MODULE solfrac_mod
+   !!======================================================================
+   !!                    ***  MODULE  solfrac  ***
+   !!     POSH representation of solar absorption (Gntermann, 2009)
+   !!=====================================================================
+   !! History :        !  11-10  (J. While)  Original code
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   solfrac  : function to calculate the solar fraction
+   !!----------------------------------------------------------------------
+   
+   USE par_kind
+   IMPLICIT NONE
+     
+   ! Parameters 
+   REAL(wp), PRIVATE, PARAMETER, DIMENSION(9) :: &
+   &                                     pp_wgt = (/0.2370, 0.36,  0.1790, &
+   &                                                0.087,  0.08,  0.025,  &
+   &                                                0.025,  0.007, 0.0004/)
+   REAL(wp), PRIVATE, PARAMETER, DIMENSION(9) :: &
+   &                                    pp_len = (/34.84,   2.266,   0.0315,  &
+   &                                               0.0055,  8.32e-4, 1.26e-4, &
+   &                                                3.13e-4, 7.82e-4, 1.44e-5/)
+   
+   PUBLIC solfrac
+                                                   
+CONTAINS
+
+   REAL(dp) FUNCTION solfrac(ptop,pbottom)
+       !!----------------------------------------------------------------------
+      !! *** ROUTINE solfrac ***
+      !!
+      !! ** Purpose :   Calculate the solar fraction absorbed between two 
+      !!                layers
+      !!
+      !! ** Reference : POSH a model of diurnal warming, Gentemann et al, 
+      !!                 JGR, 2009 
+      !!----------------------------------------------------------------------
+      
+      ! Dummy variabes
+      REAL(wp), INTENT(IN) :: ptop, pbottom   ! Top and bottom of layer
+      
+      ! local variables
+      INTEGER :: jt
+      
+      ! Calculate the solar fraction absorbed between the two layers
+      solfrac = 0._wp
+      DO jt = 1, 9
+           solfrac = solfrac + pp_wgt(jt) * ( exp ( -ptop / pp_len(jt) ) &
+            &                                 - exp ( -pbottom / pp_len(jt) ) )
+      END DO
+      
+   END FUNCTION
+   
+END MODULE solfrac_mod
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DIU/step_diu.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DIU/step_diu.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DIU/step_diu.F90	(revision 9570)
@@ -0,0 +1,93 @@
+MODULE step_diu
+   !!======================================================================
+   !!                       ***  MODULE stp_diu  ***
+   !! Time-stepping of diurnal cycle models
+   !!======================================================================
+   !! History :  3.7  ! 2015-11  (J. While)  Original code
+
+   USE diurnal_bulk    ! diurnal SST bulk routines  (diurnal_sst_takaya routine) 
+   USE cool_skin       ! diurnal cool skin correction (diurnal_sst_coolskin routine)   
+   USE iom
+   USE sbc_oce
+   USE sbcmod           ! surface boundary condition       (sbc     routine)
+   USE diaobs           ! Observation operator
+   USE oce
+   USE daymod
+   USE restart          ! ocean restart                    (rst_wri routine)
+   USE timing           ! Timing
+   
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   stp_diurnal   ! called by nemogcm.F90 or step.F90
+
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.7 , NEMO Consortium (2015)
+   !! $Id:$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+
+   CONTAINS
+
+   SUBROUTINE stp_diurnal( kstp ) 
+      INTEGER, INTENT(in) ::   kstp   ! ocean time-step index 
+      !!---------------------------------------------------------------------- 
+      !!                     ***  ROUTINE stp_diurnal  *** 
+      !!                       
+      !! ** Purpose : - Time stepping of diurnal SST model only 
+      !!   
+      !! ** Method  : -1- Update forcings and data   
+      !!              -2- Update ocean physics   
+      !!              -3- Compute the t and s trends   
+      !!              -4- Update t and s   
+      !!              -5- Compute the momentum trends 
+      !!              -6- Update the horizontal velocity 
+      !!              -7- Compute the diagnostics variables (rd,N2, div,cur,w) 
+      !!              -8- Outputs and diagnostics 
+      !!---------------------------------------------------------------------- 
+      INTEGER ::   jk       ! dummy loop indices
+      INTEGER ::   indic    ! error indicator if < 0 
+      REAL(wp), DIMENSION(jpi,jpj) :: z_fvel_bkginc, z_hflux_bkginc     
+      !! --------------------------------------------------------------------- 
+      
+      IF(ln_diurnal_only) THEN
+         indic = 0                                 ! reset to no error condition 
+         IF( kstp /= nit000 )   CALL day( kstp )   ! Calendar (day was already called at nit000 in day_init) 
+ 
+         CALL iom_setkt( kstp - nit000 + 1, cxios_context )   ! tell iom we are at time step kstp
+         IF( ln_crs ) THEN
+            CALL iom_setkt( kstp - nit000 + 1, TRIM(cxios_context)//"_crs" ) ! tell iom we are at time step kstp
+         ENDIF
+       
+            CALL sbc    ( kstp )                      ! Sea Boundary Conditions 
+      ENDIF
+     
+      ! Cool skin
+      IF( .NOT.ln_diurnal )   CALL ctl_stop( "stp_diurnal: ln_diurnal not set" )
+         
+      IF( .NOT. ln_blk    )   CALL ctl_stop( "stp_diurnal: diurnal flux processing only implemented for bulk forcing" ) 
+
+      CALL diurnal_sst_coolskin_step( qns, taum, rhop(:,:,1), rdt)
+
+      CALL iom_put( "sst_wl"   , x_dsst               )    ! warm layer (write out before update below).
+      CALL iom_put( "sst_cs"   , x_csdsst             )    ! cool skin
+
+      ! Diurnal warm layer model       
+      CALL diurnal_sst_takaya_step( kstp, & 
+      &    qsr, qns, taum, rhop(:,:,1), rdt) 
+
+      IF( ln_diurnal_only ) THEN
+         IF( ln_diaobs )         CALL dia_obs( kstp )         ! obs-minus-model (assimilation) diagnostics (call after dynamics update)
+     
+         !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 
+         ! Control and restarts 
+         !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 
+         IF( kstp == nit000   )   CALL iom_close( numror )     ! close input  ocean restart file 
+         IF( lrst_oce         )   CALL rst_write    ( kstp )   ! write output ocean restart file
+     
+         IF( ln_timing .AND.  kstp == nit000  )   CALL timing_reset 
+      ENDIF
+       
+   END SUBROUTINE stp_diurnal  
+   
+END MODULE step_diu
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DOM/closea.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DOM/closea.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DOM/closea.F90	(revision 9570)
@@ -0,0 +1,488 @@
+MODULE closea
+   !!======================================================================
+   !!                   ***  MODULE  closea  ***
+   !!
+   !! User define : specific treatments associated with closed seas
+   !!======================================================================
+   !! History :   8.2  !  2000-05  (O. Marti)  Original code
+   !!   NEMO      1.0  !  2002-06  (E. Durand, G. Madec)  F90
+   !!             3.0  !  2006-07  (G. Madec)  add clo_rnf, clo_ups, clo_bat
+   !!             3.4  !  2014-12  (P.G. Fogli) sbc_clo bug fix & mpp reproducibility
+   !!             4.0  !  2016-06  (G. Madec)  move to usrdef_closea, remove clo_ups
+   !!             4.0  !  2017-12  (D. Storkey) new formulation based on masks read from file
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   dom_clo    : read in masks which define closed seas and runoff areas
+   !!   sbc_clo    : Special handling of freshwater fluxes over closed seas
+   !!   clo_rnf    : set close sea outflows as river mouths (see sbcrnf)
+   !!   clo_bat    : set to zero a field over closed sea (see domzgr)
+   !!----------------------------------------------------------------------
+   USE oce             ! dynamics and tracers
+   USE dom_oce         ! ocean space and time domain
+   USE phycst          ! physical constants
+   USE sbc_oce         ! ocean surface boundary conditions
+   USE iom             ! I/O routines
+   !
+   USE in_out_manager  ! I/O manager
+   USE lib_fortran,    ONLY: glob_sum
+   USE lbclnk          ! lateral boundary condition - MPP exchanges
+   USE lib_mpp         ! MPP library
+   USE timing          ! Timing
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC dom_clo      ! called by domain module
+   PUBLIC sbc_clo      ! called by sbcmod module
+   PUBLIC clo_rnf      ! called by sbcrnf module
+   PUBLIC clo_bat      ! called in domzgr module
+
+   LOGICAL, PUBLIC :: ln_closea  !:  T => keep closed seas (defined by closea_mask field) in the domain and apply
+                                 !:       special treatment of freshwater fluxes.
+                                 !:  F => suppress closed seas (defined by closea_mask field) from the bathymetry
+                                 !:       at runtime.
+                                 !:  If there is no closea_mask field in the domain_cfg file or we do not use
+                                 !:  a domain_cfg file then this logical does nothing.
+                                 !:
+   LOGICAL, PUBLIC :: l_sbc_clo  !: T => Closed seas defined, apply special treatment of freshwater fluxes.
+                                 !: F => No closed seas defined (closea_mask field not found).
+   LOGICAL, PUBLIC :: l_clo_rnf  !: T => Some closed seas output freshwater (RNF or EMPMR) to specified runoff points.
+   INTEGER, PUBLIC :: jncs       !: number of closed seas (inferred from closea_mask field)
+   INTEGER, PUBLIC :: jncsr      !: number of closed seas rnf mappings (inferred from closea_mask_rnf field)
+   INTEGER, PUBLIC :: jncse      !: number of closed seas empmr mappings (inferred from closea_mask_empmr field)
+   
+   INTEGER, PUBLIC, ALLOCATABLE, DIMENSION(:,:) ::  closea_mask       !: mask of integers defining closed seas
+   INTEGER, PUBLIC, ALLOCATABLE, DIMENSION(:,:) ::  closea_mask_rnf   !: mask of integers defining closed seas rnf mappings
+   INTEGER, PUBLIC, ALLOCATABLE, DIMENSION(:,:) ::  closea_mask_empmr !: mask of integers defining closed seas empmr mappings
+   REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:)  ::   surf         !: closed sea surface areas 
+                                                                  !: (and residual global surface area) 
+   REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:)  ::   surfr        !: closed sea target rnf surface areas 
+   REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:)  ::   surfe        !: closed sea target empmr surface areas 
+
+   !! * Substitutions
+#  include "vectopt_loop_substitute.h90"
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 4.0 , NEMO Consortium (2016)
+   !! $Id: usrdef_closea.F90 9124 2017-12-19 08:26:25Z gm $
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE dom_clo()
+      !!---------------------------------------------------------------------
+      !!                  ***  ROUTINE dom_clo  ***
+      !!        
+      !! ** Purpose :   Closed sea domain initialization
+      !!
+      !! ** Method  :   if a closed sea is located only in a model grid point
+      !!                just the thermodynamic processes are applied.
+      !!
+      !! ** Action  :   Read closea_mask* fields (if they exist) from domain_cfg file and infer
+      !!                number of closed seas from closea_mask field.
+      !!                closea_mask       : integer values defining closed seas (or groups of closed seas)
+      !!                closea_mask_rnf   : integer values defining mappings from closed seas or groups of
+      !!                                    closed seas to a runoff area for downwards flux only.
+      !!                closea_mask_empmr : integer values defining mappings from closed seas or groups of
+      !!                                    closed seas to a runoff area for net fluxes.
+      !!
+      !!                Python code to generate the closea_masks* fields from the old-style indices
+      !!                definitions is available at TOOLS/DOMAINcfg/make_closea_masks.py
+      !!----------------------------------------------------------------------
+      INTEGER ::   inum    ! input file identifier
+      INTEGER ::   ierr    ! error code
+      INTEGER ::   id      ! netcdf variable ID
+
+      REAL(wp), DIMENSION(jpi,jpj) :: zdata_in ! temporary real array for input
+      !!----------------------------------------------------------------------
+      !
+      IF(lwp) WRITE(numout,*)
+      IF(lwp) WRITE(numout,*)'dom_clo : read in masks to define closed seas '
+      IF(lwp) WRITE(numout,*)'~~~~~~~'
+      !
+      ! read the closed seas masks (if they exist) from domain_cfg file (if it exists)
+      ! ------------------------------------------------------------------------------
+      !
+      IF( ln_read_cfg) THEN
+         !
+         CALL iom_open( cn_domcfg, inum )
+         !
+         id = iom_varid(inum, 'closea_mask', ldstop = .false.)
+         IF( id > 0 ) THEN 
+            l_sbc_clo = .true.
+            ALLOCATE( closea_mask(jpi,jpj) , STAT=ierr )
+            IF( ierr /= 0 )   CALL ctl_stop( 'STOP', 'dom_clo: failed to allocate closea_mask array')
+            zdata_in(:,:) = 0.0
+            CALL iom_get ( inum, jpdom_data, 'closea_mask', zdata_in )
+            closea_mask(:,:) = NINT(zdata_in(:,:)) * tmask(:,:,1)
+            ! number of closed seas = global maximum value in closea_mask field
+            jncs = maxval(closea_mask(:,:))
+            IF( lk_mpp ) CALL mpp_max(jncs)
+            IF( jncs > 0 ) THEN
+               IF( lwp ) WRITE(numout,*) 'Number of closed seas : ',jncs
+            ELSE
+               CALL ctl_stop( 'Problem with closea_mask field in domain_cfg file. Has no values > 0 so no closed seas defined.')
+            ENDIF
+         ELSE 
+            IF( lwp ) WRITE(numout,*)
+            IF( lwp ) WRITE(numout,*) '   ==>>>   closea_mask field not found in domain_cfg file.'
+            IF( lwp ) WRITE(numout,*) '           No closed seas defined.'
+            IF( lwp ) WRITE(numout,*)
+            l_sbc_clo = .false.
+            jncs = 0 
+         ENDIF
+
+         l_clo_rnf = .false.
+
+         IF( l_sbc_clo ) THEN ! No point reading in closea_mask_rnf or closea_mask_empmr fields if no closed seas defined.
+
+            id = iom_varid(inum, 'closea_mask_rnf', ldstop = .false.)
+            IF( id > 0 ) THEN 
+               l_clo_rnf = .true.            
+               ALLOCATE( closea_mask_rnf(jpi,jpj) , STAT=ierr )
+               IF( ierr /= 0 )   CALL ctl_stop( 'STOP', 'dom_clo: failed to allocate closea_mask_rnf array')
+               CALL iom_get ( inum, jpdom_data, 'closea_mask_rnf', zdata_in )
+               closea_mask_rnf(:,:) = NINT(zdata_in(:,:)) * tmask(:,:,1)
+               ! number of closed seas rnf mappings = global maximum in closea_mask_rnf field
+               jncsr = maxval(closea_mask_rnf(:,:))
+               IF( lk_mpp ) CALL mpp_max(jncsr)
+               IF( jncsr > 0 ) THEN
+                  IF( lwp ) WRITE(numout,*) 'Number of closed seas rnf mappings : ',jncsr
+               ELSE
+                  CALL ctl_stop( 'Problem with closea_mask_rnf field in domain_cfg file. Has no values > 0 so no closed seas rnf mappings defined.')
+               ENDIF
+            ELSE 
+               IF( lwp ) WRITE(numout,*) 'closea_mask_rnf field not found in domain_cfg file. No closed seas rnf mappings defined.'
+               jncsr = 0
+            ENDIF
+ 
+            id = iom_varid(inum, 'closea_mask_empmr', ldstop = .false.)
+            IF( id > 0 ) THEN 
+               l_clo_rnf = .true.            
+               ALLOCATE( closea_mask_empmr(jpi,jpj) , STAT=ierr )
+               IF( ierr /= 0 )   CALL ctl_stop( 'STOP', 'dom_clo: failed to allocate closea_mask_empmr array')
+               CALL iom_get ( inum, jpdom_data, 'closea_mask_empmr', zdata_in )
+               closea_mask_empmr(:,:) = NINT(zdata_in(:,:)) * tmask(:,:,1)
+               ! number of closed seas empmr mappings = global maximum value in closea_mask_empmr field
+               jncse = maxval(closea_mask_empmr(:,:))
+               IF( lk_mpp ) CALL mpp_max(jncse)
+               IF( jncse > 0 ) THEN 
+                  IF( lwp ) WRITE(numout,*) 'Number of closed seas empmr mappings : ',jncse
+               ELSE
+                  CALL ctl_stop( 'Problem with closea_mask_empmr field in domain_cfg file. Has no values > 0 so no closed seas empmr mappings defined.')
+               ENDIF
+            ELSE 
+               IF( lwp ) WRITE(numout,*) 'closea_mask_empmr field not found in domain_cfg file. No closed seas empmr mappings defined.'
+               jncse = 0
+            ENDIF
+
+         ENDIF ! l_sbc_clo
+         !
+         CALL iom_close( inum )
+         !
+      ELSE ! ln_read_cfg = .false. so no domain_cfg file
+         IF( lwp ) WRITE(numout,*) 'No domain_cfg file so no closed seas defined.'
+         l_sbc_clo = .false.
+         l_clo_rnf = .false.
+      ENDIF
+      !
+   END SUBROUTINE dom_clo
+
+
+   SUBROUTINE sbc_clo( kt )
+      !!---------------------------------------------------------------------
+      !!                  ***  ROUTINE sbc_clo  ***
+      !!                    
+      !! ** Purpose :   Special handling of closed seas
+      !!
+      !! ** Method  :   Water flux is forced to zero over closed sea
+      !!      Excess is shared between remaining ocean, or
+      !!      put as run-off in open ocean.
+      !!
+      !! ** Action  :   emp updated surface freshwater fluxes and associated heat content at kt
+      !!----------------------------------------------------------------------
+      INTEGER         , INTENT(in   ) ::   kt       ! ocean model time step
+      !
+      INTEGER             ::   ierr
+      INTEGER             ::   jc, jcr, jce   ! dummy loop indices
+      REAL(wp), PARAMETER ::   rsmall = 1.e-20_wp    ! Closed sea correction epsilon
+      REAL(wp)            ::   zfwf_total, zcoef, zcoef1         ! 
+      REAL(wp), DIMENSION(jncs)    ::   zfwf      !:
+      REAL(wp), DIMENSION(jncsr+1) ::   zfwfr     !: freshwater fluxes over closed seas
+      REAL(wp), DIMENSION(jncse+1) ::   zfwfe     !: 
+      REAL(wp), DIMENSION(jpi,jpj) ::   ztmp2d   ! 2D workspace
+      !!----------------------------------------------------------------------
+      !
+      IF( ln_timing )  CALL timing_start('sbc_clo')
+      !
+      !                                                   !------------------! 
+      IF( kt == nit000 ) THEN                             !  Initialisation  !
+         !                                                !------------------!
+         IF(lwp) WRITE(numout,*)
+         IF(lwp) WRITE(numout,*)'sbc_clo : closed seas '
+         IF(lwp) WRITE(numout,*)'~~~~~~~'
+
+         ALLOCATE( surf(jncs+1) , STAT=ierr )
+         IF( ierr /= 0 )   CALL ctl_stop( 'STOP', 'sbc_clo: failed to allocate surf array')
+         surf(:) = 0.e0_wp
+         !
+         ! jncsr can be zero so add 1 to avoid allocating zero-length array
+         ALLOCATE( surfr(jncsr+1) , STAT=ierr )
+         IF( ierr /= 0 )   CALL ctl_stop( 'STOP', 'sbc_clo: failed to allocate surfr array')
+         surfr(:) = 0.e0_wp
+         !
+         ! jncse can be zero so add 1 to avoid allocating zero-length array
+         ALLOCATE( surfe(jncse+1) , STAT=ierr )
+         IF( ierr /= 0 )   CALL ctl_stop( 'STOP', 'sbc_clo: failed to allocate surfe array')
+         surfe(:) = 0.e0_wp
+         !
+         surf(jncs+1) = glob_sum( e1e2t(:,:) )   ! surface of the global ocean
+         !
+         !                                        ! surface areas of closed seas 
+         DO jc = 1, jncs
+            ztmp2d(:,:) = 0.e0_wp
+            WHERE( closea_mask(:,:) == jc ) ztmp2d(:,:) = e1e2t(:,:) * tmask_i(:,:)
+            surf(jc) = glob_sum( ztmp2d(:,:) )
+         END DO
+         !
+         ! jncs+1 : surface area of global ocean, closed seas excluded
+         surf(jncs+1) = surf(jncs+1) - SUM(surf(1:jncs))
+         !
+         !                                        ! surface areas of rnf target areas
+         IF( jncsr > 0 ) THEN
+            DO jcr = 1, jncsr
+               ztmp2d(:,:) = 0.e0_wp
+               WHERE( closea_mask_rnf(:,:) == jcr .and. closea_mask(:,:) == 0 ) ztmp2d(:,:) = e1e2t(:,:) * tmask_i(:,:)
+               surfr(jcr) = glob_sum( ztmp2d(:,:) )
+            END DO
+         ENDIF
+         !
+         !                                        ! surface areas of empmr target areas
+         IF( jncse > 0 ) THEN
+            DO jce = 1, jncse
+               ztmp2d(:,:) = 0.e0_wp
+               WHERE( closea_mask_empmr(:,:) == jce .and. closea_mask(:,:) == 0 ) ztmp2d(:,:) = e1e2t(:,:) * tmask_i(:,:)
+               surfe(jce) = glob_sum( ztmp2d(:,:) )
+            END DO
+         ENDIF
+         !
+         IF(lwp) WRITE(numout,*)'     Closed sea surface areas (km2)'
+         DO jc = 1, jncs
+            IF(lwp) WRITE(numout,FMT='(1I3,5X,ES12.2)') jc, surf(jc) * 1.0e-6
+         END DO
+         IF(lwp) WRITE(numout,FMT='(A,ES12.2)') 'Global surface area excluding closed seas (km2): ', surf(jncs+1) * 1.0e-6
+         !
+         IF(jncsr > 0) THEN
+            IF(lwp) WRITE(numout,*)'     Closed sea target rnf surface areas (km2)'
+            DO jcr = 1, jncsr
+               IF(lwp) WRITE(numout,FMT='(1I3,5X,ES12.2)') jcr, surfr(jcr) * 1.0e-6
+            END DO
+         ENDIF
+         !
+         IF(jncse > 0) THEN
+            IF(lwp) WRITE(numout,*)'     Closed sea target empmr surface areas (km2)'
+            DO jce = 1, jncse
+               IF(lwp) WRITE(numout,FMT='(1I3,5X,ES12.2)') jce, surfe(jce) * 1.0e-6
+            END DO
+         ENDIF
+      ENDIF
+      !
+      !                                                      !--------------------!
+      !                                                      !  update emp        !
+      !                                                      !--------------------!
+
+      zfwf_total = 0._wp
+
+      !
+      ! 1. Work out total freshwater fluxes over closed seas from EMP - RNF.
+      !
+      zfwf(:) = 0.e0_wp           
+      DO jc = 1, jncs
+         ztmp2d(:,:) = 0.e0_wp
+         WHERE( closea_mask(:,:) == jc ) ztmp2d(:,:) = e1e2t(:,:) * ( emp(:,:)-rnf(:,:) ) * tmask_i(:,:)
+         zfwf(jc) = glob_sum( ztmp2d(:,:) )
+      END DO
+      zfwf_total = SUM(zfwf)
+
+      zfwfr(:) = 0.e0_wp           
+      IF( jncsr > 0 ) THEN
+         !
+         ! 2. Work out total FW fluxes over rnf source areas and add to rnf target areas. 
+         !    Where zfwf is negative add flux at specified runoff points and subtract from fluxes for global redistribution.
+         !    Where positive leave in global redistribution total.
+         !
+         DO jcr = 1, jncsr
+            !
+            ztmp2d(:,:) = 0.e0_wp
+            WHERE( closea_mask_rnf(:,:) == jcr .and. closea_mask(:,:) > 0 ) ztmp2d(:,:) = e1e2t(:,:) * ( emp(:,:)-rnf(:,:) ) * tmask_i(:,:)
+            zfwfr(jcr) = glob_sum( ztmp2d(:,:) )
+            !
+            ! The following if avoids the redistribution of the round off
+            IF ( ABS(zfwfr(jcr) / surf(jncs+1) ) > rsmall) THEN
+               !
+               ! Add residuals to target runoff points if negative and subtract from total to be added globally
+               IF( zfwfr(jcr) < 0.0 ) THEN 
+                  zfwf_total = zfwf_total - zfwfr(jcr)
+                  zcoef    = zfwfr(jcr) / surfr(jcr)
+                  zcoef1   = rcp * zcoef
+                  WHERE( closea_mask_rnf(:,:) == jcr .and. closea_mask(:,:) == 0.0)
+                     emp(:,:) = emp(:,:) + zcoef
+                     qns(:,:) = qns(:,:) - zcoef1 * sst_m(:,:)
+                  ENDWHERE
+               ENDIF
+               !
+            ENDIF
+         END DO
+      ENDIF  ! jncsr > 0    
+      !
+      zfwfe(:) = 0.e0_wp           
+      IF( jncse > 0 ) THEN
+         !
+         ! 3. Work out total fluxes over empmr source areas and add to empmr target areas. 
+         !
+         DO jce = 1, jncse
+            !
+            ztmp2d(:,:) = 0.e0_wp
+            WHERE( closea_mask_empmr(:,:) == jce .and. closea_mask(:,:) > 0 ) ztmp2d(:,:) = e1e2t(:,:) * ( emp(:,:)-rnf(:,:) ) * tmask_i(:,:)
+            zfwfe(jce) = glob_sum( ztmp2d(:,:) )
+            !
+            ! The following if avoids the redistribution of the round off
+            IF ( ABS( zfwfe(jce) / surf(jncs+1) ) > rsmall ) THEN
+               !
+               ! Add residuals to runoff points and subtract from total to be added globally
+               zfwf_total = zfwf_total - zfwfe(jce)
+               zcoef    = zfwfe(jce) / surfe(jce)
+               zcoef1   = rcp * zcoef
+               WHERE( closea_mask_empmr(:,:) == jce .and. closea_mask(:,:) == 0.0)
+                  emp(:,:) = emp(:,:) + zcoef
+                  qns(:,:) = qns(:,:) - zcoef1 * sst_m(:,:)
+               ENDWHERE
+               !
+            ENDIF
+         END DO
+      ENDIF ! jncse > 0    
+
+      !
+      ! 4. Spread residual flux over global ocean. 
+      !
+      ! The following if avoids the redistribution of the round off
+      IF ( ABS(zfwf_total / surf(jncs+1) ) > rsmall) THEN
+         zcoef    = zfwf_total / surf(jncs+1)
+         zcoef1   = rcp * zcoef
+         WHERE( closea_mask(:,:) == 0 )
+            emp(:,:) = emp(:,:) + zcoef
+            qns(:,:) = qns(:,:) - zcoef1 * sst_m(:,:)
+         ENDWHERE
+      ENDIF
+
+      !
+      ! 5. Subtract area means from emp (and qns) over closed seas to give zero mean FW flux over each sea.
+      !
+      DO jc = 1, jncs
+         ! The following if avoids the redistribution of the round off
+         IF ( ABS(zfwf(jc) / surf(jncs+1) ) > rsmall) THEN
+            !
+            ! Subtract residuals from fluxes over closed sea
+            zcoef    = zfwf(jc) / surf(jc)
+            zcoef1   = rcp * zcoef
+            WHERE( closea_mask(:,:) == jc )
+               emp(:,:) = emp(:,:) - zcoef
+               qns(:,:) = qns(:,:) + zcoef1 * sst_m(:,:)
+            ENDWHERE
+            !
+         ENDIF
+      END DO
+      !
+      emp (:,:) = emp (:,:) * tmask(:,:,1)
+      !
+      CALL lbc_lnk( emp , 'T', 1._wp )
+      !
+   END SUBROUTINE sbc_clo
+
+   SUBROUTINE clo_rnf( p_rnfmsk )
+      !!---------------------------------------------------------------------
+      !!                  ***  ROUTINE sbc_rnf  ***
+      !!                    
+      !! ** Purpose :   allow the treatment of closed sea outflow grid-points
+      !!                to be the same as river mouth grid-points
+      !!
+      !! ** Method  :   set to 1 the runoff mask (mskrnf, see sbcrnf module)
+      !!                at the closed sea outflow grid-point.
+      !!
+      !! ** Action  :   update (p_)mskrnf (set 1 at closed sea outflow)
+      !!----------------------------------------------------------------------
+      REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) ::   p_rnfmsk   ! river runoff mask (rnfmsk array)
+      !!----------------------------------------------------------------------
+      !
+      IF( jncsr > 0 ) THEN
+         WHERE( closea_mask_rnf(:,:) > 0 .and. closea_mask(:,:) == 0 )
+            p_rnfmsk(:,:) = MAX( p_rnfmsk(:,:), 1.0_wp )
+         ENDWHERE
+      ENDIF
+      !
+      IF( jncse > 0 ) THEN
+         WHERE( closea_mask_empmr(:,:) > 0 .and. closea_mask(:,:) == 0 )
+            p_rnfmsk(:,:) = MAX( p_rnfmsk(:,:), 1.0_wp )
+         ENDWHERE
+      ENDIF
+      !
+   END SUBROUTINE clo_rnf
+   
+      
+   SUBROUTINE clo_bat( k_top, k_bot )
+      !!---------------------------------------------------------------------
+      !!                  ***  ROUTINE clo_bat  ***
+      !!                    
+      !! ** Purpose :   Suppress closed sea from the domain
+      !!
+      !! ** Method  :   Read in closea_mask field (if it exists) from domain_cfg file.
+      !!                Where closea_mask > 0 set first and last ocean level to 0
+      !!                (As currently coded you can't define a closea_mask field in 
+      !!                usr_def_zgr).
+      !!
+      !! ** Action  :   set k_top=0 and k_bot=0 over closed seas
+      !!----------------------------------------------------------------------
+      INTEGER, DIMENSION(:,:), INTENT(inout) ::   k_top, k_bot   ! ocean first and last level indices
+      INTEGER                           :: inum, id
+      INTEGER,  DIMENSION(jpi,jpj) :: closea_mask ! closea_mask field
+      REAL(wp), DIMENSION(jpi,jpj) :: zdata_in ! temporary real array for input
+      !!----------------------------------------------------------------------
+      !
+      IF(lwp) THEN                     ! Control print
+         WRITE(numout,*)
+         WRITE(numout,*) 'clo_bat : suppression of closed seas'
+         WRITE(numout,*) '~~~~~~~'
+      ENDIF
+      !
+      IF( ln_read_cfg ) THEN
+         !
+         CALL iom_open( cn_domcfg, inum )
+         !
+         id = iom_varid(inum, 'closea_mask', ldstop = .false.)      
+         IF( id > 0 ) THEN
+            IF( lwp ) WRITE(numout,*) 'Suppressing closed seas in bathymetry based on closea_mask field,'
+            CALL iom_get ( inum, jpdom_data, 'closea_mask', zdata_in )
+            closea_mask(:,:) = NINT(zdata_in(:,:))
+            WHERE( closea_mask(:,:) > 0 )
+               k_top(:,:) = 0   
+               k_bot(:,:) = 0   
+            ENDWHERE
+         ELSE
+            IF( lwp ) WRITE(numout,*) 'No closea_mask field found in domain_cfg file. No suppression of closed seas.'
+         ENDIF
+         !
+         CALL iom_close(inum)
+         !
+      ELSE
+         IF( lwp ) WRITE(numout,*) 'No domain_cfg file => no suppression of closed seas.'
+      ENDIF
+      !
+      ! Initialise l_sbc_clo and l_clo_rnf for this case (ln_closea=.false.)
+      l_sbc_clo = .false.
+      l_clo_rnf = .false.
+      !
+   END SUBROUTINE clo_bat
+
+   !!======================================================================
+END MODULE closea
+
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DOM/daymod.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DOM/daymod.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DOM/daymod.F90	(revision 9570)
@@ -0,0 +1,421 @@
+MODULE daymod
+   !!======================================================================
+   !!                       ***  MODULE  daymod  ***
+   !! Ocean :   management of the model calendar
+   !!=====================================================================
+   !! History :  OPA  ! 1994-09  (M. Pontaud M. Imbard)  Original code
+   !!                 ! 1997-03  (O. Marti)
+   !!                 ! 1997-05  (G. Madec)
+   !!                 ! 1997-08  (M. Imbard)
+   !!   NEMO     1.0  ! 2003-09  (G. Madec)  F90 + nyear, nmonth, nday
+   !!                 ! 2004-01  (A.M. Treguier) new calculation based on adatrj
+   !!                 ! 2006-08  (G. Madec)  surface module major update
+   !!                 ! 2015-11  (D. Lea) Allow non-zero initial time of day
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   day        : calendar
+   !!----------------------------------------------------------------------
+   !!                    ----------- WARNING -----------
+   !!                    -------------------------------
+   !!   sbcmod assume that the time step is dividing the number of second of 
+   !!   in a day, i.e. ===> MOD( rday, rdt ) == 0 
+   !!   except when user defined forcing is used (see sbcmod.F90)
+   !!----------------------------------------------------------------------
+   USE dom_oce        ! ocean space and time domain
+   USE phycst         ! physical constants
+   USE ioipsl  , ONLY :   ymds2ju      ! for calendar
+   USE trc_oce , ONLY :   l_offline   ! offline flag
+   !
+   USE in_out_manager ! I/O manager
+   USE prtctl         ! Print control
+   USE iom            !
+   USE timing         ! Timing
+   USE restart        ! restart
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   day        ! called by step.F90
+   PUBLIC   day_init   ! called by istate.F90
+   PUBLIC   day_mth    ! Needed by TAM
+
+   INTEGER, PUBLIC ::   nsecd, nsecd05, ndt, ndt05   !: (PUBLIC for TAM)
+
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 4.0 , NEMO Consortium (2016)
+   !! $Id$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE day_init
+      !!----------------------------------------------------------------------
+      !!                   ***  ROUTINE day_init  ***
+      !!
+      !! ** Purpose :   Initialization of the calendar values to their values 1 time step before nit000
+      !!                because day will be called at the beginning of step
+      !!
+      !! ** Action  : - nyear        : current year
+      !!              - nmonth       : current month of the year nyear
+      !!              - nday         : current day of the month nmonth
+      !!              - nday_year    : current day of the year nyear
+      !!              - nsec_year    : current time step counted in second since 00h jan 1st of the current year
+      !!              - nsec_month   : current time step counted in second since 00h 1st day of the current month
+      !!              - nsec_day     : current time step counted in second since 00h of the current day
+      !!              - nsec1jan000  : second since Jan. 1st 00h of nit000 year and Jan. 1st 00h of the current year
+      !!              - nmonth_len, nyear_len, nmonth_half, nmonth_end through day_mth
+      !!----------------------------------------------------------------------
+      INTEGER  ::   inbday, idweek   ! local integers
+      REAL(wp) ::   zjul             ! local scalar
+      !!----------------------------------------------------------------------
+      !
+      ! max number of seconds between each restart
+      IF( REAL( nitend - nit000 + 1 ) * rdt > REAL( HUGE( nsec1jan000 ) ) ) THEN
+         CALL ctl_stop( 'The number of seconds between each restart exceeds the integer 4 max value: 2^31-1. ',   &
+            &           'You must do a restart at higher frequency (or remove this stop and recompile the code in I8)' )
+      ENDIF
+      nsecd   = NINT( rday       )
+      nsecd05 = NINT( 0.5 * rday )
+      ndt     = NINT(       rdt  )
+      ndt05   = NINT( 0.5 * rdt  )
+
+      IF( .NOT. l_offline )   CALL day_rst( nit000, 'READ' )
+
+      ! set the calandar from ndastp (read in restart file and namelist)
+      nyear   =   ndastp / 10000
+      nmonth  = ( ndastp - (nyear * 10000) ) / 100
+      nday    =   ndastp - (nyear * 10000) - ( nmonth * 100 )
+
+      nhour   =   nn_time0 / 100
+      nminute = ( nn_time0 - nhour * 100 )
+
+      CALL ymds2ju( nyear, nmonth, nday, nhour*3600._wp+nminute*60._wp, fjulday )  
+      IF( ABS(fjulday - REAL(NINT(fjulday),wp)) < 0.1 / rday )   fjulday = REAL(NINT(fjulday),wp)   ! avoid truncation error
+      IF( nn_time0*3600 - ndt05 .lt. 0 ) fjulday = fjulday + 1.                    ! move back to the day at nit000 (and not at nit000 - 1)
+
+      nsec1jan000 = 0
+      CALL day_mth
+
+      IF ( nday == 0 ) THEN     !   for ex if ndastp = ndate0 - 1
+         nmonth = nmonth - 1
+         nday = nmonth_len(nmonth)
+      ENDIF
+      IF ( nmonth == 0 ) THEN   ! go at the end of previous year
+         nmonth = 12
+         nyear = nyear - 1
+         nsec1jan000 = nsec1jan000 - nsecd * nyear_len(0)
+         IF( nleapy == 1 )   CALL day_mth
+      ENDIF
+
+      ! day since january 1st
+      nday_year = nday + SUM( nmonth_len(1:nmonth - 1) )
+
+      !compute number of days between last monday and today
+      CALL ymds2ju( 1900, 01, 01, 0.0, zjul )  ! compute julian day value of 01.01.1900 (our reference that was a Monday)
+      inbday = FLOOR(fjulday - zjul)            ! compute nb day between  01.01.1900 and start of current day
+      idweek = MOD(inbday, 7)                  ! compute nb day between last monday and current day
+      IF (idweek .lt. 0) idweek=idweek+7       ! Avoid negative values for dates before 01.01.1900
+
+      ! number of seconds since the beginning of current year/month/week/day at the middle of the time-step
+      IF (nhour*3600+nminute*60-ndt05 .gt. 0) THEN
+         ! 1 timestep before current middle of first time step is still the same day
+         nsec_year  = (nday_year-1) * nsecd + nhour*3600+nminute*60 - ndt05 
+         nsec_month = (nday-1)      * nsecd + nhour*3600+nminute*60 - ndt05    
+      ELSE
+         ! 1 time step before the middle of the first time step is the previous day 
+         nsec_year  = nday_year * nsecd + nhour*3600+nminute*60 - ndt05 
+         nsec_month = nday      * nsecd + nhour*3600+nminute*60 - ndt05   
+      ENDIF
+      nsec_week  = idweek    * nsecd + nhour*3600+nminute*60 - ndt05
+      nsec_day   =             nhour*3600+nminute*60 - ndt05 
+      IF( nsec_day .lt. 0 ) nsec_day = nsec_day + nsecd
+      IF( nsec_week .lt. 0 ) nsec_week = nsec_week + nsecd*7
+
+      ! control print
+      IF(lwp) WRITE(numout,'(a,i6,a,i2,a,i2,a,i8,a,i8,a,i8,a,i8)')   &
+           &                   ' =======>> 1/2 time step before the start of the run DATE Y/M/D = ',   &
+           &                   nyear, '/', nmonth, '/', nday, '  nsec_day:', nsec_day, '  nsec_week:', nsec_week, '  &
+           &                   nsec_month:', nsec_month , '  nsec_year:' , nsec_year
+
+      ! Up to now, calendar parameters are related to the end of previous run (nit000-1)
+      ! call day to set the calendar parameters at the begining of the current simulaton. needed by iom_init
+      CALL day( nit000 )
+      !
+      IF( lwxios ) THEN
+! define variables in restart file when writing with XIOS
+          CALL iom_set_rstw_var_active('kt')
+          CALL iom_set_rstw_var_active('ndastp')
+          CALL iom_set_rstw_var_active('adatrj')
+          CALL iom_set_rstw_var_active('ntime')
+      ENDIF
+
+   END SUBROUTINE day_init
+
+
+   SUBROUTINE day_mth
+      !!----------------------------------------------------------------------
+      !!                   ***  ROUTINE day_init  ***
+      !!
+      !! ** Purpose :   calendar values related to the months
+      !!
+      !! ** Action  : - nmonth_len    : length in days of the months of the current year
+      !!              - nyear_len     : length in days of the previous/current year
+      !!              - nmonth_half   : second since the beginning of the year and the halft of the months
+      !!              - nmonth_end    : second since the beginning of the year and the end of the months
+      !!----------------------------------------------------------------------
+      INTEGER  ::   jm               ! dummy loop indice
+      !!----------------------------------------------------------------------
+
+      ! length of the month of the current year (from nleapy, read in namelist)
+      IF ( nleapy < 2 ) THEN
+         nmonth_len(:) = (/ 31, 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31, 31 /)
+         nyear_len(:) = 365
+         IF ( nleapy == 1 ) THEN   ! we are using calandar with leap years
+            IF ( MOD(nyear-1, 4) == 0 .AND. ( MOD(nyear-1, 400) == 0 .OR. MOD(nyear-1, 100) /= 0 ) ) THEN
+               nyear_len(0)  = 366
+            ENDIF
+            IF ( MOD(nyear  , 4) == 0 .AND. ( MOD(nyear  , 400) == 0 .OR. MOD(nyear  , 100) /= 0 ) ) THEN
+               nmonth_len(2) = 29
+               nyear_len(1)  = 366
+            ENDIF
+            IF ( MOD(nyear+1, 4) == 0 .AND. ( MOD(nyear+1, 400) == 0 .OR. MOD(nyear+1, 100) /= 0 ) ) THEN
+               nyear_len(2)  = 366
+            ENDIF
+         ENDIF
+      ELSE
+         nmonth_len(:) = nleapy   ! all months with nleapy days per year
+         nyear_len(:) = 12 * nleapy
+      ENDIF
+
+      ! half month in second since the begining of the year:
+      ! time since Jan 1st   0     1     2    ...    11    12    13
+      !          ---------*--|--*--|--*--| ... |--*--|--*--|--*--|--------------------------------------
+      !                 <---> <---> <--->  ...  <---> <---> <--->
+      ! month number      0     1     2    ...    11    12    13
+      !
+      ! nmonth_half(jm) = rday * REAL( 0.5 * nmonth_len(jm) + SUM(nmonth_len(1:jm-1)) )
+      nmonth_half(0) = - nsecd05 * nmonth_len(0)
+      DO jm = 1, 13
+         nmonth_half(jm) = nmonth_half(jm-1) + nsecd05 * ( nmonth_len(jm-1) + nmonth_len(jm) )
+      END DO
+
+      nmonth_end(0) = 0
+      DO jm = 1, 13
+         nmonth_end(jm) = nmonth_end(jm-1) + nsecd * nmonth_len(jm)
+      END DO
+      !
+   END SUBROUTINE
+
+
+   SUBROUTINE day( kt )
+      !!----------------------------------------------------------------------
+      !!                      ***  ROUTINE day  ***
+      !!
+      !! ** Purpose :   Compute the date with a day iteration IF necessary.
+      !!
+      !! ** Method  : - ???
+      !!
+      !! ** Action  : - nyear     : current year
+      !!              - nmonth    : current month of the year nyear
+      !!              - nday      : current day of the month nmonth
+      !!              - nday_year : current day of the year nyear
+      !!              - ndastp    : = nyear*10000 + nmonth*100 + nday
+      !!              - adatrj    : date in days since the beginning of the run
+      !!              - nsec_year : current time of the year (in second since 00h, jan 1st)
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT(in) ::   kt        ! ocean time-step indices
+      !
+      CHARACTER (len=25) ::   charout
+      REAL(wp)           ::   zprec      ! fraction of day corresponding to 0.1 second
+      !!----------------------------------------------------------------------
+      !
+      IF( ln_timing )   CALL timing_start('day')
+      !
+      zprec = 0.1 / rday
+      !                                                 ! New time-step
+      nsec_year  = nsec_year  + ndt
+      nsec_month = nsec_month + ndt
+      nsec_week  = nsec_week  + ndt
+      nsec_day   = nsec_day   + ndt
+      adatrj  = adatrj  + rdt / rday
+      fjulday = fjulday + rdt / rday
+      IF( ABS(fjulday - REAL(NINT(fjulday),wp)) < zprec )   fjulday = REAL(NINT(fjulday),wp)   ! avoid truncation error
+      IF( ABS(adatrj  - REAL(NINT(adatrj ),wp)) < zprec )   adatrj  = REAL(NINT(adatrj ),wp)   ! avoid truncation error
+
+      IF( nsec_day > nsecd ) THEN                       ! New day
+         !
+         nday      = nday + 1
+         nday_year = nday_year + 1
+         nsec_day  = ndt05
+         !
+         IF( nday == nmonth_len(nmonth) + 1 ) THEN      ! New month
+            nday   = 1
+            nmonth = nmonth + 1
+            nsec_month = ndt05
+            IF( nmonth == 13 ) THEN                     ! New year
+               nyear     = nyear + 1
+               nmonth    = 1
+               nday_year = 1
+               nsec_year = ndt05
+               nsec1jan000 = nsec1jan000 + nsecd * nyear_len(1)
+               IF( nleapy == 1 )   CALL day_mth
+            ENDIF
+         ENDIF
+         !
+         ndastp = nyear * 10000 + nmonth * 100 + nday   ! New date
+         !
+         !compute first day of the year in julian days
+         CALL ymds2ju( nyear, 01, 01, 0.0, fjulstartyear )
+         !
+         IF(lwp) WRITE(numout,'(a,i8,a,i4.4,a,i2.2,a,i2.2,a,i3.3)') '======>> time-step =', kt,   &
+              &   '      New day, DATE Y/M/D = ', nyear, '/', nmonth, '/', nday, '      nday_year = ', nday_year
+         IF(lwp) WRITE(numout,'(a,i8,a,i7,a,i5)') '         nsec_year = ', nsec_year,   &
+              &   '   nsec_month = ', nsec_month, '   nsec_day = ', nsec_day, '   nsec_week = ', nsec_week
+      ENDIF
+
+      IF( nsec_week > 7*nsecd )   nsec_week = ndt05     ! New week
+
+      IF(ln_ctl) THEN
+         WRITE(charout,FMT="('kt =', I4,'  d/m/y =',I2,I2,I4)") kt, nday, nmonth, nyear
+         CALL prt_ctl_info(charout)
+      ENDIF
+
+      IF( .NOT. l_offline ) CALL rst_opn( kt )               ! Open the restart file if needed and control lrst_oce
+      IF( lrst_oce         ) CALL day_rst( kt, 'WRITE' )      ! write day restart information
+      !
+      IF( ln_timing )   CALL timing_stop('day')
+      !
+   END SUBROUTINE day
+
+
+   SUBROUTINE day_rst( kt, cdrw )
+      !!---------------------------------------------------------------------
+      !!                   ***  ROUTINE day_rst  ***
+      !!
+      !!  ** Purpose : Read or write calendar in restart file:
+      !!
+      !!  WRITE(READ) mode:
+      !!       kt        : number of time step since the begining of the experiment at the
+      !!                   end of the current(previous) run
+      !!       adatrj(0) : number of elapsed days since the begining of the experiment at the
+      !!                   end of the current(previous) run (REAL -> keep fractions of day)
+      !!       ndastp    : date at the end of the current(previous) run (coded as yyyymmdd integer)
+      !!
+      !!   According to namelist parameter nrstdt,
+      !!       nrstdt = 0  no control on the date (nit000 is  arbitrary).
+      !!       nrstdt = 1  we verify that nit000 is equal to the last
+      !!                   time step of previous run + 1.
+      !!       In both those options, the  exact duration of the experiment
+      !!       since the beginning (cumulated duration of all previous restart runs)
+      !!       is not stored in the restart and is assumed to be (nit000-1)*rdt.
+      !!       This is valid is the time step has remained constant.
+      !!
+      !!       nrstdt = 2  the duration of the experiment in days (adatrj)
+      !!                    has been stored in the restart file.
+      !!----------------------------------------------------------------------
+      INTEGER         , INTENT(in) ::   kt         ! ocean time-step
+      CHARACTER(len=*), INTENT(in) ::   cdrw       ! "READ"/"WRITE" flag
+      !
+      REAL(wp) ::   zkt, zndastp, zdayfrac, ksecs, ktime
+      INTEGER  ::   ihour, iminute
+      !!----------------------------------------------------------------------
+
+      IF( TRIM(cdrw) == 'READ' ) THEN
+
+         IF( iom_varid( numror, 'kt', ldstop = .FALSE. ) > 0 ) THEN
+            ! Get Calendar informations
+            CALL iom_get( numror, 'kt', zkt, ldxios = lrxios )   ! last time-step of previous run
+            IF(lwp) THEN
+               WRITE(numout,*) ' *** Info read in restart : '
+               WRITE(numout,*) '   previous time-step                               : ', NINT( zkt )
+               WRITE(numout,*) ' *** restart option'
+               SELECT CASE ( nrstdt )
+               CASE ( 0 )   ;   WRITE(numout,*) ' nrstdt = 0 : no control of nit000'
+               CASE ( 1 )   ;   WRITE(numout,*) ' nrstdt = 1 : no control the date at nit000 (use ndate0 read in the namelist)'
+               CASE ( 2 )   ;   WRITE(numout,*) ' nrstdt = 2 : calendar parameters read in restart'
+               END SELECT
+               WRITE(numout,*)
+            ENDIF
+            ! Control of date
+            IF( nit000 - NINT( zkt ) /= 1 .AND. nrstdt /= 0 )                                         &
+                 &   CALL ctl_stop( ' ===>>>> : problem with nit000 for the restart',                 &
+                 &                  ' verify the restart file or rerun with nrstdt = 0 (namelist)' )
+            ! define ndastp and adatrj
+            IF ( nrstdt == 2 ) THEN
+               ! read the parameters corresponding to nit000 - 1 (last time step of previous run)
+               CALL iom_get( numror, 'ndastp', zndastp, ldxios = lrxios )
+               ndastp = NINT( zndastp )
+               CALL iom_get( numror, 'adatrj', adatrj , ldxios = lrxios )
+	       CALL iom_get( numror, 'ntime' , ktime  , ldxios = lrxios )
+	       nn_time0=INT(ktime)
+               ! calculate start time in hours and minutes
+	       zdayfrac=adatrj-INT(adatrj)
+	       ksecs = NINT(zdayfrac*86400)	       ! Nearest second to catch rounding errors in adatrj	       
+	       ihour = INT(ksecs/3600)
+	       iminute = ksecs/60-ihour*60
+ 	        
+               ! Add to nn_time0
+               nhour   =   nn_time0 / 100
+               nminute = ( nn_time0 - nhour * 100 )
+	       nminute=nminute+iminute
+	       
+	       IF( nminute >= 60 ) THEN
+	          nminute=nminute-60
+		  nhour=nhour+1
+	       ENDIF
+	       nhour=nhour+ihour
+	       IF( nhour >= 24 ) THEN
+		  nhour=nhour-24
+	          adatrj=adatrj+1
+	       ENDIF	       
+	       nn_time0 = nhour * 100 + nminute
+	       adatrj = INT(adatrj)                    ! adatrj set to integer as nn_time0 updated	       
+            ELSE
+               ! parameters corresponding to nit000 - 1 (as we start the step loop with a call to day)
+               ndastp = ndate0        ! ndate0 read in the namelist in dom_nam
+               nhour   =   nn_time0 / 100
+               nminute = ( nn_time0 - nhour * 100 )
+               IF( nhour*3600+nminute*60-ndt05 .lt. 0 )  ndastp=ndastp-1      ! Start hour is specified in the namelist (default 0)
+               adatrj = ( REAL( nit000-1, wp ) * rdt ) / rday
+               ! note this is wrong if time step has changed during run
+            ENDIF
+         ELSE
+            ! parameters corresponding to nit000 - 1 (as we start the step loop with a call to day)
+            ndastp = ndate0           ! ndate0 read in the namelist in dom_nam
+            nhour   =   nn_time0 / 100
+	    nminute = ( nn_time0 - nhour * 100 )
+            IF( nhour*3600+nminute*60-ndt05 .lt. 0 )  ndastp=ndastp-1      ! Start hour is specified in the namelist (default 0)
+            adatrj = ( REAL( nit000-1, wp ) * rdt ) / rday
+         ENDIF
+         IF( ABS(adatrj  - REAL(NINT(adatrj),wp)) < 0.1 / rday )   adatrj = REAL(NINT(adatrj),wp)   ! avoid truncation error
+         !
+         IF(lwp) THEN
+            WRITE(numout,*) ' *** Info used values : '
+            WRITE(numout,*) '   date ndastp                                      : ', ndastp
+            WRITE(numout,*) '   number of elapsed days since the begining of run : ', adatrj
+	    WRITE(numout,*) '   nn_time0                                         : ',nn_time0
+            WRITE(numout,*)
+         ENDIF
+         !
+      ELSEIF( TRIM(cdrw) == 'WRITE' ) THEN
+         !
+         IF( kt == nitrst ) THEN
+            IF(lwp) WRITE(numout,*)
+            IF(lwp) WRITE(numout,*) 'rst_write : write oce restart file  kt =', kt
+            IF(lwp) WRITE(numout,*) '~~~~~~~'
+         ENDIF
+         ! calendar control
+         IF( lwxios ) CALL iom_swap(      cwxios_context          )
+         CALL iom_rstput( kt, nitrst, numrow, 'kt'     , REAL( kt    , wp)  , ldxios = lwxios )   ! time-step
+         CALL iom_rstput( kt, nitrst, numrow, 'ndastp' , REAL( ndastp, wp)  , ldxios = lwxios )   ! date
+         CALL iom_rstput( kt, nitrst, numrow, 'adatrj' , adatrj             , ldxios = lwxios            )   ! number of elapsed days since
+         !                                                                                                   ! the begining of the run [s]
+         CALL iom_rstput( kt, nitrst, numrow, 'ntime'  , REAL( nn_time0, wp), ldxios = lwxios ) ! time
+         IF( lwxios ) CALL iom_swap(      cxios_context          )
+      ENDIF
+      !
+   END SUBROUTINE day_rst
+
+   !!======================================================================
+END MODULE daymod
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DOM/depth_e3.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DOM/depth_e3.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DOM/depth_e3.F90	(revision 9570)
@@ -0,0 +1,164 @@
+MODULE depth_e3
+   !!======================================================================
+   !!                       ***  MODULE  depth_e3  ***
+   !!
+   !! zgr : vertical coordinate system 
+   !!======================================================================
+   !! History :  4.0  ! 2016-11  (S. Flavoni, G. Madec)  Original code
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   depth_to_e3   : use the depth of t- and w-points to calculate e3t & e3w
+   !!                   (generic interface for 1D and 3D fields)
+   !!   e3_to_depth   : use e3t & e3w to calculate the depth of t- and w-points
+   !!                   (generic interface for 1D and 3D fields)
+   !!---------------------------------------------------------------------
+   USE oce               ! ocean variables
+   USE dom_oce           ! ocean domain
+   !
+   USE in_out_manager    ! I/O manager
+   USE lbclnk            ! ocean lateral boundary conditions (or mpp link)
+   USE lib_mpp           ! distributed memory computing library
+   USE timing            ! Timing
+
+   IMPLICIT NONE
+   PRIVATE
+  
+   INTERFACE depth_to_e3
+      MODULE PROCEDURE depth_to_e3_1d, depth_to_e3_3d
+   END INTERFACE
+
+   INTERFACE e3_to_depth
+      MODULE PROCEDURE e3_to_depth_1d, e3_to_depth_3d
+   END INTERFACE
+
+   PUBLIC   depth_to_e3        ! called by usrdef_zgr
+   PUBLIC   e3_to_depth        ! called by domzgr.F90
+      
+   !! * Substitutions
+#  include "vectopt_loop_substitute.h90"
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 4.0 , NEMO Consortium (2016)
+   !! $Id$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS             
+
+   SUBROUTINE depth_to_e3_1d( pdept_1d, pdepw_1d, pe3t_1d, pe3w_1d )
+      !!---------------------------------------------------------------------
+      !!              ***  ROUTINE depth_to_e3_1d  ***
+      !!
+      !! ** Purpose :   compute e3t & e3w scale factors from t- & w-depths of model levels
+      !!
+      !! ** Method  :   The scale factors are given by the discrete derivative 
+      !!              of the depth:
+      !!                               e3w(jk) = dk[ dept_1d ] 
+      !!                               e3t(jk) = dk[ depw_1d ]
+      !!              with, at top and bottom :
+      !!                      e3w( 1 ) = 2 * ( dept( 1 ) - depw( 1 ) )
+      !!                      e3t(jpk) = 2 * ( dept(jpk) - depw(jpk) )   
+      !!
+      !! ** Action  : - pe3t_1d , pe3w_1d  : scale factors at T- and W-levels (m)
+      !!----------------------------------------------------------------------
+      REAL(wp), DIMENSION(:), INTENT(in   ) ::   pdept_1d, pdepw_1d   ! depths          [m]
+      REAL(wp), DIMENSION(:), INTENT(  out) ::   pe3t_1d , pe3w_1d    ! e3.=dk[depth]   [m]
+      !
+      INTEGER  ::   jk           ! dummy loop indices
+      !!----------------------------------------------------------------------
+      !
+      ! use pdep. at w- and t-points to compute e3. (e3. = dk[depth])
+      !
+      pe3w_1d( 1 ) = 2._wp * ( pdept_1d(1) - pdepw_1d(1) ) 
+      DO jk = 1, jpkm1
+         pe3w_1d(jk+1) = pdept_1d(jk+1) - pdept_1d(jk) 
+         pe3t_1d(jk  ) = pdepw_1d(jk+1) - pdepw_1d(jk) 
+      END DO
+      pe3t_1d(jpk) = 2._wp * ( pdept_1d(jpk) - pdepw_1d(jpk) )
+      !
+   END SUBROUTINE depth_to_e3_1d
+   
+      
+   SUBROUTINE depth_to_e3_3d( pdept_3d, pdepw_3d, pe3t_3d, pe3w_3d )
+      !!---------------------------------------------------------------------
+      !!              ***  ROUTINE depth_to_e3_3d  ***
+      !!
+      !! ** Purpose :   compute e3t & e3w scale factors from t- & w-depths of model levels
+      !!
+      !! ** Method  :   The scale factors are given by the discrete derivative 
+      !!              of the depth:
+      !!                               e3w(jk) = dk[ dept_1d ] 
+      !!                               e3t(jk) = dk[ depw_1d ]
+      !!              with, at top and bottom :
+      !!                      e3w( 1 ) = 2 * ( dept( 1 ) - depw( 1 ) )
+      !!                      e3t(jpk) = 2 * ( dept(jpk) - depw(jpk) )   
+      !!
+      !! ** Action  : - pe3t_1d , pe3w_1d  : scale factors at T- and W-levels (m)
+      !!----------------------------------------------------------------------
+      REAL(wp), DIMENSION(:,:,:), INTENT(in   ) ::   pdept_3d, pdepw_3d   ! depth           [m]
+      REAL(wp), DIMENSION(:,:,:), INTENT(  out) ::   pe3t_3d , pe3w_3d    ! e3.=dk[depth]   [m]
+      !
+      INTEGER  ::   jk           ! dummy loop indices
+      !!----------------------------------------------------------------------      
+      pe3w_3d(:,:, 1 ) = 2._wp * ( pdept_3d(:,:,1) - pdepw_3d(:,:,1) ) 
+      DO jk = 1, jpkm1
+         pe3w_3d(:,:,jk+1) = pdept_3d(:,:,jk+1) - pdept_3d(:,:,jk) 
+         pe3t_3d(:,:,jk  ) = pdepw_3d(:,:,jk+1) - pdepw_3d(:,:,jk) 
+      END DO
+      pe3t_3d(:,:,jpk) = 2._wp * ( pdept_3d(:,:,jpk) - pdepw_3d(:,:,jpk) )   
+      !
+   END SUBROUTINE depth_to_e3_3d
+
+
+   SUBROUTINE e3_to_depth_1d( pe3t_1d, pe3w_1d, pdept_1d, pdepw_1d )
+      !!---------------------------------------------------------------------
+      !!              ***  ROUTINE e3_to_depth_1d  ***
+      !!
+      !! ** Purpose :   compute t- & w-depths of model levels from e3t & e3w scale factors
+      !!
+      !! ** Method  :   The t- & w-depth are given by the summation of e3w & e3t, resp. 
+      !!
+      !! ** Action  : - pe3t_1d, pe3w_1d : scale factor of t- and w-point (m)
+      !!----------------------------------------------------------------------
+      REAL(wp), DIMENSION(:), INTENT(in   ) ::   pe3t_1d , pe3w_1d    ! vert. scale factors   [m]
+      REAL(wp), DIMENSION(:), INTENT(  out) ::   pdept_1d, pdepw_1d   ! depth = SUM( e3 )     [m]
+      !
+      INTEGER  ::   jk           ! dummy loop indices
+      !!----------------------------------------------------------------------
+      !
+      pdepw_1d(1) = 0.0_wp
+      pdept_1d(1) = 0.5_wp * pe3w_1d(1)
+      DO jk = 2, jpk
+         pdepw_1d(jk) = pdepw_1d(jk-1) + pe3t_1d(jk-1) 
+         pdept_1d(jk) = pdept_1d(jk-1) + pe3w_1d(jk  ) 
+      END DO
+      !
+   END SUBROUTINE e3_to_depth_1d
+   
+      
+   SUBROUTINE e3_to_depth_3d( pe3t_3d, pe3w_3d, pdept_3d, pdepw_3d )
+      !!---------------------------------------------------------------------
+      !!              ***  ROUTINE e3_to_depth_3d  ***
+      !!
+      !! ** Purpose :   compute t- & w-depths of model levels from e3t & e3w scale factors
+      !!
+      !! ** Method  :   The t- & w-depth are given by the summation of e3w & e3t, resp. 
+      !!
+      !! ** Action  : - pe3t_1d, pe3w_1d : scale factor of t- and w-point (m)
+      !!----------------------------------------------------------------------
+      REAL(wp), DIMENSION(:,:,:), INTENT(in   ) ::   pe3t_3d , pe3w_3d    ! vert. scale factors   [m]
+      REAL(wp), DIMENSION(:,:,:), INTENT(  out) ::   pdept_3d, pdepw_3d   ! depth = SUM( e3 )     [m]
+      !
+      INTEGER  ::   jk           ! dummy loop indices
+      !!----------------------------------------------------------------------      
+      !
+      pdepw_3d(:,:,1) = 0.0_wp
+      pdept_3d(:,:,1) = 0.5_wp * pe3w_3d(:,:,1)
+      DO jk = 2, jpk
+         pdepw_3d(:,:,jk) = pdepw_3d(:,:,jk-1) + pe3t_3d(:,:,jk-1) 
+         pdept_3d(:,:,jk) = pdept_3d(:,:,jk-1) + pe3w_3d(:,:,jk  ) 
+      END DO
+      !
+   END SUBROUTINE e3_to_depth_3d
+
+   !!======================================================================
+END MODULE depth_e3
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DOM/dom_oce.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DOM/dom_oce.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DOM/dom_oce.F90	(revision 9570)
@@ -0,0 +1,295 @@
+MODULE dom_oce
+   !!======================================================================
+   !!                       ***  MODULE dom_oce  ***
+   !!       
+   !! ** Purpose :   Define in memory all the ocean space domain variables
+   !!======================================================================
+   !! History :  1.0  ! 2005-10  (A. Beckmann, G. Madec)  reactivate s-coordinate 
+   !!            3.3  ! 2010-11  (G. Madec) add mbk. arrays associated to the deepest ocean level
+   !!            3.4  ! 2011-01  (A. R. Porter, STFC Daresbury) dynamical allocation
+   !!            3.5  ! 2012     (S. Mocavero, I. Epicoco) Add arrays associated
+   !!                             to the optimization of BDY communications
+   !!            3.7  ! 2015-11  (G. Madec) introduce surface and scale factor ratio
+   !!             -   ! 2015-11  (G. Madec, A. Coward)  time varying zgr by default
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   Agrif_Root    : dummy function used when lk_agrif=F
+   !!   Agrif_CFixed  : dummy function used when lk_agrif=F
+   !!   dom_oce_alloc : dynamical allocation of dom_oce arrays
+   !!----------------------------------------------------------------------
+   USE par_oce        ! ocean parameters
+
+   IMPLICIT NONE
+   PUBLIC             ! allows the acces to par_oce when dom_oce is used (exception to coding rules)
+
+   PUBLIC dom_oce_alloc  ! Called from nemogcm.F90
+
+   !!----------------------------------------------------------------------
+   !! time & space domain namelist
+   !! ----------------------------
+   !                                   !!* Namelist namdom : time & space domain *
+   LOGICAL , PUBLIC ::   ln_linssh      !: =T  linear free surface ==>> model level are fixed in time
+   LOGICAL , PUBLIC ::   ln_meshmask    !: =T  create a mesh-mask file (mesh_mask.nc)
+   REAL(wp), PUBLIC ::   rn_isfhmin     !: threshold to discriminate grounded ice to floating ice
+   REAL(wp), PUBLIC ::   rn_rdt         !: time step for the dynamics and tracer
+   REAL(wp), PUBLIC ::   rn_atfp        !: asselin time filter parameter
+   INTEGER , PUBLIC ::   nn_euler       !: =0 start with forward time step or not (=1)
+   LOGICAL , PUBLIC ::   ln_iscpl       !: coupling with ice sheet
+   LOGICAL , PUBLIC ::   ln_crs         !: Apply grid coarsening to dynamical model output or online passive tracers
+
+   !! Free surface parameters
+   !! =======================
+   LOGICAL , PUBLIC :: ln_dynspg_exp    !: Explicit free surface flag
+   LOGICAL , PUBLIC :: ln_dynspg_ts     !: Split-Explicit free surface flag
+
+   !! Time splitting parameters
+   !! =========================
+   LOGICAL,  PUBLIC :: ln_bt_fw         !: Forward integration of barotropic sub-stepping
+   LOGICAL,  PUBLIC :: ln_bt_av         !: Time averaging of barotropic variables
+   LOGICAL,  PUBLIC :: ln_bt_auto       !: Set number of barotropic iterations automatically
+   INTEGER,  PUBLIC :: nn_bt_flt        !: Filter choice
+   INTEGER,  PUBLIC :: nn_baro          !: Number of barotropic iterations during one baroclinic step (rdt)
+   REAL(wp), PUBLIC :: rn_bt_cmax       !: Maximum allowed courant number (used if ln_bt_auto=T)
+   REAL(wp), PUBLIC :: rn_bt_alpha      !: Time stepping diffusion parameter
+
+
+   !                                   !! old non-DOCTOR names still used in the model
+   REAL(wp), PUBLIC ::   atfp           !: asselin time filter parameter
+   REAL(wp), PUBLIC ::   rdt            !: time step for the dynamics and tracer
+
+   !                                   !!! associated variables
+   INTEGER , PUBLIC ::   neuler         !: restart euler forward option (0=Euler)
+   REAL(wp), PUBLIC ::   r2dt           !: = 2*rdt except at nit000 (=rdt) if neuler=0
+
+   !!----------------------------------------------------------------------
+   !! space domain parameters
+   !!----------------------------------------------------------------------
+   INTEGER, PUBLIC ::   jperio   !: Global domain lateral boundary type (between 0 and 6)
+   !                                !  = 0 closed                 ;   = 1 cyclic East-West
+   !                                !  = 2 equatorial symmetric   ;   = 3 North fold T-point pivot
+   !                                !  = 4 cyclic East-West AND North fold T-point pivot
+   !                                !  = 5 North fold F-point pivot
+   !                                !  = 6 cyclic East-West AND North fold F-point pivot
+   INTEGER, PUBLIC ::   nperio   !: Local domain lateral boundary type (deduced from jperio and MPP decomposition)
+
+   !                                 !  domain MPP decomposition parameters
+   INTEGER             , PUBLIC ::   nimpp, njmpp     !: i- & j-indexes for mpp-subdomain left bottom
+   INTEGER             , PUBLIC ::   nreci, nrecj     !: overlap region in i and j
+   INTEGER             , PUBLIC ::   nproc            !: number for local processor
+   INTEGER             , PUBLIC ::   narea            !: number for local area
+   INTEGER             , PUBLIC ::   nbondi, nbondj   !: mark of i- and j-direction local boundaries
+   INTEGER, ALLOCATABLE, PUBLIC ::   nbondi_bdy(:)    !: mark i-direction local boundaries for BDY open boundaries
+   INTEGER, ALLOCATABLE, PUBLIC ::   nbondj_bdy(:)    !: mark j-direction local boundaries for BDY open boundaries
+   INTEGER, ALLOCATABLE, PUBLIC ::   nbondi_bdy_b(:)  !: mark i-direction of neighbours local boundaries for BDY open boundaries  
+   INTEGER, ALLOCATABLE, PUBLIC ::   nbondj_bdy_b(:)  !: mark j-direction of neighbours local boundaries for BDY open boundaries  
+
+   INTEGER, PUBLIC ::   npolj             !: north fold mark (0, 3 or 4)
+   INTEGER, PUBLIC ::   nlci, nldi, nlei  !: i-dimensions of the local subdomain and its first and last indoor indices
+   INTEGER, PUBLIC ::   nlcj, nldj, nlej  !: i-dimensions of the local subdomain and its first and last indoor indices
+   INTEGER, PUBLIC ::   noea, nowe        !: index of the local neighboring processors in
+   INTEGER, PUBLIC ::   noso, nono        !: east, west, south and north directions
+   INTEGER, PUBLIC ::   nidom             !: ???
+
+   INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   mig        !: local  ==> global domain i-index
+   INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   mjg        !: local  ==> global domain j-index
+   INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   mi0, mi1   !: global ==> local  domain i-index (mi0=1 and mi1=0 if the global index
+   !                                                                !                                             is not in the local domain)
+   INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   mj0, mj1   !: global ==> local  domain j-index (mj0=1 and mj1=0 if the global index
+   !                                                                !                                             is not in the local domain)
+   INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   nimppt, njmppt   !: i-, j-indexes for each processor
+   INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   ibonit, ibonjt   !: i-, j- processor neighbour existence
+   INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   nlcit , nlcjt    !: dimensions of every subdomain
+   INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   nldit , nldjt    !: first, last indoor index for each i-domain
+   INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   nleit , nlejt    !: first, last indoor index for each j-domain
+   INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: nfiimpp, nfipproc, nfilcit
+
+   !!----------------------------------------------------------------------
+   !! horizontal curvilinear coordinate and scale factors
+   !! ---------------------------------------------------------------------
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE        , DIMENSION(:,:) ::   glamt , glamu, glamv , glamf    !: longitude at t, u, v, f-points [degree]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE        , DIMENSION(:,:) ::   gphit , gphiu, gphiv , gphif    !: latitude  at t, u, v, f-points [degree]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, TARGET, DIMENSION(:,:) ::   e1t   , e2t  , r1_e1t, r1_e2t   !: t-point horizontal scale factors    [m]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, TARGET, DIMENSION(:,:) ::   e1u   , e2u  , r1_e1u, r1_e2u   !: horizontal scale factors at u-point [m]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, TARGET, DIMENSION(:,:) ::   e1v   , e2v  , r1_e1v, r1_e2v   !: horizontal scale factors at v-point [m]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, TARGET, DIMENSION(:,:) ::   e1f   , e2f  , r1_e1f, r1_e2f   !: horizontal scale factors at f-point [m]
+   !
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE        , DIMENSION(:,:) ::   e1e2t , r1_e1e2t                !: associated metrics at t-point
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE        , DIMENSION(:,:) ::   e1e2u , r1_e1e2u , e2_e1u       !: associated metrics at u-point
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE        , DIMENSION(:,:) ::   e1e2v , r1_e1e2v , e1_e2v       !: associated metrics at v-point
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE        , DIMENSION(:,:) ::   e1e2f , r1_e1e2f                !: associated metrics at f-point
+   !
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE        , DIMENSION(:,:) ::   ff_f  , ff_t                    !: Coriolis factor at f- & t-points  [1/s]
+   !!----------------------------------------------------------------------
+   !! vertical coordinate and scale factors
+   !! ---------------------------------------------------------------------
+   LOGICAL, PUBLIC ::   ln_zco       !: z-coordinate - full step
+   LOGICAL, PUBLIC ::   ln_zps       !: z-coordinate - partial step
+   LOGICAL, PUBLIC ::   ln_sco       !: s-coordinate or hybrid z-s coordinate
+   LOGICAL, PUBLIC ::   ln_isfcav    !: presence of ISF 
+   !                                                        !  ref.   ! before  !   now   ! after  !
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::     e3t_0 ,   e3t_b ,   e3t_n ,  e3t_a   !: t- vert. scale factor [m]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::     e3u_0 ,   e3u_b ,   e3u_n ,  e3u_a   !: u- vert. scale factor [m]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::     e3v_0 ,   e3v_b ,   e3v_n ,  e3v_a   !: v- vert. scale factor [m]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::     e3f_0           ,   e3f_n            !: f- vert. scale factor [m]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::     e3w_0 ,   e3w_b ,   e3w_n            !: w- vert. scale factor [m]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::    e3uw_0 ,  e3uw_b ,  e3uw_n            !: uw-vert. scale factor [m]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::    e3vw_0 ,  e3vw_b ,  e3vw_n            !: vw-vert. scale factor [m]
+
+   !                                                        !  ref.   ! before  !   now   !
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   gdept_0 , gdept_b , gdept_n   !: t- depth              [m]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   gdepw_0 , gdepw_b , gdepw_n   !: w- depth              [m]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   gde3w_0           , gde3w_n   !: w- depth (sum of e3w) [m]
+   
+   !                                                      !  ref. ! before  !   now   !  after  !
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   ht_0            ,    ht_n             !: t-depth              [m]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hu_0  ,    hu_b ,    hu_n ,    hu_a   !: u-depth              [m]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hv_0  ,    hv_b ,    hv_n ,    hv_a   !: v-depth              [m]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::           r1_hu_b , r1_hu_n , r1_hu_a   !: inverse of u-depth [1/m]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::           r1_hv_b , r1_hv_n , r1_hv_a   !: inverse of v-depth [1/m]
+
+   INTEGER, PUBLIC ::   nla10              !: deepest    W level Above  ~10m (nlb10 - 1)
+   INTEGER, PUBLIC ::   nlb10              !: shallowest W level Bellow ~10m (nla10 + 1) 
+
+   !! 1D reference  vertical coordinate
+   !! =-----------------====------
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:)   ::   gdept_1d, gdepw_1d !: reference depth of t- and w-points (m)
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:)   ::   e3t_1d  , e3w_1d   !: reference vertical scale factors at T- and W-pts (m)
+
+
+   !!----------------------------------------------------------------------
+   !! masks, top and bottom ocean point position
+   !! ---------------------------------------------------------------------
+!!gm Proposition of new name for top/bottom vertical indices
+!   INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   mtk_t, mtk_u, mtk_v   !: top first wet T-, U-, V-, F-level (ISF)
+!   INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   mbk_t, mbk_u, mbk_v   !: bottom last wet T-, U- and V-level
+!!gm
+   INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   mbkt, mbku, mbkv   !: bottom last wet T-, U- and V-level
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   tmask_i            !: interior domain T-point mask
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   tmask_h            !: internal domain T-point mask (Figure 8.5 NEMO book)
+
+   INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   misfdep                 !: top first ocean level             (ISF)
+   INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   mikt, miku, mikv, mikf  !: top first wet T-, U-, V-, F-level (ISF)
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   risfdep                 !: Iceshelf draft                    (ISF)
+
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   ssmask, ssumask, ssvmask             !: surface mask at T-,U-, V- and F-pts
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:), TARGET :: tmask, umask, vmask, fmask   !: land/ocean mask at T-, U-, V- and F-pts
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:), TARGET :: wmask, wumask, wvmask        !: land/ocean mask at WT-, WU- and WV-pts
+
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   tpol, fpol          !: north fold mask (jperio= 3 or 4)
+
+   !!----------------------------------------------------------------------
+   !! calendar variables
+   !! ---------------------------------------------------------------------
+   INTEGER , PUBLIC ::   nyear         !: current year
+   INTEGER , PUBLIC ::   nmonth        !: current month
+   INTEGER , PUBLIC ::   nday          !: current day of the month
+   INTEGER , PUBLIC ::   nhour         !: current hour
+   INTEGER , PUBLIC ::   nminute       !: current minute
+   INTEGER , PUBLIC ::   ndastp        !: time step date in yyyymmdd format
+   INTEGER , PUBLIC ::   nday_year     !: current day counted from jan 1st of the current year
+   INTEGER , PUBLIC ::   nsec_year     !: current time step counted in second since 00h jan 1st of the current year
+   INTEGER , PUBLIC ::   nsec_month    !: current time step counted in second since 00h 1st day of the current month
+   INTEGER , PUBLIC ::   nsec_week     !: current time step counted in second since 00h of last monday
+   INTEGER , PUBLIC ::   nsec_day      !: current time step counted in second since 00h of the current day
+   REAL(wp), PUBLIC ::   fjulday       !: current julian day 
+   REAL(wp), PUBLIC ::   fjulstartyear !: first day of the current year in julian days
+   REAL(wp), PUBLIC ::   adatrj        !: number of elapsed days since the begining of the whole simulation
+   !                                   !: (cumulative duration of previous runs that may have used different time-step size)
+   INTEGER , PUBLIC, DIMENSION(0: 2) ::   nyear_len     !: length in days of the previous/current/next year
+   INTEGER , PUBLIC, DIMENSION(0:13) ::   nmonth_len    !: length in days of the months of the current year
+   INTEGER , PUBLIC, DIMENSION(0:13) ::   nmonth_half   !: second since Jan 1st 0h of the current year and the half of the months
+   INTEGER , PUBLIC, DIMENSION(0:13) ::   nmonth_end    !: second since Jan 1st 0h of the current year and the end of the months
+   INTEGER , PUBLIC                  ::   nsec1jan000   !: second since Jan 1st 0h of nit000 year and Jan 1st 0h the current year
+
+   !!----------------------------------------------------------------------
+   !! agrif domain
+   !!----------------------------------------------------------------------
+#if defined key_agrif
+   LOGICAL, PUBLIC, PARAMETER ::   lk_agrif = .TRUE.    !: agrif flag
+#else
+   LOGICAL, PUBLIC, PARAMETER ::   lk_agrif = .FALSE.   !: agrif flag
+#endif
+
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 4.0 , NEMO Consortium (2011)
+   !! $Id$ 
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+#if ! defined key_agrif
+   !!----------------------------------------------------------------------
+   !! NOT 'key_agrif'      dummy function                     No AGRIF zoom
+   !!----------------------------------------------------------------------
+   LOGICAL FUNCTION Agrif_Root()
+      Agrif_Root = .TRUE.
+   END FUNCTION Agrif_Root
+
+   CHARACTER(len=3) FUNCTION Agrif_CFixed()
+      Agrif_CFixed = '0' 
+   END FUNCTION Agrif_CFixed
+#endif
+
+   INTEGER FUNCTION dom_oce_alloc()
+      !!----------------------------------------------------------------------
+      INTEGER, DIMENSION(12) :: ierr
+      !!----------------------------------------------------------------------
+      ierr(:) = 0
+      !
+      ALLOCATE( mig(jpi), mjg(jpj), STAT=ierr(1) )
+         !
+      ALLOCATE( mi0(jpiglo)   , mi1 (jpiglo),  mj0(jpjglo)   , mj1 (jpjglo) ,     &
+         &      tpol(jpiglo)  , fpol(jpiglo)                                , STAT=ierr(2) )
+         !
+      ALLOCATE( glamt(jpi,jpj) ,    glamu(jpi,jpj) ,  glamv(jpi,jpj) ,  glamf(jpi,jpj) ,     &
+         &      gphit(jpi,jpj) ,    gphiu(jpi,jpj) ,  gphiv(jpi,jpj) ,  gphif(jpi,jpj) ,     &
+         &       e1t (jpi,jpj) ,     e2t (jpi,jpj) , r1_e1t(jpi,jpj) , r1_e2t(jpi,jpj) ,     &
+         &       e1u (jpi,jpj) ,     e2u (jpi,jpj) , r1_e1u(jpi,jpj) , r1_e2u(jpi,jpj) ,     &
+         &       e1v (jpi,jpj) ,     e2v (jpi,jpj) , r1_e1v(jpi,jpj) , r1_e2v(jpi,jpj) ,     &
+         &       e1f (jpi,jpj) ,     e2f (jpi,jpj) , r1_e1f(jpi,jpj) , r1_e2f(jpi,jpj) ,     &
+         &      e1e2t(jpi,jpj) , r1_e1e2t(jpi,jpj)                                     ,     &
+         &      e1e2u(jpi,jpj) , r1_e1e2u(jpi,jpj) , e2_e1u(jpi,jpj)                   ,     &
+         &      e1e2v(jpi,jpj) , r1_e1e2v(jpi,jpj) , e1_e2v(jpi,jpj)                   ,     &
+         &      e1e2f(jpi,jpj) , r1_e1e2f(jpi,jpj)                                     ,     &
+         &      ff_f (jpi,jpj) ,    ff_t (jpi,jpj)                                     , STAT=ierr(3) )
+         !
+      ALLOCATE( gdept_0(jpi,jpj,jpk) , gdepw_0(jpi,jpj,jpk) , gde3w_0(jpi,jpj,jpk) ,      &
+         &      gdept_b(jpi,jpj,jpk) , gdepw_b(jpi,jpj,jpk) ,                             &
+         &      gdept_n(jpi,jpj,jpk) , gdepw_n(jpi,jpj,jpk) , gde3w_n(jpi,jpj,jpk) , STAT=ierr(4) )
+         !
+      ALLOCATE( e3t_0(jpi,jpj,jpk) , e3u_0(jpi,jpj,jpk) , e3v_0(jpi,jpj,jpk) , e3f_0(jpi,jpj,jpk) , e3w_0(jpi,jpj,jpk) ,   &
+         &      e3t_b(jpi,jpj,jpk) , e3u_b(jpi,jpj,jpk) , e3v_b(jpi,jpj,jpk) ,                      e3w_b(jpi,jpj,jpk) ,   & 
+         &      e3t_n(jpi,jpj,jpk) , e3u_n(jpi,jpj,jpk) , e3v_n(jpi,jpj,jpk) , e3f_n(jpi,jpj,jpk) , e3w_n(jpi,jpj,jpk) ,   & 
+         &      e3t_a(jpi,jpj,jpk) , e3u_a(jpi,jpj,jpk) , e3v_a(jpi,jpj,jpk) ,                                             &
+         !                                                          !
+         &      e3uw_0(jpi,jpj,jpk) , e3vw_0(jpi,jpj,jpk) ,         &
+         &      e3uw_b(jpi,jpj,jpk) , e3vw_b(jpi,jpj,jpk) ,         &               
+         &      e3uw_n(jpi,jpj,jpk) , e3vw_n(jpi,jpj,jpk) ,     STAT=ierr(5) )                       
+         !
+      ALLOCATE( ht_0(jpi,jpj) , hu_0(jpi,jpj) , hv_0(jpi,jpj) ,                                           &
+         &                      hu_b(jpi,jpj) , hv_b(jpi,jpj) , r1_hu_b(jpi,jpj) , r1_hv_b(jpi,jpj) ,     &
+         &      ht_n(jpi,jpj) , hu_n(jpi,jpj) , hv_n(jpi,jpj) , r1_hu_n(jpi,jpj) , r1_hv_n(jpi,jpj) ,     &
+         &                      hu_a(jpi,jpj) , hv_a(jpi,jpj) , r1_hu_a(jpi,jpj) , r1_hv_a(jpi,jpj) , STAT=ierr(6)  )
+         !
+         !
+      ALLOCATE( gdept_1d(jpk) , gdepw_1d(jpk) , e3t_1d(jpk) , e3w_1d(jpk) , STAT=ierr(7) )
+         !
+      ALLOCATE( tmask_i(jpi,jpj) , tmask_h(jpi,jpj) ,                        & 
+         &      ssmask (jpi,jpj) , ssumask(jpi,jpj) , ssvmask(jpi,jpj) ,     &
+         &      mbkt   (jpi,jpj) , mbku   (jpi,jpj) , mbkv   (jpi,jpj) , STAT=ierr(9) )
+         !
+      ALLOCATE( misfdep(jpi,jpj) , mikt(jpi,jpj) , miku(jpi,jpj) ,     &
+         &      risfdep(jpi,jpj) , mikv(jpi,jpj) , mikf(jpi,jpj) , STAT=ierr(10) )
+         !
+      ALLOCATE( tmask(jpi,jpj,jpk) , umask(jpi,jpj,jpk) ,     & 
+         &      vmask(jpi,jpj,jpk) , fmask(jpi,jpj,jpk) , STAT=ierr(11) )
+         !
+      ALLOCATE( wmask(jpi,jpj,jpk) , wumask(jpi,jpj,jpk), wvmask(jpi,jpj,jpk) , STAT=ierr(12) )
+      !
+      dom_oce_alloc = MAXVAL(ierr)
+      !
+   END FUNCTION dom_oce_alloc
+
+   !!======================================================================
+END MODULE dom_oce
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DOM/domain.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DOM/domain.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DOM/domain.F90	(revision 9570)
@@ -0,0 +1,708 @@
+MODULE domain
+   !!==============================================================================
+   !!                       ***  MODULE domain   ***
+   !! Ocean initialization : domain initialization
+   !!==============================================================================
+   !! History :  OPA  !  1990-10  (C. Levy - G. Madec)  Original code
+   !!                 !  1992-01  (M. Imbard) insert time step initialization
+   !!                 !  1996-06  (G. Madec) generalized vertical coordinate 
+   !!                 !  1997-02  (G. Madec) creation of domwri.F
+   !!                 !  2001-05  (E.Durand - G. Madec) insert closed sea
+   !!   NEMO     1.0  !  2002-08  (G. Madec)  F90: Free form and module
+   !!            2.0  !  2005-11  (V. Garnier) Surface pressure gradient organization
+   !!            3.3  !  2010-11  (G. Madec)  initialisation in C1D configuration
+   !!            3.6  !  2013     ( J. Simeon, C. Calone, G. Madec, C. Ethe ) Online coarsening of outputs
+   !!            3.7  !  2015-11  (G. Madec, A. Coward)  time varying zgr by default
+   !!            4.0  !  2016-10  (G. Madec, S. Flavoni)  domain configuration / user defined interface
+   !!----------------------------------------------------------------------
+   
+   !!----------------------------------------------------------------------
+   !!   dom_init      : initialize the space and time domain
+   !!   dom_glo       : initialize global domain <--> local domain indices
+   !!   dom_nam       : read and contral domain namelists
+   !!   dom_ctl       : control print for the ocean domain
+   !!   domain_cfg    : read the global domain size in domain configuration file
+   !!   cfg_write     : create the domain configuration file
+   !!----------------------------------------------------------------------
+   USE oce            ! ocean variables
+   USE dom_oce        ! domain: ocean
+   USE sbc_oce        ! surface boundary condition: ocean
+   USE trc_oce        ! shared ocean & passive tracers variab
+   USE phycst         ! physical constants
+   USE closea         ! closed seas
+   USE domhgr         ! domain: set the horizontal mesh
+   USE domzgr         ! domain: set the vertical mesh
+   USE dommsk         ! domain: set the mask system
+   USE domwri         ! domain: write the meshmask file
+   USE domvvl         ! variable volume
+   USE c1d            ! 1D configuration
+   USE dyncor_c1d     ! 1D configuration: Coriolis term    (cor_c1d routine)
+   USE wet_dry,  ONLY : ll_wd
+   !
+   USE in_out_manager ! I/O manager
+   USE iom            ! I/O library
+   USE lbclnk         ! ocean lateral boundary condition (or mpp link)
+   USE lib_mpp        ! distributed memory computing library
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   dom_init     ! called by nemogcm.F90
+   PUBLIC   domain_cfg   ! called by nemogcm.F90
+
+   !!-------------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO Consortium (2010)
+   !! $Id$
+   !! Software governed by the CeCILL licence        (NEMOGCM/NEMO_CeCILL.txt)
+   !!-------------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE dom_init(cdstr)
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE dom_init  ***
+      !!                    
+      !! ** Purpose :   Domain initialization. Call the routines that are 
+      !!              required to create the arrays which define the space 
+      !!              and time domain of the ocean model.
+      !!
+      !! ** Method  : - dom_msk: compute the masks from the bathymetry file
+      !!              - dom_hgr: compute or read the horizontal grid-point position
+      !!                         and scale factors, and the coriolis factor
+      !!              - dom_zgr: define the vertical coordinate and the bathymetry
+      !!              - dom_wri: create the meshmask file (ln_meshmask=T)
+      !!              - 1D configuration, move Coriolis, u and v at T-point
+      !!----------------------------------------------------------------------
+      INTEGER ::   ji, jj, jk, ik   ! dummy loop indices
+      INTEGER ::   iconf = 0    ! local integers
+      CHARACTER (len=64) ::   cform = "(A12, 3(A13, I7))" 
+      CHARACTER (len=*), INTENT(IN) :: cdstr                  ! model: NEMO or SAS. Determines core restart variables
+      INTEGER , DIMENSION(jpi,jpj) ::   ik_top , ik_bot       ! top and bottom ocean level
+      REAL(wp), DIMENSION(jpi,jpj) ::   z1_hu_0, z1_hv_0
+      !!----------------------------------------------------------------------
+      !
+      IF(lwp) THEN         ! Ocean domain Parameters (control print)
+         WRITE(numout,*)
+         WRITE(numout,*) 'dom_init : domain initialization'
+         WRITE(numout,*) '~~~~~~~~'
+         !
+         WRITE(numout,*)     '   Domain info'
+         WRITE(numout,*)     '      dimension of model:'
+         WRITE(numout,*)     '             Local domain      Global domain       Data domain '
+         WRITE(numout,cform) '        ','   jpi     : ', jpi, '   jpiglo  : ', jpiglo
+         WRITE(numout,cform) '        ','   jpj     : ', jpj, '   jpjglo  : ', jpjglo
+         WRITE(numout,cform) '        ','   jpk     : ', jpk, '   jpkglo  : ', jpkglo
+         WRITE(numout,cform) '       ' ,'   jpij    : ', jpij
+         WRITE(numout,*)     '      mpp local domain info (mpp):'
+         WRITE(numout,*)     '              jpni    : ', jpni, '   nn_hls  : ', nn_hls
+         WRITE(numout,*)     '              jpnj    : ', jpnj, '   nn_hls  : ', nn_hls
+         WRITE(numout,*)     '              jpnij   : ', jpnij
+         WRITE(numout,*)     '      lateral boundary of the Global domain : jperio  = ', jperio
+         SELECT CASE ( jperio )
+         CASE( 0 )   ;   WRITE(numout,*) '         (i.e. closed)'
+         CASE( 1 )   ;   WRITE(numout,*) '         (i.e. cyclic east-west)'
+         CASE( 2 )   ;   WRITE(numout,*) '         (i.e. equatorial symmetric)'
+         CASE( 3 )   ;   WRITE(numout,*) '         (i.e. north fold with T-point pivot)'
+         CASE( 4 )   ;   WRITE(numout,*) '         (i.e. cyclic east-west and north fold with T-point pivot)'
+         CASE( 5 )   ;   WRITE(numout,*) '         (i.e. north fold with F-point pivot)'
+         CASE( 6 )   ;   WRITE(numout,*) '         (i.e. cyclic east-west and north fold with F-point pivot)'
+         CASE( 7 )   ;   WRITE(numout,*) '         (i.e. cyclic east-west and north-south)'
+         CASE DEFAULT
+            CALL ctl_stop( 'jperio is out of range' )
+         END SELECT
+         WRITE(numout,*)     '      Ocean model configuration used:'
+         WRITE(numout,*)     '         cn_cfg = ', TRIM( cn_cfg ), '   nn_cfg = ', nn_cfg
+      ENDIF
+      lwxios = .FALSE.
+      ln_xios_read = .FALSE.
+      !
+      !           !==  Reference coordinate system  ==!
+      !
+      CALL dom_glo                     ! global domain versus local domain
+      CALL dom_nam                     ! read namelist ( namrun, namdom )
+      !
+      IF( lwxios ) THEN
+!define names for restart write and set core output (restart.F90)
+         CALL iom_set_rst_vars(rst_wfields)
+         CALL iom_set_rstw_core(cdstr)
+      ENDIF
+!reset namelist for SAS
+      IF(cdstr == 'SAS') THEN
+         IF(lrxios) THEN
+               IF(lwp) write(numout,*) 'Disable reading restart file using XIOS for SAS'
+               lrxios = .FALSE.
+         ENDIF
+      ENDIF
+      !
+      CALL dom_hgr                     ! Horizontal mesh
+      CALL dom_zgr( ik_top, ik_bot )   ! Vertical mesh and bathymetry
+      CALL dom_msk( ik_top, ik_bot )   ! Masks
+      IF( ln_closea )   CALL dom_clo   ! ln_closea=T : closed seas included in the simulation
+                                       ! Read in masks to define closed seas and lakes 
+      !
+      DO jj = 1, jpj                   ! depth of the iceshelves
+         DO ji = 1, jpi
+            ik = mikt(ji,jj)
+            risfdep(ji,jj) = gdepw_0(ji,jj,ik)
+         END DO
+      END DO
+      !
+      ht_0(:,:) = 0._wp  ! Reference ocean thickness
+      hu_0(:,:) = 0._wp
+      hv_0(:,:) = 0._wp
+      DO jk = 1, jpk
+         ht_0(:,:) = ht_0(:,:) + e3t_0(:,:,jk) * tmask(:,:,jk)
+         hu_0(:,:) = hu_0(:,:) + e3u_0(:,:,jk) * umask(:,:,jk)
+         hv_0(:,:) = hv_0(:,:) + e3v_0(:,:,jk) * vmask(:,:,jk)
+      END DO
+      !
+      !           !==  time varying part of coordinate system  ==!
+      !
+      IF( ln_linssh ) THEN       != Fix in time : set to the reference one for all
+      !
+         !       before        !          now          !       after         !
+            gdept_b = gdept_0  ;   gdept_n = gdept_0   !        ---          ! depth of grid-points
+            gdepw_b = gdepw_0  ;   gdepw_n = gdepw_0   !        ---          !
+                                   gde3w_n = gde3w_0   !        ---          !
+         !                                                                  
+              e3t_b =   e3t_0  ;     e3t_n =   e3t_0   ;   e3t_a =  e3t_0    ! scale factors
+              e3u_b =   e3u_0  ;     e3u_n =   e3u_0   ;   e3u_a =  e3u_0    !
+              e3v_b =   e3v_0  ;     e3v_n =   e3v_0   ;   e3v_a =  e3v_0    !
+                                     e3f_n =   e3f_0   !        ---          !
+              e3w_b =   e3w_0  ;     e3w_n =   e3w_0   !        ---          !
+             e3uw_b =  e3uw_0  ;    e3uw_n =  e3uw_0   !        ---          !
+             e3vw_b =  e3vw_0  ;    e3vw_n =  e3vw_0   !        ---          !
+         !
+         z1_hu_0(:,:) = ssumask(:,:) / ( hu_0(:,:) + 1._wp - ssumask(:,:) )     ! _i mask due to ISF
+         z1_hv_0(:,:) = ssvmask(:,:) / ( hv_0(:,:) + 1._wp - ssvmask(:,:) )
+         !
+         !        before       !          now          !       after         !
+                                      ht_n =    ht_0   !                     ! water column thickness
+               hu_b =    hu_0  ;      hu_n =    hu_0   ;    hu_a =    hu_0   ! 
+               hv_b =    hv_0  ;      hv_n =    hv_0   ;    hv_a =    hv_0   !
+            r1_hu_b = z1_hu_0  ;   r1_hu_n = z1_hu_0   ; r1_hu_a = z1_hu_0   ! inverse of water column thickness
+            r1_hv_b = z1_hv_0  ;   r1_hv_n = z1_hv_0   ; r1_hv_a = z1_hv_0   !
+         !
+         !
+      ELSE                       != time varying : initialize before/now/after variables
+         !
+         IF( .NOT.l_offline )  CALL dom_vvl_init 
+         !
+      ENDIF
+      !
+      IF( lk_c1d         )   CALL cor_c1d       ! 1D configuration: Coriolis set at T-point
+      !
+      IF( ln_meshmask .AND. .NOT.ln_iscpl )                        CALL dom_wri     ! Create a domain file
+      IF( ln_meshmask .AND.      ln_iscpl .AND. .NOT.ln_rstart )   CALL dom_wri     ! Create a domain file
+      IF(                                       .NOT.ln_rstart )   CALL dom_ctl     ! Domain control
+      !
+      IF( ln_write_cfg )   CALL cfg_write         ! create the configuration file
+      !
+      IF(lwp) THEN
+         WRITE(numout,*)
+         WRITE(numout,*) 'dom_init :   ==>>>   END of domain initialization'
+         WRITE(numout,*) '~~~~~~~~'
+         WRITE(numout,*) 
+      ENDIF
+      !
+   END SUBROUTINE dom_init
+
+
+   SUBROUTINE dom_glo
+      !!----------------------------------------------------------------------
+      !!                     ***  ROUTINE dom_glo  ***
+      !!
+      !! ** Purpose :   initialization of global domain <--> local domain indices
+      !!
+      !! ** Method  :   
+      !!
+      !! ** Action  : - mig , mjg : local  domain indices ==> global domain indices
+      !!              - mi0 , mi1 : global domain indices ==> local  domain indices
+      !!              - mj0,, mj1   (global point not in the local domain ==> mi0>mi1 and/or mj0>mj1)
+      !!----------------------------------------------------------------------
+      INTEGER ::   ji, jj   ! dummy loop argument
+      !!----------------------------------------------------------------------
+      !
+      DO ji = 1, jpi                 ! local domain indices ==> global domain indices
+        mig(ji) = ji + nimpp - 1
+      END DO
+      DO jj = 1, jpj
+        mjg(jj) = jj + njmpp - 1
+      END DO
+      !                              ! global domain indices ==> local domain indices
+      !                                   ! (return (m.0,m.1)=(1,0) if data domain gridpoint is to the west/south of the 
+      !                                   ! local domain, or (m.0,m.1)=(jp.+1,jp.) to the east/north of local domain. 
+      DO ji = 1, jpiglo
+        mi0(ji) = MAX( 1 , MIN( ji - nimpp + 1, jpi+1 ) )
+        mi1(ji) = MAX( 0 , MIN( ji - nimpp + 1, jpi   ) )
+      END DO
+      DO jj = 1, jpjglo
+        mj0(jj) = MAX( 1 , MIN( jj - njmpp + 1, jpj+1 ) )
+        mj1(jj) = MAX( 0 , MIN( jj - njmpp + 1, jpj   ) )
+      END DO
+      IF(lwp) THEN                   ! control print
+         WRITE(numout,*)
+         WRITE(numout,*) 'dom_glo : domain: global <<==>> local '
+         WRITE(numout,*) '~~~~~~~ '
+         WRITE(numout,*) '   global domain:   jpiglo = ', jpiglo, ' jpjglo = ', jpjglo, ' jpkglo = ', jpkglo
+         WRITE(numout,*) '   local  domain:   jpi    = ', jpi   , ' jpj    = ', jpj   , ' jpk    = ', jpk
+         WRITE(numout,*)
+         WRITE(numout,*) '   conversion from local to global domain indices (and vise versa) done'
+         IF( nn_print >= 1 ) THEN
+            WRITE(numout,*)
+            WRITE(numout,*) '          conversion local  ==> global i-index domain (mig)'
+            WRITE(numout,25)              (mig(ji),ji = 1,jpi)
+            WRITE(numout,*)
+            WRITE(numout,*) '          conversion global ==> local  i-index domain'
+            WRITE(numout,*) '             starting index (mi0)'
+            WRITE(numout,25)              (mi0(ji),ji = 1,jpiglo)
+            WRITE(numout,*) '             ending index (mi1)'
+            WRITE(numout,25)              (mi1(ji),ji = 1,jpiglo)
+            WRITE(numout,*)
+            WRITE(numout,*) '          conversion local  ==> global j-index domain (mjg)'
+            WRITE(numout,25)              (mjg(jj),jj = 1,jpj)
+            WRITE(numout,*)
+            WRITE(numout,*) '          conversion global ==> local  j-index domain'
+            WRITE(numout,*) '             starting index (mj0)'
+            WRITE(numout,25)              (mj0(jj),jj = 1,jpjglo)
+            WRITE(numout,*) '             ending index (mj1)'
+            WRITE(numout,25)              (mj1(jj),jj = 1,jpjglo)
+         ENDIF
+      ENDIF
+ 25   FORMAT( 100(10x,19i4,/) )
+      !
+   END SUBROUTINE dom_glo
+
+
+   SUBROUTINE dom_nam
+      !!----------------------------------------------------------------------
+      !!                     ***  ROUTINE dom_nam  ***
+      !!                    
+      !! ** Purpose :   read domaine namelists and print the variables.
+      !!
+      !! ** input   : - namrun namelist
+      !!              - namdom namelist
+      !!              - namnc4 namelist   ! "key_netcdf4" only
+      !!----------------------------------------------------------------------
+      USE ioipsl
+      !!
+      INTEGER  ::   ios   ! Local integer
+      !
+      NAMELIST/namrun/ cn_ocerst_indir, cn_ocerst_outdir, nn_stocklist, ln_rst_list,                 &
+         &             nn_no   , cn_exp   , cn_ocerst_in, cn_ocerst_out, ln_rstart , nn_rstctl ,     &
+         &             nn_it000, nn_itend , nn_date0    , nn_time0     , nn_leapy  , nn_istate ,     &
+         &             nn_stock, nn_write , ln_mskland  , ln_clobber   , nn_chunksz, nn_euler  ,     &
+         &             ln_cfmeta, ln_iscpl, ln_xios_read, nn_wxios
+      NAMELIST/namdom/ ln_linssh, rn_isfhmin, rn_rdt, rn_atfp, ln_crs, ln_meshmask
+#if defined key_netcdf4
+      NAMELIST/namnc4/ nn_nchunks_i, nn_nchunks_j, nn_nchunks_k, ln_nc4zip
+#endif
+      !!----------------------------------------------------------------------
+      !
+      IF(lwp) THEN
+         WRITE(numout,*)
+         WRITE(numout,*) 'dom_nam : domain initialization through namelist read'
+         WRITE(numout,*) '~~~~~~~ '
+      ENDIF
+      !
+      !
+      REWIND( numnam_ref )              ! Namelist namrun in reference namelist : Parameters of the run
+      READ  ( numnam_ref, namrun, IOSTAT = ios, ERR = 901)
+901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namrun in reference namelist', lwp )
+      REWIND( numnam_cfg )              ! Namelist namrun in configuration namelist : Parameters of the run
+      READ  ( numnam_cfg, namrun, IOSTAT = ios, ERR = 902 )
+902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namrun in configuration namelist', lwp )
+      IF(lwm) WRITE ( numond, namrun )
+      !
+      IF(lwp) THEN                  ! control print
+         WRITE(numout,*) '   Namelist : namrun   ---   run parameters'
+         WRITE(numout,*) '      Assimilation cycle              nn_no           = ', nn_no
+         WRITE(numout,*) '      experiment name for output      cn_exp          = ', TRIM( cn_exp           )
+         WRITE(numout,*) '      file prefix restart input       cn_ocerst_in    = ', TRIM( cn_ocerst_in     )
+         WRITE(numout,*) '      restart input directory         cn_ocerst_indir = ', TRIM( cn_ocerst_indir  )
+         WRITE(numout,*) '      file prefix restart output      cn_ocerst_out   = ', TRIM( cn_ocerst_out    )
+         WRITE(numout,*) '      restart output directory        cn_ocerst_outdir= ', TRIM( cn_ocerst_outdir )
+         WRITE(numout,*) '      restart logical                 ln_rstart       = ', ln_rstart
+         WRITE(numout,*) '      start with forward time step    nn_euler        = ', nn_euler
+         WRITE(numout,*) '      control of time step            nn_rstctl       = ', nn_rstctl
+         WRITE(numout,*) '      number of the first time step   nn_it000        = ', nn_it000
+         WRITE(numout,*) '      number of the last time step    nn_itend        = ', nn_itend
+         WRITE(numout,*) '      initial calendar date aammjj    nn_date0        = ', nn_date0
+         WRITE(numout,*) '      initial time of day in hhmm     nn_time0        = ', nn_time0
+         WRITE(numout,*) '      leap year calendar (0/1)        nn_leapy        = ', nn_leapy
+         WRITE(numout,*) '      initial state output            nn_istate       = ', nn_istate
+         IF( ln_rst_list ) THEN
+            WRITE(numout,*) '      list of restart dump times      nn_stocklist    =', nn_stocklist
+         ELSE
+            WRITE(numout,*) '      frequency of restart file       nn_stock        = ', nn_stock
+         ENDIF
+         WRITE(numout,*) '      frequency of output file        nn_write        = ', nn_write
+         WRITE(numout,*) '      mask land points                ln_mskland      = ', ln_mskland
+         WRITE(numout,*) '      additional CF standard metadata ln_cfmeta       = ', ln_cfmeta
+         WRITE(numout,*) '      overwrite an existing file      ln_clobber      = ', ln_clobber
+         WRITE(numout,*) '      NetCDF chunksize (bytes)        nn_chunksz      = ', nn_chunksz
+         WRITE(numout,*) '      IS coupling at the restart step ln_iscpl        = ', ln_iscpl
+         IF( TRIM(Agrif_CFixed()) == '0' ) THEN
+            WRITE(numout,*) '      READ restart for a single file using XIOS ln_xios_read =', ln_xios_read
+            WRITE(numout,*) '      Write restart using XIOS        nn_wxios   = ', nn_wxios
+         ELSE
+            WRITE(numout,*) "      AGRIF: nn_wxios will be ingored. See setting for parent"
+            WRITE(numout,*) "      AGRIF: ln_xios_read will be ingored. See setting for parent"
+         ENDIF
+      ENDIF
+
+      cexper = cn_exp         ! conversion DOCTOR names into model names (this should disappear soon)
+      nrstdt = nn_rstctl
+      nit000 = nn_it000
+      nitend = nn_itend
+      ndate0 = nn_date0
+      nleapy = nn_leapy
+      ninist = nn_istate
+      nstock = nn_stock
+      nstocklist = nn_stocklist
+      nwrite = nn_write
+      neuler = nn_euler
+      IF( neuler == 1 .AND. .NOT. ln_rstart ) THEN
+         IF(lwp) WRITE(numout,*)  
+         IF(lwp) WRITE(numout,*)'   ==>>>   Start from rest (ln_rstart=F)'
+         IF(lwp) WRITE(numout,*)'           an Euler initial time step is used : nn_euler is forced to 0 '   
+         neuler = 0
+      ENDIF
+      !                             ! control of output frequency
+      IF( nstock == 0 .OR. nstock > nitend ) THEN
+         WRITE(ctmp1,*) 'nstock = ', nstock, ' it is forced to ', nitend
+         CALL ctl_warn( ctmp1 )
+         nstock = nitend
+      ENDIF
+      IF ( nwrite == 0 ) THEN
+         WRITE(ctmp1,*) 'nwrite = ', nwrite, ' it is forced to ', nitend
+         CALL ctl_warn( ctmp1 )
+         nwrite = nitend
+      ENDIF
+
+#if defined key_agrif
+      IF( Agrif_Root() ) THEN
+#endif
+      IF(lwp) WRITE(numout,*)
+      SELECT CASE ( nleapy )        ! Choose calendar for IOIPSL
+      CASE (  1 ) 
+         CALL ioconf_calendar('gregorian')
+         IF(lwp) WRITE(numout,*) '   ==>>>   The IOIPSL calendar is "gregorian", i.e. leap year'
+      CASE (  0 )
+         CALL ioconf_calendar('noleap')
+         IF(lwp) WRITE(numout,*) '   ==>>>   The IOIPSL calendar is "noleap", i.e. no leap year'
+      CASE ( 30 )
+         CALL ioconf_calendar('360d')
+         IF(lwp) WRITE(numout,*) '   ==>>>   The IOIPSL calendar is "360d", i.e. 360 days in a year'
+      END SELECT
+#if defined key_agrif
+      ENDIF
+#endif
+
+      REWIND( numnam_ref )              ! Namelist namdom in reference namelist : space & time domain (bathymetry, mesh, timestep)
+      READ  ( numnam_ref, namdom, IOSTAT = ios, ERR = 903)
+903   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namdom in reference namelist', lwp )
+      REWIND( numnam_cfg )              ! Namelist namdom in configuration namelist : space & time domain (bathymetry, mesh, timestep)
+      READ  ( numnam_cfg, namdom, IOSTAT = ios, ERR = 904 )
+904   IF( ios >  0 )   CALL ctl_nam ( ios , 'namdom in configuration namelist', lwp )
+      IF(lwm) WRITE( numond, namdom )
+      !
+      IF(lwp) THEN
+         WRITE(numout,*)
+         WRITE(numout,*) '   Namelist : namdom   ---   space & time domain'
+         WRITE(numout,*) '      linear free surface (=T)                ln_linssh   = ', ln_linssh
+         WRITE(numout,*) '      create mesh/mask file                   ln_meshmask = ', ln_meshmask
+         WRITE(numout,*) '      treshold to open the isf cavity         rn_isfhmin  = ', rn_isfhmin, ' [m]'
+         WRITE(numout,*) '      ocean time step                         rn_rdt      = ', rn_rdt
+         WRITE(numout,*) '      asselin time filter parameter           rn_atfp     = ', rn_atfp
+         WRITE(numout,*) '      online coarsening of dynamical fields   ln_crs      = ', ln_crs
+      ENDIF
+      !
+      !          ! conversion DOCTOR names into model names (this should disappear soon)
+      atfp = rn_atfp
+      rdt  = rn_rdt
+
+      IF( TRIM(Agrif_CFixed()) == '0' ) THEN
+         lrxios = ln_xios_read.AND.ln_rstart
+!set output file type for XIOS based on NEMO namelist 
+         IF (nn_wxios > 0) lwxios = .TRUE. 
+         nxioso = nn_wxios
+      ENDIF
+
+#if defined key_netcdf4
+      !                             ! NetCDF 4 case   ("key_netcdf4" defined)
+      REWIND( numnam_ref )              ! Namelist namnc4 in reference namelist : NETCDF
+      READ  ( numnam_ref, namnc4, IOSTAT = ios, ERR = 907)
+907   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namnc4 in reference namelist', lwp )
+      REWIND( numnam_cfg )              ! Namelist namnc4 in configuration namelist : NETCDF
+      READ  ( numnam_cfg, namnc4, IOSTAT = ios, ERR = 908 )
+908   IF( ios >  0 )   CALL ctl_nam ( ios , 'namnc4 in configuration namelist', lwp )
+      IF(lwm) WRITE( numond, namnc4 )
+
+      IF(lwp) THEN                        ! control print
+         WRITE(numout,*)
+         WRITE(numout,*) '   Namelist namnc4 - Netcdf4 chunking parameters'
+         WRITE(numout,*) '      number of chunks in i-dimension             nn_nchunks_i = ', nn_nchunks_i
+         WRITE(numout,*) '      number of chunks in j-dimension             nn_nchunks_j = ', nn_nchunks_j
+         WRITE(numout,*) '      number of chunks in k-dimension             nn_nchunks_k = ', nn_nchunks_k
+         WRITE(numout,*) '      apply netcdf4/hdf5 chunking & compression   ln_nc4zip    = ', ln_nc4zip
+      ENDIF
+
+      ! Put the netcdf4 settings into a simple structure (snc4set, defined in in_out_manager module)
+      ! Note the chunk size in the unlimited (time) dimension will be fixed at 1
+      snc4set%ni   = nn_nchunks_i
+      snc4set%nj   = nn_nchunks_j
+      snc4set%nk   = nn_nchunks_k
+      snc4set%luse = ln_nc4zip
+#else
+      snc4set%luse = .FALSE.        ! No NetCDF 4 case
+#endif
+      !
+   END SUBROUTINE dom_nam
+
+
+   SUBROUTINE dom_ctl
+      !!----------------------------------------------------------------------
+      !!                     ***  ROUTINE dom_ctl  ***
+      !!
+      !! ** Purpose :   Domain control.
+      !!
+      !! ** Method  :   compute and print extrema of masked scale factors
+      !!----------------------------------------------------------------------
+      INTEGER ::   iimi1, ijmi1, iimi2, ijmi2, iima1, ijma1, iima2, ijma2
+      INTEGER, DIMENSION(2) ::   iloc   ! 
+      REAL(wp) ::   ze1min, ze1max, ze2min, ze2max
+      !!----------------------------------------------------------------------
+      !
+      IF(lk_mpp) THEN
+         CALL mpp_minloc( e1t(:,:), tmask_i(:,:), ze1min, iimi1,ijmi1 )
+         CALL mpp_minloc( e2t(:,:), tmask_i(:,:), ze2min, iimi2,ijmi2 )
+         CALL mpp_maxloc( e1t(:,:), tmask_i(:,:), ze1max, iima1,ijma1 )
+         CALL mpp_maxloc( e2t(:,:), tmask_i(:,:), ze2max, iima2,ijma2 )
+      ELSE
+         ze1min = MINVAL( e1t(:,:), mask = tmask_i(:,:) == 1._wp )    
+         ze2min = MINVAL( e2t(:,:), mask = tmask_i(:,:) == 1._wp )    
+         ze1max = MAXVAL( e1t(:,:), mask = tmask_i(:,:) == 1._wp )    
+         ze2max = MAXVAL( e2t(:,:), mask = tmask_i(:,:) == 1._wp )    
+         !
+         iloc  = MINLOC( e1t(:,:), mask = tmask_i(:,:) == 1._wp )
+         iimi1 = iloc(1) + nimpp - 1
+         ijmi1 = iloc(2) + njmpp - 1
+         iloc  = MINLOC( e2t(:,:), mask = tmask_i(:,:) == 1._wp )
+         iimi2 = iloc(1) + nimpp - 1
+         ijmi2 = iloc(2) + njmpp - 1
+         iloc  = MAXLOC( e1t(:,:), mask = tmask_i(:,:) == 1._wp )
+         iima1 = iloc(1) + nimpp - 1
+         ijma1 = iloc(2) + njmpp - 1
+         iloc  = MAXLOC( e2t(:,:), mask = tmask_i(:,:) == 1._wp )
+         iima2 = iloc(1) + nimpp - 1
+         ijma2 = iloc(2) + njmpp - 1
+      ENDIF
+      IF(lwp) THEN
+         WRITE(numout,*)
+         WRITE(numout,*) 'dom_ctl : extrema of the masked scale factors'
+         WRITE(numout,*) '~~~~~~~'
+         WRITE(numout,"(14x,'e1t maxi: ',1f10.2,' at i = ',i5,' j= ',i5)") ze1max, iima1, ijma1
+         WRITE(numout,"(14x,'e1t mini: ',1f10.2,' at i = ',i5,' j= ',i5)") ze1min, iimi1, ijmi1
+         WRITE(numout,"(14x,'e2t maxi: ',1f10.2,' at i = ',i5,' j= ',i5)") ze2max, iima2, ijma2
+         WRITE(numout,"(14x,'e2t mini: ',1f10.2,' at i = ',i5,' j= ',i5)") ze2min, iimi2, ijmi2
+      ENDIF
+      !
+   END SUBROUTINE dom_ctl
+
+
+   SUBROUTINE domain_cfg( ldtxt, cd_cfg, kk_cfg, kpi, kpj, kpk, kperio )
+      !!----------------------------------------------------------------------
+      !!                     ***  ROUTINE dom_nam  ***
+      !!                    
+      !! ** Purpose :   read the domain size in domain configuration file
+      !!
+      !! ** Method  :   read the cn_domcfg NetCDF file
+      !!----------------------------------------------------------------------
+      CHARACTER(len=*), DIMENSION(:), INTENT(out) ::   ldtxt           ! stored print information
+      CHARACTER(len=*)              , INTENT(out) ::   cd_cfg          ! configuration name
+      INTEGER                       , INTENT(out) ::   kk_cfg          ! configuration resolution
+      INTEGER                       , INTENT(out) ::   kpi, kpj, kpk   ! global domain sizes 
+      INTEGER                       , INTENT(out) ::   kperio          ! lateral global domain b.c. 
+      !
+      INTEGER ::   inum, ii   ! local integer
+      REAL(wp) ::   zorca_res                     ! local scalars
+      REAL(wp) ::   ziglo, zjglo, zkglo, zperio   !   -      -
+      !!----------------------------------------------------------------------
+      !
+      ii = 1
+      WRITE(ldtxt(ii),*) '           '                                                    ;   ii = ii+1
+      WRITE(ldtxt(ii),*) 'domain_cfg : domain size read in ', TRIM( cn_domcfg ), ' file'  ;   ii = ii+1
+      WRITE(ldtxt(ii),*) '~~~~~~~~~~ '                                                    ;   ii = ii+1
+      !
+      CALL iom_open( cn_domcfg, inum )
+      !
+      !                                   !- ORCA family specificity
+      IF(  iom_varid( inum, 'ORCA'       , ldstop = .FALSE. ) > 0  .AND.  &
+         & iom_varid( inum, 'ORCA_index' , ldstop = .FALSE. ) > 0    ) THEN
+         !
+         cd_cfg = 'ORCA'
+         CALL iom_get( inum, 'ORCA_index', zorca_res )   ;   kk_cfg = INT( zorca_res )
+         !
+         WRITE(ldtxt(ii),*) '   .'                                                     ;   ii = ii+1
+         WRITE(ldtxt(ii),*) '   ==>>>   ORCA configuration '                           ;   ii = ii+1
+         WRITE(ldtxt(ii),*) '   .'                                                     ;   ii = ii+1
+         !
+      ELSE                                !- cd_cfg & k_cfg are not used
+         cd_cfg = 'UNKNOWN'
+         kk_cfg = -9999999
+                                          !- or they may be present as global attributes 
+                                          !- (netcdf only)  
+         IF( iom_file(inum)%iolib == jpnf90 ) THEN
+            CALL iom_getatt( inum, 'cn_cfg', cd_cfg )  ! returns   !  if not found
+            CALL iom_getatt( inum, 'nn_cfg', kk_cfg )  ! returns -999 if not found
+            IF( TRIM(cd_cfg) == '!') cd_cfg = 'UNKNOWN'
+            IF( kk_cfg == -999     ) kk_cfg = -9999999
+         ENDIF
+         !
+      ENDIF
+      !
+      CALL iom_get( inum, 'jpiglo', ziglo  )   ;   kpi = INT( ziglo )
+      CALL iom_get( inum, 'jpjglo', zjglo  )   ;   kpj = INT( zjglo )
+      CALL iom_get( inum, 'jpkglo', zkglo  )   ;   kpk = INT( zkglo )
+      CALL iom_get( inum, 'jperio', zperio )   ;   kperio = INT( zperio )
+      CALL iom_close( inum )
+      !
+      WRITE(ldtxt(ii),*) '      cn_cfg = ', TRIM(cd_cfg), '   nn_cfg = ', kk_cfg             ;   ii = ii+1
+      WRITE(ldtxt(ii),*) '      jpiglo = ', kpi                                              ;   ii = ii+1
+      WRITE(ldtxt(ii),*) '      jpjglo = ', kpj                                              ;   ii = ii+1
+      WRITE(ldtxt(ii),*) '      jpkglo = ', kpk                                              ;   ii = ii+1
+      WRITE(ldtxt(ii),*) '      type of global domain lateral boundary   jperio = ', kperio  ;   ii = ii+1
+      !        
+   END SUBROUTINE domain_cfg
+   
+   
+   SUBROUTINE cfg_write
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE cfg_write  ***
+      !!                   
+      !! ** Purpose :   Create the "cn_domcfg_out" file, a NetCDF file which 
+      !!              contains all the ocean domain informations required to 
+      !!              define an ocean configuration.
+      !!
+      !! ** Method  :   Write in a file all the arrays required to set up an
+      !!              ocean configuration.
+      !!
+      !! ** output file :   domcfg_out.nc : domain size, characteristics, horizontal 
+      !!                       mesh, Coriolis parameter, and vertical scale factors
+      !!                    NB: also contain ORCA family information
+      !!----------------------------------------------------------------------
+      INTEGER           ::   ji, jj, jk   ! dummy loop indices
+      INTEGER           ::   izco, izps, isco, icav
+      INTEGER           ::   inum     ! local units
+      CHARACTER(len=21) ::   clnam    ! filename (mesh and mask informations)
+      REAL(wp), DIMENSION(jpi,jpj) ::   z2d   ! workspace
+      !!----------------------------------------------------------------------
+      !
+      IF(lwp) WRITE(numout,*)
+      IF(lwp) WRITE(numout,*) 'cfg_write : create the domain configuration file (', TRIM(cn_domcfg_out),'.nc)'
+      IF(lwp) WRITE(numout,*) '~~~~~~~~~'
+      !
+      !                       ! ============================= !
+      !                       !  create 'domcfg_out.nc' file  !
+      !                       ! ============================= !
+      !         
+      clnam = cn_domcfg_out  ! filename (configuration information)
+      CALL iom_open( TRIM(clnam), inum, ldwrt = .TRUE., kiolib = jprstlib )
+      
+      !
+      !                             !==  ORCA family specificities  ==!
+      IF( cn_cfg == "ORCA" ) THEN
+         CALL iom_rstput( 0, 0, inum, 'ORCA'      , 1._wp            , ktype = jp_i4 )
+         CALL iom_rstput( 0, 0, inum, 'ORCA_index', REAL( nn_cfg, wp), ktype = jp_i4 )         
+      ENDIF
+      !
+      !                             !==  global domain size  ==!
+      !
+      CALL iom_rstput( 0, 0, inum, 'jpiglo', REAL( jpiglo, wp), ktype = jp_i4 )
+      CALL iom_rstput( 0, 0, inum, 'jpjglo', REAL( jpjglo, wp), ktype = jp_i4 )
+      CALL iom_rstput( 0, 0, inum, 'jpkglo', REAL( jpk   , wp), ktype = jp_i4 )
+      !
+      !                             !==  domain characteristics  ==!
+      !
+      !                                   ! lateral boundary of the global domain
+      CALL iom_rstput( 0, 0, inum, 'jperio', REAL( jperio, wp), ktype = jp_i4 )
+      !
+      !                                   ! type of vertical coordinate
+      IF( ln_zco    ) THEN   ;   izco = 1   ;   ELSE   ;   izco = 0   ;   ENDIF
+      IF( ln_zps    ) THEN   ;   izps = 1   ;   ELSE   ;   izps = 0   ;   ENDIF
+      IF( ln_sco    ) THEN   ;   isco = 1   ;   ELSE   ;   isco = 0   ;   ENDIF
+      CALL iom_rstput( 0, 0, inum, 'ln_zco'   , REAL( izco, wp), ktype = jp_i4 )
+      CALL iom_rstput( 0, 0, inum, 'ln_zps'   , REAL( izps, wp), ktype = jp_i4 )
+      CALL iom_rstput( 0, 0, inum, 'ln_sco'   , REAL( isco, wp), ktype = jp_i4 )
+      !
+      !                                   ! ocean cavities under iceshelves
+      IF( ln_isfcav ) THEN   ;   icav = 1   ;   ELSE   ;   icav = 0   ;   ENDIF
+      CALL iom_rstput( 0, 0, inum, 'ln_isfcav', REAL( icav, wp), ktype = jp_i4 )
+      !
+      !                             !==  horizontal mesh  !
+      !
+      CALL iom_rstput( 0, 0, inum, 'glamt', glamt, ktype = jp_r8 )   ! latitude
+      CALL iom_rstput( 0, 0, inum, 'glamu', glamu, ktype = jp_r8 )
+      CALL iom_rstput( 0, 0, inum, 'glamv', glamv, ktype = jp_r8 )
+      CALL iom_rstput( 0, 0, inum, 'glamf', glamf, ktype = jp_r8 )
+      !                                
+      CALL iom_rstput( 0, 0, inum, 'gphit', gphit, ktype = jp_r8 )   ! longitude
+      CALL iom_rstput( 0, 0, inum, 'gphiu', gphiu, ktype = jp_r8 )
+      CALL iom_rstput( 0, 0, inum, 'gphiv', gphiv, ktype = jp_r8 )
+      CALL iom_rstput( 0, 0, inum, 'gphif', gphif, ktype = jp_r8 )
+      !                                
+      CALL iom_rstput( 0, 0, inum, 'e1t'  , e1t  , ktype = jp_r8 )   ! i-scale factors (e1.)
+      CALL iom_rstput( 0, 0, inum, 'e1u'  , e1u  , ktype = jp_r8 )
+      CALL iom_rstput( 0, 0, inum, 'e1v'  , e1v  , ktype = jp_r8 )
+      CALL iom_rstput( 0, 0, inum, 'e1f'  , e1f  , ktype = jp_r8 )
+      !
+      CALL iom_rstput( 0, 0, inum, 'e2t'  , e2t  , ktype = jp_r8 )   ! j-scale factors (e2.)
+      CALL iom_rstput( 0, 0, inum, 'e2u'  , e2u  , ktype = jp_r8 )
+      CALL iom_rstput( 0, 0, inum, 'e2v'  , e2v  , ktype = jp_r8 )
+      CALL iom_rstput( 0, 0, inum, 'e2f'  , e2f  , ktype = jp_r8 )
+      !
+      CALL iom_rstput( 0, 0, inum, 'ff_f' , ff_f , ktype = jp_r8 )   ! coriolis factor
+      CALL iom_rstput( 0, 0, inum, 'ff_t' , ff_t , ktype = jp_r8 )
+      !
+      !                             !==  vertical mesh  ==!
+      !                                                     
+      CALL iom_rstput( 0, 0, inum, 'e3t_1d'  , e3t_1d , ktype = jp_r8 )   ! reference 1D-coordinate
+      CALL iom_rstput( 0, 0, inum, 'e3w_1d'  , e3w_1d , ktype = jp_r8 )
+      !
+      CALL iom_rstput( 0, 0, inum, 'e3t_0'   , e3t_0  , ktype = jp_r8 )   ! vertical scale factors
+      CALL iom_rstput( 0, 0, inum, 'e3u_0'   , e3u_0  , ktype = jp_r8 )
+      CALL iom_rstput( 0, 0, inum, 'e3v_0'   , e3v_0  , ktype = jp_r8 )
+      CALL iom_rstput( 0, 0, inum, 'e3f_0'   , e3f_0  , ktype = jp_r8 )
+      CALL iom_rstput( 0, 0, inum, 'e3w_0'   , e3w_0  , ktype = jp_r8 )
+      CALL iom_rstput( 0, 0, inum, 'e3uw_0'  , e3uw_0 , ktype = jp_r8 )
+      CALL iom_rstput( 0, 0, inum, 'e3vw_0'  , e3vw_0 , ktype = jp_r8 )
+      !                                         
+      !                             !==  wet top and bottom level  ==!   (caution: multiplied by ssmask)
+      !
+      CALL iom_rstput( 0, 0, inum, 'top_level'    , REAL( mikt, wp )*ssmask , ktype = jp_i4 )   ! nb of ocean T-points (ISF)
+      CALL iom_rstput( 0, 0, inum, 'bottom_level' , REAL( mbkt, wp )*ssmask , ktype = jp_i4 )   ! nb of ocean T-points
+      !
+      IF( ln_sco ) THEN             ! s-coordinate: store grid stiffness ratio  (Not required anyway)
+         CALL dom_stiff( z2d )
+         CALL iom_rstput( 0, 0, inum, 'stiffness', z2d )        !    ! Max. grid stiffness ratio
+      ENDIF
+      !
+      IF( ll_wd ) THEN              ! wetting and drying domain
+         CALL iom_rstput( 0, 0, inum, 'ht_0'   , ht_0   , ktype = jp_r8 )
+      ENDIF
+      !
+      ! Add some global attributes ( netcdf only )
+      IF( iom_file(inum)%iolib == jpnf90 ) THEN
+         CALL iom_putatt( inum, 'nn_cfg', nn_cfg )
+         CALL iom_putatt( inum, 'cn_cfg', TRIM(cn_cfg) )
+      ENDIF
+      !
+      !                                ! ============================
+      !                                !        close the files 
+      !                                ! ============================
+      CALL iom_close( inum )
+      !
+   END SUBROUTINE cfg_write
+
+   !!======================================================================
+END MODULE domain
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DOM/domhgr.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DOM/domhgr.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DOM/domhgr.F90	(revision 9570)
@@ -0,0 +1,235 @@
+MODULE domhgr
+   !!==============================================================================
+   !!                       ***  MODULE domhgr   ***
+   !! Ocean initialization : domain initialization
+   !!==============================================================================
+   !! History :  OPA  ! 1988-03  (G. Madec) Original code
+   !!            7.0  ! 1996-01  (G. Madec)  terrain following coordinates
+   !!            8.0  ! 1997-02  (G. Madec)  print mesh informations
+   !!            8.1  ! 1999-11  (M. Imbard) NetCDF format with IO-IPSL
+   !!            8.2  ! 2000-08  (D. Ludicone) Reduced section at Bab el Mandeb
+   !!             -   ! 2001-09  (M. Levy)  eel config: grid in km, beta-plane
+   !!  NEMO      1.0  ! 2002-08  (G. Madec)  F90: Free form and module, namelist
+   !!             -   ! 2004-01  (A.M. Treguier, J.M. Molines) Case 4 (Mercator mesh)
+   !!                            use of parameters in par_CONFIG-Rxx.h90, not in namelist
+   !!             -   ! 2004-05  (A. Koch-Larrouy) Add Gyre configuration 
+   !!            3.7  ! 2015-09  (G. Madec, S. Flavoni) add cell surface and their inverse
+   !!                                       add optional read of e1e2u & e1e2v
+   !!             -   ! 2016-04  (S. Flavoni, G. Madec) new configuration interface: read or usrdef.F90
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   dom_hgr       : initialize the horizontal mesh 
+   !!   hgr_read      : read horizontal information in the domain configuration file 
+   !!----------------------------------------------------------------------
+   USE dom_oce        ! ocean space and time domain
+   USE par_oce        ! ocean space and time domain
+   USE phycst         ! physical constants
+   USE usrdef_hgr     ! User defined routine
+   !
+   USE in_out_manager ! I/O manager
+   USE iom            ! I/O library
+   USE lib_mpp        ! MPP library
+   USE timing         ! Timing
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   dom_hgr   ! called by domain.F90
+
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.7 , NEMO Consortium (2016)
+   !! $Id$ 
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE dom_hgr
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE dom_hgr  ***
+      !!
+      !! ** Purpose :   Read or compute the geographical position (in degrees)  
+      !!      of the model grid-points, the horizontal scale factors (in meters), 
+      !!      the associated horizontal metrics, and the Coriolis factor (in s-1).
+      !!
+      !! ** Method  :   Controlled by ln_read_cfg logical
+      !!              =T : all needed arrays are read in mesh_mask.nc file 
+      !!              =F : user-defined configuration, all needed arrays 
+      !!                   are computed in usr-def_hgr subroutine 
+      !!
+      !!                If Coriolis factor is neither read nor computed (iff=0)
+      !!              it is computed from gphit assuming that the mesh is
+      !!              defined on the sphere :
+      !!                   ff = 2.*omega*sin(gphif)      (in s-1)
+      !!    
+      !!                If u- & v-surfaces are neither read nor computed (ie1e2u_v=0)
+      !!              (i.e. no use of reduced scale factors in some straits)
+      !!              they are computed from e1u, e2u, e1v and e2v as:
+      !!                   e1e2u = e1u*e2u   and   e1e2v = e1v*e2v  
+      !!    
+      !! ** Action  : - define longitude & latitude of t-, u-, v- and f-points (in degrees)
+      !!              - define Coriolis parameter at f-point                   (in 1/s)
+      !!              - define i- & j-scale factors at t-, u-, v- and f-points (in meters)
+      !!              - define associated horizontal metrics at t-, u-, v- and f-points
+      !!                (inverse of scale factors 1/e1 & 1/e2, surface e1*e2, ratios e1/e2 & e2/e1)
+      !!----------------------------------------------------------------------
+      INTEGER ::   ji, jj     ! dummy loop indices
+      INTEGER ::   ie1e2u_v   ! flag for u- & v-surfaces 
+      INTEGER ::   iff        ! flag for Coriolis parameter
+      !!----------------------------------------------------------------------
+      !
+      IF( ln_timing )   CALL timing_start('dom_hgr')
+      !
+      IF(lwp) THEN
+         WRITE(numout,*)
+         WRITE(numout,*) 'dom_hgr : define the horizontal mesh from ithe following par_oce parameters '
+         WRITE(numout,*) '~~~~~~~   '
+         WRITE(numout,*) '   namcfg : read (=T) or user defined (=F) configuration    ln_read_cfg  = ', ln_read_cfg
+      ENDIF
+      !
+      !
+      IF( ln_read_cfg ) THEN        !==  read in mesh_mask.nc file  ==!
+         IF(lwp) WRITE(numout,*)
+         IF(lwp) WRITE(numout,*) '   ==>>>   read horizontal mesh in ', TRIM( cn_domcfg ), ' file'
+         !
+         CALL hgr_read   ( glamt , glamu , glamv , glamf ,   &    ! geographic position (required)
+            &              gphit , gphiu , gphiv , gphif ,   &    !     -        -
+            &              iff   , ff_f  , ff_t  ,           &    ! Coriolis parameter (if not on the sphere)
+            &              e1t   , e1u   , e1v   , e1f   ,   &    ! scale factors (required)
+            &              e2t   , e2u   , e2v   , e2f   ,   &    !    -     -        -
+            &              ie1e2u_v      , e1e2u , e1e2v     )    ! u- & v-surfaces (if gridsize reduction in some straits)
+         !
+      ELSE                          !==  User defined configuration  ==! 
+         IF(lwp) WRITE(numout,*)
+         IF(lwp) WRITE(numout,*) '          User defined horizontal mesh (usr_def_hgr)'
+         !
+         CALL usr_def_hgr( glamt , glamu , glamv , glamf ,   &    ! geographic position (required)
+            &              gphit , gphiu , gphiv , gphif ,   &    !
+            &              iff   , ff_f  , ff_t  ,           &    ! Coriolis parameter  (if domain not on the sphere)
+            &              e1t   , e1u   , e1v   , e1f   ,   &    ! scale factors       (required)
+            &              e2t   , e2u   , e2v   , e2f   ,   &    !
+            &              ie1e2u_v      , e1e2u , e1e2v     )    ! u- & v-surfaces (if gridsize reduction is used in strait(s))
+         !
+      ENDIF
+      !
+      !                             !==  Coriolis parameter  ==!   (if necessary)
+      !
+      IF( iff == 0 ) THEN                 ! Coriolis parameter has not been defined 
+         IF(lwp) WRITE(numout,*) '          Coriolis parameter calculated on the sphere from gphif & gphit'
+         ff_f(:,:) = 2. * omega * SIN( rad * gphif(:,:) )     ! compute it on the sphere at f-point
+         ff_t(:,:) = 2. * omega * SIN( rad * gphit(:,:) )     !    -        -       -    at t-point
+      ELSE
+         IF( ln_read_cfg ) THEN
+            IF(lwp) WRITE(numout,*) '          Coriolis parameter have been read in ', TRIM( cn_domcfg ), ' file'
+         ELSE
+            IF(lwp) WRITE(numout,*) '          Coriolis parameter have been set in usr_def_hgr routine'
+         ENDIF
+      ENDIF
+
+      !
+      !                             !==  associated horizontal metrics  ==!
+      !
+      r1_e1t(:,:) = 1._wp / e1t(:,:)   ;   r1_e2t (:,:) = 1._wp / e2t(:,:)
+      r1_e1u(:,:) = 1._wp / e1u(:,:)   ;   r1_e2u (:,:) = 1._wp / e2u(:,:)
+      r1_e1v(:,:) = 1._wp / e1v(:,:)   ;   r1_e2v (:,:) = 1._wp / e2v(:,:)
+      r1_e1f(:,:) = 1._wp / e1f(:,:)   ;   r1_e2f (:,:) = 1._wp / e2f(:,:)
+      !
+      e1e2t (:,:) = e1t(:,:) * e2t(:,:)   ;   r1_e1e2t(:,:) = 1._wp / e1e2t(:,:)
+      e1e2f (:,:) = e1f(:,:) * e2f(:,:)   ;   r1_e1e2f(:,:) = 1._wp / e1e2f(:,:)
+      IF( ie1e2u_v == 0 ) THEN               ! u- & v-surfaces have not been defined
+         IF(lwp) WRITE(numout,*) '          u- & v-surfaces calculated as e1 e2 product'
+         e1e2u (:,:) = e1u(:,:) * e2u(:,:)         ! compute them
+         e1e2v (:,:) = e1v(:,:) * e2v(:,:) 
+      ELSE
+         IF(lwp) WRITE(numout,*) '          u- & v-surfaces have been read in "mesh_mask" file:'
+         IF(lwp) WRITE(numout,*) '                     grid size reduction in strait(s) is used'
+      ENDIF
+      r1_e1e2u(:,:) = 1._wp / e1e2u(:,:)     ! compute their invert in any cases
+      r1_e1e2v(:,:) = 1._wp / e1e2v(:,:)
+      !   
+      e2_e1u(:,:) = e2u(:,:) / e1u(:,:)
+      e1_e2v(:,:) = e1v(:,:) / e2v(:,:)
+      !
+      !
+      IF( ln_timing )   CALL timing_stop('dom_hgr')
+      !
+   END SUBROUTINE dom_hgr
+
+
+   SUBROUTINE hgr_read( plamt , plamu , plamv  , plamf  ,   &    ! gridpoints position (required)
+      &                 pphit , pphiu , pphiv  , pphif  ,   &     
+      &                 kff   , pff_f , pff_t  ,            &    ! Coriolis parameter  (if not on the sphere)
+      &                 pe1t  , pe1u  , pe1v   , pe1f   ,   &    ! scale factors       (required)
+      &                 pe2t  , pe2u  , pe2v   , pe2f   ,   &
+      &                 ke1e2u_v      , pe1e2u , pe1e2v     )    ! u- & v-surfaces (if gridsize reduction in some straits)
+      !!---------------------------------------------------------------------
+      !!              ***  ROUTINE hgr_read  ***
+      !!
+      !! ** Purpose :   Read a mesh_mask file in NetCDF format using IOM
+      !!
+      !!----------------------------------------------------------------------
+      REAL(wp), DIMENSION(:,:), INTENT(out) ::   plamt, plamu, plamv, plamf   ! longitude outputs 
+      REAL(wp), DIMENSION(:,:), INTENT(out) ::   pphit, pphiu, pphiv, pphif   ! latitude outputs
+      INTEGER                 , INTENT(out) ::   kff                          ! =1 Coriolis parameter read here, =0 otherwise
+      REAL(wp), DIMENSION(:,:), INTENT(out) ::   pff_f, pff_t                 ! Coriolis factor at f-point (if found in file)
+      REAL(wp), DIMENSION(:,:), INTENT(out) ::   pe1t, pe1u, pe1v, pe1f       ! i-scale factors 
+      REAL(wp), DIMENSION(:,:), INTENT(out) ::   pe2t, pe2u, pe2v, pe2f       ! j-scale factors
+      INTEGER                 , INTENT(out) ::   ke1e2u_v                     ! =1 u- & v-surfaces read here, =0 otherwise 
+      REAL(wp), DIMENSION(:,:), INTENT(out) ::   pe1e2u, pe1e2v              ! u- & v-surfaces (if found in file)
+      !
+      INTEGER  ::   inum                  ! logical unit
+      !!----------------------------------------------------------------------
+      !
+      IF(lwp) THEN
+         WRITE(numout,*)
+         WRITE(numout,*) '   hgr_read : read the horizontal coordinates in mesh_mask'
+         WRITE(numout,*) '   ~~~~~~~~      jpiglo = ', jpiglo, ' jpjglo = ', jpjglo, ' jpk = ', jpk
+      ENDIF
+      !
+      CALL iom_open( cn_domcfg, inum )
+      !
+      CALL iom_get( inum, jpdom_data, 'glamt', plamt, lrowattr=ln_use_jattr )
+      CALL iom_get( inum, jpdom_data, 'glamu', plamu, lrowattr=ln_use_jattr )
+      CALL iom_get( inum, jpdom_data, 'glamv', plamv, lrowattr=ln_use_jattr )
+      CALL iom_get( inum, jpdom_data, 'glamf', plamf, lrowattr=ln_use_jattr )
+      !
+      CALL iom_get( inum, jpdom_data, 'gphit', pphit, lrowattr=ln_use_jattr )
+      CALL iom_get( inum, jpdom_data, 'gphiu', pphiu, lrowattr=ln_use_jattr )
+      CALL iom_get( inum, jpdom_data, 'gphiv', pphiv, lrowattr=ln_use_jattr )
+      CALL iom_get( inum, jpdom_data, 'gphif', pphif, lrowattr=ln_use_jattr )
+      !
+      CALL iom_get( inum, jpdom_data, 'e1t'  , pe1t  , lrowattr=ln_use_jattr )
+      CALL iom_get( inum, jpdom_data, 'e1u'  , pe1u  , lrowattr=ln_use_jattr )
+      CALL iom_get( inum, jpdom_data, 'e1v'  , pe1v  , lrowattr=ln_use_jattr )
+      CALL iom_get( inum, jpdom_data, 'e1f'  , pe1f  , lrowattr=ln_use_jattr )
+      !
+      CALL iom_get( inum, jpdom_data, 'e2t'  , pe2t  , lrowattr=ln_use_jattr )
+      CALL iom_get( inum, jpdom_data, 'e2u'  , pe2u  , lrowattr=ln_use_jattr )
+      CALL iom_get( inum, jpdom_data, 'e2v'  , pe2v  , lrowattr=ln_use_jattr )
+      CALL iom_get( inum, jpdom_data, 'e2f'  , pe2f  , lrowattr=ln_use_jattr )
+      !
+      IF(  iom_varid( inum, 'ff_f', ldstop = .FALSE. ) > 0  .AND.  &
+         & iom_varid( inum, 'ff_t', ldstop = .FALSE. ) > 0    ) THEN
+         IF(lwp) WRITE(numout,*) '           Coriolis factor at f- and t-points read in ', TRIM( cn_domcfg ), ' file'
+         CALL iom_get( inum, jpdom_data, 'ff_f'  , pff_f  , lrowattr=ln_use_jattr )
+         CALL iom_get( inum, jpdom_data, 'ff_t'  , pff_t  , lrowattr=ln_use_jattr )
+         kff = 1
+      ELSE
+         kff = 0
+      ENDIF
+      !
+      IF( iom_varid( inum, 'e1e2u', ldstop = .FALSE. ) > 0 ) THEN
+         IF(lwp) WRITE(numout,*) '           e1e2u & e1e2v read in ', TRIM( cn_domcfg ), ' file'
+         CALL iom_get( inum, jpdom_data, 'e1e2u'  , pe1e2u  , lrowattr=ln_use_jattr )
+         CALL iom_get( inum, jpdom_data, 'e1e2v'  , pe1e2v  , lrowattr=ln_use_jattr )
+         ke1e2u_v = 1
+      ELSE
+         ke1e2u_v = 0
+      ENDIF
+      !
+      CALL iom_close( inum )
+      !
+   END SUBROUTINE hgr_read
+    
+   !!======================================================================
+END MODULE domhgr
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DOM/dommsk.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DOM/dommsk.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DOM/dommsk.F90	(revision 9570)
@@ -0,0 +1,295 @@
+MODULE dommsk
+   !!======================================================================
+   !!                       ***  MODULE dommsk   ***
+   !! Ocean initialization : domain land/sea mask 
+   !!======================================================================
+   !! History :  OPA  ! 1987-07  (G. Madec)  Original code
+   !!            6.0  ! 1993-03  (M. Guyon)  symetrical conditions (M. Guyon)
+   !!            7.0  ! 1996-01  (G. Madec)  suppression of common work arrays
+   !!             -   ! 1996-05  (G. Madec)  mask computed from tmask
+   !!            8.0  ! 1997-02  (G. Madec)  mesh information put in domhgr.F
+   !!            8.1  ! 1997-07  (G. Madec)  modification of kbat and fmask
+   !!             -   ! 1998-05  (G. Roullet)  free surface
+   !!            8.2  ! 2000-03  (G. Madec)  no slip accurate
+   !!             -   ! 2001-09  (J.-M. Molines)  Open boundaries
+   !!   NEMO     1.0  ! 2002-08  (G. Madec)  F90: Free form and module
+   !!             -   ! 2005-11  (V. Garnier) Surface pressure gradient organization
+   !!            3.2  ! 2009-07  (R. Benshila) Suppression of rigid-lid option
+   !!            3.6  ! 2015-05  (P. Mathiot) ISF: add wmask,wumask and wvmask
+   !!            4.0  ! 2016-06  (G. Madec, S. Flavoni)  domain configuration / user defined interface
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   dom_msk       : compute land/ocean mask
+   !!----------------------------------------------------------------------
+   USE oce            ! ocean dynamics and tracers
+   USE dom_oce        ! ocean space and time domain
+   USE usrdef_fmask   ! user defined fmask
+   USE bdy_oce        ! open boundary
+   !
+   USE in_out_manager ! I/O manager
+   USE lbclnk         ! ocean lateral boundary conditions (or mpp link)
+   USE lib_mpp        ! Massively Parallel Processing library
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   dom_msk    ! routine called by inidom.F90
+
+   !                            !!* Namelist namlbc : lateral boundary condition *
+   REAL(wp)        :: rn_shlat   ! type of lateral boundary condition on velocity
+   LOGICAL, PUBLIC :: ln_vorlat  !  consistency of vorticity boundary condition 
+   !                                            with analytical eqs.
+
+   !! * Substitutions
+#  include "vectopt_loop_substitute.h90"
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.2 , LODYC-IPSL  (2009)
+   !! $Id$ 
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE dom_msk( k_top, k_bot )
+      !!---------------------------------------------------------------------
+      !!                 ***  ROUTINE dom_msk  ***
+      !!
+      !! ** Purpose :   Compute land/ocean mask arrays at tracer points, hori-
+      !!      zontal velocity points (u & v), vorticity points (f) points.
+      !!
+      !! ** Method  :   The ocean/land mask  at t-point is deduced from ko_top 
+      !!      and ko_bot, the indices of the fist and last ocean t-levels which 
+      !!      are either defined in usrdef_zgr or read in zgr_read.
+      !!                The velocity masks (umask, vmask, wmask, wumask, wvmask) 
+      !!      are deduced from a product of the two neighboring tmask.
+      !!                The vorticity mask (fmask) is deduced from tmask taking
+      !!      into account the choice of lateral boundary condition (rn_shlat) :
+      !!         rn_shlat = 0, free slip  (no shear along the coast)
+      !!         rn_shlat = 2, no slip  (specified zero velocity at the coast)
+      !!         0 < rn_shlat < 2, partial slip   | non-linear velocity profile
+      !!         2 < rn_shlat, strong slip        | in the lateral boundary layer
+      !!
+      !!      tmask_i : interior ocean mask at t-point, i.e. excluding duplicated
+      !!                rows/lines due to cyclic or North Fold boundaries as well
+      !!                as MPP halos.
+      !!      tmask_h : halo mask at t-point, i.e. excluding duplicated rows/lines
+      !!                due to cyclic or North Fold boundaries as well as MPP halos.
+      !!
+      !! ** Action :   tmask, umask, vmask, wmask, wumask, wvmask : land/ocean mask 
+      !!                         at t-, u-, v- w, wu-, and wv-points (=0. or 1.)
+      !!               fmask   : land/ocean mask at f-point (=0., or =1., or 
+      !!                         =rn_shlat along lateral boundaries)
+      !!               tmask_i : interior ocean mask 
+      !!               tmask_h : halo mask
+      !!               ssmask , ssumask, ssvmask, ssfmask : 2D ocean mask
+      !!----------------------------------------------------------------------
+      INTEGER, DIMENSION(:,:), INTENT(in) ::   k_top, k_bot   ! first and last ocean level
+      !
+      INTEGER  ::   ji, jj, jk     ! dummy loop indices
+      INTEGER  ::   iif, iil       ! local integers
+      INTEGER  ::   ijf, ijl       !   -       -
+      INTEGER  ::   iktop, ikbot   !   -       -
+      INTEGER  ::   ios, inum
+      REAL(wp), ALLOCATABLE, DIMENSION(:,:) ::   zwf   ! 2D workspace
+      !!
+      NAMELIST/namlbc/ rn_shlat, ln_vorlat
+      NAMELIST/nambdy/ ln_bdy ,nb_bdy, ln_coords_file, cn_coords_file,         &
+         &             ln_mask_file, cn_mask_file, cn_dyn2d, nn_dyn2d_dta,     &
+         &             cn_dyn3d, nn_dyn3d_dta, cn_tra, nn_tra_dta,             &
+         &             ln_tra_dmp, ln_dyn3d_dmp, rn_time_dmp, rn_time_dmp_out, &
+         &             cn_ice_lim, nn_ice_lim_dta,                           &
+         &             rn_ice_tem, rn_ice_sal, rn_ice_age,                 &
+         &             ln_vol, nn_volctl, nn_rimwidth, nb_jpk_bdy
+      !!---------------------------------------------------------------------
+      !
+      REWIND( numnam_ref )              ! Namelist namlbc in reference namelist : Lateral momentum boundary condition
+      READ  ( numnam_ref, namlbc, IOSTAT = ios, ERR = 901 )
+901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namlbc in reference namelist', lwp )
+      REWIND( numnam_cfg )              ! Namelist namlbc in configuration namelist : Lateral momentum boundary condition
+      READ  ( numnam_cfg, namlbc, IOSTAT = ios, ERR = 902 )
+902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namlbc in configuration namelist', lwp )
+      IF(lwm) WRITE ( numond, namlbc )
+      
+      IF(lwp) THEN                  ! control print
+         WRITE(numout,*)
+         WRITE(numout,*) 'dommsk : ocean mask '
+         WRITE(numout,*) '~~~~~~'
+         WRITE(numout,*) '   Namelist namlbc'
+         WRITE(numout,*) '      lateral momentum boundary cond.    rn_shlat  = ',rn_shlat
+         WRITE(numout,*) '      consistency with analytical form   ln_vorlat = ',ln_vorlat 
+      ENDIF
+      !
+      IF(lwp) WRITE(numout,*)
+      IF     (      rn_shlat == 0.               ) THEN   ;   IF(lwp) WRITE(numout,*) '   ==>>>   ocean lateral  free-slip'
+      ELSEIF (      rn_shlat == 2.               ) THEN   ;   IF(lwp) WRITE(numout,*) '   ==>>>   ocean lateral  no-slip'
+      ELSEIF ( 0. < rn_shlat .AND. rn_shlat < 2. ) THEN   ;   IF(lwp) WRITE(numout,*) '   ==>>>   ocean lateral  partial-slip'
+      ELSEIF ( 2. < rn_shlat                     ) THEN   ;   IF(lwp) WRITE(numout,*) '   ==>>>   ocean lateral  strong-slip'
+      ELSE
+         CALL ctl_stop( 'dom_msk: wrong value for rn_shlat (i.e. a negalive value). We stop.' )
+      ENDIF
+
+      !  Ocean/land mask at t-point  (computed from ko_top and ko_bot)
+      ! ----------------------------
+      !
+      tmask(:,:,:) = 0._wp
+      DO jj = 1, jpj
+         DO ji = 1, jpi
+            iktop = k_top(ji,jj)
+            ikbot = k_bot(ji,jj)
+            IF( iktop /= 0 ) THEN       ! water in the column
+               tmask(ji,jj,iktop:ikbot  ) = 1._wp
+            ENDIF
+         END DO  
+      END DO  
+!SF  add here lbc_lnk: bug not still understood : cause now domain configuration is read !
+!!gm I don't understand why...  
+      CALL lbc_lnk( tmask  , 'T', 1._wp )      ! Lateral boundary conditions
+
+     ! Mask corrections for bdy (read in mppini2)
+      REWIND( numnam_ref )              ! Namelist nambdy in reference namelist :Unstructured open boundaries
+      READ  ( numnam_ref, nambdy, IOSTAT = ios, ERR = 903)
+903   IF( ios /= 0 )   CALL ctl_nam ( ios , 'nambdy in reference namelist', lwp )
+      REWIND( numnam_cfg )              ! Namelist nambdy in configuration namelist :Unstructured open boundaries
+      READ  ( numnam_cfg, nambdy, IOSTAT = ios, ERR = 904 )
+904   IF( ios >  0 )   CALL ctl_nam ( ios , 'nambdy in configuration namelist', lwp )
+      ! ------------------------
+      IF ( ln_bdy .AND. ln_mask_file ) THEN
+         DO jk = 1, jpkm1
+            DO jj = 1, jpj
+               DO ji = 1, jpi
+                  tmask(ji,jj,jk) = tmask(ji,jj,jk) * bdytmask(ji,jj)
+               END DO
+            END DO
+         END DO
+      ENDIF
+         
+      !  Ocean/land mask at u-, v-, and f-points   (computed from tmask)
+      ! ----------------------------------------
+      ! NB: at this point, fmask is designed for free slip lateral boundary condition
+      DO jk = 1, jpk
+         DO jj = 1, jpjm1
+            DO ji = 1, fs_jpim1   ! vector loop
+               umask(ji,jj,jk) = tmask(ji,jj  ,jk) * tmask(ji+1,jj  ,jk)
+               vmask(ji,jj,jk) = tmask(ji,jj  ,jk) * tmask(ji  ,jj+1,jk)
+            END DO
+            DO ji = 1, jpim1      ! NO vector opt.
+               fmask(ji,jj,jk) = tmask(ji,jj  ,jk) * tmask(ji+1,jj  ,jk)   &
+                  &            * tmask(ji,jj+1,jk) * tmask(ji+1,jj+1,jk)
+            END DO
+         END DO
+      END DO
+      CALL lbc_lnk_multi( umask, 'U', 1., vmask, 'V', 1., fmask, 'F', 1. )      ! Lateral boundary conditions
+ 
+      ! Ocean/land mask at wu-, wv- and w points    (computed from tmask)
+      !-----------------------------------------
+      wmask (:,:,1) = tmask(:,:,1)     ! surface
+      wumask(:,:,1) = umask(:,:,1)
+      wvmask(:,:,1) = vmask(:,:,1)
+      DO jk = 2, jpk                   ! interior values
+         wmask (:,:,jk) = tmask(:,:,jk) * tmask(:,:,jk-1)
+         wumask(:,:,jk) = umask(:,:,jk) * umask(:,:,jk-1)   
+         wvmask(:,:,jk) = vmask(:,:,jk) * vmask(:,:,jk-1)
+      END DO
+
+
+      ! Ocean/land column mask at t-, u-, and v-points   (i.e. at least 1 wet cell in the vertical)
+      ! ----------------------------------------------
+      ssmask (:,:) = MAXVAL( tmask(:,:,:), DIM=3 )
+      ssumask(:,:) = MAXVAL( umask(:,:,:), DIM=3 )
+      ssvmask(:,:) = MAXVAL( vmask(:,:,:), DIM=3 )
+
+
+      ! Interior domain mask  (used for global sum)
+      ! --------------------
+      !
+      iif = nn_hls   ;   iil = nlci - nn_hls + 1
+      ijf = nn_hls   ;   ijl = nlcj - nn_hls + 1
+      !
+      !                          ! halo mask : 0 on the halo and 1 elsewhere
+      tmask_h(:,:) = 1._wp                  
+      tmask_h( 1 :iif,   :   ) = 0._wp      ! first columns
+      tmask_h(iil:jpi,   :   ) = 0._wp      ! last  columns (including mpp extra columns)
+      tmask_h(   :   , 1 :ijf) = 0._wp      ! first rows
+      tmask_h(   :   ,ijl:jpj) = 0._wp      ! last  rows (including mpp extra rows)
+      !
+      !                          ! north fold mask
+      tpol(1:jpiglo) = 1._wp 
+      fpol(1:jpiglo) = 1._wp
+      IF( jperio == 3 .OR. jperio == 4 ) THEN      ! T-point pivot
+         tpol(jpiglo/2+1:jpiglo) = 0._wp
+         fpol(     1    :jpiglo) = 0._wp
+         IF( mjg(nlej) == jpjglo ) THEN                  ! only half of the nlcj-1 row for tmask_h
+            DO ji = iif+1, iil-1
+               tmask_h(ji,nlej-1) = tmask_h(ji,nlej-1) * tpol(mig(ji))
+            END DO
+         ENDIF
+      ENDIF
+      !
+      IF( jperio == 5 .OR. jperio == 6 ) THEN      ! F-point pivot
+         tpol(     1    :jpiglo) = 0._wp
+         fpol(jpiglo/2+1:jpiglo) = 0._wp
+      ENDIF
+      !
+      !                          ! interior mask : 2D ocean mask x halo mask 
+      tmask_i(:,:) = ssmask(:,:) * tmask_h(:,:)
+
+
+      ! Lateral boundary conditions on velocity (modify fmask)
+      ! ---------------------------------------  
+      IF( rn_shlat /= 0 ) THEN      ! Not free-slip lateral boundary condition
+         !
+         ALLOCATE( zwf(jpi,jpj) )
+         !
+         DO jk = 1, jpk
+            zwf(:,:) = fmask(:,:,jk)         
+            DO jj = 2, jpjm1
+               DO ji = fs_2, fs_jpim1   ! vector opt.
+                  IF( fmask(ji,jj,jk) == 0._wp ) THEN
+                     fmask(ji,jj,jk) = rn_shlat * MIN( 1._wp , MAX( zwf(ji+1,jj), zwf(ji,jj+1),   &
+                        &                                           zwf(ji-1,jj), zwf(ji,jj-1)  )  )
+                  ENDIF
+               END DO
+            END DO
+            DO jj = 2, jpjm1
+               IF( fmask(1,jj,jk) == 0._wp ) THEN
+                  fmask(1  ,jj,jk) = rn_shlat * MIN( 1._wp , MAX( zwf(2,jj), zwf(1,jj+1), zwf(1,jj-1) ) )
+               ENDIF
+               IF( fmask(jpi,jj,jk) == 0._wp ) THEN
+                  fmask(jpi,jj,jk) = rn_shlat * MIN( 1._wp , MAX( zwf(jpi,jj+1), zwf(jpim1,jj), zwf(jpi,jj-1) ) )
+               ENDIF
+            END DO         
+            DO ji = 2, jpim1
+               IF( fmask(ji,1,jk) == 0._wp ) THEN
+                  fmask(ji, 1 ,jk) = rn_shlat * MIN( 1._wp , MAX( zwf(ji+1,1), zwf(ji,2), zwf(ji-1,1) ) )
+               ENDIF
+               IF( fmask(ji,jpj,jk) == 0._wp ) THEN
+                  fmask(ji,jpj,jk) = rn_shlat * MIN( 1._wp , MAX( zwf(ji+1,jpj), zwf(ji-1,jpj), zwf(ji,jpjm1) ) )
+               ENDIF
+            END DO
+#if defined key_agrif 
+            IF( .NOT. AGRIF_Root() ) THEN 
+               IF ((nbondi ==  1).OR.(nbondi == 2)) fmask(nlci-1 , :     ,jk) = 0.e0      ! east 
+               IF ((nbondi == -1).OR.(nbondi == 2)) fmask(1      , :     ,jk) = 0.e0      ! west 
+               IF ((nbondj ==  1).OR.(nbondj == 2)) fmask(:      ,nlcj-1 ,jk) = 0.e0      ! north 
+               IF ((nbondj == -1).OR.(nbondj == 2)) fmask(:      ,1      ,jk) = 0.e0      ! south 
+            ENDIF 
+#endif 
+         END DO
+         !
+         DEALLOCATE( zwf )
+         !
+         CALL lbc_lnk( fmask, 'F', 1._wp )      ! Lateral boundary conditions on fmask
+         !
+         ! CAUTION : The fmask may be further modified in dyn_vor_init ( dynvor.F90 ) depending on ln_vorlat
+         !
+      ENDIF
+      
+      ! User defined alteration of fmask (use to reduce ocean transport in specified straits)
+      ! -------------------------------- 
+      !
+      CALL usr_def_fmask( cn_cfg, nn_cfg, fmask )
+      !
+   END SUBROUTINE dom_msk
+   
+   !!======================================================================
+END MODULE dommsk
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DOM/domngb.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DOM/domngb.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DOM/domngb.F90	(revision 9570)
@@ -0,0 +1,79 @@
+MODULE domngb
+   !!======================================================================
+   !!                       ***  MODULE  domngb  ***
+   !! Grid search:  find the closest grid point from a given on/lat position
+   !!======================================================================
+   !! History : 3.2  !  2009-11  (S. Masson)  Original code
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   dom_ngb       : find the closest grid point from a given lon/lat position
+   !!----------------------------------------------------------------------
+   USE dom_oce        ! ocean space and time domain
+   !
+   USE in_out_manager ! I/O manager
+   USE lib_mpp        ! for mppsum
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   dom_ngb   ! routine called in iom.F90 module
+
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO Consortium (2010)
+   !! $Id$ 
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE dom_ngb( plon, plat, kii, kjj, cdgrid, kkk )
+      !!----------------------------------------------------------------------
+      !!                    ***  ROUTINE dom_ngb  ***
+      !!
+      !! ** Purpose :   find the closest grid point from a given lon/lat position
+      !!
+      !! ** Method  :   look for minimum distance in cylindrical projection 
+      !!                -> not good if located at too high latitude...
+      !!----------------------------------------------------------------------
+      REAL(wp)        , INTENT(in   ) ::   plon, plat   ! longitude,latitude of the point
+      INTEGER         , INTENT(  out) ::   kii, kjj     ! i-,j-index of the closes grid point
+      INTEGER         , INTENT(in   ), OPTIONAL :: kkk  ! k-index of the mask level used
+      CHARACTER(len=1), INTENT(in   ) ::   cdgrid       ! grid name 'T', 'U', 'V', 'W'
+      !
+      INTEGER :: ik         ! working level
+      INTEGER , DIMENSION(2) ::   iloc
+      REAL(wp)               ::   zlon, zmini
+      REAL(wp), DIMENSION(jpi,jpj) ::   zglam, zgphi, zmask, zdist
+      !!--------------------------------------------------------------------
+      !
+      zmask(:,:) = 0._wp
+      ik = 1
+      IF ( PRESENT(kkk) ) ik=kkk
+      SELECT CASE( cdgrid )
+      CASE( 'U' )  ; zglam(:,:) = glamu(:,:) ; zgphi(:,:) = gphiu(:,:) ; zmask(nldi:nlei,nldj:nlej) = umask(nldi:nlei,nldj:nlej,ik)
+      CASE( 'V' )  ; zglam(:,:) = glamv(:,:) ; zgphi(:,:) = gphiv(:,:) ; zmask(nldi:nlei,nldj:nlej) = vmask(nldi:nlei,nldj:nlej,ik)
+      CASE( 'F' )  ; zglam(:,:) = glamf(:,:) ; zgphi(:,:) = gphif(:,:) ; zmask(nldi:nlei,nldj:nlej) = fmask(nldi:nlei,nldj:nlej,ik)
+      CASE DEFAULT ; zglam(:,:) = glamt(:,:) ; zgphi(:,:) = gphit(:,:) ; zmask(nldi:nlei,nldj:nlej) = tmask(nldi:nlei,nldj:nlej,ik)
+      END SELECT
+
+      zlon       = MOD( plon       + 720., 360. )                                     ! plon between    0 and 360
+      zglam(:,:) = MOD( zglam(:,:) + 720., 360. )                                     ! glam between    0 and 360
+      IF( zlon > 270. )   zlon = zlon - 360.                                          ! zlon between  -90 and 270
+      IF( zlon <  90. )   WHERE( zglam(:,:) > 180. ) zglam(:,:) = zglam(:,:) - 360.   ! glam between -180 and 180
+      zglam(:,:) = zglam(:,:) - zlon
+
+      zgphi(:,:) = zgphi(:,:) - plat
+      zdist(:,:) = zglam(:,:) * zglam(:,:) + zgphi(:,:) * zgphi(:,:)
+      
+      IF( lk_mpp ) THEN  
+         CALL mpp_minloc( zdist(:,:), zmask, zmini, kii, kjj)
+      ELSE
+         iloc(:) = MINLOC( zdist(:,:), mask = zmask(:,:) == 1.e0 )
+         kii = iloc(1) + nimpp - 1
+         kjj = iloc(2) + njmpp - 1
+      ENDIF
+      !
+   END SUBROUTINE dom_ngb
+
+   !!======================================================================
+END MODULE domngb
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DOM/domvvl.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DOM/domvvl.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DOM/domvvl.F90	(revision 9570)
@@ -0,0 +1,1050 @@
+MODULE domvvl
+   !!======================================================================
+   !!                       ***  MODULE domvvl   ***
+   !! Ocean : 
+   !!======================================================================
+   !! History :  2.0  !  2006-06  (B. Levier, L. Marie)  original code
+   !!            3.1  !  2009-02  (G. Madec, M. Leclair, R. Benshila)  pure z* coordinate
+   !!            3.3  !  2011-10  (M. Leclair) totally rewrote domvvl: vvl option includes z_star and z_tilde coordinates
+   !!            3.6  !  2014-11  (P. Mathiot) add ice shelf capability
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   dom_vvl_init     : define initial vertical scale factors, depths and column thickness
+   !!   dom_vvl_sf_nxt   : Compute next vertical scale factors
+   !!   dom_vvl_sf_swp   : Swap vertical scale factors and update the vertical grid
+   !!   dom_vvl_interpol : Interpolate vertical scale factors from one grid point to another
+   !!   dom_vvl_rst      : read/write restart file
+   !!   dom_vvl_ctl      : Check the vvl options
+   !!----------------------------------------------------------------------
+   USE oce             ! ocean dynamics and tracers
+   USE phycst          ! physical constant
+   USE dom_oce         ! ocean space and time domain
+   USE sbc_oce         ! ocean surface boundary condition
+   USE wet_dry         ! wetting and drying
+   USE usrdef_istate   ! user defined initial state (wad only)
+   USE restart         ! ocean restart
+   !
+   USE in_out_manager  ! I/O manager
+   USE iom             ! I/O manager library
+   USE lib_mpp         ! distributed memory computing library
+   USE lbclnk          ! ocean lateral boundary conditions (or mpp link)
+   USE timing          ! Timing
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC  dom_vvl_init       ! called by domain.F90
+   PUBLIC  dom_vvl_sf_nxt     ! called by step.F90
+   PUBLIC  dom_vvl_sf_swp     ! called by step.F90
+   PUBLIC  dom_vvl_interpol   ! called by dynnxt.F90
+
+   !                                                      !!* Namelist nam_vvl
+   LOGICAL , PUBLIC :: ln_vvl_zstar           = .FALSE.    ! zstar  vertical coordinate
+   LOGICAL , PUBLIC :: ln_vvl_ztilde          = .FALSE.    ! ztilde vertical coordinate
+   LOGICAL , PUBLIC :: ln_vvl_layer           = .FALSE.    ! level  vertical coordinate
+   LOGICAL , PUBLIC :: ln_vvl_ztilde_as_zstar = .FALSE.    ! ztilde vertical coordinate
+   LOGICAL , PUBLIC :: ln_vvl_zstar_at_eqtor  = .FALSE.    ! ztilde vertical coordinate
+   LOGICAL , PUBLIC :: ln_vvl_kepe            = .FALSE.    ! kinetic/potential energy transfer
+   !                                                       ! conservation: not used yet
+   REAL(wp)         :: rn_ahe3                             ! thickness diffusion coefficient
+   REAL(wp)         :: rn_rst_e3t                          ! ztilde to zstar restoration timescale [days]
+   REAL(wp)         :: rn_lf_cutoff                        ! cutoff frequency for low-pass filter  [days]
+   REAL(wp)         :: rn_zdef_max                         ! maximum fractional e3t deformation
+   LOGICAL , PUBLIC :: ln_vvl_dbg = .FALSE.                ! debug control prints
+
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: un_td, vn_td                ! thickness diffusion transport
+   REAL(wp)        , ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: hdiv_lf                     ! low frequency part of hz divergence
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: tilde_e3t_b, tilde_e3t_n    ! baroclinic scale factors
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: tilde_e3t_a, dtilde_e3t_a   ! baroclinic scale factors
+   REAL(wp)        , ALLOCATABLE, SAVE, DIMENSION(:,:)   :: frq_rst_e3t                 ! retoring period for scale factors
+   REAL(wp)        , ALLOCATABLE, SAVE, DIMENSION(:,:)   :: frq_rst_hdv                 ! retoring period for low freq. divergence
+
+   !! * Substitutions
+#  include "vectopt_loop_substitute.h90"
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.7 , NEMO-Consortium (2015) 
+   !! $Id$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   INTEGER FUNCTION dom_vvl_alloc()
+      !!----------------------------------------------------------------------
+      !!                ***  FUNCTION dom_vvl_alloc  ***
+      !!----------------------------------------------------------------------
+      IF( ln_vvl_zstar )   dom_vvl_alloc = 0
+      IF( ln_vvl_ztilde .OR. ln_vvl_layer ) THEN
+         ALLOCATE( tilde_e3t_b(jpi,jpj,jpk)  , tilde_e3t_n(jpi,jpj,jpk) , tilde_e3t_a(jpi,jpj,jpk) ,   &
+            &      dtilde_e3t_a(jpi,jpj,jpk) , un_td  (jpi,jpj,jpk)     , vn_td  (jpi,jpj,jpk)     ,   &
+            &      STAT = dom_vvl_alloc        )
+         IF( lk_mpp             )   CALL mpp_sum ( dom_vvl_alloc )
+         IF( dom_vvl_alloc /= 0 )   CALL ctl_warn('dom_vvl_alloc: failed to allocate arrays')
+         un_td = 0._wp
+         vn_td = 0._wp
+      ENDIF
+      IF( ln_vvl_ztilde ) THEN
+         ALLOCATE( frq_rst_e3t(jpi,jpj) , frq_rst_hdv(jpi,jpj) , hdiv_lf(jpi,jpj,jpk) , STAT= dom_vvl_alloc )
+         IF( lk_mpp             )   CALL mpp_sum ( dom_vvl_alloc )
+         IF( dom_vvl_alloc /= 0 )   CALL ctl_warn('dom_vvl_alloc: failed to allocate arrays')
+      ENDIF
+      !
+   END FUNCTION dom_vvl_alloc
+
+
+   SUBROUTINE dom_vvl_init
+      !!----------------------------------------------------------------------
+      !!                ***  ROUTINE dom_vvl_init  ***
+      !!                   
+      !! ** Purpose :  Initialization of all scale factors, depths
+      !!               and water column heights
+      !!
+      !! ** Method  :  - use restart file and/or initialize
+      !!               - interpolate scale factors
+      !!
+      !! ** Action  : - e3t_(n/b) and tilde_e3t_(n/b)
+      !!              - Regrid: e3(u/v)_n
+      !!                        e3(u/v)_b       
+      !!                        e3w_n           
+      !!                        e3(u/v)w_b      
+      !!                        e3(u/v)w_n      
+      !!                        gdept_n, gdepw_n and gde3w_n
+      !!              - h(t/u/v)_0
+      !!              - frq_rst_e3t and frq_rst_hdv
+      !!
+      !! Reference  : Leclair, M., and G. Madec, 2011, Ocean Modelling.
+      !!----------------------------------------------------------------------
+      INTEGER ::   ji, jj, jk
+      INTEGER ::   ii0, ii1, ij0, ij1
+      REAL(wp)::   zcoef
+      !!----------------------------------------------------------------------
+      !
+      IF(lwp) WRITE(numout,*)
+      IF(lwp) WRITE(numout,*) 'dom_vvl_init : Variable volume activated'
+      IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~'
+      !
+      CALL dom_vvl_ctl     ! choose vertical coordinate (z_star, z_tilde or layer)
+      !
+      !                    ! Allocate module arrays
+      IF( dom_vvl_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'dom_vvl_init : unable to allocate arrays' )
+      !
+      !                    ! Read or initialize e3t_(b/n), tilde_e3t_(b/n) and hdiv_lf
+      CALL dom_vvl_rst( nit000, 'READ' )
+      e3t_a(:,:,jpk) = e3t_0(:,:,jpk)  ! last level always inside the sea floor set one for all
+      !
+      !                    !== Set of all other vertical scale factors  ==!  (now and before)
+      !                                ! Horizontal interpolation of e3t
+      CALL dom_vvl_interpol( e3t_b(:,:,:), e3u_b(:,:,:), 'U' )    ! from T to U
+      CALL dom_vvl_interpol( e3t_n(:,:,:), e3u_n(:,:,:), 'U' )
+      CALL dom_vvl_interpol( e3t_b(:,:,:), e3v_b(:,:,:), 'V' )    ! from T to V 
+      CALL dom_vvl_interpol( e3t_n(:,:,:), e3v_n(:,:,:), 'V' )
+      CALL dom_vvl_interpol( e3u_n(:,:,:), e3f_n(:,:,:), 'F' )    ! from U to F
+      !                                ! Vertical interpolation of e3t,u,v 
+      CALL dom_vvl_interpol( e3t_n(:,:,:), e3w_n (:,:,:), 'W'  )  ! from T to W
+      CALL dom_vvl_interpol( e3t_b(:,:,:), e3w_b (:,:,:), 'W'  )
+      CALL dom_vvl_interpol( e3u_n(:,:,:), e3uw_n(:,:,:), 'UW' )  ! from U to UW
+      CALL dom_vvl_interpol( e3u_b(:,:,:), e3uw_b(:,:,:), 'UW' )
+      CALL dom_vvl_interpol( e3v_n(:,:,:), e3vw_n(:,:,:), 'VW' )  ! from V to UW
+      CALL dom_vvl_interpol( e3v_b(:,:,:), e3vw_b(:,:,:), 'VW' )
+
+      ! We need to define e3[tuv]_a for AGRIF initialisation (should not be a problem for the restartability...)
+      e3t_a(:,:,:) = e3t_n(:,:,:)
+      e3u_a(:,:,:) = e3u_n(:,:,:)
+      e3v_a(:,:,:) = e3v_n(:,:,:)
+      !
+      !                    !==  depth of t and w-point  ==!   (set the isf depth as it is in the initial timestep)
+      gdept_n(:,:,1) = 0.5_wp * e3w_n(:,:,1)       ! reference to the ocean surface (used for MLD and light penetration)
+      gdepw_n(:,:,1) = 0.0_wp
+      gde3w_n(:,:,1) = gdept_n(:,:,1) - sshn(:,:)  ! reference to a common level z=0 for hpg
+      gdept_b(:,:,1) = 0.5_wp * e3w_b(:,:,1)
+      gdepw_b(:,:,1) = 0.0_wp
+      DO jk = 2, jpk                               ! vertical sum
+         DO jj = 1,jpj
+            DO ji = 1,jpi
+               !    zcoef = tmask - wmask    ! 0 everywhere tmask = wmask, ie everywhere expect at jk = mikt
+               !                             ! 1 everywhere from mbkt to mikt + 1 or 1 (if no isf)
+               !                             ! 0.5 where jk = mikt     
+!!gm ???????   BUG ?  gdept_n as well as gde3w_n  does not include the thickness of ISF ??
+               zcoef = ( tmask(ji,jj,jk) - wmask(ji,jj,jk) )
+               gdepw_n(ji,jj,jk) = gdepw_n(ji,jj,jk-1) + e3t_n(ji,jj,jk-1)
+               gdept_n(ji,jj,jk) =      zcoef  * ( gdepw_n(ji,jj,jk  ) + 0.5 * e3w_n(ji,jj,jk))  &
+                  &                + (1-zcoef) * ( gdept_n(ji,jj,jk-1) +       e3w_n(ji,jj,jk)) 
+               gde3w_n(ji,jj,jk) = gdept_n(ji,jj,jk) - sshn(ji,jj)
+               gdepw_b(ji,jj,jk) = gdepw_b(ji,jj,jk-1) + e3t_b(ji,jj,jk-1)
+               gdept_b(ji,jj,jk) =      zcoef  * ( gdepw_b(ji,jj,jk  ) + 0.5 * e3w_b(ji,jj,jk))  &
+                  &                + (1-zcoef) * ( gdept_b(ji,jj,jk-1) +       e3w_b(ji,jj,jk)) 
+            END DO
+         END DO
+      END DO
+      !
+      !                    !==  thickness of the water column  !!   (ocean portion only)
+      ht_n(:,:) = e3t_n(:,:,1) * tmask(:,:,1)   !!gm  BUG  :  this should be 1/2 * e3w(k=1) ....
+      hu_b(:,:) = e3u_b(:,:,1) * umask(:,:,1)
+      hu_n(:,:) = e3u_n(:,:,1) * umask(:,:,1)
+      hv_b(:,:) = e3v_b(:,:,1) * vmask(:,:,1)
+      hv_n(:,:) = e3v_n(:,:,1) * vmask(:,:,1)
+      DO jk = 2, jpkm1
+         ht_n(:,:) = ht_n(:,:) + e3t_n(:,:,jk) * tmask(:,:,jk)
+         hu_b(:,:) = hu_b(:,:) + e3u_b(:,:,jk) * umask(:,:,jk)
+         hu_n(:,:) = hu_n(:,:) + e3u_n(:,:,jk) * umask(:,:,jk)
+         hv_b(:,:) = hv_b(:,:) + e3v_b(:,:,jk) * vmask(:,:,jk)
+         hv_n(:,:) = hv_n(:,:) + e3v_n(:,:,jk) * vmask(:,:,jk)
+      END DO
+      !
+      !                    !==  inverse of water column thickness   ==!   (u- and v- points)
+      r1_hu_b(:,:) = ssumask(:,:) / ( hu_b(:,:) + 1._wp - ssumask(:,:) )    ! _i mask due to ISF
+      r1_hu_n(:,:) = ssumask(:,:) / ( hu_n(:,:) + 1._wp - ssumask(:,:) )
+      r1_hv_b(:,:) = ssvmask(:,:) / ( hv_b(:,:) + 1._wp - ssvmask(:,:) )
+      r1_hv_n(:,:) = ssvmask(:,:) / ( hv_n(:,:) + 1._wp - ssvmask(:,:) )
+
+      !                    !==   z_tilde coordinate case  ==!   (Restoring frequencies)
+      IF( ln_vvl_ztilde ) THEN
+!!gm : idea: add here a READ in a file of custumized restoring frequency
+         !                                   ! Values in days provided via the namelist
+         !                                   ! use rsmall to avoid possible division by zero errors with faulty settings
+         frq_rst_e3t(:,:) = 2._wp * rpi / ( MAX( rn_rst_e3t  , rsmall ) * 86400.0_wp )
+         frq_rst_hdv(:,:) = 2._wp * rpi / ( MAX( rn_lf_cutoff, rsmall ) * 86400.0_wp )
+         !
+         IF( ln_vvl_ztilde_as_zstar ) THEN   ! z-star emulation using z-tile
+            frq_rst_e3t(:,:) = 0._wp               !Ignore namelist settings
+            frq_rst_hdv(:,:) = 1._wp / rdt
+         ENDIF
+         IF ( ln_vvl_zstar_at_eqtor ) THEN   ! use z-star in vicinity of the Equator
+            DO jj = 1, jpj
+               DO ji = 1, jpi
+!!gm  case |gphi| >= 6 degrees is useless   initialized just above by default
+                  IF( ABS(gphit(ji,jj)) >= 6.) THEN
+                     ! values outside the equatorial band and transition zone (ztilde)
+                     frq_rst_e3t(ji,jj) =  2.0_wp * rpi / ( MAX( rn_rst_e3t  , rsmall ) * 86400.e0_wp )
+                     frq_rst_hdv(ji,jj) =  2.0_wp * rpi / ( MAX( rn_lf_cutoff, rsmall ) * 86400.e0_wp )
+                  ELSEIF( ABS(gphit(ji,jj)) <= 2.5) THEN    ! Equator strip ==> z-star
+                     ! values inside the equatorial band (ztilde as zstar)
+                     frq_rst_e3t(ji,jj) =  0.0_wp
+                     frq_rst_hdv(ji,jj) =  1.0_wp / rdt
+                  ELSE                                      ! transition band (2.5 to 6 degrees N/S)
+                     !                                      ! (linearly transition from z-tilde to z-star)
+                     frq_rst_e3t(ji,jj) = 0.0_wp + (frq_rst_e3t(ji,jj)-0.0_wp)*0.5_wp   &
+                        &            * (  1.0_wp - COS( rad*(ABS(gphit(ji,jj))-2.5_wp)  &
+                        &                                          * 180._wp / 3.5_wp ) )
+                     frq_rst_hdv(ji,jj) = (1.0_wp / rdt)                                &
+                        &            + (  frq_rst_hdv(ji,jj)-(1.e0_wp / rdt) )*0.5_wp   &
+                        &            * (  1._wp  - COS( rad*(ABS(gphit(ji,jj))-2.5_wp)  &
+                        &                                          * 180._wp / 3.5_wp ) )
+                  ENDIF
+               END DO
+            END DO
+            IF( cn_cfg == "orca" .AND. nn_cfg == 3 ) THEN   ! ORCA2: Suppress ztilde in the Foxe Basin for ORCA2
+               ii0 = 103   ;   ii1 = 111       
+               ij0 = 128   ;   ij1 = 135   ;   
+               frq_rst_e3t( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) =  0.0_wp
+               frq_rst_hdv( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) =  1.e0_wp / rdt
+            ENDIF
+         ENDIF
+      ENDIF
+      !
+      IF(lwxios) THEN
+! define variables in restart file when writing with XIOS
+         CALL iom_set_rstw_var_active('e3t_b')
+         CALL iom_set_rstw_var_active('e3t_n')
+         !                                           ! ----------------------- !
+         IF( ln_vvl_ztilde .OR. ln_vvl_layer ) THEN  ! z_tilde and layer cases !
+            !                                        ! ----------------------- !
+            CALL iom_set_rstw_var_active('tilde_e3t_b')
+            CALL iom_set_rstw_var_active('tilde_e3t_n')
+         END IF
+         !                                           ! -------------!    
+         IF( ln_vvl_ztilde ) THEN                    ! z_tilde case !
+            !                                        ! ------------ !
+            CALL iom_set_rstw_var_active('hdiv_lf')
+         ENDIF
+         !
+      ENDIF
+      !
+   END SUBROUTINE dom_vvl_init
+
+
+   SUBROUTINE dom_vvl_sf_nxt( kt, kcall ) 
+      !!----------------------------------------------------------------------
+      !!                ***  ROUTINE dom_vvl_sf_nxt  ***
+      !!                   
+      !! ** Purpose :  - compute the after scale factors used in tra_zdf, dynnxt,
+      !!                 tranxt and dynspg routines
+      !!
+      !! ** Method  :  - z_star case:  Repartition of ssh INCREMENT proportionnaly to the level thickness.
+      !!               - z_tilde_case: after scale factor increment = 
+      !!                                    high frequency part of horizontal divergence
+      !!                                  + retsoring towards the background grid
+      !!                                  + thickness difusion
+      !!                               Then repartition of ssh INCREMENT proportionnaly
+      !!                               to the "baroclinic" level thickness.
+      !!
+      !! ** Action  :  - hdiv_lf    : restoring towards full baroclinic divergence in z_tilde case
+      !!               - tilde_e3t_a: after increment of vertical scale factor 
+      !!                              in z_tilde case
+      !!               - e3(t/u/v)_a
+      !!
+      !! Reference  : Leclair, M., and Madec, G. 2011, Ocean Modelling.
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT( in )           ::   kt      ! time step
+      INTEGER, INTENT( in ), OPTIONAL ::   kcall   ! optional argument indicating call sequence
+      !
+      INTEGER                ::   ji, jj, jk            ! dummy loop indices
+      INTEGER , DIMENSION(3) ::   ijk_max, ijk_min      ! temporary integers
+      REAL(wp)               ::   z2dt, z_tmin, z_tmax  ! local scalars
+      LOGICAL                ::   ll_do_bclinic         ! local logical
+      REAL(wp), DIMENSION(jpi,jpj)     ::   zht, z_scale, zwu, zwv, zhdiv
+      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   ze3t
+      !!----------------------------------------------------------------------
+      !
+      IF( ln_linssh )   RETURN      ! No calculation in linear free surface
+      !
+      IF( ln_timing )   CALL timing_start('dom_vvl_sf_nxt')
+      !
+      IF( kt == nit000 ) THEN
+         IF(lwp) WRITE(numout,*)
+         IF(lwp) WRITE(numout,*) 'dom_vvl_sf_nxt : compute after scale factors'
+         IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~~'
+      ENDIF
+
+      ll_do_bclinic = .TRUE.
+      IF( PRESENT(kcall) ) THEN
+         IF( kcall == 2 .AND. ln_vvl_ztilde )   ll_do_bclinic = .FALSE.
+      ENDIF
+
+      ! ******************************* !
+      ! After acale factors at t-points !
+      ! ******************************* !
+      !                                                ! --------------------------------------------- !
+      !                                                ! z_star coordinate and barotropic z-tilde part !
+      !                                                ! --------------------------------------------- !
+      !
+      z_scale(:,:) = ( ssha(:,:) - sshb(:,:) ) * ssmask(:,:) / ( ht_0(:,:) + sshn(:,:) + 1. - ssmask(:,:) )
+      DO jk = 1, jpkm1
+         ! formally this is the same as e3t_a = e3t_0*(1+ssha/ht_0)
+         e3t_a(:,:,jk) = e3t_b(:,:,jk) + e3t_n(:,:,jk) * z_scale(:,:) * tmask(:,:,jk)
+      END DO
+      !
+      IF( ln_vvl_ztilde .OR. ln_vvl_layer .AND. ll_do_bclinic ) THEN   ! z_tilde or layer coordinate !
+         !                                                            ! ------baroclinic part------ !
+         ! I - initialization
+         ! ==================
+
+         ! 1 - barotropic divergence
+         ! -------------------------
+         zhdiv(:,:) = 0._wp
+         zht(:,:)   = 0._wp
+         DO jk = 1, jpkm1
+            zhdiv(:,:) = zhdiv(:,:) + e3t_n(:,:,jk) * hdivn(:,:,jk)
+            zht  (:,:) = zht  (:,:) + e3t_n(:,:,jk) * tmask(:,:,jk)
+         END DO
+         zhdiv(:,:) = zhdiv(:,:) / ( zht(:,:) + 1. - tmask_i(:,:) )
+
+         ! 2 - Low frequency baroclinic horizontal divergence  (z-tilde case only)
+         ! --------------------------------------------------
+         IF( ln_vvl_ztilde ) THEN
+            IF( kt > nit000 ) THEN
+               DO jk = 1, jpkm1
+                  hdiv_lf(:,:,jk) = hdiv_lf(:,:,jk) - rdt * frq_rst_hdv(:,:)   &
+                     &          * ( hdiv_lf(:,:,jk) - e3t_n(:,:,jk) * ( hdivn(:,:,jk) - zhdiv(:,:) ) )
+               END DO
+            ENDIF
+         ENDIF
+
+         ! II - after z_tilde increments of vertical scale factors
+         ! =======================================================
+         tilde_e3t_a(:,:,:) = 0._wp  ! tilde_e3t_a used to store tendency terms
+
+         ! 1 - High frequency divergence term
+         ! ----------------------------------
+         IF( ln_vvl_ztilde ) THEN     ! z_tilde case
+            DO jk = 1, jpkm1
+               tilde_e3t_a(:,:,jk) = tilde_e3t_a(:,:,jk) - ( e3t_n(:,:,jk) * ( hdivn(:,:,jk) - zhdiv(:,:) ) - hdiv_lf(:,:,jk) )
+            END DO
+         ELSE                         ! layer case
+            DO jk = 1, jpkm1
+               tilde_e3t_a(:,:,jk) = tilde_e3t_a(:,:,jk) -   e3t_n(:,:,jk) * ( hdivn(:,:,jk) - zhdiv(:,:) ) * tmask(:,:,jk)
+            END DO
+         ENDIF
+
+         ! 2 - Restoring term (z-tilde case only)
+         ! ------------------
+         IF( ln_vvl_ztilde ) THEN
+            DO jk = 1, jpk
+               tilde_e3t_a(:,:,jk) = tilde_e3t_a(:,:,jk) - frq_rst_e3t(:,:) * tilde_e3t_b(:,:,jk)
+            END DO
+         ENDIF
+
+         ! 3 - Thickness diffusion term
+         ! ----------------------------
+         zwu(:,:) = 0._wp
+         zwv(:,:) = 0._wp
+         DO jk = 1, jpkm1        ! a - first derivative: diffusive fluxes
+            DO jj = 1, jpjm1
+               DO ji = 1, fs_jpim1   ! vector opt.
+                  un_td(ji,jj,jk) = rn_ahe3 * umask(ji,jj,jk) * e2_e1u(ji,jj)           &
+                     &            * ( tilde_e3t_b(ji,jj,jk) - tilde_e3t_b(ji+1,jj  ,jk) )
+                  vn_td(ji,jj,jk) = rn_ahe3 * vmask(ji,jj,jk) * e1_e2v(ji,jj)           & 
+                     &            * ( tilde_e3t_b(ji,jj,jk) - tilde_e3t_b(ji  ,jj+1,jk) )
+                  zwu(ji,jj) = zwu(ji,jj) + un_td(ji,jj,jk)
+                  zwv(ji,jj) = zwv(ji,jj) + vn_td(ji,jj,jk)
+               END DO
+            END DO
+         END DO
+         DO jj = 1, jpj          ! b - correction for last oceanic u-v points
+            DO ji = 1, jpi
+               un_td(ji,jj,mbku(ji,jj)) = un_td(ji,jj,mbku(ji,jj)) - zwu(ji,jj)
+               vn_td(ji,jj,mbkv(ji,jj)) = vn_td(ji,jj,mbkv(ji,jj)) - zwv(ji,jj)
+            END DO
+         END DO
+         DO jk = 1, jpkm1        ! c - second derivative: divergence of diffusive fluxes
+            DO jj = 2, jpjm1
+               DO ji = fs_2, fs_jpim1   ! vector opt.
+                  tilde_e3t_a(ji,jj,jk) = tilde_e3t_a(ji,jj,jk) + (   un_td(ji-1,jj  ,jk) - un_td(ji,jj,jk)    &
+                     &                                          +     vn_td(ji  ,jj-1,jk) - vn_td(ji,jj,jk)    &
+                     &                                            ) * r1_e1e2t(ji,jj)
+               END DO
+            END DO
+         END DO
+         !                       ! d - thickness diffusion transport: boundary conditions
+         !                             (stored for tracer advction and continuity equation)
+         CALL lbc_lnk_multi( un_td , 'U' , -1._wp, vn_td , 'V' , -1._wp)
+
+         ! 4 - Time stepping of baroclinic scale factors
+         ! ---------------------------------------------
+         ! Leapfrog time stepping
+         ! ~~~~~~~~~~~~~~~~~~~~~~
+         IF( neuler == 0 .AND. kt == nit000 ) THEN
+            z2dt =  rdt
+         ELSE
+            z2dt = 2.0_wp * rdt
+         ENDIF
+         CALL lbc_lnk( tilde_e3t_a(:,:,:), 'T', 1._wp )
+         tilde_e3t_a(:,:,:) = tilde_e3t_b(:,:,:) + z2dt * tmask(:,:,:) * tilde_e3t_a(:,:,:)
+
+         ! Maximum deformation control
+         ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~
+         ze3t(:,:,jpk) = 0._wp
+         DO jk = 1, jpkm1
+            ze3t(:,:,jk) = tilde_e3t_a(:,:,jk) / e3t_0(:,:,jk) * tmask(:,:,jk) * tmask_i(:,:)
+         END DO
+         z_tmax = MAXVAL( ze3t(:,:,:) )
+         IF( lk_mpp )   CALL mpp_max( z_tmax )                 ! max over the global domain
+         z_tmin = MINVAL( ze3t(:,:,:) )
+         IF( lk_mpp )   CALL mpp_min( z_tmin )                 ! min over the global domain
+         ! - ML - test: for the moment, stop simulation for too large e3_t variations
+         IF( ( z_tmax >  rn_zdef_max ) .OR. ( z_tmin < - rn_zdef_max ) ) THEN
+            IF( lk_mpp ) THEN
+               CALL mpp_maxloc( ze3t, tmask, z_tmax, ijk_max(1), ijk_max(2), ijk_max(3) )
+               CALL mpp_minloc( ze3t, tmask, z_tmin, ijk_min(1), ijk_min(2), ijk_min(3) )
+            ELSE
+               ijk_max = MAXLOC( ze3t(:,:,:) )
+               ijk_max(1) = ijk_max(1) + nimpp - 1
+               ijk_max(2) = ijk_max(2) + njmpp - 1
+               ijk_min = MINLOC( ze3t(:,:,:) )
+               ijk_min(1) = ijk_min(1) + nimpp - 1
+               ijk_min(2) = ijk_min(2) + njmpp - 1
+            ENDIF
+            IF (lwp) THEN
+               WRITE(numout, *) 'MAX( tilde_e3t_a(:,:,:) / e3t_0(:,:,:) ) =', z_tmax
+               WRITE(numout, *) 'at i, j, k=', ijk_max
+               WRITE(numout, *) 'MIN( tilde_e3t_a(:,:,:) / e3t_0(:,:,:) ) =', z_tmin
+               WRITE(numout, *) 'at i, j, k=', ijk_min            
+               CALL ctl_warn('MAX( ABS( tilde_e3t_a(:,:,:) ) / e3t_0(:,:,:) ) too high')
+            ENDIF
+         ENDIF
+         ! - ML - end test
+         ! - ML - Imposing these limits will cause a baroclinicity error which is corrected for below
+         tilde_e3t_a(:,:,:) = MIN( tilde_e3t_a(:,:,:),   rn_zdef_max * e3t_0(:,:,:) )
+         tilde_e3t_a(:,:,:) = MAX( tilde_e3t_a(:,:,:), - rn_zdef_max * e3t_0(:,:,:) )
+
+         !
+         ! "tilda" change in the after scale factor
+         ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+         DO jk = 1, jpkm1
+            dtilde_e3t_a(:,:,jk) = tilde_e3t_a(:,:,jk) - tilde_e3t_b(:,:,jk)
+         END DO
+         ! III - Barotropic repartition of the sea surface height over the baroclinic profile
+         ! ==================================================================================
+         ! add ( ssh increment + "baroclinicity error" ) proportionly to e3t(n)
+         ! - ML - baroclinicity error should be better treated in the future
+         !        i.e. locally and not spread over the water column.
+         !        (keep in mind that the idea is to reduce Eulerian velocity as much as possible)
+         zht(:,:) = 0.
+         DO jk = 1, jpkm1
+            zht(:,:)  = zht(:,:) + tilde_e3t_a(:,:,jk) * tmask(:,:,jk)
+         END DO
+         z_scale(:,:) =  - zht(:,:) / ( ht_0(:,:) + sshn(:,:) + 1. - ssmask(:,:) )
+         DO jk = 1, jpkm1
+            dtilde_e3t_a(:,:,jk) = dtilde_e3t_a(:,:,jk) + e3t_n(:,:,jk) * z_scale(:,:) * tmask(:,:,jk)
+         END DO
+
+      ENDIF
+
+      IF( ln_vvl_ztilde .OR. ln_vvl_layer )  THEN   ! z_tilde or layer coordinate !
+      !                                           ! ---baroclinic part--------- !
+         DO jk = 1, jpkm1
+            e3t_a(:,:,jk) = e3t_a(:,:,jk) + dtilde_e3t_a(:,:,jk) * tmask(:,:,jk)
+         END DO
+      ENDIF
+
+      IF( ln_vvl_dbg .AND. .NOT. ll_do_bclinic ) THEN   ! - ML - test: control prints for debuging
+         !
+         IF( lwp ) WRITE(numout, *) 'kt =', kt
+         IF ( ln_vvl_ztilde .OR. ln_vvl_layer ) THEN
+            z_tmax = MAXVAL( tmask(:,:,1) * tmask_i(:,:) * ABS( zht(:,:) ) )
+            IF( lk_mpp ) CALL mpp_max( z_tmax )                             ! max over the global domain
+            IF( lwp    ) WRITE(numout, *) kt,' MAXVAL(abs(SUM(tilde_e3t_a))) =', z_tmax
+         END IF
+         !
+         zht(:,:) = 0.0_wp
+         DO jk = 1, jpkm1
+            zht(:,:) = zht(:,:) + e3t_n(:,:,jk) * tmask(:,:,jk)
+         END DO
+         z_tmax = MAXVAL( tmask(:,:,1) * tmask_i(:,:) * ABS( ht_0(:,:) + sshn(:,:) - zht(:,:) ) )
+         IF( lk_mpp ) CALL mpp_max( z_tmax )                                ! max over the global domain
+         IF( lwp    ) WRITE(numout, *) kt,' MAXVAL(abs(ht_0+sshn-SUM(e3t_n))) =', z_tmax
+         !
+         zht(:,:) = 0.0_wp
+         DO jk = 1, jpkm1
+            zht(:,:) = zht(:,:) + e3t_a(:,:,jk) * tmask(:,:,jk)
+         END DO
+         z_tmax = MAXVAL( tmask(:,:,1) * tmask_i(:,:) * ABS( ht_0(:,:) + ssha(:,:) - zht(:,:) ) )
+         IF( lk_mpp ) CALL mpp_max( z_tmax )                                ! max over the global domain
+         IF( lwp    ) WRITE(numout, *) kt,' MAXVAL(abs(ht_0+ssha-SUM(e3t_a))) =', z_tmax
+         !
+         zht(:,:) = 0.0_wp
+         DO jk = 1, jpkm1
+            zht(:,:) = zht(:,:) + e3t_b(:,:,jk) * tmask(:,:,jk)
+         END DO
+         z_tmax = MAXVAL( tmask(:,:,1) * tmask_i(:,:) * ABS( ht_0(:,:) + sshb(:,:) - zht(:,:) ) )
+         IF( lk_mpp ) CALL mpp_max( z_tmax )                                ! max over the global domain
+         IF( lwp    ) WRITE(numout, *) kt,' MAXVAL(abs(ht_0+sshb-SUM(e3t_b))) =', z_tmax
+         !
+         z_tmax = MAXVAL( tmask(:,:,1) *  ABS( sshb(:,:) ) )
+         IF( lk_mpp ) CALL mpp_max( z_tmax )                                ! max over the global domain
+         IF( lwp    ) WRITE(numout, *) kt,' MAXVAL(abs(sshb))) =', z_tmax
+         !
+         z_tmax = MAXVAL( tmask(:,:,1) *  ABS( sshn(:,:) ) )
+         IF( lk_mpp ) CALL mpp_max( z_tmax )                                ! max over the global domain
+         IF( lwp    ) WRITE(numout, *) kt,' MAXVAL(abs(sshn))) =', z_tmax
+         !
+         z_tmax = MAXVAL( tmask(:,:,1) *  ABS( ssha(:,:) ) )
+         IF( lk_mpp ) CALL mpp_max( z_tmax )                                ! max over the global domain
+         IF( lwp    ) WRITE(numout, *) kt,' MAXVAL(abs(ssha))) =', z_tmax
+      END IF
+
+      ! *********************************** !
+      ! After scale factors at u- v- points !
+      ! *********************************** !
+
+      CALL dom_vvl_interpol( e3t_a(:,:,:), e3u_a(:,:,:), 'U' )
+      CALL dom_vvl_interpol( e3t_a(:,:,:), e3v_a(:,:,:), 'V' )
+
+      ! *********************************** !
+      ! After depths at u- v points         !
+      ! *********************************** !
+
+      hu_a(:,:) = e3u_a(:,:,1) * umask(:,:,1)
+      hv_a(:,:) = e3v_a(:,:,1) * vmask(:,:,1)
+      DO jk = 2, jpkm1
+         hu_a(:,:) = hu_a(:,:) + e3u_a(:,:,jk) * umask(:,:,jk)
+         hv_a(:,:) = hv_a(:,:) + e3v_a(:,:,jk) * vmask(:,:,jk)
+      END DO
+      !                                        ! Inverse of the local depth
+!!gm BUG ?  don't understand the use of umask_i here .....
+      r1_hu_a(:,:) = ssumask(:,:) / ( hu_a(:,:) + 1._wp - ssumask(:,:) )
+      r1_hv_a(:,:) = ssvmask(:,:) / ( hv_a(:,:) + 1._wp - ssvmask(:,:) )
+      !
+      IF( ln_timing )   CALL timing_stop('dom_vvl_sf_nxt')
+      !
+   END SUBROUTINE dom_vvl_sf_nxt
+
+
+   SUBROUTINE dom_vvl_sf_swp( kt )
+      !!----------------------------------------------------------------------
+      !!                ***  ROUTINE dom_vvl_sf_swp  ***
+      !!                   
+      !! ** Purpose :  compute time filter and swap of scale factors 
+      !!               compute all depths and related variables for next time step
+      !!               write outputs and restart file
+      !!
+      !! ** Method  :  - swap of e3t with trick for volume/tracer conservation
+      !!               - reconstruct scale factor at other grid points (interpolate)
+      !!               - recompute depths and water height fields
+      !!
+      !! ** Action  :  - e3t_(b/n), tilde_e3t_(b/n) and e3(u/v)_n ready for next time step
+      !!               - Recompute:
+      !!                    e3(u/v)_b       
+      !!                    e3w_n           
+      !!                    e3(u/v)w_b      
+      !!                    e3(u/v)w_n      
+      !!                    gdept_n, gdepw_n  and gde3w_n
+      !!                    h(u/v) and h(u/v)r
+      !!
+      !! Reference  : Leclair, M., and G. Madec, 2009, Ocean Modelling.
+      !!              Leclair, M., and G. Madec, 2011, Ocean Modelling.
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT( in ) ::   kt   ! time step
+      !
+      INTEGER  ::   ji, jj, jk   ! dummy loop indices
+      REAL(wp) ::   zcoef        ! local scalar
+      !!----------------------------------------------------------------------
+      !
+      IF( ln_linssh )   RETURN      ! No calculation in linear free surface
+      !
+      IF( ln_timing )   CALL timing_start('dom_vvl_sf_swp')
+      !
+      IF( kt == nit000 )   THEN
+         IF(lwp) WRITE(numout,*)
+         IF(lwp) WRITE(numout,*) 'dom_vvl_sf_swp : - time filter and swap of scale factors'
+         IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~~   - interpolate scale factors and compute depths for next time step'
+      ENDIF
+      !
+      ! Time filter and swap of scale factors
+      ! =====================================
+      ! - ML - e3(t/u/v)_b are allready computed in dynnxt.
+      IF( ln_vvl_ztilde .OR. ln_vvl_layer ) THEN
+         IF( neuler == 0 .AND. kt == nit000 ) THEN
+            tilde_e3t_b(:,:,:) = tilde_e3t_n(:,:,:)
+         ELSE
+            tilde_e3t_b(:,:,:) = tilde_e3t_n(:,:,:) & 
+            &         + atfp * ( tilde_e3t_b(:,:,:) - 2.0_wp * tilde_e3t_n(:,:,:) + tilde_e3t_a(:,:,:) )
+         ENDIF
+         tilde_e3t_n(:,:,:) = tilde_e3t_a(:,:,:)
+      ENDIF
+      gdept_b(:,:,:) = gdept_n(:,:,:)
+      gdepw_b(:,:,:) = gdepw_n(:,:,:)
+
+      e3t_n(:,:,:) = e3t_a(:,:,:)
+      e3u_n(:,:,:) = e3u_a(:,:,:)
+      e3v_n(:,:,:) = e3v_a(:,:,:)
+
+      ! Compute all missing vertical scale factor and depths
+      ! ====================================================
+      ! Horizontal scale factor interpolations
+      ! --------------------------------------
+      ! - ML - e3u_b and e3v_b are allready computed in dynnxt
+      ! - JC - hu_b, hv_b, hur_b, hvr_b also
+      
+      CALL dom_vvl_interpol( e3u_n(:,:,:), e3f_n(:,:,:), 'F'  )
+      
+      ! Vertical scale factor interpolations
+      CALL dom_vvl_interpol( e3t_n(:,:,:),  e3w_n(:,:,:), 'W'  )
+      CALL dom_vvl_interpol( e3u_n(:,:,:), e3uw_n(:,:,:), 'UW' )
+      CALL dom_vvl_interpol( e3v_n(:,:,:), e3vw_n(:,:,:), 'VW' )
+      CALL dom_vvl_interpol( e3t_b(:,:,:),  e3w_b(:,:,:), 'W'  )
+      CALL dom_vvl_interpol( e3u_b(:,:,:), e3uw_b(:,:,:), 'UW' )
+      CALL dom_vvl_interpol( e3v_b(:,:,:), e3vw_b(:,:,:), 'VW' )
+
+      ! t- and w- points depth (set the isf depth as it is in the initial step)
+      gdept_n(:,:,1) = 0.5_wp * e3w_n(:,:,1)
+      gdepw_n(:,:,1) = 0.0_wp
+      gde3w_n(:,:,1) = gdept_n(:,:,1) - sshn(:,:)
+      DO jk = 2, jpk
+         DO jj = 1,jpj
+            DO ji = 1,jpi
+              !    zcoef = (tmask(ji,jj,jk) - wmask(ji,jj,jk))   ! 0 everywhere tmask = wmask, ie everywhere expect at jk = mikt
+                                                                 ! 1 for jk = mikt
+               zcoef = (tmask(ji,jj,jk) - wmask(ji,jj,jk))
+               gdepw_n(ji,jj,jk) = gdepw_n(ji,jj,jk-1) + e3t_n(ji,jj,jk-1)
+               gdept_n(ji,jj,jk) =    zcoef  * ( gdepw_n(ji,jj,jk  ) + 0.5 * e3w_n(ji,jj,jk) )  &
+                   &             + (1-zcoef) * ( gdept_n(ji,jj,jk-1) +       e3w_n(ji,jj,jk) ) 
+               gde3w_n(ji,jj,jk) = gdept_n(ji,jj,jk) - sshn(ji,jj)
+            END DO
+         END DO
+      END DO
+
+      ! Local depth and Inverse of the local depth of the water
+      ! -------------------------------------------------------
+      hu_n(:,:) = hu_a(:,:)   ;   r1_hu_n(:,:) = r1_hu_a(:,:)
+      hv_n(:,:) = hv_a(:,:)   ;   r1_hv_n(:,:) = r1_hv_a(:,:)
+      !
+      ht_n(:,:) = e3t_n(:,:,1) * tmask(:,:,1)
+      DO jk = 2, jpkm1
+         ht_n(:,:) = ht_n(:,:) + e3t_n(:,:,jk) * tmask(:,:,jk)
+      END DO
+
+      ! write restart file
+      ! ==================
+      IF( lrst_oce  )   CALL dom_vvl_rst( kt, 'WRITE' )
+      !
+      IF( ln_timing )   CALL timing_stop('dom_vvl_sf_swp')
+      !
+   END SUBROUTINE dom_vvl_sf_swp
+
+
+   SUBROUTINE dom_vvl_interpol( pe3_in, pe3_out, pout )
+      !!---------------------------------------------------------------------
+      !!                  ***  ROUTINE dom_vvl__interpol  ***
+      !!
+      !! ** Purpose :   interpolate scale factors from one grid point to another
+      !!
+      !! ** Method  :   e3_out = e3_0 + interpolation(e3_in - e3_0)
+      !!                - horizontal interpolation: grid cell surface averaging
+      !!                - vertical interpolation: simple averaging
+      !!----------------------------------------------------------------------
+      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in   ) ::  pe3_in    ! input e3 to be interpolated
+      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::  pe3_out   ! output interpolated e3
+      CHARACTER(LEN=*)                , INTENT(in   ) ::  pout      ! grid point of out scale factors
+      !                                                             !   =  'U', 'V', 'W, 'F', 'UW' or 'VW'
+      !
+      INTEGER ::   ji, jj, jk                                       ! dummy loop indices
+      REAL(wp) ::  zlnwd                                            ! =1./0. when ln_wd_il = T/F
+      !!----------------------------------------------------------------------
+      !
+      IF(ln_wd_il) THEN
+        zlnwd = 1.0_wp
+      ELSE
+        zlnwd = 0.0_wp
+      END IF
+      !
+      SELECT CASE ( pout )    !==  type of interpolation  ==!
+         !
+      CASE( 'U' )                   !* from T- to U-point : hor. surface weighted mean
+         DO jk = 1, jpk
+            DO jj = 1, jpjm1
+               DO ji = 1, fs_jpim1   ! vector opt.
+                  pe3_out(ji,jj,jk) = 0.5_wp * (  umask(ji,jj,jk) * (1.0_wp - zlnwd) + zlnwd ) * r1_e1e2u(ji,jj)   &
+                     &                       * (   e1e2t(ji  ,jj) * ( pe3_in(ji  ,jj,jk) - e3t_0(ji  ,jj,jk) )     &
+                     &                           + e1e2t(ji+1,jj) * ( pe3_in(ji+1,jj,jk) - e3t_0(ji+1,jj,jk) ) )
+               END DO
+            END DO
+         END DO
+         CALL lbc_lnk( pe3_out(:,:,:), 'U', 1._wp )
+         pe3_out(:,:,:) = pe3_out(:,:,:) + e3u_0(:,:,:)
+         !
+      CASE( 'V' )                   !* from T- to V-point : hor. surface weighted mean
+         DO jk = 1, jpk
+            DO jj = 1, jpjm1
+               DO ji = 1, fs_jpim1   ! vector opt.
+                  pe3_out(ji,jj,jk) = 0.5_wp * ( vmask(ji,jj,jk)  * (1.0_wp - zlnwd) + zlnwd ) * r1_e1e2v(ji,jj)   &
+                     &                       * (   e1e2t(ji,jj  ) * ( pe3_in(ji,jj  ,jk) - e3t_0(ji,jj  ,jk) )     &
+                     &                           + e1e2t(ji,jj+1) * ( pe3_in(ji,jj+1,jk) - e3t_0(ji,jj+1,jk) ) )
+               END DO
+            END DO
+         END DO
+         CALL lbc_lnk( pe3_out(:,:,:), 'V', 1._wp )
+         pe3_out(:,:,:) = pe3_out(:,:,:) + e3v_0(:,:,:)
+         !
+      CASE( 'F' )                   !* from U-point to F-point : hor. surface weighted mean
+         DO jk = 1, jpk
+            DO jj = 1, jpjm1
+               DO ji = 1, fs_jpim1   ! vector opt.
+                  pe3_out(ji,jj,jk) = 0.5_wp * (  umask(ji,jj,jk) * umask(ji,jj+1,jk) * (1.0_wp - zlnwd) + zlnwd ) &
+                     &                       *    r1_e1e2f(ji,jj)                                                  &
+                     &                       * (   e1e2u(ji,jj  ) * ( pe3_in(ji,jj  ,jk) - e3u_0(ji,jj  ,jk) )     &
+                     &                           + e1e2u(ji,jj+1) * ( pe3_in(ji,jj+1,jk) - e3u_0(ji,jj+1,jk) ) )
+               END DO
+            END DO
+         END DO
+         CALL lbc_lnk( pe3_out(:,:,:), 'F', 1._wp )
+         pe3_out(:,:,:) = pe3_out(:,:,:) + e3f_0(:,:,:)
+         !
+      CASE( 'W' )                   !* from T- to W-point : vertical simple mean
+         !
+         pe3_out(:,:,1) = e3w_0(:,:,1) + pe3_in(:,:,1) - e3t_0(:,:,1)
+         ! - ML - The use of mask in this formulea enables the special treatment of the last w-point without indirect adressing
+!!gm BUG? use here wmask in case of ISF ?  to be checked
+         DO jk = 2, jpk
+            pe3_out(:,:,jk) = e3w_0(:,:,jk) + ( 1.0_wp - 0.5_wp * ( tmask(:,:,jk) * (1.0_wp - zlnwd) + zlnwd ) )   &
+               &                            * ( pe3_in(:,:,jk-1) - e3t_0(:,:,jk-1) )                               &
+               &                            +            0.5_wp * ( tmask(:,:,jk) * (1.0_wp - zlnwd) + zlnwd )     &
+               &                            * ( pe3_in(:,:,jk  ) - e3t_0(:,:,jk  ) )
+         END DO
+         !
+      CASE( 'UW' )                  !* from U- to UW-point : vertical simple mean
+         !
+         pe3_out(:,:,1) = e3uw_0(:,:,1) + pe3_in(:,:,1) - e3u_0(:,:,1)
+         ! - ML - The use of mask in this formaula enables the special treatment of the last w- point without indirect adressing
+!!gm BUG? use here wumask in case of ISF ?  to be checked
+         DO jk = 2, jpk
+            pe3_out(:,:,jk) = e3uw_0(:,:,jk) + ( 1.0_wp - 0.5_wp * ( umask(:,:,jk) * (1.0_wp - zlnwd) + zlnwd ) )  &
+               &                             * ( pe3_in(:,:,jk-1) - e3u_0(:,:,jk-1) )                              &
+               &                             +            0.5_wp * ( umask(:,:,jk) * (1.0_wp - zlnwd) + zlnwd )    &
+               &                             * ( pe3_in(:,:,jk  ) - e3u_0(:,:,jk  ) )
+         END DO
+         !
+      CASE( 'VW' )                  !* from V- to VW-point : vertical simple mean
+         !
+         pe3_out(:,:,1) = e3vw_0(:,:,1) + pe3_in(:,:,1) - e3v_0(:,:,1)
+         ! - ML - The use of mask in this formaula enables the special treatment of the last w- point without indirect adressing
+!!gm BUG? use here wvmask in case of ISF ?  to be checked
+         DO jk = 2, jpk
+            pe3_out(:,:,jk) = e3vw_0(:,:,jk) + ( 1.0_wp - 0.5_wp * ( vmask(:,:,jk) * (1.0_wp - zlnwd) + zlnwd ) )  &
+               &                             * ( pe3_in(:,:,jk-1) - e3v_0(:,:,jk-1) )                              &
+               &                             +            0.5_wp * ( vmask(:,:,jk) * (1.0_wp - zlnwd) + zlnwd )    &
+               &                             * ( pe3_in(:,:,jk  ) - e3v_0(:,:,jk  ) )
+         END DO
+      END SELECT
+      !
+   END SUBROUTINE dom_vvl_interpol
+
+
+   SUBROUTINE dom_vvl_rst( kt, cdrw )
+      !!---------------------------------------------------------------------
+      !!                   ***  ROUTINE dom_vvl_rst  ***
+      !!                     
+      !! ** Purpose :   Read or write VVL file in restart file
+      !!
+      !! ** Method  :   use of IOM library
+      !!                if the restart does not contain vertical scale factors,
+      !!                they are set to the _0 values
+      !!                if the restart does not contain vertical scale factors increments (z_tilde),
+      !!                they are set to 0.
+      !!----------------------------------------------------------------------
+      INTEGER         , INTENT(in) ::   kt     ! ocean time-step
+      CHARACTER(len=*), INTENT(in) ::   cdrw   ! "READ"/"WRITE" flag
+      !
+      INTEGER ::   ji, jj, jk
+      INTEGER ::   id1, id2, id3, id4, id5     ! local integers
+      !!----------------------------------------------------------------------
+      !
+      IF( TRIM(cdrw) == 'READ' ) THEN        ! Read/initialise 
+         !                                   ! ===============
+         IF( ln_rstart ) THEN                   !* Read the restart file
+            CALL rst_read_open                  !  open the restart file if necessary
+            CALL iom_get( numror, jpdom_autoglo, 'sshn'   , sshn, ldxios = lrxios    )
+            !
+            id1 = iom_varid( numror, 'e3t_b', ldstop = .FALSE. )
+            id2 = iom_varid( numror, 'e3t_n', ldstop = .FALSE. )
+            id3 = iom_varid( numror, 'tilde_e3t_b', ldstop = .FALSE. )
+            id4 = iom_varid( numror, 'tilde_e3t_n', ldstop = .FALSE. )
+            id5 = iom_varid( numror, 'hdiv_lf', ldstop = .FALSE. )
+            !                             ! --------- !
+            !                             ! all cases !
+            !                             ! --------- !
+            IF( MIN( id1, id2 ) > 0 ) THEN       ! all required arrays exist
+               CALL iom_get( numror, jpdom_autoglo, 'e3t_b', e3t_b(:,:,:), ldxios = lrxios )
+               CALL iom_get( numror, jpdom_autoglo, 'e3t_n', e3t_n(:,:,:), ldxios = lrxios )
+               ! needed to restart if land processor not computed 
+               IF(lwp) write(numout,*) 'dom_vvl_rst : e3t_b and e3t_n found in restart files'
+               WHERE ( tmask(:,:,:) == 0.0_wp ) 
+                  e3t_n(:,:,:) = e3t_0(:,:,:)
+                  e3t_b(:,:,:) = e3t_0(:,:,:)
+               END WHERE
+               IF( neuler == 0 ) THEN
+                  e3t_b(:,:,:) = e3t_n(:,:,:)
+               ENDIF
+            ELSE IF( id1 > 0 ) THEN
+               IF(lwp) write(numout,*) 'dom_vvl_rst WARNING : e3t_n not found in restart files'
+               IF(lwp) write(numout,*) 'e3t_n set equal to e3t_b.'
+               IF(lwp) write(numout,*) 'neuler is forced to 0'
+               CALL iom_get( numror, jpdom_autoglo, 'e3t_b', e3t_b(:,:,:), ldxios = lrxios )
+               e3t_n(:,:,:) = e3t_b(:,:,:)
+               neuler = 0
+            ELSE IF( id2 > 0 ) THEN
+               IF(lwp) write(numout,*) 'dom_vvl_rst WARNING : e3t_b not found in restart files'
+               IF(lwp) write(numout,*) 'e3t_b set equal to e3t_n.'
+               IF(lwp) write(numout,*) 'neuler is forced to 0'
+               CALL iom_get( numror, jpdom_autoglo, 'e3t_n', e3t_n(:,:,:), ldxios = lrxios )
+               e3t_b(:,:,:) = e3t_n(:,:,:)
+               neuler = 0
+            ELSE
+               IF(lwp) write(numout,*) 'dom_vvl_rst WARNING : e3t_n not found in restart file'
+               IF(lwp) write(numout,*) 'Compute scale factor from sshn'
+               IF(lwp) write(numout,*) 'neuler is forced to 0'
+               DO jk = 1, jpk
+                  e3t_n(:,:,jk) =  e3t_0(:,:,jk) * ( ht_0(:,:) + sshn(:,:) ) &
+                      &                          / ( ht_0(:,:) + 1._wp - ssmask(:,:) ) * tmask(:,:,jk)   &
+                      &          + e3t_0(:,:,jk)                               * (1._wp -tmask(:,:,jk))
+               END DO
+               e3t_b(:,:,:) = e3t_n(:,:,:)
+               neuler = 0
+            ENDIF
+            !                             ! ----------- !
+            IF( ln_vvl_zstar ) THEN       ! z_star case !
+               !                          ! ----------- !
+               IF( MIN( id3, id4 ) > 0 ) THEN
+                  CALL ctl_stop( 'dom_vvl_rst: z_star cannot restart from a z_tilde or layer run' )
+               ENDIF
+               !                          ! ----------------------- !
+            ELSE                          ! z_tilde and layer cases !
+               !                          ! ----------------------- !
+               IF( MIN( id3, id4 ) > 0 ) THEN  ! all required arrays exist
+                  CALL iom_get( numror, jpdom_autoglo, 'tilde_e3t_b', tilde_e3t_b(:,:,:), ldxios = lrxios )
+                  CALL iom_get( numror, jpdom_autoglo, 'tilde_e3t_n', tilde_e3t_n(:,:,:), ldxios = lrxios )
+               ELSE                            ! one at least array is missing
+                  tilde_e3t_b(:,:,:) = 0.0_wp
+                  tilde_e3t_n(:,:,:) = 0.0_wp
+               ENDIF
+               !                          ! ------------ !
+               IF( ln_vvl_ztilde ) THEN   ! z_tilde case !
+                  !                       ! ------------ !
+                  IF( id5 > 0 ) THEN  ! required array exists
+                     CALL iom_get( numror, jpdom_autoglo, 'hdiv_lf', hdiv_lf(:,:,:), ldxios = lrxios )
+                  ELSE                ! array is missing
+                     hdiv_lf(:,:,:) = 0.0_wp
+                  ENDIF
+               ENDIF
+            ENDIF
+            !
+         ELSE                                   !* Initialize at "rest"
+            !
+
+            IF( ll_wd ) THEN   ! MJB ll_wd edits start here - these are essential 
+               !
+               IF( cn_cfg == 'wad' ) THEN
+                  ! Wetting and drying test case
+                  CALL usr_def_istate( gdept_b, tmask, tsb, ub, vb, sshb  )
+                  tsn  (:,:,:,:) = tsb (:,:,:,:)       ! set now values from to before ones
+                  sshn (:,:)     = sshb(:,:)
+                  un   (:,:,:)   = ub  (:,:,:)
+                  vn   (:,:,:)   = vb  (:,:,:)
+               ELSE
+                  ! if not test case
+                  sshn(:,:) = -ssh_ref
+                  sshb(:,:) = -ssh_ref
+
+                  DO jj = 1, jpj
+                     DO ji = 1, jpi
+                        IF( ht_0(ji,jj)-ssh_ref <  rn_wdmin1 ) THEN ! if total depth is less than min depth
+
+                           sshb(ji,jj) = rn_wdmin1 - (ht_0(ji,jj) )
+                           sshn(ji,jj) = rn_wdmin1 - (ht_0(ji,jj) )
+                           ssha(ji,jj) = rn_wdmin1 - (ht_0(ji,jj) )
+                        ENDIF
+                     ENDDO
+                  ENDDO
+               ENDIF !If test case else
+
+               ! Adjust vertical metrics for all wad
+               DO jk = 1, jpk
+                  e3t_n(:,:,jk) =  e3t_0(:,:,jk) * ( ht_0(:,:) + sshn(:,:)  ) &
+                    &                            / ( ht_0(:,:) + 1._wp - ssmask(:,:) ) * tmask(:,:,jk)   &
+                    &            + e3t_0(:,:,jk) * ( 1._wp - tmask(:,:,jk) )
+               END DO
+               e3t_b(:,:,:) = e3t_n(:,:,:)
+
+               DO ji = 1, jpi
+                  DO jj = 1, jpj
+                     IF ( ht_0(ji,jj) .LE. 0.0 .AND. NINT( ssmask(ji,jj) ) .EQ. 1) THEN
+                       CALL ctl_stop( 'dom_vvl_rst: ht_0 must be positive at potentially wet points' )
+                     ENDIF
+                  END DO 
+               END DO 
+               !
+            ELSE
+               !
+               ! Just to read set ssh in fact, called latter once vertical grid
+               ! is set up:
+!               CALL usr_def_istate( gdept_0, tmask, tsb, ub, vb, sshb  )
+!               !
+!               DO jk=1,jpk
+!                  e3t_b(:,:,jk) =  e3t_0(:,:,jk) * ( ht_0(:,:) + sshb(:,:) ) &
+!                     &            / ( ht_0(:,:) + 1._wp -ssmask(:,:) ) * tmask(:,:,jk)
+!               END DO
+!               e3t_n(:,:,:) = e3t_b(:,:,:)
+                sshn(:,:)=0._wp
+                e3t_n(:,:,:)=e3t_0(:,:,:)
+                e3t_b(:,:,:)=e3t_0(:,:,:)
+               !
+            END IF           ! end of ll_wd edits
+
+            IF( ln_vvl_ztilde .OR. ln_vvl_layer) THEN
+               tilde_e3t_b(:,:,:) = 0._wp
+               tilde_e3t_n(:,:,:) = 0._wp
+               IF( ln_vvl_ztilde ) hdiv_lf(:,:,:) = 0._wp
+            END IF
+         ENDIF
+         !
+      ELSEIF( TRIM(cdrw) == 'WRITE' ) THEN   ! Create restart file
+         !                                   ! ===================
+         IF(lwp) WRITE(numout,*) '---- dom_vvl_rst ----'
+         IF( lwxios ) CALL iom_swap(      cwxios_context          )
+         !                                           ! --------- !
+         !                                           ! all cases !
+         !                                           ! --------- !
+         CALL iom_rstput( kt, nitrst, numrow, 'e3t_b', e3t_b(:,:,:), ldxios = lwxios )
+         CALL iom_rstput( kt, nitrst, numrow, 'e3t_n', e3t_n(:,:,:), ldxios = lwxios )
+         !                                           ! ----------------------- !
+         IF( ln_vvl_ztilde .OR. ln_vvl_layer ) THEN  ! z_tilde and layer cases !
+            !                                        ! ----------------------- !
+            CALL iom_rstput( kt, nitrst, numrow, 'tilde_e3t_b', tilde_e3t_b(:,:,:), ldxios = lwxios)
+            CALL iom_rstput( kt, nitrst, numrow, 'tilde_e3t_n', tilde_e3t_n(:,:,:), ldxios = lwxios)
+         END IF
+         !                                           ! -------------!    
+         IF( ln_vvl_ztilde ) THEN                    ! z_tilde case !
+            !                                        ! ------------ !
+            CALL iom_rstput( kt, nitrst, numrow, 'hdiv_lf', hdiv_lf(:,:,:), ldxios = lwxios)
+         ENDIF
+         !
+         IF( lwxios ) CALL iom_swap(      cxios_context          )
+      ENDIF
+      !
+   END SUBROUTINE dom_vvl_rst
+
+
+   SUBROUTINE dom_vvl_ctl
+      !!---------------------------------------------------------------------
+      !!                  ***  ROUTINE dom_vvl_ctl  ***
+      !!                
+      !! ** Purpose :   Control the consistency between namelist options
+      !!                for vertical coordinate
+      !!----------------------------------------------------------------------
+      INTEGER ::   ioptio, ios
+      !!
+      NAMELIST/nam_vvl/ ln_vvl_zstar, ln_vvl_ztilde, ln_vvl_layer, ln_vvl_ztilde_as_zstar, &
+         &              ln_vvl_zstar_at_eqtor      , rn_ahe3     , rn_rst_e3t            , &
+         &              rn_lf_cutoff               , rn_zdef_max , ln_vvl_dbg                ! not yet implemented: ln_vvl_kepe
+      !!---------------------------------------------------------------------- 
+      !
+      REWIND( numnam_ref )              ! Namelist nam_vvl in reference namelist : 
+      READ  ( numnam_ref, nam_vvl, IOSTAT = ios, ERR = 901)
+901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'nam_vvl in reference namelist', lwp )
+      REWIND( numnam_cfg )              ! Namelist nam_vvl in configuration namelist : Parameters of the run
+      READ  ( numnam_cfg, nam_vvl, IOSTAT = ios, ERR = 902 )
+902   IF( ios >  0 ) CALL ctl_nam ( ios , 'nam_vvl in configuration namelist', lwp )
+      IF(lwm) WRITE ( numond, nam_vvl )
+      !
+      IF(lwp) THEN                    ! Namelist print
+         WRITE(numout,*)
+         WRITE(numout,*) 'dom_vvl_ctl : choice/control of the variable vertical coordinate'
+         WRITE(numout,*) '~~~~~~~~~~~'
+         WRITE(numout,*) '   Namelist nam_vvl : chose a vertical coordinate'
+         WRITE(numout,*) '      zstar                      ln_vvl_zstar   = ', ln_vvl_zstar
+         WRITE(numout,*) '      ztilde                     ln_vvl_ztilde  = ', ln_vvl_ztilde
+         WRITE(numout,*) '      layer                      ln_vvl_layer   = ', ln_vvl_layer
+         WRITE(numout,*) '      ztilde as zstar   ln_vvl_ztilde_as_zstar  = ', ln_vvl_ztilde_as_zstar
+         WRITE(numout,*) '      ztilde near the equator    ln_vvl_zstar_at_eqtor  = ', ln_vvl_zstar_at_eqtor
+         WRITE(numout,*) '      !'
+         WRITE(numout,*) '      thickness diffusion coefficient                      rn_ahe3      = ', rn_ahe3
+         WRITE(numout,*) '      maximum e3t deformation fractional change            rn_zdef_max  = ', rn_zdef_max
+         IF( ln_vvl_ztilde_as_zstar ) THEN
+            WRITE(numout,*) '      ztilde running in zstar emulation mode (ln_vvl_ztilde_as_zstar=T) '
+            WRITE(numout,*) '         ignoring namelist timescale parameters and using:'
+            WRITE(numout,*) '            hard-wired : z-tilde to zstar restoration timescale (days)'
+            WRITE(numout,*) '                         rn_rst_e3t     = 0.e0'
+            WRITE(numout,*) '            hard-wired : z-tilde cutoff frequency of low-pass filter (days)'
+            WRITE(numout,*) '                         rn_lf_cutoff   = 1.0/rdt'
+         ELSE
+            WRITE(numout,*) '      z-tilde to zstar restoration timescale (days)        rn_rst_e3t   = ', rn_rst_e3t
+            WRITE(numout,*) '      z-tilde cutoff frequency of low-pass filter (days)   rn_lf_cutoff = ', rn_lf_cutoff
+         ENDIF
+         WRITE(numout,*) '         debug prints flag                                 ln_vvl_dbg   = ', ln_vvl_dbg
+      ENDIF
+      !
+      ioptio = 0                      ! Parameter control
+      IF( ln_vvl_ztilde_as_zstar )   ln_vvl_ztilde = .true.
+      IF( ln_vvl_zstar           )   ioptio = ioptio + 1
+      IF( ln_vvl_ztilde          )   ioptio = ioptio + 1
+      IF( ln_vvl_layer           )   ioptio = ioptio + 1
+      !
+      IF( ioptio /= 1 )   CALL ctl_stop( 'Choose ONE vertical coordinate in namelist nam_vvl' )
+      IF( .NOT. ln_vvl_zstar .AND. ln_isf ) CALL ctl_stop( 'Only vvl_zstar has been tested with ice shelf cavity' )
+      !
+      IF(lwp) THEN                   ! Print the choice
+         WRITE(numout,*)
+         IF( ln_vvl_zstar           ) WRITE(numout,*) '      ==>>>   zstar vertical coordinate is used'
+         IF( ln_vvl_ztilde          ) WRITE(numout,*) '      ==>>>   ztilde vertical coordinate is used'
+         IF( ln_vvl_layer           ) WRITE(numout,*) '      ==>>>   layer vertical coordinate is used'
+         IF( ln_vvl_ztilde_as_zstar ) WRITE(numout,*) '      ==>>>   to emulate a zstar coordinate'
+      ENDIF
+      !
+#if defined key_agrif
+      IF( (.NOT.Agrif_Root()).AND.(.NOT.ln_vvl_zstar) )   CALL ctl_stop( 'AGRIF is implemented with zstar coordinate only' )
+#endif
+      !
+   END SUBROUTINE dom_vvl_ctl
+
+   !!======================================================================
+END MODULE domvvl
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DOM/domwri.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DOM/domwri.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DOM/domwri.F90	(revision 9570)
@@ -0,0 +1,290 @@
+MODULE domwri
+   !!======================================================================
+   !!                       ***  MODULE domwri  ***
+   !! Ocean initialization : write the ocean domain mesh file(s)
+   !!======================================================================
+   !! History :  OPA  ! 1997-02  (G. Madec)  Original code
+   !!            8.1  ! 1999-11  (M. Imbard)  NetCDF FORMAT with IOIPSL
+   !!   NEMO     1.0  ! 2002-08  (G. Madec)  F90 and several file
+   !!            3.0  ! 2008-01  (S. Masson)  add dom_uniq 
+   !!            4.0  ! 2016-01  (G. Madec)  simplified mesh_mask.nc file
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   dom_wri        : create and write mesh and mask file(s)
+   !!   dom_uniq       : identify unique point of a grid (TUVF)
+   !!   dom_stiff      : diagnose maximum grid stiffness/hydrostatic consistency (s-coordinate)
+   !!----------------------------------------------------------------------
+   USE dom_oce         ! ocean space and time domain
+   USE phycst ,   ONLY :   rsmall
+   USE wet_dry,   ONLY :   ll_wd  ! Wetting and drying
+   !
+   USE in_out_manager  ! I/O manager
+   USE iom             ! I/O library
+   USE lbclnk          ! lateral boundary conditions - mpp exchanges
+   USE lib_mpp         ! MPP library
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   dom_wri              ! routine called by inidom.F90
+   PUBLIC   dom_stiff            ! routine called by inidom.F90
+
+   !! * Substitutions
+#  include "vectopt_loop_substitute.h90"
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 4.0 , NEMO Consortium (2016)
+   !! $Id$ 
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE dom_wri
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE dom_wri  ***
+      !!                   
+      !! ** Purpose :   Create the NetCDF file(s) which contain(s) all the
+      !!      ocean domain informations (mesh and mask arrays). This (these)
+      !!      file(s) is (are) used for visualisation (SAXO software) and
+      !!      diagnostic computation.
+      !!
+      !! ** Method  :   create a file with all domain related arrays
+      !!
+      !! ** output file :   meshmask.nc  : domain size, horizontal grid-point position,
+      !!                                   masks, depth and vertical scale factors
+      !!----------------------------------------------------------------------
+      INTEGER           ::   inum    ! temprary units for 'mesh_mask.nc' file
+      CHARACTER(len=21) ::   clnam   ! filename (mesh and mask informations)
+      INTEGER           ::   ji, jj, jk   ! dummy loop indices
+      INTEGER           ::   izco, izps, isco, icav
+      !                               
+      REAL(wp), DIMENSION(jpi,jpj)     ::   zprt, zprw     ! 2D workspace
+      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zdepu, zdepv   ! 3D workspace
+      !!----------------------------------------------------------------------
+      !
+      IF(lwp) WRITE(numout,*)
+      IF(lwp) WRITE(numout,*) 'dom_wri : create NetCDF mesh and mask information file(s)'
+      IF(lwp) WRITE(numout,*) '~~~~~~~'
+      
+      clnam = 'mesh_mask'  ! filename (mesh and mask informations)
+      
+      !                                  ! ============================
+      !                                  !  create 'mesh_mask.nc' file
+      !                                  ! ============================
+      CALL iom_open( TRIM(clnam), inum, ldwrt = .TRUE., kiolib = jprstlib )
+      !
+      !                                                         ! global domain size
+      CALL iom_rstput( 0, 0, inum, 'jpiglo', REAL( jpiglo, wp), ktype = jp_i4 )
+      CALL iom_rstput( 0, 0, inum, 'jpjglo', REAL( jpjglo, wp), ktype = jp_i4 )
+      CALL iom_rstput( 0, 0, inum, 'jpkglo', REAL( jpkglo, wp), ktype = jp_i4 )
+
+      !                                                         ! domain characteristics
+      CALL iom_rstput( 0, 0, inum, 'jperio', REAL( jperio, wp), ktype = jp_i4 )
+      !                                                         ! type of vertical coordinate
+      IF( ln_zco    ) THEN   ;   izco = 1   ;   ELSE   ;   izco = 0   ;   ENDIF
+      IF( ln_zps    ) THEN   ;   izps = 1   ;   ELSE   ;   izps = 0   ;   ENDIF
+      IF( ln_sco    ) THEN   ;   isco = 1   ;   ELSE   ;   isco = 0   ;   ENDIF
+      CALL iom_rstput( 0, 0, inum, 'ln_zco'   , REAL( izco, wp), ktype = jp_i4 )
+      CALL iom_rstput( 0, 0, inum, 'ln_zps'   , REAL( izps, wp), ktype = jp_i4 )
+      CALL iom_rstput( 0, 0, inum, 'ln_sco'   , REAL( isco, wp), ktype = jp_i4 )
+      !                                                         ! ocean cavities under iceshelves
+      IF( ln_isfcav ) THEN   ;   icav = 1   ;   ELSE   ;   icav = 0   ;   ENDIF
+      CALL iom_rstput( 0, 0, inum, 'ln_isfcav', REAL( icav, wp), ktype = jp_i4 )
+  
+      !                                                         ! masks
+      CALL iom_rstput( 0, 0, inum, 'tmask', tmask, ktype = jp_i1 )     !    ! land-sea mask
+      CALL iom_rstput( 0, 0, inum, 'umask', umask, ktype = jp_i1 )
+      CALL iom_rstput( 0, 0, inum, 'vmask', vmask, ktype = jp_i1 )
+      CALL iom_rstput( 0, 0, inum, 'fmask', fmask, ktype = jp_i1 )
+      
+      CALL dom_uniq( zprw, 'T' )
+      DO jj = 1, jpj
+         DO ji = 1, jpi
+            zprt(ji,jj) = ssmask(ji,jj) * zprw(ji,jj)                        !    ! unique point mask
+         END DO
+      END DO                             !    ! unique point mask
+      CALL iom_rstput( 0, 0, inum, 'tmaskutil', zprt, ktype = jp_i1 )  
+      CALL dom_uniq( zprw, 'U' )
+      DO jj = 1, jpj
+         DO ji = 1, jpi
+            zprt(ji,jj) = ssumask(ji,jj) * zprw(ji,jj)                        !    ! unique point mask
+         END DO
+      END DO
+      CALL iom_rstput( 0, 0, inum, 'umaskutil', zprt, ktype = jp_i1 )  
+      CALL dom_uniq( zprw, 'V' )
+      DO jj = 1, jpj
+         DO ji = 1, jpi
+            zprt(ji,jj) = ssvmask(ji,jj) * zprw(ji,jj)                        !    ! unique point mask
+         END DO
+      END DO
+      CALL iom_rstput( 0, 0, inum, 'vmaskutil', zprt, ktype = jp_i1 )  
+!!gm  ssfmask has been removed  ==>> find another solution to defined fmaskutil
+!!    Here we just remove the output of fmaskutil.
+!      CALL dom_uniq( zprw, 'F' )
+!      DO jj = 1, jpj
+!         DO ji = 1, jpi
+!            zprt(ji,jj) = ssfmask(ji,jj) * zprw(ji,jj)                        !    ! unique point mask
+!         END DO
+!      END DO
+!      CALL iom_rstput( 0, 0, inum, 'fmaskutil', zprt, ktype = jp_i1 )  
+!!gm
+
+      !                                                         ! horizontal mesh (inum3)
+      CALL iom_rstput( 0, 0, inum, 'glamt', glamt, ktype = jp_r8 )     !    ! latitude
+      CALL iom_rstput( 0, 0, inum, 'glamu', glamu, ktype = jp_r8 )
+      CALL iom_rstput( 0, 0, inum, 'glamv', glamv, ktype = jp_r8 )
+      CALL iom_rstput( 0, 0, inum, 'glamf', glamf, ktype = jp_r8 )
+      
+      CALL iom_rstput( 0, 0, inum, 'gphit', gphit, ktype = jp_r8 )     !    ! longitude
+      CALL iom_rstput( 0, 0, inum, 'gphiu', gphiu, ktype = jp_r8 )
+      CALL iom_rstput( 0, 0, inum, 'gphiv', gphiv, ktype = jp_r8 )
+      CALL iom_rstput( 0, 0, inum, 'gphif', gphif, ktype = jp_r8 )
+      
+      CALL iom_rstput( 0, 0, inum, 'e1t', e1t, ktype = jp_r8 )         !    ! e1 scale factors
+      CALL iom_rstput( 0, 0, inum, 'e1u', e1u, ktype = jp_r8 )
+      CALL iom_rstput( 0, 0, inum, 'e1v', e1v, ktype = jp_r8 )
+      CALL iom_rstput( 0, 0, inum, 'e1f', e1f, ktype = jp_r8 )
+      
+      CALL iom_rstput( 0, 0, inum, 'e2t', e2t, ktype = jp_r8 )         !    ! e2 scale factors
+      CALL iom_rstput( 0, 0, inum, 'e2u', e2u, ktype = jp_r8 )
+      CALL iom_rstput( 0, 0, inum, 'e2v', e2v, ktype = jp_r8 )
+      CALL iom_rstput( 0, 0, inum, 'e2f', e2f, ktype = jp_r8 )
+      
+      CALL iom_rstput( 0, 0, inum, 'ff_f', ff_f, ktype = jp_r8 )       !    ! coriolis factor
+      CALL iom_rstput( 0, 0, inum, 'ff_t', ff_t, ktype = jp_r8 )
+      
+      ! note that mbkt is set to 1 over land ==> use surface tmask
+      zprt(:,:) = ssmask(:,:) * REAL( mbkt(:,:) , wp )
+      CALL iom_rstput( 0, 0, inum, 'mbathy', zprt, ktype = jp_i4 )     !    ! nb of ocean T-points
+      zprt(:,:) = ssmask(:,:) * REAL( mikt(:,:) , wp )
+      CALL iom_rstput( 0, 0, inum, 'misf', zprt, ktype = jp_i4 )       !    ! nb of ocean T-points
+      zprt(:,:) = ssmask(:,:) * REAL( risfdep(:,:) , wp )
+      CALL iom_rstput( 0, 0, inum, 'isfdraft', zprt, ktype = jp_r8 )   !    ! nb of ocean T-points
+      !															             ! vertical mesh
+      CALL iom_rstput( 0, 0, inum, 'e3t_0', e3t_0, ktype = jp_r8  )    !    ! scale factors
+      CALL iom_rstput( 0, 0, inum, 'e3u_0', e3u_0, ktype = jp_r8  )
+      CALL iom_rstput( 0, 0, inum, 'e3v_0', e3v_0, ktype = jp_r8  )
+      CALL iom_rstput( 0, 0, inum, 'e3w_0', e3w_0, ktype = jp_r8  )
+      !
+      CALL iom_rstput( 0, 0, inum, 'gdept_1d' , gdept_1d , ktype = jp_r8 )  ! stretched system
+      CALL iom_rstput( 0, 0, inum, 'gdepw_1d' , gdepw_1d , ktype = jp_r8 )
+      CALL iom_rstput( 0, 0, inum, 'gdept_0'  , gdept_0  , ktype = jp_r8 )
+      CALL iom_rstput( 0, 0, inum, 'gdepw_0'  , gdepw_0  , ktype = jp_r8 )
+      !
+      IF( ln_sco ) THEN                                         ! s-coordinate stiffness
+         CALL dom_stiff( zprt )
+         CALL iom_rstput( 0, 0, inum, 'stiffness', zprt )       ! Max. grid stiffness ratio
+      ENDIF
+      !
+      IF( ll_wd ) CALL iom_rstput( 0, 0, inum, 'ht_0'   , ht_0   , ktype = jp_r8 )
+
+      !                                     ! ============================
+      CALL iom_close( inum )                !        close the files 
+      !                                     ! ============================
+   END SUBROUTINE dom_wri
+
+
+   SUBROUTINE dom_uniq( puniq, cdgrd )
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE dom_uniq  ***
+      !!                   
+      !! ** Purpose :   identify unique point of a grid (TUVF)
+      !!
+      !! ** Method  :   1) aplly lbc_lnk on an array with different values for each element
+      !!                2) check which elements have been changed
+      !!----------------------------------------------------------------------
+      CHARACTER(len=1)        , INTENT(in   ) ::   cdgrd   ! 
+      REAL(wp), DIMENSION(:,:), INTENT(inout) ::   puniq   ! 
+      !
+      REAL(wp) ::  zshift   ! shift value link to the process number
+      INTEGER  ::  ji       ! dummy loop indices
+      LOGICAL, DIMENSION(SIZE(puniq,1),SIZE(puniq,2),1) ::  lldbl  ! store whether each point is unique or not
+      REAL(wp), DIMENSION(jpi,jpj) ::   ztstref
+      !!----------------------------------------------------------------------
+      !
+      ! build an array with different values for each element 
+      ! in mpp: make sure that these values are different even between process
+      ! -> apply a shift value according to the process number
+      zshift = jpi * jpj * ( narea - 1 )
+      ztstref(:,:) = RESHAPE( (/ (zshift + REAL(ji,wp), ji = 1, jpi*jpj) /), (/ jpi, jpj /) )
+      !
+      puniq(:,:) = ztstref(:,:)                   ! default definition
+      CALL lbc_lnk( puniq, cdgrd, 1. )            ! apply boundary conditions
+      lldbl(:,:,1) = puniq(:,:) == ztstref(:,:)   ! check which values have been changed 
+      !
+      puniq(:,:) = 1.                             ! default definition
+      ! fill only the inner part of the cpu with llbl converted into real 
+      puniq(nldi:nlei,nldj:nlej) = REAL( COUNT( lldbl(nldi:nlei,nldj:nlej,:), dim = 3 ) , wp )
+      !
+   END SUBROUTINE dom_uniq
+
+
+   SUBROUTINE dom_stiff( px1 )
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE dom_stiff  ***
+      !!                     
+      !! ** Purpose :   Diagnose maximum grid stiffness/hydrostatic consistency
+      !!
+      !! ** Method  :   Compute Haney (1991) hydrostatic condition ratio
+      !!                Save the maximum in the vertical direction
+      !!                (this number is only relevant in s-coordinates)
+      !!
+      !!                Haney, 1991, J. Phys. Oceanogr., 21, 610-619.
+      !!----------------------------------------------------------------------
+      REAL(wp), DIMENSION(:,:), INTENT(out), OPTIONAL ::   px1   ! stiffness
+      !
+      INTEGER  ::   ji, jj, jk 
+      REAL(wp) ::   zrxmax
+      REAL(wp), DIMENSION(4) ::   zr1
+      REAL(wp), DIMENSION(jpi,jpj) ::   zx1
+      !!----------------------------------------------------------------------
+      zx1(:,:) = 0._wp
+      zrxmax   = 0._wp
+      zr1(:)   = 0._wp
+      !
+      DO ji = 2, jpim1
+         DO jj = 2, jpjm1
+            DO jk = 1, jpkm1
+!!gm   remark: dk(gdepw) = e3t   ===>>>  possible simplification of the following calculation....
+!!             especially since it is gde3w which is used to compute the pressure gradient
+!!             furthermore, I think gdept_0 should be used below instead of w point in the numerator
+!!             so that the ratio is computed at the same point (i.e. uw and vw) ....
+               zr1(1) = ABS(  ( gdepw_0(ji  ,jj,jk  )-gdepw_0(ji-1,jj,jk  )               & 
+                    &          +gdepw_0(ji  ,jj,jk+1)-gdepw_0(ji-1,jj,jk+1) )             &
+                    &       / ( gdepw_0(ji  ,jj,jk  )+gdepw_0(ji-1,jj,jk  )               &
+                    &          -gdepw_0(ji  ,jj,jk+1)-gdepw_0(ji-1,jj,jk+1) + rsmall )  ) * umask(ji-1,jj,jk)
+               zr1(2) = ABS(  ( gdepw_0(ji+1,jj,jk  )-gdepw_0(ji  ,jj,jk  )               &
+                    &          +gdepw_0(ji+1,jj,jk+1)-gdepw_0(ji  ,jj,jk+1) )             &
+                    &       / ( gdepw_0(ji+1,jj,jk  )+gdepw_0(ji  ,jj,jk  )               &
+                    &          -gdepw_0(ji+1,jj,jk+1)-gdepw_0(ji  ,jj,jk+1) + rsmall )  ) * umask(ji  ,jj,jk)
+               zr1(3) = ABS(  ( gdepw_0(ji,jj+1,jk  )-gdepw_0(ji,jj  ,jk  )               &
+                    &          +gdepw_0(ji,jj+1,jk+1)-gdepw_0(ji,jj  ,jk+1) )             &
+                    &       / ( gdepw_0(ji,jj+1,jk  )+gdepw_0(ji,jj  ,jk  )               &
+                    &          -gdepw_0(ji,jj+1,jk+1)-gdepw_0(ji,jj  ,jk+1) + rsmall )  ) * vmask(ji,jj  ,jk)
+               zr1(4) = ABS(  ( gdepw_0(ji,jj  ,jk  )-gdepw_0(ji,jj-1,jk  )               &
+                    &          +gdepw_0(ji,jj  ,jk+1)-gdepw_0(ji,jj-1,jk+1) )             &
+                    &       / ( gdepw_0(ji,jj  ,jk  )+gdepw_0(ji,jj-1,jk  )               &
+                    &          -gdepw_0(ji,jj  ,jk+1)-gdepw_0(ji,jj-1,jk+1) + rsmall )  ) * vmask(ji,jj-1,jk)
+               zrxmax = MAXVAL( zr1(1:4) )
+               zx1(ji,jj) = MAX( zx1(ji,jj) , zrxmax )
+            END DO
+         END DO
+      END DO
+      CALL lbc_lnk( zx1, 'T', 1. )
+      !
+      IF( PRESENT( px1 ) )    px1 = zx1
+      !
+      zrxmax = MAXVAL( zx1 )
+      !
+      IF( lk_mpp )   CALL mpp_max( zrxmax ) ! max over the global domain
+      !
+      IF(lwp) THEN
+         WRITE(numout,*)
+         WRITE(numout,*) 'dom_stiff : maximum grid stiffness ratio: ', zrxmax
+         WRITE(numout,*) '~~~~~~~~~'
+      ENDIF
+      !
+   END SUBROUTINE dom_stiff
+
+   !!======================================================================
+END MODULE domwri
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DOM/domzgr.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DOM/domzgr.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DOM/domzgr.F90	(revision 9570)
@@ -0,0 +1,319 @@
+MODULE domzgr
+   !!==============================================================================
+   !!                       ***  MODULE domzgr   ***
+   !! Ocean domain : definition of the vertical coordinate system
+   !!==============================================================================
+   !! History :  OPA  ! 1995-12  (G. Madec)  Original code : s vertical coordinate
+   !!                 ! 1997-07  (G. Madec)  lbc_lnk call
+   !!                 ! 1997-04  (J.-O. Beismann) 
+   !!            8.5  ! 2002-09  (A. Bozec, G. Madec)  F90: Free form and module
+   !!             -   ! 2002-09  (A. de Miranda)  rigid-lid + islands
+   !!  NEMO      1.0  ! 2003-08  (G. Madec)  F90: Free form and module
+   !!             -   ! 2005-10  (A. Beckmann)  modifications for hybrid s-ccordinates & new stretching function
+   !!            2.0  ! 2006-04  (R. Benshila, G. Madec)  add zgr_zco
+   !!            3.0  ! 2008-06  (G. Madec)  insertion of domzgr_zps.h90 & conding style
+   !!            3.2  ! 2009-07  (R. Benshila) Suppression of rigid-lid option
+   !!            3.3  ! 2010-11  (G. Madec) add mbk. arrays associated to the deepest ocean level
+   !!            3.4  ! 2012-08  (J. Siddorn) added Siddorn and Furner stretching function
+   !!            3.4  ! 2012-12  (R. Bourdalle-Badie and G. Reffray)  modify C1D case  
+   !!            3.6  ! 2014-11  (P. Mathiot and C. Harris) add ice shelf capabilitye  
+   !!            3.?  ! 2015-11  (H. Liu) Modifications for Wetting/Drying
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   dom_zgr       : read or set the ocean vertical coordinate system
+   !!   zgr_read      : read the vertical information in the domain configuration file
+   !!   zgr_top_bot   : ocean top and bottom level for t-, u, and v-points with 1 as minimum value
+   !!---------------------------------------------------------------------
+   USE oce            ! ocean variables
+   USE dom_oce        ! ocean domain
+   USE usrdef_zgr     ! user defined vertical coordinate system
+   USE closea         ! closed seas
+   USE depth_e3       ! depth <=> e3
+   USE wet_dry,   ONLY: ll_wd, ssh_ref  ! Wetting and drying
+   !
+   USE in_out_manager ! I/O manager
+   USE iom            ! I/O library
+   USE lbclnk         ! ocean lateral boundary conditions (or mpp link)
+   USE lib_mpp        ! distributed memory computing library
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   dom_zgr        ! called by dom_init.F90
+
+  !! * Substitutions
+#  include "vectopt_loop_substitute.h90"
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3.1 , NEMO Consortium (2011)
+   !! $Id$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS       
+
+   SUBROUTINE dom_zgr( k_top, k_bot )
+      !!----------------------------------------------------------------------
+      !!                ***  ROUTINE dom_zgr  ***
+      !!                   
+      !! ** Purpose :   set the depth of model levels and the resulting 
+      !!              vertical scale factors.
+      !!
+      !! ** Method  : - reference 1D vertical coordinate (gdep._1d, e3._1d)
+      !!              - read/set ocean depth and ocean levels (bathy, mbathy)
+      !!              - vertical coordinate (gdep., e3.) depending on the 
+      !!                coordinate chosen :
+      !!                   ln_zco=T   z-coordinate   
+      !!                   ln_zps=T   z-coordinate with partial steps
+      !!                   ln_zco=T   s-coordinate 
+      !!
+      !! ** Action  :   define gdep., e3., mbathy and bathy
+      !!----------------------------------------------------------------------
+      INTEGER, DIMENSION(:,:), INTENT(out) ::   k_top, k_bot   ! ocean first and last level indices
+      !
+      INTEGER  ::   jk                  ! dummy loop index
+      INTEGER  ::   ioptio, ibat, ios   ! local integer
+      REAL(wp) ::   zrefdep             ! depth of the reference level (~10m)
+      !!----------------------------------------------------------------------
+      !
+      IF(lwp) THEN                     ! Control print
+         WRITE(numout,*)
+         WRITE(numout,*) 'dom_zgr : vertical coordinate'
+         WRITE(numout,*) '~~~~~~~'
+      ENDIF
+
+      IF( ln_linssh .AND. lwp) WRITE(numout,*) '   linear free surface: the vertical mesh does not change in time'
+
+
+      IF( ln_read_cfg ) THEN        !==  read in mesh_mask.nc file  ==!
+         IF(lwp) WRITE(numout,*)
+         IF(lwp) WRITE(numout,*) '   ==>>>   Read vertical mesh in ', TRIM( cn_domcfg ), ' file'
+         !
+         CALL zgr_read   ( ln_zco  , ln_zps  , ln_sco, ln_isfcav,   & 
+            &              gdept_1d, gdepw_1d, e3t_1d, e3w_1d   ,   &    ! 1D gridpoints depth
+            &              gdept_0 , gdepw_0                    ,   &    ! gridpoints depth 
+            &              e3t_0   , e3u_0   , e3v_0 , e3f_0    ,   &    ! vertical scale factors
+            &              e3w_0   , e3uw_0  , e3vw_0           ,   &    ! vertical scale factors
+            &              k_top   , k_bot            )                  ! 1st & last ocean level
+            !
+      ELSE                          !==  User defined configuration  ==!
+         IF(lwp) WRITE(numout,*)
+         IF(lwp) WRITE(numout,*) '          User defined vertical mesh (usr_def_zgr)'
+         !
+         CALL usr_def_zgr( ln_zco  , ln_zps  , ln_sco, ln_isfcav,   & 
+            &              gdept_1d, gdepw_1d, e3t_1d, e3w_1d   ,   &    ! 1D gridpoints depth
+            &              gdept_0 , gdepw_0                    ,   &    ! gridpoints depth 
+            &              e3t_0   , e3u_0   , e3v_0 , e3f_0    ,   &    ! vertical scale factors
+            &              e3w_0   , e3uw_0  , e3vw_0           ,   &    ! vertical scale factors
+            &              k_top   , k_bot            )                  ! 1st & last ocean level
+         !
+      ENDIF
+      !
+!!gm to be remove when removing the OLD definition of e3 scale factors so that gde3w disappears
+      ! Compute gde3w_0 (vertical sum of e3w)
+      gde3w_0(:,:,1) = 0.5_wp * e3w_0(:,:,1)
+      DO jk = 2, jpk
+         gde3w_0(:,:,jk) = gde3w_0(:,:,jk-1) + e3w_0(:,:,jk)
+      END DO
+      !
+      ! Any closed seas (defined by closea_mask > 0 in domain_cfg file) to be filled 
+      ! in at runtime if ln_closea=.false.
+      IF( .NOT.ln_closea )   CALL clo_bat( k_top, k_bot )
+      !
+      IF(lwp) THEN                     ! Control print
+         WRITE(numout,*)
+         WRITE(numout,*) '   Type of vertical coordinate (read in ', TRIM( cn_domcfg ), ' file or set in userdef_nam) :'
+         WRITE(numout,*) '      z-coordinate - full steps      ln_zco    = ', ln_zco
+         WRITE(numout,*) '      z-coordinate - partial steps   ln_zps    = ', ln_zps
+         WRITE(numout,*) '      s- or hybrid z-s-coordinate    ln_sco    = ', ln_sco
+         WRITE(numout,*) '      ice shelf cavities             ln_isfcav = ', ln_isfcav
+      ENDIF
+
+      ioptio = 0                       ! Check Vertical coordinate options
+      IF( ln_zco      )   ioptio = ioptio + 1
+      IF( ln_zps      )   ioptio = ioptio + 1
+      IF( ln_sco      )   ioptio = ioptio + 1
+      IF( ioptio /= 1 )   CALL ctl_stop( ' none or several vertical coordinate options used' )
+
+
+      !                                ! top/bottom ocean level indices for t-, u- and v-points (f-point also for top)
+      CALL zgr_top_bot( k_top, k_bot )      ! with a minimum value set to 1
+      
+
+      !                                ! deepest/shallowest W level Above/Below ~10m
+!!gm BUG in s-coordinate this does not work!
+      zrefdep = 10._wp - 0.1_wp * MINVAL( e3w_1d )                   ! ref. depth with tolerance (10% of minimum layer thickness)
+      nlb10 = MINLOC( gdepw_1d, mask = gdepw_1d > zrefdep, dim = 1 ) ! shallowest W level Below ~10m
+      nla10 = nlb10 - 1                                              ! deepest    W level Above ~10m
+!!gm end bug
+      !
+      IF( nprint == 1 .AND. lwp )   THEN
+         WRITE(numout,*) ' MIN val k_top   ', MINVAL(   k_top(:,:) ), ' MAX ', MAXVAL( k_top(:,:) )
+         WRITE(numout,*) ' MIN val k_bot   ', MINVAL(   k_bot(:,:) ), ' MAX ', MAXVAL( k_bot(:,:) )
+         WRITE(numout,*) ' MIN val depth t ', MINVAL( gdept_0(:,:,:) ),   &
+            &                          ' w ', MINVAL( gdepw_0(:,:,:) ), '3w ', MINVAL( gde3w_0(:,:,:) )
+         WRITE(numout,*) ' MIN val e3    t ', MINVAL(   e3t_0(:,:,:) ), ' f ', MINVAL(   e3f_0(:,:,:) ),  &
+            &                          ' u ', MINVAL(   e3u_0(:,:,:) ), ' u ', MINVAL(   e3v_0(:,:,:) ),  &
+            &                          ' uw', MINVAL(  e3uw_0(:,:,:) ), ' vw', MINVAL(  e3vw_0(:,:,:)),   &
+            &                          ' w ', MINVAL(   e3w_0(:,:,:) )
+
+         WRITE(numout,*) ' MAX val depth t ', MAXVAL( gdept_0(:,:,:) ),   &
+            &                          ' w ', MAXVAL( gdepw_0(:,:,:) ), '3w ', MAXVAL( gde3w_0(:,:,:) )
+         WRITE(numout,*) ' MAX val e3    t ', MAXVAL(   e3t_0(:,:,:) ), ' f ', MAXVAL(   e3f_0(:,:,:) ),  &
+            &                          ' u ', MAXVAL(   e3u_0(:,:,:) ), ' u ', MAXVAL(   e3v_0(:,:,:) ),  &
+            &                          ' uw', MAXVAL(  e3uw_0(:,:,:) ), ' vw', MAXVAL(  e3vw_0(:,:,:) ),  &
+            &                          ' w ', MAXVAL(   e3w_0(:,:,:) )
+      ENDIF
+      !
+   END SUBROUTINE dom_zgr
+
+
+   SUBROUTINE zgr_read( ld_zco  , ld_zps  , ld_sco  , ld_isfcav,   &   ! type of vertical coordinate
+      &                 pdept_1d, pdepw_1d, pe3t_1d , pe3w_1d  ,   &   ! 1D reference vertical coordinate
+      &                 pdept , pdepw ,                            &   ! 3D t & w-points depth
+      &                 pe3t  , pe3u  , pe3v   , pe3f ,            &   ! vertical scale factors
+      &                 pe3w  , pe3uw , pe3vw         ,            &   !     -      -      -
+      &                 k_top  , k_bot    )                            ! top & bottom ocean level
+      !!---------------------------------------------------------------------
+      !!              ***  ROUTINE zgr_read  ***
+      !!
+      !! ** Purpose :   Read the vertical information in the domain configuration file
+      !!
+      !!----------------------------------------------------------------------
+      LOGICAL                   , INTENT(out) ::   ld_zco, ld_zps, ld_sco      ! vertical coordinate flags
+      LOGICAL                   , INTENT(out) ::   ld_isfcav                   ! under iceshelf cavity flag
+      REAL(wp), DIMENSION(:)    , INTENT(out) ::   pdept_1d, pdepw_1d          ! 1D grid-point depth       [m]
+      REAL(wp), DIMENSION(:)    , INTENT(out) ::   pe3t_1d , pe3w_1d           ! 1D vertical scale factors [m]
+      REAL(wp), DIMENSION(:,:,:), INTENT(out) ::   pdept, pdepw                ! grid-point depth          [m]
+      REAL(wp), DIMENSION(:,:,:), INTENT(out) ::   pe3t , pe3u , pe3v , pe3f   ! vertical scale factors    [m]
+      REAL(wp), DIMENSION(:,:,:), INTENT(out) ::   pe3w , pe3uw, pe3vw         !    -       -      -
+      INTEGER , DIMENSION(:,:)  , INTENT(out) ::   k_top , k_bot               ! first & last ocean level
+      !
+      INTEGER  ::   jk     ! dummy loop index
+      INTEGER  ::   inum   ! local logical unit
+      REAL(WP) ::   z_zco, z_zps, z_sco, z_cav
+      REAL(wp), DIMENSION(jpi,jpj) ::   z2d   ! 2D workspace
+      !!----------------------------------------------------------------------
+      !
+      IF(lwp) THEN
+         WRITE(numout,*)
+         WRITE(numout,*) '   zgr_read : read the vertical coordinates in ', TRIM( cn_domcfg ), ' file'
+         WRITE(numout,*) '   ~~~~~~~~'
+      ENDIF
+      !
+      CALL iom_open( cn_domcfg, inum )
+      !
+      !                          !* type of vertical coordinate
+      CALL iom_get( inum, 'ln_zco'   , z_zco )
+      CALL iom_get( inum, 'ln_zps'   , z_zps )
+      CALL iom_get( inum, 'ln_sco'   , z_sco )
+      IF( z_zco == 0._wp ) THEN   ;   ld_zco = .false.   ;   ELSE   ;   ld_zco = .true.   ;   ENDIF
+      IF( z_zps == 0._wp ) THEN   ;   ld_zps = .false.   ;   ELSE   ;   ld_zps = .true.   ;   ENDIF
+      IF( z_sco == 0._wp ) THEN   ;   ld_sco = .false.   ;   ELSE   ;   ld_sco = .true.   ;   ENDIF
+      !
+      !                          !* ocean cavities under iceshelves
+      CALL iom_get( inum, 'ln_isfcav', z_cav )
+      IF( z_cav == 0._wp ) THEN   ;   ld_isfcav = .false.   ;   ELSE   ;   ld_isfcav = .true.   ;   ENDIF
+      !
+      !                          !* vertical scale factors
+      CALL iom_get( inum, jpdom_unknown, 'e3t_1d'  , pe3t_1d  )                     ! 1D reference coordinate
+      CALL iom_get( inum, jpdom_unknown, 'e3w_1d'  , pe3w_1d  )
+      !
+      CALL iom_get( inum, jpdom_data, 'e3t_0'  , pe3t  , lrowattr=ln_use_jattr )    ! 3D coordinate
+      CALL iom_get( inum, jpdom_data, 'e3u_0'  , pe3u  , lrowattr=ln_use_jattr )
+      CALL iom_get( inum, jpdom_data, 'e3v_0'  , pe3v  , lrowattr=ln_use_jattr )
+      CALL iom_get( inum, jpdom_data, 'e3f_0'  , pe3f  , lrowattr=ln_use_jattr )
+      CALL iom_get( inum, jpdom_data, 'e3w_0'  , pe3w  , lrowattr=ln_use_jattr )
+      CALL iom_get( inum, jpdom_data, 'e3uw_0' , pe3uw , lrowattr=ln_use_jattr )
+      CALL iom_get( inum, jpdom_data, 'e3vw_0' , pe3vw , lrowattr=ln_use_jattr )
+      !
+      !                          !* depths
+      !                                   !- old depth definition (obsolescent feature)
+      IF(  iom_varid( inum, 'gdept_1d', ldstop = .FALSE. ) > 0  .AND.  &
+         & iom_varid( inum, 'gdepw_1d', ldstop = .FALSE. ) > 0  .AND.  &
+         & iom_varid( inum, 'gdept_0' , ldstop = .FALSE. ) > 0  .AND.  &
+         & iom_varid( inum, 'gdepw_0' , ldstop = .FALSE. ) > 0    ) THEN
+         CALL ctl_warn( 'zgr_read : old definition of depths and scale factors used ', & 
+            &           '           depths at t- and w-points read in the domain configuration file')
+         CALL iom_get( inum, jpdom_unknown, 'gdept_1d', pdept_1d )   
+         CALL iom_get( inum, jpdom_unknown, 'gdepw_1d', pdepw_1d )
+         CALL iom_get( inum, jpdom_data   , 'gdept_0' , pdept , lrowattr=ln_use_jattr )
+         CALL iom_get( inum, jpdom_data   , 'gdepw_0' , pdepw , lrowattr=ln_use_jattr )
+         !
+      ELSE                                !- depths computed from e3. scale factors
+         CALL e3_to_depth( pe3t_1d, pe3w_1d, pdept_1d, pdepw_1d )    ! 1D reference depth
+         CALL e3_to_depth( pe3t   , pe3w   , pdept   , pdepw    )    ! 3D depths
+         IF(lwp) THEN
+            WRITE(numout,*)
+            WRITE(numout,*) '              Reference 1D z-coordinate depth and scale factors:'
+            WRITE(numout, "(9x,' level  gdept_1d  gdepw_1d  e3t_1d   e3w_1d  ')" )
+            WRITE(numout, "(10x, i4, 4f9.2)" ) ( jk, pdept_1d(jk), pdepw_1d(jk), pe3t_1d(jk), pe3w_1d(jk), jk = 1, jpk )
+         ENDIF
+      ENDIF
+      !
+      !                          !* ocean top and bottom level
+      CALL iom_get( inum, jpdom_data, 'top_level'    , z2d  , lrowattr=ln_use_jattr )   ! 1st wet T-points (ISF)
+      k_top(:,:) = INT( z2d(:,:) )
+      CALL iom_get( inum, jpdom_data, 'bottom_level' , z2d  , lrowattr=ln_use_jattr )   ! last wet T-points
+      k_bot(:,:) = INT( z2d(:,:) )
+      !
+      ! reference depth for negative bathy (wetting and drying only)
+      IF( ll_wd )  CALL iom_get( inum,  'rn_wd_ref_depth' , ssh_ref   )
+      !
+      CALL iom_close( inum )
+      !
+   END SUBROUTINE zgr_read
+
+
+   SUBROUTINE zgr_top_bot( k_top, k_bot )
+      !!----------------------------------------------------------------------
+      !!                    ***  ROUTINE zgr_top_bot  ***
+      !!
+      !! ** Purpose :   defines the vertical index of ocean bottom (mbk. arrays)
+      !!
+      !! ** Method  :   computes from k_top and k_bot with a minimum value of 1 over land
+      !!
+      !! ** Action  :   mikt, miku, mikv :   vertical indices of the shallowest 
+      !!                                     ocean level at t-, u- & v-points
+      !!                                     (min value = 1)
+      !! ** Action  :   mbkt, mbku, mbkv :   vertical indices of the deeptest 
+      !!                                     ocean level at t-, u- & v-points
+      !!                                     (min value = 1 over land)
+      !!----------------------------------------------------------------------
+      INTEGER , DIMENSION(:,:), INTENT(in) ::   k_top, k_bot   ! top & bottom ocean level indices
+      !
+      INTEGER ::   ji, jj   ! dummy loop indices
+      REAL(wp), DIMENSION(jpi,jpj) ::   zk   ! workspace
+      !!----------------------------------------------------------------------
+      !
+      IF(lwp) WRITE(numout,*)
+      IF(lwp) WRITE(numout,*) '    zgr_top_bot : ocean top and bottom k-index of T-, U-, V- and W-levels '
+      IF(lwp) WRITE(numout,*) '    ~~~~~~~~~~~'
+      !
+      mikt(:,:) = MAX( k_top(:,:) , 1 )    ! top    ocean k-index of T-level (=1 over land)
+      !
+      mbkt(:,:) = MAX( k_bot(:,:) , 1 )    ! bottom ocean k-index of T-level (=1 over land)
+ 
+      !                                    ! N.B.  top     k-index of W-level = mikt
+      !                                    !       bottom  k-index of W-level = mbkt+1
+      DO jj = 1, jpjm1
+         DO ji = 1, jpim1
+            miku(ji,jj) = MAX(  mikt(ji+1,jj  ) , mikt(ji,jj)  )
+            mikv(ji,jj) = MAX(  mikt(ji  ,jj+1) , mikt(ji,jj)  )
+            mikf(ji,jj) = MAX(  mikt(ji  ,jj+1) , mikt(ji,jj), mikt(ji+1,jj  ), mikt(ji+1,jj+1)  )
+            !
+            mbku(ji,jj) = MIN(  mbkt(ji+1,jj  ) , mbkt(ji,jj)  )
+            mbkv(ji,jj) = MIN(  mbkt(ji  ,jj+1) , mbkt(ji,jj)  )
+         END DO
+      END DO
+      ! converte into REAL to use lbc_lnk ; impose a min value of 1 as a zero can be set in lbclnk 
+      zk(:,:) = REAL( miku(:,:), wp )   ;   CALL lbc_lnk( zk, 'U', 1. )   ;   miku(:,:) = MAX( INT( zk(:,:) ), 1 )
+      zk(:,:) = REAL( mikv(:,:), wp )   ;   CALL lbc_lnk( zk, 'V', 1. )   ;   mikv(:,:) = MAX( INT( zk(:,:) ), 1 )
+      zk(:,:) = REAL( mikf(:,:), wp )   ;   CALL lbc_lnk( zk, 'F', 1. )   ;   mikf(:,:) = MAX( INT( zk(:,:) ), 1 )
+      !
+      zk(:,:) = REAL( mbku(:,:), wp )   ;   CALL lbc_lnk( zk, 'U', 1. )   ;   mbku(:,:) = MAX( INT( zk(:,:) ), 1 )
+      zk(:,:) = REAL( mbkv(:,:), wp )   ;   CALL lbc_lnk( zk, 'V', 1. )   ;   mbkv(:,:) = MAX( INT( zk(:,:) ), 1 )
+      !
+   END SUBROUTINE zgr_top_bot
+
+   !!======================================================================
+END MODULE domzgr
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DOM/dtatsd.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DOM/dtatsd.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DOM/dtatsd.F90	(revision 9570)
@@ -0,0 +1,254 @@
+MODULE dtatsd
+   !!======================================================================
+   !!                     ***  MODULE  dtatsd  ***
+   !! Ocean data  :  read ocean Temperature & Salinity Data from gridded data
+   !!======================================================================
+   !! History :  OPA  ! 1991-03  ()  Original code
+   !!             -   ! 1992-07  (M. Imbard)
+   !!            8.0  ! 1999-10  (M.A. Foujols, M. Imbard)  NetCDF FORMAT 
+   !!   NEMO     1.0  ! 2002-06  (G. Madec)  F90: Free form and module 
+   !!            3.3  ! 2010-10  (C. Bricaud, S. Masson)  use of fldread
+   !!            3.4  ! 2010-11  (G. Madec, C. Ethe) Merge of dtatem and dtasal + remove CPP keys
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   dta_tsd      : read and time interpolated ocean Temperature & Salinity Data
+   !!----------------------------------------------------------------------
+   USE oce             ! ocean dynamics and tracers
+   USE phycst          ! physical constants
+   USE dom_oce         ! ocean space and time domain
+   USE fldread         ! read input fields
+   !
+   USE in_out_manager  ! I/O manager
+   USE lib_mpp         ! MPP library
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   dta_tsd_init   ! called by opa.F90
+   PUBLIC   dta_tsd        ! called by istate.F90 and tradmp.90
+
+   !                                  !!* namtsd  namelist : Temperature & Salinity Data *
+   LOGICAL , PUBLIC ::   ln_tsd_init   !: T & S data flag
+   LOGICAL , PUBLIC ::   ln_tsd_dmp    !: internal damping toward input data flag
+
+   TYPE(FLD), ALLOCATABLE, DIMENSION(:) ::   sf_tsd   ! structure of input SST (file informations, fields read)
+
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO Consortium (2010)
+   !! $Id$ 
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE dta_tsd_init( ld_tradmp )
+      !!----------------------------------------------------------------------
+      !!                   ***  ROUTINE dta_tsd_init  ***
+      !!                    
+      !! ** Purpose :   initialisation of T & S input data 
+      !! 
+      !! ** Method  : - Read namtsd namelist
+      !!              - allocates T & S data structure 
+      !!----------------------------------------------------------------------
+      LOGICAL, INTENT(in), OPTIONAL ::   ld_tradmp   ! force the initialization when tradp is used
+      !
+      INTEGER ::   ios, ierr0, ierr1, ierr2, ierr3   ! local integers
+      !!
+      CHARACTER(len=100)            ::   cn_dir          ! Root directory for location of ssr files
+      TYPE(FLD_N), DIMENSION( jpts) ::   slf_i           ! array of namelist informations on the fields to read
+      TYPE(FLD_N)                   ::   sn_tem, sn_sal
+      !!
+      NAMELIST/namtsd/   ln_tsd_init, ln_tsd_dmp, cn_dir, sn_tem, sn_sal
+      !!----------------------------------------------------------------------
+      !
+      !  Initialisation
+      ierr0 = 0  ;  ierr1 = 0  ;  ierr2 = 0  ;  ierr3 = 0
+      !
+      REWIND( numnam_ref )              ! Namelist namtsd in reference namelist : 
+      READ  ( numnam_ref, namtsd, IOSTAT = ios, ERR = 901)
+901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namtsd in reference namelist', lwp )
+      REWIND( numnam_cfg )              ! Namelist namtsd in configuration namelist : Parameters of the run
+      READ  ( numnam_cfg, namtsd, IOSTAT = ios, ERR = 902 )
+902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namtsd in configuration namelist', lwp )
+      IF(lwm) WRITE ( numond, namtsd )
+
+      IF( PRESENT( ld_tradmp ) )   ln_tsd_dmp = .TRUE.     ! forces the initialization when tradmp is used
+      
+      IF(lwp) THEN                  ! control print
+         WRITE(numout,*)
+         WRITE(numout,*) 'dta_tsd_init : Temperature & Salinity data '
+         WRITE(numout,*) '~~~~~~~~~~~~ '
+         WRITE(numout,*) '   Namelist namtsd'
+         WRITE(numout,*) '      Initialisation of ocean T & S with T &S input data   ln_tsd_init = ', ln_tsd_init
+         WRITE(numout,*) '      damping of ocean T & S toward T &S input data        ln_tsd_dmp  = ', ln_tsd_dmp
+         WRITE(numout,*)
+         IF( .NOT.ln_tsd_init .AND. .NOT.ln_tsd_dmp ) THEN
+            WRITE(numout,*)
+            WRITE(numout,*) '   ===>>   T & S data not used'
+         ENDIF
+      ENDIF
+      !
+      IF( ln_rstart .AND. ln_tsd_init ) THEN
+         CALL ctl_warn( 'dta_tsd_init: ocean restart and T & S data intialisation, ',   &
+            &           'we keep the restart T & S values and set ln_tsd_init to FALSE' )
+         ln_tsd_init = .FALSE.
+      ENDIF
+      !
+      !                             ! allocate the arrays (if necessary)
+      IF( ln_tsd_init .OR. ln_tsd_dmp ) THEN
+         !
+         ALLOCATE( sf_tsd(jpts), STAT=ierr0 )
+         IF( ierr0 > 0 ) THEN
+            CALL ctl_stop( 'dta_tsd_init: unable to allocate sf_tsd structure' )   ;   RETURN
+         ENDIF
+         !
+                                ALLOCATE( sf_tsd(jp_tem)%fnow(jpi,jpj,jpk)   , STAT=ierr0 )
+         IF( sn_tem%ln_tint )   ALLOCATE( sf_tsd(jp_tem)%fdta(jpi,jpj,jpk,2) , STAT=ierr1 )
+                                ALLOCATE( sf_tsd(jp_sal)%fnow(jpi,jpj,jpk)   , STAT=ierr2 )
+         IF( sn_sal%ln_tint )   ALLOCATE( sf_tsd(jp_sal)%fdta(jpi,jpj,jpk,2) , STAT=ierr3 )
+         !
+         IF( ierr0 + ierr1 + ierr2 + ierr3 > 0 ) THEN
+            CALL ctl_stop( 'dta_tsd : unable to allocate T & S data arrays' )   ;   RETURN
+         ENDIF
+         !                         ! fill sf_tsd with sn_tem & sn_sal and control print
+         slf_i(jp_tem) = sn_tem   ;   slf_i(jp_sal) = sn_sal
+         CALL fld_fill( sf_tsd, slf_i, cn_dir, 'dta_tsd', 'Temperature & Salinity data', 'namtsd', no_print )
+         !
+      ENDIF
+      !
+   END SUBROUTINE dta_tsd_init
+
+
+   SUBROUTINE dta_tsd( kt, ptsd )
+      !!----------------------------------------------------------------------
+      !!                   ***  ROUTINE dta_tsd  ***
+      !!                    
+      !! ** Purpose :   provides T and S data at kt
+      !! 
+      !! ** Method  : - call fldread routine
+      !!              - ORCA_R2: add some hand made alteration to read data  
+      !!              - 'key_orca_lev10' interpolates on 10 times more levels
+      !!              - s- or mixed z-s coordinate: vertical interpolation on model mesh
+      !!              - ln_tsd_dmp=F: deallocates the T-S data structure
+      !!                as T-S data are no are used
+      !!
+      !! ** Action  :   ptsd   T-S data on medl mesh and interpolated at time-step kt
+      !!----------------------------------------------------------------------
+      INTEGER                              , INTENT(in   ) ::   kt     ! ocean time-step
+      REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(  out) ::   ptsd   ! T & S data
+      !
+      INTEGER ::   ji, jj, jk, jl, jkk   ! dummy loop indicies
+      INTEGER ::   ik, il0, il1, ii0, ii1, ij0, ij1   ! local integers
+      REAL(wp)::   zl, zi                             ! local scalars
+      REAL(wp), DIMENSION(jpk) ::  ztp, zsp   ! 1D workspace
+      !!----------------------------------------------------------------------
+      !
+      CALL fld_read( kt, 1, sf_tsd )      !==   read T & S data at kt time step   ==!
+      !
+      !
+!!gm  This should be removed from the code   ===>>>>  T & S files has to be changed
+      !
+      !                                   !==   ORCA_R2 configuration and T & S damping   ==! 
+      IF( cn_cfg == "orca" .AND. nn_cfg == 2 .AND. ln_tsd_dmp ) THEN    ! some hand made alterations
+         !
+         ij0 = 101   ;   ij1 = 109                       ! Reduced T & S in the Alboran Sea
+         ii0 = 141   ;   ii1 = 155
+         DO jj = mj0(ij0), mj1(ij1)
+            DO ji = mi0(ii0), mi1(ii1)
+               sf_tsd(jp_tem)%fnow(ji,jj,13:13) = sf_tsd(jp_tem)%fnow(ji,jj,13:13) - 0.20_wp
+               sf_tsd(jp_tem)%fnow(ji,jj,14:15) = sf_tsd(jp_tem)%fnow(ji,jj,14:15) - 0.35_wp
+               sf_tsd(jp_tem)%fnow(ji,jj,16:25) = sf_tsd(jp_tem)%fnow(ji,jj,16:25) - 0.40_wp
+               !
+               sf_tsd(jp_sal)%fnow(ji,jj,13:13) = sf_tsd(jp_sal)%fnow(ji,jj,13:13) - 0.15_wp
+               sf_tsd(jp_sal)%fnow(ji,jj,14:15) = sf_tsd(jp_sal)%fnow(ji,jj,14:15) - 0.25_wp
+               sf_tsd(jp_sal)%fnow(ji,jj,16:17) = sf_tsd(jp_sal)%fnow(ji,jj,16:17) - 0.30_wp
+               sf_tsd(jp_sal)%fnow(ji,jj,18:25) = sf_tsd(jp_sal)%fnow(ji,jj,18:25) - 0.35_wp
+            END DO
+         END DO
+         ij0 =  87   ;   ij1 =  96                          ! Reduced temperature in Red Sea
+         ii0 = 148   ;   ii1 = 160
+         sf_tsd(jp_tem)%fnow( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ,  4:10 ) = 7.0_wp
+         sf_tsd(jp_tem)%fnow( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , 11:13 ) = 6.5_wp
+         sf_tsd(jp_tem)%fnow( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , 14:20 ) = 6.0_wp
+      ENDIF
+!!gm end
+      !
+      ptsd(:,:,:,jp_tem) = sf_tsd(jp_tem)%fnow(:,:,:)    ! NO mask
+      ptsd(:,:,:,jp_sal) = sf_tsd(jp_sal)%fnow(:,:,:) 
+      !
+      IF( ln_sco ) THEN                   !==   s- or mixed s-zps-coordinate   ==!
+         !
+         IF( kt == nit000 .AND. lwp )THEN
+            WRITE(numout,*)
+            WRITE(numout,*) 'dta_tsd: interpolates T & S data onto the s- or mixed s-z-coordinate mesh'
+         ENDIF
+         !
+         DO jj = 1, jpj                         ! vertical interpolation of T & S
+            DO ji = 1, jpi
+               DO jk = 1, jpk                        ! determines the intepolated T-S profiles at each (i,j) points
+                  zl = gdept_0(ji,jj,jk)
+                  IF(     zl < gdept_1d(1  ) ) THEN          ! above the first level of data
+                     ztp(jk) =  ptsd(ji,jj,1    ,jp_tem)
+                     zsp(jk) =  ptsd(ji,jj,1    ,jp_sal)
+                  ELSEIF( zl > gdept_1d(jpk) ) THEN          ! below the last level of data
+                     ztp(jk) =  ptsd(ji,jj,jpkm1,jp_tem)
+                     zsp(jk) =  ptsd(ji,jj,jpkm1,jp_sal)
+                  ELSE                                      ! inbetween : vertical interpolation between jkk & jkk+1
+                     DO jkk = 1, jpkm1                                  ! when  gdept(jkk) < zl < gdept(jkk+1)
+                        IF( (zl-gdept_1d(jkk)) * (zl-gdept_1d(jkk+1)) <= 0._wp ) THEN
+                           zi = ( zl - gdept_1d(jkk) ) / (gdept_1d(jkk+1)-gdept_1d(jkk))
+                           ztp(jk) = ptsd(ji,jj,jkk,jp_tem) + ( ptsd(ji,jj,jkk+1,jp_tem) - ptsd(ji,jj,jkk,jp_tem) ) * zi 
+                           zsp(jk) = ptsd(ji,jj,jkk,jp_sal) + ( ptsd(ji,jj,jkk+1,jp_sal) - ptsd(ji,jj,jkk,jp_sal) ) * zi
+                        ENDIF
+                     END DO
+                  ENDIF
+               END DO
+               DO jk = 1, jpkm1
+                  ptsd(ji,jj,jk,jp_tem) = ztp(jk) * tmask(ji,jj,jk)     ! mask required for mixed zps-s-coord
+                  ptsd(ji,jj,jk,jp_sal) = zsp(jk) * tmask(ji,jj,jk)
+               END DO
+               ptsd(ji,jj,jpk,jp_tem) = 0._wp
+               ptsd(ji,jj,jpk,jp_sal) = 0._wp
+            END DO
+         END DO
+         ! 
+      ELSE                                !==   z- or zps- coordinate   ==!
+         !                             
+         ptsd(:,:,:,jp_tem) = ptsd(:,:,:,jp_tem) * tmask(:,:,:)    ! Mask
+         ptsd(:,:,:,jp_sal) = ptsd(:,:,:,jp_sal) * tmask(:,:,:)
+         !
+         IF( ln_zps ) THEN                      ! zps-coordinate (partial steps) interpolation at the last ocean level
+            DO jj = 1, jpj
+               DO ji = 1, jpi
+                  ik = mbkt(ji,jj) 
+                  IF( ik > 1 ) THEN
+                     zl = ( gdept_1d(ik) - gdept_0(ji,jj,ik) ) / ( gdept_1d(ik) - gdept_1d(ik-1) )
+                     ptsd(ji,jj,ik,jp_tem) = (1.-zl) * ptsd(ji,jj,ik,jp_tem) + zl * ptsd(ji,jj,ik-1,jp_tem)
+                     ptsd(ji,jj,ik,jp_sal) = (1.-zl) * ptsd(ji,jj,ik,jp_sal) + zl * ptsd(ji,jj,ik-1,jp_sal)
+                  ENDIF
+                  ik = mikt(ji,jj)
+                  IF( ik > 1 ) THEN
+                     zl = ( gdept_0(ji,jj,ik) - gdept_1d(ik) ) / ( gdept_1d(ik+1) - gdept_1d(ik) ) 
+                     ptsd(ji,jj,ik,jp_tem) = (1.-zl) * ptsd(ji,jj,ik,jp_tem) + zl * ptsd(ji,jj,ik+1,jp_tem)
+                     ptsd(ji,jj,ik,jp_sal) = (1.-zl) * ptsd(ji,jj,ik,jp_sal) + zl * ptsd(ji,jj,ik+1,jp_sal)
+                  END IF
+               END DO
+            END DO
+         ENDIF
+         !
+      ENDIF
+      !
+      IF( .NOT.ln_tsd_dmp ) THEN                   !==   deallocate T & S structure   ==! 
+         !                                              (data used only for initialisation)
+         IF(lwp) WRITE(numout,*) 'dta_tsd: deallocte T & S arrays as they are only use to initialize the run'
+                                        DEALLOCATE( sf_tsd(jp_tem)%fnow )     ! T arrays in the structure
+         IF( sf_tsd(jp_tem)%ln_tint )   DEALLOCATE( sf_tsd(jp_tem)%fdta )
+                                        DEALLOCATE( sf_tsd(jp_sal)%fnow )     ! S arrays in the structure
+         IF( sf_tsd(jp_sal)%ln_tint )   DEALLOCATE( sf_tsd(jp_sal)%fdta )
+                                        DEALLOCATE( sf_tsd              )     ! the structure itself
+      ENDIF
+      !
+   END SUBROUTINE dta_tsd
+
+   !!======================================================================
+END MODULE dtatsd
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DOM/iscplhsb.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DOM/iscplhsb.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DOM/iscplhsb.F90	(revision 9570)
@@ -0,0 +1,324 @@
+MODULE iscplhsb
+   !!======================================================================
+   !!                       ***  MODULE  iscplhsb  ***
+   !! Ocean forcing: ice sheet/ocean coupling (conservation)
+   !!=====================================================================
+   !! History :  NEMO  ! 2015-01 P. Mathiot: original 
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   iscpl_alloc    : variable allocation
+   !!   iscpl_hsb      : compute and store the input of heat/salt/volume 
+   !!                    into the system due to the coupling process
+   !!   iscpl_div      : correction of divergence to keep volume conservation
+   !!----------------------------------------------------------------------
+   USE oce             ! global tra/dyn variable
+   USE dom_oce         ! ocean space and time domain
+   USE domwri          ! ocean space and time domain
+   USE domngb          ! 
+   USE phycst          ! physical constants
+   USE sbc_oce         ! surface boundary condition variables
+   USE iscplini        ! 
+   !
+   USE in_out_manager  ! I/O manager
+   USE lib_mpp         ! MPP library
+   USE lib_fortran     ! MPP library
+   USE lbclnk          !
+
+   IMPLICIT NONE
+   PRIVATE
+   
+   PUBLIC   iscpl_div   
+   PUBLIC   iscpl_cons       
+   !! * Substitutions  
+#  include "vectopt_loop_substitute.h90"
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO Consortium (2010)
+   !! $Id: sbcrnf.F90 4666 2014-06-11 12:52:23Z mathiot $
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE iscpl_cons(ptmask_b, psmask_b, pe3t_b, pts_flx, pvol_flx, prdt_iscpl)
+      !!---------------------------------------------------------------------- 
+      !!                   ***  ROUTINE iscpl_cons  ***
+      !! 
+      !! ** Purpose :   compute input into the system during the coupling step
+      !!                compute the correction term
+      !!                compute where the correction have to be applied
+      !! 
+      !! ** Method  :   compute tsn*e3t-tsb*e3tb and e3t-e3t_b
+      !!----------------------------------------------------------------------
+      REAL(wp), DIMENSION(:,:,:  ), INTENT(in ) :: ptmask_b    !! mask before
+      REAL(wp), DIMENSION(:,:,:  ), INTENT(in ) :: pe3t_b      !! scale factor before
+      REAL(wp), DIMENSION(:,:    ), INTENT(in ) :: psmask_b    !! mask before
+      REAL(wp), DIMENSION(:,:,:,:), INTENT(out) :: pts_flx     !! corrective flux to have tracer conservation
+      REAL(wp), DIMENSION(:,:,:  ), INTENT(out) :: pvol_flx    !! corrective flux to have volume conservation
+      REAL(wp),                     INTENT(in ) :: prdt_iscpl  !! coupling period 
+      !
+      INTEGER  ::   ji  , jj  , jk           ! loop index
+      INTEGER  ::   jip1, jim1, jjp1, jjm1
+      REAL(wp) ::   summsk, zsum , zsumn, zjip1_ratio  , zjim1_ratio, zdtem, zde3t, z1_rdtiscpl
+      REAL(wp) ::   zarea , zsum1, zsumb, zjjp1_ratio  , zjjm1_ratio, zdsal
+      REAL(wp), DIMENSION(jpi,jpj)        ::   zdssh   ! workspace
+      REAL(wp), DIMENSION(:), ALLOCATABLE ::   zlon, zlat
+      REAL(wp), DIMENSION(:), ALLOCATABLE ::   zcorr_vol, zcorr_tem, zcorr_sal
+      INTEGER , DIMENSION(:), ALLOCATABLE ::   ixpts, iypts, izpts, inpts
+      INTEGER :: jpts, npts
+      !!----------------------------------------------------------------------
+
+      ! get imbalance (volume heat and salt)
+      ! initialisation difference
+      zde3t = 0._wp   ;   zdsal = 0._wp   ;   zdtem = 0._wp
+
+      ! initialisation correction term
+      pvol_flx(:,:,:  ) = 0._wp
+      pts_flx (:,:,:,:) = 0._wp
+      
+      z1_rdtiscpl = 1._wp / prdt_iscpl 
+
+      ! mask tsn and tsb 
+      tsb(:,:,:,jp_tem) = tsb(:,:,:,jp_tem) * ptmask_b(:,:,:)
+      tsn(:,:,:,jp_tem) = tsn(:,:,:,jp_tem) *  tmask  (:,:,:)
+      tsb(:,:,:,jp_sal) = tsb(:,:,:,jp_sal) * ptmask_b(:,:,:)
+      tsn(:,:,:,jp_sal) = tsn(:,:,:,jp_sal) *  tmask  (:,:,:)
+
+      !==============================================================================
+      ! diagnose the heat, salt and volume input and compute the correction variable
+      !==============================================================================
+
+      ! 
+      zdssh(:,:) = sshn(:,:) * ssmask(:,:) - sshb(:,:) * psmask_b(:,:)
+      IF (.NOT. ln_linssh ) zdssh = 0.0_wp ! already included in the levels by definition
+      
+      DO jk = 1,jpk-1
+         DO jj = 2,jpj-1
+            DO ji = fs_2,fs_jpim1
+               IF (tmask_h(ji,jj) == 1._wp) THEN
+
+                  ! volume differences
+                  zde3t = e3t_n(ji,jj,jk) * tmask(ji,jj,jk) - pe3t_b(ji,jj,jk) * ptmask_b(ji,jj,jk)
+
+                  ! heat diff
+                  zdtem = tsn(ji,jj,jk,jp_tem) * e3t_n(ji,jj,jk) *  tmask  (ji,jj,jk)   &
+                        - tsb(ji,jj,jk,jp_tem) * pe3t_b (ji,jj,jk) * ptmask_b(ji,jj,jk)
+                  ! salt diff
+                  zdsal = tsn(ji,jj,jk,jp_sal) * e3t_n(ji,jj,jk) *  tmask  (ji,jj,jk)   &
+                        - tsb(ji,jj,jk,jp_sal) * pe3t_b (ji,jj,jk) * ptmask_b(ji,jj,jk)
+               
+                  ! shh changes
+                  IF ( ptmask_b(ji,jj,jk) == 1._wp .OR. tmask(ji,jj,jk) == 1._wp ) THEN 
+                     zde3t = zde3t + zdssh(ji,jj) ! zdssh = 0 if vvl
+                     zdssh(ji,jj) = 0._wp
+                  END IF
+
+                  ! volume, heat and salt differences in each cell 
+                  pvol_flx(ji,jj,jk)       =   pvol_flx(ji,jj,jk)        + zde3t * z1_rdtiscpl
+                  pts_flx (ji,jj,jk,jp_sal)=   pts_flx (ji,jj,jk,jp_sal) + zdsal * z1_rdtiscpl 
+                  pts_flx (ji,jj,jk,jp_tem)=   pts_flx (ji,jj,jk,jp_tem) + zdtem * z1_rdtiscpl
+
+                  ! case where we close a cell: check if the neighbour cells are wet 
+                  IF ( tmask(ji,jj,jk) == 0._wp .AND. ptmask_b(ji,jj,jk) == 1._wp ) THEN
+
+                     jip1=ji+1 ; jim1=ji-1 ; jjp1=jj+1 ; jjm1=jj-1 ;
+
+                     zsum =   e1e2t(ji  ,jjp1) * tmask(ji  ,jjp1,jk) + e1e2t(ji  ,jjm1) * tmask(ji  ,jjm1,jk) &
+                       &    + e1e2t(jim1,jj  ) * tmask(jim1,jj  ,jk) + e1e2t(jip1,jj  ) * tmask(jip1,jj  ,jk)
+
+                     IF ( zsum /= 0._wp ) THEN
+                        zjip1_ratio   = e1e2t(jip1,jj  ) * tmask(jip1,jj  ,jk) / zsum
+                        zjim1_ratio   = e1e2t(jim1,jj  ) * tmask(jim1,jj  ,jk) / zsum
+                        zjjp1_ratio   = e1e2t(ji  ,jjp1) * tmask(ji  ,jjp1,jk) / zsum
+                        zjjm1_ratio   = e1e2t(ji  ,jjm1) * tmask(ji  ,jjm1,jk) / zsum
+
+                        pvol_flx(ji  ,jjp1,jk       ) = pvol_flx(ji  ,jjp1,jk       ) + pvol_flx(ji,jj,jk       ) * zjjp1_ratio
+                        pvol_flx(ji  ,jjm1,jk       ) = pvol_flx(ji  ,jjm1,jk       ) + pvol_flx(ji,jj,jk       ) * zjjm1_ratio
+                        pvol_flx(jip1,jj  ,jk       ) = pvol_flx(jip1,jj  ,jk       ) + pvol_flx(ji,jj,jk       ) * zjip1_ratio
+                        pvol_flx(jim1,jj  ,jk       ) = pvol_flx(jim1,jj  ,jk       ) + pvol_flx(ji,jj,jk       ) * zjim1_ratio
+                        pts_flx (ji  ,jjp1,jk,jp_sal) = pts_flx (ji  ,jjp1,jk,jp_sal) + pts_flx (ji,jj,jk,jp_sal) * zjjp1_ratio
+                        pts_flx (ji  ,jjm1,jk,jp_sal) = pts_flx (ji  ,jjm1,jk,jp_sal) + pts_flx (ji,jj,jk,jp_sal) * zjjm1_ratio
+                        pts_flx (jip1,jj  ,jk,jp_sal) = pts_flx (jip1,jj  ,jk,jp_sal) + pts_flx (ji,jj,jk,jp_sal) * zjip1_ratio
+                        pts_flx (jim1,jj  ,jk,jp_sal) = pts_flx (jim1,jj  ,jk,jp_sal) + pts_flx (ji,jj,jk,jp_sal) * zjim1_ratio
+                        pts_flx (ji  ,jjp1,jk,jp_tem) = pts_flx (ji  ,jjp1,jk,jp_tem) + pts_flx (ji,jj,jk,jp_tem) * zjjp1_ratio
+                        pts_flx (ji  ,jjm1,jk,jp_tem) = pts_flx (ji  ,jjm1,jk,jp_tem) + pts_flx (ji,jj,jk,jp_tem) * zjjm1_ratio
+                        pts_flx (jip1,jj  ,jk,jp_tem) = pts_flx (jip1,jj  ,jk,jp_tem) + pts_flx (ji,jj,jk,jp_tem) * zjip1_ratio
+                        pts_flx (jim1,jj  ,jk,jp_tem) = pts_flx (jim1,jj  ,jk,jp_tem) + pts_flx (ji,jj,jk,jp_tem) * zjim1_ratio
+
+                        ! set to 0 the cell we distributed over neigbourg cells
+                        pvol_flx(ji,jj,jk       ) = 0._wp
+                        pts_flx (ji,jj,jk,jp_sal) = 0._wp
+                        pts_flx (ji,jj,jk,jp_tem) = 0._wp
+
+                     ELSE IF (zsum == 0._wp ) THEN
+                        ! case where we close a cell and no adjacent cell open
+                        ! check if the cell beneath is wet
+                        IF ( tmask(ji,jj,jk+1) == 1._wp ) THEN
+                           pvol_flx(ji,jj,jk+1)       =  pvol_flx(ji,jj,jk+1)        + pvol_flx(ji,jj,jk)
+                           pts_flx (ji,jj,jk+1,jp_sal)=  pts_flx (ji,jj,jk+1,jp_sal) + pts_flx (ji,jj,jk,jp_sal)
+                           pts_flx (ji,jj,jk+1,jp_tem)=  pts_flx (ji,jj,jk+1,jp_tem) + pts_flx (ji,jj,jk,jp_tem)
+
+                           ! set to 0 the cell we distributed over neigbourg cells
+                           pvol_flx(ji,jj,jk       ) = 0._wp
+                           pts_flx (ji,jj,jk,jp_sal) = 0._wp
+                           pts_flx (ji,jj,jk,jp_tem) = 0._wp
+                        ELSE
+                        ! case no adjacent cell on the horizontal and on the vertical
+                           IF ( lwp ) THEN   ! JMM : cAution this warning may occur on any mpp subdomain but numout is only
+                                             ! open for narea== 1 (lwp=T)
+                           WRITE(numout,*) 'W A R N I N G iscpl: no adjacent cell on the vertical and horizontal'
+                           WRITE(numout,*) '                     ',mig(ji),' ',mjg(jj),' ',jk
+                           WRITE(numout,*) '                     ',ji,' ',jj,' ',jk,' ',narea
+                           WRITE(numout,*) ' we are now looking for the closest wet cell on the horizontal '
+                           ENDIF
+                        ! We deal with these points later.
+                        END IF
+                     END IF
+                  END IF
+               END IF
+            END DO
+         END DO
+      END DO
+
+!!gm  ERROR !!!!
+!!    juste use tmask_i  or in case of ISF smask_i (to be created to compute the sum without halos)
+!
+!      CALL lbc_sum(pvol_flx(:,:,:       ),'T',1.)
+!      CALL lbc_sum(pts_flx (:,:,:,jp_sal),'T',1.)
+!      CALL lbc_sum(pts_flx (:,:,:,jp_tem),'T',1.)
+      STOP ' iscpl_cons:   please modify this module !'
+!!gm end
+      ! if no neighbour wet cell in case of 2close a cell", need to find the nearest wet point 
+      ! allocation and initialisation of the list of problematic point
+      ALLOCATE( inpts(jpnij) )
+      inpts(:) = 0
+
+      ! fill narea location with the number of problematic point
+      DO jk = 1,jpk-1
+         DO jj = 2,jpj-1
+            DO ji = fs_2,fs_jpim1
+               IF (     ptmask_b(ji,jj,jk) == 1._wp .AND. tmask(ji,jj,jk+1)  == 0._wp .AND. tmask_h(ji,jj) == 1._wp  &
+                  .AND. SUM(tmask(ji-1:ji+1,jj,jk)) + SUM(tmask(ji,jj-1:jj+1,jk)) == 0._wp) THEN
+                  inpts(narea) = inpts(narea) + 1 
+               END IF
+            END DO
+         END DO
+      END DO
+
+      ! build array of total problematic point on each cpu (share to each cpu)
+      CALL mpp_max(inpts,jpnij) 
+
+      ! size of the new variable
+      npts  = SUM(inpts)    
+      
+      ! allocation of the coordinates, correction, index vector for the problematic points 
+      ALLOCATE(ixpts(npts), iypts(npts), izpts(npts), zcorr_vol(npts), zcorr_sal(npts), zcorr_tem(npts), zlon(npts), zlat(npts))
+      ixpts(:) = -9999 ; iypts(:) = -9999 ; izpts(:) = -9999 ; zlon(:) = -1.0e20_wp ; zlat(:) = -1.0e20_wp
+      zcorr_vol(:) = -1.0e20_wp
+      zcorr_sal(:) = -1.0e20_wp
+      zcorr_tem(:) = -1.0e20_wp
+
+      ! fill new variable
+      jpts = SUM(inpts(1:narea-1))
+      DO jk = 1,jpk-1
+         DO jj = 2,jpj-1
+            DO ji = fs_2,fs_jpim1
+               IF (     ptmask_b(ji,jj,jk) == 1._wp .AND. tmask(ji,jj,jk+1)  == 0._wp .AND. tmask_h(ji,jj) == 1._wp  &
+                  .AND. SUM(tmask(ji-1:ji+1,jj,jk)) + SUM(tmask(ji,jj-1:jj+1,jk)) == 0._wp) THEN
+                  jpts = jpts + 1  ! positioning in the inpts vector for the area narea
+                  ixpts(jpts) = ji           ; iypts(jpts) = jj ; izpts(jpts) = jk
+                  zlon (jpts) = glamt(ji,jj) ; zlat (jpts) = gphit(ji,jj)
+                  zcorr_vol(jpts) = pvol_flx(ji,jj,jk)
+                  zcorr_sal(jpts) = pts_flx (ji,jj,jk,jp_sal)
+                  zcorr_tem(jpts) = pts_flx (ji,jj,jk,jp_tem)
+
+                  ! set flx to 0 (safer)
+                  pvol_flx(ji,jj,jk       ) = 0.0_wp
+                  pts_flx (ji,jj,jk,jp_sal) = 0.0_wp
+                  pts_flx (ji,jj,jk,jp_tem) = 0.0_wp
+               END IF
+            END DO
+         END DO
+      END DO
+
+      ! build array of total problematic point on each cpu (share to each cpu)
+      ! point coordinates
+      CALL mpp_max(zlat ,npts)
+      CALL mpp_max(zlon ,npts)
+      CALL mpp_max(izpts,npts)
+
+      ! correction values 
+      CALL mpp_max(zcorr_vol,npts)
+      CALL mpp_max(zcorr_sal,npts)
+      CALL mpp_max(zcorr_tem,npts)
+
+      ! put correction term in the closest cell          
+      DO jpts = 1,npts
+         CALL dom_ngb(zlon(jpts), zlat(jpts), ixpts(jpts), iypts(jpts),'T', izpts(jpts))
+         DO jj = mj0(iypts(jpts)),mj1(iypts(jpts))
+            DO ji = mi0(ixpts(jpts)),mi1(ixpts(jpts))
+               jk = izpts(jpts)
+
+               IF (tmask_h(ji,jj) == 1._wp) THEN
+                  ! correct the vol_flx in the closest cell
+                  pvol_flx(ji,jj,jk)        =  pvol_flx(ji,jj,jk       ) + zcorr_vol(jpts)
+                  pts_flx (ji,jj,jk,jp_sal) =  pts_flx (ji,jj,jk,jp_sal) + zcorr_sal(jpts)
+                  pts_flx (ji,jj,jk,jp_tem) =  pts_flx (ji,jj,jk,jp_tem) + zcorr_tem(jpts)
+
+                  ! set correction to 0
+                  zcorr_vol(jpts) = 0.0_wp
+                  zcorr_sal(jpts) = 0.0_wp
+                  zcorr_tem(jpts) = 0.0_wp
+               END IF
+            END DO
+         END DO
+      END DO
+
+      ! deallocate variables 
+      DEALLOCATE(inpts)
+      DEALLOCATE(ixpts, iypts, izpts, zcorr_vol, zcorr_sal, zcorr_tem, zlon, zlat)
+    
+      ! add contribution store on the hallo (lbclnk remove one of the contribution)
+      pvol_flx(:,:,:       ) = pvol_flx(:,:,:       ) * tmask(:,:,:)
+      pts_flx (:,:,:,jp_sal) = pts_flx (:,:,:,jp_sal) * tmask(:,:,:)
+      pts_flx (:,:,:,jp_tem) = pts_flx (:,:,:,jp_tem) * tmask(:,:,:)
+
+!!gm  ERROR !!!!
+!!    juste use tmask_i  or in case of ISF smask_i (to be created to compute the sum without halos)
+!
+!      ! compute sum over the halo and set it to 0.
+!      CALL lbc_sum(pvol_flx(:,:,:       ),'T',1._wp)
+!      CALL lbc_sum(pts_flx (:,:,:,jp_sal),'T',1._wp)
+!      CALL lbc_sum(pts_flx (:,:,:,jp_tem),'T',1._wp)
+!!gm end
+
+      !
+   END SUBROUTINE iscpl_cons
+
+
+   SUBROUTINE iscpl_div( phdivn )
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE iscpl_div  ***
+      !!
+      !! ** Purpose :   update the horizontal divergenc
+      !!
+      !! ** Method  :
+      !!                CAUTION : iscpl is positive (inflow) and expressed in m/s
+      !!
+      !! ** Action  :   phdivn   increase by the iscpl correction term
+      !!----------------------------------------------------------------------
+      REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   phdivn   ! horizontal divergence
+      !!
+      INTEGER  ::   ji, jj, jk   ! dummy loop indices
+      !!----------------------------------------------------------------------
+      !
+      DO jk = 1, jpk
+         DO jj = 1, jpj
+            DO ji = 1, jpi
+               phdivn(ji,jj,jk) = phdivn(ji,jj,jk) + hdiv_iscpl(ji,jj,jk) / e3t_n(ji,jj,jk)
+            END DO
+         END DO
+      END DO
+      !
+   END SUBROUTINE iscpl_div
+
+END MODULE iscplhsb
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DOM/iscplini.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DOM/iscplini.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DOM/iscplini.F90	(revision 9570)
@@ -0,0 +1,90 @@
+MODULE iscplini
+   !!======================================================================
+   !!                       ***  MODULE  sbciscpl  ***
+   !! Ocean forcing:  ?????
+   !!=====================================================================
+   !! History :  NEMO  ! 2015-01 P. Mathiot: original 
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   iscpl_init     : initialisation routine (namelist)
+   !!   iscpl_alloc    : allocation of correction variables
+   !!----------------------------------------------------------------------
+   USE oce             ! global tra/dyn variable
+   USE dom_oce         ! ocean space and time domain
+   !
+   USE lib_mpp         ! MPP library
+   USE lib_fortran     ! MPP library
+   USE in_out_manager  ! I/O manager
+
+   IMPLICIT NONE
+   PRIVATE
+   
+   PUBLIC   iscpl_init      
+   PUBLIC   iscpl_alloc 
+   
+   !                                 !!* namsbc_iscpl namelist *
+   LOGICAL , PUBLIC ::   ln_hsb       !:
+   INTEGER , PUBLIC ::   nn_fiscpl    !:
+   INTEGER , PUBLIC ::   nn_drown     !:
+   
+   INTEGER , PUBLIC ::   nstp_iscpl   !:
+   REAL(wp), PUBLIC ::   rdt_iscpl    !: 
+   !
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)   ::   hdiv_iscpl   !:
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) ::   htsc_iscpl   !:
+
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 4.0 , NEMO Consortium (2017)
+   !! $Id:$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   INTEGER FUNCTION iscpl_alloc()
+      !!----------------------------------------------------------------------
+      !!                ***  ROUTINE sbc_iscpl_alloc  ***
+      !!----------------------------------------------------------------------
+      ALLOCATE( htsc_iscpl(jpi,jpj,jpk,jpts) , hdiv_iscpl(jpi,jpj,jpk) , STAT=iscpl_alloc )
+         !
+      IF( lk_mpp          )   CALL mpp_sum ( iscpl_alloc )
+      IF( iscpl_alloc > 0 )   CALL ctl_warn('iscpl_alloc: allocation of arrays failed')
+   END FUNCTION iscpl_alloc
+
+
+   SUBROUTINE iscpl_init()
+      !!----------------------------------------------------------------------
+      !!----------------------------------------------------------------------
+      INTEGER ::   ios           ! Local integer output status for namelist read
+      NAMELIST/namsbc_iscpl/ nn_fiscpl, ln_hsb, nn_drown
+      !!----------------------------------------------------------------------
+      !
+      nn_fiscpl = 0
+      ln_hsb    = .FALSE.
+      REWIND( numnam_ref )              ! Namelist namsbc_iscpl in reference namelist : Ice sheet coupling
+      READ  ( numnam_ref, namsbc_iscpl, IOSTAT = ios, ERR = 901)
+901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namsbc_iscpl in reference namelist', lwp )
+      REWIND( numnam_cfg )              ! Namelist namsbc_iscpl in configuration namelist : Ice Sheet coupling
+      READ  ( numnam_cfg, namsbc_iscpl, IOSTAT = ios, ERR = 902 )
+902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namsbc_iscpl in configuration namelist', lwp )
+      IF(lwm) WRITE ( numond, namsbc_iscpl )
+      !
+      nstp_iscpl=MIN( nn_fiscpl, nitend-nit000+1 ) ! the coupling period have to be less or egal than the total number of time step
+      rdt_iscpl = nstp_iscpl * rn_rdt
+      !
+      IF (lwp) THEN
+         WRITE(numout,*) 'iscpl_rst:'
+         WRITE(numout,*) '~~~~~~~~~'
+         WRITE(numout,*) ' coupling     flag (ln_iscpl )            = ', ln_iscpl
+         WRITE(numout,*) ' conservation flag (ln_hsb   )            = ', ln_hsb
+         WRITE(numout,*) ' nb of stp for cons (rn_fiscpl)           = ', nstp_iscpl
+         IF (nstp_iscpl .NE. nn_fiscpl) WRITE(numout,*) 'W A R N I N G: nb of stp for cons has been modified &
+            &                                           (larger than run length)'
+         WRITE(numout,*) ' coupling time step                       = ', rdt_iscpl
+         WRITE(numout,*) ' number of call of the extrapolation loop = ', nn_drown
+      ENDIF
+      !
+   END SUBROUTINE iscpl_init
+
+   !!======================================================================
+END MODULE iscplini
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DOM/iscplrst.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DOM/iscplrst.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DOM/iscplrst.F90	(revision 9570)
@@ -0,0 +1,407 @@
+MODULE iscplrst
+   !!======================================================================
+   !!                       ***  MODULE  iscplrst  ***
+   !! Ocean forcing: update the restart file in case of ice sheet/ocean coupling
+   !!=====================================================================
+   !! History :  NEMO  ! 2015-01 P. Mathiot: original 
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   iscpl_stp          : step management
+   !!   iscpl_rst_interpol : restart interpolation in case of coupling with ice sheet
+   !!----------------------------------------------------------------------
+   USE oce             ! global tra/dyn variable
+   USE dom_oce         ! ocean space and time domain
+   USE domwri          ! ocean space and time domain
+   USE domvvl   , ONLY : dom_vvl_interpol
+   USE phycst          ! physical constants
+   USE sbc_oce         ! surface boundary condition variables
+   USE iscplini        ! ice sheet coupling: initialisation
+   USE iscplhsb        ! ice sheet coupling: conservation
+   !
+   USE in_out_manager  ! I/O manager
+   USE iom             ! I/O module
+   USE lib_mpp         ! MPP library
+   USE lib_fortran     ! MPP library
+   USE lbclnk          ! communication
+
+   IMPLICIT NONE
+   PRIVATE
+   
+   PUBLIC   iscpl_stp          ! step management 
+   !!
+   !! * Substitutions  
+#  include "vectopt_loop_substitute.h90"
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO Consortium (2010)
+   !! $Id: sbcrnf.F90 4666 2014-06-11 12:52:23Z mathiot $
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE iscpl_stp
+      !!---------------------------------------------------------------------- 
+      !!                   ***  ROUTINE iscpl_stp  ***
+      !! 
+      !! ** Purpose : compute initialisation
+      !!              compute extrapolation of restart variable un, vn, tsn, sshn (wetting/drying)   
+      !!              compute correction term if needed
+      !! 
+      !!----------------------------------------------------------------------
+      INTEGER  ::   inum0
+      REAL(wp), DIMENSION(jpi,jpj)     ::   zsmask_b
+      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   ztmask_b, zumask_b, zvmask_b
+      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   ze3t_b  , ze3u_b  , ze3v_b  
+      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zdepw_b
+      CHARACTER(20) :: cfile
+      !!----------------------------------------------------------------------
+      !
+      !                       ! get restart variable
+      CALL iom_get( numror, jpdom_autoglo, 'tmask'  , ztmask_b, ldxios = lrxios   ) ! need to extrapolate T/S
+      CALL iom_get( numror, jpdom_autoglo, 'umask'  , zumask_b, ldxios = lrxios   ) ! need to correct barotropic velocity
+      CALL iom_get( numror, jpdom_autoglo, 'vmask'  , zvmask_b, ldxios = lrxios   ) ! need to correct barotropic velocity
+      CALL iom_get( numror, jpdom_autoglo, 'smask'  , zsmask_b, ldxios = lrxios   ) ! need to correct barotropic velocity
+      CALL iom_get( numror, jpdom_autoglo, 'e3t_n'  , ze3t_b(:,:,:), ldxios = lrxios )  ! need to compute temperature correction
+      CALL iom_get( numror, jpdom_autoglo, 'e3u_n'  , ze3u_b(:,:,:), ldxios = lrxios )  ! need to correct barotropic velocity
+      CALL iom_get( numror, jpdom_autoglo, 'e3v_n'  , ze3v_b(:,:,:), ldxios = lrxios )  ! need to correct barotropic velocity
+      CALL iom_get( numror, jpdom_autoglo, 'gdepw_n', zdepw_b(:,:,:), ldxios = lrxios ) ! need to interpol vertical profile (vvl)
+      !
+      CALL iscpl_init()       ! read namelist
+      !                       ! Extrapolation/interpolation of modify cell and new cells ... (maybe do it later after domvvl)
+      CALL iscpl_rst_interpol( ztmask_b, zumask_b, zvmask_b, zsmask_b, ze3t_b, ze3u_b, ze3v_b, zdepw_b )
+      !
+      IF ( ln_hsb ) THEN      ! compute correction if conservation needed
+         IF( iscpl_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'rst_iscpl : unable to allocate rst_iscpl arrays' )
+         CALL iscpl_cons(ztmask_b, zsmask_b, ze3t_b, htsc_iscpl, hdiv_iscpl, rdt_iscpl)
+      END IF
+         
+      !                       ! create  a domain file
+      IF( ln_meshmask .AND. ln_iscpl )   CALL dom_wri
+      !
+      IF ( ln_hsb ) THEN
+         cfile='correction'
+         cfile = TRIM( cfile )
+         CALL iom_open  ( cfile, inum0, ldwrt = .TRUE., kiolib = jprstlib )
+         CALL iom_rstput( 0, 0, inum0, 'vol_cor', hdiv_iscpl(:,:,:) )
+         CALL iom_rstput( 0, 0, inum0, 'tem_cor', htsc_iscpl(:,:,:,jp_tem) )
+         CALL iom_rstput( 0, 0, inum0, 'sal_cor', htsc_iscpl(:,:,:,jp_sal) )
+         CALL iom_close ( inum0 )
+      END IF
+      !
+      neuler = 0              ! next step is an euler time step
+      !
+      !                       ! set _b and _n variables equal
+      tsb (:,:,:,:) = tsn (:,:,:,:)
+      ub  (:,:,:)   = un  (:,:,:)
+      vb  (:,:,:)   = vn  (:,:,:)
+      sshb(:,:)     = sshn(:,:)
+      !
+      !                       ! set _b and _n vertical scale factor equal
+      e3t_b (:,:,:) = e3t_n (:,:,:)
+      e3u_b (:,:,:) = e3u_n (:,:,:)
+      e3v_b (:,:,:) = e3v_n (:,:,:)
+      !
+      e3uw_b (:,:,:) = e3uw_n (:,:,:)
+      e3vw_b (:,:,:) = e3vw_n (:,:,:)
+      gdept_b(:,:,:) = gdept_n(:,:,:)
+      gdepw_b(:,:,:) = gdepw_n(:,:,:)
+      hu_b   (:,:)   = hu_n   (:,:)
+      hv_b   (:,:)   = hv_n   (:,:)
+      r1_hu_b(:,:)   = r1_hu_n(:,:)
+      r1_hv_b(:,:)   = r1_hv_n(:,:)
+      !
+   END SUBROUTINE iscpl_stp
+
+
+   SUBROUTINE iscpl_rst_interpol (ptmask_b, pumask_b, pvmask_b, psmask_b, pe3t_b, pe3u_b, pe3v_b, pdepw_b)
+      !!---------------------------------------------------------------------- 
+      !!                   ***  ROUTINE iscpl_rst_interpol  ***
+      !! 
+      !! ** Purpose :   compute new tn, sn, un, vn and sshn in case of evolving geometry of ice shelves 
+      !!                compute 2d fields of heat, salt and volume correction
+      !! 
+      !! ** Method  :   tn, sn : extrapolation from neigbourg cells
+      !!                un, vn : fill with 0 velocity and keep barotropic transport by modifing surface velocity or adjacent velocity
+      !!----------------------------------------------------------------------
+      REAL(wp), DIMENSION(:,:,:  ), INTENT(in ) :: ptmask_b, pumask_b, pvmask_b    !! mask before
+      REAL(wp), DIMENSION(:,:,:  ), INTENT(in ) :: pe3t_b  , pe3u_b  , pe3v_b      !! scale factor before
+      REAL(wp), DIMENSION(:,:,:  ), INTENT(in ) :: pdepw_b                         !! depth w before
+      REAL(wp), DIMENSION(:,:    ), INTENT(in ) :: psmask_b                        !! mask before
+      !!
+      INTEGER :: ji, jj, jk, iz          !! loop index
+      INTEGER :: jip1, jim1, jjp1, jjm1, jkp1, jkm1
+      !!
+      REAL(wp):: summsk, zsum, zsum1, zarea, zsumn, zsumb
+      REAL(wp):: zdz, zdzm1, zdzp1
+      !!
+      REAL(wp), DIMENSION(jpi,jpj)          :: zdmask , zsmask0, zucorr, zbub, zbun, zssh0, zhu1, zde3t
+      REAL(wp), DIMENSION(jpi,jpj)          :: zdsmask, zsmask1, zvcorr, zbvb, zbvn, zssh1, zhv1
+      REAL(wp), DIMENSION(jpi,jpj,jpk)      :: ztmask0, zwmaskn, ztrp
+      REAL(wp), DIMENSION(jpi,jpj,jpk)      :: ztmask1, zwmaskb, ztmp3d
+      REAL(wp), DIMENSION(jpi,jpj,jpk,jpts) :: zts0
+      !!----------------------------------------------------------------------
+      !
+      !                 ! mask value to be sure
+      tsn(:,:,:,jp_tem) = tsn(:,:,:,jp_tem) * ptmask_b(:,:,:)
+      tsn(:,:,:,jp_sal) = tsn(:,:,:,jp_sal) * ptmask_b(:,:,:)
+      !
+      !                 ! compute wmask
+      zwmaskn(:,:,1) = tmask   (:,:,1)
+      zwmaskb(:,:,1) = ptmask_b(:,:,1)
+      DO jk = 2,jpk
+         zwmaskn(:,:,jk) =  tmask  (:,:,jk) *  tmask  (:,:,jk-1)
+         zwmaskb(:,:,jk) = ptmask_b(:,:,jk) * ptmask_b(:,:,jk-1)
+      END DO
+      !    
+      !                 ! compute new ssh if we open a full water column (average of the closest neigbourgs)  
+      sshb (:,:)=sshn(:,:)
+      zssh0(:,:)=sshn(:,:)
+      zsmask0(:,:) = psmask_b(:,:)
+      zsmask1(:,:) = psmask_b(:,:)
+      DO iz = 1, 10                 ! need to be tuned (configuration dependent) (OK for ISOMIP+)
+         zdsmask(:,:) = ssmask(:,:)-zsmask0(:,:)
+         DO jj = 2,jpj-1
+            DO ji = fs_2, fs_jpim1   ! vector opt.
+               jip1=ji+1; jim1=ji-1;
+               jjp1=jj+1; jjm1=jj-1;
+               summsk=(zsmask0(jip1,jj)+zsmask0(jim1,jj)+zsmask0(ji,jjp1)+zsmask0(ji,jjm1))
+               IF (zdsmask(ji,jj) == 1._wp .AND. summsk /= 0._wp) THEN
+                  sshn(ji,jj)=( zssh0(jip1,jj)*zsmask0(jip1,jj)     &
+                  &           + zssh0(jim1,jj)*zsmask0(jim1,jj)     &
+                  &           + zssh0(ji,jjp1)*zsmask0(ji,jjp1)     &
+                  &           + zssh0(ji,jjm1)*zsmask0(ji,jjm1))/summsk
+                  zsmask1(ji,jj)=1._wp
+               ENDIF
+            END DO
+         END DO
+         CALL lbc_lnk_multi( sshn, 'T', 1., zsmask1, 'T', 1. )
+         zssh0   = sshn
+         zsmask0 = zsmask1
+      END DO
+      sshn(:,:) = sshn(:,:) * ssmask(:,:)
+
+!=============================================================================
+!PM: Is this needed since introduction of VVL by default?
+      IF ( .NOT.ln_linssh ) THEN
+      ! Reconstruction of all vertical scale factors at now time steps
+      ! =============================================================================
+      ! Horizontal scale factor interpolations
+      ! --------------------------------------
+         DO jk = 1,jpk
+            DO jj=1,jpj
+               DO ji=1,jpi
+                  IF (tmask(ji,jj,1) == 0._wp .OR. ptmask_b(ji,jj,1) == 0._wp) THEN
+                     e3t_n(ji,jj,jk) = e3t_0(ji,jj,jk) * ( 1._wp + sshn(ji,jj) /   &
+                     &   ( ht_0(ji,jj) + 1._wp - ssmask(ji,jj) ) * tmask(ji,jj,jk) )
+                  ENDIF
+               END DO
+            END DO
+         END DO
+         !
+         CALL dom_vvl_interpol( e3t_n(:,:,:), e3u_n(:,:,:), 'U' )
+         CALL dom_vvl_interpol( e3t_n(:,:,:), e3v_n(:,:,:), 'V' )
+         CALL dom_vvl_interpol( e3u_n(:,:,:), e3f_n(:,:,:), 'F' )
+
+         ! Vertical scale factor interpolations
+         ! ------------------------------------
+         CALL dom_vvl_interpol( e3t_n(:,:,:), e3w_n (:,:,:), 'W'  )
+         CALL dom_vvl_interpol( e3u_n(:,:,:), e3uw_n(:,:,:), 'UW' )
+         CALL dom_vvl_interpol( e3v_n(:,:,:), e3vw_n(:,:,:), 'VW' )
+         
+         ! t- and w- points depth
+         ! ----------------------
+         gdept_n(:,:,1) = 0.5_wp * e3w_n(:,:,1)
+         gdepw_n(:,:,1) = 0.0_wp
+         gde3w_n(:,:,1) = gdept_n(:,:,1) - sshn(:,:)
+         DO jj = 1,jpj
+            DO ji = 1,jpi
+               DO jk = 2,mikt(ji,jj)-1
+                  gdept_n(ji,jj,jk) = gdept_0(ji,jj,jk)
+                  gdepw_n(ji,jj,jk) = gdepw_0(ji,jj,jk)
+                  gde3w_n(ji,jj,jk) = gdept_0(ji,jj,jk) - sshn(ji,jj)
+               END DO
+               IF (mikt(ji,jj) > 1) THEN
+                  jk = mikt(ji,jj)
+                  gdept_n(ji,jj,jk) = gdepw_0(ji,jj,jk) + 0.5_wp * e3w_n(ji,jj,jk)
+                  gdepw_n(ji,jj,jk) = gdepw_0(ji,jj,jk)
+                  gde3w_n(ji,jj,jk) = gdept_n(ji,jj,jk  ) - sshn   (ji,jj)
+               END IF
+               DO jk = mikt(ji,jj)+1, jpk
+                  gdept_n(ji,jj,jk) = gdept_n(ji,jj,jk-1) + e3w_n(ji,jj,jk)
+                  gdepw_n(ji,jj,jk) = gdepw_n(ji,jj,jk-1) + e3t_n(ji,jj,jk-1)
+                  gde3w_n(ji,jj,jk) = gdept_n(ji,jj,jk  ) - sshn (ji,jj)
+               END DO
+            END DO
+         END DO
+
+      ! t-, u- and v- water column thickness
+      ! ------------------------------------
+         ht_n(:,:) = 0._wp ; hu_n(:,:) = 0._wp ; hv_n(:,:) = 0._wp
+         DO jk = 1, jpkm1
+            hu_n(:,:) = hu_n(:,:) + e3u_n(:,:,jk) * umask(:,:,jk)
+            hv_n(:,:) = hv_n(:,:) + e3v_n(:,:,jk) * vmask(:,:,jk)
+            ht_n(:,:) = ht_n(:,:) + e3t_n(:,:,jk) * tmask(:,:,jk)
+         END DO
+         !                                        ! Inverse of the local depth
+         r1_hu_n(:,:) = 1._wp / ( hu_n(:,:) + 1._wp - ssumask(:,:) ) * ssumask(:,:)
+         r1_hv_n(:,:) = 1._wp / ( hv_n(:,:) + 1._wp - ssvmask(:,:) ) * ssvmask(:,:)
+
+      END IF
+
+!=============================================================================
+! compute velocity
+! compute velocity in order to conserve barotropic velocity (modification by poderation of the scale factor).
+      ub(:,:,:)=un(:,:,:)
+      vb(:,:,:)=vn(:,:,:)
+      DO jk = 1,jpk
+         DO jj = 1,jpj
+            DO ji = 1,jpi
+               un(ji,jj,jk) = ub(ji,jj,jk)*pe3u_b(ji,jj,jk)*pumask_b(ji,jj,jk)/e3u_n(ji,jj,jk)*umask(ji,jj,jk);
+               vn(ji,jj,jk) = vb(ji,jj,jk)*pe3v_b(ji,jj,jk)*pvmask_b(ji,jj,jk)/e3v_n(ji,jj,jk)*vmask(ji,jj,jk);
+            END DO
+         END DO
+      END DO
+
+! compute new velocity if we close a cell (check barotropic velocity and change velocity over the water column)
+! compute barotropic velocity now and after 
+      ztrp(:,:,:) = ub(:,:,:)*pe3u_b(:,:,:); 
+      zbub(:,:)   = SUM(ztrp,DIM=3)
+      ztrp(:,:,:) = vb(:,:,:)*pe3v_b(:,:,:); 
+      zbvb(:,:)   = SUM(ztrp,DIM=3)
+      ztrp(:,:,:) = un(:,:,:)*e3u_n(:,:,:); 
+      zbun(:,:)   = SUM(ztrp,DIM=3)
+      ztrp(:,:,:) = vn(:,:,:)*e3v_n(:,:,:); 
+      zbvn(:,:)   = SUM(ztrp,DIM=3)
+
+      ! new water column
+      zhu1=0.0_wp ;
+      zhv1=0.0_wp ;
+      DO jk  = 1,jpk
+        zhu1(:,:) = zhu1(:,:) + e3u_n(:,:,jk) * umask(:,:,jk)
+        zhv1(:,:) = zhv1(:,:) + e3v_n(:,:,jk) * vmask(:,:,jk)
+      END DO
+      
+      ! compute correction      
+      zucorr = 0._wp
+      zvcorr = 0._wp
+      DO jj = 1,jpj
+         DO ji = 1,jpi
+            IF (zbun(ji,jj) /= zbub(ji,jj) .AND. zhu1(ji,jj) /= 0._wp ) THEN
+               zucorr(ji,jj) = (zbun(ji,jj) - zbub(ji,jj))/zhu1(ji,jj)
+            END IF
+            IF (zbvn(ji,jj) /= zbvb(ji,jj) .AND. zhv1(ji,jj) /= 0._wp ) THEN
+               zvcorr(ji,jj) = (zbvn(ji,jj) - zbvb(ji,jj))/zhv1(ji,jj)
+            END IF
+         END DO
+      END DO 
+      
+      ! update velocity
+      DO jk  = 1,jpk
+         un(:,:,jk)=(un(:,:,jk) - zucorr(:,:))*umask(:,:,jk)
+         vn(:,:,jk)=(vn(:,:,jk) - zvcorr(:,:))*vmask(:,:,jk)
+      END DO
+
+!=============================================================================
+      ! compute temp and salt
+      ! compute new tn and sn if we open a new cell
+      tsb (:,:,:,:) = tsn(:,:,:,:)
+      zts0(:,:,:,:) = tsn(:,:,:,:)
+      ztmask1(:,:,:) = ptmask_b(:,:,:)
+      ztmask0(:,:,:) = ptmask_b(:,:,:)
+      DO iz = 1,nn_drown ! resolution dependent (OK for ISOMIP+ case)
+          DO jk = 1,jpk-1
+              zdmask=tmask(:,:,jk)-ztmask0(:,:,jk);
+              DO jj = 2,jpj-1
+                 DO ji = fs_2,fs_jpim1
+                      jip1=ji+1; jim1=ji-1;
+                      jjp1=jj+1; jjm1=jj-1;
+                      summsk= (ztmask0(jip1,jj  ,jk)+ztmask0(jim1,jj  ,jk)+ztmask0(ji  ,jjp1,jk)+ztmask0(ji  ,jjm1,jk))
+                      IF (zdmask(ji,jj) == 1._wp .AND. summsk /= 0._wp) THEN
+                      !! horizontal basic extrapolation
+                         tsn(ji,jj,jk,1)=( zts0(jip1,jj  ,jk,1)*ztmask0(jip1,jj  ,jk) &
+                         &                +zts0(jim1,jj  ,jk,1)*ztmask0(jim1,jj  ,jk) &
+                         &                +zts0(ji  ,jjp1,jk,1)*ztmask0(ji  ,jjp1,jk) &
+                         &                +zts0(ji  ,jjm1,jk,1)*ztmask0(ji  ,jjm1,jk) ) / summsk
+                         tsn(ji,jj,jk,2)=( zts0(jip1,jj  ,jk,2)*ztmask0(jip1,jj  ,jk) &
+                         &                +zts0(jim1,jj  ,jk,2)*ztmask0(jim1,jj  ,jk) &
+                         &                +zts0(ji  ,jjp1,jk,2)*ztmask0(ji  ,jjp1,jk) &
+                         &                +zts0(ji  ,jjm1,jk,2)*ztmask0(ji  ,jjm1,jk) ) / summsk
+                         ztmask1(ji,jj,jk)=1
+                      ELSEIF (zdmask(ji,jj) == 1._wp .AND. summsk == 0._wp) THEN
+                      !! vertical extrapolation if horizontal extrapolation failed
+                         jkm1=max(1,jk-1) ; jkp1=min(jpk,jk+1)
+                         summsk=(ztmask0(ji,jj,jkm1)+ztmask0(ji,jj,jkp1))
+                         IF (zdmask(ji,jj) == 1._wp .AND. summsk /= 0._wp ) THEN
+                            tsn(ji,jj,jk,1)=( zts0(ji,jj,jkp1,1)*ztmask0(ji,jj,jkp1)     &
+                            &                +zts0(ji,jj,jkm1,1)*ztmask0(ji,jj,jkm1))/summsk
+                            tsn(ji,jj,jk,2)=( zts0(ji,jj,jkp1,2)*ztmask0(ji,jj,jkp1)     &
+                            &                +zts0(ji,jj,jkm1,2)*ztmask0(ji,jj,jkm1))/summsk
+                            ztmask1(ji,jj,jk)=1._wp
+                         END IF
+                      END IF
+                  END DO
+              END DO
+          END DO
+          
+          CALL lbc_lnk_multi( tsn(:,:,:,jp_tem), 'T', 1., tsn(:,:,:,jp_sal), 'T', 1., ztmask1, 'T', 1.)
+
+          ! update
+          zts0(:,:,:,:) = tsn(:,:,:,:)
+          ztmask0 = ztmask1
+
+      END DO
+
+      ! mask new tsn field
+      tsn(:,:,:,jp_tem) = tsn(:,:,:,jp_tem) * tmask(:,:,:)
+      tsn(:,:,:,jp_sal) = tsn(:,:,:,jp_sal) * tmask(:,:,:)
+
+      ! compute new T/S (interpolation) if vvl only for common wet cell in before and after wmask
+      !PM: Is this IF needed since change to VVL by default
+      IF (.NOT.ln_linssh) THEN
+         DO jk = 2,jpk-1
+            DO jj = 1,jpj
+               DO ji = 1,jpi
+                  IF (zwmaskn(ji,jj,jk) * zwmaskb(ji,jj,jk) == 1._wp .AND.   &
+                  &      (tmask(ji,jj,1)==0._wp .OR. ptmask_b(ji,jj,1)==0._wp) ) THEN
+                     !compute weight
+                     zdzp1 = MAX(0._wp,gdepw_n(ji,jj,jk+1) - pdepw_b(ji,jj,jk+1))
+                     zdz   =           gdepw_n(ji,jj,jk+1) - pdepw_b(ji,jj,jk  ) 
+                     zdzm1 = MAX(0._wp,pdepw_b(ji,jj,jk  ) - gdepw_n(ji,jj,jk  ))
+                     IF (zdz .LT. 0._wp) THEN 
+                        CALL ctl_stop( 'STOP', 'rst_iscpl : unable to compute the interpolation' )
+                     END IF
+                     tsn(ji,jj,jk,jp_tem) = ( zdzp1*tsb(ji,jj,jk+1,jp_tem)      &
+                        &                   + zdz  *tsb(ji,jj,jk  ,jp_tem)      &
+                        &                   + zdzm1*tsb(ji,jj,jk-1,jp_tem)      )/e3t_n(ji,jj,jk)
+                     tsn(ji,jj,jk,jp_sal) = ( zdzp1*tsb(ji,jj,jk+1,jp_sal)      &
+                        &                   + zdz  *tsb(ji,jj,jk  ,jp_sal)      &
+                        &                   + zdzm1*tsb(ji,jj,jk-1,jp_sal)      )/e3t_n(ji,jj,jk)
+                  END IF
+               END DO
+            END DO
+         END DO               
+      END IF
+
+      ! closed pool
+      ! -----------------------------------------------------------------------------------------
+      ! case we open a cell but no neigbour cells available to get an estimate of T and S
+      WHERE (tmask(:,:,:) == 1._wp .AND. tsn(:,:,:,2) == 0._wp) 
+         tsn(:,:,:,2) = -99._wp  ! Special value for closed pool (checking purpose in output.init)
+         tmask(:,:,:) = 0._wp    ! set mask to 0 to run
+         umask(:,:,:) = 0._wp
+         vmask(:,:,:) = 0._wp
+      END WHERE
+      
+      ! set mbkt and mikt to 1 in thiese location
+      WHERE (SUM(tmask,dim=3) == 0)
+         mbkt(:,:)=1 ; mbku(:,:)=1 ; mbkv(:,:)=1
+         mikt(:,:)=1 ; miku(:,:)=1 ; mikv(:,:)=1
+      END WHERE
+      ! -------------------------------------------------------------------------------------------
+      ! compute new tn and sn if we close cell 
+      ! nothing to do
+      ! 
+   END SUBROUTINE iscpl_rst_interpol
+
+   !!======================================================================
+END MODULE iscplrst
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DOM/istate.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DOM/istate.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DOM/istate.F90	(revision 9570)
@@ -0,0 +1,171 @@
+MODULE istate
+   !!======================================================================
+   !!                     ***  MODULE  istate  ***
+   !! Ocean state   :  initial state setting
+   !!=====================================================================
+   !! History :  OPA  !  1989-12  (P. Andrich)  Original code
+   !!            5.0  !  1991-11  (G. Madec)  rewritting
+   !!            6.0  !  1996-01  (G. Madec)  terrain following coordinates
+   !!            8.0  !  2001-09  (M. Levy, M. Ben Jelloul)  istate_eel
+   !!            8.0  !  2001-09  (M. Levy, M. Ben Jelloul)  istate_uvg
+   !!   NEMO     1.0  !  2003-08  (G. Madec, C. Talandier)  F90: Free form, modules + EEL R5
+   !!             -   !  2004-05  (A. Koch-Larrouy)  istate_gyre 
+   !!            2.0  !  2006-07  (S. Masson)  distributed restart using iom
+   !!            3.3  !  2010-10  (C. Ethe) merge TRC-TRA
+   !!            3.4  !  2011-04  (G. Madec) Merge of dtatem and dtasal & suppression of tb,tn/sb,sn 
+   !!            3.7  !  2016-04  (S. Flavoni) introduce user defined initial state 
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   istate_init   : initial state setting
+   !!   istate_uvg    : initial velocity in geostropic balance
+   !!----------------------------------------------------------------------
+   USE oce            ! ocean dynamics and active tracers 
+   USE dom_oce        ! ocean space and time domain 
+   USE daymod         ! calendar
+   USE divhor         ! horizontal divergence            (div_hor routine)
+   USE dtatsd         ! data temperature and salinity   (dta_tsd routine)
+   USE dtauvd         ! data: U & V current             (dta_uvd routine)
+   USE domvvl          ! varying vertical mesh
+   USE iscplrst        ! ice sheet coupling
+   USE wet_dry         ! wetting and drying (needed for wad_istate)
+   USE usrdef_istate   ! User defined initial state
+   !
+   USE in_out_manager  ! I/O manager
+   USE iom             ! I/O library
+   USE lib_mpp         ! MPP library
+   USE restart         ! restart
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   istate_init   ! routine called by step.F90
+
+   !! * Substitutions
+#  include "vectopt_loop_substitute.h90"
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.7 , NEMO Consortium (2014)
+   !! $Id$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE istate_init
+      !!----------------------------------------------------------------------
+      !!                   ***  ROUTINE istate_init  ***
+      !! 
+      !! ** Purpose :   Initialization of the dynamics and tracer fields.
+      !!----------------------------------------------------------------------
+      INTEGER ::   ji, jj, jk   ! dummy loop indices
+!!gm see comment further down
+      REAL(wp), ALLOCATABLE, DIMENSION(:,:,:,:) ::   zuvd    ! U & V data workspace
+!!gm end
+      !!----------------------------------------------------------------------
+      !
+      IF(lwp) WRITE(numout,*)
+      IF(lwp) WRITE(numout,*) 'istate_init : Initialization of the dynamics and tracers'
+      IF(lwp) WRITE(numout,*) '~~~~~~~~~~~'
+
+!!gm  Why not include in the first call of dta_tsd ?  
+!!gm  probably associated with the use of internal damping...
+                     CALL dta_tsd_init        ! Initialisation of T & S input data
+!!gm to be moved in usrdef of C1D case
+!      IF( lk_c1d )   CALL dta_uvd_init        ! Initialization of U & V input data
+!!gm
+
+      rhd  (:,:,:  ) = 0._wp   ;   rhop (:,:,:  ) = 0._wp      ! set one for all to 0 at level jpk
+      rn2b (:,:,:  ) = 0._wp   ;   rn2  (:,:,:  ) = 0._wp      ! set one for all to 0 at levels 1 and jpk
+      tsa  (:,:,:,:) = 0._wp                                   ! set one for all to 0 at level jpk
+      rab_b(:,:,:,:) = 0._wp   ;   rab_n(:,:,:,:) = 0._wp      ! set one for all to 0 at level jpk
+#if defined key_agrif
+      ua   (:,:,:  ) = 0._wp   ! used in agrif_oce_sponge at initialization
+      va   (:,:,:  ) = 0._wp   ! used in agrif_oce_sponge at initialization    
+#endif
+
+      IF( ln_rstart ) THEN                    ! Restart from a file
+         !                                    ! -------------------
+         CALL rst_read                        ! Read the restart file
+         IF (ln_iscpl)       CALL iscpl_stp   ! extrapolate restart to wet and dry
+         CALL day_init                        ! model calendar (using both namelist and restart infos)
+         !
+      ELSE                                    ! Start from rest
+         !                                    ! ---------------
+         numror = 0                           ! define numror = 0 -> no restart file to read
+         neuler = 0                           ! Set time-step indicator at nit000 (euler forward)
+         CALL day_init                        ! model calendar (using both namelist and restart infos)
+         !                                    ! Initialization of ocean to zero
+         !
+         IF( ln_tsd_init ) THEN               
+            CALL dta_tsd( nit000, tsb )       ! read 3D T and S data at nit000
+            !
+            sshb(:,:)   = 0._wp               ! set the ocean at rest
+            ub  (:,:,:) = 0._wp
+            vb  (:,:,:) = 0._wp  
+            !
+         ELSE                                 ! user defined initial T and S
+            CALL usr_def_istate( gdept_b, tmask, tsb, ub, vb, sshb  )         
+         ENDIF
+         tsn  (:,:,:,:) = tsb (:,:,:,:)       ! set now values from to before ones
+         sshn (:,:)     = sshb(:,:)   
+         un   (:,:,:)   = ub  (:,:,:)
+         vn   (:,:,:)   = vb  (:,:,:)
+         hdivn(:,:,jpk) = 0._wp               ! bottom divergence set one for 0 to zero at jpk level
+         CALL div_hor( 0 )                    ! compute interior hdivn value  
+!!gm                                    hdivn(:,:,:) = 0._wp
+
+!!gm POTENTIAL BUG :
+!!gm  ISSUE :  if sshb /= 0  then, in non linear free surface, the e3._n, e3._b should be recomputed
+!!             as well as gdept and gdepw....   !!!!! 
+!!      ===>>>>   probably a call to domvvl initialisation here....
+
+
+         !
+!!gm to be moved in usrdef of C1D case
+!         IF ( ln_uvd_init .AND. lk_c1d ) THEN ! read 3D U and V data at nit000
+!            ALLOCATE( zuvd(jpi,jpj,jpk,2) )
+!            CALL dta_uvd( nit000, zuvd )
+!            ub(:,:,:) = zuvd(:,:,:,1) ;  un(:,:,:) = ub(:,:,:)
+!            vb(:,:,:) = zuvd(:,:,:,2) ;  vn(:,:,:) = vb(:,:,:)
+!            DEALLOCATE( zuvd )
+!         ENDIF
+         !
+!!gm This is to be changed !!!!
+!         ! - ML - sshn could be modified by istate_eel, so that initialization of e3t_b is done here
+!         IF( .NOT.ln_linssh ) THEN
+!            DO jk = 1, jpk
+!               e3t_b(:,:,jk) = e3t_n(:,:,jk)
+!            END DO
+!         ENDIF
+!!gm 
+         ! 
+      ENDIF 
+      ! 
+      ! Initialize "now" and "before" barotropic velocities:
+      ! Do it whatever the free surface method, these arrays being eventually used
+      !
+      un_b(:,:) = 0._wp   ;   vn_b(:,:) = 0._wp
+      ub_b(:,:) = 0._wp   ;   vb_b(:,:) = 0._wp
+      !
+!!gm  the use of umsak & vmask is not necessary below as un, vn, ub, vb are always masked
+      DO jk = 1, jpkm1
+         DO jj = 1, jpj
+            DO ji = 1, jpi
+               un_b(ji,jj) = un_b(ji,jj) + e3u_n(ji,jj,jk) * un(ji,jj,jk) * umask(ji,jj,jk)
+               vn_b(ji,jj) = vn_b(ji,jj) + e3v_n(ji,jj,jk) * vn(ji,jj,jk) * vmask(ji,jj,jk)
+               !
+               ub_b(ji,jj) = ub_b(ji,jj) + e3u_b(ji,jj,jk) * ub(ji,jj,jk) * umask(ji,jj,jk)
+               vb_b(ji,jj) = vb_b(ji,jj) + e3v_b(ji,jj,jk) * vb(ji,jj,jk) * vmask(ji,jj,jk)
+            END DO
+         END DO
+      END DO
+      !
+      un_b(:,:) = un_b(:,:) * r1_hu_n(:,:)
+      vn_b(:,:) = vn_b(:,:) * r1_hv_n(:,:)
+      !
+      ub_b(:,:) = ub_b(:,:) * r1_hu_b(:,:)
+      vb_b(:,:) = vb_b(:,:) * r1_hv_b(:,:)
+      !
+   END SUBROUTINE istate_init
+
+   !!======================================================================
+END MODULE istate
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DOM/phycst.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DOM/phycst.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DOM/phycst.F90	(revision 9570)
@@ -0,0 +1,195 @@
+MODULE phycst
+   !!======================================================================
+   !!                    ***  MODULE  phycst  ***
+   !!     Definition of of both ocean and ice parameters used in the code
+   !!=====================================================================
+   !! History :   OPA  !  1990-10  (C. Levy - G. Madec)  Original code
+   !!             8.1  !  1991-11  (G. Madec, M. Imbard)  cosmetic changes
+   !!   NEMO      1.0  !  2002-08  (G. Madec, C. Ethe)  F90, add ice constants
+   !!              -   !  2006-08  (G. Madec)  style 
+   !!             3.2  !  2006-08  (S. Masson, G. Madec)  suppress useless variables + style 
+   !!             3.4  !  2011-11  (C. Harris)  minor changes for CICE constants 
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   phy_cst  : define and print physical constant and domain parameters
+   !!----------------------------------------------------------------------
+   USE par_oce          ! ocean parameters
+   USE in_out_manager   ! I/O manager
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   phy_cst     ! routine called by inipar.F90
+
+   REAL(wp), PUBLIC ::   rpi = 3.141592653589793_wp             !: pi
+   REAL(wp), PUBLIC ::   rad = 3.141592653589793_wp / 180._wp   !: conversion from degre into radian
+   REAL(wp), PUBLIC ::   rsmall = 0.5 * EPSILON( 1.e0 )         !: smallest real computer value
+   
+   REAL(wp), PUBLIC ::   rday = 24.*60.*60.     !: day                                [s]
+   REAL(wp), PUBLIC ::   rsiyea                 !: sideral year                       [s]
+   REAL(wp), PUBLIC ::   rsiday                 !: sideral day                        [s]
+   REAL(wp), PUBLIC ::   raamo =  12._wp        !: number of months in one year
+   REAL(wp), PUBLIC ::   rjjhh =  24._wp        !: number of hours in one day
+   REAL(wp), PUBLIC ::   rhhmm =  60._wp        !: number of minutes in one hour
+   REAL(wp), PUBLIC ::   rmmss =  60._wp        !: number of seconds in one minute
+   REAL(wp), PUBLIC ::   omega                  !: earth rotation parameter           [s-1]
+   REAL(wp), PUBLIC ::   ra    = 6371229._wp    !: earth radius                       [m]
+   REAL(wp), PUBLIC ::   grav  = 9.80665_wp     !: gravity                            [m/s2]
+   
+   REAL(wp), PUBLIC ::   rtt      = 273.16_wp        !: triple point of temperature   [Kelvin]
+   REAL(wp), PUBLIC ::   rt0      = 273.15_wp        !: freezing point of fresh water [Kelvin]
+   REAL(wp), PUBLIC ::   rt0_snow = 273.15_wp        !: melting point of snow         [Kelvin]
+#if defined key_si3
+   REAL(wp), PUBLIC ::   rt0_ice  = 273.15_wp        !: melting point of ice          [Kelvin]
+#else
+   REAL(wp), PUBLIC ::   rt0_ice  = 273.05_wp        !: melting point of ice          [Kelvin]
+#endif
+   REAL(wp), PUBLIC ::   rau0                        !: volumic mass of reference     [kg/m3]
+   REAL(wp), PUBLIC ::   r1_rau0                     !: = 1. / rau0                   [m3/kg]
+   REAL(wp), PUBLIC ::   rcp                         !: ocean specific heat           [J/Kelvin]
+   REAL(wp), PUBLIC ::   r1_rcp                      !: = 1. / rcp                    [Kelvin/J]
+   REAL(wp), PUBLIC ::   rau0_rcp                    !: = rau0 * rcp 
+   REAL(wp), PUBLIC ::   r1_rau0_rcp                 !: = 1. / ( rau0 * rcp )
+
+   REAL(wp), PUBLIC ::   rhosn    =  330._wp         !: volumic mass of snow          [kg/m3]
+   REAL(wp), PUBLIC ::   rhofw    = 1000._wp         !: volumic mass of freshwater in melt ponds [kg/m3]
+   REAL(wp), PUBLIC ::   emic     =    0.97_wp       !: emissivity of snow or ice
+   REAL(wp), PUBLIC ::   sice     =    6.0_wp        !: salinity of ice               [psu]
+   REAL(wp), PUBLIC ::   soce     =   34.7_wp        !: salinity of sea               [psu]
+   REAL(wp), PUBLIC ::   cevap    =    2.5e+6_wp     !: latent heat of evaporation (water)
+   REAL(wp), PUBLIC ::   srgamma  =    0.9_wp        !: correction factor for solar radiation (Oberhuber, 1974)
+   REAL(wp), PUBLIC ::   vkarmn   =    0.4_wp        !: von Karman constant
+   REAL(wp), PUBLIC ::   stefan   =    5.67e-8_wp    !: Stefan-Boltzmann constant 
+
+#if defined key_si3 || defined key_cice
+   REAL(wp), PUBLIC ::   rhoic    =  917._wp         !: volumic mass of sea ice                               [kg/m3]
+   REAL(wp), PUBLIC ::   rcdic    =    2.034396_wp   !: thermal conductivity of fresh ice                     [W/m/K]
+   REAL(wp), PUBLIC ::   cpic     = 2067.0_wp        !: specific heat of fresh ice                            [J/kg/K]
+   REAL(wp), PUBLIC ::   lsub     =    2.834e+6_wp   !: pure ice latent heat of sublimation                   [J/kg]
+   REAL(wp), PUBLIC ::   lfus     =    0.334e+6_wp   !: latent heat of fusion of fresh ice                    [J/kg]
+   REAL(wp), PUBLIC ::   tmut     =    0.054_wp      !: decrease of seawater meltpoint with salinity
+   REAL(wp), PUBLIC ::   xlsn                        !: = lfus*rhosn (volumetric latent heat fusion of snow)  [J/m3]
+#else
+   REAL(wp), PUBLIC ::   rhoic    =  900._wp         !: volumic mass of sea ice                               [kg/m3]
+   REAL(wp), PUBLIC ::   rcdic    =    2.034396_wp   !: conductivity of the ice                               [W/m/K]
+   REAL(wp), PUBLIC ::   rcpic    =    1.8837e+6_wp  !: volumetric specific heat for ice                      [J/m3/K]
+   REAL(wp), PUBLIC ::   cpic                        !: = rcpic / rhoic  (specific heat for ice)              [J/Kg/K]
+   REAL(wp), PUBLIC ::   rcdsn    =    0.22_wp       !: conductivity of the snow                              [W/m/K]
+   REAL(wp), PUBLIC ::   rcpsn    =    6.9069e+5_wp  !: volumetric specific heat for snow                     [J/m3/K]
+   REAL(wp), PUBLIC ::   xlsn     =  110.121e+6_wp   !: volumetric latent heat fusion of snow                 [J/m3]
+   REAL(wp), PUBLIC ::   lfus                        !: = xlsn / rhosn   (latent heat of fusion of fresh ice) [J/Kg]
+   REAL(wp), PUBLIC ::   xlic     =  300.33e+6_wp    !: volumetric latent heat fusion of ice                  [J/m3]
+   REAL(wp), PUBLIC ::   xsn      =    2.8e+6_wp     !: volumetric latent heat of sublimation of snow         [J/m3]
+#endif
+#if defined key_cice
+   REAL(wp), PUBLIC ::   rcdsn    =    0.31_wp       !: thermal conductivity of snow                          [W/m/K], now namelist parameter for LIM3
+#endif
+#if defined key_si3
+   REAL(wp), PUBLIC ::   r1_rhoic                    !: 1 / rhoic
+   REAL(wp), PUBLIC ::   r1_rhosn                    !: 1 / rhosn
+   REAL(wp), PUBLIC ::   r1_cpic                     !: 1 / cpic
+#endif
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO Consortium (2010)
+   !! $Id$ 
+   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+   
+CONTAINS
+   
+   SUBROUTINE phy_cst
+      !!----------------------------------------------------------------------
+      !!                       ***  ROUTINE phy_cst  ***
+      !!
+      !! ** Purpose :   set and print the constants
+      !!----------------------------------------------------------------------
+
+      IF(lwp) WRITE(numout,*)
+      IF(lwp) WRITE(numout,*) 'phy_cst : initialization of ocean parameters and constants'
+      IF(lwp) WRITE(numout,*) '~~~~~~~'
+
+      ! Define & print constants
+      ! ------------------------
+      IF(lwp) WRITE(numout,*)
+      IF(lwp) WRITE(numout,*) '   Constants'
+
+      IF(lwp) WRITE(numout,*)
+      IF(lwp) WRITE(numout,*) '      mathematical constant                 rpi = ', rpi
+
+      rsiyea = 365.25_wp * rday * 2._wp * rpi / 6.283076_wp
+      rsiday = rday / ( 1._wp + rday / rsiyea )
+#if defined key_cice
+      omega  = 7.292116e-05
+#else
+      omega  = 2._wp * rpi / rsiday 
+#endif
+      IF(lwp) WRITE(numout,*)
+      IF(lwp) WRITE(numout,*) '      day                                rday   = ', rday,   ' s'
+      IF(lwp) WRITE(numout,*) '      sideral year                       rsiyea = ', rsiyea, ' s'
+      IF(lwp) WRITE(numout,*) '      sideral day                        rsiday = ', rsiday, ' s'
+      IF(lwp) WRITE(numout,*) '      omega                              omega  = ', omega,  ' s^-1'
+      IF(lwp) WRITE(numout,*)
+      IF(lwp) WRITE(numout,*) '      nb of months per year               raamo = ', raamo, ' months'
+      IF(lwp) WRITE(numout,*) '      nb of hours per day                 rjjhh = ', rjjhh, ' hours'
+      IF(lwp) WRITE(numout,*) '      nb of minutes per hour              rhhmm = ', rhhmm, ' mn'
+      IF(lwp) WRITE(numout,*) '      nb of seconds per minute            rmmss = ', rmmss, ' s'
+      IF(lwp) WRITE(numout,*)
+      IF(lwp) WRITE(numout,*) '      earth radius                         ra   = ', ra, ' m'
+      IF(lwp) WRITE(numout,*) '      gravity                              grav = ', grav , ' m/s^2'
+      IF(lwp) WRITE(numout,*)
+      IF(lwp) WRITE(numout,*) '      triple point of temperature      rtt      = ', rtt     , ' K'
+      IF(lwp) WRITE(numout,*) '      freezing point of water          rt0      = ', rt0     , ' K'
+      IF(lwp) WRITE(numout,*) '      melting point of snow            rt0_snow = ', rt0_snow, ' K'
+      IF(lwp) WRITE(numout,*) '      melting point of ice             rt0_ice  = ', rt0_ice , ' K'
+      IF(lwp) WRITE(numout,*)
+      IF(lwp) WRITE(numout,*) '   reference density and heat capacity now defined in eosbn2.f90'
+              
+#if defined key_si3 || defined key_cice
+      xlsn = lfus * rhosn        ! volumetric latent heat fusion of snow [J/m3]
+#else
+      cpic = rcpic / rhoic       ! specific heat for ice   [J/Kg/K]
+      lfus = xlsn / rhosn        ! latent heat of fusion of fresh ice
+#endif
+#if defined key_si3
+      r1_rhoic = 1._wp / rhoic
+      r1_rhosn = 1._wp / rhosn
+      r1_cpic  = 1._wp / cpic
+#endif
+      IF(lwp) THEN
+         WRITE(numout,*)
+#if defined key_cice
+         WRITE(numout,*) '      thermal conductivity of the snow          = ', rcdsn   , ' J/s/m/K'
+#endif
+         WRITE(numout,*) '      thermal conductivity of pure ice          = ', rcdic   , ' J/s/m/K'
+         WRITE(numout,*) '      fresh ice specific heat                   = ', cpic    , ' J/kg/K'
+         WRITE(numout,*) '      latent heat of fusion of fresh ice / snow = ', lfus    , ' J/kg'
+#if defined key_si3 || defined key_cice
+         WRITE(numout,*) '      latent heat of subl.  of fresh ice / snow = ', lsub    , ' J/kg'
+#else
+         WRITE(numout,*) '      density times specific heat for snow      = ', rcpsn   , ' J/m^3/K' 
+         WRITE(numout,*) '      density times specific heat for ice       = ', rcpic   , ' J/m^3/K'
+         WRITE(numout,*) '      volumetric latent heat fusion of sea ice  = ', xlic    , ' J/m' 
+         WRITE(numout,*) '      latent heat of sublimation of snow        = ', xsn     , ' J/kg' 
+#endif
+         WRITE(numout,*) '      volumetric latent heat fusion of snow     = ', xlsn    , ' J/m^3' 
+         WRITE(numout,*) '      density of sea ice                        = ', rhoic   , ' kg/m^3'
+         WRITE(numout,*) '      density of snow                           = ', rhosn   , ' kg/m^3'
+         WRITE(numout,*) '      density of freshwater (in melt ponds)     = ', rhofw   , ' kg/m^3'
+         WRITE(numout,*) '      emissivity of snow or ice                 = ', emic  
+         WRITE(numout,*) '      salinity of ice                           = ', sice    , ' psu'
+         WRITE(numout,*) '      salinity of sea                           = ', soce    , ' psu'
+         WRITE(numout,*) '      latent heat of evaporation (water)        = ', cevap   , ' J/m^3' 
+         WRITE(numout,*) '      correction factor for solar radiation     = ', srgamma 
+         WRITE(numout,*) '      von Karman constant                       = ', vkarmn 
+         WRITE(numout,*) '      Stefan-Boltzmann constant                 = ', stefan  , ' J/s/m^2/K^4'
+         WRITE(numout,*)
+         WRITE(numout,*) '      conversion: degre ==> radian          rad = ', rad
+         WRITE(numout,*)
+         WRITE(numout,*) '      smallest real computer value       rsmall = ', rsmall
+      ENDIF
+
+   END SUBROUTINE phy_cst
+
+   !!======================================================================
+END MODULE phycst
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DYN/divhor.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DYN/divhor.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DYN/divhor.F90	(revision 9570)
@@ -0,0 +1,113 @@
+MODULE divhor
+   !!==============================================================================
+   !!                       ***  MODULE  divhor  ***
+   !! Ocean diagnostic variable : now horizontal divergence
+   !!==============================================================================
+   !! History :  1.0  ! 2002-09  (G. Madec, E. Durand)  Free form, F90
+   !!             -   ! 2005-01  (J. Chanut) Unstructured open boundaries
+   !!             -   ! 2003-08  (G. Madec)  merged of cur and div, free form, F90
+   !!             -   ! 2005-01  (J. Chanut, A. Sellar) unstructured open boundaries
+   !!            3.3  ! 2010-09  (D.Storkey and E.O'Dea) bug fixes for BDY module
+   !!             -   ! 2010-10  (R. Furner, G. Madec) runoff and cla added directly here
+   !!            3.7  ! 2014-01  (G. Madec) suppression of velocity curl from in-core memory
+   !!             -   ! 2014-12  (G. Madec) suppression of cross land advection option
+   !!             -   ! 2015-10  (G. Madec) add velocity and rnf flag in argument of div_hor
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   div_hor    : Compute the horizontal divergence field
+   !!----------------------------------------------------------------------
+   USE oce             ! ocean dynamics and tracers
+   USE dom_oce         ! ocean space and time domain
+   USE sbc_oce, ONLY : ln_rnf, ln_isf ! surface boundary condition: ocean
+   USE sbcrnf          ! river runoff 
+   USE sbcisf          ! ice shelf
+   USE iscplhsb        ! ice sheet / ocean coupling
+   USE iscplini        ! ice sheet / ocean coupling
+#if defined key_asminc   
+   USE asminc          ! Assimilation increment
+#endif
+   !
+   USE in_out_manager  ! I/O manager
+   USE lbclnk          ! ocean lateral boundary conditions (or mpp link)
+   USE lib_mpp         ! MPP library
+   USE timing          ! Timing
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   div_hor    ! routine called by step.F90 and istate.F90
+
+   !! * Substitutions
+#  include "vectopt_loop_substitute.h90"
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 4.0 , NEMO Consortium (2017)
+   !! $Id$ 
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE div_hor( kt )
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE div_hor  ***
+      !!                    
+      !! ** Purpose :   compute the horizontal divergence at now time-step
+      !!
+      !! ** Method  :   the now divergence is computed as :
+      !!         hdivn = 1/(e1e2t*e3t) ( di[e2u*e3u un] + dj[e1v*e3v vn] )
+      !!      and correct with runoff inflow (div_rnf) and cross land flow (div_cla) 
+      !!
+      !! ** Action  : - update hdivn, the now horizontal divergence
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT(in) ::   kt   ! ocean time-step index
+      !
+      INTEGER  ::   ji, jj, jk    ! dummy loop indices
+      REAL(wp) ::   zraur, zdep   ! local scalars
+      !!----------------------------------------------------------------------
+      !
+      IF( ln_timing )   CALL timing_start('div_hor')
+      !
+      IF( kt == nit000 ) THEN
+         IF(lwp) WRITE(numout,*)
+         IF(lwp) WRITE(numout,*) 'div_hor : horizontal velocity divergence '
+         IF(lwp) WRITE(numout,*) '~~~~~~~   '
+      ENDIF
+      !
+      DO jk = 1, jpkm1                                      !==  Horizontal divergence  ==!
+         DO jj = 2, jpjm1
+            DO ji = fs_2, fs_jpim1   ! vector opt.
+               hdivn(ji,jj,jk) = (  e2u(ji  ,jj) * e3u_n(ji  ,jj,jk) * un(ji  ,jj,jk)      &
+                  &               - e2u(ji-1,jj) * e3u_n(ji-1,jj,jk) * un(ji-1,jj,jk)      &
+                  &               + e1v(ji,jj  ) * e3v_n(ji,jj  ,jk) * vn(ji,jj  ,jk)      &
+                  &               - e1v(ji,jj-1) * e3v_n(ji,jj-1,jk) * vn(ji,jj-1,jk)  )   &
+                  &            * r1_e1e2t(ji,jj) / e3t_n(ji,jj,jk)
+            END DO  
+         END DO  
+      END DO
+#if defined key_agrif
+      IF( .NOT. Agrif_Root() ) THEN
+         IF( nbondi == -1 .OR. nbondi == 2 )   hdivn(   2   ,  :   ,:) = 0._wp      ! west
+         IF( nbondi ==  1 .OR. nbondi == 2 )   hdivn( nlci-1,  :   ,:) = 0._wp      ! east
+         IF( nbondj == -1 .OR. nbondj == 2 )   hdivn(   :   ,  2   ,:) = 0._wp      ! south
+         IF( nbondj ==  1 .OR. nbondj == 2 )   hdivn(   :   ,nlcj-1,:) = 0._wp      ! north
+      ENDIF
+#endif
+      !
+      IF( ln_rnf )   CALL sbc_rnf_div( hdivn )              !==  runoffs    ==!   (update hdivn field)
+      !
+#if defined key_asminc 
+      IF( ln_sshinc .AND. ln_asmiau )   CALL ssh_asm_div( kt, hdivn )   !==  SSH assimilation  ==!   (update hdivn field)
+      ! 
+#endif
+      IF( ln_isf )   CALL sbc_isf_div( hdivn )      !==  ice shelf  ==!   (update hdivn field)
+      !
+      IF( ln_iscpl .AND. ln_hsb )   CALL iscpl_div( hdivn ) !==  ice sheet  ==!   (update hdivn field)
+      !
+      CALL lbc_lnk( hdivn, 'T', 1. )   !   (no sign change)
+      !
+      IF( ln_timing )   CALL timing_stop('div_hor')
+      !
+   END SUBROUTINE div_hor
+   
+   !!======================================================================
+END MODULE divhor
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DYN/dynadv.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DYN/dynadv.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DYN/dynadv.F90	(revision 9570)
@@ -0,0 +1,148 @@
+MODULE dynadv
+   !!==============================================================================
+   !!                       ***  MODULE  dynadv  ***
+   !! Ocean active tracers:  advection scheme control
+   !!==============================================================================
+   !! History :  1.0  !  2006-11  (G. Madec)  Original code
+   !!            3.3  !  2010-10  (C. Ethe, G. Madec)  reorganisation of initialisation phase
+   !!            3.6  !  2015-05  (N. Ducousso, G. Madec)  add Hollingsworth scheme as an option 
+   !!            4.0  !  2017-07  (G. Madec)  add a linear dynamics option
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   dyn_adv      : compute the momentum advection trend 
+   !!   dyn_adv_init : control the different options of advection scheme
+   !!----------------------------------------------------------------------
+   USE dom_oce         ! ocean space and time domain
+   USE dynadv_cen2     ! centred flux form advection      (dyn_adv_cen2 routine)
+   USE dynadv_ubs      ! UBS flux form advection          (dyn_adv_ubs  routine)
+   USE dynkeg          ! kinetic energy gradient          (dyn_keg      routine)
+   USE dynzad          ! vertical advection               (dyn_zad      routine)
+   !
+   USE in_out_manager  ! I/O manager
+   USE lib_mpp         ! MPP library
+   USE timing          ! Timing
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC dyn_adv       ! routine called by step module
+   PUBLIC dyn_adv_init  ! routine called by opa  module
+ 
+   !                                   !!* namdyn_adv namelist *
+   LOGICAL, PUBLIC ::   ln_dynadv_OFF   !: linear dynamics (no momentum advection)
+   LOGICAL, PUBLIC ::   ln_dynadv_vec   !: vector form
+   INTEGER, PUBLIC ::      nn_dynkeg       !: scheme of grad(KE): =0 C2 ; =1 Hollingsworth
+   LOGICAL, PUBLIC ::   ln_dynadv_cen2  !: flux form - 2nd order centered scheme flag
+   LOGICAL, PUBLIC ::   ln_dynadv_ubs   !: flux form - 3rd order UBS scheme flag
+   
+   INTEGER, PUBLIC ::   n_dynadv   !: choice of the formulation and scheme for momentum advection
+   !                               !  associated indices:
+   INTEGER, PUBLIC, PARAMETER ::   np_LIN_dyn = 0   ! no advection: linear dynamics
+   INTEGER, PUBLIC, PARAMETER ::   np_VEC_c2  = 1   ! vector form : 2nd order centered scheme
+   INTEGER, PUBLIC, PARAMETER ::   np_FLX_c2  = 2   ! flux   form : 2nd order centered scheme
+   INTEGER, PUBLIC, PARAMETER ::   np_FLX_ubs = 3   ! flux   form : 3rd order Upstream Biased Scheme
+
+   !! * Substitutions
+#  include "vectopt_loop_substitute.h90"
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 4.0 , NEMO Consortium (2017)
+   !! $Id$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE dyn_adv( kt )
+      !!---------------------------------------------------------------------
+      !!                  ***  ROUTINE dyn_adv  ***
+      !!                
+      !! ** Purpose :   compute the ocean momentum advection trend.
+      !!
+      !! ** Method  : - Update (ua,va) with the advection term following n_dynadv
+      !!
+      !!      NB: in flux form advection (ln_dynadv_cen2 or ln_dynadv_ubs=T) 
+      !!      a metric term is add to the coriolis term while in vector form 
+      !!      it is the relative vorticity which is added to coriolis term
+      !!      (see dynvor module).
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT( in ) ::   kt   ! ocean time-step index
+      !!----------------------------------------------------------------------
+      !
+      IF( ln_timing )   CALL timing_start( 'dyn_adv' )
+      !
+      SELECT CASE( n_dynadv )    !==  compute advection trend and add it to general trend  ==!
+      CASE( np_VEC_c2  )     
+         CALL dyn_keg     ( kt, nn_dynkeg )    ! vector form : horizontal gradient of kinetic energy
+         CALL dyn_zad     ( kt )               ! vector form : vertical advection
+      CASE( np_FLX_c2  ) 
+         CALL dyn_adv_cen2( kt )               ! 2nd order centered scheme
+      CASE( np_FLX_ubs )   
+         CALL dyn_adv_ubs ( kt )               ! 3rd order UBS      scheme (UP3)
+      END SELECT
+      !
+      IF( ln_timing )   CALL timing_stop( 'dyn_adv' )
+      !
+   END SUBROUTINE dyn_adv
+
+   
+   SUBROUTINE dyn_adv_init
+      !!---------------------------------------------------------------------
+      !!                  ***  ROUTINE dyn_adv_init  ***
+      !!                
+      !! ** Purpose :   Control the consistency between namelist options for 
+      !!              momentum advection formulation & scheme and set n_dynadv
+      !!----------------------------------------------------------------------
+      INTEGER ::   ioptio, ios   ! Local integer
+      !
+      NAMELIST/namdyn_adv/ ln_dynadv_OFF, ln_dynadv_vec, nn_dynkeg, ln_dynadv_cen2, ln_dynadv_ubs
+      !!----------------------------------------------------------------------
+      !
+      IF(lwp) THEN
+         WRITE(numout,*)
+         WRITE(numout,*) 'dyn_adv_init : choice/control of the momentum advection scheme'
+         WRITE(numout,*) '~~~~~~~~~~~~'
+      ENDIF
+      !
+      REWIND( numnam_ref )              ! Namelist namdyn_adv in reference namelist : Momentum advection scheme
+      READ  ( numnam_ref, namdyn_adv, IOSTAT = ios, ERR = 901)
+901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namdyn_adv in reference namelist', lwp )
+      REWIND( numnam_cfg )              ! Namelist namdyn_adv in configuration namelist : Momentum advection scheme
+      READ  ( numnam_cfg, namdyn_adv, IOSTAT = ios, ERR = 902 )
+902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namdyn_adv in configuration namelist', lwp )
+      IF(lwm) WRITE ( numond, namdyn_adv )
+
+      IF(lwp) THEN                    ! Namelist print
+         WRITE(numout,*) '   Namelist namdyn_adv : chose a advection formulation & scheme for momentum'
+         WRITE(numout,*) '      linear dynamics : no momentum advection          ln_dynadv_OFF  = ', ln_dynadv_OFF
+         WRITE(numout,*) '      Vector form: 2nd order centered scheme           ln_dynadv_vec  = ', ln_dynadv_vec
+         WRITE(numout,*) '         with Hollingsworth scheme (=1) or not (=0)       nn_dynkeg   = ', nn_dynkeg
+         WRITE(numout,*) '      flux form: 2nd order centred scheme              ln_dynadv_cen2 = ', ln_dynadv_cen2
+         WRITE(numout,*) '                 3rd order UBS scheme                  ln_dynadv_ubs  = ', ln_dynadv_ubs
+      ENDIF
+
+      ioptio = 0                      ! parameter control and set n_dynadv
+      IF( ln_dynadv_OFF  ) THEN   ;   ioptio = ioptio + 1   ;   n_dynadv = np_LIN_dyn   ;   ENDIF
+      IF( ln_dynadv_vec  ) THEN   ;   ioptio = ioptio + 1   ;   n_dynadv = np_VEC_c2    ;   ENDIF
+      IF( ln_dynadv_cen2 ) THEN   ;   ioptio = ioptio + 1   ;   n_dynadv = np_FLX_c2    ;   ENDIF
+      IF( ln_dynadv_ubs  ) THEN   ;   ioptio = ioptio + 1   ;   n_dynadv = np_FLX_ubs   ;   ENDIF
+
+      IF( ioptio /= 1 )   CALL ctl_stop( 'choose ONE and only ONE advection scheme' )
+      IF( nn_dynkeg /= nkeg_C2 .AND. nn_dynkeg /= nkeg_HW )   CALL ctl_stop( 'KEG scheme wrong value of nn_dynkeg' )
+
+
+      IF(lwp) THEN                    ! Print the choice
+         WRITE(numout,*)
+         SELECT CASE( n_dynadv )
+         CASE( np_LIN_dyn )   ;   WRITE(numout,*) '   ==>>>   linear dynamics : no momentum advection used'
+         CASE( np_VEC_c2  )   ;   WRITE(numout,*) '   ==>>>   vector form : keg + zad + vor is used' 
+            IF( nn_dynkeg == nkeg_C2  )   WRITE(numout,*) '              with Centered standard keg scheme'
+            IF( nn_dynkeg == nkeg_HW  )   WRITE(numout,*) '              with Hollingsworth keg scheme'
+         CASE( np_FLX_c2  )   ;   WRITE(numout,*) '   ==>>>   flux form   : 2nd order scheme is used'
+         CASE( np_FLX_ubs )   ;   WRITE(numout,*) '   ==>>>   flux form   : UBS       scheme is used'
+         END SELECT
+      ENDIF
+      !
+   END SUBROUTINE dyn_adv_init
+
+  !!======================================================================
+END MODULE dynadv
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DYN/dynadv_cen2.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DYN/dynadv_cen2.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DYN/dynadv_cen2.F90	(revision 9570)
@@ -0,0 +1,147 @@
+MODULE dynadv_cen2
+   !!======================================================================
+   !!                       ***  MODULE  dynadv  ***
+   !! Ocean dynamics: Update the momentum trend with the flux form advection
+   !!                 using a 2nd order centred scheme
+   !!======================================================================
+   !! History :  2.0  ! 2006-08  (G. Madec, S. Theetten)  Original code
+   !!            3.2  ! 2009-07  (R. Benshila)  Suppression of rigid-lid option
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   dyn_adv_cen2  : flux form momentum advection (ln_dynadv_cen2=T) using a 2nd order centred scheme  
+   !!----------------------------------------------------------------------
+   USE oce            ! ocean dynamics and tracers
+   USE dom_oce        ! ocean space and time domain
+   USE trd_oce        ! trends: ocean variables
+   USE trddyn         ! trend manager: dynamics
+   !
+   USE in_out_manager ! I/O manager
+   USE lib_mpp        ! MPP library
+   USE prtctl         ! Print control
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   dyn_adv_cen2   ! routine called by step.F90
+
+   !! * Substitutions
+#  include "vectopt_loop_substitute.h90"
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 4.0 , NEMO Consortium (2017)
+   !! $Id$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE dyn_adv_cen2( kt )
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE dyn_adv_cen2  ***
+      !!
+      !! ** Purpose :   Compute the now momentum advection trend in flux form
+      !!              and the general trend of the momentum equation.
+      !!
+      !! ** Method  :   Trend evaluated using now fields (centered in time) 
+      !!
+      !! ** Action  :   (ua,va) updated with the now vorticity term trend
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT( in ) ::   kt   ! ocean time-step index
+      !
+      INTEGER  ::   ji, jj, jk   ! dummy loop indices
+      REAL(wp), DIMENSION(jpi,jpj,jpk) ::  zfu_t, zfu_f, zfu_uw, zfu
+      REAL(wp), DIMENSION(jpi,jpj,jpk) ::  zfv_t, zfv_f, zfv_vw, zfv, zfw
+      !!----------------------------------------------------------------------
+      !
+      IF( kt == nit000 .AND. lwp ) THEN
+         WRITE(numout,*)
+         WRITE(numout,*) 'dyn_adv_cen2 : 2nd order flux form momentum advection'
+         WRITE(numout,*) '~~~~~~~~~~~~'
+      ENDIF
+      !
+      IF( l_trddyn ) THEN           ! trends: store the input trends
+         zfu_uw(:,:,:) = ua(:,:,:)
+         zfv_vw(:,:,:) = va(:,:,:)
+      ENDIF
+      !
+      !                             !==  Horizontal advection  ==!
+      !
+      DO jk = 1, jpkm1                    ! horizontal transport
+         zfu(:,:,jk) = 0.25_wp * e2u(:,:) * e3u_n(:,:,jk) * un(:,:,jk)
+         zfv(:,:,jk) = 0.25_wp * e1v(:,:) * e3v_n(:,:,jk) * vn(:,:,jk)
+         DO jj = 1, jpjm1                 ! horizontal momentum fluxes (at T- and F-point)
+            DO ji = 1, fs_jpim1   ! vector opt.
+               zfu_t(ji+1,jj  ,jk) = ( zfu(ji,jj,jk) + zfu(ji+1,jj,jk) ) * ( un(ji,jj,jk) + un(ji+1,jj  ,jk) )
+               zfv_f(ji  ,jj  ,jk) = ( zfv(ji,jj,jk) + zfv(ji+1,jj,jk) ) * ( un(ji,jj,jk) + un(ji  ,jj+1,jk) )
+               zfu_f(ji  ,jj  ,jk) = ( zfu(ji,jj,jk) + zfu(ji,jj+1,jk) ) * ( vn(ji,jj,jk) + vn(ji+1,jj  ,jk) )
+               zfv_t(ji  ,jj+1,jk) = ( zfv(ji,jj,jk) + zfv(ji,jj+1,jk) ) * ( vn(ji,jj,jk) + vn(ji  ,jj+1,jk) )
+            END DO
+         END DO
+         DO jj = 2, jpjm1                 ! divergence of horizontal momentum fluxes
+            DO ji = fs_2, fs_jpim1   ! vector opt.
+               ua(ji,jj,jk) = ua(ji,jj,jk) - (  zfu_t(ji+1,jj,jk) - zfu_t(ji,jj  ,jk)    &
+                  &                           + zfv_f(ji  ,jj,jk) - zfv_f(ji,jj-1,jk)  ) * r1_e1e2u(ji,jj) / e3u_n(ji,jj,jk)
+               va(ji,jj,jk) = va(ji,jj,jk) - (  zfu_f(ji,jj  ,jk) - zfu_f(ji-1,jj,jk)    &
+                  &                           + zfv_t(ji,jj+1,jk) - zfv_t(ji  ,jj,jk)  ) * r1_e1e2v(ji,jj) / e3v_n(ji,jj,jk)
+            END DO
+         END DO
+      END DO
+      !
+      IF( l_trddyn ) THEN           ! trends: send trend to trddyn for diagnostic
+         zfu_uw(:,:,:) = ua(:,:,:) - zfu_uw(:,:,:)
+         zfv_vw(:,:,:) = va(:,:,:) - zfv_vw(:,:,:)
+         CALL trd_dyn( zfu_uw, zfv_vw, jpdyn_keg, kt )
+         zfu_t(:,:,:) = ua(:,:,:)
+         zfv_t(:,:,:) = va(:,:,:)
+      ENDIF
+      !
+      !                             !==  Vertical advection  ==!
+      !
+      DO jj = 2, jpjm1                    ! surface/bottom advective fluxes set to zero
+         DO ji = fs_2, fs_jpim1
+            zfu_uw(ji,jj,jpk) = 0._wp   ;   zfv_vw(ji,jj,jpk) = 0._wp
+            zfu_uw(ji,jj, 1 ) = 0._wp   ;   zfv_vw(ji,jj, 1 ) = 0._wp
+         END DO
+      END DO
+      IF( ln_linssh ) THEN                ! linear free surface: advection through the surface
+         DO jj = 2, jpjm1
+            DO ji = fs_2, fs_jpim1
+               zfu_uw(ji,jj,1) = 0.5_wp * ( e1e2t(ji,jj) * wn(ji,jj,1) + e1e2t(ji+1,jj) * wn(ji+1,jj,1) ) * un(ji,jj,1)
+               zfv_vw(ji,jj,1) = 0.5_wp * ( e1e2t(ji,jj) * wn(ji,jj,1) + e1e2t(ji,jj+1) * wn(ji,jj+1,1) ) * vn(ji,jj,1)
+            END DO
+         END DO
+      ENDIF
+      DO jk = 2, jpkm1                    ! interior advective fluxes
+         DO jj = 2, jpj                       ! 1/4 * Vertical transport
+            DO ji = 2, jpi
+               zfw(ji,jj,jk) = 0.25_wp * e1e2t(ji,jj) * wn(ji,jj,jk)
+            END DO
+         END DO
+         DO jj = 2, jpjm1
+            DO ji = fs_2, fs_jpim1   ! vector opt.
+               zfu_uw(ji,jj,jk) = ( zfw(ji,jj,jk) + zfw(ji+1,jj  ,jk) ) * ( un(ji,jj,jk) + un(ji,jj,jk-1) )
+               zfv_vw(ji,jj,jk) = ( zfw(ji,jj,jk) + zfw(ji  ,jj+1,jk) ) * ( vn(ji,jj,jk) + vn(ji,jj,jk-1) )
+            END DO
+         END DO
+      END DO
+      DO jk = 1, jpkm1                    ! divergence of vertical momentum flux divergence
+         DO jj = 2, jpjm1 
+            DO ji = fs_2, fs_jpim1   ! vector opt.
+               ua(ji,jj,jk) = ua(ji,jj,jk) - ( zfu_uw(ji,jj,jk) - zfu_uw(ji,jj,jk+1) ) * r1_e1e2u(ji,jj) / e3u_n(ji,jj,jk)
+               va(ji,jj,jk) = va(ji,jj,jk) - ( zfv_vw(ji,jj,jk) - zfv_vw(ji,jj,jk+1) ) * r1_e1e2v(ji,jj) / e3v_n(ji,jj,jk)
+            END DO
+         END DO
+      END DO
+      !
+      IF( l_trddyn ) THEN                 ! trends: send trend to trddyn for diagnostic
+         zfu_t(:,:,:) = ua(:,:,:) - zfu_t(:,:,:)
+         zfv_t(:,:,:) = va(:,:,:) - zfv_t(:,:,:)
+         CALL trd_dyn( zfu_t, zfv_t, jpdyn_zad, kt )
+      ENDIF
+      !                                   ! Control print
+      IF(ln_ctl)   CALL prt_ctl( tab3d_1=ua, clinfo1=' cen2 adv - Ua: ', mask1=umask,   &
+         &                       tab3d_2=va, clinfo2=           ' Va: ', mask2=vmask, clinfo3='dyn' )
+      !
+   END SUBROUTINE dyn_adv_cen2
+
+   !!==============================================================================
+END MODULE dynadv_cen2
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DYN/dynadv_ubs.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DYN/dynadv_ubs.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DYN/dynadv_ubs.F90	(revision 9570)
@@ -0,0 +1,240 @@
+MODULE dynadv_ubs
+   !!======================================================================
+   !!                       ***  MODULE  dynadv_ubs  ***
+   !! Ocean dynamics: Update the momentum trend with the flux form advection
+   !!                 trend using a 3rd order upstream biased scheme
+   !!======================================================================
+   !! History :  2.0  ! 2006-08  (R. Benshila, L. Debreu)  Original code
+   !!            3.2  ! 2009-07  (R. Benshila)  Suppression of rigid-lid option
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   dyn_adv_ubs   : flux form momentum advection using    (ln_dynadv=T)
+   !!                   an 3rd order Upstream Biased Scheme or Quick scheme
+   !!                   combined with 2nd or 4th order finite differences 
+   !!----------------------------------------------------------------------
+   USE oce            ! ocean dynamics and tracers
+   USE dom_oce        ! ocean space and time domain
+   USE trd_oce        ! trends: ocean variables
+   USE trddyn         ! trend manager: dynamics
+   !
+   USE in_out_manager ! I/O manager
+   USE prtctl         ! Print control
+   USE lbclnk         ! ocean lateral boundary conditions (or mpp link)
+   USE lib_mpp        ! MPP library
+
+   IMPLICIT NONE
+   PRIVATE
+
+   REAL(wp), PARAMETER :: gamma1 = 1._wp/3._wp  ! =1/4 quick      ; =1/3  3rd order UBS
+   REAL(wp), PARAMETER :: gamma2 = 1._wp/32._wp ! =0   2nd order  ; =1/32 4th order centred
+
+   PUBLIC   dyn_adv_ubs   ! routine called by step.F90
+
+   !! * Substitutions
+#  include "vectopt_loop_substitute.h90"
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 4.0 , NEMO Consortium (2017)
+   !! $Id$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE dyn_adv_ubs( kt )
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE dyn_adv_ubs  ***
+      !!
+      !! ** Purpose :   Compute the now momentum advection trend in flux form
+      !!              and the general trend of the momentum equation.
+      !!
+      !! ** Method  :   The scheme is the one implemeted in ROMS. It depends 
+      !!      on two parameter gamma1 and gamma2. The former control the 
+      !!      upstream baised part of the scheme and the later the centred 
+      !!      part:     gamma1 = 0    pure centered  (no diffusive part)
+      !!                       = 1/4  Quick scheme
+      !!                       = 1/3  3rd order Upstream biased scheme
+      !!                gamma2 = 0    2nd order finite differencing 
+      !!                       = 1/32 4th order finite differencing
+      !!      For stability reasons, the first term of the fluxes which cor-
+      !!      responds to a second order centered scheme is evaluated using  
+      !!      the now velocity (centered in time) while the second term which  
+      !!      is the diffusive part of the scheme, is evaluated using the 
+      !!      before velocity (forward in time). 
+      !!      Default value (hard coded in the begining of the module) are 
+      !!      gamma1=1/3 and gamma2=1/32.
+      !!
+      !! ** Action : - (ua,va) updated with the 3D advective momentum trends
+      !!
+      !! Reference : Shchepetkin & McWilliams, 2005, Ocean Modelling. 
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT(in) ::   kt   ! ocean time-step index
+      !
+      INTEGER  ::   ji, jj, jk   ! dummy loop indices
+      REAL(wp) ::   zui, zvj, zfuj, zfvi, zl_u, zl_v   ! local scalars
+      REAL(wp), DIMENSION(jpi,jpj,jpk)   ::   zfu_t, zfu_f, zfu_uw, zfu
+      REAL(wp), DIMENSION(jpi,jpj,jpk)   ::   zfv_t, zfv_f, zfv_vw, zfv, zfw
+      REAL(wp), DIMENSION(jpi,jpj,jpk,2) ::   zlu_uu, zlu_uv
+      REAL(wp), DIMENSION(jpi,jpj,jpk,2) ::   zlv_vv, zlv_vu
+      !!----------------------------------------------------------------------
+      !
+      IF( kt == nit000 ) THEN
+         IF(lwp) WRITE(numout,*)
+         IF(lwp) WRITE(numout,*) 'dyn_adv_ubs : UBS flux form momentum advection'
+         IF(lwp) WRITE(numout,*) '~~~~~~~~~~~'
+      ENDIF
+      !
+      zfu_t(:,:,:) = 0._wp
+      zfv_t(:,:,:) = 0._wp
+      zfu_f(:,:,:) = 0._wp
+      zfv_f(:,:,:) = 0._wp
+      !
+      zlu_uu(:,:,:,:) = 0._wp
+      zlv_vv(:,:,:,:) = 0._wp 
+      zlu_uv(:,:,:,:) = 0._wp 
+      zlv_vu(:,:,:,:) = 0._wp 
+      !
+      IF( l_trddyn ) THEN           ! trends: store the input trends
+         zfu_uw(:,:,:) = ua(:,:,:)
+         zfv_vw(:,:,:) = va(:,:,:)
+      ENDIF
+      !                                      ! =========================== !
+      DO jk = 1, jpkm1                       !  Laplacian of the velocity  !
+         !                                   ! =========================== !
+         !                                         ! horizontal volume fluxes
+         zfu(:,:,jk) = e2u(:,:) * e3u_n(:,:,jk) * un(:,:,jk)
+         zfv(:,:,jk) = e1v(:,:) * e3v_n(:,:,jk) * vn(:,:,jk)
+         !            
+         DO jj = 2, jpjm1                          ! laplacian
+            DO ji = fs_2, fs_jpim1   ! vector opt.
+               zlu_uu(ji,jj,jk,1) = ( ub (ji+1,jj  ,jk) - 2.*ub (ji,jj,jk) + ub (ji-1,jj  ,jk) ) * umask(ji,jj,jk)
+               zlv_vv(ji,jj,jk,1) = ( vb (ji  ,jj+1,jk) - 2.*vb (ji,jj,jk) + vb (ji  ,jj-1,jk) ) * vmask(ji,jj,jk)
+               zlu_uv(ji,jj,jk,1) = ( ub (ji  ,jj+1,jk) - ub (ji  ,jj  ,jk) ) * fmask(ji  ,jj  ,jk)   &
+                  &               - ( ub (ji  ,jj  ,jk) - ub (ji  ,jj-1,jk) ) * fmask(ji  ,jj-1,jk)
+               zlv_vu(ji,jj,jk,1) = ( vb (ji+1,jj  ,jk) - vb (ji  ,jj  ,jk) ) * fmask(ji  ,jj  ,jk)   &
+                  &               - ( vb (ji  ,jj  ,jk) - vb (ji-1,jj  ,jk) ) * fmask(ji-1,jj  ,jk)
+               !
+               zlu_uu(ji,jj,jk,2) = ( zfu(ji+1,jj  ,jk) - 2.*zfu(ji,jj,jk) + zfu(ji-1,jj  ,jk) ) * umask(ji,jj,jk)
+               zlv_vv(ji,jj,jk,2) = ( zfv(ji  ,jj+1,jk) - 2.*zfv(ji,jj,jk) + zfv(ji  ,jj-1,jk) ) * vmask(ji,jj,jk)
+               zlu_uv(ji,jj,jk,2) = ( zfu(ji  ,jj+1,jk) - zfu(ji  ,jj  ,jk) ) * fmask(ji  ,jj  ,jk)   &
+                  &               - ( zfu(ji  ,jj  ,jk) - zfu(ji  ,jj-1,jk) ) * fmask(ji  ,jj-1,jk)
+               zlv_vu(ji,jj,jk,2) = ( zfv(ji+1,jj  ,jk) - zfv(ji  ,jj  ,jk) ) * fmask(ji  ,jj  ,jk)   &
+                  &               - ( zfv(ji  ,jj  ,jk) - zfv(ji-1,jj  ,jk) ) * fmask(ji-1,jj  ,jk)
+            END DO
+         END DO
+      END DO
+      CALL lbc_lnk_multi( zlu_uu(:,:,:,1), 'U', 1. , zlu_uv(:,:,:,1), 'U', 1.,  &
+                      &   zlu_uu(:,:,:,2), 'U', 1. , zlu_uv(:,:,:,2), 'U', 1.,  & 
+                      &   zlv_vv(:,:,:,1), 'V', 1. , zlv_vu(:,:,:,1), 'V', 1.,  &
+                      &   zlv_vv(:,:,:,2), 'V', 1. , zlv_vu(:,:,:,2), 'V', 1.   )
+      !
+      !                                      ! ====================== !
+      !                                      !  Horizontal advection  !
+      DO jk = 1, jpkm1                       ! ====================== !
+         !                                         ! horizontal volume fluxes
+         zfu(:,:,jk) = 0.25_wp * e2u(:,:) * e3u_n(:,:,jk) * un(:,:,jk)
+         zfv(:,:,jk) = 0.25_wp * e1v(:,:) * e3v_n(:,:,jk) * vn(:,:,jk)
+         !
+         DO jj = 1, jpjm1                          ! horizontal momentum fluxes at T- and F-point
+            DO ji = 1, fs_jpim1   ! vector opt.
+               zui = ( un(ji,jj,jk) + un(ji+1,jj  ,jk) )
+               zvj = ( vn(ji,jj,jk) + vn(ji  ,jj+1,jk) )
+               !
+               IF( zui > 0 ) THEN   ;   zl_u = zlu_uu(ji  ,jj,jk,1)
+               ELSE                 ;   zl_u = zlu_uu(ji+1,jj,jk,1)
+               ENDIF
+               IF( zvj > 0 ) THEN   ;   zl_v = zlv_vv(ji,jj  ,jk,1)
+               ELSE                 ;   zl_v = zlv_vv(ji,jj+1,jk,1)
+               ENDIF
+               !
+               zfu_t(ji+1,jj  ,jk) = ( zfu(ji,jj,jk) + zfu(ji+1,jj  ,jk)                               &
+                  &                    - gamma2 * ( zlu_uu(ji,jj,jk,2) + zlu_uu(ji+1,jj  ,jk,2) )  )   &
+                  &                * ( zui - gamma1 * zl_u)
+               zfv_t(ji  ,jj+1,jk) = ( zfv(ji,jj,jk) + zfv(ji  ,jj+1,jk)                               &
+                  &                    - gamma2 * ( zlv_vv(ji,jj,jk,2) + zlv_vv(ji  ,jj+1,jk,2) )  )   &
+                  &                * ( zvj - gamma1 * zl_v)
+               !
+               zfuj = ( zfu(ji,jj,jk) + zfu(ji  ,jj+1,jk) )
+               zfvi = ( zfv(ji,jj,jk) + zfv(ji+1,jj  ,jk) )
+               IF( zfuj > 0 ) THEN   ;    zl_v = zlv_vu( ji  ,jj  ,jk,1)
+               ELSE                  ;    zl_v = zlv_vu( ji+1,jj,jk,1)
+               ENDIF
+               IF( zfvi > 0 ) THEN   ;    zl_u = zlu_uv( ji,jj  ,jk,1)
+               ELSE                  ;    zl_u = zlu_uv( ji,jj+1,jk,1)
+               ENDIF
+               !
+               zfv_f(ji  ,jj  ,jk) = ( zfvi - gamma2 * ( zlv_vu(ji,jj,jk,2) + zlv_vu(ji+1,jj  ,jk,2) )  )   &
+                  &                * ( un(ji,jj,jk) + un(ji  ,jj+1,jk) - gamma1 * zl_u )
+               zfu_f(ji  ,jj  ,jk) = ( zfuj - gamma2 * ( zlu_uv(ji,jj,jk,2) + zlu_uv(ji  ,jj+1,jk,2) )  )   &
+                  &                * ( vn(ji,jj,jk) + vn(ji+1,jj  ,jk) - gamma1 * zl_v )
+            END DO
+         END DO
+         DO jj = 2, jpjm1                          ! divergence of horizontal momentum fluxes
+            DO ji = fs_2, fs_jpim1   ! vector opt.
+               ua(ji,jj,jk) = ua(ji,jj,jk) - (  zfu_t(ji+1,jj,jk) - zfu_t(ji,jj  ,jk)    &
+                  &                           + zfv_f(ji  ,jj,jk) - zfv_f(ji,jj-1,jk)  ) * r1_e1e2u(ji,jj) / e3u_n(ji,jj,jk)
+               va(ji,jj,jk) = va(ji,jj,jk) - (  zfu_f(ji,jj  ,jk) - zfu_f(ji-1,jj,jk)    &
+                  &                           + zfv_t(ji,jj+1,jk) - zfv_t(ji  ,jj,jk)  ) * r1_e1e2v(ji,jj) / e3v_n(ji,jj,jk)
+            END DO
+         END DO
+      END DO
+      IF( l_trddyn ) THEN                          ! trends: send trends to trddyn for diagnostic
+         zfu_uw(:,:,:) = ua(:,:,:) - zfu_uw(:,:,:)
+         zfv_vw(:,:,:) = va(:,:,:) - zfv_vw(:,:,:)
+         CALL trd_dyn( zfu_uw, zfv_vw, jpdyn_keg, kt )
+         zfu_t(:,:,:) = ua(:,:,:)
+         zfv_t(:,:,:) = va(:,:,:)
+      ENDIF
+      !                                      ! ==================== !
+      !                                      !  Vertical advection  !
+      !                                      ! ==================== !
+      DO jj = 2, jpjm1                             ! surface/bottom advective fluxes set to zero                  
+         DO ji = fs_2, fs_jpim1
+            zfu_uw(ji,jj,jpk) = 0._wp
+            zfv_vw(ji,jj,jpk) = 0._wp
+            zfu_uw(ji,jj, 1 ) = 0._wp
+            zfv_vw(ji,jj, 1 ) = 0._wp
+         END DO
+      END DO
+      IF( ln_linssh ) THEN                         ! constant volume : advection through the surface
+         DO jj = 2, jpjm1
+            DO ji = fs_2, fs_jpim1
+               zfu_uw(ji,jj,1) = 0.5_wp * ( e1e2t(ji,jj) * wn(ji,jj,1) + e1e2t(ji+1,jj) * wn(ji+1,jj,1) ) * un(ji,jj,1)
+               zfv_vw(ji,jj,1) = 0.5_wp * ( e1e2t(ji,jj) * wn(ji,jj,1) + e1e2t(ji,jj+1) * wn(ji,jj+1,1) ) * vn(ji,jj,1)
+            END DO
+         END DO
+      ENDIF
+      DO jk = 2, jpkm1                          ! interior fluxes
+         DO jj = 2, jpj
+            DO ji = 2, jpi
+               zfw(ji,jj,jk) = 0.25_wp * e1e2t(ji,jj) * wn(ji,jj,jk)
+            END DO
+         END DO
+         DO jj = 2, jpjm1
+            DO ji = fs_2, fs_jpim1   ! vector opt.
+               zfu_uw(ji,jj,jk) = ( zfw(ji,jj,jk)+ zfw(ji+1,jj,jk) ) * ( un(ji,jj,jk) + un(ji,jj,jk-1) )
+               zfv_vw(ji,jj,jk) = ( zfw(ji,jj,jk)+ zfw(ji,jj+1,jk) ) * ( vn(ji,jj,jk) + vn(ji,jj,jk-1) )
+            END DO
+         END DO
+      END DO
+      DO jk = 1, jpkm1                          ! divergence of vertical momentum flux divergence
+         DO jj = 2, jpjm1
+            DO ji = fs_2, fs_jpim1   ! vector opt.
+               ua(ji,jj,jk) =  ua(ji,jj,jk) - ( zfu_uw(ji,jj,jk) - zfu_uw(ji,jj,jk+1) ) * r1_e1e2u(ji,jj) / e3u_n(ji,jj,jk)
+               va(ji,jj,jk) =  va(ji,jj,jk) - ( zfv_vw(ji,jj,jk) - zfv_vw(ji,jj,jk+1) ) * r1_e1e2v(ji,jj) / e3v_n(ji,jj,jk)
+            END DO
+         END DO
+      END DO
+      !
+      IF( l_trddyn ) THEN                       ! save the vertical advection trend for diagnostic
+         zfu_t(:,:,:) = ua(:,:,:) - zfu_t(:,:,:)
+         zfv_t(:,:,:) = va(:,:,:) - zfv_t(:,:,:)
+         CALL trd_dyn( zfu_t, zfv_t, jpdyn_zad, kt )
+      ENDIF
+      !                                         ! Control print
+      IF(ln_ctl)   CALL prt_ctl( tab3d_1=ua, clinfo1=' ubs2 adv - Ua: ', mask1=umask,   &
+         &                       tab3d_2=va, clinfo2=           ' Va: ', mask2=vmask, clinfo3='dyn' )
+      !
+   END SUBROUTINE dyn_adv_ubs
+
+   !!==============================================================================
+END MODULE dynadv_ubs
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DYN/dynhpg.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DYN/dynhpg.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DYN/dynhpg.F90	(revision 9570)
@@ -0,0 +1,1469 @@
+MODULE dynhpg
+   !!======================================================================
+   !!                       ***  MODULE  dynhpg  ***
+   !! Ocean dynamics:  hydrostatic pressure gradient trend
+   !!======================================================================
+   !! History :  OPA  !  1987-09  (P. Andrich, M.-A. Foujols)  hpg_zco: Original code
+   !!            5.0  !  1991-11  (G. Madec)
+   !!            7.0  !  1996-01  (G. Madec)  hpg_sco: Original code for s-coordinates
+   !!            8.0  !  1997-05  (G. Madec)  split dynber into dynkeg and dynhpg
+   !!            8.5  !  2002-07  (G. Madec)  F90: Free form and module
+   !!            8.5  !  2002-08  (A. Bozec)  hpg_zps: Original code
+   !!   NEMO     1.0  !  2005-10  (A. Beckmann, B.W. An)  various s-coordinate options
+   !!                 !         Original code for hpg_ctl, hpg_hel hpg_wdj, hpg_djc, hpg_rot
+   !!             -   !  2005-11  (G. Madec) style & small optimisation
+   !!            3.3  !  2010-10  (C. Ethe, G. Madec) reorganisation of initialisation phase
+   !!            3.4  !  2011-11  (H. Liu) hpg_prj: Original code for s-coordinates
+   !!                 !           (A. Coward) suppression of hel, wdj and rot options
+   !!            3.6  !  2014-11  (P. Mathiot) hpg_isf: original code for ice shelf cavity
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   dyn_hpg      : update the momentum trend with the now horizontal
+   !!                  gradient of the hydrostatic pressure
+   !!   dyn_hpg_init : initialisation and control of options
+   !!       hpg_zco  : z-coordinate scheme
+   !!       hpg_zps  : z-coordinate plus partial steps (interpolation)
+   !!       hpg_sco  : s-coordinate (standard jacobian formulation)
+   !!       hpg_isf  : s-coordinate (sco formulation) adapted to ice shelf
+   !!       hpg_djc  : s-coordinate (Density Jacobian with Cubic polynomial)
+   !!       hpg_prj  : s-coordinate (Pressure Jacobian with Cubic polynomial)
+   !!----------------------------------------------------------------------
+   USE oce             ! ocean dynamics and tracers
+   USE sbc_oce         ! surface variable (only for the flag with ice shelf)
+   USE dom_oce         ! ocean space and time domain
+   USE wet_dry         ! wetting and drying
+   USE phycst          ! physical constants
+   USE trd_oce         ! trends: ocean variables
+   USE trddyn          ! trend manager: dynamics
+!jc   USE zpshde          ! partial step: hor. derivative     (zps_hde routine)
+   !
+   USE in_out_manager  ! I/O manager
+   USE prtctl          ! Print control
+   USE lbclnk          ! lateral boundary condition 
+   USE lib_mpp         ! MPP library
+   USE eosbn2          ! compute density
+   USE timing          ! Timing
+   USE iom
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   dyn_hpg        ! routine called by step module
+   PUBLIC   dyn_hpg_init   ! routine called by opa module
+
+   !                                !!* Namelist namdyn_hpg : hydrostatic pressure gradient
+   LOGICAL, PUBLIC ::   ln_hpg_zco   !: z-coordinate - full steps
+   LOGICAL, PUBLIC ::   ln_hpg_zps   !: z-coordinate - partial steps (interpolation)
+   LOGICAL, PUBLIC ::   ln_hpg_sco   !: s-coordinate (standard jacobian formulation)
+   LOGICAL, PUBLIC ::   ln_hpg_djc   !: s-coordinate (Density Jacobian with Cubic polynomial)
+   LOGICAL, PUBLIC ::   ln_hpg_prj   !: s-coordinate (Pressure Jacobian scheme)
+   LOGICAL, PUBLIC ::   ln_hpg_isf   !: s-coordinate similar to sco modify for isf
+
+   !                                !! Flag to control the type of hydrostatic pressure gradient
+   INTEGER, PARAMETER ::   np_ERROR  =-10   ! error in specification of lateral diffusion
+   INTEGER, PARAMETER ::   np_zco    =  0   ! z-coordinate - full steps
+   INTEGER, PARAMETER ::   np_zps    =  1   ! z-coordinate - partial steps (interpolation)
+   INTEGER, PARAMETER ::   np_sco    =  2   ! s-coordinate (standard jacobian formulation)
+   INTEGER, PARAMETER ::   np_djc    =  3   ! s-coordinate (Density Jacobian with Cubic polynomial)
+   INTEGER, PARAMETER ::   np_prj    =  4   ! s-coordinate (Pressure Jacobian scheme)
+   INTEGER, PARAMETER ::   np_isf    =  5   ! s-coordinate similar to sco modify for isf
+   !
+   INTEGER, PUBLIC ::   nhpg         !: type of pressure gradient scheme used ! (deduced from ln_hpg_... flags) (PUBLIC for TAM)
+
+   !! * Substitutions
+#  include "vectopt_loop_substitute.h90"
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO Consortium (2010)
+   !! $Id$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE dyn_hpg( kt )
+      !!---------------------------------------------------------------------
+      !!                  ***  ROUTINE dyn_hpg  ***
+      !!
+      !! ** Method  :   Call the hydrostatic pressure gradient routine
+      !!              using the scheme defined in the namelist
+      !!
+      !! ** Action : - Update (ua,va) with the now hydrastatic pressure trend
+      !!             - send trends to trd_dyn for futher diagnostics (l_trddyn=T)
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT(in) ::   kt   ! ocean time-step index
+      REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) ::   ztrdu, ztrdv
+      !!----------------------------------------------------------------------
+      !
+      IF( ln_timing )   CALL timing_start('dyn_hpg')
+      !
+      IF( l_trddyn ) THEN                    ! Temporary saving of ua and va trends (l_trddyn)
+         ALLOCATE( ztrdu(jpi,jpj,jpk) , ztrdv(jpi,jpj,jpk) )
+         ztrdu(:,:,:) = ua(:,:,:)
+         ztrdv(:,:,:) = va(:,:,:)
+      ENDIF
+      !
+      SELECT CASE ( nhpg )      ! Hydrostatic pressure gradient computation
+      CASE ( np_zco )   ;   CALL hpg_zco    ( kt )      ! z-coordinate
+      CASE ( np_zps )   ;   CALL hpg_zps    ( kt )      ! z-coordinate plus partial steps (interpolation)
+      CASE ( np_sco )   ;   CALL hpg_sco    ( kt )      ! s-coordinate (standard jacobian formulation)
+      CASE ( np_djc )   ;   CALL hpg_djc    ( kt )      ! s-coordinate (Density Jacobian with Cubic polynomial)
+      CASE ( np_prj )   ;   CALL hpg_prj    ( kt )      ! s-coordinate (Pressure Jacobian scheme)
+      CASE ( np_isf )   ;   CALL hpg_isf    ( kt )      ! s-coordinate similar to sco modify for ice shelf
+      END SELECT
+      !
+      IF( l_trddyn ) THEN      ! save the hydrostatic pressure gradient trends for momentum trend diagnostics
+         ztrdu(:,:,:) = ua(:,:,:) - ztrdu(:,:,:)
+         ztrdv(:,:,:) = va(:,:,:) - ztrdv(:,:,:)
+         CALL trd_dyn( ztrdu, ztrdv, jpdyn_hpg, kt )
+         DEALLOCATE( ztrdu , ztrdv )
+      ENDIF
+      !
+      IF(ln_ctl)   CALL prt_ctl( tab3d_1=ua, clinfo1=' hpg  - Ua: ', mask1=umask,   &
+         &                       tab3d_2=va, clinfo2=       ' Va: ', mask2=vmask, clinfo3='dyn' )
+      !
+      IF( ln_timing )   CALL timing_stop('dyn_hpg')
+      !
+   END SUBROUTINE dyn_hpg
+
+
+   SUBROUTINE dyn_hpg_init
+      !!----------------------------------------------------------------------
+      !!                 ***  ROUTINE dyn_hpg_init  ***
+      !!
+      !! ** Purpose :   initializations for the hydrostatic pressure gradient
+      !!              computation and consistency control
+      !!
+      !! ** Action  :   Read the namelist namdyn_hpg and check the consistency
+      !!      with the type of vertical coordinate used (zco, zps, sco)
+      !!----------------------------------------------------------------------
+      INTEGER ::   ioptio = 0      ! temporary integer
+      INTEGER ::   ios             ! Local integer output status for namelist read
+      !!
+      INTEGER  ::   ji, jj, jk, ikt    ! dummy loop indices      ISF
+      REAL(wp) ::   znad
+      REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) ::  zts_top, zrhd   ! hypothesys on isf density
+      REAL(wp), ALLOCATABLE, DIMENSION(:,:)   ::  zrhdtop_isf    ! density at bottom of ISF
+      REAL(wp), ALLOCATABLE, DIMENSION(:,:)   ::  ziceload       ! density at bottom of ISF
+      !!
+      NAMELIST/namdyn_hpg/ ln_hpg_zco, ln_hpg_zps, ln_hpg_sco,     &
+         &                 ln_hpg_djc, ln_hpg_prj, ln_hpg_isf
+      !!----------------------------------------------------------------------
+      !
+      REWIND( numnam_ref )              ! Namelist namdyn_hpg in reference namelist : Hydrostatic pressure gradient
+      READ  ( numnam_ref, namdyn_hpg, IOSTAT = ios, ERR = 901)
+901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namdyn_hpg in reference namelist', lwp )
+      !
+      REWIND( numnam_cfg )              ! Namelist namdyn_hpg in configuration namelist : Hydrostatic pressure gradient
+      READ  ( numnam_cfg, namdyn_hpg, IOSTAT = ios, ERR = 902 )
+902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namdyn_hpg in configuration namelist', lwp )
+      IF(lwm) WRITE ( numond, namdyn_hpg )
+      !
+      IF(lwp) THEN                   ! Control print
+         WRITE(numout,*)
+         WRITE(numout,*) 'dyn_hpg_init : hydrostatic pressure gradient initialisation'
+         WRITE(numout,*) '~~~~~~~~~~~~'
+         WRITE(numout,*) '   Namelist namdyn_hpg : choice of hpg scheme'
+         WRITE(numout,*) '      z-coord. - full steps                             ln_hpg_zco    = ', ln_hpg_zco
+         WRITE(numout,*) '      z-coord. - partial steps (interpolation)          ln_hpg_zps    = ', ln_hpg_zps
+         WRITE(numout,*) '      s-coord. (standard jacobian formulation)          ln_hpg_sco    = ', ln_hpg_sco
+         WRITE(numout,*) '      s-coord. (standard jacobian formulation) for isf  ln_hpg_isf    = ', ln_hpg_isf
+         WRITE(numout,*) '      s-coord. (Density Jacobian: Cubic polynomial)     ln_hpg_djc    = ', ln_hpg_djc
+         WRITE(numout,*) '      s-coord. (Pressure Jacobian: Cubic polynomial)    ln_hpg_prj    = ', ln_hpg_prj
+      ENDIF
+      !
+      IF( ln_hpg_djc )   &
+         &   CALL ctl_stop('dyn_hpg_init : Density Jacobian: Cubic polynominal method',   &
+         &                 '   currently disabled (bugs under investigation).'        ,   &
+         &                 '   Please select either  ln_hpg_sco or  ln_hpg_prj instead' )
+         !
+      IF( .NOT.ln_linssh .AND. .NOT.(ln_hpg_sco.OR.ln_hpg_prj.OR.ln_hpg_isf) )          &
+         &   CALL ctl_stop('dyn_hpg_init : non-linear free surface requires either ',   &
+         &                 '   the standard jacobian formulation hpg_sco    or '    ,   &
+         &                 '   the pressure jacobian formulation hpg_prj'             )
+         !
+      IF( ln_hpg_isf ) THEN
+         IF( .NOT. ln_isfcav )   CALL ctl_stop( ' hpg_isf not available if ln_isfcav = false ' )
+       ELSE
+         IF(       ln_isfcav )   CALL ctl_stop( 'Only hpg_isf has been corrected to work with ice shelf cavity.' )
+      ENDIF
+      !
+      !                               ! Set nhpg from ln_hpg_... flags & consistency check
+      nhpg   = np_ERROR
+      ioptio = 0
+      IF( ln_hpg_zco ) THEN   ;   nhpg = np_zco   ;   ioptio = ioptio +1   ;   ENDIF
+      IF( ln_hpg_zps ) THEN   ;   nhpg = np_zps   ;   ioptio = ioptio +1   ;   ENDIF
+      IF( ln_hpg_sco ) THEN   ;   nhpg = np_sco   ;   ioptio = ioptio +1   ;   ENDIF
+      IF( ln_hpg_djc ) THEN   ;   nhpg = np_djc   ;   ioptio = ioptio +1   ;   ENDIF
+      IF( ln_hpg_prj ) THEN   ;   nhpg = np_prj   ;   ioptio = ioptio +1   ;   ENDIF
+      IF( ln_hpg_isf ) THEN   ;   nhpg = np_isf   ;   ioptio = ioptio +1   ;   ENDIF
+      !
+      IF( ioptio /= 1 )   CALL ctl_stop( 'NO or several hydrostatic pressure gradient options used' )
+      ! 
+      IF(lwp) THEN
+         WRITE(numout,*)
+         SELECT CASE( nhpg )
+         CASE( np_zco )   ;   WRITE(numout,*) '   ==>>>   z-coord. - full steps '
+         CASE( np_zps )   ;   WRITE(numout,*) '   ==>>>   z-coord. - partial steps (interpolation)'
+         CASE( np_sco )   ;   WRITE(numout,*) '   ==>>>   s-coord. (standard jacobian formulation)'
+         CASE( np_djc )   ;   WRITE(numout,*) '   ==>>>   s-coord. (Density Jacobian: Cubic polynomial)'
+         CASE( np_prj )   ;   WRITE(numout,*) '   ==>>>   s-coord. (Pressure Jacobian: Cubic polynomial)'
+         CASE( np_isf )   ;   WRITE(numout,*) '   ==>>>   s-coord. (standard jacobian formulation) for isf'
+         END SELECT
+         WRITE(numout,*)
+      ENDIF
+      !                          
+      IF ( .NOT. ln_isfcav ) THEN     !--- no ice shelf load
+         riceload(:,:) = 0._wp
+         !
+      ELSE                            !--- set an ice shelf load
+         !
+         IF(lwp) WRITE(numout,*)
+         IF(lwp) WRITE(numout,*) '   ice shelf case: set the ice-shelf load'
+         ALLOCATE( zts_top(jpi,jpj,jpts) , zrhd(jpi,jpj,jpk) , zrhdtop_isf(jpi,jpj) , ziceload(jpi,jpj) ) 
+         !
+         znad = 1._wp                     !- To use density and not density anomaly
+         !
+         !                                !- assume water displaced by the ice shelf is at T=-1.9 and S=34.4 (rude)
+         zts_top(:,:,jp_tem) = -1.9_wp   ;   zts_top(:,:,jp_sal) = 34.4_wp
+         !
+         DO jk = 1, jpk                   !- compute density of the water displaced by the ice shelf 
+            CALL eos( zts_top(:,:,:), gdept_n(:,:,jk), zrhd(:,:,jk) )
+         END DO
+         !
+         !                                !- compute rhd at the ice/oce interface (ice shelf side)
+         CALL eos( zts_top , risfdep, zrhdtop_isf )
+         !
+         !                                !- Surface value + ice shelf gradient
+         ziceload = 0._wp                       ! compute pressure due to ice shelf load 
+         DO jj = 1, jpj                         ! (used to compute hpgi/j for all the level from 1 to miku/v)
+            DO ji = 1, jpi                      ! divided by 2 later
+               ikt = mikt(ji,jj)
+               ziceload(ji,jj) = ziceload(ji,jj) + (znad + zrhd(ji,jj,1) ) * e3w_n(ji,jj,1) * (1._wp - tmask(ji,jj,1))
+               DO jk = 2, ikt-1
+                  ziceload(ji,jj) = ziceload(ji,jj) + (2._wp * znad + zrhd(ji,jj,jk-1) + zrhd(ji,jj,jk)) * e3w_n(ji,jj,jk) &
+                     &                              * (1._wp - tmask(ji,jj,jk))
+               END DO
+               IF (ikt  >=  2) ziceload(ji,jj) = ziceload(ji,jj) + (2._wp * znad + zrhdtop_isf(ji,jj) + zrhd(ji,jj,ikt-1)) &
+                  &                                              * ( risfdep(ji,jj) - gdept_1d(ikt-1) )
+            END DO
+         END DO
+         riceload(:,:) = ziceload(:,:)  ! need to be saved for diaar5
+         !
+         DEALLOCATE( zts_top , zrhd , zrhdtop_isf , ziceload ) 
+      ENDIF
+      !
+   END SUBROUTINE dyn_hpg_init
+
+
+   SUBROUTINE hpg_zco( kt )
+      !!---------------------------------------------------------------------
+      !!                  ***  ROUTINE hpg_zco  ***
+      !!
+      !! ** Method  :   z-coordinate case, levels are horizontal surfaces.
+      !!      The now hydrostatic pressure gradient at a given level, jk,
+      !!      is computed by taking the vertical integral of the in-situ
+      !!      density gradient along the model level from the suface to that
+      !!      level:    zhpi = grav .....
+      !!                zhpj = grav .....
+      !!      add it to the general momentum trend (ua,va).
+      !!            ua = ua - 1/e1u * zhpi
+      !!            va = va - 1/e2v * zhpj
+      !!
+      !! ** Action : - Update (ua,va) with the now hydrastatic pressure trend
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT(in) ::   kt    ! ocean time-step index
+      !
+      INTEGER  ::   ji, jj, jk       ! dummy loop indices
+      REAL(wp) ::   zcoef0, zcoef1   ! temporary scalars
+      REAL(wp), DIMENSION(jpi,jpj,jpk) ::  zhpi, zhpj
+      !!----------------------------------------------------------------------
+      !
+      IF( kt == nit000 ) THEN
+         IF(lwp) WRITE(numout,*)
+         IF(lwp) WRITE(numout,*) 'dyn:hpg_zco : hydrostatic pressure gradient trend'
+         IF(lwp) WRITE(numout,*) '~~~~~~~~~~~   z-coordinate case '
+      ENDIF
+
+      zcoef0 = - grav * 0.5_wp      ! Local constant initialization
+
+      ! Surface value
+      DO jj = 2, jpjm1
+         DO ji = fs_2, fs_jpim1   ! vector opt.
+            zcoef1 = zcoef0 * e3w_n(ji,jj,1)
+            ! hydrostatic pressure gradient
+            zhpi(ji,jj,1) = zcoef1 * ( rhd(ji+1,jj,1) - rhd(ji,jj,1) ) * r1_e1u(ji,jj)
+            zhpj(ji,jj,1) = zcoef1 * ( rhd(ji,jj+1,1) - rhd(ji,jj,1) ) * r1_e2v(ji,jj)
+            ! add to the general momentum trend
+            ua(ji,jj,1) = ua(ji,jj,1) + zhpi(ji,jj,1)
+            va(ji,jj,1) = va(ji,jj,1) + zhpj(ji,jj,1)
+         END DO
+      END DO
+
+      !
+      ! interior value (2=<jk=<jpkm1)
+      DO jk = 2, jpkm1
+         DO jj = 2, jpjm1
+            DO ji = fs_2, fs_jpim1   ! vector opt.
+               zcoef1 = zcoef0 * e3w_n(ji,jj,jk)
+               ! hydrostatic pressure gradient
+               zhpi(ji,jj,jk) = zhpi(ji,jj,jk-1)   &
+                  &           + zcoef1 * (  ( rhd(ji+1,jj,jk)+rhd(ji+1,jj,jk-1) )    &
+                  &                       - ( rhd(ji  ,jj,jk)+rhd(ji  ,jj,jk-1) )  ) * r1_e1u(ji,jj)
+
+               zhpj(ji,jj,jk) = zhpj(ji,jj,jk-1)   &
+                  &           + zcoef1 * (  ( rhd(ji,jj+1,jk)+rhd(ji,jj+1,jk-1) )    &
+                  &                       - ( rhd(ji,jj,  jk)+rhd(ji,jj  ,jk-1) )  ) * r1_e2v(ji,jj)
+               ! add to the general momentum trend
+               ua(ji,jj,jk) = ua(ji,jj,jk) + zhpi(ji,jj,jk)
+               va(ji,jj,jk) = va(ji,jj,jk) + zhpj(ji,jj,jk)
+            END DO
+         END DO
+      END DO
+      !
+   END SUBROUTINE hpg_zco
+
+
+   SUBROUTINE hpg_zps( kt )
+      !!---------------------------------------------------------------------
+      !!                 ***  ROUTINE hpg_zps  ***
+      !!
+      !! ** Method  :   z-coordinate plus partial steps case.  blahblah...
+      !!
+      !! ** Action  : - Update (ua,va) with the now hydrastatic pressure trend
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT(in) ::   kt    ! ocean time-step index
+      !!
+      INTEGER  ::   ji, jj, jk                       ! dummy loop indices
+      INTEGER  ::   iku, ikv                         ! temporary integers
+      REAL(wp) ::   zcoef0, zcoef1, zcoef2, zcoef3   ! temporary scalars
+      REAL(wp), DIMENSION(jpi,jpj,jpk) ::  zhpi, zhpj
+      !!----------------------------------------------------------------------
+      !
+      IF( kt == nit000 ) THEN
+         IF(lwp) WRITE(numout,*)
+         IF(lwp) WRITE(numout,*) 'dyn:hpg_zps : hydrostatic pressure gradient trend'
+         IF(lwp) WRITE(numout,*) '~~~~~~~~~~~   z-coordinate with partial steps - vector optimization'
+      ENDIF
+
+      ! Partial steps: bottom before horizontal gradient of t, s, rd at the last ocean level
+!jc      CALL zps_hde    ( kt, jpts, tsn, gtsu, gtsv, rhd, gru , grv )
+
+      ! Local constant initialization
+      zcoef0 = - grav * 0.5_wp
+
+      !  Surface value (also valid in partial step case)
+      DO jj = 2, jpjm1
+         DO ji = fs_2, fs_jpim1   ! vector opt.
+            zcoef1 = zcoef0 * e3w_n(ji,jj,1)
+            ! hydrostatic pressure gradient
+            zhpi(ji,jj,1) = zcoef1 * ( rhd(ji+1,jj  ,1) - rhd(ji,jj,1) ) * r1_e1u(ji,jj)
+            zhpj(ji,jj,1) = zcoef1 * ( rhd(ji  ,jj+1,1) - rhd(ji,jj,1) ) * r1_e2v(ji,jj)
+            ! add to the general momentum trend
+            ua(ji,jj,1) = ua(ji,jj,1) + zhpi(ji,jj,1)
+            va(ji,jj,1) = va(ji,jj,1) + zhpj(ji,jj,1)
+         END DO
+      END DO
+
+      ! interior value (2=<jk=<jpkm1)
+      DO jk = 2, jpkm1
+         DO jj = 2, jpjm1
+            DO ji = fs_2, fs_jpim1   ! vector opt.
+               zcoef1 = zcoef0 * e3w_n(ji,jj,jk)
+               ! hydrostatic pressure gradient
+               zhpi(ji,jj,jk) = zhpi(ji,jj,jk-1)   &
+                  &           + zcoef1 * (  ( rhd(ji+1,jj,jk) + rhd(ji+1,jj,jk-1) )   &
+                  &                       - ( rhd(ji  ,jj,jk) + rhd(ji  ,jj,jk-1) )  ) * r1_e1u(ji,jj)
+
+               zhpj(ji,jj,jk) = zhpj(ji,jj,jk-1)   &
+                  &           + zcoef1 * (  ( rhd(ji,jj+1,jk) + rhd(ji,jj+1,jk-1) )   &
+                  &                       - ( rhd(ji,jj,  jk) + rhd(ji,jj  ,jk-1) )  ) * r1_e2v(ji,jj)
+               ! add to the general momentum trend
+               ua(ji,jj,jk) = ua(ji,jj,jk) + zhpi(ji,jj,jk)
+               va(ji,jj,jk) = va(ji,jj,jk) + zhpj(ji,jj,jk)
+            END DO
+         END DO
+      END DO
+
+      ! partial steps correction at the last level  (use gru & grv computed in zpshde.F90)
+      DO jj = 2, jpjm1
+         DO ji = 2, jpim1
+            iku = mbku(ji,jj)
+            ikv = mbkv(ji,jj)
+            zcoef2 = zcoef0 * MIN( e3w_n(ji,jj,iku), e3w_n(ji+1,jj  ,iku) )
+            zcoef3 = zcoef0 * MIN( e3w_n(ji,jj,ikv), e3w_n(ji  ,jj+1,ikv) )
+            IF( iku > 1 ) THEN            ! on i-direction (level 2 or more)
+               ua  (ji,jj,iku) = ua(ji,jj,iku) - zhpi(ji,jj,iku)         ! subtract old value
+               zhpi(ji,jj,iku) = zhpi(ji,jj,iku-1)                   &   ! compute the new one
+                  &            + zcoef2 * ( rhd(ji+1,jj,iku-1) - rhd(ji,jj,iku-1) + gru(ji,jj) ) * r1_e1u(ji,jj)
+               ua  (ji,jj,iku) = ua(ji,jj,iku) + zhpi(ji,jj,iku)         ! add the new one to the general momentum trend
+            ENDIF
+            IF( ikv > 1 ) THEN            ! on j-direction (level 2 or more)
+               va  (ji,jj,ikv) = va(ji,jj,ikv) - zhpj(ji,jj,ikv)         ! subtract old value
+               zhpj(ji,jj,ikv) = zhpj(ji,jj,ikv-1)                   &   ! compute the new one
+                  &            + zcoef3 * ( rhd(ji,jj+1,ikv-1) - rhd(ji,jj,ikv-1) + grv(ji,jj) ) * r1_e2v(ji,jj)
+               va  (ji,jj,ikv) = va(ji,jj,ikv) + zhpj(ji,jj,ikv)         ! add the new one to the general momentum trend
+            ENDIF
+         END DO
+      END DO
+      !
+   END SUBROUTINE hpg_zps
+
+
+   SUBROUTINE hpg_sco( kt )
+      !!---------------------------------------------------------------------
+      !!                  ***  ROUTINE hpg_sco  ***
+      !!
+      !! ** Method  :   s-coordinate case. Jacobian scheme.
+      !!      The now hydrostatic pressure gradient at a given level, jk,
+      !!      is computed by taking the vertical integral of the in-situ
+      !!      density gradient along the model level from the suface to that
+      !!      level. s-coordinates (ln_sco): a corrective term is added
+      !!      to the horizontal pressure gradient :
+      !!         zhpi = grav .....  + 1/e1u mi(rhd) di[ grav dep3w ]
+      !!         zhpj = grav .....  + 1/e2v mj(rhd) dj[ grav dep3w ]
+      !!      add it to the general momentum trend (ua,va).
+      !!         ua = ua - 1/e1u * zhpi
+      !!         va = va - 1/e2v * zhpj
+      !!
+      !! ** Action : - Update (ua,va) with the now hydrastatic pressure trend
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT(in) ::   kt    ! ocean time-step index
+      !!
+      INTEGER  ::   ji, jj, jk, jii, jjj                 ! dummy loop indices
+      REAL(wp) ::   zcoef0, zuap, zvap, znad, ztmp       ! temporary scalars
+      LOGICAL  ::   ll_tmp1, ll_tmp2                     ! local logical variables
+      REAL(wp), DIMENSION(jpi,jpj,jpk)      ::   zhpi, zhpj
+      REAL(wp), DIMENSION(:,:), ALLOCATABLE ::   zcpx, zcpy   !W/D pressure filter
+      !!----------------------------------------------------------------------
+      !
+      IF( ln_wd_il ) ALLOCATE(zcpx(jpi,jpj), zcpy(jpi,jpj))
+      !
+      IF( kt == nit000 ) THEN
+         IF(lwp) WRITE(numout,*)
+         IF(lwp) WRITE(numout,*) 'dyn:hpg_sco : hydrostatic pressure gradient trend'
+         IF(lwp) WRITE(numout,*) '~~~~~~~~~~~   s-coordinate case, OPA original scheme used'
+      ENDIF
+      !
+      zcoef0 = - grav * 0.5_wp
+      IF ( ln_linssh ) THEN   ;   znad = 0._wp         ! Fixed    volume: density anomaly
+      ELSE                    ;   znad = 1._wp         ! Variable volume: density
+      ENDIF
+      !
+      IF( ln_wd_il ) THEN
+        DO jj = 2, jpjm1
+           DO ji = 2, jpim1 
+             ll_tmp1 = MIN(  sshn(ji,jj)               ,  sshn(ji+1,jj) ) >                &
+                  &    MAX( -ht_0(ji,jj)               , -ht_0(ji+1,jj) ) .AND.            &
+                  &    MAX(  sshn(ji,jj) +  ht_0(ji,jj),  sshn(ji+1,jj) + ht_0(ji+1,jj) )  &
+                  &                                                       > rn_wdmin1 + rn_wdmin2
+             ll_tmp2 = ( ABS( sshn(ji,jj)              -  sshn(ji+1,jj) ) > 1.E-12 ) .AND. (       &
+                  &    MAX(   sshn(ji,jj)              ,  sshn(ji+1,jj) ) >                &
+                  &    MAX(  -ht_0(ji,jj)              , -ht_0(ji+1,jj) ) + rn_wdmin1 + rn_wdmin2 )
+
+             IF(ll_tmp1) THEN
+               zcpx(ji,jj) = 1.0_wp
+             ELSE IF(ll_tmp2) THEN
+               ! no worries about  sshn(ji+1,jj) -  sshn(ji  ,jj) = 0, it won't happen ! here
+               zcpx(ji,jj) = ABS( (sshn(ji+1,jj) + ht_0(ji+1,jj) - sshn(ji,jj) - ht_0(ji,jj)) &
+                           &    / (sshn(ji+1,jj) - sshn(ji  ,jj)) )
+             ELSE
+               zcpx(ji,jj) = 0._wp
+             END IF
+      
+             ll_tmp1 = MIN(  sshn(ji,jj)              ,  sshn(ji,jj+1) ) >                &
+                  &    MAX( -ht_0(ji,jj)              , -ht_0(ji,jj+1) ) .AND.            &
+                  &    MAX(  sshn(ji,jj) + ht_0(ji,jj),  sshn(ji,jj+1) + ht_0(ji,jj+1) )  &
+                  &                                                      > rn_wdmin1 + rn_wdmin2
+             ll_tmp2 = ( ABS( sshn(ji,jj)             -  sshn(ji,jj+1) ) > 1.E-12 ) .AND. (        &
+                  &    MAX(   sshn(ji,jj)             ,  sshn(ji,jj+1) ) >                &
+                  &    MAX(  -ht_0(ji,jj)             , -ht_0(ji,jj+1) ) + rn_wdmin1 + rn_wdmin2 )
+
+             IF(ll_tmp1) THEN
+               zcpy(ji,jj) = 1.0_wp
+             ELSE IF(ll_tmp2) THEN
+               ! no worries about  sshn(ji,jj+1) -  sshn(ji,jj  ) = 0, it won't happen ! here
+               zcpy(ji,jj) = ABS( (sshn(ji,jj+1) + ht_0(ji,jj+1) - sshn(ji,jj) - ht_0(ji,jj)) &
+                           &    / (sshn(ji,jj+1) - sshn(ji,jj  )) )
+             ELSE
+               zcpy(ji,jj) = 0._wp
+             END IF
+           END DO
+        END DO
+        CALL lbc_lnk_multi( zcpx, 'U', 1., zcpy, 'V', 1. )
+      END IF
+
+      ! Surface value
+      DO jj = 2, jpjm1
+         DO ji = fs_2, fs_jpim1   ! vector opt.
+            ! hydrostatic pressure gradient along s-surfaces
+            zhpi(ji,jj,1) = zcoef0 * (  e3w_n(ji+1,jj  ,1) * ( znad + rhd(ji+1,jj  ,1) )    &
+               &                      - e3w_n(ji  ,jj  ,1) * ( znad + rhd(ji  ,jj  ,1) )  ) * r1_e1u(ji,jj)
+            zhpj(ji,jj,1) = zcoef0 * (  e3w_n(ji  ,jj+1,1) * ( znad + rhd(ji  ,jj+1,1) )    &
+               &                      - e3w_n(ji  ,jj  ,1) * ( znad + rhd(ji  ,jj  ,1) )  ) * r1_e2v(ji,jj)
+            ! s-coordinate pressure gradient correction
+            zuap = -zcoef0 * ( rhd    (ji+1,jj,1) + rhd    (ji,jj,1) + 2._wp * znad )   &
+               &           * ( gde3w_n(ji+1,jj,1) - gde3w_n(ji,jj,1) ) * r1_e1u(ji,jj)
+            zvap = -zcoef0 * ( rhd    (ji,jj+1,1) + rhd    (ji,jj,1) + 2._wp * znad )   &
+               &           * ( gde3w_n(ji,jj+1,1) - gde3w_n(ji,jj,1) ) * r1_e2v(ji,jj)
+            !
+            IF( ln_wd_il ) THEN
+               zhpi(ji,jj,1) = zhpi(ji,jj,1) * zcpx(ji,jj)
+               zhpj(ji,jj,1) = zhpj(ji,jj,1) * zcpy(ji,jj) 
+               zuap = zuap * zcpx(ji,jj)
+               zvap = zvap * zcpy(ji,jj)
+            ENDIF
+            !
+            ! add to the general momentum trend
+            ua(ji,jj,1) = ua(ji,jj,1) + zhpi(ji,jj,1) + zuap
+            va(ji,jj,1) = va(ji,jj,1) + zhpj(ji,jj,1) + zvap
+         END DO
+      END DO
+
+      ! interior value (2=<jk=<jpkm1)
+      DO jk = 2, jpkm1
+         DO jj = 2, jpjm1
+            DO ji = fs_2, fs_jpim1   ! vector opt.
+               ! hydrostatic pressure gradient along s-surfaces
+               zhpi(ji,jj,jk) = zhpi(ji,jj,jk-1) + zcoef0 * r1_e1u(ji,jj)   &
+                  &           * (  e3w_n(ji+1,jj,jk) * ( rhd(ji+1,jj,jk) + rhd(ji+1,jj,jk-1) + 2*znad )   &
+                  &              - e3w_n(ji  ,jj,jk) * ( rhd(ji  ,jj,jk) + rhd(ji  ,jj,jk-1) + 2*znad )  )
+               zhpj(ji,jj,jk) = zhpj(ji,jj,jk-1) + zcoef0 * r1_e2v(ji,jj)   &
+                  &           * (  e3w_n(ji,jj+1,jk) * ( rhd(ji,jj+1,jk) + rhd(ji,jj+1,jk-1) + 2*znad )   &
+                  &              - e3w_n(ji,jj  ,jk) * ( rhd(ji,jj,  jk) + rhd(ji,jj  ,jk-1) + 2*znad )  )
+               ! s-coordinate pressure gradient correction
+               zuap = -zcoef0 * ( rhd    (ji+1,jj  ,jk) + rhd    (ji,jj,jk) + 2._wp * znad )   &
+                  &           * ( gde3w_n(ji+1,jj  ,jk) - gde3w_n(ji,jj,jk) ) * r1_e1u(ji,jj)
+               zvap = -zcoef0 * ( rhd    (ji  ,jj+1,jk) + rhd    (ji,jj,jk) + 2._wp * znad )   &
+                  &           * ( gde3w_n(ji  ,jj+1,jk) - gde3w_n(ji,jj,jk) ) * r1_e2v(ji,jj)
+               !
+               IF( ln_wd_il ) THEN
+                  zhpi(ji,jj,jk) = zhpi(ji,jj,jk) * zcpx(ji,jj)
+                  zhpj(ji,jj,jk) = zhpj(ji,jj,jk) * zcpy(ji,jj) 
+                  zuap = zuap * zcpx(ji,jj)
+                  zvap = zvap * zcpy(ji,jj)
+               ENDIF
+               !
+               ! add to the general momentum trend
+               ua(ji,jj,jk) = ua(ji,jj,jk) + zhpi(ji,jj,jk) + zuap
+               va(ji,jj,jk) = va(ji,jj,jk) + zhpj(ji,jj,jk) + zvap
+            END DO
+         END DO
+      END DO
+      !
+      IF( ln_wd_il )  DEALLOCATE( zcpx , zcpy )
+      !
+   END SUBROUTINE hpg_sco
+
+
+   SUBROUTINE hpg_isf( kt )
+      !!---------------------------------------------------------------------
+      !!                  ***  ROUTINE hpg_isf  ***
+      !!
+      !! ** Method  :   s-coordinate case. Jacobian scheme.
+      !!      The now hydrostatic pressure gradient at a given level, jk,
+      !!      is computed by taking the vertical integral of the in-situ
+      !!      density gradient along the model level from the suface to that
+      !!      level. s-coordinates (ln_sco): a corrective term is added
+      !!      to the horizontal pressure gradient :
+      !!         zhpi = grav .....  + 1/e1u mi(rhd) di[ grav dep3w ]
+      !!         zhpj = grav .....  + 1/e2v mj(rhd) dj[ grav dep3w ]
+      !!      add it to the general momentum trend (ua,va).
+      !!         ua = ua - 1/e1u * zhpi
+      !!         va = va - 1/e2v * zhpj
+      !!      iceload is added and partial cell case are added to the top and bottom
+      !!      
+      !! ** Action : - Update (ua,va) with the now hydrastatic pressure trend
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT(in) ::   kt    ! ocean time-step index
+      !!
+      INTEGER  ::   ji, jj, jk, ikt, iktp1i, iktp1j   ! dummy loop indices
+      REAL(wp) ::   zcoef0, zuap, zvap, znad          ! temporary scalars
+      REAL(wp), DIMENSION(jpi,jpj,jpk ) ::  zhpi, zhpj
+      REAL(wp), DIMENSION(jpi,jpj,jpts) ::  zts_top
+      REAL(wp), DIMENSION(jpi,jpj)      ::  zrhdtop_oce
+      !!----------------------------------------------------------------------
+      !
+      zcoef0 = - grav * 0.5_wp   ! Local constant initialization
+      !
+      znad=1._wp                 ! To use density and not density anomaly
+      !
+      !                          ! iniitialised to 0. zhpi zhpi 
+      zhpi(:,:,:) = 0._wp   ;   zhpj(:,:,:) = 0._wp
+
+      ! compute rhd at the ice/oce interface (ocean side)
+      ! usefull to reduce residual current in the test case ISOMIP with no melting
+      DO ji = 1, jpi
+        DO jj = 1, jpj
+          ikt = mikt(ji,jj)
+          zts_top(ji,jj,1) = tsn(ji,jj,ikt,1)
+          zts_top(ji,jj,2) = tsn(ji,jj,ikt,2)
+        END DO
+      END DO
+      CALL eos( zts_top, risfdep, zrhdtop_oce )
+
+!==================================================================================     
+!===== Compute surface value ===================================================== 
+!==================================================================================
+      DO jj = 2, jpjm1
+         DO ji = fs_2, fs_jpim1   ! vector opt.
+            ikt    = mikt(ji,jj)
+            iktp1i = mikt(ji+1,jj)
+            iktp1j = mikt(ji,jj+1)
+            ! hydrostatic pressure gradient along s-surfaces and ice shelf pressure
+            ! we assume ISF is in isostatic equilibrium
+            zhpi(ji,jj,1) = zcoef0 / e1u(ji,jj) * ( 0.5_wp * e3w_n(ji+1,jj,iktp1i)                                    &
+               &                                    * ( 2._wp * znad + rhd(ji+1,jj,iktp1i) + zrhdtop_oce(ji+1,jj) )   &
+               &                                  - 0.5_wp * e3w_n(ji,jj,ikt)                                         &
+               &                                    * ( 2._wp * znad + rhd(ji,jj,ikt) + zrhdtop_oce(ji,jj) )          &
+               &                                  + ( riceload(ji+1,jj) - riceload(ji,jj))                            ) 
+            zhpj(ji,jj,1) = zcoef0 / e2v(ji,jj) * ( 0.5_wp * e3w_n(ji,jj+1,iktp1j)                                    &
+               &                                    * ( 2._wp * znad + rhd(ji,jj+1,iktp1j) + zrhdtop_oce(ji,jj+1) )   &
+               &                                  - 0.5_wp * e3w_n(ji,jj,ikt)                                         & 
+               &                                    * ( 2._wp * znad + rhd(ji,jj,ikt) + zrhdtop_oce(ji,jj) )          &
+               &                                  + ( riceload(ji,jj+1) - riceload(ji,jj))                            ) 
+            ! s-coordinate pressure gradient correction (=0 if z coordinate)
+            zuap = -zcoef0 * ( rhd    (ji+1,jj,1) + rhd    (ji,jj,1) + 2._wp * znad )   &
+               &           * ( gde3w_n(ji+1,jj,1) - gde3w_n(ji,jj,1) ) * r1_e1u(ji,jj)
+            zvap = -zcoef0 * ( rhd    (ji,jj+1,1) + rhd    (ji,jj,1) + 2._wp * znad )   &
+               &           * ( gde3w_n(ji,jj+1,1) - gde3w_n(ji,jj,1) ) * r1_e2v(ji,jj)
+            ! add to the general momentum trend
+            ua(ji,jj,1) = ua(ji,jj,1) + (zhpi(ji,jj,1) + zuap) * umask(ji,jj,1)
+            va(ji,jj,1) = va(ji,jj,1) + (zhpj(ji,jj,1) + zvap) * vmask(ji,jj,1)
+         END DO
+      END DO
+!==================================================================================     
+!===== Compute interior value ===================================================== 
+!==================================================================================
+      ! interior value (2=<jk=<jpkm1)
+      DO jk = 2, jpkm1
+         DO jj = 2, jpjm1
+            DO ji = fs_2, fs_jpim1   ! vector opt.
+               ! hydrostatic pressure gradient along s-surfaces
+               zhpi(ji,jj,jk) = zhpi(ji,jj,jk-1) + zcoef0 / e1u(ji,jj)   &
+                  &           * (  e3w_n(ji+1,jj,jk) * ( rhd(ji+1,jj,jk) + rhd(ji+1,jj,jk-1) + 2*znad ) * wmask(ji+1,jj,jk)   &
+                  &              - e3w_n(ji  ,jj,jk) * ( rhd(ji  ,jj,jk) + rhd(ji  ,jj,jk-1) + 2*znad ) * wmask(ji  ,jj,jk)   )
+               zhpj(ji,jj,jk) = zhpj(ji,jj,jk-1) + zcoef0 / e2v(ji,jj)   &
+                  &           * (  e3w_n(ji,jj+1,jk) * ( rhd(ji,jj+1,jk) + rhd(ji,jj+1,jk-1) + 2*znad ) * wmask(ji,jj+1,jk)   &
+                  &              - e3w_n(ji,jj  ,jk) * ( rhd(ji,jj,  jk) + rhd(ji,jj  ,jk-1) + 2*znad ) * wmask(ji,jj  ,jk)   )
+               ! s-coordinate pressure gradient correction
+               zuap = -zcoef0 * ( rhd   (ji+1,jj  ,jk) + rhd   (ji,jj,jk) + 2._wp * znad )   &
+                  &           * ( gde3w_n(ji+1,jj  ,jk) - gde3w_n(ji,jj,jk) ) / e1u(ji,jj)
+               zvap = -zcoef0 * ( rhd   (ji  ,jj+1,jk) + rhd   (ji,jj,jk) + 2._wp * znad )   &
+                  &           * ( gde3w_n(ji  ,jj+1,jk) - gde3w_n(ji,jj,jk) ) / e2v(ji,jj)
+               ! add to the general momentum trend
+               ua(ji,jj,jk) = ua(ji,jj,jk) + (zhpi(ji,jj,jk) + zuap) * umask(ji,jj,jk)
+               va(ji,jj,jk) = va(ji,jj,jk) + (zhpj(ji,jj,jk) + zvap) * vmask(ji,jj,jk)
+            END DO
+         END DO
+      END DO
+      !
+   END SUBROUTINE hpg_isf
+
+
+   SUBROUTINE hpg_djc( kt )
+      !!---------------------------------------------------------------------
+      !!                  ***  ROUTINE hpg_djc  ***
+      !!
+      !! ** Method  :   Density Jacobian with Cubic polynomial scheme
+      !!
+      !! Reference: Shchepetkin and McWilliams, J. Geophys. Res., 108(C3), 3090, 2003
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT(in) ::   kt    ! ocean time-step index
+      !!
+      INTEGER  ::   ji, jj, jk          ! dummy loop indices
+      REAL(wp) ::   zcoef0, zep, cffw   ! temporary scalars
+      REAL(wp) ::   z1_10, cffu, cffx   !    "         "
+      REAL(wp) ::   z1_12, cffv, cffy   !    "         "
+      LOGICAL  ::   ll_tmp1, ll_tmp2    ! local logical variables
+      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zhpi, zhpj
+      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   dzx, dzy, dzz, dzu, dzv, dzw
+      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   drhox, drhoy, drhoz, drhou, drhov, drhow
+      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   rho_i, rho_j, rho_k
+      REAL(wp), DIMENSION(:,:), ALLOCATABLE ::   zcpx, zcpy   !W/D pressure filter
+      !!----------------------------------------------------------------------
+      !
+      IF( ln_wd_il ) THEN
+         ALLOCATE( zcpx(jpi,jpj) , zcpy(jpi,jpj) )
+        DO jj = 2, jpjm1
+           DO ji = 2, jpim1 
+             ll_tmp1 = MIN(  sshn(ji,jj)              ,  sshn(ji+1,jj) ) >                &
+                  &    MAX( -ht_0(ji,jj)              , -ht_0(ji+1,jj) ) .AND.            &
+                  &    MAX(  sshn(ji,jj) + ht_0(ji,jj),  sshn(ji+1,jj) + ht_0(ji+1,jj) )  &
+                  &                                                      > rn_wdmin1 + rn_wdmin2
+             ll_tmp2 = ( ABS( sshn(ji,jj)             -  sshn(ji+1,jj) ) > 1.E-12 ) .AND. (        &
+                  &    MAX(   sshn(ji,jj)             ,  sshn(ji+1,jj) ) >                &
+                  &    MAX(  -ht_0(ji,jj)             , -ht_0(ji+1,jj) ) + rn_wdmin1 + rn_wdmin2 )
+             IF(ll_tmp1) THEN
+               zcpx(ji,jj) = 1.0_wp
+             ELSE IF(ll_tmp2) THEN
+               ! no worries about  sshn(ji+1,jj) -  sshn(ji  ,jj) = 0, it won't happen ! here
+               zcpx(ji,jj) = ABS( (sshn(ji+1,jj) + ht_0(ji+1,jj) - sshn(ji,jj) - ht_0(ji,jj)) &
+                           &    / (sshn(ji+1,jj) - sshn(ji  ,jj)) )
+             ELSE
+               zcpx(ji,jj) = 0._wp
+             END IF
+      
+             ll_tmp1 = MIN(  sshn(ji,jj)              ,  sshn(ji,jj+1) ) >                &
+                  &    MAX( -ht_0(ji,jj)              , -ht_0(ji,jj+1) ) .AND.            &
+                  &    MAX(  sshn(ji,jj) + ht_0(ji,jj),  sshn(ji,jj+1) + ht_0(ji,jj+1) )  &
+                  &                                                      > rn_wdmin1 + rn_wdmin2
+             ll_tmp2 = ( ABS( sshn(ji,jj)             -  sshn(ji,jj+1) ) > 1.E-12 ) .AND. (        &
+                  &    MAX(   sshn(ji,jj)             ,  sshn(ji,jj+1) ) >                &
+                  &    MAX(  -ht_0(ji,jj)             , -ht_0(ji,jj+1) ) + rn_wdmin1 + rn_wdmin2 )
+
+             IF(ll_tmp1) THEN
+               zcpy(ji,jj) = 1.0_wp
+             ELSE IF(ll_tmp2) THEN
+               ! no worries about  sshn(ji,jj+1) -  sshn(ji,jj  ) = 0, it won't happen ! here
+               zcpy(ji,jj) = ABS( (sshn(ji,jj+1) + ht_0(ji,jj+1) - sshn(ji,jj) - ht_0(ji,jj)) &
+                           &    / (sshn(ji,jj+1) - sshn(ji,jj  )) )
+             ELSE
+               zcpy(ji,jj) = 0._wp
+             END IF
+           END DO
+        END DO
+        CALL lbc_lnk_multi( zcpx, 'U', 1., zcpy, 'V', 1. )
+      END IF
+
+      IF( kt == nit000 ) THEN
+         IF(lwp) WRITE(numout,*)
+         IF(lwp) WRITE(numout,*) 'dyn:hpg_djc : hydrostatic pressure gradient trend'
+         IF(lwp) WRITE(numout,*) '~~~~~~~~~~~   s-coordinate case, density Jacobian with cubic polynomial scheme'
+      ENDIF
+
+      ! Local constant initialization
+      zcoef0 = - grav * 0.5_wp
+      z1_10  = 1._wp / 10._wp
+      z1_12  = 1._wp / 12._wp
+
+      !----------------------------------------------------------------------------------------
+      !  compute and store in provisional arrays elementary vertical and horizontal differences
+      !----------------------------------------------------------------------------------------
+
+!!bug gm   Not a true bug, but... dzz=e3w  for dzx, dzy verify what it is really
+
+      DO jk = 2, jpkm1
+         DO jj = 2, jpjm1
+            DO ji = fs_2, fs_jpim1   ! vector opt.
+               drhoz(ji,jj,jk) = rhd    (ji  ,jj  ,jk) - rhd    (ji,jj,jk-1)
+               dzz  (ji,jj,jk) = gde3w_n(ji  ,jj  ,jk) - gde3w_n(ji,jj,jk-1)
+               drhox(ji,jj,jk) = rhd    (ji+1,jj  ,jk) - rhd    (ji,jj,jk  )
+               dzx  (ji,jj,jk) = gde3w_n(ji+1,jj  ,jk) - gde3w_n(ji,jj,jk  )
+               drhoy(ji,jj,jk) = rhd    (ji  ,jj+1,jk) - rhd    (ji,jj,jk  )
+               dzy  (ji,jj,jk) = gde3w_n(ji  ,jj+1,jk) - gde3w_n(ji,jj,jk  )
+            END DO
+         END DO
+      END DO
+
+      !-------------------------------------------------------------------------
+      ! compute harmonic averages using eq. 5.18
+      !-------------------------------------------------------------------------
+      zep = 1.e-15
+
+!!bug  gm  drhoz not defined at level 1 and used (jk-1 with jk=2)
+!!bug  gm  idem for drhox, drhoy et ji=jpi and jj=jpj
+
+      DO jk = 2, jpkm1
+         DO jj = 2, jpjm1
+            DO ji = fs_2, fs_jpim1   ! vector opt.
+               cffw = 2._wp * drhoz(ji  ,jj  ,jk) * drhoz(ji,jj,jk-1)
+
+               cffu = 2._wp * drhox(ji+1,jj  ,jk) * drhox(ji,jj,jk  )
+               cffx = 2._wp * dzx  (ji+1,jj  ,jk) * dzx  (ji,jj,jk  )
+
+               cffv = 2._wp * drhoy(ji  ,jj+1,jk) * drhoy(ji,jj,jk  )
+               cffy = 2._wp * dzy  (ji  ,jj+1,jk) * dzy  (ji,jj,jk  )
+
+               IF( cffw > zep) THEN
+                  drhow(ji,jj,jk) = 2._wp *   drhoz(ji,jj,jk) * drhoz(ji,jj,jk-1)   &
+                     &                    / ( drhoz(ji,jj,jk) + drhoz(ji,jj,jk-1) )
+               ELSE
+                  drhow(ji,jj,jk) = 0._wp
+               ENDIF
+
+               dzw(ji,jj,jk) = 2._wp *   dzz(ji,jj,jk) * dzz(ji,jj,jk-1)   &
+                  &                  / ( dzz(ji,jj,jk) + dzz(ji,jj,jk-1) )
+
+               IF( cffu > zep ) THEN
+                  drhou(ji,jj,jk) = 2._wp *   drhox(ji+1,jj,jk) * drhox(ji,jj,jk)   &
+                     &                    / ( drhox(ji+1,jj,jk) + drhox(ji,jj,jk) )
+               ELSE
+                  drhou(ji,jj,jk ) = 0._wp
+               ENDIF
+
+               IF( cffx > zep ) THEN
+                  dzu(ji,jj,jk) = 2._wp *   dzx(ji+1,jj,jk) * dzx(ji,jj,jk)   &
+                     &                  / ( dzx(ji+1,jj,jk) + dzx(ji,jj,jk) )
+               ELSE
+                  dzu(ji,jj,jk) = 0._wp
+               ENDIF
+
+               IF( cffv > zep ) THEN
+                  drhov(ji,jj,jk) = 2._wp *   drhoy(ji,jj+1,jk) * drhoy(ji,jj,jk)   &
+                     &                    / ( drhoy(ji,jj+1,jk) + drhoy(ji,jj,jk) )
+               ELSE
+                  drhov(ji,jj,jk) = 0._wp
+               ENDIF
+
+               IF( cffy > zep ) THEN
+                  dzv(ji,jj,jk) = 2._wp *   dzy(ji,jj+1,jk) * dzy(ji,jj,jk)   &
+                     &                  / ( dzy(ji,jj+1,jk) + dzy(ji,jj,jk) )
+               ELSE
+                  dzv(ji,jj,jk) = 0._wp
+               ENDIF
+
+            END DO
+         END DO
+      END DO
+
+      !----------------------------------------------------------------------------------
+      ! apply boundary conditions at top and bottom using 5.36-5.37
+      !----------------------------------------------------------------------------------
+      drhow(:,:, 1 ) = 1.5_wp * ( drhoz(:,:, 2 ) - drhoz(:,:,  1  ) ) - 0.5_wp * drhow(:,:,  2  )
+      drhou(:,:, 1 ) = 1.5_wp * ( drhox(:,:, 2 ) - drhox(:,:,  1  ) ) - 0.5_wp * drhou(:,:,  2  )
+      drhov(:,:, 1 ) = 1.5_wp * ( drhoy(:,:, 2 ) - drhoy(:,:,  1  ) ) - 0.5_wp * drhov(:,:,  2  )
+
+      drhow(:,:,jpk) = 1.5_wp * ( drhoz(:,:,jpk) - drhoz(:,:,jpkm1) ) - 0.5_wp * drhow(:,:,jpkm1)
+      drhou(:,:,jpk) = 1.5_wp * ( drhox(:,:,jpk) - drhox(:,:,jpkm1) ) - 0.5_wp * drhou(:,:,jpkm1)
+      drhov(:,:,jpk) = 1.5_wp * ( drhoy(:,:,jpk) - drhoy(:,:,jpkm1) ) - 0.5_wp * drhov(:,:,jpkm1)
+
+
+      !--------------------------------------------------------------
+      ! Upper half of top-most grid box, compute and store
+      !-------------------------------------------------------------
+
+!!bug gm   :  e3w-gde3w = 0.5*e3w  ....  and gde3w(2)-gde3w(1)=e3w(2) ....   to be verified
+!          true if gde3w is really defined as the sum of the e3w scale factors as, it seems to me, it should be
+
+      DO jj = 2, jpjm1
+         DO ji = fs_2, fs_jpim1   ! vector opt.
+            rho_k(ji,jj,1) = -grav * ( e3w_n(ji,jj,1) - gde3w_n(ji,jj,1) )               &
+               &                   * (  rhd(ji,jj,1)                                     &
+               &                     + 0.5_wp * ( rhd    (ji,jj,2) - rhd    (ji,jj,1) )  &
+               &                              * ( e3w_n  (ji,jj,1) - gde3w_n(ji,jj,1) )  &
+               &                              / ( gde3w_n(ji,jj,2) - gde3w_n(ji,jj,1) )  )
+         END DO
+      END DO
+
+!!bug gm    : here also, simplification is possible
+!!bug gm    : optimisation: 1/10 and 1/12 the division should be done before the loop
+
+      DO jk = 2, jpkm1
+         DO jj = 2, jpjm1
+            DO ji = fs_2, fs_jpim1   ! vector opt.
+
+               rho_k(ji,jj,jk) = zcoef0 * ( rhd    (ji,jj,jk) + rhd    (ji,jj,jk-1) )                                   &
+                  &                     * ( gde3w_n(ji,jj,jk) - gde3w_n(ji,jj,jk-1) )                                   &
+                  &            - grav * z1_10 * (                                                                   &
+                  &     ( drhow  (ji,jj,jk) - drhow  (ji,jj,jk-1) )                                                     &
+                  &   * ( gde3w_n(ji,jj,jk) - gde3w_n(ji,jj,jk-1) - z1_12 * ( dzw  (ji,jj,jk) + dzw  (ji,jj,jk-1) ) )   &
+                  &   - ( dzw    (ji,jj,jk) - dzw    (ji,jj,jk-1) )                                                     &
+                  &   * ( rhd    (ji,jj,jk) - rhd    (ji,jj,jk-1) - z1_12 * ( drhow(ji,jj,jk) + drhow(ji,jj,jk-1) ) )   &
+                  &                             )
+
+               rho_i(ji,jj,jk) = zcoef0 * ( rhd    (ji+1,jj,jk) + rhd    (ji,jj,jk) )                                   &
+                  &                     * ( gde3w_n(ji+1,jj,jk) - gde3w_n(ji,jj,jk) )                                   &
+                  &            - grav* z1_10 * (                                                                    &
+                  &     ( drhou  (ji+1,jj,jk) - drhou  (ji,jj,jk) )                                                     &
+                  &   * ( gde3w_n(ji+1,jj,jk) - gde3w_n(ji,jj,jk) - z1_12 * ( dzu  (ji+1,jj,jk) + dzu  (ji,jj,jk) ) )   &
+                  &   - ( dzu    (ji+1,jj,jk) - dzu    (ji,jj,jk) )                                                     &
+                  &   * ( rhd    (ji+1,jj,jk) - rhd    (ji,jj,jk) - z1_12 * ( drhou(ji+1,jj,jk) + drhou(ji,jj,jk) ) )   &
+                  &                            )
+
+               rho_j(ji,jj,jk) = zcoef0 * ( rhd    (ji,jj+1,jk) + rhd    (ji,jj,jk) )                                 &
+                  &                     * ( gde3w_n(ji,jj+1,jk) - gde3w_n(ji,jj,jk) )                                   &
+                  &            - grav* z1_10 * (                                                                    &
+                  &     ( drhov  (ji,jj+1,jk) - drhov  (ji,jj,jk) )                                                     &
+                  &   * ( gde3w_n(ji,jj+1,jk) - gde3w_n(ji,jj,jk) - z1_12 * ( dzv  (ji,jj+1,jk) + dzv  (ji,jj,jk) ) )   &
+                  &   - ( dzv    (ji,jj+1,jk) - dzv    (ji,jj,jk) )                                                     &
+                  &   * ( rhd    (ji,jj+1,jk) - rhd    (ji,jj,jk) - z1_12 * ( drhov(ji,jj+1,jk) + drhov(ji,jj,jk) ) )   &
+                  &                            )
+
+            END DO
+         END DO
+      END DO
+      CALL lbc_lnk_multi( rho_k, 'W', 1., rho_i, 'U', 1., rho_j, 'V', 1. )
+
+      ! ---------------
+      !  Surface value
+      ! ---------------
+      DO jj = 2, jpjm1
+         DO ji = fs_2, fs_jpim1   ! vector opt.
+            zhpi(ji,jj,1) = ( rho_k(ji+1,jj  ,1) - rho_k(ji,jj,1) - rho_i(ji,jj,1) ) * r1_e1u(ji,jj)
+            zhpj(ji,jj,1) = ( rho_k(ji  ,jj+1,1) - rho_k(ji,jj,1) - rho_j(ji,jj,1) ) * r1_e2v(ji,jj)
+            IF( ln_wd_il ) THEN
+              zhpi(ji,jj,1) = zhpi(ji,jj,1) * zcpx(ji,jj)
+              zhpj(ji,jj,1) = zhpj(ji,jj,1) * zcpy(ji,jj) 
+            ENDIF
+            ! add to the general momentum trend
+            ua(ji,jj,1) = ua(ji,jj,1) + zhpi(ji,jj,1)
+            va(ji,jj,1) = va(ji,jj,1) + zhpj(ji,jj,1)
+         END DO
+      END DO
+
+      ! ----------------
+      !  interior value   (2=<jk=<jpkm1)
+      ! ----------------
+      DO jk = 2, jpkm1
+         DO jj = 2, jpjm1
+            DO ji = fs_2, fs_jpim1   ! vector opt.
+               ! hydrostatic pressure gradient along s-surfaces
+               zhpi(ji,jj,jk) = zhpi(ji,jj,jk-1)                                &
+                  &           + (  ( rho_k(ji+1,jj,jk) - rho_k(ji,jj,jk  ) )    &
+                  &              - ( rho_i(ji  ,jj,jk) - rho_i(ji,jj,jk-1) )  ) * r1_e1u(ji,jj)
+               zhpj(ji,jj,jk) = zhpj(ji,jj,jk-1)                                &
+                  &           + (  ( rho_k(ji,jj+1,jk) - rho_k(ji,jj,jk  ) )    &
+                  &               -( rho_j(ji,jj  ,jk) - rho_j(ji,jj,jk-1) )  ) * r1_e2v(ji,jj)
+               IF( ln_wd_il ) THEN
+                 zhpi(ji,jj,jk) = zhpi(ji,jj,jk) * zcpx(ji,jj)
+                 zhpj(ji,jj,jk) = zhpj(ji,jj,jk) * zcpy(ji,jj) 
+               ENDIF
+               ! add to the general momentum trend
+               ua(ji,jj,jk) = ua(ji,jj,jk) + zhpi(ji,jj,jk)
+               va(ji,jj,jk) = va(ji,jj,jk) + zhpj(ji,jj,jk)
+            END DO
+         END DO
+      END DO
+      !
+      IF( ln_wd_il )   DEALLOCATE( zcpx, zcpy )
+      !
+   END SUBROUTINE hpg_djc
+
+
+   SUBROUTINE hpg_prj( kt )
+      !!---------------------------------------------------------------------
+      !!                  ***  ROUTINE hpg_prj  ***
+      !!
+      !! ** Method  :   s-coordinate case.
+      !!      A Pressure-Jacobian horizontal pressure gradient method
+      !!      based on the constrained cubic-spline interpolation for
+      !!      all vertical coordinate systems
+      !!
+      !! ** Action : - Update (ua,va) with the now hydrastatic pressure trend
+      !!----------------------------------------------------------------------
+      INTEGER, PARAMETER  :: polynomial_type = 1    ! 1: cubic spline, 2: linear
+      INTEGER, INTENT(in) ::   kt                   ! ocean time-step index
+      !!
+      INTEGER  ::   ji, jj, jk, jkk                 ! dummy loop indices
+      REAL(wp) ::   zcoef0, znad                    ! local scalars
+      !
+      !! The local variables for the correction term
+      INTEGER  :: jk1, jis, jid, jjs, jjd
+      LOGICAL  :: ll_tmp1, ll_tmp2                  ! local logical variables
+      REAL(wp) :: zuijk, zvijk, zpwes, zpwed, zpnss, zpnsd, zdeps
+      REAL(wp) :: zrhdt1
+      REAL(wp) :: zdpdx1, zdpdx2, zdpdy1, zdpdy2
+      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zdept, zrhh
+      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zhpi, zu, zv, fsp, xsp, asp, bsp, csp, dsp
+      REAL(wp), DIMENSION(jpi,jpj)   ::   zsshu_n, zsshv_n
+      REAL(wp), DIMENSION(:,:), ALLOCATABLE ::   zcpx, zcpy   !W/D pressure filter
+      !!----------------------------------------------------------------------
+      !
+      IF( kt == nit000 ) THEN
+         IF(lwp) WRITE(numout,*)
+         IF(lwp) WRITE(numout,*) 'dyn:hpg_prj : hydrostatic pressure gradient trend'
+         IF(lwp) WRITE(numout,*) '~~~~~~~~~~~   s-coordinate case, cubic spline pressure Jacobian'
+      ENDIF
+
+      ! Local constant initialization
+      zcoef0 = - grav
+      znad = 1._wp
+      IF( ln_linssh )   znad = 0._wp
+
+      IF( ln_wd_il ) THEN
+         ALLOCATE( zcpx(jpi,jpj) , zcpy(jpi,jpj) )
+         DO jj = 2, jpjm1
+           DO ji = 2, jpim1 
+             ll_tmp1 = MIN(  sshn(ji,jj)              ,  sshn(ji+1,jj) ) >                &
+                  &    MAX( -ht_0(ji,jj)              , -ht_0(ji+1,jj) ) .AND.            &
+                  &    MAX(  sshn(ji,jj) + ht_0(ji,jj),  sshn(ji+1,jj) + ht_0(ji+1,jj) )  &
+                  &                                                      > rn_wdmin1 + rn_wdmin2
+             ll_tmp2 = ( ABS( sshn(ji,jj)             -  sshn(ji+1,jj) ) > 1.E-12 ) .AND. (         &
+                  &    MAX(   sshn(ji,jj)             ,  sshn(ji+1,jj) ) >                &
+                  &    MAX(  -ht_0(ji,jj)             , -ht_0(ji+1,jj) ) + rn_wdmin1 + rn_wdmin2 )
+
+             IF(ll_tmp1) THEN
+               zcpx(ji,jj) = 1.0_wp
+             ELSE IF(ll_tmp2) THEN
+               ! no worries about  sshn(ji+1,jj) -  sshn(ji  ,jj) = 0, it won't happen ! here
+               zcpx(ji,jj) = ABS( (sshn(ji+1,jj) + ht_0(ji+1,jj) - sshn(ji,jj) - ht_0(ji,jj)) &
+                           &    / (sshn(ji+1,jj) -  sshn(ji  ,jj)) )
+              
+                zcpx(ji,jj) = max(min( zcpx(ji,jj) , 1.0_wp),0.0_wp)
+             ELSE
+               zcpx(ji,jj) = 0._wp
+             END IF
+      
+             ll_tmp1 = MIN(  sshn(ji,jj)              ,  sshn(ji,jj+1) ) >                &
+                  &    MAX( -ht_0(ji,jj)              , -ht_0(ji,jj+1) ) .AND.            &
+                  &    MAX(  sshn(ji,jj) + ht_0(ji,jj),  sshn(ji,jj+1) + ht_0(ji,jj+1) )  &
+                  &                                                      > rn_wdmin1 + rn_wdmin2
+             ll_tmp2 = ( ABS( sshn(ji,jj)             -  sshn(ji,jj+1) ) > 1.E-12 ) .AND. (      &
+                  &    MAX(   sshn(ji,jj)             ,  sshn(ji,jj+1) ) >                &
+                  &    MAX(  -ht_0(ji,jj)             , -ht_0(ji,jj+1) ) + rn_wdmin1 + rn_wdmin2 )
+
+             IF(ll_tmp1) THEN
+               zcpy(ji,jj) = 1.0_wp
+             ELSE IF(ll_tmp2) THEN
+               ! no worries about  sshn(ji,jj+1) -  sshn(ji,jj  ) = 0, it won't happen ! here
+               zcpy(ji,jj) = ABS( (sshn(ji,jj+1) + ht_0(ji,jj+1) - sshn(ji,jj) - ht_0(ji,jj)) &
+                           &    / (sshn(ji,jj+1) - sshn(ji,jj  )) )
+                zcpy(ji,jj) = max(min( zcpy(ji,jj) , 1.0_wp),0.0_wp)
+
+               ELSE
+                  zcpy(ji,jj) = 0._wp
+               ENDIF
+            END DO
+         END DO
+         CALL lbc_lnk_multi( zcpx, 'U', 1., zcpy, 'V', 1. )
+      ENDIF
+
+      ! Clean 3-D work arrays
+      zhpi(:,:,:) = 0._wp
+      zrhh(:,:,:) = rhd(:,:,:)
+
+      ! Preparing vertical density profile "zrhh(:,:,:)" for hybrid-sco coordinate
+      DO jj = 1, jpj
+        DO ji = 1, jpi
+          jk = mbkt(ji,jj)+1
+          IF(     jk <=  0   ) THEN   ;   zrhh(ji,jj,    :   ) = 0._wp
+          ELSEIF( jk ==  1   ) THEN   ;   zrhh(ji,jj,jk+1:jpk) = rhd(ji,jj,jk)
+          ELSEIF( jk < jpkm1 ) THEN
+             DO jkk = jk+1, jpk
+                zrhh(ji,jj,jkk) = interp1(gde3w_n(ji,jj,jkk  ), gde3w_n(ji,jj,jkk-1),   &
+                   &                      gde3w_n(ji,jj,jkk-2), rhd    (ji,jj,jkk-1), rhd(ji,jj,jkk-2))
+             END DO
+          ENDIF
+        END DO
+      END DO
+
+      ! Transfer the depth of "T(:,:,:)" to vertical coordinate "zdept(:,:,:)"
+      DO jj = 1, jpj
+         DO ji = 1, jpi
+            zdept(ji,jj,1) = 0.5_wp * e3w_n(ji,jj,1) - sshn(ji,jj) * znad
+         END DO
+      END DO
+
+      DO jk = 2, jpk
+         DO jj = 1, jpj
+            DO ji = 1, jpi
+               zdept(ji,jj,jk) = zdept(ji,jj,jk-1) + e3w_n(ji,jj,jk)
+            END DO
+         END DO
+      END DO
+
+      fsp(:,:,:) = zrhh (:,:,:)
+      xsp(:,:,:) = zdept(:,:,:)
+
+      ! Construct the vertical density profile with the
+      ! constrained cubic spline interpolation
+      ! rho(z) = asp + bsp*z + csp*z^2 + dsp*z^3
+      CALL cspline( fsp, xsp, asp, bsp, csp, dsp, polynomial_type )
+
+      ! Integrate the hydrostatic pressure "zhpi(:,:,:)" at "T(ji,jj,1)"
+      DO jj = 2, jpj
+        DO ji = 2, jpi
+          zrhdt1 = zrhh(ji,jj,1) - interp3( zdept(ji,jj,1), asp(ji,jj,1), bsp(ji,jj,1),  &
+             &                                              csp(ji,jj,1), dsp(ji,jj,1) ) * 0.25_wp * e3w_n(ji,jj,1)
+
+          ! assuming linear profile across the top half surface layer
+          zhpi(ji,jj,1) =  0.5_wp * e3w_n(ji,jj,1) * zrhdt1
+        END DO
+      END DO
+
+      ! Calculate the pressure "zhpi(:,:,:)" at "T(ji,jj,2:jpkm1)"
+      DO jk = 2, jpkm1
+        DO jj = 2, jpj
+          DO ji = 2, jpi
+            zhpi(ji,jj,jk) = zhpi(ji,jj,jk-1) +                                  &
+               &             integ_spline( zdept(ji,jj,jk-1), zdept(ji,jj,jk),   &
+               &                           asp  (ji,jj,jk-1), bsp  (ji,jj,jk-1), &
+               &                           csp  (ji,jj,jk-1), dsp  (ji,jj,jk-1)  )
+          END DO
+        END DO
+      END DO
+
+      ! Z coordinate of U(ji,jj,1:jpkm1) and V(ji,jj,1:jpkm1)
+
+      ! Prepare zsshu_n and zsshv_n
+      DO jj = 2, jpjm1
+        DO ji = 2, jpim1
+!!gm BUG ?    if it is ssh at u- & v-point then it should be:
+!          zsshu_n(ji,jj) = (e1e2t(ji,jj) * sshn(ji,jj) + e1e2t(ji+1,jj) * sshn(ji+1,jj)) * &
+!                         & r1_e1e2u(ji,jj) * umask(ji,jj,1) * 0.5_wp 
+!          zsshv_n(ji,jj) = (e1e2t(ji,jj) * sshn(ji,jj) + e1e2t(ji,jj+1) * sshn(ji,jj+1)) * &
+!                         & r1_e1e2v(ji,jj) * vmask(ji,jj,1) * 0.5_wp 
+!!gm not this:
+          zsshu_n(ji,jj) = (e1e2u(ji,jj) * sshn(ji,jj) + e1e2u(ji+1, jj) * sshn(ji+1,jj)) * &
+                         & r1_e1e2u(ji,jj) * umask(ji,jj,1) * 0.5_wp 
+          zsshv_n(ji,jj) = (e1e2v(ji,jj) * sshn(ji,jj) + e1e2v(ji+1, jj) * sshn(ji,jj+1)) * &
+                         & r1_e1e2v(ji,jj) * vmask(ji,jj,1) * 0.5_wp 
+        END DO
+      END DO
+
+      CALL lbc_lnk_multi (zsshu_n, 'U', 1., zsshv_n, 'V', 1. )
+
+      DO jj = 2, jpjm1
+        DO ji = 2, jpim1
+          zu(ji,jj,1) = - ( e3u_n(ji,jj,1) - zsshu_n(ji,jj) * znad) 
+          zv(ji,jj,1) = - ( e3v_n(ji,jj,1) - zsshv_n(ji,jj) * znad)
+        END DO
+      END DO
+
+      DO jk = 2, jpkm1
+        DO jj = 2, jpjm1
+          DO ji = 2, jpim1
+            zu(ji,jj,jk) = zu(ji,jj,jk-1) - e3u_n(ji,jj,jk)
+            zv(ji,jj,jk) = zv(ji,jj,jk-1) - e3v_n(ji,jj,jk)
+          END DO
+        END DO
+      END DO
+
+      DO jk = 1, jpkm1
+        DO jj = 2, jpjm1
+          DO ji = 2, jpim1
+            zu(ji,jj,jk) = zu(ji,jj,jk) + 0.5_wp * e3u_n(ji,jj,jk)
+            zv(ji,jj,jk) = zv(ji,jj,jk) + 0.5_wp * e3v_n(ji,jj,jk)
+          END DO
+        END DO
+      END DO
+
+      DO jk = 1, jpkm1
+        DO jj = 2, jpjm1
+          DO ji = 2, jpim1
+            zu(ji,jj,jk) = MIN(  zu(ji,jj,jk) , MAX( -zdept(ji,jj,jk) , -zdept(ji+1,jj,jk) )  )
+            zu(ji,jj,jk) = MAX(  zu(ji,jj,jk) , MIN( -zdept(ji,jj,jk) , -zdept(ji+1,jj,jk) )  )
+            zv(ji,jj,jk) = MIN(  zv(ji,jj,jk) , MAX( -zdept(ji,jj,jk) , -zdept(ji,jj+1,jk) )  )
+            zv(ji,jj,jk) = MAX(  zv(ji,jj,jk) , MIN( -zdept(ji,jj,jk) , -zdept(ji,jj+1,jk) )  )
+          END DO
+        END DO
+      END DO
+
+
+      DO jk = 1, jpkm1
+        DO jj = 2, jpjm1
+          DO ji = 2, jpim1
+            zpwes = 0._wp; zpwed = 0._wp
+            zpnss = 0._wp; zpnsd = 0._wp
+            zuijk = zu(ji,jj,jk)
+            zvijk = zv(ji,jj,jk)
+
+            !!!!!     for u equation
+            IF( jk <= mbku(ji,jj) ) THEN
+               IF( -zdept(ji+1,jj,jk) >= -zdept(ji,jj,jk) ) THEN
+                 jis = ji + 1; jid = ji
+               ELSE
+                 jis = ji;     jid = ji +1
+               ENDIF
+
+               ! integrate the pressure on the shallow side
+               jk1 = jk
+               DO WHILE ( -zdept(jis,jj,jk1) > zuijk )
+                 IF( jk1 == mbku(ji,jj) ) THEN
+                   zuijk = -zdept(jis,jj,jk1)
+                   EXIT
+                 ENDIF
+                 zdeps = MIN(zdept(jis,jj,jk1+1), -zuijk)
+                 zpwes = zpwes +                                    &
+                      integ_spline(zdept(jis,jj,jk1), zdeps,            &
+                             asp(jis,jj,jk1),    bsp(jis,jj,jk1), &
+                             csp(jis,jj,jk1),    dsp(jis,jj,jk1))
+                 jk1 = jk1 + 1
+               END DO
+
+               ! integrate the pressure on the deep side
+               jk1 = jk
+               DO WHILE ( -zdept(jid,jj,jk1) < zuijk )
+                 IF( jk1 == 1 ) THEN
+                   zdeps = zdept(jid,jj,1) + MIN(zuijk, sshn(jid,jj)*znad)
+                   zrhdt1 = zrhh(jid,jj,1) - interp3(zdept(jid,jj,1), asp(jid,jj,1), &
+                                                     bsp(jid,jj,1),   csp(jid,jj,1), &
+                                                     dsp(jid,jj,1)) * zdeps
+                   zpwed  = zpwed + 0.5_wp * (zrhh(jid,jj,1) + zrhdt1) * zdeps
+                   EXIT
+                 ENDIF
+                 zdeps = MAX(zdept(jid,jj,jk1-1), -zuijk)
+                 zpwed = zpwed +                                        &
+                        integ_spline(zdeps,              zdept(jid,jj,jk1), &
+                               asp(jid,jj,jk1-1), bsp(jid,jj,jk1-1),  &
+                               csp(jid,jj,jk1-1), dsp(jid,jj,jk1-1) )
+                 jk1 = jk1 - 1
+               END DO
+
+               ! update the momentum trends in u direction
+
+               zdpdx1 = zcoef0 * r1_e1u(ji,jj) * ( zhpi(ji+1,jj,jk) - zhpi(ji,jj,jk) )
+               IF( .NOT.ln_linssh ) THEN
+                 zdpdx2 = zcoef0 * r1_e1u(ji,jj) * &
+                    &    ( REAL(jis-jid, wp) * (zpwes + zpwed) + (sshn(ji+1,jj)-sshn(ji,jj)) )
+                ELSE
+                 zdpdx2 = zcoef0 * r1_e1u(ji,jj) * REAL(jis-jid, wp) * (zpwes + zpwed)
+               ENDIF
+               IF( ln_wd_il ) THEN
+                  zdpdx1 = zdpdx1 * zcpx(ji,jj) * wdrampu(ji,jj)
+                  zdpdx2 = zdpdx2 * zcpx(ji,jj) * wdrampu(ji,jj)
+               ENDIF
+               ua(ji,jj,jk) = ua(ji,jj,jk) + (zdpdx1 + zdpdx2) * umask(ji,jj,jk) 
+            ENDIF
+
+            !!!!!     for v equation
+            IF( jk <= mbkv(ji,jj) ) THEN
+               IF( -zdept(ji,jj+1,jk) >= -zdept(ji,jj,jk) ) THEN
+                 jjs = jj + 1; jjd = jj
+               ELSE
+                 jjs = jj    ; jjd = jj + 1
+               ENDIF
+
+               ! integrate the pressure on the shallow side
+               jk1 = jk
+               DO WHILE ( -zdept(ji,jjs,jk1) > zvijk )
+                 IF( jk1 == mbkv(ji,jj) ) THEN
+                   zvijk = -zdept(ji,jjs,jk1)
+                   EXIT
+                 ENDIF
+                 zdeps = MIN(zdept(ji,jjs,jk1+1), -zvijk)
+                 zpnss = zpnss +                                      &
+                        integ_spline(zdept(ji,jjs,jk1), zdeps,            &
+                               asp(ji,jjs,jk1),    bsp(ji,jjs,jk1), &
+                               csp(ji,jjs,jk1),    dsp(ji,jjs,jk1) )
+                 jk1 = jk1 + 1
+               END DO
+
+               ! integrate the pressure on the deep side
+               jk1 = jk
+               DO WHILE ( -zdept(ji,jjd,jk1) < zvijk )
+                 IF( jk1 == 1 ) THEN
+                   zdeps = zdept(ji,jjd,1) + MIN(zvijk, sshn(ji,jjd)*znad)
+                   zrhdt1 = zrhh(ji,jjd,1) - interp3(zdept(ji,jjd,1), asp(ji,jjd,1), &
+                                                     bsp(ji,jjd,1),   csp(ji,jjd,1), &
+                                                     dsp(ji,jjd,1) ) * zdeps
+                   zpnsd  = zpnsd + 0.5_wp * (zrhh(ji,jjd,1) + zrhdt1) * zdeps
+                   EXIT
+                 ENDIF
+                 zdeps = MAX(zdept(ji,jjd,jk1-1), -zvijk)
+                 zpnsd = zpnsd +                                        &
+                        integ_spline(zdeps,              zdept(ji,jjd,jk1), &
+                               asp(ji,jjd,jk1-1), bsp(ji,jjd,jk1-1), &
+                               csp(ji,jjd,jk1-1), dsp(ji,jjd,jk1-1) )
+                 jk1 = jk1 - 1
+               END DO
+
+
+               ! update the momentum trends in v direction
+
+               zdpdy1 = zcoef0 * r1_e2v(ji,jj) * ( zhpi(ji,jj+1,jk) - zhpi(ji,jj,jk) )
+               IF( .NOT.ln_linssh ) THEN
+                  zdpdy2 = zcoef0 * r1_e2v(ji,jj) * &
+                          ( REAL(jjs-jjd, wp) * (zpnss + zpnsd) + (sshn(ji,jj+1)-sshn(ji,jj)) )
+               ELSE
+                  zdpdy2 = zcoef0 * r1_e2v(ji,jj) * REAL(jjs-jjd, wp) * (zpnss + zpnsd )
+               ENDIF
+               IF( ln_wd_il ) THEN
+                  zdpdy1 = zdpdy1 * zcpy(ji,jj) * wdrampv(ji,jj) 
+                  zdpdy2 = zdpdy2 * zcpy(ji,jj) * wdrampv(ji,jj) 
+               ENDIF
+
+               va(ji,jj,jk) = va(ji,jj,jk) + (zdpdy1 + zdpdy2) * vmask(ji,jj,jk)
+            ENDIF
+               !
+            END DO
+         END DO
+      END DO
+      !
+      IF( ln_wd_il )   DEALLOCATE( zcpx, zcpy )
+      !
+   END SUBROUTINE hpg_prj
+
+
+   SUBROUTINE cspline( fsp, xsp, asp, bsp, csp, dsp, polynomial_type )
+      !!----------------------------------------------------------------------
+      !!                 ***  ROUTINE cspline  ***
+      !!
+      !! ** Purpose :   constrained cubic spline interpolation
+      !!
+      !! ** Method  :   f(x) = asp + bsp*x + csp*x^2 + dsp*x^3
+      !!
+      !! Reference: CJC Kruger, Constrained Cubic Spline Interpoltation
+      !!----------------------------------------------------------------------
+      REAL(wp), DIMENSION(:,:,:), INTENT(in   ) ::   fsp, xsp           ! value and coordinate
+      REAL(wp), DIMENSION(:,:,:), INTENT(  out) ::   asp, bsp, csp, dsp ! coefficients of the interpoated function
+      INTEGER                   , INTENT(in   ) ::   polynomial_type    ! 1: cubic spline   ;   2: Linear
+      !
+      INTEGER  ::   ji, jj, jk                 ! dummy loop indices
+      INTEGER  ::   jpi, jpj, jpkm1
+      REAL(wp) ::   zdf1, zdf2, zddf1, zddf2, ztmp1, ztmp2, zdxtmp
+      REAL(wp) ::   zdxtmp1, zdxtmp2, zalpha
+      REAL(wp) ::   zdf(size(fsp,3))
+      !!----------------------------------------------------------------------
+      !
+!!gm  WHAT !!!!!   THIS IS VERY DANGEROUS !!!!!  
+      jpi   = size(fsp,1)
+      jpj   = size(fsp,2)
+      jpkm1 = MAX( 1, size(fsp,3) - 1 )
+      !
+      IF (polynomial_type == 1) THEN     ! Constrained Cubic Spline
+         DO ji = 1, jpi
+            DO jj = 1, jpj
+           !!Fritsch&Butland's method, 1984 (preferred, but more computation)
+           !    DO jk = 2, jpkm1-1
+           !       zdxtmp1 = xsp(ji,jj,jk)   - xsp(ji,jj,jk-1)
+           !       zdxtmp2 = xsp(ji,jj,jk+1) - xsp(ji,jj,jk)
+           !       zdf1    = ( fsp(ji,jj,jk)   - fsp(ji,jj,jk-1) ) / zdxtmp1
+           !       zdf2    = ( fsp(ji,jj,jk+1) - fsp(ji,jj,jk)   ) / zdxtmp2
+           !
+           !       zalpha = ( zdxtmp1 + 2._wp * zdxtmp2 ) / ( zdxtmp1 + zdxtmp2 ) / 3._wp
+           !
+           !       IF(zdf1 * zdf2 <= 0._wp) THEN
+           !           zdf(jk) = 0._wp
+           !       ELSE
+           !         zdf(jk) = zdf1 * zdf2 / ( ( 1._wp - zalpha ) * zdf1 + zalpha * zdf2 )
+           !       ENDIF
+           !    END DO
+
+           !!Simply geometric average
+               DO jk = 2, jpkm1-1
+                  zdf1 = (fsp(ji,jj,jk  ) - fsp(ji,jj,jk-1)) / (xsp(ji,jj,jk  ) - xsp(ji,jj,jk-1))
+                  zdf2 = (fsp(ji,jj,jk+1) - fsp(ji,jj,jk  )) / (xsp(ji,jj,jk+1) - xsp(ji,jj,jk  ))
+
+                  IF(zdf1 * zdf2 <= 0._wp) THEN
+                     zdf(jk) = 0._wp
+                  ELSE
+                     zdf(jk) = 2._wp * zdf1 * zdf2 / (zdf1 + zdf2)
+                  ENDIF
+               END DO
+
+               zdf(1)     = 1.5_wp * ( fsp(ji,jj,2) - fsp(ji,jj,1) ) / &
+                          &          ( xsp(ji,jj,2) - xsp(ji,jj,1) )           -  0.5_wp * zdf(2)
+               zdf(jpkm1) = 1.5_wp * ( fsp(ji,jj,jpkm1) - fsp(ji,jj,jpkm1-1) ) / &
+                          &          ( xsp(ji,jj,jpkm1) - xsp(ji,jj,jpkm1-1) ) - 0.5_wp * zdf(jpkm1 - 1)
+
+               DO jk = 1, jpkm1 - 1
+                 zdxtmp = xsp(ji,jj,jk+1) - xsp(ji,jj,jk)
+                 ztmp1  = (zdf(jk+1) + 2._wp * zdf(jk)) / zdxtmp
+                 ztmp2  =  6._wp * (fsp(ji,jj,jk+1) - fsp(ji,jj,jk)) / zdxtmp / zdxtmp
+                 zddf1  = -2._wp * ztmp1 + ztmp2
+                 ztmp1  = (2._wp * zdf(jk+1) + zdf(jk)) / zdxtmp
+                 zddf2  =  2._wp * ztmp1 - ztmp2
+
+                 dsp(ji,jj,jk) = (zddf2 - zddf1) / 6._wp / zdxtmp
+                 csp(ji,jj,jk) = ( xsp(ji,jj,jk+1) * zddf1 - xsp(ji,jj,jk)*zddf2 ) / 2._wp / zdxtmp
+                 bsp(ji,jj,jk) = ( fsp(ji,jj,jk+1) - fsp(ji,jj,jk) ) / zdxtmp - &
+                               & csp(ji,jj,jk) * ( xsp(ji,jj,jk+1) + xsp(ji,jj,jk) ) - &
+                               & dsp(ji,jj,jk) * ((xsp(ji,jj,jk+1) + xsp(ji,jj,jk))**2 - &
+                               &                   xsp(ji,jj,jk+1) * xsp(ji,jj,jk))
+                 asp(ji,jj,jk) = fsp(ji,jj,jk) - xsp(ji,jj,jk) * (bsp(ji,jj,jk) + &
+                               &                (xsp(ji,jj,jk) * (csp(ji,jj,jk) + &
+                               &                 dsp(ji,jj,jk) * xsp(ji,jj,jk))))
+               END DO
+            END DO
+         END DO
+
+      ELSEIF ( polynomial_type == 2 ) THEN     ! Linear
+         DO ji = 1, jpi
+            DO jj = 1, jpj
+               DO jk = 1, jpkm1-1
+                  zdxtmp =xsp(ji,jj,jk+1) - xsp(ji,jj,jk)
+                  ztmp1 = fsp(ji,jj,jk+1) - fsp(ji,jj,jk)
+
+                  dsp(ji,jj,jk) = 0._wp
+                  csp(ji,jj,jk) = 0._wp
+                  bsp(ji,jj,jk) = ztmp1 / zdxtmp
+                  asp(ji,jj,jk) = fsp(ji,jj,jk) - bsp(ji,jj,jk) * xsp(ji,jj,jk)
+               END DO
+            END DO
+         END DO
+         !
+      ELSE
+         CALL ctl_stop( 'invalid polynomial type in cspline' )
+      ENDIF
+      !
+   END SUBROUTINE cspline
+
+
+   FUNCTION interp1(x, xl, xr, fl, fr)  RESULT(f)
+      !!----------------------------------------------------------------------
+      !!                 ***  ROUTINE interp1  ***
+      !!
+      !! ** Purpose :   1-d linear interpolation
+      !!
+      !! ** Method  :   interpolation is straight forward
+      !!                extrapolation is also permitted (no value limit)
+      !!----------------------------------------------------------------------
+      REAL(wp), INTENT(in) ::  x, xl, xr, fl, fr
+      REAL(wp)             ::  f ! result of the interpolation (extrapolation)
+      REAL(wp)             ::  zdeltx
+      !!----------------------------------------------------------------------
+      !
+      zdeltx = xr - xl
+      IF( abs(zdeltx) <= 10._wp * EPSILON(x) ) THEN
+         f = 0.5_wp * (fl + fr)
+      ELSE
+         f = ( (x - xl ) * fr - ( x - xr ) * fl ) / zdeltx
+      ENDIF
+      !
+   END FUNCTION interp1
+
+
+   FUNCTION interp2( x, a, b, c, d )  RESULT(f)
+      !!----------------------------------------------------------------------
+      !!                 ***  ROUTINE interp1  ***
+      !!
+      !! ** Purpose :   1-d constrained cubic spline interpolation
+      !!
+      !! ** Method  :  cubic spline interpolation
+      !!
+      !!----------------------------------------------------------------------
+      REAL(wp), INTENT(in) ::  x, a, b, c, d
+      REAL(wp)             ::  f ! value from the interpolation
+      !!----------------------------------------------------------------------
+      !
+      f = a + x* ( b + x * ( c + d * x ) )
+      !
+   END FUNCTION interp2
+
+
+   FUNCTION interp3( x, a, b, c, d )  RESULT(f)
+      !!----------------------------------------------------------------------
+      !!                 ***  ROUTINE interp1  ***
+      !!
+      !! ** Purpose :   Calculate the first order of derivative of
+      !!                a cubic spline function y=a+b*x+c*x^2+d*x^3
+      !!
+      !! ** Method  :   f=dy/dx=b+2*c*x+3*d*x^2
+      !!
+      !!----------------------------------------------------------------------
+      REAL(wp), INTENT(in) ::  x, a, b, c, d
+      REAL(wp)             ::  f ! value from the interpolation
+      !!----------------------------------------------------------------------
+      !
+      f = b + x * ( 2._wp * c + 3._wp * d * x)
+      !
+   END FUNCTION interp3
+
+
+   FUNCTION integ_spline( xl, xr, a, b, c, d )  RESULT(f)
+      !!----------------------------------------------------------------------
+      !!                 ***  ROUTINE interp1  ***
+      !!
+      !! ** Purpose :   1-d constrained cubic spline integration
+      !!
+      !! ** Method  :  integrate polynomial a+bx+cx^2+dx^3 from xl to xr
+      !!
+      !!----------------------------------------------------------------------
+      REAL(wp), INTENT(in) ::  xl, xr, a, b, c, d
+      REAL(wp)             ::  za1, za2, za3
+      REAL(wp)             ::  f                   ! integration result
+      !!----------------------------------------------------------------------
+      !
+      za1 = 0.5_wp * b
+      za2 = c / 3.0_wp
+      za3 = 0.25_wp * d
+      !
+      f  = xr * ( a + xr * ( za1 + xr * ( za2 + za3 * xr ) ) ) - &
+         & xl * ( a + xl * ( za1 + xl * ( za2 + za3 * xl ) ) )
+      !
+   END FUNCTION integ_spline
+
+   !!======================================================================
+END MODULE dynhpg
+
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DYN/dynkeg.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DYN/dynkeg.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DYN/dynkeg.F90	(revision 9570)
@@ -0,0 +1,195 @@
+MODULE dynkeg
+   !!======================================================================
+   !!                       ***  MODULE  dynkeg  ***
+   !! Ocean dynamics:  kinetic energy gradient trend
+   !!======================================================================
+   !! History :  1.0  !  1987-09  (P. Andrich, M.-A. Foujols)  Original code
+   !!            7.0  !  1997-05  (G. Madec)  Split dynber into dynkeg and dynhpg
+   !!  NEMO      1.0  !  2002-07  (G. Madec)  F90: Free form and module
+   !!            3.6  !  2015-05  (N. Ducousso, G. Madec)  add Hollingsworth scheme as an option 
+   !!----------------------------------------------------------------------
+   
+   !!----------------------------------------------------------------------
+   !!   dyn_keg      : update the momentum trend with the horizontal tke
+   !!----------------------------------------------------------------------
+   USE oce             ! ocean dynamics and tracers
+   USE dom_oce         ! ocean space and time domain
+   USE trd_oce         ! trends: ocean variables
+   USE trddyn          ! trend manager: dynamics
+   !
+   USE in_out_manager  ! I/O manager
+   USE lbclnk          ! ocean lateral boundary conditions (or mpp link)
+   USE lib_mpp         ! MPP library
+   USE prtctl          ! Print control
+   USE timing          ! Timing
+   USE bdy_oce         ! ocean open boundary conditions
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   dyn_keg    ! routine called by step module
+   
+   INTEGER, PARAMETER, PUBLIC  ::   nkeg_C2  = 0   !: 2nd order centered scheme (standard scheme)
+   INTEGER, PARAMETER, PUBLIC  ::   nkeg_HW  = 1   !: Hollingsworth et al., QJRMS, 1983
+   !
+   REAL(wp) ::   r1_48 = 1._wp / 48._wp   !: =1/(4*2*6)
+   
+   !! * Substitutions
+#  include "vectopt_loop_substitute.h90"
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 4.0 , NEMO Consortium (2017)
+   !! $Id$ 
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE dyn_keg( kt, kscheme )
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE dyn_keg  ***
+      !!
+      !! ** Purpose :   Compute the now momentum trend due to the horizontal
+      !!      gradient of the horizontal kinetic energy and add it to the 
+      !!      general momentum trend.
+      !!
+      !! ** Method  : * kscheme = nkeg_C2 : 2nd order centered scheme that 
+      !!      conserve kinetic energy. Compute the now horizontal kinetic energy 
+      !!         zhke = 1/2 [ mi-1( un^2 ) + mj-1( vn^2 ) ]
+      !!              * kscheme = nkeg_HW : Hollingsworth correction following
+      !!      Arakawa (2001). The now horizontal kinetic energy is given by:
+      !!         zhke = 1/6 [ mi-1(  2 * un^2 + ((un(j+1)+un(j-1))/2)^2  )
+      !!                    + mj-1(  2 * vn^2 + ((vn(i+1)+vn(i-1))/2)^2  ) ]
+      !!      
+      !!      Take its horizontal gradient and add it to the general momentum
+      !!      trend (ua,va).
+      !!         ua = ua - 1/e1u di[ zhke ]
+      !!         va = va - 1/e2v dj[ zhke ]
+      !!
+      !! ** Action : - Update the (ua, va) with the hor. ke gradient trend
+      !!             - send this trends to trd_dyn (l_trddyn=T) for post-processing
+      !!
+      !! ** References : Arakawa, A., International Geophysics 2001.
+      !!                 Hollingsworth et al., Quart. J. Roy. Meteor. Soc., 1983.
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT( in ) ::   kt        ! ocean time-step index
+      INTEGER, INTENT( in ) ::   kscheme   ! =0/1   type of KEG scheme 
+      !
+      INTEGER  ::   ji, jj, jk, jb    ! dummy loop indices
+      INTEGER  ::   ii, ifu, ib_bdy   ! local integers
+      INTEGER  ::   ij, ifv, igrd     !   -       -
+      REAL(wp) ::   zu, zv            ! local scalars
+      REAL(wp), DIMENSION(jpi,jpj,jpk)        ::   zhke
+      REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) ::   ztrdu, ztrdv 
+      !!----------------------------------------------------------------------
+      !
+      IF( ln_timing )   CALL timing_start('dyn_keg')
+      !
+      IF( kt == nit000 ) THEN
+         IF(lwp) WRITE(numout,*)
+         IF(lwp) WRITE(numout,*) 'dyn_keg : kinetic energy gradient trend, scheme number=', kscheme
+         IF(lwp) WRITE(numout,*) '~~~~~~~'
+      ENDIF
+
+      IF( l_trddyn ) THEN           ! Save the input trends
+         ALLOCATE( ztrdu(jpi,jpj,jpk) , ztrdv(jpi,jpj,jpk) )
+         ztrdu(:,:,:) = ua(:,:,:) 
+         ztrdv(:,:,:) = va(:,:,:) 
+      ENDIF
+      
+      zhke(:,:,jpk) = 0._wp
+      
+      IF (ln_bdy) THEN
+         ! Maria Luneva & Fred Wobus: July-2016
+         ! compensate for lack of turbulent kinetic energy on liquid bdy points
+         DO ib_bdy = 1, nb_bdy
+            IF( cn_dyn3d(ib_bdy) /= 'none' ) THEN
+               igrd = 2           ! Copying normal velocity into points outside bdy
+               DO jb = 1, idx_bdy(ib_bdy)%nblenrim(igrd)
+                  DO jk = 1, jpkm1
+                     ii   = idx_bdy(ib_bdy)%nbi(jb,igrd)
+                     ij   = idx_bdy(ib_bdy)%nbj(jb,igrd)
+                     ifu   = NINT( idx_bdy(ib_bdy)%flagu(jb,igrd) )
+                     un(ii-ifu,ij,jk) = un(ii,ij,jk) * umask(ii,ij,jk)
+                  END DO
+               END DO
+               !
+               igrd = 3           ! Copying normal velocity into points outside bdy
+               DO jb = 1, idx_bdy(ib_bdy)%nblenrim(igrd)
+                  DO jk = 1, jpkm1
+                     ii   = idx_bdy(ib_bdy)%nbi(jb,igrd)
+                     ij   = idx_bdy(ib_bdy)%nbj(jb,igrd)
+                     ifv   = NINT( idx_bdy(ib_bdy)%flagv(jb,igrd) )
+                     vn(ii,ij-ifv,jk) = vn(ii,ij,jk) * vmask(ii,ij,jk)
+                  END DO
+               END DO
+            ENDIF
+         ENDDO  
+      ENDIF 
+
+      SELECT CASE ( kscheme )             !== Horizontal kinetic energy at T-point  ==!
+      !
+      CASE ( nkeg_C2 )                          !--  Standard scheme  --!
+         DO jk = 1, jpkm1
+            DO jj = 2, jpj
+               DO ji = fs_2, jpi   ! vector opt.
+                  zu =    un(ji-1,jj  ,jk) * un(ji-1,jj  ,jk)   &
+                     &  + un(ji  ,jj  ,jk) * un(ji  ,jj  ,jk)
+                  zv =    vn(ji  ,jj-1,jk) * vn(ji  ,jj-1,jk)   &
+                     &  + vn(ji  ,jj  ,jk) * vn(ji  ,jj  ,jk)
+                  zhke(ji,jj,jk) = 0.25_wp * ( zv + zu )
+               END DO  
+            END DO
+         END DO
+         !
+      CASE ( nkeg_HW )                          !--  Hollingsworth scheme  --!
+         DO jk = 1, jpkm1
+            DO jj = 2, jpjm1       
+               DO ji = fs_2, jpim1   ! vector opt.
+                  zu = 8._wp * ( un(ji-1,jj  ,jk) * un(ji-1,jj  ,jk)    &
+                     &         + un(ji  ,jj  ,jk) * un(ji  ,jj  ,jk) )  &
+                     &   +     ( un(ji-1,jj-1,jk) + un(ji-1,jj+1,jk) ) * ( un(ji-1,jj-1,jk) + un(ji-1,jj+1,jk) )   &
+                     &   +     ( un(ji  ,jj-1,jk) + un(ji  ,jj+1,jk) ) * ( un(ji  ,jj-1,jk) + un(ji  ,jj+1,jk) )
+                     !
+                  zv = 8._wp * ( vn(ji  ,jj-1,jk) * vn(ji  ,jj-1,jk)    &
+                     &         + vn(ji  ,jj  ,jk) * vn(ji  ,jj  ,jk) )  &
+                     &  +      ( vn(ji-1,jj-1,jk) + vn(ji+1,jj-1,jk) ) * ( vn(ji-1,jj-1,jk) + vn(ji+1,jj-1,jk) )   &
+                     &  +      ( vn(ji-1,jj  ,jk) + vn(ji+1,jj  ,jk) ) * ( vn(ji-1,jj  ,jk) + vn(ji+1,jj  ,jk) )
+                  zhke(ji,jj,jk) = r1_48 * ( zv + zu )
+               END DO  
+            END DO
+         END DO
+         CALL lbc_lnk( zhke, 'T', 1. )
+         !
+      END SELECT
+
+      IF (ln_bdy) THEN
+         ! restore velocity masks at points outside boundary
+         un(:,:,:) = un(:,:,:) * umask(:,:,:)
+         vn(:,:,:) = vn(:,:,:) * vmask(:,:,:)
+      ENDIF      
+
+      !
+      DO jk = 1, jpkm1                    !==  grad( KE ) added to the general momentum trends  ==!
+         DO jj = 2, jpjm1
+            DO ji = fs_2, fs_jpim1   ! vector opt.
+               ua(ji,jj,jk) = ua(ji,jj,jk) - ( zhke(ji+1,jj  ,jk) - zhke(ji,jj,jk) ) / e1u(ji,jj)
+               va(ji,jj,jk) = va(ji,jj,jk) - ( zhke(ji  ,jj+1,jk) - zhke(ji,jj,jk) ) / e2v(ji,jj)
+            END DO 
+         END DO
+      END DO
+      !
+      IF( l_trddyn ) THEN                 ! save the Kinetic Energy trends for diagnostic
+         ztrdu(:,:,:) = ua(:,:,:) - ztrdu(:,:,:)
+         ztrdv(:,:,:) = va(:,:,:) - ztrdv(:,:,:)
+         CALL trd_dyn( ztrdu, ztrdv, jpdyn_keg, kt )
+         DEALLOCATE( ztrdu , ztrdv )
+      ENDIF
+      !
+      IF(ln_ctl)   CALL prt_ctl( tab3d_1=ua, clinfo1=' keg  - Ua: ', mask1=umask,   &
+         &                       tab3d_2=va, clinfo2=       ' Va: ', mask2=vmask, clinfo3='dyn' )
+      !
+      IF( ln_timing )   CALL timing_stop('dyn_keg')
+      !
+   END SUBROUTINE dyn_keg
+
+   !!======================================================================
+END MODULE dynkeg
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DYN/dynldf.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DYN/dynldf.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DYN/dynldf.F90	(revision 9570)
@@ -0,0 +1,113 @@
+MODULE dynldf
+   !!======================================================================
+   !!                       ***  MODULE  dynldf  ***
+   !! Ocean physics:  lateral diffusivity trends 
+   !!=====================================================================
+   !! History :  2.0  ! 2005-11  (G. Madec)  Original code (new step architecture)
+   !!            3.7  ! 2014-01  (F. Lemarie, G. Madec)  restructuration/simplification of ahm specification,
+   !!                 !                                  add velocity dependent coefficient and optional read in file
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   dyn_ldf      : update the dynamics trend with the lateral diffusion
+   !!   dyn_ldf_init : initialization, namelist read, and parameters control
+   !!----------------------------------------------------------------------
+   USE oce            ! ocean dynamics and tracers
+   USE dom_oce        ! ocean space and time domain
+   USE phycst         ! physical constants
+   USE ldfdyn         ! lateral diffusion: eddy viscosity coef.
+   USE dynldf_lap_blp ! lateral mixing   (dyn_ldf_lap & dyn_ldf_blp routines)
+   USE dynldf_iso     ! lateral mixing                 (dyn_ldf_iso routine )
+   USE trd_oce        ! trends: ocean variables
+   USE trddyn         ! trend manager: dynamics   (trd_dyn      routine)
+   !
+   USE prtctl         ! Print control
+   USE in_out_manager ! I/O manager
+   USE lib_mpp        ! distribued memory computing library
+   USE lbclnk         ! ocean lateral boundary conditions (or mpp link)
+   USE timing         ! Timing
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   dyn_ldf       ! called by step module 
+   PUBLIC   dyn_ldf_init  ! called by opa  module 
+
+   !! * Substitutions
+#  include "vectopt_loop_substitute.h90"
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 4.0 , NEMO Consortium (2017)
+   !! $Id$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE dyn_ldf( kt )
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE dyn_ldf  ***
+      !! 
+      !! ** Purpose :   compute the lateral ocean dynamics physics.
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT(in) ::   kt   ! ocean time-step index
+      !
+      REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) ::   ztrdu, ztrdv
+      !!----------------------------------------------------------------------
+      !
+      IF( ln_timing )   CALL timing_start('dyn_ldf')
+      !
+      IF( l_trddyn )   THEN                      ! temporary save of momentum trends
+         ALLOCATE( ztrdu(jpi,jpj,jpk) , ztrdv(jpi,jpj,jpk) )
+         ztrdu(:,:,:) = ua(:,:,:) 
+         ztrdv(:,:,:) = va(:,:,:) 
+      ENDIF
+
+      SELECT CASE ( nldf_dyn )                   ! compute lateral mixing trend and add it to the general trend
+      !
+      CASE ( np_lap   )    ;   CALL dyn_ldf_lap( kt, ub, vb, ua, va, 1 )      ! iso-level    laplacian
+      CASE ( np_lap_i )    ;   CALL dyn_ldf_iso( kt )                         ! rotated      laplacian
+      CASE ( np_blp   )    ;   CALL dyn_ldf_blp( kt, ub, vb, ua, va    )      ! iso-level bi-laplacian
+      !
+      END SELECT
+
+      IF( l_trddyn ) THEN                        ! save the horizontal diffusive trends for further diagnostics
+         ztrdu(:,:,:) = ua(:,:,:) - ztrdu(:,:,:)
+         ztrdv(:,:,:) = va(:,:,:) - ztrdv(:,:,:)
+         CALL trd_dyn( ztrdu, ztrdv, jpdyn_ldf, kt )
+         DEALLOCATE ( ztrdu , ztrdv )
+      ENDIF
+      !                                          ! print sum trends (used for debugging)
+      IF(ln_ctl)   CALL prt_ctl( tab3d_1=ua, clinfo1=' ldf  - Ua: ', mask1=umask,   &
+         &                       tab3d_2=va, clinfo2=       ' Va: ', mask2=vmask, clinfo3='dyn' )
+      !
+      IF( ln_timing )   CALL timing_stop('dyn_ldf')
+      !
+   END SUBROUTINE dyn_ldf
+
+
+   SUBROUTINE dyn_ldf_init
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE dyn_ldf_init  ***
+      !! 
+      !! ** Purpose :   initializations of the horizontal ocean dynamics physics
+      !!----------------------------------------------------------------------
+      !
+      IF(lwp) THEN                     !==  Namelist print  ==!
+         WRITE(numout,*)
+         WRITE(numout,*) 'dyn_ldf_init : Choice of the lateral diffusive operator on dynamics'
+         WRITE(numout,*) '~~~~~~~~~~~~'
+         WRITE(numout,*) '   Namelist namdyn_ldf: already read in ldfdyn module'
+         WRITE(numout,*) '      see ldf_dyn_init report for lateral mixing parameters'
+         WRITE(numout,*)
+         !
+         SELECT CASE( nldf_dyn )             ! print the choice of operator
+         CASE( np_no_ldf )   ;   WRITE(numout,*) '   ==>>>   NO lateral viscosity'
+         CASE( np_lap    )   ;   WRITE(numout,*) '   ==>>>   iso-level laplacian operator'
+         CASE( np_lap_i  )   ;   WRITE(numout,*) '   ==>>>   rotated laplacian operator with iso-level background'
+         CASE( np_blp    )   ;   WRITE(numout,*) '   ==>>>   iso-level bi-laplacian operator'
+         END SELECT
+      ENDIF
+      !
+   END SUBROUTINE dyn_ldf_init
+
+   !!======================================================================
+END MODULE dynldf
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DYN/dynldf_iso.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DYN/dynldf_iso.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DYN/dynldf_iso.F90	(revision 9570)
@@ -0,0 +1,403 @@
+MODULE dynldf_iso
+   !!======================================================================
+   !!                     ***  MODULE  dynldf_iso  ***
+   !! Ocean dynamics:   lateral viscosity trend (rotated laplacian operator)
+   !!======================================================================
+   !! History :  OPA  !  97-07  (G. Madec)  Original code
+   !!  NEMO      1.0  !  2002-08  (G. Madec)  F90: Free form and module
+   !!             -   !  2004-08  (C. Talandier) New trends organization
+   !!            2.0  !  2005-11  (G. Madec)  s-coordinate: horizontal diffusion
+   !!            3.7  !  2014-01  (F. Lemarie, G. Madec)  restructuration/simplification of ahm specification,
+   !!                 !                                   add velocity dependent coefficient and optional read in file
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   dyn_ldf_iso  : update the momentum trend with the horizontal part
+   !!                  of the lateral diffusion using isopycnal or horizon-
+   !!                  tal s-coordinate laplacian operator.
+   !!----------------------------------------------------------------------
+   USE oce             ! ocean dynamics and tracers
+   USE dom_oce         ! ocean space and time domain
+   USE ldfdyn          ! lateral diffusion: eddy viscosity coef.
+   USE ldftra          ! lateral physics: eddy diffusivity
+   USE zdf_oce         ! ocean vertical physics
+   USE ldfslp          ! iso-neutral slopes 
+   !
+   USE in_out_manager  ! I/O manager
+   USE lib_mpp         ! MPP library
+   USE lbclnk          ! ocean lateral boundary conditions (or mpp link)
+   USE prtctl          ! Print control
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   dyn_ldf_iso           ! called by step.F90
+   PUBLIC   dyn_ldf_iso_alloc     ! called by nemogcm.F90
+
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   akzu, akzv   !: vertical component of rotated lateral viscosity
+   
+   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: zfuw, zdiu, zdju, zdj1u   ! 2D workspace (dyn_ldf_iso) 
+   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: zfvw, zdiv, zdjv, zdj1v   !  -      -
+
+   !! * Substitutions
+#  include "vectopt_loop_substitute.h90"
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 4.0 , NEMO Consortium (2017)
+   !! $Id$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   INTEGER FUNCTION dyn_ldf_iso_alloc()
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE dyn_ldf_iso_alloc  ***
+      !!----------------------------------------------------------------------
+      ALLOCATE( akzu(jpi,jpj,jpk) , zfuw(jpi,jpk) , zdiu(jpi,jpk) , zdju(jpi,jpk) , zdj1u(jpi,jpk) ,     & 
+         &      akzv(jpi,jpj,jpk) , zfvw(jpi,jpk) , zdiv(jpi,jpk) , zdjv(jpi,jpk) , zdj1v(jpi,jpk) , STAT=dyn_ldf_iso_alloc )
+         !
+      IF( dyn_ldf_iso_alloc /= 0 )   CALL ctl_warn('dyn_ldf_iso_alloc: array allocate failed.')
+   END FUNCTION dyn_ldf_iso_alloc
+
+
+   SUBROUTINE dyn_ldf_iso( kt )
+      !!----------------------------------------------------------------------
+      !!                     ***  ROUTINE dyn_ldf_iso  ***
+      !!                       
+      !! ** Purpose :   Compute the before trend of the rotated laplacian
+      !!      operator of lateral momentum diffusion except the diagonal
+      !!      vertical term that will be computed in dynzdf module. Add it
+      !!      to the general trend of momentum equation.
+      !!
+      !! ** Method :
+      !!        The momentum lateral diffusive trend is provided by a 2nd
+      !!      order operator rotated along neutral or geopotential surfaces
+      !!      (in s-coordinates).
+      !!      It is computed using before fields (forward in time) and isopyc-
+      !!      nal or geopotential slopes computed in routine ldfslp.
+      !!      Here, u and v components are considered as 2 independent scalar
+      !!      fields. Therefore, the property of splitting divergent and rota-
+      !!      tional part of the flow of the standard, z-coordinate laplacian
+      !!      momentum diffusion is lost.
+      !!      horizontal fluxes associated with the rotated lateral mixing:
+      !!      u-component:
+      !!         ziut = ( ahmt + rn_ahm_b ) e2t * e3t / e1t  di[ ub ]
+      !!               -  ahmt              e2t * mi-1(uslp) dk[ mi(mk(ub)) ]
+      !!         zjuf = ( ahmf + rn_ahm_b ) e1f * e3f / e2f  dj[ ub ]
+      !!               -  ahmf              e1f * mi(vslp)   dk[ mj(mk(ub)) ]
+      !!      v-component:
+      !!         zivf = ( ahmf + rn_ahm_b ) e2t * e3t / e1t  di[ vb ]
+      !!               -  ahmf              e2t * mj(uslp)   dk[ mi(mk(vb)) ]
+      !!         zjvt = ( ahmt + rn_ahm_b ) e1f * e3f / e2f  dj[ ub ]
+      !!               -  ahmt              e1f * mj-1(vslp) dk[ mj(mk(vb)) ]
+      !!      take the horizontal divergence of the fluxes:
+      !!         diffu = 1/(e1u*e2u*e3u) {  di  [ ziut ] + dj-1[ zjuf ]  }
+      !!         diffv = 1/(e1v*e2v*e3v) {  di-1[ zivf ] + dj  [ zjvt ]  }
+      !!      Add this trend to the general trend (ua,va):
+      !!         ua = ua + diffu
+      !!      CAUTION: here the isopycnal part is with a coeff. of aht. This
+      !!      should be modified for applications others than orca_r2 (!!bug)
+      !!
+      !! ** Action :
+      !!       -(ua,va) updated with the before geopotential harmonic mixing trend
+      !!       -(akzu,akzv) to accompt for the diagonal vertical component
+      !!                    of the rotated operator in dynzdf module
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT( in ) ::   kt   ! ocean time-step index
+      !
+      INTEGER  ::   ji, jj, jk   ! dummy loop indices
+      REAL(wp) ::   zabe1, zmskt, zmkt, zuav, zuwslpi, zuwslpj   ! local scalars
+      REAL(wp) ::   zabe2, zmskf, zmkf, zvav, zvwslpi, zvwslpj   !   -      -
+      REAL(wp) ::   zcof0, zcof1, zcof2, zcof3, zcof4, zaht_0    !   -      -
+      REAL(wp), DIMENSION(jpi,jpj) ::   ziut, zivf, zdku, zdk1u  ! 2D workspace
+      REAL(wp), DIMENSION(jpi,jpj) ::   zjuf, zjvt, zdkv, zdk1v  !  -      -
+      !!----------------------------------------------------------------------
+      !
+      IF( kt == nit000 ) THEN
+         IF(lwp) WRITE(numout,*)
+         IF(lwp) WRITE(numout,*) 'dyn_ldf_iso : iso-neutral laplacian diffusive operator or '
+         IF(lwp) WRITE(numout,*) '~~~~~~~~~~~   s-coordinate horizontal diffusive operator'
+         !                                      ! allocate dyn_ldf_bilap arrays
+         IF( dyn_ldf_iso_alloc() /= 0 )   CALL ctl_stop('STOP', 'dyn_ldf_iso: failed to allocate arrays')
+      ENDIF
+
+!!gm bug is dyn_ldf_iso called before tra_ldf_iso ....   <<<<<===== TO BE CHECKED
+      ! s-coordinate: Iso-level diffusion on momentum but not on tracer
+      IF( ln_dynldf_hor .AND. ln_traldf_iso ) THEN
+         !
+         DO jk = 1, jpk         ! set the slopes of iso-level
+            DO jj = 2, jpjm1
+               DO ji = 2, jpim1
+                  uslp (ji,jj,jk) = - ( gdept_b(ji+1,jj,jk) - gdept_b(ji ,jj ,jk) ) * r1_e1u(ji,jj) * umask(ji,jj,jk)
+                  vslp (ji,jj,jk) = - ( gdept_b(ji,jj+1,jk) - gdept_b(ji ,jj ,jk) ) * r1_e2v(ji,jj) * vmask(ji,jj,jk)
+                  wslpi(ji,jj,jk) = - ( gdepw_b(ji+1,jj,jk) - gdepw_b(ji-1,jj,jk) ) * r1_e1t(ji,jj) * tmask(ji,jj,jk) * 0.5
+                  wslpj(ji,jj,jk) = - ( gdepw_b(ji,jj+1,jk) - gdepw_b(ji,jj-1,jk) ) * r1_e2t(ji,jj) * tmask(ji,jj,jk) * 0.5
+               END DO
+            END DO
+         END DO
+         ! Lateral boundary conditions on the slopes
+         CALL lbc_lnk_multi( uslp , 'U', -1., vslp , 'V', -1., wslpi, 'W', -1., wslpj, 'W', -1. )
+         !
+       ENDIF
+         
+      zaht_0 = 0.5_wp * rn_Ud * rn_Ld                  ! aht_0 from namtra_ldf = zaht_max
+      
+      !                                                ! ===============
+      DO jk = 1, jpkm1                                 ! Horizontal slab
+         !                                             ! ===============
+
+         ! Vertical u- and v-shears at level jk and jk+1
+         ! ---------------------------------------------
+         ! surface boundary condition: zdku(jk=1)=zdku(jk=2)
+         !                             zdkv(jk=1)=zdkv(jk=2)
+
+         zdk1u(:,:) = ( ub(:,:,jk) -ub(:,:,jk+1) ) * umask(:,:,jk+1)
+         zdk1v(:,:) = ( vb(:,:,jk) -vb(:,:,jk+1) ) * vmask(:,:,jk+1)
+
+         IF( jk == 1 ) THEN
+            zdku(:,:) = zdk1u(:,:)
+            zdkv(:,:) = zdk1v(:,:)
+         ELSE
+            zdku(:,:) = ( ub(:,:,jk-1) - ub(:,:,jk) ) * umask(:,:,jk)
+            zdkv(:,:) = ( vb(:,:,jk-1) - vb(:,:,jk) ) * vmask(:,:,jk)
+         ENDIF
+
+         !                               -----f-----
+         ! Horizontal fluxes on U             |  
+         ! --------------------===        t   u   t
+         !                                    |  
+         ! i-flux at t-point             -----f-----
+
+         IF( ln_zps ) THEN      ! z-coordinate - partial steps : min(e3u)
+            DO jj = 2, jpjm1
+               DO ji = fs_2, jpi   ! vector opt.
+                  zabe1 = ( ahmt(ji,jj,jk)+rn_ahm_b ) * e2t(ji,jj) * MIN( e3u_n(ji,jj,jk), e3u_n(ji-1,jj,jk) ) * r1_e1t(ji,jj)
+
+                  zmskt = 1._wp / MAX(   umask(ji-1,jj,jk  )+umask(ji,jj,jk+1)     &
+                     &                 + umask(ji-1,jj,jk+1)+umask(ji,jj,jk  ) , 1._wp )
+
+                  zcof1 = - zaht_0 * e2t(ji,jj) * zmskt * 0.5  * ( uslp(ji-1,jj,jk) + uslp(ji,jj,jk) )
+   
+                  ziut(ji,jj) = (  zabe1 * ( ub(ji,jj,jk) - ub(ji-1,jj,jk) )    &
+                     &           + zcof1 * ( zdku (ji,jj) + zdk1u(ji-1,jj)      &
+                     &                      +zdk1u(ji,jj) + zdku (ji-1,jj) )  ) * tmask(ji,jj,jk)
+               END DO
+            END DO
+         ELSE                   ! other coordinate system (zco or sco) : e3t
+            DO jj = 2, jpjm1
+               DO ji = fs_2, jpi   ! vector opt.
+                  zabe1 = ( ahmt(ji,jj,jk)+rn_ahm_b ) * e2t(ji,jj) * e3t_n(ji,jj,jk) * r1_e1t(ji,jj)
+
+                  zmskt = 1._wp / MAX(   umask(ji-1,jj,jk  ) + umask(ji,jj,jk+1)     &
+                     &                 + umask(ji-1,jj,jk+1) + umask(ji,jj,jk  ) , 1._wp )
+
+                  zcof1 = - zaht_0 * e2t(ji,jj) * zmskt * 0.5  * ( uslp(ji-1,jj,jk) + uslp(ji,jj,jk) )
+
+                  ziut(ji,jj) = (  zabe1 * ( ub(ji,jj,jk) - ub(ji-1,jj,jk) )   &
+                     &           + zcof1 * ( zdku (ji,jj) + zdk1u(ji-1,jj)     &
+                     &                      +zdk1u(ji,jj) + zdku (ji-1,jj) )  ) * tmask(ji,jj,jk)
+               END DO
+            END DO
+         ENDIF
+
+         ! j-flux at f-point
+         DO jj = 1, jpjm1
+            DO ji = 1, fs_jpim1   ! vector opt.
+               zabe2 = ( ahmf(ji,jj,jk) + rn_ahm_b ) * e1f(ji,jj) * e3f_n(ji,jj,jk) * r1_e2f(ji,jj)
+
+               zmskf = 1._wp / MAX(   umask(ji,jj+1,jk  )+umask(ji,jj,jk+1)     &
+                  &                 + umask(ji,jj+1,jk+1)+umask(ji,jj,jk  ) , 1._wp )
+
+               zcof2 = - zaht_0 * e1f(ji,jj) * zmskf * 0.5  * ( vslp(ji+1,jj,jk) + vslp(ji,jj,jk) )
+
+               zjuf(ji,jj) = (  zabe2 * ( ub(ji,jj+1,jk) - ub(ji,jj,jk) )   &
+                  &           + zcof2 * ( zdku (ji,jj+1) + zdk1u(ji,jj)     &
+                  &                      +zdk1u(ji,jj+1) + zdku (ji,jj) )  ) * fmask(ji,jj,jk)
+            END DO
+         END DO
+
+         !                                |   t   |
+         ! Horizontal fluxes on V         |       |
+         ! --------------------===        f---v---f
+         !                                |       |
+         ! i-flux at f-point              |   t   |
+
+         DO jj = 2, jpjm1
+            DO ji = 1, fs_jpim1   ! vector opt.
+               zabe1 = ( ahmf(ji,jj,jk) + rn_ahm_b ) * e2f(ji,jj) * e3f_n(ji,jj,jk) * r1_e1f(ji,jj)
+
+               zmskf = 1._wp / MAX(  vmask(ji+1,jj,jk  )+vmask(ji,jj,jk+1)     &
+                  &                + vmask(ji+1,jj,jk+1)+vmask(ji,jj,jk  ) , 1._wp )
+
+               zcof1 = - zaht_0 * e2f(ji,jj) * zmskf * 0.5 * ( uslp(ji,jj+1,jk) + uslp(ji,jj,jk) )
+
+               zivf(ji,jj) = (  zabe1 * ( vb(ji+1,jj,jk) - vb(ji,jj,jk) )    &
+                  &           + zcof1 * (  zdkv (ji,jj) + zdk1v(ji+1,jj)      &
+                  &                      + zdk1v(ji,jj) + zdkv (ji+1,jj) )  ) * fmask(ji,jj,jk)
+            END DO
+         END DO
+
+         ! j-flux at t-point
+         IF( ln_zps ) THEN      ! z-coordinate - partial steps : min(e3u)
+            DO jj = 2, jpj
+               DO ji = 1, fs_jpim1   ! vector opt.
+                  zabe2 = ( ahmt(ji,jj,jk)+rn_ahm_b ) * e1t(ji,jj) * MIN( e3v_n(ji,jj,jk), e3v_n(ji,jj-1,jk) ) * r1_e2t(ji,jj)
+
+                  zmskt = 1._wp / MAX(  vmask(ji,jj-1,jk  )+vmask(ji,jj,jk+1)     &
+                     &                + vmask(ji,jj-1,jk+1)+vmask(ji,jj,jk  ) , 1._wp )
+
+                  zcof2 = - zaht_0 * e1t(ji,jj) * zmskt * 0.5 * ( vslp(ji,jj-1,jk) + vslp(ji,jj,jk) )
+
+                  zjvt(ji,jj) = (  zabe2 * ( vb(ji,jj,jk) - vb(ji,jj-1,jk) )    &
+                     &           + zcof2 * ( zdkv (ji,jj-1) + zdk1v(ji,jj)      &
+                     &                      +zdk1v(ji,jj-1) + zdkv (ji,jj) )  ) * tmask(ji,jj,jk)
+               END DO
+            END DO
+         ELSE                   ! other coordinate system (zco or sco) : e3t
+            DO jj = 2, jpj
+               DO ji = 1, fs_jpim1   ! vector opt.
+                  zabe2 = ( ahmt(ji,jj,jk)+rn_ahm_b ) * e1t(ji,jj) * e3t_n(ji,jj,jk) * r1_e2t(ji,jj)
+
+                  zmskt = 1./MAX(  vmask(ji,jj-1,jk  )+vmask(ji,jj,jk+1)   &
+                     &           + vmask(ji,jj-1,jk+1)+vmask(ji,jj,jk  ), 1. )
+
+                  zcof2 = - zaht_0 * e1t(ji,jj) * zmskt * 0.5 * ( vslp(ji,jj-1,jk) + vslp(ji,jj,jk) )
+
+                  zjvt(ji,jj) = (  zabe2 * ( vb(ji,jj,jk) - vb(ji,jj-1,jk) )   &
+                     &           + zcof2 * ( zdkv (ji,jj-1) + zdk1v(ji,jj)     &
+                     &                      +zdk1v(ji,jj-1) + zdkv (ji,jj) )  ) * tmask(ji,jj,jk)
+               END DO
+            END DO
+         ENDIF
+
+
+         ! Second derivative (divergence) and add to the general trend
+         ! -----------------------------------------------------------
+         DO jj = 2, jpjm1
+            DO ji = 2, jpim1          !!gm Question vectop possible??? !!bug
+               ua(ji,jj,jk) = ua(ji,jj,jk) + (  ziut(ji+1,jj) - ziut(ji,jj  )    &
+                  &                           + zjuf(ji  ,jj) - zjuf(ji,jj-1)  ) * r1_e1e2u(ji,jj) / e3u_n(ji,jj,jk)
+               va(ji,jj,jk) = va(ji,jj,jk) + (  zivf(ji,jj  ) - zivf(ji-1,jj)    &
+                  &                           + zjvt(ji,jj+1) - zjvt(ji,jj  )  ) * r1_e1e2v(ji,jj) / e3v_n(ji,jj,jk)
+            END DO
+         END DO
+         !                                             ! ===============
+      END DO                                           !   End of slab
+      !                                                ! ===============
+
+      ! print sum trends (used for debugging)
+      IF(ln_ctl)   CALL prt_ctl( tab3d_1=ua, clinfo1=' ldfh - Ua: ', mask1=umask, &
+         &                       tab3d_2=va, clinfo2=       ' Va: ', mask2=vmask, clinfo3='dyn' )
+
+
+      !                                                ! ===============
+      DO jj = 2, jpjm1                                 !  Vertical slab
+         !                                             ! ===============
+
+ 
+         ! I. vertical trends associated with the lateral mixing
+         ! =====================================================
+         !  (excluding the vertical flux proportional to dk[t]
+
+
+         ! I.1 horizontal momentum gradient
+         ! --------------------------------
+
+         DO jk = 1, jpk
+            DO ji = 2, jpi
+               ! i-gradient of u at jj
+               zdiu (ji,jk) = tmask(ji,jj  ,jk) * ( ub(ji,jj  ,jk) - ub(ji-1,jj  ,jk) )
+               ! j-gradient of u and v at jj
+               zdju (ji,jk) = fmask(ji,jj  ,jk) * ( ub(ji,jj+1,jk) - ub(ji  ,jj  ,jk) )
+               zdjv (ji,jk) = tmask(ji,jj  ,jk) * ( vb(ji,jj  ,jk) - vb(ji  ,jj-1,jk) )
+               ! j-gradient of u and v at jj+1
+               zdj1u(ji,jk) = fmask(ji,jj-1,jk) * ( ub(ji,jj  ,jk) - ub(ji  ,jj-1,jk) )
+               zdj1v(ji,jk) = tmask(ji,jj+1,jk) * ( vb(ji,jj+1,jk) - vb(ji  ,jj  ,jk) )
+            END DO
+         END DO
+         DO jk = 1, jpk
+            DO ji = 1, jpim1
+               ! i-gradient of v at jj
+               zdiv (ji,jk) = fmask(ji,jj  ,jk) * ( vb(ji+1,jj,jk) - vb(ji  ,jj  ,jk) )
+            END DO
+         END DO
+
+
+         ! I.2 Vertical fluxes
+         ! -------------------
+
+         ! Surface and bottom vertical fluxes set to zero
+         DO ji = 1, jpi
+            zfuw(ji, 1 ) = 0.e0
+            zfvw(ji, 1 ) = 0.e0
+            zfuw(ji,jpk) = 0.e0
+            zfvw(ji,jpk) = 0.e0
+         END DO
+
+         ! interior (2=<jk=<jpk-1) on U field
+         DO jk = 2, jpkm1
+            DO ji = 2, jpim1
+               zcof0 = 0.5_wp * zaht_0 * umask(ji,jj,jk)
+               !
+               zuwslpi = zcof0 * ( wslpi(ji+1,jj,jk) + wslpi(ji,jj,jk) )
+               zuwslpj = zcof0 * ( wslpj(ji+1,jj,jk) + wslpj(ji,jj,jk) )
+               !
+               zmkt = 1./MAX(  tmask(ji,jj,jk-1)+tmask(ji+1,jj,jk-1)      &
+                             + tmask(ji,jj,jk  )+tmask(ji+1,jj,jk  ) , 1. )
+               zmkf = 1./MAX(  fmask(ji,jj-1,jk-1) + fmask(ji,jj,jk-1)      &
+                             + fmask(ji,jj-1,jk  ) + fmask(ji,jj,jk  ) , 1. )
+
+               zcof3 = - e2u(ji,jj) * zmkt * zuwslpi
+               zcof4 = - e1u(ji,jj) * zmkf * zuwslpj
+               ! vertical flux on u field
+               zfuw(ji,jk) = zcof3 * (  zdiu (ji,jk-1) + zdiu (ji+1,jk-1)      &
+                  &                   + zdiu (ji,jk  ) + zdiu (ji+1,jk  )  )   &
+                  &        + zcof4 * (  zdj1u(ji,jk-1) + zdju (ji  ,jk-1)      &
+                  &                   + zdj1u(ji,jk  ) + zdju (ji  ,jk  )  )
+               ! vertical mixing coefficient (akzu)
+               ! Note: zcof0 include zaht_0, so divided by zaht_0 to obtain slp^2 * zaht_0
+               akzu(ji,jj,jk) = ( zuwslpi * zuwslpi + zuwslpj * zuwslpj ) / zaht_0
+            END DO
+         END DO
+
+         ! interior (2=<jk=<jpk-1) on V field
+         DO jk = 2, jpkm1
+            DO ji = 2, jpim1
+               zcof0 = 0.5_wp * zaht_0 * vmask(ji,jj,jk)
+               !
+               zvwslpi = zcof0 * ( wslpi(ji,jj+1,jk) + wslpi(ji,jj,jk) )
+               zvwslpj = zcof0 * ( wslpj(ji,jj+1,jk) + wslpj(ji,jj,jk) )
+               !
+               zmkf = 1./MAX(  fmask(ji-1,jj,jk-1)+fmask(ji,jj,jk-1)      &
+                  &          + fmask(ji-1,jj,jk  )+fmask(ji,jj,jk  ) , 1. )
+               zmkt = 1./MAX(  tmask(ji,jj,jk-1)+tmask(ji,jj+1,jk-1)      &
+                  &          + tmask(ji,jj,jk  )+tmask(ji,jj+1,jk  ) , 1. )
+
+               zcof3 = - e2v(ji,jj) * zmkf * zvwslpi
+               zcof4 = - e1v(ji,jj) * zmkt * zvwslpj
+               ! vertical flux on v field
+               zfvw(ji,jk) = zcof3 * (  zdiv (ji,jk-1) + zdiv (ji-1,jk-1)      &
+                  &                   + zdiv (ji,jk  ) + zdiv (ji-1,jk  )  )   &
+                  &        + zcof4 * (  zdjv (ji,jk-1) + zdj1v(ji  ,jk-1)      &
+                  &                   + zdjv (ji,jk  ) + zdj1v(ji  ,jk  )  )
+               ! vertical mixing coefficient (akzv)
+               ! Note: zcof0 include zaht_0, so divided by zaht_0 to obtain slp^2 * zaht_0
+               akzv(ji,jj,jk) = ( zvwslpi * zvwslpi + zvwslpj * zvwslpj ) / zaht_0
+            END DO
+         END DO
+
+
+         ! I.3 Divergence of vertical fluxes added to the general tracer trend
+         ! -------------------------------------------------------------------
+         DO jk = 1, jpkm1
+            DO ji = 2, jpim1
+               ua(ji,jj,jk) = ua(ji,jj,jk) + ( zfuw(ji,jk) - zfuw(ji,jk+1) ) * r1_e1e2u(ji,jj) / e3u_n(ji,jj,jk)
+               va(ji,jj,jk) = va(ji,jj,jk) + ( zfvw(ji,jk) - zfvw(ji,jk+1) ) * r1_e1e2v(ji,jj) / e3v_n(ji,jj,jk)
+            END DO
+         END DO
+         !                                             ! ===============
+      END DO                                           !   End of slab
+      !                                                ! ===============
+   END SUBROUTINE dyn_ldf_iso
+
+   !!======================================================================
+END MODULE dynldf_iso
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DYN/dynldf_lap_blp.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DYN/dynldf_lap_blp.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DYN/dynldf_lap_blp.F90	(revision 9570)
@@ -0,0 +1,145 @@
+MODULE dynldf_lap_blp
+   !!======================================================================
+   !!                   ***  MODULE  dynldf_lap_blp  ***
+   !! Ocean dynamics:  lateral viscosity trend (laplacian and bilaplacian)
+   !!======================================================================
+   !! History : 3.7  ! 2014-01  (G. Madec, S. Masson)  Original code, re-entrant laplacian
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   dyn_ldf_lap   : update the momentum trend with the lateral viscosity using an iso-level   laplacian operator
+   !!   dyn_ldf_blp   : update the momentum trend with the lateral viscosity using an iso-level bilaplacian operator
+   !!----------------------------------------------------------------------
+   USE oce            ! ocean dynamics and tracers
+   USE dom_oce        ! ocean space and time domain
+   USE ldfdyn         ! lateral diffusion: eddy viscosity coef.
+   USE ldfslp         ! iso-neutral slopes 
+   USE zdf_oce        ! ocean vertical physics
+   !
+   USE in_out_manager ! I/O manager
+   USE lbclnk         ! ocean lateral boundary conditions (or mpp link)
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC dyn_ldf_lap  ! called by dynldf.F90
+   PUBLIC dyn_ldf_blp  ! called by dynldf.F90
+
+   !! * Substitutions
+#  include "vectopt_loop_substitute.h90"
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 4.0 , NEMO Consortium (2017)
+   !! $Id$ 
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE dyn_ldf_lap( kt, pub, pvb, pua, pva, kpass )
+      !!----------------------------------------------------------------------
+      !!                     ***  ROUTINE dyn_ldf_lap  ***
+      !!                       
+      !! ** Purpose :   Compute the before horizontal momentum diffusive 
+      !!      trend and add it to the general trend of momentum equation.
+      !!
+      !! ** Method  :   The Laplacian operator apply on horizontal velocity is 
+      !!      writen as :   grad_h( ahmt div_h(U )) - curl_h( ahmf curl_z(U) ) 
+      !!
+      !! ** Action : - pua, pva increased by the harmonic operator applied on pub, pvb.
+      !!----------------------------------------------------------------------
+      INTEGER                         , INTENT(in   ) ::   kt         ! ocean time-step index
+      INTEGER                         , INTENT(in   ) ::   kpass      ! =1/2 first or second passage
+      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in   ) ::   pub, pvb   ! before velocity  [m/s]
+      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pua, pva   ! velocity trend   [m/s2]
+      !
+      INTEGER  ::   ji, jj, jk   ! dummy loop indices
+      REAL(wp) ::   zsign        ! local scalars
+      REAL(wp) ::   zua, zva     ! local scalars
+      REAL(wp), DIMENSION(jpi,jpj) ::   zcur, zdiv
+      !!----------------------------------------------------------------------
+      !
+      IF( kt == nit000 .AND. lwp ) THEN
+         WRITE(numout,*)
+         WRITE(numout,*) 'dyn_ldf : iso-level harmonic (laplacian) operator, pass=', kpass
+         WRITE(numout,*) '~~~~~~~ '
+      ENDIF
+      !
+      IF( kpass == 1 ) THEN   ;   zsign =  1._wp      ! bilaplacian operator require a minus sign
+      ELSE                    ;   zsign = -1._wp      !  (eddy viscosity coef. >0)
+      ENDIF
+      !
+      !                                                ! ===============
+      DO jk = 1, jpkm1                                 ! Horizontal slab
+         !                                             ! ===============
+         DO jj = 2, jpj
+            DO ji = fs_2, jpi   ! vector opt.
+               !                                      ! ahm * e3 * curl  (computed from 1 to jpim1/jpjm1)
+!!gm open question here : e3f  at before or now ?    probably now...
+!!gm note that ahmf has already been multiplied by fmask
+               zcur(ji-1,jj-1) = ahmf(ji-1,jj-1,jk) * e3f_n(ji-1,jj-1,jk) * r1_e1e2f(ji-1,jj-1)       &
+                  &     * (  e2v(ji  ,jj-1) * pvb(ji  ,jj-1,jk) - e2v(ji-1,jj-1) * pvb(ji-1,jj-1,jk)  &
+                  &        - e1u(ji-1,jj  ) * pub(ji-1,jj  ,jk) + e1u(ji-1,jj-1) * pub(ji-1,jj-1,jk)  )
+               !                                      ! ahm * div        (computed from 2 to jpi/jpj)
+!!gm note that ahmt has already been multiplied by tmask
+               zdiv(ji,jj)     = ahmt(ji,jj,jk) * r1_e1e2t(ji,jj) / e3t_b(ji,jj,jk)                                         &
+                  &     * (  e2u(ji,jj)*e3u_b(ji,jj,jk) * pub(ji,jj,jk) - e2u(ji-1,jj)*e3u_b(ji-1,jj,jk) * pub(ji-1,jj,jk)  &
+                  &        + e1v(ji,jj)*e3v_b(ji,jj,jk) * pvb(ji,jj,jk) - e1v(ji,jj-1)*e3v_b(ji,jj-1,jk) * pvb(ji,jj-1,jk)  )
+            END DO  
+         END DO  
+         !
+         DO jj = 2, jpjm1                             ! - curl( curl) + grad( div )
+            DO ji = fs_2, fs_jpim1   ! vector opt.
+               pua(ji,jj,jk) = pua(ji,jj,jk) + zsign * (                                                 &
+                  &              - ( zcur(ji  ,jj) - zcur(ji,jj-1) ) * r1_e2u(ji,jj) / e3u_n(ji,jj,jk)   &
+                  &              + ( zdiv(ji+1,jj) - zdiv(ji,jj  ) ) * r1_e1u(ji,jj)                     )
+                  !
+               pva(ji,jj,jk) = pva(ji,jj,jk) + zsign * (                                                 &
+                  &                ( zcur(ji,jj  ) - zcur(ji-1,jj) ) * r1_e1v(ji,jj) / e3v_n(ji,jj,jk)   &
+                  &              + ( zdiv(ji,jj+1) - zdiv(ji  ,jj) ) * r1_e2v(ji,jj)                     )
+            END DO
+         END DO
+         !                                             ! ===============
+      END DO                                           !   End of slab
+      !                                                ! ===============
+      !
+   END SUBROUTINE dyn_ldf_lap
+
+
+   SUBROUTINE dyn_ldf_blp( kt, pub, pvb, pua, pva )
+      !!----------------------------------------------------------------------
+      !!                 ***  ROUTINE dyn_ldf_blp  ***
+      !!                    
+      !! ** Purpose :   Compute the before lateral momentum viscous trend 
+      !!              and add it to the general trend of momentum equation.
+      !!
+      !! ** Method  :   The lateral viscous trends is provided by a bilaplacian
+      !!      operator applied to before field (forward in time).
+      !!      It is computed by two successive calls to dyn_ldf_lap routine
+      !!
+      !! ** Action :   pta   updated with the before rotated bilaplacian diffusion
+      !!----------------------------------------------------------------------
+      INTEGER                         , INTENT(in   ) ::   kt         ! ocean time-step index
+      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in   ) ::   pub, pvb   ! before velocity fields
+      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pua, pva   ! momentum trend
+      !
+      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zulap, zvlap   ! laplacian at u- and v-point
+      !!----------------------------------------------------------------------
+      !
+      IF( kt == nit000 )  THEN
+         IF(lwp) WRITE(numout,*)
+         IF(lwp) WRITE(numout,*) 'dyn_ldf_blp : bilaplacian operator momentum '
+         IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~'
+      ENDIF
+      !
+      zulap(:,:,:) = 0._wp
+      zvlap(:,:,:) = 0._wp
+      !
+      CALL dyn_ldf_lap( kt, pub, pvb, zulap, zvlap, 1 )   ! rotated laplacian applied to ptb (output in zlap)
+      !
+      CALL lbc_lnk_multi( zulap, 'U', -1., zvlap, 'V', -1. )             ! Lateral boundary conditions
+      !
+      CALL dyn_ldf_lap( kt, zulap, zvlap, pua, pva, 2 )   ! rotated laplacian applied to zlap (output in pta)
+      !
+   END SUBROUTINE dyn_ldf_blp
+
+   !!======================================================================
+END MODULE dynldf_lap_blp
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DYN/dynnxt.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DYN/dynnxt.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DYN/dynnxt.F90	(revision 9570)
@@ -0,0 +1,377 @@
+MODULE dynnxt
+   !!=========================================================================
+   !!                       ***  MODULE  dynnxt  ***
+   !! Ocean dynamics: time stepping
+   !!=========================================================================
+   !! History :  OPA  !  1987-02  (P. Andrich, D. L Hostis)  Original code
+   !!                 !  1990-10  (C. Levy, G. Madec)
+   !!            7.0  !  1993-03  (M. Guyon)  symetrical conditions
+   !!            8.0  !  1997-02  (G. Madec & M. Imbard)  opa, release 8.0
+   !!            8.2  !  1997-04  (A. Weaver)  Euler forward step
+   !!             -   !  1997-06  (G. Madec)  lateral boudary cond., lbc routine
+   !!    NEMO    1.0  !  2002-08  (G. Madec)  F90: Free form and module
+   !!             -   !  2002-10  (C. Talandier, A-M. Treguier) Open boundary cond.
+   !!            2.0  !  2005-11  (V. Garnier) Surface pressure gradient organization
+   !!            2.3  !  2007-07  (D. Storkey) Calls to BDY routines. 
+   !!            3.2  !  2009-06  (G. Madec, R.Benshila)  re-introduce the vvl option
+   !!            3.3  !  2010-09  (D. Storkey, E.O'Dea) Bug fix for BDY module
+   !!            3.3  !  2011-03  (P. Oddo) Bug fix for time-splitting+(BDY-OBC) and not VVL
+   !!            3.5  !  2013-07  (J. Chanut) Compliant with time splitting changes
+   !!            3.6  !  2014-04  (G. Madec) add the diagnostic of the time filter trends
+   !!            3.7  !  2015-11  (J. Chanut) Free surface simplification
+   !!-------------------------------------------------------------------------
+  
+   !!-------------------------------------------------------------------------
+   !!   dyn_nxt       : obtain the next (after) horizontal velocity
+   !!-------------------------------------------------------------------------
+   USE oce            ! ocean dynamics and tracers
+   USE dom_oce        ! ocean space and time domain
+   USE sbc_oce        ! Surface boundary condition: ocean fields
+   USE sbcrnf         ! river runoffs
+   USE sbcisf         ! ice shelf
+   USE phycst         ! physical constants
+   USE dynadv         ! dynamics: vector invariant versus flux form
+   USE dynspg_ts      ! surface pressure gradient: split-explicit scheme
+   USE domvvl         ! variable volume
+   USE bdy_oce   , ONLY: ln_bdy
+   USE bdydta         ! ocean open boundary conditions
+   USE bdydyn         ! ocean open boundary conditions
+   USE bdyvol         ! ocean open boundary condition (bdy_vol routines)
+   USE trd_oce        ! trends: ocean variables
+   USE trddyn         ! trend manager: dynamics
+   USE trdken         ! trend manager: kinetic energy
+   !
+   USE in_out_manager ! I/O manager
+   USE iom            ! I/O manager library
+   USE lbclnk         ! lateral boundary condition (or mpp link)
+   USE lib_mpp        ! MPP library
+   USE prtctl         ! Print control
+   USE timing         ! Timing
+#if defined key_agrif
+   USE agrif_oce_interp
+#endif
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC    dyn_nxt   ! routine called by step.F90
+
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 4.0 , NEMO Consortium (2017)
+   !! $Id$ 
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE dyn_nxt ( kt )
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE dyn_nxt  ***
+      !!                   
+      !! ** Purpose :   Finalize after horizontal velocity. Apply the boundary 
+      !!             condition on the after velocity, achieve the time stepping 
+      !!             by applying the Asselin filter on now fields and swapping 
+      !!             the fields.
+      !!
+      !! ** Method  : * Ensure after velocities transport matches time splitting
+      !!             estimate (ln_dynspg_ts=T)
+      !!
+      !!              * Apply lateral boundary conditions on after velocity 
+      !!             at the local domain boundaries through lbc_lnk call,
+      !!             at the one-way open boundaries (ln_bdy=T),
+      !!             at the AGRIF zoom   boundaries (lk_agrif=T)
+      !!
+      !!              * Apply the time filter applied and swap of the dynamics
+      !!             arrays to start the next time step:
+      !!                (ub,vb) = (un,vn) + atfp [ (ub,vb) + (ua,va) - 2 (un,vn) ]
+      !!                (un,vn) = (ua,va).
+      !!             Note that with flux form advection and non linear free surface,
+      !!             the time filter is applied on thickness weighted velocity.
+      !!             As a result, dyn_nxt MUST be called after tra_nxt.
+      !!
+      !! ** Action :   ub,vb   filtered before horizontal velocity of next time-step
+      !!               un,vn   now horizontal velocity of next time-step
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT( in ) ::   kt      ! ocean time-step index
+      !
+      INTEGER  ::   ji, jj, jk   ! dummy loop indices
+      INTEGER  ::   ikt          ! local integers
+      REAL(wp) ::   zue3a, zue3n, zue3b, zuf, zcoef    ! local scalars
+      REAL(wp) ::   zve3a, zve3n, zve3b, zvf, z1_2dt   !   -      -
+      REAL(wp), ALLOCATABLE, DIMENSION(:,:)   ::   zue, zve
+      REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) ::   ze3u_f, ze3v_f, zua, zva 
+      !!----------------------------------------------------------------------
+      !
+      IF( ln_timing    )   CALL timing_start('dyn_nxt')
+      IF( ln_dynspg_ts )   ALLOCATE( zue(jpi,jpj)     , zve(jpi,jpj)     )
+      IF( l_trddyn     )   ALLOCATE( zua(jpi,jpj,jpk) , zva(jpi,jpj,jpk) )
+      !
+      IF( kt == nit000 ) THEN
+         IF(lwp) WRITE(numout,*)
+         IF(lwp) WRITE(numout,*) 'dyn_nxt : time stepping'
+         IF(lwp) WRITE(numout,*) '~~~~~~~'
+      ENDIF
+
+      IF ( ln_dynspg_ts ) THEN
+         ! Ensure below that barotropic velocities match time splitting estimate
+         ! Compute actual transport and replace it with ts estimate at "after" time step
+         zue(:,:) = e3u_a(:,:,1) * ua(:,:,1) * umask(:,:,1)
+         zve(:,:) = e3v_a(:,:,1) * va(:,:,1) * vmask(:,:,1)
+         DO jk = 2, jpkm1
+            zue(:,:) = zue(:,:) + e3u_a(:,:,jk) * ua(:,:,jk) * umask(:,:,jk)
+            zve(:,:) = zve(:,:) + e3v_a(:,:,jk) * va(:,:,jk) * vmask(:,:,jk)
+         END DO
+         DO jk = 1, jpkm1
+            ua(:,:,jk) = ( ua(:,:,jk) - zue(:,:) * r1_hu_a(:,:) + ua_b(:,:) ) * umask(:,:,jk)
+            va(:,:,jk) = ( va(:,:,jk) - zve(:,:) * r1_hv_a(:,:) + va_b(:,:) ) * vmask(:,:,jk)
+         END DO
+         !
+         IF( .NOT.ln_bt_fw ) THEN
+            ! Remove advective velocity from "now velocities" 
+            ! prior to asselin filtering     
+            ! In the forward case, this is done below after asselin filtering   
+            ! so that asselin contribution is removed at the same time 
+            DO jk = 1, jpkm1
+               un(:,:,jk) = ( un(:,:,jk) - un_adv(:,:)*r1_hu_n(:,:) + un_b(:,:) )*umask(:,:,jk)
+               vn(:,:,jk) = ( vn(:,:,jk) - vn_adv(:,:)*r1_hv_n(:,:) + vn_b(:,:) )*vmask(:,:,jk)
+            END DO  
+         ENDIF
+      ENDIF
+
+      ! Update after velocity on domain lateral boundaries
+      ! --------------------------------------------------      
+# if defined key_agrif
+      CALL Agrif_dyn( kt )             !* AGRIF zoom boundaries
+# endif
+      !
+      CALL lbc_lnk_multi( ua, 'U', -1., va, 'V', -1. )     !* local domain boundaries
+      !
+      !                                !* BDY open boundaries
+      IF( ln_bdy .AND. ln_dynspg_exp )   CALL bdy_dyn( kt )
+      IF( ln_bdy .AND. ln_dynspg_ts  )   CALL bdy_dyn( kt, dyn3d_only=.true. )
+
+!!$   Do we need a call to bdy_vol here??
+      !
+      IF( l_trddyn ) THEN             ! prepare the atf trend computation + some diagnostics
+         z1_2dt = 1._wp / (2. * rdt)        ! Euler or leap-frog time step 
+         IF( neuler == 0 .AND. kt == nit000 )   z1_2dt = 1._wp / rdt
+         !
+         !                                  ! Kinetic energy and Conversion
+         IF( ln_KE_trd  )   CALL trd_dyn( ua, va, jpdyn_ken, kt )
+         !
+         IF( ln_dyn_trd ) THEN              ! 3D output: total momentum trends
+            zua(:,:,:) = ( ua(:,:,:) - ub(:,:,:) ) * z1_2dt
+            zva(:,:,:) = ( va(:,:,:) - vb(:,:,:) ) * z1_2dt
+            CALL iom_put( "utrd_tot", zua )        ! total momentum trends, except the asselin time filter
+            CALL iom_put( "vtrd_tot", zva )
+         ENDIF
+         !
+         zua(:,:,:) = un(:,:,:)             ! save the now velocity before the asselin filter
+         zva(:,:,:) = vn(:,:,:)             ! (caution: there will be a shift by 1 timestep in the
+         !                                  !  computation of the asselin filter trends)
+      ENDIF
+
+      ! Time filter and swap of dynamics arrays
+      ! ------------------------------------------
+      IF( neuler == 0 .AND. kt == nit000 ) THEN        !* Euler at first time-step: only swap
+         DO jk = 1, jpkm1
+            un(:,:,jk) = ua(:,:,jk)                         ! un <-- ua
+            vn(:,:,jk) = va(:,:,jk)
+         END DO
+         IF( .NOT.ln_linssh ) THEN                          ! e3._b <-- e3._n
+!!gm BUG ????    I don't understand why it is not : e3._n <-- e3._a  
+            DO jk = 1, jpkm1
+!               e3t_b(:,:,jk) = e3t_n(:,:,jk)
+!               e3u_b(:,:,jk) = e3u_n(:,:,jk)
+!               e3v_b(:,:,jk) = e3v_n(:,:,jk)
+               !
+               e3t_n(:,:,jk) = e3t_a(:,:,jk)
+               e3u_n(:,:,jk) = e3u_a(:,:,jk)
+               e3v_n(:,:,jk) = e3v_a(:,:,jk)
+            END DO
+!!gm BUG end
+         ENDIF
+                                                            ! 
+         
+      ELSE                                             !* Leap-Frog : Asselin filter and swap
+         !                                ! =============!
+         IF( ln_linssh ) THEN             ! Fixed volume !
+            !                             ! =============!
+            DO jk = 1, jpkm1                              
+               DO jj = 1, jpj
+                  DO ji = 1, jpi    
+                     zuf = un(ji,jj,jk) + atfp * ( ub(ji,jj,jk) - 2._wp * un(ji,jj,jk) + ua(ji,jj,jk) )
+                     zvf = vn(ji,jj,jk) + atfp * ( vb(ji,jj,jk) - 2._wp * vn(ji,jj,jk) + va(ji,jj,jk) )
+                     !
+                     ub(ji,jj,jk) = zuf                      ! ub <-- filtered velocity
+                     vb(ji,jj,jk) = zvf
+                     un(ji,jj,jk) = ua(ji,jj,jk)             ! un <-- ua
+                     vn(ji,jj,jk) = va(ji,jj,jk)
+                  END DO
+               END DO
+            END DO
+            !                             ! ================!
+         ELSE                             ! Variable volume !
+            !                             ! ================!
+            ! Before scale factor at t-points
+            ! (used as a now filtered scale factor until the swap)
+            ! ----------------------------------------------------
+            DO jk = 1, jpkm1
+               e3t_b(:,:,jk) = e3t_n(:,:,jk) + atfp * ( e3t_b(:,:,jk) - 2._wp * e3t_n(:,:,jk) + e3t_a(:,:,jk) )
+            END DO
+            ! Add volume filter correction: compatibility with tracer advection scheme
+            ! => time filter + conservation correction (only at the first level)
+            zcoef = atfp * rdt * r1_rau0
+
+            e3t_b(:,:,1) = e3t_b(:,:,1) - zcoef * ( emp_b(:,:) - emp(:,:) ) * tmask(:,:,1)
+
+            IF ( ln_rnf ) THEN
+               IF( ln_rnf_depth ) THEN
+                  DO jk = 1, jpkm1 ! Deal with Rivers separetely, as can be through depth too
+                     DO jj = 1, jpj
+                        DO ji = 1, jpi
+                           IF( jk <=  nk_rnf(ji,jj)  ) THEN
+                               e3t_b(ji,jj,jk) =   e3t_b(ji,jj,jk) - zcoef *  ( - rnf_b(ji,jj) + rnf(ji,jj) ) &
+                                      &          * ( e3t_n(ji,jj,jk) / h_rnf(ji,jj) ) * tmask(ji,jj,jk)
+                           ENDIF
+                        ENDDO
+                     ENDDO
+                  ENDDO
+               ELSE
+                  e3t_b(:,:,1) = e3t_b(:,:,1) - zcoef *  ( -rnf_b(:,:) + rnf(:,:))*tmask(:,:,1)
+               ENDIF
+            END IF
+
+            IF ( ln_isf ) THEN   ! if ice shelf melting
+               DO jk = 1, jpkm1 ! Deal with isf separetely, as can be through depth too
+                  DO jj = 1, jpj
+                     DO ji = 1, jpi
+                        IF( misfkt(ji,jj) <= jk .AND. jk <= misfkb(ji,jj) ) THEN
+                           e3t_b(ji,jj,jk) =   e3t_b(ji,jj,jk) - zcoef *  ( fwfisf_b(ji,jj) - fwfisf(ji,jj) ) &
+                                &          * ( e3t_n(ji,jj,jk) * r1_hisf_tbl(ji,jj) ) * tmask(ji,jj,jk)
+                        ENDIF
+                     END DO
+                  END DO
+               END DO
+            END IF
+            !
+            IF( ln_dynadv_vec ) THEN      ! Asselin filter applied on velocity
+               ! Before filtered scale factor at (u/v)-points
+               CALL dom_vvl_interpol( e3t_b(:,:,:), e3u_b(:,:,:), 'U' )
+               CALL dom_vvl_interpol( e3t_b(:,:,:), e3v_b(:,:,:), 'V' )
+               DO jk = 1, jpkm1
+                  DO jj = 1, jpj
+                     DO ji = 1, jpi
+                        zuf = un(ji,jj,jk) + atfp * ( ub(ji,jj,jk) - 2._wp * un(ji,jj,jk) + ua(ji,jj,jk) )
+                        zvf = vn(ji,jj,jk) + atfp * ( vb(ji,jj,jk) - 2._wp * vn(ji,jj,jk) + va(ji,jj,jk) )
+                        !
+                        ub(ji,jj,jk) = zuf                      ! ub <-- filtered velocity
+                        vb(ji,jj,jk) = zvf
+                        un(ji,jj,jk) = ua(ji,jj,jk)             ! un <-- ua
+                        vn(ji,jj,jk) = va(ji,jj,jk)
+                     END DO
+                  END DO
+               END DO
+               !
+            ELSE                          ! Asselin filter applied on thickness weighted velocity
+               !
+               ALLOCATE( ze3u_f(jpi,jpj,jpk) , ze3v_f(jpi,jpj,jpk) )
+               ! Before filtered scale factor at (u/v)-points stored in ze3u_f, ze3v_f
+               CALL dom_vvl_interpol( e3t_b(:,:,:), ze3u_f, 'U' )
+               CALL dom_vvl_interpol( e3t_b(:,:,:), ze3v_f, 'V' )
+               DO jk = 1, jpkm1
+                  DO jj = 1, jpj
+                     DO ji = 1, jpi                  
+                        zue3a = e3u_a(ji,jj,jk) * ua(ji,jj,jk)
+                        zve3a = e3v_a(ji,jj,jk) * va(ji,jj,jk)
+                        zue3n = e3u_n(ji,jj,jk) * un(ji,jj,jk)
+                        zve3n = e3v_n(ji,jj,jk) * vn(ji,jj,jk)
+                        zue3b = e3u_b(ji,jj,jk) * ub(ji,jj,jk)
+                        zve3b = e3v_b(ji,jj,jk) * vb(ji,jj,jk)
+                        !
+                        zuf = ( zue3n + atfp * ( zue3b - 2._wp * zue3n  + zue3a ) ) / ze3u_f(ji,jj,jk)
+                        zvf = ( zve3n + atfp * ( zve3b - 2._wp * zve3n  + zve3a ) ) / ze3v_f(ji,jj,jk)
+                        !
+                        ub(ji,jj,jk) = zuf                     ! ub <-- filtered velocity
+                        vb(ji,jj,jk) = zvf
+                        un(ji,jj,jk) = ua(ji,jj,jk)            ! un <-- ua
+                        vn(ji,jj,jk) = va(ji,jj,jk)
+                     END DO
+                  END DO
+               END DO
+               e3u_b(:,:,1:jpkm1) = ze3u_f(:,:,1:jpkm1)        ! e3u_b <-- filtered scale factor
+               e3v_b(:,:,1:jpkm1) = ze3v_f(:,:,1:jpkm1)
+               !
+               DEALLOCATE( ze3u_f , ze3v_f )
+            ENDIF
+            !
+         ENDIF
+         !
+         IF( ln_dynspg_ts .AND. ln_bt_fw ) THEN
+            ! Revert "before" velocities to time split estimate
+            ! Doing it here also means that asselin filter contribution is removed  
+            zue(:,:) = e3u_b(:,:,1) * ub(:,:,1) * umask(:,:,1)
+            zve(:,:) = e3v_b(:,:,1) * vb(:,:,1) * vmask(:,:,1)    
+            DO jk = 2, jpkm1
+               zue(:,:) = zue(:,:) + e3u_b(:,:,jk) * ub(:,:,jk) * umask(:,:,jk)
+               zve(:,:) = zve(:,:) + e3v_b(:,:,jk) * vb(:,:,jk) * vmask(:,:,jk)    
+            END DO
+            DO jk = 1, jpkm1
+               ub(:,:,jk) = ub(:,:,jk) - (zue(:,:) * r1_hu_n(:,:) - un_b(:,:)) * umask(:,:,jk)
+               vb(:,:,jk) = vb(:,:,jk) - (zve(:,:) * r1_hv_n(:,:) - vn_b(:,:)) * vmask(:,:,jk)
+            END DO
+         ENDIF
+         !
+      ENDIF ! neuler =/0
+      !
+      ! Set "now" and "before" barotropic velocities for next time step:
+      ! JC: Would be more clever to swap variables than to make a full vertical
+      ! integration
+      !
+      !
+      IF(.NOT.ln_linssh ) THEN
+         hu_b(:,:) = e3u_b(:,:,1) * umask(:,:,1)
+         hv_b(:,:) = e3v_b(:,:,1) * vmask(:,:,1)
+         DO jk = 2, jpkm1
+            hu_b(:,:) = hu_b(:,:) + e3u_b(:,:,jk) * umask(:,:,jk)
+            hv_b(:,:) = hv_b(:,:) + e3v_b(:,:,jk) * vmask(:,:,jk)
+         END DO
+         r1_hu_b(:,:) = ssumask(:,:) / ( hu_b(:,:) + 1._wp - ssumask(:,:) )
+         r1_hv_b(:,:) = ssvmask(:,:) / ( hv_b(:,:) + 1._wp - ssvmask(:,:) )
+      ENDIF
+      !
+      un_b(:,:) = e3u_a(:,:,1) * un(:,:,1) * umask(:,:,1)
+      ub_b(:,:) = e3u_b(:,:,1) * ub(:,:,1) * umask(:,:,1)
+      vn_b(:,:) = e3v_a(:,:,1) * vn(:,:,1) * vmask(:,:,1)
+      vb_b(:,:) = e3v_b(:,:,1) * vb(:,:,1) * vmask(:,:,1)
+      DO jk = 2, jpkm1
+         un_b(:,:) = un_b(:,:) + e3u_a(:,:,jk) * un(:,:,jk) * umask(:,:,jk)
+         ub_b(:,:) = ub_b(:,:) + e3u_b(:,:,jk) * ub(:,:,jk) * umask(:,:,jk)
+         vn_b(:,:) = vn_b(:,:) + e3v_a(:,:,jk) * vn(:,:,jk) * vmask(:,:,jk)
+         vb_b(:,:) = vb_b(:,:) + e3v_b(:,:,jk) * vb(:,:,jk) * vmask(:,:,jk)
+      END DO
+      un_b(:,:) = un_b(:,:) * r1_hu_a(:,:)
+      vn_b(:,:) = vn_b(:,:) * r1_hv_a(:,:)
+      ub_b(:,:) = ub_b(:,:) * r1_hu_b(:,:)
+      vb_b(:,:) = vb_b(:,:) * r1_hv_b(:,:)
+      !
+      IF( .NOT.ln_dynspg_ts ) THEN        ! output the barotropic currents
+         CALL iom_put(  "ubar", un_b(:,:) )
+         CALL iom_put(  "vbar", vn_b(:,:) )
+      ENDIF
+      IF( l_trddyn ) THEN                ! 3D output: asselin filter trends on momentum
+         zua(:,:,:) = ( ub(:,:,:) - zua(:,:,:) ) * z1_2dt
+         zva(:,:,:) = ( vb(:,:,:) - zva(:,:,:) ) * z1_2dt
+         CALL trd_dyn( zua, zva, jpdyn_atf, kt )
+      ENDIF
+      !
+      IF(ln_ctl)   CALL prt_ctl( tab3d_1=un, clinfo1=' nxt  - Un: ', mask1=umask,   &
+         &                       tab3d_2=vn, clinfo2=' Vn: '       , mask2=vmask )
+      ! 
+      IF( ln_dynspg_ts )   DEALLOCATE( zue, zve )
+      IF( l_trddyn     )   DEALLOCATE( zua, zva )
+      IF( ln_timing    )   CALL timing_stop('dyn_nxt')
+      !
+   END SUBROUTINE dyn_nxt
+
+   !!=========================================================================
+END MODULE dynnxt
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DYN/dynspg.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DYN/dynspg.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DYN/dynspg.F90	(revision 9570)
@@ -0,0 +1,240 @@
+MODULE dynspg
+   !!======================================================================
+   !!                       ***  MODULE  dynspg  ***
+   !! Ocean dynamics:  surface pressure gradient control
+   !!======================================================================
+   !! History :  1.0  ! 2005-12  (C. Talandier, G. Madec, V. Garnier)  Original code
+   !!            3.2  ! 2009-07  (R. Benshila)  Suppression of rigid-lid option
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   dyn_spg     : update the dynamics trend with surface pressure gradient 
+   !!   dyn_spg_init: initialization, namelist read, and parameters control
+   !!----------------------------------------------------------------------
+   USE oce            ! ocean dynamics and tracers variables
+   USE dom_oce        ! ocean space and time domain variables
+   USE c1d            ! 1D vertical configuration
+   USE phycst         ! physical constants
+   USE sbc_oce        ! surface boundary condition: ocean
+   USE sbc_ice , ONLY : snwice_mass, snwice_mass_b
+   USE sbcapr         ! surface boundary condition: atmospheric pressure
+   USE dynspg_exp     ! surface pressure gradient     (dyn_spg_exp routine)
+   USE dynspg_ts      ! surface pressure gradient     (dyn_spg_ts  routine)
+   USE sbctide        ! 
+   USE updtide        ! 
+   USE trd_oce        ! trends: ocean variables
+   USE trddyn         ! trend manager: dynamics
+   !
+   USE prtctl         ! Print control                     (prt_ctl routine)
+   USE in_out_manager ! I/O manager
+   USE lib_mpp        ! MPP library
+   USE timing         ! Timing
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   dyn_spg        ! routine called by step module
+   PUBLIC   dyn_spg_init   ! routine called by opa module
+
+   INTEGER ::   nspg = 0   ! type of surface pressure gradient scheme defined from lk_dynspg_... 
+
+   !                       ! Parameter to control the surface pressure gradient scheme
+   INTEGER, PARAMETER ::   np_TS  = 1   ! split-explicit time stepping (Time-Splitting)
+   INTEGER, PARAMETER ::   np_EXP = 0   !       explicit time stepping
+   INTEGER, PARAMETER ::   np_NO  =-1   ! no surface pressure gradient, no scheme
+
+   !! * Substitutions
+#  include "vectopt_loop_substitute.h90"
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 4.0 , LODYC-IPSL  (2017)
+   !! $Id$ 
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE dyn_spg( kt )
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE dyn_spg  ***
+      !!
+      !! ** Purpose :   compute surface pressure gradient including the 
+      !!              atmospheric pressure forcing (ln_apr_dyn=T).
+      !!
+      !! ** Method  :   Two schemes:
+      !!              - explicit       : the spg is evaluated at now
+      !!              - split-explicit : a time splitting technique is used
+      !!
+      !!              ln_apr_dyn=T : the atmospheric pressure forcing is applied 
+      !!             as the gradient of the inverse barometer ssh:
+      !!                apgu = - 1/rau0 di[apr] = 0.5*grav di[ssh_ib+ssh_ibb]
+      !!                apgv = - 1/rau0 dj[apr] = 0.5*grav dj[ssh_ib+ssh_ibb]
+      !!             Note that as all external forcing a time averaging over a two rdt
+      !!             period is used to prevent the divergence of odd and even time step.
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT(in) ::   kt   ! ocean time-step index
+      !
+      INTEGER  ::   ji, jj, jk                   ! dummy loop indices
+      REAL(wp) ::   z2dt, zg_2, zintp, zgrau0r, zld   ! local scalars
+      REAL(wp), ALLOCATABLE, DIMENSION(:,:)   ::   zpice
+      REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) ::   ztrdu, ztrdv
+      !!----------------------------------------------------------------------
+      !
+      IF( ln_timing )   CALL timing_start('dyn_spg')
+      !
+      IF( l_trddyn )   THEN                      ! temporary save of ta and sa trends
+         ALLOCATE( ztrdu(jpi,jpj,jpk) , ztrdv(jpi,jpj,jpk) ) 
+         ztrdu(:,:,:) = ua(:,:,:)
+         ztrdv(:,:,:) = va(:,:,:)
+      ENDIF
+      !
+      IF(      ln_apr_dyn                                                &   ! atmos. pressure
+         .OR.  ( .NOT.ln_dynspg_ts .AND. (ln_tide_pot .AND. ln_tide) )   &   ! tide potential (no time slitting)
+         .OR.  ln_ice_embd ) THEN                                            ! embedded sea-ice
+         !
+         DO jj = 2, jpjm1
+            DO ji = fs_2, fs_jpim1   ! vector opt.
+               spgu(ji,jj) = 0._wp
+               spgv(ji,jj) = 0._wp
+            END DO
+         END DO         
+         !
+         IF( ln_apr_dyn .AND. .NOT.ln_dynspg_ts ) THEN   !==  Atmospheric pressure gradient (added later in time-split case) ==!
+            zg_2 = grav * 0.5
+            DO jj = 2, jpjm1                          ! gradient of Patm using inverse barometer ssh
+               DO ji = fs_2, fs_jpim1   ! vector opt.
+                  spgu(ji,jj) = spgu(ji,jj) + zg_2 * (  ssh_ib (ji+1,jj) - ssh_ib (ji,jj)    &
+                     &                                + ssh_ibb(ji+1,jj) - ssh_ibb(ji,jj)  ) * r1_e1u(ji,jj)
+                  spgv(ji,jj) = spgv(ji,jj) + zg_2 * (  ssh_ib (ji,jj+1) - ssh_ib (ji,jj)    &
+                     &                                + ssh_ibb(ji,jj+1) - ssh_ibb(ji,jj)  ) * r1_e2v(ji,jj)
+               END DO
+            END DO
+         ENDIF
+         !
+         !                                    !==  tide potential forcing term  ==!
+         IF( .NOT.ln_dynspg_ts .AND. ( ln_tide_pot .AND. ln_tide )  ) THEN   ! N.B. added directly at sub-time-step in ts-case
+            !
+            CALL upd_tide( kt )                      ! update tide potential
+            !
+            DO jj = 2, jpjm1                         ! add tide potential forcing
+               DO ji = fs_2, fs_jpim1   ! vector opt.
+                  spgu(ji,jj) = spgu(ji,jj) + grav * ( pot_astro(ji+1,jj) - pot_astro(ji,jj) ) * r1_e1u(ji,jj)
+                  spgv(ji,jj) = spgv(ji,jj) + grav * ( pot_astro(ji,jj+1) - pot_astro(ji,jj) ) * r1_e2v(ji,jj)
+               END DO 
+            END DO
+            !
+            IF (ln_scal_load) THEN
+               zld = rn_scal_load * grav
+               DO jj = 2, jpjm1                    ! add scalar approximation for load potential
+                  DO ji = fs_2, fs_jpim1   ! vector opt.
+                     spgu(ji,jj) = spgu(ji,jj) + zld * ( sshn(ji+1,jj) - sshn(ji,jj) ) * r1_e1u(ji,jj)
+                     spgv(ji,jj) = spgv(ji,jj) + zld * ( sshn(ji,jj+1) - sshn(ji,jj) ) * r1_e2v(ji,jj)
+                  END DO 
+               END DO
+            ENDIF
+         ENDIF
+         !
+         IF( ln_ice_embd ) THEN              !== embedded sea ice: Pressure gradient due to snow-ice mass ==!
+            ALLOCATE( zpice(jpi,jpj) )
+            zintp = REAL( MOD( kt-1, nn_fsbc ) ) / REAL( nn_fsbc )
+            zgrau0r     = - grav * r1_rau0
+            zpice(:,:) = (  zintp * snwice_mass(:,:) + ( 1.- zintp ) * snwice_mass_b(:,:)  ) * zgrau0r
+            DO jj = 2, jpjm1
+               DO ji = fs_2, fs_jpim1   ! vector opt.
+                  spgu(ji,jj) = spgu(ji,jj) + ( zpice(ji+1,jj) - zpice(ji,jj) ) * r1_e1u(ji,jj)
+                  spgv(ji,jj) = spgv(ji,jj) + ( zpice(ji,jj+1) - zpice(ji,jj) ) * r1_e2v(ji,jj)
+               END DO
+            END DO
+            DEALLOCATE( zpice )         
+         ENDIF
+         !
+         DO jk = 1, jpkm1                    !== Add all terms to the general trend
+            DO jj = 2, jpjm1
+               DO ji = fs_2, fs_jpim1   ! vector opt.
+                  ua(ji,jj,jk) = ua(ji,jj,jk) + spgu(ji,jj)
+                  va(ji,jj,jk) = va(ji,jj,jk) + spgv(ji,jj)
+               END DO
+            END DO
+         END DO    
+         !
+!!gm add here a call to dyn_trd for ice pressure gradient, the surf pressure trends ????
+         !    
+      ENDIF
+      !
+      SELECT CASE ( nspg )                   !== surface pressure gradient computed and add to the general trend ==!
+      CASE ( np_EXP )   ;   CALL dyn_spg_exp( kt )              ! explicit
+      CASE ( np_TS  )   ;   CALL dyn_spg_ts ( kt )              ! time-splitting
+      END SELECT
+      !                    
+      IF( l_trddyn )   THEN                  ! save the surface pressure gradient trends for further diagnostics
+         ztrdu(:,:,:) = ua(:,:,:) - ztrdu(:,:,:)
+         ztrdv(:,:,:) = va(:,:,:) - ztrdv(:,:,:)
+         CALL trd_dyn( ztrdu, ztrdv, jpdyn_spg, kt )
+         DEALLOCATE( ztrdu , ztrdv ) 
+      ENDIF
+      !                                      ! print mean trends (used for debugging)
+      IF(ln_ctl)   CALL prt_ctl( tab3d_1=ua, clinfo1=' spg  - Ua: ', mask1=umask, &
+         &                       tab3d_2=va, clinfo2=       ' Va: ', mask2=vmask, clinfo3='dyn' )
+      !
+      IF( ln_timing )   CALL timing_stop('dyn_spg')
+      !
+   END SUBROUTINE dyn_spg
+
+
+   SUBROUTINE dyn_spg_init
+      !!---------------------------------------------------------------------
+      !!                  ***  ROUTINE dyn_spg_init  ***
+      !!                
+      !! ** Purpose :   Control the consistency between namelist options for 
+      !!              surface pressure gradient schemes
+      !!----------------------------------------------------------------------
+      INTEGER ::   ioptio, ios   ! local integers
+      !
+      NAMELIST/namdyn_spg/ ln_dynspg_exp       , ln_dynspg_ts,   &
+      &                    ln_bt_fw, ln_bt_av  , ln_bt_auto  ,   &
+      &                    nn_baro , rn_bt_cmax, nn_bt_flt, rn_bt_alpha
+      !!----------------------------------------------------------------------
+      !
+      IF(lwp) THEN
+         WRITE(numout,*)
+         WRITE(numout,*) 'dyn_spg_init : choice of the surface pressure gradient scheme'
+         WRITE(numout,*) '~~~~~~~~~~~~'
+      ENDIF
+      !
+      REWIND( numnam_ref )              ! Namelist namdyn_spg in reference namelist : Free surface
+      READ  ( numnam_ref, namdyn_spg, IOSTAT = ios, ERR = 901)
+901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namdyn_spg in reference namelist', lwp )
+      !
+      REWIND( numnam_cfg )              ! Namelist namdyn_spg in configuration namelist : Free surface
+      READ  ( numnam_cfg, namdyn_spg, IOSTAT = ios, ERR = 902 )
+902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namdyn_spg in configuration namelist', lwp )
+      IF(lwm) WRITE ( numond, namdyn_spg )
+      !
+      IF(lwp) THEN             ! Namelist print
+         WRITE(numout,*) '   Namelist : namdyn_spg                    '
+         WRITE(numout,*) '      Explicit free surface                  ln_dynspg_exp = ', ln_dynspg_exp
+         WRITE(numout,*) '      Free surface with time splitting       ln_dynspg_ts  = ', ln_dynspg_ts
+      ENDIF
+      !                          ! Control of surface pressure gradient scheme options
+                                     nspg =  np_NO    ;   ioptio = 0
+      IF( ln_dynspg_exp ) THEN   ;   nspg =  np_EXP   ;   ioptio = ioptio + 1   ;   ENDIF
+      IF( ln_dynspg_ts  ) THEN   ;   nspg =  np_TS    ;   ioptio = ioptio + 1   ;   ENDIF
+      !
+      IF( ioptio  > 1 )   CALL ctl_stop( 'Choose only one surface pressure gradient scheme' )
+      IF( ioptio == 0 )   CALL ctl_warn( 'NO surface pressure gradient trend in momentum Eqs.' )
+      IF( ln_dynspg_exp .AND. ln_isfcav )   &
+           &   CALL ctl_stop( ' dynspg_exp not tested with ice shelf cavity ' )
+      !
+      IF(lwp) THEN
+         WRITE(numout,*)
+         IF( nspg == np_EXP )   WRITE(numout,*) '   ==>>>   explicit free surface'
+         IF( nspg == np_TS  )   WRITE(numout,*) '   ==>>>   free surface with time splitting scheme'
+         IF( nspg == np_NO  )   WRITE(numout,*) '   ==>>>   No surface surface pressure gradient trend in momentum Eqs.'
+      ENDIF
+      !
+      IF( nspg == np_TS ) THEN   ! split-explicit scheme initialisation
+         CALL dyn_spg_ts_init          ! do it first: set nn_baro used to allocate some arrays later on
+      ENDIF
+      !
+   END SUBROUTINE dyn_spg_init
+
+  !!======================================================================
+END MODULE dynspg
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DYN/dynspg_exp.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DYN/dynspg_exp.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DYN/dynspg_exp.F90	(revision 9570)
@@ -0,0 +1,95 @@
+MODULE dynspg_exp
+   !!======================================================================
+   !!                   ***  MODULE  dynspg_exp  ***
+   !! Ocean dynamics:  surface pressure gradient trend, explicit scheme
+   !!======================================================================
+   !! History :  2.0  !  2005-11  (V. Garnier, G. Madec, L. Bessieres) Original code
+   !!            3.2  !  2009-06  (G. Madec, M. Leclair, R. Benshila) introduce sshwzv module
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   dyn_spg_exp  : update the momentum trend with the surface 
+   !!                      pressure gradient in the free surface constant  
+   !!                      volume case with vector optimization
+   !!----------------------------------------------------------------------
+   USE oce             ! ocean dynamics and tracers 
+   USE dom_oce         ! ocean space and time domain 
+   USE sbc_oce         ! surface boundary condition: ocean
+   USE phycst          ! physical constants
+   !
+   USE in_out_manager  ! I/O manager
+   USE lib_mpp         ! distributed memory computing library
+   USE lbclnk          ! ocean lateral boundary conditions (or mpp link)
+   USE prtctl          ! Print control
+   USE iom             ! I/O library
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   dyn_spg_exp   ! called in dynspg.F90 
+
+   !! * Substitutions
+#  include "vectopt_loop_substitute.h90"
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO Consortium (2010)
+   !! $Id$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE dyn_spg_exp( kt )
+      !!----------------------------------------------------------------------
+      !!                  ***  routine dyn_spg_exp  ***
+      !!
+      !! ** Purpose :   Compute the now trend due to the surface pressure
+      !!              gradient in case of explicit free surface formulation and 
+      !!              add it to the general trend of momentum equation.
+      !!
+      !! ** Method  :   Explicit free surface formulation. Add to the general
+      !!              momentum trend the surface pressure gradient :
+      !!                      (ua,va) = (ua,va) + (spgu,spgv)
+      !!              where spgu = -1/rau0 d/dx(ps) = -g/e1u di( sshn )
+      !!                    spgv = -1/rau0 d/dy(ps) = -g/e2v dj( sshn )
+      !!
+      !! ** Action :   (ua,va)   trend of horizontal velocity increased by 
+      !!                         the surf. pressure gradient trend
+      !!---------------------------------------------------------------------
+      INTEGER, INTENT(in)  ::   kt   ! ocean time-step index
+      !!
+      INTEGER ::   ji, jj, jk   ! dummy loop indices
+      !!----------------------------------------------------------------------
+      !
+      IF( kt == nit000 ) THEN
+         IF(lwp) WRITE(numout,*)
+         IF(lwp) WRITE(numout,*) 'dyn_spg_exp : surface pressure gradient trend'
+         IF(lwp) WRITE(numout,*) '~~~~~~~~~~~   (explicit free surface)'
+         !
+         spgu(:,:) = 0._wp   ;   spgv(:,:) = 0._wp
+         !
+         IF( .NOT.ln_linssh .AND. lwp ) WRITE(numout,*) '      non linear free surface: spg is included in dynhpg'
+      ENDIF
+
+      IF( ln_linssh ) THEN          !* linear free surface : add the surface pressure gradient trend
+         !
+         DO jj = 2, jpjm1                    ! now surface pressure gradient
+            DO ji = fs_2, fs_jpim1   ! vector opt.
+               spgu(ji,jj) = - grav * ( sshn(ji+1,jj) - sshn(ji,jj) ) * r1_e1u(ji,jj)
+               spgv(ji,jj) = - grav * ( sshn(ji,jj+1) - sshn(ji,jj) ) * r1_e2v(ji,jj)
+            END DO 
+         END DO
+         !
+         DO jk = 1, jpkm1                    ! Add it to the general trend
+            DO jj = 2, jpjm1
+               DO ji = fs_2, fs_jpim1   ! vector opt.
+                  ua(ji,jj,jk) = ua(ji,jj,jk) + spgu(ji,jj)
+                  va(ji,jj,jk) = va(ji,jj,jk) + spgv(ji,jj)
+               END DO
+            END DO
+         END DO
+         !
+      ENDIF
+      !
+   END SUBROUTINE dyn_spg_exp
+
+   !!======================================================================
+END MODULE dynspg_exp
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DYN/dynspg_ts.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DYN/dynspg_ts.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DYN/dynspg_ts.F90	(revision 9570)
@@ -0,0 +1,1570 @@
+MODULE dynspg_ts
+
+   !! Includes ROMS wd scheme with diagnostic outputs ; un and ua updates are commented out ! 
+
+   !!======================================================================
+   !!                   ***  MODULE  dynspg_ts  ***
+   !! Ocean dynamics:  surface pressure gradient trend, split-explicit scheme
+   !!======================================================================
+   !! History :   1.0  ! 2004-12  (L. Bessieres, G. Madec)  Original code
+   !!              -   ! 2005-11  (V. Garnier, G. Madec)  optimization
+   !!              -   ! 2006-08  (S. Masson)  distributed restart using iom
+   !!             2.0  ! 2007-07  (D. Storkey) calls to BDY routines
+   !!              -   ! 2008-01  (R. Benshila)  change averaging method
+   !!             3.2  ! 2009-07  (R. Benshila, G. Madec) Complete revisit associated to vvl reactivation
+   !!             3.3  ! 2010-09  (D. Storkey, E. O'Dea) update for BDY for Shelf configurations
+   !!             3.3  ! 2011-03  (R. Benshila, R. Hordoir, P. Oddo) update calculation of ub_b
+   !!             3.5  ! 2013-07  (J. Chanut) Switch to Forward-backward time stepping
+   !!             3.6  ! 2013-11  (A. Coward) Update for z-tilde compatibility
+   !!             3.7  ! 2015-11  (J. Chanut) free surface simplification
+   !!              -   ! 2016-12  (G. Madec, E. Clementi) update for Stoke-Drift divergence
+   !!             4.0  ! 2017-05  (G. Madec)  drag coef. defined at t-point (zdfdrg.F90)
+   !!---------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   dyn_spg_ts     : compute surface pressure gradient trend using a time-splitting scheme 
+   !!   dyn_spg_ts_init: initialisation of the time-splitting scheme
+   !!   ts_wgt         : set time-splitting weights for temporal averaging (or not)
+   !!   ts_rst         : read/write time-splitting fields in restart file
+   !!----------------------------------------------------------------------
+   USE oce             ! ocean dynamics and tracers
+   USE dom_oce         ! ocean space and time domain
+   USE sbc_oce         ! surface boundary condition: ocean
+   USE zdf_oce         ! vertical physics: variables
+   USE zdfdrg          ! vertical physics: top/bottom drag coef.
+   USE sbcisf          ! ice shelf variable (fwfisf)
+   USE sbcapr          ! surface boundary condition: atmospheric pressure
+   USE dynadv    , ONLY: ln_dynadv_vec
+   USE dynvor          ! vortivity scheme indicators
+   USE phycst          ! physical constants
+   USE dynvor          ! vorticity term
+   USE wet_dry         ! wetting/drying flux limter
+   USE bdy_oce         ! open boundary
+   USE bdytides        ! open boundary condition data
+   USE bdydyn2d        ! open boundary conditions on barotropic variables
+   USE sbctide         ! tides
+   USE updtide         ! tide potential
+   USE sbcwave         ! surface wave
+   USE diatmb          ! Top,middle,bottom output
+#if defined key_agrif
+   USE agrif_oce_interp ! agrif
+   USE agrif_oce
+#endif
+#if defined key_asminc   
+   USE asminc          ! Assimilation increment
+#endif
+   !
+   USE in_out_manager  ! I/O manager
+   USE lib_mpp         ! distributed memory computing library
+   USE lbclnk          ! ocean lateral boundary conditions (or mpp link)
+   USE prtctl          ! Print control
+   USE iom             ! IOM library
+   USE restart         ! only for lrst_oce
+   USE diatmb          ! Top,middle,bottom output
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC dyn_spg_ts        ! called by dyn_spg 
+   PUBLIC dyn_spg_ts_init   !    -    - dyn_spg_init
+
+   !! Time filtered arrays at baroclinic time step:
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   un_adv , vn_adv   !: Advection vel. at "now" barocl. step
+   !
+   INTEGER, SAVE :: icycle      ! Number of barotropic sub-steps for each internal step nn_baro <= 2.5 nn_baro
+   REAL(wp),SAVE :: rdtbt       ! Barotropic time step
+   !
+   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:)   ::   wgtbtp1, wgtbtp2   ! 1st & 2nd weights used in time filtering of barotropic fields
+   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   zwz                ! ff_f/h at F points
+   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   ftnw, ftne         ! triad of coriolis parameter
+   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   ftsw, ftse         ! (only used with een vorticity scheme)
+
+   REAL(wp) ::   r1_12 = 1._wp / 12._wp   ! local ratios
+   REAL(wp) ::   r1_8  = 0.125_wp         !
+   REAL(wp) ::   r1_4  = 0.25_wp          !
+   REAL(wp) ::   r1_2  = 0.5_wp           !
+
+   !! * Substitutions
+#  include "vectopt_loop_substitute.h90"
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 4.0 , NEMO Consortium (2017)
+   !! $Id$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   INTEGER FUNCTION dyn_spg_ts_alloc()
+      !!----------------------------------------------------------------------
+      !!                  ***  routine dyn_spg_ts_alloc  ***
+      !!----------------------------------------------------------------------
+      INTEGER :: ierr(3)
+      !!----------------------------------------------------------------------
+      ierr(:) = 0
+      !
+      ALLOCATE( wgtbtp1(3*nn_baro), wgtbtp2(3*nn_baro), zwz(jpi,jpj), STAT=ierr(1) )
+      !
+      IF( ln_dynvor_een .OR. ln_dynvor_eeT )   &
+         &     ALLOCATE( ftnw(jpi,jpj) , ftne(jpi,jpj) , & 
+         &               ftsw(jpi,jpj) , ftse(jpi,jpj) , STAT=ierr(2) )
+         !
+      ALLOCATE( un_adv(jpi,jpj), vn_adv(jpi,jpj)                    , STAT=ierr(3) )
+      !
+      dyn_spg_ts_alloc = MAXVAL( ierr(:) )
+      !
+      IF( lk_mpp                )   CALL mpp_sum( dyn_spg_ts_alloc )
+      IF( dyn_spg_ts_alloc /= 0 )   CALL ctl_warn('dyn_spg_ts_alloc: failed to allocate arrays')
+      !
+   END FUNCTION dyn_spg_ts_alloc
+
+
+   SUBROUTINE dyn_spg_ts( kt )
+      !!----------------------------------------------------------------------
+      !!
+      !! ** Purpose : - Compute the now trend due to the explicit time stepping
+      !!              of the quasi-linear barotropic system, and add it to the
+      !!              general momentum trend. 
+      !!
+      !! ** Method  : - split-explicit schem (time splitting) :
+      !!      Barotropic variables are advanced from internal time steps
+      !!      "n"   to "n+1" if ln_bt_fw=T
+      !!      or from 
+      !!      "n-1" to "n+1" if ln_bt_fw=F
+      !!      thanks to a generalized forward-backward time stepping (see ref. below).
+      !!
+      !! ** Action :
+      !!      -Update the filtered free surface at step "n+1"      : ssha
+      !!      -Update filtered barotropic velocities at step "n+1" : ua_b, va_b
+      !!      -Compute barotropic advective fluxes at step "n"     : un_adv, vn_adv
+      !!      These are used to advect tracers and are compliant with discrete
+      !!      continuity equation taken at the baroclinic time steps. This 
+      !!      ensures tracers conservation.
+      !!      - (ua, va) momentum trend updated with barotropic component.
+      !!
+      !! References : Shchepetkin and McWilliams, Ocean Modelling, 2005. 
+      !!---------------------------------------------------------------------
+      INTEGER, INTENT(in)  ::   kt   ! ocean time-step index
+      !
+      INTEGER  ::   ji, jj, jk, jn        ! dummy loop indices
+      LOGICAL  ::   ll_fw_start           ! =T : forward integration 
+      LOGICAL  ::   ll_init               ! =T : special startup of 2d equations
+      LOGICAL  ::   ll_tmp1, ll_tmp2      ! local logical variables used in W/D
+      INTEGER  ::   ikbu, iktu, noffset   ! local integers
+      INTEGER  ::   ikbv, iktv            !   -      -
+      REAL(wp) ::   r1_2dt_b, z2dt_bf               ! local scalars
+      REAL(wp) ::   zx1, zx2, zu_spg, zhura, z1_hu  !   -      -
+      REAL(wp) ::   zy1, zy2, zv_spg, zhvra, z1_hv  !   -      -
+      REAL(wp) ::   za0, za1, za2, za3              !   -      -
+      REAL(wp) ::   zmdi, zztmp            , z1_ht  !   -      -
+      REAL(wp), DIMENSION(jpi,jpj) :: zsshp2_e, zhf
+      REAL(wp), DIMENSION(jpi,jpj) :: zwx, zu_trd, zu_frc, zssh_frc
+      REAL(wp), DIMENSION(jpi,jpj) :: zwy, zv_trd, zv_frc, zhdiv
+      REAL(wp), DIMENSION(jpi,jpj) :: zsshu_a, zhup2_e, zhust_e, zhtp2_e
+      REAL(wp), DIMENSION(jpi,jpj) :: zsshv_a, zhvp2_e, zhvst_e
+      REAL(wp), DIMENSION(jpi,jpj) :: zCdU_u, zCdU_v   ! top/bottom stress at u- & v-points
+      !
+      REAL(wp) ::   zwdramp                     ! local scalar - only used if ln_wd_dl = .True. 
+
+      INTEGER  :: iwdg, jwdg, kwdg   ! short-hand values for the indices of the output point
+
+      REAL(wp) ::   zepsilon, zgamma            !   -      -
+      REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zcpx, zcpy   ! Wetting/Dying gravity filter coef.
+      REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: ztwdmask, zuwdmask, zvwdmask ! ROMS wetting and drying masks at t,u,v points
+      REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zuwdav2, zvwdav2    ! averages over the sub-steps of zuwdmask and zvwdmask
+      !!----------------------------------------------------------------------
+      !
+      IF( ln_wd_il ) ALLOCATE( zcpx(jpi,jpj), zcpy(jpi,jpj) )
+      !                                         !* Allocate temporary arrays
+      IF( ln_wd_dl ) ALLOCATE( ztwdmask(jpi,jpj), zuwdmask(jpi,jpj), zvwdmask(jpi,jpj), zuwdav2(jpi,jpj), zvwdav2(jpi,jpj))
+      !
+      zmdi=1.e+20                               !  missing data indicator for masking
+      !
+      zwdramp = r_rn_wdmin1               ! simplest ramp 
+!     zwdramp = 1._wp / (rn_wdmin2 - rn_wdmin1) ! more general ramp
+      !                                         ! reciprocal of baroclinic time step 
+      IF( kt == nit000 .AND. neuler == 0 ) THEN   ;   z2dt_bf =          rdt
+      ELSE                                        ;   z2dt_bf = 2.0_wp * rdt
+      ENDIF
+      r1_2dt_b = 1.0_wp / z2dt_bf 
+      !
+      ll_init     = ln_bt_av                    ! if no time averaging, then no specific restart 
+      ll_fw_start = .FALSE.
+      !                                         ! time offset in steps for bdy data update
+      IF( .NOT.ln_bt_fw ) THEN   ;   noffset = - nn_baro
+      ELSE                       ;   noffset =   0 
+      ENDIF
+      !
+      IF( kt == nit000 ) THEN                   !* initialisation
+         !
+         IF(lwp) WRITE(numout,*)
+         IF(lwp) WRITE(numout,*) 'dyn_spg_ts : surface pressure gradient trend'
+         IF(lwp) WRITE(numout,*) '~~~~~~~~~~   free surface with time splitting'
+         IF(lwp) WRITE(numout,*)
+         !
+         IF( neuler == 0 )   ll_init=.TRUE.
+         !
+         IF( ln_bt_fw .OR. neuler == 0 ) THEN
+            ll_fw_start =.TRUE.
+            noffset     = 0
+         ELSE
+            ll_fw_start =.FALSE.
+         ENDIF
+         !
+         ! Set averaging weights and cycle length:
+         CALL ts_wgt( ln_bt_av, ll_fw_start, icycle, wgtbtp1, wgtbtp2 )
+         !
+      ENDIF
+      !
+      IF( ln_isfcav ) THEN    ! top+bottom friction (ocean cavities)
+         DO jj = 2, jpjm1
+            DO ji = fs_2, fs_jpim1   ! vector opt.
+               zCdU_u(ji,jj) = r1_2*( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) + rCdU_top(ji+1,jj)+rCdU_top(ji,jj) )
+               zCdU_v(ji,jj) = r1_2*( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) + rCdU_top(ji,jj+1)+rCdU_top(ji,jj) )
+            END DO
+         END DO
+      ELSE                    ! bottom friction only
+         DO jj = 2, jpjm1
+            DO ji = fs_2, fs_jpim1   ! vector opt.
+               zCdU_u(ji,jj) = r1_2*( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) )
+               zCdU_v(ji,jj) = r1_2*( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) )
+            END DO
+         END DO
+      ENDIF
+      !
+      ! Set arrays to remove/compute coriolis trend.
+      ! Do it once at kt=nit000 if volume is fixed, else at each long time step.
+      ! Note that these arrays are also used during barotropic loop. These are however frozen
+      ! although they should be updated in the variable volume case. Not a big approximation.
+      ! To remove this approximation, copy lines below inside barotropic loop
+      ! and update depths at T-F points (ht and zhf resp.) at each barotropic time step
+      !
+      IF( kt == nit000 .OR. .NOT.ln_linssh ) THEN
+         !
+         SELECT CASE( nvor_scheme )
+         CASE( np_EEN )                != EEN scheme using e3f (energy & enstrophy scheme)
+            SELECT CASE( nn_een_e3f )              !* ff_f/e3 at F-point
+            CASE ( 0 )                                   ! original formulation  (masked averaging of e3t divided by 4)
+               DO jj = 1, jpjm1
+                  DO ji = 1, jpim1
+                     zwz(ji,jj) =   ( ht_n(ji  ,jj+1) + ht_n(ji+1,jj+1) +                    &
+                        &             ht_n(ji  ,jj  ) + ht_n(ji+1,jj  )   ) * 0.25_wp  
+                     IF( zwz(ji,jj) /= 0._wp )   zwz(ji,jj) = ff_f(ji,jj) / zwz(ji,jj)
+                  END DO
+               END DO
+            CASE ( 1 )                                   ! new formulation  (masked averaging of e3t divided by the sum of mask)
+               DO jj = 1, jpjm1
+                  DO ji = 1, jpim1
+                     zwz(ji,jj) =             (  ht_n  (ji  ,jj+1) + ht_n  (ji+1,jj+1)      &
+                        &                      + ht_n  (ji  ,jj  ) + ht_n  (ji+1,jj  )  )   &
+                        &       / ( MAX( 1._wp,  ssmask(ji  ,jj+1) + ssmask(ji+1,jj+1)      &
+                        &                      + ssmask(ji  ,jj  ) + ssmask(ji+1,jj  )  )   )
+                     IF( zwz(ji,jj) /= 0._wp )   zwz(ji,jj) = ff_f(ji,jj) / zwz(ji,jj)
+                  END DO
+               END DO
+            END SELECT
+            CALL lbc_lnk( zwz, 'F', 1._wp )
+            !
+            ftne(1,:) = 0._wp ; ftnw(1,:) = 0._wp ; ftse(1,:) = 0._wp ; ftsw(1,:) = 0._wp
+            DO jj = 2, jpj
+               DO ji = 2, jpi
+                  ftne(ji,jj) = zwz(ji-1,jj  ) + zwz(ji  ,jj  ) + zwz(ji  ,jj-1)
+                  ftnw(ji,jj) = zwz(ji-1,jj-1) + zwz(ji-1,jj  ) + zwz(ji  ,jj  )
+                  ftse(ji,jj) = zwz(ji  ,jj  ) + zwz(ji  ,jj-1) + zwz(ji-1,jj-1)
+                  ftsw(ji,jj) = zwz(ji  ,jj-1) + zwz(ji-1,jj-1) + zwz(ji-1,jj  )
+               END DO
+            END DO
+            !
+         CASE( np_EET )                  != EEN scheme using e3t (energy conserving scheme)
+            ftne(1,:) = 0._wp ; ftnw(1,:) = 0._wp ; ftse(1,:) = 0._wp ; ftsw(1,:) = 0._wp
+            DO jj = 2, jpj
+               DO ji = 2, jpi
+                  z1_ht = ssmask(ji,jj) / ( ht_n(ji,jj) + 1._wp - ssmask(ji,jj) )
+                  ftne(ji,jj) = ( ff_f(ji-1,jj  ) + ff_f(ji  ,jj  ) + ff_f(ji  ,jj-1) ) * z1_ht
+                  ftnw(ji,jj) = ( ff_f(ji-1,jj-1) + ff_f(ji-1,jj  ) + ff_f(ji  ,jj  ) ) * z1_ht
+                  ftse(ji,jj) = ( ff_f(ji  ,jj  ) + ff_f(ji  ,jj-1) + ff_f(ji-1,jj-1) ) * z1_ht
+                  ftsw(ji,jj) = ( ff_f(ji  ,jj-1) + ff_f(ji-1,jj-1) + ff_f(ji-1,jj  ) ) * z1_ht
+               END DO
+            END DO
+            !
+         CASE( np_ENE, np_ENS , np_MIX )  != all other schemes (ENE, ENS, MIX) except ENT !
+            !
+            zwz(:,:) = 0._wp
+            zhf(:,:) = 0._wp
+            
+!!gm  assume 0 in both cases (which is almost surely WRONG ! ) as hvatf has been removed 
+!!gm    A priori a better value should be something like :
+!!gm          zhf(i,j) = masked sum of  ht(i,j) , ht(i+1,j) , ht(i,j+1) , (i+1,j+1) 
+!!gm                     divided by the sum of the corresponding mask 
+!!gm 
+!!            
+            IF( .NOT.ln_sco ) THEN
+  
+   !!gm  agree the JC comment  : this should be done in a much clear way
+  
+   ! JC: It not clear yet what should be the depth at f-points over land in z-coordinate case
+   !     Set it to zero for the time being 
+   !              IF( rn_hmin < 0._wp ) THEN    ;   jk = - INT( rn_hmin )                                      ! from a nb of level
+   !              ELSE                          ;   jk = MINLOC( gdepw_0, mask = gdepw_0 > rn_hmin, dim = 1 )  ! from a depth
+   !              ENDIF
+   !              zhf(:,:) = gdepw_0(:,:,jk+1)
+               !
+            ELSE
+               !
+               !zhf(:,:) = hbatf(:,:)
+               DO jj = 1, jpjm1
+                  DO ji = 1, jpim1
+                     zhf(ji,jj) =    (   ht_0  (ji,jj  ) + ht_0  (ji+1,jj  )          &
+                        &              + ht_0  (ji,jj+1) + ht_0  (ji+1,jj+1)   )      &
+                        &       / MAX(   ssmask(ji,jj  ) + ssmask(ji+1,jj  )          &
+                        &              + ssmask(ji,jj+1) + ssmask(ji+1,jj+1) , 1._wp  )
+                  END DO
+               END DO
+            ENDIF
+            !
+            DO jj = 1, jpjm1
+               zhf(:,jj) = zhf(:,jj) * (1._wp- umask(:,jj,1) * umask(:,jj+1,1))
+            END DO
+            !
+            DO jk = 1, jpkm1
+               DO jj = 1, jpjm1
+                  zhf(:,jj) = zhf(:,jj) + e3f_n(:,jj,jk) * umask(:,jj,jk) * umask(:,jj+1,jk)
+               END DO
+            END DO
+            CALL lbc_lnk( zhf, 'F', 1._wp )
+            ! JC: TBC. hf should be greater than 0 
+            DO jj = 1, jpj
+               DO ji = 1, jpi
+                  IF( zhf(ji,jj) /= 0._wp )   zwz(ji,jj) = 1._wp / zhf(ji,jj) ! zhf is actually hf here but it saves an array
+               END DO
+            END DO
+            zwz(:,:) = ff_f(:,:) * zwz(:,:)
+         END SELECT
+      ENDIF
+      !
+      ! If forward start at previous time step, and centered integration, 
+      ! then update averaging weights:
+      IF (.NOT.ln_bt_fw .AND.( neuler==0 .AND. kt==nit000+1 ) ) THEN
+         ll_fw_start=.FALSE.
+         CALL ts_wgt( ln_bt_av, ll_fw_start, icycle, wgtbtp1, wgtbtp2 )
+      ENDIF
+                          
+      ! -----------------------------------------------------------------------------
+      !  Phase 1 : Coupling between general trend and barotropic estimates (1st step)
+      ! -----------------------------------------------------------------------------
+      !      
+      !
+      !                                   !* e3*d/dt(Ua) (Vertically integrated)
+      !                                   ! --------------------------------------------------
+      zu_frc(:,:) = 0._wp
+      zv_frc(:,:) = 0._wp
+      !
+      DO jk = 1, jpkm1
+         zu_frc(:,:) = zu_frc(:,:) + e3u_n(:,:,jk) * ua(:,:,jk) * umask(:,:,jk)
+         zv_frc(:,:) = zv_frc(:,:) + e3v_n(:,:,jk) * va(:,:,jk) * vmask(:,:,jk)         
+      END DO
+      !
+      zu_frc(:,:) = zu_frc(:,:) * r1_hu_n(:,:)
+      zv_frc(:,:) = zv_frc(:,:) * r1_hv_n(:,:)
+      !
+      !
+      !                                   !* baroclinic momentum trend (remove the vertical mean trend)
+      DO jk = 1, jpkm1                    ! -----------------------------------------------------------
+         DO jj = 2, jpjm1
+            DO ji = fs_2, fs_jpim1   ! vector opt.
+               ua(ji,jj,jk) = ua(ji,jj,jk) - zu_frc(ji,jj) * umask(ji,jj,jk)
+               va(ji,jj,jk) = va(ji,jj,jk) - zv_frc(ji,jj) * vmask(ji,jj,jk)
+            END DO
+         END DO
+      END DO
+      
+!!gm  Question here when removing the Vertically integrated trends, we remove the vertically integrated NL trends on momentum....
+!!gm  Is it correct to do so ?   I think so...
+      
+      
+      !                                   !* barotropic Coriolis trends (vorticity scheme dependent)
+      !                                   ! --------------------------------------------------------
+      !
+      zwx(:,:) = un_b(:,:) * hu_n(:,:) * e2u(:,:)        ! now fluxes 
+      zwy(:,:) = vn_b(:,:) * hv_n(:,:) * e1v(:,:)
+      !
+      SELECT CASE( nvor_scheme )
+      CASE( np_ENT )                ! enstrophy conserving scheme (f-point)
+         DO jj = 2, jpjm1
+            DO ji = 2, jpim1   ! vector opt.
+               zu_trd(ji,jj) = + r1_4 * r1_e1e2u(ji,jj) * r1_hu_n(ji,jj)                    &
+                  &               * (  e1e2t(ji+1,jj)*ht_n(ji+1,jj)*ff_t(ji+1,jj) * ( vn_b(ji+1,jj) + vn_b(ji+1,jj-1) )   &
+                  &                  + e1e2t(ji  ,jj)*ht_n(ji  ,jj)*ff_t(ji  ,jj) * ( vn_b(ji  ,jj) + vn_b(ji  ,jj-1) )   )
+                  !
+               zv_trd(ji,jj) = - r1_4 * r1_e1e2v(ji,jj) * r1_hv_n(ji,jj)                    &
+                  &               * (  e1e2t(ji,jj+1)*ht_n(ji,jj+1)*ff_t(ji,jj+1) * ( un_b(ji,jj+1) + un_b(ji-1,jj+1) )   & 
+                  &                  + e1e2t(ji,jj  )*ht_n(ji,jj  )*ff_t(ji,jj  ) * ( un_b(ji,jj  ) + un_b(ji-1,jj  ) )   ) 
+            END DO  
+         END DO  
+         !         
+      CASE( np_ENE , np_MIX )        ! energy conserving scheme (t-point) ENE or MIX
+         DO jj = 2, jpjm1
+            DO ji = fs_2, fs_jpim1   ! vector opt.
+               zy1 = ( zwy(ji,jj-1) + zwy(ji+1,jj-1) ) * r1_e1u(ji,jj)
+               zy2 = ( zwy(ji,jj  ) + zwy(ji+1,jj  ) ) * r1_e1u(ji,jj)
+               zx1 = ( zwx(ji-1,jj) + zwx(ji-1,jj+1) ) * r1_e2v(ji,jj)
+               zx2 = ( zwx(ji  ,jj) + zwx(ji  ,jj+1) ) * r1_e2v(ji,jj)
+               ! energy conserving formulation for planetary vorticity term
+               zu_trd(ji,jj) =   r1_4 * ( zwz(ji  ,jj-1) * zy1 + zwz(ji,jj) * zy2 )
+               zv_trd(ji,jj) = - r1_4 * ( zwz(ji-1,jj  ) * zx1 + zwz(ji,jj) * zx2 )
+            END DO
+         END DO
+         !
+      CASE( np_ENS )                ! enstrophy conserving scheme (f-point)
+         DO jj = 2, jpjm1
+            DO ji = fs_2, fs_jpim1   ! vector opt.
+               zy1 =   r1_8 * ( zwy(ji  ,jj-1) + zwy(ji+1,jj-1) &
+                 &            + zwy(ji  ,jj  ) + zwy(ji+1,jj  ) ) * r1_e1u(ji,jj)
+               zx1 = - r1_8 * ( zwx(ji-1,jj  ) + zwx(ji-1,jj+1) &
+                 &            + zwx(ji  ,jj  ) + zwx(ji  ,jj+1) ) * r1_e2v(ji,jj)
+               zu_trd(ji,jj)  = zy1 * ( zwz(ji  ,jj-1) + zwz(ji,jj) )
+               zv_trd(ji,jj)  = zx1 * ( zwz(ji-1,jj  ) + zwz(ji,jj) )
+            END DO
+         END DO
+         !
+      CASE( np_EET , np_EEN )      ! energy & enstrophy scheme (using e3t or e3f)         
+         DO jj = 2, jpjm1
+            DO ji = fs_2, fs_jpim1   ! vector opt.
+               zu_trd(ji,jj) = + r1_12 * r1_e1u(ji,jj) * (  ftne(ji,jj  ) * zwy(ji  ,jj  ) &
+                &                                         + ftnw(ji+1,jj) * zwy(ji+1,jj  ) &
+                &                                         + ftse(ji,jj  ) * zwy(ji  ,jj-1) &
+                &                                         + ftsw(ji+1,jj) * zwy(ji+1,jj-1) )
+               zv_trd(ji,jj) = - r1_12 * r1_e2v(ji,jj) * (  ftsw(ji,jj+1) * zwx(ji-1,jj+1) &
+                &                                         + ftse(ji,jj+1) * zwx(ji  ,jj+1) &
+                &                                         + ftnw(ji,jj  ) * zwx(ji-1,jj  ) &
+                &                                         + ftne(ji,jj  ) * zwx(ji  ,jj  ) )
+            END DO
+         END DO
+         !
+      END SELECT
+      !
+      !                                   !* Right-Hand-Side of the barotropic momentum equation
+      !                                   ! ----------------------------------------------------
+      IF( .NOT.ln_linssh ) THEN                 ! Variable volume : remove surface pressure gradient
+         IF( ln_wd_il ) THEN                        ! Calculating and applying W/D gravity filters
+            DO jj = 2, jpjm1
+               DO ji = 2, jpim1 
+                  ll_tmp1 = MIN(  sshn(ji,jj)               ,  sshn(ji+1,jj) ) >                &
+                     &      MAX( -ht_0(ji,jj)               , -ht_0(ji+1,jj) ) .AND.            &
+                     &      MAX(  sshn(ji,jj) + ht_0(ji,jj) ,  sshn(ji+1,jj) + ht_0(ji+1,jj) )  &
+                     &                                                         > rn_wdmin1 + rn_wdmin2
+                  ll_tmp2 = ( ABS( sshn(ji+1,jj)            -  sshn(ji  ,jj))  > 1.E-12 ).AND.( &
+                     &      MAX(   sshn(ji,jj)              ,  sshn(ji+1,jj) ) >                &
+                     &      MAX(  -ht_0(ji,jj)              , -ht_0(ji+1,jj) ) + rn_wdmin1 + rn_wdmin2 )
+                  IF(ll_tmp1) THEN
+                     zcpx(ji,jj) = 1.0_wp
+                  ELSEIF(ll_tmp2) THEN
+                     ! no worries about  sshn(ji+1,jj) -  sshn(ji  ,jj) = 0, it won't happen ! here
+                     zcpx(ji,jj) = ABS( (sshn(ji+1,jj) + ht_0(ji+1,jj) - sshn(ji,jj) - ht_0(ji,jj)) &
+                                 &    / (sshn(ji+1,jj) - sshn(ji  ,jj)) )
+                     zcpx(ji,jj) = max(min( zcpx(ji,jj) , 1.0_wp),0.0_wp)
+                  ELSE
+                     zcpx(ji,jj) = 0._wp
+                  ENDIF
+                  !
+                  ll_tmp1 = MIN(  sshn(ji,jj)               ,  sshn(ji,jj+1) ) >                &
+                     &      MAX( -ht_0(ji,jj)               , -ht_0(ji,jj+1) ) .AND.            &
+                     &      MAX(  sshn(ji,jj) + ht_0(ji,jj) ,  sshn(ji,jj+1) + ht_0(ji,jj+1) )  &
+                     &                                                       > rn_wdmin1 + rn_wdmin2
+                  ll_tmp2 = ( ABS( sshn(ji,jj)              -  sshn(ji,jj+1))  > 1.E-12 ).AND.( &
+                     &      MAX(   sshn(ji,jj)              ,  sshn(ji,jj+1) ) >                &
+                     &      MAX(  -ht_0(ji,jj)              , -ht_0(ji,jj+1) ) + rn_wdmin1 + rn_wdmin2 )
+  
+                  IF(ll_tmp1) THEN
+                     zcpy(ji,jj) = 1.0_wp
+                  ELSE IF(ll_tmp2) THEN
+                     ! no worries about  sshn(ji,jj+1) -  sshn(ji,jj  ) = 0, it won't happen ! here
+                     zcpy(ji,jj) = ABS( (sshn(ji,jj+1) + ht_0(ji,jj+1) - sshn(ji,jj) - ht_0(ji,jj)) &
+                        &             / (sshn(ji,jj+1) - sshn(ji,jj  )) )
+                     zcpy(ji,jj) = MAX(  0._wp , MIN( zcpy(ji,jj) , 1.0_wp )  )
+                  ELSE
+                     zcpy(ji,jj) = 0._wp
+                  ENDIF
+               END DO
+            END DO
+            !
+            DO jj = 2, jpjm1
+               DO ji = 2, jpim1
+                  zu_trd(ji,jj) = zu_trd(ji,jj) - grav * ( sshn(ji+1,jj  ) - sshn(ji  ,jj ) )   &
+                     &                          * r1_e1u(ji,jj) * zcpx(ji,jj)  * wdrampu(ji,jj)  !jth
+                  zv_trd(ji,jj) = zv_trd(ji,jj) - grav * ( sshn(ji  ,jj+1) - sshn(ji  ,jj ) )   &
+                     &                          * r1_e2v(ji,jj) * zcpy(ji,jj)  * wdrampv(ji,jj)  !jth
+               END DO
+            END DO
+            !
+         ELSE
+            !
+            DO jj = 2, jpjm1
+               DO ji = fs_2, fs_jpim1   ! vector opt.
+                  zu_trd(ji,jj) = zu_trd(ji,jj) - grav * (  sshn(ji+1,jj  ) - sshn(ji  ,jj  )  ) * r1_e1u(ji,jj)
+                  zv_trd(ji,jj) = zv_trd(ji,jj) - grav * (  sshn(ji  ,jj+1) - sshn(ji  ,jj  )  ) * r1_e2v(ji,jj) 
+               END DO
+            END DO
+         ENDIF
+         !
+      ENDIF
+      !
+      DO jj = 2, jpjm1                          ! Remove coriolis term (and possibly spg) from barotropic trend
+         DO ji = fs_2, fs_jpim1
+             zu_frc(ji,jj) = zu_frc(ji,jj) - zu_trd(ji,jj) * ssumask(ji,jj)
+             zv_frc(ji,jj) = zv_frc(ji,jj) - zv_trd(ji,jj) * ssvmask(ji,jj)
+          END DO
+      END DO 
+      !
+      !                                         ! Add bottom stress contribution from baroclinic velocities:      
+      IF (ln_bt_fw) THEN
+         DO jj = 2, jpjm1                          
+            DO ji = fs_2, fs_jpim1   ! vector opt.
+               ikbu = mbku(ji,jj)       
+               ikbv = mbkv(ji,jj)    
+               zwx(ji,jj) = un(ji,jj,ikbu) - un_b(ji,jj) ! NOW bottom baroclinic velocities
+               zwy(ji,jj) = vn(ji,jj,ikbv) - vn_b(ji,jj)
+            END DO
+         END DO
+      ELSE
+         DO jj = 2, jpjm1
+            DO ji = fs_2, fs_jpim1   ! vector opt.
+               ikbu = mbku(ji,jj)       
+               ikbv = mbkv(ji,jj)    
+               zwx(ji,jj) = ub(ji,jj,ikbu) - ub_b(ji,jj) ! BEFORE bottom baroclinic velocities
+               zwy(ji,jj) = vb(ji,jj,ikbv) - vb_b(ji,jj)
+            END DO
+         END DO
+      ENDIF
+      !
+      ! Note that the "unclipped" bottom friction parameter is used even with explicit drag
+      IF( ln_wd_il ) THEN
+         zztmp = -1._wp / rdtbt
+         DO jj = 2, jpjm1
+            DO ji = fs_2, fs_jpim1   ! vector opt.
+               zu_frc(ji,jj) = zu_frc(ji,jj) + & 
+               & MAX(r1_hu_n(ji,jj) * r1_2 * ( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) ), zztmp ) * zwx(ji,jj) *  wdrampu(ji,jj)
+               zv_frc(ji,jj) = zv_frc(ji,jj) + & 
+               & MAX(r1_hv_n(ji,jj) * r1_2 * ( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) ), zztmp ) * zwy(ji,jj) *  wdrampv(ji,jj)
+            END DO
+         END DO
+      ELSE
+         DO jj = 2, jpjm1
+            DO ji = fs_2, fs_jpim1   ! vector opt.
+               zu_frc(ji,jj) = zu_frc(ji,jj) + r1_hu_n(ji,jj) * r1_2 * ( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) ) * zwx(ji,jj)
+               zv_frc(ji,jj) = zv_frc(ji,jj) + r1_hv_n(ji,jj) * r1_2 * ( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) ) * zwy(ji,jj)
+            END DO
+         END DO
+      END IF
+      !
+      IF( ln_isfcav ) THEN       ! Add TOP stress contribution from baroclinic velocities:      
+         IF( ln_bt_fw ) THEN
+            DO jj = 2, jpjm1
+               DO ji = fs_2, fs_jpim1   ! vector opt.
+                  iktu = miku(ji,jj)
+                  iktv = mikv(ji,jj)
+                  zwx(ji,jj) = un(ji,jj,iktu) - un_b(ji,jj) ! NOW top baroclinic velocities
+                  zwy(ji,jj) = vn(ji,jj,iktv) - vn_b(ji,jj)
+               END DO
+            END DO
+         ELSE
+            DO jj = 2, jpjm1
+               DO ji = fs_2, fs_jpim1   ! vector opt.
+                  iktu = miku(ji,jj)
+                  iktv = mikv(ji,jj)
+                  zwx(ji,jj) = ub(ji,jj,iktu) - ub_b(ji,jj) ! BEFORE top baroclinic velocities
+                  zwy(ji,jj) = vb(ji,jj,iktv) - vb_b(ji,jj)
+               END DO
+            END DO
+         ENDIF
+         !
+         ! Note that the "unclipped" top friction parameter is used even with explicit drag
+         DO jj = 2, jpjm1              
+            DO ji = fs_2, fs_jpim1   ! vector opt.
+               zu_frc(ji,jj) = zu_frc(ji,jj) + r1_hu_n(ji,jj) * r1_2 * ( rCdU_top(ji+1,jj)+rCdU_top(ji,jj) ) * zwx(ji,jj)
+               zv_frc(ji,jj) = zv_frc(ji,jj) + r1_hv_n(ji,jj) * r1_2 * ( rCdU_top(ji,jj+1)+rCdU_top(ji,jj) ) * zwy(ji,jj)
+            END DO
+         END DO
+      ENDIF
+      !       
+      IF( ln_bt_fw ) THEN                        ! Add wind forcing
+         DO jj = 2, jpjm1
+            DO ji = fs_2, fs_jpim1   ! vector opt.
+               zu_frc(ji,jj) =  zu_frc(ji,jj) + r1_rau0 * utau(ji,jj) * r1_hu_n(ji,jj)
+               zv_frc(ji,jj) =  zv_frc(ji,jj) + r1_rau0 * vtau(ji,jj) * r1_hv_n(ji,jj)
+            END DO
+         END DO
+      ELSE
+         zztmp = r1_rau0 * r1_2
+         DO jj = 2, jpjm1
+            DO ji = fs_2, fs_jpim1   ! vector opt.
+               zu_frc(ji,jj) =  zu_frc(ji,jj) + zztmp * ( utau_b(ji,jj) + utau(ji,jj) ) * r1_hu_n(ji,jj)
+               zv_frc(ji,jj) =  zv_frc(ji,jj) + zztmp * ( vtau_b(ji,jj) + vtau(ji,jj) ) * r1_hv_n(ji,jj)
+            END DO
+         END DO
+      ENDIF  
+      !
+      IF( ln_apr_dyn ) THEN                     ! Add atm pressure forcing
+         IF( ln_bt_fw ) THEN
+            DO jj = 2, jpjm1              
+               DO ji = fs_2, fs_jpim1   ! vector opt.
+                  zu_spg =  grav * (  ssh_ib (ji+1,jj  ) - ssh_ib (ji,jj) ) * r1_e1u(ji,jj)
+                  zv_spg =  grav * (  ssh_ib (ji  ,jj+1) - ssh_ib (ji,jj) ) * r1_e2v(ji,jj)
+                  zu_frc(ji,jj) = zu_frc(ji,jj) + zu_spg
+                  zv_frc(ji,jj) = zv_frc(ji,jj) + zv_spg
+               END DO
+            END DO
+         ELSE
+            zztmp = grav * r1_2
+            DO jj = 2, jpjm1              
+               DO ji = fs_2, fs_jpim1   ! vector opt.
+                  zu_spg = zztmp * (  ssh_ib (ji+1,jj  ) - ssh_ib (ji,jj)    &
+                      &             + ssh_ibb(ji+1,jj  ) - ssh_ibb(ji,jj)  ) * r1_e1u(ji,jj)
+                  zv_spg = zztmp * (  ssh_ib (ji  ,jj+1) - ssh_ib (ji,jj)    &
+                      &             + ssh_ibb(ji  ,jj+1) - ssh_ibb(ji,jj)  ) * r1_e2v(ji,jj)
+                  zu_frc(ji,jj) = zu_frc(ji,jj) + zu_spg
+                  zv_frc(ji,jj) = zv_frc(ji,jj) + zv_spg
+               END DO
+            END DO
+         ENDIF 
+      ENDIF
+      !                                   !* Right-Hand-Side of the barotropic ssh equation
+      !                                   ! -----------------------------------------------
+      !                                         ! Surface net water flux and rivers
+      IF (ln_bt_fw) THEN
+         zssh_frc(:,:) = r1_rau0 * ( emp(:,:) - rnf(:,:) + fwfisf(:,:) )
+      ELSE
+         zztmp = r1_rau0 * r1_2
+         zssh_frc(:,:) = zztmp * (  emp(:,:) + emp_b(:,:) - rnf(:,:) - rnf_b(:,:)   &
+                &                 + fwfisf(:,:) + fwfisf_b(:,:)                     )
+      ENDIF
+      !
+      IF( ln_sdw ) THEN                         ! Stokes drift divergence added if necessary
+         zssh_frc(:,:) = zssh_frc(:,:) + div_sd(:,:)
+      ENDIF
+      !
+#if defined key_asminc
+      !                                         ! Include the IAU weighted SSH increment
+      IF( lk_asminc .AND. ln_sshinc .AND. ln_asmiau ) THEN
+         zssh_frc(:,:) = zssh_frc(:,:) - ssh_iau(:,:)
+      ENDIF
+#endif
+      !                                   !* Fill boundary data arrays for AGRIF
+      !                                   ! ------------------------------------
+#if defined key_agrif
+         IF( .NOT.Agrif_Root() ) CALL agrif_dta_ts( kt )
+#endif
+      !
+      ! -----------------------------------------------------------------------
+      !  Phase 2 : Integration of the barotropic equations 
+      ! -----------------------------------------------------------------------
+      !
+      !                                             ! ==================== !
+      !                                             !    Initialisations   !
+      !                                             ! ==================== !  
+      ! Initialize barotropic variables:      
+      IF( ll_init )THEN
+         sshbb_e(:,:) = 0._wp
+         ubb_e  (:,:) = 0._wp
+         vbb_e  (:,:) = 0._wp
+         sshb_e (:,:) = 0._wp
+         ub_e   (:,:) = 0._wp
+         vb_e   (:,:) = 0._wp
+      ENDIF
+
+      !
+      IF (ln_bt_fw) THEN                  ! FORWARD integration: start from NOW fields                    
+         sshn_e(:,:) =    sshn(:,:)            
+         un_e  (:,:) =    un_b(:,:)            
+         vn_e  (:,:) =    vn_b(:,:)
+         !
+         hu_e  (:,:) =    hu_n(:,:)       
+         hv_e  (:,:) =    hv_n(:,:) 
+         hur_e (:,:) = r1_hu_n(:,:)    
+         hvr_e (:,:) = r1_hv_n(:,:)
+      ELSE                                ! CENTRED integration: start from BEFORE fields
+         sshn_e(:,:) =    sshb(:,:)
+         un_e  (:,:) =    ub_b(:,:)         
+         vn_e  (:,:) =    vb_b(:,:)
+         !
+         hu_e  (:,:) =    hu_b(:,:)       
+         hv_e  (:,:) =    hv_b(:,:) 
+         hur_e (:,:) = r1_hu_b(:,:)    
+         hvr_e (:,:) = r1_hv_b(:,:)
+      ENDIF
+      !
+      !
+      !
+      ! Initialize sums:
+      ua_b  (:,:) = 0._wp       ! After barotropic velocities (or transport if flux form)          
+      va_b  (:,:) = 0._wp
+      ssha  (:,:) = 0._wp       ! Sum for after averaged sea level
+      un_adv(:,:) = 0._wp       ! Sum for now transport issued from ts loop
+      vn_adv(:,:) = 0._wp
+      !
+      IF( ln_wd_dl ) THEN
+         zuwdmask(:,:) = 0._wp  ! set to zero for definiteness (not sure this is necessary) 
+         zvwdmask(:,:) = 0._wp  ! 
+         zuwdav2 (:,:) = 0._wp 
+         zvwdav2 (:,:) = 0._wp   
+      END IF 
+
+      !                                             ! ==================== !
+      DO jn = 1, icycle                             !  sub-time-step loop  !
+         !                                          ! ==================== !
+         !                                                !* Update the forcing (BDY and tides)
+         !                                                !  ------------------
+         ! Update only tidal forcing at open boundaries
+         IF( ln_bdy      .AND. ln_tide )   CALL bdy_dta_tides( kt, kit=jn, time_offset= noffset+1 )
+         IF( ln_tide_pot .AND. ln_tide )   CALL upd_tide     ( kt, kit=jn, time_offset= noffset   )
+         !
+         ! Set extrapolation coefficients for predictor step:
+         IF ((jn<3).AND.ll_init) THEN      ! Forward           
+           za1 = 1._wp                                          
+           za2 = 0._wp                        
+           za3 = 0._wp                        
+         ELSE                              ! AB3-AM4 Coefficients: bet=0.281105 
+           za1 =  1.781105_wp              ! za1 =   3/2 +   bet
+           za2 = -1.06221_wp               ! za2 = -(1/2 + 2*bet)
+           za3 =  0.281105_wp              ! za3 = bet
+         ENDIF
+
+         ! Extrapolate barotropic velocities at step jit+0.5:
+         ua_e(:,:) = za1 * un_e(:,:) + za2 * ub_e(:,:) + za3 * ubb_e(:,:)
+         va_e(:,:) = za1 * vn_e(:,:) + za2 * vb_e(:,:) + za3 * vbb_e(:,:)
+
+         IF( .NOT.ln_linssh ) THEN                        !* Update ocean depth (variable volume case only)
+            !                                             !  ------------------
+            ! Extrapolate Sea Level at step jit+0.5:
+            zsshp2_e(:,:) = za1 * sshn_e(:,:)  + za2 * sshb_e(:,:) + za3 * sshbb_e(:,:)
+            
+            ! set wetting & drying mask at tracer points for this barotropic sub-step 
+            IF ( ln_wd_dl ) THEN 
+               !
+               IF ( ln_wd_dl_rmp ) THEN 
+                  DO jj = 1, jpj                                 
+                     DO ji = 1, jpi   ! vector opt.  
+                        IF ( zsshp2_e(ji,jj) + ht_0(ji,jj) >  2._wp * rn_wdmin1 ) THEN 
+!                        IF ( zsshp2_e(ji,jj) + ht_0(ji,jj) >  rn_wdmin2 ) THEN 
+                           ztwdmask(ji,jj) = 1._wp
+                        ELSE IF ( zsshp2_e(ji,jj) + ht_0(ji,jj) >  rn_wdmin1 ) THEN
+                           ztwdmask(ji,jj) = (tanh(50._wp*( ( zsshp2_e(ji,jj) + ht_0(ji,jj) -  rn_wdmin1 )*r_rn_wdmin1)) ) 
+                        ELSE 
+                           ztwdmask(ji,jj) = 0._wp
+                        END IF
+                     END DO
+                  END DO
+               ELSE
+                  DO jj = 1, jpj                                 
+                     DO ji = 1, jpi   ! vector opt.  
+                        IF ( zsshp2_e(ji,jj) + ht_0(ji,jj) >  rn_wdmin1 ) THEN 
+                           ztwdmask(ji,jj) = 1._wp
+                        ELSE 
+                           ztwdmask(ji,jj) = 0._wp
+                        ENDIF
+                     END DO
+                  END DO
+               ENDIF 
+               !
+            ENDIF 
+            !
+            DO jj = 2, jpjm1                                    ! Sea Surface Height at u- & v-points
+               DO ji = 2, fs_jpim1   ! Vector opt.
+                  zwx(ji,jj) = r1_2 * ssumask(ji,jj)  * r1_e1e2u(ji,jj)     &
+                     &              * ( e1e2t(ji  ,jj) * zsshp2_e(ji  ,jj)  &
+                     &              +   e1e2t(ji+1,jj) * zsshp2_e(ji+1,jj) )
+                  zwy(ji,jj) = r1_2 * ssvmask(ji,jj)  * r1_e1e2v(ji,jj)     &
+                     &              * ( e1e2t(ji,jj  ) * zsshp2_e(ji,jj  )  &
+                     &              +   e1e2t(ji,jj+1) * zsshp2_e(ji,jj+1) )
+               END DO
+            END DO
+            CALL lbc_lnk_multi( zwx, 'U', 1._wp, zwy, 'V', 1._wp )
+            !
+            zhup2_e(:,:) = hu_0(:,:) + zwx(:,:)                ! Ocean depth at U- and V-points
+            zhvp2_e(:,:) = hv_0(:,:) + zwy(:,:)
+            zhtp2_e(:,:) = ht_0(:,:) + zsshp2_e(:,:)
+         ELSE
+            zhup2_e(:,:) = hu_n(:,:)
+            zhvp2_e(:,:) = hv_n(:,:)
+            zhtp2_e(:,:) = ht_n(:,:)
+         ENDIF
+         !                                                !* after ssh
+         !                                                !  -----------
+         ! One should enforce volume conservation at open boundaries here
+         ! considering fluxes below:
+         !
+         zwx(:,:) = e2u(:,:) * ua_e(:,:) * zhup2_e(:,:)         ! fluxes at jn+0.5
+         zwy(:,:) = e1v(:,:) * va_e(:,:) * zhvp2_e(:,:)
+         !
+#if defined key_agrif
+         ! Set fluxes during predictor step to ensure volume conservation
+         IF( .NOT.Agrif_Root() .AND. ln_bt_fw ) THEN
+            IF((nbondi == -1).OR.(nbondi == 2)) THEN
+               DO jj = 1, jpj
+                  zwx(2:nbghostcells+1,jj) = ubdy_w(1:nbghostcells,jj) * e2u(2:nbghostcells+1,jj)
+               END DO
+            ENDIF
+            IF((nbondi ==  1).OR.(nbondi == 2)) THEN
+               DO jj=1,jpj
+                  zwx(nlci-nbghostcells-1:nlci-2,jj) = ubdy_e(1:nbghostcells,jj) * e2u(nlci-nbghostcells-1:nlci-2,jj)
+               END DO
+            ENDIF
+            IF((nbondj == -1).OR.(nbondj == 2)) THEN
+               DO ji=1,jpi
+                  zwy(ji,2:nbghostcells+1) = vbdy_s(ji,1:nbghostcells) * e1v(ji,2:nbghostcells+1)
+               END DO
+            ENDIF
+            IF((nbondj ==  1).OR.(nbondj == 2)) THEN
+               DO ji=1,jpi
+                  zwy(ji,nlcj-nbghostcells-1:nlcj-2) = vbdy_n(ji,1:nbghostcells) * e1v(ji,nlcj-nbghostcells-1:nlcj-2)
+               END DO
+            ENDIF
+         ENDIF
+#endif
+         IF( ln_wd_il )   CALL wad_lmt_bt(zwx, zwy, sshn_e, zssh_frc, rdtbt)
+
+         IF ( ln_wd_dl ) THEN 
+            !
+            ! un_e and vn_e are set to zero at faces where the direction of the flow is from dry cells 
+            !
+            DO jj = 1, jpjm1                                 
+               DO ji = 1, jpim1   
+                  IF ( zwx(ji,jj) > 0.0 ) THEN 
+                     zuwdmask(ji, jj) = ztwdmask(ji  ,jj) 
+                  ELSE 
+                     zuwdmask(ji, jj) = ztwdmask(ji+1,jj)  
+                  END IF 
+                  zwx(ji, jj) = zuwdmask(ji,jj)*zwx(ji, jj)
+                  un_e(ji,jj) = zuwdmask(ji,jj)*un_e(ji,jj)
+
+                  IF ( zwy(ji,jj) > 0.0 ) THEN
+                     zvwdmask(ji, jj) = ztwdmask(ji, jj  )
+                  ELSE 
+                     zvwdmask(ji, jj) = ztwdmask(ji, jj+1)  
+                  END IF 
+                  zwy(ji, jj) = zvwdmask(ji,jj)*zwy(ji,jj) 
+                  vn_e(ji,jj) = zvwdmask(ji,jj)*vn_e(ji,jj)
+               END DO
+            END DO
+            !
+         ENDIF    
+         
+         ! Sum over sub-time-steps to compute advective velocities
+         za2 = wgtbtp2(jn)
+         un_adv(:,:) = un_adv(:,:) + za2 * zwx(:,:) * r1_e2u(:,:)
+         vn_adv(:,:) = vn_adv(:,:) + za2 * zwy(:,:) * r1_e1v(:,:)
+         
+         ! sum over sub-time-steps to decide which baroclinic velocities to set to zero (zuwdav2 is only used when ln_wd_dl_bc = True) 
+         IF ( ln_wd_dl_bc ) THEN
+            zuwdav2(:,:) = zuwdav2(:,:) + za2 * zuwdmask(:,:)
+            zvwdav2(:,:) = zvwdav2(:,:) + za2 * zvwdmask(:,:)
+         END IF 
+
+         ! Set next sea level:
+         DO jj = 2, jpjm1                                 
+            DO ji = fs_2, fs_jpim1   ! vector opt.
+               zhdiv(ji,jj) = (   zwx(ji,jj) - zwx(ji-1,jj)   &
+                  &             + zwy(ji,jj) - zwy(ji,jj-1)   ) * r1_e1e2t(ji,jj)
+            END DO
+         END DO
+         ssha_e(:,:) = (  sshn_e(:,:) - rdtbt * ( zssh_frc(:,:) + zhdiv(:,:) )  ) * ssmask(:,:)
+         
+         CALL lbc_lnk( ssha_e, 'T',  1._wp )
+
+         ! Duplicate sea level across open boundaries (this is only cosmetic if linssh=T)
+         IF( ln_bdy )   CALL bdy_ssh( ssha_e )
+#if defined key_agrif
+         IF( .NOT.Agrif_Root() )   CALL agrif_ssh_ts( jn )
+#endif
+         !  
+         ! Sea Surface Height at u-,v-points (vvl case only)
+         IF( .NOT.ln_linssh ) THEN                                
+            DO jj = 2, jpjm1
+               DO ji = 2, jpim1      ! NO Vector Opt.
+                  zsshu_a(ji,jj) = r1_2 * ssumask(ji,jj) * r1_e1e2u(ji,jj)    &
+                     &              * ( e1e2t(ji  ,jj  )  * ssha_e(ji  ,jj  ) &
+                     &              +   e1e2t(ji+1,jj  )  * ssha_e(ji+1,jj  ) )
+                  zsshv_a(ji,jj) = r1_2 * ssvmask(ji,jj) * r1_e1e2v(ji,jj)    &
+                     &              * ( e1e2t(ji  ,jj  )  * ssha_e(ji  ,jj  ) &
+                     &              +   e1e2t(ji  ,jj+1)  * ssha_e(ji  ,jj+1) )
+               END DO
+            END DO
+            CALL lbc_lnk_multi( zsshu_a, 'U', 1._wp, zsshv_a, 'V', 1._wp )
+         ENDIF   
+         !                                 
+         ! Half-step back interpolation of SSH for surface pressure computation:
+         !----------------------------------------------------------------------
+         IF ((jn==1).AND.ll_init) THEN
+           za0=1._wp                        ! Forward-backward
+           za1=0._wp                           
+           za2=0._wp
+           za3=0._wp
+         ELSEIF ((jn==2).AND.ll_init) THEN  ! AB2-AM3 Coefficients; bet=0 ; gam=-1/6 ; eps=1/12
+           za0= 1.0833333333333_wp          ! za0 = 1-gam-eps
+           za1=-0.1666666666666_wp          ! za1 = gam
+           za2= 0.0833333333333_wp          ! za2 = eps
+           za3= 0._wp              
+         ELSE                               ! AB3-AM4 Coefficients; bet=0.281105 ; eps=0.013 ; gam=0.0880 
+            IF (rn_bt_alpha==0._wp) THEN
+               za0=0.614_wp                 ! za0 = 1/2 +   gam + 2*eps
+               za1=0.285_wp                 ! za1 = 1/2 - 2*gam - 3*eps
+               za2=0.088_wp                 ! za2 = gam
+               za3=0.013_wp                 ! za3 = eps
+            ELSE
+               zepsilon = 0.00976186_wp - 0.13451357_wp * rn_bt_alpha
+               zgamma = 0.08344500_wp - 0.51358400_wp * rn_bt_alpha
+               za0 = 0.5_wp + zgamma + 2._wp * rn_bt_alpha + 2._wp * zepsilon
+               za1 = 1._wp - za0 - zgamma - zepsilon
+               za2 = zgamma
+               za3 = zepsilon
+            ENDIF 
+         ENDIF
+         !
+         zsshp2_e(:,:) = za0 *  ssha_e(:,:) + za1 *  sshn_e (:,:)   &
+            &          + za2 *  sshb_e(:,:) + za3 *  sshbb_e(:,:)
+         
+         IF( ln_wd_il ) THEN                   ! Calculating and applying W/D gravity filters
+           DO jj = 2, jpjm1
+              DO ji = 2, jpim1 
+                ll_tmp1 = MIN( zsshp2_e(ji,jj)               , zsshp2_e(ji+1,jj) ) >                &
+                     &    MAX(    -ht_0(ji,jj)               ,    -ht_0(ji+1,jj) ) .AND.            &
+                     &    MAX( zsshp2_e(ji,jj) + ht_0(ji,jj) , zsshp2_e(ji+1,jj) + ht_0(ji+1,jj) ) &
+                     &                                                             > rn_wdmin1 + rn_wdmin2
+                ll_tmp2 = (ABS(zsshp2_e(ji,jj)               - zsshp2_e(ji+1,jj))  > 1.E-12 ).AND.( &
+                     &    MAX( zsshp2_e(ji,jj)               , zsshp2_e(ji+1,jj) ) >                &
+                     &    MAX(    -ht_0(ji,jj)               ,    -ht_0(ji+1,jj) ) + rn_wdmin1 + rn_wdmin2 )
+   
+                IF(ll_tmp1) THEN
+                  zcpx(ji,jj) = 1.0_wp
+                ELSE IF(ll_tmp2) THEN
+                  ! no worries about  zsshp2_e(ji+1,jj) - zsshp2_e(ji  ,jj) = 0, it won't happen ! here
+                  zcpx(ji,jj) = ABS( (zsshp2_e(ji+1,jj) +     ht_0(ji+1,jj) - zsshp2_e(ji,jj) - ht_0(ji,jj)) &
+                              &    / (zsshp2_e(ji+1,jj) - zsshp2_e(ji  ,jj)) )
+                ELSE
+                  zcpx(ji,jj) = 0._wp
+                ENDIF
+                !
+                ll_tmp1 = MIN( zsshp2_e(ji,jj)               , zsshp2_e(ji,jj+1) ) >                &
+                     &    MAX(    -ht_0(ji,jj)               ,    -ht_0(ji,jj+1) ) .AND.            &
+                     &    MAX( zsshp2_e(ji,jj) + ht_0(ji,jj) , zsshp2_e(ji,jj+1) + ht_0(ji,jj+1) ) &
+                     &                                                             > rn_wdmin1 + rn_wdmin2
+                ll_tmp2 = (ABS(zsshp2_e(ji,jj)               - zsshp2_e(ji,jj+1))  > 1.E-12 ).AND.( &
+                     &    MAX( zsshp2_e(ji,jj)               , zsshp2_e(ji,jj+1) ) >                &
+                     &    MAX(    -ht_0(ji,jj)               ,    -ht_0(ji,jj+1) ) + rn_wdmin1 + rn_wdmin2 )
+   
+                IF(ll_tmp1) THEN
+                  zcpy(ji,jj) = 1.0_wp
+                ELSEIF(ll_tmp2) THEN
+                  ! no worries about  zsshp2_e(ji,jj+1) - zsshp2_e(ji,jj  ) = 0, it won't happen ! here
+                  zcpy(ji,jj) = ABS( (zsshp2_e(ji,jj+1) +     ht_0(ji,jj+1) - zsshp2_e(ji,jj) - ht_0(ji,jj)) &
+                              &    / (zsshp2_e(ji,jj+1) - zsshp2_e(ji,jj  )) )
+                ELSE
+                  zcpy(ji,jj) = 0._wp
+                ENDIF
+              END DO
+           END DO
+         ENDIF
+         !
+         ! Compute associated depths at U and V points:
+         IF( .NOT.ln_linssh  .AND. .NOT.ln_dynadv_vec ) THEN     !* Vector form
+            !                                        
+            DO jj = 2, jpjm1                            
+               DO ji = 2, jpim1
+                  zx1 = r1_2 * ssumask(ji  ,jj) *  r1_e1e2u(ji  ,jj)    &
+                     &      * ( e1e2t(ji  ,jj  ) * zsshp2_e(ji  ,jj)    &
+                     &      +   e1e2t(ji+1,jj  ) * zsshp2_e(ji+1,jj  ) )
+                  zy1 = r1_2 * ssvmask(ji  ,jj) *  r1_e1e2v(ji  ,jj  )  &
+                     &       * ( e1e2t(ji ,jj  ) * zsshp2_e(ji  ,jj  )  &
+                     &       +   e1e2t(ji ,jj+1) * zsshp2_e(ji  ,jj+1) )
+                  zhust_e(ji,jj) = hu_0(ji,jj) + zx1 
+                  zhvst_e(ji,jj) = hv_0(ji,jj) + zy1
+               END DO
+            END DO
+            !
+         ENDIF
+         !
+         ! Add Coriolis trend:
+         ! zwz array below or triads normally depend on sea level with ln_linssh=F and should be updated
+         ! at each time step. We however keep them constant here for optimization.
+         ! Recall that zwx and zwy arrays hold fluxes at this stage:
+         ! zwx(:,:) = e2u(:,:) * ua_e(:,:) * zhup2_e(:,:)   ! fluxes at jn+0.5
+         ! zwy(:,:) = e1v(:,:) * va_e(:,:) * zhvp2_e(:,:)
+         !
+         SELECT CASE( nvor_scheme )
+         CASE( np_ENT )             ! energy conserving scheme (t-point)
+         DO jj = 2, jpjm1
+            DO ji = 2, jpim1   ! vector opt.
+
+               z1_hu = ssumask(ji,jj) / ( hu_0(ji,jj) + zhup2_e(ji,jj) + 1._wp - ssumask(ji,jj) )
+               z1_hv = ssvmask(ji,jj) / ( hv_0(ji,jj) + zhvp2_e(ji,jj) + 1._wp - ssvmask(ji,jj) )
+            
+               zu_trd(ji,jj) = + r1_4 * r1_e1e2u(ji,jj) * z1_hu                   &
+                  &               * (  e1e2t(ji+1,jj)*zhtp2_e(ji+1,jj)*ff_t(ji+1,jj) * ( va_e(ji+1,jj) + va_e(ji+1,jj-1) )   &
+                  &                  + e1e2t(ji  ,jj)*zhtp2_e(ji  ,jj)*ff_t(ji  ,jj) * ( va_e(ji  ,jj) + va_e(ji  ,jj-1) )   )
+                  !
+               zv_trd(ji,jj) = - r1_4 * r1_e1e2v(ji,jj) * z1_hv                    &
+                  &               * (  e1e2t(ji,jj+1)*zhtp2_e(ji,jj+1)*ff_t(ji,jj+1) * ( ua_e(ji,jj+1) + ua_e(ji-1,jj+1) )   & 
+                  &                  + e1e2t(ji,jj  )*zhtp2_e(ji,jj  )*ff_t(ji,jj  ) * ( ua_e(ji,jj  ) + ua_e(ji-1,jj  ) )   ) 
+            END DO  
+         END DO  
+         !         
+         CASE( np_ENE, np_MIX )     ! energy conserving scheme (f-point)
+            DO jj = 2, jpjm1
+               DO ji = fs_2, fs_jpim1   ! vector opt.
+                  zy1 = ( zwy(ji  ,jj-1) + zwy(ji+1,jj-1) ) * r1_e1u(ji,jj)
+                  zy2 = ( zwy(ji  ,jj  ) + zwy(ji+1,jj  ) ) * r1_e1u(ji,jj)
+                  zx1 = ( zwx(ji-1,jj  ) + zwx(ji-1,jj+1) ) * r1_e2v(ji,jj)
+                  zx2 = ( zwx(ji  ,jj  ) + zwx(ji  ,jj+1) ) * r1_e2v(ji,jj)
+                  zu_trd(ji,jj) = r1_4 * ( zwz(ji  ,jj-1) * zy1 + zwz(ji,jj) * zy2 )
+                  zv_trd(ji,jj) =-r1_4 * ( zwz(ji-1,jj  ) * zx1 + zwz(ji,jj) * zx2 )
+               END DO
+            END DO
+            !
+         CASE( np_ENS )             ! enstrophy conserving scheme (f-point)
+            DO jj = 2, jpjm1
+               DO ji = fs_2, fs_jpim1   ! vector opt.
+                  zy1 =   r1_8 * ( zwy(ji  ,jj-1) + zwy(ji+1,jj-1) &
+                   &             + zwy(ji  ,jj  ) + zwy(ji+1,jj  ) ) * r1_e1u(ji,jj)
+                  zx1 = - r1_8 * ( zwx(ji-1,jj  ) + zwx(ji-1,jj+1) &
+                   &             + zwx(ji  ,jj  ) + zwx(ji  ,jj+1) ) * r1_e2v(ji,jj)
+                  zu_trd(ji,jj)  = zy1 * ( zwz(ji  ,jj-1) + zwz(ji,jj) )
+                  zv_trd(ji,jj)  = zx1 * ( zwz(ji-1,jj  ) + zwz(ji,jj) )
+               END DO
+            END DO
+            !
+         CASE( np_EET , np_EEN )   ! energy & enstrophy scheme (using e3t or e3f)
+            DO jj = 2, jpjm1
+               DO ji = fs_2, fs_jpim1   ! vector opt.
+                  zu_trd(ji,jj) = + r1_12 * r1_e1u(ji,jj) * (  ftne(ji,jj  ) * zwy(ji  ,jj  )  &
+                     &                                       + ftnw(ji+1,jj) * zwy(ji+1,jj  )  &
+                     &                                       + ftse(ji,jj  ) * zwy(ji  ,jj-1)  & 
+                     &                                       + ftsw(ji+1,jj) * zwy(ji+1,jj-1)  )
+                  zv_trd(ji,jj) = - r1_12 * r1_e2v(ji,jj) * (  ftsw(ji,jj+1) * zwx(ji-1,jj+1)  & 
+                     &                                       + ftse(ji,jj+1) * zwx(ji  ,jj+1)  &
+                     &                                       + ftnw(ji,jj  ) * zwx(ji-1,jj  )  & 
+                     &                                       + ftne(ji,jj  ) * zwx(ji  ,jj  )  )
+               END DO
+            END DO
+            ! 
+         END SELECT
+         !
+         ! Add tidal astronomical forcing if defined
+         IF ( ln_tide .AND. ln_tide_pot ) THEN
+            DO jj = 2, jpjm1
+               DO ji = fs_2, fs_jpim1   ! vector opt.
+                  zu_spg = grav * ( pot_astro(ji+1,jj) - pot_astro(ji,jj) ) * r1_e1u(ji,jj)
+                  zv_spg = grav * ( pot_astro(ji,jj+1) - pot_astro(ji,jj) ) * r1_e2v(ji,jj)
+                  zu_trd(ji,jj) = zu_trd(ji,jj) + zu_spg
+                  zv_trd(ji,jj) = zv_trd(ji,jj) + zv_spg
+               END DO
+            END DO
+         ENDIF
+         !
+         ! Add bottom stresses:
+!jth do implicitly instead
+         IF ( .NOT. ll_wd ) THEN ! Revert to explicit for bit comparison tests in non wad runs
+            DO jj = 2, jpjm1
+               DO ji = fs_2, fs_jpim1   ! vector opt.
+                  zu_trd(ji,jj) = zu_trd(ji,jj) + zCdU_u(ji,jj) * un_e(ji,jj) * hur_e(ji,jj)
+                  zv_trd(ji,jj) = zv_trd(ji,jj) + zCdU_v(ji,jj) * vn_e(ji,jj) * hvr_e(ji,jj)
+               END DO
+            END DO
+         ENDIF 
+         !
+         ! Surface pressure trend:
+         IF( ln_wd_il ) THEN
+           DO jj = 2, jpjm1
+              DO ji = 2, jpim1 
+                 ! Add surface pressure gradient
+                 zu_spg = - grav * ( zsshp2_e(ji+1,jj) - zsshp2_e(ji,jj) ) * r1_e1u(ji,jj)
+                 zv_spg = - grav * ( zsshp2_e(ji,jj+1) - zsshp2_e(ji,jj) ) * r1_e2v(ji,jj)
+                 zwx(ji,jj) = (1._wp - rn_scal_load) * zu_spg * zcpx(ji,jj) 
+                 zwy(ji,jj) = (1._wp - rn_scal_load) * zv_spg * zcpy(ji,jj)
+              END DO
+           END DO
+         ELSE
+           DO jj = 2, jpjm1
+              DO ji = fs_2, fs_jpim1   ! vector opt.
+                 ! Add surface pressure gradient
+                 zu_spg = - grav * ( zsshp2_e(ji+1,jj) - zsshp2_e(ji,jj) ) * r1_e1u(ji,jj)
+                 zv_spg = - grav * ( zsshp2_e(ji,jj+1) - zsshp2_e(ji,jj) ) * r1_e2v(ji,jj)
+                 zwx(ji,jj) = (1._wp - rn_scal_load) * zu_spg
+                 zwy(ji,jj) = (1._wp - rn_scal_load) * zv_spg
+              END DO
+           END DO
+         END IF
+
+         !
+         ! Set next velocities:
+         IF( ln_dynadv_vec .OR. ln_linssh ) THEN      !* Vector form
+            DO jj = 2, jpjm1
+               DO ji = fs_2, fs_jpim1   ! vector opt.
+                  ua_e(ji,jj) = (                                 un_e(ji,jj)   & 
+                            &     + rdtbt * (                      zwx(ji,jj)   &
+                            &                                 + zu_trd(ji,jj)   &
+                            &                                 + zu_frc(ji,jj) ) & 
+                            &   ) * ssumask(ji,jj)
+
+                  va_e(ji,jj) = (                                 vn_e(ji,jj)   &
+                            &     + rdtbt * (                      zwy(ji,jj)   &
+                            &                                 + zv_trd(ji,jj)   &
+                            &                                 + zv_frc(ji,jj) ) &
+                            &   ) * ssvmask(ji,jj)
+ 
+!jth implicit bottom friction:
+                  IF ( ll_wd ) THEN ! revert to explicit for bit comparison tests in non wad runs
+                     ua_e(ji,jj) =  ua_e(ji,jj) /(1.0 -   rdtbt * zCdU_u(ji,jj) * hur_e(ji,jj))
+                     va_e(ji,jj) =  va_e(ji,jj) /(1.0 -   rdtbt * zCdU_v(ji,jj) * hvr_e(ji,jj))
+                  ENDIF
+
+               END DO
+            END DO
+            !
+         ELSE                           !* Flux form
+            DO jj = 2, jpjm1
+               DO ji = fs_2, fs_jpim1   ! vector opt.
+
+                  zhura = hu_0(ji,jj) + zsshu_a(ji,jj)
+                  zhvra = hv_0(ji,jj) + zsshv_a(ji,jj)
+
+                  zhura = ssumask(ji,jj)/(zhura + 1._wp - ssumask(ji,jj))
+                  zhvra = ssvmask(ji,jj)/(zhvra + 1._wp - ssvmask(ji,jj))
+
+                  ua_e(ji,jj) = (                hu_e(ji,jj)  *   un_e(ji,jj)   & 
+                            &     + rdtbt * ( zhust_e(ji,jj)  *    zwx(ji,jj)   & 
+                            &               + zhup2_e(ji,jj)  * zu_trd(ji,jj)   &
+                            &               +    hu_n(ji,jj)  * zu_frc(ji,jj) ) &
+                            &   ) * zhura
+
+                  va_e(ji,jj) = (                hv_e(ji,jj)  *   vn_e(ji,jj)   &
+                            &     + rdtbt * ( zhvst_e(ji,jj)  *    zwy(ji,jj)   &
+                            &               + zhvp2_e(ji,jj)  * zv_trd(ji,jj)   &
+                            &               +    hv_n(ji,jj)  * zv_frc(ji,jj) ) &
+                            &   ) * zhvra
+               END DO
+            END DO
+         ENDIF
+
+         
+         IF( .NOT.ln_linssh ) THEN                     !* Update ocean depth (variable volume case only)
+            hu_e (:,:) = hu_0(:,:) + zsshu_a(:,:)
+            hv_e (:,:) = hv_0(:,:) + zsshv_a(:,:)
+            hur_e(:,:) = ssumask(:,:) / ( hu_e(:,:) + 1._wp - ssumask(:,:) )
+            hvr_e(:,:) = ssvmask(:,:) / ( hv_e(:,:) + 1._wp - ssvmask(:,:) )
+            !
+         ENDIF
+         !                                             !* domain lateral boundary
+         CALL lbc_lnk_multi( ua_e, 'U', -1._wp, va_e , 'V', -1._wp )
+         !
+         !                                                 ! open boundaries
+         IF( ln_bdy )   CALL bdy_dyn2d( jn, ua_e, va_e, un_e, vn_e, hur_e, hvr_e, ssha_e )
+#if defined key_agrif                                                           
+         IF( .NOT.Agrif_Root() )  CALL agrif_dyn_ts( jn )  ! Agrif
+#endif
+         !                                             !* Swap
+         !                                             !  ----
+         ubb_e  (:,:) = ub_e  (:,:)
+         ub_e   (:,:) = un_e  (:,:)
+         un_e   (:,:) = ua_e  (:,:)
+         !
+         vbb_e  (:,:) = vb_e  (:,:)
+         vb_e   (:,:) = vn_e  (:,:)
+         vn_e   (:,:) = va_e  (:,:)
+         !
+         sshbb_e(:,:) = sshb_e(:,:)
+         sshb_e (:,:) = sshn_e(:,:)
+         sshn_e (:,:) = ssha_e(:,:)
+
+         !                                             !* Sum over whole bt loop
+         !                                             !  ----------------------
+         za1 = wgtbtp1(jn)                                    
+         IF( ln_dynadv_vec .OR. ln_linssh ) THEN    ! Sum velocities
+            ua_b  (:,:) = ua_b  (:,:) + za1 * ua_e  (:,:) 
+            va_b  (:,:) = va_b  (:,:) + za1 * va_e  (:,:) 
+         ELSE                                       ! Sum transports
+            IF ( .NOT.ln_wd_dl ) THEN  
+               ua_b  (:,:) = ua_b  (:,:) + za1 * ua_e  (:,:) * hu_e (:,:)
+               va_b  (:,:) = va_b  (:,:) + za1 * va_e  (:,:) * hv_e (:,:)
+            ELSE 
+               ua_b  (:,:) = ua_b  (:,:) + za1 * ua_e  (:,:) * hu_e (:,:) * zuwdmask(:,:)
+               va_b  (:,:) = va_b  (:,:) + za1 * va_e  (:,:) * hv_e (:,:) * zvwdmask(:,:)
+            END IF 
+         ENDIF
+         !                                          ! Sum sea level
+         ssha(:,:) = ssha(:,:) + za1 * ssha_e(:,:)
+
+         !                                                 ! ==================== !
+      END DO                                               !        end loop      !
+      !                                                    ! ==================== !
+      ! -----------------------------------------------------------------------------
+      ! Phase 3. update the general trend with the barotropic trend
+      ! -----------------------------------------------------------------------------
+      !
+      ! Set advection velocity correction:
+      IF (ln_bt_fw) THEN
+         zwx(:,:) = un_adv(:,:)
+         zwy(:,:) = vn_adv(:,:)
+         IF( .NOT.( kt == nit000 .AND. neuler==0 ) ) THEN
+            un_adv(:,:) = r1_2 * ( ub2_b(:,:) + zwx(:,:) - atfp * un_bf(:,:) )
+            vn_adv(:,:) = r1_2 * ( vb2_b(:,:) + zwy(:,:) - atfp * vn_bf(:,:) )
+            !
+            ! Update corrective fluxes for next time step:
+            un_bf(:,:)  = atfp * un_bf(:,:) + (zwx(:,:) - ub2_b(:,:))
+            vn_bf(:,:)  = atfp * vn_bf(:,:) + (zwy(:,:) - vb2_b(:,:))
+         ELSE
+            un_bf(:,:) = 0._wp
+            vn_bf(:,:) = 0._wp 
+         END IF         
+         ! Save integrated transport for next computation
+         ub2_b(:,:) = zwx(:,:)
+         vb2_b(:,:) = zwy(:,:)
+      ENDIF
+
+
+      !
+      ! Update barotropic trend:
+      IF( ln_dynadv_vec .OR. ln_linssh ) THEN
+         DO jk=1,jpkm1
+            ua(:,:,jk) = ua(:,:,jk) + ( ua_b(:,:) - ub_b(:,:) ) * r1_2dt_b
+            va(:,:,jk) = va(:,:,jk) + ( va_b(:,:) - vb_b(:,:) ) * r1_2dt_b
+         END DO
+      ELSE
+         ! At this stage, ssha has been corrected: compute new depths at velocity points
+         DO jj = 1, jpjm1
+            DO ji = 1, jpim1      ! NO Vector Opt.
+               zsshu_a(ji,jj) = r1_2 * ssumask(ji,jj)  * r1_e1e2u(ji,jj) &
+                  &              * ( e1e2t(ji  ,jj) * ssha(ji  ,jj)      &
+                  &              +   e1e2t(ji+1,jj) * ssha(ji+1,jj) )
+               zsshv_a(ji,jj) = r1_2 * ssvmask(ji,jj)  * r1_e1e2v(ji,jj) &
+                  &              * ( e1e2t(ji,jj  ) * ssha(ji,jj  )      &
+                  &              +   e1e2t(ji,jj+1) * ssha(ji,jj+1) )
+            END DO
+         END DO
+         CALL lbc_lnk_multi( zsshu_a, 'U', 1._wp, zsshv_a, 'V', 1._wp ) ! Boundary conditions
+         !
+         DO jk=1,jpkm1
+            ua(:,:,jk) = ua(:,:,jk) + r1_hu_n(:,:) * ( ua_b(:,:) - ub_b(:,:) * hu_b(:,:) ) * r1_2dt_b
+            va(:,:,jk) = va(:,:,jk) + r1_hv_n(:,:) * ( va_b(:,:) - vb_b(:,:) * hv_b(:,:) ) * r1_2dt_b
+         END DO
+         ! Save barotropic velocities not transport:
+         ua_b(:,:) =  ua_b(:,:) / ( hu_0(:,:) + zsshu_a(:,:) + 1._wp - ssumask(:,:) )
+         va_b(:,:) =  va_b(:,:) / ( hv_0(:,:) + zsshv_a(:,:) + 1._wp - ssvmask(:,:) )
+      ENDIF
+
+
+      ! Correct velocities so that the barotropic velocity equals (un_adv, vn_adv) (in all cases)  
+      DO jk = 1, jpkm1
+         un(:,:,jk) = ( un(:,:,jk) + un_adv(:,:)*r1_hu_n(:,:) - un_b(:,:) ) * umask(:,:,jk)
+         vn(:,:,jk) = ( vn(:,:,jk) + vn_adv(:,:)*r1_hv_n(:,:) - vn_b(:,:) ) * vmask(:,:,jk)
+      END DO
+
+      IF ( ln_wd_dl .and. ln_wd_dl_bc) THEN 
+         DO jk = 1, jpkm1
+            un(:,:,jk) = ( un_adv(:,:)*r1_hu_n(:,:) &
+                       & + zuwdav2(:,:)*(un(:,:,jk) - un_adv(:,:)*r1_hu_n(:,:)) ) * umask(:,:,jk) 
+            vn(:,:,jk) = ( vn_adv(:,:)*r1_hv_n(:,:) & 
+                       & + zvwdav2(:,:)*(vn(:,:,jk) - vn_adv(:,:)*r1_hv_n(:,:)) ) * vmask(:,:,jk)  
+         END DO
+      END IF 
+
+      
+      CALL iom_put(  "ubar", un_adv(:,:)*r1_hu_n(:,:) )    ! barotropic i-current
+      CALL iom_put(  "vbar", vn_adv(:,:)*r1_hv_n(:,:) )    ! barotropic i-current
+      !
+#if defined key_agrif
+      ! Save time integrated fluxes during child grid integration
+      ! (used to update coarse grid transports at next time step)
+      !
+      IF( .NOT.Agrif_Root() .AND. ln_bt_fw ) THEN
+         IF( Agrif_NbStepint() == 0 ) THEN
+            ub2_i_b(:,:) = 0._wp
+            vb2_i_b(:,:) = 0._wp
+         END IF
+         !
+         za1 = 1._wp / REAL(Agrif_rhot(), wp)
+         ub2_i_b(:,:) = ub2_i_b(:,:) + za1 * ub2_b(:,:)
+         vb2_i_b(:,:) = vb2_i_b(:,:) + za1 * vb2_b(:,:)
+      ENDIF
+#endif      
+      !                                   !* write time-spliting arrays in the restart
+      IF( lrst_oce .AND.ln_bt_fw )   CALL ts_rst( kt, 'WRITE' )
+      !
+      IF( ln_wd_il )   DEALLOCATE( zcpx, zcpy )
+      IF( ln_wd_dl )   DEALLOCATE( ztwdmask, zuwdmask, zvwdmask, zuwdav2, zvwdav2 )
+      !
+      IF( ln_diatmb ) THEN
+         CALL iom_put( "baro_u" , un_b*ssumask(:,:)+zmdi*(1.-ssumask(:,:) ) )  ! Barotropic  U Velocity
+         CALL iom_put( "baro_v" , vn_b*ssvmask(:,:)+zmdi*(1.-ssvmask(:,:) ) )  ! Barotropic  V Velocity
+      ENDIF
+      !
+   END SUBROUTINE dyn_spg_ts
+
+
+   SUBROUTINE ts_wgt( ll_av, ll_fw, jpit, zwgt1, zwgt2)
+      !!---------------------------------------------------------------------
+      !!                   ***  ROUTINE ts_wgt  ***
+      !!
+      !! ** Purpose : Set time-splitting weights for temporal averaging (or not)
+      !!----------------------------------------------------------------------
+      LOGICAL, INTENT(in) ::   ll_av      ! temporal averaging=.true.
+      LOGICAL, INTENT(in) ::   ll_fw      ! forward time splitting =.true.
+      INTEGER, INTENT(inout) :: jpit      ! cycle length    
+      REAL(wp), DIMENSION(3*nn_baro), INTENT(inout) ::   zwgt1, & ! Primary weights
+                                                         zwgt2    ! Secondary weights
+      
+      INTEGER ::  jic, jn, ji                      ! temporary integers
+      REAL(wp) :: za1, za2
+      !!----------------------------------------------------------------------
+
+      zwgt1(:) = 0._wp
+      zwgt2(:) = 0._wp
+
+      ! Set time index when averaged value is requested
+      IF (ll_fw) THEN 
+         jic = nn_baro
+      ELSE
+         jic = 2 * nn_baro
+      ENDIF
+
+      ! Set primary weights:
+      IF (ll_av) THEN
+           ! Define simple boxcar window for primary weights 
+           ! (width = nn_baro, centered around jic)     
+         SELECT CASE ( nn_bt_flt )
+              CASE( 0 )  ! No averaging
+                 zwgt1(jic) = 1._wp
+                 jpit = jic
+
+              CASE( 1 )  ! Boxcar, width = nn_baro
+                 DO jn = 1, 3*nn_baro
+                    za1 = ABS(float(jn-jic))/float(nn_baro) 
+                    IF (za1 < 0.5_wp) THEN
+                      zwgt1(jn) = 1._wp
+                      jpit = jn
+                    ENDIF
+                 ENDDO
+
+              CASE( 2 )  ! Boxcar, width = 2 * nn_baro
+                 DO jn = 1, 3*nn_baro
+                    za1 = ABS(float(jn-jic))/float(nn_baro) 
+                    IF (za1 < 1._wp) THEN
+                      zwgt1(jn) = 1._wp
+                      jpit = jn
+                    ENDIF
+                 ENDDO
+              CASE DEFAULT   ;   CALL ctl_stop( 'unrecognised value for nn_bt_flt' )
+         END SELECT
+
+      ELSE ! No time averaging
+         zwgt1(jic) = 1._wp
+         jpit = jic
+      ENDIF
+    
+      ! Set secondary weights
+      DO jn = 1, jpit
+        DO ji = jn, jpit
+             zwgt2(jn) = zwgt2(jn) + zwgt1(ji)
+        END DO
+      END DO
+
+      ! Normalize weigths:
+      za1 = 1._wp / SUM(zwgt1(1:jpit))
+      za2 = 1._wp / SUM(zwgt2(1:jpit))
+      DO jn = 1, jpit
+        zwgt1(jn) = zwgt1(jn) * za1
+        zwgt2(jn) = zwgt2(jn) * za2
+      END DO
+      !
+   END SUBROUTINE ts_wgt
+
+
+   SUBROUTINE ts_rst( kt, cdrw )
+      !!---------------------------------------------------------------------
+      !!                   ***  ROUTINE ts_rst  ***
+      !!
+      !! ** Purpose : Read or write time-splitting arrays in restart file
+      !!----------------------------------------------------------------------
+      INTEGER         , INTENT(in) ::   kt     ! ocean time-step
+      CHARACTER(len=*), INTENT(in) ::   cdrw   ! "READ"/"WRITE" flag
+      !!----------------------------------------------------------------------
+      !
+      IF( TRIM(cdrw) == 'READ' ) THEN        ! Read/initialise 
+         !                                   ! ---------------
+         IF( ln_rstart .AND. ln_bt_fw ) THEN    !* Read the restart file
+            CALL iom_get( numror, jpdom_autoglo, 'ub2_b'  , ub2_b  (:,:), ldxios = lrxios )   
+            CALL iom_get( numror, jpdom_autoglo, 'vb2_b'  , vb2_b  (:,:), ldxios = lrxios ) 
+            CALL iom_get( numror, jpdom_autoglo, 'un_bf'  , un_bf  (:,:), ldxios = lrxios )   
+            CALL iom_get( numror, jpdom_autoglo, 'vn_bf'  , vn_bf  (:,:), ldxios = lrxios ) 
+            IF( .NOT.ln_bt_av ) THEN
+               CALL iom_get( numror, jpdom_autoglo, 'sshbb_e'  , sshbb_e(:,:), ldxios = lrxios )   
+               CALL iom_get( numror, jpdom_autoglo, 'ubb_e'    ,   ubb_e(:,:), ldxios = lrxios )   
+               CALL iom_get( numror, jpdom_autoglo, 'vbb_e'    ,   vbb_e(:,:), ldxios = lrxios )
+               CALL iom_get( numror, jpdom_autoglo, 'sshb_e'   ,  sshb_e(:,:), ldxios = lrxios ) 
+               CALL iom_get( numror, jpdom_autoglo, 'ub_e'     ,    ub_e(:,:), ldxios = lrxios )   
+               CALL iom_get( numror, jpdom_autoglo, 'vb_e'     ,    vb_e(:,:), ldxios = lrxios )
+            ENDIF
+#if defined key_agrif
+            ! Read time integrated fluxes
+            IF ( .NOT.Agrif_Root() ) THEN
+               CALL iom_get( numror, jpdom_autoglo, 'ub2_i_b'  , ub2_i_b(:,:), ldxios = lrxios )   
+               CALL iom_get( numror, jpdom_autoglo, 'vb2_i_b'  , vb2_i_b(:,:), ldxios = lrxios )
+            ENDIF
+#endif
+         ELSE                                   !* Start from rest
+            IF(lwp) WRITE(numout,*)
+            IF(lwp) WRITE(numout,*) '   ==>>>   start from rest: set barotropic values to 0'
+            ub2_b (:,:) = 0._wp   ;   vb2_b (:,:) = 0._wp   ! used in the 1st interpol of agrif
+            un_adv(:,:) = 0._wp   ;   vn_adv(:,:) = 0._wp   ! used in the 1st interpol of agrif
+            un_bf (:,:) = 0._wp   ;   vn_bf (:,:) = 0._wp   ! used in the 1st update   of agrif
+#if defined key_agrif
+            IF ( .NOT.Agrif_Root() ) THEN
+               ub2_i_b(:,:) = 0._wp   ;   vb2_i_b(:,:) = 0._wp   ! used in the 1st update of agrif
+            ENDIF
+#endif
+         ENDIF
+         !
+      ELSEIF( TRIM(cdrw) == 'WRITE' ) THEN   ! Create restart file
+         !                                   ! -------------------
+         IF(lwp) WRITE(numout,*) '---- ts_rst ----'
+         IF( lwxios ) CALL iom_swap(      cwxios_context          )
+         CALL iom_rstput( kt, nitrst, numrow, 'ub2_b'   , ub2_b  (:,:), ldxios = lwxios )
+         CALL iom_rstput( kt, nitrst, numrow, 'vb2_b'   , vb2_b  (:,:), ldxios = lwxios )
+         CALL iom_rstput( kt, nitrst, numrow, 'un_bf'   , un_bf  (:,:), ldxios = lwxios )
+         CALL iom_rstput( kt, nitrst, numrow, 'vn_bf'   , vn_bf  (:,:), ldxios = lwxios )
+         !
+         IF (.NOT.ln_bt_av) THEN
+            CALL iom_rstput( kt, nitrst, numrow, 'sshbb_e'  , sshbb_e(:,:), ldxios = lwxios ) 
+            CALL iom_rstput( kt, nitrst, numrow, 'ubb_e'    ,   ubb_e(:,:), ldxios = lwxios )
+            CALL iom_rstput( kt, nitrst, numrow, 'vbb_e'    ,   vbb_e(:,:), ldxios = lwxios )
+            CALL iom_rstput( kt, nitrst, numrow, 'sshb_e'   ,  sshb_e(:,:), ldxios = lwxios )
+            CALL iom_rstput( kt, nitrst, numrow, 'ub_e'     ,    ub_e(:,:), ldxios = lwxios )
+            CALL iom_rstput( kt, nitrst, numrow, 'vb_e'     ,    vb_e(:,:), ldxios = lwxios )
+         ENDIF
+#if defined key_agrif
+         ! Save time integrated fluxes
+         IF ( .NOT.Agrif_Root() ) THEN
+            CALL iom_rstput( kt, nitrst, numrow, 'ub2_i_b'  , ub2_i_b(:,:), ldxios = lwxios )
+            CALL iom_rstput( kt, nitrst, numrow, 'vb2_i_b'  , vb2_i_b(:,:), ldxios = lwxios )
+         ENDIF
+#endif
+         IF( lwxios ) CALL iom_swap(      cxios_context          )
+      ENDIF
+      !
+   END SUBROUTINE ts_rst
+
+
+   SUBROUTINE dyn_spg_ts_init
+      !!---------------------------------------------------------------------
+      !!                   ***  ROUTINE dyn_spg_ts_init  ***
+      !!
+      !! ** Purpose : Set time splitting options
+      !!----------------------------------------------------------------------
+      INTEGER  ::   ji ,jj              ! dummy loop indices
+      REAL(wp) ::   zxr2, zyr2, zcmax   ! local scalar
+      REAL(wp), DIMENSION(jpi,jpj) ::   zcu
+      !!----------------------------------------------------------------------
+      !
+      ! Max courant number for ext. grav. waves
+      !
+      DO jj = 1, jpj
+         DO ji =1, jpi
+            zxr2 = r1_e1t(ji,jj) * r1_e1t(ji,jj)
+            zyr2 = r1_e2t(ji,jj) * r1_e2t(ji,jj)
+            zcu(ji,jj) = SQRT( grav * MAX(ht_0(ji,jj),0._wp) * (zxr2 + zyr2) )
+         END DO
+      END DO
+      !
+      zcmax = MAXVAL( zcu(:,:) )
+      IF( lk_mpp )   CALL mpp_max( zcmax )
+
+      ! Estimate number of iterations to satisfy a max courant number= rn_bt_cmax
+      IF( ln_bt_auto )   nn_baro = CEILING( rdt / rn_bt_cmax * zcmax)
+      
+      rdtbt = rdt / REAL( nn_baro , wp )
+      zcmax = zcmax * rdtbt
+      ! Print results
+      IF(lwp) WRITE(numout,*)
+      IF(lwp) WRITE(numout,*) 'dyn_spg_ts_init : split-explicit free surface'
+      IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~~~'
+      IF( ln_bt_auto ) THEN
+         IF(lwp) WRITE(numout,*) '     ln_ts_auto =.true. Automatically set nn_baro '
+         IF(lwp) WRITE(numout,*) '     Max. courant number allowed: ', rn_bt_cmax
+      ELSE
+         IF(lwp) WRITE(numout,*) '     ln_ts_auto=.false.: Use nn_baro in namelist   nn_baro = ', nn_baro
+      ENDIF
+
+      IF(ln_bt_av) THEN
+         IF(lwp) WRITE(numout,*) '     ln_bt_av =.true.  ==> Time averaging over nn_baro time steps is on '
+      ELSE
+         IF(lwp) WRITE(numout,*) '     ln_bt_av =.false. => No time averaging of barotropic variables '
+      ENDIF
+      !
+      !
+      IF(ln_bt_fw) THEN
+         IF(lwp) WRITE(numout,*) '     ln_bt_fw=.true.  => Forward integration of barotropic variables '
+      ELSE
+         IF(lwp) WRITE(numout,*) '     ln_bt_fw =.false.=> Centred integration of barotropic variables '
+      ENDIF
+      !
+#if defined key_agrif
+      ! Restrict the use of Agrif to the forward case only
+!!!      IF( .NOT.ln_bt_fw .AND. .NOT.Agrif_Root() )   CALL ctl_stop( 'AGRIF not implemented if ln_bt_fw=.FALSE.' )
+#endif
+      !
+      IF(lwp) WRITE(numout,*)    '     Time filter choice, nn_bt_flt: ', nn_bt_flt
+      SELECT CASE ( nn_bt_flt )
+         CASE( 0 )      ;   IF(lwp) WRITE(numout,*) '           Dirac'
+         CASE( 1 )      ;   IF(lwp) WRITE(numout,*) '           Boxcar: width = nn_baro'
+         CASE( 2 )      ;   IF(lwp) WRITE(numout,*) '           Boxcar: width = 2*nn_baro' 
+         CASE DEFAULT   ;   CALL ctl_stop( 'unrecognised value for nn_bt_flt: should 0,1, or 2' )
+      END SELECT
+      !
+      IF(lwp) WRITE(numout,*) ' '
+      IF(lwp) WRITE(numout,*) '     nn_baro = ', nn_baro
+      IF(lwp) WRITE(numout,*) '     Barotropic time step [s] is :', rdtbt
+      IF(lwp) WRITE(numout,*) '     Maximum Courant number is   :', zcmax
+      !
+      IF(lwp) WRITE(numout,*)    '     Time diffusion parameter rn_bt_alpha: ', rn_bt_alpha
+      IF ((ln_bt_av.AND.nn_bt_flt/=0).AND.(rn_bt_alpha>0._wp)) THEN
+         CALL ctl_stop( 'dynspg_ts ERROR: if rn_bt_alpha > 0, remove temporal averaging' )
+      ENDIF
+      !
+      IF( .NOT.ln_bt_av .AND. .NOT.ln_bt_fw ) THEN
+         CALL ctl_stop( 'dynspg_ts ERROR: No time averaging => only forward integration is possible' )
+      ENDIF
+      IF( zcmax>0.9_wp ) THEN
+         CALL ctl_stop( 'dynspg_ts ERROR: Maximum Courant number is greater than 0.9: Inc. nn_baro !' )          
+      ENDIF
+      !
+      !                             ! Allocate time-splitting arrays
+      IF( dyn_spg_ts_alloc() /= 0    )   CALL ctl_stop('STOP', 'dyn_spg_init: failed to allocate dynspg_ts  arrays' )
+      !
+      !                             ! read restart when needed
+      CALL ts_rst( nit000, 'READ' )
+      !
+      IF( lwxios ) THEN
+! define variables in restart file when writing with XIOS
+         CALL iom_set_rstw_var_active('ub2_b')
+         CALL iom_set_rstw_var_active('vb2_b')
+         CALL iom_set_rstw_var_active('un_bf')
+         CALL iom_set_rstw_var_active('vn_bf')
+         !
+         IF (.NOT.ln_bt_av) THEN
+            CALL iom_set_rstw_var_active('sshbb_e')
+            CALL iom_set_rstw_var_active('ubb_e')
+            CALL iom_set_rstw_var_active('vbb_e')
+            CALL iom_set_rstw_var_active('sshb_e')
+            CALL iom_set_rstw_var_active('ub_e')
+            CALL iom_set_rstw_var_active('vb_e')
+         ENDIF
+#if defined key_agrif
+         ! Save time integrated fluxes
+         IF ( .NOT.Agrif_Root() ) THEN
+            CALL iom_set_rstw_var_active('ub2_i_b')
+            CALL iom_set_rstw_var_active('vb2_i_b')
+         ENDIF
+#endif
+      ENDIF
+      !
+   END SUBROUTINE dyn_spg_ts_init
+
+   !!======================================================================
+END MODULE dynspg_ts
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DYN/dynvor.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DYN/dynvor.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DYN/dynvor.F90	(revision 9570)
@@ -0,0 +1,935 @@
+MODULE dynvor
+   !!======================================================================
+   !!                       ***  MODULE  dynvor  ***
+   !! Ocean dynamics: Update the momentum trend with the relative and
+   !!                 planetary vorticity trends
+   !!======================================================================
+   !! History :  OPA  ! 1989-12  (P. Andrich)  vor_ens: Original code
+   !!            5.0  ! 1991-11  (G. Madec)  vor_ene, vor_mix: Original code
+   !!            6.0  ! 1996-01  (G. Madec)  s-coord, suppress work arrays
+   !!   NEMO     0.5  ! 2002-08  (G. Madec)  F90: Free form and module
+   !!            1.0  ! 2004-02  (G. Madec)  vor_een: Original code
+   !!             -   ! 2003-08  (G. Madec)  add vor_ctl
+   !!             -   ! 2005-11  (G. Madec)  add dyn_vor (new step architecture)
+   !!            2.0  ! 2006-11  (G. Madec)  flux form advection: add metric term
+   !!            3.2  ! 2009-04  (R. Benshila)  vvl: correction of een scheme
+   !!            3.3  ! 2010-10  (C. Ethe, G. Madec)  reorganisation of initialisation phase
+   !!            3.7  ! 2014-04  (G. Madec)  trend simplification: suppress jpdyn_trd_dat vorticity 
+   !!             -   ! 2014-06  (G. Madec)  suppression of velocity curl from in-core memory
+   !!             -   ! 2016-12  (G. Madec, E. Clementi) add Stokes-Coriolis trends (ln_stcor=T)
+   !!            4.0  ! 2017-07  (G. Madec)  linear dynamics + trends diag. with Stokes-Coriolis
+   !!             -   ! 2018-03  (G. Madec)  add two new schemes (ln_dynvor_enT and ln_dynvor_eet)
+   !!             -   ! 2018-04  (G. Madec)  add pre-computed gradient for metric term calculation
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   dyn_vor       : Update the momentum trend with the vorticity trend
+   !!       vor_ens   : enstrophy conserving scheme       (ln_dynvor_ens=T)
+   !!       vor_ene   : energy conserving scheme          (ln_dynvor_ene=T)
+   !!       vor_een   : energy and enstrophy conserving   (ln_dynvor_een=T)
+   !!   dyn_vor_init  : set and control of the different vorticity option
+   !!----------------------------------------------------------------------
+   USE oce            ! ocean dynamics and tracers
+   USE dom_oce        ! ocean space and time domain
+   USE dommsk         ! ocean mask
+   USE dynadv         ! momentum advection
+   USE trd_oce        ! trends: ocean variables
+   USE trddyn         ! trend manager: dynamics
+   USE sbcwave        ! Surface Waves (add Stokes-Coriolis force)
+   USE sbc_oce , ONLY : ln_stcor    ! use Stoke-Coriolis force
+   !
+   USE lbclnk         ! ocean lateral boundary conditions (or mpp link)
+   USE prtctl         ! Print control
+   USE in_out_manager ! I/O manager
+   USE lib_mpp        ! MPP library
+   USE timing         ! Timing
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   dyn_vor        ! routine called by step.F90
+   PUBLIC   dyn_vor_init   ! routine called by nemogcm.F90
+
+   !                                   !!* Namelist namdyn_vor: vorticity term
+   LOGICAL, PUBLIC ::   ln_dynvor_ens   !: enstrophy conserving scheme          (ENS)
+   LOGICAL, PUBLIC ::   ln_dynvor_ene   !: f-point energy conserving scheme     (ENE)
+   LOGICAL, PUBLIC ::   ln_dynvor_enT   !: t-point energy conserving scheme     (ENT)
+   LOGICAL, PUBLIC ::   ln_dynvor_eeT   !: t-point energy conserving scheme     (EET)
+   LOGICAL, PUBLIC ::   ln_dynvor_een   !: energy & enstrophy conserving scheme (EEN)
+   INTEGER, PUBLIC ::      nn_een_e3f      !: e3f=masked averaging of e3t divided by 4 (=0) or by the sum of mask (=1)
+   LOGICAL, PUBLIC ::   ln_dynvor_mix   !: mixed scheme                         (MIX)
+   LOGICAL, PUBLIC ::   ln_dynvor_msk   !: vorticity multiplied by fmask (=T) or not (=F) (all vorticity schemes)
+
+   INTEGER, PUBLIC ::   nvor_scheme     !: choice of the type of advection scheme
+   !                                       ! associated indices:
+   INTEGER, PUBLIC, PARAMETER ::   np_ENS = 0   ! ENS scheme
+   INTEGER, PUBLIC, PARAMETER ::   np_ENE = 1   ! ENE scheme
+   INTEGER, PUBLIC, PARAMETER ::   np_ENT = 2   ! ENT scheme (t-point vorticity)
+   INTEGER, PUBLIC, PARAMETER ::   np_EET = 3   ! EET scheme (EEN using e3t)
+   INTEGER, PUBLIC, PARAMETER ::   np_EEN = 4   ! EEN scheme
+   INTEGER, PUBLIC, PARAMETER ::   np_MIX = 5   ! MIX scheme
+
+   INTEGER ::   ncor, nrvm, ntot   ! choice of calculated vorticity 
+   !                               ! associated indices:
+   INTEGER, PUBLIC, PARAMETER ::   np_COR = 1         ! Coriolis (planetary)
+   INTEGER, PUBLIC, PARAMETER ::   np_RVO = 2         ! relative vorticity
+   INTEGER, PUBLIC, PARAMETER ::   np_MET = 3         ! metric term
+   INTEGER, PUBLIC, PARAMETER ::   np_CRV = 4         ! relative + planetary (total vorticity)
+   INTEGER, PUBLIC, PARAMETER ::   np_CME = 5         ! Coriolis + metric term
+
+   REAL(wp), ALLOCATABLE, DIMENSION(:,:) ::   di_e2u_2        ! = di(e2u)/2          used in T-point metric term calculation
+   REAL(wp), ALLOCATABLE, DIMENSION(:,:) ::   dj_e1v_2        ! = dj(e1v)/2           -        -      -       - 
+   REAL(wp), ALLOCATABLE, DIMENSION(:,:) ::   di_e2v_2e1e2f   ! = di(e2u)/(2*e1e2f)  used in F-point metric term calculation
+   REAL(wp), ALLOCATABLE, DIMENSION(:,:) ::   dj_e1u_2e1e2f   ! = dj(e1v)/(2*e1e2f)   -        -      -       - 
+   
+   REAL(wp) ::   r1_4  = 0.250_wp         ! =1/4
+   REAL(wp) ::   r1_8  = 0.125_wp         ! =1/8
+   REAL(wp) ::   r1_12 = 1._wp / 12._wp   ! 1/12
+   
+   !! * Substitutions
+#  include "vectopt_loop_substitute.h90"
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 4.0 , NEMO Consortium (2017)
+   !! $Id$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE dyn_vor( kt )
+      !!----------------------------------------------------------------------
+      !!
+      !! ** Purpose :   compute the lateral ocean tracer physics.
+      !!
+      !! ** Action : - Update (ua,va) with the now vorticity term trend
+      !!             - save the trends in (ztrdu,ztrdv) in 2 parts (relative
+      !!               and planetary vorticity trends) and send them to trd_dyn 
+      !!               for futher diagnostics (l_trddyn=T)
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT( in ) ::   kt   ! ocean time-step index
+      !
+      REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) ::  ztrdu, ztrdv
+      !!----------------------------------------------------------------------
+      !
+      IF( ln_timing )   CALL timing_start('dyn_vor')
+      !
+      IF( l_trddyn ) THEN     !==  trend diagnostics case : split the added trend in two parts  ==!
+         !
+         ALLOCATE( ztrdu(jpi,jpj,jpk), ztrdv(jpi,jpj,jpk) )
+         !
+         ztrdu(:,:,:) = ua(:,:,:)            !* planetary vorticity trend (including Stokes-Coriolis force)
+         ztrdv(:,:,:) = va(:,:,:)
+         SELECT CASE( nvor_scheme )
+         CASE( np_ENS )           ;   CALL vor_ens( kt, ncor, un , vn , ua, va )   ! enstrophy conserving scheme
+            IF( ln_stcor )            CALL vor_ens( kt, ncor, usd, vsd, ua, va )   ! add the Stokes-Coriolis trend
+         CASE( np_ENE, np_MIX )   ;   CALL vor_ene( kt, ncor, un , vn , ua, va )   ! energy conserving scheme
+            IF( ln_stcor )            CALL vor_ene( kt, ncor, usd, vsd, ua, va )   ! add the Stokes-Coriolis trend
+         CASE( np_ENT )           ;   CALL vor_enT( kt, ncor, un , vn , ua, va )   ! energy conserving scheme (T-pts)
+            IF( ln_stcor )            CALL vor_enT( kt, ncor, usd, vsd, ua, va )   ! add the Stokes-Coriolis trend
+         CASE( np_EET )           ;   CALL vor_eeT( kt, ncor, un , vn , ua, va )   ! energy conserving scheme (een with e3t)
+            IF( ln_stcor )            CALL vor_eeT( kt, ncor, usd, vsd, ua, va )   ! add the Stokes-Coriolis trend
+         CASE( np_EEN )           ;   CALL vor_een( kt, ncor, un , vn , ua, va )   ! energy & enstrophy scheme
+            IF( ln_stcor )            CALL vor_een( kt, ncor, usd, vsd, ua, va )   ! add the Stokes-Coriolis trend
+         END SELECT
+         ztrdu(:,:,:) = ua(:,:,:) - ztrdu(:,:,:)
+         ztrdv(:,:,:) = va(:,:,:) - ztrdv(:,:,:)
+         CALL trd_dyn( ztrdu, ztrdv, jpdyn_pvo, kt )
+         !
+         IF( n_dynadv /= np_LIN_dyn ) THEN   !* relative vorticity or metric trend (only in non-linear case)
+            ztrdu(:,:,:) = ua(:,:,:)
+            ztrdv(:,:,:) = va(:,:,:)
+            SELECT CASE( nvor_scheme )
+            CASE( np_ENT )           ;   CALL vor_enT( kt, nrvm, un , vn , ua, va )  ! energy conserving scheme (T-pts)
+            CASE( np_EET )           ;   CALL vor_eeT( kt, nrvm, un , vn , ua, va )  ! energy conserving scheme (een with e3t)
+            CASE( np_ENE )           ;   CALL vor_ene( kt, nrvm, un , vn , ua, va )  ! energy conserving scheme
+            CASE( np_ENS, np_MIX )   ;   CALL vor_ens( kt, nrvm, un , vn , ua, va )  ! enstrophy conserving scheme
+            CASE( np_EEN )           ;   CALL vor_een( kt, nrvm, un , vn , ua, va )  ! energy & enstrophy scheme
+            END SELECT
+            ztrdu(:,:,:) = ua(:,:,:) - ztrdu(:,:,:)
+            ztrdv(:,:,:) = va(:,:,:) - ztrdv(:,:,:)
+            CALL trd_dyn( ztrdu, ztrdv, jpdyn_rvo, kt )
+         ENDIF
+         !
+         DEALLOCATE( ztrdu, ztrdv )
+         !
+      ELSE              !==  total vorticity trend added to the general trend  ==!
+         !
+         SELECT CASE ( nvor_scheme )      !==  vorticity trend added to the general trend  ==!
+         CASE( np_ENT )                        !* energy conserving scheme  (T-pts)
+                             CALL vor_enT( kt, ntot, un , vn , ua, va )   ! total vorticity trend
+            IF( ln_stcor )   CALL vor_enT( kt, ncor, usd, vsd, ua, va )   ! add the Stokes-Coriolis trend
+         CASE( np_EET )                        !* energy conserving scheme (een scheme using e3t)
+                             CALL vor_eeT( kt, ntot, un , vn , ua, va )   ! total vorticity trend
+            IF( ln_stcor )   CALL vor_eeT( kt, ncor, usd, vsd, ua, va )   ! add the Stokes-Coriolis trend
+         CASE( np_ENE )                        !* energy conserving scheme
+                             CALL vor_ene( kt, ntot, un , vn , ua, va )   ! total vorticity trend
+            IF( ln_stcor )   CALL vor_ene( kt, ncor, usd, vsd, ua, va )   ! add the Stokes-Coriolis trend
+         CASE( np_ENS )                        !* enstrophy conserving scheme
+                             CALL vor_ens( kt, ntot, un , vn , ua, va )  ! total vorticity trend
+            IF( ln_stcor )   CALL vor_ens( kt, ncor, usd, vsd, ua, va )  ! add the Stokes-Coriolis trend
+         CASE( np_MIX )                        !* mixed ene-ens scheme
+                             CALL vor_ens( kt, nrvm, un , vn , ua, va )   ! relative vorticity or metric trend (ens)
+                             CALL vor_ene( kt, ncor, un , vn , ua, va )   ! planetary vorticity trend (ene)
+            IF( ln_stcor )   CALL vor_ene( kt, ncor, usd, vsd, ua, va )   ! add the Stokes-Coriolis trend
+         CASE( np_EEN )                        !* energy and enstrophy conserving scheme
+                             CALL vor_een( kt, ntot, un , vn , ua, va )   ! total vorticity trend
+            IF( ln_stcor )   CALL vor_een( kt, ncor, usd, vsd, ua, va )   ! add the Stokes-Coriolis trend
+         END SELECT
+         !
+      ENDIF
+      !
+      !                       ! print sum trends (used for debugging)
+      IF(ln_ctl) CALL prt_ctl( tab3d_1=ua, clinfo1=' vor  - Ua: ', mask1=umask,               &
+         &                     tab3d_2=va, clinfo2=       ' Va: ', mask2=vmask, clinfo3='dyn' )
+      !
+      IF( ln_timing )   CALL timing_stop('dyn_vor')
+      !
+   END SUBROUTINE dyn_vor
+
+
+   SUBROUTINE vor_enT( kt, kvor, pu, pv, pu_rhs, pv_rhs )
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE vor_enT  ***
+      !!
+      !! ** Purpose :   Compute the now total vorticity trend and add it to 
+      !!      the general trend of the momentum equation.
+      !!
+      !! ** Method  :   Trend evaluated using now fields (centered in time) 
+      !!       and t-point evaluation of vorticity (planetary and relative).
+      !!       conserves the horizontal kinetic energy.
+      !!         The general trend of momentum is increased due to the vorticity 
+      !!       term which is given by:
+      !!          voru = 1/bu  mj[ ( mi(mj(bf*rvor))+bt*f_t)/e3t  mj[vn] ]
+      !!          vorv = 1/bv  mi[ ( mi(mj(bf*rvor))+bt*f_t)/e3f  mj[un] ]
+      !!       where rvor is the relative vorticity at f-point
+      !!
+      !! ** Action : - Update (ua,va) with the now vorticity term trend
+      !!----------------------------------------------------------------------
+      INTEGER                         , INTENT(in   ) ::   kt               ! ocean time-step index
+      INTEGER                         , INTENT(in   ) ::   kvor             ! total, planetary, relative, or metric
+      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pu, pv           ! now velocities
+      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pu_rhs, pv_rhs   ! total v-trend
+      !
+      INTEGER  ::   ji, jj, jk           ! dummy loop indices
+      REAL(wp) ::   zx1, zy1, zx2, zy2   ! local scalars
+      REAL(wp), DIMENSION(jpi,jpj) ::   zwx, zwy, zwz, zwt   ! 2D workspace
+      !!----------------------------------------------------------------------
+      !
+      IF( kt == nit000 ) THEN
+         IF(lwp) WRITE(numout,*)
+         IF(lwp) WRITE(numout,*) 'dyn:vor_enT : vorticity term: t-point energy conserving scheme'
+         IF(lwp) WRITE(numout,*) '~~~~~~~~~~~'
+      ENDIF
+      !
+      !                                                ! ===============
+      DO jk = 1, jpkm1                                 ! Horizontal slab
+         !                                             ! ===============
+         !
+         SELECT CASE( kvor )                 !==  volume weighted vorticity considered  ==!
+         CASE ( np_COR )                           !* Coriolis (planetary vorticity)
+            zwt(:,:) = ff_t(:,:) * e1e2t(:,:)*e3t_n(:,:,jk)
+         CASE ( np_RVO )                           !* relative vorticity
+            DO jj = 1, jpjm1
+               DO ji = 1, jpim1
+                  zwz(ji,jj) = (  e2v(ji+1,jj) * pv(ji+1,jj,jk) - e2v(ji,jj) * pv(ji,jj,jk)  &
+                     &          - e1u(ji,jj+1) * pu(ji,jj+1,jk) + e1u(ji,jj) * pu(ji,jj,jk)  ) * r1_e1e2f(ji,jj)
+               END DO
+            END DO
+            IF( ln_dynvor_msk ) THEN                     ! mask/unmask relative vorticity 
+               DO jj = 1, jpjm1
+                  DO ji = 1, jpim1
+                     zwz(ji,jj) = zwz(ji,jj) * fmask(ji,jj,jk)
+                  END DO
+               END DO
+            ENDIF
+            CALL lbc_lnk( zwz, 'F', 1. )
+            DO jj = 2, jpj
+               DO ji = 2, jpi   ! vector opt.
+                  zwt(ji,jj) = r1_4 * (   zwz(ji-1,jj  ) + zwz(ji,jj  )   &
+                     &                  + zwz(ji-1,jj-1) + zwz(ji,jj-1)   ) * e1e2t(ji,jj)*e3t_n(ji,jj,jk)
+               END DO
+            END DO
+         CASE ( np_MET )                           !* metric term
+            DO jj = 2, jpj
+               DO ji = 2, jpi
+                  zwt(ji,jj) = (   ( pv(ji,jj,jk) + pv(ji,jj-1,jk) ) * di_e2u_2(ji,jj)   &
+                     &           - ( pu(ji,jj,jk) + pu(ji-1,jj,jk) ) * dj_e1v_2(ji,jj)   ) * e3t_n(ji,jj,jk)
+               END DO
+            END DO
+         CASE ( np_CRV )                           !* Coriolis + relative vorticity
+            DO jj = 1, jpjm1
+               DO ji = 1, jpim1                          ! relative vorticity
+                  zwz(ji,jj) = (   e2v(ji+1,jj) * pv(ji+1,jj,jk) - e2v(ji,jj) * pv(ji,jj,jk)   &
+                     &           - e1u(ji,jj+1) * pu(ji,jj+1,jk) + e1u(ji,jj) * pu(ji,jj,jk)   ) * r1_e1e2f(ji,jj)
+               END DO
+            END DO
+            IF( ln_dynvor_msk ) THEN                     ! mask/unmask relative vorticity 
+               DO jj = 1, jpjm1
+                  DO ji = 1, jpim1
+                     zwz(ji,jj) = zwz(ji,jj) * fmask(ji,jj,jk)
+                  END DO
+               END DO
+            ENDIF
+            CALL lbc_lnk( zwz, 'F', 1. )
+            DO jj = 2, jpj
+               DO ji = 2, jpi   ! vector opt.
+                  zwt(ji,jj) = (  ff_t(ji,jj) + r1_4 * ( zwz(ji-1,jj  ) + zwz(ji,jj  )    &
+                     &                                 + zwz(ji-1,jj-1) + zwz(ji,jj-1) )  ) * e1e2t(ji,jj)*e3t_n(ji,jj,jk)
+               END DO
+            END DO
+         CASE ( np_CME )                           !* Coriolis + metric
+            DO jj = 2, jpj
+               DO ji = 2, jpi   ! vector opt.
+                  zwt(ji,jj) = (  ff_t(ji,jj) * e1e2t(ji,jj)                           &
+                       &        + ( pv(ji,jj,jk) + pv(ji,jj-1,jk) ) * di_e2u_2(ji,jj)  &
+                       &        - ( pu(ji,jj,jk) + pu(ji-1,jj,jk) ) * dj_e1v_2(ji,jj)  ) * e3t_n(ji,jj,jk)
+               END DO
+            END DO
+         CASE DEFAULT                                             ! error
+            CALL ctl_stop('STOP','dyn_vor: wrong value for kvor'  )
+         END SELECT
+         !
+         !                                   !==  compute and add the vorticity term trend  =!
+         DO jj = 2, jpjm1
+            DO ji = 2, jpim1   ! vector opt.
+               pu_rhs(ji,jj,jk) = pu_rhs(ji,jj,jk) + r1_4 * r1_e1e2u(ji,jj) / e3u_n(ji,jj,jk)                    &
+                  &                                * (  zwt(ji+1,jj) * ( pv(ji+1,jj,jk) + pv(ji+1,jj-1,jk) )   &
+                  &                                   + zwt(ji  ,jj) * ( pv(ji  ,jj,jk) + pv(ji  ,jj-1,jk) )   )
+                  !
+               pv_rhs(ji,jj,jk) = pv_rhs(ji,jj,jk) - r1_4 * r1_e1e2v(ji,jj) / e3v_n(ji,jj,jk)                    &
+                  &                                * (  zwt(ji,jj+1) * ( pu(ji,jj+1,jk) + pu(ji-1,jj+1,jk) )   & 
+                  &                                   + zwt(ji,jj  ) * ( pu(ji,jj  ,jk) + pu(ji-1,jj  ,jk) )   ) 
+            END DO  
+         END DO  
+         !                                             ! ===============
+      END DO                                           !   End of slab
+      !                                                ! ===============
+   END SUBROUTINE vor_enT
+
+
+   SUBROUTINE vor_ene( kt, kvor, pun, pvn, pua, pva )
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE vor_ene  ***
+      !!
+      !! ** Purpose :   Compute the now total vorticity trend and add it to 
+      !!      the general trend of the momentum equation.
+      !!
+      !! ** Method  :   Trend evaluated using now fields (centered in time) 
+      !!       and the Sadourny (1975) flux form formulation : conserves the
+      !!       horizontal kinetic energy.
+      !!         The general trend of momentum is increased due to the vorticity 
+      !!       term which is given by:
+      !!          voru = 1/e1u  mj-1[ (rvor+f)/e3f  mi(e1v*e3v vn) ]
+      !!          vorv = 1/e2v  mi-1[ (rvor+f)/e3f  mj(e2u*e3u un) ]
+      !!       where rvor is the relative vorticity
+      !!
+      !! ** Action : - Update (ua,va) with the now vorticity term trend
+      !!
+      !! References : Sadourny, r., 1975, j. atmos. sciences, 32, 680-689.
+      !!----------------------------------------------------------------------
+      INTEGER                         , INTENT(in   ) ::   kt          ! ocean time-step index
+      INTEGER                         , INTENT(in   ) ::   kvor        ! total, planetary, relative, or metric
+      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pun, pvn    ! now velocities
+      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pua, pva    ! total v-trend
+      !
+      INTEGER  ::   ji, jj, jk           ! dummy loop indices
+      REAL(wp) ::   zx1, zy1, zx2, zy2   ! local scalars
+      REAL(wp), DIMENSION(jpi,jpj) ::   zwx, zwy, zwz   ! 2D workspace
+      !!----------------------------------------------------------------------
+      !
+      IF( kt == nit000 ) THEN
+         IF(lwp) WRITE(numout,*)
+         IF(lwp) WRITE(numout,*) 'dyn:vor_ene : vorticity term: energy conserving scheme'
+         IF(lwp) WRITE(numout,*) '~~~~~~~~~~~'
+      ENDIF
+      !
+      !                                                ! ===============
+      DO jk = 1, jpkm1                                 ! Horizontal slab
+         !                                             ! ===============
+         !
+         SELECT CASE( kvor )                 !==  vorticity considered  ==!
+         CASE ( np_COR )                           !* Coriolis (planetary vorticity)
+            zwz(:,:) = ff_f(:,:) 
+         CASE ( np_RVO )                           !* relative vorticity
+            DO jj = 1, jpjm1
+               DO ji = 1, fs_jpim1   ! vector opt.
+                  zwz(ji,jj) = (  e2v(ji+1,jj  ) * pvn(ji+1,jj  ,jk) - e2v(ji,jj) * pvn(ji,jj,jk)    &
+                     &          - e1u(ji  ,jj+1) * pun(ji  ,jj+1,jk) + e1u(ji,jj) * pun(ji,jj,jk)  ) * r1_e1e2f(ji,jj)
+               END DO
+            END DO
+         CASE ( np_MET )                           !* metric term
+            DO jj = 1, jpjm1
+               DO ji = 1, fs_jpim1   ! vector opt.
+                  zwz(ji,jj) = ( pvn(ji+1,jj  ,jk) + pvn(ji,jj,jk) ) * di_e2v_2e1e2f(ji,jj)   &
+                     &       - ( pun(ji  ,jj+1,jk) + pun(ji,jj,jk) ) * dj_e1u_2e1e2f(ji,jj)
+               END DO
+            END DO
+         CASE ( np_CRV )                           !* Coriolis + relative vorticity
+            DO jj = 1, jpjm1
+               DO ji = 1, fs_jpim1   ! vector opt.
+                  zwz(ji,jj) = ff_f(ji,jj) + (  e2v(ji+1,jj) * pvn(ji+1,jj,jk) - e2v(ji,jj) * pvn(ji,jj,jk)      &
+                     &                        - e1u(ji,jj+1) * pun(ji,jj+1,jk) + e1u(ji,jj) * pun(ji,jj,jk)  ) * r1_e1e2f(ji,jj)
+               END DO
+            END DO
+         CASE ( np_CME )                           !* Coriolis + metric
+            DO jj = 1, jpjm1
+               DO ji = 1, fs_jpim1   ! vector opt.
+                  zwz(ji,jj) = ff_f(ji,jj) + ( pvn(ji+1,jj  ,jk) + pvn(ji,jj,jk) ) * di_e2v_2e1e2f(ji,jj)   &
+                     &                     - ( pun(ji  ,jj+1,jk) + pun(ji,jj,jk) ) * dj_e1u_2e1e2f(ji,jj)
+               END DO
+            END DO
+         CASE DEFAULT                                             ! error
+            CALL ctl_stop('STOP','dyn_vor: wrong value for kvor'  )
+         END SELECT
+         !
+         IF( ln_dynvor_msk ) THEN          !==  mask/unmask vorticity ==!
+            DO jj = 1, jpjm1
+               DO ji = 1, fs_jpim1   ! vector opt.
+                  zwz(ji,jj) = zwz(ji,jj) * fmask(ji,jj,jk)
+               END DO
+            END DO
+         ENDIF
+
+         IF( ln_sco ) THEN
+            zwz(:,:) = zwz(:,:) / e3f_n(:,:,jk)
+            zwx(:,:) = e2u(:,:) * e3u_n(:,:,jk) * pun(:,:,jk)
+            zwy(:,:) = e1v(:,:) * e3v_n(:,:,jk) * pvn(:,:,jk)
+         ELSE
+            zwx(:,:) = e2u(:,:) * pun(:,:,jk)
+            zwy(:,:) = e1v(:,:) * pvn(:,:,jk)
+         ENDIF
+         !                                   !==  compute and add the vorticity term trend  =!
+         DO jj = 2, jpjm1
+            DO ji = fs_2, fs_jpim1   ! vector opt.
+               zy1 = zwy(ji,jj-1) + zwy(ji+1,jj-1)
+               zy2 = zwy(ji,jj  ) + zwy(ji+1,jj  )
+               zx1 = zwx(ji-1,jj) + zwx(ji-1,jj+1)
+               zx2 = zwx(ji  ,jj) + zwx(ji  ,jj+1)
+               pua(ji,jj,jk) = pua(ji,jj,jk) + r1_4 * r1_e1u(ji,jj) * ( zwz(ji  ,jj-1) * zy1 + zwz(ji,jj) * zy2 )
+               pva(ji,jj,jk) = pva(ji,jj,jk) - r1_4 * r1_e2v(ji,jj) * ( zwz(ji-1,jj  ) * zx1 + zwz(ji,jj) * zx2 ) 
+            END DO  
+         END DO  
+         !                                             ! ===============
+      END DO                                           !   End of slab
+      !                                                ! ===============
+   END SUBROUTINE vor_ene
+
+
+   SUBROUTINE vor_ens( kt, kvor, pun, pvn, pua, pva )
+      !!----------------------------------------------------------------------
+      !!                ***  ROUTINE vor_ens  ***
+      !!
+      !! ** Purpose :   Compute the now total vorticity trend and add it to
+      !!      the general trend of the momentum equation.
+      !!
+      !! ** Method  :   Trend evaluated using now fields (centered in time)
+      !!      and the Sadourny (1975) flux FORM formulation : conserves the
+      !!      potential enstrophy of a horizontally non-divergent flow. the
+      !!      trend of the vorticity term is given by:
+      !!          voru = 1/e1u  mj-1[ (rvor+f)/e3f ]  mj-1[ mi(e1v*e3v vn) ]
+      !!          vorv = 1/e2v  mi-1[ (rvor+f)/e3f ]  mi-1[ mj(e2u*e3u un) ]
+      !!      Add this trend to the general momentum trend (ua,va):
+      !!          (ua,va) = (ua,va) + ( voru , vorv )
+      !!
+      !! ** Action : - Update (ua,va) arrays with the now vorticity term trend
+      !!
+      !! References : Sadourny, r., 1975, j. atmos. sciences, 32, 680-689.
+      !!----------------------------------------------------------------------
+      INTEGER                         , INTENT(in   ) ::   kt          ! ocean time-step index
+      INTEGER                         , INTENT(in   ) ::   kvor        ! total, planetary, relative, or metric
+      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pun, pvn    ! now velocities
+      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pua, pva    ! total v-trend
+      !
+      INTEGER  ::   ji, jj, jk   ! dummy loop indices
+      REAL(wp) ::   zuav, zvau   ! local scalars
+      REAL(wp), DIMENSION(jpi,jpj) ::   zwx, zwy, zwz, zww   ! 2D workspace
+      !!----------------------------------------------------------------------
+      !
+      IF( kt == nit000 ) THEN
+         IF(lwp) WRITE(numout,*)
+         IF(lwp) WRITE(numout,*) 'dyn:vor_ens : vorticity term: enstrophy conserving scheme'
+         IF(lwp) WRITE(numout,*) '~~~~~~~~~~~'
+      ENDIF
+      !                                                ! ===============
+      DO jk = 1, jpkm1                                 ! Horizontal slab
+         !                                             ! ===============
+         !
+         SELECT CASE( kvor )                 !==  vorticity considered  ==!
+         CASE ( np_COR )                           !* Coriolis (planetary vorticity)
+            zwz(:,:) = ff_f(:,:) 
+         CASE ( np_RVO )                           !* relative vorticity
+            DO jj = 1, jpjm1
+               DO ji = 1, fs_jpim1   ! vector opt.
+                  zwz(ji,jj) = (  e2v(ji+1,jj  ) * pvn(ji+1,jj  ,jk) - e2v(ji,jj) * pvn(ji,jj,jk)    &
+                     &          - e1u(ji  ,jj+1) * pun(ji  ,jj+1,jk) + e1u(ji,jj) * pun(ji,jj,jk)  ) * r1_e1e2f(ji,jj)
+               END DO
+            END DO
+         CASE ( np_MET )                           !* metric term
+            DO jj = 1, jpjm1
+               DO ji = 1, fs_jpim1   ! vector opt.
+                  zwz(ji,jj) = ( pvn(ji+1,jj  ,jk) + pvn(ji,jj,jk) ) * di_e2v_2e1e2f(ji,jj)   &
+                     &       - ( pun(ji  ,jj+1,jk) + pun(ji,jj,jk) ) * dj_e1u_2e1e2f(ji,jj)
+               END DO
+            END DO
+         CASE ( np_CRV )                           !* Coriolis + relative vorticity
+            DO jj = 1, jpjm1
+               DO ji = 1, fs_jpim1   ! vector opt.
+                  zwz(ji,jj) = ff_f(ji,jj) + (  e2v(ji+1,jj  ) * pvn(ji+1,jj  ,jk) - e2v(ji,jj) * pvn(ji,jj,jk)  &
+                     &                        - e1u(ji  ,jj+1) * pun(ji  ,jj+1,jk) + e1u(ji,jj) * pun(ji,jj,jk)  ) * r1_e1e2f(ji,jj)
+               END DO
+            END DO
+         CASE ( np_CME )                           !* Coriolis + metric
+            DO jj = 1, jpjm1
+               DO ji = 1, fs_jpim1   ! vector opt.
+                  zwz(ji,jj) = ff_f(ji,jj) + ( pvn(ji+1,jj  ,jk) + pvn(ji,jj,jk) ) * di_e2v_2e1e2f(ji,jj)   &
+                     &                     - ( pun(ji  ,jj+1,jk) + pun(ji,jj,jk) ) * dj_e1u_2e1e2f(ji,jj)
+               END DO
+            END DO
+         CASE DEFAULT                                             ! error
+            CALL ctl_stop('STOP','dyn_vor: wrong value for kvor'  )
+         END SELECT
+         !
+         IF( ln_dynvor_msk ) THEN           !==  mask/unmask vorticity ==!
+            DO jj = 1, jpjm1
+               DO ji = 1, fs_jpim1   ! vector opt.
+                  zwz(ji,jj) = zwz(ji,jj) * fmask(ji,jj,jk)
+               END DO
+            END DO
+         ENDIF
+         !
+         IF( ln_sco ) THEN                   !==  horizontal fluxes  ==!
+            zwz(:,:) = zwz(:,:) / e3f_n(:,:,jk)
+            zwx(:,:) = e2u(:,:) * e3u_n(:,:,jk) * pun(:,:,jk)
+            zwy(:,:) = e1v(:,:) * e3v_n(:,:,jk) * pvn(:,:,jk)
+         ELSE
+            zwx(:,:) = e2u(:,:) * pun(:,:,jk)
+            zwy(:,:) = e1v(:,:) * pvn(:,:,jk)
+         ENDIF
+         !                                   !==  compute and add the vorticity term trend  =!
+         DO jj = 2, jpjm1
+            DO ji = fs_2, fs_jpim1   ! vector opt.
+               zuav = r1_8 * r1_e1u(ji,jj) * (  zwy(ji  ,jj-1) + zwy(ji+1,jj-1)  &
+                  &                           + zwy(ji  ,jj  ) + zwy(ji+1,jj  )  )
+               zvau =-r1_8 * r1_e2v(ji,jj) * (  zwx(ji-1,jj  ) + zwx(ji-1,jj+1)  &
+                  &                           + zwx(ji  ,jj  ) + zwx(ji  ,jj+1)  )
+               pua(ji,jj,jk) = pua(ji,jj,jk) + zuav * ( zwz(ji  ,jj-1) + zwz(ji,jj) )
+               pva(ji,jj,jk) = pva(ji,jj,jk) + zvau * ( zwz(ji-1,jj  ) + zwz(ji,jj) )
+            END DO  
+         END DO  
+         !                                             ! ===============
+      END DO                                           !   End of slab
+      !                                                ! ===============
+   END SUBROUTINE vor_ens
+
+
+   SUBROUTINE vor_een( kt, kvor, pun, pvn, pua, pva )
+      !!----------------------------------------------------------------------
+      !!                ***  ROUTINE vor_een  ***
+      !!
+      !! ** Purpose :   Compute the now total vorticity trend and add it to 
+      !!      the general trend of the momentum equation.
+      !!
+      !! ** Method  :   Trend evaluated using now fields (centered in time) 
+      !!      and the Arakawa and Lamb (1980) flux form formulation : conserves 
+      !!      both the horizontal kinetic energy and the potential enstrophy
+      !!      when horizontal divergence is zero (see the NEMO documentation)
+      !!      Add this trend to the general momentum trend (ua,va).
+      !!
+      !! ** Action : - Update (ua,va) with the now vorticity term trend
+      !!
+      !! References : Arakawa and Lamb 1980, Mon. Wea. Rev., 109, 18-36
+      !!----------------------------------------------------------------------
+      INTEGER                         , INTENT(in   ) ::   kt          ! ocean time-step index
+      INTEGER                         , INTENT(in   ) ::   kvor        ! total, planetary, relative, or metric
+      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pun, pvn    ! now velocities
+      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pua, pva    ! total v-trend
+      !
+      INTEGER  ::   ji, jj, jk   ! dummy loop indices
+      INTEGER  ::   ierr         ! local integer
+      REAL(wp) ::   zua, zva     ! local scalars
+      REAL(wp) ::   zmsk, ze3f   ! local scalars
+      REAL(wp), DIMENSION(jpi,jpj) ::   zwx , zwy , zwz , z1_e3f
+      REAL(wp), DIMENSION(jpi,jpj) ::   ztnw, ztne, ztsw, ztse
+      !!----------------------------------------------------------------------
+      !
+      IF( kt == nit000 ) THEN
+         IF(lwp) WRITE(numout,*)
+         IF(lwp) WRITE(numout,*) 'dyn:vor_een : vorticity term: energy and enstrophy conserving scheme'
+         IF(lwp) WRITE(numout,*) '~~~~~~~~~~~'
+      ENDIF
+      !
+      !                                                ! ===============
+      DO jk = 1, jpkm1                                 ! Horizontal slab
+         !                                             ! ===============
+         !
+         SELECT CASE( nn_een_e3f )           ! == reciprocal of e3 at F-point
+         CASE ( 0 )                                   ! original formulation  (masked averaging of e3t divided by 4)
+            DO jj = 1, jpjm1
+               DO ji = 1, fs_jpim1   ! vector opt.
+                  ze3f = (  e3t_n(ji,jj+1,jk)*tmask(ji,jj+1,jk) + e3t_n(ji+1,jj+1,jk)*tmask(ji+1,jj+1,jk)   &
+                     &    + e3t_n(ji,jj  ,jk)*tmask(ji,jj  ,jk) + e3t_n(ji+1,jj  ,jk)*tmask(ji+1,jj  ,jk)  )
+                  IF( ze3f /= 0._wp ) THEN   ;   z1_e3f(ji,jj) = 4._wp / ze3f
+                  ELSE                       ;   z1_e3f(ji,jj) = 0._wp
+                  ENDIF
+               END DO
+            END DO
+         CASE ( 1 )                                   ! new formulation  (masked averaging of e3t divided by the sum of mask)
+            DO jj = 1, jpjm1
+               DO ji = 1, fs_jpim1   ! vector opt.
+                  ze3f = (  e3t_n(ji,jj+1,jk)*tmask(ji,jj+1,jk) + e3t_n(ji+1,jj+1,jk)*tmask(ji+1,jj+1,jk)   &
+                     &    + e3t_n(ji,jj  ,jk)*tmask(ji,jj  ,jk) + e3t_n(ji+1,jj  ,jk)*tmask(ji+1,jj  ,jk)  )
+                  zmsk = (                    tmask(ji,jj+1,jk) +                     tmask(ji+1,jj+1,jk)   &
+                     &                      + tmask(ji,jj  ,jk) +                     tmask(ji+1,jj  ,jk)  )
+                  IF( ze3f /= 0._wp ) THEN   ;   z1_e3f(ji,jj) = zmsk / ze3f
+                  ELSE                       ;   z1_e3f(ji,jj) = 0._wp
+                  ENDIF
+               END DO
+            END DO
+         END SELECT
+         !
+         SELECT CASE( kvor )                 !==  vorticity considered  ==!
+         CASE ( np_COR )                           !* Coriolis (planetary vorticity)
+            DO jj = 1, jpjm1
+               DO ji = 1, fs_jpim1   ! vector opt.
+                  zwz(ji,jj) = ff_f(ji,jj) * z1_e3f(ji,jj)
+               END DO
+            END DO
+         CASE ( np_RVO )                           !* relative vorticity
+            DO jj = 1, jpjm1
+               DO ji = 1, fs_jpim1   ! vector opt.
+                  zwz(ji,jj) = ( e2v(ji+1,jj  ) * pvn(ji+1,jj,jk) - e2v(ji,jj) * pvn(ji,jj,jk)  &
+                     &         - e1u(ji  ,jj+1) * pun(ji,jj+1,jk) + e1u(ji,jj) * pun(ji,jj,jk)  ) * r1_e1e2f(ji,jj)*z1_e3f(ji,jj)
+               END DO
+            END DO
+         CASE ( np_MET )                           !* metric term
+            DO jj = 1, jpjm1
+               DO ji = 1, fs_jpim1   ! vector opt.
+                  zwz(ji,jj) = (   ( pvn(ji+1,jj,jk) + pvn(ji,jj,jk) ) * di_e2v_2e1e2f(ji,jj)   &
+                     &           - ( pun(ji,jj+1,jk) + pun(ji,jj,jk) ) * dj_e1u_2e1e2f(ji,jj)   ) * z1_e3f(ji,jj)
+               END DO
+            END DO
+         CASE ( np_CRV )                           !* Coriolis + relative vorticity
+            DO jj = 1, jpjm1
+               DO ji = 1, fs_jpim1   ! vector opt.
+                  zwz(ji,jj) = (  ff_f(ji,jj) + (  e2v(ji+1,jj  ) * pvn(ji+1,jj,jk) - e2v(ji,jj) * pvn(ji,jj,jk)      &
+                     &                           - e1u(ji  ,jj+1) * pun(ji,jj+1,jk) + e1u(ji,jj) * pun(ji,jj,jk)  )   &
+                     &                        * r1_e1e2f(ji,jj)   ) * z1_e3f(ji,jj)
+               END DO
+            END DO
+         CASE ( np_CME )                           !* Coriolis + metric
+            DO jj = 1, jpjm1
+               DO ji = 1, fs_jpim1   ! vector opt.
+                  zwz(ji,jj) = (   ff_f(ji,jj) + ( pvn(ji+1,jj  ,jk) + pvn(ji,jj,jk) ) * di_e2v_2e1e2f(ji,jj)   &
+                     &                         - ( pun(ji  ,jj+1,jk) + pun(ji,jj,jk) ) * dj_e1u_2e1e2f(ji,jj)   ) * z1_e3f(ji,jj)
+               END DO
+            END DO
+         CASE DEFAULT                                             ! error
+            CALL ctl_stop('STOP','dyn_vor: wrong value for kvor'  )
+         END SELECT
+         !
+         IF( ln_dynvor_msk ) THEN          !==  mask/unmask vorticity ==!
+            DO jj = 1, jpjm1
+               DO ji = 1, fs_jpim1   ! vector opt.
+                  zwz(ji,jj) = zwz(ji,jj) * fmask(ji,jj,jk)
+               END DO
+            END DO
+         ENDIF
+         !
+         CALL lbc_lnk( zwz, 'F', 1. )
+         !
+         !                                   !==  horizontal fluxes  ==!
+         zwx(:,:) = e2u(:,:) * e3u_n(:,:,jk) * pun(:,:,jk)
+         zwy(:,:) = e1v(:,:) * e3v_n(:,:,jk) * pvn(:,:,jk)
+
+         !                                   !==  compute and add the vorticity term trend  =!
+         jj = 2
+         ztne(1,:) = 0   ;   ztnw(1,:) = 0   ;   ztse(1,:) = 0   ;   ztsw(1,:) = 0
+         DO ji = 2, jpi          ! split in 2 parts due to vector opt.
+               ztne(ji,jj) = zwz(ji-1,jj  ) + zwz(ji  ,jj  ) + zwz(ji  ,jj-1)
+               ztnw(ji,jj) = zwz(ji-1,jj-1) + zwz(ji-1,jj  ) + zwz(ji  ,jj  )
+               ztse(ji,jj) = zwz(ji  ,jj  ) + zwz(ji  ,jj-1) + zwz(ji-1,jj-1)
+               ztsw(ji,jj) = zwz(ji  ,jj-1) + zwz(ji-1,jj-1) + zwz(ji-1,jj  )
+         END DO
+         DO jj = 3, jpj
+            DO ji = fs_2, jpi   ! vector opt. ok because we start at jj = 3
+               ztne(ji,jj) = zwz(ji-1,jj  ) + zwz(ji  ,jj  ) + zwz(ji  ,jj-1)
+               ztnw(ji,jj) = zwz(ji-1,jj-1) + zwz(ji-1,jj  ) + zwz(ji  ,jj  )
+               ztse(ji,jj) = zwz(ji  ,jj  ) + zwz(ji  ,jj-1) + zwz(ji-1,jj-1)
+               ztsw(ji,jj) = zwz(ji  ,jj-1) + zwz(ji-1,jj-1) + zwz(ji-1,jj  )
+            END DO
+         END DO
+         DO jj = 2, jpjm1
+            DO ji = fs_2, fs_jpim1   ! vector opt.
+               zua = + r1_12 * r1_e1u(ji,jj) * (  ztne(ji,jj  ) * zwy(ji  ,jj  ) + ztnw(ji+1,jj) * zwy(ji+1,jj  )   &
+                  &                             + ztse(ji,jj  ) * zwy(ji  ,jj-1) + ztsw(ji+1,jj) * zwy(ji+1,jj-1) )
+               zva = - r1_12 * r1_e2v(ji,jj) * (  ztsw(ji,jj+1) * zwx(ji-1,jj+1) + ztse(ji,jj+1) * zwx(ji  ,jj+1)   &
+                  &                             + ztnw(ji,jj  ) * zwx(ji-1,jj  ) + ztne(ji,jj  ) * zwx(ji  ,jj  ) )
+               pua(ji,jj,jk) = pua(ji,jj,jk) + zua
+               pva(ji,jj,jk) = pva(ji,jj,jk) + zva
+            END DO  
+         END DO  
+         !                                             ! ===============
+      END DO                                           !   End of slab
+      !                                                ! ===============
+   END SUBROUTINE vor_een
+
+
+
+   SUBROUTINE vor_eeT( kt, kvor, pun, pvn, pua, pva )
+      !!----------------------------------------------------------------------
+      !!                ***  ROUTINE vor_eeT  ***
+      !!
+      !! ** Purpose :   Compute the now total vorticity trend and add it to 
+      !!      the general trend of the momentum equation.
+      !!
+      !! ** Method  :   Trend evaluated using now fields (centered in time) 
+      !!      and the Arakawa and Lamb (1980) vector form formulation using 
+      !!      a modified version of Arakawa and Lamb (1980) scheme (see vor_een).
+      !!      The change consists in 
+      !!      Add this trend to the general momentum trend (ua,va).
+      !!
+      !! ** Action : - Update (ua,va) with the now vorticity term trend
+      !!
+      !! References : Arakawa and Lamb 1980, Mon. Wea. Rev., 109, 18-36
+      !!----------------------------------------------------------------------
+      INTEGER                         , INTENT(in   ) ::   kt          ! ocean time-step index
+      INTEGER                         , INTENT(in   ) ::   kvor        ! total, planetary, relative, or metric
+      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pun, pvn    ! now velocities
+      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pua, pva    ! total v-trend
+      !
+      INTEGER  ::   ji, jj, jk     ! dummy loop indices
+      INTEGER  ::   ierr           ! local integer
+      REAL(wp) ::   zua, zva       ! local scalars
+      REAL(wp) ::   zmsk, z1_e3t   ! local scalars
+      REAL(wp), DIMENSION(jpi,jpj) ::   zwx , zwy , zwz
+      REAL(wp), DIMENSION(jpi,jpj) ::   ztnw, ztne, ztsw, ztse
+      !!----------------------------------------------------------------------
+      !
+      IF( kt == nit000 ) THEN
+         IF(lwp) WRITE(numout,*)
+         IF(lwp) WRITE(numout,*) 'dyn:vor_een : vorticity term: energy and enstrophy conserving scheme'
+         IF(lwp) WRITE(numout,*) '~~~~~~~~~~~'
+      ENDIF
+      !
+      !                                                ! ===============
+      DO jk = 1, jpkm1                                 ! Horizontal slab
+         !                                             ! ===============
+         !
+         !
+         SELECT CASE( kvor )                 !==  vorticity considered  ==!
+         CASE ( np_COR )                           !* Coriolis (planetary vorticity)
+            DO jj = 1, jpjm1
+               DO ji = 1, fs_jpim1   ! vector opt.
+                  zwz(ji,jj) = ff_f(ji,jj)
+               END DO
+            END DO
+         CASE ( np_RVO )                           !* relative vorticity
+            DO jj = 1, jpjm1
+               DO ji = 1, fs_jpim1   ! vector opt.
+                  zwz(ji,jj) = (  e2v(ji+1,jj  ) * pvn(ji+1,jj  ,jk) - e2v(ji,jj) * pvn(ji,jj,jk)    &
+                     &          - e1u(ji  ,jj+1) * pun(ji  ,jj+1,jk) + e1u(ji,jj) * pun(ji,jj,jk)  ) &
+                     &       * r1_e1e2f(ji,jj)
+               END DO
+            END DO
+         CASE ( np_MET )                           !* metric term
+            DO jj = 1, jpjm1
+               DO ji = 1, fs_jpim1   ! vector opt.
+                  zwz(ji,jj) = ( pvn(ji+1,jj  ,jk) + pvn(ji,jj,jk) ) * di_e2v_2e1e2f(ji,jj)   &
+                     &       - ( pun(ji  ,jj+1,jk) + pun(ji,jj,jk) ) * dj_e1u_2e1e2f(ji,jj)
+               END DO
+            END DO
+         CASE ( np_CRV )                           !* Coriolis + relative vorticity
+            DO jj = 1, jpjm1
+               DO ji = 1, fs_jpim1   ! vector opt.
+                  zwz(ji,jj) = (  ff_f(ji,jj) + (  e2v(ji+1,jj  ) * pvn(ji+1,jj  ,jk) - e2v(ji,jj) * pvn(ji,jj,jk)    &
+                     &                           - e1u(ji  ,jj+1) * pun(ji  ,jj+1,jk) + e1u(ji,jj) * pun(ji,jj,jk)  ) &
+                     &                      * r1_e1e2f(ji,jj)    )
+               END DO
+            END DO
+         CASE ( np_CME )                           !* Coriolis + metric
+            DO jj = 1, jpjm1
+               DO ji = 1, fs_jpim1   ! vector opt.
+                  zwz(ji,jj) = ff_f(ji,jj) + ( pvn(ji+1,jj  ,jk) + pvn(ji,jj,jk) ) * di_e2v_2e1e2f(ji,jj)   &
+                     &                     - ( pun(ji  ,jj+1,jk) + pun(ji,jj,jk) ) * dj_e1u_2e1e2f(ji,jj)
+               END DO
+            END DO
+         CASE DEFAULT                                             ! error
+            CALL ctl_stop('STOP','dyn_vor: wrong value for kvor'  )
+         END SELECT
+         !
+         IF( ln_dynvor_msk ) THEN          !==  mask/unmask vorticity ==!
+            DO jj = 1, jpjm1
+               DO ji = 1, fs_jpim1   ! vector opt.
+                  zwz(ji,jj) = zwz(ji,jj) * fmask(ji,jj,jk)
+               END DO
+            END DO
+         ENDIF
+         !
+         CALL lbc_lnk( zwz, 'F', 1. )
+         !
+         !                                   !==  horizontal fluxes  ==!
+         zwx(:,:) = e2u(:,:) * e3u_n(:,:,jk) * pun(:,:,jk)
+         zwy(:,:) = e1v(:,:) * e3v_n(:,:,jk) * pvn(:,:,jk)
+
+         !                                   !==  compute and add the vorticity term trend  =!
+         jj = 2
+         ztne(1,:) = 0   ;   ztnw(1,:) = 0   ;   ztse(1,:) = 0   ;   ztsw(1,:) = 0
+         DO ji = 2, jpi          ! split in 2 parts due to vector opt.
+               z1_e3t = 1._wp / e3t_n(ji,jj,jk)
+               ztne(ji,jj) = ( zwz(ji-1,jj  ) + zwz(ji  ,jj  ) + zwz(ji  ,jj-1) ) * z1_e3t
+               ztnw(ji,jj) = ( zwz(ji-1,jj-1) + zwz(ji-1,jj  ) + zwz(ji  ,jj  ) ) * z1_e3t
+               ztse(ji,jj) = ( zwz(ji  ,jj  ) + zwz(ji  ,jj-1) + zwz(ji-1,jj-1) ) * z1_e3t
+               ztsw(ji,jj) = ( zwz(ji  ,jj-1) + zwz(ji-1,jj-1) + zwz(ji-1,jj  ) ) * z1_e3t
+         END DO
+         DO jj = 3, jpj
+            DO ji = fs_2, jpi   ! vector opt. ok because we start at jj = 3
+               z1_e3t = 1._wp / e3t_n(ji,jj,jk)
+               ztne(ji,jj) = ( zwz(ji-1,jj  ) + zwz(ji  ,jj  ) + zwz(ji  ,jj-1) ) * z1_e3t
+               ztnw(ji,jj) = ( zwz(ji-1,jj-1) + zwz(ji-1,jj  ) + zwz(ji  ,jj  ) ) * z1_e3t
+               ztse(ji,jj) = ( zwz(ji  ,jj  ) + zwz(ji  ,jj-1) + zwz(ji-1,jj-1) ) * z1_e3t
+               ztsw(ji,jj) = ( zwz(ji  ,jj-1) + zwz(ji-1,jj-1) + zwz(ji-1,jj  ) ) * z1_e3t
+            END DO
+         END DO
+         DO jj = 2, jpjm1
+            DO ji = fs_2, fs_jpim1   ! vector opt.
+               zua = + r1_12 * r1_e1u(ji,jj) * (  ztne(ji,jj  ) * zwy(ji  ,jj  ) + ztnw(ji+1,jj) * zwy(ji+1,jj  )   &
+                  &                             + ztse(ji,jj  ) * zwy(ji  ,jj-1) + ztsw(ji+1,jj) * zwy(ji+1,jj-1) )
+               zva = - r1_12 * r1_e2v(ji,jj) * (  ztsw(ji,jj+1) * zwx(ji-1,jj+1) + ztse(ji,jj+1) * zwx(ji  ,jj+1)   &
+                  &                             + ztnw(ji,jj  ) * zwx(ji-1,jj  ) + ztne(ji,jj  ) * zwx(ji  ,jj  ) )
+               pua(ji,jj,jk) = pua(ji,jj,jk) + zua
+               pva(ji,jj,jk) = pva(ji,jj,jk) + zva
+            END DO  
+         END DO  
+         !                                             ! ===============
+      END DO                                           !   End of slab
+      !                                                ! ===============
+   END SUBROUTINE vor_eeT
+
+
+   SUBROUTINE dyn_vor_init
+      !!---------------------------------------------------------------------
+      !!                  ***  ROUTINE dyn_vor_init  ***
+      !!
+      !! ** Purpose :   Control the consistency between cpp options for
+      !!              tracer advection schemes
+      !!----------------------------------------------------------------------
+      INTEGER ::   ji, jj, jk    ! dummy loop indices
+      INTEGER ::   ioptio, ios   ! local integer
+      !!
+      NAMELIST/namdyn_vor/ ln_dynvor_ens, ln_dynvor_ene, ln_dynvor_enT, ln_dynvor_eeT,   &
+         &                 ln_dynvor_een, nn_een_e3f   , ln_dynvor_mix, ln_dynvor_msk
+      !!----------------------------------------------------------------------
+      !
+      IF(lwp) THEN
+         WRITE(numout,*)
+         WRITE(numout,*) 'dyn_vor_init : vorticity term : read namelist and control the consistency'
+         WRITE(numout,*) '~~~~~~~~~~~~'
+      ENDIF
+      !
+      REWIND( numnam_ref )              ! Namelist namdyn_vor in reference namelist : Vorticity scheme options
+      READ  ( numnam_ref, namdyn_vor, IOSTAT = ios, ERR = 901)
+901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namdyn_vor in reference namelist', lwp )
+      REWIND( numnam_cfg )              ! Namelist namdyn_vor in configuration namelist : Vorticity scheme options
+      READ  ( numnam_cfg, namdyn_vor, IOSTAT = ios, ERR = 902 )
+902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namdyn_vor in configuration namelist', lwp )
+      IF(lwm) WRITE ( numond, namdyn_vor )
+      !
+      IF(lwp) THEN                    ! Namelist print
+         WRITE(numout,*) '   Namelist namdyn_vor : choice of the vorticity term scheme'
+         WRITE(numout,*) '      enstrophy conserving scheme                    ln_dynvor_ens = ', ln_dynvor_ens
+         WRITE(numout,*) '      f-point energy conserving scheme               ln_dynvor_ene = ', ln_dynvor_ene
+         WRITE(numout,*) '      t-point energy conserving scheme               ln_dynvor_enT = ', ln_dynvor_enT
+         WRITE(numout,*) '      energy conserving scheme  (een using e3t)      ln_dynvor_eeT = ', ln_dynvor_eeT
+         WRITE(numout,*) '      enstrophy and energy conserving scheme         ln_dynvor_een = ', ln_dynvor_een
+         WRITE(numout,*) '         e3f = averaging /4 (=0) or /sum(tmask) (=1)    nn_een_e3f = ', nn_een_e3f
+         WRITE(numout,*) '      mixed enstrophy/energy conserving scheme       ln_dynvor_mix = ', ln_dynvor_mix
+         WRITE(numout,*) '      masked (=T) or unmasked(=F) vorticity          ln_dynvor_msk = ', ln_dynvor_msk
+      ENDIF
+
+      IF( ln_dynvor_msk )   CALL ctl_stop( 'dyn_vor_init:   masked vorticity is not currently not available')
+
+!!gm  this should be removed when choosing a unique strategy for fmask at the coast
+      ! If energy, enstrophy or mixed advection of momentum in vector form change the value for masks
+      ! at angles with three ocean points and one land point
+      IF(lwp) WRITE(numout,*)
+      IF(lwp) WRITE(numout,*) '      change fmask value in the angles (T)           ln_vorlat = ', ln_vorlat
+      IF( ln_vorlat .AND. ( ln_dynvor_ene .OR. ln_dynvor_ens .OR. ln_dynvor_mix ) ) THEN
+         DO jk = 1, jpk
+            DO jj = 1, jpjm1
+               DO ji = 1, jpim1
+                  IF(    tmask(ji,jj+1,jk) + tmask(ji+1,jj+1,jk)              &
+                     & + tmask(ji,jj  ,jk) + tmask(ji+1,jj+1,jk) == 3._wp )   fmask(ji,jj,jk) = 1._wp
+               END DO
+            END DO
+         END DO
+         !
+         CALL lbc_lnk( fmask, 'F', 1._wp )      ! Lateral boundary conditions on fmask
+         !
+      ENDIF
+!!gm end
+
+      ioptio = 0                     ! type of scheme for vorticity (set nvor_scheme)
+      IF( ln_dynvor_ens ) THEN   ;   ioptio = ioptio + 1   ;   nvor_scheme = np_ENS   ;   ENDIF
+      IF( ln_dynvor_ene ) THEN   ;   ioptio = ioptio + 1   ;   nvor_scheme = np_ENE   ;   ENDIF
+      IF( ln_dynvor_enT ) THEN   ;   ioptio = ioptio + 1   ;   nvor_scheme = np_ENT   ;   ENDIF
+      IF( ln_dynvor_eeT ) THEN   ;   ioptio = ioptio + 1   ;   nvor_scheme = np_EET   ;   ENDIF
+      IF( ln_dynvor_een ) THEN   ;   ioptio = ioptio + 1   ;   nvor_scheme = np_EEN   ;   ENDIF
+      IF( ln_dynvor_mix ) THEN   ;   ioptio = ioptio + 1   ;   nvor_scheme = np_MIX   ;   ENDIF
+      !
+      IF( ioptio /= 1 ) CALL ctl_stop( ' use ONE and ONLY one vorticity scheme' )
+      !                      
+      IF(lwp) WRITE(numout,*)        ! type of calculated vorticity (set ncor, nrvm, ntot)
+      ncor = np_COR                       ! planetary vorticity
+      SELECT CASE( n_dynadv )
+      CASE( np_LIN_dyn )
+         IF(lwp) WRITE(numout,*) '   ==>>>   linear dynamics : total vorticity = Coriolis'
+         nrvm = np_COR        ! planetary vorticity
+         ntot = np_COR        !     -         -
+      CASE( np_VEC_c2  )
+         IF(lwp) WRITE(numout,*) '   ==>>>   vector form dynamics : total vorticity = Coriolis + relative vorticity' 
+         nrvm = np_RVO        ! relative vorticity
+         ntot = np_CRV        ! relative + planetary vorticity         
+      CASE( np_FLX_c2 , np_FLX_ubs  )
+         IF(lwp) WRITE(numout,*) '   ==>>>   flux form dynamics : total vorticity = Coriolis + metric term'
+         nrvm = np_MET        ! metric term
+         ntot = np_CME        ! Coriolis + metric term
+         !
+         SELECT CASE( nvor_scheme )    ! pre-computed gradients for the metric term:
+         CASE( np_ENT )                      !* T-point metric term :   pre-compute di(e2u)/2 and dj(e1v)/2
+            ALLOCATE( di_e2u_2(jpi,jpj), dj_e1v_2(jpi,jpj) )
+            DO jj = 2, jpjm1
+               DO ji = 2, jpim1
+                  di_e2u_2(ji,jj) = ( e2u(ji,jj) - e2u(ji-1,jj  ) ) * 0.5_wp
+                  dj_e1v_2(ji,jj) = ( e1v(ji,jj) - e1v(ji  ,jj-1) ) * 0.5_wp
+               END DO
+            END DO
+            CALL lbc_lnk_multi( di_e2u_2, 'T', -1. , dj_e1v_2, 'T', -1. )   ! Lateral boundary conditions
+            !
+         CASE DEFAULT                        !* F-point metric term :   pre-compute di(e2u)/(2*e1e2f) and dj(e1v)/(2*e1e2f)
+            ALLOCATE( di_e2v_2e1e2f(jpi,jpj), dj_e1u_2e1e2f(jpi,jpj) )
+            DO jj = 1, jpjm1
+               DO ji = 1, jpim1
+                  di_e2v_2e1e2f(ji,jj) = ( e2v(ji+1,jj  ) - e2v(ji,jj) )  * 0.5 * r1_e1e2f(ji,jj)
+                  dj_e1u_2e1e2f(ji,jj) = ( e1u(ji  ,jj+1) - e1u(ji,jj) )  * 0.5 * r1_e1e2f(ji,jj)
+               END DO
+            END DO
+            CALL lbc_lnk_multi( di_e2v_2e1e2f, 'F', -1. , dj_e1u_2e1e2f, 'F', -1. )   ! Lateral boundary conditions
+         END SELECT
+         !
+      END SELECT
+      
+      IF(lwp) THEN                   ! Print the choice
+         WRITE(numout,*)
+         SELECT CASE( nvor_scheme )
+         CASE( np_ENS )   ;   WRITE(numout,*) '   ==>>>   enstrophy conserving scheme (ENS)'
+         CASE( np_ENE )   ;   WRITE(numout,*) '   ==>>>   energy conserving scheme (Coriolis at F-points) (ENE)'
+         CASE( np_ENT )   ;   WRITE(numout,*) '   ==>>>   energy conserving scheme (Coriolis at T-points) (ENT)'
+         CASE( np_EET )   ;   WRITE(numout,*) '   ==>>>   energy conserving scheme (EEN scheme using e3t) (EET)'
+         CASE( np_EEN )   ;   WRITE(numout,*) '   ==>>>   energy and enstrophy conserving scheme (EEN)'
+         CASE( np_MIX )   ;   WRITE(numout,*) '   ==>>>   mixed enstrophy/energy conserving scheme (MIX)'
+         END SELECT         
+      ENDIF
+      !
+   END SUBROUTINE dyn_vor_init
+
+   !!==============================================================================
+END MODULE dynvor
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DYN/dynzad.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DYN/dynzad.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DYN/dynzad.F90	(revision 9570)
@@ -0,0 +1,135 @@
+MODULE dynzad
+   !!======================================================================
+   !!                       ***  MODULE  dynzad  ***
+   !! Ocean dynamics : vertical advection trend
+   !!======================================================================
+   !! History :  OPA  ! 1991-01  (G. Madec) Original code
+   !!   NEMO     0.5  ! 2002-07  (G. Madec) Free form, F90
+   !!----------------------------------------------------------------------
+   
+   !!----------------------------------------------------------------------
+   !!   dyn_zad       : vertical advection momentum trend
+   !!----------------------------------------------------------------------
+   USE oce            ! ocean dynamics and tracers
+   USE dom_oce        ! ocean space and time domain
+   USE sbc_oce        ! surface boundary condition: ocean
+   USE trd_oce        ! trends: ocean variables
+   USE trddyn         ! trend manager: dynamics
+   !
+   USE in_out_manager ! I/O manager
+   USE lib_mpp        ! MPP library
+   USE prtctl         ! Print control
+   USE timing         ! Timing
+
+   IMPLICIT NONE
+   PRIVATE
+   
+   PUBLIC   dyn_zad       ! routine called by dynadv.F90
+
+   !! * Substitutions
+#  include "vectopt_loop_substitute.h90"
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 4.0 , NEMO Consortium (2017)
+   !! $Id$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE dyn_zad ( kt )
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE dynzad  ***
+      !! 
+      !! ** Purpose :   Compute the now vertical momentum advection trend and 
+      !!      add it to the general trend of momentum equation.
+      !!
+      !! ** Method  :   The now vertical advection of momentum is given by:
+      !!         w dz(u) = ua + 1/(e1e2u*e3u) mk+1[ mi(e1e2t*wn) dk(un) ]
+      !!         w dz(v) = va + 1/(e1e2v*e3v) mk+1[ mj(e1e2t*wn) dk(vn) ]
+      !!      Add this trend to the general trend (ua,va):
+      !!         (ua,va) = (ua,va) + w dz(u,v)
+      !!
+      !! ** Action  : - Update (ua,va) with the vert. momentum adv. trends
+      !!              - Send the trends to trddyn for diagnostics (l_trddyn=T)
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT(in) ::   kt   ! ocean time-step inedx
+      !
+      INTEGER  ::   ji, jj, jk   ! dummy loop indices
+      REAL(wp) ::   zua, zva     ! local scalars
+      REAL(wp), DIMENSION(jpi,jpj)     ::   zww
+      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zwuw, zwvw
+      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::   ztrdu, ztrdv
+      !!----------------------------------------------------------------------
+      !
+      IF( ln_timing )   CALL timing_start('dyn_zad')
+      !
+      IF( kt == nit000 ) THEN
+         IF(lwp) WRITE(numout,*)
+         IF(lwp) WRITE(numout,*) 'dyn_zad : 2nd order vertical advection scheme'
+      ENDIF
+
+      IF( l_trddyn )   THEN         ! Save ua and va trends
+         ALLOCATE( ztrdu(jpi,jpj,jpk) , ztrdv(jpi,jpj,jpk) ) 
+         ztrdu(:,:,:) = ua(:,:,:) 
+         ztrdv(:,:,:) = va(:,:,:) 
+      ENDIF
+      
+      DO jk = 2, jpkm1              ! Vertical momentum advection at level w and u- and v- vertical
+         DO jj = 2, jpj                   ! vertical fluxes 
+            DO ji = fs_2, jpi             ! vector opt.
+               zww(ji,jj) = 0.25_wp * e1e2t(ji,jj) * wn(ji,jj,jk)
+            END DO
+         END DO
+         DO jj = 2, jpjm1                 ! vertical momentum advection at w-point
+            DO ji = fs_2, fs_jpim1        ! vector opt.
+               zwuw(ji,jj,jk) = ( zww(ji+1,jj  ) + zww(ji,jj) ) * ( un(ji,jj,jk-1) - un(ji,jj,jk) )
+               zwvw(ji,jj,jk) = ( zww(ji  ,jj+1) + zww(ji,jj) ) * ( vn(ji,jj,jk-1) - vn(ji,jj,jk) )
+            END DO  
+         END DO   
+      END DO
+      !
+      ! Surface and bottom advective fluxes set to zero
+      IF( ln_isfcav ) THEN
+         DO jj = 2, jpjm1
+            DO ji = fs_2, fs_jpim1           ! vector opt.
+               zwuw(ji,jj, 1:miku(ji,jj) ) = 0._wp
+               zwvw(ji,jj, 1:mikv(ji,jj) ) = 0._wp
+               zwuw(ji,jj,jpk) = 0._wp
+               zwvw(ji,jj,jpk) = 0._wp
+            END DO
+         END DO
+      ELSE
+         DO jj = 2, jpjm1        
+            DO ji = fs_2, fs_jpim1           ! vector opt.
+               zwuw(ji,jj, 1 ) = 0._wp
+               zwvw(ji,jj, 1 ) = 0._wp
+               zwuw(ji,jj,jpk) = 0._wp
+               zwvw(ji,jj,jpk) = 0._wp
+            END DO  
+         END DO
+      END IF
+
+      DO jk = 1, jpkm1              ! Vertical momentum advection at u- and v-points
+         DO jj = 2, jpjm1
+            DO ji = fs_2, fs_jpim1       ! vector opt.
+               ua(ji,jj,jk) = ua(ji,jj,jk) - ( zwuw(ji,jj,jk) + zwuw(ji,jj,jk+1) ) * r1_e1e2u(ji,jj) / e3u_n(ji,jj,jk)
+               va(ji,jj,jk) = va(ji,jj,jk) - ( zwvw(ji,jj,jk) + zwvw(ji,jj,jk+1) ) * r1_e1e2v(ji,jj) / e3v_n(ji,jj,jk)
+            END DO  
+         END DO  
+      END DO
+
+      IF( l_trddyn ) THEN           ! save the vertical advection trends for diagnostic
+         ztrdu(:,:,:) = ua(:,:,:) - ztrdu(:,:,:)
+         ztrdv(:,:,:) = va(:,:,:) - ztrdv(:,:,:)
+         CALL trd_dyn( ztrdu, ztrdv, jpdyn_zad, kt )
+         DEALLOCATE( ztrdu, ztrdv ) 
+      ENDIF
+      !                             ! Control print
+      IF(ln_ctl)   CALL prt_ctl( tab3d_1=ua, clinfo1=' zad  - Ua: ', mask1=umask,   &
+         &                       tab3d_2=va, clinfo2=       ' Va: ', mask2=vmask, clinfo3='dyn' )
+      !
+      IF( ln_timing )   CALL timing_stop('dyn_zad')
+      !
+   END SUBROUTINE dyn_zad
+
+   !!======================================================================
+END MODULE dynzad
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DYN/dynzdf.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DYN/dynzdf.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DYN/dynzdf.F90	(revision 9570)
@@ -0,0 +1,404 @@
+MODULE dynzdf
+   !!==============================================================================
+   !!                 ***  MODULE  dynzdf  ***
+   !! Ocean dynamics :  vertical component of the momentum mixing trend
+   !!==============================================================================
+   !! History :  1.0  !  2005-11  (G. Madec)  Original code
+   !!            3.3  !  2010-10  (C. Ethe, G. Madec) reorganisation of initialisation phase
+   !!            4.0  !  2017-06  (G. Madec) remove the explicit time-stepping option + avm at t-point
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   dyn_zdf       : compute the after velocity through implicit calculation of vertical mixing
+   !!----------------------------------------------------------------------
+   USE oce            ! ocean dynamics and tracers variables
+   USE phycst         ! physical constants
+   USE dom_oce        ! ocean space and time domain variables 
+   USE sbc_oce        ! surface boundary condition: ocean
+   USE zdf_oce        ! ocean vertical physics variables
+   USE zdfdrg         ! vertical physics: top/bottom drag coef.
+   USE dynadv    ,ONLY: ln_dynadv_vec    ! dynamics: advection form
+   USE dynldf_iso,ONLY: akzu, akzv       ! dynamics: vertical component of rotated lateral mixing 
+   USE ldfdyn         ! lateral diffusion: eddy viscosity coef. and type of operator
+   USE trd_oce        ! trends: ocean variables
+   USE trddyn         ! trend manager: dynamics
+   !
+   USE in_out_manager ! I/O manager
+   USE lib_mpp        ! MPP library
+   USE prtctl         ! Print control
+   USE timing         ! Timing
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   dyn_zdf   !  routine called by step.F90
+
+   REAL(wp) ::  r_vvl     ! non-linear free surface indicator: =0 if ln_linssh=T, =1 otherwise 
+
+   !! * Substitutions
+#  include "vectopt_loop_substitute.h90"
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 4.0 , NEMO Consortium (2017)
+   !! $Id$
+   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+   
+   SUBROUTINE dyn_zdf( kt )
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE dyn_zdf  ***
+      !!
+      !! ** Purpose :   compute the trend due to the vert. momentum diffusion
+      !!              together with the Leap-Frog time stepping using an 
+      !!              implicit scheme.
+      !!
+      !! ** Method  :  - Leap-Frog time stepping on all trends but the vertical mixing
+      !!         ua =         ub + 2*dt *       ua             vector form or linear free surf.
+      !!         ua = ( e3u_b*ub + 2*dt * e3u_n*ua ) / e3u_a   otherwise
+      !!               - update the after velocity with the implicit vertical mixing.
+      !!      This requires to solver the following system: 
+      !!         ua = ua + 1/e3u_a dk+1[ mi(avm) / e3uw_a dk[ua] ]
+      !!      with the following surface/top/bottom boundary condition:
+      !!      surface: wind stress input (averaged over kt-1/2 & kt+1/2)
+      !!      top & bottom : top stress (iceshelf-ocean) & bottom stress (cf zdfdrg.F90)
+      !!
+      !! ** Action :   (ua,va)   after velocity 
+      !!---------------------------------------------------------------------
+      INTEGER, INTENT(in) ::   kt   ! ocean time-step index
+      !
+      INTEGER  ::   ji, jj, jk         ! dummy loop indices
+      INTEGER  ::   iku, ikv           ! local integers
+      REAL(wp) ::   zzwi, ze3ua, zdt   ! local scalars
+      REAL(wp) ::   zzws, ze3va        !   -      -
+      REAL(wp), DIMENSION(jpi,jpj,jpk)        ::  zwi, zwd, zws   ! 3D workspace 
+      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::   ztrdu, ztrdv   !  -      -
+      !!---------------------------------------------------------------------
+      !
+      IF( ln_timing )   CALL timing_start('dyn_zdf')
+      !
+      IF( kt == nit000 ) THEN       !* initialization
+         IF(lwp) WRITE(numout,*)
+         IF(lwp) WRITE(numout,*) 'dyn_zdf_imp : vertical momentum diffusion implicit operator'
+         IF(lwp) WRITE(numout,*) '~~~~~~~~~~~ '
+         !
+         If( ln_linssh ) THEN   ;    r_vvl = 0._wp    ! non-linear free surface indicator
+         ELSE                   ;    r_vvl = 1._wp
+         ENDIF
+      ENDIF
+      !                             !* set time step
+      IF( neuler == 0 .AND. kt == nit000     ) THEN   ;   r2dt =      rdt   ! = rdt (restart with Euler time stepping)
+      ELSEIF(               kt <= nit000 + 1 ) THEN   ;   r2dt = 2. * rdt   ! = 2 rdt (leapfrog)
+      ENDIF
+      !
+      !                             !* explicit top/bottom drag case
+      IF( .NOT.ln_drgimp )   CALL zdf_drg_exp( kt, ub, vb, ua, va )  ! add top/bottom friction trend to (ua,va)
+      !
+      !
+      IF( l_trddyn )   THEN         !* temporary save of ta and sa trends
+         ALLOCATE( ztrdu(jpi,jpj,jpk), ztrdv(jpi,jpj,jpk) ) 
+         ztrdu(:,:,:) = ua(:,:,:)
+         ztrdv(:,:,:) = va(:,:,:)
+      ENDIF
+      !
+      !              !==  RHS: Leap-Frog time stepping on all trends but the vertical mixing  ==!   (put in ua,va)
+      !
+      !                    ! time stepping except vertical diffusion
+      IF( ln_dynadv_vec .OR. ln_linssh ) THEN   ! applied on velocity
+         DO jk = 1, jpkm1
+            ua(:,:,jk) = ( ub(:,:,jk) + r2dt * ua(:,:,jk) ) * umask(:,:,jk)
+            va(:,:,jk) = ( vb(:,:,jk) + r2dt * va(:,:,jk) ) * vmask(:,:,jk)
+         END DO
+      ELSE                                      ! applied on thickness weighted velocity
+         DO jk = 1, jpkm1
+            ua(:,:,jk) = (         e3u_b(:,:,jk) * ub(:,:,jk)  &
+               &          + r2dt * e3u_n(:,:,jk) * ua(:,:,jk)  ) / e3u_a(:,:,jk) * umask(:,:,jk)
+            va(:,:,jk) = (         e3v_b(:,:,jk) * vb(:,:,jk)  &
+               &          + r2dt * e3v_n(:,:,jk) * va(:,:,jk)  ) / e3v_a(:,:,jk) * vmask(:,:,jk)
+         END DO
+      ENDIF
+      !                    ! add top/bottom friction 
+      !     With split-explicit free surface, barotropic stress is treated explicitly Update velocities at the bottom.
+      !     J. Chanut: The bottom stress is computed considering after barotropic velocities, which does 
+      !                not lead to the effective stress seen over the whole barotropic loop. 
+      !     G. Madec : in linear free surface, e3u_a = e3u_n = e3u_0, so systematic use of e3u_a
+      IF( ln_drgimp .AND. ln_dynspg_ts ) THEN
+         DO jk = 1, jpkm1        ! remove barotropic velocities
+            ua(:,:,jk) = ( ua(:,:,jk) - ua_b(:,:) ) * umask(:,:,jk)
+            va(:,:,jk) = ( va(:,:,jk) - va_b(:,:) ) * vmask(:,:,jk)
+         END DO
+         DO jj = 2, jpjm1        ! Add bottom/top stress due to barotropic component only
+            DO ji = fs_2, fs_jpim1   ! vector opt.
+               iku = mbku(ji,jj)         ! ocean bottom level at u- and v-points 
+               ikv = mbkv(ji,jj)         ! (deepest ocean u- and v-points)
+               ze3ua =  ( 1._wp - r_vvl ) * e3u_n(ji,jj,iku) + r_vvl * e3u_a(ji,jj,iku)
+               ze3va =  ( 1._wp - r_vvl ) * e3v_n(ji,jj,ikv) + r_vvl * e3v_a(ji,jj,ikv)
+               ua(ji,jj,iku) = ua(ji,jj,iku) + r2dt * 0.5*( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) ) * ua_b(ji,jj) / ze3ua
+               va(ji,jj,ikv) = va(ji,jj,ikv) + r2dt * 0.5*( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) ) * va_b(ji,jj) / ze3va
+            END DO
+         END DO
+         IF( ln_isfcav ) THEN    ! Ocean cavities (ISF)
+            DO jj = 2, jpjm1        
+               DO ji = fs_2, fs_jpim1   ! vector opt.
+                  iku = miku(ji,jj)         ! top ocean level at u- and v-points 
+                  ikv = mikv(ji,jj)         ! (first wet ocean u- and v-points)
+                  ze3ua =  ( 1._wp - r_vvl ) * e3u_n(ji,jj,iku) + r_vvl * e3u_a(ji,jj,iku)
+                  ze3va =  ( 1._wp - r_vvl ) * e3v_n(ji,jj,ikv) + r_vvl * e3v_a(ji,jj,ikv)
+                  ua(ji,jj,iku) = ua(ji,jj,iku) + r2dt * 0.5*( rCdU_top(ji+1,jj)+rCdU_top(ji,jj) ) * ua_b(ji,jj) / ze3ua
+                  va(ji,jj,ikv) = va(ji,jj,ikv) + r2dt * 0.5*( rCdU_top(ji+1,jj)+rCdU_top(ji,jj) ) * va_b(ji,jj) / ze3va
+               END DO
+            END DO
+         END IF
+      ENDIF
+      !
+      !              !==  Vertical diffusion on u  ==!
+      !
+      !                    !* Matrix construction
+      zdt = r2dt * 0.5
+      SELECT CASE( nldf_dyn )
+      CASE( np_lap_i )           ! rotated lateral mixing: add its vertical mixing (akzu)
+         DO jk = 1, jpkm1
+            DO jj = 2, jpjm1 
+               DO ji = fs_2, fs_jpim1   ! vector opt.
+                  ze3ua =  ( 1._wp - r_vvl ) * e3u_n(ji,jj,jk) + r_vvl * e3u_a(ji,jj,jk)   ! after scale factor at T-point
+                  zzwi = - zdt * ( avm(ji+1,jj,jk  ) + avm(ji,jj,jk  ) + akzu(ji,jj,jk  ) )   &
+                     &         / ( ze3ua * e3uw_n(ji,jj,jk  ) ) * wumask(ji,jj,jk  )
+                  zzws = - zdt * ( avm(ji+1,jj,jk+1) + avm(ji,jj,jk+1) + akzu(ji,jj,jk+1) )   &
+                     &         / ( ze3ua * e3uw_n(ji,jj,jk+1) ) * wumask(ji,jj,jk+1)
+                  zwi(ji,jj,jk) = zzwi
+                  zws(ji,jj,jk) = zzws
+                  zwd(ji,jj,jk) = 1._wp - zzwi - zzws
+               END DO
+            END DO
+         END DO
+      CASE DEFAULT               ! iso-level lateral mixing
+         DO jk = 1, jpkm1
+            DO jj = 2, jpjm1 
+               DO ji = fs_2, fs_jpim1   ! vector opt.
+                  ze3ua =  ( 1._wp - r_vvl ) * e3u_n(ji,jj,jk) + r_vvl * e3u_a(ji,jj,jk)   ! after scale factor at T-point
+                  zzwi = - zdt * ( avm(ji+1,jj,jk  ) + avm(ji,jj,jk  ) ) / ( ze3ua * e3uw_n(ji,jj,jk  ) ) * wumask(ji,jj,jk  )
+                  zzws = - zdt * ( avm(ji+1,jj,jk+1) + avm(ji,jj,jk+1) ) / ( ze3ua * e3uw_n(ji,jj,jk+1) ) * wumask(ji,jj,jk+1)
+                  zwi(ji,jj,jk) = zzwi
+                  zws(ji,jj,jk) = zzws
+                  zwd(ji,jj,jk) = 1._wp - zzwi - zzws
+               END DO
+            END DO
+         END DO
+      END SELECT
+      !
+      DO jj = 2, jpjm1     !* Surface boundary conditions
+         DO ji = fs_2, fs_jpim1   ! vector opt.
+            zwi(ji,jj,1) = 0._wp
+            zwd(ji,jj,1) = 1._wp - zws(ji,jj,1)
+         END DO
+      END DO
+      !
+      !              !==  Apply semi-implicit bottom friction  ==!
+      !
+      !     Only needed for semi-implicit bottom friction setup. The explicit
+      !     bottom friction has been included in "u(v)a" which act as the R.H.S
+      !     column vector of the tri-diagonal matrix equation
+      !
+      IF ( ln_drgimp ) THEN      ! implicit bottom friction
+         DO jj = 2, jpjm1
+            DO ji = 2, jpim1
+               iku = mbku(ji,jj)       ! ocean bottom level at u- and v-points
+               ze3ua =  ( 1._wp - r_vvl ) * e3u_n(ji,jj,iku) + r_vvl * e3u_a(ji,jj,iku)   ! after scale factor at T-point
+               zwd(ji,jj,iku) = zwd(ji,jj,iku) - r2dt * 0.5*( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) ) / ze3ua
+            END DO
+         END DO
+         IF ( ln_isfcav ) THEN   ! top friction (always implicit)
+            DO jj = 2, jpjm1
+               DO ji = 2, jpim1
+                  !!gm   top Cd is masked (=0 outside cavities) no need of test on mik>=2  ==>> it has been suppressed
+                  iku = miku(ji,jj)       ! ocean top level at u- and v-points 
+                  ze3ua =  ( 1._wp - r_vvl ) * e3u_n(ji,jj,iku) + r_vvl * e3u_a(ji,jj,iku)   ! after scale factor at T-point
+                  zwd(ji,jj,iku) = zwd(ji,jj,iku) - r2dt * 0.5*( rCdU_top(ji+1,jj)+rCdU_top(ji,jj) ) / ze3ua
+               END DO
+            END DO
+         END IF
+      ENDIF
+      !
+      ! Matrix inversion starting from the first level
+      !-----------------------------------------------------------------------
+      !   solve m.x = y  where m is a tri diagonal matrix ( jpk*jpk )
+      !
+      !        ( zwd1 zws1   0    0    0  )( zwx1 ) ( zwy1 )
+      !        ( zwi2 zwd2 zws2   0    0  )( zwx2 ) ( zwy2 )
+      !        (  0   zwi3 zwd3 zws3   0  )( zwx3 )=( zwy3 )
+      !        (        ...               )( ...  ) ( ...  )
+      !        (  0    0    0   zwik zwdk )( zwxk ) ( zwyk )
+      !
+      !   m is decomposed in the product of an upper and a lower triangular matrix
+      !   The 3 diagonal terms are in 2d arrays: zwd, zws, zwi
+      !   The solution (the after velocity) is in ua
+      !-----------------------------------------------------------------------
+      !
+      DO jk = 2, jpkm1        !==  First recurrence : Dk = Dk - Lk * Uk-1 / Dk-1   (increasing k)  ==
+         DO jj = 2, jpjm1   
+            DO ji = fs_2, fs_jpim1   ! vector opt.
+               zwd(ji,jj,jk) = zwd(ji,jj,jk) - zwi(ji,jj,jk) * zws(ji,jj,jk-1) / zwd(ji,jj,jk-1)
+            END DO
+         END DO
+      END DO
+      !
+      DO jj = 2, jpjm1        !==  second recurrence:    SOLk = RHSk - Lk / Dk-1  Lk-1  ==!
+         DO ji = fs_2, fs_jpim1   ! vector opt.
+            ze3ua =  ( 1._wp - r_vvl ) * e3u_n(ji,jj,1) + r_vvl * e3u_a(ji,jj,1) 
+            ua(ji,jj,1) = ua(ji,jj,1) + r2dt * 0.5_wp * ( utau_b(ji,jj) + utau(ji,jj) )   &
+               &                                      / ( ze3ua * rau0 ) * umask(ji,jj,1) 
+         END DO
+      END DO
+      DO jk = 2, jpkm1
+         DO jj = 2, jpjm1
+            DO ji = fs_2, fs_jpim1
+               ua(ji,jj,jk) = ua(ji,jj,jk) - zwi(ji,jj,jk) / zwd(ji,jj,jk-1) * ua(ji,jj,jk-1)
+            END DO
+         END DO
+      END DO
+      !
+      DO jj = 2, jpjm1        !==  thrid recurrence : SOLk = ( Lk - Uk * Ek+1 ) / Dk  ==!
+         DO ji = fs_2, fs_jpim1   ! vector opt.
+            ua(ji,jj,jpkm1) = ua(ji,jj,jpkm1) / zwd(ji,jj,jpkm1)
+         END DO
+      END DO
+      DO jk = jpk-2, 1, -1
+         DO jj = 2, jpjm1
+            DO ji = fs_2, fs_jpim1
+               ua(ji,jj,jk) = ( ua(ji,jj,jk) - zws(ji,jj,jk) * ua(ji,jj,jk+1) ) / zwd(ji,jj,jk)
+            END DO
+         END DO
+      END DO
+      !
+      !              !==  Vertical diffusion on v  ==!
+      !
+      !                       !* Matrix construction
+      zdt = r2dt * 0.5
+      SELECT CASE( nldf_dyn )
+      CASE( np_lap_i )           ! rotated lateral mixing: add its vertical mixing (akzu)
+         DO jk = 1, jpkm1
+            DO jj = 2, jpjm1   
+               DO ji = fs_2, fs_jpim1   ! vector opt.
+                  ze3va =  ( 1._wp - r_vvl ) * e3v_n(ji,jj,jk) + r_vvl * e3v_a(ji,jj,jk)   ! after scale factor at T-point
+                  zzwi = - zdt * ( avm(ji,jj+1,jk  ) + avm(ji,jj,jk  ) + akzv(ji,jj,jk  ) )   &
+                     &         / ( ze3va * e3vw_n(ji,jj,jk  ) ) * wvmask(ji,jj,jk  )
+                  zzws = - zdt * ( avm(ji,jj+1,jk+1) + avm(ji,jj,jk+1) + akzv(ji,jj,jk+1) )   &
+                     &         / ( ze3va * e3vw_n(ji,jj,jk+1) ) * wvmask(ji,jj,jk+1)
+                  zwi(ji,jj,jk) = zzwi * wvmask(ji,jj,jk  )
+                  zws(ji,jj,jk) = zzws * wvmask(ji,jj,jk+1)
+                  zwd(ji,jj,jk) = 1._wp - zzwi - zzws
+               END DO
+            END DO
+         END DO
+      CASE DEFAULT               ! iso-level lateral mixing
+         DO jk = 1, jpkm1
+            DO jj = 2, jpjm1   
+               DO ji = fs_2, fs_jpim1   ! vector opt.
+                  ze3va =  ( 1._wp - r_vvl ) * e3v_n(ji,jj,jk) + r_vvl * e3v_a(ji,jj,jk)   ! after scale factor at T-point
+                  zzwi = - zdt * ( avm(ji,jj+1,jk  ) + avm(ji,jj,jk  ) ) / ( ze3va * e3vw_n(ji,jj,jk  ) ) * wvmask(ji,jj,jk  )
+                  zzws = - zdt * ( avm(ji,jj+1,jk+1) + avm(ji,jj,jk+1) ) / ( ze3va * e3vw_n(ji,jj,jk+1) ) * wvmask(ji,jj,jk+1)
+                  zwi(ji,jj,jk) = zzwi * wvmask(ji,jj,jk  )
+                  zws(ji,jj,jk) = zzws * wvmask(ji,jj,jk+1)
+                  zwd(ji,jj,jk) = 1._wp - zzwi - zzws
+               END DO
+            END DO
+         END DO
+      END SELECT
+      !
+      DO jj = 2, jpjm1        !* Surface boundary conditions
+         DO ji = fs_2, fs_jpim1   ! vector opt.
+            zwi(ji,jj,1) = 0._wp
+            zwd(ji,jj,1) = 1._wp - zws(ji,jj,1)
+         END DO
+      END DO
+      !              !==  Apply semi-implicit top/bottom friction  ==!
+      !
+      !     Only needed for semi-implicit bottom friction setup. The explicit
+      !     bottom friction has been included in "u(v)a" which act as the R.H.S
+      !     column vector of the tri-diagonal matrix equation
+      !
+      IF( ln_drgimp ) THEN
+         DO jj = 2, jpjm1
+            DO ji = 2, jpim1
+               ikv = mbkv(ji,jj)       ! (deepest ocean u- and v-points)
+               ze3va =  ( 1._wp - r_vvl ) * e3v_n(ji,jj,ikv) + r_vvl * e3v_a(ji,jj,ikv)   ! after scale factor at T-point
+               zwd(ji,jj,ikv) = zwd(ji,jj,ikv) - r2dt * 0.5*( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) ) / ze3va           
+            END DO
+         END DO
+         IF ( ln_isfcav ) THEN
+            DO jj = 2, jpjm1
+               DO ji = 2, jpim1
+                  ikv = mikv(ji,jj)       ! (first wet ocean u- and v-points)
+                  ze3va =  ( 1._wp - r_vvl ) * e3v_n(ji,jj,ikv) + r_vvl * e3v_a(ji,jj,ikv)   ! after scale factor at T-point
+                  zwd(ji,jj,iku) = zwd(ji,jj,iku) - r2dt * 0.5*( rCdU_top(ji+1,jj)+rCdU_top(ji,jj) ) / ze3va
+               END DO
+            END DO
+         ENDIF
+      ENDIF
+
+      ! Matrix inversion
+      !-----------------------------------------------------------------------
+      !   solve m.x = y  where m is a tri diagonal matrix ( jpk*jpk )
+      !
+      !        ( zwd1 zws1   0    0    0  )( zwx1 ) ( zwy1 )
+      !        ( zwi2 zwd2 zws2   0    0  )( zwx2 ) ( zwy2 )
+      !        (  0   zwi3 zwd3 zws3   0  )( zwx3 )=( zwy3 )
+      !        (        ...               )( ...  ) ( ...  )
+      !        (  0    0    0   zwik zwdk )( zwxk ) ( zwyk )
+      !
+      !   m is decomposed in the product of an upper and lower triangular matrix
+      !   The 3 diagonal terms are in 2d arrays: zwd, zws, zwi
+      !   The solution (after velocity) is in 2d array va
+      !-----------------------------------------------------------------------
+      !
+      DO jk = 2, jpkm1        !==  First recurrence : Dk = Dk - Lk * Uk-1 / Dk-1   (increasing k)  ==
+         DO jj = 2, jpjm1   
+            DO ji = fs_2, fs_jpim1   ! vector opt.
+               zwd(ji,jj,jk) = zwd(ji,jj,jk) - zwi(ji,jj,jk) * zws(ji,jj,jk-1) / zwd(ji,jj,jk-1)
+            END DO
+         END DO
+      END DO
+      !
+      DO jj = 2, jpjm1        !==  second recurrence:    SOLk = RHSk - Lk / Dk-1  Lk-1  ==!
+         DO ji = fs_2, fs_jpim1   ! vector opt.          
+            ze3va =  ( 1._wp - r_vvl ) * e3v_n(ji,jj,1) + r_vvl * e3v_a(ji,jj,1) 
+            va(ji,jj,1) = va(ji,jj,1) + r2dt * 0.5_wp * ( vtau_b(ji,jj) + vtau(ji,jj) )   &
+               &                                      / ( ze3va * rau0 ) * vmask(ji,jj,1) 
+         END DO
+      END DO
+      DO jk = 2, jpkm1
+         DO jj = 2, jpjm1
+            DO ji = fs_2, fs_jpim1   ! vector opt.
+               va(ji,jj,jk) = va(ji,jj,jk) - zwi(ji,jj,jk) / zwd(ji,jj,jk-1) * va(ji,jj,jk-1)
+            END DO
+         END DO
+      END DO
+      !
+      DO jj = 2, jpjm1        !==  third recurrence : SOLk = ( Lk - Uk * SOLk+1 ) / Dk  ==!
+         DO ji = fs_2, fs_jpim1   ! vector opt.
+            va(ji,jj,jpkm1) = va(ji,jj,jpkm1) / zwd(ji,jj,jpkm1)
+         END DO
+      END DO
+      DO jk = jpk-2, 1, -1
+         DO jj = 2, jpjm1
+            DO ji = fs_2, fs_jpim1
+               va(ji,jj,jk) = ( va(ji,jj,jk) - zws(ji,jj,jk) * va(ji,jj,jk+1) ) / zwd(ji,jj,jk)
+            END DO
+         END DO
+      END DO
+      !
+      IF( l_trddyn )   THEN                      ! save the vertical diffusive trends for further diagnostics
+         ztrdu(:,:,:) = ( ua(:,:,:) - ub(:,:,:) ) / r2dt - ztrdu(:,:,:)
+         ztrdv(:,:,:) = ( va(:,:,:) - vb(:,:,:) ) / r2dt - ztrdv(:,:,:)
+         CALL trd_dyn( ztrdu, ztrdv, jpdyn_zdf, kt )
+         DEALLOCATE( ztrdu, ztrdv ) 
+      ENDIF
+      !                                          ! print mean trends (used for debugging)
+      IF(ln_ctl)   CALL prt_ctl( tab3d_1=ua, clinfo1=' zdf  - Ua: ', mask1=umask,               &
+         &                       tab3d_2=va, clinfo2=       ' Va: ', mask2=vmask, clinfo3='dyn' )
+         !
+      IF( ln_timing )   CALL timing_stop('dyn_zdf')
+      !
+   END SUBROUTINE dyn_zdf
+
+   !!==============================================================================
+END MODULE dynzdf
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DYN/sshwzv.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DYN/sshwzv.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DYN/sshwzv.F90	(revision 9570)
@@ -0,0 +1,268 @@
+MODULE sshwzv   
+   !!==============================================================================
+   !!                       ***  MODULE  sshwzv  ***
+   !! Ocean dynamics : sea surface height and vertical velocity
+   !!==============================================================================
+   !! History :  3.1  !  2009-02  (G. Madec, M. Leclair)  Original code
+   !!            3.3  !  2010-04  (M. Leclair, G. Madec)  modified LF-RA 
+   !!             -   !  2010-05  (K. Mogensen, A. Weaver, M. Martin, D. Lea) Assimilation interface
+   !!             -   !  2010-09  (D.Storkey and E.O'Dea) bug fixes for BDY module
+   !!            3.3  !  2011-10  (M. Leclair) split former ssh_wzv routine and remove all vvl related work
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   ssh_nxt       : after ssh
+   !!   ssh_swp       : filter ans swap the ssh arrays
+   !!   wzv           : compute now vertical velocity
+   !!----------------------------------------------------------------------
+   USE oce            ! ocean dynamics and tracers variables
+   USE dom_oce        ! ocean space and time domain variables 
+   USE sbc_oce        ! surface boundary condition: ocean
+   USE domvvl         ! Variable volume
+   USE divhor         ! horizontal divergence
+   USE phycst         ! physical constants
+   USE bdy_oce , ONLY : ln_bdy, bdytmask   ! Open BounDarY
+   USE bdydyn2d       ! bdy_ssh routine
+#if defined key_agrif
+   USE agrif_oce_interp
+#endif
+   !
+   USE in_out_manager ! I/O manager
+   USE restart        ! only for lrst_oce
+   USE prtctl         ! Print control
+   USE lbclnk         ! ocean lateral boundary condition (or mpp link)
+   USE lib_mpp        ! MPP library
+   USE timing         ! Timing
+   USE wet_dry        ! Wetting/Drying flux limiting
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   ssh_nxt    ! called by step.F90
+   PUBLIC   wzv        ! called by step.F90
+   PUBLIC   ssh_swp    ! called by step.F90
+
+   !! * Substitutions
+#  include "vectopt_loop_substitute.h90"
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO Consortium (2010)
+   !! $Id$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE ssh_nxt( kt )
+      !!----------------------------------------------------------------------
+      !!                ***  ROUTINE ssh_nxt  ***
+      !!                   
+      !! ** Purpose :   compute the after ssh (ssha)
+      !!
+      !! ** Method  : - Using the incompressibility hypothesis, the ssh increment
+      !!      is computed by integrating the horizontal divergence and multiply by
+      !!      by the time step.
+      !!
+      !! ** action  :   ssha, after sea surface height
+      !!
+      !! Reference  : Leclair, M., and G. Madec, 2009, Ocean Modelling.
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT(in) ::   kt   ! time step
+      ! 
+      INTEGER  ::   jk            ! dummy loop indice
+      REAL(wp) ::   z2dt, zcoef   ! local scalars
+      REAL(wp), DIMENSION(jpi,jpj) ::   zhdiv   ! 2D workspace
+      !!----------------------------------------------------------------------
+      !
+      IF( ln_timing )   CALL timing_start('ssh_nxt')
+      !
+      IF( kt == nit000 ) THEN
+         IF(lwp) WRITE(numout,*)
+         IF(lwp) WRITE(numout,*) 'ssh_nxt : after sea surface height'
+         IF(lwp) WRITE(numout,*) '~~~~~~~ '
+      ENDIF
+      !
+      z2dt = 2._wp * rdt                          ! set time step size (Euler/Leapfrog)
+      IF( neuler == 0 .AND. kt == nit000 )   z2dt = rdt
+      zcoef = 0.5_wp * r1_rau0
+
+      !                                           !------------------------------!
+      !                                           !   After Sea Surface Height   !
+      !                                           !------------------------------!
+      IF(ln_wd_il) THEN
+         CALL wad_lmt(sshb, zcoef * (emp_b(:,:) + emp(:,:)), z2dt)
+      ENDIF
+
+      CALL div_hor( kt )                               ! Horizontal divergence
+      !
+      zhdiv(:,:) = 0._wp
+      DO jk = 1, jpkm1                                 ! Horizontal divergence of barotropic transports
+        zhdiv(:,:) = zhdiv(:,:) + e3t_n(:,:,jk) * hdivn(:,:,jk)
+      END DO
+      !                                                ! Sea surface elevation time stepping
+      ! In time-split case we need a first guess of the ssh after (using the baroclinic timestep) in order to
+      ! compute the vertical velocity which can be used to compute the non-linear terms of the momentum equations.
+      ! 
+      ssha(:,:) = (  sshb(:,:) - z2dt * ( zcoef * ( emp_b(:,:) + emp(:,:) ) + zhdiv(:,:) )  ) * ssmask(:,:)
+      !
+#if defined key_agrif
+      CALL agrif_ssh( kt )
+#endif
+      !
+      IF ( .NOT.ln_dynspg_ts ) THEN
+         IF( ln_bdy ) THEN
+            CALL lbc_lnk( ssha, 'T', 1. )    ! Not sure that's necessary
+            CALL bdy_ssh( ssha )             ! Duplicate sea level across open boundaries
+         ENDIF
+      ENDIF
+      !                                           !------------------------------!
+      !                                           !           outputs            !
+      !                                           !------------------------------!
+      !
+      IF(ln_ctl)   CALL prt_ctl( tab2d_1=ssha, clinfo1=' ssha  - : ', mask1=tmask )
+      !
+      IF( ln_timing )   CALL timing_stop('ssh_nxt')
+      !
+   END SUBROUTINE ssh_nxt
+
+   
+   SUBROUTINE wzv( kt )
+      !!----------------------------------------------------------------------
+      !!                ***  ROUTINE wzv  ***
+      !!                   
+      !! ** Purpose :   compute the now vertical velocity
+      !!
+      !! ** Method  : - Using the incompressibility hypothesis, the vertical 
+      !!      velocity is computed by integrating the horizontal divergence  
+      !!      from the bottom to the surface minus the scale factor evolution.
+      !!        The boundary conditions are w=0 at the bottom (no flux) and.
+      !!
+      !! ** action  :   wn      : now vertical velocity
+      !!
+      !! Reference  : Leclair, M., and G. Madec, 2009, Ocean Modelling.
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT(in) ::   kt   ! time step
+      !
+      INTEGER  ::   ji, jj, jk   ! dummy loop indices
+      REAL(wp) ::   z1_2dt       ! local scalars
+      REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) ::   zhdiv
+      !!----------------------------------------------------------------------
+      !
+      IF( ln_timing )   CALL timing_start('wzv')
+      !
+      IF( kt == nit000 ) THEN
+         IF(lwp) WRITE(numout,*)
+         IF(lwp) WRITE(numout,*) 'wzv : now vertical velocity '
+         IF(lwp) WRITE(numout,*) '~~~~~ '
+         !
+         wn(:,:,jpk) = 0._wp                  ! bottom boundary condition: w=0 (set once for all)
+      ENDIF
+      !                                           !------------------------------!
+      !                                           !     Now Vertical Velocity    !
+      !                                           !------------------------------!
+      z1_2dt = 1. / ( 2. * rdt )                         ! set time step size (Euler/Leapfrog)
+      IF( neuler == 0 .AND. kt == nit000 )   z1_2dt = 1. / rdt
+      !
+      IF( ln_vvl_ztilde .OR. ln_vvl_layer ) THEN      ! z_tilde and layer cases
+         ALLOCATE( zhdiv(jpi,jpj,jpk) ) 
+         !
+         DO jk = 1, jpkm1
+            ! horizontal divergence of thickness diffusion transport ( velocity multiplied by e3t)
+            ! - ML - note: computation already done in dom_vvl_sf_nxt. Could be optimized (not critical and clearer this way)
+            DO jj = 2, jpjm1
+               DO ji = fs_2, fs_jpim1   ! vector opt.
+                  zhdiv(ji,jj,jk) = r1_e1e2t(ji,jj) * ( un_td(ji,jj,jk) - un_td(ji-1,jj,jk) + vn_td(ji,jj,jk) - vn_td(ji,jj-1,jk) )
+               END DO
+            END DO
+         END DO
+         CALL lbc_lnk(zhdiv, 'T', 1.)  ! - ML - Perhaps not necessary: not used for horizontal "connexions"
+         !                             ! Is it problematic to have a wrong vertical velocity in boundary cells?
+         !                             ! Same question holds for hdivn. Perhaps just for security
+         DO jk = jpkm1, 1, -1                       ! integrate from the bottom the hor. divergence
+            ! computation of w
+            wn(:,:,jk) = wn(:,:,jk+1) - (  e3t_n(:,:,jk) * hdivn(:,:,jk) + zhdiv(:,:,jk)    &
+               &                         + z1_2dt * ( e3t_a(:,:,jk) - e3t_b(:,:,jk) )     ) * tmask(:,:,jk)
+         END DO
+         !          IF( ln_vvl_layer ) wn(:,:,:) = 0.e0
+         DEALLOCATE( zhdiv ) 
+      ELSE   ! z_star and linear free surface cases
+         DO jk = jpkm1, 1, -1                       ! integrate from the bottom the hor. divergence
+            ! computation of w
+            wn(:,:,jk) = wn(:,:,jk+1) - (  e3t_n(:,:,jk) * hdivn(:,:,jk)                 &
+               &                         + z1_2dt * ( e3t_a(:,:,jk) - e3t_b(:,:,jk) )  ) * tmask(:,:,jk)
+         END DO
+      ENDIF
+
+      IF( ln_bdy ) THEN
+         DO jk = 1, jpkm1
+            wn(:,:,jk) = wn(:,:,jk) * bdytmask(:,:)
+         END DO
+      ENDIF
+      !
+#if defined key_agrif 
+      IF( .NOT. AGRIF_Root() ) THEN 
+         IF ((nbondi ==  1).OR.(nbondi == 2)) wn(nlci-1 , :     ,:) = 0.e0      ! east 
+         IF ((nbondi == -1).OR.(nbondi == 2)) wn(2      , :     ,:) = 0.e0      ! west 
+         IF ((nbondj ==  1).OR.(nbondj == 2)) wn(:      ,nlcj-1 ,:) = 0.e0      ! north 
+         IF ((nbondj == -1).OR.(nbondj == 2)) wn(:      ,2      ,:) = 0.e0      ! south 
+      ENDIF 
+#endif 
+      !
+      IF( ln_timing )   CALL timing_stop('wzv')
+      !
+   END SUBROUTINE wzv
+
+
+   SUBROUTINE ssh_swp( kt )
+      !!----------------------------------------------------------------------
+      !!                    ***  ROUTINE ssh_nxt  ***
+      !!
+      !! ** Purpose :   achieve the sea surface  height time stepping by 
+      !!              applying Asselin time filter and swapping the arrays
+      !!              ssha  already computed in ssh_nxt  
+      !!
+      !! ** Method  : - apply Asselin time fiter to now ssh (excluding the forcing
+      !!              from the filter, see Leclair and Madec 2010) and swap :
+      !!                sshn = ssha + atfp * ( sshb -2 sshn + ssha )
+      !!                            - atfp * rdt * ( emp_b - emp ) / rau0
+      !!                sshn = ssha
+      !!
+      !! ** action  : - sshb, sshn   : before & now sea surface height
+      !!                               ready for the next time step
+      !!
+      !! Reference  : Leclair, M., and G. Madec, 2009, Ocean Modelling.
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT(in) ::   kt   ! ocean time-step index
+      !
+      REAL(wp) ::   zcoef   ! local scalar
+      !!----------------------------------------------------------------------
+      !
+      IF( ln_timing )   CALL timing_start('ssh_swp')
+      !
+      IF( kt == nit000 ) THEN
+         IF(lwp) WRITE(numout,*)
+         IF(lwp) WRITE(numout,*) 'ssh_swp : Asselin time filter and swap of sea surface height'
+         IF(lwp) WRITE(numout,*) '~~~~~~~ '
+      ENDIF
+      !              !==  Euler time-stepping: no filter, just swap  ==!
+      IF ( neuler == 0 .AND. kt == nit000 ) THEN
+         sshn(:,:) = ssha(:,:)                              ! now    <-- after  (before already = now)
+         !
+      ELSE           !==  Leap-Frog time-stepping: Asselin filter + swap  ==!
+         !                                                  ! before <-- now filtered
+         sshb(:,:) = sshn(:,:) + atfp * ( sshb(:,:) - 2 * sshn(:,:) + ssha(:,:) )
+         IF( .NOT.ln_linssh ) THEN                          ! before <-- with forcing removed
+            zcoef = atfp * rdt * r1_rau0
+            sshb(:,:) = sshb(:,:) - zcoef * (     emp_b(:,:) - emp   (:,:)   &
+               &                             -    rnf_b(:,:) + rnf   (:,:)   &
+               &                             + fwfisf_b(:,:) - fwfisf(:,:)   ) * ssmask(:,:)
+         ENDIF
+         sshn(:,:) = ssha(:,:)                              ! now <-- after
+      ENDIF
+      !
+      IF(ln_ctl)   CALL prt_ctl( tab2d_1=sshb, clinfo1=' sshb  - : ', mask1=tmask )
+      !
+      IF( ln_timing )   CALL timing_stop('ssh_swp')
+      !
+   END SUBROUTINE ssh_swp
+
+   !!======================================================================
+END MODULE sshwzv
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DYN/wet_dry.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DYN/wet_dry.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/DYN/wet_dry.F90	(revision 9570)
@@ -0,0 +1,396 @@
+MODULE wet_dry
+
+   !! includes updates to namelist namwad for diagnostic outputs of ROMS wetting and drying
+
+   !!==============================================================================
+   !!                       ***  MODULE  wet_dry  ***
+   !! Wetting and drying includes initialisation routine and routines to
+   !! compute and apply flux limiters and preserve water depth positivity
+   !! only effects if wetting/drying is on (ln_wd_il == .true. or ln_wd_dl==.true. )
+   !!==============================================================================
+   !! History :  3.6  ! 2014-09  ((H.Liu)  Original code
+   !!                 ! will add the runoff and periodic BC case later
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   wad_init      : initialisation of wetting and drying
+   !!   wad_lmt       : horizontal flux limiter and limited velocity when wetting and drying happens
+   !!   wad_lmt_bt    : same as wad_lmt for the barotropic stepping (dynspg_ts)
+   !!----------------------------------------------------------------------
+   USE oce            ! ocean dynamics and tracers
+   USE dom_oce        ! ocean space and time domain
+   USE sbc_oce  , ONLY: ln_rnf   ! surface boundary condition: ocean
+   USE sbcrnf         ! river runoff 
+   !
+   USE in_out_manager ! I/O manager
+   USE lbclnk         ! ocean lateral boundary conditions (or mpp link)
+   USE lib_mpp        ! MPP library
+   USE timing         ! timing of the main modules
+
+   IMPLICIT NONE
+   PRIVATE
+
+   !!----------------------------------------------------------------------
+   !! critical depths,filters, limiters,and masks for  Wetting and Drying
+   !! ---------------------------------------------------------------------
+
+   REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) ::   wdmask   !: u- and v- limiter 
+   !                                                           !  (can include negative depths)
+   REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) ::   wdramp, wdrampu, wdrampv !: for hpg limiting
+
+   LOGICAL,  PUBLIC  ::   ln_wd_il    !: Wetting/drying il activation switch (T:on,F:off)
+   LOGICAL,  PUBLIC  ::   ln_wd_dl    !: Wetting/drying dl activation switch (T:on,F:off)
+   REAL(wp), PUBLIC  ::   rn_wdmin0   !: depth at which wetting/drying starts
+   REAL(wp), PUBLIC  ::   rn_wdmin1   !: minimum water depth on dried cells
+   REAL(wp), PUBLIC  ::   r_rn_wdmin1 !: 1/minimum water depth on dried cells 
+   REAL(wp), PUBLIC  ::   rn_wdmin2   !: tolerance of minimum water depth on dried cells
+   REAL(wp), PUBLIC  ::   rn_wdld     !: land elevation below which wetting/drying will be considered
+   INTEGER , PUBLIC  ::   nn_wdit     !: maximum number of iteration for W/D limiter
+   LOGICAL,  PUBLIC  ::   ln_wd_dl_bc !: DL scheme: True implies 3D velocities are set to the barotropic values at points 
+                                      !: where the flow is from wet points on less than half the barotropic sub-steps  
+   LOGICAL,  PUBLIC  ::  ln_wd_dl_rmp !: use a ramp for the dl flux limiter between 2 rn_wdmin1 and rn_wdmin1 (rather than a cut-off at rn_wdmin1)      
+   REAL(wp), PUBLIC  ::   ssh_ref     !: height of z=0 with respect to the geoid; 
+
+   LOGICAL,  PUBLIC  ::   ll_wd       !: Wetting/drying activation switch if either ln_wd_il or ln_wd_dl
+
+   PUBLIC   wad_init                  ! initialisation routine called by step.F90
+   PUBLIC   wad_lmt                   ! routine called by sshwzv.F90
+   PUBLIC   wad_lmt_bt                ! routine called by dynspg_ts.F90
+
+   !! * Substitutions
+#  include "vectopt_loop_substitute.h90"
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE wad_init
+      !!----------------------------------------------------------------------
+      !!                     ***  ROUTINE wad_init  ***
+      !!                    
+      !! ** Purpose :   read wetting and drying namelist and print the variables.
+      !!
+      !! ** input   : - namwad namelist
+      !!----------------------------------------------------------------------
+      INTEGER  ::   ios, ierr   ! Local integer
+      !!
+      NAMELIST/namwad/ ln_wd_il, ln_wd_dl   , rn_wdmin0, rn_wdmin1, rn_wdmin2, rn_wdld,   &
+         &             nn_wdit , ln_wd_dl_bc, ln_wd_dl_rmp
+      !!----------------------------------------------------------------------
+      !
+      REWIND( numnam_ref )              ! Namelist namwad in reference namelist : Parameters for Wetting/Drying
+      READ  ( numnam_ref, namwad, IOSTAT = ios, ERR = 905)
+905   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namwad in reference namelist', .TRUE.) 
+      REWIND( numnam_cfg )              ! Namelist namwad in configuration namelist : Parameters for Wetting/Drying
+      READ  ( numnam_cfg, namwad, IOSTAT = ios, ERR = 906)
+906   IF( ios >  0 )   CALL ctl_nam ( ios , 'namwad in configuration namelist', .TRUE. )
+      IF(lwm) WRITE ( numond, namwad )
+      !
+      IF(lwp) THEN                  ! control print
+         WRITE(numout,*)
+         WRITE(numout,*) 'wad_init : Wetting and drying initialization through namelist read'
+         WRITE(numout,*) '~~~~~~~~'
+         WRITE(numout,*) '   Namelist namwad'
+         WRITE(numout,*) '      Logical for Iter Lim wd option   ln_wd_il     = ', ln_wd_il
+         WRITE(numout,*) '      Logical for Dir. Lim wd option   ln_wd_dl     = ', ln_wd_dl
+         WRITE(numout,*) '      Depth at which wet/drying starts rn_wdmin0    = ', rn_wdmin0
+         WRITE(numout,*) '      Minimum wet depth on dried cells rn_wdmin1    = ', rn_wdmin1
+         WRITE(numout,*) '      Tolerance of min wet depth       rn_wdmin2    = ', rn_wdmin2
+         WRITE(numout,*) '      land elevation threshold         rn_wdld      = ', rn_wdld
+         WRITE(numout,*) '      Max iteration for W/D limiter    nn_wdit      = ', nn_wdit
+         WRITE(numout,*) '      T => baroclinic u,v=0 at dry pts: ln_wd_dl_bc = ', ln_wd_dl_bc     
+         WRITE(numout,*) '      use a ramp for rwd limiter:  ln_wd_dl_rwd_rmp = ', ln_wd_dl_rmp
+      ENDIF
+      IF( .NOT. ln_read_cfg ) THEN
+         IF(lwp) WRITE(numout,*) '      No configuration file so seting ssh_ref to zero  '
+         ssh_ref=0._wp
+      ENDIF
+
+      r_rn_wdmin1 = 1 / rn_wdmin1
+      ll_wd = .FALSE.
+      IF( ln_wd_il .OR. ln_wd_dl ) THEN
+         ll_wd = .TRUE.
+         ALLOCATE( wdmask(jpi,jpj),   STAT=ierr )
+         ALLOCATE( wdramp(jpi,jpj), wdrampu(jpi,jpj), wdrampv(jpi,jpj), STAT=ierr ) 
+         IF( ierr /= 0 ) CALL ctl_stop('STOP', 'wad_init : Array allocation error')
+      ENDIF
+      !
+   END SUBROUTINE wad_init
+
+
+   SUBROUTINE wad_lmt( sshb1, sshemp, z2dt )
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE wad_lmt  ***
+      !!                    
+      !! ** Purpose :   generate flux limiters for wetting/drying
+      !!
+      !! ** Method  : - Prevent negative depth occurring (Not ready for Agrif) 
+      !!
+      !! ** Action  : - calculate flux limiter and W/D flag
+      !!----------------------------------------------------------------------
+      REAL(wp), DIMENSION(:,:), INTENT(inout) ::   sshb1        !!gm DOCTOR names: should start with p !
+      REAL(wp), DIMENSION(:,:), INTENT(in   ) ::   sshemp
+      REAL(wp)                , INTENT(in   ) ::   z2dt
+      !
+      INTEGER  ::   ji, jj, jk, jk1     ! dummy loop indices
+      INTEGER  ::   jflag               ! local scalar
+      REAL(wp) ::   zcoef, zdep1, zdep2 ! local scalars
+      REAL(wp) ::   zzflxp, zzflxn      ! local scalars
+      REAL(wp) ::   zdepwd              ! local scalar, always wet cell depth
+      REAL(wp) ::   ztmp                ! local scalars
+      REAL(wp),  DIMENSION(jpi,jpj) ::   zwdlmtu, zwdlmtv   ! W/D flux limiters
+      REAL(wp),  DIMENSION(jpi,jpj) ::   zflxp  ,  zflxn    ! local 2D workspace
+      REAL(wp),  DIMENSION(jpi,jpj) ::   zflxu  ,  zflxv    ! local 2D workspace
+      REAL(wp),  DIMENSION(jpi,jpj) ::   zflxu1 , zflxv1    ! local 2D workspace
+      !!----------------------------------------------------------------------
+      IF( ln_timing )   CALL timing_start('wad_lmt')      !
+      !
+      DO jk = 1, jpkm1
+         un(:,:,jk) = un(:,:,jk) * zwdlmtu(:,:) 
+         vn(:,:,jk) = vn(:,:,jk) * zwdlmtv(:,:) 
+      END DO
+      jflag  = 0
+      zdepwd = 50._wp      ! maximum depth on which that W/D could possibly happen
+      !
+      zflxp(:,:)   = 0._wp
+      zflxn(:,:)   = 0._wp
+      zflxu(:,:)   = 0._wp
+      zflxv(:,:)   = 0._wp
+      !
+      zwdlmtu(:,:) = 1._wp
+      zwdlmtv(:,:) = 1._wp
+      !
+      DO jk = 1, jpkm1     ! Horizontal Flux in u and v direction
+         zflxu(:,:) = zflxu(:,:) + e3u_n(:,:,jk) * un(:,:,jk) * umask(:,:,jk)
+         zflxv(:,:) = zflxv(:,:) + e3v_n(:,:,jk) * vn(:,:,jk) * vmask(:,:,jk)
+      END DO
+      zflxu(:,:) = zflxu(:,:) * e2u(:,:)
+      zflxv(:,:) = zflxv(:,:) * e1v(:,:)
+      !
+      wdmask(:,:) = 1._wp
+      DO jj = 2, jpj
+         DO ji = 2, jpi 
+            !
+            IF( tmask(ji,jj,1)        < 0.5_wp )   CYCLE    ! we don't care about land cells
+            IF( ht_0(ji,jj) - ssh_ref > zdepwd )   CYCLE    ! and cells which are unlikely to dry
+            !
+            zflxp(ji,jj) = MAX( zflxu(ji,jj) , 0._wp ) - MIN( zflxu(ji-1,jj  ) , 0._wp )   &
+               &         + MAX( zflxv(ji,jj) , 0._wp ) - MIN( zflxv(ji,  jj-1) , 0._wp ) 
+            zflxn(ji,jj) = MIN( zflxu(ji,jj) , 0._wp ) - MAX( zflxu(ji-1,jj  ) , 0._wp )   &
+               &         + MIN( zflxv(ji,jj) , 0._wp ) - MAX( zflxv(ji,  jj-1) , 0._wp ) 
+            !
+            zdep2 = ht_0(ji,jj) + sshb1(ji,jj) - rn_wdmin1
+            IF( zdep2 <= 0._wp ) THEN     ! add more safty, but not necessary
+               sshb1(ji,jj) = rn_wdmin1 - ht_0(ji,jj)
+               IF(zflxu(ji,  jj) > 0._wp) zwdlmtu(ji  ,jj) = 0._wp
+               IF(zflxu(ji-1,jj) < 0._wp) zwdlmtu(ji-1,jj) = 0._wp
+               IF(zflxv(ji,  jj) > 0._wp) zwdlmtv(ji  ,jj) = 0._wp
+               IF(zflxv(ji,jj-1) < 0._wp) zwdlmtv(ji,jj-1) = 0._wp 
+               wdmask(ji,jj) = 0._wp
+            END IF
+         END DO
+      END DO
+      !
+      !           ! HPG limiter from jholt
+      wdramp(:,:) = min((ht_0(:,:) + sshb1(:,:) - rn_wdmin1)/(rn_wdmin0 - rn_wdmin1),1.0_wp)
+      !jth assume don't need a lbc_lnk here
+      DO jj = 1, jpjm1
+         DO ji = 1, jpim1
+            wdrampu(ji,jj) = MIN( wdramp(ji,jj) , wdramp(ji+1,jj) )
+            wdrampv(ji,jj) = MIN( wdramp(ji,jj) , wdramp(ji,jj+1) )
+         END DO
+      END DO
+      !           ! end HPG limiter
+      !
+      !
+      DO jk1 = 1, nn_wdit + 1      !==  start limiter iterations  ==!
+         !
+         zflxu1(:,:) = zflxu(:,:) * zwdlmtu(:,:)
+         zflxv1(:,:) = zflxv(:,:) * zwdlmtv(:,:)
+         jflag = 0     ! flag indicating if any further iterations are needed
+         !
+         DO jj = 2, jpj
+            DO ji = 2, jpi 
+               IF( tmask(ji, jj, 1) < 0.5_wp )   CYCLE 
+               IF( ht_0(ji,jj)      > zdepwd )   CYCLE
+               !
+               ztmp = e1e2t(ji,jj)
+               !
+               zzflxp = MAX( zflxu1(ji,jj) , 0._wp ) - MIN( zflxu1(ji-1,jj  ) , 0._wp)   &
+                  &   + MAX( zflxv1(ji,jj) , 0._wp ) - MIN( zflxv1(ji,  jj-1) , 0._wp) 
+               zzflxn = MIN( zflxu1(ji,jj) , 0._wp ) - MAX( zflxu1(ji-1,jj  ) , 0._wp)   &
+                  &   + MIN( zflxv1(ji,jj) , 0._wp ) - MAX( zflxv1(ji,  jj-1) , 0._wp) 
+               !
+               zdep1 = (zzflxp + zzflxn) * z2dt / ztmp
+               zdep2 = ht_0(ji,jj) + sshb1(ji,jj) - rn_wdmin1 - z2dt * sshemp(ji,jj)
+               !
+               IF( zdep1 > zdep2 ) THEN
+                  wdmask(ji, jj) = 0._wp
+                  zcoef = ( ( zdep2 - rn_wdmin2 ) * ztmp - zzflxn * z2dt ) / ( zflxp(ji,jj) * z2dt )
+                  !zcoef = ( ( zdep2 - rn_wdmin2 ) * ztmp - zzflxn * z2dt ) / ( zzflxp * z2dt )
+                  ! flag if the limiter has been used but stop flagging if the only
+                  ! changes have zeroed the coefficient since further iterations will
+                  ! not change anything
+                  IF( zcoef > 0._wp ) THEN   ;   jflag = 1 
+                  ELSE                       ;   zcoef = 0._wp
+                  ENDIF
+                  IF( jk1 > nn_wdit )   zcoef = 0._wp
+                  IF( zflxu1(ji  ,jj  ) > 0._wp )   zwdlmtu(ji  ,jj  ) = zcoef
+                  IF( zflxu1(ji-1,jj  ) < 0._wp )   zwdlmtu(ji-1,jj  ) = zcoef
+                  IF( zflxv1(ji  ,jj  ) > 0._wp )   zwdlmtv(ji  ,jj  ) = zcoef
+                  IF( zflxv1(ji  ,jj-1) < 0._wp )   zwdlmtv(ji  ,jj-1) = zcoef
+               ENDIF
+            END DO
+         END DO
+         CALL lbc_lnk_multi( zwdlmtu, 'U', 1., zwdlmtv, 'V', 1. )
+         !
+         IF( lk_mpp )   CALL mpp_max(jflag)   !max over the global domain
+         !
+         IF( jflag == 0 )   EXIT
+         !
+      END DO  ! jk1 loop
+      !
+      DO jk = 1, jpkm1
+         un(:,:,jk) = un(:,:,jk) * zwdlmtu(:,:) 
+         vn(:,:,jk) = vn(:,:,jk) * zwdlmtv(:,:) 
+      END DO
+      un_b(:,:) = un_b(:,:) * zwdlmtu(:, :)
+      vn_b(:,:) = vn_b(:,:) * zwdlmtv(:, :)
+      !
+!!gm TO BE SUPPRESSED ?  these lbc_lnk are useless since zwdlmtu and zwdlmtv are defined everywhere !
+      CALL lbc_lnk_multi( un  , 'U', -1., vn  , 'V', -1. )
+      CALL lbc_lnk_multi( un_b, 'U', -1., vn_b, 'V', -1. )
+!!gm
+      !
+      IF(jflag == 1 .AND. lwp)   WRITE(numout,*) 'Need more iterations in wad_lmt!!!'
+      !
+      !IF( ln_rnf      )   CALL sbc_rnf_div( hdivn )          ! runoffs (update hdivn field)
+      !
+      IF( ln_timing )   CALL timing_stop('wad_lmt')      !
+      !
+   END SUBROUTINE wad_lmt
+
+
+   SUBROUTINE wad_lmt_bt( zflxu, zflxv, sshn_e, zssh_frc, rdtbt )
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE wad_lmt  ***
+      !!                    
+      !! ** Purpose :   limiting flux in the barotropic stepping (dynspg_ts)
+      !!
+      !! ** Method  : - Prevent negative depth occurring (Not ready for Agrif) 
+      !!
+      !! ** Action  : - calculate flux limiter and W/D flag
+      !!----------------------------------------------------------------------
+      REAL(wp)                , INTENT(in   ) ::   rdtbt    ! ocean time-step index
+      REAL(wp), DIMENSION(:,:), INTENT(inout) ::   zflxu,  zflxv, sshn_e, zssh_frc  
+      !
+      INTEGER  ::   ji, jj, jk, jk1     ! dummy loop indices
+      INTEGER  ::   jflag               ! local integer
+      REAL(wp) ::   z2dt
+      REAL(wp) ::   zcoef, zdep1, zdep2 ! local scalars
+      REAL(wp) ::   zzflxp, zzflxn      ! local scalars
+      REAL(wp) ::   zdepwd              ! local scalar, always wet cell depth
+      REAL(wp) ::   ztmp                ! local scalars
+      REAL(wp), DIMENSION(jpi,jpj) ::   zwdlmtu, zwdlmtv         !: W/D flux limiters
+      REAL(wp), DIMENSION(jpi,jpj) ::   zflxp,  zflxn            ! local 2D workspace
+      REAL(wp), DIMENSION(jpi,jpj) ::   zflxu1, zflxv1           ! local 2D workspace
+      !!----------------------------------------------------------------------
+      IF( ln_timing )   CALL timing_start('wad_lmt_bt')      !
+      !
+      jflag  = 0
+      zdepwd = 50._wp   ! maximum depth that ocean cells can have W/D processes
+      !
+      z2dt = rdtbt   
+      !
+      zflxp(:,:)   = 0._wp
+      zflxn(:,:)   = 0._wp
+      zwdlmtu(:,:) = 1._wp
+      zwdlmtv(:,:) = 1._wp
+      !
+      DO jj = 2, jpj      ! Horizontal Flux in u and v direction
+         DO ji = 2, jpi 
+            !
+            IF( tmask(ji, jj, 1 ) < 0.5_wp) CYCLE   ! we don't care about land cells
+            IF( ht_0(ji,jj) > zdepwd )      CYCLE   ! and cells which are unlikely to dry
+            !
+            zflxp(ji,jj) = MAX( zflxu(ji,jj) , 0._wp ) - MIN( zflxu(ji-1,jj  ) , 0._wp )   &
+               &         + MAX( zflxv(ji,jj) , 0._wp ) - MIN( zflxv(ji,  jj-1) , 0._wp ) 
+            zflxn(ji,jj) = MIN( zflxu(ji,jj) , 0._wp ) - MAX( zflxu(ji-1,jj  ) , 0._wp )   &
+               &         + MIN( zflxv(ji,jj) , 0._wp ) - MAX( zflxv(ji,  jj-1) , 0._wp ) 
+            !
+            zdep2 = ht_0(ji,jj) + sshn_e(ji,jj) - rn_wdmin1
+            IF( zdep2 <= 0._wp ) THEN  !add more safety, but not necessary
+              sshn_e(ji,jj) = rn_wdmin1 - ht_0(ji,jj)
+              IF( zflxu(ji  ,jj  ) > 0._wp)   zwdlmtu(ji  ,jj  ) = 0._wp
+              IF( zflxu(ji-1,jj  ) < 0._wp)   zwdlmtu(ji-1,jj  ) = 0._wp
+              IF( zflxv(ji  ,jj  ) > 0._wp)   zwdlmtv(ji  ,jj  ) = 0._wp
+              IF( zflxv(ji  ,jj-1) < 0._wp)   zwdlmtv(ji  ,jj-1) = 0._wp 
+            ENDIF
+         END DO
+      END DO
+      !
+      DO jk1 = 1, nn_wdit + 1      !! start limiter iterations 
+         !
+         zflxu1(:,:) = zflxu(:,:) * zwdlmtu(:,:)
+         zflxv1(:,:) = zflxv(:,:) * zwdlmtv(:,:)
+         jflag = 0     ! flag indicating if any further iterations are needed
+         !
+         DO jj = 2, jpj
+            DO ji = 2, jpi 
+               !
+               IF( tmask(ji, jj, 1 ) < 0.5_wp )   CYCLE 
+               IF( ht_0(ji,jj)       > zdepwd )   CYCLE
+               !
+               ztmp = e1e2t(ji,jj)
+               !
+               zzflxp = max(zflxu1(ji,jj), 0._wp) - min(zflxu1(ji-1,jj),   0._wp)   &
+                  &   + max(zflxv1(ji,jj), 0._wp) - min(zflxv1(ji,  jj-1), 0._wp) 
+               zzflxn = min(zflxu1(ji,jj), 0._wp) - max(zflxu1(ji-1,jj),   0._wp)   &
+                  &   + min(zflxv1(ji,jj), 0._wp) - max(zflxv1(ji,  jj-1), 0._wp) 
+          
+               zdep1 = (zzflxp + zzflxn) * z2dt / ztmp
+               zdep2 = ht_0(ji,jj) + sshn_e(ji,jj) - rn_wdmin1 - z2dt * zssh_frc(ji,jj)
+          
+               IF(zdep1 > zdep2) THEN
+                 zcoef = ( ( zdep2 - rn_wdmin2 ) * ztmp - zzflxn * z2dt ) / ( zflxp(ji,jj) * z2dt )
+                 !zcoef = ( ( zdep2 - rn_wdmin2 ) * ztmp - zzflxn * z2dt ) / ( zzflxp * z2dt )
+                 ! flag if the limiter has been used but stop flagging if the only
+                 ! changes have zeroed the coefficient since further iterations will
+                 ! not change anything
+                 IF( zcoef > 0._wp ) THEN
+                    jflag = 1 
+                 ELSE
+                    zcoef = 0._wp
+                 ENDIF
+                 IF(jk1 > nn_wdit) zcoef = 0._wp
+                 IF(zflxu1(ji,  jj) > 0._wp) zwdlmtu(ji  ,jj) = zcoef
+                 IF(zflxu1(ji-1,jj) < 0._wp) zwdlmtu(ji-1,jj) = zcoef
+                 IF(zflxv1(ji,  jj) > 0._wp) zwdlmtv(ji  ,jj) = zcoef
+                 IF(zflxv1(ji,jj-1) < 0._wp) zwdlmtv(ji,jj-1) = zcoef
+               END IF
+            END DO ! ji loop
+         END DO  ! jj loop
+         !
+         CALL lbc_lnk_multi( zwdlmtu, 'U', 1., zwdlmtv, 'V', 1. )
+         !
+         IF(lk_mpp) CALL mpp_max(jflag)   !max over the global domain
+         !
+         IF(jflag == 0)   EXIT
+         !
+      END DO  ! jk1 loop
+      !
+      zflxu(:,:) = zflxu(:,:) * zwdlmtu(:, :) 
+      zflxv(:,:) = zflxv(:,:) * zwdlmtv(:, :) 
+      !
+!!gm THIS lbc_lnk is useless since it is already done at the end of the jk1-loop
+      CALL lbc_lnk_multi( zflxu, 'U', -1., zflxv, 'V', -1. )
+!!gm end
+      !
+      IF( jflag == 1 .AND. lwp )   WRITE(numout,*) 'Need more iterations in wad_lmt_bt!!!'
+      !
+      !IF( ln_rnf      )   CALL sbc_rnf_div( hdivn )          ! runoffs (update hdivn field)
+      !
+      IF( ln_timing )   CALL timing_stop('wad_lmt_bt')      !
+      !
+   END SUBROUTINE wad_lmt_bt
+
+   !!==============================================================================
+END MODULE wet_dry
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/FLO/flo4rk.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/FLO/flo4rk.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/FLO/flo4rk.F90	(revision 9570)
@@ -0,0 +1,454 @@
+MODULE flo4rk
+   !!======================================================================
+   !!                    ***  MODULE  flo4rk  ***
+   !! Ocean floats :   trajectory computation using a 4th order Runge-Kutta
+   !!======================================================================
+#if   defined key_floats
+   !!----------------------------------------------------------------------
+   !!   'key_floats'                                     float trajectories
+   !!----------------------------------------------------------------------
+   !!   flo_4rk        : Compute the geographical position of floats
+   !!   flo_interp     : interpolation
+   !!----------------------------------------------------------------------
+   USE flo_oce         ! ocean drifting floats
+   USE oce             ! ocean dynamics and tracers
+   USE dom_oce         ! ocean space and time domain
+   USE in_out_manager  ! I/O manager
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   flo_4rk    ! routine called by floats.F90
+
+   !                                   ! RK4 and Lagrange interpolation coefficients
+   REAL(wp), DIMENSION (4) ::   tcoef1 = (/  1.0  ,  0.5  ,  0.5  ,  0.0  /)   ! 
+   REAL(wp), DIMENSION (4) ::   tcoef2 = (/  0.0  ,  0.5  ,  0.5  ,  1.0  /)   !
+   REAL(wp), DIMENSION (4) ::   scoef2 = (/  1.0  ,  2.0  ,  2.0  ,  1.0  /)   !
+   REAL(wp), DIMENSION (4) ::   rcoef  = (/-1./6. , 1./2. ,-1./2. , 1./6. /)   !
+   REAL(wp), DIMENSION (3) ::   scoef1 = (/  0.5  ,  0.5  ,  1.0  /)           !
+
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO Consortium (2010)
+   !! $Id$ 
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE flo_4rk( kt )
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE flo_4rk  ***
+      !!
+      !!  ** Purpose :   Compute the geographical position (lat,lon,depth)
+      !!       of each float at each time step.
+      !! 
+      !!  ** Method  :   The position of a float is computed with a 4th order
+      !!       Runge-Kutta scheme and and Lagrange interpolation.
+      !!         We need to know the velocity field, the old positions of the
+      !!       floats and the grid defined on the domain.
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT(in) ::   kt   ! ocean time-step index
+      !!
+      INTEGER ::  jfl, jind           ! dummy loop indices
+      INTEGER ::  ierror              ! error value
+
+      REAL(wp), DIMENSION(jpnfl)   ::   zgifl , zgjfl , zgkfl    ! index RK  positions
+      REAL(wp), DIMENSION(jpnfl)   ::   zufl  , zvfl  , zwfl     ! interpolated velocity at the float position 
+      REAL(wp), DIMENSION(jpnfl,4) ::   zrkxfl, zrkyfl, zrkzfl   ! RK coefficients
+      !!---------------------------------------------------------------------
+      !
+      IF( ierror /= 0 ) THEN
+         WRITE(numout,*) 'flo_4rk: allocation of workspace arrays failed'
+      ENDIF
+
+    
+      IF( kt == nit000 ) THEN
+         IF(lwp) WRITE(numout,*)
+         IF(lwp) WRITE(numout,*) 'flo_4rk : compute Runge Kutta trajectories for floats '
+         IF(lwp) WRITE(numout,*) '~~~~~~~'
+      ENDIF
+
+      ! Verification of the floats positions. If one of them leave the domain
+      ! domain we replace the float near the border.
+      DO jfl = 1, jpnfl
+         ! i-direction
+         IF( tpifl(jfl) <= 1.5 ) THEN
+            IF(lwp)WRITE(numout,*)'!!!!!!!!!!!!! WARNING !!!!!!!!!!!!!!!!'
+            IF(lwp)WRITE(numout,*)'The float',jfl,'is out of the domain at the WEST border.'
+            tpifl(jfl) = tpifl(jfl) + 1.
+            IF(lwp)WRITE(numout,*)'New initialisation for this float at i=',tpifl(jfl)
+         ENDIF
+          
+         IF( tpifl(jfl) >= jpi-.5 ) THEN
+            IF(lwp)WRITE(numout,*)'!!!!!!!!!!!!! WARNING !!!!!!!!!!!!!!!!'
+            IF(lwp)WRITE(numout,*)'The float',jfl,'is out of the domain at the EAST border.'
+            tpifl(jfl) = tpifl(jfl) - 1.
+            IF(lwp)WRITE(numout,*)'New initialisation for this float at i=', tpifl(jfl)
+         ENDIF
+         ! j-direction
+         IF( tpjfl(jfl) <= 1.5 ) THEN
+            IF(lwp)WRITE(numout,*)'!!!!!!!!!!!!! WARNING !!!!!!!!!!!!!!!!'
+            IF(lwp)WRITE(numout,*)'The float',jfl,'is out of the domain at the SOUTH border.'
+            tpjfl(jfl) = tpjfl(jfl) + 1.
+            IF(lwp)WRITE(numout,*)'New initialisation for this float at j=', tpjfl(jfl)
+         ENDIF
+           
+         IF( tpjfl(jfl) >= jpj-.5 ) THEN
+            IF(lwp)WRITE(numout,*)'!!!!!!!!!!!!! WARNING !!!!!!!!!!!!!!!!'
+            IF(lwp)WRITE(numout,*)'The float',jfl,'is out of the domain at the NORTH border.'
+            tpjfl(jfl) = tpjfl(jfl) - 1.
+            IF(lwp)WRITE(numout,*)'New initialisation for this float at j=', tpjfl(jfl)
+         ENDIF
+         ! k-direction
+         IF( tpkfl(jfl) <= .5 ) THEN
+            IF(lwp)WRITE(numout,*)'!!!!!!!!!!!!! WARNING !!!!!!!!!!!!!!!!'
+            IF(lwp)WRITE(numout,*)'The float',jfl,'is out of the domain at the TOP border.'
+            tpkfl(jfl) = tpkfl(jfl) + 1.
+            IF(lwp)WRITE(numout,*)'New initialisation for this float at k=', tpkfl(jfl)
+         ENDIF
+         
+         IF( tpkfl(jfl) >= jpk-.5 )  THEN
+            IF(lwp)WRITE(numout,*)'!!!!!!!!!!!!! WARNING !!!!!!!!!!!!!!!!'
+            IF(lwp)WRITE(numout,*)'The float',jfl,'is out of the domain at the BOTTOM border.'
+            tpkfl(jfl) = tpkfl(jfl) - 1.
+            IF(lwp)WRITE(numout,*)'New initialisation for this float at k=', tpkfl(jfl)
+         ENDIF
+      END DO
+      
+      ! 4 steps of Runge-Kutta algorithme
+      ! initialisation of the positions 
+      
+      DO jfl = 1, jpnfl
+         zgifl(jfl) = tpifl(jfl)
+         zgjfl(jfl) = tpjfl(jfl)
+         zgkfl(jfl) = tpkfl(jfl)
+      END DO
+       
+      DO  jind = 1, 4         
+      
+         ! for each step we compute the compute the velocity with Lagrange interpolation
+         CALL flo_interp( zgifl, zgjfl, zgkfl, zufl, zvfl, zwfl, jind )
+         
+         ! computation of Runge-Kutta factor
+         DO jfl = 1, jpnfl
+            zrkxfl(jfl,jind) = rdt*zufl(jfl)
+            zrkyfl(jfl,jind) = rdt*zvfl(jfl)
+            zrkzfl(jfl,jind) = rdt*zwfl(jfl)
+         END DO
+         IF( jind /= 4 ) THEN
+            DO jfl = 1, jpnfl
+               zgifl(jfl) = (tpifl(jfl)) + scoef1(jind)*zrkxfl(jfl,jind)
+               zgjfl(jfl) = (tpjfl(jfl)) + scoef1(jind)*zrkyfl(jfl,jind)
+               zgkfl(jfl) = (tpkfl(jfl)) + scoef1(jind)*zrkzfl(jfl,jind)
+            END DO
+         ENDIF
+      END DO
+      DO jind = 1, 4
+         DO jfl = 1, jpnfl
+            tpifl(jfl) = tpifl(jfl) + scoef2(jind)*zrkxfl(jfl,jind)/6.
+            tpjfl(jfl) = tpjfl(jfl) + scoef2(jind)*zrkyfl(jfl,jind)/6.
+            tpkfl(jfl) = tpkfl(jfl) + scoef2(jind)*zrkzfl(jfl,jind)/6.
+         END DO
+      END DO
+      !
+      !
+   END SUBROUTINE flo_4rk
+
+
+   SUBROUTINE flo_interp( pxt , pyt , pzt ,      &
+      &                   pufl, pvfl, pwfl, ki )
+      !!----------------------------------------------------------------------
+      !!                ***  ROUTINE flointerp  ***
+      !!
+      !! ** Purpose :   Interpolation of the velocity on the float position
+      !! 
+      !! ** Method  :   Lagrange interpolation with the 64 neighboring
+      !!      points. This routine is call 4 time at each time step to
+      !!      compute velocity at the date and the position we need to
+      !!      integrated with RK method.
+      !!----------------------------------------------------------------------
+      REAL(wp) , DIMENSION(jpnfl), INTENT(in   ) ::   pxt , pyt , pzt    ! position of the float
+      REAL(wp) , DIMENSION(jpnfl), INTENT(  out) ::   pufl, pvfl, pwfl   ! velocity at this position
+      INTEGER                    , INTENT(in   ) ::   ki                 !
+      !!
+      INTEGER  ::   jfl, jind1, jind2, jind3   ! dummy loop indices
+      REAL(wp) ::   zsumu, zsumv, zsumw        ! local scalar
+      INTEGER  , DIMENSION(jpnfl)       ::   iilu, ijlu, iklu   ! nearest neighbour INDEX-u
+      INTEGER  , DIMENSION(jpnfl)       ::   iilv, ijlv, iklv   ! nearest neighbour INDEX-v
+      INTEGER  , DIMENSION(jpnfl)       ::   iilw, ijlw, iklw   ! nearest neighbour INDEX-w
+      INTEGER  , DIMENSION(jpnfl,4)     ::   iidu, ijdu, ikdu   ! 64 nearest neighbour INDEX-u
+      INTEGER  , DIMENSION(jpnfl,4)     ::   iidv, ijdv, ikdv   ! 64 nearest neighbour INDEX-v
+      INTEGER  , DIMENSION(jpnfl,4)     ::   iidw, ijdw, ikdw   ! 64 nearest neighbour INDEX-w
+      REAL(wp) , DIMENSION(jpnfl,4)     ::   zlagxu, zlagyu, zlagzu   ! Lagrange  coefficients
+      REAL(wp) , DIMENSION(jpnfl,4)     ::   zlagxv, zlagyv, zlagzv   !    -           -
+      REAL(wp) , DIMENSION(jpnfl,4)     ::   zlagxw, zlagyw, zlagzw   !    -           -
+      REAL(wp) , DIMENSION(jpnfl,4,4,4) ::   ztufl , ztvfl , ztwfl   ! velocity at choosen time step
+      !!---------------------------------------------------------------------
+ 
+      ! Interpolation of U velocity
+
+      ! nearest neightboring point for computation of u       
+      DO jfl = 1, jpnfl
+         iilu(jfl) = INT(pxt(jfl)-.5)
+         ijlu(jfl) = INT(pyt(jfl)-.5)
+         iklu(jfl) = INT(pzt(jfl))
+      END DO
+      
+      !  64 neightboring points for computation of u 
+      DO jind1 = 1, 4
+         DO jfl = 1, jpnfl
+            !  i-direction
+            IF( iilu(jfl) <= 2 ) THEN          ;   iidu(jfl,jind1) = jind1
+            ELSE
+               IF( iilu(jfl) >= jpi-1 ) THEN   ;   iidu(jfl,jind1) = jpi       + jind1 - 4
+               ELSE                            ;   iidu(jfl,jind1) = iilu(jfl) + jind1 - 2
+               ENDIF
+            ENDIF
+            !  j-direction
+            IF( ijlu(jfl) <= 2 ) THEN          ;   ijdu(jfl,jind1) = jind1
+            ELSE
+               IF( ijlu(jfl) >= jpj-1 ) THEN   ;   ijdu(jfl,jind1) = jpj       + jind1 - 4
+               ELSE                            ;   ijdu(jfl,jind1) = ijlu(jfl) + jind1 - 2
+               ENDIF
+            ENDIF
+            ! k-direction
+            IF( iklu(jfl) <= 2 ) THEN          ;   ikdu(jfl,jind1) = jind1
+            ELSE
+               IF( iklu(jfl) >= jpk-1 ) THEN   ;   ikdu(jfl,jind1) = jpk + jind1 - 4
+               ELSE                            ;   ikdu(jfl,jind1) = iklu(jfl) + jind1 - 2
+               ENDIF
+            ENDIF
+         END DO
+      END DO
+      
+      ! Lagrange coefficients
+      DO jfl = 1, jpnfl
+         DO jind1 = 1, 4
+            zlagxu(jfl,jind1) = 1.
+            zlagyu(jfl,jind1) = 1.
+            zlagzu(jfl,jind1) = 1.
+         END DO
+      END DO
+      DO jind1 = 1, 4
+         DO jind2 = 1, 4
+            DO jfl= 1, jpnfl
+               IF( jind1 /= jind2 ) THEN
+                  zlagxu(jfl,jind1) = zlagxu(jfl,jind1) * ( pxt(jfl)-(float(iidu(jfl,jind2))+.5) )
+                  zlagyu(jfl,jind1) = zlagyu(jfl,jind1) * ( pyt(jfl)-(float(ijdu(jfl,jind2))) )
+                  zlagzu(jfl,jind1) = zlagzu(jfl,jind1) * ( pzt(jfl)-(float(ikdu(jfl,jind2))) )
+               ENDIF
+            END DO
+         END DO
+      END DO
+      
+      ! velocity when we compute at middle time step
+      
+      DO jfl = 1, jpnfl
+         DO jind1 = 1, 4
+            DO jind2 = 1, 4
+               DO jind3 = 1, 4
+                  ztufl(jfl,jind1,jind2,jind3) =   &
+                     &   (  tcoef1(ki) * ub(iidu(jfl,jind1),ijdu(jfl,jind2),ikdu(jfl,jind3)) +   &
+                     &      tcoef2(ki) * un(iidu(jfl,jind1),ijdu(jfl,jind2),ikdu(jfl,jind3)) )   &
+                     &      / e1u(iidu(jfl,jind1),ijdu(jfl,jind2)) 
+               END DO
+            END DO
+         END DO
+         
+         zsumu = 0.
+         DO jind1 = 1, 4
+            DO jind2 = 1, 4
+               DO jind3 = 1, 4
+                  zsumu = zsumu + ztufl(jfl,jind1,jind2,jind3) * zlagxu(jfl,jind1) * zlagyu(jfl,jind2)   &
+                     &  * zlagzu(jfl,jind3) * rcoef(jind1)*rcoef(jind2)*rcoef(jind3) 
+               END DO
+            END DO
+         END DO
+         pufl(jfl) = zsumu
+      END DO
+      
+      ! Interpolation of V velocity 
+
+      ! nearest neightboring point for computation of v 
+      DO jfl = 1, jpnfl
+         iilv(jfl) = INT(pxt(jfl)-.5)
+         ijlv(jfl) = INT(pyt(jfl)-.5)
+         iklv(jfl) = INT(pzt(jfl))
+      END DO
+      
+      ! 64 neightboring points for computation of v 
+      DO jind1 = 1, 4
+         DO jfl = 1, jpnfl
+            ! i-direction
+            IF( iilv(jfl) <= 2 ) THEN          ;   iidv(jfl,jind1) = jind1
+            ELSE
+               IF( iilv(jfl) >= jpi-1 ) THEN   ;   iidv(jfl,jind1) = jpi       + jind1 - 4
+               ELSE                            ;   iidv(jfl,jind1) = iilv(jfl) + jind1 - 2
+               ENDIF
+            ENDIF
+            ! j-direction
+            IF( ijlv(jfl) <= 2 ) THEN          ;   ijdv(jfl,jind1) = jind1
+            ELSE
+               IF( ijlv(jfl) >= jpj-1 ) THEN   ;   ijdv(jfl,jind1) = jpj       + jind1 - 4
+               ELSE                            ;   ijdv(jfl,jind1) = ijlv(jfl) + jind1 - 2
+               ENDIF
+            ENDIF
+            ! k-direction
+            IF( iklv(jfl) <= 2 ) THEN          ;   ikdv(jfl,jind1) = jind1
+            ELSE
+               IF( iklv(jfl) >= jpk-1 ) THEN   ;   ikdv(jfl,jind1) = jpk + jind1 - 4
+               ELSE                            ;   ikdv(jfl,jind1) = iklv(jfl) + jind1 - 2
+               ENDIF
+            ENDIF
+         END DO
+      END DO
+      
+      ! Lagrange coefficients
+      
+      DO jfl = 1, jpnfl
+         DO jind1 = 1, 4
+            zlagxv(jfl,jind1) = 1.
+            zlagyv(jfl,jind1) = 1.
+            zlagzv(jfl,jind1) = 1.
+         END DO
+      END DO
+      
+      DO jind1 = 1, 4
+         DO jind2 = 1, 4
+            DO jfl = 1, jpnfl
+               IF( jind1 /= jind2 ) THEN
+                  zlagxv(jfl,jind1)= zlagxv(jfl,jind1)*(pxt(jfl) - (float(iidv(jfl,jind2))   ) )
+                  zlagyv(jfl,jind1)= zlagyv(jfl,jind1)*(pyt(jfl) - (float(ijdv(jfl,jind2))+.5) )
+                  zlagzv(jfl,jind1)= zlagzv(jfl,jind1)*(pzt(jfl) - (float(ikdv(jfl,jind2))   ) )
+               ENDIF
+            END DO
+         END DO
+      END DO
+      
+      ! velocity when we compute at middle time step
+      
+      DO jfl = 1, jpnfl
+         DO jind1 = 1, 4
+            DO jind2 = 1, 4
+               DO jind3 = 1 ,4
+                  ztvfl(jfl,jind1,jind2,jind3)=   &
+                     &   ( tcoef1(ki) * vb(iidv(jfl,jind1),ijdv(jfl,jind2),ikdv(jfl,jind3))  +   &
+                     &     tcoef2(ki) * vn(iidv(jfl,jind1),ijdv(jfl,jind2),ikdv(jfl,jind3)) )    & 
+                     &     / e2v(iidv(jfl,jind1),ijdv(jfl,jind2))
+               END DO
+            END DO
+         END DO
+         
+         zsumv=0.
+         DO jind1 = 1, 4
+            DO jind2 = 1, 4
+               DO jind3 = 1, 4
+                  zsumv = zsumv + ztvfl(jfl,jind1,jind2,jind3) * zlagxv(jfl,jind1) * zlagyv(jfl,jind2)   &
+                     &  * zlagzv(jfl,jind3) * rcoef(jind1)*rcoef(jind2)*rcoef(jind3)
+               END DO
+            END DO
+         END DO
+         pvfl(jfl) = zsumv
+      END DO
+      
+      ! Interpolation of W velocity
+
+      ! nearest neightboring point for computation of w 
+      DO jfl = 1, jpnfl
+         iilw(jfl) = INT( pxt(jfl)   )
+         ijlw(jfl) = INT( pyt(jfl)   )
+         iklw(jfl) = INT( pzt(jfl)+.5)
+      END DO
+      
+      ! 64 neightboring points for computation of w 
+      DO jind1 = 1, 4
+         DO jfl = 1, jpnfl
+            ! i-direction
+            IF( iilw(jfl) <= 2 ) THEN          ;   iidw(jfl,jind1) = jind1
+            ELSE
+               IF( iilw(jfl) >= jpi-1 ) THEN   ;   iidw(jfl,jind1) = jpi       + jind1 - 4
+               ELSE                            ;   iidw(jfl,jind1) = iilw(jfl) + jind1 - 2
+               ENDIF
+            ENDIF
+            ! j-direction
+            IF( ijlw(jfl) <= 2 ) THEN          ;   ijdw(jfl,jind1) = jind1
+            ELSE
+               IF( ijlw(jfl) >= jpj-1 ) THEN   ;   ijdw(jfl,jind1) = jpj       + jind1 - 4
+               ELSE                            ;   ijdw(jfl,jind1) = ijlw(jfl) + jind1 - 2
+               ENDIF
+            ENDIF
+            ! k-direction
+            IF( iklw(jfl) <= 2 ) THEN          ;   ikdw(jfl,jind1) = jind1
+            ELSE
+               IF( iklw(jfl) >= jpk-1 ) THEN   ;   ikdw(jfl,jind1) = jpk       + jind1 - 4
+               ELSE                            ;   ikdw(jfl,jind1) = iklw(jfl) + jind1 - 2
+               ENDIF
+            ENDIF
+         END DO
+      END DO
+      DO jind1 = 1, 4
+         DO jfl = 1, jpnfl
+            IF( iklw(jfl) <= 2 ) THEN          ;   ikdw(jfl,jind1) = jind1
+            ELSE
+               IF( iklw(jfl) >= jpk-1 ) THEN   ;   ikdw(jfl,jind1) = jpk       + jind1 - 4
+               ELSE                            ;   ikdw(jfl,jind1) = iklw(jfl) + jind1 - 2
+               ENDIF
+            ENDIF
+         END DO
+      END DO
+      
+      ! Lagrange coefficients  for w interpolation
+      DO jfl = 1, jpnfl
+         DO jind1 = 1, 4
+            zlagxw(jfl,jind1) = 1.
+            zlagyw(jfl,jind1) = 1.
+            zlagzw(jfl,jind1) = 1.
+         END DO
+      END DO
+      DO jind1 = 1, 4
+         DO jind2 = 1, 4
+            DO jfl = 1, jpnfl
+               IF( jind1 /= jind2 ) THEN
+                  zlagxw(jfl,jind1) = zlagxw(jfl,jind1) * (pxt(jfl) - (float(iidw(jfl,jind2))   ) )
+                  zlagyw(jfl,jind1) = zlagyw(jfl,jind1) * (pyt(jfl) - (float(ijdw(jfl,jind2))   ) )
+                  zlagzw(jfl,jind1) = zlagzw(jfl,jind1) * (pzt(jfl) - (float(ikdw(jfl,jind2))-.5) )
+               ENDIF
+            END DO
+         END DO
+      END DO
+      
+      ! velocity w  when we compute at middle time step
+      DO jfl = 1, jpnfl
+         DO jind1 = 1, 4
+            DO jind2 = 1, 4
+               DO jind3 = 1, 4
+                  ztwfl(jfl,jind1,jind2,jind3)=   &
+                     &   ( tcoef1(ki) * wb(iidw(jfl,jind1),ijdw(jfl,jind2),ikdw(jfl,jind3))+   &
+                     &     tcoef2(ki) * wn(iidw(jfl,jind1),ijdw(jfl,jind2),ikdw(jfl,jind3)) )  &
+                     &   / e3w_n(iidw(jfl,jind1),ijdw(jfl,jind2),ikdw(jfl,jind3))
+               END DO
+            END DO
+         END DO
+         
+         zsumw = 0.e0
+         DO jind1 = 1, 4
+            DO jind2 = 1, 4
+               DO jind3 = 1, 4
+                  zsumw = zsumw + ztwfl(jfl,jind1,jind2,jind3) * zlagxw(jfl,jind1) * zlagyw(jfl,jind2)   &
+                     &  * zlagzw(jfl,jind3) * rcoef(jind1)*rcoef(jind2)*rcoef(jind3)
+               END DO
+            END DO
+         END DO
+         pwfl(jfl) = zsumw
+      END DO
+      !   
+      !   
+   END SUBROUTINE flo_interp
+
+#  else
+   !!----------------------------------------------------------------------
+   !!   No floats                                              Dummy module
+   !!----------------------------------------------------------------------
+#endif
+   
+   !!======================================================================
+END MODULE flo4rk
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/FLO/flo_oce.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/FLO/flo_oce.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/FLO/flo_oce.F90	(revision 9570)
@@ -0,0 +1,78 @@
+MODULE flo_oce
+   !!======================================================================
+   !!                     ***  MODULE flo_oce  ***
+   !! lagrangian floats :   define in memory all floats parameters and variables
+   !!======================================================================
+   !! History :   OPA  ! 1999-10  (CLIPPER projet)
+   !!   NEMO      1.0  ! 2002-11  (G. Madec, A. Bozec)  F90: Free form and module
+   !!----------------------------------------------------------------------
+#if   defined   key_floats
+   !!----------------------------------------------------------------------
+   !!   'key_floats'                                        drifting floats
+   !!----------------------------------------------------------------------
+   USE par_oce         ! ocean parameters
+   USE in_out_manager  ! I/O manager
+   USE lib_mpp         ! MPP library
+
+   IMPLICIT NONE
+   PUBLIC
+
+   PUBLIC   flo_oce_alloc   ! Routine called in floats.F90
+
+   LOGICAL, PUBLIC, PARAMETER ::   lk_floats = .TRUE.    !: float flag
+
+   !! float parameters
+   !! ----------------
+   INTEGER, PUBLIC ::   jpnfl       !: total number of floats during the run
+   INTEGER, PUBLIC ::   jpnnewflo   !: number of floats added in a new run
+   INTEGER, PUBLIC ::   jpnrstflo   !: number of floats for the restart
+
+   !! float variables
+   !! ---------------
+   INTEGER , PUBLIC, ALLOCATABLE, DIMENSION(:) ::   nisobfl   !: =0 for a isobar float , =1 for a float following the w velocity
+   INTEGER , PUBLIC, ALLOCATABLE, DIMENSION(:) ::   ngrpfl    !: number to identify searcher group
+   INTEGER , PUBLIC, ALLOCATABLE, DIMENSION(:) ::   nfloat    !: number to identify searcher group
+
+   REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:) ::   flxx , flyy , flzz    !: long, lat, depth of float (decimal degree, m >0)
+   REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:) ::   tpifl, tpjfl, tpkfl   !: (i,j,k) indices of float position
+
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   wb   !: vertical velocity at previous time step (m s-1).
+   
+   !                                   !! * namelist namflo : langrangian floats *
+   LOGICAL, PUBLIC  ::   ln_rstflo      !: T/F float restart 
+   LOGICAL, PUBLIC  ::   ln_argo        !: T/F argo type floats
+   LOGICAL, PUBLIC  ::   ln_flork4      !: T/F 4th order Runge-Kutta
+   LOGICAL, PUBLIC  ::   ln_ariane      !: handle ariane input/output convention
+   LOGICAL, PUBLIC  ::   ln_flo_ascii   !: write in ascii (T) or in Netcdf (F)
+
+   INTEGER, PUBLIC  ::   nn_writefl     !: frequency of float output file 
+   INTEGER, PUBLIC  ::   nn_stockfl     !: frequency of float restart file
+
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 4.0 , NEMO Consortium (2011)
+   !! $Id$ 
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   INTEGER FUNCTION flo_oce_alloc()
+      !!----------------------------------------------------------------------
+      !!                 ***  FUNCTION flo_oce_alloc  ***
+      !!----------------------------------------------------------------------
+      ALLOCATE( wb(jpi,jpj,jpk) , nfloat(jpnfl) , nisobfl(jpnfl) , ngrpfl(jpnfl) , &
+         &      flxx(jpnfl)     , flyy(jpnfl)   , flzz(jpnfl)    ,                 & 
+         &      tpifl(jpnfl)    , tpjfl(jpnfl)  , tpkfl(jpnfl)   , STAT=flo_oce_alloc )
+      !
+      IF( lk_mpp             )   CALL mpp_sum ( flo_oce_alloc )
+      IF( flo_oce_alloc /= 0 )   CALL ctl_warn('flo_oce_alloc: failed to allocate arrays')
+   END FUNCTION flo_oce_alloc
+
+#else
+   !!----------------------------------------------------------------------
+   !!   Default option :                                 NO drifting floats
+   !!----------------------------------------------------------------------
+   LOGICAL, PUBLIC, PARAMETER ::   lk_floats = .FALSE.   !: float flag
+#endif
+
+   !!======================================================================
+END MODULE flo_oce
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/FLO/floats.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/FLO/floats.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/FLO/floats.F90	(revision 9570)
@@ -0,0 +1,151 @@
+MODULE floats
+   !!======================================================================
+   !!                       ***  MODULE  floats  ***
+   !! Ocean floats : floats
+   !!======================================================================
+   !! History :  OPA  !          (CLIPPER)   original Code
+   !!   NEMO     1.0  ! 2002-06  (A. Bozec)  F90, Free form and module
+   !!----------------------------------------------------------------------
+#if   defined   key_floats
+   !!----------------------------------------------------------------------
+   !!   'key_floats'                                     float trajectories
+   !!----------------------------------------------------------------------
+   !!   flo_stp   : float trajectories computation
+   !!   flo_init  : initialization of float trajectories computation
+   !!----------------------------------------------------------------------
+   USE oce             ! ocean variables
+   USE flo_oce         ! floats variables
+   USE lib_mpp         ! distributed memory computing
+   USE flodom          ! initialisation Module 
+   USE flowri          ! float output                     (flo_wri routine)
+   USE florst          ! float restart                    (flo_rst routine)
+   USE flo4rk          ! Trajectories, Runge Kutta scheme (flo_4rk routine)
+   USE floblk          ! Trajectories, Blanke scheme      (flo_blk routine)
+   !
+   USE in_out_manager  ! I/O manager
+   USE timing          ! preformance summary
+
+   IMPLICIT NONE
+   PRIVATE  
+
+   PUBLIC   flo_stp    ! routine called by step.F90
+   PUBLIC   flo_init   ! routine called by opa.F90
+
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO Consortium (2010)
+   !! $Id$ 
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE flo_stp( kt )
+      !!----------------------------------------------------------------------
+      !!                   ***  ROUTINE flo_stp  ***
+      !!                    
+      !! ** Purpose :   Compute the geographical position (lat., long., depth)
+      !!      of each float at each time step with one of the algorithm.
+      !! 
+      !! ** Method  :   The position of a float is computed with Bruno Blanke 
+      !!        algorithm by default and with a 4th order Runge-Kutta scheme
+      !!        if ln_flork4 =T
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT( in  ) ::   kt   ! ocean time step
+      !!----------------------------------------------------------------------
+      !
+      IF( ln_timing )   CALL timing_start('flo_stp')
+      !
+      IF( ln_flork4 ) THEN   ;   CALL flo_4rk( kt )        ! Trajectories using a 4th order Runge Kutta scheme
+      ELSE                   ;   CALL flo_blk( kt )        ! Trajectories using Blanke' algorithme
+      ENDIF
+      !
+      IF( lk_mpp )   CALL mppsync   ! synchronization of all the processor
+      !
+      CALL flo_wri( kt )      ! trajectories ouput 
+      !
+      CALL flo_rst( kt )      ! trajectories restart
+      !
+      wb(:,:,:) = wn(:,:,:)         ! Save the old vertical velocity field
+      !
+      IF( ln_timing )   CALL timing_stop('flo_stp')
+      !
+   END SUBROUTINE flo_stp
+
+
+   SUBROUTINE flo_init
+      !!----------------------------------------------------------------
+      !!                 ***  ROUTINE flo_init  ***
+      !!                   
+      !! ** Purpose :   Read the namelist of floats
+      !!----------------------------------------------------------------------
+      INTEGER ::   jfl
+      INTEGER ::   ios                 ! Local integer output status for namelist read
+      !
+      NAMELIST/namflo/ jpnfl, jpnnewflo, ln_rstflo, nn_writefl, nn_stockfl, ln_argo, ln_flork4, ln_ariane, ln_flo_ascii
+      !!---------------------------------------------------------------------
+      !
+      IF(lwp) WRITE(numout,*)
+      IF(lwp) WRITE(numout,*) 'flo_stp : call floats routine '
+      IF(lwp) WRITE(numout,*) '~~~~~~~'
+
+      REWIND( numnam_ref )              ! Namelist namflo in reference namelist : Floats
+      READ  ( numnam_ref, namflo, IOSTAT = ios, ERR = 901)
+901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namflo in reference namelist', lwp )
+
+      REWIND( numnam_cfg )              ! Namelist namflo in configuration namelist : Floats
+      READ  ( numnam_cfg, namflo, IOSTAT = ios, ERR = 902 )
+902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namflo in configuration namelist', lwp )
+      IF(lwm) WRITE ( numond, namflo )
+      !
+      IF(lwp) THEN                  ! control print
+         WRITE(numout,*)
+         WRITE(numout,*) '         Namelist floats :'
+         WRITE(numout,*) '            number of floats                      jpnfl        = ', jpnfl
+         WRITE(numout,*) '            number of new floats                  jpnflnewflo  = ', jpnnewflo
+         WRITE(numout,*) '            restart                               ln_rstflo    = ', ln_rstflo
+         WRITE(numout,*) '            frequency of float output file        nn_writefl   = ', nn_writefl
+         WRITE(numout,*) '            frequency of float restart file       nn_stockfl   = ', nn_stockfl
+         WRITE(numout,*) '            Argo type floats                      ln_argo      = ', ln_argo
+         WRITE(numout,*) '            Computation of T trajectories         ln_flork4    = ', ln_flork4
+         WRITE(numout,*) '            Use of ariane convention              ln_ariane    = ', ln_ariane
+         WRITE(numout,*) '            ascii output (T) or netcdf output (F) ln_flo_ascii = ', ln_flo_ascii
+
+      ENDIF
+      !
+      !                             ! allocate floats arrays
+      IF( flo_oce_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'flo_init : unable to allocate arrays' )
+      !
+      !                             ! allocate flodom arrays
+      IF( flo_dom_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'flo_dom : unable to allocate arrays' )
+      !
+      !                             ! allocate flowri arrays
+      IF( flo_wri_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'flo_wri : unable to allocate arrays' )
+      !
+      !                             ! allocate florst arrays
+      IF( flo_rst_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'flo_rst : unable to allocate arrays' )
+      !
+      jpnrstflo = jpnfl-jpnnewflo   ! memory allocation 
+      !
+      DO jfl = 1, jpnfl             ! vertical axe for netcdf IOM ouput
+         nfloat(jfl) = jfl 
+      END DO
+      !
+      CALL flo_dom                  ! compute/read initial position of floats
+      !
+      wb(:,:,:) = wn(:,:,:)         ! set wb for computation of floats trajectories at the first time step
+      !
+   END SUBROUTINE flo_init
+
+#  else
+   !!----------------------------------------------------------------------
+   !!   Default option :                                       Empty module
+   !!----------------------------------------------------------------------
+CONTAINS
+   SUBROUTINE flo_stp( kt )          ! Empty routine
+      WRITE(*,*) 'flo_stp: You should not have seen this print! error?', kt
+   END SUBROUTINE flo_stp
+   SUBROUTINE flo_init          ! Empty routine
+   END SUBROUTINE flo_init
+#endif
+
+   !!======================================================================
+ END MODULE floats
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/FLO/floblk.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/FLO/floblk.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/FLO/floblk.F90	(revision 9570)
@@ -0,0 +1,381 @@
+MODULE floblk
+   !!======================================================================
+   !!                     ***  MODULE  floblk  ***
+   !! Ocean floats :   trajectory computation
+   !!======================================================================
+#if   defined key_floats
+   !!----------------------------------------------------------------------
+   !!   'key_floats'                                     float trajectories
+   !!----------------------------------------------------------------------
+   !!    flotblk     : compute float trajectories with Blanke algorithme
+   !!----------------------------------------------------------------------
+   USE flo_oce         ! ocean drifting floats
+   USE oce             ! ocean dynamics and tracers
+   USE dom_oce         ! ocean space and time domain
+   USE phycst          ! physical constants
+   USE in_out_manager  ! I/O manager
+   USE lib_mpp         ! distribued memory computing library
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   flo_blk    ! routine called by floats.F90
+
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO Consortium (2010)
+   !! $Id$ 
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE flo_blk( kt )
+      !!---------------------------------------------------------------------
+      !!                  ***  ROUTINE flo_blk  ***
+      !!           
+      !! ** Purpose :   Compute the geographical position,latitude, longitude
+      !!      and depth of each float at each time step.
+      !! 
+      !! ** Method  :   The position of a float is computed with Bruno Blanke
+      !!      algorithm. We need to know the velocity field, the old positions
+      !!      of the floats and the grid defined on the domain.
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT( in  ) ::   kt ! ocean time step
+      !!
+      INTEGER :: jfl              ! dummy loop arguments
+      INTEGER :: ind, ifin, iloop
+      REAL(wp)   ::       &
+         zuinfl,zvinfl,zwinfl,      &     ! transport across the input face
+         zuoutfl,zvoutfl,zwoutfl,   &     ! transport across the ouput face
+         zvol,                      &     ! volume of the mesh
+         zsurfz,                    &     ! surface of the face of the mesh 
+         zind
+
+      REAL(wp), DIMENSION ( 2 )  ::   zsurfx, zsurfy   ! surface of the face of the mesh
+
+      INTEGER  , DIMENSION ( jpnfl )  ::   iil, ijl, ikl                   ! index of nearest mesh
+      INTEGER  , DIMENSION ( jpnfl )  ::   iiloc , ijloc              
+      INTEGER  , DIMENSION ( jpnfl )  ::   iiinfl, ijinfl, ikinfl          ! index of input mesh of the float.
+      INTEGER  , DIMENSION ( jpnfl )  ::   iioutfl, ijoutfl, ikoutfl       ! index of output mesh of the float.
+      REAL(wp) , DIMENSION ( jpnfl )  ::   zgifl, zgjfl, zgkfl             ! position of floats, index on 
+      !                                                                         ! velocity mesh.
+      REAL(wp) , DIMENSION ( jpnfl )  ::    ztxfl, ztyfl, ztzfl            ! time for a float to quit the mesh
+      !                                                                         ! across one of the face x,y and z 
+      REAL(wp) , DIMENSION ( jpnfl )  ::    zttfl                          ! time for a float to quit the mesh 
+      REAL(wp) , DIMENSION ( jpnfl )  ::    zagefl                         ! time during which, trajectorie of 
+      !                                                                         ! the float has been computed
+      REAL(wp) , DIMENSION ( jpnfl )  ::   zagenewfl                       ! new age of float after calculation 
+      !                                                                         ! of new position
+      REAL(wp) , DIMENSION ( jpnfl )  ::   zufl, zvfl, zwfl                ! interpolated vel. at float position
+      REAL(wp) , DIMENSION ( jpnfl )  ::   zudfl, zvdfl, zwdfl             ! velocity diff input/output of mesh
+      REAL(wp) , DIMENSION ( jpnfl )  ::   zgidfl, zgjdfl, zgkdfl          ! direction index of float
+      !!---------------------------------------------------------------------
+
+      IF( kt == nit000 ) THEN
+         IF(lwp) WRITE(numout,*)
+         IF(lwp) WRITE(numout,*) 'flo_blk : compute Blanke trajectories for floats '
+         IF(lwp) WRITE(numout,*) '~~~~~~~ '
+      ENDIF
+
+      ! Initialisation of parameters
+      
+      DO jfl = 1, jpnfl
+         ! ages of floats are put at zero
+         zagefl(jfl) = 0.
+         ! index on the velocity grid 
+         ! We considere k coordinate negative, with this transformation 
+         ! the computation in the 3 direction is the same. 
+         zgifl(jfl) = tpifl(jfl) - 0.5
+         zgjfl(jfl) = tpjfl(jfl) - 0.5
+         zgkfl(jfl) = MIN(-1.,-(tpkfl(jfl)))
+         ! surface drift every 10 days 
+         IF( ln_argo ) THEN
+            IF( MOD(kt,150) >= 146 .OR. MOD(kt,150) == 0 )  zgkfl(jfl) = -1.
+         ENDIF
+         ! index of T mesh
+         iil(jfl) = 1 + INT(zgifl(jfl))
+         ijl(jfl) = 1 + INT(zgjfl(jfl))
+         ikl(jfl) =     INT(zgkfl(jfl))
+      END DO
+       
+      iloop = 0
+222   DO jfl = 1, jpnfl
+# if   defined key_mpp_mpi
+         IF( iil(jfl) >= mig(nldi) .AND. iil(jfl) <= mig(nlei) .AND.   &
+             ijl(jfl) >= mjg(nldj) .AND. ijl(jfl) <= mjg(nlej)   ) THEN
+            iiloc(jfl) = iil(jfl) - mig(1) + 1
+            ijloc(jfl) = ijl(jfl) - mjg(1) + 1
+# else 
+            iiloc(jfl) = iil(jfl)
+            ijloc(jfl) = ijl(jfl)
+# endif
+            
+            ! compute the transport across the mesh where the float is.            
+!!bug (gm) change e3t into e3. but never checked 
+            zsurfx(1) = e2u(iiloc(jfl)-1,ijloc(jfl)  ) * e3u_n(iiloc(jfl)-1,ijloc(jfl)  ,-ikl(jfl))
+            zsurfx(2) = e2u(iiloc(jfl)  ,ijloc(jfl)  ) * e3u_n(iiloc(jfl)  ,ijloc(jfl)  ,-ikl(jfl))
+            zsurfy(1) = e1v(iiloc(jfl)  ,ijloc(jfl)-1) * e3v_n(iiloc(jfl)  ,ijloc(jfl)-1,-ikl(jfl))
+            zsurfy(2) = e1v(iiloc(jfl)  ,ijloc(jfl)  ) * e3v_n(iiloc(jfl)  ,ijloc(jfl)  ,-ikl(jfl))
+
+            ! for a isobar float zsurfz is put to zero. The vertical velocity will be zero too.
+            zsurfz =          e1e2t(iiloc(jfl),ijloc(jfl))
+            zvol   = zsurfz * e3t_n(iiloc(jfl),ijloc(jfl),-ikl(jfl))
+
+            !
+            zuinfl =( ub(iiloc(jfl)-1,ijloc(jfl),-ikl(jfl)) + un(iiloc(jfl)-1,ijloc(jfl),-ikl(jfl)) )/2.*zsurfx(1)
+            zuoutfl=( ub(iiloc(jfl)  ,ijloc(jfl),-ikl(jfl)) + un(iiloc(jfl)  ,ijloc(jfl),-ikl(jfl)) )/2.*zsurfx(2)
+            zvinfl =( vb(iiloc(jfl),ijloc(jfl)-1,-ikl(jfl)) + vn(iiloc(jfl),ijloc(jfl)-1,-ikl(jfl)) )/2.*zsurfy(1)
+            zvoutfl=( vb(iiloc(jfl),ijloc(jfl)  ,-ikl(jfl)) + vn(iiloc(jfl),ijloc(jfl)  ,-ikl(jfl)) )/2.*zsurfy(2)
+            zwinfl =-(wb(iiloc(jfl),ijloc(jfl),-(ikl(jfl)-1))    &
+               &   +  wn(iiloc(jfl),ijloc(jfl),-(ikl(jfl)-1)) )/2. *  zsurfz*nisobfl(jfl)
+            zwoutfl=-(wb(iiloc(jfl),ijloc(jfl),- ikl(jfl)   )   &
+               &   +  wn(iiloc(jfl),ijloc(jfl),- ikl(jfl)   ) )/2. *  zsurfz*nisobfl(jfl)
+            
+            ! interpolation of velocity field on the float initial position            
+            zufl(jfl)=  zuinfl  + ( zgifl(jfl) - float(iil(jfl)-1) ) * ( zuoutfl - zuinfl)
+            zvfl(jfl)=  zvinfl  + ( zgjfl(jfl) - float(ijl(jfl)-1) ) * ( zvoutfl - zvinfl)
+            zwfl(jfl)=  zwinfl  + ( zgkfl(jfl) - float(ikl(jfl)-1) ) * ( zwoutfl - zwinfl)
+            
+            ! faces of input and output
+            ! u-direction
+            IF( zufl(jfl) < 0. ) THEN
+               iioutfl(jfl) = iil(jfl) - 1.
+               iiinfl (jfl) = iil(jfl)
+               zind   = zuinfl
+               zuinfl = zuoutfl
+               zuoutfl= zind
+            ELSE
+               iioutfl(jfl) = iil(jfl)
+               iiinfl (jfl) = iil(jfl) - 1
+            ENDIF
+            ! v-direction       
+            IF( zvfl(jfl) < 0. ) THEN
+               ijoutfl(jfl) = ijl(jfl) - 1.
+               ijinfl (jfl) = ijl(jfl)
+               zind    = zvinfl
+               zvinfl  = zvoutfl
+               zvoutfl = zind
+            ELSE
+               ijoutfl(jfl) = ijl(jfl)
+               ijinfl (jfl) = ijl(jfl) - 1.
+            ENDIF
+            ! w-direction
+            IF( zwfl(jfl) < 0. ) THEN
+               ikoutfl(jfl) = ikl(jfl) - 1.
+               ikinfl (jfl) = ikl(jfl)
+               zind    = zwinfl
+               zwinfl  = zwoutfl
+               zwoutfl = zind
+            ELSE
+               ikoutfl(jfl) = ikl(jfl)
+               ikinfl (jfl) = ikl(jfl) - 1.
+            ENDIF
+            
+            ! compute the time to go out the mesh across a face
+            ! u-direction
+            zudfl (jfl) = zuoutfl - zuinfl
+            zgidfl(jfl) = float(iioutfl(jfl) - iiinfl(jfl))
+            IF( zufl(jfl)*zuoutfl <= 0. ) THEN
+               ztxfl(jfl) = 1.E99
+            ELSE
+               IF( ABS(zudfl(jfl)) >= 1.E-5 ) THEN
+                  ztxfl(jfl)= zgidfl(jfl)/zudfl(jfl) * LOG(zuoutfl/zufl (jfl))
+               ELSE
+                  ztxfl(jfl)=(float(iioutfl(jfl))-zgifl(jfl))/zufl(jfl)
+               ENDIF
+               IF( (ABS(zgifl(jfl)-float(iiinfl (jfl))) <=  1.E-7) .OR.   &
+                   (ABS(zgifl(jfl)-float(iioutfl(jfl))) <=  1.E-7) ) THEN
+                  ztxfl(jfl)=(zgidfl(jfl))/zufl(jfl)
+               ENDIF
+            ENDIF
+            ! v-direction
+            zvdfl (jfl) = zvoutfl - zvinfl
+            zgjdfl(jfl) = float(ijoutfl(jfl)-ijinfl(jfl))
+            IF( zvfl(jfl)*zvoutfl <= 0. ) THEN
+               ztyfl(jfl) = 1.E99
+            ELSE
+               IF( ABS(zvdfl(jfl)) >= 1.E-5 ) THEN
+                  ztyfl(jfl) = zgjdfl(jfl)/zvdfl(jfl) * LOG(zvoutfl/zvfl (jfl))
+               ELSE
+                  ztyfl(jfl) = (float(ijoutfl(jfl)) - zgjfl(jfl))/zvfl(jfl)
+               ENDIF
+               IF( (ABS(zgjfl(jfl)-float(ijinfl (jfl))) <= 1.E-7) .OR.   &
+                   (ABS(zgjfl(jfl)-float(ijoutfl(jfl))) <=  1.E-7) ) THEN
+                  ztyfl(jfl) = (zgjdfl(jfl)) / zvfl(jfl)
+               ENDIF
+            ENDIF
+            ! w-direction        
+            IF( nisobfl(jfl) == 1. ) THEN 
+               zwdfl (jfl) = zwoutfl - zwinfl
+               zgkdfl(jfl) = float(ikoutfl(jfl) - ikinfl(jfl))
+               IF( zwfl(jfl)*zwoutfl <= 0. ) THEN
+                  ztzfl(jfl) = 1.E99
+               ELSE
+                  IF( ABS(zwdfl(jfl)) >= 1.E-5 ) THEN
+                     ztzfl(jfl) = zgkdfl(jfl)/zwdfl(jfl) * LOG(zwoutfl/zwfl (jfl))
+                  ELSE
+                     ztzfl(jfl) = (float(ikoutfl(jfl)) - zgkfl(jfl))/zwfl(jfl)
+                  ENDIF
+                  IF( (ABS(zgkfl(jfl)-float(ikinfl (jfl))) <=  1.E-7) .OR.   &
+                      (ABS(zgkfl(jfl)-float(ikoutfl(jfl))) <= 1.E-7) ) THEN
+                     ztzfl(jfl) = (zgkdfl(jfl)) / zwfl(jfl)
+                  ENDIF
+               ENDIF
+            ENDIF
+            
+            ! the time to go leave the mesh is the smallest time
+                   
+            IF( nisobfl(jfl) == 1. ) THEN 
+               zttfl(jfl) = MIN(ztxfl(jfl),ztyfl(jfl),ztzfl(jfl))
+            ELSE
+               zttfl(jfl) = MIN(ztxfl(jfl),ztyfl(jfl))
+            ENDIF
+            ! new age of the FLOAT
+            zagenewfl(jfl) = zagefl(jfl) + zttfl(jfl)*zvol
+            ! test to know if the "age" of the float is not bigger than the 
+            ! time step
+            IF( zagenewfl(jfl) > rdt ) THEN
+               zttfl(jfl) = (rdt-zagefl(jfl)) / zvol
+               zagenewfl(jfl) = rdt
+            ENDIF
+            
+            ! In the "minimal" direction we compute the index of new mesh
+            ! on i-direction
+            IF( ztxfl(jfl) <=  zttfl(jfl) ) THEN
+               zgifl(jfl) = float(iioutfl(jfl))
+               ind = iioutfl(jfl)
+               IF( iioutfl(jfl) >= iiinfl(jfl) ) THEN
+                  iioutfl(jfl) = iioutfl(jfl) + 1
+               ELSE
+                  iioutfl(jfl) = iioutfl(jfl) - 1
+               ENDIF
+               iiinfl(jfl) = ind
+            ELSE
+               IF( ABS(zudfl(jfl)) >= 1.E-5 ) THEN 
+                  zgifl(jfl) = zgifl(jfl) + zgidfl(jfl)*zufl(jfl)    &
+                     &       * ( EXP( zudfl(jfl)/zgidfl(jfl)*zttfl(jfl) ) - 1. ) /  zudfl(jfl)
+               ELSE
+                  zgifl(jfl) = zgifl(jfl) + zufl(jfl) * zttfl(jfl)
+               ENDIF
+            ENDIF
+            ! on j-direction
+            IF( ztyfl(jfl) <= zttfl(jfl) ) THEN
+               zgjfl(jfl) = float(ijoutfl(jfl))
+               ind = ijoutfl(jfl)
+               IF( ijoutfl(jfl) >= ijinfl(jfl) ) THEN
+                  ijoutfl(jfl) = ijoutfl(jfl) + 1
+               ELSE
+                  ijoutfl(jfl) = ijoutfl(jfl) - 1
+               ENDIF
+               ijinfl(jfl) = ind
+            ELSE
+               IF( ABS(zvdfl(jfl)) >= 1.E-5 ) THEN 
+                  zgjfl(jfl) = zgjfl(jfl)+zgjdfl(jfl)*zvfl(jfl)   &
+                     &       * ( EXP(zvdfl(jfl)/zgjdfl(jfl)*zttfl(jfl)) - 1. ) /  zvdfl(jfl)
+               ELSE
+                  zgjfl(jfl) = zgjfl(jfl)+zvfl(jfl)*zttfl(jfl)
+               ENDIF
+            ENDIF
+            ! on k-direction
+            IF( nisobfl(jfl) == 1. ) THEN
+               IF( ztzfl(jfl) <= zttfl(jfl) ) THEN
+                  zgkfl(jfl) = float(ikoutfl(jfl))
+                  ind = ikoutfl(jfl)
+                  IF( ikoutfl(jfl) >= ikinfl(jfl) ) THEN
+                     ikoutfl(jfl) = ikoutfl(jfl)+1
+                  ELSE
+                     ikoutfl(jfl) = ikoutfl(jfl)-1
+                  ENDIF
+                  ikinfl(jfl) = ind
+               ELSE
+                  IF( ABS(zwdfl(jfl)) >= 1.E-5 ) THEN 
+                     zgkfl(jfl) = zgkfl(jfl)+zgkdfl(jfl)*zwfl(jfl)    &
+                        &       * ( EXP(zwdfl(jfl)/zgkdfl(jfl)*zttfl(jfl)) - 1. ) /  zwdfl(jfl)
+                  ELSE
+                     zgkfl(jfl) = zgkfl(jfl)+zwfl(jfl)*zttfl(jfl)
+                  ENDIF
+               ENDIF
+            ENDIF
+            
+            ! coordinate of the new point on the temperature grid
+            
+            iil(jfl) = MAX(iiinfl(jfl),iioutfl(jfl))
+            ijl(jfl) = MAX(ijinfl(jfl),ijoutfl(jfl))
+            IF( nisobfl(jfl) ==  1 ) ikl(jfl) = MAX(ikinfl(jfl),ikoutfl(jfl))
+!!Alexcadm	 write(*,*)'PE ',narea,
+!!Alexcadm     .    iiinfl(jfl),iioutfl(jfl),ijinfl(jfl)
+!!Alexcadm     .		,ijoutfl(jfl),ikinfl(jfl),
+!!Alexcadm     .	  ikoutfl(jfl),ztxfl(jfl),ztyfl(jfl)
+!!Alexcadm     .		,ztzfl(jfl),zgifl(jfl),
+!!Alexcadm     .  zgjfl(jfl) 
+!!Alexcadm	IF (jfl == 910) write(*,*)'Flotteur 910',
+!!Alexcadm     .    iiinfl(jfl),iioutfl(jfl),ijinfl(jfl)
+!!Alexcadm     .		,ijoutfl(jfl),ikinfl(jfl),
+!!Alexcadm     .	  ikoutfl(jfl),ztxfl(jfl),ztyfl(jfl)
+!!Alexcadm     .		,ztzfl(jfl),zgifl(jfl),
+!!Alexcadm     .  zgjfl(jfl) 
+            ! reinitialisation of the age of FLOAT
+            zagefl(jfl) = zagenewfl(jfl)
+# if   defined key_mpp_mpi
+         ELSE
+            ! we put zgifl, zgjfl, zgkfl, zagefl
+            zgifl (jfl) = 0.
+            zgjfl (jfl) = 0.
+            zgkfl (jfl) = 0.
+            zagefl(jfl) = 0.
+            iil(jfl) = 0
+            ijl(jfl) = 0
+         ENDIF
+# endif
+      END DO
+      
+      ! synchronisation
+      IF( lk_mpp )   CALL mpp_sum( zgifl , jpnfl )   ! sums over the global domain
+      IF( lk_mpp )   CALL mpp_sum( zgjfl , jpnfl )
+      IF( lk_mpp )   CALL mpp_sum( zgkfl , jpnfl )
+      IF( lk_mpp )   CALL mpp_sum( zagefl, jpnfl )
+      IF( lk_mpp )   CALL mpp_sum( iil   , jpnfl )
+      IF( lk_mpp )   CALL mpp_sum( ijl   , jpnfl )
+      
+      ! Test to know if a  float hasn't integrated enought time
+      IF( ln_argo ) THEN
+         ifin = 1
+         DO jfl = 1, jpnfl
+            IF( zagefl(jfl) < rdt )   ifin = 0
+            tpifl(jfl) = zgifl(jfl) + 0.5
+            tpjfl(jfl) = zgjfl(jfl) + 0.5
+         END DO
+      ELSE
+         ifin = 1
+         DO jfl = 1, jpnfl
+            IF( zagefl(jfl) < rdt )   ifin = 0
+            tpifl(jfl) = zgifl(jfl) + 0.5
+            tpjfl(jfl) = zgjfl(jfl) + 0.5
+            IF( nisobfl(jfl) == 1 ) tpkfl(jfl) = -(zgkfl(jfl))
+         END DO
+      ENDIF
+!!Alexcadm	IF (lwp) write(numout,*) '---------'
+!!Alexcadm	IF (lwp) write(numout,*) 'before Erika:',tpifl(880),tpjfl(880),
+!!Alexcadm     .       tpkfl(880),zufl(880),zvfl(880),zwfl(880)
+!!Alexcadm	IF (lwp) write(numout,*) 'first Erika:',tpifl(900),tpjfl(900),
+!!Alexcadm     .       tpkfl(900),zufl(900),zvfl(900),zwfl(900)
+!!Alexcadm	IF (lwp) write(numout,*) 'last Erika:',tpifl(jpnfl),tpjfl(jpnfl),
+!!Alexcadm     .       tpkfl(jpnfl),zufl(jpnfl),zvfl(jpnfl),zwfl(jpnfl)
+      IF( ifin == 0 ) THEN
+         iloop = iloop + 1 
+         GO TO 222
+      ENDIF
+      !
+      !
+   END SUBROUTINE flo_blk
+
+#  else
+   !!----------------------------------------------------------------------
+   !!   Default option                                         Empty module
+   !!----------------------------------------------------------------------
+CONTAINS
+   SUBROUTINE flo_blk                  ! Empty routine
+   END SUBROUTINE flo_blk 
+#endif
+   
+   !!======================================================================
+END MODULE floblk 
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/FLO/flodom.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/FLO/flodom.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/FLO/flodom.F90	(revision 9570)
@@ -0,0 +1,469 @@
+MODULE flodom
+   !!======================================================================
+   !!                       ***  MODULE  flodom  ***
+   !! Ocean floats :   domain
+   !!======================================================================
+   !! History :  OPA  ! 1998-07 (Y.Drillet, CLIPPER)  Original code
+   !!  NEMO      3.3  ! 2011-09 (C.Bricaud,S.Law-Chune Mercator-Ocean): add ARIANE convention + comsecitc changes
+   !!----------------------------------------------------------------------
+#if   defined key_floats
+   !!----------------------------------------------------------------------
+   !!   'key_floats'                                     float trajectories
+   !!----------------------------------------------------------------------
+   !!   flo_dom               : initialization of floats
+   !!   add_new_floats        : add new floats (long/lat/depth)
+   !!   add_new_ariane_floats : add new floats with araine convention (i/j/k)
+   !!   findmesh              : compute index of position 
+   !!   dstnce                : compute distance between face mesh and floats 
+   !!----------------------------------------------------------------------
+   USE oce             ! ocean dynamics and tracers
+   USE dom_oce         ! ocean space and time domain
+   USE flo_oce         ! ocean drifting floats
+   USE in_out_manager  ! I/O manager
+   USE lib_mpp         ! distribued memory computing library
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   flo_dom         ! routine called by floats.F90
+   PUBLIC   flo_dom_alloc   ! Routine called in floats.F90
+
+   CHARACTER (len=21) ::  clname1 = 'init_float'              ! floats initialisation filename
+   CHARACTER (len=21) ::  clname2 = 'init_float_ariane'       ! ariane floats initialisation filename
+
+
+   INTEGER , ALLOCATABLE, DIMENSION(:) ::   iimfl, ijmfl, ikmfl       ! index mesh of floats
+   INTEGER , ALLOCATABLE, DIMENSION(:) ::   idomfl, ivtest, ihtest    !   -     
+   REAL(wp), ALLOCATABLE, DIMENSION(:) ::   zgifl, zgjfl,  zgkfl      ! distances in indexes
+
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO Consortium (2010)
+   !! $Id$ 
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE flo_dom
+      !! ---------------------------------------------------------------------
+      !!                  ***  ROUTINE flo_dom  ***
+      !!                 
+      !!  ** Purpose :   Initialisation of floats
+      !!
+      !!  ** Method  :   We put the floats  in the domain with the latitude,
+      !!               the longitude (degree) and the depth (m).
+      !!----------------------------------------------------------------------      
+      INTEGER            ::   jfl    ! dummy loop  
+      INTEGER            ::   inum   ! logical unit for file read
+      !!---------------------------------------------------------------------
+      
+      ! Initialisation with the geographical position or restart
+      
+      IF(lwp) WRITE(numout,*) 'flo_dom : compute initial position of floats'
+      IF(lwp) WRITE(numout,*) '~~~~~~~~'
+      IF(lwp) WRITE(numout,*) '           jpnfl = ',jpnfl
+      
+      !-------------------------!
+      ! FLOAT RESTART FILE READ !
+      !-------------------------!
+      IF( ln_rstflo )THEN
+
+         IF(lwp) WRITE(numout,*) '        float restart file read'
+         
+         ! open the restart file 
+         !----------------------
+         CALL ctl_opn( inum, 'restart_float', 'OLD', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp )
+
+         ! read of the restart file
+         READ(inum,*)   ( tpifl  (jfl), jfl=1, jpnrstflo),   & 
+                        ( tpjfl  (jfl), jfl=1, jpnrstflo),   &
+                        ( tpkfl  (jfl), jfl=1, jpnrstflo),   &
+                        ( nisobfl(jfl), jfl=1, jpnrstflo),   &
+                        ( ngrpfl (jfl), jfl=1, jpnrstflo)    
+         CLOSE(inum)
+
+         ! if we want a  surface drift  ( like PROVOR floats )
+         IF( ln_argo ) nisobfl(1:jpnrstflo) = 0
+         
+         ! It is possible to add new floats.          
+         !---------------------------------
+         IF( jpnfl > jpnrstflo )THEN
+
+            IF(lwp) WRITE(numout,*) '        add new floats'
+
+            IF( ln_ariane )THEN  !Add new floats with ariane convention
+                CALL flo_add_new_ariane_floats(jpnrstflo+1,jpnfl) 
+            ELSE                 !Add new floats with long/lat convention
+                CALL flo_add_new_floats(jpnrstflo+1,jpnfl)
+            ENDIF
+         ENDIF
+
+      !--------------------------------------!
+      ! FLOAT INITILISATION: NO RESTART FILE !
+      !--------------------------------------!
+      ELSE    !ln_rstflo
+
+         IF( ln_ariane )THEN       !Add new floats with ariane convention
+            CALL flo_add_new_ariane_floats(1,jpnfl)
+         ELSE                      !Add new floats with long/lat convention
+            CALL flo_add_new_floats(1,jpnfl)
+         ENDIF
+
+      ENDIF
+            
+   END SUBROUTINE flo_dom
+
+   SUBROUTINE flo_add_new_floats(kfl_start, kfl_end)
+      !! -------------------------------------------------------------
+      !!                 ***  SUBROUTINE add_new_arianefloats  ***
+      !!          
+      !! ** Purpose :   
+      !!
+      !!       First initialisation of floats
+      !!       the initials positions of floats are written in a file
+      !!       with a variable to know if it is a isobar float a number 
+      !!       to identified who want the trajectories of this float and 
+      !!       an index for the number of the float         
+      !!       open the init file 
+      !!               
+      !! ** Method  : 
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT(in) :: kfl_start, kfl_end
+      !!
+      INTEGER           :: inum ! file unit
+      INTEGER           :: jfl,ji, jj, jk ! dummy loop indices
+      INTEGER           :: itrash         ! trash var for reading
+      INTEGER           :: ifl            ! number of floats to read
+      REAL(wp)          :: zdxab, zdyad
+      LOGICAL           :: llinmesh
+      CHARACTER(len=80) :: cltmp
+      !!---------------------------------------------------------------------
+      ifl = kfl_end-kfl_start+1
+
+      ! we get the init values 
+      !-----------------------
+      CALL ctl_opn( inum , clname1, 'OLD', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp )
+      DO jfl = kfl_start,kfl_end
+         READ(inum,*) flxx(jfl),flyy(jfl),flzz(jfl), nisobfl(jfl),ngrpfl(jfl),itrash
+         if(lwp)write(numout,*)'read:',jfl,flxx(jfl),flyy(jfl),flzz(jfl), nisobfl(jfl),ngrpfl(jfl),itrash ; call flush(numout)
+      END DO
+      CLOSE(inum)
+            
+      ! Test to find the grid point coordonate with the geographical position            
+      !----------------------------------------------------------------------
+      DO jfl = kfl_start,kfl_end
+         ihtest(jfl) = 0
+         ivtest(jfl) = 0
+         ikmfl(jfl) = 0
+# if   defined key_mpp_mpi
+         DO ji = MAX(nldi,2), nlei
+            DO jj = MAX(nldj,2), nlej   ! NO vector opt.
+# else         
+         DO ji = 2, jpi
+            DO jj = 2, jpj   ! NO vector opt.
+# endif                     
+               ! For each float we find the indexes of the mesh                      
+               CALL flo_findmesh(glamf(ji-1,jj-1),gphif(ji-1,jj-1),   &
+                                 glamf(ji-1,jj  ),gphif(ji-1,jj  ),   &
+                                 glamf(ji  ,jj  ),gphif(ji  ,jj  ),   &
+                                 glamf(ji  ,jj-1),gphif(ji  ,jj-1),   &
+                                 flxx(jfl)       ,flyy(jfl)       ,   &
+                                 glamt(ji  ,jj  ),gphit(ji  ,jj  ), llinmesh)
+               IF( llinmesh )THEN
+                  iimfl(jfl) = ji
+                  ijmfl(jfl) = jj
+                  ihtest(jfl) = ihtest(jfl)+1
+                  DO jk = 1, jpk-1
+                     IF( (gdepw_n(ji,jj,jk) <= flzz(jfl)) .AND. (gdepw_n(ji,jj,jk+1) > flzz(jfl)) ) THEN
+                        ikmfl(jfl) = jk
+                        ivtest(jfl) = ivtest(jfl) + 1
+                     ENDIF
+                  END DO
+               ENDIF
+            END DO
+         END DO
+
+         ! If the float is in a mesh computed by an other processor we put iimfl=ijmfl=-1               
+         IF( ihtest(jfl) ==  0 ) THEN
+            iimfl(jfl) = -1
+            ijmfl(jfl) = -1
+         ENDIF
+      END DO
+
+      !Test if each float is in one and only one proc
+      !----------------------------------------------
+      IF( lk_mpp )   THEN 
+         CALL mpp_sum(ihtest,jpnfl)
+         CALL mpp_sum(ivtest,jpnfl)
+      ENDIF
+      DO jfl = kfl_start,kfl_end
+
+         IF( (ihtest(jfl) > 1 ) .OR. ( ivtest(jfl) > 1) ) THEN
+             WRITE(cltmp,'(A10,i4.4,A20)' )'THE FLOAT',jfl,' IS NOT IN ONLY ONE MESH'
+             CALL ctl_stop('STOP',TRIM(cltmp) )
+         ENDIF
+         IF( (ihtest(jfl) == 0) ) THEN
+             WRITE(cltmp,'(A10,i4.4,A20)' )'THE FLOAT',jfl,' IS IN NO MESH'
+             CALL ctl_stop('STOP',TRIM(cltmp) )
+         ENDIF
+      END DO
+
+      ! We compute the distance between the float and the face of the mesh            
+      !-------------------------------------------------------------------
+      DO jfl = kfl_start,kfl_end
+
+         ! Made only if the float is in the domain of the processor              
+         IF( (iimfl(jfl) >= 0) .AND. (ijmfl(jfl) >= 0) ) THEN
+
+            ! TEST TO KNOW IF THE FLOAT IS NOT INITIALISED IN THE COAST
+            idomfl(jfl) = 0
+            IF( tmask(iimfl(jfl),ijmfl(jfl),ikmfl(jfl)) == 0. ) idomfl(jfl) = 1
+
+            ! Computation of the distance between the float and the faces of the mesh
+            !            zdxab
+            !             .
+            !        B----.---------C
+            !        |    .         |
+            !        |<------>flo   |
+            !        |        ^     |
+            !        |        |.....|....zdyad
+            !        |        |     |
+            !        A--------|-----D
+            !
+            zdxab = flo_dstnce( flxx(jfl), flyy(jfl), glamf(iimfl(jfl)-1,ijmfl(jfl)-1), flyy(jfl) )
+            zdyad = flo_dstnce( flxx(jfl), flyy(jfl), flxx(jfl), gphif(iimfl(jfl)-1,ijmfl(jfl)-1) )
+
+            ! Translation of this distances (in meter) in indexes
+            zgifl(jfl)= (iimfl(jfl)-0.5) + zdxab/e1u(iimfl(jfl)-1,ijmfl(jfl)) + (mig(1)-1)
+            zgjfl(jfl)= (ijmfl(jfl)-0.5) + zdyad/e2v(iimfl(jfl),ijmfl(jfl)-1) + (mjg(1)-1)
+            zgkfl(jfl) = (( gdepw_n(iimfl(jfl),ijmfl(jfl),ikmfl(jfl)+1) - flzz(jfl) )* ikmfl(jfl))   &
+               &                 / (  gdepw_n(iimfl(jfl),ijmfl(jfl),ikmfl(jfl)+1)                              &
+               &                    - gdepw_n(iimfl(jfl),ijmfl(jfl),ikmfl(jfl) ) )                             &
+               &                 + (( flzz(jfl)-gdepw_n(iimfl(jfl),ijmfl(jfl),ikmfl(jfl)) ) *(ikmfl(jfl)+1))   &
+               &                 / (  gdepw_n(iimfl(jfl),ijmfl(jfl),ikmfl(jfl)+1)                              &
+               &                    - gdepw_n(iimfl(jfl),ijmfl(jfl),ikmfl(jfl)) )
+         ELSE
+            zgifl(jfl) = 0.e0
+            zgjfl(jfl) = 0.e0
+            zgkfl(jfl) = 0.e0
+         ENDIF
+
+      END DO
+                  
+      ! The sum of all the arrays zgifl, zgjfl, zgkfl give 3 arrays with the positions of all the floats.
+      IF( lk_mpp )   THEN 
+         CALL mpp_sum( zgjfl, ifl )   ! sums over the global domain
+         CALL mpp_sum( zgkfl, ifl )
+      ENDIF
+            
+      DO jfl = kfl_start,kfl_end
+         tpifl(jfl) = zgifl(jfl)
+         tpjfl(jfl) = zgjfl(jfl)
+         tpkfl(jfl) = zgkfl(jfl)
+      END DO
+
+      ! WARNING : initial position not in the sea         
+      IF( .NOT. ln_rstflo ) THEN 
+         DO jfl =  kfl_start,kfl_end
+            IF( idomfl(jfl) == 1 ) THEN
+               IF(lwp) WRITE(numout,*)'*****************************'
+               IF(lwp) WRITE(numout,*)'!!!!!!!  WARNING   !!!!!!!!!!'
+               IF(lwp) WRITE(numout,*)'*****************************'
+               IF(lwp) WRITE(numout,*)'The float number',jfl,'is out of the sea.'
+               IF(lwp) WRITE(numout,*)'geographical position',flxx(jfl),flyy(jfl),flzz(jfl)
+               IF(lwp) WRITE(numout,*)'index position',tpifl(jfl),tpjfl(jfl),tpkfl(jfl)
+            ENDIF
+         END DO
+      ENDIF
+
+   END SUBROUTINE flo_add_new_floats
+
+   SUBROUTINE flo_add_new_ariane_floats(kfl_start, kfl_end)
+      !! -------------------------------------------------------------
+      !!                 ***  SUBROUTINE add_new_arianefloats  ***
+      !!          
+      !! ** Purpose :   
+      !!       First initialisation of floats with ariane convention
+      !!       
+      !!       The indexes are read directly from file (warning ariane
+      !!       convention, are refered to 
+      !!       U,V,W grids - and not T-) 
+      !!       The isobar advection is managed with the sign of tpkfl ( >0 -> 3D
+      !!       advection, <0 -> 2D) 
+      !!       Some variables are not read, as - gl         : time index; 4th
+      !!       column        
+      !!                                       - transport  : transport ; 5th
+      !!                                       column
+      !!       and paste in the jtrash var
+      !!       At the end, ones need to replace the indexes on T grid
+      !!       RMQ : there is no float groups identification !
+      !!
+      !!               
+      !! ** Method  : 
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT(in) :: kfl_start, kfl_end
+      !!
+      INTEGER  :: inum         ! file unit
+      INTEGER  :: ierr, ifl
+      INTEGER  :: jfl, jfl1    ! dummy loop indices
+      INTEGER  :: itrash       ! trash var for reading  
+      CHARACTER(len=80) :: cltmp
+
+      !!----------------------------------------------------------------------
+      nisobfl(kfl_start:kfl_end) = 1 ! we assume that by default we want 3D advection
+
+      ifl = kfl_end - kfl_start + 1  ! number of floats to read  
+
+      ! we check that the number of floats in the init_file are consistant with the namelist
+      IF( lwp ) THEN
+
+         jfl1=0
+         ierr=0
+         CALL ctl_opn( inum, clname2, 'OLD', 'FORMATTED', 'SEQUENTIAL',  1, numout, .TRUE., 1 )
+         DO WHILE (ierr .EQ. 0)
+            jfl1=jfl1+1
+            READ(inum,*, iostat=ierr)
+         END DO
+         CLOSE(inum)
+         IF( (jfl1-1) .NE. ifl )THEN 
+            WRITE(cltmp,'(A25,A20,A3,i4.4,A10,i4.4)')"the number of floats in ",TRIM(clname2), &
+                                                     " = ",jfl1," is not equal to jfl= ",ifl
+            CALL ctl_stop('STOP',TRIM(cltmp) )
+         ENDIF
+
+      ENDIF
+            
+      ! we get the init values 
+      CALL ctl_opn( inum, clname2, 'OLD', 'FORMATTED', 'SEQUENTIAL', 1, numout, .TRUE., 1 )
+      DO jfl = kfl_start, kfl_end
+          READ(inum,*) tpifl(jfl),tpjfl(jfl),tpkfl(jfl),itrash, itrash
+              
+          IF ( tpkfl(jfl) .LT. 0. ) nisobfl(jfl) = 0 !set the 2D advection according to init_float
+          ngrpfl(jfl)=jfl
+      END DO
+
+      ! conversion from ariane index to T grid index
+      tpkfl(kfl_start:kfl_end) = abs(tpkfl)-0.5 ! reversed vertical axis
+      tpifl(kfl_start:kfl_end) = tpifl+0.5
+      tpjfl(kfl_start:kfl_end) = tpjfl+0.5
+
+
+   END SUBROUTINE flo_add_new_ariane_floats
+
+
+   SUBROUTINE flo_findmesh( pax, pay, pbx, pby,   &
+                            pcx, pcy, pdx, pdy,   &
+                            px  ,py  ,ptx, pty, ldinmesh )
+      !! -------------------------------------------------------------
+      !!                ***  ROUTINE findmesh  ***
+      !!      
+      !! ** Purpose :   Find the index of mesh for the point spx spy
+      !!
+      !! ** Method  : 
+      !!----------------------------------------------------------------------
+      REAL(wp) ::   &
+         pax, pay, pbx, pby,    &     ! ???
+         pcx, pcy, pdx, pdy,    &     ! ???
+         px, py,                &     ! longitude and latitude
+         ptx, pty                     ! ???
+      LOGICAL ::  ldinmesh            ! ???
+      !!
+      REAL(wp) ::   zabt, zbct, zcdt, zdat, zabpt, zbcpt, zcdpt, zdapt
+      !!---------------------------------------------------------------------
+      !! Statement function
+      REAL(wp) ::   fsline
+      REAL(wp) ::   psax, psay, psbx, psby, psx, psy
+      fsline( psax, psay, psbx, psby, psx, psy ) = psy  * ( psbx - psax )   &
+         &                                       - psx  * ( psby - psay )   &
+         &                                       + psax *   psby - psay * psbx
+      !!---------------------------------------------------------------------
+      
+      ! 4 semi plane defined by the 4 points and including the T point
+      zabt = fsline(pax,pay,pbx,pby,ptx,pty)
+      zbct = fsline(pbx,pby,pcx,pcy,ptx,pty)
+      zcdt = fsline(pcx,pcy,pdx,pdy,ptx,pty)
+      zdat = fsline(pdx,pdy,pax,pay,ptx,pty)
+      
+      ! 4 semi plane defined by the 4 points and including the extrememity
+      zabpt = fsline(pax,pay,pbx,pby,px,py)
+      zbcpt = fsline(pbx,pby,pcx,pcy,px,py)
+      zcdpt = fsline(pcx,pcy,pdx,pdy,px,py)
+      zdapt = fsline(pdx,pdy,pax,pay,px,py)
+       
+      ! We compare the semi plane T with the semi plane including the point
+      ! to know if it is in this  mesh.
+      ! For numerical reasons it is possible that for a point which is on
+      ! the line we don't have exactly zero with fsline function. We want 
+      ! that a point can't be in 2 mesh in the same time, so we put the 
+      ! coefficient to zero if it is smaller than 1.E-12
+      
+      IF( ABS(zabpt) <= 1.E-12 ) zabpt = 0.
+      IF( ABS(zbcpt) <= 1.E-12 ) zbcpt = 0.
+      IF( ABS(zcdpt) <= 1.E-12 ) zcdpt = 0.
+      IF( ABS(zdapt) <= 1.E-12 ) zdapt = 0.
+      IF( (zabt*zabpt >  0.) .AND. (zbct*zbcpt >= 0. ) .AND. ( zcdt*zcdpt >= 0. ) .AND. ( zdat*zdapt > 0. )   &
+         .AND. ( px <= MAX(pcx,pdx) ) .AND. ( px >= MIN(pax,pbx) )    &
+         .AND. ( py <= MAX(pby,pcy) ) .AND. ( py >= MIN(pay,pdy) ) ) THEN
+         ldinmesh=.TRUE.
+      ELSE
+         ldinmesh=.FALSE.
+      ENDIF
+      !
+   END SUBROUTINE flo_findmesh
+
+
+   FUNCTION flo_dstnce( pla1, phi1, pla2, phi2 )
+      !! -------------------------------------------------------------
+      !!                 ***  Function dstnce  ***
+      !!          
+      !! ** Purpose :   returns distance (in m) between two geographical
+      !!                points
+      !! ** Method  : 
+      !!----------------------------------------------------------------------
+      REAL(wp), INTENT(in) ::   pla1, phi1, pla2, phi2   ! ???
+      !!
+      REAL(wp) :: dly1, dly2, dlx1, dlx2, dlx, dls, dld, dpi
+      REAL(wp) :: flo_dstnce
+      !!---------------------------------------------------------------------
+      !
+      dpi  = 2._wp * ASIN(1._wp)
+      dls  = dpi / 180._wp
+      dly1 = phi1 * dls
+      dly2 = phi2 * dls
+      dlx1 = pla1 * dls
+      dlx2 = pla2 * dls
+      !
+      dlx = SIN(dly1) * SIN(dly2) + COS(dly1) * COS(dly2) * COS(dlx2-dlx1)
+      !
+      IF( ABS(dlx) > 1.0_wp ) dlx = 1.0_wp
+      !
+      dld = ATAN(DSQRT( 1._wp * ( 1._wp-dlx )/( 1._wp+dlx ) )) * 222.24_wp / dls
+      flo_dstnce = dld * 1000._wp
+      !
+   END FUNCTION flo_dstnce
+
+   INTEGER FUNCTION flo_dom_alloc()
+      !!----------------------------------------------------------------------
+      !!                 ***  FUNCTION flo_dom_alloc  ***
+      !!----------------------------------------------------------------------
+
+      ALLOCATE( iimfl(jpnfl) , ijmfl(jpnfl) , ikmfl(jpnfl) ,                          &  
+                idomfl(jpnfl), ivtest(jpnfl), ihtest(jpnfl),                 &
+                zgifl(jpnfl) , zgjfl(jpnfl) , zgkfl(jpnfl)   , STAT=flo_dom_alloc )
+      !
+      IF( lk_mpp             )   CALL mpp_sum ( flo_dom_alloc )
+      IF( flo_dom_alloc /= 0 )   CALL ctl_warn('flo_dom_alloc: failed to allocate arrays')
+   END FUNCTION flo_dom_alloc
+
+
+#else
+   !!----------------------------------------------------------------------
+   !!   Default option                                         Empty module
+   !!----------------------------------------------------------------------
+CONTAINS
+   SUBROUTINE flo_dom                 ! Empty routine
+         WRITE(*,*) 'flo_dom: : You should not have seen this print! error?'
+   END SUBROUTINE flo_dom
+#endif
+
+   !!======================================================================
+END MODULE flodom
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/FLO/florst.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/FLO/florst.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/FLO/florst.F90	(revision 9570)
@@ -0,0 +1,137 @@
+MODULE florst
+   !!======================================================================
+   !!                       ***  MODULE  florst  ***
+   !! Ocean floats : write floats restart files
+   !!======================================================================
+   !!  History :  OPA  !  1999-09  (Y. Drillet)    : Original code
+   !!              -   !  2000-06  (J.-M. Molines) : Profiling floats for CLS 
+   !!   NEMO      1.0  !  2002-10  (A. Bozec)  F90 : Free form and module
+   !!             3.2  !  2010-08  (slaw, cbricaud): netcdf outputs and others 
+   !!----------------------------------------------------------------------
+#if   defined key_floats
+   !!----------------------------------------------------------------------
+   !!   'key_floats'                                     float trajectories
+   !!----------------------------------------------------------------------
+   USE flo_oce         ! ocean drifting floats
+   USE dom_oce         ! ocean space and time domain
+   USE lib_mpp         ! distribued memory computing library
+   USE in_out_manager  ! I/O manager
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC flo_rst         ! routine called by floats.F90
+   PUBLIC flo_rst_alloc   ! routine called by floats.F90
+
+   INTEGER, ALLOCATABLE, DIMENSION(:) :: iperproc   ! 1D workspace
+
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.2 , LODYC-IPSL  (2009)
+   !! $Id$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   INTEGER FUNCTION flo_rst_alloc()
+      !!-------------------------------------------------------------------
+      !!                ***  FUNCTION flo_rst_alloc  ***
+      !!-------------------------------------------------------------------
+      ALLOCATE( iperproc(jpnij), STAT=flo_rst_alloc )
+      !  
+      IF( lk_mpp             )   CALL mpp_sum ( flo_rst_alloc )
+      IF( flo_rst_alloc /= 0 )   CALL ctl_warn('flo_rst_alloc: failed to allocate arrays.')
+   END FUNCTION flo_rst_alloc
+
+
+   SUBROUTINE flo_rst( kt )
+      !!---------------------------------------------------------------------
+      !!                  ***  ROUTINE flo_rst ***
+      !!             
+      !! ** Purpose :  
+      !!             
+      !!      
+      !! ** Method  :   The frequency of  ??? is nwritefl
+      !!      
+      !!----------------------------------------------------------------------
+      INTEGER  :: kt                            ! time step
+      !
+      CHARACTER (len=80)       :: clname             ! restart filename
+      INTEGER                  :: ic , jc , jpn ,jfl ! temporary integer
+      INTEGER                  :: inum               ! temporary logical unit for restart file
+      !!----------------------------------------------------------------------
+
+      IF(  ( MOD(kt,nn_stockfl) == 0 ) .OR. ( kt == nitend )  )THEN      
+
+         IF(lwp) THEN
+            WRITE(numout,*)
+            WRITE(numout,*) 'flo_rst : write in  restart_float file '
+            WRITE(numout,*) '~~~~~~~    '
+         ENDIF
+
+         ! file is opened and closed every time it is used.
+
+         clname = 'restart.float.'
+         ic = 1
+         DO jc = 1, 16
+            IF( cexper(jc:jc) /= ' ' ) ic = jc
+         END DO
+         clname = clname(1:14)//cexper(1:ic)
+         ic = 1
+         DO jc = 1, 48
+            IF( clname(jc:jc) /= ' ' ) ic = jc
+         END DO
+
+         inum=0
+         IF( lwp )THEN
+            CALL ctl_opn( inum, clname, 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE. )
+            REWIND inum
+         ENDIF
+         !
+         DO jpn = 1, jpnij
+            iperproc(jpn) = 0
+         END DO
+         !
+         IF(lwp) THEN
+            REWIND(inum)
+            WRITE (inum,*) tpifl,tpjfl,tpkfl,nisobfl,ngrpfl
+            CLOSE (inum)
+         ENDIF
+         !
+         ! Compute the number of trajectories for each processor
+         !
+         IF( lk_mpp ) THEN
+            DO jfl = 1, jpnfl
+               IF( (INT(tpifl(jfl)) >= mig(nldi)) .AND.   &
+                  &(INT(tpifl(jfl)) <= mig(nlei)) .AND.   &
+                  &(INT(tpjfl(jfl)) >= mjg(nldj)) .AND.   &
+                  &(INT(tpjfl(jfl)) <= mjg(nlej)) ) THEN
+                  iperproc(narea) = iperproc(narea)+1
+               ENDIF
+            END DO
+            CALL mpp_sum( iperproc, jpnij )
+            !
+            IF(lwp) THEN
+               WRITE(numout,*) 'DATE',adatrj
+               DO jpn = 1, jpnij
+                  IF( iperproc(jpn) /= 0 ) THEN
+                     WRITE(numout,*)'PROCESSOR',jpn-1,'compute',iperproc(jpn), 'trajectories.'
+                  ENDIF
+               END DO
+            ENDIF
+         ENDIF
+         !
+      ENDIF
+      !
+   END SUBROUTINE flo_rst
+
+#  else
+   !!----------------------------------------------------------------------
+   !!   Default option                                         Empty module
+   !!----------------------------------------------------------------------
+CONTAINS
+   SUBROUTINE flo_rst                 ! Empty routine
+   END SUBROUTINE flo_rst
+#endif
+
+   !!=======================================================================
+END MODULE florst
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/FLO/flowri.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/FLO/flowri.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/FLO/flowri.F90	(revision 9570)
@@ -0,0 +1,290 @@
+MODULE flowri
+   !!======================================================================
+   !!                       ***  MODULE  flowri  ***
+   !!
+   !! Ocean floats: write floats trajectory in ascii                    ln_flo_ascii = T
+   !!                                    or in netcdf ( IOM or IOSPSL ) ln_flo_ascii = F           
+   !!======================================================================
+   !!  History :  OPA  !  1999-09  (Y. Drillet)    : Original code
+   !!              -   !  2000-06  (J.-M. Molines) : Profiling floats for CLS 
+   !!   NEMO      1.0  !  2002-10  (A. Bozec)  F90 : Free form and module
+   !!             3.2  !  2010-08  (slaw, cbricaud): netcdf outputs and others 
+   !!----------------------------------------------------------------------
+#if   defined key_floats
+   !!----------------------------------------------------------------------
+   !!   'key_floats'                                     float trajectories
+   !!----------------------------------------------------------------------
+   USE flo_oce         ! ocean drifting floats
+   USE oce             ! ocean dynamics and tracers
+   USE dom_oce         ! ocean space and time domain
+   USE lib_mpp         ! distribued memory computing library
+   USE in_out_manager  ! I/O manager
+   USE phycst          ! physic constants
+   USE dianam          ! build name of file (routine)
+   USE ioipsl
+   USE iom             ! I/O library
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC flo_wri         ! routine called by floats.F90
+   PUBLIC flo_wri_alloc   ! routine called by floats.F90
+
+   INTEGER :: jfl                            ! number of floats
+   CHARACTER (len=80)  :: clname             ! netcdf output filename
+
+   REAL(wp), ALLOCATABLE, DIMENSION(:) ::   zlon , zlat, zdep   ! 2D workspace
+   REAL(wp), ALLOCATABLE, DIMENSION(:) ::   ztem , zsal, zrho   ! 2D workspace
+
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.2 , LODYC-IPSL  (2009)
+   !! $Id$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   INTEGER FUNCTION flo_wri_alloc()
+      !!-------------------------------------------------------------------
+      !!                ***  FUNCTION flo_wri_alloc  ***
+      !!-------------------------------------------------------------------
+      ALLOCATE( ztem(jpnfl) , zsal(jpnfl) , zrho(jpnfl) , &
+                zlon(jpnfl) , zlat(jpnfl) , zdep(jpnfl) , STAT=flo_wri_alloc)
+      !  
+      IF( lk_mpp             )   CALL mpp_sum ( flo_wri_alloc )
+      IF( flo_wri_alloc /= 0 )   CALL ctl_warn('flo_wri_alloc: failed to allocate arrays.')
+   END FUNCTION flo_wri_alloc
+
+   SUBROUTINE flo_wri( kt )
+      !!---------------------------------------------------------------------
+      !!                  ***  ROUTINE flo_wri ***
+      !!             
+      !! ** Purpose :   Write position of floats in "trajec_float.nc",according
+      !!                to ARIANE TOOLS (http://stockage.univ-brest.fr/~grima/Ariane/ )  n
+      !!                nomenclature
+      !!    
+      !!      
+      !! ** Method  :   The frequency of  ??? is nwritefl
+      !!      
+      !!----------------------------------------------------------------------
+      !! * Arguments
+      INTEGER  :: kt                               ! time step
+
+      !! * Local declarations
+      INTEGER  :: iafl , ibfl , icfl             ! temporary integer
+      INTEGER  :: ia1fl, ib1fl, ic1fl            !   "
+      INTEGER  :: iafloc,ibfloc,ia1floc,ib1floc  !   "
+      INTEGER  :: irec, irecflo
+
+      REAL(wp) :: zafl,zbfl,zcfl                 ! temporary real
+      REAL(wp) :: ztime                          !   "
+
+      INTEGER, DIMENSION(2)          :: icount
+      INTEGER, DIMENSION(2)          :: istart
+      INTEGER, DIMENSION(1)          :: ish
+      INTEGER, DIMENSION(2)          :: ish2
+      !!----------------------------------------------------------------------
+      
+      !-----------------------------------------------------
+      ! I- Save positions, temperature, salinty and density 
+      !-----------------------------------------------------
+      zlon(:)=0.0 ; zlat(:)=0.0 ; zdep(:)=0.0 
+      ztem(:)=0.0 ; zsal(:)=0.0 ; zrho(:)=0.0 
+
+      DO jfl = 1, jpnfl
+
+         iafl  = INT (tpifl(jfl))            ! I-index of the nearest point before
+         ibfl  = INT (tpjfl(jfl))            ! J-index of the nearest point before
+         icfl  = INT (tpkfl(jfl))            ! K-index of the nearest point before
+         ia1fl = iafl + 1                    ! I-index of the nearest point after
+         ib1fl = ibfl + 1                    ! J-index of the nearest point after
+         ic1fl = icfl + 1                    ! K-index of the nearest point after
+         zafl  = tpifl(jfl) - REAL(iafl,wp)  ! distance  ?????
+         zbfl  = tpjfl(jfl) - REAL(ibfl,wp)  ! distance  ?????
+         zcfl  = tpkfl(jfl) - REAL(icfl,wp)  ! distance  ?????
+
+         IF( lk_mpp ) THEN
+               
+            iafloc = mi1( iafl )
+            ibfloc = mj1( ibfl )
+ 
+            IF( nldi <= iafloc .AND. iafloc <= nlei .AND. &
+              & nldj <= ibfloc .AND. ibfloc <= nlej       ) THEN 
+
+               !the float is inside of current proc's area
+               ia1floc = iafloc + 1
+               ib1floc = ibfloc + 1
+     
+               !save position of the float
+               zlat(jfl) = (1.-zafl)*(1.-zbfl)*gphit(iafloc ,ibfloc ) + (1.-zafl) * zbfl * gphit(iafloc ,ib1floc)   &
+                     +     zafl *(1.-zbfl)*gphit(ia1floc,ibfloc ) +     zafl  * zbfl * gphit(ia1floc,ib1floc)   
+               zlon(jfl) = (1.-zafl)*(1.-zbfl)*glamt(iafloc ,ibfloc ) + (1.-zafl) * zbfl * glamt(iafloc ,ib1floc)   &
+                     +     zafl *(1.-zbfl)*glamt(ia1floc,ibfloc ) +     zafl  * zbfl * glamt(ia1floc,ib1floc)
+               zdep(jfl) = (1.-zcfl)*gdepw_n(iafloc,ibfloc,icfl ) + zcfl * gdepw_n(iafloc,ibfloc,ic1fl)     
+
+               !save temperature, salinity and density at this position
+               ztem(jfl) = tsn(iafloc,ibfloc,icfl,jp_tem)
+               zsal (jfl) = tsn(iafloc,ibfloc,icfl,jp_sal)
+               zrho (jfl) = (rhd(iafloc,ibfloc,icfl)+1)*rau0
+
+            ENDIF
+
+         ELSE  ! mono proc case  
+
+            iafloc  = iafl
+            ibfloc  = ibfl
+            ia1floc = iafloc + 1
+            ib1floc = ibfloc + 1
+
+            !save position of the float               
+            zlat(jfl) = (1.-zafl)*(1.-zbfl)*gphit(iafloc ,ibfloc ) + (1.-zafl) * zbfl * gphit(iafloc ,ib1floc)   &
+                      +     zafl *(1.-zbfl)*gphit(ia1floc,ibfloc ) +     zafl  * zbfl * gphit(ia1floc,ib1floc)
+            zlon(jfl) = (1.-zafl)*(1.-zbfl)*glamt(iafloc ,ibfloc ) + (1.-zafl) * zbfl * glamt(iafloc ,ib1floc)   &
+                      +     zafl *(1.-zbfl)*glamt(ia1floc,ibfloc ) +     zafl  * zbfl * glamt(ia1floc,ib1floc)
+            zdep(jfl) = (1.-zcfl)*gdepw_n(iafloc,ibfloc,icfl ) + zcfl * gdepw_n(iafloc,ibfloc,ic1fl)
+
+            ztem(jfl) = tsn(iafloc,ibfloc,icfl,jp_tem)
+            zsal(jfl) = tsn(iafloc,ibfloc,icfl,jp_sal)
+            zrho(jfl) = (rhd(iafloc,ibfloc,icfl)+1)*rau0
+          
+         ENDIF
+
+      END DO ! loop on float
+
+      !Only proc 0 writes all positions : SUM of positions on all procs
+      IF( lk_mpp ) THEN
+         CALL mpp_sum( zlon, jpnfl )   ! sums over the global domain
+         CALL mpp_sum( zlat, jpnfl )   ! sums over the global domain
+         CALL mpp_sum( zdep, jpnfl )   ! sums over the global domain
+         CALL mpp_sum( ztem, jpnfl )   ! sums over the global domain
+         CALL mpp_sum( zsal, jpnfl )   ! sums over the global domain
+         CALL mpp_sum( zrho, jpnfl )   ! sums over the global domain
+      ENDIF
+
+
+      !-------------------------------------!
+      ! II- WRITE WRITE WRITE WRITE WRITE   !
+      !-------------------------------------!
+
+      !--------------------------!
+      ! II-1 Write in ascii file !
+      !--------------------------!
+
+      IF( ln_flo_ascii )THEN
+
+         IF( ( kt == nn_it000 .OR. MOD( kt,nn_writefl)== 0 ) .AND. lwp )THEN
+
+            !II-1-a Open ascii file
+            !----------------------
+            IF( kt == nn_it000 ) THEN
+               CALL ctl_opn( numflo, 'trajec_float', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE. )
+               irecflo = NINT( (nitend-nn_it000) / FLOAT(nn_writefl) )
+               WRITE(numflo,*)cexper,no,irecflo,jpnfl,nn_writefl
+            ENDIF
+
+            !II-1-b Write in ascii file
+            !-----------------------------
+            WRITE(numflo,*) zlon,zlat,zdep,nisobfl,ngrpfl,ztem,zsal, FLOAT(ndastp)
+
+
+            !II-1-c Close netcdf file
+            !-------------------------
+            IF( kt == nitend )   CLOSE( numflo )
+
+         ENDIF
+
+      !-----------------------------------------------------
+      ! II-2 Write in netcdf file
+      !-----------------------------------------------------
+
+      ELSE
+
+      !II-2-a Write with IOM
+      !----------------------
+
+#if defined key_iomput
+         CALL iom_put( "traj_lon"     , zlon )
+         CALL iom_put( "traj_lat"     , zlat )
+         CALL iom_put( "traj_dep"     , zdep )
+         CALL iom_put( "traj_temp"    , ztem )
+         CALL iom_put( "traj_salt"    , zsal  )
+         CALL iom_put( "traj_dens"    , zrho )
+         CALL iom_put( "traj_group"   , REAL(ngrpfl,wp) )
+#else
+
+      !II-2-b Write with IOIPSL
+      !------------------------
+
+         IF( ( kt == nn_it000 .OR. MOD( kt,nn_writefl)== 0 ) .AND. lwp )THEN
+
+
+            !II-2-b-1 Open netcdf file
+            !-------------------------
+            IF( kt==nn_it000 )THEN   ! Create and open
+
+               CALL dia_nam( clname, nn_writefl, 'trajec_float' )
+               clname=TRIM(clname)//".nc"
+
+               CALL fliocrfd( clname , (/ 'ntraj' , 't' /), (/ jpnfl , -1  /) , numflo )
+   
+               CALL fliodefv( numflo, 'traj_lon'    , (/1,2/), v_t=flio_r8, long_name="Longitude"           , units="degrees_east"  )
+               CALL fliodefv( numflo, 'traj_lat'    , (/1,2/), v_t=flio_r8, long_name="Latitude"            , units="degrees_north" )
+               CALL fliodefv( numflo, 'traj_depth'  , (/1,2/), v_t=flio_r8, long_name="Depth"               , units="meters" )
+               CALL fliodefv( numflo, 'time_counter', (/2/)  , v_t=flio_r8, long_name="Time axis"           & 
+                         & , units="seconds since start of the run " )
+               CALL fliodefv( numflo, 'traj_temp'   , (/1,2/), v_t=flio_r8, long_name="Temperature"         , units="C" )
+               CALL fliodefv( numflo, 'traj_salt'   , (/1,2/), v_t=flio_r8, long_name="Salinity"            , units="PSU" )
+               CALL fliodefv( numflo, 'traj_dens'   , (/1,2/), v_t=flio_r8, long_name="Density"             , units="kg/m3" )
+               CALL fliodefv( numflo, 'traj_group'  , (/1/)  , v_t=flio_r8, long_name="number of the group" , units="no unit" )
+
+               CALL flioputv( numflo , 'traj_group' , REAL(ngrpfl,wp) )
+  
+            ELSE  ! Re-open
+       
+               CALL flioopfd( TRIM(clname), numflo , "WRITE" )
+
+            ENDIF
+
+            !II-2-b-2 Write in  netcdf file
+            !-------------------------------
+            irec =  INT( (kt-nn_it000+1)/nn_writefl ) +1
+            ztime = ( kt-nn_it000 + 1 ) * rdt
+
+            CALL flioputv( numflo , 'time_counter', ztime , start=(/irec/) )
+
+            DO jfl = 1, jpnfl
+
+               istart = (/jfl,irec/)
+               icfl   = INT( tpkfl(jfl) )            ! K-index of the nearest point before
+
+               CALL flioputv( numflo , 'traj_lon'    , zlon(jfl)        , start=istart )
+               CALL flioputv( numflo , 'traj_lat'    , zlat(jfl)        , start=istart )  
+               CALL flioputv( numflo , 'traj_depth'  , zdep(jfl)        , start=istart )  
+               CALL flioputv( numflo , 'traj_temp'   , ztemp(icfl,jfl)  , start=istart )  
+               CALL flioputv( numflo , 'traj_salt'   , zsal(icfl,jfl)   , start=istart )  
+               CALL flioputv( numflo , 'traj_dens'   , zrho(icfl,jfl)   , start=istart )  
+
+            ENDDO
+
+            !II-2-b-3 Close netcdf file
+            !---------------------------
+            CALL flioclo( numflo )
+
+         ENDIF
+
+#endif
+      ENDIF ! netcdf writing
+   
+   END SUBROUTINE flo_wri
+
+
+#  else
+   !!----------------------------------------------------------------------
+   !!   Default option                                         Empty module
+   !!----------------------------------------------------------------------
+CONTAINS
+   SUBROUTINE flo_wri                 ! Empty routine
+   END SUBROUTINE flo_wri
+#endif
+
+   !!=======================================================================
+END MODULE flowri
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/ICB/icb_oce.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/ICB/icb_oce.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/ICB/icb_oce.F90	(revision 9570)
@@ -0,0 +1,196 @@
+MODULE icb_oce
+   !!======================================================================
+   !!                       ***  MODULE  icb_oce  ***
+   !! Icebergs:  declare variables for iceberg tracking
+   !!======================================================================
+   !! History :  3.3  !  2010-01  (T. Martin & A. Adcroft)  Original code
+   !!             -   !  2011-03  (G. Madec)  Part conversion to NEMO form
+   !!             -   !                       Removal of mapping from another grid
+   !!             -   !  2011-04  (S. Alderson) Extensive rewrite ; Split into separate modules
+   !!----------------------------------------------------------------------
+   !!
+   !! Track Icebergs as Lagrangian objects within the model domain
+   !! Interaction with the other model variables through 'icebergs_gridded'
+   !!
+   !! A single iceberg is held as an instance of type 'iceberg'
+   !! This type defines a linked list, so each instance contains a pointer 
+   !! to the previous and next icebergs in the list
+   !!
+   !! Type 'icebergs' is a convenience container for all relevant arrays
+   !! It contains one pointer to an 'iceberg' instance representing all icebergs in the processor
+   !!
+   !! Each iceberg has a position represented as a real cartesian coordinate which is 
+   !! fractional grid cell, centred on T-points; so an iceberg position of (1.0,1.0) lies 
+   !! exactly on the first T-point and the T-cell spans 0.5 to 1.5 in each direction
+   !!
+   !! Each iceberg is assigned a unique id even in MPI
+   !! This consists of an array of integers: the first element is used to label, the second
+   !! and subsequent elements are used to count the number of times the first element wraps
+   !! around all possible values within the valid size for this datatype.
+   !! Labelling is done by starting the first label in each processor (even when only one)
+   !! as narea, and then incrementing by jpnij (i.e. the total number of processors.
+   !! This means that the source processor for each iceberg can be identified by arithmetic
+   !! modulo jpnij.
+   !! 
+   !!----------------------------------------------------------------------
+   USE par_oce   ! ocean parameters
+   USE lib_mpp   ! MPP library
+
+   IMPLICIT NONE
+   PUBLIC
+
+   PUBLIC   icb_alloc   ! routine called by icb_init in icbini.F90 module
+
+   INTEGER, PUBLIC, PARAMETER ::   nclasses = 10   !: Number of icebergs classes   
+   INTEGER, PUBLIC, PARAMETER ::   nkounts  =  3   !: Number of integers combined for unique naming
+
+   TYPE, PUBLIC ::   icebergs_gridded   !: various icebergs properties on model grid
+      REAL(wp), DIMENSION(:,:)  , ALLOCATABLE ::   calving         ! Calving mass rate  (into stored ice)         [kg/s]
+      REAL(wp), DIMENSION(:,:)  , ALLOCATABLE ::   calving_hflx    ! Calving heat flux [heat content of calving]  [W/m2]
+      REAL(wp), DIMENSION(:,:)  , ALLOCATABLE ::   floating_melt   ! Net melting rate to icebergs + bits      [kg/s/m^2]
+      INTEGER , DIMENSION(:,:)  , ALLOCATABLE ::   maxclass        ! maximum class number at calving source point
+      REAL(wp), DIMENSION(:,:)  , ALLOCATABLE ::   tmp             ! Temporary work space
+      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::   stored_ice      ! Accumulated ice mass flux at calving locations [kg]
+      REAL(wp), DIMENSION(:,:)  , ALLOCATABLE ::   stored_heat     ! Heat content of stored ice                      [J]
+   END TYPE icebergs_gridded
+
+   TYPE, PUBLIC ::   point              !: properties of an individual iceberg (position, mass, size, etc...)
+      INTEGER  ::   year
+      REAL(wp) ::   xi , yj                                              ! iceberg coordinates in the (i,j) referential (global)
+      REAL(wp) ::   e1 , e2                                              ! horizontal scale factors at the iceberg position
+      REAL(wp) ::   lon, lat, day                                        ! geographic position
+      REAL(wp) ::   mass, thickness, width, length, uvel, vvel           ! iceberg physical properties
+      REAL(wp) ::   uo, vo, ui, vi, ua, va, ssh_x, ssh_y, sst, cn, hi    ! properties of iceberg environment 
+      REAL(wp) ::   mass_of_bits, heat_density
+   END TYPE point
+
+   TYPE, PUBLIC ::   iceberg            !: linked list defining all the icebergs present in the model domain
+      TYPE(iceberg), POINTER      ::   prev=>NULL(), next=>NULL()   ! pointers to previous and next unique icebergs in linked list
+      INTEGER, DIMENSION(nkounts) ::   number                       ! variables which do not change for this iceberg
+      REAL(wp)                    ::   mass_scaling                 !    -        -            -                -  
+      TYPE(point), POINTER        ::   current_point => NULL()      ! variables which change with time are held in a separate type
+   END TYPE iceberg
+
+
+   TYPE(icebergs_gridded), POINTER ::   berg_grid                 !: master instance of gridded iceberg type
+   TYPE(iceberg)         , POINTER ::   first_berg => NULL()      !: master instance of linked list iceberg type
+
+   !                                                             !!! parameters controlling iceberg characteristics and modelling
+   REAL(wp)                            ::   berg_dt                   !: Time-step between iceberg CALLs (should make adaptive?)
+   REAL(wp), DIMENSION(:), ALLOCATABLE ::   first_width, first_length !: 
+   LOGICAL                             ::   l_restarted_bergs=.FALSE.  ! Indicate whether we read state from a restart or not
+   !                                                               ! arbitrary numbers for diawri entry
+   REAL(wp), DIMENSION(nclasses), PUBLIC ::   class_num=(/ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10 /)
+
+   ! Extra arrays with bigger halo, needed when interpolating forcing onto iceberg position
+   ! particularly for MPP when iceberg can lie inside T grid but outside U, V, or f grid
+   REAL(wp), PUBLIC, DIMENSION(:,:), ALLOCATABLE ::   uo_e, vo_e
+   REAL(wp), PUBLIC, DIMENSION(:,:), ALLOCATABLE ::   ff_e, tt_e, fr_e, hicth
+   REAL(wp), PUBLIC, DIMENSION(:,:), ALLOCATABLE ::   ua_e, va_e
+   REAL(wp), PUBLIC, DIMENSION(:,:), ALLOCATABLE ::   ssh_e
+#if defined key_si3 || defined key_cice
+   REAL(wp), PUBLIC, DIMENSION(:,:), ALLOCATABLE ::   ui_e, vi_e
+#endif
+
+   !!gm almost all those PARAM ARE defined in NEMO
+   REAL(wp), PUBLIC, PARAMETER :: pp_rho_ice      = 916.7_wp   !: Density of fresh ice   @ 0oC [kg/m^3]
+   REAL(wp), PUBLIC, PARAMETER :: pp_rho_water    = 999.8_wp   !: Density of fresh water @ 0oC [kg/m^3]
+   REAL(wp), PUBLIC, PARAMETER :: pp_rho_air      = 1.1_wp     !: Density of air         @ 0oC [kg/m^3]
+   REAL(wp), PUBLIC, PARAMETER :: pp_rho_seawater = 1025._wp   !: Approx. density of surface sea water @ 0oC [kg/m^3]
+   !!gm end
+   REAL(wp), PUBLIC, PARAMETER :: pp_Cd_av = 1.3_wp      !: (Vertical) Drag coefficient between bergs and atmos 
+   REAL(wp), PUBLIC, PARAMETER :: pp_Cd_ah = 0.0055_wp   !: (lateral ) Drag coefficient between bergs and atmos 
+   REAL(wp), PUBLIC, PARAMETER :: pp_Cd_wv = 0.9_wp      !: (Vertical) Drag coefficient between bergs and ocean
+   REAL(wp), PUBLIC, PARAMETER :: pp_Cd_wh = 0.0012_wp   !: (lateral ) Drag coefficient between bergs and ocean 
+   REAL(wp), PUBLIC, PARAMETER :: pp_Cd_iv = 0.9_wp      !: (Vertical) Drag coefficient between bergs and sea-ice
+!TOM> no horizontal drag for sea ice! real, PARAMETER :: pp_Cd_ih=0.0012 ! (lateral) Drag coeff. between bergs and sea-ice
+
+   !                                                         !!* namberg namelist parameters (and defaults) **
+   LOGICAL , PUBLIC ::   ln_bergdia                      !: Calculate budgets
+   INTEGER , PUBLIC ::   nn_verbose_level                !: Turn on debugging when level > 0
+   INTEGER , PUBLIC ::   nn_test_icebergs                !: Create icebergs in absence of a restart file from the supplied class nb
+   REAL(wp), PUBLIC, DIMENSION(4) ::   rn_test_box       !: lon1,lon2,lat1,lat2 box to create them in
+   INTEGER , PUBLIC ::   nn_sample_rate                  !: Timesteps between sampling of position for trajectory storage
+   INTEGER , PUBLIC ::   nn_verbose_write                !: timesteps between verbose messages
+   REAL(wp), PUBLIC ::   rn_rho_bergs                    !: Density of icebergs
+   REAL(wp), PUBLIC ::   rn_LoW_ratio                    !: Initial ratio L/W for newly calved icebergs
+   REAL(wp), PUBLIC ::   rn_bits_erosion_fraction        !: Fraction of erosion melt flux to divert to bergy bits
+   REAL(wp), PUBLIC ::   rn_sicn_shift                   !: Shift of sea-ice concentration in erosion flux modulation (0<sicn_shift<1)
+   LOGICAL , PUBLIC ::   ln_operator_splitting           !: Use first order operator splitting for thermodynamics
+   LOGICAL , PUBLIC ::   ln_passive_mode                 !: iceberg - ocean decoupling
+   LOGICAL , PUBLIC ::   ln_time_average_weight          !: Time average the weight on the ocean    !!gm I don't understand that !
+   REAL(wp), PUBLIC ::   rn_speed_limit                  !: CFL speed limit for a berg
+   !
+   !                                     ! Mass thresholds between iceberg classes [kg]
+   REAL(wp), DIMENSION(nclasses), PUBLIC ::   rn_initial_mass      ! Fraction of calving to apply to this class [non-dim]
+   REAL(wp), DIMENSION(nclasses), PUBLIC ::   rn_distribution      ! Ratio between effective and real iceberg mass (non-dim)
+   REAL(wp), DIMENSION(nclasses), PUBLIC ::   rn_mass_scaling      ! Total thickness of newly calved bergs [m]
+   REAL(wp), DIMENSION(nclasses), PUBLIC ::   rn_initial_thickness !  Single instance of an icebergs type initialised in icebergs_init and updated in icebergs_run
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)     ::   src_calving, src_calving_hflx    !: accumulate input ice
+   INTEGER , PUBLIC             , SAVE                     ::   numicb                           !: iceberg IO
+   INTEGER , PUBLIC             , SAVE, DIMENSION(nkounts) ::   num_bergs                        !: iceberg counter
+   INTEGER , PUBLIC             , SAVE                     ::   nicbdi, nicbei, nicbdj, nicbej   !: processor bounds
+   REAL(wp), PUBLIC             , SAVE                     ::   ricb_left, ricb_right            !: cyclical bounds
+   INTEGER , PUBLIC             , SAVE                     ::   nicbpack                         !: packing integer
+   INTEGER , PUBLIC             , SAVE                     ::   nktberg, nknberg                 !: helpers
+   INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:)       ::   nicbfldpts                       !: nfold packed points
+   INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:)       ::   nicbflddest                      !: nfold destination proc
+   INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:)       ::   nicbfldproc                      !: nfold destination proc
+   INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:)       ::   nicbfldnsend                     !: nfold number of bergs to send to nfold neighbour
+   INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:)       ::   nicbfldexpect                    !: nfold expected number of bergs
+   INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:)       ::   nicbfldreq                       !: nfold message handle (immediate send)
+
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)   :: griddata                           !: work array for icbrst
+
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO Consortium (2011)
+   !! $Id$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+   
+   INTEGER FUNCTION icb_alloc()
+      !!----------------------------------------------------------------------
+      !!                ***  ROUTINE icb_alloc  ***
+      !!----------------------------------------------------------------------
+      INTEGER ::   ill
+      !!----------------------------------------------------------------------
+      !
+      icb_alloc = 0
+      ALLOCATE( berg_grid, STAT=ill )
+      icb_alloc = icb_alloc + ill
+      ALLOCATE( berg_grid%calving    (jpi,jpj) , berg_grid%calving_hflx (jpi,jpj)          ,   &
+         &      berg_grid%stored_heat(jpi,jpj) , berg_grid%floating_melt(jpi,jpj)          ,   &
+         &      berg_grid%maxclass   (jpi,jpj) , berg_grid%stored_ice   (jpi,jpj,nclasses) ,   &
+         &      berg_grid%tmp        (jpi,jpj) , STAT=ill)
+      icb_alloc = icb_alloc + ill
+      !
+      ! expanded arrays for bilinear interpolation
+      ALLOCATE( uo_e(0:jpi+1,0:jpj+1) , ua_e(0:jpi+1,0:jpj+1) ,   &
+         &      vo_e(0:jpi+1,0:jpj+1) , va_e(0:jpi+1,0:jpj+1) ,   &
+#if defined key_si3 || defined key_cice
+         &      ui_e(0:jpi+1,0:jpj+1) ,                            &
+         &      vi_e(0:jpi+1,0:jpj+1) ,                            &
+#endif
+         &      ff_e(0:jpi+1,0:jpj+1) , fr_e(0:jpi+1,0:jpj+1)  ,   &
+         &      tt_e(0:jpi+1,0:jpj+1) , ssh_e(0:jpi+1,0:jpj+1) ,   &
+         &      hicth(0:jpi+1,0:jpj+1),                            &
+         &      first_width(nclasses) , first_length(nclasses) ,   &
+         &      src_calving (jpi,jpj) ,                            &
+         &      src_calving_hflx(jpi,jpj) , STAT=ill)
+      icb_alloc = icb_alloc + ill
+
+      ALLOCATE( nicbfldpts(jpi) , nicbflddest(jpi) , nicbfldproc(jpni) , &
+         &      nicbfldnsend(jpni), nicbfldexpect(jpni) , nicbfldreq(jpni), STAT=ill)
+      icb_alloc = icb_alloc + ill
+
+      ALLOCATE( griddata(jpi,jpj,1), STAT=ill )
+      icb_alloc = icb_alloc + ill
+
+      IF( lk_mpp        )   CALL mpp_sum ( icb_alloc )
+      IF( icb_alloc > 0 )   CALL ctl_warn('icb_alloc: allocation of arrays failed')
+      !
+   END FUNCTION icb_alloc
+
+   !!======================================================================
+END MODULE icb_oce
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/ICB/icbclv.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/ICB/icbclv.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/ICB/icbclv.F90	(revision 9570)
@@ -0,0 +1,184 @@
+MODULE icbclv
+   !!======================================================================
+   !!                       ***  MODULE  icbclv  ***
+   !! Icebergs:  calving routines for iceberg calving
+   !!======================================================================
+   !! History : 3.3.1 !  2010-01  (Martin&Adcroft) Original code
+   !!            -    !  2011-03  (Madec)          Part conversion to NEMO form
+   !!            -    !                            Removal of mapping from another grid
+   !!            -    !  2011-04  (Alderson)       Split into separate modules
+   !!            -    !  2011-05  (Alderson)       budgets into separate module
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   icb_clv_flx   : transfer input flux of ice into iceberg classes
+   !!   icb_clv       : calve icebergs from stored ice
+   !!----------------------------------------------------------------------
+   USE par_oce        ! NEMO parameters
+   USE dom_oce        ! NEMO ocean domain
+   USE phycst         ! NEMO physical constants
+   USE lib_mpp        ! NEMO MPI library, lk_mpp in particular
+   USE lbclnk         ! NEMO boundary exchanges for gridded data
+
+   USE icb_oce        ! iceberg variables
+   USE icbdia         ! iceberg diagnostics
+   USE icbutl         ! iceberg utility routines
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   icb_clv_flx  ! routine called in icbstp.F90 module
+   PUBLIC   icb_clv      ! routine called in icbstp.F90 module
+
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO Consortium (2011)
+   !! $Id$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE icb_clv_flx( kt )
+      !!----------------------------------------------------------------------
+      !!                 ***  ROUTINE icb_clv_flx  ***
+      !!
+      !! ** Purpose :   accumulate ice available for calving into class arrays
+      !!
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT(in) ::   kt
+      !
+      REAL(wp)      ::   zcalving_used, zdist, zfact
+      INTEGER       ::   jn, ji, jj                    ! loop counters
+      INTEGER       ::   imx                           ! temporary integer for max berg class
+      LOGICAL, SAVE ::   ll_first_call = .TRUE.
+      !!----------------------------------------------------------------------
+      !
+      ! Adapt calving flux and calving heat flux from coupler for use here
+      ! Use interior mask: so no bergs in overlap areas and convert from km^3/year to kg/s
+      ! this assumes that input is given as equivalent water flux so that pure water density is appropriate
+
+      zfact = ( (1000._wp)**3 / ( NINT(rday) * nyear_len(1) ) ) * 850._wp
+      berg_grid%calving(:,:) = src_calving(:,:) * tmask_i(:,:) * zfact
+
+      ! Heat in units of W/m2, and mask (just in case)
+      berg_grid%calving_hflx(:,:) = src_calving_hflx(:,:) * tmask_i(:,:)
+
+      IF( ll_first_call .AND. .NOT. l_restarted_bergs) THEN      ! This is a hack to simplify initialization
+         ll_first_call = .FALSE.
+         !do jn=1, nclasses
+         !  where (berg_grid%calving==0.) berg_grid%stored_ice(:,:,jn)=0.
+         !end do
+         DO jj = 2, jpjm1
+            DO ji = 2, jpim1
+               IF( berg_grid%calving(ji,jj) /= 0._wp )                                          &    ! Need units of J
+                  berg_grid%stored_heat(ji,jj) = SUM( berg_grid%stored_ice(ji,jj,:) ) *         &    ! initial stored ice in kg
+                     &                   berg_grid%calving_hflx(ji,jj) * e1e2t(ji,jj) / berg_grid%calving(ji,jj)   ! J/s/m2 x m^2 
+                     !                                                                                             ! = J/s/calving in kg/s
+            END DO
+         END DO
+      ENDIF
+
+      ! assume that all calving flux must be distributed even if distribution array does not sum
+      ! to one - this may not be what is intended, but it's what you've got
+      DO jj = 1, jpj
+         DO ji = 1, jpi
+            imx = berg_grid%maxclass(ji,jj)
+            zdist = SUM( rn_distribution(1:nclasses) ) / SUM( rn_distribution(1:imx) )
+            DO jn = 1, imx
+               berg_grid%stored_ice(ji,jj,jn) = berg_grid%stored_ice(ji,jj,jn)     &
+                  &                           + berg_dt * berg_grid%calving(ji,jj) * rn_distribution(jn) * zdist
+            END DO
+         END DO
+      END DO
+
+      ! before changing the calving, save the amount we're about to use and do budget
+      zcalving_used = SUM( berg_grid%calving(:,:) )
+      berg_grid%tmp(:,:) = berg_dt * berg_grid%calving_hflx(:,:) * e1e2t(:,:) * tmask_i(:,:)
+      berg_grid%stored_heat (:,:) = berg_grid%stored_heat (:,:) + berg_grid%tmp(:,:)
+      CALL icb_dia_income( kt,  zcalving_used, berg_grid%tmp )
+      !
+   END SUBROUTINE icb_clv_flx
+
+
+   SUBROUTINE icb_clv()
+      !!----------------------------------------------------------------------
+      !!                 ***  ROUTINE icb_clv  ***
+      !!
+      !! ** Purpose :   This routine takes a stored ice field and calves to the ocean,
+      !!                so the gridded array stored_ice has only non-zero entries at selected
+      !!                wet points adjacent to known land based calving points
+      !!
+      !! ** method  : - Look at each grid point and see if there's enough for each size class to calve
+      !!                If there is, a new iceberg is calved.  This happens in the order determined by
+      !!                the class definition arrays (which in the default case is smallest first)
+      !!                Note that only the non-overlapping part of the processor where icebergs are allowed
+      !!                is considered
+      !!----------------------------------------------------------------------
+      INTEGER       ::   ji, jj, jn   ! dummy loop indices
+      INTEGER       ::   icnt, icntmax
+      TYPE(iceberg) ::   newberg
+      TYPE(point)   ::   newpt
+      REAL(wp)      ::   zday, zcalved_to_berg, zheat_to_berg
+      !!----------------------------------------------------------------------
+      !
+      icntmax = 0
+      zday    = REAL(nday_year,wp) + REAL(nsec_day,wp)/86400.0_wp
+      !
+      DO jn = 1, nclasses
+         DO jj = nicbdj, nicbej
+            DO ji = nicbdi, nicbei
+               !
+               icnt = 0
+               !
+               DO WHILE (berg_grid%stored_ice(ji,jj,jn) >= rn_initial_mass(jn) * rn_mass_scaling(jn) )
+                  !
+                  newpt%lon = glamt(ji,jj)         ! at t-point (centre of the cell)
+                  newpt%lat = gphit(ji,jj)
+                  newpt%xi  = REAL( mig(ji), wp )
+                  newpt%yj  = REAL( mjg(jj), wp )
+                  !
+                  newpt%uvel = 0._wp               ! initially at rest
+                  newpt%vvel = 0._wp
+                  !                                ! set berg characteristics
+                  newpt%mass           = rn_initial_mass     (jn)
+                  newpt%thickness      = rn_initial_thickness(jn)
+                  newpt%width          = first_width         (jn)
+                  newpt%length         = first_length        (jn)
+                  newberg%mass_scaling = rn_mass_scaling     (jn)
+                  newpt%mass_of_bits   = 0._wp                          ! no bergy
+                  !
+                  newpt%year   = nyear
+                  newpt%day    = zday
+                  newpt%heat_density = berg_grid%stored_heat(ji,jj) / berg_grid%stored_ice(ji,jj,jn)   ! This is in J/kg
+                  !
+                  CALL icb_utl_incr()
+                  newberg%number(:) = num_bergs(:)
+                  !
+                  CALL icb_utl_add( newberg, newpt )
+                  !
+                  zcalved_to_berg = rn_initial_mass(jn) * rn_mass_scaling(jn)           ! Units of kg
+                  !                                ! Heat content
+                  zheat_to_berg           = zcalved_to_berg * newpt%heat_density             ! Units of J
+                  berg_grid%stored_heat(ji,jj) = berg_grid%stored_heat(ji,jj) - zheat_to_berg
+                  !                                ! Stored mass
+                  berg_grid%stored_ice(ji,jj,jn) = berg_grid%stored_ice(ji,jj,jn) - zcalved_to_berg
+                  !
+                  icnt = icnt + 1
+                  !
+                  CALL icb_dia_calve(ji, jj, jn,  zcalved_to_berg, zheat_to_berg )
+               END DO
+               icntmax = MAX( icntmax, icnt )
+            END DO
+         END DO
+      END DO
+      !
+      DO jn = 1, nclasses
+         CALL lbc_lnk( berg_grid%stored_ice(:,:,jn), 'T', 1._wp )
+      END DO
+      CALL lbc_lnk( berg_grid%stored_heat, 'T', 1._wp )
+      !
+      IF( nn_verbose_level > 0 .AND. icntmax > 1 )   WRITE(numicb,*) 'icb_clv: icnt=', icnt,' on', narea
+      !
+   END SUBROUTINE  icb_clv
+
+   !!======================================================================
+END MODULE icbclv
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/ICB/icbdia.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/ICB/icbdia.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/ICB/icbdia.F90	(revision 9570)
@@ -0,0 +1,596 @@
+MODULE icbdia
+   !!======================================================================
+   !!                       ***  MODULE  icbdia  ***
+   !! Icebergs:  initialise variables for iceberg budgets and diagnostics
+   !!======================================================================
+   !! History : 3.3 !  2010-01  (Martin, Adcroft) Original code
+   !!            -  !  2011-03  (Madec)          Part conversion to NEMO form
+   !!            -  !                            Removal of mapping from another grid
+   !!            -  !  2011-04  (Alderson)       Split into separate modules
+   !!            -  !  2011-05  (Alderson)       Budgets are now all here with lots
+   !!            -  !                            of silly routines to call to get values in
+   !!            -  !                            from the right points in the code
+   !!----------------------------------------------------------------------
+ 
+   !!----------------------------------------------------------------------
+   !!   icb_dia_init  : initialise iceberg budgeting
+   !!   icb_dia       : global iceberg diagnostics
+   !!   icb_dia_step  : reset at the beginning of each timestep
+   !!   icb_dia_put   : output (via iom_put) iceberg fields
+   !!   icb_dia_calve : 
+   !!   icb_dia_income: 
+   !!   icb_dia_size  : 
+   !!   icb_dia_speed : 
+   !!   icb_dia_melt  : 
+   !!   report_state  : 
+   !!   report_consistant : 
+   !!   report_budget : 
+   !!   report_istate : 
+   !!   report_ibudget: 
+   !!----------------------------------------------------------------------
+   USE par_oce        ! ocean parameters
+   USE dom_oce        ! ocean domain
+   USE in_out_manager ! nemo IO
+   USE lib_mpp        ! MPP library
+   USE iom            ! I/O library
+   USE icb_oce        ! iceberg variables
+   USE icbutl         ! iceberg utility routines
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   icb_dia_init      ! routine called in icbini.F90 module
+   PUBLIC   icb_dia           ! routine called in icbstp.F90 module
+   PUBLIC   icb_dia_step      ! routine called in icbstp.F90 module
+   PUBLIC   icb_dia_put       ! routine called in icbstp.F90 module
+   PUBLIC   icb_dia_melt      ! routine called in icbthm.F90 module
+   PUBLIC   icb_dia_size      ! routine called in icbthm.F90 module
+   PUBLIC   icb_dia_speed     ! routine called in icbdyn.F90 module
+   PUBLIC   icb_dia_calve     ! routine called in icbclv.F90 module
+   PUBLIC   icb_dia_income    ! routine called in icbclv.F90 module
+
+   REAL(wp), DIMENSION(:,:)  , ALLOCATABLE, PUBLIC  ::   berg_melt       ! Melting+erosion rate of icebergs     [kg/s/m2]
+   REAL(wp), DIMENSION(:,:)  , ALLOCATABLE, PUBLIC  ::   buoy_melt       ! Buoyancy component of melting rate   [kg/s/m2]
+   REAL(wp), DIMENSION(:,:)  , ALLOCATABLE, PUBLIC  ::   eros_melt       ! Erosion component of melting rate    [kg/s/m2]
+   REAL(wp), DIMENSION(:,:)  , ALLOCATABLE, PUBLIC  ::   conv_melt       ! Convective component of melting rate [kg/s/m2]
+   REAL(wp), DIMENSION(:,:)  , ALLOCATABLE, PUBLIC  ::   bits_src        ! Mass flux from berg erosion into bergy bits [kg/s/m2]
+   REAL(wp), DIMENSION(:,:)  , ALLOCATABLE, PUBLIC  ::   bits_melt       ! Melting rate of bergy bits           [kg/s/m2]
+   REAL(wp), DIMENSION(:,:)  , ALLOCATABLE, PUBLIC  ::   bits_mass       ! Mass distribution of bergy bits      [kg/s/m2]
+   REAL(wp), DIMENSION(:,:)  , ALLOCATABLE, PUBLIC  ::   virtual_area    ! Virtual surface coverage by icebergs [m2]
+   REAL(wp), DIMENSION(:,:)  , ALLOCATABLE, PUBLIC  ::   berg_mass       ! Mass distribution                    [kg/m2]
+   REAL(wp), DIMENSION(:,:,:), ALLOCATABLE, PUBLIC  ::   real_calving    ! Calving rate into iceberg class at
+   !                                                                          ! calving locations                    [kg/s]
+   
+   REAL(wp), DIMENSION(:,:)  , ALLOCATABLE ::   tmpc                     ! Temporary work space
+   REAL(wp), DIMENSION(:)    , ALLOCATABLE ::   rsumbuf                  ! Temporary work space to reduce mpp exchanges
+   INTEGER , DIMENSION(:)    , ALLOCATABLE ::   nsumbuf                  ! Temporary work space to reduce mpp exchanges
+
+   REAL(wp)                      ::  berg_melt_net
+   REAL(wp)                      ::  bits_src_net
+   REAL(wp)                      ::  bits_melt_net
+   REAL(wp)                      ::  bits_mass_start     , bits_mass_end
+   REAL(wp)                      ::  floating_heat_start , floating_heat_end
+   REAL(wp)                      ::  floating_mass_start , floating_mass_end
+   REAL(wp)                      ::  bergs_mass_start    , bergs_mass_end
+   REAL(wp)                      ::  stored_start        , stored_heat_start
+   REAL(wp)                      ::  stored_end          , stored_heat_end
+   REAL(wp)                      ::  calving_src_net     , calving_out_net
+   REAL(wp)                      ::  calving_src_heat_net, calving_out_heat_net
+   REAL(wp)                      ::  calving_src_heat_used_net
+   REAL(wp)                      ::  calving_rcv_net  , calving_ret_net  , calving_used_net
+   REAL(wp)                      ::  heat_to_bergs_net, heat_to_ocean_net, melt_net
+   REAL(wp)                      ::  calving_to_bergs_net
+
+   INTEGER                       ::  nbergs_start, nbergs_end, nbergs_calved
+   INTEGER                       ::  nbergs_melted
+   INTEGER                       ::  nspeeding_tickets
+   INTEGER , DIMENSION(nclasses) ::  nbergs_calved_by_class
+
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO Consortium (2011)
+   !! $Id$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE icb_dia_init( )
+      !!----------------------------------------------------------------------
+      !!----------------------------------------------------------------------
+      !
+      IF( .NOT.ln_bergdia )   RETURN
+
+      ALLOCATE( berg_melt    (jpi,jpj)   )           ;   berg_melt   (:,:)   = 0._wp
+      ALLOCATE( buoy_melt    (jpi,jpj)   )           ;   buoy_melt   (:,:)   = 0._wp
+      ALLOCATE( eros_melt    (jpi,jpj)   )           ;   eros_melt   (:,:)   = 0._wp
+      ALLOCATE( conv_melt    (jpi,jpj)   )           ;   conv_melt   (:,:)   = 0._wp
+      ALLOCATE( bits_src     (jpi,jpj)   )           ;   bits_src    (:,:)   = 0._wp
+      ALLOCATE( bits_melt    (jpi,jpj)   )           ;   bits_melt   (:,:)   = 0._wp
+      ALLOCATE( bits_mass    (jpi,jpj)   )           ;   bits_mass   (:,:)   = 0._wp
+      ALLOCATE( virtual_area (jpi,jpj)   )           ;   virtual_area(:,:)   = 0._wp
+      ALLOCATE( berg_mass    (jpi,jpj)   )           ;   berg_mass   (:,:)   = 0._wp
+      ALLOCATE( real_calving (jpi,jpj,nclasses) )    ;   real_calving(:,:,:) = 0._wp
+      ALLOCATE( tmpc(jpi,jpj) )                      ;   tmpc        (:,:)   = 0._wp
+
+      nbergs_start              = 0
+      nbergs_end                = 0
+      stored_end                = 0._wp
+      nbergs_start              = 0._wp
+      stored_start              = 0._wp
+      nbergs_melted             = 0
+      nbergs_calved             = 0
+      nbergs_calved_by_class(:) = 0
+      nspeeding_tickets         = 0
+      stored_heat_end           = 0._wp
+      floating_heat_end         = 0._wp
+      floating_mass_end         = 0._wp
+      bergs_mass_end            = 0._wp
+      bits_mass_end             = 0._wp
+      stored_heat_start         = 0._wp
+      floating_heat_start       = 0._wp
+      floating_mass_start       = 0._wp
+      bergs_mass_start          = 0._wp
+      bits_mass_start           = 0._wp
+      bits_mass_end             = 0._wp
+      calving_used_net          = 0._wp
+      calving_to_bergs_net      = 0._wp
+      heat_to_bergs_net         = 0._wp
+      heat_to_ocean_net         = 0._wp
+      calving_rcv_net           = 0._wp
+      calving_ret_net           = 0._wp
+      calving_src_net           = 0._wp
+      calving_out_net           = 0._wp
+      calving_src_heat_net      = 0._wp
+      calving_src_heat_used_net = 0._wp
+      calving_out_heat_net      = 0._wp
+      melt_net                  = 0._wp
+      berg_melt_net             = 0._wp
+      bits_melt_net             = 0._wp
+      bits_src_net              = 0._wp
+
+      floating_mass_start       = icb_utl_mass( first_berg )
+      bergs_mass_start          = icb_utl_mass( first_berg, justbergs=.TRUE. )
+      bits_mass_start           = icb_utl_mass( first_berg, justbits =.TRUE. )
+      IF( lk_mpp ) THEN
+         ALLOCATE( rsumbuf(23) )          ; rsumbuf(:) = 0._wp
+         ALLOCATE( nsumbuf(4+nclasses) )  ; nsumbuf(:) = 0
+         rsumbuf(1) = floating_mass_start
+         rsumbuf(2) = bergs_mass_start
+         rsumbuf(3) = bits_mass_start
+         CALL mpp_sum( rsumbuf(1:3), 3 )
+         floating_mass_start = rsumbuf(1)
+         bergs_mass_start = rsumbuf(2)
+         bits_mass_start = rsumbuf(3)
+      ENDIF
+      !
+   END SUBROUTINE icb_dia_init
+
+
+   SUBROUTINE icb_dia( ld_budge )
+      !!----------------------------------------------------------------------
+      !! sum all the things we've accumulated so far in the current processor
+      !! in MPP case then add these sums across all processors
+      !! for this we pack variables into buffer so we only need one mpp_sum
+      !!----------------------------------------------------------------------
+      LOGICAL, INTENT(in) ::   ld_budge   !
+      !
+      INTEGER ::   ik
+      REAL(wp)::   zunused_calving, ztmpsum, zgrdd_berg_mass, zgrdd_bits_mass
+      !!----------------------------------------------------------------------
+      !
+      IF( .NOT.ln_bergdia )   RETURN
+
+      zunused_calving      = SUM( berg_grid%calving(:,:) )
+      ztmpsum              = SUM( berg_grid%floating_melt(:,:) * e1e2t(:,:) * tmask_i(:,:) )
+      melt_net             = melt_net + ztmpsum * berg_dt
+      calving_out_net      = calving_out_net + ( zunused_calving + ztmpsum ) * berg_dt
+      ztmpsum              = SUM( berg_melt(:,:) * e1e2t(:,:) * tmask_i(:,:) )
+      berg_melt_net        = berg_melt_net + ztmpsum * berg_dt
+      ztmpsum              = SUM( bits_src(:,:) * e1e2t(:,:) * tmask_i(:,:) )
+      bits_src_net         = bits_src_net + ztmpsum * berg_dt
+      ztmpsum              = SUM( bits_melt(:,:) * e1e2t(:,:) * tmask_i(:,:) )
+      bits_melt_net        = bits_melt_net + ztmpsum * berg_dt
+      ztmpsum              = SUM( src_calving(:,:) * tmask_i(:,:) )
+      calving_ret_net      = calving_ret_net + ztmpsum * berg_dt
+      ztmpsum              = SUM( berg_grid%calving_hflx(:,:) * e1e2t(:,:) * tmask_i(:,:) )
+      calving_out_heat_net = calving_out_heat_net + ztmpsum * berg_dt   ! Units of J
+      !
+      IF( ld_budge ) THEN
+         stored_end        = SUM( berg_grid%stored_ice(:,:,:) )
+         stored_heat_end   = SUM( berg_grid%stored_heat(:,:) )
+         floating_mass_end = icb_utl_mass( first_berg )
+         bergs_mass_end    = icb_utl_mass( first_berg,justbergs=.TRUE. )
+         bits_mass_end     = icb_utl_mass( first_berg,justbits =.TRUE. )
+         floating_heat_end = icb_utl_heat( first_berg )
+         !
+         nbergs_end        = icb_utl_count()
+         zgrdd_berg_mass   = SUM( berg_mass(:,:)*e1e2t(:,:)*tmask_i(:,:) )
+         zgrdd_bits_mass   = SUM( bits_mass(:,:)*e1e2t(:,:)*tmask_i(:,:) )
+         !
+         IF( lk_mpp ) THEN
+            rsumbuf( 1) = stored_end
+            rsumbuf( 2) = stored_heat_end
+            rsumbuf( 3) = floating_mass_end
+            rsumbuf( 4) = bergs_mass_end
+            rsumbuf( 5) = bits_mass_end
+            rsumbuf( 6) = floating_heat_end
+            rsumbuf( 7) = calving_ret_net
+            rsumbuf( 8) = calving_out_net
+            rsumbuf( 9) = calving_rcv_net
+            rsumbuf(10) = calving_src_net
+            rsumbuf(11) = calving_src_heat_net
+            rsumbuf(12) = calving_src_heat_used_net
+            rsumbuf(13) = calving_out_heat_net
+            rsumbuf(14) = calving_used_net
+            rsumbuf(15) = calving_to_bergs_net
+            rsumbuf(16) = heat_to_bergs_net
+            rsumbuf(17) = heat_to_ocean_net
+            rsumbuf(18) = melt_net
+            rsumbuf(19) = berg_melt_net
+            rsumbuf(20) = bits_src_net
+            rsumbuf(21) = bits_melt_net
+            rsumbuf(22) = zgrdd_berg_mass
+            rsumbuf(23) = zgrdd_bits_mass
+            !
+            CALL mpp_sum( rsumbuf(1:23), 23)
+            !
+            stored_end                = rsumbuf( 1)
+            stored_heat_end           = rsumbuf( 2)
+            floating_mass_end         = rsumbuf( 3)
+            bergs_mass_end            = rsumbuf( 4)
+            bits_mass_end             = rsumbuf( 5)
+            floating_heat_end         = rsumbuf( 6)
+            calving_ret_net           = rsumbuf( 7)
+            calving_out_net           = rsumbuf( 8)
+            calving_rcv_net           = rsumbuf( 9)
+            calving_src_net           = rsumbuf(10)
+            calving_src_heat_net      = rsumbuf(11)
+            calving_src_heat_used_net = rsumbuf(12)
+            calving_out_heat_net      = rsumbuf(13)
+            calving_used_net          = rsumbuf(14)
+            calving_to_bergs_net      = rsumbuf(15)
+            heat_to_bergs_net         = rsumbuf(16)
+            heat_to_ocean_net         = rsumbuf(17)
+            melt_net                  = rsumbuf(18)
+            berg_melt_net             = rsumbuf(19)
+            bits_src_net              = rsumbuf(20)
+            bits_melt_net             = rsumbuf(21)
+            zgrdd_berg_mass           = rsumbuf(22)
+            zgrdd_bits_mass           = rsumbuf(23)
+            !
+            nsumbuf(1) = nbergs_end
+            nsumbuf(2) = nbergs_calved
+            nsumbuf(3) = nbergs_melted
+            nsumbuf(4) = nspeeding_tickets
+            DO ik = 1, nclasses
+               nsumbuf(4+ik) = nbergs_calved_by_class(ik)
+            END DO
+            CALL mpp_sum( nsumbuf(1:nclasses+4), nclasses+4 )
+            !
+            nbergs_end        = nsumbuf(1)
+            nbergs_calved     = nsumbuf(2)
+            nbergs_melted     = nsumbuf(3)
+            nspeeding_tickets = nsumbuf(4)
+            DO ik = 1,nclasses
+               nbergs_calved_by_class(ik)= nsumbuf(4+ik)
+            END DO
+            !
+         ENDIF
+         !
+         CALL report_state  ( 'stored ice','kg','',stored_start,'',stored_end,'')
+         CALL report_state  ( 'floating','kg','',floating_mass_start,'',floating_mass_end,'',nbergs_end )
+         CALL report_state  ( 'icebergs','kg','',bergs_mass_start,'',bergs_mass_end,'')
+         CALL report_state  ( 'bits','kg','',bits_mass_start,'',bits_mass_end,'')
+         CALL report_istate ( 'berg #','',nbergs_start,'',nbergs_end,'')
+         CALL report_ibudget( 'berg #','calved',nbergs_calved, &
+            &                          'melted',nbergs_melted, &
+            &                          '#',nbergs_start,nbergs_end)
+         CALL report_budget( 'stored mass','kg','calving used',calving_used_net, &
+            &                              'bergs',calving_to_bergs_net, &
+            &                              'stored mass',stored_start,stored_end)
+         CALL report_budget( 'floating mass','kg','calving used',calving_to_bergs_net, &
+            &                                'bergs',melt_net, &
+            &                                'stored mass',floating_mass_start,floating_mass_end)
+         CALL report_budget( 'berg mass','kg','calving',calving_to_bergs_net, &
+            &                                 'melt+eros',berg_melt_net, &
+            &                                 'berg mass',bergs_mass_start,bergs_mass_end)
+         CALL report_budget( 'bits mass','kg','eros used',bits_src_net, &
+            &                                 'bergs',bits_melt_net, &
+            &                                 'stored mass',bits_mass_start,bits_mass_end)
+         CALL report_budget( 'net mass','kg','recvd',calving_rcv_net, &
+            &                                'rtrnd',calving_ret_net, &
+            &                                'net mass',stored_start+floating_mass_start, &
+            &                                           stored_end+floating_mass_end)
+         CALL report_consistant( 'iceberg mass','kg','gridded',zgrdd_berg_mass,'bergs',bergs_mass_end)
+         CALL report_consistant( 'bits mass','kg','gridded',zgrdd_bits_mass,'bits',bits_mass_end)
+         CALL report_state( 'net heat','J','',stored_heat_start+floating_heat_start,'', &
+            &                                 stored_heat_end+floating_heat_end,'')
+         CALL report_state( 'stored heat','J','',stored_heat_start,'',stored_heat_end,'')
+         CALL report_state( 'floating heat','J','',floating_heat_start,'',floating_heat_end,'')
+         CALL report_budget( 'net heat','J','net heat',calving_src_heat_net, &
+            &                               'net heat',calving_out_heat_net, &
+            &                               'net heat',stored_heat_start+floating_heat_start, &
+            &                                          stored_heat_end+floating_heat_end)
+         CALL report_budget( 'stored heat','J','calving used',calving_src_heat_used_net, &
+            &                                  'bergs',heat_to_bergs_net, &
+            &                                  'net heat',stored_heat_start,stored_heat_end)
+         CALL report_budget( 'flting heat','J','calved',heat_to_bergs_net, &
+            &                                  'melt',heat_to_ocean_net, &
+            &                                  'net heat',floating_heat_start,floating_heat_end)
+         IF (nn_verbose_level >= 1) THEN
+            CALL report_consistant( 'top interface','kg','from SIS',calving_src_net, &
+               &                    'received',calving_rcv_net)
+            CALL report_consistant( 'bot interface','kg','sent',calving_out_net, &
+               &                    'returned',calving_ret_net)
+         ENDIF
+         WRITE( numicb, '("calved by class = ",i6,20(",",i6))') (nbergs_calved_by_class(ik),ik=1,nclasses)
+         IF( nspeeding_tickets > 0 )   WRITE( numicb, '("speeding tickets issued = ",i6)') nspeeding_tickets
+         !
+         nbergs_start              = nbergs_end
+         stored_start              = stored_end
+         nbergs_melted             = 0
+         nbergs_calved             = 0
+         nbergs_calved_by_class(:) = 0
+         nspeeding_tickets         = 0
+         stored_heat_start         = stored_heat_end
+         floating_heat_start       = floating_heat_end
+         floating_mass_start       = floating_mass_end
+         bergs_mass_start          = bergs_mass_end
+         bits_mass_start           = bits_mass_end
+         calving_used_net          = 0._wp
+         calving_to_bergs_net      = 0._wp
+         heat_to_bergs_net         = 0._wp
+         heat_to_ocean_net         = 0._wp
+         calving_rcv_net           = 0._wp
+         calving_ret_net           = 0._wp
+         calving_src_net           = 0._wp
+         calving_out_net           = 0._wp
+         calving_src_heat_net      = 0._wp
+         calving_src_heat_used_net = 0._wp
+         calving_out_heat_net      = 0._wp
+         melt_net                  = 0._wp
+         berg_melt_net             = 0._wp
+         bits_melt_net             = 0._wp
+         bits_src_net              = 0._wp
+      ENDIF
+      !
+   END SUBROUTINE icb_dia
+
+
+   SUBROUTINE icb_dia_step
+      !!----------------------------------------------------------------------
+      !! things to reset at the beginning of each timestep
+      !!----------------------------------------------------------------------
+      !
+      IF( .NOT.ln_bergdia )   RETURN
+      berg_melt   (:,:)   = 0._wp
+      buoy_melt   (:,:)   = 0._wp
+      eros_melt   (:,:)   = 0._wp
+      conv_melt   (:,:)   = 0._wp
+      bits_src    (:,:)   = 0._wp
+      bits_melt   (:,:)   = 0._wp
+      bits_mass   (:,:)   = 0._wp
+      berg_mass   (:,:)   = 0._wp
+      virtual_area(:,:)   = 0._wp
+      real_calving(:,:,:) = 0._wp
+      !
+   END SUBROUTINE icb_dia_step
+
+
+   SUBROUTINE icb_dia_put
+      !!----------------------------------------------------------------------
+      !!----------------------------------------------------------------------
+      !
+      IF( .NOT.ln_bergdia )   RETURN            !!gm useless iom will control whether it is output or not
+      !
+      CALL iom_put( "berg_melt"        , berg_melt   (:,:)   )   ! Melt rate of icebergs                     [kg/m2/s]
+      CALL iom_put( "berg_buoy_melt"   , buoy_melt   (:,:)   )   ! Buoyancy component of iceberg melt rate   [kg/m2/s]
+      CALL iom_put( "berg_eros_melt"   , eros_melt   (:,:)   )   ! Erosion component of iceberg melt rate    [kg/m2/s]
+      CALL iom_put( "berg_conv_melt"   , conv_melt   (:,:)   )   ! Convective component of iceberg melt rate [kg/m2/s]
+      CALL iom_put( "berg_virtual_area", virtual_area(:,:)   )   ! Virtual coverage by icebergs              [m2]
+      CALL iom_put( "bits_src"         , bits_src    (:,:)   )   ! Mass source of bergy bits                 [kg/m2/s]
+      CALL iom_put( "bits_melt"        , bits_melt   (:,:)   )   ! Melt rate of bergy bits                   [kg/m2/s]
+      CALL iom_put( "bits_mass"        , bits_mass   (:,:)   )   ! Bergy bit density field                   [kg/m2]
+      CALL iom_put( "berg_mass"        , berg_mass   (:,:)   )   ! Iceberg density field                     [kg/m2]
+      CALL iom_put( "berg_real_calving", real_calving(:,:,:) )   ! Calving into iceberg class                [kg/s]
+      !
+   END SUBROUTINE icb_dia_put
+
+
+   SUBROUTINE icb_dia_calve( ki, kj, kn, pcalved, pheated )
+      !!----------------------------------------------------------------------
+      !!----------------------------------------------------------------------
+      INTEGER , INTENT(in)  ::   ki, kj, kn
+      REAL(wp), INTENT(in)  ::   pcalved
+      REAL(wp), INTENT(in)  ::   pheated
+      !!----------------------------------------------------------------------
+      !
+      IF( .NOT. ln_bergdia ) RETURN
+      real_calving(ki,kj,kn)     = real_calving(ki,kj,kn) + pcalved / berg_dt
+      nbergs_calved              = nbergs_calved              + 1
+      nbergs_calved_by_class(kn) = nbergs_calved_by_class(kn) + 1
+      calving_to_bergs_net       = calving_to_bergs_net + pcalved
+      heat_to_bergs_net          = heat_to_bergs_net    + pheated
+      !
+   END SUBROUTINE icb_dia_calve
+
+
+   SUBROUTINE icb_dia_income( kt,  pcalving_used, pheat_used )
+      !!----------------------------------------------------------------------
+      !!----------------------------------------------------------------------
+      INTEGER ,                 INTENT(in)  :: kt
+      REAL(wp),                 INTENT(in)  :: pcalving_used
+      REAL(wp), DIMENSION(:,:), INTENT(in)  :: pheat_used
+      !!----------------------------------------------------------------------
+      !
+      IF( .NOT.ln_bergdia )   RETURN
+      !
+      IF( kt == nit000 ) THEN
+         stored_start = SUM( berg_grid%stored_ice(:,:,:) )
+         IF( lk_mpp ) CALL mpp_sum( stored_start )
+         WRITE(numicb,'(a,es13.6,a)')   'icb_dia_income: initial stored mass=',stored_start,' kg'
+         !
+         stored_heat_start = SUM( berg_grid%stored_heat(:,:) )
+         IF( lk_mpp ) CALL mpp_sum( stored_heat_start )
+         WRITE(numicb,'(a,es13.6,a)')    'icb_dia_income: initial stored heat=',stored_heat_start,' J'
+      ENDIF
+      !
+      calving_rcv_net = calving_rcv_net + SUM( berg_grid%calving(:,:) ) * berg_dt
+      calving_src_net = calving_rcv_net
+      calving_src_heat_net = calving_src_heat_net +  &
+         &                      SUM( berg_grid%calving_hflx(:,:) * e1e2t(:,:) ) * berg_dt   ! Units of J
+      calving_used_net = calving_used_net + pcalving_used * berg_dt
+      calving_src_heat_used_net = calving_src_heat_used_net + SUM( pheat_used(:,:) )
+      !
+   END SUBROUTINE icb_dia_income
+
+
+   SUBROUTINE icb_dia_size(ki, kj, pWn, pLn, pAbits,   &
+      &                    pmass_scale, pMnew, pnMbits, pz1_e1e2)
+      !!----------------------------------------------------------------------
+      !!----------------------------------------------------------------------
+      INTEGER , INTENT(in) ::   ki, kj
+      REAL(wp), INTENT(in) ::   pWn, pLn, pAbits, pmass_scale, pMnew, pnMbits, pz1_e1e2
+      !!----------------------------------------------------------------------
+      !
+      IF( .NOT.ln_bergdia )   RETURN
+      virtual_area(ki,kj) = virtual_area(ki,kj) + ( pWn * pLn + pAbits ) * pmass_scale      ! m^2
+      berg_mass(ki,kj)    = berg_mass(ki,kj) + pMnew * pz1_e1e2                             ! kg/m2
+      bits_mass(ki,kj)    = bits_mass(ki,kj) + pnMbits * pz1_e1e2                           ! kg/m2
+      !
+   END SUBROUTINE icb_dia_size
+
+
+   SUBROUTINE icb_dia_speed()
+      !!----------------------------------------------------------------------
+      !!----------------------------------------------------------------------
+      !
+      IF( .NOT.ln_bergdia )   RETURN
+      nspeeding_tickets = nspeeding_tickets + 1
+      !
+   END SUBROUTINE icb_dia_speed
+
+
+   SUBROUTINE icb_dia_melt(ki, kj, pmnew, pheat, pmass_scale,     &
+      &                    pdM, pdMbitsE, pdMbitsM, pdMb, pdMe,   &
+      &                    pdMv, pz1_dt_e1e2 )
+      !!----------------------------------------------------------------------
+      !!----------------------------------------------------------------------
+      INTEGER , INTENT(in) ::   ki, kj
+      REAL(wp), INTENT(in) ::   pmnew, pheat, pmass_scale
+      REAL(wp), INTENT(in) ::   pdM, pdMbitsE, pdMbitsM, pdMb, pdMe, pdMv, pz1_dt_e1e2
+      !!----------------------------------------------------------------------
+      !
+      IF( .NOT.ln_bergdia )   RETURN
+      !
+      berg_melt (ki,kj) = berg_melt (ki,kj) + pdM      * pz1_dt_e1e2   ! kg/m2/s
+      bits_src  (ki,kj) = bits_src  (ki,kj) + pdMbitsE * pz1_dt_e1e2   ! mass flux into bergy bitskg/m2/s
+      bits_melt (ki,kj) = bits_melt (ki,kj) + pdMbitsM * pz1_dt_e1e2   ! melt rate of bergy bits kg/m2/s
+      buoy_melt (ki,kj) = buoy_melt (ki,kj) + pdMb     * pz1_dt_e1e2   ! kg/m2/s
+      eros_melt (ki,kj) = eros_melt (ki,kj) + pdMe     * pz1_dt_e1e2   ! erosion rate kg/m2/s
+      conv_melt (ki,kj) = conv_melt (ki,kj) + pdMv     * pz1_dt_e1e2   ! kg/m2/s
+      heat_to_ocean_net = heat_to_ocean_net + pheat * pmass_scale * berg_dt         ! J
+      IF( pmnew <= 0._wp ) nbergs_melted = nbergs_melted + 1                        ! Delete the berg if completely melted
+      !
+   END SUBROUTINE icb_dia_melt
+
+
+   SUBROUTINE report_state( cd_budgetstr, cd_budgetunits, cd_startstr, pstartval, cd_endstr,   &
+      &                     pendval, cd_delstr, kbergs )
+      !!----------------------------------------------------------------------
+      !!----------------------------------------------------------------------
+      CHARACTER*(*), INTENT(in)           :: cd_budgetstr, cd_budgetunits, cd_startstr, cd_endstr, cd_delstr
+      REAL(wp),      INTENT(in)           :: pstartval, pendval
+      INTEGER,       INTENT(in), OPTIONAL :: kbergs
+      !!----------------------------------------------------------------------
+      !
+      IF( PRESENT(kbergs) ) THEN
+         WRITE(numicb,100) cd_budgetstr // ' state:',                                    &
+            &              cd_startstr  // ' start',  pstartval,         cd_budgetunits, &
+            &              cd_endstr    // ' end',    pendval,           cd_budgetunits, &
+            &              'Delta '     // cd_delstr, pendval-pstartval, cd_budgetunits, &
+            &              '# of bergs', kbergs
+      ELSE
+         WRITE(numicb,100) cd_budgetstr // ' state:',                                   &
+            &              cd_startstr  // ' start', pstartval,         cd_budgetunits, &
+            &              cd_endstr    // ' end',   pendval,           cd_budgetunits, &
+            &              cd_delstr    // 'Delta',  pendval-pstartval, cd_budgetunits
+      ENDIF
+100   FORMAT(a19,3(a18,"=",es14.7,x,a2,:,","),a12,i8)
+      !
+   END SUBROUTINE report_state
+
+
+   SUBROUTINE report_consistant( cd_budgetstr, cd_budgetunits, cd_startstr, pstartval, cd_endstr, pendval)
+      !!----------------------------------------------------------------------
+      !!----------------------------------------------------------------------
+      CHARACTER*(*), INTENT(in) :: cd_budgetstr, cd_budgetunits, cd_startstr, cd_endstr
+      REAL(wp),      INTENT(in) :: pstartval, pendval
+      !!----------------------------------------------------------------------
+      !
+      WRITE(numicb,200) cd_budgetstr // ' check:',                 &
+         &              cd_startstr,    pstartval, cd_budgetunits, &
+         &              cd_endstr,      pendval,   cd_budgetunits, &
+         &              'error',        (pendval-pstartval)/((pendval+pstartval)+1e-30), 'nd'
+200   FORMAT(a19,10(a18,"=",es14.7,x,a2,:,","))
+      !
+   END SUBROUTINE report_consistant
+
+
+   SUBROUTINE report_budget( cd_budgetstr, cd_budgetunits, cd_instr, pinval, cd_outstr,   &
+      &                      poutval, cd_delstr, pstartval, pendval)
+      !!----------------------------------------------------------------------
+      !!----------------------------------------------------------------------
+      CHARACTER*(*), INTENT(in) :: cd_budgetstr, cd_budgetunits, cd_instr, cd_outstr, cd_delstr
+      REAL(wp),      INTENT(in) :: pinval, poutval, pstartval, pendval
+      !
+      REAL(wp) ::   zval
+      !!----------------------------------------------------------------------
+      !
+      zval = ( ( pendval - pstartval ) - ( pinval - poutval ) ) /   &
+         &   MAX( 1.e-30, MAX( ABS( pendval - pstartval ) , ABS( pinval - poutval ) ) )
+         !
+      WRITE(numicb,200) cd_budgetstr // ' budget:', &
+         &              cd_instr     // ' in',      pinval,         cd_budgetunits, &
+         &              cd_outstr    // ' out',     poutval,        cd_budgetunits, &
+         &              'Delta '     // cd_delstr,  pinval-poutval, cd_budgetunits, &
+         &              'error',        zval,                       'nd'
+  200 FORMAT(a19,3(a18,"=",es14.7,x,a2,:,","),a8,"=",es10.3,x,a2)
+      !
+   END SUBROUTINE report_budget
+
+
+   SUBROUTINE report_istate( cd_budgetstr, cd_startstr, pstartval, cd_endstr, pendval, cd_delstr)
+      !!----------------------------------------------------------------------
+      !!----------------------------------------------------------------------
+      CHARACTER*(*), INTENT(in) ::   cd_budgetstr, cd_startstr, cd_endstr, cd_delstr
+      INTEGER      , INTENT(in) ::   pstartval, pendval
+      !!----------------------------------------------------------------------
+      !
+      WRITE(numicb,100) cd_budgetstr // ' state:',           &
+         &              cd_startstr  // ' start', pstartval, &
+         &              cd_endstr    // ' end',   pendval,   &
+         &              cd_delstr    // 'Delta',  pendval-pstartval
+  100 FORMAT(a19,3(a18,"=",i14,x,:,","))
+      !
+   END SUBROUTINE report_istate
+
+
+   SUBROUTINE report_ibudget( cd_budgetstr, cd_instr, pinval, cd_outstr, poutval,   &
+      &                       cd_delstr, pstartval, pendval)
+      !!----------------------------------------------------------------------
+      !!----------------------------------------------------------------------
+      CHARACTER*(*), INTENT(in) :: cd_budgetstr, cd_instr, cd_outstr, cd_delstr
+      INTEGER,       INTENT(in) :: pinval, poutval, pstartval, pendval
+      !!----------------------------------------------------------------------
+      !
+      WRITE(numicb,200) cd_budgetstr // ' budget:', &
+         &              cd_instr     // ' in',      pinval, &
+         &              cd_outstr    // ' out',     poutval, &
+         &              'Delta '     // cd_delstr,  pinval-poutval, &
+         &              'error',                    ( ( pendval - pstartval ) - ( pinval - poutval ) )
+200   FORMAT(a19,10(a18,"=",i14,x,:,","))
+      !
+   END SUBROUTINE report_ibudget
+
+   !!======================================================================
+END MODULE icbdia
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/ICB/icbdyn.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/ICB/icbdyn.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/ICB/icbdyn.F90	(revision 9570)
@@ -0,0 +1,381 @@
+MODULE icbdyn
+   !!======================================================================
+   !!                       ***  MODULE  icbdyn  ***
+   !! Iceberg:  time stepping routine for iceberg tracking
+   !!======================================================================
+   !! History :  3.3  !  2010-01  (Martin&Adcroft)  Original code
+   !!             -   !  2011-03  (Madec)  Part conversion to NEMO form
+   !!             -   !                    Removal of mapping from another grid
+   !!             -   !  2011-04  (Alderson)  Split into separate modules
+   !!             -   !  2011-05  (Alderson)  Replace broken grounding routine with one of
+   !!             -   !                       Gurvan's suggestions (just like the broken one)
+   !!----------------------------------------------------------------------
+   USE par_oce        ! NEMO parameters
+   USE dom_oce        ! NEMO ocean domain
+   USE phycst         ! NEMO physical constants
+   !
+   USE icb_oce        ! define iceberg arrays
+   USE icbutl         ! iceberg utility routines
+   USE icbdia         ! iceberg budget routines
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   icb_dyn  ! routine called in icbstp.F90 module
+
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO Consortium (2011)
+   !! $Id$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE icb_dyn( kt )
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE icb_dyn  ***
+      !!
+      !! ** Purpose :   iceberg evolution.
+      !!
+      !! ** Method  : - See Martin & Adcroft, Ocean Modelling 34, 2010
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT(in) ::   kt   !
+      !
+      LOGICAL  ::   ll_bounced
+      REAL(wp) ::   zuvel1 , zvvel1 , zu1, zv1, zax1, zay1, zxi1 , zyj1
+      REAL(wp) ::   zuvel2 , zvvel2 , zu2, zv2, zax2, zay2, zxi2 , zyj2
+      REAL(wp) ::   zuvel3 , zvvel3 , zu3, zv3, zax3, zay3, zxi3 , zyj3
+      REAL(wp) ::   zuvel4 , zvvel4 , zu4, zv4, zax4, zay4, zxi4 , zyj4
+      REAL(wp) ::   zuvel_n, zvvel_n, zxi_n   , zyj_n
+      REAL(wp) ::   zdt, zdt_2, zdt_6, ze1, ze2
+      TYPE(iceberg), POINTER ::   berg
+      TYPE(point)  , POINTER ::   pt
+      !!----------------------------------------------------------------------
+      !
+      ! 4th order Runge-Kutta to solve:   d/dt X = V,  d/dt V = A
+      !                    with I.C.'s:   X=X1 and V=V1
+      !
+      !                                    ; A1=A(X1,V1)
+      !  X2 = X1+dt/2*V1 ; V2 = V1+dt/2*A1 ; A2=A(X2,V2)
+      !  X3 = X1+dt/2*V2 ; V3 = V1+dt/2*A2 ; A3=A(X3,V3)
+      !  X4 = X1+  dt*V3 ; V4 = V1+  dt*A3 ; A4=A(X4,V4)
+      !
+      !  Xn = X1+dt*(V1+2*V2+2*V3+V4)/6
+      !  Vn = V1+dt*(A1+2*A2+2*A3+A4)/6
+
+      ! time steps
+      zdt   = berg_dt
+      zdt_2 = zdt * 0.5_wp
+      zdt_6 = zdt / 6._wp
+
+      berg => first_berg                    ! start from the first berg
+      !
+      DO WHILE ( ASSOCIATED(berg) )          !==  loop over all bergs  ==!
+         !
+         pt => berg%current_point
+
+         ll_bounced = .FALSE.
+
+
+         ! STEP 1 !
+         ! ====== !
+         zxi1 = pt%xi   ;   zuvel1 = pt%uvel     !**   X1 in (i,j)  ;  V1 in m/s
+         zyj1 = pt%yj   ;   zvvel1 = pt%vvel
+
+
+         !                                         !**   A1 = A(X1,V1)
+         CALL icb_accel( berg , zxi1, ze1, zuvel1, zuvel1, zax1,     &
+            &                   zyj1, ze2, zvvel1, zvvel1, zay1, zdt_2 )
+         !
+         zu1 = zuvel1 / ze1                           !**   V1 in d(i,j)/dt
+         zv1 = zvvel1 / ze2
+
+         ! STEP 2 !
+         ! ====== !
+         !                                         !**   X2 = X1+dt/2*V1   ;   V2 = V1+dt/2*A1
+         ! position using di/dt & djdt   !   V2  in m/s
+         zxi2 = zxi1 + zdt_2 * zu1          ;   zuvel2 = zuvel1 + zdt_2 * zax1
+         zyj2 = zyj1 + zdt_2 * zv1          ;   zvvel2 = zvvel1 + zdt_2 * zay1
+         !
+         CALL icb_ground( zxi2, zxi1, zu1,   &
+            &             zyj2, zyj1, zv1, ll_bounced )
+
+         !                                         !**   A2 = A(X2,V2)
+         CALL icb_accel( berg , zxi2, ze1, zuvel2, zuvel1, zax2,    &
+            &                   zyj2, ze2, zvvel2, zvvel1, zay2, zdt_2 )
+         !
+         zu2 = zuvel2 / ze1                           !**   V2 in d(i,j)/dt
+         zv2 = zvvel2 / ze2
+         !
+         ! STEP 3 !
+         ! ====== !
+         !                                         !**  X3 = X1+dt/2*V2  ;   V3 = V1+dt/2*A2; A3=A(X3)
+         zxi3  = zxi1  + zdt_2 * zu2   ;   zuvel3 = zuvel1 + zdt_2 * zax2
+         zyj3  = zyj1  + zdt_2 * zv2   ;   zvvel3 = zvvel1 + zdt_2 * zay2
+         !
+         CALL icb_ground( zxi3, zxi1, zu3,   &
+            &                zyj3, zyj1, zv3, ll_bounced )
+
+         !                                         !**   A3 = A(X3,V3)
+         CALL icb_accel( berg , zxi3, ze1, zuvel3, zuvel1, zax3,    &
+            &                   zyj3, ze2, zvvel3, zvvel1, zay3, zdt )
+         !
+         zu3 = zuvel3 / ze1                           !**   V3 in d(i,j)/dt
+         zv3 = zvvel3 / ze2
+
+         ! STEP 4 !
+         ! ====== !
+         !                                         !**   X4 = X1+dt*V3   ;   V4 = V1+dt*A3
+         zxi4 = zxi1 + zdt * zu3   ;   zuvel4 = zuvel1 + zdt * zax3
+         zyj4 = zyj1 + zdt * zv3   ;   zvvel4 = zvvel1 + zdt * zay3
+
+         CALL icb_ground( zxi4, zxi1, zu4,   &
+            &             zyj4, zyj1, zv4, ll_bounced )
+
+         !                                         !**   A4 = A(X4,V4)
+         CALL icb_accel( berg , zxi4, ze1, zuvel4, zuvel1, zax4,    &
+            &                   zyj4, ze2, zvvel4, zvvel1, zay4, zdt )
+
+         zu4 = zuvel4 / ze1                           !**   V4 in d(i,j)/dt
+         zv4 = zvvel4 / ze2
+
+         ! FINAL STEP !
+         ! ========== !
+         !                                         !**   Xn = X1+dt*(V1+2*V2+2*V3+V4)/6
+         !                                         !**   Vn = V1+dt*(A1+2*A2+2*A3+A4)/6
+         zxi_n   = pt%xi   + zdt_6 * (  zu1  + 2.*(zu2  + zu3 ) + zu4  )
+         zyj_n   = pt%yj   + zdt_6 * (  zv1  + 2.*(zv2  + zv3 ) + zv4  )
+         zuvel_n = pt%uvel + zdt_6 * (  zax1 + 2.*(zax2 + zax3) + zax4 )
+         zvvel_n = pt%vvel + zdt_6 * (  zay1 + 2.*(zay2 + zay3) + zay4 )
+
+         CALL icb_ground( zxi_n, zxi1, zuvel_n,   &
+            &             zyj_n, zyj1, zvvel_n, ll_bounced )
+
+         pt%uvel = zuvel_n                        !** save in berg structure
+         pt%vvel = zvvel_n
+         pt%xi   = zxi_n
+         pt%yj   = zyj_n
+
+         ! update actual position
+         pt%lon  = icb_utl_bilin_x(glamt, pt%xi, pt%yj )
+         pt%lat  = icb_utl_bilin(gphit, pt%xi, pt%yj, 'T' )
+
+         berg => berg%next                         ! switch to the next berg
+         !
+      END DO                                  !==  end loop over all bergs  ==!
+      !
+   END SUBROUTINE icb_dyn
+
+
+   SUBROUTINE icb_ground( pi, pi0, pu,   &
+      &                   pj, pj0, pv, ld_bounced )
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE icb_ground  ***
+      !!
+      !! ** Purpose :   iceberg grounding.
+      !!
+      !! ** Method  : - adjust velocity and then put iceberg back to start position
+      !!                NB two possibilities available one of which is hard-coded here
+      !!----------------------------------------------------------------------
+      REAL(wp), INTENT(inout) ::   pi , pj      ! current iceberg position
+      REAL(wp), INTENT(in   ) ::   pi0, pj0     ! previous iceberg position
+      REAL(wp), INTENT(inout) ::   pu  , pv     ! current iceberg velocities
+      LOGICAL , INTENT(  out) ::   ld_bounced   ! bounced indicator
+      !
+      INTEGER  ::   ii, ii0
+      INTEGER  ::   ij, ij0
+      INTEGER  ::   ibounce_method
+      !!----------------------------------------------------------------------
+      !
+      ld_bounced = .FALSE.
+      !
+      ii0 = INT( pi0+0.5 )   ;   ij0 = INT( pj0+0.5 )       ! initial gridpoint position (T-cell)
+      ii  = INT( pi +0.5 )   ;   ij  = INT( pj +0.5 )       ! current     -         -
+      !
+      IF( ii == ii0  .AND.  ij == ij0  )   RETURN           ! berg remains in the same cell
+      !
+      ! map into current processor
+      ii0 = mi1( ii0 )
+      ij0 = mj1( ij0 )
+      ii  = mi1( ii  )
+      ij  = mj1( ij  )
+      !
+      IF(  tmask(ii,ij,1)  /=   0._wp  )   RETURN           ! berg reach a new t-cell, but an ocean one
+      !
+      ! From here, berg have reach land: treat grounding/bouncing
+      ! -------------------------------
+      ld_bounced = .TRUE.
+
+      !! not obvious what should happen now
+      !! if berg tries to enter a land box, the only location we can return it to is the start 
+      !! position (pi0,pj0), since it has to be in a wet box to do any melting;
+      !! first option is simply to set whole velocity to zero and move back to start point
+      !! second option (suggested by gm) is only to set the velocity component in the (i,j) direction
+      !! of travel to zero; at a coastal boundary this has the effect of sliding the berg along the coast
+
+      ibounce_method = 2
+      SELECT CASE ( ibounce_method )
+      CASE ( 1 )
+         pi = pi0
+         pj = pj0
+         pu = 0._wp
+         pv = 0._wp
+      CASE ( 2 )
+         IF( ii0 /= ii ) THEN
+            pi = pi0                   ! return back to the initial position
+            pu = 0._wp                 ! zeroing of velocity in the direction of the grounding
+         ENDIF
+         IF( ij0 /= ij ) THEN
+            pj = pj0                   ! return back to the initial position
+            pv = 0._wp                 ! zeroing of velocity in the direction of the grounding
+         ENDIF
+      END SELECT
+      !
+   END SUBROUTINE icb_ground
+
+
+   SUBROUTINE icb_accel( berg , pxi, pe1, puvel, puvel0, pax,                &
+      &                         pyj, pe2, pvvel, pvvel0, pay, pdt )
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE icb_accel  ***
+      !!
+      !! ** Purpose :   compute the iceberg acceleration.
+      !!
+      !! ** Method  : - sum the terms in the momentum budget
+      !!----------------------------------------------------------------------
+      TYPE(iceberg ), POINTER, INTENT(in   ) ::   berg             ! berg
+      REAL(wp)               , INTENT(in   ) ::   pxi   , pyj      ! berg position in (i,j) referential
+      REAL(wp)               , INTENT(in   ) ::   puvel , pvvel    ! berg velocity [m/s]
+      REAL(wp)               , INTENT(in   ) ::   puvel0, pvvel0   ! initial berg velocity [m/s]
+      REAL(wp)               , INTENT(  out) ::   pe1, pe2         ! horizontal scale factor at (xi,yj)
+      REAL(wp)               , INTENT(inout) ::   pax, pay         ! berg acceleration
+      REAL(wp)               , INTENT(in   ) ::   pdt              ! berg time step
+      !
+      REAL(wp), PARAMETER ::   pp_alpha     = 0._wp      !
+      REAL(wp), PARAMETER ::   pp_beta      = 1._wp      !
+      REAL(wp), PARAMETER ::   pp_vel_lim   =15._wp      ! max allowed berg speed
+      REAL(wp), PARAMETER ::   pp_accel_lim = 1.e-2_wp   ! max allowed berg acceleration
+      REAL(wp), PARAMETER ::   pp_Cr0       = 0.06_wp    !
+      !
+      INTEGER  ::   itloop
+      REAL(wp) ::   zuo, zui, zua, zuwave, zssh_x, zsst, zcn, zhi
+      REAL(wp) ::   zvo, zvi, zva, zvwave, zssh_y
+      REAL(wp) ::   zff, zT, zD, zW, zL, zM, zF
+      REAL(wp) ::   zdrag_ocn, zdrag_atm, zdrag_ice, zwave_rad
+      REAL(wp) ::   z_ocn, z_atm, z_ice
+      REAL(wp) ::   zampl, zwmod, zCr, zLwavelength, zLcutoff, zLtop
+      REAL(wp) ::   zlambda, zdetA, zA11, zA12, zaxe, zaye, zD_hi
+      REAL(wp) ::   zuveln, zvveln, zus, zvs, zspeed, zloc_dx, zspeed_new
+      !!----------------------------------------------------------------------
+
+      ! Interpolate gridded fields to berg
+      nknberg = berg%number(1)
+      CALL icb_utl_interp( pxi, pe1, zuo, zui, zua, zssh_x,                     &
+         &                 pyj, pe2, zvo, zvi, zva, zssh_y, zsst, zcn, zhi, zff )
+
+      zM = berg%current_point%mass
+      zT = berg%current_point%thickness               ! total thickness
+      zD = ( rn_rho_bergs / pp_rho_seawater ) * zT    ! draught (keel depth)
+      zF = zT - zD                                    ! freeboard
+      zW = berg%current_point%width
+      zL = berg%current_point%length
+
+      zhi   = MIN( zhi   , zD    )
+      zD_hi = MAX( 0._wp, zD-zhi )
+
+      ! Wave radiation
+      zuwave = zua - zuo   ;   zvwave = zva - zvo     ! Use wind speed rel. to ocean for wave model
+      zwmod  = zuwave*zuwave + zvwave*zvwave          ! The wave amplitude and length depend on the  current;
+      !                                               ! wind speed relative to the ocean. Actually wmod is wmod**2 here.
+      zampl        = 0.5 * 0.02025 * zwmod            ! This is "a", the wave amplitude
+      zLwavelength =       0.32    * zwmod            ! Surface wave length fitted to data in table at
+      !                                               ! http://www4.ncsu.edu/eos/users/c/ceknowle/public/chapter10/part2.html
+      zLcutoff     = 0.125 * zLwavelength
+      zLtop        = 0.25  * zLwavelength
+      zCr          = pp_Cr0 * MIN(  MAX( 0., (zL-zLcutoff) / ((zLtop-zLcutoff)+1.e-30)) , 1.)  ! Wave radiation coefficient
+      !                                               ! fitted to graph from Carrieres et al.,  POAC Drift Model.
+      zwave_rad    = 0.5 * pp_rho_seawater / zM * zCr * grav * zampl * MIN( zampl,zF ) * (2.*zW*zL) / (zW+zL)
+      zwmod        = SQRT( zua*zua + zva*zva )        ! Wind speed
+      IF( zwmod /= 0._wp ) THEN
+         zuwave = zua/zwmod   ! Wave radiation force acts in wind direction ...       !!gm  this should be the wind rel. to ocean ?
+         zvwave = zva/zwmod
+      ELSE
+         zuwave = 0.   ;    zvwave=0.   ;    zwave_rad=0. ! ... and only when wind is present.     !!gm  wave_rad=0. is useless
+      ENDIF
+
+      ! Weighted drag coefficients
+      z_ocn = pp_rho_seawater / zM * (0.5*pp_Cd_wv*zW*(zD_hi)+pp_Cd_wh*zW*zL)
+      z_atm = pp_rho_air      / zM * (0.5*pp_Cd_av*zW*zF     +pp_Cd_ah*zW*zL)
+      z_ice = pp_rho_ice      / zM * (0.5*pp_Cd_iv*zW*zhi              )
+      IF( abs(zui) + abs(zvi) == 0._wp )   z_ice = 0._wp
+
+      zuveln = puvel   ;   zvveln = pvvel ! Copy starting uvel, vvel
+      !
+      DO itloop = 1, 2  ! Iterate on drag coefficients
+         !
+         zus = 0.5 * ( zuveln + puvel )
+         zvs = 0.5 * ( zvveln + pvvel )
+         zdrag_ocn = z_ocn * SQRT( (zus-zuo)*(zus-zuo) + (zvs-zvo)*(zvs-zvo) )
+         zdrag_atm = z_atm * SQRT( (zus-zua)*(zus-zua) + (zvs-zva)*(zvs-zva) )
+         zdrag_ice = z_ice * SQRT( (zus-zui)*(zus-zui) + (zvs-zvi)*(zvs-zvi) )
+         !
+         ! Explicit accelerations
+         !zaxe= zff*pvvel -grav*zssh_x +zwave_rad*zuwave &
+         !    -zdrag_ocn*(puvel-zuo) -zdrag_atm*(puvel-zua) -zdrag_ice*(puvel-zui)
+         !zaye=-zff*puvel -grav*zssh_y +zwave_rad*zvwave &
+         !    -zdrag_ocn*(pvvel-zvo) -zdrag_atm*(pvvel-zva) -zdrag_ice*(pvvel-zvi)
+         zaxe = -grav * zssh_x + zwave_rad * zuwave
+         zaye = -grav * zssh_y + zwave_rad * zvwave
+         IF( pp_alpha > 0._wp ) THEN   ! If implicit, use time-level (n) rather than RK4 latest
+            zaxe = zaxe + zff*pvvel0
+            zaye = zaye - zff*puvel0
+         ELSE
+            zaxe = zaxe + zff*pvvel
+            zaye = zaye - zff*puvel
+         ENDIF
+         IF( pp_beta > 0._wp ) THEN    ! If implicit, use time-level (n) rather than RK4 latest
+            zaxe = zaxe - zdrag_ocn*(puvel0-zuo) - zdrag_atm*(puvel0-zua) -zdrag_ice*(puvel0-zui)
+            zaye = zaye - zdrag_ocn*(pvvel0-zvo) - zdrag_atm*(pvvel0-zva) -zdrag_ice*(pvvel0-zvi)
+         ELSE
+            zaxe = zaxe - zdrag_ocn*(puvel -zuo) - zdrag_atm*(puvel -zua) -zdrag_ice*(puvel -zui)
+            zaye = zaye - zdrag_ocn*(pvvel -zvo) - zdrag_atm*(pvvel -zva) -zdrag_ice*(pvvel -zvi)
+         ENDIF
+
+         ! Solve for implicit accelerations
+         IF( pp_alpha + pp_beta > 0._wp ) THEN
+            zlambda = zdrag_ocn + zdrag_atm + zdrag_ice
+            zA11    = 1._wp + pp_beta *pdt*zlambda
+            zA12    =         pp_alpha*pdt*zff
+            zdetA   = 1._wp / ( zA11*zA11 + zA12*zA12 )
+            pax     = zdetA * ( zA11*zaxe + zA12*zaye )
+            pay     = zdetA * ( zA11*zaye - zA12*zaxe )
+         ELSE
+            pax = zaxe   ;   pay = zaye
+         ENDIF
+
+         zuveln = puvel0 + pdt*pax
+         zvveln = pvvel0 + pdt*pay
+         !
+      END DO      ! itloop
+
+      IF( rn_speed_limit > 0._wp ) THEN       ! Limit speed of bergs based on a CFL criteria (if asked)
+         zspeed = SQRT( zuveln*zuveln + zvveln*zvveln )    ! Speed of berg
+         IF( zspeed > 0._wp ) THEN
+            zloc_dx = MIN( pe1, pe2 )                          ! minimum grid spacing
+            zspeed_new = zloc_dx / pdt * rn_speed_limit        ! Speed limit as a factor of dx / dt
+            IF( zspeed_new < zspeed ) THEN
+               zuveln = zuveln * ( zspeed_new / zspeed )        ! Scale velocity to reduce speed
+               zvveln = zvveln * ( zspeed_new / zspeed )        ! without changing the direction
+               CALL icb_dia_speed()
+            ENDIF
+         ENDIF
+      ENDIF
+      !                                      ! check the speed and acceleration limits
+      IF( ABS( zuveln ) > pp_vel_lim   .OR. ABS( zvveln ) > pp_vel_lim   )   &
+         WRITE(numicb,'("pe=",i3,x,a)') narea,'Dump triggered by excessive velocity'
+      IF( ABS( pax    ) > pp_accel_lim .OR. ABS( pay    ) > pp_accel_lim )   &
+         WRITE(numicb,'("pe=",i3,x,a)') narea,'Dump triggered by excessive acceleration'
+      !
+   END SUBROUTINE icb_accel
+
+   !!======================================================================
+END MODULE icbdyn
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/ICB/icbini.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/ICB/icbini.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/ICB/icbini.F90	(revision 9570)
@@ -0,0 +1,467 @@
+MODULE icbini
+   !!======================================================================
+   !!                       ***  MODULE  icbini  ***
+   !! Icebergs:  initialise variables for iceberg tracking
+   !!======================================================================
+   !! History :   -   !  2010-01  (T. Martin & A. Adcroft)  Original code
+   !!            3.3  !  2011-03  (G. Madec)  Part conversion to NEMO form ; Removal of mapping from another grid
+   !!             -   !  2011-04  (S. Alderson)  Split into separate modules ; Restore restart routines
+   !!             -   !  2011-05  (S. Alderson)  generate_test_icebergs restored ; new forcing arrays with extra halo ;
+   !!             -   !                          north fold exchange arrays added
+   !!----------------------------------------------------------------------
+   !!----------------------------------------------------------------------
+   !!   icb_init     : initialise icebergs
+   !!   icb_ini_gen  : generate test icebergs
+   !!   icb_nam      : read iceberg namelist
+   !!----------------------------------------------------------------------
+   USE dom_oce        ! ocean domain
+   USE in_out_manager ! IO routines and numout in particular
+   USE lib_mpp        ! mpi library and lk_mpp in particular
+   USE sbc_oce        ! ocean  : surface boundary condition
+   USE sbc_ice        ! sea-ice: surface boundary condition
+   USE iom            ! IOM library
+   USE fldread        ! field read
+   USE lbclnk         ! lateral boundary condition - MPP link
+   !
+   USE icb_oce        ! define iceberg arrays
+   USE icbutl         ! iceberg utility routines
+   USE icbrst         ! iceberg restart routines
+   USE icbtrj         ! iceberg trajectory I/O routines
+   USE icbdia         ! iceberg budget routines
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   icb_init  ! routine called in nemogcm.F90 module
+
+   CHARACTER(len=100)                                 ::   cn_dir = './'   !: Root directory for location of icb files
+   TYPE(FLD_N)                                        ::   sn_icb          !: information about the calving file to be read
+   TYPE(FLD), PUBLIC, ALLOCATABLE     , DIMENSION(:)  ::   sf_icb          !: structure: file information, fields read
+                                                                           !: used in icbini and icbstp
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO Consortium (2011)
+   !! $Id$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE icb_init( pdt, kt )
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE dom_init  ***
+      !!
+      !! ** Purpose :   iceberg initialization.
+      !!
+      !! ** Method  : - read the iceberg namelist
+      !!              - find non-overlapping processor interior since we can only
+      !!                have one instance of a particular iceberg
+      !!              - calculate the destinations for north fold exchanges
+      !!              - setup either test icebergs or calving file
+      !!----------------------------------------------------------------------
+      REAL(wp), INTENT(in) ::   pdt   ! iceberg time-step (rdt*nn_fsbc)
+      INTEGER , INTENT(in) ::   kt    ! time step number
+      !
+      INTEGER ::   ji, jj, jn               ! dummy loop indices
+      INTEGER ::   i1, i2, i3               ! local integers
+      INTEGER ::   ii, inum, ivar           !   -       -
+      INTEGER ::   istat1, istat2, istat3   !   -       -
+      CHARACTER(len=300) ::   cl_sdist      ! local character
+      !!----------------------------------------------------------------------
+      !
+      CALL icb_nam               ! Read and print namelist parameters
+      !
+      IF( .NOT. ln_icebergs )   RETURN
+
+      !                          ! allocate gridded fields
+      IF( icb_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'icb_alloc : unable to allocate arrays' )
+
+      !                          ! open ascii output file or files for iceberg status information
+      !                          ! note that we choose to do this on all processors since we cannot
+      !                          ! predict where icebergs will be ahead of time
+      CALL ctl_opn( numicb, 'icebergs.stat', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp, narea )
+
+      ! set parameters (mostly from namelist)
+      !
+      berg_dt         = pdt
+      first_width (:) = SQRT(  rn_initial_mass(:) / ( rn_LoW_ratio * rn_rho_bergs * rn_initial_thickness(:) )  )
+      first_length(:) = rn_LoW_ratio * first_width(:)
+
+      berg_grid%calving      (:,:)   = 0._wp
+      berg_grid%calving_hflx (:,:)   = 0._wp
+      berg_grid%stored_heat  (:,:)   = 0._wp
+      berg_grid%floating_melt(:,:)   = 0._wp
+      berg_grid%maxclass     (:,:)   = nclasses
+      berg_grid%stored_ice   (:,:,:) = 0._wp
+      berg_grid%tmp          (:,:)   = 0._wp
+      src_calving            (:,:)   = 0._wp
+      src_calving_hflx       (:,:)   = 0._wp
+
+      !                          ! domain for icebergs
+      IF( lk_mpp .AND. jpni == 1 )   CALL ctl_stop( 'icbinit: having ONE processor in x currently does not work' )
+      ! NB: the issue here is simply that cyclic east-west boundary condition have not been coded in mpp case
+      ! for the north fold we work out which points communicate by asking
+      ! lbc_lnk to pass processor number (valid even in single processor case)
+      ! borrow src_calving arrays for this
+      !
+      ! pack i and j together using a scaling of a power of 10
+      nicbpack = 10000
+      IF( jpiglo >= nicbpack )   CALL ctl_stop( 'icbini: processor index packing failure' )
+      nicbfldproc(:) = -1
+
+      DO jj = 1, jpj
+         DO ji = 1, jpi
+            src_calving_hflx(ji,jj) = narea
+            src_calving     (ji,jj) = nicbpack * mjg(jj) + mig(ji)
+         END DO
+      END DO
+      CALL lbc_lnk( src_calving_hflx, 'T', 1._wp )
+      CALL lbc_lnk( src_calving     , 'T', 1._wp )
+
+      ! work out interior of processor from exchange array
+      ! first entry with narea for this processor is left hand interior index
+      ! last  entry                               is right hand interior index
+      jj = nlcj/2
+      nicbdi = -1
+      nicbei = -1
+      DO ji = 1, jpi
+         i3 = INT( src_calving(ji,jj) )
+         i2 = INT( i3/nicbpack )
+         i1 = i3 - i2*nicbpack
+         i3 = INT( src_calving_hflx(ji,jj) )
+         IF( i1 == mig(ji) .AND. i3 == narea ) THEN
+            IF( nicbdi < 0 ) THEN   ;   nicbdi = ji
+            ELSE                    ;   nicbei = ji
+            ENDIF
+         ENDIF
+      END DO
+      !
+      ! repeat for j direction
+      ji = nlci/2
+      nicbdj = -1
+      nicbej = -1
+      DO jj = 1, jpj
+         i3 = INT( src_calving(ji,jj) )
+         i2 = INT( i3/nicbpack )
+         i1 = i3 - i2*nicbpack
+         i3 = INT( src_calving_hflx(ji,jj) )
+         IF( i2 == mjg(jj) .AND. i3 == narea ) THEN
+            IF( nicbdj < 0 ) THEN   ;   nicbdj = jj
+            ELSE                    ;   nicbej = jj
+            ENDIF
+         ENDIF
+      END DO
+      !   
+      ! special for east-west boundary exchange we save the destination index
+      i1 = MAX( nicbdi-1, 1)
+      i3 = INT( src_calving(i1,nlcj/2) )
+      jj = INT( i3/nicbpack )
+      ricb_left = REAL( i3 - nicbpack*jj, wp )
+      i1 = MIN( nicbei+1, jpi )
+      i3 = INT( src_calving(i1,nlcj/2) )
+      jj = INT( i3/nicbpack )
+      ricb_right = REAL( i3 - nicbpack*jj, wp )
+      
+      ! north fold
+      IF( npolj > 0 ) THEN
+         !
+         ! icebergs in row nicbej+1 get passed across fold
+         nicbfldpts(:)  = INT( src_calving(:,nicbej+1) )
+         nicbflddest(:) = INT( src_calving_hflx(:,nicbej+1) )
+         !
+         ! work out list of unique processors to talk to
+         ! pack them into a fixed size array where empty slots are marked by a -1
+         DO ji = nicbdi, nicbei
+            ii = nicbflddest(ji)
+            IF( ii .GT. 0 ) THEN     ! Needed because land suppression can mean
+                                     ! that unused points are not set in edge haloes
+               DO jn = 1, jpni
+                  ! work along array until we find an empty slot
+                  IF( nicbfldproc(jn) == -1 ) THEN
+                     nicbfldproc(jn) = ii
+                     EXIT                             !!gm EXIT should be avoided: use DO WHILE expression instead
+                  ENDIF
+                  ! before we find an empty slot, we may find processor number is already here so we exit
+                  IF( nicbfldproc(jn) == ii ) EXIT
+               END DO
+            ENDIF
+         END DO
+      ENDIF
+      !
+      IF( nn_verbose_level > 0) THEN
+         WRITE(numicb,*) 'processor ', narea
+         WRITE(numicb,*) 'jpi, jpj   ', jpi, jpj
+         WRITE(numicb,*) 'nldi, nlei ', nldi, nlei
+         WRITE(numicb,*) 'nldj, nlej ', nldj, nlej
+         WRITE(numicb,*) 'berg i interior ', nicbdi, nicbei
+         WRITE(numicb,*) 'berg j interior ', nicbdj, nicbej
+         WRITE(numicb,*) 'berg left       ', ricb_left
+         WRITE(numicb,*) 'berg right      ', ricb_right
+         jj = nlcj/2
+         WRITE(numicb,*) "central j line:"
+         WRITE(numicb,*) "i processor"
+         WRITE(numicb,*) (INT(src_calving_hflx(ji,jj)), ji=1,jpi)
+         WRITE(numicb,*) "i point"
+         WRITE(numicb,*) (INT(src_calving(ji,jj)), ji=1,jpi)
+         ji = nlci/2
+         WRITE(numicb,*) "central i line:"
+         WRITE(numicb,*) "j processor"
+         WRITE(numicb,*) (INT(src_calving_hflx(ji,jj)), jj=1,jpj)
+         WRITE(numicb,*) "j point"
+         WRITE(numicb,*) (INT(src_calving(ji,jj)), jj=1,jpj)
+         IF( npolj > 0 ) THEN
+            WRITE(numicb,*) 'north fold destination points '
+            WRITE(numicb,*) nicbfldpts
+            WRITE(numicb,*) 'north fold destination procs  '
+            WRITE(numicb,*) nicbflddest
+            WRITE(numicb,*) 'north fold destination proclist  '
+            WRITE(numicb,*) nicbfldproc
+         ENDIF
+         CALL flush(numicb)
+      ENDIF
+      
+      src_calving     (:,:) = 0._wp
+      src_calving_hflx(:,:) = 0._wp
+
+      ! assign each new iceberg with a unique number constructed from the processor number
+      ! and incremented by the total number of processors
+      num_bergs(:) = 0
+      num_bergs(1) = narea - jpnij
+
+      ! when not generating test icebergs we need to setup calving file
+      IF( nn_test_icebergs < 0 ) THEN
+         !
+         ! maximum distribution class array does not change in time so read it once
+         cl_sdist = TRIM( cn_dir )//TRIM( sn_icb%clname )
+         CALL iom_open ( cl_sdist, inum )                              ! open file
+         ivar = iom_varid( inum, 'maxclass', ldstop=.FALSE. )
+         IF( ivar > 0 ) THEN
+            CALL iom_get  ( inum, jpdom_data, 'maxclass', src_calving )   ! read the max distribution array
+            berg_grid%maxclass(:,:) = INT( src_calving )
+            src_calving(:,:) = 0._wp
+         ENDIF
+         CALL iom_close( inum )                                     ! close file
+         !
+         WRITE(numicb,*)
+         WRITE(numicb,*) '          calving read in a file'
+         ALLOCATE( sf_icb(1), STAT=istat1 )         ! Create sf_icb structure (calving)
+         ALLOCATE( sf_icb(1)%fnow(jpi,jpj,1), STAT=istat2 )
+         ALLOCATE( sf_icb(1)%fdta(jpi,jpj,1,2), STAT=istat3 )
+         IF( istat1+istat2+istat3 > 0 ) THEN
+            CALL ctl_stop( 'sbc_icb: unable to allocate sf_icb structure' )   ;   RETURN
+         ENDIF
+         !                                          ! fill sf_icb with the namelist (sn_icb) and control print
+         CALL fld_fill( sf_icb, (/ sn_icb /), cn_dir, 'icb_init', 'read calving data', 'namicb' )
+         !
+      ENDIF
+
+      IF( .NOT.ln_rstart ) THEN
+         IF( nn_test_icebergs > 0 )   CALL icb_ini_gen()
+      ELSE
+         IF( nn_test_icebergs > 0 ) THEN
+            CALL icb_ini_gen()
+         ELSE
+            CALL icb_rst_read()
+            l_restarted_bergs = .TRUE.
+         ENDIF
+      ENDIF
+      !
+      IF( nn_sample_rate .GT. 0 ) CALL icb_trj_init( nitend )
+      !
+      CALL icb_dia_init()
+      !
+      IF( nn_verbose_level >= 2 )   CALL icb_utl_print('icb_init, initial status', nit000-1)
+      !
+   END SUBROUTINE icb_init
+
+
+   SUBROUTINE icb_ini_gen()
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE icb_ini_gen  ***
+      !!
+      !! ** Purpose :   iceberg generation
+      !!
+      !! ** Method  : - at each grid point of the test box supplied in the namelist
+      !!                generate an iceberg in one class determined by the value of
+      !!                parameter nn_test_icebergs
+      !!----------------------------------------------------------------------
+      INTEGER                         ::   ji, jj, ibergs
+      TYPE(iceberg)                   ::   localberg ! NOT a pointer but an actual local variable
+      TYPE(point)                     ::   localpt
+      INTEGER                         ::   iyr, imon, iday, ihr, imin, isec
+      INTEGER                         ::   iberg
+      !!----------------------------------------------------------------------
+
+      ! For convenience
+      iberg = nn_test_icebergs
+
+      ! call get_date(Time, iyr, imon, iday, ihr, imin, isec)
+      ! Convert nemo time variables from dom_oce into local versions
+      iyr  = nyear
+      imon = nmonth
+      iday = nday
+      ihr = INT(nsec_day/3600)
+      imin = INT((nsec_day-ihr*3600)/60)
+      isec = nsec_day - ihr*3600 - imin*60
+
+      ! no overlap for icebergs since we want only one instance of each across the whole domain
+      ! so restrict area of interest
+      ! use tmask here because tmask_i has been doctored on one side of the north fold line
+
+      DO jj = nicbdj, nicbej
+         DO ji = nicbdi, nicbei
+            IF( tmask(ji,jj,1) > 0._wp        .AND.                                       &
+                rn_test_box(1) < glamt(ji,jj) .AND. glamt(ji,jj) < rn_test_box(2) .AND.   &
+                rn_test_box(3) < gphit(ji,jj) .AND. gphit(ji,jj) < rn_test_box(4) ) THEN
+               localberg%mass_scaling = rn_mass_scaling(iberg)
+               localpt%xi = REAL( mig(ji), wp )
+               localpt%yj = REAL( mjg(jj), wp )
+               localpt%lon = icb_utl_bilin(glamt, localpt%xi, localpt%yj, 'T' )
+               localpt%lat = icb_utl_bilin(gphit, localpt%xi, localpt%yj, 'T' )
+               localpt%mass      = rn_initial_mass     (iberg)
+               localpt%thickness = rn_initial_thickness(iberg)
+               localpt%width  = first_width (iberg)
+               localpt%length = first_length(iberg)
+               localpt%year = iyr
+               localpt%day = REAL(iday,wp)+(REAL(ihr,wp)+REAL(imin,wp)/60._wp)/24._wp
+               localpt%mass_of_bits = 0._wp
+               localpt%heat_density = 0._wp
+               localpt%uvel = 0._wp
+               localpt%vvel = 0._wp
+               CALL icb_utl_incr()
+               localberg%number(:) = num_bergs(:)
+               call icb_utl_add(localberg, localpt)
+            ENDIF
+         END DO
+      END DO
+      !
+      ibergs = icb_utl_count()
+      IF( lk_mpp ) CALL mpp_sum(ibergs)
+      WRITE(numicb,'(a,i6,a)') 'diamonds, icb_ini_gen: ',ibergs,' were generated'
+      !
+   END SUBROUTINE icb_ini_gen
+
+
+   SUBROUTINE icb_nam
+      !!----------------------------------------------------------------------
+      !!                     ***  ROUTINE icb_nam  ***
+      !!
+      !! ** Purpose :   read iceberg namelist and print the variables.
+      !!
+      !! ** input   : - namberg namelist
+      !!----------------------------------------------------------------------
+      INTEGER  ::   jn      ! dummy loop indices
+      INTEGER  ::   ios     ! Local integer output status for namelist read
+      REAL(wp) ::   zfact   ! local scalar
+      !
+      NAMELIST/namberg/ ln_icebergs    , ln_bergdia     , nn_sample_rate      , rn_initial_mass      ,   &
+         &              rn_distribution, rn_mass_scaling, rn_initial_thickness, nn_verbose_write     ,   &
+         &              rn_rho_bergs   , rn_LoW_ratio   , nn_verbose_level    , ln_operator_splitting,   &
+         &              rn_bits_erosion_fraction        , rn_sicn_shift       , ln_passive_mode      ,   &
+         &              ln_time_average_weight          , nn_test_icebergs    , rn_test_box          ,   &
+         &              rn_speed_limit , cn_dir, sn_icb
+      !!----------------------------------------------------------------------
+
+#if defined key_agrif
+      IF(lwp) THEN
+         WRITE(numout,*)
+         WRITE(numout,*) 'icb_nam : AGRIF is not compatible with namelist namberg :  '
+         WRITE(numout,*) '~~~~~~~   definition of rn_initial_mass(nclasses) with nclasses as PARAMETER '
+         WRITE(numout,*)
+         WRITE(numout,*) '   ==>>>   force  NO icebergs used. The namelist namberg is not read'
+      ENDIF
+      ln_icebergs = .false.      
+      RETURN
+#else
+      IF(lwp) THEN
+         WRITE(numout,*)
+         WRITE(numout,*) 'icb_nam : iceberg initialization through namberg namelist read'
+         WRITE(numout,*) '~~~~~~~~ '
+      ENDIF
+#endif   
+      !                             !==  read namelist  ==!
+      REWIND( numnam_ref )              ! Namelist namberg in reference namelist : Iceberg parameters
+      READ  ( numnam_ref, namberg, IOSTAT = ios, ERR = 901)
+901   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namberg in reference namelist', lwp )
+      REWIND( numnam_cfg )              ! Namelist namberg in configuration namelist : Iceberg parameters
+      READ  ( numnam_cfg, namberg, IOSTAT = ios, ERR = 902 )
+902   IF( ios >  0 ) CALL ctl_nam ( ios , 'namberg in configuration namelist', lwp )
+      IF(lwm) WRITE ( numond, namberg )
+      !
+      IF(lwp) WRITE(numout,*)
+      IF( ln_icebergs ) THEN
+         IF(lwp) WRITE(numout,*) '   ==>>>   icebergs are used'
+      ELSE
+         IF(lwp) WRITE(numout,*) '   ==>>>   No icebergs used'
+         RETURN
+      ENDIF
+      !
+      IF( nn_test_icebergs > nclasses ) THEN
+         IF(lwp) WRITE(numout,*)
+         IF(lwp) WRITE(numout,*) '   ==>>>   Resetting of nn_test_icebergs to ', nclasses
+         nn_test_icebergs = nclasses
+      ENDIF
+      !
+      IF(lwp) THEN                  ! control print
+         WRITE(numout,*)
+         WRITE(numout,*) 'icb_nam : iceberg initialization through namberg namelist read'
+         WRITE(numout,*) '~~~~~~~~ '
+         WRITE(numout,*) '   Calculate budgets                                            ln_bergdia       = ', ln_bergdia
+         WRITE(numout,*) '   Period between sampling of position for trajectory storage   nn_sample_rate = ', nn_sample_rate
+         WRITE(numout,*) '   Mass thresholds between iceberg classes (kg)                 rn_initial_mass     ='
+         DO jn = 1, nclasses
+            WRITE(numout,'(a,f15.2)') '                                                                ', rn_initial_mass(jn)
+         ENDDO
+         WRITE(numout,*) '   Fraction of calving to apply to this class (non-dim)         rn_distribution     ='
+         DO jn = 1, nclasses
+            WRITE(numout,'(a,f10.4)') '                                                                ', rn_distribution(jn)
+         END DO
+         WRITE(numout,*) '   Ratio between effective and real iceberg mass (non-dim)      rn_mass_scaling     = '
+         DO jn = 1, nclasses
+            WRITE(numout,'(a,f10.2)') '                                                                ', rn_mass_scaling(jn)
+         END DO
+         WRITE(numout,*) '   Total thickness of newly calved bergs (m)                    rn_initial_thickness = '
+         DO jn = 1, nclasses
+            WRITE(numout,'(a,f10.2)') '                                                                ', rn_initial_thickness(jn)
+         END DO
+         WRITE(numout,*) '   Timesteps between verbose messages                           nn_verbose_write    = ', nn_verbose_write
+
+         WRITE(numout,*) '   Density of icebergs                           rn_rho_bergs  = ', rn_rho_bergs
+         WRITE(numout,*) '   Initial ratio L/W for newly calved icebergs   rn_LoW_ratio  = ', rn_LoW_ratio
+         WRITE(numout,*) '   Turn on more verbose output                          level  = ', nn_verbose_level
+         WRITE(numout,*) '   Use first order operator splitting for thermodynamics    ',   &
+            &                    'use_operator_splitting = ', ln_operator_splitting
+         WRITE(numout,*) '   Fraction of erosion melt flux to divert to bergy bits    ',   &
+            &                    'bits_erosion_fraction = ', rn_bits_erosion_fraction
+
+         WRITE(numout,*) '   Shift of sea-ice concentration in erosion flux modulation ',   &
+            &                    '(0<sicn_shift<1)    rn_sicn_shift  = ', rn_sicn_shift
+         WRITE(numout,*) '   Do not add freshwater flux from icebergs to ocean                ',   &
+            &                    '                  passive_mode            = ', ln_passive_mode
+         WRITE(numout,*) '   Time average the weight on the ocean   time_average_weight       = ', ln_time_average_weight
+         WRITE(numout,*) '   Create icebergs in absence of a restart file   nn_test_icebergs  = ', nn_test_icebergs
+         WRITE(numout,*) '                   in lon/lat box                                   = ', rn_test_box
+         WRITE(numout,*) '   CFL speed limit for a berg            speed_limit                = ', rn_speed_limit
+         WRITE(numout,*) '   Writing Iceberg status information to icebergs.stat file        '
+      ENDIF
+      !
+      ! ensure that the sum of berg input distribution is equal to one
+      zfact = SUM( rn_distribution )
+      IF( zfact /= 1._wp .AND. 0_wp /= zfact ) THEN
+         rn_distribution(:) = rn_distribution(:) / zfact
+         IF(lwp) THEN
+            WRITE(numout,*)
+            WRITE(numout,*) '      ==>>> CAUTION:    sum of berg input distribution = ', zfact
+            WRITE(numout,*) '            *******     redistribution has been rescaled'
+            WRITE(numout,*) '                        updated berg distribution is :'
+            DO jn = 1, nclasses
+               WRITE(numout,'(a,f10.4)') '                                   ',rn_distribution(jn)
+            END DO
+         ENDIF
+      ENDIF
+      IF( MINVAL( rn_distribution(:) ) < 0._wp ) THEN
+         CALL ctl_stop( 'icb_nam: a negative rn_distribution value encountered ==>> change your namelist namberg' )
+      ENDIF
+      !
+   END SUBROUTINE icb_nam
+
+   !!======================================================================
+END MODULE icbini
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/ICB/icblbc.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/ICB/icblbc.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/ICB/icblbc.F90	(revision 9570)
@@ -0,0 +1,929 @@
+MODULE icblbc
+   !!======================================================================
+   !!                       ***  MODULE  icblbc  ***
+   !! Ocean physics:  routines to handle boundary exchanges for icebergs
+   !!======================================================================
+   !! History :  3.3  !  2010-01  (Martin&Adcroft) Original code
+   !!             -   !  2011-03  (Madec)          Part conversion to NEMO form
+   !!             -   !                            Removal of mapping from another grid
+   !!             -   !  2011-04  (Alderson)       Split into separate modules
+   !!             -   !  2011-05  (Alderson)       MPP exchanges written based on lib_mpp
+   !!             -   !  2011-05  (Alderson)       MPP and single processor boundary conditions added
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   icb_lbc       : -  Pass icebergs across cyclic boundaries
+   !!   icb_lbc_mpp   : -  In MPP pass icebergs from linked list between processors
+   !!                      as they advect around
+   !!                   -  Lagrangian processes cannot be handled by existing NEMO MPP
+   !!                      routines because they do not lie on regular jpi,jpj grids
+   !!                   -  Processor exchanges are handled as in lib_mpp whenever icebergs step 
+   !!                      across boundary of interior domain (nicbdi-nicbei, nicbdj-nicbej)
+   !!                      so that iceberg does not exist in more than one processor
+   !!                   -  North fold exchanges controlled by three arrays:
+   !!                         nicbflddest - unique processor numbers that current one exchanges with
+   !!                         nicbfldproc - processor number that current grid point exchanges with
+   !!                         nicbfldpts  - packed i,j point in exchanging processor
+   !!----------------------------------------------------------------------
+   USE par_oce                             ! ocean parameters
+   USE dom_oce                             ! ocean domain
+   USE in_out_manager                      ! IO parameters
+   USE lib_mpp                             ! MPI code and lk_mpp in particular
+   USE icb_oce                             ! define iceberg arrays
+   USE icbutl                              ! iceberg utility routines
+
+   IMPLICIT NONE
+   PRIVATE
+
+#if defined key_mpp_mpi
+
+!$AGRIF_DO_NOT_TREAT
+   INCLUDE 'mpif.h'
+!$AGRIF_END_DO_NOT_TREAT
+
+   TYPE, PUBLIC :: buffer
+      INTEGER :: size = 0
+      REAL(wp), DIMENSION(:,:), POINTER ::   data
+   END TYPE buffer
+
+   TYPE(buffer), POINTER       ::   obuffer_n=>NULL() , ibuffer_n=>NULL()
+   TYPE(buffer), POINTER       ::   obuffer_s=>NULL() , ibuffer_s=>NULL()
+   TYPE(buffer), POINTER       ::   obuffer_e=>NULL() , ibuffer_e=>NULL()
+   TYPE(buffer), POINTER       ::   obuffer_w=>NULL() , ibuffer_w=>NULL()
+
+   ! north fold exchange buffers
+   TYPE(buffer), POINTER       ::   obuffer_f=>NULL() , ibuffer_f=>NULL()
+
+   INTEGER, PARAMETER, PRIVATE ::   jp_delta_buf = 25             ! Size by which to increment buffers
+   INTEGER, PARAMETER, PRIVATE ::   jp_buffer_width = 15+nkounts  ! items to store for each berg
+
+#endif
+
+   PUBLIC   icb_lbc
+   PUBLIC   icb_lbc_mpp
+
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO Consortium (2011)
+   !! $Id$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE icb_lbc()
+      !!----------------------------------------------------------------------
+      !!                 ***  SUBROUTINE icb_lbc  ***
+      !!
+      !! ** Purpose :   in non-mpp case need to deal with cyclic conditions
+      !!                including north-fold
+      !!----------------------------------------------------------------------
+      TYPE(iceberg), POINTER ::   this
+      TYPE(point)  , POINTER ::   pt
+      INTEGER                ::   iine
+      !!----------------------------------------------------------------------
+
+      !! periodic east/west boundaries
+      !! =============================
+
+      IF( nperio == 1 .OR. nperio == 4 .OR. nperio == 6 ) THEN
+
+         this => first_berg
+         DO WHILE( ASSOCIATED(this) )
+            pt => this%current_point
+            iine = INT( pt%xi + 0.5 )
+            IF( iine > mig(nicbei) ) THEN
+               pt%xi = ricb_right + MOD(pt%xi, 1._wp ) - 1._wp
+            ELSE IF( iine < mig(nicbdi) ) THEN
+               pt%xi = ricb_left + MOD(pt%xi, 1._wp )
+            ENDIF
+            this => this%next
+         END DO
+         !
+      ENDIF
+
+      !! north/south boundaries
+      !! ======================
+      ! south symmetric
+      IF( nperio == 2 )   CALL ctl_stop(' south symmetric condition not implemented for icebergs')
+      ! north fold
+      IF( nperio == 3 .OR. nperio == 4 .OR. nperio == 5 .OR. nperio == 6 )   CALL icb_lbc_nfld()
+      !
+   END SUBROUTINE icb_lbc
+
+
+   SUBROUTINE icb_lbc_nfld()
+      !!----------------------------------------------------------------------
+      !!                 ***  SUBROUTINE icb_lbc_nfld  ***
+      !!
+      !! ** Purpose :   single processor north fold exchange
+      !!----------------------------------------------------------------------
+      TYPE(iceberg), POINTER ::   this
+      TYPE(point)  , POINTER ::   pt
+      INTEGER                ::   iine, ijne, ipts
+      INTEGER                ::   iiglo, ijglo
+      !!----------------------------------------------------------------------
+      !
+      this => first_berg
+      DO WHILE( ASSOCIATED(this) )
+         pt => this%current_point
+         ijne = INT( pt%yj + 0.5 )
+         IF( ijne .GT. mjg(nicbej) ) THEN
+            !
+            iine = INT( pt%xi + 0.5 )
+            ipts  = nicbfldpts (mi1(iine))
+            !
+            ! moving across the cut line means both position and
+            ! velocity must change
+            ijglo = INT( ipts/nicbpack )
+            iiglo = ipts - nicbpack*ijglo
+            pt%xi = iiglo - ( pt%xi - REAL(iine,wp) )
+            pt%yj = ijglo - ( pt%yj - REAL(ijne,wp) )
+            pt%uvel = -1._wp * pt%uvel
+            pt%vvel = -1._wp * pt%vvel
+         ENDIF
+         this => this%next
+      END DO
+      !
+   END SUBROUTINE icb_lbc_nfld
+
+#if defined key_mpp_mpi
+   !!----------------------------------------------------------------------
+   !!   'key_mpp_mpi'             MPI massively parallel processing library
+   !!----------------------------------------------------------------------
+
+   SUBROUTINE icb_lbc_mpp()
+      !!----------------------------------------------------------------------
+      !!                 ***  SUBROUTINE icb_lbc_mpp  ***
+      !!
+      !! ** Purpose :   multi processor exchange
+      !!
+      !! ** Method  :   identify direction for exchange, pack into a buffer
+      !!                which is basically a real array and delete from linked list
+      !!                length of buffer is exchanged first with receiving processor
+      !!                then buffer is sent if necessary
+      !!----------------------------------------------------------------------
+      TYPE(iceberg)         , POINTER     ::   tmpberg, this
+      TYPE(point)           , POINTER     ::   pt
+      INTEGER                             ::   ibergs_to_send_e, ibergs_to_send_w
+      INTEGER                             ::   ibergs_to_send_n, ibergs_to_send_s
+      INTEGER                             ::   ibergs_rcvd_from_e, ibergs_rcvd_from_w
+      INTEGER                             ::   ibergs_rcvd_from_n, ibergs_rcvd_from_s
+      INTEGER                             ::   i, ibergs_start, ibergs_end
+      INTEGER                             ::   iine, ijne
+      INTEGER                             ::   ipe_N, ipe_S, ipe_W, ipe_E
+      REAL(wp), DIMENSION(2)              ::   zewbergs, zwebergs, znsbergs, zsnbergs
+      INTEGER                             ::   iml_req1, iml_req2, iml_req3, iml_req4
+      INTEGER                             ::   iml_req5, iml_req6, iml_req7, iml_req8, iml_err
+      INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   iml_stat
+
+      ! set up indices of neighbouring processors
+      ipe_N = -1
+      ipe_S = -1
+      ipe_W = -1
+      ipe_E = -1
+      IF( nbondi .EQ.  0 .OR. nbondi .EQ. 1) ipe_W = nowe
+      IF( nbondi .EQ. -1 .OR. nbondi .EQ. 0) ipe_E = noea
+      IF( nbondj .EQ.  0 .OR. nbondj .EQ. 1) ipe_S = noso
+      IF( nbondj .EQ. -1 .OR. nbondj .EQ. 0) ipe_N = nono
+      !
+      ! at northern line of processors with north fold handle bergs differently
+      IF( npolj > 0 ) ipe_N = -1
+
+      ! if there's only one processor in x direction then don't let mpp try to handle periodicity
+      IF( jpni == 1 ) THEN
+         ipe_E = -1
+         ipe_W = -1
+      ENDIF
+
+      IF( nn_verbose_level >= 2 ) THEN
+         WRITE(numicb,*) 'processor west  : ', ipe_W
+         WRITE(numicb,*) 'processor east  : ', ipe_E
+         WRITE(numicb,*) 'processor north : ', ipe_N
+         WRITE(numicb,*) 'processor south : ', ipe_S
+         WRITE(numicb,*) 'processor nimpp : ', nimpp
+         WRITE(numicb,*) 'processor njmpp : ', njmpp
+         WRITE(numicb,*) 'processor nbondi: ', nbondi
+         WRITE(numicb,*) 'processor nbondj: ', nbondj
+         CALL flush( numicb )
+      ENDIF
+
+      ! periodicity is handled here when using mpp when there is more than one processor in
+      ! the i direction, but it also has to happen when jpni=1 case so this is dealt with
+      ! in icb_lbc and called here
+
+      IF( jpni == 1 ) CALL icb_lbc()
+
+      ! Note that xi is adjusted when swapping because of periodic condition
+
+      IF( nn_verbose_level > 0 ) THEN
+         ! store the number of icebergs on this processor at start
+         ibergs_start = icb_utl_count()
+      ENDIF
+
+      ibergs_to_send_e   = 0
+      ibergs_to_send_w   = 0
+      ibergs_to_send_n   = 0
+      ibergs_to_send_s   = 0
+      ibergs_rcvd_from_e = 0
+      ibergs_rcvd_from_w = 0
+      ibergs_rcvd_from_n = 0
+      ibergs_rcvd_from_s = 0
+
+      IF( ASSOCIATED(first_berg) ) THEN      ! Find number of bergs that headed east/west
+         this => first_berg
+         DO WHILE (ASSOCIATED(this))
+            pt => this%current_point
+            iine = INT( pt%xi + 0.5 )
+            IF( ipe_E >= 0 .AND. iine > mig(nicbei) ) THEN
+               tmpberg => this
+               this => this%next
+               ibergs_to_send_e = ibergs_to_send_e + 1
+               IF( nn_verbose_level >= 4 ) THEN
+                  WRITE(numicb,*) 'bergstep ',nktberg,' packing berg ',tmpberg%number(:),' for transfer to east'
+                  CALL flush( numicb )
+               ENDIF
+               ! deal with periodic case
+               tmpberg%current_point%xi = ricb_right + MOD(tmpberg%current_point%xi, 1._wp ) - 1._wp
+               ! now pack it into buffer and delete from list
+               CALL icb_pack_into_buffer( tmpberg, obuffer_e, ibergs_to_send_e)
+               CALL icb_utl_delete(first_berg, tmpberg)
+            ELSE IF( ipe_W >= 0 .AND. iine < mig(nicbdi) ) THEN
+               tmpberg => this
+               this => this%next
+               ibergs_to_send_w = ibergs_to_send_w + 1
+               IF( nn_verbose_level >= 4 ) THEN
+                  WRITE(numicb,*) 'bergstep ',nktberg,' packing berg ',tmpberg%number(:),' for transfer to west'
+                  CALL flush( numicb )
+               ENDIF
+               ! deal with periodic case
+               tmpberg%current_point%xi = ricb_left + MOD(tmpberg%current_point%xi, 1._wp )
+               ! now pack it into buffer and delete from list
+               CALL icb_pack_into_buffer( tmpberg, obuffer_w, ibergs_to_send_w)
+               CALL icb_utl_delete(first_berg, tmpberg)
+            ELSE
+               this => this%next
+            ENDIF
+         END DO
+      ENDIF
+      IF( nn_verbose_level >= 3) THEN
+         WRITE(numicb,*) 'bergstep ',nktberg,' send ew: ', ibergs_to_send_e, ibergs_to_send_w
+         CALL flush(numicb)
+      ENDIF
+
+      ! send bergs east and receive bergs from west (ie ones that were sent east) and vice versa
+
+      ! pattern here is copied from lib_mpp code
+
+      SELECT CASE ( nbondi )
+      CASE( -1 )
+         zwebergs(1) = ibergs_to_send_e
+         CALL mppsend( 12, zwebergs(1), 1, ipe_E, iml_req1)
+         CALL mpprecv( 11, zewbergs(2), 1, ipe_E )
+         IF( l_isend ) CALL mpi_wait( iml_req1, iml_stat, iml_err )
+         ibergs_rcvd_from_e = INT( zewbergs(2) )
+      CASE(  0 )
+         zewbergs(1) = ibergs_to_send_w
+         zwebergs(1) = ibergs_to_send_e
+         CALL mppsend( 11, zewbergs(1), 1, ipe_W, iml_req2)
+         CALL mppsend( 12, zwebergs(1), 1, ipe_E, iml_req3)
+         CALL mpprecv( 11, zewbergs(2), 1, ipe_E )
+         CALL mpprecv( 12, zwebergs(2), 1, ipe_W )
+         IF( l_isend ) CALL mpi_wait( iml_req2, iml_stat, iml_err )
+         IF( l_isend ) CALL mpi_wait( iml_req3, iml_stat, iml_err )
+         ibergs_rcvd_from_e = INT( zewbergs(2) )
+         ibergs_rcvd_from_w = INT( zwebergs(2) )
+      CASE(  1 )
+         zewbergs(1) = ibergs_to_send_w
+         CALL mppsend( 11, zewbergs(1), 1, ipe_W, iml_req4)
+         CALL mpprecv( 12, zwebergs(2), 1, ipe_W )
+         IF( l_isend ) CALL mpi_wait( iml_req4, iml_stat, iml_err )
+         ibergs_rcvd_from_w = INT( zwebergs(2) )
+      END SELECT
+      IF( nn_verbose_level >= 3) THEN
+         WRITE(numicb,*) 'bergstep ',nktberg,' recv ew: ', ibergs_rcvd_from_w, ibergs_rcvd_from_e
+         CALL flush(numicb)
+      ENDIF
+
+      SELECT CASE ( nbondi )
+      CASE( -1 )
+         IF( ibergs_to_send_e > 0 ) CALL mppsend( 14, obuffer_e%data, ibergs_to_send_e*jp_buffer_width, ipe_E, iml_req1 )
+         IF( ibergs_rcvd_from_e > 0 ) THEN
+            CALL icb_increase_ibuffer(ibuffer_e, ibergs_rcvd_from_e)
+            CALL mpprecv( 13, ibuffer_e%data, ibergs_rcvd_from_e*jp_buffer_width )
+         ENDIF
+         IF( ibergs_to_send_e > 0 .AND. l_isend ) CALL mpi_wait( iml_req1, iml_stat, iml_err )
+         DO i = 1, ibergs_rcvd_from_e
+            IF( nn_verbose_level >= 4 ) THEN
+               WRITE(numicb,*) 'bergstep ',nktberg,' unpacking berg ',INT(ibuffer_e%data(16,i)),' from east'
+               CALL flush( numicb )
+            ENDIF
+            CALL icb_unpack_from_buffer(first_berg, ibuffer_e, i)
+         ENDDO
+      CASE(  0 )
+         IF( ibergs_to_send_w > 0 ) CALL mppsend( 13, obuffer_w%data, ibergs_to_send_w*jp_buffer_width, ipe_W, iml_req2 )
+         IF( ibergs_to_send_e > 0 ) CALL mppsend( 14, obuffer_e%data, ibergs_to_send_e*jp_buffer_width, ipe_E, iml_req3 )
+         IF( ibergs_rcvd_from_e > 0 ) THEN
+            CALL icb_increase_ibuffer(ibuffer_e, ibergs_rcvd_from_e)
+            CALL mpprecv( 13, ibuffer_e%data, ibergs_rcvd_from_e*jp_buffer_width )
+         ENDIF
+         IF( ibergs_rcvd_from_w > 0 ) THEN
+            CALL icb_increase_ibuffer(ibuffer_w, ibergs_rcvd_from_w)
+            CALL mpprecv( 14, ibuffer_w%data, ibergs_rcvd_from_w*jp_buffer_width )
+         ENDIF
+         IF( ibergs_to_send_w > 0 .AND. l_isend ) CALL mpi_wait( iml_req2, iml_stat, iml_err )
+         IF( ibergs_to_send_e > 0 .AND. l_isend ) CALL mpi_wait( iml_req3, iml_stat, iml_err )
+         DO i = 1, ibergs_rcvd_from_e
+            IF( nn_verbose_level >= 4 ) THEN
+               WRITE(numicb,*) 'bergstep ',nktberg,' unpacking berg ',INT(ibuffer_e%data(16,i)),' from east'
+               CALL flush( numicb )
+            ENDIF
+            CALL icb_unpack_from_buffer(first_berg, ibuffer_e, i)
+         END DO
+         DO i = 1, ibergs_rcvd_from_w
+            IF( nn_verbose_level >= 4 ) THEN
+               WRITE(numicb,*) 'bergstep ',nktberg,' unpacking berg ',INT(ibuffer_w%data(16,i)),' from west'
+               CALL flush( numicb )
+            ENDIF
+            CALL icb_unpack_from_buffer(first_berg, ibuffer_w, i)
+         ENDDO
+      CASE(  1 )
+         IF( ibergs_to_send_w > 0 ) CALL mppsend( 13, obuffer_w%data, ibergs_to_send_w*jp_buffer_width, ipe_W, iml_req4 )
+         IF( ibergs_rcvd_from_w > 0 ) THEN
+            CALL icb_increase_ibuffer(ibuffer_w, ibergs_rcvd_from_w)
+            CALL mpprecv( 14, ibuffer_w%data, ibergs_rcvd_from_w*jp_buffer_width )
+         ENDIF
+         IF( ibergs_to_send_w > 0 .AND. l_isend ) CALL mpi_wait( iml_req4, iml_stat, iml_err )
+         DO i = 1, ibergs_rcvd_from_w
+            IF( nn_verbose_level >= 4 ) THEN
+               WRITE(numicb,*) 'bergstep ',nktberg,' unpacking berg ',INT(ibuffer_w%data(16,i)),' from west'
+               CALL flush( numicb )
+            ENDIF
+            CALL icb_unpack_from_buffer(first_berg, ibuffer_w, i)
+         END DO
+      END SELECT
+
+      ! Find number of bergs that headed north/south
+      ! (note: this block should technically go ahead of the E/W recv block above
+      !  to handle arbitrary orientation of PEs. But for simplicity, it is
+      !  here to accomodate diagonal transfer of bergs between PEs -AJA)
+
+      IF( ASSOCIATED(first_berg) ) THEN
+         this => first_berg
+         DO WHILE (ASSOCIATED(this))
+            pt => this%current_point
+            ijne = INT( pt%yj + 0.5 )
+            IF( ipe_N >= 0 .AND. ijne .GT. mjg(nicbej) ) THEN
+               tmpberg => this
+               this => this%next
+               ibergs_to_send_n = ibergs_to_send_n + 1
+               IF( nn_verbose_level >= 4 ) THEN
+                  WRITE(numicb,*) 'bergstep ',nktberg,' packing berg ',tmpberg%number(:),' for transfer to north'
+                  CALL flush( numicb )
+               ENDIF
+               CALL icb_pack_into_buffer( tmpberg, obuffer_n, ibergs_to_send_n)
+               CALL icb_utl_delete(first_berg, tmpberg)
+            ELSE IF( ipe_S >= 0 .AND. ijne .LT. mjg(nicbdj) ) THEN
+               tmpberg => this
+               this => this%next
+               ibergs_to_send_s = ibergs_to_send_s + 1
+               IF( nn_verbose_level >= 4 ) THEN
+                  WRITE(numicb,*) 'bergstep ',nktberg,' packing berg ',tmpberg%number(:),' for transfer to south'
+                  CALL flush( numicb )
+               ENDIF
+               CALL icb_pack_into_buffer( tmpberg, obuffer_s, ibergs_to_send_s)
+               CALL icb_utl_delete(first_berg, tmpberg)
+            ELSE
+               this => this%next
+            ENDIF
+         END DO
+      ENDIF
+      if( nn_verbose_level >= 3) then
+         write(numicb,*) 'bergstep ',nktberg,' send ns: ', ibergs_to_send_n, ibergs_to_send_s
+         call flush(numicb)
+      endif
+
+      ! send bergs north
+      ! and receive bergs from south (ie ones sent north)
+
+      SELECT CASE ( nbondj )
+      CASE( -1 )
+         zsnbergs(1) = ibergs_to_send_n
+         CALL mppsend( 16, zsnbergs(1), 1, ipe_N, iml_req1)
+         CALL mpprecv( 15, znsbergs(2), 1, ipe_N )
+         IF( l_isend ) CALL mpi_wait( iml_req1, iml_stat, iml_err )
+         ibergs_rcvd_from_n = INT( znsbergs(2) )
+      CASE(  0 )
+         znsbergs(1) = ibergs_to_send_s
+         zsnbergs(1) = ibergs_to_send_n
+         CALL mppsend( 15, znsbergs(1), 1, ipe_S, iml_req2)
+         CALL mppsend( 16, zsnbergs(1), 1, ipe_N, iml_req3)
+         CALL mpprecv( 15, znsbergs(2), 1, ipe_N )
+         CALL mpprecv( 16, zsnbergs(2), 1, ipe_S )
+         IF( l_isend ) CALL mpi_wait( iml_req2, iml_stat, iml_err )
+         IF( l_isend ) CALL mpi_wait( iml_req3, iml_stat, iml_err )
+         ibergs_rcvd_from_n = INT( znsbergs(2) )
+         ibergs_rcvd_from_s = INT( zsnbergs(2) )
+      CASE(  1 )
+         znsbergs(1) = ibergs_to_send_s
+         CALL mppsend( 15, znsbergs(1), 1, ipe_S, iml_req4)
+         CALL mpprecv( 16, zsnbergs(2), 1, ipe_S )
+         IF( l_isend ) CALL mpi_wait( iml_req4, iml_stat, iml_err )
+         ibergs_rcvd_from_s = INT( zsnbergs(2) )
+      END SELECT
+      if( nn_verbose_level >= 3) then
+         write(numicb,*) 'bergstep ',nktberg,' recv ns: ', ibergs_rcvd_from_s, ibergs_rcvd_from_n
+         call flush(numicb)
+      endif
+
+      SELECT CASE ( nbondj )
+      CASE( -1 )
+         IF( ibergs_to_send_n > 0 ) CALL mppsend( 18, obuffer_n%data, ibergs_to_send_n*jp_buffer_width, ipe_N, iml_req1 )
+         IF( ibergs_rcvd_from_n > 0 ) THEN
+            CALL icb_increase_ibuffer(ibuffer_n, ibergs_rcvd_from_n)
+            CALL mpprecv( 17, ibuffer_n%data, ibergs_rcvd_from_n*jp_buffer_width )
+         ENDIF
+         IF( ibergs_to_send_n > 0 .AND. l_isend ) CALL mpi_wait( iml_req1, iml_stat, iml_err )
+         DO i = 1, ibergs_rcvd_from_n
+            IF( nn_verbose_level >= 4 ) THEN
+               WRITE(numicb,*) 'bergstep ',nktberg,' unpacking berg ',INT(ibuffer_n%data(16,i)),' from north'
+               CALL flush( numicb )
+            ENDIF
+            CALL icb_unpack_from_buffer(first_berg, ibuffer_n, i)
+         END DO
+      CASE(  0 )
+         IF( ibergs_to_send_s > 0 ) CALL mppsend( 17, obuffer_s%data, ibergs_to_send_s*jp_buffer_width, ipe_S, iml_req2 )
+         IF( ibergs_to_send_n > 0 ) CALL mppsend( 18, obuffer_n%data, ibergs_to_send_n*jp_buffer_width, ipe_N, iml_req3 )
+         IF( ibergs_rcvd_from_n > 0 ) THEN
+            CALL icb_increase_ibuffer(ibuffer_n, ibergs_rcvd_from_n)
+            CALL mpprecv( 17, ibuffer_n%data, ibergs_rcvd_from_n*jp_buffer_width )
+         ENDIF
+         IF( ibergs_rcvd_from_s > 0 ) THEN
+            CALL icb_increase_ibuffer(ibuffer_s, ibergs_rcvd_from_s)
+            CALL mpprecv( 18, ibuffer_s%data, ibergs_rcvd_from_s*jp_buffer_width )
+         ENDIF
+         IF( ibergs_to_send_s > 0 .AND. l_isend ) CALL mpi_wait( iml_req2, iml_stat, iml_err )
+         IF( ibergs_to_send_n > 0 .AND. l_isend ) CALL mpi_wait( iml_req3, iml_stat, iml_err )
+         DO i = 1, ibergs_rcvd_from_n
+            IF( nn_verbose_level >= 4 ) THEN
+               WRITE(numicb,*) 'bergstep ',nktberg,' unpacking berg ',INT(ibuffer_n%data(16,i)),' from north'
+               CALL flush( numicb )
+            ENDIF
+            CALL icb_unpack_from_buffer(first_berg, ibuffer_n, i)
+         END DO
+         DO i = 1, ibergs_rcvd_from_s
+            IF( nn_verbose_level >= 4 ) THEN
+               WRITE(numicb,*) 'bergstep ',nktberg,' unpacking berg ',INT(ibuffer_s%data(16,i)),' from south'
+               CALL flush( numicb )
+            ENDIF
+            CALL icb_unpack_from_buffer(first_berg, ibuffer_s, i)
+         ENDDO
+      CASE(  1 )
+         IF( ibergs_to_send_s > 0 ) CALL mppsend( 17, obuffer_s%data, ibergs_to_send_s*jp_buffer_width, ipe_S, iml_req4 )
+         IF( ibergs_rcvd_from_s > 0 ) THEN
+            CALL icb_increase_ibuffer(ibuffer_s, ibergs_rcvd_from_s)
+            CALL mpprecv( 18, ibuffer_s%data, ibergs_rcvd_from_s*jp_buffer_width )
+         ENDIF
+         IF( ibergs_to_send_s > 0 .AND. l_isend ) CALL mpi_wait( iml_req4, iml_stat, iml_err )
+         DO i = 1, ibergs_rcvd_from_s
+            IF( nn_verbose_level >= 4 ) THEN
+               WRITE(numicb,*) 'bergstep ',nktberg,' unpacking berg ',INT(ibuffer_s%data(16,i)),' from south'
+               CALL flush( numicb )
+            ENDIF
+            CALL icb_unpack_from_buffer(first_berg, ibuffer_s, i)
+         END DO
+      END SELECT
+
+      IF( nn_verbose_level > 0 ) THEN
+         ! compare the number of icebergs on this processor from the start to the end
+         ibergs_end = icb_utl_count()
+         i = ( ibergs_rcvd_from_n + ibergs_rcvd_from_s + ibergs_rcvd_from_e + ibergs_rcvd_from_w ) - &
+             ( ibergs_to_send_n + ibergs_to_send_s + ibergs_to_send_e + ibergs_to_send_w )
+         IF( ibergs_end-(ibergs_start+i) .NE. 0 ) THEN
+            WRITE( numicb,*   ) 'send_bergs_to_other_pes: net change in number of icebergs'
+            WRITE( numicb,1000) 'send_bergs_to_other_pes: ibergs_end=', &
+                                ibergs_end,' on PE',narea
+            WRITE( numicb,1000) 'send_bergs_to_other_pes: ibergs_start=', &
+                                ibergs_start,' on PE',narea
+            WRITE( numicb,1000) 'send_bergs_to_other_pes: delta=', &
+                                i,' on PE',narea
+            WRITE( numicb,1000) 'send_bergs_to_other_pes: error=', &
+                                ibergs_end-(ibergs_start+i),' on PE',narea
+            WRITE( numicb,1000) 'send_bergs_to_other_pes: ibergs_to_send_n=', &
+                                ibergs_to_send_n,' on PE',narea
+            WRITE( numicb,1000) 'send_bergs_to_other_pes: ibergs_to_send_s=', &
+                                ibergs_to_send_s,' on PE',narea
+            WRITE( numicb,1000) 'send_bergs_to_other_pes: ibergs_to_send_e=', &
+                                ibergs_to_send_e,' on PE',narea
+            WRITE( numicb,1000) 'send_bergs_to_other_pes: ibergs_to_send_w=', &
+                                ibergs_to_send_w,' on PE',narea
+            WRITE( numicb,1000) 'send_bergs_to_other_pes: ibergs_rcvd_from_n=', &
+                                ibergs_rcvd_from_n,' on PE',narea
+            WRITE( numicb,1000) 'send_bergs_to_other_pes: ibergs_rcvd_from_s=', &
+                                ibergs_rcvd_from_s,' on PE',narea
+            WRITE( numicb,1000) 'send_bergs_to_other_pes: ibergs_rcvd_from_e=', &
+                                ibergs_rcvd_from_e,' on PE',narea
+            WRITE( numicb,1000) 'send_bergs_to_other_pes: ibergs_rcvd_from_w=', &
+                                ibergs_rcvd_from_w,' on PE',narea
+  1000      FORMAT(a,i5,a,i4)
+            CALL ctl_stop('send_bergs_to_other_pes: lost or gained an iceberg or two')
+         ENDIF
+      ENDIF
+
+      ! deal with north fold if we necessary when there is more than one top row processor
+      ! note that for jpni=1 north fold has been dealt with above in call to icb_lbc
+      IF( npolj /= 0 .AND. jpni > 1 ) CALL icb_lbc_mpp_nfld( )
+
+      IF( nn_verbose_level > 0 ) THEN
+         i = 0
+         this => first_berg
+         DO WHILE (ASSOCIATED(this))
+            pt => this%current_point
+            iine = INT( pt%xi + 0.5 )
+            ijne = INT( pt%yj + 0.5 )
+            IF( iine .LT. mig(nicbdi) .OR. &
+                iine .GT. mig(nicbei) .OR. &
+                ijne .LT. mjg(nicbdj) .OR. &
+                ijne .GT. mjg(nicbej)) THEN
+               i = i + 1
+               WRITE(numicb,*) 'berg lost in halo: ', this%number(:),iine,ijne
+               WRITE(numicb,*) '                   ', nimpp, njmpp
+               WRITE(numicb,*) '                   ', nicbdi, nicbei, nicbdj, nicbej
+               CALL flush( numicb )
+            ENDIF
+            this => this%next
+         ENDDO ! WHILE
+         CALL mpp_sum(i)
+         IF( i .GT. 0 ) THEN
+            WRITE( numicb,'(a,i4)') 'send_bergs_to_other_pes: # of bergs outside computational domain = ',i
+            CALL ctl_stop('send_bergs_to_other_pes:  there are bergs still in halos!')
+         ENDIF ! root_pe
+      ENDIF ! debug
+      !
+      CALL mppsync()
+      !
+   END SUBROUTINE icb_lbc_mpp
+
+
+   SUBROUTINE icb_lbc_mpp_nfld()
+      !!----------------------------------------------------------------------
+      !!                 ***  SUBROUTINE icb_lbc_mpp_nfld  ***
+      !!
+      !! ** Purpose :   north fold treatment in multi processor exchange
+      !!
+      !! ** Method  :   
+      !!----------------------------------------------------------------------
+      TYPE(iceberg)         , POINTER     :: tmpberg, this
+      TYPE(point)           , POINTER     :: pt
+      INTEGER                             :: ibergs_to_send
+      INTEGER                             :: ibergs_to_rcv
+      INTEGER                             :: iiglo, ijglo, jk, jn
+      INTEGER                             :: ifldproc, iproc, ipts
+      INTEGER                             :: iine, ijne
+      INTEGER                             :: jjn
+      REAL(wp), DIMENSION(0:3)            :: zsbergs, znbergs
+      INTEGER                             :: iml_req1, iml_req2, iml_err
+      INTEGER, DIMENSION(MPI_STATUS_SIZE) :: iml_stat
+
+      ! set up indices of neighbouring processors
+
+      ! nicbfldproc is a list of unique processor numbers that this processor
+      ! exchanges with (including itself), so we loop over this array; since
+      ! its of fixed size, the first -1 marks end of list of processors
+      !
+      nicbfldnsend(:) = 0
+      nicbfldexpect(:) = 0
+      nicbfldreq(:) = 0
+      !
+      ! Since each processor may be communicating with more than one northern
+      ! neighbour, cycle through the sends so that the receive order can be
+      ! controlled.
+      !
+      ! First compute how many icebergs each active neighbour should expect
+      DO jn = 1, jpni
+         IF( nicbfldproc(jn) /= -1 ) THEN
+            ifldproc = nicbfldproc(jn)
+            nicbfldnsend(jn) = 0
+
+            ! Find number of bergs that need to be exchanged
+            ! Pick out exchanges with processor ifldproc
+            ! if ifldproc is this processor then don't send
+            !
+            IF( ASSOCIATED(first_berg) ) THEN
+               this => first_berg
+               DO WHILE (ASSOCIATED(this))
+                  pt => this%current_point
+                  iine = INT( pt%xi + 0.5 )
+                  ijne = INT( pt%yj + 0.5 )
+                  iproc = nicbflddest(mi1(iine))
+                  IF( ijne .GT. mjg(nicbej) ) THEN
+                     IF( iproc == ifldproc ) THEN
+                        !
+                        IF( iproc /= narea ) THEN
+                           tmpberg => this
+                           nicbfldnsend(jn) = nicbfldnsend(jn) + 1
+                        ENDIF
+                        !
+                     ENDIF
+                  ENDIF
+                  this => this%next
+               END DO
+            ENDIF
+            !
+         ENDIF
+         !
+      END DO
+      !
+      ! Now tell each active neighbour how many icebergs to expect
+      DO jn = 1, jpni
+         IF( nicbfldproc(jn) /= -1 ) THEN
+            ifldproc = nicbfldproc(jn)
+            IF( ifldproc == narea ) CYCLE
+   
+            zsbergs(0) = narea
+            zsbergs(1) = nicbfldnsend(jn)
+            !IF ( nicbfldnsend(jn) .GT. 0) write(numicb,*) 'ICB sending ',nicbfldnsend(jn),' to ', ifldproc
+            CALL mppsend( 21, zsbergs(0:1), 2, ifldproc-1, nicbfldreq(jn))
+         ENDIF
+         !
+      END DO
+      !
+      ! and receive the heads-up from active neighbours preparing to send
+      DO jn = 1, jpni
+         IF( nicbfldproc(jn) /= -1 ) THEN
+            ifldproc = nicbfldproc(jn)
+            IF( ifldproc == narea ) CYCLE
+
+            CALL mpprecv( 21, znbergs(1:2), 2 )
+            DO jjn = 1,jpni
+             IF( nicbfldproc(jjn) .eq. INT(znbergs(1)) ) EXIT
+            END DO
+            IF( jjn .GT. jpni ) write(numicb,*) 'ICB ERROR'
+            nicbfldexpect(jjn) = INT( znbergs(2) )
+            !IF ( nicbfldexpect(jjn) .GT. 0) write(numicb,*) 'ICB expecting ',nicbfldexpect(jjn),' from ', nicbfldproc(jjn)
+            !CALL FLUSH(numicb)
+         ENDIF
+         !
+      END DO
+      !
+      ! post the mpi waits if using immediate send protocol
+      DO jn = 1, jpni
+         IF( nicbfldproc(jn) /= -1 ) THEN
+            ifldproc = nicbfldproc(jn)
+            IF( ifldproc == narea ) CYCLE
+
+            IF( l_isend ) CALL mpi_wait( nicbfldreq(jn), iml_stat, iml_err )
+         ENDIF
+         !
+      END DO
+   
+         !
+         ! Cycle through the icebergs again, this time packing and sending any
+         ! going through the north fold. They will be expected.
+      DO jn = 1, jpni
+         IF( nicbfldproc(jn) /= -1 ) THEN
+            ifldproc = nicbfldproc(jn)
+            ibergs_to_send = 0
+   
+            ! Find number of bergs that need to be exchanged
+            ! Pick out exchanges with processor ifldproc
+            ! if ifldproc is this processor then don't send
+            !
+            IF( ASSOCIATED(first_berg) ) THEN
+               this => first_berg
+               DO WHILE (ASSOCIATED(this))
+                  pt => this%current_point
+                  iine = INT( pt%xi + 0.5 )
+                  ijne = INT( pt%yj + 0.5 )
+                  ipts  = nicbfldpts (mi1(iine))
+                  iproc = nicbflddest(mi1(iine))
+                  IF( ijne .GT. mjg(nicbej) ) THEN
+                     IF( iproc == ifldproc ) THEN
+                        !
+                        ! moving across the cut line means both position and
+                        ! velocity must change
+                        ijglo = INT( ipts/nicbpack )
+                        iiglo = ipts - nicbpack*ijglo
+                        pt%xi = iiglo - ( pt%xi - REAL(iine,wp) )
+                        pt%yj = ijglo - ( pt%yj - REAL(ijne,wp) )
+                        pt%uvel = -1._wp * pt%uvel
+                        pt%vvel = -1._wp * pt%vvel
+                        !
+                        ! now remove berg from list and pack it into a buffer
+                        IF( iproc /= narea ) THEN
+                           tmpberg => this
+                           ibergs_to_send = ibergs_to_send + 1
+                           IF( nn_verbose_level >= 4 ) THEN
+                              WRITE(numicb,*) 'bergstep ',nktberg,' packing berg ',tmpberg%number(:),' for north fold'
+                              CALL flush( numicb )
+                           ENDIF
+                           CALL icb_pack_into_buffer( tmpberg, obuffer_f, ibergs_to_send)
+                           CALL icb_utl_delete(first_berg, tmpberg)
+                        ENDIF
+                        !
+                     ENDIF
+                  ENDIF
+                  this => this%next
+               END DO
+            ENDIF
+            if( nn_verbose_level >= 3) then
+               write(numicb,*) 'bergstep ',nktberg,' send nfld: ', ibergs_to_send
+               call flush(numicb)
+            endif
+            !
+            ! if we're in this processor, then we've done everything we need to
+            ! so go on to next element of loop
+            IF( ifldproc == narea ) CYCLE
+   
+            ! send bergs
+   
+            IF( ibergs_to_send > 0 )  &
+                CALL mppsend( 12, obuffer_f%data, ibergs_to_send*jp_buffer_width, ifldproc-1, nicbfldreq(jn) )
+            !
+         ENDIF
+         !
+      END DO
+      !
+      ! Now receive the expected number of bergs from the active neighbours
+      DO jn = 1, jpni
+         IF( nicbfldproc(jn) /= -1 ) THEN
+            ifldproc = nicbfldproc(jn)
+            IF( ifldproc == narea ) CYCLE
+            ibergs_to_rcv = nicbfldexpect(jn)
+
+            IF( ibergs_to_rcv  > 0 ) THEN
+               CALL icb_increase_ibuffer(ibuffer_f, ibergs_to_rcv)
+               CALL mpprecv( 12, ibuffer_f%data, ibergs_to_rcv*jp_buffer_width, ifldproc-1 )
+            ENDIF
+            !
+            DO jk = 1, ibergs_to_rcv
+               IF( nn_verbose_level >= 4 ) THEN
+                  WRITE(numicb,*) 'bergstep ',nktberg,' unpacking berg ',INT(ibuffer_f%data(16,jk)),' from north fold'
+                  CALL flush( numicb )
+               ENDIF
+               CALL icb_unpack_from_buffer(first_berg, ibuffer_f, jk )
+            END DO
+         ENDIF
+         !
+      END DO
+      !
+      ! Finally post the mpi waits if using immediate send protocol
+      DO jn = 1, jpni
+         IF( nicbfldproc(jn) /= -1 ) THEN
+            ifldproc = nicbfldproc(jn)
+            IF( ifldproc == narea ) CYCLE
+
+            IF( l_isend ) CALL mpi_wait( nicbfldreq(jn), iml_stat, iml_err )
+         ENDIF
+         !
+      END DO
+      !
+   END SUBROUTINE icb_lbc_mpp_nfld
+
+
+   SUBROUTINE icb_pack_into_buffer( berg, pbuff, kb )
+      !!----------------------------------------------------------------------
+      !!----------------------------------------------------------------------
+      TYPE(iceberg), POINTER :: berg
+      TYPE(buffer) , POINTER :: pbuff
+      INTEGER               , INTENT(in) :: kb
+      ! 
+      INTEGER ::   k   ! local integer
+      !!----------------------------------------------------------------------
+      !
+      IF( .NOT. ASSOCIATED(pbuff) ) CALL icb_increase_buffer( pbuff, jp_delta_buf )
+      IF( kb .GT. pbuff%size ) CALL icb_increase_buffer( pbuff, jp_delta_buf )
+
+      !! pack points into buffer
+
+      pbuff%data( 1,kb) = berg%current_point%lon
+      pbuff%data( 2,kb) = berg%current_point%lat
+      pbuff%data( 3,kb) = berg%current_point%uvel
+      pbuff%data( 4,kb) = berg%current_point%vvel
+      pbuff%data( 5,kb) = berg%current_point%xi
+      pbuff%data( 6,kb) = berg%current_point%yj
+      pbuff%data( 7,kb) = float(berg%current_point%year)
+      pbuff%data( 8,kb) = berg%current_point%day
+      pbuff%data( 9,kb) = berg%current_point%mass
+      pbuff%data(10,kb) = berg%current_point%thickness
+      pbuff%data(11,kb) = berg%current_point%width
+      pbuff%data(12,kb) = berg%current_point%length
+      pbuff%data(13,kb) = berg%current_point%mass_of_bits
+      pbuff%data(14,kb) = berg%current_point%heat_density
+
+      pbuff%data(15,kb) = berg%mass_scaling
+      DO k=1,nkounts
+         pbuff%data(15+k,kb) = REAL( berg%number(k), wp )
+      END DO
+      !
+   END SUBROUTINE icb_pack_into_buffer
+
+
+   SUBROUTINE icb_unpack_from_buffer(first, pbuff, kb)
+      !!----------------------------------------------------------------------
+      !!----------------------------------------------------------------------
+      TYPE(iceberg),             POINTER :: first
+      TYPE(buffer) ,             POINTER :: pbuff
+      INTEGER      , INTENT(in)          :: kb
+      ! 
+      TYPE(iceberg)                      :: currentberg
+      TYPE(point)                        :: pt
+      INTEGER                            :: ik
+      !!----------------------------------------------------------------------
+      !
+      pt%lon            =      pbuff%data( 1,kb)
+      pt%lat            =      pbuff%data( 2,kb)
+      pt%uvel           =      pbuff%data( 3,kb)
+      pt%vvel           =      pbuff%data( 4,kb)
+      pt%xi             =      pbuff%data( 5,kb)
+      pt%yj             =      pbuff%data( 6,kb)
+      pt%year           = INT( pbuff%data( 7,kb) )
+      pt%day            =      pbuff%data( 8,kb)
+      pt%mass           =      pbuff%data( 9,kb)
+      pt%thickness      =      pbuff%data(10,kb)
+      pt%width          =      pbuff%data(11,kb)
+      pt%length         =      pbuff%data(12,kb)
+      pt%mass_of_bits   =      pbuff%data(13,kb)
+      pt%heat_density   =      pbuff%data(14,kb)
+
+      currentberg%mass_scaling =      pbuff%data(15,kb)
+      DO ik = 1, nkounts
+         currentberg%number(ik) = INT( pbuff%data(15+ik,kb) )
+      END DO
+      !
+      CALL icb_utl_add(currentberg, pt )
+      !
+   END SUBROUTINE icb_unpack_from_buffer
+
+
+   SUBROUTINE icb_increase_buffer(old,kdelta)
+      !!----------------------------------------------------------------------
+      TYPE(buffer), POINTER    :: old
+      INTEGER     , INTENT(in) :: kdelta
+      ! 
+      TYPE(buffer), POINTER ::   new
+      INTEGER ::   inew_size
+      !!----------------------------------------------------------------------
+      !
+      IF( .NOT. ASSOCIATED(old) ) THEN   ;   inew_size = kdelta
+      ELSE                               ;   inew_size = old%size + kdelta
+      ENDIF
+      ALLOCATE( new )
+      ALLOCATE( new%data( jp_buffer_width, inew_size) )
+      new%size = inew_size
+      IF( ASSOCIATED(old) ) THEN
+         new%data(:,1:old%size) = old%data(:,1:old%size)
+         DEALLOCATE(old%data)
+         DEALLOCATE(old)
+      ENDIF
+      old => new
+      !
+   END SUBROUTINE icb_increase_buffer
+
+
+   SUBROUTINE icb_increase_ibuffer(old,kdelta)
+      !!----------------------------------------------------------------------
+      !!----------------------------------------------------------------------
+      TYPE(buffer),            POINTER :: old
+      INTEGER     , INTENT(in)         :: kdelta
+      !
+      TYPE(buffer),            POINTER :: new
+      INTEGER                          :: inew_size, iold_size
+      !!----------------------------------------------------------------------
+
+      IF( .NOT. ASSOCIATED(old) ) THEN
+         inew_size = kdelta + jp_delta_buf
+         iold_size = 0
+      ELSE
+         iold_size = old%size
+         IF( kdelta .LT. old%size ) THEN
+            inew_size = old%size + kdelta
+         ELSE
+            inew_size = kdelta + jp_delta_buf
+         ENDIF
+      ENDIF
+
+      IF( iold_size .NE. inew_size ) THEN
+         ALLOCATE( new )
+         ALLOCATE( new%data( jp_buffer_width, inew_size) )
+         new%size = inew_size
+         IF( ASSOCIATED(old) ) THEN
+            new%data(:,1:old%size) = old%data(:,1:old%size)
+            DEALLOCATE(old%data)
+            DEALLOCATE(old)
+         ENDIF
+         old => new
+        !WRITE( numicb,*) 'icb_increase_ibuffer',narea,' increased to',inew_size
+      ENDIF
+      !
+   END SUBROUTINE icb_increase_ibuffer
+
+#else
+   !!----------------------------------------------------------------------
+   !!   Default case:            Dummy module        share memory computing
+   !!----------------------------------------------------------------------
+   SUBROUTINE icb_lbc_mpp()
+      WRITE(numout,*) 'icb_lbc_mpp: You should not have seen this message!!'
+   END SUBROUTINE icb_lbc_mpp
+#endif
+
+   !!======================================================================
+END MODULE icblbc
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/ICB/icbrst.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/ICB/icbrst.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/ICB/icbrst.F90	(revision 9570)
@@ -0,0 +1,363 @@
+MODULE icbrst
+   !!======================================================================
+   !!                       ***  MODULE  icbrst  ***
+   !! Ocean physics:  read and write iceberg restart files
+   !!======================================================================
+   !! History : 3.3.1 !  2010-01  (Martin&Adcroft) Original code
+   !!            -    !  2011-03  (Madec)          Part conversion to NEMO form
+   !!            -    !                            Removal of mapping from another grid
+   !!            -    !  2011-04  (Alderson)       Split into separate modules
+   !!            -    !  2011-04  (Alderson)       Restore restart routine
+   !!            -    !                            Currently needs a fixed processor
+   !!            -    !                            layout between restarts
+   !!            -    !  2015-11  Dave Storkey     Convert icb_rst_read to use IOM so can
+   !!                                              read single restart files
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   icb_rst_read    : read restart file
+   !!   icb_rst_write   : write restart file
+   !!----------------------------------------------------------------------
+   USE par_oce        ! NEMO parameters
+   USE dom_oce        ! NEMO domain
+   USE in_out_manager ! NEMO IO routines
+   USE lib_mpp        ! NEMO MPI library, lk_mpp in particular
+   USE netcdf         ! netcdf routines for IO
+   USE iom
+   USE icb_oce        ! define iceberg arrays
+   USE icbutl         ! iceberg utility routines
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   icb_rst_read    ! routine called in icbini.F90 module
+   PUBLIC   icb_rst_write   ! routine called in icbstp.F90 module
+   
+   INTEGER ::   nlonid, nlatid, nxid, nyid, nuvelid, nvvelid
+   INTEGER ::   nmassid, nthicknessid, nwidthid, nlengthid
+   INTEGER ::   nyearid, ndayid
+   INTEGER ::   nscaling_id, nmass_of_bits_id, nheat_density_id, numberid
+   INTEGER ::   nsiceid, nsheatid, ncalvid, ncalvhid, nkountid
+   INTEGER ::   nret, ncid, nc_dim
+   
+   INTEGER,  DIMENSION(3)                  :: nstrt3, nlngth3
+
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO Consortium (2011)
+   !! $Id$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE icb_rst_read()
+      !!----------------------------------------------------------------------
+      !!                 ***  SUBROUTINE icb_rst_read  ***
+      !!
+      !! ** Purpose :   read a iceberg restart file
+      !!      NB: for this version, we just read back in the restart for this processor
+      !!      so we cannot change the processor layout currently with iceberg code
+      !!----------------------------------------------------------------------
+      INTEGER                      ::   idim, ivar, iatt
+      INTEGER                      ::   jn, iunlim_dim, ibergs_in_file
+      INTEGER                      ::   ii,ij,iclass
+      REAL(wp), DIMENSION(nkounts) ::   zdata      
+      LOGICAL                      ::   ll_found_restart
+      CHARACTER(len=256)           ::   cl_path
+      CHARACTER(len=256)           ::   cl_filename
+      CHARACTER(len=NF90_MAX_NAME) ::   cl_dname
+      TYPE(iceberg)                ::   localberg ! NOT a pointer but an actual local variable
+      TYPE(point)                  ::   localpt   ! NOT a pointer but an actual local variable
+      !!----------------------------------------------------------------------
+
+      ! Find a restart file. Assume iceberg restarts in same directory as ocean restarts
+      ! and are called TRIM(cn_ocerst)//'_icebergs'
+      cl_path = TRIM(cn_ocerst_indir)
+      IF( cl_path(LEN_TRIM(cl_path):) /= '/' ) cl_path = TRIM(cl_path) // '/'
+      cl_filename = TRIM(cn_ocerst_in)//'_icebergs'
+      CALL iom_open( TRIM(cl_path)//cl_filename, ncid )
+
+      IF( iom_file(ncid)%iduld .GE. 0) THEN
+
+         ibergs_in_file = iom_file(ncid)%lenuld
+         DO jn = 1,ibergs_in_file
+
+            ! iom_get treats the unlimited dimension as time. Here the unlimited dimension 
+            ! is the iceberg index, but we can still use the ktime keyword to get the iceberg we want. 
+
+            CALL iom_get( ncid, 'xi'     ,localpt%xi  , ktime=jn )
+            CALL iom_get( ncid, 'yj'     ,localpt%yj  , ktime=jn )
+
+            ii = INT( localpt%xi + 0.5 )
+            ij = INT( localpt%yj + 0.5 )
+            ! Only proceed if this iceberg is on the local processor (excluding halos).
+            IF ( ii .GE. nldi+nimpp-1 .AND. ii .LE. nlei+nimpp-1 .AND. &
+           &     ij .GE. nldj+njmpp-1 .AND. ij .LE. nlej+njmpp-1 ) THEN           
+
+               CALL iom_get( ncid, jpdom_unknown, 'number'       , zdata(:) , ktime=jn, kstart=(/1/), kcount=(/nkounts/) )
+               localberg%number(:) = INT(zdata(:))
+               CALL iom_get( ncid, 'mass_scaling' , localberg%mass_scaling, ktime=jn )
+               CALL iom_get( ncid, 'lon'          , localpt%lon           , ktime=jn )
+               CALL iom_get( ncid, 'lat'          , localpt%lat           , ktime=jn )
+               CALL iom_get( ncid, 'uvel'         , localpt%uvel          , ktime=jn )
+               CALL iom_get( ncid, 'vvel'         , localpt%vvel          , ktime=jn )
+               CALL iom_get( ncid, 'mass'         , localpt%mass          , ktime=jn )
+               CALL iom_get( ncid, 'thickness'    , localpt%thickness     , ktime=jn )
+               CALL iom_get( ncid, 'width'        , localpt%width         , ktime=jn )
+               CALL iom_get( ncid, 'length'       , localpt%length        , ktime=jn )
+               CALL iom_get( ncid, 'year'         , zdata(1)              , ktime=jn )
+               localpt%year = INT(zdata(1))
+               CALL iom_get( ncid, 'day'          , localpt%day           , ktime=jn )
+               CALL iom_get( ncid, 'mass_of_bits' , localpt%mass_of_bits  , ktime=jn )
+               CALL iom_get( ncid, 'heat_density' , localpt%heat_density  , ktime=jn )
+               !
+               CALL icb_utl_add( localberg, localpt )
+               !
+            ENDIF
+            !
+         END DO
+         !
+      ENDIF 
+
+      ! Gridded variables
+      CALL iom_get( ncid, jpdom_autoglo,    'calving'     , src_calving  )
+      CALL iom_get( ncid, jpdom_autoglo,    'calving_hflx', src_calving_hflx  )
+      CALL iom_get( ncid, jpdom_autoglo,    'stored_heat' , berg_grid%stored_heat  )
+      CALL iom_get( ncid, jpdom_autoglo_xy, 'stored_ice'  , berg_grid%stored_ice, kstart=(/1,1,1/), kcount=(/1,1,nclasses/) )
+      
+      CALL iom_get( ncid, jpdom_unknown, 'kount' , zdata(:) )
+      num_bergs(:) = INT(zdata(:))
+
+      ! Sanity check
+      jn = icb_utl_count()
+      IF (nn_verbose_level >= 0)   &
+         WRITE(numout,'(2(a,i5))') 'icebergs, read_restart_bergs: # bergs =',jn,' on PE',narea-1
+      IF( lk_mpp ) THEN
+         ! Only mpp_sum ibergs_in_file if we are reading from multiple restart files. 
+         IF( INDEX(iom_file(ncid)%name,'icebergs.nc' ) .EQ. 0 ) CALL mpp_sum(ibergs_in_file)
+         CALL mpp_sum(jn)
+      ENDIF
+      IF(lwp)   WRITE(numout,'(a,i5,a,i5,a)') 'icebergs, read_restart_bergs: there were',ibergs_in_file,   &
+         &                                    ' bergs in the restart file and', jn,' bergs have been read'
+      !
+      ! Finish up
+      CALL iom_close( ncid )
+      !
+      IF( lwp .AND. nn_verbose_level >= 0)  WRITE(numout,'(a)') 'icebergs, read_restart_bergs: completed'
+      !
+   END SUBROUTINE icb_rst_read
+
+
+   SUBROUTINE icb_rst_write( kt )
+      !!----------------------------------------------------------------------
+      !!                 ***  SUBROUTINE icb_rst_write  ***
+      !!
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT( in ) :: kt
+      !
+      INTEGER ::   jn   ! dummy loop index
+      INTEGER ::   ix_dim, iy_dim, ik_dim, in_dim
+      CHARACTER(len=256)     :: cl_path
+      CHARACTER(len=256)     :: cl_filename
+      TYPE(iceberg), POINTER :: this
+      TYPE(point)  , POINTER :: pt
+      !!----------------------------------------------------------------------
+
+      ! Assume we write iceberg restarts to same directory as ocean restarts.
+      cl_path = TRIM(cn_ocerst_outdir)
+      IF( cl_path(LEN_TRIM(cl_path):) /= '/' ) cl_path = TRIM(cl_path) // '/'
+      IF( lk_mpp ) THEN
+         WRITE(cl_filename,'(A,"_icebergs_",I8.8,"_restart_",I4.4,".nc")') TRIM(cexper), kt, narea-1
+      ELSE
+         WRITE(cl_filename,'(A,"_icebergs_",I8.8,"_restart.nc")') TRIM(cexper), kt
+      ENDIF
+      IF (nn_verbose_level >= 0) WRITE(numout,'(2a)') 'icebergs, write_restart: creating ',TRIM(cl_path)//TRIM(cl_filename)
+
+      nret = NF90_CREATE(TRIM(cl_path)//TRIM(cl_filename), NF90_CLOBBER, ncid)
+      IF (nret .ne. NF90_NOERR) CALL ctl_stop('icebergs, write_restart: nf_create failed')
+
+      ! Dimensions
+      nret = NF90_DEF_DIM(ncid, 'x', jpi, ix_dim)
+      IF (nret .ne. NF90_NOERR) CALL ctl_stop('icebergs, write_restart: nf_def_dim x failed')
+
+      nret = NF90_DEF_DIM(ncid, 'y', jpj, iy_dim)
+      IF (nret .ne. NF90_NOERR) CALL ctl_stop('icebergs, write_restart: nf_def_dim y failed')
+
+      nret = NF90_DEF_DIM(ncid, 'c', nclasses, nc_dim)
+      IF (nret .ne. NF90_NOERR) CALL ctl_stop('icebergs, write_restart: nf_def_dim c failed')
+
+      nret = NF90_DEF_DIM(ncid, 'k', nkounts, ik_dim)
+      IF (nret .ne. NF90_NOERR) CALL ctl_stop('icebergs, write_restart: nf_def_dim k failed')
+
+      ! global attributes
+      IF( lk_mpp ) THEN
+         ! Set domain parameters (assume jpdom_local_full)
+         nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_number_total'   , jpnij              )
+         nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_number'         , narea-1            )
+         nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_dimensions_ids' , (/1     , 2     /) )
+         nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_size_global'    , (/jpiglo, jpjglo/) )
+         nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_size_local'     , (/jpi   , jpj   /) )
+         nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_position_first' , (/nimpp , njmpp /) )
+         nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_position_last'  , (/nimpp + jpi - 1 , njmpp + jpj - 1  /) )
+         nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_halo_size_start', (/nldi - 1        , nldj - 1         /) )
+         nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_halo_size_end'  , (/jpi - nlei      , jpj - nlej       /) )
+         nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_type'           , 'BOX'              )
+      ENDIF
+      
+      IF (associated(first_berg)) then
+         nret = NF90_DEF_DIM(ncid, 'n', NF90_UNLIMITED, in_dim)
+         IF (nret .ne. NF90_NOERR) CALL ctl_stop('icebergs, write_restart: nf_def_dim n failed')
+      ENDIF
+
+      ! Variables
+      nret = NF90_DEF_VAR(ncid, 'kount'       , NF90_INT   , (/ ik_dim /), nkountid)
+      nret = NF90_DEF_VAR(ncid, 'calving'     , NF90_DOUBLE, (/ ix_dim, iy_dim /), ncalvid)
+      nret = NF90_DEF_VAR(ncid, 'calving_hflx', NF90_DOUBLE, (/ ix_dim, iy_dim /), ncalvhid)
+      nret = NF90_DEF_VAR(ncid, 'stored_ice'  , NF90_DOUBLE, (/ ix_dim, iy_dim, nc_dim /), nsiceid)
+      nret = NF90_DEF_VAR(ncid, 'stored_heat' , NF90_DOUBLE, (/ ix_dim, iy_dim /), nsheatid)
+
+      ! Attributes
+      nret = NF90_PUT_ATT(ncid, ncalvid , 'long_name', 'iceberg calving')
+      nret = NF90_PUT_ATT(ncid, ncalvid , 'units', 'some')
+      nret = NF90_PUT_ATT(ncid, ncalvhid, 'long_name', 'heat flux associated with iceberg calving')
+      nret = NF90_PUT_ATT(ncid, ncalvhid, 'units', 'some')
+      nret = NF90_PUT_ATT(ncid, nsiceid , 'long_name', 'stored ice used to calve icebergs')
+      nret = NF90_PUT_ATT(ncid, nsiceid , 'units', 'kg/s')
+      nret = NF90_PUT_ATT(ncid, nsheatid, 'long_name', 'heat in stored ice used to calve icebergs')
+      nret = NF90_PUT_ATT(ncid, nsheatid, 'units', 'J/kg/s')
+
+      IF ( ASSOCIATED(first_berg) ) THEN
+
+         ! Only add berg variables for this PE if we have anything to say
+
+         ! Variables
+         nret = NF90_DEF_VAR(ncid, 'lon', NF90_DOUBLE, in_dim, nlonid)
+         nret = NF90_DEF_VAR(ncid, 'lat', NF90_DOUBLE, in_dim, nlatid)
+         nret = NF90_DEF_VAR(ncid, 'xi', NF90_DOUBLE, in_dim, nxid)
+         nret = NF90_DEF_VAR(ncid, 'yj', NF90_DOUBLE, in_dim, nyid)
+         nret = NF90_DEF_VAR(ncid, 'uvel', NF90_DOUBLE, in_dim, nuvelid)
+         nret = NF90_DEF_VAR(ncid, 'vvel', NF90_DOUBLE, in_dim, nvvelid)
+         nret = NF90_DEF_VAR(ncid, 'mass', NF90_DOUBLE, in_dim, nmassid)
+         nret = NF90_DEF_VAR(ncid, 'thickness', NF90_DOUBLE, in_dim, nthicknessid)
+         nret = NF90_DEF_VAR(ncid, 'width', NF90_DOUBLE, in_dim, nwidthid)
+         nret = NF90_DEF_VAR(ncid, 'length', NF90_DOUBLE, in_dim, nlengthid)
+         nret = NF90_DEF_VAR(ncid, 'number', NF90_INT, (/ik_dim,in_dim/), numberid)
+         nret = NF90_DEF_VAR(ncid, 'year', NF90_INT, in_dim, nyearid)
+         nret = NF90_DEF_VAR(ncid, 'day', NF90_DOUBLE, in_dim, ndayid)
+         nret = NF90_DEF_VAR(ncid, 'mass_scaling', NF90_DOUBLE, in_dim, nscaling_id)
+         nret = NF90_DEF_VAR(ncid, 'mass_of_bits', NF90_DOUBLE, in_dim, nmass_of_bits_id)
+         nret = NF90_DEF_VAR(ncid, 'heat_density', NF90_DOUBLE, in_dim, nheat_density_id)
+
+         ! Attributes
+         nret = NF90_PUT_ATT(ncid, nlonid, 'long_name', 'longitude')
+         nret = NF90_PUT_ATT(ncid, nlonid, 'units', 'degrees_E')
+         nret = NF90_PUT_ATT(ncid, nlatid, 'long_name', 'latitude')
+         nret = NF90_PUT_ATT(ncid, nlatid, 'units', 'degrees_N')
+         nret = NF90_PUT_ATT(ncid, nxid, 'long_name', 'x grid box position')
+         nret = NF90_PUT_ATT(ncid, nxid, 'units', 'fractional')
+         nret = NF90_PUT_ATT(ncid, nyid, 'long_name', 'y grid box position')
+         nret = NF90_PUT_ATT(ncid, nyid, 'units', 'fractional')
+         nret = NF90_PUT_ATT(ncid, nuvelid, 'long_name', 'zonal velocity')
+         nret = NF90_PUT_ATT(ncid, nuvelid, 'units', 'm/s')
+         nret = NF90_PUT_ATT(ncid, nvvelid, 'long_name', 'meridional velocity')
+         nret = NF90_PUT_ATT(ncid, nvvelid, 'units', 'm/s')
+         nret = NF90_PUT_ATT(ncid, nmassid, 'long_name', 'mass')
+         nret = NF90_PUT_ATT(ncid, nmassid, 'units', 'kg')
+         nret = NF90_PUT_ATT(ncid, nthicknessid, 'long_name', 'thickness')
+         nret = NF90_PUT_ATT(ncid, nthicknessid, 'units', 'm')
+         nret = NF90_PUT_ATT(ncid, nwidthid, 'long_name', 'width')
+         nret = NF90_PUT_ATT(ncid, nwidthid, 'units', 'm')
+         nret = NF90_PUT_ATT(ncid, nlengthid, 'long_name', 'length')
+         nret = NF90_PUT_ATT(ncid, nlengthid, 'units', 'm')
+         nret = NF90_PUT_ATT(ncid, numberid, 'long_name', 'iceberg number on this processor')
+         nret = NF90_PUT_ATT(ncid, numberid, 'units', 'count')
+         nret = NF90_PUT_ATT(ncid, nyearid, 'long_name', 'calendar year of calving event')
+         nret = NF90_PUT_ATT(ncid, nyearid, 'units', 'years')
+         nret = NF90_PUT_ATT(ncid, ndayid, 'long_name', 'year day of calving event')
+         nret = NF90_PUT_ATT(ncid, ndayid, 'units', 'days')
+         nret = NF90_PUT_ATT(ncid, nscaling_id, 'long_name', 'scaling factor for mass of calving berg')
+         nret = NF90_PUT_ATT(ncid, nscaling_id, 'units', 'none')
+         nret = NF90_PUT_ATT(ncid, nmass_of_bits_id, 'long_name', 'mass of bergy bits')
+         nret = NF90_PUT_ATT(ncid, nmass_of_bits_id, 'units', 'kg')
+         nret = NF90_PUT_ATT(ncid, nheat_density_id, 'long_name', 'heat density')
+         nret = NF90_PUT_ATT(ncid, nheat_density_id, 'units', 'J/kg')
+
+      ENDIF ! associated(first_berg)
+
+      ! End define mode
+      nret = NF90_ENDDEF(ncid)
+
+      ! --------------------------------
+      ! now write some data
+
+      nstrt3(1) = 1
+      nstrt3(2) = 1
+      nlngth3(1) = jpi
+      nlngth3(2) = jpj
+      nlngth3(3) = 1
+
+      DO jn=1,nclasses
+         griddata(:,:,1) = berg_grid%stored_ice(:,:,jn)
+         nstrt3(3) = jn
+         nret = NF90_PUT_VAR( ncid, nsiceid, griddata, nstrt3, nlngth3 )
+         IF (nret .ne. NF90_NOERR) THEN
+            IF( lwp ) WRITE(numout,*) TRIM(NF90_STRERROR( nret ))
+            CALL ctl_stop('icebergs, write_restart: nf_put_var stored_ice failed')
+         ENDIF
+      ENDDO
+      IF( lwp ) WRITE(numout,*) 'file: ',TRIM(cl_path)//TRIM(cl_filename),' var: stored_ice  written'
+
+      nret = NF90_PUT_VAR( ncid, nkountid, num_bergs(:) )
+      IF (nret .ne. NF90_NOERR) CALL ctl_stop('icebergs, write_restart: nf_put_var kount failed')
+
+      nret = NF90_PUT_VAR( ncid, nsheatid, berg_grid%stored_heat(:,:) )
+      IF (nret .ne. NF90_NOERR) CALL ctl_stop('icebergs, write_restart: nf_put_var stored_heat failed')
+      IF( lwp ) WRITE(numout,*) 'file: ',TRIM(cl_path)//TRIM(cl_filename),' var: stored_heat written'
+
+      nret = NF90_PUT_VAR( ncid, ncalvid , src_calving(:,:) )
+      IF (nret .ne. NF90_NOERR) CALL ctl_stop('icebergs, write_restart: nf_put_var calving failed')
+      nret = NF90_PUT_VAR( ncid, ncalvhid, src_calving_hflx(:,:) )
+      IF (nret .ne. NF90_NOERR) CALL ctl_stop('icebergs, write_restart: nf_put_var calving_hflx failed')
+      IF( lwp ) WRITE(numout,*) 'file: ',TRIM(cl_path)//TRIM(cl_filename),' var: calving written'
+
+      IF ( ASSOCIATED(first_berg) ) THEN
+
+         ! Write variables
+         ! just write out the current point of the trajectory
+
+         this => first_berg
+         jn = 0
+         DO WHILE (ASSOCIATED(this))
+            pt => this%current_point
+            jn=jn+1
+
+            nret = NF90_PUT_VAR(ncid, numberid, this%number, (/1,jn/), (/nkounts,1/) )
+            nret = NF90_PUT_VAR(ncid, nscaling_id, this%mass_scaling, (/ jn /) )
+
+            nret = NF90_PUT_VAR(ncid, nlonid, pt%lon, (/ jn /) )
+            nret = NF90_PUT_VAR(ncid, nlatid, pt%lat, (/ jn /) )
+            nret = NF90_PUT_VAR(ncid, nxid, pt%xi, (/ jn /) )
+            nret = NF90_PUT_VAR(ncid, nyid, pt%yj, (/ jn /) )
+            nret = NF90_PUT_VAR(ncid, nuvelid, pt%uvel, (/ jn /) )
+            nret = NF90_PUT_VAR(ncid, nvvelid, pt%vvel, (/ jn /) )
+            nret = NF90_PUT_VAR(ncid, nmassid, pt%mass, (/ jn /) )
+            nret = NF90_PUT_VAR(ncid, nthicknessid, pt%thickness, (/ jn /) )
+            nret = NF90_PUT_VAR(ncid, nwidthid, pt%width, (/ jn /) )
+            nret = NF90_PUT_VAR(ncid, nlengthid, pt%length, (/ jn /) )
+            nret = NF90_PUT_VAR(ncid, nyearid, pt%year, (/ jn /) )
+            nret = NF90_PUT_VAR(ncid, ndayid, pt%day, (/ jn /) )
+            nret = NF90_PUT_VAR(ncid, nmass_of_bits_id, pt%mass_of_bits, (/ jn /) )
+            nret = NF90_PUT_VAR(ncid, nheat_density_id, pt%heat_density, (/ jn /) )
+
+            this=>this%next
+         END DO
+         !
+      ENDIF ! associated(first_berg)
+
+      ! Finish up
+      nret = NF90_CLOSE(ncid)
+      IF (nret /= NF90_NOERR) CALL ctl_stop('icebergs, write_restart: nf_close failed')
+      !
+   END SUBROUTINE icb_rst_write
+   !
+   !!======================================================================
+END MODULE icbrst
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/ICB/icbstp.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/ICB/icbstp.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/ICB/icbstp.F90	(revision 9570)
@@ -0,0 +1,171 @@
+MODULE icbstp
+   !!======================================================================
+   !!                       ***  MODULE  icbstp  ***
+   !! Icebergs:  initialise variables for iceberg tracking
+   !!======================================================================
+   !! History : 3.3.1 !  2010-01  (Martin&Adcroft) Original code
+   !!            -    !  2011-03  (Madec)          Part conversion to NEMO form
+   !!            -    !                            Removal of mapping from another grid
+   !!            -    !  2011-04  (Alderson)       Split into separate modules
+   !!            -    !                            Move budgets to icbdia routine
+   !!            -    !  2011-05  (Alderson)       Add call to copy forcing arrays
+   !!            -    !                            into icb copies with haloes
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   icb_stp       : start iceberg tracking
+   !!   icb_end       : end   iceberg tracking
+   !!----------------------------------------------------------------------
+   USE par_oce        ! nemo parameters
+   USE dom_oce        ! ocean domain
+   USE sbc_oce        ! ocean surface forcing
+   USE phycst         ! physical constants
+   !
+   USE icb_oce        ! iceberg: define arrays
+   USE icbini         ! iceberg: initialisation routines
+   USE icbutl         ! iceberg: utility routines
+   USE icbrst         ! iceberg: restart routines
+   USE icbdyn         ! iceberg: dynamics (ie advection) routines
+   USE icbclv         ! iceberg: calving routines
+   USE icbthm         ! iceberg: thermodynamics routines
+   USE icblbc         ! iceberg: lateral boundary routines (including mpp)
+   USE icbtrj         ! iceberg: trajectory I/O routines
+   USE icbdia         ! iceberg: budget
+   !
+   USE in_out_manager ! nemo IO
+   USE lib_mpp        ! massively parallel library 
+   USE iom            ! I/O manager
+   USE fldread        ! field read
+   USE timing         ! timing
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   icb_stp        ! routine called in sbcmod.F90 module
+   PUBLIC   icb_end        ! routine called in nemogcm.F90 module
+
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO Consortium (2011)
+   !! $Id$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE icb_stp( kt )
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE icb_stp  ***
+      !!
+      !! ** Purpose :   iceberg time stepping.
+      !!
+      !! ** Method  : - top level routine to do things in the correct order
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT(in) ::   kt   ! time step index
+      !
+      LOGICAL ::   ll_sample_traj, ll_budget, ll_verbose   ! local logical
+      !!----------------------------------------------------------------------
+      !
+      IF( ln_timing )   CALL timing_start('icb_stp')
+
+      !                       !==  start of timestep housekeeping  ==!
+      !
+      nktberg = kt
+      !
+      IF( nn_test_icebergs < 0 ) THEN     !* read calving data
+         !
+         CALL fld_read ( kt, 1, sf_icb )
+         src_calving     (:,:) = sf_icb(1)%fnow(:,:,1)    ! calving in km^3/year (water equivalent)
+         src_calving_hflx(:,:) = 0._wp                    ! NO heat flux for now
+         !
+      ENDIF
+      !
+      berg_grid%floating_melt(:,:) = 0._wp
+      !
+      !                                   !* anything that needs to be reset to zero each timestep 
+      CALL icb_dia_step()                 !  for budgets is dealt with here
+      !
+      !                                   !* write out time
+      ll_verbose = .FALSE.
+      IF( nn_verbose_write > 0 .AND. MOD( kt-1 , nn_verbose_write ) == 0 )   ll_verbose = ( nn_verbose_level >= 0 )
+      !
+      IF( ll_verbose )   WRITE(numicb,9100) nktberg, ndastp, nsec_day
+ 9100 FORMAT('kt= ',i8, ' day= ',i8,' secs=',i8)
+      !
+      !                                   !* copy nemo forcing arrays into iceberg versions with extra halo
+      CALL icb_utl_copy()                 ! only necessary for variables not on T points
+      !
+      !
+      !                       !==  process icebergs  ==!
+      !                              !
+                                     CALL icb_clv_flx( kt )   ! Accumulate ice from calving
+      !                              !
+                                     CALL icb_clv()           ! Calve excess stored ice into icebergs
+      !                              !
+      !
+      !                       !==  For each berg, evolve  ==!
+      !
+      IF( ASSOCIATED(first_berg) )   CALL icb_dyn( kt )       ! ice berg dynamics
+
+      IF( lk_mpp ) THEN   ;          CALL icb_lbc_mpp()       ! Send bergs to other PEs
+      ELSE                ;          CALL icb_lbc()           ! Deal with any cyclic boundaries in non-mpp case
+      ENDIF
+
+      IF( ASSOCIATED(first_berg) )   CALL icb_thm( kt )       ! Ice berg thermodynamics (melting) + rolling
+      !
+      !
+      !                       !==  diagnostics and output  ==!
+      !
+      !                                   !* For each berg, record trajectory (when needed)
+      ll_sample_traj = .FALSE.
+      IF( nn_sample_rate > 0 .AND. MOD(kt-1,nn_sample_rate) == 0 )   ll_sample_traj = .TRUE.
+      IF( ll_sample_traj .AND. ASSOCIATED(first_berg) )   CALL icb_trj_write( kt )
+
+      !                                   !* Gridded diagnostics
+      !                                   !  To get these iom_put's and those preceding to actually do something
+      !                                   !  use key_iomput in cpp file and create content for XML file
+      !
+      CALL iom_put( "calving"           , berg_grid%calving      (:,:)   )  ! 'calving mass input'
+      CALL iom_put( "berg_floating_melt", berg_grid%floating_melt(:,:)   )  ! 'Melt rate of icebergs + bits' , 'kg/m2/s'
+      CALL iom_put( "berg_stored_ice"   , berg_grid%stored_ice   (:,:,:) )  ! 'Accumulated ice mass by class', 'kg'
+      !
+      CALL icb_dia_put()                  !* store mean budgets
+      !
+      !                                   !*  Dump icebergs to screen
+      IF( nn_verbose_level >= 2 )   CALL icb_utl_print( 'icb_stp, status', kt )
+      !
+      !                                   !* Diagnose budgets
+      ll_budget = .FALSE.
+      IF( nn_verbose_write > 0 .AND. MOD(kt-1,nn_verbose_write) == 0 )   ll_budget = ln_bergdia
+      CALL icb_dia( ll_budget )
+      !
+      IF( lrst_oce ) THEN    !* restart
+         CALL icb_rst_write( kt )
+         IF( nn_sample_rate > 0 )   CALL icb_trj_sync()
+      ENDIF
+      !
+      IF( ln_timing )   CALL timing_stop('icb_stp')
+      !
+   END SUBROUTINE icb_stp
+
+
+   SUBROUTINE icb_end( kt )
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE icb_end  ***
+      !!
+      !! ** Purpose :   close iceberg files
+      !!
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT( in )  ::   kt   ! model time-step index
+      !!----------------------------------------------------------------------
+      !
+      ! finish with trajectories if they were written
+      IF( nn_sample_rate > 0 )   CALL icb_trj_end()
+
+      IF(lwp) WRITE(numout,'(a,i6)') 'icebergs: icb_end complete', narea
+      !
+      CALL flush( numicb )
+      CLOSE( numicb )
+      !
+   END SUBROUTINE icb_end
+
+   !!======================================================================
+END MODULE icbstp
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/ICB/icbthm.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/ICB/icbthm.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/ICB/icbthm.F90	(revision 9570)
@@ -0,0 +1,219 @@
+MODULE icbthm
+   !!======================================================================
+   !!                       ***  MODULE  icbthm  ***
+   !! Icebergs:  thermodynamics routines for icebergs
+   !!======================================================================
+   !! History : 3.3.1 !  2010-01  (Martin&Adcroft) Original code
+   !!            -    !  2011-03  (Madec)          Part conversion to NEMO form
+   !!            -    !                            Removal of mapping from another grid
+   !!            -    !  2011-04  (Alderson)       Split into separate modules
+   !!            -    !  2011-05  (Alderson)       Use tmask instead of tmask_i
+   !!----------------------------------------------------------------------
+   !!----------------------------------------------------------------------
+   !!   icb_thm : initialise
+   !!             reference for equations - M = Martin + Adcroft, OM 34, 2010
+   !!----------------------------------------------------------------------
+   USE par_oce        ! NEMO parameters
+   USE dom_oce        ! NEMO domain
+   USE in_out_manager ! NEMO IO routines, numout in particular
+   USE lib_mpp        ! NEMO MPI routines, ctl_stop in particular
+   USE phycst         ! NEMO physical constants
+   USE sbc_oce
+
+   USE icb_oce        ! define iceberg arrays
+   USE icbutl         ! iceberg utility routines
+   USE icbdia         ! iceberg budget routines
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   icb_thm ! routine called in icbstp.F90 module
+
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO Consortium (2011)
+   !! $Id$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE icb_thm( kt )
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE icb_thm  ***
+      !!
+      !! ** Purpose :   compute the iceberg thermodynamics.
+      !!
+      !! ** Method  : - See Martin & Adcroft, Ocean Modelling 34, 2010
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT(in) ::   kt   ! timestep number, just passed to icb_utl_print_berg
+      !
+      INTEGER  ::   ii, ij
+      REAL(wp) ::   zM, zT, zW, zL, zSST, zVol, zLn, zWn, zTn, znVol, zIC, zDn
+      REAL(wp) ::   zMv, zMe, zMb, zmelt, zdvo, zdva, zdM, zSs, zdMe, zdMb, zdMv
+      REAL(wp) ::   zMnew, zMnew1, zMnew2, zheat
+      REAL(wp) ::   zMbits, znMbits, zdMbitsE, zdMbitsM, zLbits, zAbits, zMbb
+      REAL(wp) ::   zxi, zyj, zff, z1_rday, z1_e1e2, zdt, z1_dt, z1_dt_e1e2
+      TYPE(iceberg), POINTER ::   this, next
+      TYPE(point)  , POINTER ::   pt
+      !!----------------------------------------------------------------------
+      !
+      z1_rday = 1._wp / rday
+      !
+      ! we're either going to ignore berg fresh water melt flux and associated heat
+      ! or we pass it into the ocean, so at this point we set them both to zero,
+      ! accumulate the contributions to them from each iceberg in the while loop following
+      ! and then pass them (or not) to the ocean
+      !
+      berg_grid%floating_melt(:,:) = 0._wp
+      berg_grid%calving_hflx(:,:)  = 0._wp
+      !
+      this => first_berg
+      DO WHILE( ASSOCIATED(this) )
+         !
+         pt => this%current_point
+         nknberg = this%number(1)
+         CALL icb_utl_interp( pt%xi, pt%e1, pt%uo, pt%ui, pt%ua, pt%ssh_x,   &
+            &                 pt%yj, pt%e2, pt%vo, pt%vi, pt%va, pt%ssh_y,   &
+            &                 pt%sst, pt%cn, pt%hi, zff )
+         !
+         zSST = pt%sst
+         zIC  = MIN( 1._wp, pt%cn + rn_sicn_shift )     ! Shift sea-ice concentration       !!gm ???
+         zM   = pt%mass
+         zT   = pt%thickness                               ! total thickness
+       ! D   = (rn_rho_bergs/pp_rho_seawater)*zT ! draught (keel depth)
+       ! F   = zT - D ! freeboard
+         zW   = pt%width
+         zL   = pt%length
+         zxi  = pt%xi                                      ! position in (i,j) referential
+         zyj  = pt%yj
+         ii  = INT( zxi + 0.5 )                            ! T-cell of the berg
+         ii  = mi1( ii )
+         ij  = INT( zyj + 0.5 )              
+         ij  = mj1( ij )
+         zVol = zT * zW * zL
+         zdt = berg_dt   ;   z1_dt = 1._wp / zdt
+
+         ! Environment
+         zdvo = SQRT( (pt%uvel-pt%uo)**2 + (pt%vvel-pt%vo)**2 )
+         zdva = SQRT( (pt%ua  -pt%uo)**2 + (pt%va  -pt%vo)**2 )
+         zSs  = 1.5 * SQRT( zdva ) + 0.1 * zdva                ! Sea state      (eqn M.A9)
+
+         ! Melt rates in m/s (i.e. division by rday)
+         zMv = MAX( 7.62e-3*zSST+1.29e-3*(zSST**2)            , 0._wp ) * z1_rday   ! Buoyant convection at sides (eqn M.A10)
+         zMb = MAX( 0.58*(zdvo**0.8)*(zSST+4.0)/(zL**0.2)      , 0._wp ) * z1_rday   ! Basal turbulent melting     (eqn M.A7 )
+         zMe = MAX( 1./12.*(zSST+2.)*zSs*(1+COS(rpi*(zIC**3))) , 0._wp ) * z1_rday   ! Wave erosion                (eqn M.A8 )
+
+         IF( ln_operator_splitting ) THEN      ! Operator split update of volume/mass
+            zTn    = MAX( zT - zMb*zdt , 0._wp )         ! new total thickness (m)
+            znVol  = zTn * zW * zL                       ! new volume (m^3)
+            zMnew1 = (znVol/zVol) * zM                   ! new mass (kg)
+            zdMb   = zM - zMnew1                         ! mass lost to basal melting (>0) (kg)
+            !
+            zLn    = MAX( zL - zMv*zdt , 0._wp )         ! new length (m)
+            zWn    = MAX( zW - zMv*zdt , 0._wp )         ! new width (m)
+            znVol  = zTn * zWn * zLn                     ! new volume (m^3)
+            zMnew2 = (znVol/zVol) * zM                   ! new mass (kg)
+            zdMv   = zMnew1 - zMnew2                     ! mass lost to buoyant convection (>0) (kg)
+            !
+            zLn    = MAX( zLn - zMe*zdt , 0._wp )        ! new length (m)
+            zWn    = MAX( zWn - zMe*zdt , 0._wp )        ! new width (m)
+            znVol  = zTn * zWn * zLn                     ! new volume (m^3)
+            zMnew  = ( znVol / zVol ) * zM               ! new mass (kg)
+            zdMe   = zMnew2 - zMnew                      ! mass lost to erosion (>0) (kg)
+            zdM    = zM - zMnew                          ! mass lost to all erosion and melting (>0) (kg)
+            !
+         ELSE                                         ! Update dimensions of berg
+            zLn = MAX( zL -(zMv+zMe)*zdt ,0._wp )        ! (m)
+            zWn = MAX( zW -(zMv+zMe)*zdt ,0._wp )        ! (m)
+            zTn = MAX( zT - zMb    *zdt ,0._wp )         ! (m)
+            ! Update volume and mass of berg
+            znVol = zTn*zWn*zLn                          ! (m^3)
+            zMnew = (znVol/zVol)*zM                      ! (kg)
+            zdM   = zM - zMnew                           ! (kg)
+            zdMb = (zM/zVol) * (zW*   zL ) *zMb*zdt      ! approx. mass loss to basal melting (kg)
+            zdMe = (zM/zVol) * (zT*(zW+zL)) *zMe*zdt     ! approx. mass lost to erosion (kg)
+            zdMv = (zM/zVol) * (zT*(zW+zL)) *zMv*zdt     ! approx. mass loss to buoyant convection (kg)
+         ENDIF
+
+         IF( rn_bits_erosion_fraction > 0._wp ) THEN     ! Bergy bits
+            !
+            zMbits   = pt%mass_of_bits                                               ! mass of bergy bits (kg)
+            zdMbitsE = rn_bits_erosion_fraction * zdMe                               ! change in mass of bits (kg)
+            znMbits  = zMbits + zdMbitsE                                             ! add new bergy bits to mass (kg)
+            zLbits   = MIN( zL, zW, zT, 40._wp )                                     ! assume bergy bits are smallest dimension or 40 meters
+            zAbits   = ( zMbits / rn_rho_bergs ) / zLbits                            ! Effective bottom area (assuming T=Lbits)
+            zMbb     = MAX( 0.58*(zdvo**0.8)*(zSST+2.0)/(zLbits**0.2), 0.) * z1_rday ! Basal turbulent melting (for bits)
+            zMbb     = rn_rho_bergs * zAbits * zMbb                                  ! in kg/s
+            zdMbitsM = MIN( zMbb*zdt , znMbits )                                     ! bergy bits mass lost to melting (kg)
+            znMbits  = znMbits-zdMbitsM                                              ! remove mass lost to bergy bits melt
+            IF( zMnew == 0._wp ) THEN                                                ! if parent berg has completely melted then
+               zdMbitsM = zdMbitsM + znMbits                                         ! instantly melt all the bergy bits
+               znMbits  = 0._wp
+            ENDIF
+         ELSE                                                     ! No bergy bits
+            zAbits   = 0._wp
+            zdMbitsE = 0._wp
+            zdMbitsM = 0._wp
+            znMbits  = pt%mass_of_bits                             ! retain previous value incase non-zero
+         ENDIF
+
+         ! use tmask rather than tmask_i when dealing with icebergs
+         IF( tmask(ii,ij,1) /= 0._wp ) THEN    ! Add melting to the grid and field diagnostics
+            z1_e1e2    = r1_e1e2t(ii,ij) * this%mass_scaling
+            z1_dt_e1e2 = z1_dt * z1_e1e2
+            zmelt    = ( zdM - ( zdMbitsE - zdMbitsM ) ) * z1_dt   ! kg/s
+            berg_grid%floating_melt(ii,ij) = berg_grid%floating_melt(ii,ij) + zmelt    * z1_e1e2    ! kg/m2/s
+            zheat = zmelt * pt%heat_density              ! kg/s x J/kg = J/s
+            berg_grid%calving_hflx (ii,ij) = berg_grid%calving_hflx (ii,ij) + zheat    * z1_e1e2    ! W/m2
+            CALL icb_dia_melt( ii, ij, zMnew, zheat, this%mass_scaling,       &
+               &                       zdM, zdMbitsE, zdMbitsM, zdMb, zdMe,   &
+               &                       zdMv, z1_dt_e1e2 )
+         ELSE
+            WRITE(numout,*) 'icb_thm: berg ',this%number(:),' appears to have grounded  at ',narea,ii,ij
+            CALL icb_utl_print_berg( this, kt )
+            WRITE(numout,*) 'msk=',tmask(ii,ij,1), e1e2t(ii,ij)
+            CALL ctl_stop('icb_thm', 'berg appears to have grounded!')
+         ENDIF
+
+         ! Rolling
+         zDn = ( rn_rho_bergs / pp_rho_seawater ) * zTn       ! draught (keel depth)
+         IF( zDn > 0._wp .AND. MAX(zWn,zLn) < SQRT( 0.92*(zDn**2) + 58.32*zDn ) ) THEN
+            zT  = zTn
+            zTn = zWn
+            zWn = zT
+         ENDIF
+
+         ! Store the new state of iceberg (with L>W)
+         pt%mass         = zMnew
+         pt%mass_of_bits = znMbits
+         pt%thickness    = zTn
+         pt%width        = MIN( zWn , zLn )
+         pt%length       = MAX( zWn , zLn )
+
+         next=>this%next
+
+!!gm  add a test to avoid over melting ?
+
+         IF( zMnew <= 0._wp ) THEN       ! Delete the berg if completely melted
+            CALL icb_utl_delete( first_berg, this )
+            !
+         ELSE                            ! Diagnose mass distribution on grid
+            z1_e1e2 = r1_e1e2t(ii,ij) * this%mass_scaling
+            CALL icb_dia_size( ii, ij, zWn, zLn, zAbits,   &
+               &               this%mass_scaling, zMnew, znMbits, z1_e1e2 )
+         ENDIF
+         !
+         this=>next
+         !
+      END DO
+
+      ! now use melt and associated heat flux in ocean (or not)
+      !
+      IF(.NOT. ln_passive_mode ) THEN
+         emp (:,:) = emp (:,:) - berg_grid%floating_melt(:,:)
+!!       qns (:,:) = qns (:,:) + berg_grid%calving_hflx (:,:)  !!gm heat flux not yet properly coded ==>> need it, SOLVE that!
+      ENDIF
+      !
+   END SUBROUTINE icb_thm
+
+   !!======================================================================
+END MODULE icbthm
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/ICB/icbtrj.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/ICB/icbtrj.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/ICB/icbtrj.F90	(revision 9570)
@@ -0,0 +1,282 @@
+MODULE icbtrj
+   !!======================================================================
+   !!                       ***  MODULE  icbtrj  ***
+   !! Ocean physics:  trajectory I/O routines
+   !!======================================================================
+   !! History :  3.3  !  2010-01  (Martin&Adcroft) Original code
+   !!             -   !  2011-03  (Madec)          Part conversion to NEMO form
+   !!             -   !                            Removal of mapping from another grid
+   !!             -   !  2011-05  (Alderson)       New module to handle trajectory output
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   icb_trj_init  : initialise iceberg trajectory output files
+   !!   icb_trj_write :
+   !!   icb_trj_sync  :
+   !!   icb_trj_end   :
+   !!----------------------------------------------------------------------
+   USE par_oce        ! NEMO parameters
+   USE dom_oce        ! NEMO ocean domain
+   USE phycst         ! NEMO physical constants
+   USE icb_oce        ! define iceberg arrays
+   USE icbutl         ! iceberg utility routines
+   !
+   USE lib_mpp        ! NEMO MPI library, lk_mpp in particular
+   USE in_out_manager ! NEMO IO, numout in particular
+   USE ioipsl  , ONLY : ju2ymds    ! for calendar
+   USE netcdf
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   icb_trj_init    ! routine called in icbini.F90 module
+   PUBLIC   icb_trj_write   ! routine called in icbstp.F90 module
+   PUBLIC   icb_trj_sync    ! routine called in icbstp.F90 module
+   PUBLIC   icb_trj_end     ! routine called in icbstp.F90 module
+
+   INTEGER ::   num_traj
+   INTEGER ::   n_dim, m_dim
+   INTEGER ::   ntrajid
+   INTEGER ::   numberid, nstepid, nscaling_id
+   INTEGER ::   nlonid, nlatid, nxid, nyid, nuvelid, nvvelid, nmassid
+   INTEGER ::   nuoid, nvoid, nuaid, nvaid, nuiid, nviid
+   INTEGER ::   nsshxid, nsshyid, nsstid, ncntid, nthkid
+   INTEGER ::   nthicknessid, nwidthid, nlengthid
+   INTEGER ::   nyearid, ndayid
+   INTEGER ::   nmass_of_bits_id, nheat_density_id
+
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 4.0 , NEMO Consortium (2017)
+   !! $Id$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE icb_trj_init( ktend )
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE icb_trj_init  ***
+      !!
+      !! ** Purpose :   initialise iceberg trajectory output files
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT(in) ::   ktend   ! time step index
+      !
+      INTEGER                ::   iret, iyear, imonth, iday
+      REAL(wp)               ::   zfjulday, zsec
+      CHARACTER(len=80)      ::   cl_filename
+      CHARACTER(LEN=20)      ::   cldate_ini, cldate_end
+      TYPE(iceberg), POINTER ::   this
+      TYPE(point)  , POINTER ::   pt
+      !!----------------------------------------------------------------------
+
+      ! compute initial time step date
+      CALL ju2ymds( fjulday, iyear, imonth, iday, zsec )
+      WRITE(cldate_ini, '(i4.4,2i2.2)') iyear, imonth, iday
+
+      ! compute end time step date
+      zfjulday = fjulday + rdt / rday * REAL( nitend - nit000 + 1 , wp)
+      IF( ABS(zfjulday - REAL(NINT(zfjulday),wp)) < 0.1 / rday )   zfjulday = REAL(NINT(zfjulday),wp)   ! avoid truncation error
+      CALL ju2ymds( zfjulday, iyear, imonth, iday, zsec )
+      WRITE(cldate_end, '(i4.4,2i2.2)') iyear, imonth, iday
+
+      ! define trajectory output name
+      IF ( lk_mpp ) THEN   ;   WRITE(cl_filename,'("trajectory_icebergs_",A,"-",A,"_",I4.4,".nc")')   &
+         &                        TRIM(ADJUSTL(cldate_ini)), TRIM(ADJUSTL(cldate_end)), narea-1
+      ELSE                 ;   WRITE(cl_filename,'("trajectory_icebergs_",A,"-",A         ,".nc")')   &
+         &                        TRIM(ADJUSTL(cldate_ini)), TRIM(ADJUSTL(cldate_end))
+      ENDIF
+      IF( lwp .AND. nn_verbose_level >= 0 )   WRITE(numout,'(2a)') 'icebergs, icb_trj_init: creating ',TRIM(cl_filename)
+
+      iret = NF90_CREATE( TRIM(cl_filename), NF90_CLOBBER, ntrajid )
+      IF (iret .NE. NF90_NOERR)   CALL ctl_stop('icebergs, icb_trj_init: nf_create failed')
+
+      ! Dimensions
+      iret = NF90_DEF_DIM( ntrajid, 'n', NF90_UNLIMITED, n_dim )
+      IF ( iret /= NF90_NOERR )   CALL ctl_stop('icebergs, icb_trj_init: nf_def_dim n failed')
+      iret = NF90_DEF_DIM( ntrajid, 'k', nkounts, m_dim )
+      IF ( iret /= NF90_NOERR )   CALL ctl_stop('icebergs, icb_trj_init: nf_def_dim k failed')
+
+      ! Variables
+      iret = NF90_DEF_VAR( ntrajid, 'iceberg_number', NF90_INT   , (/m_dim,n_dim/), numberid         )
+      iret = NF90_DEF_VAR( ntrajid, 'timestep'      , NF90_INT   , n_dim          , nstepid          )
+      iret = NF90_DEF_VAR( ntrajid, 'mass_scaling'  , NF90_DOUBLE, n_dim          , nscaling_id      )
+      iret = NF90_DEF_VAR( ntrajid, 'lon'           , NF90_DOUBLE, n_dim          , nlonid           )
+      iret = NF90_DEF_VAR( ntrajid, 'lat'           , NF90_DOUBLE, n_dim          , nlatid           )
+      iret = NF90_DEF_VAR( ntrajid, 'xi'            , NF90_DOUBLE, n_dim          , nxid             )
+      iret = NF90_DEF_VAR( ntrajid, 'yj'            , NF90_DOUBLE, n_dim          , nyid             )
+      iret = NF90_DEF_VAR( ntrajid, 'uvel'          , NF90_DOUBLE, n_dim          , nuvelid          )
+      iret = NF90_DEF_VAR( ntrajid, 'vvel'          , NF90_DOUBLE, n_dim          , nvvelid          )
+      iret = NF90_DEF_VAR( ntrajid, 'uto'           , NF90_DOUBLE, n_dim          , nuoid            )
+      iret = NF90_DEF_VAR( ntrajid, 'vto'           , NF90_DOUBLE, n_dim          , nvoid            )
+      iret = NF90_DEF_VAR( ntrajid, 'uta'           , NF90_DOUBLE, n_dim          , nuaid            )
+      iret = NF90_DEF_VAR( ntrajid, 'vta'           , NF90_DOUBLE, n_dim          , nvaid            )
+      iret = NF90_DEF_VAR( ntrajid, 'uti'           , NF90_DOUBLE, n_dim          , nuiid            )
+      iret = NF90_DEF_VAR( ntrajid, 'vti'           , NF90_DOUBLE, n_dim          , nviid            )
+      iret = NF90_DEF_VAR( ntrajid, 'ssh_x'         , NF90_DOUBLE, n_dim          , nsshxid          )
+      iret = NF90_DEF_VAR( ntrajid, 'ssh_y'         , NF90_DOUBLE, n_dim          , nsshyid          )
+      iret = NF90_DEF_VAR( ntrajid, 'sst'           , NF90_DOUBLE, n_dim          , nsstid           )
+      iret = NF90_DEF_VAR( ntrajid, 'icnt'          , NF90_DOUBLE, n_dim          , ncntid           )
+      iret = NF90_DEF_VAR( ntrajid, 'ithk'          , NF90_DOUBLE, n_dim          , nthkid           )
+      iret = NF90_DEF_VAR( ntrajid, 'mass'          , NF90_DOUBLE, n_dim          , nmassid          )
+      iret = NF90_DEF_VAR( ntrajid, 'thickness'     , NF90_DOUBLE, n_dim          , nthicknessid     )
+      iret = NF90_DEF_VAR( ntrajid, 'width'         , NF90_DOUBLE, n_dim          , nwidthid         )
+      iret = NF90_DEF_VAR( ntrajid, 'length'        , NF90_DOUBLE, n_dim          , nlengthid        )
+      iret = NF90_DEF_VAR( ntrajid, 'year'          , NF90_INT   , n_dim          , nyearid          )
+      iret = NF90_DEF_VAR( ntrajid, 'day'           , NF90_DOUBLE, n_dim          , ndayid           )
+      iret = NF90_DEF_VAR( ntrajid, 'mass_of_bits'  , NF90_DOUBLE, n_dim          , nmass_of_bits_id )
+      iret = NF90_DEF_VAR( ntrajid, 'heat_density'  , NF90_DOUBLE, n_dim          , nheat_density_id )
+
+      ! Attributes
+      iret = NF90_PUT_ATT( ntrajid, numberid        , 'long_name', 'iceberg number on this processor' )
+      iret = NF90_PUT_ATT( ntrajid, numberid        , 'units'    , 'count' )
+      iret = NF90_PUT_ATT( ntrajid, nstepid         , 'long_name', 'timestep number kt' )
+      iret = NF90_PUT_ATT( ntrajid, nstepid         , 'units'    , 'count' )
+      iret = NF90_PUT_ATT( ntrajid, nlonid          , 'long_name', 'longitude' )
+      iret = NF90_PUT_ATT( ntrajid, nlonid          , 'units'    , 'degrees_E')
+      iret = NF90_PUT_ATT( ntrajid, nlatid          , 'long_name', 'latitude' )
+      iret = NF90_PUT_ATT( ntrajid, nlatid          , 'units'    , 'degrees_N' )
+      iret = NF90_PUT_ATT( ntrajid, nxid            , 'long_name', 'x grid box position' )
+      iret = NF90_PUT_ATT( ntrajid, nxid            , 'units'    , 'fractional' )
+      iret = NF90_PUT_ATT( ntrajid, nyid            , 'long_name', 'y grid box position' )
+      iret = NF90_PUT_ATT( ntrajid, nyid            , 'units'    , 'fractional' )
+      iret = NF90_PUT_ATT( ntrajid, nuvelid         , 'long_name', 'zonal velocity' )
+      iret = NF90_PUT_ATT( ntrajid, nuvelid         , 'units'    , 'm/s' )
+      iret = NF90_PUT_ATT( ntrajid, nvvelid         , 'long_name', 'meridional velocity' )
+      iret = NF90_PUT_ATT( ntrajid, nvvelid         , 'units'    , 'm/s' )
+      iret = NF90_PUT_ATT( ntrajid, nuoid           , 'long_name', 'ocean u component' )
+      iret = NF90_PUT_ATT( ntrajid, nuoid           , 'units'    , 'm/s' )
+      iret = NF90_PUT_ATT( ntrajid, nvoid           , 'long_name', 'ocean v component' )
+      iret = NF90_PUT_ATT( ntrajid, nvoid           , 'units'    , 'm/s' )
+      iret = NF90_PUT_ATT( ntrajid, nuaid           , 'long_name', 'atmosphere u component' )
+      iret = NF90_PUT_ATT( ntrajid, nuaid           , 'units'    , 'm/s' )
+      iret = NF90_PUT_ATT( ntrajid, nvaid           , 'long_name', 'atmosphere v component' )
+      iret = NF90_PUT_ATT( ntrajid, nvaid           , 'units'    , 'm/s' )
+      iret = NF90_PUT_ATT( ntrajid, nuiid           , 'long_name', 'sea ice u component' )
+      iret = NF90_PUT_ATT( ntrajid, nuiid           , 'units'    , 'm/s' )
+      iret = NF90_PUT_ATT( ntrajid, nviid           , 'long_name', 'sea ice v component' )
+      iret = NF90_PUT_ATT( ntrajid, nviid           , 'units'    , 'm/s' )
+      iret = NF90_PUT_ATT( ntrajid, nsshxid         , 'long_name', 'sea surface height gradient from x points' )
+      iret = NF90_PUT_ATT( ntrajid, nsshxid         , 'units'    , 'm/m' )
+      iret = NF90_PUT_ATT( ntrajid, nsshyid         , 'long_name', 'sea surface height gradient from y points' )
+      iret = NF90_PUT_ATT( ntrajid, nsshyid         , 'units'    , 'm/m' )
+      iret = NF90_PUT_ATT( ntrajid, nsstid          , 'long_name', 'sea surface temperature' )
+      iret = NF90_PUT_ATT( ntrajid, nsstid          , 'units'    , 'degC')
+      iret = NF90_PUT_ATT( ntrajid, ncntid          , 'long_name', 'sea ice concentration' )
+      iret = NF90_PUT_ATT( ntrajid, ncntid          , 'units'    , 'degC')
+      iret = NF90_PUT_ATT( ntrajid, nthkid          , 'long_name', 'sea ice thickness' )
+      iret = NF90_PUT_ATT( ntrajid, nthkid          , 'units'    , 'm'   )
+      iret = NF90_PUT_ATT( ntrajid, nmassid         , 'long_name', 'mass')
+      iret = NF90_PUT_ATT( ntrajid, nmassid         , 'units'    , 'kg'  )
+      iret = NF90_PUT_ATT( ntrajid, nthicknessid    , 'long_name', 'thickness' )
+      iret = NF90_PUT_ATT( ntrajid, nthicknessid    , 'units'    , 'm'   )
+      iret = NF90_PUT_ATT( ntrajid, nwidthid        , 'long_name', 'width' )
+      iret = NF90_PUT_ATT( ntrajid, nwidthid        , 'units'    , 'm'    )
+      iret = NF90_PUT_ATT( ntrajid, nlengthid       , 'long_name', 'length' )
+      iret = NF90_PUT_ATT( ntrajid, nlengthid       , 'units'    , 'm'    )
+      iret = NF90_PUT_ATT( ntrajid, nyearid         , 'long_name', 'calendar year' )
+      iret = NF90_PUT_ATT( ntrajid, nyearid         , 'units'    , 'years' )
+      iret = NF90_PUT_ATT( ntrajid, ndayid          , 'long_name', 'day of year' )
+      iret = NF90_PUT_ATT( ntrajid, ndayid          , 'units'    , 'days' )
+      iret = NF90_PUT_ATT( ntrajid, nscaling_id     , 'long_name', 'scaling factor for mass of berg' )
+      iret = NF90_PUT_ATT( ntrajid, nscaling_id     , 'units'    , 'none' )
+      iret = NF90_PUT_ATT( ntrajid, nmass_of_bits_id, 'long_name', 'mass of bergy bits' )
+      iret = NF90_PUT_ATT( ntrajid, nmass_of_bits_id, 'units'    , 'kg'   )
+      iret = NF90_PUT_ATT( ntrajid, nheat_density_id, 'long_name', 'heat density' )
+      iret = NF90_PUT_ATT( ntrajid, nheat_density_id, 'units'    , 'J/kg' )
+      !
+      ! End define mode
+      iret = NF90_ENDDEF( ntrajid )
+      !
+   END SUBROUTINE icb_trj_init
+
+
+   SUBROUTINE icb_trj_write( kt )
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE icb_trj_write  ***
+      !!
+      !! ** Purpose :   write out iceberg trajectories
+      !!
+      !! ** Method  : - for the moment write out each snapshot of positions later
+      !!                can rewrite so that it is buffered and written out more efficiently
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT( in ) ::   kt   ! time-step index
+      !
+      INTEGER                ::   iret, jn
+      CHARACTER(len=80)      ::   cl_filename
+      TYPE(iceberg), POINTER ::   this
+      TYPE(point  ), POINTER ::   pt
+      !!----------------------------------------------------------------------
+
+      ! Write variables
+      ! sga - just write out the current point of the trajectory
+
+      this => first_berg
+      jn = num_traj
+      DO WHILE( ASSOCIATED(this) )
+         pt => this%current_point
+         jn = jn + 1
+         !
+         iret = NF90_PUT_VAR( ntrajid, numberid        , this%number      , (/1,jn/) , (/nkounts,1/) )
+         iret = NF90_PUT_VAR( ntrajid, nstepid         , kt               , (/ jn /) )
+         iret = NF90_PUT_VAR( ntrajid, nscaling_id     , this%mass_scaling, (/ jn /) )
+         !
+         iret = NF90_PUT_VAR( ntrajid, nlonid          , pt%lon           , (/ jn /) )
+         iret = NF90_PUT_VAR( ntrajid, nlatid          , pt%lat           , (/ jn /) )
+         iret = NF90_PUT_VAR( ntrajid, nxid            , pt%xi            , (/ jn /) )
+         iret = NF90_PUT_VAR( ntrajid, nyid            , pt%yj            , (/ jn /) )
+         iret = NF90_PUT_VAR( ntrajid, nuvelid         , pt%uvel          , (/ jn /) )
+         iret = NF90_PUT_VAR( ntrajid, nvvelid         , pt%vvel          , (/ jn /) )
+         iret = NF90_PUT_VAR( ntrajid, nuoid           , pt%uo            , (/ jn /) )
+         iret = NF90_PUT_VAR( ntrajid, nvoid           , pt%vo            , (/ jn /) )
+         iret = NF90_PUT_VAR( ntrajid, nuaid           , pt%ua            , (/ jn /) )
+         iret = NF90_PUT_VAR( ntrajid, nvaid           , pt%va            , (/ jn /) )
+         iret = NF90_PUT_VAR( ntrajid, nuiid           , pt%ui            , (/ jn /) )
+         iret = NF90_PUT_VAR( ntrajid, nviid           , pt%vi            , (/ jn /) )
+         iret = NF90_PUT_VAR( ntrajid, nsshxid         , pt%ssh_x         , (/ jn /) )
+         iret = NF90_PUT_VAR( ntrajid, nsshyid         , pt%ssh_y         , (/ jn /) )
+         iret = NF90_PUT_VAR( ntrajid, nsstid          , pt%sst           , (/ jn /) )
+         iret = NF90_PUT_VAR( ntrajid, ncntid          , pt%cn            , (/ jn /) )
+         iret = NF90_PUT_VAR( ntrajid, nthkid          , pt%hi            , (/ jn /) )
+         iret = NF90_PUT_VAR( ntrajid, nmassid         , pt%mass          , (/ jn /) )
+         iret = NF90_PUT_VAR( ntrajid, nthicknessid    , pt%thickness     , (/ jn /) )
+         iret = NF90_PUT_VAR( ntrajid, nwidthid        , pt%width         , (/ jn /) )
+         iret = NF90_PUT_VAR( ntrajid, nlengthid       , pt%length        , (/ jn /) )
+         iret = NF90_PUT_VAR( ntrajid, nyearid         , pt%year          , (/ jn /) )
+         iret = NF90_PUT_VAR( ntrajid, ndayid          , pt%day           , (/ jn /) )
+         iret = NF90_PUT_VAR( ntrajid, nmass_of_bits_id, pt%mass_of_bits  , (/ jn /) )
+         iret = NF90_PUT_VAR( ntrajid, nheat_density_id, pt%heat_density  , (/ jn /) )
+         !
+         this => this%next
+      END DO
+      IF( lwp .AND. nn_verbose_level > 0 )   WRITE(numout,*) 'trajectory write to frame ', jn
+      num_traj = jn
+      !
+   END SUBROUTINE icb_trj_write
+
+
+   SUBROUTINE icb_trj_sync()
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE icb_trj_sync  ***
+      !!
+      !! ** Purpose :   
+      !!----------------------------------------------------------------------
+      INTEGER ::   iret
+      !!----------------------------------------------------------------------
+      ! flush to file
+      iret = NF90_SYNC( ntrajid )
+      IF ( iret /= NF90_NOERR )   CALL ctl_stop( 'icebergs, icb_trj_sync: nf_sync failed' )
+      !
+   END SUBROUTINE icb_trj_sync
+
+
+   SUBROUTINE icb_trj_end()
+      !!----------------------------------------------------------------------
+      INTEGER ::   iret
+      !!----------------------------------------------------------------------
+      ! Finish up
+      iret = NF90_CLOSE( ntrajid )
+      IF ( iret /= NF90_NOERR )   CALL ctl_stop( 'icebergs, icb_trj_end: nf_close failed' )
+      !
+   END SUBROUTINE icb_trj_end
+
+   !!======================================================================
+END MODULE icbtrj
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/ICB/icbutl.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/ICB/icbutl.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/ICB/icbutl.F90	(revision 9570)
@@ -0,0 +1,791 @@
+MODULE icbutl
+   !!======================================================================
+   !!                       ***  MODULE  icbutl  ***
+   !! Icebergs:  various iceberg utility routines
+   !!======================================================================
+   !! History : 3.3.1 !  2010-01  (Martin&Adcroft) Original code
+   !!            -    !  2011-03  (Madec)          Part conversion to NEMO form
+   !!            -    !                            Removal of mapping from another grid
+   !!            -    !  2011-04  (Alderson)       Split into separate modules
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   icb_utl_interp   :
+   !!   icb_utl_bilin    :
+   !!   icb_utl_bilin_e  :
+   !!----------------------------------------------------------------------
+   USE par_oce                             ! ocean parameters
+   USE dom_oce                             ! ocean domain
+   USE in_out_manager                      ! IO parameters
+   USE lbclnk                              ! lateral boundary condition
+   USE lib_mpp                             ! MPI code and lk_mpp in particular
+   USE icb_oce                             ! define iceberg arrays
+   USE sbc_oce                             ! ocean surface boundary conditions
+#if defined key_si3
+   USE ice,    ONLY: u_ice, v_ice, hm_i    ! LIM-3 variables
+#endif
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   icb_utl_copy          ! routine called in icbstp module
+   PUBLIC   icb_utl_interp        ! routine called in icbdyn, icbthm modules
+   PUBLIC   icb_utl_bilin         ! routine called in icbini, icbdyn modules
+   PUBLIC   icb_utl_bilin_x       ! routine called in icbdyn module
+   PUBLIC   icb_utl_add           ! routine called in icbini.F90, icbclv, icblbc and icbrst modules
+   PUBLIC   icb_utl_delete        ! routine called in icblbc, icbthm modules
+   PUBLIC   icb_utl_destroy       ! routine called in icbstp module
+   PUBLIC   icb_utl_track         ! routine not currently used, retain just in case
+   PUBLIC   icb_utl_print_berg    ! routine called in icbthm module
+   PUBLIC   icb_utl_print         ! routine called in icbini, icbstp module
+   PUBLIC   icb_utl_count         ! routine called in icbdia, icbini, icblbc, icbrst modules
+   PUBLIC   icb_utl_incr          ! routine called in icbini, icbclv modules
+   PUBLIC   icb_utl_yearday       ! routine called in icbclv, icbstp module
+   PUBLIC   icb_utl_mass          ! routine called in icbdia module
+   PUBLIC   icb_utl_heat          ! routine called in icbdia module
+
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO Consortium (2011)
+   !! $Id$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE icb_utl_copy()
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE icb_utl_copy  ***
+      !!
+      !! ** Purpose :   iceberg initialization.
+      !!
+      !! ** Method  : - blah blah
+      !!----------------------------------------------------------------------
+
+      ! copy nemo forcing arrays into iceberg versions with extra halo
+      ! only necessary for variables not on T points
+      ! and ssh which is used to calculate gradients
+
+      uo_e(:,:) = 0._wp   ;   uo_e(1:jpi,1:jpj) = ssu_m(:,:) * umask(:,:,1)
+      vo_e(:,:) = 0._wp   ;   vo_e(1:jpi,1:jpj) = ssv_m(:,:) * vmask(:,:,1)
+      ff_e(:,:) = 0._wp   ;   ff_e(1:jpi,1:jpj) = ff_f (:,:) 
+      tt_e(:,:) = 0._wp   ;   tt_e(1:jpi,1:jpj) = sst_m(:,:)
+      fr_e(:,:) = 0._wp   ;   fr_e(1:jpi,1:jpj) = fr_i (:,:)
+      ua_e(:,:) = 0._wp   ;   ua_e(1:jpi,1:jpj) = utau (:,:) * umask(:,:,1) ! maybe mask useless because mask applied in sbcblk
+      va_e(:,:) = 0._wp   ;   va_e(1:jpi,1:jpj) = vtau (:,:) * vmask(:,:,1) ! maybe mask useless because mask applied in sbcblk
+      !
+      CALL lbc_lnk_icb( uo_e, 'U', -1._wp, 1, 1 )
+      CALL lbc_lnk_icb( vo_e, 'V', -1._wp, 1, 1 )
+      CALL lbc_lnk_icb( ff_e, 'F', +1._wp, 1, 1 )
+      CALL lbc_lnk_icb( ua_e, 'U', -1._wp, 1, 1 )
+      CALL lbc_lnk_icb( va_e, 'V', -1._wp, 1, 1 )
+      CALL lbc_lnk_icb( fr_e, 'T', +1._wp, 1, 1 )
+      CALL lbc_lnk_icb( tt_e, 'T', +1._wp, 1, 1 )
+#if defined key_si3
+      hicth(:,:) = 0._wp ;  hicth(1:jpi,1:jpj) = hm_i (:,:)  
+      ui_e(:,:) = 0._wp ;   ui_e(1:jpi, 1:jpj) = u_ice(:,:)
+      vi_e(:,:) = 0._wp ;   vi_e(1:jpi, 1:jpj) = v_ice(:,:)
+      !
+      CALL lbc_lnk_icb( hicth, 'T', +1._wp, 1, 1 )
+      CALL lbc_lnk_icb( ui_e , 'U', -1._wp, 1, 1 )
+      CALL lbc_lnk_icb( vi_e , 'V', -1._wp, 1, 1 )
+#endif
+
+      !! special for ssh which is used to calculate slope
+      !! so fudge some numbers all the way around the boundary
+
+      ssh_e(:,:) = 0._wp ;   ssh_e(1:jpi, 1:jpj) = ssh_m(:,:) * tmask(:,:,1)
+      ssh_e(0    ,    :) = ssh_e(1  ,  :)
+      ssh_e(jpi+1,    :) = ssh_e(jpi,  :)
+      ssh_e(:    ,    0) = ssh_e(:  ,  1)
+      ssh_e(:    ,jpj+1) = ssh_e(:  ,jpj)
+      ssh_e(0,0)         = ssh_e(1,1)
+      ssh_e(jpi+1,0)     = ssh_e(jpi,1)
+      ssh_e(0,jpj+1)     = ssh_e(1,jpj)
+      ssh_e(jpi+1,jpj+1) = ssh_e(jpi,jpj)
+      CALL lbc_lnk_icb( ssh_e, 'T', +1._wp, 1, 1 )
+      !
+   END SUBROUTINE icb_utl_copy
+
+
+   SUBROUTINE icb_utl_interp( pi, pe1, puo, pui, pua, pssh_i,   &
+      &                       pj, pe2, pvo, pvi, pva, pssh_j,   &
+      &                       psst, pcn, phi, pff            )
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE icb_utl_interp  ***
+      !!
+      !! ** Purpose :   interpolation
+      !!
+      !! ** Method  : - interpolate from various ocean arrays onto iceberg position
+      !!
+      !!       !!gm  CAUTION here I do not care of the slip/no-slip conditions
+      !!             this can be done later (not that easy to do...)
+      !!             right now, U is 0 in land so that the coastal value of velocity parallel to the coast
+      !!             is half the off shore value, wile the normal-to-the-coast value is zero.
+      !!             This is OK as a starting point.
+      !!
+      !!----------------------------------------------------------------------
+      REAL(wp), INTENT(in   ) ::   pi , pj                        ! position in (i,j) referential
+      REAL(wp), INTENT(  out) ::   pe1, pe2                       ! i- and j scale factors
+      REAL(wp), INTENT(  out) ::   puo, pvo, pui, pvi, pua, pva   ! ocean, ice and wind speeds
+      REAL(wp), INTENT(  out) ::   pssh_i, pssh_j                 ! ssh i- & j-gradients
+      REAL(wp), INTENT(  out) ::   psst, pcn, phi, pff            ! SST, ice concentration, ice thickness, Coriolis
+      !
+      REAL(wp) ::   zcd, zmod       ! local scalars
+      !!----------------------------------------------------------------------
+
+      pe1 = icb_utl_bilin_e( e1t, e1u, e1v, e1f, pi, pj )     ! scale factors
+      pe2 = icb_utl_bilin_e( e2t, e2u, e2v, e2f, pi, pj )
+      !
+      puo  = icb_utl_bilin_h( uo_e, pi, pj, 'U' )             ! ocean velocities
+      pvo  = icb_utl_bilin_h( vo_e, pi, pj, 'V' )
+      psst = icb_utl_bilin_h( tt_e, pi, pj, 'T' )             ! SST
+      pcn  = icb_utl_bilin_h( fr_e , pi, pj, 'T' )            ! ice concentration
+      pff  = icb_utl_bilin_h( ff_e , pi, pj, 'F' )            ! Coriolis parameter
+      !
+      pua  = icb_utl_bilin_h( ua_e , pi, pj, 'U' )            ! 10m wind
+      pva  = icb_utl_bilin_h( va_e , pi, pj, 'V' )            ! here (ua,va) are stress => rough conversion from stress to speed
+      zcd  = 1.22_wp * 1.5e-3_wp                              ! air density * drag coefficient
+      zmod = 1._wp / MAX(  1.e-20, SQRT(  zcd * SQRT( pua*pua + pva*pva)  )  )
+      pua  = pua * zmod                                       ! note: stress module=0 necessarly implies ua=va=0
+      pva  = pva * zmod
+
+#if defined key_si3
+      pui = icb_utl_bilin_h( ui_e , pi, pj, 'U' )              ! sea-ice velocities
+      pvi = icb_utl_bilin_h( vi_e , pi, pj, 'V' )
+      phi = icb_utl_bilin_h( hicth, pi, pj, 'T' )              ! ice thickness
+#else
+      pui = 0._wp
+      pvi = 0._wp
+      phi = 0._wp
+#endif
+
+      ! Estimate SSH gradient in i- and j-direction (centred evaluation)
+      pssh_i = ( icb_utl_bilin_h( ssh_e, pi+0.1_wp, pj, 'T' ) -   &
+         &       icb_utl_bilin_h( ssh_e, pi-0.1_wp, pj, 'T' )  ) / ( 0.2_wp * pe1 )
+      pssh_j = ( icb_utl_bilin_h( ssh_e, pi, pj+0.1_wp, 'T' ) -   &
+         &       icb_utl_bilin_h( ssh_e, pi, pj-0.1_wp, 'T' )  ) / ( 0.2_wp * pe2 )
+      !
+   END SUBROUTINE icb_utl_interp
+
+
+   REAL(wp) FUNCTION icb_utl_bilin_h( pfld, pi, pj, cd_type )
+      !!----------------------------------------------------------------------
+      !!                  ***  FUNCTION icb_utl_bilin  ***
+      !!
+      !! ** Purpose :   bilinear interpolation at berg location depending on the grid-point type
+      !!                this version deals with extra halo points
+      !!
+      !!       !!gm  CAUTION an optional argument should be added to handle
+      !!             the slip/no-slip conditions  ==>>> to be done later
+      !!
+      !!----------------------------------------------------------------------
+      REAL(wp), DIMENSION(0:jpi+1,0:jpj+1), INTENT(in) ::   pfld      ! field to be interpolated
+      REAL(wp)                            , INTENT(in) ::   pi, pj    ! targeted coordinates in (i,j) referential
+      CHARACTER(len=1)                    , INTENT(in) ::   cd_type   ! type of pfld array grid-points: = T , U , V or F points
+      !
+      INTEGER  ::   ii, ij   ! local integer
+      REAL(wp) ::   zi, zj   ! local real
+      !!----------------------------------------------------------------------
+      !
+      SELECT CASE ( cd_type )
+      CASE ( 'T' )
+         ! note that here there is no +0.5 added
+         ! since we're looking for four T points containing quadrant we're in of 
+         ! current T cell
+         ii = MAX(1, INT( pi     ))
+         ij = MAX(1, INT( pj     ))    ! T-point
+         zi = pi - REAL(ii,wp)
+         zj = pj - REAL(ij,wp)
+      CASE ( 'U' )
+         ii = MAX(1, INT( pi-0.5 ))
+         ij = MAX(1, INT( pj     ))    ! U-point
+         zi = pi - 0.5 - REAL(ii,wp)
+         zj = pj - REAL(ij,wp)
+      CASE ( 'V' )
+         ii = MAX(1, INT( pi     ))
+         ij = MAX(1, INT( pj-0.5 ))    ! V-point
+         zi = pi - REAL(ii,wp)
+         zj = pj - 0.5 - REAL(ij,wp)
+      CASE ( 'F' )
+         ii = MAX(1, INT( pi-0.5 ))
+         ij = MAX(1, INT( pj-0.5 ))    ! F-point
+         zi = pi - 0.5 - REAL(ii,wp)
+         zj = pj - 0.5 - REAL(ij,wp)
+      END SELECT
+      !
+      ! find position in this processor. Prevent near edge problems (see #1389)
+      !
+      IF    ( ii < mig( 1 ) ) THEN   ;   ii = 1
+      ELSEIF( ii > mig(jpi) ) THEN   ;   ii = jpi
+      ELSE                           ;   ii = mi1(ii)
+      ENDIF
+      IF    ( ij < mjg( 1 ) ) THEN   ;   ij = 1
+      ELSEIF( ij > mjg(jpj) ) THEN   ;   ij = jpj
+      ELSE                           ;   ij  = mj1(ij)
+      ENDIF
+      !
+      IF( ii == jpi )   ii = ii-1      
+      IF( ij == jpj )   ij = ij-1
+      !
+      icb_utl_bilin_h = ( pfld(ii,ij  ) * (1.-zi) + pfld(ii+1,ij  ) * zi ) * (1.-zj)   &
+         &            + ( pfld(ii,ij+1) * (1.-zi) + pfld(ii+1,ij+1) * zi ) *     zj
+      !
+   END FUNCTION icb_utl_bilin_h
+
+
+   REAL(wp) FUNCTION icb_utl_bilin( pfld, pi, pj, cd_type )
+      !!----------------------------------------------------------------------
+      !!                  ***  FUNCTION icb_utl_bilin  ***
+      !!
+      !! ** Purpose :   bilinear interpolation at berg location depending on the grid-point type
+      !!
+      !!       !!gm  CAUTION an optional argument should be added to handle
+      !!             the slip/no-slip conditions  ==>>> to be done later
+      !!
+      !!----------------------------------------------------------------------
+      REAL(wp), DIMENSION(jpi,jpj), INTENT(in) ::   pfld      ! field to be interpolated
+      REAL(wp)                    , INTENT(in) ::   pi, pj    ! targeted coordinates in (i,j) referential
+      CHARACTER(len=1)            , INTENT(in) ::   cd_type   ! type of pfld array grid-points: = T , U , V or F points
+      !
+      INTEGER  ::   ii, ij   ! local integer
+      REAL(wp) ::   zi, zj   ! local real
+      !!----------------------------------------------------------------------
+      !
+      SELECT CASE ( cd_type )
+         CASE ( 'T' )
+            ! note that here there is no +0.5 added
+            ! since we're looking for four T points containing quadrant we're in of 
+            ! current T cell
+            ii = MAX(1, INT( pi     ))
+            ij = MAX(1, INT( pj     ))    ! T-point
+            zi = pi - REAL(ii,wp)
+            zj = pj - REAL(ij,wp)
+         CASE ( 'U' )
+            ii = MAX(1, INT( pi-0.5 ))
+            ij = MAX(1, INT( pj     ))    ! U-point
+            zi = pi - 0.5 - REAL(ii,wp)
+            zj = pj - REAL(ij,wp)
+         CASE ( 'V' )
+            ii = MAX(1, INT( pi     ))
+            ij = MAX(1, INT( pj-0.5 ))    ! V-point
+            zi = pi - REAL(ii,wp)
+            zj = pj - 0.5 - REAL(ij,wp)
+         CASE ( 'F' )
+            ii = MAX(1, INT( pi-0.5 ))
+            ij = MAX(1, INT( pj-0.5 ))    ! F-point
+            zi = pi - 0.5 - REAL(ii,wp)
+            zj = pj - 0.5 - REAL(ij,wp)
+      END SELECT
+      !
+      ! find position in this processor. Prevent near edge problems (see #1389)
+      IF    ( ii < mig( 1 ) ) THEN   ;   ii = 1
+      ELSEIF( ii > mig(jpi) ) THEN   ;   ii = jpi
+      ELSE                           ;   ii = mi1(ii)
+      ENDIF
+      IF    ( ij < mjg( 1 ) ) THEN   ;   ij = 1
+      ELSEIF( ij > mjg(jpj) ) THEN   ;   ij = jpj
+      ELSE                           ;   ij  = mj1(ij)
+      ENDIF
+      !
+      IF( ii == jpi )   ii = ii-1      
+      IF( ij == jpj )   ij = ij-1
+      !
+      icb_utl_bilin = ( pfld(ii,ij  ) * (1.-zi) + pfld(ii+1,ij  ) * zi ) * (1.-zj)   &
+         &          + ( pfld(ii,ij+1) * (1.-zi) + pfld(ii+1,ij+1) * zi ) *     zj
+      !
+   END FUNCTION icb_utl_bilin
+
+
+   REAL(wp) FUNCTION icb_utl_bilin_x( pfld, pi, pj )
+      !!----------------------------------------------------------------------
+      !!                  ***  FUNCTION icb_utl_bilin_x  ***
+      !!
+      !! ** Purpose :   bilinear interpolation at berg location depending on the grid-point type
+      !!                Special case for interpolating longitude
+      !!
+      !!       !!gm  CAUTION an optional argument should be added to handle
+      !!             the slip/no-slip conditions  ==>>> to be done later
+      !!
+      !!----------------------------------------------------------------------
+      REAL(wp), DIMENSION(jpi,jpj), INTENT(in) ::   pfld      ! field to be interpolated
+      REAL(wp)                    , INTENT(in) ::   pi, pj    ! targeted coordinates in (i,j) referential
+      !
+      INTEGER                                  ::   ii, ij   ! local integer
+      REAL(wp)                                 ::   zi, zj   ! local real
+      REAL(wp)                                 ::   zret     ! local real
+      REAL(wp), DIMENSION(4)                   ::   z4
+      !!----------------------------------------------------------------------
+      !
+      ! note that here there is no +0.5 added
+      ! since we're looking for four T points containing quadrant we're in of 
+      ! current T cell
+      ii = MAX(1, INT( pi     ))
+      ij = MAX(1, INT( pj     ))    ! T-point
+      zi = pi - REAL(ii,wp)
+      zj = pj - REAL(ij,wp)
+      !
+      ! find position in this processor. Prevent near edge problems (see #1389)
+      IF    ( ii < mig( 1 ) ) THEN   ;   ii = 1
+      ELSEIF( ii > mig(jpi) ) THEN   ;   ii = jpi
+      ELSE                           ;   ii = mi1(ii)
+      ENDIF
+      IF    ( ij < mjg( 1 ) ) THEN   ;   ij = 1
+      ELSEIF( ij > mjg(jpj) ) THEN   ;   ij = jpj
+      ELSE                           ;   ij  = mj1(ij)
+      ENDIF
+      !
+      IF( ii == jpi )   ii = ii-1      
+      IF( ij == jpj )   ij = ij-1
+      !
+      z4(1) = pfld(ii  ,ij  )
+      z4(2) = pfld(ii+1,ij  )
+      z4(3) = pfld(ii  ,ij+1)
+      z4(4) = pfld(ii+1,ij+1)
+      IF( MAXVAL(z4) - MINVAL(z4) > 90._wp ) THEN
+         WHERE( z4 < 0._wp ) z4 = z4 + 360._wp
+      ENDIF
+      !
+      zret = (z4(1) * (1.-zi) + z4(2) * zi) * (1.-zj) + (z4(3) * (1.-zi) + z4(4) * zi) * zj
+      IF( zret > 180._wp ) zret = zret - 360._wp
+      icb_utl_bilin_x = zret
+      !
+   END FUNCTION icb_utl_bilin_x
+
+
+   REAL(wp) FUNCTION icb_utl_bilin_e( pet, peu, pev, pef, pi, pj )
+      !!----------------------------------------------------------------------
+      !!                  ***  FUNCTION dom_init  ***
+      !!
+      !! ** Purpose :   bilinear interpolation at berg location of horizontal scale factor
+      !! ** Method  :   interpolation done using the 4 nearest grid points among
+      !!                t-, u-, v-, and f-points.
+      !!----------------------------------------------------------------------
+      REAL(wp), DIMENSION(:,:), INTENT(in) ::   pet, peu, pev, pef   ! horizontal scale factor to be interpolated at t-,u-,v- & f-pts
+      REAL(wp)                , INTENT(in) ::   pi, pj               ! targeted coordinates in (i,j) referential
+      !
+      INTEGER  ::   ii, ij, icase   ! local integer
+      !
+      ! weights corresponding to corner points of a T cell quadrant
+      REAL(wp) ::   zi, zj          ! local real
+      !
+      ! values at corner points of a T cell quadrant
+      ! 00 = bottom left, 10 = bottom right, 01 = top left, 11 = top right
+      REAL(wp) ::   ze00, ze10, ze01, ze11
+      !!----------------------------------------------------------------------
+      !
+      ii = MAX(1, INT( pi ))   ;   ij = MAX(1, INT( pj ))            ! left bottom T-point (i,j) indices
+
+      ! fractional box spacing
+      ! 0   <= zi < 0.5, 0   <= zj < 0.5   -->  NW quadrant of current T cell
+      ! 0.5 <= zi < 1  , 0   <= zj < 0.5   -->  NE quadrant
+      ! 0   <= zi < 0.5, 0.5 <= zj < 1     -->  SE quadrant
+      ! 0.5 <= zi < 1  , 0.5 <= zj < 1     -->  SW quadrant
+
+      zi = pi - REAL(ii,wp)          !!gm use here mig, mjg arrays
+      zj = pj - REAL(ij,wp)
+
+      ! find position in this processor. Prevent near edge problems (see #1389)
+      IF    ( ii < mig( 1 ) ) THEN   ;   ii = 1
+      ELSEIF( ii > mig(jpi) ) THEN   ;   ii = jpi
+      ELSE                           ;   ii = mi1(ii)
+      ENDIF
+      IF    ( ij < mjg( 1 ) ) THEN   ;   ij = 1
+      ELSEIF( ij > mjg(jpj) ) THEN   ;   ij = jpj
+      ELSE                           ;   ij  = mj1(ij)
+      ENDIF
+      !
+      IF( ii == jpi )   ii = ii-1      
+      IF( ij == jpj )   ij = ij-1
+      !
+      IF(    0.0_wp <= zi .AND. zi < 0.5_wp   ) THEN
+         IF( 0.0_wp <= zj .AND. zj < 0.5_wp        )   THEN        !  NE quadrant
+            !                                                      !             i=I       i=I+1/2
+            ze01 = pev(ii  ,ij  )   ;   ze11 = pef(ii  ,ij  )      !   j=J+1/2    V ------- F
+            ze00 = pet(ii  ,ij  )   ;   ze10 = peu(ii  ,ij  )      !   j=J        T ------- U
+            zi = 2._wp * zi
+            zj = 2._wp * zj
+         ELSE                                                      !  SE quadrant
+            !                                                                    !             i=I       i=I+1/2
+            ze01 = pet(ii  ,ij+1)   ;   ze11 = peu(ii  ,ij+1)      !   j=J+1      T ------- U
+            ze00 = pev(ii  ,ij  )   ;   ze10 = pef(ii  ,ij  )      !   j=J+1/2    V ------- F
+            zi = 2._wp *  zi
+            zj = 2._wp * (zj-0.5_wp)
+         ENDIF
+      ELSE
+         IF( 0.0_wp <= zj .AND. zj < 0.5_wp        )   THEN        !  NW quadrant
+            !                                                                    !             i=I       i=I+1/2
+            ze01 = pef(ii  ,ij  )   ;   ze11 = pev(ii+1,ij)        !   j=J+1/2    F ------- V
+            ze00 = peu(ii  ,ij  )   ;   ze10 = pet(ii+1,ij)        !   j=J        U ------- T
+            zi = 2._wp * (zi-0.5_wp)
+            zj = 2._wp *  zj
+         ELSE                                                      !  SW quadrant
+            !                                                                    !             i=I+1/2   i=I+1
+            ze01 = peu(ii  ,ij+1)   ;   ze11 = pet(ii+1,ij+1)      !   j=J+1      U ------- T
+            ze00 = pef(ii  ,ij  )   ;   ze10 = pev(ii+1,ij  )      !   j=J+1/2    F ------- V
+            zi = 2._wp * (zi-0.5_wp)
+            zj = 2._wp * (zj-0.5_wp)
+         ENDIF
+      ENDIF
+      !
+      icb_utl_bilin_e = ( ze01 * (1.-zi) + ze11 * zi ) *     zj    &
+         &            + ( ze00 * (1.-zi) + ze10 * zi ) * (1.-zj)
+      !
+   END FUNCTION icb_utl_bilin_e
+
+
+   SUBROUTINE icb_utl_add( bergvals, ptvals )
+      !!----------------------------------------------------------------------
+      !!                ***  ROUTINE icb_utl_add           ***
+      !!
+      !! ** Purpose :   add a new berg to the iceberg list
+      !!
+      !!----------------------------------------------------------------------
+      TYPE(iceberg), INTENT(in)           ::   bergvals
+      TYPE(point)  , INTENT(in)           ::   ptvals
+      !
+      TYPE(iceberg), POINTER ::   new => NULL()
+      !!----------------------------------------------------------------------
+      !
+      new => NULL()
+      CALL icb_utl_create( new, bergvals, ptvals )
+      CALL icb_utl_insert( new )
+      new => NULL()     ! Clear new
+      !
+   END SUBROUTINE icb_utl_add         
+
+
+   SUBROUTINE icb_utl_create( berg, bergvals, ptvals )
+      !!----------------------------------------------------------------------
+      !!                ***  ROUTINE icb_utl_create  ***
+      !!
+      !! ** Purpose :   add a new berg to the iceberg list
+      !!
+      !!----------------------------------------------------------------------
+      TYPE(iceberg), INTENT(in) ::   bergvals
+      TYPE(point)  , INTENT(in) ::   ptvals
+      TYPE(iceberg), POINTER    ::   berg
+      !
+      TYPE(point)  , POINTER    ::   pt
+      INTEGER                   ::   istat
+      !!----------------------------------------------------------------------
+      !
+      IF( ASSOCIATED(berg) )   CALL ctl_stop( 'icebergs, icb_utl_create: berg already associated' )
+      ALLOCATE(berg, STAT=istat)
+      IF( istat /= 0 ) CALL ctl_stop( 'failed to allocate iceberg' )
+      berg%number(:) = bergvals%number(:)
+      berg%mass_scaling = bergvals%mass_scaling
+      berg%prev => NULL()
+      berg%next => NULL()
+      !
+      ALLOCATE(pt, STAT=istat)
+      IF( istat /= 0 ) CALL ctl_stop( 'failed to allocate first iceberg point' )
+      pt = ptvals
+      berg%current_point => pt
+      !
+   END SUBROUTINE icb_utl_create
+
+
+   SUBROUTINE icb_utl_insert( newberg )
+      !!----------------------------------------------------------------------
+      !!                 ***  ROUTINE icb_utl_insert  ***
+      !!
+      !! ** Purpose :   add a new berg to the iceberg list
+      !!
+      !!----------------------------------------------------------------------
+      TYPE(iceberg), POINTER  ::   newberg
+      !
+      TYPE(iceberg), POINTER  ::   this, prev, last
+      !!----------------------------------------------------------------------
+      !
+      IF( ASSOCIATED( first_berg ) ) THEN
+         last => first_berg
+         DO WHILE (ASSOCIATED(last%next))
+            last => last%next
+         ENDDO
+         newberg%prev => last
+         last%next    => newberg
+         last         => newberg
+      ELSE                       ! list is empty so create it
+         first_berg => newberg
+      ENDIF
+      !
+   END SUBROUTINE icb_utl_insert
+
+
+   REAL(wp) FUNCTION icb_utl_yearday(kmon, kday, khr, kmin, ksec)
+      !!----------------------------------------------------------------------
+      !!                 ***  FUNCTION icb_utl_yearday  ***
+      !!
+      !! ** Purpose :   
+      !!
+      ! sga - improved but still only applies to 365 day year, need to do this properly
+      !
+      !!gm  all these info are already known in daymod, no???
+      !!
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT(in)     :: kmon, kday, khr, kmin, ksec
+      ! 
+      INTEGER, DIMENSION(12)  :: imonths = (/ 0,31,28,31,30,31,30,31,31,30,31,30 /)
+      !!----------------------------------------------------------------------
+      !
+      icb_utl_yearday = REAL( SUM( imonths(1:kmon) ), wp )
+      icb_utl_yearday = icb_utl_yearday + REAL(kday-1,wp) + (REAL(khr,wp) + (REAL(kmin,wp) + REAL(ksec,wp)/60.)/60.)/24.
+      !
+   END FUNCTION icb_utl_yearday
+
+   !!-------------------------------------------------------------------------
+
+   SUBROUTINE icb_utl_delete( first, berg )
+      !!----------------------------------------------------------------------
+      !!                 ***  ROUTINE icb_utl_delete  ***
+      !!
+      !! ** Purpose :   
+      !!
+      !!----------------------------------------------------------------------
+      TYPE(iceberg), POINTER :: first, berg
+      !!----------------------------------------------------------------------
+      ! Connect neighbors to each other
+      IF ( ASSOCIATED(berg%prev) ) THEN
+        berg%prev%next => berg%next
+      ELSE
+        first => berg%next
+      ENDIF
+      IF (ASSOCIATED(berg%next)) berg%next%prev => berg%prev
+      !
+      CALL icb_utl_destroy(berg)
+      !
+   END SUBROUTINE icb_utl_delete
+
+
+   SUBROUTINE icb_utl_destroy( berg )
+      !!----------------------------------------------------------------------
+      !!                 ***  ROUTINE icb_utl_destroy  ***
+      !!
+      !! ** Purpose :   remove a single iceberg instance
+      !!
+      !!----------------------------------------------------------------------
+      TYPE(iceberg), POINTER :: berg
+      !!----------------------------------------------------------------------
+      !
+      ! Remove any points
+      IF( ASSOCIATED( berg%current_point ) )   DEALLOCATE( berg%current_point )
+      !
+      DEALLOCATE(berg)
+      !
+   END SUBROUTINE icb_utl_destroy
+
+
+   SUBROUTINE icb_utl_track( knum, cd_label, kt )
+      !!----------------------------------------------------------------------
+      !!                 ***  ROUTINE icb_utl_track  ***
+      !!
+      !! ** Purpose :   
+      !!
+      !!----------------------------------------------------------------------
+      INTEGER, DIMENSION(nkounts)    :: knum       ! iceberg number
+      CHARACTER(len=*)               :: cd_label   ! 
+      INTEGER                        :: kt         ! timestep number
+      ! 
+      TYPE(iceberg), POINTER         :: this
+      LOGICAL                        :: match
+      INTEGER                        :: k
+      !!----------------------------------------------------------------------
+      !
+      this => first_berg
+      DO WHILE( ASSOCIATED(this) )
+         match = .TRUE.
+         DO k = 1, nkounts
+            IF( this%number(k) /= knum(k) ) match = .FALSE.
+         END DO
+         IF( match )   CALL icb_utl_print_berg(this, kt)
+         this => this%next
+      END DO
+      !
+   END SUBROUTINE icb_utl_track
+
+
+   SUBROUTINE icb_utl_print_berg( berg, kt )
+      !!----------------------------------------------------------------------
+      !!                 ***  ROUTINE icb_utl_print_berg  ***
+      !!
+      !! ** Purpose :   print one
+      !!
+      !!----------------------------------------------------------------------
+      TYPE(iceberg), POINTER :: berg
+      TYPE(point)  , POINTER :: pt
+      INTEGER                :: kt      ! timestep number
+      !!----------------------------------------------------------------------
+      !
+      pt => berg%current_point
+      WRITE(numicb, 9200) kt, berg%number(1), &
+                   pt%xi, pt%yj, pt%lon, pt%lat, pt%uvel, pt%vvel,  &
+                   pt%uo, pt%vo, pt%ua, pt%va, pt%ui, pt%vi
+      CALL flush( numicb )
+ 9200 FORMAT(5x,i5,2x,i10,6(2x,2f10.4))
+      !
+   END SUBROUTINE icb_utl_print_berg
+
+
+   SUBROUTINE icb_utl_print( cd_label, kt )
+      !!----------------------------------------------------------------------
+      !!                 ***  ROUTINE icb_utl_print  ***
+      !!
+      !! ** Purpose :   print many
+      !!
+      !!----------------------------------------------------------------------
+      CHARACTER(len=*)       :: cd_label
+      INTEGER                :: kt             ! timestep number
+      ! 
+      INTEGER                :: ibergs, inbergs
+      TYPE(iceberg), POINTER :: this
+      !!----------------------------------------------------------------------
+      !
+      this => first_berg
+      IF( ASSOCIATED(this) ) THEN
+         WRITE(numicb,'(a," pe=(",i3,")")' ) cd_label, narea
+         WRITE(numicb,'(a8,4x,a6,12x,a5,15x,a7,19x,a3,17x,a5,17x,a5,17x,a5)' )   &
+            &         'timestep', 'number', 'xi,yj','lon,lat','u,v','uo,vo','ua,va','ui,vi'
+      ENDIF
+      DO WHILE( ASSOCIATED(this) )
+        CALL icb_utl_print_berg(this, kt)
+        this => this%next
+      END DO
+      ibergs = icb_utl_count()
+      inbergs = ibergs
+      IF( lk_mpp )   CALL mpp_sum(inbergs)
+      IF( ibergs > 0 )   WRITE(numicb,'(a," there are",i5," bergs out of",i6," on PE ",i4)')   &
+         &                                  cd_label, ibergs, inbergs, narea
+      !
+   END SUBROUTINE icb_utl_print
+
+
+   SUBROUTINE icb_utl_incr()
+      !!----------------------------------------------------------------------
+      !!                 ***  ROUTINE icb_utl_incr  ***
+      !!
+      !! ** Purpose :   
+      !!
+      ! Small routine for coping with very large integer values labelling icebergs
+      ! num_bergs is a array of integers
+      ! the first member is incremented in steps of jpnij starting from narea
+      ! this means each iceberg is labelled with a unique number
+      ! when this gets to the maximum allowed integer the second and subsequent members are 
+      ! used to count how many times the member before cycles
+      !!----------------------------------------------------------------------
+      INTEGER ::   ii, ibig
+      !!----------------------------------------------------------------------
+
+      ibig = HUGE(num_bergs(1))
+      IF( ibig-jpnij < num_bergs(1) ) THEN
+         num_bergs(1) = narea
+         DO ii = 2,nkounts
+            IF( num_bergs(ii) == ibig ) THEN
+               num_bergs(ii) = 0
+               IF( ii == nkounts ) CALL ctl_stop('Sorry, run out of iceberg number space')
+            ELSE
+               num_bergs(ii) = num_bergs(ii) + 1
+               EXIT
+            ENDIF
+         END DO
+      ELSE
+         num_bergs(1) = num_bergs(1) + jpnij
+      ENDIF
+      !
+   END SUBROUTINE icb_utl_incr
+
+
+   INTEGER FUNCTION icb_utl_count()
+      !!----------------------------------------------------------------------
+      !!                 ***  FUNCTION icb_utl_count  ***
+      !!
+      !! ** Purpose :   
+      !!----------------------------------------------------------------------
+      TYPE(iceberg), POINTER :: this
+      !!----------------------------------------------------------------------
+      !
+      icb_utl_count = 0
+      this => first_berg
+      DO WHILE( ASSOCIATED(this) )
+         icb_utl_count = icb_utl_count+1
+         this => this%next
+      END DO
+      !
+   END FUNCTION icb_utl_count
+
+
+   REAL(wp) FUNCTION icb_utl_mass( first, justbits, justbergs )
+      !!----------------------------------------------------------------------
+      !!                 ***  FUNCTION icb_utl_mass  ***
+      !!
+      !! ** Purpose :   compute the mass all iceberg, all berg bits or all bergs.
+      !!----------------------------------------------------------------------
+      TYPE(iceberg)      , POINTER  ::   first
+      TYPE(point)        , POINTER  ::   pt
+      LOGICAL, INTENT(in), OPTIONAL ::   justbits, justbergs
+      !
+      TYPE(iceberg), POINTER ::   this
+      !!----------------------------------------------------------------------
+      icb_utl_mass = 0._wp
+      this => first
+      !
+      IF( PRESENT( justbergs  ) ) THEN
+         DO WHILE( ASSOCIATED( this ) )
+            pt => this%current_point
+            icb_utl_mass = icb_utl_mass + pt%mass         * this%mass_scaling
+            this => this%next
+         END DO
+      ELSEIF( PRESENT(justbits) ) THEN
+         DO WHILE( ASSOCIATED( this ) )
+            pt => this%current_point
+            icb_utl_mass = icb_utl_mass + pt%mass_of_bits * this%mass_scaling
+            this => this%next
+         END DO
+      ELSE
+         DO WHILE( ASSOCIATED( this ) )
+            pt => this%current_point
+            icb_utl_mass = icb_utl_mass + ( pt%mass + pt%mass_of_bits ) * this%mass_scaling
+            this => this%next
+         END DO
+      ENDIF
+      !
+   END FUNCTION icb_utl_mass
+
+
+   REAL(wp) FUNCTION icb_utl_heat( first, justbits, justbergs )
+      !!----------------------------------------------------------------------
+      !!                 ***  FUNCTION icb_utl_heat  ***
+      !!
+      !! ** Purpose :   compute the heat in all iceberg, all bergies or all bergs.
+      !!----------------------------------------------------------------------
+      TYPE(iceberg)      , POINTER  ::   first
+      LOGICAL, INTENT(in), OPTIONAL ::   justbits, justbergs
+      !
+      TYPE(iceberg)      , POINTER  ::   this
+      TYPE(point)        , POINTER  ::   pt
+      !!----------------------------------------------------------------------
+      icb_utl_heat = 0._wp
+      this => first
+      !
+      IF( PRESENT( justbergs  ) ) THEN
+         DO WHILE( ASSOCIATED( this ) )
+            pt => this%current_point
+            icb_utl_heat = icb_utl_heat + pt%mass         * this%mass_scaling * pt%heat_density
+            this => this%next
+         END DO
+      ELSEIF( PRESENT(justbits) ) THEN
+         DO WHILE( ASSOCIATED( this ) )
+            pt => this%current_point
+            icb_utl_heat = icb_utl_heat + pt%mass_of_bits * this%mass_scaling * pt%heat_density
+            this => this%next
+         END DO
+      ELSE
+         DO WHILE( ASSOCIATED( this ) )
+            pt => this%current_point
+            icb_utl_heat = icb_utl_heat + ( pt%mass + pt%mass_of_bits ) * this%mass_scaling * pt%heat_density
+            this => this%next
+         END DO
+      ENDIF
+      !
+   END FUNCTION icb_utl_heat
+
+   !!======================================================================
+END MODULE icbutl
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/IOM/in_out_manager.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/IOM/in_out_manager.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/IOM/in_out_manager.F90	(revision 9570)
@@ -0,0 +1,164 @@
+MODULE in_out_manager   
+   !!======================================================================
+   !!                       ***  MODULE  in_out_manager  ***
+   !! I/O manager utilities : Defines run parameters together with logical units
+   !!=====================================================================
+   !! History :   1.0  !  2002-06  (G. Madec)   original code
+   !!             2.0  !  2006-07  (S. Masson)  iom, add ctl_stop, ctl_warn
+   !!             3.0  !  2008-06  (G. Madec)   add ctmp4 to ctmp10
+   !!             3.2  !  2009-08  (S. MAsson)  add new ctl_opn
+   !!             3.3  !  2010-10  (A. Coward)  add NetCDF4 usage
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   USE par_oce       ! ocean parameter
+   USE nc4interface  ! NetCDF4 interface
+
+   IMPLICIT NONE
+   PUBLIC
+
+   !!----------------------------------------------------------------------
+   !!                   namrun namelist parameters
+   !!----------------------------------------------------------------------
+   CHARACTER(lc) ::   cn_exp           !: experiment name used for output filename
+   CHARACTER(lc) ::   cn_ocerst_in     !: suffix of ocean restart name (input)
+   CHARACTER(lc) ::   cn_ocerst_indir  !: restart input directory
+   CHARACTER(lc) ::   cn_ocerst_out    !: suffix of ocean restart name (output)
+   CHARACTER(lc) ::   cn_ocerst_outdir !: restart output directory
+   LOGICAL       ::   ln_rstart        !: start from (F) rest or (T) a restart file
+   LOGICAL       ::   ln_rst_list      !: output restarts at list of times (T) or by frequency (F)
+   INTEGER       ::   nn_rstctl        !: control of the time step (0, 1 or 2)
+   INTEGER       ::   nn_rstssh   = 0  !: hand made initilization of ssh or not (1/0)
+   INTEGER       ::   nn_it000         !: index of the first time step
+   INTEGER       ::   nn_itend         !: index of the last time step
+   INTEGER       ::   nn_date0         !: initial calendar date aammjj
+   INTEGER       ::   nn_time0         !: initial time of day in hhmm
+   INTEGER       ::   nn_leapy         !: Leap year calendar flag (0/1 or 30)
+   INTEGER       ::   nn_istate        !: initial state output flag (0/1)
+   INTEGER       ::   nn_write         !: model standard output frequency
+   INTEGER       ::   nn_stock         !: restart file frequency
+   INTEGER, DIMENSION(10) :: nn_stocklist  !: restart dump times
+   LOGICAL       ::   ln_mskland       !: mask land points in NetCDF outputs (costly: + ~15%)
+   LOGICAL       ::   ln_cfmeta        !: output additional data to netCDF files required for compliance with the CF metadata standard
+   LOGICAL       ::   ln_clobber       !: clobber (overwrite) an existing file
+   INTEGER       ::   nn_chunksz       !: chunksize (bytes) for NetCDF file (works only with iom_nf90 routines)
+   LOGICAL       ::   ln_xios_read     !: use xios to read single file restart
+   INTEGER       ::   nn_wxios         !: write resart using xios 0 - no, 1 - single, 2 - multiple file output
+   INTEGER       ::   nn_no            !: Assimilation cycle
+
+#if defined key_netcdf4
+   !!----------------------------------------------------------------------
+   !!                   namnc4 namelist parameters                         (key_netcdf4)
+   !!----------------------------------------------------------------------
+   ! The following four values determine the partitioning of the output fields
+   ! into netcdf4 chunks. They are unrelated to the nn_chunk_sz setting which is
+   ! for runtime optimisation. The individual netcdf4 chunks can be optionally 
+   ! gzipped (recommended) leading to significant reductions in I/O volumes 
+   !                         !!!**  variables only used with iom_nf90 routines and key_netcdf4 **
+   INTEGER ::   nn_nchunks_i   !: number of chunks required in the i-dimension 
+   INTEGER ::   nn_nchunks_j   !: number of chunks required in the j-dimension 
+   INTEGER ::   nn_nchunks_k   !: number of chunks required in the k-dimension 
+   INTEGER ::   nn_nchunks_t   !: number of chunks required in the t-dimension 
+   LOGICAL ::   ln_nc4zip      !: netcdf4 usage: (T) chunk and compress output using the HDF5 sublayers of netcdf4
+   !                           !                 (F) ignore chunking request and use the netcdf4 library 
+   !                           !                     to produce netcdf3-compatible files 
+#endif
+
+!$AGRIF_DO_NOT_TREAT
+   TYPE(snc4_ctl)     :: snc4set        !: netcdf4 chunking control structure (always needed for decision making)
+!$AGRIF_END_DO_NOT_TREAT
+
+
+   !! conversion of DOCTOR norm namelist name into model name
+   !! (this should disappear in a near futur)
+
+   CHARACTER(lc) ::   cexper                      !: experiment name used for output filename
+   INTEGER       ::   nrstdt                      !: control of the time step (0, 1 or 2)
+   INTEGER       ::   nit000                      !: index of the first time step
+   INTEGER       ::   nitend                      !: index of the last time step
+   INTEGER       ::   ndate0                      !: initial calendar date aammjj
+   INTEGER       ::   nleapy                      !: Leap year calendar flag (0/1 or 30)
+   INTEGER       ::   ninist                      !: initial state output flag (0/1)
+   INTEGER       ::   nwrite                      !: model standard output frequency
+   INTEGER       ::   nstock                      !: restart file frequency
+   INTEGER, DIMENSION(10) :: nstocklist           !: restart dump times
+
+   !!----------------------------------------------------------------------
+   !! was in restart but moved here because of the OFF line... better solution should be found...
+   !!----------------------------------------------------------------------
+   INTEGER ::   nitrst                !: time step at which restart file should be written
+   LOGICAL ::   lrst_oce              !: logical to control the oce restart write 
+   LOGICAL ::   lrst_ice              !: logical to control the ice restart write 
+   INTEGER ::   numror = 0            !: logical unit for ocean restart (read). Init to 0 is needed for SAS (in daymod.F90)
+   INTEGER ::   numrir                !: logical unit for ice   restart (read)
+   INTEGER ::   numrow                !: logical unit for ocean restart (write)
+   INTEGER ::   numriw                !: logical unit for ice   restart (write)
+   INTEGER ::   nrst_lst              !: number of restart to output next
+
+   !!----------------------------------------------------------------------
+   !!                    output monitoring
+   !!----------------------------------------------------------------------
+   LOGICAL ::   ln_ctl           !: run control for debugging
+   LOGICAL ::   ln_timing        !: run control for timing
+   LOGICAL ::   ln_diacfl        !: flag whether to create CFL diagnostics
+   INTEGER ::   nn_print         !: level of print (0 no print)
+   INTEGER ::   nn_ictls         !: Start i indice for the SUM control
+   INTEGER ::   nn_ictle         !: End   i indice for the SUM control
+   INTEGER ::   nn_jctls         !: Start j indice for the SUM control
+   INTEGER ::   nn_jctle         !: End   j indice for the SUM control
+   INTEGER ::   nn_isplt         !: number of processors following i
+   INTEGER ::   nn_jsplt         !: number of processors following j
+   INTEGER ::   nn_bench         !: benchmark parameter (0/1)
+   INTEGER ::   nn_bit_cmp = 0   !: bit reproducibility  (0/1)
+   !                                          
+   INTEGER ::   nprint, nictls, nictle, njctls, njctle, isplt, jsplt    !: OLD namelist names
+
+   INTEGER ::   ijsplt     =    1      !: nb of local domain = nb of processors
+
+   !!----------------------------------------------------------------------
+   !!                        logical units
+   !!----------------------------------------------------------------------
+   INTEGER ::   numstp          =   -1      !: logical unit for time step
+   INTEGER ::   numtime         =   -1      !: logical unit for timing
+   INTEGER ::   numout          =    6      !: logical unit for output print; Set to stdout to ensure any
+      !                                     !  early output can be collected; do not change
+   INTEGER ::   numnam_ref      =   -1      !: logical unit for reference namelist
+   INTEGER ::   numnam_cfg      =   -1      !: logical unit for configuration specific namelist
+   INTEGER ::   numond          =   -1      !: logical unit for Output Namelist Dynamics
+   INTEGER ::   numnam_ice_ref  =   -1      !: logical unit for ice reference namelist
+   INTEGER ::   numnam_ice_cfg  =   -1      !: logical unit for ice reference namelist
+   INTEGER ::   numoni          =   -1      !: logical unit for Output Namelist Ice
+   INTEGER ::   numevo_ice      =   -1      !: logical unit for ice variables (temp. evolution)
+   INTEGER ::   numrun          =   -1      !: logical unit for run statistics
+   INTEGER ::   numdct_in       =   -1      !: logical unit for transports computing
+   INTEGER ::   numdct_vol      =   -1      !: logical unit for voulume transports output
+   INTEGER ::   numdct_heat     =   -1      !: logical unit for heat    transports output
+   INTEGER ::   numdct_salt     =   -1      !: logical unit for salt    transports output
+   INTEGER ::   numfl           =   -1      !: logical unit for floats ascii output
+   INTEGER ::   numflo          =   -1      !: logical unit for floats ascii output
+
+   !!----------------------------------------------------------------------
+   !!                          Run control  
+   !!----------------------------------------------------------------------
+   INTEGER       ::   no_print = 0          !: optional argument of fld_fill (if present, suppress some control print)
+   INTEGER       ::   nstop = 0             !: error flag (=number of reason for a premature stop run)
+   INTEGER       ::   nwarn = 0             !: warning flag (=number of warning found during the run)
+   CHARACTER(lc) ::   ctmp1, ctmp2, ctmp3   !: temporary characters 1 to 3
+   CHARACTER(lc) ::   ctmp4, ctmp5, ctmp6   !: temporary characters 4 to 6
+   CHARACTER(lc) ::   ctmp7, ctmp8, ctmp9   !: temporary characters 7 to 9
+   CHARACTER(lc) ::   ctmp10                !: temporary character 10
+   CHARACTER(lc) ::   cform_err = "(/,' ===>>> : E R R O R',     /,'         ===========',/)"       !:
+   CHARACTER(lc) ::   cform_war = "(/,' ===>>> : W A R N I N G', /,'         ===============',/)"   !:
+   LOGICAL       ::   lwm      = .FALSE.    !: boolean : true on the 1st processor only (always)
+   LOGICAL       ::   lwp      = .FALSE.    !: boolean : true on the 1st processor only .OR. ln_ctl
+   LOGICAL       ::   lsp_area = .TRUE.     !: to make a control print over a specific area
+   CHARACTER(lc) ::   cxios_context         !: context name used in xios
+   CHARACTER(lc) ::   crxios_context         !: context name used in xios to read restart
+   CHARACTER(lc) ::   cwxios_context        !: context name used in xios to write restart file
+
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 4.0 , NEMO Consortium (2018)
+   !! $Id$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!=====================================================================
+END MODULE in_out_manager
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/IOM/iom.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/IOM/iom.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/IOM/iom.F90	(revision 9570)
@@ -0,0 +1,2418 @@
+MODULE iom
+   !!======================================================================
+   !!                    ***  MODULE  iom ***
+   !! Input/Output manager :  Library to read input files
+   !!======================================================================
+   !! History :  2.0  ! 2005-12  (J. Belier) Original code
+   !!            2.0  ! 2006-02  (S. Masson) Adaptation to NEMO
+   !!            3.0  ! 2007-07  (D. Storkey) Changes to iom_gettime
+   !!            3.4  ! 2012-12  (R. Bourdalle-Badie and G. Reffray)  add C1D case  
+   !!            3.6  ! 2014-15  DIMG format removed
+   !!            3.6  ! 2015-15  (J. Harle) Added procedure to read REAL attributes
+   !!            4.0  ! 2017-11  (M. Andrejczuk) Extend IOM interface to write any 3D fields
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   iom_open       : open a file read only
+   !!   iom_close      : close a file or all files opened by iom
+   !!   iom_get        : read a field (interfaced to several routines)
+   !!   iom_gettime    : read the time axis cdvar in the file
+   !!   iom_varid      : get the id of a variable in a file
+   !!   iom_rstput     : write a field in a restart file (interfaced to several routines)
+   !!----------------------------------------------------------------------
+   USE dom_oce         ! ocean space and time domain
+   USE c1d             ! 1D vertical configuration
+   USE flo_oce         ! floats module declarations
+   USE lbclnk          ! lateal boundary condition / mpp exchanges
+   USE iom_def         ! iom variables definitions
+   USE iom_nf90        ! NetCDF format with native NetCDF library
+   USE in_out_manager  ! I/O manager
+   USE lib_mpp           ! MPP library
+#if defined key_iomput
+   USE sbc_oce  , ONLY :   nn_fsbc         ! ocean space and time domain
+   USE trc_oce  , ONLY :   nn_dttrc        !  !: frequency of step on passive tracers
+   USE icb_oce  , ONLY :   nclasses, class_num       !  !: iceberg classes
+#if defined key_si3
+   USE ice      , ONLY :   jpl
+#endif
+   USE domngb          ! ocean space and time domain
+   USE phycst          ! physical constants
+   USE dianam          ! build name of file
+   USE xios
+# endif
+   USE ioipsl, ONLY :  ju2ymds    ! for calendar
+   USE crs             ! Grid coarsening
+   USE lib_fortran 
+   USE diurnal_bulk, ONLY : ln_diurnal_only, ln_diurnal
+
+   IMPLICIT NONE
+   PUBLIC   !   must be public to be able to access iom_def through iom
+   
+#if defined key_iomput
+   LOGICAL, PUBLIC, PARAMETER ::   lk_iomput = .TRUE.        !: iom_put flag
+#else
+   LOGICAL, PUBLIC, PARAMETER ::   lk_iomput = .FALSE.       !: iom_put flag
+#endif
+   PUBLIC iom_init, iom_swap, iom_open, iom_close, iom_setkt, iom_varid, iom_get
+   PUBLIC iom_getatt, iom_putatt, iom_gettime, iom_rstput, iom_put
+   PUBLIC iom_use, iom_context_finalize
+
+   PRIVATE iom_rp0d, iom_rp1d, iom_rp2d, iom_rp3d
+   PRIVATE iom_g0d, iom_g1d, iom_g2d, iom_g3d, iom_get_123d
+   PRIVATE iom_p1d, iom_p2d, iom_p3d
+#if defined key_iomput
+   PRIVATE iom_set_domain_attr, iom_set_axis_attr, iom_set_field_attr, iom_set_file_attr, iom_get_file_attr, iom_set_grid_attr
+   PRIVATE set_grid, set_grid_bounds, set_scalar, set_xmlatt, set_mooring, iom_update_file_name, iom_sdate
+   PRIVATE iom_set_rst_context, iom_set_rstw_active, iom_set_rstr_active
+# endif
+   PUBLIC iom_set_rstw_var_active, iom_set_rstw_core, iom_set_rst_vars
+
+   INTERFACE iom_get
+      MODULE PROCEDURE iom_g0d, iom_g1d, iom_g2d, iom_g3d
+   END INTERFACE
+   INTERFACE iom_getatt
+      MODULE PROCEDURE iom_g0d_iatt, iom_g0d_ratt, iom_g0d_catt
+   END INTERFACE
+   INTERFACE iom_putatt
+      MODULE PROCEDURE iom_p0d_iatt, iom_p0d_ratt, iom_p0d_catt
+   END INTERFACE
+   INTERFACE iom_rstput
+      MODULE PROCEDURE iom_rp0d, iom_rp1d, iom_rp2d, iom_rp3d
+   END INTERFACE
+  INTERFACE iom_put
+     MODULE PROCEDURE iom_p0d, iom_p1d, iom_p2d, iom_p3d
+  END INTERFACE
+
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 4.0 , NEMO Consortium (2017)
+   !! $Id$
+   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE iom_init( cdname, fname ) 
+      !!----------------------------------------------------------------------
+      !!                     ***  ROUTINE   ***
+      !!
+      !! ** Purpose :   
+      !!
+      !!----------------------------------------------------------------------
+      CHARACTER(len=*), INTENT(in)  :: cdname
+      CHARACTER(len=*), OPTIONAL, INTENT(in)  :: fname
+#if defined key_iomput
+      !
+      TYPE(xios_duration) :: dtime    = xios_duration(0, 0, 0, 0, 0, 0)
+      TYPE(xios_date)     :: start_date
+      CHARACTER(len=lc) :: clname
+      INTEGER           :: ji, jkmin
+      LOGICAL :: llrst_context              ! is context related to restart
+      !
+      REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zt_bnds, zw_bnds
+      !!----------------------------------------------------------------------
+      !
+      ALLOCATE( zt_bnds(2,jpk), zw_bnds(2,jpk) )
+      !
+      clname = cdname
+      IF( TRIM(Agrif_CFixed()) /= '0' )   clname = TRIM(Agrif_CFixed())//"_"//TRIM(cdname)
+      CALL xios_context_initialize(TRIM(clname), mpi_comm_oce)
+      CALL iom_swap( cdname )
+      llrst_context =  (TRIM(cdname) == TRIM(crxios_context) .OR. TRIM(cdname) == TRIM(cwxios_context))
+
+      ! Calendar type is now defined in xml file 
+      SELECT CASE ( nleapy )        ! Choose calendar for IOIPSL
+      CASE ( 1)   ; CALL xios_define_calendar( TYPE = "Gregorian", time_origin = xios_date(1900,01,01,00,00,00), &
+          &                                    start_date = xios_date(nyear,nmonth,nday,0,0,0) )
+      CASE ( 0)   ; CALL xios_define_calendar( TYPE = "NoLeap"   , time_origin = xios_date(1900,01,01,00,00,00), &
+          &                                    start_date = xios_date(nyear,nmonth,nday,0,0,0) )
+      CASE (30)   ; CALL xios_define_calendar( TYPE = "D360"     , time_origin = xios_date(1900,01,01,00,00,00), &
+          &                                    start_date = xios_date(nyear,nmonth,nday,0,0,0) )
+      END SELECT
+
+      ! horizontal grid definition
+      IF(.NOT.llrst_context) CALL set_scalar
+      !
+      IF( TRIM(cdname) == TRIM(cxios_context) ) THEN  
+         CALL set_grid( "T", glamt, gphit, .FALSE. ) 
+         CALL set_grid( "U", glamu, gphiu, .FALSE. )
+         CALL set_grid( "V", glamv, gphiv, .FALSE. )
+         CALL set_grid( "W", glamt, gphit, .FALSE. )
+         CALL set_grid_znl( gphit )
+         !
+         IF( ln_cfmeta ) THEN   ! Add additional grid metadata
+            CALL iom_set_domain_attr("grid_T", area = e1e2t(nldi:nlei, nldj:nlej))
+            CALL iom_set_domain_attr("grid_U", area = e1e2u(nldi:nlei, nldj:nlej))
+            CALL iom_set_domain_attr("grid_V", area = e1e2v(nldi:nlei, nldj:nlej))
+            CALL iom_set_domain_attr("grid_W", area = e1e2t(nldi:nlei, nldj:nlej))
+            CALL set_grid_bounds( "T", glamf, gphif, glamt, gphit )
+            CALL set_grid_bounds( "U", glamv, gphiv, glamu, gphiu )
+            CALL set_grid_bounds( "V", glamu, gphiu, glamv, gphiv )
+            CALL set_grid_bounds( "W", glamf, gphif, glamt, gphit )
+         ENDIF
+      ENDIF
+      !
+      IF( TRIM(cdname) == TRIM(cxios_context)//"_crs" ) THEN  
+         CALL dom_grid_crs   ! Save the parent grid information  & Switch to coarse grid domain
+         !
+         CALL set_grid( "T", glamt_crs, gphit_crs, .FALSE. ) 
+         CALL set_grid( "U", glamu_crs, gphiu_crs, .FALSE. ) 
+         CALL set_grid( "V", glamv_crs, gphiv_crs, .FALSE. ) 
+         CALL set_grid( "W", glamt_crs, gphit_crs, .FALSE. ) 
+         CALL set_grid_znl( gphit_crs )
+          !
+         CALL dom_grid_glo   ! Return to parent grid domain
+         !
+         IF( ln_cfmeta .AND. .NOT. llrst_context) THEN   ! Add additional grid metadata
+            CALL iom_set_domain_attr("grid_T", area = e1e2t_crs(nldi:nlei, nldj:nlej))
+            CALL iom_set_domain_attr("grid_U", area = e1u_crs(nldi:nlei, nldj:nlej) * e2u_crs(nldi:nlei, nldj:nlej))
+            CALL iom_set_domain_attr("grid_V", area = e1v_crs(nldi:nlei, nldj:nlej) * e2v_crs(nldi:nlei, nldj:nlej))
+            CALL iom_set_domain_attr("grid_W", area = e1e2t_crs(nldi:nlei, nldj:nlej))
+            CALL set_grid_bounds( "T", glamf_crs, gphif_crs, glamt_crs, gphit_crs )
+            CALL set_grid_bounds( "U", glamv_crs, gphiv_crs, glamu_crs, gphiu_crs )
+            CALL set_grid_bounds( "V", glamu_crs, gphiu_crs, glamv_crs, gphiv_crs )
+            CALL set_grid_bounds( "W", glamf_crs, gphif_crs, glamt_crs, gphit_crs )
+         ENDIF
+      ENDIF
+      !
+      ! vertical grid definition
+      IF(.NOT.llrst_context) THEN
+          CALL iom_set_axis_attr( "deptht", paxis = gdept_1d )
+          CALL iom_set_axis_attr( "depthu", paxis = gdept_1d )
+          CALL iom_set_axis_attr( "depthv", paxis = gdept_1d )
+          CALL iom_set_axis_attr( "depthw", paxis = gdepw_1d )
+
+          ! Add vertical grid bounds
+          jkmin = MIN(2,jpk)  ! in case jpk=1 (i.e. sas2D)
+          zt_bnds(2,:        ) = gdept_1d(:)
+          zt_bnds(1,jkmin:jpk) = gdept_1d(1:jpkm1)
+          zt_bnds(1,1        ) = gdept_1d(1) - e3w_1d(1)
+          zw_bnds(1,:        ) = gdepw_1d(:)
+          zw_bnds(2,1:jpkm1  ) = gdepw_1d(jkmin:jpk)
+          zw_bnds(2,jpk:     ) = gdepw_1d(jpk) + e3t_1d(jpk)
+          CALL iom_set_axis_attr( "deptht", bounds=zt_bnds )
+          CALL iom_set_axis_attr( "depthu", bounds=zt_bnds )
+          CALL iom_set_axis_attr( "depthv", bounds=zt_bnds )
+          CALL iom_set_axis_attr( "depthw", bounds=zw_bnds )
+          !
+# if defined key_floats
+          CALL iom_set_axis_attr( "nfloat", (/ (REAL(ji,wp), ji=1,nfloat) /) )
+# endif
+# if defined key_si3
+          CALL iom_set_axis_attr( "ncatice", (/ (REAL(ji,wp), ji=1,jpl) /) )
+          ! SIMIP diagnostics (4 main arctic straits)
+          CALL iom_set_axis_attr( "nstrait", (/ (REAL(ji,wp), ji=1,4) /) )
+# endif
+          CALL iom_set_axis_attr( "icbcla", class_num )
+          CALL iom_set_axis_attr( "iax_20C", (/ REAL(20,wp) /) )
+          CALL iom_set_axis_attr( "iax_28C", (/ REAL(28,wp) /) )
+      ENDIF
+      !
+      ! automatic definitions of some of the xml attributs
+      IF( TRIM(cdname) == TRIM(crxios_context) ) THEN
+!set names of the fields in restart file IF using XIOS to read data
+          CALL iom_set_rst_context()
+          CALL iom_set_rst_vars(rst_rfields)
+!set which fields are to be read from restart file
+          CALL iom_set_rstr_active()
+      ELSE IF( TRIM(cdname) == TRIM(cwxios_context) ) THEN
+!set names of the fields in restart file IF using XIOS to write data
+          CALL iom_set_rst_context()
+          CALL iom_set_rst_vars(rst_wfields)
+!set which fields are to be written to a restart file
+          CALL iom_set_rstw_active(fname)
+      ELSE
+          CALL set_xmlatt
+      ENDIF
+      !
+      ! end file definition
+      dtime%second = rdt
+      CALL xios_set_timestep( dtime )
+      CALL xios_close_context_definition()
+      CALL xios_update_calendar( 0 )
+      !
+      DEALLOCATE( zt_bnds, zw_bnds )
+      !
+#endif
+      !
+   END SUBROUTINE iom_init
+
+   SUBROUTINE iom_set_rstw_var_active(field)
+      !!---------------------------------------------------------------------
+      !!                   ***  SUBROUTINE  iom_set_rstw_var_active  ***
+      !!
+      !! ** Purpose :  enable variable in restart file when writing with XIOS 
+      !!---------------------------------------------------------------------
+   CHARACTER(len = *), INTENT(IN) :: field
+   INTEGER :: i
+   LOGICAL :: llis_set
+   CHARACTER(LEN=256) :: clinfo    ! info character
+
+#if defined key_iomput
+   llis_set = .FALSE.
+
+   DO i = 1, max_rst_fields
+       IF(TRIM(rst_wfields(i)%vname) == field) THEN 
+          rst_wfields(i)%active = .TRUE.
+          llis_set = .TRUE.
+          EXIT
+       ENDIF
+   ENDDO
+!Warn if variable is not in defined in rst_wfields
+   IF(.NOT.llis_set) THEN
+      IF(lwp) THEN
+         write(numout,cform_err)
+         write(numout,*) 'iom_set_rstw_var_active: variable ', field ,' is available for writing but not defined' 
+      ENDIF
+        nstop = nstop + 1
+   ENDIF
+#else
+        clinfo = 'iom_set_rstw_var_active: key_iomput is needed to use XIOS restart read/write functionality'
+        CALL ctl_stop('STOP', TRIM(clinfo))
+#endif
+
+   END SUBROUTINE iom_set_rstw_var_active
+
+   SUBROUTINE iom_set_rstr_active()
+      !!---------------------------------------------------------------------
+      !!                   ***  SUBROUTINE  iom_set_rstr_active  ***
+      !!
+      !! ** Purpose :  define file name in XIOS context for reading restart file,
+      !!               enable variables present in restart file for reading with XIOS 
+      !!---------------------------------------------------------------------
+
+!sets enabled = .TRUE. for each field in restart file
+   CHARACTER(len=256) :: rst_file
+
+#if defined key_iomput
+   TYPE(xios_field) :: field_hdl
+   TYPE(xios_file) :: file_hdl
+   TYPE(xios_filegroup) :: filegroup_hdl
+   INTEGER :: i
+   CHARACTER(lc)  ::   clpath
+
+        clpath = TRIM(cn_ocerst_indir)
+        IF( clpath(LEN_TRIM(clpath):) /= '/' ) clpath = TRIM(clpath) // '/'
+        IF( TRIM(Agrif_CFixed()) == '0' ) THEN
+           rst_file = TRIM(clpath)//TRIM(cn_ocerst_in)
+        ELSE
+           rst_file = TRIM(clpath)//'1_'//TRIM(cn_ocerst_in)
+        ENDIF
+!set name of the restart file and enable available fields
+        if(lwp) WRITE(numout,*) 'Setting restart filename (for XIOS) to: ',rst_file
+        CALL xios_get_handle("file_definition", filegroup_hdl )
+        CALL xios_add_child(filegroup_hdl, file_hdl, 'rrestart')
+        CALL xios_set_file_attr( "rrestart", name=trim(rst_file), type="one_file", &
+             par_access="collective", enabled=.TRUE., mode="read",                 &
+             output_freq=xios_timestep)
+!define variables for restart context
+        DO i = 1, max_rst_fields
+         IF( TRIM(rst_rfields(i)%vname) /= "NO_NAME") THEN
+           IF( iom_varid( numror, TRIM(rst_rfields(i)%vname), ldstop = .FALSE. ) > 0 ) THEN
+                CALL xios_add_child(file_hdl, field_hdl, TRIM(rst_rfields(i)%vname))
+                SELECT CASE (TRIM(rst_rfields(i)%grid))
+                 CASE ("grid_N_3D")
+                    CALL xios_set_attr (field_hdl, enabled = .TRUE., name = TRIM(rst_rfields(i)%vname), &
+                        domain_ref="grid_N", axis_ref="nav_lev", operation = "instant")
+                 CASE ("grid_N")
+                    CALL xios_set_attr (field_hdl, enabled = .TRUE., name = TRIM(rst_rfields(i)%vname), &
+                        domain_ref="grid_N", operation = "instant") 
+                CASE ("grid_vector")
+                    CALL xios_set_attr (field_hdl, enabled = .TRUE., name = TRIM(rst_rfields(i)%vname), &
+                         axis_ref="nav_lev", operation = "instant")
+                 CASE ("grid_scalar")
+                    CALL xios_set_attr (field_hdl, enabled = .TRUE., name = TRIM(rst_rfields(i)%vname), &
+                        scalar_ref = "grid_scalar", operation = "instant")
+                END SELECT
+                IF(lwp) WRITE(numout,*) 'XIOS read: ', TRIM(rst_rfields(i)%vname), ' enabled in ', TRIM(rst_file)
+           ENDIF
+         ENDIF
+        END DO
+#endif
+   END SUBROUTINE iom_set_rstr_active
+
+   SUBROUTINE iom_set_rstw_core(cdmdl)
+      !!---------------------------------------------------------------------
+      !!                   ***  SUBROUTINE  iom_set_rstw_core  ***
+      !!
+      !! ** Purpose :  set variables which are always in restart file 
+      !!---------------------------------------------------------------------
+   CHARACTER (len=*), INTENT (IN) :: cdmdl ! model OPA or SAS
+   CHARACTER(LEN=256)             :: clinfo    ! info character
+#if defined key_iomput
+   IF(cdmdl == "OPA") THEN
+!from restart.F90
+   CALL iom_set_rstw_var_active("rdt")
+   IF ( .NOT. ln_diurnal_only ) THEN
+        CALL iom_set_rstw_var_active('ub'  )
+        CALL iom_set_rstw_var_active('vb'  )
+        CALL iom_set_rstw_var_active('tb'  )
+        CALL iom_set_rstw_var_active('sb'  )
+        CALL iom_set_rstw_var_active('sshb')
+        !
+        CALL iom_set_rstw_var_active('un'  )
+        CALL iom_set_rstw_var_active('vn'  )
+        CALL iom_set_rstw_var_active('tn'  )
+        CALL iom_set_rstw_var_active('sn'  )
+        CALL iom_set_rstw_var_active('sshn')
+        CALL iom_set_rstw_var_active('rhop')
+     ! extra variable needed for the ice sheet coupling
+        IF ( ln_iscpl ) THEN
+             CALL iom_set_rstw_var_active('tmask')
+             CALL iom_set_rstw_var_active('umask')
+             CALL iom_set_rstw_var_active('vmask')
+             CALL iom_set_rstw_var_active('smask')
+             CALL iom_set_rstw_var_active('e3t_n')
+             CALL iom_set_rstw_var_active('e3u_n')
+             CALL iom_set_rstw_var_active('e3v_n')
+             CALL iom_set_rstw_var_active('gdepw_n')
+        END IF
+      ENDIF
+      IF(ln_diurnal) CALL iom_set_rstw_var_active('Dsst')
+!from trasbc.F90
+         CALL iom_set_rstw_var_active('sbc_hc_b')
+         CALL iom_set_rstw_var_active('sbc_sc_b')
+   ENDIF
+#else
+        clinfo = 'iom_set_rstw_core: key_iomput is needed to use XIOS restart read/write functionality'
+        CALL ctl_stop('STOP', TRIM(clinfo))
+#endif
+   END SUBROUTINE iom_set_rstw_core
+
+   SUBROUTINE iom_set_rst_vars(fields)
+      !!---------------------------------------------------------------------
+      !!                   ***  SUBROUTINE iom_set_rst_vars   ***
+      !!
+      !! ** Purpose :  Fill array fields with the information about all 
+      !!               possible variables and corresponding grids definition 
+      !!               for reading/writing restart with XIOS
+      !!---------------------------------------------------------------------
+   TYPE(RST_FIELD), INTENT(INOUT) :: fields(max_rst_fields)
+   INTEGER :: i
+
+        i = 0
+        i = i + 1; fields(i)%vname="rdt";            fields(i)%grid="grid_scalar"
+        i = i + 1; fields(i)%vname="un";             fields(i)%grid="grid_N_3D"
+        i = i + 1; fields(i)%vname="ub";             fields(i)%grid="grid_N_3D"
+        i = i + 1; fields(i)%vname="vn";             fields(i)%grid="grid_N_3D"
+        i = i + 1; fields(i)%vname="vb";             fields(i)%grid="grid_N_3D"  
+        i = i + 1; fields(i)%vname="tn";             fields(i)%grid="grid_N_3D"
+        i = i + 1; fields(i)%vname="tb";             fields(i)%grid="grid_N_3D"
+        i = i + 1; fields(i)%vname="sn";             fields(i)%grid="grid_N_3D"
+        i = i + 1; fields(i)%vname="sb";             fields(i)%grid="grid_N_3D"
+        i = i + 1; fields(i)%vname="sshn";           fields(i)%grid="grid_N"
+        i = i + 1; fields(i)%vname="sshb";           fields(i)%grid="grid_N"
+        i = i + 1; fields(i)%vname="rhop";           fields(i)%grid="grid_N_3D"
+        i = i + 1; fields(i)%vname="kt";             fields(i)%grid="grid_scalar"
+        i = i + 1; fields(i)%vname="ndastp";         fields(i)%grid="grid_scalar"
+        i = i + 1; fields(i)%vname="adatrj";         fields(i)%grid="grid_scalar"
+        i = i + 1; fields(i)%vname="utau_b";         fields(i)%grid="grid_N"
+        i = i + 1; fields(i)%vname="vtau_b";         fields(i)%grid="grid_N"
+        i = i + 1; fields(i)%vname="qns_b";          fields(i)%grid="grid_N"
+        i = i + 1; fields(i)%vname="emp_b";          fields(i)%grid="grid_N"
+        i = i + 1; fields(i)%vname="sfx_b";          fields(i)%grid="grid_N"
+        i = i + 1; fields(i)%vname="en" ;            fields(i)%grid="grid_N_3D" 
+        i = i + 1; fields(i)%vname="avt_k";            fields(i)%grid="grid_N_3D"
+        i = i + 1; fields(i)%vname="avm_k";            fields(i)%grid="grid_N_3D"
+        i = i + 1; fields(i)%vname="dissl";          fields(i)%grid="grid_N_3D"
+        i = i + 1; fields(i)%vname="sbc_hc_b";       fields(i)%grid="grid_N"
+        i = i + 1; fields(i)%vname="sbc_sc_b";       fields(i)%grid="grid_N"
+        i = i + 1; fields(i)%vname="qsr_hc_b";       fields(i)%grid="grid_N_3D"
+        i = i + 1; fields(i)%vname="fraqsr_1lev";    fields(i)%grid="grid_N"
+        i = i + 1; fields(i)%vname="greenland_icesheet_mass"
+                                               fields(i)%grid="grid_scalar"
+        i = i + 1; fields(i)%vname="greenland_icesheet_timelapsed"
+                                               fields(i)%grid="grid_scalar"
+        i = i + 1; fields(i)%vname="greenland_icesheet_mass_roc"
+                                               fields(i)%grid="grid_scalar"
+        i = i + 1; fields(i)%vname="antarctica_icesheet_mass"
+                                               fields(i)%grid="grid_scalar"
+        i = i + 1; fields(i)%vname="antarctica_icesheet_timelapsed"
+                                               fields(i)%grid="grid_scalar"
+        i = i + 1; fields(i)%vname="antarctica_icesheet_mass_roc"
+                                               fields(i)%grid="grid_scalar"
+        i = i + 1; fields(i)%vname="frc_v";          fields(i)%grid="grid_scalar"
+        i = i + 1; fields(i)%vname="frc_t";          fields(i)%grid="grid_scalar"
+        i = i + 1; fields(i)%vname="frc_s";          fields(i)%grid="grid_scalar"
+        i = i + 1; fields(i)%vname="frc_wn_t";       fields(i)%grid="grid_scalar"
+        i = i + 1; fields(i)%vname="frc_wn_s";       fields(i)%grid="grid_scalar"
+        i = i + 1; fields(i)%vname="ssh_ini";        fields(i)%grid="grid_N"
+        i = i + 1; fields(i)%vname="e3t_ini";        fields(i)%grid="grid_N_3D"
+        i = i + 1; fields(i)%vname="hc_loc_ini";     fields(i)%grid="grid_N_3D"
+        i = i + 1; fields(i)%vname="sc_loc_ini";     fields(i)%grid="grid_N_3D"
+        i = i + 1; fields(i)%vname="ssh_hc_loc_ini"; fields(i)%grid="grid_N"
+        i = i + 1; fields(i)%vname="ssh_sc_loc_ini"; fields(i)%grid="grid_N"
+        i = i + 1; fields(i)%vname="tilde_e3t_b";    fields(i)%grid="grid_N"
+        i = i + 1; fields(i)%vname="tilde_e3t_n";    fields(i)%grid="grid_N"
+        i = i + 1; fields(i)%vname="hdiv_lf";        fields(i)%grid="grid_N"
+        i = i + 1; fields(i)%vname="ub2_b";          fields(i)%grid="grid_N"
+        i = i + 1; fields(i)%vname="vb2_b";          fields(i)%grid="grid_N"
+        i = i + 1; fields(i)%vname="sshbb_e";        fields(i)%grid="grid_N"
+        i = i + 1; fields(i)%vname="ubb_e";          fields(i)%grid="grid_N"
+        i = i + 1; fields(i)%vname="vbb_e";          fields(i)%grid="grid_N"
+        i = i + 1; fields(i)%vname="sshb_e";         fields(i)%grid="grid_N"
+        i = i + 1; fields(i)%vname="ub_e";           fields(i)%grid="grid_N"
+        i = i + 1; fields(i)%vname="vb_e";           fields(i)%grid="grid_N"
+        i = i + 1; fields(i)%vname="fwf_isf_b";      fields(i)%grid="grid_N"
+        i = i + 1; fields(i)%vname="isf_sc_b";       fields(i)%grid="grid_N"
+        i = i + 1; fields(i)%vname="isf_hc_b";       fields(i)%grid="grid_N"
+        i = i + 1; fields(i)%vname="ssh_ibb";        fields(i)%grid="grid_N"
+        i = i + 1; fields(i)%vname="rnf_b";          fields(i)%grid="grid_N"
+        i = i + 1; fields(i)%vname="rnf_hc_b";       fields(i)%grid="grid_N"
+        i = i + 1; fields(i)%vname="rnf_sc_b";       fields(i)%grid="grid_N"
+        i = i + 1; fields(i)%vname="nn_fsbc";        fields(i)%grid="grid_scalar"
+        i = i + 1; fields(i)%vname="ssu_m";          fields(i)%grid="grid_N"
+        i = i + 1; fields(i)%vname="ssv_m";          fields(i)%grid="grid_N"
+        i = i + 1; fields(i)%vname="sst_m";          fields(i)%grid="grid_N"
+        i = i + 1; fields(i)%vname="sss_m";          fields(i)%grid="grid_N"
+        i = i + 1; fields(i)%vname="ssh_m";          fields(i)%grid="grid_N"
+        i = i + 1; fields(i)%vname="e3t_m";          fields(i)%grid="grid_N"
+        i = i + 1; fields(i)%vname="frq_m";          fields(i)%grid="grid_N"
+        i = i + 1; fields(i)%vname="avmb";           fields(i)%grid="grid_vector"
+        i = i + 1; fields(i)%vname="avtb";           fields(i)%grid="grid_vector"
+        i = i + 1; fields(i)%vname="ub2_i_b";        fields(i)%grid="grid_N"
+        i = i + 1; fields(i)%vname="vb2_i_b";        fields(i)%grid="grid_N"
+        i = i + 1; fields(i)%vname="ntime";          fields(i)%grid="grid_scalar"
+        i = i + 1; fields(i)%vname="Dsst";           fields(i)%grid="grid_scalar"
+        i = i + 1; fields(i)%vname="tmask";          fields(i)%grid="grid_N_3D"
+        i = i + 1; fields(i)%vname="umask";          fields(i)%grid="grid_N_3D"
+        i = i + 1; fields(i)%vname="vmask";          fields(i)%grid="grid_N_3D"
+        i = i + 1; fields(i)%vname="smask";          fields(i)%grid="grid_N_3D"
+        i = i + 1; fields(i)%vname="gdepw_n";        fields(i)%grid="grid_N_3D"
+        i = i + 1; fields(i)%vname="e3t_n";          fields(i)%grid="grid_N_3D"
+        i = i + 1; fields(i)%vname="e3u_n";          fields(i)%grid="grid_N_3D"
+        i = i + 1; fields(i)%vname="e3v_n";          fields(i)%grid="grid_N_3D"
+        i = i + 1; fields(i)%vname="surf_ini";       fields(i)%grid="grid_N"
+        i = i + 1; fields(i)%vname="e3t_b";          fields(i)%grid="grid_N_3D"
+        i = i + 1; fields(i)%vname="hmxl_n";         fields(i)%grid="grid_N_3D"
+        i = i + 1; fields(i)%vname="un_bf";          fields(i)%grid="grid_N"
+        i = i + 1; fields(i)%vname="vn_bf";          fields(i)%grid="grid_N"
+        i = i + 1; fields(i)%vname="hbl";            fields(i)%grid="grid_N"
+        i = i + 1; fields(i)%vname="hbli";           fields(i)%grid="grid_N"
+        i = i + 1; fields(i)%vname="wn";             fields(i)%grid="grid_N_3D"
+
+        IF( i-1 > max_rst_fields) THEN
+        IF(lwp) write(numout,*) 'E R R O R : iom_set_rst_vars SIZE of RST_FIELD array is too small'
+        nstop = nstop + 1
+        ENDIF
+   END SUBROUTINE iom_set_rst_vars
+
+
+   SUBROUTINE iom_set_rstw_active(cdrst_file)
+      !!---------------------------------------------------------------------
+      !!                   ***  SUBROUTINE iom_set_rstw_active   ***
+      !!
+      !! ** Purpose :  define file name in XIOS context for writing restart
+      !!               enable variables present in restart file for writing
+      !!---------------------------------------------------------------------
+!sets enabled = .TRUE. for each field in restart file
+   CHARACTER(len=*) :: cdrst_file
+#if defined key_iomput
+   TYPE(xios_field) :: field_hdl
+   TYPE(xios_file) :: file_hdl
+   TYPE(xios_filegroup) :: filegroup_hdl
+   INTEGER :: i
+   CHARACTER(lc)  ::   clpath
+
+!set name of the restart file and enable available fields
+        IF(lwp) WRITE(numout,*) 'Setting restart filename (for XIOS write) to: ',cdrst_file
+        CALL xios_get_handle("file_definition", filegroup_hdl )
+        CALL xios_add_child(filegroup_hdl, file_hdl, 'wrestart')
+        IF(nxioso.eq.1) THEN 
+           CALL xios_set_file_attr( "wrestart", type="one_file", enabled=.TRUE.,& 
+                                    mode="write", output_freq=xios_timestep) 
+           if(lwp) write(numout,*) 'OPEN ', trim(cdrst_file), ' in one_file mode' 
+        ELSE  
+           CALL xios_set_file_attr( "wrestart", type="multiple_file", enabled=.TRUE.,& 
+                                    mode="write", output_freq=xios_timestep) 
+           if(lwp) write(numout,*) 'OPEN ', trim(cdrst_file), ' in multiple_file mode' 
+        ENDIF 
+        CALL xios_set_file_attr( "wrestart", name=trim(cdrst_file))
+!define fields for restart context
+        DO i = 1, max_rst_fields
+         IF( rst_wfields(i)%active ) THEN
+                CALL xios_add_child(file_hdl, field_hdl, TRIM(rst_wfields(i)%vname))
+                SELECT CASE (TRIM(rst_wfields(i)%grid))
+                 CASE ("grid_N_3D")
+                    CALL xios_set_attr (field_hdl, enabled = .TRUE., name = TRIM(rst_wfields(i)%vname), &
+                        domain_ref="grid_N", axis_ref="nav_lev", prec = 8, operation = "instant")
+                 CASE ("grid_N")
+                    CALL xios_set_attr (field_hdl, enabled = .TRUE., name = TRIM(rst_wfields(i)%vname), &
+                        domain_ref="grid_N", prec = 8, operation = "instant") 
+                 CASE ("grid_vector")
+                    CALL xios_set_attr (field_hdl, enabled = .TRUE., name = TRIM(rst_wfields(i)%vname), &
+                         axis_ref="nav_lev", prec = 8, operation = "instant")
+                 CASE ("grid_scalar")
+                    CALL xios_set_attr (field_hdl, enabled = .TRUE., name = TRIM(rst_wfields(i)%vname), &
+                        scalar_ref = "grid_scalar", prec = 8, operation = "instant")
+                END SELECT
+         ENDIF
+        END DO
+#endif
+   END SUBROUTINE iom_set_rstw_active
+
+   SUBROUTINE iom_set_rst_context( ) 
+     !!---------------------------------------------------------------------
+      !!                   ***  SUBROUTINE  iom_set_rst_context  ***
+      !!
+      !! ** Purpose : Define domain, axis and grid for restart (read/write) 
+      !!              context 
+      !!               
+      !!---------------------------------------------------------------------
+#if defined key_iomput
+   TYPE(xios_domaingroup)            :: domaingroup_hdl 
+   TYPE(xios_domain)                 :: domain_hdl 
+   TYPE(xios_axisgroup)              :: axisgroup_hdl 
+   TYPE(xios_axis)                   :: axis_hdl 
+   TYPE(xios_scalar)                 :: scalar_hdl 
+   TYPE(xios_scalargroup)            :: scalargroup_hdl 
+
+     CALL xios_get_handle("domain_definition",domaingroup_hdl) 
+     CALL xios_add_child(domaingroup_hdl, domain_hdl, "grid_N") 
+     CALL set_grid("N", glamt, gphit, .TRUE.) 
+ 
+     CALL xios_get_handle("axis_definition",axisgroup_hdl) 
+     CALL xios_add_child(axisgroup_hdl, axis_hdl, "nav_lev") 
+!AGRIF fails to compile when unit= is in call to xios_set_axis_attr
+!    CALL xios_set_axis_attr( "nav_lev", long_name="Vertical levels",  unit="m", positive="down") 
+     CALL xios_set_axis_attr( "nav_lev", long_name="Vertical levels in meters", positive="down")
+     CALL iom_set_axis_attr( "nav_lev", paxis = gdept_1d ) 
+
+     CALL xios_get_handle("scalar_definition", scalargroup_hdl) 
+     CALL xios_add_child(scalargroup_hdl, scalar_hdl, "grid_scalar") 
+#endif
+   END SUBROUTINE iom_set_rst_context
+
+   SUBROUTINE iom_swap( cdname )
+      !!---------------------------------------------------------------------
+      !!                   ***  SUBROUTINE  iom_swap  ***
+      !!
+      !! ** Purpose :  swap context between different agrif grid for xmlio_server
+      !!---------------------------------------------------------------------
+      CHARACTER(len=*), INTENT(in) :: cdname
+#if defined key_iomput
+      TYPE(xios_context) :: nemo_hdl
+
+      IF( TRIM(Agrif_CFixed()) == '0' ) THEN
+        CALL xios_get_handle(TRIM(cdname),nemo_hdl)
+      ELSE
+        CALL xios_get_handle(TRIM(Agrif_CFixed())//"_"//TRIM(cdname),nemo_hdl)
+      ENDIF
+      !
+      CALL xios_set_current_context(nemo_hdl)
+#endif
+      !
+   END SUBROUTINE iom_swap
+
+
+   SUBROUTINE iom_open( cdname, kiomid, ldwrt, kdom, kiolib, ldstop, ldiof, kdlev )
+      !!---------------------------------------------------------------------
+      !!                   ***  SUBROUTINE  iom_open  ***
+      !!
+      !! ** Purpose :  open an input file (return 0 if not found)
+      !!---------------------------------------------------------------------
+      CHARACTER(len=*), INTENT(in   )           ::   cdname   ! File name
+      INTEGER         , INTENT(  out)           ::   kiomid   ! iom identifier of the opened file
+      LOGICAL         , INTENT(in   ), OPTIONAL ::   ldwrt    ! open in write modeb          (default = .FALSE.)
+      INTEGER         , INTENT(in   ), OPTIONAL ::   kdom     ! Type of domain to be written (default = jpdom_local_noovlap)
+      INTEGER         , INTENT(in   ), OPTIONAL ::   kiolib   ! library used to open the file (default = jpnf90) 
+      LOGICAL         , INTENT(in   ), OPTIONAL ::   ldstop   ! stop if open to read a non-existing file (default = .TRUE.)
+      LOGICAL         , INTENT(in   ), OPTIONAL ::   ldiof    ! Interp On the Fly, needed for AGRIF (default = .FALSE.)
+      INTEGER         , INTENT(in   ), OPTIONAL ::   kdlev    ! number of vertical levels
+      !
+      CHARACTER(LEN=256)    ::   clname    ! the name of the file based on cdname [[+clcpu]+clcpu]
+      CHARACTER(LEN=256)    ::   cltmpn    ! tempory name to store clname (in writting mode)
+      CHARACTER(LEN=10)     ::   clsuffix  ! ".nc" 
+      CHARACTER(LEN=15)     ::   clcpu     ! the cpu number (max jpmax_digits digits)
+      CHARACTER(LEN=256)    ::   clinfo    ! info character
+      LOGICAL               ::   llok      ! check the existence 
+      LOGICAL               ::   llwrt     ! local definition of ldwrt
+      LOGICAL               ::   llnoov    ! local definition to read overlap
+      LOGICAL               ::   llstop    ! local definition of ldstop
+      LOGICAL               ::   lliof     ! local definition of ldiof
+      INTEGER               ::   iolib     ! library do we use to open the file
+      INTEGER               ::   icnt      ! counter for digits in clcpu (max = jpmax_digits)
+      INTEGER               ::   iln, ils  ! lengths of character
+      INTEGER               ::   idom      ! type of domain
+      INTEGER               ::   istop     ! 
+      INTEGER, DIMENSION(2,5) ::   idompar ! domain parameters: 
+      ! local number of points for x,y dimensions
+      ! position of first local point for x,y dimensions
+      ! position of last local point for x,y dimensions
+      ! start halo size for x,y dimensions
+      ! end halo size for x,y dimensions
+      !---------------------------------------------------------------------
+      ! Initializations and control
+      ! =============
+      kiomid = -1
+      clinfo = '                    iom_open ~~~  '
+      istop = nstop
+      ! if iom_open is called for the first time: initialize iom_file(:)%nfid to 0
+      ! (could be done when defining iom_file in f95 but not in f90)
+      IF( Agrif_Root() ) THEN
+         IF( iom_open_init == 0 ) THEN
+            iom_file(:)%nfid = 0
+            iom_open_init = 1
+         ENDIF
+      ENDIF
+      ! do we read or write the file?
+      IF( PRESENT(ldwrt) ) THEN   ;   llwrt = ldwrt
+      ELSE                        ;   llwrt = .FALSE.
+      ENDIF
+      ! do we call ctl_stop if we try to open a non-existing file in read mode?
+      IF( PRESENT(ldstop) ) THEN   ;   llstop = ldstop
+      ELSE                         ;   llstop = .TRUE.
+      ENDIF
+      ! what library do we use to open the file?
+      IF( PRESENT(kiolib) ) THEN   ;   iolib = kiolib
+      ELSE                         ;   iolib = jpnf90
+      ENDIF
+      ! are we using interpolation on the fly?
+      IF( PRESENT(ldiof) ) THEN   ;   lliof = ldiof
+      ELSE                        ;   lliof = .FALSE.
+      ENDIF
+      ! do we read the overlap 
+      ! ugly patch SM+JMM+RB to overwrite global definition in some cases
+      !llnoov = (jpni * jpnj ) == jpnij .AND. .NOT. lk_agrif
+      !llnoov = .true.
+      llnoov = .NOT. lk_agrif
+      ! create the file name by added, if needed, TRIM(Agrif_CFixed()) and TRIM(clsuffix)
+      ! =============
+      clname   = trim(cdname)
+      IF ( .NOT. Agrif_Root() .AND. .NOT. lliof ) THEN
+         iln    = INDEX(clname,'/') 
+         cltmpn = clname(1:iln)
+         clname = clname(iln+1:LEN_TRIM(clname))
+         clname=TRIM(cltmpn)//TRIM(Agrif_CFixed())//'_'//TRIM(clname)
+      ENDIF
+      ! which suffix should we use?
+      SELECT CASE (iolib)
+      CASE (jpnf90   ) ;   clsuffix = '.nc'
+      CASE DEFAULT     ;   clsuffix = ''
+         CALL ctl_stop( TRIM(clinfo), 'accepted IO library is only jpnf90 (jpioipsl option has been removed) ' )
+      END SELECT
+      ! Add the suffix if needed
+      iln = LEN_TRIM(clname)
+      ils = LEN_TRIM(clsuffix)
+      IF( iln <= ils .OR. INDEX( TRIM(clname), TRIM(clsuffix), back = .TRUE. ) /= iln - ils + 1 )   &
+         &   clname = TRIM(clname)//TRIM(clsuffix)
+      cltmpn = clname   ! store this name
+      ! try to find if the file to be opened already exist
+      ! =============
+      INQUIRE( FILE = clname, EXIST = llok )
+      IF( .NOT.llok ) THEN
+         ! we try to add the cpu number to the name
+         WRITE(clcpu,*) narea-1
+
+         clcpu  = TRIM(ADJUSTL(clcpu))
+         iln = INDEX(clname,TRIM(clsuffix), back = .TRUE.)
+         clname = clname(1:iln-1)//'_'//TRIM(clcpu)//TRIM(clsuffix)
+         icnt = 0
+         INQUIRE( FILE = clname, EXIST = llok ) 
+         ! we try different formats for the cpu number by adding 0
+         DO WHILE( .NOT.llok .AND. icnt < jpmax_digits )
+            clcpu  = "0"//trim(clcpu)
+            clname = clname(1:iln-1)//'_'//TRIM(clcpu)//TRIM(clsuffix)
+            INQUIRE( FILE = clname, EXIST = llok )
+            icnt = icnt + 1
+         END DO
+      ELSE
+         lxios_sini = .TRUE.
+      ENDIF
+      IF( llwrt ) THEN
+         ! check the domain definition
+! JMM + SM: ugly patch before getting the new version of lib_mpp)
+!         idom = jpdom_local_noovlap   ! default definition
+         IF( llnoov ) THEN   ;   idom = jpdom_local_noovlap   ! default definition
+         ELSE                ;   idom = jpdom_local_full      ! default definition
+         ENDIF
+         IF( PRESENT(kdom) )   idom = kdom
+         ! create the domain informations
+         ! =============
+         SELECT CASE (idom)
+         CASE (jpdom_local_full)
+            idompar(:,1) = (/ jpi             , jpj              /)
+            idompar(:,2) = (/ nimpp           , njmpp            /)
+            idompar(:,3) = (/ nimpp + jpi - 1 , njmpp + jpj - 1  /)
+            idompar(:,4) = (/ nldi - 1        , nldj - 1         /)
+            idompar(:,5) = (/ jpi - nlei      , jpj - nlej       /)
+         CASE (jpdom_local_noextra)
+            idompar(:,1) = (/ nlci            , nlcj             /)
+            idompar(:,2) = (/ nimpp           , njmpp            /)
+            idompar(:,3) = (/ nimpp + nlci - 1, njmpp + nlcj - 1 /)
+            idompar(:,4) = (/ nldi - 1        , nldj - 1         /)
+            idompar(:,5) = (/ nlci - nlei     , nlcj - nlej      /)
+         CASE (jpdom_local_noovlap)
+            idompar(:,1) = (/ nlei  - nldi + 1, nlej  - nldj + 1 /)
+            idompar(:,2) = (/ nimpp + nldi - 1, njmpp + nldj - 1 /)
+            idompar(:,3) = (/ nimpp + nlei - 1, njmpp + nlej - 1 /)
+            idompar(:,4) = (/ 0               , 0                /)
+            idompar(:,5) = (/ 0               , 0                /)
+         CASE DEFAULT
+            CALL ctl_stop( TRIM(clinfo), 'wrong value of kdom, only jpdom_local* cases are accepted' )
+         END SELECT
+      ENDIF
+      ! Open the NetCDF file
+      ! =============
+      ! do we have some free file identifier?
+      IF( MINVAL(iom_file(:)%nfid) /= 0 )   &
+         &   CALL ctl_stop( TRIM(clinfo), 'No more free file identifier', 'increase jpmax_files in iom_def' )
+      ! if no file was found...
+      IF( .NOT. llok ) THEN
+         IF( .NOT. llwrt ) THEN   ! we are in read mode 
+            IF( llstop ) THEN   ;   CALL ctl_stop( TRIM(clinfo), 'File '//TRIM(cltmpn)//'* not found' )
+            ELSE                ;   istop = nstop + 1   ! make sure that istop /= nstop so we don't open the file
+            ENDIF
+         ELSE                     ! we are in write mode so we 
+            clname = cltmpn       ! get back the file name without the cpu number
+         ENDIF
+      ELSE
+         IF( llwrt .AND. .NOT. ln_clobber ) THEN   ! we stop as we want to write in a new file 
+            CALL ctl_stop( TRIM(clinfo), 'We want to write in a new file but '//TRIM(clname)//' already exists...' )
+            istop = nstop + 1                      ! make sure that istop /= nstop so we don't open the file
+         ELSEIF( llwrt ) THEN     ! the file exists and we are in write mode with permission to 
+            clname = cltmpn       ! overwrite so get back the file name without the cpu number
+         ENDIF
+      ENDIF
+      IF( istop == nstop ) THEN   ! no error within this routine
+         SELECT CASE (iolib)
+         CASE (jpnf90   )   ;   CALL iom_nf90_open(    clname, kiomid, llwrt, llok, idompar, kdlev = kdlev )
+         CASE DEFAULT
+            CALL ctl_stop( TRIM(clinfo)//' accepted IO library is only jpnf90 (jpioipsl option has been removed) ' )
+         END SELECT
+      ENDIF
+      !
+   END SUBROUTINE iom_open
+
+
+   SUBROUTINE iom_close( kiomid )
+      !!--------------------------------------------------------------------
+      !!                   ***  SUBROUTINE  iom_close  ***
+      !!
+      !! ** Purpose : close an input file, or all files opened by iom
+      !!--------------------------------------------------------------------
+      INTEGER, INTENT(inout), OPTIONAL ::   kiomid   ! iom identifier of the file to be closed
+      !                                              ! return 0 when file is properly closed
+      !                                              ! No argument: all files opened by iom are closed
+
+      INTEGER ::   jf         ! dummy loop indices
+      INTEGER ::   i_s, i_e   ! temporary integer
+      CHARACTER(LEN=100)    ::   clinfo    ! info character
+      !---------------------------------------------------------------------
+      !
+      clinfo = '                    iom_close ~~~  '
+      IF( PRESENT(kiomid) ) THEN
+         i_s = kiomid
+         i_e = kiomid
+      ELSE
+         i_s = 1
+         i_e = jpmax_files
+      ENDIF
+
+      IF( i_s > 0 ) THEN
+         DO jf = i_s, i_e
+            IF( iom_file(jf)%nfid > 0 ) THEN
+               SELECT CASE (iom_file(jf)%iolib)
+               CASE (jpnf90   )   ;   CALL iom_nf90_close(    jf )
+               CASE DEFAULT
+                  CALL ctl_stop( TRIM(clinfo)//' accepted IO library is only jpnf90 (jpioipsl option has been removed)' )
+               END SELECT
+               iom_file(jf)%nfid       = 0          ! free the id 
+               IF( PRESENT(kiomid) )   kiomid = 0   ! return 0 as id to specify that the file was closed
+               IF(lwp) WRITE(numout,*) TRIM(clinfo)//' close file: '//TRIM(iom_file(jf)%name)//' ok'
+            ELSEIF( PRESENT(kiomid) ) THEN
+               WRITE(ctmp1,*) '--->',  kiomid
+               CALL ctl_stop( TRIM(clinfo)//' Invalid file identifier', ctmp1 )
+            ENDIF
+         END DO
+      ENDIF
+      !    
+   END SUBROUTINE iom_close
+
+
+   FUNCTION iom_varid ( kiomid, cdvar, kdimsz, kndims, ldstop )  
+      !!-----------------------------------------------------------------------
+      !!                  ***  FUNCTION  iom_varid  ***
+      !!
+      !! ** Purpose : get the id of a variable in a file (return 0 if not found)
+      !!-----------------------------------------------------------------------
+      INTEGER              , INTENT(in   )           ::   kiomid   ! file Identifier
+      CHARACTER(len=*)     , INTENT(in   )           ::   cdvar    ! name of the variable
+      INTEGER, DIMENSION(:), INTENT(  out), OPTIONAL ::   kdimsz   ! size of each dimension
+      INTEGER,               INTENT(  out), OPTIONAL ::   kndims   ! size of the dimensions
+      LOGICAL              , INTENT(in   ), OPTIONAL ::   ldstop   ! stop if looking for non-existing variable (default = .TRUE.)
+      !
+      INTEGER                        ::   iom_varid, iiv, i_nvd
+      LOGICAL                        ::   ll_fnd
+      CHARACTER(LEN=100)             ::   clinfo                   ! info character
+      LOGICAL                        ::   llstop                   ! local definition of ldstop
+      !!-----------------------------------------------------------------------
+      iom_varid = 0                         ! default definition
+      ! do we call ctl_stop if we look for non-existing variable?
+      IF( PRESENT(ldstop) ) THEN   ;   llstop = ldstop
+      ELSE                         ;   llstop = .TRUE.
+      ENDIF
+      !
+      IF( kiomid > 0 ) THEN
+         clinfo = 'iom_varid, file: '//trim(iom_file(kiomid)%name)//', var: '//trim(cdvar)
+         IF( iom_file(kiomid)%nfid == 0 ) THEN 
+            CALL ctl_stop( trim(clinfo), 'the file is not open' )
+         ELSE
+            ll_fnd  = .FALSE.
+            iiv = 0
+            !
+            DO WHILE ( .NOT.ll_fnd .AND. iiv < iom_file(kiomid)%nvars )
+               iiv = iiv + 1
+               ll_fnd  = ( TRIM(cdvar) == TRIM(iom_file(kiomid)%cn_var(iiv)) )
+            END DO
+            !
+            IF( .NOT.ll_fnd ) THEN
+               iiv = iiv + 1
+               IF( iiv <= jpmax_vars ) THEN
+                  SELECT CASE (iom_file(kiomid)%iolib)
+                  CASE (jpnf90   )   ;   iom_varid = iom_nf90_varid  ( kiomid, cdvar, iiv, kdimsz, kndims )
+                  CASE DEFAULT
+                     CALL ctl_stop( TRIM(clinfo)//' accepted IO library is only jpnf90 (jpioipsl option has been removed)' )
+                  END SELECT
+               ELSE
+                  CALL ctl_stop( trim(clinfo), 'Too many variables in the file '//iom_file(kiomid)%name,   &
+                        &                         'increase the parameter jpmax_vars')
+               ENDIF
+               IF( llstop .AND. iom_varid == -1 )   CALL ctl_stop( TRIM(clinfo)//' not found' ) 
+            ELSE
+               iom_varid = iiv
+               IF( PRESENT(kdimsz) ) THEN 
+                  i_nvd = iom_file(kiomid)%ndims(iiv)
+                  IF( i_nvd <= size(kdimsz) ) THEN
+                     kdimsz(1:i_nvd) = iom_file(kiomid)%dimsz(1:i_nvd,iiv)
+                  ELSE
+                     WRITE(ctmp1,*) i_nvd, size(kdimsz)
+                     CALL ctl_stop( trim(clinfo), 'error in kdimsz size'//trim(ctmp1) )
+                  ENDIF
+               ENDIF
+               IF( PRESENT(kndims) )  kndims = iom_file(kiomid)%ndims(iiv)
+            ENDIF
+         ENDIF
+      ENDIF
+      !
+   END FUNCTION iom_varid
+
+
+   !!----------------------------------------------------------------------
+   !!                   INTERFACE iom_get
+   !!----------------------------------------------------------------------
+   SUBROUTINE iom_g0d( kiomid, cdvar, pvar, ktime, ldxios )
+      INTEGER         , INTENT(in   )                 ::   kiomid    ! Identifier of the file
+      CHARACTER(len=*), INTENT(in   )                 ::   cdvar     ! Name of the variable
+      REAL(wp)        , INTENT(  out)                 ::   pvar      ! read field
+      INTEGER         , INTENT(in   ),     OPTIONAL   ::   ktime     ! record number
+      LOGICAL         , INTENT(in   ),     OPTIONAL   ::   ldxios    ! use xios to read restart
+      !
+      INTEGER                                         ::   idvar     ! variable id
+      INTEGER                                         ::   idmspc    ! number of spatial dimensions
+      INTEGER         , DIMENSION(1)                  ::   itime     ! record number
+      CHARACTER(LEN=100)                              ::   clinfo    ! info character
+      CHARACTER(LEN=100)                              ::   clname    ! file name
+      CHARACTER(LEN=1)                                ::   cldmspc   !
+      LOGICAL                                         ::   llxios
+      !
+      llxios = .FALSE.
+      IF( PRESENT(ldxios) ) llxios = ldxios
+
+      IF(.NOT.llxios) THEN  ! read data using default library
+         itime = 1
+         IF( PRESENT(ktime) ) itime = ktime
+         !
+         clname = iom_file(kiomid)%name
+         clinfo = '          iom_g0d, file: '//trim(clname)//', var: '//trim(cdvar)
+         !
+         IF( kiomid > 0 ) THEN
+            idvar = iom_varid( kiomid, cdvar )
+            IF( iom_file(kiomid)%nfid > 0 .AND. idvar > 0 ) THEN
+               idmspc = iom_file ( kiomid )%ndims( idvar )
+               IF( iom_file(kiomid)%luld(idvar) )  idmspc = idmspc - 1
+               WRITE(cldmspc , fmt='(i1)') idmspc
+               IF( idmspc > 0 )  CALL ctl_stop( TRIM(clinfo), 'When reading to a 0D array, we do not accept data', &
+                                    &                         'with 1 or more spatial dimensions: '//cldmspc//' were found.' , &
+                                    &                         'Use ncwa -a to suppress the unnecessary dimensions' )
+               SELECT CASE (iom_file(kiomid)%iolib)
+               CASE (jpnf90   )   ;   CALL iom_nf90_get(    kiomid, idvar, pvar, itime )
+               CASE DEFAULT
+                  CALL ctl_stop( 'iom_g0d: accepted IO library is only jpnf90 (jpioipsl option has been removed)' )
+               END SELECT
+            ENDIF
+         ENDIF
+      ELSE
+#if defined key_iomput
+         IF(lwp) WRITE(numout,*) 'XIOS RST READ (0D): ', trim(cdvar)
+         CALL iom_swap( TRIM(crxios_context) )
+         CALL xios_recv_field( trim(cdvar), pvar)
+         CALL iom_swap( TRIM(cxios_context) )
+#else
+         nstop = nstop + 1 
+         clinfo = 'Can not use XIOS in iom_g0d, file: '//trim(clname)//', var:'//trim(cdvar)
+#endif
+      ENDIF
+   END SUBROUTINE iom_g0d
+
+   SUBROUTINE iom_g1d( kiomid, kdom, cdvar, pvar, ktime, kstart, kcount, ldxios )
+      INTEGER         , INTENT(in   )                         ::   kiomid    ! Identifier of the file
+      INTEGER         , INTENT(in   )                         ::   kdom      ! Type of domain to be read
+      CHARACTER(len=*), INTENT(in   )                         ::   cdvar     ! Name of the variable
+      REAL(wp)        , INTENT(  out), DIMENSION(:)           ::   pvar      ! read field
+      INTEGER         , INTENT(in   )              , OPTIONAL ::   ktime     ! record number
+      INTEGER         , INTENT(in   ), DIMENSION(1), OPTIONAL ::   kstart    ! start axis position of the reading 
+      INTEGER         , INTENT(in   ), DIMENSION(1), OPTIONAL ::   kcount    ! number of points in each axis
+      LOGICAL         , INTENT(in   ),               OPTIONAL ::   ldxios    ! read data using XIOS
+      !
+      IF( kiomid > 0 ) THEN
+         IF( iom_file(kiomid)%nfid > 0 ) CALL iom_get_123d( kiomid, kdom       , cdvar        , pv_r1d=pvar,   &
+              &                                                     ktime=ktime, kstart=kstart, kcount=kcount, &
+              &                                                     ldxios=ldxios )
+      ENDIF
+   END SUBROUTINE iom_g1d
+
+   SUBROUTINE iom_g2d( kiomid, kdom, cdvar, pvar, ktime, kstart, kcount, lrowattr, ldxios)
+      INTEGER         , INTENT(in   )                           ::   kiomid    ! Identifier of the file
+      INTEGER         , INTENT(in   )                           ::   kdom      ! Type of domain to be read
+      CHARACTER(len=*), INTENT(in   )                           ::   cdvar     ! Name of the variable
+      REAL(wp)        , INTENT(  out), DIMENSION(:,:)           ::   pvar      ! read field
+      INTEGER         , INTENT(in   )                , OPTIONAL ::   ktime     ! record number
+      INTEGER         , INTENT(in   ), DIMENSION(2)  , OPTIONAL ::   kstart    ! start axis position of the reading 
+      INTEGER         , INTENT(in   ), DIMENSION(2)  , OPTIONAL ::   kcount    ! number of points in each axis
+      LOGICAL         , INTENT(in   )                , OPTIONAL ::   lrowattr  ! logical flag telling iom_get to
+                                                                               ! look for and use a file attribute
+                                                                               ! called open_ocean_jstart to set the start
+                                                                               ! value for the 2nd dimension (netcdf only)
+      LOGICAL         , INTENT(in   ),               OPTIONAL ::   ldxios      ! read data using XIOS
+      !
+      IF( kiomid > 0 ) THEN
+         IF( iom_file(kiomid)%nfid > 0 ) CALL iom_get_123d( kiomid, kdom       , cdvar        , pv_r2d=pvar,   &
+              &                                                     ktime=ktime, kstart=kstart, kcount=kcount, &
+              &                                                     lrowattr=lrowattr,  ldxios=ldxios)
+      ENDIF
+   END SUBROUTINE iom_g2d
+
+   SUBROUTINE iom_g3d( kiomid, kdom, cdvar, pvar, ktime, kstart, kcount, lrowattr, ldxios )
+      INTEGER         , INTENT(in   )                             ::   kiomid    ! Identifier of the file
+      INTEGER         , INTENT(in   )                             ::   kdom      ! Type of domain to be read
+      CHARACTER(len=*), INTENT(in   )                             ::   cdvar     ! Name of the variable
+      REAL(wp)        , INTENT(  out), DIMENSION(:,:,:)           ::   pvar      ! read field
+      INTEGER         , INTENT(in   )                  , OPTIONAL ::   ktime     ! record number
+      INTEGER         , INTENT(in   ), DIMENSION(3)    , OPTIONAL ::   kstart    ! start axis position of the reading 
+      INTEGER         , INTENT(in   ), DIMENSION(3)    , OPTIONAL ::   kcount    ! number of points in each axis
+      LOGICAL         , INTENT(in   )                  , OPTIONAL ::   lrowattr  ! logical flag telling iom_get to
+                                                                                 ! look for and use a file attribute
+                                                                                 ! called open_ocean_jstart to set the start
+                                                                                 ! value for the 2nd dimension (netcdf only)
+      LOGICAL         , INTENT(in   ),               OPTIONAL ::   ldxios        ! read data using XIOS
+      !
+      IF( kiomid > 0 ) THEN
+         IF( iom_file(kiomid)%nfid > 0 ) CALL iom_get_123d( kiomid, kdom       , cdvar        , pv_r3d=pvar,   &
+              &                                                     ktime=ktime, kstart=kstart, kcount=kcount, &
+              &                                                     lrowattr=lrowattr, ldxios=ldxios )
+      ENDIF
+   END SUBROUTINE iom_g3d
+   !!----------------------------------------------------------------------
+
+   SUBROUTINE iom_get_123d( kiomid, kdom  , cdvar ,   &
+         &                  pv_r1d, pv_r2d, pv_r3d,   &
+         &                  ktime , kstart, kcount,   &
+         &                  lrowattr, ldxios        )
+      !!-----------------------------------------------------------------------
+      !!                  ***  ROUTINE  iom_get_123d  ***
+      !!
+      !! ** Purpose : read a 1D/2D/3D variable
+      !!
+      !! ** Method : read ONE record at each CALL
+      !!-----------------------------------------------------------------------
+      INTEGER                    , INTENT(in   )           ::   kiomid     ! Identifier of the file
+      INTEGER                    , INTENT(in   )           ::   kdom       ! Type of domain to be read
+      CHARACTER(len=*)           , INTENT(in   )           ::   cdvar      ! Name of the variable
+      REAL(wp), DIMENSION(:)     , INTENT(  out), OPTIONAL ::   pv_r1d     ! read field (1D case)
+      REAL(wp), DIMENSION(:,:)   , INTENT(  out), OPTIONAL ::   pv_r2d     ! read field (2D case)
+      REAL(wp), DIMENSION(:,:,:) , INTENT(  out), OPTIONAL ::   pv_r3d     ! read field (3D case)
+      INTEGER                    , INTENT(in   ), OPTIONAL ::   ktime      ! record number
+      INTEGER , DIMENSION(:)     , INTENT(in   ), OPTIONAL ::   kstart     ! start position of the reading in each axis 
+      INTEGER , DIMENSION(:)     , INTENT(in   ), OPTIONAL ::   kcount     ! number of points to be read in each axis
+      LOGICAL                    , INTENT(in   ), OPTIONAL ::   lrowattr   ! logical flag telling iom_get to
+                                                                           ! look for and use a file attribute
+                                                                           ! called open_ocean_jstart to set the start
+                                                                           ! value for the 2nd dimension (netcdf only)
+      LOGICAL                    , INTENT(in   ), OPTIONAL ::   ldxios     ! use XIOS to read restart
+      !
+      LOGICAL                        ::   llxios       ! local definition for XIOS read
+      LOGICAL                        ::   llnoov      ! local definition to read overlap
+      LOGICAL                        ::   luse_jattr  ! local definition to read open_ocean_jstart file attribute
+      INTEGER                        ::   jstartrow   ! start point for 2nd dimension optionally set by file attribute
+      INTEGER                        ::   jl          ! loop on number of dimension 
+      INTEGER                        ::   idom        ! type of domain
+      INTEGER                        ::   idvar       ! id of the variable
+      INTEGER                        ::   inbdim      ! number of dimensions of the variable
+      INTEGER                        ::   idmspc      ! number of spatial dimensions 
+      INTEGER                        ::   itime       ! record number
+      INTEGER                        ::   istop       ! temporary value of nstop
+      INTEGER                        ::   ix1, ix2, iy1, iy2   ! subdomain indexes
+      INTEGER                        ::   ji, jj      ! loop counters
+      INTEGER                        ::   irankpv     ! 
+      INTEGER                        ::   ind1, ind2  ! substring index
+      INTEGER, DIMENSION(jpmax_dims) ::   istart      ! starting point to read for each axis
+      INTEGER, DIMENSION(jpmax_dims) ::   icnt        ! number of value to read along each axis 
+      INTEGER, DIMENSION(jpmax_dims) ::   idimsz      ! size of the dimensions of the variable
+      INTEGER, DIMENSION(jpmax_dims) ::   ishape      ! size of the dimensions of the variable
+      REAL(wp)                       ::   zscf, zofs  ! sacle_factor and add_offset
+      INTEGER                        ::   itmp        ! temporary integer
+      CHARACTER(LEN=256)             ::   clinfo      ! info character
+      CHARACTER(LEN=256)             ::   clname      ! file name
+      CHARACTER(LEN=1)               ::   clrankpv, cldmspc      ! 
+      LOGICAL                        ::   ll_depth_spec ! T => if kstart, kcount present then *only* use values for 3rd spatial dimension.
+      INTEGER                        ::   inlev       ! number of levels for 3D data
+      REAL(wp)                       ::   gma, gmi
+      !---------------------------------------------------------------------
+      !
+      inlev = -1
+      IF( PRESENT(pv_r3d) )   inlev = SIZE(pv_r3d, 3)
+      !
+      llxios = .FALSE.
+      if(PRESENT(ldxios)) llxios = ldxios
+      idvar = iom_varid( kiomid, cdvar ) 
+      idom = kdom
+      !
+      IF(.NOT.llxios) THEN
+         clname = iom_file(kiomid)%name   !   esier to read
+         clinfo = '          iom_get_123d, file: '//trim(clname)//', var: '//trim(cdvar)
+         ! local definition of the domain ?
+         ! do we read the overlap 
+         ! ugly patch SM+JMM+RB to overwrite global definition in some cases
+         llnoov = (jpni * jpnj ) == jpnij .AND. .NOT. lk_agrif 
+         ! check kcount and kstart optionals parameters...
+         IF( PRESENT(kcount) .AND. (.NOT. PRESENT(kstart)) ) CALL ctl_stop(trim(clinfo), 'kcount present needs kstart present')
+         IF( PRESENT(kstart) .AND. (.NOT. PRESENT(kcount)) ) CALL ctl_stop(trim(clinfo), 'kstart present needs kcount present')
+         IF( PRESENT(kstart) .AND. idom /= jpdom_unknown .AND.  idom /= jpdom_autoglo_xy  ) &
+     &          CALL ctl_stop(trim(clinfo), 'kstart present needs kdom = jpdom_unknown or kdom = jpdom_autoglo_xy')
+
+         luse_jattr = .false.
+         IF( PRESENT(lrowattr) ) THEN
+            IF( lrowattr .AND. idom /= jpdom_data   ) CALL ctl_stop(trim(clinfo), 'lrowattr present and true needs kdom = jpdom_data')
+            IF( lrowattr .AND. idom == jpdom_data   ) luse_jattr = .true.
+         ENDIF
+         IF( luse_jattr ) THEN
+            SELECT CASE (iom_file(kiomid)%iolib)
+            CASE (jpnf90   )   
+                ! Ok
+            CASE DEFAULT    
+               CALL ctl_stop( TRIM(clinfo)//' accepted IO library is only jpnf90 (jpioipsl option has been removed)' )
+            END SELECT
+         ENDIF
+
+         ! Search for the variable in the data base (eventually actualize data)
+         istop = nstop
+         !
+         IF( idvar > 0 ) THEN
+            ! to write iom_file(kiomid)%dimsz in a shorter way !
+            idimsz(:) = iom_file(kiomid)%dimsz(:, idvar) 
+            inbdim = iom_file(kiomid)%ndims(idvar)            ! number of dimensions in the file
+            idmspc = inbdim                                   ! number of spatial dimensions in the file
+            IF( iom_file(kiomid)%luld(idvar) )   idmspc = inbdim - 1
+            IF( idmspc > 3 )   CALL ctl_stop(trim(clinfo), 'the file has more than 3 spatial dimensions this case is not coded...') 
+            !
+            ! update idom definition...
+            ! Identify the domain in case of jpdom_auto(glo/dta) definition
+            IF( idom == jpdom_autoglo_xy ) THEN
+               ll_depth_spec = .TRUE.
+               idom = jpdom_autoglo
+            ELSE
+               ll_depth_spec = .FALSE.
+            ENDIF
+            IF( idom == jpdom_autoglo .OR. idom == jpdom_autodta ) THEN            
+               IF( idom == jpdom_autoglo ) THEN   ;   idom = jpdom_global 
+               ELSE                               ;   idom = jpdom_data
+               ENDIF
+               ind1 = INDEX( clname, '_', back = .TRUE. ) + 1
+               ind2 = INDEX( clname, '.', back = .TRUE. ) - 1
+               IF( ind2 > ind1 ) THEN   ;   IF( VERIFY( clname(ind1:ind2), '0123456789' ) == 0 )   idom = jpdom_local   ;   ENDIF
+            ENDIF
+            ! Identify the domain in case of jpdom_local definition
+            IF( idom == jpdom_local ) THEN
+               IF(     idimsz(1) == jpi               .AND. idimsz(2) == jpj               ) THEN   ;   idom = jpdom_local_full
+               ELSEIF( idimsz(1) == nlci              .AND. idimsz(2) == nlcj              ) THEN   ;   idom = jpdom_local_noextra
+               ELSEIF( idimsz(1) == (nlei - nldi + 1) .AND. idimsz(2) == (nlej - nldj + 1) ) THEN   ;   idom = jpdom_local_noovlap
+               ELSE   ;   CALL ctl_stop( trim(clinfo), 'impossible to identify the local domain' )
+               ENDIF
+            ENDIF
+            !
+            ! check the consistency between input array and data rank in the file
+            !
+            ! initializations
+            itime = 1
+            IF( PRESENT(ktime) ) itime = ktime
+            !
+            irankpv = 1 * COUNT( (/PRESENT(pv_r1d)/) ) + 2 * COUNT( (/PRESENT(pv_r2d)/) ) + 3 * COUNT( (/PRESENT(pv_r3d)/) )
+            WRITE(clrankpv, fmt='(i1)') irankpv
+            WRITE(cldmspc , fmt='(i1)') idmspc
+            !
+            IF(     idmspc <  irankpv ) THEN 
+               CALL ctl_stop( TRIM(clinfo), 'The file has only '//cldmspc//' spatial dimension',   &
+                  &                         'it is impossible to read a '//clrankpv//'D array from this file...' )
+            ELSEIF( idmspc == irankpv ) THEN
+               IF( PRESENT(pv_r1d) .AND. idom /= jpdom_unknown )   &
+                  &   CALL ctl_stop( TRIM(clinfo), 'case not coded...You must use jpdom_unknown' )
+            ELSEIF( idmspc >  irankpv ) THEN
+                  IF( PRESENT(pv_r2d) .AND. itime == 1 .AND. idimsz(3) == 1 .AND. idmspc == 3 ) THEN
+                     CALL ctl_warn( trim(clinfo), '2D array but 3 spatial dimensions for the data...'              ,   &
+                           &         'As the size of the z dimension is 1 and as we try to read the first record, ',   &
+                           &         'we accept this case, even if there is a possible mix-up between z and time dimension' )   
+                     idmspc = idmspc - 1
+                  ELSE
+                     CALL ctl_stop( TRIM(clinfo), 'To keep iom lisibility, when reading a '//clrankpv//'D array,'         ,   &
+                        &                         'we do not accept data with '//cldmspc//' spatial dimensions',   &
+                        &                         'Use ncwa -a to suppress the unnecessary dimensions' )
+                  ENDIF
+            ENDIF
+            !
+            ! definition of istart and icnt
+            !
+            icnt  (:) = 1
+            istart(:) = 1
+            istart(idmspc+1) = itime
+   
+            IF( PRESENT(kstart) .AND. .NOT. ll_depth_spec ) THEN 
+               istart(1:idmspc) = kstart(1:idmspc) 
+               icnt  (1:idmspc) = kcount(1:idmspc)
+            ELSE
+               IF(idom == jpdom_unknown ) THEN
+                  icnt(1:idmspc) = idimsz(1:idmspc)
+               ELSE 
+                  IF( .NOT. PRESENT(pv_r1d) ) THEN   !   not a 1D array
+                     IF(     idom == jpdom_data    ) THEN
+                        jstartrow = 1
+                        IF( luse_jattr ) THEN
+                           CALL iom_getatt(kiomid, 'open_ocean_jstart', jstartrow ) ! -999 is returned if the attribute is not found
+                           jstartrow = MAX(1,jstartrow)
+                        ENDIF
+                        istart(1:2) = (/ mig(1), mjg(1) + jstartrow - 1 /)  ! icnt(1:2) done below
+                     ELSEIF( idom == jpdom_global  ) THEN ; istart(1:2) = (/ nimpp , njmpp  /)  ! icnt(1:2) done below
+                     ENDIF
+                     ! we do not read the overlap                     -> we start to read at nldi, nldj
+! JMM + SM: ugly patch before getting the new version of lib_mpp)
+!                  IF( idom /= jpdom_local_noovlap )   istart(1:2) = istart(1:2) + (/ nldi - 1, nldj - 1 /)
+                     IF( llnoov .AND. idom /= jpdom_local_noovlap ) istart(1:2) = istart(1:2) + (/ nldi - 1, nldj - 1 /)
+                  ! we do not read the overlap and the extra-halos -> from nldi to nlei and from nldj to nlej 
+! JMM + SM: ugly patch before getting the new version of lib_mpp)
+!                  icnt(1:2) = (/ nlei - nldi + 1, nlej - nldj + 1 /)
+                     IF( llnoov ) THEN   ;   icnt(1:2) = (/ nlei - nldi + 1, nlej - nldj + 1 /)
+                     ELSE                ;   icnt(1:2) = (/ nlci           , nlcj            /)
+                     ENDIF
+                     IF( PRESENT(pv_r3d) ) THEN
+                        IF( idom == jpdom_data ) THEN                        ;                               icnt(3) = inlev
+                        ELSEIF( ll_depth_spec .AND. PRESENT(kstart) ) THEN   ;   istart(3) = kstart(3)   ;   icnt(3) = kcount(3)
+                        ELSE                                                 ;                               icnt(3) = inlev
+                        ENDIF
+                     ENDIF
+                  ENDIF
+               ENDIF
+            ENDIF
+
+            ! check that istart and icnt can be used with this file
+            !-
+            DO jl = 1, jpmax_dims
+               itmp = istart(jl)+icnt(jl)-1
+               IF( itmp > idimsz(jl) .AND. idimsz(jl) /= 0 ) THEN
+                  WRITE( ctmp1, FMT="('(istart(', i1, ') + icnt(', i1, ') - 1) = ', i5)" ) jl, jl, itmp
+                  WRITE( ctmp2, FMT="(' is larger than idimsz(', i1,') = ', i5)"         ) jl, idimsz(jl)
+                  CALL ctl_stop( trim(clinfo), 'start and count too big regarding to the size of the data, ', ctmp1, ctmp2 )     
+               ENDIF
+            END DO
+
+            ! check that icnt matches the input array
+            !-     
+            IF( idom == jpdom_unknown ) THEN
+               IF( irankpv == 1 )        ishape(1:1) = SHAPE(pv_r1d)
+               IF( irankpv == 2 )        ishape(1:2) = SHAPE(pv_r2d)
+               IF( irankpv == 3 )        ishape(1:3) = SHAPE(pv_r3d)
+               ctmp1 = 'd'
+            ELSE
+               IF( irankpv == 2 ) THEN
+! JMM + SM: ugly patch before getting the new version of lib_mpp)
+!               ishape(1:2) = SHAPE(pv_r2d(nldi:nlei,nldj:nlej  ))   ;   ctmp1 = 'd(nldi:nlei,nldj:nlej)'
+                  IF( llnoov ) THEN ; ishape(1:2)=SHAPE(pv_r2d(nldi:nlei,nldj:nlej  )) ; ctmp1='d(nldi:nlei,nldj:nlej)'
+                  ELSE              ; ishape(1:2)=SHAPE(pv_r2d(1   :nlci,1   :nlcj  )) ; ctmp1='d(1:nlci,1:nlcj)'
+                  ENDIF
+               ENDIF
+               IF( irankpv == 3 ) THEN 
+! JMM + SM: ugly patch before getting the new version of lib_mpp)
+!               ishape(1:3) = SHAPE(pv_r3d(nldi:nlei,nldj:nlej,:))   ;   ctmp1 = 'd(nldi:nlei,nldj:nlej,:)'
+                  IF( llnoov ) THEN ; ishape(1:3)=SHAPE(pv_r3d(nldi:nlei,nldj:nlej,:)) ; ctmp1='d(nldi:nlei,nldj:nlej,:)'
+                  ELSE              ; ishape(1:3)=SHAPE(pv_r3d(1   :nlci,1   :nlcj,:)) ; ctmp1='d(1:nlci,1:nlcj,:)'
+                  ENDIF
+               ENDIF
+            ENDIF
+         
+            DO jl = 1, irankpv
+               WRITE( ctmp2, FMT="(', ', i1,'): ', i5,' /= icnt(', i1,'):', i5)" ) jl, ishape(jl), jl, icnt(jl)
+               IF( ishape(jl) /= icnt(jl) )   CALL ctl_stop( TRIM(clinfo), 'size(pv_r'//clrankpv//TRIM(ctmp1)//TRIM(ctmp2) )
+            END DO
+
+         ENDIF
+
+         ! read the data
+         !-     
+         IF( idvar > 0 .AND. istop == nstop ) THEN   ! no additional errors until this point...
+            !
+         ! find the right index of the array to be read
+! JMM + SM: ugly patch before getting the new version of lib_mpp)
+!         IF( idom /= jpdom_unknown ) THEN   ;   ix1 = nldi   ;   ix2 = nlei      ;   iy1 = nldj   ;   iy2 = nlej
+!         ELSE                               ;   ix1 = 1      ;   ix2 = icnt(1)   ;   iy1 = 1      ;   iy2 = icnt(2)
+!         ENDIF
+            IF( llnoov ) THEN
+               IF( idom /= jpdom_unknown ) THEN   ;   ix1 = nldi   ;   ix2 = nlei      ;   iy1 = nldj   ;   iy2 = nlej
+               ELSE                               ;   ix1 = 1      ;   ix2 = icnt(1)   ;   iy1 = 1      ;   iy2 = icnt(2)
+               ENDIF
+            ELSE
+               IF( idom /= jpdom_unknown ) THEN   ;   ix1 = 1      ;   ix2 = nlci      ;   iy1 = 1      ;   iy2 = nlcj
+               ELSE                               ;   ix1 = 1      ;   ix2 = icnt(1)   ;   iy1 = 1      ;   iy2 = icnt(2)
+               ENDIF
+            ENDIF
+      
+            SELECT CASE (iom_file(kiomid)%iolib)
+            CASE (jpnf90   )   ;   CALL iom_nf90_get(    kiomid, idvar, inbdim, istart, icnt, ix1, ix2, iy1, iy2,   &
+               &                                         pv_r1d, pv_r2d, pv_r3d )
+            CASE DEFAULT
+               CALL ctl_stop( TRIM(clinfo)//' accepted IO library is only jpnf90 (jpioipsl option has been removed)' )
+            END SELECT
+
+            IF( istop == nstop ) THEN   ! no additional errors until this point...
+               IF(lwp) WRITE(numout,"(10x,' read ',a,' (rec: ',i6,') in ',a,' ok')") TRIM(cdvar), itime, TRIM(iom_file(kiomid)%name)
+             
+               !--- overlap areas and extra hallows (mpp)
+               IF(     PRESENT(pv_r2d) .AND. idom /= jpdom_unknown ) THEN
+                  CALL lbc_lnk( pv_r2d,'Z',-999.,'no0' )
+               ELSEIF( PRESENT(pv_r3d) .AND. idom /= jpdom_unknown ) THEN
+                  ! this if could be simplified with the new lbc_lnk that works with any size of the 3rd dimension
+                  IF( icnt(3) == inlev ) THEN
+                     CALL lbc_lnk( pv_r3d,'Z',-999.,'no0' )
+                  ELSE   ! put some arbitrary value (a call to lbc_lnk will be done later...)
+                     DO jj = nlcj+1, jpj   ;   pv_r3d(1:nlci, jj, :) = pv_r3d(1:nlci, nlej, :)   ;   END DO
+                     DO ji = nlci+1, jpi   ;   pv_r3d(ji    , : , :) = pv_r3d(nlei  , :   , :)   ;   END DO
+                  ENDIF
+               ENDIF
+               !
+            ELSE
+               ! return if istop == nstop is false
+               RETURN
+            ENDIF
+         ELSE
+            ! return if statment idvar > 0 .AND. istop == nstop is false
+            RETURN
+         ENDIF
+         !
+      ELSE        ! read using XIOS. Only if KEY_IOMPUT is defined
+#if defined key_iomput
+!would be good to be able to check which context is active and swap only if current is not restart
+         CALL iom_swap( TRIM(crxios_context) ) 
+         IF( PRESENT(pv_r3d) ) THEN
+            pv_r3d(:, :, :) = 0.
+            if(lwp) write(numout,*) 'XIOS RST READ (3D): ',trim(cdvar)
+            CALL xios_recv_field( trim(cdvar), pv_r3d)
+            IF(idom /= jpdom_unknown ) then
+                CALL lbc_lnk( pv_r3d,'Z',-999.,'no0' )
+            ENDIF
+         ELSEIF( PRESENT(pv_r2d) ) THEN
+            pv_r2d(:, :) = 0.
+            if(lwp) write(numout,*) 'XIOS RST READ (2D): ', trim(cdvar)
+            CALL xios_recv_field( trim(cdvar), pv_r2d)
+            IF(idom /= jpdom_unknown ) THEN
+                CALL lbc_lnk(pv_r2d,'Z',-999.,'no0')
+            ENDIF
+         ELSEIF( PRESENT(pv_r1d) ) THEN
+            pv_r1d(:) = 0.
+            if(lwp) write(numout,*) 'XIOS RST READ (1D): ', trim(cdvar)
+            CALL xios_recv_field( trim(cdvar), pv_r1d)
+         ENDIF
+         CALL iom_swap( TRIM(cxios_context) )
+#else
+         istop = istop + 1 
+         clinfo = 'Can not use XIOS in iom_get_123d, file: '//trim(clname)//', var:'//trim(cdvar)
+#endif
+      ENDIF
+!some final adjustments
+      ! C1D case : always call lbc_lnk to replicate the central value over the whole 3X3 domain
+      IF( lk_c1d .AND. PRESENT(pv_r2d) )   CALL lbc_lnk( pv_r2d,'Z',1. )
+      IF( lk_c1d .AND. PRESENT(pv_r3d) )   CALL lbc_lnk( pv_r3d,'Z',1. )
+
+      !--- Apply scale_factor and offset
+      zscf = iom_file(kiomid)%scf(idvar)      ! scale factor
+      zofs = iom_file(kiomid)%ofs(idvar)      ! offset
+      IF(     PRESENT(pv_r1d) ) THEN
+         IF( zscf /= 1. )   pv_r1d(:) = pv_r1d(:) * zscf 
+         IF( zofs /= 0. )   pv_r1d(:) = pv_r1d(:) + zofs
+      ELSEIF( PRESENT(pv_r2d) ) THEN
+         IF( zscf /= 1.)   pv_r2d(:,:) = pv_r2d(:,:) * zscf
+         IF( zofs /= 0.)   pv_r2d(:,:) = pv_r2d(:,:) + zofs
+      ELSEIF( PRESENT(pv_r3d) ) THEN
+         IF( zscf /= 1.)   pv_r3d(:,:,:) = pv_r3d(:,:,:) * zscf
+         IF( zofs /= 0.)   pv_r3d(:,:,:) = pv_r3d(:,:,:) + zofs
+      ENDIF
+      !
+   END SUBROUTINE iom_get_123d
+
+
+   SUBROUTINE iom_gettime( kiomid, ptime, cdvar, kntime, cdunits, cdcalendar )
+      !!--------------------------------------------------------------------
+      !!                   ***  SUBROUTINE iom_gettime  ***
+      !!
+      !! ** Purpose : read the time axis cdvar in the file 
+      !!--------------------------------------------------------------------
+      INTEGER                    , INTENT(in   ) ::   kiomid     ! file Identifier
+      REAL(wp), DIMENSION(:)     , INTENT(  out) ::   ptime      ! the time axis
+      CHARACTER(len=*), OPTIONAL , INTENT(in   ) ::   cdvar      ! time axis name
+      INTEGER         , OPTIONAL , INTENT(  out) ::   kntime     ! number of times in file
+      CHARACTER(len=*), OPTIONAL , INTENT(  out) ::   cdunits    ! units attribute of time coordinate
+      CHARACTER(len=*), OPTIONAL , INTENT(  out) ::   cdcalendar ! calendar attribute of 
+      !
+      INTEGER, DIMENSION(1) :: kdimsz
+      INTEGER            ::   idvar    ! id of the variable
+      CHARACTER(LEN=32)  ::   tname    ! local name of time coordinate
+      CHARACTER(LEN=100) ::   clinfo   ! info character
+      !---------------------------------------------------------------------
+      !
+      IF ( PRESENT(cdvar) ) THEN
+         tname = cdvar
+      ELSE
+         tname = iom_file(kiomid)%uldname
+      ENDIF
+      IF( kiomid > 0 ) THEN
+         clinfo = 'iom_gettime, file: '//trim(iom_file(kiomid)%name)//', var: '//trim(tname)
+         IF ( PRESENT(kntime) ) THEN
+            idvar  = iom_varid( kiomid, tname, kdimsz = kdimsz )
+            kntime = kdimsz(1)
+         ELSE
+            idvar = iom_varid( kiomid, tname )
+         ENDIF
+         !
+         ptime(:) = 0. ! default definition
+         IF( idvar > 0 ) THEN
+            IF( iom_file(kiomid)%ndims(idvar) == 1 ) THEN
+               IF( iom_file(kiomid)%luld(idvar) ) THEN
+                  IF( iom_file(kiomid)%dimsz(1,idvar) <= size(ptime) ) THEN
+                     SELECT CASE (iom_file(kiomid)%iolib)
+                     CASE (jpnf90   )   ;   CALL iom_nf90_gettime(   kiomid, idvar, ptime, cdunits, cdcalendar )
+                     CASE DEFAULT
+                        CALL ctl_stop( TRIM(clinfo)//' accepted IO library is only jpnf90 (jpioipsl option has been removed)' )
+                     END SELECT
+                  ELSE
+                     WRITE(ctmp1,*) 'error with the size of ptime ',size(ptime),iom_file(kiomid)%dimsz(1,idvar)
+                     CALL ctl_stop( trim(clinfo), trim(ctmp1) )
+                  ENDIF
+               ELSE
+                  CALL ctl_stop( trim(clinfo), 'variable dimension is not unlimited... use iom_get' )
+               ENDIF
+            ELSE
+               CALL ctl_stop( trim(clinfo), 'the variable has more than 1 dimension' )
+            ENDIF
+         ELSE
+            CALL ctl_stop( trim(clinfo), 'variable not found in '//iom_file(kiomid)%name )
+         ENDIF
+      ENDIF
+      !
+   END SUBROUTINE iom_gettime
+
+
+   !!----------------------------------------------------------------------
+   !!                   INTERFACE iom_getatt
+   !!----------------------------------------------------------------------
+   SUBROUTINE iom_g0d_iatt( kiomid, cdatt, pvar, cdvar )
+      INTEGER         , INTENT(in   )                 ::   kiomid    ! Identifier of the file
+      CHARACTER(len=*), INTENT(in   )                 ::   cdatt     ! Name of the attribute
+      INTEGER         , INTENT(  out)                 ::   pvar      ! read field
+      CHARACTER(len=*), INTENT(in   ), OPTIONAL       ::   cdvar     ! Name of the variable
+      !
+      IF( kiomid > 0 ) THEN
+         IF( iom_file(kiomid)%nfid > 0 ) THEN
+            SELECT CASE (iom_file(kiomid)%iolib)
+            CASE (jpnf90   )   ;   IF( PRESENT(cdvar) ) THEN
+                                      CALL iom_nf90_getatt( kiomid, cdatt, pvar, cdvar=cdvar )
+                                   ELSE
+                                      CALL iom_nf90_getatt( kiomid, cdatt, pvar )
+                                   ENDIF
+            CASE DEFAULT
+               CALL ctl_stop( 'iom_g0d_iatt: accepted IO library is only jpnf90' )
+            END SELECT
+         ENDIF
+      ENDIF
+   END SUBROUTINE iom_g0d_iatt
+
+   SUBROUTINE iom_g0d_ratt( kiomid, cdatt, pvar, cdvar )
+      INTEGER         , INTENT(in   )                 ::   kiomid    ! Identifier of the file
+      CHARACTER(len=*), INTENT(in   )                 ::   cdatt     ! Name of the attribute
+      REAL(wp)        , INTENT(  out)                 ::   pvar      ! written field
+      CHARACTER(len=*), INTENT(in   ), OPTIONAL       ::   cdvar     ! Name of the variable
+      !
+      IF( kiomid > 0 ) THEN
+         IF( iom_file(kiomid)%nfid > 0 ) THEN
+            SELECT CASE (iom_file(kiomid)%iolib)
+            CASE (jpnf90   )   ;   IF( PRESENT(cdvar) ) THEN
+                                      CALL iom_nf90_getatt( kiomid, cdatt, pvar, cdvar=cdvar )
+                                   ELSE
+                                      CALL iom_nf90_getatt( kiomid, cdatt, pvar )
+                                   ENDIF
+            CASE DEFAULT    
+               CALL ctl_stop( 'iom_g0d_ratt: accepted IO library is only jpnf90' )
+            END SELECT
+         ENDIF
+      ENDIF
+   END SUBROUTINE iom_g0d_ratt
+
+   SUBROUTINE iom_g0d_catt( kiomid, cdatt, pvar, cdvar )
+      INTEGER         , INTENT(in   )                 ::   kiomid    ! Identifier of the file
+      CHARACTER(len=*), INTENT(in   )                 ::   cdatt     ! Name of the attribute
+      CHARACTER(len=*), INTENT(  out)                 ::   pvar      ! written field
+      CHARACTER(len=*), INTENT(in   ), OPTIONAL       ::   cdvar     ! Name of the variable
+      !
+      IF( kiomid > 0 ) THEN
+         IF( iom_file(kiomid)%nfid > 0 ) THEN
+            SELECT CASE (iom_file(kiomid)%iolib)
+            CASE (jpnf90   )   ;   IF( PRESENT(cdvar) ) THEN
+                                      CALL iom_nf90_getatt( kiomid, cdatt, pvar, cdvar=cdvar )
+                                   ELSE
+                                      CALL iom_nf90_getatt( kiomid, cdatt, pvar )
+                                   ENDIF
+            CASE DEFAULT
+               CALL ctl_stop( 'iom_g0d_ratt: accepted IO library is only jpnf90' )
+            END SELECT
+         ENDIF
+      ENDIF
+   END SUBROUTINE iom_g0d_catt
+
+   !!----------------------------------------------------------------------
+   !!                   INTERFACE iom_putatt
+   !!----------------------------------------------------------------------
+   SUBROUTINE iom_p0d_iatt( kiomid, cdatt, pvar, cdvar )
+      INTEGER         , INTENT(in   )                 ::   kiomid    ! Identifier of the file
+      CHARACTER(len=*), INTENT(in   )                 ::   cdatt     ! Name of the attribute
+      INTEGER         , INTENT(in   )                 ::   pvar      ! write field
+      CHARACTER(len=*), INTENT(in   ), OPTIONAL       ::   cdvar     ! Name of the variable
+      !
+      IF( kiomid > 0 ) THEN
+         IF( iom_file(kiomid)%nfid > 0 ) THEN
+            SELECT CASE (iom_file(kiomid)%iolib)
+            CASE (jpnf90   )   ;   IF( PRESENT(cdvar) ) THEN
+                                      CALL iom_nf90_putatt( kiomid, cdatt, pvar, cdvar=cdvar )
+                                   ELSE
+                                      CALL iom_nf90_putatt( kiomid, cdatt, pvar )
+                                   ENDIF
+            CASE DEFAULT
+               CALL ctl_stop( 'iom_p0d_iatt: accepted IO library is only jpnf90' )
+            END SELECT
+         ENDIF
+      ENDIF
+   END SUBROUTINE iom_p0d_iatt
+
+   SUBROUTINE iom_p0d_ratt( kiomid, cdatt, pvar, cdvar )
+      INTEGER         , INTENT(in   )                 ::   kiomid    ! Identifier of the file
+      CHARACTER(len=*), INTENT(in   )                 ::   cdatt     ! Name of the attribute
+      REAL(wp)        , INTENT(in   )                 ::   pvar      ! write field
+      CHARACTER(len=*), INTENT(in   ), OPTIONAL       ::   cdvar     ! Name of the variable
+      !
+      IF( kiomid > 0 ) THEN
+         IF( iom_file(kiomid)%nfid > 0 ) THEN
+            SELECT CASE (iom_file(kiomid)%iolib)
+            CASE (jpnf90   )   ;   IF( PRESENT(cdvar) ) THEN
+                                      CALL iom_nf90_putatt( kiomid, cdatt, pvar, cdvar=cdvar )
+                                   ELSE
+                                      CALL iom_nf90_putatt( kiomid, cdatt, pvar )
+                                   ENDIF
+            CASE DEFAULT    
+               CALL ctl_stop( 'iom_p0d_ratt: accepted IO library is only jpnf90' )
+            END SELECT
+         ENDIF
+      ENDIF
+   END SUBROUTINE iom_p0d_ratt
+
+   SUBROUTINE iom_p0d_catt( kiomid, cdatt, pvar, cdvar )
+      INTEGER         , INTENT(in   )                 ::   kiomid    ! Identifier of the file
+      CHARACTER(len=*), INTENT(in   )                 ::   cdatt     ! Name of the attribute
+      CHARACTER(len=*), INTENT(in   )                 ::   pvar      ! write field
+      CHARACTER(len=*), INTENT(in   ), OPTIONAL       ::   cdvar     ! Name of the variable
+      !
+      IF( kiomid > 0 ) THEN
+         IF( iom_file(kiomid)%nfid > 0 ) THEN
+            SELECT CASE (iom_file(kiomid)%iolib)
+            CASE (jpnf90   )   ;   IF( PRESENT(cdvar) ) THEN
+                                      CALL iom_nf90_putatt( kiomid, cdatt, pvar, cdvar=cdvar )
+                                   ELSE
+                                      CALL iom_nf90_putatt( kiomid, cdatt, pvar )
+                                   ENDIF
+            CASE DEFAULT
+               CALL ctl_stop( 'iom_p0d_ratt: accepted IO library is only jpnf90' )
+            END SELECT
+         ENDIF
+      ENDIF
+   END SUBROUTINE iom_p0d_catt
+
+   !!----------------------------------------------------------------------
+   !!                   INTERFACE iom_rstput
+   !!----------------------------------------------------------------------
+   SUBROUTINE iom_rp0d( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios )
+      INTEGER         , INTENT(in)                         ::   kt       ! ocean time-step
+      INTEGER         , INTENT(in)                         ::   kwrite   ! writing time-step
+      INTEGER         , INTENT(in)                         ::   kiomid   ! Identifier of the file 
+      CHARACTER(len=*), INTENT(in)                         ::   cdvar    ! time axis name
+      REAL(wp)        , INTENT(in)                         ::   pvar     ! written field
+      INTEGER         , INTENT(in), OPTIONAL               ::   ktype    ! variable external type
+      LOGICAL, OPTIONAL :: ldxios   ! xios write flag
+      LOGICAL :: llx                ! local xios write flag
+      INTEGER :: ivid   ! variable id
+
+      llx = .FALSE.
+      IF(PRESENT(ldxios)) llx = ldxios
+      IF( llx ) THEN
+#ifdef key_iomput
+      IF( kt == kwrite ) THEN
+          IF(lwp) write(numout,*) 'RESTART: write (XIOS 0D) ',trim(cdvar)
+          CALL xios_send_field(trim(cdvar), pvar)
+      ENDIF
+#endif
+      ELSE
+         IF( kiomid > 0 ) THEN
+            IF( iom_file(kiomid)%nfid > 0 ) THEN
+               ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. )
+               SELECT CASE (iom_file(kiomid)%iolib)
+               CASE (jpnf90   )   ;   CALL iom_nf90_rstput(   kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r0d = pvar )
+               CASE DEFAULT     
+                  CALL ctl_stop( 'iom_rp0d: accepted IO library is only jpnf90 (jpioipsl option has been removed)' )
+               END SELECT
+            ENDIF
+         ENDIF
+      ENDIF
+   END SUBROUTINE iom_rp0d
+
+   SUBROUTINE iom_rp1d( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios )
+      INTEGER         , INTENT(in)                         ::   kt       ! ocean time-step
+      INTEGER         , INTENT(in)                         ::   kwrite   ! writing time-step
+      INTEGER         , INTENT(in)                         ::   kiomid   ! Identifier of the file 
+      CHARACTER(len=*), INTENT(in)                         ::   cdvar    ! time axis name
+      REAL(wp)        , INTENT(in), DIMENSION(          :) ::   pvar     ! written field
+      INTEGER         , INTENT(in), OPTIONAL               ::   ktype    ! variable external type
+      LOGICAL, OPTIONAL                                    ::   ldxios   ! xios write flag
+      LOGICAL :: llx                ! local xios write flag
+      INTEGER :: ivid   ! variable id
+
+      llx = .FALSE.
+      IF(PRESENT(ldxios)) llx = ldxios
+      IF( llx ) THEN
+#ifdef key_iomput
+      IF( kt == kwrite ) THEN
+         IF(lwp) write(numout,*) 'RESTART: write (XIOS 1D) ',trim(cdvar)
+         CALL xios_send_field(trim(cdvar), pvar)
+      ENDIF
+#endif
+      ELSE
+         IF( kiomid > 0 ) THEN
+            IF( iom_file(kiomid)%nfid > 0 ) THEN
+               ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. )
+               SELECT CASE (iom_file(kiomid)%iolib)
+               CASE (jpnf90   )   ;   CALL iom_nf90_rstput(   kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r1d = pvar )
+               CASE DEFAULT     
+                  CALL ctl_stop( 'iom_rp1d: accepted IO library is only jpnf90 (jpioipsl option has been removed)' )
+               END SELECT
+            ENDIF
+         ENDIF
+      ENDIF
+   END SUBROUTINE iom_rp1d
+
+   SUBROUTINE iom_rp2d( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios )
+      INTEGER         , INTENT(in)                         ::   kt       ! ocean time-step
+      INTEGER         , INTENT(in)                         ::   kwrite   ! writing time-step
+      INTEGER         , INTENT(in)                         ::   kiomid   ! Identifier of the file 
+      CHARACTER(len=*), INTENT(in)                         ::   cdvar    ! time axis name
+      REAL(wp)        , INTENT(in), DIMENSION(:,    :    ) ::   pvar     ! written field
+      INTEGER         , INTENT(in), OPTIONAL               ::   ktype    ! variable external type
+      LOGICAL, OPTIONAL :: ldxios   ! xios write flag
+      LOGICAL :: llx
+      INTEGER :: ivid   ! variable id
+
+      llx = .FALSE.
+      IF(PRESENT(ldxios)) llx = ldxios
+      IF( llx ) THEN
+#ifdef key_iomput
+      IF( kt == kwrite ) THEN
+         IF(lwp) write(numout,*) 'RESTART: write (XIOS 2D) ',trim(cdvar)
+         CALL xios_send_field(trim(cdvar), pvar)
+      ENDIF
+#endif
+      ELSE
+         IF( kiomid > 0 ) THEN
+            IF( iom_file(kiomid)%nfid > 0 ) THEN
+               ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. )
+               SELECT CASE (iom_file(kiomid)%iolib)
+               CASE (jpnf90   )   ;   CALL iom_nf90_rstput(   kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r2d = pvar )
+               CASE DEFAULT     
+                  CALL ctl_stop( 'iom_rp2d: accepted IO library is only jpnf90 (jpioipsl option has been removed)' )
+               END SELECT
+            ENDIF
+         ENDIF
+      ENDIF
+   END SUBROUTINE iom_rp2d
+
+   SUBROUTINE iom_rp3d( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios )
+      INTEGER         , INTENT(in)                         ::   kt       ! ocean time-step
+      INTEGER         , INTENT(in)                         ::   kwrite   ! writing time-step
+      INTEGER         , INTENT(in)                         ::   kiomid   ! Identifier of the file 
+      CHARACTER(len=*), INTENT(in)                         ::   cdvar    ! time axis name
+      REAL(wp)        , INTENT(in),       DIMENSION(:,:,:) ::   pvar     ! written field
+      INTEGER         , INTENT(in), OPTIONAL               ::   ktype    ! variable external type
+      LOGICAL, OPTIONAL :: ldxios   ! xios write flag
+      LOGICAL :: llx                 ! local xios write flag
+      INTEGER :: ivid   ! variable id
+
+      llx = .FALSE.
+      IF(PRESENT(ldxios)) llx = ldxios
+      IF( llx ) THEN
+#ifdef key_iomput
+      IF( kt == kwrite ) THEN
+         IF(lwp) write(numout,*) 'RESTART: write (XIOS 3D) ',trim(cdvar)
+         CALL xios_send_field(trim(cdvar), pvar)
+      ENDIF
+#endif
+      ELSE
+         IF( kiomid > 0 ) THEN
+            IF( iom_file(kiomid)%nfid > 0 ) THEN
+               ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. )
+               SELECT CASE (iom_file(kiomid)%iolib)
+               CASE (jpnf90   )   ;   CALL iom_nf90_rstput(   kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r3d = pvar )
+               CASE DEFAULT     
+                  CALL ctl_stop( 'iom_rp3d: accepted IO library is only jpnf90 (jpioipsl option has been removed)' )
+               END SELECT
+            ENDIF
+         ENDIF
+      ENDIF
+   END SUBROUTINE iom_rp3d
+
+
+   !!----------------------------------------------------------------------
+   !!                   INTERFACE iom_put
+   !!----------------------------------------------------------------------
+   SUBROUTINE iom_p0d( cdname, pfield0d )
+      CHARACTER(LEN=*), INTENT(in) ::   cdname
+      REAL(wp)        , INTENT(in) ::   pfield0d
+      REAL(wp)        , DIMENSION(jpi,jpj) ::   zz     ! masson
+#if defined key_iomput
+      zz(:,:)=pfield0d
+      CALL xios_send_field(cdname, zz)
+      !CALL xios_send_field(cdname, (/pfield0d/)) 
+#else
+      IF( .FALSE. )   WRITE(numout,*) cdname, pfield0d   ! useless test to avoid compilation warnings
+#endif
+   END SUBROUTINE iom_p0d
+
+   SUBROUTINE iom_p1d( cdname, pfield1d )
+      CHARACTER(LEN=*)          , INTENT(in) ::   cdname
+      REAL(wp),     DIMENSION(:), INTENT(in) ::   pfield1d
+#if defined key_iomput
+      CALL xios_send_field( cdname, RESHAPE( (/pfield1d/), (/1,1,SIZE(pfield1d)/) ) )
+#else
+      IF( .FALSE. )   WRITE(numout,*) cdname, pfield1d   ! useless test to avoid compilation warnings
+#endif
+   END SUBROUTINE iom_p1d
+
+   SUBROUTINE iom_p2d( cdname, pfield2d )
+      CHARACTER(LEN=*)            , INTENT(in) ::   cdname
+      REAL(wp),     DIMENSION(:,:), INTENT(in) ::   pfield2d
+#if defined key_iomput
+      CALL xios_send_field(cdname, pfield2d)
+#else
+      IF( .FALSE. )   WRITE(numout,*) cdname, pfield2d   ! useless test to avoid compilation warnings
+#endif
+   END SUBROUTINE iom_p2d
+
+   SUBROUTINE iom_p3d( cdname, pfield3d )
+      CHARACTER(LEN=*)                , INTENT(in) ::   cdname
+      REAL(wp),       DIMENSION(:,:,:), INTENT(in) ::   pfield3d
+#if defined key_iomput
+      CALL xios_send_field( cdname, pfield3d )
+#else
+      IF( .FALSE. )   WRITE(numout,*) cdname, pfield3d   ! useless test to avoid compilation warnings
+#endif
+   END SUBROUTINE iom_p3d
+
+#if defined key_iomput
+   !!----------------------------------------------------------------------
+   !!   'key_iomput'                                         IOM  interface
+   !!----------------------------------------------------------------------
+
+   SUBROUTINE iom_set_domain_attr( cdid, ni_glo, nj_glo, ibegin, jbegin, ni, nj, zoom_ibegin, zoom_jbegin, zoom_ni, zoom_nj,   &
+      &                                    data_dim, data_ibegin, data_ni, data_jbegin, data_nj, lonvalue, latvalue, mask,     &
+      &                                    nvertex, bounds_lon, bounds_lat, area )
+      !!----------------------------------------------------------------------
+      !!----------------------------------------------------------------------
+      CHARACTER(LEN=*)                  , INTENT(in) ::   cdid
+      INTEGER                 , OPTIONAL, INTENT(in) ::   ni_glo, nj_glo, ibegin, jbegin, ni, nj
+      INTEGER                 , OPTIONAL, INTENT(in) ::   data_dim, data_ibegin, data_ni, data_jbegin, data_nj
+      INTEGER                 , OPTIONAL, INTENT(in) ::   zoom_ibegin, zoom_jbegin, zoom_ni, zoom_nj, nvertex
+      REAL(wp), DIMENSION(:)  , OPTIONAL, INTENT(in) ::   lonvalue, latvalue
+      REAL(wp), DIMENSION(:,:), OPTIONAL, INTENT(in) ::   bounds_lon, bounds_lat, area
+      LOGICAL , DIMENSION(:)  , OPTIONAL, INTENT(in) ::   mask
+      !!----------------------------------------------------------------------
+      !
+      IF( xios_is_valid_domain     (cdid) ) THEN
+         CALL xios_set_domain_attr     ( cdid, ni_glo=ni_glo, nj_glo=nj_glo, ibegin=ibegin, jbegin=jbegin, ni=ni, nj=nj,   &
+            &    data_dim=data_dim, data_ibegin=data_ibegin, data_ni=data_ni, data_jbegin=data_jbegin, data_nj=data_nj ,   &
+            &    lonvalue_1D=lonvalue, latvalue_1D=latvalue, mask_1D=mask, nvertex=nvertex, bounds_lon_1D=bounds_lon,      &
+            &    bounds_lat_1D=bounds_lat, area=area, type='curvilinear')
+      ENDIF
+      IF( xios_is_valid_domaingroup(cdid) ) THEN
+         CALL xios_set_domaingroup_attr( cdid, ni_glo=ni_glo, nj_glo=nj_glo, ibegin=ibegin, jbegin=jbegin, ni=ni, nj=nj,   &
+            &    data_dim=data_dim, data_ibegin=data_ibegin, data_ni=data_ni, data_jbegin=data_jbegin, data_nj=data_nj ,   &
+            &    lonvalue_1D=lonvalue, latvalue_1D=latvalue, mask_1D=mask, nvertex=nvertex, bounds_lon_1D=bounds_lon,      &
+            &    bounds_lat_1D=bounds_lat, area=area, type='curvilinear' )
+      ENDIF
+      !
+      CALL xios_solve_inheritance()
+      !
+   END SUBROUTINE iom_set_domain_attr
+
+
+   SUBROUTINE iom_set_zoom_domain_attr( cdid, ibegin, jbegin, ni, nj )
+      !!----------------------------------------------------------------------
+      !!----------------------------------------------------------------------
+      CHARACTER(LEN=*)          , INTENT(in) ::   cdid
+      INTEGER         , OPTIONAL, INTENT(in) ::   ibegin, jbegin, ni, nj
+      !!----------------------------------------------------------------------
+      IF( xios_is_valid_zoom_domain(cdid) )   CALL xios_set_zoom_domain_attr( cdid, ibegin=ibegin, jbegin=jbegin, ni=ni, nj=nj )
+   END SUBROUTINE iom_set_zoom_domain_attr
+
+
+   SUBROUTINE iom_set_axis_attr( cdid, paxis, bounds )
+      !!----------------------------------------------------------------------
+      !!----------------------------------------------------------------------
+      CHARACTER(LEN=*)      , INTENT(in) ::   cdid
+      REAL(wp), DIMENSION(:)  , OPTIONAL, INTENT(in) ::   paxis
+      REAL(wp), DIMENSION(:,:), OPTIONAL, INTENT(in) ::   bounds
+      !!----------------------------------------------------------------------
+      IF( PRESENT(paxis) ) THEN
+         IF( xios_is_valid_axis     (cdid) )   CALL xios_set_axis_attr     ( cdid, n_glo=SIZE(paxis), value=paxis )
+         IF( xios_is_valid_axisgroup(cdid) )   CALL xios_set_axisgroup_attr( cdid, n_glo=SIZE(paxis), value=paxis )
+      ENDIF
+      IF( xios_is_valid_axis     (cdid) )   CALL xios_set_axis_attr     ( cdid, bounds=bounds )
+      IF( xios_is_valid_axisgroup(cdid) )   CALL xios_set_axisgroup_attr( cdid, bounds=bounds )
+      CALL xios_solve_inheritance()
+   END SUBROUTINE iom_set_axis_attr
+
+
+   SUBROUTINE iom_set_field_attr( cdid, freq_op, freq_offset )
+      !!----------------------------------------------------------------------
+      !!----------------------------------------------------------------------
+      CHARACTER(LEN=*)             , INTENT(in) ::   cdid
+      TYPE(xios_duration), OPTIONAL, INTENT(in) ::   freq_op
+      TYPE(xios_duration), OPTIONAL, INTENT(in) ::   freq_offset
+      !!----------------------------------------------------------------------
+      IF( xios_is_valid_field     (cdid) )   CALL xios_set_field_attr     ( cdid, freq_op=freq_op, freq_offset=freq_offset )
+      IF( xios_is_valid_fieldgroup(cdid) )   CALL xios_set_fieldgroup_attr( cdid, freq_op=freq_op, freq_offset=freq_offset )
+      CALL xios_solve_inheritance()
+   END SUBROUTINE iom_set_field_attr
+
+
+   SUBROUTINE iom_set_file_attr( cdid, name, name_suffix )
+      !!----------------------------------------------------------------------
+      !!----------------------------------------------------------------------
+      CHARACTER(LEN=*)          , INTENT(in) ::   cdid
+      CHARACTER(LEN=*),OPTIONAL , INTENT(in) ::   name, name_suffix
+      !!----------------------------------------------------------------------
+      IF( xios_is_valid_file     (cdid) )   CALL xios_set_file_attr     ( cdid, name=name, name_suffix=name_suffix )
+      IF( xios_is_valid_filegroup(cdid) )   CALL xios_set_filegroup_attr( cdid, name=name, name_suffix=name_suffix )
+      CALL xios_solve_inheritance()
+   END SUBROUTINE iom_set_file_attr
+
+
+   SUBROUTINE iom_get_file_attr( cdid, name, name_suffix, output_freq )
+      !!----------------------------------------------------------------------
+      !!----------------------------------------------------------------------
+      CHARACTER(LEN=*)          , INTENT(in ) ::   cdid
+      CHARACTER(LEN=*),OPTIONAL , INTENT(out) ::   name, name_suffix
+      TYPE(xios_duration), OPTIONAL , INTENT(out) :: output_freq
+      LOGICAL                                 ::   llexist1,llexist2,llexist3
+      !---------------------------------------------------------------------
+      IF( PRESENT( name        ) )   name = ''          ! default values
+      IF( PRESENT( name_suffix ) )   name_suffix = ''
+      IF( PRESENT( output_freq ) )   output_freq = xios_duration(0,0,0,0,0,0)
+      IF( xios_is_valid_file     (cdid) ) THEN
+         CALL xios_solve_inheritance()
+         CALL xios_is_defined_file_attr     ( cdid, name = llexist1, name_suffix = llexist2, output_freq = llexist3)
+         IF(llexist1)   CALL xios_get_file_attr     ( cdid, name = name )
+         IF(llexist2)   CALL xios_get_file_attr     ( cdid, name_suffix = name_suffix )
+         IF(llexist3)   CALL xios_get_file_attr     ( cdid, output_freq = output_freq )
+      ENDIF
+      IF( xios_is_valid_filegroup(cdid) ) THEN
+         CALL xios_solve_inheritance()
+         CALL xios_is_defined_filegroup_attr( cdid, name = llexist1, name_suffix = llexist2, output_freq = llexist3)
+         IF(llexist1)   CALL xios_get_filegroup_attr( cdid, name = name )
+         IF(llexist2)   CALL xios_get_filegroup_attr( cdid, name_suffix = name_suffix )
+         IF(llexist3)   CALL xios_get_filegroup_attr( cdid, output_freq = output_freq )
+      ENDIF
+   END SUBROUTINE iom_get_file_attr
+
+
+   SUBROUTINE iom_set_grid_attr( cdid, mask )
+      !!----------------------------------------------------------------------
+      !!----------------------------------------------------------------------
+      CHARACTER(LEN=*)                   , INTENT(in) ::   cdid
+      LOGICAL, DIMENSION(:,:,:), OPTIONAL, INTENT(in) ::   mask
+      !!----------------------------------------------------------------------
+      IF( xios_is_valid_grid     (cdid) )   CALL xios_set_grid_attr     ( cdid, mask_3D=mask )
+      IF( xios_is_valid_gridgroup(cdid) )   CALL xios_set_gridgroup_attr( cdid, mask_3D=mask )
+      CALL xios_solve_inheritance()
+   END SUBROUTINE iom_set_grid_attr
+
+   SUBROUTINE iom_setkt( kt, cdname )
+      !!----------------------------------------------------------------------
+      !!----------------------------------------------------------------------
+      INTEGER         , INTENT(in) ::   kt 
+      CHARACTER(LEN=*), INTENT(in) ::   cdname
+      !!----------------------------------------------------------------------
+      CALL iom_swap( cdname )   ! swap to cdname context
+      CALL xios_update_calendar(kt)
+      IF( cdname /= TRIM(cxios_context) )   CALL iom_swap( TRIM(cxios_context) )   ! return back to nemo context
+   END SUBROUTINE iom_setkt
+
+   SUBROUTINE iom_context_finalize( cdname )
+      !!----------------------------------------------------------------------
+      !!----------------------------------------------------------------------
+      CHARACTER(LEN=*), INTENT(in) :: cdname
+      CHARACTER(LEN=120)           :: clname
+      !!----------------------------------------------------------------------
+      clname = cdname
+      IF( TRIM(Agrif_CFixed()) .NE. '0' ) clname = TRIM(Agrif_CFixed())//"_"//clname 
+      IF( xios_is_valid_context(clname) ) THEN
+         CALL iom_swap( cdname )   ! swap to cdname context
+         CALL xios_context_finalize() ! finalize the context
+         IF( cdname /= TRIM(cxios_context) ) CALL iom_swap( TRIM(cxios_context) )   ! return back to nemo context
+      ENDIF
+      !
+   END SUBROUTINE iom_context_finalize
+
+
+   SUBROUTINE set_grid( cdgrd, plon, plat, ldxios )
+      !!----------------------------------------------------------------------
+      !!                     ***  ROUTINE set_grid  ***
+      !!
+      !! ** Purpose :   define horizontal grids
+      !!----------------------------------------------------------------------
+      CHARACTER(LEN=1)            , INTENT(in) ::   cdgrd
+      REAL(wp), DIMENSION(jpi,jpj), INTENT(in) ::   plon
+      REAL(wp), DIMENSION(jpi,jpj), INTENT(in) ::   plat
+      !
+      INTEGER  :: ni, nj
+      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zmask
+      LOGICAL, INTENT(IN) :: ldxios
+      !!----------------------------------------------------------------------
+      !
+      ni = nlei-nldi+1
+      nj = nlej-nldj+1
+      !
+      CALL iom_set_domain_attr("grid_"//cdgrd, ni_glo=jpiglo, nj_glo=jpjglo, ibegin=nimpp+nldi-2, jbegin=njmpp+nldj-2, ni=ni, nj=nj)
+      CALL iom_set_domain_attr("grid_"//cdgrd, data_dim=2, data_ibegin = 1-nldi, data_ni = jpi, data_jbegin = 1-nldj, data_nj = jpj)
+      CALL iom_set_domain_attr("grid_"//cdgrd, lonvalue = RESHAPE(plon(nldi:nlei, nldj:nlej),(/ ni*nj /)),   &
+         &                                     latvalue = RESHAPE(plat(nldi:nlei, nldj:nlej),(/ ni*nj /)))  
+      !
+      IF ( ln_mskland .AND. (.NOT.ldxios) ) THEN
+         ! mask land points, keep values on coast line -> specific mask for U, V and W points
+         SELECT CASE ( cdgrd )
+         CASE('T')   ;   zmask(:,:,:)       = tmask(:,:,:)
+         CASE('U')   ;   zmask(2:jpim1,:,:) = tmask(2:jpim1,:,:) + tmask(3:jpi,:,:)   ;   CALL lbc_lnk( zmask, 'U', 1. )
+         CASE('V')   ;   zmask(:,2:jpjm1,:) = tmask(:,2:jpjm1,:) + tmask(:,3:jpj,:)   ;   CALL lbc_lnk( zmask, 'V', 1. )
+         CASE('W')   ;   zmask(:,:,2:jpk  ) = tmask(:,:,1:jpkm1) + tmask(:,:,2:jpk)   ;   zmask(:,:,1) = tmask(:,:,1)
+         END SELECT
+         !
+         CALL iom_set_domain_attr( "grid_"//cdgrd       , mask = RESHAPE(zmask(nldi:nlei,nldj:nlej,1),(/ni*nj    /)) /= 0. )
+         CALL iom_set_grid_attr  ( "grid_"//cdgrd//"_3D", mask = RESHAPE(zmask(nldi:nlei,nldj:nlej,:),(/ni,nj,jpk/)) /= 0. )
+      ENDIF
+      !
+   END SUBROUTINE set_grid
+
+
+   SUBROUTINE set_grid_bounds( cdgrd, plon_cnr, plat_cnr, plon_pnt, plat_pnt )
+      !!----------------------------------------------------------------------
+      !!                   ***  ROUTINE set_grid_bounds  ***
+      !!
+      !! ** Purpose :   define horizontal grid corners
+      !!
+      !!----------------------------------------------------------------------
+      CHARACTER(LEN=1)                      , INTENT(in) :: cdgrd
+      REAL(wp), DIMENSION(jpi,jpj)          , INTENT(in) :: plon_cnr, plat_cnr  ! Lat/lon coord. of a contiguous vertex of cell (i,j)
+      REAL(wp), DIMENSION(jpi,jpj), OPTIONAL, INTENT(in) :: plon_pnt, plat_pnt  ! Lat/lon coord. of the point of cell (i,j)
+      !
+      INTEGER :: ji, jj, jn, ni, nj
+      INTEGER :: icnr, jcnr                                    ! Offset such that the vertex coordinate (i+icnr,j+jcnr)
+      !                                                        ! represents the bottom-left corner of cell (i,j)
+      REAL(wp), ALLOCATABLE, DIMENSION(:,:,:,:) :: z_bnds      ! Lat/lon coordinates of the vertices of cell (i,j)
+      REAL(wp), ALLOCATABLE, DIMENSION(:,:)     :: z_fld       ! Working array to determine where to rotate cells
+      REAL(wp), ALLOCATABLE, DIMENSION(:,:)     :: z_rot       ! Lat/lon working array for rotation of cells
+      !!----------------------------------------------------------------------
+      !
+      ALLOCATE( z_bnds(4,jpi,jpj,2), z_fld(jpi,jpj), z_rot(4,2)  )
+      !
+      ! Offset of coordinate representing bottom-left corner
+      SELECT CASE ( TRIM(cdgrd) )
+      CASE ('T', 'W')   ;   icnr = -1   ;   jcnr = -1
+      CASE ('U')        ;   icnr =  0   ;   jcnr = -1
+      CASE ('V')        ;   icnr = -1   ;   jcnr =  0
+      END SELECT
+      !
+      ni = nlei-nldi+1   ! Dimensions of subdomain interior
+      nj = nlej-nldj+1
+      !
+      z_fld(:,:) = 1._wp
+      CALL lbc_lnk( z_fld, cdgrd, -1. )    ! Working array for location of northfold
+      !
+      ! Cell vertices that can be defined
+      DO jj = 2, jpjm1
+         DO ji = 2, jpim1
+            z_bnds(1,ji,jj,1) = plat_cnr(ji+icnr,  jj+jcnr  ) ! Bottom-left
+            z_bnds(2,ji,jj,1) = plat_cnr(ji+icnr+1,jj+jcnr  ) ! Bottom-right
+            z_bnds(3,ji,jj,1) = plat_cnr(ji+icnr+1,jj+jcnr+1) ! Top-right
+            z_bnds(4,ji,jj,1) = plat_cnr(ji+icnr,  jj+jcnr+1) ! Top-left
+            z_bnds(1,ji,jj,2) = plon_cnr(ji+icnr,  jj+jcnr  ) ! Bottom-left
+            z_bnds(2,ji,jj,2) = plon_cnr(ji+icnr+1,jj+jcnr  ) ! Bottom-right
+            z_bnds(3,ji,jj,2) = plon_cnr(ji+icnr+1,jj+jcnr+1) ! Top-right
+            z_bnds(4,ji,jj,2) = plon_cnr(ji+icnr,  jj+jcnr+1) ! Top-left
+         END DO
+      END DO
+      !
+      ! Cell vertices on boundries
+      DO jn = 1, 4
+         CALL lbc_lnk( z_bnds(jn,:,:,1), cdgrd, 1., pval=999._wp )
+         CALL lbc_lnk( z_bnds(jn,:,:,2), cdgrd, 1., pval=999._wp )
+      END DO
+      !
+      ! Zero-size cells at closed boundaries if cell points provided,
+      ! otherwise they are closed cells with unrealistic bounds
+      IF( PRESENT(plon_pnt) .AND. PRESENT(plat_pnt) ) THEN
+         IF( (nbondi == -1 .OR. nbondi == 2) .AND. .NOT. (jperio == 1 .OR. jperio == 4 .OR. jperio == 6) ) THEN
+            DO jn = 1, 4        ! (West or jpni = 1), closed E-W
+               z_bnds(jn,1,:,1) = plat_pnt(1,:)  ;  z_bnds(jn,1,:,2) = plon_pnt(1,:)
+            END DO
+         ENDIF
+         IF( (nbondi == 1 .OR. nbondi == 2) .AND. .NOT. (jperio == 1 .OR. jperio == 4 .OR. jperio == 6) ) THEN
+            DO jn = 1, 4        ! (East or jpni = 1), closed E-W
+               z_bnds(jn,nlci,:,1) = plat_pnt(nlci,:)  ;  z_bnds(jn,nlci,:,2) = plon_pnt(nlci,:)
+            END DO
+         ENDIF
+         IF( nbondj == -1 .OR. (nbondj == 2 .AND. jperio /= 2) ) THEN
+            DO jn = 1, 4        ! South or (jpnj = 1, not symmetric)
+               z_bnds(jn,:,1,1) = plat_pnt(:,1)  ;  z_bnds(jn,:,1,2) = plon_pnt(:,1)
+            END DO
+         ENDIF
+         IF( (nbondj == 1 .OR. nbondj == 2) .AND. jperio  < 3 ) THEN
+            DO jn = 1, 4        ! (North or jpnj = 1), no north fold
+               z_bnds(jn,:,nlcj,1) = plat_pnt(:,nlcj)  ;  z_bnds(jn,:,nlcj,2) = plon_pnt(:,nlcj)
+            END DO
+         ENDIF
+      ENDIF
+      !
+      IF( (nbondj == 1 .OR. nbondj == 2) .AND. jperio >= 3 ) THEN    ! Rotate cells at the north fold
+         DO jj = 1, jpj
+            DO ji = 1, jpi
+               IF( z_fld(ji,jj) == -1. ) THEN
+                  z_rot(1,:) = z_bnds(3,ji,jj,:) ; z_rot(2,:) = z_bnds(4,ji,jj,:)
+                  z_rot(3,:) = z_bnds(1,ji,jj,:) ; z_rot(4,:) = z_bnds(2,ji,jj,:)
+                  z_bnds(:,ji,jj,:) = z_rot(:,:)
+               ENDIF
+            END DO
+         END DO
+      ELSE IF( nbondj == 2 .AND. jperio == 2 ) THEN                  ! Invert cells at the symmetric equator
+         DO ji = 1, jpi
+            z_rot(1:2,:) = z_bnds(3:4,ji,1,:)
+            z_rot(3:4,:) = z_bnds(1:2,ji,1,:)
+            z_bnds(:,ji,1,:) = z_rot(:,:)
+         END DO
+      ENDIF
+      !
+      CALL iom_set_domain_attr("grid_"//cdgrd, bounds_lat = RESHAPE(z_bnds(:,nldi:nlei,nldj:nlej,1),(/ 4,ni*nj /)),           &
+          &                                    bounds_lon = RESHAPE(z_bnds(:,nldi:nlei,nldj:nlej,2),(/ 4,ni*nj /)), nvertex=4 )
+      !
+      DEALLOCATE( z_bnds, z_fld, z_rot ) 
+      !
+   END SUBROUTINE set_grid_bounds
+
+
+   SUBROUTINE set_grid_znl( plat )
+      !!----------------------------------------------------------------------
+      !!                     ***  ROUTINE set_grid_znl  ***
+      !!
+      !! ** Purpose :   define grids for zonal mean
+      !!
+      !!----------------------------------------------------------------------
+      REAL(wp), DIMENSION(jpi,jpj), INTENT(in) ::   plat
+      !
+      INTEGER  :: ni, nj, ix, iy
+      REAL(wp), DIMENSION(:), ALLOCATABLE  ::   zlon
+      !!----------------------------------------------------------------------
+      !
+      ni=nlei-nldi+1       ! define zonal mean domain (jpj*jpk)
+      nj=nlej-nldj+1
+      ALLOCATE( zlon(ni*nj) )       ;       zlon(:) = 0._wp
+      !
+      CALL dom_ngb( -168.53, 65.03, ix, iy, 'T' ) !  i-line that passes through Bering Strait: Reference latitude (used in plots)
+!      CALL dom_ngb( 180., 90., ix, iy, 'T' ) !  i-line that passes near the North Pole : Reference latitude (used in plots)
+      CALL iom_set_domain_attr("gznl", ni_glo=jpiglo, nj_glo=jpjglo, ibegin=nimpp+nldi-2, jbegin=njmpp+nldj-2, ni=ni, nj=nj)
+      CALL iom_set_domain_attr("gznl", data_dim=2, data_ibegin = 1-nldi, data_ni = jpi, data_jbegin = 1-nldj, data_nj = jpj)
+      CALL iom_set_domain_attr("gznl", lonvalue = zlon,   &
+         &                             latvalue = RESHAPE(plat(nldi:nlei, nldj:nlej),(/ ni*nj /)))  
+      CALL iom_set_zoom_domain_attr ("ptr", ibegin=ix-1, jbegin=0, ni=1, nj=jpjglo)
+      !
+      CALL iom_update_file_name('ptr')
+      !
+   END SUBROUTINE set_grid_znl
+
+
+   SUBROUTINE set_scalar
+      !!----------------------------------------------------------------------
+      !!                     ***  ROUTINE set_scalar  ***
+      !!
+      !! ** Purpose :   define fake grids for scalar point
+      !!
+      !!----------------------------------------------------------------------
+      REAL(wp), DIMENSION(1)   ::   zz = 1.
+      !!----------------------------------------------------------------------
+      !
+      CALL iom_set_domain_attr('scalarpoint', ni_glo=jpnij, nj_glo=1, ibegin=narea-1, jbegin=0, ni=1, nj=1)
+      CALL iom_set_domain_attr('scalarpoint', data_dim=2, data_ibegin = 1, data_ni = 1, data_jbegin = 1, data_nj = 1)
+      !
+      zz = REAL( narea, wp )
+      CALL iom_set_domain_attr('scalarpoint', lonvalue=zz, latvalue=zz)
+      !
+   END SUBROUTINE set_scalar
+
+
+   SUBROUTINE set_xmlatt
+      !!----------------------------------------------------------------------
+      !!                     ***  ROUTINE set_xmlatt  ***
+      !!
+      !! ** Purpose :   automatic definitions of some of the xml attributs...
+      !!
+      !!----------------------------------------------------------------------
+      CHARACTER(len=1),DIMENSION( 3) ::   clgrd                    ! suffix name
+      CHARACTER(len=256)             ::   clsuff                   ! suffix name
+      CHARACTER(len=1)               ::   cl1                      ! 1 character
+      CHARACTER(len=2)               ::   cl2                      ! 2 characters
+      CHARACTER(len=3)               ::   cl3                      ! 3 characters
+      INTEGER                        ::   ji, jg                   ! loop counters
+      INTEGER                        ::   ix, iy                   ! i-,j- index
+      REAL(wp)        ,DIMENSION(11) ::   zlontao                  ! longitudes of tao    moorings
+      REAL(wp)        ,DIMENSION( 7) ::   zlattao                  ! latitudes  of tao    moorings
+      REAL(wp)        ,DIMENSION( 4) ::   zlonrama                 ! longitudes of rama   moorings
+      REAL(wp)        ,DIMENSION(11) ::   zlatrama                 ! latitudes  of rama   moorings
+      REAL(wp)        ,DIMENSION( 3) ::   zlonpira                 ! longitudes of pirata moorings
+      REAL(wp)        ,DIMENSION( 9) ::   zlatpira                 ! latitudes  of pirata moorings
+      TYPE(xios_duration)            ::   f_op, f_of
+      !!----------------------------------------------------------------------
+      ! 
+      ! frequency of the call of iom_put (attribut: freq_op)
+      f_op%timestep = 1        ;  f_of%timestep =  0  ; CALL iom_set_field_attr('field_definition', freq_op=f_op, freq_offset=f_of)
+      f_op%timestep = 2        ;  f_of%timestep =  0  ; CALL iom_set_field_attr('trendT_even'     , freq_op=f_op, freq_offset=f_of)
+      f_op%timestep = 2        ;  f_of%timestep = -1  ; CALL iom_set_field_attr('trendT_odd'      , freq_op=f_op, freq_offset=f_of)
+      f_op%timestep = nn_fsbc  ;  f_of%timestep =  0  ; CALL iom_set_field_attr('SBC'             , freq_op=f_op, freq_offset=f_of)
+      f_op%timestep = nn_fsbc  ;  f_of%timestep =  0  ; CALL iom_set_field_attr('SBC_scalar'      , freq_op=f_op, freq_offset=f_of)
+      f_op%timestep = nn_dttrc ;  f_of%timestep =  0  ; CALL iom_set_field_attr('ptrc_T'          , freq_op=f_op, freq_offset=f_of)
+      f_op%timestep = nn_dttrc ;  f_of%timestep =  0  ; CALL iom_set_field_attr('diad_T'          , freq_op=f_op, freq_offset=f_of)
+
+      ! output file names (attribut: name)
+      DO ji = 1, 9
+         WRITE(cl1,'(i1)') ji 
+         CALL iom_update_file_name('file'//cl1)
+      END DO
+      DO ji = 1, 99
+         WRITE(cl2,'(i2.2)') ji 
+         CALL iom_update_file_name('file'//cl2)
+      END DO
+      DO ji = 1, 999
+         WRITE(cl3,'(i3.3)') ji 
+         CALL iom_update_file_name('file'//cl3)
+      END DO
+
+      ! Zooms...
+      clgrd = (/ 'T', 'U', 'W' /) 
+      DO jg = 1, SIZE(clgrd)                                                                   ! grid type
+         cl1 = clgrd(jg)
+         ! Equatorial section (attributs: jbegin, ni, name_suffix)
+         CALL dom_ngb( 0., 0., ix, iy, cl1 )
+         CALL iom_set_zoom_domain_attr ('Eq'//cl1, jbegin=iy-1, ni=jpiglo)
+         CALL iom_get_file_attr   ('Eq'//cl1, name_suffix = clsuff             )
+         CALL iom_set_file_attr   ('Eq'//cl1, name_suffix = TRIM(clsuff)//'_Eq')
+         CALL iom_update_file_name('Eq'//cl1)
+      END DO
+      ! TAO moorings (attributs: ibegin, jbegin, name_suffix)
+      zlontao = (/ 137.0, 147.0, 156.0, 165.0, -180.0, -170.0, -155.0, -140.0, -125.0, -110.0, -95.0 /)
+      zlattao = (/  -8.0,  -5.0,  -2.0,   0.0,    2.0,    5.0,    8.0 /)
+      CALL set_mooring( zlontao, zlattao )
+      ! RAMA moorings (attributs: ibegin, jbegin, name_suffix)
+      zlonrama = (/  55.0,  67.0, 80.5, 90.0 /)
+      zlatrama = (/ -16.0, -12.0, -8.0, -4.0, -1.5, 0.0, 1.5, 4.0, 8.0, 12.0, 15.0 /)
+      CALL set_mooring( zlonrama, zlatrama )
+      ! PIRATA moorings (attributs: ibegin, jbegin, name_suffix)
+      zlonpira = (/ -38.0, -23.0, -10.0 /)
+      zlatpira = (/ -19.0, -14.0,  -8.0, 0.0, 4.0, 8.0, 12.0, 15.0, 20.0 /)
+      CALL set_mooring( zlonpira, zlatpira )
+      !
+   END SUBROUTINE set_xmlatt
+
+
+   SUBROUTINE set_mooring( plon, plat )
+      !!----------------------------------------------------------------------
+      !!                     ***  ROUTINE set_mooring  ***
+      !!
+      !! ** Purpose :   automatic definitions of moorings xml attributs...
+      !!
+      !!----------------------------------------------------------------------
+      REAL(wp), DIMENSION(:), INTENT(in) ::   plon, plat   ! longitudes/latitudes oft the mooring
+      !
+!!$      CHARACTER(len=1),DIMENSION(4) ::   clgrd = (/ 'T', 'U', 'V', 'W' /)   ! suffix name
+      CHARACTER(len=1),DIMENSION(1) ::   clgrd = (/ 'T' /)        ! suffix name
+      CHARACTER(len=256)            ::   clname                   ! file name
+      CHARACTER(len=256)            ::   clsuff                   ! suffix name
+      CHARACTER(len=1)              ::   cl1                      ! 1 character
+      CHARACTER(len=6)              ::   clon,clat                ! name of longitude, latitude
+      INTEGER                       ::   ji, jj, jg               ! loop counters
+      INTEGER                       ::   ix, iy                   ! i-,j- index
+      REAL(wp)                      ::   zlon, zlat
+      !!----------------------------------------------------------------------
+      DO jg = 1, SIZE(clgrd)
+         cl1 = clgrd(jg)
+         DO ji = 1, SIZE(plon)
+            DO jj = 1, SIZE(plat)
+               zlon = plon(ji)
+               zlat = plat(jj)
+               ! modifications for RAMA moorings
+               IF( zlon ==  67. .AND. zlat ==  15. )   zlon =  65.
+               IF( zlon ==  90. .AND. zlat <=  -4. )   zlon =  95.
+               IF( zlon ==  95. .AND. zlat ==  -4. )   zlat =  -5.
+               ! modifications for PIRATA moorings
+               IF( zlon == -38. .AND. zlat == -19. )   zlon = -34.
+               IF( zlon == -38. .AND. zlat == -14. )   zlon = -32.
+               IF( zlon == -38. .AND. zlat ==  -8. )   zlon = -30.
+               IF( zlon == -38. .AND. zlat ==   0. )   zlon = -35.
+               IF( zlon == -23. .AND. zlat ==  20. )   zlat =  21.
+               IF( zlon == -10. .AND. zlat == -14. )   zlat = -10.
+               IF( zlon == -10. .AND. zlat ==  -8. )   zlat =  -6.
+               IF( zlon == -10. .AND. zlat ==   4. ) THEN   ;   zlon = 0.   ;   zlat = 0.   ;   ENDIF
+               CALL dom_ngb( zlon, zlat, ix, iy, cl1 )
+               IF( zlon >= 0. ) THEN  
+                  IF( zlon == REAL(NINT(zlon), wp) ) THEN   ;   WRITE(clon, '(i3,  a)') NINT( zlon), 'e'
+                  ELSE                                      ;   WRITE(clon, '(f5.1,a)')       zlon , 'e'
+                  ENDIF
+               ELSE             
+                  IF( zlon == REAL(NINT(zlon), wp) ) THEN   ;   WRITE(clon, '(i3,  a)') NINT(-zlon), 'w'
+                  ELSE                                      ;   WRITE(clon, '(f5.1,a)')      -zlon , 'w'
+                  ENDIF
+               ENDIF
+               IF( zlat >= 0. ) THEN  
+                  IF( zlat == REAL(NINT(zlat), wp) ) THEN   ;   WRITE(clat, '(i2,  a)') NINT( zlat), 'n'
+                  ELSE                                      ;   WRITE(clat, '(f4.1,a)')       zlat , 'n'
+                  ENDIF
+               ELSE             
+                  IF( zlat == REAL(NINT(zlat), wp) ) THEN   ;   WRITE(clat, '(i2,  a)') NINT(-zlat), 's'
+                  ELSE                                      ;   WRITE(clat, '(f4.1,a)')      -zlat , 's'
+                  ENDIF
+               ENDIF
+               clname = TRIM(ADJUSTL(clat))//TRIM(ADJUSTL(clon))
+               CALL iom_set_zoom_domain_attr  (TRIM(clname)//cl1, ibegin= ix-1, jbegin= iy-1)
+
+               CALL iom_get_file_attr   (TRIM(clname)//cl1, name_suffix = clsuff                         )
+               CALL iom_set_file_attr   (TRIM(clname)//cl1, name_suffix = TRIM(clsuff)//'_'//TRIM(clname))
+               CALL iom_update_file_name(TRIM(clname)//cl1)
+            END DO
+         END DO
+      END DO
+      
+   END SUBROUTINE set_mooring
+
+   
+   SUBROUTINE iom_update_file_name( cdid )
+      !!----------------------------------------------------------------------
+      !!                     ***  ROUTINE iom_update_file_name  ***
+      !!
+      !! ** Purpose :   
+      !!
+      !!----------------------------------------------------------------------
+      CHARACTER(LEN=*)          , INTENT(in) ::   cdid
+      !
+      CHARACTER(LEN=256) ::   clname
+      CHARACTER(LEN=20)  ::   clfreq
+      CHARACTER(LEN=20)  ::   cldate
+      INTEGER            ::   idx
+      INTEGER            ::   jn
+      INTEGER            ::   itrlen
+      INTEGER            ::   iyear, imonth, iday, isec
+      REAL(wp)           ::   zsec
+      LOGICAL            ::   llexist
+      TYPE(xios_duration)   ::   output_freq 
+      !!----------------------------------------------------------------------
+      !
+      DO jn = 1, 2
+         !
+         output_freq = xios_duration(0,0,0,0,0,0)
+         IF( jn == 1 )   CALL iom_get_file_attr( cdid, name        = clname, output_freq = output_freq )
+         IF( jn == 2 )   CALL iom_get_file_attr( cdid, name_suffix = clname )
+         !
+         IF ( TRIM(clname) /= '' ) THEN 
+            !
+            idx = INDEX(clname,'@expname@') + INDEX(clname,'@EXPNAME@')
+            DO WHILE ( idx /= 0 ) 
+               clname = clname(1:idx-1)//TRIM(cexper)//clname(idx+9:LEN_TRIM(clname))
+               idx = INDEX(clname,'@expname@') + INDEX(clname,'@EXPNAME@')
+            END DO
+            !
+            idx = INDEX(clname,'@freq@') + INDEX(clname,'@FREQ@')
+            DO WHILE ( idx /= 0 ) 
+              IF ( output_freq%timestep /= 0) THEN
+                  WRITE(clfreq,'(I18,A2)')INT(output_freq%timestep),'ts' 
+                  itrlen = LEN_TRIM(ADJUSTL(clfreq))
+              ELSE IF ( output_freq%second /= 0 ) THEN
+                  WRITE(clfreq,'(I19,A1)')INT(output_freq%second),'s' 
+                  itrlen = LEN_TRIM(ADJUSTL(clfreq))
+              ELSE IF ( output_freq%minute /= 0 ) THEN
+                  WRITE(clfreq,'(I18,A2)')INT(output_freq%minute),'mi' 
+                  itrlen = LEN_TRIM(ADJUSTL(clfreq))
+              ELSE IF ( output_freq%hour /= 0 ) THEN
+                  WRITE(clfreq,'(I19,A1)')INT(output_freq%hour),'h' 
+                  itrlen = LEN_TRIM(ADJUSTL(clfreq))
+              ELSE IF ( output_freq%day /= 0 ) THEN
+                  WRITE(clfreq,'(I19,A1)')INT(output_freq%day),'d' 
+                  itrlen = LEN_TRIM(ADJUSTL(clfreq))
+              ELSE IF ( output_freq%month /= 0 ) THEN   
+                  WRITE(clfreq,'(I19,A1)')INT(output_freq%month),'m' 
+                  itrlen = LEN_TRIM(ADJUSTL(clfreq))
+              ELSE IF ( output_freq%year /= 0 ) THEN   
+                  WRITE(clfreq,'(I19,A1)')INT(output_freq%year),'y' 
+                  itrlen = LEN_TRIM(ADJUSTL(clfreq))
+              ELSE
+                  CALL ctl_stop('error in the name of file id '//TRIM(cdid),   &
+                     & ' attribute output_freq is undefined -> cannot replace @freq@ in '//TRIM(clname) )
+              ENDIF
+              clname = clname(1:idx-1)//TRIM(ADJUSTL(clfreq))//clname(idx+6:LEN_TRIM(clname))
+              idx = INDEX(clname,'@freq@') + INDEX(clname,'@FREQ@')
+            END DO
+            !
+            idx = INDEX(clname,'@startdate@') + INDEX(clname,'@STARTDATE@')
+            DO WHILE ( idx /= 0 ) 
+               cldate = iom_sdate( fjulday - rdt / rday )
+               clname = clname(1:idx-1)//TRIM(cldate)//clname(idx+11:LEN_TRIM(clname))
+               idx = INDEX(clname,'@startdate@') + INDEX(clname,'@STARTDATE@')
+            END DO
+            !
+            idx = INDEX(clname,'@startdatefull@') + INDEX(clname,'@STARTDATEFULL@')
+            DO WHILE ( idx /= 0 ) 
+               cldate = iom_sdate( fjulday - rdt / rday, ldfull = .TRUE. )
+               clname = clname(1:idx-1)//TRIM(cldate)//clname(idx+15:LEN_TRIM(clname))
+               idx = INDEX(clname,'@startdatefull@') + INDEX(clname,'@STARTDATEFULL@')
+            END DO
+            !
+            idx = INDEX(clname,'@enddate@') + INDEX(clname,'@ENDDATE@')
+            DO WHILE ( idx /= 0 ) 
+               cldate = iom_sdate( fjulday + rdt / rday * REAL( nitend - nit000, wp ), ld24 = .TRUE. )
+               clname = clname(1:idx-1)//TRIM(cldate)//clname(idx+9:LEN_TRIM(clname))
+               idx = INDEX(clname,'@enddate@') + INDEX(clname,'@ENDDATE@')
+            END DO
+            !
+            idx = INDEX(clname,'@enddatefull@') + INDEX(clname,'@ENDDATEFULL@')
+            DO WHILE ( idx /= 0 ) 
+               cldate = iom_sdate( fjulday + rdt / rday * REAL( nitend - nit000, wp ), ld24 = .TRUE., ldfull = .TRUE. )
+               clname = clname(1:idx-1)//TRIM(cldate)//clname(idx+13:LEN_TRIM(clname))
+               idx = INDEX(clname,'@enddatefull@') + INDEX(clname,'@ENDDATEFULL@')
+            END DO
+            !
+            IF( jn == 1 .AND. TRIM(Agrif_CFixed()) /= '0' )   clname = TRIM(Agrif_CFixed())//"_"//TRIM(clname)
+            IF( jn == 1 )   CALL iom_set_file_attr( cdid, name        = clname )
+            IF( jn == 2 )   CALL iom_set_file_attr( cdid, name_suffix = clname )
+            !
+         ENDIF
+         !
+      END DO
+      !
+   END SUBROUTINE iom_update_file_name
+
+
+   FUNCTION iom_sdate( pjday, ld24, ldfull )
+      !!----------------------------------------------------------------------
+      !!                     ***  ROUTINE iom_sdate  ***
+      !!
+      !! ** Purpose :   send back the date corresponding to the given julian day
+      !!----------------------------------------------------------------------
+      REAL(wp), INTENT(in   )           ::   pjday    ! julian day
+      LOGICAL , INTENT(in   ), OPTIONAL ::   ld24     ! true to force 24:00 instead of 00:00
+      LOGICAL , INTENT(in   ), OPTIONAL ::   ldfull   ! true to get the compleate date: yyyymmdd_hh:mm:ss
+      !
+      CHARACTER(LEN=20) ::   iom_sdate
+      CHARACTER(LEN=50) ::   clfmt                         !  format used to write the date 
+      INTEGER           ::   iyear, imonth, iday, ihour, iminute, isec
+      REAL(wp)          ::   zsec
+      LOGICAL           ::   ll24, llfull
+      !!----------------------------------------------------------------------
+      !
+      IF( PRESENT(ld24) ) THEN   ;   ll24 = ld24
+      ELSE                       ;   ll24 = .FALSE.
+      ENDIF
+      !
+      IF( PRESENT(ldfull) ) THEN   ;   llfull = ldfull
+      ELSE                         ;   llfull = .FALSE.
+      ENDIF
+      !
+      CALL ju2ymds( pjday, iyear, imonth, iday, zsec )
+      isec = NINT(zsec)
+      !
+      IF ( ll24 .AND. isec == 0 ) THEN   ! 00:00 of the next day -> move to 24:00 of the current day
+         CALL ju2ymds( pjday - 1., iyear, imonth, iday, zsec )
+         isec = 86400
+      ENDIF
+      !
+      IF( iyear < 10000 ) THEN   ;   clfmt = "i4.4,2i2.2"                ! format used to write the date 
+      ELSE                       ;   WRITE(clfmt, "('i',i1,',2i2.2')") INT(LOG10(REAL(iyear,wp))) + 1
+      ENDIF
+      !
+!$AGRIF_DO_NOT_TREAT      
+      ! needed in the conv
+      IF( llfull ) THEN 
+         clfmt = TRIM(clfmt)//",'_',i2.2,':',i2.2,':',i2.2"
+         ihour   = isec / 3600
+         isec    = MOD(isec, 3600)
+         iminute = isec / 60
+         isec    = MOD(isec, 60)
+         WRITE(iom_sdate, '('//TRIM(clfmt)//')') iyear, imonth, iday, ihour, iminute, isec    ! date of the end of run
+      ELSE
+         WRITE(iom_sdate, '('//TRIM(clfmt)//')') iyear, imonth, iday                          ! date of the end of run
+      ENDIF
+!$AGRIF_END_DO_NOT_TREAT      
+      !
+   END FUNCTION iom_sdate
+
+#else
+   !!----------------------------------------------------------------------
+   !!   NOT 'key_iomput'                               a few dummy routines
+   !!----------------------------------------------------------------------
+
+   SUBROUTINE iom_setkt( kt, cdname )
+      INTEGER         , INTENT(in)::   kt 
+      CHARACTER(LEN=*), INTENT(in) ::   cdname
+      IF( .FALSE. )   WRITE(numout,*) kt, cdname   ! useless test to avoid compilation warnings
+   END SUBROUTINE iom_setkt
+
+   SUBROUTINE iom_context_finalize( cdname )
+      CHARACTER(LEN=*), INTENT(in) ::   cdname
+      IF( .FALSE. )   WRITE(numout,*)  cdname   ! useless test to avoid compilation warnings
+   END SUBROUTINE iom_context_finalize
+
+#endif
+
+   LOGICAL FUNCTION iom_use( cdname )
+      !!----------------------------------------------------------------------
+      !!----------------------------------------------------------------------
+      CHARACTER(LEN=*), INTENT(in) ::   cdname
+      !!----------------------------------------------------------------------
+#if defined key_iomput
+      iom_use = xios_field_is_active( cdname )
+#else
+      iom_use = .FALSE.
+#endif
+   END FUNCTION iom_use
+   
+   !!======================================================================
+END MODULE iom
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/IOM/iom_def.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/IOM/iom_def.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/IOM/iom_def.F90	(revision 9570)
@@ -0,0 +1,89 @@
+MODULE iom_def
+   !!======================================================================
+   !!                    ***  MODULE  iom_def ***
+   !! IOM variables definitions
+   !!======================================================================
+   !! History :  9.0  ! 2006 09  (S. Masson) Original code
+   !!             -   ! 2007 07  (D. Storkey) Add uldname
+   !!            4.0  ! 2017-11 (M. Andrejczuk) Extend IOM interface to write any 3D fields
+   !!----------------------------------------------------------------------
+   USE par_kind
+
+   IMPLICIT NONE
+   PRIVATE
+
+   INTEGER, PARAMETER, PUBLIC ::   jpdom_data          = 1   !: ( 1  :jpiglo, 1  :jpjglo)    !!gm to be suppressed
+   INTEGER, PARAMETER, PUBLIC ::   jpdom_global        = 2   !: ( 1  :jpiglo, 1  :jpjglo)
+   INTEGER, PARAMETER, PUBLIC ::   jpdom_local         = 3   !: One of the 3 following cases
+   INTEGER, PARAMETER, PUBLIC ::   jpdom_local_full    = 4   !: ( 1  :jpi   , 1  :jpi   )
+   INTEGER, PARAMETER, PUBLIC ::   jpdom_local_noextra = 5   !: ( 1  :nlci  , 1  :nlcj  )
+   INTEGER, PARAMETER, PUBLIC ::   jpdom_local_noovlap = 6   !: (nldi:nlei  ,nldj:nlej  )
+   INTEGER, PARAMETER, PUBLIC ::   jpdom_unknown       = 7   !: No dimension checking
+   INTEGER, PARAMETER, PUBLIC ::   jpdom_autoglo       = 8   !: 
+   INTEGER, PARAMETER, PUBLIC ::   jpdom_autoglo_xy    = 9   !: Automatically set horizontal dimensions only
+   INTEGER, PARAMETER, PUBLIC ::   jpdom_autodta       = 10  !: 
+
+   INTEGER, PARAMETER, PUBLIC ::   jpnf90      = 101      !: Use nf90 library
+
+   INTEGER, PARAMETER, PUBLIC ::   jprstlib  = jpnf90     !: restarts io library
+
+   INTEGER, PARAMETER, PUBLIC ::   jp_r8    = 200      !: write REAL(8)
+   INTEGER, PARAMETER, PUBLIC ::   jp_r4    = 201      !: write REAL(4)
+   INTEGER, PARAMETER, PUBLIC ::   jp_i4    = 202      !: write INTEGER(4)
+   INTEGER, PARAMETER, PUBLIC ::   jp_i2    = 203      !: write INTEGER(2)
+   INTEGER, PARAMETER, PUBLIC ::   jp_i1    = 204      !: write INTEGER(1)
+
+   INTEGER, PARAMETER, PUBLIC ::   jpmax_files  = 100  !: maximum number of simultaneously opened file
+   INTEGER, PARAMETER, PUBLIC ::   jpmax_vars   = 1200 !: maximum number of variables in one file
+   INTEGER, PARAMETER, PUBLIC ::   jpmax_dims   =  4   !: maximum number of dimensions for one variable
+   INTEGER, PARAMETER, PUBLIC ::   jpmax_digits =  5   !: maximum number of digits for the cpu number in the file name
+
+
+!$AGRIF_DO_NOT_TREAT
+   INTEGER, PUBLIC            ::   iom_open_init = 0   !: used to initialize iom_file(:)%nfid to 0
+!XIOS write restart   
+   LOGICAL, PUBLIC            ::   lwxios          !: write single file restart using XIOS
+   INTEGER, PUBLIC            ::   nxioso          !: type of restart file when writing using XIOS 1 - single, 2 - multiple
+!XIOS read restart   
+   LOGICAL, PUBLIC            ::   lrxios          !: read single file restart using XIOS
+   LOGICAL, PUBLIC            ::   lxios_sini = .FALSE. ! is restart in a single file
+   LOGICAL, PUBLIC            ::   lxios_set  = .FALSE. 
+
+
+
+   TYPE, PUBLIC ::   file_descriptor
+      CHARACTER(LEN=240)                        ::   name     !: name of the file
+      INTEGER                                   ::   nfid     !: identifier of the file (0 if closed)
+      INTEGER                                   ::   iolib    !: library used to read the file (jpnf90 or new formats,
+                                                              !: jpioipsl option has been removed)
+      INTEGER                                   ::   nvars    !: number of identified varibles in the file
+      INTEGER                                   ::   iduld    !: id of the unlimited dimension
+      INTEGER                                   ::   lenuld   !: length of the unlimited dimension (number of records in file)
+      INTEGER                                   ::   irec     !: writing record position  
+      CHARACTER(LEN=32)                         ::   uldname  !: name of the unlimited dimension
+      CHARACTER(LEN=32), DIMENSION(jpmax_vars)  ::   cn_var   !: names of the variables
+      INTEGER, DIMENSION(jpmax_vars)            ::   nvid     !: id of the variables
+      INTEGER, DIMENSION(jpmax_vars)            ::   ndims    !: number of dimensions of the variables
+      LOGICAL, DIMENSION(jpmax_vars)            ::   luld     !: variable using the unlimited dimension
+      INTEGER, DIMENSION(jpmax_dims,jpmax_vars) ::   dimsz    !: size of variables dimensions 
+      REAL(kind=wp), DIMENSION(jpmax_vars)      ::   scf      !: scale_factor of the variables
+      REAL(kind=wp), DIMENSION(jpmax_vars)      ::   ofs      !: add_offset of the variables
+      INTEGER                                   ::   nlev     ! number of vertical levels
+   END TYPE file_descriptor
+   TYPE(file_descriptor), DIMENSION(jpmax_files), PUBLIC ::   iom_file !: array containing the info for all opened files
+   INTEGER, PARAMETER, PUBLIC                   :: max_rst_fields = 95 !: maximum number of restart variables defined in iom_set_rst_vars
+   TYPE, PUBLIC :: RST_FIELD  
+    CHARACTER(len=30) :: vname = "NO_NAME" ! names of variables in restart file
+    CHARACTER(len=30) :: grid = "NO_GRID"
+    LOGICAL           :: active =.FALSE. ! for restart write only: true - write field, false do not write field
+   END TYPE RST_FIELD
+!$AGRIF_END_DO_NOT_TREAT
+   !
+   TYPE(RST_FIELD), PUBLIC :: rst_wfields(max_rst_fields), rst_rfields(max_rst_fields)
+   !
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO Consortium (2010)
+   !! $Id$
+   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
+   !!======================================================================
+END MODULE iom_def
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/IOM/iom_nf90.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/IOM/iom_nf90.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/IOM/iom_nf90.F90	(revision 9570)
@@ -0,0 +1,890 @@
+MODULE iom_nf90
+   !!======================================================================
+   !!                    ***  MODULE  iom_nf90 ***
+   !! Input/Output manager :  Library to read input files with NF90 (only fliocom module)
+   !!======================================================================
+   !! History :  9.0  ! 05 12  (J. Belier) Original code
+   !!            9.0  ! 06 02  (S. Masson) Adaptation to NEMO
+   !!             "   ! 07 07  (D. Storkey) Changes to iom_nf90_gettime
+   !!            3.6  ! 2015-15  (J. Harle) Added procedure to read REAL attributes
+   !!            4.0  ! 2017-11 (M. Andrejczuk) Extend IOM interface to write any 3D fields
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   iom_open       : open a file read only
+   !!   iom_close      : close a file or all files opened by iom
+   !!   iom_get        : read a field (interfaced to several routines)
+   !!   iom_gettime    : read the time axis kvid in the file
+   !!   iom_varid      : get the id of a variable in a file
+   !!   iom_rstput     : write a field in a restart file (interfaced to several routines)
+   !!----------------------------------------------------------------------
+   USE dom_oce         ! ocean space and time domain
+   USE lbclnk          ! lateal boundary condition / mpp exchanges
+   USE iom_def         ! iom variables definitions
+   USE netcdf          ! NetCDF library
+   USE in_out_manager  ! I/O manager
+   USE lib_mpp         ! MPP library
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC iom_nf90_open  , iom_nf90_close, iom_nf90_varid, iom_nf90_get, iom_nf90_gettime, iom_nf90_rstput
+   PUBLIC iom_nf90_getatt, iom_nf90_putatt
+
+   INTERFACE iom_nf90_get
+      MODULE PROCEDURE iom_nf90_g0d, iom_nf90_g123d
+   END INTERFACE
+   INTERFACE iom_nf90_getatt
+      MODULE PROCEDURE iom_nf90_giatt, iom_nf90_gratt, iom_nf90_gcatt
+   END INTERFACE
+   INTERFACE iom_nf90_putatt
+      MODULE PROCEDURE iom_nf90_piatt, iom_nf90_pratt, iom_nf90_pcatt
+   END INTERFACE
+   INTERFACE iom_nf90_rstput
+      MODULE PROCEDURE iom_nf90_rp0123d
+   END INTERFACE
+
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 4.0 , NEMO Consortium (2017)
+   !! $Id$
+   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE iom_nf90_open( cdname, kiomid, ldwrt, ldok, kdompar, kdlev )
+      !!---------------------------------------------------------------------
+      !!                   ***  SUBROUTINE  iom_open  ***
+      !!
+      !! ** Purpose : open an input file with NF90
+      !!---------------------------------------------------------------------
+      CHARACTER(len=*)       , INTENT(inout)           ::   cdname      ! File name
+      INTEGER                , INTENT(  out)           ::   kiomid      ! nf90 identifier of the opened file
+      LOGICAL                , INTENT(in   )           ::   ldwrt       ! read or write the file?
+      LOGICAL                , INTENT(in   )           ::   ldok        ! check the existence 
+      INTEGER, DIMENSION(2,5), INTENT(in   ), OPTIONAL ::   kdompar     ! domain parameters: 
+      INTEGER                , INTENT(in   ), OPTIONAL ::   kdlev       ! size of the third dimension
+
+      CHARACTER(LEN=256) ::   clinfo           ! info character
+      CHARACTER(LEN=256) ::   cltmp            ! temporary character
+      INTEGER            ::   iln              ! lengths of character
+      INTEGER            ::   istop            ! temporary storage of nstop
+      INTEGER            ::   if90id           ! nf90 identifier of the opened file
+      INTEGER            ::   idmy             ! dummy variable
+      INTEGER            ::   jl               ! loop variable
+      INTEGER            ::   ichunk           ! temporary storage of nn_chunksz
+      INTEGER            ::   imode            ! creation mode flag: NF90_CLOBBER or NF90_NOCLOBBER or NF90_HDF5
+      INTEGER            ::   ihdf5            ! local variable for retrieval of value for NF90_HDF5
+      LOGICAL            ::   llclobber        ! local definition of ln_clobber
+      INTEGER            ::   ilevels           ! vertical levels
+      !---------------------------------------------------------------------
+      !
+      clinfo = '                    iom_nf90_open ~~~  '
+      istop = nstop     ! store the actual value of nstop
+      !
+      !                 !number of vertical levels
+      IF( PRESENT(kdlev) ) THEN   ;   ilevels = kdlev    ! use input value (useful for sea-ice)
+      ELSE                        ;   ilevels = jpk      ! by default jpk
+      ENDIF
+      !
+      IF( nn_chunksz > 0 ) THEN   ;   ichunk = nn_chunksz
+      ELSE                        ;   ichunk = NF90_SIZEHINT_DEFAULT
+      ENDIF
+      !
+      llclobber = ldwrt .AND. ln_clobber
+      IF( ldok .AND. .NOT. llclobber ) THEN      !==  Open existing file ==!
+         !                                       !=========================!
+         IF( ldwrt ) THEN  ! ... in write mode
+            IF(lwp) WRITE(numout,*) TRIM(clinfo)//' open existing file: '//TRIM(cdname)//' in WRITE mode'
+            IF( snc4set%luse ) THEN
+               CALL iom_nf90_check(NF90_OPEN( TRIM(cdname), NF90_WRITE  , if90id ), clinfo)
+            ELSE
+               CALL iom_nf90_check(NF90_OPEN( TRIM(cdname), NF90_WRITE  , if90id, chunksize = ichunk ), clinfo)
+            ENDIF
+            CALL iom_nf90_check(NF90_SET_FILL( if90id, NF90_NOFILL, idmy                          ), clinfo)
+         ELSE              ! ... in read mode
+            IF(lwp) WRITE(numout,*) TRIM(clinfo)//' open existing file: '//TRIM(cdname)//' in READ mode'
+            CALL iom_nf90_check(NF90_OPEN( TRIM(cdname), NF90_NOWRITE, if90id, chunksize = ichunk ), clinfo)
+         ENDIF
+      ELSE                                       !== the file doesn't exist ==!   (or we overwrite it)
+         !                                       !============================!
+         iln = INDEX( cdname, '.nc' )
+         IF( ldwrt ) THEN              !* the file should be open in write mode so we create it...
+            IF( jpnij > 1 ) THEN
+               WRITE(cltmp,'(a,a,i4.4,a)') cdname(1:iln-1), '_', narea-1, '.nc'
+               cdname = TRIM(cltmp)
+            ENDIF
+            IF(lwp) WRITE(numout,*) TRIM(clinfo)//' create new file: '//TRIM(cdname)//' in WRITE mode'
+
+            IF( llclobber ) THEN   ;   imode = IOR( NF90_64BIT_OFFSET, NF90_CLOBBER   )
+            ELSE                   ;   imode = IOR( NF90_64BIT_OFFSET, NF90_NOCLOBBER ) 
+            ENDIF
+            IF( snc4set%luse ) THEN
+               IF(lwp) WRITE(numout,*) TRIM(clinfo)//' creating file: '//TRIM(cdname)//' in hdf5 (netcdf4) mode'
+               CALL GET_NF90_SYMBOL("NF90_HDF5", ihdf5)
+               IF( llclobber ) THEN   ;   imode = IOR(ihdf5, NF90_CLOBBER)
+               ELSE                   ;   imode = IOR(ihdf5, NF90_NOCLOBBER)
+               ENDIF
+               CALL iom_nf90_check(NF90_CREATE( TRIM(cdname), imode, if90id ), clinfo)
+            ELSE
+               CALL iom_nf90_check(NF90_CREATE( TRIM(cdname), imode, if90id, chunksize = ichunk ), clinfo)
+            ENDIF
+            CALL iom_nf90_check(NF90_SET_FILL( if90id, NF90_NOFILL, idmy                     ), clinfo)
+            ! define dimensions
+            CALL iom_nf90_check(NF90_DEF_DIM( if90id, 'x'      , kdompar(1,1)  , idmy ), clinfo)
+            CALL iom_nf90_check(NF90_DEF_DIM( if90id, 'y'      , kdompar(2,1)  , idmy ), clinfo)
+            IF( PRESENT(kdlev) ) THEN
+               CALL iom_nf90_check(NF90_DEF_DIM( if90id, 'numcat' , ilevels    , idmy ), clinfo)
+            ELSE
+               CALL iom_nf90_check(NF90_DEF_DIM( if90id, 'nav_lev', ilevels    , idmy ), clinfo)
+            ENDIF
+            CALL iom_nf90_check(NF90_DEF_DIM( if90id, 'time_counter', NF90_UNLIMITED, idmy ), clinfo)
+            ! global attributes
+            CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_number_total'   , jpnij              ), clinfo)
+            CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_number'         , narea-1            ), clinfo)
+            CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_dimensions_ids' , (/1     , 2     /) ), clinfo)
+            CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_size_global'    , (/jpiglo, jpjglo/) ), clinfo)
+            CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_size_local'     , kdompar(:,1)       ), clinfo)
+            CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_position_first' , kdompar(:,2)       ), clinfo)
+            CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_position_last'  , kdompar(:,3)       ), clinfo)
+            CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_halo_size_start', kdompar(:,4)       ), clinfo)
+            CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_halo_size_end'  , kdompar(:,5)       ), clinfo)
+            CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_type'           , 'BOX'              ), clinfo)
+         ELSE                          !* the file should be open for read mode so it must exist...
+            CALL ctl_stop( TRIM(clinfo), ' should be impossible case...' )
+         ENDIF
+      ENDIF
+      !
+      ! start to fill file informations
+      ! =============
+      IF( istop == nstop ) THEN   ! no error within this routine
+!does not work with some compilers         kiomid = MINLOC(iom_file(:)%nfid, dim = 1)
+         kiomid = 0
+         DO jl = jpmax_files, 1, -1
+            IF( iom_file(jl)%nfid == 0 )   kiomid = jl
+         ENDDO
+         iom_file(kiomid)%name   = TRIM(cdname)
+         iom_file(kiomid)%nfid   = if90id
+         iom_file(kiomid)%iolib  = jpnf90
+         iom_file(kiomid)%nvars  = 0
+         iom_file(kiomid)%irec   = -1   ! useless for NetCDF files, used to know if the file is in define mode 
+         iom_file(kiomid)%nlev   = ilevels
+         CALL iom_nf90_check(NF90_Inquire(if90id, unlimitedDimId = iom_file(kiomid)%iduld), clinfo)
+         IF( iom_file(kiomid)%iduld .GE. 0 ) THEN
+            CALL iom_nf90_check(NF90_Inquire_Dimension(if90id, iom_file(kiomid)%iduld,    & 
+               &                                       name = iom_file(kiomid)%uldname,   &
+               &                                       len  = iom_file(kiomid)%lenuld ), clinfo )
+         ENDIF
+         IF(lwp) WRITE(numout,*) '                   ---> '//TRIM(cdname)//' OK'
+      ELSE
+         kiomid = 0               ! return error flag
+      ENDIF
+      !
+   END SUBROUTINE iom_nf90_open
+
+
+   SUBROUTINE iom_nf90_close( kiomid )
+      !!--------------------------------------------------------------------
+      !!                   ***  SUBROUTINE  iom_nf90_close  ***
+      !!
+      !! ** Purpose : close an input file with NF90
+      !!--------------------------------------------------------------------
+      INTEGER, INTENT(in) ::   kiomid   ! iom identifier of the file to be closed
+      CHARACTER(LEN=100)  ::   clinfo   ! info character
+      !---------------------------------------------------------------------
+      clinfo = '      iom_nf90_close    , file: '//TRIM(iom_file(kiomid)%name)
+      CALL iom_nf90_check(NF90_CLOSE(iom_file(kiomid)%nfid), clinfo)
+   END SUBROUTINE iom_nf90_close
+
+
+   FUNCTION iom_nf90_varid ( kiomid, cdvar, kiv, kdimsz, kndims )  
+      !!-----------------------------------------------------------------------
+      !!                  ***  FUNCTION  iom_varid  ***
+      !!
+      !! ** Purpose : get the id of a variable in a file with NF90
+      !!-----------------------------------------------------------------------
+      INTEGER              , INTENT(in   )           ::   kiomid   ! file Identifier
+      CHARACTER(len=*)     , INTENT(in   )           ::   cdvar    ! name of the variable
+      INTEGER              , INTENT(in   )           ::   kiv   ! 
+      INTEGER, DIMENSION(:), INTENT(  out), OPTIONAL ::   kdimsz   ! size of the dimensions
+      INTEGER,               INTENT(  out), OPTIONAL ::   kndims   ! size of the dimensions
+      !
+      INTEGER                        ::   iom_nf90_varid   ! iom variable Id
+      INTEGER                        ::   if90id           ! nf90 file identifier
+      INTEGER                        ::   ji               ! dummy loop index
+      INTEGER                        ::   ivarid           ! NetCDF  variable Id
+      INTEGER                        ::   i_nvd            ! number of dimension of the variable
+      INTEGER, DIMENSION(jpmax_dims) ::   idimid           ! dimension ids of the variable
+      LOGICAL                        ::   llok             ! ok  test
+      CHARACTER(LEN=100)             ::   clinfo           ! info character
+      !!-----------------------------------------------------------------------
+      clinfo = '          iom_nf90_varid, file: '//TRIM(iom_file(kiomid)%name)//', var: '//TRIM(cdvar)
+      iom_nf90_varid = 0                    ! default definition
+      IF( PRESENT(kdimsz) ) kdimsz(:) = 0   ! default definition
+      if90id = iom_file(kiomid)%nfid        ! get back NetCDF file id
+      !
+      llok = NF90_INQ_VARID( if90id, TRIM(cdvar), ivarid ) == nf90_noerr   ! does the variable exist in the file
+      IF( llok ) THEN
+         iom_nf90_varid = kiv
+         iom_file(kiomid)%nvars       = kiv
+         iom_file(kiomid)%nvid(kiv)   = ivarid
+         iom_file(kiomid)%cn_var(kiv) = TRIM(cdvar)
+         CALL iom_nf90_check(NF90_Inquire_Variable(if90id, ivarid, ndims = i_nvd), clinfo)   ! number of dimensions
+         iom_file(kiomid)%ndims(kiv)  = i_nvd
+         CALL iom_nf90_check(NF90_Inquire_Variable(if90id, ivarid, dimids = idimid(1:i_nvd)), clinfo)   ! dimensions ids
+         iom_file(kiomid)%luld(kiv) = .FALSE.   ! default value
+         iom_file(kiomid)%dimsz(:,kiv) = 0      ! reset dimsz in case previously used
+         DO ji = 1, i_nvd                       ! dimensions size
+            CALL iom_nf90_check(NF90_Inquire_Dimension(if90id, idimid(ji), len = iom_file(kiomid)%dimsz(ji,kiv)), clinfo)   
+            IF( idimid(ji) == iom_file(kiomid)%iduld ) iom_file(kiomid)%luld(kiv) = .TRUE.   ! unlimited dimension? 
+         END DO
+         !---------- Deal with scale_factor and add_offset
+         llok = NF90_Inquire_attribute(if90id, ivarid, 'scale_factor') == nf90_noerr
+         IF( llok) THEN
+            CALL iom_nf90_check(NF90_GET_ATT(if90id, ivarid, 'scale_factor', iom_file(kiomid)%scf(kiv)), clinfo)
+         ELSE
+            iom_file(kiomid)%scf(kiv) = 1.
+         END IF
+         llok = NF90_Inquire_attribute(if90id, ivarid, 'add_offset') == nf90_noerr
+         IF( llok ) THEN
+            CALL iom_nf90_check(NF90_GET_ATT(if90id, ivarid, 'add_offset', iom_file(kiomid)%ofs(kiv)), clinfo)
+         ELSE
+            iom_file(kiomid)%ofs(kiv) = 0.
+         END IF
+         ! return the simension size
+         IF( PRESENT(kdimsz) ) THEN 
+            IF( i_nvd <= SIZE(kdimsz) ) THEN
+               kdimsz(1:i_nvd) = iom_file(kiomid)%dimsz(1:i_nvd,kiv)
+            ELSE
+               WRITE(ctmp1,*) i_nvd, SIZE(kdimsz)
+               CALL ctl_stop( TRIM(clinfo), 'error in kdimsz size'//TRIM(ctmp1) )
+            ENDIF
+         ENDIF
+         IF( PRESENT(kndims) )  kndims = iom_file(kiomid)%ndims(kiv)
+      ELSE  
+         iom_nf90_varid = -1   !   variable not found, return error code: -1
+      ENDIF
+      !
+   END FUNCTION iom_nf90_varid
+
+   !!----------------------------------------------------------------------
+   !!                   INTERFACE iom_nf90_get
+   !!----------------------------------------------------------------------
+
+   SUBROUTINE iom_nf90_g0d( kiomid, kvid, pvar, kstart )
+      !!-----------------------------------------------------------------------
+      !!                  ***  ROUTINE  iom_nf90_g0d  ***
+      !!
+      !! ** Purpose : read a scalar with NF90
+      !!-----------------------------------------------------------------------
+      INTEGER ,               INTENT(in   )            ::   kiomid   ! Identifier of the file
+      INTEGER ,               INTENT(in   )            ::   kvid     ! variable id
+      REAL(wp),               INTENT(  out)            ::   pvar     ! read field
+      INTEGER , DIMENSION(1), INTENT(in   ), OPTIONAL  ::   kstart   ! start position of the reading in each axis
+      !
+      CHARACTER(LEN=100)      ::   clinfo   ! info character
+      !---------------------------------------------------------------------
+      clinfo = 'iom_nf90_g0d , file: '//TRIM(iom_file(kiomid)%name)//', var: '//TRIM(iom_file(kiomid)%cn_var(kvid))
+      CALL iom_nf90_check(NF90_GET_VAR(iom_file(kiomid)%nfid, iom_file(kiomid)%nvid(kvid), pvar, start = kstart), clinfo )
+   END SUBROUTINE iom_nf90_g0d
+
+
+   SUBROUTINE iom_nf90_g123d( kiomid, kvid, knbdim, kstart, kcount, kx1, kx2, ky1, ky2,   &
+         &                    pv_r1d, pv_r2d, pv_r3d )
+      !!-----------------------------------------------------------------------
+      !!                  ***  ROUTINE  iom_nf90_g123d  ***
+      !!
+      !! ** Purpose : read a 1D/2D/3D variable with NF90
+      !!
+      !! ** Method : read ONE record at each CALL
+      !!-----------------------------------------------------------------------
+      INTEGER                    , INTENT(in   )           ::   kiomid    ! iom identifier of the file
+      INTEGER                    , INTENT(in   )           ::   kvid      ! Name of the variable
+      INTEGER                    , INTENT(in   )           ::   knbdim    ! number of dimensions of the variable
+      INTEGER , DIMENSION(:)     , INTENT(in   )           ::   kstart    ! start position of the reading in each axis 
+      INTEGER , DIMENSION(:)     , INTENT(in   )           ::   kcount    ! number of points to be read in each axis
+      INTEGER ,                    INTENT(in   )           ::   kx1, kx2, ky1, ky2   ! subdomain indexes
+      REAL(wp), DIMENSION(:)     , INTENT(  out), OPTIONAL ::   pv_r1d    ! read field (1D case)
+      REAL(wp), DIMENSION(:,:)   , INTENT(  out), OPTIONAL ::   pv_r2d    ! read field (2D case)
+      REAL(wp), DIMENSION(:,:,:) , INTENT(  out), OPTIONAL ::   pv_r3d    ! read field (3D case)
+      !
+      CHARACTER(LEN=100) ::   clinfo               ! info character
+      INTEGER            ::   if90id               ! nf90 identifier of the opened file
+      INTEGER            ::   ivid                 ! nf90 variable id
+      !---------------------------------------------------------------------
+      clinfo = 'iom_nf90_g123d , file: '//TRIM(iom_file(kiomid)%name)//', var: '//TRIM(iom_file(kiomid)%cn_var(kvid))
+      if90id = iom_file(kiomid)%nfid         ! get back NetCDF file id
+      ivid   = iom_file(kiomid)%nvid(kvid)   ! get back NetCDF var id
+      !
+      IF(     PRESENT(pv_r1d) ) THEN
+         CALL iom_nf90_check( NF90_GET_VAR(if90id, ivid, pv_r1d(:                ), start = kstart(1:knbdim),   &
+            &                                                                       count = kcount(1:knbdim)), clinfo )
+      ELSEIF( PRESENT(pv_r2d) ) THEN
+         CALL iom_nf90_check( NF90_GET_VAR(if90id, ivid, pv_r2d(kx1:kx2,ky1:ky2  ), start = kstart(1:knbdim),   &
+            &                                                                       count = kcount(1:knbdim)), clinfo )
+      ELSEIF( PRESENT(pv_r3d) ) THEN
+         CALL iom_nf90_check( NF90_GET_VAR(if90id, ivid, pv_r3d(kx1:kx2,ky1:ky2,:), start = kstart(1:knbdim),   &
+            &                                                                       count = kcount(1:knbdim)), clinfo )
+      ENDIF
+      !
+   END SUBROUTINE iom_nf90_g123d
+
+   !!----------------------------------------------------------------------
+   !!                   INTERFACE iom_nf90_getatt
+   !!----------------------------------------------------------------------
+
+   SUBROUTINE iom_nf90_giatt( kiomid, cdatt, pv_i0d, cdvar)
+      !!-----------------------------------------------------------------------
+      !!                  ***  ROUTINE  iom_nf90_giatt  ***
+      !!
+      !! ** Purpose : read an integer attribute with NF90
+      !!              (either a global attribute (default) or a variable
+      !!               attribute if optional variable name is supplied (cdvar))
+      !!-----------------------------------------------------------------------
+      INTEGER         , INTENT(in   ) ::   kiomid   ! Identifier of the file
+      CHARACTER(len=*), INTENT(in   ) ::   cdatt    ! attribute name
+      INTEGER         , INTENT(  out) ::   pv_i0d   ! read field
+      CHARACTER(len=*), INTENT(in   ), OPTIONAL     &
+                      &               ::   cdvar    ! name of the variable
+      !
+      INTEGER                         ::   if90id   ! temporary integer
+      INTEGER                         ::   ivarid   ! NetCDF variable Id
+      LOGICAL                         ::   llok     ! temporary logical
+      CHARACTER(LEN=100)              ::   clinfo   ! info character
+      !---------------------------------------------------------------------
+      !
+      if90id = iom_file(kiomid)%nfid
+      IF( PRESENT(cdvar) ) THEN
+         ! check the variable exists in the file
+         llok = NF90_INQ_VARID( if90id, TRIM(cdvar), ivarid ) == nf90_noerr
+         IF( llok ) THEN
+            ! check the variable has the attribute required
+            llok = NF90_Inquire_attribute(if90id, ivarid, cdatt) == nf90_noerr
+         ELSE
+            CALL ctl_warn('iom_nf90_getatt: no variable '//cdvar//' found')
+         ENDIF
+      ELSE
+         llok = NF90_Inquire_attribute(if90id, NF90_GLOBAL, cdatt) == nf90_noerr
+         ivarid = NF90_GLOBAL
+      ENDIF
+      !
+      IF( llok) THEN
+         clinfo = 'iom_nf90_getatt, file: '//TRIM(iom_file(kiomid)%name)//', giatt: '//TRIM(cdatt)
+         CALL iom_nf90_check(NF90_GET_ATT(if90id, ivarid, cdatt, values=pv_i0d), clinfo)
+      ELSE
+         CALL ctl_warn('iom_nf90_getatt: no attribute '//cdatt//' found')
+         pv_i0d = -999
+      ENDIF
+      !
+   END SUBROUTINE iom_nf90_giatt
+
+
+   SUBROUTINE iom_nf90_gratt( kiomid, cdatt, pv_r0d, cdvar )
+      !!-----------------------------------------------------------------------
+      !!                  ***  ROUTINE  iom_nf90_gratt  ***
+      !!
+      !! ** Purpose : read a real attribute with NF90
+      !!              (either a global attribute (default) or a variable
+      !!               attribute if optional variable name is supplied (cdvar))
+      !!-----------------------------------------------------------------------
+      INTEGER                   , INTENT(in   ) ::   kiomid   ! Identifier of the file
+      CHARACTER(len=*)          , INTENT(in   ) ::   cdatt    ! attribute name
+      REAL(wp)                  , INTENT(  out) ::   pv_r0d   ! read field
+      CHARACTER(len=*), OPTIONAL, INTENT(in   ) ::   cdvar    ! name of the variable
+      !
+      INTEGER            ::   if90id   ! temporary integer
+      INTEGER            ::   ivarid   ! NetCDF variable Id
+      LOGICAL            ::   llok     ! temporary logical
+      CHARACTER(LEN=100) ::   clinfo   ! info character
+      !---------------------------------------------------------------------
+      !
+      if90id = iom_file(kiomid)%nfid
+      IF( PRESENT(cdvar) ) THEN
+         ! check the variable exists in the file
+         llok = NF90_INQ_VARID( if90id, TRIM(cdvar), ivarid ) == nf90_noerr
+         IF( llok ) THEN
+            ! check the variable has the attribute required
+            llok = NF90_Inquire_attribute(if90id, ivarid, cdatt) == nf90_noerr
+         ELSE
+            CALL ctl_warn('iom_nf90_getatt: no variable '//cdvar//' found')
+         ENDIF
+      ELSE
+         llok = NF90_Inquire_attribute(if90id, NF90_GLOBAL, cdatt) == nf90_noerr
+         ivarid = NF90_GLOBAL
+      ENDIF
+      !
+      IF( llok) THEN
+         clinfo = 'iom_nf90_getatt, file: '//TRIM(iom_file(kiomid)%name)//', gratt: '//TRIM(cdatt)
+         CALL iom_nf90_check(NF90_GET_ATT(if90id, ivarid, cdatt, values=pv_r0d), clinfo)
+      ELSE
+         CALL ctl_warn('iom_nf90_getatt: no attribute '//cdatt//' found')
+         pv_r0d = -999._wp
+      ENDIF
+      !
+   END SUBROUTINE iom_nf90_gratt
+
+
+   SUBROUTINE iom_nf90_gcatt( kiomid, cdatt, pv_c0d, cdvar )
+      !!-----------------------------------------------------------------------
+      !!                  ***  ROUTINE  iom_nf90_gcatt  ***
+      !!
+      !! ** Purpose : read a character attribute with NF90
+      !!              (either a global attribute (default) or a variable
+      !!               attribute if optional variable name is supplied (cdvar))
+      !!-----------------------------------------------------------------------
+      INTEGER                   , INTENT(in   ) ::   kiomid   ! Identifier of the file
+      CHARACTER(len=*)          , INTENT(in   ) ::   cdatt    ! attribute name
+      CHARACTER(len=*)          , INTENT(  out) ::   pv_c0d   ! read field
+      CHARACTER(len=*), OPTIONAL, INTENT(in   ) ::   cdvar    ! name of the variable
+      !
+      INTEGER            ::   if90id   ! temporary integer
+      INTEGER            ::   ivarid   ! NetCDF variable Id
+      LOGICAL            ::   llok     ! temporary logical
+      CHARACTER(LEN=100) ::   clinfo   ! info character
+      !---------------------------------------------------------------------
+      !
+      if90id = iom_file(kiomid)%nfid
+      IF( PRESENT(cdvar) ) THEN
+         ! check the variable exists in the file
+         llok = NF90_INQ_VARID( if90id, TRIM(cdvar), ivarid ) == nf90_noerr
+         IF( llok ) THEN
+            ! check the variable has the attribute required
+            llok = NF90_Inquire_attribute(if90id, ivarid, cdatt) == nf90_noerr
+         ELSE
+            CALL ctl_warn('iom_nf90_getatt: no variable '//cdvar//' found')
+         ENDIF
+      ELSE
+         llok = NF90_Inquire_attribute(if90id, NF90_GLOBAL, cdatt) == nf90_noerr
+         ivarid = NF90_GLOBAL
+      ENDIF
+!
+      IF( llok) THEN
+         clinfo = 'iom_nf90_getatt, file: '//TRIM(iom_file(kiomid)%name)//', gcatt: '//TRIM(cdatt)
+         CALL iom_nf90_check(NF90_GET_ATT(if90id, ivarid, cdatt, values=pv_c0d), clinfo)
+      ELSE
+         CALL ctl_warn('iom_nf90_getatt: no attribute '//cdatt//' found')
+         pv_c0d = '!'
+      ENDIF
+      !
+   END SUBROUTINE iom_nf90_gcatt
+
+
+   !!----------------------------------------------------------------------
+   !!                   INTERFACE iom_nf90_putatt
+   !!----------------------------------------------------------------------
+
+   SUBROUTINE iom_nf90_piatt( kiomid, cdatt, pv_i0d, cdvar)
+      !!-----------------------------------------------------------------------
+      !!                  ***  ROUTINE  iom_nf90_piatt  ***
+      !!
+      !! ** Purpose : write an integer attribute with NF90
+      !!              (either a global attribute (default) or a variable
+      !!               attribute if optional variable name is supplied (cdvar))
+      !!-----------------------------------------------------------------------
+      INTEGER         , INTENT(in   ) ::   kiomid   ! Identifier of the file
+      CHARACTER(len=*), INTENT(in   ) ::   cdatt    ! attribute name
+      INTEGER         , INTENT(in   ) ::   pv_i0d   ! write field
+      CHARACTER(len=*), INTENT(in   ), OPTIONAL     &
+                      &               ::   cdvar    ! name of the variable
+      !
+      INTEGER                         ::   if90id   ! temporary integer
+      INTEGER                         ::   ivarid   ! NetCDF variable Id
+      LOGICAL                         ::   llok     ! temporary logical
+      LOGICAL                         ::   lenddef  ! temporary logical
+      CHARACTER(LEN=100)              ::   clinfo   ! info character
+      !---------------------------------------------------------------------
+      !
+      if90id = iom_file(kiomid)%nfid
+      lenddef = .false.
+      IF( PRESENT(cdvar) ) THEN
+         ! check the variable exists in the file
+         llok = NF90_INQ_VARID( if90id, TRIM(cdvar), ivarid ) == nf90_noerr
+         IF( .NOT. llok ) THEN
+            CALL ctl_warn('iom_nf90_putatt: no variable '//cdvar//' found')
+         ENDIF
+      ELSE
+         llok = .true.
+         ivarid = NF90_GLOBAL
+      ENDIF
+      !
+      IF( llok) THEN
+         clinfo = 'iom_nf90_putatt, file: '//TRIM(iom_file(kiomid)%name)//', piatt: '//TRIM(cdatt)
+         IF( iom_file(kiomid)%irec /= -1 ) THEN   
+            ! trick: irec used to know if the file is in define mode or not
+            ! if it is not then temporarily put it into define mode
+            CALL iom_nf90_check(NF90_REDEF( if90id ), clinfo)
+            lenddef = .true.
+         ENDIF
+         !
+         CALL iom_nf90_check(NF90_PUT_ATT(if90id, ivarid, cdatt, values=pv_i0d), clinfo)
+         !
+         IF( lenddef ) THEN   
+            ! file was in data mode on entry; put it back in that mode
+            CALL iom_nf90_check(NF90_ENDDEF( if90id ), clinfo)
+         ENDIF
+      ELSE
+         CALL ctl_warn('iom_nf90_putatt: no attribute '//cdatt//' written')
+      ENDIF
+      !
+   END SUBROUTINE iom_nf90_piatt
+
+
+   SUBROUTINE iom_nf90_pratt( kiomid, cdatt, pv_r0d, cdvar )
+      !!-----------------------------------------------------------------------
+      !!                  ***  ROUTINE  iom_nf90_pratt  ***
+      !!
+      !! ** Purpose : write a real attribute with NF90
+      !!              (either a global attribute (default) or a variable
+      !!               attribute if optional variable name is supplied (cdvar))
+      !!-----------------------------------------------------------------------
+      INTEGER                   , INTENT(in   ) ::   kiomid   ! Identifier of the file
+      CHARACTER(len=*)          , INTENT(in   ) ::   cdatt    ! attribute name
+      REAL(wp)                  , INTENT(in   ) ::   pv_r0d   ! write field
+      CHARACTER(len=*), OPTIONAL, INTENT(in   ) ::   cdvar    ! name of the variable
+      !
+      INTEGER            ::   if90id   ! temporary integer
+      INTEGER            ::   ivarid   ! NetCDF variable Id
+      LOGICAL            ::   llok     ! temporary logical
+      LOGICAL            ::   lenddef  ! temporary logical
+      CHARACTER(LEN=100) ::   clinfo   ! info character
+      !---------------------------------------------------------------------
+      !
+      if90id = iom_file(kiomid)%nfid
+      lenddef = .false.
+      IF( PRESENT(cdvar) ) THEN
+         ! check the variable exists in the file
+         llok = NF90_INQ_VARID( if90id, TRIM(cdvar), ivarid ) == nf90_noerr
+         IF( .NOT. llok ) THEN
+            CALL ctl_warn('iom_nf90_putatt: no variable '//cdvar//' found')
+         ENDIF
+      ELSE
+         llok = .true.
+         ivarid = NF90_GLOBAL
+      ENDIF
+      !
+      IF( llok) THEN
+         clinfo = 'iom_nf90_putatt, file: '//TRIM(iom_file(kiomid)%name)//', pratt: '//TRIM(cdatt)
+         IF( iom_file(kiomid)%irec /= -1 ) THEN   
+            ! trick: irec used to know if the file is in define mode or not
+            ! if it is not then temporarily put it into define mode
+            CALL iom_nf90_check(NF90_REDEF( if90id ), clinfo)
+            lenddef = .true.
+         ENDIF
+         !
+         CALL iom_nf90_check(NF90_PUT_ATT(if90id, ivarid, cdatt, values=pv_r0d), clinfo)
+         !
+         IF( lenddef ) THEN   
+            ! file was in data mode on entry; put it back in that mode
+            CALL iom_nf90_check(NF90_ENDDEF( if90id ), clinfo)
+         ENDIF
+      ELSE
+         CALL ctl_warn('iom_nf90_putatt: no attribute '//cdatt//' written')
+      ENDIF
+      !
+   END SUBROUTINE iom_nf90_pratt
+
+
+   SUBROUTINE iom_nf90_pcatt( kiomid, cdatt, pv_c0d, cdvar )
+      !!-----------------------------------------------------------------------
+      !!                  ***  ROUTINE  iom_nf90_pcatt  ***
+      !!
+      !! ** Purpose : write a character attribute with NF90
+      !!              (either a global attribute (default) or a variable
+      !!               attribute if optional variable name is supplied (cdvar))
+      !!-----------------------------------------------------------------------
+      INTEGER                   , INTENT(in   ) ::   kiomid   ! Identifier of the file
+      CHARACTER(len=*)          , INTENT(in   ) ::   cdatt    ! attribute name
+      CHARACTER(len=*)          , INTENT(in   ) ::   pv_c0d   ! write field
+      CHARACTER(len=*), OPTIONAL, INTENT(in   ) ::   cdvar    ! name of the variable
+      !
+      INTEGER            ::   if90id   ! temporary integer
+      INTEGER            ::   ivarid   ! NetCDF variable Id
+      LOGICAL            ::   llok     ! temporary logical
+      LOGICAL            ::   lenddef  ! temporary logical
+      CHARACTER(LEN=100) ::   clinfo   ! info character
+      !---------------------------------------------------------------------
+      !
+      if90id = iom_file(kiomid)%nfid
+      lenddef = .false.
+      IF( PRESENT(cdvar) ) THEN
+         ! check the variable exists in the file
+         llok = NF90_INQ_VARID( if90id, TRIM(cdvar), ivarid ) == nf90_noerr
+         IF( .NOT. llok ) THEN
+            CALL ctl_warn('iom_nf90_putatt: no variable '//cdvar//' found')
+         ENDIF
+      ELSE
+         llok = .true.
+         ivarid = NF90_GLOBAL
+      ENDIF
+      !
+      IF( llok) THEN
+         clinfo = 'iom_nf90_putatt, file: '//TRIM(iom_file(kiomid)%name)//', pcatt: '//TRIM(cdatt)
+         IF( iom_file(kiomid)%irec /= -1 ) THEN   
+            ! trick: irec used to know if the file is in define mode or not
+            ! if it is not then temporarily put it into define mode
+            CALL iom_nf90_check(NF90_REDEF( if90id ), clinfo)
+            lenddef = .true.
+         ENDIF
+         !
+         CALL iom_nf90_check(NF90_PUT_ATT(if90id, ivarid, cdatt, values=pv_c0d), clinfo)
+         !
+         IF( lenddef ) THEN   
+            ! file was in data mode on entry; put it back in that mode
+            CALL iom_nf90_check(NF90_ENDDEF( if90id ), clinfo)
+         ENDIF
+      ELSE
+         CALL ctl_warn('iom_nf90_putatt: no attribute '//cdatt//' written')
+      ENDIF
+      !
+   END SUBROUTINE iom_nf90_pcatt
+
+
+   SUBROUTINE iom_nf90_gettime( kiomid, kvid, ptime, cdunits, cdcalendar )
+      !!--------------------------------------------------------------------
+      !!                   ***  SUBROUTINE iom_gettime  ***
+      !!
+      !! ** Purpose : read the time axis kvid in the file with NF90
+      !!--------------------------------------------------------------------
+      INTEGER                   , INTENT(in   ) ::   kiomid     ! file Identifier
+      INTEGER                   , INTENT(in   ) ::   kvid       ! variable id
+      REAL(wp), DIMENSION(:)    , INTENT(  out) ::   ptime      ! the time axis
+      CHARACTER(len=*), OPTIONAL, INTENT(  out) ::   cdunits    ! units attribute
+      CHARACTER(len=*), OPTIONAL, INTENT(  out) ::   cdcalendar ! calendar attribute
+      !
+      CHARACTER(LEN=100) ::   clinfo     ! info character
+      !---------------------------------------------------------------------
+      clinfo = 'iom_nf90_gettime, file: '//TRIM(iom_file(kiomid)%name)//', var: '//TRIM(iom_file(kiomid)%cn_var(kvid))
+      CALL iom_nf90_check(NF90_GET_VAR(iom_file(kiomid)%nfid, iom_file(kiomid)%nvid(kvid), ptime(:),   &
+            &                           start=(/ 1 /), count=(/ iom_file(kiomid)%dimsz(1, kvid) /)), clinfo)
+      IF ( PRESENT(cdunits) ) THEN 
+         CALL iom_nf90_check(NF90_GET_ATT(iom_file(kiomid)%nfid, iom_file(kiomid)%nvid(kvid), "units", &
+            &                           values=cdunits), clinfo)
+      ENDIF
+      IF ( PRESENT(cdcalendar) ) THEN 
+         CALL iom_nf90_check(NF90_GET_ATT(iom_file(kiomid)%nfid, iom_file(kiomid)%nvid(kvid), "calendar", &
+            &                           values=cdcalendar), clinfo)
+      ENDIF
+      !
+   END SUBROUTINE iom_nf90_gettime
+
+
+   SUBROUTINE iom_nf90_rp0123d( kt, kwrite, kiomid, cdvar , kvid  , ktype,   &
+         &                                  pv_r0d, pv_r1d, pv_r2d, pv_r3d )
+      !!--------------------------------------------------------------------
+      !!                   ***  SUBROUTINE  iom_nf90_rstput  ***
+      !!
+      !! ** Purpose : read the time axis cdvar in the file 
+      !!--------------------------------------------------------------------
+      INTEGER                     , INTENT(in)           ::   kt       ! ocean time-step
+      INTEGER                     , INTENT(in)           ::   kwrite   ! writing time-step
+      INTEGER                     , INTENT(in)           ::   kiomid   ! Identifier of the file 
+      CHARACTER(len=*)            , INTENT(in)           ::   cdvar    ! variable name
+      INTEGER                     , INTENT(in)           ::   kvid     ! variable id
+      INTEGER                     , INTENT(in), OPTIONAL ::   ktype    ! variable type (default R8)
+      REAL(wp)                    , INTENT(in), OPTIONAL ::   pv_r0d   ! written Od field
+      REAL(wp), DIMENSION(      :), INTENT(in), OPTIONAL ::   pv_r1d   ! written 1d field
+      REAL(wp), DIMENSION(:, :   ), INTENT(in), OPTIONAL ::   pv_r2d   ! written 2d field
+      REAL(wp), DIMENSION(:, :, :), INTENT(in), OPTIONAL ::   pv_r3d   ! written 3d field
+      !
+      INTEGER               :: idims                ! number of dimension
+      INTEGER               :: idvar                ! variable id
+      INTEGER               :: jd                   ! dimension loop counter   
+      INTEGER               :: ix1, ix2, iy1, iy2   ! subdomain indexes   
+      INTEGER, DIMENSION(4) :: idimsz               ! dimensions size  
+      INTEGER, DIMENSION(4) :: idimid               ! dimensions id
+      CHARACTER(LEN=256)    :: clinfo               ! info character
+      CHARACTER(LEN= 12), DIMENSION(4) :: cltmp     ! temporary character
+      INTEGER               :: if90id               ! nf90 file identifier
+      INTEGER               :: idmy                 ! dummy variable
+      INTEGER               :: itype                ! variable type
+      INTEGER, DIMENSION(4) :: ichunksz             ! NetCDF4 chunk sizes. Will be computed using
+      !                                             ! nn_nchunks_[i,j,k,t] namelist parameters
+      INTEGER               :: ichunkalg, ishuffle, ideflate, ideflate_level
+      !                                             ! NetCDF4 internally fixed parameters
+      LOGICAL               :: lchunk               ! logical switch to activate chunking and compression
+      !                                             ! when appropriate (currently chunking is applied to 4d fields only)
+      INTEGER               :: idlv                 ! local variable
+      !---------------------------------------------------------------------
+      !
+      clinfo = '          iom_nf90_rp0123d, file: '//TRIM(iom_file(kiomid)%name)//', var: '//TRIM(cdvar)
+      if90id = iom_file(kiomid)%nfid
+      !
+      ! define dimension variables if it is not already done
+      ! ==========================
+      IF( iom_file(kiomid)%nvars == 0 ) THEN
+         ! are we in define mode?
+         IF( iom_file(kiomid)%irec /= -1 ) THEN   ! trick: irec used to know if the file is in define mode or not
+            CALL iom_nf90_check(NF90_REDEF( if90id ), clinfo)   ;   iom_file(kiomid)%irec = -1
+         ENDIF
+         ! define the dimension variables if it is not already done
+         IF(iom_file(kiomid)%nlev == jpk ) THEN
+          cltmp = (/ 'nav_lon     ', 'nav_lat     ', 'nav_lev     ', 'time_counter' /)
+         ELSE
+          cltmp = (/ 'nav_lon     ', 'nav_lat     ', 'numcat      ', 'time_counter' /)
+         ENDIF
+         CALL iom_nf90_check(NF90_DEF_VAR( if90id, TRIM(cltmp(1)), NF90_FLOAT , (/ 1, 2 /), iom_file(kiomid)%nvid(1) ), clinfo)
+         CALL iom_nf90_check(NF90_DEF_VAR( if90id, TRIM(cltmp(2)), NF90_FLOAT , (/ 1, 2 /), iom_file(kiomid)%nvid(2) ), clinfo)
+         CALL iom_nf90_check(NF90_DEF_VAR( if90id, TRIM(cltmp(3)), NF90_FLOAT , (/ 3    /), iom_file(kiomid)%nvid(3) ), clinfo)
+         CALL iom_nf90_check(NF90_DEF_VAR( if90id, TRIM(cltmp(4)), NF90_DOUBLE, (/ 4    /), iom_file(kiomid)%nvid(4) ), clinfo)
+         ! update informations structure related the dimension variable we just added...
+         iom_file(kiomid)%nvars       = 4
+         iom_file(kiomid)%luld(1:4)   = (/ .FALSE., .FALSE., .FALSE., .TRUE. /)
+         iom_file(kiomid)%cn_var(1:4) = cltmp
+         iom_file(kiomid)%ndims(1:4)  = (/ 2, 2, 1, 1 /)  
+         ! trick: defined to 0 to say that dimension variables are defined but not yet written
+         iom_file(kiomid)%dimsz(1, 1)  = 0   
+         IF(lwp) WRITE(numout,*) TRIM(clinfo)//' define dimension variables done'
+      ENDIF
+      ! define the data if it is not already done
+      ! ===============
+      IF( kvid <= 0 ) THEN
+         !
+         ! NetCDF4 chunking and compression fixed settings
+         ichunkalg = 0
+         ishuffle = 1
+         ideflate = 1
+         ideflate_level = 1
+         !
+         idvar = iom_file(kiomid)%nvars + 1
+         ! are we in define mode?
+         IF( iom_file(kiomid)%irec /= -1 ) THEN   ! trick: irec used to know if the file is in define mode or not
+            CALL iom_nf90_check(NF90_REDEF( if90id ), clinfo)   ;   iom_file(kiomid)%irec = -1
+         ENDIF
+         ! variable definition
+         IF(     PRESENT(pv_r0d) ) THEN   ;   idims = 0
+         ELSEIF( PRESENT(pv_r1d) ) THEN   ;   idims = 2   ;   idimid(1:idims) = (/    3,4/)
+         ELSEIF( PRESENT(pv_r2d) ) THEN   ;   idims = 3   ;   idimid(1:idims) = (/1,2  ,4/)
+         ELSEIF( PRESENT(pv_r3d) ) THEN   ;   idims = 4   ;   idimid(1:idims) = (/1,2,3,4/)
+         ENDIF
+         IF( PRESENT(ktype) ) THEN   ! variable external type
+            SELECT CASE (ktype)
+            CASE (jp_r8)  ;   itype = NF90_DOUBLE
+            CASE (jp_r4)  ;   itype = NF90_FLOAT
+            CASE (jp_i4)  ;   itype = NF90_INT
+            CASE (jp_i2)  ;   itype = NF90_SHORT
+            CASE (jp_i1)  ;   itype = NF90_BYTE
+            CASE DEFAULT   ;   CALL ctl_stop( TRIM(clinfo)//' unknown variable type' )
+            END SELECT
+         ELSE
+            itype = NF90_DOUBLE
+         ENDIF
+         IF( PRESENT(pv_r0d) ) THEN
+            CALL iom_nf90_check(NF90_DEF_VAR( if90id, TRIM(cdvar), itype,                    &
+               &                              iom_file(kiomid)%nvid(idvar) ), clinfo )
+         ELSE
+            CALL iom_nf90_check(NF90_DEF_VAR( if90id, TRIM(cdvar), itype, idimid(1:idims),   &
+               &                              iom_file(kiomid)%nvid(idvar) ), clinfo )
+         ENDIF
+         lchunk = .false.
+         IF( snc4set%luse .AND. idims == 4 )   lchunk = .true.
+         ! update informations structure related the new variable we want to add...
+         iom_file(kiomid)%nvars         = idvar
+         iom_file(kiomid)%cn_var(idvar) = TRIM(cdvar)
+         iom_file(kiomid)%scf(idvar)    = 1.
+         iom_file(kiomid)%ofs(idvar)    = 0.
+         iom_file(kiomid)%ndims(idvar)  = idims
+         IF( .NOT. PRESENT(pv_r0d) ) THEN   ;   iom_file(kiomid)%luld(idvar) = .TRUE.
+         ELSE                               ;   iom_file(kiomid)%luld(idvar) = .FALSE.
+         ENDIF
+         DO jd = 1, idims
+            CALL iom_nf90_check(NF90_INQUIRE_DIMENSION( if90id, idimid(jd), len = iom_file(kiomid)%dimsz(jd,idvar) ), clinfo)
+            IF ( lchunk ) ichunksz(jd) = iom_file(kiomid)%dimsz(jd,idvar)
+         END DO
+         IF ( lchunk ) THEN
+            ! Calculate chunk sizes by partitioning each dimension as requested in namnc4 namelist
+            ! Disallow very small chunk sizes and prevent chunk sizes larger than each individual dimension
+            ichunksz(1) = MIN( ichunksz(1),MAX( (ichunksz(1)-1)/snc4set%ni + 1 ,16 ) ) ! Suggested default nc4set%ni=4
+            ichunksz(2) = MIN( ichunksz(2),MAX( (ichunksz(2)-1)/snc4set%nj + 1 ,16 ) ) ! Suggested default nc4set%nj=2
+            ichunksz(3) = MIN( ichunksz(3),MAX( (ichunksz(3)-1)/snc4set%nk + 1 , 1 ) ) ! Suggested default nc4set%nk=6
+            ichunksz(4) = 1                                                            ! Do not allow chunks to span the
+            !                                                                          ! unlimited dimension
+            CALL iom_nf90_check(SET_NF90_DEF_VAR_CHUNKING(if90id, idvar, ichunkalg, ichunksz), clinfo)
+            CALL iom_nf90_check(SET_NF90_DEF_VAR_DEFLATE(if90id, idvar, ishuffle, ideflate, ideflate_level), clinfo)
+            IF(lwp) WRITE(numout,*) TRIM(clinfo)//' chunked ok. Chunks sizes: ', ichunksz
+         ENDIF
+         IF(lwp) WRITE(numout,*) TRIM(clinfo)//' defined ok'
+      ELSE
+         idvar = kvid
+      ENDIF
+      !
+      ! time step kwrite : write the variable
+      IF( kt == kwrite ) THEN
+         ! are we in write mode?
+         IF( iom_file(kiomid)%irec == -1 ) THEN   ! trick: irec used to know if the file is in define mode or not
+            CALL iom_nf90_check(NF90_ENDDEF( if90id ), clinfo)   ;   iom_file(kiomid)%irec = 0
+         ENDIF
+         ! on what kind of domain must the data be written?
+         IF( PRESENT(pv_r2d) .OR. PRESENT(pv_r3d) ) THEN
+            idimsz(1:2) = iom_file(kiomid)%dimsz(1:2,idvar)
+            IF(     idimsz(1) == (nlei - nldi + 1) .AND. idimsz(2) == (nlej - nldj + 1) ) THEN
+               ix1 = nldi   ;   ix2 = nlei   ;   iy1 = nldj   ;   iy2 = nlej
+            ELSEIF( idimsz(1) == nlci              .AND. idimsz(2) == nlcj              ) THEN
+               ix1 = 1      ;   ix2 = nlci   ;   iy1 = 1      ;   iy2 = nlcj
+            ELSEIF( idimsz(1) == jpi               .AND. idimsz(2) == jpj               ) THEN
+               ix1 = 1      ;   ix2 = jpi    ;   iy1 = 1      ;   iy2 = jpj
+            ELSE 
+               CALL ctl_stop( 'iom_nf90_rp0123d: should have been an impossible case...' )
+            ENDIF
+
+            ! write dimension variables if it is not already done
+            ! =============
+            ! trick: is defined to 0 => dimension variable are defined but not yet written
+            IF( iom_file(kiomid)%dimsz(1, 1) == 0 ) THEN
+               CALL iom_nf90_check( NF90_INQ_VARID( if90id, 'nav_lon'     , idmy )         , clinfo )
+               CALL iom_nf90_check( NF90_PUT_VAR  ( if90id, idmy, glamt(ix1:ix2, iy1:iy2) ), clinfo )
+               CALL iom_nf90_check( NF90_INQ_VARID( if90id, 'nav_lat'     , idmy )         , clinfo )
+               CALL iom_nf90_check( NF90_PUT_VAR  ( if90id, idmy, gphit(ix1:ix2, iy1:iy2) ), clinfo )
+               IF(iom_file(kiomid)%nlev == jpk ) THEN 
+                  !NEMO
+                  CALL iom_nf90_check( NF90_INQ_VARID( if90id, 'nav_lev'     , idmy ), clinfo )
+                  CALL iom_nf90_check( NF90_PUT_VAR  ( if90id, idmy, gdept_1d       ), clinfo )
+               ELSE
+                  CALL iom_nf90_check( NF90_INQ_VARID( if90id, 'numcat'     , idmy ), clinfo)
+                  CALL iom_nf90_check( NF90_PUT_VAR  ( if90id, idmy, (/ (idlv, idlv = 1,iom_file(kiomid)%nlev) /)), clinfo )
+               ENDIF
+               ! +++ WRONG VALUE: to be improved but not really useful...
+               CALL iom_nf90_check( NF90_INQ_VARID( if90id, 'time_counter', idmy ), clinfo )
+               CALL iom_nf90_check( NF90_PUT_VAR( if90id, idmy, kt                      ), clinfo )   
+               ! update the values of the variables dimensions size
+               CALL iom_nf90_check( NF90_INQUIRE_DIMENSION( if90id, 1, len = iom_file(kiomid)%dimsz(1,1) ), clinfo )
+               CALL iom_nf90_check( NF90_INQUIRE_DIMENSION( if90id, 2, len = iom_file(kiomid)%dimsz(2,1) ), clinfo )
+               iom_file(kiomid)%dimsz(1:2, 2) = iom_file(kiomid)%dimsz(1:2, 1)
+               CALL iom_nf90_check( NF90_INQUIRE_DIMENSION( if90id, 3, len = iom_file(kiomid)%dimsz(1,3) ), clinfo )
+               iom_file(kiomid)%dimsz(1  , 4) = 1   ! unlimited dimension
+               IF(lwp) WRITE(numout,*) TRIM(clinfo)//' write dimension variables done'
+            ENDIF
+         ENDIF
+
+         ! write the data
+         ! =============
+         IF(     PRESENT(pv_r0d) ) THEN
+            CALL iom_nf90_check( NF90_PUT_VAR( if90id, idvar, pv_r0d                    ), clinfo )
+         ELSEIF( PRESENT(pv_r1d) ) THEN
+            CALL iom_nf90_check( NF90_PUT_VAR( if90id, idvar, pv_r1d(:)                 ), clinfo )
+         ELSEIF( PRESENT(pv_r2d) ) THEN
+            CALL iom_nf90_check( NF90_PUT_VAR( if90id, idvar, pv_r2d(ix1:ix2,iy1:iy2)   ), clinfo )
+         ELSEIF( PRESENT(pv_r3d) ) THEN
+            CALL iom_nf90_check( NF90_PUT_VAR( if90id, idvar, pv_r3d(ix1:ix2,iy1:iy2,:) ), clinfo )
+         ENDIF
+         ! add 1 to the size of the temporal dimension (not really useful...)
+         IF( iom_file(kiomid)%luld(idvar) )   iom_file(kiomid)%dimsz(iom_file(kiomid)%ndims(idvar), idvar)    &
+               &                            = iom_file(kiomid)%dimsz(iom_file(kiomid)%ndims(idvar), idvar) + 1
+         IF(lwp) WRITE(numout,*) TRIM(clinfo)//' written ok'
+      ENDIF
+      !     
+   END SUBROUTINE iom_nf90_rp0123d
+
+
+   SUBROUTINE iom_nf90_check( kstatus, cdinfo )
+      !!--------------------------------------------------------------------
+      !!                   ***  SUBROUTINE iom_nf90_check  ***
+      !!
+      !! ** Purpose :   check nf90 errors
+      !!--------------------------------------------------------------------
+      INTEGER,          INTENT(in) :: kstatus
+      CHARACTER(LEN=*), INTENT(in) :: cdinfo
+      !---------------------------------------------------------------------
+      IF(kstatus /= nf90_noerr)   CALL ctl_stop( 'iom_nf90_check : '//TRIM(nf90_strerror(kstatus)), TRIM(cdinfo) )
+   END SUBROUTINE iom_nf90_check
+
+   !!======================================================================
+END MODULE iom_nf90
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/IOM/prtctl.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/IOM/prtctl.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/IOM/prtctl.F90	(revision 9570)
@@ -0,0 +1,587 @@
+MODULE prtctl
+   !!======================================================================
+   !!                       ***  MODULE prtctl   ***
+   !! Ocean system : print all SUM trends for each processor domain
+   !!======================================================================
+   !! History :  9.0  !  05-07  (C. Talandier) original code
+   !!            3.4  !  11-11  (C. Harris) decomposition changes for running with CICE
+   !!----------------------------------------------------------------------
+   USE dom_oce          ! ocean space and time domain variables
+#if defined key_nemocice_decomp
+   USE ice_domain_size, only: nx_global, ny_global
+#endif
+   USE in_out_manager   ! I/O manager
+   USE lib_mpp          ! distributed memory computing
+
+   IMPLICIT NONE
+   PRIVATE
+
+   INTEGER , DIMENSION(:), ALLOCATABLE, SAVE ::   numid
+   INTEGER , DIMENSION(:), ALLOCATABLE, SAVE ::   nlditl , nldjtl    ! first, last indoor index for each i-domain
+   INTEGER , DIMENSION(:), ALLOCATABLE, SAVE ::   nleitl , nlejtl    ! first, last indoor index for each j-domain
+   INTEGER , DIMENSION(:), ALLOCATABLE, SAVE ::   nimpptl, njmpptl   ! i-, j-indexes for each processor
+   INTEGER , DIMENSION(:), ALLOCATABLE, SAVE ::   nlcitl , nlcjtl    ! dimensions of every subdomain
+   INTEGER , DIMENSION(:), ALLOCATABLE, SAVE ::   ibonitl, ibonjtl   !
+
+   REAL(wp), DIMENSION(:), ALLOCATABLE, SAVE ::   t_ctll , s_ctll    ! previous tracer trend values
+   REAL(wp), DIMENSION(:), ALLOCATABLE, SAVE ::   u_ctll , v_ctll    ! previous velocity trend values
+
+   INTEGER ::   ktime   ! time step
+
+   PUBLIC prt_ctl         ! called by all subroutines
+   PUBLIC prt_ctl_info    ! called by all subroutines
+   PUBLIC prt_ctl_init    ! called by opa.F90
+   PUBLIC sub_dom         ! called by opa.F90
+
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO Consortium (2010)
+   !! $Id$ 
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE prt_ctl (tab2d_1, tab3d_1, mask1, clinfo1, tab2d_2, tab3d_2,   &
+      &                                  mask2, clinfo2, kdim, clinfo3 )
+      !!----------------------------------------------------------------------
+      !!                     ***  ROUTINE prt_ctl  ***
+      !!
+      !! ** Purpose : - print sum control of 2D or 3D arrays over the same area 
+      !!                in mono and mpp case. This way can be usefull when
+      !!                debugging a new parametrization in mono or mpp. 
+      !!
+      !! ** Method  : 2 possibilities exist when setting the ln_ctl parameter to
+      !!                .true. in the ocean namelist:
+      !!              - to debug a MPI run .vs. a mono-processor one; 
+      !!                the control print will be done over each sub-domain.
+      !!                The nictl[se] and njctl[se] parameters in the namelist must 
+      !!                be set to zero and [ij]splt to the corresponding splitted
+      !!                domain in MPI along respectively i-, j- directions.
+      !!              - to debug a mono-processor run over the whole domain/a specific area; 
+      !!                in the first case the nictl[se] and njctl[se] parameters must be set
+      !!                to zero else to the indices of the area to be controled. In both cases
+      !!                isplt and jsplt must be set to 1.
+      !!              - All arguments of the above calling sequence are optional so their
+      !!                name must be explicitly typed if used. For instance if the 3D
+      !!                array tn(:,:,:) must be passed through the prt_ctl subroutine, 
+      !!                it must looks like: CALL prt_ctl(tab3d_1=tn).
+      !!
+      !!                    tab2d_1 : first 2D array
+      !!                    tab3d_1 : first 3D array
+      !!                    mask1   : mask (3D) to apply to the tab[23]d_1 array
+      !!                    clinfo1 : information about the tab[23]d_1 array
+      !!                    tab2d_2 : second 2D array
+      !!                    tab3d_2 : second 3D array
+      !!                    mask2   : mask (3D) to apply to the tab[23]d_2 array
+      !!                    clinfo2 : information about the tab[23]d_2 array
+      !!                    kdim    : k- direction for 3D arrays 
+      !!                    clinfo3 : additional information 
+      !!----------------------------------------------------------------------
+      REAL(wp), DIMENSION(:,:)  , INTENT(in), OPTIONAL ::   tab2d_1
+      REAL(wp), DIMENSION(:,:,:), INTENT(in), OPTIONAL ::   tab3d_1
+      REAL(wp), DIMENSION(:,:,:), INTENT(in), OPTIONAL ::   mask1
+      CHARACTER (len=*)         , INTENT(in), OPTIONAL ::   clinfo1
+      REAL(wp), DIMENSION(:,:)  , INTENT(in), OPTIONAL ::   tab2d_2
+      REAL(wp), DIMENSION(:,:,:), INTENT(in), OPTIONAL ::   tab3d_2
+      REAL(wp), DIMENSION(:,:,:), INTENT(in), OPTIONAL ::   mask2
+      CHARACTER (len=*)         , INTENT(in), OPTIONAL ::   clinfo2
+      INTEGER                   , INTENT(in), OPTIONAL ::   kdim
+      CHARACTER (len=*)         , INTENT(in), OPTIONAL ::   clinfo3
+      !
+      CHARACTER (len=15) :: cl2
+      INTEGER ::  jn, sind, eind, kdir,j_id
+      REAL(wp) :: zsum1, zsum2, zvctl1, zvctl2
+      REAL(wp), DIMENSION(jpi,jpj)     :: ztab2d_1, ztab2d_2
+      REAL(wp), DIMENSION(jpi,jpj,jpk) :: zmask1, zmask2, ztab3d_1, ztab3d_2
+      !!----------------------------------------------------------------------
+
+      ! Arrays, scalars initialization 
+      kdir      = jpkm1
+      cl2       = ''
+      zsum1     = 0.e0
+      zsum2     = 0.e0
+      zvctl1    = 0.e0
+      zvctl2    = 0.e0
+      ztab2d_1(:,:)   = 0.e0
+      ztab2d_2(:,:)   = 0.e0
+      ztab3d_1(:,:,:) = 0.e0
+      ztab3d_2(:,:,:) = 0.e0
+      zmask1  (:,:,:) = 1.e0
+      zmask2  (:,:,:) = 1.e0
+
+      ! Control of optional arguments
+      IF( PRESENT(clinfo2) )   cl2                  = clinfo2
+      IF( PRESENT(kdim)    )   kdir                 = kdim
+      IF( PRESENT(tab2d_1) )   ztab2d_1(:,:)        = tab2d_1(:,:)
+      IF( PRESENT(tab2d_2) )   ztab2d_2(:,:)        = tab2d_2(:,:)
+      IF( PRESENT(tab3d_1) )   ztab3d_1(:,:,1:kdir) = tab3d_1(:,:,1:kdir)
+      IF( PRESENT(tab3d_2) )   ztab3d_2(:,:,1:kdir) = tab3d_2(:,:,1:kdir)
+      IF( PRESENT(mask1)   )   zmask1  (:,:,:)      = mask1  (:,:,:)
+      IF( PRESENT(mask2)   )   zmask2  (:,:,:)      = mask2  (:,:,:)
+
+      IF( lk_mpp .AND. jpnij > 1 ) THEN       ! processor number
+         sind = narea
+         eind = narea
+      ELSE                                    ! processors total number
+         sind = 1
+         eind = ijsplt
+      ENDIF
+
+      ! Loop over each sub-domain, i.e. the total number of processors ijsplt
+      DO jn = sind, eind
+         ! Set logical unit
+         j_id = numid(jn - narea + 1)
+         ! Set indices for the SUM control
+         IF( .NOT. lsp_area ) THEN
+            IF (lk_mpp .AND. jpnij > 1)   THEN
+               nictls = MAX(  1, nlditl(jn) )
+               nictle = MIN(jpi, nleitl(jn) )
+               njctls = MAX(  1, nldjtl(jn) )
+               njctle = MIN(jpj, nlejtl(jn) )
+               ! Do not take into account the bound of the domain
+               IF( ibonitl(jn) == -1 .OR. ibonitl(jn) == 2 ) nictls = MAX(2, nictls)
+               IF( ibonjtl(jn) == -1 .OR. ibonjtl(jn) == 2 ) njctls = MAX(2, njctls)
+               IF( ibonitl(jn) ==  1 .OR. ibonitl(jn) == 2 ) nictle = MIN(nictle, nleitl(jn) - 1)
+               IF( ibonjtl(jn) ==  1 .OR. ibonjtl(jn) == 2 ) njctle = MIN(njctle, nlejtl(jn) - 1)
+            ELSE
+               nictls = MAX(  1, nimpptl(jn) - 1 + nlditl(jn) )
+               nictle = MIN(jpi, nimpptl(jn) - 1 + nleitl(jn) )
+               njctls = MAX(  1, njmpptl(jn) - 1 + nldjtl(jn) )
+               njctle = MIN(jpj, njmpptl(jn) - 1 + nlejtl(jn) )
+               ! Do not take into account the bound of the domain
+               IF( ibonitl(jn) == -1 .OR. ibonitl(jn) == 2 ) nictls = MAX(2, nictls)
+               IF( ibonjtl(jn) == -1 .OR. ibonjtl(jn) == 2 ) njctls = MAX(2, njctls)
+               IF( ibonitl(jn) ==  1 .OR. ibonitl(jn) == 2 ) nictle = MIN(nictle, nimpptl(jn) + nleitl(jn) - 2)
+               IF( ibonjtl(jn) ==  1 .OR. ibonjtl(jn) == 2 ) njctle = MIN(njctle, njmpptl(jn) + nlejtl(jn) - 2)
+            ENDIF
+         ENDIF
+
+         IF( PRESENT(clinfo3)) THEN
+            IF ( clinfo3 == 'tra' )  THEN
+               zvctl1 = t_ctll(jn)
+               zvctl2 = s_ctll(jn)
+            ELSEIF ( clinfo3 == 'dyn' )   THEN
+               zvctl1 = u_ctll(jn)
+               zvctl2 = v_ctll(jn)
+            ENDIF
+         ENDIF
+
+         ! Compute the sum control
+         ! 2D arrays
+         IF( PRESENT(tab2d_1) )   THEN
+            zsum1 = SUM( ztab2d_1(nictls:nictle,njctls:njctle)*zmask1(nictls:nictle,njctls:njctle,1) )
+            zsum2 = SUM( ztab2d_2(nictls:nictle,njctls:njctle)*zmask2(nictls:nictle,njctls:njctle,1) )
+         ENDIF
+
+         ! 3D arrays
+         IF( PRESENT(tab3d_1) )   THEN
+            zsum1 = SUM( ztab3d_1(nictls:nictle,njctls:njctle,1:kdir)*zmask1(nictls:nictle,njctls:njctle,1:kdir) )
+            zsum2 = SUM( ztab3d_2(nictls:nictle,njctls:njctle,1:kdir)*zmask2(nictls:nictle,njctls:njctle,1:kdir) )
+         ENDIF
+
+         ! Print the result
+         IF( PRESENT(clinfo3) )   THEN
+            WRITE(j_id,FMT='(a,D23.16,3x,a,D23.16)')clinfo1, zsum1-zvctl1, cl2, zsum2-zvctl2
+            SELECT CASE( clinfo3 )
+            CASE ( 'tra-ta' ) 
+               t_ctll(jn) = zsum1
+            CASE ( 'tra' ) 
+                t_ctll(jn) = zsum1
+                s_ctll(jn) = zsum2
+            CASE ( 'dyn' ) 
+                u_ctll(jn) = zsum1
+                v_ctll(jn) = zsum2 
+            END SELECT
+         ELSEIF ( PRESENT(clinfo2) .OR. PRESENT(tab2d_2) .OR. PRESENT(tab3d_2) )   THEN
+            WRITE(j_id,FMT='(a,D23.16,3x,a,D23.16)')clinfo1, zsum1, cl2, zsum2
+         ELSE
+            WRITE(j_id,FMT='(a,D23.16)')clinfo1, zsum1
+         ENDIF
+
+      ENDDO
+      !
+   END SUBROUTINE prt_ctl
+
+
+   SUBROUTINE prt_ctl_info (clinfo1, ivar1, clinfo2, ivar2, itime)
+      !!----------------------------------------------------------------------
+      !!                     ***  ROUTINE prt_ctl_info  ***
+      !!
+      !! ** Purpose : - print information without any computation
+      !!
+      !! ** Action  : - input arguments
+      !!                    clinfo1 : information about the ivar1
+      !!                    ivar1   : value to print
+      !!                    clinfo2 : information about the ivar2
+      !!                    ivar2   : value to print
+      !!----------------------------------------------------------------------
+      CHARACTER (len=*), INTENT(in)           ::   clinfo1
+      INTEGER          , INTENT(in), OPTIONAL ::   ivar1
+      CHARACTER (len=*), INTENT(in), OPTIONAL ::   clinfo2
+      INTEGER          , INTENT(in), OPTIONAL ::   ivar2
+      INTEGER          , INTENT(in), OPTIONAL ::   itime
+      !
+      INTEGER :: jn, sind, eind, iltime, j_id
+      !!----------------------------------------------------------------------
+
+      IF( lk_mpp .AND. jpnij > 1 ) THEN       ! processor number
+         sind = narea
+         eind = narea
+      ELSE                                    ! total number of processors
+         sind = 1
+         eind = ijsplt
+      ENDIF
+
+      ! Set to zero arrays at each new time step
+      IF( PRESENT(itime) )   THEN
+         iltime = itime
+         IF( iltime > ktime )   THEN
+            t_ctll(:) = 0.e0   ;   s_ctll(:) = 0.e0
+            u_ctll(:) = 0.e0   ;   v_ctll(:) = 0.e0
+            ktime = iltime
+         ENDIF
+      ENDIF
+
+      ! Loop over each sub-domain, i.e. number of processors ijsplt
+      DO jn = sind, eind
+         !
+         j_id = numid(jn - narea + 1)         ! Set logical unit
+         !
+         IF( PRESENT(ivar1) .AND. PRESENT(clinfo2) .AND. PRESENT(ivar2) )   THEN
+            WRITE(j_id,*)clinfo1, ivar1, clinfo2, ivar2
+         ELSEIF ( PRESENT(ivar1) .AND. PRESENT(clinfo2) .AND. .NOT. PRESENT(ivar2) )   THEN
+            WRITE(j_id,*)clinfo1, ivar1, clinfo2
+         ELSEIF ( PRESENT(ivar1) .AND. .NOT. PRESENT(clinfo2) .AND. PRESENT(ivar2) )   THEN
+            WRITE(j_id,*)clinfo1, ivar1, ivar2
+         ELSEIF ( PRESENT(ivar1) .AND. .NOT. PRESENT(clinfo2) .AND. .NOT. PRESENT(ivar2) )   THEN
+            WRITE(j_id,*)clinfo1, ivar1
+         ELSE
+            WRITE(j_id,*)clinfo1
+         ENDIF
+         !
+      END DO
+      !
+   END SUBROUTINE prt_ctl_info
+
+
+   SUBROUTINE prt_ctl_init
+      !!----------------------------------------------------------------------
+      !!                     ***  ROUTINE prt_ctl_init  ***
+      !!
+      !! ** Purpose :   open ASCII files & compute indices
+      !!----------------------------------------------------------------------
+      INTEGER ::   jn, sind, eind, j_id
+      CHARACTER (len=28) :: clfile_out
+      CHARACTER (len=23) :: clb_name
+      CHARACTER (len=19) :: cl_run
+      !!----------------------------------------------------------------------
+
+      ! Allocate arrays
+      ALLOCATE( nlditl(ijsplt) , nleitl(ijsplt) , nimpptl(ijsplt) , ibonitl(ijsplt) ,   &
+         &      nldjtl(ijsplt) , nlejtl(ijsplt) , njmpptl(ijsplt) , ibonjtl(ijsplt) ,   &
+         &      nlcitl(ijsplt) , t_ctll(ijsplt) , u_ctll (ijsplt) ,                     &
+         &      nlcjtl(ijsplt) , s_ctll(ijsplt) , v_ctll (ijsplt)                       )
+
+      ! Initialization 
+      t_ctll(:) = 0.e0
+      s_ctll(:) = 0.e0
+      u_ctll(:) = 0.e0
+      v_ctll(:) = 0.e0
+      ktime = 1
+
+      IF( lk_mpp .AND. jpnij > 1 ) THEN
+         sind = narea
+         eind = narea
+         clb_name = "('mpp.output_',I4.4)"
+         cl_run = 'MULTI processor run'
+         ! use indices for each area computed by mpp_init subroutine
+         nlditl(1:jpnij) = nldit(:) 
+         nleitl(1:jpnij) = nleit(:) 
+         nldjtl(1:jpnij) = nldjt(:) 
+         nlejtl(1:jpnij) = nlejt(:) 
+         !
+         nimpptl(1:jpnij) = nimppt(:)
+         njmpptl(1:jpnij) = njmppt(:)
+         !
+         nlcitl(1:jpnij) = nlcit(:)
+         nlcjtl(1:jpnij) = nlcjt(:)
+         !
+         ibonitl(1:jpnij) = ibonit(:)
+         ibonjtl(1:jpnij) = ibonjt(:)
+      ELSE
+         sind = 1
+         eind = ijsplt
+         clb_name = "('mono.output_',I4.4)"
+         cl_run = 'MONO processor run '
+         ! compute indices for each area as done in mpp_init subroutine
+         CALL sub_dom
+      ENDIF
+
+      ALLOCATE( numid(eind-sind+1) )
+
+      DO jn = sind, eind
+         WRITE(clfile_out,FMT=clb_name) jn-1
+         CALL ctl_opn( numid(jn -narea + 1), clfile_out, 'REPLACE', 'FORMATTED', 'SEQUENTIAL', 1, numout, .FALSE. )
+         j_id = numid(jn -narea + 1)
+         WRITE(j_id,*)
+         WRITE(j_id,*) '                 L O D Y C - I P S L'
+         WRITE(j_id,*) '                     O P A model'
+         WRITE(j_id,*) '            Ocean General Circulation Model'
+         WRITE(j_id,*) '               version OPA 9.0  (2005) '
+         WRITE(j_id,*)
+         WRITE(j_id,*) '                   PROC number: ', jn
+         WRITE(j_id,*)
+         WRITE(j_id,FMT="(19x,a20)")cl_run
+
+         ! Print the SUM control indices
+         IF( .NOT. lsp_area )   THEN
+            nictls = nimpptl(jn) + nlditl(jn) - 1
+            nictle = nimpptl(jn) + nleitl(jn) - 1
+            njctls = njmpptl(jn) + nldjtl(jn) - 1
+            njctle = njmpptl(jn) + nlejtl(jn) - 1
+         ENDIF
+         WRITE(j_id,*) 
+         WRITE(j_id,*) 'prt_ctl :  Sum control indices'
+         WRITE(j_id,*) '~~~~~~~'
+         WRITE(j_id,*)
+         WRITE(j_id,9000)'                                nlej   = ', nlejtl(jn), '              '
+         WRITE(j_id,9000)'                  ------------- njctle = ', njctle, ' -------------'
+         WRITE(j_id,9001)'                  |                                       |'
+         WRITE(j_id,9001)'                  |                                       |'
+         WRITE(j_id,9001)'                  |                                       |'
+         WRITE(j_id,9002)'           nictls = ', nictls,  '                           nictle = ', nictle
+         WRITE(j_id,9002)'           nldi   = ', nlditl(jn),  '                           nlei   = ', nleitl(jn)
+         WRITE(j_id,9001)'                  |                                       |'
+         WRITE(j_id,9001)'                  |                                       |'
+         WRITE(j_id,9001)'                  |                                       |'
+         WRITE(j_id,9004)'  njmpp  = ',njmpptl(jn),'   ------------- njctls = ', njctls, ' -------------'
+         WRITE(j_id,9003)'           nimpp  = ', nimpptl(jn), '        nldj   = ', nldjtl(jn), '              '
+         WRITE(j_id,*)
+         WRITE(j_id,*)
+
+9000     FORMAT(a41,i4.4,a14)
+9001     FORMAT(a59)
+9002     FORMAT(a20,i4.4,a36,i3.3)
+9003     FORMAT(a20,i4.4,a17,i4.4)
+9004     FORMAT(a11,i4.4,a26,i4.4,a14)
+      END DO
+      !
+   END SUBROUTINE prt_ctl_init
+
+
+   SUBROUTINE sub_dom
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE sub_dom  ***
+      !!                    
+      !! ** Purpose :   Lay out the global domain over processors. 
+      !!                CAUTION: 
+      !!                This part has been extracted from the mpp_init
+      !!                subroutine and names of variables/arrays have been 
+      !!                slightly changed to avoid confusion but the computation
+      !!                is exactly the same. Any modification about indices of
+      !!                each sub-domain in the mppini.F90 module should be reported 
+      !!                here.
+      !!
+      !! ** Method  :   Global domain is distributed in smaller local domains.
+      !!                Periodic condition is a function of the local domain position
+      !!                (global boundary or neighbouring domain) and of the global
+      !!                periodic
+      !!                Type :         jperio global periodic condition
+      !!                               nperio local  periodic condition
+      !!
+      !! ** Action  : - set domain parameters
+      !!                    nimpp     : longitudinal index 
+      !!                    njmpp     : latitudinal  index
+      !!                    nperio    : lateral condition type 
+      !!                    narea     : number for local area
+      !!                    nlcil      : first dimension
+      !!                    nlcjl      : second dimension
+      !!                    nbondil    : mark for "east-west local boundary"
+      !!                    nbondjl    : mark for "north-south local boundary"
+      !!
+      !! History :
+      !!        !  94-11  (M. Guyon)  Original code
+      !!        !  95-04  (J. Escobar, M. Imbard)
+      !!        !  98-02  (M. Guyon)  FETI method
+      !!        !  98-05  (M. Imbard, J. Escobar, L. Colombet )  SHMEM and MPI versions
+      !!   8.5  !  02-08  (G. Madec)  F90 : free form
+      !!----------------------------------------------------------------------
+      INTEGER ::   ji, jj, jn               ! dummy loop indices
+      INTEGER ::   &
+         ii, ij,                         &  ! temporary integers
+         irestil, irestjl,               &  !    "          "
+         ijpi  , ijpj, nlcil,            &  ! temporary logical unit
+         nlcjl , nbondil, nbondjl,       &
+         nrecil, nrecjl, nldil, nleil, nldjl, nlejl
+
+      INTEGER, DIMENSION(jpi,jpj) ::   iimpptl, ijmpptl, ilcitl, ilcjtl   ! workspace
+      REAL(wp) ::   zidom, zjdom            ! temporary scalars
+      INTEGER ::   inum                     ! local logical unit
+      !!----------------------------------------------------------------------
+
+      !
+      !
+      !  1. Dimension arrays for subdomains
+      ! -----------------------------------
+      !  Computation of local domain sizes ilcitl() ilcjtl()
+      !  These dimensions depend on global sizes isplt,jsplt and jpiglo,jpjglo
+      !  The subdomains are squares leeser than or equal to the global
+      !  dimensions divided by the number of processors minus the overlap
+      !  array (cf. par_oce.F90).
+
+#if defined key_nemocice_decomp
+      ijpi = ( nx_global+2-2*nn_hls + (isplt-1) ) / isplt + 2*nn_hls
+      ijpj = ( ny_global+2-2*nn_hls + (jsplt-1) ) / jsplt + 2*nn_hls 
+#else
+      ijpi = ( jpiglo-2*nn_hls + (isplt-1) ) / isplt + 2*nn_hls
+      ijpj = ( jpjglo-2*nn_hls + (jsplt-1) ) / jsplt + 2*nn_hls
+#endif
+
+
+      nrecil  = 2 * nn_hls
+      nrecjl  = 2 * nn_hls
+      irestil = MOD( jpiglo - nrecil , isplt )
+      irestjl = MOD( jpjglo - nrecjl , jsplt )
+
+      IF(  irestil == 0 )   irestil = isplt
+#if defined key_nemocice_decomp
+
+      ! In order to match CICE the size of domains in NEMO has to be changed
+      ! The last line of blocks (west) will have fewer points 
+      DO jj = 1, jsplt 
+         DO ji=1, isplt-1 
+            ilcitl(ji,jj) = ijpi 
+         END DO 
+         ilcitl(isplt,jj) = jpiglo - (isplt - 1) * (ijpi - nrecil)
+      END DO 
+
+#else 
+
+      DO jj = 1, jsplt
+         DO ji = 1, irestil
+            ilcitl(ji,jj) = ijpi
+         END DO
+         DO ji = irestil+1, isplt
+            ilcitl(ji,jj) = ijpi -1
+         END DO
+      END DO
+
+#endif
+      
+      IF( irestjl == 0 )   irestjl = jsplt
+#if defined key_nemocice_decomp 
+
+      ! Same change to domains in North-South direction as in East-West. 
+      DO ji = 1, isplt 
+         DO jj=1, jsplt-1 
+            ilcjtl(ji,jj) = ijpj 
+         END DO 
+         ilcjtl(ji,jsplt) = jpjglo - (jsplt - 1) * (ijpj - nrecjl)
+      END DO 
+
+#else 
+
+      DO ji = 1, isplt
+         DO jj = 1, irestjl
+            ilcjtl(ji,jj) = ijpj
+         END DO
+         DO jj = irestjl+1, jsplt
+            ilcjtl(ji,jj) = ijpj -1
+         END DO
+      END DO
+
+#endif
+      zidom = nrecil
+      DO ji = 1, isplt
+         zidom = zidom + ilcitl(ji,1) - nrecil
+      END DO
+      IF(lwp) WRITE(numout,*)
+      IF(lwp) WRITE(numout,*)' sum ilcitl(i,1) = ', zidom, ' jpiglo = ', jpiglo
+      
+      zjdom = nrecjl
+      DO jj = 1, jsplt
+         zjdom = zjdom + ilcjtl(1,jj) - nrecjl
+      END DO
+      IF(lwp) WRITE(numout,*)' sum ilcitl(1,j) = ', zjdom, ' jpjglo = ', jpjglo
+      IF(lwp) WRITE(numout,*)
+      
+
+      !  2. Index arrays for subdomains
+      ! -------------------------------
+
+      iimpptl(:,:) = 1
+      ijmpptl(:,:) = 1
+      
+      IF( isplt > 1 ) THEN
+         DO jj = 1, jsplt
+            DO ji = 2, isplt
+               iimpptl(ji,jj) = iimpptl(ji-1,jj) + ilcitl(ji-1,jj) - nrecil
+            END DO
+         END DO
+      ENDIF
+
+      IF( jsplt > 1 ) THEN
+         DO jj = 2, jsplt
+            DO ji = 1, isplt
+               ijmpptl(ji,jj) = ijmpptl(ji,jj-1)+ilcjtl(ji,jj-1)-nrecjl
+            END DO
+         END DO
+      ENDIF
+      
+      ! 3. Subdomain description
+      ! ------------------------
+
+      DO jn = 1, ijsplt
+         ii = 1 + MOD( jn-1, isplt )
+         ij = 1 + (jn-1) / isplt
+         nimpptl(jn) = iimpptl(ii,ij)
+         njmpptl(jn) = ijmpptl(ii,ij)
+         nlcitl (jn) = ilcitl (ii,ij)     
+         nlcil       = nlcitl (jn)     
+         nlcjtl (jn) = ilcjtl (ii,ij)     
+         nlcjl       = nlcjtl (jn)
+         nbondjl = -1                                    ! general case
+         IF( jn   >  isplt          )   nbondjl = 0      ! first row of processor
+         IF( jn   >  (jsplt-1)*isplt )  nbondjl = 1     ! last  row of processor
+         IF( jsplt == 1             )   nbondjl = 2      ! one processor only in j-direction
+         ibonjtl(jn) = nbondjl
+         
+         nbondil = 0                                     ! 
+         IF( MOD( jn, isplt ) == 1 )   nbondil = -1      !
+         IF( MOD( jn, isplt ) == 0 )   nbondil =  1      !
+         IF( isplt            == 1 )   nbondil =  2      ! one processor only in i-direction
+         ibonitl(jn) = nbondil
+         
+         nldil =  1   + nn_hls
+         nleil = nlcil - nn_hls
+         IF( nbondil == -1 .OR. nbondil == 2 )   nldil = 1
+         IF( nbondil ==  1 .OR. nbondil == 2 )   nleil = nlcil
+         nldjl =  1   + nn_hls
+         nlejl = nlcjl - nn_hls
+         IF( nbondjl == -1 .OR. nbondjl == 2 )   nldjl = 1
+         IF( nbondjl ==  1 .OR. nbondjl == 2 )   nlejl = nlcjl
+         nlditl(jn) = nldil
+         nleitl(jn) = nleil
+         nldjtl(jn) = nldjl
+         nlejtl(jn) = nlejl
+      END DO
+      !
+      ! Save processor layout in layout_prtctl.dat file 
+      IF(lwp) THEN
+         CALL ctl_opn( inum, 'layout_prtctl.dat', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE., narea )
+         WRITE(inum,'(a)') 'nproc nlcil nlcjl nldil nldjl nleil nlejl nimpptl njmpptl ibonitl ibonjtl'
+         !
+         DO jn = 1, ijsplt
+            WRITE(inum,'(i5,6i6,4i8)') jn-1,nlcitl(jn),  nlcjtl(jn), &
+               &                            nlditl(jn),  nldjtl(jn), &
+               &                            nleitl(jn),  nlejtl(jn), &
+               &                           nimpptl(jn), njmpptl(jn), &
+               &                           ibonitl(jn), ibonjtl(jn)
+         END DO
+         CLOSE(inum)   
+      END IF
+      !
+      !
+   END SUBROUTINE sub_dom
+
+   !!======================================================================
+END MODULE prtctl
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/IOM/restart.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/IOM/restart.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/IOM/restart.F90	(revision 9570)
@@ -0,0 +1,314 @@
+MODULE restart
+   !!======================================================================
+   !!                     ***  MODULE  restart  ***
+   !! Ocean restart :  write the ocean restart file
+   !!======================================================================
+   !! History :  OPA  !  1999-11  (M. Imbard)  Original code
+   !!   NEMO     1.0  !  2002-08  (G. Madec)  F90: Free form
+   !!            2.0  !  2006-07  (S. Masson)  use IOM for restart
+   !!            3.3  !  2010-04  (M. Leclair, G. Madec)  modified LF-RA
+   !!            - -  !  2010-10  (C. Ethe, G. Madec) TRC-TRA merge (T-S in 4D)
+   !!            3.7  !  2014-01  (G. Madec) suppression of curl and hdiv from the restart
+   !!             -   !  2014-12  (G. Madec) remove KPP scheme
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   rst_opn    : open the ocean restart file
+   !!   rst_write  : write the ocean restart file
+   !!   rst_read   : read the ocean restart file
+   !!----------------------------------------------------------------------
+   USE oce             ! ocean dynamics and tracers 
+   USE dom_oce         ! ocean space and time domain
+   USE sbc_ice         ! only lk_lim3 
+   USE phycst          ! physical constants
+   USE eosbn2          ! equation of state            (eos bn2 routine)
+   USE trdmxl_oce      ! ocean active mixed layer tracers trends variables
+   !
+   USE in_out_manager  ! I/O manager
+   USE iom             ! I/O module
+   USE diurnal_bulk
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   rst_opn         ! routine called by step module
+   PUBLIC   rst_write       ! routine called by step module
+   PUBLIC   rst_read        ! routine called by istate module
+   PUBLIC   rst_read_open   ! routine called in rst_read and (possibly) in dom_vvl_init
+
+   !! * Substitutions
+#  include "vectopt_loop_substitute.h90"
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO Consortium (2010)
+   !! $Id$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE rst_opn( kt )
+      !!---------------------------------------------------------------------
+      !!                   ***  ROUTINE rst_opn  ***
+      !!                     
+      !! ** Purpose : + initialization (should be read in the namelist) of nitrst 
+      !!              + open the restart when we are one time step before nitrst
+      !!                   - restart header is defined when kt = nitrst-1
+      !!                   - restart data  are written when kt = nitrst
+      !!              + define lrst_oce to .TRUE. when we need to define or write the restart
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT(in) ::   kt     ! ocean time-step
+      !!
+      CHARACTER(LEN=20)   ::   clkt     ! ocean time-step deine as a character
+      CHARACTER(LEN=50)   ::   clname   ! ocean output restart file name
+      CHARACTER(lc)       ::   clpath   ! full path to ocean output restart file
+      CHARACTER(LEN=52)   ::   clpname   ! ocean output restart file name including prefix for AGRIF
+      CHARACTER(LEN=256)  ::   clinfo    ! info character
+      !!----------------------------------------------------------------------
+      !
+      IF( kt == nit000 ) THEN   ! default definitions
+         lrst_oce = .FALSE.   
+         IF( ln_rst_list ) THEN
+            nrst_lst = 1
+            nitrst = nstocklist( nrst_lst )
+         ELSE
+            nitrst = nitend
+         ENDIF
+      ENDIF
+
+      ! frequency-based restart dumping (nn_stock)
+      IF( .NOT. ln_rst_list .AND. MOD( kt - 1, nstock ) == 0 ) THEN   
+         ! we use kt - 1 and not kt - nit000 to keep the same periodicity from the beginning of the experiment
+         nitrst = kt + nstock - 1                  ! define the next value of nitrst for restart writing
+         IF( nitrst > nitend )   nitrst = nitend   ! make sure we write a restart at the end of the run
+      ENDIF
+      ! to get better performances with NetCDF format:
+      ! we open and define the ocean restart file one time step before writing the data (-> at nitrst - 1)
+      ! except if we write ocean restart files every time step or if an ocean restart file was writen at nitend - 1
+      IF( kt == nitrst - 1 .OR. nstock == 1 .OR. ( kt == nitend .AND. .NOT. lrst_oce ) ) THEN
+         IF( nitrst <= nitend .AND. nitrst > 0 ) THEN 
+            ! beware of the format used to write kt (default is i8.8, that should be large enough...)
+            IF( nitrst > 999999999 ) THEN   ;   WRITE(clkt, *       ) nitrst
+            ELSE                            ;   WRITE(clkt, '(i8.8)') nitrst
+            ENDIF
+            ! create the file
+            clname = TRIM(cexper)//"_"//TRIM(ADJUSTL(clkt))//"_"//TRIM(cn_ocerst_out)
+            clpath = TRIM(cn_ocerst_outdir)
+            IF( clpath(LEN_TRIM(clpath):) /= '/' ) clpath = TRIM(clpath) // '/'
+            IF(lwp) THEN
+               WRITE(numout,*)
+               IF(.NOT.lwxios) THEN
+                  SELECT CASE ( jprstlib )
+                  CASE DEFAULT         ;   WRITE(numout,*)                            &
+                      '             open ocean restart NetCDF file: ',TRIM(clpath)//TRIM(clname)
+                  END SELECT
+                  IF ( snc4set%luse )      WRITE(numout,*) '             opened for NetCDF4 chunking and compression'
+                  IF( kt == nitrst - 1 ) THEN   ;   WRITE(numout,*) '             kt = nitrst - 1 = ', kt
+                  ELSE                          ;   WRITE(numout,*) '             kt = '             , kt
+                  ENDIF
+               ENDIF
+            ENDIF
+            !
+            IF(.NOT.lwxios) THEN
+               CALL iom_open( TRIM(clpath)//TRIM(clname), numrow, ldwrt = .TRUE., kiolib = jprstlib )
+            ELSE
+#if defined key_iomput
+               cwxios_context = "rstw_"//TRIM(ADJUSTL(clkt))
+               IF( TRIM(Agrif_CFixed()) == '0' ) THEN
+                  clpname = clname
+               ELSE
+                  clpname = TRIM(Agrif_CFixed())//"_"//clname   
+               ENDIF
+               CALL iom_init( cwxios_context, TRIM(clpath)//TRIM(clpname))
+               CALL xios_update_calendar(nitrst)
+               CALL iom_swap(      cxios_context          )
+#else
+               clinfo = 'Can not use XIOS in rst_opn'
+               CALL ctl_stop(TRIM(clinfo))
+#endif
+            ENDIF
+            lrst_oce = .TRUE.
+         ENDIF
+      ENDIF
+      !
+   END SUBROUTINE rst_opn
+
+
+   SUBROUTINE rst_write( kt )
+      !!---------------------------------------------------------------------
+      !!                   ***  ROUTINE rstwrite  ***
+      !!                     
+      !! ** Purpose :   Write restart fields in the format corresponding to jprstlib
+      !!
+      !! ** Method  :   Write in numrow when kt == nitrst in NetCDF
+      !!              file, save fields which are necessary for restart
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT(in) ::   kt   ! ocean time-step
+      !!----------------------------------------------------------------------
+                     IF(lwxios) CALL iom_swap(      cwxios_context          )
+                     CALL iom_rstput( kt, nitrst, numrow, 'rdt'    , rdt       , ldxios = lwxios)   ! dynamics time step
+
+      IF ( .NOT. ln_diurnal_only ) THEN
+                     CALL iom_rstput( kt, nitrst, numrow, 'ub'     , ub, ldxios = lwxios        )     ! before fields
+                     CALL iom_rstput( kt, nitrst, numrow, 'vb'     , vb, ldxios = lwxios        )
+                     CALL iom_rstput( kt, nitrst, numrow, 'tb'     , tsb(:,:,:,jp_tem), ldxios = lwxios )
+                     CALL iom_rstput( kt, nitrst, numrow, 'sb'     , tsb(:,:,:,jp_sal), ldxios = lwxios )
+                     CALL iom_rstput( kt, nitrst, numrow, 'sshb'   , sshb, ldxios = lwxios      )
+                     !
+                     CALL iom_rstput( kt, nitrst, numrow, 'un'     , un, ldxios = lwxios        )     ! now fields
+                     CALL iom_rstput( kt, nitrst, numrow, 'vn'     , vn, ldxios = lwxios        )
+                     CALL iom_rstput( kt, nitrst, numrow, 'tn'     , tsn(:,:,:,jp_tem), ldxios = lwxios )
+                     CALL iom_rstput( kt, nitrst, numrow, 'sn'     , tsn(:,:,:,jp_sal), ldxios = lwxios )
+                     CALL iom_rstput( kt, nitrst, numrow, 'sshn'   , sshn, ldxios = lwxios      )
+                     CALL iom_rstput( kt, nitrst, numrow, 'rhop'   , rhop, ldxios = lwxios      )
+                  ! extra variable needed for the ice sheet coupling
+                  IF ( ln_iscpl ) THEN 
+                     CALL iom_rstput( kt, nitrst, numrow, 'tmask'  , tmask, ldxios = lwxios ) ! need to extrapolate T/S
+                     CALL iom_rstput( kt, nitrst, numrow, 'umask'  , umask, ldxios = lwxios ) ! need to correct barotropic velocity
+                     CALL iom_rstput( kt, nitrst, numrow, 'vmask'  , vmask, ldxios = lwxios ) ! need to correct barotropic velocity
+                     CALL iom_rstput( kt, nitrst, numrow, 'smask'  , ssmask, ldxios = lwxios) ! need to correct barotropic velocity
+                     CALL iom_rstput( kt, nitrst, numrow, 'e3t_n', e3t_n(:,:,:), ldxios = lwxios )   ! need to compute temperature correction
+                     CALL iom_rstput( kt, nitrst, numrow, 'e3u_n', e3u_n(:,:,:), ldxios = lwxios )   ! need to compute bt conservation
+                     CALL iom_rstput( kt, nitrst, numrow, 'e3v_n', e3v_n(:,:,:), ldxios = lwxios )   ! need to compute bt conservation
+                     CALL iom_rstput( kt, nitrst, numrow, 'gdepw_n', gdepw_n(:,:,:), ldxios = lwxios ) ! need to compute extrapolation if vvl
+                  END IF
+      ENDIF
+      
+      IF (ln_diurnal) CALL iom_rstput( kt, nitrst, numrow, 'Dsst', x_dsst, ldxios = lwxios )  
+      IF(lwxios) CALL iom_swap(      cxios_context          )
+      IF( kt == nitrst ) THEN
+         IF(.NOT.lwxios) THEN
+            CALL iom_close( numrow )     ! close the restart file (only at last time step)
+         ELSE
+            CALL iom_context_finalize(      cwxios_context          )
+         ENDIF
+!!gm         IF( .NOT. lk_trdmld )   lrst_oce = .FALSE.
+!!gm  not sure what to do here   ===>>>  ask to Sebastian
+         lrst_oce = .FALSE.
+            IF( ln_rst_list ) THEN
+               nrst_lst = MIN(nrst_lst + 1, SIZE(nstocklist,1))
+               nitrst = nstocklist( nrst_lst )
+            ENDIF
+      ENDIF
+      !
+   END SUBROUTINE rst_write
+
+
+   SUBROUTINE rst_read_open
+      !!---------------------------------------------------------------------- 
+      !!                   ***  ROUTINE rst_read_open  ***
+      !! 
+      !! ** Purpose :   Open read files for restart (format fixed by jprstlib )
+      !! 
+      !! ** Method  :   Use a non-zero, positive value of numror to assess whether or not
+      !!                the file has already been opened
+      !!----------------------------------------------------------------------
+      INTEGER        ::   jlibalt = jprstlib
+      LOGICAL        ::   llok
+      CHARACTER(lc)  ::   clpath   ! full path to ocean output restart file
+      !!----------------------------------------------------------------------
+      !
+      IF( numror <= 0 ) THEN
+         IF(lwp) THEN                                             ! Contol prints
+            WRITE(numout,*)
+            SELECT CASE ( jprstlib )
+            CASE ( jpnf90    )   ;   WRITE(numout,*) 'rst_read : read oce NetCDF restart file'
+            END SELECT
+            IF ( snc4set%luse )      WRITE(numout,*) 'rst_read : configured with NetCDF4 support'
+            WRITE(numout,*) '~~~~~~~~'
+         ENDIF
+         lxios_sini = .FALSE.
+         clpath = TRIM(cn_ocerst_indir)
+         IF( clpath(LEN_TRIM(clpath):) /= '/' ) clpath = TRIM(clpath) // '/'
+         CALL iom_open( TRIM(clpath)//cn_ocerst_in, numror, kiolib = jlibalt )
+! are we using XIOS to read the data? Part above will have to modified once XIOS
+! can handle checking if variable is in the restart file (there will be no need to open
+! restart)
+         IF(.NOT.lxios_set) lrxios = lrxios.AND.lxios_sini
+         IF( lrxios) THEN
+             crxios_context = 'nemo_rst'
+             IF( .NOT.lxios_set ) THEN
+                 IF(lwp) WRITE(numout,*) 'Enable restart reading by XIOS'
+                 CALL iom_init( crxios_context )
+                 lxios_set = .TRUE.
+             ENDIF
+         ENDIF
+         IF( TRIM(Agrif_CFixed()) /= '0' .AND. lrxios) THEN
+             CALL iom_init( crxios_context )
+             IF(lwp) WRITE(numout,*) 'Enable restart reading by XIOS for AGRIF'
+             lxios_set = .TRUE.
+         ENDIF 
+      ENDIF
+
+   END SUBROUTINE rst_read_open
+
+
+   SUBROUTINE rst_read
+      !!---------------------------------------------------------------------- 
+      !!                   ***  ROUTINE rst_read  ***
+      !! 
+      !! ** Purpose :   Read files for restart (format fixed by jprstlib )
+      !! 
+      !! ** Method  :   Read in restart.nc file fields which are necessary for restart
+      !!----------------------------------------------------------------------
+      REAL(wp) ::   zrdt
+      INTEGER  ::   jk
+      REAL(wp), DIMENSION(jpi, jpj, jpk) :: w3d
+      !!----------------------------------------------------------------------
+
+      CALL rst_read_open           ! open restart for reading (if not already opened)
+
+      ! Check dynamics and tracer time-step consistency and force Euler restart if changed
+      IF( iom_varid( numror, 'rdt', ldstop = .FALSE. ) > 0 )   THEN
+         CALL iom_get( numror, 'rdt', zrdt, ldxios = lrxios )
+         IF( zrdt /= rdt )   neuler = 0
+      ENDIF
+
+      ! Diurnal DSST 
+      IF( ln_diurnal ) CALL iom_get( numror, jpdom_autoglo, 'Dsst' , x_dsst, ldxios = lrxios ) 
+      IF ( ln_diurnal_only ) THEN 
+         IF(lwp) WRITE( numout, * ) &
+         &   "rst_read:- ln_diurnal_only set, setting rhop=rau0" 
+         rhop = rau0
+         CALL iom_get( numror, jpdom_autoglo, 'tn'     , w3d, ldxios = lrxios ) 
+         tsn(:,:,1,jp_tem) = w3d(:,:,1)
+         RETURN 
+      ENDIF  
+      
+      IF( iom_varid( numror, 'ub', ldstop = .FALSE. ) > 0 ) THEN
+         CALL iom_get( numror, jpdom_autoglo, 'ub'     , ub, ldxios = lrxios                )   ! before fields
+         CALL iom_get( numror, jpdom_autoglo, 'vb'     , vb, ldxios = lrxios                )
+         CALL iom_get( numror, jpdom_autoglo, 'tb'     , tsb(:,:,:,jp_tem), ldxios = lrxios )
+         CALL iom_get( numror, jpdom_autoglo, 'sb'     , tsb(:,:,:,jp_sal), ldxios = lrxios )
+         CALL iom_get( numror, jpdom_autoglo, 'sshb'   , sshb, ldxios = lrxios              )
+      ELSE
+         neuler = 0
+      ENDIF
+      !
+      CALL iom_get( numror, jpdom_autoglo, 'un'     , un, ldxios = lrxios )   ! now    fields
+      CALL iom_get( numror, jpdom_autoglo, 'vn'     , vn, ldxios = lrxios )
+      CALL iom_get( numror, jpdom_autoglo, 'tn'     , tsn(:,:,:,jp_tem), ldxios = lrxios )
+      CALL iom_get( numror, jpdom_autoglo, 'sn'     , tsn(:,:,:,jp_sal), ldxios = lrxios )
+      CALL iom_get( numror, jpdom_autoglo, 'sshn'   , sshn, ldxios = lrxios )
+      IF( iom_varid( numror, 'rhop', ldstop = .FALSE. ) > 0 ) THEN
+         CALL iom_get( numror, jpdom_autoglo, 'rhop'   , rhop, ldxios = lrxios )   ! now    potential density
+      ELSE
+         CALL eos( tsn, rhd, rhop, gdept_n(:,:,:) )   
+      ENDIF
+      !
+      IF( neuler == 0 ) THEN                                  ! Euler restart (neuler=0)
+         tsb  (:,:,:,:) = tsn  (:,:,:,:)                             ! all before fields set to now values
+         ub   (:,:,:)   = un   (:,:,:)
+         vb   (:,:,:)   = vn   (:,:,:)
+         sshb (:,:)     = sshn (:,:)
+         !
+         IF( .NOT.ln_linssh ) THEN
+            DO jk = 1, jpk
+               e3t_b(:,:,jk) = e3t_n(:,:,jk)
+            END DO
+         ENDIF
+         !
+      ENDIF
+      !
+   END SUBROUTINE rst_read
+
+   !!=====================================================================
+END MODULE restart
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/LBC/lbc_lnk_generic.h90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/LBC/lbc_lnk_generic.h90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/LBC/lbc_lnk_generic.h90	(revision 9570)
@@ -0,0 +1,123 @@
+#if defined MULTI
+#   define NAT_IN(k)                cd_nat(k)   
+#   define SGN_IN(k)                psgn(k)
+#   define F_SIZE(ptab)             kfld
+#   define OPT_K(k)                 ,ipf
+#   if defined DIM_2d
+#      define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_2D)                , INTENT(inout) ::   ptab(f)
+#      define ARRAY_IN(i,j,k,l,f)      ptab(f)%pt2d(i,j)
+#      define K_SIZE(ptab)             1
+#      define L_SIZE(ptab)             1
+#   endif
+#   if defined DIM_3d
+#      define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_3D),INTENT(inout)::ptab(f)
+#      define ARRAY_IN(i,j,k,l,f)      ptab(f)%pt3d(i,j,k)
+#      define K_SIZE(ptab)             SIZE(ptab(1)%pt3d,3)
+#      define L_SIZE(ptab)             1
+#   endif
+#   if defined DIM_4d
+#      define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_4D),INTENT(inout)::ptab(f)
+#      define ARRAY_IN(i,j,k,l,f)      ptab(f)%pt4d(i,j,k,l)
+#      define K_SIZE(ptab)             SIZE(ptab(1)%pt4d,3)
+#      define L_SIZE(ptab)             SIZE(ptab(1)%pt4d,4)
+#   endif
+#else
+#   define ARRAY_TYPE(i,j,k,l,f)    REAL(wp)                    , INTENT(inout) ::   ARRAY_IN(i,j,k,l,f)
+#   define NAT_IN(k)                cd_nat
+#   define SGN_IN(k)                psgn
+#   define F_SIZE(ptab)             1
+#   define OPT_K(k)                 
+#   if defined DIM_2d
+#      define ARRAY_IN(i,j,k,l,f)   ptab(i,j)
+#      define K_SIZE(ptab)          1
+#      define L_SIZE(ptab)          1
+#   endif
+#   if defined DIM_3d
+#      define ARRAY_IN(i,j,k,l,f)   ptab(i,j,k)
+#      define K_SIZE(ptab)          SIZE(ptab,3)
+#      define L_SIZE(ptab)          1
+#   endif
+#   if defined DIM_4d
+#      define ARRAY_IN(i,j,k,l,f)   ptab(i,j,k,l)
+#      define K_SIZE(ptab)          SIZE(ptab,3)
+#      define L_SIZE(ptab)          SIZE(ptab,4)
+#   endif
+#endif
+
+#if defined MULTI
+   SUBROUTINE ROUTINE_LNK( ptab, cd_nat, psgn, kfld, cd_mpp, pval )
+      INTEGER                     , INTENT(in   ) ::   kfld        ! number of pt3d arrays
+#else
+   SUBROUTINE ROUTINE_LNK( ptab, cd_nat, psgn      , cd_mpp, pval )
+#endif
+      ARRAY_TYPE(:,:,:,:,:)                                        ! array or pointer of arrays on which the boundary condition is applied
+      CHARACTER(len=1)            , INTENT(in   ) ::   NAT_IN(:)   ! nature of array grid-points
+      REAL(wp)                    , INTENT(in   ) ::   SGN_IN(:)   ! sign used across the north fold boundary
+      CHARACTER(len=3), OPTIONAL  , INTENT(in   ) ::   cd_mpp      ! fill the overlap area only
+      REAL(wp)        , OPTIONAL  , INTENT(in   ) ::   pval        ! background value (used at closed boundaries)
+      !
+      INTEGER  ::    ji,  jj,  jk,  jl, jh, jf   ! dummy loop indices
+      INTEGER  ::   ipi, ipj, ipk, ipl, ipf      ! dimension of the input array
+      REAL(wp) ::   zland
+      LOGICAL  ::   ll_Iperio, ll_Jperio, ll_nfd
+      !!----------------------------------------------------------------------
+      !
+      ipk = K_SIZE(ptab)   ! 3rd dimension
+      ipl = L_SIZE(ptab)   ! 4th    -
+      ipf = F_SIZE(ptab)   ! 5th    -      use in "multi" case (array of pointers)
+      !
+      ll_Iperio = nperio==1 .OR. nperio==4 .OR. nperio==6
+      ll_Jperio = jperio==7
+      ll_nfd    = nperio==3 .OR. nperio==4 .OR. nperio==5 .OR. nperio==6
+      !
+      IF( PRESENT( pval ) ) THEN   ;   zland = pval      ! set land value
+      ELSE                         ;   zland = 0._wp     ! zero by default
+      ENDIF
+
+      ! ------------------------------- !
+      !   standard boundary treatment   !    ! CAUTION: semi-column notation is often impossible
+      ! ------------------------------- !
+      !
+      IF( PRESENT( cd_mpp ) ) THEN     !==  halos filled with inner values  ==!
+         !
+         ! only fill the overlap area and extra allows 
+         ! this is in mpp case. In this module, just do nothing
+         !
+      ELSE                             !==  standard close or cyclic treatment  ==!
+         !
+         DO jf = 1, ipf                   ! number of arrays to be treated
+            !
+            !                                ! East-West boundaries
+            IF( ll_Iperio ) THEN                   !* cyclic
+               ARRAY_IN( 1 ,:,:,:,jf) = ARRAY_IN(jpim1,:,:,:,jf)
+               ARRAY_IN(jpi,:,:,:,jf) = ARRAY_IN(  2  ,:,:,:,jf)
+            ELSE                                   !* closed
+               IF( .NOT. NAT_IN(jf) == 'F' )   ARRAY_IN( 1 ,:,:,:,jf) = zland    ! east except F-point
+                                               ARRAY_IN(jpi,:,:,:,jf) = zland    ! west
+            ENDIF
+            !                                ! North-South boundaries
+            IF( ll_Jperio ) THEN                   !* cyclic
+               ARRAY_IN(:, 1 ,:,:,jf) = ARRAY_IN(:, jpjm1,:,:,jf)
+               ARRAY_IN(:,jpj,:,:,jf) = ARRAY_IN(:,   2  ,:,:,jf)
+            ELSEIF( ll_nfd ) THEN                  !* north fold
+               IF( .NOT. NAT_IN(jf) == 'F' )   ARRAY_IN(:, 1 ,:,:,jf) = zland    ! south except F-point
+               CALL lbc_nfd( ptab, NAT_IN(:), SGN_IN(:) OPT_K(:) )                       ! north fold treatment         
+            ELSE                                   !* closed
+               IF( .NOT. NAT_IN(jf) == 'F' )   ARRAY_IN(:, 1 ,:,:,jf) = zland    ! south except F-point
+                                               ARRAY_IN(:,jpj,:,:,jf) = zland    ! north
+            ENDIF
+            !
+         END DO
+         !
+      ENDIF
+      !
+   END SUBROUTINE ROUTINE_LNK
+
+#undef ARRAY_TYPE
+#undef NAT_IN
+#undef SGN_IN
+#undef ARRAY_IN
+#undef K_SIZE
+#undef L_SIZE
+#undef F_SIZE
+#undef OPT_K
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/LBC/lbc_lnk_multi_generic.h90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/LBC/lbc_lnk_multi_generic.h90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/LBC/lbc_lnk_multi_generic.h90	(revision 9570)
@@ -0,0 +1,74 @@
+#if defined DIM_2d
+#   define ARRAY_TYPE(i,j,k,l)   REAL(wp), DIMENSION(i,j)
+#   define PTR_TYPE              TYPE(PTR_2D)
+#   define PTR_ptab              pt2d
+#endif
+#if defined DIM_3d
+#   define ARRAY_TYPE(i,j,k,l)   REAL(wp), DIMENSION(i,j,k)
+#   define PTR_TYPE              TYPE(PTR_3D)
+#   define PTR_ptab              pt3d
+#endif
+#if defined DIM_4d
+#   define ARRAY_TYPE(i,j,k,l)   REAL(wp), DIMENSION(i,j,k,l)
+#   define PTR_TYPE              TYPE(PTR_4D)
+#   define PTR_ptab              pt4d
+#endif
+   SUBROUTINE ROUTINE_MULTI( pt1, cdna1, psgn1, pt2, cdna2, psgn2, pt3, cdna3, psgn3   &
+      &                    , pt4, cdna4, psgn4, pt5, cdna5, psgn5, pt6, cdna6, psgn6   &
+      &                    , pt7, cdna7, psgn7, pt8, cdna8, psgn8, pt9, cdna9, psgn9, cd_mpp, pval)
+      !!---------------------------------------------------------------------
+      ARRAY_TYPE(:,:,:,:)          , TARGET, INTENT(inout) ::   pt1     ! arrays on which the lbc is applied
+      ARRAY_TYPE(:,:,:,:), OPTIONAL, TARGET, INTENT(inout) ::   pt2  ,  pt3  , pt4  , pt5  , pt6  , pt7  , pt8  , pt9
+      CHARACTER(len=1)                     , INTENT(in   ) ::   cdna1   ! nature of pt2D. array grid-points
+      CHARACTER(len=1)   , OPTIONAL        , INTENT(in   ) ::   cdna2,  cdna3, cdna4, cdna5, cdna6, cdna7, cdna8, cdna9
+      REAL(wp)                             , INTENT(in   ) ::   psgn1   ! sign used across the north fold
+      REAL(wp)           , OPTIONAL        , INTENT(in   ) ::   psgn2,  psgn3, psgn4, psgn5, psgn6, psgn7, psgn8, psgn9   
+      CHARACTER(len=3)   , OPTIONAL        , INTENT(in   ) ::   cd_mpp  ! fill the overlap area only
+      REAL(wp)           , OPTIONAL        , INTENT(in   ) ::   pval    ! background value (used at closed boundaries)
+      !!
+      INTEGER                         ::   kfld        ! number of elements that will be attributed
+      PTR_TYPE         , DIMENSION(9) ::   ptab_ptr    ! pointer array
+      CHARACTER(len=1) , DIMENSION(9) ::   cdna_ptr    ! nature of ptab_ptr grid-points
+      REAL(wp)         , DIMENSION(9) ::   psgn_ptr    ! sign used across the north fold boundary
+      !!---------------------------------------------------------------------
+      !
+      kfld = 0          ! initial array of pointer size
+      !
+      !                 ! Load the first array
+      CALL ROUTINE_LOAD( pt1, cdna1, psgn1, ptab_ptr, cdna_ptr, psgn_ptr, kfld )
+      !
+      !                 ! Look if more arrays are added
+      IF( PRESENT(psgn2) )   CALL ROUTINE_LOAD( pt2, cdna2, psgn2, ptab_ptr, cdna_ptr, psgn_ptr, kfld )
+      IF( PRESENT(psgn3) )   CALL ROUTINE_LOAD( pt3, cdna3, psgn3, ptab_ptr, cdna_ptr, psgn_ptr, kfld )
+      IF( PRESENT(psgn4) )   CALL ROUTINE_LOAD( pt4, cdna4, psgn4, ptab_ptr, cdna_ptr, psgn_ptr, kfld )
+      IF( PRESENT(psgn5) )   CALL ROUTINE_LOAD( pt5, cdna5, psgn5, ptab_ptr, cdna_ptr, psgn_ptr, kfld )
+      IF( PRESENT(psgn6) )   CALL ROUTINE_LOAD( pt6, cdna6, psgn6, ptab_ptr, cdna_ptr, psgn_ptr, kfld )
+      IF( PRESENT(psgn7) )   CALL ROUTINE_LOAD( pt7, cdna7, psgn7, ptab_ptr, cdna_ptr, psgn_ptr, kfld )
+      IF( PRESENT(psgn8) )   CALL ROUTINE_LOAD( pt8, cdna8, psgn8, ptab_ptr, cdna_ptr, psgn_ptr, kfld )
+      IF( PRESENT(psgn9) )   CALL ROUTINE_LOAD( pt9, cdna9, psgn9, ptab_ptr, cdna_ptr, psgn_ptr, kfld )
+      !
+      CALL lbc_lnk_ptr( ptab_ptr, cdna_ptr, psgn_ptr, kfld, cd_mpp, pval )
+      !
+   END SUBROUTINE ROUTINE_MULTI
+
+
+   SUBROUTINE ROUTINE_LOAD( ptab, cdna, psgn, ptab_ptr, cdna_ptr, psgn_ptr, kfld )
+      !!---------------------------------------------------------------------
+      ARRAY_TYPE(:,:,:,:)   , TARGET, INTENT(inout) ::   ptab       ! arrays on which the lbc is applied
+      CHARACTER(len=1)              , INTENT(in   ) ::   cdna       ! nature of pt2d array grid-points
+      REAL(wp)                      , INTENT(in   ) ::   psgn       ! sign used across the north fold boundary
+      PTR_TYPE        , DIMENSION(:), INTENT(inout) ::   ptab_ptr   ! array of pointers
+      CHARACTER(len=1), DIMENSION(:), INTENT(inout) ::   cdna_ptr   ! nature of pt2d_array array grid-points
+      REAL(wp)        , DIMENSION(:), INTENT(inout) ::   psgn_ptr   ! sign used across the north fold boundary
+      INTEGER                       , INTENT(inout) ::   kfld       ! number of elements that has been attributed
+      !!---------------------------------------------------------------------
+      !
+      kfld                    =  kfld + 1
+      ptab_ptr(kfld)%PTR_ptab => ptab
+      cdna_ptr(kfld)          =  cdna
+      psgn_ptr(kfld)          =  psgn
+      !
+   END SUBROUTINE ROUTINE_LOAD
+#undef ARRAY_TYPE
+#undef PTR_TYPE
+#undef PTR_ptab
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/LBC/lbc_nfd_ext_generic.h90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/LBC/lbc_nfd_ext_generic.h90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/LBC/lbc_nfd_ext_generic.h90	(revision 9570)
@@ -0,0 +1,157 @@
+!                          !==  IN: ptab is an array  ==!
+#define NAT_IN(k)                cd_nat
+#define SGN_IN(k)                psgn
+#define F_SIZE(ptab)             1
+#if defined DIM_2d
+#   define ARRAY_IN(i,j,k,l,f)   ptab(i,j)
+#   define K_SIZE(ptab)          1
+#   define L_SIZE(ptab)          1
+#endif
+#define ARRAY_TYPE(i,j,k,l,f)    REAL(wp),INTENT(inout)::ARRAY_IN(i,j,k,l,f)
+
+   SUBROUTINE ROUTINE_NFD( ptab, cd_nat, psgn, kextj )
+      !!----------------------------------------------------------------------
+      ARRAY_TYPE(:,1-kextj:,:,:,:)                      ! array or pointer of arrays on which the boundary condition is applied
+      CHARACTER(len=1) , INTENT(in   ) ::   NAT_IN(:)   ! nature of array grid-points
+      REAL(wp)         , INTENT(in   ) ::   SGN_IN(:)   ! sign used across the north fold boundary
+      INTEGER          , INTENT(in   ) ::   kextj       ! extra halo width at north fold
+      !
+      INTEGER  ::    ji,  jj,  jk,  jl, jh,  jf   ! dummy loop indices
+      INTEGER  ::   ipi, ipj, ipk, ipl,     ipf   ! dimension of the input array
+      INTEGER  ::   ijt, iju, ipjm1
+      !!----------------------------------------------------------------------
+      !
+      ipk = K_SIZE(ptab)   ! 3rd dimension
+      ipl = L_SIZE(ptab)   ! 4th    -
+      ipf = F_SIZE(ptab)   ! 5th    -      use in "multi" case (array of pointers)
+      !
+      !
+      SELECT CASE ( jpni )
+      CASE ( 1 )     ;   ipj = nlcj       ! 1 proc only  along the i-direction
+      CASE DEFAULT   ;   ipj = 4          ! several proc along the i-direction
+      END SELECT
+      !
+      ipjm1 = ipj-1
+
+      !
+      DO jf = 1, ipf                      ! Loop on the number of arrays to be treated
+         !
+         SELECT CASE ( npolj )
+         !
+         CASE ( 3 , 4 )                        ! *  North fold  T-point pivot
+            !
+            SELECT CASE ( NAT_IN(jf)  )
+            CASE ( 'T' , 'W' )                         ! T-, W-point
+               DO jh = 0, kextj
+                  DO ji = 2, jpiglo
+                     ijt = jpiglo-ji+2
+                     ARRAY_IN(ji,ipj+jh,:,:,jf) = SGN_IN(jf)  * ARRAY_IN(ijt,ipj-2-jh,:,:,jf)
+                  END DO
+                  ARRAY_IN(1,ipj+jh,:,:,jf) = SGN_IN(jf)  * ARRAY_IN(3,ipj-2-jh,:,:,jf)
+               END DO
+               DO ji = jpiglo/2+1, jpiglo
+                  ijt = jpiglo-ji+2
+                  ARRAY_IN(ji,ipjm1,:,:,jf) = SGN_IN(jf)  * ARRAY_IN(ijt,ipjm1,:,:,jf)
+               END DO
+            CASE ( 'U' )                               ! U-point
+               DO jh = 0, kextj
+                  DO ji = 2, jpiglo-1
+                     iju = jpiglo-ji+1
+                     ARRAY_IN(ji,ipj+jh,:,:,jf) = SGN_IN(jf)  * ARRAY_IN(iju,ipj-2-jh,:,:,jf)
+                  END DO
+                 ARRAY_IN(   1  ,ipj+jh,:,:,jf) = SGN_IN(jf)  * ARRAY_IN(    2   ,ipj-2-jh,:,:,jf)
+                 ARRAY_IN(jpiglo,ipj+jh,:,:,jf) = SGN_IN(jf)  * ARRAY_IN(jpiglo-1,ipj-2-jh,:,:,jf) 
+               END DO
+               DO ji = jpiglo/2, jpiglo-1
+                  iju = jpiglo-ji+1
+                  ARRAY_IN(ji,ipjm1,:,:,jf) = SGN_IN(jf)  * ARRAY_IN(iju,ipjm1,:,:,jf)
+               END DO
+            CASE ( 'V' )                               ! V-point
+               DO jh = 0, kextj
+                  DO ji = 2, jpiglo
+                     ijt = jpiglo-ji+2
+                     ARRAY_IN(ji,ipj-1+jh,:,:,jf) = SGN_IN(jf)  * ARRAY_IN(ijt,ipj-2-jh,:,:,jf)
+                     ARRAY_IN(ji,ipj+jh  ,:,:,jf) = SGN_IN(jf)  * ARRAY_IN(ijt,ipj-3-jh,:,:,jf)
+                  END DO
+                  ARRAY_IN(1,ipj+jh,:,:,jf) = SGN_IN(jf)  * ARRAY_IN(3,ipj-3-jh,:,:,jf) 
+               END DO
+            CASE ( 'F' )                               ! F-point
+               DO jh = 0, kextj
+                  DO ji = 1, jpiglo-1
+                     iju = jpiglo-ji+1
+                     ARRAY_IN(ji,ipj-1+jh,:,:,jf) = SGN_IN(jf)  * ARRAY_IN(iju,ipj-2-jh,:,:,jf)
+                     ARRAY_IN(ji,ipj+jh  ,:,:,jf) = SGN_IN(jf)  * ARRAY_IN(iju,ipj-3-jh,:,:,jf)
+                  END DO
+               END DO
+               DO jh = 0, kextj
+                  ARRAY_IN(   1  ,ipj+jh,:,:,jf) = SGN_IN(jf)  * ARRAY_IN(    2   ,ipj-3-jh,:,:,jf)
+                  ARRAY_IN(jpiglo,ipj+jh,:,:,jf) = SGN_IN(jf)  * ARRAY_IN(jpiglo-1,ipj-3-jh,:,:,jf)
+               END DO
+            END SELECT
+            !
+         CASE ( 5 , 6 )                        ! *  North fold  F-point pivot
+            !
+            SELECT CASE ( NAT_IN(jf)  )
+            CASE ( 'T' , 'W' )                         ! T-, W-point
+               DO jh = 0, kextj
+                  DO ji = 1, jpiglo
+                     ijt = jpiglo-ji+1
+                     ARRAY_IN(ji,ipj+jh,:,:,jf) = SGN_IN(jf)  * ARRAY_IN(ijt,ipj-1-jh,:,:,jf)
+                  END DO
+               END DO
+            CASE ( 'U' )                               ! U-point
+               DO jh = 0, kextj
+                  DO ji = 1, jpiglo-1
+                     iju = jpiglo-ji
+                     ARRAY_IN(ji,ipj+jh,:,:,jf) = SGN_IN(jf)  * ARRAY_IN(iju,ipj-1-jh,:,:,jf)
+                  END DO
+                  ARRAY_IN(jpiglo,ipj+jh,:,:,jf) = SGN_IN(jf)  * ARRAY_IN(1,ipj-1-jh,:,:,jf)
+               END DO
+            CASE ( 'V' )                               ! V-point
+               DO jh = 0, kextj
+                  DO ji = 1, jpiglo
+                     ijt = jpiglo-ji+1
+                     ARRAY_IN(ji,ipj+jh,:,:,jf) = SGN_IN(jf)  * ARRAY_IN(ijt,ipj-2-jh,:,:,jf)
+                  END DO
+               END DO
+               DO ji = jpiglo/2+1, jpiglo
+                  ijt = jpiglo-ji+1
+                  ARRAY_IN(ji,ipjm1,:,:,jf) = SGN_IN(jf)  * ARRAY_IN(ijt,ipjm1,:,:,jf)
+               END DO
+            CASE ( 'F' )                               ! F-point
+               DO jh = 0, kextj
+                  DO ji = 1, jpiglo-1
+                     iju = jpiglo-ji
+                     ARRAY_IN(ji,ipj+jh  ,:,:,jf) = SGN_IN(jf)  * ARRAY_IN(iju,ipj-2-jh,:,:,jf)
+                  END DO
+                  ARRAY_IN(jpiglo,ipj+jh,:,:,jf) = SGN_IN(jf)  * ARRAY_IN(1,ipj-2-jh,:,:,jf)
+               END DO
+               DO ji = jpiglo/2+1, jpiglo-1
+                  iju = jpiglo-ji
+                  ARRAY_IN(ji,ipjm1,:,:,jf) = SGN_IN(jf)  * ARRAY_IN(iju,ipjm1,:,:,jf)
+               END DO
+            END SELECT
+            !
+         CASE DEFAULT                           ! *  closed : the code probably never go through
+            !
+            SELECT CASE ( NAT_IN(jf) )
+            CASE ( 'T' , 'U' , 'V' , 'W' )             ! T-, U-, V-, W-points
+               ARRAY_IN(:,  1:1-kextj  ,:,:,jf) = 0._wp
+               ARRAY_IN(:,ipj:ipj+kextj,:,:,jf) = 0._wp
+            CASE ( 'F' )                               ! F-point
+               ARRAY_IN(:,ipj:ipj+kextj,:,:,jf) = 0._wp
+            END SELECT
+            !
+         END SELECT     !  npolj
+         !
+      END DO
+      !
+   END SUBROUTINE ROUTINE_NFD
+
+#undef ARRAY_TYPE
+#undef ARRAY_IN
+#undef NAT_IN
+#undef SGN_IN
+#undef K_SIZE
+#undef L_SIZE
+#undef F_SIZE
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/LBC/lbc_nfd_generic.h90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/LBC/lbc_nfd_generic.h90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/LBC/lbc_nfd_generic.h90	(revision 9570)
@@ -0,0 +1,175 @@
+#if defined MULTI
+#   define NAT_IN(k)                cd_nat(k)   
+#   define SGN_IN(k)                psgn(k)
+#   define F_SIZE(ptab)             kfld
+#   if defined DIM_2d
+#      define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_2D),INTENT(inout)::ptab(f)
+#      define ARRAY_IN(i,j,k,l,f)      ptab(f)%pt2d(i,j)
+#      define K_SIZE(ptab)             1
+#      define L_SIZE(ptab)             1
+#   endif
+#   if defined DIM_3d
+#      define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_3D),INTENT(inout)::ptab(f)
+#      define ARRAY_IN(i,j,k,l,f)      ptab(f)%pt3d(i,j,k)
+#      define K_SIZE(ptab)             SIZE(ptab(1)%pt3d,3)
+#      define L_SIZE(ptab)             1
+#   endif
+#   if defined DIM_4d
+#      define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_4D),INTENT(inout)::ptab(f)
+#      define ARRAY_IN(i,j,k,l,f)      ptab(f)%pt4d(i,j,k,l)
+#      define K_SIZE(ptab)             SIZE(ptab(1)%pt4d,3)
+#      define L_SIZE(ptab)             SIZE(ptab(1)%pt4d,4)
+#   endif
+#else
+!                          !==  IN: ptab is an array  ==!
+#   define NAT_IN(k)                cd_nat
+#   define SGN_IN(k)                psgn
+#   define F_SIZE(ptab)             1
+#   if defined DIM_2d
+#      define ARRAY_IN(i,j,k,l,f)   ptab(i,j)
+#      define K_SIZE(ptab)          1
+#      define L_SIZE(ptab)          1
+#   endif
+#   if defined DIM_3d
+#      define ARRAY_IN(i,j,k,l,f)   ptab(i,j,k)
+#      define K_SIZE(ptab)          SIZE(ptab,3)
+#      define L_SIZE(ptab)          1
+#   endif
+#   if defined DIM_4d
+#      define ARRAY_IN(i,j,k,l,f)   ptab(i,j,k,l)
+#      define K_SIZE(ptab)          SIZE(ptab,3)
+#      define L_SIZE(ptab)          SIZE(ptab,4)
+#   endif
+#   define ARRAY_TYPE(i,j,k,l,f)    REAL(wp),INTENT(inout)::ARRAY_IN(i,j,k,l,f)
+#endif
+
+#if defined MULTI
+   SUBROUTINE ROUTINE_NFD( ptab, cd_nat, psgn, kfld )
+      INTEGER          , INTENT(in   ) ::   kfld        ! number of pt3d arrays
+#else
+   SUBROUTINE ROUTINE_NFD( ptab, cd_nat, psgn       )
+#endif
+      ARRAY_TYPE(:,:,:,:,:)                             ! array or pointer of arrays on which the boundary condition is applied
+      CHARACTER(len=1) , INTENT(in   ) ::   NAT_IN(:)   ! nature of array grid-points
+      REAL(wp)         , INTENT(in   ) ::   SGN_IN(:)   ! sign used across the north fold boundary
+      !
+      INTEGER  ::    ji,  jj,  jk,  jl, jh,  jf   ! dummy loop indices
+      INTEGER  ::   ipi, ipj, ipk, ipl,     ipf   ! dimension of the input array
+      INTEGER  ::   ijt, iju, ipjm1
+      !!----------------------------------------------------------------------
+      !
+      ipk = K_SIZE(ptab)   ! 3rd dimension
+      ipl = L_SIZE(ptab)   ! 4th    -
+      ipf = F_SIZE(ptab)   ! 5th    -      use in "multi" case (array of pointers)
+      !
+      !
+      SELECT CASE ( jpni )
+      CASE ( 1 )     ;   ipj = nlcj       ! 1 proc only  along the i-direction
+      CASE DEFAULT   ;   ipj = 4          ! several proc along the i-direction
+      END SELECT
+      ipjm1 = ipj-1
+
+      !
+      DO jf = 1, ipf                      ! Loop on the number of arrays to be treated
+         !
+         SELECT CASE ( npolj )
+         !
+         CASE ( 3 , 4 )                        ! *  North fold  T-point pivot
+            !
+            SELECT CASE ( NAT_IN(jf)  )
+            CASE ( 'T' , 'W' )                         ! T-, W-point
+               DO ji = 2, jpiglo
+                  ijt = jpiglo-ji+2
+                  ARRAY_IN(ji,ipj,:,:,jf) = SGN_IN(jf)  * ARRAY_IN(ijt,ipj-2,:,:,jf)
+               END DO
+               ARRAY_IN(1,ipj,:,:,jf) = SGN_IN(jf)  * ARRAY_IN(3,ipj-2,:,:,jf)
+               DO ji = jpiglo/2+1, jpiglo
+                  ijt = jpiglo-ji+2
+                  ARRAY_IN(ji,ipjm1,:,:,jf) = SGN_IN(jf)  * ARRAY_IN(ijt,ipjm1,:,:,jf)
+               END DO
+            CASE ( 'U' )                               ! U-point
+               DO ji = 1, jpiglo-1
+                  iju = jpiglo-ji+1
+                  ARRAY_IN(ji,ipj,:,:,jf) = SGN_IN(jf)  * ARRAY_IN(iju,ipj-2,:,:,jf)
+               END DO
+               ARRAY_IN(   1  ,ipj,:,:,jf) = SGN_IN(jf)  * ARRAY_IN(    2   ,ipj-2,:,:,jf)
+               ARRAY_IN(jpiglo,ipj,:,:,jf) = SGN_IN(jf)  * ARRAY_IN(jpiglo-1,ipj-2,:,:,jf) 
+               DO ji = jpiglo/2, jpiglo-1
+                  iju = jpiglo-ji+1
+                  ARRAY_IN(ji,ipjm1,:,:,jf) = SGN_IN(jf)  * ARRAY_IN(iju,ipjm1,:,:,jf)
+               END DO
+            CASE ( 'V' )                               ! V-point
+               DO ji = 2, jpiglo
+                  ijt = jpiglo-ji+2
+                  ARRAY_IN(ji,ipj-1,:,:,jf) = SGN_IN(jf)  * ARRAY_IN(ijt,ipj-2,:,:,jf)
+                  ARRAY_IN(ji,ipj  ,:,:,jf) = SGN_IN(jf)  * ARRAY_IN(ijt,ipj-3,:,:,jf)
+               END DO
+               ARRAY_IN(1,ipj,:,:,jf) = SGN_IN(jf)  * ARRAY_IN(3,ipj-3,:,:,jf) 
+            CASE ( 'F' )                               ! F-point
+               DO ji = 1, jpiglo-1
+                  iju = jpiglo-ji+1
+                  ARRAY_IN(ji,ipj-1,:,:,jf) = SGN_IN(jf)  * ARRAY_IN(iju,ipj-2,:,:,jf)
+                  ARRAY_IN(ji,ipj  ,:,:,jf) = SGN_IN(jf)  * ARRAY_IN(iju,ipj-3,:,:,jf)
+               END DO
+               ARRAY_IN(   1  ,ipj,:,:,jf) = SGN_IN(jf)  * ARRAY_IN(    2   ,ipj-3,:,:,jf)
+               ARRAY_IN(jpiglo,ipj,:,:,jf) = SGN_IN(jf)  * ARRAY_IN(jpiglo-1,ipj-3,:,:,jf) 
+            END SELECT
+            !
+         CASE ( 5 , 6 )                        ! *  North fold  F-point pivot
+            !
+            SELECT CASE ( NAT_IN(jf)  )
+            CASE ( 'T' , 'W' )                         ! T-, W-point
+               DO ji = 1, jpiglo
+                  ijt = jpiglo-ji+1
+                  ARRAY_IN(ji,ipj,:,:,jf) = SGN_IN(jf)  * ARRAY_IN(ijt,ipj-1,:,:,jf)
+               END DO
+            CASE ( 'U' )                               ! U-point
+               DO ji = 1, jpiglo-1
+                  iju = jpiglo-ji
+                  ARRAY_IN(ji,ipj,:,:,jf) = SGN_IN(jf)  * ARRAY_IN(iju,ipj-1,:,:,jf)
+               END DO
+               ARRAY_IN(jpiglo,ipj,:,:,jf) = SGN_IN(jf)  * ARRAY_IN(1,ipj-1,:,:,jf)
+            CASE ( 'V' )                               ! V-point
+               DO ji = 1, jpiglo
+                  ijt = jpiglo-ji+1
+                  ARRAY_IN(ji,ipj,:,:,jf) = SGN_IN(jf)  * ARRAY_IN(ijt,ipj-2,:,:,jf)
+               END DO
+               DO ji = jpiglo/2+1, jpiglo
+                  ijt = jpiglo-ji+1
+                  ARRAY_IN(ji,ipjm1,:,:,jf) = SGN_IN(jf)  * ARRAY_IN(ijt,ipjm1,:,:,jf)
+               END DO
+            CASE ( 'F' )                               ! F-point
+               DO ji = 1, jpiglo-1
+                  iju = jpiglo-ji
+                  ARRAY_IN(ji,ipj  ,:,:,jf) = SGN_IN(jf)  * ARRAY_IN(iju,ipj-2,:,:,jf)
+               END DO
+               ARRAY_IN(jpiglo,ipj,:,:,jf) = SGN_IN(jf)  * ARRAY_IN(1,ipj-2,:,:,jf)
+               DO ji = jpiglo/2+1, jpiglo-1
+                  iju = jpiglo-ji
+                  ARRAY_IN(ji,ipjm1,:,:,jf) = SGN_IN(jf)  * ARRAY_IN(iju,ipjm1,:,:,jf)
+               END DO
+            END SELECT
+            !
+         CASE DEFAULT                           ! *  closed : the code probably never go through
+            !
+            SELECT CASE ( NAT_IN(jf) )
+            CASE ( 'T' , 'U' , 'V' , 'W' )             ! T-, U-, V-, W-points
+               ARRAY_IN(:, 1 ,:,:,jf) = 0._wp
+               ARRAY_IN(:,ipj,:,:,jf) = 0._wp
+            CASE ( 'F' )                               ! F-point
+               ARRAY_IN(:,ipj,:,:,jf) = 0._wp
+            END SELECT
+            !
+         END SELECT     !  npolj
+         !
+      END DO
+      !
+   END SUBROUTINE ROUTINE_NFD
+
+#undef ARRAY_TYPE
+#undef ARRAY_IN
+#undef NAT_IN
+#undef SGN_IN
+#undef K_SIZE
+#undef L_SIZE
+#undef F_SIZE
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/LBC/lbc_nfd_nogather_generic.h90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/LBC/lbc_nfd_nogather_generic.h90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/LBC/lbc_nfd_nogather_generic.h90	(revision 9570)
@@ -0,0 +1,334 @@
+#if defined MULTI
+#   define NAT_IN(k)                cd_nat(k)   
+#   define SGN_IN(k)                psgn(k)
+#   define F_SIZE(ptab)             kfld
+#   if defined DIM_2d
+#      define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_2D),INTENT(inout)::ptab(f)
+#      define ARRAY_IN(i,j,k,l,f)      ptab(f)%pt2d(i,j)
+#      define K_SIZE(ptab)             1
+#      define L_SIZE(ptab)             1
+#      define ARRAY2_TYPE(i,j,k,l,f)   TYPE(PTR_2D),INTENT(inout)::ptab2(f)
+#      define ARRAY2_IN(i,j,k,l,f)     ptab2(f)%pt2d(i,j)
+#   endif
+#   if defined DIM_3d
+#      define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_3D),INTENT(inout)::ptab(f)
+#      define ARRAY_IN(i,j,k,l,f)      ptab(f)%pt3d(i,j,k)
+#      define K_SIZE(ptab)             SIZE(ptab(1)%pt3d,3)
+#      define L_SIZE(ptab)             1
+#      define ARRAY2_TYPE(i,j,k,l,f)   TYPE(PTR_3D),INTENT(inout)::ptab2(f)
+#      define ARRAY2_IN(i,j,k,l,f)     ptab2(f)%pt3d(i,j,k)
+#   endif
+#   if defined DIM_4d
+#      define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_4D),INTENT(inout)::ptab(f)
+#      define ARRAY_IN(i,j,k,l,f)      ptab(f)%pt4d(i,j,k,l)
+#      define K_SIZE(ptab)             SIZE(ptab(1)%pt4d,3)
+#      define L_SIZE(ptab)             SIZE(ptab(1)%pt4d,4)
+#      define ARRAY2_TYPE(i,j,k,l,f)   TYPE(PTR_4D),INTENT(inout)::ptab2(f)
+#      define ARRAY2_IN(i,j,k,l,f)     ptab2(f)%pt4d(i,j,k,l)
+#   endif
+#else
+!                          !==  IN: ptab is an array  ==!
+#   define NAT_IN(k)                cd_nat
+#   define SGN_IN(k)                psgn
+#   define F_SIZE(ptab)             1
+#   if defined DIM_2d
+#      define ARRAY_IN(i,j,k,l,f)   ptab(i,j)
+#      define K_SIZE(ptab)          1
+#      define L_SIZE(ptab)          1
+#      define ARRAY2_IN(i,j,k,l,f)  ptab2(i,j)
+#   endif
+#   if defined DIM_3d
+#      define ARRAY_IN(i,j,k,l,f)   ptab(i,j,k)
+#      define K_SIZE(ptab)          SIZE(ptab,3)
+#      define L_SIZE(ptab)          1
+#      define ARRAY2_IN(i,j,k,l,f)  ptab2(i,j,k)
+#   endif
+#   if defined DIM_4d
+#      define ARRAY_IN(i,j,k,l,f)   ptab(i,j,k,l)
+#      define K_SIZE(ptab)          SIZE(ptab,3)
+#      define L_SIZE(ptab)          SIZE(ptab,4)
+#      define ARRAY2_IN(i,j,k,l,f)  ptab2(i,j,k,l)
+#   endif
+#   define ARRAY_TYPE(i,j,k,l,f)     REAL(wp),INTENT(inout)::ARRAY_IN(i,j,k,l,f)
+#   define ARRAY2_TYPE(i,j,k,l,f)    REAL(wp),INTENT(inout)::ARRAY2_IN(i,j,k,l,f)
+#endif
+
+   SUBROUTINE ROUTINE_NFD( ptab, ptab2, cd_nat, psgn, kfld )
+      !!----------------------------------------------------------------------
+      !!
+      !! ** Purpose :   lateral boundary condition : North fold treatment
+      !!                without allgather exchanges. 
+      !!
+      !!----------------------------------------------------------------------
+      ARRAY_TYPE(:,:,:,:,:)                             ! array or pointer of arrays on which the boundary condition is applied
+      ARRAY2_TYPE(:,:,:,:,:)                            ! array or pointer of arrays on which the boundary condition is applied
+      CHARACTER(len=1) , INTENT(in   ) ::   NAT_IN(:)   ! nature of array grid-points
+      REAL(wp)         , INTENT(in   ) ::   SGN_IN(:)   ! sign used across the north fold boundary
+      INTEGER, OPTIONAL, INTENT(in   ) ::   kfld        ! number of pt3d arrays
+      !
+      INTEGER  ::    ji,  jj,   jk,     jl,   jh,  jf   ! dummy loop indices
+      INTEGER  ::   ipi, ipj,  ipk,    ipl,  ipf        ! dimension of the input array
+      INTEGER  ::   ijt, iju, ijpj, ijpjm1, ijta, ijua, jia, startloop, endloop
+      !!----------------------------------------------------------------------
+      ipk = K_SIZE(ptab)   ! 3rd dimension
+      ipl = L_SIZE(ptab)   ! 4th    -
+      ipf = F_SIZE(ptab)   ! 5th    -      use in "multi" case (array of pointers)
+      !
+      !
+      SELECT CASE ( jpni )
+      CASE ( 1 )     ;   ijpj = nlcj      ! 1 proc only  along the i-direction
+      CASE DEFAULT   ;   ijpj = 4         ! several proc along the i-direction
+      END SELECT
+      ijpjm1 = ijpj-1
+      !
+      !
+      DO jf = 1, ipf                      ! Loop over the number of arrays to be processed
+         !
+         SELECT CASE ( npolj )
+         !
+         CASE ( 3, 4 )                       ! *  North fold  T-point pivot
+            !
+            SELECT CASE ( NAT_IN(jf) )
+            !
+            CASE ( 'T' , 'W' )                         ! T-, W-point
+               IF ( nimpp /= 1 ) THEN   ;   startloop = 1
+               ELSE                     ;   startloop = 2
+               ENDIF
+               !
+               DO ji = startloop, nlci
+                  ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4
+                  ARRAY_IN(ji,ijpj,:,:,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpj-2,:,:,jf)
+               END DO
+               IF( nimpp == 1 ) THEN
+                  ARRAY_IN(1,ijpj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(3,ijpj-2,:,:,jf)
+               ENDIF
+               !
+               IF( nimpp >= jpiglo/2+1 ) THEN
+                  startloop = 1
+               ELSEIF( nimpp+nlci-1 >= jpiglo/2+1 .AND. nimpp < jpiglo/2+1 ) THEN
+                  startloop = jpiglo/2+1 - nimpp + 1
+               ELSE
+                  startloop = nlci + 1
+               ENDIF
+               IF( startloop <= nlci ) THEN
+                  DO ji = startloop, nlci
+                     ijt  = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4
+                     jia  = ji + nimpp - 1
+                     ijta = jpiglo - jia + 2
+                     IF( ijta >= startloop+nimpp-1 .AND. ijta < jia ) THEN
+                        ARRAY_IN(ji,ijpjm1,:,:,jf) = SGN_IN(jf) * ARRAY_IN(ijta-nimpp+1,ijpjm1,:,:,jf)
+                     ELSE
+                        ARRAY_IN(ji,ijpjm1,:,:,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpjm1,:,:,jf)
+                     ENDIF
+                  END DO
+               ENDIF
+               !
+            CASE ( 'U' )                                     ! U-point
+               IF( nimpp + nlci - 1 /= jpiglo ) THEN
+                  endloop = nlci
+               ELSE
+                  endloop = nlci - 1
+               ENDIF
+               DO ji = 1, endloop
+                  iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3
+                        ARRAY_IN(ji,ijpj,:,:,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpj-2,:,:,jf)
+               END DO
+               IF (nimpp .eq. 1) THEN
+                        ARRAY_IN(   1  ,ijpj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(    2   ,ijpj-2,:,:,jf)
+               ENDIF
+               IF((nimpp + nlci - 1) .eq. jpiglo) THEN
+                        ARRAY_IN(nlci,ijpj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(nlci-1,ijpj-2,:,:,jf)
+               ENDIF
+               !
+               IF( nimpp + nlci - 1 /= jpiglo ) THEN
+                  endloop = nlci
+               ELSE
+                  endloop = nlci - 1
+               ENDIF
+               IF( nimpp >= jpiglo/2 ) THEN
+                  startloop = 1
+                  ELSEIF( ( nimpp+nlci-1 >= jpiglo/2 ) .AND. ( nimpp < jpiglo/2 ) ) THEN
+                  startloop = jpiglo/2 - nimpp + 1
+               ELSE
+                  startloop = endloop + 1
+               ENDIF
+               IF( startloop <= endloop ) THEN
+               DO ji = startloop, endloop
+                  iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3
+                  jia = ji + nimpp - 1
+                  ijua = jpiglo - jia + 1
+                  IF( ijua >= startloop+nimpp-1 .AND. ijua < jia ) THEN
+                           ARRAY_IN(ji,ijpjm1,:,:,jf) = SGN_IN(jf) * ARRAY_IN(ijua-nimpp+1,ijpjm1,:,:,jf)
+                  ELSE
+                           ARRAY_IN(ji,ijpjm1,:,:,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpjm1,:,:,jf)
+                  ENDIF
+               END DO
+               ENDIF
+               !
+            CASE ( 'V' )                                     ! V-point
+               IF( nimpp /= 1 ) THEN
+                 startloop = 1
+               ELSE
+                 startloop = 2
+               ENDIF
+               DO ji = startloop, nlci
+                 ijt=jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4
+                        ARRAY_IN(ji,ijpj-1,:,:,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpj-2,:,:,jf)
+                        ARRAY_IN(ji,ijpj  ,:,:,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpj-3,:,:,jf)
+               END DO
+               IF (nimpp .eq. 1) THEN
+                        ARRAY_IN(1,ijpj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(3,ijpj-3,:,:,jf)
+               ENDIF
+            CASE ( 'F' )                                     ! F-point
+               IF( nimpp + nlci - 1 /= jpiglo ) THEN
+                  endloop = nlci
+               ELSE
+                  endloop = nlci - 1
+               ENDIF
+               DO ji = 1, endloop
+                  iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3
+                        ARRAY_IN(ji,ijpj-1,:,:,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpj-2,:,:,jf)
+                        ARRAY_IN(ji,ijpj  ,:,:,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpj-3,:,:,jf)
+               END DO
+               IF (nimpp .eq. 1) THEN
+                        ARRAY_IN(   1  ,ijpj  ,:,:,jf) = SGN_IN(jf) * ARRAY_IN(    2   ,ijpj-3,:,:,jf)
+                        ARRAY_IN(   1  ,ijpj-1,:,:,jf) = SGN_IN(jf) * ARRAY_IN(    2   ,ijpj-2,:,:,jf)
+               ENDIF
+               IF((nimpp + nlci - 1) .eq. jpiglo) THEN
+                        ARRAY_IN(nlci,ijpj  ,:,:,jf) = SGN_IN(jf) * ARRAY_IN(nlci-1,ijpj-3,:,:,jf)
+                        ARRAY_IN(nlci,ijpj-1,:,:,jf) = SGN_IN(jf) * ARRAY_IN(nlci-1,ijpj-2,:,:,jf) 
+               ENDIF
+               !
+            CASE ( 'I' )                                     ! ice U-V point (I-point)
+               IF( nimpp /= 1 ) THEN
+                  startloop = 1
+               ELSE
+                  startloop = 3
+                  ARRAY_IN(2,ijpj,:,:,jf) = SGN_IN(jf) * ARRAY2_IN(3,ijpjm1,:,:,jf)
+               ENDIF
+               DO ji = startloop, nlci
+                  iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 5
+                  ARRAY_IN(ji,ijpj,:,:,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpjm1,:,:,jf)
+               END DO
+            END SELECT
+            !
+         CASE ( 5, 6 )                        ! *  North fold  F-point pivot
+            !
+            SELECT CASE ( NAT_IN(jf) )
+            CASE ( 'T' , 'W' )                               ! T-, W-point
+               DO ji = 1, nlci
+                  ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3
+                        ARRAY_IN(ji,ijpj,:,:,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpj-1,:,:,jf)
+               END DO
+               !
+            CASE ( 'U' )                                     ! U-point
+               IF( nimpp + nlci - 1 /= jpiglo ) THEN
+                  endloop = nlci
+               ELSE
+                  endloop = nlci - 1
+               ENDIF
+               DO ji = 1, endloop
+                  iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2
+                        ARRAY_IN(ji,ijpj,:,:,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpj-1,:,:,jf)
+               END DO
+               IF((nimpp + nlci - 1) .eq. jpiglo) THEN
+                        ARRAY_IN(nlci,ijpj,:,:,jf) = SGN_IN(jf) * ARRAY2_IN(1,ijpj-1,:,:,jf)
+               ENDIF
+               !
+            CASE ( 'V' )                                     ! V-point
+               DO ji = 1, nlci
+                  ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3
+                        ARRAY_IN(ji,ijpj,:,:,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpj-2,:,:,jf)
+               END DO
+                  !
+               IF( nimpp >= jpiglo/2+1 ) THEN
+                  startloop = 1
+               ELSEIF( nimpp+nlci-1 >= jpiglo/2+1 .AND. nimpp < jpiglo/2+1 ) THEN
+                  startloop = jpiglo/2+1 - nimpp + 1
+               ELSE
+                  startloop = nlci + 1
+               ENDIF
+               IF( startloop <= nlci ) THEN
+               DO ji = startloop, nlci
+                  ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3
+                          ARRAY_IN(ji,ijpjm1,:,:,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpjm1,:,:,jf)
+               END DO
+               ENDIF
+               !
+            CASE ( 'F' )                               ! F-point
+               IF( nimpp + nlci - 1 /= jpiglo ) THEN
+                  endloop = nlci
+               ELSE
+                  endloop = nlci - 1
+               ENDIF
+               DO ji = 1, endloop
+                  iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2
+                        ARRAY_IN(ji,ijpj ,:,:,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpj-2,:,:,jf)
+               END DO
+               IF((nimpp + nlci - 1) .eq. jpiglo) THEN
+                        ARRAY_IN(nlci,ijpj,:,:,jf) = SGN_IN(jf) * ARRAY2_IN(1,ijpj-2,:,:,jf)
+               ENDIF
+               !
+               IF( nimpp + nlci - 1 /= jpiglo ) THEN
+                  endloop = nlci
+               ELSE
+                  endloop = nlci - 1
+               ENDIF
+               IF( nimpp >= jpiglo/2+1 ) THEN
+                  startloop = 1
+               ELSEIF( nimpp+nlci-1 >= jpiglo/2+1 .AND. nimpp < jpiglo/2+1 ) THEN
+                  startloop = jpiglo/2+1 - nimpp + 1
+               ELSE
+                  startloop = endloop + 1
+               ENDIF
+               IF( startloop <= endloop ) THEN
+                  DO ji = startloop, endloop
+                      iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2
+                      ARRAY_IN(ji,ijpjm1,:,:,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpjm1,:,:,jf)
+                  END DO
+               ENDIF
+               !
+            CASE ( 'I' )                                  ! ice U-V point (I-point)
+               IF( nimpp /= 1 ) THEN
+                  startloop = 1
+               ELSE
+                  startloop = 2
+               ENDIF
+               IF( nimpp + nlci - 1 /= jpiglo ) THEN
+                  endloop = nlci
+               ELSE
+                  endloop = nlci - 1
+               ENDIF
+               DO ji = startloop , endloop
+                  ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4
+                  ARRAY_IN(ji,ijpj,:,:,jf) = 0.5 * (ARRAY_IN(ji,ijpjm1,:,:,jf) + SGN_IN(jf) * ARRAY2_IN(ijt,ijpjm1,:,:,jf))
+               END DO
+               !
+            END SELECT
+            !
+         CASE DEFAULT                           ! *  closed : the code probably never go through
+            !
+            SELECT CASE ( NAT_IN(jf))
+            CASE ( 'T' , 'U' , 'V' , 'W' )                 ! T-, U-, V-, W-points
+               ARRAY_IN(:, 1  ,:,:,jf) = 0._wp
+               ARRAY_IN(:,ijpj,:,:,jf) = 0._wp
+            CASE ( 'F' )                                   ! F-point
+               ARRAY_IN(:,ijpj,:,:,jf) = 0._wp
+            CASE ( 'I' )                                   ! ice U-V point
+               ARRAY_IN(:, 1  ,:,:,jf) = 0._wp
+               ARRAY_IN(:,ijpj,:,:,jf) = 0._wp
+            END SELECT
+            !
+         END SELECT     !  npolj
+         !
+      END DO            ! End jf loop
+   END SUBROUTINE ROUTINE_NFD
+#undef ARRAY_TYPE
+#undef ARRAY_IN
+#undef NAT_IN
+#undef SGN_IN
+#undef K_SIZE
+#undef L_SIZE
+#undef F_SIZE
+#undef ARRAY2_TYPE
+#undef ARRAY2_IN
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/LBC/lbclnk.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/LBC/lbclnk.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/LBC/lbclnk.F90	(revision 9570)
@@ -0,0 +1,329 @@
+MODULE lbclnk
+   !!======================================================================
+   !!                       ***  MODULE  lbclnk  ***
+   !! NEMO        : lateral boundary conditions
+   !!=====================================================================
+   !! History :  OPA  ! 1997-06  (G. Madec)  Original code
+   !!   NEMO     1.0  ! 2002-09  (G. Madec)  F90: Free form and module
+   !!            3.2  ! 2009-03  (R. Benshila)  External north fold treatment  
+   !!            3.5  ! 2012     (S.Mocavero, I. Epicoco)  optimization of BDY comm. via lbc_bdy_lnk and lbc_obc_lnk
+   !!            3.4  ! 2012-12  (R. Bourdalle-Badie, G. Reffray)  add a C1D case  
+   !!            3.6  ! 2015-06  (O. Tintó and M. Castrillo)  add lbc_lnk_multi  
+   !!            4.0  ! 2017-03  (G. Madec) automatique allocation of array size (use with any 3rd dim size)
+   !!             -   ! 2017-04  (G. Madec) remove duplicated routines (lbc_lnk_2d_9, lbc_lnk_2d_multiple, lbc_lnk_3d_gather)
+   !!             -   ! 2017-05  (G. Madec) create generic.h90 files to generate all lbc and north fold routines
+   !!----------------------------------------------------------------------
+#if defined key_mpp_mpi
+   !!----------------------------------------------------------------------
+   !!   'key_mpp_mpi'             MPI massively parallel processing library
+   !!----------------------------------------------------------------------
+   !!           define the generic interfaces of lib_mpp routines
+   !!----------------------------------------------------------------------
+   !!   lbc_lnk       : generic interface for mpp_lnk_3d and mpp_lnk_2d routines defined in lib_mpp
+   !!   lbc_bdy_lnk   : generic interface for mpp_lnk_bdy_2d and mpp_lnk_bdy_3d routines defined in lib_mpp
+   !!----------------------------------------------------------------------
+   USE par_oce        ! ocean dynamics and tracers   
+   USE lib_mpp        ! distributed memory computing library
+   USE lbcnfd         ! north fold
+
+   INTERFACE lbc_lnk
+      MODULE PROCEDURE   mpp_lnk_2d      , mpp_lnk_3d      , mpp_lnk_4d
+   END INTERFACE
+   INTERFACE lbc_lnk_ptr
+      MODULE PROCEDURE   mpp_lnk_2d_ptr  , mpp_lnk_3d_ptr  , mpp_lnk_4d_ptr
+   END INTERFACE
+   INTERFACE lbc_lnk_multi
+      MODULE PROCEDURE   lbc_lnk_2d_multi, lbc_lnk_3d_multi, lbc_lnk_4d_multi
+   END INTERFACE
+   !
+   INTERFACE lbc_bdy_lnk
+      MODULE PROCEDURE mpp_lnk_bdy_2d, mpp_lnk_bdy_3d
+   END INTERFACE
+   !
+   INTERFACE lbc_lnk_icb
+      MODULE PROCEDURE mpp_lnk_2d_icb
+   END INTERFACE
+
+   PUBLIC   lbc_lnk       ! ocean/ice lateral boundary conditions
+   PUBLIC   lbc_lnk_multi ! modified ocean/ice lateral boundary conditions
+   PUBLIC   lbc_bdy_lnk   ! ocean lateral BDY boundary conditions
+   PUBLIC   lbc_lnk_icb   ! iceberg lateral boundary conditions
+
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 4.0 , NEMO Consortium (2017)
+   !! $Id$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+#else
+   !!----------------------------------------------------------------------
+   !!   Default option                              shared memory computing
+   !!----------------------------------------------------------------------
+   !!                routines setting the appropriate values
+   !!         on first and last row and column of the global domain
+   !!----------------------------------------------------------------------
+   !!   lbc_lnk_sum_3d: compute sum over the halos on a 3D variable on ocean mesh
+   !!   lbc_lnk_sum_3d: compute sum over the halos on a 2D variable on ocean mesh
+   !!   lbc_lnk       : generic interface for lbc_lnk_3d and lbc_lnk_2d
+   !!   lbc_lnk_3d    : set the lateral boundary condition on a 3D variable on ocean mesh
+   !!   lbc_lnk_2d    : set the lateral boundary condition on a 2D variable on ocean mesh
+   !!   lbc_bdy_lnk   : set the lateral BDY boundary condition
+   !!----------------------------------------------------------------------
+   USE oce            ! ocean dynamics and tracers   
+   USE dom_oce        ! ocean space and time domain 
+   USE in_out_manager ! I/O manager
+   USE lbcnfd         ! north fold
+
+   IMPLICIT NONE
+   PRIVATE
+
+   INTERFACE lbc_lnk
+      MODULE PROCEDURE   lbc_lnk_2d      , lbc_lnk_3d      , lbc_lnk_4d
+   END INTERFACE
+   INTERFACE lbc_lnk_ptr
+      MODULE PROCEDURE   lbc_lnk_2d_ptr  , lbc_lnk_3d_ptr  , lbc_lnk_4d_ptr
+   END INTERFACE
+   INTERFACE lbc_lnk_multi
+      MODULE PROCEDURE   lbc_lnk_2d_multi, lbc_lnk_3d_multi, lbc_lnk_4d_multi
+   END INTERFACE
+   !
+   INTERFACE lbc_bdy_lnk
+      MODULE PROCEDURE lbc_bdy_lnk_2d, lbc_bdy_lnk_3d
+   END INTERFACE
+   !
+   INTERFACE lbc_lnk_icb
+      MODULE PROCEDURE lbc_lnk_2d_icb
+   END INTERFACE
+   
+   PUBLIC   lbc_lnk       ! ocean/ice  lateral boundary conditions
+   PUBLIC   lbc_lnk_multi ! modified ocean/ice lateral boundary conditions
+   PUBLIC   lbc_bdy_lnk   ! ocean lateral BDY boundary conditions
+   PUBLIC   lbc_lnk_icb   ! iceberg lateral boundary conditions
+   
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 4.0 , NEMO Consortium (2017)
+   !! $Id$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+# if defined key_c1d
+   !!======================================================================
+   !!   'key_c1d'                                          1D configuration
+   !!======================================================================
+   !!     central point value replicated over the 8 surrounding points
+   !!----------------------------------------------------------------------
+
+   SUBROUTINE lbc_lnk_3d( pt3d, cd_type, psgn, cd_mpp, pval )
+      !!---------------------------------------------------------------------
+      !!                  ***  ROUTINE lbc_lnk_3d  ***
+      !!
+      !! ** Purpose :   set lateral boundary conditions on a 3D array (C1D case)
+      !!
+      !! ** Method  :   1D case, the central water column is set everywhere
+      !!----------------------------------------------------------------------
+      REAL(wp), DIMENSION(:,:,:), INTENT(inout)           ::   pt3d      ! 3D array on which the lbc is applied
+      CHARACTER(len=1)          , INTENT(in   )           ::   cd_type   ! nature of pt3d grid-points
+      REAL(wp)                  , INTENT(in   )           ::   psgn      ! sign used across north fold 
+      CHARACTER(len=3)          , INTENT(in   ), OPTIONAL ::   cd_mpp    ! MPP only (here do nothing)
+      REAL(wp)                  , INTENT(in   ), OPTIONAL ::   pval      ! background value (for closed boundaries)
+      !
+      INTEGER  ::   jk     ! dummy loop index
+      REAL(wp) ::   ztab   ! local scalar
+      !!----------------------------------------------------------------------
+      !
+      DO jk = 1, SIZE( pt3d, 3 )
+         ztab = pt3d(2,2,jk)
+         pt3d(:,:,jk) = ztab
+      END DO
+      !
+   END SUBROUTINE lbc_lnk_3d
+
+
+   SUBROUTINE lbc_lnk_2d( pt2d, cd_type, psgn, cd_mpp, pval )
+      !!---------------------------------------------------------------------
+      !!                 ***  ROUTINE lbc_lnk_2d  ***
+      !!
+      !! ** Purpose :   set lateral boundary conditions on a 2D array (non mpp case)
+      !!
+      !! ** Method  :   1D case, the central water column is set everywhere
+      !!----------------------------------------------------------------------
+      REAL(wp), DIMENSION(jpi,jpj), INTENT(inout)           ::   pt2d      ! 2D array on which the lbc is applied
+      CHARACTER(len=1)            , INTENT(in   )           ::   cd_type   ! nature of pt3d grid-points
+      REAL(wp)                    , INTENT(in   )           ::   psgn      ! sign used across north fold 
+      CHARACTER(len=3)            , INTENT(in   ), OPTIONAL ::   cd_mpp    ! MPP only (here do nothing)
+      REAL(wp)                    , INTENT(in   ), OPTIONAL ::   pval      ! background value (for closed boundaries)
+      !
+      REAL(wp) ::   ztab   ! local scalar
+      !!----------------------------------------------------------------------
+      !
+      ztab = pt2d(2,2)
+      pt2d(:,:) = ztab
+      !
+   END SUBROUTINE lbc_lnk_2d
+   
+#else
+   !!======================================================================
+   !!   Default option                           3D shared memory computing
+   !!======================================================================
+   !!          routines setting land point, or east-west cyclic,
+   !!             or north-south cyclic, or north fold values
+   !!         on first and last row and column of the global domain
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!                   ***  routine lbc_lnk_(2,3,4)d  ***
+   !!
+   !!   * Argument : dummy argument use in lbc_lnk_... routines
+   !!                ptab   :   array or pointer of arrays on which the boundary condition is applied
+   !!                cd_nat :   nature of array grid-points
+   !!                psgn   :   sign used across the north fold boundary
+   !!                kfld   :   optional, number of pt3d arrays
+   !!                cd_mpp :   optional, fill the overlap area only
+   !!                pval   :   optional, background value (used at closed boundaries)
+   !!----------------------------------------------------------------------
+   !
+   !                       !==  2D array and array of 2D pointer  ==!
+   !
+#  define DIM_2d
+#     define ROUTINE_LNK           lbc_lnk_2d
+#     include "lbc_lnk_generic.h90"
+#     undef ROUTINE_LNK
+#     define MULTI
+#     define ROUTINE_LNK           lbc_lnk_2d_ptr
+#     include "lbc_lnk_generic.h90"
+#     undef ROUTINE_LNK
+#     undef MULTI
+#  undef DIM_2d
+   !
+   !                       !==  3D array and array of 3D pointer  ==!
+   !
+#  define DIM_3d
+#     define ROUTINE_LNK           lbc_lnk_3d
+#     include "lbc_lnk_generic.h90"
+#     undef ROUTINE_LNK
+#     define MULTI
+#     define ROUTINE_LNK           lbc_lnk_3d_ptr
+#     include "lbc_lnk_generic.h90"
+#     undef ROUTINE_LNK
+#     undef MULTI
+#  undef DIM_3d
+   !
+   !                       !==  4D array and array of 4D pointer  ==!
+   !
+#  define DIM_4d
+#     define ROUTINE_LNK           lbc_lnk_4d
+#     include "lbc_lnk_generic.h90"
+#     undef ROUTINE_LNK
+#     define MULTI
+#     define ROUTINE_LNK           lbc_lnk_4d_ptr
+#     include "lbc_lnk_generic.h90"
+#     undef ROUTINE_LNK
+#     undef MULTI
+#  undef DIM_4d
+   
+#endif
+
+   !!======================================================================
+   !!   identical routines in both C1D and shared memory computing
+   !!======================================================================
+
+   !!----------------------------------------------------------------------
+   !!                   ***  routine lbc_bdy_lnk_(2,3)d  ***
+   !!
+   !!   wrapper rountine to 'lbc_lnk_3d'. This wrapper is used
+   !!   to maintain the same interface with regards to the mpp case
+   !!----------------------------------------------------------------------
+   
+   SUBROUTINE lbc_bdy_lnk_3d( pt3d, cd_type, psgn, ib_bdy )
+      !!----------------------------------------------------------------------
+      REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   pt3d      ! 3D array on which the lbc is applied
+      CHARACTER(len=1)          , INTENT(in   ) ::   cd_type   ! nature of pt3d grid-points
+      REAL(wp)                  , INTENT(in   ) ::   psgn      ! sign used across north fold 
+      INTEGER                   , INTENT(in   ) ::   ib_bdy    ! BDY boundary set
+      !!----------------------------------------------------------------------
+      CALL lbc_lnk_3d( pt3d, cd_type, psgn)
+   END SUBROUTINE lbc_bdy_lnk_3d
+
+
+   SUBROUTINE lbc_bdy_lnk_2d( pt2d, cd_type, psgn, ib_bdy )
+      !!----------------------------------------------------------------------
+      REAL(wp), DIMENSION(:,:), INTENT(inout) ::   pt2d      ! 3D array on which the lbc is applied
+      CHARACTER(len=1)        , INTENT(in   ) ::   cd_type   ! nature of pt3d grid-points
+      REAL(wp)                , INTENT(in   ) ::   psgn      ! sign used across north fold 
+      INTEGER                 , INTENT(in   ) ::   ib_bdy    ! BDY boundary set
+      !!----------------------------------------------------------------------
+      CALL lbc_lnk_2d( pt2d, cd_type, psgn)
+   END SUBROUTINE lbc_bdy_lnk_2d
+
+
+!!gm  This routine should be removed with an optional halos size added in argument of generic routines
+
+   SUBROUTINE lbc_lnk_2d_icb( pt2d, cd_type, psgn, ki, kj )
+      !!----------------------------------------------------------------------
+      REAL(wp), DIMENSION(:,:), INTENT(inout) ::   pt2d      ! 2D array on which the lbc is applied
+      CHARACTER(len=1)        , INTENT(in   ) ::   cd_type   ! nature of pt3d grid-points
+      REAL(wp)                , INTENT(in   ) ::   psgn      ! sign used across north fold 
+      INTEGER                 , INTENT(in   ) ::   ki, kj    ! sizes of extra halo (not needed in non-mpp)
+      !!----------------------------------------------------------------------
+      CALL lbc_lnk_2d( pt2d, cd_type, psgn )
+   END SUBROUTINE lbc_lnk_2d_icb
+!!gm end
+
+#endif
+
+   !!======================================================================
+   !!   identical routines in both distributed and shared memory computing
+   !!======================================================================
+
+   !!----------------------------------------------------------------------
+   !!                   ***   load_ptr_(2,3,4)d   ***
+   !!
+   !!   * Dummy Argument :
+   !!       in    ==>   ptab       ! array to be loaded (2D, 3D or 4D)
+   !!                   cd_nat     ! nature of pt2d array grid-points
+   !!                   psgn       ! sign used across the north fold boundary
+   !!       inout <=>   ptab_ptr   ! array of 2D, 3D or 4D pointers
+   !!                   cdna_ptr   ! nature of ptab array grid-points
+   !!                   psgn_ptr   ! sign used across the north fold boundary
+   !!                   kfld       ! number of elements that has been attributed
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!                  ***   lbc_lnk_(2,3,4)d_multi   ***
+   !!                     ***   load_ptr_(2,3,4)d   ***
+   !!
+   !!   * Argument : dummy argument use in lbc_lnk_multi_... routines
+   !!
+   !!----------------------------------------------------------------------
+
+#  define DIM_2d
+#     define ROUTINE_MULTI          lbc_lnk_2d_multi
+#     define ROUTINE_LOAD           load_ptr_2d
+#     include "lbc_lnk_multi_generic.h90"
+#     undef ROUTINE_MULTI
+#     undef ROUTINE_LOAD
+#  undef DIM_2d
+
+
+#  define DIM_3d
+#     define ROUTINE_MULTI          lbc_lnk_3d_multi
+#     define ROUTINE_LOAD           load_ptr_3d
+#     include "lbc_lnk_multi_generic.h90"
+#     undef ROUTINE_MULTI
+#     undef ROUTINE_LOAD
+#  undef DIM_3d
+
+
+#  define DIM_4d
+#     define ROUTINE_MULTI          lbc_lnk_4d_multi
+#     define ROUTINE_LOAD           load_ptr_4d
+#     include "lbc_lnk_multi_generic.h90"
+#     undef ROUTINE_MULTI
+#     undef ROUTINE_LOAD
+#  undef DIM_4d
+
+   !!======================================================================
+END MODULE lbclnk
+
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/LBC/lbcnfd.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/LBC/lbcnfd.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/LBC/lbcnfd.F90	(revision 9570)
@@ -0,0 +1,168 @@
+MODULE lbcnfd
+   !!======================================================================
+   !!                       ***  MODULE  lbcnfd  ***
+   !! Ocean        : north fold  boundary conditions
+   !!======================================================================
+   !! History :  3.2  ! 2009-03  (R. Benshila)  Original code 
+   !!            3.5  ! 2013-07  (I. Epicoco, S. Mocavero - CMCC) MPP optimization
+   !!            4.0  ! 2017-04  (G. Madec) automatique allocation of array argument (use any 3rd dimension)
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   lbc_nfd       : generic interface for lbc_nfd_3d and lbc_nfd_2d routines
+   !!   lbc_nfd_3d    : lateral boundary condition: North fold treatment for a 3D arrays   (lbc_nfd)
+   !!   lbc_nfd_2d    : lateral boundary condition: North fold treatment for a 2D arrays   (lbc_nfd)
+   !!   lbc_nfd_nogather       : generic interface for lbc_nfd_nogather_3d and 
+   !!                            lbc_nfd_nogather_2d routines (designed for use
+   !!                            with ln_nnogather to avoid global width arrays
+   !!                            mpi all gather operations)
+   !!----------------------------------------------------------------------
+   USE dom_oce        ! ocean space and time domain 
+   USE in_out_manager ! I/O manager
+
+   IMPLICIT NONE
+   PRIVATE
+
+   INTERFACE lbc_nfd
+      MODULE PROCEDURE   lbc_nfd_2d    , lbc_nfd_3d    , lbc_nfd_4d
+      MODULE PROCEDURE   lbc_nfd_2d_ptr, lbc_nfd_3d_ptr, lbc_nfd_4d_ptr
+      MODULE PROCEDURE   lbc_nfd_2d_ext
+   END INTERFACE
+   !
+   INTERFACE lbc_nfd_nogather
+!                        ! Currently only 4d array version is needed
+!     MODULE PROCEDURE   lbc_nfd_nogather_2d    , lbc_nfd_nogather_3d
+      MODULE PROCEDURE   lbc_nfd_nogather_4d
+!     MODULE PROCEDURE   lbc_nfd_nogather_2d_ptr, lbc_nfd_nogather_3d_ptr
+!     MODULE PROCEDURE   lbc_nfd_nogather_4d_ptr
+   END INTERFACE
+
+   TYPE, PUBLIC ::   PTR_2D   !: array of 2D pointers (also used in lib_mpp)
+      REAL(wp), DIMENSION (:,:)    , POINTER ::   pt2d
+   END TYPE PTR_2D
+   TYPE, PUBLIC ::   PTR_3D   !: array of 3D pointers (also used in lib_mpp)
+      REAL(wp), DIMENSION (:,:,:)  , POINTER ::   pt3d
+   END TYPE PTR_3D
+   TYPE, PUBLIC ::   PTR_4D   !: array of 4D pointers (also used in lib_mpp)
+      REAL(wp), DIMENSION (:,:,:,:), POINTER ::   pt4d
+   END TYPE PTR_4D
+
+   PUBLIC   lbc_nfd            ! north fold conditions
+   PUBLIC   lbc_nfd_nogather   ! north fold conditions (no allgather case)
+
+   INTEGER, PUBLIC, PARAMETER            ::   jpmaxngh = 3               !:
+   INTEGER, PUBLIC                       ::   nsndto, nfsloop, nfeloop   !:
+   INTEGER, PUBLIC, DIMENSION (jpmaxngh) ::   isendto                    !: processes to which communicate
+
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO Consortium (2010)
+   !! $Id$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   !!----------------------------------------------------------------------
+   !!                   ***  routine lbc_nfd_(2,3,4)d  ***
+   !!----------------------------------------------------------------------
+   !!
+   !! ** Purpose :   lateral boundary condition 
+   !!                North fold treatment without processor exchanges. 
+   !!
+   !! ** Method  :   
+   !!
+   !! ** Action  :   ptab with updated values along the north fold
+   !!----------------------------------------------------------------------
+   !
+   !                       !==  2D array and array of 2D pointer  ==!
+   !
+#  define DIM_2d
+#     define ROUTINE_NFD           lbc_nfd_2d
+#     include "lbc_nfd_generic.h90"
+#     undef ROUTINE_NFD
+#     define MULTI
+#     define ROUTINE_NFD           lbc_nfd_2d_ptr
+#     include "lbc_nfd_generic.h90"
+#     undef ROUTINE_NFD
+#     undef MULTI
+#  undef DIM_2d
+   !
+   !                       !==  2D array with extra haloes  ==!
+   !
+#  define DIM_2d
+#     define ROUTINE_NFD           lbc_nfd_2d_ext
+#     include "lbc_nfd_ext_generic.h90"
+#     undef ROUTINE_NFD
+#  undef DIM_2d
+   !
+   !                       !==  3D array and array of 3D pointer  ==!
+   !
+#  define DIM_3d
+#     define ROUTINE_NFD           lbc_nfd_3d
+#     include "lbc_nfd_generic.h90"
+#     undef ROUTINE_NFD
+#     define MULTI
+#     define ROUTINE_NFD           lbc_nfd_3d_ptr
+#     include "lbc_nfd_generic.h90"
+#     undef ROUTINE_NFD
+#     undef MULTI
+#  undef DIM_3d
+   !
+   !                       !==  4D array and array of 4D pointer  ==!
+   !
+#  define DIM_4d
+#     define ROUTINE_NFD           lbc_nfd_4d
+#     include "lbc_nfd_generic.h90"
+#     undef ROUTINE_NFD
+#     define MULTI
+#     define ROUTINE_NFD           lbc_nfd_4d_ptr
+#     include "lbc_nfd_generic.h90"
+#     undef ROUTINE_NFD
+#     undef MULTI
+#  undef DIM_4d
+   !
+   !  lbc_nfd_nogather routines
+   !
+   !                       !==  2D array and array of 2D pointer  ==!
+   !
+!#  define DIM_2d
+!#     define ROUTINE_NFD           lbc_nfd_nogather_2d
+!#     include "lbc_nfd_nogather_generic.h90"
+!#     undef ROUTINE_NFD
+!#     define MULTI
+!#     define ROUTINE_NFD           lbc_nfd_nogather_2d_ptr
+!#     include "lbc_nfd_nogather_generic.h90"
+!#     undef ROUTINE_NFD
+!#     undef MULTI
+!#  undef DIM_2d
+   !
+   !                       !==  3D array and array of 3D pointer  ==!
+   !
+!#  define DIM_3d
+!#     define ROUTINE_NFD           lbc_nfd_nogather_3d
+!#     include "lbc_nfd_nogather_generic.h90"
+!#     undef ROUTINE_NFD
+!#     define MULTI
+!#     define ROUTINE_NFD           lbc_nfd_nogather_3d_ptr
+!#     include "lbc_nfd_nogather_generic.h90"
+!#     undef ROUTINE_NFD
+!#     undef MULTI
+!#  undef DIM_3d
+   !
+   !                       !==  4D array and array of 4D pointer  ==!
+   !
+#  define DIM_4d
+#     define ROUTINE_NFD           lbc_nfd_nogather_4d
+#     include "lbc_nfd_nogather_generic.h90"
+#     undef ROUTINE_NFD
+!#     define MULTI
+!#     define ROUTINE_NFD           lbc_nfd_nogather_4d_ptr
+!#     include "lbc_nfd_nogather_generic.h90"
+!#     undef ROUTINE_NFD
+!#     undef MULTI
+#  undef DIM_4d
+
+   !!----------------------------------------------------------------------
+
+
+   !!======================================================================
+END MODULE lbcnfd
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/LBC/lib_mpp.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/LBC/lib_mpp.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/LBC/lib_mpp.F90	(revision 9570)
@@ -0,0 +1,2012 @@
+MODULE lib_mpp
+   !!======================================================================
+   !!                       ***  MODULE  lib_mpp  ***
+   !! Ocean numerics:  massively parallel processing library
+   !!=====================================================================
+   !! History :  OPA  !  1994  (M. Guyon, J. Escobar, M. Imbard)  Original code
+   !!            7.0  !  1997  (A.M. Treguier)  SHMEM additions
+   !!            8.0  !  1998  (M. Imbard, J. Escobar, L. Colombet ) SHMEM and MPI
+   !!                 !  1998  (J.M. Molines) Open boundary conditions
+   !!   NEMO     1.0  !  2003  (J.M. Molines, G. Madec)  F90, free form
+   !!                 !  2003  (J.M. Molines) add mpp_ini_north(_3d,_2d)
+   !!             -   !  2004  (R. Bourdalle Badie)  isend option in mpi
+   !!                 !  2004  (J.M. Molines) minloc, maxloc
+   !!             -   !  2005  (G. Madec, S. Masson)  npolj=5,6 F-point & ice cases
+   !!             -   !  2005  (R. Redler) Replacement of MPI_COMM_WORLD except for MPI_Abort
+   !!             -   !  2005  (R. Benshila, G. Madec)  add extra halo case
+   !!             -   !  2008  (R. Benshila) add mpp_ini_ice
+   !!            3.2  !  2009  (R. Benshila) SHMEM suppression, north fold in lbc_nfd
+   !!            3.2  !  2009  (O. Marti)    add mpp_ini_znl
+   !!            4.0  !  2011  (G. Madec)  move ctl_ routines from in_out_manager
+   !!            3.5  !  2012  (S.Mocavero, I. Epicoco) Add mpp_lnk_bdy_3d/2d routines to optimize the BDY comm.
+   !!            3.5  !  2013  (C. Ethe, G. Madec)  message passing arrays as local variables 
+   !!            3.5  !  2013  (S.Mocavero, I.Epicoco - CMCC) north fold optimizations
+   !!            3.6  !  2015  (O. Tintó and M. Castrillo - BSC) Added '_multiple' case for 2D lbc and max
+   !!            4.0  !  2017  (G. Madec) automatique allocation of array argument (use any 3rd dimension)
+   !!             -   !  2017  (G. Madec) create generic.h90 files to generate all lbc and north fold routines
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   ctl_stop      : update momentum and tracer Kz from a tke scheme
+   !!   ctl_warn      : initialization, namelist read, and parameters control
+   !!   ctl_opn       : Open file and check if required file is available.
+   !!   ctl_nam       : Prints informations when an error occurs while reading a namelist
+   !!   get_unit      : give the index of an unused logical unit
+   !!----------------------------------------------------------------------
+#if   defined key_mpp_mpi
+   !!----------------------------------------------------------------------
+   !!   'key_mpp_mpi'             MPI massively parallel processing library
+   !!----------------------------------------------------------------------
+   !!   lib_mpp_alloc : allocate mpp arrays
+   !!   mynode        : indentify the processor unit
+   !!   mpp_lnk       : interface (defined in lbclnk) for message passing of 2d or 3d arrays (mpp_lnk_2d, mpp_lnk_3d)
+   !!   mpp_lnk_icb   : interface for message passing of 2d arrays with extra halo for icebergs (mpp_lnk_2d_icb)
+   !!   mpprecv       :
+   !!   mppsend       :
+   !!   mppscatter    :
+   !!   mppgather     :
+   !!   mpp_min       : generic interface for mppmin_int , mppmin_a_int , mppmin_real, mppmin_a_real
+   !!   mpp_max       : generic interface for mppmax_int , mppmax_a_int , mppmax_real, mppmax_a_real
+   !!   mpp_sum       : generic interface for mppsum_int , mppsum_a_int , mppsum_real, mppsum_a_real
+   !!   mpp_minloc    :
+   !!   mpp_maxloc    :
+   !!   mppsync       :
+   !!   mppstop       :
+   !!   mpp_ini_north : initialisation of north fold
+   !!   mpp_lbc_north_icb : alternative to mpp_nfd for extra outer halo with icebergs
+   !!----------------------------------------------------------------------
+   USE dom_oce        ! ocean space and time domain
+   USE lbcnfd         ! north fold treatment
+   USE in_out_manager ! I/O manager
+
+   IMPLICIT NONE
+   PRIVATE
+
+   INTERFACE mpp_nfd
+      MODULE PROCEDURE   mpp_nfd_2d      , mpp_nfd_3d      , mpp_nfd_4d
+      MODULE PROCEDURE   mpp_nfd_2d_ptr, mpp_nfd_3d_ptr, mpp_nfd_4d_ptr
+   END INTERFACE
+
+   ! Interface associated to the mpp_lnk_... routines is defined in lbclnk
+   PUBLIC   mpp_lnk_2d      , mpp_lnk_3d      , mpp_lnk_4d
+   PUBLIC   mpp_lnk_2d_ptr, mpp_lnk_3d_ptr, mpp_lnk_4d_ptr
+   !
+!!gm  this should be useless
+   PUBLIC   mpp_nfd_2d    , mpp_nfd_3d    , mpp_nfd_4d
+   PUBLIC   mpp_nfd_2d_ptr, mpp_nfd_3d_ptr, mpp_nfd_4d_ptr
+!!gm end
+   !
+   PUBLIC   ctl_stop, ctl_warn, get_unit, ctl_opn, ctl_nam
+   PUBLIC   mynode, mppstop, mppsync, mpp_comm_free
+   PUBLIC   mpp_ini_north
+   PUBLIC   mpp_lnk_2d_icb
+   PUBLIC   mpp_lbc_north_icb
+   PUBLIC   mpp_min, mpp_max, mpp_sum, mpp_minloc, mpp_maxloc
+   PUBLIC   mpp_max_multiple
+   PUBLIC   mppscatter, mppgather
+   PUBLIC   mpp_ini_ice, mpp_ini_znl
+   PUBLIC   mppsize
+   PUBLIC   mppsend, mpprecv                          ! needed by TAM and ICB routines
+   PUBLIC   mpp_lnk_bdy_2d, mpp_lnk_bdy_3d
+   PUBLIC   mpprank
+   
+   !! * Interfaces
+   !! define generic interface for these routine as they are called sometimes
+   !! with scalar arguments instead of array arguments, which causes problems
+   !! for the compilation on AIX system as well as NEC and SGI. Ok on COMPACQ
+   INTERFACE mpp_min
+      MODULE PROCEDURE mppmin_a_int, mppmin_int, mppmin_a_real, mppmin_real
+   END INTERFACE
+   INTERFACE mpp_max
+      MODULE PROCEDURE mppmax_a_int, mppmax_int, mppmax_a_real, mppmax_real
+   END INTERFACE
+   INTERFACE mpp_sum
+      MODULE PROCEDURE mppsum_a_int, mppsum_int, mppsum_a_real, mppsum_real,   &
+         &             mppsum_realdd, mppsum_a_realdd
+   END INTERFACE
+   INTERFACE mpp_minloc
+      MODULE PROCEDURE mpp_minloc2d ,mpp_minloc3d
+   END INTERFACE
+   INTERFACE mpp_maxloc
+      MODULE PROCEDURE mpp_maxloc2d ,mpp_maxloc3d
+   END INTERFACE
+   INTERFACE mpp_max_multiple
+      MODULE PROCEDURE mppmax_real_multiple
+   END INTERFACE
+
+   !! ========================= !!
+   !!  MPI  variable definition !!
+   !! ========================= !!
+!$AGRIF_DO_NOT_TREAT
+   INCLUDE 'mpif.h'
+!$AGRIF_END_DO_NOT_TREAT
+
+   LOGICAL, PUBLIC, PARAMETER ::   lk_mpp = .TRUE.    !: mpp flag
+
+   INTEGER, PARAMETER         ::   nprocmax = 2**10   ! maximun dimension (required to be a power of 2)
+
+   INTEGER ::   mppsize        ! number of process
+   INTEGER ::   mpprank        ! process number  [ 0 - size-1 ]
+!$AGRIF_DO_NOT_TREAT
+   INTEGER, PUBLIC ::   mpi_comm_oce   ! opa local communicator
+!$AGRIF_END_DO_NOT_TREAT
+
+   INTEGER :: MPI_SUMDD
+
+   ! variables used in case of sea-ice
+   INTEGER, PUBLIC ::   ncomm_ice       !: communicator made by the processors with sea-ice (public so that it can be freed in icethd)
+   INTEGER         ::   ngrp_iworld     !  group ID for the world processors (for rheology)
+   INTEGER         ::   ngrp_ice        !  group ID for the ice processors (for rheology)
+   INTEGER         ::   ndim_rank_ice   !  number of 'ice' processors
+   INTEGER         ::   n_ice_root      !  number (in the comm_ice) of proc 0 in the ice comm
+   INTEGER, DIMENSION(:), ALLOCATABLE, SAVE ::   nrank_ice     ! dimension ndim_rank_ice
+
+   ! variables used for zonal integration
+   INTEGER, PUBLIC ::   ncomm_znl       !: communicator made by the processors on the same zonal average
+   LOGICAL, PUBLIC ::   l_znl_root      !: True on the 'left'most processor on the same row
+   INTEGER         ::   ngrp_znl        !  group ID for the znl processors
+   INTEGER         ::   ndim_rank_znl   !  number of processors on the same zonal average
+   INTEGER, DIMENSION(:), ALLOCATABLE, SAVE ::   nrank_znl  ! dimension ndim_rank_znl, number of the procs into the same znl domain
+
+   ! North fold condition in mpp_mpi with jpni > 1 (PUBLIC for TAM)
+   INTEGER, PUBLIC ::   ngrp_world        !: group ID for the world processors
+   INTEGER, PUBLIC ::   ngrp_opa          !: group ID for the opa processors
+   INTEGER, PUBLIC ::   ngrp_north        !: group ID for the northern processors (to be fold)
+   INTEGER, PUBLIC ::   ncomm_north       !: communicator made by the processors belonging to ngrp_north
+   INTEGER, PUBLIC ::   ndim_rank_north   !: number of 'sea' processor in the northern line (can be /= jpni !)
+   INTEGER, PUBLIC ::   njmppmax          !: value of njmpp for the processors of the northern line
+   INTEGER, PUBLIC ::   north_root        !: number (in the comm_opa) of proc 0 in the northern comm
+   INTEGER, PUBLIC, DIMENSION(:), ALLOCATABLE, SAVE ::   nrank_north   !: dimension ndim_rank_north
+
+   ! Type of send : standard, buffered, immediate
+   CHARACTER(len=1), PUBLIC ::   cn_mpi_send        !: type od mpi send/recieve (S=standard, B=bsend, I=isend)
+   LOGICAL         , PUBLIC ::   l_isend = .FALSE.  !: isend use indicator (T if cn_mpi_send='I')
+   INTEGER         , PUBLIC ::   nn_buffer          !: size of the buffer in case of mpi_bsend
+
+   REAL(wp), DIMENSION(:), ALLOCATABLE, SAVE ::   tampon   ! buffer in case of bsend
+
+   LOGICAL, PUBLIC ::   ln_nnogather                !: namelist control of northfold comms
+   LOGICAL, PUBLIC ::   l_north_nogather = .FALSE.  !: internal control of northfold comms
+
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 4.0 , NEMO Consortium (2017)
+   !! $Id$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   FUNCTION mynode( ldtxt, ldname, kumnam_ref, kumnam_cfg, kumond, kstop, localComm )
+      !!----------------------------------------------------------------------
+      !!                  ***  routine mynode  ***
+      !!
+      !! ** Purpose :   Find processor unit
+      !!----------------------------------------------------------------------
+      CHARACTER(len=*),DIMENSION(:), INTENT(  out) ::   ldtxt        !
+      CHARACTER(len=*)             , INTENT(in   ) ::   ldname       !
+      INTEGER                      , INTENT(in   ) ::   kumnam_ref   ! logical unit for reference namelist
+      INTEGER                      , INTENT(in   ) ::   kumnam_cfg   ! logical unit for configuration namelist
+      INTEGER                      , INTENT(inout) ::   kumond       ! logical unit for namelist output
+      INTEGER                      , INTENT(inout) ::   kstop        ! stop indicator
+      INTEGER         , OPTIONAL   , INTENT(in   ) ::   localComm    !
+      !
+      INTEGER ::   mynode, ierr, code, ji, ii, ios
+      LOGICAL ::   mpi_was_called
+      !
+      NAMELIST/nammpp/ cn_mpi_send, nn_buffer, jpni, jpnj, jpnij, ln_nnogather
+      !!----------------------------------------------------------------------
+      !
+      ii = 1
+      WRITE(ldtxt(ii),*)                                                                  ;   ii = ii + 1
+      WRITE(ldtxt(ii),*) 'mynode : mpi initialisation'                                    ;   ii = ii + 1
+      WRITE(ldtxt(ii),*) '~~~~~~ '                                                        ;   ii = ii + 1
+      !
+      REWIND( kumnam_ref )              ! Namelist nammpp in reference namelist: mpi variables
+      READ  ( kumnam_ref, nammpp, IOSTAT = ios, ERR = 901)
+901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'nammpp in reference namelist', lwp )
+      !
+      REWIND( kumnam_cfg )              ! Namelist nammpp in configuration namelist: mpi variables
+      READ  ( kumnam_cfg, nammpp, IOSTAT = ios, ERR = 902 )
+902   IF( ios >  0 )   CALL ctl_nam ( ios , 'nammpp in configuration namelist', lwp )
+      !
+      !                              ! control print
+      WRITE(ldtxt(ii),*) '   Namelist nammpp'                                             ;   ii = ii + 1
+      WRITE(ldtxt(ii),*) '      mpi send type          cn_mpi_send = ', cn_mpi_send       ;   ii = ii + 1
+      WRITE(ldtxt(ii),*) '      size exported buffer   nn_buffer   = ', nn_buffer,' bytes';   ii = ii + 1
+      !
+#if defined key_agrif
+      IF( .NOT. Agrif_Root() ) THEN
+         jpni  = Agrif_Parent(jpni )
+         jpnj  = Agrif_Parent(jpnj )
+         jpnij = Agrif_Parent(jpnij)
+      ENDIF
+#endif
+      !
+      IF( jpnij < 1 ) THEN         ! If jpnij is not specified in namelist then we calculate it
+         jpnij = jpni * jpnj       ! this means there will be no land cutting out.
+      ENDIF
+
+      IF( jpni < 1 .OR. jpnj < 1  ) THEN
+         WRITE(ldtxt(ii),*) '      jpni, jpnj and jpnij will be calculated automatically' ;   ii = ii + 1
+      ELSE
+         WRITE(ldtxt(ii),*) '      processor grid extent in i         jpni = ',jpni       ;   ii = ii + 1
+         WRITE(ldtxt(ii),*) '      processor grid extent in j         jpnj = ',jpnj       ;   ii = ii + 1
+         WRITE(ldtxt(ii),*) '      number of local domains           jpnij = ',jpnij      ;   ii = ii + 1
+      ENDIF
+
+      WRITE(ldtxt(ii),*) '      avoid use of mpi_allgather at the north fold  ln_nnogather = ', ln_nnogather  ; ii = ii + 1
+
+      CALL mpi_initialized ( mpi_was_called, code )
+      IF( code /= MPI_SUCCESS ) THEN
+         DO ji = 1, SIZE(ldtxt)
+            IF( TRIM(ldtxt(ji)) /= '' )   WRITE(*,*) ldtxt(ji)      ! control print of mynode
+         END DO
+         WRITE(*, cform_err)
+         WRITE(*, *) 'lib_mpp: Error in routine mpi_initialized'
+         CALL mpi_abort( mpi_comm_world, code, ierr )
+      ENDIF
+
+      IF( mpi_was_called ) THEN
+         !
+         SELECT CASE ( cn_mpi_send )
+         CASE ( 'S' )                ! Standard mpi send (blocking)
+            WRITE(ldtxt(ii),*) '           Standard blocking mpi send (send)'             ;   ii = ii + 1
+         CASE ( 'B' )                ! Buffer mpi send (blocking)
+            WRITE(ldtxt(ii),*) '           Buffer blocking mpi send (bsend)'              ;   ii = ii + 1
+            IF( Agrif_Root() )   CALL mpi_init_oce( ldtxt, ii, ierr )
+         CASE ( 'I' )                ! Immediate mpi send (non-blocking send)
+            WRITE(ldtxt(ii),*) '           Immediate non-blocking send (isend)'           ;   ii = ii + 1
+            l_isend = .TRUE.
+         CASE DEFAULT
+            WRITE(ldtxt(ii),cform_err)                                                    ;   ii = ii + 1
+            WRITE(ldtxt(ii),*) '           bad value for cn_mpi_send = ', cn_mpi_send     ;   ii = ii + 1
+            kstop = kstop + 1
+         END SELECT
+         !
+      ELSEIF ( PRESENT(localComm) .AND. .NOT. mpi_was_called ) THEN
+         WRITE(ldtxt(ii),*) ' lib_mpp: You cannot provide a local communicator '          ;   ii = ii + 1
+         WRITE(ldtxt(ii),*) '          without calling MPI_Init before ! '                ;   ii = ii + 1
+         kstop = kstop + 1
+      ELSE
+         SELECT CASE ( cn_mpi_send )
+         CASE ( 'S' )                ! Standard mpi send (blocking)
+            WRITE(ldtxt(ii),*) '           Standard blocking mpi send (send)'             ;   ii = ii + 1
+            CALL mpi_init( ierr )
+         CASE ( 'B' )                ! Buffer mpi send (blocking)
+            WRITE(ldtxt(ii),*) '           Buffer blocking mpi send (bsend)'              ;   ii = ii + 1
+            IF( Agrif_Root() )   CALL mpi_init_oce( ldtxt, ii, ierr )
+         CASE ( 'I' )                ! Immediate mpi send (non-blocking send)
+            WRITE(ldtxt(ii),*) '           Immediate non-blocking send (isend)'           ;   ii = ii + 1
+            l_isend = .TRUE.
+            CALL mpi_init( ierr )
+         CASE DEFAULT
+            WRITE(ldtxt(ii),cform_err)                                                    ;   ii = ii + 1
+            WRITE(ldtxt(ii),*) '           bad value for cn_mpi_send = ', cn_mpi_send     ;   ii = ii + 1
+            kstop = kstop + 1
+         END SELECT
+         !
+      ENDIF
+
+      IF( PRESENT(localComm) ) THEN
+         IF( Agrif_Root() ) THEN
+            mpi_comm_oce = localComm
+         ENDIF
+      ELSE
+         CALL mpi_comm_dup( mpi_comm_world, mpi_comm_oce, code)
+         IF( code /= MPI_SUCCESS ) THEN
+            DO ji = 1, SIZE(ldtxt)
+               IF( TRIM(ldtxt(ji)) /= '' )   WRITE(*,*) ldtxt(ji)      ! control print of mynode
+            END DO
+            WRITE(*, cform_err)
+            WRITE(*, *) ' lib_mpp: Error in routine mpi_comm_dup'
+            CALL mpi_abort( mpi_comm_world, code, ierr )
+         ENDIF
+      ENDIF
+
+#if defined key_agrif
+      IF( Agrif_Root() ) THEN
+         CALL Agrif_MPI_Init(mpi_comm_oce)
+      ELSE
+         CALL Agrif_MPI_set_grid_comm(mpi_comm_oce)
+      ENDIF
+#endif
+
+      CALL mpi_comm_rank( mpi_comm_oce, mpprank, ierr )
+      CALL mpi_comm_size( mpi_comm_oce, mppsize, ierr )
+      mynode = mpprank
+
+      IF( mynode == 0 ) THEN
+         CALL ctl_opn( kumond, TRIM(ldname), 'UNKNOWN', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. , 1 )
+         WRITE(kumond, nammpp)      
+      ENDIF
+      !
+      CALL MPI_OP_CREATE(DDPDD_MPI, .TRUE., MPI_SUMDD, ierr)
+      !
+   END FUNCTION mynode
+
+   !!----------------------------------------------------------------------
+   !!                   ***  routine mpp_lnk_(2,3,4)d  ***
+   !!
+   !!   * Argument : dummy argument use in mpp_lnk_... routines
+   !!                ptab   :   array or pointer of arrays on which the boundary condition is applied
+   !!                cd_nat :   nature of array grid-points
+   !!                psgn   :   sign used across the north fold boundary
+   !!                kfld   :   optional, number of pt3d arrays
+   !!                cd_mpp :   optional, fill the overlap area only
+   !!                pval   :   optional, background value (used at closed boundaries)
+   !!----------------------------------------------------------------------
+   !
+   !                       !==  2D array and array of 2D pointer  ==!
+   !
+#  define DIM_2d
+#     define ROUTINE_LNK           mpp_lnk_2d
+#     include "mpp_lnk_generic.h90"
+#     undef ROUTINE_LNK
+#     define MULTI
+#     define ROUTINE_LNK           mpp_lnk_2d_ptr
+#     include "mpp_lnk_generic.h90"
+#     undef ROUTINE_LNK
+#     undef MULTI
+#  undef DIM_2d
+   !
+   !                       !==  3D array and array of 3D pointer  ==!
+   !
+#  define DIM_3d
+#     define ROUTINE_LNK           mpp_lnk_3d
+#     include "mpp_lnk_generic.h90"
+#     undef ROUTINE_LNK
+#     define MULTI
+#     define ROUTINE_LNK           mpp_lnk_3d_ptr
+#     include "mpp_lnk_generic.h90"
+#     undef ROUTINE_LNK
+#     undef MULTI
+#  undef DIM_3d
+   !
+   !                       !==  4D array and array of 4D pointer  ==!
+   !
+#  define DIM_4d
+#     define ROUTINE_LNK           mpp_lnk_4d
+#     include "mpp_lnk_generic.h90"
+#     undef ROUTINE_LNK
+#     define MULTI
+#     define ROUTINE_LNK           mpp_lnk_4d_ptr
+#     include "mpp_lnk_generic.h90"
+#     undef ROUTINE_LNK
+#     undef MULTI
+#  undef DIM_4d
+
+   !!----------------------------------------------------------------------
+   !!                   ***  routine mpp_nfd_(2,3,4)d  ***
+   !!
+   !!   * Argument : dummy argument use in mpp_nfd_... routines
+   !!                ptab   :   array or pointer of arrays on which the boundary condition is applied
+   !!                cd_nat :   nature of array grid-points
+   !!                psgn   :   sign used across the north fold boundary
+   !!                kfld   :   optional, number of pt3d arrays
+   !!                cd_mpp :   optional, fill the overlap area only
+   !!                pval   :   optional, background value (used at closed boundaries)
+   !!----------------------------------------------------------------------
+   !
+   !                       !==  2D array and array of 2D pointer  ==!
+   !
+#  define DIM_2d
+#     define ROUTINE_NFD           mpp_nfd_2d
+#     include "mpp_nfd_generic.h90"
+#     undef ROUTINE_NFD
+#     define MULTI
+#     define ROUTINE_NFD           mpp_nfd_2d_ptr
+#     include "mpp_nfd_generic.h90"
+#     undef ROUTINE_NFD
+#     undef MULTI
+#  undef DIM_2d
+   !
+   !                       !==  3D array and array of 3D pointer  ==!
+   !
+#  define DIM_3d
+#     define ROUTINE_NFD           mpp_nfd_3d
+#     include "mpp_nfd_generic.h90"
+#     undef ROUTINE_NFD
+#     define MULTI
+#     define ROUTINE_NFD           mpp_nfd_3d_ptr
+#     include "mpp_nfd_generic.h90"
+#     undef ROUTINE_NFD
+#     undef MULTI
+#  undef DIM_3d
+   !
+   !                       !==  4D array and array of 4D pointer  ==!
+   !
+#  define DIM_4d
+#     define ROUTINE_NFD           mpp_nfd_4d
+#     include "mpp_nfd_generic.h90"
+#     undef ROUTINE_NFD
+#     define MULTI
+#     define ROUTINE_NFD           mpp_nfd_4d_ptr
+#     include "mpp_nfd_generic.h90"
+#     undef ROUTINE_NFD
+#     undef MULTI
+#  undef DIM_4d
+
+
+   !!----------------------------------------------------------------------
+   !!                   ***  routine mpp_lnk_bdy_(2,3,4)d  ***
+   !!
+   !!   * Argument : dummy argument use in mpp_lnk_... routines
+   !!                ptab   :   array or pointer of arrays on which the boundary condition is applied
+   !!                cd_nat :   nature of array grid-points
+   !!                psgn   :   sign used across the north fold boundary
+   !!                kb_bdy :   BDY boundary set
+   !!                kfld   :   optional, number of pt3d arrays
+   !!----------------------------------------------------------------------
+   !
+   !                       !==  2D array and array of 2D pointer  ==!
+   !
+#  define DIM_2d
+#     define ROUTINE_BDY           mpp_lnk_bdy_2d
+#     include "mpp_bdy_generic.h90"
+#     undef ROUTINE_BDY
+#  undef DIM_2d
+   !
+   !                       !==  3D array and array of 3D pointer  ==!
+   !
+#  define DIM_3d
+#     define ROUTINE_BDY           mpp_lnk_bdy_3d
+#     include "mpp_bdy_generic.h90"
+#     undef ROUTINE_BDY
+#  undef DIM_3d
+   !
+   !                       !==  4D array and array of 4D pointer  ==!
+   !
+!!#  define DIM_4d
+!!#     define ROUTINE_BDY           mpp_lnk_bdy_4d
+!!#     include "mpp_bdy_generic.h90"
+!!#     undef ROUTINE_BDY
+!!#  undef DIM_4d
+
+   !!----------------------------------------------------------------------
+   !!
+   !!   load_array  &   mpp_lnk_2d_9    à generaliser a 3D et 4D
+   
+   
+   !!    mpp_lnk_sum_2d et 3D   ====>>>>>>   à virer du code !!!!
+   
+   
+   !!----------------------------------------------------------------------
+
+
+
+   SUBROUTINE mppsend( ktyp, pmess, kbytes, kdest, md_req )
+      !!----------------------------------------------------------------------
+      !!                  ***  routine mppsend  ***
+      !!
+      !! ** Purpose :   Send messag passing array
+      !!
+      !!----------------------------------------------------------------------
+      REAL(wp), INTENT(inout) ::   pmess(*)   ! array of real
+      INTEGER , INTENT(in   ) ::   kbytes     ! size of the array pmess
+      INTEGER , INTENT(in   ) ::   kdest      ! receive process number
+      INTEGER , INTENT(in   ) ::   ktyp       ! tag of the message
+      INTEGER , INTENT(in   ) ::   md_req     ! argument for isend
+      !!
+      INTEGER ::   iflag
+      !!----------------------------------------------------------------------
+      !
+      SELECT CASE ( cn_mpi_send )
+      CASE ( 'S' )                ! Standard mpi send (blocking)
+         CALL mpi_send ( pmess, kbytes, mpi_double_precision, kdest , ktyp, mpi_comm_oce        , iflag )
+      CASE ( 'B' )                ! Buffer mpi send (blocking)
+         CALL mpi_bsend( pmess, kbytes, mpi_double_precision, kdest , ktyp, mpi_comm_oce        , iflag )
+      CASE ( 'I' )                ! Immediate mpi send (non-blocking send)
+         ! be carefull, one more argument here : the mpi request identifier..
+         CALL mpi_isend( pmess, kbytes, mpi_double_precision, kdest , ktyp, mpi_comm_oce, md_req, iflag )
+      END SELECT
+      !
+   END SUBROUTINE mppsend
+
+
+   SUBROUTINE mpprecv( ktyp, pmess, kbytes, ksource )
+      !!----------------------------------------------------------------------
+      !!                  ***  routine mpprecv  ***
+      !!
+      !! ** Purpose :   Receive messag passing array
+      !!
+      !!----------------------------------------------------------------------
+      REAL(wp), INTENT(inout) ::   pmess(*)   ! array of real
+      INTEGER , INTENT(in   ) ::   kbytes     ! suze of the array pmess
+      INTEGER , INTENT(in   ) ::   ktyp       ! Tag of the recevied message
+      INTEGER, OPTIONAL, INTENT(in) :: ksource    ! source process number
+      !!
+      INTEGER :: istatus(mpi_status_size)
+      INTEGER :: iflag
+      INTEGER :: use_source
+      !!----------------------------------------------------------------------
+      !
+      ! If a specific process number has been passed to the receive call,
+      ! use that one. Default is to use mpi_any_source
+      use_source = mpi_any_source
+      IF( PRESENT(ksource) )   use_source = ksource
+      !
+      CALL mpi_recv( pmess, kbytes, mpi_double_precision, use_source, ktyp, mpi_comm_oce, istatus, iflag )
+      !
+   END SUBROUTINE mpprecv
+
+
+   SUBROUTINE mppgather( ptab, kp, pio )
+      !!----------------------------------------------------------------------
+      !!                   ***  routine mppgather  ***
+      !!
+      !! ** Purpose :   Transfert between a local subdomain array and a work
+      !!     array which is distributed following the vertical level.
+      !!
+      !!----------------------------------------------------------------------
+      REAL(wp), DIMENSION(jpi,jpj)      , INTENT(in   ) ::   ptab   ! subdomain input array
+      INTEGER                           , INTENT(in   ) ::   kp     ! record length
+      REAL(wp), DIMENSION(jpi,jpj,jpnij), INTENT(  out) ::   pio    ! subdomain input array
+      !!
+      INTEGER :: itaille, ierror   ! temporary integer
+      !!---------------------------------------------------------------------
+      !
+      itaille = jpi * jpj
+      CALL mpi_gather( ptab, itaille, mpi_double_precision, pio, itaille     ,   &
+         &                            mpi_double_precision, kp , mpi_comm_oce, ierror )
+      !
+   END SUBROUTINE mppgather
+
+
+   SUBROUTINE mppscatter( pio, kp, ptab )
+      !!----------------------------------------------------------------------
+      !!                  ***  routine mppscatter  ***
+      !!
+      !! ** Purpose :   Transfert between awork array which is distributed
+      !!      following the vertical level and the local subdomain array.
+      !!
+      !!----------------------------------------------------------------------
+      REAL(wp), DIMENSION(jpi,jpj,jpnij)  ::   pio    ! output array
+      INTEGER                             ::   kp     ! Tag (not used with MPI
+      REAL(wp), DIMENSION(jpi,jpj)        ::   ptab   ! subdomain array input
+      !!
+      INTEGER :: itaille, ierror   ! temporary integer
+      !!---------------------------------------------------------------------
+      !
+      itaille = jpi * jpj
+      !
+      CALL mpi_scatter( pio, itaille, mpi_double_precision, ptab, itaille     ,   &
+         &                            mpi_double_precision, kp  , mpi_comm_oce, ierror )
+      !
+   END SUBROUTINE mppscatter
+
+   !!----------------------------------------------------------------------
+   !!    ***  mppmax_a_int, mppmax_int, mppmax_a_real, mppmax_real  ***
+   !!   
+   !!----------------------------------------------------------------------
+   !!
+   SUBROUTINE mppmax_a_int( ktab, kdim, kcom )
+      !!----------------------------------------------------------------------
+      INTEGER , INTENT(in   )                  ::   kdim   ! size of array
+      INTEGER , INTENT(inout), DIMENSION(kdim) ::   ktab   ! input array
+      INTEGER , INTENT(in   ), OPTIONAL        ::   kcom   !
+      INTEGER :: ierror, ilocalcomm   ! temporary integer
+      INTEGER, DIMENSION(kdim) ::   iwork
+      !!----------------------------------------------------------------------
+      ilocalcomm = mpi_comm_oce
+      IF( PRESENT(kcom) )   ilocalcomm = kcom
+      CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer, mpi_max, ilocalcomm, ierror )
+      ktab(:) = iwork(:)
+   END SUBROUTINE mppmax_a_int
+   !!
+   SUBROUTINE mppmax_int( ktab, kcom )
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT(inout)           ::   ktab   ! ???
+      INTEGER, INTENT(in   ), OPTIONAL ::   kcom   ! ???
+      INTEGER ::   ierror, iwork, ilocalcomm   ! temporary integer
+      !!----------------------------------------------------------------------
+      ilocalcomm = mpi_comm_oce
+      IF( PRESENT(kcom) )   ilocalcomm = kcom
+      CALL mpi_allreduce( ktab, iwork, 1, mpi_integer, mpi_max, ilocalcomm, ierror )
+      ktab = iwork
+   END SUBROUTINE mppmax_int
+   !!
+   SUBROUTINE mppmax_a_real( ptab, kdim, kcom )
+      !!----------------------------------------------------------------------
+      REAL(wp), DIMENSION(kdim), INTENT(inout) ::   ptab
+      INTEGER                  , INTENT(in   ) ::   kdim
+      INTEGER , OPTIONAL       , INTENT(in   ) ::   kcom
+      INTEGER :: ierror, ilocalcomm
+      REAL(wp), DIMENSION(kdim) ::  zwork
+      !!----------------------------------------------------------------------
+      ilocalcomm = mpi_comm_oce
+      IF( PRESENT(kcom) )   ilocalcomm = kcom
+      CALL mpi_allreduce( ptab, zwork, kdim, mpi_double_precision, mpi_max, ilocalcomm, ierror )
+      ptab(:) = zwork(:)
+   END SUBROUTINE mppmax_a_real
+   !!
+   SUBROUTINE mppmax_real( ptab, kcom )
+      !!----------------------------------------------------------------------
+      REAL(wp), INTENT(inout)           ::   ptab   ! ???
+      INTEGER , INTENT(in   ), OPTIONAL ::   kcom   ! ???
+      INTEGER  ::   ierror, ilocalcomm
+      REAL(wp) ::   zwork
+      !!----------------------------------------------------------------------
+      ilocalcomm = mpi_comm_oce
+      IF( PRESENT(kcom) )   ilocalcomm = kcom!
+      CALL mpi_allreduce( ptab, zwork, 1, mpi_double_precision, mpi_max, ilocalcomm, ierror )
+      ptab = zwork
+   END SUBROUTINE mppmax_real
+
+
+   !!----------------------------------------------------------------------
+   !!    ***  mppmin_a_int, mppmin_int, mppmin_a_real, mppmin_real  ***
+   !!   
+   !!----------------------------------------------------------------------
+   !!
+   SUBROUTINE mppmin_a_int( ktab, kdim, kcom )
+      !!----------------------------------------------------------------------
+      INTEGER , INTENT( in  )                  ::   kdim   ! size of array
+      INTEGER , INTENT(inout), DIMENSION(kdim) ::   ktab   ! input array
+      INTEGER , INTENT( in  ), OPTIONAL        ::   kcom   ! input array
+      !!
+      INTEGER ::   ierror, ilocalcomm   ! temporary integer
+      INTEGER, DIMENSION(kdim) ::   iwork
+      !!----------------------------------------------------------------------
+      ilocalcomm = mpi_comm_oce
+      IF( PRESENT(kcom) )   ilocalcomm = kcom
+      CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer, mpi_min, ilocalcomm, ierror )
+      ktab(:) = iwork(:)
+   END SUBROUTINE mppmin_a_int
+   !!
+   SUBROUTINE mppmin_int( ktab, kcom )
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT(inout) ::   ktab      ! ???
+      INTEGER , INTENT( in  ), OPTIONAL        ::   kcom        ! input array
+      !!
+      INTEGER ::  ierror, iwork, ilocalcomm
+      !!----------------------------------------------------------------------
+      ilocalcomm = mpi_comm_oce
+      IF( PRESENT(kcom) )   ilocalcomm = kcom
+      CALL mpi_allreduce( ktab, iwork, 1, mpi_integer, mpi_min, ilocalcomm, ierror )
+      ktab = iwork
+   END SUBROUTINE mppmin_int
+   !!
+   SUBROUTINE mppmin_a_real( ptab, kdim, kcom )
+      !!----------------------------------------------------------------------
+      INTEGER , INTENT(in   )                  ::   kdim
+      REAL(wp), INTENT(inout), DIMENSION(kdim) ::   ptab
+      INTEGER , INTENT(in   ), OPTIONAL        ::   kcom
+      INTEGER :: ierror, ilocalcomm
+      REAL(wp), DIMENSION(kdim) ::   zwork
+      !!-----------------------------------------------------------------------
+      ilocalcomm = mpi_comm_oce
+      IF( PRESENT(kcom) )   ilocalcomm = kcom
+      CALL mpi_allreduce( ptab, zwork, kdim, mpi_double_precision, mpi_min, ilocalcomm, ierror )
+      ptab(:) = zwork(:)
+   END SUBROUTINE mppmin_a_real
+   !!
+   SUBROUTINE mppmin_real( ptab, kcom )
+      !!-----------------------------------------------------------------------
+      REAL(wp), INTENT(inout)           ::   ptab        !
+      INTEGER , INTENT(in   ), OPTIONAL :: kcom
+      INTEGER  ::   ierror, ilocalcomm
+      REAL(wp) ::   zwork
+      !!-----------------------------------------------------------------------
+      ilocalcomm = mpi_comm_oce
+      IF( PRESENT(kcom) )   ilocalcomm = kcom
+      CALL mpi_allreduce( ptab, zwork, 1, mpi_double_precision, mpi_min, ilocalcomm, ierror )
+      ptab = zwork
+   END SUBROUTINE mppmin_real
+
+
+   !!----------------------------------------------------------------------
+   !!    ***  mppsum_a_int, mppsum_int, mppsum_a_real, mppsum_real  ***
+   !!   
+   !!   Global sum of 1D array or a variable (integer, real or complex)
+   !!----------------------------------------------------------------------
+   !!
+   SUBROUTINE mppsum_a_int( ktab, kdim )
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT(in   )                   ::   kdim   ! ???
+      INTEGER, INTENT(inout), DIMENSION (kdim) ::   ktab   ! ???
+      INTEGER :: ierror
+      INTEGER, DIMENSION (kdim) ::  iwork
+      !!----------------------------------------------------------------------
+      CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer, mpi_sum, mpi_comm_oce, ierror )
+      ktab(:) = iwork(:)
+   END SUBROUTINE mppsum_a_int
+   !!
+   SUBROUTINE mppsum_int( ktab )
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT(inout) ::   ktab
+      INTEGER :: ierror, iwork
+      !!----------------------------------------------------------------------
+      CALL mpi_allreduce( ktab, iwork, 1, mpi_integer, mpi_sum, mpi_comm_oce, ierror )
+      ktab = iwork
+   END SUBROUTINE mppsum_int
+   !!
+   SUBROUTINE mppsum_a_real( ptab, kdim, kcom )
+      !!-----------------------------------------------------------------------
+      INTEGER                  , INTENT(in   ) ::   kdim   ! size of ptab
+      REAL(wp), DIMENSION(kdim), INTENT(inout) ::   ptab   ! input array
+      INTEGER , OPTIONAL       , INTENT(in   ) ::   kcom   ! specific communicator
+      INTEGER  ::   ierror, ilocalcomm    ! local integer
+      REAL(wp) ::   zwork(kdim)           ! local workspace
+      !!-----------------------------------------------------------------------
+      ilocalcomm = mpi_comm_oce
+      IF( PRESENT(kcom) )   ilocalcomm = kcom
+      CALL mpi_allreduce( ptab, zwork, kdim, mpi_double_precision, mpi_sum, ilocalcomm, ierror )
+      ptab(:) = zwork(:)
+   END SUBROUTINE mppsum_a_real
+   !!
+   SUBROUTINE mppsum_real( ptab, kcom )
+      !!-----------------------------------------------------------------------
+      REAL(wp)          , INTENT(inout)           ::   ptab   ! input scalar
+      INTEGER , OPTIONAL, INTENT(in   ) ::   kcom
+      INTEGER  ::   ierror, ilocalcomm
+      REAL(wp) ::   zwork
+      !!-----------------------------------------------------------------------
+      ilocalcomm = mpi_comm_oce
+      IF( PRESENT(kcom) )   ilocalcomm = kcom
+      CALL mpi_allreduce( ptab, zwork, 1, mpi_double_precision, mpi_sum, ilocalcomm, ierror )
+      ptab = zwork
+   END SUBROUTINE mppsum_real
+   !!
+   SUBROUTINE mppsum_realdd( ytab, kcom )
+      !!-----------------------------------------------------------------------
+      COMPLEX(wp)          , INTENT(inout) ::   ytab    ! input scalar
+      INTEGER    , OPTIONAL, INTENT(in   ) ::   kcom
+      INTEGER     ::   ierror, ilocalcomm
+      COMPLEX(wp) ::   zwork
+      !!-----------------------------------------------------------------------
+      ilocalcomm = mpi_comm_oce
+      IF( PRESENT(kcom) )   ilocalcomm = kcom
+      CALL MPI_ALLREDUCE( ytab, zwork, 1, MPI_DOUBLE_COMPLEX, MPI_SUMDD, ilocalcomm, ierror )
+      ytab = zwork
+   END SUBROUTINE mppsum_realdd
+   !!
+   SUBROUTINE mppsum_a_realdd( ytab, kdim, kcom )
+      !!----------------------------------------------------------------------
+      INTEGER                     , INTENT(in   ) ::   kdim   ! size of ytab
+      COMPLEX(wp), DIMENSION(kdim), INTENT(inout) ::   ytab   ! input array
+      INTEGER    , OPTIONAL       , INTENT(in   ) ::   kcom
+      INTEGER:: ierror, ilocalcomm    ! local integer
+      COMPLEX(wp), DIMENSION(kdim) :: zwork     ! temporary workspace
+      !!-----------------------------------------------------------------------
+      ilocalcomm = mpi_comm_oce
+      IF( PRESENT(kcom) )   ilocalcomm = kcom
+      CALL MPI_ALLREDUCE( ytab, zwork, kdim, MPI_DOUBLE_COMPLEX, MPI_SUMDD, ilocalcomm, ierror )
+      ytab(:) = zwork(:)
+   END SUBROUTINE mppsum_a_realdd
+   
+
+   SUBROUTINE mppmax_real_multiple( pt1d, kdim, kcom  )
+      !!----------------------------------------------------------------------
+      !!                  ***  routine mppmax_real  ***
+      !!
+      !! ** Purpose :   Maximum across processor of each element of a 1D arrays
+      !!
+      !!----------------------------------------------------------------------
+      REAL(wp), DIMENSION(kdim), INTENT(inout) ::   pt1d   ! 1D arrays
+      INTEGER                  , INTENT(in   ) ::   kdim
+      INTEGER , OPTIONAL       , INTENT(in   ) ::   kcom   ! local communicator
+      !!
+      INTEGER  ::   ierror, ilocalcomm
+      REAL(wp), DIMENSION(kdim) ::  zwork
+      !!----------------------------------------------------------------------
+      ilocalcomm = mpi_comm_oce
+      IF( PRESENT(kcom) )   ilocalcomm = kcom
+      !
+      CALL mpi_allreduce( pt1d, zwork, kdim, mpi_double_precision, mpi_max, ilocalcomm, ierror )
+      pt1d(:) = zwork(:)
+      !
+   END SUBROUTINE mppmax_real_multiple
+
+
+   SUBROUTINE mpp_minloc2d( ptab, pmask, pmin, ki,kj )
+      !!------------------------------------------------------------------------
+      !!             ***  routine mpp_minloc  ***
+      !!
+      !! ** Purpose :   Compute the global minimum of an array ptab
+      !!              and also give its global position
+      !!
+      !! ** Method  :   Use MPI_ALLREDUCE with MPI_MINLOC
+      !!
+      !!--------------------------------------------------------------------------
+      REAL(wp), DIMENSION (jpi,jpj), INTENT(in   ) ::   ptab    ! Local 2D array
+      REAL(wp), DIMENSION (jpi,jpj), INTENT(in   ) ::   pmask   ! Local mask
+      REAL(wp)                     , INTENT(  out) ::   pmin    ! Global minimum of ptab
+      INTEGER                      , INTENT(  out) ::   ki, kj  ! index of minimum in global frame
+      !
+      INTEGER :: ierror
+      INTEGER , DIMENSION(2)   ::   ilocs
+      REAL(wp) ::   zmin   ! local minimum
+      REAL(wp), DIMENSION(2,1) ::   zain, zaout
+      !!-----------------------------------------------------------------------
+      !
+      zmin  = MINVAL( ptab(:,:) , mask= pmask == 1._wp )
+      ilocs = MINLOC( ptab(:,:) , mask= pmask == 1._wp )
+      !
+      ki = ilocs(1) + nimpp - 1
+      kj = ilocs(2) + njmpp - 1
+      !
+      zain(1,:)=zmin
+      zain(2,:)=ki+10000.*kj
+      !
+      CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MINLOC,MPI_COMM_OCE,ierror)
+      !
+      pmin = zaout(1,1)
+      kj = INT(zaout(2,1)/10000.)
+      ki = INT(zaout(2,1) - 10000.*kj )
+      !
+   END SUBROUTINE mpp_minloc2d
+
+
+   SUBROUTINE mpp_minloc3d( ptab, pmask, pmin, ki, kj ,kk)
+      !!------------------------------------------------------------------------
+      !!             ***  routine mpp_minloc  ***
+      !!
+      !! ** Purpose :   Compute the global minimum of an array ptab
+      !!              and also give its global position
+      !!
+      !! ** Method  :   Use MPI_ALLREDUCE with MPI_MINLOC
+      !!
+      !!--------------------------------------------------------------------------
+      REAL(wp), DIMENSION(:,:,:), INTENT(in   ) ::   ptab         ! Local 2D array
+      REAL(wp), DIMENSION(:,:,:), INTENT(in   ) ::   pmask        ! Local mask
+      REAL(wp)                  , INTENT(  out) ::   pmin         ! Global minimum of ptab
+      INTEGER                   , INTENT(  out) ::   ki, kj, kk   ! index of minimum in global frame
+      !
+      INTEGER  ::   ierror
+      REAL(wp) ::   zmin     ! local minimum
+      INTEGER , DIMENSION(3)   ::   ilocs
+      REAL(wp), DIMENSION(2,1) ::   zain, zaout
+      !!-----------------------------------------------------------------------
+      !
+      zmin  = MINVAL( ptab(:,:,:) , mask= pmask == 1._wp )
+      ilocs = MINLOC( ptab(:,:,:) , mask= pmask == 1._wp )
+      !
+      ki = ilocs(1) + nimpp - 1
+      kj = ilocs(2) + njmpp - 1
+      kk = ilocs(3)
+      !
+      zain(1,:) = zmin
+      zain(2,:) = ki + 10000.*kj + 100000000.*kk
+      !
+      CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MINLOC,MPI_COMM_OCE,ierror)
+      !
+      pmin = zaout(1,1)
+      kk   = INT( zaout(2,1) / 100000000. )
+      kj   = INT( zaout(2,1) - kk * 100000000. ) / 10000
+      ki   = INT( zaout(2,1) - kk * 100000000. -kj * 10000. )
+      !
+   END SUBROUTINE mpp_minloc3d
+
+
+   SUBROUTINE mpp_maxloc2d( ptab, pmask, pmax, ki, kj )
+      !!------------------------------------------------------------------------
+      !!             ***  routine mpp_maxloc  ***
+      !!
+      !! ** Purpose :   Compute the global maximum of an array ptab
+      !!              and also give its global position
+      !!
+      !! ** Method  :   Use MPI_ALLREDUCE with MPI_MINLOC
+      !!
+      !!--------------------------------------------------------------------------
+      REAL(wp), DIMENSION (jpi,jpj), INTENT(in   ) ::   ptab     ! Local 2D array
+      REAL(wp), DIMENSION (jpi,jpj), INTENT(in   ) ::   pmask    ! Local mask
+      REAL(wp)                     , INTENT(  out) ::   pmax     ! Global maximum of ptab
+      INTEGER                      , INTENT(  out) ::   ki, kj   ! index of maximum in global frame
+      !!
+      INTEGER  :: ierror
+      INTEGER, DIMENSION (2)   ::   ilocs
+      REAL(wp) :: zmax   ! local maximum
+      REAL(wp), DIMENSION(2,1) ::   zain, zaout
+      !!-----------------------------------------------------------------------
+      !
+      zmax  = MAXVAL( ptab(:,:) , mask= pmask == 1._wp )
+      ilocs = MAXLOC( ptab(:,:) , mask= pmask == 1._wp )
+      !
+      ki = ilocs(1) + nimpp - 1
+      kj = ilocs(2) + njmpp - 1
+      !
+      zain(1,:) = zmax
+      zain(2,:) = ki + 10000. * kj
+      !
+      CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MAXLOC,MPI_COMM_OCE,ierror)
+      !
+      pmax = zaout(1,1)
+      kj   = INT( zaout(2,1) / 10000.     )
+      ki   = INT( zaout(2,1) - 10000.* kj )
+      !
+   END SUBROUTINE mpp_maxloc2d
+
+
+   SUBROUTINE mpp_maxloc3d( ptab, pmask, pmax, ki, kj, kk )
+      !!------------------------------------------------------------------------
+      !!             ***  routine mpp_maxloc  ***
+      !!
+      !! ** Purpose :  Compute the global maximum of an array ptab
+      !!              and also give its global position
+      !!
+      !! ** Method : Use MPI_ALLREDUCE with MPI_MINLOC
+      !!
+      !!--------------------------------------------------------------------------
+      REAL(wp), DIMENSION (:,:,:), INTENT(in   ) ::   ptab         ! Local 2D array
+      REAL(wp), DIMENSION (:,:,:), INTENT(in   ) ::   pmask        ! Local mask
+      REAL(wp)                   , INTENT(  out) ::   pmax         ! Global maximum of ptab
+      INTEGER                    , INTENT(  out) ::   ki, kj, kk   ! index of maximum in global frame
+      !
+      INTEGER  ::   ierror   ! local integer
+      REAL(wp) ::   zmax     ! local maximum
+      REAL(wp), DIMENSION(2,1) ::   zain, zaout
+      INTEGER , DIMENSION(3)   ::   ilocs
+      !!-----------------------------------------------------------------------
+      !
+      zmax  = MAXVAL( ptab(:,:,:) , mask= pmask == 1._wp )
+      ilocs = MAXLOC( ptab(:,:,:) , mask= pmask == 1._wp )
+      !
+      ki = ilocs(1) + nimpp - 1
+      kj = ilocs(2) + njmpp - 1
+      kk = ilocs(3)
+      !
+      zain(1,:) = zmax
+      zain(2,:) = ki + 10000.*kj + 100000000.*kk
+      !
+      CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MAXLOC,MPI_COMM_OCE,ierror)
+      !
+      pmax = zaout(1,1)
+      kk   = INT( zaout(2,1) / 100000000. )
+      kj   = INT( zaout(2,1) - kk * 100000000. ) / 10000
+      ki   = INT( zaout(2,1) - kk * 100000000. -kj * 10000. )
+      !
+   END SUBROUTINE mpp_maxloc3d
+
+
+   SUBROUTINE mppsync()
+      !!----------------------------------------------------------------------
+      !!                  ***  routine mppsync  ***
+      !!
+      !! ** Purpose :   Massively parallel processors, synchroneous
+      !!
+      !!-----------------------------------------------------------------------
+      INTEGER :: ierror
+      !!-----------------------------------------------------------------------
+      !
+      CALL mpi_barrier( mpi_comm_oce, ierror )
+      !
+   END SUBROUTINE mppsync
+
+
+   SUBROUTINE mppstop
+      !!----------------------------------------------------------------------
+      !!                  ***  routine mppstop  ***
+      !!
+      !! ** purpose :   Stop massively parallel processors method
+      !!
+      !!----------------------------------------------------------------------
+      INTEGER ::   info
+      !!----------------------------------------------------------------------
+      !
+      CALL mppsync
+      CALL mpi_finalize( info )
+      !
+   END SUBROUTINE mppstop
+
+
+   SUBROUTINE mpp_comm_free( kcom )
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT(in) ::   kcom
+      !!
+      INTEGER :: ierr
+      !!----------------------------------------------------------------------
+      !
+      CALL MPI_COMM_FREE(kcom, ierr)
+      !
+   END SUBROUTINE mpp_comm_free
+
+
+   SUBROUTINE mpp_ini_ice( pindic, kumout )
+      !!----------------------------------------------------------------------
+      !!               ***  routine mpp_ini_ice  ***
+      !!
+      !! ** Purpose :   Initialize special communicator for ice areas
+      !!      condition together with global variables needed in the ddmpp folding
+      !!
+      !! ** Method  : - Look for ice processors in ice routines
+      !!              - Put their number in nrank_ice
+      !!              - Create groups for the world processors and the ice processors
+      !!              - Create a communicator for ice processors
+      !!
+      !! ** output
+      !!      njmppmax = njmpp for northern procs
+      !!      ndim_rank_ice = number of processors with ice
+      !!      nrank_ice (ndim_rank_ice) = ice processors
+      !!      ngrp_iworld = group ID for the world processors
+      !!      ngrp_ice = group ID for the ice processors
+      !!      ncomm_ice = communicator for the ice procs.
+      !!      n_ice_root = number (in the world) of proc 0 in the ice comm.
+      !!
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT(in) ::   pindic
+      INTEGER, INTENT(in) ::   kumout   ! ocean.output logical unit
+      !!
+      INTEGER :: jjproc
+      INTEGER :: ii, ierr
+      INTEGER, ALLOCATABLE, DIMENSION(:) ::   kice
+      INTEGER, ALLOCATABLE, DIMENSION(:) ::   zwork
+      !!----------------------------------------------------------------------
+      !
+      ALLOCATE( kice(jpnij), zwork(jpnij), STAT=ierr )
+      IF( ierr /= 0 ) THEN
+         WRITE(kumout, cform_err)
+         WRITE(kumout,*) 'mpp_ini_ice : failed to allocate 2, 1D arrays (jpnij in length)'
+         CALL mppstop
+      ENDIF
+
+      ! Look for how many procs with sea-ice
+      !
+      kice = 0
+      DO jjproc = 1, jpnij
+         IF( jjproc == narea .AND. pindic .GT. 0 )   kice(jjproc) = 1
+      END DO
+      !
+      zwork = 0
+      CALL MPI_ALLREDUCE( kice, zwork, jpnij, mpi_integer, mpi_sum, mpi_comm_oce, ierr )
+      ndim_rank_ice = SUM( zwork )
+
+      ! Allocate the right size to nrank_north
+      IF( ALLOCATED ( nrank_ice ) )   DEALLOCATE( nrank_ice )
+      ALLOCATE( nrank_ice(ndim_rank_ice) )
+      !
+      ii = 0
+      nrank_ice = 0
+      DO jjproc = 1, jpnij
+         IF( zwork(jjproc) == 1) THEN
+            ii = ii + 1
+            nrank_ice(ii) = jjproc -1
+         ENDIF
+      END DO
+
+      ! Create the world group
+      CALL MPI_COMM_GROUP( mpi_comm_oce, ngrp_iworld, ierr )
+
+      ! Create the ice group from the world group
+      CALL MPI_GROUP_INCL( ngrp_iworld, ndim_rank_ice, nrank_ice, ngrp_ice, ierr )
+
+      ! Create the ice communicator , ie the pool of procs with sea-ice
+      CALL MPI_COMM_CREATE( mpi_comm_oce, ngrp_ice, ncomm_ice, ierr )
+
+      ! Find proc number in the world of proc 0 in the north
+      ! The following line seems to be useless, we just comment & keep it as reminder
+      ! CALL MPI_GROUP_TRANSLATE_RANKS(ngrp_ice,1,0,ngrp_iworld,n_ice_root,ierr)
+      !
+      CALL MPI_GROUP_FREE(ngrp_ice, ierr)
+      CALL MPI_GROUP_FREE(ngrp_iworld, ierr)
+
+      DEALLOCATE(kice, zwork)
+      !
+   END SUBROUTINE mpp_ini_ice
+
+
+   SUBROUTINE mpp_ini_znl( kumout )
+      !!----------------------------------------------------------------------
+      !!               ***  routine mpp_ini_znl  ***
+      !!
+      !! ** Purpose :   Initialize special communicator for computing zonal sum
+      !!
+      !! ** Method  : - Look for processors in the same row
+      !!              - Put their number in nrank_znl
+      !!              - Create group for the znl processors
+      !!              - Create a communicator for znl processors
+      !!              - Determine if processor should write znl files
+      !!
+      !! ** output
+      !!      ndim_rank_znl = number of processors on the same row
+      !!      ngrp_znl = group ID for the znl processors
+      !!      ncomm_znl = communicator for the ice procs.
+      !!      n_znl_root = number (in the world) of proc 0 in the ice comm.
+      !!
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT(in) ::   kumout   ! ocean.output logical units
+      !
+      INTEGER :: jproc      ! dummy loop integer
+      INTEGER :: ierr, ii   ! local integer
+      INTEGER, ALLOCATABLE, DIMENSION(:) ::   kwork
+      !!----------------------------------------------------------------------
+      !-$$     WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ngrp_world     : ', ngrp_world
+      !-$$     WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - mpi_comm_world : ', mpi_comm_world
+      !-$$     WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - mpi_comm_oce   : ', mpi_comm_oce
+      !
+      ALLOCATE( kwork(jpnij), STAT=ierr )
+      IF( ierr /= 0 ) THEN
+         WRITE(kumout, cform_err)
+         WRITE(kumout,*) 'mpp_ini_znl : failed to allocate 1D array of length jpnij'
+         CALL mppstop
+      ENDIF
+
+      IF( jpnj == 1 ) THEN
+         ngrp_znl  = ngrp_world
+         ncomm_znl = mpi_comm_oce
+      ELSE
+         !
+         CALL MPI_ALLGATHER ( njmpp, 1, mpi_integer, kwork, 1, mpi_integer, mpi_comm_oce, ierr )
+         !-$$        WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - kwork pour njmpp : ', kwork
+         !-$$        CALL flush(numout)
+         !
+         ! Count number of processors on the same row
+         ndim_rank_znl = 0
+         DO jproc=1,jpnij
+            IF ( kwork(jproc) == njmpp ) THEN
+               ndim_rank_znl = ndim_rank_znl + 1
+            ENDIF
+         END DO
+         !-$$        WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ndim_rank_znl : ', ndim_rank_znl
+         !-$$        CALL flush(numout)
+         ! Allocate the right size to nrank_znl
+         IF (ALLOCATED (nrank_znl)) DEALLOCATE(nrank_znl)
+         ALLOCATE(nrank_znl(ndim_rank_znl))
+         ii = 0
+         nrank_znl (:) = 0
+         DO jproc=1,jpnij
+            IF ( kwork(jproc) == njmpp) THEN
+               ii = ii + 1
+               nrank_znl(ii) = jproc -1
+            ENDIF
+         END DO
+         !-$$        WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - nrank_znl : ', nrank_znl
+         !-$$        CALL flush(numout)
+
+         ! Create the opa group
+         CALL MPI_COMM_GROUP(mpi_comm_oce,ngrp_opa,ierr)
+         !-$$        WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ngrp_opa : ', ngrp_opa
+         !-$$        CALL flush(numout)
+
+         ! Create the znl group from the opa group
+         CALL MPI_GROUP_INCL  ( ngrp_opa, ndim_rank_znl, nrank_znl, ngrp_znl, ierr )
+         !-$$        WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ngrp_znl ', ngrp_znl
+         !-$$        CALL flush(numout)
+
+         ! Create the znl communicator from the opa communicator, ie the pool of procs in the same row
+         CALL MPI_COMM_CREATE ( mpi_comm_oce, ngrp_znl, ncomm_znl, ierr )
+         !-$$        WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ncomm_znl ', ncomm_znl
+         !-$$        CALL flush(numout)
+         !
+      END IF
+
+      ! Determines if processor if the first (starting from i=1) on the row
+      IF ( jpni == 1 ) THEN
+         l_znl_root = .TRUE.
+      ELSE
+         l_znl_root = .FALSE.
+         kwork (1) = nimpp
+         CALL mpp_min ( kwork(1), kcom = ncomm_znl)
+         IF ( nimpp == kwork(1)) l_znl_root = .TRUE.
+      END IF
+
+      DEALLOCATE(kwork)
+
+   END SUBROUTINE mpp_ini_znl
+
+
+   SUBROUTINE mpp_ini_north
+      !!----------------------------------------------------------------------
+      !!               ***  routine mpp_ini_north  ***
+      !!
+      !! ** Purpose :   Initialize special communicator for north folding
+      !!      condition together with global variables needed in the mpp folding
+      !!
+      !! ** Method  : - Look for northern processors
+      !!              - Put their number in nrank_north
+      !!              - Create groups for the world processors and the north processors
+      !!              - Create a communicator for northern processors
+      !!
+      !! ** output
+      !!      njmppmax = njmpp for northern procs
+      !!      ndim_rank_north = number of processors in the northern line
+      !!      nrank_north (ndim_rank_north) = number  of the northern procs.
+      !!      ngrp_world = group ID for the world processors
+      !!      ngrp_north = group ID for the northern processors
+      !!      ncomm_north = communicator for the northern procs.
+      !!      north_root = number (in the world) of proc 0 in the northern comm.
+      !!
+      !!----------------------------------------------------------------------
+      INTEGER ::   ierr
+      INTEGER ::   jjproc
+      INTEGER ::   ii, ji
+      !!----------------------------------------------------------------------
+      !
+      njmppmax = MAXVAL( njmppt )
+      !
+      ! Look for how many procs on the northern boundary
+      ndim_rank_north = 0
+      DO jjproc = 1, jpnij
+         IF( njmppt(jjproc) == njmppmax )   ndim_rank_north = ndim_rank_north + 1
+      END DO
+      !
+      ! Allocate the right size to nrank_north
+      IF (ALLOCATED (nrank_north)) DEALLOCATE(nrank_north)
+      ALLOCATE( nrank_north(ndim_rank_north) )
+
+      ! Fill the nrank_north array with proc. number of northern procs.
+      ! Note : the rank start at 0 in MPI
+      ii = 0
+      DO ji = 1, jpnij
+         IF ( njmppt(ji) == njmppmax   ) THEN
+            ii=ii+1
+            nrank_north(ii)=ji-1
+         END IF
+      END DO
+      !
+      ! create the world group
+      CALL MPI_COMM_GROUP( mpi_comm_oce, ngrp_world, ierr )
+      !
+      ! Create the North group from the world group
+      CALL MPI_GROUP_INCL( ngrp_world, ndim_rank_north, nrank_north, ngrp_north, ierr )
+      !
+      ! Create the North communicator , ie the pool of procs in the north group
+      CALL MPI_COMM_CREATE( mpi_comm_oce, ngrp_north, ncomm_north, ierr )
+      !
+   END SUBROUTINE mpp_ini_north
+
+
+   SUBROUTINE mpi_init_oce( ldtxt, ksft, code )
+      !!---------------------------------------------------------------------
+      !!                   ***  routine mpp_init.opa  ***
+      !!
+      !! ** Purpose :: export and attach a MPI buffer for bsend
+      !!
+      !! ** Method  :: define buffer size in namelist, if 0 no buffer attachment
+      !!            but classical mpi_init
+      !!
+      !! History :: 01/11 :: IDRIS initial version for IBM only
+      !!            08/04 :: R. Benshila, generalisation
+      !!---------------------------------------------------------------------
+      CHARACTER(len=*),DIMENSION(:), INTENT(  out) ::   ldtxt
+      INTEGER                      , INTENT(inout) ::   ksft
+      INTEGER                      , INTENT(  out) ::   code
+      INTEGER                                      ::   ierr, ji
+      LOGICAL                                      ::   mpi_was_called
+      !!---------------------------------------------------------------------
+      !
+      CALL mpi_initialized( mpi_was_called, code )      ! MPI initialization
+      IF ( code /= MPI_SUCCESS ) THEN
+         DO ji = 1, SIZE(ldtxt)
+            IF( TRIM(ldtxt(ji)) /= '' )   WRITE(*,*) ldtxt(ji)      ! control print of mynode
+         END DO
+         WRITE(*, cform_err)
+         WRITE(*, *) ' lib_mpp: Error in routine mpi_initialized'
+         CALL mpi_abort( mpi_comm_world, code, ierr )
+      ENDIF
+      !
+      IF( .NOT. mpi_was_called ) THEN
+         CALL mpi_init( code )
+         CALL mpi_comm_dup( mpi_comm_world, mpi_comm_oce, code )
+         IF ( code /= MPI_SUCCESS ) THEN
+            DO ji = 1, SIZE(ldtxt)
+               IF( TRIM(ldtxt(ji)) /= '' )   WRITE(*,*) ldtxt(ji)      ! control print of mynode
+            END DO
+            WRITE(*, cform_err)
+            WRITE(*, *) ' lib_mpp: Error in routine mpi_comm_dup'
+            CALL mpi_abort( mpi_comm_world, code, ierr )
+         ENDIF
+      ENDIF
+      !
+      IF( nn_buffer > 0 ) THEN
+         WRITE(ldtxt(ksft),*) 'mpi_bsend, buffer allocation of  : ', nn_buffer   ;   ksft = ksft + 1
+         ! Buffer allocation and attachment
+         ALLOCATE( tampon(nn_buffer), stat = ierr )
+         IF( ierr /= 0 ) THEN
+            DO ji = 1, SIZE(ldtxt)
+               IF( TRIM(ldtxt(ji)) /= '' )   WRITE(*,*) ldtxt(ji)      ! control print of mynode
+            END DO
+            WRITE(*, cform_err)
+            WRITE(*, *) ' lib_mpp: Error in ALLOCATE', ierr
+            CALL mpi_abort( mpi_comm_world, code, ierr )
+         END IF
+         CALL mpi_buffer_attach( tampon, nn_buffer, code )
+      ENDIF
+      !
+   END SUBROUTINE mpi_init_oce
+
+
+   SUBROUTINE DDPDD_MPI( ydda, yddb, ilen, itype )
+      !!---------------------------------------------------------------------
+      !!   Routine DDPDD_MPI: used by reduction operator MPI_SUMDD
+      !!
+      !!   Modification of original codes written by David H. Bailey
+      !!   This subroutine computes yddb(i) = ydda(i)+yddb(i)
+      !!---------------------------------------------------------------------
+      INTEGER                     , INTENT(in)    ::   ilen, itype
+      COMPLEX(wp), DIMENSION(ilen), INTENT(in)    ::   ydda
+      COMPLEX(wp), DIMENSION(ilen), INTENT(inout) ::   yddb
+      !
+      REAL(wp) :: zerr, zt1, zt2    ! local work variables
+      INTEGER  :: ji, ztmp           ! local scalar
+      !!---------------------------------------------------------------------
+      !
+      ztmp = itype   ! avoid compilation warning
+      !
+      DO ji=1,ilen
+      ! Compute ydda + yddb using Knuth's trick.
+         zt1  = real(ydda(ji)) + real(yddb(ji))
+         zerr = zt1 - real(ydda(ji))
+         zt2  = ((real(yddb(ji)) - zerr) + (real(ydda(ji)) - (zt1 - zerr))) &
+                + aimag(ydda(ji)) + aimag(yddb(ji))
+
+         ! The result is zt1 + zt2, after normalization.
+         yddb(ji) = cmplx ( zt1 + zt2, zt2 - ((zt1 + zt2) - zt1),wp )
+      END DO
+      !
+   END SUBROUTINE DDPDD_MPI
+
+
+   SUBROUTINE mpp_lbc_north_icb( pt2d, cd_type, psgn, kextj)
+      !!---------------------------------------------------------------------
+      !!                   ***  routine mpp_lbc_north_icb  ***
+      !!
+      !! ** Purpose :   Ensure proper north fold horizontal bondary condition
+      !!              in mpp configuration in case of jpn1 > 1 and for 2d
+      !!              array with outer extra halo
+      !!
+      !! ** Method  :   North fold condition and mpp with more than one proc
+      !!              in i-direction require a specific treatment. We gather
+      !!              the 4+kextj northern lines of the global domain on 1
+      !!              processor and apply lbc north-fold on this sub array.
+      !!              Then we scatter the north fold array back to the processors.
+      !!              This routine accounts for an extra halo with icebergs
+      !!              and assumes ghost rows and columns have been suppressed.
+      !!
+      !!----------------------------------------------------------------------
+      REAL(wp), DIMENSION(:,:), INTENT(inout) ::   pt2d     ! 2D array with extra halo
+      CHARACTER(len=1)        , INTENT(in   ) ::   cd_type  ! nature of pt3d grid-points
+      !                                                     !   = T ,  U , V , F or W -points
+      REAL(wp)                , INTENT(in   ) ::   psgn     ! = -1. the sign change across the
+      !!                                                    ! north fold, =  1. otherwise
+      INTEGER                 , INTENT(in   ) ::   kextj    ! Extra halo width at north fold
+      !
+      INTEGER ::   ji, jj, jr
+      INTEGER ::   ierr, itaille, ildi, ilei, iilb
+      INTEGER ::   ipj, ij, iproc
+      !
+      REAL(wp), DIMENSION(:,:)  , ALLOCATABLE  ::  ztab_e, znorthloc_e
+      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE  ::  znorthgloio_e
+      !!----------------------------------------------------------------------
+      !
+      ipj=4
+      ALLOCATE(        ztab_e(jpiglo, 1-kextj:ipj+kextj)       ,       &
+     &            znorthloc_e(jpimax, 1-kextj:ipj+kextj)       ,       &
+     &          znorthgloio_e(jpimax, 1-kextj:ipj+kextj,jpni)    )
+      !
+      ztab_e(:,:)      = 0._wp
+      znorthloc_e(:,:) = 0._wp
+      !
+      ij = 1 - kextj
+      ! put the last ipj+2*kextj lines of pt2d into znorthloc_e 
+      DO jj = jpj - ipj + 1 - kextj , jpj + kextj
+         znorthloc_e(1:jpi,ij)=pt2d(1:jpi,jj)
+         ij = ij + 1
+      END DO
+      !
+      itaille = jpimax * ( ipj + 2*kextj )
+      CALL MPI_ALLGATHER( znorthloc_e(1,1-kextj)    , itaille, MPI_DOUBLE_PRECISION,    &
+         &                znorthgloio_e(1,1-kextj,1), itaille, MPI_DOUBLE_PRECISION,    &
+         &                ncomm_north, ierr )
+      !
+      DO jr = 1, ndim_rank_north            ! recover the global north array
+         iproc = nrank_north(jr) + 1
+         ildi = nldit (iproc)
+         ilei = nleit (iproc)
+         iilb = nimppt(iproc)
+         DO jj = 1-kextj, ipj+kextj
+            DO ji = ildi, ilei
+               ztab_e(ji+iilb-1,jj) = znorthgloio_e(ji,jj,jr)
+            END DO
+         END DO
+      END DO
+
+      ! 2. North-Fold boundary conditions
+      ! ----------------------------------
+      CALL lbc_nfd( ztab_e(:,1-kextj:ipj+kextj), cd_type, psgn, kextj )
+
+      ij = 1 - kextj
+      !! Scatter back to pt2d
+      DO jj = jpj - ipj + 1 - kextj , jpj + kextj
+         DO ji= 1, jpi
+            pt2d(ji,jj) = ztab_e(ji+nimpp-1,ij)
+         END DO
+         ij  = ij +1
+      END DO
+      !
+      DEALLOCATE( ztab_e, znorthloc_e, znorthgloio_e )
+      !
+   END SUBROUTINE mpp_lbc_north_icb
+
+
+   SUBROUTINE mpp_lnk_2d_icb( pt2d, cd_type, psgn, kexti, kextj )
+      !!----------------------------------------------------------------------
+      !!                  ***  routine mpp_lnk_2d_icb  ***
+      !!
+      !! ** Purpose :   Message passing management for 2d array (with extra halo for icebergs)
+      !!                This routine receives a (1-kexti:jpi+kexti,1-kexti:jpj+kextj)
+      !!                array (usually (0:jpi+1, 0:jpj+1)) from lbc_lnk_icb calls.
+      !!
+      !! ** Method  :   Use mppsend and mpprecv function for passing mask
+      !!      between processors following neighboring subdomains.
+      !!            domain parameters
+      !!                    jpi    : first dimension of the local subdomain
+      !!                    jpj    : second dimension of the local subdomain
+      !!                    kexti  : number of columns for extra outer halo
+      !!                    kextj  : number of rows for extra outer halo
+      !!                    nbondi : mark for "east-west local boundary"
+      !!                    nbondj : mark for "north-south local boundary"
+      !!                    noea   : number for local neighboring processors
+      !!                    nowe   : number for local neighboring processors
+      !!                    noso   : number for local neighboring processors
+      !!                    nono   : number for local neighboring processors
+      !!----------------------------------------------------------------------
+      REAL(wp), DIMENSION(1-kexti:jpi+kexti,1-kextj:jpj+kextj), INTENT(inout) ::   pt2d     ! 2D array with extra halo
+      CHARACTER(len=1)                                        , INTENT(in   ) ::   cd_type  ! nature of ptab array grid-points
+      REAL(wp)                                                , INTENT(in   ) ::   psgn     ! sign used across the north fold
+      INTEGER                                                 , INTENT(in   ) ::   kexti    ! extra i-halo width
+      INTEGER                                                 , INTENT(in   ) ::   kextj    ! extra j-halo width
+      !
+      INTEGER  ::   jl   ! dummy loop indices
+      INTEGER  ::   imigr, iihom, ijhom        ! local integers
+      INTEGER  ::   ipreci, iprecj             !   -       -
+      INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend
+      INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend
+      !!
+      REAL(wp), DIMENSION(1-kexti:jpi+kexti,nn_hls+kextj,2) ::   r2dns, r2dsn
+      REAL(wp), DIMENSION(1-kextj:jpj+kextj,nn_hls+kexti,2) ::   r2dwe, r2dew
+      !!----------------------------------------------------------------------
+
+      ipreci = nn_hls + kexti      ! take into account outer extra 2D overlap area
+      iprecj = nn_hls + kextj
+
+
+      ! 1. standard boundary treatment
+      ! ------------------------------
+      ! Order matters Here !!!!
+      !
+      !                                      ! East-West boundaries
+      !                                           !* Cyclic east-west
+      IF( nbondi == 2 .AND. (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN
+         pt2d(1-kexti:     1    ,:) = pt2d(jpim1-kexti:  jpim1 ,:)       ! east
+         pt2d(   jpi  :jpi+kexti,:) = pt2d(     2      :2+kexti,:)       ! west
+         !
+      ELSE                                        !* closed
+         IF( .NOT. cd_type == 'F' )   pt2d(  1-kexti   :nn_hls    ,:) = 0._wp    ! south except at F-point
+                                      pt2d(jpi-nn_hls+1:jpi+kexti,:) = 0._wp    ! north
+      ENDIF
+      !
+
+      ! north fold treatment
+      ! -----------------------
+      IF( npolj /= 0 ) THEN
+         !
+         SELECT CASE ( jpni )
+                   CASE ( 1 )     ;   CALL lbc_nfd          ( pt2d(1:jpi,1:jpj+kextj), cd_type, psgn, kextj )
+                   CASE DEFAULT   ;   CALL mpp_lbc_north_icb( pt2d(1:jpi,1:jpj+kextj), cd_type, psgn, kextj )
+         END SELECT
+         !
+      ENDIF
+
+      ! 2. East and west directions exchange
+      ! ------------------------------------
+      ! we play with the neigbours AND the row number because of the periodicity
+      !
+      SELECT CASE ( nbondi )      ! Read Dirichlet lateral conditions
+      CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case)
+         iihom = jpi-nreci-kexti
+         DO jl = 1, ipreci
+            r2dew(:,jl,1) = pt2d(nn_hls+jl,:)
+            r2dwe(:,jl,1) = pt2d(iihom +jl,:)
+         END DO
+      END SELECT
+      !
+      !                           ! Migrations
+      imigr = ipreci * ( jpj + 2*kextj )
+      !
+      SELECT CASE ( nbondi )
+      CASE ( -1 )
+         CALL mppsend( 2, r2dwe(1-kextj,1,1), imigr, noea, ml_req1 )
+         CALL mpprecv( 1, r2dew(1-kextj,1,2), imigr, noea )
+         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
+      CASE ( 0 )
+         CALL mppsend( 1, r2dew(1-kextj,1,1), imigr, nowe, ml_req1 )
+         CALL mppsend( 2, r2dwe(1-kextj,1,1), imigr, noea, ml_req2 )
+         CALL mpprecv( 1, r2dew(1-kextj,1,2), imigr, noea )
+         CALL mpprecv( 2, r2dwe(1-kextj,1,2), imigr, nowe )
+         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
+         IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
+      CASE ( 1 )
+         CALL mppsend( 1, r2dew(1-kextj,1,1), imigr, nowe, ml_req1 )
+         CALL mpprecv( 2, r2dwe(1-kextj,1,2), imigr, nowe )
+         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
+      END SELECT
+      !
+      !                           ! Write Dirichlet lateral conditions
+      iihom = jpi - nn_hls
+      !
+      SELECT CASE ( nbondi )
+      CASE ( -1 )
+         DO jl = 1, ipreci
+            pt2d(iihom+jl,:) = r2dew(:,jl,2)
+         END DO
+      CASE ( 0 )
+         DO jl = 1, ipreci
+            pt2d(jl-kexti,:) = r2dwe(:,jl,2)
+            pt2d(iihom+jl,:) = r2dew(:,jl,2)
+         END DO
+      CASE ( 1 )
+         DO jl = 1, ipreci
+            pt2d(jl-kexti,:) = r2dwe(:,jl,2)
+         END DO
+      END SELECT
+
+
+      ! 3. North and south directions
+      ! -----------------------------
+      ! always closed : we play only with the neigbours
+      !
+      IF( nbondj /= 2 ) THEN      ! Read Dirichlet lateral conditions
+         ijhom = jpj-nrecj-kextj
+         DO jl = 1, iprecj
+            r2dsn(:,jl,1) = pt2d(:,ijhom +jl)
+            r2dns(:,jl,1) = pt2d(:,nn_hls+jl)
+         END DO
+      ENDIF
+      !
+      !                           ! Migrations
+      imigr = iprecj * ( jpi + 2*kexti )
+      !
+      SELECT CASE ( nbondj )
+      CASE ( -1 )
+         CALL mppsend( 4, r2dsn(1-kexti,1,1), imigr, nono, ml_req1 )
+         CALL mpprecv( 3, r2dns(1-kexti,1,2), imigr, nono )
+         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
+      CASE ( 0 )
+         CALL mppsend( 3, r2dns(1-kexti,1,1), imigr, noso, ml_req1 )
+         CALL mppsend( 4, r2dsn(1-kexti,1,1), imigr, nono, ml_req2 )
+         CALL mpprecv( 3, r2dns(1-kexti,1,2), imigr, nono )
+         CALL mpprecv( 4, r2dsn(1-kexti,1,2), imigr, noso )
+         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
+         IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
+      CASE ( 1 )
+         CALL mppsend( 3, r2dns(1-kexti,1,1), imigr, noso, ml_req1 )
+         CALL mpprecv( 4, r2dsn(1-kexti,1,2), imigr, noso )
+         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
+      END SELECT
+      !
+      !                           ! Write Dirichlet lateral conditions
+      ijhom = jpj - nn_hls
+      !
+      SELECT CASE ( nbondj )
+      CASE ( -1 )
+         DO jl = 1, iprecj
+            pt2d(:,ijhom+jl) = r2dns(:,jl,2)
+         END DO
+      CASE ( 0 )
+         DO jl = 1, iprecj
+            pt2d(:,jl-kextj) = r2dsn(:,jl,2)
+            pt2d(:,ijhom+jl) = r2dns(:,jl,2)
+         END DO
+      CASE ( 1 )
+         DO jl = 1, iprecj
+            pt2d(:,jl-kextj) = r2dsn(:,jl,2)
+         END DO
+      END SELECT
+      !
+   END SUBROUTINE mpp_lnk_2d_icb
+   
+#else
+   !!----------------------------------------------------------------------
+   !!   Default case:            Dummy module        share memory computing
+   !!----------------------------------------------------------------------
+   USE in_out_manager
+
+   INTERFACE mpp_sum
+      MODULE PROCEDURE mpp_sum_a2s, mpp_sum_as, mpp_sum_ai, mpp_sum_s, mpp_sum_i, mppsum_realdd, mppsum_a_realdd
+   END INTERFACE
+   INTERFACE mpp_max
+      MODULE PROCEDURE mppmax_a_int, mppmax_int, mppmax_a_real, mppmax_real
+   END INTERFACE
+   INTERFACE mpp_min
+      MODULE PROCEDURE mppmin_a_int, mppmin_int, mppmin_a_real, mppmin_real
+   END INTERFACE
+   INTERFACE mpp_minloc
+      MODULE PROCEDURE mpp_minloc2d ,mpp_minloc3d
+   END INTERFACE
+   INTERFACE mpp_maxloc
+      MODULE PROCEDURE mpp_maxloc2d ,mpp_maxloc3d
+   END INTERFACE
+   INTERFACE mpp_max_multiple
+      MODULE PROCEDURE mppmax_real_multiple
+   END INTERFACE
+
+   LOGICAL, PUBLIC, PARAMETER ::   lk_mpp = .FALSE.      !: mpp flag
+   LOGICAL, PUBLIC            ::   ln_nnogather          !: namelist control of northfold comms (needed here in case "key_mpp_mpi" is not used)
+   INTEGER :: ncomm_ice
+   INTEGER, PUBLIC            ::   mpi_comm_oce          ! opa local communicator
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   INTEGER FUNCTION lib_mpp_alloc(kumout)          ! Dummy function
+      INTEGER, INTENT(in) ::   kumout
+      lib_mpp_alloc = 0
+   END FUNCTION lib_mpp_alloc
+
+   FUNCTION mynode( ldtxt, ldname, kumnam_ref, knumnam_cfg,  kumond , kstop, localComm ) RESULT (function_value)
+      INTEGER, OPTIONAL            , INTENT(in   ) ::   localComm
+      CHARACTER(len=*),DIMENSION(:) ::   ldtxt
+      CHARACTER(len=*) ::   ldname
+      INTEGER ::   kumnam_ref, knumnam_cfg , kumond , kstop
+      IF( PRESENT( localComm ) ) mpi_comm_oce = localComm
+      function_value = 0
+      IF( .FALSE. )   ldtxt(:) = 'never done'
+      CALL ctl_opn( kumond, TRIM(ldname), 'UNKNOWN', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. , 1 )
+   END FUNCTION mynode
+
+   SUBROUTINE mppsync                       ! Dummy routine
+   END SUBROUTINE mppsync
+
+   SUBROUTINE mpp_sum_as( parr, kdim, kcom )      ! Dummy routine
+      REAL   , DIMENSION(:) :: parr
+      INTEGER               :: kdim
+      INTEGER, OPTIONAL     :: kcom
+      WRITE(*,*) 'mpp_sum_as: You should not have seen this print! error?', kdim, parr(1), kcom
+   END SUBROUTINE mpp_sum_as
+
+   SUBROUTINE mpp_sum_a2s( parr, kdim, kcom )      ! Dummy routine
+      REAL   , DIMENSION(:,:) :: parr
+      INTEGER               :: kdim
+      INTEGER, OPTIONAL     :: kcom
+      WRITE(*,*) 'mpp_sum_a2s: You should not have seen this print! error?', kdim, parr(1,1), kcom
+   END SUBROUTINE mpp_sum_a2s
+
+   SUBROUTINE mpp_sum_ai( karr, kdim, kcom )      ! Dummy routine
+      INTEGER, DIMENSION(:) :: karr
+      INTEGER               :: kdim
+      INTEGER, OPTIONAL     :: kcom
+      WRITE(*,*) 'mpp_sum_ai: You should not have seen this print! error?', kdim, karr(1), kcom
+   END SUBROUTINE mpp_sum_ai
+
+   SUBROUTINE mpp_sum_s( psca, kcom )            ! Dummy routine
+      REAL                  :: psca
+      INTEGER, OPTIONAL     :: kcom
+      WRITE(*,*) 'mpp_sum_s: You should not have seen this print! error?', psca, kcom
+   END SUBROUTINE mpp_sum_s
+
+   SUBROUTINE mpp_sum_i( kint, kcom )            ! Dummy routine
+      integer               :: kint
+      INTEGER, OPTIONAL     :: kcom
+      WRITE(*,*) 'mpp_sum_i: You should not have seen this print! error?', kint, kcom
+   END SUBROUTINE mpp_sum_i
+
+   SUBROUTINE mppsum_realdd( ytab, kcom )
+      COMPLEX(wp), INTENT(inout)         :: ytab    ! input scalar
+      INTEGER , INTENT( in  ), OPTIONAL :: kcom
+      WRITE(*,*) 'mppsum_realdd: You should not have seen this print! error?', ytab
+   END SUBROUTINE mppsum_realdd
+
+   SUBROUTINE mppsum_a_realdd( ytab, kdim, kcom )
+      INTEGER , INTENT( in )                        ::   kdim      ! size of ytab
+      COMPLEX(wp), DIMENSION(kdim), INTENT( inout ) ::   ytab      ! input array
+      INTEGER , INTENT( in  ), OPTIONAL :: kcom
+      WRITE(*,*) 'mppsum_a_realdd: You should not have seen this print! error?', kdim, ytab(1), kcom
+   END SUBROUTINE mppsum_a_realdd
+
+   SUBROUTINE mppmax_a_real( parr, kdim, kcom )
+      REAL   , DIMENSION(:) :: parr
+      INTEGER               :: kdim
+      INTEGER, OPTIONAL     :: kcom
+      WRITE(*,*) 'mppmax_a_real: You should not have seen this print! error?', kdim, parr(1), kcom
+   END SUBROUTINE mppmax_a_real
+
+   SUBROUTINE mppmax_real( psca, kcom )
+      REAL                  :: psca
+      INTEGER, OPTIONAL     :: kcom
+      WRITE(*,*) 'mppmax_real: You should not have seen this print! error?', psca, kcom
+   END SUBROUTINE mppmax_real
+
+   SUBROUTINE mppmin_a_real( parr, kdim, kcom )
+      REAL   , DIMENSION(:) :: parr
+      INTEGER               :: kdim
+      INTEGER, OPTIONAL     :: kcom
+      WRITE(*,*) 'mppmin_a_real: You should not have seen this print! error?', kdim, parr(1), kcom
+   END SUBROUTINE mppmin_a_real
+
+   SUBROUTINE mppmin_real( psca, kcom )
+      REAL                  :: psca
+      INTEGER, OPTIONAL     :: kcom
+      WRITE(*,*) 'mppmin_real: You should not have seen this print! error?', psca, kcom
+   END SUBROUTINE mppmin_real
+
+   SUBROUTINE mppmax_a_int( karr, kdim ,kcom)
+      INTEGER, DIMENSION(:) :: karr
+      INTEGER               :: kdim
+      INTEGER, OPTIONAL     :: kcom
+      WRITE(*,*) 'mppmax_a_int: You should not have seen this print! error?', kdim, karr(1), kcom
+   END SUBROUTINE mppmax_a_int
+
+   SUBROUTINE mppmax_int( kint, kcom)
+      INTEGER               :: kint
+      INTEGER, OPTIONAL     :: kcom
+      WRITE(*,*) 'mppmax_int: You should not have seen this print! error?', kint, kcom
+   END SUBROUTINE mppmax_int
+
+   SUBROUTINE mppmin_a_int( karr, kdim, kcom )
+      INTEGER, DIMENSION(:) :: karr
+      INTEGER               :: kdim
+      INTEGER, OPTIONAL     :: kcom
+      WRITE(*,*) 'mppmin_a_int: You should not have seen this print! error?', kdim, karr(1), kcom
+   END SUBROUTINE mppmin_a_int
+
+   SUBROUTINE mppmin_int( kint, kcom )
+      INTEGER               :: kint
+      INTEGER, OPTIONAL     :: kcom
+      WRITE(*,*) 'mppmin_int: You should not have seen this print! error?', kint, kcom
+   END SUBROUTINE mppmin_int
+
+   SUBROUTINE mpp_minloc2d( ptab, pmask, pmin, ki, kj )
+      REAL                   :: pmin
+      REAL , DIMENSION (:,:) :: ptab, pmask
+      INTEGER :: ki, kj
+      WRITE(*,*) 'mpp_minloc2d: You should not have seen this print! error?', pmin, ki, kj, ptab(1,1), pmask(1,1)
+   END SUBROUTINE mpp_minloc2d
+
+   SUBROUTINE mpp_minloc3d( ptab, pmask, pmin, ki, kj, kk )
+      REAL                     :: pmin
+      REAL , DIMENSION (:,:,:) :: ptab, pmask
+      INTEGER :: ki, kj, kk
+      WRITE(*,*) 'mpp_minloc3d: You should not have seen this print! error?', pmin, ki, kj, kk, ptab(1,1,1), pmask(1,1,1)
+   END SUBROUTINE mpp_minloc3d
+
+   SUBROUTINE mpp_maxloc2d( ptab, pmask, pmax, ki, kj )
+      REAL                   :: pmax
+      REAL , DIMENSION (:,:) :: ptab, pmask
+      INTEGER :: ki, kj
+      WRITE(*,*) 'mpp_maxloc2d: You should not have seen this print! error?', pmax, ki, kj, ptab(1,1), pmask(1,1)
+   END SUBROUTINE mpp_maxloc2d
+
+   SUBROUTINE mpp_maxloc3d( ptab, pmask, pmax, ki, kj, kk )
+      REAL                     :: pmax
+      REAL , DIMENSION (:,:,:) :: ptab, pmask
+      INTEGER :: ki, kj, kk
+      WRITE(*,*) 'mpp_maxloc3d: You should not have seen this print! error?', pmax, ki, kj, kk, ptab(1,1,1), pmask(1,1,1)
+   END SUBROUTINE mpp_maxloc3d
+
+   SUBROUTINE mppstop
+      STOP      ! non MPP case, just stop the run
+   END SUBROUTINE mppstop
+
+   SUBROUTINE mpp_ini_ice( kcom, knum )
+      INTEGER :: kcom, knum
+      WRITE(*,*) 'mpp_ini_ice: You should not have seen this print! error?', kcom, knum
+   END SUBROUTINE mpp_ini_ice
+
+   SUBROUTINE mpp_ini_znl( knum )
+      INTEGER :: knum
+      WRITE(*,*) 'mpp_ini_znl: You should not have seen this print! error?', knum
+   END SUBROUTINE mpp_ini_znl
+
+   SUBROUTINE mpp_comm_free( kcom )
+      INTEGER :: kcom
+      WRITE(*,*) 'mpp_comm_free: You should not have seen this print! error?', kcom
+   END SUBROUTINE mpp_comm_free
+   
+   SUBROUTINE mppmax_real_multiple( ptab, kdim , kcom  )
+      REAL, DIMENSION(:) ::   ptab   ! 
+      INTEGER            ::   kdim   ! 
+      INTEGER, OPTIONAL  ::   kcom   ! 
+      WRITE(*,*) 'mppmax_real_multiple: You should not have seen this print! error?', ptab(1), kdim
+   END SUBROUTINE mppmax_real_multiple
+
+#endif
+
+   !!----------------------------------------------------------------------
+   !!   All cases:         ctl_stop, ctl_warn, get_unit, ctl_opn, ctl_nam   routines
+   !!----------------------------------------------------------------------
+
+   SUBROUTINE ctl_stop( cd1, cd2, cd3, cd4, cd5 ,   &
+      &                 cd6, cd7, cd8, cd9, cd10 )
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE  stop_opa  ***
+      !!
+      !! ** Purpose :   print in ocean.outpput file a error message and
+      !!                increment the error number (nstop) by one.
+      !!----------------------------------------------------------------------
+      CHARACTER(len=*), INTENT(in), OPTIONAL ::  cd1, cd2, cd3, cd4, cd5
+      CHARACTER(len=*), INTENT(in), OPTIONAL ::  cd6, cd7, cd8, cd9, cd10
+      !!----------------------------------------------------------------------
+      !
+      nstop = nstop + 1
+      IF(lwp) THEN
+         WRITE(numout,cform_err)
+         IF( PRESENT(cd1 ) )   WRITE(numout,*) cd1
+         IF( PRESENT(cd2 ) )   WRITE(numout,*) cd2
+         IF( PRESENT(cd3 ) )   WRITE(numout,*) cd3
+         IF( PRESENT(cd4 ) )   WRITE(numout,*) cd4
+         IF( PRESENT(cd5 ) )   WRITE(numout,*) cd5
+         IF( PRESENT(cd6 ) )   WRITE(numout,*) cd6
+         IF( PRESENT(cd7 ) )   WRITE(numout,*) cd7
+         IF( PRESENT(cd8 ) )   WRITE(numout,*) cd8
+         IF( PRESENT(cd9 ) )   WRITE(numout,*) cd9
+         IF( PRESENT(cd10) )   WRITE(numout,*) cd10
+      ENDIF
+                               CALL FLUSH(numout    )
+      IF( numstp     /= -1 )   CALL FLUSH(numstp    )
+      IF( numrun     /= -1 )   CALL FLUSH(numrun    )
+      IF( numevo_ice /= -1 )   CALL FLUSH(numevo_ice)
+      !
+      IF( cd1 == 'STOP' ) THEN
+         IF(lwp) WRITE(numout,*)  'huge E-R-R-O-R : immediate stop'
+         CALL mppstop()
+      ENDIF
+      !
+   END SUBROUTINE ctl_stop
+
+
+   SUBROUTINE ctl_warn( cd1, cd2, cd3, cd4, cd5,   &
+      &                 cd6, cd7, cd8, cd9, cd10 )
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE  stop_warn  ***
+      !!
+      !! ** Purpose :   print in ocean.outpput file a error message and
+      !!                increment the warning number (nwarn) by one.
+      !!----------------------------------------------------------------------
+      CHARACTER(len=*), INTENT(in), OPTIONAL ::  cd1, cd2, cd3, cd4, cd5
+      CHARACTER(len=*), INTENT(in), OPTIONAL ::  cd6, cd7, cd8, cd9, cd10
+      !!----------------------------------------------------------------------
+      !
+      nwarn = nwarn + 1
+      IF(lwp) THEN
+         WRITE(numout,cform_war)
+         IF( PRESENT(cd1 ) ) WRITE(numout,*) cd1
+         IF( PRESENT(cd2 ) ) WRITE(numout,*) cd2
+         IF( PRESENT(cd3 ) ) WRITE(numout,*) cd3
+         IF( PRESENT(cd4 ) ) WRITE(numout,*) cd4
+         IF( PRESENT(cd5 ) ) WRITE(numout,*) cd5
+         IF( PRESENT(cd6 ) ) WRITE(numout,*) cd6
+         IF( PRESENT(cd7 ) ) WRITE(numout,*) cd7
+         IF( PRESENT(cd8 ) ) WRITE(numout,*) cd8
+         IF( PRESENT(cd9 ) ) WRITE(numout,*) cd9
+         IF( PRESENT(cd10) ) WRITE(numout,*) cd10
+      ENDIF
+      CALL FLUSH(numout)
+      !
+   END SUBROUTINE ctl_warn
+
+
+   SUBROUTINE ctl_opn( knum, cdfile, cdstat, cdform, cdacce, klengh, kout, ldwp, karea )
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE ctl_opn  ***
+      !!
+      !! ** Purpose :   Open file and check if required file is available.
+      !!
+      !! ** Method  :   Fortan open
+      !!----------------------------------------------------------------------
+      INTEGER          , INTENT(  out) ::   knum      ! logical unit to open
+      CHARACTER(len=*) , INTENT(in   ) ::   cdfile    ! file name to open
+      CHARACTER(len=*) , INTENT(in   ) ::   cdstat    ! disposition specifier
+      CHARACTER(len=*) , INTENT(in   ) ::   cdform    ! formatting specifier
+      CHARACTER(len=*) , INTENT(in   ) ::   cdacce    ! access specifier
+      INTEGER          , INTENT(in   ) ::   klengh    ! record length
+      INTEGER          , INTENT(in   ) ::   kout      ! number of logical units for write
+      LOGICAL          , INTENT(in   ) ::   ldwp      ! boolean term for print
+      INTEGER, OPTIONAL, INTENT(in   ) ::   karea     ! proc number
+      !
+      CHARACTER(len=80) ::   clfile
+      INTEGER           ::   iost
+      !!----------------------------------------------------------------------
+      !
+      ! adapt filename
+      ! ----------------
+      clfile = TRIM(cdfile)
+      IF( PRESENT( karea ) ) THEN
+         IF( karea > 1 )   WRITE(clfile, "(a,'_',i4.4)") TRIM(clfile), karea-1
+      ENDIF
+#if defined key_agrif
+      IF( .NOT. Agrif_Root() )   clfile = TRIM(Agrif_CFixed())//'_'//TRIM(clfile)
+      knum=Agrif_Get_Unit()
+#else
+      knum=get_unit()
+#endif
+      !
+      iost=0
+      IF( cdacce(1:6) == 'DIRECT' )  THEN
+         OPEN( UNIT=knum, FILE=clfile, FORM=cdform, ACCESS=cdacce, STATUS=cdstat, RECL=klengh, ERR=100, IOSTAT=iost )
+      ELSE
+         OPEN( UNIT=knum, FILE=clfile, FORM=cdform, ACCESS=cdacce, STATUS=cdstat             , ERR=100, IOSTAT=iost )
+      ENDIF
+      IF( iost == 0 ) THEN
+         IF(ldwp) THEN
+            WRITE(kout,*) '     file   : ', clfile,' open ok'
+            WRITE(kout,*) '     unit   = ', knum
+            WRITE(kout,*) '     status = ', cdstat
+            WRITE(kout,*) '     form   = ', cdform
+            WRITE(kout,*) '     access = ', cdacce
+            WRITE(kout,*)
+         ENDIF
+      ENDIF
+100   CONTINUE
+      IF( iost /= 0 ) THEN
+         IF(ldwp) THEN
+            WRITE(kout,*)
+            WRITE(kout,*) ' ===>>>> : bad opening file: ', clfile
+            WRITE(kout,*) ' =======   ===  '
+            WRITE(kout,*) '           unit   = ', knum
+            WRITE(kout,*) '           status = ', cdstat
+            WRITE(kout,*) '           form   = ', cdform
+            WRITE(kout,*) '           access = ', cdacce
+            WRITE(kout,*) '           iostat = ', iost
+            WRITE(kout,*) '           we stop. verify the file '
+            WRITE(kout,*)
+         ELSE  !!! Force writing to make sure we get the information - at least once - in this violent STOP!!
+            WRITE(*,*)
+            WRITE(*,*) ' ===>>>> : bad opening file: ', clfile
+            WRITE(*,*) ' =======   ===  '
+            WRITE(*,*) '           unit   = ', knum
+            WRITE(*,*) '           status = ', cdstat
+            WRITE(*,*) '           form   = ', cdform
+            WRITE(*,*) '           access = ', cdacce
+            WRITE(*,*) '           iostat = ', iost
+            WRITE(*,*) '           we stop. verify the file '
+            WRITE(*,*)
+         ENDIF
+         CALL FLUSH( kout ) 
+         STOP 'ctl_opn bad opening'
+      ENDIF
+      !
+   END SUBROUTINE ctl_opn
+
+
+   SUBROUTINE ctl_nam ( kios, cdnam, ldwp )
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE ctl_nam  ***
+      !!
+      !! ** Purpose :   Informations when error while reading a namelist
+      !!
+      !! ** Method  :   Fortan open
+      !!----------------------------------------------------------------------
+      INTEGER         , INTENT(inout) ::   kios    ! IO status after reading the namelist
+      CHARACTER(len=*), INTENT(in   ) ::   cdnam   ! group name of namelist for which error occurs
+      CHARACTER(len=5)                ::   clios   ! string to convert iostat in character for print
+      LOGICAL         , INTENT(in   ) ::   ldwp    ! boolean term for print
+      !!----------------------------------------------------------------------
+      !
+      WRITE (clios, '(I5.0)')   kios
+      IF( kios < 0 ) THEN         
+         CALL ctl_warn( 'end of record or file while reading namelist '   &
+            &           // TRIM(cdnam) // ' iostat = ' // TRIM(clios) )
+      ENDIF
+      !
+      IF( kios > 0 ) THEN
+         CALL ctl_stop( 'misspelled variable in namelist '   &
+            &           // TRIM(cdnam) // ' iostat = ' // TRIM(clios) )
+      ENDIF
+      kios = 0
+      RETURN
+      !
+   END SUBROUTINE ctl_nam
+
+
+   INTEGER FUNCTION get_unit()
+      !!----------------------------------------------------------------------
+      !!                  ***  FUNCTION  get_unit  ***
+      !!
+      !! ** Purpose :   return the index of an unused logical unit
+      !!----------------------------------------------------------------------
+      LOGICAL :: llopn
+      !!----------------------------------------------------------------------
+      !
+      get_unit = 15   ! choose a unit that is big enough then it is not already used in NEMO
+      llopn = .TRUE.
+      DO WHILE( (get_unit < 998) .AND. llopn )
+         get_unit = get_unit + 1
+         INQUIRE( unit = get_unit, opened = llopn )
+      END DO
+      IF( (get_unit == 999) .AND. llopn ) THEN
+         CALL ctl_stop( 'get_unit: All logical units until 999 are used...' )
+         get_unit = -1
+      ENDIF
+      !
+   END FUNCTION get_unit
+
+   !!----------------------------------------------------------------------
+END MODULE lib_mpp
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/LBC/mpp_bdy_generic.h90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/LBC/mpp_bdy_generic.h90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/LBC/mpp_bdy_generic.h90	(revision 9570)
@@ -0,0 +1,270 @@
+#   define ARRAY_TYPE(i,j,k,l,f)    REAL(wp)                    , INTENT(inout) ::   ARRAY_IN(i,j,k,l,f)
+#   define NAT_IN(k)                cd_nat
+#   define SGN_IN(k)                psgn
+#   define IBD_IN(k)                kb_bdy
+#   define F_SIZE(ptab)             1
+#   define OPT_K(k)                 
+#   if defined DIM_2d
+#      define ARRAY_IN(i,j,k,l,f)   ptab(i,j)
+#      define K_SIZE(ptab)          1
+#      define L_SIZE(ptab)          1
+#   endif
+#   if defined DIM_3d
+#      define ARRAY_IN(i,j,k,l,f)   ptab(i,j,k)
+#      define K_SIZE(ptab)          SIZE(ptab,3)
+#      define L_SIZE(ptab)          1
+#   endif
+#   if defined DIM_4d
+#      define ARRAY_IN(i,j,k,l,f)   ptab(i,j,k,l)
+#      define K_SIZE(ptab)          SIZE(ptab,3)
+#      define L_SIZE(ptab)          SIZE(ptab,4)
+#   endif
+
+   SUBROUTINE ROUTINE_BDY( ptab, cd_nat, psgn      , kb_bdy )
+      !!----------------------------------------------------------------------
+      !!                  ***  routine mpp_lnk_bdy_3d  ***
+      !!
+      !! ** Purpose :   Message passing management
+      !!
+      !! ** Method  :   Use mppsend and mpprecv function for passing BDY boundaries 
+      !!      between processors following neighboring subdomains.
+      !!            domain parameters
+      !!                    nlci   : first dimension of the local subdomain
+      !!                    nlcj   : second dimension of the local subdomain
+      !!                    nbondi_bdy : mark for "east-west local boundary"
+      !!                    nbondj_bdy : mark for "north-south local boundary"
+      !!                    noea   : number for local neighboring processors 
+      !!                    nowe   : number for local neighboring processors
+      !!                    noso   : number for local neighboring processors
+      !!                    nono   : number for local neighboring processors
+      !!
+      !! ** Action  :   ptab with update value at its periphery
+      !!
+      !!----------------------------------------------------------------------
+      ARRAY_TYPE(:,:,:,:,:)   ! array or pointer of arrays on which the boundary condition is applied
+      CHARACTER(len=1)            , INTENT(in   ) ::   NAT_IN(:)   ! nature of array grid-points
+      REAL(wp)                    , INTENT(in   ) ::   SGN_IN(:)   ! sign used across the north fold boundary
+      INTEGER                     , INTENT(in   ) ::   IBD_IN(:)   ! BDY boundary set
+      !
+      INTEGER  ::   ji, jj, jk, jl, jh, jf     ! dummy loop indices
+      INTEGER  ::   ipk, ipl, ipf              ! 3dimension of the input array
+      INTEGER  ::   imigr, iihom, ijhom        ! local integers
+      INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend
+      REAL(wp) ::   zland                      ! local scalar
+      INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend
+      !
+      REAL(wp), DIMENSION(:,:,:,:,:,:), ALLOCATABLE ::   zt3ns, zt3sn   ! 3d for north-south & south-north
+      REAL(wp), DIMENSION(:,:,:,:,:,:), ALLOCATABLE ::   zt3ew, zt3we   ! 3d for east-west & west-east
+      !!----------------------------------------------------------------------
+      !
+      ipk = K_SIZE(ptab)   ! 3rd dimension
+      ipl = L_SIZE(ptab)   ! 4th    -
+      ipf = F_SIZE(ptab)   ! 5th    -      use in "multi" case (array of pointers)
+      !      
+      ALLOCATE( zt3ns(jpi,nn_hls,ipk,ipl,ipf,2), zt3sn(jpi,nn_hls,ipk,ipl,ipf,2),   &
+         &      zt3ew(jpj,nn_hls,ipk,ipl,ipf,2), zt3we(jpj,nn_hls,ipk,ipl,ipf,2)  )
+
+      zland = 0._wp
+
+      ! 1. standard boundary treatment
+      ! ------------------------------
+      !
+      DO jf = 1, ipf                   ! number of arrays to be treated
+         !
+         !                                ! East-West boundaries
+         !                    
+         IF( nbondi == 2) THEN                  ! neither subdomain to the east nor to the west
+            !                                      !* Cyclic
+            IF( nperio == 1 .OR. nperio == 4 .OR. nperio == 6 ) THEN
+               ARRAY_IN( 1 ,:,:,:,jf) = ARRAY_IN(jpim1,:,:,:,jf)
+               ARRAY_IN(jpi,:,:,:,jf) = ARRAY_IN(  2  ,:,:,:,jf)
+            ELSE                                   !* Closed
+               IF( .NOT. NAT_IN(jf) == 'F' )   ARRAY_IN(     1       :nn_hls,:,:,:,jf) = zland  ! east except F-point
+                                               ARRAY_IN(nlci-nn_hls+1:jpi   ,:,:,:,jf) = zland  ! west
+            ENDIF
+         ELSEIF(nbondi == -1) THEN              ! subdomain to the east only
+            IF( .NOT. NAT_IN(jf) == 'F' )   ARRAY_IN(1:nn_hls,:,:,:,jf) = zland     ! south except F-point
+            !
+         ELSEIF(nbondi == 1) THEN               ! subdomain to the west only
+            ARRAY_IN(nlci-nn_hls+1:jpi,:,:,:,jf) = zland    ! north
+         ENDIF
+         !                                ! North-South boundaries
+         !
+         IF (nbondj == 2 .OR. nbondj == -1) THEN      !* closed
+           IF( .NOT. NAT_IN(jf) == 'F' )   ARRAY_IN(:,1:nn_hls,:,:,jf) = zland            ! south except F-point
+         ELSEIF (nbondj == 2 .OR. nbondj == 1) THEN
+                                           ARRAY_IN(:,nlcj-nn_hls+1:jpj,:,:,jf) = zland   ! north
+         ENDIF
+      END DO
+
+      ! 2. East and west directions exchange
+      ! ------------------------------------
+      ! we play with the neigbours AND the row number because of the periodicity 
+      !
+      !
+      DO jf = 1, ipf
+         SELECT CASE ( nbondi_bdy(IBD_IN(jf)) )      ! Read Dirichlet lateral conditions
+         CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case)
+            iihom = nlci-nreci
+               DO jl = 1, ipl
+                  DO jk = 1, ipk
+                     DO jh = 1, nn_hls
+                        zt3ew(:,jh,jk,jl,jf,1) = ARRAY_IN(nn_hls+jh,:,jk,jl,jf)
+                        zt3we(:,jh,jk,jl,jf,1) = ARRAY_IN(iihom +jh,:,jk,jl,jf)
+                     END DO
+                  END DO
+               END DO
+         END SELECT
+         !
+         !                           ! Migrations
+!!gm      imigr = nn_hls * jpj * ipk * ipl * ipf
+         imigr = nn_hls * jpj * ipk * ipl
+         !
+         SELECT CASE ( nbondi_bdy(IBD_IN(jf)) )
+         CASE ( -1 )
+            CALL mppsend( 2, zt3we(1,1,1,1,1,1), imigr, noea, ml_req1 )
+            CALL mpprecv( 1, zt3ew(1,1,1,1,1,2), imigr, noea )
+            IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
+         CASE ( 0 )
+            CALL mppsend( 1, zt3ew(1,1,1,1,1,1), imigr, nowe, ml_req1 )
+            CALL mppsend( 2, zt3we(1,1,1,1,1,1), imigr, noea, ml_req2 )
+            CALL mpprecv( 1, zt3ew(1,1,1,1,1,2), imigr, noea )
+            CALL mpprecv( 2, zt3we(1,1,1,1,1,2), imigr, nowe )
+            IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
+            IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
+         CASE ( 1 )
+            CALL mppsend( 1, zt3ew(1,1,1,1,1,1), imigr, nowe, ml_req1 )
+            CALL mpprecv( 2, zt3we(1,1,1,1,1,2), imigr, nowe )
+            IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
+         END SELECT
+         !
+         !                           ! Write Dirichlet lateral conditions
+         iihom = nlci-nn_hls
+         !
+         !
+         SELECT CASE ( nbondi_bdy_b(IBD_IN(jf)) )
+         CASE ( -1 )
+            DO jl = 1, ipl
+               DO jk = 1, ipk
+                  DO jh = 1, nn_hls
+                     ARRAY_IN(iihom+jh,:,jk,jl,jf) = zt3ew(:,jh,jk,jl,jf,2)
+                  END DO
+               END DO
+            END DO
+         CASE ( 0 )
+            DO jl = 1, ipl
+               DO jk = 1, ipk
+                  DO jh = 1, nn_hls
+                     ARRAY_IN(jh      ,:,jk,jl,jf) = zt3we(:,jh,jk,jl,jf,2)
+                     ARRAY_IN(iihom+jh,:,jk,jl,jf) = zt3ew(:,jh,jk,jl,jf,2)
+                  END DO
+               END DO
+            END DO
+         CASE ( 1 )
+            DO jl = 1, ipl
+               DO jk = 1, ipk
+                  DO jh = 1, nn_hls
+                     ARRAY_IN(jh      ,:,jk,jl,jf) = zt3we(:,jh,jk,jl,jf,2)
+                  END DO
+               END DO
+            END DO
+         END SELECT
+         !
+      END DO
+
+      ! 3. North and south directions
+      ! -----------------------------
+      ! always closed : we play only with the neigbours
+      !
+      DO jf = 1, ipf
+         IF( nbondj_bdy(IBD_IN(jf)) /= 2 ) THEN      ! Read Dirichlet lateral conditions
+            ijhom = nlcj-nrecj
+            DO jl = 1, ipl
+               DO jk = 1, ipk
+                  DO jh = 1, nn_hls
+                     zt3sn(:,jh,jk,jl,jf,1) = ARRAY_IN(:,ijhom +jh,jk,jl,jf)
+                     zt3ns(:,jh,jk,jl,jf,1) = ARRAY_IN(:,nn_hls+jh,jk,jl,jf)
+                  END DO
+               END DO
+            END DO
+         ENDIF
+         !
+         !                           ! Migrations
+!!gm      imigr = nn_hls * jpi * ipk * ipl * ipf
+         imigr = nn_hls * jpi * ipk * ipl
+         !
+         SELECT CASE ( nbondj_bdy(IBD_IN(jf)) )
+         CASE ( -1 )
+            CALL mppsend( 4, zt3sn(1,1,1,1,1,1), imigr, nono, ml_req1 )
+            CALL mpprecv( 3, zt3ns(1,1,1,1,1,2), imigr, nono )
+            IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
+         CASE ( 0 )
+            CALL mppsend( 3, zt3ns(1,1,1,1,1,1), imigr, noso, ml_req1 )
+            CALL mppsend( 4, zt3sn(1,1,1,1,1,1), imigr, nono, ml_req2 )
+            CALL mpprecv( 3, zt3ns(1,1,1,1,1,2), imigr, nono )
+            CALL mpprecv( 4, zt3sn(1,1,1,1,1,2), imigr, noso )
+            IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
+            IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
+         CASE ( 1 )
+            CALL mppsend( 3, zt3ns(1,1,1,1,1,1), imigr, noso, ml_req1 )
+            CALL mpprecv( 4, zt3sn(1,1,1,1,1,2), imigr, noso )
+            IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
+         END SELECT
+         !
+         !                           ! Write Dirichlet lateral conditions
+         ijhom = nlcj-nn_hls
+         !
+         SELECT CASE ( nbondj_bdy_b(IBD_IN(jf)) )
+         CASE ( -1 )
+            DO jl = 1, ipl
+               DO jk = 1, ipk
+                  DO jh = 1, nn_hls
+                     ARRAY_IN(:,ijhom+jh,jk,jl,jf) = zt3ns(:,jh,jk,jl,jf,2)
+                  END DO
+               END DO
+            END DO
+         CASE ( 0 )
+            DO jl = 1, ipl
+               DO jk = 1, ipk
+                  DO jh = 1, nn_hls
+                     ARRAY_IN(:,      jh,jk,jl,jf) = zt3sn(:,jh,jk,jl,jf,2)
+                     ARRAY_IN(:,ijhom+jh,jk,jl,jf) = zt3ns(:,jh,jk,jl,jf,2)
+                  END DO
+               END DO
+            END DO
+         CASE ( 1 )
+            DO jl = 1, ipl
+               DO jk = 1, ipk
+                  DO jh = 1, nn_hls
+                     ARRAY_IN(:,jh,jk,jl,jf) = zt3sn(:,jh,jk,jl,jf,2)
+                  END DO
+               END DO
+            END DO
+         END SELECT
+      END DO
+
+      ! 4. north fold treatment
+      ! -----------------------
+      !
+      IF( npolj /= 0) THEN
+         !
+         SELECT CASE ( jpni )
+         CASE ( 1 )     ;   CALL lbc_nfd( ptab, NAT_IN(:), SGN_IN(:) OPT_K(:) )   ! only 1 northern proc, no mpp
+         CASE DEFAULT   ;   CALL mpp_nfd( ptab, NAT_IN(:), SGN_IN(:) OPT_K(:) )   ! for all northern procs.
+         END SELECT
+         !
+      ENDIF
+      !
+      DEALLOCATE( zt3ns, zt3sn, zt3ew, zt3we  )
+      !
+   END SUBROUTINE ROUTINE_BDY
+
+#undef ARRAY_TYPE
+#undef NAT_IN
+#undef SGN_IN
+#undef IBD_IN
+#undef ARRAY_IN
+#undef K_SIZE
+#undef L_SIZE
+#undef F_SIZE
+#undef OPT_K
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/LBC/mpp_lnk_generic.h90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/LBC/mpp_lnk_generic.h90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/LBC/mpp_lnk_generic.h90	(revision 9570)
@@ -0,0 +1,310 @@
+#if defined MULTI
+#   define NAT_IN(k)                cd_nat(k)   
+#   define SGN_IN(k)                psgn(k)
+#   define F_SIZE(ptab)             kfld
+#   define OPT_K(k)                 ,ipf
+#   if defined DIM_2d
+#      define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_2D)                , INTENT(inout) ::   ptab(f)
+#      define ARRAY_IN(i,j,k,l,f)      ptab(f)%pt2d(i,j)
+#      define K_SIZE(ptab)             1
+#      define L_SIZE(ptab)             1
+#   endif
+#   if defined DIM_3d
+#      define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_3D)                , INTENT(inout) ::   ptab(f)
+#      define ARRAY_IN(i,j,k,l,f)      ptab(f)%pt3d(i,j,k)
+#      define K_SIZE(ptab)             SIZE(ptab(1)%pt3d,3)
+#      define L_SIZE(ptab)             1
+#   endif
+#   if defined DIM_4d
+#      define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_4D)                , INTENT(inout) ::   ptab(f)
+#      define ARRAY_IN(i,j,k,l,f)      ptab(f)%pt4d(i,j,k,l)
+#      define K_SIZE(ptab)             SIZE(ptab(1)%pt4d,3)
+#      define L_SIZE(ptab)             SIZE(ptab(1)%pt4d,4)
+#   endif
+#else
+#   define ARRAY_TYPE(i,j,k,l,f)    REAL(wp)                    , INTENT(inout) ::   ARRAY_IN(i,j,k,l,f)
+#   define NAT_IN(k)                cd_nat
+#   define SGN_IN(k)                psgn
+#   define F_SIZE(ptab)             1
+#   define OPT_K(k)                 
+#   if defined DIM_2d
+#      define ARRAY_IN(i,j,k,l,f)   ptab(i,j)
+#      define K_SIZE(ptab)          1
+#      define L_SIZE(ptab)          1
+#   endif
+#   if defined DIM_3d
+#      define ARRAY_IN(i,j,k,l,f)   ptab(i,j,k)
+#      define K_SIZE(ptab)          SIZE(ptab,3)
+#      define L_SIZE(ptab)          1
+#   endif
+#   if defined DIM_4d
+#      define ARRAY_IN(i,j,k,l,f)   ptab(i,j,k,l)
+#      define K_SIZE(ptab)          SIZE(ptab,3)
+#      define L_SIZE(ptab)          SIZE(ptab,4)
+#   endif
+#endif
+
+#if defined MULTI
+   SUBROUTINE ROUTINE_LNK( ptab, cd_nat, psgn, kfld, cd_mpp, pval )
+      INTEGER                     , INTENT(in   ) ::   kfld        ! number of pt3d arrays
+#else
+   SUBROUTINE ROUTINE_LNK( ptab, cd_nat, psgn      , cd_mpp, pval )
+#endif
+      ARRAY_TYPE(:,:,:,:,:)                                        ! array or pointer of arrays on which the boundary condition is applied
+      CHARACTER(len=1)            , INTENT(in   ) ::   NAT_IN(:)   ! nature of array grid-points
+      REAL(wp)                    , INTENT(in   ) ::   SGN_IN(:)   ! sign used across the north fold boundary
+      CHARACTER(len=3), OPTIONAL  , INTENT(in   ) ::   cd_mpp      ! fill the overlap area only
+      REAL(wp)        , OPTIONAL  , INTENT(in   ) ::   pval        ! background value (used at closed boundaries)
+      !
+      INTEGER  ::    ji,  jj,  jk,  jl, jh, jf   ! dummy loop indices
+      INTEGER  ::   ipi, ipj, ipk, ipl, ipf      ! dimension of the input array
+      INTEGER  ::   imigr, iihom, ijhom          ! local integers
+      INTEGER  ::   ml_req1, ml_req2, ml_err     ! for key_mpi_isend
+      REAL(wp) ::   zland
+      LOGICAL  ::   ll_Iperio, ll_Jperio
+      INTEGER , DIMENSION(MPI_STATUS_SIZE)      ::   ml_stat        ! for key_mpi_isend
+      REAL(wp), DIMENSION(:,:,:,:,:,:), ALLOCATABLE ::   zt3ns, zt3sn   ! north-south & south-north  halos
+      REAL(wp), DIMENSION(:,:,:,:,:,:), ALLOCATABLE ::   zt3ew, zt3we   ! east -west  & west - east  halos
+      !!----------------------------------------------------------------------
+      !
+      ipk = K_SIZE(ptab)   ! 3rd dimension
+      ipl = L_SIZE(ptab)   ! 4th    -
+      ipf = F_SIZE(ptab)   ! 5th    -      use in "multi" case (array of pointers)
+      !
+      ALLOCATE( zt3ns(jpi,nn_hls,ipk,ipl,ipf,2), zt3sn(jpi,nn_hls,ipk,ipl,ipf,2),   &
+         &      zt3ew(jpj,nn_hls,ipk,ipl,ipf,2), zt3we(jpj,nn_hls,ipk,ipl,ipf,2)  )
+      !
+      ll_Iperio = nbondi == 2 .AND. (nperio == 1 .OR. nperio == 4 .OR. nperio == 6)
+      ll_Jperio = nbondj == 2 .AND.  jperio == 7
+      !
+      IF( PRESENT( pval ) ) THEN   ;   zland = pval      ! set land value
+      ELSE                         ;   zland = 0._wp     ! zero by default
+      ENDIF
+
+      ! ------------------------------- !
+      !   standard boundary treatment   !    ! CAUTION: semi-column notation is often impossible
+      ! ------------------------------- !
+      !
+      IF( PRESENT( cd_mpp ) ) THEN     !==  halos filled with inner values  ==!
+         !
+         DO jf = 1, ipf                      ! number of arrays to be treated
+            !
+            DO jl = 1, ipl                   ! CAUTION: ptab is defined only between nld and nle
+               DO jk = 1, ipk
+                  DO jj = nlcj+1, jpj                 ! added line(s)   (inner only)
+                     ARRAY_IN(nldi  :nlei  ,jj,jk,jl,jf) = ARRAY_IN(nldi:nlei,nlej,jk,jl,jf)
+                     ARRAY_IN(1     :nldi-1,jj,jk,jl,jf) = ARRAY_IN(nldi     ,nlej,jk,jl,jf)
+                     ARRAY_IN(nlei+1:nlci  ,jj,jk,jl,jf) = ARRAY_IN(     nlei,nlej,jk,jl,jf)
+                  END DO
+                  DO ji = nlci+1, jpi                 ! added column(s) (full)
+                     ARRAY_IN(ji,nldj  :nlej  ,jk,jl,jf) = ARRAY_IN(nlei,nldj:nlej,jk,jl,jf)
+                     ARRAY_IN(ji,1     :nldj-1,jk,jl,jf) = ARRAY_IN(nlei,nldj     ,jk,jl,jf)
+                     ARRAY_IN(ji,nlej+1:jpj   ,jk,jl,jf) = ARRAY_IN(nlei,     nlej,jk,jl,jf)
+                  END DO
+               END DO
+            END DO
+            !
+         END DO
+         !
+      ELSE                              !==  standard close or cyclic treatment  ==!
+         !
+         DO jf = 1, ipf                      ! number of arrays to be treated
+            !
+            !                             ! East-West boundaries
+            IF( ll_Iperio ) THEN                   !* cyclic
+               ARRAY_IN( 1 ,:,:,:,jf) = ARRAY_IN(jpim1,:,:,:,jf)
+               ARRAY_IN(jpi,:,:,:,jf) = ARRAY_IN(  2  ,:,:,:,jf)
+            ELSE                                   !* closed
+               IF( .NOT. NAT_IN(jf) == 'F' )   ARRAY_IN(     1       :nn_hls,:,:,:,jf) = zland    ! east except F-point
+                                               ARRAY_IN(nlci-nn_hls+1:jpi   ,:,:,:,jf) = zland    ! west
+            ENDIF
+            !                                ! North-South boundaries
+            IF( ll_Jperio ) THEN                   !* cyclic (only with no mpp j-split)
+               ARRAY_IN(:, 1 ,:,:,jf) = ARRAY_IN(:, jpjm1,:,:,jf)
+               ARRAY_IN(:,jpj,:,:,jf) = ARRAY_IN(:,   2  ,:,:,jf)
+            ELSE                                   !* closed
+               IF( .NOT. NAT_IN(jf) == 'F' )   ARRAY_IN(:,     1       :nn_hls,:,:,jf) = zland    ! south except F-point
+                                               ARRAY_IN(:,nlcj-nn_hls+1:jpj   ,:,:,jf) = zland    ! north
+            ENDIF
+         END DO
+         !
+      ENDIF
+
+      ! ------------------------------- !
+      !      East and west exchange     !
+      ! ------------------------------- !
+      ! we play with the neigbours AND the row number because of the periodicity
+      !
+      SELECT CASE ( nbondi )      ! Read Dirichlet lateral conditions
+      CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case)
+         iihom = nlci-nreci
+         DO jf = 1, ipf
+            DO jl = 1, ipl
+               DO jk = 1, ipk
+                  DO jh = 1, nn_hls
+                     zt3ew(:,jh,jk,jl,jf,1) = ARRAY_IN(nn_hls+jh,:,jk,jl,jf)
+                     zt3we(:,jh,jk,jl,jf,1) = ARRAY_IN(iihom +jh,:,jk,jl,jf)
+                  END DO
+               END DO
+            END DO
+         END DO
+      END SELECT
+      !
+      !                           ! Migrations
+      imigr = nn_hls * jpj * ipk * ipl * ipf
+      !
+      SELECT CASE ( nbondi )
+      CASE ( -1 )
+         CALL mppsend( 2, zt3we(1,1,1,1,1,1), imigr, noea, ml_req1 )
+         CALL mpprecv( 1, zt3ew(1,1,1,1,1,2), imigr, noea )
+         IF(l_isend)   CALL mpi_wait(ml_req1, ml_stat, ml_err)
+      CASE ( 0 )
+         CALL mppsend( 1, zt3ew(1,1,1,1,1,1), imigr, nowe, ml_req1 )
+         CALL mppsend( 2, zt3we(1,1,1,1,1,1), imigr, noea, ml_req2 )
+         CALL mpprecv( 1, zt3ew(1,1,1,1,1,2), imigr, noea )
+         CALL mpprecv( 2, zt3we(1,1,1,1,1,2), imigr, nowe )
+         IF(l_isend)   CALL mpi_wait(ml_req1, ml_stat, ml_err)
+         IF(l_isend)   CALL mpi_wait(ml_req2, ml_stat, ml_err)
+      CASE ( 1 )
+         CALL mppsend( 1, zt3ew(1,1,1,1,1,1), imigr, nowe, ml_req1 )
+         CALL mpprecv( 2, zt3we(1,1,1,1,1,2), imigr, nowe )
+         IF(l_isend)   CALL mpi_wait(ml_req1, ml_stat, ml_err )
+      END SELECT
+      !
+      !                           ! Write Dirichlet lateral conditions
+      iihom = nlci-nn_hls
+      !
+      SELECT CASE ( nbondi )
+      CASE ( -1 )
+         DO jf = 1, ipf
+            DO jl = 1, ipl
+               DO jk = 1, ipk
+                  DO jh = 1, nn_hls
+                     ARRAY_IN(iihom+jh,:,jk,jl,jf) = zt3ew(:,jh,jk,jl,jf,2)
+                  END DO
+               END DO
+            END DO
+         END DO
+      CASE ( 0 )
+         DO jf = 1, ipf
+            DO jl = 1, ipl
+               DO jk = 1, ipk
+                  DO jh = 1, nn_hls
+                     ARRAY_IN(jh      ,:,jk,jl,jf) = zt3we(:,jh,jk,jl,jf,2)
+                     ARRAY_IN(iihom+jh,:,jk,jl,jf) = zt3ew(:,jh,jk,jl,jf,2)
+                  END DO
+               END DO
+            END DO
+         END DO
+      CASE ( 1 )
+         DO jf = 1, ipf
+            DO jl = 1, ipl
+               DO jk = 1, ipk
+                  DO jh = 1, nn_hls
+                     ARRAY_IN(jh      ,:,jk,jl,jf) = zt3we(:,jh,jk,jl,jf,2)
+                  END DO
+               END DO
+            END DO
+         END DO
+      END SELECT
+
+      ! 3. North and south directions
+      ! -----------------------------
+      ! always closed : we play only with the neigbours
+      !
+      IF( nbondj /= 2 ) THEN      ! Read Dirichlet lateral conditions
+         ijhom = nlcj-nrecj
+         DO jf = 1, ipf
+            DO jl = 1, ipl
+               DO jk = 1, ipk
+                  DO jh = 1, nn_hls
+                     zt3sn(:,jh,jk,jl,jf,1) = ARRAY_IN(:,ijhom +jh,jk,jl,jf)
+                     zt3ns(:,jh,jk,jl,jf,1) = ARRAY_IN(:,nn_hls+jh,jk,jl,jf)
+                  END DO
+               END DO
+            END DO
+         END DO
+      ENDIF
+      !
+      !                           ! Migrations
+      imigr = nn_hls * jpi * ipk * ipl * ipf
+      !
+      SELECT CASE ( nbondj )
+      CASE ( -1 )
+         CALL mppsend( 4, zt3sn(1,1,1,1,1,1), imigr, nono, ml_req1 )
+         CALL mpprecv( 3, zt3ns(1,1,1,1,1,2), imigr, nono )
+         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err )
+      CASE ( 0 )
+         CALL mppsend( 3, zt3ns(1,1,1,1,1,1), imigr, noso, ml_req1 )
+         CALL mppsend( 4, zt3sn(1,1,1,1,1,1), imigr, nono, ml_req2 )
+         CALL mpprecv( 3, zt3ns(1,1,1,1,1,2), imigr, nono )
+         CALL mpprecv( 4, zt3sn(1,1,1,1,1,2), imigr, noso )
+         IF(l_isend)   CALL mpi_wait(ml_req1, ml_stat, ml_err )
+         IF(l_isend)   CALL mpi_wait(ml_req2, ml_stat, ml_err )
+      CASE ( 1 )
+         CALL mppsend( 3, zt3ns(1,1,1,1,1,1), imigr, noso, ml_req1 )
+         CALL mpprecv( 4, zt3sn(1,1,1,1,1,2), imigr, noso )
+         IF(l_isend)   CALL mpi_wait(ml_req1, ml_stat, ml_err )
+      END SELECT
+      !
+      !                           ! Write Dirichlet lateral conditions
+      ijhom = nlcj-nn_hls
+      !
+      SELECT CASE ( nbondj )
+      CASE ( -1 )
+         DO jf = 1, ipf
+            DO jl = 1, ipl
+               DO jk = 1, ipk
+                  DO jh = 1, nn_hls
+                     ARRAY_IN(:,ijhom+jh,jk,jl,jf) = zt3ns(:,jh,jk,jl,jf,2)
+                  END DO
+               END DO
+            END DO
+         END DO
+      CASE ( 0 )
+         DO jf = 1, ipf
+            DO jl = 1, ipl
+               DO jk = 1, ipk
+                  DO jh = 1, nn_hls
+                     ARRAY_IN(:,      jh,jk,jl,jf) = zt3sn(:,jh,jk,jl,jf,2)
+                     ARRAY_IN(:,ijhom+jh,jk,jl,jf) = zt3ns(:,jh,jk,jl,jf,2)
+                  END DO
+               END DO
+            END DO
+         END DO
+      CASE ( 1 )
+         DO jf = 1, ipf
+            DO jl = 1, ipl
+               DO jk = 1, ipk
+                  DO jh = 1, nn_hls
+                     ARRAY_IN(:,jh,jk,jl,jf) = zt3sn(:,jh,jk,jl,jf,2)
+                  END DO
+               END DO
+            END DO
+         END DO
+      END SELECT
+
+      ! 4. north fold treatment
+      ! -----------------------
+      !
+      IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN
+         !
+         SELECT CASE ( jpni )
+         CASE ( 1 )     ;   CALL lbc_nfd( ptab, NAT_IN(:), SGN_IN(:) OPT_K(:) )   ! only 1 northern proc, no mpp
+         CASE DEFAULT   ;   CALL mpp_nfd( ptab, NAT_IN(:), SGN_IN(:) OPT_K(:) )   ! for all northern procs.
+         END SELECT
+         !
+      ENDIF
+      !
+      DEALLOCATE( zt3ns, zt3sn, zt3ew, zt3we )
+      !
+   END SUBROUTINE ROUTINE_LNK
+
+#undef ARRAY_TYPE
+#undef NAT_IN
+#undef SGN_IN
+#undef ARRAY_IN
+#undef K_SIZE
+#undef L_SIZE
+#undef F_SIZE
+#undef OPT_K
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/LBC/mpp_nfd_generic.h90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/LBC/mpp_nfd_generic.h90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/LBC/mpp_nfd_generic.h90	(revision 9570)
@@ -0,0 +1,235 @@
+#if defined MULTI
+#   define NAT_IN(k)                cd_nat(k)   
+#   define SGN_IN(k)                psgn(k)
+#   define F_SIZE(ptab)             kfld
+#   define LBC_ARG                  (jf)
+#   if defined DIM_2d
+#      define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_2D)     , INTENT(inout) ::   ptab(f)
+#      define ARRAY_IN(i,j,k,l,f)      ptab(f)%pt2d(i,j)
+#      define K_SIZE(ptab)             1
+#      define L_SIZE(ptab)             1
+#   endif
+#   if defined DIM_3d
+#      define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_3D)     , INTENT(inout) ::   ptab(f)
+#      define ARRAY_IN(i,j,k,l,f)      ptab(f)%pt3d(i,j,k)
+#      define K_SIZE(ptab)             SIZE(ptab(1)%pt3d,3)
+#      define L_SIZE(ptab)             1
+#   endif
+#   if defined DIM_4d
+#      define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_4D)     , INTENT(inout) ::   ptab(f)
+#      define ARRAY_IN(i,j,k,l,f)      ptab(f)%pt4d(i,j,k,l)
+#      define K_SIZE(ptab)             SIZE(ptab(1)%pt4d,3)
+#      define L_SIZE(ptab)             SIZE(ptab(1)%pt4d,4)
+#   endif
+#else
+!                          !==  IN: ptab is an array  ==!
+#   define ARRAY_TYPE(i,j,k,l,f)    REAL(wp)         , INTENT(inout) ::   ARRAY_IN(i,j,k,l,f)
+#   define NAT_IN(k)                cd_nat
+#   define SGN_IN(k)                psgn
+#   define F_SIZE(ptab)             1
+#   define LBC_ARG
+#   if defined DIM_2d
+#      define ARRAY_IN(i,j,k,l,f)   ptab(i,j)
+#      define K_SIZE(ptab)          1
+#      define L_SIZE(ptab)          1
+#   endif
+#   if defined DIM_3d
+#      define ARRAY_IN(i,j,k,l,f)   ptab(i,j,k)
+#      define K_SIZE(ptab)          SIZE(ptab,3)
+#      define L_SIZE(ptab)          1
+#   endif
+#   if defined DIM_4d
+#      define ARRAY_IN(i,j,k,l,f)   ptab(i,j,k,l)
+#      define K_SIZE(ptab)          SIZE(ptab,3)
+#      define L_SIZE(ptab)          SIZE(ptab,4)
+#   endif
+#endif
+
+   SUBROUTINE ROUTINE_NFD( ptab, cd_nat, psgn, kfld )
+      !!----------------------------------------------------------------------
+      ARRAY_TYPE(:,:,:,:,:)   ! array or pointer of arrays on which the boundary condition is applied
+      CHARACTER(len=1) , INTENT(in   ) ::   NAT_IN(:)   ! nature of array grid-points
+      REAL(wp)         , INTENT(in   ) ::   SGN_IN(:)   ! sign used across the north fold boundary
+      INTEGER, OPTIONAL, INTENT(in   ) ::   kfld        ! number of pt3d arrays
+      !
+      INTEGER  ::   ji,  jj,  jk,  jl, jh, jf, jr   ! dummy loop indices
+      INTEGER  ::   ipi, ipj, ipk, ipl, ipf         ! dimension of the input array
+      INTEGER  ::   imigr, iihom, ijhom             ! local integers
+      INTEGER  ::   ierr, itaille, ildi, ilei, iilb
+      INTEGER  ::   ij, iproc
+      INTEGER, DIMENSION (jpmaxngh)       ::   ml_req_nf   ! for mpi_isend when avoiding mpi_allgather
+      INTEGER                             ::   ml_err      ! for mpi_isend when avoiding mpi_allgather
+      INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat     ! for mpi_isend when avoiding mpi_allgather
+      !                                                    ! Workspace for message transfers avoiding mpi_allgather
+      REAL(wp), DIMENSION(:,:,:,:,:)  , ALLOCATABLE ::   ztab, ztabl, ztabr
+      REAL(wp), DIMENSION(:,:,:,:,:)  , ALLOCATABLE ::   znorthloc, zfoldwk      
+      REAL(wp), DIMENSION(:,:,:,:,:,:), ALLOCATABLE ::   znorthgloio
+      !!----------------------------------------------------------------------
+      !
+      ipk = K_SIZE(ptab)   ! 3rd dimension
+      ipl = L_SIZE(ptab)   ! 4th    -
+      ipf = F_SIZE(ptab)   ! 5th    -      use in "multi" case (array of pointers)
+      !
+      ipj   = 4            ! 2nd dimension of message transfers (last j-lines)
+      !
+      ALLOCATE( znorthloc(jpimax,4,ipk,ipl,ipf) )
+      !
+      znorthloc(:,:,:,:,:) = 0._wp
+      !
+      DO jf = 1, ipf                ! put in znorthloc the last ipj j-lines of ptab
+         DO jl = 1, ipl
+            DO jk = 1, ipk
+               DO jj = nlcj - ipj +1, nlcj
+                  ij = jj - nlcj + ipj
+                  znorthloc(1:jpi,ij,jk,jl,jf) = ARRAY_IN(1:jpi,jj,jk,jl,jf)
+               END DO
+            END DO
+         END DO
+      END DO
+      !
+      !
+      itaille = jpimax * ipj * ipk * ipl * ipf
+      !
+      IF( l_north_nogather ) THEN      !==  ????  ==!
+         ALLOCATE( zfoldwk(jpimax,4,ipk,ipl,ipf) )
+         ALLOCATE( ztabl(jpimax   ,4,ipk,ipl,ipf) , ztabr(jpimax*jpmaxngh,4,ipk,ipl,ipf) ) 
+         !
+         ztabr(:,:,:,:,:) = 0._wp
+         ztabl(:,:,:,:,:) = 0._wp
+         !
+         DO jf = 1, ipf
+            DO jl = 1, ipl
+               DO jk = 1, ipk
+                  DO jj = nlcj-ipj+1, nlcj          ! First put local values into the global array
+                     ij = jj - nlcj + ipj
+                     DO ji = nfsloop, nfeloop
+                        ztabl(ji,ij,jk,jl,jf) = ARRAY_IN(ji,jj,jk,jl,jf)
+                     END DO
+                  END DO
+               END DO
+            END DO
+         END DO
+         !
+         DO jr = 1, nsndto
+            IF( nfipproc(isendto(jr),jpnj) /= narea-1 .AND. nfipproc(isendto(jr),jpnj) /= -1 ) THEN
+              CALL mppsend( 5, znorthloc, itaille, nfipproc(isendto(jr),jpnj), ml_req_nf(jr) )
+            ENDIF
+         END DO
+         DO jr = 1,nsndto
+            iproc = nfipproc(isendto(jr),jpnj)
+            IF(iproc /= -1) THEN
+               ilei = nleit (iproc+1)
+               ildi = nldit (iproc+1)
+               iilb = nfiimpp(isendto(jr),jpnj) - nfiimpp(isendto(1),jpnj)
+            ENDIF
+            IF( iproc /= narea-1 .AND. iproc /= -1 ) THEN
+              CALL mpprecv(5, zfoldwk, itaille, iproc)
+               DO jf = 1, ipf
+                  DO jl = 1, ipl
+                     DO jk = 1, ipk
+                        DO jj = 1, ipj
+                           DO ji = ildi, ilei
+                              ztabr(iilb+ji,jj,jk,jl,jf) = zfoldwk(ji,jj,jk,jl,jf)
+                           END DO
+                        END DO
+                     END DO
+                  END DO
+               END DO
+            ELSE IF( iproc == narea-1 ) THEN
+               DO jf = 1, ipf
+                  DO jl = 1, ipl
+                     DO jk = 1, ipk
+                        DO jj = 1, ipj
+                           DO ji = ildi, ilei
+                              ztabr(iilb+ji,jj,jk,jl,jf) = ARRAY_IN(ji,nlcj-ipj+jj,jk,jl,jf)
+                           END DO
+                        END DO
+                     END DO
+                  END DO
+               END DO
+            ENDIF
+         END DO
+         IF( l_isend ) THEN
+            DO jr = 1,nsndto
+               IF( nfipproc(isendto(jr),jpnj) /= narea-1 .AND. nfipproc(isendto(jr),jpnj) /= -1 ) THEN
+                  CALL mpi_wait( ml_req_nf(jr), ml_stat, ml_err )
+               ENDIF    
+            END DO
+         ENDIF
+         DO jf = 1, ipf
+            CALL lbc_nfd_nogather( ztabl(:,:,:,:,jf), ztabr(:,:,:,:,jf), cd_nat LBC_ARG, psgn LBC_ARG )   ! North fold boundary condition
+         END DO
+         DO jf = 1, ipf
+            DO jl = 1, ipl
+               DO jk = 1, ipk
+                  DO jj = nlcj-ipj+1, nlcj             ! Scatter back to ARRAY_IN
+                     ij = jj - nlcj + ipj
+                     DO ji= 1, nlci
+                        ARRAY_IN(ji,jj,jk,jl,jf) = ztabl(ji,ij,jk,jl,jf)
+                     END DO
+                  END DO
+               END DO
+            END DO
+         END DO
+         !
+         DEALLOCATE( zfoldwk )
+         DEALLOCATE( ztabl, ztabr ) 
+      ELSE                             !==  ????  ==!
+         ALLOCATE( ztab       (jpiglo,4,ipk,ipl,ipf     ) )
+         ALLOCATE( znorthgloio(jpimax,4,ipk,ipl,ipf,jpni) )
+         !
+         CALL MPI_ALLGATHER( znorthloc  , itaille, MPI_DOUBLE_PRECISION,                &
+            &                znorthgloio, itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr )
+         !
+         ztab(:,:,:,:,:) = 0._wp
+         DO jr = 1, ndim_rank_north         ! recover the global north array
+            iproc = nrank_north(jr) + 1
+            ildi  = nldit (iproc)
+            ilei  = nleit (iproc)
+            iilb  = nimppt(iproc)
+            DO jf = 1, ipf
+               DO jl = 1, ipl
+                  DO jk = 1, ipk
+                     DO jj = 1, ipj
+                        DO ji = ildi, ilei
+                           ztab(ji+iilb-1,jj,jk,jl,jf) = znorthgloio(ji,jj,jk,jl,jf,jr)
+                        END DO
+                     END DO
+                  END DO
+               END DO
+            END DO
+         END DO
+         DO jf = 1, ipf
+            CALL lbc_nfd( ztab(:,:,:,:,jf), cd_nat LBC_ARG, psgn LBC_ARG )   ! North fold boundary condition
+         END DO
+         !
+         DO jf = 1, ipf
+            DO jl = 1, ipl
+               DO jk = 1, ipk
+                  DO jj = nlcj-ipj+1, nlcj             ! Scatter back to ARRAY_IN
+                     ij = jj - nlcj + ipj
+                     DO ji= 1, nlci
+                        ARRAY_IN(ji,jj,jk,jl,jf) = ztab(ji+nimpp-1,ij,jk,jl,jf)
+                     END DO
+                  END DO
+               END DO
+            END DO
+         END DO
+         !
+      !
+         DEALLOCATE( ztab )
+         DEALLOCATE( znorthgloio )
+      ENDIF
+      !
+      DEALLOCATE( znorthloc )
+      !
+   END SUBROUTINE ROUTINE_NFD
+
+#undef ARRAY_TYPE
+#undef NAT_IN
+#undef SGN_IN
+#undef ARRAY_IN
+#undef K_SIZE
+#undef L_SIZE
+#undef F_SIZE
+#undef LBC_ARG
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/LBC/mppini.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/LBC/mppini.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/LBC/mppini.F90	(revision 9570)
@@ -0,0 +1,883 @@
+MODULE mppini
+   !!======================================================================
+   !!                       ***  MODULE mppini   ***
+   !! Ocean initialization : distributed memory computing initialization
+   !!======================================================================
+   !! History :  6.0  !  1994-11  (M. Guyon)  Original code
+   !!  OPA       7.0  !  1995-04  (J. Escobar, M. Imbard)
+   !!            8.0  !  1998-05  (M. Imbard, J. Escobar, L. Colombet )  SHMEM and MPI versions
+   !!  NEMO      1.0  !  2004-01  (G. Madec, J.M Molines)  F90 : free form , north fold jpni > 1
+   !!            3.4  ! 2011-10  (A. C. Coward, NOCS & J. Donners, PRACE) add mpp_init_nfdcom
+   !!            3.   ! 2013-06  (I. Epicoco, S. Mocavero, CMCC) mpp_init_nfdcom: setup avoiding MPI communication 
+   !!            4.0  !  2016-06  (G. Madec)  use domain configuration file instead of bathymetry file
+   !!            4.0  !  2017-06  (J.M. Molines, T. Lovato) merge of mppini and mppini_2
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!  mpp_init          : Lay out the global domain over processors with/without land processor elimination
+   !!  mpp_init_mask     : Read global bathymetric information to facilitate land suppression
+   !!  mpp_init_ioipsl   : IOIPSL initialization in mpp 
+   !!  mpp_init_partition: Calculate MPP domain decomposition
+   !!  factorise         : Calculate the factors of the no. of MPI processes
+   !!  mpp_init_nfdcom   : Setup for north fold exchanges with explicit point-to-point messaging
+   !!----------------------------------------------------------------------
+   USE dom_oce        ! ocean space and time domain
+   USE bdy_oce        ! open BounDarY  
+   !
+   USE lbcnfd  , ONLY : isendto, nsndto, nfsloop, nfeloop   ! Setup of north fold exchanges 
+   USE lib_mpp        ! distribued memory computing library
+   USE iom            ! nemo I/O library 
+   USE ioipsl         ! I/O IPSL library
+   USE in_out_manager ! I/O Manager
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC mpp_init       ! called by opa.F90
+
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 4.0 , NEMO Consortium (2017)
+   !! $Id$ 
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+#if ! defined key_mpp_mpi
+   !!----------------------------------------------------------------------
+   !!   Default option :                            shared memory computing
+   !!----------------------------------------------------------------------
+
+   SUBROUTINE mpp_init
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE mpp_init  ***
+      !!
+      !! ** Purpose :   Lay out the global domain over processors.
+      !!
+      !! ** Method  :   Shared memory computing, set the local processor
+      !!              variables to the value of the global domain
+      !!----------------------------------------------------------------------
+      !
+      jpimax = jpiglo
+      jpjmax = jpjglo
+      jpi    = jpiglo
+      jpj    = jpjglo
+      jpk    = jpjglo
+      jpim1  = jpi-1                                            ! inner domain indices
+      jpjm1  = jpj-1                                            !   "           "
+      jpkm1  = MAX( 1, jpk-1 )                                  !   "           "
+      jpij   = jpi*jpj
+      jpni   = 1
+      jpnj   = 1
+      jpnij  = jpni*jpnj
+      nimpp  = 1           ! 
+      njmpp  = 1
+      nlci   = jpi
+      nlcj   = jpj
+      nldi   = 1
+      nldj   = 1
+      nlei   = jpi
+      nlej   = jpj
+      nperio = jperio
+      nbondi = 2
+      nbondj = 2
+      nidom  = FLIO_DOM_NONE
+      npolj = jperio
+      !
+      IF(lwp) THEN
+         WRITE(numout,*)
+         WRITE(numout,*) 'mpp_init : NO massively parallel processing'
+         WRITE(numout,*) '~~~~~~~~ '
+         WRITE(numout,*) '   nperio = ', nperio, '   nimpp  = ', nimpp
+         WRITE(numout,*) '   npolj  = ', npolj , '   njmpp  = ', njmpp
+      ENDIF
+      !
+      IF(  jpni /= 1 .OR. jpnj /= 1 .OR. jpnij /= 1 )                                     &
+         CALL ctl_stop( 'mpp_init: equality  jpni = jpnj = jpnij = 1 is not satisfied',   &
+            &           'the domain is lay out for distributed memory computing!' )
+         !
+      IF( jperio == 7 ) CALL ctl_stop( 'mpp_init: jperio = 7 needs distributed memory computing ',       &
+         &                             'with 1 process. Add key_mpp_mpi in the list of active cpp keys ' )
+         !
+   END SUBROUTINE mpp_init
+
+#else
+   !!----------------------------------------------------------------------
+   !!   'key_mpp_mpi'                     MPI massively parallel processing
+   !!----------------------------------------------------------------------
+
+
+   SUBROUTINE mpp_init
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE mpp_init  ***
+      !!                    
+      !! ** Purpose :   Lay out the global domain over processors.
+      !!      If land processors are to be eliminated, this program requires the
+      !!      presence of the domain configuration file. Land processors elimination
+      !!      is performed if jpni x jpnj /= jpnij. In this case, using the MPP_PREP
+      !!      preprocessing tool, help for defining the best cutting out.
+      !!
+      !! ** Method  :   Global domain is distributed in smaller local domains.
+      !!      Periodic condition is a function of the local domain position
+      !!      (global boundary or neighbouring domain) and of the global
+      !!      periodic
+      !!      Type :         jperio global periodic condition
+      !!                     nperio local  periodic condition
+      !!
+      !! ** Action : - set domain parameters
+      !!                    nimpp     : longitudinal index 
+      !!                    njmpp     : latitudinal  index
+      !!                    nperio    : lateral condition type 
+      !!                    narea     : number for local area
+      !!                    nlci      : first dimension
+      !!                    nlcj      : second dimension
+      !!                    nbondi    : mark for "east-west local boundary"
+      !!                    nbondj    : mark for "north-south local boundary"
+      !!                    nproc     : number for local processor
+      !!                    noea      : number for local neighboring processor
+      !!                    nowe      : number for local neighboring processor
+      !!                    noso      : number for local neighboring processor
+      !!                    nono      : number for local neighboring processor
+      !!----------------------------------------------------------------------
+      INTEGER ::   ji, jj, jn, jproc, jarea   ! dummy loop indices
+      INTEGER ::   inum                       ! local logical unit
+      INTEGER ::   idir, ifreq, icont, isurf  ! local integers
+      INTEGER ::   ii, il1, ili, imil         !   -       -
+      INTEGER ::   ij, il2, ilj, ijm1         !   -       -
+      INTEGER ::   iino, ijno, iiso, ijso     !   -       -
+      INTEGER ::   iiea, ijea, iiwe, ijwe     !   -       -
+      INTEGER ::   iresti, irestj, iarea0     !   -       -
+      INTEGER ::   ierr                       ! local logical unit
+      REAL(wp)::   zidom, zjdom               ! local scalars
+      INTEGER, ALLOCATABLE, DIMENSION(:)     ::   iin, ii_nono, ii_noea          ! 1D workspace
+      INTEGER, ALLOCATABLE, DIMENSION(:)     ::   ijn, ii_noso, ii_nowe          !  -     -
+      INTEGER, ALLOCATABLE, DIMENSION(:,:) ::   iimppt, ilci, ibondi, ipproc   ! 2D workspace
+      INTEGER, ALLOCATABLE, DIMENSION(:,:) ::   ijmppt, ilcj, ibondj, ipolj    !  -     -
+      INTEGER, ALLOCATABLE, DIMENSION(:,:) ::   ilei, ildi, iono, ioea         !  -     -
+      INTEGER, ALLOCATABLE, DIMENSION(:,:) ::   ilej, ildj, ioso, iowe         !  -     -
+      INTEGER, DIMENSION(jpiglo,jpjglo) ::   imask   ! 2D global domain workspace
+      !!----------------------------------------------------------------------
+
+      ! If dimensions of processor grid weren't specified in the namelist file
+      ! then we calculate them here now that we have our communicator size
+      IF( jpni < 1 .OR. jpnj < 1 )   CALL mpp_init_partition( mppsize )
+      !
+#if defined key_agrif
+      IF( jpnij /= jpni*jpnj ) CALL ctl_stop( 'STOP', 'Cannot remove land proc with AGRIF' )
+#endif
+      !
+      ALLOCATE(  nfiimpp(jpni,jpnj), nfipproc(jpni,jpnj), nfilcit(jpni,jpnj) ,    &
+         &       nimppt(jpnij) , ibonit(jpnij) , nlcit(jpnij) , nlcjt(jpnij) ,    &
+         &       njmppt(jpnij) , ibonjt(jpnij) , nldit(jpnij) , nldjt(jpnij) ,    &
+         &                                       nleit(jpnij) , nlejt(jpnij) ,    &
+         &       iin(jpnij), ii_nono(jpnij), ii_noea(jpnij),   &
+         &       ijn(jpnij), ii_noso(jpnij), ii_nowe(jpnij),   &
+         &       iimppt(jpni,jpnj), ilci(jpni,jpnj), ibondi(jpni,jpnj), ipproc(jpni,jpnj),   &
+         &       ijmppt(jpni,jpnj), ilcj(jpni,jpnj), ibondj(jpni,jpnj), ipolj(jpni,jpnj),   &
+         &       ilei(jpni,jpnj), ildi(jpni,jpnj), iono(jpni,jpnj), ioea(jpni,jpnj),   &
+         &       ilej(jpni,jpnj), ildj(jpni,jpnj), ioso(jpni,jpnj), iowe(jpni,jpnj),   &
+         &       STAT=ierr )
+      CALL mpp_sum( ierr )
+      IF( ierr /= 0 )   CALL ctl_stop( 'STOP', 'mpp_init: unable to allocate standard ocean arrays' )
+      
+      !
+#if defined key_agrif
+      IF( .NOT. Agrif_Root() ) THEN       ! AGRIF children: specific setting (cf. agrif_user.F90)
+         IF( jpiglo /= nbcellsx + 2 + 2*nbghostcells )   &
+            CALL ctl_stop( 'STOP', 'mpp_init: Agrif children requires jpiglo == nbcellsx + 2 + 2*nbghostcells' )
+         IF( jpjglo /= nbcellsy + 2 + 2*nbghostcells )   &
+            CALL ctl_stop( 'STOP', 'mpp_init: Agrif children requires jpjglo == nbcellsy + 2 + 2*nbghostcells' )
+         IF( ln_use_jattr )   CALL ctl_stop( 'STOP', 'mpp_init:Agrif children requires ln_use_jattr = .false. ' )
+      ENDIF
+#endif
+
+#if defined key_nemocice_decomp
+      jpimax = ( nx_global+2-2*nn_hls + (jpni-1) ) / jpni + 2*nn_hls    ! first  dim.
+      jpjmax = ( ny_global+2-2*nn_hls + (jpnj-1) ) / jpnj + 2*nn_hls    ! second dim. 
+#else
+      jpimax = ( jpiglo - 2*nn_hls + (jpni-1) ) / jpni + 2*nn_hls    ! first  dim.
+      jpjmax = ( jpjglo - 2*nn_hls + (jpnj-1) ) / jpnj + 2*nn_hls    ! second dim.
+#endif
+
+      !
+      IF ( jpni * jpnj == jpnij ) THEN    ! regular domain lay out over processors
+         imask(:,:) = 1               
+      ELSEIF ( jpni*jpnj > jpnij ) THEN   ! remove land-only processor (i.e. where imask(:,:)=0)
+         CALL mpp_init_mask( imask )   
+      ELSE                                ! error
+         CALL ctl_stop( 'mpp_init: jpnij > jpni x jpnj. Check namelist setting!' )
+      ENDIF
+      !
+      !  1. Dimension arrays for subdomains
+      ! -----------------------------------
+      !  Computation of local domain sizes ilci() ilcj()
+      !  These dimensions depend on global sizes jpni,jpnj and jpiglo,jpjglo
+      !  The subdomains are squares lesser than or equal to the global
+      !  dimensions divided by the number of processors minus the overlap array.
+      !
+      nreci = 2 * nn_hls
+      nrecj = 2 * nn_hls
+      iresti = 1 + MOD( jpiglo - nreci -1 , jpni )
+      irestj = 1 + MOD( jpjglo - nrecj -1 , jpnj )
+      !
+      !  Need to use jpimax and jpjmax here since jpi and jpj not yet defined
+#if defined key_nemocice_decomp
+      ! Change padding to be consistent with CICE
+      ilci(1:jpni-1      ,:) = jpimax
+      ilci(jpni          ,:) = jpiglo - (jpni - 1) * (jpimax - nreci)
+      !
+      ilcj(:,      1:jpnj-1) = jpjmax
+      ilcj(:,          jpnj) = jpjglo - (jpnj - 1) * (jpjmax - nrecj)
+#else
+      ilci(1:iresti      ,:) = jpimax
+      ilci(iresti+1:jpni ,:) = jpimax-1
+
+      ilcj(:,      1:irestj) = jpjmax
+      ilcj(:, irestj+1:jpnj) = jpjmax-1
+#endif
+      !
+      zidom = nreci + sum(ilci(:,1) - nreci )
+      zjdom = nrecj + sum(ilcj(1,:) - nrecj )
+      !
+      IF(lwp) THEN
+         WRITE(numout,*)
+         WRITE(numout,*) 'mpp_init : MPI Message Passing MPI - domain lay out over processors'
+         WRITE(numout,*) '~~~~~~~~ '
+         WRITE(numout,*) '   defines mpp subdomains'
+         WRITE(numout,*) '      iresti = ', iresti, ' jpni = ', jpni  
+         WRITE(numout,*) '      irestj = ', irestj, ' jpnj = ', jpnj
+         WRITE(numout,*)
+         WRITE(numout,*) '      sum ilci(i,1) = ', zidom, ' jpiglo = ', jpiglo
+         WRITE(numout,*) '      sum ilcj(1,j) = ', zjdom, ' jpjglo = ', jpjglo
+      ENDIF
+
+      !  2. Index arrays for subdomains
+      ! -------------------------------
+      iimppt(:,:) =  1
+      ijmppt(:,:) =  1
+      ipproc(:,:) = -1
+      !
+      IF( jpni > 1 ) THEN
+         DO jj = 1, jpnj
+            DO ji = 2, jpni
+               iimppt(ji,jj) = iimppt(ji-1,jj) + ilci(ji-1,jj) - nreci
+            END DO
+         END DO
+      ENDIF
+      nfiimpp(:,:) = iimppt(:,:)
+      !
+      IF( jpnj > 1 )THEN
+         DO jj = 2, jpnj
+            DO ji = 1, jpni
+               ijmppt(ji,jj) = ijmppt(ji,jj-1) + ilcj(ji,jj-1) - nrecj
+            END DO
+         END DO
+      ENDIF
+
+      ! 3. Subdomain description in the Regular Case
+      ! --------------------------------------------
+      nperio = 0
+      icont = -1
+      DO jarea = 1, jpni*jpnj
+         iarea0 = jarea - 1
+         ii = 1 + MOD(iarea0,jpni)
+         ij = 1 +     iarea0/jpni
+         ili = ilci(ii,ij)
+         ilj = ilcj(ii,ij)
+         ibondj(ii,ij) = -1
+         IF( jarea >  jpni          )   ibondj(ii,ij) = 0
+         IF( jarea >  (jpnj-1)*jpni )   ibondj(ii,ij) = 1
+         IF( jpnj  == 1             )   ibondj(ii,ij) = 2
+         ibondi(ii,ij) = 0
+         IF( MOD(jarea,jpni) ==  1  )   ibondi(ii,ij) = -1
+         IF( MOD(jarea,jpni) ==  0  )   ibondi(ii,ij) =  1
+         IF( jpni            ==  1  )   ibondi(ii,ij) =  2
+
+         ! Subdomain neighbors (get their zone number): default definition
+         ioso(ii,ij) = iarea0 - jpni
+         iowe(ii,ij) = iarea0 - 1
+         ioea(ii,ij) = iarea0 + 1
+         iono(ii,ij) = iarea0 + jpni
+         ildi(ii,ij) =  1  + nn_hls
+         ilei(ii,ij) = ili - nn_hls
+         ildj(ii,ij) =  1  + nn_hls
+         ilej(ii,ij) = ilj - nn_hls
+
+         ! East-West periodicity: change ibondi, ioea, iowe
+         IF( jperio == 1 .OR. jperio == 4 .OR. jperio == 6 .OR. jperio == 7 ) THEN
+            IF( jpni == 1 )THEN
+               ibondi(ii,ij) = 2
+               nperio = 1
+            ELSE
+               ibondi(ii,ij) = 0
+            ENDIF
+            IF( MOD(jarea,jpni) == 0 ) THEN
+               ioea(ii,ij) = iarea0 - (jpni-1)
+            ENDIF
+            IF( MOD(jarea,jpni) == 1 ) THEN
+               iowe(ii,ij) = iarea0 + jpni - 1
+            ENDIF
+         ENDIF
+
+         ! North fold: define ipolj, change iono. Warning: we do not change ibondj...
+         ipolj(ii,ij) = 0
+         IF( jperio == 3 .OR. jperio == 4 ) THEN
+            ijm1 = jpni*(jpnj-1)
+            imil = ijm1+(jpni+1)/2
+            IF( jarea > ijm1 ) ipolj(ii,ij) = 3
+            IF( MOD(jpni,2) == 1 .AND. jarea == imil ) ipolj(ii,ij) = 4
+            IF( ipolj(ii,ij) == 3 ) iono(ii,ij) = jpni*jpnj-jarea+ijm1   ! MPI rank of northern neighbour
+         ENDIF
+         IF( jperio == 5 .OR. jperio == 6 ) THEN
+            ijm1 = jpni*(jpnj-1)
+            imil = ijm1+(jpni+1)/2
+            IF( jarea > ijm1) ipolj(ii,ij) = 5
+            IF( MOD(jpni,2) == 1 .AND. jarea == imil ) ipolj(ii,ij) = 6
+            IF( ipolj(ii,ij) == 5) iono(ii,ij) = jpni*jpnj-jarea+ijm1    ! MPI rank of northern neighbour
+         ENDIF
+         !
+         ! Check wet points over the entire domain to preserve the MPI communication stencil
+         isurf = 0
+         DO jj = 1, ilj
+            DO  ji = 1, ili
+               IF( imask(ji+iimppt(ii,ij)-1, jj+ijmppt(ii,ij)-1) == 1)   isurf = isurf+1
+            END DO
+         END DO
+         !
+         IF( isurf /= 0 ) THEN
+            icont = icont + 1
+            ipproc(ii,ij) = icont
+            iin(icont+1) = ii
+            ijn(icont+1) = ij
+         ENDIF
+      END DO
+      !
+      nfipproc(:,:) = ipproc(:,:)
+
+      ! Check potential error
+      IF( icont+1 /= jpnij ) THEN
+         WRITE(ctmp1,*) ' jpni =',jpni,' jpnj =',jpnj
+         WRITE(ctmp2,*) ' jpnij =',jpnij, '< jpni x jpnj' 
+         WRITE(ctmp3,*) ' ***********, mpp_init2 finds jpnij=',icont+1
+         CALL ctl_stop( 'STOP', 'mpp_init: Eliminate land processors algorithm', '', ctmp1, ctmp2, '', ctmp3 )
+      ENDIF
+
+      ! 4. Subdomain print
+      ! ------------------
+      IF(lwp) THEN
+         ifreq = 4
+         il1 = 1
+         DO jn = 1, (jpni-1)/ifreq+1
+            il2 = MIN(jpni,il1+ifreq-1)
+            WRITE(numout,*)
+            WRITE(numout,9400) ('***',ji=il1,il2-1)
+            DO jj = jpnj, 1, -1
+               WRITE(numout,9403) ('   ',ji=il1,il2-1)
+               WRITE(numout,9402) jj, (ilci(ji,jj),ilcj(ji,jj),ji=il1,il2)
+               WRITE(numout,9404) (ipproc(ji,jj),ji=il1,il2)
+               WRITE(numout,9403) ('   ',ji=il1,il2-1)
+               WRITE(numout,9400) ('***',ji=il1,il2-1)
+            END DO
+            WRITE(numout,9401) (ji,ji=il1,il2)
+            il1 = il1+ifreq
+         END DO
+ 9400    FORMAT('           ***'   ,20('*************',a3)    )
+ 9403    FORMAT('           *     ',20('         *   ',a3)    )
+ 9401    FORMAT('              '   ,20('   ',i3,'          ') )
+ 9402    FORMAT('       ',i3,' *  ',20(i3,'  x',i3,'   *   ') )
+ 9404    FORMAT('           *  '   ,20('      ',i3,'   *   ') )
+      ENDIF
+
+      ! 5. neighbour treatment: change ibondi, ibondj if next to a land zone
+      ! ----------------------
+      DO jarea = 1, jpni*jpnj
+         ii = 1 + MOD( jarea-1  , jpni )
+         ij = 1 +     (jarea-1) / jpni
+         IF ( ipproc(ii,ij) == -1 .AND. 0 <= iono(ii,ij) .AND. iono(ii,ij) <= jpni*jpnj-1 ) THEN
+            iino = 1 + MOD( iono(ii,ij) , jpni )
+            ijno = 1 +      iono(ii,ij) / jpni
+            ! Need to reverse the logical direction of communication 
+            ! for northern neighbours of northern row processors (north-fold)
+            ! i.e. need to check that the northern neighbour only communicates
+            ! to the SOUTH (or not at all) if this area is land-only (#1057)
+            idir = 1
+            IF( ij == jpnj .AND. ijno == jpnj )   idir = -1    
+            IF( ibondj(iino,ijno) == idir     )   ibondj(iino,ijno) =   2
+            IF( ibondj(iino,ijno) == 0        )   ibondj(iino,ijno) = -idir
+         ENDIF
+         IF( ipproc(ii,ij) == -1 .AND. 0 <= ioso(ii,ij) .AND. ioso(ii,ij) <= jpni*jpnj-1 ) THEN
+            iiso = 1 + MOD( ioso(ii,ij) , jpni )
+            ijso = 1 +      ioso(ii,ij) / jpni
+            IF( ibondj(iiso,ijso) == -1 )   ibondj(iiso,ijso) = 2
+            IF( ibondj(iiso,ijso) ==  0 )   ibondj(iiso,ijso) = 1
+         ENDIF
+         IF( ipproc(ii,ij) == -1 .AND. 0 <= ioea(ii,ij) .AND. ioea(ii,ij) <= jpni*jpnj-1 ) THEN
+            iiea = 1 + MOD( ioea(ii,ij) , jpni )
+            ijea = 1 +      ioea(ii,ij) / jpni
+            IF( ibondi(iiea,ijea) == 1 )   ibondi(iiea,ijea) =  2
+            IF( ibondi(iiea,ijea) == 0 )   ibondi(iiea,ijea) = -1
+         ENDIF
+         IF( ipproc(ii,ij) == -1 .AND. 0 <= iowe(ii,ij) .AND. iowe(ii,ij) <= jpni*jpnj-1) THEN
+            iiwe = 1 + MOD( iowe(ii,ij) , jpni )
+            ijwe = 1 +      iowe(ii,ij) / jpni
+            IF( ibondi(iiwe,ijwe) == -1 )   ibondi(iiwe,ijwe) = 2
+            IF( ibondi(iiwe,ijwe) ==  0 )   ibondi(iiwe,ijwe) = 1
+         ENDIF
+      END DO
+
+      ! Update il[de][ij] according to modified ibond[ij]
+      ! ----------------------
+      DO jproc = 1, jpnij
+         ii = iin(jproc)
+         ij = ijn(jproc)
+         IF( ibondi(ii,ij) == -1 .OR. ibondi(ii,ij) == 2 ) ildi(ii,ij) =  1
+         IF( ibondi(ii,ij) ==  1 .OR. ibondi(ii,ij) == 2 ) ilei(ii,ij) = ilci(ii,ij)
+         IF( ibondj(ii,ij) == -1 .OR. ibondj(ii,ij) == 2 ) ildj(ii,ij) =  1
+         IF( ibondj(ii,ij) ==  1 .OR. ibondj(ii,ij) == 2 ) ilej(ii,ij) = ilcj(ii,ij)
+      END DO
+         
+      ! just to save nono etc for all proc
+      ! warning ii*ij (zone) /= nproc (processors)!
+      ! ioso = zone number, ii_noso = proc number
+      ii_noso(:) = -1
+      ii_nono(:) = -1
+      ii_noea(:) = -1
+      ii_nowe(:) = -1 
+      DO jproc = 1, jpnij
+         ii = iin(jproc)
+         ij = ijn(jproc)
+         IF( 0 <= ioso(ii,ij) .AND. ioso(ii,ij) <= (jpni*jpnj-1) ) THEN
+            iiso = 1 + MOD( ioso(ii,ij) , jpni )
+            ijso = 1 +      ioso(ii,ij) / jpni
+            ii_noso(jproc) = ipproc(iiso,ijso)
+         ENDIF
+         IF( 0 <= iowe(ii,ij) .AND. iowe(ii,ij) <= (jpni*jpnj-1) ) THEN
+          iiwe = 1 + MOD( iowe(ii,ij) , jpni )
+          ijwe = 1 +      iowe(ii,ij) / jpni
+          ii_nowe(jproc) = ipproc(iiwe,ijwe)
+         ENDIF
+         IF( 0 <= ioea(ii,ij) .AND. ioea(ii,ij) <= (jpni*jpnj-1) ) THEN
+            iiea = 1 + MOD( ioea(ii,ij) , jpni )
+            ijea = 1 +      ioea(ii,ij) / jpni
+            ii_noea(jproc)= ipproc(iiea,ijea)
+         ENDIF
+         IF( 0 <= iono(ii,ij) .AND. iono(ii,ij) <= (jpni*jpnj-1) ) THEN
+            iino = 1 + MOD( iono(ii,ij) , jpni )
+            ijno = 1 +      iono(ii,ij) / jpni
+            ii_nono(jproc)= ipproc(iino,ijno)
+         ENDIF
+      END DO
+    
+      ! 6. Change processor name
+      ! ------------------------
+      ii = iin(narea)
+      ij = ijn(narea)
+      !
+      ! set default neighbours
+      noso = ii_noso(narea)
+      nowe = ii_nowe(narea)
+      noea = ii_noea(narea)
+      nono = ii_nono(narea)
+      nlci = ilci(ii,ij)  
+      nldi = ildi(ii,ij)
+      nlei = ilei(ii,ij)
+      nlcj = ilcj(ii,ij)  
+      nldj = ildj(ii,ij)
+      nlej = ilej(ii,ij)
+      nbondi = ibondi(ii,ij)
+      nbondj = ibondj(ii,ij)
+      nimpp = iimppt(ii,ij)  
+      njmpp = ijmppt(ii,ij)
+      jpi = nlci
+      jpj = nlcj
+      jpk = jpkglo                                             ! third dim
+#if defined key_agrif
+      ! simple trick to use same vertical grid as parent but different number of levels: 
+      ! Save maximum number of levels in jpkglo, then define all vertical grids with this number.
+      ! Suppress once vertical online interpolation is ok
+!!$      IF(.NOT.Agrif_Root())   jpkglo = Agrif_Parent( jpkglo )
+#endif
+      jpim1 = jpi-1                                            ! inner domain indices
+      jpjm1 = jpj-1                                            !   "           "
+      jpkm1 = MAX( 1, jpk-1 )                                  !   "           "
+      jpij  = jpi*jpj                                          !  jpi x j
+      DO jproc = 1, jpnij
+         ii = iin(jproc)
+         ij = ijn(jproc)
+         nlcit(jproc) = ilci(ii,ij)
+         nldit(jproc) = ildi(ii,ij)
+         nleit(jproc) = ilei(ii,ij)
+         nlcjt(jproc) = ilcj(ii,ij)
+         nldjt(jproc) = ildj(ii,ij)
+         nlejt(jproc) = ilej(ii,ij)
+         ibonit(jproc) = ibondi(ii,ij)
+         ibonjt(jproc) = ibondj(ii,ij)
+         nimppt(jproc) = iimppt(ii,ij)  
+         njmppt(jproc) = ijmppt(ii,ij) 
+         nfilcit(ii,ij) = ilci(ii,ij)
+      END DO
+
+      ! Save processor layout in ascii file
+      IF (lwp) THEN
+         CALL ctl_opn( inum, 'layout.dat', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE., narea )
+         WRITE(inum,'(a)') '   jpnij   jpimax  jpjmax    jpk  jpiglo  jpjglo'//&
+   &           ' ( local:    narea     jpi     jpj )'
+         WRITE(inum,'(6i8,a,3i8,a)') jpnij,jpimax,jpjmax,jpk,jpiglo,jpjglo,&
+   &           ' ( local: ',narea,jpi,jpj,' )'
+         WRITE(inum,'(a)') 'nproc nlci nlcj nldi nldj nlei nlej nimp njmp nono noso nowe noea nbondi nbondj '
+
+         DO jproc = 1, jpnij
+            WRITE(inum,'(13i5,2i7)')   jproc-1, nlcit  (jproc), nlcjt  (jproc),   &
+               &                                nldit  (jproc), nldjt  (jproc),   &
+               &                                nleit  (jproc), nlejt  (jproc),   &
+               &                                nimppt (jproc), njmppt (jproc),   & 
+               &                                ii_nono(jproc), ii_noso(jproc),   &
+               &                                ii_nowe(jproc), ii_noea(jproc),   &
+               &                                ibonit (jproc), ibonjt (jproc) 
+         END DO
+         CLOSE(inum)   
+      END IF
+
+      !                          ! north fold parameter
+      ! Defined npolj, either 0, 3 , 4 , 5 , 6
+      ! In this case the important thing is that npolj /= 0
+      ! Because if we go through these line it is because jpni >1 and thus
+      ! we must use lbcnorthmpp, which tests only npolj =0 or npolj /= 0
+      npolj = 0
+      ij = ijn(narea)
+      IF( jperio == 3 .OR. jperio == 4 ) THEN
+         IF( ij == jpnj )   npolj = 3
+      ENDIF
+      IF( jperio == 5 .OR. jperio == 6 ) THEN
+         IF( ij == jpnj )   npolj = 5
+      ENDIF
+      !
+      nproc = narea-1
+      IF(lwp) THEN
+         WRITE(numout,*)
+         WRITE(numout,*) '   resulting internal parameters : '
+         WRITE(numout,*) '      nproc  = ', nproc
+         WRITE(numout,*) '      nowe   = ', nowe  , '   noea  =  ', noea
+         WRITE(numout,*) '      nono   = ', nono  , '   noso  =  ', noso
+         WRITE(numout,*) '      nbondi = ', nbondi
+         WRITE(numout,*) '      nbondj = ', nbondj
+         WRITE(numout,*) '      npolj  = ', npolj
+         WRITE(numout,*) '      nperio = ', nperio
+         WRITE(numout,*) '      nlci   = ', nlci
+         WRITE(numout,*) '      nlcj   = ', nlcj
+         WRITE(numout,*) '      nimpp  = ', nimpp
+         WRITE(numout,*) '      njmpp  = ', njmpp
+         WRITE(numout,*) '      nreci  = ', nreci  
+         WRITE(numout,*) '      nrecj  = ', nrecj  
+         WRITE(numout,*) '      nn_hls = ', nn_hls 
+      ENDIF
+ 
+      IF( nperio == 1 .AND. jpni /= 1 )   CALL ctl_stop( 'mpp_init: error on cyclicity' )
+
+      IF( jperio == 7 .AND. ( jpni /= 1 .OR. jpnj /= 1 ) )   &
+         &                  CALL ctl_stop( ' mpp_init: error jperio = 7 works only with jpni = jpnj = 1' )
+
+      !                          ! Prepare mpp north fold
+      IF( jperio >= 3 .AND. jperio <= 6 .AND. jpni > 1 ) THEN
+         CALL mpp_ini_north
+         IF(lwp) WRITE(numout,*)
+         IF(lwp) WRITE(numout,*) '   ==>>>   North fold boundary prepared for jpni >1'
+      ENDIF
+      !
+      CALL mpp_init_ioipsl       ! Prepare NetCDF output file (if necessary)
+      !
+      IF( ln_nnogather )   CALL mpp_init_nfdcom     ! northfold neighbour lists
+      !
+      DEALLOCATE(iin, ijn, ii_nono, ii_noea, ii_noso, ii_nowe,    &
+         &       iimppt, ijmppt, ibondi, ibondj, ipproc, ipolj,   &
+         &       ilci, ilcj, ilei, ilej, ildi, ildj,              &
+         &       iono, ioea, ioso, iowe)
+      !
+    END SUBROUTINE mpp_init
+
+
+    SUBROUTINE mpp_init_mask( kmask )
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE mpp_init_mask  ***
+      !!
+      !! ** Purpose : Read relevant bathymetric information in a global array
+      !!              in order to provide a land/sea mask used for the elimination
+      !!              of land domains, in an mpp computation.
+      !!
+      !! ** Method  : Read the namelist ln_zco and ln_isfcav in namelist namzgr
+      !!              in order to choose the correct bathymetric information
+      !!              (file and variables)  
+      !!----------------------------------------------------------------------
+      INTEGER, DIMENSION(jpiglo,jpjglo), INTENT(out) ::   kmask   ! global domain 
+  
+      INTEGER :: inum   !: logical unit for configuration file
+      INTEGER :: ios    !: iostat error flag
+      INTEGER ::  ijstartrow                   ! temporary integers
+      REAL(wp), DIMENSION(jpiglo,jpjglo) ::   zbot, zbdy          ! global workspace
+      REAL(wp) ::   zidom , zjdom          ! local scalars
+      NAMELIST/nambdy/ ln_bdy, nb_bdy, ln_coords_file, cn_coords_file,           &
+           &             ln_mask_file, cn_mask_file, cn_dyn2d, nn_dyn2d_dta,     &
+           &             cn_dyn3d, nn_dyn3d_dta, cn_tra, nn_tra_dta,             &  
+           &             ln_tra_dmp, ln_dyn3d_dmp, rn_time_dmp, rn_time_dmp_out, &
+           &             cn_ice_lim, nn_ice_lim_dta,                             &
+           &             rn_ice_tem, rn_ice_sal, rn_ice_age,                     &
+           &             ln_vol, nn_volctl, nn_rimwidth, nb_jpk_bdy
+      !!----------------------------------------------------------------------
+      ! 0. initialisation
+      ! -----------------
+      CALL iom_open( cn_domcfg, inum )
+      !
+      ! ocean bottom level
+      CALL iom_get( inum, jpdom_unknown, 'bottom_level' , zbot , lrowattr=ln_use_jattr )  ! nb of ocean T-points
+      !
+      CALL iom_close( inum )
+      !
+      ! 2D ocean mask (=1 if at least one level of the water column is ocean, =0 otherwise)
+      WHERE( zbot(:,:) > 0 )   ;   kmask(:,:) = 1
+      ELSEWHERE                ;   kmask(:,:) = 0
+      END WHERE
+  
+      ! Adjust kmask with bdy_msk if it exists
+  
+      REWIND( numnam_ref )              ! Namelist nambdy in reference namelist : BDY
+      READ  ( numnam_ref, nambdy, IOSTAT = ios, ERR = 903)
+903   IF( ios /= 0 )   CALL ctl_nam ( ios , 'nambdy in reference namelist (mppini)', lwp )
+      !
+      REWIND( numnam_cfg )              ! Namelist nambdy in configuration namelist : BDY
+      READ  ( numnam_cfg, nambdy, IOSTAT = ios, ERR = 904 )
+904   IF( ios >  0 )   CALL ctl_nam ( ios , 'nambdy in configuration namelist (mppini)', lwp )
+
+      IF( ln_bdy .AND. ln_mask_file ) THEN
+         CALL iom_open( cn_mask_file, inum )
+         CALL iom_get ( inum, jpdom_unknown, 'bdy_msk', zbdy )
+         CALL iom_close( inum )
+         WHERE ( zbdy(:,:) <= 0. ) kmask = 0
+      ENDIF
+      !
+   END SUBROUTINE mpp_init_mask
+
+
+   SUBROUTINE mpp_init_ioipsl
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE mpp_init_ioipsl  ***
+      !!
+      !! ** Purpose :   
+      !!
+      !! ** Method  :   
+      !!
+      !! History :
+      !!   9.0  !  04-03  (G. Madec )  MPP-IOIPSL 
+      !!   " "  !  08-12  (A. Coward)  addition in case of jpni*jpnj < jpnij
+      !!----------------------------------------------------------------------
+      INTEGER, DIMENSION(2) ::   iglo, iloc, iabsf, iabsl, ihals, ihale, idid
+      !!----------------------------------------------------------------------
+
+      ! The domain is split only horizontally along i- or/and j- direction
+      ! So we need at the most only 1D arrays with 2 elements.
+      ! Set idompar values equivalent to the jpdom_local_noextra definition
+      ! used in IOM. This works even if jpnij .ne. jpni*jpnj.
+      iglo(1) = jpiglo
+      iglo(2) = jpjglo
+      iloc(1) = nlci
+      iloc(2) = nlcj
+      iabsf(1) = nimppt(narea)
+      iabsf(2) = njmppt(narea)
+      iabsl(:) = iabsf(:) + iloc(:) - 1
+      ihals(1) = nldi - 1
+      ihals(2) = nldj - 1
+      ihale(1) = nlci - nlei
+      ihale(2) = nlcj - nlej
+      idid(1) = 1
+      idid(2) = 2
+
+      IF(lwp) THEN
+          WRITE(numout,*)
+          WRITE(numout,*) 'mpp_init_ioipsl :   iloc  = ', iloc (1), iloc (2)
+          WRITE(numout,*) '~~~~~~~~~~~~~~~     iabsf = ', iabsf(1), iabsf(2)
+          WRITE(numout,*) '                    ihals = ', ihals(1), ihals(2)
+          WRITE(numout,*) '                    ihale = ', ihale(1), ihale(2)
+      ENDIF
+      !
+      CALL flio_dom_set ( jpnij, nproc, idid, iglo, iloc, iabsf, iabsl, ihals, ihale, 'BOX', nidom)
+      !
+   END SUBROUTINE mpp_init_ioipsl  
+
+
+   SUBROUTINE mpp_init_partition( num_pes )
+      !!----------------------------------------------------------------------
+      !!                 ***  ROUTINE mpp_init_partition  ***
+      !!
+      !! ** Purpose :
+      !!
+      !! ** Method  :
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT(in) ::   num_pes   ! The number of MPI processes we have
+      !
+      INTEGER, PARAMETER :: nfactmax = 20
+      INTEGER :: nfact ! The no. of factors returned
+      INTEGER :: ierr  ! Error flag
+      INTEGER :: ji
+      INTEGER :: idiff, mindiff, imin ! For choosing pair of factors that are closest in value
+      INTEGER, DIMENSION(nfactmax) :: ifact ! Array of factors
+      !!----------------------------------------------------------------------
+      !
+      ierr = 0
+      !
+      CALL factorise( ifact, nfactmax, nfact, num_pes, ierr )
+      !
+      IF( nfact <= 1 ) THEN
+         WRITE (numout, *) 'WARNING: factorisation of number of PEs failed'
+         WRITE (numout, *) '       : using grid of ',num_pes,' x 1'
+         jpnj = 1
+         jpni = num_pes
+      ELSE
+         ! Search through factors for the pair that are closest in value
+         mindiff = 1000000
+         imin    = 1
+         DO ji = 1, nfact-1, 2
+            idiff = ABS( ifact(ji) - ifact(ji+1) )
+            IF( idiff < mindiff ) THEN
+               mindiff = idiff
+               imin = ji
+            ENDIF
+         END DO
+         jpnj = ifact(imin)
+         jpni = ifact(imin + 1)
+      ENDIF
+      !
+      jpnij = jpni*jpnj
+      !
+   END SUBROUTINE mpp_init_partition
+
+
+   SUBROUTINE factorise( kfax, kmaxfax, knfax, kn, kerr )
+      !!----------------------------------------------------------------------
+      !!                     ***  ROUTINE factorise  ***
+      !!
+      !! ** Purpose :   return the prime factors of n.
+      !!                knfax factors are returned in array kfax which is of
+      !!                maximum dimension kmaxfax.
+      !! ** Method  :
+      !!----------------------------------------------------------------------
+      INTEGER                    , INTENT(in   ) ::   kn, kmaxfax
+      INTEGER                    , INTENT(  out) ::   kerr, knfax
+      INTEGER, DIMENSION(kmaxfax), INTENT(  out) ::   kfax
+      !
+      INTEGER :: ifac, jl, inu
+      INTEGER, PARAMETER :: ntest = 14
+      INTEGER, DIMENSION(ntest) ::   ilfax
+      !!----------------------------------------------------------------------
+      !
+      ! lfax contains the set of allowed factors.
+      ilfax(:) = (/(2**jl,jl=ntest,1,-1)/)
+      !
+      ! Clear the error flag and initialise output vars
+      kerr  = 0
+      kfax  = 1
+      knfax = 0
+      !
+      IF( kn /= 1 ) THEN      ! Find the factors of n
+         !
+         ! nu holds the unfactorised part of the number.
+         ! knfax holds the number of factors found.
+         ! l points to the allowed factor list.
+         ! ifac holds the current factor.
+         !
+         inu   = kn
+         knfax = 0
+         !
+         DO jl = ntest, 1, -1
+            !
+            ifac = ilfax(jl)
+            IF( ifac > inu )   CYCLE
+            !
+            ! Test whether the factor will divide.
+            !
+            IF( MOD(inu,ifac) == 0 ) THEN
+               !
+               knfax = knfax + 1            ! Add the factor to the list
+               IF( knfax > kmaxfax ) THEN
+                  kerr = 6
+                  write (*,*) 'FACTOR: insufficient space in factor array ', knfax
+                  return
+               ENDIF
+               kfax(knfax) = ifac
+               ! Store the other factor that goes with this one
+               knfax = knfax + 1
+               kfax(knfax) = inu / ifac
+               !WRITE (*,*) 'ARPDBG, factors ',knfax-1,' & ',knfax,' are ', kfax(knfax-1),' and ',kfax(knfax)
+            ENDIF
+            !
+         END DO
+         !
+      ENDIF
+      !
+   END SUBROUTINE factorise
+
+
+   SUBROUTINE mpp_init_nfdcom
+      !!----------------------------------------------------------------------
+      !!                     ***  ROUTINE  mpp_init_nfdcom  ***
+      !! ** Purpose :   Setup for north fold exchanges with explicit 
+      !!                point-to-point messaging
+      !!
+      !! ** Method :   Initialization of the northern neighbours lists.
+      !!----------------------------------------------------------------------
+      !!    1.0  ! 2011-10  (A. C. Coward, NOCS & J. Donners, PRACE)
+      !!    2.0  ! 2013-06 Setup avoiding MPI communication (I. Epicoco, S. Mocavero, CMCC) 
+      !!----------------------------------------------------------------------
+      INTEGER  ::   sxM, dxM, sxT, dxT, jn
+      INTEGER  ::   njmppmax
+      !!----------------------------------------------------------------------
+      !
+      njmppmax = MAXVAL( njmppt )
+      !
+      !initializes the north-fold communication variables
+      isendto(:) = 0
+      nsndto     = 0
+      !
+      IF ( njmpp == njmppmax ) THEN      ! if I am a process in the north
+         !
+         !sxM is the first point (in the global domain) needed to compute the north-fold for the current process
+         sxM = jpiglo - nimppt(narea) - nlcit(narea) + 1
+         !dxM is the last point (in the global domain) needed to compute the north-fold for the current process
+         dxM = jpiglo - nimppt(narea) + 2
+         !
+         ! loop over the other north-fold processes to find the processes
+         ! managing the points belonging to the sxT-dxT range
+         !
+         DO jn = 1, jpni
+            !
+            sxT = nfiimpp(jn, jpnj)                            ! sxT = 1st  point (in the global domain) of the jn process
+            dxT = nfiimpp(jn, jpnj) + nfilcit(jn, jpnj) - 1    ! dxT = last point (in the global domain) of the jn process
+            !
+            IF    ( sxT < sxM  .AND.  sxM < dxT ) THEN
+               nsndto          = nsndto + 1
+               isendto(nsndto) = jn
+            ELSEIF( sxM <= sxT  .AND.  dxM >= dxT ) THEN
+               nsndto          = nsndto + 1
+               isendto(nsndto) = jn
+            ELSEIF( dxM <  dxT  .AND.  sxT <  dxM ) THEN
+               nsndto          = nsndto + 1
+               isendto(nsndto) = jn
+            ENDIF
+            !
+         END DO
+         nfsloop = 1
+         nfeloop = nlci
+         DO jn = 2,jpni-1
+            IF( nfipproc(jn,jpnj) == (narea - 1) ) THEN
+               IF( nfipproc(jn-1,jpnj) == -1 )   nfsloop = nldi
+               IF( nfipproc(jn+1,jpnj) == -1 )   nfeloop = nlei
+            ENDIF
+         END DO
+         !
+      ENDIF
+      l_north_nogather = .TRUE.
+      !
+   END SUBROUTINE mpp_init_nfdcom
+
+   
+#endif
+
+   !!======================================================================
+END MODULE mppini
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/LDF/ldfc1d_c2d.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/LDF/ldfc1d_c2d.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/LDF/ldfc1d_c2d.F90	(revision 9570)
@@ -0,0 +1,168 @@
+MODULE ldfc1d_c2d
+   !!======================================================================
+   !!                    ***  MODULE  ldfc1d_c2d  ***
+   !! Ocean physics:  profile and horizontal shape of lateral eddy coefficients 
+   !!=====================================================================
+   !! History :  3.7  ! 2013-12  (G. Madec)  restructuration/simplification of aht/aeiv specification,
+   !!                 !                      add velocity dependent coefficient and optional read in file
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   ldf_c1d       : ah reduced by 1/4 on the vertical (tanh profile, inflection at 300m) 
+   !!   ldf_c2d       : ah = F(e1,e2) (laplacian or = F(e1^3,e2^3) (bilaplacian)
+   !!----------------------------------------------------------------------
+   USE oce            ! ocean dynamics and tracers
+   USE dom_oce        ! ocean space and time domain
+   USE phycst         ! physical constants
+   !
+   USE in_out_manager ! I/O manager
+   USE lib_mpp        ! distribued memory computing library
+   USE lbclnk         ! ocean lateral boundary conditions (or mpp link)
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   ldf_c1d   ! called by ldftra and ldfdyn modules
+   PUBLIC   ldf_c2d   ! called by ldftra and ldfdyn modules
+
+   REAL(wp) ::   r1_2  = 0.5_wp           ! =1/2
+   REAL(wp) ::   r1_4  = 0.25_wp          ! =1/4
+   REAL(wp) ::   r1_12 = 1._wp / 12._wp   ! =1/12
+ 
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.7 , NEMO Consortium (2015)
+   !! $Id: $
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE ldf_c1d( cd_type, pahs1, pahs2, pah1, pah2 )
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE ldf_c1d  ***
+      !!              
+      !! ** Purpose :   1D eddy diffusivity/viscosity coefficients
+      !!
+      !! ** Method  :   1D eddy diffusivity coefficients F( depth )
+      !!                Reduction by zratio from surface to bottom 
+      !!                hyperbolic tangent profile with inflection point 
+      !!                at zh=500m and a width of zw=200m
+      !!
+      !!   cd_type = TRA      pah1, pah2 defined at U- and V-points
+      !!             DYN      pah1, pah2 defined at T- and F-points
+      !!----------------------------------------------------------------------
+      CHARACTER(len=3)                , INTENT(in   ) ::   cd_type        ! DYNamique or TRAcers
+      REAL(wp), DIMENSION(jpi,jpj)    , INTENT(in   ) ::   pahs1, pahs2   ! surface value of eddy coefficient   [m2/s]
+      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pah1 , pah2    ! eddy coefficient                    [m2/s]
+      !
+      INTEGER  ::   ji, jj, jk      ! dummy loop indices
+      REAL(wp) ::   zh, zc, zdep1   ! local scalars
+      REAL(wp) ::   zw    , zdep2   !   -      -
+      REAL(wp) ::   zratio          !   -      -
+      !!----------------------------------------------------------------------
+      !
+      IF(lwp) WRITE(numout,*)
+      IF(lwp) WRITE(numout,*) '   ldf_c1d : set a given profile to eddy mixing coefficients'
+      !
+      ! initialization of the profile
+      zratio = 0.25_wp           ! surface/bottom ratio
+      zh =  500._wp              ! depth    of the inflection point [m]
+      zw =  1._wp / 200._wp      ! width^-1     -        -      -   [1/m]
+      !                          ! associated coefficient           [-]
+      zc = ( 1._wp - zratio ) / ( 1._wp + TANH( zh * zw) )
+      !
+      !
+      SELECT CASE( cd_type )        ! point of calculation
+      !
+      CASE( 'DYN' )                     ! T- and F-points
+         DO jk = jpkm1, 1, -1                ! pah1 at T-point
+            pah1(:,:,jk) = pahs1(:,:) * (  zratio + zc * ( 1._wp + TANH( - ( gdept_0(:,:,jk) - zh ) * zw) )  )
+         END DO
+         DO jk = jpkm1, 1, -1                ! pah2 at F-point (zdep2 is an approximation in zps-coord.)
+            DO jj = 1, jpjm1
+               DO ji = 1, jpim1
+                  zdep2 = (  gdept_0(ji,jj+1,jk) + gdept_0(ji+1,jj+1,jk)   &
+                     &     + gdept_0(ji,jj  ,jk) + gdept_0(ji+1,jj  ,jk)  ) * r1_4
+                  pah2(ji,jj,jk) = pahs2(ji,jj) * (  zratio + zc * ( 1._wp + TANH( - ( zdep2 - zh ) * zw) )  )
+               END DO
+            END DO
+         END DO
+         CALL lbc_lnk( pah2, 'F', 1. )   ! Lateral boundary conditions
+         !
+      CASE( 'TRA' )                     ! U- and V-points (zdep1 & 2 are an approximation in zps-coord.)
+         DO jk = jpkm1, 1, -1
+            DO jj = 1, jpjm1
+               DO ji = 1, jpim1
+                  zdep1 = (  gdept_0(ji,jj,jk) + gdept_0(ji+1,jj,jk)  ) * 0.5_wp
+                  zdep2 = (  gdept_0(ji,jj,jk) + gdept_0(ji,jj+1,jk)  ) * 0.5_wp
+                  pah1(ji,jj,jk) = pahs1(ji,jj) * (  zratio + zc * ( 1._wp + TANH( - ( zdep1 - zh ) * zw) )  )
+                  pah2(ji,jj,jk) = pahs2(ji,jj) * (  zratio + zc * ( 1._wp + TANH( - ( zdep2 - zh ) * zw) )  )
+               END DO
+            END DO
+         END DO
+         ! Lateral boundary conditions
+         CALL lbc_lnk_multi( pah1, 'U', 1. , pah2, 'V', 1. )   
+         !
+      CASE DEFAULT                        ! error
+         CALL ctl_stop( 'ldf_c1d: ', cd_type, ' Unknown, i.e. /= DYN or TRA' )
+      END SELECT
+      !
+   END SUBROUTINE ldf_c1d
+
+
+   SUBROUTINE ldf_c2d( cd_type, pUfac, knn, pah1, pah2 )
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE ldf_c2d  ***
+      !!              
+      !! ** Purpose :   2D eddy diffusivity/viscosity coefficients
+      !!
+      !! ** Method  :   2D eddy diffusivity coefficients F( e1 , e2 )
+      !!       laplacian   operator :   ah proportional to the scale factor      [m2/s]
+      !!       bilaplacian operator :   ah proportional to the (scale factor)^3  [m4/s]
+      !!       In both cases, pah0 is the maximum value reached by the coefficient 
+      !!       at the Equator in case of e1=ra*rad= ~111km, not over the whole domain.
+      !!
+      !!   cd_type = TRA      pah1, pah2 defined at U- and V-points
+      !!             DYN      pah1, pah2 defined at T- and F-points
+      !!----------------------------------------------------------------------
+      CHARACTER(len=3)          , INTENT(in   ) ::   cd_type      ! DYNamique or TRAcers
+      REAL(wp)                  , INTENT(in   ) ::   pUfac        ! =1/2*Uc LAPlacian BiLaPlacian
+      INTEGER                   , INTENT(in   ) ::   knn          ! characteristic velocity   [m/s]
+      REAL(wp), DIMENSION(:,:,:), INTENT(  out) ::   pah1, pah2   ! eddy coefficients         [m2/s or m4/s]
+      !
+      INTEGER  ::   ji, jj, jk   ! dummy loop indices
+      INTEGER  ::   inn          ! local integer
+      !!----------------------------------------------------------------------
+      !
+      IF(lwp) WRITE(numout,*)
+      IF(lwp) WRITE(numout,*) '   ldf_c2d :   aht = Ufac * max(e1,e2)   with Ufac = ', pUfac, ' m/s'
+      !
+      !
+      SELECT CASE( cd_type )        !==  surface values  ==!  (chosen grid point function of DYN or TRA)
+      !
+      CASE( 'DYN' )                       ! T- and F-points
+         DO jj = 1, jpj
+            DO ji = 1, jpi 
+               pah1(ji,jj,1) = pUfac * MAX( e1t(ji,jj) , e2t(ji,jj) )**knn
+               pah2(ji,jj,1) = pUfac * MAX( e1f(ji,jj) , e2f(ji,jj) )**knn
+            END DO
+         END DO
+      CASE( 'TRA' )                       ! U- and V-points
+         DO jj = 1, jpj 
+            DO ji = 1, jpi 
+               pah1(ji,jj,1) = pUfac * MAX( e1u(ji,jj), e2u(ji,jj) )**knn
+               pah2(ji,jj,1) = pUfac * MAX( e1v(ji,jj), e2v(ji,jj) )**knn
+            END DO
+         END DO
+      CASE DEFAULT                        ! error
+         CALL ctl_stop( 'ldf_c2d: ', cd_type, ' Unknown, i.e. /= DYN or TRA' )
+      END SELECT
+      !                             !==  deeper values = surface one  ==!  (except jpk)
+      DO jk = 2, jpkm1
+         pah1(:,:,jk) = pah1(:,:,1)
+         pah2(:,:,jk) = pah2(:,:,1)
+      END DO
+      !
+   END SUBROUTINE ldf_c2d
+
+   !!======================================================================
+END MODULE ldfc1d_c2d
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/LDF/ldfdyn.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/LDF/ldfdyn.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/LDF/ldfdyn.F90	(revision 9570)
@@ -0,0 +1,493 @@
+MODULE ldfdyn
+   !!======================================================================
+   !!                       ***  MODULE  ldfdyn  ***
+   !! Ocean physics:  lateral viscosity coefficient 
+   !!=====================================================================
+   !! History :  OPA  ! 1997-07  (G. Madec)  multi dimensional coefficients
+   !!   NEMO     1.0  ! 2002-09  (G. Madec)  F90: Free form and module
+   !!            3.7  ! 2014-01  (F. Lemarie, G. Madec)  restructuration/simplification of ahm specification,
+   !!                 !                                  add velocity dependent coefficient and optional read in file
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   ldf_dyn_init  : initialization, namelist read, and parameters control
+   !!   ldf_dyn       : update lateral eddy viscosity coefficients at each time step 
+   !!----------------------------------------------------------------------
+   USE oce             ! ocean dynamics and tracers   
+   USE dom_oce         ! ocean space and time domain 
+   USE phycst          ! physical constants
+   USE ldfslp          ! lateral diffusion: slopes of mixing orientation
+   USE ldfc1d_c2d      ! lateral diffusion: 1D and 2D cases
+   !
+   USE in_out_manager  ! I/O manager
+   USE iom             ! I/O module for ehanced bottom friction file
+   USE timing          ! Timing
+   USE lib_mpp         ! distribued memory computing library
+   USE lbclnk          ! ocean lateral boundary conditions (or mpp link)
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   ldf_dyn_init   ! called by nemogcm.F90
+   PUBLIC   ldf_dyn        ! called by step.F90
+
+   !                                    !!* Namelist namdyn_ldf : lateral mixing on momentum *
+   LOGICAL , PUBLIC ::   ln_dynldf_OFF   !: No operator (i.e. no explicit diffusion)
+   LOGICAL , PUBLIC ::   ln_dynldf_lap   !: laplacian operator
+   LOGICAL , PUBLIC ::   ln_dynldf_blp   !: bilaplacian operator
+   LOGICAL , PUBLIC ::   ln_dynldf_lev   !: iso-level direction
+   LOGICAL , PUBLIC ::   ln_dynldf_hor   !: horizontal (geopotential) direction
+!  LOGICAL , PUBLIC ::   ln_dynldf_iso   !: iso-neutral direction                        (see ldfslp)
+   INTEGER , PUBLIC ::   nn_ahm_ijk_t    !: choice of time & space variations of the lateral eddy viscosity coef.
+   !                                        !  time invariant coefficients:  aht = 1/2  Ud*Ld   (lap case) 
+   !                                           !                             bht = 1/12 Ud*Ld^3 (blp case)
+   REAL(wp), PUBLIC ::   rn_Uv                 !: lateral viscous velocity  [m/s]
+   REAL(wp), PUBLIC ::   rn_Lv                 !: lateral viscous length    [m]
+   !                                        ! Smagorinsky viscosity  (nn_ahm_ijk_t = 32) 
+   REAL(wp), PUBLIC ::   rn_csmc               !: Smagorinsky constant of proportionality 
+   REAL(wp), PUBLIC ::   rn_minfac             !: Multiplicative factor of theorectical minimum Smagorinsky viscosity
+   REAL(wp), PUBLIC ::   rn_maxfac             !: Multiplicative factor of theorectical maximum Smagorinsky viscosity
+   !                                        ! iso-neutral laplacian (ln_dynldf_lap=ln_dynldf_iso=T)
+   REAL(wp), PUBLIC ::   rn_ahm_b              !: lateral laplacian background eddy viscosity  [m2/s]
+
+   !                                    !!* Parameter to control the type of lateral viscous operator
+   INTEGER, PARAMETER, PUBLIC ::   np_ERROR  =-10                       !: error in setting the operator
+   INTEGER, PARAMETER, PUBLIC ::   np_no_ldf = 00                       !: without operator (i.e. no lateral viscous trend)
+   !                          !!      laplacian     !    bilaplacian    !
+   INTEGER, PARAMETER, PUBLIC ::   np_lap    = 10   ,   np_blp    = 20  !: iso-level operator
+   INTEGER, PARAMETER, PUBLIC ::   np_lap_i  = 11                       !: iso-neutral or geopotential operator
+   !
+   INTEGER           , PUBLIC ::   nldf_dyn         !: type of lateral diffusion used defined from ln_dynldf_... (namlist logicals)
+   LOGICAL           , PUBLIC ::   l_ldfdyn_time    !: flag for time variation of the lateral eddy viscosity coef.
+
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   ahmt, ahmf   !: eddy viscosity coef. at T- and F-points [m2/s or m4/s]
+   REAL(wp),         ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   dtensq       !: horizontal tension squared         (Smagorinsky only)
+   REAL(wp),         ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   dshesq       !: horizontal shearing strain squared (Smagorinsky only)
+   REAL(wp),         ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   esqt, esqf   !: Square of the local gridscale (e1e2/(e1+e2))**2           
+
+   REAL(wp) ::   r1_2    = 0.5_wp            ! =1/2
+   REAL(wp) ::   r1_4    = 0.25_wp           ! =1/4
+   REAL(wp) ::   r1_8    = 0.125_wp          ! =1/8
+   REAL(wp) ::   r1_12   = 1._wp / 12._wp    ! =1/12
+   REAL(wp) ::   r1_288  = 1._wp / 288._wp   ! =1/( 12^2 * 2 )
+
+   !! * Substitutions
+#  include "vectopt_loop_substitute.h90"
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.7 , NEMO Consortium (2014)
+   !! $Id$ 
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE ldf_dyn_init
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE ldf_dyn_init  ***
+      !!                   
+      !! ** Purpose :   set the horizontal ocean dynamics physics
+      !!
+      !! ** Method  :   the eddy viscosity coef. specification depends on:
+      !!              - the operator:
+      !!             ln_dynldf_lap = T     laplacian operator
+      !!             ln_dynldf_blp = T   bilaplacian operator
+      !!              - the parameter nn_ahm_ijk_t:
+      !!    nn_ahm_ijk_t  =  0 => = constant
+      !!                  = 10 => = F(z) :     = constant with a reduction of 1/4 with depth 
+      !!                  =-20 => = F(i,j)     = shape read in 'eddy_viscosity.nc' file
+      !!                  = 20    = F(i,j)     = F(e1,e2) or F(e1^3,e2^3) (lap or bilap case)
+      !!                  =-30 => = F(i,j,k)   = shape read in 'eddy_viscosity.nc'  file
+      !!                  = 30    = F(i,j,k)   = 2D (case 20) + decrease with depth (case 10)
+      !!                  = 31    = F(i,j,k,t) = F(local velocity) (  |u|e  /12   laplacian operator
+      !!                                                           or |u|e^3/12 bilaplacian operator )
+      !!                  = 32    = F(i,j,k,t) = F(local deformation rate and gridscale) (D and L) (Smagorinsky)  
+      !!                                                           (   L^2|D|      laplacian operator
+      !!                                                           or  L^4|D|/8  bilaplacian operator )
+      !!----------------------------------------------------------------------
+      INTEGER  ::   ji, jj, jk                     ! dummy loop indices
+      INTEGER  ::   ioptio, ierr, inum, ios, inn   ! local integer
+      REAL(wp) ::   zah0, zah_max, zUfac           ! local scalar
+      CHARACTER(len=5) ::   cl_Units               ! units (m2/s or m4/s)
+      !!
+      NAMELIST/namdyn_ldf/ ln_dynldf_OFF, ln_dynldf_lap, ln_dynldf_blp,   &   ! type of operator
+         &                 ln_dynldf_lev, ln_dynldf_hor, ln_dynldf_iso,   &   ! acting direction of the operator
+         &                 nn_ahm_ijk_t , rn_Uv    , rn_Lv,   rn_ahm_b,   &   ! lateral eddy coefficient
+         &                 rn_csmc      , rn_minfac    , rn_maxfac            ! Smagorinsky settings
+      !!----------------------------------------------------------------------
+      !
+      REWIND( numnam_ref )              ! Namelist namdyn_ldf in reference namelist : Lateral physics
+      READ  ( numnam_ref, namdyn_ldf, IOSTAT = ios, ERR = 901)
+901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namdyn_ldf in reference namelist', lwp )
+
+      REWIND( numnam_cfg )              ! Namelist namdyn_ldf in configuration namelist : Lateral physics
+      READ  ( numnam_cfg, namdyn_ldf, IOSTAT = ios, ERR = 902 )
+902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namdyn_ldf in configuration namelist', lwp )
+      IF(lwm) WRITE ( numond, namdyn_ldf )
+
+      IF(lwp) THEN                      ! Parameter print
+         WRITE(numout,*)
+         WRITE(numout,*) 'ldf_dyn : lateral momentum physics'
+         WRITE(numout,*) '~~~~~~~'
+         WRITE(numout,*) '   Namelist namdyn_ldf : set lateral mixing parameters'
+         !
+         WRITE(numout,*) '      type :'
+         WRITE(numout,*) '         no explicit diffusion                ln_dynldf_OFF = ', ln_dynldf_OFF
+         WRITE(numout,*) '         laplacian operator                   ln_dynldf_lap = ', ln_dynldf_lap
+         WRITE(numout,*) '         bilaplacian operator                 ln_dynldf_blp = ', ln_dynldf_blp
+         !
+         WRITE(numout,*) '      direction of action :'
+         WRITE(numout,*) '         iso-level                            ln_dynldf_lev = ', ln_dynldf_lev
+         WRITE(numout,*) '         horizontal (geopotential)            ln_dynldf_hor = ', ln_dynldf_hor
+         WRITE(numout,*) '         iso-neutral                          ln_dynldf_iso = ', ln_dynldf_iso
+         !
+         WRITE(numout,*) '      coefficients :'
+         WRITE(numout,*) '         type of time-space variation         nn_ahm_ijk_t  = ', nn_ahm_ijk_t
+         WRITE(numout,*) '         lateral viscous velocity  (if cst)      rn_Uv      = ', rn_Uv, ' m/s'
+         WRITE(numout,*) '         lateral viscous length    (if cst)      rn_Lv      = ', rn_Lv, ' m'
+         WRITE(numout,*) '         background viscosity (iso-lap case)     rn_ahm_b   = ', rn_ahm_b, ' m2/s'
+         !
+         WRITE(numout,*) '      Smagorinsky settings (nn_ahm_ijk_t  = 32) :'
+         WRITE(numout,*) '         Smagorinsky coefficient              rn_csmc       = ', rn_csmc
+         WRITE(numout,*) '         factor multiplier for eddy visc.'
+         WRITE(numout,*) '            lower limit (default 1.0)         rn_minfac    = ', rn_minfac
+         WRITE(numout,*) '            upper limit (default 1.0)         rn_maxfac    = ', rn_maxfac
+      ENDIF
+
+      !
+      !           !==  type of lateral operator used  ==!   (set nldf_dyn)
+      !           !=====================================!
+      !
+      nldf_dyn = np_ERROR
+      ioptio = 0
+      IF( ln_dynldf_OFF ) THEN   ;   nldf_dyn = np_no_ldf   ;   ioptio = ioptio + 1   ;   ENDIF
+      IF( ln_dynldf_lap ) THEN   ;                              ioptio = ioptio + 1   ;   ENDIF
+      IF( ln_dynldf_blp ) THEN   ;                              ioptio = ioptio + 1   ;   ENDIF
+      IF( ioptio /= 1   )   CALL ctl_stop( 'dyn_ldf_init: use ONE of the 3 operator options (NONE/lap/blp)' )
+      !
+      IF(.NOT.ln_dynldf_OFF ) THEN     !==  direction ==>> type of operator  ==!
+         ioptio = 0
+         IF( ln_dynldf_lev )   ioptio = ioptio + 1
+         IF( ln_dynldf_hor )   ioptio = ioptio + 1
+         IF( ln_dynldf_iso )   ioptio = ioptio + 1
+         IF( ioptio /= 1   )   CALL ctl_stop( 'dyn_ldf_init: use ONE of the 3 direction options (level/hor/iso)' )
+         !
+         !                             ! Set nldf_dyn, the type of lateral diffusion, from ln_dynldf_... logicals
+         ierr = 0
+         IF( ln_dynldf_lap ) THEN         ! laplacian operator
+            IF( ln_zco ) THEN                   ! z-coordinate
+               IF ( ln_dynldf_lev )   nldf_dyn = np_lap     ! iso-level = horizontal (no rotation)
+               IF ( ln_dynldf_hor )   nldf_dyn = np_lap     ! iso-level = horizontal (no rotation)
+               IF ( ln_dynldf_iso )   nldf_dyn = np_lap_i   ! iso-neutral            (   rotation)
+            ENDIF
+            IF( ln_zps ) THEN                   ! z-coordinate with partial step
+               IF ( ln_dynldf_lev )   nldf_dyn = np_lap     ! iso-level              (no rotation)
+               IF ( ln_dynldf_hor )   nldf_dyn = np_lap     ! iso-level              (no rotation)
+               IF ( ln_dynldf_iso )   nldf_dyn = np_lap_i   ! iso-neutral            (   rotation)
+            ENDIF
+            IF( ln_sco ) THEN                   ! s-coordinate
+               IF ( ln_dynldf_lev )   nldf_dyn = np_lap     ! iso-level = horizontal (no rotation)
+               IF ( ln_dynldf_hor )   nldf_dyn = np_lap_i   ! horizontal             (   rotation)
+               IF ( ln_dynldf_iso )   nldf_dyn = np_lap_i   ! iso-neutral            (   rotation)
+            ENDIF
+         ENDIF
+         !
+         IF( ln_dynldf_blp ) THEN         ! bilaplacian operator
+            IF( ln_zco ) THEN                   ! z-coordinate
+               IF( ln_dynldf_lev )   nldf_dyn = np_blp   ! iso-level = horizontal (no rotation)
+               IF( ln_dynldf_hor )   nldf_dyn = np_blp   ! iso-level = horizontal (no rotation)
+               IF( ln_dynldf_iso )   ierr = 2            ! iso-neutral            (   rotation)
+            ENDIF
+            IF( ln_zps ) THEN                   ! z-coordinate with partial step
+               IF( ln_dynldf_lev )   nldf_dyn = np_blp   ! iso-level              (no rotation)
+               IF( ln_dynldf_hor )   nldf_dyn = np_blp   ! iso-level              (no rotation)
+               IF( ln_dynldf_iso )   ierr = 2            ! iso-neutral            (   rotation)
+            ENDIF
+            IF( ln_sco ) THEN                   ! s-coordinate
+               IF( ln_dynldf_lev )   nldf_dyn = np_blp   ! iso-level              (no rotation)
+               IF( ln_dynldf_hor )   ierr = 2            ! horizontal             (   rotation)
+               IF( ln_dynldf_iso )   ierr = 2            ! iso-neutral            (   rotation)
+            ENDIF
+         ENDIF
+         !
+         IF( ierr == 2 )   CALL ctl_stop( 'rotated bi-laplacian operator does not exist' )
+         !
+         IF( nldf_dyn == np_lap_i )   l_ldfslp = .TRUE.  ! rotation require the computation of the slopes
+         !
+      ENDIF
+      !
+      IF(lwp) THEN
+         WRITE(numout,*)
+         SELECT CASE( nldf_dyn )
+         CASE( np_no_ldf )   ;   WRITE(numout,*) '   ==>>>   NO lateral viscosity'
+         CASE( np_lap    )   ;   WRITE(numout,*) '   ==>>>   iso-level laplacian operator'
+         CASE( np_lap_i  )   ;   WRITE(numout,*) '   ==>>>   rotated laplacian operator with iso-level background'
+         CASE( np_blp    )   ;   WRITE(numout,*) '   ==>>>   iso-level bi-laplacian operator'
+         END SELECT
+         WRITE(numout,*)
+      ENDIF
+      
+      !
+      !           !==  Space/time variation of eddy coefficients  ==!
+      !           !=================================================!
+      !
+      l_ldfdyn_time = .FALSE.                ! no time variation except in case defined below
+      !
+      IF( ln_dynldf_OFF ) THEN
+         IF(lwp) WRITE(numout,*) '   ==>>>   No viscous operator selected. ahmt and ahmf are not allocated'
+         RETURN
+         !
+      ELSE                                   !==  a lateral diffusion operator is used  ==!
+         !
+         !                                         ! allocate the ahm arrays
+         ALLOCATE( ahmt(jpi,jpj,jpk) , ahmf(jpi,jpj,jpk) , STAT=ierr )
+         IF( ierr /= 0 )   CALL ctl_stop( 'STOP', 'ldf_dyn_init: failed to allocate arrays')
+         !
+         ahmt(:,:,jpk) = 0._wp                     ! last level always 0  
+         ahmf(:,:,jpk) = 0._wp
+         !
+         !                                         ! value of lap/blp eddy mixing coef.
+         IF(     ln_dynldf_lap ) THEN   ;   zUfac = r1_2 *rn_Uv   ;   inn = 1   ;   cl_Units = ' m2/s'   !   laplacian
+         ELSEIF( ln_dynldf_blp ) THEN   ;   zUfac = r1_12*rn_Uv   ;   inn = 3   ;   cl_Units = ' m4/s'   ! bilaplacian
+         ENDIF
+         zah0    = zUfac *    rn_Lv**inn              ! mixing coefficient
+         zah_max = zUfac * (ra*rad)**inn              ! maximum reachable coefficient (value at the Equator)
+         !
+         SELECT CASE(  nn_ahm_ijk_t  )             !* Specification of space-time variations of ahmt, ahmf
+         !
+         CASE(   0  )      !==  constant  ==!
+            IF(lwp) WRITE(numout,*) '   ==>>>   eddy viscosity. = constant = ', zah0, cl_Units
+            ahmt(:,:,1:jpkm1) = zah0
+            ahmf(:,:,1:jpkm1) = zah0
+            !
+         CASE(  10  )      !==  fixed profile  ==!
+            IF(lwp) WRITE(numout,*) '   ==>>>   eddy viscosity = F( depth )'
+            IF(lwp) WRITE(numout,*) '           surface viscous coef. = constant = ', zah0, cl_Units
+            ahmt(:,:,1) = zah0                        ! constant surface value
+            ahmf(:,:,1) = zah0
+            CALL ldf_c1d( 'DYN', ahmt(:,:,1), ahmf(:,:,1), ahmt, ahmf )
+            !
+         CASE ( -20 )      !== fixed horizontal shape read in file  ==!
+            IF(lwp) WRITE(numout,*) '   ==>>>   eddy viscosity = F(i,j) read in eddy_viscosity.nc file'
+            CALL iom_open( 'eddy_viscosity_2D.nc', inum )
+            CALL iom_get ( inum, jpdom_data, 'ahmt_2d', ahmt(:,:,1) )
+            CALL iom_get ( inum, jpdom_data, 'ahmf_2d', ahmf(:,:,1) )
+            CALL iom_close( inum )
+            DO jk = 2, jpkm1
+               ahmt(:,:,jk) = ahmt(:,:,1)
+               ahmf(:,:,jk) = ahmf(:,:,1)
+            END DO
+            !
+         CASE(  20  )      !== fixed horizontal shape  ==!
+            IF(lwp) WRITE(numout,*) '   ==>>>   eddy viscosity = F( e1, e2 ) or F( e1^3, e2^3 ) (lap. or blp. case)'
+            IF(lwp) WRITE(numout,*) '           using a fixed viscous velocity = ', rn_Uv  ,' m/s   and   Lv = Max(e1,e2)'
+            IF(lwp) WRITE(numout,*) '           maximum reachable coefficient (at the Equator) = ', zah_max, cl_Units, '  for e1=1°)'
+            CALL ldf_c2d( 'DYN', zUfac      , inn        , ahmt, ahmf )         ! surface value proportional to scale factor^inn
+            !
+         CASE( -30  )      !== fixed 3D shape read in file  ==!
+            IF(lwp) WRITE(numout,*) '   ==>>>   eddy viscosity = F(i,j,k) read in eddy_viscosity_3D.nc file'
+            CALL iom_open( 'eddy_viscosity_3D.nc', inum )
+            CALL iom_get ( inum, jpdom_data, 'ahmt_3d', ahmt )
+            CALL iom_get ( inum, jpdom_data, 'ahmf_3d', ahmf )
+            CALL iom_close( inum )
+            !
+         CASE(  30  )       !==  fixed 3D shape  ==!
+            IF(lwp) WRITE(numout,*) '   ==>>>   eddy viscosity = F( latitude, longitude, depth )'
+            IF(lwp) WRITE(numout,*) '           using a fixed viscous velocity = ', rn_Uv  ,' m/s   and   Ld = Max(e1,e2)'
+            IF(lwp) WRITE(numout,*) '           maximum reachable coefficient (at the Equator) = ', zah_max, cl_Units, '  for e1=1°)'
+            CALL ldf_c2d( 'DYN', zUfac      , inn        , ahmt, ahmf )         ! surface value proportional to scale factor^inn
+            CALL ldf_c1d( 'DYN', ahmt(:,:,1), ahmf(:,:,1), ahmt, ahmf )  ! reduction with depth
+            !
+         CASE(  31  )       !==  time varying 3D field  ==!
+            IF(lwp) WRITE(numout,*) '   ==>>>   eddy viscosity = F( latitude, longitude, depth , time )'
+            IF(lwp) WRITE(numout,*) '           proportional to the local velocity : 1/2 |u|e (lap) or 1/12 |u|e^3 (blp)'
+            !
+            l_ldfdyn_time = .TRUE.     ! will be calculated by call to ldf_dyn routine in step.F90
+            !
+         CASE(  32  )       !==  time varying 3D field  ==!
+            IF(lwp) WRITE(numout,*) '   ==>>>   eddy viscosity = F( latitude, longitude, depth , time )'
+            IF(lwp) WRITE(numout,*) '           proportional to the local deformation rate and gridscale (Smagorinsky)'
+            !
+            l_ldfdyn_time = .TRUE.     ! will be calculated by call to ldf_dyn routine in step.F90
+            !
+            !                          ! allocate arrays used in ldf_dyn. 
+            ALLOCATE( dtensq(jpi,jpj) , dshesq(jpi,jpj) , esqt(jpi,jpj) ,  esqf(jpi,jpj) , STAT=ierr )
+            IF( ierr /= 0 )   CALL ctl_stop( 'STOP', 'ldf_dyn_init: failed to allocate Smagorinsky arrays')
+            !
+            DO jj = 2, jpjm1           ! Set local gridscale values
+               DO ji = fs_2, fs_jpim1
+                  esqt(ji,jj) = ( e1e2t(ji,jj) /( e1t(ji,jj) + e2t(ji,jj) ) )**2 
+                  esqf(ji,jj) = ( e1e2f(ji,jj) /( e1f(ji,jj) + e2f(ji,jj) ) )**2 
+               END DO
+            END DO
+            !
+         CASE DEFAULT
+            CALL ctl_stop('ldf_dyn_init: wrong choice for nn_ahm_ijk_t, the type of space-time variation of ahm')
+         END SELECT
+         !
+         IF( .NOT.l_ldfdyn_time ) THEN             !* No time variation 
+            IF(     ln_dynldf_lap ) THEN                 !   laplacian operator (mask only)
+               ahmt(:,:,1:jpkm1) =       ahmt(:,:,1:jpkm1)   * tmask(:,:,1:jpkm1)
+               ahmf(:,:,1:jpkm1) =       ahmf(:,:,1:jpkm1)   * fmask(:,:,1:jpkm1)
+            ELSEIF( ln_dynldf_blp ) THEN                 ! bilaplacian operator (square root + mask)
+               ahmt(:,:,1:jpkm1) = SQRT( ahmt(:,:,1:jpkm1) ) * tmask(:,:,1:jpkm1)
+               ahmf(:,:,1:jpkm1) = SQRT( ahmf(:,:,1:jpkm1) ) * fmask(:,:,1:jpkm1)
+            ENDIF
+         ENDIF
+         !
+      ENDIF
+      !
+   END SUBROUTINE ldf_dyn_init
+
+
+   SUBROUTINE ldf_dyn( kt )
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE ldf_dyn  ***
+      !! 
+      !! ** Purpose :   update at kt the momentum lateral mixing coeff. (ahmt and ahmf)
+      !!
+      !! ** Method  :   time varying eddy viscosity coefficients:
+      !!
+      !!    nn_ahm_ijk_t = 31    ahmt, ahmf = F(i,j,k,t) = F(local velocity) 
+      !!                         ( |u|e /12  or  |u|e^3/12 for laplacian or bilaplacian operator )
+      !!
+      !!    nn_ahm_ijk_t = 32    ahmt, ahmf = F(i,j,k,t) = F(local deformation rate and gridscale) (D and L) (Smagorinsky)  
+      !!                         ( L^2|D|    or  L^4|D|/8  for laplacian or bilaplacian operator )
+      !!
+      !! ** note    :    in BLP cases the sqrt of the eddy coef is returned, since bilaplacian is en re-entrant laplacian
+      !! ** action  :    ahmt, ahmf   updated at each time step
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT(in) ::   kt   ! time step index
+      !
+      INTEGER  ::   ji, jj, jk   ! dummy loop indices
+      REAL(wp) ::   zu2pv2_ij_p1, zu2pv2_ij, zu2pv2_ij_m1, zetmax, zefmax   ! local scalar
+      REAL(wp) ::   zcmsmag, zstabf_lo, zstabf_up, zdelta, zdb              ! local scalar
+      !!----------------------------------------------------------------------
+      !
+      IF( ln_timing )   CALL timing_start('ldf_dyn')
+      !
+      SELECT CASE(  nn_ahm_ijk_t  )       !== Eddy vicosity coefficients ==!
+      !
+      CASE(  31  )       !==  time varying 3D field  ==!   = F( local velocity )
+         !
+         IF( ln_dynldf_lap   ) THEN        ! laplacian operator : |u| e /12 = |u/144| e
+            DO jk = 1, jpkm1
+               DO jj = 2, jpjm1
+                  DO ji = fs_2, fs_jpim1
+                     zu2pv2_ij_p1 = ub(ji  ,jj+1,jk) * ub(ji  ,jj+1,jk) + vb(ji+1,jj  ,jk) * vb(ji+1,jj  ,jk)
+                     zu2pv2_ij    = ub(ji  ,jj  ,jk) * ub(ji  ,jj  ,jk) + vb(ji  ,jj  ,jk) * vb(ji  ,jj  ,jk)
+                     zu2pv2_ij_m1 = ub(ji-1,jj  ,jk) * ub(ji-1,jj  ,jk) + vb(ji  ,jj-1,jk) * vb(ji  ,jj-1,jk)
+                     zetmax = MAX( e1t(ji,jj) , e2t(ji,jj) )
+                     zefmax = MAX( e1f(ji,jj) , e2f(ji,jj) )
+                     ahmt(ji,jj,jk) = SQRT( (zu2pv2_ij + zu2pv2_ij_m1) * r1_288 ) * zetmax * tmask(ji,jj,jk)      ! 288= 12*12 * 2
+                     ahmf(ji,jj,jk) = SQRT( (zu2pv2_ij + zu2pv2_ij_p1) * r1_288 ) * zefmax * fmask(ji,jj,jk)
+                  END DO
+               END DO
+            END DO
+         ELSEIF( ln_dynldf_blp ) THEN      ! bilaplacian operator : sqrt( |u| e^3 /12 ) = sqrt( |u/144| e ) * e
+            DO jk = 1, jpkm1
+               DO jj = 2, jpjm1
+                  DO ji = fs_2, fs_jpim1
+                     zu2pv2_ij_p1 = ub(ji  ,jj+1,jk) * ub(ji  ,jj+1,jk) + vb(ji+1,jj  ,jk) * vb(ji+1,jj  ,jk)
+                     zu2pv2_ij    = ub(ji  ,jj  ,jk) * ub(ji  ,jj  ,jk) + vb(ji  ,jj  ,jk) * vb(ji  ,jj  ,jk)
+                     zu2pv2_ij_m1 = ub(ji-1,jj  ,jk) * ub(ji-1,jj  ,jk) + vb(ji  ,jj-1,jk) * vb(ji  ,jj-1,jk)
+                     zetmax = MAX( e1t(ji,jj) , e2t(ji,jj) )
+                     zefmax = MAX( e1f(ji,jj) , e2f(ji,jj) )
+                     ahmt(ji,jj,jk) = SQRT(  SQRT( (zu2pv2_ij + zu2pv2_ij_m1) * r1_288 ) * zetmax  ) * zetmax * tmask(ji,jj,jk)
+                     ahmf(ji,jj,jk) = SQRT(  SQRT( (zu2pv2_ij + zu2pv2_ij_p1) * r1_288 ) * zefmax  ) * zefmax * fmask(ji,jj,jk)
+                  END DO
+               END DO
+            END DO
+         ENDIF
+         !
+         CALL lbc_lnk_multi( ahmt, 'T', 1.,  ahmf, 'F', 1. )
+         !
+         !
+      CASE(  32  )       !==  time varying 3D field  ==!   = F( local deformation rate and gridscale ) (Smagorinsky)
+         !
+         IF( ln_dynldf_lap .OR. ln_dynldf_blp  ) THEN        ! laplacian operator : (C_smag/pi)^2 L^2 |D|
+            !
+            zcmsmag = (rn_csmc/rpi)**2                                              ! (C_smag/pi)^2
+            zstabf_lo  = rn_minfac * rn_minfac / ( 2._wp * 4._wp * zcmsmag )        ! lower limit stability factor scaling
+            zstabf_up  = rn_maxfac / ( 4._wp * zcmsmag * 2._wp * rdt )              ! upper limit stability factor scaling
+            IF( ln_dynldf_blp ) zstabf_lo = ( 16._wp / 9._wp ) * zstabf_lo          ! provide |U|L^3/12 lower limit instead 
+            !                                                                       ! of |U|L^3/16 in blp case
+            DO jk = 1, jpkm1
+               !
+               DO jj = 2, jpj
+                  DO ji = 2, jpi
+                     zdb = ( (  ub(ji,jj,jk) * r1_e2u(ji,jj) -  ub(ji-1,jj,jk) * r1_e2u(ji-1,jj) )  &
+                          &                  * r1_e1t(ji,jj) * e2t(ji,jj)                           &
+                          & - ( vb(ji,jj,jk) * r1_e1v(ji,jj) -  vb(ji,jj-1,jk) * r1_e1v(ji,jj-1) )  &
+                          &                  * r1_e2t(ji,jj) * e1t(ji,jj)    ) * tmask(ji,jj,jk)
+                     dtensq(ji,jj) = zdb * zdb
+                  END DO
+               END DO
+               !
+               DO jj = 1, jpjm1
+                  DO ji = 1, jpim1
+                     zdb = ( (  ub(ji,jj+1,jk) * r1_e1u(ji,jj+1) -  ub(ji,jj,jk) * r1_e1u(ji,jj) )  &
+                          &                    * r1_e2f(ji,jj)   * e1f(ji,jj)                       &
+                          & + ( vb(ji+1,jj,jk) * r1_e2v(ji+1,jj) -  vb(ji,jj,jk) * r1_e2v(ji,jj) )  &
+                          &                    * r1_e1f(ji,jj)   * e2f(ji,jj)  ) * fmask(ji,jj,jk)
+                     dshesq(ji,jj) = zdb * zdb
+                  END DO
+               END DO
+               !
+               DO jj = 2, jpjm1
+                  DO ji = fs_2, fs_jpim1
+                     !
+                     zu2pv2_ij_p1 = ub(ji  ,jj+1,jk) * ub(ji  ,jj+1,jk) + vb(ji+1,jj  ,jk) * vb(ji+1,jj  ,jk)
+                     zu2pv2_ij    = ub(ji  ,jj  ,jk) * ub(ji  ,jj  ,jk) + vb(ji  ,jj  ,jk) * vb(ji  ,jj  ,jk)
+                     zu2pv2_ij_m1 = ub(ji-1,jj  ,jk) * ub(ji-1,jj  ,jk) + vb(ji  ,jj-1,jk) * vb(ji  ,jj-1,jk)
+                                                     ! T-point value
+                     zdelta         = zcmsmag * esqt(ji,jj)                                        ! L^2 * (C_smag/pi)^2
+                     ahmt(ji,jj,jk) = zdelta * sqrt(          dtensq(ji,jj)   +                        &
+                                     &               r1_4 * ( dshesq(ji,jj)   + dshesq(ji,jj-1)   +    &
+                                     &                        dshesq(ji-1,jj) + dshesq(ji-1,jj-1) ) )
+                     ahmt(ji,jj,jk) =   MAX( ahmt(ji,jj,jk),   &
+                                     &   SQRT( (zu2pv2_ij + zu2pv2_ij_m1) * zdelta * zstabf_lo ) ) ! Impose lower limit == minfac  * |U|L/2
+                     ahmt(ji,jj,jk) = MIN( ahmt(ji,jj,jk), zdelta * zstabf_up )                    ! Impose upper limit == maxfac  * L^2/(4*2dt)
+                                                     ! F-point value
+                     zdelta         = zcmsmag * esqf(ji,jj)                                        ! L^2 * (C_smag/pi)^2
+                     ahmf(ji,jj,jk) = zdelta * sqrt(          dshesq(ji,jj)   +                        &
+                                     &               r1_4 * ( dtensq(ji,jj)   + dtensq(ji,jj+1)   +    &
+                                     &                        dtensq(ji+1,jj) + dtensq(ji+1,jj+1) ) )
+                     ahmf(ji,jj,jk) =   MAX( ahmf(ji,jj,jk),   &
+                                     &   SQRT( (zu2pv2_ij + zu2pv2_ij_p1) * zdelta * zstabf_lo ) ) ! Impose lower limit == minfac  * |U|L/2
+                     ahmf(ji,jj,jk) = MIN( ahmf(ji,jj,jk), zdelta * zstabf_up )                    ! Impose upper limit == maxfac  * L^2/(4*2dt)
+                     !
+                  END DO
+               END DO
+            END DO
+            !
+         ENDIF
+         !
+         IF( ln_dynldf_blp ) THEN      ! bilaplacian operator : sqrt( (C_smag/pi)^2 L^4 |D|/8)
+            !                          !                      = sqrt( A_lap_smag L^2/8 )
+            !                          ! stability limits already applied to laplacian values
+            !                          ! effective default limits are 1/12 |U|L^3 < B_hm < 1//(32*2dt) L^4
+            DO jk = 1, jpkm1
+               DO jj = 2, jpjm1
+                  DO ji = fs_2, fs_jpim1
+                     ahmt(ji,jj,jk) = SQRT( r1_8 * esqt(ji,jj) * ahmt(ji,jj,jk) )
+                     ahmf(ji,jj,jk) = SQRT( r1_8 * esqf(ji,jj) * ahmf(ji,jj,jk) )
+                  END DO
+               END DO
+            END DO
+            !
+         ENDIF
+         !
+         CALL lbc_lnk_multi( ahmt, 'T', 1. , ahmf, 'F', 1. )
+         !
+      END SELECT
+      !
+      CALL iom_put( "ahmt_2d", ahmt(:,:,1) )   ! surface u-eddy diffusivity coeff.
+      CALL iom_put( "ahmf_2d", ahmf(:,:,1) )   ! surface v-eddy diffusivity coeff.
+      CALL iom_put( "ahmt_3d", ahmt(:,:,:) )   ! 3D      u-eddy diffusivity coeff.
+      CALL iom_put( "ahmf_3d", ahmf(:,:,:) )   ! 3D      v-eddy diffusivity coeff.
+      !
+      IF( ln_timing )   CALL timing_stop('ldf_dyn')
+      !
+   END SUBROUTINE ldf_dyn
+
+   !!======================================================================
+END MODULE ldfdyn
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/LDF/ldfslp.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/LDF/ldfslp.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/LDF/ldfslp.F90	(revision 9570)
@@ -0,0 +1,800 @@
+MODULE ldfslp
+   !!======================================================================
+   !!                       ***  MODULE  ldfslp  ***
+   !! Ocean physics: slopes of neutral surfaces
+   !!======================================================================
+   !! History :  OPA  ! 1994-12  (G. Madec, M. Imbard)  Original code
+   !!            8.0  ! 1997-06  (G. Madec)  optimization, lbc
+   !!            8.1  ! 1999-10  (A. Jouzeau)  NEW profile in the mixed layer
+   !!   NEMO     1.0  ! 2002-10  (G. Madec)  Free form, F90
+   !!             -   ! 2005-10  (A. Beckmann)  correction for s-coordinates
+   !!            3.3  ! 2010-10  (G. Nurser, C. Harris, G. Madec)  add Griffies operator
+   !!             -   ! 2010-11  (F. Dupond, G. Madec)  bug correction in slopes just below the ML
+   !!            3.7  ! 2013-12  (F. Lemarie, G. Madec)  add limiter on triad slopes
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   ldf_slp       : calculates the slopes of neutral surface   (Madec operator)
+   !!   ldf_slp_triad : calculates the triads of isoneutral slopes (Griffies operator)
+   !!   ldf_slp_mxl   : calculates the slopes at the base of the mixed layer (Madec operator)
+   !!   ldf_slp_init  : initialization of the slopes computation
+   !!----------------------------------------------------------------------
+   USE oce            ! ocean dynamics and tracers
+   USE dom_oce        ! ocean space and time domain
+!   USE ldfdyn         ! lateral diffusion: eddy viscosity coef.
+   USE phycst         ! physical constants
+   USE zdfmxl         ! mixed layer depth
+   USE eosbn2         ! equation of states
+   !
+   USE in_out_manager ! I/O manager
+   USE prtctl         ! Print control
+   USE lbclnk         ! ocean lateral boundary conditions (or mpp link)
+   USE lib_mpp        ! distribued memory computing library
+   USE lib_fortran    ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined)
+   USE timing         ! Timing
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   ldf_slp         ! routine called by step.F90
+   PUBLIC   ldf_slp_triad   ! routine called by step.F90
+   PUBLIC   ldf_slp_init    ! routine called by nemogcm.F90
+
+   LOGICAL , PUBLIC ::   l_ldfslp = .FALSE.     !: slopes flag
+
+   LOGICAL , PUBLIC ::   ln_traldf_iso   = .TRUE.       !: iso-neutral direction                           (nam_traldf namelist)
+   LOGICAL , PUBLIC ::   ln_traldf_triad = .FALSE.      !: griffies triad scheme                           (nam_traldf namelist)
+   LOGICAL , PUBLIC ::   ln_dynldf_iso                  !: iso-neutral direction                           (nam_dynldf namelist)
+
+   LOGICAL , PUBLIC ::   ln_triad_iso    = .FALSE.      !: pure horizontal mixing in ML                    (nam_traldf namelist)
+   LOGICAL , PUBLIC ::   ln_botmix_triad = .FALSE.      !: mixing on bottom                                (nam_traldf namelist)
+   REAL(wp), PUBLIC ::   rn_sw_triad     = 1._wp        !: =1 switching triads ; =0 all four triads used   (nam_traldf namelist)
+   REAL(wp), PUBLIC ::   rn_slpmax       = 0.01_wp      !: slope limit                                     (nam_traldf namelist)
+
+   LOGICAL , PUBLIC ::   l_grad_zps = .FALSE.           !: special treatment for Horz Tgradients w partial steps (triad operator)
+   
+   !                                                     !! Classic operator (Madec)
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)     ::   uslp, wslpi          !: i_slope at U- and W-points
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)     ::   vslp, wslpj          !: j-slope at V- and W-points
+   !                                                     !! triad operator (Griffies)
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)     ::   wslp2                !: wslp**2 from Griffies quarter cells
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:,:) ::   triadi_g, triadj_g   !: skew flux  slopes relative to geopotentials
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:,:) ::   triadi  , triadj     !: isoneutral slopes relative to model-coordinate
+   !                                                     !! both operators
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)     ::   ah_wslp2             !: ah * slope^2 at w-point
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)     ::   akz                  !: stabilizing vertical diffusivity
+   
+   !                                                     !! Madec operator
+   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   omlmask           ! mask of the surface mixed layer at T-pt
+   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   uslpml, wslpiml   ! i_slope at U- and W-points just below the mixed layer
+   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   vslpml, wslpjml   ! j_slope at V- and W-points just below the mixed layer
+
+   REAL(wp) ::   repsln = 1.e-25_wp       ! tiny value used as minium of di(rho), dj(rho) and dk(rho)
+
+   !! * Substitutions
+#  include "vectopt_loop_substitute.h90"
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 4.0 , NEMO Consortium (2014)
+   !! $Id$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE ldf_slp( kt, prd, pn2 )
+      !!----------------------------------------------------------------------
+      !!                 ***  ROUTINE ldf_slp  ***
+      !!
+      !! ** Purpose :   Compute the slopes of neutral surface (slope of isopycnal
+      !!              surfaces referenced locally) (ln_traldf_iso=T).
+      !!
+      !! ** Method  :   The slope in the i-direction is computed at U- and
+      !!      W-points (uslp, wslpi) and the slope in the j-direction is
+      !!      computed at V- and W-points (vslp, wslpj).
+      !!      They are bounded by 1/100 over the whole ocean, and within the
+      !!      surface layer they are bounded by the distance to the surface
+      !!      ( slope<= depth/l  where l is the length scale of horizontal
+      !!      diffusion (here, aht=2000m2/s ==> l=20km with a typical velocity
+      !!      of 10cm/s)
+      !!        A horizontal shapiro filter is applied to the slopes
+      !!        ln_sco=T, s-coordinate, add to the previously computed slopes
+      !!      the slope of the model level surface.
+      !!        macro-tasked on horizontal slab (jk-loop)  (2, jpk-1)
+      !!      [slopes already set to zero at level 1, and to zero or the ocean
+      !!      bottom slope (ln_sco=T) at level jpk in inildf]
+      !!
+      !! ** Action : - uslp, wslpi, and vslp, wslpj, the i- and  j-slopes
+      !!               of now neutral surfaces at u-, w- and v- w-points, resp.
+      !!----------------------------------------------------------------------
+      INTEGER , INTENT(in)                   ::   kt    ! ocean time-step index
+      REAL(wp), INTENT(in), DIMENSION(:,:,:) ::   prd   ! in situ density
+      REAL(wp), INTENT(in), DIMENSION(:,:,:) ::   pn2   ! Brunt-Vaisala frequency (locally ref.)
+      !!
+      INTEGER  ::   ji , jj , jk    ! dummy loop indices
+      INTEGER  ::   ii0, ii1        ! temporary integer
+      INTEGER  ::   ij0, ij1        ! temporary integer
+      REAL(wp) ::   zeps, zm1_g, zm1_2g, z1_16, zcofw, z1_slpmax ! local scalars
+      REAL(wp) ::   zci, zfi, zau, zbu, zai, zbi   !   -      -
+      REAL(wp) ::   zcj, zfj, zav, zbv, zaj, zbj   !   -      -
+      REAL(wp) ::   zck, zfk,      zbw             !   -      -
+      REAL(wp) ::   zdepu, zdepv                   !   -      -
+      REAL(wp), DIMENSION(jpi,jpj)     ::  zslpml_hmlpu, zslpml_hmlpv
+      REAL(wp), DIMENSION(jpi,jpj,jpk) ::  zgru, zwz, zdzr
+      REAL(wp), DIMENSION(jpi,jpj,jpk) ::  zgrv, zww
+      !!----------------------------------------------------------------------
+      !
+      IF( ln_timing )   CALL timing_start('ldf_slp')
+      !
+      zeps   =  1.e-20_wp        !==   Local constant initialization   ==!
+      z1_16  =  1.0_wp / 16._wp
+      zm1_g  = -1.0_wp / grav
+      zm1_2g = -0.5_wp / grav
+      z1_slpmax = 1._wp / rn_slpmax
+      !
+      zww(:,:,:) = 0._wp
+      zwz(:,:,:) = 0._wp
+      !
+      DO jk = 1, jpk             !==   i- & j-gradient of density   ==!
+         DO jj = 1, jpjm1
+            DO ji = 1, fs_jpim1   ! vector opt.
+               zgru(ji,jj,jk) = umask(ji,jj,jk) * ( prd(ji+1,jj  ,jk) - prd(ji,jj,jk) )
+               zgrv(ji,jj,jk) = vmask(ji,jj,jk) * ( prd(ji  ,jj+1,jk) - prd(ji,jj,jk) )
+            END DO
+         END DO
+      END DO
+      IF( ln_zps ) THEN                           ! partial steps correction at the bottom ocean level
+         DO jj = 1, jpjm1
+            DO ji = 1, jpim1
+               zgru(ji,jj,mbku(ji,jj)) = gru(ji,jj)
+               zgrv(ji,jj,mbkv(ji,jj)) = grv(ji,jj)
+            END DO
+         END DO
+      ENDIF
+      IF( ln_zps .AND. ln_isfcav ) THEN           ! partial steps correction at the bottom ocean level
+         DO jj = 1, jpjm1
+            DO ji = 1, jpim1
+               IF( miku(ji,jj) > 1 )   zgru(ji,jj,miku(ji,jj)) = grui(ji,jj) 
+               IF( mikv(ji,jj) > 1 )   zgrv(ji,jj,mikv(ji,jj)) = grvi(ji,jj)
+            END DO
+         END DO
+      ENDIF
+      !
+      zdzr(:,:,1) = 0._wp        !==   Local vertical density gradient at T-point   == !   (evaluated from N^2)
+      DO jk = 2, jpkm1
+         !                                ! zdzr = d/dz(prd)= - ( prd ) / grav * mk(pn2) -- at t point
+         !                                !   trick: tmask(ik  )  = 0   =>   all pn2   = 0   =>   zdzr = 0
+         !                                !    else  tmask(ik+1)  = 0   =>   pn2(ik+1) = 0   =>   zdzr divides by 1
+         !                                !          umask(ik+1) /= 0   =>   all pn2  /= 0   =>   zdzr divides by 2
+         !                                ! NB: 1/(tmask+1) = (1-.5*tmask)  substitute a / by a *  ==> faster
+         zdzr(:,:,jk) = zm1_g * ( prd(:,:,jk) + 1._wp )              &
+            &                 * ( pn2(:,:,jk) + pn2(:,:,jk+1) ) * ( 1._wp - 0.5_wp * tmask(:,:,jk+1) )
+      END DO
+      !
+      !                          !==   Slopes just below the mixed layer   ==!
+      CALL ldf_slp_mxl( prd, pn2, zgru, zgrv, zdzr )        ! output: uslpml, vslpml, wslpiml, wslpjml
+
+
+      ! I.  slopes at u and v point      | uslp = d/di( prd ) / d/dz( prd )
+      ! ===========================      | vslp = d/dj( prd ) / d/dz( prd )
+      !
+      IF ( ln_isfcav ) THEN
+         DO jj = 2, jpjm1
+            DO ji = fs_2, fs_jpim1   ! vector opt.
+               zslpml_hmlpu(ji,jj) = uslpml(ji,jj) / ( MAX(hmlpt  (ji,jj), hmlpt  (ji+1,jj  ), 5._wp) &
+                  &                                  - MAX(risfdep(ji,jj), risfdep(ji+1,jj  )       ) ) 
+               zslpml_hmlpv(ji,jj) = vslpml(ji,jj) / ( MAX(hmlpt  (ji,jj), hmlpt  (ji  ,jj+1), 5._wp) &
+                  &                                  - MAX(risfdep(ji,jj), risfdep(ji  ,jj+1)       ) )
+            END DO
+         END DO
+      ELSE
+         DO jj = 2, jpjm1
+            DO ji = fs_2, fs_jpim1   ! vector opt.
+               zslpml_hmlpu(ji,jj) = uslpml(ji,jj) / MAX(hmlpt(ji,jj), hmlpt(ji+1,jj  ), 5._wp)
+               zslpml_hmlpv(ji,jj) = vslpml(ji,jj) / MAX(hmlpt(ji,jj), hmlpt(ji  ,jj+1), 5._wp)
+            END DO
+         END DO
+      END IF
+
+      DO jk = 2, jpkm1                            !* Slopes at u and v points
+         DO jj = 2, jpjm1
+            DO ji = fs_2, fs_jpim1   ! vector opt.
+               !                                      ! horizontal and vertical density gradient at u- and v-points
+               zau = zgru(ji,jj,jk) * r1_e1u(ji,jj)
+               zav = zgrv(ji,jj,jk) * r1_e2v(ji,jj)
+               zbu = 0.5_wp * ( zdzr(ji,jj,jk) + zdzr(ji+1,jj  ,jk) )
+               zbv = 0.5_wp * ( zdzr(ji,jj,jk) + zdzr(ji  ,jj+1,jk) )
+               !                                      ! bound the slopes: abs(zw.)<= 1/100 and zb..<0
+               !                                      ! + kxz max= ah slope max =< e1 e3 /(pi**2 2 dt)
+               zbu = MIN(  zbu, - z1_slpmax * ABS( zau ) , -7.e+3_wp/e3u_n(ji,jj,jk)* ABS( zau )  )
+               zbv = MIN(  zbv, - z1_slpmax * ABS( zav ) , -7.e+3_wp/e3v_n(ji,jj,jk)* ABS( zav )  )
+               !                                      ! uslp and vslp output in zwz and zww, resp.
+               zfi = MAX( omlmask(ji,jj,jk), omlmask(ji+1,jj,jk) )
+               zfj = MAX( omlmask(ji,jj,jk), omlmask(ji,jj+1,jk) )
+               ! thickness of water column between surface and level k at u/v point
+               zdepu = 0.5_wp * ( ( gdept_n (ji,jj,jk) + gdept_n (ji+1,jj,jk) )                            &
+                                - 2 * MAX( risfdep(ji,jj), risfdep(ji+1,jj) ) - e3u_n(ji,jj,miku(ji,jj))   )
+               zdepv = 0.5_wp * ( ( gdept_n (ji,jj,jk) + gdept_n (ji,jj+1,jk) )                            &
+                                - 2 * MAX( risfdep(ji,jj), risfdep(ji,jj+1) ) - e3v_n(ji,jj,mikv(ji,jj))   )
+               !
+               zwz(ji,jj,jk) = ( ( 1._wp - zfi) * zau / ( zbu - zeps )                                     &
+                  &                      + zfi  * zdepu * zslpml_hmlpu(ji,jj) ) * umask(ji,jj,jk)
+               zww(ji,jj,jk) = ( ( 1._wp - zfj) * zav / ( zbv - zeps )                                     &
+                  &                      + zfj  * zdepv * zslpml_hmlpv(ji,jj) ) * vmask(ji,jj,jk)
+!!gm  modif to suppress omlmask.... (as in Griffies case)
+!               !                                         ! jk must be >= ML level for zf=1. otherwise  zf=0.
+!               zfi = REAL( 1 - 1/(1 + jk / MAX( nmln(ji+1,jj), nmln(ji,jj) ) ), wp )
+!               zfj = REAL( 1 - 1/(1 + jk / MAX( nmln(ji,jj+1), nmln(ji,jj) ) ), wp )
+!               zci = 0.5 * ( gdept_n(ji+1,jj,jk)+gdept_n(ji,jj,jk) ) / MAX( hmlpt(ji,jj), hmlpt(ji+1,jj), 10. ) )
+!               zcj = 0.5 * ( gdept_n(ji,jj+1,jk)+gdept_n(ji,jj,jk) ) / MAX( hmlpt(ji,jj), hmlpt(ji,jj+1), 10. ) )
+!               zwz(ji,jj,jk) = ( zfi * zai / ( zbi - zeps ) + ( 1._wp - zfi ) * wslpiml(ji,jj) * zci ) * tmask(ji,jj,jk)
+!               zww(ji,jj,jk) = ( zfj * zaj / ( zbj - zeps ) + ( 1._wp - zfj ) * wslpjml(ji,jj) * zcj ) * tmask(ji,jj,jk)
+!!gm end modif
+            END DO
+         END DO
+      END DO
+      CALL lbc_lnk_multi( zwz, 'U', -1.,  zww, 'V', -1. )      ! lateral boundary conditions
+      !
+      !                                            !* horizontal Shapiro filter
+      DO jk = 2, jpkm1
+         DO jj = 2, jpjm1, MAX(1, jpj-3)                        ! rows jj=2 and =jpjm1 only
+            DO ji = 2, jpim1
+               uslp(ji,jj,jk) = z1_16 * (        zwz(ji-1,jj-1,jk) + zwz(ji+1,jj-1,jk)      &
+                  &                       +      zwz(ji-1,jj+1,jk) + zwz(ji+1,jj+1,jk)      &
+                  &                       + 2.*( zwz(ji  ,jj-1,jk) + zwz(ji-1,jj  ,jk)      &
+                  &                       +      zwz(ji+1,jj  ,jk) + zwz(ji  ,jj+1,jk) )    &
+                  &                       + 4.*  zwz(ji  ,jj  ,jk)                       )
+               vslp(ji,jj,jk) = z1_16 * (        zww(ji-1,jj-1,jk) + zww(ji+1,jj-1,jk)      &
+                  &                       +      zww(ji-1,jj+1,jk) + zww(ji+1,jj+1,jk)      &
+                  &                       + 2.*( zww(ji  ,jj-1,jk) + zww(ji-1,jj  ,jk)      &
+                  &                       +      zww(ji+1,jj  ,jk) + zww(ji  ,jj+1,jk) )    &
+                  &                       + 4.*  zww(ji,jj    ,jk)                       )
+            END DO
+         END DO
+         DO jj = 3, jpj-2                               ! other rows
+            DO ji = fs_2, fs_jpim1   ! vector opt.
+               uslp(ji,jj,jk) = z1_16 * (        zwz(ji-1,jj-1,jk) + zwz(ji+1,jj-1,jk)      &
+                  &                       +      zwz(ji-1,jj+1,jk) + zwz(ji+1,jj+1,jk)      &
+                  &                       + 2.*( zwz(ji  ,jj-1,jk) + zwz(ji-1,jj  ,jk)      &
+                  &                       +      zwz(ji+1,jj  ,jk) + zwz(ji  ,jj+1,jk) )    &
+                  &                       + 4.*  zwz(ji  ,jj  ,jk)                       )
+               vslp(ji,jj,jk) = z1_16 * (        zww(ji-1,jj-1,jk) + zww(ji+1,jj-1,jk)      &
+                  &                       +      zww(ji-1,jj+1,jk) + zww(ji+1,jj+1,jk)      &
+                  &                       + 2.*( zww(ji  ,jj-1,jk) + zww(ji-1,jj  ,jk)      &
+                  &                       +      zww(ji+1,jj  ,jk) + zww(ji  ,jj+1,jk) )    &
+                  &                       + 4.*  zww(ji,jj    ,jk)                       )
+            END DO
+         END DO
+         !                                        !* decrease along coastal boundaries
+         DO jj = 2, jpjm1
+            DO ji = fs_2, fs_jpim1   ! vector opt.
+               uslp(ji,jj,jk) = uslp(ji,jj,jk) * ( umask(ji,jj+1,jk) + umask(ji,jj-1,jk  ) ) * 0.5_wp   &
+                  &                            * ( umask(ji,jj  ,jk) + umask(ji,jj  ,jk+1) ) * 0.5_wp
+               vslp(ji,jj,jk) = vslp(ji,jj,jk) * ( vmask(ji+1,jj,jk) + vmask(ji-1,jj,jk  ) ) * 0.5_wp   &
+                  &                            * ( vmask(ji  ,jj,jk) + vmask(ji  ,jj,jk+1) ) * 0.5_wp
+            END DO
+         END DO
+      END DO
+
+
+      ! II.  slopes at w point           | wslpi = mij( d/di( prd ) / d/dz( prd )
+      ! ===========================      | wslpj = mij( d/dj( prd ) / d/dz( prd )
+      !
+      DO jk = 2, jpkm1
+         DO jj = 2, jpjm1
+            DO ji = fs_2, fs_jpim1   ! vector opt.
+               !                                  !* Local vertical density gradient evaluated from N^2
+               zbw = zm1_2g * pn2 (ji,jj,jk) * ( prd (ji,jj,jk) + prd (ji,jj,jk-1) + 2. )
+               !                                  !* Slopes at w point
+               !                                        ! i- & j-gradient of density at w-points
+               zci = MAX(  umask(ji-1,jj,jk  ) + umask(ji,jj,jk  )           &
+                  &      + umask(ji-1,jj,jk-1) + umask(ji,jj,jk-1) , zeps  ) * e1t(ji,jj)
+               zcj = MAX(  vmask(ji,jj-1,jk  ) + vmask(ji,jj,jk-1)           &
+                  &      + vmask(ji,jj-1,jk-1) + vmask(ji,jj,jk  ) , zeps  ) * e2t(ji,jj)
+               zai =    (  zgru (ji-1,jj,jk  ) + zgru (ji,jj,jk-1)           &
+                  &      + zgru (ji-1,jj,jk-1) + zgru (ji,jj,jk  )   ) / zci * wmask (ji,jj,jk)
+               zaj =    (  zgrv (ji,jj-1,jk  ) + zgrv (ji,jj,jk-1)           &
+                  &      + zgrv (ji,jj-1,jk-1) + zgrv (ji,jj,jk  )   ) / zcj * wmask (ji,jj,jk)
+               !                                        ! bound the slopes: abs(zw.)<= 1/100 and zb..<0.
+               !                                        ! + kxz max= ah slope max =< e1 e3 /(pi**2 2 dt)
+               zbi = MIN( zbw ,- 100._wp* ABS( zai ) , -7.e+3_wp/e3w_n(ji,jj,jk)* ABS( zai )  )
+               zbj = MIN( zbw , -100._wp* ABS( zaj ) , -7.e+3_wp/e3w_n(ji,jj,jk)* ABS( zaj )  )
+               !                                        ! wslpi and wslpj with ML flattening (output in zwz and zww, resp.)
+               zfk = MAX( omlmask(ji,jj,jk), omlmask(ji,jj,jk-1) )   ! zfk=1 in the ML otherwise zfk=0
+               zck = ( gdepw_n(ji,jj,jk) - gdepw_n(ji,jj,mikt(ji,jj) ) ) / MAX( hmlp(ji,jj) - gdepw_n(ji,jj,mikt(ji,jj)), 10._wp )
+               zwz(ji,jj,jk) = (  zai / ( zbi - zeps ) * ( 1._wp - zfk ) + zck * wslpiml(ji,jj) * zfk  ) * wmask(ji,jj,jk)
+               zww(ji,jj,jk) = (  zaj / ( zbj - zeps ) * ( 1._wp - zfk ) + zck * wslpjml(ji,jj) * zfk  ) * wmask(ji,jj,jk)
+
+!!gm  modif to suppress omlmask....  (as in Griffies operator)
+!               !                                         ! jk must be >= ML level for zfk=1. otherwise  zfk=0.
+!               zfk = REAL( 1 - 1/(1 + jk / nmln(ji+1,jj)), wp )
+!               zck = gdepw(ji,jj,jk)    / MAX( hmlp(ji,jj), 10. )
+!               zwz(ji,jj,jk) = ( zfk * zai / ( zbi - zeps ) + ( 1._wp - zfk ) * wslpiml(ji,jj) * zck ) * tmask(ji,jj,jk)
+!               zww(ji,jj,jk) = ( zfk * zaj / ( zbj - zeps ) + ( 1._wp - zfk ) * wslpjml(ji,jj) * zck ) * tmask(ji,jj,jk)
+!!gm end modif
+            END DO
+         END DO
+      END DO
+      CALL lbc_lnk_multi( zwz, 'T', -1.,  zww, 'T', -1. )      ! lateral boundary conditions
+      !
+      !                                           !* horizontal Shapiro filter
+      DO jk = 2, jpkm1
+         DO jj = 2, jpjm1, MAX(1, jpj-3)                        ! rows jj=2 and =jpjm1 only
+            DO ji = 2, jpim1
+               zcofw = wmask(ji,jj,jk) * z1_16
+               wslpi(ji,jj,jk) = (         zwz(ji-1,jj-1,jk) + zwz(ji+1,jj-1,jk)     &
+                    &               +      zwz(ji-1,jj+1,jk) + zwz(ji+1,jj+1,jk)     &
+                    &               + 2.*( zwz(ji  ,jj-1,jk) + zwz(ji-1,jj  ,jk)     &
+                    &               +      zwz(ji+1,jj  ,jk) + zwz(ji  ,jj+1,jk) )   &
+                    &               + 4.*  zwz(ji  ,jj  ,jk)                         ) * zcofw
+
+               wslpj(ji,jj,jk) = (         zww(ji-1,jj-1,jk) + zww(ji+1,jj-1,jk)     &
+                    &               +      zww(ji-1,jj+1,jk) + zww(ji+1,jj+1,jk)     &
+                    &               + 2.*( zww(ji  ,jj-1,jk) + zww(ji-1,jj  ,jk)     &
+                    &               +      zww(ji+1,jj  ,jk) + zww(ji  ,jj+1,jk) )   &
+                    &               + 4.*  zww(ji  ,jj  ,jk)                         ) * zcofw
+            END DO
+         END DO
+         DO jj = 3, jpj-2                               ! other rows
+            DO ji = fs_2, fs_jpim1   ! vector opt.
+               zcofw = wmask(ji,jj,jk) * z1_16
+               wslpi(ji,jj,jk) = (         zwz(ji-1,jj-1,jk) + zwz(ji+1,jj-1,jk)     &
+                    &               +      zwz(ji-1,jj+1,jk) + zwz(ji+1,jj+1,jk)     &
+                    &               + 2.*( zwz(ji  ,jj-1,jk) + zwz(ji-1,jj  ,jk)     &
+                    &               +      zwz(ji+1,jj  ,jk) + zwz(ji  ,jj+1,jk) )   &
+                    &               + 4.*  zwz(ji  ,jj  ,jk)                         ) * zcofw
+
+               wslpj(ji,jj,jk) = (         zww(ji-1,jj-1,jk) + zww(ji+1,jj-1,jk)     &
+                    &               +      zww(ji-1,jj+1,jk) + zww(ji+1,jj+1,jk)     &
+                    &               + 2.*( zww(ji  ,jj-1,jk) + zww(ji-1,jj  ,jk)     &
+                    &               +      zww(ji+1,jj  ,jk) + zww(ji  ,jj+1,jk) )   &
+                    &               + 4.*  zww(ji  ,jj  ,jk)                         ) * zcofw
+            END DO
+         END DO
+         !                                        !* decrease in vicinity of topography
+         DO jj = 2, jpjm1
+            DO ji = fs_2, fs_jpim1   ! vector opt.
+               zck =   ( umask(ji,jj,jk) + umask(ji-1,jj,jk) )   &
+                  &  * ( vmask(ji,jj,jk) + vmask(ji,jj-1,jk) ) * 0.25
+               wslpi(ji,jj,jk) = wslpi(ji,jj,jk) * zck
+               wslpj(ji,jj,jk) = wslpj(ji,jj,jk) * zck
+            END DO
+         END DO
+      END DO
+
+      ! IV. Lateral boundary conditions
+      ! ===============================
+      CALL lbc_lnk_multi( uslp , 'U', -1. , vslp , 'V', -1. , wslpi, 'W', -1., wslpj, 'W', -1. )
+
+      IF(ln_ctl) THEN
+         CALL prt_ctl(tab3d_1=uslp , clinfo1=' slp  - u : ', tab3d_2=vslp,  clinfo2=' v : ', kdim=jpk)
+         CALL prt_ctl(tab3d_1=wslpi, clinfo1=' slp  - wi: ', tab3d_2=wslpj, clinfo2=' wj: ', kdim=jpk)
+      ENDIF
+      !
+      IF( ln_timing )   CALL timing_stop('ldf_slp')
+      !
+   END SUBROUTINE ldf_slp
+
+
+   SUBROUTINE ldf_slp_triad ( kt )
+      !!----------------------------------------------------------------------
+      !!                 ***  ROUTINE ldf_slp_triad  ***
+      !!
+      !! ** Purpose :   Compute the squared slopes of neutral surfaces (slope
+      !!      of iso-pycnal surfaces referenced locally) (ln_traldf_triad=T)
+      !!      at W-points using the Griffies quarter-cells.
+      !!
+      !! ** Method  :   calculates alpha and beta at T-points
+      !!
+      !! ** Action : - triadi_g, triadj_g   T-pts i- and j-slope triads relative to geopot. (used for eiv)
+      !!             - triadi , triadj    T-pts i- and j-slope triads relative to model-coordinate
+      !!             - wslp2              squared slope of neutral surfaces at w-points.
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT( in ) ::   kt             ! ocean time-step index
+      !!
+      INTEGER  ::   ji, jj, jk, jl, ip, jp, kp  ! dummy loop indices
+      INTEGER  ::   iku, ikv                    ! local integer
+      REAL(wp) ::   zfacti, zfactj              ! local scalars
+      REAL(wp) ::   znot_thru_surface           ! local scalars
+      REAL(wp) ::   zdit, zdis, zdkt, zbu, zbti, zisw
+      REAL(wp) ::   zdjt, zdjs, zdks, zbv, zbtj, zjsw
+      REAL(wp) ::   zdxrho_raw, zti_coord, zti_raw, zti_lim, zti_g_raw, zti_g_lim
+      REAL(wp) ::   zdyrho_raw, ztj_coord, ztj_raw, ztj_lim, ztj_g_raw, ztj_g_lim
+      REAL(wp) ::   zdzrho_raw
+      REAL(wp) ::   zbeta0, ze3_e1, ze3_e2
+      REAL(wp), DIMENSION(jpi,jpj)     ::   z1_mlbw
+      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zalbet
+      REAL(wp), DIMENSION(jpi,jpj,jpk,0:1) ::   zdxrho , zdyrho, zdzrho     ! Horizontal and vertical density gradients
+      REAL(wp), DIMENSION(jpi,jpj,0:1,0:1) ::   zti_mlb, ztj_mlb            ! for Griffies operator only
+      !!----------------------------------------------------------------------
+      !
+      IF( ln_timing )   CALL timing_start('ldf_slp_triad')
+      !
+      !--------------------------------!
+      !  Some preliminary calculation  !
+      !--------------------------------!
+      !
+      DO jl = 0, 1                            !==  unmasked before density i- j-, k-gradients  ==!
+         !
+         ip = jl   ;   jp = jl                ! guaranteed nonzero gradients ( absolute value larger than repsln)
+         DO jk = 1, jpkm1                     ! done each pair of triad
+            DO jj = 1, jpjm1                  ! NB: not masked ==>  a minimum value is set
+               DO ji = 1, fs_jpim1            ! vector opt.
+                  zdit = ( tsb(ji+1,jj,jk,jp_tem) - tsb(ji,jj,jk,jp_tem) )    ! i-gradient of T & S at u-point
+                  zdis = ( tsb(ji+1,jj,jk,jp_sal) - tsb(ji,jj,jk,jp_sal) )
+                  zdjt = ( tsb(ji,jj+1,jk,jp_tem) - tsb(ji,jj,jk,jp_tem) )    ! j-gradient of T & S at v-point
+                  zdjs = ( tsb(ji,jj+1,jk,jp_sal) - tsb(ji,jj,jk,jp_sal) )
+                  zdxrho_raw = ( - rab_b(ji+ip,jj   ,jk,jp_tem) * zdit + rab_b(ji+ip,jj   ,jk,jp_sal) * zdis ) * r1_e1u(ji,jj)
+                  zdyrho_raw = ( - rab_b(ji   ,jj+jp,jk,jp_tem) * zdjt + rab_b(ji   ,jj+jp,jk,jp_sal) * zdjs ) * r1_e2v(ji,jj)
+                  zdxrho(ji+ip,jj   ,jk,1-ip) = SIGN(  MAX( repsln, ABS( zdxrho_raw ) ), zdxrho_raw  )   ! keep the sign
+                  zdyrho(ji   ,jj+jp,jk,1-jp) = SIGN(  MAX( repsln, ABS( zdyrho_raw ) ), zdyrho_raw  )
+               END DO
+            END DO
+         END DO
+         !
+         IF( ln_zps .AND. l_grad_zps ) THEN     ! partial steps: correction of i- & j-grad on bottom
+            DO jj = 1, jpjm1
+               DO ji = 1, jpim1
+                  iku  = mbku(ji,jj)          ;   ikv  = mbkv(ji,jj)             ! last ocean level (u- & v-points)
+                  zdit = gtsu(ji,jj,jp_tem)   ;   zdjt = gtsv(ji,jj,jp_tem)      ! i- & j-gradient of Temperature
+                  zdis = gtsu(ji,jj,jp_sal)   ;   zdjs = gtsv(ji,jj,jp_sal)      ! i- & j-gradient of Salinity
+                  zdxrho_raw = ( - rab_b(ji+ip,jj   ,iku,jp_tem) * zdit + rab_b(ji+ip,jj   ,iku,jp_sal) * zdis ) * r1_e1u(ji,jj)
+                  zdyrho_raw = ( - rab_b(ji   ,jj+jp,ikv,jp_tem) * zdjt + rab_b(ji   ,jj+jp,ikv,jp_sal) * zdjs ) * r1_e2v(ji,jj)
+                  zdxrho(ji+ip,jj   ,iku,1-ip) = SIGN( MAX( repsln, ABS( zdxrho_raw ) ), zdxrho_raw )   ! keep the sign
+                  zdyrho(ji   ,jj+jp,ikv,1-jp) = SIGN( MAX( repsln, ABS( zdyrho_raw ) ), zdyrho_raw )
+               END DO
+            END DO
+         ENDIF
+         !
+      END DO
+
+      DO kp = 0, 1                            !==  unmasked before density i- j-, k-gradients  ==!
+         DO jk = 1, jpkm1                     ! done each pair of triad
+            DO jj = 1, jpj                    ! NB: not masked ==>  a minimum value is set
+               DO ji = 1, jpi                 ! vector opt.
+                  IF( jk+kp > 1 ) THEN        ! k-gradient of T & S a jk+kp
+                     zdkt = ( tsb(ji,jj,jk+kp-1,jp_tem) - tsb(ji,jj,jk+kp,jp_tem) )
+                     zdks = ( tsb(ji,jj,jk+kp-1,jp_sal) - tsb(ji,jj,jk+kp,jp_sal) )
+                  ELSE
+                     zdkt = 0._wp                                             ! 1st level gradient set to zero
+                     zdks = 0._wp
+                  ENDIF
+                  zdzrho_raw = ( - zalbet(ji,jj,jk) * zdkt + zbeta0*zdks ) / e3w_n(ji,jj,jk+kp)
+                  zdzrho(ji,jj,jk,kp) = - MIN( - repsln , zdzrho_raw )    ! force zdzrho >= repsln
+                 END DO
+            END DO
+         END DO
+      END DO
+      !
+      DO jj = 1, jpj                          !==  Reciprocal depth of the w-point below ML base  ==!
+         DO ji = 1, jpi
+            jk = MIN( nmln(ji,jj), mbkt(ji,jj) ) + 1     ! MIN in case ML depth is the ocean depth
+            z1_mlbw(ji,jj) = 1._wp / gdepw_n(ji,jj,jk)
+         END DO
+      END DO
+      !
+      !                                       !==  intialisations to zero  ==!
+      !
+      wslp2  (:,:,:)     = 0._wp              ! wslp2 will be cumulated 3D field set to zero
+      triadi_g(:,:,1,:,:) = 0._wp   ;   triadi_g(:,:,jpk,:,:) = 0._wp   ! set surface and bottom slope to zero
+      triadj_g(:,:,1,:,:) = 0._wp   ;   triadj_g(:,:,jpk,:,:) = 0._wp
+      !!gm _iso set to zero missing
+      triadi  (:,:,1,:,:) = 0._wp   ;   triadj  (:,:,jpk,:,:) = 0._wp   ! set surface and bottom slope to zero
+      triadj  (:,:,1,:,:) = 0._wp   ;   triadj  (:,:,jpk,:,:) = 0._wp
+
+      !-------------------------------------!
+      !  Triads just below the Mixed Layer  !
+      !-------------------------------------!
+      !
+      DO jl = 0, 1                            ! calculate slope of the 4 triads immediately ONE level below mixed-layer base
+         DO kp = 0, 1                         ! with only the slope-max limit   and   MASKED
+            DO jj = 1, jpjm1
+               DO ji = 1, fs_jpim1
+                  ip = jl   ;   jp = jl
+                  !
+                  jk = nmln(ji+ip,jj) + 1
+                  IF( jk > mbkt(ji+ip,jj) ) THEN   ! ML reaches bottom
+                     zti_mlb(ji+ip,jj   ,1-ip,kp) = 0.0_wp
+                  ELSE                             
+                     ! Add s-coordinate slope at t-points (do this by *subtracting* gradient of depth)
+                     zti_g_raw = (  zdxrho(ji+ip,jj,jk-kp,1-ip) / zdzrho(ji+ip,jj,jk-kp,kp)      &
+                        &          - ( gdept_n(ji+1,jj,jk-kp) - gdept_n(ji,jj,jk-kp) ) * r1_e1u(ji,jj)  ) * umask(ji,jj,jk)
+                     ze3_e1    =  e3w_n(ji+ip,jj,jk-kp) * r1_e1u(ji,jj) 
+                     zti_mlb(ji+ip,jj   ,1-ip,kp) = SIGN( MIN( rn_slpmax, 5.0_wp * ze3_e1  , ABS( zti_g_raw ) ), zti_g_raw )
+                  ENDIF
+                  !
+                  jk = nmln(ji,jj+jp) + 1
+                  IF( jk >  mbkt(ji,jj+jp) ) THEN  !ML reaches bottom
+                     ztj_mlb(ji   ,jj+jp,1-jp,kp) = 0.0_wp
+                  ELSE
+                     ztj_g_raw = (  zdyrho(ji,jj+jp,jk-kp,1-jp) / zdzrho(ji,jj+jp,jk-kp,kp)      &
+                        &      - ( gdept_n(ji,jj+1,jk-kp) - gdept_n(ji,jj,jk-kp) ) / e2v(ji,jj)  ) * vmask(ji,jj,jk)
+                     ze3_e2    =  e3w_n(ji,jj+jp,jk-kp) / e2v(ji,jj)
+                     ztj_mlb(ji   ,jj+jp,1-jp,kp) = SIGN( MIN( rn_slpmax, 5.0_wp * ze3_e2  , ABS( ztj_g_raw ) ), ztj_g_raw )
+                  ENDIF
+               END DO
+            END DO
+         END DO
+      END DO
+
+      !-------------------------------------!
+      !  Triads with surface limits         !
+      !-------------------------------------!
+      !
+      DO kp = 0, 1                            ! k-index of triads
+         DO jl = 0, 1
+            ip = jl   ;   jp = jl             ! i- and j-indices of triads (i-k and j-k planes)
+            DO jk = 1, jpkm1
+               ! Must mask contribution to slope from dz/dx at constant s for triads jk=1,kp=0 that poke up though ocean surface
+               znot_thru_surface = REAL( 1-1/(jk+kp), wp )  !jk+kp=1,=0.; otherwise=1.0
+               DO jj = 1, jpjm1
+                  DO ji = 1, fs_jpim1         ! vector opt.
+                     !
+                     ! Calculate slope relative to geopotentials used for GM skew fluxes
+                     ! Add s-coordinate slope at t-points (do this by *subtracting* gradient of depth)
+                     ! Limit by slope *relative to geopotentials* by rn_slpmax, and mask by psi-point
+                     ! masked by umask taken at the level of dz(rho)
+                     !
+                     ! raw slopes: unmasked unbounded slopes (relative to geopotential (zti_g) and model surface (zti)
+                     !
+                     zti_raw   = zdxrho(ji+ip,jj   ,jk,1-ip) / zdzrho(ji+ip,jj   ,jk,kp)                   ! unmasked
+                     ztj_raw   = zdyrho(ji   ,jj+jp,jk,1-jp) / zdzrho(ji   ,jj+jp,jk,kp)
+                     !
+                     ! Must mask contribution to slope for triad jk=1,kp=0 that poke up though ocean surface
+                     zti_coord = znot_thru_surface * ( gdept_n(ji+1,jj  ,jk) - gdept_n(ji,jj,jk) ) * r1_e1u(ji,jj)
+                     ztj_coord = znot_thru_surface * ( gdept_n(ji  ,jj+1,jk) - gdept_n(ji,jj,jk) ) * r1_e2v(ji,jj)     ! unmasked
+                     zti_g_raw = zti_raw - zti_coord      ! ref to geopot surfaces
+                     ztj_g_raw = ztj_raw - ztj_coord
+                     ! additional limit required in bilaplacian case
+                     ze3_e1    = e3w_n(ji+ip,jj   ,jk+kp) * r1_e1u(ji,jj)
+                     ze3_e2    = e3w_n(ji   ,jj+jp,jk+kp) * r1_e2v(ji,jj)
+                     ! NB: hard coded factor 5 (can be a namelist parameter...)
+                     zti_g_lim = SIGN( MIN( rn_slpmax, 5.0_wp * ze3_e1, ABS( zti_g_raw ) ), zti_g_raw )
+                     ztj_g_lim = SIGN( MIN( rn_slpmax, 5.0_wp * ze3_e2, ABS( ztj_g_raw ) ), ztj_g_raw )
+                     !
+                     ! Below  ML use limited zti_g as is & mask
+                     ! Inside ML replace by linearly reducing sx_mlb towards surface & mask
+                     !
+                     zfacti = REAL( 1 - 1/(1 + (jk+kp-1)/nmln(ji+ip,jj)), wp )  ! k index of uppermost point(s) of triad is jk+kp-1
+                     zfactj = REAL( 1 - 1/(1 + (jk+kp-1)/nmln(ji,jj+jp)), wp )  ! must be .ge. nmln(ji,jj) for zfact=1
+                     !                                                          !                   otherwise  zfact=0
+                     zti_g_lim =          ( zfacti   * zti_g_lim                       &
+                        &      + ( 1._wp - zfacti ) * zti_mlb(ji+ip,jj,1-ip,kp)   &
+                        &                           * gdepw_n(ji+ip,jj,jk+kp) * z1_mlbw(ji+ip,jj) ) * umask(ji,jj,jk+kp)
+                     ztj_g_lim =          ( zfactj   * ztj_g_lim                       &
+                        &      + ( 1._wp - zfactj ) * ztj_mlb(ji,jj+jp,1-jp,kp)   &
+                        &                           * gdepw_n(ji,jj+jp,jk+kp) * z1_mlbw(ji,jj+jp) ) * vmask(ji,jj,jk+kp)
+                     !
+                     triadi_g(ji+ip,jj   ,jk,1-ip,kp) = zti_g_lim
+                     triadj_g(ji   ,jj+jp,jk,1-jp,kp) = ztj_g_lim
+                     !
+                     ! Get coefficients of isoneutral diffusion tensor
+                     ! 1. Utilise gradients *relative* to s-coordinate, so add t-point slopes (*subtract* depth gradients)
+                     ! 2. We require that isoneutral diffusion  gives no vertical buoyancy flux
+                     !     i.e. 33 term = (real slope* 31, 13 terms)
+                     ! To do this, retain limited sx**2  in vertical flux, but divide by real slope for 13/31 terms
+                     ! Equivalent to tapering A_iso = sx_limited**2/(real slope)**2
+                     !
+                     zti_lim  = ( zti_g_lim + zti_coord ) * umask(ji,jj,jk+kp)    ! remove coordinate slope => relative to coordinate surfaces
+                     ztj_lim  = ( ztj_g_lim + ztj_coord ) * vmask(ji,jj,jk+kp)
+                     !
+                     IF( ln_triad_iso ) THEN
+                        zti_raw = zti_lim*zti_lim / zti_raw
+                        ztj_raw = ztj_lim*ztj_lim / ztj_raw
+                        zti_raw = SIGN( MIN( ABS(zti_lim), ABS( zti_raw ) ), zti_raw )
+                        ztj_raw = SIGN( MIN( ABS(ztj_lim), ABS( ztj_raw ) ), ztj_raw )
+                        zti_lim = zfacti * zti_lim + ( 1._wp - zfacti ) * zti_raw
+                        ztj_lim = zfactj * ztj_lim + ( 1._wp - zfactj ) * ztj_raw
+                     ENDIF
+                     !                                      ! switching triad scheme 
+                     zisw = (rn_sw_triad - 1._wp ) + rn_sw_triad    &
+                        &            * 2._wp * ABS( 0.5_wp - kp - ( 0.5_wp - ip ) * SIGN( 1._wp , zdxrho(ji+ip,jj,jk,1-ip) )  )
+                     zjsw = (rn_sw_triad - 1._wp ) + rn_sw_triad    &
+                        &            * 2._wp * ABS( 0.5_wp - kp - ( 0.5_wp - jp ) * SIGN( 1._wp , zdyrho(ji,jj+jp,jk,1-jp) )  )
+                     !
+                     triadi(ji+ip,jj   ,jk,1-ip,kp) = zti_lim * zisw
+                     triadj(ji   ,jj+jp,jk,1-jp,kp) = ztj_lim * zjsw
+                     !
+                     zbu  = e1e2u(ji   ,jj   ) * e3u_n(ji   ,jj   ,jk   )
+                     zbv  = e1e2v(ji   ,jj   ) * e3v_n(ji   ,jj   ,jk   )
+                     zbti = e1e2t(ji+ip,jj   ) * e3w_n(ji+ip,jj   ,jk+kp)
+                     zbtj = e1e2t(ji   ,jj+jp) * e3w_n(ji   ,jj+jp,jk+kp)
+                     !
+                     wslp2(ji+ip,jj,jk+kp) = wslp2(ji+ip,jj,jk+kp) + 0.25_wp * zbu / zbti * zti_g_lim*zti_g_lim      ! masked
+                     wslp2(ji,jj+jp,jk+kp) = wslp2(ji,jj+jp,jk+kp) + 0.25_wp * zbv / zbtj * ztj_g_lim*ztj_g_lim
+                  END DO
+               END DO
+            END DO
+         END DO
+      END DO
+      !
+      wslp2(:,:,1) = 0._wp                ! force the surface wslp to zero
+
+      CALL lbc_lnk( wslp2, 'W', 1. )      ! lateral boundary confition on wslp2 only   ==>>> gm : necessary ? to be checked
+      !
+      IF( ln_timing )   CALL timing_stop('ldf_slp_triad')
+      !
+   END SUBROUTINE ldf_slp_triad
+
+
+   SUBROUTINE ldf_slp_mxl( prd, pn2, p_gru, p_grv, p_dzr )
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE ldf_slp_mxl  ***
+      !!
+      !! ** Purpose :   Compute the slopes of iso-neutral surface just below
+      !!              the mixed layer.
+      !!
+      !! ** Method  :   The slope in the i-direction is computed at u- & w-points
+      !!              (uslpml, wslpiml) and the slope in the j-direction is computed
+      !!              at v- and w-points (vslpml, wslpjml) with the same bounds as
+      !!              in ldf_slp.
+      !!
+      !! ** Action  :   uslpml, wslpiml :  i- &  j-slopes of neutral surfaces
+      !!                vslpml, wslpjml    just below the mixed layer
+      !!                omlmask         :  mixed layer mask
+      !!----------------------------------------------------------------------
+      REAL(wp), DIMENSION(:,:,:), INTENT(in) ::   prd            ! in situ density
+      REAL(wp), DIMENSION(:,:,:), INTENT(in) ::   pn2            ! Brunt-Vaisala frequency (locally ref.)
+      REAL(wp), DIMENSION(:,:,:), INTENT(in) ::   p_gru, p_grv   ! i- & j-gradient of density (u- & v-pts)
+      REAL(wp), DIMENSION(:,:,:), INTENT(in) ::   p_dzr          ! z-gradient of density      (T-point)
+      !!
+      INTEGER  ::   ji , jj , jk                   ! dummy loop indices
+      INTEGER  ::   iku, ikv, ik, ikm1             ! local integers
+      REAL(wp) ::   zeps, zm1_g, zm1_2g, z1_slpmax ! local scalars
+      REAL(wp) ::   zci, zfi, zau, zbu, zai, zbi   !   -      -
+      REAL(wp) ::   zcj, zfj, zav, zbv, zaj, zbj   !   -      -
+      REAL(wp) ::   zck, zfk,      zbw             !   -      -
+      !!----------------------------------------------------------------------
+      !
+      zeps   =  1.e-20_wp        !==   Local constant initialization   ==!
+      zm1_g  = -1.0_wp / grav
+      zm1_2g = -0.5_wp / grav
+      z1_slpmax = 1._wp / rn_slpmax
+      !
+      uslpml (1,:) = 0._wp      ;      uslpml (jpi,:) = 0._wp
+      vslpml (1,:) = 0._wp      ;      vslpml (jpi,:) = 0._wp
+      wslpiml(1,:) = 0._wp      ;      wslpiml(jpi,:) = 0._wp
+      wslpjml(1,:) = 0._wp      ;      wslpjml(jpi,:) = 0._wp
+      !
+      !                                            !==   surface mixed layer mask   !
+      DO jk = 1, jpk                               ! =1 inside the mixed layer, =0 otherwise
+         DO jj = 1, jpj
+            DO ji = 1, jpi
+               ik = nmln(ji,jj) - 1
+               IF( jk <= ik ) THEN   ;   omlmask(ji,jj,jk) = 1._wp
+               ELSE                  ;   omlmask(ji,jj,jk) = 0._wp
+               ENDIF
+            END DO
+         END DO
+      END DO
+
+
+      ! Slopes of isopycnal surfaces just before bottom of mixed layer
+      ! --------------------------------------------------------------
+      ! The slope are computed as in the 3D case.
+      ! A key point here is the definition of the mixed layer at u- and v-points.
+      ! It is assumed to be the maximum of the two neighbouring T-point mixed layer depth.
+      ! Otherwise, a n2 value inside the mixed layer can be involved in the computation
+      ! of the slope, resulting in a too steep diagnosed slope and thus a spurious eddy
+      ! induce velocity field near the base of the mixed layer.
+      !-----------------------------------------------------------------------
+      !
+      DO jj = 2, jpjm1
+         DO ji = 2, jpim1
+            !                        !==   Slope at u- & v-points just below the Mixed Layer   ==!
+            !
+            !                        !- vertical density gradient for u- and v-slopes (from dzr at T-point)
+            iku = MIN(  MAX( 1, nmln(ji,jj) , nmln(ji+1,jj) ) , jpkm1  )   ! ML (MAX of T-pts, bound by jpkm1)
+            ikv = MIN(  MAX( 1, nmln(ji,jj) , nmln(ji,jj+1) ) , jpkm1  )   !
+            zbu = 0.5_wp * ( p_dzr(ji,jj,iku) + p_dzr(ji+1,jj  ,iku) )
+            zbv = 0.5_wp * ( p_dzr(ji,jj,ikv) + p_dzr(ji  ,jj+1,ikv) )
+            !                        !- horizontal density gradient at u- & v-points
+            zau = p_gru(ji,jj,iku) * r1_e1u(ji,jj)
+            zav = p_grv(ji,jj,ikv) * r1_e2v(ji,jj)
+            !                        !- bound the slopes: abs(zw.)<= 1/100 and zb..<0
+            !                           kxz max= ah slope max =< e1 e3 /(pi**2 2 dt)
+            zbu = MIN(  zbu , - z1_slpmax * ABS( zau ) , -7.e+3_wp/e3u_n(ji,jj,iku)* ABS( zau )  )
+            zbv = MIN(  zbv , - z1_slpmax * ABS( zav ) , -7.e+3_wp/e3v_n(ji,jj,ikv)* ABS( zav )  )
+            !                        !- Slope at u- & v-points (uslpml, vslpml)
+            uslpml(ji,jj) = zau / ( zbu - zeps ) * umask(ji,jj,iku)
+            vslpml(ji,jj) = zav / ( zbv - zeps ) * vmask(ji,jj,ikv)
+            !
+            !                        !==   i- & j-slopes at w-points just below the Mixed Layer   ==!
+            !
+            ik   = MIN( nmln(ji,jj) + 1, jpk )
+            ikm1 = MAX( 1, ik-1 )
+            !                        !- vertical density gradient for w-slope (from N^2)
+            zbw = zm1_2g * pn2 (ji,jj,ik) * ( prd (ji,jj,ik) + prd (ji,jj,ikm1) + 2. )
+            !                        !- horizontal density i- & j-gradient at w-points
+            zci = MAX(   umask(ji-1,jj,ik  ) + umask(ji,jj,ik  )           &
+               &       + umask(ji-1,jj,ikm1) + umask(ji,jj,ikm1) , zeps  ) * e1t(ji,jj)
+            zcj = MAX(   vmask(ji,jj-1,ik  ) + vmask(ji,jj,ik  )           &
+               &       + vmask(ji,jj-1,ikm1) + vmask(ji,jj,ikm1) , zeps  ) * e2t(ji,jj)
+            zai =    (   p_gru(ji-1,jj,ik  ) + p_gru(ji,jj,ik)             &
+               &       + p_gru(ji-1,jj,ikm1) + p_gru(ji,jj,ikm1  )  ) / zci  * tmask(ji,jj,ik)
+            zaj =    (   p_grv(ji,jj-1,ik  ) + p_grv(ji,jj,ik  )           &
+               &       + p_grv(ji,jj-1,ikm1) + p_grv(ji,jj,ikm1)  ) / zcj  * tmask(ji,jj,ik)
+            !                        !- bound the slopes: abs(zw.)<= 1/100 and zb..<0.
+            !                           kxz max= ah slope max =< e1 e3 /(pi**2 2 dt)
+            zbi = MIN(  zbw , -100._wp* ABS( zai ) , -7.e+3_wp/e3w_n(ji,jj,ik)* ABS( zai )  )
+            zbj = MIN(  zbw , -100._wp* ABS( zaj ) , -7.e+3_wp/e3w_n(ji,jj,ik)* ABS( zaj )  )
+            !                        !- i- & j-slope at w-points (wslpiml, wslpjml)
+            wslpiml(ji,jj) = zai / ( zbi - zeps ) * tmask (ji,jj,ik)
+            wslpjml(ji,jj) = zaj / ( zbj - zeps ) * tmask (ji,jj,ik)
+         END DO
+      END DO
+      !!gm this lbc_lnk should be useless....
+      CALL lbc_lnk_multi( uslpml , 'U', -1. , vslpml , 'V', -1. , wslpiml, 'W', -1. , wslpjml, 'W', -1. ) 
+      !
+   END SUBROUTINE ldf_slp_mxl
+
+
+   SUBROUTINE ldf_slp_init
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE ldf_slp_init  ***
+      !!
+      !! ** Purpose :   Initialization for the isopycnal slopes computation
+      !!
+      !! ** Method  :   
+      !!----------------------------------------------------------------------
+      INTEGER ::   ji, jj, jk   ! dummy loop indices
+      INTEGER ::   ierr         ! local integer
+      !!----------------------------------------------------------------------
+      !
+      IF(lwp) THEN
+         WRITE(numout,*)
+         WRITE(numout,*) 'ldf_slp_init : direction of lateral mixing'
+         WRITE(numout,*) '~~~~~~~~~~~~'
+      ENDIF
+      !
+      ALLOCATE( ah_wslp2(jpi,jpj,jpk) , akz(jpi,jpj,jpk) , STAT=ierr )
+      IF( ierr > 0 )   CALL ctl_stop( 'STOP', 'ldf_slp_init : unable to allocate ah_slp2 or akz' )
+      !
+      IF( ln_traldf_triad ) THEN        ! Griffies operator : triad of slopes
+         IF(lwp) WRITE(numout,*) '   ==>>>   triad) operator (Griffies)'
+         ALLOCATE( triadi_g(jpi,jpj,jpk,0:1,0:1) , triadj_g(jpi,jpj,jpk,0:1,0:1) ,     &
+            &      triadi  (jpi,jpj,jpk,0:1,0:1) , triadj  (jpi,jpj,jpk,0:1,0:1) ,     &
+            &      wslp2   (jpi,jpj,jpk)                                         , STAT=ierr )
+         IF( ierr > 0      )   CALL ctl_stop( 'STOP', 'ldf_slp_init : unable to allocate Griffies operator slope' )
+         IF( ln_dynldf_iso )   CALL ctl_stop( 'ldf_slp_init: Griffies operator on momentum not supported' )
+         !
+      ELSE                             ! Madec operator : slopes at u-, v-, and w-points
+         IF(lwp) WRITE(numout,*) '   ==>>>   iso operator (Madec)'
+         ALLOCATE( omlmask(jpi,jpj,jpk) ,                                                                        &
+            &      uslp(jpi,jpj,jpk) , uslpml(jpi,jpj) , wslpi(jpi,jpj,jpk) , wslpiml(jpi,jpj) ,     &
+            &      vslp(jpi,jpj,jpk) , vslpml(jpi,jpj) , wslpj(jpi,jpj,jpk) , wslpjml(jpi,jpj) , STAT=ierr )
+         IF( ierr > 0 )   CALL ctl_stop( 'STOP', 'ldf_slp_init : unable to allocate Madec operator slope ' )
+
+         ! Direction of lateral diffusion (tracers and/or momentum)
+         ! ------------------------------
+         uslp (:,:,:) = 0._wp   ;   uslpml (:,:) = 0._wp      ! set the slope to zero (even in s-coordinates)
+         vslp (:,:,:) = 0._wp   ;   vslpml (:,:) = 0._wp
+         wslpi(:,:,:) = 0._wp   ;   wslpiml(:,:) = 0._wp
+         wslpj(:,:,:) = 0._wp   ;   wslpjml(:,:) = 0._wp
+
+         !!gm I no longer understand this.....
+!!gm         IF( (ln_traldf_hor .OR. ln_dynldf_hor) .AND. .NOT. (.NOT.ln_linssh .AND. ln_rstart) ) THEN
+!            IF(lwp)   WRITE(numout,*) '          Horizontal mixing in s-coordinate: slope = slope of s-surfaces'
+!
+!            ! geopotential diffusion in s-coordinates on tracers and/or momentum
+!            ! The slopes of s-surfaces are computed once (no call to ldfslp in step)
+!            ! The slopes for momentum diffusion are i- or j- averaged of those on tracers
+!
+!            ! set the slope of diffusion to the slope of s-surfaces
+!            !      ( c a u t i o n : minus sign as dep has positive value )
+!            DO jk = 1, jpk
+!               DO jj = 2, jpjm1
+!                  DO ji = fs_2, fs_jpim1   ! vector opt.
+!                     uslp (ji,jj,jk) = - ( gdept_n(ji+1,jj,jk) - gdept_n(ji ,jj ,jk) ) * r1_e1u(ji,jj) * umask(ji,jj,jk)
+!                     vslp (ji,jj,jk) = - ( gdept_n(ji,jj+1,jk) - gdept_n(ji ,jj ,jk) ) * r1_e2v(ji,jj) * vmask(ji,jj,jk)
+!                     wslpi(ji,jj,jk) = - ( gdepw_n(ji+1,jj,jk) - gdepw_n(ji-1,jj,jk) ) * r1_e1t(ji,jj) * wmask(ji,jj,jk) * 0.5
+!                     wslpj(ji,jj,jk) = - ( gdepw_n(ji,jj+1,jk) - gdepw_n(ji,jj-1,jk) ) * r1_e2t(ji,jj) * wmask(ji,jj,jk) * 0.5
+!                  END DO
+!               END DO
+!            END DO
+!            CALL lbc_lnk_multi( uslp , 'U', -1. ; CALL lbc_lnk( vslp , 'V', -1.,  wslpi, 'W', -1.,  wslpj, 'W', -1. )
+!!gm         ENDIF
+      ENDIF
+      !
+   END SUBROUTINE ldf_slp_init
+
+   !!======================================================================
+END MODULE ldfslp
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/LDF/ldftra.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/LDF/ldftra.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/LDF/ldftra.F90	(revision 9570)
@@ -0,0 +1,927 @@
+MODULE ldftra
+   !!======================================================================
+   !!                       ***  MODULE  ldftra  ***
+   !! Ocean physics:  lateral diffusivity coefficients 
+   !!=====================================================================
+   !! History :       ! 1997-07  (G. Madec)  from inimix.F split in 2 routines
+   !!   NEMO     1.0  ! 2002-09  (G. Madec)  F90: Free form and module
+   !!            2.0  ! 2005-11  (G. Madec)  
+   !!            3.7  ! 2013-12  (F. Lemarie, G. Madec)  restructuration/simplification of aht/aeiv specification,
+   !!                 !                                  add velocity dependent coefficient and optional read in file
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   ldf_tra_init : initialization, namelist read, and parameters control
+   !!   ldf_tra      : update lateral eddy diffusivity coefficients at each time step 
+   !!   ldf_eiv_init : initialization of the eiv coeff. from namelist choices 
+   !!   ldf_eiv      : time evolution of the eiv coefficients (function of the growth rate of baroclinic instability)
+   !!   ldf_eiv_trp  : add to the input ocean transport the contribution of the EIV parametrization
+   !!   ldf_eiv_dia  : diagnose the eddy induced velocity from the eiv streamfunction
+   !!----------------------------------------------------------------------
+   USE oce             ! ocean dynamics and tracers
+   USE dom_oce         ! ocean space and time domain
+   USE phycst          ! physical constants
+   USE ldfslp          ! lateral diffusion: slope of iso-neutral surfaces
+   USE ldfc1d_c2d      ! lateral diffusion: 1D & 2D cases 
+   USE diaptr
+   !
+   USE in_out_manager  ! I/O manager
+   USE iom             ! I/O module for ehanced bottom friction file
+   USE lib_mpp         ! distribued memory computing library
+   USE lbclnk          ! ocean lateral boundary conditions (or mpp link)
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   ldf_tra_init   ! called by nemogcm.F90
+   PUBLIC   ldf_tra        ! called by step.F90
+   PUBLIC   ldf_eiv_init   ! called by nemogcm.F90
+   PUBLIC   ldf_eiv        ! called by step.F90
+   PUBLIC   ldf_eiv_trp    ! called by traadv.F90
+   PUBLIC   ldf_eiv_dia    ! called by traldf_iso and traldf_iso_triad.F90
+   
+   !                                   !!* Namelist namtra_ldf : lateral mixing on tracers * 
+   !                                    != Operator type =!
+   LOGICAL , PUBLIC ::   ln_traldf_OFF       !: no operator: No explicit diffusion
+   LOGICAL , PUBLIC ::   ln_traldf_lap       !: laplacian operator
+   LOGICAL , PUBLIC ::   ln_traldf_blp       !: bilaplacian operator
+   !                                    != Direction of action =!
+   LOGICAL , PUBLIC ::   ln_traldf_lev       !: iso-level direction
+   LOGICAL , PUBLIC ::   ln_traldf_hor       !: horizontal (geopotential) direction
+!  LOGICAL , PUBLIC ::   ln_traldf_iso       !: iso-neutral direction                    (see ldfslp)
+   !		       	                      != iso-neutral options =!
+!  LOGICAL , PUBLIC ::   ln_traldf_triad     !: griffies triad scheme                    (see ldfslp)
+   LOGICAL , PUBLIC ::   ln_traldf_msc       !: Method of Stabilizing Correction 
+!  LOGICAL , PUBLIC ::   ln_triad_iso        !: pure horizontal mixing in ML             (see ldfslp)
+!  LOGICAL , PUBLIC ::   ln_botmix_triad     !: mixing on bottom                         (see ldfslp)
+!  REAL(wp), PUBLIC ::   rn_sw_triad         !: =1/0 switching triad / all 4 triads used (see ldfslp)
+!  REAL(wp), PUBLIC ::   rn_slpmax           !: slope limit                              (see ldfslp)
+   !                                    !=  Coefficients =!
+   INTEGER , PUBLIC ::   nn_aht_ijk_t        !: choice of time & space variations of the lateral eddy diffusivity coef.
+   !                                            !  time invariant coefficients:  aht_0 = 1/2  Ud*Ld   (lap case) 
+   !                                            !                                bht_0 = 1/12 Ud*Ld^3 (blp case)
+   REAL(wp), PUBLIC ::      rn_Ud               !: lateral diffusive velocity  [m/s]
+   REAL(wp), PUBLIC ::      rn_Ld               !: lateral diffusive length    [m]
+
+   !                                   !!* Namelist namtra_eiv : eddy induced velocity param. *
+   !                                    != Use/diagnose eiv =!
+   LOGICAL , PUBLIC ::   ln_ldfeiv           !: eddy induced velocity flag
+   LOGICAL , PUBLIC ::   ln_ldfeiv_dia       !: diagnose & output eiv streamfunction and velocity (IOM)
+   !                                    != Coefficients =!
+   INTEGER , PUBLIC ::   nn_aei_ijk_t        !: choice of time/space variation of the eiv coeff.
+   REAL(wp), PUBLIC ::      rn_Ue               !: lateral diffusive velocity  [m/s]
+   REAL(wp), PUBLIC ::      rn_Le               !: lateral diffusive length    [m]
+   
+   !                                  ! Flag to control the type of lateral diffusive operator
+   INTEGER, PARAMETER, PUBLIC ::   np_ERROR  =-10   ! error in specification of lateral diffusion
+   INTEGER, PARAMETER, PUBLIC ::   np_no_ldf = 00   ! without operator (i.e. no lateral diffusive trend)
+   !                          !!      laplacian     !    bilaplacian    !
+   INTEGER, PARAMETER, PUBLIC ::   np_lap    = 10   ,   np_blp    = 20  ! iso-level operator
+   INTEGER, PARAMETER, PUBLIC ::   np_lap_i  = 11   ,   np_blp_i  = 21  ! standard iso-neutral or geopotential operator
+   INTEGER, PARAMETER, PUBLIC ::   np_lap_it = 12   ,   np_blp_it = 22  ! triad    iso-neutral or geopotential operator
+
+   INTEGER , PUBLIC ::   nldf_tra      = 0         !: type of lateral diffusion used defined from ln_traldf_... (namlist logicals)
+   LOGICAL , PUBLIC ::   l_ldftra_time = .FALSE.   !: flag for time variation of the lateral eddy diffusivity coef.
+   LOGICAL , PUBLIC ::   l_ldfeiv_time = .FALSE.   !: flag for time variation of the eiv coef.
+
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   ahtu, ahtv   !: eddy diffusivity coef. at U- and V-points   [m2/s]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   aeiu, aeiv   !: eddy induced velocity coeff.                [m2/s]
+
+   REAL(wp) ::   aht0, aei0               ! constant eddy coefficients (deduced from namelist values)                     [m2/s]
+   REAL(wp) ::   r1_2  = 0.5_wp           ! =1/2
+   REAL(wp) ::   r1_4  = 0.25_wp          ! =1/4
+   REAL(wp) ::   r1_12 = 1._wp / 12._wp   ! =1/12
+
+   !! * Substitutions
+#  include "vectopt_loop_substitute.h90"
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.7 , NEMO Consortium (2015)
+   !! $Id$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE ldf_tra_init
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE ldf_tra_init  ***
+      !! 
+      !! ** Purpose :   initializations of the tracer lateral mixing coeff.
+      !!
+      !! ** Method  : * the eddy diffusivity coef. specification depends on:
+      !!
+      !!    ln_traldf_lap = T     laplacian operator
+      !!    ln_traldf_blp = T   bilaplacian operator
+      !!
+      !!    nn_aht_ijk_t  =  0 => = constant
+      !!                  !
+      !!                  = 10 => = F(z) : constant with a reduction of 1/4 with depth 
+      !!                  !
+      !!                  =-20 => = F(i,j)   = shape read in 'eddy_diffusivity.nc' file
+      !!                  = 20    = F(i,j)   = F(e1,e2) or F(e1^3,e2^3) (lap or bilap case)
+      !!                  = 21    = F(i,j,t) = F(growth rate of baroclinic instability)
+      !!                  !
+      !!                  =-30 => = F(i,j,k)   = shape read in 'eddy_diffusivity.nc' file
+      !!                  = 30    = F(i,j,k)   = 2D (case 20) + decrease with depth (case 10)
+      !!                  = 31    = F(i,j,k,t) = F(local velocity) (  1/2  |u|e     laplacian operator
+      !!                                                           or 1/12 |u|e^3 bilaplacian operator )
+      !!              * initialisation of the eddy induced velocity coefficient by a call to ldf_eiv_init 
+      !!            
+      !! ** action  : ahtu, ahtv initialized one for all or l_ldftra_time set to true
+      !!              aeiu, aeiv initialized one for all or l_ldfeiv_time set to true
+      !!----------------------------------------------------------------------
+      INTEGER  ::   jk                             ! dummy loop indices
+      INTEGER  ::   ioptio, ierr, inum, ios, inn   ! local integer
+      REAL(wp) ::   zah_max, zUfac                 !   -      -
+      CHARACTER(len=5) ::   cl_Units               ! units (m2/s or m4/s)
+      !!
+      NAMELIST/namtra_ldf/ ln_traldf_OFF, ln_traldf_lap  , ln_traldf_blp  ,   &   ! type of operator
+         &                 ln_traldf_lev, ln_traldf_hor  , ln_traldf_triad,   &   ! acting direction of the operator
+         &                 ln_traldf_iso, ln_traldf_msc  ,  rn_slpmax     ,   &   ! option for iso-neutral operator
+         &                 ln_triad_iso , ln_botmix_triad, rn_sw_triad    ,   &   ! option for triad operator
+         &                 nn_aht_ijk_t , rn_Ud          , rn_Ld                  ! lateral eddy coefficient
+      !!----------------------------------------------------------------------
+      !
+      IF(lwp) THEN                      ! control print
+         WRITE(numout,*)
+         WRITE(numout,*) 'ldf_tra_init : lateral tracer diffusion'
+         WRITE(numout,*) '~~~~~~~~~~~~ '
+      ENDIF
+      
+      !
+      !  Choice of lateral tracer physics
+      ! =================================
+      !
+      REWIND( numnam_ref )              ! Namelist namtra_ldf in reference namelist : Lateral physics on tracers
+      READ  ( numnam_ref, namtra_ldf, IOSTAT = ios, ERR = 901)
+901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namtra_ldf in reference namelist', lwp )
+      REWIND( numnam_cfg )              ! Namelist namtra_ldf in configuration namelist : Lateral physics on tracers
+      READ  ( numnam_cfg, namtra_ldf, IOSTAT = ios, ERR = 902 )
+902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namtra_ldf in configuration namelist', lwp )
+      IF(lwm) WRITE( numond, namtra_ldf )
+      !
+      IF(lwp) THEN                      ! control print
+         WRITE(numout,*) '   Namelist : namtra_ldf --- lateral mixing parameters (type, direction, coefficients)'
+         WRITE(numout,*) '      type :'
+         WRITE(numout,*) '         no explicit diffusion                   ln_traldf_OFF   = ', ln_traldf_OFF
+         WRITE(numout,*) '         laplacian operator                      ln_traldf_lap   = ', ln_traldf_lap
+         WRITE(numout,*) '         bilaplacian operator                    ln_traldf_blp   = ', ln_traldf_blp
+         WRITE(numout,*) '      direction of action :'
+         WRITE(numout,*) '         iso-level                               ln_traldf_lev   = ', ln_traldf_lev
+         WRITE(numout,*) '         horizontal (geopotential)               ln_traldf_hor   = ', ln_traldf_hor
+         WRITE(numout,*) '         iso-neutral Madec operator              ln_traldf_iso   = ', ln_traldf_iso
+         WRITE(numout,*) '         iso-neutral triad operator              ln_traldf_triad = ', ln_traldf_triad
+         WRITE(numout,*) '            use the Method of Stab. Correction   ln_traldf_msc   = ', ln_traldf_msc
+         WRITE(numout,*) '            maximum isoppycnal slope             rn_slpmax       = ', rn_slpmax
+         WRITE(numout,*) '            pure lateral mixing in ML            ln_triad_iso    = ', ln_triad_iso
+         WRITE(numout,*) '            switching triad or not               rn_sw_triad     = ', rn_sw_triad
+         WRITE(numout,*) '            lateral mixing on bottom             ln_botmix_triad = ', ln_botmix_triad
+         WRITE(numout,*) '      coefficients :'
+         WRITE(numout,*) '         type of time-space variation            nn_aht_ijk_t    = ', nn_aht_ijk_t
+         WRITE(numout,*) '            lateral diffusive velocity (if cst)  rn_Ud           = ', rn_Ud, ' m/s'
+         WRITE(numout,*) '            lateral diffusive length   (if cst)  rn_Ld           = ', rn_Ld, ' m'
+      ENDIF
+      !
+      !
+      ! Operator and its acting direction   (set nldf_tra)  
+      ! =================================
+      !
+      nldf_tra = np_ERROR
+      ioptio   = 0
+      IF( ln_traldf_OFF ) THEN   ;   nldf_tra = np_no_ldf   ;   ioptio = ioptio + 1   ;   ENDIF
+      IF( ln_traldf_lap ) THEN   ;                              ioptio = ioptio + 1   ;   ENDIF
+      IF( ln_traldf_blp ) THEN   ;                              ioptio = ioptio + 1   ;   ENDIF
+      IF( ioptio /=  1  )   CALL ctl_stop( 'tra_ldf_init: use ONE of the 3 operator options (NONE/lap/blp)' )
+      !
+      IF( .NOT.ln_traldf_OFF ) THEN    !==  direction ==>> type of operator  ==!
+         ioptio = 0
+         IF( ln_traldf_lev )   ioptio = ioptio + 1
+         IF( ln_traldf_hor )   ioptio = ioptio + 1
+         IF( ln_traldf_iso )   ioptio = ioptio + 1
+         IF( ioptio /=  1  )   CALL ctl_stop( 'tra_ldf_init: use ONE direction (level/hor/iso)' )
+         !
+         !                                ! defined the type of lateral diffusion from ln_traldf_... logicals
+         ierr = 0
+         IF ( ln_traldf_lap ) THEN        ! laplacian operator
+            IF ( ln_zco ) THEN                  ! z-coordinate
+               IF ( ln_traldf_lev   )   nldf_tra = np_lap     ! iso-level = horizontal (no rotation)
+               IF ( ln_traldf_hor   )   nldf_tra = np_lap     ! iso-level = horizontal (no rotation)
+               IF ( ln_traldf_iso   )   nldf_tra = np_lap_i   ! iso-neutral: standard  (   rotation)
+               IF ( ln_traldf_triad )   nldf_tra = np_lap_it  ! iso-neutral: triad     (   rotation)
+            ENDIF
+            IF ( ln_zps ) THEN                  ! z-coordinate with partial step
+               IF ( ln_traldf_lev   )   ierr     = 1          ! iso-level not allowed 
+               IF ( ln_traldf_hor   )   nldf_tra = np_lap     ! horizontal             (no rotation)
+               IF ( ln_traldf_iso   )   nldf_tra = np_lap_i   ! iso-neutral: standard     (rotation)
+               IF ( ln_traldf_triad )   nldf_tra = np_lap_it  ! iso-neutral: triad        (rotation)
+            ENDIF
+            IF ( ln_sco ) THEN                  ! s-coordinate
+               IF ( ln_traldf_lev   )   nldf_tra = np_lap     ! iso-level              (no rotation)
+               IF ( ln_traldf_hor   )   nldf_tra = np_lap_i   ! horizontal             (   rotation)
+               IF ( ln_traldf_iso   )   nldf_tra = np_lap_i   ! iso-neutral: standard  (   rotation)
+               IF ( ln_traldf_triad )   nldf_tra = np_lap_it  ! iso-neutral: triad     (   rotation)
+            ENDIF
+         ENDIF
+         !
+         IF( ln_traldf_blp ) THEN         ! bilaplacian operator
+            IF ( ln_zco ) THEN                  ! z-coordinate
+               IF ( ln_traldf_lev   )   nldf_tra = np_blp     ! iso-level = horizontal (no rotation)
+               IF ( ln_traldf_hor   )   nldf_tra = np_blp     ! iso-level = horizontal (no rotation)
+               IF ( ln_traldf_iso   )   nldf_tra = np_blp_i   ! iso-neutral: standard  (   rotation)
+               IF ( ln_traldf_triad )   nldf_tra = np_blp_it  ! iso-neutral: triad     (   rotation)
+            ENDIF
+            IF ( ln_zps ) THEN                  ! z-coordinate with partial step
+               IF ( ln_traldf_lev   )   ierr     = 1          ! iso-level not allowed 
+               IF ( ln_traldf_hor   )   nldf_tra = np_blp     ! horizontal             (no rotation)
+               IF ( ln_traldf_iso   )   nldf_tra = np_blp_i   ! iso-neutral: standard  (   rotation)
+               IF ( ln_traldf_triad )   nldf_tra = np_blp_it  ! iso-neutral: triad     (   rotation)
+            ENDIF
+            IF ( ln_sco ) THEN                  ! s-coordinate
+               IF ( ln_traldf_lev   )   nldf_tra = np_blp     ! iso-level              (no rotation)
+               IF ( ln_traldf_hor   )   nldf_tra = np_blp_it  ! horizontal             (   rotation)
+               IF ( ln_traldf_iso   )   nldf_tra = np_blp_i   ! iso-neutral: standard  (   rotation)
+               IF ( ln_traldf_triad )   nldf_tra = np_blp_it  ! iso-neutral: triad     (   rotation)
+            ENDIF
+         ENDIF
+         IF ( ierr == 1 )   CALL ctl_stop( 'iso-level in z-partial step, not allowed' )
+      ENDIF
+      !
+      IF( ln_ldfeiv .AND. .NOT.( ln_traldf_iso .OR. ln_traldf_triad ) )                &
+           &            CALL ctl_stop( 'ln_ldfeiv=T requires iso-neutral laplacian diffusion' )
+      IF( ln_isfcav .AND. ln_traldf_triad ) &
+           &            CALL ctl_stop( ' ice shelf cavity and traldf_triad not tested' )
+           !
+      IF(  nldf_tra == np_lap_i .OR. nldf_tra == np_lap_it .OR. &
+         & nldf_tra == np_blp_i .OR. nldf_tra == np_blp_it  )   l_ldfslp = .TRUE.    ! slope of neutral surfaces required 
+      !
+      IF( ln_traldf_blp .AND. ( ln_traldf_iso .OR. ln_traldf_triad) ) THEN     ! iso-neutral bilaplacian need MSC
+         IF( .NOT.ln_traldf_msc )   CALL ctl_stop( 'tra_ldf_init: iso-neutral bilaplacian requires ln_traldf_msc=.true.' )
+      ENDIF
+      !
+      IF(lwp) THEN
+         WRITE(numout,*)
+         SELECT CASE( nldf_tra )
+         CASE( np_no_ldf )   ;   WRITE(numout,*) '   ==>>>   NO lateral diffusion'
+         CASE( np_lap    )   ;   WRITE(numout,*) '   ==>>>   laplacian iso-level operator'
+         CASE( np_lap_i  )   ;   WRITE(numout,*) '   ==>>>   Rotated laplacian operator (standard)'
+         CASE( np_lap_it )   ;   WRITE(numout,*) '   ==>>>   Rotated laplacian operator (triad)'
+         CASE( np_blp    )   ;   WRITE(numout,*) '   ==>>>   bilaplacian iso-level operator'
+         CASE( np_blp_i  )   ;   WRITE(numout,*) '   ==>>>   Rotated bilaplacian operator (standard)'
+         CASE( np_blp_it )   ;   WRITE(numout,*) '   ==>>>   Rotated bilaplacian operator (triad)'
+         END SELECT
+         WRITE(numout,*)
+      ENDIF
+
+      !
+      !  Space/time variation of eddy coefficients 
+      ! ===========================================
+      !
+      l_ldftra_time = .FALSE.                ! no time variation except in case defined below
+      !
+      IF( ln_traldf_OFF ) THEN               !== no explicit diffusive operator  ==!
+         !
+         IF(lwp) WRITE(numout,*) '   ==>>>   No diffusive operator selected. ahtu and ahtv are not allocated'
+         RETURN
+         !
+      ELSE                                   !==  a lateral diffusion operator is used  ==!
+         !
+         !                                         ! allocate the aht arrays
+         ALLOCATE( ahtu(jpi,jpj,jpk) , ahtv(jpi,jpj,jpk) , STAT=ierr )
+         IF( ierr /= 0 )   CALL ctl_stop( 'STOP', 'ldf_tra_init: failed to allocate arrays')
+         !
+         ahtu(:,:,jpk) = 0._wp                     ! last level always 0  
+         ahtv(:,:,jpk) = 0._wp
+         !.
+         !                                         ! value of lap/blp eddy mixing coef.
+         IF(     ln_traldf_lap ) THEN   ;   zUfac = r1_2 *rn_Ud   ;   inn = 1   ;   cl_Units = ' m2/s'   !   laplacian
+         ELSEIF( ln_traldf_blp ) THEN   ;   zUfac = r1_12*rn_Ud   ;   inn = 3   ;   cl_Units = ' m4/s'   ! bilaplacian
+         ENDIF
+         aht0    = zUfac *    rn_Ld**inn              ! mixing coefficient
+         zah_max = zUfac * (ra*rad)**inn              ! maximum reachable coefficient (value at the Equator for e1=1 degree)
+         !
+         !
+         SELECT CASE(  nn_aht_ijk_t  )             !* Specification of space-time variations of ahtu, ahtv
+         !
+         CASE(   0  )      !==  constant  ==!
+            IF(lwp) WRITE(numout,*) '   ==>>>   eddy diffusivity = constant = ', aht0, cl_Units
+            ahtu(:,:,1:jpkm1) = aht0
+            ahtv(:,:,1:jpkm1) = aht0
+            !
+         CASE(  10  )      !==  fixed profile  ==!
+            IF(lwp) WRITE(numout,*) '   ==>>>   eddy diffusivity = F( depth )'
+            IF(lwp) WRITE(numout,*) '           surface eddy diffusivity = constant = ', aht0, cl_Units
+            ahtu(:,:,1) = aht0                        ! constant surface value
+            ahtv(:,:,1) = aht0
+            CALL ldf_c1d( 'TRA', ahtu(:,:,1), ahtv(:,:,1), ahtu, ahtv )
+            !
+         CASE ( -20 )      !== fixed horizontal shape and magnitude read in file  ==!
+            IF(lwp) WRITE(numout,*) '   ==>>>   eddy diffusivity = F(i,j) read in eddy_diffusivity.nc file'
+            CALL iom_open( 'eddy_diffusivity_2D.nc', inum )
+            CALL iom_get ( inum, jpdom_data, 'ahtu_2D', ahtu(:,:,1) )
+            CALL iom_get ( inum, jpdom_data, 'ahtv_2D', ahtv(:,:,1) )
+            CALL iom_close( inum )
+            DO jk = 2, jpkm1
+               ahtu(:,:,jk) = ahtu(:,:,1)
+               ahtv(:,:,jk) = ahtv(:,:,1)
+            END DO
+            !
+         CASE(  20  )      !== fixed horizontal shape  ==!
+            IF(lwp) WRITE(numout,*) '   ==>>>   eddy diffusivity = F( e1, e2 ) or F( e1^3, e2^3 ) (lap or blp case)'
+            IF(lwp) WRITE(numout,*) '           using a fixed diffusive velocity = ', rn_Ud,' m/s   and   Ld = Max(e1,e2)'
+            IF(lwp) WRITE(numout,*) '           maximum reachable coefficient (at the Equator) = ', zah_max, cl_Units, '  for e1=1°)'
+            CALL ldf_c2d( 'TRA', zUfac      , inn        , ahtu, ahtv )    ! value proportional to scale factor^inn
+            !
+         CASE(  21  )      !==  time varying 2D field  ==!
+            IF(lwp) WRITE(numout,*) '   ==>>>   eddy diffusivity = F( latitude, longitude, time )'
+            IF(lwp) WRITE(numout,*) '                            = F( growth rate of baroclinic instability )'
+            IF(lwp) WRITE(numout,*) '            min value = 0.2 * aht0 (with aht0= 1/2 rn_Ud*rn_Ld)'
+            IF(lwp) WRITE(numout,*) '            max value =       aei0 (with aei0=1/2 rn_Ue*Le  increased to aht0 within 20N-20S'
+            !
+            l_ldftra_time = .TRUE.     ! will be calculated by call to ldf_tra routine in step.F90
+            !
+            IF( ln_traldf_blp )   CALL ctl_stop( 'ldf_tra_init: aht=F( growth rate of baroc. insta .)',   &
+               &                                 '              incompatible with bilaplacian operator' )
+            !
+         CASE( -30  )      !== fixed 3D shape read in file  ==!
+            IF(lwp) WRITE(numout,*) '   ==>>>   eddy diffusivity = F(i,j,k) read in eddy_diffusivity.nc file'
+            CALL iom_open( 'eddy_diffusivity_3D.nc', inum )
+            CALL iom_get ( inum, jpdom_data, 'ahtu_3D', ahtu )
+            CALL iom_get ( inum, jpdom_data, 'ahtv_3D', ahtv )
+            CALL iom_close( inum )
+            !
+         CASE(  30  )      !==  fixed 3D shape  ==!
+            IF(lwp) WRITE(numout,*) '   ==>>>   eddy diffusivity = F( latitude, longitude, depth )'
+            IF(lwp) WRITE(numout,*) '           using a fixed diffusive velocity = ', rn_Ud,' m/s   and   Ld = Max(e1,e2)'
+            IF(lwp) WRITE(numout,*) '           maximum reachable coefficient (at the Equator) = ', zah_max, cl_Units, '  for e1=1°)'
+            CALL ldf_c2d( 'TRA', zUfac      , inn        , ahtu, ahtv )    ! surface value proportional to scale factor^inn
+            CALL ldf_c1d( 'TRA', ahtu(:,:,1), ahtv(:,:,1), ahtu, ahtv )    ! reduction with depth
+            !
+         CASE(  31  )      !==  time varying 3D field  ==!
+            IF(lwp) WRITE(numout,*) '   ==>>>   eddy diffusivity = F( latitude, longitude, depth , time )'
+            IF(lwp) WRITE(numout,*) '           proportional to the velocity : 1/2 |u|e or 1/12 |u|e^3'
+            !
+            l_ldftra_time = .TRUE.     ! will be calculated by call to ldf_tra routine in step.F90
+            !
+         CASE DEFAULT
+            CALL ctl_stop('ldf_tra_init: wrong choice for nn_aht_ijk_t, the type of space-time variation of aht')
+         END SELECT
+         !
+         IF( .NOT.l_ldftra_time ) THEN             !* No time variation 
+            IF(     ln_traldf_lap ) THEN                 !   laplacian operator (mask only)
+               ahtu(:,:,1:jpkm1) =       ahtu(:,:,1:jpkm1)   * umask(:,:,1:jpkm1)
+               ahtv(:,:,1:jpkm1) =       ahtv(:,:,1:jpkm1)   * vmask(:,:,1:jpkm1)
+            ELSEIF( ln_traldf_blp ) THEN                 ! bilaplacian operator (square root + mask)
+               ahtu(:,:,1:jpkm1) = SQRT( ahtu(:,:,1:jpkm1) ) * umask(:,:,1:jpkm1)
+               ahtv(:,:,1:jpkm1) = SQRT( ahtv(:,:,1:jpkm1) ) * vmask(:,:,1:jpkm1)
+            ENDIF
+         ENDIF
+         !
+      ENDIF
+      !
+   END SUBROUTINE ldf_tra_init
+
+
+   SUBROUTINE ldf_tra( kt )
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE ldf_tra  ***
+      !! 
+      !! ** Purpose :   update at kt the tracer lateral mixing coeff. (aht and aeiv)
+      !!
+      !! ** Method  : * time varying eddy diffusivity coefficients:
+      !!
+      !!    nn_aei_ijk_t = 21    aeiu, aeiv = F(i,j,  t) = F(growth rate of baroclinic instability)
+      !!                                                   with a reduction to 0 in vicinity of the Equator
+      !!    nn_aht_ijk_t = 21    ahtu, ahtv = F(i,j,  t) = F(growth rate of baroclinic instability)
+      !!
+      !!                 = 31    ahtu, ahtv = F(i,j,k,t) = F(local velocity) (  |u|e  /12   laplacian operator
+      !!                                                                     or |u|e^3/12 bilaplacian operator )
+      !!
+      !!              * time varying EIV coefficients: call to ldf_eiv routine
+      !!
+      !! ** action  :   ahtu, ahtv   update at each time step   
+      !!                aeiu, aeiv      -       -     -    -   (if ln_ldfeiv=T) 
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT(in) ::   kt   ! time step
+      !
+      INTEGER  ::   ji, jj, jk   ! dummy loop indices
+      REAL(wp) ::   zaht, zahf, zaht_min, zDaht, z1_f20   ! local scalar
+      !!----------------------------------------------------------------------
+      !
+      IF( ln_ldfeiv .AND. nn_aei_ijk_t == 21 ) THEN       ! eddy induced velocity coefficients
+         !                                ! =F(growth rate of baroclinic instability)
+         !                                ! max value aeiv_0 ; decreased to 0 within 20N-20S
+         CALL ldf_eiv( kt, aei0, aeiu, aeiv )
+      ENDIF
+      !
+      SELECT CASE(  nn_aht_ijk_t  )       ! Eddy diffusivity coefficients
+      !
+      CASE(  21  )       !==  time varying 2D field  ==!   = F( growth rate of baroclinic instability )
+         !                                             !   min value 0.2*aht0
+         !                                             !   max value aht0 (aei0 if nn_aei_ijk_t=21)
+         !                                             !   increase to aht0 within 20N-20S
+         IF( ln_ldfeiv .AND. nn_aei_ijk_t == 21 ) THEN   ! use the already computed aei.
+            ahtu(:,:,1) = aeiu(:,:,1)
+            ahtv(:,:,1) = aeiv(:,:,1)
+         ELSE                                            ! compute aht. 
+            CALL ldf_eiv( kt, aht0, ahtu, ahtv )
+         ENDIF
+         !
+         z1_f20   = 1._wp / (  2._wp * omega * SIN( rad * 20._wp )  )   ! 1 / ff(20 degrees)   
+         zaht_min = 0.2_wp * aht0                                       ! minimum value for aht
+         zDaht    = aht0 - zaht_min                                      
+         DO jj = 1, jpj
+            DO ji = 1, jpi
+               !!gm CAUTION : here we assume lat/lon grid in 20deg N/S band (like all ORCA cfg)
+               !!     ==>>>   The Coriolis value is identical for t- & u_points, and for v- and f-points
+               zaht = ( 1._wp -  MIN( 1._wp , ABS( ff_t(ji,jj) * z1_f20 ) ) ) * zDaht
+               zahf = ( 1._wp -  MIN( 1._wp , ABS( ff_f(ji,jj) * z1_f20 ) ) ) * zDaht
+               ahtu(ji,jj,1) = (  MAX( zaht_min, ahtu(ji,jj,1) ) + zaht  )     ! min value zaht_min
+               ahtv(ji,jj,1) = (  MAX( zaht_min, ahtv(ji,jj,1) ) + zahf  )     ! increase within 20S-20N
+            END DO
+         END DO
+         DO jk = 1, jpkm1                             ! deeper value = surface value + mask for all levels
+            ahtu(:,:,jk) = ahtu(:,:,1) * umask(:,:,jk)
+            ahtv(:,:,jk) = ahtv(:,:,1) * vmask(:,:,jk)
+         END DO
+         !
+      CASE(  31  )       !==  time varying 3D field  ==!   = F( local velocity )
+         IF( ln_traldf_lap     ) THEN          !   laplacian operator |u| e /12
+            DO jk = 1, jpkm1
+               ahtu(:,:,jk) = ABS( ub(:,:,jk) ) * e1u(:,:) * r1_12   ! n.b. ub,vb are masked
+               ahtv(:,:,jk) = ABS( vb(:,:,jk) ) * e2v(:,:) * r1_12
+            END DO
+         ELSEIF( ln_traldf_blp ) THEN      ! bilaplacian operator      sqrt( |u| e^3 /12 ) = sqrt( |u| e /12 ) * e
+            DO jk = 1, jpkm1
+               ahtu(:,:,jk) = SQRT(  ABS( ub(:,:,jk) ) * e1u(:,:) * r1_12  ) * e1u(:,:)
+               ahtv(:,:,jk) = SQRT(  ABS( vb(:,:,jk) ) * e2v(:,:) * r1_12  ) * e2v(:,:)
+            END DO
+         ENDIF
+         !
+      END SELECT
+      !
+      CALL iom_put( "ahtu_2d", ahtu(:,:,1) )   ! surface u-eddy diffusivity coeff.
+      CALL iom_put( "ahtv_2d", ahtv(:,:,1) )   ! surface v-eddy diffusivity coeff.
+      CALL iom_put( "ahtu_3d", ahtu(:,:,:) )   ! 3D      u-eddy diffusivity coeff.
+      CALL iom_put( "ahtv_3d", ahtv(:,:,:) )   ! 3D      v-eddy diffusivity coeff.
+      !
+      IF( ln_ldfeiv ) THEN
+        CALL iom_put( "aeiu_2d", aeiu(:,:,1) )   ! surface u-EIV coeff.
+        CALL iom_put( "aeiv_2d", aeiv(:,:,1) )   ! surface v-EIV coeff.
+        CALL iom_put( "aeiu_3d", aeiu(:,:,:) )   ! 3D      u-EIV coeff.
+        CALL iom_put( "aeiv_3d", aeiv(:,:,:) )   ! 3D      v-EIV coeff.
+      ENDIF
+      !
+   END SUBROUTINE ldf_tra
+
+
+   SUBROUTINE ldf_eiv_init
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE ldf_eiv_init  ***
+      !!
+      !! ** Purpose :   initialization of the eiv coeff. from namelist choices.
+      !!
+      !! ** Method  :   the eiv diffusivity coef. specification depends on:
+      !!    nn_aei_ijk_t  =  0 => = constant
+      !!                  !
+      !!                  = 10 => = F(z) : constant with a reduction of 1/4 with depth 
+      !!                  !
+      !!                  =-20 => = F(i,j)   = shape read in 'eddy_diffusivity.nc' file
+      !!                  = 20    = F(i,j)   = F(e1,e2) or F(e1^3,e2^3) (lap or bilap case)
+      !!                  = 21    = F(i,j,t) = F(growth rate of baroclinic instability)
+      !!                  !
+      !!                  =-30 => = F(i,j,k)   = shape read in 'eddy_diffusivity.nc' file
+      !!                  = 30    = F(i,j,k)   = 2D (case 20) + decrease with depth (case 10)
+      !!
+      !! ** Action  :   aeiu , aeiv   :  initialized one for all or l_ldftra_time set to true
+      !!                l_ldfeiv_time : =T if EIV coefficients vary with time
+      !!----------------------------------------------------------------------
+      INTEGER  ::   jk                     ! dummy loop indices
+      INTEGER  ::   ierr, inum, ios, inn   ! local integer
+      REAL(wp) ::   zah_max, zUfac         !   -   scalar
+      !!
+      NAMELIST/namtra_eiv/ ln_ldfeiv   , ln_ldfeiv_dia,   &   ! eddy induced velocity (eiv)
+         &                 nn_aei_ijk_t, rn_Ue, rn_Le         ! eiv  coefficient
+      !!----------------------------------------------------------------------
+      !
+      IF(lwp) THEN                      ! control print
+         WRITE(numout,*)
+         WRITE(numout,*) 'ldf_eiv_init : eddy induced velocity parametrization'
+         WRITE(numout,*) '~~~~~~~~~~~~ '
+      ENDIF
+      !
+      REWIND( numnam_ref )              ! Namelist namtra_eiv in reference namelist : eddy induced velocity param.
+      READ  ( numnam_ref, namtra_eiv, IOSTAT = ios, ERR = 901)
+901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namtra_eiv in reference namelist', lwp )
+      !
+      REWIND( numnam_cfg )              ! Namelist namtra_eiv in configuration namelist : eddy induced velocity param.
+      READ  ( numnam_cfg, namtra_eiv, IOSTAT = ios, ERR = 902 )
+902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namtra_eiv in configuration namelist', lwp )
+      IF(lwm)  WRITE ( numond, namtra_eiv )
+
+      IF(lwp) THEN                      ! control print
+         WRITE(numout,*) '   Namelist namtra_eiv : '
+         WRITE(numout,*) '      Eddy Induced Velocity (eiv) param.         ln_ldfeiv     = ', ln_ldfeiv
+         WRITE(numout,*) '      eiv streamfunction & velocity diag.        ln_ldfeiv_dia = ', ln_ldfeiv_dia
+         WRITE(numout,*) '      coefficients :'
+         WRITE(numout,*) '         type of time-space variation            nn_aei_ijk_t  = ', nn_aht_ijk_t
+         WRITE(numout,*) '         lateral diffusive velocity (if cst)     rn_Ue         = ', rn_Ue, ' m/s'
+         WRITE(numout,*) '         lateral diffusive length   (if cst)     rn_Le         = ', rn_Le, ' m'
+         WRITE(numout,*)
+      ENDIF
+      !
+      l_ldfeiv_time = .FALSE.       ! no time variation except in case defined below
+      !
+      !
+      IF( .NOT.ln_ldfeiv ) THEN     !== Parametrization not used  ==!
+         !
+         IF(lwp) WRITE(numout,*) '   ==>>>   eddy induced velocity param is NOT used'
+         ln_ldfeiv_dia = .FALSE.
+         !
+      ELSE                          !== use the parametrization  ==!
+         !
+         IF(lwp) WRITE(numout,*) '   ==>>>   use eddy induced velocity parametrization'
+         IF(lwp) WRITE(numout,*)
+         !
+         IF( ln_traldf_blp )   CALL ctl_stop( 'ldf_eiv_init: eddy induced velocity ONLY with laplacian diffusivity' )
+         !
+         !                                != allocate the aei arrays
+         ALLOCATE( aeiu(jpi,jpj,jpk), aeiv(jpi,jpj,jpk), STAT=ierr )
+         IF( ierr /= 0 )   CALL ctl_stop('STOP', 'ldf_eiv: failed to allocate arrays')
+         !
+         !                                != Specification of space-time variations of eaiu, aeiv
+         !
+         aeiu(:,:,jpk) = 0._wp               ! last level always 0  
+         aeiv(:,:,jpk) = 0._wp
+         !                                   ! value of EIV coef. (laplacian operator)
+         zUfac = r1_2 *rn_Ue                    ! velocity factor
+         inn = 1                                ! L-exponent
+         aei0    = zUfac *    rn_Le**inn        ! mixing coefficient
+         zah_max = zUfac * (ra*rad)**inn        ! maximum reachable coefficient (value at the Equator)
+
+         SELECT CASE( nn_aei_ijk_t )         !* Specification of space-time variations
+         !
+         CASE(   0  )                        !--  constant  --!
+            IF(lwp) WRITE(numout,*) '   ==>>>   eddy induced velocity coef. = constant = ', aei0, ' m2/s'
+            aeiu(:,:,1:jpkm1) = aei0
+            aeiv(:,:,1:jpkm1) = aei0
+            !
+         CASE(  10  )                        !--  fixed profile  --!
+            IF(lwp) WRITE(numout,*) '   ==>>>   eddy induced velocity coef. = F( depth )'
+            IF(lwp) WRITE(numout,*) '           surface eddy diffusivity = constant = ', aht0, ' m2/s'
+            aeiu(:,:,1) = aei0                  ! constant surface value
+            aeiv(:,:,1) = aei0
+            CALL ldf_c1d( 'TRA', aeiu(:,:,1), aeiv(:,:,1), aeiu, aeiv )
+            !
+         CASE ( -20 )                        !--  fixed horizontal shape read in file  --!
+            IF(lwp) WRITE(numout,*) '   ==>>>   eddy induced velocity coef. = F(i,j) read in eddy_diffusivity_2D.nc file'
+            CALL iom_open ( 'eddy_induced_velocity_2D.nc', inum )
+            CALL iom_get  ( inum, jpdom_data, 'aeiu', aeiu(:,:,1) )
+            CALL iom_get  ( inum, jpdom_data, 'aeiv', aeiv(:,:,1) )
+            CALL iom_close( inum )
+            DO jk = 2, jpkm1
+               aeiu(:,:,jk) = aeiu(:,:,1)
+               aeiv(:,:,jk) = aeiv(:,:,1)
+            END DO
+            !
+         CASE(  20  )                        !--  fixed horizontal shape  --!
+            IF(lwp) WRITE(numout,*) '   ==>>>   eddy induced velocity coef. = F( e1, e2 )'
+            IF(lwp) WRITE(numout,*) '           using a fixed diffusive velocity = ', rn_Ue, ' m/s   and   Le = Max(e1,e2)'
+            IF(lwp) WRITE(numout,*) '           maximum reachable coefficient (at the Equator) = ', zah_max, ' m2/s   for e1=1°)'
+            CALL ldf_c2d( 'TRA', zUfac      , inn        , aeiu, aeiv )    ! value proportional to scale factor^inn
+            !
+         CASE(  21  )                        !--  time varying 2D field  --!
+            IF(lwp) WRITE(numout,*) '   ==>>>   eddy induced velocity coef. = F( latitude, longitude, time )'
+            IF(lwp) WRITE(numout,*) '                                       = F( growth rate of baroclinic instability )'
+            IF(lwp) WRITE(numout,*) '           maximum allowed value: aei0 = ', aei0, ' m2/s'
+            !
+            l_ldfeiv_time = .TRUE.     ! will be calculated by call to ldf_tra routine in step.F90
+            !
+         CASE( -30  )                        !-- fixed 3D shape read in file  --!
+            IF(lwp) WRITE(numout,*) '   ==>>>   eddy induced velocity coef. = F(i,j,k) read in eddy_diffusivity_3D.nc file'
+            CALL iom_open ( 'eddy_induced_velocity_3D.nc', inum )
+            CALL iom_get  ( inum, jpdom_data, 'aeiu', aeiu )
+            CALL iom_get  ( inum, jpdom_data, 'aeiv', aeiv )
+            CALL iom_close( inum )
+            !
+         CASE(  30  )                        !--  fixed 3D shape  --!
+            IF(lwp) WRITE(numout,*) '   ==>>>   eddy induced velocity coef. = F( latitude, longitude, depth )'
+            CALL ldf_c2d( 'TRA', zUfac      , inn        , aeiu, aeiv )    ! surface value proportional to scale factor^inn
+            CALL ldf_c1d( 'TRA', aeiu(:,:,1), aeiv(:,:,1), aeiu, aeiv )    ! reduction with depth
+            !
+         CASE DEFAULT
+            CALL ctl_stop('ldf_tra_init: wrong choice for nn_aei_ijk_t, the type of space-time variation of aei')
+         END SELECT
+         !
+         IF( .NOT.l_ldfeiv_time ) THEN             !* mask if No time variation 
+            DO jk = 1, jpkm1
+               aeiu(:,:,jk) = aeiu(:,:,jk) * umask(:,:,jk)
+               ahtv(:,:,jk) = ahtv(:,:,jk) * vmask(:,:,jk)
+            END DO
+         ENDIF
+         !
+      ENDIF
+      !                    
+   END SUBROUTINE ldf_eiv_init
+
+
+   SUBROUTINE ldf_eiv( kt, paei0, paeiu, paeiv )
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE ldf_eiv  ***
+      !!
+      !! ** Purpose :   Compute the eddy induced velocity coefficient from the
+      !!              growth rate of baroclinic instability.
+      !!
+      !! ** Method  :   coefficient function of the growth rate of baroclinic instability
+      !!
+      !! Reference : Treguier et al. JPO 1997   ; Held and Larichev JAS 1996
+      !!----------------------------------------------------------------------
+      INTEGER                         , INTENT(in   ) ::   kt             ! ocean time-step index
+      REAL(wp)                        , INTENT(inout) ::   paei0          ! max value            [m2/s]
+      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   paeiu, paeiv   ! eiv coefficient      [m2/s]
+      !
+      INTEGER  ::   ji, jj, jk    ! dummy loop indices
+      REAL(wp) ::   zfw, ze3w, zn2, z1_f20, zaht, zaht_min, zzaei    ! local scalars
+      REAL(wp), DIMENSION(jpi,jpj) ::   zn, zah, zhw, zRo, zaeiw   ! 2D workspace
+      !!----------------------------------------------------------------------
+      !
+      zn (:,:) = 0._wp        ! Local initialization
+      zhw(:,:) = 5._wp
+      zah(:,:) = 0._wp
+      zRo(:,:) = 0._wp
+      !                       ! Compute lateral diffusive coefficient at T-point
+      IF( ln_traldf_triad ) THEN
+         DO jk = 1, jpk
+            DO jj = 2, jpjm1
+               DO ji = 2, jpim1
+                  ! Take the max of N^2 and zero then take the vertical sum 
+                  ! of the square root of the resulting N^2 ( required to compute 
+                  ! internal Rossby radius Ro = .5 * sum_jpk(N) / f 
+                  zn2 = MAX( rn2b(ji,jj,jk), 0._wp )
+                  zn(ji,jj) = zn(ji,jj) + SQRT( zn2 ) * e3w_n(ji,jj,jk)
+                  ! Compute elements required for the inverse time scale of baroclinic
+                  ! eddies using the isopycnal slopes calculated in ldfslp.F : 
+                  ! T^-1 = sqrt(m_jpk(N^2*(r1^2+r2^2)*e3w))
+                  ze3w = e3w_n(ji,jj,jk) * tmask(ji,jj,jk)
+                  zah(ji,jj) = zah(ji,jj) + zn2 * wslp2(ji,jj,jk) * ze3w
+                  zhw(ji,jj) = zhw(ji,jj) + ze3w
+               END DO
+            END DO
+         END DO
+      ELSE
+         DO jk = 1, jpk
+            DO jj = 2, jpjm1
+               DO ji = 2, jpim1
+                  ! Take the max of N^2 and zero then take the vertical sum 
+                  ! of the square root of the resulting N^2 ( required to compute 
+                  ! internal Rossby radius Ro = .5 * sum_jpk(N) / f 
+                  zn2 = MAX( rn2b(ji,jj,jk), 0._wp )
+                  zn(ji,jj) = zn(ji,jj) + SQRT( zn2 ) * e3w_n(ji,jj,jk)
+                  ! Compute elements required for the inverse time scale of baroclinic
+                  ! eddies using the isopycnal slopes calculated in ldfslp.F : 
+                  ! T^-1 = sqrt(m_jpk(N^2*(r1^2+r2^2)*e3w))
+                  ze3w = e3w_n(ji,jj,jk) * tmask(ji,jj,jk)
+                  zah(ji,jj) = zah(ji,jj) + zn2 * ( wslpi(ji,jj,jk) * wslpi(ji,jj,jk)   &
+                     &                            + wslpj(ji,jj,jk) * wslpj(ji,jj,jk) ) * ze3w
+                  zhw(ji,jj) = zhw(ji,jj) + ze3w
+               END DO
+            END DO
+         END DO
+      ENDIF
+
+      DO jj = 2, jpjm1
+         DO ji = fs_2, fs_jpim1   ! vector opt.
+            zfw = MAX( ABS( 2. * omega * SIN( rad * gphit(ji,jj) ) ) , 1.e-10 )
+            ! Rossby radius at w-point taken betwenn 2 km and  40km
+            zRo(ji,jj) = MAX(  2.e3 , MIN( .4 * zn(ji,jj) / zfw, 40.e3 )  )
+            ! Compute aeiw by multiplying Ro^2 and T^-1
+            zaeiw(ji,jj) = zRo(ji,jj) * zRo(ji,jj) * SQRT( zah(ji,jj) / zhw(ji,jj) ) * tmask(ji,jj,1)
+         END DO
+      END DO
+
+      !                                         !==  Bound on eiv coeff.  ==!
+      z1_f20 = 1._wp / (  2._wp * omega * sin( rad * 20._wp )  )
+      DO jj = 2, jpjm1
+         DO ji = fs_2, fs_jpim1   ! vector opt.
+            zzaei = MIN( 1._wp, ABS( ff_t(ji,jj) * z1_f20 ) ) * zaeiw(ji,jj)     ! tropical decrease
+            zaeiw(ji,jj) = MIN( zzaei , paei0 )                                  ! Max value = paei0
+         END DO
+      END DO
+      CALL lbc_lnk( zaeiw(:,:), 'W', 1. )       ! lateral boundary condition
+      !               
+      DO jj = 2, jpjm1                          !== aei at u- and v-points  ==!
+         DO ji = fs_2, fs_jpim1   ! vector opt.
+            paeiu(ji,jj,1) = 0.5_wp * ( zaeiw(ji,jj) + zaeiw(ji+1,jj  ) ) * umask(ji,jj,1)
+            paeiv(ji,jj,1) = 0.5_wp * ( zaeiw(ji,jj) + zaeiw(ji  ,jj+1) ) * vmask(ji,jj,1)
+         END DO 
+      END DO 
+      CALL lbc_lnk_multi( paeiu(:,:,1), 'U', 1. , paeiv(:,:,1), 'V', 1. )      ! lateral boundary condition
+
+      DO jk = 2, jpkm1                          !==  deeper values equal the surface one  ==!
+         paeiu(:,:,jk) = paeiu(:,:,1) * umask(:,:,jk)
+         paeiv(:,:,jk) = paeiv(:,:,1) * vmask(:,:,jk)
+      END DO
+      !  
+   END SUBROUTINE ldf_eiv
+
+
+   SUBROUTINE ldf_eiv_trp( kt, kit000, pun, pvn, pwn, cdtype )
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE ldf_eiv_trp  ***
+      !! 
+      !! ** Purpose :   add to the input ocean transport the contribution of 
+      !!              the eddy induced velocity parametrization.
+      !!
+      !! ** Method  :   The eddy induced transport is computed from a flux stream-
+      !!              function which depends on the slope of iso-neutral surfaces
+      !!              (see ldf_slp). For example, in the i-k plan : 
+      !!                   psi_uw = mk(aeiu) e2u mi(wslpi)   [in m3/s]
+      !!                   Utr_eiv = - dk[psi_uw]
+      !!                   Vtr_eiv = + di[psi_uw]
+      !!                ln_ldfeiv_dia = T : output the associated streamfunction,
+      !!                                    velocity and heat transport (call ldf_eiv_dia)
+      !!
+      !! ** Action  : pun, pvn increased by the eiv transport
+      !!----------------------------------------------------------------------
+      INTEGER                         , INTENT(in   ) ::   kt       ! ocean time-step index
+      INTEGER                         , INTENT(in   ) ::   kit000   ! first time step index
+      CHARACTER(len=3)                , INTENT(in   ) ::   cdtype   ! =TRA or TRC (tracer indicator)
+      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pun      ! in : 3 ocean transport components   [m3/s]
+      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pvn      ! out: 3 ocean transport components   [m3/s]
+      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pwn      ! increased by the eiv                [m3/s]
+      !!
+      INTEGER  ::   ji, jj, jk                 ! dummy loop indices
+      REAL(wp) ::   zuwk, zuwk1, zuwi, zuwi1   ! local scalars
+      REAL(wp) ::   zvwk, zvwk1, zvwj, zvwj1   !   -      -
+      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zpsi_uw, zpsi_vw
+      !!----------------------------------------------------------------------
+      !
+      IF( kt == kit000 )  THEN
+         IF(lwp) WRITE(numout,*)
+         IF(lwp) WRITE(numout,*) 'ldf_eiv_trp : eddy induced advection on ', cdtype,' :'
+         IF(lwp) WRITE(numout,*) '~~~~~~~~~~~   add to velocity fields the eiv component'
+      ENDIF
+
+      
+      zpsi_uw(:,:, 1 ) = 0._wp   ;   zpsi_vw(:,:, 1 ) = 0._wp
+      zpsi_uw(:,:,jpk) = 0._wp   ;   zpsi_vw(:,:,jpk) = 0._wp
+      !
+      DO jk = 2, jpkm1
+         DO jj = 1, jpjm1
+            DO ji = 1, fs_jpim1   ! vector opt.
+               zpsi_uw(ji,jj,jk) = - r1_4 * e2u(ji,jj) * ( wslpi(ji,jj,jk  ) + wslpi(ji+1,jj,jk) )   &
+                  &                                    * ( aeiu (ji,jj,jk-1) + aeiu (ji  ,jj,jk) ) * umask(ji,jj,jk)
+               zpsi_vw(ji,jj,jk) = - r1_4 * e1v(ji,jj) * ( wslpj(ji,jj,jk  ) + wslpj(ji,jj+1,jk) )   &
+                  &                                    * ( aeiv (ji,jj,jk-1) + aeiv (ji,jj  ,jk) ) * vmask(ji,jj,jk)
+            END DO
+         END DO
+      END DO
+      !
+      DO jk = 1, jpkm1
+         DO jj = 1, jpjm1
+            DO ji = 1, fs_jpim1   ! vector opt.               
+               pun(ji,jj,jk) = pun(ji,jj,jk) - ( zpsi_uw(ji,jj,jk) - zpsi_uw(ji,jj,jk+1) )
+               pvn(ji,jj,jk) = pvn(ji,jj,jk) - ( zpsi_vw(ji,jj,jk) - zpsi_vw(ji,jj,jk+1) )
+            END DO
+         END DO
+      END DO
+      DO jk = 1, jpkm1
+         DO jj = 2, jpjm1
+            DO ji = fs_2, fs_jpim1   ! vector opt.
+               pwn(ji,jj,jk) = pwn(ji,jj,jk) + (  zpsi_uw(ji,jj,jk) - zpsi_uw(ji-1,jj  ,jk)   &
+                  &                             + zpsi_vw(ji,jj,jk) - zpsi_vw(ji  ,jj-1,jk) )
+            END DO
+         END DO
+      END DO
+      !
+      !                              ! diagnose the eddy induced velocity and associated heat transport
+      IF( ln_ldfeiv_dia .AND. cdtype == 'TRA' )   CALL ldf_eiv_dia( zpsi_uw, zpsi_vw )
+      !
+    END SUBROUTINE ldf_eiv_trp
+
+
+   SUBROUTINE ldf_eiv_dia( psi_uw, psi_vw )
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE ldf_eiv_dia  ***
+      !!
+      !! ** Purpose :   diagnose the eddy induced velocity and its associated
+      !!              vertically integrated heat transport.
+      !!
+      !! ** Method :
+      !!
+      !!----------------------------------------------------------------------
+      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   psi_uw, psi_vw   ! streamfunction   [m3/s]
+      !
+      INTEGER  ::   ji, jj, jk    ! dummy loop indices
+      REAL(wp) ::   zztmp   ! local scalar
+      REAL(wp), DIMENSION(jpi,jpj)     ::   zw2d   ! 2D workspace
+      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zw3d   ! 3D workspace
+      !!----------------------------------------------------------------------
+      !
+!!gm I don't like this routine....   Crazy  way of doing things, not optimal at all...
+!!gm     to be redesigned....   
+      !                                                  !==  eiv stream function: output  ==!
+      CALL lbc_lnk_multi( psi_uw, 'U', -1. , psi_vw, 'V', -1. )
+      !
+!!gm      CALL iom_put( "psi_eiv_uw", psi_uw )                 ! output
+!!gm      CALL iom_put( "psi_eiv_vw", psi_vw )
+      !
+      !                                                  !==  eiv velocities: calculate and output  ==!
+      !
+      zw3d(:,:,jpk) = 0._wp                                    ! bottom value always 0
+      !
+      DO jk = 1, jpkm1                                         ! e2u e3u u_eiv = -dk[psi_uw]
+         zw3d(:,:,jk) = ( psi_uw(:,:,jk+1) - psi_uw(:,:,jk) ) / ( e2u(:,:) * e3u_n(:,:,jk) )
+      END DO
+      CALL iom_put( "uoce_eiv", zw3d )
+      !
+      DO jk = 1, jpkm1                                         ! e1v e3v v_eiv = -dk[psi_vw]
+         zw3d(:,:,jk) = ( psi_vw(:,:,jk+1) - psi_vw(:,:,jk) ) / ( e1v(:,:) * e3v_n(:,:,jk) )
+      END DO
+      CALL iom_put( "voce_eiv", zw3d )
+      !
+      DO jk = 1, jpkm1                                         ! e1 e2 w_eiv = dk[psix] + dk[psix]
+         DO jj = 2, jpjm1
+            DO ji = fs_2, fs_jpim1  ! vector opt.
+               zw3d(ji,jj,jk) = (  psi_vw(ji,jj,jk) - psi_vw(ji  ,jj-1,jk)    &
+                  &              + psi_uw(ji,jj,jk) - psi_uw(ji-1,jj  ,jk)  ) / e1e2t(ji,jj)
+            END DO
+         END DO
+      END DO
+      CALL lbc_lnk( zw3d, 'T', 1. )      ! lateral boundary condition
+      CALL iom_put( "woce_eiv", zw3d )
+      !
+      !
+      zztmp = 0.5_wp * rau0 * rcp 
+      IF( iom_use('ueiv_heattr') .OR. iom_use('ueiv_heattr3d') ) THEN
+        zw2d(:,:)   = 0._wp 
+        zw3d(:,:,:) = 0._wp 
+        DO jk = 1, jpkm1
+           DO jj = 2, jpjm1
+              DO ji = fs_2, fs_jpim1   ! vector opt.
+                 zw3d(ji,jj,jk) = zw3d(ji,jj,jk) + ( psi_uw(ji,jj,jk+1)      - psi_uw(ji,jj,jk)          )   &
+                    &                            * ( tsn   (ji,jj,jk,jp_tem) + tsn   (ji+1,jj,jk,jp_tem) ) 
+                 zw2d(ji,jj) = zw2d(ji,jj) + zw3d(ji,jj,jk)
+              END DO
+           END DO
+        END DO
+        CALL lbc_lnk( zw2d, 'U', -1. )
+        CALL lbc_lnk( zw3d, 'U', -1. )
+        CALL iom_put( "ueiv_heattr"  , zztmp * zw2d )                  ! heat transport in i-direction
+        CALL iom_put( "ueiv_heattr3d", zztmp * zw3d )                  ! heat transport in i-direction
+      ENDIF
+      zw2d(:,:)   = 0._wp 
+      zw3d(:,:,:) = 0._wp 
+      DO jk = 1, jpkm1
+         DO jj = 2, jpjm1
+            DO ji = fs_2, fs_jpim1   ! vector opt.
+               zw3d(ji,jj,jk) = zw3d(ji,jj,jk) + ( psi_vw(ji,jj,jk+1)      - psi_vw(ji,jj,jk)          )   &
+                  &                            * ( tsn   (ji,jj,jk,jp_tem) + tsn   (ji,jj+1,jk,jp_tem) ) 
+               zw2d(ji,jj) = zw2d(ji,jj) + zw3d(ji,jj,jk)
+            END DO
+         END DO
+      END DO
+      CALL lbc_lnk( zw2d, 'V', -1. )
+      CALL iom_put( "veiv_heattr", zztmp * zw2d )                  !  heat transport in j-direction
+      CALL iom_put( "veiv_heattr", zztmp * zw3d )                  !  heat transport in j-direction
+      !
+      IF( ln_diaptr )  CALL dia_ptr_hst( jp_tem, 'eiv', 0.5 * zw3d )
+      !
+      zztmp = 0.5_wp * 0.5
+      IF( iom_use('ueiv_salttr') .OR. iom_use('ueiv_salttr3d')) THEN
+        zw2d(:,:) = 0._wp 
+        zw3d(:,:,:) = 0._wp 
+        DO jk = 1, jpkm1
+           DO jj = 2, jpjm1
+              DO ji = fs_2, fs_jpim1   ! vector opt.
+                 zw3d(ji,jj,jk) = zw3d(ji,jj,jk) * ( psi_uw(ji,jj,jk+1)      - psi_uw(ji,jj,jk)          )   &
+                    &                            * ( tsn   (ji,jj,jk,jp_sal) + tsn   (ji+1,jj,jk,jp_sal) ) 
+                 zw2d(ji,jj) = zw2d(ji,jj) + zw3d(ji,jj,jk)
+              END DO
+           END DO
+        END DO
+        CALL lbc_lnk( zw2d, 'U', -1. )
+        CALL lbc_lnk( zw3d, 'U', -1. )
+        CALL iom_put( "ueiv_salttr", zztmp * zw2d )                  ! salt transport in i-direction
+        CALL iom_put( "ueiv_salttr3d", zztmp * zw3d )                  ! salt transport in i-direction
+      ENDIF
+      zw2d(:,:) = 0._wp 
+      zw3d(:,:,:) = 0._wp 
+      DO jk = 1, jpkm1
+         DO jj = 2, jpjm1
+            DO ji = fs_2, fs_jpim1   ! vector opt.
+               zw3d(ji,jj,jk) = zw3d(ji,jj,jk) + ( psi_vw(ji,jj,jk+1)      - psi_vw(ji,jj,jk)          )   &
+                  &                            * ( tsn   (ji,jj,jk,jp_sal) + tsn   (ji,jj+1,jk,jp_sal) ) 
+               zw2d(ji,jj) = zw2d(ji,jj) + zw3d(ji,jj,jk)
+            END DO
+         END DO
+      END DO
+      CALL lbc_lnk( zw2d, 'V', -1. )
+      CALL iom_put( "veiv_salttr", zztmp * zw2d )                  !  salt transport in j-direction
+      CALL iom_put( "veiv_salttr", zztmp * zw3d )                  !  salt transport in j-direction
+      !
+      IF( ln_diaptr ) CALL dia_ptr_hst( jp_sal, 'eiv', 0.5 * zw3d )
+      !
+      !
+   END SUBROUTINE ldf_eiv_dia
+
+   !!======================================================================
+END MODULE ldftra
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/ddatetoymdhms.h90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/ddatetoymdhms.h90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/ddatetoymdhms.h90	(revision 9570)
@@ -0,0 +1,43 @@
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO Consortium (2010)
+   !! $Id$
+   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+
+   SUBROUTINE ddatetoymdhms( ddate, kyea, kmon, kday, khou, kmin, ksec )
+      !!----------------------------------------------------------------------
+      !!
+      !!                    *** ROUTINE ddatetoymdhms ***
+      !!
+      !! ** Purpose : Convert YYYYMMDD.hhmmss to components
+      !!
+      !! ** Method  :
+      !!
+      !! ** Action  :
+      !!
+      !! History
+      !!----------------------------------------------------------------------
+      !! * Modules used
+
+      !! * Arguments
+      real(wp), INTENT(IN) :: ddate
+      INTEGER, INTENT(OUT) :: kyea
+      INTEGER, INTENT(OUT) :: kmon
+      INTEGER, INTENT(OUT) :: kday
+      INTEGER, INTENT(OUT) :: khou
+      INTEGER, INTENT(OUT) :: kmin
+      INTEGER, INTENT(OUT) :: ksec
+      !! * Local declarations
+      INTEGER :: iyymmdd
+      INTEGER :: ihhmmss
+      
+      iyymmdd = INT( ddate )
+      ihhmmss = INT( ( ddate - iyymmdd ) * 1000000 )
+      kyea = iyymmdd/10000
+      kmon = iyymmdd / 100 - 100 * kyea
+      kday = MOD( iyymmdd, 100 )
+      khou = ihhmmss/10000
+      kmin = ihhmmss / 100 - 100 * khou
+      ksec = MOD( ihhmmss, 100 )
+      
+   END SUBROUTINE ddatetoymdhms
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/diaobs.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/diaobs.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/diaobs.F90	(revision 9570)
@@ -0,0 +1,1013 @@
+MODULE diaobs
+   !!======================================================================
+   !!                       ***  MODULE diaobs  ***
+   !! Observation diagnostics: Computation of the misfit between data and
+   !!                          their model equivalent 
+   !!======================================================================
+   !! History :  1.0  !  2006-03  (K. Mogensen) Original code
+   !!             -   !  2006-05  (K. Mogensen, A. Weaver) Reformatted
+   !!             -   !  2006-10  (A. Weaver) Cleaning and add controls
+   !!             -   !  2007-03  (K. Mogensen) General handling of profiles
+   !!             -   !  2007-04  (G. Smith) Generalized surface operators
+   !!            2.0  !  2008-10  (M. Valdivieso) obs operator for velocity profiles
+   !!            3.4  !  2014-08  (J. While) observation operator for profiles in all vertical coordinates
+   !!             -   !                      Incorporated SST bias correction  
+   !!            3.6  !  2015-02  (M. Martin) Simplification of namelist and code
+   !!             -   !  2015-08  (M. Martin) Combined surface/profile routines.
+   !!            4.0  !  2017-11  (G. Madec) style only
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   dia_obs_init  : Reading and prepare observations
+   !!   dia_obs       : Compute model equivalent to observations
+   !!   dia_obs_wri   : Write observational diagnostics
+   !!   calc_date     : Compute the date of timestep in YYYYMMDD.HHMMSS format
+   !!   ini_date      : Compute the initial date YYYYMMDD.HHMMSS
+   !!   fin_date      : Compute the final date YYYYMMDD.HHMMSS
+   !!----------------------------------------------------------------------
+   USE par_kind       ! Precision variables
+   USE in_out_manager ! I/O manager
+   USE par_oce        ! ocean parameter
+   USE dom_oce        ! Ocean space and time domain variables
+   USE sbc_oce        ! Sea-ice fraction
+   !
+   USE obs_read_prof  ! Reading and allocation of profile obs
+   USE obs_read_surf  ! Reading and allocation of surface obs
+   USE obs_sstbias    ! Bias correction routine for SST 
+   USE obs_readmdt    ! Reading and allocation of MDT for SLA.
+   USE obs_prep       ! Preparation of obs. (grid search etc).
+   USE obs_oper       ! Observation operators
+   USE obs_write      ! Writing of observation related diagnostics
+   USE obs_grid       ! Grid searching
+   USE obs_read_altbias ! Bias treatment for altimeter
+   USE obs_profiles_def ! Profile data definitions
+   USE obs_surf_def   ! Surface data definitions
+   USE obs_types      ! Definitions for observation types
+   !
+   USE mpp_map        ! MPP mapping
+   USE lib_mpp        ! For ctl_warn/stop
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC dia_obs_init     ! Initialize and read observations
+   PUBLIC dia_obs          ! Compute model equivalent to observations
+   PUBLIC dia_obs_wri      ! Write model equivalent to observations
+   PUBLIC dia_obs_dealloc  ! Deallocate dia_obs data
+   PUBLIC calc_date        ! Compute the date of a timestep
+
+   LOGICAL, PUBLIC :: ln_diaobs          !: Logical switch for the obs operator
+   LOGICAL         :: ln_sstnight        !  Logical switch for night mean SST obs
+   LOGICAL         :: ln_sla_fp_indegs   !  T=> SLA obs footprint size specified in degrees, F=> in metres
+   LOGICAL         :: ln_sst_fp_indegs   !  T=> SST obs footprint size specified in degrees, F=> in metres
+   LOGICAL         :: ln_sss_fp_indegs   !  T=> SSS obs footprint size specified in degrees, F=> in metres
+   LOGICAL         :: ln_sic_fp_indegs   !  T=> sea-ice obs footprint size specified in degrees, F=> in metres
+
+   REAL(wp) ::   rn_sla_avglamscl   ! E/W diameter of SLA observation footprint (metres)
+   REAL(wp) ::   rn_sla_avgphiscl   ! N/S diameter of SLA observation footprint (metres)
+   REAL(wp) ::   rn_sst_avglamscl   ! E/W diameter of SST observation footprint (metres)
+   REAL(wp) ::   rn_sst_avgphiscl   ! N/S diameter of SST observation footprint (metres)
+   REAL(wp) ::   rn_sss_avglamscl   ! E/W diameter of SSS observation footprint (metres)
+   REAL(wp) ::   rn_sss_avgphiscl   ! N/S diameter of SSS observation footprint (metres)
+   REAL(wp) ::   rn_sic_avglamscl   ! E/W diameter of sea-ice observation footprint (metres)
+   REAL(wp) ::   rn_sic_avgphiscl   ! N/S diameter of sea-ice observation footprint (metres)
+
+   INTEGER :: nn_1dint       ! Vertical interpolation method
+   INTEGER :: nn_2dint       ! Default horizontal interpolation method
+   INTEGER :: nn_2dint_sla   ! SLA horizontal interpolation method 
+   INTEGER :: nn_2dint_sst   ! SST horizontal interpolation method 
+   INTEGER :: nn_2dint_sss   ! SSS horizontal interpolation method 
+   INTEGER :: nn_2dint_sic   ! Seaice horizontal interpolation method 
+   INTEGER, DIMENSION(imaxavtypes) ::   nn_profdavtypes   ! Profile data types representing a daily average
+   INTEGER :: nproftypes     ! Number of profile obs types
+   INTEGER :: nsurftypes     ! Number of surface obs types
+   INTEGER , DIMENSION(:), ALLOCATABLE ::   nvarsprof, nvarssurf   ! Number of profile & surface variables
+   INTEGER , DIMENSION(:), ALLOCATABLE ::   nextrprof, nextrsurf   ! Number of profile & surface extra variables
+   INTEGER , DIMENSION(:), ALLOCATABLE ::   n2dintsurf             ! Interpolation option for surface variables
+   REAL(wp), DIMENSION(:), ALLOCATABLE ::   zavglamscl, zavgphiscl ! E/W & N/S diameter of averaging footprint for surface variables
+   LOGICAL , DIMENSION(:), ALLOCATABLE ::   lfpindegs              ! T=> surface obs footprint size specified in degrees, F=> in metres
+   LOGICAL , DIMENSION(:), ALLOCATABLE ::   llnightav              ! Logical for calculating night-time averages
+
+   TYPE(obs_surf), PUBLIC, POINTER, DIMENSION(:) ::   surfdata     !: Initial surface data
+   TYPE(obs_surf), PUBLIC, POINTER, DIMENSION(:) ::   surfdataqc   !: Surface data after quality control
+   TYPE(obs_prof), PUBLIC, POINTER, DIMENSION(:) ::   profdata     !: Initial profile data
+   TYPE(obs_prof), PUBLIC, POINTER, DIMENSION(:) ::   profdataqc   !: Profile data after quality control
+
+   CHARACTER(len=6), PUBLIC, DIMENSION(:), ALLOCATABLE ::   cobstypesprof, cobstypessurf   !: Profile & surface obs types
+
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO Consortium (2010)
+   !! $Id$
+   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE dia_obs_init
+      !!----------------------------------------------------------------------
+      !!                    ***  ROUTINE dia_obs_init  ***
+      !!          
+      !! ** Purpose : Initialize and read observations
+      !!
+      !! ** Method  : Read the namelist and call reading routines
+      !!
+      !! ** Action  : Read the namelist and call reading routines
+      !!
+      !!----------------------------------------------------------------------
+      INTEGER, PARAMETER ::   jpmaxnfiles = 1000    ! Maximum number of files for each obs type
+      INTEGER, DIMENSION(:), ALLOCATABLE ::   ifilesprof, ifilessurf   ! Number of profile & surface files
+      INTEGER :: ios             ! Local integer output status for namelist read
+      INTEGER :: jtype           ! Counter for obs types
+      INTEGER :: jvar            ! Counter for variables
+      INTEGER :: jfile           ! Counter for files
+      INTEGER :: jnumsstbias
+      !
+      CHARACTER(len=128), DIMENSION(jpmaxnfiles) :: &
+         & cn_profbfiles, &      ! T/S profile input filenames
+         & cn_sstfbfiles, &      ! Sea surface temperature input filenames
+         & cn_sssfbfiles, &      ! Sea surface salinity input filenames
+         & cn_slafbfiles, &      ! Sea level anomaly input filenames
+         & cn_sicfbfiles, &      ! Seaice concentration input filenames
+         & cn_velfbfiles, &      ! Velocity profile input filenames
+         & cn_sstbiasfiles      ! SST bias input filenames
+      CHARACTER(LEN=128) :: &
+         & cn_altbiasfile        ! Altimeter bias input filename
+      CHARACTER(len=128), DIMENSION(:,:), ALLOCATABLE :: &
+         & clproffiles, &        ! Profile filenames
+         & clsurffiles           ! Surface filenames
+         !
+      LOGICAL :: ln_t3d          ! Logical switch for temperature profiles
+      LOGICAL :: ln_s3d          ! Logical switch for salinity profiles
+      LOGICAL :: ln_sla          ! Logical switch for sea level anomalies 
+      LOGICAL :: ln_sst          ! Logical switch for sea surface temperature
+      LOGICAL :: ln_sss          ! Logical switch for sea surface salinity
+      LOGICAL :: ln_sic          ! Logical switch for sea ice concentration
+      LOGICAL :: ln_vel3d        ! Logical switch for velocity (u,v) obs
+      LOGICAL :: ln_nea          ! Logical switch to remove obs near land
+      LOGICAL :: ln_altbias      ! Logical switch for altimeter bias
+      LOGICAL :: ln_sstbias      ! Logical switch for bias corection of SST 
+      LOGICAL :: ln_ignmis       ! Logical switch for ignoring missing files
+      LOGICAL :: ln_s_at_t       ! Logical switch to compute model S at T obs
+      LOGICAL :: ln_bound_reject ! Logical to remove obs near boundaries in LAMs.
+      LOGICAL :: llvar1          ! Logical for profile variable 1
+      LOGICAL :: llvar2          ! Logical for profile variable 1
+      LOGICAL, DIMENSION(jpmaxnfiles) :: lmask ! Used for finding number of sstbias files
+      !
+      REAL(dp) :: rn_dobsini     ! Obs window start date YYYYMMDD.HHMMSS
+      REAL(dp) :: rn_dobsend     ! Obs window end date   YYYYMMDD.HHMMSS
+      REAL(wp), DIMENSION(jpi,jpj)     ::   zglam1, zglam2   ! Model longitudes for profile variable 1 & 2
+      REAL(wp), DIMENSION(jpi,jpj)     ::   zgphi1, zgphi2   ! Model latitudes  for profile variable 1 & 2
+      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zmask1, zmask2   ! Model land/sea mask associated with variable 1 & 2
+      !!
+      NAMELIST/namobs/ln_diaobs, ln_t3d, ln_s3d, ln_sla,              &
+         &            ln_sst, ln_sic, ln_sss, ln_vel3d,               &
+         &            ln_altbias, ln_sstbias, ln_nea,                 &
+         &            ln_grid_global, ln_grid_search_lookup,          &
+         &            ln_ignmis, ln_s_at_t, ln_bound_reject,          &
+         &            ln_sstnight,                                    &
+         &            ln_sla_fp_indegs, ln_sst_fp_indegs,             &
+         &            ln_sss_fp_indegs, ln_sic_fp_indegs,             &
+         &            cn_profbfiles, cn_slafbfiles,                   &
+         &            cn_sstfbfiles, cn_sicfbfiles,                   &
+         &            cn_velfbfiles, cn_sssfbfiles,                   &
+         &            cn_sstbiasfiles, cn_altbiasfile,                &
+         &            cn_gridsearchfile, rn_gridsearchres,            &
+         &            rn_dobsini, rn_dobsend,                         &
+         &            rn_sla_avglamscl, rn_sla_avgphiscl,             &
+         &            rn_sst_avglamscl, rn_sst_avgphiscl,             &
+         &            rn_sss_avglamscl, rn_sss_avgphiscl,             &
+         &            rn_sic_avglamscl, rn_sic_avgphiscl,             &
+         &            nn_1dint, nn_2dint,                             &
+         &            nn_2dint_sla, nn_2dint_sst,                     &
+         &            nn_2dint_sss, nn_2dint_sic,                     &
+         &            nn_msshc, rn_mdtcorr, rn_mdtcutoff,             &
+         &            nn_profdavtypes
+      !-----------------------------------------------------------------------
+
+      !-----------------------------------------------------------------------
+      ! Read namelist parameters
+      !-----------------------------------------------------------------------
+      ! Some namelist arrays need initialising
+      cn_profbfiles  (:) = ''
+      cn_slafbfiles  (:) = ''
+      cn_sstfbfiles  (:) = ''
+      cn_sicfbfiles  (:) = ''
+      cn_velfbfiles  (:) = ''
+      cn_sssfbfiles  (:) = ''
+      cn_sstbiasfiles(:) = ''
+      nn_profdavtypes(:) = -1
+
+      CALL ini_date( rn_dobsini )
+      CALL fin_date( rn_dobsend )
+
+      ! Read namelist namobs : control observation diagnostics
+      REWIND( numnam_ref )   ! Namelist namobs in reference namelist
+      READ  ( numnam_ref, namobs, IOSTAT = ios, ERR = 901)
+901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namobs in reference namelist', lwp )
+      REWIND( numnam_cfg )   ! Namelist namobs in configuration namelist
+      READ  ( numnam_cfg, namobs, IOSTAT = ios, ERR = 902 )
+902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namobs in configuration namelist', lwp )
+      IF(lwm) WRITE ( numond, namobs )
+
+      IF( .NOT.ln_diaobs ) THEN
+         IF(lwp) WRITE(numout,*)
+         IF(lwp) WRITE(numout,*) 'dia_obs_init : NO Observation diagnostic used'
+         IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~'
+         RETURN
+      ENDIF
+
+      IF(lwp) THEN
+         WRITE(numout,*)
+         WRITE(numout,*) 'dia_obs_init : Observation diagnostic initialization'
+         WRITE(numout,*) '~~~~~~~~~~~~'
+         WRITE(numout,*) '   Namelist namobs : set observation diagnostic parameters' 
+         WRITE(numout,*) '      Logical switch for T profile observations                ln_t3d = ', ln_t3d
+         WRITE(numout,*) '      Logical switch for S profile observations                ln_s3d = ', ln_s3d
+         WRITE(numout,*) '      Logical switch for SLA observations                      ln_sla = ', ln_sla
+         WRITE(numout,*) '      Logical switch for SST observations                      ln_sst = ', ln_sst
+         WRITE(numout,*) '      Logical switch for Sea Ice observations                  ln_sic = ', ln_sic
+         WRITE(numout,*) '      Logical switch for velocity observations               ln_vel3d = ', ln_vel3d
+         WRITE(numout,*) '      Logical switch for SSS observations                      ln_sss = ', ln_sss
+         WRITE(numout,*) '      Global distribution of observations              ln_grid_global = ', ln_grid_global
+         WRITE(numout,*) '      Logical switch for obs grid search lookup ln_grid_search_lookup = ', ln_grid_search_lookup
+         IF (ln_grid_search_lookup) &
+            WRITE(numout,*) '      Grid search lookup file header                cn_gridsearchfile = ', cn_gridsearchfile
+         WRITE(numout,*) '      Initial date in window YYYYMMDD.HHMMSS               rn_dobsini = ', rn_dobsini
+         WRITE(numout,*) '      Final date in window YYYYMMDD.HHMMSS                 rn_dobsend = ', rn_dobsend
+         WRITE(numout,*) '      Type of vertical interpolation method                  nn_1dint = ', nn_1dint
+         WRITE(numout,*) '      Type of horizontal interpolation method                nn_2dint = ', nn_2dint
+         WRITE(numout,*) '      Rejection of observations near land switch               ln_nea = ', ln_nea
+         WRITE(numout,*) '      Rejection of obs near open bdys                 ln_bound_reject = ', ln_bound_reject
+         WRITE(numout,*) '      MSSH correction scheme                                 nn_msshc = ', nn_msshc
+         WRITE(numout,*) '      MDT  correction                                      rn_mdtcorr = ', rn_mdtcorr
+         WRITE(numout,*) '      MDT cutoff for computed correction                 rn_mdtcutoff = ', rn_mdtcutoff
+         WRITE(numout,*) '      Logical switch for alt bias                          ln_altbias = ', ln_altbias
+         WRITE(numout,*) '      Logical switch for sst bias                          ln_sstbias = ', ln_sstbias
+         WRITE(numout,*) '      Logical switch for ignoring missing files             ln_ignmis = ', ln_ignmis
+         WRITE(numout,*) '      Daily average types                             nn_profdavtypes = ', nn_profdavtypes
+         WRITE(numout,*) '      Logical switch for night-time SST obs               ln_sstnight = ', ln_sstnight
+      ENDIF
+      !-----------------------------------------------------------------------
+      ! Set up list of observation types to be used
+      ! and the files associated with each type
+      !-----------------------------------------------------------------------
+
+      nproftypes = COUNT( (/ln_t3d .OR. ln_s3d, ln_vel3d /) )
+      nsurftypes = COUNT( (/ln_sla, ln_sst, ln_sic, ln_sss /) )
+
+      IF( ln_sstbias ) THEN 
+         lmask(:) = .FALSE. 
+         WHERE( cn_sstbiasfiles(:) /= '' )   lmask(:) = .TRUE. 
+         jnumsstbias = COUNT(lmask) 
+         lmask(:) = .FALSE. 
+      ENDIF      
+
+      IF( nproftypes == 0 .AND. nsurftypes == 0 ) THEN
+         CALL ctl_warn( 'dia_obs_init: ln_diaobs is set to true, but all obs operator logical flags',   &
+            &           ' (ln_t3d, ln_s3d, ln_sla, ln_sst, ln_sic, ln_vel3d)',                          &
+            &           ' are set to .FALSE. so turning off calls to dia_obs'  )
+         ln_diaobs = .FALSE.
+         RETURN
+      ENDIF
+
+      IF( nproftypes > 0 ) THEN
+         !
+         ALLOCATE( cobstypesprof(nproftypes)             )
+         ALLOCATE( ifilesprof   (nproftypes)             )
+         ALLOCATE( clproffiles  (nproftypes,jpmaxnfiles) )
+         !
+         jtype = 0
+         IF( ln_t3d .OR. ln_s3d ) THEN
+            jtype = jtype + 1
+            CALL obs_settypefiles( nproftypes, jpmaxnfiles, jtype, 'prof  ', &
+               &                   cn_profbfiles, ifilesprof, cobstypesprof, clproffiles )
+         ENDIF
+         IF( ln_vel3d ) THEN
+            jtype = jtype + 1
+            CALL obs_settypefiles( nproftypes, jpmaxnfiles, jtype, 'vel   ', &
+               &                   cn_velfbfiles, ifilesprof, cobstypesprof, clproffiles )
+         ENDIF
+         !
+      ENDIF
+
+      IF( nsurftypes > 0 ) THEN
+         !
+         ALLOCATE( cobstypessurf(nsurftypes)             )
+         ALLOCATE( ifilessurf   (nsurftypes)             )
+         ALLOCATE( clsurffiles  (nsurftypes,jpmaxnfiles) )
+         ALLOCATE( n2dintsurf   (nsurftypes)             )
+         ALLOCATE( zavglamscl   (nsurftypes)             )
+         ALLOCATE( zavgphiscl   (nsurftypes)             )
+         ALLOCATE( lfpindegs    (nsurftypes)             )
+         ALLOCATE( llnightav    (nsurftypes)             )
+         !
+         jtype = 0
+         IF( ln_sla ) THEN
+            jtype = jtype + 1
+            CALL obs_settypefiles( nsurftypes, jpmaxnfiles, jtype, 'sla   ', &
+               &                   cn_slafbfiles, ifilessurf, cobstypessurf, clsurffiles )
+            CALL obs_setinterpopts( nsurftypes, jtype, 'sla   ',      &
+               &                  nn_2dint, nn_2dint_sla,             &
+               &                  rn_sla_avglamscl, rn_sla_avgphiscl, &
+               &                  ln_sla_fp_indegs, .FALSE.,          &
+               &                  n2dintsurf, zavglamscl, zavgphiscl, &
+               &                  lfpindegs, llnightav )
+         ENDIF
+         IF( ln_sst ) THEN
+            jtype = jtype + 1
+            CALL obs_settypefiles( nsurftypes, jpmaxnfiles, jtype, 'sst   ', &
+               &                   cn_sstfbfiles, ifilessurf, cobstypessurf, clsurffiles )
+            CALL obs_setinterpopts( nsurftypes, jtype, 'sst   ',      &
+               &                  nn_2dint, nn_2dint_sst,             &
+               &                  rn_sst_avglamscl, rn_sst_avgphiscl, &
+               &                  ln_sst_fp_indegs, ln_sstnight,      &
+               &                  n2dintsurf, zavglamscl, zavgphiscl, &
+               &                  lfpindegs, llnightav )
+         ENDIF
+#if defined key_si3 || defined key_cice
+         IF( ln_sic ) THEN
+            jtype = jtype + 1
+            CALL obs_settypefiles( nsurftypes, jpmaxnfiles, jtype, 'sic   ', &
+               &                   cn_sicfbfiles, ifilessurf, cobstypessurf, clsurffiles )
+            CALL obs_setinterpopts( nsurftypes, jtype, 'sic   ',      &
+               &                  nn_2dint, nn_2dint_sic,             &
+               &                  rn_sic_avglamscl, rn_sic_avgphiscl, &
+               &                  ln_sic_fp_indegs, .FALSE.,          &
+               &                  n2dintsurf, zavglamscl, zavgphiscl, &
+               &                  lfpindegs, llnightav )
+         ENDIF
+#endif
+         IF( ln_sss ) THEN
+            jtype = jtype + 1
+            CALL obs_settypefiles( nsurftypes, jpmaxnfiles, jtype, 'sss   ', &
+               &                   cn_sssfbfiles, ifilessurf, cobstypessurf, clsurffiles )
+            CALL obs_setinterpopts( nsurftypes, jtype, 'sss   ',      &
+               &                  nn_2dint, nn_2dint_sss,             &
+               &                  rn_sss_avglamscl, rn_sss_avgphiscl, &
+               &                  ln_sss_fp_indegs, .FALSE.,          &
+               &                  n2dintsurf, zavglamscl, zavgphiscl, &
+               &                  lfpindegs, llnightav )
+         ENDIF
+         !
+      ENDIF
+
+
+      !-----------------------------------------------------------------------
+      ! Obs operator parameter checking and initialisations
+      !-----------------------------------------------------------------------
+      !
+      IF( ln_vel3d  .AND.  .NOT.ln_grid_global ) THEN
+         CALL ctl_stop( 'Velocity data only works with ln_grid_global=.true.' )
+         RETURN
+      ENDIF
+      !
+      IF( ln_grid_global ) THEN
+         CALL ctl_warn( 'dia_obs_init: ln_grid_global=T may cause memory issues when used with a large number of processors' )
+      ENDIF
+      !
+      IF( nn_1dint < 0  .OR.  nn_1dint > 1 ) THEN
+         CALL ctl_stop('dia_obs_init: Choice of vertical (1D) interpolation method is not available')
+      ENDIF
+      !
+      IF( nn_2dint < 0  .OR.  nn_2dint > 6  ) THEN
+         CALL ctl_stop('dia_obs_init: Choice of horizontal (2D) interpolation method is not available')
+      ENDIF
+      !
+      CALL obs_typ_init
+      IF( ln_grid_global )   CALL mppmap_init
+      !
+      CALL obs_grid_setup( )
+
+      !-----------------------------------------------------------------------
+      ! Depending on switches read the various observation types
+      !-----------------------------------------------------------------------
+      !
+      IF( nproftypes > 0 ) THEN
+         !
+         ALLOCATE( profdata  (nproftypes) , nvarsprof (nproftypes) )
+         ALLOCATE( profdataqc(nproftypes) , nextrprof (nproftypes) )
+         !
+         DO jtype = 1, nproftypes
+            !
+            nvarsprof(jtype) = 2
+            IF ( TRIM(cobstypesprof(jtype)) == 'prof' ) THEN
+               nextrprof(jtype) = 1
+               llvar1 = ln_t3d
+               llvar2 = ln_s3d
+               zglam1 = glamt
+               zgphi1 = gphit
+               zmask1 = tmask
+               zglam2 = glamt
+               zgphi2 = gphit
+               zmask2 = tmask
+            ENDIF
+            IF ( TRIM(cobstypesprof(jtype)) == 'vel' )  THEN
+               nextrprof(jtype) = 2
+               llvar1 = ln_vel3d
+               llvar2 = ln_vel3d
+               zglam1 = glamu
+               zgphi1 = gphiu
+               zmask1 = umask
+               zglam2 = glamv
+               zgphi2 = gphiv
+               zmask2 = vmask
+            ENDIF
+            !
+            ! Read in profile or profile obs types
+            CALL obs_rea_prof( profdata(jtype), ifilesprof(jtype),       &
+               &               clproffiles(jtype,1:ifilesprof(jtype)), &
+               &               nvarsprof(jtype), nextrprof(jtype), nitend-nit000+2, &
+               &               rn_dobsini, rn_dobsend, llvar1, llvar2, &
+               &               ln_ignmis, ln_s_at_t, .FALSE., &
+               &               kdailyavtypes = nn_profdavtypes )
+               !
+            DO jvar = 1, nvarsprof(jtype)
+               CALL obs_prof_staend( profdata(jtype), jvar )
+            END DO
+            !
+            CALL obs_pre_prof( profdata(jtype), profdataqc(jtype), &
+               &               llvar1, llvar2, &
+               &               jpi, jpj, jpk, &
+               &               zmask1, zglam1, zgphi1, zmask2, zglam2, zgphi2,  &
+               &               ln_nea, ln_bound_reject, &
+               &               kdailyavtypes = nn_profdavtypes )
+         END DO
+         !
+         DEALLOCATE( ifilesprof, clproffiles )
+         !
+      ENDIF
+      !
+      IF( nsurftypes > 0 ) THEN
+         !
+         ALLOCATE( surfdata  (nsurftypes) , nvarssurf(nsurftypes) )
+         ALLOCATE( surfdataqc(nsurftypes) , nextrsurf(nsurftypes) )
+         !
+         DO jtype = 1, nsurftypes
+            !
+            nvarssurf(jtype) = 1
+            nextrsurf(jtype) = 0
+            llnightav(jtype) = .FALSE.
+            IF( TRIM(cobstypessurf(jtype)) == 'sla' )   nextrsurf(jtype) = 2
+            IF( TRIM(cobstypessurf(jtype)) == 'sst' )   llnightav(jtype) = ln_sstnight
+            !
+            ! Read in surface obs types
+            CALL obs_rea_surf( surfdata(jtype), ifilessurf(jtype), &
+               &               clsurffiles(jtype,1:ifilessurf(jtype)), &
+               &               nvarssurf(jtype), nextrsurf(jtype), nitend-nit000+2, &
+               &               rn_dobsini, rn_dobsend, ln_ignmis, .FALSE., llnightav(jtype) )
+               !
+            CALL obs_pre_surf( surfdata(jtype), surfdataqc(jtype), ln_nea, ln_bound_reject )
+            !
+            IF( TRIM(cobstypessurf(jtype)) == 'sla' ) THEN
+               CALL obs_rea_mdt( surfdataqc(jtype), n2dintsurf(jtype) )
+               IF( ln_altbias )   &
+                  & CALL obs_rea_altbias ( surfdataqc(jtype), n2dintsurf(jtype), cn_altbiasfile )
+            ENDIF
+            !
+            IF( TRIM(cobstypessurf(jtype)) == 'sst' .AND. ln_sstbias ) THEN
+               jnumsstbias = 0
+               DO jfile = 1, jpmaxnfiles
+                  IF( TRIM(cn_sstbiasfiles(jfile)) /= '' )   jnumsstbias = jnumsstbias + 1
+               END DO
+               IF( jnumsstbias == 0 )   CALL ctl_stop("ln_sstbias set but no bias files to read in")    
+               !
+               CALL obs_app_sstbias( surfdataqc(jtype), n2dintsurf(jtype)             ,   & 
+                  &                  jnumsstbias      , cn_sstbiasfiles(1:jnumsstbias) ) 
+            ENDIF
+         END DO
+         !
+         DEALLOCATE( ifilessurf, clsurffiles )
+         !
+      ENDIF
+      !
+   END SUBROUTINE dia_obs_init
+
+
+   SUBROUTINE dia_obs( kstp )
+      !!----------------------------------------------------------------------
+      !!                    ***  ROUTINE dia_obs  ***
+      !!          
+      !! ** Purpose : Call the observation operators on each time step
+      !!
+      !! ** Method  : Call the observation operators on each time step to
+      !!              compute the model equivalent of the following data:
+      !!               - Profile data, currently T/S or U/V
+      !!               - Surface data, currently SST, SLA or sea-ice concentration.
+      !!
+      !! ** Action  :
+      !!----------------------------------------------------------------------
+      USE dom_oce, ONLY : gdept_n, gdept_1d   ! Ocean space and time domain variables
+      USE phycst , ONLY : rday                ! Physical constants
+      USE oce    , ONLY : tsn, un, vn, sshn   ! Ocean dynamics and tracers variables
+      USE phycst , ONLY : rday                ! Physical constants
+#if defined  key_si3
+      USE ice    , ONLY : at_i                ! LIM3 Ice model variables
+#endif
+#if defined key_cice
+      USE sbc_oce, ONLY : fr_i     ! ice fraction
+#endif
+
+      IMPLICIT NONE
+
+      !! * Arguments
+      INTEGER, INTENT(IN) :: kstp  ! Current timestep
+      !! * Local declarations
+      INTEGER :: idaystp           ! Number of timesteps per day
+      INTEGER :: jtype             ! Data loop variable
+      INTEGER :: jvar              ! Variable number
+      INTEGER :: ji, jj            ! Loop counters
+      REAL(wp), DIMENSION(jpi,jpj,jpk) :: &
+         & zprofvar1, &            ! Model values for 1st variable in a prof ob
+         & zprofvar2               ! Model values for 2nd variable in a prof ob
+      REAL(wp), DIMENSION(jpi,jpj,jpk) :: &
+         & zprofmask1, &           ! Mask associated with zprofvar1
+         & zprofmask2              ! Mask associated with zprofvar2
+      REAL(wp), DIMENSION(jpi,jpj) :: &
+         & zsurfvar, &             ! Model values equivalent to surface ob.
+         & zsurfmask               ! Mask associated with surface variable
+      REAL(wp), DIMENSION(jpi,jpj) :: &
+         & zglam1,    &            ! Model longitudes for prof variable 1
+         & zglam2,    &            ! Model longitudes for prof variable 2
+         & zgphi1,    &            ! Model latitudes for prof variable 1
+         & zgphi2                  ! Model latitudes for prof variable 2
+
+      !-----------------------------------------------------------------------
+
+      IF(lwp) THEN
+         WRITE(numout,*)
+         WRITE(numout,*) 'dia_obs : Call the observation operators', kstp
+         WRITE(numout,*) '~~~~~~~'
+      ENDIF
+
+      idaystp = NINT( rday / rdt )
+
+      !-----------------------------------------------------------------------
+      ! Call the profile and surface observation operators
+      !-----------------------------------------------------------------------
+
+      IF ( nproftypes > 0 ) THEN
+
+         DO jtype = 1, nproftypes
+
+            SELECT CASE ( TRIM(cobstypesprof(jtype)) )
+            CASE('prof')
+               zprofvar1(:,:,:) = tsn(:,:,:,jp_tem)
+               zprofvar2(:,:,:) = tsn(:,:,:,jp_sal)
+               zprofmask1(:,:,:) = tmask(:,:,:)
+               zprofmask2(:,:,:) = tmask(:,:,:)
+               zglam1(:,:) = glamt(:,:)
+               zglam2(:,:) = glamt(:,:)
+               zgphi1(:,:) = gphit(:,:)
+               zgphi2(:,:) = gphit(:,:)
+            CASE('vel')
+               zprofvar1(:,:,:) = un(:,:,:)
+               zprofvar2(:,:,:) = vn(:,:,:)
+               zprofmask1(:,:,:) = umask(:,:,:)
+               zprofmask2(:,:,:) = vmask(:,:,:)
+               zglam1(:,:) = glamu(:,:)
+               zglam2(:,:) = glamv(:,:)
+               zgphi1(:,:) = gphiu(:,:)
+               zgphi2(:,:) = gphiv(:,:)
+            CASE DEFAULT
+               CALL ctl_stop( 'Unknown profile observation type '//TRIM(cobstypesprof(jtype))//' in dia_obs' )
+            END SELECT
+
+            CALL obs_prof_opt( profdataqc(jtype), kstp, jpi, jpj, jpk,  &
+               &               nit000, idaystp,                         &
+               &               zprofvar1, zprofvar2,                    &
+               &               gdept_n(:,:,:), gdepw_n(:,:,:),            & 
+               &               zprofmask1, zprofmask2,                  &
+               &               zglam1, zglam2, zgphi1, zgphi2,          &
+               &               nn_1dint, nn_2dint,                      &
+               &               kdailyavtypes = nn_profdavtypes )
+
+         END DO
+
+      ENDIF
+
+      IF ( nsurftypes > 0 ) THEN
+
+         DO jtype = 1, nsurftypes
+
+            !Defaults which might be changed
+            zsurfmask(:,:) = tmask(:,:,1)
+
+            SELECT CASE ( TRIM(cobstypessurf(jtype)) )
+            CASE('sst')
+               zsurfvar(:,:) = tsn(:,:,1,jp_tem)
+            CASE('sla')
+               zsurfvar(:,:) = sshn(:,:)
+            CASE('sss')
+               zsurfvar(:,:) = tsn(:,:,1,jp_sal)
+            CASE('sic')
+               IF ( kstp == 0 ) THEN
+                  IF ( lwp .AND. surfdataqc(jtype)%nsstpmpp(1) > 0 ) THEN
+                     CALL ctl_warn( 'Sea-ice not initialised on zeroth '// &
+                        &           'time-step but some obs are valid then.' )
+                     WRITE(numout,*)surfdataqc(jtype)%nsstpmpp(1), &
+                        &           ' sea-ice obs will be missed'
+                  ENDIF
+                  surfdataqc(jtype)%nsurfup = surfdataqc(jtype)%nsurfup + &
+                     &                        surfdataqc(jtype)%nsstp(1)
+                  CYCLE
+               ELSE
+#if defined key_cice || defined key_si3
+                  zsurfvar(:,:) = fr_i(:,:)
+#else
+                  CALL ctl_stop( ' Trying to run sea-ice observation operator', &
+                     &           ' but no sea-ice model appears to have been defined' )
+#endif
+               ENDIF
+
+            END SELECT
+
+            CALL obs_surf_opt( surfdataqc(jtype), kstp, jpi, jpj,       &
+               &               nit000, idaystp, zsurfvar, zsurfmask,    &
+               &               n2dintsurf(jtype), llnightav(jtype),     &
+               &               zavglamscl(jtype), zavgphiscl(jtype),     &
+               &               lfpindegs(jtype) )
+
+         END DO
+
+      ENDIF
+
+   END SUBROUTINE dia_obs
+
+   SUBROUTINE dia_obs_wri
+      !!----------------------------------------------------------------------
+      !!                    ***  ROUTINE dia_obs_wri  ***
+      !!          
+      !! ** Purpose : Call observation diagnostic output routines
+      !!
+      !! ** Method  : Call observation diagnostic output routines
+      !!
+      !! ** Action  :
+      !!
+      !! History :
+      !!        !  06-03  (K. Mogensen) Original code
+      !!        !  06-05  (K. Mogensen) Reformatted
+      !!        !  06-10  (A. Weaver) Cleaning
+      !!        !  07-03  (K. Mogensen) General handling of profiles
+      !!        !  08-09  (M. Valdivieso) Velocity component (U,V) profiles
+      !!        !  15-08  (M. Martin) Combined writing for prof and surf types
+      !!----------------------------------------------------------------------
+      !! * Modules used
+      USE obs_rot_vel          ! Rotation of velocities
+
+      IMPLICIT NONE
+
+      !! * Local declarations
+      INTEGER :: jtype                    ! Data set loop variable
+      INTEGER :: jo, jvar, jk
+      REAL(wp), DIMENSION(:), ALLOCATABLE :: &
+         & zu, &
+         & zv
+
+      !-----------------------------------------------------------------------
+      ! Depending on switches call various observation output routines
+      !-----------------------------------------------------------------------
+
+      IF ( nproftypes > 0 ) THEN
+
+         DO jtype = 1, nproftypes
+
+            IF ( TRIM(cobstypesprof(jtype)) == 'vel' ) THEN
+
+               ! For velocity data, rotate the model velocities to N/S, E/W
+               ! using the compressed data structure.
+               ALLOCATE( &
+                  & zu(profdataqc(jtype)%nvprot(1)), &
+                  & zv(profdataqc(jtype)%nvprot(2))  &
+                  & )
+
+               CALL obs_rotvel( profdataqc(jtype), nn_2dint, zu, zv )
+
+               DO jo = 1, profdataqc(jtype)%nprof
+                  DO jvar = 1, 2
+                     DO jk = profdataqc(jtype)%npvsta(jo,jvar), profdataqc(jtype)%npvend(jo,jvar)
+
+                        IF ( jvar == 1 ) THEN
+                           profdataqc(jtype)%var(jvar)%vmod(jk) = zu(jk)
+                        ELSE
+                           profdataqc(jtype)%var(jvar)%vmod(jk) = zv(jk)
+                        ENDIF
+
+                     END DO
+                  END DO
+               END DO
+
+               DEALLOCATE( zu )
+               DEALLOCATE( zv )
+
+            END IF
+
+            CALL obs_prof_decompress( profdataqc(jtype), &
+               &                      profdata(jtype), .TRUE., numout )
+
+            CALL obs_wri_prof( profdata(jtype) )
+
+         END DO
+
+      ENDIF
+
+      IF ( nsurftypes > 0 ) THEN
+
+         DO jtype = 1, nsurftypes
+
+            CALL obs_surf_decompress( surfdataqc(jtype), &
+               &                      surfdata(jtype), .TRUE., numout )
+
+            CALL obs_wri_surf( surfdata(jtype) )
+
+         END DO
+
+      ENDIF
+
+   END SUBROUTINE dia_obs_wri
+
+   SUBROUTINE dia_obs_dealloc
+      IMPLICIT NONE
+      !!----------------------------------------------------------------------
+      !!                    *** ROUTINE dia_obs_dealloc ***
+      !!
+      !!  ** Purpose : To deallocate data to enable the obs_oper online loop.
+      !!               Specifically: dia_obs_init --> dia_obs --> dia_obs_wri
+      !!
+      !!  ** Method : Clean up various arrays left behind by the obs_oper.
+      !!
+      !!  ** Action :
+      !!
+      !!----------------------------------------------------------------------
+      ! obs_grid deallocation
+      CALL obs_grid_deallocate
+
+      ! diaobs deallocation
+      IF ( nproftypes > 0 ) &
+         &   DEALLOCATE( cobstypesprof, profdata, profdataqc, nvarsprof, nextrprof )
+
+      IF ( nsurftypes > 0 ) &
+         &   DEALLOCATE( cobstypessurf, surfdata, surfdataqc, nvarssurf, nextrsurf, &
+         &               n2dintsurf, zavglamscl, zavgphiscl, lfpindegs, llnightav )
+
+   END SUBROUTINE dia_obs_dealloc
+
+   SUBROUTINE calc_date( kstp, ddobs )
+      !!----------------------------------------------------------------------
+      !!                    ***  ROUTINE calc_date  ***
+      !!          
+      !! ** Purpose : Get date in double precision YYYYMMDD.HHMMSS format
+      !!
+      !! ** Method  : Get date in double precision YYYYMMDD.HHMMSS format
+      !!
+      !! ** Action  : Get date in double precision YYYYMMDD.HHMMSS format
+      !!
+      !! ** Action  : Get initial date in double precision YYYYMMDD.HHMMSS format
+      !!
+      !! History :
+      !!        !  06-03  (K. Mogensen)  Original code
+      !!        !  06-05  (K. Mogensen)  Reformatted
+      !!        !  06-10  (A. Weaver) Cleaning
+      !!        !  06-10  (G. Smith) Calculates initial date the same as method for final date
+      !!        !  10-05  (D. Lea) Update to month length calculation for NEMO vn3.2
+      !!        !  2014-09  (D. Lea) New generic routine now deals with arbitrary initial time of day
+      !!----------------------------------------------------------------------
+      USE phycst, ONLY : &            ! Physical constants
+         & rday
+      USE dom_oce, ONLY : &           ! Ocean space and time domain variables
+         & rdt
+
+      IMPLICIT NONE
+
+      !! * Arguments
+      REAL(KIND=dp), INTENT(OUT) :: ddobs                        ! Date in YYYYMMDD.HHMMSS
+      INTEGER :: kstp
+
+      !! * Local declarations
+      INTEGER :: iyea        ! date - (year, month, day, hour, minute)
+      INTEGER :: imon
+      INTEGER :: iday
+      INTEGER :: ihou
+      INTEGER :: imin
+      INTEGER :: imday       ! Number of days in month.
+      REAL(wp) :: zdayfrc    ! Fraction of day
+
+      INTEGER, DIMENSION(12) ::   imonth_len    !: length in days of the months of the current year
+
+      !!----------------------------------------------------------------------
+      !! Initial date initialization (year, month, day, hour, minute)
+      !!----------------------------------------------------------------------
+      iyea =   ndate0 / 10000
+      imon = ( ndate0 - iyea * 10000 ) / 100
+      iday =   ndate0 - iyea * 10000 - imon * 100
+      ihou =   nn_time0 / 100
+      imin = ( nn_time0 - ihou * 100 ) 
+
+      !!----------------------------------------------------------------------
+      !! Compute number of days + number of hours + min since initial time
+      !!----------------------------------------------------------------------
+      zdayfrc = kstp * rdt / rday
+      zdayfrc = zdayfrc - aint(zdayfrc)
+      imin = imin + int( zdayfrc * 24 * 60 ) 
+      DO WHILE (imin >= 60) 
+        imin=imin-60
+        ihou=ihou+1
+      END DO
+      DO WHILE (ihou >= 24)
+        ihou=ihou-24
+        iday=iday+1
+      END DO 
+      iday = iday + kstp * rdt / rday 
+
+      !-----------------------------------------------------------------------
+      ! Convert number of days (iday) into a real date
+      !----------------------------------------------------------------------
+
+      CALL calc_month_len( iyea, imonth_len )
+
+      DO WHILE ( iday > imonth_len(imon) )
+         iday = iday - imonth_len(imon)
+         imon = imon + 1 
+         IF ( imon > 12 ) THEN
+            imon = 1
+            iyea = iyea + 1
+            CALL calc_month_len( iyea, imonth_len )  ! update month lengths
+         ENDIF
+      END DO
+
+      !----------------------------------------------------------------------
+      ! Convert it into YYYYMMDD.HHMMSS format.
+      !----------------------------------------------------------------------
+      ddobs = iyea * 10000_dp + imon * 100_dp + &
+         &    iday + ihou * 0.01_dp + imin * 0.0001_dp
+
+   END SUBROUTINE calc_date
+
+   SUBROUTINE ini_date( ddobsini )
+      !!----------------------------------------------------------------------
+      !!                    ***  ROUTINE ini_date  ***
+      !!          
+      !! ** Purpose : Get initial date in double precision YYYYMMDD.HHMMSS format
+      !!
+      !! ** Method  : 
+      !!
+      !! ** Action  : 
+      !!
+      !! History :
+      !!        !  06-03  (K. Mogensen)  Original code
+      !!        !  06-05  (K. Mogensen)  Reformatted
+      !!        !  06-10  (A. Weaver) Cleaning
+      !!        !  10-05  (D. Lea) Update to month length calculation for NEMO vn3.2
+      !!        !  2014-09  (D. Lea) Change to call generic routine calc_date
+      !!----------------------------------------------------------------------
+
+      IMPLICIT NONE
+
+      !! * Arguments
+      REAL(KIND=dp), INTENT(OUT) :: ddobsini                   ! Initial date in YYYYMMDD.HHMMSS
+
+      CALL calc_date( nit000 - 1, ddobsini )
+
+   END SUBROUTINE ini_date
+
+   SUBROUTINE fin_date( ddobsfin )
+      !!----------------------------------------------------------------------
+      !!                    ***  ROUTINE fin_date  ***
+      !!          
+      !! ** Purpose : Get final date in double precision YYYYMMDD.HHMMSS format
+      !!
+      !! ** Method  : 
+      !!
+      !! ** Action  : 
+      !!
+      !! History :
+      !!        !  06-03  (K. Mogensen)  Original code
+      !!        !  06-05  (K. Mogensen)  Reformatted
+      !!        !  06-10  (A. Weaver) Cleaning
+      !!        !  10-05  (D. Lea) Update to month length calculation for NEMO vn3.2
+      !!        !  2014-09  (D. Lea) Change to call generic routine calc_date
+      !!----------------------------------------------------------------------
+
+      IMPLICIT NONE
+
+      !! * Arguments
+      REAL(dp), INTENT(OUT) :: ddobsfin ! Final date in YYYYMMDD.HHMMSS
+
+      CALL calc_date( nitend, ddobsfin )
+
+   END SUBROUTINE fin_date
+   
+    SUBROUTINE obs_settypefiles( ntypes, jpmaxnfiles, jtype, ctypein, &
+       &                         cfilestype, ifiles, cobstypes, cfiles )
+
+    INTEGER, INTENT(IN) :: ntypes      ! Total number of obs types
+    INTEGER, INTENT(IN) :: jpmaxnfiles ! Maximum number of files allowed for each type
+    INTEGER, INTENT(IN) :: jtype       ! Index of the current type of obs
+    INTEGER, DIMENSION(ntypes), INTENT(INOUT) :: &
+       &                   ifiles      ! Out appended number of files for this type
+
+    CHARACTER(len=6), INTENT(IN) :: ctypein 
+    CHARACTER(len=128), DIMENSION(jpmaxnfiles), INTENT(IN) :: &
+       &                   cfilestype  ! In list of files for this obs type
+    CHARACTER(len=6), DIMENSION(ntypes), INTENT(INOUT) :: &
+       &                   cobstypes   ! Out appended list of obs types
+    CHARACTER(len=128), DIMENSION(ntypes, jpmaxnfiles), INTENT(INOUT) :: &
+       &                   cfiles      ! Out appended list of files for all types
+
+    !Local variables
+    INTEGER :: jfile
+
+    cfiles(jtype,:) = cfilestype(:)
+    cobstypes(jtype) = ctypein
+    ifiles(jtype) = 0
+    DO jfile = 1, jpmaxnfiles
+       IF ( trim(cfiles(jtype,jfile)) /= '' ) &
+                 ifiles(jtype) = ifiles(jtype) + 1
+    END DO
+
+    IF ( ifiles(jtype) == 0 ) THEN
+         CALL ctl_stop( 'Logical for observation type '//TRIM(ctypein)//   &
+            &           ' set to true but no files available to read' )
+    ENDIF
+
+    IF(lwp) THEN    
+       WRITE(numout,*) '             '//cobstypes(jtype)//' input observation file names:'
+       DO jfile = 1, ifiles(jtype)
+          WRITE(numout,*) '                '//TRIM(cfiles(jtype,jfile))
+       END DO
+    ENDIF
+
+    END SUBROUTINE obs_settypefiles
+
+    SUBROUTINE obs_setinterpopts( ntypes, jtype, ctypein,             &
+               &                  n2dint_default, n2dint_type,        &
+               &                  zavglamscl_type, zavgphiscl_type,   &
+               &                  lfp_indegs_type, lavnight_type,     &
+               &                  n2dint, zavglamscl, zavgphiscl,     &
+               &                  lfpindegs, lavnight )
+
+    INTEGER, INTENT(IN)  :: ntypes             ! Total number of obs types
+    INTEGER, INTENT(IN)  :: jtype              ! Index of the current type of obs
+    INTEGER, INTENT(IN)  :: n2dint_default     ! Default option for interpolation type
+    INTEGER, INTENT(IN)  :: n2dint_type        ! Option for interpolation type
+    REAL(wp), INTENT(IN) :: &
+       &                    zavglamscl_type, & !E/W diameter of obs footprint for this type
+       &                    zavgphiscl_type    !N/S diameter of obs footprint for this type
+    LOGICAL, INTENT(IN)  :: lfp_indegs_type    !T=> footprint in degrees, F=> in metres
+    LOGICAL, INTENT(IN)  :: lavnight_type      !T=> obs represent night time average
+    CHARACTER(len=6), INTENT(IN) :: ctypein 
+
+    INTEGER, DIMENSION(ntypes), INTENT(INOUT) :: &
+       &                    n2dint 
+    REAL(wp), DIMENSION(ntypes), INTENT(INOUT) :: &
+       &                    zavglamscl, zavgphiscl
+    LOGICAL, DIMENSION(ntypes), INTENT(INOUT) :: &
+       &                    lfpindegs, lavnight
+
+    lavnight(jtype) = lavnight_type
+
+    IF ( (n2dint_type >= 1) .AND. (n2dint_type <= 6) ) THEN
+       n2dint(jtype) = n2dint_type
+    ELSE
+       n2dint(jtype) = n2dint_default
+    ENDIF
+
+    ! For averaging observation footprints set options for size of footprint 
+    IF ( (n2dint(jtype) > 4) .AND. (n2dint(jtype) <= 6) ) THEN
+       IF ( zavglamscl_type > 0._wp ) THEN
+          zavglamscl(jtype) = zavglamscl_type
+       ELSE
+          CALL ctl_stop( 'Incorrect value set for averaging footprint '// &
+                         'scale (zavglamscl) for observation type '//TRIM(ctypein) )      
+       ENDIF
+
+       IF ( zavgphiscl_type > 0._wp ) THEN
+          zavgphiscl(jtype) = zavgphiscl_type
+       ELSE
+          CALL ctl_stop( 'Incorrect value set for averaging footprint '// &
+                         'scale (zavgphiscl) for observation type '//TRIM(ctypein) )      
+       ENDIF
+
+       lfpindegs(jtype) = lfp_indegs_type 
+
+    ENDIF
+
+    ! Write out info 
+    IF(lwp) THEN
+       IF ( n2dint(jtype) <= 4 ) THEN
+          WRITE(numout,*) '             '//TRIM(ctypein)// &
+             &            ' model counterparts will be interpolated horizontally'
+       ELSE IF ( n2dint(jtype) <= 6 ) THEN
+          WRITE(numout,*) '             '//TRIM(ctypein)// &
+             &            ' model counterparts will be averaged horizontally'
+          WRITE(numout,*) '             '//'    with E/W scale: ',zavglamscl(jtype)
+          WRITE(numout,*) '             '//'    with N/S scale: ',zavgphiscl(jtype)
+          IF ( lfpindegs(jtype) ) THEN
+              WRITE(numout,*) '             '//'    (in degrees)'
+          ELSE
+              WRITE(numout,*) '             '//'    (in metres)'
+          ENDIF
+       ENDIF
+    ENDIF
+
+    END SUBROUTINE obs_setinterpopts
+
+END MODULE diaobs
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/find_obs_proc.h90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/find_obs_proc.h90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/find_obs_proc.h90	(revision 9570)
@@ -0,0 +1,60 @@
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO Consortium (2010)
+   !! $Id$
+   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+
+   SUBROUTINE find_obs_proc(kldi,klei,kldj,klej,kmyproc,kobsp,kobsi,kobsj,kno)
+      !!----------------------------------------------------------------------
+      !!               ***  ROUTINE find_obs_proc ***
+      !!          
+      !! ** Purpose : From the array kobsp containing the results of the grid
+      !!              grid search on each processor the processor return a
+      !!              decision of which processors should hold the observation.
+      !!
+      !! ** Method : Use i and j and halo regions to decide which processor to 
+      !!             put ob in. Intended to avoid the mpp calls required by
+      !!             obs_mpp_find_obs_proc
+      !!
+      !! History : 
+      !!! 03-08  (D. Lea)  Original code
+      !!-----------------------------------------------------------------------
+
+      !! * Arguments
+
+      INTEGER, INTENT(IN) :: kldi               ! Start of inner domain in i
+      INTEGER, INTENT(IN) :: klei               ! End of inner domain in i
+      INTEGER, INTENT(IN) :: kldj               ! Start of inner domain in j
+      INTEGER, INTENT(IN) :: klej               ! End of inner domain in j
+
+      INTEGER, INTENT(IN) :: kmyproc
+      INTEGER, INTENT(IN) :: kno
+
+      INTEGER, DIMENSION(kno), INTENT(IN) :: kobsi
+      INTEGER, DIMENSION(kno), INTENT(IN) :: kobsj
+      INTEGER, DIMENSION(kno), INTENT(INOUT) :: kobsp
+      
+      !! * local variables
+      INTEGER :: &
+         & ji
+          
+      ! first and last indoor i- and j-indexes      kldi, klei,   kldj, klej
+      ! exclude any obs in the bottom-left overlap region
+      ! also any obs outside to whole region (defined by nlci and nlcj)
+      ! I am assuming that kobsp does not need to be the correct processor 
+      ! number
+      
+      DO ji = 1, kno
+         IF (kobsi(ji) < kldi .OR. kobsj(ji) < kldj &
+            .OR. kobsi(ji) > klei  .OR. kobsj(ji) > klej) THEN
+            IF (lwp .AND. kobsp(ji) /= -1) WRITE(numout,*) &
+               & 'kobs: ',kobsi(ji), kobsj(ji), kobsp(ji)
+            kobsp(ji)=1000000
+         ENDIF
+      END DO
+
+      ! Ensure that observations not in processor are masked
+
+      WHERE(kobsp(:) /= kmyproc) kobsp(:)=1000000
+
+   END SUBROUTINE find_obs_proc
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/greg2jul.h90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/greg2jul.h90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/greg2jul.h90	(revision 9570)
@@ -0,0 +1,89 @@
+   SUBROUTINE greg2jul( ksec, kmin, khour, kday, kmonth, kyear, pjulian, &
+      &                 krefdate )
+      !!-----------------------------------------------------------------------
+      !!
+      !!                     ***  ROUTINE greg2jul  ***
+      !!
+      !! ** Purpose : Produce the time relative to the current date and time.
+      !!
+      !! ** Method  : The units are days, so hours and minutes transform to
+      !!              fractions of a day. 
+      !!
+      !!              Reference date : 19500101
+      !! ** Action  :
+      !!
+      !! History :
+      !!      ! 06-04  (A. Vidard) Original
+      !!      ! 06-04  (A. Vidard) Reformatted
+      !!      ! 06-10  (A. Weaver) Cleanup
+      !!-----------------------------------------------------------------------
+
+      ! * Arguments
+      INTEGER, INTENT(IN) :: &
+         & ksec,   &
+         & kmin,   &
+         & khour,  & 
+         & kday,   &
+         & kmonth, & 
+         & kyear
+      REAL(KIND=dp), INTENT(OUT) :: &
+         & pjulian
+      INTEGER, INTENT(IN), OPTIONAL :: &
+         & krefdate
+
+      !! * Local declarations
+      INTEGER, PARAMETER :: &
+         & jpgreg = 15 + 31 * ( 10 + 12 * 1582 ), &     ! Gregorian calendar introduction date
+         & jporef = 2433283,                      &     ! Julian reference date: 19500101
+         & jparef = 2415021,                      &     ! Julian reference date: 19000101
+         & jpgref = 2299161                             ! Julian reference date start of Gregorian calender
+      INTEGER :: &
+         & ija,     &
+         & ijy,     &
+         & ijm,     &
+         & ijultmp, &
+         & ijyear,  &
+         & iref
+      CHARACTER(len=200) :: &
+         & cerr
+
+      IF ( PRESENT( krefdate ) ) THEN
+         SELECT CASE ( krefdate )
+
+         CASE( 0 ) 
+            iref = jpgref
+
+         CASE( 19500101 )
+            iref = jporef
+
+         CASE( 19000101 )
+            iref = jparef
+
+         CASE DEFAULT
+            WRITE(cerr,'(A,I8.8)')'greg2jul: Unknown krefdate:', krefdate
+            CALL ctl_stop( cerr )
+
+         END SELECT
+
+      ELSE
+         iref = jporef 
+      ENDIF
+
+      ! Main computation
+      ijyear = kyear
+      IF ( ijyear < 0 ) ijyear = ijyear + 1
+      IF ( kmonth > 2 ) THEN
+	 ijy = ijyear
+	 ijm = kmonth + 1
+      ELSE
+	 ijy = ijyear  - 1
+	 ijm = kmonth + 13
+      ENDIF
+      ijultmp = INT( 365.25 * ijy ) + INT( 30.6001 * ijm ) + kday + 1720995
+      IF ( kday + 31 * ( kmonth + 12 * ijyear ) >= jpgreg ) THEN
+	 ija = INT( 0.01 * ijy )
+	 ijultmp = ijultmp + 2 - ija + INT( 0.25 * ija )
+      ENDIF
+      pjulian = ( ijultmp - iref ) + ( ( 60 * khour + kmin ) * 60 + ksec ) / 86400.
+
+   END SUBROUTINE greg2jul
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/grt_cir_dis.h90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/grt_cir_dis.h90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/grt_cir_dis.h90	(revision 9570)
@@ -0,0 +1,33 @@
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO Consortium (2010)
+   !! $Id$
+   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+
+   REAL(KIND=wp) FUNCTION grt_cir_dis( pa1, pa2, pb1, pb2, pc1, pc2 )
+      !!----------------------------------------------------------------------
+      !!                     *** FUNCTION grt_cir_dis ***
+      !!
+      !! ** Purpose : Great circle distance between pts (lat1,lon1) 
+      !!               & (lat2,lon2)
+      !!                   
+      !! ** Method   : Geometry.
+      !!
+      !! History :
+      !!        !  1995-12 (G. Madec, E. Durand, A. Weaver, N. Daget) Original 
+      !!        !  2006-03 (A. Vidard) Migration to NEMOVAR 
+      !!        !  2006-10 (A. Weaver) Cleanup
+      !!----------------------------------------------------------------------
+      
+      !! * Arguments
+      REAL(KIND=wp) :: pa1   !  sin(lat1)
+      REAL(KIND=wp) :: pa2   !  sin(lat2)
+      REAL(KIND=wp) :: pb1   !  cos(lat1) * cos(lon1)
+      REAL(KIND=wp) :: pb2   !  cos(lat2) * cos(lon2)
+      REAL(KIND=wp) :: pc1   !  cos(lat1) * sin(lon1)
+      REAL(KIND=wp) :: pc2   !  cos(lat2) * sin(lon2)
+
+      grt_cir_dis = &
+         &  ASIN( SQRT( 1.0 - ( pa1 * pa2 + pb1 * pb2 + pc1 * pc2 )**2 ) )
+      
+   END FUNCTION grt_cir_dis
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/grt_cir_dis_saa.h90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/grt_cir_dis_saa.h90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/grt_cir_dis_saa.h90	(revision 9570)
@@ -0,0 +1,32 @@
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO Consortium (2010)
+   !! $Id$
+   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+
+   REAL(KIND=wp) FUNCTION grt_cir_dis_saa( pa, pb, pc )
+      !!----------------------------------------------------------------------
+      !!                     *** FUNCTION grt_cir_dis_saa ***
+      !!
+      !! ** Purpose : Great circle distance between pts (lat1,lon1) 
+      !!               & (lat2,lon2) with a small-angle approximation
+      !!
+      !! ** Method  : Geometry
+      !!
+      !! ** Action  :
+      !!
+      !! History
+      !!      !  95-12 (G. Madec, E. Durand, A. Weaver, N. Daget) Original 
+      !!      !  06-03 (A. Vidard) Migration to NEMOVAR 
+      !!      !  06-10 (A. Weaver) Cleanup
+      !!----------------------------------------------------------------------
+      
+      !! * Arguments
+      REAL(KIND=wp) :: pa   !  lon1 - lon2
+      REAL(KIND=wp) :: pb   !  lat1 - lat2
+      REAL(KIND=wp) :: pc   !  cos(lat2)
+
+      grt_cir_dis_saa = SQRT( pa * pa + ( pb * pc )**2 )
+
+   END FUNCTION grt_cir_dis_saa
+ 
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/jul2greg.h90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/jul2greg.h90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/jul2greg.h90	(revision 9570)
@@ -0,0 +1,115 @@
+   RECURSIVE SUBROUTINE jul2greg( ksec, kminut, khour, kday, kmonth, kyear, &
+      &                           prelday, krefdate )
+      !!-----------------------------------------------------------------------
+      !!
+      !!                     ***  ROUTINE jul2greg  ***
+      !!
+      !! ** Purpose : Take the relative time in days and re-express in terms of
+      !!              seconds, minutes, hours, days, month, year.
+      !!
+      !! ** Method  : Reference date : 19500101
+      !!
+      !! ** Action  :
+      !!
+      !! History
+      !!      ! 06-04  (A. Vidard) Original
+      !!      ! 06-05  (A. Vidard) Reformatted and refdate      
+      !!      ! 06-10  (A. Weaver) Cleanup
+      !!      ! 2014-09 (D. Lea) Change to use FLOOR to deal with negative prelday
+      !!-----------------------------------------------------------------------
+
+      ! * Arguments
+      INTEGER, INTENT(IN), OPTIONAL :: &
+         & krefdate
+      INTEGER, INTENT(OUT) :: &
+         & ksec,   &
+         & kminut, &
+         & khour,  &
+         & kday,   &
+         & kmonth, &
+         & kyear
+      REAL(KIND=dp), INTENT(IN) :: &
+         & prelday
+
+      !! * Local declarations
+      INTEGER, PARAMETER :: &
+         & jpgreg = 2299161, &
+         & jporef = 2433283, &
+         & jparef = 2415021
+      INTEGER :: &
+         & ijulian, &
+         & ij1,     &
+         & ija,     &
+         & ijb,     &
+         & ijc,     &
+         & ijd,     &
+         & ije,     &
+         & isec,    &
+         & imin,    &
+         & ihou,    &
+         & iday,    &
+         & imon,    &
+         & iyea,    &
+         & iref
+      REAL(KIND=wp) :: &
+         & zday, &
+         & zref
+      CHARACTER(len=200) :: &
+         & cerr
+
+      ! Main computation
+      IF ( PRESENT( krefdate ) ) THEN
+
+         SELECT CASE ( krefdate )
+
+         CASE( 0 ) 
+            iref = jpgreg
+
+         CASE( 19500101 )
+            iref = jporef
+
+         CASE( 19000101 )
+            iref = jparef
+
+         CASE DEFAULT
+            WRITE(cerr,'(A,I8.8)')'jul2greg: Unknown krefdate:', krefdate
+            CALL ctl_stop( cerr )
+
+         END SELECT
+
+      ELSE
+         iref = jporef 
+      ENDIF
+
+      zday = prelday
+      ksec = FLOOR( 86400. * MOD( zday, 1. ) )
+
+      IF ( ksec < 0. ) ksec = 86400. + ksec
+
+      khour  = ksec / 3600
+      kminut = ( ksec - 3600 * khour ) / 60
+      ksec   = MOD( ksec , 60 )
+
+      ijulian = iref + INT( zday )
+      IF ( zday < 0. ) ijulian = ijulian - 1
+
+      ! If input date after 10/15/1582 :
+      IF ( ijulian >= jpgreg ) THEN
+	 ij1 = INT( ( DBLE( ijulian - 1867216 ) - 0.25 ) / 36524.25 )
+	 ija = ijulian + 1 + ij1 - INT( ( 0.25 * ij1 ) )
+      ELSE
+	 ija = ijulian
+      ENDIF
+
+      ijb = ija + 1524
+      ijc = INT( 6680. + ( DBLE ( ijb - 2439870 ) - 122.1 ) / 365.25 )
+      ijd = 365 * ijc + INT( 0.25 * ijc )
+      ije = INT( ( ijb - ijd ) / 30.6001 )
+      kday = ijb - ijd - INT( 30.6001 * ije )
+      kmonth = ije - 1
+      IF ( kmonth > 12 ) kmonth = kmonth - 12
+      kyear = ijc - 4715
+      IF ( kmonth > 2 ) kyear = kyear - 1
+      IF ( kyear <= 0 ) kyear = kyear - 1
+
+   END SUBROUTINE jul2greg
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/julian.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/julian.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/julian.F90	(revision 9570)
@@ -0,0 +1,33 @@
+MODULE julian
+   !!======================================================================
+   !!                       ***  MODULE julian   ***
+   !! Ocean          : Julian data utilities
+   !!=====================================================================
+
+   !!----------------------------------------------------------------------
+   !!   jul2greg        : Convert relative time to date
+   !!   greg2jul        : Convert date to relative time
+   !!----------------------------------------------------------------------
+   !! * Modules used
+   USE par_kind, ONLY : &       ! Precision variables
+      & wp, &
+      & dp  
+   !USE in_out_manager           ! I/O manager
+   USE lib_mpp,  ONLY : &
+      & ctl_warn, ctl_stop
+
+   IMPLICIT NONE
+
+   !! * Routine accessibility
+   PRIVATE
+   PUBLIC jul2greg,        &  ! Convert relative time to date
+      &   greg2jul            ! Convert date to relative time 
+  
+   !! $Id$
+CONTAINS
+ 
+#include "jul2greg.h90"
+
+#include "greg2jul.h90"
+   
+END MODULE julian
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/linquad.h90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/linquad.h90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/linquad.h90	(revision 9570)
@@ -0,0 +1,59 @@
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO Consortium (2010)
+   !! $Id$
+   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+
+   LOGICAL FUNCTION linquad( px, py, pxv, pyv )
+      !!----------------------------------------------------------------------
+      !!                    ***  FUNCTION linquad ***
+      !!
+      !! ** Purpose : Determine whether a point P(x,y) lies within or on the
+      !!              boundary of a quadrangle (ABCD) of any shape on a plane.
+      !!
+      !! ** Method  : Check if the vectorial products PA x PC, PB x PA, 
+      !!              PC x PD, and PD x PB are all negative.
+      !!
+      !! ** Action  : 
+      !!
+      !! History :
+      !!        !  2001-11  (N. Daget, A. Weaver)
+      !!        !  2006-08  (A. Weaver) NEMOVAR migration
+      !!        !  2006-10  (A. Weaver) Cleanup
+      !!----------------------------------------------------------------------
+
+      !! * Arguments
+      REAL(KIND=wp), INTENT(IN) :: px        ! (lon) of the point P(x,y) 
+      REAL(KIND=wp), INTENT(IN) :: py        ! (lat) of the point P(x,y)               
+      REAL(KIND=wp), DIMENSION(4), INTENT(IN) :: &
+         & pxv,  &                  ! (lon, lat) of the surrounding cell
+         & pyv                     
+  
+      !! * Local declarations
+      REAL(KIND=wp) :: zst1
+      REAL(KIND=wp) :: zst2
+      REAL(KIND=wp) :: zst3
+      REAL(KIND=wp) :: zst4
+
+      !-----------------------------------------------------------------------
+      ! Test to see if the point is within the cell
+      !-----------------------------------------------------------------------
+      linquad = .FALSE.
+      zst1 =   ( px - pxv(1) ) * ( py - pyv(4) ) &
+         &   - ( py - pyv(1) ) * ( px - pxv(4) )
+      IF ( zst1 <= 0.0 ) THEN
+         zst2 =   ( px - pxv(4) ) * ( py - pyv(3) ) &
+         &   - ( py - pyv(4) ) * ( px - pxv(3) )
+         IF ( zst2 <= 0.0 ) THEN
+            zst3 =   ( px - pxv(3) ) * ( py - pyv(2) ) &
+               &   - ( py - pyv(3) ) * ( px - pxv(2) )
+            IF ( zst3 <= 0.0) THEN
+               zst4 =   ( px - pxv(2) ) * ( py - pyv(1) ) &
+                  &   - ( py - pyv(2) ) * ( px - pxv(1) )
+               IF ( zst4 <= 0.0 ) linquad = .TRUE.
+            ENDIF
+         ENDIF
+      ENDIF
+
+   END FUNCTION linquad
+
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/maxdist.h90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/maxdist.h90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/maxdist.h90	(revision 9570)
@@ -0,0 +1,76 @@
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO Consortium (2010)
+   !! $Id$
+   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+
+   REAL FUNCTION maxdist( pxv, pyv )
+      !!----------------------------------------------------------------------
+      !!                    ***  FUNCTION maxdist ***
+      !!
+      !! ** Purpose : Compute the maximum distance between any points within
+      !!              a cell
+      !!
+      !! ** Method  : Call to grt_cir_dis
+      !!
+      !! ** Action  : 
+      !!
+      !! History :
+      !!        !  2006-08  (K. Mogensen)
+      !!        !  2006-10  (A. Weaver) Cleanup
+      !!----------------------------------------------------------------------
+
+      !! * Arguments
+      REAL(KIND=wp), DIMENSION(4), INTENT(IN) :: &
+          & pxv, &                 ! (lon, lat) of the surrounding cell
+          & pyv    
+
+      !! * Local declarations
+      REAL(KIND=wp), DIMENSION(4) :: &
+          &  zxv, &
+          &  zyv, &
+          &  za,  &
+          &  zb,  &
+          &  zc
+      REAL(KIND=wp) :: zdist
+      
+      INTEGER :: ji
+      INTEGER :: jj
+      
+      !-----------------------------------------------------------------------
+      ! Convert data to radians
+      !-----------------------------------------------------------------------
+      DO ji = 1, 4
+         zxv(ji) = pxv(ji) * rad
+         zyv(ji) = pyv(ji) * rad
+      END DO
+
+      !-----------------------------------------------------------------------
+      ! Prepare input to grt_cir_dis
+      !-----------------------------------------------------------------------
+      DO ji = 1, 4
+         za(ji) = SIN( zyv(ji) )
+         zb(ji) = COS( zyv(ji) ) * COS( zxv(ji) )
+         zc(ji) = COS( zyv(ji) ) * SIN( zxv(ji) )
+      END DO
+      
+      !-----------------------------------------------------------------------
+      ! Get max distance between any points in the area
+      !-----------------------------------------------------------------------
+      maxdist = 0.0
+      DO jj = 1, 4
+         DO ji = jj+1, 4
+            zdist = grt_cir_dis( za(jj), za(ji), zb(jj), &
+               &                 zb(ji), zc(jj), zc(ji))
+            IF ( zdist > maxdist ) THEN
+               maxdist = zdist
+            ENDIF
+         END DO
+      END DO
+      
+      !-----------------------------------------------------------------------
+      ! Convert to degrees.
+      !-----------------------------------------------------------------------
+      maxdist = maxdist / rad
+
+   END FUNCTION maxdist
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/mpp_map.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/mpp_map.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/mpp_map.F90	(revision 9570)
@@ -0,0 +1,85 @@
+MODULE mpp_map
+   !!======================================================================
+   !!                       ***  MODULE mpp_mpa  ***
+   !! NEMOVAR: MPP global grid point mapping to processors
+   !!======================================================================
+   !! History :  2.0  ! 2007-08  (K. Mogensen)  Original code
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!  mppmap_init : Initialize mppmap.
+   !!----------------------------------------------------------------------
+   USE par_kind, ONLY :   wp            ! Precision variables
+   USE par_oce , ONLY :   jpi, jpj      ! Ocean parameters
+   USE dom_oce , ONLY :   mig, mjg, nldi, nlei, nldj, nlej, nlci, nlcj, narea   ! Ocean space and time domain variables
+#if defined key_mpp_mpi
+   USE lib_mpp, ONLY :   mpi_comm_oce   ! MPP library
+#endif
+   USE in_out_manager   ! I/O manager
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC ::   mppmap_init, mppmap   !: ???
+
+   INTEGER, DIMENSION(:,:), ALLOCATABLE ::   mppmap   ! ???
+
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO Consortium (2010)
+   !! $Id$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE mppmap_init
+      !!----------------------------------------------------------------------
+      !!               ***  ROUTINE mppmap_init ***
+      !!          
+      !! ** Purpose : Setup a global map of processor rank for all gridpoints
+      !!
+      !! ** Method  : MPI all reduce.
+      !!
+      !! ** Action  : This does only work for MPI. 
+      !!
+      !! References : http://www.mpi-forum.org
+      !!----------------------------------------------------------------------
+      INTEGER, DIMENSION(:,:), ALLOCATABLE ::   imppmap   !
+#if defined key_mpp_mpi
+      INTEGER :: ierr
+
+INCLUDE 'mpif.h'
+#endif
+      !!----------------------------------------------------------------------
+
+      IF (.NOT. ALLOCATED(mppmap)) THEN
+         ALLOCATE( &
+            & mppmap(jpiglo,jpjglo) &
+            & )
+      ENDIF
+      ! Initialize local imppmap
+
+      ALLOCATE( &
+         & imppmap(jpiglo,jpjglo) &
+         & )
+      imppmap(:,:) = 0
+
+!      ! Setup local grid points
+      imppmap(mig(1):mig(nlci),mjg(1):mjg(nlcj)) = narea
+      
+      ! Get global data
+
+#if defined key_mpp_mpi
+
+      ! Call the MPI library to find the max across processors
+      CALL mpi_allreduce( imppmap, mppmap, jpiglo*jpjglo, mpi_integer,   &
+         &                mpi_max, mpi_comm_oce, ierr )
+#else      
+      
+      ! No MPP: Just copy the data
+      mppmap(:,:) = imppmap(:,:)
+#endif
+      !
+   END SUBROUTINE mppmap_init
+
+   !!======================================================================
+END MODULE mpp_map
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/obs_averg_h2d.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/obs_averg_h2d.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/obs_averg_h2d.F90	(revision 9570)
@@ -0,0 +1,824 @@
+MODULE obs_averg_h2d
+   !!======================================================================
+   !!                       ***  MODULE obs_averg_h2d   ***
+   !! Observation diagnostics: Perform the horizontal averaging
+   !!                          from model grid to observation footprint
+   !!=====================================================================
+
+   !!----------------------------------------------------------------------
+   !!   obs_averg_h2d     : Horizontal averaging to the observation footprint
+   !!----------------------------------------------------------------------
+   !! * Modules used
+   USE par_kind, ONLY : &  ! Precision variables
+      & wp
+   USE par_oce, ONLY : & 
+      & jpi, jpj
+   USE phycst,   ONLY : &  ! Physical constants
+      & rad,  &
+      & ra,   &
+      & rpi
+   USE dom_oce,   ONLY : &
+      & e1t, e2t, &
+      & e1f, e2f, &
+      & glamt, gphit, &
+      & nproc
+   USE in_out_manager
+   USE obs_const, ONLY : &
+      & obfillflt		! Fillvalue
+   USE obs_utils           ! Utility functions
+   USE lib_mpp,   ONLY : &
+      & ctl_warn, ctl_stop, &
+      & mpp_min, lk_mpp
+
+   IMPLICIT NONE
+
+   !! * Routine accessibility
+   PRIVATE obs_avg_h2d_rad, & ! Horizontal averaging using a radial footprint
+      &    obs_avg_h2d_rec, & ! Horizontal averaging using a rectangular footprint
+      &    obs_deg2dist,    & ! Conversion of distance in degrees to distance in metres
+      &    obs_dist2corners   ! Distance from the centre of obs footprint to the corners of a grid box
+   
+   PUBLIC obs_avg_h2d,      & ! Horizontal averaging to the observation footprint
+      &   obs_avg_h2d_init, & ! Set up weights for the averaging
+      &   obs_max_fpsize      ! Works out the maximum number of grid points required for the averaging
+
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO Consortium (2010)
+   !! $Id: obs_averg_h2d.F90 2715 2011-03-30 15:58:35Z rblod $
+   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+
+CONTAINS
+   SUBROUTINE obs_avg_h2d_init( kpk, kpk2, kmaxifp, kmaxjfp, k2dint, plam,  pphi, &
+      &                         pglam, pgphi, pglamf, pgphif, pmask, plamscl, pphiscl, lindegrees, &
+      &                         pweig, pobsmask, iminpoints )
+      !!-----------------------------------------------------------------------
+      !!
+      !!                     ***  ROUTINE obs_avg_h2d_init  ***
+      !!
+      !! ** Purpose : Computes weights for horizontal averaging to the 
+      !!              observation footprint.
+      !!
+      !! ** Method  : Horizontal averaging to the observation footprint using
+      !!              model values at a defined area.
+      !!
+      !!    Averaging schemes :
+      !!
+      !!    Two horizontal averaging schemes are available:
+      !!        - weighted radial footprint        (k2dint = 5)
+      !!        - weighted rectangular footprint   (k2dint = 6)
+      !!
+      !! History :
+      !!        ! 13-10 (M. Martin)
+      !!-----------------------------------------------------------------------
+      !! * Modules used
+      !! * Arguments
+      INTEGER, INTENT(IN) :: &
+         & kpk,   &             ! Parameter values for automatic arrays
+         & kpk2,  &
+         & kmaxifp,  &          ! Max size of model points in i-direction for obs footprint
+         & kmaxjfp,  &          ! Max size of model points in j-direction for obs footprint
+         & k2dint               ! Averaging scheme options - see header
+      REAL(KIND=wp), INTENT(INOUT) :: &
+         & plam, &              ! Geographical (lat,lon) coordinates of
+         & pphi                 ! observation
+      REAL(KIND=wp), DIMENSION(kmaxifp,kmaxjfp), INTENT(IN) :: &
+         & pglam, &             ! Model variable lon
+         & pgphi                ! Model variable lat
+      REAL(KIND=wp), DIMENSION(kmaxifp+1,kmaxjfp+1), INTENT(IN) :: &
+         & pglamf, &            ! Model variable lon at corners of grid-boxes
+         & pgphif               ! Model variable lat at corners of grid-boxes
+      REAL(KIND=wp), DIMENSION(kmaxifp,kmaxjfp,kpk2), INTENT(IN) :: &
+         & pmask                ! Model variable mask
+      REAL(KIND=wp), INTENT(IN) :: &
+         & plamscl, &           ! Diameter (lat,lon) of obs footprint in metres
+         & pphiscl              ! This is the full width (rather than half-width)
+      LOGICAL, INTENT(IN) :: &
+         & lindegrees           ! T=> obs footprint specified in degrees, F=> in metres
+      REAL(KIND=wp), DIMENSION(kmaxifp,kmaxjfp,kpk2), INTENT(OUT) ::  &
+         & pweig                ! Weights for averaging
+      REAL(KIND=wp), DIMENSION(kpk2), INTENT(OUT) ::  &
+         & pobsmask             ! Vertical mask for observations
+      INTEGER, INTENT(IN), OPTIONAL :: &
+         & iminpoints           ! Reject point which is not surrounded
+                                ! by at least iminpoints sea points
+
+      !! * Local declarations
+      INTEGER :: &
+         & jk
+      INTEGER :: &
+         & ikmax
+
+
+      !------------------------------------------------------------------------
+      !
+      !------------------------------------------------------------------------
+
+      !------------------------------------------------------------------------
+      ! Initialize number of levels
+      !------------------------------------------------------------------------
+      IF ( kpk2 == 1 ) THEN
+         ikmax = 1
+      ELSEIF ( kpk2 == kpk) THEN
+         ikmax = kpk-1
+      ENDIF
+
+
+         SELECT CASE (k2dint)
+         CASE(5)
+            CALL obs_avg_h2d_rad( kpk2, ikmax, kmaxifp, kmaxjfp, plam, pphi, &
+      &                           plamscl, pphiscl, lindegrees, pmask, pglam, pgphi, pglamf, pgphif, pweig )
+         CASE(6)
+            CALL obs_avg_h2d_rec( kpk2, ikmax, kmaxifp, kmaxjfp, plam, pphi, &
+      &                           plamscl, pphiscl, lindegrees, pmask, pglam, pgphi, pglamf, pgphif, pweig )
+         END SELECT
+
+
+      END SUBROUTINE obs_avg_h2d_init
+
+
+      SUBROUTINE obs_avg_h2d_rad( kpk2, kmax, kmaxifp, kmaxjfp, plam, pphi, &
+      &                           plamscl, pphiscl, lindegrees, pmask, pglam, pgphi, pglamf, pgphif, pweig )
+      !!-----------------------------------------------------------------------
+      !!
+      !!                     ***  ROUTINE obs_avg_h2d_rad  ***
+      !!
+      !! ** Purpose : Computes weights for horizontal averaging to the 
+      !!              observation using a radial footprint.
+      !!
+      !! ** Method  : Calculate whether each grid box is completely or 
+      !!              partially within the observation footprint.
+      !!              If it is partially in the footprint then calculate
+      !!              the ratio of the area inside the footprint to the total 
+      !!              area of the grid box.
+      !!
+      !! History :
+      !!        ! 14-01 (M. Martin)
+      !!-----------------------------------------------------------------------
+      !! * Modules used
+      USE phycst,   ONLY : &  ! Physical constants
+         & ra,  &
+         & rpi
+
+      !! * Arguments
+      INTEGER, INTENT(IN) :: &
+         & kpk2, &             ! Parameter values for automatic arrays
+         & kmax
+
+      INTEGER, INTENT(IN) :: &
+         & kmaxifp,   &         ! Max size of model points in i-direction for obs footprint
+         & kmaxjfp              ! Max size of model points in j-direction for obs footprint
+
+      REAL(KIND=wp), INTENT(IN) :: &
+         & plam, &
+         & pphi                 ! Geographical (lat,lon) coordinates of
+                                ! observation
+      REAL(KIND=wp), INTENT(IN) :: &
+         & plamscl, &           ! Diameter (lat,lon) of obs footprint in metres or degrees (see below)
+         & pphiscl              ! This is the full width (rather than half-width)
+      LOGICAL, INTENT(IN) :: &
+         & lindegrees           ! T=>scales specified in degrees, F=> in metres
+      REAL(KIND=wp), DIMENSION(kmaxifp,kmaxjfp,kpk2), INTENT(IN) :: &
+         & pmask                ! Model variable mask
+      REAL(KIND=wp), DIMENSION(kmaxifp,kmaxjfp), INTENT(IN) :: &
+         & pglam, &             ! Model variable lon
+         & pgphi                ! Model variable lat
+      REAL(KIND=wp), DIMENSION(kmaxifp+1,kmaxjfp+1), INTENT(IN) :: &
+         & pglamf, &             ! Model variable lon at corners of grid boxes
+         & pgphif                ! Model variable lat at corners of grid boxes
+      REAL(KIND=wp), DIMENSION(kmaxifp,kmaxjfp,kpk2), INTENT(OUT) ::  &
+         & pweig                ! Weights for interpolation
+
+      !! Local declarations
+      INTEGER :: ji, jj, jk
+      INTEGER :: jvert, jis, jjs
+      INTEGER :: jnumvert, jnumvertbig
+      INTEGER, PARAMETER :: &
+         & jnumsubgrid = 20     ! The number of sub grid-boxes (in x and y directions) used to approximate area of obs fp
+
+      REAL(KIND=wp), DIMENSION(4) :: &
+         & zxvert, zyvert, &    ! The lon/lat of the vertices(corners) of the grid box in m relative to centre of obs fp
+         & zdist                ! Distance of each vertex to the centre of the obs footprint
+      REAL(KIND=wp), DIMENSION(4) :: &
+         & zxgrid, zygrid, &      ! Distance of each vertex of grid box to the centre of the grid box in x/y directions
+         & zdgrid
+      REAL(KIND=wp) :: &
+         & zdx, zdy, &          ! The sub grid-box sizes (in metres)
+         & zarea_subbox, &      ! The area of each sub grid-box (in metres squared)
+         & zxpos, zypos, &      ! The x,y position (relative to centre of obs footprint) of the centre of each sub grid-box
+         & zsubdist, &          ! The distance of the centre of each sub grid-box from the centre of the obs footprint
+         & zarea_fp, &          ! Total area of obs footprint within the grid box
+         & zareabox             ! Total area of the grid box
+      REAL(KIND=wp) :: &
+         & zphiscl_m, &         ! Diameter of obs footprint in metres
+         & zlamscl_m
+      !---------------------------------------------------------------------------------------------------
+      !Initialise weights to zero.
+      pweig(:,:,:) = 0.0_wp
+      
+      !Two footprint sizes can be specified in the namelist but this routine assumes a circular footprint. 
+      !If the two sizes are different then write out a warning.
+      IF ( pphiscl /= plamscl ) THEN
+               CALL ctl_warn( 'obs_avg_h2d_rad:',   &
+                  &           'The two components of the obs footprint size are not equal', &
+                  &           'yet the radial option has been selected - using pphiscl here' )
+      ENDIF
+      
+      DO jk = 1, kmax
+         DO ji = 1, kmaxifp
+            DO jj = 1, kmaxjfp
+            
+               IF ( pmask(ji,jj,jk) == 1.0_wp ) THEN
+
+                  IF ( lindegrees ) THEN
+                     !If the scales are specified in degrees, work out the
+                     !scales (metres) in x/y directions
+                     CALL obs_deg2dist( 1, 1, pglam(ji,jj), pgphi(ji,jj), &
+                        &               plamscl, pphiscl, zlamscl_m, zphiscl_m )
+                  ELSE
+                     zphiscl_m = pphiscl
+                  ENDIF
+
+
+                  ! Work out the area of the grid box using distance of corners relative to centre of grid box
+                  CALL obs_dist2corners(pglamf(ji,jj), pglamf(ji+1,jj), pglamf(ji,jj+1), pglamf(ji+1,jj+1), &
+                     &                  pgphif(ji,jj), pgphif(ji+1,jj), pgphif(ji,jj+1), pgphif(ji+1,jj+1), &
+                     &                  pglam(ji,jj), pgphi(ji,jj), zxgrid, zygrid, zdgrid)
+                  zareabox = ABS( zxgrid(1) - zxgrid(2) ) * ABS( zygrid(1) - zygrid(4) )
+
+                  !1. Determine how many of the vertices of the grid box lie within the circle
+                  
+                  !For each vertex, calculate its location and distance relative 
+                  !to the centre of the observation footprint
+                  
+                  CALL obs_dist2corners(pglamf(ji,jj), pglamf(ji+1,jj), pglamf(ji,jj+1), pglamf(ji+1,jj+1), &
+                     &                  pgphif(ji,jj), pgphif(ji+1,jj), pgphif(ji,jj+1), pgphif(ji+1,jj+1), &
+                     &                  plam, pphi, zxvert, zyvert, zdist)
+
+                  jnumvert = 0
+                  jnumvertbig = 0
+                  DO jvert = 1, 4
+
+                     !If the distance to the center to the observation footprint is less
+                     !than the radius of the footprint (half the diameter) then this
+                     !vertex is within the observation footprint
+                     IF ( zdist(jvert) <= ( zphiscl_m / 2.0_wp ) ) jnumvert = jnumvert + 1
+                     
+                     !For expediency, check if the vertices are "nearly" within the obs
+                     !footprint as if none of them are close to the edge of the footprint
+                     !then the footprint is unlikely to be intersecting the grid box
+                     IF ( zdist(jvert) - ( 0.5_wp * zareabox ) <= ( zphiscl_m / 2.0 ) ) &
+                        & jnumvertbig = jnumvertbig + 1
+                     
+                  END DO
+                  
+                  !2. If none of the vertices are even close to the edge of the obs
+                  !footprint then leave weight as zero and cycle to next grid box.
+                  IF ( jnumvertbig == 0 ) CYCLE
+
+                  !3. If all the vertices of the box are within the observation footprint then the 
+                  !      whole grid box is within the footprint so set the weight to one and 
+                  !      move to the next grid box.
+                  IF ( jnumvert == 4 ) THEN
+                     pweig(ji,jj,jk) = 1.0_wp
+                     CYCLE
+                  ENDIF
+
+
+                  !4. Use a brute force technique for calculating the area within 
+                  !   the grid box covered by the obs footprint.
+                  !  (alternative could be to use formulae on 
+                  !         http://mathworld.wolfram.com/Circle-LineIntersection.html)
+                  !   For now split the grid box into a specified number of smaller 
+                  !   boxes and add up the area of those whose centre is within the obs footprint.
+                  !   Order of vertices is 1=topleft, 2=topright, 3=bottomright, 4=bottomleft
+                  zdx = ABS( zxvert(3) - zxvert(4) ) / REAL(jnumsubgrid, wp)
+                  zdy = ABS( zyvert(1) - zyvert(4) ) / REAL(jnumsubgrid, wp)
+                  zarea_subbox = zdx * zdy
+
+                  zarea_fp = 0.0_wp
+                  DO jis = 1, jnumsubgrid
+                     zxpos = zxvert(4) + ( REAL(jis, wp) * zdx ) - (0.5_wp * zdx )
+                     DO jjs = 1, jnumsubgrid
+                        !Find the distance of the centre of this sub grid box to the
+                        !centre of the obs footprint
+                        zypos = zyvert(4) + ( REAL(jjs, wp) * zdy ) - ( 0.5_wp * zdy )
+                        zsubdist = SQRT( (zxpos * zxpos) + (zypos * zypos) )
+                        IF ( zsubdist < ( zphiscl_m / 2.0_wp ) ) &
+                           &  zarea_fp = zarea_fp + zarea_subbox
+                     END DO
+                  END DO
+
+                  !6. Calculate the ratio of the area of the footprint within the box 
+                  !   to the total area of the grid box and use this fraction to weight 
+                  !   the model value in this grid box.
+                  pweig(ji,jj,jk) = MIN( zarea_fp / zareabox, 1.0_wp )
+
+               END IF  !pmask
+            END DO
+         END DO
+      END DO
+      
+      END SUBROUTINE obs_avg_h2d_rad
+
+
+      SUBROUTINE obs_avg_h2d_rec( kpk2, kmax, kmaxifp, kmaxjfp, plam, pphi, &
+      &                           plamscl, pphiscl, lindegrees, pmask, pglam, pgphi, pglamf, pgphif, pweig )
+      !!-----------------------------------------------------------------------
+      !!
+      !!                     ***  ROUTINE obs_avg_h2d_rec  ***
+      !!
+      !! ** Purpose : Computes weights for horizontal averaging to the
+      !!              observation using a rectangular footprint which
+      !!              is aligned with lines of lat/lon.
+      !!
+      !! ** Method  : Horizontal averaging to the observation footprint using
+      !!              model values at a defined area.
+      !!
+      !! History :
+      !!        ! 14-01 (M. Martin)
+      !!-----------------------------------------------------------------------
+      !! * Modules used
+      USE phycst,   ONLY : &    ! Physical constants
+         & ra,  &
+         & rpi
+
+      !! * Arguments
+      INTEGER, INTENT(IN) :: &
+         & kpk2, &              ! Parameter values for automatic arrays
+         & kmax
+
+      INTEGER, INTENT(IN) :: &
+         & kmaxifp,   &         ! Max size of model points in i-direction for obs footprint
+         & kmaxjfp              ! Max size of model points in j-direction for obs footprint
+
+      REAL(KIND=wp), INTENT(IN) :: &
+         & plam, &
+         & pphi                 ! Geographical (lat,lon) coordinates of
+                                ! observation
+      REAL(KIND=wp), INTENT(IN) :: &
+         & plamscl, &
+         & pphiscl              ! Width in x/y directions of obs footprint in metres
+                                ! This is the full width (rather than half-width)
+      LOGICAL, INTENT(IN) :: &
+         & lindegrees           !T=> scales specified in degrees, F=> in metres
+      REAL(KIND=wp), DIMENSION(kmaxifp,kmaxjfp,kpk2), INTENT(IN) :: &
+         & pmask                ! Model variable mask
+      REAL(KIND=wp), DIMENSION(kmaxifp,kmaxjfp), INTENT(IN) :: &
+         & pglam, &             ! Model variable lat at centre of grid boxes
+         & pgphi                ! Model variable lon at centre of grid boxes
+      REAL(KIND=wp), DIMENSION(kmaxifp+1,kmaxjfp+1), INTENT(IN) :: &
+         & pglamf, &             ! Model variable lat at corners of grid boxes
+         & pgphif                ! Model variable lon at corners of grid boxes
+      REAL(KIND=wp), DIMENSION(kmaxifp,kmaxjfp,kpk2), INTENT(OUT) ::  &
+         & pweig                ! Weights for interpolation
+
+      !! Local declarations
+      INTEGER :: ji, jj, jk
+      INTEGER :: jvert
+      INTEGER, DIMENSION(4) :: &
+         & jnumvert
+      REAL(KIND=wp), DIMENSION(4) :: &
+         & zxvert, zyvert         ! The lon/lat of the vertices(corners) of the grid box in m relative to centre of obs fp
+      REAL(KIND=wp), DIMENSION(4) :: &
+         & zdist                  ! Distance of each vertex to the centre of the obs footprint
+      REAL(KIND=wp), DIMENSION(4) :: &
+         & zxgrid, zygrid, &      ! Distance of each vertex of grid box to the centre of the grid box in x/y directions
+         & zdgrid
+      REAL(KIND=wp) :: &
+         & zareabox, &            ! Total area of grid box
+         & zarea_fp, &            ! Total area of obs footprint
+         & zarea_intersect        ! Area of the intersection between the grid box and the obs footprint
+      REAL(KIND=wp) :: &
+         & zlamscl_m, &
+         & zphiscl_m              ! Total width (lat,lon) of obs footprint in metres
+      REAL(KIND=wp) :: &
+         & z_awidth, z_aheight, & ! Width and height of model grid box
+         & z_cwidth, z_cheight    ! Width and height of union of model grid box and obs footprint
+      REAL(KIND=wp) :: &
+         & zleft, zright, &       ! Distance (metres) of corners area of intersection
+         & ztop, zbottom          ! between grid box and obs footprint
+
+      !-----------------------------------------------------------------------
+
+      !Initialise weights to zero
+      pweig(:,:,:) = 0.0_wp
+      
+      !Loop over the grid boxes which have been identified as potentially being within the
+      !observation footprint
+      DO jk = 1, kmax
+         DO ji = 1, kmaxifp
+            DO jj = 1, kmaxjfp
+
+               IF ( pmask(ji,jj,jk) == 1.0_wp ) THEN
+
+
+                  IF ( lindegrees ) THEN
+                     !If the scales are specified in degrees, work out the
+                     !scales (metres) in x/y directions
+                     CALL obs_deg2dist( 1, 1, pglam(ji,jj), pgphi(ji,jj), &
+                        &               plamscl, pphiscl, zlamscl_m, zphiscl_m )
+                  ELSE
+                     zlamscl_m = plamscl
+                     zphiscl_m = pphiscl
+                  ENDIF
+
+                  ! Work out the area of the grid box using distance of corners relative to centre of grid box
+                  CALL obs_dist2corners(pglamf(ji,jj), pglamf(ji+1,jj), pglamf(ji,jj+1), pglamf(ji+1,jj+1), &
+                     &                  pgphif(ji,jj), pgphif(ji+1,jj), pgphif(ji,jj+1), pgphif(ji+1,jj+1), &
+                     &                  pglam(ji,jj), pgphi(ji,jj), zxgrid, zygrid, zdgrid)
+
+                  !Calculate width and height of model grid box
+                  z_awidth  = ABS( zxgrid(1) - zxgrid(2) )
+                  z_aheight = ABS( zygrid(1) - zygrid(4) )
+                  zareabox = z_awidth * z_aheight
+
+                  ! Work out area of the observation footprint
+                  zarea_fp = zlamscl_m * zphiscl_m
+
+                  ! For each corner of the grid box, calculate its location and distance relative
+                  ! to the centre of the observation footprint
+                  CALL obs_dist2corners(pglamf(ji,jj), pglamf(ji+1,jj), pglamf(ji,jj+1), pglamf(ji+1,jj+1), &
+                     &                  pgphif(ji,jj), pgphif(ji+1,jj), pgphif(ji,jj+1), pgphif(ji+1,jj+1), &
+                     &                  plam, pphi, zxvert, zyvert, zdist)
+
+                  !Work out maximum width and height of rectangle covered by corners of obs fp and grid box
+                  z_cwidth  = MAX( zxvert(1), zxvert(2), -zlamscl_m/2.0_wp, zlamscl_m/2.0_wp ) - &
+                     &       MIN( zxvert(1), zxvert(2), -zlamscl_m/2.0_wp, zlamscl_m/2.0_wp )
+                     
+                  z_cheight = MAX( zyvert(1), zyvert(4), zphiscl_m/2.0_wp, -zphiscl_m/2.0_wp ) - &
+                     &       MIN( zyvert(1), zyvert(4), zphiscl_m/2.0_wp, -zphiscl_m/2.0_wp )
+                  
+                  IF ( ( z_cwidth  >= z_awidth  + zlamscl_m  ) .OR. &
+                     & ( z_cheight >= z_aheight + zphiscl_m ) ) THEN
+                     !The obs footprint and the model grid box don't overlap so set weight to zero
+                     pweig(ji,jj,jk) = 0.0_wp
+                  ELSE IF ( ( z_cwidth  == zlamscl_m ) .AND. &
+                     &      ( z_cheight == zphiscl_m ) ) THEN
+                     !The grid box is totally contained within the obs footprint so set weight to one
+                     pweig(ji,jj,jk) = 1.0_wp
+                  ELSE IF ( ( z_cwidth  == z_awidth  ) .AND. &
+                     &      ( z_cheight == z_aheight ) ) THEN
+                     !The obs footprint is totally contained within the grid box so set weight as ratio of the two
+                     pweig(ji,jj,jk) = zarea_fp / zareabox
+                  ELSE 
+                     !The obs footprint and the grid box overlap so calculate the area of the intersection of the two
+                     zleft   = max(zxvert(1), -zlamscl_m/2.0_wp)
+                     zright  = min(zxvert(2),  zlamscl_m/2.0_wp)
+                     zbottom = max(zyvert(4), -zphiscl_m/2.0_wp)
+                     ztop    = min(zyvert(1),  zphiscl_m/2.0_wp)
+                     
+                     IF (  ( zleft < zright ) .AND. ( zbottom < ztop ) ) THEN
+                        zarea_intersect = ( zright - zleft ) * ( ztop - zbottom )
+                        pweig(ji,jj,jk) = zarea_intersect / zareabox
+                     ENDIF
+                  ENDIF
+
+               END IF !pmask
+            END DO
+         END DO
+      END DO
+
+   END SUBROUTINE obs_avg_h2d_rec
+
+   SUBROUTINE obs_avg_h2d( kpk, kpk2, kmaxifp, kmaxjfp, pweig, pmod, pobsk )
+
+      !!-----------------------------------------------------------------------
+      !!
+      !!                     ***  ROUTINE obs_int_h2d  ***
+      !!
+      !! ** Purpose : Horizontal averaging to the observation footprint.
+      !!
+      !! ** Method  : Average the model points based on the weights already calculated.
+      !!
+      !! ** Action  :
+      !!                   
+      !! References : 
+      !!
+      !! History :
+      !!        ! 13/10. M. Martin.
+      !!-----------------------------------------------------------------------
+      !! * Modules used
+      !! * Arguments
+      INTEGER, INTENT(IN) :: &
+         & kpk,   &             ! Parameter values for automatic arrays
+         & kpk2
+      INTEGER, INTENT(IN) :: &
+         & kmaxifp,   &         ! Max size of model points in i-direction for obs footprint
+         & kmaxjfp              ! Max size of model points in j-direction for obs footprint
+      REAL(KIND=wp), DIMENSION(kmaxifp,kmaxjfp,kpk2), INTENT(IN) :: &
+         & pweig                ! Interpolation weights
+      REAL(KIND=wp), DIMENSION(kmaxifp,kmaxjfp,kpk2), INTENT(IN) :: &
+         & pmod                 ! Model variable to interpolate
+      REAL(KIND=wp), DIMENSION(kpk2), INTENT(OUT) ::  &
+         & pobsk                ! Model profile interpolated to obs (i,j) pt
+
+      INTEGER :: &
+         & jk
+      INTEGER :: &
+         & ikmax
+      REAL(KIND=wp) :: &
+         & zsum
+
+      !------------------------------------------------------------------------
+      ! Initialize number of levels
+      !------------------------------------------------------------------------
+      IF ( kpk2 == 1 ) THEN
+         ikmax = 1
+      ELSEIF ( kpk2 == kpk) THEN
+         ikmax = kpk-1
+      ENDIF
+
+      !------------------------------------------------------------------------
+      ! Average model values to the observation footprint
+      !------------------------------------------------------------------------
+      pobsk = obfillflt
+
+      DO jk = 1, ikmax
+
+         zsum = SUM( pweig(:,:,jk) )
+
+         IF ( zsum /= 0.0_wp ) THEN
+            pobsk(jk) = SUM ( pweig(:,:,jk) * pmod(:,:,jk), Mask=pweig(:,:,jk) > 0.0_wp )
+            pobsk(jk) = pobsk(jk) / zsum
+         END IF
+
+      END DO
+
+   END SUBROUTINE obs_avg_h2d
+
+   SUBROUTINE obs_max_fpsize( k2dint, plamscl, pphiscl, lindegrees, pmask, kmaxifp, kmaxjfp )
+      !!-----------------------------------------------------------------------
+      !!
+      !!                     ***  ROUTINE obs_max_fpsize  ***
+      !!
+      !! ** Purpose : Calculate maximum number of grid points which may
+      !!              need to be used in the averaging in the global domain.
+      !!
+      !!
+      !! ** Method  : Work out the minimum grid size and work out
+      !!              how many of the smallest grid points would be needed
+      !!              to cover the scale of the observation footprint.
+      !!              This needs to be done using the max/min of the global domain
+      !!              as the obs can be distributed from other parts of the grid.
+      !!
+      !! ** Action  :
+      !!                   
+      !! References : 
+      !!
+      !! History :
+      !!        ! 14/01. M. Martin. 
+      !!-----------------------------------------------------------------------
+      !! * Modules used
+      !! * Arguments
+      INTEGER , INTENT(IN) :: &
+         & k2dint                   !Type of interpolation/averaging used
+      REAL(KIND=wp), INTENT(IN) :: &
+         & plamscl,   &             !Total width/radius in metres of the observation footprint
+         & pphiscl                  !
+      LOGICAL, INTENT(IN) :: &
+         & lindegrees               !T=> plamscl and pphiscl are specified in degrees
+      REAL(KIND=wp), DIMENSION(jpi,jpj), INTENT(IN) :: &
+         & pmask                    !Land/sea mask
+                                    !F=> plamscl and pphiscl are specified in metres
+      INTEGER, INTENT(OUT)  :: &
+         & kmaxifp,   &             !Max number of grid points in i,j directions to use in averaging
+         & kmaxjfp                  !these have to be even so that the footprint is centred
+
+      !! * Local variables
+      REAL(KIND=wp) :: &
+         & ze1min,     &            !Minimum global grid-size in i,j directions
+         & ze2min
+      REAL(KIND=wp) :: &
+         & zphiscl_m, &
+         & zlamscl_m
+      !------------------------------------------------------------------------
+
+      IF ( k2dint <= 4 ) THEN
+         !If interpolation is being used then only need to use a 2x2 footprint
+         kmaxifp = 2
+         kmaxjfp = 2
+
+      ELSE
+
+         IF ( lindegrees ) THEN
+            !If the scales are specified in degrees, work out the max 
+            !distance (metres) in x/y directions
+            CALL obs_deg2dist( jpi, jpj, glamt, gphit, &
+               &               plamscl, pphiscl, zlamscl_m, zphiscl_m )
+         ELSE
+            zlamscl_m = plamscl
+            zphiscl_m = pphiscl
+         ENDIF
+
+         ze1min = MINVAL( e1t(:,:), mask = pmask(:,:) == 1._wp )
+         ze2min = MINVAL( e2t(:,:), mask = pmask(:,:) == 1._wp )
+         
+         IF(lk_mpp) THEN
+            CALL mpp_min( ze1min )
+            CALL mpp_min( ze2min )
+         ENDIF
+
+         kmaxifp = ceiling(zlamscl_m/ze1min) + 1
+         kmaxjfp = ceiling(zphiscl_m/ze2min) + 1
+         
+         !Ensure that these numbers are even
+         kmaxifp = kmaxifp + MOD(kmaxifp,2)
+         kmaxjfp = kmaxjfp + MOD(kmaxjfp,2)
+         
+
+      ENDIF
+
+   END SUBROUTINE obs_max_fpsize
+
+   SUBROUTINE obs_deg2dist( ki, kj, pglam, pgphi, plamscl_deg, pphiscl_deg, &
+      &                     plamscl_max, pphiscl_max )
+      !!-----------------------------------------------------------------------
+      !!
+      !!                     ***  ROUTINE obs_deg2dist  ***
+      !!
+      !! ** Purpose : Calculate the maximum distance in m of the length scale
+      !!              in degrees.
+      !!
+      !! ** Method  : At each lon/lat point, work out the distances in the 
+      !!              zonal and meridional directions.
+      !!
+      !! ** Action  :
+      !!                   
+      !! References : 
+      !!
+      !! History :
+      !!        ! 14/01. M. Martin. 
+      !!-----------------------------------------------------------------------
+      !! * Modules used
+      !! * Arguments
+      INTEGER , INTENT(IN) :: &
+         & ki, kj                   !x/y dimensions of input lat/lon variables
+      REAL(KIND=wp), INTENT(IN), DIMENSION(ki,kj) :: &
+         & pglam, pgphi             !Longitude and latitudes of grid points
+      REAL(KIND=wp), INTENT(IN) :: &
+         & plamscl_deg,   &         !Size in degrees of the observation footprint
+         & pphiscl_deg              !
+      REAL(KIND=wp), INTENT(OUT) :: &
+         & plamscl_max, &           !Maximum size of obs footprint in metres
+         & pphiscl_max
+      
+      !! * Local declarations
+      INTEGER :: &
+         & ji, jj                   !Counters
+      REAL(KIND=wp) :: &
+         & zlon1, zlon2, &          !Lon values surrounding centre of grid point
+         & zlat1, zlat2, &          !Lat values surrounding centre of grid point
+         & zdlat, zdlon             !Distance in radians in lat/lon directions
+      REAL(KIND=wp) :: &
+         & za1, za2, za, zc, zd
+      
+      plamscl_max = -1.0_wp
+      pphiscl_max = -1.0_wp
+
+      DO ji = 1, ki
+         DO jj = 1, kj
+
+            !Calculate distance in metres in zonal(x) direction
+
+            zlon1 = rad * ( pglam(ji,jj) + ( 0.5_wp * plamscl_deg ) )
+            zlon2 = rad * ( pglam(ji,jj) - ( 0.5_wp * plamscl_deg ) )
+            zlat1 = rad * pgphi(ji,jj)
+            zlat2 = rad * pgphi(ji,jj)
+            zdlon = zlon2 - zlon1
+            zdlat = zlat2 - zlat1
+
+            za1 = sin( zdlat/2.0_wp )
+            za2 = sin( zdlon/2.0_wp )
+            za = ( za1 * za1 ) + ( COS( zlat1 ) * COS( zlat2 ) * ( za2 * za2 ) )
+            zc = 2.0_wp * atan2( SQRT( za ), SQRT( 1.0_wp-za ) )
+            zd = ra * zc
+
+            IF ( zd > plamscl_max ) plamscl_max = zd
+
+            !Calculate distance in metres in meridional(y) direction
+
+            zlon1 = rad * pglam(ji,jj)
+            zlon2 = rad * pglam(ji,jj)
+            zlat1 = rad * ( pgphi(ji,jj) + ( 0.5_wp * pphiscl_deg ) )
+            zlat2 = rad * ( pgphi(ji,jj) - ( 0.5_wp * pphiscl_deg ) )
+            zdlon = zlon2 - zlon1
+            zdlat = zlat2 - zlat1
+
+            za1 = sin( zdlat/2.0_wp )
+            za2 = sin( zdlon/2.0_wp )
+            za = ( za1 * za1 ) + ( COS( zlat1 ) * COS( zlat2 ) * ( za2 * za2 ) )
+            zc = 2.0_wp * atan2( SQRT( za ), SQRT( 1.0_wp-za ) )
+            zd = ra * zc
+
+            IF ( zd > pphiscl_max ) pphiscl_max = zd
+
+         END DO
+      END DO
+         
+   END SUBROUTINE obs_deg2dist
+
+   SUBROUTINE obs_dist2corners(pglam_bl, pglam_br, pglam_tl, pglam_tr, &
+      &                        pgphi_bl, pgphi_br, pgphi_tl, pgphi_tr, &
+      &                        plam, pphi, pxvert, pyvert, pdist)
+      !!-----------------------------------------------------------------------
+      !!
+      !!                     ***  ROUTINE obs_dist2corners  ***
+      !!
+      !! ** Purpose : Calculate distance from centre of obs footprint to the corners of a grid box
+      !!
+      !! ** Method  : Use great circle distance formulae.
+      !!              Order of corners is 1=topleft, 2=topright, 3=bottomright, 4=bottomleft
+      !!
+      !! ** Action  :
+      !!                   
+      !! References : 
+      !!
+      !! History :
+      !!        ! 14/01. M. Martin.
+      !!-----------------------------------------------------------------------
+      !! * Modules used
+      !! * Arguments
+         REAL(KIND=wp), INTENT(IN) :: &
+            &  pglam_bl, pglam_br, &       !lon at corners of grid box
+            &  pglam_tl, pglam_tr
+         REAL(KIND=wp), INTENT(IN) :: &
+            &  pgphi_bl, pgphi_br, &       !lat at corners of grid box
+            &  pgphi_tl, pgphi_tr
+         REAL(KIND=wp), INTENT(IN) :: &
+            &  pphi, plam                  !lat/lon of centre of obs footprint
+         REAL(KIND=wp), DIMENSION(4), INTENT(OUT) :: &
+            &  pxvert, pyvert              !x/y location (in metres relative to centre of obs footprint) of corners
+         REAL(KIND=wp), DIMENSION(4), INTENT(OUT) :: &
+            &  pdist                       !distance (in metres) of each corner relative to centre of obs footprint
+
+      !! * Local variables
+         INTEGER :: &
+            &  jvert                       !Counter for corners
+         REAL(KIND=wp) :: &
+            &  zphi, zlam                  !Local values for lon/lat of corners
+         REAL(KIND=wp) :: & 
+            &  za1, za2,  &                !For great circle distance calculations
+            &  zb1, zb2,  &
+            &  zc1, zc2
+         REAL(KIND=wp) :: &
+            &  zdist_centre_lat, &         !Distances in lat/lon directions (in metres)
+            &  zdist_centre_lon
+
+      !!-----------------------------------------------------------------------
+
+         ! Work out latitudinal and longitudinal distance from centre of 
+         ! obs fp to corners of grid box
+         DO jvert = 1, 4
+            SELECT CASE(jvert)
+            CASE(1)
+               zphi = pgphi_tl
+               zlam = pglam_tl
+            CASE(2)
+               zphi = pgphi_tr
+               zlam = pglam_tr
+            CASE(3)
+               zphi = pgphi_br
+               zlam = pglam_br
+            CASE(4)
+               zphi = pgphi_bl
+               zlam = pglam_bl
+            END SELECT
+            
+            IF (zlam == plam ) THEN
+               pxvert(jvert) = 0.0_wp
+            ELSE
+               za1 = SIN( zphi * rad )
+               za2 = SIN( zphi * rad )
+               zb1 = COS( zphi * rad ) * COS( zlam * rad )
+               zb2 = COS( zphi * rad ) * COS( plam  * rad )
+               zc1 = COS( zphi * rad ) * SIN( zlam * rad )
+               zc2 = COS( zphi * rad ) * SIN( plam  * rad )
+               pxvert(jvert) = grt_cir_dis( za1, za2, zb1, zb2, zc1, zc2 )
+               pxvert(jvert) =  ra * pxvert(jvert)
+               IF ( zlam < plam ) pxvert(jvert) = - pxvert(jvert)
+            ENDIF
+            
+            IF ( zphi == pphi ) THEN
+               pyvert(jvert) = 0.0_wp
+            ELSE
+               za1 = SIN( zphi * rad )
+               za2 = SIN( pphi * rad )
+               zb1 = COS( zphi * rad ) * COS( zlam * rad )
+               zb2 = COS( pphi * rad ) * COS( zlam * rad )
+               zc1 = COS( zphi * rad ) * SIN( zlam * rad )
+               zc2 = COS( pphi * rad ) * SIN( zlam * rad )
+               pyvert(jvert) = grt_cir_dis( za1, za2, zb1, zb2, zc1, zc2 )
+               pyvert(jvert) =  ra * pyvert(jvert)
+               IF ( zphi < pphi ) pyvert(jvert) = - pyvert(jvert)
+            ENDIF
+
+            !Calculate the distance of each vertex relative to centre of obs footprint
+            pdist(jvert) = SQRT( ( pxvert(jvert) * pxvert(jvert) ) + &
+               &                 ( pyvert(jvert) * pyvert(jvert) ) )
+
+         END DO
+
+      END SUBROUTINE obs_dist2corners
+
+END MODULE obs_averg_h2d
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/obs_const.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/obs_const.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/obs_const.F90	(revision 9570)
@@ -0,0 +1,23 @@
+MODULE obs_const
+   !!=====================================================================
+   !!                       ***  MODULE obs_const  ***
+   !! Observation diagnostics: Constants used by many modules
+   !!===================================================================== 
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO Consortium (2010)
+   !! $Id$
+   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+
+   !! * Modules used
+   USE par_kind, ONLY : & ! Precision variables
+      & sp         
+   IMPLICIT NONE
+
+   !! * Routine/type accessibility
+   PUBLIC
+
+   REAL(kind=sp), PARAMETER :: obfillflt=99999.
+
+END MODULE obs_const
+
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/obs_conv.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/obs_conv.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/obs_conv.F90	(revision 9570)
@@ -0,0 +1,46 @@
+MODULE obs_conv
+   !!=====================================================================
+   !!                       ***  MODULE  obs_conv  ***
+   !! Observation diagnostics: Various conversion functions
+   !!=====================================================================
+   !!
+   !!   potemp   : Compute potential temperature from insitu temperature,
+   !!              salinity and pressure
+   !!   fspott   : Compute potential temperature from insitu temperature,
+   !!              salinity and pressure
+   !!   atg      : Compute adiabatic temperature gradient deg c per decibar
+   !!   theta    : Compute potential temperature from insitu temperature,
+   !!              salinity and pressure
+   !!   depth    : Compute depth from pressure and latitude.
+   !!   p_to_dep : Compute depth from pressure and latitude 
+   !!              (approximate version)
+   !!   dep_to_p : Compute pressure from depth and latitude 
+   !!              (approximate version)
+   !!---------------------------------------------------------------------
+   !! * Modules used
+   USE par_kind, ONLY : & ! Precision variables
+      & wp   
+   IMPLICIT NONE
+ 
+   !! * Function accessibility
+   PRIVATE
+   PUBLIC &
+      & potemp,   &
+      & fspott,   &
+      & atg,      &
+      & theta,    &
+      & depth,    &
+      & p_to_dep, &
+      & dep_to_p
+   
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO Consortium (2010)
+   !! $Id$
+   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+
+CONTAINS
+
+#include "obs_conv_functions.h90"
+
+END MODULE obs_conv
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/obs_conv_functions.h90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/obs_conv_functions.h90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/obs_conv_functions.h90	(revision 9570)
@@ -0,0 +1,294 @@
+    !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO Consortium (2010)
+   !! $Id$
+   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+
+  REAL(KIND=wp) FUNCTION potemp( ps, pt, pp, ppr )
+      !!----------------------------------------------------------------------
+      !!                    ***  FUNCTION potemp  ***
+      !!          
+      !! ** Purpose : Compute potential temperature
+      !!
+      !! ** Method  : A regression formula is used. 
+      !!
+      !! ** Action  : The code is kept as close to the F77 code as possible
+      !!              Check value: potemp(35,20,2000,0) = 19.621967
+      !!
+      !! References : T. J. Mcdougall, D. R. Jackett, D. G. Wright 
+      !!              and R. Feistel
+      !!              Accurate and computationally efficient algoritms for
+      !!              potential temperatures and density of seawater
+      !!              Journal of atmospheric and oceanic technology
+      !!              Vol 20, 2003, pp 730-741
+      !!              
+      !!
+      !! History :
+      !!        !  07-05 (K. Mogensen) Original code
+      !!----------------------------------------------------------------------
+
+      !! * Arguments
+
+      REAL(KIND=wp), INTENT(IN) :: ps
+      REAL(KIND=wp), INTENT(IN) :: pt
+      REAL(KIND=wp), INTENT(IN) :: pp
+      REAL(KIND=wp), INTENT(IN) :: ppr
+
+      !! * Local declarations
+      REAL(KIND=wp) :: zpol
+      REAL(KIND=wp), PARAMETER :: a1 =  1.067610e-05
+      REAL(KIND=wp), PARAMETER :: a2 = -1.434297e-06
+      REAL(KIND=wp), PARAMETER :: a3 = -7.566349e-09
+      REAL(KIND=wp), PARAMETER :: a4 = -8.535585e-06
+      REAL(KIND=wp), PARAMETER :: a5 =  3.074672e-08
+      REAL(KIND=wp), PARAMETER :: a6 =  1.918639e-08
+      REAL(KIND=wp), PARAMETER :: a7 =  1.788718e-10
+
+      zpol = a1 + a2 * ps + a3 * ( pp + ppr ) + a4 * pt &
+         & + a5 * ps * pt + a6 * pt * pt + a7 * pt * ( pp + ppr )
+      
+      potemp = pt + ( pp - ppr ) * zpol
+      
+   END FUNCTION potemp
+
+   REAL(KIND=wp) FUNCTION fspott( pft, pfs, pfp )
+      !!----------------------------------------------------------------------
+      !!                    ***  FUNCTION fspott  ***
+      !!          
+      !! ** Purpose : Compute potential temperature
+      !!
+      !! ** Method  : A regression formula is used. 
+      !!
+      !! ** Action  : Check value: fspott(10,25,1000) = 8.4678516
+      !!
+      !! References : A. E. Gill
+      !!              Atmosphere-Ocean Dynamics
+      !!              Volume 30 (International Geophysics)
+      !!
+      !! History :
+      !!        !  07-05 (K. Mogensen) NEMO adopting of OPAVAR code.
+      !!----------------------------------------------------------------------
+
+      !! * Arguments
+      REAL(KIND=wp) :: pft   ! in situ temperature in degrees Celsius
+      REAL(KIND=wp) :: pfs   ! salinity in psu
+      REAL(KIND=wp) :: pfp   ! pressure in bars
+      
+      fspott = &
+         &  pft - pfp * (   (            3.6504e-4                     &
+         &                    + pft * (  8.3198e-5                     &
+         &                    + pft * ( -5.4065e-7                     &
+         &                    + pft *    4.0274e-9  ) ) )              &
+         &                + ( pfs - 35.0 ) * (         1.7439e-5       &
+         &                                     - pft * 2.9778e-7 )     &
+         &                + pfp * (            8.9309e-7               &
+         &                          + pft * ( -3.1628e-8               &
+         &                          + pft *    2.1987e-10 )            &
+         &                          - ( pfs - 35.0 ) *  4.1057e-9      &
+         &                          + pfp * (          -1.6056e-10     &
+         &                                    + pft * 5.0484e-12 ) ) )
+
+   END FUNCTION fspott
+
+   REAL(KIND=wp) FUNCTION atg( p_s, p_t, p_p )
+      !!----------------------------------------------------------------------
+      !!                    ***  FUNCTION atg  ***
+      !!          
+      !! ** Purpose : Compute adiabatic temperature gradient deg c per decibar
+      !!
+      !! ** Method  : A regression formula is used
+      !!
+      !! ** Action  : The code is kept as close to the F77 code as possible
+      !!              Check value: atg(40,40,10000) = 3.255974e-4
+      !!
+      !! References : N. P. Fotonoff and R.C. Millard jr., 
+      !!              Algoritms for computation of fundamental
+      !!              properties of seawater
+      !!              Unesco technical papers in marine science 44
+      !!              Unesco 1983
+      !!
+      !! History :
+      !!        !  07-05 (K. Mogensen) Original code based on the F77 code.
+      !!----------------------------------------------------------------------
+
+      !! * Arguments
+
+      REAL(KIND=wp), INTENT(IN) :: p_s    ! Salinity in PSU
+      REAL(KIND=wp), INTENT(IN) :: p_t    ! Temperature in centigrades
+      REAL(KIND=wp), INTENT(IN) :: p_p    ! Pressure in decibars.
+
+      !! * Local declarations
+      
+      REAL(KIND=wp) :: z_ds
+
+      z_ds = p_s - 35.0
+      atg = ((( -2.1687e-16 * p_t + 1.8676e-14 ) * p_t - 4.6206e-13 ) * p_p      &
+         &  + (( 2.7759e-12 * p_t - 1.1351e-10 ) * z_ds + (( - 5.4481e-14 * p_t  &  
+         &  + 8.733e-12 ) * p_t - 6.7795e-10 ) * p_t  + 1.8741e-8)) * p_p        &
+         &  + ( -4.2393e-8 * p_t + 1.8932e-6 ) * z_ds                          &
+         &  + (( 6.6228e-10 * p_t - 6.836e-8 ) * p_t + 8.5258e-6 ) * p_t + 3.5803e-5
+
+   END FUNCTION atg
+      
+   REAL(KIND=wp) FUNCTION theta( p_s, p_t0, p_p0, p_pr )
+      !!----------------------------------------------------------------------
+      !!                    ***  FUNCTION theta  ***
+      !!          
+      !! ** Purpose : Compute potential temperature
+      !!
+      !! ** Method  : A regression formula is used. 
+      !!
+      !! ** Action  : The code is kept as close to the F77 code as possible
+      !!              Check value: theta(40,40,10000,0) = 36.89073
+      !!
+      !! References : N. P. Fotonoff and R.C. Millard jr., 
+      !!              Algoritms for computation of fundamental
+      !!              properties of seawater
+      !!              Unesco technical papers in marine science 44
+      !!              Unesco 1983
+      !!
+      !! History :
+      !!        !  07-05 (K. Mogensen) Original code based on the F77 code.
+      !!----------------------------------------------------------------------
+
+      !! * Arguments
+      REAL(KIND=wp), INTENT(IN) :: p_s
+      REAL(KIND=wp), INTENT(IN) :: p_t0
+      REAL(KIND=wp), INTENT(IN) :: p_p0
+      REAL(KIND=wp), INTENT(IN) :: p_pr
+
+      !! * Local declarations
+      REAL(KIND=wp) :: z_p
+      REAL(KIND=wp) :: z_t
+      REAL(KIND=wp) :: z_h
+      REAL(KIND=wp) :: z_xk
+      REAL(KIND=wp) :: z_q
+
+      z_p = p_p0
+      z_t = p_t0
+      z_h = p_pr - z_p
+      z_xk = z_h * atg( p_s, z_t, z_p ) 
+      Z_t = z_t + 0.5 * z_xk
+      z_q = z_xk
+      z_p = z_p + 0.5 * z_h
+      z_xk = z_h * atg( p_s, z_t, z_p )
+      z_t = z_t + 0.29289322 * ( z_xk - z_q )
+      z_q = 0.58578644 * z_xk + 0.121320344 * z_q
+      z_xk = z_h * atg( p_s, z_t, z_p )
+      z_t = z_t + 1.707106781 * ( z_xk - z_q )
+      z_q = 3.414213562 * z_xk - 4.121320244 * z_q
+      z_p = z_p + 0.5 * z_h
+      z_xk = z_h * atg( p_s, z_t, z_p )
+      theta = z_t + ( z_xk - 2.0 * z_q ) / 6.0
+
+   END FUNCTION theta
+
+   REAL(KIND=wp) FUNCTION depth( p_p, p_lat )
+      !!----------------------------------------------------------------------
+      !!                    ***  FUNCTION depth  ***
+      !!          
+      !! ** Purpose : Compute depth from pressure and latitudes
+      !!
+      !! ** Method  : A regression formula is used. 
+      !!
+      !! ** Action  : The code is kept as close to the F77 code as possible
+      !!              Check value: depth(10000,30) = 9712.653
+      !!
+      !! References : N. P. Fotonoff and R.C. Millard jr., 
+      !!              Algoritms for computation of fundamental
+      !!              properties of seawater
+      !!              Unesco technical papers in marine science 44
+      !!              Unesco 1983
+      !!
+      !! History :
+      !!        !  07-05 (K. Mogensen) Original code based on the F77 code.
+      !!----------------------------------------------------------------------
+
+      !! * Arguments
+      REAL(KIND=wp), INTENT(IN) :: p_p     ! Pressure in decibars
+      REAL(KIND=wp), INTENT(IN) :: p_lat   ! Latitude in degrees
+
+      !! * Local declarations
+      REAL(KIND=wp) :: z_x
+      REAL(KIND=wp) :: z_gr
+      
+      z_x = SIN( p_lat / 57.29578 )
+      z_x = z_x * z_x
+      z_gr = 9.780318 * ( 1.0 + ( 5.2788e-3 + 2.36e-5 * z_x ) * z_x ) + 1.092e-6 * p_p
+      depth = ((( -1.82e-15 * p_p + 2.279e-10 ) * p_p - 2.2512e-5 ) * p_p + 9.72659 ) * p_p
+      depth = depth / z_gr
+
+   END FUNCTION depth
+
+   REAL(KIND=wp) FUNCTION p_to_dep( p_p, p_lat )
+      !!----------------------------------------------------------------------
+      !!                    ***  FUNCTION p_to_dep  ***
+      !!          
+      !! ** Purpose : Compute depth from pressure and latitudes
+      !!
+      !! ** Method  : A regression formula is used. This version is less
+      !!              accurate the "depth" but invertible.
+      !!
+      !! ** Action  : 
+      !!
+      !! References : P.M Saunders
+      !!              Pratical conversion of pressure to depth
+      !!              Journal of physical oceanography Vol 11, 1981, pp 573-574
+      !!
+      !! History :
+      !!        !  07-05  (K. Mogensen) Original code
+      !!----------------------------------------------------------------------
+
+      !! * Arguments
+      REAL(KIND=wp), INTENT(IN) :: p_p    ! Pressure in decibars
+      REAL(KIND=wp), INTENT(IN) :: p_lat  ! Latitude in degrees
+
+      !! * Local declarations
+      REAL(KIND=wp) :: z_x
+      REAL(KIND=wp) :: z_c1
+      REAL(KIND=wp) :: z_c2
+
+      z_x = SIN( p_lat / 57.29578 )
+      z_x = z_x * z_x
+      z_c1 = ( 5.92  + 5.25 * z_x ) * 1e-3 
+      z_c2 = 2.21e-6 
+      p_to_dep = (1 - z_c1)  * p_p - z_c2 * p_p * p_p
+
+   END FUNCTION p_to_dep
+
+   REAL(KIND=wp) FUNCTION dep_to_p( p_dep, p_lat )
+      !!----------------------------------------------------------------------
+      !!                    ***  FUNCTION dep_to_p  ***
+      !!          
+      !! ** Purpose : Compute depth from pressure and latitudes
+      !!
+      !! ** Method  : The expression used in p_to_dep is inverted.
+      !!
+      !! ** Action  : 
+      !!
+      !! References : P.M Saunders
+      !!              Pratical conversion of pressure to depth
+      !!              Journal of physical oceanography Vol 11, 1981, pp 573-574
+      !!
+      !! History :
+      !!        !  07-05  (K. Mogensen) Original code
+      !!----------------------------------------------------------------------
+
+      !! * Arguments
+      REAL(KIND=wp), INTENT(IN) :: p_dep    ! Depth in meters
+      REAL(KIND=wp), INTENT(IN) :: p_lat    ! Latitude in degrees
+
+      !! * Local declarations
+      REAL(KIND=wp) :: z_x
+      REAL(KIND=wp) :: z_c1
+      REAL(KIND=wp) :: z_c2
+      REAL(KIND=wp) :: z_d
+
+      z_x = SIN( p_lat / 57.29578 )
+      z_x = z_x * z_x
+      z_c1 = ( 5.92  + 5.25 * z_x ) * 1e-3 
+      z_c2 = 2.21e-6 
+      z_d = ( z_c1 - 1 ) * ( z_c1 - 1  ) - 4 * z_c2 * p_dep
+      dep_to_p = (( 1 - z_c1 ) - SQRT( z_d )) / ( 2 * z_c2 )
+
+   END FUNCTION dep_to_p
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/obs_fbm.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/obs_fbm.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/obs_fbm.F90	(revision 9570)
@@ -0,0 +1,1998 @@
+MODULE obs_fbm
+   !!======================================================================
+   !!                       ***  MODULE obs_fbm  ***
+   !! Observation operators : I/O + tools for feedback files
+   !!======================================================================
+   !! History : 
+   !!             !  08-11  (K. Mogensen) Initial version
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   init_obfbdata     :  Initialize sizes in obfbdata structure
+   !!   alloc_obfbdata    :  Allocate data in an obfbdata structure
+   !!   dealloc_obfbdata  :  Dellocate data in an obfbdata structure
+   !!   copy_obfbdata     :  Copy an obfbdata structure
+   !!   subsamp_obfbdata  :  Sumsample an obfbdata structure
+   !!   merge_obfbdata    :  Merge multiple obfbdata structures into an one.
+   !!   write_obfbdata    :  Write an obfbdata structure into a netCDF file.
+   !!   read_obfbdata     :  Read an obfbdata structure from a netCDF file.
+   !!----------------------------------------------------------------------
+   USE netcdf
+   USE obs_utils      ! Various utilities for observation operators
+
+   IMPLICIT NONE
+   PUBLIC
+
+   ! Type kinds for feedback data.
+
+   INTEGER, PARAMETER :: fbsp = SELECTED_REAL_KIND( 6, 37) !: single precision
+   INTEGER, PARAMETER :: fbdp = SELECTED_REAL_KIND(12,307) !: double precision
+
+   ! Parameters for string lengths.
+
+   INTEGER, PARAMETER    :: ilenwmo  = 8    !: Length of station identifier
+   INTEGER, PARAMETER    :: ilentyp  = 4    !: Length of type
+   INTEGER, PARAMETER    :: ilenname = 8    !: Length of variable names
+   INTEGER, PARAMETER    :: ilengrid = 1    !: Grid (e.g. 'T') length
+   INTEGER, PARAMETER    :: ilenjuld = 14   !: Lenght of reference julian date
+   INTEGER, PARAMETER    :: idefnqcf = 2    !: Default number of words in QC
+                                            !  flags
+   INTEGER, PARAMETER    :: ilenlong = 128  !: Length of long name
+   INTEGER, PARAMETER    :: ilenunit = 32   !: Length of units
+   
+   ! Missinge data indicators 
+   
+   INTEGER, PARAMETER    :: fbimdi = -99999   !: Integers
+   REAL(fbsp), PARAMETER :: fbrmdi =  99999   !: Reals
+ 
+   ! Main data structure for observation feedback data.
+
+   TYPE obfbdata
+      LOGICAL :: lalloc         !: Allocation status for data
+      LOGICAL :: lgrid          !: Include grid search info
+      INTEGER :: nvar           !: Number of variables
+      INTEGER :: nobs           !: Number of observations
+      INTEGER :: nlev           !: Number of levels
+      INTEGER :: nadd           !: Number of additional entries
+      INTEGER :: next           !: Number of extra variables
+      INTEGER :: nqcf           !: Number of words per qc flag
+      CHARACTER(LEN=ilenwmo), DIMENSION(:), POINTER :: &
+         & cdwmo                !: Identifier
+      CHARACTER(LEN=ilentyp), DIMENSION(:), POINTER :: &
+         & cdtyp                !: Instrument type
+      CHARACTER(LEN=ilenjuld) :: &
+         & cdjuldref            !: Julian date reference
+      INTEGER, DIMENSION(:), POINTER :: &
+         & kindex               !: Index of observations in the original file
+      INTEGER, DIMENSION(:), POINTER :: &
+         & ioqc, &              !: Observation QC
+         & ipqc, &              !: Position QC
+         & itqc                 !: Time QC
+      INTEGER, DIMENSION(:,:), POINTER :: &
+         & ioqcf, &             !: Observation QC flags
+         & ipqcf, &             !: Position QC flags
+         & itqcf                !: Time QC flags
+      INTEGER, DIMENSION(:,:), POINTER :: &
+         & idqc                 !: Depth QC
+      INTEGER, DIMENSION(:,:,:), POINTER :: &
+         & idqcf                !: Depth QC flags
+      REAL(KIND=fbdp), DIMENSION(:), POINTER :: &
+         & plam, &              !: Longitude
+         & pphi, &              !: Latitude
+         & ptim                 !: Time
+      REAL(KIND=fbsp), DIMENSION(:,:), POINTER :: &
+         & pdep                 !: Depth
+      CHARACTER(LEN=ilenname), DIMENSION(:), POINTER  :: &
+         & cname                !: Name of variable
+      REAL(fbsp), DIMENSION(:,:,:), POINTER :: &
+         & pob                  !: Observation
+      CHARACTER(LEN=ilenlong), DIMENSION(:), POINTER :: &
+         & coblong              !: Observation long name (for output)
+      CHARACTER(LEN=ilenunit), DIMENSION(:), POINTER :: &
+         & cobunit              !: Observation units (for output)
+      INTEGER, DIMENSION(:,:), POINTER :: &
+         & ivqc                 !: Variable QC
+      INTEGER, DIMENSION(:,:,:), POINTER :: &
+         & ivqcf                !: Variable QC flags
+      INTEGER, DIMENSION(:,:,:), POINTER :: &
+         & ivlqc                !: Variable level QC
+      INTEGER, DIMENSION(:,:,:,:), POINTER :: &
+         & ivlqcf               !: Variable level QC flags
+      INTEGER, DIMENSION(:,:), POINTER :: &
+         & iproc, &             !: Processor of obs (no I/O for this variable).
+         & iobsi, &             !: Global i index
+         & iobsj                !: Global j index
+      INTEGER, DIMENSION(:,:,:), POINTER :: &
+         & iobsk                !: k index
+      CHARACTER(LEN=ilengrid), DIMENSION(:), POINTER  :: &
+         & cgrid                !: Grid for this variable
+      CHARACTER(LEN=ilenname), DIMENSION(:), POINTER :: &
+         & caddname             !: Additional entries names
+      CHARACTER(LEN=ilenlong), DIMENSION(:,:), POINTER :: &
+         & caddlong             !: Additional entries long name (for output)
+      CHARACTER(LEN=ilenunit), DIMENSION(:,:), POINTER :: &
+         & caddunit             !: Additional entries units (for output)
+      REAL(fbsp), DIMENSION(:,:,:,:)   , POINTER :: &
+         & padd                 !: Additional entries
+      CHARACTER(LEN=ilenname), DIMENSION(:), POINTER :: &
+         & cextname             !: Extra variables names
+      CHARACTER(LEN=ilenlong), DIMENSION(:), POINTER :: &
+         & cextlong             !: Extra variables long name (for output)
+      CHARACTER(LEN=ilenunit), DIMENSION(:), POINTER :: &
+         & cextunit             !: Extra variables units (for output)
+      REAL(fbsp), DIMENSION(:,:,:)   , POINTER :: &
+         & pext                 !: Extra variables
+   END TYPE obfbdata
+
+   PRIVATE putvaratt_obfbdata
+
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO Consortium (2010)
+   !! $Id$
+   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+
+CONTAINS
+
+   SUBROUTINE init_obfbdata( fbdata )
+      !!----------------------------------------------------------------------
+      !!                    ***  ROUTINE init_obfbdata  ***
+      !!
+      !! ** Purpose :   Initialize sizes in obfbdata structure
+      !!
+      !! ** Method  :   
+      !!
+      !! ** Action  : 
+      !!
+      !!----------------------------------------------------------------------
+      !! * Arguments
+      TYPE(obfbdata) :: fbdata      ! obsfbdata structure
+
+      fbdata%nvar   = 0
+      fbdata%nobs   = 0
+      fbdata%nlev   = 0
+      fbdata%nadd   = 0
+      fbdata%next   = 0
+      fbdata%nqcf   = idefnqcf
+      fbdata%lalloc = .FALSE.
+      fbdata%lgrid  = .FALSE.
+
+   END SUBROUTINE init_obfbdata
+   
+   SUBROUTINE alloc_obfbdata( fbdata, kvar, kobs, klev, kadd, kext, lgrid, &
+      &                       kqcf)
+      !!----------------------------------------------------------------------
+      !!                    ***  ROUTINE alloc_obfbdata  ***
+      !!
+      !! ** Purpose :   Allocate data in an obfbdata structure
+      !!
+      !! ** Method  :   
+      !!
+      !! ** Action  : 
+      !!
+      !!----------------------------------------------------------------------
+      !! * Arguments
+      TYPE(obfbdata) ::  fbdata          ! obsfbdata structure to be allocated
+      INTEGER, INTENT(IN) :: kvar        ! Number of variables
+      INTEGER, INTENT(IN) :: kobs        ! Number of observations
+      INTEGER, INTENT(IN) :: klev        ! Number of levels
+      INTEGER, INTENT(IN) :: kadd        ! Number of additional entries
+      INTEGER, INTENT(IN) :: kext        ! Number of extra variables
+      LOGICAL, INTENT(IN) :: lgrid       ! Include grid search information
+      INTEGER, OPTIONAL ::  kqcf         ! Number of words for QC flags
+      !! * Local variables
+      INTEGER :: ji
+      INTEGER :: jv
+
+      ! Check allocation status and deallocate previous allocated structures
+
+      IF ( fbdata%lalloc ) THEN
+         CALL dealloc_obfbdata( fbdata )
+      ENDIF
+
+      ! Set dimensions
+
+      fbdata%lalloc = .TRUE.
+      fbdata%nvar   = kvar
+      fbdata%nobs   = kobs
+      fbdata%nlev   = MAX( klev, 1 )
+      fbdata%nadd   = kadd
+      fbdata%next   = kext
+      IF ( PRESENT(kqcf) ) THEN
+         fbdata%nqcf = kqcf
+      ELSE
+         fbdata%nqcf = idefnqcf
+      ENDIF
+
+      ! Set data not depending on number of observations
+
+      fbdata%cdjuldref  = REPEAT( 'X', ilenjuld )
+
+      ! Allocate and initialize standard data 
+
+      ALLOCATE( &
+         & fbdata%cname(fbdata%nvar),   &
+         & fbdata%coblong(fbdata%nvar), &
+         & fbdata%cobunit(fbdata%nvar)  &
+         & )
+      DO ji = 1, fbdata%nvar
+         WRITE(fbdata%cname(ji),'(A,I2.2)')'V_',ji
+         fbdata%coblong(ji) = REPEAT( ' ', ilenlong )
+         fbdata%cobunit(ji) = REPEAT( ' ', ilenunit )
+      END DO
+
+      ! Optionally also store grid search information
+      
+      IF ( lgrid ) THEN
+         ALLOCATE ( &
+            & fbdata%cgrid(fbdata%nvar) &
+            & )
+         fbdata%cgrid(:)      = REPEAT( 'X', ilengrid )
+         fbdata%lgrid         = .TRUE.
+      ENDIF
+         
+      ! Allocate and initialize additional entries if present
+         
+      IF ( fbdata%nadd > 0 ) THEN
+         ALLOCATE( &
+            & fbdata%caddname(fbdata%nadd),              &
+            & fbdata%caddlong(fbdata%nadd, fbdata%nvar), &
+            & fbdata%caddunit(fbdata%nadd, fbdata%nvar)  &
+            & )
+         DO ji = 1, fbdata%nadd
+            WRITE(fbdata%caddname(ji),'(A,I2.2)')'A',ji
+         END DO
+         DO jv = 1, fbdata%nvar
+            DO ji = 1, fbdata%nadd
+               fbdata%caddlong(ji,jv) = REPEAT( ' ', ilenlong )
+               fbdata%caddunit(ji,jv) = REPEAT( ' ', ilenunit )
+            END DO
+         END DO
+      ENDIF
+         
+      ! Allocate and initialize additional variables if present
+         
+      IF ( fbdata%next > 0 ) THEN
+         ALLOCATE( &
+            & fbdata%cextname(fbdata%next), &
+            & fbdata%cextlong(fbdata%next), &
+            & fbdata%cextunit(fbdata%next)  &
+            & )
+         DO ji = 1, fbdata%next
+            WRITE(fbdata%cextname(ji),'(A,I2.2)')'E_',ji
+            fbdata%cextlong(ji) = REPEAT( ' ', ilenlong )
+            fbdata%cextunit(ji) = REPEAT( ' ', ilenunit )
+         END DO
+      ENDIF
+
+      ! Data depending on number of observations is only allocated if nobs>0
+
+      IF ( fbdata%nobs > 0 ) THEN
+
+         ALLOCATE( &
+            & fbdata%cdwmo(fbdata%nobs),                                      &
+            & fbdata%cdtyp(fbdata%nobs),                                      &
+            & fbdata%ioqc(fbdata%nobs),                                       &
+            & fbdata%ioqcf(fbdata%nqcf,fbdata%nobs),                          &
+            & fbdata%ipqc(fbdata%nobs),                                       &
+            & fbdata%ipqcf(fbdata%nqcf,fbdata%nobs),                          &
+            & fbdata%itqc(fbdata%nobs),                                       &
+            & fbdata%itqcf(fbdata%nqcf,fbdata%nobs),                          &
+            & fbdata%idqc(fbdata%nlev,fbdata%nobs),                           &
+            & fbdata%idqcf(fbdata%nqcf,fbdata%nlev,fbdata%nobs),              &
+            & fbdata%plam(fbdata%nobs),                                       &
+            & fbdata%pphi(fbdata%nobs),                                       &
+            & fbdata%pdep(fbdata%nlev,fbdata%nobs),                           &
+            & fbdata%ptim(fbdata%nobs),                                       &
+            & fbdata%kindex(fbdata%nobs),                                     &
+            & fbdata%ivqc(fbdata%nobs,fbdata%nvar),                           &
+            & fbdata%ivqcf(fbdata%nqcf,fbdata%nobs,fbdata%nvar),              &
+            & fbdata%ivlqc(fbdata%nlev,fbdata%nobs,fbdata%nvar),              &
+            & fbdata%ivlqcf(fbdata%nqcf,fbdata%nlev,fbdata%nobs,fbdata%nvar), &
+            & fbdata%pob(fbdata%nlev,fbdata%nobs,fbdata%nvar)                 &
+            & )
+         fbdata%kindex(:)       = fbimdi
+         fbdata%cdwmo(:)        = REPEAT( 'X', ilenwmo )
+         fbdata%cdtyp(:)        = REPEAT( 'X', ilentyp )
+         fbdata%ioqc(:)         = fbimdi
+         fbdata%ioqcf(:,:)      = fbimdi
+         fbdata%ipqc(:)         = fbimdi
+         fbdata%ipqcf(:,:)      = fbimdi
+         fbdata%itqc(:)         = fbimdi
+         fbdata%itqcf(:,:)      = fbimdi
+         fbdata%idqc(:,:)       = fbimdi
+         fbdata%idqcf(:,:,:)    = fbimdi
+         fbdata%plam(:)         = fbrmdi
+         fbdata%pphi(:)         = fbrmdi
+         fbdata%pdep(:,:)       = fbrmdi
+         fbdata%ptim(:)         = fbrmdi
+         fbdata%ivqc(:,:)       = fbimdi
+         fbdata%ivqcf(:,:,:)    = fbimdi
+         fbdata%ivlqc(:,:,:)    = fbimdi
+         fbdata%ivlqcf(:,:,:,:) = fbimdi
+         fbdata%pob(:,:,:)      = fbrmdi
+         
+         ! Optionally also store grid search information
+         
+         IF ( lgrid ) THEN
+            ALLOCATE ( &
+               & fbdata%iproc(fbdata%nobs,fbdata%nvar),            &
+               & fbdata%iobsi(fbdata%nobs,fbdata%nvar),            &
+               & fbdata%iobsj(fbdata%nobs,fbdata%nvar),            &
+               & fbdata%iobsk(fbdata%nlev,fbdata%nobs,fbdata%nvar) &
+               & )
+            fbdata%iproc(:,:)    = fbimdi
+            fbdata%iobsi(:,:)    = fbimdi
+            fbdata%iobsj(:,:)    = fbimdi
+            fbdata%iobsk(:,:,:)  = fbimdi
+            fbdata%lgrid         = .TRUE.
+         ENDIF
+         
+         ! Allocate and initialize additional entries if present
+         
+         IF ( fbdata%nadd > 0 ) THEN
+            ALLOCATE( &
+               & fbdata%padd(fbdata%nlev,fbdata%nobs,fbdata%nadd,fbdata%nvar) &
+               & )
+            fbdata%padd(:,:,:,:) = fbrmdi
+         ENDIF
+         
+         ! Allocate and initialize additional variables if present
+         
+         IF ( fbdata%next > 0 ) THEN
+            ALLOCATE( &
+               & fbdata%pext(fbdata%nlev,fbdata%nobs,fbdata%next) &
+               & )
+            fbdata%pext(:,:,:) = fbrmdi
+         ENDIF
+
+      ENDIF
+
+   END SUBROUTINE alloc_obfbdata
+
+   SUBROUTINE dealloc_obfbdata( fbdata )
+      !!----------------------------------------------------------------------
+      !!                    ***  ROUTINE dealloc_obfbdata  ***
+      !!
+      !! ** Purpose :   Deallocate data in an obfbdata strucure
+      !!
+      !! ** Method  :   
+      !!
+      !! ** Action  : 
+      !!
+      !!----------------------------------------------------------------------
+      !! * Arguments
+      TYPE(obfbdata) :: fbdata      ! obsfbdata structure
+
+      ! Deallocate data 
+
+      DEALLOCATE( &
+         & fbdata%cname,  &
+         & fbdata%coblong,&
+         & fbdata%cobunit &
+         & )
+
+      ! Deallocate optional grid search information
+      
+      IF ( fbdata%lgrid ) THEN
+         DEALLOCATE ( &
+            & fbdata%cgrid  &
+            & )
+      ENDIF
+
+      ! Deallocate additional entries
+
+      IF ( fbdata%nadd > 0 ) THEN
+         DEALLOCATE( &
+            & fbdata%caddname, &
+            & fbdata%caddlong, &
+            & fbdata%caddunit  &
+            & )
+      ENDIF
+
+      ! Deallocate extra variables
+
+      IF ( fbdata%next > 0 ) THEN
+         DEALLOCATE( &
+            & fbdata%cextname, &
+            & fbdata%cextlong, &
+            & fbdata%cextunit  &
+            & )
+      ENDIF
+
+      ! Deallocate arrays depending on number of obs (if nobs>0 only).
+
+      IF ( fbdata%nobs > 0 ) THEN
+
+         DEALLOCATE( &
+            & fbdata%cdwmo,  &
+            & fbdata%cdtyp,  &
+            & fbdata%ioqc,   &
+            & fbdata%ioqcf,  &
+            & fbdata%ipqc,   &
+            & fbdata%ipqcf,  &
+            & fbdata%itqc,   &
+            & fbdata%itqcf,  &
+            & fbdata%idqc,   &
+            & fbdata%idqcf,  &
+            & fbdata%plam,   &
+            & fbdata%pphi,   &
+            & fbdata%pdep,   &
+            & fbdata%ptim,   &
+            & fbdata%kindex, &
+            & fbdata%ivqc,   &
+            & fbdata%ivqcf,  &
+            & fbdata%ivlqc,  &
+            & fbdata%ivlqcf, &
+            & fbdata%pob     &
+            & )
+
+
+         ! Deallocate optional grid search information
+      
+         IF ( fbdata%lgrid ) THEN
+            DEALLOCATE ( &
+               & fbdata%iproc, &
+               & fbdata%iobsi, &
+               & fbdata%iobsj, &
+               & fbdata%iobsk  & 
+               & )
+         ENDIF
+
+         ! Deallocate additional entries
+
+         IF ( fbdata%nadd > 0 ) THEN
+            DEALLOCATE( &
+               & fbdata%padd       &
+               & )
+         ENDIF
+
+         ! Deallocate extra variables
+
+         IF ( fbdata%next > 0 ) THEN
+            DEALLOCATE( &
+               & fbdata%pext       &
+               & )
+         ENDIF
+
+      ENDIF
+
+      ! Reset arrays sizes
+
+      fbdata%lalloc = .FALSE.
+      fbdata%lgrid  = .FALSE.
+      fbdata%nvar   = 0
+      fbdata%nobs   = 0
+      fbdata%nlev   = 0
+      fbdata%nadd   = 0
+      fbdata%next   = 0
+   
+   END SUBROUTINE dealloc_obfbdata
+
+   SUBROUTINE copy_obfbdata( fbdata1, fbdata2, kadd, kext, lgrid, kqcf )
+      !!----------------------------------------------------------------------
+      !!                    ***  ROUTINE copy_obfbdata  ***
+      !!
+      !! ** Purpose :   Copy an obfbdata structure
+      !!
+      !! ** Method  :   Copy all data from fbdata1 to fbdata2
+      !!                If fbdata2 is allocated it needs to be compliant
+      !!                with fbdata1.
+      !!                Additional entries can be added by setting nadd
+      !!                Additional extra fields can be added by setting next
+      !!                Grid information can be included with lgrid=.true.
+      !!
+      !! ** Action  : 
+      !!
+      !!----------------------------------------------------------------------
+      !! * Arguments
+      TYPE(obfbdata) :: fbdata1               ! Input obsfbdata structure
+      TYPE(obfbdata) :: fbdata2               ! Output obsfbdata structure
+      INTEGER, INTENT(IN), OPTIONAL :: kadd   ! Number of additional entries
+      INTEGER, INTENT(IN), OPTIONAL :: kext   ! Number of extra variables
+      INTEGER, INTENT(IN), OPTIONAL :: kqcf   ! Number of words per qc flags
+      LOGICAL, OPTIONAL :: lgrid              ! Grid info on output file
+
+      !! * Local variables
+      INTEGER :: nadd
+      INTEGER :: next
+      INTEGER :: nqcf
+      LOGICAL :: llgrid
+      INTEGER :: jv
+      INTEGER :: je
+      INTEGER :: ji
+      INTEGER :: jk
+      INTEGER :: jq
+
+      ! Check allocation status of fbdata1
+
+      IF ( .NOT. fbdata1%lalloc ) THEN
+         CALL fatal_error( 'copy_obfbdata: input data not allocated', &
+            &              __LINE__ )
+      ENDIF
+      
+      ! If nadd,next not specified use the ones from fbdata1
+      ! Otherwise check that they have large than the original ones
+      
+      IF ( PRESENT(kadd) ) THEN
+         nadd = kadd
+         IF ( nadd < fbdata1%nadd ) THEN
+            CALL warning    ( 'copy_obfbdata: ' // &
+               &              'nadd smaller than input nadd', __LINE__ )
+         ENDIF
+      ELSE
+         nadd = fbdata1%nadd
+      ENDIF
+      IF ( PRESENT(kext) ) THEN
+         next = kext
+         IF ( next < fbdata1%next ) THEN
+            CALL fatal_error( 'copy_obfbdata: ' // &
+               &              'next smaller than input next', __LINE__ )
+         ENDIF
+      ELSE
+         next = fbdata1%next
+      ENDIF
+      IF ( PRESENT(lgrid) ) THEN
+         llgrid = lgrid
+         IF ( fbdata1%lgrid .AND. (.NOT. llgrid) ) THEN
+            CALL fatal_error( 'copy_obfbdata: ' // &
+               &              'switching off grid info not possible', &
+               &              __LINE__ )
+         ENDIF
+      ELSE
+         llgrid = fbdata1%lgrid
+      ENDIF
+      IF ( PRESENT(kqcf) ) THEN
+         nqcf = kqcf
+         IF ( nqcf < fbdata1%nqcf ) THEN
+            CALL fatal_error( 'copy_obfbdata: ' // &
+               &              'nqcf smaller than input nqcf', __LINE__ )
+         ENDIF
+      ELSE
+         nqcf = fbdata1%nqcf
+      ENDIF
+
+      ! Check allocation status of fbdata2 and 
+      ! a) check that it conforms in size if already allocated
+      ! b) allocate it if not already allocated
+      
+      IF ( fbdata2%lalloc ) THEN
+         IF ( fbdata1%nvar > fbdata2%nvar ) THEN
+            CALL fatal_error( 'copy_obfbdata: ' // &
+               &              'output kvar smaller than input kvar', __LINE__ )
+         ENDIF
+         IF ( fbdata1%nobs > fbdata2%nobs ) THEN
+            CALL fatal_error( 'copy_obfbdata: ' // &
+               &              'output kobs smaller than input kobs', __LINE__ )
+         ENDIF
+         IF ( fbdata1%nlev > fbdata2%nlev ) THEN
+            CALL fatal_error( 'copy_obfbdata: ' // &
+               &              'output klev smaller than input klev', __LINE__ )
+         ENDIF
+         IF ( fbdata1%nadd > fbdata2%nadd ) THEN
+            CALL warning    ( 'copy_obfbdata: ' // &
+               &              'output nadd smaller than input nadd', __LINE__ )
+         ENDIF
+         IF ( fbdata1%next > fbdata2%next ) THEN
+            CALL fatal_error( 'copy_obfbdata: ' // &
+               &              'output next smaller than input next', __LINE__ )
+         ENDIF
+         IF ( fbdata1%lgrid .NEQV. fbdata2%lgrid ) THEN
+            CALL fatal_error( 'copy_obfbdata: ' // &
+               &              'lgrid inconsistent', __LINE__ )
+         ENDIF
+         IF ( fbdata1%next > fbdata2%next ) THEN
+            CALL fatal_error( 'copy_obfbdata: ' // &
+               &              'output next smaller than input next', __LINE__ )
+         ENDIF
+         IF ( fbdata1%nqcf > fbdata2%nqcf ) THEN
+            CALL fatal_error( 'copy_obfbdata: ' // &
+               &              'output  smaller than input kext', __LINE__ )
+         ENDIF
+      ELSE
+         CALL alloc_obfbdata( fbdata2, fbdata1%nvar, fbdata1%nobs, &
+            &                 fbdata1%nlev, nadd, next, llgrid, kqcf = nqcf )
+      ENDIF
+
+      ! Copy the header data
+
+      fbdata2%cdjuldref = fbdata1%cdjuldref
+
+      DO ji = 1, fbdata1%nobs
+         fbdata2%cdwmo(ji)  = fbdata1%cdwmo(ji)
+         fbdata2%cdtyp(ji)  = fbdata1%cdtyp(ji)
+         fbdata2%ioqc(ji)   = fbdata1%ioqc(ji)
+         fbdata2%ipqc(ji)   = fbdata1%ipqc(ji)
+         fbdata2%itqc(ji)   = fbdata1%itqc(ji)
+         fbdata2%plam(ji)   = fbdata1%plam(ji)
+         fbdata2%pphi(ji)   = fbdata1%pphi(ji)
+         fbdata2%ptim(ji)   = fbdata1%ptim(ji)
+         fbdata2%kindex(ji) = fbdata1%kindex(ji)
+         DO jq = 1, fbdata1%nqcf
+            fbdata2%ioqcf(jq,ji)  = fbdata1%ioqcf(jq,ji)
+            fbdata2%ipqcf(jq,ji)  = fbdata1%ipqcf(jq,ji)
+            fbdata2%itqcf(jq,ji)  = fbdata1%itqcf(jq,ji)
+         END DO
+         DO jk = 1, fbdata1%nlev
+            fbdata2%idqc(jk,ji)  = fbdata1%idqc(jk,ji)
+            fbdata2%pdep(jk,ji)  = fbdata1%pdep(jk,ji)
+            DO jq = 1, fbdata1%nqcf
+               fbdata2%idqcf(jq,jk,ji) = fbdata1%idqcf(jq,jk,ji)
+            END DO
+         END DO
+      END DO
+
+      ! Copy the variable data
+
+      DO jv = 1, fbdata1%nvar
+         fbdata2%cname(jv) = fbdata1%cname(jv)
+         fbdata2%coblong(jv) = fbdata1%coblong(jv)
+         fbdata2%cobunit(jv) = fbdata1%cobunit(jv)
+         DO ji = 1, fbdata1%nobs
+            fbdata2%ivqc(ji,jv)  = fbdata1%ivqc(ji,jv)
+            DO jq = 1, fbdata1%nqcf
+               fbdata2%ivqcf(jq,ji,jv) = fbdata1%ivqcf(jq,ji,jv)
+            END DO
+            DO jk = 1, fbdata1%nlev
+               fbdata2%ivlqc(jk,ji,jv)  = fbdata1%ivlqc(jk,ji,jv)
+               fbdata2%pob(jk,ji,jv)    = fbdata1%pob(jk,ji,jv)
+               DO jq = 1, fbdata1%nqcf
+                  fbdata2%ivlqcf(jq,jk,ji,jv) = fbdata1%ivlqcf(jq,jk,ji,jv)
+               END DO
+            END DO
+         END DO
+      END DO
+
+      ! Copy grid information
+      
+      IF ( fbdata1%lgrid ) THEN
+         DO jv = 1, fbdata1%nvar
+            fbdata2%cgrid(jv) = fbdata1%cgrid(jv)
+            DO ji = 1, fbdata1%nobs
+               fbdata2%iproc(ji,jv) = fbdata1%iproc(ji,jv)
+               fbdata2%iobsi(ji,jv) = fbdata1%iobsi(ji,jv)
+               fbdata2%iobsj(ji,jv) = fbdata1%iobsj(ji,jv)
+               DO jk = 1, fbdata1%nlev
+                  fbdata2%iobsk(jk,ji,jv)  = fbdata1%iobsk(jk,ji,jv)
+               END DO
+            END DO
+         END DO
+      ENDIF
+
+      ! Copy additional information
+      
+      DO je = 1, MIN( fbdata1%nadd, fbdata2%nadd )
+         fbdata2%caddname(je) = fbdata1%caddname(je)
+      END DO
+      DO jv = 1, fbdata1%nvar
+         DO je = 1, MIN( fbdata1%nadd, fbdata2%nadd )
+            fbdata2%caddlong(je,jv) = fbdata1%caddlong(je,jv)
+            fbdata2%caddunit(je,jv) = fbdata1%caddunit(je,jv)
+            DO ji = 1, fbdata1%nobs
+               DO jk = 1, fbdata1%nlev
+                  fbdata2%padd(jk,ji,je,jv) = fbdata1%padd(jk,ji,je,jv)
+               END DO
+            END DO
+         END DO
+      END DO
+      
+      ! Copy extra information
+
+      DO je = 1, fbdata1%next
+         fbdata2%cextname(je) = fbdata1%cextname(je)
+         fbdata2%cextlong(je) = fbdata1%cextlong(je)
+         fbdata2%cextunit(je) = fbdata1%cextunit(je)
+      END DO
+      DO je = 1, fbdata1%next
+         DO ji = 1, fbdata1%nobs
+            DO jk = 1, fbdata1%nlev
+               fbdata2%pext(jk,ji,je) = fbdata1%pext(jk,ji,je)
+            END DO
+         END DO
+      END DO
+
+   END SUBROUTINE copy_obfbdata
+
+   SUBROUTINE subsamp_obfbdata( fbdata1, fbdata2, llvalid )
+      !!----------------------------------------------------------------------
+      !!                    ***  ROUTINE susbamp_obfbdata  ***
+      !!
+      !! ** Purpose :   Subsample an obfbdata structure based on the
+      !!                logical mask.
+      !!
+      !! ** Method  :   Copy all data from fbdata1 to fbdata2 if
+      !!                llvalid(obs)==true
+      !!
+      !! ** Action  : 
+      !!
+      !!----------------------------------------------------------------------
+      !! * Arguments
+      TYPE(obfbdata) :: fbdata1           ! Input obsfbdata structure
+      TYPE(obfbdata) :: fbdata2           ! Output obsfbdata structure
+      LOGICAL, DIMENSION(fbdata1%nobs) :: llvalid     ! Grid info on output file
+      !! * Local variables
+      INTEGER :: nobs
+      INTEGER :: jv
+      INTEGER :: je
+      INTEGER :: ji
+      INTEGER :: jk
+      INTEGER :: jq
+      INTEGER :: ij
+
+      ! Check allocation status of fbdata1
+
+      IF ( .NOT. fbdata1%lalloc ) THEN
+         CALL fatal_error( 'copy_obfbdata: input data not allocated', &
+            &              __LINE__ )
+      ENDIF
+      
+      ! Check allocation status of fbdata2 and abort if already allocated
+      
+      IF ( fbdata2%lalloc ) THEN
+         CALL fatal_error( 'subsample_obfbdata: ' // &
+            &              'fbdata2 already allocated', __LINE__ )
+      ENDIF
+      
+      ! Count number of subsampled observations
+
+      nobs = COUNT(llvalid)
+      
+      ! Allocate new data structure
+
+      CALL alloc_obfbdata( fbdata2, fbdata1%nvar, nobs, &
+         &                 fbdata1%nlev, fbdata1%nadd, fbdata1%next, &
+         &                 fbdata1%lgrid, kqcf = fbdata1%nqcf )
+
+      ! Copy the header data
+
+      fbdata2%cdjuldref = fbdata1%cdjuldref
+      
+      ij = 0
+      DO ji = 1, fbdata1%nobs
+         IF ( llvalid(ji) ) THEN
+            ij = ij +1
+            fbdata2%cdwmo(ij)  = fbdata1%cdwmo(ji)
+            fbdata2%cdtyp(ij)  = fbdata1%cdtyp(ji)
+            fbdata2%ioqc(ij)   = fbdata1%ioqc(ji)
+            fbdata2%ipqc(ij)   = fbdata1%ipqc(ji)
+            fbdata2%itqc(ij)   = fbdata1%itqc(ji)
+            fbdata2%plam(ij)   = fbdata1%plam(ji)
+            fbdata2%pphi(ij)   = fbdata1%pphi(ji)
+            fbdata2%ptim(ij)   = fbdata1%ptim(ji)
+            fbdata2%kindex(ij) = fbdata1%kindex(ji)
+            DO jq = 1, fbdata1%nqcf
+               fbdata2%ioqcf(jq,ij)  = fbdata1%ioqcf(jq,ji)
+               fbdata2%ipqcf(jq,ij)  = fbdata1%ipqcf(jq,ji)
+               fbdata2%itqcf(jq,ij)  = fbdata1%itqcf(jq,ji)
+            END DO
+            DO jk = 1, fbdata1%nlev
+               fbdata2%idqc(jk,ij)  = fbdata1%idqc(jk,ji)
+               fbdata2%pdep(jk,ij)  = fbdata1%pdep(jk,ji)
+               DO jq = 1, fbdata1%nqcf
+                  fbdata2%idqcf(jq,jk,ij) = fbdata1%idqcf(jq,jk,ji)
+               END DO
+            END DO
+         ENDIF
+      END DO
+
+      ! Copy the variable data
+
+      DO jv = 1, fbdata1%nvar
+         fbdata2%cname(jv) = fbdata1%cname(jv)
+         fbdata2%coblong(jv) = fbdata1%coblong(jv)
+         fbdata2%cobunit(jv) = fbdata1%cobunit(jv)
+         ij = 0
+         DO ji = 1, fbdata1%nobs
+            IF ( llvalid(ji) ) THEN
+               ij = ij + 1
+               fbdata2%ivqc(ij,jv)  = fbdata1%ivqc(ji,jv)
+               DO jq = 1, fbdata1%nqcf
+                  fbdata2%ivqcf(jq,ij,jv) = fbdata1%ivqcf(jq,ji,jv)
+               END DO
+               DO jk = 1, fbdata1%nlev
+                  fbdata2%ivlqc(jk,ij,jv)  = fbdata1%ivlqc(jk,ji,jv)
+                  fbdata2%pob(jk,ij,jv)    = fbdata1%pob(jk,ji,jv)
+                  DO jq = 1, fbdata1%nqcf
+                     fbdata2%ivlqcf(jq,jk,ij,jv) = fbdata1%ivlqcf(jq,jk,ji,jv)
+                  END DO
+               END DO
+            ENDIF
+         END DO
+      END DO
+
+      ! Copy grid information
+      
+      IF ( fbdata1%lgrid ) THEN
+         DO jv = 1, fbdata1%nvar
+            fbdata2%cgrid(jv) = fbdata1%cgrid(jv)
+            ij = 0
+            DO ji = 1, fbdata1%nobs
+               IF ( llvalid(ji) ) THEN
+                  ij = ij + 1
+                  fbdata2%iproc(ij,jv) = fbdata1%iproc(ji,jv)
+                  fbdata2%iobsi(ij,jv) = fbdata1%iobsi(ji,jv)
+                  fbdata2%iobsj(ij,jv) = fbdata1%iobsj(ji,jv)
+                  DO jk = 1, fbdata1%nlev
+                     fbdata2%iobsk(jk,ij,jv)  = fbdata1%iobsk(jk,ji,jv)
+                  END DO
+               ENDIF
+            END DO
+         END DO
+      ENDIF
+
+      ! Copy additional information
+      
+      DO je = 1, fbdata1%nadd
+         fbdata2%caddname(je) = fbdata1%caddname(je)
+      END DO
+      DO jv = 1, fbdata1%nvar
+         DO je = 1, fbdata1%nadd
+            fbdata2%caddlong(je,jv) = fbdata1%caddlong(je,jv)
+            fbdata2%caddunit(je,jv) = fbdata1%caddunit(je,jv)
+            ij = 0
+            DO ji = 1, fbdata1%nobs
+               IF ( llvalid(ji) ) THEN
+                  ij = ij + 1
+                  DO jk = 1, fbdata1%nlev
+                     fbdata2%padd(jk,ij,je,jv) = fbdata1%padd(jk,ji,je,jv)
+                  END DO
+               ENDIF
+            END DO
+         END DO
+      END DO
+      
+      ! Copy extra information
+
+      DO je = 1, fbdata1%next
+         fbdata2%cextname(je) = fbdata1%cextname(je)
+         fbdata2%cextlong(je) = fbdata1%cextlong(je)
+         fbdata2%cextunit(je) = fbdata1%cextunit(je)
+      END DO
+      DO je = 1, fbdata1%next
+         ij = 0
+         DO ji = 1, fbdata1%nobs
+            IF ( llvalid(ji) ) THEN
+               ij = ij + 1
+               DO jk = 1, fbdata1%nlev
+                  fbdata2%pext(jk,ij,je) = fbdata1%pext(jk,ji,je)
+               END DO
+            ENDIF
+         END DO
+      END DO
+
+   END SUBROUTINE subsamp_obfbdata
+
+   SUBROUTINE merge_obfbdata( nsets, fbdatain, fbdataout, iset, inum, iind )
+      !!----------------------------------------------------------------------
+      !!                    ***  ROUTINE merge_obfbdata  ***
+      !!
+      !! ** Purpose :   Merge multiple obfbdata structures into an one.
+      !!
+      !! ** Method  :   The order of elements is based on the indices in
+      !!                iind.
+      !!                All input data are assumed to be consistent. This
+      !!                is assumed to be checked before calling this routine.
+      !!                Likewise output data is assume to be consistent as 
+      !!                well without error checking.
+      !!
+      !! ** Action  : 
+      !!
+      !!----------------------------------------------------------------------
+      !! * Arguments
+      INTEGER, INTENT(IN):: nsets      ! Number of input data sets 
+      TYPE(obfbdata), DIMENSION(nsets) :: fbdatain  ! Input obsfbdata structure
+      TYPE(obfbdata) :: fbdataout      ! Output obsfbdata structure
+      INTEGER, INTENT(IN), DIMENSION(fbdataout%nobs) :: &
+         & iset                 ! Set number for a given obs.
+      INTEGER, INTENT(IN), DIMENSION(fbdataout%nobs) :: &
+         & inum                 ! Number within set for an obs
+      INTEGER, INTENT(IN), DIMENSION(fbdataout%nobs) :: &
+         & iind                 ! Indices for copying.
+      !! * Local variables
+
+      INTEGER :: js
+      INTEGER :: jo
+      INTEGER :: jv
+      INTEGER :: je
+      INTEGER :: ji
+      INTEGER :: jk
+      INTEGER :: jq
+
+      ! Check allocation status of fbdatain 
+      
+      DO js = 1, nsets
+         IF ( .NOT. fbdatain(js)%lalloc ) THEN
+            CALL fatal_error( 'merge_obfbdata: input data not allocated', &
+               &              __LINE__ )
+         ENDIF
+      END DO
+
+      ! Check allocation status of fbdataout
+      
+      IF ( .NOT.fbdataout%lalloc ) THEN
+         CALL fatal_error( 'merge_obfbdata: output data not allocated', &
+            &              __LINE__ )
+      ENDIF
+
+      ! Merge various names
+
+      DO jv = 1, fbdatain(1)%nvar
+         fbdataout%cname(jv) = fbdatain(1)%cname(jv)
+         fbdataout%coblong(jv) = fbdatain(1)%coblong(jv)
+         fbdataout%cobunit(jv) = fbdatain(1)%cobunit(jv)
+         IF ( fbdatain(1)%lgrid ) THEN
+            fbdataout%cgrid(jv) = fbdatain(1)%cgrid(jv)
+         ENDIF
+      END DO
+      DO jv = 1, fbdatain(1)%nadd
+         fbdataout%caddname(jv) = fbdatain(1)%caddname(jv)
+      END DO
+      DO jv = 1, fbdatain(1)%nvar
+         DO je = 1, fbdatain(1)%nadd
+            fbdataout%caddlong(je,jv) = fbdatain(1)%caddlong(je,jv)
+            fbdataout%caddunit(je,jv) = fbdatain(1)%caddunit(je,jv)
+         END DO
+      END DO
+      DO jv = 1, fbdatain(1)%next
+         fbdataout%cextname(jv) = fbdatain(1)%cextname(jv)
+         fbdataout%cextlong(jv) = fbdatain(1)%cextlong(jv)
+         fbdataout%cextunit(jv) = fbdatain(1)%cextunit(jv)
+      END DO
+      fbdataout%cdjuldref = fbdatain(1)%cdjuldref
+
+      ! Loop over total views
+
+      DO jo = 1, fbdataout%nobs
+
+         js = iset(iind(jo))
+         ji = inum(iind(jo))
+
+         ! Merge the header data
+
+         fbdataout%cdwmo(jo)  = fbdatain(js)%cdwmo(ji)
+         fbdataout%cdtyp(jo)  = fbdatain(js)%cdtyp(ji)
+         fbdataout%ioqc(jo)   = fbdatain(js)%ioqc(ji)
+         fbdataout%ipqc(jo)   = fbdatain(js)%ipqc(ji)
+         fbdataout%itqc(jo)   = fbdatain(js)%itqc(ji)
+         fbdataout%plam(jo)   = fbdatain(js)%plam(ji)
+         fbdataout%pphi(jo)   = fbdatain(js)%pphi(ji)
+         fbdataout%ptim(jo)   = fbdatain(js)%ptim(ji)
+         fbdataout%kindex(jo) = fbdatain(js)%kindex(ji)
+         DO jq = 1, fbdatain(js)%nqcf
+            fbdataout%ioqcf(jq,jo)  = fbdatain(js)%ioqcf(jq,ji)
+            fbdataout%ipqcf(jq,jo)  = fbdatain(js)%ipqcf(jq,ji)
+            fbdataout%itqcf(jq,jo)  = fbdatain(js)%itqcf(jq,ji)
+         END DO
+         DO jk = 1, fbdatain(js)%nlev
+            fbdataout%pdep(jk,jo)  = fbdatain(js)%pdep(jk,ji)
+            fbdataout%idqc(jk,jo)  = fbdatain(js)%idqc(jk,ji)
+            DO jq = 1, fbdatain(js)%nqcf
+               fbdataout%idqcf(jq,jk,jo) = fbdatain(js)%idqcf(jq,jk,ji)
+            END DO
+         END DO
+
+         ! Merge the variable data
+
+         DO jv = 1, fbdatain(js)%nvar
+            fbdataout%ivqc(jo,jv)  = fbdatain(js)%ivqc(ji,jv)
+            DO jq = 1, fbdatain(js)%nqcf
+               fbdataout%ivqcf(jq,jo,jv) = fbdatain(js)%ivqcf(jq,ji,jv)
+            END DO
+            DO jk = 1, fbdatain(js)%nlev
+               fbdataout%ivlqc(jk,jo,jv)  = fbdatain(js)%ivlqc(jk,ji,jv)
+               fbdataout%pob(jk,jo,jv)    = fbdatain(js)%pob(jk,ji,jv)
+               DO jq = 1, fbdatain(js)%nqcf
+                  fbdataout%ivlqcf(jq,jk,jo,jv) = &
+                     &                     fbdatain(js)%ivlqcf(jq,jk,ji,jv)
+               END DO
+            END DO
+         END DO
+
+         ! Merge grid information
+         
+         IF ( fbdatain(js)%lgrid ) THEN
+            DO jv = 1, fbdatain(js)%nvar
+               fbdataout%cgrid(jv) = fbdatain(js)%cgrid(jv)
+               fbdataout%iproc(jo,jv) = fbdatain(js)%iproc(ji,jv)
+               fbdataout%iobsi(jo,jv) = fbdatain(js)%iobsi(ji,jv)
+               fbdataout%iobsj(jo,jv) = fbdatain(js)%iobsj(ji,jv)
+               DO jk = 1, fbdatain(js)%nlev
+                  fbdataout%iobsk(jk,jo,jv)  = fbdatain(js)%iobsk(jk,ji,jv)
+               END DO
+            END DO
+         ENDIF
+
+         ! Merge additional information
+      
+         DO jv = 1, fbdatain(js)%nvar
+            DO je = 1, fbdatain(js)%nadd
+               DO jk = 1, fbdatain(js)%nlev
+                  fbdataout%padd(jk,jo,je,jv) = fbdatain(js)%padd(jk,ji,je,jv)
+               END DO
+            END DO
+         END DO
+         
+         ! Merge extra information
+         
+         DO je = 1, fbdatain(js)%next
+            DO jk = 1, fbdatain(js)%nlev
+               fbdataout%pext(jk,jo,je) = fbdatain(js)%pext(jk,ji,je)
+            END DO
+         END DO
+
+      END DO
+
+   END SUBROUTINE merge_obfbdata
+
+   SUBROUTINE write_obfbdata( cdfilename, fbdata )
+      !!----------------------------------------------------------------------
+      !!                    ***  ROUTINE write_obfbdata  ***
+      !!
+      !! ** Purpose :   Write an obfbdata structure into a netCDF file.
+      !!
+      !! ** Method  :   
+      !!
+      !! ** Action  : 
+      !!
+      !!----------------------------------------------------------------------
+      !! * Arguments
+      CHARACTER(len=*) :: cdfilename ! Output filename
+      TYPE(obfbdata)   :: fbdata     ! obsfbdata structure
+      !! * Local variables
+      CHARACTER(LEN=14), PARAMETER :: cpname = 'write_obfbdata'
+      ! Dimension ids
+      INTEGER :: idfile
+      INTEGER :: idodim
+      INTEGER :: idldim
+      INTEGER :: idvdim
+      INTEGER :: idadim
+      INTEGER :: idedim
+      INTEGER :: idsndim
+      INTEGER :: idsgdim
+      INTEGER :: idswdim
+      INTEGER :: idstdim
+      INTEGER :: idjddim
+      INTEGER :: idqcdim
+      INTEGER :: idvard
+      INTEGER :: idaddd
+      INTEGER :: idextd
+      INTEGER :: idcdwmo
+      INTEGER :: idcdtyp
+      INTEGER :: idplam
+      INTEGER :: idpphi
+      INTEGER :: idpdep
+      INTEGER :: idptim
+      INTEGER :: idptimr
+      INTEGER :: idioqc         
+      INTEGER :: idioqcf         
+      INTEGER :: idipqc
+      INTEGER :: idipqcf
+      INTEGER :: iditqc
+      INTEGER :: iditqcf
+      INTEGER :: ididqc
+      INTEGER :: ididqcf
+      INTEGER :: idkindex
+      INTEGER, DIMENSION(fbdata%nvar) :: &
+         & idpob,    &
+         & idivqc,   &
+         & idivqcf,  &
+         & idivlqc,  &
+         & idivlqcf, &
+         & idiobsi,  &
+         & idiobsj,  &
+         & idiobsk,  &
+         & idcgrid
+      INTEGER, DIMENSION(fbdata%nadd,fbdata%nvar) :: idpadd
+      INTEGER, DIMENSION(fbdata%next) :: idpext
+      INTEGER, DIMENSION(1) :: incdim1
+      INTEGER, DIMENSION(2) :: incdim2
+      INTEGER, DIMENSION(3) :: incdim3
+      INTEGER, DIMENSION(4) :: incdim4
+
+      INTEGER :: jv
+      INTEGER :: je
+      INTEGER :: ioldfill
+      CHARACTER(len=nf90_max_name) :: &
+         & cdtmp
+      CHARACTER(len=16), PARAMETER :: &
+         & cdqcconv = 'q where q =[0,9]'
+      CHARACTER(len=24), PARAMETER :: &
+         & cdqcfconv = 'NEMOVAR flag conventions'
+      CHARACTER(len=ilenlong) :: &
+         & cdltmp
+
+      ! Open output filename
+
+      CALL chkerr( nf90_create( TRIM( cdfilename ), nf90_clobber, idfile ), &
+         &         cpname, __LINE__ )
+      CALL chkerr( nf90_set_fill( idfile, nf90_nofill, ioldfill ), &
+         &         cpname, __LINE__ )
+      CALL chkerr( nf90_put_att( idfile, nf90_global, 'title', &
+         &                       'NEMO observation operator output' ), &
+         &         cpname, __LINE__ )
+      CALL chkerr( nf90_put_att( idfile, nf90_global, 'Convention', &
+         &                       'NEMO unified observation operator output' ),&
+         &         cpname,__LINE__ )
+
+      ! Create the dimensions
+
+      CALL chkerr( nf90_def_dim( idfile, 'N_OBS'  , fbdata%nobs, idodim ),  &
+         &         cpname,__LINE__ )
+      CALL chkerr( nf90_def_dim( idfile, 'N_LEVELS', fbdata%nlev, idldim ), &
+         &         cpname,__LINE__ )
+      CALL chkerr( nf90_def_dim( idfile, 'N_VARS', fbdata%nvar, idvdim ), &
+         &         cpname,__LINE__ )
+      CALL chkerr( nf90_def_dim( idfile, 'N_QCF', fbdata%nqcf, idqcdim ),&
+         &         cpname,__LINE__ )
+      IF ( fbdata%nadd > 0 ) THEN
+         CALL chkerr( nf90_def_dim( idfile, 'N_ENTRIES', fbdata%nadd, idadim ), &
+            &         cpname,__LINE__ )
+      ENDIF
+      IF ( fbdata%next > 0 ) THEN
+         CALL chkerr( nf90_def_dim( idfile, 'N_EXTRA', fbdata%next, idedim ), &
+            &         cpname,__LINE__ )
+      ENDIF
+      CALL chkerr( nf90_def_dim( idfile, 'STRINGNAM', ilenname, idsndim ), &
+         &         cpname,__LINE__ )
+      IF (fbdata%lgrid) THEN
+         CALL chkerr( nf90_def_dim( idfile, 'STRINGGRID', ilengrid, idsgdim ),&
+            &         cpname,__LINE__ )
+      ENDIF
+      CALL chkerr( nf90_def_dim( idfile, 'STRINGWMO', ilenwmo, idswdim ), &
+         &         cpname,__LINE__ )
+      CALL chkerr( nf90_def_dim( idfile, 'STRINGTYP', ilentyp, idstdim ), &
+         &         cpname,__LINE__ )
+      CALL chkerr( nf90_def_dim( idfile, 'STRINGJULD', ilenjuld, idjddim ), &
+         &         cpname,__LINE__ )
+      
+      ! Define netCDF variables for header information
+      
+      incdim2(1) = idsndim
+      incdim2(2) = idvdim
+
+      CALL chkerr( nf90_def_var( idfile, 'VARIABLES', nf90_char, incdim2, &
+         &                       idvard ), cpname, __LINE__ )
+      CALL putvaratt_obfbdata( idfile, idvard, &
+         &                     'List of variables in feedback files' )
+      
+      IF ( fbdata%nadd > 0 ) THEN
+         incdim2(1) = idsndim
+         incdim2(2) = idadim
+         CALL chkerr( nf90_def_var( idfile, 'ENTRIES', nf90_char, incdim2, &
+            &                       idaddd ), cpname, __LINE__ )
+         CALL putvaratt_obfbdata( idfile, idaddd,  &
+            &                     'List of additional entries for each '// &
+            &                     'variable in feedback files' )
+      ENDIF
+   
+      IF ( fbdata%next > 0 ) THEN
+         incdim2(1) = idsndim
+         incdim2(2) = idedim
+         CALL chkerr( nf90_def_var( idfile, 'EXTRA', nf90_char, incdim2, &
+            &                       idextd ), cpname, __LINE__ )
+         CALL putvaratt_obfbdata(  idfile, idextd, &
+            &                      'List of extra variables' )
+      ENDIF
+
+      incdim2(1) = idswdim
+      incdim2(2) = idodim
+      CALL chkerr( nf90_def_var( idfile, 'STATION_IDENTIFIER', &
+         &                       nf90_char, incdim2, &
+         &                       idcdwmo ), cpname, __LINE__ )
+      CALL putvaratt_obfbdata(  idfile, idcdwmo, &
+         &                      'Station identifier' )
+      incdim2(1) = idstdim
+      incdim2(2) = idodim
+      CALL chkerr( nf90_def_var( idfile, 'STATION_TYPE', &
+         &                       nf90_char, incdim2, &
+         &                       idcdtyp ), cpname, __LINE__ )
+      CALL putvaratt_obfbdata(  idfile, idcdtyp, &
+         &                      'Code instrument type' )
+      incdim1(1) = idodim
+      CALL chkerr( nf90_def_var( idfile, 'LONGITUDE', &
+         &                       nf90_double, incdim1, &
+         &                       idplam ), cpname, __LINE__ )
+      CALL putvaratt_obfbdata(  idfile, idplam, &
+         &                      'Longitude', cdunits = 'degrees_east', &
+         &                      rfillvalue = fbrmdi )
+      CALL chkerr( nf90_def_var( idfile, 'LATITUDE', &
+         &                       nf90_double, incdim1, &
+         &                       idpphi ), cpname, __LINE__ )
+      CALL putvaratt_obfbdata(  idfile, idpphi, &
+         &                      'Latitude', cdunits = 'degrees_north', &
+         &                      rfillvalue = fbrmdi )
+      incdim2(1) = idldim
+      incdim2(2) = idodim
+      CALL chkerr( nf90_def_var( idfile, 'DEPTH', &
+         &                       nf90_double, incdim2, &
+         &                       idpdep ), cpname, __LINE__ )
+      CALL putvaratt_obfbdata(  idfile, idpdep, &
+         &                      'Depth', cdunits = 'metre', &
+         &                      rfillvalue = fbrmdi )
+      incdim3(1) = idqcdim
+      incdim3(2) = idldim
+      incdim3(3) = idodim
+      CALL chkerr( nf90_def_var( idfile, 'DEPTH_QC', &
+         &                       nf90_int, incdim2, &
+         &                       ididqc ), cpname, __LINE__ )
+      CALL putvaratt_obfbdata(  idfile, ididqc, &
+         &                      'Quality on depth',  &
+         &                      conventions = cdqcconv, &
+         &                      ifillvalue = 0 )
+      CALL chkerr( nf90_def_var( idfile, 'DEPTH_QC_FLAGS', &
+         &                       nf90_int, incdim3, &
+         &                       ididqcf ), cpname, __LINE__ )
+      CALL putvaratt_obfbdata(  idfile, ididqcf, &
+         &                      'Quality flags on depth',  &
+         &                      conventions = cdqcfconv )
+      CALL chkerr( nf90_def_var( idfile, 'JULD', &
+         &                       nf90_double, incdim1, &
+         &                       idptim ), cpname, __LINE__ )
+      CALL putvaratt_obfbdata(  idfile, idptim, &
+         &                      'Julian day', &
+         &                      cdunits = 'days since JULD_REFERENCE', &
+         &                      conventions = 'relative julian days with '// &
+         &                                 'decimal part (as parts of day)', &
+         &                      rfillvalue = fbrmdi )
+      incdim1(1) = idjddim
+      CALL chkerr( nf90_def_var( idfile, 'JULD_REFERENCE', &
+         &                       nf90_char, incdim1, &
+         &                       idptimr ), cpname, __LINE__ )
+      CALL putvaratt_obfbdata(  idfile, idptimr, &
+         &                      'Date of reference for julian days ', &
+         &                      conventions = 'YYYYMMDDHHMMSS' )
+      incdim1(1) = idodim
+      CALL chkerr( nf90_def_var( idfile, 'OBSERVATION_QC', &
+         &                       nf90_int, incdim1, &
+         &                       idioqc ), cpname, __LINE__ )
+      CALL putvaratt_obfbdata(  idfile, idioqc, &
+         &                      'Quality on observation',  &
+         &                      conventions = cdqcconv, &
+         &                      ifillvalue = 0 )
+      incdim2(1) = idqcdim
+      incdim2(2) = idodim
+      CALL chkerr( nf90_def_var( idfile, 'OBSERVATION_QC_FLAGS', &
+         &                       nf90_int, incdim2, &
+         &                       idioqcf ), cpname, __LINE__ )
+      CALL putvaratt_obfbdata(  idfile, idioqcf, &
+         &                      'Quality flags on observation',  &
+         &                      conventions = cdqcfconv, &
+         &                      ifillvalue = 0 )
+      CALL chkerr( nf90_def_var( idfile, 'POSITION_QC', &
+         &                       nf90_int, incdim1, &
+         &                       idipqc ), cpname, __LINE__ )
+      CALL putvaratt_obfbdata(  idfile, idipqc, &
+         &                      'Quality on position (latitude and longitude)',  &
+         &                      conventions = cdqcconv, &
+         &                      ifillvalue = 0 )
+      CALL chkerr( nf90_def_var( idfile, 'POSITION_QC_FLAGS', &
+         &                       nf90_int, incdim2, &
+         &                       idipqcf ), cpname, __LINE__ )
+      CALL putvaratt_obfbdata(  idfile, idipqcf, &
+         &                      'Quality flags on position',  &
+         &                      conventions = cdqcfconv, &
+         &                      ifillvalue = 0 )
+      CALL chkerr( nf90_def_var( idfile, 'JULD_QC', &
+         &                       nf90_int, incdim1, &
+         &                       iditqc ), cpname, __LINE__ )
+      CALL putvaratt_obfbdata(  idfile, iditqc, &
+         &                      'Quality on date and time',  &
+         &                      conventions = cdqcconv, &
+         &                      ifillvalue = 0 )
+      CALL chkerr( nf90_def_var( idfile, 'JULD_QC_FLAGS', &
+         &                       nf90_int, incdim2, &
+         &                       iditqcf ), cpname, __LINE__ )
+      CALL putvaratt_obfbdata(  idfile, iditqcf, &
+         &                      'Quality flags on date and time',  &
+         &                      conventions = cdqcfconv, &
+         &                      ifillvalue = 0 )
+      CALL chkerr( nf90_def_var( idfile, 'ORIGINAL_FILE_INDEX', &
+         &                       nf90_int, incdim1, &
+         &                       idkindex ), cpname, __LINE__ )
+      CALL putvaratt_obfbdata(  idfile, idkindex, &
+         &                      'Index in original data file',  &
+         &                      ifillvalue = fbimdi )
+
+      ! Define netCDF variables for individual variables
+
+      DO jv = 1, fbdata%nvar
+
+         incdim1(1) = idodim
+         incdim2(1) = idldim
+         incdim2(2) = idodim
+         WRITE(cdtmp,'(2A)') TRIM(fbdata%cname(jv)),'_OBS'
+         CALL chkerr( nf90_def_var( idfile, cdtmp, nf90_float, &
+            &                       incdim2, idpob(jv) ), &
+            &         cpname, __LINE__ )
+         CALL putvaratt_obfbdata(  idfile, idpob(jv), &
+            &                      fbdata%coblong(jv),  &
+            &                      cdunits =  fbdata%cobunit(jv), &
+            &                      rfillvalue = fbrmdi )
+
+         IF ( fbdata%nadd > 0 ) THEN
+            DO je = 1, fbdata%nadd
+               WRITE(cdtmp,'(3A)') TRIM(fbdata%cname(jv)),'_',&
+                  &                TRIM(fbdata%caddname(je))
+               CALL chkerr( nf90_def_var( idfile, cdtmp, nf90_float, &
+                  &                       incdim2, idpadd(je,jv) ), &
+                  &         cpname, __LINE__ )
+               CALL putvaratt_obfbdata(  idfile, idpadd(je,jv), &
+                  &                      fbdata%caddlong(je,jv), &
+                  &                      cdunits =  fbdata%caddunit(je,jv), &
+                  &                      rfillvalue = fbrmdi )
+            END DO
+         ENDIF
+
+         cdltmp = fbdata%coblong(jv)
+         IF (( cdltmp(1:1) >= 'A' ).AND.( cdltmp(1:1) <= 'Z' )) &
+            & cdltmp(1:1) = ACHAR(IACHAR(cdltmp(1:1)) + 32)
+         WRITE(cdtmp,'(2A)') TRIM(fbdata%cname(jv)),'_QC'
+         CALL chkerr( nf90_def_var( idfile, cdtmp, nf90_int, &
+            &                       incdim1, idivqc(jv) ), &
+            &         cpname, __LINE__ )
+         CALL putvaratt_obfbdata(  idfile, idivqc(jv), &
+            &                      'Quality on '//cdltmp,  &
+            &                      conventions = cdqcconv, &
+            &                      ifillvalue = 0 )
+         incdim2(1) = idqcdim
+         incdim2(2) = idodim
+         WRITE(cdtmp,'(2A)') TRIM(fbdata%cname(jv)),'_QC_FLAGS'
+         CALL chkerr( nf90_def_var( idfile, cdtmp, nf90_int, &
+            &                       incdim2, idivqcf(jv) ), &
+            &         cpname, __LINE__ )
+         CALL putvaratt_obfbdata(  idfile, idivqcf(jv), &
+            &                      'Quality flags on '//cdltmp,  &
+            &                      conventions = cdqcfconv, &
+            &                      ifillvalue = 0 )
+         incdim2(1) = idldim
+         incdim2(2) = idodim
+         WRITE(cdtmp,'(2A)') TRIM(fbdata%cname(jv)),'_LEVEL_QC'
+         CALL chkerr( nf90_def_var( idfile, cdtmp, nf90_int, &
+            &                       incdim2, idivlqc(jv) ), &
+            &         cpname, __LINE__ )
+         CALL putvaratt_obfbdata(  idfile, idivlqc(jv), &
+            &                      'Quality for each level on '//cdltmp,  &
+            &                      conventions = cdqcconv, &
+            &                      ifillvalue = 0 )
+         incdim3(1) = idqcdim
+         incdim3(2) = idldim
+         incdim3(3) = idodim
+         WRITE(cdtmp,'(2A)') TRIM(fbdata%cname(jv)),'_LEVEL_QC_FLAGS'
+         CALL chkerr( nf90_def_var( idfile, cdtmp, nf90_int, &
+            &                       incdim3, idivlqcf(jv) ), &
+            &         cpname, __LINE__ )
+         CALL putvaratt_obfbdata(  idfile, idivlqcf(jv), &
+            &                      'Quality flags for each level on '//&
+            &                      cdltmp,  &
+            &                      conventions = cdqcfconv, &
+            &                      ifillvalue = 0 )
+
+         IF (fbdata%lgrid) THEN
+            incdim2(1) = idldim
+            incdim2(2) = idodim
+            WRITE(cdtmp,'(2A)') TRIM(fbdata%cname(jv)),'_IOBSI'
+            CALL chkerr( nf90_def_var( idfile, cdtmp, nf90_int, &
+               &                       incdim1, idiobsi(jv) ), &
+               &         cpname, __LINE__ )
+            CALL putvaratt_obfbdata(  idfile, idiobsi(jv), &
+               &                      'ORCA grid search I coordinate')
+            WRITE(cdtmp,'(2A)') TRIM(fbdata%cname(jv)),'_IOBSJ'
+            CALL chkerr( nf90_def_var( idfile, cdtmp, nf90_int, &
+               &                       incdim1, idiobsj(jv) ), &
+               &         cpname, __LINE__ )
+            CALL putvaratt_obfbdata(  idfile, idiobsj(jv), &
+               &                      'ORCA grid search J coordinate')
+            WRITE(cdtmp,'(2A)') TRIM(fbdata%cname(jv)),'_IOBSK'
+            CALL chkerr( nf90_def_var( idfile, cdtmp, nf90_int, &
+               &                       incdim2, idiobsk(jv) ), &
+               &         cpname, __LINE__ )
+            CALL putvaratt_obfbdata(  idfile, idiobsk(jv), &
+               &                      'ORCA grid search K coordinate')
+            incdim1(1) = idsgdim
+            WRITE(cdtmp,'(2A)') TRIM(fbdata%cname(jv)),'_GRID'
+            CALL chkerr( nf90_def_var( idfile, cdtmp, nf90_char, incdim1, &
+               &                       idcgrid(jv) ), cpname, __LINE__ )
+            CALL putvaratt_obfbdata(  idfile, idcgrid(jv), &
+               &                      'ORCA grid search grid (T,U,V)')
+         ENDIF
+
+      END DO
+
+      IF ( fbdata%next > 0 ) THEN
+         DO je = 1, fbdata%next
+            incdim2(1) = idldim
+            incdim2(2) = idodim
+            WRITE(cdtmp,'(A)') TRIM(fbdata%cextname(je))
+            CALL chkerr( nf90_def_var( idfile, cdtmp, nf90_float, &
+               &                       incdim2, idpext(je) ), &
+               &         cpname, __LINE__ )
+            CALL putvaratt_obfbdata(  idfile, idpext(je), &
+               &                      fbdata%cextlong(je),  &
+               &                      cdunits =  fbdata%cextunit(je), &
+               &                      rfillvalue = fbrmdi )
+         END DO
+      ENDIF
+      
+      ! Stop definitions
+
+      CALL chkerr( nf90_enddef( idfile ), cpname, __LINE__ )
+      
+      ! Write the variables
+      
+      CALL chkerr( nf90_put_var( idfile, idvard, fbdata%cname ), &
+         &         cpname, __LINE__ )
+      
+      IF ( fbdata%nadd > 0 ) THEN
+         CALL chkerr( nf90_put_var( idfile, idaddd, fbdata%caddname ), &
+            &         cpname, __LINE__ )
+      ENDIF
+      
+      IF ( fbdata%next > 0 ) THEN
+         CALL chkerr( nf90_put_var( idfile, idextd, fbdata%cextname ), &
+            &         cpname, __LINE__ )
+      ENDIF
+
+      CALL chkerr( nf90_put_var( idfile, idptimr, fbdata%cdjuldref ), &
+         &         cpname, __LINE__ )
+
+      ! Only write the data if observation is available
+      
+      IF ( fbdata%nobs > 0 ) THEN
+
+         CALL chkerr( nf90_put_var( idfile, idcdwmo, fbdata%cdwmo ), &
+            &         cpname, __LINE__ )
+         CALL chkerr( nf90_put_var( idfile, idcdtyp, fbdata%cdtyp ), &
+            &         cpname, __LINE__ )
+         CALL chkerr( nf90_put_var( idfile, idplam, fbdata%plam ), &
+            &         cpname, __LINE__ )
+         CALL chkerr( nf90_put_var( idfile, idpphi, fbdata%pphi ), &
+            &         cpname, __LINE__ )
+         CALL chkerr( nf90_put_var( idfile, idpdep, fbdata%pdep ), &
+            &         cpname, __LINE__ )
+         CALL chkerr( nf90_put_var( idfile, idptim, fbdata%ptim ), &
+            &         cpname, __LINE__ )
+         CALL chkerr( nf90_put_var( idfile, idioqc, fbdata%ioqc ), &
+            &         cpname, __LINE__ )
+         CALL chkerr( nf90_put_var( idfile, idioqcf, fbdata%ioqcf ), &
+            &         cpname, __LINE__ )
+         CALL chkerr( nf90_put_var( idfile, idipqc, fbdata%ipqc ), &
+            &         cpname, __LINE__ )
+         CALL chkerr( nf90_put_var( idfile, idipqcf, fbdata%ipqcf ), &
+            &         cpname, __LINE__ )
+         CALL chkerr( nf90_put_var( idfile, iditqc, fbdata%itqc ), &
+            &         cpname, __LINE__ )
+         CALL chkerr( nf90_put_var( idfile, iditqcf, fbdata%itqcf ), &
+            &         cpname, __LINE__ )
+         CALL chkerr( nf90_put_var( idfile, ididqc, fbdata%idqc ), &
+            &         cpname, __LINE__ )
+         CALL chkerr( nf90_put_var( idfile, ididqcf, fbdata%idqcf ), &
+            &         cpname, __LINE__ )
+         CALL chkerr( nf90_put_var( idfile, idkindex, fbdata%kindex ), &
+            &         cpname, __LINE__ )
+
+         DO jv = 1, fbdata%nvar
+            CALL chkerr( nf90_put_var( idfile, idpob(jv), fbdata%pob(:,:,jv) ), &
+               &         cpname, __LINE__ )
+            IF ( fbdata%nadd > 0 ) THEN
+               DO je = 1, fbdata%nadd
+                  CALL chkerr( nf90_put_var( idfile, idpadd(je,jv), &
+                     &                       fbdata%padd(:,:,je,jv) ), &
+                     &         cpname, __LINE__ )
+               END DO
+            ENDIF
+            CALL chkerr( nf90_put_var( idfile, idivqc(jv), &
+               &                       fbdata%ivqc(:,jv) ),&
+               &         cpname, __LINE__ )
+            CALL chkerr( nf90_put_var( idfile, idivqcf(jv), &
+               &                       fbdata%ivqcf(:,:,jv) ),&
+               &         cpname, __LINE__ )
+            CALL chkerr( nf90_put_var( idfile, idivlqc(jv), &
+               &                       fbdata%ivlqc(:,:,jv) ),&
+               &         cpname, __LINE__ )
+            CALL chkerr( nf90_put_var( idfile, idivlqcf(jv), &
+               &                       fbdata%ivlqcf(:,:,:,jv) ),&
+               &         cpname, __LINE__ )
+            IF (fbdata%lgrid) THEN
+               CALL chkerr( nf90_put_var( idfile, idiobsi(jv), &
+                  &                       fbdata%iobsi(:,jv) ),&
+                  &         cpname, __LINE__ )
+               CALL chkerr( nf90_put_var( idfile, idiobsj(jv), &
+                  &                       fbdata%iobsj(:,jv) ),&
+                  &         cpname, __LINE__ )
+               CALL chkerr( nf90_put_var( idfile, idiobsk(jv), &
+                  &                       fbdata%iobsk(:,:,jv) ),&
+                  &         cpname, __LINE__ )
+               CALL chkerr( nf90_put_var( idfile, idcgrid(jv), &
+                  &                       fbdata%cgrid(jv) ), &
+                  &         cpname, __LINE__ )
+            ENDIF
+         END DO
+
+         IF ( fbdata%next > 0 ) THEN
+            DO je = 1, fbdata%next
+               CALL chkerr( nf90_put_var( idfile, idpext(je), &
+                  &                       fbdata%pext(:,:,je) ), &
+                  &         cpname, __LINE__ )
+            END DO
+         ENDIF
+
+      ENDIF
+
+      ! Close the file
+
+      CALL chkerr( nf90_close( idfile ), cpname, __LINE__ )
+
+      
+   END SUBROUTINE write_obfbdata
+
+   SUBROUTINE putvaratt_obfbdata( idfile, idvar, cdlongname, cdunits, &
+      &                           conventions, cfillvalue, &
+      &                           ifillvalue, rfillvalue )
+      !!----------------------------------------------------------------------
+      !!                    ***  ROUTINE putvaratt_obfbdata  ***
+      !!
+      !! ** Purpose :   Write netcdf attributes for variable
+      !!
+      !! ** Method  :   
+      !!
+      !! ** Action  : 
+      !!
+      !!----------------------------------------------------------------------
+      !! * Arguments
+      INTEGER :: idfile                    ! File netcdf id.
+      INTEGER :: idvar                     ! Variable netcdf id.
+      CHARACTER(len=*) :: cdlongname       ! Long name for variable
+      CHARACTER(len=*), OPTIONAL :: cdunits       ! Units for variable
+      CHARACTER(len=*), OPTIONAL :: cfillvalue    ! Fill value for character variables
+      INTEGER, OPTIONAL :: ifillvalue             ! Fill value for integer variables
+      REAL(kind=fbsp), OPTIONAL :: rfillvalue     ! Fill value for real variables
+      CHARACTER(len=*), OPTIONAL :: conventions   ! Conventions for variable
+      !! * Local variables
+      CHARACTER(LEN=18), PARAMETER :: &
+         & cpname = 'putvaratt_obfbdata'
+
+      CALL chkerr( nf90_put_att( idfile, idvar, 'long_name', &
+         &                       TRIM(cdlongname) ), &
+         &                       cpname, __LINE__ )
+      
+      IF ( PRESENT(cdunits) ) THEN
+
+         CALL chkerr( nf90_put_att( idfile, idvar, 'units', &
+            &                       TRIM(cdunits) ), &
+            &                       cpname, __LINE__ )
+
+      ENDIF
+
+      IF ( PRESENT(conventions) ) THEN
+
+         CALL chkerr( nf90_put_att( idfile, idvar, 'Conventions', &
+            &                       TRIM(conventions) ), &
+            &                       cpname, __LINE__ )
+
+      ENDIF
+
+      IF ( PRESENT(cfillvalue) ) THEN
+
+         CALL chkerr( nf90_put_att( idfile, idvar, '_Fillvalue', &
+            &                       TRIM(cfillvalue) ), &
+            &                       cpname, __LINE__ )
+
+      ENDIF
+
+      IF ( PRESENT(ifillvalue) ) THEN
+
+         CALL chkerr( nf90_put_att( idfile, idvar, '_Fillvalue', &
+            &                       ifillvalue ), &
+            &                       cpname, __LINE__ )
+
+      ENDIF
+
+      IF ( PRESENT(rfillvalue) ) THEN
+
+         CALL chkerr( nf90_put_att( idfile, idvar, '_Fillvalue', &
+            &                       rfillvalue ), &
+            &                       cpname, __LINE__ )
+
+      ENDIF
+
+   END SUBROUTINE putvaratt_obfbdata
+
+   SUBROUTINE read_obfbdata( cdfilename, fbdata, ldgrid )
+      !!----------------------------------------------------------------------
+      !!                    ***  ROUTINE read_obfbdata  ***
+      !!
+      !! ** Purpose :   Read an obfbdata structure from a netCDF file.
+      !!
+      !! ** Method  :   
+      !!
+      !! ** Action  : 
+      !!
+      !!----------------------------------------------------------------------
+      !! * Arguments
+      CHARACTER(len=*) :: cdfilename  ! Input filename
+      TYPE(obfbdata)   :: fbdata      ! obsfbdata structure
+      LOGICAL, OPTIONAL :: ldgrid     ! Allow forcing of grid info
+      !! * Local variables
+      CHARACTER(LEN=14), PARAMETER :: cpname = 'read_obfbdata'
+      INTEGER :: idfile
+      INTEGER :: idodim
+      INTEGER :: idldim
+      INTEGER :: idvdim
+      INTEGER :: idadim
+      INTEGER :: idedim
+      INTEGER :: idgdim
+      INTEGER :: idvard
+      INTEGER :: idaddd
+      INTEGER :: idextd
+      INTEGER :: idcdwmo
+      INTEGER :: idcdtyp
+      INTEGER :: idplam
+      INTEGER :: idpphi
+      INTEGER :: idpdep
+      INTEGER :: idptim
+      INTEGER :: idptimr
+      INTEGER :: idioqc        
+      INTEGER :: idioqcf
+      INTEGER :: idipqc
+      INTEGER :: idipqcf
+      INTEGER :: ididqc
+      INTEGER :: ididqcf
+      INTEGER :: iditqc
+      INTEGER :: iditqcf
+      INTEGER :: idkindex
+      INTEGER, DIMENSION(:), ALLOCATABLE :: &
+         & idpob,    &
+         & idivqc,   &
+         & idivqcf,  &
+         & idivlqc,  &
+         & idivlqcf, &
+         & idiobsi,  &
+         & idiobsj,  &
+         & idiobsk,  &
+         & idcgrid,  &
+         & idpext
+      INTEGER, DIMENSION(:,:), ALLOCATABLE :: &
+         & idpadd
+      INTEGER :: jv
+      INTEGER :: je
+      INTEGER :: nvar
+      INTEGER :: nobs
+      INTEGER :: nlev
+      INTEGER :: nadd
+      INTEGER :: next
+      LOGICAL :: lgrid
+      CHARACTER(len=NF90_MAX_NAME) :: cdtmp
+
+      ! Check allocation status and deallocate previous allocated structures
+
+      IF ( fbdata%lalloc ) THEN
+         CALL dealloc_obfbdata( fbdata )
+      ENDIF
+
+      ! Open input filename
+
+      CALL chkerr( nf90_open( TRIM( cdfilename ), nf90_nowrite, idfile ), &
+         &         cpname, __LINE__ )
+
+      ! Get input dimensions
+
+      CALL chkerr( nf90_inq_dimid( idfile, 'N_OBS'  , idodim ),  &
+         &         cpname,__LINE__ )
+      CALL chkerr( nf90_inquire_dimension( idfile, idodim, len=nobs ), &
+         &         cpname,__LINE__ )
+      CALL chkerr( nf90_inq_dimid( idfile, 'N_LEVELS', idldim ), &
+         &         cpname,__LINE__ )
+      CALL chkerr( nf90_inquire_dimension( idfile, idldim, len=nlev ), &
+         &         cpname,__LINE__ )
+      CALL chkerr( nf90_inq_dimid( idfile, 'N_VARS', idvdim ), &
+         &         cpname,__LINE__ )
+      CALL chkerr( nf90_inquire_dimension( idfile, idvdim, len=nvar ), &
+         &         cpname,__LINE__ )
+      IF ( nf90_inq_dimid( idfile, 'N_ENTRIES',  idadim ) == 0 ) THEN
+         CALL chkerr( nf90_inquire_dimension( idfile, idadim, len=nadd ), &
+            &         cpname,__LINE__ )
+      ELSE
+         nadd = 0
+      ENDIF
+      IF ( nf90_inq_dimid( idfile, 'N_EXTRA',  idedim ) == 0 ) THEN
+         CALL chkerr( nf90_inquire_dimension( idfile, idedim, len=next ), &
+            &         cpname,__LINE__ )
+      ELSE
+         next = 0
+      ENDIF
+      !
+      ! Check if this input file  contains grid search informations
+      !
+      lgrid = ( nf90_inq_dimid( idfile, 'STRINGGRID',  idgdim ) == 0 )
+
+      ! Allocate data structure
+
+      IF ( PRESENT(ldgrid) ) THEN
+         CALL alloc_obfbdata( fbdata, nvar, nobs, nlev, nadd, next, &
+            & lgrid.OR.ldgrid )
+      ELSE
+         CALL alloc_obfbdata( fbdata, nvar, nobs, nlev, nadd, next, &
+            & lgrid )
+      ENDIF
+
+      ! Allocate netcdf identifiers
+
+      ALLOCATE( &
+         & idpob(fbdata%nvar),    &
+         & idivqc(fbdata%nvar),   &
+         & idivqcf(fbdata%nvar),  &
+         & idivlqc(fbdata%nvar),  &
+         & idivlqcf(fbdata%nvar), &
+         & idiobsi(fbdata%nvar),  &
+         & idiobsj(fbdata%nvar),  &
+         & idiobsk(fbdata%nvar),  &
+         & idcgrid(fbdata%nvar)   &
+         & )
+      IF ( fbdata%nadd > 0 ) THEN
+         ALLOCATE( &
+            & idpadd(fbdata%nadd,fbdata%nvar) &
+            & )
+      ENDIF
+      IF ( fbdata%next > 0 ) THEN
+         ALLOCATE( &
+            & idpext(fbdata%next) &
+            & )
+      ENDIF
+
+      ! Read variables for header information
+
+      CALL chkerr( nf90_inq_varid( idfile, 'VARIABLES',idvard ), &
+         &         cpname, __LINE__ )
+      CALL chkerr( nf90_get_var( idfile, idvard, fbdata%cname ), &
+         &         cpname, __LINE__ )
+      IF ( fbdata%nadd > 0 ) THEN
+         CALL chkerr( nf90_inq_varid( idfile, 'ENTRIES', idaddd ), &
+            &         cpname, __LINE__ )
+         CALL chkerr( nf90_get_var( idfile, idaddd, fbdata%caddname ), &
+            &         cpname, __LINE__ )
+      ENDIF
+      IF ( fbdata%next > 0 ) THEN
+         CALL chkerr( nf90_inq_varid( idfile, 'EXTRA', idextd ), &
+            &         cpname, __LINE__ )
+         CALL chkerr( nf90_get_var( idfile, idextd, fbdata%cextname ), &
+            &         cpname, __LINE__ )
+      ENDIF
+
+      CALL chkerr( nf90_inq_varid( idfile, 'JULD_REFERENCE', idptimr ), &
+         &         cpname, __LINE__ )
+      CALL chkerr( nf90_get_var( idfile, idptimr, fbdata%cdjuldref ), &
+         &         cpname, __LINE__ )
+
+      IF  ( fbdata%nobs > 0 ) THEN
+         
+         CALL chkerr( nf90_inq_varid( idfile, 'STATION_IDENTIFIER', idcdwmo ),&
+            &         cpname, __LINE__ )
+         CALL chkerr( nf90_get_var( idfile, idcdwmo, fbdata%cdwmo ), &
+            &         cpname, __LINE__ )
+         CALL chkerr( nf90_inq_varid( idfile, 'STATION_TYPE', idcdtyp ), &
+            &         cpname, __LINE__ )
+         CALL chkerr( nf90_get_var( idfile, idcdtyp, fbdata%cdtyp), &
+            &         cpname, __LINE__ )
+         CALL chkerr( nf90_inq_varid( idfile, 'LONGITUDE', idplam ), &
+            &         cpname, __LINE__ )
+         CALL chkerr( nf90_get_var( idfile, idplam, fbdata%plam ), &
+            &         cpname, __LINE__ )
+         CALL chkerr( nf90_inq_varid( idfile, 'LATITUDE', idpphi ), &
+            &         cpname, __LINE__ )
+         CALL chkerr( nf90_get_var( idfile, idpphi, fbdata%pphi ), &
+            &         cpname, __LINE__ )
+         CALL chkerr( nf90_inq_varid( idfile, 'DEPTH', idpdep ), &
+            &         cpname, __LINE__ )
+         CALL chkerr( nf90_get_var( idfile, idpdep, fbdata%pdep ), &
+            &         cpname, __LINE__ )
+         CALL chkerr( nf90_inq_varid( idfile, 'JULD', idptim ), &
+            &         cpname, __LINE__ )
+         CALL chkerr( nf90_get_var( idfile, idptim, fbdata%ptim ), &
+            &         cpname, __LINE__ )
+         CALL chkerr( nf90_inq_varid( idfile, 'OBSERVATION_QC', idioqc ), &
+            &         cpname, __LINE__ )
+         CALL chkerr( nf90_get_var( idfile, idioqc, fbdata%ioqc ), &
+            &         cpname, __LINE__ )
+         CALL chkerr( nf90_inq_varid( idfile, 'OBSERVATION_QC_FLAGS', idioqcf ), &
+            &         cpname, __LINE__ )
+         CALL chkerr( nf90_get_var( idfile, idioqcf, fbdata%ioqcf ), &
+            &         cpname, __LINE__ )
+         CALL chkerr( nf90_inq_varid( idfile, 'POSITION_QC', idipqc ), &
+            &         cpname, __LINE__ )
+         CALL chkerr( nf90_get_var( idfile, idipqc, fbdata%ipqc ), &
+            &         cpname, __LINE__ )
+         CALL chkerr( nf90_inq_varid( idfile, 'POSITION_QC_FLAGS', idipqcf ), &
+            &         cpname, __LINE__ )
+         CALL chkerr( nf90_get_var( idfile, idipqcf, fbdata%ipqcf ), &
+            &         cpname, __LINE__ )
+         CALL chkerr( nf90_inq_varid( idfile, 'DEPTH_QC', ididqc ), &
+            &         cpname, __LINE__ )
+         CALL chkerr( nf90_get_var( idfile, ididqc, fbdata%idqc ), &
+            &         cpname, __LINE__ )
+         CALL chkerr( nf90_inq_varid( idfile, 'DEPTH_QC_FLAGS', ididqcf ), &
+            &         cpname, __LINE__ )
+         CALL chkerr( nf90_get_var( idfile, ididqcf, fbdata%idqcf ), &
+            &         cpname, __LINE__ )
+         CALL chkerr( nf90_inq_varid( idfile, 'JULD_QC', iditqc ), &
+            &         cpname, __LINE__ )
+         CALL chkerr( nf90_get_var( idfile, iditqc, fbdata%itqc ), &
+            &         cpname, __LINE__ )
+         CALL chkerr( nf90_inq_varid( idfile, 'JULD_QC_FLAGS', iditqcf ), &
+            &         cpname, __LINE__ )
+         CALL chkerr( nf90_get_var( idfile, iditqcf, fbdata%itqcf ), &
+            &         cpname, __LINE__ )
+         CALL chkerr( nf90_inq_varid( idfile, 'ORIGINAL_FILE_INDEX', idkindex ), &
+            &         cpname, __LINE__ )
+         CALL chkerr( nf90_get_var( idfile, idkindex, fbdata%kindex ), &
+            &         cpname, __LINE__ )
+         
+         ! Read netCDF variables for individual variables
+         
+         DO jv = 1, fbdata%nvar
+            
+            WRITE(cdtmp,'(2A)') TRIM(fbdata%cname(jv)),'_OBS'
+            CALL chkerr( nf90_inq_varid( idfile, cdtmp, idpob(jv) ), &
+               &         cpname, __LINE__ )
+            CALL chkerr( nf90_get_var( idfile, idpob(jv), &
+               &                       fbdata%pob(:,:,jv) ), &
+               &         cpname, __LINE__ )
+            CALL getvaratt_obfbdata( idfile, idpob(jv), &
+               &                     fbdata%coblong(jv), &
+               &                     fbdata%cobunit(jv) )
+            
+            IF ( fbdata%nadd > 0 ) THEN
+               DO je = 1, fbdata%nadd
+                  WRITE(cdtmp,'(3A)') TRIM(fbdata%cname(jv)),'_',&
+                     &                TRIM(fbdata%caddname(je))
+                  CALL chkerr( nf90_inq_varid( idfile, cdtmp, idpadd(je,jv) ), &
+                     &         cpname, __LINE__ )
+                  CALL chkerr( nf90_get_var( idfile, idpadd(je,jv), &
+                     &                       fbdata%padd(:,:,je,jv) ), &
+                     &         cpname, __LINE__ )
+                  CALL getvaratt_obfbdata( idfile, idpadd(je,jv), &
+                     &                     fbdata%caddlong(je,jv), &
+                     &                     fbdata%caddunit(je,jv) )
+               END DO
+            ENDIF
+            
+            WRITE(cdtmp,'(2A)') TRIM(fbdata%cname(jv)),'_QC'
+            CALL chkerr( nf90_inq_varid( idfile, cdtmp, idivqc(jv) ), &
+            &         cpname, __LINE__ )
+            CALL chkerr( nf90_get_var( idfile, idivqc(jv), &
+               &                       fbdata%ivqc(:,jv) ), &
+               &         cpname, __LINE__ )
+            WRITE(cdtmp,'(2A)') TRIM(fbdata%cname(jv)),'_QC_FLAGS'
+            CALL chkerr( nf90_inq_varid( idfile, cdtmp, idivqcf(jv) ), &
+               &         cpname, __LINE__ )
+            CALL chkerr( nf90_get_var( idfile, idivqcf(jv), &
+               &                       fbdata%ivqcf(:,:,jv) ), &
+               &         cpname, __LINE__ )
+            WRITE(cdtmp,'(2A)') TRIM(fbdata%cname(jv)),'_LEVEL_QC'
+            CALL chkerr( nf90_inq_varid( idfile, cdtmp, idivlqc(jv) ), &
+               &         cpname, __LINE__ )
+            CALL chkerr( nf90_get_var( idfile, idivlqc(jv), &
+               &                       fbdata%ivlqc(:,:,jv) ), &
+               &         cpname, __LINE__ )
+            WRITE(cdtmp,'(2A)') TRIM(fbdata%cname(jv)),'_LEVEL_QC_FLAGS'
+            CALL chkerr( nf90_inq_varid( idfile, cdtmp, idivlqcf(jv) ), &
+               &         cpname, __LINE__ )
+            CALL chkerr( nf90_get_var( idfile, idivlqcf(jv), &
+               &                       fbdata%ivlqcf(:,:,:,jv) ), &
+               &         cpname, __LINE__ )
+            IF ( lgrid ) THEN
+               WRITE(cdtmp,'(2A)') TRIM(fbdata%cname(jv)),'_IOBSI'
+               CALL chkerr( nf90_inq_varid( idfile, cdtmp, idiobsi(jv) ), &
+                  &         cpname, __LINE__ )
+               CALL chkerr( nf90_get_var( idfile, idiobsi(jv), &
+                  &                       fbdata%iobsi(:,jv) ), &
+                  &         cpname, __LINE__ )
+               WRITE(cdtmp,'(2A)') TRIM(fbdata%cname(jv)),'_IOBSJ'
+               CALL chkerr( nf90_inq_varid( idfile, cdtmp, idiobsj(jv) ), &
+                  &         cpname, __LINE__ )
+               CALL chkerr( nf90_get_var( idfile, idiobsj(jv), &
+                  &                       fbdata%iobsj(:,jv) ), &
+                  &         cpname, __LINE__ )
+               WRITE(cdtmp,'(2A)') TRIM(fbdata%cname(jv)),'_IOBSK'
+               CALL chkerr( nf90_inq_varid( idfile, cdtmp, idiobsk(jv) ), &
+                  &         cpname, __LINE__ )
+               CALL chkerr( nf90_get_var( idfile, idiobsk(jv), &
+                  &                       fbdata%iobsk(:,:,jv) ), &
+                  &         cpname, __LINE__ )
+               WRITE(cdtmp,'(2A)') TRIM(fbdata%cname(jv)),'_GRID'
+               CALL chkerr( nf90_inq_varid( idfile, cdtmp, idcgrid(jv) ), &
+                  &         cpname, __LINE__ )
+               CALL chkerr( nf90_get_var( idfile, idcgrid(jv), &
+                  &                       fbdata%cgrid(jv) ), &
+                  &         cpname, __LINE__ )
+            ENDIF
+            
+         END DO
+         
+         IF ( fbdata%next > 0 ) THEN
+            DO je = 1, fbdata%next
+               WRITE(cdtmp,'(A)') TRIM(fbdata%cextname(je))
+               CALL chkerr( nf90_inq_varid( idfile, cdtmp, idpext(je) ), &
+                  &         cpname, __LINE__ )
+               CALL chkerr( nf90_get_var( idfile, idpext(je), &
+                  &                       fbdata%pext(:,:,je) ), &
+                  &         cpname, __LINE__ )
+               CALL getvaratt_obfbdata( idfile, idpext(je), &
+                  &                     fbdata%cextlong(je), &
+                  &                     fbdata%cextunit(je) )
+            END DO
+         ENDIF
+
+      ELSE ! if no observations only get attributes
+
+         DO jv = 1, fbdata%nvar            
+
+            WRITE(cdtmp,'(2A)') TRIM(fbdata%cname(jv)),'_OBS'
+            CALL chkerr( nf90_inq_varid( idfile, cdtmp, idpob(jv) ), &
+               &         cpname, __LINE__ )
+            CALL getvaratt_obfbdata( idfile, idpob(jv), &
+               &                     fbdata%coblong(jv), &
+               &                     fbdata%cobunit(jv) )
+            
+            IF ( fbdata%nadd > 0 ) THEN
+               DO je = 1, fbdata%nadd
+                  WRITE(cdtmp,'(3A)') TRIM(fbdata%cname(jv)),'_',&
+                     &                TRIM(fbdata%caddname(je))
+                  CALL chkerr( nf90_inq_varid( idfile, cdtmp, idpadd(je,jv) ), &
+                     &         cpname, __LINE__ )
+                  CALL getvaratt_obfbdata( idfile, idpadd(je,jv), &
+                     &                     fbdata%caddlong(je,jv), &
+                     &                     fbdata%caddunit(je,jv) )
+               END DO
+            ENDIF
+            
+         END DO
+         
+         IF ( fbdata%next > 0 ) THEN
+            DO je = 1, fbdata%next
+               WRITE(cdtmp,'(A)') TRIM(fbdata%cextname(je))
+               CALL chkerr( nf90_inq_varid( idfile, cdtmp, idpext(je) ), &
+                  &         cpname, __LINE__ )
+               CALL getvaratt_obfbdata( idfile, idpext(je), &
+                  &                     fbdata%cextlong(je), &
+                  &                     fbdata%cextunit(je) )
+            END DO
+         ENDIF
+
+      ENDIF
+
+      ! Close the file
+
+      CALL chkerr( nf90_close( idfile ), cpname, __LINE__ )
+
+   END SUBROUTINE read_obfbdata
+
+   SUBROUTINE getvaratt_obfbdata( idfile, idvar, cdlongname, cdunits )
+      !!----------------------------------------------------------------------
+      !!                    ***  ROUTINE putvaratt_obfbdata  ***
+      !!
+      !! ** Purpose :   Read netcdf attributes for variable
+      !!
+      !! ** Method  :   
+      !!
+      !! ** Action  : 
+      !!
+      !!----------------------------------------------------------------------
+      !! * Arguments
+      INTEGER :: idfile      ! File netcdf id.
+      INTEGER :: idvar       ! Variable netcdf id.
+      CHARACTER(len=*) :: cdlongname  ! Long name for variable
+      CHARACTER(len=*) :: cdunits     ! Units for variable
+      !! * Local variables
+      CHARACTER(LEN=18), PARAMETER :: cpname = 'getvaratt_obfbdata'
+
+      CALL chkerr( nf90_get_att( idfile, idvar, 'long_name', &
+         &                       cdlongname ), &
+         &                       cpname, __LINE__ )
+
+      CALL chkerr( nf90_get_att( idfile, idvar, 'units', &
+         &                       cdunits ), &
+         &                       cpname, __LINE__ )
+
+   END SUBROUTINE getvaratt_obfbdata
+
+END MODULE obs_fbm
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/obs_grd_bruteforce.h90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/obs_grd_bruteforce.h90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/obs_grd_bruteforce.h90	(revision 9570)
@@ -0,0 +1,349 @@
+   SUBROUTINE obs_grd_bruteforce( kpi, kpj, kpiglo, kpjglo,       &
+      &                            kldi, klei, kldj, klej,         &
+      &                            kmyproc, ktotproc,              &
+      &                            pglam, pgphi, pmask,            &
+      &                            kobs, plam, pphi, kobsi, kobsj, &
+      &                                   kproc)
+      !!----------------------------------------------------------------------
+      !!                ***  ROUTINE obs_grd_bruteforce ***
+      !!
+      !! ** Purpose : Search gridpoints to find the grid box containing
+      !!              the observations
+      !!
+      !! ** Method  : Call to linquad
+      !!
+      !! ** Action  : Return kproc holding the observation and kiobsi,kobsj
+      !!              valid on kproc=kmyproc processor only.
+      !!   
+      !! History :
+      !!        !  2001-11  (N. Daget, A. Weaver)
+      !!        !  2006-03  (A. Weaver) NEMOVAR migration.
+      !!        !  2006-05  (K. Mogensen) Moved to to separate routine.
+      !!        !  2007-10  (A. Vidard) Bug fix in wrap around checks; cleanup
+      !!----------------------------------------------------------------------
+
+      !! * Arguments
+      INTEGER, INTENT(IN) :: kpi                ! Number of local longitudes
+      INTEGER, INTENT(IN) :: kpj                ! Number of local latitudes
+      INTEGER, INTENT(IN) :: kpiglo             ! Number of global longitudes
+      INTEGER, INTENT(IN) :: kpjglo             ! Number of global latitudes
+      INTEGER, INTENT(IN) :: kldi               ! Start of inner domain in i
+      INTEGER, INTENT(IN) :: klei               ! End of inner domain in i
+      INTEGER, INTENT(IN) :: kldj               ! Start of inner domain in j
+      INTEGER, INTENT(IN) :: klej               ! End of inner domain in j
+      INTEGER, INTENT(IN) :: kmyproc            ! Processor number for MPP
+      INTEGER, INTENT(IN) :: ktotproc           ! Total number of processors
+      REAL(KIND=wp), DIMENSION(kpi,kpj), INTENT(IN) :: &
+         & pglam,   &               ! Grid point longitude
+         & pgphi,   &               ! Grid point latitude
+         & pmask                    ! Grid point mask
+      INTEGER,INTENT(IN) :: kobs                ! Size of the observation arrays
+      REAL(KIND=wp), DIMENSION(kobs), INTENT(IN) :: &
+         & plam, &                  ! Longitude of obsrvations 
+         & pphi                     ! Latitude of observations
+      INTEGER, DIMENSION(kobs), INTENT(OUT) :: &
+         & kobsi, &                 ! I-index of observations 
+         & kobsj, &                 ! J-index of observations 
+         & kproc                    ! Processor number of observations
+  
+      !! * Local declarations
+      REAL(wp), DIMENSION(:), ALLOCATABLE :: &
+         & zplam, zpphi
+      REAL(wp) :: zlammax
+      REAL(wp) :: zlam
+      INTEGER :: ji
+      INTEGER :: jj
+      INTEGER :: jk
+      INTEGER :: jo
+      INTEGER :: jlon
+      INTEGER :: jlat
+      INTEGER :: joffset
+      INTEGER :: jostride
+      REAL(KIND=wp), DIMENSION(:,:), ALLOCATABLE :: &
+         & zlamg, &
+         & zphig, &
+         & zmskg, &
+         & zphitmax,&
+         & zphitmin,&
+         & zlamtmax,&
+         & zlamtmin
+      LOGICAL, DIMENSION(:,:), ALLOCATABLE :: &
+         & llinvalidcell
+      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: &
+         & zlamtm,  &
+         & zphitm
+
+      !-----------------------------------------------------------------------
+      ! Define grid setup for grid search
+      !-----------------------------------------------------------------------
+      IF (ln_grid_global) THEN
+         jlon     = kpiglo
+         jlat     = kpjglo
+         joffset  = kmyproc
+         jostride = ktotproc
+      ELSE
+         jlon     = kpi
+         jlat     = kpj
+         joffset  = 0
+         jostride = 1
+      ENDIF
+      !-----------------------------------------------------------------------
+      ! Set up data for grid search
+      !-----------------------------------------------------------------------
+      ALLOCATE( &
+         & zlamg(jlon,jlat),             &
+         & zphig(jlon,jlat),             &
+         & zmskg(jlon,jlat),             &
+         & zphitmax(jlon-1,jlat-1),      &
+         & zphitmin(jlon-1,jlat-1),      &
+         & zlamtmax(jlon-1,jlat-1),      &
+         & zlamtmin(jlon-1,jlat-1),      &
+         & llinvalidcell(jlon-1,jlat-1), &
+         & zlamtm(4,jlon-1,jlat-1),      &
+         & zphitm(4,jlon-1,jlat-1)       &
+         & )
+      !-----------------------------------------------------------------------
+      ! Copy data to local arrays
+      !-----------------------------------------------------------------------
+      IF (ln_grid_global) THEN
+         zlamg(:,:) = -1.e+10
+         zphig(:,:) = -1.e+10
+         zmskg(:,:) = -1.e+10
+         DO jj = kldj, klej
+            DO ji = kldi, klei
+               zlamg(mig(ji),mjg(jj)) = pglam(ji,jj)
+               zphig(mig(ji),mjg(jj)) = pgphi(ji,jj)
+               zmskg(mig(ji),mjg(jj)) = pmask(ji,jj)
+            END DO
+         END DO
+         CALL mpp_global_max( zlamg )
+         CALL mpp_global_max( zphig )
+         CALL mpp_global_max( zmskg )
+      ELSE
+         DO jj = 1, jlat
+            DO ji = 1, jlon
+               zlamg(ji,jj) = pglam(ji,jj)
+               zphig(ji,jj) = pgphi(ji,jj)
+               zmskg(ji,jj) = pmask(ji,jj)
+            END DO
+         END DO
+      ENDIF
+      !-----------------------------------------------------------------------
+      ! Copy longitudes and latitudes
+      !-----------------------------------------------------------------------
+      ALLOCATE( &
+         & zplam(kobs), &
+         & zpphi(kobs)  &
+         & )
+      DO jo = 1, kobs
+         zplam(jo) = plam(jo)
+         zpphi(jo) = pphi(jo)
+      END DO
+      !-----------------------------------------------------------------------
+      ! Set default values for output
+      !-----------------------------------------------------------------------
+      kproc(:) = -1
+      kobsi(:) = -1
+      kobsj(:) = -1
+      !-----------------------------------------------------------------------
+      ! Copy grid positions to temporary arrays and renormalize to 0 to 360.
+      !-----------------------------------------------------------------------
+      DO jj = 1, jlat-1
+         DO ji = 1, jlon-1
+            zlamtm(1,ji,jj) = zlamg(ji  ,jj  )
+            zphitm(1,ji,jj) = zphig(ji  ,jj  )
+            zlamtm(2,ji,jj) = zlamg(ji+1,jj  )
+            zphitm(2,ji,jj) = zphig(ji+1,jj  )
+            zlamtm(3,ji,jj) = zlamg(ji+1,jj+1)
+            zphitm(3,ji,jj) = zphig(ji+1,jj+1)
+            zlamtm(4,ji,jj) = zlamg(ji  ,jj+1)
+            zphitm(4,ji,jj) = zphig(ji  ,jj+1)
+         END DO
+      END DO
+      WHERE ( zlamtm(:,:,:) < 0.0_wp )
+         zlamtm(:,:,:) = zlamtm(:,:,:) + 360.0_wp
+      END WHERE
+      WHERE ( zlamtm(:,:,:) > 360.0_wp )
+         zlamtm(:,:,:) = zlamtm(:,:,:) - 360.0_wp
+      END WHERE
+      !-----------------------------------------------------------------------
+      ! Handle case of the wraparound; beware, not working with orca180
+      !-----------------------------------------------------------------------
+      DO jj = 1, jlat-1
+         DO ji = 1, jlon-1
+            zlammax = MAXVAL( zlamtm(:,ji,jj) )
+            WHERE (zlammax - zlamtm(:, ji, jj) > 180 ) &
+               & zlamtm(:,ji,jj) = zlamtm(:,ji,jj) + 360._wp
+            zphitmax(ji,jj) = MAXVAL(zphitm(:,ji,jj))
+            zphitmin(ji,jj) = MINVAL(zphitm(:,ji,jj))
+            zlamtmax(ji,jj) = MAXVAL(zlamtm(:,ji,jj))
+            zlamtmin(ji,jj) = MINVAL(zlamtm(:,ji,jj))
+         END DO
+      END DO
+      !-----------------------------------------------------------------------
+      ! Search for boxes with only land points mark them invalid
+      !-----------------------------------------------------------------------
+      llinvalidcell(:,:) = .FALSE.
+      DO jj = 1, jlat-1
+         DO ji = 1, jlon-1
+            llinvalidcell(ji,jj) =               &
+               & zmskg(ji  ,jj  ) == 0.0_wp .AND. &
+               & zmskg(ji+1,jj  ) == 0.0_wp .AND. &
+               & zmskg(ji+1,jj+1) == 0.0_wp .AND. &
+               & zmskg(ji  ,jj+1) == 0.0_wp
+         END DO
+      END DO
+
+      !------------------------------------------------------------------------
+      ! Master loop for grid search
+      !------------------------------------------------------------------------
+
+      DO jo = 1+joffset, kobs, jostride
+
+         !---------------------------------------------------------------------
+         ! Ensure that all observation longtiudes are between 0 and 360
+         !---------------------------------------------------------------------
+
+         IF ( zplam(jo) <   0.0_wp ) zplam(jo) = zplam(jo) + 360.0_wp
+         IF ( zplam(jo) > 360.0_wp ) zplam(jo) = zplam(jo) - 360.0_wp
+
+         !---------------------------------------------------------------------
+         ! Find observations which are on within 1e-6 of a grid point
+         !---------------------------------------------------------------------
+
+         gridloop: DO jj = 1, jlat-1
+            DO ji = 1, jlon-1
+               IF ( ABS( zphig(ji,jj) - zpphi(jo) ) < 1e-6 )  THEN
+                  zlam = zlamg(ji,jj)
+                  IF ( zlam <   0.0_wp ) zlam = zlam + 360.0_wp
+                  IF ( zlam > 360.0_wp ) zlam = zlam - 360.0_wp
+                  IF ( ABS( zlam - zplam(jo) ) < 1e-6 ) THEN
+                     IF ( llinvalidcell(ji,jj) ) THEN
+                        kproc(jo) = kmyproc + 1000000
+                        kobsi(jo) = ji + 1
+                        kobsj(jo) = jj + 1
+                        CYCLE
+                     ELSE
+                        kproc(jo) = kmyproc
+                        kobsi(jo) = ji + 1
+                        kobsj(jo) = jj + 1
+                        EXIT gridloop
+                     ENDIF
+                  ENDIF
+               ENDIF
+            END DO
+         END DO gridloop
+         
+         !---------------------------------------------------------------------
+         ! Ensure that all observation longtiudes are between -180 and 180
+         !---------------------------------------------------------------------
+
+         IF ( zplam(jo) > 180 ) zplam(jo) = zplam(jo) - 360.0_wp
+
+         !---------------------------------------------------------------------
+         ! Do coordinate search using brute force.
+         ! - For land points kproc is set to number of the processor + 1000000
+         !   and we continue the search.
+         ! - For ocean points kproc is set to the number of the processor 
+         !   and we stop the search.
+         !---------------------------------------------------------------------
+
+         IF ( kproc(jo) == -1 ) THEN
+
+            ! Normal case
+            gridpoints : DO jj = 1, jlat-1
+               DO ji = 1, jlon-1
+                  
+                  IF ( ( zplam(jo) > zlamtmax(ji,jj) ) .OR. &
+                     & ( zplam(jo) < zlamtmin(ji,jj) ) ) CYCLE
+                  
+                  IF ( ABS( zpphi(jo) ) < 85 ) THEN
+                     IF ( ( zpphi(jo) > zphitmax(ji,jj) ) .OR. &
+                        & ( zpphi(jo) < zphitmin(ji,jj) ) ) CYCLE
+                  ENDIF
+                  
+                  IF ( linquad( zplam(jo), zpphi(jo), &
+                     &          zlamtm(:,ji,jj), zphitm(:,ji,jj) ) ) THEN
+                     IF ( llinvalidcell(ji,jj) ) THEN
+                        kproc(jo) = kmyproc + 1000000
+                        kobsi(jo) = ji + 1
+                        kobsj(jo) = jj + 1
+                        CYCLE
+                     ELSE
+                        kproc(jo) = kmyproc
+                        kobsi(jo) = ji + 1
+                        kobsj(jo) = jj + 1
+                        EXIT gridpoints
+                     ENDIF
+                  ENDIF
+                  
+               END DO
+            END DO gridpoints
+
+         ENDIF
+
+         ! In case of failure retry for obs. longtiude + 360.
+         IF ( kproc(jo) == -1 ) THEN
+            gridpoints_greenwich : DO jj = 1, jlat-1
+               DO ji = 1, jlon-1
+
+                  IF ( ( zplam(jo)+360.0_wp > zlamtmax(ji,jj) ) .OR. &
+                     & ( zplam(jo)+360.0_wp < zlamtmin(ji,jj) ) ) CYCLE
+
+                  IF ( ABS( zpphi(jo) ) < 85 ) THEN
+                     IF ( ( zpphi(jo) > zphitmax(ji,jj) ) .OR. &
+                        & ( zpphi(jo) < zphitmin(ji,jj) ) ) CYCLE
+                  ENDIF
+
+                  IF ( linquad( zplam(jo)+360.0_wp, zpphi(jo), &
+                     &          zlamtm(:,ji,jj), zphitm(:,ji,jj) ) ) THEN
+                     IF ( llinvalidcell(ji,jj) ) THEN
+                        kproc(jo) = kmyproc + 1000000
+                        kobsi(jo) = ji + 1
+                        kobsj(jo) = jj + 1
+                        CYCLE
+                     ELSE
+                        kproc(jo) = kmyproc
+                        kobsi(jo) = ji + 1
+                        kobsj(jo) = jj + 1
+                        EXIT gridpoints_greenwich
+                     ENDIF
+                  ENDIF
+
+               END DO
+            END DO gridpoints_greenwich
+
+         ENDIF
+      END DO
+
+      !----------------------------------------------------------------------
+      ! Synchronize kproc on all processors
+      !----------------------------------------------------------------------
+      IF ( ln_grid_global ) THEN
+         CALL obs_mpp_max_integer( kproc, kobs )
+         CALL obs_mpp_max_integer( kobsi, kobs )
+         CALL obs_mpp_max_integer( kobsj, kobs )
+      ELSE
+         CALL obs_mpp_find_obs_proc( kproc, kobs )
+      ENDIF
+
+      WHERE( kproc(:) >= 1000000 )
+         kproc(:) = kproc(:) - 1000000
+      END WHERE
+
+      DEALLOCATE( &
+         & zlamg,         &
+         & zphig,         &
+         & zmskg,         &
+         & zphitmax,      &
+         & zphitmin,      &
+         & zlamtmax,      &
+         & zlamtmin,      &
+         & llinvalidcell, &
+         & zlamtm,        &
+         & zphitm,        &
+         & zplam,         &
+         & zpphi          &
+         & )
+
+   END SUBROUTINE obs_grd_bruteforce
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/obs_grid.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/obs_grid.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/obs_grid.F90	(revision 9570)
@@ -0,0 +1,1182 @@
+MODULE obs_grid
+   !!======================================================================
+   !!                       ***  MODULE  obs_grid  ***
+   !! Observation diagnostics: Various tools for grid searching etc.
+   !!======================================================================
+   !!----------------------------------------------------------------------
+   !!   obs_grid_search   : Find i,j on the ORCA grid from lat,lon
+   !!   obs_level_search  : Find level from depth
+   !!   obs_zlevel_search : Find depth level from observed depth
+   !!   obs_tlevel_search : Find temperature level from observed temp
+   !!   obs_rlevel_search : Find density level from observed density
+   !!----------------------------------------------------------------------
+   !! * Modules used   
+   USE par_kind, ONLY : &          ! Precision variables
+      & wp 
+   USE par_oce, ONLY :  &          ! Ocean parameters
+      & jpk,     &
+      & jpni,    &
+      & jpnj,    &
+      & jpnij
+   USE dom_oce                     ! Ocean space and time domain variables
+   USE obs_mpp, ONLY : &           ! MPP support routines for observation diagnostics
+      & obs_mpp_find_obs_proc, &
+      & mpp_global_max,        &
+      & obs_mpp_max_integer
+   USE phycst, ONLY : &            ! Physical constants
+      & rad
+   USE obs_utils, ONLY : &         ! Observation operator utility functions
+      & grt_cir_dis, &
+      & chkerr
+   USE in_out_manager              ! Printing support
+   USE netcdf
+   USE obs_const, ONLY :      &
+      & obfillflt                  ! Fillvalue   
+   USE lib_mpp, ONLY :   &
+      & ctl_warn, ctl_stop
+
+   IMPLICIT NONE
+
+   !! * Routine accessibility
+   PUBLIC  obs_grid_setup,      & ! Setup grid searching
+      &    obs_grid_search,     & ! Find i, j on the ORCA grid from lat, lon
+      &    obs_grid_deallocate, & ! Deallocate the look up table
+      &    obs_level_search       ! Find level from depth
+
+   PRIVATE linquad,                    & ! Determine whether a point lies within a cell
+      &    maxdist,                    & ! Find the maximum distance between 2 pts in a cell
+      &    obs_grd_bruteforce, & ! Find i, j on the ORCA grid from lat, lon
+      &    obs_grd_lookup        ! Find i, j on the ORCA grid from lat, lon quicker
+
+   !!* Module variables
+
+   !! Default values
+   REAL, PUBLIC :: rn_gridsearchres = 0.5   ! Resolution of grid
+   INTEGER, PRIVATE :: gsearch_nlons_def    ! Num of longitudes
+   INTEGER, PRIVATE :: gsearch_nlats_def    ! Num of latitudes
+   REAL(wp), PRIVATE :: gsearch_lonmin_def  ! Min longitude
+   REAL(wp), PRIVATE :: gsearch_latmin_def  ! Min latitude
+   REAL(wp), PRIVATE :: gsearch_dlon_def    ! Lon spacing
+   REAL(wp), PRIVATE :: gsearch_dlat_def    ! Lat spacing
+   !! Variable versions
+   INTEGER, PRIVATE :: nlons     ! Num of longitudes
+   INTEGER, PRIVATE :: nlats     ! Num of latitudes
+   REAL(wp), PRIVATE :: lonmin ! Min longitude
+   REAL(wp), PRIVATE :: latmin ! Min latitude
+   REAL(wp), PRIVATE :: dlon     ! Lon spacing
+   REAL(wp), PRIVATE :: dlat     ! Lat spacing
+   
+   INTEGER, PRIVATE :: maxxdiff, maxydiff ! Max diffs between model points
+   INTEGER, PRIVATE :: limxdiff, limydiff
+   
+   ! Data storage
+   REAL(wp), PRIVATE, DIMENSION(:,:), ALLOCATABLE :: &
+      & lons,  &
+      & lats
+   INTEGER, PRIVATE, DIMENSION(:,:), ALLOCATABLE :: &
+      & ixpos, &
+      & iypos, &
+      & iprocn    
+
+   ! Switches
+   LOGICAL, PUBLIC :: ln_grid_search_lookup  ! Use lookup table to speed up grid search
+   LOGICAL, PUBLIC :: ln_grid_global         ! Use global distribution of observations
+   CHARACTER(LEN=44), PUBLIC :: &
+      & cn_gridsearchfile    ! file name head for grid search lookup 
+
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO Consortium (2010)
+   !! $Id$
+   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+
+CONTAINS
+
+   SUBROUTINE obs_grid_search( kobsin, plam, pphi, kobsi, kobsj, kproc, &
+      &                        cdgrid )
+      !!----------------------------------------------------------------------
+      !!                ***  ROUTINE obs_grid_search ***
+      !!
+      !! ** Purpose : Search local gridpoints to find the grid box containing
+      !!              the observations calls either
+      !!              obs_grd_bruteforce - the original brute force search
+      !!                     or
+      !!              obs_grd_lookup - uses a lookup table to do a fast 
+      !!search
+      !!History :
+      !!        !  2007-12  (D. Lea) 
+      !!------------------------------------------------------------------------
+
+      !! * Arguments
+      INTEGER :: &
+         & kobsin                     ! Size of the observation arrays
+      REAL(KIND=wp), DIMENSION(kobsin), INTENT(IN) :: &
+         & plam, &                  ! Longitude of obsrvations 
+         & pphi                     ! Latitude of observations
+      INTEGER, DIMENSION(kobsin), INTENT(OUT) :: &
+         & kobsi, &                 ! I-index of observations 
+         & kobsj, &                 ! J-index of observations 
+         & kproc                    ! Processor number of observations
+      CHARACTER(LEN=1) :: &
+         & cdgrid                   ! Grid to search
+
+      IF(kobsin > 0) THEN
+
+         IF ( ln_grid_search_lookup .AND. ( cdgrid == 'T' ) ) THEN
+            CALL obs_grd_lookup( kobsin, plam, pphi, &
+               &                         kobsi, kobsj, kproc )
+         ELSE
+            IF ( cdgrid == 'T' ) THEN
+               CALL obs_grd_bruteforce( jpi, jpj, jpiglo, jpjglo, &
+                  &                             1, nlci, 1, nlcj,         &
+                  &                             nproc, jpnij,             &
+                  &                             glamt, gphit, tmask,      &
+                  &                             kobsin, plam, pphi,       &
+                  &                             kobsi, kobsj, kproc )
+            ELSEIF ( cdgrid == 'U' ) THEN
+               CALL obs_grd_bruteforce( jpi, jpj, jpiglo, jpjglo, &
+                  &                             1, nlci, 1, nlcj,         &
+                  &                             nproc, jpnij,             &
+                  &                             glamu, gphiu, umask,      &
+                  &                             kobsin, plam, pphi,       &
+                  &                             kobsi, kobsj, kproc )
+            ELSEIF ( cdgrid == 'V' ) THEN
+               CALL obs_grd_bruteforce( jpi, jpj, jpiglo, jpjglo, &
+                  &                             1, nlci, 1, nlcj,         &
+                  &                             nproc, jpnij,             &
+                  &                             glamv, gphiv, vmask,      &
+                  &                             kobsin, plam, pphi,       &
+                  &                             kobsi, kobsj, kproc )
+            ELSEIF ( cdgrid == 'F' ) THEN
+               CALL obs_grd_bruteforce( jpi, jpj, jpiglo, jpjglo, &
+                  &                             1, nlci, 1, nlcj,         &
+                  &                             nproc, jpnij,             &
+                  &                             glamf, gphif, fmask,      &
+                  &                             kobsin, plam, pphi,       &
+                  &                             kobsi, kobsj, kproc )
+            ELSE
+               CALL ctl_stop( 'Grid not supported' )
+            ENDIF
+         ENDIF
+         
+      ENDIF
+
+   END SUBROUTINE obs_grid_search
+
+#include "obs_grd_bruteforce.h90"
+   
+   SUBROUTINE obs_grd_lookup( kobs, plam, pphi, kobsi, kobsj, kproc )
+      !!----------------------------------------------------------------------
+      !!                ***  ROUTINE obs_grid_lookup ***
+      !!
+      !! ** Purpose : Search local gridpoints to find the grid box containing
+      !!              the observations (much faster then obs_grd_bruteforce)
+      !!
+      !! ** Method  : Call to linquad
+      !!
+      !! ** Action  : Return kproc holding the observation and kiobsi,kobsj
+      !!              valid on kproc=nproc processor only.
+      !!   
+      !! History :
+      !!        !  2007-12 (D. Lea) new routine based on obs_grid_search
+      !!! updated with fixes from new version of obs_grid_search_bruteforce
+      !!! speeded up where points are not near a "difficult" region like an edge
+      !!----------------------------------------------------------------------
+
+      !! * Arguments
+      INTEGER :: kobs                     ! Size of the observation arrays
+      REAL(KIND=wp), DIMENSION(kobs), INTENT(IN) :: &
+         & plam, &                  ! Longitude of obsrvations 
+         & pphi                     ! Latitude of observations
+      INTEGER, DIMENSION(kobs), INTENT(OUT) :: &
+         & kobsi, &                 ! I-index of observations 
+         & kobsj, &                 ! J-index of observations 
+         & kproc                    ! Processor number of observations
+  
+      !! * Local declarations
+      REAL(KIND=wp), DIMENSION(:), ALLOCATABLE :: &
+         & zplam
+      REAL(wp) :: zlammax
+      REAL(wp) :: zlam
+      INTEGER :: ji
+      INTEGER :: jj
+      INTEGER :: jk
+      INTEGER :: jo
+      INTEGER :: isx
+      INTEGER :: isy
+      INTEGER :: jimin
+      INTEGER :: jimax
+      INTEGER :: jjmin
+      INTEGER :: jjmax
+      INTEGER :: jojimin
+      INTEGER :: jojimax
+      INTEGER :: jojjmin
+      INTEGER :: jojjmax
+      INTEGER :: ipx1
+      INTEGER :: ipy1
+      INTEGER :: ip
+      INTEGER :: jp
+      INTEGER :: ipx
+      INTEGER :: ipy
+      INTEGER :: ipmx
+      INTEGER :: jlon
+      INTEGER :: jlat
+      INTEGER :: joffset
+      INTEGER :: jostride
+      REAL(KIND=wp), DIMENSION(:,:), ALLOCATABLE :: &
+         & zlamg, &
+         & zphig, &
+         & zmskg, &
+         & zphitmax,&
+         & zphitmin,&
+         & zlamtmax,&
+         & zlamtmin
+      LOGICAL, DIMENSION(:,:), ALLOCATABLE :: &
+         & llinvalidcell
+      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: &
+         & zlamtm,  &
+         & zphitm
+      LOGICAL :: llfourflag
+      INTEGER :: ifourflagcountt
+      INTEGER :: ifourflagcountf
+      INTEGER, DIMENSION(5) :: ifourflagcountr
+
+      !-----------------------------------------------------------------------
+      ! Define grid for grid search
+      !-----------------------------------------------------------------------
+      IF (ln_grid_global) THEN
+         jlon     = jpiglo
+         jlat     = jpjglo
+         joffset  = nproc
+         jostride = jpnij
+      ELSE
+         jlon     = jpi
+         jlat     = jpj
+         joffset  = 0
+         jostride = 1
+      ENDIF
+      !-----------------------------------------------------------------------
+      ! Set up data for grid search
+      !-----------------------------------------------------------------------
+      ALLOCATE( &
+         & zlamg(jlon,jlat),             &
+         & zphig(jlon,jlat),             &
+         & zmskg(jlon,jlat),             &
+         & zphitmax(jlon-1,jlat-1),      &
+         & zphitmin(jlon-1,jlat-1),      &
+         & zlamtmax(jlon-1,jlat-1),      &
+         & zlamtmin(jlon-1,jlat-1),      &
+         & llinvalidcell(jlon-1,jlat-1), &
+         & zlamtm(4,jlon-1,jlat-1),      &
+         & zphitm(4,jlon-1,jlat-1)       &
+         & )
+      !-----------------------------------------------------------------------
+      ! Copy data to local arrays
+      !-----------------------------------------------------------------------
+      IF (ln_grid_global) THEN
+         zlamg(:,:) = -1.e+10
+         zphig(:,:) = -1.e+10
+         zmskg(:,:) = -1.e+10
+         ! Add various grids here.
+         DO jj = 1, nlcj
+            DO ji = 1, nlci
+               zlamg(mig(ji),mjg(jj)) = glamt(ji,jj)
+               zphig(mig(ji),mjg(jj)) = gphit(ji,jj)
+               zmskg(mig(ji),mjg(jj)) = tmask(ji,jj,1)
+            END DO
+         END DO
+         CALL mpp_global_max( zlamg )
+         CALL mpp_global_max( zphig )
+         CALL mpp_global_max( zmskg )
+      ELSE
+         ! Add various grids here.
+         DO jj = 1, jlat
+            DO ji = 1, jlon
+               zlamg(ji,jj) = glamt(ji,jj)
+               zphig(ji,jj) = gphit(ji,jj)
+               zmskg(ji,jj) = tmask(ji,jj,1)
+            END DO
+         END DO
+      ENDIF
+      !-----------------------------------------------------------------------
+      ! Copy longitudes
+      !----------------------------------------------------------------------- 
+      ALLOCATE( &
+         & zplam(kobs) &
+         & )
+      DO jo = 1, kobs
+         zplam(jo) = plam(jo)
+      END DO
+      !-----------------------------------------------------------------------
+      ! Set default values for output
+      !-----------------------------------------------------------------------
+      kproc(:) = -1
+      kobsi(:) = -1
+      kobsj(:) = -1
+      !-----------------------------------------------------------------------
+      ! Copy grid positions to temporary arrays and renormalize to 0 to 360.
+      !-----------------------------------------------------------------------
+      DO jj = 1, jlat-1
+         DO ji = 1, jlon-1
+            zlamtm(1,ji,jj) = zlamg(ji  ,jj  )
+            zphitm(1,ji,jj) = zphig(ji  ,jj  )
+            zlamtm(2,ji,jj) = zlamg(ji+1,jj  )
+            zphitm(2,ji,jj) = zphig(ji+1,jj  )
+            zlamtm(3,ji,jj) = zlamg(ji+1,jj+1)
+            zphitm(3,ji,jj) = zphig(ji+1,jj+1)
+            zlamtm(4,ji,jj) = zlamg(ji  ,jj+1)
+            zphitm(4,ji,jj) = zphig(ji  ,jj+1)
+         END DO
+      END DO
+      WHERE ( zlamtm(:,:,:) < 0.0_wp )
+         zlamtm(:,:,:) = zlamtm(:,:,:) + 360.0_wp
+      END WHERE
+      WHERE ( zlamtm(:,:,:) > 360.0_wp )
+         zlamtm(:,:,:) = zlamtm(:,:,:) - 360.0_wp
+      END WHERE
+      !-----------------------------------------------------------------------
+      ! Handle case of the wraparound; beware, not working with orca180
+      !-----------------------------------------------------------------------
+      DO jj = 1, jlat-1
+         DO ji = 1, jlon-1
+            zlammax = MAXVAL( zlamtm(:,ji,jj) )
+            WHERE (zlammax - zlamtm(:, ji, jj) > 180 ) & 
+               & zlamtm(:,ji,jj) = zlamtm(:,ji,jj) + 360._wp
+            zphitmax(ji,jj) = MAXVAL(zphitm(:,ji,jj))
+            zphitmin(ji,jj) = MINVAL(zphitm(:,ji,jj))
+            zlamtmax(ji,jj) = MAXVAL(zlamtm(:,ji,jj))
+            zlamtmin(ji,jj) = MINVAL(zlamtm(:,ji,jj))
+         END DO
+      END DO
+      !-----------------------------------------------------------------------
+      ! Search for boxes with only land points mark them invalid
+      !-----------------------------------------------------------------------
+      llinvalidcell(:,:) = .FALSE.
+      DO jj = 1, jlat-1
+         DO ji = 1, jlon-1
+            llinvalidcell(ji,jj) =               &
+               & zmskg(ji  ,jj  ) == 0.0_wp .AND. &
+               & zmskg(ji+1,jj  ) == 0.0_wp .AND. &
+               & zmskg(ji+1,jj+1) == 0.0_wp .AND. &
+               & zmskg(ji  ,jj+1) == 0.0_wp
+         END DO
+      END DO
+
+      if(lwp) WRITE(numout,*) 'obs_grid_lookup do coordinate search using lookup table'
+
+      !-----------------------------------------------------------------------
+      ! Do coordinate search using lookup table with local searches.
+      ! - For land points kproc is set to number of the processor + 1000000
+      !   and we continue the search.
+      ! - For ocean points kproc is set to the number of the processor 
+      !   and we stop the search.
+      !-----------------------------------------------------------------------
+      ifourflagcountt = 0
+      ifourflagcountf = 0
+      ifourflagcountr(:) = 0
+
+      !------------------------------------------------------------------------
+      ! Master loop for grid search
+      !------------------------------------------------------------------------
+         
+      gpkobs: DO jo = 1+joffset, kobs, jostride
+         ! Normal case
+         !        specify 4 points which surround the lat lon of interest
+         !                          x i,j+1  x i+1, j+1
+         !
+         !
+         !                             * lon,lat
+         !                          x i,j    x i+1,j
+
+         ! bottom corner point
+         ipx1 = INT( ( zplam(jo)  - lonmin ) / dlon + 1.0 ) 
+         ipy1 = INT( ( pphi (jo)  - latmin ) / dlat + 1.0 )  
+         
+         ipx = ipx1 + 1
+         ipy = ipy1 + 1
+
+         ! flag for searching around four points separately
+         ! default to false
+         llfourflag = .FALSE.
+         
+         ! check for point fully outside of region
+         IF ( (ipx1 > nlons) .OR. (ipy1 > nlats) .OR. &
+            & (ipx < 1) .OR. (ipy < 1) ) THEN
+            CYCLE
+         ENDIF
+         ! check wrap around
+         IF ( (ipx > nlons) .OR. (ipy > nlats) .OR. &
+            & (ipx1 < 1) .OR. (ipy1 < 1) ) THEN
+            llfourflag=.TRUE.
+            ifourflagcountr(1) = ifourflagcountr(1) + 1
+         ENDIF
+
+         IF (.NOT. llfourflag) THEN
+            IF (MAXVAL(ixpos(ipx1:ipx,ipy1:ipy)) == -1) CYCLE! cycle if no lookup points found
+         ENDIF
+         
+         jimin = 0
+         jimax = 0
+         jjmin = 0
+         jjmax = 0
+         
+         IF (.NOT. llfourflag) THEN 
+
+            ! calculate points range
+            ! define a square region encompassing the four corner points
+            ! do I need the -1 points?
+
+            jojimin = MINVAL(ixpos(ipx1:ipx,ipy1:ipy)) - 1
+            jojimax = MAXVAL(ixpos(ipx1:ipx,ipy1:ipy)) + 1
+            jojjmin = MINVAL(iypos(ipx1:ipx,ipy1:ipy)) - 1
+            jojjmax = MAXVAL(iypos(ipx1:ipx,ipy1:ipy)) + 1
+
+            jimin = jojimin - 1
+            jimax = jojimax + 1
+            jjmin = jojjmin - 1
+            jjmax = jojjmax + 1
+            
+            IF ( jojimin < 0 .OR. jojjmin < 0) THEN 
+               llfourflag = .TRUE.
+               ifourflagcountr(2) = ifourflagcountr(2) + 1
+            ENDIF
+            IF ( jojimax - jojimin > maxxdiff) THEN
+               llfourflag = .TRUE.
+               ifourflagcountr(3) = ifourflagcountr(3) + 1
+            ENDIF
+            IF ( jojjmax - jojjmin > maxydiff) THEN
+               llfourflag = .TRUE.
+               ifourflagcountr(4) = ifourflagcountr(4) + 1
+            ENDIF
+            
+         ENDIF
+
+         ipmx = 0
+         IF (llfourflag) ipmx = 1
+
+         IF (llfourflag) THEN 
+            ifourflagcountt = ifourflagcountt + 1
+         ELSE
+            ifourflagcountf = ifourflagcountf + 1
+         ENDIF
+
+         gridpointsn : DO ip = 0, ipmx
+            DO jp = 0, ipmx
+               
+               IF ( kproc(jo) /= -1 ) EXIT gridpointsn
+        
+               ipx = ipx1 + ip
+               ipy = ipy1 + jp
+               
+               IF (llfourflag) THEN
+
+                  ! deal with wrap around
+                  IF ( ipx > nlons ) ipx = 1
+                  IF ( ipy > nlats ) ipy = 1
+                  IF ( ipx < 1     ) ipx = nlons
+                  IF ( ipy < 1     ) ipy = nlats
+
+                  ! get i,j 
+                  isx = ixpos(ipx,ipy)
+                  isy = iypos(ipx,ipy)
+                  
+                  ! estimate appropriate search region (use max/min values)
+                  jimin = isx - maxxdiff - 1
+                  jimax = isx + maxxdiff + 1
+                  jjmin = isy - maxydiff - 1
+                  jjmax = isy + maxydiff + 1
+
+               ENDIF
+
+               IF ( jimin < 1      ) jimin = 1
+               IF ( jimax > jlon-1 ) jimax = jlon-1
+               IF ( jjmin < 1      ) jjmin = 1
+               IF ( jjmax > jlat-1 ) jjmax = jlat-1
+               
+               !---------------------------------------------------------------
+               ! Ensure that all observation longtiudes are between 0 and 360 
+               !---------------------------------------------------------------
+
+               IF ( zplam(jo) <   0.0_wp ) zplam(jo) = zplam(jo) + 360.0_wp
+               IF ( zplam(jo) > 360.0_wp ) zplam(jo) = zplam(jo) - 360.0_wp
+      
+               !---------------------------------------------------------------
+               ! Find observations which are on within 1e-6 of a grid point
+               !---------------------------------------------------------------
+
+               gridloop: DO jj = jjmin, jjmax
+                  DO ji = jimin, jimax
+                     IF ( ABS( zphig(ji,jj) - pphi(jo) ) < 1e-6 )  THEN
+                        zlam = zlamg(ji,jj)
+                        IF ( zlam <   0.0_wp ) zlam = zlam + 360.0_wp
+                        IF ( zlam > 360.0_wp ) zlam = zlam - 360.0_wp
+                        IF ( ABS( zlam - zplam(jo) ) < 1e-6 ) THEN
+                           IF ( llinvalidcell(ji,jj) ) THEN
+                              kproc(jo) = nproc + 1000000
+                              kobsi(jo) = ji + 1
+                              kobsj(jo) = jj + 1
+                              CYCLE
+                           ELSE
+                              kproc(jo) = nproc
+                              kobsi(jo) = ji + 1
+                              kobsj(jo) = jj + 1
+                              EXIT gridloop
+                           ENDIF
+                        ENDIF
+                     ENDIF
+                  END DO
+               END DO gridloop
+
+               !---------------------------------------------------------------
+               ! Ensure that all observation longtiudes are between -180/180
+               !---------------------------------------------------------------
+
+               IF ( zplam(jo) > 180 ) zplam(jo) = zplam(jo) - 360.0_wp
+
+               IF ( kproc(jo) == -1 ) THEN
+                  
+                  ! Normal case 
+                  gridpoints : DO jj = jjmin, jjmax
+                     DO ji = jimin, jimax
+
+
+                        IF ( ( zplam(jo) > zlamtmax(ji,jj) ) .OR. &
+                           & ( zplam(jo) < zlamtmin(ji,jj) ) ) CYCLE
+                        
+                        IF ( ABS( pphi(jo) ) < 85 ) THEN
+                           IF ( ( pphi(jo) > zphitmax(ji,jj) ) .OR. &
+                              & ( pphi(jo) < zphitmin(ji,jj) ) ) CYCLE
+                        ENDIF
+                        
+                        IF ( linquad( zplam(jo), pphi(jo), &
+                           &          zlamtm(:,ji,jj), zphitm(:,ji,jj) ) ) THEN
+                           IF ( llinvalidcell(ji,jj) ) THEN
+                              kproc(jo) = nproc + 1000000
+                              kobsi(jo) = ji + 1
+                              kobsj(jo) = jj + 1
+                              CYCLE
+                           ELSE
+                              kproc(jo) = nproc
+                              kobsi(jo) = ji + 1
+                              kobsj(jo) = jj + 1
+                              EXIT gridpoints
+                           ENDIF
+                        ENDIF
+                        
+                     END DO
+                  END DO gridpoints
+               ENDIF
+
+               ! In case of failure retry for obs. longtiude + 360.
+               IF ( kproc(jo) == -1 ) THEN
+                  gridpoints_greenwich : DO jj = jjmin, jjmax
+                     DO ji = jimin, jimax
+                        
+                        IF ( ( zplam(jo)+360.0_wp > zlamtmax(ji,jj) ) .OR. &
+                           & ( zplam(jo)+360.0_wp < zlamtmin(ji,jj) ) ) CYCLE
+
+                        IF ( ABS( pphi(jo) ) < 85 ) THEN
+                           IF ( ( pphi(jo) > zphitmax(ji,jj) ) .OR. &
+                              & ( pphi(jo) < zphitmin(ji,jj) ) ) CYCLE
+                        ENDIF
+
+                        IF ( linquad( zplam(jo)+360.0_wp, pphi(jo), &
+                           &          zlamtm(:,ji,jj), zphitm(:,ji,jj) ) ) THEN
+                           IF ( llinvalidcell(ji,jj) ) THEN
+                              kproc(jo) = nproc + 1000000
+                              kobsi(jo) = ji + 1
+                              kobsj(jo) = jj + 1
+                              CYCLE
+                           ELSE
+                              kproc(jo) = nproc
+                              kobsi(jo) = ji + 1
+                              kobsj(jo) = jj + 1
+                              EXIT gridpoints_greenwich
+                           ENDIF
+                        ENDIF
+                        
+                     END DO
+                  END DO gridpoints_greenwich
+                  
+               ENDIF   ! kproc
+               
+            END DO
+         END DO gridpointsn
+      END DO gpkobs  ! kobs
+
+      !----------------------------------------------------------------------
+      ! Synchronize kproc on all processors
+      !----------------------------------------------------------------------
+      IF ( ln_grid_global ) THEN
+         CALL obs_mpp_max_integer( kproc, kobs )
+         CALL obs_mpp_max_integer( kobsi, kobs )
+         CALL obs_mpp_max_integer( kobsj, kobs )
+      ELSE
+         CALL obs_mpp_find_obs_proc( kproc, kobs )
+      ENDIF
+
+      WHERE( kproc(:) >= 1000000 )
+         kproc(:) = kproc(:) - 1000000
+      END WHERE
+
+      DEALLOCATE( &
+         & zlamg,         &
+         & zphig,         &
+         & zmskg,         &
+         & zphitmax,      &
+         & zphitmin,      &
+         & zlamtmax,      &
+         & zlamtmin,      &
+         & llinvalidcell, &
+         & zlamtm,        &
+         & zphitm,        &
+         & zplam          &
+         & )
+      
+   END SUBROUTINE obs_grd_lookup
+
+
+   SUBROUTINE obs_grid_setup
+      !!----------------------------------------------------------------------
+      !!                ***  ROUTINE obs_grid_setup ***
+      !!
+      !! ** Purpose : Setup a lookup table to reduce the searching required
+      !!              for converting lat lons to grid point location
+      !!              produces or reads in a preexisting file for use in 
+      !!              obs_grid_search_lookup_local
+      !!
+      !! ** Method : calls obs_grid_search_bruteforce_local with a array 
+      !!             of lats and lons
+      !!
+      !! History :
+      !!        !  2007-12 (D. Lea) new routine
+      !!----------------------------------------------------------------------
+      
+      !! * Local declarations
+      CHARACTER(LEN=15), PARAMETER :: &
+         & cpname = 'obs_grid_setup'
+      CHARACTER(LEN=40) :: cfname      
+      INTEGER :: ji
+      INTEGER :: jj
+      INTEGER :: jk
+      INTEGER :: jo
+      INTEGER :: idfile, idny, idnx, idxpos, idypos
+      INTEGER :: idlat, idlon, fileexist
+      INTEGER, DIMENSION(2) :: incdim
+      CHARACTER(LEN=20) :: datestr=" ",timestr=" "
+      REAL(wp) :: tmpx1, tmpx2, tmpy1, tmpy2
+      REAL(wp) :: meanxdiff, meanydiff
+      REAL(wp) :: meanxdiff1, meanydiff1
+      REAL(wp) :: meanxdiff2, meanydiff2
+      INTEGER :: numx1, numx2, numy1, numy2, df
+      INTEGER :: jimin, jimax, jjmin, jjmax
+      REAL(wp), DIMENSION(:,:), ALLOCATABLE :: &
+         & lonsi,     &
+         & latsi
+      INTEGER, DIMENSION(:,:), ALLOCATABLE :: &  
+         & ixposi,    &
+         & iyposi,    & 
+         & iproci    
+      INTEGER, PARAMETER :: histsize=90
+      INTEGER, DIMENSION(histsize) :: &
+         & histx1, histx2, histy1, histy2
+      REAL, DIMENSION(histsize) :: &
+         & fhistx1, fhistx2, fhisty1, fhisty2
+      REAL(wp) :: histtol
+      
+      IF (ln_grid_search_lookup) THEN
+         
+         WRITE(numout,*) 'Calling obs_grid_setup'
+         
+         IF(lwp) WRITE(numout,*)
+         IF(lwp) WRITE(numout,*)'Grid search resolution : ', rn_gridsearchres
+         
+         gsearch_nlons_def  = NINT( 360.0_wp / rn_gridsearchres ) 
+         gsearch_nlats_def  = NINT( 180.0_wp / rn_gridsearchres )
+         gsearch_lonmin_def = -180.0_wp + 0.5_wp * rn_gridsearchres
+         gsearch_latmin_def =  -90.0_wp + 0.5_wp * rn_gridsearchres
+         gsearch_dlon_def   = rn_gridsearchres
+         gsearch_dlat_def   = rn_gridsearchres
+         
+         IF (lwp) THEN
+            WRITE(numout,*)'Grid search gsearch_nlons_def  = ',gsearch_nlons_def
+            WRITE(numout,*)'Grid search gsearch_nlats_def  = ',gsearch_nlats_def
+            WRITE(numout,*)'Grid search gsearch_lonmin_def = ',gsearch_lonmin_def
+            WRITE(numout,*)'Grid search gsearch_latmin_def = ',gsearch_latmin_def
+            WRITE(numout,*)'Grid search gsearch_dlon_def   = ',gsearch_dlon_def
+            WRITE(numout,*)'Grid search gsearch_dlat_def   = ',gsearch_dlat_def
+         ENDIF
+
+         IF ( ln_grid_global ) THEN
+            WRITE(cfname, FMT="(A,'_',A)") &
+               &          TRIM(cn_gridsearchfile), 'global.nc'
+         ELSE
+            WRITE(cfname, FMT="(A,'_',I4.4,'of',I4.4,'by',I4.4,'.nc')") &
+               &          TRIM(cn_gridsearchfile), nproc, jpni, jpnj
+         ENDIF
+
+         fileexist=nf90_open( TRIM( cfname ), nf90_nowrite, &
+            &                  idfile )
+         
+         IF ( fileexist == nf90_noerr ) THEN
+            
+            ! read data
+            ! initially assume size is as defined (to be fixed)
+            
+            WRITE(numout,*) 'Reading: ',cfname
+            
+            CALL chkerr( nf90_open( TRIM( cfname ), nf90_nowrite, idfile ), &
+               &         cpname, __LINE__ )
+            CALL chkerr( nf90_get_att( idfile, nf90_global, 'maxxdiff', maxxdiff ), &
+               &         cpname, __LINE__ )        
+            CALL chkerr( nf90_get_att( idfile, nf90_global, 'maxydiff', maxydiff ), &
+               &         cpname, __LINE__ )        
+            CALL chkerr( nf90_get_att( idfile, nf90_global, 'dlon', dlon ), &
+            &         cpname, __LINE__ )        
+            CALL chkerr( nf90_get_att( idfile, nf90_global, 'dlat', dlat ), &
+               &         cpname, __LINE__ )        
+            CALL chkerr( nf90_get_att( idfile, nf90_global, 'lonmin', lonmin ), &
+               &         cpname, __LINE__ )        
+            CALL chkerr( nf90_get_att( idfile, nf90_global, 'latmin', latmin ), &
+               &         cpname, __LINE__ )        
+            
+            CALL chkerr( nf90_inq_dimid(idfile, 'nx'  , idnx), &
+               &         cpname, __LINE__ )
+            CALL chkerr( nf90_inquire_dimension( idfile, idnx, len = nlons ),     &
+               &         cpname, __LINE__ ) 
+            CALL chkerr( nf90_inq_dimid(idfile, 'ny'  , idny), &
+               &         cpname, __LINE__ )
+            CALL chkerr( nf90_inquire_dimension( idfile, idny, len = nlats ),     &
+               &         cpname, __LINE__ ) 
+            
+            ALLOCATE( &
+               & lons(nlons,nlats),  &
+               & lats(nlons,nlats),  &
+               & ixpos(nlons,nlats), &
+               & iypos(nlons,nlats), &
+               & iprocn(nlons,nlats)  &
+               & )
+            
+            CALL chkerr( nf90_inq_varid( idfile, 'XPOS', idxpos ), & 
+               &         cpname, __LINE__ )
+            CALL chkerr( nf90_get_var  ( idfile, idxpos, ixpos),   &
+               &         cpname, __LINE__ )
+            CALL chkerr( nf90_inq_varid( idfile, 'YPOS', idypos ), & 
+               &         cpname, __LINE__ )
+            CALL chkerr( nf90_get_var  ( idfile, idypos, iypos),   &
+               &         cpname, __LINE__ )
+            
+            CALL chkerr( nf90_close( idfile ), cpname, __LINE__ )
+            
+            ! setup arrays
+            
+            DO ji = 1, nlons
+               DO jj = 1, nlats
+                  lons(ji,jj) = lonmin + (ji-1) * dlon
+                  lats(ji,jj) = latmin + (jj-1) * dlat
+               END DO
+            END DO
+            
+            ! if we are not reading the file we need to create it
+            ! create new obs grid search lookup file
+            
+         ELSE 
+            
+            ! call obs_grid_search
+            
+            IF (lwp) THEN
+               WRITE(numout,*) 'creating: ',cfname
+               WRITE(numout,*) 'calling obs_grid_search: ',nlons*nlats
+            ENDIF
+
+            ! set parameters from default values
+            nlons  = gsearch_nlons_def
+            nlats  = gsearch_nlats_def
+            lonmin = gsearch_lonmin_def
+            latmin = gsearch_latmin_def
+            dlon   = gsearch_dlon_def
+            dlat   = gsearch_dlat_def
+            
+            ! setup arrays
+            
+            ALLOCATE( &
+               & lonsi(nlons,nlats),   &
+               & latsi(nlons,nlats),   &
+               & ixposi(nlons,nlats),  &
+               & iyposi(nlons,nlats),  &
+               & iproci(nlons,nlats)   &
+               & )
+         
+            DO ji = 1, nlons
+               DO jj = 1, nlats
+                  lonsi(ji,jj) = lonmin + (ji-1) * dlon
+                  latsi(ji,jj) = latmin + (jj-1) * dlat
+               END DO
+            END DO
+            
+            CALL obs_grd_bruteforce( jpi, jpj, jpiglo, jpjglo,  &
+               &                     1, nlci, 1, nlcj,          &
+               &                     nproc, jpnij,              &
+               &                     glamt, gphit, tmask,       &
+               &                     nlons*nlats, lonsi, latsi, &
+               &                     ixposi, iyposi, iproci )
+            
+            ! minimise file size by removing regions with no data from xypos file
+            ! should be able to just use xpos (ypos will have the same areas of missing data)
+         
+            jimin=1
+            jimax=nlons
+            jjmin=1
+            jjmax=nlats
+
+            minlon_xpos: DO ji= 1, nlons
+               IF (COUNT(ixposi(ji,:) >= 0) > 0) THEN
+                  jimin=ji
+                  EXIT minlon_xpos
+               ENDIF
+            END DO minlon_xpos
+
+            maxlon_xpos: DO ji= nlons, 1, -1
+               IF (COUNT(ixposi(ji,:) >= 0) > 0) THEN
+                  jimax=ji
+                  EXIT maxlon_xpos
+               ENDIF
+            END DO maxlon_xpos
+
+            minlat_xpos: DO jj= 1, nlats
+               IF (COUNT(ixposi(:,jj) >= 0) > 0) THEN
+                  jjmin=jj
+                  EXIT minlat_xpos
+               ENDIF
+            END DO minlat_xpos
+
+            maxlat_xpos: DO jj= nlats, 1, -1
+               IF (COUNT(ixposi(:,jj) >= 0) > 0) THEN 
+                  jjmax=jj
+                  EXIT maxlat_xpos
+               ENDIF
+            END DO maxlat_xpos
+
+            lonmin = lonsi(jimin,jjmin)
+            latmin = latsi(jimin,jjmin)
+            nlons  = jimax-jimin+1
+            nlats  = jjmax-jjmin+1
+
+            ! construct new arrays
+
+            ALLOCATE( &
+               & lons(nlons,nlats),    &
+               & lats(nlons,nlats),    &
+               & ixpos(nlons,nlats),   &
+               & iypos(nlons,nlats),   &
+               & iprocn(nlons,nlats)    &
+               & )
+
+            lons(:,:) = lonsi(jimin:jimax,jjmin:jjmax)
+            lats(:,:) = latsi(jimin:jimax,jjmin:jjmax)
+            ixpos(:,:) = ixposi(jimin:jimax,jjmin:jjmax)
+            iypos(:,:) = iyposi(jimin:jimax,jjmin:jjmax)
+            iprocn(:,:) = iproci(jimin:jimax,jjmin:jjmax)
+
+            DEALLOCATE(lonsi,latsi,ixposi,iyposi,iproci)
+
+            ! calculate (estimate) maxxdiff, maxydiff
+            ! this is to help define the search area for obs_grid_search_lookup
+
+            maxxdiff = 1
+            maxydiff = 1
+
+            tmpx1 = 0
+            tmpx2 = 0
+            tmpy1 = 0
+            tmpy2 = 0 
+
+            numx1 = 0
+            numx2 = 0
+            numy1 = 0
+            numy2 = 0
+
+            ! calculate the mean absolute xdiff and ydiff
+            ! also calculate a histogram
+            ! note the reason why looking for xdiff and ydiff in both directions
+            ! is to allow for rotated grids
+
+            DO ji = 1, nlons-1
+               DO jj = 1, nlats-1
+                  IF ( ixpos(ji,jj) > 0 .AND. iypos(ji,jj) > 0 ) THEN
+                     IF ( ixpos(ji+1,jj) > 0 ) THEN
+                        df = ABS( ixpos(ji+1,jj) - ixpos(ji,jj) )
+                        tmpx1 = tmpx1+df
+                        numx1 = numx1+1
+                        IF ( df < histsize ) histx1(df+1) = histx1(df+1) + 1
+                     ENDIF
+                     IF ( ixpos(ji,jj+1) > 0 ) THEN
+                        df = ABS( ixpos(ji,jj+1) - ixpos(ji,jj) )
+                        tmpx2 = tmpx2 + df
+                        numx2 = numx2 + 1
+                        IF ( df < histsize ) histx2(df+1) = histx2(df+1) + 1
+                     ENDIF
+                     IF (iypos(ji+1,jj) > 0) THEN
+                        df = ABS( iypos(ji+1,jj) - iypos(ji,jj) )
+                        tmpy1 = tmpy1 + df
+                        numy1 = numy1 + 1
+                        IF ( df < histsize ) histy1(df+1) = histy1(df+1) + 1
+                     ENDIF
+                     IF ( iypos(ji,jj+1) > 0 ) THEN
+                        df = ABS( iypos(ji,jj+1) - iypos(ji,jj) )
+                        tmpy2 = tmpy2 + df
+                        numy2 = numy2 + 1
+                        IF ( df < histsize ) histy2(df+1) = histy2(df+1) + 1
+                     ENDIF
+                  ENDIF
+               END DO
+            END DO
+
+            IF (lwp) THEN
+               WRITE(numout,*) 'histograms'
+               WRITE(numout,*) '0   1   2   3   4   5   6   7   8   9   10 ...'
+               WRITE(numout,*) 'histx1'
+               WRITE(numout,*) histx1
+               WRITE(numout,*) 'histx2'
+               WRITE(numout,*) histx2
+               WRITE(numout,*) 'histy1'
+               WRITE(numout,*) histy1
+               WRITE(numout,*) 'histy2'
+               WRITE(numout,*) histy2
+            ENDIF
+
+            meanxdiff1 = tmpx1 / numx1
+            meanydiff1 = tmpy1 / numy1
+            meanxdiff2 = tmpx2 / numx2
+            meanydiff2 = tmpy2 / numy2
+
+            meanxdiff = MAXVAL((/ meanxdiff1, meanxdiff2 /))
+            meanydiff = MAXVAL((/ meanydiff1, meanydiff2 /))
+
+            IF (lwp) THEN
+               WRITE(numout,*) tmpx1, tmpx2, tmpy1, tmpy2
+               WRITE(numout,*) numx1, numx2, numy1, numy2
+               WRITE(numout,*) 'meanxdiff: ',meanxdiff, meanxdiff1, meanxdiff2
+               WRITE(numout,*) 'meanydiff: ',meanydiff, meanydiff1, meanydiff2
+            ENDIF
+
+            tmpx1 = 0
+            tmpx2 = 0
+            tmpy1 = 0
+            tmpy2 = 0
+
+            numx1 = 0
+            numx2 = 0
+            numy1 = 0
+            numy2 = 0
+
+            histx1(:) = 0
+            histx2(:) = 0
+            histy1(:) = 0
+            histy2(:) = 0
+
+            limxdiff = meanxdiff * 4! limit the difference to avoid picking up wraparound
+            limydiff = meanydiff * 4
+
+            DO ji = 1, nlons-1
+               DO jj = 1, nlats-1
+                  IF ( ixpos(ji,jj) > 0 .AND. iypos(ji,jj) > 0 ) THEN
+
+                     IF ( ixpos(ji+1,jj) > 0 ) THEN
+                        df = ABS( ixpos(ji+1,jj)-ixpos(ji,jj) )
+                        tmpx1 = df
+                        IF ( df < limxdiff ) numx1 = numx1+1
+                        IF ( df < histsize ) histx1(df+1) = histx1(df+1) + 1
+                     ENDIF
+                     IF ( ixpos(ji,jj+1) > 0 ) THEN
+                        df = ABS( ixpos(ji,jj+1) - ixpos(ji,jj) )
+                        tmpx2 = df
+                        IF ( df < limxdiff ) numx2 = numx2 + 1
+                        IF ( df < histsize ) histx2(df+1) = histx2(df+1) + 1
+                     ENDIF
+                     IF (iypos(ji+1,jj) > 0) THEN
+                        df = ABS( iypos(ji+1,jj) - iypos(ji,jj) )
+                        tmpy1 = df
+                        IF ( df < limydiff ) numy1 = numy1 + 1
+                        IF ( df < histsize ) histy1(df+1) = histy1(df+1) + 1
+                     ENDIF
+                     IF (iypos(ji,jj+1) > 0) THEN
+                        df = ABS( iypos(ji,jj+1) - iypos(ji,jj) )
+                        tmpy2 = df
+                        IF ( df < limydiff ) numy2 = numy2+1
+                        IF ( df < histsize ) histy2(df+1) = histy2(df+1)+1
+                     ENDIF
+
+                     IF ( maxxdiff < tmpx1 .AND. tmpx1 < limxdiff ) &
+                        & maxxdiff = tmpx1
+                     IF ( maxxdiff < tmpx2 .AND. tmpx2 < limxdiff ) &
+                        & maxxdiff = tmpx2
+                     IF ( maxydiff < tmpy1 .AND. tmpy1 < limydiff ) &
+                        & maxydiff = tmpy1
+                     IF ( maxydiff < tmpy2 .AND. tmpy2 < limydiff ) &
+                        & maxydiff = tmpy2
+
+                  ENDIF
+               END DO
+            END DO
+
+            ! cumulative histograms
+
+            DO ji = 1, histsize - 1
+               histx1(ji+1) = histx1(ji+1) + histx1(ji)
+               histx2(ji+1) = histx2(ji+1) + histx2(ji)
+               histy1(ji+1) = histy1(ji+1) + histy1(ji)
+               histy2(ji+1) = histy2(ji+1) + histy2(ji)
+            END DO
+
+            fhistx1(:) = histx1(:) * 1.0 / numx1
+            fhistx2(:) = histx2(:) * 1.0 / numx2
+            fhisty1(:) = histy1(:) * 1.0 / numy1
+            fhisty2(:) = histy2(:) * 1.0 / numy2
+
+            ! output new histograms
+
+            IF (lwp) THEN
+               WRITE(numout,*) 'cumulative histograms'
+               WRITE(numout,*) '0   1   2   3   4   5   6   7   8   9   10 ...'
+               WRITE(numout,*) 'fhistx1'
+               WRITE(numout,*) fhistx1
+               WRITE(numout,*) 'fhistx2'
+               WRITE(numout,*) fhistx2
+               WRITE(numout,*) 'fhisty1'
+               WRITE(numout,*) fhisty1
+               WRITE(numout,*) 'fhisty2'
+               WRITE(numout,*) fhisty2
+            ENDIF
+
+            ! calculate maxxdiff and maxydiff based on cumulative histograms
+            ! where > 0.999 of points are
+
+            ! maxval just converts 1x1 vector return from maxloc to a scalar 
+
+            histtol = 0.999
+            tmpx1 = MAXVAL( MAXLOC( fhistx1(:), mask = ( fhistx1(:) <= histtol ) ) )
+            tmpx2 = MAXVAL( MAXLOC( fhistx2(:), mask = ( fhistx2(:) <= histtol ) ) )
+            tmpy1 = MAXVAL( MAXLOC( fhisty1(:), mask = ( fhisty1(:) <= histtol ) ) )
+            tmpy2 = MAXVAL( MAXLOC( fhisty2(:), mask = ( fhisty2(:) <= histtol ) ) )
+
+            maxxdiff = MAXVAL( (/ tmpx1, tmpx2 /) ) + 1
+            maxydiff = MAXVAL( (/ tmpy1, tmpy2 /) ) + 1
+
+            ! Write out data
+
+            IF ( ( .NOT. ln_grid_global ) .OR. &
+               & ( ( ln_grid_global ) .AND. ( nproc==0 ) ) ) THEN
+
+               CALL chkerr( nf90_create (TRIM(cfname), nf90_clobber, idfile), &
+                  &         cpname, __LINE__ )
+               CALL chkerr( nf90_put_att( idfile, nf90_global, 'title',       &
+                  &         'Mapping file from lon/lat to model grid point' ),&
+                  &         cpname,__LINE__ ) 
+               CALL chkerr( nf90_put_att( idfile, nf90_global, 'maxxdiff',    &
+                  &                       maxxdiff ),                         &
+                  &         cpname,__LINE__ ) 
+               CALL chkerr( nf90_put_att( idfile, nf90_global, 'maxydiff',    &
+                  &                       maxydiff ),                         &
+                  &         cpname,__LINE__ ) 
+               CALL chkerr( nf90_put_att( idfile, nf90_global, 'dlon', dlon ),&
+                  &         cpname,__LINE__ ) 
+               CALL chkerr( nf90_put_att( idfile, nf90_global, 'dlat', dlat ),&
+                  &         cpname,__LINE__ ) 
+               CALL chkerr( nf90_put_att( idfile, nf90_global, 'lonmin',      &
+                  &                       lonmin ),                           &
+                  &         cpname,__LINE__ ) 
+               CALL chkerr( nf90_put_att( idfile, nf90_global, 'latmin',      &
+                  &                       latmin ),                           &
+                  &         cpname,__LINE__ ) 
+
+               CALL chkerr( nf90_def_dim(idfile, 'nx'  , nlons, idnx),        &
+                  &         cpname,__LINE__ )
+               CALL chkerr( nf90_def_dim(idfile, 'ny'  , nlats, idny),        &
+                  &         cpname,__LINE__ )
+
+               incdim(1) = idnx
+               incdim(2) = idny
+               
+               CALL chkerr( nf90_def_var( idfile, 'LON', nf90_float, incdim,  &
+                  &                       idlon ),                            &
+                  &         cpname, __LINE__ )
+               CALL chkerr( nf90_put_att( idfile, idlon, 'long_name',         &
+                  &                       'longitude' ),                      &
+                  &         cpname, __LINE__ )
+               
+               CALL chkerr( nf90_def_var( idfile, 'LAT', nf90_float, incdim,  &
+                  &                       idlat ),                            &
+                  &         cpname, __LINE__ )
+               CALL chkerr( nf90_put_att( idfile, idlat, 'long_name',         &
+                  &                       'latitude' ),                       &
+                  &         cpname, __LINE__ )
+
+               CALL chkerr( nf90_def_var( idfile, 'XPOS', nf90_int, incdim,   &
+                  &                       idxpos ),                           &
+                  &         cpname, __LINE__ )
+               CALL chkerr( nf90_put_att( idfile, idxpos, 'long_name',        &
+                  &                       'x position' ),                     &
+                  &         cpname, __LINE__ )
+               CALL chkerr( nf90_put_att( idfile, idxpos, '_FillValue', -1 ), &
+                  &         cpname, __LINE__ )
+
+               CALL chkerr( nf90_def_var( idfile, 'YPOS', nf90_int, incdim,   &
+                  &                       idypos ),                           &
+                  &         cpname, __LINE__ )
+               CALL chkerr( nf90_put_att( idfile, idypos, 'long_name',        &
+                  &                       'y position' ),                     &
+                  &         cpname, __LINE__ )
+               CALL chkerr( nf90_put_att( idfile, idypos, '_FillValue', -1 ), &
+                  &         cpname, __LINE__ )
+
+               CALL chkerr( nf90_enddef( idfile ), cpname, __LINE__ )
+               
+               CALL chkerr( nf90_put_var( idfile, idlon, lons),               &
+                  &         cpname, __LINE__ )
+               CALL chkerr( nf90_put_var( idfile, idlat, lats),               &
+                  &         cpname, __LINE__ )
+               CALL chkerr( nf90_put_var( idfile, idxpos, ixpos),             &
+                  &         cpname, __LINE__ )
+               CALL chkerr( nf90_put_var( idfile, idypos, iypos),             &
+                  &         cpname, __LINE__ )
+               
+               CALL chkerr( nf90_close( idfile ), cpname, __LINE__ )
+               
+               ! should also output max i, max j spacing for use in 
+               ! obs_grid_search_lookup
+               
+            ENDIF
+
+         ENDIF
+
+      ENDIF
+
+   END SUBROUTINE obs_grid_setup
+   
+   SUBROUTINE obs_grid_deallocate( )
+      !!----------------------------------------------------------------------
+      !!                ***  ROUTINE obs_grid_setup ***
+      !!
+      !! ** Purpose : Deallocate arrays setup by obs_grid_setup
+      !!
+      !! History :
+      !!        !  2007-12 (D. Lea) new routine
+      !!-----------------------------------------------------------------------
+
+      IF (ln_grid_search_lookup) THEN
+         DEALLOCATE( lons, lats, ixpos, iypos, iprocn )
+      ENDIF
+      
+   END SUBROUTINE obs_grid_deallocate
+
+#include "obs_level_search.h90"
+
+#include "linquad.h90"
+
+#include "maxdist.h90"
+
+#include "find_obs_proc.h90"
+
+END MODULE obs_grid
+
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/obs_inter_h2d.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/obs_inter_h2d.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/obs_inter_h2d.F90	(revision 9570)
@@ -0,0 +1,58 @@
+MODULE obs_inter_h2d
+   !!======================================================================
+   !!                       ***  MODULE obs_inter_h2d   ***
+   !! Observation diagnostics: Perform the horizontal interpolation
+   !!                          from model grid to observation location
+   !!=====================================================================
+
+   !!----------------------------------------------------------------------
+   !!   obs_int_h2d     : Horizontal interpolation to the observation point
+   !!   obs_int_h2d_ds1 : Distance-weighted interpolation                 (n2dint=0)
+   !!   obs_int_h2d_ds2 : Distance-weighted interpolation (small angle)   (n2dint=1)
+   !!   obs_int_h2d_bil : Bilinear interpolation (geographical grid)      (n2dint=2)
+   !!   obs_int_h2d_bir : Bilinear remapping interpolation (general grid) (n2dint=3)
+   !!   obs_int_h2d_pol : Polynomial interpolation                        (n2dint=4)
+   !!   bil_wgt         : Compute weights for bilinear remapping
+   !!   lu_invmat       : Invert a matrix using LU decomposition
+   !!   lu_decomp       : LU decomposition
+   !!   lu_backsb       : LU decomposition - back substitution
+   !!----------------------------------------------------------------------
+   !! * Modules used
+   USE par_kind, ONLY : &  ! Precision variables
+      & wp
+   USE phycst,   ONLY : &  ! Physical constants
+      & rad,  &
+      & rpi
+   USE in_out_manager
+   USE obs_const, ONLY : &
+      & obfillflt		! Fillvalue
+   USE obs_utils           ! Utility functions
+      USE lib_mpp,ONLY : &
+      & ctl_warn, ctl_stop
+
+   IMPLICIT NONE
+
+   !! * Routine accessibility
+   PRIVATE obs_int_h2d_ds1, & ! Distance-weighted interpolation               
+      &    obs_int_h2d_ds2, & ! Distance-weighted interpolation (small angle) 
+      &    obs_int_h2d_bil, & ! Bilinear interpolation (geographical grid)    
+      &    obs_int_h2d_bir, & ! Bilinear remapping interpolation (general grid)
+      &    obs_int_h2d_pol, & ! Polynomial interpolation                       
+      &    lu_invmat,       & ! Invert a matrix using LU decomposition
+      &    lu_decomp,       & ! LU decomposition
+      &    lu_backsb,       & ! LU decomposition - back substitution
+      &    bil_wgt            ! Compute weights for bilinear remapping
+   PUBLIC obs_int_h2d,      & ! Horizontal interpolation to the observation point
+      &   obs_int_h2d_init    ! Set up weights and vertical mask
+
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO Consortium (2010)
+   !! $Id$
+   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+
+CONTAINS
+ 
+#include "obsinter_h2d.h90"
+
+END MODULE obs_inter_h2d
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/obs_inter_sup.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/obs_inter_sup.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/obs_inter_sup.F90	(revision 9570)
@@ -0,0 +1,386 @@
+MODULE obs_inter_sup
+   !!=====================================================================
+   !!                       ***  MODULE obs_inter_sup  ***
+   !! Observation diagnostics: Support for interpolation
+   !!=====================================================================
+
+   !!----------------------------------------------------------------------
+   !!   obs_int_comm_3d : Get 3D interpolation stencil
+   !!   obs_int_comm_2d : Get 2D interpolation stencil
+   !!---------------------------------------------------------------------
+   !! * Modules used
+   USE par_kind        ! Precision variables
+   USE dom_oce         ! Domain variables
+   USE mpp_map         ! Map of processor points
+   USE lib_mpp         ! MPP stuff
+   USE obs_mpp         ! MPP stuff for observations
+   USE obs_grid        ! Grid tools
+   USE in_out_manager  ! I/O stuff
+
+   IMPLICIT NONE
+
+   !! * Routine accessibility
+   PRIVATE
+   
+   PUBLIC obs_int_comm_3d, & ! Get 3D interpolation stencil
+      &   obs_int_comm_2d    ! Get 2D interpolation stencil
+   
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO Consortium (2010)
+   !! $Id$
+   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+
+CONTAINS
+
+   SUBROUTINE obs_int_comm_3d( kptsi, kptsj, kobs, kpi, kpj, kpk, kgrdi, kgrdj, &
+      &                        pval, pgval, kproc )
+      !!----------------------------------------------------------------------
+      !!                    ***  ROUTINE obs_int_comm_3d  ***
+      !!          
+      !! ** Purpose : Get 3D interpolation stencil
+      !!
+      !! ** Method  : Either on-demand communication with 
+      !!              obs_int_comm_3d_global 
+      !!              or local memory with
+      !!              obs_int_comm_3D_local
+      !!              depending on ln_global_grid
+      !!
+      !! ** Action  : 
+      !!
+      !! History :
+      !!        !  08-02  (K. Mogensen)  Original code
+      !!----------------------------------------------------------------------
+      !! * Arguments
+      INTEGER, INTENT(IN) :: kptsi     ! Number of i horizontal points per stencil 
+      INTEGER, INTENT(IN) :: kptsj     ! Number of j horizontal points per stencil
+      INTEGER, INTENT(IN) :: kobs      ! Local number of observations
+      INTEGER, INTENT(IN) :: kpi       ! Number of points in i direction
+      INTEGER, INTENT(IN) :: kpj       ! Number of points in j direction
+      INTEGER, INTENT(IN) :: kpk       ! Number of levels
+      INTEGER, DIMENSION(kptsi,kptsj,kobs), INTENT(IN) :: &
+         & kgrdi, &         ! i,j indicies for each stencil
+         & kgrdj
+      INTEGER, OPTIONAL, DIMENSION(kptsi,kptsj,kobs), INTENT(IN) :: &
+         & kproc            ! Precomputed processor for each i,j,iobs points
+      REAL(KIND=wp), DIMENSION(kpi,kpj,kpk), INTENT(IN) ::&
+         & pval             ! Local 3D array to extract data from
+      REAL(KIND=wp), DIMENSION(kptsi,kptsj,kpk,kobs), INTENT(OUT) ::&
+         & pgval            ! Stencil at each point
+      !! * Local declarations
+      
+      IF (ln_grid_global) THEN
+         
+         IF (PRESENT(kproc)) THEN
+
+            CALL obs_int_comm_3d_global( kptsi, kptsj, kobs, kpi, kpj, kpk, kgrdi, &
+               &                         kgrdj, pval, pgval, kproc=kproc )
+
+         ELSE
+
+            CALL obs_int_comm_3d_global( kptsi, kptsj, kobs, kpi, kpj, kpk, kgrdi, &
+               &                         kgrdj, pval, pgval )
+
+         ENDIF
+
+      ELSE
+
+         CALL obs_int_comm_3d_local( kptsi, kptsj, kobs, kpi, kpj, kpk, kgrdi, kgrdj, &
+            &                        pval, pgval )
+
+      ENDIF
+
+   END SUBROUTINE obs_int_comm_3d
+
+   SUBROUTINE obs_int_comm_2d( kptsi, kptsj, kobs, kpi, kpj, kgrdi, kgrdj, pval, pgval, &
+      &                        kproc )
+      !!----------------------------------------------------------------------
+      !!                    ***  ROUTINE obs_int_comm_2d  ***
+      !!          
+      !! ** Purpose : Get 2D interpolation stencil
+      !!
+      !! ** Method  : Call to obs_int_comm_3d
+      !!
+      !! ** Action  : 
+      !!
+      !! History :
+      !!        !  08-02  (K. Mogensen)  Original code
+      !!----------------------------------------------------------------------
+      !!
+      !! * Arguments
+      INTEGER, INTENT(IN) :: kptsi        ! Number of i horizontal points per stencil
+      INTEGER, INTENT(IN) :: kptsj        ! Number of j horizontal points per stencil
+      INTEGER, INTENT(IN) :: kobs          ! Local number of observations
+      INTEGER, INTENT(IN) :: kpi          ! Number of model grid points in i direction
+      INTEGER, INTENT(IN) :: kpj          ! Number of model grid points in j direction
+      INTEGER, DIMENSION(kptsi,kptsj,kobs), INTENT(IN) :: &
+         & kgrdi, &         ! i,j indicies for each stencil
+         & kgrdj
+      INTEGER, OPTIONAL, DIMENSION(kptsi,kptsj,kobs), INTENT(IN) :: &
+         & kproc            ! Precomputed processor for each i,j,iobs points
+      REAL(KIND=wp), DIMENSION(kpi,kpj), INTENT(IN) ::&
+         & pval             ! Local 3D array to extra data from
+      REAL(KIND=wp), DIMENSION(kptsi,kptsj,kobs), INTENT(OUT) ::&
+         & pgval            ! Stencil at each point
+      !! * Local declarations
+      REAL(KIND=wp), DIMENSION(jpi,jpj,1) ::   zval
+      REAL(KIND=wp), DIMENSION(kptsi,kptsj,1,kobs) ::&
+         & zgval 
+
+      ! Set up local "3D" buffer
+
+      zval(:,:,1) = pval(:,:)
+
+      ! Call the 3D version
+
+      IF (PRESENT(kproc)) THEN
+
+         CALL obs_int_comm_3d( kptsi, kptsj, kobs, kpi, kpj, 1, kgrdi, kgrdj, zval, &
+            &                  zgval, kproc=kproc )
+      ELSE
+
+         CALL obs_int_comm_3d( kptsi, kptsj, kobs, kpi, kpj, 1, kgrdi, kgrdj, zval, &
+            &                  zgval )
+
+      ENDIF
+
+      ! Copy "3D" data back to 2D
+
+      pgval(:,:,:) = zgval(:,:,1,:)
+
+   END SUBROUTINE obs_int_comm_2d
+
+   SUBROUTINE obs_int_comm_3d_global( kptsi, kptsj, kobs, kpi, kpj, kpk, kgrdi, kgrdj, &
+      &                               pval, pgval, kproc )
+      !!----------------------------------------------------------------------
+      !!                    ***  ROUTINE obs_int_comm_3d_global  ***
+      !!          
+      !! ** Purpose : Get 3D interpolation stencil (global version)
+      !!
+      !! ** Method  : On-demand communication where each processor send its
+      !!              list of (i,j) of points to all processors and receive 
+      !!              the corresponding values
+      !!
+      !! ** Action  : 
+      !!
+      !! History :
+      !!        !  08-02  (K. Mogensen)  Original code
+      !!----------------------------------------------------------------------
+      !! * Arguments
+      INTEGER, INTENT(IN) :: kptsi     ! Number of i horizontal points per stencil 
+      INTEGER, INTENT(IN) :: kptsj     ! Number of j horizontal points per stencil
+      INTEGER, INTENT(IN) :: kobs      ! Local number of observations
+      INTEGER, INTENT(IN) :: kpi       ! Number of model points in i direction
+      INTEGER, INTENT(IN) :: kpj       ! Number of model points in j direction
+      INTEGER, INTENT(IN) :: kpk       ! Number of levels
+      INTEGER, DIMENSION(kptsi,kptsj,kobs), INTENT(IN) :: &
+         & kgrdi, &         ! i,j indicies for each stencil
+         & kgrdj
+      INTEGER, OPTIONAL, DIMENSION(kptsi,kptsj,kobs), INTENT(IN) :: &
+         & kproc            ! Precomputed processor for each i,j,iobs points
+      REAL(KIND=wp), DIMENSION(kpi,kpj,kpk), INTENT(IN) ::&
+         & pval             ! Local 3D array to extract data from
+      REAL(KIND=wp), DIMENSION(kptsi,kptsj,kpk,kobs), INTENT(OUT) ::&
+         & pgval            ! Stencil at each point
+      !! * Local declarations
+      REAL(KIND=wp), DIMENSION(:,:), ALLOCATABLE :: &
+         & zsend, &
+         & zrecv
+      INTEGER, DIMENSION(:), ALLOCATABLE :: &
+         & igrdij_send, &
+         & igrdij_recv
+      INTEGER, DIMENSION(kptsi,kptsj,kobs) :: &
+         & iorder, &
+         & iproc
+      INTEGER :: nplocal(jpnij)
+      INTEGER :: npglobal(jpnij)
+      INTEGER :: ji
+      INTEGER :: jj
+      INTEGER :: jk
+      INTEGER :: jp
+      INTEGER :: jobs
+      INTEGER :: it
+      INTEGER :: itot
+      INTEGER :: ii
+      INTEGER :: ij
+
+      ! Check valid points
+
+      IF ( ( MAXVAL(kgrdi) > jpiglo ) .OR. ( MINVAL(kgrdi) < 1 ) .OR. &
+         & ( MAXVAL(kgrdj) > jpjglo ) .OR. ( MINVAL(kgrdj) < 1 ) ) THEN
+
+         CALL ctl_stop( 'Error in obs_int_comm_3d_global', &
+            &           'Point outside global domain' )
+
+      ENDIF
+
+      ! Count number of points on each processors
+
+      nplocal(:) = 0
+      IF (PRESENT(kproc)) THEN 
+         iproc(:,:,:) = kproc(:,:,:)
+         DO jobs = 1, kobs
+            DO jj = 1, kptsj
+               DO ji = 1, kptsi
+                  nplocal(iproc(ji,jj,jobs)) = nplocal(iproc(ji,jj,jobs)) + 1
+               END DO
+            END DO
+         END DO
+      ELSE
+         DO jobs = 1, kobs
+            DO jj = 1, kptsj
+               DO ji = 1, kptsi
+                  iproc(ji,jj,jobs) = mppmap(kgrdi(ji,jj,jobs),&
+                     &                       kgrdj(ji,jj,jobs))
+                  nplocal(iproc(ji,jj,jobs)) = nplocal(iproc(ji,jj,jobs)) + 1
+               END DO
+            END DO
+         END DO
+      ENDIF
+
+      ! Send local number of points and receive points on current domain
+
+      CALL mpp_alltoall_int( 1, nplocal, npglobal )
+
+      ! Allocate message parsing workspace
+
+      itot = SUM(npglobal)
+
+      ALLOCATE( &
+         & igrdij_send(kptsi*kptsj*kobs*2), &
+         & igrdij_recv(itot*2),             &
+         & zsend(kpk,itot),                 &
+         & zrecv(kpk,kptsi*kptsj*kobs)      &
+         & )
+
+      ! Pack buffers for list of points
+
+      it = 0
+      DO jp = 1, jpnij 
+         DO jobs = 1, kobs
+            DO jj = 1, kptsj
+               DO ji = 1, kptsi
+                  IF ( iproc(ji,jj,jobs) == jp ) THEN
+                     it = it + 1
+                     iorder(ji,jj,jobs) = it
+                     igrdij_send(2*it-1) = kgrdi(ji,jj,jobs)
+                     igrdij_send(2*it  ) = kgrdj(ji,jj,jobs)
+                  ENDIF
+               END DO
+            END DO
+         END DO
+      END DO
+
+      ! Send and recieve buffers for list of points
+
+      CALL mpp_alltoallv_int( igrdij_send, kptsi*kptsj*kobs*2, nplocal(:)*2, &
+         &                    igrdij_recv, itot*2, npglobal(:)*2 )
+
+      ! Pack interpolation data to be sent
+
+      DO ji = 1, itot
+         ii = mi1(igrdij_recv(2*ji-1))
+         ij = mj1(igrdij_recv(2*ji))
+         DO jk = 1, kpk
+            zsend(jk,ji) = pval(ii,ij,jk)
+         END DO
+      END DO
+
+      ! Re-adjust sizes
+
+      nplocal(:)  = kpk*nplocal(:)
+      npglobal(:) = kpk*npglobal(:)
+
+
+      ! Send and receive data for interpolation stencil
+
+      CALL mpp_alltoallv_real( zsend, kpk*itot,             npglobal, &
+         &                     zrecv, kpk*kptsi*kptsj*kobs, nplocal )
+
+      ! Copy the received data into output data structure
+      
+      DO jobs = 1, kobs
+         DO jj = 1, kptsj
+            DO ji = 1, kptsi
+               it = iorder(ji,jj,jobs)  
+               DO jk = 1, kpk
+                  pgval(ji,jj,jk,jobs) = zrecv(jk,it)
+               END DO
+            END DO
+         END DO
+      END DO
+
+      ! Deallocate message parsing workspace
+
+      DEALLOCATE( &
+         & igrdij_send, &
+         & igrdij_recv, &
+         & zsend,       &
+         & zrecv        &
+         & )
+
+   END SUBROUTINE obs_int_comm_3d_global
+   
+   SUBROUTINE obs_int_comm_3d_local( kptsi, kptsj, kobs, kpi, kpj, kpk, kgrdi, kgrdj, &
+      &                              pval, pgval )
+      !!----------------------------------------------------------------------
+      !!                    ***  ROUTINE obs_int_comm_3d_global  ***
+      !!          
+      !! ** Purpose : Get 3D interpolation stencil (global version)
+      !!
+      !! ** Method  : On-demand communication where each processor send its
+      !!              list of (i,j) of points to all processors and receive 
+      !!              the corresponding values
+      !!
+      !! ** Action  : 
+      !!
+      !! History :
+      !!        !  08-02  (K. Mogensen)  Original code
+      !!----------------------------------------------------------------------
+      !! * Arguments
+      INTEGER, INTENT(IN) :: kptsi        ! Number of i horizontal points per stencil 
+      INTEGER, INTENT(IN) :: kptsj        ! Number of j horizontal points per stencil
+      INTEGER, INTENT(IN) :: kobs         ! Local number of observations
+      INTEGER, INTENT(IN) :: kpi          ! Number of model points in i direction
+      INTEGER, INTENT(IN) :: kpj          ! Number of model points in j direction
+      INTEGER, INTENT(IN) :: kpk          ! Number of levels
+      INTEGER, DIMENSION(kptsi,kptsj,kobs), INTENT(IN) :: &
+         & kgrdi, &         ! i,j indicies for each stencil
+         & kgrdj
+      REAL(KIND=wp), DIMENSION(kpi,kpj,kpk), INTENT(IN) ::&
+         & pval             ! Local 3D array to extract data from
+      REAL(KIND=wp), DIMENSION(kptsi,kptsj,kpk,kobs), INTENT(OUT) ::&
+         & pgval            ! Stencil at each point
+      !! * Local declarations
+      INTEGER ::  ji
+      INTEGER ::  jj
+      INTEGER ::  jk
+      INTEGER ::  jobs
+
+      ! Check valid points
+
+      IF ( ( MAXVAL(kgrdi) > jpi ) .OR. ( MINVAL(kgrdi) < 1 ) .OR. &
+         & ( MAXVAL(kgrdj) > jpj ) .OR. ( MINVAL(kgrdj) < 1 ) ) THEN
+         
+         CALL ctl_stop( 'Error in obs_int_comm_3d_local', &
+            &           'Point outside local domain' )
+ 
+      ENDIF
+
+      ! Copy local data
+
+      DO jobs = 1, kobs
+         DO jj = 1, kptsj
+            DO ji = 1, kptsi
+               DO jk = 1, kpk
+                  pgval(ji,jj,jk,jobs) = &
+                     &            pval(kgrdi(ji,jj,jobs),kgrdj(ji,jj,jobs),jk)
+               END DO
+            END DO
+         END DO
+      END DO
+
+   END SUBROUTINE obs_int_comm_3d_local
+
+END MODULE obs_inter_sup
+ 
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/obs_inter_z1d.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/obs_inter_z1d.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/obs_inter_z1d.F90	(revision 9570)
@@ -0,0 +1,37 @@
+MODULE obs_inter_z1d
+   !!======================================================================
+   !!                       ***  MODULE obs_inter_z1d  ***
+   !! Observation diagnostics: Perform the vertical interpolation
+   !!                          from model grid to observation location
+   !!======================================================================
+
+   !!----------------------------------------------------------------------
+   !!   obs_int_z1d     : Vertical interpolation to the observation point
+   !!   obs_int_z1d_spl : Compute the vertical 2nd derivative of the
+   !!                     interpolating function for a cubic spline (n1dint=1)
+   !!----------------------------------------------------------------------
+   !! * Modules used
+   USE par_kind, ONLY : &  ! Precision variables
+      & wp
+
+   IMPLICIT NONE
+
+   !! * Routine accessibility
+   PRIVATE
+
+   PUBLIC obs_int_z1d,    &  ! Vertical interpolation to the observation pt.
+      &   obs_int_z1d_spl    ! Compute the vertical 2nd derivative of the
+                             ! interpolating function used with a cubic spline
+
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO Consortium (2010)
+   !! $Id$
+   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+
+CONTAINS
+
+#include "obsinter_z1d.h90"
+
+END MODULE obs_inter_z1d
+
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/obs_level_search.h90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/obs_level_search.h90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/obs_level_search.h90	(revision 9570)
@@ -0,0 +1,51 @@
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO Consortium (2010)
+   !! $Id$
+   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+
+   SUBROUTINE obs_level_search( kgrd, pgrddep, kobs, pobsdep, kobsk )
+      !!----------------------------------------------------------------------
+      !!                    ***  ROUTINE obs_level_search ***
+      !!
+      !! ** Purpose : Search levels to find matching level to observed depth
+      !!
+      !! ** Method  : Straightforward search
+      !!
+      !! ** Action  : 
+      !!
+      !! History :
+      !!        !  2001-11  (N. Daget, A. Weaver)
+      !!        !  2006-03  (A. Weaver) NEMOVAR migration.
+      !!        !  2006-05  (K. Mogensen) Moved to to separate routine.
+      !!        !  2006-10  (A. Weaver) Cleanup
+      !!        !  2008-10  (K. Mogensen) Remove assumptions on grid.
+      !!----------------------------------------------------------------------
+
+      !! * Arguments
+      INTEGER, INTENT(IN) :: kgrd     ! Number of gridpoints
+      REAL(KIND=wp), DIMENSION(kgrd), INTENT(INOUT) :: &
+         &   pgrddep  ! Depths of gridpoints
+      INTEGER, INTENT(IN) :: &
+         &   kobs     ! Number of observations
+      REAL(KIND=wp), DIMENSION(kobs), INTENT(INOUT) :: &
+         &   pobsdep  ! Depths of observations
+      INTEGER ,DIMENSION(kobs), INTENT(OUT) :: &
+         &   kobsk    ! Level indices of observations
+  
+      !! * Local declarations
+      INTEGER :: ji
+      INTEGER :: jk
+
+      !------------------------------------------------------------------------
+      ! Search levels for each observations to find matching level
+      !------------------------------------------------------------------------
+      DO ji = 1, kobs 
+         kobsk(ji) = 1
+         depk: DO jk = 2, kgrd
+            IF ( pgrddep(jk) >= pobsdep(ji) ) EXIT depk
+         END DO depk
+         kobsk(ji) = jk
+      END DO
+
+   END SUBROUTINE obs_level_search
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/obs_mpp.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/obs_mpp.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/obs_mpp.F90	(revision 9570)
@@ -0,0 +1,445 @@
+MODULE obs_mpp
+   !!======================================================================
+   !!                       ***  MODULE obs_mpp  ***
+   !! Observation diagnostics: Various MPP support routines
+   !!======================================================================
+   !! History :  2.0  ! 2006-03  (K. Mogensen)  Original code
+   !!             -   ! 2006-05  (K. Mogensen)  Reformatted
+   !!             -   ! 2008-01  (K. Mogensen)  add mpp_global_max
+   !!            3.6  ! 2015-01  (J. Waters) obs_mpp_find_obs_proc 
+   !!                            rewritten to avoid global arrays
+   !!----------------------------------------------------------------------
+#  define mpivar mpi_double_precision
+   !!----------------------------------------------------------------------
+   !! obs_mpp_bcast_integer : Broadcast an integer array from a processor to all processors
+   !! obs_mpp_max_integer   : Find maximum on all processors of each value in an integer on all processors
+   !! obs_mpp_find_obs_proc : Find processors which should hold the observations, avoiding global arrays
+   !! obs_mpp_sum_integers  : Sum an integer array from all processors
+   !! obs_mpp_sum_integer   : Sum an integer from all processors
+   !!----------------------------------------------------------------------
+   USE dom_oce, ONLY :   nproc, mig, mjg   ! Ocean space and time domain variables
+   USE mpp_map, ONLY :   mppmap
+   USE in_out_manager
+#if defined key_mpp_mpi
+   USE lib_mpp, ONLY :   mpi_comm_oce      ! MPP library
+#endif
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC obs_mpp_bcast_integer, & !: Broadcast an integer array from a proc to all procs
+      &   obs_mpp_max_integer,   & !: Find maximum across processors in an integer array
+      &   obs_mpp_find_obs_proc, & !: Find processors which should hold the observations
+      &   obs_mpp_sum_integers,  & !: Sum an integer array from all processors
+      &   obs_mpp_sum_integer,   & !: Sum an integer from all processors
+      &   mpp_alltoall_int,      &
+      &   mpp_alltoallv_int,     &
+      &   mpp_alltoallv_real,    &
+      &   mpp_global_max
+
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO Consortium (2010)
+   !! $Id$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE obs_mpp_bcast_integer( kvals, kno, kroot )
+      !!----------------------------------------------------------------------
+      !!               ***  ROUTINE obs_mpp_bcast_integer ***
+      !!          
+      !! ** Purpose : Send array kvals to all processors
+      !!
+      !! ** Method  : MPI broadcast
+      !!
+      !! ** Action  : This does only work for MPI. 
+      !!              MPI_COMM_OCE needs to be replace for OASIS4.!
+      !!
+      !! References : http://www.mpi-forum.org
+      !!----------------------------------------------------------------------
+      INTEGER                , INTENT(in   ) ::   kno     ! Number of elements in array
+      INTEGER                , INTENT(in   ) ::   kroot   ! Processor to send data
+      INTEGER, DIMENSION(kno), INTENT(inout) ::   kvals   ! Array to send on kroot, receive for non-kroot
+      !
+#if defined key_mpp_mpi
+      !
+      INTEGER :: ierr 
+      !
+INCLUDE 'mpif.h'
+      !!----------------------------------------------------------------------
+
+      ! Call the MPI library to broadcast data
+      CALL mpi_bcast( kvals, kno, mpi_integer,  &
+         &            kroot, mpi_comm_oce, ierr )
+#else
+      ! no MPI: empty routine
+#endif
+      !
+   END SUBROUTINE obs_mpp_bcast_integer
+
+  
+   SUBROUTINE obs_mpp_max_integer( kvals, kno )
+      !!----------------------------------------------------------------------
+      !!               ***  ROUTINE obs_mpp_bcast_integer ***
+      !!          
+      !! ** Purpose : Find maximum across processors in an integer array.
+      !!
+      !! ** Method  : MPI all reduce.
+      !!
+      !! ** Action  : This does only work for MPI. 
+      !!              It does not work for SHMEM.
+      !!              MPI_COMM_OCE needs to be replace for OASIS4.!
+      !!
+      !! References : http://www.mpi-forum.org
+      !!----------------------------------------------------------------------
+      INTEGER                , INTENT(in   ) ::   kno     ! Number of elements in array
+      INTEGER, DIMENSION(kno), INTENT(inout) ::   kvals   ! Array to send on kroot, receive for non-kroot  
+      !
+#if defined key_mpp_mpi
+      !
+      INTEGER :: ierr 
+      INTEGER, DIMENSION(kno) ::   ivals
+      !
+INCLUDE 'mpif.h'
+      !!----------------------------------------------------------------------
+
+      ! Call the MPI library to find the maximum across processors
+      CALL mpi_allreduce( kvals, ivals, kno, mpi_integer,   &
+         &                mpi_max, mpi_comm_oce, ierr )
+      kvals(:) = ivals(:)
+#else
+      ! no MPI: empty routine
+#endif
+   END SUBROUTINE obs_mpp_max_integer
+
+
+   SUBROUTINE obs_mpp_find_obs_proc( kobsp,kno )
+      !!----------------------------------------------------------------------
+      !!               ***  ROUTINE obs_mpp_find_obs_proc  ***
+      !!         
+      !! ** Purpose : From the array kobsp containing the results of the
+      !!              grid search on each processor the processor return a
+      !!              decision of which processors should hold the observation.
+      !!
+      !! ** Method  : Synchronize the processor number for each obs using
+      !!              obs_mpp_max_integer. If an observation exists on two 
+      !!              processors it will be allocated to the lower numbered
+      !!              processor.
+      !!
+      !! ** Action  : This does only work for MPI.
+      !!              It does not work for SHMEM.
+      !!
+      !! References : http://www.mpi-forum.org
+      !!----------------------------------------------------------------------
+      INTEGER                , INTENT(in   ) ::   kno
+      INTEGER, DIMENSION(kno), INTENT(inout) ::   kobsp
+      !
+#if defined key_mpp_mpi
+      !
+      !
+      INTEGER :: ji, isum
+      INTEGER, DIMENSION(kno) ::   iobsp
+      !!
+      !!
+
+      iobsp(:)=kobsp(:)
+
+      WHERE( iobsp(:) == -1 )
+         iobsp(:) = 9999999
+      END WHERE
+
+      iobsp(:)=-1*iobsp(:)
+
+      CALL obs_mpp_max_integer( iobsp, kno )
+
+      kobsp(:)=-1*iobsp(:)
+
+      isum=0
+      DO ji = 1, kno
+         IF ( kobsp(ji) == 9999999 ) THEN
+            isum=isum+1
+            kobsp(ji)=-1
+         ENDIF
+      ENDDO
+
+
+      IF ( isum > 0 ) THEN
+         IF (lwp) WRITE(numout,*) isum, ' observations failed the grid search.'
+         IF (lwp) WRITE(numout,*)'If ln_grid_search_lookup=.TRUE., try reducing grid_search_res'
+      ENDIF
+
+#else
+      ! no MPI: empty routine
+#endif     
+      
+   END SUBROUTINE obs_mpp_find_obs_proc
+
+
+   SUBROUTINE obs_mpp_sum_integers( kvalsin, kvalsout, kno )
+      !!----------------------------------------------------------------------
+      !!               ***  ROUTINE obs_mpp_sum_integers ***
+      !!          
+      !! ** Purpose : Sum an integer array.
+      !!
+      !! ** Method  : MPI all reduce.
+      !!
+      !! ** Action  : This does only work for MPI. 
+      !!              It does not work for SHMEM.
+      !!
+      !! References : http://www.mpi-forum.org
+      !!----------------------------------------------------------------------
+      INTEGER                , INTENT(in   ) :: kno
+      INTEGER, DIMENSION(kno), INTENT(in   ) ::   kvalsin
+      INTEGER, DIMENSION(kno), INTENT(  out) ::   kvalsout
+      !
+#if defined key_mpp_mpi
+      !
+      INTEGER :: ierr
+      !
+INCLUDE 'mpif.h'
+      !!----------------------------------------------------------------------
+      !
+      !-----------------------------------------------------------------------
+      ! Call the MPI library to find the sum across processors
+      !-----------------------------------------------------------------------
+      CALL mpi_allreduce( kvalsin, kvalsout, kno, mpi_integer, &
+         &                mpi_sum, mpi_comm_oce, ierr )
+#else
+      !-----------------------------------------------------------------------
+      ! For no-MPP just return input values
+      !-----------------------------------------------------------------------
+      kvalsout(:) = kvalsin(:)
+#endif
+      !
+   END SUBROUTINE obs_mpp_sum_integers
+
+
+   SUBROUTINE obs_mpp_sum_integer( kvalin, kvalout )
+      !!----------------------------------------------------------------------
+      !!               ***  ROUTINE obs_mpp_sum_integers ***
+      !!          
+      !! ** Purpose : Sum a single integer
+      !!
+      !! ** Method  : MPI all reduce.
+      !!
+      !! ** Action  : This does only work for MPI. 
+      !!              It does not work for SHMEM.
+      !!
+      !! References : http://www.mpi-forum.org
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT(in   ) ::   kvalin
+      INTEGER, INTENT(  out) ::   kvalout
+      !
+#if defined key_mpp_mpi
+      !
+      INTEGER :: ierr
+      !
+INCLUDE 'mpif.h'
+      !!----------------------------------------------------------------------
+      !
+      !-----------------------------------------------------------------------
+      ! Call the MPI library to find the sum across processors
+      !-----------------------------------------------------------------------
+      CALL mpi_allreduce( kvalin, kvalout, 1, mpi_integer,   &
+         &                mpi_sum, mpi_comm_oce, ierr )
+#else
+      !-----------------------------------------------------------------------
+      ! For no-MPP just return input values
+      !-----------------------------------------------------------------------
+      kvalout = kvalin
+#endif
+      !
+   END SUBROUTINE obs_mpp_sum_integer
+
+
+   SUBROUTINE mpp_global_max( pval )
+      !!----------------------------------------------------------------------
+      !!               ***  ROUTINE mpp_global_or ***
+      !!          
+      !! ** Purpose : Get the maximum value across processors for a global 
+      !!              real array
+      !!
+      !! ** Method  : MPI allreduce
+      !!
+      !! ** Action  : This does only work for MPI. 
+      !!              It does not work for SHMEM.
+      !!
+      !! References : http://www.mpi-forum.org
+      !!----------------------------------------------------------------------
+      REAL(KIND=wp), DIMENSION(jpiglo,jpjglo), INTENT(inout) ::   pval
+      !
+      INTEGER :: ierr
+      !
+#if defined key_mpp_mpi
+      !
+INCLUDE 'mpif.h'
+      REAL(KIND=wp), DIMENSION(:,:), ALLOCATABLE ::   zcp
+      !!----------------------------------------------------------------------
+
+      ! Copy data for input to MPI
+
+      ALLOCATE( &
+         & zcp(jpiglo,jpjglo) &
+         & )
+      zcp(:,:) = pval(:,:)
+
+      ! Call the MPI library to find the coast lines globally
+
+      CALL mpi_allreduce( zcp, pval, jpiglo*jpjglo, mpivar, &
+         &                mpi_max, mpi_comm_oce, ierr )
+
+      DEALLOCATE( &
+         & zcp &
+         & )
+
+#else
+      ! no MPI: empty routine
+#endif
+      !
+   END SUBROUTINE mpp_global_max
+
+
+   SUBROUTINE mpp_alltoall_int( kno, kvalsin, kvalsout )
+      !!----------------------------------------------------------------------
+      !!               ***  ROUTINE mpp_allgatherv ***
+      !!          
+      !! ** Purpose : all to all.
+      !!
+      !! ** Method  : MPI alltoall
+      !!
+      !! ** Action  : This does only work for MPI. 
+      !!              It does not work for SHMEM.
+      !!
+      !! References : http://www.mpi-forum.org
+      !!----------------------------------------------------------------------
+      INTEGER                      , INTENT(in   ) ::   kno
+      INTEGER, DIMENSION(kno*jpnij), INTENT(in   ) ::   kvalsin
+      INTEGER, DIMENSION(kno*jpnij), INTENT(  out) ::   kvalsout
+      !!
+      INTEGER :: ierr
+      !
+#if defined key_mpp_mpi
+      !
+INCLUDE 'mpif.h'
+      !-----------------------------------------------------------------------
+      ! Call the MPI library to do the all to all operation of the data
+      !-----------------------------------------------------------------------
+      CALL mpi_alltoall( kvalsin,  kno, mpi_integer, &
+         &               kvalsout, kno, mpi_integer, &
+         &               mpi_comm_oce, ierr )
+#else
+      !-----------------------------------------------------------------------
+      ! For no-MPP just return input values
+      !-----------------------------------------------------------------------
+      kvalsout = kvalsin
+#endif
+      !
+   END SUBROUTINE mpp_alltoall_int
+
+
+   SUBROUTINE mpp_alltoallv_int( kvalsin, knoin , kinv , kvalsout,   &
+      &                                   knoout, koutv )
+      !!----------------------------------------------------------------------
+      !!               ***  ROUTINE mpp_alltoallv_int ***
+      !!          
+      !! ** Purpose : all to all (integer version).
+      !!
+      !! ** Method  : MPI alltoall
+      !!
+      !! ** Action  : This does only work for MPI. 
+      !!              It does not work for SHMEM.
+      !!
+      !! References : http://www.mpi-forum.org
+      !!----------------------------------------------------------------------
+      INTEGER                   , INTENT(in) :: knoin
+      INTEGER                   , INTENT(in) :: knoout
+      INTEGER, DIMENSION(jpnij)                 ::   kinv, koutv
+      INTEGER, DIMENSION(knoin) , INTENT(in   ) ::   kvalsin
+      INTEGER, DIMENSION(knoout), INTENT(  out) ::   kvalsout
+      !!
+      INTEGER :: ierr
+      INTEGER :: jproc
+      !
+#if defined key_mpp_mpi
+      !
+INCLUDE 'mpif.h'
+      INTEGER, DIMENSION(jpnij) ::   irdsp, isdsp
+      !-----------------------------------------------------------------------
+      ! Compute displacements
+      !-----------------------------------------------------------------------
+      irdsp(1) = 0
+      isdsp(1) = 0
+      DO jproc = 2, jpnij
+         isdsp(jproc) = isdsp(jproc-1) + kinv(jproc-1)
+         irdsp(jproc) = irdsp(jproc-1) + koutv(jproc-1)
+      END DO
+      !-----------------------------------------------------------------------
+      ! Call the MPI library to do the all to all operation of the data
+      !-----------------------------------------------------------------------
+      CALL mpi_alltoallv( kvalsin,  kinv,  isdsp, mpi_integer, &
+         &                kvalsout, koutv, irdsp, mpi_integer, &
+         &                mpi_comm_oce, ierr )
+#else
+      !-----------------------------------------------------------------------
+      ! For no-MPP just return input values
+      !-----------------------------------------------------------------------
+      kvalsout = kvalsin
+#endif
+      !
+   END SUBROUTINE mpp_alltoallv_int
+
+
+   SUBROUTINE mpp_alltoallv_real( pvalsin, knoin , kinv , pvalsout,   &
+      &                                    knoout, koutv )
+      !!----------------------------------------------------------------------
+      !!               ***  ROUTINE mpp_alltoallv_real ***
+      !!          
+      !! ** Purpose : all to all (integer version).
+      !!
+      !! ** Method  : MPI alltoall
+      !!
+      !! ** Action  : This does only work for MPI. 
+      !!              It does not work for SHMEM.
+      !!
+      !! References : http://www.mpi-forum.org
+      !!----------------------------------------------------------------------
+      INTEGER                    , INTENT(in   ) :: knoin
+      INTEGER                    , INTENT(in   ) :: knoout
+      INTEGER , DIMENSION(jpnij)                 ::   kinv, koutv
+      REAL(wp), DIMENSION(knoin) , INTENT(in   ) ::   pvalsin
+      REAL(wp), DIMENSION(knoout), INTENT(  out) ::   pvalsout
+      !!
+      INTEGER :: ierr
+      INTEGER :: jproc
+      !
+#if defined key_mpp_mpi
+      !
+INCLUDE 'mpif.h'
+      INTEGER, DIMENSION(jpnij) ::   irdsp, isdsp
+      !!----------------------------------------------------------------------
+      !
+      !-----------------------------------------------------------------------
+      ! Compute displacements
+      !-----------------------------------------------------------------------
+      irdsp(1) = 0
+      isdsp(1) = 0
+      DO jproc = 2, jpnij
+         isdsp(jproc) = isdsp(jproc-1) + kinv(jproc-1)
+         irdsp(jproc) = irdsp(jproc-1) + koutv(jproc-1)
+      END DO
+      !-----------------------------------------------------------------------
+      ! Call the MPI library to do the all to all operation of the data
+      !-----------------------------------------------------------------------
+      CALL mpi_alltoallv( pvalsin,  kinv,  isdsp, mpivar, &
+         &                pvalsout, koutv, irdsp, mpivar, &
+         &                mpi_comm_oce, ierr )
+#else
+      !-----------------------------------------------------------------------
+      ! For no-MPP just return input values
+      !-----------------------------------------------------------------------
+      pvalsout = pvalsin
+#endif
+      !
+   END SUBROUTINE mpp_alltoallv_real
+
+   !!======================================================================
+END MODULE obs_mpp
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/obs_oper.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/obs_oper.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/obs_oper.F90	(revision 9570)
@@ -0,0 +1,977 @@
+MODULE obs_oper
+   !!======================================================================
+   !!                       ***  MODULE obs_oper  ***
+   !! Observation diagnostics: Observation operators for various observation
+   !!                          types
+   !!======================================================================
+
+   !!----------------------------------------------------------------------
+   !!   obs_prof_opt :    Compute the model counterpart of profile data
+   !!   obs_surf_opt :    Compute the model counterpart of surface data
+   !!----------------------------------------------------------------------
+   USE obs_inter_sup                                        ! Interpolation support
+   USE obs_inter_h2d, ONLY : obs_int_h2d, obs_int_h2d_init  ! Horizontal interpolation to the obs pt
+   USE obs_averg_h2d, ONLY : obs_avg_h2d, obs_avg_h2d_init, obs_max_fpsize    ! Horizontal averaging to the obs footprint
+   USE obs_inter_z1d, ONLY : obs_int_z1d, obs_int_z1d_spl   ! Vertical interpolation to the obs pt
+   USE obs_const    , ONLY : obfillflt                      ! Obs fill value
+   USE dom_oce,       ONLY :   glamt, glamf, gphit, gphif   ! lat/lon of ocean grid-points
+   USE lib_mpp,       ONLY :   ctl_warn, ctl_stop           ! Warning and stopping routines
+   USE sbcdcy,        ONLY :   sbc_dcy, nday_qsr            ! For calculation of where it is night-time
+   USE obs_grid,      ONLY :   obs_level_search     
+   !
+   USE par_kind     , ONLY :   wp   ! Precision variables
+   USE in_out_manager               ! I/O manager
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   obs_prof_opt   !: Compute the model counterpart of profile obs
+   PUBLIC   obs_surf_opt   !: Compute the model counterpart of surface obs
+
+   INTEGER, PARAMETER, PUBLIC ::   imaxavtypes = 20   !: Max number of daily avgd obs types
+
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 4.0 , NEMO Consortium (2018)
+   !! $Id$
+   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE obs_prof_opt( prodatqc, kt, kpi, kpj, kpk,          &
+      &                     kit000, kdaystp,                      &
+      &                     pvar1, pvar2, pgdept, pgdepw,         &
+      &                     pmask1, pmask2,                       &  
+      &                     plam1, plam2, pphi1, pphi2,           &
+      &                     k1dint, k2dint, kdailyavtypes )
+      !!-----------------------------------------------------------------------
+      !!                     ***  ROUTINE obs_pro_opt  ***
+      !!
+      !! ** Purpose : Compute the model counterpart of profiles
+      !!              data by interpolating from the model grid to the 
+      !!              observation point.
+      !!
+      !! ** Method  : Linearly interpolate to each observation point using 
+      !!              the model values at the corners of the surrounding grid box.
+      !!
+      !!    First, a vertical profile of horizontally interpolated model
+      !!    now values is computed at the obs (lon, lat) point.
+      !!    Several horizontal interpolation schemes are available:
+      !!        - distance-weighted (great circle) (k2dint = 0)
+      !!        - distance-weighted (small angle)  (k2dint = 1)
+      !!        - bilinear (geographical grid)     (k2dint = 2)
+      !!        - bilinear (quadrilateral grid)    (k2dint = 3)
+      !!        - polynomial (quadrilateral grid)  (k2dint = 4)
+      !!
+      !!    Next, the vertical profile is interpolated to the
+      !!    data depth points. Two vertical interpolation schemes are
+      !!    available:
+      !!        - linear       (k1dint = 0)
+      !!        - Cubic spline (k1dint = 1)
+      !!
+      !!    For the cubic spline the 2nd derivative of the interpolating 
+      !!    polynomial is computed before entering the vertical interpolation 
+      !!    routine.
+      !!
+      !!    If the logical is switched on, the model equivalent is
+      !!    a daily mean model temperature field. So, we first compute
+      !!    the mean, then interpolate only at the end of the day.
+      !!
+      !!    Note: in situ temperature observations must be converted
+      !!    to potential temperature (the model variable) prior to
+      !!    assimilation. 
+      !!
+      !! ** Action  :
+      !!
+      !! History :
+      !!      ! 97-11 (A. Weaver, S. Ricci, N. Daget)
+      !!      ! 06-03 (G. Smith) NEMOVAR migration
+      !!      ! 06-10 (A. Weaver) Cleanup
+      !!      ! 07-01 (K. Mogensen) Merge of temperature and salinity
+      !!      ! 07-03 (K. Mogensen) General handling of profiles
+      !!      ! 15-02 (M. Martin) Combined routine for all profile types
+      !!      ! 17-02 (M. Martin) Include generalised vertical coordinate changes
+      !!-----------------------------------------------------------------------
+      USE obs_profiles_def ! Definition of storage space for profile obs.
+
+      IMPLICIT NONE
+
+      TYPE(obs_prof), INTENT(inout) ::   prodatqc        ! Subset of profile data passing QC
+      INTEGER       , INTENT(in   ) ::   kt              ! Time step
+      INTEGER       , INTENT(in   ) ::   kpi, kpj, kpk   ! Model grid parameters
+      INTEGER       , INTENT(in   ) ::   kit000          ! Number of the first time step (kit000-1 = restart time)
+      INTEGER       , INTENT(in   ) ::   k1dint          ! Vertical interpolation type (see header)
+      INTEGER       , INTENT(in   ) ::   k2dint          ! Horizontal interpolation type (see header)
+      INTEGER       , INTENT(in   ) ::   kdaystp         ! Number of time steps per day
+      REAL(KIND=wp) , INTENT(in   ), DIMENSION(kpi,kpj,kpk) ::   pvar1 , pvar2    ! Model field     1 and 2
+      REAL(KIND=wp) , INTENT(in   ), DIMENSION(kpi,kpj,kpk) ::   pmask1, pmask2   ! Land-sea mask   1 and 2
+      REAL(KIND=wp) , INTENT(in   ), DIMENSION(kpi,kpj)     ::   plam1 , plam2    ! Model longitude 1 and 2
+      REAL(KIND=wp) , INTENT(in   ), DIMENSION(kpi,kpj)     ::   pphi1 , pphi2    ! Model latitudes 1 and 2
+      REAL(KIND=wp) , INTENT(in   ), DIMENSION(kpi,kpj,kpk) ::   pgdept, pgdepw   ! depth of T and W levels 
+      INTEGER, DIMENSION(imaxavtypes), OPTIONAL ::   kdailyavtypes             ! Types for daily averages
+
+      !! * Local declarations
+      INTEGER ::   ji
+      INTEGER ::   jj
+      INTEGER ::   jk
+      INTEGER ::   jobs
+      INTEGER ::   inrc
+      INTEGER ::   ipro
+      INTEGER ::   idayend
+      INTEGER ::   ista
+      INTEGER ::   iend
+      INTEGER ::   iobs
+      INTEGER ::   iin, ijn, ikn, ik   ! looping indices over interpolation nodes 
+      INTEGER ::   inum_obs
+      INTEGER, DIMENSION(imaxavtypes) :: &
+         & idailyavtypes
+      INTEGER, DIMENSION(:,:,:), ALLOCATABLE :: &
+         & igrdi1, &
+         & igrdi2, &
+         & igrdj1, &
+         & igrdj2
+      INTEGER, ALLOCATABLE, DIMENSION(:) :: iv_indic
+
+      REAL(KIND=wp) :: zlam
+      REAL(KIND=wp) :: zphi
+      REAL(KIND=wp) :: zdaystp
+      REAL(KIND=wp), DIMENSION(kpk) :: &
+         & zobsmask1, &
+         & zobsmask2, &
+         & zobsk,    &
+         & zobs2k
+      REAL(KIND=wp), DIMENSION(2,2,1) :: &
+         & zweig1, &
+         & zweig2, &
+         & zweig
+      REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: &
+         & zmask1, &
+         & zmask2, &
+         & zint1,  &
+         & zint2,  &
+         & zinm1,  &
+         & zinm2,  &
+         & zgdept, & 
+         & zgdepw
+      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: &
+         & zglam1, &
+         & zglam2, &
+         & zgphi1, &
+         & zgphi2
+      REAL(KIND=wp), DIMENSION(1) :: zmsk_1, zmsk_2   
+      REAL(KIND=wp), DIMENSION(:,:,:), ALLOCATABLE :: interp_corner
+
+      LOGICAL :: ld_dailyav
+
+      !------------------------------------------------------------------------
+      ! Local initialization 
+      !------------------------------------------------------------------------
+      ! Record and data counters
+      inrc = kt - kit000 + 2
+      ipro = prodatqc%npstp(inrc)
+
+      ! Daily average types
+      ld_dailyav = .FALSE.
+      IF ( PRESENT(kdailyavtypes) ) THEN
+         idailyavtypes(:) = kdailyavtypes(:)
+         IF ( ANY (idailyavtypes(:) /= -1) ) ld_dailyav = .TRUE.
+      ELSE
+         idailyavtypes(:) = -1
+      ENDIF
+
+      ! Daily means are calculated for values over timesteps:
+      !  [1 <= kt <= kdaystp], [kdaystp+1 <= kt <= 2*kdaystp], ...
+      idayend = MOD( kt - kit000 + 1, kdaystp )
+
+      IF ( ld_dailyav ) THEN
+
+         ! Initialize daily mean for first timestep of the day
+         IF ( idayend == 1 .OR. kt == 0 ) THEN
+            DO jk = 1, jpk
+               DO jj = 1, jpj
+                  DO ji = 1, jpi
+                     prodatqc%vdmean(ji,jj,jk,1) = 0.0
+                     prodatqc%vdmean(ji,jj,jk,2) = 0.0
+                  END DO
+               END DO
+            END DO
+         ENDIF
+
+         DO jk = 1, jpk
+            DO jj = 1, jpj
+               DO ji = 1, jpi
+                  ! Increment field 1 for computing daily mean
+                  prodatqc%vdmean(ji,jj,jk,1) = prodatqc%vdmean(ji,jj,jk,1) &
+                     &                        + pvar1(ji,jj,jk)
+                  ! Increment field 2 for computing daily mean
+                  prodatqc%vdmean(ji,jj,jk,2) = prodatqc%vdmean(ji,jj,jk,2) &
+                     &                        + pvar2(ji,jj,jk)
+               END DO
+            END DO
+         END DO
+
+         ! Compute the daily mean at the end of day
+         zdaystp = 1.0 / REAL( kdaystp )
+         IF ( idayend == 0 ) THEN
+            IF (lwp) WRITE(numout,*) 'Calculating prodatqc%vdmean on time-step: ',kt
+            CALL FLUSH(numout)
+            DO jk = 1, jpk
+               DO jj = 1, jpj
+                  DO ji = 1, jpi
+                     prodatqc%vdmean(ji,jj,jk,1) = prodatqc%vdmean(ji,jj,jk,1) &
+                        &                        * zdaystp
+                     prodatqc%vdmean(ji,jj,jk,2) = prodatqc%vdmean(ji,jj,jk,2) &
+                        &                        * zdaystp
+                  END DO
+               END DO
+            END DO
+         ENDIF
+
+      ENDIF
+
+      ! Get the data for interpolation
+      ALLOCATE( &
+         & igrdi1(2,2,ipro),      &
+         & igrdi2(2,2,ipro),      &
+         & igrdj1(2,2,ipro),      &
+         & igrdj2(2,2,ipro),      &
+         & zglam1(2,2,ipro),      &
+         & zglam2(2,2,ipro),      &
+         & zgphi1(2,2,ipro),      &
+         & zgphi2(2,2,ipro),      &
+         & zmask1(2,2,kpk,ipro),  &
+         & zmask2(2,2,kpk,ipro),  &
+         & zint1(2,2,kpk,ipro),   &
+         & zint2(2,2,kpk,ipro),   &
+         & zgdept(2,2,kpk,ipro),  & 
+         & zgdepw(2,2,kpk,ipro)   & 
+         & )
+
+      DO jobs = prodatqc%nprofup + 1, prodatqc%nprofup + ipro
+         iobs = jobs - prodatqc%nprofup
+         igrdi1(1,1,iobs) = prodatqc%mi(jobs,1)-1
+         igrdj1(1,1,iobs) = prodatqc%mj(jobs,1)-1
+         igrdi1(1,2,iobs) = prodatqc%mi(jobs,1)-1
+         igrdj1(1,2,iobs) = prodatqc%mj(jobs,1)
+         igrdi1(2,1,iobs) = prodatqc%mi(jobs,1)
+         igrdj1(2,1,iobs) = prodatqc%mj(jobs,1)-1
+         igrdi1(2,2,iobs) = prodatqc%mi(jobs,1)
+         igrdj1(2,2,iobs) = prodatqc%mj(jobs,1)
+         igrdi2(1,1,iobs) = prodatqc%mi(jobs,2)-1
+         igrdj2(1,1,iobs) = prodatqc%mj(jobs,2)-1
+         igrdi2(1,2,iobs) = prodatqc%mi(jobs,2)-1
+         igrdj2(1,2,iobs) = prodatqc%mj(jobs,2)
+         igrdi2(2,1,iobs) = prodatqc%mi(jobs,2)
+         igrdj2(2,1,iobs) = prodatqc%mj(jobs,2)-1
+         igrdi2(2,2,iobs) = prodatqc%mi(jobs,2)
+         igrdj2(2,2,iobs) = prodatqc%mj(jobs,2)
+      END DO
+
+      ! Initialise depth arrays
+      zgdept(:,:,:,:) = 0.0
+      zgdepw(:,:,:,:) = 0.0
+
+      CALL obs_int_comm_2d( 2, 2, ipro, kpi, kpj, igrdi1, igrdj1, plam1, zglam1 )
+      CALL obs_int_comm_2d( 2, 2, ipro, kpi, kpj, igrdi1, igrdj1, pphi1, zgphi1 )
+      CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi1, igrdj1, pmask1, zmask1 )
+      CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi1, igrdj1, pvar1,   zint1 )
+      
+      CALL obs_int_comm_2d( 2, 2, ipro, kpi, kpj, igrdi2, igrdj2, plam2, zglam2 )
+      CALL obs_int_comm_2d( 2, 2, ipro, kpi, kpj, igrdi2, igrdj2, pphi2, zgphi2 )
+      CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi2, igrdj2, pmask2, zmask2 )
+      CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi2, igrdj2, pvar2,   zint2 )
+
+      CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi1, igrdj1, pgdept, zgdept ) 
+      CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi1, igrdj1, pgdepw, zgdepw ) 
+
+      ! At the end of the day also get interpolated means
+      IF ( ld_dailyav .AND. idayend == 0 ) THEN
+
+         ALLOCATE( &
+            & zinm1(2,2,kpk,ipro),  &
+            & zinm2(2,2,kpk,ipro)   &
+            & )
+
+         CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi1, igrdj1, &
+            &                  prodatqc%vdmean(:,:,:,1), zinm1 )
+         CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi2, igrdj2, &
+            &                  prodatqc%vdmean(:,:,:,2), zinm2 )
+
+      ENDIF
+
+      ! Return if no observations to process 
+      ! Has to be done after comm commands to ensure processors 
+      ! stay in sync 
+      IF ( ipro == 0 ) RETURN 
+
+      DO jobs = prodatqc%nprofup + 1, prodatqc%nprofup + ipro
+
+         iobs = jobs - prodatqc%nprofup
+
+         IF ( kt /= prodatqc%mstp(jobs) ) THEN
+
+            IF(lwp) THEN
+               WRITE(numout,*)
+               WRITE(numout,*) ' E R R O R : Observation',              &
+                  &            ' time step is not consistent with the', &
+                  &            ' model time step'
+               WRITE(numout,*) ' ========='
+               WRITE(numout,*)
+               WRITE(numout,*) ' Record  = ', jobs,                    &
+                  &            ' kt      = ', kt,                      &
+                  &            ' mstp    = ', prodatqc%mstp(jobs), &
+                  &            ' ntyp    = ', prodatqc%ntyp(jobs)
+            ENDIF
+            CALL ctl_stop( 'obs_pro_opt', 'Inconsistent time' )
+         ENDIF
+
+         zlam = prodatqc%rlam(jobs)
+         zphi = prodatqc%rphi(jobs)
+
+         ! Horizontal weights 
+         ! Masked values are calculated later.  
+         IF ( prodatqc%npvend(jobs,1) > 0 ) THEN
+
+            CALL obs_int_h2d_init( 1, 1, k2dint, zlam, zphi,     &
+               &                   zglam1(:,:,iobs), zgphi1(:,:,iobs), &
+               &                   zmask1(:,:,1,iobs), zweig1, zmsk_1 )
+
+         ENDIF
+
+         IF ( prodatqc%npvend(jobs,2) > 0 ) THEN
+
+            CALL obs_int_h2d_init( 1, 1, k2dint, zlam, zphi,     &
+               &                   zglam2(:,:,iobs), zgphi2(:,:,iobs), &
+               &                   zmask2(:,:,1,iobs), zweig2, zmsk_2 )
+ 
+         ENDIF
+
+         IF ( prodatqc%npvend(jobs,1) > 0 ) THEN
+
+            zobsk(:) = obfillflt
+
+            IF ( ANY (idailyavtypes(:) == prodatqc%ntyp(jobs)) ) THEN
+
+               IF ( idayend == 0 )  THEN
+                  ! Daily averaged data
+
+                  ! vertically interpolate all 4 corners 
+                  ista = prodatqc%npvsta(jobs,1) 
+                  iend = prodatqc%npvend(jobs,1) 
+                  inum_obs = iend - ista + 1 
+                  ALLOCATE(interp_corner(2,2,inum_obs),iv_indic(inum_obs)) 
+
+                  DO iin=1,2 
+                     DO ijn=1,2 
+
+                        IF ( k1dint == 1 ) THEN 
+                           CALL obs_int_z1d_spl( kpk, & 
+                              &     zinm1(iin,ijn,:,iobs), & 
+                              &     zobs2k, zgdept(iin,ijn,:,iobs), & 
+                              &     zmask1(iin,ijn,:,iobs)) 
+                        ENDIF 
+       
+                        CALL obs_level_search(kpk, & 
+                           &    zgdept(iin,ijn,:,iobs), & 
+                           &    inum_obs, prodatqc%var(1)%vdep(ista:iend), & 
+                           &    iv_indic) 
+
+                        CALL obs_int_z1d(kpk, iv_indic, k1dint, inum_obs, & 
+                           &    prodatqc%var(1)%vdep(ista:iend), & 
+                           &    zinm1(iin,ijn,:,iobs), & 
+                           &    zobs2k, interp_corner(iin,ijn,:), & 
+                           &    zgdept(iin,ijn,:,iobs), & 
+                           &    zmask1(iin,ijn,:,iobs)) 
+       
+                     ENDDO 
+                  ENDDO 
+
+               ENDIF !idayend
+
+            ELSE   
+
+               ! Point data 
+     
+               ! vertically interpolate all 4 corners 
+               ista = prodatqc%npvsta(jobs,1) 
+               iend = prodatqc%npvend(jobs,1) 
+               inum_obs = iend - ista + 1 
+               ALLOCATE(interp_corner(2,2,inum_obs), iv_indic(inum_obs)) 
+               DO iin=1,2  
+                  DO ijn=1,2 
+                    
+                     IF ( k1dint == 1 ) THEN 
+                        CALL obs_int_z1d_spl( kpk, & 
+                           &    zint1(iin,ijn,:,iobs),& 
+                           &    zobs2k, zgdept(iin,ijn,:,iobs), & 
+                           &    zmask1(iin,ijn,:,iobs)) 
+  
+                     ENDIF 
+       
+                     CALL obs_level_search(kpk, & 
+                         &        zgdept(iin,ijn,:,iobs),& 
+                         &        inum_obs, prodatqc%var(1)%vdep(ista:iend), & 
+                         &        iv_indic) 
+
+                     CALL obs_int_z1d(kpk, iv_indic, k1dint, inum_obs,     & 
+                         &          prodatqc%var(1)%vdep(ista:iend),     & 
+                         &          zint1(iin,ijn,:,iobs),            & 
+                         &          zobs2k,interp_corner(iin,ijn,:), & 
+                         &          zgdept(iin,ijn,:,iobs),         & 
+                         &          zmask1(iin,ijn,:,iobs) )      
+         
+                  ENDDO 
+               ENDDO 
+             
+            ENDIF 
+
+            !------------------------------------------------------------- 
+            ! Compute the horizontal interpolation for every profile level 
+            !------------------------------------------------------------- 
+             
+            DO ikn=1,inum_obs 
+               iend=ista+ikn-1
+                  
+               zweig(:,:,1) = 0._wp 
+   
+               ! This code forces the horizontal weights to be  
+               ! zero IF the observation is below the bottom of the  
+               ! corners of the interpolation nodes, Or if it is in  
+               ! the mask. This is important for observations near  
+               ! steep bathymetry 
+               DO iin=1,2 
+                  DO ijn=1,2 
+     
+                     depth_loop1: DO ik=kpk,2,-1 
+                        IF(zmask1(iin,ijn,ik-1,iobs ) > 0.9 )THEN   
+                            
+                           zweig(iin,ijn,1) = &  
+                              & zweig1(iin,ijn,1) * & 
+                              & MAX( SIGN(1._wp,(zgdepw(iin,ijn,ik,iobs) ) & 
+                              &  - prodatqc%var(1)%vdep(iend)),0._wp) 
+                            
+                           EXIT depth_loop1 
+
+                        ENDIF 
+
+                     ENDDO depth_loop1 
+     
+                  ENDDO 
+               ENDDO 
+   
+               CALL obs_int_h2d( 1, 1, zweig, interp_corner(:,:,ikn), & 
+                  &              prodatqc%var(1)%vmod(iend:iend) ) 
+
+                  ! Set QC flag for any observations found below the bottom
+                  ! needed as the check here is more strict than that in obs_prep
+               IF (sum(zweig) == 0.0_wp) prodatqc%var(1)%nvqc(iend:iend)=4
+ 
+            ENDDO 
+ 
+            DEALLOCATE(interp_corner,iv_indic) 
+          
+         ENDIF 
+
+         ! For the second variable
+         IF ( prodatqc%npvend(jobs,2) > 0 ) THEN
+
+            zobsk(:) = obfillflt
+
+            IF ( ANY (idailyavtypes(:) == prodatqc%ntyp(jobs)) ) THEN
+
+               IF ( idayend == 0 )  THEN
+                  ! Daily averaged data
+
+                  ! vertically interpolate all 4 corners 
+                  ista = prodatqc%npvsta(jobs,2) 
+                  iend = prodatqc%npvend(jobs,2) 
+                  inum_obs = iend - ista + 1 
+                  ALLOCATE(interp_corner(2,2,inum_obs),iv_indic(inum_obs)) 
+
+                  DO iin=1,2 
+                     DO ijn=1,2 
+
+                        IF ( k1dint == 1 ) THEN 
+                           CALL obs_int_z1d_spl( kpk, & 
+                              &     zinm2(iin,ijn,:,iobs), & 
+                              &     zobs2k, zgdept(iin,ijn,:,iobs), & 
+                              &     zmask2(iin,ijn,:,iobs)) 
+                        ENDIF 
+       
+                        CALL obs_level_search(kpk, & 
+                           &    zgdept(iin,ijn,:,iobs), & 
+                           &    inum_obs, prodatqc%var(2)%vdep(ista:iend), & 
+                           &    iv_indic) 
+
+                        CALL obs_int_z1d(kpk, iv_indic, k1dint, inum_obs, & 
+                           &    prodatqc%var(2)%vdep(ista:iend), & 
+                           &    zinm2(iin,ijn,:,iobs), & 
+                           &    zobs2k, interp_corner(iin,ijn,:), & 
+                           &    zgdept(iin,ijn,:,iobs), & 
+                           &    zmask2(iin,ijn,:,iobs)) 
+       
+                     ENDDO 
+                  ENDDO 
+
+               ENDIF !idayend
+
+            ELSE   
+
+               ! Point data 
+     
+               ! vertically interpolate all 4 corners 
+               ista = prodatqc%npvsta(jobs,2) 
+               iend = prodatqc%npvend(jobs,2) 
+               inum_obs = iend - ista + 1 
+               ALLOCATE(interp_corner(2,2,inum_obs), iv_indic(inum_obs)) 
+               DO iin=1,2  
+                  DO ijn=1,2 
+                    
+                     IF ( k1dint == 1 ) THEN 
+                        CALL obs_int_z1d_spl( kpk, & 
+                           &    zint2(iin,ijn,:,iobs),& 
+                           &    zobs2k, zgdept(iin,ijn,:,iobs), & 
+                           &    zmask2(iin,ijn,:,iobs)) 
+  
+                     ENDIF 
+       
+                     CALL obs_level_search(kpk, & 
+                         &        zgdept(iin,ijn,:,iobs),& 
+                         &        inum_obs, prodatqc%var(2)%vdep(ista:iend), & 
+                         &        iv_indic) 
+
+                     CALL obs_int_z1d(kpk, iv_indic, k1dint, inum_obs,     & 
+                         &          prodatqc%var(2)%vdep(ista:iend),     & 
+                         &          zint2(iin,ijn,:,iobs),            & 
+                         &          zobs2k,interp_corner(iin,ijn,:), & 
+                         &          zgdept(iin,ijn,:,iobs),         & 
+                         &          zmask2(iin,ijn,:,iobs) )      
+         
+                  ENDDO 
+               ENDDO 
+             
+            ENDIF 
+
+            !------------------------------------------------------------- 
+            ! Compute the horizontal interpolation for every profile level 
+            !------------------------------------------------------------- 
+             
+            DO ikn=1,inum_obs 
+               iend=ista+ikn-1
+                  
+               zweig(:,:,1) = 0._wp 
+   
+               ! This code forces the horizontal weights to be  
+               ! zero IF the observation is below the bottom of the  
+               ! corners of the interpolation nodes, Or if it is in  
+               ! the mask. This is important for observations near  
+               ! steep bathymetry 
+               DO iin=1,2 
+                  DO ijn=1,2 
+     
+                     depth_loop2: DO ik=kpk,2,-1 
+                        IF(zmask2(iin,ijn,ik-1,iobs ) > 0.9 )THEN   
+                            
+                           zweig(iin,ijn,1) = &  
+                              & zweig2(iin,ijn,1) * & 
+                              & MAX( SIGN(1._wp,(zgdepw(iin,ijn,ik,iobs) ) & 
+                              &  - prodatqc%var(2)%vdep(iend)),0._wp) 
+                            
+                           EXIT depth_loop2 
+
+                        ENDIF 
+
+                     ENDDO depth_loop2 
+     
+                  ENDDO 
+               ENDDO 
+   
+               CALL obs_int_h2d( 1, 1, zweig, interp_corner(:,:,ikn), & 
+                  &              prodatqc%var(2)%vmod(iend:iend) ) 
+
+                  ! Set QC flag for any observations found below the bottom
+                  ! needed as the check here is more strict than that in obs_prep
+               IF (sum(zweig) == 0.0_wp) prodatqc%var(2)%nvqc(iend:iend)=4
+ 
+            ENDDO 
+ 
+            DEALLOCATE(interp_corner,iv_indic) 
+          
+         ENDIF 
+
+      ENDDO
+
+      ! Deallocate the data for interpolation
+      DEALLOCATE( &
+         & igrdi1, &
+         & igrdi2, &
+         & igrdj1, &
+         & igrdj2, &
+         & zglam1, &
+         & zglam2, &
+         & zgphi1, &
+         & zgphi2, &
+         & zmask1, &
+         & zmask2, &
+         & zint1,  &
+         & zint2,  &
+         & zgdept, &
+         & zgdepw  &
+         & )
+
+      ! At the end of the day also get interpolated means
+      IF ( ld_dailyav .AND. idayend == 0 ) THEN
+         DEALLOCATE( &
+            & zinm1,  &
+            & zinm2   &
+            & )
+      ENDIF
+
+      prodatqc%nprofup = prodatqc%nprofup + ipro 
+
+   END SUBROUTINE obs_prof_opt
+
+   SUBROUTINE obs_surf_opt( surfdataqc, kt, kpi, kpj,            &
+      &                     kit000, kdaystp, psurf, psurfmask,   &
+      &                     k2dint, ldnightav, plamscl, pphiscl, &
+      &                     lindegrees )
+
+      !!-----------------------------------------------------------------------
+      !!
+      !!                     ***  ROUTINE obs_surf_opt  ***
+      !!
+      !! ** Purpose : Compute the model counterpart of surface
+      !!              data by interpolating from the model grid to the 
+      !!              observation point.
+      !!
+      !! ** Method  : Linearly interpolate to each observation point using 
+      !!              the model values at the corners of the surrounding grid box.
+      !!
+      !!    The new model value is first computed at the obs (lon, lat) point.
+      !!
+      !!    Several horizontal interpolation schemes are available:
+      !!        - distance-weighted (great circle) (k2dint = 0)
+      !!        - distance-weighted (small angle)  (k2dint = 1)
+      !!        - bilinear (geographical grid)     (k2dint = 2)
+      !!        - bilinear (quadrilateral grid)    (k2dint = 3)
+      !!        - polynomial (quadrilateral grid)  (k2dint = 4)
+      !!
+      !!    Two horizontal averaging schemes are also available:
+      !!        - weighted radial footprint        (k2dint = 5)
+      !!        - weighted rectangular footprint   (k2dint = 6)
+      !!
+      !!
+      !! ** Action  :
+      !!
+      !! History :
+      !!      ! 07-03 (A. Weaver)
+      !!      ! 15-02 (M. Martin) Combined routine for surface types
+      !!      ! 17-03 (M. Martin) Added horizontal averaging options
+      !!-----------------------------------------------------------------------
+      USE obs_surf_def  ! Definition of storage space for surface observations
+
+      IMPLICIT NONE
+
+      TYPE(obs_surf), INTENT(INOUT) :: &
+         & surfdataqc                  ! Subset of surface data passing QC
+      INTEGER, INTENT(IN) :: kt        ! Time step
+      INTEGER, INTENT(IN) :: kpi       ! Model grid parameters
+      INTEGER, INTENT(IN) :: kpj
+      INTEGER, INTENT(IN) :: kit000    ! Number of the first time step 
+                                       !   (kit000-1 = restart time)
+      INTEGER, INTENT(IN) :: kdaystp   ! Number of time steps per day
+      INTEGER, INTENT(IN) :: k2dint    ! Horizontal interpolation type (see header)
+      REAL(wp), INTENT(IN), DIMENSION(kpi,kpj) :: &
+         & psurf,  &                   ! Model surface field
+         & psurfmask                   ! Land-sea mask
+      LOGICAL, INTENT(IN) :: ldnightav ! Logical for averaging night-time data
+      REAL(KIND=wp), INTENT(IN) :: &
+         & plamscl, &                  ! Diameter in metres of obs footprint in E/W, N/S directions
+         & pphiscl                     ! This is the full width (rather than half-width)
+      LOGICAL, INTENT(IN) :: &
+         & lindegrees                  ! T=> plamscl and pphiscl are specified in degrees, F=> in metres
+
+      !! * Local declarations
+      INTEGER :: ji
+      INTEGER :: jj
+      INTEGER :: jobs
+      INTEGER :: inrc
+      INTEGER :: isurf
+      INTEGER :: iobs
+      INTEGER :: imaxifp, imaxjfp
+      INTEGER :: imodi, imodj
+      INTEGER :: idayend
+      INTEGER, DIMENSION(:,:,:), ALLOCATABLE :: &
+         & igrdi,   &
+         & igrdj,   &
+         & igrdip1, &
+         & igrdjp1
+      INTEGER, DIMENSION(:,:), SAVE, ALLOCATABLE :: &
+         & icount_night,      &
+         & imask_night
+      REAL(wp) :: zlam
+      REAL(wp) :: zphi
+      REAL(wp), DIMENSION(1) :: zext, zobsmask
+      REAL(wp) :: zdaystp
+      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: &
+         & zweig,  &
+         & zmask,  &
+         & zsurf,  &
+         & zsurfm, &
+         & zsurftmp, &
+         & zglam,  &
+         & zgphi,  &
+         & zglamf, &
+         & zgphif
+
+      REAL(wp), DIMENSION(:,:), SAVE, ALLOCATABLE :: &
+         & zintmp,  &
+         & zouttmp, &
+         & zmeanday    ! to compute model sst in region of 24h daylight (pole)
+
+      !------------------------------------------------------------------------
+      ! Local initialization 
+      !------------------------------------------------------------------------
+      ! Record and data counters
+      inrc = kt - kit000 + 2
+      isurf = surfdataqc%nsstp(inrc)
+
+      ! Work out the maximum footprint size for the 
+      ! interpolation/averaging in model grid-points - has to be even.
+
+      CALL obs_max_fpsize( k2dint, plamscl, pphiscl, lindegrees, psurfmask, imaxifp, imaxjfp )
+
+
+      IF ( ldnightav ) THEN
+
+      ! Initialize array for night mean
+         IF ( kt == 0 ) THEN
+            ALLOCATE ( icount_night(kpi,kpj) )
+            ALLOCATE ( imask_night(kpi,kpj) )
+            ALLOCATE ( zintmp(kpi,kpj) )
+            ALLOCATE ( zouttmp(kpi,kpj) )
+            ALLOCATE ( zmeanday(kpi,kpj) )
+            nday_qsr = -1   ! initialisation flag for nbc_dcy
+         ENDIF
+
+         ! Night-time means are calculated for night-time values over timesteps:
+         !  [1 <= kt <= kdaystp], [kdaystp+1 <= kt <= 2*kdaystp], .....
+         idayend = MOD( kt - kit000 + 1, kdaystp )
+
+         ! Initialize night-time mean for first timestep of the day
+         IF ( idayend == 1 .OR. kt == 0 ) THEN
+            DO jj = 1, jpj
+               DO ji = 1, jpi
+                  surfdataqc%vdmean(ji,jj) = 0.0
+                  zmeanday(ji,jj) = 0.0
+                  icount_night(ji,jj) = 0
+               END DO
+            END DO
+         ENDIF
+
+         zintmp(:,:) = 0.0
+         zouttmp(:,:) = sbc_dcy( zintmp(:,:), .TRUE. )
+         imask_night(:,:) = INT( zouttmp(:,:) )
+
+         DO jj = 1, jpj
+            DO ji = 1, jpi
+               ! Increment the temperature field for computing night mean and counter
+               surfdataqc%vdmean(ji,jj) = surfdataqc%vdmean(ji,jj)  &
+                      &                    + psurf(ji,jj) * REAL( imask_night(ji,jj) )
+               zmeanday(ji,jj)          = zmeanday(ji,jj) + psurf(ji,jj)
+               icount_night(ji,jj)      = icount_night(ji,jj) + imask_night(ji,jj)
+            END DO
+         END DO
+
+         ! Compute the night-time mean at the end of the day
+         zdaystp = 1.0 / REAL( kdaystp )
+         IF ( idayend == 0 ) THEN
+            IF (lwp) WRITE(numout,*) 'Calculating surfdataqc%vdmean on time-step: ',kt
+            DO jj = 1, jpj
+               DO ji = 1, jpi
+                  ! Test if "no night" point
+                  IF ( icount_night(ji,jj) > 0 ) THEN
+                     surfdataqc%vdmean(ji,jj) = surfdataqc%vdmean(ji,jj) &
+                       &                        / REAL( icount_night(ji,jj) )
+                  ELSE
+                     !At locations where there is no night (e.g. poles),
+                     ! calculate daily mean instead of night-time mean.
+                     surfdataqc%vdmean(ji,jj) = zmeanday(ji,jj) * zdaystp
+                  ENDIF
+               END DO
+            END DO
+         ENDIF
+
+      ENDIF
+
+      ! Get the data for interpolation
+
+      ALLOCATE( &
+         & zweig(imaxifp,imaxjfp,1),      &
+         & igrdi(imaxifp,imaxjfp,isurf), &
+         & igrdj(imaxifp,imaxjfp,isurf), &
+         & zglam(imaxifp,imaxjfp,isurf), &
+         & zgphi(imaxifp,imaxjfp,isurf), &
+         & zmask(imaxifp,imaxjfp,isurf), &
+         & zsurf(imaxifp,imaxjfp,isurf), &
+         & zsurftmp(imaxifp,imaxjfp,isurf),  &
+         & zglamf(imaxifp+1,imaxjfp+1,isurf), &
+         & zgphif(imaxifp+1,imaxjfp+1,isurf), &
+         & igrdip1(imaxifp+1,imaxjfp+1,isurf), &
+         & igrdjp1(imaxifp+1,imaxjfp+1,isurf) &
+         & )
+
+      DO jobs = surfdataqc%nsurfup + 1, surfdataqc%nsurfup + isurf
+         iobs = jobs - surfdataqc%nsurfup
+         DO ji = 0, imaxifp
+            imodi = surfdataqc%mi(jobs) - int(imaxifp/2) + ji - 1
+            !
+            !Deal with wrap around in longitude
+            IF ( imodi < 1      ) imodi = imodi + jpiglo
+            IF ( imodi > jpiglo ) imodi = imodi - jpiglo
+            !
+            DO jj = 0, imaxjfp
+               imodj = surfdataqc%mj(jobs) - int(imaxjfp/2) + jj - 1
+               !If model values are out of the domain to the north/south then
+               !set them to be the edge of the domain
+               IF ( imodj < 1      ) imodj = 1
+               IF ( imodj > jpjglo ) imodj = jpjglo
+               !
+               igrdip1(ji+1,jj+1,iobs) = imodi
+               igrdjp1(ji+1,jj+1,iobs) = imodj
+               !
+               IF ( ji >= 1 .AND. jj >= 1 ) THEN
+                  igrdi(ji,jj,iobs) = imodi
+                  igrdj(ji,jj,iobs) = imodj
+               ENDIF
+               !
+            END DO
+         END DO
+      END DO
+
+      CALL obs_int_comm_2d( imaxifp, imaxjfp, isurf, kpi, kpj, &
+         &                  igrdi, igrdj, glamt, zglam )
+      CALL obs_int_comm_2d( imaxifp, imaxjfp, isurf, kpi, kpj, &
+         &                  igrdi, igrdj, gphit, zgphi )
+      CALL obs_int_comm_2d( imaxifp, imaxjfp, isurf, kpi, kpj, &
+         &                  igrdi, igrdj, psurfmask, zmask )
+      CALL obs_int_comm_2d( imaxifp, imaxjfp, isurf, kpi, kpj, &
+         &                  igrdi, igrdj, psurf, zsurf )
+      CALL obs_int_comm_2d( imaxifp+1, imaxjfp+1, isurf, kpi, kpj, &
+         &                  igrdip1, igrdjp1, glamf, zglamf )
+      CALL obs_int_comm_2d( imaxifp+1, imaxjfp+1, isurf, kpi, kpj, &
+         &                  igrdip1, igrdjp1, gphif, zgphif )
+
+      ! At the end of the day get interpolated means
+      IF ( idayend == 0 .AND. ldnightav ) THEN
+
+         ALLOCATE( &
+            & zsurfm(imaxifp,imaxjfp,isurf)  &
+            & )
+
+         CALL obs_int_comm_2d( imaxifp,imaxjfp, isurf, kpi, kpj, igrdi, igrdj, &
+            &               surfdataqc%vdmean(:,:), zsurfm )
+
+      ENDIF
+
+      ! Loop over observations
+      DO jobs = surfdataqc%nsurfup + 1, surfdataqc%nsurfup + isurf
+
+         iobs = jobs - surfdataqc%nsurfup
+
+         IF ( kt /= surfdataqc%mstp(jobs) ) THEN
+
+            IF(lwp) THEN
+               WRITE(numout,*)
+               WRITE(numout,*) ' E R R O R : Observation',              &
+                  &            ' time step is not consistent with the', &
+                  &            ' model time step'
+               WRITE(numout,*) ' ========='
+               WRITE(numout,*)
+               WRITE(numout,*) ' Record  = ', jobs,                &
+                  &            ' kt      = ', kt,                  &
+                  &            ' mstp    = ', surfdataqc%mstp(jobs), &
+                  &            ' ntyp    = ', surfdataqc%ntyp(jobs)
+            ENDIF
+            CALL ctl_stop( 'obs_surf_opt', 'Inconsistent time' )
+
+         ENDIF
+
+         zlam = surfdataqc%rlam(jobs)
+         zphi = surfdataqc%rphi(jobs)
+
+         IF ( ldnightav .AND. idayend == 0 ) THEN
+            ! Night-time averaged data
+            zsurftmp(:,:,iobs) = zsurfm(:,:,iobs)
+         ELSE
+            zsurftmp(:,:,iobs) = zsurf(:,:,iobs)
+         ENDIF
+
+         IF ( k2dint <= 4 ) THEN
+
+            ! Get weights to interpolate the model value to the observation point
+            CALL obs_int_h2d_init( 1, 1, k2dint, zlam, zphi,         &
+               &                   zglam(:,:,iobs), zgphi(:,:,iobs), &
+               &                   zmask(:,:,iobs), zweig, zobsmask )
+
+            ! Interpolate the model value to the observation point 
+            CALL obs_int_h2d( 1, 1, zweig, zsurftmp(:,:,iobs), zext )
+
+         ELSE
+
+            ! Get weights to average the model SLA to the observation footprint
+            CALL obs_avg_h2d_init( 1, 1, imaxifp, imaxjfp, k2dint, zlam,  zphi, &
+               &                   zglam(:,:,iobs), zgphi(:,:,iobs), &
+               &                   zglamf(:,:,iobs), zgphif(:,:,iobs), &
+               &                   zmask(:,:,iobs), plamscl, pphiscl, &
+               &                   lindegrees, zweig, zobsmask )
+
+            ! Average the model SST to the observation footprint
+            CALL obs_avg_h2d( 1, 1, imaxifp, imaxjfp, &
+               &              zweig, zsurftmp(:,:,iobs),  zext )
+
+         ENDIF
+
+         IF ( TRIM(surfdataqc%cvars(1)) == 'SLA' .AND. surfdataqc%nextra == 2 ) THEN
+            ! ... Remove the MDT from the SSH at the observation point to get the SLA
+            surfdataqc%rext(jobs,1) = zext(1)
+            surfdataqc%rmod(jobs,1) = surfdataqc%rext(jobs,1) - surfdataqc%rext(jobs,2)
+         ELSE
+            surfdataqc%rmod(jobs,1) = zext(1)
+         ENDIF
+         
+         IF ( zext(1) == obfillflt ) THEN
+            ! If the observation value is a fill value, set QC flag to bad
+            surfdataqc%nqc(jobs) = 4
+         ENDIF
+
+      END DO
+
+      ! Deallocate the data for interpolation
+      DEALLOCATE( &
+         & zweig, &
+         & igrdi, &
+         & igrdj, &
+         & zglam, &
+         & zgphi, &
+         & zmask, &
+         & zsurf, &
+         & zsurftmp, &
+         & zglamf, &
+         & zgphif, &
+         & igrdip1,&
+         & igrdjp1 &
+         & )
+
+      ! At the end of the day also deallocate night-time mean array
+      IF ( idayend == 0 .AND. ldnightav ) THEN
+         DEALLOCATE( &
+            & zsurfm  &
+            & )
+      ENDIF
+      !
+      surfdataqc%nsurfup = surfdataqc%nsurfup + isurf
+      !
+   END SUBROUTINE obs_surf_opt
+
+   !!======================================================================
+END MODULE obs_oper
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/obs_prep.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/obs_prep.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/obs_prep.F90	(revision 9570)
@@ -0,0 +1,1451 @@
+MODULE obs_prep
+   !!=====================================================================
+   !!                       ***  MODULE  obs_prep  ***
+   !! Observation diagnostics: Prepare observation arrays: screening, 
+   !!                          sorting, coordinate search
+   !!=====================================================================
+
+   !!---------------------------------------------------------------------
+   !!   obs_pre_prof  : First level check and screening of profile observations
+   !!   obs_pre_surf  : First level check and screening of surface observations
+   !!   obs_scr       : Basic screening of the observations
+   !!   obs_coo_tim   : Compute number of time steps to the observation time
+   !!   obs_sor       : Sort the observation arrays
+   !!---------------------------------------------------------------------
+   USE par_kind, ONLY : wp ! Precision variables
+   USE in_out_manager     ! I/O manager
+   USE obs_profiles_def   ! Definitions for storage arrays for profiles
+   USE obs_surf_def       ! Definitions for storage arrays for surface data
+   USE obs_mpp, ONLY : &  ! MPP support routines for observation diagnostics
+      & obs_mpp_sum_integer, &
+      & obs_mpp_sum_integers
+   USE obs_inter_sup      ! Interpolation support
+   USE obs_oper           ! Observation operators
+   USE lib_mpp, ONLY :   ctl_warn, ctl_stop
+   USE bdy_oce, ONLY : &        ! Boundary information
+      idx_bdy, nb_bdy, ln_bdy
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   obs_pre_prof     ! First level check and screening of profile obs
+   PUBLIC   obs_pre_surf     ! First level check and screening of surface obs
+   PUBLIC   calc_month_len   ! Calculate the number of days in the months of a year
+
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO Consortium (2010)
+   !! $Id$
+   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+
+
+CONTAINS
+
+   SUBROUTINE obs_pre_surf( surfdata, surfdataqc, ld_nea, ld_bound_reject, &
+                            kqc_cutoff )
+      !!----------------------------------------------------------------------
+      !!                    ***  ROUTINE obs_pre_sla  ***
+      !!
+      !! ** Purpose : First level check and screening of surface observations
+      !!
+      !! ** Method  : First level check and screening of surface observations
+      !!
+      !! ** Action  : 
+      !!
+      !! References :
+      !!   
+      !! History :
+      !!        !  2007-03  (A. Weaver, K. Mogensen) Original
+      !!        !  2007-06  (K. Mogensen et al) Reject obs. near land.
+      !!        !  2015-02  (M. Martin) Combined routine for surface types.
+      !!----------------------------------------------------------------------
+      !! * Modules used
+      USE par_oce             ! Ocean parameters
+      USE dom_oce, ONLY       :   glamt, gphit, tmask, nproc   ! Geographical information
+      !! * Arguments
+      TYPE(obs_surf), INTENT(INOUT) :: surfdata    ! Full set of surface data
+      TYPE(obs_surf), INTENT(INOUT) :: surfdataqc   ! Subset of surface data not failing screening
+      LOGICAL, INTENT(IN) :: ld_nea         ! Switch for rejecting observation near land
+      LOGICAL, INTENT(IN) :: ld_bound_reject       ! Switch for rejecting obs near the boundary
+      INTEGER, INTENT(IN), OPTIONAL :: kqc_cutoff   ! cut off for QC value
+      !! * Local declarations
+      INTEGER :: iqc_cutoff = 255   ! cut off for QC value
+      INTEGER :: iyea0        ! Initial date
+      INTEGER :: imon0        !  - (year, month, day, hour, minute)
+      INTEGER :: iday0    
+      INTEGER :: ihou0    
+      INTEGER :: imin0
+      INTEGER :: icycle       ! Current assimilation cycle
+                              ! Counters for observations that
+      INTEGER :: iotdobs      !  - outside time domain
+      INTEGER :: iosdsobs     !  - outside space domain
+      INTEGER :: ilansobs     !  - within a model land cell
+      INTEGER :: inlasobs     !  - close to land
+      INTEGER :: igrdobs      !  - fail the grid search
+      INTEGER :: ibdysobs     !  - close to open boundary
+                              ! Global counters for observations that
+      INTEGER :: iotdobsmpp     !  - outside time domain
+      INTEGER :: iosdsobsmpp    !  - outside space domain
+      INTEGER :: ilansobsmpp    !  - within a model land cell
+      INTEGER :: inlasobsmpp    !  - close to land
+      INTEGER :: igrdobsmpp     !  - fail the grid search
+      INTEGER :: ibdysobsmpp  !  - close to open boundary
+      LOGICAL, DIMENSION(:), ALLOCATABLE :: & 
+         & llvalid            ! SLA data selection
+      INTEGER :: jobs         ! Obs. loop variable
+      INTEGER :: jstp         ! Time loop variable
+      INTEGER :: inrc         ! Time index variable
+      !!----------------------------------------------------------------------
+
+      IF(lwp) WRITE(numout,*) 'obs_pre_surf : Preparing the surface observations...'
+      IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~'
+      
+      ! Initial date initialization (year, month, day, hour, minute)
+      iyea0 =   ndate0 / 10000
+      imon0 = ( ndate0 - iyea0 * 10000 ) / 100
+      iday0 =   ndate0 - iyea0 * 10000 - imon0 * 100
+      ihou0 = nn_time0 / 100
+      imin0 = ( nn_time0 - ihou0 * 100 )
+
+      icycle = nn_no     ! Assimilation cycle
+
+      ! Diagnotics counters for various failures.
+
+      iotdobs  = 0
+      igrdobs  = 0
+      iosdsobs = 0
+      ilansobs = 0
+      inlasobs = 0
+      ibdysobs = 0 
+
+      ! Set QC cutoff to optional value if provided
+      IF ( PRESENT(kqc_cutoff) ) iqc_cutoff=kqc_cutoff
+
+      ! -----------------------------------------------------------------------
+      ! Find time coordinate for surface data
+      ! -----------------------------------------------------------------------
+
+      CALL obs_coo_tim( icycle, &
+         &              iyea0,   imon0,   iday0,   ihou0,   imin0,      &
+         &              surfdata%nsurf,   surfdata%nyea, surfdata%nmon, &
+         &              surfdata%nday,    surfdata%nhou, surfdata%nmin, &
+         &              surfdata%nqc,     surfdata%mstp, iotdobs        )
+
+      CALL obs_mpp_sum_integer( iotdobs, iotdobsmpp )
+      
+      ! -----------------------------------------------------------------------
+      ! Check for surface data failing the grid search
+      ! -----------------------------------------------------------------------
+
+      CALL obs_coo_grd( surfdata%nsurf,   surfdata%mi, surfdata%mj, &
+         &              surfdata%nqc,     igrdobs                         )
+
+      CALL obs_mpp_sum_integer( igrdobs, igrdobsmpp )
+
+      ! -----------------------------------------------------------------------
+      ! Check for land points. 
+      ! -----------------------------------------------------------------------
+
+      CALL obs_coo_spc_2d( surfdata%nsurf,              &
+         &                 jpi,          jpj,          &
+         &                 surfdata%mi,   surfdata%mj,   & 
+         &                 surfdata%rlam, surfdata%rphi, &
+         &                 glamt,        gphit,        &
+         &                 tmask(:,:,1), surfdata%nqc,  &
+         &                 iosdsobs,     ilansobs,     &
+         &                 inlasobs,     ld_nea,       &
+         &                 ibdysobs,     ld_bound_reject, &
+         &                 iqc_cutoff                     )
+
+      CALL obs_mpp_sum_integer( iosdsobs, iosdsobsmpp )
+      CALL obs_mpp_sum_integer( ilansobs, ilansobsmpp )
+      CALL obs_mpp_sum_integer( inlasobs, inlasobsmpp )
+      CALL obs_mpp_sum_integer( ibdysobs, ibdysobsmpp )
+
+      ! -----------------------------------------------------------------------
+      ! Copy useful data from the surfdata data structure to
+      ! the surfdataqc data structure 
+      ! -----------------------------------------------------------------------
+
+      ! Allocate the selection arrays
+
+      ALLOCATE( llvalid(surfdata%nsurf) )
+      
+      ! We want all data which has qc flags <= iqc_cutoff
+
+      llvalid(:)  = ( surfdata%nqc(:)  <= iqc_cutoff )
+
+      ! The actual copying
+
+      CALL obs_surf_compress( surfdata,     surfdataqc,       .TRUE.,  numout, &
+         &                    lvalid=llvalid )
+
+      ! Dellocate the selection arrays
+      DEALLOCATE( llvalid )
+
+      ! -----------------------------------------------------------------------
+      ! Print information about what observations are left after qc
+      ! -----------------------------------------------------------------------
+
+      ! Update the total observation counter array
+      
+      IF(lwp) THEN
+         WRITE(numout,*)
+         WRITE(numout,*) ' '//surfdataqc%cvars(1)//' data outside time domain                  = ', &
+            &            iotdobsmpp
+         WRITE(numout,*) ' Remaining '//surfdataqc%cvars(1)//' data that failed grid search    = ', &
+            &            igrdobsmpp
+         WRITE(numout,*) ' Remaining '//surfdataqc%cvars(1)//' data outside space domain       = ', &
+            &            iosdsobsmpp
+         WRITE(numout,*) ' Remaining '//surfdataqc%cvars(1)//' data at land points             = ', &
+            &            ilansobsmpp
+         IF (ld_nea) THEN
+            WRITE(numout,*) ' Remaining '//surfdataqc%cvars(1)//' data near land points (removed) = ', &
+               &            inlasobsmpp
+         ELSE
+            WRITE(numout,*) ' Remaining '//surfdataqc%cvars(1)//' data near land points (kept)    = ', &
+               &            inlasobsmpp
+         ENDIF
+         WRITE(numout,*) ' Remaining '//surfdataqc%cvars(1)//' data near open boundary (removed) = ', &
+            &            ibdysobsmpp  
+         WRITE(numout,*) ' '//surfdataqc%cvars(1)//' data accepted                             = ', &
+            &            surfdataqc%nsurfmpp
+
+         WRITE(numout,*)
+         WRITE(numout,*) ' Number of observations per time step :'
+         WRITE(numout,*)
+         WRITE(numout,'(10X,A,10X,A)')'Time step',surfdataqc%cvars(1)
+         WRITE(numout,'(10X,A,5X,A)')'---------','-----------------'
+         CALL FLUSH(numout)
+      ENDIF
+      
+      DO jobs = 1, surfdataqc%nsurf
+         inrc = surfdataqc%mstp(jobs) + 2 - nit000
+         surfdataqc%nsstp(inrc)  = surfdataqc%nsstp(inrc) + 1
+      END DO
+      
+      CALL obs_mpp_sum_integers( surfdataqc%nsstp, surfdataqc%nsstpmpp, &
+         &                       nitend - nit000 + 2 )
+
+      IF ( lwp ) THEN
+         DO jstp = nit000 - 1, nitend
+            inrc = jstp - nit000 + 2
+            WRITE(numout,1999) jstp, surfdataqc%nsstpmpp(inrc)
+            CALL FLUSH(numout)
+         END DO
+      ENDIF
+
+1999  FORMAT(10X,I9,5X,I17)
+
+   END SUBROUTINE obs_pre_surf
+
+
+   SUBROUTINE obs_pre_prof( profdata, prodatqc, ld_var1, ld_var2, &
+      &                     kpi, kpj, kpk, &
+      &                     zmask1, pglam1, pgphi1, zmask2, pglam2, pgphi2,  &
+      &                     ld_nea, ld_bound_reject, kdailyavtypes,  kqc_cutoff )
+
+!!----------------------------------------------------------------------
+      !!                    ***  ROUTINE obs_pre_prof  ***
+      !!
+      !! ** Purpose : First level check and screening of profiles
+      !!
+      !! ** Method  : First level check and screening of profiles
+      !!
+      !! History :
+      !!        !  2007-06  (K. Mogensen) original : T and S profile data
+      !!        !  2008-09  (M. Valdivieso) : TAO velocity data
+      !!        !  2009-01  (K. Mogensen) : New feedback stricture
+      !!        !  2015-02  (M. Martin) : Combined profile routine.
+      !!
+      !!----------------------------------------------------------------------
+      !! * Modules used
+      USE par_oce             ! Ocean parameters
+      USE dom_oce, ONLY : &   ! Geographical information
+         & gdept_1d,             &
+         & nproc
+
+      !! * Arguments
+      TYPE(obs_prof), INTENT(INOUT) :: profdata   ! Full set of profile data
+      TYPE(obs_prof), INTENT(INOUT) :: prodatqc   ! Subset of profile data not failing screening
+      LOGICAL, INTENT(IN) :: ld_var1              ! Observed variables switches
+      LOGICAL, INTENT(IN) :: ld_var2
+      LOGICAL, INTENT(IN) :: ld_nea               ! Switch for rejecting observation near land
+      LOGICAL, INTENT(IN) :: ld_bound_reject      ! Switch for rejecting observations near the boundary
+      INTEGER, INTENT(IN) :: kpi, kpj, kpk        ! Local domain sizes
+      INTEGER, DIMENSION(imaxavtypes), OPTIONAL :: &
+         & kdailyavtypes                          ! Types for daily averages
+      REAL(wp), INTENT(IN), DIMENSION(kpi,kpj,kpk) :: &
+         & zmask1, &
+         & zmask2
+      REAL(wp), INTENT(IN), DIMENSION(kpi,kpj) :: &
+         & pglam1, &
+         & pglam2, &
+         & pgphi1, &
+         & pgphi2
+      INTEGER, INTENT(IN), OPTIONAL :: kqc_cutoff   ! cut off for QC value
+
+      !! * Local declarations
+      INTEGER :: iqc_cutoff = 255   ! cut off for QC value
+      INTEGER :: iyea0        ! Initial date
+      INTEGER :: imon0        !  - (year, month, day, hour, minute)
+      INTEGER :: iday0    
+      INTEGER :: ihou0    
+      INTEGER :: imin0
+      INTEGER :: icycle       ! Current assimilation cycle
+                              ! Counters for observations that are
+      INTEGER :: iotdobs      !  - outside time domain
+      INTEGER :: iosdv1obs    !  - outside space domain (variable 1)
+      INTEGER :: iosdv2obs    !  - outside space domain (variable 2)
+      INTEGER :: ilanv1obs    !  - within a model land cell (variable 1)
+      INTEGER :: ilanv2obs    !  - within a model land cell (variable 2)
+      INTEGER :: inlav1obs    !  - close to land (variable 1)
+      INTEGER :: inlav2obs    !  - close to land (variable 2)
+      INTEGER :: ibdyv1obs    !  - boundary (variable 1) 
+      INTEGER :: ibdyv2obs    !  - boundary (variable 2)      
+      INTEGER :: igrdobs      !  - fail the grid search
+      INTEGER :: iuvchku      !  - reject u if v rejected and vice versa
+      INTEGER :: iuvchkv      !
+                              ! Global counters for observations that are
+      INTEGER :: iotdobsmpp   !  - outside time domain
+      INTEGER :: iosdv1obsmpp !  - outside space domain (variable 1)
+      INTEGER :: iosdv2obsmpp !  - outside space domain (variable 2)
+      INTEGER :: ilanv1obsmpp !  - within a model land cell (variable 1)
+      INTEGER :: ilanv2obsmpp !  - within a model land cell (variable 2)
+      INTEGER :: inlav1obsmpp !  - close to land (variable 1)
+      INTEGER :: inlav2obsmpp !  - close to land (variable 2)
+      INTEGER :: ibdyv1obsmpp !  - boundary (variable 1) 
+      INTEGER :: ibdyv2obsmpp !  - boundary (variable 2)      
+      INTEGER :: igrdobsmpp   !  - fail the grid search
+      INTEGER :: iuvchkumpp   !  - reject var1 if var2 rejected and vice versa
+      INTEGER :: iuvchkvmpp   !
+      TYPE(obs_prof_valid) ::  llvalid      ! Profile selection 
+      TYPE(obs_prof_valid), DIMENSION(profdata%nvar) :: &
+         & llvvalid           ! var1,var2 selection 
+      INTEGER :: jvar         ! Variable loop variable
+      INTEGER :: jobs         ! Obs. loop variable
+      INTEGER :: jstp         ! Time loop variable
+      INTEGER :: inrc         ! Time index variable
+      !!----------------------------------------------------------------------
+
+      IF(lwp) WRITE(numout,*)'obs_pre_prof: Preparing the profile data...'
+      IF(lwp) WRITE(numout,*) '~~~~~~~~~~~'
+
+      ! Initial date initialization (year, month, day, hour, minute)
+      iyea0 =   ndate0 / 10000
+      imon0 = ( ndate0 - iyea0 * 10000 ) / 100
+      iday0 =   ndate0 - iyea0 * 10000 - imon0 * 100
+      ihou0 = nn_time0 / 100
+      imin0 = ( nn_time0 - ihou0 * 100 )
+
+      icycle = nn_no     ! Assimilation cycle
+
+      ! Diagnotics counters for various failures.
+
+      iotdobs   = 0
+      igrdobs   = 0
+      iosdv1obs = 0
+      iosdv2obs = 0
+      ilanv1obs = 0
+      ilanv2obs = 0
+      inlav1obs = 0
+      inlav2obs = 0
+      ibdyv1obs = 0
+      ibdyv2obs = 0
+      iuvchku   = 0
+      iuvchkv   = 0
+
+
+      ! Set QC cutoff to optional value if provided
+      IF ( PRESENT(kqc_cutoff) ) iqc_cutoff=kqc_cutoff
+
+      ! -----------------------------------------------------------------------
+      ! Find time coordinate for profiles
+      ! -----------------------------------------------------------------------
+
+      IF ( PRESENT(kdailyavtypes) ) THEN
+         CALL obs_coo_tim_prof( icycle, &
+            &              iyea0,   imon0,   iday0,   ihou0,   imin0,      &
+            &              profdata%nprof,   profdata%nyea, profdata%nmon, &
+            &              profdata%nday,    profdata%nhou, profdata%nmin, &
+            &              profdata%ntyp,    profdata%nqc,  profdata%mstp, &
+            &              iotdobs, kdailyavtypes = kdailyavtypes,         &
+            &              kqc_cutoff = iqc_cutoff )
+      ELSE
+         CALL obs_coo_tim_prof( icycle, &
+            &              iyea0,   imon0,   iday0,   ihou0,   imin0,      &
+            &              profdata%nprof,   profdata%nyea, profdata%nmon, &
+            &              profdata%nday,    profdata%nhou, profdata%nmin, &
+            &              profdata%ntyp,    profdata%nqc,  profdata%mstp, &
+            &              iotdobs,          kqc_cutoff = iqc_cutoff )
+      ENDIF
+
+      CALL obs_mpp_sum_integer( iotdobs, iotdobsmpp )
+      
+      ! -----------------------------------------------------------------------
+      ! Check for profiles failing the grid search
+      ! -----------------------------------------------------------------------
+
+      CALL obs_coo_grd( profdata%nprof,   profdata%mi(:,1), profdata%mj(:,1), &
+         &              profdata%nqc,     igrdobs                         )
+      CALL obs_coo_grd( profdata%nprof,   profdata%mi(:,2), profdata%mj(:,2), &
+         &              profdata%nqc,     igrdobs                         )
+
+      CALL obs_mpp_sum_integer( igrdobs, igrdobsmpp )
+
+      ! -----------------------------------------------------------------------
+      ! Reject all observations for profiles with nqc > iqc_cutoff
+      ! -----------------------------------------------------------------------
+
+      CALL obs_pro_rej( profdata, kqc_cutoff = iqc_cutoff )
+
+      ! -----------------------------------------------------------------------
+      ! Check for land points. This includes points below the model
+      ! bathymetry so this is done for every point in the profile
+      ! -----------------------------------------------------------------------
+
+      ! Variable 1
+      CALL obs_coo_spc_3d( profdata%nprof,        profdata%nvprot(1),   &
+         &                 profdata%npvsta(:,1),  profdata%npvend(:,1), &
+         &                 jpi,                   jpj,                  &
+         &                 jpk,                                         &
+         &                 profdata%mi,           profdata%mj,          &
+         &                 profdata%var(1)%mvk,                         &
+         &                 profdata%rlam,         profdata%rphi,        &
+         &                 profdata%var(1)%vdep,                        &
+         &                 pglam1,                pgphi1,               &
+         &                 gdept_1d,              zmask1,               &
+         &                 profdata%nqc,          profdata%var(1)%nvqc, &
+         &                 iosdv1obs,             ilanv1obs,            &
+         &                 inlav1obs,             ld_nea,               &
+         &                 ibdyv1obs,             ld_bound_reject,      &
+         &                 iqc_cutoff       )
+
+      CALL obs_mpp_sum_integer( iosdv1obs, iosdv1obsmpp )
+      CALL obs_mpp_sum_integer( ilanv1obs, ilanv1obsmpp )
+      CALL obs_mpp_sum_integer( inlav1obs, inlav1obsmpp )
+      CALL obs_mpp_sum_integer( ibdyv1obs, ibdyv1obsmpp )
+
+      ! Variable 2
+      CALL obs_coo_spc_3d( profdata%nprof,        profdata%nvprot(2),   &
+         &                 profdata%npvsta(:,2),  profdata%npvend(:,2), &
+         &                 jpi,                   jpj,                  &
+         &                 jpk,                                         &
+         &                 profdata%mi,           profdata%mj,          & 
+         &                 profdata%var(2)%mvk,                         &
+         &                 profdata%rlam,         profdata%rphi,        &
+         &                 profdata%var(2)%vdep,                        &
+         &                 pglam2,                pgphi2,               &
+         &                 gdept_1d,              zmask2,               &
+         &                 profdata%nqc,          profdata%var(2)%nvqc, &
+         &                 iosdv2obs,             ilanv2obs,            &
+         &                 inlav2obs,             ld_nea,               &
+         &                 ibdyv2obs,             ld_bound_reject,      &
+         &                 iqc_cutoff       )
+
+      CALL obs_mpp_sum_integer( iosdv2obs, iosdv2obsmpp )
+      CALL obs_mpp_sum_integer( ilanv2obs, ilanv2obsmpp )
+      CALL obs_mpp_sum_integer( inlav2obs, inlav2obsmpp )
+      CALL obs_mpp_sum_integer( ibdyv2obs, ibdyv2obsmpp )
+
+      ! -----------------------------------------------------------------------
+      ! Reject u if v is rejected and vice versa
+      ! -----------------------------------------------------------------------
+
+      IF ( TRIM(profdata%cvars(1)) == 'UVEL' ) THEN
+         CALL obs_uv_rej( profdata, iuvchku, iuvchkv, iqc_cutoff )
+         CALL obs_mpp_sum_integer( iuvchku, iuvchkumpp )
+         CALL obs_mpp_sum_integer( iuvchkv, iuvchkvmpp )
+      ENDIF
+
+      ! -----------------------------------------------------------------------
+      ! Copy useful data from the profdata data structure to
+      ! the prodatqc data structure 
+      ! -----------------------------------------------------------------------
+
+      ! Allocate the selection arrays
+
+      ALLOCATE( llvalid%luse(profdata%nprof) )
+      DO jvar = 1,profdata%nvar
+         ALLOCATE( llvvalid(jvar)%luse(profdata%nvprot(jvar)) )
+      END DO
+
+      ! We want all data which has qc flags <= iqc_cutoff
+
+      llvalid%luse(:) = ( profdata%nqc(:)  <= iqc_cutoff )
+      DO jvar = 1,profdata%nvar
+         llvvalid(jvar)%luse(:) = ( profdata%var(jvar)%nvqc(:) <= iqc_cutoff )
+      END DO
+
+      ! The actual copying
+
+      CALL obs_prof_compress( profdata,     prodatqc,       .TRUE.,  numout, &
+         &                    lvalid=llvalid, lvvalid=llvvalid )
+
+      ! Dellocate the selection arrays
+      DEALLOCATE( llvalid%luse )
+      DO jvar = 1,profdata%nvar
+         DEALLOCATE( llvvalid(jvar)%luse )
+      END DO
+
+      ! -----------------------------------------------------------------------
+      ! Print information about what observations are left after qc
+      ! -----------------------------------------------------------------------
+
+      ! Update the total observation counter array
+      
+      IF(lwp) THEN
+      
+         WRITE(numout,*)
+         WRITE(numout,*) ' Profiles outside time domain                     = ', &
+            &            iotdobsmpp
+         WRITE(numout,*) ' Remaining profiles that failed grid search       = ', &
+            &            igrdobsmpp
+         WRITE(numout,*) ' Remaining '//prodatqc%cvars(1)//' data outside space domain       = ', &
+            &            iosdv1obsmpp
+         WRITE(numout,*) ' Remaining '//prodatqc%cvars(1)//' data at land points             = ', &
+            &            ilanv1obsmpp
+         IF (ld_nea) THEN
+            WRITE(numout,*) ' Remaining '//prodatqc%cvars(1)//' data near land points (removed) = ',&
+               &            inlav1obsmpp
+         ELSE
+            WRITE(numout,*) ' Remaining '//prodatqc%cvars(1)//' data near land points (kept)    = ',&
+               &            inlav1obsmpp
+         ENDIF
+         IF ( TRIM(profdata%cvars(1)) == 'UVEL' ) THEN
+            WRITE(numout,*) ' U observation rejected since V rejected     = ', &
+               &            iuvchku
+         ENDIF
+         WRITE(numout,*) ' Remaining '//prodatqc%cvars(1)//' data near open boundary (removed) = ',&
+               &            ibdyv1obsmpp
+         WRITE(numout,*) ' '//prodatqc%cvars(1)//' data accepted                             = ', &
+            &            prodatqc%nvprotmpp(1)
+         WRITE(numout,*) ' Remaining '//prodatqc%cvars(2)//' data outside space domain       = ', &
+            &            iosdv2obsmpp
+         WRITE(numout,*) ' Remaining '//prodatqc%cvars(2)//' data at land points             = ', &
+            &            ilanv2obsmpp
+         IF (ld_nea) THEN
+            WRITE(numout,*) ' Remaining '//prodatqc%cvars(2)//' data near land points (removed) = ',&
+               &            inlav2obsmpp
+         ELSE
+            WRITE(numout,*) ' Remaining '//prodatqc%cvars(2)//' data near land points (kept)    = ',&
+               &            inlav2obsmpp
+         ENDIF
+         IF ( TRIM(profdata%cvars(1)) == 'UVEL' ) THEN
+            WRITE(numout,*) ' V observation rejected since U rejected     = ', &
+               &            iuvchkv
+         ENDIF
+         WRITE(numout,*) ' Remaining '//prodatqc%cvars(2)//' data near open boundary (removed) = ',&
+               &            ibdyv2obsmpp
+         WRITE(numout,*) ' '//prodatqc%cvars(2)//' data accepted                             = ', &
+            &            prodatqc%nvprotmpp(2)
+
+         WRITE(numout,*)
+         WRITE(numout,*) ' Number of observations per time step :'
+         WRITE(numout,*)
+         WRITE(numout,'(10X,A,5X,A,5X,A,A)')'Time step','Profiles', &
+            &                               '     '//prodatqc%cvars(1)//'     ', &
+            &                               '     '//prodatqc%cvars(2)//'     '
+         WRITE(numout,998)
+      ENDIF
+      
+      DO jobs = 1, prodatqc%nprof
+         inrc = prodatqc%mstp(jobs) + 2 - nit000
+         prodatqc%npstp(inrc)  = prodatqc%npstp(inrc) + 1
+         DO jvar = 1, prodatqc%nvar
+            IF ( prodatqc%npvend(jobs,jvar) > 0 ) THEN
+               prodatqc%nvstp(inrc,jvar) = prodatqc%nvstp(inrc,jvar) + &
+                  &                      ( prodatqc%npvend(jobs,jvar) - &
+                  &                        prodatqc%npvsta(jobs,jvar) + 1 )
+            ENDIF
+         END DO
+      END DO
+      
+      
+      CALL obs_mpp_sum_integers( prodatqc%npstp, prodatqc%npstpmpp, &
+         &                       nitend - nit000 + 2 )
+      DO jvar = 1, prodatqc%nvar
+         CALL obs_mpp_sum_integers( prodatqc%nvstp(:,jvar), &
+            &                       prodatqc%nvstpmpp(:,jvar), &
+            &                       nitend - nit000 + 2 )
+      END DO
+
+      IF ( lwp ) THEN
+         DO jstp = nit000 - 1, nitend
+            inrc = jstp - nit000 + 2
+            WRITE(numout,999) jstp, prodatqc%npstpmpp(inrc), &
+               &                    prodatqc%nvstpmpp(inrc,1), &
+               &                    prodatqc%nvstpmpp(inrc,2)
+         END DO
+      ENDIF
+
+998   FORMAT(10X,'---------',5X,'--------',5X,'-----------',5X,'----------------')
+999   FORMAT(10X,I9,5X,I8,5X,I11,5X,I8)
+
+   END SUBROUTINE obs_pre_prof
+
+   SUBROUTINE obs_coo_tim( kcycle, &
+      &                    kyea0,   kmon0,   kday0,   khou0,   kmin0,     &
+      &                    kobsno,                                        &
+      &                    kobsyea, kobsmon, kobsday, kobshou, kobsmin,   &
+      &                    kobsqc,  kobsstp, kotdobs                      )
+      !!----------------------------------------------------------------------
+      !!                    ***  ROUTINE obs_coo_tim ***
+      !!
+      !! ** Purpose : Compute the number of time steps to the observation time.
+      !!
+      !! ** Method  : For time coordinates ( yea_obs, mon_obs, day_obs, 
+      !!              hou_obs, min_obs ), this routine locates the time step 
+      !!              that is closest to this time.
+      !!
+      !! ** Action  : 
+      !!
+      !! References :
+      !!   
+      !! History :
+      !!        !  1997-07  (A. Weaver) Original
+      !!        !  2006-08  (A. Weaver) NEMOVAR migration
+      !!        !  2006-10  (A. Weaver) Cleanup
+      !!        !  2007-01  (K. Mogensen) Rewritten with loop
+      !!        !  2010-05  (D. Lea) Fix in leap year calculation for NEMO vn3.2
+      !!----------------------------------------------------------------------
+      !! * Modules used
+      USE dom_oce, ONLY : &  ! Geographical information
+         & rdt
+      USE phycst, ONLY : &   ! Physical constants
+         & rday,  &             
+         & rmmss, &             
+         & rhhmm                        
+      !! * Arguments
+      INTEGER, INTENT(IN) :: kcycle     ! Current cycle
+      INTEGER, INTENT(IN) :: kyea0      ! Initial date coordinates
+      INTEGER, INTENT(IN) :: kmon0
+      INTEGER, INTENT(IN) :: kday0 
+      INTEGER, INTENT(IN) :: khou0
+      INTEGER, INTENT(IN) :: kmin0
+      INTEGER, INTENT(IN) :: kobsno     ! Number of observations
+      INTEGER, INTENT(INOUT) :: kotdobs   ! Number of observations failing time check
+      INTEGER, DIMENSION(kobsno), INTENT(IN ) :: &
+         & kobsyea,  &      ! Observation time coordinates
+         & kobsmon,  &
+         & kobsday,  & 
+         & kobshou,  &
+         & kobsmin
+      INTEGER, DIMENSION(kobsno), INTENT(INOUT) :: &
+         & kobsqc           ! Quality control flag
+      INTEGER, DIMENSION(kobsno), INTENT(OUT) :: &
+         & kobsstp          ! Number of time steps up to the 
+                            ! observation time
+
+      !! * Local declarations
+      INTEGER :: jyea
+      INTEGER :: jmon
+      INTEGER :: jday
+      INTEGER :: jobs
+      INTEGER :: iyeastr
+      INTEGER :: iyeaend
+      INTEGER :: imonstr
+      INTEGER :: imonend
+      INTEGER :: idaystr
+      INTEGER :: idayend 
+      INTEGER :: iskip
+      INTEGER :: idaystp
+      REAL(KIND=wp) :: zminstp
+      REAL(KIND=wp) :: zhoustp
+      REAL(KIND=wp) :: zobsstp 
+      INTEGER, DIMENSION(12) ::   imonth_len    !: length in days of the months of the current year
+ 
+      !-----------------------------------------------------------------------
+      ! Initialization
+      !-----------------------------------------------------------------------
+
+      ! Intialize the number of time steps per day
+      idaystp = NINT( rday / rdt )
+
+      !---------------------------------------------------------------------
+      ! Locate the model time coordinates for interpolation
+      !---------------------------------------------------------------------
+
+      DO jobs = 1, kobsno
+
+         ! Initialize the time step counter
+         kobsstp(jobs) = nit000 - 1
+
+         ! Flag if observation date is less than the initial date
+
+         IF ( ( kobsyea(jobs) < kyea0 )                   &
+            & .OR. ( ( kobsyea(jobs) == kyea0 )           &
+            &        .AND. ( kobsmon(jobs) <  kmon0 ) )   &
+            & .OR. ( ( kobsyea(jobs) == kyea0 )           &
+            &        .AND. ( kobsmon(jobs) == kmon0 )     &
+            &        .AND. ( kobsday(jobs) <  kday0 ) )   &
+            & .OR. ( ( kobsyea(jobs) == kyea0 )           &
+            &        .AND. ( kobsmon(jobs) == kmon0 )     &
+            &        .AND. ( kobsday(jobs) == kday0 )     &
+            &        .AND. ( kobshou(jobs) <  khou0 ) )   &
+            &  .OR. ( ( kobsyea(jobs) == kyea0 )          &
+            &        .AND. ( kobsmon(jobs) == kmon0 )     &
+            &        .AND. ( kobsday(jobs) == kday0 )          &
+            &        .AND. ( kobshou(jobs) == khou0 )          &
+            &        .AND. ( kobsmin(jobs) <= kmin0 ) ) ) THEN
+            kobsstp(jobs) = -1
+            kobsqc(jobs)  = IBSET(kobsqc(jobs),13)
+            kotdobs       = kotdobs + 1
+            CYCLE
+         ENDIF
+
+         ! Compute the number of time steps to the observation day
+         iyeastr = kyea0
+         iyeaend = kobsyea(jobs)
+         
+         !---------------------------------------------------------------------
+         ! Year loop
+         !---------------------------------------------------------------------
+         DO jyea = iyeastr, iyeaend
+
+            CALL calc_month_len( jyea, imonth_len )
+            
+            imonstr = 1
+            IF ( jyea == kyea0         ) imonstr = kmon0
+            imonend = 12
+            IF ( jyea == kobsyea(jobs) ) imonend = kobsmon(jobs)
+            
+            ! Month loop
+            DO jmon = imonstr, imonend
+               
+               idaystr = 1
+               IF (       ( jmon == kmon0   ) &
+                  & .AND. ( jyea == kyea0   ) ) idaystr = kday0
+               idayend = imonth_len(jmon)
+               IF (       ( jmon == kobsmon(jobs) ) &
+                  & .AND. ( jyea == kobsyea(jobs) ) ) idayend = kobsday(jobs) - 1
+               
+               ! Day loop
+               DO jday = idaystr, idayend
+                  kobsstp(jobs) = kobsstp(jobs) + idaystp
+               END DO
+               
+            END DO
+
+         END DO
+
+         ! Add in the number of time steps to the observation minute
+         zminstp = rmmss / rdt
+         zhoustp = rhhmm * zminstp
+
+         zobsstp =   REAL( kobsmin(jobs) - kmin0, KIND=wp ) * zminstp &
+            &      + REAL( kobshou(jobs) - khou0, KIND=wp ) * zhoustp
+         kobsstp(jobs) = kobsstp(jobs) + NINT( zobsstp )
+
+         ! Flag if observation step outside the time window
+         IF ( ( kobsstp(jobs) < ( nit000 - 1 ) ) &
+            & .OR.( kobsstp(jobs) > nitend ) ) THEN
+            kobsqc(jobs) = IBSET(kobsqc(jobs),13)
+            kotdobs = kotdobs + 1
+            CYCLE
+         ENDIF
+
+      END DO
+
+   END SUBROUTINE obs_coo_tim
+
+   SUBROUTINE calc_month_len( iyear, imonth_len )
+      !!----------------------------------------------------------------------
+      !!                    ***  ROUTINE calc_month_len  ***
+      !!          
+      !! ** Purpose : Compute the number of days in a months given a year.
+      !!
+      !! ** Method  : 
+      !!
+      !! ** Action  : 
+      !!
+      !! History :
+      !!        !  10-05  (D. Lea)   New routine based on day_init 
+      !!----------------------------------------------------------------------
+
+      INTEGER, DIMENSION(12) ::   imonth_len    !: length in days of the months of the current year
+      INTEGER :: iyear         !: year
+      
+      ! length of the month of the current year (from nleapy, read in namelist)
+      IF ( nleapy < 2 ) THEN 
+         imonth_len(:) = (/ 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31 /)
+         IF ( nleapy == 1 ) THEN   ! we are using calendar with leap years
+            IF ( MOD(iyear, 4) == 0 .AND. ( MOD(iyear, 400) == 0 .OR. MOD(iyear, 100) /= 0 ) ) THEN
+               imonth_len(2) = 29
+            ENDIF
+         ENDIF
+      ELSE
+         imonth_len(:) = nleapy   ! all months with nleapy days per year
+      ENDIF
+
+   END SUBROUTINE
+
+   SUBROUTINE obs_coo_tim_prof( kcycle,                                   &
+      &                    kyea0,   kmon0,   kday0,   khou0,   kmin0,     &
+      &                    kobsno,                                        &
+      &                    kobsyea, kobsmon, kobsday, kobshou, kobsmin,   &
+      &                    ktyp,    kobsqc,  kobsstp, kotdobs, kdailyavtypes, &
+      &                    kqc_cutoff )
+      !!----------------------------------------------------------------------
+      !!                    ***  ROUTINE obs_coo_tim ***
+      !!
+      !! ** Purpose : Compute the number of time steps to the observation time.
+      !!
+      !! ** Method  : For time coordinates ( yea_obs, mon_obs, day_obs, 
+      !!              hou_obs, min_obs ), this routine locates the time step 
+      !!              that is closest to this time.
+      !!
+      !! ** Action  : 
+      !!
+      !! References :
+      !!   
+      !! History :
+      !!        !  1997-07  (A. Weaver) Original
+      !!        !  2006-08  (A. Weaver) NEMOVAR migration
+      !!        !  2006-10  (A. Weaver) Cleanup
+      !!        !  2007-01  (K. Mogensen) Rewritten with loop
+      !!----------------------------------------------------------------------
+      !! * Modules used
+      !! * Arguments
+      INTEGER, INTENT(IN) :: kcycle      ! Current cycle
+      INTEGER, INTENT(IN) :: kyea0       ! Initial date coordinates
+      INTEGER, INTENT(IN) :: kmon0
+      INTEGER, INTENT(IN) :: kday0
+      INTEGER, INTENT(IN) :: khou0
+      INTEGER, INTENT(IN) :: kmin0
+      INTEGER, INTENT(IN) :: kobsno      ! Number of observations
+      INTEGER, INTENT(INOUT) ::  kotdobs    ! Number of observations failing time check
+      INTEGER, DIMENSION(kobsno), INTENT(IN ) :: &
+         & kobsyea,  &      ! Observation time coordinates
+         & kobsmon,  &
+         & kobsday,  & 
+         & kobshou,  &
+         & kobsmin,  &
+         & ktyp             ! Observation type.
+      INTEGER, DIMENSION(kobsno), INTENT(INOUT) :: &
+         & kobsqc           ! Quality control flag
+      INTEGER, DIMENSION(kobsno), INTENT(OUT) :: &
+         & kobsstp          ! Number of time steps up to the 
+                            ! observation time
+      INTEGER, DIMENSION(imaxavtypes), OPTIONAL :: &
+         & kdailyavtypes    ! Types for daily averages
+      INTEGER, OPTIONAL, INTENT(IN) :: kqc_cutoff           ! QC cutoff value
+
+      !! * Local declarations
+      INTEGER :: jobs
+      INTEGER :: iqc_cutoff=255
+
+      !-----------------------------------------------------------------------
+      ! Call standard obs_coo_tim
+      !-----------------------------------------------------------------------
+
+      CALL obs_coo_tim( kcycle, &
+         &              kyea0,   kmon0,   kday0,   khou0,   kmin0,     &
+         &              kobsno,                                        &
+         &              kobsyea, kobsmon, kobsday, kobshou, kobsmin,   &
+         &              kobsqc,  kobsstp, kotdobs                      )
+
+      !------------------------------------------------------------------------
+      ! Always reject daily averaged data (e.g. MRB data (820)) at initial time
+      !------------------------------------------------------------------------
+
+      IF ( PRESENT(kdailyavtypes) ) THEN
+         DO jobs = 1, kobsno
+            
+            IF ( kobsqc(jobs) <= iqc_cutoff ) THEN
+               
+               IF ( ( kobsstp(jobs) == (nit000 - 1) ).AND.&
+                  & ( ANY (kdailyavtypes(:) == ktyp(jobs)) ) ) THEN
+                  kobsqc(jobs) = IBSET(kobsqc(jobs),13)
+                  kotdobs      = kotdobs + 1
+                  CYCLE
+               ENDIF
+               
+            ENDIF
+         END DO
+      ENDIF
+
+
+   END SUBROUTINE obs_coo_tim_prof
+
+   SUBROUTINE obs_coo_grd( kobsno, kobsi, kobsj, kobsqc, kgrdobs )
+      !!----------------------------------------------------------------------
+      !!                    ***  ROUTINE obs_coo_grd ***
+      !!
+      !! ** Purpose : Verify that the grid search has not failed
+      !!
+      !! ** Method  : The previously computed i,j indeces are checked  
+      !!
+      !! ** Action  : 
+      !!
+      !! References :
+      !!   
+      !! History :
+      !!        !  2007-01  (K. Mogensen)  Original
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT(IN) :: kobsno        ! Number of observations
+      INTEGER, DIMENSION(kobsno), INTENT(IN ) :: &
+         & kobsi, &         ! i,j indeces previously computed
+         & kobsj
+      INTEGER, INTENT(INOUT) ::  kgrdobs   ! Number of observations failing the check
+      INTEGER, DIMENSION(kobsno), INTENT(INOUT) :: &
+         & kobsqc           ! Quality control flag
+
+      !! * Local declarations
+      INTEGER :: jobs       ! Loop variable
+
+      ! Flag if the grid search failed
+
+      DO jobs = 1, kobsno
+         IF ( ( kobsi(jobs) <= 0 ) .AND. ( kobsj(jobs) <= 0 ) ) THEN
+            kobsqc(jobs) = IBSET(kobsqc(jobs),12)
+            kgrdobs = kgrdobs + 1
+         ENDIF
+      END DO
+      
+   END SUBROUTINE obs_coo_grd
+
+   SUBROUTINE obs_coo_spc_2d( kobsno, kpi,     kpj,              &
+      &                       kobsi,  kobsj,   pobslam, pobsphi, & 
+      &                       plam,   pphi,    pmask,            &
+      &                       kobsqc, kosdobs, klanobs,          &
+      &                       knlaobs,ld_nea,                    &
+      &                       kbdyobs,ld_bound_reject,           &
+      &                       kqc_cutoff                         )
+      !!----------------------------------------------------------------------
+      !!                    ***  ROUTINE obs_coo_spc_2d  ***
+      !!
+      !! ** Purpose : Check for points outside the domain and land points
+      !!
+      !! ** Method  : Remove the observations that are outside the model space
+      !!              and time domain or located within model land cells.
+      !!
+      !! ** Action  : 
+      !!   
+      !! History :  2007-03  (A. Weaver, K. Mogensen)  Original
+      !!         !  2007-06  (K. Mogensen et al) Reject obs. near land.
+      !!----------------------------------------------------------------------
+      INTEGER , INTENT(in   )                     ::   kobsno            ! Total number of observations
+      INTEGER , INTENT(in   )                     ::   kpi    , kpj      ! Number of grid points in (i,j)
+      INTEGER , INTENT(in   ), DIMENSION(kobsno)  ::   kobsi  , kobsj    ! Observation (i,j) coordinates
+      REAL(wp), INTENT(in   ), DIMENSION(kobsno)  ::   pobslam, pobsphi  ! Observation (lon,lat) coordinates
+      REAL(wp), INTENT(in   ), DIMENSION(kpi,kpj) ::   plam   , pphi     ! Model (lon,lat) coordinates
+      REAL(wp), INTENT(in   ), DIMENSION(kpi,kpj) ::   pmask             ! Land mask array
+      INTEGER , INTENT(inout), DIMENSION(kobsno)  ::   kobsqc            ! Observation quality control
+      INTEGER , INTENT(inout)                     ::   kosdobs           ! Observations outside space domain
+      INTEGER , INTENT(inout)                     ::   klanobs           ! Observations within a model land cell
+      INTEGER , INTENT(inout)                     ::   knlaobs           ! Observations near land
+      INTEGER , INTENT(inout)                     ::   kbdyobs           ! Observations near boundary
+      LOGICAL , INTENT(in   )                     ::   ld_nea            ! Flag observations near land
+      LOGICAL , INTENT(in   )                     ::   ld_bound_reject   ! Flag observations near open boundary 
+      INTEGER , INTENT(in   )                     ::   kqc_cutoff        ! Cutoff QC value
+      !
+      REAL(KIND=wp), DIMENSION(2,2,kobsno) ::   zgmsk          ! Grid mask
+      REAL(KIND=wp), DIMENSION(2,2,kobsno) ::   zbmsk          ! Boundary mask
+      REAL(KIND=wp), DIMENSION(jpi,jpj)    ::   zbdymask
+      REAL(KIND=wp), DIMENSION(2,2,kobsno) ::   zglam, zgphi   ! Model Lon/lat at grid points
+      INTEGER      , DIMENSION(2,2,kobsno) ::   igrdi, igrdj   ! Grid i,j
+      LOGICAL ::   lgridobs           ! Is observation on a model grid point.
+      INTEGER ::   iig, ijg           ! i,j of observation on model grid point.
+      INTEGER ::   jobs, ji, jj
+      !!----------------------------------------------------------------------
+      
+      ! Get grid point indices
+
+      DO jobs = 1, kobsno
+         
+         ! For invalid points use 2,2
+
+         IF ( kobsqc(jobs) >= kqc_cutoff ) THEN
+
+            igrdi(1,1,jobs) = 1
+            igrdj(1,1,jobs) = 1
+            igrdi(1,2,jobs) = 1
+            igrdj(1,2,jobs) = 2
+            igrdi(2,1,jobs) = 2
+            igrdj(2,1,jobs) = 1
+            igrdi(2,2,jobs) = 2
+            igrdj(2,2,jobs) = 2
+
+         ELSE
+
+            igrdi(1,1,jobs) = kobsi(jobs)-1
+            igrdj(1,1,jobs) = kobsj(jobs)-1
+            igrdi(1,2,jobs) = kobsi(jobs)-1
+            igrdj(1,2,jobs) = kobsj(jobs)
+            igrdi(2,1,jobs) = kobsi(jobs)
+            igrdj(2,1,jobs) = kobsj(jobs)-1
+            igrdi(2,2,jobs) = kobsi(jobs)
+            igrdj(2,2,jobs) = kobsj(jobs)
+
+         ENDIF
+
+      END DO
+
+      IF (ln_bdy) THEN
+        ! Create a mask grid points in boundary rim
+        IF (ld_bound_reject) THEN
+           zbdymask(:,:) = 1.0_wp
+           DO ji = 1, nb_bdy
+              DO jj = 1, idx_bdy(ji)%nblen(1)
+                 zbdymask(idx_bdy(ji)%nbi(jj,1),idx_bdy(ji)%nbj(jj,1)) = 0.0_wp
+              ENDDO
+           ENDDO
+
+           CALL obs_int_comm_2d( 2, 2, kobsno, kpi, kpj, igrdi, igrdj, zbdymask, zbmsk )
+        ENDIF
+      ENDIF
+
+      
+      CALL obs_int_comm_2d( 2, 2, kobsno, kpi, kpj, igrdi, igrdj, pmask, zgmsk )
+      CALL obs_int_comm_2d( 2, 2, kobsno, kpi, kpj, igrdi, igrdj, plam, zglam )
+      CALL obs_int_comm_2d( 2, 2, kobsno, kpi, kpj, igrdi, igrdj, pphi, zgphi )
+
+      DO jobs = 1, kobsno
+
+         ! Skip bad observations
+         IF ( kobsqc(jobs) >= kqc_cutoff ) CYCLE
+
+         ! Flag if the observation falls outside the model spatial domain
+         IF (       ( pobslam(jobs) < -180. ) &
+            &  .OR. ( pobslam(jobs) >  180. ) &
+            &  .OR. ( pobsphi(jobs) <  -90. ) &
+            &  .OR. ( pobsphi(jobs) >   90. ) ) THEN
+            kobsqc(jobs) = IBSET(kobsqc(jobs),11)
+            kosdobs = kosdobs + 1
+            CYCLE
+         ENDIF
+
+         ! Flag if the observation falls with a model land cell
+         IF ( SUM( zgmsk(1:2,1:2,jobs) ) == 0.0_wp ) THEN
+            kobsqc(jobs) = IBSET(kobsqc(jobs),10)
+            klanobs = klanobs + 1
+            CYCLE
+         ENDIF
+
+         ! Check if this observation is on a grid point
+
+         lgridobs = .FALSE.
+         iig = -1
+         ijg = -1
+         DO jj = 1, 2
+            DO ji = 1, 2
+               IF ( ( ABS( zgphi(ji,jj,jobs) - pobsphi(jobs) ) < 1.0e-6_wp ) &
+                  & .AND. &
+                  & ( ABS( MOD( zglam(ji,jj,jobs) - pobslam(jobs),360.0) )  &
+                  & < 1.0e-6_wp ) ) THEN
+                  lgridobs = .TRUE.
+                  iig = ji
+                  ijg = jj
+               ENDIF
+            END DO
+         END DO
+  
+         ! For observations on the grid reject them if their are at
+         ! a masked point
+         
+         IF (lgridobs) THEN
+            IF (zgmsk(iig,ijg,jobs) == 0.0_wp ) THEN
+               kobsqc(jobs) = IBSET(kobsqc(jobs),10)
+               klanobs = klanobs + 1
+               CYCLE
+            ENDIF
+         ENDIF
+                      
+         ! Flag if the observation falls is close to land
+         IF ( MINVAL( zgmsk(1:2,1:2,jobs) ) == 0.0_wp) THEN
+            knlaobs = knlaobs + 1
+            IF (ld_nea) THEN
+               kobsqc(jobs) = IBSET(kobsqc(jobs),9)
+               CYCLE
+            ENDIF
+         ENDIF
+
+         IF (ln_bdy) THEN
+         ! Flag if the observation falls close to the boundary rim
+           IF (ld_bound_reject) THEN
+              IF ( MINVAL( zbmsk(1:2,1:2,jobs) ) == 0.0_wp ) THEN
+                 kobsqc(jobs) = IBSET(kobsqc(jobs),8)
+                 kbdyobs = kbdyobs + 1
+                 CYCLE
+              ENDIF
+              ! for observations on the grid...
+              IF (lgridobs) THEN
+                 IF (zbmsk(iig,ijg,jobs) == 0.0_wp ) THEN
+                    kobsqc(jobs) = IBSET(kobsqc(jobs),8)
+                    kbdyobs = kbdyobs + 1
+                    CYCLE
+                 ENDIF
+              ENDIF
+            ENDIF
+         ENDIF
+         !
+      END DO
+      !
+   END SUBROUTINE obs_coo_spc_2d
+
+
+   SUBROUTINE obs_coo_spc_3d( kprofno, kobsno,  kpstart, kpend, &
+      &                       kpi,     kpj,     kpk,            &
+      &                       kobsi,   kobsj,   kobsk,          &
+      &                       pobslam, pobsphi, pobsdep,        &
+      &                       plam,    pphi,    pdep,    pmask, &
+      &                       kpobsqc, kobsqc,  kosdobs,        &
+      &                       klanobs, knlaobs, ld_nea,         &
+      &                       kbdyobs, ld_bound_reject,         &
+      &                       kqc_cutoff                        )
+      !!----------------------------------------------------------------------
+      !!                    ***  ROUTINE obs_coo_spc_3d  ***
+      !!
+      !! ** Purpose : Check for points outside the domain and land points
+      !!              Reset depth of observation above highest model level
+      !!              to the value of highest model level
+      !!
+      !! ** Method  : Remove the observations that are outside the model space
+      !!              and time domain or located within model land cells.
+      !!
+      !!              NB. T and S profile observations lying between the ocean
+      !!              surface and the depth of the first model T point are 
+      !!              assigned a depth equal to that of the first model T pt.
+      !!
+      !! ** Action  : 
+      !!   
+      !! History :
+      !!        !  2007-01  (K. Mogensen) Rewrite of parts of obs_scr
+      !!        !  2007-06  (K. Mogensen et al) Reject obs. near land.
+      !!----------------------------------------------------------------------
+      !! * Modules used
+      USE dom_oce, ONLY : &       ! Geographical information
+         & gdepw_1d,      &
+         & gdepw_0,       &                       
+         & gdepw_n,       &
+         & gdept_n,       &
+         & ln_zco,        &
+         & ln_zps             
+
+      !! * Arguments
+      INTEGER, INTENT(IN) :: kprofno      ! Number of profiles
+      INTEGER, INTENT(IN) :: kobsno       ! Total number of observations
+      INTEGER, INTENT(IN) :: kpi          ! Number of grid points in (i,j,k)
+      INTEGER, INTENT(IN) :: kpj
+      INTEGER, INTENT(IN) :: kpk    
+      INTEGER, DIMENSION(kprofno), INTENT(IN) :: &
+         & kpstart, &         ! Start of individual profiles
+         & kpend              ! End of individual profiles
+      INTEGER, DIMENSION(kprofno), INTENT(IN) :: &
+         & kobsi, &           ! Observation (i,j) coordinates
+         & kobsj
+      INTEGER, DIMENSION(kobsno), INTENT(IN) :: &
+         & kobsk              ! Observation k coordinate
+      REAL(KIND=wp), DIMENSION(kprofno), INTENT(IN) :: &
+         & pobslam, &         ! Observation (lon,lat) coordinates
+         & pobsphi
+      REAL(KIND=wp), DIMENSION(kobsno), INTENT(INOUT) :: &
+         & pobsdep            ! Observation depths  
+      REAL(KIND=wp), DIMENSION(kpi,kpj), INTENT(IN) :: &
+         & plam, pphi         ! Model (lon,lat) coordinates
+      REAL(KIND=wp), DIMENSION(kpk), INTENT(IN) :: &
+         & pdep               ! Model depth coordinates
+      REAL(KIND=wp), DIMENSION(kpi,kpj,kpk), INTENT(IN) :: &
+         & pmask              ! Land mask array
+      INTEGER, DIMENSION(kprofno), INTENT(INOUT) :: &
+         & kpobsqc             ! Profile quality control
+      INTEGER, DIMENSION(kobsno), INTENT(INOUT) :: &
+         & kobsqc             ! Observation quality control
+      INTEGER, INTENT(INOUT) :: kosdobs     ! Observations outside space domain
+      INTEGER, INTENT(INOUT) :: klanobs     ! Observations within a model land cell
+      INTEGER, INTENT(INOUT) :: knlaobs     ! Observations near land
+      INTEGER, INTENT(INOUT) :: kbdyobs     ! Observations near boundary
+      LOGICAL, INTENT(IN) :: ld_nea         ! Flag observations near land
+      LOGICAL, INTENT(IN) :: ld_bound_reject  ! Flag observations near open boundary
+      INTEGER, INTENT(IN) :: kqc_cutoff     ! Cutoff QC value
+
+      !! * Local declarations
+      REAL(KIND=wp), DIMENSION(2,2,kpk,kprofno) :: &
+         & zgmsk              ! Grid mask
+      REAL(KIND=wp), DIMENSION(2,2,kprofno) :: &
+         & zbmsk              ! Boundary mask
+      REAL(KIND=wp), DIMENSION(jpi,jpj) :: zbdymask
+      REAL(KIND=wp), DIMENSION(2,2,kpk,kprofno) :: &
+         & zgdepw
+      REAL(KIND=wp), DIMENSION(2,2,kprofno) :: &
+         & zglam, &           ! Model longitude at grid points
+         & zgphi              ! Model latitude at grid points
+      INTEGER, DIMENSION(2,2,kprofno) :: &
+         & igrdi, &           ! Grid i,j
+         & igrdj
+      LOGICAL :: lgridobs           ! Is observation on a model grid point.
+      LOGICAL :: ll_next_to_land    ! Is a profile next to land 
+      INTEGER :: iig, ijg           ! i,j of observation on model grid point.
+      INTEGER :: jobs, jobsp, jk, ji, jj
+      !!----------------------------------------------------------------------
+
+      ! Get grid point indices
+      
+      DO jobs = 1, kprofno
+
+         ! For invalid points use 2,2
+
+         IF ( kpobsqc(jobs) >= kqc_cutoff ) THEN
+            
+            igrdi(1,1,jobs) = 1
+            igrdj(1,1,jobs) = 1
+            igrdi(1,2,jobs) = 1
+            igrdj(1,2,jobs) = 2
+            igrdi(2,1,jobs) = 2
+            igrdj(2,1,jobs) = 1
+            igrdi(2,2,jobs) = 2
+            igrdj(2,2,jobs) = 2
+            
+         ELSE
+            
+            igrdi(1,1,jobs) = kobsi(jobs)-1
+            igrdj(1,1,jobs) = kobsj(jobs)-1
+            igrdi(1,2,jobs) = kobsi(jobs)-1
+            igrdj(1,2,jobs) = kobsj(jobs)
+            igrdi(2,1,jobs) = kobsi(jobs)
+            igrdj(2,1,jobs) = kobsj(jobs)-1
+            igrdi(2,2,jobs) = kobsi(jobs)
+            igrdj(2,2,jobs) = kobsj(jobs)
+            
+         ENDIF
+         
+      END DO
+
+      IF (ln_bdy) THEN
+        ! Create a mask grid points in boundary rim
+        IF (ld_bound_reject) THEN           
+           zbdymask(:,:) = 1.0_wp
+           DO ji = 1, nb_bdy
+              DO jj = 1, idx_bdy(ji)%nblen(1)
+                 zbdymask(idx_bdy(ji)%nbi(jj,1),idx_bdy(ji)%nbj(jj,1)) = 0.0_wp
+              ENDDO
+           ENDDO
+        ENDIF
+   
+        CALL obs_int_comm_2d( 2, 2, kprofno, kpi, kpj, igrdi, igrdj, zbdymask, zbmsk )
+      ENDIF
+      
+      CALL obs_int_comm_3d( 2, 2, kprofno, kpi, kpj, kpk, igrdi, igrdj, pmask, zgmsk )
+      CALL obs_int_comm_2d( 2, 2, kprofno, kpi, kpj, igrdi, igrdj, plam, zglam )
+      CALL obs_int_comm_2d( 2, 2, kprofno, kpi, kpj, igrdi, igrdj, pphi, zgphi )
+      CALL obs_int_comm_3d( 2, 2, kprofno, kpi, kpj, kpk, igrdi, igrdj, gdepw_n(:,:,:), &
+        &                     zgdepw )
+
+      DO jobs = 1, kprofno
+
+         ! Skip bad profiles
+         IF ( kpobsqc(jobs) >= kqc_cutoff ) CYCLE
+
+         ! Check if this observation is on a grid point
+
+         lgridobs = .FALSE.
+         iig = -1
+         ijg = -1
+         DO jj = 1, 2
+            DO ji = 1, 2
+               IF ( ( ABS( zgphi(ji,jj,jobs) - pobsphi(jobs) ) < 1.0e-6_wp ) &
+                  & .AND. &
+                  & ( ABS( MOD( zglam(ji,jj,jobs) - pobslam(jobs),360.0) ) < 1.0e-6_wp ) &
+                  & ) THEN
+                  lgridobs = .TRUE.
+                  iig = ji
+                  ijg = jj
+               ENDIF
+            END DO
+         END DO
+
+         ! Check if next to land
+         IF (  ANY( zgmsk(1:2,1:2,1,jobs) == 0.0_wp ) ) THEN
+            ll_next_to_land=.TRUE.
+         ELSE
+            ll_next_to_land=.FALSE.
+         ENDIF 
+
+         ! Reject observations
+
+         DO jobsp = kpstart(jobs), kpend(jobs)
+
+            ! Flag if the observation falls outside the model spatial domain
+            IF (       ( pobslam(jobs) < -180.         )       &
+               &  .OR. ( pobslam(jobs) >  180.         )       &
+               &  .OR. ( pobsphi(jobs) <  -90.         )       &
+               &  .OR. ( pobsphi(jobs) >   90.         )       &
+               &  .OR. ( pobsdep(jobsp) < 0.0          )       &
+               &  .OR. ( pobsdep(jobsp) > gdepw_1d(kpk)) ) THEN
+               kobsqc(jobsp) = IBSET(kobsqc(jobsp),11)
+               kosdobs = kosdobs + 1
+               CYCLE
+            ENDIF
+
+            ! To check if an observations falls within land:
+             
+            ! Flag if the observation is deeper than the bathymetry
+            ! Or if it is within the mask
+            IF ( ALL( zgdepw(1:2,1:2,kpk,jobs) < pobsdep(jobsp) ) &
+               &     .OR. &
+               &  ( SUM( zgmsk(1:2,1:2,kobsk(jobsp)-1:kobsk(jobsp),jobs) ) &
+               &  == 0.0_wp) ) THEN
+               kobsqc(jobsp) = IBSET(kobsqc(jobsp),10)
+               klanobs = klanobs + 1
+               CYCLE
+            ENDIF
+               
+            ! Flag if the observation is close to land
+            IF ( ll_next_to_land ) THEN
+               knlaobs = knlaobs + 1
+               IF (ld_nea) THEN   
+                  kobsqc(jobsp) = IBSET(kobsqc(jobsp),10)
+               ENDIF 
+            ENDIF
+            
+            ! For observations on the grid reject them if their are at
+            ! a masked point
+            
+            IF (lgridobs) THEN
+               IF (zgmsk(iig,ijg,kobsk(jobsp)-1,jobs) == 0.0_wp ) THEN
+                  kobsqc(jobsp) = IBSET(kobsqc(jobs),10)
+                  klanobs = klanobs + 1
+                  CYCLE
+               ENDIF
+            ENDIF
+            
+            ! Flag if the observation falls is close to land
+            IF ( MINVAL( zgmsk(1:2,1:2,kobsk(jobsp)-1:kobsk(jobsp),jobs) ) == &
+               &  0.0_wp) THEN
+               IF (ld_nea) kobsqc(jobsp) = kobsqc(jobsp) + 14
+               knlaobs = knlaobs + 1
+            ENDIF
+
+            ! Set observation depth equal to that of the first model depth
+            IF ( pobsdep(jobsp) <= pdep(1) ) THEN
+               pobsdep(jobsp) = pdep(1)  
+            ENDIF
+            
+            IF (ln_bdy) THEN
+               ! Flag if the observation falls close to the boundary rim
+               IF (ld_bound_reject) THEN
+                  IF ( MINVAL( zbmsk(1:2,1:2,jobs) ) == 0.0_wp ) THEN
+                     kobsqc(jobsp) = IBSET(kobsqc(jobs),8)
+                     kbdyobs = kbdyobs + 1
+                     CYCLE
+                  ENDIF
+                  ! for observations on the grid...
+                  IF (lgridobs) THEN
+                     IF (zbmsk(iig,ijg,jobs) == 0.0_wp ) THEN
+                        kobsqc(jobsp) = IBSET(kobsqc(jobs),8)
+                        kbdyobs = kbdyobs + 1
+                        CYCLE
+                     ENDIF
+                  ENDIF
+               ENDIF
+            ENDIF
+            !
+         END DO
+      END DO
+      !
+   END SUBROUTINE obs_coo_spc_3d
+
+
+   SUBROUTINE obs_pro_rej( profdata, kqc_cutoff )
+      !!----------------------------------------------------------------------
+      !!                    ***  ROUTINE obs_pro_rej ***
+      !!
+      !! ** Purpose : Reject all data within a rejected profile
+      !!
+      !! ** Method  : 
+      !!
+      !! ** Action  : 
+      !!
+      !! References :
+      !!   
+      !! History :   2007-10  (K. Mogensen) Original code
+      !!----------------------------------------------------------------------
+      TYPE(obs_prof), INTENT(inout) ::   profdata     ! Profile data
+      INTEGER       , INTENT(in   ) ::   kqc_cutoff   ! QC cutoff value
+      !
+      INTEGER :: jprof
+      INTEGER :: jvar
+      INTEGER :: jobs
+      !!----------------------------------------------------------------------
+      
+      ! Loop over profiles
+
+      DO jprof = 1, profdata%nprof
+
+         IF ( profdata%nqc(jprof) > kqc_cutoff ) THEN
+            
+            DO jvar = 1, profdata%nvar
+
+               DO jobs = profdata%npvsta(jprof,jvar),  &
+                  &      profdata%npvend(jprof,jvar)
+                  
+                  profdata%var(jvar)%nvqc(jobs) = &
+                     & IBSET(profdata%var(jvar)%nvqc(jobs),14)
+
+               END DO
+
+            END DO
+
+         ENDIF
+
+      END DO
+      !
+   END SUBROUTINE obs_pro_rej
+
+
+   SUBROUTINE obs_uv_rej( profdata, knumu, knumv, kqc_cutoff )
+      !!----------------------------------------------------------------------
+      !!                    ***  ROUTINE obs_uv_rej ***
+      !!
+      !! ** Purpose : Reject u if v is rejected and vice versa
+      !!
+      !! ** Method  : 
+      !!
+      !! ** Action  : 
+      !!
+      !! References :
+      !!   
+      !! History :   2009-2  (K. Mogensen) Original code
+      !!----------------------------------------------------------------------
+      TYPE(obs_prof), INTENT(INOUT) :: profdata   ! Profile data
+      INTEGER, INTENT(INOUT) :: knumu             ! Number of u rejected
+      INTEGER, INTENT(INOUT) :: knumv             ! Number of v rejected
+      INTEGER, INTENT(IN) :: kqc_cutoff           ! QC cutoff value
+      !
+      INTEGER :: jprof
+      INTEGER :: jvar
+      INTEGER :: jobs
+      !!----------------------------------------------------------------------
+
+      DO jprof = 1, profdata%nprof      !==  Loop over profiles  ==!
+         !
+         IF ( ( profdata%npvsta(jprof,1) /= profdata%npvsta(jprof,2) ) .OR. &
+            & ( profdata%npvend(jprof,1) /= profdata%npvend(jprof,2) ) ) THEN
+            !
+            CALL ctl_stop('U,V profiles inconsistent in obs_uv_rej')
+            RETURN
+            !
+         ENDIF
+         !
+         DO jobs = profdata%npvsta(jprof,1), profdata%npvend(jprof,1)
+            !  
+            IF ( ( profdata%var(1)%nvqc(jobs) >  kqc_cutoff ) .AND. &
+               & ( profdata%var(2)%nvqc(jobs) <=  kqc_cutoff) ) THEN
+               profdata%var(2)%nvqc(jobs) = IBSET(profdata%var(1)%nvqc(jobs),15)
+               knumv = knumv + 1
+            ENDIF
+            IF ( ( profdata%var(2)%nvqc(jobs) >  kqc_cutoff ) .AND. &
+               & ( profdata%var(1)%nvqc(jobs) <=  kqc_cutoff) ) THEN
+               profdata%var(1)%nvqc(jobs) = IBSET(profdata%var(1)%nvqc(jobs),15)
+               knumu = knumu + 1
+            ENDIF
+            !
+         END DO
+         !
+      END DO
+      !
+   END SUBROUTINE obs_uv_rej
+
+   !!=====================================================================
+END MODULE obs_prep
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/obs_profiles.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/obs_profiles.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/obs_profiles.F90	(revision 9570)
@@ -0,0 +1,39 @@
+MODULE obs_profiles
+   !!=====================================================================
+   !!                       ***  MODULE  obs_profiles  ***
+   !! Observation diagnostics: Storage space for profile observations
+   !!                          arrays and additional flags etc.
+   !!=====================================================================
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO Consortium (2010)
+   !! $Id$
+   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+
+   
+   !! * Modules used 
+   USE obs_profiles_def ! Definition of profile data types and tools
+
+   IMPLICIT NONE
+   
+   SAVE
+
+   !! * Routine accessibility
+   PRIVATE
+
+   PUBLIC nprofsets, nprofvars, nprofextr, profdata, prodatqc
+   PUBLIC nvelosets, nvelovars, nveloextr, velodata, veldatqc
+   
+   !! * Shared Module variables
+   INTEGER :: nprofsets                    ! Total number of profile data sets
+   INTEGER :: nprofvars                    ! Total number of variables for profiles
+   INTEGER :: nprofextr                    ! Extra fields for each variable
+   TYPE(obs_prof), POINTER ::  profdata(:) ! Initial profile data
+   TYPE(obs_prof), POINTER ::  prodatqc(:) ! Profile data after quality control
+
+   INTEGER :: nvelosets                     ! Total number of velocity profile data sets
+   INTEGER :: nvelovars                     ! Total number of variables for profiles
+   INTEGER :: nveloextr                     ! Extra fields for each variable
+   TYPE(obs_prof), POINTER ::  velodata(:)  ! Initial velocity profile data
+   TYPE(obs_prof), POINTER ::  veldatqc(:)  ! Velocity profile data after quality control
+END MODULE obs_profiles
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/obs_profiles_def.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/obs_profiles_def.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/obs_profiles_def.F90	(revision 9570)
@@ -0,0 +1,928 @@
+MODULE obs_profiles_def
+   !!=====================================================================
+   !!                       ***  MODULE  obs_profiles_def  ***
+   !! Observation diagnostics: Storage handling for T,S profiles
+   !!                          arrays and additional flags etc.
+   !!                          This module only defines the data type and
+   !!                          operations on the data type. There is no
+   !!                          actual data in the module.
+   !!===================================================================== 
+
+   !!----------------------------------------------------------------------
+   !!   obs_prof            : F90 type containing the profile information
+   !!   obs_prof_var        : F90 type containing the variable definition
+   !!   obs_prof_valid       : F90 type containing the valid obs. definition
+   !!   obs_prof_alloc      : Allocates profile arrays
+   !!   obs_prof_dealloc    : Deallocates profile arrays
+   !!   obs_prof_compress   : Extract sub-information from a obs_prof type
+   !!                         to a new obs_prof type
+   !!   obs_prof_decompress : Reinsert sub-information from a obs_prof type
+   !!                         into the original obs_prof type
+   !!   obs_prof_staend     : Set npvsta and npvend of a variable within an 
+   !!                         obs_prof_var type
+   !!----------------------------------------------------------------------
+   !! * Modules used
+   USE par_kind, ONLY : & ! Precision variables
+      & wp         
+   USE in_out_manager     ! I/O manager
+   USE obs_mpp, ONLY : &  ! MPP tools 
+      obs_mpp_sum_integers
+   USE obs_fbm            ! Obs feedback format
+   USE lib_mpp, ONLY : &
+      & ctl_warn, ctl_stop
+
+   IMPLICIT NONE
+
+   !! * Routine/type accessibility
+   PRIVATE
+
+   PUBLIC &
+      & obs_prof,           &
+      & obs_prof_var,       &
+      & obs_prof_valid,     &
+      & obs_prof_alloc,     &
+      & obs_prof_alloc_var, &
+      & obs_prof_dealloc,   &
+      & obs_prof_compress,  &
+      & obs_prof_decompress,&
+      & obs_prof_staend
+
+   !! * Type definition for valid observations
+
+   TYPE obs_prof_valid
+      
+      LOGICAL, POINTER, DIMENSION(:) :: luse
+
+   END TYPE obs_prof_valid
+
+   !! * Type definition for each variable
+
+   TYPE obs_prof_var
+
+      ! Arrays with size equal to the number of observations
+
+      INTEGER, POINTER, DIMENSION(:) :: &
+         & mvk,   &       !: k-th grid coord. for interpolating to profile data
+         & nvpidx,&       !: Profile number
+         & nvlidx,&       !: Level number in profile
+         & nvqc,  &       !: Variable QC flags
+         & idqc           !: Depth QC flag
+
+      REAL(KIND=wp), POINTER, DIMENSION(:) :: &
+         & vdep,  &       !: Depth coordinate of profile data
+         & vobs,  &       !: Profile data
+         & vmod           !: Model counterpart of the profile data vector
+
+      REAL(KIND=wp), POINTER, DIMENSION(:,:) :: &
+         & vext           !: Extra variables
+
+      INTEGER, POINTER, DIMENSION(:) :: &
+         & nvind          !: Source indices of temp. data in compressed data
+
+      ! Arrays with size equal to idefnqcf times the number of observations
+      INTEGER, POINTER, DIMENSION(:,:) :: &
+         & idqcf,  &      !: Depth QC flags
+         & nvqcf          !: Variable QC flags
+
+   END TYPE obs_prof_var
+
+   !! * Type definition for profile observation type
+
+   TYPE obs_prof
+
+      ! Bookkeeping
+
+      INTEGER :: nvar     !: Number of variables
+      INTEGER :: next     !: Number of extra fields
+      INTEGER :: nprof    !: Total number of profiles within window.
+      INTEGER :: nstp     !: Number of time steps
+      INTEGER :: npi      !: Number of 3D grid points
+      INTEGER :: npj
+      INTEGER :: npk
+      INTEGER :: nprofup  !: Observation counter used in obs_oper
+
+      ! Bookkeeping arrays with sizes equal to number of variables
+
+      CHARACTER(len=8), POINTER, DIMENSION(:) :: &
+         & cvars          !: Variable names
+
+      INTEGER, POINTER, DIMENSION(:) :: &
+         & nvprot,   &    !: Local total number of profile T data
+         & nvprotmpp      !: Global total number of profile T data
+      
+      ! Arrays with size equal to the number of profiles
+
+      INTEGER, POINTER, DIMENSION(:) :: &
+         & npidx,&        !: Profile number
+         & npfil,&        !: Profile number in file
+         & nyea, &        !: Year of profile
+         & nmon, &        !: Month of profile
+         & nday, &        !: Day of profile
+         & nhou, &        !: Hour of profile
+         & nmin, &        !: Minute of profile
+         & mstp, &        !: Time step nearest to profile
+         & nqc,  &        !: Profile QC
+         & ntyp, &        !: Type of profile product (WMO table 1770)
+         & ipqc, &        !: Position QC
+         & itqc           !: Time QC
+
+      REAL(KIND=wp), POINTER, DIMENSION(:) :: &
+         & rlam, &        !: Longitude coordinate of profile data
+         & rphi           !: Latitude coordinate of profile data
+
+      CHARACTER(LEN=8), POINTER, DIMENSION(:) :: &
+         & cwmo           !: Profile WMO indentifier
+      
+      ! Arrays with size equal to the number of profiles times
+      ! number of variables
+
+      INTEGER, POINTER, DIMENSION(:,:) :: &
+         & npvsta, &      !: Start of each variable profile in full arrays
+         & npvend, &      !: End of each variable profile in full arrays
+         & mi,     &      !: i-th grid coord. for interpolating to profile T data
+         & mj,     &      !: j-th grid coord. for interpolating to profile T data
+         & ivqc           !: QC flags for all levels for a variable
+
+      ! Arrays with size equal to idefnqcf
+      ! the number of profiles times number of variables
+      INTEGER, POINTER, DIMENSION(:,:) :: &
+         & nqcf,  &       !: Observation QC flags
+         & ipqcf, &       !: Position QC flags
+         & itqcf          !: Time QC flags
+
+      ! Arrays with size equal to idefnqcf
+      ! the number of profiles times number of variables
+      INTEGER, POINTER, DIMENSION(:,:,:) :: &
+         & ivqcf
+
+      ! Arrays of variables
+
+      TYPE(obs_prof_var), POINTER, DIMENSION(:) :: var
+
+      ! Arrays with size equal to the number of time steps in the window
+
+      INTEGER, POINTER, DIMENSION(:) :: &
+         & npstp,    &    !: Total number of profiles
+         & npstpmpp       !: Total number of profiles
+
+      ! Arrays with size equal to the number of time steps in the window times
+      ! number of variables
+
+      INTEGER, POINTER, DIMENSION(:,:) :: &
+         & nvstp,    &    !: Local total num. of profile data each time step 
+         & nvstpmpp       !: Global total num. of profile data each time step
+      
+      ! Arrays with size equal to the number of grid points times number of
+      ! variables
+
+      REAL(KIND=wp), POINTER, DIMENSION(:,:,:,:) :: &
+         & vdmean        !: Daily averaged model field
+
+      ! Arrays used to store source indices when 
+      ! compressing obs_prof derived types
+      
+      ! Array with size nprof
+
+      INTEGER, POINTER, DIMENSION(:) :: &
+         & npind         !: Source indices of profile data in compressed data
+
+   END TYPE obs_prof
+
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO Consortium (2010)
+   !! $Id$
+   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+
+CONTAINS
+   
+   SUBROUTINE obs_prof_alloc( prof,  kvar, kext, kprof,  &
+      &                       ko3dt, kstp, kpi, kpj, kpk )
+      !!----------------------------------------------------------------------
+      !!                     ***  ROUTINE obs_prof_alloc  ***
+      !!                      
+      !! ** Purpose : - Allocate data for profile arrays
+      !! 
+      !! ** Method  : - Fortran-90 dynamic arrays
+      !!
+      !! History :
+      !!        !  07-01  (K. Mogensen) Original code
+      !!        !  07-03  (K. Mogensen) Generalized profiles
+      !!----------------------------------------------------------------------
+      !! * Arguments
+      TYPE(obs_prof), INTENT(INOUT) :: prof      ! Profile data to be allocated
+      INTEGER, INTENT(IN) :: kprof  ! Number of profiles
+      INTEGER, INTENT(IN) :: kvar   ! Number of variables
+      INTEGER, INTENT(IN) :: kext   ! Number of extra fields within each variable
+      INTEGER, INTENT(IN), DIMENSION(kvar) :: &
+         & ko3dt     ! Number of observations per variables
+      INTEGER, INTENT(IN) :: kstp   ! Number of time steps
+      INTEGER, INTENT(IN) :: kpi    ! Number of 3D grid points
+      INTEGER, INTENT(IN) :: kpj
+      INTEGER, INTENT(IN) :: kpk
+
+      !!* Local variables
+      INTEGER :: jvar
+      INTEGER :: ji
+
+      ! Set bookkeeping variables
+
+      prof%nvar      = kvar
+      prof%next      = kext
+      prof%nprof     = kprof
+
+      prof%nstp      = kstp
+      prof%npi       = kpi
+      prof%npj       = kpj
+      prof%npk       = kpk
+
+      ! Allocate arrays of size number of variables
+
+      ALLOCATE( &
+         & prof%cvars(kvar),    &
+         & prof%nvprot(kvar),   &
+         & prof%nvprotmpp(kvar) &
+         )
+         
+      DO jvar = 1, kvar
+         prof%cvars    (jvar) = "NotSet"
+         prof%nvprot   (jvar) = ko3dt(jvar)
+         prof%nvprotmpp(jvar) = 0
+      END DO
+
+      ! Allocate arrays of size number of profiles
+      ! times number of variables
+      
+      ALLOCATE( &
+         & prof%npvsta(kprof,kvar), &  
+         & prof%npvend(kprof,kvar), &
+         & prof%mi(kprof,kvar),     &
+         & prof%mj(kprof,kvar),     &
+         & prof%ivqc(kprof,kvar)    &
+         )
+
+      ! Allocate arrays of size iqcfdef times number of profiles
+      ! times number of variables
+
+      ALLOCATE( &
+         & prof%ivqcf(idefnqcf,kprof,kvar) &
+         & )
+
+      ! Allocate arrays of size number of profiles
+
+      ALLOCATE( &
+         & prof%npidx(kprof),   &
+         & prof%npfil(kprof),   &
+         & prof%nyea(kprof),    &
+         & prof%nmon(kprof),    &
+         & prof%nday(kprof),    &
+         & prof%nhou(kprof),    &
+         & prof%nmin(kprof),    &
+         & prof%mstp(kprof),    &
+         & prof%nqc(kprof),     &
+         & prof%ipqc(kprof),    &
+         & prof%itqc(kprof),    &
+         & prof%ntyp(kprof),    &
+         & prof%rlam(kprof),    &
+         & prof%rphi(kprof),    &
+         & prof%cwmo(kprof),    &
+         & prof%npind(kprof)    &
+         & )
+
+      ! Allocate arrays of size idefnqcf times number of profiles
+
+      ALLOCATE( &
+         & prof%nqcf(idefnqcf,kprof),  &
+         & prof%ipqcf(idefnqcf,kprof), &
+         & prof%itqcf(idefnqcf,kprof)  &
+         & )
+
+      ! Allocate obs_prof_var type
+      ALLOCATE( &
+         & prof%var(kvar) &
+         & )
+
+      ! For each variables allocate arrays of size number of observations
+
+      DO jvar = 1, kvar
+
+         IF ( ko3dt(jvar) >= 0 ) THEN
+            CALL obs_prof_alloc_var( prof, jvar, kext, ko3dt(jvar) )
+         ENDIF
+         
+      END DO
+
+      ! Allocate arrays of size number of time step size
+
+      ALLOCATE( &
+         & prof%npstp(kstp),   &
+         & prof%npstpmpp(kstp) &
+         & )
+
+      ! Allocate arrays of size number of time step size times 
+      ! number of variables
+      
+      ALLOCATE( &
+         & prof%nvstp(kstp,kvar),   &
+         & prof%nvstpmpp(kstp,kvar) &
+         & )
+
+      ! Allocate arrays of size number of grid points size times
+      ! number of variables
+
+      ALLOCATE( &
+         & prof%vdmean(kpi,kpj,kpk,kvar) &
+         & )
+
+      ! Set defaults for compression indices
+      
+      DO ji = 1, kprof
+         prof%npind(ji) = ji
+      END DO
+
+      DO jvar = 1, kvar
+         DO ji = 1, ko3dt(jvar)
+            prof%var(jvar)%nvind(ji) = ji
+         END DO
+      END DO
+
+      ! Set defaults for number of observations per time step
+
+      prof%npstp(:)      = 0
+      prof%npstpmpp(:)   = 0
+      prof%nvstp(:,:)    = 0
+      prof%nvstpmpp(:,:) = 0
+      
+      ! Set the observation counter used in obs_oper
+
+      prof%nprofup     = 0
+
+   END SUBROUTINE obs_prof_alloc
+
+   SUBROUTINE obs_prof_dealloc( prof )
+      !!----------------------------------------------------------------------
+      !!                     ***  ROUTINE obs_prof_dealloc  ***
+      !!                      
+      !! ** Purpose : - Deallocate data for profile arrays
+      !! 
+      !! ** Method  : - Fortran-90 dynamic arrays
+      !!
+      !! History :
+      !!        !  07-01  (K. Mogensen) Original code
+      !!----------------------------------------------------------------------
+      !! * Arguments
+      TYPE(obs_prof), INTENT(INOUT) :: &
+         & prof      ! Profile data to be deallocated
+
+      !!* Local variables
+      INTEGER :: &
+         & jvar
+
+      ! Deallocate arrays of size number of profiles
+      ! times number of variables
+      
+      DEALLOCATE( &
+         & prof%npvsta, &  
+         & prof%npvend  &
+         )
+
+      ! Dellocate arrays of size number of profiles size
+
+      DEALLOCATE( &
+         & prof%mi,      &
+         & prof%mj,      &
+         & prof%ivqc,    &
+         & prof%ivqcf,   &
+         & prof%npidx,   &
+         & prof%npfil,   &
+         & prof%nyea,    &
+         & prof%nmon,    &
+         & prof%nday,    &
+         & prof%nhou,    &
+         & prof%nmin,    &
+         & prof%mstp,    &
+         & prof%nqc,     &
+         & prof%ipqc,    &
+         & prof%itqc,    &
+         & prof%nqcf,    &
+         & prof%ipqcf,   &
+         & prof%itqcf,   &
+         & prof%ntyp,    &
+         & prof%rlam,    &
+         & prof%rphi,    &
+         & prof%cwmo,    &
+         & prof%npind    &
+         & )
+
+      ! For each variables allocate arrays of size number of observations
+
+      DO jvar = 1, prof%nvar
+
+         IF ( prof%nvprot(jvar) >= 0 ) THEN
+
+            CALL obs_prof_dealloc_var( prof, jvar )
+
+         ENDIF
+         
+      END DO
+
+      ! Dellocate obs_prof_var type
+      DEALLOCATE( &
+         & prof%var &
+         & )
+
+      ! Deallocate arrays of size number of time step size
+
+      DEALLOCATE( &
+         & prof%npstp,   &
+         & prof%npstpmpp &
+         & )
+
+      ! Deallocate arrays of size number of time step size times 
+      ! number of variables
+      
+      DEALLOCATE( &
+         & prof%nvstp,   &
+         & prof%nvstpmpp &
+         & )
+
+      ! Deallocate arrays of size number of grid points size times
+      ! number of variables
+
+      DEALLOCATE( &
+         & prof%vdmean &
+         & )
+
+      ! Dellocate arrays of size number of variables
+
+      DEALLOCATE( &
+         & prof%cvars,    &
+         & prof%nvprot,   &
+         & prof%nvprotmpp &
+         )
+
+
+   END SUBROUTINE obs_prof_dealloc
+
+
+   SUBROUTINE obs_prof_alloc_var( prof, kvar, kext, kobs )
+
+      !!----------------------------------------------------------------------
+      !!                     ***  ROUTINE obs_prof_alloc_var  ***
+      !!                      
+      !! ** Purpose : - Allocate data for variable data in profile arrays
+      !! 
+      !! ** Method  : - Fortran-90 dynamic arrays
+      !!
+      !! History :
+      !!        !  07-03  (K. Mogensen) Original code
+      !! * Arguments
+      TYPE(obs_prof), INTENT(INOUT) :: prof   ! Profile data to be allocated
+      INTEGER, INTENT(IN) :: kvar   ! Variable number
+      INTEGER, INTENT(IN) :: kext   ! Number of extra fields within each variable
+      INTEGER, INTENT(IN) :: kobs   ! Number of observations
+      
+      ALLOCATE( & 
+         & prof%var(kvar)%mvk(kobs),       &
+         & prof%var(kvar)%nvpidx(kobs),    &
+         & prof%var(kvar)%nvlidx(kobs),    &
+         & prof%var(kvar)%nvqc(kobs),      &
+         & prof%var(kvar)%idqc(kobs),      &
+         & prof%var(kvar)%vdep(kobs),      &
+         & prof%var(kvar)%vobs(kobs),      &
+         & prof%var(kvar)%vmod(kobs),      &
+         & prof%var(kvar)%nvind(kobs)      &
+         & )
+      ALLOCATE( & 
+         & prof%var(kvar)%idqcf(idefnqcf,kobs), &
+         & prof%var(kvar)%nvqcf(idefnqcf,kobs)  &
+         & )
+      IF (kext>0) THEN
+         ALLOCATE( & 
+            & prof%var(kvar)%vext(kobs,kext) &
+            & )
+      ENDIF
+
+   END SUBROUTINE obs_prof_alloc_var
+
+   SUBROUTINE obs_prof_dealloc_var( prof, kvar )
+
+      !!----------------------------------------------------------------------
+      !!                     ***  ROUTINE obs_prof_alloc_var  ***
+      !!                      
+      !! ** Purpose : - Allocate data for variable data in profile arrays
+      !! 
+      !! ** Method  : - Fortran-90 dynamic arrays
+      !!
+      !! History :
+      !!        !  07-03  (K. Mogensen) Original code
+      !! * Arguments
+      TYPE(obs_prof), INTENT(INOUT) :: prof   ! Profile data to be allocated
+      INTEGER, INTENT(IN) :: kvar      ! Variable number
+      
+      DEALLOCATE( & 
+         & prof%var(kvar)%mvk,    &
+         & prof%var(kvar)%nvpidx, &
+         & prof%var(kvar)%nvlidx, &
+         & prof%var(kvar)%nvqc,   &
+         & prof%var(kvar)%idqc,   &
+         & prof%var(kvar)%vdep,   &
+         & prof%var(kvar)%vobs,   &
+         & prof%var(kvar)%vmod,   &
+         & prof%var(kvar)%nvind,  &
+         & prof%var(kvar)%idqcf,  &
+         & prof%var(kvar)%nvqcf   &
+         & )
+      IF (prof%next>0) THEN
+         DEALLOCATE( & 
+            & prof%var(kvar)%vext  &
+            & )
+      ENDIF
+
+   END SUBROUTINE obs_prof_dealloc_var
+
+   SUBROUTINE obs_prof_compress( prof,   newprof, lallocate, &
+      &                          kumout, lvalid,   lvvalid )
+      !!----------------------------------------------------------------------
+      !!                     ***  ROUTINE obs_prof_compress  ***
+      !!                      
+      !! ** Purpose : - Extract sub-information from a obs_prof type
+      !!                into a new obs_prof type
+      !! 
+      !! ** Method  : - The data is copied from prof to new prof.
+      !!                In the case of lvalid and lvvalid both being
+      !!                present only the selected data will be copied.
+      !!                If lallocate is true the data in the newprof is 
+      !!                allocated either with the same number of elements
+      !!                as prof or with only the subset of elements defined
+      !!                by the optional selection in lvalid and lvvalid
+      !!
+      !! History :
+      !!        !  07-01  (K. Mogensen) Original code
+      !!----------------------------------------------------------------------
+      !! * Arguments
+      TYPE(obs_prof), INTENT(IN)    :: prof      ! Original profile
+      TYPE(obs_prof), INTENT(INOUT) :: newprof   ! New profile with the copy of the data
+      LOGICAL :: lallocate                ! Allocate newprof data
+      INTEGER,INTENT(IN) :: kumout        ! Fortran unit for messages
+      TYPE(obs_prof_valid), OPTIONAL, INTENT(in) :: &
+         & lvalid        ! Valid profiles
+      TYPE(obs_prof_valid), OPTIONAL, INTENT(in), DIMENSION(prof%nvar) :: &
+         & lvvalid       ! Valid data within the profiles
+      
+      !!* Local variables
+      INTEGER :: inprof
+      INTEGER, DIMENSION(prof%nvar) :: &
+         & invpro
+      INTEGER :: jvar
+      INTEGER :: jext
+      INTEGER :: ji
+      INTEGER :: jj 
+      LOGICAL :: lfirst
+      TYPE(obs_prof_valid) :: &
+         & llvalid
+      TYPE(obs_prof_valid), DIMENSION(prof%nvar) :: &
+         & llvvalid
+      LOGICAL :: lallpresent
+      LOGICAL :: lnonepresent
+
+      ! Check that either all or none of the masks are persent.
+
+      lallpresent  = .FALSE.
+      lnonepresent = .FALSE.
+      IF ( PRESENT(lvalid) .AND. PRESENT(lvvalid) ) THEN
+         lallpresent =  .TRUE.
+      ELSEIF ( ( .NOT. PRESENT(lvalid)  ) .AND. &
+         &     ( .NOT. PRESENT(lvvalid) ) ) THEN
+         lnonepresent = .TRUE.
+      ELSE
+         CALL ctl_stop('Error in obs_prof_compress:', &
+            &          'Either all selection variables should be set', &
+            &          'or no selection variable should be set' )
+      ENDIF
+      
+      ! Count how many elements there should be in the new data structure
+
+      IF ( lallpresent ) THEN
+         inprof = 0
+         invpro(:) = 0
+         DO ji = 1, prof%nprof
+            IF ( lvalid%luse(ji) ) THEN
+               inprof=inprof+1
+               DO jvar = 1, prof%nvar
+                  DO jj = prof%npvsta(ji,jvar), prof%npvend(ji,jvar)
+                     IF ( lvvalid(jvar)%luse(jj) ) &
+                        &           invpro(jvar) = invpro(jvar) +1
+                  END DO
+               END DO
+            ENDIF
+         END DO
+      ELSE
+         inprof    = prof%nprof
+         invpro(:) = prof%nvprot(:)
+      ENDIF
+
+      ! Optionally allocate data in the new data structure
+
+      IF ( lallocate ) THEN
+         CALL obs_prof_alloc( newprof,   prof%nvar, &
+            &                 prof%next,            &
+            &                 inprof,    invpro,    &
+            &                 prof%nstp, prof%npi,  &
+            &                 prof%npj,  prof%npk )
+      ENDIF
+
+      ! Allocate temporary mask array to unify the code for both cases
+
+      ALLOCATE( llvalid%luse(prof%nprof) )
+      DO jvar = 1, prof%nvar
+         ALLOCATE( llvvalid(jvar)%luse(prof%nvprot(jvar)) )
+      END DO
+      IF ( lallpresent ) THEN
+         llvalid%luse(:) = lvalid%luse(:)
+         DO jvar = 1, prof%nvar
+            llvvalid(jvar)%luse(:) = lvvalid(jvar)%luse(:)
+         END DO
+      ELSE
+         llvalid%luse(:) = .TRUE.
+         DO jvar = 1, prof%nvar
+            llvvalid(jvar)%luse(:) = .TRUE.
+         END DO
+      ENDIF
+
+      ! Setup bookkeeping variables
+
+      inprof    = 0
+      invpro(:) = 0
+
+      newprof%npvsta(:,:) =  0
+      newprof%npvend(:,:) = -1
+      
+      ! Loop over source profiles
+
+      DO ji = 1, prof%nprof
+
+         IF ( llvalid%luse(ji) ) THEN
+
+            ! Copy the header information
+
+            inprof = inprof + 1
+
+            newprof%mi(inprof,:)  = prof%mi(ji,:)
+            newprof%mj(inprof,:) = prof%mj(ji,:)
+            newprof%npidx(inprof) = prof%npidx(ji)
+            newprof%npfil(inprof) = prof%npfil(ji)
+            newprof%nyea(inprof)  = prof%nyea(ji)
+            newprof%nmon(inprof)  = prof%nmon(ji)
+            newprof%nday(inprof)  = prof%nday(ji)
+            newprof%nhou(inprof)  = prof%nhou(ji)
+            newprof%nmin(inprof)  = prof%nmin(ji)
+            newprof%mstp(inprof)  = prof%mstp(ji)
+            newprof%nqc(inprof)   = prof%nqc(ji)
+            newprof%ipqc(inprof)  = prof%ipqc(ji)
+            newprof%itqc(inprof)  = prof%itqc(ji)
+            newprof%ivqc(inprof,:)= prof%ivqc(ji,:)
+            newprof%ntyp(inprof)  = prof%ntyp(ji)
+            newprof%rlam(inprof)  = prof%rlam(ji)
+            newprof%rphi(inprof)  = prof%rphi(ji)
+            newprof%cwmo(inprof)  = prof%cwmo(ji)
+            
+            ! QC info
+
+            newprof%nqcf(:,inprof)    = prof%nqcf(:,ji)
+            newprof%ipqcf(:,inprof)   = prof%ipqcf(:,ji)
+            newprof%itqcf(:,inprof)   = prof%itqcf(:,ji)
+            newprof%ivqcf(:,inprof,:) = prof%ivqcf(:,ji,:)
+            
+            ! npind is the index of the original profile
+            
+            newprof%npind(inprof) = ji
+
+            ! Copy the variable information
+
+            DO jvar = 1, prof%nvar
+
+               lfirst = .TRUE.
+               
+               DO jj = prof%npvsta(ji,jvar), prof%npvend(ji,jvar)
+                  
+                  IF ( llvvalid(jvar)%luse(jj) ) THEN
+
+                     invpro(jvar) = invpro(jvar) + 1
+                  
+                     ! Book keeping information
+                                    
+                     IF ( lfirst ) THEN
+                        lfirst = .FALSE.
+                        newprof%npvsta(inprof,jvar) = invpro(jvar)
+                     ENDIF
+                     newprof%npvend(inprof,jvar) = invpro(jvar)
+
+                     ! Variable data
+                     
+                     newprof%var(jvar)%mvk(invpro(jvar))    = &
+                        &                           prof%var(jvar)%mvk(jj)
+                     newprof%var(jvar)%nvpidx(invpro(jvar)) = &
+                        &                           prof%var(jvar)%nvpidx(jj)
+                     newprof%var(jvar)%nvlidx(invpro(jvar)) = &
+                        &                           prof%var(jvar)%nvlidx(jj)
+                     newprof%var(jvar)%nvqc(invpro(jvar))   = &
+                        &                           prof%var(jvar)%nvqc(jj)
+                     newprof%var(jvar)%idqc(invpro(jvar))   = &
+                        &                           prof%var(jvar)%idqc(jj)
+                     newprof%var(jvar)%idqcf(:,invpro(jvar))= &
+                        &                           prof%var(jvar)%idqcf(:,jj)
+                     newprof%var(jvar)%nvqcf(:,invpro(jvar))= &
+                        &                           prof%var(jvar)%nvqcf(:,jj)
+                     newprof%var(jvar)%vdep(invpro(jvar))   = &
+                        &                           prof%var(jvar)%vdep(jj)
+                     newprof%var(jvar)%vobs(invpro(jvar))   = &
+                        &                           prof%var(jvar)%vobs(jj)
+                     newprof%var(jvar)%vmod(invpro(jvar))   = &
+                        &                           prof%var(jvar)%vmod(jj)
+                     DO jext = 1, prof%next
+                        newprof%var(jvar)%vext(invpro(jvar),jext) = &
+                           &                      prof%var(jvar)%vext(jj,jext)
+                     END DO
+                  
+                     ! nvind is the index of the original variable data
+                     
+                     newprof%var(jvar)%nvind(invpro(jvar))  = jj
+                     
+                  ENDIF
+
+               END DO
+
+            END DO
+
+         ENDIF
+
+      END DO
+
+      ! Update MPP counters
+
+      DO jvar = 1, prof%nvar
+         newprof%nvprot(jvar) = invpro(jvar)
+      END DO
+      CALL obs_mpp_sum_integers ( newprof%nvprot, newprof%nvprotmpp,&
+         &                        prof%nvar )
+      
+      ! Set book keeping variables which do not depend on number of obs.
+
+      newprof%nvar     = prof%nvar
+      newprof%next     = prof%next
+      newprof%nstp     = prof%nstp
+      newprof%npi      = prof%npi
+      newprof%npj      = prof%npj
+      newprof%npk      = prof%npk
+      newprof%cvars(:) = prof%cvars(:)
+ 
+      ! Deallocate temporary data
+
+      DO jvar = 1, prof%nvar
+         DEALLOCATE( llvvalid(jvar)%luse )
+      END DO
+ 
+      DEALLOCATE( llvalid%luse )
+     
+   END SUBROUTINE obs_prof_compress
+
+   SUBROUTINE obs_prof_decompress( prof, oldprof, ldeallocate, kumout )
+      !!----------------------------------------------------------------------
+      !!                     ***  ROUTINE obs_prof_decompress  ***
+      !!                      
+      !! ** Purpose : - Copy back information to original profile type
+      !!
+      !! ** Method  : - Reinsert updated information from a previous
+      !!                copied/compressed profile type into the original
+      !!                profile data and optionally deallocate the prof
+      !!                data input
+      !! 
+      !! History :
+      !!        !  07-01  (K. Mogensen) Original code
+      !!----------------------------------------------------------------------
+      !! * Arguments
+      TYPE(obs_prof),INTENT(INOUT) :: prof      ! Updated profile data
+      TYPE(obs_prof),INTENT(INOUT) :: oldprof   ! Original profile data
+      LOGICAL :: ldeallocate         ! Deallocate the updated data of insertion
+      INTEGER,INTENT(in) :: kumout   ! Output unit
+      
+      !!* Local variables
+      INTEGER :: jvar
+      INTEGER :: jext
+      INTEGER :: ji
+      INTEGER :: jj
+      INTEGER :: jk
+      INTEGER :: jl
+
+      DO ji = 1, prof%nprof
+
+         ! Copy header information
+         
+         jk = prof%npind(ji)
+      
+         oldprof%mi(jk,:)  = prof%mi(ji,:)
+         oldprof%mj(jk,:)  = prof%mj(ji,:)
+         oldprof%npidx(jk) = prof%npidx(ji)
+         oldprof%npfil(jk) = prof%npfil(ji)
+         oldprof%nyea(jk)  = prof%nyea(ji)
+         oldprof%nmon(jk)  = prof%nmon(ji)
+         oldprof%nday(jk)  = prof%nday(ji)
+         oldprof%nhou(jk)  = prof%nhou(ji)
+         oldprof%nmin(jk)  = prof%nmin(ji)
+         oldprof%mstp(jk)  = prof%mstp(ji)
+         oldprof%nqc(jk)   = prof%nqc(ji)
+         oldprof%ipqc(jk)  = prof%ipqc(ji)
+         oldprof%itqc(jk)  = prof%itqc(ji)
+         oldprof%ivqc(jk,:)= prof%ivqc(ji,:)
+         oldprof%ntyp(jk)  = prof%ntyp(ji)
+         oldprof%rlam(jk)  = prof%rlam(ji)
+         oldprof%rphi(jk)  = prof%rphi(ji)
+         oldprof%cwmo(jk)  = prof%cwmo(ji)
+         
+         ! QC info
+
+         oldprof%nqcf(:,jk)    = prof%nqcf(:,ji)
+         oldprof%ipqcf(:,jk)   = prof%ipqcf(:,ji)
+         oldprof%itqcf(:,jk)   = prof%itqcf(:,ji)
+         oldprof%ivqcf(:,jk,:) = prof%ivqcf(:,ji,:)
+
+         ! Copy the variable information
+
+         DO jvar = 1, prof%nvar
+
+            DO jj = prof%npvsta(ji,jvar), prof%npvend(ji,jvar)
+               
+               jl = prof%var(jvar)%nvind(jj)
+
+               oldprof%var(jvar)%mvk(jl)    = prof%var(jvar)%mvk(jj)
+               oldprof%var(jvar)%nvpidx(jl) = prof%var(jvar)%nvpidx(jj)
+               oldprof%var(jvar)%nvlidx(jl) = prof%var(jvar)%nvlidx(jj)
+               oldprof%var(jvar)%nvqc(jl)   = prof%var(jvar)%nvqc(jj)
+               oldprof%var(jvar)%idqc(jl)   = prof%var(jvar)%idqc(jj)
+               oldprof%var(jvar)%vdep(jl)   = prof%var(jvar)%vdep(jj)
+               oldprof%var(jvar)%vobs(jl)   = prof%var(jvar)%vobs(jj)
+               oldprof%var(jvar)%vmod(jl)   = prof%var(jvar)%vmod(jj)
+               oldprof%var(jvar)%idqcf(:,jl) = prof%var(jvar)%idqcf(:,jj)
+               oldprof%var(jvar)%nvqcf(:,jl) = prof%var(jvar)%nvqcf(:,jj)
+               DO jext = 1, prof%next
+                  oldprof%var(jvar)%vext(jl,jext) = &
+                     &                        prof%var(jvar)%vext(jj,jext)
+               END DO
+               
+            END DO
+
+         END DO
+         
+      END DO
+
+      ! Optionally deallocate the updated profile data
+
+      IF ( ldeallocate ) CALL obs_prof_dealloc( prof )
+      
+   END SUBROUTINE obs_prof_decompress
+
+   SUBROUTINE obs_prof_staend( prof, kvarno )
+      !!----------------------------------------------------------------------
+      !!                     ***  ROUTINE obs_prof_decompress  ***
+      !!                      
+      !! ** Purpose : - Set npvsta and npvend of a variable within 
+      !!                an obs_prof_var type
+      !!
+      !! ** Method  : - Find the start and stop of a profile by searching 
+      !!                through the data
+      !! 
+      !! History :
+      !!        !  07-04  (K. Mogensen) Original code
+      !!----------------------------------------------------------------------
+      !! * Arguments
+      TYPE(obs_prof),INTENT(INOUT) :: prof     ! Profile data
+      INTEGER,INTENT(IN) :: kvarno     ! Variable number
+
+      !!* Local variables
+      INTEGER :: ji
+      INTEGER :: iprofno
+
+      !-----------------------------------------------------------------------
+      ! Compute start and end bookkeeping arrays
+      !-----------------------------------------------------------------------
+
+      prof%npvsta(:,kvarno) = prof%nvprot(kvarno) + 1
+      prof%npvend(:,kvarno) = -1
+      DO ji = 1, prof%nvprot(kvarno)
+         iprofno = prof%var(kvarno)%nvpidx(ji)
+         prof%npvsta(iprofno,kvarno) = &
+            & MIN( ji, prof%npvsta(iprofno,kvarno) )
+         prof%npvend(iprofno,kvarno) = &
+            & MAX( ji, prof%npvend(iprofno,kvarno) )
+      END DO
+
+      DO ji = 1, prof%nprof
+         IF ( prof%npvsta(ji,kvarno) == ( prof%nvprot(kvarno) + 1 ) ) &
+            & prof%npvsta(ji,kvarno) = 0
+      END DO
+
+   END SUBROUTINE obs_prof_staend
+   
+END MODULE obs_profiles_def
+
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/obs_read_altbias.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/obs_read_altbias.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/obs_read_altbias.F90	(revision 9570)
@@ -0,0 +1,204 @@
+MODULE obs_read_altbias
+   !!======================================================================
+   !!                       ***  MODULE obs_readaltbias  ***
+   !! Observation diagnostics: Read the bias for SLA data
+   !!======================================================================
+
+   !!----------------------------------------------------------------------
+   !!   obs_rea_altbias : Driver for reading altimeter bias
+   !!----------------------------------------------------------------------
+
+   !! * Modules used   
+   USE par_kind, ONLY : &       ! Precision variables
+      & wp, &
+      & dp, &
+      & sp
+   USE par_oce, ONLY : &        ! Domain parameters
+      & jpi, &
+      & jpj, &
+      & jpim1
+   USE in_out_manager, ONLY : & ! I/O manager
+      & lwp,    &
+      & numout 
+   USE obs_surf_def             ! Surface observation definitions
+   USE dom_oce, ONLY : &        ! Domain variables
+      & tmask, &
+      & tmask_i, &
+      & e1t,   &
+      & e2t,   &
+      & gphit
+   USE oce, ONLY : &           ! Model variables
+      & sshn
+   USE obs_inter_h2d
+   USE obs_utils               ! Various observation tools
+   USE obs_inter_sup
+
+   IMPLICIT NONE
+
+   !! * Routine accessibility
+   PRIVATE
+
+   PUBLIC obs_rea_altbias     ! Read the altimeter bias
+
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO Consortium (2010)
+   !! $Id$
+   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+
+CONTAINS
+
+   SUBROUTINE obs_rea_altbias( sladata, k2dint, bias_file )
+      !!---------------------------------------------------------------------
+      !!
+      !!                   *** ROUTINE obs_rea_altbias ***
+      !!
+      !! ** Purpose : Read from file the bias data 
+      !!
+      !! ** Method  : 
+      !!
+      !! ** Action  : 
+      !!
+      !! References :
+      !!
+      !! History :  
+      !!      ! :  2008-02 (D. Lea) Initial version
+      !!----------------------------------------------------------------------
+      !! * Modules used
+      USE iom
+      !
+      !! * Arguments
+      TYPE(obs_surf), INTENT(INOUT) :: &
+         & sladata       ! SLA data
+      INTEGER, INTENT(IN) :: k2dint
+      CHARACTER(LEN=128) :: bias_file
+
+      !! * Local declarations
+
+      CHARACTER(LEN=12), PARAMETER :: cpname = 'obs_rea_altbias'
+
+      INTEGER :: jobs         ! Obs loop variable
+      INTEGER :: jpialtbias   ! Number of grid point in latitude for the bias
+      INTEGER :: jpjaltbias   ! Number of grid point in longitude for the bias
+      INTEGER :: iico         ! Grid point indicies
+      INTEGER :: ijco
+      INTEGER :: i_nx_id      ! Index to read the NetCDF file
+      INTEGER :: i_ny_id      ! 
+      INTEGER :: i_file_id    ! 
+      INTEGER :: i_var_id
+
+      REAL(wp), DIMENSION(1) :: &
+         & zext, &
+         & zobsmask
+      REAL(wp), DIMENSION(2,2,1) :: &
+         & zweig
+      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: &
+         & zmask, &
+         & zbias, &
+         & zglam, &
+         & zgphi
+      REAL(wp), DIMENSION(jpi,jpj) ::   z_altbias
+      REAL(wp) :: zlam
+      REAL(wp) :: zphi
+      INTEGER, DIMENSION(:,:,:), ALLOCATABLE :: &
+         & igrdi, &
+         & igrdj
+      INTEGER :: numaltbias
+
+      IF(lwp)WRITE(numout,*) 
+      IF(lwp)WRITE(numout,*) ' obs_rea_altbias : '
+      IF(lwp)WRITE(numout,*) ' ------------- '
+      IF(lwp)WRITE(numout,*) '   Read altimeter bias'
+
+      ! Open the file
+
+      z_altbias(:,:)=0.0_wp
+      numaltbias=0
+
+      IF(lwp)WRITE(numout,*) 'Opening ',bias_file
+
+      CALL iom_open( bias_file, numaltbias, ldstop=.FALSE. )
+      
+
+      IF (numaltbias .GT. 0) THEN      
+
+         ! Get the Alt bias data
+         
+         CALL iom_get( numaltbias, jpdom_data, 'altbias', z_altbias(:,:), 1 )
+         
+         ! Close the file
+         
+         CALL iom_close(numaltbias)     
+         
+      ELSE
+
+         IF(lwp)WRITE(numout,*) 'no file found'
+      
+      ENDIF
+
+      ! Intepolate the bias already on the model grid at the observation point
+  
+      ALLOCATE( &
+         & igrdi(2,2,sladata%nsurf), &
+         & igrdj(2,2,sladata%nsurf), &
+         & zglam(2,2,sladata%nsurf), &
+         & zgphi(2,2,sladata%nsurf), &
+         & zmask(2,2,sladata%nsurf), &
+         & zbias(2,2,sladata%nsurf)  &
+         & )
+         
+      DO jobs = 1, sladata%nsurf
+
+         igrdi(1,1,jobs) = sladata%mi(jobs)-1
+         igrdj(1,1,jobs) = sladata%mj(jobs)-1
+         igrdi(1,2,jobs) = sladata%mi(jobs)-1
+         igrdj(1,2,jobs) = sladata%mj(jobs)
+         igrdi(2,1,jobs) = sladata%mi(jobs)
+         igrdj(2,1,jobs) = sladata%mj(jobs)-1
+         igrdi(2,2,jobs) = sladata%mi(jobs)
+         igrdj(2,2,jobs) = sladata%mj(jobs)
+
+      END DO
+
+      CALL obs_int_comm_2d( 2, 2, sladata%nsurf, jpi, jpj, &
+         &                  igrdi, igrdj, glamt, zglam )
+      CALL obs_int_comm_2d( 2, 2, sladata%nsurf, jpi, jpj, &
+         &                  igrdi, igrdj, gphit, zgphi )
+      CALL obs_int_comm_2d( 2, 2, sladata%nsurf, jpi, jpj, &
+         &                  igrdi, igrdj, tmask(:,:,1), zmask )
+      CALL obs_int_comm_2d( 2, 2, sladata%nsurf, jpi, jpj, &
+         &                  igrdi, igrdj, z_altbias, zbias )
+
+      DO jobs = 1, sladata%nsurf
+
+         zlam = sladata%rlam(jobs)
+         zphi = sladata%rphi(jobs)
+         iico = sladata%mi(jobs)
+         ijco = sladata%mj(jobs)
+            
+         CALL obs_int_h2d_init( 1, 1, k2dint, zlam, zphi,         &
+            &                   zglam(:,:,jobs), zgphi(:,:,jobs), &
+            &                   zmask(:,:,jobs), zweig, zobsmask )
+            
+         CALL obs_int_h2d( 1, 1,      &
+            &              zweig, zbias(:,:,jobs),  zext )
+
+         ! adjust mdt with bias field
+         sladata%rext(jobs,2) = sladata%rext(jobs,2) - zext(1)
+            
+      END DO
+
+      DEALLOCATE( &
+         & igrdi, &
+         & igrdj, &
+         & zglam, &
+         & zgphi, &
+         & zmask, &
+         & zbias  &
+         & )
+         
+   END SUBROUTINE obs_rea_altbias
+
+
+ 
+END MODULE obs_read_altbias
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/obs_read_prof.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/obs_read_prof.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/obs_read_prof.F90	(revision 9570)
@@ -0,0 +1,866 @@
+MODULE obs_read_prof
+   !!======================================================================
+   !!                       ***  MODULE obs_read_prof  ***
+   !! Observation diagnostics: Read the T and S profile observations
+   !!======================================================================
+
+   !!----------------------------------------------------------------------
+   !!   obs_rea_pro_dri : Driver for reading profile obs
+   !!----------------------------------------------------------------------
+
+   !! * Modules used   
+   USE par_kind                 ! Precision variables
+   USE par_oce                  ! Ocean parameters
+   USE in_out_manager           ! I/O manager
+   USE dom_oce                  ! Ocean space and time domain variables
+   USE obs_mpp                  ! MPP support routines for observation diagnostics
+   USE julian                   ! Julian date routines
+   USE obs_utils                ! Observation operator utility functions
+   USE obs_prep                 ! Prepare observation arrays
+   USE obs_grid                 ! Grid search
+   USE obs_sort                 ! Sorting observation arrays
+   USE obs_profiles_def         ! Profile definitions
+   USE obs_conv                 ! Various conversion routines
+   USE obs_types                ! Observation type definitions
+   USE netcdf                   ! NetCDF library
+   USE obs_oper                 ! Observation operators
+   USE lib_mpp                  ! For ctl_warn/stop
+   USE obs_fbm                  ! Feedback routines
+
+   IMPLICIT NONE
+
+   !! * Routine accessibility
+   PRIVATE
+
+   PUBLIC obs_rea_prof  ! Read the profile observations 
+
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO Consortium (2010)
+   !! $Id$
+   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+
+CONTAINS
+
+   SUBROUTINE obs_rea_prof( profdata, knumfiles, cdfilenames, &
+      &                     kvars, kextr, kstp, ddobsini, ddobsend, &
+      &                     ldvar1, ldvar2, ldignmis, ldsatt, &
+      &                     ldmod, kdailyavtypes )
+      !!---------------------------------------------------------------------
+      !!
+      !!                   *** ROUTINE obs_rea_prof ***
+      !!
+      !! ** Purpose : Read from file the profile observations
+      !!
+      !! ** Method  : Read feedback data in and transform to NEMO internal 
+      !!              profile data structure
+      !!
+      !! ** Action  : 
+      !!
+      !! References : 
+      !!
+      !! History :  
+      !!      ! :  2009-09 (K. Mogensen) : New merged version of old routines
+      !!      ! :  2015-08 (M. Martin) : Merged profile and velocity routines
+      !!----------------------------------------------------------------------
+
+      !! * Arguments
+      TYPE(obs_prof), INTENT(OUT) :: &
+         & profdata                     ! Profile data to be read
+      INTEGER, INTENT(IN) :: knumfiles  ! Number of files to read
+      CHARACTER(LEN=128), INTENT(IN) ::  &
+         & cdfilenames(knumfiles)        ! File names to read in
+      INTEGER, INTENT(IN) :: kvars      ! Number of variables in profdata
+      INTEGER, INTENT(IN) :: kextr      ! Number of extra fields for each var
+      INTEGER, INTENT(IN) :: kstp       ! Ocean time-step index
+      LOGICAL, INTENT(IN) :: ldvar1     ! Observed variables switches
+      LOGICAL, INTENT(IN) :: ldvar2
+      LOGICAL, INTENT(IN) :: ldignmis   ! Ignore missing files
+      LOGICAL, INTENT(IN) :: ldsatt     ! Compute salinity at all temperature points
+      LOGICAL, INTENT(IN) :: ldmod      ! Initialize model from input data
+      REAL(dp), INTENT(IN) :: ddobsini  ! Obs. ini time in YYYYMMDD.HHMMSS
+      REAL(dp), INTENT(IN) :: ddobsend  ! Obs. end time in YYYYMMDD.HHMMSS
+      INTEGER, DIMENSION(imaxavtypes), OPTIONAL :: &
+         & kdailyavtypes                ! Types of daily average observations
+
+      !! * Local declarations
+      CHARACTER(LEN=15), PARAMETER :: cpname='obs_rea_prof'
+      CHARACTER(len=8) :: clrefdate
+      CHARACTER(len=8), DIMENSION(:), ALLOCATABLE :: clvars
+      INTEGER :: jvar
+      INTEGER :: ji
+      INTEGER :: jj
+      INTEGER :: jk
+      INTEGER :: ij
+      INTEGER :: iflag
+      INTEGER :: inobf
+      INTEGER :: i_file_id
+      INTEGER :: inowin
+      INTEGER :: iyea
+      INTEGER :: imon
+      INTEGER :: iday
+      INTEGER :: ihou
+      INTEGER :: imin
+      INTEGER :: isec
+      INTEGER :: iprof
+      INTEGER :: iproftot
+      INTEGER :: ivar1t0
+      INTEGER :: ivar2t0
+      INTEGER :: ivar1t
+      INTEGER :: ivar2t
+      INTEGER :: ip3dt
+      INTEGER :: ios
+      INTEGER :: ioserrcount
+      INTEGER :: ivar1tmpp
+      INTEGER :: ivar2tmpp
+      INTEGER :: ip3dtmpp
+      INTEGER :: itype
+      INTEGER, DIMENSION(knumfiles) :: &
+         & irefdate
+      INTEGER, DIMENSION(ntyp1770+1) :: &
+         & itypvar1,    &
+         & itypvar1mpp, &
+         & itypvar2,    &
+         & itypvar2mpp 
+      INTEGER, DIMENSION(:), ALLOCATABLE :: &
+         & iobsi1,    &
+         & iobsj1,    &
+         & iproc1,    &
+         & iobsi2,    &
+         & iobsj2,    &
+         & iproc2,    &
+         & iindx,    &
+         & ifileidx, &
+         & iprofidx
+      INTEGER, DIMENSION(imaxavtypes) :: &
+         & idailyavtypes
+      INTEGER, DIMENSION(kvars) :: &
+         & iv3dt
+      REAL(wp), DIMENSION(:), ALLOCATABLE :: &
+         & zphi, &
+         & zlam
+      REAL(wp), DIMENSION(:), ALLOCATABLE :: &
+         & zdat
+      REAL(wp), DIMENSION(knumfiles) :: &
+         & djulini, &
+         & djulend
+      LOGICAL :: llvalprof
+      LOGICAL :: lldavtimset
+      TYPE(obfbdata), POINTER, DIMENSION(:) :: &
+         & inpfiles
+
+      ! Local initialization
+      iprof = 0
+      ivar1t0 = 0
+      ivar2t0 = 0
+      ip3dt = 0
+
+      ! Daily average types
+      lldavtimset = .FALSE.
+      IF ( PRESENT(kdailyavtypes) ) THEN
+         idailyavtypes(:) = kdailyavtypes(:)
+         IF ( ANY (idailyavtypes(:) /= -1) ) lldavtimset = .TRUE.
+      ELSE
+         idailyavtypes(:) = -1
+      ENDIF
+
+      !-----------------------------------------------------------------------
+      ! Count the number of files needed and allocate the obfbdata type
+      !-----------------------------------------------------------------------
+
+      inobf = knumfiles
+
+      ALLOCATE( inpfiles(inobf) )
+
+      prof_files : DO jj = 1, inobf
+
+         !---------------------------------------------------------------------
+         ! Prints
+         !---------------------------------------------------------------------
+         IF(lwp) THEN
+            WRITE(numout,*)
+            WRITE(numout,*) ' obs_rea_pro_dri : Reading from file = ', &
+               & TRIM( TRIM( cdfilenames(jj) ) )
+            WRITE(numout,*) ' ~~~~~~~~~~~~~~~'
+            WRITE(numout,*)
+         ENDIF
+
+         !---------------------------------------------------------------------
+         !  Initialization: Open file and get dimensions only
+         !---------------------------------------------------------------------
+
+         iflag = nf90_open( TRIM( cdfilenames(jj) ), nf90_nowrite, &
+            &                      i_file_id )
+
+         IF ( iflag /= nf90_noerr ) THEN
+
+            IF ( ldignmis ) THEN
+               inpfiles(jj)%nobs = 0
+               CALL ctl_warn( 'File ' // TRIM( cdfilenames(jj) ) // &
+                  &           ' not found' )
+            ELSE 
+               CALL ctl_stop( 'File ' // TRIM( cdfilenames(jj) ) // &
+                  &           ' not found' )
+            ENDIF
+
+         ELSE 
+
+            !------------------------------------------------------------------
+            !  Close the file since it is opened in read_obfbdata
+            !------------------------------------------------------------------
+
+            iflag = nf90_close( i_file_id )
+
+            !------------------------------------------------------------------
+            !  Read the profile file into inpfiles
+            !------------------------------------------------------------------
+            CALL init_obfbdata( inpfiles(jj) )
+            CALL read_obfbdata( TRIM( cdfilenames(jj) ), inpfiles(jj), &
+               &                ldgrid = .TRUE. )
+
+            IF ( inpfiles(jj)%nvar < 2 ) THEN
+               CALL ctl_stop( 'Feedback format error: ', &
+                  &           ' less than 2 vars in profile file' )
+            ENDIF
+
+            IF ( ldmod .AND. ( inpfiles(jj)%nadd == 0 ) ) THEN
+               CALL ctl_stop( 'Model not in input data' )
+            ENDIF
+
+            IF ( jj == 1 ) THEN
+               ALLOCATE( clvars( inpfiles(jj)%nvar ) )
+               DO ji = 1, inpfiles(jj)%nvar
+                 clvars(ji) = inpfiles(jj)%cname(ji)
+               END DO
+            ELSE
+               DO ji = 1, inpfiles(jj)%nvar
+                  IF ( inpfiles(jj)%cname(ji) /= clvars(ji) ) THEN
+                     CALL ctl_stop( 'Feedback file variables not consistent', &
+                        &           ' with previous files for this type' )
+                  ENDIF
+               END DO
+            ENDIF
+
+            !------------------------------------------------------------------
+            !  Change longitude (-180,180)
+            !------------------------------------------------------------------
+
+            DO ji = 1, inpfiles(jj)%nobs 
+
+               IF ( inpfiles(jj)%plam(ji) < -180. ) &
+                  &   inpfiles(jj)%plam(ji) = inpfiles(jj)%plam(ji) + 360.
+
+               IF ( inpfiles(jj)%plam(ji) >  180. ) &
+                  &   inpfiles(jj)%plam(ji) = inpfiles(jj)%plam(ji) - 360.
+
+            END DO
+
+            !------------------------------------------------------------------
+            !  Calculate the date  (change eventually)
+            !------------------------------------------------------------------
+            clrefdate=inpfiles(jj)%cdjuldref(1:8)
+            READ(clrefdate,'(I8)') irefdate(jj)
+
+            CALL ddatetoymdhms( ddobsini, iyea, imon, iday, ihou, imin, isec )
+            CALL greg2jul( isec, imin, ihou, iday, imon, iyea, djulini(jj), &
+               &           krefdate = irefdate(jj) )
+            CALL ddatetoymdhms( ddobsend, iyea, imon, iday, ihou, imin, isec )
+            CALL greg2jul( isec, imin, ihou, iday, imon, iyea, djulend(jj), &
+               &           krefdate = irefdate(jj) )
+
+            ioserrcount=0
+            IF ( lldavtimset ) THEN
+
+               IF ( ANY ( idailyavtypes(:) /= -1 ) .AND. lwp) THEN
+                  WRITE(numout,*)' Resetting time of daily averaged', &
+                     &           ' observations to the end of the day'
+               ENDIF
+
+               DO ji = 1, inpfiles(jj)%nobs
+                  READ( inpfiles(jj)%cdtyp(ji), '(I4)', IOSTAT = ios, ERR = 900 ) itype
+900               IF ( ios /= 0 ) THEN
+                     ! Set type to zero if there is a problem in the string conversion
+                     itype = 0
+                  ENDIF
+
+                  IF ( ANY ( idailyavtypes(:) == itype ) ) THEN
+                  !  for daily averaged data force the time
+                  !  to be the last time-step of the day, but still within the day.
+                     IF ( inpfiles(jj)%ptim(ji) >= 0. ) THEN
+                        inpfiles(jj)%ptim(ji) = &
+                           & INT(inpfiles(jj)%ptim(ji)) + 0.9999
+                     ELSE
+                        inpfiles(jj)%ptim(ji) = &
+                           & INT(inpfiles(jj)%ptim(ji)) - 0.0001
+                     ENDIF
+                  ENDIF
+
+               END DO
+
+            ENDIF
+
+            IF ( inpfiles(jj)%nobs > 0 ) THEN
+               inpfiles(jj)%iproc(:,:) = -1
+               inpfiles(jj)%iobsi(:,:) = -1
+               inpfiles(jj)%iobsj(:,:) = -1
+            ENDIF
+            inowin = 0
+            DO ji = 1, inpfiles(jj)%nobs
+               IF ( BTEST(inpfiles(jj)%ioqc(ji),2 ) ) CYCLE
+               IF ( BTEST(inpfiles(jj)%ivqc(ji,1),2) .AND. &
+                  & BTEST(inpfiles(jj)%ivqc(ji,2),2) ) CYCLE
+               IF ( ( inpfiles(jj)%ptim(ji) >  djulini(jj) ) .AND. &
+                  & ( inpfiles(jj)%ptim(ji) <= djulend(jj) )       ) THEN
+                  inowin = inowin + 1
+               ENDIF
+            END DO
+            ALLOCATE( zlam(inowin)  )
+            ALLOCATE( zphi(inowin)  )
+            ALLOCATE( iobsi1(inowin) )
+            ALLOCATE( iobsj1(inowin) )
+            ALLOCATE( iproc1(inowin) )
+            ALLOCATE( iobsi2(inowin) )
+            ALLOCATE( iobsj2(inowin) )
+            ALLOCATE( iproc2(inowin) )
+            inowin = 0
+            DO ji = 1, inpfiles(jj)%nobs
+               IF ( BTEST(inpfiles(jj)%ioqc(ji),2 ) ) CYCLE
+               IF ( BTEST(inpfiles(jj)%ivqc(ji,1),2) .AND. &
+                  & BTEST(inpfiles(jj)%ivqc(ji,2),2) ) CYCLE
+               IF ( ( inpfiles(jj)%ptim(ji) >  djulini(jj) ) .AND. &
+                  & ( inpfiles(jj)%ptim(ji) <= djulend(jj) )       ) THEN
+                  inowin = inowin + 1
+                  zlam(inowin) = inpfiles(jj)%plam(ji)
+                  zphi(inowin) = inpfiles(jj)%pphi(ji)
+               ENDIF
+            END DO
+
+            IF ( TRIM( inpfiles(jj)%cname(1) ) == 'POTM' ) THEN
+               CALL obs_grid_search( inowin, zlam, zphi, iobsi1, iobsj1, &
+                  &                  iproc1, 'T' )
+               iobsi2(:) = iobsi1(:)
+               iobsj2(:) = iobsj1(:)
+               iproc2(:) = iproc1(:)
+            ELSEIF ( TRIM( inpfiles(jj)%cname(1) ) == 'UVEL' ) THEN
+               CALL obs_grid_search( inowin, zlam, zphi, iobsi1, iobsj1, &
+                  &                  iproc1, 'U' )
+               CALL obs_grid_search( inowin, zlam, zphi, iobsi2, iobsj2, &
+                  &                  iproc2, 'V' )
+            ENDIF
+
+            inowin = 0
+            DO ji = 1, inpfiles(jj)%nobs
+               IF ( BTEST(inpfiles(jj)%ioqc(ji),2 ) ) CYCLE
+               IF ( BTEST(inpfiles(jj)%ivqc(ji,1),2) .AND. &
+                  & BTEST(inpfiles(jj)%ivqc(ji,2),2) ) CYCLE
+               IF ( ( inpfiles(jj)%ptim(ji) >  djulini(jj) ) .AND. &
+                  & ( inpfiles(jj)%ptim(ji) <= djulend(jj) )       ) THEN
+                  inowin = inowin + 1
+                  inpfiles(jj)%iproc(ji,1) = iproc1(inowin)
+                  inpfiles(jj)%iobsi(ji,1) = iobsi1(inowin)
+                  inpfiles(jj)%iobsj(ji,1) = iobsj1(inowin)
+                  inpfiles(jj)%iproc(ji,2) = iproc2(inowin)
+                  inpfiles(jj)%iobsi(ji,2) = iobsi2(inowin)
+                  inpfiles(jj)%iobsj(ji,2) = iobsj2(inowin)
+                  IF ( inpfiles(jj)%iproc(ji,1) /= &
+                     & inpfiles(jj)%iproc(ji,2) ) THEN
+                     CALL ctl_stop( 'Error in obs_read_prof:', &
+                        & 'var1 and var2 observation on different processors')
+                  ENDIF
+               ENDIF
+            END DO
+            DEALLOCATE( zlam, zphi, iobsi1, iobsj1, iproc1, iobsi2, iobsj2, iproc2 )
+
+            DO ji = 1, inpfiles(jj)%nobs
+               IF ( BTEST(inpfiles(jj)%ioqc(ji),2 ) ) CYCLE
+               IF ( BTEST(inpfiles(jj)%ivqc(ji,1),2) .AND. &
+                  & BTEST(inpfiles(jj)%ivqc(ji,2),2) ) CYCLE
+               IF ( ( inpfiles(jj)%ptim(ji) >  djulini(jj) ) .AND. &
+                  & ( inpfiles(jj)%ptim(ji) <= djulend(jj) )       ) THEN
+                  IF ( nproc == 0 ) THEN
+                     IF ( inpfiles(jj)%iproc(ji,1) >  nproc ) CYCLE
+                  ELSE
+                     IF ( inpfiles(jj)%iproc(ji,1) /= nproc ) CYCLE
+                  ENDIF
+                  llvalprof = .FALSE.
+                  IF ( ldvar1 ) THEN
+                     loop_t_count : DO ij = 1,inpfiles(jj)%nlev
+                        IF ( inpfiles(jj)%pdep(ij,ji) >= 6000. ) &
+                           & CYCLE
+                        IF ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,1),2) .AND. &
+                           & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) ) THEN
+                           ivar1t0 = ivar1t0 + 1
+                        ENDIF
+                     END DO loop_t_count
+                  ENDIF
+                  IF ( ldvar2 ) THEN
+                     loop_s_count : DO ij = 1,inpfiles(jj)%nlev
+                        IF ( inpfiles(jj)%pdep(ij,ji) >= 6000. ) &
+                           & CYCLE
+                        IF ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,2),2) .AND. &
+                           & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) ) THEN
+                           ivar2t0 = ivar2t0 + 1
+                        ENDIF
+                     END DO loop_s_count
+                  ENDIF
+                  loop_p_count : DO ij = 1,inpfiles(jj)%nlev
+                     IF ( inpfiles(jj)%pdep(ij,ji) >= 6000. ) &
+                        & CYCLE
+                     IF ( ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,1),2) .AND. &
+                        &   .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) .AND. &
+                        &    ldvar1 ) .OR. &
+                        & ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,2),2) .AND. &
+                        &   .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) .AND. &
+                        &     ldvar2 ) ) THEN
+                        ip3dt = ip3dt + 1
+                        llvalprof = .TRUE.
+                     ENDIF
+                  END DO loop_p_count
+
+                  IF ( llvalprof ) iprof = iprof + 1
+
+               ENDIF
+            END DO
+
+         ENDIF
+
+      END DO prof_files
+
+      !-----------------------------------------------------------------------
+      ! Get the time ordered indices of the input data
+      !-----------------------------------------------------------------------
+
+      !---------------------------------------------------------------------
+      !  Loop over input data files to count total number of profiles
+      !---------------------------------------------------------------------
+      iproftot = 0
+      DO jj = 1, inobf
+         DO ji = 1, inpfiles(jj)%nobs
+            IF ( BTEST(inpfiles(jj)%ioqc(ji),2 ) ) CYCLE
+            IF ( BTEST(inpfiles(jj)%ivqc(ji,1),2) .AND. &
+               & BTEST(inpfiles(jj)%ivqc(ji,2),2) ) CYCLE
+            IF ( ( inpfiles(jj)%ptim(ji) >  djulini(jj) ) .AND. &
+               & ( inpfiles(jj)%ptim(ji) <= djulend(jj) )       ) THEN
+               iproftot = iproftot + 1
+            ENDIF
+         END DO
+      END DO
+
+      ALLOCATE( iindx(iproftot), ifileidx(iproftot), &
+         &      iprofidx(iproftot), zdat(iproftot) )
+      jk = 0
+      DO jj = 1, inobf
+         DO ji = 1, inpfiles(jj)%nobs
+            IF ( BTEST(inpfiles(jj)%ioqc(ji),2 ) ) CYCLE
+            IF ( BTEST(inpfiles(jj)%ivqc(ji,1),2) .AND. &
+               & BTEST(inpfiles(jj)%ivqc(ji,2),2) ) CYCLE
+            IF ( ( inpfiles(jj)%ptim(ji) >  djulini(jj) ) .AND. &
+               & ( inpfiles(jj)%ptim(ji) <= djulend(jj) )       ) THEN
+               jk = jk + 1
+               ifileidx(jk) = jj
+               iprofidx(jk) = ji
+               zdat(jk)     = inpfiles(jj)%ptim(ji)
+            ENDIF
+         END DO
+      END DO
+      CALL sort_dp_indx( iproftot, &
+         &               zdat,     &
+         &               iindx   )
+
+      iv3dt(:) = -1
+      IF (ldsatt) THEN
+         iv3dt(1) = ip3dt
+         iv3dt(2) = ip3dt
+      ELSE
+         iv3dt(1) = ivar1t0
+         iv3dt(2) = ivar2t0
+      ENDIF
+      CALL obs_prof_alloc( profdata, kvars, kextr, iprof, iv3dt, &
+         &                 kstp, jpi, jpj, jpk )
+
+      ! * Read obs/positions, QC, all variable and assign to profdata
+
+      profdata%nprof     = 0
+      profdata%nvprot(:) = 0
+      profdata%cvars(:)  = clvars(:)
+      iprof = 0
+
+      ip3dt = 0
+      ivar1t = 0
+      ivar2t = 0
+      itypvar1   (:) = 0
+      itypvar1mpp(:) = 0
+
+      itypvar2   (:) = 0
+      itypvar2mpp(:) = 0
+
+      ioserrcount = 0
+      DO jk = 1, iproftot
+
+         jj = ifileidx(iindx(jk))
+         ji = iprofidx(iindx(jk))
+
+            IF ( BTEST(inpfiles(jj)%ioqc(ji),2 ) ) CYCLE
+            IF ( BTEST(inpfiles(jj)%ivqc(ji,1),2) .AND. &
+               & BTEST(inpfiles(jj)%ivqc(ji,2),2) ) CYCLE
+
+         IF ( ( inpfiles(jj)%ptim(ji) >  djulini(jj) ) .AND.  &
+            & ( inpfiles(jj)%ptim(ji) <= djulend(jj) ) ) THEN
+
+            IF ( nproc == 0 ) THEN
+               IF ( inpfiles(jj)%iproc(ji,1) >  nproc ) CYCLE
+            ELSE
+               IF ( inpfiles(jj)%iproc(ji,1) /= nproc ) CYCLE
+            ENDIF
+
+            llvalprof = .FALSE.
+
+            IF ( inpfiles(jj)%ioqc(ji) > 2 ) CYCLE
+
+            IF ( BTEST(inpfiles(jj)%ioqc(ji),2 ) ) CYCLE
+            IF ( BTEST(inpfiles(jj)%ivqc(ji,1),2) .AND. &
+               & BTEST(inpfiles(jj)%ivqc(ji,2),2) ) CYCLE
+
+            loop_prof : DO ij = 1, inpfiles(jj)%nlev
+
+               IF ( inpfiles(jj)%pdep(ij,ji) >= 6000. ) &
+                  & CYCLE
+
+               IF ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,1),2) .AND. &
+                  & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) ) THEN
+
+                  llvalprof = .TRUE. 
+                  EXIT loop_prof
+
+               ENDIF
+
+               IF ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,2),2) .AND. &
+                  & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) ) THEN
+
+                  llvalprof = .TRUE. 
+                  EXIT loop_prof
+
+               ENDIF
+
+            END DO loop_prof
+
+            ! Set profile information
+
+            IF ( llvalprof ) THEN
+
+               iprof = iprof + 1
+
+               CALL jul2greg( isec,                   &
+                  &           imin,                   &
+                  &           ihou,                   &
+                  &           iday,                   &
+                  &           imon,                   &
+                  &           iyea,                   &
+                  &           inpfiles(jj)%ptim(ji), &
+                  &           irefdate(jj) )
+
+
+               ! Profile time coordinates
+               profdata%nyea(iprof) = iyea
+               profdata%nmon(iprof) = imon
+               profdata%nday(iprof) = iday
+               profdata%nhou(iprof) = ihou
+               profdata%nmin(iprof) = imin
+
+               ! Profile space coordinates
+               profdata%rlam(iprof) = inpfiles(jj)%plam(ji)
+               profdata%rphi(iprof) = inpfiles(jj)%pphi(ji)
+
+               ! Coordinate search parameters
+               profdata%mi  (iprof,1) = inpfiles(jj)%iobsi(ji,1)
+               profdata%mj  (iprof,1) = inpfiles(jj)%iobsj(ji,1)
+               profdata%mi  (iprof,2) = inpfiles(jj)%iobsi(ji,2)
+               profdata%mj  (iprof,2) = inpfiles(jj)%iobsj(ji,2)
+
+               ! Profile WMO number
+               profdata%cwmo(iprof) = inpfiles(jj)%cdwmo(ji)
+
+               ! Instrument type
+               READ( inpfiles(jj)%cdtyp(ji), '(I4)', IOSTAT = ios, ERR = 901 ) itype
+901            IF ( ios /= 0 ) THEN
+                  IF (ioserrcount == 0) CALL ctl_warn ( 'Problem converting an instrument type to integer. Setting type to zero' )
+                  ioserrcount = ioserrcount + 1
+                  itype = 0
+               ENDIF
+
+               profdata%ntyp(iprof) = itype
+
+               ! QC stuff
+
+               profdata%nqc(iprof)     = inpfiles(jj)%ioqc(ji)
+               profdata%nqcf(:,iprof)  = inpfiles(jj)%ioqcf(:,ji)
+               profdata%ipqc(iprof)    = inpfiles(jj)%ipqc(ji)
+               profdata%ipqcf(:,iprof) = inpfiles(jj)%ipqcf(:,ji)
+               profdata%itqc(iprof)    = inpfiles(jj)%itqc(ji)
+               profdata%itqcf(:,iprof) = inpfiles(jj)%itqcf(:,ji)
+               profdata%ivqc(iprof,:)  = inpfiles(jj)%ivqc(ji,:)
+               profdata%ivqcf(:,iprof,:) = inpfiles(jj)%ivqcf(:,ji,:)
+
+               ! Bookkeeping data to match profiles
+               profdata%npidx(iprof) = iprof
+               profdata%npfil(iprof) = iindx(jk)
+
+               ! Observation QC flag (whole profile)
+               profdata%nqc(iprof)  = 0 !TODO
+
+               loop_p : DO ij = 1, inpfiles(jj)%nlev
+
+                  IF ( inpfiles(jj)%pdep(ij,ji) >= 6000. ) &
+                     & CYCLE
+
+                  IF (ldsatt) THEN
+
+                     IF ( ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,1),2) .AND. &
+                        &   .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) .AND. &
+                        &    ldvar1 ) .OR. &
+                        & ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,2),2) .AND. &
+                        &   .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) .AND. &
+                        &   ldvar2 ) ) THEN
+                        ip3dt = ip3dt + 1
+                     ELSE
+                        CYCLE
+                     ENDIF
+
+                  ENDIF
+
+                  IF ( ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,1),2) .AND. &
+                    &   .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) .AND. &
+                    &    ldvar1 ) .OR. ldsatt ) THEN
+
+                     IF (ldsatt) THEN
+
+                        ivar1t = ip3dt
+
+                     ELSE
+
+                        ivar1t = ivar1t + 1
+
+                     ENDIF
+
+                     ! Depth of var1 observation
+                     profdata%var(1)%vdep(ivar1t) = &
+                        &                inpfiles(jj)%pdep(ij,ji)
+
+                     ! Depth of var1 observation QC
+                     profdata%var(1)%idqc(ivar1t) = &
+                        &                inpfiles(jj)%idqc(ij,ji)
+
+                     ! Depth of var1 observation QC flags
+                     profdata%var(1)%idqcf(:,ivar1t) = &
+                        &                inpfiles(jj)%idqcf(:,ij,ji)
+
+                     ! Profile index
+                     profdata%var(1)%nvpidx(ivar1t) = iprof
+
+                     ! Vertical index in original profile
+                     profdata%var(1)%nvlidx(ivar1t) = ij
+
+                     ! Profile var1 value
+                     IF ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,1),2) .AND. &
+                        & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) ) THEN
+                        profdata%var(1)%vobs(ivar1t) = &
+                           &                inpfiles(jj)%pob(ij,ji,1)
+                        IF ( ldmod ) THEN
+                           profdata%var(1)%vmod(ivar1t) = &
+                              &                inpfiles(jj)%padd(ij,ji,1,1)
+                        ENDIF
+                        ! Count number of profile var1 data as function of type
+                        itypvar1( profdata%ntyp(iprof) + 1 ) = &
+                           & itypvar1( profdata%ntyp(iprof) + 1 ) + 1
+                     ELSE
+                        profdata%var(1)%vobs(ivar1t) = fbrmdi
+                     ENDIF
+
+                     ! Profile var1 qc
+                     profdata%var(1)%nvqc(ivar1t) = &
+                        & inpfiles(jj)%ivlqc(ij,ji,1)
+
+                     ! Profile var1 qc flags
+                     profdata%var(1)%nvqcf(:,ivar1t) = &
+                        & inpfiles(jj)%ivlqcf(:,ij,ji,1)
+
+                     ! Profile insitu T value
+                     IF ( TRIM( inpfiles(jj)%cname(1) ) == 'POTM' ) THEN
+                        profdata%var(1)%vext(ivar1t,1) = &
+                           &                inpfiles(jj)%pext(ij,ji,1)
+                     ENDIF
+
+                  ENDIF
+
+                  IF ( ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,2),2) .AND. &
+                     &   .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2)    .AND. &
+                     &   ldvar2 ) .OR. ldsatt ) THEN
+
+                     IF (ldsatt) THEN
+
+                        ivar2t = ip3dt
+
+                     ELSE
+
+                        ivar2t = ivar2t + 1
+
+                     ENDIF
+
+                     ! Depth of var2 observation
+                     profdata%var(2)%vdep(ivar2t) = &
+                        &                inpfiles(jj)%pdep(ij,ji)
+
+                     ! Depth of var2 observation QC
+                     profdata%var(2)%idqc(ivar2t) = &
+                        &                inpfiles(jj)%idqc(ij,ji)
+
+                     ! Depth of var2 observation QC flags
+                     profdata%var(2)%idqcf(:,ivar2t) = &
+                        &                inpfiles(jj)%idqcf(:,ij,ji)
+
+                     ! Profile index
+                     profdata%var(2)%nvpidx(ivar2t) = iprof
+
+                     ! Vertical index in original profile
+                     profdata%var(2)%nvlidx(ivar2t) = ij
+
+                     ! Profile var2 value
+                  IF (  ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,2),2) ) .AND. &
+                    &   ( .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2)    )  ) THEN
+                        profdata%var(2)%vobs(ivar2t) = &
+                           &                inpfiles(jj)%pob(ij,ji,2)
+                        IF ( ldmod ) THEN
+                           profdata%var(2)%vmod(ivar2t) = &
+                              &                inpfiles(jj)%padd(ij,ji,1,2)
+                        ENDIF
+                        ! Count number of profile var2 data as function of type
+                        itypvar2( profdata%ntyp(iprof) + 1 ) = &
+                           & itypvar2( profdata%ntyp(iprof) + 1 ) + 1
+                     ELSE
+                        profdata%var(2)%vobs(ivar2t) = fbrmdi
+                     ENDIF
+
+                     ! Profile var2 qc
+                     profdata%var(2)%nvqc(ivar2t) = &
+                        & inpfiles(jj)%ivlqc(ij,ji,2)
+
+                     ! Profile var2 qc flags
+                     profdata%var(2)%nvqcf(:,ivar2t) = &
+                        & inpfiles(jj)%ivlqcf(:,ij,ji,2)
+
+                  ENDIF
+
+               END DO loop_p
+
+            ENDIF
+
+         ENDIF
+
+      END DO
+
+      !-----------------------------------------------------------------------
+      ! Sum up over processors
+      !-----------------------------------------------------------------------
+
+      CALL obs_mpp_sum_integer ( ivar1t0, ivar1tmpp )
+      CALL obs_mpp_sum_integer ( ivar2t0, ivar2tmpp )
+      CALL obs_mpp_sum_integer ( ip3dt,   ip3dtmpp  )
+
+      CALL obs_mpp_sum_integers( itypvar1, itypvar1mpp, ntyp1770 + 1 )
+      CALL obs_mpp_sum_integers( itypvar2, itypvar2mpp, ntyp1770 + 1 )
+
+      !-----------------------------------------------------------------------
+      ! Output number of observations.
+      !-----------------------------------------------------------------------
+      IF(lwp) THEN
+         WRITE(numout,*) 
+         WRITE(numout,'(A)') ' Profile data'
+         WRITE(numout,'(1X,A)') '------------'
+         WRITE(numout,*) 
+         WRITE(numout,'(1X,A)') 'Profile data, '//TRIM( profdata%cvars(1) )
+         WRITE(numout,'(1X,A)') '------------------------'
+         DO ji = 0, ntyp1770
+            IF ( itypvar1mpp(ji+1) > 0 ) THEN
+               WRITE(numout,'(1X,A3,1X,A48,A3,I8)') ctypshort(ji), &
+                  & cwmonam1770(ji)(1:52),' = ', &
+                  & itypvar1mpp(ji+1)
+            ENDIF
+         END DO
+         WRITE(numout,'(1X,A)') &
+            & '---------------------------------------------------------------'
+         WRITE(numout,'(1X,A55,I8)') &
+            & 'Total profile data for variable '//TRIM( profdata%cvars(1) )// &
+            & '             = ', ivar1tmpp
+         WRITE(numout,'(1X,A)') &
+            & '---------------------------------------------------------------'
+         WRITE(numout,*) 
+         WRITE(numout,'(1X,A)') 'Profile data, '//TRIM( profdata%cvars(2) )
+         WRITE(numout,'(1X,A)') '------------------------'
+         DO ji = 0, ntyp1770
+            IF ( itypvar2mpp(ji+1) > 0 ) THEN
+               WRITE(numout,'(1X,A3,1X,A48,A3,I8)') ctypshort(ji), &
+                  & cwmonam1770(ji)(1:52),' = ', &
+                  & itypvar2mpp(ji+1)
+            ENDIF
+         END DO
+         WRITE(numout,'(1X,A)') &
+            & '---------------------------------------------------------------'
+         WRITE(numout,'(1X,A55,I8)') &
+            & 'Total profile data for variable '//TRIM( profdata%cvars(2) )// &
+            & '             = ', ivar2tmpp
+         WRITE(numout,'(1X,A)') &
+            & '---------------------------------------------------------------'
+         WRITE(numout,*) 
+      ENDIF
+
+      IF (ldsatt) THEN
+         profdata%nvprot(1)    = ip3dt
+         profdata%nvprot(2)    = ip3dt
+         profdata%nvprotmpp(1) = ip3dtmpp
+         profdata%nvprotmpp(2) = ip3dtmpp
+      ELSE
+         profdata%nvprot(1)    = ivar1t
+         profdata%nvprot(2)    = ivar2t
+         profdata%nvprotmpp(1) = ivar1tmpp
+         profdata%nvprotmpp(2) = ivar2tmpp
+      ENDIF
+      profdata%nprof        = iprof
+
+      !-----------------------------------------------------------------------
+      ! Model level search
+      !-----------------------------------------------------------------------
+      IF ( ldvar1 ) THEN
+         CALL obs_level_search( jpk, gdept_1d, &
+            & profdata%nvprot(1), profdata%var(1)%vdep, &
+            & profdata%var(1)%mvk )
+      ENDIF
+      IF ( ldvar2 ) THEN
+         CALL obs_level_search( jpk, gdept_1d, &
+            & profdata%nvprot(2), profdata%var(2)%vdep, &
+            & profdata%var(2)%mvk )
+      ENDIF
+
+      !-----------------------------------------------------------------------
+      ! Set model equivalent to 99999
+      !-----------------------------------------------------------------------
+      IF ( .NOT. ldmod ) THEN
+         DO jvar = 1, kvars
+            profdata%var(jvar)%vmod(:) = fbrmdi
+         END DO
+      ENDIF
+      !-----------------------------------------------------------------------
+      ! Deallocate temporary data
+      !-----------------------------------------------------------------------
+      DEALLOCATE( ifileidx, iprofidx, zdat, clvars )
+
+      !-----------------------------------------------------------------------
+      ! Deallocate input data
+      !-----------------------------------------------------------------------
+      DO jj = 1, inobf
+         CALL dealloc_obfbdata( inpfiles(jj) )
+      END DO
+      DEALLOCATE( inpfiles )
+
+   END SUBROUTINE obs_rea_prof
+
+END MODULE obs_read_prof
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/obs_read_surf.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/obs_read_surf.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/obs_read_surf.F90	(revision 9570)
@@ -0,0 +1,496 @@
+MODULE obs_read_surf
+   !!======================================================================
+   !!                       ***  MODULE obs_read_surf  ***
+   !! Observation diagnostics: Read the surface data from feedback files
+   !!======================================================================
+
+   !!----------------------------------------------------------------------
+   !!   obs_rea_surf : Driver for reading surface data from feedback files
+   !!----------------------------------------------------------------------
+
+   !! * Modules used
+   USE par_kind                 ! Precision variables
+   USE in_out_manager           ! I/O manager
+   USE dom_oce                  ! Ocean space and time domain variables
+   USE obs_mpp                  ! MPP support routines for observation diagnostics
+   USE julian                   ! Julian date routines
+   USE obs_utils                ! Observation operator utility functions
+   USE obs_grid                 ! Grid search
+   USE obs_sort                 ! Sorting observation arrays
+   USE obs_surf_def             ! Surface observation definitions
+   USE obs_types                ! Observation type definitions
+   USE obs_fbm                  ! Feedback routines
+   USE netcdf                   ! NetCDF library
+
+   IMPLICIT NONE
+
+   !! * Routine accessibility
+   PRIVATE
+
+   PUBLIC obs_rea_surf      ! Read the surface observations from the point data
+
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO Consortium (2010)
+   !! $Id: obs_read_surf.F90 4990 2014-12-15 16:42:49Z timgraham $
+   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+
+CONTAINS
+
+   SUBROUTINE obs_rea_surf( surfdata, knumfiles, cdfilenames, &
+      &                     kvars, kextr, kstp, ddobsini, ddobsend, &
+      &                     ldignmis, ldmod, ldnightav )
+      !!---------------------------------------------------------------------
+      !!
+      !!                   *** ROUTINE obs_rea_surf ***
+      !!
+      !! ** Purpose : Read from file the surface data
+      !!
+      !! ** Method  : Read in the data from feedback format files and 
+      !!              put into the NEMO internal surface data structure
+      !!
+      !! ** Action  : 
+      !!
+      !!
+      !! History :  
+      !!      ! :  2009-01 (K. Mogensen) Initial version based on old versions
+      !!      ! :  2015-02 (M. Martin)   Unify the different surface data type reading.
+      !!----------------------------------------------------------------------
+      !! * Modules used
+
+      !! * Arguments
+      TYPE(obs_surf), INTENT(INOUT) :: &
+         & surfdata                     ! Surface data to be read
+      INTEGER, INTENT(IN) :: knumfiles  ! Number of corio format files to read
+      CHARACTER(LEN=128), INTENT(IN) :: &
+         & cdfilenames(knumfiles)       ! File names to read in
+      INTEGER, INTENT(IN) :: kvars      ! Number of variables in surfdata
+      INTEGER, INTENT(IN) :: kextr      ! Number of extra fields for each var
+      INTEGER, INTENT(IN) :: kstp       ! Ocean time-step index
+      LOGICAL, INTENT(IN) :: ldignmis   ! Ignore missing files
+      LOGICAL, INTENT(IN) :: ldmod      ! Initialize model from input data
+      LOGICAL, INTENT(IN) :: ldnightav  ! Observations represent a night-time average
+      REAL(dp), INTENT(IN) :: ddobsini   ! Obs. ini time in YYYYMMDD.HHMMSS
+      REAL(dp), INTENT(IN) :: ddobsend   ! Obs. end time in YYYYMMDD.HHMMSS
+
+      !! * Local declarations
+      CHARACTER(LEN=11), PARAMETER :: cpname='obs_rea_surf'
+      CHARACTER(len=8) :: clrefdate
+      CHARACTER(len=8), DIMENSION(:), ALLOCATABLE :: clvars
+      INTEGER :: ji
+      INTEGER :: jj
+      INTEGER :: jk
+      INTEGER :: iflag
+      INTEGER :: inobf
+      INTEGER :: i_file_id
+      INTEGER :: inowin
+      INTEGER :: iyea
+      INTEGER :: imon
+      INTEGER :: iday
+      INTEGER :: ihou
+      INTEGER :: imin
+      INTEGER :: isec
+      INTEGER :: itype
+      INTEGER :: iobsmpp
+      INTEGER :: iobs
+      INTEGER :: iobstot
+      INTEGER :: ios
+      INTEGER :: ioserrcount
+      INTEGER, PARAMETER :: jpsurfmaxtype = 1024
+      INTEGER, DIMENSION(knumfiles) :: irefdate
+      INTEGER, DIMENSION(jpsurfmaxtype+1) :: &
+         & ityp, &
+         & itypmpp
+      INTEGER, DIMENSION(:), ALLOCATABLE :: &
+         & iobsi,    &
+         & iobsj,    &
+         & iproc,    &
+         & iindx,    &
+         & ifileidx, &
+         & isurfidx
+      REAL(wp), DIMENSION(:), ALLOCATABLE :: &
+         & zphi, &
+         & zlam
+      REAL(wp), DIMENSION(:), ALLOCATABLE :: &
+         & zdat
+      REAL(wp), DIMENSION(knumfiles) :: &
+         & djulini, &
+         & djulend
+      LOGICAL :: llvalprof
+      TYPE(obfbdata), POINTER, DIMENSION(:) :: &
+         & inpfiles
+
+      ! Local initialization
+      iobs = 0
+
+      !-----------------------------------------------------------------------
+      ! Count the number of files needed and allocate the obfbdata type
+      !-----------------------------------------------------------------------
+
+      inobf = knumfiles
+
+      ALLOCATE( inpfiles(inobf) )
+
+      surf_files : DO jj = 1, inobf
+
+         !---------------------------------------------------------------------
+         ! Prints
+         !---------------------------------------------------------------------
+         IF(lwp) THEN
+            WRITE(numout,*)
+            WRITE(numout,*) ' obs_rea_surf : Reading from file = ', &
+               & TRIM( TRIM( cdfilenames(jj) ) )
+            WRITE(numout,*) ' ~~~~~~~~~~~'
+            WRITE(numout,*)
+         ENDIF
+
+         !---------------------------------------------------------------------
+         !  Initialization: Open file and get dimensions only
+         !---------------------------------------------------------------------
+
+         iflag = nf90_open( TRIM( TRIM( cdfilenames(jj) ) ), nf90_nowrite, &
+            &                      i_file_id )
+
+         IF ( iflag /= nf90_noerr ) THEN
+
+            IF ( ldignmis ) THEN
+               inpfiles(jj)%nobs = 0
+               CALL ctl_warn( 'File ' // TRIM( TRIM( cdfilenames(jj) ) ) // &
+                  &           ' not found' )
+            ELSE 
+               CALL ctl_stop( 'File ' // TRIM( TRIM( cdfilenames(jj) ) ) // &
+                  &           ' not found' )
+            ENDIF
+
+         ELSE 
+
+            !------------------------------------------------------------------
+            !  Close the file since it is opened in read_obfbdata
+            !------------------------------------------------------------------
+
+            iflag = nf90_close( i_file_id )
+
+            !------------------------------------------------------------------
+            !  Read the surface file into inpfiles
+            !------------------------------------------------------------------
+            CALL init_obfbdata( inpfiles(jj) )
+            CALL read_obfbdata( TRIM( cdfilenames(jj) ), inpfiles(jj), &
+               &                ldgrid = .TRUE. )
+
+            IF ( ldmod .AND. ( inpfiles(jj)%nadd == 0 ) ) THEN
+               CALL ctl_stop( 'Model not in input data' )
+               RETURN
+            ENDIF
+
+            IF ( jj == 1 ) THEN
+               ALLOCATE( clvars( inpfiles(jj)%nvar ) )
+               DO ji = 1, inpfiles(jj)%nvar
+                 clvars(ji) = inpfiles(jj)%cname(ji)
+               END DO
+            ELSE
+               DO ji = 1, inpfiles(jj)%nvar
+                  IF ( inpfiles(jj)%cname(ji) /= clvars(ji) ) THEN
+                     CALL ctl_stop( 'Feedback file variables not consistent', &
+                        &           ' with previous files for this type' )
+                  ENDIF
+               END DO
+            ENDIF
+
+            IF (lwp) WRITE(numout,*)'Observation file contains ',inpfiles(jj)%nobs,' observations'
+
+            !------------------------------------------------------------------
+            !  Change longitude (-180,180)
+            !------------------------------------------------------------------
+
+            DO ji = 1, inpfiles(jj)%nobs
+
+               IF ( inpfiles(jj)%plam(ji) < -180. ) &
+                  &   inpfiles(jj)%plam(ji) = inpfiles(jj)%plam(ji) + 360.
+
+               IF ( inpfiles(jj)%plam(ji) >  180. ) &
+                  &   inpfiles(jj)%plam(ji) = inpfiles(jj)%plam(ji) - 360.
+
+            END DO
+
+            !------------------------------------------------------------------
+            !  Calculate the date  (change eventually)
+            !------------------------------------------------------------------
+            clrefdate=inpfiles(jj)%cdjuldref(1:8)
+            READ(clrefdate,'(I8)') irefdate(jj)
+
+            CALL ddatetoymdhms( ddobsini, iyea, imon, iday, ihou, imin, isec )
+            CALL greg2jul( isec, imin, ihou, iday, imon, iyea, djulini(jj), &
+               &           krefdate = irefdate(jj) )
+            CALL ddatetoymdhms( ddobsend, iyea, imon, iday, ihou, imin, isec )
+            CALL greg2jul( isec, imin, ihou, iday, imon, iyea, djulend(jj), &
+               &           krefdate = irefdate(jj) )
+
+            IF ( ldnightav ) THEN
+
+               IF ( lwp ) THEN
+                  WRITE(numout,*)'Resetting time of night-time averaged observations', &
+                     &             ' to the end of the day'
+               ENDIF
+
+               DO ji = 1, inpfiles(jj)%nobs
+                  !  for night-time averaged data force the time
+                  !  to be the last time-step of the day, but still within the day.
+                  IF ( inpfiles(jj)%ptim(ji) >= 0. ) THEN
+                     inpfiles(jj)%ptim(ji) = &
+                        & INT(inpfiles(jj)%ptim(ji)) + 0.9999
+                  ELSE
+                     inpfiles(jj)%ptim(ji) = &
+                        & INT(inpfiles(jj)%ptim(ji)) - 0.0001
+                  ENDIF
+               END DO
+            ENDIF
+
+            IF ( inpfiles(jj)%nobs > 0 ) THEN
+               inpfiles(jj)%iproc = -1
+               inpfiles(jj)%iobsi = -1
+               inpfiles(jj)%iobsj = -1
+            ENDIF
+            inowin = 0
+            DO ji = 1, inpfiles(jj)%nobs
+               IF ( ( inpfiles(jj)%ptim(ji) >  djulini(jj) ) .AND. &
+                  & ( inpfiles(jj)%ptim(ji) <= djulend(jj) )       ) THEN
+                  inowin = inowin + 1
+               ENDIF
+            END DO
+            ALLOCATE( zlam(inowin)  )
+            ALLOCATE( zphi(inowin)  )
+            ALLOCATE( iobsi(inowin) )
+            ALLOCATE( iobsj(inowin) )
+            ALLOCATE( iproc(inowin) )
+            inowin = 0
+            DO ji = 1, inpfiles(jj)%nobs
+               IF ( ( inpfiles(jj)%ptim(ji) >  djulini(jj) ) .AND. &
+                  & ( inpfiles(jj)%ptim(ji) <= djulend(jj) )       ) THEN
+                  inowin = inowin + 1
+                  zlam(inowin) = inpfiles(jj)%plam(ji)
+                  zphi(inowin) = inpfiles(jj)%pphi(ji)
+               ENDIF
+            END DO
+
+            CALL obs_grid_search( inowin, zlam, zphi, iobsi, iobsj, iproc, 'T' )
+
+            inowin = 0
+            DO ji = 1, inpfiles(jj)%nobs
+               IF ( ( inpfiles(jj)%ptim(ji) >  djulini(jj) ) .AND. &
+                  & ( inpfiles(jj)%ptim(ji) <= djulend(jj) )       ) THEN
+                  inowin = inowin + 1
+                  inpfiles(jj)%iproc(ji,1) = iproc(inowin)
+                  inpfiles(jj)%iobsi(ji,1) = iobsi(inowin)
+                  inpfiles(jj)%iobsj(ji,1) = iobsj(inowin)
+               ENDIF
+            END DO
+            DEALLOCATE( zlam, zphi, iobsi, iobsj, iproc )
+
+            DO ji = 1, inpfiles(jj)%nobs
+               IF ( ( inpfiles(jj)%ptim(ji) >  djulini(jj) ) .AND. &
+                  & ( inpfiles(jj)%ptim(ji) <= djulend(jj) )       ) THEN
+                  IF ( nproc == 0 ) THEN
+                     IF ( inpfiles(jj)%iproc(ji,1) >  nproc ) CYCLE
+                  ELSE
+                     IF ( inpfiles(jj)%iproc(ji,1) /= nproc ) CYCLE
+                  ENDIF
+                  llvalprof = .FALSE.
+                  IF ( .NOT. BTEST(inpfiles(jj)%ivlqc(1,ji,1),2) ) THEN
+                     iobs = iobs + 1
+                  ENDIF
+               ENDIF
+            END DO
+
+         ENDIF
+
+      END DO surf_files
+
+      !-----------------------------------------------------------------------
+      ! Get the time ordered indices of the input data
+      !-----------------------------------------------------------------------
+
+      !---------------------------------------------------------------------
+      !  Loop over input data files to count total number of profiles
+      !---------------------------------------------------------------------
+      iobstot = 0
+      DO jj = 1, inobf
+         DO ji = 1, inpfiles(jj)%nobs
+            IF ( ( inpfiles(jj)%ptim(ji) >  djulini(jj) ) .AND. &
+               & ( inpfiles(jj)%ptim(ji) <= djulend(jj) )       ) THEN
+               iobstot = iobstot + 1
+            ENDIF
+         END DO
+      END DO
+
+      ALLOCATE( iindx(iobstot), ifileidx(iobstot), &
+         &      isurfidx(iobstot), zdat(iobstot) )
+      jk = 0
+      DO jj = 1, inobf
+         DO ji = 1, inpfiles(jj)%nobs
+            IF ( ( inpfiles(jj)%ptim(ji) >  djulini(jj) ) .AND. &
+               & ( inpfiles(jj)%ptim(ji) <= djulend(jj) )       ) THEN
+               jk = jk + 1
+               ifileidx(jk) = jj
+               isurfidx(jk) = ji
+               zdat(jk)     = inpfiles(jj)%ptim(ji)
+            ENDIF
+         END DO
+      END DO
+      CALL sort_dp_indx( iobstot, &
+         &               zdat,     &
+         &               iindx   )
+
+      CALL obs_surf_alloc( surfdata, iobs, kvars, kextr, kstp, jpi, jpj )
+
+      ! Read obs/positions, QC, all variable and assign to surfdata
+
+      iobs = 0
+
+      surfdata%cvars(:)  = clvars(:)
+
+      ityp   (:) = 0
+      itypmpp(:) = 0
+
+      ioserrcount = 0
+
+      DO jk = 1, iobstot
+
+         jj = ifileidx(iindx(jk))
+         ji = isurfidx(iindx(jk))
+         IF ( ( inpfiles(jj)%ptim(ji) >  djulini(jj) ) .AND.  &
+            & ( inpfiles(jj)%ptim(ji) <= djulend(jj) ) ) THEN
+
+            IF ( nproc == 0 ) THEN
+               IF ( inpfiles(jj)%iproc(ji,1) >  nproc ) CYCLE
+            ELSE
+               IF ( inpfiles(jj)%iproc(ji,1) /= nproc ) CYCLE
+            ENDIF
+
+            ! Set observation information
+
+            IF ( .NOT. BTEST(inpfiles(jj)%ivlqc(1,ji,1),2) ) THEN
+
+               iobs = iobs + 1
+
+               CALL jul2greg( isec,                   &
+                  &           imin,                   &
+                  &           ihou,                   &
+                  &           iday,                   &
+                  &           imon,                   &
+                  &           iyea,                   &
+                  &           inpfiles(jj)%ptim(ji), &
+                  &           irefdate(jj) )
+
+
+               ! Surface time coordinates
+               surfdata%nyea(iobs) = iyea
+               surfdata%nmon(iobs) = imon
+               surfdata%nday(iobs) = iday
+               surfdata%nhou(iobs) = ihou
+               surfdata%nmin(iobs) = imin
+
+               ! Surface space coordinates
+               surfdata%rlam(iobs) = inpfiles(jj)%plam(ji)
+               surfdata%rphi(iobs) = inpfiles(jj)%pphi(ji)
+
+               ! Coordinate search parameters
+               surfdata%mi  (iobs) = inpfiles(jj)%iobsi(ji,1)
+               surfdata%mj  (iobs) = inpfiles(jj)%iobsj(ji,1)
+
+               ! WMO number
+               surfdata%cwmo(iobs) = inpfiles(jj)%cdwmo(ji)
+
+               ! Instrument type
+               READ( inpfiles(jj)%cdtyp(ji), '(I4)', IOSTAT = ios, ERR = 901 ) itype
+901            IF ( ios /= 0 ) THEN
+                  IF (ioserrcount == 0) THEN
+                     CALL ctl_warn ( 'Problem converting an instrument type ', &
+                        &            'to integer. Setting type to zero' )
+                  ENDIF
+                  ioserrcount = ioserrcount + 1
+                  itype = 0
+               ENDIF
+               surfdata%ntyp(iobs) = itype
+               IF ( itype < jpsurfmaxtype + 1 ) THEN
+                  ityp(itype+1) = ityp(itype+1) + 1
+               ELSE
+                  IF(lwp)WRITE(numout,*)'WARNING:Increase jpsurfmaxtype in ',&
+                     &                  cpname
+               ENDIF
+
+               ! Bookkeeping data to match observations
+               surfdata%nsidx(iobs) = iobs
+               surfdata%nsfil(iobs) = iindx(jk)
+
+               ! QC flags
+               surfdata%nqc(iobs) = inpfiles(jj)%ivqc(ji,1)
+
+               ! Observed value
+               surfdata%robs(iobs,1) = inpfiles(jj)%pob(1,ji,1)
+
+
+               ! Model and MDT is set to fbrmdi unless read from file
+               IF ( ldmod ) THEN
+                  surfdata%rmod(iobs,1) = inpfiles(jj)%padd(1,ji,1,1)
+                  IF ( TRIM(surfdata%cvars(1)) == 'SLA' ) THEN
+                     surfdata%rext(iobs,1) = inpfiles(jj)%padd(1,ji,2,1)
+                     surfdata%rext(iobs,2) = inpfiles(jj)%pext(1,ji,1)
+                  ENDIF
+                ELSE
+                  surfdata%rmod(iobs,1) = fbrmdi
+                  IF ( TRIM(surfdata%cvars(1)) == 'SLA' ) surfdata%rext(iobs,:) = fbrmdi
+               ENDIF
+            ENDIF
+         ENDIF
+
+      END DO
+
+      !-----------------------------------------------------------------------
+      ! Sum up over processors
+      !-----------------------------------------------------------------------
+
+      CALL obs_mpp_sum_integer( iobs, iobsmpp )
+      CALL obs_mpp_sum_integers( ityp, itypmpp, jpsurfmaxtype + 1 )
+
+      !-----------------------------------------------------------------------
+      ! Output number of observations.
+      !-----------------------------------------------------------------------
+      IF (lwp) THEN
+
+         WRITE(numout,*)
+         WRITE(numout,'(1X,A)')TRIM( surfdata%cvars(1) )//' data'
+         WRITE(numout,'(1X,A)')'--------------'
+         DO jj = 1,8
+            IF ( itypmpp(jj) > 0 ) THEN
+               WRITE(numout,'(1X,A4,I4,A3,I10)')'Type ', jj,' = ',itypmpp(jj)
+            ENDIF
+         END DO
+         WRITE(numout,'(1X,A)') &
+            & '---------------------------------------------------------------'
+         WRITE(numout,'(1X,A,I8)') &
+            & 'Total data for variable '//TRIM( surfdata%cvars(1) )// &
+            & '           = ', iobsmpp
+         WRITE(numout,'(1X,A)') &
+            & '---------------------------------------------------------------'
+         WRITE(numout,*)
+
+      ENDIF
+
+      !-----------------------------------------------------------------------
+      ! Deallocate temporary data
+      !-----------------------------------------------------------------------
+      DEALLOCATE( ifileidx, isurfidx, zdat, clvars )
+
+      !-----------------------------------------------------------------------
+      ! Deallocate input data
+      !-----------------------------------------------------------------------
+      DO jj = 1, inobf
+         IF ( inpfiles(jj)%lalloc ) THEN
+            CALL dealloc_obfbdata( inpfiles(jj) )
+         ENDIF
+      END DO
+      DEALLOCATE( inpfiles )
+
+   END SUBROUTINE obs_rea_surf
+
+END MODULE obs_read_surf
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/obs_readmdt.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/obs_readmdt.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/obs_readmdt.F90	(revision 9570)
@@ -0,0 +1,258 @@
+MODULE obs_readmdt
+   !!======================================================================
+   !!                       ***  MODULE obs_readmdt  ***
+   !! Observation diagnostics: Read the MDT for SLA data (skeleton for now)
+   !!======================================================================
+   !! History :      ! 2007-03 (K. Mogensen) Initial skeleton version
+   !!                ! 2007-04 (E. Remy) migration and improvement from OPAVAR
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   obs_rea_mdt    : Driver for reading MDT
+   !!   obs_offset_mdt : Remove the offset between the model MDT and the used one
+   !!----------------------------------------------------------------------
+   USE par_kind         ! Precision variables
+   USE par_oce          ! Domain parameters
+   USE in_out_manager   ! I/O manager
+   USE obs_surf_def     ! Surface observation definitions
+   USE obs_inter_sup    ! Interpolation support routines
+   USE obs_inter_h2d    ! 2D interpolation
+   USE obs_utils        ! Various observation tools
+   USE iom_nf90         ! IOM NetCDF
+   USE netcdf           ! NetCDF library
+   USE lib_mpp          ! MPP library
+   USE dom_oce, ONLY : &                  ! Domain variables
+      &                    tmask, tmask_i, e1e2t, gphit, glamt
+   USE obs_const, ONLY :   obfillflt      ! Fillvalue
+   USE oce      , ONLY :   sshn           ! Model variables
+
+   IMPLICIT NONE
+   PRIVATE
+   
+   PUBLIC   obs_rea_mdt     ! called by dia_obs_init
+   PUBLIC   obs_offset_mdt  ! called by obs_rea_mdt
+
+   INTEGER , PUBLIC :: nn_msshc    = 1         ! MDT correction scheme
+   REAL(wp), PUBLIC :: rn_mdtcorr   = 1.61_wp  ! User specified MDT correction
+   REAL(wp), PUBLIC :: rn_mdtcutoff = 65.0_wp  ! MDT cutoff for computed correction
+
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO Consortium (2010)
+   !! $Id$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE obs_rea_mdt( sladata, k2dint )
+      !!---------------------------------------------------------------------
+      !!
+      !!                   *** ROUTINE obs_rea_mdt ***
+      !!
+      !! ** Purpose : Read from file the MDT data (skeleton)
+      !!
+      !! ** Method  : 
+      !!
+      !! ** Action  : 
+      !!----------------------------------------------------------------------
+      USE iom
+      !
+      TYPE(obs_surf), INTENT(inout) ::   sladata   ! SLA data
+      INTEGER       , INTENT(in)    ::   k2dint    ! ?
+      !
+      CHARACTER(LEN=12), PARAMETER ::   cpname  = 'obs_rea_mdt'
+      CHARACTER(LEN=20), PARAMETER ::   mdtname = 'slaReferenceLevel.nc'
+
+      INTEGER ::   jobs                ! Obs loop variable
+      INTEGER ::   jpimdt, jpjmdt      ! Number of grid point in lat/lon for the MDT
+      INTEGER ::   iico, ijco          ! Grid point indicies
+      INTEGER ::   i_nx_id, i_ny_id, i_file_id, i_var_id, i_stat
+      INTEGER ::   nummdt
+      !
+      REAL(wp), DIMENSION(1)     ::   zext, zobsmask
+      REAL(wp), DIMENSION(2,2,1) ::   zweig
+      !
+      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::   zmask, zmdtl, zglam, zgphi
+      INTEGER , DIMENSION(:,:,:), ALLOCATABLE ::   igrdi, igrdj
+      !
+      REAL(wp), DIMENSION(jpi,jpj) ::  z_mdt, mdtmask
+         
+      REAL(wp) :: zlam, zphi, zfill, zinfill    ! local scalar
+      !!----------------------------------------------------------------------
+
+      IF(lwp)WRITE(numout,*) 
+      IF(lwp)WRITE(numout,*) ' obs_rea_mdt : Read MDT for referencing altimeter anomalies'
+      IF(lwp)WRITE(numout,*) ' ------------- '
+      CALL FLUSH(numout)
+
+      CALL iom_open( mdtname, nummdt )       ! Open the file
+      !                                      ! Get the MDT data
+      CALL iom_get ( nummdt, jpdom_data, 'sossheig', z_mdt(:,:), 1 )
+      CALL iom_close(nummdt)                 ! Close the file
+      
+      ! Read in the fill value
+      zinfill = 0.0
+      i_stat = nf90_open( mdtname, nf90_nowrite, nummdt )
+      i_stat = nf90_inq_varid( nummdt, 'sossheig', i_var_id )
+      i_stat = nf90_get_att( nummdt, i_var_id, "_FillValue",zinfill)
+      zfill = zinfill
+      i_stat = nf90_close( nummdt )
+
+      ! setup mask based on tmask and MDT mask
+      ! set mask to 0 where the MDT is set to fillvalue
+      WHERE(z_mdt(:,:) /= zfill)   ;   mdtmask(:,:) = tmask(:,:,1)
+      ELSE WHERE                   ;   mdtmask(:,:) = 0
+      END WHERE
+
+      ! Remove the offset between the MDT used with the sla and the model MDT
+      IF( nn_msshc == 1 .OR. nn_msshc == 2 ) &
+         & CALL obs_offset_mdt( jpi, jpj, z_mdt, zfill )
+
+      ! Intepolate the MDT already on the model grid at the observation point
+  
+      ALLOCATE( &
+         & igrdi(2,2,sladata%nsurf), &
+         & igrdj(2,2,sladata%nsurf), &
+         & zglam(2,2,sladata%nsurf), &
+         & zgphi(2,2,sladata%nsurf), &
+         & zmask(2,2,sladata%nsurf), &
+         & zmdtl(2,2,sladata%nsurf)  &
+         & )
+         
+      DO jobs = 1, sladata%nsurf
+
+         igrdi(1,1,jobs) = sladata%mi(jobs)-1
+         igrdj(1,1,jobs) = sladata%mj(jobs)-1
+         igrdi(1,2,jobs) = sladata%mi(jobs)-1
+         igrdj(1,2,jobs) = sladata%mj(jobs)
+         igrdi(2,1,jobs) = sladata%mi(jobs)
+         igrdj(2,1,jobs) = sladata%mj(jobs)-1
+         igrdi(2,2,jobs) = sladata%mi(jobs)
+         igrdj(2,2,jobs) = sladata%mj(jobs)
+
+      END DO
+
+      CALL obs_int_comm_2d( 2, 2, sladata%nsurf, jpi, jpj, igrdi, igrdj, glamt  , zglam )
+      CALL obs_int_comm_2d( 2, 2, sladata%nsurf, jpi, jpj, igrdi, igrdj, gphit  , zgphi )
+      CALL obs_int_comm_2d( 2, 2, sladata%nsurf, jpi, jpj, igrdi, igrdj, mdtmask, zmask )
+      CALL obs_int_comm_2d( 2, 2, sladata%nsurf, jpi, jpj, igrdi, igrdj, z_mdt  , zmdtl )
+
+      DO jobs = 1, sladata%nsurf
+            
+         zlam = sladata%rlam(jobs)
+         zphi = sladata%rphi(jobs)
+
+         CALL obs_int_h2d_init( 1, 1, k2dint, zlam, zphi,         &
+            &                   zglam(:,:,jobs), zgphi(:,:,jobs), &
+            &                   zmask(:,:,jobs), zweig, zobsmask )
+            
+         CALL obs_int_h2d( 1, 1, zweig, zmdtl(:,:,jobs),  zext )
+ 
+         sladata%rext(jobs,2) = zext(1)
+
+! mark any masked data with a QC flag
+         IF( zobsmask(1) == 0 )   sladata%nqc(jobs) = IBSET(sladata%nqc(jobs),15)
+
+         END DO
+         
+      DEALLOCATE( &
+         & igrdi, &
+         & igrdj, &
+         & zglam, &
+         & zgphi, &
+         & zmask, &
+         & zmdtl  &
+         & )
+
+      IF(lwp)WRITE(numout,*) ' ------------- '
+      !
+   END SUBROUTINE obs_rea_mdt
+
+
+   SUBROUTINE obs_offset_mdt( kpi, kpj, mdt, zfill )
+      !!---------------------------------------------------------------------
+      !!
+      !!                   *** ROUTINE obs_offset_mdt ***
+      !!
+      !! ** Purpose : Compute a correction term for the MDT on the model grid
+      !!             !!!!! IF it is on the model grid
+      !!
+      !! ** Method  : Compute the mean difference between the model and the 
+      !!              used MDT and remove the offset. 
+      !!
+      !! ** Action  : 
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT(IN) ::  kpi, kpj
+      REAL(wp), DIMENSION(kpi,kpj), INTENT(INOUT) ::   mdt     ! MDT used on the model grid
+      REAL(wp)                    , INTENT(IN   ) ::   zfill 
+      ! 
+      INTEGER  :: ji, jj
+      REAL(wp) :: zdxdy, zarea, zeta1, zeta2, zcorr_mdt, zcorr_bcketa, zcorr     ! local scalar
+      REAL(wp), DIMENSION(jpi,jpj) :: zpromsk
+      CHARACTER(LEN=14), PARAMETER ::   cpname = 'obs_offset_mdt'
+      !!----------------------------------------------------------------------
+
+      !  Initialize the local mask, for domain projection 
+      !  Also exclude mdt points which are set to missing data
+
+      DO ji = 1, jpi
+        DO jj = 1, jpj
+           zpromsk(ji,jj) = tmask_i(ji,jj)
+           IF (    ( gphit(ji,jj) .GT.  rn_mdtcutoff ) &
+              &.OR.( gphit(ji,jj) .LT. -rn_mdtcutoff ) &
+              &.OR.( mdt(ji,jj) .EQ. zfill ) ) &
+              &        zpromsk(ji,jj) = 0.0
+        END DO
+      END DO 
+
+      ! Compute MSSH mean over [0,360] x [-rn_mdtcutoff,rn_mdtcutoff]
+
+      zarea = 0.0
+      zeta1 = 0.0
+      zeta2 = 0.0
+
+      DO jj = 1, jpj
+         DO ji = 1, jpi
+          zdxdy = e1e2t(ji,jj) * zpromsk(ji,jj)
+          zarea = zarea + zdxdy
+          zeta1 = zeta1 + mdt(ji,jj) * zdxdy
+          zeta2 = zeta2 + sshn (ji,jj) * zdxdy
+        END DO      
+      END DO
+
+      IF( lk_mpp)   CALL mpp_sum( zeta1 )
+      IF( lk_mpp)   CALL mpp_sum( zeta2 )
+      IF( lk_mpp)   CALL mpp_sum( zarea )
+      
+      zcorr_mdt    = zeta1 / zarea
+      zcorr_bcketa = zeta2 / zarea
+
+      !  Define correction term
+
+      zcorr = zcorr_mdt - zcorr_bcketa
+
+      !  Correct spatial mean of the MSSH
+
+      IF( nn_msshc == 1 )   mdt(:,:) = mdt(:,:) - zcorr  
+
+      ! User defined value : 1.6 m for the Rio MDT compared to ORCA2 MDT
+
+      IF( nn_msshc == 2 )   mdt(:,:) = mdt(:,:) - rn_mdtcorr
+
+      IF(lwp) THEN
+         WRITE(numout,*)
+         WRITE(numout,*) ' obs_readmdt : rn_mdtcutoff     = ', rn_mdtcutoff
+         WRITE(numout,*) ' -----------   zcorr_mdt     = ', zcorr_mdt
+         WRITE(numout,*) '               zcorr_bcketa  = ', zcorr_bcketa
+         WRITE(numout,*) '               zcorr         = ', zcorr
+         WRITE(numout,*) '               nn_msshc        = ', nn_msshc
+      ENDIF
+
+      IF ( nn_msshc == 0 ) WRITE(numout,*) '           MSSH correction is not applied'
+      IF ( nn_msshc == 1 ) WRITE(numout,*) '           MSSH correction is applied'
+      IF ( nn_msshc == 2 ) WRITE(numout,*) '           User defined MSSH correction' 
+
+      !
+   END SUBROUTINE obs_offset_mdt
+ 
+   !!======================================================================
+END MODULE obs_readmdt
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/obs_rot_vel.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/obs_rot_vel.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/obs_rot_vel.F90	(revision 9570)
@@ -0,0 +1,228 @@
+MODULE obs_rot_vel
+   !!======================================================================
+   !!                       ***  MODULE obs_rot_vel  ***
+   !! Observation diagnostics: Read the velocity profile observations
+   !!======================================================================
+
+   !!----------------------------------------------------------------------
+   !!   obs_rotvel : Rotate velocity data into N-S,E-W directorions
+   !!----------------------------------------------------------------------
+   !! * Modules used   
+   USE par_kind                 ! Precision variables
+   USE par_oce                  ! Ocean parameters
+   USE in_out_manager           ! I/O manager
+   USE dom_oce                  ! Ocean space and time domain variables
+   USE obs_grid                 ! Grid search
+   USE obs_utils                ! For error handling
+   USE obs_profiles_def         ! Profile definitions
+   USE obs_inter_h2d            ! Horizontal interpolation
+   USE obs_inter_sup            ! MPP support routines for interpolation
+   USE geo2ocean                ! Rotation of vectors
+   USE obs_fbm                  ! Feedback definitions
+
+   IMPLICIT NONE
+
+   !! * Routine accessibility
+   PRIVATE
+
+   PUBLIC obs_rotvel            ! Rotate the observations
+
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO Consortium (2010)
+   !! $Id$
+   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+
+CONTAINS
+
+   SUBROUTINE obs_rotvel( profdata, k2dint, pu, pv )
+      !!---------------------------------------------------------------------
+      !!
+      !!                   *** ROUTINE obs_rea_pro_dri ***
+      !!
+      !! ** Purpose : Rotate velocity data into N-S,E-W directorions
+      !!
+      !! ** Method  : Interpolation of geo2ocean coefficients on U,V grid
+      !!              to observation point followed by a similar computations
+      !!              as in geo2ocean.
+      !!
+      !! ** Action  : Review if there is a better way to do this.
+      !!
+      !! References : 
+      !!
+      !! History :  
+      !!      ! :  2009-02 (K. Mogensen) : New routine
+      !!----------------------------------------------------------------------
+      !! * Modules used
+      !! * Arguments
+      TYPE(obs_prof), INTENT(INOUT) :: profdata    ! Profile data to be read
+      INTEGER, INTENT(IN) :: k2dint     ! Horizontal interpolation methed
+      REAL(wp), DIMENSION(*) :: &
+         & pu, &
+         & pv
+      !! * Local declarations
+      REAL(wp), DIMENSION(2,2,1) :: zweig
+      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: &
+         & zmasku, &
+         & zmaskv, &
+         & zcoslu, &
+         & zsinlu, &
+         & zcoslv, &
+         & zsinlv, &
+         & zglamu, &
+         & zgphiu, &
+         & zglamv, &
+         & zgphiv
+      REAL(wp), DIMENSION(1) :: &
+         & zsinu, &
+         & zcosu, &
+         & zsinv, &
+         & zcosv
+      REAL(wp) :: zsin
+      REAL(wp) :: zcos
+      REAL(wp), DIMENSION(1) :: zobsmask
+      REAL(wp), DIMENSION(jpi,jpj) :: zsingu,zcosgu,zsingv,zcosgv
+      INTEGER, DIMENSION(:,:,:), ALLOCATABLE :: &
+         & igrdiu, &
+         & igrdju, &
+         & igrdiv, &
+         & igrdjv
+      INTEGER :: ji
+      INTEGER :: jk
+
+
+      !-----------------------------------------------------------------------
+      ! Allocate data for message parsing and interpolation
+      !-----------------------------------------------------------------------
+
+      ALLOCATE( &
+         & igrdiu(2,2,profdata%nprof), &
+         & igrdju(2,2,profdata%nprof), &
+         & zglamu(2,2,profdata%nprof), &
+         & zgphiu(2,2,profdata%nprof), &
+         & zmasku(2,2,profdata%nprof), &
+         & zcoslu(2,2,profdata%nprof), &
+         & zsinlu(2,2,profdata%nprof), &
+         & igrdiv(2,2,profdata%nprof), &
+         & igrdjv(2,2,profdata%nprof), &
+         & zglamv(2,2,profdata%nprof), &
+         & zgphiv(2,2,profdata%nprof), &
+         & zmaskv(2,2,profdata%nprof), &
+         & zcoslv(2,2,profdata%nprof), &
+         & zsinlv(2,2,profdata%nprof)  &
+         & )
+
+      !-----------------------------------------------------------------------
+      ! Receive the angles on the U and V grids.
+      !-----------------------------------------------------------------------
+
+      CALL obs_rot( zsingu, zcosgu, zsingv, zcosgv )
+
+      DO ji = 1, profdata%nprof
+         igrdiu(1,1,ji) = profdata%mi(ji,1)-1
+         igrdju(1,1,ji) = profdata%mj(ji,1)-1
+         igrdiu(1,2,ji) = profdata%mi(ji,1)-1
+         igrdju(1,2,ji) = profdata%mj(ji,1)
+         igrdiu(2,1,ji) = profdata%mi(ji,1)
+         igrdju(2,1,ji) = profdata%mj(ji,1)-1
+         igrdiu(2,2,ji) = profdata%mi(ji,1)
+         igrdju(2,2,ji) = profdata%mj(ji,1)
+         igrdiv(1,1,ji) = profdata%mi(ji,2)-1
+         igrdjv(1,1,ji) = profdata%mj(ji,2)-1
+         igrdiv(1,2,ji) = profdata%mi(ji,2)-1
+         igrdjv(1,2,ji) = profdata%mj(ji,2)
+         igrdiv(2,1,ji) = profdata%mi(ji,2)
+         igrdjv(2,1,ji) = profdata%mj(ji,2)-1
+         igrdiv(2,2,ji) = profdata%mi(ji,2)
+         igrdjv(2,2,ji) = profdata%mj(ji,2)
+      END DO
+
+      CALL obs_int_comm_2d( 2, 2, profdata%nprof, jpi, jpj, igrdiu, igrdju, &
+         &                  glamu, zglamu )
+      CALL obs_int_comm_2d( 2, 2, profdata%nprof, jpi, jpj, igrdiu, igrdju, &
+         &                  gphiu, zgphiu )
+      CALL obs_int_comm_2d( 2, 2, profdata%nprof, jpi, jpj, igrdiu, igrdju, &
+         &                  umask(:,:,1), zmasku )
+      CALL obs_int_comm_2d( 2, 2, profdata%nprof, jpi, jpj, igrdiu, igrdju, &
+         &                  zsingu, zsinlu )
+      CALL obs_int_comm_2d( 2, 2, profdata%nprof, jpi, jpj, igrdiu, igrdju, &
+         &                  zcosgu, zcoslu )
+      CALL obs_int_comm_2d( 2, 2, profdata%nprof, jpi, jpj, igrdiv, igrdjv, &
+         &                  glamv, zglamv )
+      CALL obs_int_comm_2d( 2, 2, profdata%nprof, jpi, jpj, igrdiv, igrdjv, &
+         &                  gphiv, zgphiv )
+      CALL obs_int_comm_2d( 2, 2, profdata%nprof, jpi, jpj, igrdiv, igrdjv, &
+         &                  vmask(:,:,1), zmaskv )
+      CALL obs_int_comm_2d( 2, 2, profdata%nprof, jpi, jpj, igrdiv, igrdjv, &
+         &                  zsingv, zsinlv )
+      CALL obs_int_comm_2d( 2, 2, profdata%nprof, jpi, jpj, igrdiv, igrdjv, &
+         &                  zcosgv, zcoslv )
+
+      DO ji = 1, profdata%nprof
+            
+         CALL obs_int_h2d_init( 1, 1, k2dint, &
+            &                   profdata%rlam(ji), profdata%rphi(ji), &
+            &                   zglamu(:,:,ji), zgphiu(:,:,ji), &
+            &                   zmasku(:,:,ji), zweig, zobsmask )
+         
+         CALL obs_int_h2d( 1, 1, zweig, zsinlu(:,:,ji),  zsinu )
+
+         CALL obs_int_h2d( 1, 1, zweig, zcoslu(:,:,ji),  zcosu )
+
+         CALL obs_int_h2d_init( 1, 1, k2dint, &
+            &                   profdata%rlam(ji), profdata%rphi(ji), &
+            &                   zglamv(:,:,ji), zgphiv(:,:,ji), &
+            &                   zmaskv(:,:,ji), zweig, zobsmask )
+         
+         CALL obs_int_h2d( 1, 1, zweig, zsinlv(:,:,ji),  zsinv )
+
+         CALL obs_int_h2d( 1, 1, zweig, zcoslv(:,:,ji),  zcosv )
+
+         ! Assume that the angle at observation point is the 
+         ! mean of u and v cosines/sines
+
+         zcos = 0.5_wp * ( zcosu(1) + zcosv(1) )
+         zsin = 0.5_wp * ( zsinu(1) + zsinv(1) )
+         
+         IF ( ( profdata%npvsta(ji,1) /= profdata%npvsta(ji,2) ) .OR. &
+            & ( profdata%npvend(ji,1) /= profdata%npvend(ji,2) ) ) THEN
+            CALL fatal_error( 'Different number of U and V observations '// &
+               'in a profile in obs_rotvel', __LINE__ )
+         ENDIF
+
+         DO jk = profdata%npvsta(ji,1), profdata%npvend(ji,1)
+            IF ( ( profdata%var(1)%vmod(jk) /= fbrmdi ) .AND. &
+               & ( profdata%var(2)%vmod(jk) /= fbrmdi ) ) THEN
+               pu(jk) = profdata%var(1)%vmod(jk) * zcos - &
+                  &     profdata%var(2)%vmod(jk) * zsin
+               pv(jk) = profdata%var(2)%vmod(jk) * zcos + &
+                  &     profdata%var(1)%vmod(jk) * zsin
+            ELSE
+               pu(jk) = fbrmdi
+               pv(jk) = fbrmdi
+            ENDIF
+
+         END DO
+
+      END DO
+      
+      DEALLOCATE( &
+         & igrdiu, &
+         & igrdju, &
+         & zglamu, &
+         & zgphiu, &
+         & zmasku, &
+         & zcoslu, &
+         & zsinlu, &
+         & igrdiv, &
+         & igrdjv, &
+         & zglamv, &
+         & zgphiv, &
+         & zmaskv, &
+         & zcoslv, &
+         & zsinlv  &
+         & )
+
+   END SUBROUTINE obs_rotvel
+
+END MODULE obs_rot_vel
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/obs_sort.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/obs_sort.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/obs_sort.F90	(revision 9570)
@@ -0,0 +1,147 @@
+MODULE obs_sort
+   !!=====================================================================
+   !!                       ***  MODULE obs_sort  ***
+   !! Observation diagnostics: Various tools for sorting etc.
+   !!=====================================================================
+
+   !!----------------------------------------------------------------------
+   !!   sort_dp_indx : Get indicies for ascending order for a double prec. array
+   !!   index_sort   : Get indicies for ascending order for a double prec. array
+   !!---------------------------------------------------------------------
+   !! * Modules used
+   USE par_kind, ONLY : & ! Precision variables
+      & dp
+  
+   IMPLICIT NONE
+
+   !! * Routine accessibility
+   PRIVATE index_sort    ! Get indicies for ascending order for a double prec. array
+   
+   PUBLIC sort_dp_indx   ! Get indicies for ascending order for a double prec. array
+  
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO Consortium (2010)
+   !! $Id$
+   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+
+CONTAINS
+
+   SUBROUTINE sort_dp_indx( kvals, pvals, kindx )
+      !!----------------------------------------------------------------------
+      !!                    ***  ROUTINE sort_dp_indx  ***
+      !!          
+      !! ** Purpose : Get indicies for ascending order for a double precision array
+      !!
+      !! ** Method  : Call index_sort routine
+      !!
+      !! ** Action  : 
+      !!
+      !! History :
+      !!        !  06-05  (K. Mogensen)  Original code
+      !!        !  06-10  (A. Weaver) Cleaning
+      !!----------------------------------------------------------------------
+
+      !! * Arguments
+      INTEGER, INTENT(IN) :: kvals     ! Number of elements to be sorted
+      REAL(KIND=dp), DIMENSION(kvals), INTENT(IN) :: &
+         & pvals            ! Array to be sorted
+      INTEGER, DIMENSION(kvals), INTENT(OUT) ::  &
+         & kindx            ! Indices for ordering of array
+
+      !! * Local declarations
+
+      !-----------------------------------------------------------------------
+      ! Call qsort routine
+      !-----------------------------------------------------------------------
+      IF (kvals>=1) THEN
+
+         CALL index_sort( pvals, kindx, kvals )
+
+      ENDIF
+
+   END SUBROUTINE sort_dp_indx
+
+   SUBROUTINE index_sort( pval, kindx, kvals )
+      !!----------------------------------------------------------------------
+      !!                    ***  ROUTINE index_sort  ***
+      !!          
+      !! ** Purpose : Get indicies for ascending order for a double precision array
+      !!
+      !! ** Method  : Heapsort
+      !!
+      !! ** Action  : 
+      !!
+      !! References : http://en.wikipedia.org/wiki/Heapsort
+      !!
+      !! History :
+      !!        !  06-05  (K. Mogensen)  Original code
+      !!        !  06-10  (A. Weaver) Cleaning
+      !!----------------------------------------------------------------------
+
+      !! * Arguments
+      INTEGER, INTENT(IN) :: kvals         ! Number of values
+      REAL(KIND=dp), DIMENSION(kvals), INTENT(IN) :: &
+         & pval                            ! Array to be sorted
+      INTEGER, DIMENSION(kvals), INTENT(INOUT) :: &
+         & kindx                           ! Indicies for ordering
+
+      !! * Local declarations
+      INTEGER :: ji
+      INTEGER :: jj
+      INTEGER :: jt
+      INTEGER :: jn
+      INTEGER :: jparent
+      INTEGER :: jchild
+
+      DO ji = 1, kvals
+         kindx(ji) = ji
+      END DO
+      
+      ji = kvals/2 + 1
+      jn = kvals
+
+      main_loop : DO
+
+         IF ( ji > 1 ) THEN
+            ji = ji-1
+            jt = kindx(ji)
+         ELSE
+            jt = kindx(jn)
+            kindx(jn) = kindx(1)
+            jn = jn-1
+            IF ( jn <= 1 ) THEN
+               kindx(1) = jt
+               EXIT main_loop
+            ENDIF
+         ENDIF
+
+         jparent = ji
+         jchild =  2 * ji
+
+         inner_loop : DO
+
+            IF ( jchild > jn ) EXIT inner_loop
+            IF ( jchild < jn ) THEN
+               IF ( pval(kindx(jchild)) < pval(kindx(jchild+1)) ) THEN
+                 jchild = jchild+1
+               ENDIF
+            ENDIF
+            IF  ( pval(jt) < pval(kindx(jchild))) THEN
+               kindx(jparent) = kindx(jchild)
+               jparent = jchild
+               jchild  = jchild*2
+            ELSE 
+               jchild = jn + 1 
+            ENDIF
+
+         END DO inner_loop
+
+         kindx(jparent) = jt
+
+      END DO main_loop
+      
+   END SUBROUTINE index_sort
+
+END MODULE obs_sort
+ 
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/obs_sstbias.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/obs_sstbias.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/obs_sstbias.F90	(revision 9570)
@@ -0,0 +1,243 @@
+MODULE obs_sstbias
+   !!======================================================================
+   !!                       ***  MODULE obs_sstbias  ***
+   !! Observation diagnostics: Read the bias for SST data
+   !!======================================================================
+   !!----------------------------------------------------------------------
+   !!   obs_app_sstbias : Driver for reading and applying the SST bias
+   !!----------------------------------------------------------------------
+   !! * Modules used   
+   USE par_kind, ONLY : &       ! Precision variables
+      & wp, &
+      & dp, &
+      & sp
+   USE par_oce, ONLY : &        ! Domain parameters
+      & jpi, &
+      & jpj, &
+      & jpim1
+   USE in_out_manager, ONLY : & ! I/O manager
+      & lwp,    &
+      & numout 
+   USE obs_surf_def             ! Surface observation definitions
+   USE dom_oce, ONLY : &        ! Domain variables
+      & tmask, &
+      & tmask_i, &
+      & e1t,   &
+      & e2t,   &
+      & gphit, &
+      & glamt
+   USE oce, ONLY : &           ! Model variables
+      & sshn
+   USE obs_inter_h2d
+   USE obs_utils               ! Various observation tools
+   USE obs_inter_sup
+   IMPLICIT NONE
+   !! * Routine accessibility
+   PRIVATE
+   PUBLIC obs_app_sstbias     ! Read the altimeter bias
+CONTAINS
+   SUBROUTINE obs_app_sstbias( sstdata, k2dint, knumtypes, &
+                               cl_bias_files )
+      !!---------------------------------------------------------------------
+      !!
+      !!                   *** ROUTINE obs_app_sstbias ***
+      !!
+      !! ** Purpose : Read SST bias data from files and apply correction to
+      !!             observations
+      !!
+      !! ** Method  :
+      !!
+      !! ** Action  :
+      !!
+      !! References :
+      !!
+      !! History : 
+      !!      ! :  2014-08 (J. While) Bias correction code for SST obs,
+      !!      !                      based on obs_rea_altbias
+      !!----------------------------------------------------------------------
+      !! * Modules used
+      USE iom
+      USE netcdf
+      !! * Arguments
+
+      TYPE(obs_surf), INTENT(INOUT) :: sstdata       ! SST data
+      INTEGER, INTENT(IN) :: k2dint
+      INTEGER, INTENT(IN) :: knumtypes !number of bias types to read in
+      CHARACTER(LEN=128), DIMENSION(knumtypes), INTENT(IN) :: &
+                          cl_bias_files !List of files to read
+      !! * Local declarations
+      INTEGER :: jobs         ! Obs loop variable
+      INTEGER :: jpisstbias   ! Number of grid point in latitude for the bias
+      INTEGER :: jpjsstbias   ! Number of grid point in longitude for the bias
+      INTEGER :: iico         ! Grid point indices
+      INTEGER :: ijco
+      INTEGER :: jt
+      INTEGER :: i_nx_id      ! Index to read the NetCDF file
+      INTEGER :: i_ny_id      !
+      INTEGER :: i_file_id    !
+      INTEGER :: i_var_id
+      INTEGER, DIMENSION(knumtypes) :: &
+         & ibiastypes             ! Array of the bias types in each file
+      REAL(wp), DIMENSION(jpi,jpj,knumtypes) :: & 
+         & z_sstbias              ! Array to store the SST bias values
+      REAL(wp), DIMENSION(jpi,jpj) :: & 
+         & z_sstbias_2d           ! Array to store the SST bias values   
+      REAL(wp), DIMENSION(1) :: &
+         & zext, &
+         & zobsmask
+      REAL(wp), DIMENSION(2,2,1) :: &
+         & zweig
+      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: &
+         & zmask, &
+         & zglam, &
+         & zgphi
+      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: &
+         & zmask_tmp, &
+         & zglam_tmp, &
+         & zgphi_tmp   
+      REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) ::  zbias   
+      REAL(wp) :: zlam
+      REAL(wp) :: zphi
+      INTEGER, DIMENSION(:,:,:), ALLOCATABLE :: &
+         & igrdi, &
+         & igrdj
+      INTEGER, DIMENSION(:,:,:), ALLOCATABLE :: &
+         & igrdi_tmp, &
+         & igrdj_tmp   
+      INTEGER :: numsstbias
+      INTEGER(KIND=NF90_INT) :: ifile_source
+     
+      INTEGER :: incfile
+      INTEGER :: jtype
+      INTEGER :: iret 
+      INTEGER :: inumtype
+      IF(lwp)WRITE(numout,*) 
+      IF(lwp)WRITE(numout,*) 'obs_rea_sstbias : '
+      IF(lwp)WRITE(numout,*) '----------------- '
+      IF(lwp)WRITE(numout,*) 'Read SST bias '
+      ! Open and read the files
+      z_sstbias(:,:,:)=0.0_wp
+      DO jtype = 1, knumtypes
+     
+         numsstbias=0
+         IF(lwp)WRITE(numout,*) 'Opening ',cl_bias_files(jtype)
+         CALL iom_open( cl_bias_files(jtype), numsstbias, ldstop=.FALSE. )       
+         IF (numsstbias > 0) THEN
+     
+            !Read the bias type from the file
+            !No IOM get attribute command at time of writing, 
+            !so have to use NETCDF
+            !routines directly - should be upgraded in the future
+            iret=NF90_OPEN(TRIM(cl_bias_files(jtype)), NF90_NOWRITE, incfile)
+            iret=NF90_GET_ATT( incfile, NF90_GLOBAL, "SST_source", &
+                              ifile_source )
+            ibiastypes(jtype) = ifile_source                 
+            iret=NF90_CLOSE(incfile)       
+           
+            IF ( iret /= 0  ) CALL ctl_stop( &
+               'obs_rea_sstbias : Cannot read bias type from file '// &
+               cl_bias_files(jtype) )
+            ! Get the SST bias data
+            CALL iom_get( numsstbias, jpdom_data, 'tn', z_sstbias_2d(:,:), 1 )
+            z_sstbias(:,:,jtype) = z_sstbias_2d(:,:)       
+            ! Close the file
+            CALL iom_close(numsstbias)       
+         ELSE
+            CALL ctl_stop('obs_read_sstbias: File '// & 
+                           TRIM( cl_bias_files(jtype) )//' Not found')
+         ENDIF
+      END DO
+           
+      ! Interpolate the bias already on the model grid at the observation point
+      ALLOCATE( &
+         & igrdi(2,2,sstdata%nsurf), &
+         & igrdj(2,2,sstdata%nsurf), &
+         & zglam(2,2,sstdata%nsurf), &
+         & zgphi(2,2,sstdata%nsurf), &
+         & zmask(2,2,sstdata%nsurf)  )
+       
+      DO jobs = 1, sstdata%nsurf 
+         igrdi(1,1,jobs) = sstdata%mi(jobs)-1
+         igrdj(1,1,jobs) = sstdata%mj(jobs)-1
+         igrdi(1,2,jobs) = sstdata%mi(jobs)-1
+         igrdj(1,2,jobs) = sstdata%mj(jobs)
+         igrdi(2,1,jobs) = sstdata%mi(jobs)
+         igrdj(2,1,jobs) = sstdata%mj(jobs)-1
+         igrdi(2,2,jobs) = sstdata%mi(jobs)
+         igrdj(2,2,jobs) = sstdata%mj(jobs)
+      END DO
+      CALL obs_int_comm_2d( 2, 2, sstdata%nsurf, jpi, jpj, &
+         &                  igrdi, igrdj, glamt, zglam )
+      CALL obs_int_comm_2d( 2, 2, sstdata%nsurf, jpi, jpj, &
+         &                  igrdi, igrdj, gphit, zgphi )
+      CALL obs_int_comm_2d( 2, 2, sstdata%nsurf, jpi, jpj, &
+         &                  igrdi, igrdj, tmask(:,:,1), zmask )
+      DO jtype = 1, knumtypes
+         
+         !Find the number observations of type and allocate tempory arrays
+         inumtype = COUNT( sstdata%ntyp(:) == ibiastypes(jtype) )
+         ALLOCATE( &
+            & igrdi_tmp(2,2,inumtype), &
+            & igrdj_tmp(2,2,inumtype), &
+            & zglam_tmp(2,2,inumtype), &
+            & zgphi_tmp(2,2,inumtype), &
+            & zmask_tmp(2,2,inumtype), &
+            & zbias( 2,2,inumtype ) )
+         jt=1
+         DO jobs = 1, sstdata%nsurf 
+            IF ( sstdata%ntyp(jobs) == ibiastypes(jtype) ) THEN
+               igrdi_tmp(:,:,jt) = igrdi(:,:,jobs) 
+               igrdj_tmp(:,:,jt) = igrdj(:,:,jobs)
+               zglam_tmp(:,:,jt) = zglam(:,:,jobs)
+               zgphi_tmp(:,:,jt) = zgphi(:,:,jobs)
+               zmask_tmp(:,:,jt) = zmask(:,:,jobs)
+               jt = jt +1
+            ENDIF
+         END DO
+                         
+         CALL obs_int_comm_2d( 2, 2, inumtype, jpi, jpj, &
+               &           igrdi_tmp(:,:,:), igrdj_tmp(:,:,:), &
+               &           z_sstbias(:,:,jtype), zbias(:,:,:) )
+         jt=1
+         DO jobs = 1, sstdata%nsurf
+            IF ( sstdata%ntyp(jobs) == ibiastypes(jtype) ) THEN
+               zlam = sstdata%rlam(jobs)
+               zphi = sstdata%rphi(jobs)
+               iico = sstdata%mi(jobs)
+               ijco = sstdata%mj(jobs)         
+               CALL obs_int_h2d_init( 1, 1, k2dint, zlam, zphi,         &
+                  &                   zglam_tmp(:,:,jt), &
+                  &                   zgphi_tmp(:,:,jt), &
+                  &                   zmask_tmp(:,:,jt), zweig, zobsmask )
+               CALL obs_int_h2d( 1, 1, zweig, zbias(:,:,jt),  zext )
+               ! adjust sst with bias field
+               sstdata%robs(jobs,1) = sstdata%robs(jobs,1) - zext(1)
+               jt=jt+1
+            ENDIF
+         END DO 
+               
+         !Deallocate arrays
+         DEALLOCATE( &
+         & igrdi_tmp, &
+         & igrdj_tmp, &
+         & zglam_tmp, &
+         & zgphi_tmp, &
+         & zmask_tmp, &
+         & zbias )           
+      END DO
+      DEALLOCATE( &
+         & igrdi, &
+         & igrdj, &
+         & zglam, &
+         & zgphi, &
+         & zmask )
+
+      IF(lwp) THEN
+         WRITE(numout,*) " "
+         WRITE(numout,*) "SST bias correction applied successfully"
+         WRITE(numout,*) "Obs types: ",ibiastypes(:), &
+                              " Have all been bias corrected\n"
+      ENDIF
+   END SUBROUTINE obs_app_sstbias
+ 
+END MODULE obs_sstbias
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/obs_surf_def.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/obs_surf_def.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/obs_surf_def.F90	(revision 9570)
@@ -0,0 +1,530 @@
+MODULE obs_surf_def
+   !!=====================================================================
+   !!                       ***  MODULE  obs_surf_def  ***
+   !! Observation diagnostics: Storage handling for surface observation
+   !!                          arrays and additional flags etc.
+   !!                          This module only defines the data type and
+   !!                          operations on the data type. There is no
+   !!                          actual data in the module.
+   !!===================================================================== 
+
+   !!----------------------------------------------------------------------
+   !!   obs_surf            : F90 type containing the surface information
+   !!   obs_surf_alloc      : Allocates surface data arrays
+   !!   obs_surf_dealloc    : Deallocates surface data arrays
+   !!   obs_surf_compress   : Extract sub-information from a obs_surf type
+   !!                         to a new obs_surf type
+   !!   obs_surf_decompress : Reinsert sub-information from a obs_surf type
+   !!                         into the original obs_surf type
+   !!----------------------------------------------------------------------
+   !! * Modules used
+   USE par_kind, ONLY : & ! Precision variables
+      & wp         
+   USE obs_mpp, ONLY : &  ! MPP tools 
+      obs_mpp_sum_integer
+
+   IMPLICIT NONE
+
+   !! * Routine/type accessibility
+   PRIVATE
+
+   PUBLIC &
+      & obs_surf,           &
+      & obs_surf_alloc,     &
+      & obs_surf_dealloc,   &
+      & obs_surf_compress,  &
+      & obs_surf_decompress
+
+   !! * Type definition for surface observation type
+
+   TYPE obs_surf
+
+      ! Bookkeeping
+
+      INTEGER :: nsurf      !: Local number of surface data within window
+      INTEGER :: nsurfmpp   !: Global number of surface data within window
+      INTEGER :: nvar       !: Number of variables at observation points
+      INTEGER :: nextra     !: Number of extra fields at observation points
+      INTEGER :: nstp       !: Number of time steps
+      INTEGER :: npi        !: Number of 3D grid points
+      INTEGER :: npj
+      INTEGER :: nsurfup    !: Observation counter used in obs_oper
+      INTEGER :: nrec       !: Number of surface observation records in window
+
+      ! Arrays with size equal to the number of surface observations
+
+      INTEGER, POINTER, DIMENSION(:) :: &
+         & mi,   &        !: i-th grid coord. for interpolating to surface observation
+         & mj,   &        !: j-th grid coord. for interpolating to surface observation
+         & mt,   &        !: time record number for gridded data
+         & nsidx,&        !: Surface observation number
+         & nsfil,&        !: Surface observation number in file
+         & nyea, &        !: Year of surface observation
+         & nmon, &        !: Month of surface observation 
+         & nday, &        !: Day of surface observation
+         & nhou, &        !: Hour of surface observation
+         & nmin, &        !: Minute of surface observation
+         & mstp, &        !: Time step nearest to surface observation
+         & nqc,  &        !: Surface observation qc flag
+         & ntyp           !: Type of surface observation product
+
+      CHARACTER(len=8), POINTER, DIMENSION(:) :: &
+         & cvars          !: Variable names
+
+      CHARACTER(LEN=8), POINTER, DIMENSION(:) :: &
+         & cwmo           !: WMO indentifier
+         
+      REAL(KIND=wp), POINTER, DIMENSION(:) :: &
+         & rlam, &        !: Longitude coordinate of surface observation
+         & rphi           !: Latitude coordinate of surface observation
+
+      REAL(KIND=wp), POINTER, DIMENSION(:,:) :: &
+         & robs, &        !: Surface observation 
+         & rmod           !: Model counterpart of the surface observation vector
+
+      REAL(KIND=wp), POINTER, DIMENSION(:,:) :: &
+         & rext           !: Extra fields interpolated to observation points
+
+      REAL(KIND=wp), POINTER, DIMENSION(:,:) :: &
+         & vdmean         !: Time averaged of model field
+
+      ! Arrays with size equal to the number of time steps in the window
+
+      INTEGER, POINTER, DIMENSION(:) :: &
+         & nsstp,     &   !: Local number of surface observations per time step
+         & nsstpmpp       !: Global number of surface observations per time step
+
+      ! Arrays with size equal to the number of observation records in the window
+      INTEGER, POINTER, DIMENSION(:) :: &
+         & mrecstp   ! Time step of the records
+
+      ! Arrays used to store source indices when 
+      ! compressing obs_surf derived types
+      
+      ! Array with size nsurf
+
+      INTEGER, POINTER, DIMENSION(:) :: &
+         & nsind          !: Source indices of surface data in compressed data
+
+      ! Is this a gridded product?
+     
+      LOGICAL :: lgrid
+
+   END TYPE obs_surf
+
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO Consortium (2010)
+   !! $Id$
+   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+
+CONTAINS
+   
+   SUBROUTINE obs_surf_alloc( surf, ksurf, kvar, kextra, kstp, kpi, kpj )
+      !!----------------------------------------------------------------------
+      !!                     ***  ROUTINE obs_surf_alloc  ***
+      !!                      
+      !! ** Purpose : - Allocate data for surface data arrays
+      !! 
+      !! ** Method  : - Fortran-90 dynamic arrays
+      !!
+      !! History :
+      !!        !  07-03  (K. Mogensen, A. Weaver, E. Remy, S. Ricci) original
+      !!----------------------------------------------------------------------
+      !! * Arguments
+      TYPE(obs_surf), INTENT(INOUT) ::  surf      ! Surface data to be allocated
+      INTEGER, INTENT(IN) :: ksurf   ! Number of surface observations
+      INTEGER, INTENT(IN) :: kvar    ! Number of surface variables
+      INTEGER, INTENT(IN) :: kextra  ! Number of extra fields at observation points
+      INTEGER, INTENT(IN) :: kstp    ! Number of time steps
+      INTEGER, INTENT(IN) :: kpi     ! Number of 3D grid points
+      INTEGER, INTENT(IN) :: kpj
+
+      !!* Local variables
+      INTEGER :: ji
+      INTEGER :: jvar
+
+      ! Set bookkeeping variables
+
+      surf%nsurf    = ksurf
+      surf%nsurfmpp = 0
+      surf%nextra   = kextra
+      surf%nvar     = kvar
+      surf%nstp     = kstp
+      surf%npi      = kpi
+      surf%npj      = kpj
+
+      ! Allocate arrays of size number of variables
+
+      ALLOCATE( &
+         & surf%cvars(kvar)    &
+         & )
+
+      DO jvar = 1, kvar
+         surf%cvars(jvar) = "NotSet"
+      END DO
+      
+      ! Allocate arrays of number of surface data size
+
+      ALLOCATE( &
+         & surf%mi(ksurf),      &
+         & surf%mj(ksurf),      &
+         & surf%mt(ksurf),      &
+         & surf%nsidx(ksurf),   &
+         & surf%nsfil(ksurf),   &
+         & surf%nyea(ksurf),    &
+         & surf%nmon(ksurf),    &
+         & surf%nday(ksurf),    &
+         & surf%nhou(ksurf),    &
+         & surf%nmin(ksurf),    &
+         & surf%mstp(ksurf),    &
+         & surf%nqc(ksurf),     &
+         & surf%ntyp(ksurf),    &
+         & surf%cwmo(ksurf),    &
+         & surf%rlam(ksurf),    &
+         & surf%rphi(ksurf),    &
+         & surf%nsind(ksurf)    &
+         & )
+
+      surf%mt(:) = -1
+
+
+      ! Allocate arrays of number of surface data size * number of variables
+
+      ALLOCATE( & 
+         & surf%robs(ksurf,kvar), &
+         & surf%rmod(ksurf,kvar)  &
+         & )   
+
+      ! Allocate arrays of number of extra fields at observation points
+
+      ALLOCATE( & 
+         & surf%rext(ksurf,kextra) &
+         & )
+
+      surf%rext(:,:) = 0.0_wp 
+
+      ! Allocate arrays of number of time step size
+
+      ALLOCATE( &
+         & surf%nsstp(kstp),     &
+         & surf%nsstpmpp(kstp)   &
+         & )
+
+      ! Allocate arrays of size number of grid points
+
+      ALLOCATE( &
+         & surf%vdmean(kpi,kpj) &
+         & )
+
+      ! Set defaults for compression indices
+      
+      DO ji = 1, ksurf
+         surf%nsind(ji) = ji
+      END DO
+      
+      ! Set defaults for number of observations per time step
+
+      surf%nsstp(:)     = 0
+      surf%nsstpmpp(:)  = 0
+
+      ! Set the observation counter used in obs_oper
+
+      surf%nsurfup     = 0
+      
+      ! Not gridded by default
+          
+      surf%lgrid       = .FALSE.
+              
+   END SUBROUTINE obs_surf_alloc
+
+   SUBROUTINE obs_surf_dealloc( surf )
+      !!----------------------------------------------------------------------
+      !!                     ***  ROUTINE obs_surf_dealloc  ***
+      !!                      
+      !! ** Purpose : - Deallocate data for surface data arrays
+      !! 
+      !! ** Method  : - Fortran-90 dynamic arrays
+      !!
+      !! History :
+      !!        !  07-03  (K. Mogensen, A. Weaver, E. Remy, S. Ricci) original
+      !!----------------------------------------------------------------------
+      !! * Arguments
+      TYPE(obs_surf), INTENT(INOUT) :: &
+         & surf      ! Surface data to be allocated
+
+      !!* Local variables
+
+      ! Deallocate arrays of number of surface data size
+
+      DEALLOCATE( &
+         & surf%mi,      &
+         & surf%mj,      &
+         & surf%mt,      &
+         & surf%nsidx,   &
+         & surf%nsfil,   &
+         & surf%nyea,    &
+         & surf%nmon,    &
+         & surf%nday,    &
+         & surf%nhou,    &
+         & surf%nmin,    &
+         & surf%mstp,    &
+         & surf%nqc,     &
+         & surf%ntyp,    &
+         & surf%cwmo,    &
+         & surf%rlam,    &
+         & surf%rphi,    &
+         & surf%nsind    &
+         & )
+
+      ! Allocate arrays of number of surface data size * number of variables
+
+      DEALLOCATE( & 
+         & surf%robs,    &
+         & surf%rmod     &
+         & )
+
+      ! Deallocate arrays of number of extra fields at observation points
+
+      DEALLOCATE( & 
+         & surf%rext &
+         & )
+
+      ! Deallocate arrays of size number of grid points size times
+      ! number of variables
+
+      DEALLOCATE( &
+         & surf%vdmean &
+         & )
+
+      ! Deallocate arrays of number of time step size
+
+      DEALLOCATE( &
+         & surf%nsstp,     &
+         & surf%nsstpmpp   &
+         & )
+
+      ! Dellocate arrays of size number of variables
+
+      DEALLOCATE( &
+         & surf%cvars     &
+         & )
+
+   END SUBROUTINE obs_surf_dealloc
+
+   SUBROUTINE obs_surf_compress( surf, newsurf, lallocate, kumout, lvalid )
+      !!----------------------------------------------------------------------
+      !!                     ***  ROUTINE obs_surf_compress  ***
+      !!                      
+      !! ** Purpose : - Extract sub-information from a obs_surf type
+      !!                into a new obs_surf type
+      !! 
+      !! ** Method  : - The data is copied from surf to new surf.
+      !!                In the case of lvalid being present only the 
+      !!                selected data will be copied.
+      !!                If lallocate is true the data in the newsurf is 
+      !!                allocated either with the same number of elements
+      !!                as surf or with only the subset of elements defined
+      !!                by the optional selection.
+      !!
+      !! History :
+      !!        !  07-03  (K. Mogensen, A. Weaver, E. Remy, S. Ricci) original
+      !!----------------------------------------------------------------------
+      !! * Arguments
+      TYPE(obs_surf), INTENT(IN)    :: surf      ! Original surface data
+      TYPE(obs_surf), INTENT(INOUT) :: newsurf   ! New surface data with a subset of the original data
+      LOGICAL :: lallocate     ! Allocate newsurf data
+      INTEGER,INTENT(IN) :: kumout        ! Fortran unit for messages
+      LOGICAL, OPTIONAL, INTENT(in), DIMENSION(:) :: &
+         & lvalid         ! Valid of surface observations
+      
+      !!* Local variables
+      INTEGER :: insurf
+      INTEGER :: ji
+      INTEGER :: jk
+      LOGICAL, DIMENSION(:), ALLOCATABLE :: llvalid
+
+      ! Count how many elements there should be in the new data structure
+
+      IF ( PRESENT(lvalid) ) THEN
+         insurf = 0
+         DO ji = 1, surf%nsurf
+            IF ( lvalid(ji) ) THEN
+               insurf = insurf + 1
+            ENDIF
+         END DO
+      ELSE
+         insurf = surf%nsurf
+      ENDIF
+
+      ! Optionally allocate data in the new data structure
+
+      IF ( lallocate ) THEN
+         CALL obs_surf_alloc( newsurf,  insurf, surf%nvar, &
+            & surf%nextra, surf%nstp, surf%npi, surf%npj )
+      ENDIF
+
+      ! Allocate temporary valid array to unify the code for both cases
+
+      ALLOCATE( llvalid(surf%nsurf) )
+      IF ( PRESENT(lvalid) ) THEN
+         llvalid(:)  = lvalid(:)
+      ELSE
+         llvalid(:)  = .TRUE.
+      ENDIF
+
+      ! Setup bookkeeping variables
+
+      insurf = 0
+
+      ! Loop over source surface data
+
+      DO ji = 1, surf%nsurf
+
+         IF ( llvalid(ji) ) THEN
+
+            ! Copy the header information
+
+            insurf = insurf + 1
+
+            newsurf%mi(insurf)    = surf%mi(ji)
+            newsurf%mj(insurf)    = surf%mj(ji)
+            newsurf%mt(insurf)    = surf%mt(ji)
+            newsurf%nsidx(insurf) = surf%nsidx(ji)
+            newsurf%nsfil(insurf) = surf%nsfil(ji)
+            newsurf%nyea(insurf)  = surf%nyea(ji)
+            newsurf%nmon(insurf)  = surf%nmon(ji)
+            newsurf%nday(insurf)  = surf%nday(ji)
+            newsurf%nhou(insurf)  = surf%nhou(ji)
+            newsurf%nmin(insurf)  = surf%nmin(ji)
+            newsurf%mstp(insurf)  = surf%mstp(ji)
+            newsurf%nqc(insurf)   = surf%nqc(ji)
+            newsurf%ntyp(insurf)  = surf%ntyp(ji)
+            newsurf%cwmo(insurf)  = surf%cwmo(ji)
+            newsurf%rlam(insurf)  = surf%rlam(ji)
+            newsurf%rphi(insurf)  = surf%rphi(ji)
+
+            DO jk = 1, surf%nvar
+
+               newsurf%robs(insurf,jk)  = surf%robs(ji,jk)
+               newsurf%rmod(insurf,jk)  = surf%rmod(ji,jk)
+               
+            END DO
+
+            DO jk = 1, surf%nextra
+
+               newsurf%rext(insurf,jk) = surf%rext(ji,jk)
+
+            END DO
+            
+            ! nsind is the index of the original surface data
+            
+            newsurf%nsind(insurf) = ji
+
+         ENDIF
+
+      END DO
+
+      ! Update MPP counters
+
+      newsurf%nsurf = insurf
+      CALL obs_mpp_sum_integer ( newsurf%nsurf, newsurf%nsurfmpp )
+
+      ! Set book keeping variables which do not depend on number of obs.
+
+      newsurf%nstp     = surf%nstp
+      newsurf%cvars(:) = surf%cvars(:)
+      
+      ! Set gridded stuff
+      
+      newsurf%mt(insurf)    = surf%mt(ji)
+ 
+      ! Deallocate temporary data
+
+      DEALLOCATE( llvalid )
+     
+   END SUBROUTINE obs_surf_compress
+
+   SUBROUTINE obs_surf_decompress( surf, oldsurf, ldeallocate, kumout )
+      !!----------------------------------------------------------------------
+      !!                     ***  ROUTINE obs_surf_decompress  ***
+      !!                      
+      !! ** Purpose : - Copy back information to original surface data type
+      !!
+      !! ** Method  : - Reinsert updated information from a previous
+      !!                copied/compressed surface data type into the original
+      !!                surface data and optionally deallocate the surface
+      !!                data input
+      !! 
+      !! History :
+      !!        !  07-03  (K. Mogensen, A. Weaver, E. Remy, S. Ricci) original
+      !!----------------------------------------------------------------------
+      !! * Arguments
+      TYPE(obs_surf),INTENT(INOUT) :: surf       ! Updated surface data
+      TYPE(obs_surf),INTENT(INOUT) :: oldsurf    ! Original surface data
+      LOGICAL :: ldeallocate ! Deallocate the updated data of insertion
+      INTEGER,INTENT(in) :: kumout      ! Output unit
+      
+      !!* Local variables
+      INTEGER :: ji
+      INTEGER :: jj
+      INTEGER :: jk
+
+      ! Copy data from surf to old surf
+
+      DO ji = 1, surf%nsurf
+
+         jj=surf%nsind(ji)
+
+         oldsurf%mi(jj)    = surf%mi(ji)
+         oldsurf%mj(jj)    = surf%mj(ji)
+         oldsurf%mt(jj)    = surf%mt(ji)
+         oldsurf%nsidx(jj) = surf%nsidx(ji)
+         oldsurf%nsfil(jj) = surf%nsfil(ji)
+         oldsurf%nyea(jj)  = surf%nyea(ji)
+         oldsurf%nmon(jj)  = surf%nmon(ji)
+         oldsurf%nday(jj)  = surf%nday(ji)
+         oldsurf%nhou(jj)  = surf%nhou(ji)
+         oldsurf%nmin(jj)  = surf%nmin(ji)
+         oldsurf%mstp(jj)  = surf%mstp(ji)
+         oldsurf%nqc(jj)   = surf%nqc(ji)
+         oldsurf%ntyp(jj)  = surf%ntyp(ji)
+         oldsurf%cwmo(jj)  = surf%cwmo(ji)
+         oldsurf%rlam(jj)  = surf%rlam(ji)
+         oldsurf%rphi(jj)  = surf%rphi(ji)
+
+      END DO
+
+      DO jk = 1, surf%nvar
+
+         DO ji = 1, surf%nsurf
+            
+            jj=surf%nsind(ji)
+
+            oldsurf%robs(jj,jk)  = surf%robs(ji,jk)
+            oldsurf%rmod(jj,jk)  = surf%rmod(ji,jk)
+
+         END DO
+
+      END DO
+
+      DO jk = 1, surf%nextra
+
+         DO ji = 1, surf%nsurf
+            
+            jj=surf%nsind(ji)
+
+            oldsurf%rext(jj,jk)  = surf%rext(ji,jk)
+
+         END DO
+
+      END DO
+
+      ! Optionally deallocate the updated surface data
+
+      IF ( ldeallocate ) CALL obs_surf_dealloc( surf )
+      
+   END SUBROUTINE obs_surf_decompress
+   
+END MODULE obs_surf_def
+
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/obs_types.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/obs_types.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/obs_types.F90	(revision 9570)
@@ -0,0 +1,267 @@
+MODULE obs_types
+   !!=====================================================================
+   !!                       ***  MODULE  obs_types  ***
+   !! Observation diagnostics: Observation type integer to character 
+   !!                          translation
+   !!=====================================================================
+
+   !!---------------------------------------------------------------------
+   !! 
+   !!   The NetCDF variable CWMO_INST_TYP_COR is used to identify the 
+   !!   different instrument types for coriolis data.
+   !!
+   !!    WMO  NEMOVAR  TYPE                   DESCRIPTION
+   !!    ---  -------  ----   --------------------------------------------
+   !!    800     0     MBT    (1941-) mechanical bathythermograph data
+   !!    401     1     XBT    (1967-) expendable bathythermograph data
+   !!    830     2     CTD    (1967-) high resolution CTD data
+   !!    820     3     MRB    (1990-) moored buoy data
+   !!    831     4     PFL    (1994-) profiling float data
+   !!    995     5     DRB    (1998-) drifting buoy data
+   !!    997     6     APB    (1997-) autonomous pinniped bathythermograph
+   !!    996     7     UOR    (1992-) undulating oceanographic recorder
+   !!    741     8     OSD    (1800-) low resolution (bottle) CTD data
+  !!
+   !! History :
+   !!        !  06-03  (K. Mogensen) Original code
+   !!        !  06-10  (A. Weaver) Cleanup
+   !!---------------------------------------------------------------------
+
+   IMPLICIT NONE
+
+   !! * Routine accessibility
+   PRIVATE 
+
+   !! * Shared Module variables
+
+   INTEGER, PUBLIC, PARAMETER :: ntyp1770 = 1023
+!RBbug useless ?   CHARACTER(LEN=4), PUBLIC, DIMENSION(0:ntyp1770) :: cwmotyp1770
+   CHARACTER(LEN=80), PUBLIC, DIMENSION(0:ntyp1770) :: cwmonam1770
+   CHARACTER(LEN=3), PUBLIC, DIMENSION(0:ntyp1770) :: ctypshort
+
+   INTEGER, PUBLIC, PARAMETER :: ntypalt = 8
+   CHARACTER(LEN=40), PUBLIC, DIMENSION(0:ntypalt) :: calttyp
+
+   PUBLIC obs_typ_init
+   PUBLIC obs_wmo_init
+   PUBLIC obs_alt_typ_init
+
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO Consortium (2010)
+   !! $Id$
+   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+
+CONTAINS 
+   
+   SUBROUTINE obs_typ_init
+      !!---------------------------------------------------------------------
+      !!
+      !!                   *** ROUTINE obs_wmo_init ***
+      !!
+      !! ** Purpose : Initialize code tables
+      !!
+      !! ** Method  : 
+      !!
+      !! ** Action  : 
+      !!
+      !! References : 
+      !!
+      !! History :  
+      !!      ! :  2007-06 (K. Mogensen) Original code
+      !!----------------------------------------------------------------------
+      !! * Modules used
+      
+      !! * Arguments
+
+      !! * Local declarations
+
+      CALL obs_wmo_init
+
+      CALL obs_alt_typ_init
+
+   END SUBROUTINE obs_typ_init
+
+   SUBROUTINE obs_wmo_init
+      !!---------------------------------------------------------------------
+      !!
+      !!                   *** ROUTINE obs_wmo_init ***
+      !!
+      !! ** Purpose : Initialize WMO code 1770 code tables
+      !!
+      !! ** Method  : Direct initialisation of variables
+      !!
+      !! ** Action  : 
+      !!
+      !! References : WORLD  METEOROLOGICAL  ORGANIZATION
+      !!              Manual on Codes
+      !!              International Codes
+      !!              VOLUME I.1 (Annex II to WMO Technical Regulations)
+      !!              Part A -- Alphanumeric Codes
+      !!              1995 edition
+      !!              WMO-No. 306 
+      !!              Secretariat of the World Meteorological Organization 
+      !!              Geneva, Switzerland
+      !!
+      !! History :  
+      !!      ! :  2007-04 (K. Mogensen) Original code
+      !!----------------------------------------------------------------------
+      !! * Modules used
+      
+      !! * Arguments
+
+      !! * Local declarations
+      INTEGER :: ji
+
+      DO ji = 0, ntyp1770
+
+         cwmonam1770(ji) = 'Not defined'
+         ctypshort(ji) = '---'
+
+!         IF ( ji < 1000 ) THEN
+!            WRITE(cwmotyp1770(ji),'(1X,I3.3)') ji
+!         ELSE
+!            WRITE(cwmotyp1770(ji),'(I4.4)') ji
+!         ENDIF
+
+      END DO
+
+      cwmonam1770(   1) = 'Sippican T-4'
+      cwmonam1770(   2) = 'Sippican T-4'
+      cwmonam1770(  11) = 'Sippican T-5'
+      cwmonam1770(  21) = 'Sippican Fast Deep'
+      cwmonam1770(  31) = 'Sippican T-6'
+      cwmonam1770(  32) = 'Sippican T-6'
+      cwmonam1770(  41) = 'Sippican T-7'
+      cwmonam1770(  42) = 'Sippican T-7'
+      cwmonam1770(  51) = 'Sippican Deep Blue'
+      cwmonam1770(  52) = 'Sippican Deep Blue'
+      cwmonam1770(  61) = 'Sippican T-10'
+      cwmonam1770(  71) = 'Sippican T-11'
+      cwmonam1770( 201) = 'TSK T-4'
+      cwmonam1770( 202) = 'TSK T-4'
+      cwmonam1770( 211) = 'TSK T-6'
+      cwmonam1770( 212) = 'TSK T-6'
+      cwmonam1770( 221) = 'TSK T-7'
+      cwmonam1770( 222) = 'TSK T-7'
+      cwmonam1770( 231) = 'TSK T-5'
+      cwmonam1770( 241) = 'TSK T-10'
+      cwmonam1770( 251) = 'TSK Deep Blue'
+      cwmonam1770( 252) = 'TSK Deep Blue'
+      cwmonam1770( 261) = 'TSK AXBT '
+      cwmonam1770( 401) = 'Sparton XBT-1'
+      cwmonam1770( 411) = 'Sparton XBT-3'
+      cwmonam1770( 421) = 'Sparton XBT-4'
+      cwmonam1770( 431) = 'Sparton XBT-5'
+      cwmonam1770( 441) = 'Sparton XBT-5DB'
+      cwmonam1770( 451) = 'Sparton XBT-6'
+      cwmonam1770( 461) = 'Sparton XBT-7'
+      cwmonam1770( 462) = 'Sparton XBT-7'
+      cwmonam1770( 471) = 'Sparton XBT-7DB'
+      cwmonam1770( 481) = 'Sparton XBT-10'
+      cwmonam1770( 491) = 'Sparton XBT-20'
+      cwmonam1770( 501) = 'Sparton XBT-20DB'
+      cwmonam1770( 510) = 'Sparton 536 AXBT'
+      cwmonam1770( 700) = 'Sippican XCTD standard'
+      cwmonam1770( 710) = 'Sippican XCTD deep'
+      cwmonam1770( 720) = 'Sippican AXCTD'
+      cwmonam1770( 730) = 'Sippican SXCTD'
+      cwmonam1770( 741) = 'TSK XCTD'
+      cwmonam1770( 742) = 'TSK XCTD-2 '
+      cwmonam1770( 743) = 'TSK XCTD-2F '
+      cwmonam1770( 751) = 'TSK AXCTD '
+      cwmonam1770( 800) = 'Mechanical BT'
+      cwmonam1770( 810) = 'Hydrocast'
+      cwmonam1770( 820) = 'Thermistor Chain'
+      cwmonam1770( 825) = 'Temperature (sonic) and pressure probes'
+      cwmonam1770( 830) = 'CTD'
+      cwmonam1770( 831) = 'CTD-P-ALACE float'
+      cwmonam1770( 840) = 'PROVOR, No conductivity sensor '
+      cwmonam1770( 841) = 'PROVOR, Seabird conductivity sensor '
+      cwmonam1770( 842) = 'PROVOR, FSI conductivity sensor '
+      cwmonam1770( 845) = 'Web Research, No conductivity sensor '
+      cwmonam1770( 846) = 'Web Research, Seabird conductivity sensor '
+      cwmonam1770( 847) = 'Web Research. FSI conductivity sensor'
+      cwmonam1770( 850) = 'SOLO, No conductivity sensor '
+      cwmonam1770( 851) = 'SOLO, Seabird conductivity sensor '
+      cwmonam1770( 852) = 'SOLO, FSI conductivity sensor'
+      cwmonam1770( 855) = 'Profiling float, NINJA, no conductivity sensor'
+      cwmonam1770( 856) = 'Profiling float, NINJA, SBE conductivity sensor'
+      cwmonam1770( 857) = 'Profiling float, NINJA, FSI conductivity sensor'
+      cwmonam1770( 858) = 'Profiling float, NINJA, TSK conductivity sensor'
+      cwmonam1770( 900) = 'Sippican T-12 XBT'
+      cwmonam1770(1023) = 'Missing value'
+
+      DO ji = 853, 854
+         cwmonam1770(ji) = 'Reserved'
+      END DO
+
+      DO ji = 859, 899
+         cwmonam1770(ji) = 'Reserved'
+      END DO
+
+      DO ji = 901, 999
+         cwmonam1770(ji) = 'Reserved'
+      END DO
+
+      DO ji = 1000, 1022
+         cwmonam1770(ji) = 'Reserved'
+      END DO
+
+      ctypshort(800) = 'MBT'
+      ctypshort(401) = 'XBT'
+      ctypshort(830) = 'CTD'
+      ctypshort(820) = 'MRB'
+      ctypshort(831) = 'PFL'
+      ctypshort(995) = 'DRB'
+      ctypshort(997) = 'APB'
+      ctypshort(996) = 'UOR'
+      ctypshort(700:799) = 'OSD'
+
+   END SUBROUTINE obs_wmo_init
+
+   SUBROUTINE obs_alt_typ_init
+      !!---------------------------------------------------------------------
+      !!
+      !!                   *** ROUTINE obs_alt_typ_init ***
+      !!
+      !! ** Purpose : Initialize CLS altimeter code tables
+      !!
+      !! ** Method  : Direct initialisation of variables
+      !!
+      !! ** Action  : 
+      !!
+      !! References : CLS
+      !1              SSALTO/DUACS User Handbook
+      !!              (M)SLA and (M)ADT Near-Real Time and
+      !!              Delayed time products
+      !!              CLS-DOS-NT-06-034
+      !!              2006
+      !!              CLS
+      !!              8-10 Rue Hermes
+      !!              Parc Technologique du Canal
+      !!              31526 Ramonville St-Agne
+      !!              France
+      !!
+      !! History :  
+      !!      ! :  2007-06 (K. Mogensen) Original code
+      !!----------------------------------------------------------------------
+      !! * Modules used
+      
+      !! * Arguments
+
+      !! * Local declarations
+
+      calttyp(0) = 'Unknown'
+      calttyp(1) = 'ERS-1'
+      calttyp(2) = 'ERS-2'
+      calttyp(3) = 'Topex/Poseidon'
+      calttyp(4) = 'Topex/Poseidon on its new orbit'
+      calttyp(5) = 'GFO'
+      calttyp(6) = 'Jason-1'
+      calttyp(7) = 'Envisat'
+      calttyp(8) = 'Jason-2'
+
+   END SUBROUTINE obs_alt_typ_init
+
+END MODULE obs_types
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/obs_utils.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/obs_utils.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/obs_utils.F90	(revision 9570)
@@ -0,0 +1,213 @@
+MODULE obs_utils
+   !!======================================================================
+   !!                       ***  MODULE obs_utils   ***
+   !! Observation diagnostics: Utility functions
+   !!=====================================================================
+
+   !!----------------------------------------------------------------------
+   !!   grt_cir_dis     : Great circle distance 
+   !!   grt_cir_dis_saa : Great circle distance (small angle)
+   !!   chkerr          : Error-message managment for NetCDF files
+   !!   chkdim          : Error-message managment for NetCDF files
+   !!   fatal_error     : Fatal error handling
+   !!   ddatetoymdhms   : Convert YYYYMMDD.hhmmss to components
+   !!----------------------------------------------------------------------
+   !! * Modules used
+   USE par_oce, ONLY : &        ! Precision variables
+      & wp, &
+      & dp, &
+      & i8  
+   USE in_out_manager           ! I/O manager
+   USE lib_mpp                  ! For ctl_warn/stop
+
+   IMPLICIT NONE
+
+   !! * Routine accessibility
+   PRIVATE
+   PUBLIC grt_cir_dis,     &  ! Great circle distance 
+      &   grt_cir_dis_saa, &  ! Great circle distance (small angle)
+      &   str_c_to_for,    &  ! Remove non-printable chars from string
+      &   chkerr,          &  ! Error-message managment for NetCDF files
+      &   chkdim,          &  ! Check if dimensions are correct for a variable
+      &   fatal_error,     &  ! Fatal error handling
+      &   warning,         &  ! Warning handling
+      &   ddatetoymdhms       ! Convert YYYYMMDD.hhmmss to components
+         
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO Consortium (2010)
+   !! $Id$
+   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+
+CONTAINS
+ 
+#include "grt_cir_dis.h90"
+
+#include "grt_cir_dis_saa.h90"
+
+#include "str_c_to_for.h90"
+
+   SUBROUTINE chkerr( kstatus, cd_name, klineno )
+      !!----------------------------------------------------------------------
+      !!   
+      !!                    *** ROUTINE chkerr ***
+      !! 
+      !! ** Purpose : Error-message managment for NetCDF files.
+      !! 
+      !! ** Method  : 
+      !!
+      !! ** Action  :
+      !!
+      !! History
+      !!      ! 02-12  (N. Daget)  hdlerr
+      !!      ! 06-04  (A. Vidard) f90/nemovar migration, change name
+      !!      ! 06-10  (A. Weaver) Cleanup
+      !!----------------------------------------------------------------------
+      !! * Modules used
+      USE netcdf             ! NetCDF library
+      USE dom_oce, ONLY : &  ! Ocean space and time domain variables
+         & nproc
+
+      !! * Arguments
+      INTEGER :: kstatus
+      INTEGER :: klineno
+      CHARACTER(LEN=*) :: cd_name
+      
+      !! * Local declarations
+      CHARACTER(len=200) :: clineno
+
+      ! Main computation
+      IF ( kstatus /= nf90_noerr ) THEN
+         WRITE(clineno,'(A,I8)')' at line number ', klineno
+         CALL ctl_stop( ' chkerr', ' Netcdf Error in ' // TRIM( cd_name ), &
+            &           clineno, nf90_strerror( kstatus ) )
+      ENDIF
+
+   END SUBROUTINE chkerr
+
+   SUBROUTINE chkdim( kfileid, kvarid, kndim, kdim, cd_name, klineno )
+      !!----------------------------------------------------------------------
+      !!   
+      !!                    *** ROUTINE chkerr ***
+      !! 
+      !! ** Purpose : Error-message managment for NetCDF files.
+      !! 
+      !! ** Method  : 
+      !!
+      !! ** Action  :
+      !!
+      !! History
+      !!      ! 07-03  (K. Mogenen + E. Remy) Initial version
+      !!----------------------------------------------------------------------
+      !! * Modules used
+      USE netcdf             ! NetCDF library
+      USE dom_oce, ONLY : &  ! Ocean space and time domain variables
+         & nproc
+
+      !! * Arguments
+      INTEGER :: kfileid       ! NetCDF file id   
+      INTEGER :: kvarid        ! NetCDF variable id   
+      INTEGER :: kndim         ! Expected number of dimensions
+      INTEGER, DIMENSION(kndim) :: kdim      ! Expected dimensions
+      CHARACTER(LEN=*) :: cd_name            ! Calling routine name
+      INTEGER ::  klineno      ! Calling line number
+
+      !! * Local declarations
+      INTEGER :: indim
+      INTEGER, ALLOCATABLE, DIMENSION(:) :: &
+         & idim,ilendim
+      INTEGER :: ji
+      LOGICAL :: llerr
+      CHARACTER(len=200) :: clineno
+
+      CALL chkerr( nf90_inquire_variable( kfileid, kvarid, ndims=indim ), &
+         &         cd_name, klineno )
+
+      ALLOCATE(idim(indim),ilendim(indim))
+
+      CALL chkerr( nf90_inquire_variable( kfileid, kvarid, dimids=idim ), &
+         &         cd_name, klineno )
+
+      DO ji = 1, indim
+         CALL chkerr( nf90_inquire_dimension( kfileid, idim(ji), &
+            &                                 len=ilendim(ji) ), &
+            &         cd_name, klineno )
+      END DO
+      
+      IF ( indim /= kndim ) THEN
+         WRITE(clineno,'(A,I8)')' at line number ', klineno
+         CALL ctl_stop( ' chkdim',  &
+            &           ' Netcdf no dim error in ' // TRIM( cd_name ), &
+            &           clineno )
+      ENDIF
+
+      DO ji = 1, indim
+         IF ( ilendim(ji) /= kdim(ji) ) THEN
+            WRITE(clineno,'(A,I8)')' at line number ', klineno
+            CALL ctl_stop( ' chkdim',  &
+               &           ' Netcdf dim len error in ' // TRIM( cd_name ), &
+               &           clineno )
+         ENDIF
+      END DO
+         
+      DEALLOCATE(idim,ilendim)
+
+   END SUBROUTINE chkdim
+   
+  SUBROUTINE fatal_error( cd_name, klineno )
+      !!----------------------------------------------------------------------
+      !!
+      !!                    *** ROUTINE fatal_error ***
+      !!
+      !! ** Purpose : Fatal error handling
+      !!
+      !! ** Method  :
+      !!
+      !! ** Action  :
+      !!
+      !! History
+      !!----------------------------------------------------------------------
+      !! * Modules used
+
+      !! * Arguments
+      INTEGER :: klineno
+      CHARACTER(LEN=*) :: cd_name
+      !! * Local declarations
+      CHARACTER(len=200) :: clineno
+
+      WRITE(clineno,'(A,I8)')' at line number ', klineno
+      CALL ctl_stop( ' fatal_error', ' Error in ' // TRIM( cd_name ), &
+         &           clineno)
+      
+   END SUBROUTINE fatal_error
+
+   SUBROUTINE warning( cd_name, klineno )
+      !!----------------------------------------------------------------------
+      !!
+      !!                    *** ROUTINE warning ***
+      !!
+      !! ** Purpose : Warning handling
+      !!
+      !! ** Method  :
+      !!
+      !! ** Action  :
+      !!
+      !! History
+      !!----------------------------------------------------------------------
+      !! * Modules used
+
+      !! * Arguments
+      INTEGER :: klineno
+      CHARACTER(LEN=*) :: cd_name
+      !! * Local declarations
+      CHARACTER(len=200) :: clineno
+
+      WRITE(clineno,'(A,I8)')' at line number ', klineno
+      CALL ctl_warn( ' warning', ' Potential problem in ' // TRIM( cd_name ), &
+         &           clineno)
+      
+   END SUBROUTINE warning
+
+#include "ddatetoymdhms.h90"
+
+END MODULE obs_utils
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/obs_write.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/obs_write.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/obs_write.F90	(revision 9570)
@@ -0,0 +1,608 @@
+MODULE obs_write
+   !!======================================================================
+   !!                       ***  MODULE obs_write   ***
+   !! Observation diagnosticss: Write observation related diagnostics
+   !!=====================================================================
+
+   !!----------------------------------------------------------------------
+   !!   obs_wri_prof   : Write profile observations in feedback format
+   !!   obs_wri_surf   : Write surface observations in feedback format
+   !!   obs_wri_stats  : Print basic statistics on the data being written out
+   !!----------------------------------------------------------------------
+
+   !! * Modules used
+   USE par_kind, ONLY : &   ! Precision variables
+      & wp
+   USE in_out_manager       ! I/O manager
+   USE dom_oce              ! Ocean space and time domain variables
+   USE obs_types            ! Observation type integer to character translation
+   USE julian, ONLY : &         ! Julian date routines
+      & greg2jul
+   USE obs_utils, ONLY : &  ! Observation operator utility functions
+      & chkerr
+   USE obs_profiles_def     ! Type definitions for profiles
+   USE obs_surf_def         ! Type defintions for surface observations
+   USE obs_fbm              ! Observation feedback I/O
+   USE obs_grid             ! Grid tools
+   USE obs_conv             ! Conversion between units
+   USE obs_const
+   USE obs_mpp              ! MPP support routines for observation diagnostics
+   USE lib_mpp		    ! MPP routines
+
+   IMPLICIT NONE
+
+   !! * Routine accessibility
+   PRIVATE
+   PUBLIC obs_wri_prof, &    ! Write profile observation files
+      &   obs_wri_surf, &    ! Write surface observation files
+      &   obswriinfo
+   
+   TYPE obswriinfo
+      INTEGER :: inum
+      INTEGER, POINTER, DIMENSION(:) :: ipoint
+      CHARACTER(len=ilenname), POINTER, DIMENSION(:) :: cdname
+      CHARACTER(len=ilenlong), POINTER, DIMENSION(:,:) :: cdlong
+      CHARACTER(len=ilenunit), POINTER, DIMENSION(:,:) :: cdunit
+   END TYPE obswriinfo
+
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO Consortium (2010)
+   !! $Id$
+   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+
+CONTAINS
+
+   SUBROUTINE obs_wri_prof( profdata, padd, pext )
+      !!-----------------------------------------------------------------------
+      !!
+      !!                     *** ROUTINE obs_wri_prof  ***
+      !!
+      !! ** Purpose : Write profile feedback files
+      !!
+      !! ** Method  : NetCDF
+      !! 
+      !! ** Action  :
+      !!
+      !! History :
+      !!      ! 06-04  (A. Vidard) Original
+      !!      ! 06-04  (A. Vidard) Reformatted
+      !!      ! 06-10  (A. Weaver) Cleanup
+      !!      ! 07-01  (K. Mogensen) Use profile data types
+      !!      ! 07-03  (K. Mogensen) General handling of profiles
+      !!      ! 09-01  (K. Mogensen) New feedback format
+      !!      ! 15-02  (M. Martin) Combined routine for writing profiles
+      !!-----------------------------------------------------------------------
+
+      !! * Arguments
+      TYPE(obs_prof), INTENT(INOUT) :: profdata      ! Full set of profile data
+      TYPE(obswriinfo), OPTIONAL :: padd             ! Additional info for each variable
+      TYPE(obswriinfo), OPTIONAL :: pext             ! Extra info
+
+      !! * Local declarations
+      TYPE(obfbdata) :: fbdata
+      CHARACTER(LEN=40) :: clfname
+      CHARACTER(LEN=10) :: clfiletype
+      INTEGER :: ilevel
+      INTEGER :: jvar
+      INTEGER :: jo
+      INTEGER :: jk
+      INTEGER :: ik
+      INTEGER :: ja
+      INTEGER :: je
+      INTEGER :: iadd
+      INTEGER :: iext
+      REAL(wp) :: zpres
+
+      IF ( PRESENT( padd ) ) THEN
+         iadd = padd%inum
+      ELSE
+         iadd = 0
+      ENDIF
+
+      IF ( PRESENT( pext ) ) THEN
+         iext = pext%inum
+      ELSE
+         iext = 0
+      ENDIF
+
+      CALL init_obfbdata( fbdata )
+
+      ! Find maximum level
+      ilevel = 0
+      DO jvar = 1, 2
+         ilevel = MAX( ilevel, MAXVAL( profdata%var(jvar)%nvlidx(:) ) )
+      END DO
+
+      SELECT CASE ( TRIM(profdata%cvars(1)) )
+      CASE('POTM')
+
+         clfiletype='profb'
+         CALL alloc_obfbdata( fbdata, 2, profdata%nprof, ilevel, &
+            &                 1 + iadd, 1 + iext, .TRUE. )
+         fbdata%cname(1)      = profdata%cvars(1)
+         fbdata%cname(2)      = profdata%cvars(2)
+         fbdata%coblong(1)    = 'Potential temperature'
+         fbdata%coblong(2)    = 'Practical salinity'
+         fbdata%cobunit(1)    = 'Degrees centigrade'
+         fbdata%cobunit(2)    = 'PSU'
+         fbdata%cextname(1)   = 'TEMP'
+         fbdata%cextlong(1)   = 'Insitu temperature'
+         fbdata%cextunit(1)   = 'Degrees centigrade'
+         fbdata%caddlong(1,1) = 'Model interpolated potential temperature'
+         fbdata%caddlong(1,2) = 'Model interpolated practical salinity'
+         fbdata%caddunit(1,1) = 'Degrees centigrade'
+         fbdata%caddunit(1,2) = 'PSU'
+         fbdata%cgrid(:)      = 'T'
+         DO je = 1, iext
+            fbdata%cextname(1+je) = pext%cdname(je)
+            fbdata%cextlong(1+je) = pext%cdlong(je,1)
+            fbdata%cextunit(1+je) = pext%cdunit(je,1)
+         END DO
+         DO ja = 1, iadd
+            fbdata%caddname(1+ja) = padd%cdname(ja)
+            DO jvar = 1, 2
+               fbdata%caddlong(1+ja,jvar) = padd%cdlong(ja,jvar)
+               fbdata%caddunit(1+ja,jvar) = padd%cdunit(ja,jvar)
+            END DO
+         END DO
+
+      CASE('UVEL')
+
+         clfiletype='velfb'
+         CALL alloc_obfbdata( fbdata, 2, profdata%nprof, ilevel, 1, 0, .TRUE. )
+         fbdata%cname(1)      = profdata%cvars(1)
+         fbdata%cname(2)      = profdata%cvars(2)
+         fbdata%coblong(1)    = 'Zonal velocity'
+         fbdata%coblong(2)    = 'Meridional velocity'
+         fbdata%cobunit(1)    = 'm/s'
+         fbdata%cobunit(2)    = 'm/s'
+         DO je = 1, iext
+            fbdata%cextname(je) = pext%cdname(je)
+            fbdata%cextlong(je) = pext%cdlong(je,1)
+            fbdata%cextunit(je) = pext%cdunit(je,1)
+         END DO
+         fbdata%caddlong(1,1) = 'Model interpolated zonal velocity'
+         fbdata%caddlong(1,2) = 'Model interpolated meridional velocity'
+         fbdata%caddunit(1,1) = 'm/s'
+         fbdata%caddunit(1,2) = 'm/s'
+         fbdata%cgrid(1)      = 'U' 
+         fbdata%cgrid(2)      = 'V'
+         DO ja = 1, iadd
+            fbdata%caddname(1+ja) = padd%cdname(ja)
+            fbdata%caddlong(1+ja,1) = padd%cdlong(ja,1)
+            fbdata%caddunit(1+ja,1) = padd%cdunit(ja,1)
+         END DO
+
+      END SELECT
+
+      fbdata%caddname(1)   = 'Hx'
+
+      WRITE(clfname, FMT="(A,'_fdbk_',I4.4,'.nc')") TRIM(clfiletype), nproc
+
+      IF(lwp) THEN
+         WRITE(numout,*)
+         WRITE(numout,*)'obs_wri_prof :'
+         WRITE(numout,*)'~~~~~~~~~~~~~'
+         WRITE(numout,*)'Writing '//TRIM(clfiletype)//' feedback file : ',TRIM(clfname)
+      ENDIF
+
+      ! Transform obs_prof data structure into obfb data structure
+      fbdata%cdjuldref = '19500101000000'
+      DO jo = 1, profdata%nprof
+         fbdata%plam(jo)      = profdata%rlam(jo)
+         fbdata%pphi(jo)      = profdata%rphi(jo)
+         WRITE(fbdata%cdtyp(jo),'(I4)') profdata%ntyp(jo)
+         fbdata%ivqc(jo,:)    = profdata%ivqc(jo,:)
+         fbdata%ivqcf(:,jo,:) = profdata%ivqcf(:,jo,:)
+         IF ( profdata%nqc(jo) > 255 ) THEN
+            fbdata%ioqc(jo)    = IBSET(profdata%nqc(jo),2)
+            fbdata%ioqcf(1,jo) = profdata%nqcf(1,jo)
+            fbdata%ioqcf(2,jo) = profdata%nqc(jo)
+         ELSE
+            fbdata%ioqc(jo)    = profdata%nqc(jo)
+            fbdata%ioqcf(:,jo) = profdata%nqcf(:,jo)
+         ENDIF
+         fbdata%ipqc(jo)      = profdata%ipqc(jo)
+         fbdata%ipqcf(:,jo)   = profdata%ipqcf(:,jo)
+         fbdata%itqc(jo)      = profdata%itqc(jo)
+         fbdata%itqcf(:,jo)   = profdata%itqcf(:,jo)
+         fbdata%cdwmo(jo)     = profdata%cwmo(jo)
+         fbdata%kindex(jo)    = profdata%npfil(jo)
+         DO jvar = 1, profdata%nvar
+            IF (ln_grid_global) THEN
+               fbdata%iobsi(jo,jvar) = profdata%mi(jo,jvar)
+               fbdata%iobsj(jo,jvar) = profdata%mj(jo,jvar)
+            ELSE
+               fbdata%iobsi(jo,jvar) = mig(profdata%mi(jo,jvar))
+               fbdata%iobsj(jo,jvar) = mjg(profdata%mj(jo,jvar))
+            ENDIF
+         END DO
+         CALL greg2jul( 0, &
+            &           profdata%nmin(jo), &
+            &           profdata%nhou(jo), &
+            &           profdata%nday(jo), &
+            &           profdata%nmon(jo), &
+            &           profdata%nyea(jo), &
+            &           fbdata%ptim(jo),   &
+            &           krefdate = 19500101 )
+         ! Reform the profiles arrays for output
+         DO jvar = 1, 2
+            DO jk = profdata%npvsta(jo,jvar), profdata%npvend(jo,jvar)
+               ik = profdata%var(jvar)%nvlidx(jk)
+               fbdata%padd(ik,jo,1,jvar) = profdata%var(jvar)%vmod(jk)
+               fbdata%pob(ik,jo,jvar)    = profdata%var(jvar)%vobs(jk)
+               fbdata%pdep(ik,jo)        = profdata%var(jvar)%vdep(jk)
+               fbdata%idqc(ik,jo)        = profdata%var(jvar)%idqc(jk)
+               fbdata%idqcf(:,ik,jo)     = profdata%var(jvar)%idqcf(:,jk)
+               IF ( profdata%var(jvar)%nvqc(jk) > 255 ) THEN
+                  fbdata%ivlqc(ik,jo,jvar) = IBSET(profdata%var(jvar)%nvqc(jk),2)
+                  fbdata%ivlqcf(1,ik,jo,jvar) = profdata%var(jvar)%nvqcf(1,jk)
+!$AGRIF_DO_NOT_TREAT
+                  fbdata%ivlqcf(2,ik,jo,jvar) = IAND(profdata%var(jvar)%nvqc(jk),b'0000000011111111')
+!$AGRIF_END_DO_NOT_TREAT
+               ELSE
+                  fbdata%ivlqc(ik,jo,jvar) = profdata%var(jvar)%nvqc(jk)
+                  fbdata%ivlqcf(:,ik,jo,jvar) = profdata%var(jvar)%nvqcf(:,jk)
+               ENDIF
+               fbdata%iobsk(ik,jo,jvar)  = profdata%var(jvar)%mvk(jk)
+               DO ja = 1, iadd
+                  fbdata%padd(ik,jo,1+ja,jvar) = &
+                     & profdata%var(jvar)%vext(jk,padd%ipoint(ja))
+               END DO
+               DO je = 1, iext
+                  fbdata%pext(ik,jo,1+je) = &
+                     & profdata%var(jvar)%vext(jk,pext%ipoint(je))
+               END DO
+               IF ( ( jvar == 1 ) .AND. &
+                  & ( TRIM(profdata%cvars(1)) == 'POTM' ) ) THEN
+                  fbdata%pext(ik,jo,1) = profdata%var(jvar)%vext(jk,1)
+               ENDIF 
+            END DO
+         END DO
+      END DO
+
+      IF ( TRIM(profdata%cvars(1)) == 'POTM' ) THEN
+         ! Convert insitu temperature to potential temperature using the model
+         ! salinity if no potential temperature
+         DO jo = 1, fbdata%nobs
+            IF ( fbdata%pphi(jo) < 9999.0 ) THEN
+               DO jk = 1, fbdata%nlev
+                  IF ( ( fbdata%pob(jk,jo,1) >= 9999.0 ) .AND. &
+                     & ( fbdata%pdep(jk,jo) < 9999.0 ) .AND. &
+                     & ( fbdata%padd(jk,jo,1,2) < 9999.0 ) .AND. &
+                     & ( fbdata%pext(jk,jo,1) < 9999.0 ) ) THEN
+                     zpres = dep_to_p( REAL(fbdata%pdep(jk,jo),wp), &
+                        &              REAL(fbdata%pphi(jo),wp) )
+                     fbdata%pob(jk,jo,1) = potemp( &
+                        &                     REAL(fbdata%padd(jk,jo,1,2), wp),  &
+                        &                     REAL(fbdata%pext(jk,jo,1), wp), &
+                        &                     zpres, 0.0_wp )
+                  ENDIF
+               END DO
+            ENDIF
+         END DO
+      ENDIF
+
+      ! Write the obfbdata structure
+      CALL write_obfbdata( clfname, fbdata )
+
+      ! Output some basic statistics
+      CALL obs_wri_stats( fbdata )
+
+      CALL dealloc_obfbdata( fbdata )
+
+   END SUBROUTINE obs_wri_prof
+
+   SUBROUTINE obs_wri_surf( surfdata, padd, pext )
+      !!-----------------------------------------------------------------------
+      !!
+      !!                     *** ROUTINE obs_wri_surf  ***
+      !!
+      !! ** Purpose : Write surface observation files
+      !!
+      !! ** Method  : NetCDF
+      !! 
+      !! ** Action  :
+      !!
+      !!      ! 07-03  (K. Mogensen) Original
+      !!      ! 09-01  (K. Mogensen) New feedback format.
+      !!      ! 15-02  (M. Martin) Combined surface writing routine.
+      !!-----------------------------------------------------------------------
+
+      !! * Modules used
+      IMPLICIT NONE
+
+      !! * Arguments
+      TYPE(obs_surf), INTENT(INOUT) :: surfdata         ! Full set of surface data
+      TYPE(obswriinfo), OPTIONAL :: padd               ! Additional info for each variable
+      TYPE(obswriinfo), OPTIONAL :: pext               ! Extra info
+
+      !! * Local declarations
+      TYPE(obfbdata) :: fbdata
+      CHARACTER(LEN=40) :: clfname         ! netCDF filename
+      CHARACTER(LEN=10) :: clfiletype
+      CHARACTER(LEN=12), PARAMETER :: cpname = 'obs_wri_surf'
+      INTEGER :: jo
+      INTEGER :: ja
+      INTEGER :: je
+      INTEGER :: iadd
+      INTEGER :: iext
+
+      IF ( PRESENT( padd ) ) THEN
+         iadd = padd%inum
+      ELSE
+         iadd = 0
+      ENDIF
+
+      IF ( PRESENT( pext ) ) THEN
+         iext = pext%inum
+      ELSE
+         iext = 0
+      ENDIF
+
+      CALL init_obfbdata( fbdata )
+
+      SELECT CASE ( TRIM(surfdata%cvars(1)) )
+      CASE('SLA')
+
+         CALL alloc_obfbdata( fbdata, 1, surfdata%nsurf, 1, &
+            &                 2 + iadd, 1 + iext, .TRUE. )
+
+         clfiletype = 'slafb'
+         fbdata%cname(1)      = surfdata%cvars(1)
+         fbdata%coblong(1)    = 'Sea level anomaly'
+         fbdata%cobunit(1)    = 'Metres'
+         fbdata%cextname(1)   = 'MDT'
+         fbdata%cextlong(1)   = 'Mean dynamic topography'
+         fbdata%cextunit(1)   = 'Metres'
+         DO je = 1, iext
+            fbdata%cextname(je) = pext%cdname(je)
+            fbdata%cextlong(je) = pext%cdlong(je,1)
+            fbdata%cextunit(je) = pext%cdunit(je,1)
+         END DO
+         fbdata%caddlong(1,1) = 'Model interpolated SSH - MDT'
+         fbdata%caddunit(1,1) = 'Metres' 
+         fbdata%caddname(2)   = 'SSH'
+         fbdata%caddlong(2,1) = 'Model Sea surface height'
+         fbdata%caddunit(2,1) = 'Metres'
+         fbdata%cgrid(1)      = 'T'
+         DO ja = 1, iadd
+            fbdata%caddname(2+ja) = padd%cdname(ja)
+            fbdata%caddlong(2+ja,1) = padd%cdlong(ja,1)
+            fbdata%caddunit(2+ja,1) = padd%cdunit(ja,1)
+         END DO
+
+      CASE('SST')
+
+         CALL alloc_obfbdata( fbdata, 1, surfdata%nsurf, 1, &
+            &                 1 + iadd, iext, .TRUE. )
+
+         clfiletype = 'sstfb'
+         fbdata%cname(1)      = surfdata%cvars(1)
+         fbdata%coblong(1)    = 'Sea surface temperature'
+         fbdata%cobunit(1)    = 'Degree centigrade'
+         DO je = 1, iext
+            fbdata%cextname(je) = pext%cdname(je)
+            fbdata%cextlong(je) = pext%cdlong(je,1)
+            fbdata%cextunit(je) = pext%cdunit(je,1)
+         END DO
+         fbdata%caddlong(1,1) = 'Model interpolated SST'
+         fbdata%caddunit(1,1) = 'Degree centigrade'
+         fbdata%cgrid(1)      = 'T'
+         DO ja = 1, iadd
+            fbdata%caddname(1+ja) = padd%cdname(ja)
+            fbdata%caddlong(1+ja,1) = padd%cdlong(ja,1)
+            fbdata%caddunit(1+ja,1) = padd%cdunit(ja,1)
+         END DO
+
+      CASE('ICECONC')
+
+         CALL alloc_obfbdata( fbdata, 1, surfdata%nsurf, 1, &
+            &                 1 + iadd, iext, .TRUE. )
+
+         clfiletype = 'sicfb'
+         fbdata%cname(1)      = surfdata%cvars(1)
+         fbdata%coblong(1)    = 'Sea ice'
+         fbdata%cobunit(1)    = 'Fraction'
+         DO je = 1, iext
+            fbdata%cextname(je) = pext%cdname(je)
+            fbdata%cextlong(je) = pext%cdlong(je,1)
+            fbdata%cextunit(je) = pext%cdunit(je,1)
+         END DO
+         fbdata%caddlong(1,1) = 'Model interpolated ICE'
+         fbdata%caddunit(1,1) = 'Fraction'
+         fbdata%cgrid(1)      = 'T'
+         DO ja = 1, iadd
+            fbdata%caddname(1+ja) = padd%cdname(ja)
+            fbdata%caddlong(1+ja,1) = padd%cdlong(ja,1)
+            fbdata%caddunit(1+ja,1) = padd%cdunit(ja,1)
+         END DO
+
+      CASE('SSS')
+
+         CALL alloc_obfbdata( fbdata, 1, surfdata%nsurf, 1, &
+            &                 1 + iadd, iext, .TRUE. )
+
+         clfiletype = 'sssfb'
+         fbdata%cname(1)      = surfdata%cvars(1)
+         fbdata%coblong(1)    = 'Sea surface salinity'
+         fbdata%cobunit(1)    = 'psu'
+         DO je = 1, iext
+            fbdata%cextname(je) = pext%cdname(je)
+            fbdata%cextlong(je) = pext%cdlong(je,1)
+            fbdata%cextunit(je) = pext%cdunit(je,1)
+         END DO
+         fbdata%caddlong(1,1) = 'Model interpolated SSS'
+         fbdata%caddunit(1,1) = 'psu'
+         fbdata%cgrid(1)      = 'T'
+         DO ja = 1, iadd
+            fbdata%caddname(1+ja) = padd%cdname(ja)
+            fbdata%caddlong(1+ja,1) = padd%cdlong(ja,1)
+            fbdata%caddunit(1+ja,1) = padd%cdunit(ja,1)
+         END DO
+
+      CASE DEFAULT
+
+         CALL ctl_stop( 'Unknown observation type '//TRIM(surfdata%cvars(1))//' in obs_wri_surf' )
+
+      END SELECT
+
+      fbdata%caddname(1)   = 'Hx'
+
+      WRITE(clfname, FMT="(A,'_fdbk_',I4.4,'.nc')") TRIM(clfiletype), nproc
+
+      IF(lwp) THEN
+         WRITE(numout,*)
+         WRITE(numout,*)'obs_wri_surf :'
+         WRITE(numout,*)'~~~~~~~~~~~~~'
+         WRITE(numout,*)'Writing '//TRIM(surfdata%cvars(1))//' feedback file : ',TRIM(clfname)
+      ENDIF
+
+      ! Transform surf data structure into obfbdata structure
+      fbdata%cdjuldref = '19500101000000'
+      DO jo = 1, surfdata%nsurf
+         fbdata%plam(jo)      = surfdata%rlam(jo)
+         fbdata%pphi(jo)      = surfdata%rphi(jo)
+         WRITE(fbdata%cdtyp(jo),'(I4)') surfdata%ntyp(jo)
+         fbdata%ivqc(jo,:)    = 0
+         fbdata%ivqcf(:,jo,:) = 0
+         IF ( surfdata%nqc(jo) > 255 ) THEN
+            fbdata%ioqc(jo)    = 4
+            fbdata%ioqcf(1,jo) = 0
+!$AGRIF_DO_NOT_TREAT
+            fbdata%ioqcf(2,jo) = IAND(surfdata%nqc(jo),b'0000000011111111')
+!$AGRIF_END_DO_NOT_TREAT
+         ELSE
+            fbdata%ioqc(jo)    = surfdata%nqc(jo)
+            fbdata%ioqcf(:,jo) = 0
+         ENDIF
+         fbdata%ipqc(jo)      = 0
+         fbdata%ipqcf(:,jo)   = 0
+         fbdata%itqc(jo)      = 0
+         fbdata%itqcf(:,jo)   = 0
+         fbdata%cdwmo(jo)     = surfdata%cwmo(jo)
+         fbdata%kindex(jo)    = surfdata%nsfil(jo)
+         IF (ln_grid_global) THEN
+            fbdata%iobsi(jo,1) = surfdata%mi(jo)
+            fbdata%iobsj(jo,1) = surfdata%mj(jo)
+         ELSE
+            fbdata%iobsi(jo,1) = mig(surfdata%mi(jo))
+            fbdata%iobsj(jo,1) = mjg(surfdata%mj(jo))
+         ENDIF
+         CALL greg2jul( 0, &
+            &           surfdata%nmin(jo), &
+            &           surfdata%nhou(jo), &
+            &           surfdata%nday(jo), &
+            &           surfdata%nmon(jo), &
+            &           surfdata%nyea(jo), &
+            &           fbdata%ptim(jo),   &
+            &           krefdate = 19500101 )
+         fbdata%padd(1,jo,1,1) = surfdata%rmod(jo,1)
+         IF ( TRIM(surfdata%cvars(1)) == 'SLA' ) fbdata%padd(1,jo,2,1) = surfdata%rext(jo,1)
+         fbdata%pob(1,jo,1)    = surfdata%robs(jo,1) 
+         fbdata%pdep(1,jo)     = 0.0
+         fbdata%idqc(1,jo)     = 0
+         fbdata%idqcf(:,1,jo)  = 0
+         IF ( surfdata%nqc(jo) > 255 ) THEN
+            fbdata%ivqc(jo,1)       = 4
+            fbdata%ivlqc(1,jo,1)    = 4
+            fbdata%ivlqcf(1,1,jo,1) = 0
+!$AGRIF_DO_NOT_TREAT
+            fbdata%ivlqcf(2,1,jo,1) = IAND(surfdata%nqc(jo),b'0000000011111111')
+!$AGRIF_END_DO_NOT_TREAT
+         ELSE
+            fbdata%ivqc(jo,1)       = surfdata%nqc(jo)
+            fbdata%ivlqc(1,jo,1)    = surfdata%nqc(jo)
+            fbdata%ivlqcf(:,1,jo,1) = 0
+         ENDIF
+         fbdata%iobsk(1,jo,1)  = 0
+         IF ( TRIM(surfdata%cvars(1)) == 'SLA' ) fbdata%pext(1,jo,1) = surfdata%rext(jo,2)
+         DO ja = 1, iadd
+            fbdata%padd(1,jo,2+ja,1) = &
+               & surfdata%rext(jo,padd%ipoint(ja))
+         END DO
+         DO je = 1, iext
+            fbdata%pext(1,jo,1+je) = &
+               & surfdata%rext(jo,pext%ipoint(je))
+         END DO
+      END DO
+
+      ! Write the obfbdata structure
+      CALL write_obfbdata( clfname, fbdata )
+
+      ! Output some basic statistics
+      CALL obs_wri_stats( fbdata )
+
+      CALL dealloc_obfbdata( fbdata )
+
+   END SUBROUTINE obs_wri_surf
+
+   SUBROUTINE obs_wri_stats( fbdata )
+      !!-----------------------------------------------------------------------
+      !!
+      !!                     *** ROUTINE obs_wri_stats  ***
+      !!
+      !! ** Purpose : Output some basic statistics of the data being written out
+      !!
+      !! ** Method  :
+      !! 
+      !! ** Action  :
+      !!
+      !!      ! 2014-08  (D. Lea) Initial version 
+      !!-----------------------------------------------------------------------
+
+      !! * Arguments
+      TYPE(obfbdata) :: fbdata
+
+      !! * Local declarations
+      INTEGER :: jvar
+      INTEGER :: jo
+      INTEGER :: jk
+      INTEGER :: inumgoodobs
+      INTEGER :: inumgoodobsmpp
+      REAL(wp) :: zsumx
+      REAL(wp) :: zsumx2
+      REAL(wp) :: zomb
+      
+
+      IF (lwp) THEN
+         WRITE(numout,*) ''
+         WRITE(numout,*) 'obs_wri_stats :'
+         WRITE(numout,*) '~~~~~~~~~~~~~~~'
+      ENDIF
+
+      DO jvar = 1, fbdata%nvar
+         zsumx=0.0_wp
+         zsumx2=0.0_wp
+         inumgoodobs=0
+         DO jo = 1, fbdata%nobs
+            DO jk = 1, fbdata%nlev
+               IF ( ( fbdata%pob(jk,jo,jvar) < 9999.0 ) .AND. &
+                  & ( fbdata%pdep(jk,jo) < 9999.0 ) .AND. &
+                  & ( fbdata%padd(jk,jo,1,jvar) < 9999.0 ) ) THEN
+
+                  zomb=fbdata%pob(jk, jo, jvar)-fbdata%padd(jk, jo, 1, jvar)
+                  zsumx=zsumx+zomb
+                  zsumx2=zsumx2+zomb**2
+                  inumgoodobs=inumgoodobs+1
+               ENDIF
+            ENDDO
+         ENDDO
+
+         CALL obs_mpp_sum_integer( inumgoodobs, inumgoodobsmpp )
+         CALL mpp_sum(zsumx)
+         CALL mpp_sum(zsumx2)
+
+         IF (lwp) THEN
+            WRITE(numout,*) 'Type: ',fbdata%cname(jvar),'  Total number of good observations: ',inumgoodobsmpp 
+            WRITE(numout,*) 'Overall mean obs minus model of the good observations: ',zsumx/inumgoodobsmpp
+            WRITE(numout,*) 'Overall RMS obs minus model of the good observations: ',sqrt( zsumx2/inumgoodobsmpp )
+            WRITE(numout,*) ''
+         ENDIF
+
+      ENDDO
+
+   END SUBROUTINE obs_wri_stats
+
+END MODULE obs_write
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/obsinter_h2d.h90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/obsinter_h2d.h90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/obsinter_h2d.h90	(revision 9570)
@@ -0,0 +1,1360 @@
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO Consortium (2010)
+   !! $Id$
+   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+
+   SUBROUTINE obs_int_h2d_init( kpk,   kpk2,  k2dint, plam,  pphi, &
+      &                         pglam, pgphi, pmask,  pweig, pobsmask, &
+      &                         iminpoints )
+      !!-----------------------------------------------------------------------
+      !!
+      !!                     ***  ROUTINE obs_int_h2d  ***
+      !!
+      !! ** Purpose : Computes weights for horizontal interpolation to the 
+      !!              observation point.
+      !!
+      !! ** Method  : Horizontal interpolation to the observation point using
+      !!              model values at the corners of the surrounding grid 
+      !!              points.
+      !!
+      !!    Interpolation Schemes : 
+      !!
+      !!    1) k2dint = 0: Distance-weighted interpolation scheme 1
+      !!
+      !!       The interpolation weights are computed as a weighted 
+      !!       sum of the distance between the model grid points (A)
+      !!       and the observation point (B). Distance (s) is computed 
+      !!       using the great-circle distance formula: 
+      !!
+      !!       s(AB) = arcos(   sin( phiA ) x sin( phiB )
+      !!                      + cos( phiA ) x cos( phiB ) 
+      !!                                    x cos( lamB - lamA ) )
+      !!
+      !!    2) k2dint = 1: Distance-weighted interpolation scheme 2
+      !!
+      !!       As k2dint = 0 but with distance (ds) computed using 
+      !!       a small-angle approximation to the great-circle formula:
+      !!
+      !!       ds(AB) = sqrt(   ( phiB - phiA )^{2} 
+      !!                    + ( ( lamB - lamA ) * cos( phiB ) )^{2} )
+      !!
+      !!    3) k2dint = 2: Bilinear interpolation on a geographical grid
+      !!
+      !!       The interpolation is split into two 1D interpolations in
+      !!       the longitude and latitude directions, respectively.
+      !!
+      !!    4) k2dint = 3: General bilinear remapping interpolation
+      !!
+      !!       An iterative scheme that involves first mapping a 
+      !!       quadrilateral cell into a cell with coordinates 
+      !!       (0,0), (1,0), (0,1) and (1,1).
+      !!
+      !!    5) k2dint = 4: Polynomial interpolation
+      !!
+      !!       The interpolation weights are computed by fitting a 
+      !!       polynomial function of the form 
+      !!              
+      !!       P(i) = a1(i) + a2(i) * phi + a3(i) * plam 
+      !!                                  + a4(i) * phi * plam
+      !!    
+      !!       through the model values at the four surrounding grid points.
+      !!
+      !! ** Action  :
+      !!                   
+      !! References : Jones, P.: A users guide for SCRIP: A Spherical 
+      !!                        Coordinate Remapping and Interpolation Package.
+      !!                        Version 1.4. Los Alomos. 
+      !!                    
+      !!       http://www.acl.lanl.gov/climate/software/SCRIP/SCRIPmain.html
+      !!
+      !! History :
+      !!        ! 97-11 (A. Weaver, N. Daget)
+      !!        ! 06-03 (A. Vidard) NEMOVAR migration
+      !!        ! 06-10 (A. Weaver) Cleanup
+      !!        ! 07-08 (K. Mogensen) Split in two routines for easier adj.
+      !!-----------------------------------------------------------------------
+      !! * Modules used
+      !! * Arguments
+      INTEGER, INTENT(IN) :: &
+         & kpk,   &             ! Parameter values for automatic arrays
+         & kpk2,  &        
+         & k2dint               ! Interpolation scheme options
+                                ! = 0 distance-weighted (great circle)
+                                ! = 1 distance-weighted (small angle)
+                                ! = 2 bilinear (geographical grid)
+                                ! = 3 bilinear (quadrilateral grid)
+                                ! = 4 polynomial (quadrilateral grid)
+      REAL(KIND=wp), INTENT(INOUT) :: &
+         & plam, &
+         & pphi                 ! Geographical (lat,lon) coordinates of
+                                ! observation
+      REAL(KIND=wp), DIMENSION(2,2), INTENT(IN) :: &
+         & pglam, &             ! Model variable lat
+         & pgphi                ! Model variable lon
+      REAL(KIND=wp), DIMENSION(2,2,kpk2), INTENT(IN) :: &
+         & pmask                ! Model variable mask
+      REAL(KIND=wp), DIMENSION(2,2,kpk2), INTENT(OUT) ::  &
+         & pweig                ! Weights for interpolation
+      REAL(KIND=wp), DIMENSION(kpk2), INTENT(OUT) ::  &
+         & pobsmask             ! Vertical mask for observations
+      INTEGER, INTENT(IN), OPTIONAL :: &
+         & iminpoints           ! Reject point which is not surrounded
+                                ! by at least iminpoints sea points
+
+      !! * Local declarations
+      INTEGER :: &
+         & jk
+      INTEGER :: &
+         & ikmax, &
+         & iamb1, &
+         & iamb2
+      REAL(KIND=wp) :: &
+         & zphimm,  &
+         & zphimp,  &
+         & zphipm,  &
+         & zphipp,  &
+         & zlammm,  &
+         & zlammp,  &
+         & zlampm,  &
+         & zlampp,  &
+         & zphimin, &
+         & zphimax, &
+         & zlammin, &
+         & zlammax
+      REAL(KIND=wp), DIMENSION(kpk2) :: &
+         & z2dmm,  &
+         & z2dmp,  &
+         & z2dpm,  &
+         & z2dpp,  &
+         & z2dmmt, &
+         & z2dmpt, &
+         & z2dpmt, &
+         & z2dppt, &
+         & zsum
+      LOGICAL :: &
+         & ll_ds1, &
+         & ll_skip, &
+         & ll_fail
+       
+      !------------------------------------------------------------------------
+      ! Constants for the 360 degrees ambiguity
+      !------------------------------------------------------------------------
+      iamb1 = 10   ! dlam < iamb1 * dphi
+      iamb2 = 3    ! Special treatment if iamb2 * lam < max(lam) 
+       
+      !------------------------------------------------------------------------
+      ! Initialize number of levels
+      !------------------------------------------------------------------------
+      IF ( kpk2 == 1 ) THEN
+         ikmax = 1
+      ELSEIF ( kpk2 == kpk) THEN
+         ikmax = kpk-1
+      ENDIF
+      !------------------------------------------------------------------------
+      ! Initialize the cell corners
+      !------------------------------------------------------------------------
+      zphimm = pgphi(1,1)
+      zphimp = pgphi(1,2)
+      zphipm = pgphi(2,1)
+      zphipp = pgphi(2,2)
+      zlammm = pglam(1,1)
+      zlammp = pglam(1,2)
+      zlampm = pglam(2,1)
+      zlampp = pglam(2,2)
+       
+      !------------------------------------------------------------------------
+      ! Treat the 360 degrees ambiguity
+      !------------------------------------------------------------------------
+      DO WHILE ( ( zlammm < 0.0_wp ).OR.( zlammm > 360.0_wp )  &
+         &   .OR.( zlampm < 0.0_wp ).OR.( zlampm > 360.0_wp )  &
+         &   .OR.( zlampp < 0.0_wp ).OR.( zlampp > 360.0_wp )  &
+         &   .OR.( zlammp < 0.0_wp ).OR.( zlammp > 360.0_wp ) )
+       
+         IF ( zlammm < 0.0_wp   ) zlammm = zlammm + 360.0_wp
+         IF ( zlammm > 360.0_wp ) zlammm = zlammm - 360.0_wp
+         IF ( zlammp < 0.0_wp   ) zlammp = zlammp + 360.0_wp
+         IF ( zlammp > 360.0_wp ) zlammp = zlammp - 360.0_wp
+         IF ( zlampm < 0.0_wp   ) zlampm = zlampm + 360.0_wp
+         IF ( zlampm > 360.0_wp ) zlampm = zlampm - 360.0_wp
+         IF ( zlampp < 0.0_wp   ) zlampp = zlampp + 360.0_wp
+         IF ( zlampp > 360.0_wp ) zlampp = zlampp - 360.0_wp
+       
+      END DO
+
+      DO WHILE ( ( plam < 0.0_wp ) .OR. ( plam > 360.0_wp ) )
+         IF ( plam < 0.0_wp   ) plam = plam + 360.0_wp
+         IF ( plam > 360.0_wp ) plam = plam - 360.0_wp
+      END DO
+
+      !------------------------------------------------------------------------
+      ! Special case for observation on grid points
+      !------------------------------------------------------------------------
+      ll_skip = .FALSE.
+      IF ( ( ABS( zphimm - pphi ) < 1.0e-6_wp ) .AND. &
+         & ( ABS( zlammm - plam ) < 1.0e-6_wp ) ) THEN
+         z2dmm(:) = 1.0_wp
+         z2dpm(:) = 0.0_wp
+         z2dmp(:) = 0.0_wp
+         z2dpp(:) = 0.0_wp
+         ll_skip = .TRUE.
+      ENDIF
+      IF ( ( ABS( zphipm - pphi ) < 1.0e-6_wp ) .AND. &
+         & ( ABS( zlampm - plam ) < 1.0e-6_wp ) ) THEN
+         z2dmm(:) = 0.0_wp
+         z2dpm(:) = 1.0_wp
+         z2dmp(:) = 0.0_wp
+         z2dpp(:) = 0.0_wp
+         ll_skip = .TRUE.
+      ENDIF
+      IF ( ( ABS( zphimp - pphi ) < 1.0e-6_wp ) .AND. &
+         & ( ABS( zlammp - plam ) < 1.0e-6_wp ) ) THEN
+         z2dmm(:) = 0.0_wp
+         z2dpm(:) = 0.0_wp
+         z2dmp(:) = 1.0_wp
+         z2dpp(:) = 0.0_wp
+         ll_skip = .TRUE.
+      ENDIF
+      IF ( ( ABS( zphipp - pphi ) < 1.0e-6_wp ) .AND. &
+         & ( ABS( zlampp - plam ) < 1.0e-6_wp ) ) THEN
+         z2dmm(:) = 0.0_wp
+         z2dpm(:) = 0.0_wp
+         z2dmp(:) = 0.0_wp
+         z2dpp(:) = 1.0_wp
+         ll_skip = .TRUE.
+      ENDIF
+
+      IF ( .NOT.ll_skip ) THEN
+
+         zphimin = MIN( zphimm, zphipm, zphipp, zphimp )
+         zphimax = MAX( zphimm, zphipm, zphipp, zphimp )
+         zlammin = MIN( zlammm, zlampm, zlampp, zlammp )
+         zlammax = MAX( zlammm, zlampm, zlampp, zlammp )
+
+         IF ( ( ( zlammax - zlammin ) / ( zphimax - zphimin ) ) > iamb1 ) THEN
+            IF ( iamb2 * zlammm < zlammax ) zlammm = zlammm + 360.0_wp
+            IF ( iamb2 * zlammp < zlammax ) zlammp = zlammp + 360.0_wp
+            IF ( iamb2 * zlampm < zlammax ) zlampm = zlampm + 360.0_wp
+            IF ( iamb2 * zlampp < zlammax ) zlampp = zlampp + 360.0_wp
+         ENDIF
+
+         zlammin = MIN( zlammm, zlampm, zlampp, zlammp )
+         IF ( zlammm > ( zlammin + 180.0_wp ) ) zlammm = zlammm - 360.0_wp
+         IF ( zlammp > ( zlammin + 180.0_wp ) ) zlammp = zlammp - 360.0_wp
+         IF ( zlampm > ( zlammin + 180.0_wp ) ) zlampm = zlampm - 360.0_wp
+         IF ( zlampp > ( zlammin + 180.0_wp ) ) zlampp = zlampp - 360.0_wp
+         
+         IF ( plam < zlammin ) plam = plam + 360.0_wp
+	   z2dmm = 0.0_wp
+	   z2dmp = 0.0_wp
+	   z2dpm = 0.0_wp
+	   z2dpp = 0.0_wp
+         SELECT CASE (k2dint)
+            
+         CASE(0)
+            CALL obs_int_h2d_ds1( kpk2, ikmax,                        &
+               &                  pphi, plam, pmask,                  &
+               &                  zphimm, zlammm, zphimp, zlammp,     & 
+               &                  zphipm, zlampm, zphipp, zlampp,     &
+               &                  z2dmm, z2dmp, z2dpm, z2dpp )
+         CASE(1)
+            CALL obs_int_h2d_ds2( kpk2, ikmax,                        &
+               &                  pphi, plam, pmask,                  &
+               &                  zphimm, zlammm, zphimp, zlammp,     &
+               &                  zphipm, zlampm, zphipp, zlampp,     &
+               &                  z2dmm, z2dmp, z2dpm, z2dpp )
+         CASE(2)
+            CALL obs_int_h2d_bil( kpk2, ikmax,                        &
+               &                  pphi, plam, pmask,                  &
+               &                                          zlammp,     &
+               &                  zphipm,         zphipp, zlampp,     &
+               &                  z2dmm, z2dmp, z2dpm, z2dpp )
+         CASE(3)
+            CALL obs_int_h2d_bir( kpk2, ikmax,                        &
+               &                  pphi, plam, pmask,                  &
+               &                  zphimm, zlammm, zphimp, zlammp,     &
+               &                  zphipm, zlampm, zphipp, zlampp,     &
+               &                  z2dmm, z2dmp, z2dpm, z2dpp, ll_fail )
+            IF (ll_fail) THEN
+               IF(lwp) THEN
+                  WRITE(numout,*)'Bilinear weight computation failed'
+                  WRITE(numout,*)'Switching to great circle distance'
+                  WRITE(numout,*)
+               ENDIF
+               CALL obs_int_h2d_ds1( kpk2, ikmax,                        &
+                  &                  pphi, plam, pmask,                  &
+                  &                  zphimm, zlammm, zphimp, zlammp,     & 
+                  &                  zphipm, zlampm, zphipp, zlampp,     &
+                  &                  z2dmm, z2dmp, z2dpm, z2dpp )
+            ENDIF
+         CASE(4)  
+            CALL obs_int_h2d_pol( kpk2, ikmax,                        &
+               &                  pphi, plam, pmask,                  &
+               &                  zphimm, zlammm, zphimp, zlammp,     &
+               &                  zphipm, zlampm, zphipp, zlampp,     & 
+               &                  z2dmm, z2dmp, z2dpm, z2dpp )
+         END SELECT
+
+      ENDIF
+      !------------------------------------------------------------------------
+      ! Compute weights for interpolation to the observation point
+      !------------------------------------------------------------------------
+      pobsmask(:) = 0.0_wp
+      pweig(:,:,:) = 0.0_wp
+      ! ll_ds1 is used for failed interpolations
+      ll_ds1 = .FALSE.
+      DO jk = 1, ikmax
+         IF (PRESENT(iminpoints)) THEN
+            IF (NINT(SUM(pmask(:,:,jk)))<iminpoints) CYCLE
+         ENDIF
+         zsum(jk) = z2dmm(jk) + z2dmp(jk) + z2dpm(jk) + z2dpp(jk) 
+         IF ( zsum(jk) /= 0.0_wp ) THEN
+            pweig(1,1,jk) = z2dmm(jk) 
+            pweig(1,2,jk) = z2dmp(jk)
+            pweig(2,1,jk) = z2dpm(jk)
+            pweig(2,2,jk) = z2dpp(jk)
+            ! Set the vertical mask
+            IF ( ( ( z2dmm(jk) > 0.0_wp ) .AND.       &
+               &   ( pmask(1,1,jk) == 1.0_wp ) ) .OR. &
+               & ( ( z2dmp(jk) > 0.0_wp ) .AND.       &
+               &   ( pmask(1,2,jk) == 1.0_wp ) ) .OR. &
+               & ( ( z2dpm(jk) > 0.0_wp ) .AND.       &
+               &   ( pmask(2,1,jk) == 1.0_wp ) ) .OR. &
+               & ( ( z2dpp(jk) > 0.0_wp ) .AND.       &
+               &   ( pmask(2,2,jk) == 1.0_wp ) ) ) pobsmask(jk)=1.0_wp
+         ELSE
+            ! If the interpolation has failed due to the point
+            ! being on the intersect of two land points retry with
+            ! k2dint = 0
+            IF ( ( pmask(1,1,jk) /= 0.0_wp ).OR. &
+               & ( pmask(1,2,jk) /= 0.0_wp ).OR. &
+               & ( pmask(2,1,jk) /= 0.0_wp ).OR. &
+               & ( pmask(2,2,jk) /= 0.0_wp ) ) THEN
+               ! If ll_ds1 is false compute k2dint = 0 weights
+               IF ( .NOT.ll_ds1 ) THEN
+                  CALL obs_int_h2d_ds1( kpk2, ikmax,                        &
+                     &                  pphi, plam, pmask,                  &
+                     &                  zphimm, zlammm, zphimp, zlammp,     & 
+                     &                  zphipm, zlampm, zphipp, zlampp,     &
+                     &                  z2dmmt, z2dmpt, z2dpmt, z2dppt ) 
+                  ll_ds1 = .TRUE.
+               ENDIF
+               zsum(jk) = z2dmmt(jk) + z2dmpt(jk) + z2dpmt(jk) + z2dppt(jk) 
+               IF ( zsum(jk) /= 0.0_wp ) THEN
+                  pweig(1,1,jk) = z2dmmt(jk) 
+                  pweig(1,2,jk) = z2dmpt(jk)
+                  pweig(2,1,jk) = z2dpmt(jk)
+                  pweig(2,2,jk) = z2dppt(jk)
+                  ! Set the vertical mask
+                  IF ( ( ( z2dmmt(jk) > 0.0_wp ) .AND.      &
+                     &   ( pmask(1,1,jk) == 1.0_wp ) ) .OR. &
+                     & ( ( z2dmpt(jk) > 0.0_wp ) .AND.      &
+                     &   ( pmask(1,2,jk) == 1.0_wp ) ) .OR. &
+                     & ( ( z2dpmt(jk) > 0.0_wp) .AND.      &
+                     &   ( pmask(2,1,jk) == 1.0_wp ) ) .OR. &
+                     & ( ( z2dppt(jk) > 0.0_wp ) .AND.      &
+                     &   ( pmask(2,2,jk) == 1.0_wp ) ) )    &
+                     & pobsmask(jk)=1.0_wp
+               ENDIF
+            ENDIF
+         ENDIF
+      END DO
+  
+   END SUBROUTINE obs_int_h2d_init
+
+   SUBROUTINE obs_int_h2d( kpk, kpk2, &
+      &                    pweig, pmod, pobsk )
+      !!-----------------------------------------------------------------------
+      !!
+      !!                     ***  ROUTINE obs_int_h2d  ***
+      !!
+      !! ** Purpose : Horizontal interpolation to the observation point.
+      !!
+      !! ** Method  : Horizontal interpolation to the observation point using
+      !!              model values at the corners of the surrounding grid 
+      !!              points.
+      !!
+      !! ** Action  :
+      !!                   
+      !! References : 
+      !!
+      !! History :
+      !!        ! 97-11 (A. Weaver, N. Daget)
+      !!        ! 06-03 (A. Vidard) NEMOVAR migration
+      !!        ! 06-10 (A. Weaver) Cleanup
+      !!        ! 07-08 (K. Mogensen) Split in two routines for easier adj.
+      !!-----------------------------------------------------------------------
+      !! * Modules used
+      !! * Arguments
+      INTEGER, INTENT(IN) :: &
+         & kpk,   &             ! Parameter values for automatic arrays
+         & kpk2
+      REAL(KIND=wp), DIMENSION(2,2,kpk2), INTENT(IN) :: &
+         & pweig                ! Interpolation weights
+      REAL(KIND=wp), DIMENSION(2,2,kpk2), INTENT(IN) :: &
+         & pmod                 ! Model variable to interpolate
+      REAL(KIND=wp), DIMENSION(kpk2), INTENT(OUT) ::  &
+         & pobsk                ! Model profile interpolated to obs (i,j) pt
+
+      !! * Local declarations
+      INTEGER :: &
+         & jk
+      INTEGER :: &
+         & ikmax
+      REAL(KIND=wp) :: &
+         & zsum
+      !------------------------------------------------------------------------
+      ! Initialize number of levels
+      !------------------------------------------------------------------------
+      IF ( kpk2 == 1 ) THEN
+         ikmax = 1
+      ELSEIF ( kpk2 == kpk) THEN
+         ikmax = kpk-1
+      ENDIF
+      !------------------------------------------------------------------------
+      ! Interpolate to the observation point
+      !------------------------------------------------------------------------
+      pobsk(:) = obfillflt
+      DO jk = 1, ikmax
+         zsum = pweig(1,1,jk) + pweig(1,2,jk) + pweig(2,1,jk) +  pweig(2,2,jk) 
+         IF ( zsum /= 0.0_wp ) THEN
+            pobsk(jk) = (  pweig(1,1,jk) * pmod(1,1,jk)         &
+               &         + pweig(1,2,jk) * pmod(1,2,jk)         &
+               &         + pweig(2,1,jk) * pmod(2,1,jk)         &
+               &         + pweig(2,2,jk) * pmod(2,2,jk)         &
+               &                                             ) / zsum
+         ENDIF
+      END DO
+
+   END SUBROUTINE obs_int_h2d
+  
+   SUBROUTINE obs_int_h2d_ds1( kpk2, kmax,                        &
+      &                        pphi, plam, pmask,                 &
+      &                        pphimm, plammm, pphimp, plammp,    & 
+      &                        pphipm, plampm, pphipp, plampp,    &
+      &                        p2dmm, p2dmp, p2dpm, p2dpp )
+      !!-----------------------------------------------------------------------
+      !!
+      !!                     ***  ROUTINE obs_int_h2d_ds1  ***
+      !!
+      !! ** Purpose : Distance-weighted interpolation scheme (k2dint = 0)
+      !!
+      !! ** Method  : The interpolation weights are computed as a weighted 
+      !!              sum of the distance between the model grid points (A) 
+      !!              and the observation point (B). 
+      !!
+      !!    Distance (s) is computed using the great-circle distance formula:
+      !!
+      !!    s(AB) = arcos(   sin( phiA ) x sin( phiB )
+      !!                   + cos( phiA ) x cos( phiB ) x cos( lamB - lamA )
+      !!
+      !! ** Action  :
+      !!
+      !! History :
+      !!        ! 97-11 (A. Weaver, N. Daget)
+      !!        ! 06-10 (A. Weaver) Cleanup
+      !!-----------------------------------------------------------------------
+
+      !! * Modules used
+
+      !! * Arguments
+      INTEGER, INTENT(IN) :: &
+         & kpk2, &             ! Parameter values for automatic arrays
+         & kmax
+      REAL(KIND=wp), INTENT(IN) :: &
+         & pphi,   &           ! Geographical location of observation
+         & plam,   &
+         & pphimm, &           ! Geographical location of surrounding
+         & pphimp, &           ! model grid points
+         & pphipm, &
+         & pphipp, & 
+         & plammm, &
+         & plammp, &
+         & plampm, &
+         & plampp
+      REAL(KIND=wp), DIMENSION(2,2,kpk2), INTENT(IN) :: &
+         & pmask               ! Model variable mask 
+      REAL(KIND=wp), DIMENSION(kpk2), INTENT(OUT) :: &
+         & p2dmm, &            ! Interpolation weights
+         & p2dmp, &
+         & p2dpm, &
+         & p2dpp
+
+      !! * Local declarations
+      INTEGER :: &
+         & jk
+      REAL(KIND=wp) :: &
+         & zphi2,   &
+         & zlam2,   &
+         & zcola,   &
+         & za2,     &
+         & zb2,     &
+         & zc2,     &
+         & zphimm2, &
+         & zphimp2, &
+         & zphipm2, &
+         & zphipp2, &
+         & zlammm2, &
+         & zlammp2, &
+         & zlampm2, &
+         & zlampp2, &
+         & za1mm,   &
+         & za1mp,   &
+         & za1pm,   &
+         & za1pp,   &
+         & zcomm,   &
+         & zcomp,   &
+         & zcopm,   &
+         & zcopp,   &
+         & zb1mm,   &
+         & zb1mp,   &
+         & zb1pm,   &
+         & zb1pp,   &
+         & zc1mm,   &
+         & zc1mp,   &
+         & zc1pm,   &
+         & zc1pp,   &
+         & zsopmpp, &
+         & zsommmp, &
+         & zsomm,   &
+         & zsomp,   &
+         & zsopm,   &
+         & zsopp
+       
+      !------------------------------------------------------------------------
+      ! Distance-weighted interpolation using the great circle formula
+      !------------------------------------------------------------------------
+      zphi2 = pphi * rad
+      zlam2 = plam * rad
+      zcola = COS( zphi2 )
+      za2   = SIN( zphi2 )
+      zb2   = zcola * COS( zlam2 )
+      zc2   = zcola * SIN( zlam2 )
+       
+      zphimm2 = pphimm * rad
+      zphimp2 = pphimp * rad
+      zphipm2 = pphipm * rad
+      zphipp2 = pphipp * rad
+       
+      zlammm2 = plammm * rad
+      zlammp2 = plammp * rad
+      zlampm2 = plampm * rad
+      zlampp2 = plampp * rad
+       
+      za1mm = SIN( zphimm2 )
+      za1mp = SIN( zphimp2 )
+      za1pm = SIN( zphipm2 )
+      za1pp = SIN( zphipp2 )
+       
+      zcomm = COS( zphimm2 )
+      zcomp = COS( zphimp2 )
+      zcopm = COS( zphipm2 )
+      zcopp = COS( zphipp2 )
+       
+      zb1mm = zcomm * COS( zlammm2 )
+      zb1mp = zcomp * COS( zlammp2 )
+      zb1pm = zcopm * COS( zlampm2 )
+      zb1pp = zcopp * COS( zlampp2 )
+       
+      zc1mm = zcomm * SIN( zlammm2 )
+      zc1mp = zcomp * SIN( zlammp2 )
+      zc1pm = zcopm * SIN( zlampm2 )
+      zc1pp = zcopp * SIN( zlampp2 )
+       
+      ! Function for arcsin(sqrt(1-x^2) version of great-circle formula
+      zsomm = grt_cir_dis( za1mm, za2, zb1mm, zb2, zc1mm, zc2 )
+      zsomp = grt_cir_dis( za1mp, za2, zb1mp, zb2, zc1mp, zc2 )
+      zsopm = grt_cir_dis( za1pm, za2, zb1pm, zb2, zc1pm, zc2 )
+      zsopp = grt_cir_dis( za1pp, za2, zb1pp, zb2, zc1pp, zc2 )
+       
+      zsopmpp = zsopm * zsopp
+      zsommmp = zsomm * zsomp
+      DO jk = 1, kmax
+         p2dmm(jk) = zsomp * zsopmpp * pmask(1,1,jk)
+         p2dmp(jk) = zsomm * zsopmpp * pmask(1,2,jk) 
+         p2dpm(jk) = zsopp * zsommmp * pmask(2,1,jk)
+         p2dpp(jk) = zsopm * zsommmp * pmask(2,2,jk)
+      END DO
+       
+   END SUBROUTINE obs_int_h2d_ds1
+  
+   SUBROUTINE obs_int_h2d_ds2( kpk2, kmax,                        &
+      &                        pphi, plam, pmask,                 &
+      &                        pphimm, plammm, pphimp, plammp,    &
+      &                        pphipm, plampm, pphipp, plampp,    &
+      &                        p2dmm, p2dmp, p2dpm, p2dpp ) 
+      !!-----------------------------------------------------------------------
+      !!
+      !!                     ***  ROUTINE obs_int_h2d_ds2  ***
+      !!
+      !! ** Purpose : Distance-weighted interpolation scheme (k2dint = 1)
+      !!
+      !! ** Method  : As k2dint = 0 but with distance (ds) computed using a 
+      !!              small-angle approximation to the great-circle distance 
+      !!              formula:
+      !!
+      !!    ds(AB) = sqrt(   ( phiB - phiA )^{2}
+      !!                   + ( ( lamB - lamA ) * cos( phiB ) )^{2} )
+      !!
+      !! ** Action  :
+      !!
+      !! History :
+      !!        ! 97-11 (A. Weaver, N. Daget)
+      !!        ! 06-10 (A. Weaver) Cleanup
+      !!-----------------------------------------------------------------------
+
+      !!-----------------------------------------------------------------------
+      !! * Modules used
+      !!----------------------------------------------------------------------- 
+      !! * Arguments
+      INTEGER, INTENT(IN) :: &
+         & kpk2, &             ! Parameter values for automatic arrays
+         & kmax
+      REAL(KIND=wp), INTENT(IN) ::        &
+         & pphi,   &           ! Geographical location of observation
+         & plam,   &
+         & pphimm, &           ! Geographical location of surrounding
+         & pphimp, &           ! model grid points
+         & pphipm, &
+         & pphipp, & 
+         & plammm, &
+         & plammp, &
+         & plampm, &
+         & plampp
+      REAL(KIND=wp), DIMENSION(2,2,kpk2), INTENT(IN) :: &
+         & pmask               ! Model variable mask 
+      REAL(KIND=wp), DIMENSION(kpk2), INTENT(OUT) :: &
+         & p2dmm, &            ! Interpolation weights
+         & p2dmp, &
+         & p2dpm, &
+         & p2dpp
+
+      !! * Local declarations
+      INTEGER :: &
+         & jk
+      REAL(KIND=wp) :: &
+         & zcosp,   &
+         & zdlmm,   &
+         & zdlmp,   &
+         & zdlpm,   &
+         & zdlpp,   &
+         & zdpmm,   &
+         & zdpmp,   &
+         & zdppm,   &
+         & zdppp,   &
+         & zsomm,   &
+         & zsomp,   &
+         & zsopm,   &
+         & zsopp,   &
+         & zsopmpp, &
+         & zsommmp
+       
+      !------------------------------------------------------------------------
+      ! Distance-weighted interpolation with a small angle approximation
+      !------------------------------------------------------------------------
+      zcosp = COS( pphi * rad )
+       
+      zdlmm = plammm - plam
+      zdlmp = plammp - plam
+      zdlpm = plampm - plam
+      zdlpp = plampp - plam
+       
+      zdpmm = pphimm - pphi
+      zdpmp = pphimp - pphi
+      zdppm = pphipm - pphi
+      zdppp = pphipp - pphi
+       
+      zsomm = grt_cir_dis_saa( zdlmm, zdpmm, zcosp )
+      zsomp = grt_cir_dis_saa( zdlmp, zdpmp, zcosp )
+      zsopm = grt_cir_dis_saa( zdlpm, zdppm, zcosp )
+      zsopp = grt_cir_dis_saa( zdlpp, zdppp, zcosp )
+       
+      zsopmpp = zsopm * zsopp
+      zsommmp = zsomm * zsomp
+       
+      DO jk = 1, kmax
+         p2dmm(jk) = zsomp * zsopmpp * pmask(1,1,jk)
+         p2dmp(jk) = zsomm * zsopmpp * pmask(1,2,jk)
+         p2dpm(jk) = zsopp * zsommmp * pmask(2,1,jk)
+         p2dpp(jk) = zsopm * zsommmp * pmask(2,2,jk)
+      END DO
+       
+   END SUBROUTINE obs_int_h2d_ds2
+  
+   SUBROUTINE obs_int_h2d_bil( kpk2, kmax,                        &
+      &                        pphi, plam, pmask,                 &
+      &                        plammp, pphipm, pphipp, plampp,    &
+      &                        p2dmm, p2dmp, p2dpm, p2dpp)
+      !!-----------------------------------------------------------------------
+      !!
+      !!                     ***  ROUTINE obs_int_h2d_bil  ***
+      !!
+      !! ** Purpose : Bilinear interpolation on a geographical grid (k2dint = 2)
+      !!
+      !! ** Method  : The interpolation is split into two 1D interpolations in 
+      !!              the longitude and latitude directions, respectively.
+      !!
+      !!    An iterative scheme that involves first mapping a quadrilateral
+      !!    cell into a cell with coordinates (0,0), (1,0), (0,1) and (1,1).
+      !!
+      !! ** Action  :
+      !!
+      !! History :
+      !!        ! 97-11 (A. Weaver, N. Daget)
+      !!        ! 06-10 (A. Weaver) Cleanup
+      !!-----------------------------------------------------------------------
+
+      !! * Arguments
+      INTEGER, INTENT(IN) :: &
+         & kpk2, &             ! Parameter values for automatic arrays
+         & kmax
+      REAL(KIND=wp), INTENT(IN) :: &
+         & pphi,   &           ! Geographical location of observation
+         & plam,   &
+         & pphipm, &           ! Geographical location of surrounding
+         & pphipp, &           ! model grid points
+         & plammp, &
+         & plampp
+      REAL(KIND=wp), DIMENSION(2,2,kpk2), INTENT(IN)  :: &
+         & pmask               ! Model variable mask
+      REAL(KIND=wp), DIMENSION(kpk2), INTENT(OUT) :: &
+         & p2dmm, &            ! Interpolation weights
+         & p2dmp, &
+         & p2dpm, &
+         & p2dpp
+
+      !! * Local declarations
+      INTEGER :: &
+         & jk
+      REAL(KIND=wp) :: &
+         & zdlmp, &
+         & zdppm, &
+         & zdlpp, &
+         & zdppp
+       
+      !----------------------------------------------------------------------
+      ! Bilinear interpolation for geographical grid
+      !----------------------------------------------------------------------
+      zdlmp = ABS(plam   - plammp) 
+      zdppm = ABS(pphi   - pphipm)
+      zdlpp = ABS(plampp - plam)
+      zdppp = ABS(pphipp - pphi)
+       
+      DO jk = 1, kmax
+         p2dmm(jk) = zdlpp * zdppp * pmask(1,1,jk)
+         p2dmp(jk) = zdlpp * zdppm * pmask(1,2,jk)
+         p2dpm(jk) = zdlmp * zdppp * pmask(2,1,jk)
+         p2dpp(jk) = zdlmp * zdppm * pmask(2,2,jk)
+      END DO
+       
+   END SUBROUTINE obs_int_h2d_bil
+  
+   SUBROUTINE obs_int_h2d_bir( kpk2, kmax,                        &
+      &                        pphi, plam, pmask,                 &
+      &                        pphimm, plammm, pphimp, plammp,    &
+      &                        pphipm, plampm, pphipp, plampp,    &
+      &                        p2dmm, p2dmp, p2dpm, p2dpp, ldfail )
+      !!-----------------------------------------------------------------------
+      !!
+      !!                     ***  ROUTINE obs_int_h2d_bir  ***
+      !!
+      !! ** Purpose : General bilinear remapping interpolation (k2dint = 3)
+      !!
+      !! ** Method  : An iterative scheme that involves first mapping a 
+      !!              quadrilateral cell into a cell with coordinates 
+      !!              (0,0), (1,0), (0,1) and (1,1).
+      !!
+      !! ** Action  :
+      !!
+      !! History :
+      !!        ! 97-11 (A. Weaver, N. Daget)
+      !!        ! 06-10 (A. Weaver) Cleanup
+      !!-----------------------------------------------------------------------
+
+      !! * Arguments
+      INTEGER, INTENT(IN) :: &
+         & kpk2, &             ! Parameter values for automatic arrays
+         & kmax
+      REAL(KIND=wp), INTENT(IN) ::        &
+         & pphi,   &           ! Geographical location of observation
+         & plam,   &
+         & pphimm, &           ! Geographical location of surrounding
+         & pphimp, &           ! model grid points
+         & pphipm, &
+         & pphipp, & 
+         & plammm, &
+         & plammp, &
+         & plampm, &
+         & plampp
+      REAL(KIND=wp), DIMENSION(2,2,kpk2), INTENT(IN) :: &
+         & pmask               ! Model variable mask 
+      REAL(KIND=wp), DIMENSION(kpk2), INTENT(OUT) :: &
+         & p2dmm, &            ! Interpolation weights
+         & p2dmp, &
+         & p2dpm, &
+         & p2dpp
+      LOGICAL, INTENT(OUT) :: &
+         & ldfail
+      !! * Local declarations
+      INTEGER :: &
+         & jk
+      REAL(KIND=wp) :: &
+         & zbiwmm, &
+         & zbiwmp, &
+         & zbiwpm, &
+         & zbiwpp
+  
+      !----------------------------------------------------------------------
+      ! Bilinear remapping interpolation for general quadrilateral grid
+      !----------------------------------------------------------------------
+      CALL bil_wgt( pphimm, pphimp, pphipm, pphipp,  &
+         &          plammm, plammp, plampm, plampp,  &
+         &          zbiwmm, zbiwmp, zbiwpm, zbiwpp,  &
+         &          pphi  , plam,   ldfail           )
+
+      IF ( .NOT.ldfail ) THEN
+         DO jk = 1, kmax
+            p2dmm(jk) = zbiwmm * pmask(1,1,jk)
+            p2dmp(jk) = zbiwmp * pmask(1,2,jk)
+            p2dpm(jk) = zbiwpm * pmask(2,1,jk)
+            p2dpp(jk) = zbiwpp * pmask(2,2,jk)
+         END DO
+      ENDIF
+
+   END SUBROUTINE obs_int_h2d_bir
+
+   SUBROUTINE obs_int_h2d_pol( kpk2, kmax,                         &
+      &                        pphi, plam, pmask,                  &
+      &                        pphimm, plammm, pphimp, plammp,     &
+      &                        pphipm, plampm, pphipp, plampp,     &
+      &                        p2dmm, p2dmp, p2dpm, p2dpp )
+      !!-----------------------------------------------------------------------
+      !!
+      !!                     ***  ROUTINE obs_int_h2d_pol  ***
+      !!
+      !! ** Purpose : Polynomial interpolation (k2dint = 4)
+      !!
+      !! ** Method  : The interpolation weights are computed by fitting a 
+      !!              polynomial function of the form
+      !!
+      !!    P(i) = a1(i) + a2(i) * phi + a3(i) * plam + a4(i) * phi * plam
+      !!
+      !!    through the model values at four surrounding grid pts (i=1,4).
+      !!    As k2dint = 0 but with distance (ds) computed using a small-
+      !!    angle approximation to the great-circle distance formula:
+      !!
+      !!    ds(AB) = sqrt(   ( phiB - phiA )^{2}
+      !!                   + ( ( lamB - lamA ) * cos( phiB ) )^{2} )
+      !!
+      !! ** Action  :
+      !!
+      !! History :
+      !!        ! 97-11 (A. Weaver, N. Daget)
+      !!        ! 06-10 (A. Weaver) Cleanup
+      !!-----------------------------------------------------------------------
+
+      !! * Arguments
+      INTEGER, INTENT(IN) :: &  
+         & kpk2,   &           ! Parameter values for automatic arrays 
+         & kmax
+      REAL(KIND=wp), INTENT(IN) :: &
+         & pphi,   &           ! Geographical location of observation
+         & plam,   &
+         & pphimm, &           ! Geographical location of surrounding
+         & pphimp, &           ! model grid points
+         & pphipm, &
+         & pphipp, &
+         & plammm, &
+         & plammp, &
+         & plampm, &
+         & plampp
+      REAL(KIND=wp), DIMENSION(2,2,kpk2), INTENT(IN) :: &
+         & pmask               ! Model variable mask
+      REAL(KIND=wp), DIMENSION(kpk2), INTENT(OUT) :: &
+         & p2dmm,  &           ! Interpolation weights
+         & p2dmp,  &
+         & p2dpm,  &
+         & p2dpp
+  
+      !! * Local declarations
+      INTEGER :: &
+         & jk
+      REAL(KIND=wp) :: &
+         & zplp
+      REAL(KIND=wp), DIMENSION(4,4) :: &
+         & zmat,  &
+         & zmati
+       
+      !------------------------------------------------------------------------
+      ! Polynomial interpolation
+      !------------------------------------------------------------------------       
+      zmat(1,1) = 1.0_wp
+      zmat(1,2) = 1.0_wp
+      zmat(1,3) = 1.0_wp
+      zmat(1,4) = 1.0_wp
+      zmat(2,1) = plammm
+      zmat(2,2) = plammp
+      zmat(2,3) = plampm
+      zmat(2,4) = plampp
+      zmat(3,1) = pphimm
+      zmat(3,2) = pphimp
+      zmat(3,3) = pphipm
+      zmat(3,4) = pphipp
+      zmat(4,1) = plammm * pphimm
+      zmat(4,2) = plammp * pphimp
+      zmat(4,3) = plampm * pphipm
+      zmat(4,4) = plampp * pphipp
+       
+      CALL lu_invmat( zmat, 4, zmati )
+       
+      zplp = plam * pphi            
+      DO jk = 1, kmax
+         p2dmm(jk) = ABS(   zmati(1,1)        + zmati(1,2) * plam    &
+            &             + zmati(1,3) * pphi + zmati(1,4) * zplp )  &
+            &      * pmask(1,1,jk) 
+         p2dmp(jk) = ABS(   zmati(2,1)        + zmati(2,2) * plam    &
+            &             + zmati(2,3) * pphi + zmati(2,4) * zplp )  &
+            &      * pmask(1,2,jk)
+         p2dpm(jk) = ABS(   zmati(3,1)        + zmati(3,2) * plam    &
+            &             + zmati(3,3) * pphi + zmati(3,4) * zplp )  &
+            &      * pmask(2,1,jk)
+         p2dpp(jk) = ABS(   zmati(4,1)        + zmati(4,2) * plam    &
+            &             + zmati(4,3) * pphi + zmati(4,4) * zplp )  &
+            &      * pmask(2,2,jk)
+      END DO
+  
+   END SUBROUTINE obs_int_h2d_pol
+
+   SUBROUTINE bil_wgt( pphimm, pphimp, pphipm, pphipp,   &
+      &               plammm, plammp, plampm, plampp,   &
+      &               pbiwmm, pbiwmp, pbiwpm, pbiwpp,   &
+      &               pphi  , plam,   ldfail            )
+      !!-------------------------------------------------------------------
+      !!
+      !!                   ***  ROUTINE bil_wgt  ***
+      !!
+      !! ** Purpose : Compute the weights for a bilinear remapping 
+      !!              interpolation scheme.
+      !!
+      !! ** Method  : This scheme is appropriate for bilinear interpolation 
+      !!              on a general quadrilateral grid.    
+      !!              This scheme is also used in OASIS.
+      !!
+      !!              This routine is a derivative of the SCRIP software.
+      !!              Copyright 1997, 1998 the Regents of the University 
+      !!              of California. See SCRIP_Copyright.txt.
+      !!     
+      !! ** Action  :
+      !!
+      !! References : Jones, P.: A user's guide for SCRIP: A Spherical 
+      !!                Coordinate Remapping and Interpolation Package. 
+      !!                Version 1.4. Los Alamos. 
+      !!                  
+      !!         http://www.acl.lanl.gov/climate/software/SCRIP/SCRIPmain.html
+      !!
+      !! History
+      !!      ! 97-11 (A. Weaver, N. Daget)
+      !!      ! 06-03 (A. Vidard)
+      !!      ! 06-10 (A. Weaver) Cleanup
+      !!-----------------------------------------------------------------------
+ 
+      !! * Arguments
+      REAL(KIND=wp), INTENT(IN) :: &
+         & pphi,   &           ! Geographical location of observation
+         & plam,   &
+         & pphimm, &           ! Geographical location of surrounding
+         & pphimp, &           ! model grid points
+         & pphipm, &
+         & pphipp, &
+         & plammm, &
+         & plammp, & 
+         & plampm, &
+         & plampp
+      REAL(KIND=wp), INTENT(OUT) :: &
+         & pbiwmm, &           ! Interpolation weights
+         & pbiwmp, &
+         & pbiwpm, &
+         & pbiwpp
+      LOGICAL, INTENT(out) :: &
+         & ldfail
+
+      !! * Local declarations
+      INTEGER :: &
+         & jiter
+      INTEGER :: &
+         & itermax
+      REAL(KIND=wp) :: &
+         & zphi,    &           ! Geographical location of observation
+         & zlam,    &
+         & zphimm,  &           ! Geographical location of surrounding
+         & zphimp,  &           ! model grid points
+         & zphipm,  &
+         & zphipp,  &
+         & zlammm,  &
+         & zlammp,  & 
+         & zlampm,  &
+         & zlampp,  &
+         & zdth1,   &
+         & zdth2,   &
+         & zdth3,   &
+         & zdthp,   &
+         & zdph1,   &
+         & zdph2,   &
+         & zdph3,   &
+         & zdphp,   &
+         & zmat1,   &
+         & zmat2,   &
+         & zmat3,   &
+         & zmat4,   &
+         & zdeli,   &
+         & zdelj,   &
+         & ziguess, &
+         & zjguess, &
+         & zeps,    &
+         & zdeterm, &
+         & z2pi,    &
+         & zhpi
+      
+      ! Initialization
+
+      ! Conversion to radians
+
+      zphi   = pphi   * rad
+      zlam   = plam   * rad
+      zphimm = pphimm * rad
+      zphimp = pphimp * rad
+      zphipm = pphipm * rad
+      zphipp = pphipp * rad
+      zlammm = plammm * rad
+      zlammp = plammp * rad
+      zlampm = plampm * rad
+      zlampp = plampp * rad
+
+      ldfail = .FALSE.
+
+      zdth1 = zphipm - zphimm
+      zdth2 = zphimp - zphimm
+      zdth3 = zphipp - zphipm - zdth2
+       
+      zdph1 = zlampm - zlammm
+      zdph2 = zlammp - zlammm
+      zdph3 = zlampp - zlampm
+       
+      z2pi = 2.0_wp * rpi
+       
+      IF ( zdph1 >  3.0_wp * rpi ) zdph1 = zdph1 - z2pi
+      IF ( zdph2 >  3.0_wp * rpi ) zdph2 = zdph2 - z2pi
+      IF ( zdph3 >  3.0_wp * rpi ) zdph3 = zdph3 - z2pi
+      IF ( zdph1 < -3.0_wp * rpi ) zdph1 = zdph1 + z2pi
+      IF ( zdph2 < -3.0_wp * rpi ) zdph2 = zdph2 + z2pi
+      IF ( zdph3 < -3.0_wp * rpi ) zdph3 = zdph3 + z2pi
+       
+      zdph3 = zdph3 - zdph2
+       
+      ziguess = 0.5_wp
+      zjguess = 0.5_wp
+       
+      itermax = 100
+
+      IF ( wp == sp ) THEN
+         zeps = 1.0e-6_wp	! Single precision
+      ELSE
+         zeps = 1.0e-10_wp      ! Double precision
+      ENDIF
+  
+      !------------------------------------------------------------------------
+      ! Iterate to determine (i,j) in new coordinate system
+      !------------------------------------------------------------------------
+      jiter_loop: DO jiter = 1, itermax
+         
+         zdthp = zphi - zphimm - zdth1 * ziguess - zdth2 * zjguess &
+            &  - zdth3 * ziguess * zjguess
+         zdphp = zlam - zlammm
+         
+         zhpi = 0.5_wp * rpi
+         IF ( zdphp >  3.0_wp * zhpi ) zdphp = zdphp - z2pi
+         IF ( zdphp < -3.0_wp * zhpi ) zdphp = zdphp + z2pi
+         
+         zdphp = zdphp - zdph1 * ziguess - zdph2 * zjguess &
+            &  - zdph3 * ziguess * zjguess
+         
+         zmat1 = zdth1 + zdth3 * zjguess
+         zmat2 = zdth2 + zdth3 * ziguess
+         zmat3 = zdph1 + zdph3 * zjguess
+         zmat4 = zdph2 + zdph3 * ziguess
+         
+         ! Matrix determinant
+         zdeterm = zmat1 * zmat4 - zmat2 * zmat3
+         
+         zdeli = ( zdthp * zmat4 - zmat2 * zdphp) / zdeterm
+         zdelj = ( zmat1 * zdphp - zdthp * zmat3) / zdeterm
+         
+         IF ( ABS( zdeli ) < zeps .AND. ABS( zdelj ) < zeps ) EXIT jiter_loop
+         
+         ziguess = ziguess + zdeli
+         zjguess = zjguess + zdelj
+
+         ! DJL prevent ziguess and zjguess from going outside the range
+         ! 0 to 1
+         ! prevents interpolated value going wrong
+         ! for example sea ice concentration gt 1
+         
+         IF ( ziguess < 0 ) ziguess = 0.0_wp
+         IF ( zjguess < 0 ) zjguess = 0.0_wp
+         IF ( ziguess > 1 ) ziguess = 1.0_wp
+         IF ( zjguess > 1 ) zjguess = 1.0_wp
+         
+      END DO jiter_loop
+       
+      IF ( jiter <= itermax ) THEN
+           
+         ! Successfully found i,j, now compute the weights
+
+         pbiwmm = ( 1.0_wp - ziguess ) * ( 1.0_wp - zjguess )
+         pbiwmp = ( 1.0_wp - ziguess ) *            zjguess
+         pbiwpm =            ziguess   * ( 1.0_wp - zjguess )
+         pbiwpp =            ziguess   *            zjguess
+         
+      ELSEIF ( jiter > itermax ) THEN
+            
+         IF(lwp) THEN
+            
+            WRITE(numout,*)'Obs lat/lon  : ',pphi, plam
+            WRITE(numout,*)'Grid lats    : ',pphimm, pphimp, pphipm, pphipp
+            WRITE(numout,*)'Grid lons    : ',plammm, plammp, plampm, plampp
+            WRITE(numout,*)'Current i,j  : ',ziguess, zjguess
+            WRITE(numout,*)'Weights      : ',pbiwmm, pbiwmp, pbiwpm, pbiwpp
+            WRITE(numout,*)'jiter        = ',jiter
+            WRITE(numout,*)'zeps         = ',zeps
+            WRITE(numout,*)'zdeli, zdelj = ',zdeli, zdelj
+            WRITE(numout,*)' Iterations for i,j exceed max iteration count!'
+            WRITE(numout,*)
+            
+            ldfail = .TRUE.
+
+         ENDIF
+         
+      ENDIF
+    
+   END SUBROUTINE bil_wgt
+
+   SUBROUTINE lu_invmat( pmatin, kdim, pmatou )
+      !!-----------------------------------------------------------------------
+      !!
+      !!                   ***  ROUTINE lu_invmat  ***
+      !!
+      !! ** Purpose : Invert a matrix using LU decomposition.
+      !!
+      !! ** Method  : 
+      !! 
+      !! ** Action  :
+      !!
+      !! References : 
+      !!
+      !! History
+      !!      ! 02-11 (A. Weaver, N. Daget)
+      !!      ! 06-03 (A. Vidard)
+      !!      ! 06-10 (A. Weaver) Cleanup
+      !!      ! 06-11 (NEMOVAR task force) Fix declaration of zd.
+      !!-----------------------------------------------------------------------
+
+      !! * Arguments
+      INTEGER, INTENT(IN) :: &
+         & kdim             ! Array dimension
+      REAL(KIND=wp), DIMENSION(kdim,kdim), INTENT(IN) :: &
+         & pmatin 
+      REAL(KIND=wp), DIMENSION(kdim,kdim), INTENT(OUT) :: &
+         & pmatou 
+  
+      !! * Local declarations
+      INTEGER :: &
+         & ji, &
+         & jj
+      INTEGER, DIMENSION(kdim) :: &
+         & indx
+      REAL(KIND=wp), DIMENSION(kdim,kdim) :: &
+         & zmat
+      REAL(KIND=wp) :: &
+         & zd
+
+      ! Invert the matrix       
+      DO jj = 1, kdim
+         DO ji = 1, kdim
+            pmatou(ji,jj) = 0.0_wp
+            zmat(ji,jj) = pmatin(ji,jj)
+         END DO
+         pmatou(jj,jj) = 1.0_wp
+      END DO
+      CALL lu_decomp( zmat, kdim, kdim, indx, zd )
+      DO jj = 1, kdim
+         CALL lu_backsb( zmat, kdim, kdim, indx, pmatou(1,jj) )
+      END DO
+      
+   END SUBROUTINE lu_invmat
+
+   SUBROUTINE lu_decomp( pmatin, kdim1, kdim2, kindex, pflt )
+      !!-----------------------------------------------------------------------
+      !!
+      !!                   ***  ROUTINE lu_decomp  ***
+      !!
+      !! ** Purpose : Compute the LU decomposition of a matrix
+      !!
+      !! ** Method  : 
+      !! 
+      !! ** Action  :
+      !!
+      !! References : 
+      !!
+      !! History
+      !!      ! 02-11 (A. Weaver, N. Daget)
+      !!      ! 06-03 (A. Vidard)
+      !!      ! 06-10 (A. Weaver) Cleanup
+      !!-----------------------------------------------------------------------
+       
+      !! * Arguments
+      INTEGER, INTENT(IN) :: &
+         & kdim1, &   ! Array dimensions
+         & kdim2
+      INTEGER, DIMENSION(kdim1), INTENT(OUT) :: &
+         & kindex
+      REAL(KIND=wp), INTENT(OUT) :: &
+         & pflt
+      REAL(KIND=wp), DIMENSION(kdim2,kdim2), INTENT(INOUT) :: &
+         & pmatin 
+  
+      !! * Local declarations
+      INTEGER, PARAMETER :: &
+         & jpmax = 100
+      REAL(KIND=wp), PARAMETER :: &
+         & pptiny = 1.0e-20_wp
+      REAL(KIND=wp), DIMENSION(jpmax) :: &
+         & zvv
+      INTEGER :: &
+         & ji, &
+         & jj, &
+         & jk
+      INTEGER :: &
+         & imax
+      REAL(KIND=wp) :: &
+         & zsum,  &
+         & zdum,  &
+         & zaamax
+      
+      imax = -1 
+      ! Main computation
+      pflt = 1.0_wp
+      DO ji = 1, kdim1
+         zaamax = 0.0_wp
+         DO jj = 1, kdim1
+            IF ( ABS( pmatin(ji,jj) ) > zaamax ) zaamax = ABS( pmatin(ji,jj) )
+         END DO
+         IF ( zaamax == 0.0_wp ) THEN
+            CALL ctl_stop( 'singular matrix' )
+         ENDIF 
+         zvv(ji) = 1.0_wp / zaamax
+      END DO
+      DO jj = 1, kdim1
+         DO ji = 1, jj-1
+            zsum = pmatin(ji,jj)
+            DO jk = 1, ji-1
+	       zsum = zsum - pmatin(ji,jk) * pmatin(jk,jj)
+	    END DO
+            pmatin(ji,jj) = zsum
+         END DO
+         zaamax = 0.0_wp
+         DO ji = jj, kdim1
+            zsum = pmatin(ji,jj)
+            DO jk = 1, jj-1
+               zsum = zsum - pmatin(ji,jk) * pmatin(jk,jj)
+            END DO
+            pmatin(ji,jj) = zsum
+            zdum = zvv(ji) * ABS( zsum )
+            IF ( zdum >= zaamax ) THEN
+               imax = ji
+               zaamax = zdum
+            ENDIF
+	 END DO
+         IF ( jj /= imax ) THEN
+            DO jk = 1, kdim1
+               zdum = pmatin(imax,jk)
+               pmatin(imax,jk) = pmatin(jj,jk)
+               pmatin(jj,jk) = zdum
+	    END DO
+            pflt = -pflt
+            zvv(imax) = zvv(jj)
+         ENDIF
+         kindex(jj) = imax
+         IF ( pmatin(jj,jj) == 0.0_wp ) pmatin(jj,jj) = pptiny
+         IF ( jj /= kdim1 ) THEN
+            zdum = 1.0_wp / pmatin(jj,jj)
+            DO ji = jj+1, kdim1
+               pmatin(ji,jj) = pmatin(ji,jj) * zdum
+	    END DO
+         ENDIF
+      END DO
+     
+   END SUBROUTINE lu_decomp
+     
+   SUBROUTINE lu_backsb( pmat, kdim1, kdim2, kindex, pvect )
+      !!-----------------------------------------------------------------------
+      !!
+      !!                   ***  ROUTINE lu_backsb  ***
+      !!
+      !! ** Purpose : Back substitution
+      !!
+      !! ** Method  : 
+      !! 
+      !! ** Action  :
+      !!
+      !! References : 
+      !!
+      !! History
+      !!      ! 02-11 (A. Weaver, N. Daget)
+      !!      ! 06-03 (A. Vidard)
+      !!      ! 06-10 (A. Weaver) Cleanup
+      !!-----------------------------------------------------------------------
+      
+      !! * Arguments
+      INTEGER, INTENT(IN) :: &
+         & kdim1, &     ! Array dimensions
+         & kdim2
+      INTEGER, DIMENSION(kdim1), INTENT(IN) :: &
+         & kindex
+      REAL(KIND=wp), DIMENSION(kdim1), INTENT(INOUT) :: &
+         & pvect
+      REAL(KIND=wp), DIMENSION(kdim2,kdim2), INTENT(IN) :: &
+         & pmat
+  
+      !! * Local declarations
+      INTEGER :: &
+         & ji,  &
+         & jii, &
+         & jj,  &
+         & jll
+      REAL(KIND=wp) :: &
+         & zsum
+
+      ! Main computation
+      jii = 0
+      DO ji = 1, kdim1
+         jll = kindex(ji)
+         zsum = pvect(jll)
+         pvect(jll) = pvect(ji)
+         IF ( jii /= 0 ) THEN
+            DO jj = jii, ji-1
+               zsum = zsum - pmat(ji,jj) * pvect(jj)
+            END DO
+         ELSEIF ( zsum /= 0.0_wp ) THEN
+            jii = ji
+         ENDIF
+         pvect(ji) = zsum
+      END DO
+      DO ji = kdim1, 1, -1
+         zsum = pvect(ji)
+         DO jj = ji+1, kdim1
+            zsum = zsum - pmat(ji,jj) * pvect(jj)
+         END DO
+         pvect(ji) = zsum / pmat(ji,ji)
+      END DO
+     
+   END SUBROUTINE lu_backsb
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/obsinter_z1d.h90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/obsinter_z1d.h90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/obsinter_z1d.h90	(revision 9570)
@@ -0,0 +1,191 @@
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO Consortium (2010)
+   !! $Id$
+   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+
+   SUBROUTINE obs_int_z1d( kpk, kkco, k1dint, kdep, &
+      &                    pobsdep, pobsk, pobs2k,  &
+      &                    pobs, pdep, pobsmask )
+      !!---------------------------------------------------------------------
+      !!
+      !!                   ***  ROUTINE obs_int_z1d ***
+      !!
+      !! ** Purpose : Vertical interpolation to the observation point.
+      !!  
+      !! ** Method  : If k1dint = 0 then use linear interpolation.
+      !!              If k1dint = 1 then use cubic spline interpolation.
+      !! 
+      !! ** Action  :
+      !!
+      !! References :
+      !!
+      !! History
+      !!      ! 97-11 (A. Weaver, S. Ricci, N. Daget)
+      !!      ! 06-03 (G. Smith) Conversion to F90 for use with NEMOVAR
+      !!      ! 06-10 (A. Weaver) Cleanup
+      !!      ! 07-01 (K. Mogensen) Use profile rather than single level
+      !!---------------------------------------------------------------------
+
+      !! * Arguments
+      INTEGER, INTENT(IN) :: kpk        ! Number of vertical levels
+      INTEGER, INTENT(IN) :: k1dint     ! 0 = linear; 1 = cubic spline interpolation 
+      INTEGER, INTENT(IN) :: kdep       ! Number of levels in profile
+      INTEGER, INTENT(IN), DIMENSION(kdep) :: &
+         & kkco                 ! Array indicies for interpolation
+      REAL(KIND=wp), INTENT(IN), DIMENSION(kdep) :: &
+         & pobsdep              ! Depth of the observation
+      REAL(KIND=wp), INTENT(IN), DIMENSION(kpk) :: &
+         & pobsk,  &            ! Model profile at a given (lon,lat)
+         & pobs2k, &            ! 2nd derivative of the interpolating function
+         & pdep,   &            ! Model depth array
+         & pobsmask             ! Vertical mask
+      REAL(KIND=wp), INTENT(OUT), DIMENSION(kdep) :: &
+         & pobs                 ! Model equivalent at observation point
+  
+      !! * Local declarations
+      REAL(KIND=wp) :: z1dm       ! Distance above and below obs to model grid points
+      REAL(KIND=wp) :: z1dp         
+      REAL(KIND=wp) :: zsum       ! Dummy variables for computation
+      REAL(KIND=wp) :: zsum2
+      INTEGER :: jdep             ! Observation depths loop variable
+    
+      !------------------------------------------------------------------------
+      ! Loop over all observation depths
+      !------------------------------------------------------------------------
+
+      DO jdep = 1, kdep
+
+         !---------------------------------------------------------------------
+         ! Initialization
+         !---------------------------------------------------------------------
+         z1dm = ( pdep(kkco(jdep)) - pobsdep(jdep)      )
+         z1dp = ( pobsdep(jdep)    - pdep(kkco(jdep)-1) )
+         IF ( pobsmask(kkco(jdep)) == 0.0_wp ) z1dp = 0.0_wp
+
+         zsum = z1dm + z1dp
+         
+         IF ( k1dint == 0 ) THEN
+
+            !-----------------------------------------------------------------
+            !  Linear interpolation
+            !-----------------------------------------------------------------
+            pobs(jdep) = (   z1dm * pobsk(kkco(jdep)-1) &
+               &           + z1dp * pobsk(kkco(jdep)  ) ) / zsum
+
+         ELSEIF ( k1dint == 1 ) THEN
+
+            !-----------------------------------------------------------------
+            ! Cubic spline interpolation
+            !-----------------------------------------------------------------
+            zsum2 = zsum * zsum
+            pobs(jdep)  = (  z1dm                             * pobsk (kkco(jdep)-1) &
+               &           + z1dp                             * pobsk (kkco(jdep)  ) &
+               &           + ( z1dm * ( z1dm * z1dm - zsum2 ) * pobs2k(kkco(jdep)-1) &
+               &           +   z1dp * ( z1dp * z1dp - zsum2 ) * pobs2k(kkco(jdep)  ) &
+               &             ) / 6.0_wp                                              &
+               &          ) / zsum
+
+         ENDIF
+      END DO
+
+   END SUBROUTINE obs_int_z1d
+
+   SUBROUTINE obs_int_z1d_spl( kpk, pobsk, pobs2k, &
+      &                        pdep, pobsmask )
+      !!--------------------------------------------------------------------
+      !!
+      !!                  *** ROUTINE obs_int_z1d_spl ***
+      !!
+      !! ** Purpose : Compute the local vector of vertical second-derivatives 
+      !!              of the interpolating function used with a cubic spline.
+      !!  
+      !! ** Method  : 
+      !! 
+      !!    Top and bottom boundary conditions on the 2nd derivative are
+      !!    set to zero.
+      !!
+      !! ** Action  :
+      !!
+      !! References : 
+      !!
+      !! History
+      !!      ! 01-11 (A. Weaver, S. Ricci, N. Daget)
+      !!      ! 06-03 (G. Smith) Conversion to F90 for use with NEMOVAR
+      !!      ! 06-10 (A. Weaver) Cleanup
+      !!----------------------------------------------------------------------
+     
+      !! * Arguments
+      INTEGER, INTENT(IN) :: kpk               ! Number of vertical levels
+      REAL(KIND=wp), INTENT(IN), DIMENSION(kpk) :: &
+         & pobsk, &          ! Model profile at a given (lon,lat)
+         & pdep,  &          ! Model depth array
+         & pobsmask          ! Vertical mask
+      REAL(KIND=wp), INTENT(OUT), DIMENSION(kpk) :: &
+         & pobs2k            ! 2nd derivative of the interpolating function
+  
+      !! * Local declarations
+      INTEGER :: jk
+      REAL(KIND=wp) :: za
+      REAL(KIND=wp) :: zb
+      REAL(KIND=wp) :: zc
+      REAL(KIND=wp) :: zpa
+      REAL(KIND=wp) :: zkm
+      REAL(KIND=wp) :: zkp
+      REAL(KIND=wp) :: zk
+      REAL(KIND=wp), DIMENSION(kpk-1) :: &
+         & zs, &
+         & zp, &
+         & zu, &
+         & zv
+
+      !-----------------------------------------------------------------------
+      ! Matrix initialisation
+      !-----------------------------------------------------------------------
+      zs(1) =  0.0_wp
+      zp(1) =  0.0_wp
+      zv(1) = -0.5_wp
+      DO jk = 2, kpk-1
+         zs(jk) =  ( pdep(jk  ) - pdep(jk-1) ) &
+            &    / ( pdep(jk+1) - pdep(jk-1) )
+         zp(jk) = zs(jk) * zv(jk-1) + 2.0_wp
+         zv(jk) = ( zs(jk) - 1.0_wp ) / zp(jk)
+      END DO
+ 
+      !-----------------------------------------------------------------------
+      ! Solution of the tridiagonal system
+      !-----------------------------------------------------------------------
+ 
+      ! Top boundary condition
+      zu(1) = 0.0_wp
+ 
+      DO jk = 2, kpk-1
+         za = pdep(jk+1) - pdep(jk-1)
+         zb = pdep(jk+1) - pdep(jk  )
+         zc = pdep(jk  ) - pdep(jk-1)
+ 
+         zpa = 6.0_wp / ( zp(jk) * za )
+         zkm = zpa / zc
+         zkp = zpa / zb
+         zk  = - ( zkm + zkp )
+  
+         zu(jk) =  pobsk(jk+1) * zkp  &
+            &    + pobsk(jk  ) * zk   &
+            &    + pobsk(jk-1) * zkm  &
+            &    + zu(jk-1) * ( -zs(jk) / zp(jk) )
+      END DO
+ 
+      !-----------------------------------------------------------------------
+      ! Second derivative
+      !-----------------------------------------------------------------------
+      pobs2k(kpk) = 0.0_wp
+ 
+      ! Bottom boundary condition
+      DO jk = kpk-1, 1, -1
+         pobs2k(jk) = zv(jk) * pobs2k(jk+1) + zu(jk)
+         IF ( pobsmask(jk+1) == 0.0_wp ) pobs2k(jk) = 0.0_wp
+      END DO
+ 
+  END SUBROUTINE obs_int_z1d_spl
+
+
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/str_c_to_for.h90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/str_c_to_for.h90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/OBS/str_c_to_for.h90	(revision 9570)
@@ -0,0 +1,39 @@
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO Consortium (2010)
+   !! $Id$
+   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+
+   SUBROUTINE str_c_to_for( cd_str )
+      !!---------------------------------------------------------------------
+      !!   
+      !!                     *** ROUTINE str_c_to_for ***
+      !! 
+      !! ** Purpose : Loop over a string and replace all non-printable
+      !!              ASCII characters with spaces assuming English 
+      !!              characters only
+      !!
+      !! ** Method  : Loop over a string and replace all non-printable
+      !!              ASCII characters with spaces assuming English 
+      !!              characters only
+      !!
+      !! ** Action  : 
+      !! 
+      !! History :  
+      !!        ! : 06-05 (K. Mogensen) Original
+      !!        ! : 06-05 (A. Vidard) Cleaning up
+      !!        ! : 06-10 (A. Weaver) More cleaning
+      !!---------------------------------------------------------------------
+      !! * Arguments
+      CHARACTER(LEN=*), INTENT(INOUT) :: cd_str
+
+      !! * Local declarations
+      INTEGER :: &
+         & ji
+
+      DO ji = 1, LEN( cd_str )
+         IF (     ( IACHAR( cd_str(ji:ji) ) > 128 ) &
+            & .OR.( IACHAR( cd_str(ji:ji) ) < 32  ) ) cd_str(ji:ji) = ' '
+      END DO
+
+   END SUBROUTINE str_c_to_for
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/SBC/cpl_oasis3.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/SBC/cpl_oasis3.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/SBC/cpl_oasis3.F90	(revision 9570)
@@ -0,0 +1,571 @@
+MODULE cpl_oasis3
+   !!======================================================================
+   !!                    ***  MODULE cpl_oasis  ***
+   !! Coupled O/A : coupled ocean-atmosphere case using OASIS3-MCT
+   !!=====================================================================
+   !! History :  1.0  !  2004-06  (R. Redler, NEC Laboratories Europe, Germany) Original code
+   !!             -   !  2004-11  (R. Redler, NEC Laboratories Europe; N. Keenlyside, W. Park, IFM-GEOMAR, Germany) revision
+   !!             -   !  2004-11  (V. Gayler, MPI M&D) Grid writing
+   !!            2.0  !  2005-08  (R. Redler, W. Park) frld initialization, paral(2) revision
+   !!             -   !  2005-09  (R. Redler) extended to allow for communication over root only
+   !!             -   !  2006-01  (W. Park) modification of physical part
+   !!             -   !  2006-02  (R. Redler, W. Park) buffer array fix for root exchange
+   !!            3.4  !  2011-11  (C. Harris) Changes to allow mutiple category fields
+   !!            3.6  !  2014-11  (S. Masson) OASIS3-MCT
+   !!----------------------------------------------------------------------
+   
+   !!----------------------------------------------------------------------
+   !!   'key_oasis3'                    coupled Ocean/Atmosphere via OASIS3-MCT
+   !!   'key_oa3mct_v3'                 to be added for OASIS3-MCT version 3
+   !!----------------------------------------------------------------------
+   !!   cpl_init     : initialization of coupled mode communication
+   !!   cpl_define   : definition of grid and fields
+   !!   cpl_snd      : snd out fields in coupled mode
+   !!   cpl_rcv      : receive fields in coupled mode
+   !!   cpl_finalize : finalize the coupled mode communication
+   !!----------------------------------------------------------------------
+#if defined key_oasis3
+   USE mod_oasis                    ! OASIS3-MCT module
+#endif
+   USE par_oce                      ! ocean parameters
+   USE dom_oce                      ! ocean space and time domain
+   USE in_out_manager               ! I/O manager
+   USE lbclnk                       ! ocean lateral boundary conditions (or mpp link)
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   cpl_init
+   PUBLIC   cpl_define
+   PUBLIC   cpl_snd
+   PUBLIC   cpl_rcv
+   PUBLIC   cpl_freq
+   PUBLIC   cpl_finalize
+
+   INTEGER, PUBLIC            ::   OASIS_Rcv  = 1    !: return code if received field
+   INTEGER, PUBLIC            ::   OASIS_idle = 0    !: return code if nothing done by oasis
+   INTEGER                    ::   ncomp_id          ! id returned by oasis_init_comp
+   INTEGER                    ::   nerror            ! return error code
+#if ! defined key_oasis3
+   ! OASIS Variables not used. defined only for compilation purpose
+   INTEGER                    ::   OASIS_Out         = -1
+   INTEGER                    ::   OASIS_REAL        = -1
+   INTEGER                    ::   OASIS_Ok          = -1
+   INTEGER                    ::   OASIS_In          = -1
+   INTEGER                    ::   OASIS_Sent        = -1
+   INTEGER                    ::   OASIS_SentOut     = -1
+   INTEGER                    ::   OASIS_ToRest      = -1
+   INTEGER                    ::   OASIS_ToRestOut   = -1
+   INTEGER                    ::   OASIS_Recvd       = -1
+   INTEGER                    ::   OASIS_RecvOut     = -1
+   INTEGER                    ::   OASIS_FromRest    = -1
+   INTEGER                    ::   OASIS_FromRestOut = -1
+#endif
+
+   INTEGER                    ::   nrcv         ! total number of fields received 
+   INTEGER                    ::   nsnd         ! total number of fields sent 
+   INTEGER                    ::   ncplmodel    ! Maximum number of models to/from which NEMO is potentialy sending/receiving data
+   INTEGER, PUBLIC, PARAMETER ::   nmaxfld=60   ! Maximum number of coupling fields
+   INTEGER, PUBLIC, PARAMETER ::   nmaxcat=5    ! Maximum number of coupling fields
+   INTEGER, PUBLIC, PARAMETER ::   nmaxcpl=5    ! Maximum number of coupling fields
+   
+   TYPE, PUBLIC ::   FLD_CPL               !: Type for coupling field information
+      LOGICAL               ::   laction   ! To be coupled or not
+      CHARACTER(len = 8)    ::   clname    ! Name of the coupling field   
+      CHARACTER(len = 1)    ::   clgrid    ! Grid type  
+      REAL(wp)              ::   nsgn      ! Control of the sign change
+      INTEGER, DIMENSION(nmaxcat,nmaxcpl) ::   nid   ! Id of the field (no more than 9 categories and 9 extrena models)
+      INTEGER               ::   nct       ! Number of categories in field
+      INTEGER               ::   ncplmodel ! Maximum number of models to/from which this variable may be sent/received
+   END TYPE FLD_CPL
+
+   TYPE(FLD_CPL), DIMENSION(nmaxfld), PUBLIC ::   srcv, ssnd   !: Coupling fields
+
+   REAL(wp), DIMENSION(:,:), ALLOCATABLE ::   exfld   ! Temporary buffer for receiving
+
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO Consortium (2010)
+   !! $Id$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE cpl_init( cd_modname, kl_comm )
+      !!-------------------------------------------------------------------
+      !!             ***  ROUTINE cpl_init  ***
+      !!
+      !! ** Purpose :   Initialize coupled mode communication for ocean
+      !!    exchange between AGCM, OGCM and COUPLER. (OASIS3 software)
+      !!
+      !! ** Method  :   OASIS3 MPI communication 
+      !!--------------------------------------------------------------------
+      CHARACTER(len = *), INTENT(in   ) ::   cd_modname   ! model name as set in namcouple file
+      INTEGER           , INTENT(  out) ::   kl_comm      ! local communicator of the model
+      !!--------------------------------------------------------------------
+
+      ! WARNING: No write in numout in this routine
+      !============================================
+
+      !------------------------------------------------------------------
+      ! 1st Initialize the OASIS system for the application
+      !------------------------------------------------------------------
+      CALL oasis_init_comp ( ncomp_id, TRIM(cd_modname), nerror )
+      IF ( nerror /= OASIS_Ok ) &
+         CALL oasis_abort (ncomp_id, 'cpl_init', 'Failure in oasis_init_comp')
+
+      !------------------------------------------------------------------
+      ! 3rd Get an MPI communicator for OPA local communication
+      !------------------------------------------------------------------
+
+      CALL oasis_get_localcomm ( kl_comm, nerror )
+      IF ( nerror /= OASIS_Ok ) &
+         CALL oasis_abort (ncomp_id, 'cpl_init','Failure in oasis_get_localcomm' )
+      !
+   END SUBROUTINE cpl_init
+
+
+   SUBROUTINE cpl_define( krcv, ksnd, kcplmodel )
+      !!-------------------------------------------------------------------
+      !!             ***  ROUTINE cpl_define  ***
+      !!
+      !! ** Purpose :   Define grid and field information for ocean
+      !!    exchange between AGCM, OGCM and COUPLER. (OASIS3 software)
+      !!
+      !! ** Method  :   OASIS3 MPI communication 
+      !!--------------------------------------------------------------------
+      INTEGER, INTENT(in) ::   krcv, ksnd     ! Number of received and sent coupling fields
+      INTEGER, INTENT(in) ::   kcplmodel      ! Maximum number of models to/from which NEMO is potentialy sending/receiving data
+      !
+      INTEGER :: id_part
+      INTEGER :: paral(5)       ! OASIS3 box partition
+      INTEGER :: ishape(2,2)    ! shape of arrays passed to PSMILe
+      INTEGER :: ji,jc,jm       ! local loop indicees
+      CHARACTER(LEN=64) :: zclname
+      CHARACTER(LEN=2) :: cli2
+      !!--------------------------------------------------------------------
+
+      IF(lwp) WRITE(numout,*)
+      IF(lwp) WRITE(numout,*) 'cpl_define : initialization in coupled ocean/atmosphere case'
+      IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~~~~~'
+      IF(lwp) WRITE(numout,*)
+
+      ncplmodel = kcplmodel
+      IF( kcplmodel > nmaxcpl ) THEN
+         CALL oasis_abort ( ncomp_id, 'cpl_define', 'ncplmodel is larger than nmaxcpl, increase nmaxcpl')   ;   RETURN
+      ENDIF
+
+      nrcv = krcv
+      IF( nrcv > nmaxfld ) THEN
+         CALL oasis_abort ( ncomp_id, 'cpl_define', 'nrcv is larger than nmaxfld, increase nmaxfld')   ;   RETURN
+      ENDIF
+
+      nsnd = ksnd
+      IF( nsnd > nmaxfld ) THEN
+         CALL oasis_abort ( ncomp_id, 'cpl_define', 'nsnd is larger than nmaxfld, increase nmaxfld')   ;   RETURN
+      ENDIF
+      !
+      ! ... Define the shape for the area that excludes the halo
+      !     For serial configuration (key_mpp_mpi not being active)
+      !     nl* is set to the global values 1 and jp*glo.
+      !
+      ishape(:,1) = (/ 1, nlei-nldi+1 /)
+      ishape(:,2) = (/ 1, nlej-nldj+1 /)
+      !
+      ! ... Allocate memory for data exchange
+      !
+      ALLOCATE(exfld(nlei-nldi+1, nlej-nldj+1), stat = nerror)
+      IF( nerror > 0 ) THEN
+         CALL oasis_abort ( ncomp_id, 'cpl_define', 'Failure in allocating exfld')   ;   RETURN
+      ENDIF
+      !
+      ! -----------------------------------------------------------------
+      ! ... Define the partition 
+      ! -----------------------------------------------------------------
+      
+      paral(1) = 2                                              ! box partitioning
+      paral(2) = jpiglo * (nldj-1+njmpp-1) + (nldi-1+nimpp-1)   ! NEMO lower left corner global offset    
+      paral(3) = nlei-nldi+1                                    ! local extent in i 
+      paral(4) = nlej-nldj+1                                    ! local extent in j
+      paral(5) = jpiglo                                         ! global extent in x
+      
+      IF( ln_ctl ) THEN
+         WRITE(numout,*) ' multiexchg: paral (1:5)', paral
+         WRITE(numout,*) ' multiexchg: jpi, jpj =', jpi, jpj
+         WRITE(numout,*) ' multiexchg: nldi, nlei, nimpp =', nldi, nlei, nimpp
+         WRITE(numout,*) ' multiexchg: nldj, nlej, njmpp =', nldj, nlej, njmpp
+      ENDIF
+   
+      CALL oasis_def_partition ( id_part, paral, nerror, jpiglo*jpjglo )
+      !
+      ! ... Announce send variables. 
+      !
+      ssnd(:)%ncplmodel = kcplmodel
+      !
+      DO ji = 1, ksnd
+         IF ( ssnd(ji)%laction ) THEN
+
+            IF( ssnd(ji)%nct > nmaxcat ) THEN
+               CALL oasis_abort ( ncomp_id, 'cpl_define', 'Number of categories of '//   &
+                  &              TRIM(ssnd(ji)%clname)//' is larger than nmaxcat, increase nmaxcat' )
+               RETURN
+            ENDIF
+            
+            DO jc = 1, ssnd(ji)%nct
+               DO jm = 1, kcplmodel
+
+                  IF ( ssnd(ji)%nct .GT. 1 ) THEN
+                     WRITE(cli2,'(i2.2)') jc
+                     zclname = TRIM(ssnd(ji)%clname)//'_cat'//cli2
+                  ELSE
+                     zclname = ssnd(ji)%clname
+                  ENDIF
+                  IF ( kcplmodel  > 1 ) THEN
+                     WRITE(cli2,'(i2.2)') jm
+                     zclname = 'model'//cli2//'_'//TRIM(zclname)
+                  ENDIF
+#if defined key_agrif
+                  IF( agrif_fixed() /= 0 ) THEN 
+                     zclname=TRIM(Agrif_CFixed())//'_'//TRIM(zclname)
+                  END IF
+#endif
+                  IF( ln_ctl ) WRITE(numout,*) "Define", ji, jc, jm, " "//TRIM(zclname), " for ", OASIS_Out
+                  CALL oasis_def_var (ssnd(ji)%nid(jc,jm), zclname, id_part   , (/ 2, 0 /),   &
+                     &                OASIS_Out          , ishape , OASIS_REAL, nerror )
+                  IF ( nerror /= OASIS_Ok ) THEN
+                     WRITE(numout,*) 'Failed to define transient ', ji, jc, jm, " "//TRIM(zclname)
+                     CALL oasis_abort ( ssnd(ji)%nid(jc,jm), 'cpl_define', 'Failure in oasis_def_var' )
+                  ENDIF
+                  IF( ln_ctl .AND. ssnd(ji)%nid(jc,jm) /= -1 ) WRITE(numout,*) "variable defined in the namcouple"
+                  IF( ln_ctl .AND. ssnd(ji)%nid(jc,jm) == -1 ) WRITE(numout,*) "variable NOT defined in the namcouple"
+               END DO
+            END DO
+         ENDIF
+      END DO
+      !
+      ! ... Announce received variables. 
+      !
+      srcv(:)%ncplmodel = kcplmodel
+      !
+      DO ji = 1, krcv
+         IF ( srcv(ji)%laction ) THEN 
+            
+            IF( srcv(ji)%nct > nmaxcat ) THEN
+               CALL oasis_abort ( ncomp_id, 'cpl_define', 'Number of categories of '//   &
+                  &              TRIM(srcv(ji)%clname)//' is larger than nmaxcat, increase nmaxcat' )
+               RETURN
+            ENDIF
+            
+            DO jc = 1, srcv(ji)%nct
+               DO jm = 1, kcplmodel
+                  
+                  IF ( srcv(ji)%nct .GT. 1 ) THEN
+                     WRITE(cli2,'(i2.2)') jc
+                     zclname = TRIM(srcv(ji)%clname)//'_cat'//cli2
+                  ELSE
+                     zclname = srcv(ji)%clname
+                  ENDIF
+                  IF ( kcplmodel  > 1 ) THEN
+                     WRITE(cli2,'(i2.2)') jm
+                     zclname = 'model'//cli2//'_'//TRIM(zclname)
+                  ENDIF
+#if defined key_agrif
+                  IF( agrif_fixed() /= 0 ) THEN 
+                     zclname=TRIM(Agrif_CFixed())//'_'//TRIM(zclname)
+                  END IF
+#endif
+                  IF( ln_ctl ) WRITE(numout,*) "Define", ji, jc, jm, " "//TRIM(zclname), " for ", OASIS_In
+                  CALL oasis_def_var (srcv(ji)%nid(jc,jm), zclname, id_part   , (/ 2, 0 /),   &
+                     &                OASIS_In           , ishape , OASIS_REAL, nerror )
+                  IF ( nerror /= OASIS_Ok ) THEN
+                     WRITE(numout,*) 'Failed to define transient ', ji, jc, jm, " "//TRIM(zclname)
+                     CALL oasis_abort ( srcv(ji)%nid(jc,jm), 'cpl_define', 'Failure in oasis_def_var' )
+                  ENDIF
+                  IF( ln_ctl .AND. srcv(ji)%nid(jc,jm) /= -1 ) WRITE(numout,*) "variable defined in the namcouple"
+                  IF( ln_ctl .AND. srcv(ji)%nid(jc,jm) == -1 ) WRITE(numout,*) "variable NOT defined in the namcouple"
+
+               END DO
+            END DO
+         ENDIF
+      END DO
+      
+      !------------------------------------------------------------------
+      ! End of definition phase
+      !------------------------------------------------------------------
+      
+      CALL oasis_enddef(nerror)
+      IF( nerror /= OASIS_Ok )   CALL oasis_abort ( ncomp_id, 'cpl_define', 'Failure in oasis_enddef')
+      !
+   END SUBROUTINE cpl_define
+   
+   
+   SUBROUTINE cpl_snd( kid, kstep, pdata, kinfo )
+      !!---------------------------------------------------------------------
+      !!              ***  ROUTINE cpl_snd  ***
+      !!
+      !! ** Purpose : - At each coupling time-step,this routine sends fields
+      !!      like sst or ice cover to the coupler or remote application.
+      !!----------------------------------------------------------------------
+      INTEGER                   , INTENT(in   ) ::   kid       ! variable index in the array
+      INTEGER                   , INTENT(  out) ::   kinfo     ! OASIS3 info argument
+      INTEGER                   , INTENT(in   ) ::   kstep     ! ocean time-step in seconds
+      REAL(wp), DIMENSION(:,:,:), INTENT(in   ) ::   pdata
+      !!
+      INTEGER                                   ::   jc,jm     ! local loop index
+      !!--------------------------------------------------------------------
+      !
+      ! snd data to OASIS3
+      !
+      DO jc = 1, ssnd(kid)%nct
+         DO jm = 1, ssnd(kid)%ncplmodel
+        
+            IF( ssnd(kid)%nid(jc,jm) /= -1 ) THEN
+               CALL oasis_put ( ssnd(kid)%nid(jc,jm), kstep, pdata(nldi:nlei, nldj:nlej,jc), kinfo )
+               
+               IF ( ln_ctl ) THEN        
+                  IF ( kinfo == OASIS_Sent     .OR. kinfo == OASIS_ToRest .OR.   &
+                     & kinfo == OASIS_SentOut  .OR. kinfo == OASIS_ToRestOut ) THEN
+                     WRITE(numout,*) '****************'
+                     WRITE(numout,*) 'oasis_put: Outgoing ', ssnd(kid)%clname
+                     WRITE(numout,*) 'oasis_put: ivarid ', ssnd(kid)%nid(jc,jm)
+                     WRITE(numout,*) 'oasis_put:  kstep ', kstep
+                     WRITE(numout,*) 'oasis_put:   info ', kinfo
+                     WRITE(numout,*) '     - Minimum value is ', MINVAL(pdata(:,:,jc))
+                     WRITE(numout,*) '     - Maximum value is ', MAXVAL(pdata(:,:,jc))
+                     WRITE(numout,*) '     -     Sum value is ', SUM(pdata(:,:,jc))
+                     WRITE(numout,*) '****************'
+                  ENDIF
+               ENDIF
+               
+            ENDIF
+            
+         ENDDO
+      ENDDO
+      !
+    END SUBROUTINE cpl_snd
+
+
+   SUBROUTINE cpl_rcv( kid, kstep, pdata, pmask, kinfo )
+      !!---------------------------------------------------------------------
+      !!              ***  ROUTINE cpl_rcv  ***
+      !!
+      !! ** Purpose : - At each coupling time-step,this routine receives fields
+      !!      like stresses and fluxes from the coupler or remote application.
+      !!----------------------------------------------------------------------
+      INTEGER                   , INTENT(in   ) ::   kid       ! variable index in the array
+      INTEGER                   , INTENT(in   ) ::   kstep     ! ocean time-step in seconds
+      REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   pdata     ! IN to keep the value if nothing is done
+      REAL(wp), DIMENSION(:,:,:), INTENT(in   ) ::   pmask     ! coupling mask
+      INTEGER                   , INTENT(  out) ::   kinfo     ! OASIS3 info argument
+      !!
+      INTEGER                                   ::   jc,jm     ! local loop index
+      LOGICAL                                   ::   llaction, llfisrt
+      !!--------------------------------------------------------------------
+      !
+      ! receive local data from OASIS3 on every process
+      !
+      kinfo = OASIS_idle
+      !
+      DO jc = 1, srcv(kid)%nct
+         llfisrt = .TRUE.
+
+         DO jm = 1, srcv(kid)%ncplmodel
+
+            IF( srcv(kid)%nid(jc,jm) /= -1 ) THEN
+
+               CALL oasis_get ( srcv(kid)%nid(jc,jm), kstep, exfld, kinfo )         
+               
+               llaction =  kinfo == OASIS_Recvd   .OR. kinfo == OASIS_FromRest .OR.   &
+                  &        kinfo == OASIS_RecvOut .OR. kinfo == OASIS_FromRestOut
+               
+               IF ( ln_ctl )   WRITE(numout,*) "llaction, kinfo, kstep, ivarid: " , llaction, kinfo, kstep, srcv(kid)%nid(jc,jm)
+               
+               IF ( llaction ) THEN
+                  
+                  kinfo = OASIS_Rcv
+                  IF( llfisrt ) THEN 
+                     pdata(nldi:nlei,nldj:nlej,jc) =                                 exfld(:,:) * pmask(nldi:nlei,nldj:nlej,jm)
+                     llfisrt = .FALSE.
+                  ELSE
+                     pdata(nldi:nlei,nldj:nlej,jc) = pdata(nldi:nlei,nldj:nlej,jc) + exfld(:,:) * pmask(nldi:nlei,nldj:nlej,jm)
+                  ENDIF
+                  
+                  IF ( ln_ctl ) THEN        
+                     WRITE(numout,*) '****************'
+                     WRITE(numout,*) 'oasis_get: Incoming ', srcv(kid)%clname
+                     WRITE(numout,*) 'oasis_get: ivarid '  , srcv(kid)%nid(jc,jm)
+                     WRITE(numout,*) 'oasis_get:   kstep', kstep
+                     WRITE(numout,*) 'oasis_get:   info ', kinfo
+                     WRITE(numout,*) '     - Minimum value is ', MINVAL(pdata(:,:,jc))
+                     WRITE(numout,*) '     - Maximum value is ', MAXVAL(pdata(:,:,jc))
+                     WRITE(numout,*) '     -     Sum value is ', SUM(pdata(:,:,jc))
+                     WRITE(numout,*) '****************'
+                  ENDIF
+                  
+               ENDIF
+               
+            ENDIF
+            
+         ENDDO
+
+         !--- Fill the overlap areas and extra hallows (mpp)
+         !--- check periodicity conditions (all cases)
+         IF( .not. llfisrt )   CALL lbc_lnk( pdata(:,:,jc), srcv(kid)%clgrid, srcv(kid)%nsgn )   
+ 
+      ENDDO
+      !
+   END SUBROUTINE cpl_rcv
+
+
+   INTEGER FUNCTION cpl_freq( cdfieldname )  
+      !!---------------------------------------------------------------------
+      !!              ***  ROUTINE cpl_freq  ***
+      !!
+      !! ** Purpose : - send back the coupling frequency for a particular field
+      !!----------------------------------------------------------------------
+      CHARACTER(len = *), INTENT(in) ::   cdfieldname    ! field name as set in namcouple file
+      !!
+      INTEGER               :: id
+      INTEGER               :: info
+      INTEGER, DIMENSION(1) :: itmp
+      INTEGER               :: ji,jm     ! local loop index
+      INTEGER               :: mop
+      !!----------------------------------------------------------------------
+      cpl_freq = 0   ! defaut definition
+      id = -1        ! defaut definition
+      !
+      DO ji = 1, nsnd
+         IF (ssnd(ji)%laction ) THEN
+            DO jm = 1, ncplmodel
+               IF( ssnd(ji)%nid(1,jm) /= -1 ) THEN
+                  IF( TRIM(cdfieldname) == TRIM(ssnd(ji)%clname) ) THEN
+                     id = ssnd(ji)%nid(1,jm)
+                     mop = OASIS_Out
+                  ENDIF
+               ENDIF
+            ENDDO
+         ENDIF
+      ENDDO
+      DO ji = 1, nrcv
+         IF (srcv(ji)%laction ) THEN
+            DO jm = 1, ncplmodel
+               IF( srcv(ji)%nid(1,jm) /= -1 ) THEN
+                  IF( TRIM(cdfieldname) == TRIM(srcv(ji)%clname) ) THEN
+                     id = srcv(ji)%nid(1,jm)
+                     mop = OASIS_In
+                  ENDIF
+               ENDIF
+            ENDDO
+         ENDIF
+      ENDDO
+      !
+      IF( id /= -1 ) THEN
+#if defined key_oa3mct_v3
+         CALL oasis_get_freqs(id, mop, 1, itmp, info)
+#else
+         CALL oasis_get_freqs(id,      1, itmp, info)
+#endif
+         cpl_freq = itmp(1)
+      ENDIF
+      !
+   END FUNCTION cpl_freq
+
+
+   SUBROUTINE cpl_finalize
+      !!---------------------------------------------------------------------
+      !!              ***  ROUTINE cpl_finalize  ***
+      !!
+      !! ** Purpose : - Finalizes the coupling. If MPI_init has not been
+      !!      called explicitly before cpl_init it will also close
+      !!      MPI communication.
+      !!----------------------------------------------------------------------
+      !
+      DEALLOCATE( exfld )
+      IF (nstop == 0) THEN
+         CALL oasis_terminate( nerror )         
+      ELSE
+         CALL oasis_abort( ncomp_id, "cpl_finalize", "NEMO ABORT STOP" )
+      ENDIF       
+      !
+   END SUBROUTINE cpl_finalize
+
+#if ! defined key_oasis3
+
+   !!----------------------------------------------------------------------
+   !!   No OASIS Library          OASIS3 Dummy module...
+   !!----------------------------------------------------------------------
+
+   SUBROUTINE oasis_init_comp(k1,cd1,k2)
+      CHARACTER(*), INTENT(in   ) ::  cd1
+      INTEGER     , INTENT(  out) ::  k1,k2
+      k1 = -1 ; k2 = -1
+      WRITE(numout,*) 'oasis_init_comp: Error you sould not be there...', cd1
+   END SUBROUTINE oasis_init_comp
+
+   SUBROUTINE oasis_abort(k1,cd1,cd2)
+      INTEGER     , INTENT(in   ) ::  k1
+      CHARACTER(*), INTENT(in   ) ::  cd1,cd2
+      WRITE(numout,*) 'oasis_abort: Error you sould not be there...', cd1, cd2
+   END SUBROUTINE oasis_abort
+
+   SUBROUTINE oasis_get_localcomm(k1,k2)
+      INTEGER     , INTENT(  out) ::  k1,k2
+      k1 = -1 ; k2 = -1
+      WRITE(numout,*) 'oasis_get_localcomm: Error you sould not be there...'
+   END SUBROUTINE oasis_get_localcomm
+
+   SUBROUTINE oasis_def_partition(k1,k2,k3,k4)
+      INTEGER     , INTENT(  out) ::  k1,k3
+      INTEGER     , INTENT(in   ) ::  k2(5)
+      INTEGER     , INTENT(in   ) ::  k4
+      k1 = k2(1) ; k3 = k2(5)+k4
+      WRITE(numout,*) 'oasis_def_partition: Error you sould not be there...'
+   END SUBROUTINE oasis_def_partition
+
+   SUBROUTINE oasis_def_var(k1,cd1,k2,k3,k4,k5,k6,k7)
+      CHARACTER(*), INTENT(in   ) ::  cd1
+      INTEGER     , INTENT(in   ) ::  k2,k3(2),k4,k5(2,2),k6
+      INTEGER     , INTENT(  out) ::  k1,k7
+      k1 = -1 ; k7 = -1
+      WRITE(numout,*) 'oasis_def_var: Error you sould not be there...', cd1
+   END SUBROUTINE oasis_def_var
+
+   SUBROUTINE oasis_enddef(k1)
+      INTEGER     , INTENT(  out) ::  k1
+      k1 = -1
+      WRITE(numout,*) 'oasis_enddef: Error you sould not be there...'
+   END SUBROUTINE oasis_enddef
+  
+   SUBROUTINE oasis_put(k1,k2,p1,k3)
+      REAL(wp), DIMENSION(:,:), INTENT(in   ) ::  p1
+      INTEGER                 , INTENT(in   ) ::  k1,k2
+      INTEGER                 , INTENT(  out) ::  k3
+      k3 = -1
+      WRITE(numout,*) 'oasis_put: Error you sould not be there...'
+   END SUBROUTINE oasis_put
+
+   SUBROUTINE oasis_get(k1,k2,p1,k3)
+      REAL(wp), DIMENSION(:,:), INTENT(  out) ::  p1
+      INTEGER                 , INTENT(in   ) ::  k1,k2
+      INTEGER                 , INTENT(  out) ::  k3
+      p1(1,1) = -1. ; k3 = -1
+      WRITE(numout,*) 'oasis_get: Error you sould not be there...'
+   END SUBROUTINE oasis_get
+
+   SUBROUTINE oasis_get_freqs(k1,k2,k3,k4)
+      INTEGER              , INTENT(in   ) ::  k1,k2
+      INTEGER, DIMENSION(1), INTENT(  out) ::  k3
+      INTEGER              , INTENT(  out) ::  k4
+      k3(1) = k1 ; k4 = k2
+      WRITE(numout,*) 'oasis_get_freqs: Error you sould not be there...'
+   END SUBROUTINE oasis_get_freqs
+
+   SUBROUTINE oasis_terminate(k1)
+      INTEGER     , INTENT(  out) ::  k1
+      k1 = -1
+      WRITE(numout,*) 'oasis_terminate: Error you sould not be there...'
+   END SUBROUTINE oasis_terminate
+   
+#endif
+
+   !!=====================================================================
+END MODULE cpl_oasis3
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/SBC/cyclone.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/SBC/cyclone.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/SBC/cyclone.F90	(revision 9570)
@@ -0,0 +1,275 @@
+MODULE cyclone
+   !!======================================================================
+   !!                       ***  MODULE  cyclone  ***
+   !! add the Tropical Cyclones along tracks to the surface wind forcing
+   !!                 
+   !!======================================================================
+   !! History : 3.3  ! 2010-05  (E Vincent, G Madec, S Masson)  Original code
+   !!----------------------------------------------------------------------
+
+#if defined key_cyclone
+   !!----------------------------------------------------------------------
+   !!  'key_cyclone' : key option add Tropical Cyclones in the wind forcing
+   !!----------------------------------------------------------------------
+   !!   wnd_cyc      : 1 module subroutine
+   !!----------------------------------------------------------------------
+   USE oce             ! ocean dynamics and active tracers
+   USE sbc_oce         ! surface boundary condition: ocean
+   USE dom_oce         ! ocean space domain variables
+   USE phycst          ! physical constant
+   USE fldread         ! read input fields
+   USE in_out_manager  ! I/O manager
+   USE geo2ocean       ! tools for projection on ORCA grid
+   USE lib_mpp       
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   wnd_cyc   ! routine called in sbcblk.F90 module
+
+   INTEGER , PARAMETER ::   jp_is1  = 1   ! index of presence 1 or absence 0 of a TC record
+   INTEGER , PARAMETER ::   jp_lon  = 2   ! index of longitude for present TCs
+   INTEGER , PARAMETER ::   jp_lat  = 3   ! index of latitude  for present TCs
+   INTEGER , PARAMETER ::   jp_vmax = 4   ! index of max wind  for present TCs
+   INTEGER , PARAMETER ::   jp_pres = 5   ! index of eye-pres  for present TCs
+
+   TYPE(FLD), ALLOCATABLE, DIMENSION(:) ::   sf   ! structure of input fields (file informations, fields read)
+
+   !! * Substitutions
+#  include "vectopt_loop_substitute.h90"
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , LOCEAN-IPSL (2010) 
+   !! $Id$ 
+   !! Software governed by the CeCILL licence (modipsl/doc/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+
+CONTAINS
+
+   SUBROUTINE wnd_cyc( kt, pwnd_i, pwnd_j )
+      !!----------------------------------------------------------------------
+      !!                    ***  ROUTINE wnd_cyc  ***
+      !!
+      !! ** Purpose :  Add cyclone winds on the ORCA grid
+      !!
+      !! ** Action  : - open TC data, find TCs for the current timestep
+      !!              - for each potential TC, add the winds on the grid
+      !!----------------------------------------------------------------------
+      INTEGER , INTENT(in)                      ::   kt       ! time step index 
+      REAL(wp), INTENT(out), DIMENSION(jpi,jpj) ::   pwnd_i   ! wind speed i-components at T-point ORCA direction
+      REAL(wp), INTENT(out), DIMENSION(jpi,jpj) ::   pwnd_j   ! wind speed j-components at T-point ORCA direction
+      ! 
+      !!
+      INTEGER  ::   ji, jj , jtc        ! loop arguments
+      INTEGER  ::   ierror              ! loop arguments
+      INTEGER  ::   vortex=1            ! vortex shape to be used: 0=Holland 1=Willoughby
+      REAL(wp) ::   zrout1=1.5e6        ! distance from center where we begin to kill vortex (m)
+      REAL(wp) ::   zrout2=2.5e6        ! distance from center where we bring vortex to zero (m)
+      REAL(wp) ::   zb                  ! power in Holland vortex shape
+      REAL(wp) ::   zA                  ! shape parameter in Willoughby vortex : A transtion between first and second outter exp
+      REAL(wp) ::   zn                  ! shape parameter in Willoughby vortex : n power law in the eye
+      REAL(wp) ::   zXX1                ! shape parameter in Willoughby vortex : decay length second outter exponential
+      REAL(wp) ::   zXX2                ! shape parameter in Willoughby vortex : decay length first  outter exponential
+      REAL(wp) ::   zztmp               ! temporary 
+      REAL(wp) ::   zzrglam, zzrgphi    ! temporary 
+      REAL(wp) ::   ztheta              ! azimuthal angle
+      REAL(wp) ::   zdist               ! dist to the TC center
+      REAL(wp) ::   zhemi               ! 1 for NH ;  -1 for SH
+      REAL(wp) ::   zinfl               ! clim inflow angle in TCs
+      REAL(wp) ::   zrmw                ! mean radius of Max wind of a tropical cyclone (Willoughby 2004) [m]
+      REAL(wp) ::   zwnd_r, zwnd_t      ! radial and tangential components of the wind
+      REAL(wp) ::   zvmax               ! timestep interpolated vmax
+      REAL(wp) ::   zrlon, zrlat        ! temporary 
+      REAL(wp), DIMENSION(jpi,jpj) ::   zwnd_x, zwnd_y   ! zonal and meridional components of the wind
+      REAL(wp), DIMENSION(14,5)    ::   ztct                ! tropical cyclone track data at kt
+      !
+      CHARACTER(len=100) ::  cn_dir            ! Root directory for location of files
+      TYPE(FLD_N), DIMENSION(1) ::   slf_i     ! array of namelist informations on the TC position
+      TYPE(FLD_N) ::   sn_tc                   ! informations about the fields to be read
+      !!--------------------------------------------------------------------
+
+      !                                         ! ====================== !
+      IF( kt == nit000 ) THEN                   !  First call kt=nit000  !
+         !                                      ! ====================== !
+         ! set file information (default values)
+         cn_dir = './'       ! directory in which the model is executed
+         !
+         ! (NB: frequency positive => hours, negative => months)
+         !          !    file     ! frequency !  variable ! time intep !  clim   ! 'yearly' or ! weights  ! rotation   ! land/sea mask !
+         !          !    name     !  (hours)  !   name    !   (T/F)    !  (T/F)  !  'monthly'  ! filename ! pairs      ! filename      !
+         sn_tc = FLD_N( 'tc_track',     6     ,  'tc'     ,  .true.    , .false. ,   'yearly'  , ''       , ''         , ''            )
+         !
+         !  Namelist is read in namsbc_blk
+         ! set sf structure
+         ALLOCATE( sf(1), STAT=ierror )
+         IF( ierror > 0 ) THEN
+            CALL ctl_stop( 'wnd_cyc: unable to allocate sf structure' )   ;   RETURN
+         ENDIF
+         ALLOCATE( sf(1)%fnow(14,5,1) )
+         ALLOCATE( sf(1)%fdta(14,5,1,2) )
+         slf_i(1) = sn_tc
+         !
+         ! fill sf with slf_i and control print
+         CALL fld_fill( sf, slf_i, cn_dir, 'sbc_blk_tc', 'tropical cyclone track', 'namsbc_tc' )
+         !
+      ENDIF
+
+
+      !       Interpolation of lon lat vmax... at the current timestep
+      !       ***************************************************************
+
+      CALL fld_read( kt, nn_fsbc, sf )                   ! input fields provided at the current time-step
+
+      ztct(:,:) = sf(1)%fnow(:,:,1)
+
+      !       Add TC wind on the grid
+      !       ***************************************************************
+
+      zwnd_x(:,:) = 0.e0  
+      zwnd_y(:,:) = 0.e0 
+      
+      DO jtc = 1, 14
+         !
+         IF( ztct(jtc,jp_is1) == 1 ) THEN                ! cyclone is defined in this slot ? yes--> begin
+
+            zvmax =       ztct(jtc,jp_vmax)
+            zrlon = rad * ztct(jtc,jp_lon )
+            zrlat = rad * ztct(jtc,jp_lat )
+            zhemi = SIGN( 1. , zrlat )
+            zinfl = 15.* rad                             ! clim inflow angle in Tropical Cyclones
+         IF ( vortex == 0 ) THEN
+
+            ! Vortex Holland reconstruct wind at each lon-lat position
+            ! ********************************************************
+            zrmw = 51.6 * EXP( -0.0223*zvmax + 0.0281* ABS( ztct(jtc,jp_lat) ) ) * 1000.
+            ! climatological ZRMW of cyclones as a function of wind and latitude (Willoughby 2004)             
+            ! zb = 1.0036 + 0.0173 * zvmax - 0.0313 * LOG(zrmw/1000.) + 0.0087 * ABS( ztct(jtc,jp_lat) ) 
+            ! fitted B parameter (Willoughby 2004)
+            zb = 2.
+
+            DO jj = 1, jpj
+               DO ji = 1, jpi
+
+                  ! calc distance between TC center and any point following great circle
+                  ! source : http://www.movable-type.co.uk/scripts/latlong.html
+                  zzrglam = rad * glamt(ji,jj) - zrlon
+                  zzrgphi = rad * gphit(ji,jj)
+                  zdist = ra * ACOS(  SIN( zrlat ) * SIN( zzrgphi )   &
+                     &              + COS( zrlat ) * COS( zzrgphi ) * COS( zzrglam ) )
+
+                 IF (zdist < zrout2) THEN ! calculation of wind only to a given max radius
+                  ! shape of the wind profile
+                  zztmp = ( zrmw / ( zdist + 1.e-12 ) )**zb
+                  zztmp =  zvmax * SQRT( zztmp * EXP(1. - zztmp) )    
+
+                  IF (zdist > zrout1) THEN ! bring to zero between r_out1 and r_out2
+                     zztmp = zztmp * ( (zrout2-zdist)*1.e-6 )
+                  ENDIF
+
+                  ! !!! KILL EQ WINDS
+                  ! IF (SIGN( 1. , zrlat ) /= zhemi) THEN
+                  !    zztmp = 0.                              ! winds in other hemisphere
+                  !    IF (ABS(gphit(ji,jj)) <= 5.) zztmp=0.   ! kill between 5N-5S
+                  ! ENDIF
+                  ! IF (ABS(gphit(ji,jj)) <= 10. .and. ABS(gphit(ji,jj)) > 5.) THEN
+                  !    zztmp = zztmp * ( 1./5. * (ABS(gphit(ji,jj)) - 5.) ) 
+                  !    !linear to zero between 10 and 5
+                  ! ENDIF
+                  ! !!! / KILL EQ
+
+                  IF (ABS(gphit(ji,jj)) >= 55.) zztmp = 0. ! kill weak spurious winds at high latitude
+
+                  zwnd_t =   COS( zinfl ) * zztmp    
+                  zwnd_r = - SIN( zinfl ) * zztmp
+
+                  ! Project radial-tangential components on zonal-meridional components
+                  ! -------------------------------------------------------------------
+                  
+                  ! ztheta = azimuthal angle of the great circle between two points
+                  zztmp = COS( zrlat ) * SIN( zzrgphi ) &
+                     &  - SIN( zrlat ) * COS( zzrgphi ) * COS( zzrglam )
+                  ztheta = ATAN2(        COS( zzrgphi ) * SIN( zzrglam ) , zztmp )
+
+                  zwnd_x(ji,jj) = zwnd_x(ji,jj) - zhemi * COS(ztheta)*zwnd_t + SIN(ztheta)*zwnd_r
+                  zwnd_y(ji,jj) = zwnd_y(ji,jj) + zhemi * SIN(ztheta)*zwnd_t + COS(ztheta)*zwnd_r
+                 ENDIF
+               END DO
+            END DO
+         
+         ELSE IF ( vortex == 1 ) THEN
+
+            ! Vortex Willoughby reconstruct wind at each lon-lat position
+            ! ***********************************************************
+            zrmw = 46.4 * EXP( -0.0155*zvmax + 0.0169* ABS( ztct(jtc,jp_lat) ) )*1000.
+            ! climatological ZRMW of cyclones as a function of wind and latitude (Willoughby 2006)
+            zXX2 = 25.*1000.                                              ! 25km fixed "near-eye" exponential decay
+            zXX1 = ( 287.6  - 1.942 *zvmax + 7.799 *LOG(zrmw/1000.) + 1.819 *ABS( ztct(jtc,jp_lat) ) )*1000.    
+            zn   =   2.1340 + 0.0077*zvmax - 0.4522*LOG(zrmw/1000.) - 0.0038*ABS( ztct(jtc,jp_lat) )            
+            zA   =   0.5913 + 0.0029*zvmax - 0.1361*LOG(zrmw/1000.) - 0.0042*ABS( ztct(jtc,jp_lat) )  
+            IF (zA < 0) THEN 
+               zA=0
+            ENDIF           
+        
+            DO jj = 1, jpj
+               DO ji = 1, jpi
+                                  
+                  zzrglam = rad * glamt(ji,jj) - zrlon
+                  zzrgphi = rad * gphit(ji,jj)
+                  zdist = ra * ACOS(  SIN( zrlat ) * SIN( zzrgphi )   &
+                     &              + COS( zrlat ) * COS( zzrgphi ) * COS( zzrglam ) )
+
+                 IF (zdist < zrout2) THEN ! calculation of wind only to a given max radius
+               
+                  ! shape of the wind profile                     
+                  IF (zdist <= zrmw) THEN     ! inside the Radius of Maximum Wind
+                     zztmp  = zvmax * (zdist/zrmw)**zn
+                  ELSE 
+                     zztmp  = zvmax * ( (1-zA) * EXP(- (zdist-zrmw)/zXX1 ) + zA * EXP(- (zdist-zrmw)/zXX2 ) )
+                  ENDIF
+
+                  IF (zdist > zrout1) THEN ! bring to zero between r_out1 and r_out2
+                     zztmp = zztmp * ( (zrout2-zdist)*1.e-6 )
+                  ENDIF
+
+                  ! !!! KILL EQ WINDS
+                  ! IF (SIGN( 1. , zrlat ) /= zhemi) THEN
+                  !    zztmp = 0.                              ! winds in other hemisphere
+                  !    IF (ABS(gphit(ji,jj)) <= 5.) zztmp=0.   ! kill between 5N-5S
+                  ! ENDIF
+                  ! IF (ABS(gphit(ji,jj)) <= 10. .and. ABS(gphit(ji,jj)) > 5.) THEN
+                  !    zztmp = zztmp * ( 1./5. * (ABS(gphit(ji,jj)) - 5.) ) 
+                  !    !linear to zero between 10 and 5
+                  ! ENDIF
+                  ! !!! / KILL EQ
+
+                  IF (ABS(gphit(ji,jj)) >= 55.) zztmp = 0. ! kill weak spurious winds at high latitude
+
+                  zwnd_t =   COS( zinfl ) * zztmp    
+                  zwnd_r = - SIN( zinfl ) * zztmp
+
+                  ! Project radial-tangential components on zonal-meridional components
+                  ! -------------------------------------------------------------------
+                  
+                  ! ztheta = azimuthal angle of the great circle between two points
+                  zztmp = COS( zrlat ) * SIN( zzrgphi ) &
+                     &  - SIN( zrlat ) * COS( zzrgphi ) * COS( zzrglam )
+                  ztheta = ATAN2(        COS( zzrgphi ) * SIN( zzrglam ) , zztmp )
+
+                  zwnd_x(ji,jj) = zwnd_x(ji,jj) - zhemi * COS(ztheta)*zwnd_t + SIN(ztheta)*zwnd_r
+                  zwnd_y(ji,jj) = zwnd_y(ji,jj) + zhemi * SIN(ztheta)*zwnd_t + COS(ztheta)*zwnd_r
+                  
+                 ENDIF
+               END DO
+            END DO
+         ENDIF                                         ! / vortex Holland or Wiloughby
+         ENDIF                                           ! / cyclone is defined in this slot ? yes--> begin
+      END DO ! / end simultaneous cyclones loop
+
+      CALL rot_rep ( zwnd_x, zwnd_y, 'T', 'en->i', pwnd_i ) !rotation of components on ORCA grid
+      CALL rot_rep ( zwnd_x, zwnd_y, 'T', 'en->j', pwnd_j ) !rotation of components on ORCA grid
+
+   END SUBROUTINE wnd_cyc
+
+#endif
+
+   !!======================================================================
+END MODULE cyclone
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/SBC/fldread.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/SBC/fldread.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/SBC/fldread.F90	(revision 9570)
@@ -0,0 +1,1911 @@
+MODULE fldread
+   !!======================================================================
+   !!                       ***  MODULE  fldread  ***
+   !! Ocean forcing:  read input field for surface boundary condition
+   !!=====================================================================
+   !! History :  2.0  !  2006-06  (S. Masson, G. Madec)  Original code
+   !!            3.0  !  2008-05  (S. Alderson)  Modified for Interpolation in memory from input grid to model grid
+   !!            3.4  !  2013-10  (D. Delrosso, P. Oddo)  suppression of land point prior to interpolation
+   !!                 !  12-2015  (J. Harle) Adding BDY on-the-fly interpolation
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   fld_read      : read input fields used for the computation of the surface boundary condition
+   !!   fld_init      : initialization of field read
+   !!   fld_rec       : determined the record(s) to be read
+   !!   fld_get       : read the data
+   !!   fld_map       : read global data from file and map onto local data using a general mapping (use for open boundaries)
+   !!   fld_rot       : rotate the vector fields onto the local grid direction
+   !!   fld_clopn     : update the data file name and close/open the files
+   !!   fld_fill      : fill the data structure with the associated information read in namelist
+   !!   wgt_list      : manage the weights used for interpolation
+   !!   wgt_print     : print the list of known weights
+   !!   fld_weight    : create a WGT structure and fill in data from file, restructuring as required
+   !!   apply_seaoverland : fill land with ocean values
+   !!   seaoverland   : create shifted matrices for seaoverland application
+   !!   fld_interp    : apply weights to input gridded data to create data on model grid
+   !!   ksec_week     : function returning the first 3 letters of the first day of the weekly file
+   !!----------------------------------------------------------------------
+   USE oce            ! ocean dynamics and tracers
+   USE dom_oce        ! ocean space and time domain
+   USE phycst         ! physical constant
+   USE sbc_oce        ! surface boundary conditions : fields
+   USE geo2ocean      ! for vector rotation on to model grid
+   !
+   USE in_out_manager ! I/O manager
+   USE iom            ! I/O manager library
+   USE ioipsl  , ONLY : ymds2ju, ju2ymds   ! for calendar
+   USE lib_mpp        ! MPP library
+   USE lbclnk         ! ocean lateral boundary conditions (C1D case)
+   
+   IMPLICIT NONE
+   PRIVATE   
+ 
+   PUBLIC   fld_map    ! routine called by tides_init
+   PUBLIC   fld_read, fld_fill   ! called by sbc... modules
+   PUBLIC   fld_clopn
+
+   TYPE, PUBLIC ::   FLD_N      !: Namelist field informations
+      CHARACTER(len = 256) ::   clname      ! generic name of the NetCDF flux file
+      REAL(wp)             ::   nfreqh      ! frequency of each flux file
+      CHARACTER(len = 34)  ::   clvar       ! generic name of the variable in the NetCDF flux file
+      LOGICAL              ::   ln_tint     ! time interpolation or not (T/F)
+      LOGICAL              ::   ln_clim     ! climatology or not (T/F)
+      CHARACTER(len = 8)   ::   cltype      ! type of data file 'daily', 'monthly' or yearly'
+      CHARACTER(len = 256) ::   wname       ! generic name of a NetCDF weights file to be used, blank if not
+      CHARACTER(len = 34)  ::   vcomp       ! symbolic component name if a vector that needs rotation
+      !                                     ! a string starting with "U" or "V" for each component   
+      !                                     ! chars 2 onwards identify which components go together  
+      CHARACTER(len = 34)  ::   lname       ! generic name of a NetCDF land/sea mask file to be used, blank if not 
+      !                                     ! 0=sea 1=land
+   END TYPE FLD_N
+
+   TYPE, PUBLIC ::   FLD        !: Input field related variables
+      CHARACTER(len = 256)            ::   clrootname   ! generic name of the NetCDF file
+      CHARACTER(len = 256)            ::   clname       ! current name of the NetCDF file
+      REAL(wp)                        ::   nfreqh       ! frequency of each flux file
+      CHARACTER(len = 34)             ::   clvar        ! generic name of the variable in the NetCDF flux file
+      LOGICAL                         ::   ln_tint      ! time interpolation or not (T/F)
+      LOGICAL                         ::   ln_clim      ! climatology or not (T/F)
+      CHARACTER(len = 8)              ::   cltype       ! type of data file 'daily', 'monthly' or yearly'
+      INTEGER                         ::   num          ! iom id of the jpfld files to be read
+      INTEGER , DIMENSION(2)          ::   nrec_b       ! before record (1: index, 2: second since Jan. 1st 00h of nit000 year)
+      INTEGER , DIMENSION(2)          ::   nrec_a       ! after  record (1: index, 2: second since Jan. 1st 00h of nit000 year)
+      REAL(wp) , ALLOCATABLE, DIMENSION(:,:,:  ) ::   fnow   ! input fields interpolated to now time step
+      REAL(wp) , ALLOCATABLE, DIMENSION(:,:,:,:) ::   fdta   ! 2 consecutive record of input fields
+      CHARACTER(len = 256)            ::   wgtname      ! current name of the NetCDF weight file acting as a key
+      !                                                 ! into the WGTLIST structure
+      CHARACTER(len = 34)             ::   vcomp        ! symbolic name for a vector component that needs rotation
+      LOGICAL, DIMENSION(2)           ::   rotn         ! flag to indicate whether before/after field has been rotated
+      INTEGER                         ::   nreclast     ! last record to be read in the current file
+      CHARACTER(len = 256)            ::   lsmname      ! current name of the NetCDF mask file acting as a key
+      INTEGER                         ::   igrd         ! grid type for bdy data
+      INTEGER                         ::   ibdy         ! bdy set id number
+   END TYPE FLD
+
+   TYPE, PUBLIC ::   MAP_POINTER      !: Map from input data file to local domain
+      INTEGER, POINTER, DIMENSION(:)  ::  ptr           ! Array of integer pointers to 1D arrays
+      LOGICAL                         ::  ll_unstruc    ! Unstructured (T) or structured (F) boundary data file
+   END TYPE MAP_POINTER
+
+!$AGRIF_DO_NOT_TREAT
+
+   !! keep list of all weights variables so they're only read in once
+   !! need to add AGRIF directives not to process this structure
+   !! also need to force wgtname to include AGRIF nest number
+   TYPE         ::   WGT        !: Input weights related variables
+      CHARACTER(len = 256)                    ::   wgtname      ! current name of the NetCDF weight file
+      INTEGER , DIMENSION(2)                  ::   ddims        ! shape of input grid
+      INTEGER , DIMENSION(2)                  ::   botleft      ! top left corner of box in input grid containing 
+      !                                                         ! current processor grid
+      INTEGER , DIMENSION(2)                  ::   topright     ! top right corner of box 
+      INTEGER                                 ::   jpiwgt       ! width of box on input grid
+      INTEGER                                 ::   jpjwgt       ! height of box on input grid
+      INTEGER                                 ::   numwgt       ! number of weights (4=bilinear, 16=bicubic)
+      INTEGER                                 ::   nestid       ! for agrif, keep track of nest we're in
+      INTEGER                                 ::   overlap      ! =0 when cyclic grid has no overlapping EW columns
+      !                                                         ! =>1 when they have one or more overlapping columns      
+      !                                                         ! =-1 not cyclic
+      LOGICAL                                 ::   cyclic       ! east-west cyclic or not
+      INTEGER,  DIMENSION(:,:,:), POINTER     ::   data_jpi     ! array of source integers
+      INTEGER,  DIMENSION(:,:,:), POINTER     ::   data_jpj     ! array of source integers
+      REAL(wp), DIMENSION(:,:,:), POINTER     ::   data_wgt     ! array of weights on model grid
+      REAL(wp), DIMENSION(:,:,:), POINTER     ::   fly_dta      ! array of values on input grid
+      REAL(wp), DIMENSION(:,:,:), POINTER     ::   col          ! temporary array for reading in columns
+   END TYPE WGT
+
+   INTEGER,     PARAMETER             ::   tot_wgts = 20
+   TYPE( WGT ), DIMENSION(tot_wgts)   ::   ref_wgts     ! array of wgts
+   INTEGER                            ::   nxt_wgt = 1  ! point to next available space in ref_wgts array
+   REAL(wp), PARAMETER                ::   undeff_lsm = -999.00_wp
+
+!$AGRIF_END_DO_NOT_TREAT
+
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO Consortium (2010)
+   !! $Id$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE fld_read( kt, kn_fsbc, sd, map, kit, kt_offset, jpk_bdy, fvl )
+      !!---------------------------------------------------------------------
+      !!                    ***  ROUTINE fld_read  ***
+      !!                   
+      !! ** Purpose :   provide at each time step the surface ocean fluxes
+      !!                (momentum, heat, freshwater and runoff) 
+      !!
+      !! ** Method  :   READ each input fields in NetCDF files using IOM
+      !!      and intepolate it to the model time-step.
+      !!         Several assumptions are made on the input file:
+      !!      blahblahblah....
+      !!----------------------------------------------------------------------
+      INTEGER  , INTENT(in   )               ::   kt        ! ocean time step
+      INTEGER  , INTENT(in   )               ::   kn_fsbc   ! sbc computation period (in time step) 
+      TYPE(FLD), INTENT(inout), DIMENSION(:) ::   sd        ! input field related variables
+      TYPE(MAP_POINTER),INTENT(in), OPTIONAL, DIMENSION(:) ::   map   ! global-to-local mapping indices
+      INTEGER  , INTENT(in   ), OPTIONAL     ::   kit       ! subcycle timestep for timesplitting option
+      INTEGER  , INTENT(in   ), OPTIONAL     ::   kt_offset ! provide fields at time other than "now"
+      !                                                     !   kt_offset = -1 => fields at "before" time level
+      !                                                     !   kt_offset = +1 => fields at "after"  time level
+      !                                                     !   etc.
+      INTEGER  , INTENT(in   ), OPTIONAL     ::   jpk_bdy   ! number of vertical levels in the BDY data
+      LOGICAL  , INTENT(in   ), OPTIONAL     ::   fvl   ! number of vertical levels in the BDY data
+      !!
+      INTEGER  ::   itmp         ! local variable
+      INTEGER  ::   imf          ! size of the structure sd
+      INTEGER  ::   jf           ! dummy indices
+      INTEGER  ::   isecend      ! number of second since Jan. 1st 00h of nit000 year at nitend
+      INTEGER  ::   isecsbc      ! number of seconds between Jan. 1st 00h of nit000 year and the middle of sbc time step
+      INTEGER  ::   it_offset    ! local time offset variable
+      LOGICAL  ::   llnxtyr      ! open next year  file?
+      LOGICAL  ::   llnxtmth     ! open next month file?
+      LOGICAL  ::   llstop       ! stop is the file does not exist
+      LOGICAL  ::   ll_firstcall ! true if this is the first call to fld_read for this set of fields
+      REAL(wp) ::   ztinta       ! ratio applied to after  records when doing time interpolation
+      REAL(wp) ::   ztintb       ! ratio applied to before records when doing time interpolation
+      CHARACTER(LEN=1000) ::   clfmt  ! write format
+      TYPE(MAP_POINTER)   ::   imap   ! global-to-local mapping indices
+      !!---------------------------------------------------------------------
+      ll_firstcall = kt == nit000
+      IF( PRESENT(kit) )   ll_firstcall = ll_firstcall .and. kit == 1
+
+      IF ( nn_components == jp_iam_sas ) THEN   ;   it_offset = nn_fsbc
+      ELSE                                      ;   it_offset = 0
+      ENDIF
+      IF( PRESENT(kt_offset) )   it_offset = kt_offset
+
+      imap%ptr => NULL()
+
+      ! Note that shifting time to be centrered in the middle of sbc time step impacts only nsec_* variables of the calendar 
+      IF( present(kit) ) THEN   ! ignore kn_fsbc in this case
+         isecsbc = nsec_year + nsec1jan000 + (kit+it_offset)*NINT( rdt/REAL(nn_baro,wp) )
+      ELSE                      ! middle of sbc time step
+         isecsbc = nsec_year + nsec1jan000 + NINT(0.5 * REAL(kn_fsbc - 1,wp) * rdt) + it_offset * NINT(rdt)
+      ENDIF
+      imf = SIZE( sd )
+      !
+      IF( ll_firstcall ) THEN                      ! initialization
+         DO jf = 1, imf 
+            IF( PRESENT(map) ) imap = map(jf)
+               IF( PRESENT(jpk_bdy) ) THEN
+                  CALL fld_init( kn_fsbc, sd(jf), imap, jpk_bdy, fvl )  ! read each before field (put them in after as they will be swapped)
+               ELSE
+                  CALL fld_init( kn_fsbc, sd(jf), imap )  ! read each before field (put them in after as they will be swapped)
+               ENDIF
+         END DO
+         IF( lwp ) CALL wgt_print()                ! control print
+      ENDIF
+      !                                            ! ====================================== !
+      IF( MOD( kt-1, kn_fsbc ) == 0 ) THEN         ! update field at each kn_fsbc time-step !
+         !                                         ! ====================================== !
+         !
+         DO jf = 1, imf                            ! ---   loop over field   --- !
+            
+            IF( isecsbc > sd(jf)%nrec_a(2) .OR. ll_firstcall ) THEN    ! read/update the after data?
+
+               IF( PRESENT(map) )   imap = map(jf)   ! temporary definition of map
+
+               sd(jf)%nrec_b(:) = sd(jf)%nrec_a(:)                                  ! swap before record informations
+               sd(jf)%rotn(1) = sd(jf)%rotn(2)                                      ! swap before rotate informations
+               IF( sd(jf)%ln_tint )   sd(jf)%fdta(:,:,:,1) = sd(jf)%fdta(:,:,:,2)   ! swap before record field
+
+               CALL fld_rec( kn_fsbc, sd(jf), kt_offset = it_offset, kit = kit )    ! update after record informations
+
+               ! if kn_fsbc*rdt is larger than nfreqh (which is kind of odd),
+               ! it is possible that the before value is no more the good one... we have to re-read it
+               ! if before is not the last record of the file currently opened and after is the first record to be read
+               ! in a new file which means after = 1 (the file to be opened corresponds to the current time)
+               ! or after = nreclast + 1 (the file to be opened corresponds to a future time step)
+               IF( .NOT. ll_firstcall .AND. sd(jf)%ln_tint .AND. sd(jf)%nrec_b(1) /= sd(jf)%nreclast &
+                  &                   .AND. MOD( sd(jf)%nrec_a(1), sd(jf)%nreclast ) == 1 ) THEN
+                  itmp = sd(jf)%nrec_a(1)                       ! temporary storage
+                  sd(jf)%nrec_a(1) = sd(jf)%nreclast            ! read the last record of the file currently opened
+                  CALL fld_get( sd(jf), imap )                  ! read after data
+                  sd(jf)%fdta(:,:,:,1) = sd(jf)%fdta(:,:,:,2)   ! re-swap before record field
+                  sd(jf)%nrec_b(1) = sd(jf)%nrec_a(1)           ! update before record informations
+                  sd(jf)%nrec_b(2) = sd(jf)%nrec_a(2) - NINT( sd(jf)%nfreqh * 3600 )  ! assume freq to be in hours in this case
+                  sd(jf)%rotn(1)   = sd(jf)%rotn(2)             ! update before rotate informations
+                  sd(jf)%nrec_a(1) = itmp                       ! move back to after record 
+               ENDIF
+
+               CALL fld_clopn( sd(jf) )   ! Do we need to open a new year/month/week/day file?
+               
+               IF( sd(jf)%ln_tint ) THEN
+                  
+                  ! if kn_fsbc*rdt is larger than nfreqh (which is kind of odd),
+                  ! it is possible that the before value is no more the good one... we have to re-read it
+                  ! if before record is not just just before the after record...
+                  IF( .NOT. ll_firstcall .AND. MOD( sd(jf)%nrec_a(1), sd(jf)%nreclast ) /= 1 &
+                     &                   .AND. sd(jf)%nrec_b(1) /= sd(jf)%nrec_a(1) - 1 ) THEN   
+                     sd(jf)%nrec_a(1) = sd(jf)%nrec_a(1) - 1       ! move back to before record
+                     CALL fld_get( sd(jf), imap )                  ! read after data
+                     sd(jf)%fdta(:,:,:,1) = sd(jf)%fdta(:,:,:,2)   ! re-swap before record field
+                     sd(jf)%nrec_b(1) = sd(jf)%nrec_a(1)           ! update before record informations
+                     sd(jf)%nrec_b(2) = sd(jf)%nrec_a(2) - NINT( sd(jf)%nfreqh * 3600 )  ! assume freq to be in hours in this case
+                     sd(jf)%rotn(1)   = sd(jf)%rotn(2)             ! update before rotate informations
+                     sd(jf)%nrec_a(1) = sd(jf)%nrec_a(1) + 1       ! move back to after record
+                  ENDIF
+
+                  ! do we have to change the year/month/week/day of the forcing field?? 
+                  ! if we do time interpolation we will need to open next year/month/week/day file before the end of the current
+                  ! one. If so, we are still before the end of the year/month/week/day when calling fld_rec so sd(jf)%nrec_a(1)
+                  ! will be larger than the record number that should be read for current year/month/week/day
+                  ! do we need next file data?
+                  IF( sd(jf)%nrec_a(1) > sd(jf)%nreclast ) THEN
+                     
+                     sd(jf)%nrec_a(1) = sd(jf)%nrec_a(1) - sd(jf)%nreclast   ! 
+                     
+                     IF( .NOT. ( sd(jf)%ln_clim .AND. sd(jf)%cltype == 'yearly' ) ) THEN   ! close/open the current/new file
+                        
+                        llnxtmth = sd(jf)%cltype == 'monthly' .OR. nday == nmonth_len(nmonth)      ! open next month file?
+                        llnxtyr  = sd(jf)%cltype == 'yearly'  .OR. (nmonth == 12 .AND. llnxtmth)   ! open next year  file?
+
+                        ! if the run finishes at the end of the current year/month/week/day, we will allow next
+                        ! year/month/week/day file to be not present. If the run continue further than the current
+                        ! year/month/week/day, next year/month/week/day file must exist
+                        isecend = nsec_year + nsec1jan000 + (nitend - kt) * NINT(rdt)   ! second at the end of the run
+                        llstop = isecend > sd(jf)%nrec_a(2)                                   ! read more than 1 record of next year
+                        ! we suppose that the date of next file is next day (should be ok even for weekly files...)
+                        CALL fld_clopn( sd(jf), nyear  + COUNT((/llnxtyr /))                                           ,         &
+                           &                    nmonth + COUNT((/llnxtmth/)) - 12                 * COUNT((/llnxtyr /)),         &
+                           &                    nday   + 1                   - nmonth_len(nmonth) * COUNT((/llnxtmth/)), llstop )
+
+                        IF( sd(jf)%num <= 0 .AND. .NOT. llstop ) THEN    ! next year file does not exist
+                           CALL ctl_warn('next year/month/week/day file: '//TRIM(sd(jf)%clname)//     &
+                              &     ' not present -> back to current year/month/day')
+                           CALL fld_clopn( sd(jf) )       ! back to the current year/month/day
+                           sd(jf)%nrec_a(1) = sd(jf)%nreclast     ! force to read the last record in the current year file
+                        ENDIF
+                        
+                     ENDIF
+                  ENDIF   ! open need next file?
+                  
+               ENDIF   ! temporal interpolation?
+
+               ! read after data
+               IF( PRESENT(jpk_bdy) ) THEN
+                  CALL fld_get( sd(jf), imap, jpk_bdy, fvl)
+               ELSE
+                  CALL fld_get( sd(jf), imap )
+               ENDIF
+            ENDIF   ! read new data?
+         END DO                                    ! --- end loop over field --- !
+
+         CALL fld_rot( kt, sd )                    ! rotate vector before/now/after fields if needed
+
+         DO jf = 1, imf                            ! ---   loop over field   --- !
+            !
+            IF( sd(jf)%ln_tint ) THEN              ! temporal interpolation
+               IF(lwp .AND. kt - nit000 <= 100 ) THEN 
+                  clfmt = "('   fld_read: var ', a, ' kt = ', i8, ' (', f9.4,' days), Y/M/D = ', i4.4,'/', i2.2,'/', i2.2," //   &
+                     &    "', records b/a: ', i6.4, '/', i6.4, ' (days ', f9.4,'/', f9.4, ')')"
+                  WRITE(numout, clfmt)  TRIM( sd(jf)%clvar ), kt, REAL(isecsbc,wp)/rday, nyear, nmonth, nday,   &            
+                     & sd(jf)%nrec_b(1), sd(jf)%nrec_a(1), REAL(sd(jf)%nrec_b(2),wp)/rday, REAL(sd(jf)%nrec_a(2),wp)/rday
+                  WRITE(numout, *) '      it_offset is : ',it_offset
+               ENDIF
+               ! temporal interpolation weights
+               ztinta =  REAL( isecsbc - sd(jf)%nrec_b(2), wp ) / REAL( sd(jf)%nrec_a(2) - sd(jf)%nrec_b(2), wp )
+               ztintb =  1. - ztinta
+               sd(jf)%fnow(:,:,:) = ztintb * sd(jf)%fdta(:,:,:,1) + ztinta * sd(jf)%fdta(:,:,:,2)
+            ELSE   ! nothing to do...
+               IF(lwp .AND. kt - nit000 <= 100 ) THEN
+                  clfmt = "('   fld_read: var ', a, ' kt = ', i8,' (', f9.4,' days), Y/M/D = ', i4.4,'/', i2.2,'/', i2.2," //   &
+                     &    "', record: ', i6.4, ' (days ', f9.4, ' <-> ', f9.4, ')')"
+                  WRITE(numout, clfmt) TRIM(sd(jf)%clvar), kt, REAL(isecsbc,wp)/rday, nyear, nmonth, nday,    &
+                     &                 sd(jf)%nrec_a(1), REAL(sd(jf)%nrec_b(2),wp)/rday, REAL(sd(jf)%nrec_a(2),wp)/rday
+               ENDIF
+            ENDIF
+            !
+            IF( kt == nitend - kn_fsbc + 1 )   CALL iom_close( sd(jf)%num )   ! Close the input files
+
+         END DO                                    ! --- end loop over field --- !
+         !
+      ENDIF
+      !
+   END SUBROUTINE fld_read
+
+
+   SUBROUTINE fld_init( kn_fsbc, sdjf, map , jpk_bdy, fvl)
+      !!---------------------------------------------------------------------
+      !!                    ***  ROUTINE fld_init  ***
+      !!
+      !! ** Purpose :  - first call to fld_rec to define before values
+      !!               - if time interpolation, read before data 
+      !!----------------------------------------------------------------------
+      INTEGER  , INTENT(in   ) ::   kn_fsbc      ! sbc computation period (in time step) 
+      TYPE(FLD), INTENT(inout) ::   sdjf         ! input field related variables
+      TYPE(MAP_POINTER),INTENT(in) ::   map      ! global-to-local mapping indices
+      INTEGER  , INTENT(in), OPTIONAL :: jpk_bdy ! number of vertical levels in the BDY data
+      LOGICAL  , INTENT(in), OPTIONAL :: fvl     ! number of vertical levels in the BDY data
+      !!
+      LOGICAL :: llprevyr              ! are we reading previous year  file?
+      LOGICAL :: llprevmth             ! are we reading previous month file?
+      LOGICAL :: llprevweek            ! are we reading previous week  file?
+      LOGICAL :: llprevday             ! are we reading previous day   file?
+      LOGICAL :: llprev                ! llprevyr .OR. llprevmth .OR. llprevweek .OR. llprevday
+      INTEGER :: idvar                 ! variable id 
+      INTEGER :: inrec                 ! number of record existing for this variable
+      INTEGER :: iyear, imonth, iday   ! first day of the current file in yyyy mm dd
+      INTEGER :: isec_week             ! number of seconds since start of the weekly file
+      CHARACTER(LEN=1000) ::   clfmt   ! write format
+      !!---------------------------------------------------------------------
+      llprevyr   = .FALSE.
+      llprevmth  = .FALSE.
+      llprevweek = .FALSE.
+      llprevday  = .FALSE.
+      isec_week  = 0
+      !
+      ! define record informations
+      CALL fld_rec( kn_fsbc, sdjf, ldbefore = .TRUE. )  ! return before values in sdjf%nrec_a (as we will swap it later)
+      !
+      ! Note that shifting time to be centrered in the middle of sbc time step impacts only nsec_* variables of the calendar 
+      !
+      IF( sdjf%ln_tint ) THEN ! we need to read the previous record and we will put it in the current record structure
+         !
+         IF( sdjf%nrec_a(1) == 0  ) THEN   ! we redefine record sdjf%nrec_a(1) with the last record of previous year file
+            IF    ( sdjf%nfreqh == -12 ) THEN   ! yearly mean
+               IF( sdjf%cltype == 'yearly' ) THEN             ! yearly file
+                  sdjf%nrec_a(1) = 1                                                       ! force to read the unique record
+                  llprevyr  = .NOT. sdjf%ln_clim                                           ! use previous year  file?
+               ELSE
+                  CALL ctl_stop( "fld_init: yearly mean file must be in a yearly type of file: "//TRIM(sdjf%clrootname) )
+               ENDIF
+            ELSEIF( sdjf%nfreqh ==  -1 ) THEN   ! monthly mean
+               IF( sdjf%cltype == 'monthly' ) THEN            ! monthly file
+                  sdjf%nrec_a(1) = 1                                                       ! force to read the unique record
+                  llprevmth = .TRUE.                                                       ! use previous month file?
+                  llprevyr  = llprevmth .AND. nmonth == 1                                  ! use previous year  file?
+               ELSE                                           ! yearly file
+                  sdjf%nrec_a(1) = 12                                                      ! force to read december mean
+                  llprevyr = .NOT. sdjf%ln_clim                                            ! use previous year  file?
+               ENDIF
+            ELSE                                ! higher frequency mean (in hours) 
+               IF    ( sdjf%cltype      == 'monthly' ) THEN   ! monthly file
+                  sdjf%nrec_a(1) = NINT( 24 * nmonth_len(nmonth-1) / sdjf%nfreqh )         ! last record of previous month
+                  llprevmth = .TRUE.                                                       ! use previous month file?
+                  llprevyr  = llprevmth .AND. nmonth == 1                                  ! use previous year  file?
+               ELSEIF( sdjf%cltype(1:4) == 'week'    ) THEN   ! weekly file
+                  llprevweek = .TRUE.                                                      ! use previous week  file?
+                  sdjf%nrec_a(1) = NINT( 24 * 7 / sdjf%nfreqh )                            ! last record of previous week
+                  isec_week = NINT(rday) * 7                                               ! add a shift toward previous week
+               ELSEIF( sdjf%cltype      == 'daily'   ) THEN   ! daily file
+                  sdjf%nrec_a(1) = NINT( 24 / sdjf%nfreqh )                                ! last record of previous day
+                  llprevday = .TRUE.                                                       ! use previous day   file?
+                  llprevmth = llprevday .AND. nday   == 1                                  ! use previous month file?
+                  llprevyr  = llprevmth .AND. nmonth == 1                                  ! use previous year  file?
+               ELSE                                           ! yearly file
+                  sdjf%nrec_a(1) = NINT( 24 * nyear_len(0) / sdjf%nfreqh )                 ! last record of previous year 
+                  llprevyr = .NOT. sdjf%ln_clim                                            ! use previous year  file?
+               ENDIF
+            ENDIF
+         ENDIF
+         !
+         IF ( sdjf%cltype(1:4) == 'week' ) THEN
+            isec_week = isec_week + ksec_week( sdjf%cltype(6:8) )   ! second since the beginning of the week
+            llprevmth = isec_week > nsec_month                      ! longer time since the beginning of the week than the month
+            llprevyr  = llprevmth .AND. nmonth == 1
+         ENDIF
+         llprev = llprevyr .OR. llprevmth .OR. llprevweek .OR. llprevday
+         !
+         iyear  = nyear  - COUNT((/llprevyr /))
+         imonth = nmonth - COUNT((/llprevmth/)) + 12 * COUNT((/llprevyr /))
+         iday   = nday   - COUNT((/llprevday/)) + nmonth_len(nmonth-1) * COUNT((/llprevmth/)) - isec_week / NINT(rday)
+         !
+         CALL fld_clopn( sdjf, iyear, imonth, iday, .NOT. llprev )
+         !
+         ! if previous year/month/day file does not exist, we switch to the current year/month/day
+         IF( llprev .AND. sdjf%num <= 0 ) THEN
+            CALL ctl_warn( 'previous year/month/week/day file: '//TRIM(sdjf%clrootname)//   &
+               &           ' not present -> back to current year/month/week/day' )
+            ! we force to read the first record of the current year/month/day instead of last record of previous year/month/day
+            llprev = .FALSE.
+            sdjf%nrec_a(1) = 1
+            CALL fld_clopn( sdjf )
+         ENDIF
+         !
+         IF( llprev ) THEN   ! check if the record sdjf%nrec_a(1) exists in the file
+            idvar = iom_varid( sdjf%num, sdjf%clvar )                                        ! id of the variable sdjf%clvar
+            IF( idvar <= 0 )   RETURN
+            inrec = iom_file( sdjf%num )%dimsz( iom_file( sdjf%num )%ndims(idvar), idvar )   ! size of the last dim of idvar
+            sdjf%nrec_a(1) = MIN( sdjf%nrec_a(1), inrec )   ! make sure we select an existing record
+         ENDIF
+         !
+         ! read before data in after arrays(as we will swap it later)
+         IF( PRESENT(jpk_bdy) ) THEN
+            CALL fld_get( sdjf, map, jpk_bdy, fvl )
+         ELSE
+            CALL fld_get( sdjf, map )
+         ENDIF
+         !
+         clfmt = "('   fld_init : time-interpolation for ', a, ' read previous record = ', i6, ' at time = ', f7.2, ' days')"
+         IF(lwp) WRITE(numout, clfmt) TRIM(sdjf%clvar), sdjf%nrec_a(1), REAL(sdjf%nrec_a(2),wp)/rday
+         !
+      ENDIF
+      !
+   END SUBROUTINE fld_init
+
+
+   SUBROUTINE fld_rec( kn_fsbc, sdjf, ldbefore, kit, kt_offset )
+      !!---------------------------------------------------------------------
+      !!                    ***  ROUTINE fld_rec  ***
+      !!
+      !! ** Purpose : Compute
+      !!              if sdjf%ln_tint = .TRUE.
+      !!                  nrec_a: record number and its time (nrec_b is obtained from nrec_a when swapping)
+      !!              if sdjf%ln_tint = .FALSE.
+      !!                  nrec_a(1): record number
+      !!                  nrec_b(2) and nrec_a(2): time of the beginning and end of the record (for print only)
+      !!----------------------------------------------------------------------
+      INTEGER  , INTENT(in   )           ::   kn_fsbc   ! sbc computation period (in time step) 
+      TYPE(FLD), INTENT(inout)           ::   sdjf      ! input field related variables
+      LOGICAL  , INTENT(in   ), OPTIONAL ::   ldbefore  ! sent back before record values (default = .FALSE.)
+      INTEGER  , INTENT(in   ), OPTIONAL ::   kit       ! index of barotropic subcycle
+      !                                                 ! used only if sdjf%ln_tint = .TRUE.
+      INTEGER  , INTENT(in   ), OPTIONAL ::   kt_offset ! Offset of required time level compared to "now"
+      !                                                 !   time level in units of time steps.
+      !
+      LOGICAL  ::   llbefore    ! local definition of ldbefore
+      INTEGER  ::   iendrec     ! end of this record (in seconds)
+      INTEGER  ::   imth        ! month number
+      INTEGER  ::   ifreq_sec   ! frequency mean (in seconds)
+      INTEGER  ::   isec_week   ! number of seconds since the start of the weekly file
+      INTEGER  ::   it_offset   ! local time offset variable
+      REAL(wp) ::   ztmp        ! temporary variable
+      !!----------------------------------------------------------------------
+      !
+      ! Note that shifting time to be centrered in the middle of sbc time step impacts only nsec_* variables of the calendar 
+      !
+      IF( PRESENT(ldbefore) ) THEN   ;   llbefore = ldbefore .AND. sdjf%ln_tint   ! needed only if sdjf%ln_tint = .TRUE.
+      ELSE                           ;   llbefore = .FALSE.
+      ENDIF
+      !
+      IF ( nn_components == jp_iam_sas ) THEN   ;   it_offset = nn_fsbc
+      ELSE                                      ;   it_offset = 0
+      ENDIF
+      IF( PRESENT(kt_offset) )   it_offset = kt_offset
+      IF( PRESENT(kit) ) THEN   ;   it_offset = ( kit + it_offset ) * NINT( rdt/REAL(nn_baro,wp) )
+      ELSE                      ;   it_offset =         it_offset   * NINT(       rdt            )
+      ENDIF
+      !
+      !                                      ! =========== !
+      IF    ( sdjf%nfreqh == -12 ) THEN      ! yearly mean
+         !                                   ! =========== !
+         !
+         IF( sdjf%ln_tint ) THEN                 ! time interpolation, shift by 1/2 record
+            !
+            !                  INT( ztmp )
+            !                     /|\
+            !                    1 |    *----
+            !                    0 |----(              
+            !                      |----+----|--> time
+            !                      0   /|\   1   (nday/nyear_len(1))
+            !                           |   
+            !                           |   
+            !       forcing record :    1 
+            !                            
+            ztmp = REAL( nsec_year, wp ) / ( REAL( nyear_len(1), wp ) * rday ) + 0.5 &
+           &       + REAL( it_offset, wp ) / ( REAL( nyear_len(1), wp ) * rday )
+            sdjf%nrec_a(1) = 1 + INT( ztmp ) - COUNT((/llbefore/))
+            ! swap at the middle of the year
+            IF( llbefore ) THEN   ;   sdjf%nrec_a(2) = nsec1jan000 - (1 - INT(ztmp)) * NINT(0.5 * rday) * nyear_len(0) + &
+                                    & INT(ztmp) * NINT( 0.5 * rday) * nyear_len(1) 
+            ELSE                  ;   sdjf%nrec_a(2) = nsec1jan000 + (1 - INT(ztmp)) * NINT(0.5 * rday) * nyear_len(1) + &
+                                    & INT(ztmp) * INT(rday) * nyear_len(1) + INT(ztmp) * NINT( 0.5 * rday) * nyear_len(2) 
+            ENDIF
+         ELSE                                    ! no time interpolation
+            sdjf%nrec_a(1) = 1
+            sdjf%nrec_a(2) = NINT(rday) * nyear_len(1) + nsec1jan000   ! swap at the end    of the year
+            sdjf%nrec_b(2) = nsec1jan000                               ! beginning of the year (only for print)
+         ENDIF
+         !
+         !                                   ! ============ !
+      ELSEIF( sdjf%nfreqh ==  -1 ) THEN      ! monthly mean !
+         !                                   ! ============ !
+         !
+         IF( sdjf%ln_tint ) THEN                 ! time interpolation, shift by 1/2 record
+            !
+            !                  INT( ztmp )
+            !                     /|\
+            !                    1 |    *----
+            !                    0 |----(              
+            !                      |----+----|--> time
+            !                      0   /|\   1   (nday/nmonth_len(nmonth))
+            !                           |   
+            !                           |   
+            !       forcing record :  nmonth 
+            !                            
+            ztmp = REAL( nsec_month, wp ) / ( REAL( nmonth_len(nmonth), wp ) * rday ) + 0.5 &
+           &       + REAL( it_offset, wp ) / ( REAL( nmonth_len(nmonth), wp ) * rday )
+            imth = nmonth + INT( ztmp ) - COUNT((/llbefore/))
+            IF( sdjf%cltype == 'monthly' ) THEN   ;   sdjf%nrec_a(1) = 1 + INT( ztmp ) - COUNT((/llbefore/))
+            ELSE                                  ;   sdjf%nrec_a(1) = imth
+            ENDIF
+            sdjf%nrec_a(2) = nmonth_half(   imth ) + nsec1jan000   ! swap at the middle of the month
+         ELSE                                    ! no time interpolation
+            IF( sdjf%cltype == 'monthly' ) THEN   ;   sdjf%nrec_a(1) = 1
+            ELSE                                  ;   sdjf%nrec_a(1) = nmonth
+            ENDIF
+            sdjf%nrec_a(2) =  nmonth_end(nmonth  ) + nsec1jan000   ! swap at the end    of the month
+            sdjf%nrec_b(2) =  nmonth_end(nmonth-1) + nsec1jan000   ! beginning of the month (only for print)
+         ENDIF
+         !
+         !                                   ! ================================ !
+      ELSE                                   ! higher frequency mean (in hours)
+         !                                   ! ================================ !
+         !
+         ifreq_sec = NINT( sdjf%nfreqh * 3600 )                                         ! frequency mean (in seconds)
+         IF( sdjf%cltype(1:4) == 'week' )   isec_week = ksec_week( sdjf%cltype(6:8) )   ! since the first day of the current week
+         ! number of second since the beginning of the file
+         IF(     sdjf%cltype      == 'monthly' ) THEN   ;   ztmp = REAL(nsec_month,wp)  ! since the first day of the current month
+         ELSEIF( sdjf%cltype(1:4) == 'week'    ) THEN   ;   ztmp = REAL(isec_week ,wp)  ! since the first day of the current week
+         ELSEIF( sdjf%cltype      == 'daily'   ) THEN   ;   ztmp = REAL(nsec_day  ,wp)  ! since 00h of the current day
+         ELSE                                           ;   ztmp = REAL(nsec_year ,wp)  ! since 00h on Jan 1 of the current year
+         ENDIF
+         ztmp = ztmp + 0.5 * REAL(kn_fsbc - 1, wp) * rdt + REAL( it_offset, wp )        ! centrered in the middle of sbc time step
+         ztmp = ztmp + 0.01 * rdt                                                       ! avoid truncation error 
+         IF( sdjf%ln_tint ) THEN                ! time interpolation, shift by 1/2 record
+            !
+            !          INT( ztmp/ifreq_sec + 0.5 )
+            !                     /|\
+            !                    2 |        *-----(
+            !                    1 |  *-----(
+            !                    0 |--(              
+            !                      |--+--|--+--|--+--|--> time
+            !                      0 /|\ 1 /|\ 2 /|\ 3    (ztmp/ifreq_sec)
+            !                         |     |     |
+            !                         |     |     |
+            !       forcing record :  1     2     3
+            !                   
+            ztmp= ztmp / REAL(ifreq_sec, wp) + 0.5
+         ELSE                                   ! no time interpolation
+            !
+            !           INT( ztmp/ifreq_sec )
+            !                     /|\
+            !                    2 |           *-----(
+            !                    1 |     *-----(
+            !                    0 |-----(              
+            !                      |--+--|--+--|--+--|--> time
+            !                      0 /|\ 1 /|\ 2 /|\ 3    (ztmp/ifreq_sec)
+            !                         |     |     |
+            !                         |     |     |
+            !       forcing record :  1     2     3
+            !                            
+            ztmp= ztmp / REAL(ifreq_sec, wp)
+         ENDIF
+         sdjf%nrec_a(1) = 1 + INT( ztmp ) - COUNT((/llbefore/))   ! record number to be read
+
+         iendrec = ifreq_sec * sdjf%nrec_a(1) + nsec1jan000       ! end of this record (in second)
+         ! add the number of seconds between 00h Jan 1 and the end of previous month/week/day (ok if nmonth=1)
+         IF( sdjf%cltype      == 'monthly' )   iendrec = iendrec + NINT(rday) * SUM(nmonth_len(1:nmonth -1))
+         IF( sdjf%cltype(1:4) == 'week'    )   iendrec = iendrec + ( nsec_year - isec_week )
+         IF( sdjf%cltype      == 'daily'   )   iendrec = iendrec + NINT(rday) * ( nday_year - 1 )
+         IF( sdjf%ln_tint ) THEN
+             sdjf%nrec_a(2) = iendrec - ifreq_sec / 2        ! swap at the middle of the record
+         ELSE
+             sdjf%nrec_a(2) = iendrec                        ! swap at the end    of the record
+             sdjf%nrec_b(2) = iendrec - ifreq_sec            ! beginning of the record (only for print)
+         ENDIF
+         !
+      ENDIF
+      !
+   END SUBROUTINE fld_rec
+
+
+   SUBROUTINE fld_get( sdjf, map, jpk_bdy, fvl )
+      !!---------------------------------------------------------------------
+      !!                    ***  ROUTINE fld_get  ***
+      !!
+      !! ** Purpose :   read the data
+      !!----------------------------------------------------------------------
+      TYPE(FLD)        , INTENT(inout) ::   sdjf   ! input field related variables
+      TYPE(MAP_POINTER), INTENT(in   ) ::   map    ! global-to-local mapping indices
+      INTEGER  , INTENT(in), OPTIONAL  ::   jpk_bdy ! number of vertical levels in the bdy data
+      LOGICAL  , INTENT(in), OPTIONAL  ::   fvl     ! number of vertical levels in the bdy data
+      !
+      INTEGER ::   ipk      ! number of vertical levels of sdjf%fdta ( 2D: ipk=1 ; 3D: ipk=jpk )
+      INTEGER ::   iw       ! index into wgts array
+      INTEGER ::   ipdom    ! index of the domain
+      INTEGER ::   idvar    ! variable ID
+      INTEGER ::   idmspc   ! number of spatial dimensions
+      LOGICAL ::   lmoor    ! C1D case: point data
+      !!---------------------------------------------------------------------
+      !
+      ipk = SIZE( sdjf%fnow, 3 )
+      !
+      IF( ASSOCIATED(map%ptr) ) THEN
+         IF( PRESENT(jpk_bdy) ) THEN
+            IF( sdjf%ln_tint ) THEN   ;   CALL fld_map( sdjf%num, sdjf%clvar, sdjf%fdta(:,:,:,2),                &
+                                                        sdjf%nrec_a(1), map, sdjf%igrd, sdjf%ibdy, jpk_bdy, fvl )
+            ELSE                      ;   CALL fld_map( sdjf%num, sdjf%clvar, sdjf%fnow(:,:,:  ),                &
+                                                        sdjf%nrec_a(1), map, sdjf%igrd, sdjf%ibdy, jpk_bdy, fvl )
+            ENDIF
+         ELSE
+            IF( sdjf%ln_tint ) THEN   ;   CALL fld_map( sdjf%num, sdjf%clvar, sdjf%fdta(:,:,:,2), sdjf%nrec_a(1), map )
+            ELSE                      ;   CALL fld_map( sdjf%num, sdjf%clvar, sdjf%fnow(:,:,:  ), sdjf%nrec_a(1), map )
+            ENDIF
+         ENDIF        
+      ELSE IF( LEN(TRIM(sdjf%wgtname)) > 0 ) THEN
+         CALL wgt_list( sdjf, iw )
+         IF( sdjf%ln_tint ) THEN   ;   CALL fld_interp( sdjf%num, sdjf%clvar, iw, ipk, sdjf%fdta(:,:,:,2),          & 
+            &                                                                          sdjf%nrec_a(1), sdjf%lsmname )
+         ELSE                      ;   CALL fld_interp( sdjf%num, sdjf%clvar, iw, ipk, sdjf%fnow(:,:,:  ),          &
+            &                                                                          sdjf%nrec_a(1), sdjf%lsmname )
+         ENDIF
+      ELSE
+         IF( SIZE(sdjf%fnow, 1) == jpi ) THEN   ;   ipdom = jpdom_data
+         ELSE                                   ;   ipdom = jpdom_unknown
+         ENDIF
+         ! C1D case: If product of spatial dimensions == ipk, then x,y are of
+         ! size 1 (point/mooring data): this must be read onto the central grid point
+         idvar  = iom_varid( sdjf%num, sdjf%clvar )
+         idmspc = iom_file ( sdjf%num )%ndims( idvar )
+         IF( iom_file( sdjf%num )%luld( idvar ) )   idmspc = idmspc - 1
+         lmoor  = (  idmspc == 0 .OR. PRODUCT( iom_file( sdjf%num )%dimsz( 1:MAX(idmspc,1) ,idvar ) ) == ipk  )
+         !
+         SELECT CASE( ipk )
+         CASE(1)
+            IF( lk_c1d .AND. lmoor ) THEN
+               IF( sdjf%ln_tint ) THEN
+                  CALL iom_get( sdjf%num, sdjf%clvar, sdjf%fdta(2,2,1,2), sdjf%nrec_a(1) )
+                  CALL lbc_lnk( sdjf%fdta(:,:,1,2),'Z',1. )
+               ELSE
+                  CALL iom_get( sdjf%num, sdjf%clvar, sdjf%fnow(2,2,1  ), sdjf%nrec_a(1) )
+                  CALL lbc_lnk( sdjf%fnow(:,:,1  ),'Z',1. )
+               ENDIF
+            ELSE
+               IF( sdjf%ln_tint ) THEN   ;   CALL iom_get( sdjf%num, ipdom, sdjf%clvar, sdjf%fdta(:,:,1,2), sdjf%nrec_a(1) )
+               ELSE                      ;   CALL iom_get( sdjf%num, ipdom, sdjf%clvar, sdjf%fnow(:,:,1  ), sdjf%nrec_a(1) )
+               ENDIF
+            ENDIF
+         CASE DEFAULT
+            IF (lk_c1d .AND. lmoor ) THEN
+               IF( sdjf%ln_tint ) THEN
+                  CALL iom_get( sdjf%num, jpdom_unknown, sdjf%clvar, sdjf%fdta(2,2,:,2), sdjf%nrec_a(1) )
+                  CALL lbc_lnk( sdjf%fdta(:,:,:,2),'Z',1. )
+               ELSE
+                  CALL iom_get( sdjf%num, jpdom_unknown, sdjf%clvar, sdjf%fnow(2,2,:  ), sdjf%nrec_a(1) )
+                  CALL lbc_lnk( sdjf%fnow(:,:,:  ),'Z',1. )
+               ENDIF
+            ELSE
+               IF( sdjf%ln_tint ) THEN   ;   CALL iom_get( sdjf%num, ipdom, sdjf%clvar, sdjf%fdta(:,:,:,2), sdjf%nrec_a(1) )
+               ELSE                      ;   CALL iom_get( sdjf%num, ipdom, sdjf%clvar, sdjf%fnow(:,:,:  ), sdjf%nrec_a(1) )
+               ENDIF
+            ENDIF
+         END SELECT
+      ENDIF
+      !
+      sdjf%rotn(2) = .false.   ! vector not yet rotated
+      !
+   END SUBROUTINE fld_get
+
+   SUBROUTINE fld_map( num, clvar, dta, nrec, map, igrd, ibdy, jpk_bdy, fvl )
+      !!---------------------------------------------------------------------
+      !!                    ***  ROUTINE fld_map  ***
+      !!
+      !! ** Purpose :   read global data from file and map onto local data
+      !!                using a general mapping (for open boundaries)
+      !!----------------------------------------------------------------------
+
+      USE bdy_oce, ONLY: ln_bdy, idx_bdy, dta_global, dta_global_z, dta_global_dz, dta_global2, dta_global2_z, dta_global2_dz                 ! workspace to read in global data arrays
+
+      INTEGER                   , INTENT(in ) ::   num     ! stream number
+      CHARACTER(LEN=*)          , INTENT(in ) ::   clvar   ! variable name
+      REAL(wp), DIMENSION(:,:,:), INTENT(out) ::   dta     ! output field on model grid (2 dimensional)
+      INTEGER                   , INTENT(in ) ::   nrec    ! record number to read (ie time slice)
+      TYPE(MAP_POINTER)         , INTENT(in ) ::   map     ! global-to-local mapping indices
+      INTEGER  , INTENT(in), OPTIONAL         ::   igrd, ibdy, jpk_bdy  ! grid type, set number and number of vertical levels in the bdy data
+      LOGICAL  , INTENT(in), OPTIONAL         ::   fvl     ! grid type, set number and number of vertical levels in the bdy data
+      INTEGER                                 ::   jpkm1_bdy! number of vertical levels in the bdy data minus 1
+      !!
+      INTEGER                                 ::   ipi      ! length of boundary data on local process
+      INTEGER                                 ::   ipj      ! length of dummy dimension ( = 1 )
+      INTEGER                                 ::   ipk      ! number of vertical levels of dta ( 2D: ipk=1 ; 3D: ipk=jpk )
+      INTEGER                                 ::   ilendta  ! length of data in file
+      INTEGER                                 ::   idvar    ! variable ID
+      INTEGER                                 ::   ib, ik, ji, jj   ! loop counters
+      INTEGER                                 ::   ierr
+      REAL(wp)                                ::   fv          ! fillvalue 
+      REAL(wp), POINTER, DIMENSION(:,:,:)     ::   dta_read    ! work space for global data
+      REAL(wp), POINTER, DIMENSION(:,:,:)     ::   dta_read_z  ! work space for global data
+      REAL(wp), POINTER, DIMENSION(:,:,:)     ::   dta_read_dz ! work space for global data
+      !!---------------------------------------------------------------------
+      !
+      ipi = SIZE( dta, 1 )
+      ipj = 1
+      ipk = SIZE( dta, 3 )
+      !
+      idvar   = iom_varid( num, clvar )
+      ilendta = iom_file(num)%dimsz(1,idvar)
+
+      IF ( ln_bdy ) THEN
+         ipj = iom_file(num)%dimsz(2,idvar)
+         IF( map%ll_unstruc) THEN   ! unstructured open boundary data file
+            dta_read => dta_global
+            IF( PRESENT(jpk_bdy) ) THEN
+               IF( jpk_bdy>0 ) THEN
+                  dta_read_z => dta_global_z
+                  dta_read_dz => dta_global_dz
+                  jpkm1_bdy = jpk_bdy-1
+               ENDIF
+            ENDIF
+         ELSE                       ! structured open boundary file
+            dta_read => dta_global2
+            IF( PRESENT(jpk_bdy) ) THEN
+               IF( jpk_bdy>0 ) THEN
+                  dta_read_z => dta_global2_z
+                  dta_read_dz => dta_global2_dz
+                  jpkm1_bdy = jpk_bdy-1
+               ENDIF
+            ENDIF
+         ENDIF
+      ENDIF
+
+      IF(lwp) WRITE(numout,*) 'Dim size for ',        TRIM(clvar),' is ', ilendta
+      IF(lwp) WRITE(numout,*) 'Number of levels for ',TRIM(clvar),' is ', ipk
+      !
+      SELECT CASE( ipk )
+      CASE(1)        ;   
+      CALL iom_get ( num, jpdom_unknown, clvar, dta_read(1:ilendta,1:ipj,1    ), nrec )
+         IF ( map%ll_unstruc) THEN ! unstructured open boundary data file
+            DO ib = 1, ipi
+              DO ik = 1, ipk
+                dta(ib,1,ik) =  dta_read(map%ptr(ib),1,ik)
+              END DO
+            END DO
+         ELSE ! we assume that this is a structured open boundary file
+            DO ib = 1, ipi
+               jj=1+floor(REAL(map%ptr(ib)-1)/REAL(ilendta))
+               ji=map%ptr(ib)-(jj-1)*ilendta
+               DO ik = 1, ipk
+                  dta(ib,1,ik) =  dta_read(ji,jj,ik)
+               END DO
+            END DO
+         ENDIF
+
+      !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+      ! Do we include something here to adjust barotropic velocities !
+      ! in case of a depth difference between bdy files and          !
+      ! bathymetry in the case ln_full_vel = .false. and jpk_bdy>0?  !
+      ! [as the enveloping and parital cells could change H]         !
+      !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+      CASE DEFAULT   ;
+
+      IF( PRESENT(jpk_bdy) .AND. jpk_bdy>0 ) THEN       ! boundary data not on model grid: vertical interpolation
+         CALL iom_getatt(num, '_FillValue', fv, cdvar=clvar )
+         dta_read(:,:,:) = -ABS(fv)
+         dta_read_z(:,:,:) = 0._wp
+         dta_read_dz(:,:,:) = 0._wp
+         CALL iom_get ( num, jpdom_unknown, clvar, dta_read(1:ilendta,1:ipj,1:jpk_bdy), nrec )
+         SELECT CASE( igrd )                  
+            CASE(1)
+               CALL iom_get ( num, jpdom_unknown, 'gdept', dta_read_z(1:ilendta,1:ipj,1:jpk_bdy) )
+               CALL iom_get ( num, jpdom_unknown, 'e3t',  dta_read_dz(1:ilendta,1:ipj,1:jpk_bdy) )
+            CASE(2)  
+               CALL iom_get ( num, jpdom_unknown, 'gdepu', dta_read_z(1:ilendta,1:ipj,1:jpk_bdy) )
+               CALL iom_get ( num, jpdom_unknown, 'e3u',  dta_read_dz(1:ilendta,1:ipj,1:jpk_bdy) )
+            CASE(3)
+               CALL iom_get ( num, jpdom_unknown, 'gdepv', dta_read_z(1:ilendta,1:ipj,1:jpk_bdy) )
+               CALL iom_get ( num, jpdom_unknown, 'e3v',  dta_read_dz(1:ilendta,1:ipj,1:jpk_bdy) )
+         END SELECT
+
+      IF ( ln_bdy ) & 
+         CALL fld_bdy_interp(dta_read, dta_read_z, dta_read_dz, map, jpk_bdy, igrd, ibdy, fv, dta, fvl, ilendta)
+
+      ELSE ! boundary data assumed to be on model grid
+         
+         CALL iom_get ( num, jpdom_unknown, clvar, dta_read(1:ilendta,1:ipj,1:ipk), nrec )                    
+         IF ( map%ll_unstruc) THEN ! unstructured open boundary data file
+            DO ib = 1, ipi
+              DO ik = 1, ipk
+                dta(ib,1,ik) =  dta_read(map%ptr(ib),1,ik)
+              END DO
+            END DO
+         ELSE ! we assume that this is a structured open boundary file
+            DO ib = 1, ipi
+               jj=1+floor(REAL(map%ptr(ib)-1)/REAL(ilendta))
+               ji=map%ptr(ib)-(jj-1)*ilendta
+               DO ik = 1, ipk
+                  dta(ib,1,ik) =  dta_read(ji,jj,ik)
+               END DO
+            END DO
+         ENDIF
+      ENDIF ! PRESENT(jpk_bdy)
+      END SELECT
+
+   END SUBROUTINE fld_map
+   
+   SUBROUTINE fld_bdy_interp(dta_read, dta_read_z, dta_read_dz, map, jpk_bdy, igrd, ibdy, fv, dta, fvl, ilendta)
+
+      !!---------------------------------------------------------------------
+      !!                    ***  ROUTINE fld_bdy_interp  ***
+      !!
+      !! ** Purpose :   on the fly vertical interpolation to allow the use of
+      !!                boundary data from non-native vertical grid
+      !!----------------------------------------------------------------------
+      USE bdy_oce, ONLY:  idx_bdy         ! indexing for map <-> ij transformation
+
+      REAL(wp), POINTER, DIMENSION(:,:,:), INTENT(in )     ::   dta_read      ! work space for global data
+      REAL(wp), POINTER, DIMENSION(:,:,:), INTENT(in )     ::   dta_read_z    ! work space for global data
+      REAL(wp), POINTER, DIMENSION(:,:,:), INTENT(in )     ::   dta_read_dz   ! work space for global data
+      REAL(wp) , INTENT(in)                                ::   fv            ! fillvalue and alternative -ABS(fv)
+      REAL(wp), DIMENSION(:,:,:), INTENT(out) ::   dta                        ! output field on model grid (2 dimensional)
+      TYPE(MAP_POINTER)         , INTENT(in ) ::   map                        ! global-to-local mapping indices
+      LOGICAL  , INTENT(in), OPTIONAL         ::   fvl                        ! grid type, set number and number of vertical levels in the bdy data
+      INTEGER  , INTENT(in)                   ::   igrd, ibdy, jpk_bdy        ! number of levels in bdy data
+      INTEGER  , INTENT(in)                   ::   ilendta                    ! length of data in file
+      !!
+      INTEGER                                 ::   ipi                        ! length of boundary data on local process
+      INTEGER                                 ::   ipj                        ! length of dummy dimension ( = 1 )
+      INTEGER                                 ::   ipk                        ! number of vertical levels of dta ( 2D: ipk=1 ; 3D: ipk=jpk )
+      INTEGER                                 ::   jpkm1_bdy                  ! number of levels in bdy data minus 1
+      INTEGER                                 ::   ib, ik, ikk                ! loop counters
+      INTEGER                                 ::   ji, jj, zij, zjj           ! temporary indices
+      REAL(wp)                                ::   zl, zi, zh                 ! tmp variable for current depth and interpolation factor
+      REAL(wp)                                ::   fv_alt, ztrans, ztrans_new ! fillvalue and alternative -ABS(fv)
+      CHARACTER (LEN=10)                      ::   ibstr
+      !!---------------------------------------------------------------------
+     
+
+      ipi       = SIZE( dta, 1 )
+      ipj       = SIZE( dta_read, 2 )
+      ipk       = SIZE( dta, 3 )
+      jpkm1_bdy = jpk_bdy-1
+      
+      fv_alt = -ABS(fv)  ! set _FillValue < 0 as we make use of MAXVAL and MAXLOC later
+      DO ib = 1, ipi
+            zij = idx_bdy(ibdy)%nbi(ib,igrd)
+            zjj = idx_bdy(ibdy)%nbj(ib,igrd)
+         IF(narea==2) WRITE(*,*) 'MAPI', ib, igrd, map%ptr(ib), narea-1, zij, zjj
+      ENDDO
+      !
+      IF ( map%ll_unstruc ) THEN                            ! unstructured open boundary data file
+
+         DO ib = 1, ipi
+            DO ik = 1, jpk_bdy
+               IF( ( dta_read(map%ptr(ib),1,ik) == fv ) ) THEN
+                  dta_read_z(map%ptr(ib),1,ik)  = fv_alt ! safety: put fillvalue into external depth field so consistent with data
+                  dta_read_dz(map%ptr(ib),1,ik) = 0._wp  ! safety: put 0._wp into external thickness factors to ensure transport is correct
+               ENDIF
+            ENDDO
+         ENDDO 
+
+         DO ib = 1, ipi
+            zij = idx_bdy(ibdy)%nbi(ib,igrd)
+            zjj = idx_bdy(ibdy)%nbj(ib,igrd)
+            zh  = SUM(dta_read_dz(map%ptr(ib),1,:) )
+            ! Warnings to flag differences in the input and model topgraphy - is this useful/necessary?
+            SELECT CASE( igrd )                         
+               CASE(1)
+                  IF( ABS( (zh - ht_n(zij,zjj)) / ht_n(zij,zjj)) * tmask(zij,zjj,1) > 0.01_wp ) THEN
+                     WRITE(ibstr,"(I10.10)") map%ptr(ib) 
+                     CALL ctl_warn('fld_bdy_interp: T depths differ between grids at BDY point '//TRIM(ibstr)//' by more than 1%')
+                 !   IF(lwp) WRITE(*,*) 'DEPTHT', zh, sum(e3t_n(zij,zjj,:), mask=tmask(zij,zjj,:)==1),  ht_n(zij,zjj), map%ptr(ib), ib, zij, zjj
+                  ENDIF
+               CASE(2)
+                  IF( ABS( (zh - hu_n(zij,zjj)) * r1_hu_n(zij,zjj)) * umask(zij,zjj,1) > 0.01_wp ) THEN
+                     WRITE(ibstr,"(I10.10)") map%ptr(ib) 
+                     CALL ctl_warn('fld_bdy_interp: U depths differ between grids at BDY point '//TRIM(ibstr)//' by more than 1%')
+                     IF(lwp) WRITE(*,*) 'DEPTHU', zh, sum(e3u_n(zij,zjj,:), mask=umask(zij,zjj,:)==1),  sum(umask(zij,zjj,:)), &
+                       &                hu_n(zij,zjj), map%ptr(ib), ib, zij, zjj, narea-1  , &
+                        &                dta_read(map%ptr(ib),1,:)
+                  ENDIF
+               CASE(3)
+                  IF( ABS( (zh - hv_n(zij,zjj)) * r1_hv_n(zij,zjj)) * vmask(zij,zjj,1) > 0.01_wp ) THEN
+                     WRITE(ibstr,"(I10.10)") map%ptr(ib) 
+                     CALL ctl_warn('fld_bdy_interp: V depths differ between grids at BDY point '//TRIM(ibstr)//' by more than 1%')
+                  ENDIF
+            END SELECT
+            DO ik = 1, ipk                      
+               SELECT CASE( igrd )                       
+                  CASE(1)
+                     zl =  gdept_n(zij,zjj,ik)                                          ! if using in step could use fsdept instead of gdept_n?
+                  CASE(2)
+                     IF(ln_sco) THEN
+                        zl =  ( gdept_n(zij,zjj,ik) + gdept_n(zij+1,zjj,ik) ) * 0.5_wp  ! if using in step could use fsdept instead of gdept_n?
+                     ELSE
+                        zl =  MIN( gdept_n(zij,zjj,ik), gdept_n(zij+1,zjj,ik) ) 
+                     ENDIF
+                  CASE(3)
+                     IF(ln_sco) THEN
+                        zl =  ( gdept_n(zij,zjj,ik) + gdept_n(zij,zjj+1,ik) ) * 0.5_wp  ! if using in step could use fsdept instead of gdept_n?
+                     ELSE
+                        zl =  MIN( gdept_n(zij,zjj,ik), gdept_n(zij,zjj+1,ik) )
+                     ENDIF
+               END SELECT
+               IF( zl < dta_read_z(map%ptr(ib),1,1) ) THEN                                         ! above the first level of external data
+                  dta(ib,1,ik) =  dta_read(map%ptr(ib),1,1)
+               ELSEIF( zl > MAXVAL(dta_read_z(map%ptr(ib),1,:),1) ) THEN                           ! below the last level of external data 
+                  dta(ib,1,ik) =  dta_read(map%ptr(ib),1,MAXLOC(dta_read_z(map%ptr(ib),1,:),1))
+               ELSE                                                                                ! inbetween : vertical interpolation between ikk & ikk+1
+                  DO ikk = 1, jpkm1_bdy                                                            ! when  gdept_n(ikk) < zl < gdept_n(ikk+1)
+                     IF( ( (zl-dta_read_z(map%ptr(ib),1,ikk)) * (zl-dta_read_z(map%ptr(ib),1,ikk+1)) <= 0._wp) &
+                    &    .AND. (dta_read_z(map%ptr(ib),1,ikk+1) /= fv_alt)) THEN
+                        zi           = ( zl - dta_read_z(map%ptr(ib),1,ikk) ) / &
+                       &               ( dta_read_z(map%ptr(ib),1,ikk+1) - dta_read_z(map%ptr(ib),1,ikk) )
+                        dta(ib,1,ik) = dta_read(map%ptr(ib),1,ikk) + &
+                       &               ( dta_read(map%ptr(ib),1,ikk+1) - dta_read(map%ptr(ib),1,ikk) ) * zi
+                     ENDIF
+                  END DO
+               ENDIF
+            END DO
+         END DO
+
+         IF(igrd == 2) THEN                                 ! do we need to adjust the transport term?
+            DO ib = 1, ipi
+              zij = idx_bdy(ibdy)%nbi(ib,igrd)
+              zjj = idx_bdy(ibdy)%nbj(ib,igrd)
+              zh  = SUM(dta_read_dz(map%ptr(ib),1,:) )
+              ztrans = 0._wp
+              ztrans_new = 0._wp
+              DO ik = 1, jpk_bdy                            ! calculate transport on input grid
+                  ztrans     = ztrans     + dta_read(map%ptr(ib),1,ik) * dta_read_dz(map%ptr(ib),1,ik)
+              ENDDO
+              DO ik = 1, ipk                                ! calculate transport on model grid
+                  ztrans_new = ztrans_new + dta(ib,1,ik) * e3u_n(zij,zjj,ik) * umask(zij,zjj,ik)
+              ENDDO
+              DO ik = 1, ipk                                ! make transport correction
+                 IF(fvl) THEN ! bdy data are total velocity so adjust bt transport term to match input data
+                    dta(ib,1,ik) = ( dta(ib,1,ik) + ( ztrans - ztrans_new ) * r1_hu_n(zij,zjj) ) * umask(zij,zjj,ik)
+                 ELSE ! we're just dealing with bc velocity so bt transport term should sum to zero
+                    IF( ABS(ztrans * r1_hu_n(zij,zjj)) > 0.01_wp ) &
+                   &   CALL ctl_warn('fld_bdy_interp: barotropic component of > 0.01 ms-1 found in baroclinic velocities at')
+                    dta(ib,1,ik) = dta(ib,1,ik) + ( 0._wp - ztrans_new ) * r1_hu_n(zij,zjj) * umask(zij,zjj,ik)
+                 ENDIF
+              ENDDO
+            ENDDO
+         ENDIF
+
+         IF(igrd == 3) THEN                                 ! do we need to adjust the transport term?
+            DO ib = 1, ipi
+              zij = idx_bdy(ibdy)%nbi(ib,igrd)
+              zjj = idx_bdy(ibdy)%nbj(ib,igrd)
+              zh  = SUM(dta_read_dz(map%ptr(ib),1,:) )
+              ztrans = 0._wp
+              ztrans_new = 0._wp
+              DO ik = 1, jpk_bdy                            ! calculate transport on input grid
+                  ztrans     = ztrans     + dta_read(map%ptr(ib),1,ik) * dta_read_dz(map%ptr(ib),1,ik)
+              ENDDO
+              DO ik = 1, ipk                                ! calculate transport on model grid
+                  ztrans_new = ztrans_new + dta(ib,1,ik) * e3v_n(zij,zjj,ik) * vmask(zij,zjj,ik)
+              ENDDO
+              DO ik = 1, ipk                                ! make transport correction
+                 IF(fvl) THEN ! bdy data are total velocity so adjust bt transport term to match input data
+                    dta(ib,1,ik) = ( dta(ib,1,ik) + ( ztrans - ztrans_new ) * r1_hv_n(zij,zjj) ) * vmask(zij,zjj,ik)
+                 ELSE ! we're just dealing with bc velocity so bt transport term should sum to zero
+                    dta(ib,1,ik) = dta(ib,1,ik) + ( 0._wp - ztrans_new ) * r1_hv_n(zij,zjj) * vmask(zij,zjj,ik)
+                 ENDIF
+              ENDDO
+            ENDDO
+         ENDIF
+  
+      ELSE ! structured open boundary file
+
+         DO ib = 1, ipi
+            jj=1+floor(REAL(map%ptr(ib)-1)/REAL(ilendta))
+            ji=map%ptr(ib)-(jj-1)*ilendta
+            DO ik = 1, jpk_bdy                      
+               IF( ( dta_read(ji,jj,ik) == fv ) ) THEN
+                  dta_read_z(ji,jj,ik)  = fv_alt ! safety: put fillvalue into external depth field so consistent with data
+                  dta_read_dz(ji,jj,ik) = 0._wp  ! safety: put 0._wp into external thickness factors to ensure transport is correct
+               ENDIF
+            ENDDO
+         ENDDO 
+       
+
+         DO ib = 1, ipi
+            jj=1+floor(REAL(map%ptr(ib)-1)/REAL(ilendta))
+            ji=map%ptr(ib)-(jj-1)*ilendta
+            zij = idx_bdy(ibdy)%nbi(ib,igrd)
+            zjj = idx_bdy(ibdy)%nbj(ib,igrd)
+            zh  = SUM(dta_read_dz(ji,jj,:) )
+            ! Warnings to flag differences in the input and model topgraphy - is this useful/necessary?
+            SELECT CASE( igrd )                         
+               CASE(1)
+                  IF( ABS( (zh - ht_n(zij,zjj)) / ht_n(zij,zjj)) * tmask(zij,zjj,1) > 0.01_wp ) THEN
+                     WRITE(ibstr,"(I10.10)") map%ptr(ib) 
+                     CALL ctl_warn('fld_bdy_interp: T depths differ between grids at BDY point '//TRIM(ibstr)//' by more than 1%')
+                 !   IF(lwp) WRITE(*,*) 'DEPTHT', zh, sum(e3t_n(zij,zjj,:), mask=tmask(zij,zjj,:)==1),  ht_n(zij,zjj), map%ptr(ib), ib, zij, zjj
+                  ENDIF
+               CASE(2)
+                  IF( ABS( (zh - hu_n(zij,zjj)) * r1_hu_n(zij,zjj)) * umask(zij,zjj,1) > 0.01_wp ) THEN
+                     WRITE(ibstr,"(I10.10)") map%ptr(ib) 
+                     CALL ctl_warn('fld_bdy_interp: U depths differ between grids at BDY point '//TRIM(ibstr)//' by more than 1%')
+                  ENDIF
+               CASE(3)
+                  IF( ABS( (zh - hv_n(zij,zjj)) * r1_hv_n(zij,zjj)) * vmask(zij,zjj,1) > 0.01_wp ) THEN
+                     WRITE(ibstr,"(I10.10)") map%ptr(ib) 
+                     CALL ctl_warn('fld_bdy_interp: V depths differ between grids at BDY point '//TRIM(ibstr)//' by more than 1%')
+                  ENDIF
+            END SELECT
+            DO ik = 1, ipk                      
+               SELECT CASE( igrd )                          ! coded for sco - need zco and zps option using min
+                  CASE(1)
+                     zl =  gdept_n(zij,zjj,ik)              ! if using in step could use fsdept instead of gdept_n?
+                  CASE(2)
+                     IF(ln_sco) THEN
+                        zl =  ( gdept_n(zij,zjj,ik) + gdept_n(zij+1,zjj,ik) ) * 0.5_wp  ! if using in step could use fsdept instead of gdept_n?
+                     ELSE
+                        zl =  MIN( gdept_n(zij,zjj,ik), gdept_n(zij+1,zjj,ik) )
+                     ENDIF
+                  CASE(3)
+                     IF(ln_sco) THEN
+                        zl =  ( gdept_n(zij,zjj,ik) + gdept_n(zij,zjj+1,ik) ) * 0.5_wp  ! if using in step could use fsdept instead of gdept_n?
+                     ELSE
+                        zl =  MIN( gdept_n(zij,zjj,ik), gdept_n(zij,zjj+1,ik) )
+                     ENDIF
+               END SELECT
+               IF( zl < dta_read_z(ji,jj,1) ) THEN                                      ! above the first level of external data
+                  dta(ib,1,ik) =  dta_read(ji,jj,1)
+               ELSEIF( zl > MAXVAL(dta_read_z(ji,jj,:),1) ) THEN                        ! below the last level of external data 
+                  dta(ib,1,ik) =  dta_read(ji,jj,MAXLOC(dta_read_z(ji,jj,:),1))
+               ELSE                                                                     ! inbetween : vertical interpolation between ikk & ikk+1
+                  DO ikk = 1, jpkm1_bdy                                                 ! when  gdept_n(ikk) < zl < gdept_n(ikk+1)
+                     IF( ( (zl-dta_read_z(ji,jj,ikk)) * (zl-dta_read_z(ji,jj,ikk+1)) <= 0._wp) &
+                    &    .AND. (dta_read_z(ji,jj,ikk+1) /= fv_alt)) THEN
+                        zi           = ( zl - dta_read_z(ji,jj,ikk) ) / &
+                       &               ( dta_read_z(ji,jj,ikk+1) - dta_read_z(ji,jj,ikk) )
+                        dta(ib,1,ik) = dta_read(ji,jj,ikk) + &
+                       &               ( dta_read(ji,jj,ikk+1) - dta_read(ji,jj,ikk) ) * zi
+                     ENDIF
+                  END DO
+               ENDIF
+            END DO
+         END DO
+
+         IF(igrd == 2) THEN                                 ! do we need to adjust the transport term?
+            DO ib = 1, ipi
+               jj=1+floor(REAL(map%ptr(ib)-1)/REAL(ilendta))
+               ji=map%ptr(ib)-(jj-1)*ilendta
+               zij = idx_bdy(ibdy)%nbi(ib,igrd)
+               zjj = idx_bdy(ibdy)%nbj(ib,igrd)
+               zh = SUM(dta_read_dz(ji,jj,:) )
+               ztrans = 0._wp
+               ztrans_new = 0._wp
+               DO ik = 1, jpk_bdy                            ! calculate transport on input grid
+                  ztrans = ztrans + dta_read(ji,jj,ik) * dta_read_dz(ji,jj,ik)
+               ENDDO
+               DO ik = 1, ipk                                ! calculate transport on model grid
+                  ztrans_new = ztrans_new + dta(ib,1,ik) * e3u_n(zij,zjj,ik) * umask(zij,zjj,ik)
+               ENDDO
+               DO ik = 1, ipk                                ! make transport correction
+                  IF(fvl) THEN ! bdy data are total velocity so adjust bt transport term to match input data
+                     dta(ib,1,ik) = ( dta(ib,1,ik) + ( ztrans - ztrans_new ) * r1_hu_n(zij,zjj) ) * umask(zij,zjj,ik)
+                  ELSE ! we're just dealing with bc velocity so bt transport term should sum to zero
+                     dta(ib,1,ik) = ( dta(ib,1,ik) + ( 0._wp  - ztrans_new ) * r1_hu_n(zij,zjj) ) * umask(zij,zjj,ik)
+                  ENDIF
+               ENDDO
+            ENDDO
+         ENDIF
+
+         IF(igrd == 3) THEN                                 ! do we need to adjust the transport term?
+            DO ib = 1, ipi
+               jj  = 1+floor(REAL(map%ptr(ib)-1)/REAL(ilendta))
+               ji  = map%ptr(ib)-(jj-1)*ilendta
+               zij = idx_bdy(ibdy)%nbi(ib,igrd)
+               zjj = idx_bdy(ibdy)%nbj(ib,igrd)
+               zh  = SUM(dta_read_dz(ji,jj,:) )
+               ztrans = 0._wp
+               ztrans_new = 0._wp
+               DO ik = 1, jpk_bdy                            ! calculate transport on input grid
+                  ztrans     = ztrans     + dta_read(ji,jj,ik) * dta_read_dz(ji,jj,ik)
+               ENDDO
+               DO ik = 1, ipk                                ! calculate transport on model grid
+                  ztrans_new = ztrans_new + dta(ib,1,ik) * e3v_n(zij,zjj,ik) * vmask(zij,zjj,ik)
+               ENDDO
+               DO ik = 1, ipk                                ! make transport correction
+                  IF(fvl) THEN ! bdy data are total velocity so adjust bt transport term to match input data
+                     dta(ib,1,ik) = ( dta(ib,1,ik) + ( ztrans - ztrans_new ) * r1_hv_n(zij,zjj) ) * vmask(zij,zjj,ik)
+                  ELSE ! we're just dealing with bc velocity so bt transport term should sum to zero
+                     dta(ib,1,ik) = ( dta(ib,1,ik) + ( 0._wp  - ztrans_new ) * r1_hv_n(zij,zjj) ) * vmask(zij,zjj,ik)
+                  ENDIF
+               ENDDO
+            ENDDO
+         ENDIF
+
+      ENDIF ! endif unstructured or structured
+
+   END SUBROUTINE fld_bdy_interp
+
+
+   SUBROUTINE fld_rot( kt, sd )
+      !!---------------------------------------------------------------------
+      !!                    ***  ROUTINE fld_rot  ***
+      !!
+      !! ** Purpose :   Vector fields may need to be rotated onto the local grid direction
+      !!----------------------------------------------------------------------
+      INTEGER                , INTENT(in   ) ::   kt   ! ocean time step
+      TYPE(FLD), DIMENSION(:), INTENT(inout) ::   sd   ! input field related variables
+      !
+      INTEGER ::   ju, jv, jk, jn  ! loop indices
+      INTEGER ::   imf             ! size of the structure sd
+      INTEGER ::   ill             ! character length
+      INTEGER ::   iv              ! indice of V component
+      CHARACTER (LEN=100)          ::   clcomp       ! dummy weight name
+      REAL(wp), DIMENSION(jpi,jpj) ::   utmp, vtmp   ! temporary arrays for vector rotation
+      !!---------------------------------------------------------------------
+      !
+      !! (sga: following code should be modified so that pairs arent searched for each time
+      !
+      imf = SIZE( sd )
+      DO ju = 1, imf
+         ill = LEN_TRIM( sd(ju)%vcomp )
+         DO jn = 2-COUNT((/sd(ju)%ln_tint/)), 2
+            IF( ill > 0 .AND. .NOT. sd(ju)%rotn(jn) ) THEN   ! find vector rotations required             
+               IF( sd(ju)%vcomp(1:1) == 'U' ) THEN      ! east-west component has symbolic name starting with 'U'
+                  ! look for the north-south component which has same symbolic name but with 'U' replaced with 'V'
+                  clcomp = 'V' // sd(ju)%vcomp(2:ill)   ! works even if ill == 1
+                  iv = -1
+                  DO jv = 1, imf
+                     IF( TRIM(sd(jv)%vcomp) == TRIM(clcomp) )   iv = jv
+                  END DO
+                  IF( iv > 0 ) THEN   ! fields ju and iv are two components which need to be rotated together
+                     DO jk = 1, SIZE( sd(ju)%fnow, 3 )
+                        IF( sd(ju)%ln_tint )THEN
+                           CALL rot_rep( sd(ju)%fdta(:,:,jk,jn), sd(iv)%fdta(:,:,jk,jn), 'T', 'en->i', utmp(:,:) )
+                           CALL rot_rep( sd(ju)%fdta(:,:,jk,jn), sd(iv)%fdta(:,:,jk,jn), 'T', 'en->j', vtmp(:,:) )
+                           sd(ju)%fdta(:,:,jk,jn) = utmp(:,:)   ;   sd(iv)%fdta(:,:,jk,jn) = vtmp(:,:)
+                        ELSE 
+                           CALL rot_rep( sd(ju)%fnow(:,:,jk  ), sd(iv)%fnow(:,:,jk  ), 'T', 'en->i', utmp(:,:) )
+                           CALL rot_rep( sd(ju)%fnow(:,:,jk  ), sd(iv)%fnow(:,:,jk  ), 'T', 'en->j', vtmp(:,:) )
+                           sd(ju)%fnow(:,:,jk   ) = utmp(:,:)   ;   sd(iv)%fnow(:,:,jk   ) = vtmp(:,:)
+                        ENDIF
+                     END DO
+                     sd(ju)%rotn(jn) = .TRUE.               ! vector was rotated 
+                     IF( lwp .AND. kt == nit000 )   WRITE(numout,*)   &
+                        &   'fld_read: vector pair ('//TRIM(sd(ju)%clvar)//', '//TRIM(sd(iv)%clvar)//') rotated on to model grid'
+                  ENDIF
+               ENDIF
+            ENDIF
+         END DO
+       END DO
+      !
+   END SUBROUTINE fld_rot
+
+
+   SUBROUTINE fld_clopn( sdjf, kyear, kmonth, kday, ldstop )
+      !!---------------------------------------------------------------------
+      !!                    ***  ROUTINE fld_clopn  ***
+      !!
+      !! ** Purpose :   update the file name and close/open the files
+      !!----------------------------------------------------------------------
+      TYPE(FLD)        , INTENT(inout) ::   sdjf     ! input field related variables
+      INTEGER, OPTIONAL, INTENT(in   ) ::   kyear    ! year value
+      INTEGER, OPTIONAL, INTENT(in   ) ::   kmonth   ! month value
+      INTEGER, OPTIONAL, INTENT(in   ) ::   kday     ! day value
+      LOGICAL, OPTIONAL, INTENT(in   ) ::   ldstop   ! stop if open to read a non-existing file (default = .TRUE.)
+      !
+      LOGICAL :: llprevyr              ! are we reading previous year  file?
+      LOGICAL :: llprevmth             ! are we reading previous month file?
+      INTEGER :: iyear, imonth, iday   ! first day of the current file in yyyy mm dd
+      INTEGER :: isec_week             ! number of seconds since start of the weekly file
+      INTEGER :: indexyr               ! year undex (O/1/2: previous/current/next)
+      INTEGER :: iyear_len, imonth_len ! length (days) of iyear and imonth             ! 
+      CHARACTER(len = 256)::   clname  ! temporary file name
+      !!----------------------------------------------------------------------
+      IF( PRESENT(kyear) ) THEN                             ! use given values 
+         iyear = kyear
+         imonth = kmonth
+         iday = kday
+         IF ( sdjf%cltype(1:4) == 'week' ) THEN             ! find the day of the beginning of the week
+            isec_week = ksec_week( sdjf%cltype(6:8) )- (86400 * 8 )  
+            llprevmth  = isec_week > nsec_month             ! longer time since beginning of the week than the month
+            llprevyr   = llprevmth .AND. nmonth == 1
+            iyear  = nyear  - COUNT((/llprevyr /))
+            imonth = nmonth - COUNT((/llprevmth/)) + 12 * COUNT((/llprevyr /))
+            iday   = nday   + nmonth_len(nmonth-1) * COUNT((/llprevmth/)) - isec_week / NINT(rday)
+         ENDIF
+      ELSE                                                  ! use current day values
+         IF ( sdjf%cltype(1:4) == 'week' ) THEN             ! find the day of the beginning of the week
+            isec_week  = ksec_week( sdjf%cltype(6:8) )      ! second since the beginning of the week
+            llprevmth  = isec_week > nsec_month             ! longer time since beginning of the week than the month
+            llprevyr   = llprevmth .AND. nmonth == 1
+         ELSE
+            isec_week  = 0
+            llprevmth  = .FALSE.
+            llprevyr   = .FALSE.
+         ENDIF
+         iyear  = nyear  - COUNT((/llprevyr /))
+         imonth = nmonth - COUNT((/llprevmth/)) + 12 * COUNT((/llprevyr /))
+         iday   = nday   + nmonth_len(nmonth-1) * COUNT((/llprevmth/)) - isec_week / NINT(rday)
+      ENDIF
+
+      ! build the new filename if not climatological data
+      clname=TRIM(sdjf%clrootname)
+      !
+      ! note that sdjf%ln_clim is is only acting on the presence of the year in the file name
+      IF( .NOT. sdjf%ln_clim ) THEN   
+                                         WRITE(clname, '(a,"_y",i4.4)' ) TRIM( sdjf%clrootname ), iyear    ! add year
+         IF( sdjf%cltype /= 'yearly' )   WRITE(clname, '(a,"m" ,i2.2)' ) TRIM( clname          ), imonth   ! add month
+      ELSE
+         ! build the new filename if climatological data
+         IF( sdjf%cltype /= 'yearly' )   WRITE(clname, '(a,"_m",i2.2)' ) TRIM( sdjf%clrootname ), imonth   ! add month
+      ENDIF
+      IF( sdjf%cltype == 'daily' .OR. sdjf%cltype(1:4) == 'week' ) &
+            &                            WRITE(clname, '(a,"d" ,i2.2)' ) TRIM( clname          ), iday     ! add day
+      !
+      IF( TRIM(clname) /= TRIM(sdjf%clname) .OR. sdjf%num == 0 ) THEN   ! new file to be open 
+         !
+         sdjf%clname = TRIM(clname)
+         IF( sdjf%num /= 0 )   CALL iom_close( sdjf%num )   ! close file if already open
+         CALL iom_open( sdjf%clname, sdjf%num, ldstop = ldstop, ldiof =  LEN(TRIM(sdjf%wgtname)) > 0 )
+         !
+         ! find the last record to be read -> update sdjf%nreclast
+         indexyr = iyear - nyear + 1
+         iyear_len = nyear_len( indexyr )
+         SELECT CASE ( indexyr )
+         CASE ( 0 )   ;   imonth_len = 31   ! previous year -> imonth = 12
+         CASE ( 1 )   ;   imonth_len = nmonth_len(imonth) 
+         CASE ( 2 )   ;   imonth_len = 31   ! next     year -> imonth = 1
+         END SELECT
+         !
+         ! last record to be read in the current file
+         IF    ( sdjf%nfreqh == -12 ) THEN                 ;   sdjf%nreclast = 1    !  yearly mean
+         ELSEIF( sdjf%nfreqh ==  -1 ) THEN                                          ! monthly mean
+            IF(     sdjf%cltype      == 'monthly' ) THEN   ;   sdjf%nreclast = 1
+            ELSE                                           ;   sdjf%nreclast = 12
+            ENDIF
+         ELSE                                                                       ! higher frequency mean (in hours)
+            IF(     sdjf%cltype      == 'monthly' ) THEN   ;   sdjf%nreclast = NINT( 24 * imonth_len / sdjf%nfreqh )
+            ELSEIF( sdjf%cltype(1:4) == 'week'    ) THEN   ;   sdjf%nreclast = NINT( 24 * 7          / sdjf%nfreqh )
+            ELSEIF( sdjf%cltype      == 'daily'   ) THEN   ;   sdjf%nreclast = NINT( 24              / sdjf%nfreqh )
+            ELSE                                           ;   sdjf%nreclast = NINT( 24 * iyear_len  / sdjf%nfreqh )
+            ENDIF
+         ENDIF
+         !
+      ENDIF
+      !
+   END SUBROUTINE fld_clopn
+
+
+   SUBROUTINE fld_fill( sdf, sdf_n, cdir, cdcaller, cdtitle, cdnam, knoprint )
+      !!---------------------------------------------------------------------
+      !!                    ***  ROUTINE fld_fill  ***
+      !!
+      !! ** Purpose :   fill the data structure (sdf) with the associated information 
+      !!              read in namelist (sdf_n) and control print
+      !!----------------------------------------------------------------------
+      TYPE(FLD)  , DIMENSION(:)          , INTENT(inout) ::   sdf        ! structure of input fields (file informations, fields read)
+      TYPE(FLD_N), DIMENSION(:)          , INTENT(in   ) ::   sdf_n      ! array of namelist information structures
+      CHARACTER(len=*)                   , INTENT(in   ) ::   cdir       ! Root directory for location of flx files
+      CHARACTER(len=*)                   , INTENT(in   ) ::   cdcaller   ! name of the calling routine
+      CHARACTER(len=*)                   , INTENT(in   ) ::   cdtitle    ! description of the calling routine 
+      CHARACTER(len=*)                   , INTENT(in   ) ::   cdnam      ! name of the namelist from which sdf_n comes
+      INTEGER                  , OPTIONAL, INTENT(in   ) ::   knoprint   ! no calling routine information printed
+      !
+      INTEGER  ::   jf   ! dummy indices
+      !!---------------------------------------------------------------------
+      !
+      DO jf = 1, SIZE(sdf)
+         sdf(jf)%clrootname = TRIM( cdir )//TRIM( sdf_n(jf)%clname )
+         sdf(jf)%clname     = "not yet defined"
+         sdf(jf)%nfreqh     = sdf_n(jf)%nfreqh
+         sdf(jf)%clvar      = sdf_n(jf)%clvar
+         sdf(jf)%ln_tint    = sdf_n(jf)%ln_tint
+         sdf(jf)%ln_clim    = sdf_n(jf)%ln_clim
+         sdf(jf)%cltype     = sdf_n(jf)%cltype
+         sdf(jf)%num        = -1
+         sdf(jf)%wgtname    = " "
+         IF( LEN( TRIM(sdf_n(jf)%wname) ) > 0 )   sdf(jf)%wgtname = TRIM( cdir )//TRIM( sdf_n(jf)%wname )
+         sdf(jf)%lsmname = " "
+         IF( LEN( TRIM(sdf_n(jf)%lname) ) > 0 )   sdf(jf)%lsmname = TRIM( cdir )//TRIM( sdf_n(jf)%lname )
+         sdf(jf)%vcomp      = sdf_n(jf)%vcomp
+         sdf(jf)%rotn(:)    = .TRUE.   ! pretend to be rotated -> won't try to rotate data before the first call to fld_get
+         IF( sdf(jf)%cltype(1:4) == 'week' .AND. nn_leapy == 0  )   &
+            &   CALL ctl_stop('fld_clopn: weekly file ('//TRIM(sdf(jf)%clrootname)//') needs nn_leapy = 1')
+         IF( sdf(jf)%cltype(1:4) == 'week' .AND. sdf(jf)%ln_clim )   &
+            &   CALL ctl_stop('fld_clopn: weekly file ('//TRIM(sdf(jf)%clrootname)//') needs ln_clim = .FALSE.')
+         sdf(jf)%nreclast = -1 ! Set to non zero default value to avoid errors, is updated to meaningful value during fld_clopn
+      END DO
+      !
+      IF(lwp) THEN      ! control print
+         WRITE(numout,*)
+         IF( .NOT.PRESENT( knoprint) ) THEN
+            WRITE(numout,*) TRIM( cdcaller )//' : '//TRIM( cdtitle )
+            WRITE(numout,*) (/ ('~', jf = 1, LEN_TRIM( cdcaller ) ) /)
+         ENDIF
+         WRITE(numout,*) '   fld_fill : fill data structure with information from namelist '//TRIM( cdnam )
+         WRITE(numout,*) '   ~~~~~~~~'
+         WRITE(numout,*) '      list of files and frequency (>0: in hours ; <0 in months)'
+         DO jf = 1, SIZE(sdf)
+            WRITE(numout,*) '      root filename: '  , TRIM( sdf(jf)%clrootname ), '   variable name: ', TRIM( sdf(jf)%clvar )
+            WRITE(numout,*) '         frequency: '      ,       sdf(jf)%nfreqh      ,   &
+               &                  '   time interp: '    ,       sdf(jf)%ln_tint     ,   &
+               &                  '   climatology: '    ,       sdf(jf)%ln_clim
+            WRITE(numout,*) '         weights: '        , TRIM( sdf(jf)%wgtname    ),   &
+               &                  '   pairing: '        , TRIM( sdf(jf)%vcomp      ),   &
+               &                  '   data type: '      ,       sdf(jf)%cltype      ,   &
+               &                  '   land/sea mask:'   , TRIM( sdf(jf)%lsmname    )
+            call flush(numout)
+         END DO
+      ENDIF
+      !
+   END SUBROUTINE fld_fill
+
+
+   SUBROUTINE wgt_list( sd, kwgt )
+      !!---------------------------------------------------------------------
+      !!                    ***  ROUTINE wgt_list  ***
+      !!
+      !! ** Purpose :   search array of WGTs and find a weights file entry,
+      !!                or return a new one adding it to the end if new entry.
+      !!                the weights data is read in and restructured (fld_weight)
+      !!----------------------------------------------------------------------
+      TYPE( FLD ), INTENT(in   ) ::   sd        ! field with name of weights file
+      INTEGER    , INTENT(inout) ::   kwgt      ! index of weights
+      !
+      INTEGER ::   kw, nestid   ! local integer
+      LOGICAL ::   found        ! local logical
+      !!----------------------------------------------------------------------
+      !
+      !! search down linked list 
+      !! weights filename is either present or we hit the end of the list
+      found = .FALSE.
+      !
+      !! because agrif nest part of filenames are now added in iom_open
+      !! to distinguish between weights files on the different grids, need to track
+      !! nest number explicitly
+      nestid = 0
+#if defined key_agrif
+      nestid = Agrif_Fixed()
+#endif
+      DO kw = 1, nxt_wgt-1
+         IF( TRIM(ref_wgts(kw)%wgtname) == TRIM(sd%wgtname) .AND. &
+             ref_wgts(kw)%nestid == nestid) THEN
+            kwgt = kw
+            found = .TRUE.
+            EXIT
+         ENDIF
+      END DO
+      IF( .NOT.found ) THEN
+         kwgt = nxt_wgt
+         CALL fld_weight( sd )
+      ENDIF
+      !
+   END SUBROUTINE wgt_list
+
+
+   SUBROUTINE wgt_print( )
+      !!---------------------------------------------------------------------
+      !!                    ***  ROUTINE wgt_print  ***
+      !!
+      !! ** Purpose :   print the list of known weights
+      !!----------------------------------------------------------------------
+      INTEGER ::   kw   !
+      !!----------------------------------------------------------------------
+      !
+      DO kw = 1, nxt_wgt-1
+         WRITE(numout,*) 'weight file:  ',TRIM(ref_wgts(kw)%wgtname)
+         WRITE(numout,*) '      ddims:  ',ref_wgts(kw)%ddims(1),ref_wgts(kw)%ddims(2)
+         WRITE(numout,*) '     numwgt:  ',ref_wgts(kw)%numwgt
+         WRITE(numout,*) '     jpiwgt:  ',ref_wgts(kw)%jpiwgt
+         WRITE(numout,*) '     jpjwgt:  ',ref_wgts(kw)%jpjwgt
+         WRITE(numout,*) '    botleft:  ',ref_wgts(kw)%botleft
+         WRITE(numout,*) '   topright:  ',ref_wgts(kw)%topright
+         IF( ref_wgts(kw)%cyclic ) THEN
+            WRITE(numout,*) '       cyclical'
+            IF( ref_wgts(kw)%overlap > 0 ) WRITE(numout,*) '              with overlap of ', ref_wgts(kw)%overlap
+         ELSE
+            WRITE(numout,*) '       not cyclical'
+         ENDIF
+         IF( ASSOCIATED(ref_wgts(kw)%data_wgt) )  WRITE(numout,*) '       allocated'
+      END DO
+      !
+   END SUBROUTINE wgt_print
+
+
+   SUBROUTINE fld_weight( sd )
+      !!---------------------------------------------------------------------
+      !!                    ***  ROUTINE fld_weight  ***
+      !!
+      !! ** Purpose :   create a new WGT structure and fill in data from file,
+      !!              restructuring as required
+      !!----------------------------------------------------------------------
+      TYPE( FLD ), INTENT(in) ::   sd   ! field with name of weights file
+      !!
+      INTEGER ::   jn         ! dummy loop indices
+      INTEGER ::   inum       ! local logical unit
+      INTEGER ::   id         ! local variable id
+      INTEGER ::   ipk        ! local vertical dimension
+      INTEGER ::   zwrap      ! local integer
+      LOGICAL ::   cyclical   ! 
+      CHARACTER (len=5) ::   aname   !
+      INTEGER , DIMENSION(:), ALLOCATABLE ::   ddims
+      INTEGER,  DIMENSION(jpi,jpj) ::   data_src
+      REAL(wp), DIMENSION(jpi,jpj) ::   data_tmp
+      !!----------------------------------------------------------------------
+      !
+      IF( nxt_wgt > tot_wgts ) THEN
+        CALL ctl_stop("fld_weight: weights array size exceeded, increase tot_wgts")
+      ENDIF
+      !
+      !! new weights file entry, add in extra information
+      !! a weights file represents a 2D grid of a certain shape, so we assume that the current
+      !! input data file is representative of all other files to be opened and processed with the
+      !! current weights file
+
+      !! open input data file (non-model grid)
+      CALL iom_open( sd%clname, inum, ldiof =  LEN(TRIM(sd%wgtname)) > 0 )
+
+      !! get dimensions
+      IF ( SIZE(sd%fnow, 3) > 1 ) THEN
+         ALLOCATE( ddims(4) )
+      ELSE
+         ALLOCATE( ddims(3) )
+      ENDIF
+      id = iom_varid( inum, sd%clvar, ddims )
+
+      !! close it
+      CALL iom_close( inum )
+
+      !! now open the weights file
+
+      CALL iom_open ( sd%wgtname, inum )   ! interpolation weights
+      IF ( inum > 0 ) THEN
+
+         !! determine whether we have an east-west cyclic grid
+         !! from global attribute called "ew_wrap" in the weights file
+         !! note that if not found, iom_getatt returns -999 and cyclic with no overlap is assumed
+         !! since this is the most common forcing configuration
+
+         CALL iom_getatt(inum, 'ew_wrap', zwrap)
+         IF( zwrap >= 0 ) THEN
+            cyclical = .TRUE.
+         ELSE IF( zwrap == -999 ) THEN
+            cyclical = .TRUE.
+            zwrap = 0
+         ELSE
+            cyclical = .FALSE.
+         ENDIF
+
+         ref_wgts(nxt_wgt)%ddims(1) = ddims(1)
+         ref_wgts(nxt_wgt)%ddims(2) = ddims(2)
+         ref_wgts(nxt_wgt)%wgtname = sd%wgtname
+         ref_wgts(nxt_wgt)%overlap = zwrap
+         ref_wgts(nxt_wgt)%cyclic = cyclical
+         ref_wgts(nxt_wgt)%nestid = 0
+#if defined key_agrif
+         ref_wgts(nxt_wgt)%nestid = Agrif_Fixed()
+#endif
+         !! weights file is stored as a set of weights (wgt01->wgt04 or wgt01->wgt16)
+         !! for each weight wgtNN there is an integer array srcNN which gives the point in
+         !! the input data grid which is to be multiplied by the weight
+         !! they are both arrays on the model grid so the result of the multiplication is
+         !! added into an output array on the model grid as a running sum
+
+         !! two possible cases: bilinear (4 weights) or bicubic (16 weights)
+         id = iom_varid(inum, 'src05', ldstop=.FALSE.)
+         IF( id <= 0) THEN
+            ref_wgts(nxt_wgt)%numwgt = 4
+         ELSE
+            ref_wgts(nxt_wgt)%numwgt = 16
+         ENDIF
+
+         ALLOCATE( ref_wgts(nxt_wgt)%data_jpi(jpi,jpj,4) )
+         ALLOCATE( ref_wgts(nxt_wgt)%data_jpj(jpi,jpj,4) )
+         ALLOCATE( ref_wgts(nxt_wgt)%data_wgt(jpi,jpj,ref_wgts(nxt_wgt)%numwgt) )
+
+         DO jn = 1,4
+            aname = ' '
+            WRITE(aname,'(a3,i2.2)') 'src',jn
+            data_tmp(:,:) = 0
+            CALL iom_get ( inum, jpdom_data, aname, data_tmp(:,:) )
+            data_src(:,:) = INT(data_tmp(:,:))
+            ref_wgts(nxt_wgt)%data_jpj(:,:,jn) = 1 + (data_src(:,:)-1) / ref_wgts(nxt_wgt)%ddims(1)
+            ref_wgts(nxt_wgt)%data_jpi(:,:,jn) = data_src(:,:) - ref_wgts(nxt_wgt)%ddims(1)*(ref_wgts(nxt_wgt)%data_jpj(:,:,jn)-1)
+         END DO
+
+         DO jn = 1, ref_wgts(nxt_wgt)%numwgt
+            aname = ' '
+            WRITE(aname,'(a3,i2.2)') 'wgt',jn
+            ref_wgts(nxt_wgt)%data_wgt(:,:,jn) = 0.0
+            CALL iom_get ( inum, jpdom_data, aname, ref_wgts(nxt_wgt)%data_wgt(:,:,jn) )
+         END DO
+         CALL iom_close (inum)
+ 
+         ! find min and max indices in grid
+         ref_wgts(nxt_wgt)%botleft(1) = MINVAL(ref_wgts(nxt_wgt)%data_jpi(:,:,:))
+         ref_wgts(nxt_wgt)%botleft(2) = MINVAL(ref_wgts(nxt_wgt)%data_jpj(:,:,:))
+         ref_wgts(nxt_wgt)%topright(1) = MAXVAL(ref_wgts(nxt_wgt)%data_jpi(:,:,:))
+         ref_wgts(nxt_wgt)%topright(2) = MAXVAL(ref_wgts(nxt_wgt)%data_jpj(:,:,:))
+
+         ! and therefore dimensions of the input box
+         ref_wgts(nxt_wgt)%jpiwgt = ref_wgts(nxt_wgt)%topright(1) - ref_wgts(nxt_wgt)%botleft(1) + 1
+         ref_wgts(nxt_wgt)%jpjwgt = ref_wgts(nxt_wgt)%topright(2) - ref_wgts(nxt_wgt)%botleft(2) + 1
+
+         ! shift indexing of source grid
+         ref_wgts(nxt_wgt)%data_jpi(:,:,:) = ref_wgts(nxt_wgt)%data_jpi(:,:,:) - ref_wgts(nxt_wgt)%botleft(1) + 1
+         ref_wgts(nxt_wgt)%data_jpj(:,:,:) = ref_wgts(nxt_wgt)%data_jpj(:,:,:) - ref_wgts(nxt_wgt)%botleft(2) + 1
+
+         ! create input grid, give it a halo to allow gradient calculations
+         ! SA: +3 stencil is a patch to avoid out-of-bound computation in some configuration. 
+         ! a more robust solution will be given in next release
+         ipk =  SIZE(sd%fnow, 3)
+         ALLOCATE( ref_wgts(nxt_wgt)%fly_dta(ref_wgts(nxt_wgt)%jpiwgt+3, ref_wgts(nxt_wgt)%jpjwgt+3 ,ipk) )
+         IF( ref_wgts(nxt_wgt)%cyclic ) ALLOCATE( ref_wgts(nxt_wgt)%col(1,ref_wgts(nxt_wgt)%jpjwgt+3,ipk) )
+         !
+         nxt_wgt = nxt_wgt + 1
+         !
+      ELSE 
+         CALL ctl_stop( '    fld_weight : unable to read the file ' )
+      ENDIF
+
+      DEALLOCATE (ddims )
+      !
+   END SUBROUTINE fld_weight
+
+
+   SUBROUTINE apply_seaoverland( clmaskfile, zfieldo, jpi1_lsm, jpi2_lsm, jpj1_lsm,   &
+      &                          jpj2_lsm, itmpi, itmpj, itmpz, rec1_lsm, recn_lsm )
+      !!---------------------------------------------------------------------
+      !!                    ***  ROUTINE apply_seaoverland  ***
+      !!
+      !! ** Purpose :   avoid spurious fluxes in coastal or near-coastal areas
+      !!                due to the wrong usage of "land" values from the coarse
+      !!                atmospheric model when spatial interpolation is required
+      !!      D. Delrosso INGV          
+      !!---------------------------------------------------------------------- 
+      INTEGER,                   INTENT(in   ) :: itmpi,itmpj,itmpz                    ! lengths
+      INTEGER,                   INTENT(in   ) :: jpi1_lsm,jpi2_lsm,jpj1_lsm,jpj2_lsm  ! temporary indices
+      INTEGER, DIMENSION(3),     INTENT(in   ) :: rec1_lsm,recn_lsm                    ! temporary arrays for start and length
+      REAL(wp),DIMENSION (:,:,:),INTENT(inout) :: zfieldo                              ! input/output array for seaoverland application
+      CHARACTER (len=100),       INTENT(in   ) :: clmaskfile                           ! land/sea mask file name
+      !
+      INTEGER :: inum,jni,jnj,jnz,jc   ! local indices
+      REAL(wp),DIMENSION (:,:,:),ALLOCATABLE :: zslmec1             ! local array for land point detection
+      REAL(wp),DIMENSION (:,:),  ALLOCATABLE :: zfieldn   ! array of forcing field with undeff for land points
+      REAL(wp),DIMENSION (:,:),  ALLOCATABLE :: zfield    ! array of forcing field
+      !!---------------------------------------------------------------------
+      !
+      ALLOCATE ( zslmec1(itmpi,itmpj,itmpz), zfieldn(itmpi,itmpj), zfield(itmpi,itmpj) )
+      !
+      ! Retrieve the land sea mask data
+      CALL iom_open( clmaskfile, inum )
+      SELECT CASE( SIZE(zfieldo(jpi1_lsm:jpi2_lsm,jpj1_lsm:jpj2_lsm,:),3) )
+      CASE(1)
+         CALL iom_get( inum, jpdom_unknown, 'LSM', zslmec1(jpi1_lsm:jpi2_lsm,jpj1_lsm:jpj2_lsm,1), 1, rec1_lsm, recn_lsm)
+      CASE DEFAULT
+         CALL iom_get( inum, jpdom_unknown, 'LSM', zslmec1(jpi1_lsm:jpi2_lsm,jpj1_lsm:jpj2_lsm,:), 1, rec1_lsm, recn_lsm)
+      END SELECT
+      CALL iom_close( inum )
+      !
+      DO jnz=1,rec1_lsm(3)             !! Loop over k dimension
+         !
+         DO jni = 1, itmpi                               !! copy the original field into a tmp array
+            DO jnj = 1, itmpj                            !! substituting undeff over land points
+               zfieldn(jni,jnj) = zfieldo(jni,jnj,jnz)
+               IF( zslmec1(jni,jnj,jnz) == 1. )   zfieldn(jni,jnj) = undeff_lsm
+            END DO
+         END DO
+         !
+         CALL seaoverland( zfieldn, itmpi, itmpj, zfield )
+         DO jc = 1, nn_lsm
+            CALL seaoverland( zfield, itmpi, itmpj, zfield )
+         END DO
+         !
+         !   Check for Undeff and substitute original values
+         IF( ANY(zfield==undeff_lsm) ) THEN
+            DO jni = 1, itmpi
+               DO jnj = 1, itmpj
+                  IF( zfield(jni,jnj)==undeff_lsm )   zfield(jni,jnj) = zfieldo(jni,jnj,jnz)
+               END DO
+            END DO
+         ENDIF
+         !
+         zfieldo(:,:,jnz) = zfield(:,:)
+         !
+      END DO                           !! End Loop over k dimension
+      !
+      DEALLOCATE ( zslmec1, zfieldn, zfield )
+      !
+   END SUBROUTINE apply_seaoverland 
+
+
+   SUBROUTINE seaoverland( zfieldn, ileni, ilenj, zfield )
+      !!---------------------------------------------------------------------
+      !!                    ***  ROUTINE seaoverland  ***
+      !!
+      !! ** Purpose :   create shifted matrices for seaoverland application  
+      !!      D. Delrosso INGV
+      !!---------------------------------------------------------------------- 
+      INTEGER                      , INTENT(in   ) :: ileni,ilenj   ! lengths 
+      REAL, DIMENSION (ileni,ilenj), INTENT(in   ) :: zfieldn       ! array of forcing field with undeff for land points
+      REAL, DIMENSION (ileni,ilenj), INTENT(  out) :: zfield        ! array of forcing field
+      !
+      REAL   , DIMENSION (ileni,ilenj)   :: zmat1, zmat2, zmat3, zmat4  ! local arrays 
+      REAL   , DIMENSION (ileni,ilenj)   :: zmat5, zmat6, zmat7, zmat8  !   -     - 
+      REAL   , DIMENSION (ileni,ilenj)   :: zlsm2d                      !   -     - 
+      REAL   , DIMENSION (ileni,ilenj,8) :: zlsm3d                      !   -     -
+      LOGICAL, DIMENSION (ileni,ilenj,8) :: ll_msknan3d                 ! logical mask for undeff detection
+      LOGICAL, DIMENSION (ileni,ilenj)   :: ll_msknan2d                 ! logical mask for undeff detection
+      !!---------------------------------------------------------------------- 
+      zmat8 = eoshift( zfieldn , SHIFT=-1 , BOUNDARY = (/zfieldn(:,1)/)     , DIM=2 )
+      zmat1 = eoshift( zmat8   , SHIFT=-1 , BOUNDARY = (/zmat8(1,:)/)       , DIM=1 )
+      zmat2 = eoshift( zfieldn , SHIFT=-1 , BOUNDARY = (/zfieldn(1,:)/)     , DIM=1 )
+      zmat4 = eoshift( zfieldn , SHIFT= 1 , BOUNDARY = (/zfieldn(:,ilenj)/) , DIM=2 )
+      zmat3 = eoshift( zmat4   , SHIFT=-1 , BOUNDARY = (/zmat4(1,:)/)       , DIM=1 )
+      zmat5 = eoshift( zmat4   , SHIFT= 1 , BOUNDARY = (/zmat4(ileni,:)/)   , DIM=1 )
+      zmat6 = eoshift( zfieldn , SHIFT= 1 , BOUNDARY = (/zfieldn(ileni,:)/) , DIM=1 )
+      zmat7 = eoshift( zmat8   , SHIFT= 1 , BOUNDARY = (/zmat8(ileni,:)/)   , DIM=1 )
+      !
+      zlsm3d  = RESHAPE( (/ zmat1, zmat2, zmat3, zmat4, zmat5, zmat6, zmat7, zmat8 /), (/ ileni, ilenj, 8 /))
+      ll_msknan3d = .NOT.( zlsm3d  == undeff_lsm )
+      ll_msknan2d = .NOT.( zfieldn == undeff_lsm )  ! FALSE where is Undeff (land)
+      zlsm2d = SUM( zlsm3d, 3 , ll_msknan3d ) / MAX( 1 , COUNT( ll_msknan3d , 3 ) )
+      WHERE( COUNT( ll_msknan3d , 3 ) == 0._wp )   zlsm2d = undeff_lsm
+      zfield = MERGE( zfieldn, zlsm2d, ll_msknan2d )
+      !
+   END SUBROUTINE seaoverland
+
+
+   SUBROUTINE fld_interp( num, clvar, kw, kk, dta,  &
+                          &         nrec, lsmfile)      
+      !!---------------------------------------------------------------------
+      !!                    ***  ROUTINE fld_interp  ***
+      !!
+      !! ** Purpose :   apply weights to input gridded data to create data
+      !!                on model grid
+      !!----------------------------------------------------------------------
+      INTEGER                   , INTENT(in   ) ::   num     ! stream number
+      CHARACTER(LEN=*)          , INTENT(in   ) ::   clvar   ! variable name
+      INTEGER                   , INTENT(in   ) ::   kw      ! weights number
+      INTEGER                   , INTENT(in   ) ::   kk      ! vertical dimension of kk
+      REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   dta     ! output field on model grid
+      INTEGER                   , INTENT(in   ) ::   nrec    ! record number to read (ie time slice)
+      CHARACTER(LEN=*)          , INTENT(in   ) ::   lsmfile ! land sea mask file name
+      !
+      INTEGER, DIMENSION(3) ::   rec1, recn           ! temporary arrays for start and length
+      INTEGER, DIMENSION(3) ::   rec1_lsm, recn_lsm   ! temporary arrays for start and length in case of seaoverland
+      INTEGER ::   ii_lsm1,ii_lsm2,ij_lsm1,ij_lsm2    ! temporary indices
+      INTEGER ::   jk, jn, jm, jir, jjr               ! loop counters
+      INTEGER ::   ni, nj                             ! lengths
+      INTEGER ::   jpimin,jpiwid                      ! temporary indices
+      INTEGER ::   jpimin_lsm,jpiwid_lsm              ! temporary indices
+      INTEGER ::   jpjmin,jpjwid                      ! temporary indices
+      INTEGER ::   jpjmin_lsm,jpjwid_lsm              ! temporary indices
+      INTEGER ::   jpi1,jpi2,jpj1,jpj2                ! temporary indices
+      INTEGER ::   jpi1_lsm,jpi2_lsm,jpj1_lsm,jpj2_lsm   ! temporary indices
+      INTEGER ::   itmpi,itmpj,itmpz                     ! lengths
+      REAL(wp),DIMENSION(:,:,:), ALLOCATABLE ::   ztmp_fly_dta                 ! local array of values on input grid     
+      !!----------------------------------------------------------------------
+      !
+      !! for weighted interpolation we have weights at four corners of a box surrounding 
+      !! a model grid point, each weight is multiplied by a grid value (bilinear case)
+      !! or by a grid value and gradients at the corner point (bicubic case) 
+      !! so we need to have a 4 by 4 subgrid surrounding each model point to cover both cases
+
+      !! sub grid from non-model input grid which encloses all grid points in this nemo process
+      jpimin = ref_wgts(kw)%botleft(1)
+      jpjmin = ref_wgts(kw)%botleft(2)
+      jpiwid = ref_wgts(kw)%jpiwgt
+      jpjwid = ref_wgts(kw)%jpjwgt
+
+      !! when reading in, expand this sub-grid by one halo point all the way round for calculating gradients
+      rec1(1) = MAX( jpimin-1, 1 )
+      rec1(2) = MAX( jpjmin-1, 1 )
+      rec1(3) = 1
+      recn(1) = MIN( jpiwid+2, ref_wgts(kw)%ddims(1)-rec1(1)+1 )
+      recn(2) = MIN( jpjwid+2, ref_wgts(kw)%ddims(2)-rec1(2)+1 )
+      recn(3) = kk
+
+      !! where we need to put it in the non-nemo grid fly_dta
+      !! note that jpi1 and jpj1 only differ from 1 when jpimin and jpjmin are 1
+      !! (ie at the extreme west or south of the whole input grid) and similarly for jpi2 and jpj2
+      jpi1 = 2 + rec1(1) - jpimin
+      jpj1 = 2 + rec1(2) - jpjmin
+      jpi2 = jpi1 + recn(1) - 1
+      jpj2 = jpj1 + recn(2) - 1
+
+
+      IF( LEN( TRIM(lsmfile) ) > 0 ) THEN
+      !! indeces for ztmp_fly_dta
+      ! --------------------------
+         rec1_lsm(1)=MAX(rec1(1)-nn_lsm,1)  ! starting index for enlarged external data, x direction
+         rec1_lsm(2)=MAX(rec1(2)-nn_lsm,1)  ! starting index for enlarged external data, y direction
+         rec1_lsm(3) = 1                    ! vertical dimension
+         recn_lsm(1)=MIN(rec1(1)-rec1_lsm(1)+recn(1)+nn_lsm,ref_wgts(kw)%ddims(1)-rec1_lsm(1)) ! n points in x direction
+         recn_lsm(2)=MIN(rec1(2)-rec1_lsm(2)+recn(2)+nn_lsm,ref_wgts(kw)%ddims(2)-rec1_lsm(2)) ! n points in y direction
+         recn_lsm(3) = kk                   ! number of vertical levels in the input file
+
+      !  Avoid out of bound
+         jpimin_lsm = MAX( rec1_lsm(1)+1, 1 )
+         jpjmin_lsm = MAX( rec1_lsm(2)+1, 1 )
+         jpiwid_lsm = MIN( recn_lsm(1)-2,ref_wgts(kw)%ddims(1)-rec1(1)+1)
+         jpjwid_lsm = MIN( recn_lsm(2)-2,ref_wgts(kw)%ddims(2)-rec1(2)+1)
+
+         jpi1_lsm = 2+rec1_lsm(1)-jpimin_lsm
+         jpj1_lsm = 2+rec1_lsm(2)-jpjmin_lsm
+         jpi2_lsm = jpi1_lsm + recn_lsm(1) - 1
+         jpj2_lsm = jpj1_lsm + recn_lsm(2) - 1
+
+
+         itmpi=jpi2_lsm-jpi1_lsm+1
+         itmpj=jpj2_lsm-jpj1_lsm+1
+         itmpz=kk
+         ALLOCATE(ztmp_fly_dta(itmpi,itmpj,itmpz))
+         ztmp_fly_dta(:,:,:) = 0.0
+         SELECT CASE( SIZE(ztmp_fly_dta(jpi1_lsm:jpi2_lsm,jpj1_lsm:jpj2_lsm,:),3) )
+         CASE(1)
+              CALL iom_get( num, jpdom_unknown, clvar, ztmp_fly_dta(jpi1_lsm:jpi2_lsm,jpj1_lsm:jpj2_lsm,1),   &
+                 &                                                                nrec, rec1_lsm, recn_lsm)
+         CASE DEFAULT
+              CALL iom_get( num, jpdom_unknown, clvar, ztmp_fly_dta(jpi1_lsm:jpi2_lsm,jpj1_lsm:jpj2_lsm,:),   &
+                 &                                                                nrec, rec1_lsm, recn_lsm)
+         END SELECT
+         CALL apply_seaoverland(lsmfile,ztmp_fly_dta(jpi1_lsm:jpi2_lsm,jpj1_lsm:jpj2_lsm,:),                  &
+                 &                                      jpi1_lsm,jpi2_lsm,jpj1_lsm,jpj2_lsm,                  &
+                 &                                      itmpi,itmpj,itmpz,rec1_lsm,recn_lsm)
+
+
+         ! Relative indeces for remapping
+         ii_lsm1 = (rec1(1)-rec1_lsm(1))+1
+         ii_lsm2 = (ii_lsm1+recn(1))-1
+         ij_lsm1 = (rec1(2)-rec1_lsm(2))+1
+         ij_lsm2 = (ij_lsm1+recn(2))-1
+
+         ref_wgts(kw)%fly_dta(:,:,:) = 0.0
+         ref_wgts(kw)%fly_dta(jpi1:jpi2,jpj1:jpj2,:) = ztmp_fly_dta(ii_lsm1:ii_lsm2,ij_lsm1:ij_lsm2,:)
+         DEALLOCATE(ztmp_fly_dta)
+
+      ELSE
+         
+         ref_wgts(kw)%fly_dta(:,:,:) = 0.0
+         SELECT CASE( SIZE(ref_wgts(kw)%fly_dta(jpi1:jpi2,jpj1:jpj2,:),3) )
+         CASE(1)
+              CALL iom_get( num, jpdom_unknown, clvar, ref_wgts(kw)%fly_dta(jpi1:jpi2,jpj1:jpj2,1), nrec, rec1, recn)
+         CASE DEFAULT
+              CALL iom_get( num, jpdom_unknown, clvar, ref_wgts(kw)%fly_dta(jpi1:jpi2,jpj1:jpj2,:), nrec, rec1, recn)
+         END SELECT 
+      ENDIF
+      
+
+      !! first four weights common to both bilinear and bicubic
+      !! data_jpi, data_jpj have already been shifted to (1,1) corresponding to botleft
+      !! note that we have to offset by 1 into fly_dta array because of halo
+      dta(:,:,:) = 0.0
+      DO jk = 1,4
+        DO jn = 1, jpj
+          DO jm = 1,jpi
+            ni = ref_wgts(kw)%data_jpi(jm,jn,jk)
+            nj = ref_wgts(kw)%data_jpj(jm,jn,jk)
+            dta(jm,jn,:) = dta(jm,jn,:) + ref_wgts(kw)%data_wgt(jm,jn,jk) * ref_wgts(kw)%fly_dta(ni+1,nj+1,:)
+          END DO
+        END DO
+      END DO
+
+      IF (ref_wgts(kw)%numwgt .EQ. 16) THEN
+
+        !! fix up halo points that we couldnt read from file
+        IF( jpi1 == 2 ) THEN
+           ref_wgts(kw)%fly_dta(jpi1-1,:,:) = ref_wgts(kw)%fly_dta(jpi1,:,:)
+        ENDIF
+        IF( jpi2 + jpimin - 1 == ref_wgts(kw)%ddims(1)+1 ) THEN
+           ref_wgts(kw)%fly_dta(jpi2+1,:,:) = ref_wgts(kw)%fly_dta(jpi2,:,:)
+        ENDIF
+        IF( jpj1 == 2 ) THEN
+           ref_wgts(kw)%fly_dta(:,jpj1-1,:) = ref_wgts(kw)%fly_dta(:,jpj1,:)
+        ENDIF
+        IF( jpj2 + jpjmin - 1 == ref_wgts(kw)%ddims(2)+1 .AND. jpj2 .lt. jpjwid+2 ) THEN
+           ref_wgts(kw)%fly_dta(:,jpj2+1,:) = 2.0*ref_wgts(kw)%fly_dta(:,jpj2,:) - ref_wgts(kw)%fly_dta(:,jpj2-1,:)
+        ENDIF
+
+        !! if data grid is cyclic we can do better on east-west edges
+        !! but have to allow for whether first and last columns are coincident
+        IF( ref_wgts(kw)%cyclic ) THEN
+           rec1(2) = MAX( jpjmin-1, 1 )
+           recn(1) = 1
+           recn(2) = MIN( jpjwid+2, ref_wgts(kw)%ddims(2)-rec1(2)+1 )
+           jpj1 = 2 + rec1(2) - jpjmin
+           jpj2 = jpj1 + recn(2) - 1
+           IF( jpi1 == 2 ) THEN
+              rec1(1) = ref_wgts(kw)%ddims(1) - ref_wgts(kw)%overlap
+              SELECT CASE( SIZE( ref_wgts(kw)%col(:,jpj1:jpj2,:),3) )
+              CASE(1)
+                   CALL iom_get( num, jpdom_unknown, clvar, ref_wgts(kw)%col(:,jpj1:jpj2,1), nrec, rec1, recn)
+              CASE DEFAULT
+                   CALL iom_get( num, jpdom_unknown, clvar, ref_wgts(kw)%col(:,jpj1:jpj2,:), nrec, rec1, recn)
+              END SELECT      
+              ref_wgts(kw)%fly_dta(jpi1-1,jpj1:jpj2,:) = ref_wgts(kw)%col(1,jpj1:jpj2,:)
+           ENDIF
+           IF( jpi2 + jpimin - 1 == ref_wgts(kw)%ddims(1)+1 ) THEN
+              rec1(1) = 1 + ref_wgts(kw)%overlap
+              SELECT CASE( SIZE( ref_wgts(kw)%col(:,jpj1:jpj2,:),3) )
+              CASE(1)
+                   CALL iom_get( num, jpdom_unknown, clvar, ref_wgts(kw)%col(:,jpj1:jpj2,1), nrec, rec1, recn)
+              CASE DEFAULT
+                   CALL iom_get( num, jpdom_unknown, clvar, ref_wgts(kw)%col(:,jpj1:jpj2,:), nrec, rec1, recn)
+              END SELECT
+              ref_wgts(kw)%fly_dta(jpi2+1,jpj1:jpj2,:) = ref_wgts(kw)%col(1,jpj1:jpj2,:)
+           ENDIF
+        ENDIF
+
+        ! gradient in the i direction
+        DO jk = 1,4
+          DO jn = 1, jpj
+            DO jm = 1,jpi
+              ni = ref_wgts(kw)%data_jpi(jm,jn,jk)
+              nj = ref_wgts(kw)%data_jpj(jm,jn,jk)
+              dta(jm,jn,:) = dta(jm,jn,:) + ref_wgts(kw)%data_wgt(jm,jn,jk+4) * 0.5 *         &
+                               (ref_wgts(kw)%fly_dta(ni+2,nj+1,:) - ref_wgts(kw)%fly_dta(ni,nj+1,:))
+            END DO
+          END DO
+        END DO
+
+        ! gradient in the j direction
+        DO jk = 1,4
+          DO jn = 1, jpj
+            DO jm = 1,jpi
+              ni = ref_wgts(kw)%data_jpi(jm,jn,jk)
+              nj = ref_wgts(kw)%data_jpj(jm,jn,jk)
+              dta(jm,jn,:) = dta(jm,jn,:) + ref_wgts(kw)%data_wgt(jm,jn,jk+8) * 0.5 *         &
+                               (ref_wgts(kw)%fly_dta(ni+1,nj+2,:) - ref_wgts(kw)%fly_dta(ni+1,nj,:))
+            END DO
+          END DO
+        END DO
+
+         ! gradient in the ij direction
+         DO jk = 1,4
+            DO jn = 1, jpj
+               DO jm = 1,jpi
+                  ni = ref_wgts(kw)%data_jpi(jm,jn,jk)
+                  nj = ref_wgts(kw)%data_jpj(jm,jn,jk)
+                  dta(jm,jn,:) = dta(jm,jn,:) + ref_wgts(kw)%data_wgt(jm,jn,jk+12) * 0.25 * ( &
+                               (ref_wgts(kw)%fly_dta(ni+2,nj+2,:) - ref_wgts(kw)%fly_dta(ni  ,nj+2,:)) -   &
+                               (ref_wgts(kw)%fly_dta(ni+2,nj  ,:) - ref_wgts(kw)%fly_dta(ni  ,nj  ,:)))
+               END DO
+            END DO
+         END DO
+         !
+      END IF
+      !
+   END SUBROUTINE fld_interp
+
+
+   FUNCTION ksec_week( cdday )
+      !!---------------------------------------------------------------------
+      !!                    ***  FUNCTION kshift_week *** 
+      !!
+      !! ** Purpose :   return the first 3 letters of the first day of the weekly file
+      !!---------------------------------------------------------------------
+      CHARACTER(len=*), INTENT(in)   ::   cdday   ! first 3 letters of the first day of the weekly file
+      !!
+      INTEGER                        ::   ksec_week      ! output variable
+      INTEGER                        ::   ijul, ishift   ! local integer
+      CHARACTER(len=3),DIMENSION(7)  ::   cl_week 
+      !!----------------------------------------------------------------------
+      cl_week = (/"sun","sat","fri","thu","wed","tue","mon"/)
+      DO ijul = 1, 7
+         IF( cl_week(ijul) == TRIM(cdday) ) EXIT
+      END DO
+      IF( ijul .GT. 7 )   CALL ctl_stop( 'ksec_week: wrong day for sdjf%cltype(6:8): '//TRIM(cdday) )
+      !
+      ishift = ijul * NINT(rday)
+      ! 
+      ksec_week = nsec_week + ishift
+      ksec_week = MOD( ksec_week, 7*NINT(rday) )
+      ! 
+   END FUNCTION ksec_week
+
+   !!======================================================================
+END MODULE fldread
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/SBC/geo2ocean.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/SBC/geo2ocean.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/SBC/geo2ocean.F90	(revision 9570)
@@ -0,0 +1,471 @@
+MODULE geo2ocean
+   !!======================================================================
+   !!                     ***  MODULE  geo2ocean  ***
+   !! Ocean mesh    :  ???
+   !!======================================================================
+   !! History :  OPA  !  07-1996  (O. Marti)  Original code
+   !!   NEMO     1.0  !  06-2006  (G. Madec )  Free form, F90 + opt.
+   !!                 !  04-2007  (S. Masson)  angle: Add T, F points and bugfix in cos lateral boundary
+   !!            3.0  !  07-2008  (G. Madec)  geo2oce suppress lon/lat agruments
+   !!            3.7  !  11-2015  (G. Madec)  remove the unused repere and repcmo routines
+   !!----------------------------------------------------------------------
+#if defined key_agrif
+!clem: these lines do not seem necessary anymore
+!!DIR$ OPTIMIZE (-O 1)  ! cray formulation
+# if defined __INTEL_COMPILER
+!acc: still breaks on at least one Ivybridge cluster with ifort 17.0.4 without this directive
+!DIR$ OPTIMIZE:1        ! intel formulation
+# endif
+#endif
+   !!----------------------------------------------------------------------
+   !!   rot_rep       : Rotate the Repere: geographic grid <==> stretched coordinates grid
+   !!   angle         :
+   !!   geo2oce       :
+   !!   oce2geo       :
+   !!----------------------------------------------------------------------
+   USE dom_oce        ! mesh and scale factors
+   USE phycst         ! physical constants
+   !
+   USE in_out_manager ! I/O manager
+   USE lbclnk         ! ocean lateral boundary conditions (or mpp link)
+   USE lib_mpp        ! MPP library
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   rot_rep   ! called in sbccpl, fldread, and cyclone
+   PUBLIC   geo2oce   ! called in sbccpl
+   PUBLIC   oce2geo   ! called in sbccpl
+   PUBLIC   obs_rot   ! called in obs_rot_vel and obs_write
+
+   !                                         ! cos/sin between model grid lines and NP direction
+   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   gsint, gcost   ! at T point
+   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   gsinu, gcosu   ! at U point
+   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   gsinv, gcosv   ! at V point
+   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   gsinf, gcosf   ! at F point
+
+   LOGICAL ,              SAVE, DIMENSION(4)     ::   linit = .FALSE.
+   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   gsinlon, gcoslon, gsinlat, gcoslat
+
+   LOGICAL ::   lmust_init = .TRUE.        !: used to initialize the cos/sin variables (see above)
+
+   !! * Substitutions
+#  include "vectopt_loop_substitute.h90"
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO Consortium (2010)
+   !! $Id$ 
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE rot_rep ( pxin, pyin, cd_type, cdtodo, prot )
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE rot_rep  ***
+      !!
+      !! ** Purpose :   Rotate the Repere: Change vector componantes between
+      !!                geographic grid <--> stretched coordinates grid.
+      !!----------------------------------------------------------------------
+      REAL(wp), DIMENSION(jpi,jpj), INTENT(in   ) ::   pxin, pyin   ! vector componantes
+      CHARACTER(len=1),             INTENT(in   ) ::   cd_type      ! define the nature of pt2d array grid-points
+      CHARACTER(len=5),             INTENT(in   ) ::   cdtodo       ! type of transpormation:
+      !                                                             ! 'en->i' = east-north to i-component
+      !                                                             ! 'en->j' = east-north to j-component
+      !                                                             ! 'ij->e' = (i,j) components to east
+      !                                                             ! 'ij->n' = (i,j) components to north
+      REAL(wp), DIMENSION(jpi,jpj), INTENT(  out) ::   prot      
+      !!----------------------------------------------------------------------
+      !
+      IF( lmust_init ) THEN      ! at 1st call only: set  gsin. & gcos.
+         IF(lwp) WRITE(numout,*)
+         IF(lwp) WRITE(numout,*) ' rot_rep: coordinate transformation : geographic <==> model (i,j)-components'
+         IF(lwp) WRITE(numout,*) ' ~~~~~~~~    '
+         !
+         CALL angle       ! initialization of the transformation
+         lmust_init = .FALSE.
+      ENDIF
+      !
+      SELECT CASE( cdtodo )      ! type of rotation
+      !
+      CASE( 'en->i' )                  ! east-north to i-component
+         SELECT CASE (cd_type)
+         CASE ('T')   ;   prot(:,:) = pxin(:,:) * gcost(:,:) + pyin(:,:) * gsint(:,:)
+         CASE ('U')   ;   prot(:,:) = pxin(:,:) * gcosu(:,:) + pyin(:,:) * gsinu(:,:)
+         CASE ('V')   ;   prot(:,:) = pxin(:,:) * gcosv(:,:) + pyin(:,:) * gsinv(:,:)
+         CASE ('F')   ;   prot(:,:) = pxin(:,:) * gcosf(:,:) + pyin(:,:) * gsinf(:,:)
+         CASE DEFAULT   ;   CALL ctl_stop( 'Only T, U, V and F grid points are coded' )
+         END SELECT
+      CASE ('en->j')                   ! east-north to j-component
+         SELECT CASE (cd_type)
+         CASE ('T')   ;   prot(:,:) = pyin(:,:) * gcost(:,:) - pxin(:,:) * gsint(:,:)
+         CASE ('U')   ;   prot(:,:) = pyin(:,:) * gcosu(:,:) - pxin(:,:) * gsinu(:,:)
+         CASE ('V')   ;   prot(:,:) = pyin(:,:) * gcosv(:,:) - pxin(:,:) * gsinv(:,:)   
+         CASE ('F')   ;   prot(:,:) = pyin(:,:) * gcosf(:,:) - pxin(:,:) * gsinf(:,:)   
+         CASE DEFAULT   ;   CALL ctl_stop( 'Only T, U, V and F grid points are coded' )
+         END SELECT
+      CASE ('ij->e')                   ! (i,j)-components to east
+         SELECT CASE (cd_type)
+         CASE ('T')   ;   prot(:,:) = pxin(:,:) * gcost(:,:) - pyin(:,:) * gsint(:,:)
+         CASE ('U')   ;   prot(:,:) = pxin(:,:) * gcosu(:,:) - pyin(:,:) * gsinu(:,:)
+         CASE ('V')   ;   prot(:,:) = pxin(:,:) * gcosv(:,:) - pyin(:,:) * gsinv(:,:)
+         CASE ('F')   ;   prot(:,:) = pxin(:,:) * gcosf(:,:) - pyin(:,:) * gsinf(:,:)
+         CASE DEFAULT   ;   CALL ctl_stop( 'Only T, U, V and F grid points are coded' )
+         END SELECT
+      CASE ('ij->n')                   ! (i,j)-components to north 
+         SELECT CASE (cd_type)
+         CASE ('T')   ;   prot(:,:) = pyin(:,:) * gcost(:,:) + pxin(:,:) * gsint(:,:)
+         CASE ('U')   ;   prot(:,:) = pyin(:,:) * gcosu(:,:) + pxin(:,:) * gsinu(:,:)
+         CASE ('V')   ;   prot(:,:) = pyin(:,:) * gcosv(:,:) + pxin(:,:) * gsinv(:,:)
+         CASE ('F')   ;   prot(:,:) = pyin(:,:) * gcosf(:,:) + pxin(:,:) * gsinf(:,:)
+         CASE DEFAULT   ;   CALL ctl_stop( 'Only T, U, V and F grid points are coded' )
+         END SELECT
+      CASE DEFAULT   ;   CALL ctl_stop( 'rot_rep: Syntax Error in the definition of cdtodo' )
+      !
+      END SELECT
+      !
+   END SUBROUTINE rot_rep
+
+
+   SUBROUTINE angle
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE angle  ***
+      !! 
+      !! ** Purpose :   Compute angles between model grid lines and the North direction
+      !!
+      !! ** Method  :   sinus and cosinus of the angle between the north-south axe 
+      !!              and the j-direction at t, u, v and f-points
+      !!                dot and cross products are used to obtain cos and sin, resp.
+      !!
+      !! ** Action  : - gsint, gcost, gsinu, gcosu, gsinv, gcosv, gsinf, gcosf
+      !!----------------------------------------------------------------------
+      INTEGER  ::   ji, jj   ! dummy loop indices
+      INTEGER  ::   ierr     ! local integer
+      REAL(wp) ::   zlam, zphi            ! local scalars
+      REAL(wp) ::   zlan, zphh            !   -      -
+      REAL(wp) ::   zxnpt, zynpt, znnpt   ! x,y components and norm of the vector: T point to North Pole
+      REAL(wp) ::   zxnpu, zynpu, znnpu   ! x,y components and norm of the vector: U point to North Pole
+      REAL(wp) ::   zxnpv, zynpv, znnpv   ! x,y components and norm of the vector: V point to North Pole
+      REAL(wp) ::   zxnpf, zynpf, znnpf   ! x,y components and norm of the vector: F point to North Pole
+      REAL(wp) ::   zxvvt, zyvvt, znvvt   ! x,y components and norm of the vector: between V points below and above a T point
+      REAL(wp) ::   zxffu, zyffu, znffu   ! x,y components and norm of the vector: between F points below and above a U point
+      REAL(wp) ::   zxffv, zyffv, znffv   ! x,y components and norm of the vector: between F points left  and right a V point
+      REAL(wp) ::   zxuuf, zyuuf, znuuf   ! x,y components and norm of the vector: between U points below and above a F point
+      !!----------------------------------------------------------------------
+      !
+      ALLOCATE( gsint(jpi,jpj), gcost(jpi,jpj),   & 
+         &      gsinu(jpi,jpj), gcosu(jpi,jpj),   & 
+         &      gsinv(jpi,jpj), gcosv(jpi,jpj),   &  
+         &      gsinf(jpi,jpj), gcosf(jpi,jpj), STAT=ierr )
+      IF(lk_mpp)   CALL mpp_sum( ierr )
+      IF( ierr /= 0 )   CALL ctl_stop( 'angle: unable to allocate arrays' )
+      !
+      ! ============================= !
+      ! Compute the cosinus and sinus !
+      ! ============================= !
+      ! (computation done on the north stereographic polar plane)
+      !
+      DO jj = 2, jpjm1
+         DO ji = fs_2, jpi   ! vector opt.
+            !                  
+            zlam = glamt(ji,jj)     ! north pole direction & modulous (at t-point)
+            zphi = gphit(ji,jj)
+            zxnpt = 0. - 2. * COS( rad*zlam ) * TAN( rpi/4. - rad*zphi/2. )
+            zynpt = 0. - 2. * SIN( rad*zlam ) * TAN( rpi/4. - rad*zphi/2. )
+            znnpt = zxnpt*zxnpt + zynpt*zynpt
+            !
+            zlam = glamu(ji,jj)     ! north pole direction & modulous (at u-point)
+            zphi = gphiu(ji,jj)
+            zxnpu = 0. - 2. * COS( rad*zlam ) * TAN( rpi/4. - rad*zphi/2. )
+            zynpu = 0. - 2. * SIN( rad*zlam ) * TAN( rpi/4. - rad*zphi/2. )
+            znnpu = zxnpu*zxnpu + zynpu*zynpu
+            !
+            zlam = glamv(ji,jj)     ! north pole direction & modulous (at v-point)
+            zphi = gphiv(ji,jj)
+            zxnpv = 0. - 2. * COS( rad*zlam ) * TAN( rpi/4. - rad*zphi/2. )
+            zynpv = 0. - 2. * SIN( rad*zlam ) * TAN( rpi/4. - rad*zphi/2. )
+            znnpv = zxnpv*zxnpv + zynpv*zynpv
+            !
+            zlam = glamf(ji,jj)     ! north pole direction & modulous (at f-point)
+            zphi = gphif(ji,jj)
+            zxnpf = 0. - 2. * COS( rad*zlam ) * TAN( rpi/4. - rad*zphi/2. )
+            zynpf = 0. - 2. * SIN( rad*zlam ) * TAN( rpi/4. - rad*zphi/2. )
+            znnpf = zxnpf*zxnpf + zynpf*zynpf
+            !
+            zlam = glamv(ji,jj  )   ! j-direction: v-point segment direction (around t-point)
+            zphi = gphiv(ji,jj  )
+            zlan = glamv(ji,jj-1)
+            zphh = gphiv(ji,jj-1)
+            zxvvt =  2. * COS( rad*zlam ) * TAN( rpi/4. - rad*zphi/2. )   &
+               &  -  2. * COS( rad*zlan ) * TAN( rpi/4. - rad*zphh/2. )
+            zyvvt =  2. * SIN( rad*zlam ) * TAN( rpi/4. - rad*zphi/2. )   &
+               &  -  2. * SIN( rad*zlan ) * TAN( rpi/4. - rad*zphh/2. )
+            znvvt = SQRT( znnpt * ( zxvvt*zxvvt + zyvvt*zyvvt )  )
+            znvvt = MAX( znvvt, 1.e-14 )
+            !
+            zlam = glamf(ji,jj  )   ! j-direction: f-point segment direction (around u-point)
+            zphi = gphif(ji,jj  )
+            zlan = glamf(ji,jj-1)
+            zphh = gphif(ji,jj-1)
+            zxffu =  2. * COS( rad*zlam ) * TAN( rpi/4. - rad*zphi/2. )   &
+               &  -  2. * COS( rad*zlan ) * TAN( rpi/4. - rad*zphh/2. )
+            zyffu =  2. * SIN( rad*zlam ) * TAN( rpi/4. - rad*zphi/2. )   &
+               &  -  2. * SIN( rad*zlan ) * TAN( rpi/4. - rad*zphh/2. )
+            znffu = SQRT( znnpu * ( zxffu*zxffu + zyffu*zyffu )  )
+            znffu = MAX( znffu, 1.e-14 )
+            !
+            zlam = glamf(ji  ,jj)   ! i-direction: f-point segment direction (around v-point)
+            zphi = gphif(ji  ,jj)
+            zlan = glamf(ji-1,jj)
+            zphh = gphif(ji-1,jj)
+            zxffv =  2. * COS( rad*zlam ) * TAN( rpi/4. - rad*zphi/2. )   &
+               &  -  2. * COS( rad*zlan ) * TAN( rpi/4. - rad*zphh/2. )
+            zyffv =  2. * SIN( rad*zlam ) * TAN( rpi/4. - rad*zphi/2. )   &
+               &  -  2. * SIN( rad*zlan ) * TAN( rpi/4. - rad*zphh/2. )
+            znffv = SQRT( znnpv * ( zxffv*zxffv + zyffv*zyffv )  )
+            znffv = MAX( znffv, 1.e-14 )
+            !
+            zlam = glamu(ji,jj+1)   ! j-direction: u-point segment direction (around f-point)
+            zphi = gphiu(ji,jj+1)
+            zlan = glamu(ji,jj  )
+            zphh = gphiu(ji,jj  )
+            zxuuf =  2. * COS( rad*zlam ) * TAN( rpi/4. - rad*zphi/2. )   &
+               &  -  2. * COS( rad*zlan ) * TAN( rpi/4. - rad*zphh/2. )
+            zyuuf =  2. * SIN( rad*zlam ) * TAN( rpi/4. - rad*zphi/2. )   &
+               &  -  2. * SIN( rad*zlan ) * TAN( rpi/4. - rad*zphh/2. )
+            znuuf = SQRT( znnpf * ( zxuuf*zxuuf + zyuuf*zyuuf )  )
+            znuuf = MAX( znuuf, 1.e-14 )
+            !
+            !                       ! cosinus and sinus using dot and cross products
+            gsint(ji,jj) = ( zxnpt*zyvvt - zynpt*zxvvt ) / znvvt
+            gcost(ji,jj) = ( zxnpt*zxvvt + zynpt*zyvvt ) / znvvt
+            !
+            gsinu(ji,jj) = ( zxnpu*zyffu - zynpu*zxffu ) / znffu
+            gcosu(ji,jj) = ( zxnpu*zxffu + zynpu*zyffu ) / znffu
+            !
+            gsinf(ji,jj) = ( zxnpf*zyuuf - zynpf*zxuuf ) / znuuf
+            gcosf(ji,jj) = ( zxnpf*zxuuf + zynpf*zyuuf ) / znuuf
+            !
+            gsinv(ji,jj) = ( zxnpv*zxffv + zynpv*zyffv ) / znffv
+            gcosv(ji,jj) =-( zxnpv*zyffv - zynpv*zxffv ) / znffv     ! (caution, rotation of 90 degres)
+            !
+         END DO
+      END DO
+
+      ! =============== !
+      ! Geographic mesh !
+      ! =============== !
+
+      DO jj = 2, jpjm1
+         DO ji = fs_2, jpi   ! vector opt.
+            IF( MOD( ABS( glamv(ji,jj) - glamv(ji,jj-1) ), 360. ) < 1.e-8 ) THEN
+               gsint(ji,jj) = 0.
+               gcost(ji,jj) = 1.
+            ENDIF
+            IF( MOD( ABS( glamf(ji,jj) - glamf(ji,jj-1) ), 360. ) < 1.e-8 ) THEN
+               gsinu(ji,jj) = 0.
+               gcosu(ji,jj) = 1.
+            ENDIF
+            IF(      ABS( gphif(ji,jj) - gphif(ji-1,jj) )         < 1.e-8 ) THEN
+               gsinv(ji,jj) = 0.
+               gcosv(ji,jj) = 1.
+            ENDIF
+            IF( MOD( ABS( glamu(ji,jj) - glamu(ji,jj+1) ), 360. ) < 1.e-8 ) THEN
+               gsinf(ji,jj) = 0.
+               gcosf(ji,jj) = 1.
+            ENDIF
+         END DO
+      END DO
+
+      ! =========================== !
+      ! Lateral boundary conditions !
+      ! =========================== !
+      !           ! lateral boundary cond.: T-, U-, V-, F-pts, sgn
+      CALL lbc_lnk_multi( gcost, 'T', -1., gsint, 'T', -1., gcosu, 'U', -1., gsinu, 'U', -1., & 
+                      &   gcosv, 'V', -1., gsinv, 'V', -1., gcosf, 'F', -1., gsinf, 'F', -1.  )
+      !
+   END SUBROUTINE angle
+
+
+   SUBROUTINE geo2oce ( pxx, pyy, pzz, cgrid, pte, ptn )
+      !!----------------------------------------------------------------------
+      !!                    ***  ROUTINE geo2oce  ***
+      !!      
+      !! ** Purpose :
+      !!
+      !! ** Method  :   Change a vector from geocentric to east/north 
+      !!
+      !!----------------------------------------------------------------------
+      REAL(wp), DIMENSION(jpi,jpj), INTENT(in   ) ::  pxx, pyy, pzz
+      CHARACTER(len=1)            , INTENT(in   ) ::  cgrid
+      REAL(wp), DIMENSION(jpi,jpj), INTENT(  out) ::  pte, ptn
+      !
+      REAL(wp), PARAMETER :: rpi = 3.141592653e0
+      REAL(wp), PARAMETER :: rad = rpi / 180.e0
+      INTEGER ::   ig     !
+      INTEGER ::   ierr   ! local integer
+      !!----------------------------------------------------------------------
+      !
+      IF( .NOT. ALLOCATED( gsinlon ) ) THEN
+         ALLOCATE( gsinlon(jpi,jpj,4) , gcoslon(jpi,jpj,4) ,   &
+            &      gsinlat(jpi,jpj,4) , gcoslat(jpi,jpj,4) , STAT=ierr )
+         IF( lk_mpp    )   CALL mpp_sum( ierr )
+         IF( ierr /= 0 )   CALL ctl_stop('geo2oce: unable to allocate arrays' )
+      ENDIF
+      !
+      SELECT CASE( cgrid)
+      CASE ( 'T' )   
+         ig = 1
+         IF( .NOT. linit(ig) ) THEN 
+            gsinlon(:,:,ig) = SIN( rad * glamt(:,:) )
+            gcoslon(:,:,ig) = COS( rad * glamt(:,:) )
+            gsinlat(:,:,ig) = SIN( rad * gphit(:,:) )
+            gcoslat(:,:,ig) = COS( rad * gphit(:,:) )
+            linit(ig) = .TRUE.
+         ENDIF
+      CASE ( 'U' )   
+         ig = 2
+         IF( .NOT. linit(ig) ) THEN 
+            gsinlon(:,:,ig) = SIN( rad * glamu(:,:) )
+            gcoslon(:,:,ig) = COS( rad * glamu(:,:) )
+            gsinlat(:,:,ig) = SIN( rad * gphiu(:,:) )
+            gcoslat(:,:,ig) = COS( rad * gphiu(:,:) )
+            linit(ig) = .TRUE.
+         ENDIF
+      CASE ( 'V' )   
+         ig = 3
+         IF( .NOT. linit(ig) ) THEN 
+            gsinlon(:,:,ig) = SIN( rad * glamv(:,:) )
+            gcoslon(:,:,ig) = COS( rad * glamv(:,:) )
+            gsinlat(:,:,ig) = SIN( rad * gphiv(:,:) )
+            gcoslat(:,:,ig) = COS( rad * gphiv(:,:) )
+            linit(ig) = .TRUE.
+         ENDIF
+      CASE ( 'F' )   
+         ig = 4
+         IF( .NOT. linit(ig) ) THEN 
+            gsinlon(:,:,ig) = SIN( rad * glamf(:,:) )
+            gcoslon(:,:,ig) = COS( rad * glamf(:,:) )
+            gsinlat(:,:,ig) = SIN( rad * gphif(:,:) )
+            gcoslat(:,:,ig) = COS( rad * gphif(:,:) )
+            linit(ig) = .TRUE.
+         ENDIF
+      CASE default   
+         WRITE(ctmp1,*) 'geo2oce : bad grid argument : ', cgrid
+         CALL ctl_stop( ctmp1 )
+      END SELECT
+      !
+      pte = - gsinlon(:,:,ig) * pxx + gcoslon(:,:,ig) * pyy
+      ptn = - gcoslon(:,:,ig) * gsinlat(:,:,ig) * pxx    &
+         &  - gsinlon(:,:,ig) * gsinlat(:,:,ig) * pyy    &
+         &  + gcoslat(:,:,ig) * pzz
+      !
+   END SUBROUTINE geo2oce
+
+
+   SUBROUTINE oce2geo ( pte, ptn, cgrid, pxx , pyy , pzz )
+      !!----------------------------------------------------------------------
+      !!                    ***  ROUTINE oce2geo  ***
+      !!      
+      !! ** Purpose :
+      !!
+      !! ** Method  :   Change vector from east/north to geocentric
+      !!
+      !! History :     ! (A. Caubel)  oce2geo - Original code
+      !!----------------------------------------------------------------------
+      REAL(wp), DIMENSION(jpi,jpj), INTENT( IN    ) ::  pte, ptn
+      CHARACTER(len=1)            , INTENT( IN    ) ::  cgrid
+      REAL(wp), DIMENSION(jpi,jpj), INTENT(   OUT ) ::  pxx , pyy , pzz
+      !!
+      REAL(wp), PARAMETER :: rpi = 3.141592653E0
+      REAL(wp), PARAMETER :: rad = rpi / 180.e0
+      INTEGER ::   ig     !
+      INTEGER ::   ierr   ! local integer
+      !!----------------------------------------------------------------------
+
+      IF( .NOT. ALLOCATED( gsinlon ) ) THEN
+         ALLOCATE( gsinlon(jpi,jpj,4) , gcoslon(jpi,jpj,4) ,   &
+            &      gsinlat(jpi,jpj,4) , gcoslat(jpi,jpj,4) , STAT=ierr )
+         IF( lk_mpp    )   CALL mpp_sum( ierr )
+         IF( ierr /= 0 )   CALL ctl_stop('oce2geo: unable to allocate arrays' )
+      ENDIF
+
+      SELECT CASE( cgrid)
+         CASE ( 'T' )   
+            ig = 1
+            IF( .NOT. linit(ig) ) THEN 
+               gsinlon(:,:,ig) = SIN( rad * glamt(:,:) )
+               gcoslon(:,:,ig) = COS( rad * glamt(:,:) )
+               gsinlat(:,:,ig) = SIN( rad * gphit(:,:) )
+               gcoslat(:,:,ig) = COS( rad * gphit(:,:) )
+               linit(ig) = .TRUE.
+            ENDIF
+         CASE ( 'U' )   
+            ig = 2
+            IF( .NOT. linit(ig) ) THEN 
+               gsinlon(:,:,ig) = SIN( rad * glamu(:,:) )
+               gcoslon(:,:,ig) = COS( rad * glamu(:,:) )
+               gsinlat(:,:,ig) = SIN( rad * gphiu(:,:) )
+               gcoslat(:,:,ig) = COS( rad * gphiu(:,:) )
+               linit(ig) = .TRUE.
+            ENDIF
+         CASE ( 'V' )   
+            ig = 3
+            IF( .NOT. linit(ig) ) THEN 
+               gsinlon(:,:,ig) = SIN( rad * glamv(:,:) )
+               gcoslon(:,:,ig) = COS( rad * glamv(:,:) )
+               gsinlat(:,:,ig) = SIN( rad * gphiv(:,:) )
+               gcoslat(:,:,ig) = COS( rad * gphiv(:,:) )
+               linit(ig) = .TRUE.
+            ENDIF
+         CASE ( 'F' )   
+            ig = 4
+            IF( .NOT. linit(ig) ) THEN 
+               gsinlon(:,:,ig) = SIN( rad * glamf(:,:) )
+               gcoslon(:,:,ig) = COS( rad * glamf(:,:) )
+               gsinlat(:,:,ig) = SIN( rad * gphif(:,:) )
+               gcoslat(:,:,ig) = COS( rad * gphif(:,:) )
+               linit(ig) = .TRUE.
+            ENDIF
+         CASE default   
+            WRITE(ctmp1,*) 'geo2oce : bad grid argument : ', cgrid
+            CALL ctl_stop( ctmp1 )
+      END SELECT
+      !
+      pxx = - gsinlon(:,:,ig) * pte - gcoslon(:,:,ig) * gsinlat(:,:,ig) * ptn 
+      pyy =   gcoslon(:,:,ig) * pte - gsinlon(:,:,ig) * gsinlat(:,:,ig) * ptn
+      pzz =   gcoslat(:,:,ig) * ptn
+      !
+   END SUBROUTINE oce2geo
+
+
+   SUBROUTINE obs_rot( psinu, pcosu, psinv, pcosv )
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE obs_rot  ***
+      !!
+      !! ** Purpose :   Copy gsinu, gcosu, gsinv and gsinv
+      !!                to input data for rotations of
+      !!                current at observation points
+      !!
+      !! History :  9.2  !  09-02  (K. Mogensen)
+      !!----------------------------------------------------------------------
+      REAL(wp), DIMENSION(jpi,jpj), INTENT( OUT )::   psinu, pcosu, psinv, pcosv   ! copy of data
+      !!----------------------------------------------------------------------
+      !
+      ! Initialization of gsin* and gcos* at first call
+      ! -----------------------------------------------
+      IF( lmust_init ) THEN
+         IF(lwp) WRITE(numout,*)
+         IF(lwp) WRITE(numout,*) ' obs_rot : geographic <--> stretched'
+         IF(lwp) WRITE(numout,*) ' ~~~~~~~   coordinate transformation'
+         CALL angle       ! initialization of the transformation
+         lmust_init = .FALSE.
+      ENDIF
+      !
+      psinu(:,:) = gsinu(:,:)
+      pcosu(:,:) = gcosu(:,:)
+      psinv(:,:) = gsinv(:,:)
+      pcosv(:,:) = gcosv(:,:)
+      !
+   END SUBROUTINE obs_rot
+
+  !!======================================================================
+END MODULE geo2ocean
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/SBC/ocealb.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/SBC/ocealb.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/SBC/ocealb.F90	(revision 9570)
@@ -0,0 +1,48 @@
+MODULE ocealb
+   !!======================================================================
+   !!                       ***  MODULE  ocealb  ***
+   !! Ocean forcing:  bulk thermohaline forcing of the ocean
+   !!=====================================================================
+   !! History :
+   !!   NEMO     4.0  ! 2017-07  (C. Rousset) Split ocean and ice albedos
+   !!----------------------------------------------------------------------
+   !!   oce_alb    : albedo for ocean (clear and overcast skies)
+   !!----------------------------------------------------------------------
+   USE phycst         ! physical constants
+   USE in_out_manager ! I/O manager
+   USE lib_mpp        ! MPP library
+   USE lib_fortran    ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined)  
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   oce_alb   ! routine called by sbccpl
+  
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 4.0 , NEMO Consortium (2010)
+   !! $Id: ocealb.F90 8268 2017-07-03 15:01:04Z clem $
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE oce_alb( palb_os , palb_cs )
+      !!----------------------------------------------------------------------
+      !!               ***  ROUTINE oce_alb  ***
+      !! 
+      !! ** Purpose :   Computation of the albedo of the ocean
+      !!----------------------------------------------------------------------
+      REAL(wp), DIMENSION(:,:), INTENT(out) ::   palb_os   !  albedo of ocean under overcast sky
+      REAL(wp), DIMENSION(:,:), INTENT(out) ::   palb_cs   !  albedo of ocean under clear sky
+      !!
+      REAL(wp) ::   zcoef 
+      REAL(wp) ::   rmue = 0.40    !  cosine of local solar altitude
+      !!----------------------------------------------------------------------
+      !
+      zcoef = 0.05 / ( 1.1 * rmue**1.4 + 0.15 )   ! Parameterization of Briegled and Ramanathan, 1982
+      palb_cs(:,:) = zcoef 
+      palb_os(:,:) = 0.06                         ! Parameterization of Kondratyev, 1969 and Payne, 1972
+      !
+   END SUBROUTINE oce_alb
+
+   !!======================================================================
+END MODULE ocealb
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/SBC/sbc_ice.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/SBC/sbc_ice.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/SBC/sbc_ice.F90	(revision 9570)
@@ -0,0 +1,207 @@
+MODULE sbc_ice
+   !!======================================================================
+   !!                 ***  MODULE  sbc_ice  ***
+   !! Surface module - LIM-3: parameters & variables defined in memory
+   !!======================================================================
+   !! History :  3.0  ! 2006-08  (G. Madec)  Surface module
+   !!            3.2  ! 2009-06  (S. Masson) merge with ice_oce
+   !!            3.3.1! 2011-01  (A. R. Porter, STFC Daresbury) dynamical allocation
+   !!            3.4  ! 2011-11  (C. Harris) CICE added as an option
+   !!----------------------------------------------------------------------
+#if defined key_si3 || defined key_cice
+   !!----------------------------------------------------------------------
+   !!   'key_si3' or 'key_cice' :              LIM-3 or CICE sea-ice model
+   !!----------------------------------------------------------------------
+   USE par_oce          ! ocean parameters
+   USE sbc_oce          ! surface boundary condition: ocean
+# if defined key_si3
+   USE ice              ! LIM-3 parameters
+# endif
+# if defined key_cice
+   USE ice_domain_size, only: ncat 
+#endif
+   USE lib_mpp          ! MPP library
+   USE in_out_manager   ! I/O manager
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   sbc_ice_alloc   ! called in sbcmod.F90 or sbcice_cice.F90
+
+# if defined  key_si3
+   LOGICAL         , PUBLIC, PARAMETER ::   lk_lim3    = .TRUE.   !: LIM-3 ice model
+   LOGICAL         , PUBLIC, PARAMETER ::   lk_cice    = .FALSE.  !: no CICE 
+   CHARACTER(len=1), PUBLIC, PARAMETER ::   cp_ice_msh = 'C'      !: 'C'-grid ice-velocity
+# endif
+# if defined  key_cice
+   LOGICAL         , PUBLIC, PARAMETER ::   lk_lim3    = .FALSE.  !: no LIM-3
+   LOGICAL         , PUBLIC, PARAMETER ::   lk_cice    = .TRUE.   !: CICE ice model
+   CHARACTER(len=1), PUBLIC            ::   cp_ice_msh = 'F'      !: 'F'-grid ice-velocity
+# endif
+
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   qns_ice        !: non solar heat flux over ice                  [W/m2]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   qsr_ice        !: solar heat flux over ice                      [W/m2]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   qla_ice        !: latent flux over ice                          [W/m2]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   dqla_ice       !: latent sensibility over ice                 [W/m2/K]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   dqns_ice       !: non solar heat flux over ice (LW+SEN+LA)    [W/m2/K]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   tn_ice         !: ice surface temperature                          [K]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   alb_ice        !: ice albedo                                       [-]
+
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   qml_ice        !: heat available for snow / ice surface melting     [W/m2] 
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   qcn_ice        !: heat conduction flux in the layer below surface   [W/m2] 
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   qsr_ice_tr     !: solar flux transmitted below the ice surface      [W/m2]
+
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   utau_ice       !: atmos-ice u-stress. VP: I-pt ; EVP: U,V-pts   [N/m2]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   vtau_ice       !: atmos-ice v-stress. VP: I-pt ; EVP: U,V-pts   [N/m2]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   emp_ice        !: sublimation - precip over sea ice          [kg/m2/s]
+
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   topmelt            !: category topmelt
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   botmelt            !: category botmelt
+
+#if defined  key_si3
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   evap_ice       !: sublimation                              [kg/m2/s]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   devap_ice      !: sublimation sensitivity                [kg/m2/s/K]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   qns_oce        !: non solar heat flux over ocean              [W/m2]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   qsr_oce        !: non solar heat flux over ocean              [W/m2]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   qemp_oce       !: heat flux of precip and evap over ocean     [W/m2]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   qemp_ice       !: heat flux of precip and evap over ice       [W/m2]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   qevap_ice      !: heat flux of evap over ice                  [W/m2]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   qprec_ice      !: enthalpy of precip over ice                 [J/m3]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   emp_oce        !: evap - precip over ocean                 [kg/m2/s]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   wndm_ice       !: wind speed module at T-point                 [m/s]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   sstfrz         !: wind speed module at T-point                 [m/s]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   tsfc_ice       !: sea ice surface skin temperature (on categories)
+#endif
+
+#if defined key_cice
+   !
+   ! for consistency with LIM, these are declared with three dimensions
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   qlw_ice            !: incoming long-wave
+   !
+   ! other forcing arrays are two dimensional
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   ss_iou             !: x ice-ocean surface stress at NEMO U point
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   ss_iov             !: y ice-ocean surface stress at NEMO V point
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   qatm_ice           !: specific humidity
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   wndi_ice           !: i wind at T point
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   wndj_ice           !: j wind at T point
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   nfrzmlt            !: NEMO frzmlt
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   fr_iu              !: ice fraction at NEMO U point
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   fr_iv              !: ice fraction at NEMO V point
+   
+   ! variables used in the coupled interface
+   INTEGER , PUBLIC, PARAMETER ::   jpl = ncat
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   u_ice, v_ice          ! jpi, jpj
+   
+   ! already defined in ice.F90 for LIM3
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::  a_i
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::  h_i, h_s
+
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   tatm_ice       !: air temperature [K]
+#endif
+
+   REAL(wp), PUBLIC, SAVE ::   cldf_ice = 0.81    !: cloud fraction over sea ice, summer CLIO value   [-]
+
+   !! arrays relating to embedding ice in the ocean
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   snwice_mass        !: mass of snow and ice at current  ice time step   [Kg/m2]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   snwice_mass_b      !: mass of snow and ice at previous ice time step   [Kg/m2]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   snwice_fmass       !: time evolution of mass of snow+ice               [Kg/m2/s]
+
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 4.0 , NEMO Consortium (2011)
+   !! $Id$ 
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   INTEGER FUNCTION sbc_ice_alloc()
+      !!----------------------------------------------------------------------
+      !!                     ***  FUNCTION sbc_ice_alloc  ***
+      !!----------------------------------------------------------------------
+      INTEGER :: ierr(4)
+      !!----------------------------------------------------------------------
+      ierr(:) = 0
+
+      ALLOCATE( snwice_mass(jpi,jpj) , snwice_mass_b(jpi,jpj), snwice_fmass(jpi,jpj) , STAT=ierr(1) )
+
+#if defined key_si3
+      ALLOCATE( qns_ice (jpi,jpj,jpl) , qsr_ice  (jpi,jpj,jpl) ,     &
+         &      qla_ice (jpi,jpj,jpl) , dqla_ice (jpi,jpj,jpl) ,     &
+         &      dqns_ice(jpi,jpj,jpl) , tn_ice   (jpi,jpj,jpl) , alb_ice   (jpi,jpj,jpl) ,   &
+         &      qml_ice (jpi,jpj,jpl) , qcn_ice  (jpi,jpj,jpl) , qsr_ice_tr(jpi,jpj,jpl) ,   &
+         &      utau_ice(jpi,jpj)     , vtau_ice (jpi,jpj)     , wndm_ice  (jpi,jpj)     ,   &
+         &      evap_ice(jpi,jpj,jpl) , devap_ice(jpi,jpj,jpl) , qprec_ice (jpi,jpj)     ,   &
+         &      qemp_ice(jpi,jpj)     , qevap_ice(jpi,jpj,jpl) , qemp_oce  (jpi,jpj)     ,   &
+         &      qns_oce (jpi,jpj)     , qsr_oce  (jpi,jpj)     , emp_oce   (jpi,jpj)     ,   &
+         &      emp_ice (jpi,jpj)     , tsfc_ice (jpi,jpj,jpl) , sstfrz    (jpi,jpj)     , STAT= ierr(2) )
+#endif
+
+#if defined key_cice
+      ALLOCATE( qla_ice(jpi,jpj,1)    , qlw_ice(jpi,jpj,1)    , qsr_ice(jpi,jpj,1)    , &
+                wndi_ice(jpi,jpj)     , tatm_ice(jpi,jpj)     , qatm_ice(jpi,jpj)     , &
+                wndj_ice(jpi,jpj)     , nfrzmlt(jpi,jpj)      , ss_iou(jpi,jpj)       , &
+                ss_iov(jpi,jpj)       , fr_iu(jpi,jpj)        , fr_iv(jpi,jpj)        , &
+                a_i(jpi,jpj,ncat)     , topmelt(jpi,jpj,ncat) , botmelt(jpi,jpj,ncat) , &
+                STAT= ierr(2) )
+      IF( ln_cpl )   ALLOCATE( u_ice(jpi,jpj)        , tn_ice (jpi,jpj,1)    , &
+         &                     v_ice(jpi,jpj)        , alb_ice(jpi,jpj,1)    , &
+         &                     emp_ice(jpi,jpj)      , qns_ice(jpi,jpj,1)    , dqns_ice(jpi,jpj,1)   , &
+         &                     STAT= ierr(3) )      
+      IF( ln_cpl )   ALLOCATE( h_i(jpi,jpj,jpl) , h_s(jpi,jpj,jpl) , STAT=ierr(4) )
+#endif
+
+      sbc_ice_alloc = MAXVAL( ierr )
+      IF( lk_mpp            )   CALL mpp_sum ( sbc_ice_alloc )
+      IF( sbc_ice_alloc > 0 )   CALL ctl_warn('sbc_ice_alloc: allocation of arrays failed')
+   END FUNCTION sbc_ice_alloc
+
+#else
+   !!----------------------------------------------------------------------
+   !!   Default option                      NO LIM3 or CICE sea-ice model
+   !!----------------------------------------------------------------------
+   USE lib_mpp          ! MPP library
+   USE in_out_manager   ! I/O manager
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   sbc_ice_alloc   !
+
+   LOGICAL         , PUBLIC, PARAMETER ::   lk_lim3    = .FALSE.  !: no LIM-3 ice model
+   LOGICAL         , PUBLIC, PARAMETER ::   lk_cice    = .FALSE.  !: no CICE  ice model
+   CHARACTER(len=1), PUBLIC, PARAMETER ::   cp_ice_msh = '-'      !: no grid ice-velocity
+   REAL(wp)        , PUBLIC, PARAMETER ::   cldf_ice = 0.81       !: cloud fraction over sea ice, summer CLIO value   [-]
+   INTEGER         , PUBLIC, PARAMETER ::   jpl = 1 
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   u_ice, v_ice                        ! jpi, jpj
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   tn_ice, alb_ice, qns_ice, dqns_ice  ! (jpi,jpj,jpl)
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   a_i
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   emp_ice
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   qsr_ice
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   h_i, h_s
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   topmelt, botmelt
+   !
+   !! arrays related to embedding ice in the ocean. 
+   !! These arrays need to be declared even if no ice model is required. 
+   !! In the no ice model or traditional levitating ice cases they contain only zeros
+   !! ---------------------
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   snwice_mass        !: mass of snow and ice at current  ice time step   [Kg/m2]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   snwice_mass_b      !: mass of snow and ice at previous ice time step   [Kg/m2]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   snwice_fmass       !: time evolution of mass of snow+ice               [Kg/m2/s]
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   INTEGER FUNCTION sbc_ice_alloc()
+      !!----------------------------------------------------------------------
+      !!                     ***  FUNCTION sbc_ice_alloc  ***
+      !!----------------------------------------------------------------------
+      INTEGER :: ierr(1)
+      !!----------------------------------------------------------------------
+      ierr(:) = 0
+      ALLOCATE( snwice_mass(jpi,jpj) , snwice_mass_b(jpi,jpj), snwice_fmass(jpi,jpj) , STAT=ierr(1) )
+      sbc_ice_alloc = MAXVAL( ierr )
+      IF( lk_mpp            )   CALL mpp_sum ( sbc_ice_alloc )
+      IF( sbc_ice_alloc > 0 )   CALL ctl_warn('sbc_ice_alloc: allocation of arrays failed')
+   END FUNCTION sbc_ice_alloc
+#endif
+
+   !!======================================================================
+END MODULE sbc_ice
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/SBC/sbc_oce.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/SBC/sbc_oce.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/SBC/sbc_oce.F90	(revision 9570)
@@ -0,0 +1,223 @@
+MODULE sbc_oce
+   !!======================================================================
+   !!                       ***  MODULE  sbc_oce  ***
+   !! Surface module :   variables defined in core memory 
+   !!======================================================================
+   !! History :  3.0  ! 2006-06  (G. Madec)  Original code
+   !!             -   ! 2008-08  (G. Madec)  namsbc moved from sbcmod
+   !!            3.3  ! 2010-04  (M. Leclair, G. Madec)  Forcing averaged over 2 time steps
+   !!             -   ! 2010-11  (G. Madec) ice-ocean stress always computed at each ocean time-step
+   !!            3.3  ! 2010-10  (J. Chanut, C. Bricaud)  add the surface pressure forcing
+   !!            4.0  ! 2012-05  (C. Rousset) add attenuation coef for use in ice model 
+   !!            4.0  ! 2016-06  (L. Brodeau) new unified bulk routine (based on AeroBulk)
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   sbc_oce_alloc : allocation of sbc arrays
+   !!   sbc_tau2wnd   : wind speed estimated from wind stress
+   !!----------------------------------------------------------------------
+   USE par_oce        ! ocean parameters
+   USE in_out_manager ! I/O manager
+   USE lib_mpp        ! MPP library
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   sbc_oce_alloc   ! routine called in sbcmod.F90
+   PUBLIC   sbc_tau2wnd     ! routine called in several sbc modules
+   
+   !!----------------------------------------------------------------------
+   !!           Namelist for the Ocean Surface Boundary Condition
+   !!----------------------------------------------------------------------
+   !                                   !!* namsbc namelist *
+   LOGICAL , PUBLIC ::   ln_usr         !: user defined formulation
+   LOGICAL , PUBLIC ::   ln_flx         !: flux      formulation
+   LOGICAL , PUBLIC ::   ln_blk         !: bulk formulation
+#if defined key_oasis3
+   LOGICAL , PUBLIC ::   lk_oasis = .TRUE.  !: OASIS used
+#else
+   LOGICAL , PUBLIC ::   lk_oasis = .FALSE. !: OASIS unused
+#endif
+   LOGICAL , PUBLIC ::   ln_cpl         !: ocean-atmosphere coupled formulation
+   LOGICAL , PUBLIC ::   ln_mixcpl      !: ocean-atmosphere forced-coupled mixed formulation
+   LOGICAL , PUBLIC ::   ln_dm2dc       !: Daily mean to Diurnal Cycle short wave (qsr)
+   LOGICAL , PUBLIC ::   ln_rnf         !: runoffs / runoff mouths
+   LOGICAL , PUBLIC ::   ln_isf         !: ice shelf melting
+   LOGICAL , PUBLIC ::   ln_ssr         !: Sea Surface restoring on SST and/or SSS      
+   LOGICAL , PUBLIC ::   ln_apr_dyn     !: Atmospheric pressure forcing used on dynamics (ocean & ice)
+   INTEGER , PUBLIC ::   nn_ice         !: flag for ice in the surface boundary condition (=0/1/2/3)
+   LOGICAL , PUBLIC ::   ln_ice_embd    !: flag for levitating/embedding sea-ice in the ocean
+   !                                             !: =F levitating ice (no presure effect) with mass and salt exchanges
+   !                                             !: =T embedded sea-ice (pressure effect + mass and salt exchanges)
+   INTEGER , PUBLIC ::   nn_components  !: flag for sbc module (including sea-ice) coupling mode (see component definition below) 
+   INTEGER , PUBLIC ::   nn_fwb         !: FreshWater Budget: 
+   !                                             !:  = 0 unchecked 
+   !                                             !:  = 1 global mean of e-p-r set to zero at each nn_fsbc time step
+   !                                             !:  = 2 annual global mean of e-p-r set to zero
+   LOGICAL , PUBLIC ::   ln_wave        !: true if some coupling with wave model
+   LOGICAL , PUBLIC ::   ln_cdgw        !: true if neutral drag coefficient from wave model
+   LOGICAL , PUBLIC ::   ln_sdw         !: true if 3d stokes drift from wave model
+   LOGICAL , PUBLIC ::   ln_tauwoc       !: true if normalized stress from wave is used
+   LOGICAL , PUBLIC ::   ln_tauw        !: true if ocean stress components from wave is used
+   LOGICAL , PUBLIC ::   ln_stcor       !: true if Stokes-Coriolis term is used
+   !
+   INTEGER , PUBLIC ::   nn_sdrift      ! type of parameterization to calculate vertical Stokes drift
+   !
+   LOGICAL , PUBLIC ::   ln_icebergs    !: Icebergs
+   !
+   INTEGER , PUBLIC ::   nn_lsm         !: Number of iteration if seaoverland is applied
+   !
+   !                                   !!* namsbc_cpl namelist *
+   INTEGER , PUBLIC ::   nn_cats_cpl    !: Number of sea ice categories over which the coupling is carried out
+
+   !!----------------------------------------------------------------------
+   !!           switch definition (improve readability)
+   !!----------------------------------------------------------------------
+   INTEGER , PUBLIC, PARAMETER ::   jp_usr     = 1        !: user defined                  formulation
+   INTEGER , PUBLIC, PARAMETER ::   jp_flx     = 2        !: flux                          formulation
+   INTEGER , PUBLIC, PARAMETER ::   jp_blk     = 3        !: bulk                          formulation
+   INTEGER , PUBLIC, PARAMETER ::   jp_purecpl = 4        !: Pure ocean-atmosphere Coupled formulation
+   INTEGER , PUBLIC, PARAMETER ::   jp_none    = 5        !: for OPA when doing coupling via SAS module
+   
+   !!----------------------------------------------------------------------
+   !!           Stokes drift parametrization definition 
+   !!----------------------------------------------------------------------
+   INTEGER , PUBLIC, PARAMETER ::   jp_breivik_2014 = 0     !: Breivik  2014: v_z=v_0*[exp(2*k*z)/(1-8*k*z)]
+   INTEGER , PUBLIC, PARAMETER ::   jp_li_2017      = 1     !: Li et al 2017: Stokes drift based on Phillips spectrum (Breivik 2016) 
+                                                            !  with depth averaged profile
+   INTEGER , PUBLIC, PARAMETER ::   jp_peakfr       = 2     !: Li et al 2017: using the peak wave number read from wave model instead 
+                                                            !  of the inverse depth scale
+   LOGICAL , PUBLIC            ::   ll_st_bv2014  = .FALSE. !  logical indicator, .true. if Breivik 2014 parameterisation is active.
+   LOGICAL , PUBLIC            ::   ll_st_li2017  = .FALSE. !  logical indicator, .true. if Li 2017 parameterisation is active.
+   LOGICAL , PUBLIC            ::   ll_st_bv_li   = .FALSE. !  logical indicator, .true. if either Breivik or Li parameterisation is active.
+   LOGICAL , PUBLIC            ::   ll_st_peakfr  = .FALSE. !  logical indicator, .true. if using Li 2017 with peak wave number
+
+   !!----------------------------------------------------------------------
+   !!           component definition
+   !!----------------------------------------------------------------------
+   INTEGER , PUBLIC, PARAMETER ::   jp_iam_nemo = 0      !: Initial single executable configuration 
+                                                         !  (no internal OASIS coupling)
+   INTEGER , PUBLIC, PARAMETER ::   jp_iam_opa  = 1      !: Multi executable configuration - OPA component
+                                                         !  (internal OASIS coupling)
+   INTEGER , PUBLIC, PARAMETER ::   jp_iam_sas  = 2      !: Multi executable configuration - SAS component
+                                                         !  (internal OASIS coupling)
+   !!----------------------------------------------------------------------
+   !!              Ocean Surface Boundary Condition fields
+   !!----------------------------------------------------------------------
+   INTEGER , PUBLIC ::  ncpl_qsr_freq            !: qsr coupling frequency per days from atmosphere
+   !
+   LOGICAL , PUBLIC ::   lhftau = .FALSE.        !: HF tau used in TKE: mean(stress module) - module(mean stress)
+   !!                                   !!   now    ! before   !!
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   utau   , utau_b   !: sea surface i-stress (ocean referential)     [N/m2]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   vtau   , vtau_b   !: sea surface j-stress (ocean referential)     [N/m2]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   taum              !: module of sea surface stress (at T-point)    [N/m2] 
+   !! wndm is used onmpute surface gases exchanges in ice-free ocean or leads
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wndm              !: wind speed module at T-point (=|U10m-Uoce|)  [m/s]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   qsr               !: sea heat flux:     solar                     [W/m2]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   qns    , qns_b    !: sea heat flux: non solar                     [W/m2]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   qsr_tot           !: total     solar heat flux (over sea and ice) [W/m2]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   qns_tot           !: total non solar heat flux (over sea and ice) [W/m2]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   emp    , emp_b    !: freshwater budget: volume flux               [Kg/m2/s]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   sfx    , sfx_b    !: salt flux                                    [PSU/m2/s]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   emp_tot           !: total E-P over ocean and ice                 [Kg/m2/s]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   fmmflx            !: freshwater budget: freezing/melting          [Kg/m2/s]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   rnf    , rnf_b    !: river runoff        [Kg/m2/s]  
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   fwfisf , fwfisf_b !: ice shelf melting   [Kg/m2/s]  
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   fwficb , fwficb_b !: iceberg melting [Kg/m2/s]  
+
+   !!
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::  sbc_tsc, sbc_tsc_b  !: sbc content trend                      [K.m/s] jpi,jpj,jpts
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::  qsr_hc , qsr_hc_b   !: heat content trend due to qsr flux     [K.m/s] jpi,jpj,jpk
+   !!
+   !!
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   tprecip           !: total precipitation                          [Kg/m2/s]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   sprecip           !: solid precipitation                          [Kg/m2/s]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   fr_i              !: ice fraction = 1 - lead fraction      (between 0 to 1)
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   atm_co2           !: atmospheric pCO2                             [ppm]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: xcplmask          !: coupling mask for ln_mixcpl (warning: allocated in sbccpl)
+
+   !!----------------------------------------------------------------------
+   !!                     Sea Surface Mean fields
+   !!----------------------------------------------------------------------
+   INTEGER , PUBLIC                     ::   nn_fsbc   !: frequency of sbc computation (as well as sea-ice model)
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   ssu_m     !: mean (nn_fsbc time-step) surface sea i-current (U-point) [m/s]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   ssv_m     !: mean (nn_fsbc time-step) surface sea j-current (V-point) [m/s]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   sst_m     !: mean (nn_fsbc time-step) surface sea temperature     [Celsius]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   sss_m     !: mean (nn_fsbc time-step) surface sea salinity            [psu]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   ssh_m     !: mean (nn_fsbc time-step) sea surface height                [m]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   e3t_m     !: mean (nn_fsbc time-step) sea surface layer thickness       [m]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   frq_m     !: mean (nn_fsbc time-step) fraction of solar net radiation absorbed in the 1st T level [-]
+
+   !! * Substitutions
+#  include "vectopt_loop_substitute.h90"
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 4.0 , NEMO Consortium (2011)
+   !! $Id$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   INTEGER FUNCTION sbc_oce_alloc()
+      !!---------------------------------------------------------------------
+      !!                  ***  FUNCTION sbc_oce_alloc  ***
+      !!---------------------------------------------------------------------
+      INTEGER :: ierr(5)
+      !!---------------------------------------------------------------------
+      ierr(:) = 0
+      !
+      ALLOCATE( utau(jpi,jpj) , utau_b(jpi,jpj) , taum(jpi,jpj) ,     &
+         &      vtau(jpi,jpj) , vtau_b(jpi,jpj) , wndm(jpi,jpj) , STAT=ierr(1) ) 
+         !
+      ALLOCATE( qns_tot(jpi,jpj) , qns  (jpi,jpj) , qns_b(jpi,jpj),        &
+         &      qsr_tot(jpi,jpj) , qsr  (jpi,jpj) ,                        &
+         &      emp    (jpi,jpj) , emp_b(jpi,jpj) ,                        &
+         &      sfx    (jpi,jpj) , sfx_b(jpi,jpj) , emp_tot(jpi,jpj), fmmflx(jpi,jpj), STAT=ierr(2) )
+         !
+      ALLOCATE( fwfisf  (jpi,jpj), rnf  (jpi,jpj) , sbc_tsc  (jpi,jpj,jpts) , qsr_hc  (jpi,jpj,jpk) ,  &
+         &      fwfisf_b(jpi,jpj), rnf_b(jpi,jpj) , sbc_tsc_b(jpi,jpj,jpts) , qsr_hc_b(jpi,jpj,jpk) ,  &
+         &      fwficb  (jpi,jpj), fwficb_b(jpi,jpj), STAT=ierr(3) )
+         !
+      ALLOCATE( tprecip(jpi,jpj) , sprecip(jpi,jpj) , fr_i(jpi,jpj) ,     &
+         &      atm_co2(jpi,jpj) ,                                        &
+         &      ssu_m  (jpi,jpj) , sst_m(jpi,jpj) , frq_m(jpi,jpj) ,      &
+         &      ssv_m  (jpi,jpj) , sss_m(jpi,jpj) , ssh_m(jpi,jpj) , STAT=ierr(4) )
+         !
+      ALLOCATE( e3t_m(jpi,jpj) , STAT=ierr(5) )
+         !
+      sbc_oce_alloc = MAXVAL( ierr )
+      IF( lk_mpp            )   CALL mpp_sum ( sbc_oce_alloc )
+      IF( sbc_oce_alloc > 0 )   CALL ctl_warn('sbc_oce_alloc: allocation of arrays failed')
+      !
+   END FUNCTION sbc_oce_alloc
+
+
+   SUBROUTINE sbc_tau2wnd
+      !!---------------------------------------------------------------------
+      !!                    ***  ROUTINE sbc_tau2wnd  ***
+      !!                   
+      !! ** Purpose : Estimation of wind speed as a function of wind stress   
+      !!
+      !! ** Method  : |tau|=rhoa*Cd*|U|^2
+      !!---------------------------------------------------------------------
+      USE dom_oce         ! ocean space and time domain
+      USE lbclnk          ! ocean lateral boundary conditions (or mpp link)
+      REAL(wp) ::   zrhoa  = 1.22         ! Air density kg/m3
+      REAL(wp) ::   zcdrag = 1.5e-3       ! drag coefficient
+      REAL(wp) ::   ztx, zty, ztau, zcoef ! temporary variables
+      INTEGER  ::   ji, jj                ! dummy indices
+      !!---------------------------------------------------------------------
+      zcoef = 0.5 / ( zrhoa * zcdrag ) 
+      DO jj = 2, jpjm1
+         DO ji = fs_2, fs_jpim1   ! vect. opt.
+            ztx = utau(ji-1,jj  ) + utau(ji,jj) 
+            zty = vtau(ji  ,jj-1) + vtau(ji,jj) 
+            ztau = SQRT( ztx * ztx + zty * zty )
+            wndm(ji,jj) = SQRT ( ztau * zcoef ) * tmask(ji,jj,1)
+         END DO
+      END DO
+      CALL lbc_lnk( wndm(:,:) , 'T', 1. )
+      !
+   END SUBROUTINE sbc_tau2wnd
+
+   !!======================================================================
+END MODULE sbc_oce
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/SBC/sbcapr.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/SBC/sbcapr.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/SBC/sbcapr.F90	(revision 9570)
@@ -0,0 +1,179 @@
+MODULE sbcapr
+   !!======================================================================
+   !!                       ***  MODULE  sbcapr  ***
+   !! Surface module :   atmospheric pressure forcing
+   !!======================================================================
+   !! History :  3.3  !   2010-09  (J. Chanut, C. Bricaud, G. Madec)  Original code
+   !!----------------------------------------------------------------------
+   
+   !!----------------------------------------------------------------------
+   !!   sbc_apr        : read atmospheric pressure in netcdf files 
+   !!----------------------------------------------------------------------
+   USE dom_oce         ! ocean space and time domain
+   USE sbc_oce         ! surface boundary condition
+   USE phycst          ! physical constants
+   !
+   USE fldread         ! read input fields
+   USE in_out_manager  ! I/O manager
+   USE lib_fortran     ! distribued memory computing library
+   USE iom             ! IOM library
+   USE lib_mpp         ! MPP library
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   sbc_apr       ! routine called in sbcmod
+   PUBLIC   sbc_apr_init  ! routine called in sbcmod
+   
+   !                                !!* namsbc_apr namelist (Atmospheric PRessure) *
+   LOGICAL, PUBLIC ::   ln_apr_obc   !: inverse barometer added to OBC ssh data 
+   LOGICAL, PUBLIC ::   ln_ref_apr   !: ref. pressure: global mean Patm (F) or a constant (F)
+   REAL(wp)        ::   rn_pref      !  reference atmospheric pressure   [N/m2]
+
+   REAL(wp), ALLOCATABLE, SAVE, PUBLIC, DIMENSION(:,:) ::   ssh_ib    ! Inverse barometer now    sea surface height   [m]
+   REAL(wp), ALLOCATABLE, SAVE, PUBLIC, DIMENSION(:,:) ::   ssh_ibb   ! Inverse barometer before sea surface height   [m]
+   REAL(wp), ALLOCATABLE, SAVE, PUBLIC, DIMENSION(:,:) ::   apr       ! atmospheric pressure at kt                 [N/m2]
+   
+   REAL(wp) ::   tarea                ! whole domain mean masked ocean surface
+   REAL(wp) ::   r1_grau              ! = 1.e0 / (grav * rau0)
+   
+   TYPE(FLD), ALLOCATABLE, DIMENSION(:) ::   sf_apr   ! structure of input fields (file informations, fields read)
+
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 4.0 , NEMO Consortium (2011) 
+   !! $Id$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE sbc_apr_init
+      !!---------------------------------------------------------------------
+      !!                     ***  ROUTINE sbc_apr  ***
+      !!
+      !! ** Purpose :   read atmospheric pressure fields in netcdf files.
+      !!
+      !! ** Method  : - Read namelist namsbc_apr
+      !!              - Read Patm fields in netcdf files 
+      !!              - Compute reference atmospheric pressure
+      !!              - Compute inverse barometer ssh
+      !! ** action  :   apr      : atmospheric pressure at kt
+      !!                ssh_ib   : inverse barometer ssh at kt
+      !!---------------------------------------------------------------------
+      INTEGER            ::   ierror  ! local integer 
+      INTEGER            ::   ios     ! Local integer output status for namelist read
+      !!
+      CHARACTER(len=100) ::  cn_dir   ! Root directory for location of ssr files
+      TYPE(FLD_N)        ::  sn_apr   ! informations about the fields to be read
+      LOGICAL            ::  lrxios   ! read restart using XIOS?
+      !!
+      NAMELIST/namsbc_apr/ cn_dir, sn_apr, ln_ref_apr, rn_pref, ln_apr_obc
+      !!----------------------------------------------------------------------
+      REWIND( numnam_ref )              ! Namelist namsbc_apr in reference namelist : File for atmospheric pressure forcing
+      READ  ( numnam_ref, namsbc_apr, IOSTAT = ios, ERR = 901)
+901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namsbc_apr in reference namelist', lwp )
+
+      REWIND( numnam_cfg )              ! Namelist namsbc_apr in configuration namelist : File for atmospheric pressure forcing
+      READ  ( numnam_cfg, namsbc_apr, IOSTAT = ios, ERR = 902 )
+902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namsbc_apr in configuration namelist', lwp )
+      IF(lwm) WRITE ( numond, namsbc_apr )
+      !
+      ALLOCATE( sf_apr(1), STAT=ierror )           !* allocate and fill sf_sst (forcing structure) with sn_sst
+      IF( ierror > 0 )   CALL ctl_stop( 'STOP', 'sbc_apr: unable to allocate sf_apr structure' )
+      !
+      CALL fld_fill( sf_apr, (/ sn_apr /), cn_dir, 'sbc_apr', 'Atmospheric pressure ', 'namsbc_apr' )
+                                ALLOCATE( sf_apr(1)%fnow(jpi,jpj,1)   )
+      IF( sn_apr%ln_tint )   ALLOCATE( sf_apr(1)%fdta(jpi,jpj,1,2) )
+                             ALLOCATE( ssh_ib(jpi,jpj) , ssh_ibb(jpi,jpj) )
+                             ALLOCATE( apr (jpi,jpj) )
+      !
+      IF( lwp )THEN                                 !* control print
+         WRITE(numout,*)
+         WRITE(numout,*) '   Namelist namsbc_apr : Atmospheric PRessure as extrenal forcing'
+         WRITE(numout,*) '      ref. pressure: global mean Patm (T) or a constant (F)  ln_ref_apr = ', ln_ref_apr
+      ENDIF
+      !
+      IF( ln_ref_apr ) THEN                        !* Compute whole inner domain mean masked ocean surface
+         tarea = glob_sum( e1e2t(:,:) )
+         IF(lwp) WRITE(numout,*) '         Variable ref. Patm computed over a ocean surface of ', tarea*1e-6, 'km2'
+      ELSE
+         IF(lwp) WRITE(numout,*) '         Reference Patm used : ', rn_pref, ' N/m2'
+      ENDIF
+      !
+      r1_grau = 1.e0 / (grav * rau0)               !* constant for optimization
+      !
+      !                                            !* control check
+      IF ( ln_apr_obc  ) THEN
+         IF(lwp) WRITE(numout,*) '         Inverse barometer added to OBC ssh data'
+      ENDIF
+!jc: stop below should rather be a warning 
+      IF( ln_apr_obc .AND. .NOT.ln_apr_dyn   )   &
+            CALL ctl_warn( 'sbc_apr: use inverse barometer ssh at open boundary ONLY requires ln_apr_dyn=T' )
+      !
+      IF( lwxios ) THEN
+         CALL iom_set_rstw_var_active('ssh_ibb')
+      ENDIF
+   END SUBROUTINE sbc_apr_init
+
+   SUBROUTINE sbc_apr( kt )
+      !!---------------------------------------------------------------------
+      !!                     ***  ROUTINE sbc_apr  ***
+      !!
+      !! ** Purpose :   read atmospheric pressure fields in netcdf files.
+      !!
+      !! ** Method  : - Read namelist namsbc_apr
+      !!              - Read Patm fields in netcdf files 
+      !!              - Compute reference atmospheric pressure
+      !!              - Compute inverse barometer ssh
+      !! ** action  :   apr      : atmospheric pressure at kt
+      !!                ssh_ib   : inverse barometer ssh at kt
+      !!---------------------------------------------------------------------
+      INTEGER, INTENT(in)::   kt   ! ocean time step
+      !
+      !!----------------------------------------------------------------------
+
+      !                                         ! ========================== !
+      IF( MOD( kt-1, nn_fsbc ) == 0 ) THEN      !    At each sbc time-step   !
+         !                                      ! ===========+++============ !
+         !
+         IF( kt /= nit000 )   ssh_ibb(:,:) = ssh_ib(:,:)    !* Swap of ssh_ib fields
+         !
+         CALL fld_read( kt, nn_fsbc, sf_apr )               !* input Patm provided at kt + nn_fsbc/2
+         !
+         !                                                  !* update the reference atmospheric pressure (if necessary)
+         IF( ln_ref_apr )   rn_pref = glob_sum( sf_apr(1)%fnow(:,:,1) * e1e2t(:,:) ) / tarea
+         !
+         !                                                  !* Patm related forcing at kt
+         ssh_ib(:,:) = - ( sf_apr(1)%fnow(:,:,1) - rn_pref ) * r1_grau    ! equivalent ssh (inverse barometer)
+         apr   (:,:) =     sf_apr(1)%fnow(:,:,1)                        ! atmospheric pressure
+         !
+         CALL iom_put( "ssh_ib", ssh_ib )                   !* output the inverse barometer ssh
+      ENDIF
+
+      !                                         ! ---------------------------------------- !
+      IF( kt == nit000 ) THEN                   !   set the forcing field at nit000 - 1    !
+         !                                      ! ---------------------------------------- !
+         !                                            !* Restart: read in restart file
+         IF( ln_rstart .AND. iom_varid( numror, 'ssh_ibb', ldstop = .FALSE. ) > 0 ) THEN 
+            IF(lwp) WRITE(numout,*) 'sbc_apr:   ssh_ibb read in the restart file'
+            CALL iom_get( numror, jpdom_autoglo, 'ssh_ibb', ssh_ibb, ldxios = lrxios )   ! before inv. barometer ssh
+            !
+         ELSE                                         !* no restart: set from nit000 values
+            IF(lwp) WRITE(numout,*) 'sbc_apr:   ssh_ibb set to nit000 values'
+            ssh_ibb(:,:) = ssh_ib(:,:)
+         ENDIF
+      ENDIF
+      !                                         ! ---------------------------------------- !
+      IF( lrst_oce ) THEN                       !      Write in the ocean restart file     !
+         !                                      ! ---------------------------------------- !
+         IF(lwp) WRITE(numout,*)
+         IF(lwp) WRITE(numout,*) 'sbc_apr : ssh_ib written in ocean restart file at it= ', kt,' date= ', ndastp
+         IF(lwp) WRITE(numout,*) '~~~~'
+         IF( lwxios ) CALL iom_swap(      cwxios_context          )
+         CALL iom_rstput( kt, nitrst, numrow, 'ssh_ibb' , ssh_ib, ldxios = lwxios )
+         IF( lwxios ) CALL iom_swap(      cxios_context          )
+      ENDIF
+      !
+   END SUBROUTINE sbc_apr
+      
+   !!======================================================================
+END MODULE sbcapr
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/SBC/sbcblk.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/SBC/sbcblk.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/SBC/sbcblk.F90	(revision 9570)
@@ -0,0 +1,1227 @@
+MODULE sbcblk
+   !!======================================================================
+   !!                       ***  MODULE  sbcblk  ***
+   !! Ocean forcing:  momentum, heat and freshwater flux formulation
+   !!                         Aerodynamic Bulk Formulas
+   !!                        SUCCESSOR OF "sbcblk_core"
+   !!=====================================================================
+   !! History :  1.0  !  2004-08  (U. Schweckendiek)  Original CORE code
+   !!            2.0  !  2005-04  (L. Brodeau, A.M. Treguier)  improved CORE bulk and its user interface
+   !!            3.0  !  2006-06  (G. Madec)  sbc rewritting
+   !!             -   !  2006-12  (L. Brodeau)  Original code for turb_core
+   !!            3.2  !  2009-04  (B. Lemaire)  Introduce iom_put
+   !!            3.3  !  2010-10  (S. Masson)  add diurnal cycle
+   !!            3.4  !  2011-11  (C. Harris)  Fill arrays required by CICE
+   !!            3.7  !  2014-06  (L. Brodeau)  simplification and optimization of CORE bulk
+   !!            4.0  !  2016-06  (L. Brodeau)  sbcblk_core becomes sbcblk and is not restricted to the CORE algorithm anymore
+   !!                 !                        ==> based on AeroBulk (http://aerobulk.sourceforge.net/)
+   !!            4.0  !  2016-10  (G. Madec)  introduce a sbc_blk_init routine
+   !!            4.0  !  2016-10  (M. Vancoppenolle)  Introduce Jules emulator (M. Vancoppenolle) 
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   sbc_blk_init  : initialisation of the chosen bulk formulation as ocean surface boundary condition
+   !!   sbc_blk       : bulk formulation as ocean surface boundary condition
+   !!   blk_oce       : computes momentum, heat and freshwater fluxes over ocean
+   !!   rho_air       : density of (moist) air (depends on T_air, q_air and SLP
+   !!   cp_air        : specific heat of (moist) air (depends spec. hum. q_air)
+   !!   q_sat         : saturation humidity as a function of SLP and temperature
+   !!   L_vap         : latent heat of vaporization of water as a function of temperature
+   !!             sea-ice case only : 
+   !!   blk_ice_tau   : provide the air-ice stress
+   !!   blk_ice_flx   : provide the heat and mass fluxes at air-ice interface
+   !!   blk_ice_qcn   : provide ice surface temperature and snow/ice conduction flux (emulating JULES coupler)
+   !!   Cdn10_Lupkes2012 : Lupkes et al. (2012) air-ice drag
+   !!   Cdn10_Lupkes2015 : Lupkes et al. (2015) air-ice drag 
+   !!----------------------------------------------------------------------
+   USE oce            ! ocean dynamics and tracers
+   USE dom_oce        ! ocean space and time domain
+   USE phycst         ! physical constants
+   USE fldread        ! read input fields
+   USE sbc_oce        ! Surface boundary condition: ocean fields
+   USE cyclone        ! Cyclone 10m wind form trac of cyclone centres
+   USE sbcdcy         ! surface boundary condition: diurnal cycle
+   USE sbcwave , ONLY :   cdn_wave ! wave module
+   USE sbc_ice        ! Surface boundary condition: ice fields
+   USE lib_fortran    ! to use key_nosignedzero
+#if defined key_si3
+   USE ice     , ONLY :   u_ice, v_ice, jpl, a_i_b, at_i_b, tm_su, rn_cnd_s
+   USE icethd_dh      ! for CALL ice_thd_snwblow
+#endif
+   USE sbcblk_algo_ncar     ! => turb_ncar     : NCAR - CORE (Large & Yeager, 2009) 
+   USE sbcblk_algo_coare    ! => turb_coare    : COAREv3.0 (Fairall et al. 2003) 
+   USE sbcblk_algo_coare3p5 ! => turb_coare3p5 : COAREv3.5 (Edson et al. 2013)
+   USE sbcblk_algo_ecmwf    ! => turb_ecmwf    : ECMWF (IFS cycle 31) 
+   !
+   USE iom            ! I/O manager library
+   USE in_out_manager ! I/O manager
+   USE lib_mpp        ! distribued memory computing library
+   USE lbclnk         ! ocean lateral boundary conditions (or mpp link)
+   USE prtctl         ! Print control
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   sbc_blk_init  ! called in sbcmod
+   PUBLIC   sbc_blk       ! called in sbcmod
+#if defined key_si3
+   PUBLIC   blk_ice_tau   ! routine called in iceforcing
+   PUBLIC   blk_ice_flx   ! routine called in iceforcing
+   PUBLIC   blk_ice_qcn   ! routine called in iceforcing
+#endif 
+
+!!Lolo: should ultimately be moved in the module with all physical constants ?
+!!gm  : In principle, yes.
+   REAL(wp), PARAMETER ::   Cp_dry = 1005.0       !: Specic heat of dry air, constant pressure      [J/K/kg]
+   REAL(wp), PARAMETER ::   Cp_vap = 1860.0       !: Specic heat of water vapor, constant pressure  [J/K/kg]
+   REAL(wp), PARAMETER ::   R_dry = 287.05_wp     !: Specific gas constant for dry air              [J/K/kg]
+   REAL(wp), PARAMETER ::   R_vap = 461.495_wp    !: Specific gas constant for water vapor          [J/K/kg]
+   REAL(wp), PARAMETER ::   reps0 = R_dry/R_vap   !: ratio of gas constant for dry air and water vapor => ~ 0.622
+   REAL(wp), PARAMETER ::   rctv0 = R_vap/R_dry   !: for virtual temperature (== (1-eps)/eps) => ~ 0.608
+
+   INTEGER , PARAMETER ::   jpfld   =10           ! maximum number of files to read
+   INTEGER , PARAMETER ::   jp_wndi = 1           ! index of 10m wind velocity (i-component) (m/s)    at T-point
+   INTEGER , PARAMETER ::   jp_wndj = 2           ! index of 10m wind velocity (j-component) (m/s)    at T-point
+   INTEGER , PARAMETER ::   jp_tair = 3           ! index of 10m air temperature             (Kelvin)
+   INTEGER , PARAMETER ::   jp_humi = 4           ! index of specific humidity               ( % )
+   INTEGER , PARAMETER ::   jp_qsr  = 5           ! index of solar heat                      (W/m2)
+   INTEGER , PARAMETER ::   jp_qlw  = 6           ! index of Long wave                       (W/m2)
+   INTEGER , PARAMETER ::   jp_prec = 7           ! index of total precipitation (rain+snow) (Kg/m2/s)
+   INTEGER , PARAMETER ::   jp_snow = 8           ! index of snow (solid prcipitation)       (kg/m2/s)
+   INTEGER , PARAMETER ::   jp_slp  = 9           ! index of sea level pressure              (Pa)
+   INTEGER , PARAMETER ::   jp_tdif =10           ! index of tau diff associated to HF tau   (N/m2)   at T-point
+
+   TYPE(FLD), ALLOCATABLE, DIMENSION(:) ::   sf   ! structure of input fields (file informations, fields read)
+
+   !                                             !!! Bulk parameters
+   REAL(wp), PARAMETER ::   cpa    = 1000.5         ! specific heat of air (only used for ice fluxes now...)
+   REAL(wp), PARAMETER ::   Ls     =    2.839e6     ! latent heat of sublimation
+   REAL(wp), PARAMETER ::   Stef   =    5.67e-8     ! Stefan Boltzmann constant
+   REAL(wp), PARAMETER ::   Cd_ice =    1.4e-3      ! transfer coefficient over ice
+   REAL(wp), PARAMETER ::   albo   =    0.066       ! ocean albedo assumed to be constant
+   !
+   !                           !!* Namelist namsbc_blk : bulk parameters
+   LOGICAL  ::   ln_NCAR        ! "NCAR"      algorithm   (Large and Yeager 2008)
+   LOGICAL  ::   ln_COARE_3p0   ! "COARE 3.0" algorithm   (Fairall et al. 2003)
+   LOGICAL  ::   ln_COARE_3p5   ! "COARE 3.5" algorithm   (Edson et al. 2013)
+   LOGICAL  ::   ln_ECMWF       ! "ECMWF"     algorithm   (IFS cycle 31)
+   !
+   LOGICAL  ::   ln_taudif      ! logical flag to use the "mean of stress module - module of mean stress" data
+   REAL(wp) ::   rn_pfac        ! multiplication factor for precipitation
+   REAL(wp) ::   rn_efac        ! multiplication factor for evaporation
+   REAL(wp) ::   rn_vfac        ! multiplication factor for ice/ocean velocity in the calculation of wind stress
+   REAL(wp) ::   rn_zqt         ! z(q,t) : height of humidity and temperature measurements
+   REAL(wp) ::   rn_zu          ! z(u)   : height of wind measurements
+!!gm ref namelist initialize it so remove the setting to false below
+   LOGICAL  ::   ln_Cd_L12 = .FALSE. !  Modify the drag ice-atm depending on ice concentration (from Lupkes et al. JGR2012)
+   LOGICAL  ::   ln_Cd_L15 = .FALSE. !  Modify the drag ice-atm depending on ice concentration (from Lupkes et al. JGR2015)
+   !
+   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   Cd_atm                    ! transfer coefficient for momentum      (tau)
+   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   Ch_atm                    ! transfer coefficient for sensible heat (Q_sens)
+   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   Ce_atm                    ! tansfert coefficient for evaporation   (Q_lat)
+   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   t_zu                      ! air temperature at wind speed height (needed by Lupkes 2015 bulk scheme)
+   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   q_zu                      ! air spec. hum.  at wind speed height (needed by Lupkes 2015 bulk scheme)
+   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   cdn_oce, chn_oce, cen_oce ! needed by Lupkes 2015 bulk scheme
+
+   INTEGER  ::   nblk           ! choice of the bulk algorithm
+   !                            ! associated indices:
+   INTEGER, PARAMETER ::   np_NCAR      = 1   ! "NCAR" algorithm        (Large and Yeager 2008)
+   INTEGER, PARAMETER ::   np_COARE_3p0 = 2   ! "COARE 3.0" algorithm   (Fairall et al. 2003)
+   INTEGER, PARAMETER ::   np_COARE_3p5 = 3   ! "COARE 3.5" algorithm   (Edson et al. 2013)
+   INTEGER, PARAMETER ::   np_ECMWF     = 4   ! "ECMWF" algorithm       (IFS cycle 31)
+
+   !! * Substitutions
+#  include "vectopt_loop_substitute.h90"
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.7 , NEMO-consortium (2014)
+   !! $Id: sbcblk.F90 6416 2016-04-01 12:22:17Z clem $
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   INTEGER FUNCTION sbc_blk_alloc()
+      !!-------------------------------------------------------------------
+      !!             ***  ROUTINE sbc_blk_alloc ***
+      !!-------------------------------------------------------------------
+      ALLOCATE( Cd_atm (jpi,jpj), Ch_atm (jpi,jpj), Ce_atm (jpi,jpj), t_zu(jpi,jpj), q_zu(jpi,jpj), &
+         &      cdn_oce(jpi,jpj), chn_oce(jpi,jpj), cen_oce(jpi,jpj), STAT=sbc_blk_alloc )
+      !
+      IF( lk_mpp             )   CALL mpp_sum ( sbc_blk_alloc )
+      IF( sbc_blk_alloc /= 0 )   CALL ctl_warn('sbc_blk_alloc: failed to allocate arrays')
+   END FUNCTION sbc_blk_alloc
+
+
+   SUBROUTINE sbc_blk_init
+      !!---------------------------------------------------------------------
+      !!                    ***  ROUTINE sbc_blk_init  ***
+      !!
+      !! ** Purpose :   choose and initialize a bulk formulae formulation
+      !!
+      !! ** Method  : 
+      !!
+      !!----------------------------------------------------------------------
+      INTEGER  ::   ifpr, jfld            ! dummy loop indice and argument
+      INTEGER  ::   ios, ierror, ioptio   ! Local integer
+      !!
+      CHARACTER(len=100)            ::   cn_dir                ! Root directory for location of atmospheric forcing files
+      TYPE(FLD_N), DIMENSION(jpfld) ::   slf_i                 ! array of namelist informations on the fields to read
+      TYPE(FLD_N) ::   sn_wndi, sn_wndj, sn_humi, sn_qsr       ! informations about the fields to be read
+      TYPE(FLD_N) ::   sn_qlw , sn_tair, sn_prec, sn_snow      !       "                        "
+      TYPE(FLD_N) ::   sn_slp , sn_tdif                        !       "                        "
+      NAMELIST/namsbc_blk/ sn_wndi, sn_wndj, sn_humi, sn_qsr, sn_qlw ,                &   ! input fields
+         &                 sn_tair, sn_prec, sn_snow, sn_slp, sn_tdif,                &
+         &                 ln_NCAR, ln_COARE_3p0, ln_COARE_3p5, ln_ECMWF,             &   ! bulk algorithm
+         &                 cn_dir , ln_taudif, rn_zqt, rn_zu,                         & 
+         &                 rn_pfac, rn_efac, rn_vfac, ln_Cd_L12, ln_Cd_L15
+      !!---------------------------------------------------------------------
+      !
+      !                                      ! allocate sbc_blk_core array
+      IF( sbc_blk_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'sbc_blk : unable to allocate standard arrays' )
+      !
+      !                             !** read bulk namelist  
+      REWIND( numnam_ref )                !* Namelist namsbc_blk in reference namelist : bulk parameters
+      READ  ( numnam_ref, namsbc_blk, IOSTAT = ios, ERR = 901)
+901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namsbc_blk in reference namelist', lwp )
+      !
+      REWIND( numnam_cfg )                !* Namelist namsbc_blk in configuration namelist : bulk parameters
+      READ  ( numnam_cfg, namsbc_blk, IOSTAT = ios, ERR = 902 )
+902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namsbc_blk in configuration namelist', lwp )
+      !
+      IF(lwm) WRITE( numond, namsbc_blk )
+      !
+      !                             !** initialization of the chosen bulk formulae (+ check)
+      !                                   !* select the bulk chosen in the namelist and check the choice
+                                                               ioptio = 0
+      IF( ln_NCAR      ) THEN   ;   nblk =  np_NCAR        ;   ioptio = ioptio + 1   ;   ENDIF
+      IF( ln_COARE_3p0 ) THEN   ;   nblk =  np_COARE_3p0   ;   ioptio = ioptio + 1   ;   ENDIF
+      IF( ln_COARE_3p5 ) THEN   ;   nblk =  np_COARE_3p5   ;   ioptio = ioptio + 1   ;   ENDIF
+      IF( ln_ECMWF     ) THEN   ;   nblk =  np_ECMWF       ;   ioptio = ioptio + 1   ;   ENDIF
+      !
+      IF( ioptio /= 1 )   CALL ctl_stop( 'sbc_blk_init: Choose one and only one bulk algorithm' )
+      !
+      IF( ln_dm2dc ) THEN                 !* check: diurnal cycle on Qsr
+         IF( sn_qsr%nfreqh /= 24 )   CALL ctl_stop( 'sbc_blk_init: ln_dm2dc=T only with daily short-wave input' )
+         IF( sn_qsr%ln_tint ) THEN 
+            CALL ctl_warn( 'sbc_blk_init: ln_dm2dc=T daily qsr time interpolation done by sbcdcy module',   &
+               &           '              ==> We force time interpolation = .false. for qsr' )
+            sn_qsr%ln_tint = .false.
+         ENDIF
+      ENDIF
+      !                                   !* set the bulk structure
+      !                                      !- store namelist information in an array
+      slf_i(jp_wndi) = sn_wndi   ;   slf_i(jp_wndj) = sn_wndj
+      slf_i(jp_qsr ) = sn_qsr    ;   slf_i(jp_qlw ) = sn_qlw
+      slf_i(jp_tair) = sn_tair   ;   slf_i(jp_humi) = sn_humi
+      slf_i(jp_prec) = sn_prec   ;   slf_i(jp_snow) = sn_snow
+      slf_i(jp_slp)  = sn_slp    ;   slf_i(jp_tdif) = sn_tdif
+      !
+      lhftau = ln_taudif                     !- add an extra field if HF stress is used
+      jfld = jpfld - COUNT( (/.NOT.lhftau/) )
+      !
+      !                                      !- allocate the bulk structure
+      ALLOCATE( sf(jfld), STAT=ierror )
+      IF( ierror > 0 )   CALL ctl_stop( 'STOP', 'sbc_blk_init: unable to allocate sf structure' )
+      DO ifpr= 1, jfld
+         ALLOCATE( sf(ifpr)%fnow(jpi,jpj,1) )
+         IF( slf_i(ifpr)%ln_tint )   ALLOCATE( sf(ifpr)%fdta(jpi,jpj,1,2) )
+         IF( slf_i(ifpr)%nfreqh > 0. .AND. MOD( 3600. * slf_i(ifpr)%nfreqh , REAL(nn_fsbc) * rdt) /= 0. )   &
+            &  CALL ctl_warn( 'sbc_blk_init: sbcmod timestep rdt*nn_fsbc is NOT a submultiple of atmospheric forcing frequency.',   &
+            &                 '               This is not ideal. You should consider changing either rdt or nn_fsbc value...' )
+
+      END DO
+      !                                      !- fill the bulk structure with namelist informations
+      CALL fld_fill( sf, slf_i, cn_dir, 'sbc_blk_init', 'surface boundary condition -- bulk formulae', 'namsbc_blk' )
+      !
+      IF ( ln_wave ) THEN
+      !Activated wave module but neither drag nor stokes drift activated
+         IF ( .NOT.(ln_cdgw .OR. ln_sdw .OR. ln_tauwoc .OR. ln_stcor ) )   THEN
+            CALL ctl_warn( 'Ask for wave coupling but ln_cdgw=F, ln_sdw=F, ln_tauwoc=F, ln_stcor=F')
+      !drag coefficient read from wave model definable only with mfs bulk formulae and core 
+         ELSEIF (ln_cdgw .AND. .NOT. ln_NCAR )       THEN       
+             CALL ctl_stop( 'drag coefficient read from wave model definable only with mfs bulk formulae and core')
+         ELSEIF (ln_stcor .AND. .NOT. ln_sdw)                             THEN
+             CALL ctl_stop( 'Stokes-Coriolis term calculated only if activated Stokes Drift ln_sdw=T')
+         ENDIF
+      ELSE
+      IF ( ln_cdgw .OR. ln_sdw .OR. ln_tauwoc .OR. ln_stcor )                & 
+         &   CALL ctl_stop( 'Not Activated Wave Module (ln_wave=F) but asked coupling ',    &
+         &                  'with drag coefficient (ln_cdgw =T) '  ,                        &
+         &                  'or Stokes Drift (ln_sdw=T) ' ,                                 &
+         &                  'or ocean stress modification due to waves (ln_tauwoc=T) ',      &  
+         &                  'or Stokes-Coriolis term (ln_stcori=T)'  )
+      ENDIF 
+      !
+      !           
+      IF(lwp) THEN                     !** Control print
+         !
+         WRITE(numout,*)                  !* namelist 
+         WRITE(numout,*) '   Namelist namsbc_blk (other than data information):'
+         WRITE(numout,*) '      "NCAR"      algorithm   (Large and Yeager 2008)     ln_NCAR      = ', ln_NCAR
+         WRITE(numout,*) '      "COARE 3.0" algorithm   (Fairall et al. 2003)       ln_COARE_3p0 = ', ln_COARE_3p0
+         WRITE(numout,*) '      "COARE 3.5" algorithm   (Edson et al. 2013)         ln_COARE_3p5 = ', ln_COARE_3p0
+         WRITE(numout,*) '      "ECMWF"     algorithm   (IFS cycle 31)              ln_ECMWF     = ', ln_ECMWF
+         WRITE(numout,*) '      add High freq.contribution to the stress module     ln_taudif    = ', ln_taudif
+         WRITE(numout,*) '      Air temperature and humidity reference height (m)   rn_zqt       = ', rn_zqt
+         WRITE(numout,*) '      Wind vector reference height (m)                    rn_zu        = ', rn_zu
+         WRITE(numout,*) '      factor applied on precipitation (total & snow)      rn_pfac      = ', rn_pfac
+         WRITE(numout,*) '      factor applied on evaporation                       rn_efac      = ', rn_efac
+         WRITE(numout,*) '      factor applied on ocean/ice velocity                rn_vfac      = ', rn_vfac
+         WRITE(numout,*) '         (form absolute (=0) to relative winds(=1))'
+         WRITE(numout,*) '      use ice-atm drag from Lupkes2012                    ln_Cd_L12    = ', ln_Cd_L12
+         WRITE(numout,*) '      use ice-atm drag from Lupkes2015                    ln_Cd_L15    = ', ln_Cd_L15
+         !
+         WRITE(numout,*)
+         SELECT CASE( nblk )              !* Print the choice of bulk algorithm
+         CASE( np_NCAR      )   ;   WRITE(numout,*) '   ==>>>   "NCAR" algorithm        (Large and Yeager 2008)'
+         CASE( np_COARE_3p0 )   ;   WRITE(numout,*) '   ==>>>   "COARE 3.0" algorithm   (Fairall et al. 2003)'
+         CASE( np_COARE_3p5 )   ;   WRITE(numout,*) '   ==>>>   "COARE 3.5" algorithm   (Edson et al. 2013)'
+         CASE( np_ECMWF     )   ;   WRITE(numout,*) '   ==>>>   "ECMWF" algorithm       (IFS cycle 31)'
+         END SELECT
+         !
+      ENDIF
+      !
+   END SUBROUTINE sbc_blk_init
+
+
+   SUBROUTINE sbc_blk( kt )
+      !!---------------------------------------------------------------------
+      !!                    ***  ROUTINE sbc_blk  ***
+      !!
+      !! ** Purpose :   provide at each time step the surface ocean fluxes
+      !!              (momentum, heat, freshwater and runoff)
+      !!
+      !! ** Method  : (1) READ each fluxes in NetCDF files:
+      !!      the 10m wind velocity (i-component) (m/s)    at T-point
+      !!      the 10m wind velocity (j-component) (m/s)    at T-point
+      !!      the 10m or 2m specific humidity     ( % )
+      !!      the solar heat                      (W/m2)
+      !!      the Long wave                       (W/m2)
+      !!      the 10m or 2m air temperature       (Kelvin)
+      !!      the total precipitation (rain+snow) (Kg/m2/s)
+      !!      the snow (solid prcipitation)       (kg/m2/s)
+      !!      the tau diff associated to HF tau   (N/m2)   at T-point   (ln_taudif=T)
+      !!              (2) CALL blk_oce
+      !!
+      !!      C A U T I O N : never mask the surface stress fields
+      !!                      the stress is assumed to be in the (i,j) mesh referential
+      !!
+      !! ** Action  :   defined at each time-step at the air-sea interface
+      !!              - utau, vtau  i- and j-component of the wind stress
+      !!              - taum        wind stress module at T-point
+      !!              - wndm        wind speed  module at T-point over free ocean or leads in presence of sea-ice
+      !!              - qns, qsr    non-solar and solar heat fluxes
+      !!              - emp         upward mass flux (evapo. - precip.)
+      !!              - sfx         salt flux due to freezing/melting (non-zero only if ice is present)
+      !!                            (set in limsbc(_2).F90)
+      !!
+      !! ** References :   Large & Yeager, 2004 / Large & Yeager, 2008
+      !!                   Brodeau et al. Ocean Modelling 2010
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT(in) ::   kt   ! ocean time step
+      !!---------------------------------------------------------------------
+      !
+      CALL fld_read( kt, nn_fsbc, sf )             ! input fields provided at the current time-step
+      !
+      !                                            ! compute the surface ocean fluxes using bulk formulea
+      IF( MOD( kt - 1, nn_fsbc ) == 0 )   CALL blk_oce( kt, sf, sst_m, ssu_m, ssv_m )
+
+#if defined key_cice
+      IF( MOD( kt - 1, nn_fsbc ) == 0 )   THEN
+         qlw_ice(:,:,1)   = sf(jp_qlw )%fnow(:,:,1)
+         IF( ln_dm2dc ) THEN ; qsr_ice(:,:,1) = sbc_dcy( sf(jp_qsr)%fnow(:,:,1) )
+         ELSE                ; qsr_ice(:,:,1) =          sf(jp_qsr)%fnow(:,:,1) 
+         ENDIF 
+         tatm_ice(:,:)    = sf(jp_tair)%fnow(:,:,1)
+         qatm_ice(:,:)    = sf(jp_humi)%fnow(:,:,1)
+         tprecip(:,:)     = sf(jp_prec)%fnow(:,:,1) * rn_pfac
+         sprecip(:,:)     = sf(jp_snow)%fnow(:,:,1) * rn_pfac
+         wndi_ice(:,:)    = sf(jp_wndi)%fnow(:,:,1)
+         wndj_ice(:,:)    = sf(jp_wndj)%fnow(:,:,1)
+      ENDIF
+#endif
+      !
+   END SUBROUTINE sbc_blk
+
+
+   SUBROUTINE blk_oce( kt, sf, pst, pu, pv )
+      !!---------------------------------------------------------------------
+      !!                     ***  ROUTINE blk_oce  ***
+      !!
+      !! ** Purpose :   provide the momentum, heat and freshwater fluxes at
+      !!      the ocean surface at each time step
+      !!
+      !! ** Method  :   bulk formulea for the ocean using atmospheric
+      !!      fields read in sbc_read
+      !!
+      !! ** Outputs : - utau    : i-component of the stress at U-point  (N/m2)
+      !!              - vtau    : j-component of the stress at V-point  (N/m2)
+      !!              - taum    : Wind stress module at T-point         (N/m2)
+      !!              - wndm    : Wind speed module at T-point          (m/s)
+      !!              - qsr     : Solar heat flux over the ocean        (W/m2)
+      !!              - qns     : Non Solar heat flux over the ocean    (W/m2)
+      !!              - emp     : evaporation minus precipitation       (kg/m2/s)
+      !!
+      !!  ** Nota  :   sf has to be a dummy argument for AGRIF on NEC
+      !!---------------------------------------------------------------------
+      INTEGER  , INTENT(in   )                 ::   kt    ! time step index
+      TYPE(fld), INTENT(inout), DIMENSION(:)   ::   sf    ! input data
+      REAL(wp) , INTENT(in)   , DIMENSION(:,:) ::   pst   ! surface temperature                      [Celcius]
+      REAL(wp) , INTENT(in)   , DIMENSION(:,:) ::   pu    ! surface current at U-point (i-component) [m/s]
+      REAL(wp) , INTENT(in)   , DIMENSION(:,:) ::   pv    ! surface current at V-point (j-component) [m/s]
+      !
+      INTEGER  ::   ji, jj               ! dummy loop indices
+      REAL(wp) ::   zztmp                ! local variable
+      REAL(wp), DIMENSION(jpi,jpj) ::   zwnd_i, zwnd_j    ! wind speed components at T-point
+      REAL(wp), DIMENSION(jpi,jpj) ::   zsq               ! specific humidity at pst
+      REAL(wp), DIMENSION(jpi,jpj) ::   zqlw, zqsb        ! long wave and sensible heat fluxes
+      REAL(wp), DIMENSION(jpi,jpj) ::   zqla, zevap       ! latent heat fluxes and evaporation
+      REAL(wp), DIMENSION(jpi,jpj) ::   zst               ! surface temperature in Kelvin
+      REAL(wp), DIMENSION(jpi,jpj) ::   zU_zu             ! bulk wind speed at height zu  [m/s]
+      REAL(wp), DIMENSION(jpi,jpj) ::   ztpot             ! potential temperature of air at z=rn_zqt [K]
+      REAL(wp), DIMENSION(jpi,jpj) ::   zrhoa             ! density of air   [kg/m^3]
+      !!---------------------------------------------------------------------
+      !
+      ! local scalars ( place there for vector optimisation purposes)
+      zst(:,:) = pst(:,:) + rt0      ! convert SST from Celcius to Kelvin (and set minimum value far above 0 K)
+
+      ! ----------------------------------------------------------------------------- !
+      !      0   Wind components and module at T-point relative to the moving ocean   !
+      ! ----------------------------------------------------------------------------- !
+
+      ! ... components ( U10m - U_oce ) at T-point (unmasked)
+!!gm    move zwnd_i (_j) set to zero  inside the key_cyclone ???
+      zwnd_i(:,:) = 0._wp
+      zwnd_j(:,:) = 0._wp
+#if defined key_cyclone
+      CALL wnd_cyc( kt, zwnd_i, zwnd_j )    ! add analytical tropical cyclone (Vincent et al. JGR 2012)
+      DO jj = 2, jpjm1
+         DO ji = fs_2, fs_jpim1   ! vect. opt.
+            sf(jp_wndi)%fnow(ji,jj,1) = sf(jp_wndi)%fnow(ji,jj,1) + zwnd_i(ji,jj)
+            sf(jp_wndj)%fnow(ji,jj,1) = sf(jp_wndj)%fnow(ji,jj,1) + zwnd_j(ji,jj)
+         END DO
+      END DO
+#endif
+      DO jj = 2, jpjm1
+         DO ji = fs_2, fs_jpim1   ! vect. opt.
+            zwnd_i(ji,jj) = (  sf(jp_wndi)%fnow(ji,jj,1) - rn_vfac * 0.5 * ( pu(ji-1,jj  ) + pu(ji,jj) )  )
+            zwnd_j(ji,jj) = (  sf(jp_wndj)%fnow(ji,jj,1) - rn_vfac * 0.5 * ( pv(ji  ,jj-1) + pv(ji,jj) )  )
+         END DO
+      END DO
+      CALL lbc_lnk_multi( zwnd_i, 'T', -1., zwnd_j, 'T', -1. )
+      ! ... scalar wind ( = | U10m - U_oce | ) at T-point (masked)
+      wndm(:,:) = SQRT(  zwnd_i(:,:) * zwnd_i(:,:)   &
+         &             + zwnd_j(:,:) * zwnd_j(:,:)  ) * tmask(:,:,1)
+
+      ! ----------------------------------------------------------------------------- !
+      !      I   Radiative FLUXES                                                     !
+      ! ----------------------------------------------------------------------------- !
+
+      ! ocean albedo assumed to be constant + modify now Qsr to include the diurnal cycle                    ! Short Wave
+      zztmp = 1. - albo
+      IF( ln_dm2dc ) THEN   ;   qsr(:,:) = zztmp * sbc_dcy( sf(jp_qsr)%fnow(:,:,1) ) * tmask(:,:,1)
+      ELSE                  ;   qsr(:,:) = zztmp *          sf(jp_qsr)%fnow(:,:,1)   * tmask(:,:,1)
+      ENDIF
+
+      zqlw(:,:) = (  sf(jp_qlw)%fnow(:,:,1) - Stef * zst(:,:)*zst(:,:)*zst(:,:)*zst(:,:)  ) * tmask(:,:,1)   ! Long  Wave
+
+      ! ----------------------------------------------------------------------------- !
+      !     II    Turbulent FLUXES                                                    !
+      ! ----------------------------------------------------------------------------- !
+
+      ! ... specific humidity at SST and IST tmask(
+      zsq(:,:) = 0.98 * q_sat( zst(:,:), sf(jp_slp)%fnow(:,:,1) )
+      !!
+      !! Estimate of potential temperature at z=rn_zqt, based on adiabatic lapse-rate
+      !!    (see Josey, Gulev & Yu, 2013) / doi=10.1016/B978-0-12-391851-2.00005-2
+      !!    (since reanalysis products provide T at z, not theta !)
+      ztpot = sf(jp_tair)%fnow(:,:,1) + gamma_moist( sf(jp_tair)%fnow(:,:,1), sf(jp_humi)%fnow(:,:,1) ) * rn_zqt
+
+      SELECT CASE( nblk )        !==  transfer coefficients  ==!   Cd, Ch, Ce at T-point
+      !
+      CASE( np_NCAR      )   ;   CALL turb_ncar    ( rn_zqt, rn_zu, zst, ztpot, zsq, sf(jp_humi)%fnow, wndm,   &  ! NCAR-COREv2
+         &                                           Cd_atm, Ch_atm, Ce_atm, t_zu, q_zu, zU_zu, cdn_oce, chn_oce, cen_oce )
+      CASE( np_COARE_3p0 )   ;   CALL turb_coare   ( rn_zqt, rn_zu, zst, ztpot, zsq, sf(jp_humi)%fnow, wndm,   &  ! COARE v3.0
+         &                                           Cd_atm, Ch_atm, Ce_atm, t_zu, q_zu, zU_zu, cdn_oce, chn_oce, cen_oce )
+      CASE( np_COARE_3p5 )   ;   CALL turb_coare3p5( rn_zqt, rn_zu, zst, ztpot, zsq, sf(jp_humi)%fnow, wndm,   &  ! COARE v3.5
+         &                                           Cd_atm, Ch_atm, Ce_atm, t_zu, q_zu, zU_zu, cdn_oce, chn_oce, cen_oce )
+      CASE( np_ECMWF     )   ;   CALL turb_ecmwf   ( rn_zqt, rn_zu, zst, ztpot, zsq, sf(jp_humi)%fnow, wndm,   &  ! ECMWF
+         &                                           Cd_atm, Ch_atm, Ce_atm, t_zu, q_zu, zU_zu, cdn_oce, chn_oce, cen_oce )
+      CASE DEFAULT
+         CALL ctl_stop( 'STOP', 'sbc_oce: non-existing bulk formula selected' )
+      END SELECT
+
+      !                          ! Compute true air density :
+      IF( ABS(rn_zu - rn_zqt) > 0.01 ) THEN     ! At zu: (probably useless to remove zrho*grav*rn_zu from SLP...)
+         zrhoa(:,:) = rho_air( t_zu(:,:)              , q_zu(:,:)              , sf(jp_slp)%fnow(:,:,1) )
+      ELSE                                      ! At zt:
+         zrhoa(:,:) = rho_air( sf(jp_tair)%fnow(:,:,1), sf(jp_humi)%fnow(:,:,1), sf(jp_slp)%fnow(:,:,1) )
+      END IF
+
+!!      CALL iom_put( "Cd_oce", Cd_atm)  ! output value of pure ocean-atm. transfer coef.
+!!      CALL iom_put( "Ch_oce", Ch_atm)  ! output value of pure ocean-atm. transfer coef.
+
+      DO jj = 1, jpj             ! tau module, i and j component
+         DO ji = 1, jpi
+            zztmp = zrhoa(ji,jj)  * zU_zu(ji,jj) * Cd_atm(ji,jj)   ! using bulk wind speed
+            taum  (ji,jj) = zztmp * wndm  (ji,jj)
+            zwnd_i(ji,jj) = zztmp * zwnd_i(ji,jj)
+            zwnd_j(ji,jj) = zztmp * zwnd_j(ji,jj)
+         END DO
+      END DO
+
+      !                          ! add the HF tau contribution to the wind stress module
+      IF( lhftau )   taum(:,:) = taum(:,:) + sf(jp_tdif)%fnow(:,:,1)
+
+      CALL iom_put( "taum_oce", taum )   ! output wind stress module
+
+      ! ... utau, vtau at U- and V_points, resp.
+      !     Note the use of 0.5*(2-umask) in order to unmask the stress along coastlines
+      !     Note the use of MAX(tmask(i,j),tmask(i+1,j) is to mask tau over ice shelves
+      DO jj = 1, jpjm1
+         DO ji = 1, fs_jpim1
+            utau(ji,jj) = 0.5 * ( 2. - umask(ji,jj,1) ) * ( zwnd_i(ji,jj) + zwnd_i(ji+1,jj  ) ) &
+               &          * MAX(tmask(ji,jj,1),tmask(ji+1,jj,1))
+            vtau(ji,jj) = 0.5 * ( 2. - vmask(ji,jj,1) ) * ( zwnd_j(ji,jj) + zwnd_j(ji  ,jj+1) ) &
+               &          * MAX(tmask(ji,jj,1),tmask(ji,jj+1,1))
+         END DO
+      END DO
+      CALL lbc_lnk_multi( utau, 'U', -1., vtau, 'V', -1. )
+
+      !  Turbulent fluxes over ocean
+      ! -----------------------------
+
+      ! zqla used as temporary array, for rho*U (common term of bulk formulae):
+      zqla(:,:) = zrhoa(:,:) * zU_zu(:,:)
+
+      IF( ABS( rn_zu - rn_zqt) < 0.01_wp ) THEN
+         !! q_air and t_air are given at 10m (wind reference height)
+         zevap(:,:) = rn_efac*MAX( 0._wp,             zqla(:,:)*Ce_atm(:,:)*(zsq(:,:) - sf(jp_humi)%fnow(:,:,1)) ) ! Evaporation, using bulk wind speed
+         zqsb (:,:) = cp_air(sf(jp_humi)%fnow(:,:,1))*zqla(:,:)*Ch_atm(:,:)*(zst(:,:) - ztpot(:,:)             )   ! Sensible Heat, using bulk wind speed
+      ELSE
+         !! q_air and t_air are not given at 10m (wind reference height)
+         ! Values of temp. and hum. adjusted to height of wind during bulk algorithm iteration must be used!!!
+         zevap(:,:) = rn_efac*MAX( 0._wp,             zqla(:,:)*Ce_atm(:,:)*(zsq(:,:) - q_zu(:,:) ) ) ! Evaporation, using bulk wind speed
+         zqsb (:,:) = cp_air(sf(jp_humi)%fnow(:,:,1))*zqla(:,:)*Ch_atm(:,:)*(zst(:,:) - t_zu(:,:) )   ! Sensible Heat, using bulk wind speed
+      ENDIF
+
+      zqla(:,:) = L_vap(zst(:,:)) * zevap(:,:)     ! Latent Heat flux
+
+
+      IF(ln_ctl) THEN
+         CALL prt_ctl( tab2d_1=zqla  , clinfo1=' blk_oce: zqla   : ', tab2d_2=Ce_atm , clinfo2=' Ce_oce  : ' )
+         CALL prt_ctl( tab2d_1=zqsb  , clinfo1=' blk_oce: zqsb   : ', tab2d_2=Ch_atm , clinfo2=' Ch_oce  : ' )
+         CALL prt_ctl( tab2d_1=zqlw  , clinfo1=' blk_oce: zqlw   : ', tab2d_2=qsr, clinfo2=' qsr : ' )
+         CALL prt_ctl( tab2d_1=zsq   , clinfo1=' blk_oce: zsq    : ', tab2d_2=zst, clinfo2=' zst : ' )
+         CALL prt_ctl( tab2d_1=utau  , clinfo1=' blk_oce: utau   : ', mask1=umask,   &
+            &          tab2d_2=vtau  , clinfo2=           ' vtau : ', mask2=vmask )
+         CALL prt_ctl( tab2d_1=wndm  , clinfo1=' blk_oce: wndm   : ')
+         CALL prt_ctl( tab2d_1=zst   , clinfo1=' blk_oce: zst    : ')
+      ENDIF
+
+      ! ----------------------------------------------------------------------------- !
+      !     III    Total FLUXES                                                       !
+      ! ----------------------------------------------------------------------------- !
+      !
+      emp (:,:) = (  zevap(:,:)                                          &   ! mass flux (evap. - precip.)
+         &         - sf(jp_prec)%fnow(:,:,1) * rn_pfac  ) * tmask(:,:,1)
+      !
+      qns(:,:) = zqlw(:,:) - zqsb(:,:) - zqla(:,:)                                &   ! Downward Non Solar
+         &     - sf(jp_snow)%fnow(:,:,1) * rn_pfac * lfus                         &   ! remove latent melting heat for solid precip
+         &     - zevap(:,:) * pst(:,:) * rcp                                      &   ! remove evap heat content at SST
+         &     + ( sf(jp_prec)%fnow(:,:,1) - sf(jp_snow)%fnow(:,:,1) ) * rn_pfac  &   ! add liquid precip heat content at Tair
+         &     * ( sf(jp_tair)%fnow(:,:,1) - rt0 ) * rcp                          &
+         &     + sf(jp_snow)%fnow(:,:,1) * rn_pfac                                &   ! add solid  precip heat content at min(Tair,Tsnow)
+         &     * ( MIN( sf(jp_tair)%fnow(:,:,1), rt0_snow ) - rt0 ) * cpic * tmask(:,:,1)
+      !
+#if defined key_si3
+      qns_oce(:,:) = zqlw(:,:) - zqsb(:,:) - zqla(:,:)                                ! non solar without emp (only needed by LIM3)
+      qsr_oce(:,:) = qsr(:,:)
+#endif
+      !
+      IF ( nn_ice == 0 ) THEN
+         CALL iom_put( "qlw_oce" ,   zqlw )                 ! output downward longwave heat over the ocean
+         CALL iom_put( "qsb_oce" , - zqsb )                 ! output downward sensible heat over the ocean
+         CALL iom_put( "qla_oce" , - zqla )                 ! output downward latent   heat over the ocean
+         CALL iom_put( "qemp_oce",   qns-zqlw+zqsb+zqla )   ! output downward heat content of E-P over the ocean
+         CALL iom_put( "qns_oce" ,   qns  )                 ! output downward non solar heat over the ocean
+         CALL iom_put( "qsr_oce" ,   qsr  )                 ! output downward solar heat over the ocean
+         CALL iom_put( "qt_oce"  ,   qns+qsr )              ! output total downward heat over the ocean
+         tprecip(:,:) = sf(jp_prec)%fnow(:,:,1) * rn_pfac   ! output total precipitation [kg/m2/s]
+         sprecip(:,:) = sf(jp_snow)%fnow(:,:,1) * rn_pfac   ! output solid precipitation [kg/m2/s]
+         CALL iom_put( 'snowpre', sprecip )                 ! Snow
+         CALL iom_put( 'precip' , tprecip )                 ! Total precipitation
+      ENDIF
+      !
+      IF(ln_ctl) THEN
+         CALL prt_ctl(tab2d_1=zqsb , clinfo1=' blk_oce: zqsb   : ', tab2d_2=zqlw , clinfo2=' zqlw  : ')
+         CALL prt_ctl(tab2d_1=zqla , clinfo1=' blk_oce: zqla   : ', tab2d_2=qsr  , clinfo2=' qsr   : ')
+         CALL prt_ctl(tab2d_1=pst  , clinfo1=' blk_oce: pst    : ', tab2d_2=emp  , clinfo2=' emp   : ')
+         CALL prt_ctl(tab2d_1=utau , clinfo1=' blk_oce: utau   : ', mask1=umask,   &
+            &         tab2d_2=vtau , clinfo2=              ' vtau  : ' , mask2=vmask )
+      ENDIF
+      !
+   END SUBROUTINE blk_oce
+
+
+
+   FUNCTION rho_air( ptak, pqa, pslp )
+      !!-------------------------------------------------------------------------------
+      !!                           ***  FUNCTION rho_air  ***
+      !!
+      !! ** Purpose : compute density of (moist) air using the eq. of state of the atmosphere
+      !!
+      !! ** Author: L. Brodeau, june 2016 / AeroBulk (https://sourceforge.net/p/aerobulk) 
+      !!-------------------------------------------------------------------------------
+      REAL(wp), DIMENSION(jpi,jpj), INTENT(in) ::   ptak      ! air temperature             [K]
+      REAL(wp), DIMENSION(jpi,jpj), INTENT(in) ::   pqa       ! air specific humidity   [kg/kg]
+      REAL(wp), DIMENSION(jpi,jpj), INTENT(in) ::   pslp      ! pressure in                [Pa]
+      REAL(wp), DIMENSION(jpi,jpj)             ::   rho_air   ! density of moist air   [kg/m^3]
+      !!-------------------------------------------------------------------------------
+      !
+      rho_air = pslp / (  R_dry*ptak * ( 1._wp + rctv0*pqa )  )
+      !
+   END FUNCTION rho_air
+
+
+   FUNCTION cp_air( pqa )
+      !!-------------------------------------------------------------------------------
+      !!                           ***  FUNCTION cp_air  ***
+      !!
+      !! ** Purpose : Compute specific heat (Cp) of moist air
+      !!
+      !! ** Author: L. Brodeau, june 2016 / AeroBulk (https://sourceforge.net/p/aerobulk)
+      !!-------------------------------------------------------------------------------
+      REAL(wp), DIMENSION(jpi,jpj), INTENT(in) ::   pqa      ! air specific humidity         [kg/kg]
+      REAL(wp), DIMENSION(jpi,jpj)             ::   cp_air   ! specific heat of moist air   [J/K/kg]
+      !!-------------------------------------------------------------------------------
+      !
+      Cp_air = Cp_dry + Cp_vap * pqa
+      !
+   END FUNCTION cp_air
+
+
+   FUNCTION q_sat( ptak, pslp )
+      !!----------------------------------------------------------------------------------
+      !!                           ***  FUNCTION q_sat  ***
+      !!
+      !! ** Purpose : Specific humidity at saturation in [kg/kg]
+      !!              Based on accurate estimate of "e_sat"
+      !!              aka saturation water vapor (Goff, 1957)
+      !!
+      !! ** Author: L. Brodeau, june 2016 / AeroBulk (https://sourceforge.net/p/aerobulk)
+      !!----------------------------------------------------------------------------------
+      REAL(wp), DIMENSION(jpi,jpj), INTENT(in) ::   ptak    ! air temperature                       [K]
+      REAL(wp), DIMENSION(jpi,jpj), INTENT(in) ::   pslp    ! sea level atmospheric pressure       [Pa]
+      REAL(wp), DIMENSION(jpi,jpj)             ::   q_sat   ! Specific humidity at saturation   [kg/kg]
+      !
+      INTEGER  ::   ji, jj         ! dummy loop indices
+      REAL(wp) ::   ze_sat, ztmp   ! local scalar
+      !!----------------------------------------------------------------------------------
+      !
+      DO jj = 1, jpj
+         DO ji = 1, jpi
+            !
+            ztmp = rt0 / ptak(ji,jj)
+            !
+            ! Vapour pressure at saturation [hPa] : WMO, (Goff, 1957)
+            ze_sat = 10.**( 10.79574*(1. - ztmp) - 5.028*LOG10(ptak(ji,jj)/rt0)        &
+               &    + 1.50475*10.**(-4)*(1. - 10.**(-8.2969*(ptak(ji,jj)/rt0 - 1.)) )  &
+               &    + 0.42873*10.**(-3)*(10.**(4.76955*(1. - ztmp)) - 1.) + 0.78614  )
+               !
+            q_sat(ji,jj) = reps0 * ze_sat/( 0.01_wp*pslp(ji,jj) - (1._wp - reps0)*ze_sat )   ! 0.01 because SLP is in [Pa]
+            !
+         END DO
+      END DO
+      !
+   END FUNCTION q_sat
+
+
+   FUNCTION gamma_moist( ptak, pqa )
+      !!----------------------------------------------------------------------------------
+      !!                           ***  FUNCTION gamma_moist  ***
+      !!
+      !! ** Purpose : Compute the moist adiabatic lapse-rate.
+      !!     => http://glossary.ametsoc.org/wiki/Moist-adiabatic_lapse_rate
+      !!     => http://www.geog.ucsb.edu/~joel/g266_s10/lecture_notes/chapt03/oh10_3_01/oh10_3_01.html
+      !!
+      !! ** Author: L. Brodeau, june 2016 / AeroBulk (https://sourceforge.net/p/aerobulk)
+      !!----------------------------------------------------------------------------------
+      REAL(wp), DIMENSION(jpi,jpj), INTENT(in) ::   ptak          ! air temperature       [K]
+      REAL(wp), DIMENSION(jpi,jpj), INTENT(in) ::   pqa           ! specific humidity [kg/kg]
+      REAL(wp), DIMENSION(jpi,jpj)             ::   gamma_moist   ! moist adiabatic lapse-rate
+      !
+      INTEGER  ::   ji, jj         ! dummy loop indices
+      REAL(wp) :: zrv, ziRT        ! local scalar
+      !!----------------------------------------------------------------------------------
+      !
+      DO jj = 1, jpj
+         DO ji = 1, jpi
+            zrv = pqa(ji,jj) / (1. - pqa(ji,jj))
+            ziRT = 1. / (R_dry*ptak(ji,jj))    ! 1/RT
+            gamma_moist(ji,jj) = grav * ( 1. + cevap*zrv*ziRT ) / ( Cp_dry + cevap*cevap*zrv*reps0*ziRT/ptak(ji,jj) )
+         END DO
+      END DO
+      !
+   END FUNCTION gamma_moist
+
+
+   FUNCTION L_vap( psst )
+      !!---------------------------------------------------------------------------------
+      !!                           ***  FUNCTION L_vap  ***
+      !!
+      !! ** Purpose : Compute the latent heat of vaporization of water from temperature
+      !!
+      !! ** Author: L. Brodeau, june 2016 / AeroBulk (https://sourceforge.net/p/aerobulk)
+      !!----------------------------------------------------------------------------------
+      REAL(wp), DIMENSION(jpi,jpj)             ::   L_vap   ! latent heat of vaporization   [J/kg]
+      REAL(wp), DIMENSION(jpi,jpj), INTENT(in) ::   psst   ! water temperature                [K]
+      !!----------------------------------------------------------------------------------
+      !
+      L_vap = (  2.501 - 0.00237 * ( psst(:,:) - rt0)  ) * 1.e6
+      !
+   END FUNCTION L_vap
+
+#if defined key_si3
+   !!----------------------------------------------------------------------
+   !!   'key_si3'                                       SI3 sea-ice model
+   !!----------------------------------------------------------------------
+   !!   blk_ice_tau : provide the air-ice stress
+   !!   blk_ice_flx : provide the heat and mass fluxes at air-ice interface
+   !!   blk_ice_qcn : provide ice surface temperature and snow/ice conduction flux (emulating JULES coupler)
+   !!   Cdn10_Lupkes2012 : Lupkes et al. (2012) air-ice drag
+   !!   Cdn10_Lupkes2015 : Lupkes et al. (2015) air-ice drag 
+   !!----------------------------------------------------------------------
+
+   SUBROUTINE blk_ice_tau
+      !!---------------------------------------------------------------------
+      !!                     ***  ROUTINE blk_ice_tau  ***
+      !!
+      !! ** Purpose :   provide the surface boundary condition over sea-ice
+      !!
+      !! ** Method  :   compute momentum using bulk formulation
+      !!                formulea, ice variables and read atmospheric fields.
+      !!                NB: ice drag coefficient is assumed to be a constant
+      !!---------------------------------------------------------------------
+      INTEGER  ::   ji, jj    ! dummy loop indices
+      REAL(wp) ::   zwndi_f , zwndj_f, zwnorm_f   ! relative wind module and components at F-point
+      REAL(wp) ::   zwndi_t , zwndj_t             ! relative wind components at T-point
+      REAL(wp), DIMENSION(jpi,jpj) ::   zrhoa     ! transfer coefficient for momentum      (tau)
+      !!---------------------------------------------------------------------
+      !
+      ! set transfer coefficients to default sea-ice values
+      Cd_atm(:,:) = Cd_ice
+      Ch_atm(:,:) = Cd_ice
+      Ce_atm(:,:) = Cd_ice
+
+      wndm_ice(:,:) = 0._wp      !!gm brutal....
+
+      ! ------------------------------------------------------------ !
+      !    Wind module relative to the moving ice ( U10m - U_ice )   !
+      ! ------------------------------------------------------------ !
+      SELECT CASE( cp_ice_msh )
+      CASE( 'I' )                  ! B-grid ice dynamics :   I-point (i.e. F-point with sea-ice indexation)
+         !                           and scalar wind at T-point ( = | U10m - U_ice | ) (masked)
+         DO jj = 2, jpjm1
+            DO ji = 2, jpim1   ! B grid : NO vector opt
+               ! ... scalar wind at T-point (fld being at T-point)
+               zwndi_t = sf(jp_wndi)%fnow(ji,jj,1) - rn_vfac * 0.25 * (  u_ice(ji,jj+1) + u_ice(ji+1,jj+1)   &
+                  &                                                    + u_ice(ji,jj  ) + u_ice(ji+1,jj  )  )
+               zwndj_t = sf(jp_wndj)%fnow(ji,jj,1) - rn_vfac * 0.25 * (  v_ice(ji,jj+1) + v_ice(ji+1,jj+1)   &
+                  &                                                    + v_ice(ji,jj  ) + v_ice(ji+1,jj  )  )
+               wndm_ice(ji,jj) = SQRT( zwndi_t * zwndi_t + zwndj_t * zwndj_t ) * tmask(ji,jj,1)
+            END DO
+         END DO
+         CALL lbc_lnk( wndm_ice, 'T',  1. )
+         !
+      CASE( 'C' )                  ! C-grid ice dynamics :   U & V-points (same as ocean)
+         DO jj = 2, jpjm1
+            DO ji = fs_2, fs_jpim1   ! vect. opt.
+               zwndi_t = (  sf(jp_wndi)%fnow(ji,jj,1) - rn_vfac * 0.5 * ( u_ice(ji-1,jj  ) + u_ice(ji,jj) )  )
+               zwndj_t = (  sf(jp_wndj)%fnow(ji,jj,1) - rn_vfac * 0.5 * ( v_ice(ji  ,jj-1) + v_ice(ji,jj) )  )
+               wndm_ice(ji,jj) = SQRT( zwndi_t * zwndi_t + zwndj_t * zwndj_t ) * tmask(ji,jj,1)
+            END DO
+         END DO
+         CALL lbc_lnk( wndm_ice, 'T',  1. )
+         !
+      END SELECT
+
+      ! Make ice-atm. drag dependent on ice concentration
+      IF    ( ln_Cd_L12 ) THEN   ! calculate new drag from Lupkes(2012) equations
+         CALL Cdn10_Lupkes2012( Cd_atm )
+         Ch_atm(:,:) = Cd_atm(:,:)       ! momentum and heat transfer coef. are considered identical
+      ELSEIF( ln_Cd_L15 ) THEN   ! calculate new drag from Lupkes(2015) equations
+         CALL Cdn10_Lupkes2015( Cd_atm, Ch_atm ) 
+      ENDIF
+
+!!      CALL iom_put( "Cd_ice", Cd_atm)  ! output value of pure ice-atm. transfer coef.
+!!      CALL iom_put( "Ch_ice", Ch_atm)  ! output value of pure ice-atm. transfer coef.
+
+      ! local scalars ( place there for vector optimisation purposes)
+      ! Computing density of air! Way denser that 1.2 over sea-ice !!!
+      zrhoa (:,:) =  rho_air(sf(jp_tair)%fnow(:,:,1), sf(jp_humi)%fnow(:,:,1), sf(jp_slp)%fnow(:,:,1))
+
+      !!gm brutal....
+      utau_ice  (:,:) = 0._wp
+      vtau_ice  (:,:) = 0._wp
+      !!gm end
+
+      ! ------------------------------------------------------------ !
+      !    Wind stress relative to the moving ice ( U10m - U_ice )   !
+      ! ------------------------------------------------------------ !
+      SELECT CASE( cp_ice_msh )
+      CASE( 'I' )                  ! B-grid ice dynamics :   I-point (i.e. F-point with sea-ice indexation)
+         DO jj = 2, jpjm1
+            DO ji = 2, jpim1   ! B grid : NO vector opt
+               ! ... scalar wind at I-point (fld being at T-point)
+               zwndi_f = 0.25 * (  sf(jp_wndi)%fnow(ji-1,jj  ,1) + sf(jp_wndi)%fnow(ji  ,jj  ,1)   &
+                  &              + sf(jp_wndi)%fnow(ji-1,jj-1,1) + sf(jp_wndi)%fnow(ji  ,jj-1,1)  ) - rn_vfac * u_ice(ji,jj)
+               zwndj_f = 0.25 * (  sf(jp_wndj)%fnow(ji-1,jj  ,1) + sf(jp_wndj)%fnow(ji  ,jj  ,1)   &
+                  &              + sf(jp_wndj)%fnow(ji-1,jj-1,1) + sf(jp_wndj)%fnow(ji  ,jj-1,1)  ) - rn_vfac * v_ice(ji,jj)
+               ! ... ice stress at I-point
+               zwnorm_f = zrhoa(ji,jj) * Cd_atm(ji,jj) * SQRT( zwndi_f * zwndi_f + zwndj_f * zwndj_f )
+               utau_ice(ji,jj) = zwnorm_f * zwndi_f
+               vtau_ice(ji,jj) = zwnorm_f * zwndj_f
+            END DO
+         END DO
+         CALL lbc_lnk_multi( utau_ice, 'I', -1., vtau_ice, 'I', -1. )
+         !
+      CASE( 'C' )                  ! C-grid ice dynamics :   U & V-points (same as ocean)
+         DO jj = 2, jpjm1
+            DO ji = fs_2, fs_jpim1   ! vect. opt.
+               utau_ice(ji,jj) = 0.5 * zrhoa(ji,jj) * Cd_atm(ji,jj) * ( wndm_ice(ji+1,jj  ) + wndm_ice(ji,jj) )            &
+                  &          * ( 0.5 * (sf(jp_wndi)%fnow(ji+1,jj,1) + sf(jp_wndi)%fnow(ji,jj,1) ) - rn_vfac * u_ice(ji,jj) )
+               vtau_ice(ji,jj) = 0.5 * zrhoa(ji,jj) * Cd_atm(ji,jj) * ( wndm_ice(ji,jj+1  ) + wndm_ice(ji,jj) )            &
+                  &          * ( 0.5 * (sf(jp_wndj)%fnow(ji,jj+1,1) + sf(jp_wndj)%fnow(ji,jj,1) ) - rn_vfac * v_ice(ji,jj) )
+            END DO
+         END DO
+         CALL lbc_lnk_multi( utau_ice, 'U', -1., vtau_ice, 'V', -1. )
+         !
+      END SELECT
+      !
+      IF(ln_ctl) THEN
+         CALL prt_ctl(tab2d_1=utau_ice  , clinfo1=' blk_ice: utau_ice : ', tab2d_2=vtau_ice  , clinfo2=' vtau_ice : ')
+         CALL prt_ctl(tab2d_1=wndm_ice  , clinfo1=' blk_ice: wndm_ice : ')
+      ENDIF
+      !
+   END SUBROUTINE blk_ice_tau
+
+
+   SUBROUTINE blk_ice_flx( ptsu, phs, phi, palb )
+      !!---------------------------------------------------------------------
+      !!                     ***  ROUTINE blk_ice_flx  ***
+      !!
+      !! ** Purpose :   provide the heat and mass fluxes at air-ice interface
+      !!
+      !! ** Method  :   compute heat and freshwater exchanged
+      !!                between atmosphere and sea-ice using bulk formulation
+      !!                formulea, ice variables and read atmmospheric fields.
+      !!
+      !! caution : the net upward water flux has with mm/day unit
+      !!---------------------------------------------------------------------
+      REAL(wp), DIMENSION(:,:,:), INTENT(in)  ::   ptsu   ! sea ice surface temperature
+      REAL(wp), DIMENSION(:,:,:), INTENT(in)  ::   phs    ! snow thickness
+      REAL(wp), DIMENSION(:,:,:), INTENT(in)  ::   phi    ! ice thickness
+      REAL(wp), DIMENSION(:,:,:), INTENT(in)  ::   palb   ! ice albedo (all skies)
+      !!
+      INTEGER  ::   ji, jj, jl               ! dummy loop indices
+      REAL(wp) ::   zst3                     ! local variable
+      REAL(wp) ::   zcoef_dqlw, zcoef_dqla   !   -      -
+      REAL(wp) ::   zztmp, z1_lsub           !   -      -
+      REAL(wp) ::   zfr1, zfr2               ! local variables
+      REAL(wp), DIMENSION(jpi,jpj,jpl) ::   z1_st         ! inverse of surface temperature
+      REAL(wp), DIMENSION(jpi,jpj,jpl) ::   z_qlw         ! long wave heat flux over ice
+      REAL(wp), DIMENSION(jpi,jpj,jpl) ::   z_qsb         ! sensible  heat flux over ice
+      REAL(wp), DIMENSION(jpi,jpj,jpl) ::   z_dqlw        ! long wave heat sensitivity over ice
+      REAL(wp), DIMENSION(jpi,jpj,jpl) ::   z_dqsb        ! sensible  heat sensitivity over ice
+      REAL(wp), DIMENSION(jpi,jpj)     ::   zevap, zsnw   ! evaporation and snw distribution after wind blowing (LIM3)
+      REAL(wp), DIMENSION(jpi,jpj)     ::   zrhoa
+      !!---------------------------------------------------------------------
+      !
+      zcoef_dqlw = 4.0 * 0.95 * Stef             ! local scalars
+      zcoef_dqla = -Ls * 11637800. * (-5897.8)
+      !
+      zrhoa(:,:) = rho_air( sf(jp_tair)%fnow(:,:,1), sf(jp_humi)%fnow(:,:,1), sf(jp_slp)%fnow(:,:,1) )
+      !
+      zztmp = 1. / ( 1. - albo )
+      WHERE( ptsu(:,:,:) /= 0._wp )   ;   z1_st(:,:,:) = 1._wp / ptsu(:,:,:)
+      ELSEWHERE                       ;   z1_st(:,:,:) = 0._wp
+      END WHERE
+      !                                     ! ========================== !
+      DO jl = 1, jpl                        !  Loop over ice categories  !
+         !                                  ! ========================== !
+         DO jj = 1 , jpj
+            DO ji = 1, jpi
+               ! ----------------------------!
+               !      I   Radiative FLUXES   !
+               ! ----------------------------!
+               zst3 = ptsu(ji,jj,jl) * ptsu(ji,jj,jl) * ptsu(ji,jj,jl)
+               ! Short Wave (sw)
+               qsr_ice(ji,jj,jl) = zztmp * ( 1. - palb(ji,jj,jl) ) * qsr(ji,jj)
+               ! Long  Wave (lw)
+               z_qlw(ji,jj,jl) = 0.95 * ( sf(jp_qlw)%fnow(ji,jj,1) - Stef * ptsu(ji,jj,jl) * zst3 ) * tmask(ji,jj,1)
+               ! lw sensitivity
+               z_dqlw(ji,jj,jl) = zcoef_dqlw * zst3
+
+               ! ----------------------------!
+               !     II    Turbulent FLUXES  !
+               ! ----------------------------!
+
+               ! ... turbulent heat fluxes with Ch_atm recalculated in blk_ice_tau
+               ! Sensible Heat
+               z_qsb(ji,jj,jl) = zrhoa(ji,jj) * cpa * Ch_atm(ji,jj) * wndm_ice(ji,jj) * (ptsu(ji,jj,jl) - sf(jp_tair)%fnow(ji,jj,1))
+               ! Latent Heat
+               qla_ice(ji,jj,jl) = rn_efac * MAX( 0.e0, zrhoa(ji,jj) * Ls  * Ch_atm(ji,jj) * wndm_ice(ji,jj) *  &
+                  &                ( 11637800. * EXP( -5897.8 * z1_st(ji,jj,jl) ) / zrhoa(ji,jj) - sf(jp_humi)%fnow(ji,jj,1) ) )
+               ! Latent heat sensitivity for ice (Dqla/Dt)
+               IF( qla_ice(ji,jj,jl) > 0._wp ) THEN
+                  dqla_ice(ji,jj,jl) = rn_efac * zcoef_dqla * Ch_atm(ji,jj) * wndm_ice(ji,jj) *  &
+                     &                 z1_st(ji,jj,jl)*z1_st(ji,jj,jl) * EXP(-5897.8 * z1_st(ji,jj,jl))
+               ELSE
+                  dqla_ice(ji,jj,jl) = 0._wp
+               ENDIF
+
+               ! Sensible heat sensitivity (Dqsb_ice/Dtn_ice)
+               z_dqsb(ji,jj,jl) = zrhoa(ji,jj) * cpa * Ch_atm(ji,jj) * wndm_ice(ji,jj)
+
+               ! ----------------------------!
+               !     III    Total FLUXES     !
+               ! ----------------------------!
+               ! Downward Non Solar flux
+               qns_ice (ji,jj,jl) =     z_qlw (ji,jj,jl) - z_qsb (ji,jj,jl) - qla_ice (ji,jj,jl)
+               ! Total non solar heat flux sensitivity for ice
+               dqns_ice(ji,jj,jl) = - ( z_dqlw(ji,jj,jl) + z_dqsb(ji,jj,jl) + dqla_ice(ji,jj,jl) )
+            END DO
+            !
+         END DO
+         !
+      END DO
+      !
+      tprecip(:,:) = sf(jp_prec)%fnow(:,:,1) * rn_pfac      ! total precipitation [kg/m2/s]
+      sprecip(:,:) = sf(jp_snow)%fnow(:,:,1) * rn_pfac      ! solid precipitation [kg/m2/s]
+      CALL iom_put( 'snowpre', sprecip )                    ! Snow precipitation
+      CALL iom_put( 'precip' , tprecip )                    ! Total precipitation
+
+      ! --- evaporation --- !
+      z1_lsub = 1._wp / Lsub
+      evap_ice (:,:,:) = rn_efac * qla_ice (:,:,:) * z1_lsub    ! sublimation
+      devap_ice(:,:,:) = rn_efac * dqla_ice(:,:,:) * z1_lsub    ! d(sublimation)/dT
+      zevap    (:,:)   = rn_efac * ( emp(:,:) + tprecip(:,:) )  ! evaporation over ocean
+
+      ! --- evaporation minus precipitation --- !
+      zsnw(:,:) = 0._wp
+      CALL ice_thd_snwblow( (1.-at_i_b(:,:)), zsnw )  ! snow distribution over ice after wind blowing
+      emp_oce(:,:) = ( 1._wp - at_i_b(:,:) ) * zevap(:,:) - ( tprecip(:,:) - sprecip(:,:) ) - sprecip(:,:) * (1._wp - zsnw )
+      emp_ice(:,:) = SUM( a_i_b(:,:,:) * evap_ice(:,:,:), dim=3 ) - sprecip(:,:) * zsnw
+      emp_tot(:,:) = emp_oce(:,:) + emp_ice(:,:)
+
+      ! --- heat flux associated with emp --- !
+      qemp_oce(:,:) = - ( 1._wp - at_i_b(:,:) ) * zevap(:,:) * sst_m(:,:) * rcp                  & ! evap at sst
+         &          + ( tprecip(:,:) - sprecip(:,:) ) * ( sf(jp_tair)%fnow(:,:,1) - rt0 ) * rcp  & ! liquid precip at Tair
+         &          +   sprecip(:,:) * ( 1._wp - zsnw ) *                                        & ! solid precip at min(Tair,Tsnow)
+         &              ( ( MIN( sf(jp_tair)%fnow(:,:,1), rt0_snow ) - rt0 ) * cpic * tmask(:,:,1) - lfus )
+      qemp_ice(:,:) =   sprecip(:,:) * zsnw *                                                    & ! solid precip (only)
+         &              ( ( MIN( sf(jp_tair)%fnow(:,:,1), rt0_snow ) - rt0 ) * cpic * tmask(:,:,1) - lfus )
+
+      ! --- total solar and non solar fluxes --- !
+      qns_tot(:,:) = ( 1._wp - at_i_b(:,:) ) * qns_oce(:,:) + SUM( a_i_b(:,:,:) * qns_ice(:,:,:), dim=3 )  &
+         &           + qemp_ice(:,:) + qemp_oce(:,:)
+      qsr_tot(:,:) = ( 1._wp - at_i_b(:,:) ) * qsr_oce(:,:) + SUM( a_i_b(:,:,:) * qsr_ice(:,:,:), dim=3 )
+
+      ! --- heat content of precip over ice in J/m3 (to be used in 1D-thermo) --- !
+      qprec_ice(:,:) = rhosn * ( ( MIN( sf(jp_tair)%fnow(:,:,1), rt0_snow ) - rt0 ) * cpic * tmask(:,:,1) - lfus )
+
+      ! --- heat content of evap over ice in W/m2 (to be used in 1D-thermo) ---
+      DO jl = 1, jpl
+         qevap_ice(:,:,jl) = 0._wp ! should be -evap_ice(:,:,jl)*( ( Tice - rt0 ) * cpic * tmask(:,:,1) )
+         !                         ! But we do not have Tice => consider it at 0degC => evap=0 
+      END DO
+
+      ! --- shortwave radiation transmitted below the surface (W/m2, see Grenfell Maykut 77) --- !
+      zfr1 = ( 0.18 * ( 1.0 - cldf_ice ) + 0.35 * cldf_ice )            ! transmission when hi>10cm
+      zfr2 = ( 0.82 * ( 1.0 - cldf_ice ) + 0.65 * cldf_ice )            ! zfr2 such that zfr1 + zfr2 to equal 1
+      !
+      WHERE    ( phs(:,:,:) <= 0._wp .AND. phi(:,:,:) <  0.1_wp )       ! linear decrease from hi=0 to 10cm  
+         qsr_ice_tr(:,:,:) = qsr_ice(:,:,:) * ( zfr1 + zfr2 * ( 1._wp - phi(:,:,:) * 10._wp ) )
+      ELSEWHERE( phs(:,:,:) <= 0._wp .AND. phi(:,:,:) >= 0.1_wp )       ! constant (zfr1) when hi>10cm
+         qsr_ice_tr(:,:,:) = qsr_ice(:,:,:) * zfr1
+      ELSEWHERE                                                         ! zero when hs>0
+         qsr_ice_tr(:,:,:) = 0._wp 
+      END WHERE
+      !
+      IF(ln_ctl) THEN
+         CALL prt_ctl(tab3d_1=qla_ice , clinfo1=' blk_ice: qla_ice  : ', tab3d_2=z_qsb   , clinfo2=' z_qsb    : ', kdim=jpl)
+         CALL prt_ctl(tab3d_1=z_qlw   , clinfo1=' blk_ice: z_qlw    : ', tab3d_2=dqla_ice, clinfo2=' dqla_ice : ', kdim=jpl)
+         CALL prt_ctl(tab3d_1=z_dqsb  , clinfo1=' blk_ice: z_dqsb   : ', tab3d_2=z_dqlw  , clinfo2=' z_dqlw   : ', kdim=jpl)
+         CALL prt_ctl(tab3d_1=dqns_ice, clinfo1=' blk_ice: dqns_ice : ', tab3d_2=qsr_ice , clinfo2=' qsr_ice  : ', kdim=jpl)
+         CALL prt_ctl(tab3d_1=ptsu    , clinfo1=' blk_ice: ptsu     : ', tab3d_2=qns_ice , clinfo2=' qns_ice  : ', kdim=jpl)
+         CALL prt_ctl(tab2d_1=tprecip , clinfo1=' blk_ice: tprecip  : ', tab2d_2=sprecip , clinfo2=' sprecip  : ')
+      ENDIF
+      !
+   END SUBROUTINE blk_ice_flx
+   
+
+   SUBROUTINE blk_ice_qcn( k_virtual_itd, ptsu, ptb, phs, phi )
+      !!---------------------------------------------------------------------
+      !!                     ***  ROUTINE blk_ice_qcn  ***
+      !!
+      !! ** Purpose :   Compute surface temperature and snow/ice conduction flux
+      !!                to force sea ice / snow thermodynamics
+      !!                in the case JULES coupler is emulated
+      !!                
+      !! ** Method  :   compute surface energy balance assuming neglecting heat storage
+      !!                following the 0-layer Semtner (1976) approach
+      !!
+      !! ** Outputs : - ptsu    : sea-ice / snow surface temperature (K)
+      !!              - qcn_ice : surface inner conduction flux (W/m2)
+      !!
+      !!---------------------------------------------------------------------
+      INTEGER                   , INTENT(in   ) ::   k_virtual_itd   ! single-category option
+      REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   ptsu            ! sea ice / snow surface temperature
+      REAL(wp), DIMENSION(:,:)  , INTENT(in   ) ::   ptb             ! sea ice base temperature
+      REAL(wp), DIMENSION(:,:,:), INTENT(in   ) ::   phs             ! snow thickness
+      REAL(wp), DIMENSION(:,:,:), INTENT(in   ) ::   phi             ! sea ice thickness
+      !
+      INTEGER , PARAMETER ::   nit = 10                  ! number of iterations
+      REAL(wp), PARAMETER ::   zepsilon = 0.1_wp         ! characteristic thickness for enhanced conduction
+      !
+      INTEGER  ::   ji, jj, jl           ! dummy loop indices
+      INTEGER  ::   iter                 ! local integer
+      REAL(wp) ::   zfac, zfac2, zfac3   ! local scalars
+      REAL(wp) ::   zkeff_h, ztsu, ztsu0 !
+      REAL(wp) ::   zqc, zqnet           !
+      REAL(wp) ::   zhe, zqa0            !
+      REAL(wp), DIMENSION(jpi,jpj,jpl) ::   zgfac   ! enhanced conduction factor
+      !!---------------------------------------------------------------------
+      
+      ! -------------------------------------!
+      !      I   Enhanced conduction factor  !
+      ! -------------------------------------!
+      ! Emulates the enhancement of conduction by unresolved thin ice (k_virtual_itd = 1/2)
+      ! Fichefet and Morales Maqueda, JGR 1997
+      !
+      zgfac(:,:,:) = 1._wp
+      
+      SELECT CASE ( k_virtual_itd )
+      !
+      CASE ( 1 , 2 )
+         !
+         zfac  = 1._wp /  ( rn_cnd_s + rcdic )
+         zfac2 = EXP(1._wp) * 0.5_wp * zepsilon
+         zfac3 = 2._wp / zepsilon
+         !   
+         DO jl = 1, jpl                
+            DO jj = 1 , jpj
+               DO ji = 1, jpi
+                  zhe = ( rn_cnd_s * phi(ji,jj,jl) + rcdic * phs(ji,jj,jl) ) * zfac                             ! Effective thickness
+                  IF( zhe >=  zfac2 )   zgfac(ji,jj,jl) = MIN( 2._wp, 0.5_wp * ( 1._wp + LOG( zhe * zfac3 ) ) ) ! Enhanced conduction factor
+               END DO
+            END DO
+         END DO
+         !      
+      END SELECT
+      
+      ! -------------------------------------------------------------!
+      !      II   Surface temperature and conduction flux            !
+      ! -------------------------------------------------------------!
+      !
+      zfac = rcdic * rn_cnd_s
+      !
+      DO jl = 1, jpl
+         DO jj = 1 , jpj
+            DO ji = 1, jpi
+               !                    
+               zkeff_h = zfac * zgfac(ji,jj,jl) / &                                    ! Effective conductivity of the snow-ice system divided by thickness
+                  &      ( rcdic * phs(ji,jj,jl) + rn_cnd_s * MAX( 0.01, phi(ji,jj,jl) ) )
+               ztsu    = ptsu(ji,jj,jl)                                                ! Store current iteration temperature
+               ztsu0   = ptsu(ji,jj,jl)                                                ! Store initial surface temperature
+               zqa0    = qsr_ice(ji,jj,jl) - qsr_ice_tr(ji,jj,jl) + qns_ice(ji,jj,jl)  ! Net initial atmospheric heat flux
+               !
+               DO iter = 1, nit     ! --- Iterative loop
+                  zqc   = zkeff_h * ( ztsu - ptb(ji,jj) )                              ! Conduction heat flux through snow-ice system (>0 downwards)
+                  zqnet = zqa0 + dqns_ice(ji,jj,jl) * ( ztsu - ptsu(ji,jj,jl) ) - zqc  ! Surface energy budget
+                  ztsu  = ztsu - zqnet / ( dqns_ice(ji,jj,jl) - zkeff_h )              ! Temperature update
+               END DO
+               !
+               ptsu   (ji,jj,jl) = MIN( rt0, ztsu )
+               qcn_ice(ji,jj,jl) = zkeff_h * ( ptsu(ji,jj,jl) - ptb(ji,jj) )
+               qns_ice(ji,jj,jl) = qns_ice(ji,jj,jl) + dqns_ice(ji,jj,jl) * ( ptsu(ji,jj,jl) - ztsu0 )
+               qml_ice(ji,jj,jl) = ( qsr_ice(ji,jj,jl) - qsr_ice_tr(ji,jj,jl) + qns_ice(ji,jj,jl) - qcn_ice(ji,jj,jl) )   &
+                             &   * MAX( 0._wp , SIGN( 1._wp, ptsu(ji,jj,jl) - rt0 ) )
+
+            END DO
+         END DO
+         !
+      END DO 
+      !      
+   END SUBROUTINE blk_ice_qcn
+   
+
+   SUBROUTINE Cdn10_Lupkes2012( Cd )
+      !!----------------------------------------------------------------------
+      !!                      ***  ROUTINE  Cdn10_Lupkes2012  ***
+      !!
+      !! ** Purpose :    Recompute the neutral air-ice drag referenced at 10m 
+      !!                 to make it dependent on edges at leads, melt ponds and flows.
+      !!                 After some approximations, this can be resumed to a dependency
+      !!                 on ice concentration.
+      !!                
+      !! ** Method :     The parameterization is taken from Lupkes et al. (2012) eq.(50)
+      !!                 with the highest level of approximation: level4, eq.(59)
+      !!                 The generic drag over a cell partly covered by ice can be re-written as follows:
+      !!
+      !!                 Cd = Cdw * (1-A) + Cdi * A + Ce * (1-A)**(nu+1/(10*beta)) * A**mu
+      !!
+      !!                    Ce = 2.23e-3       , as suggested by Lupkes (eq. 59)
+      !!                    nu = mu = beta = 1 , as suggested by Lupkes (eq. 59)
+      !!                    A is the concentration of ice minus melt ponds (if any)
+      !!
+      !!                 This new drag has a parabolic shape (as a function of A) starting at
+      !!                 Cdw(say 1.5e-3) for A=0, reaching 1.97e-3 for A~0.5 
+      !!                 and going down to Cdi(say 1.4e-3) for A=1
+      !!
+      !!                 It is theoretically applicable to all ice conditions (not only MIZ)
+      !!                 => see Lupkes et al (2013)
+      !!
+      !! ** References : Lupkes et al. JGR 2012 (theory)
+      !!                 Lupkes et al. GRL 2013 (application to GCM)
+      !!
+      !!----------------------------------------------------------------------
+      REAL(wp), DIMENSION(:,:), INTENT(inout) ::   Cd
+      REAL(wp), PARAMETER ::   zCe   = 2.23e-03_wp
+      REAL(wp), PARAMETER ::   znu   = 1._wp
+      REAL(wp), PARAMETER ::   zmu   = 1._wp
+      REAL(wp), PARAMETER ::   zbeta = 1._wp
+      REAL(wp)            ::   zcoef
+      !!----------------------------------------------------------------------
+      zcoef = znu + 1._wp / ( 10._wp * zbeta )
+
+      ! generic drag over a cell partly covered by ice
+      !!Cd(:,:) = Cd_oce(:,:) * ( 1._wp - at_i_b(:,:) ) +  &                        ! pure ocean drag
+      !!   &      Cd_ice      *           at_i_b(:,:)   +  &                        ! pure ice drag
+      !!   &      zCe         * ( 1._wp - at_i_b(:,:) )**zcoef * at_i_b(:,:)**zmu   ! change due to sea-ice morphology
+
+      ! ice-atm drag
+      Cd(:,:) = Cd_ice +  &                                                         ! pure ice drag
+         &      zCe    * ( 1._wp - at_i_b(:,:) )**zcoef * at_i_b(:,:)**(zmu-1._wp)  ! change due to sea-ice morphology
+      
+   END SUBROUTINE Cdn10_Lupkes2012
+
+
+   SUBROUTINE Cdn10_Lupkes2015( Cd, Ch )
+      !!----------------------------------------------------------------------
+      !!                      ***  ROUTINE  Cdn10_Lupkes2015  ***
+      !!
+      !! ** pUrpose :    Alternative turbulent transfert coefficients formulation
+      !!                 between sea-ice and atmosphere with distinct momentum 
+      !!                 and heat coefficients depending on sea-ice concentration 
+      !!                 and atmospheric stability (no meltponds effect for now).
+      !!                
+      !! ** Method :     The parameterization is adapted from Lupkes et al. (2015)
+      !!                 and ECHAM6 atmospheric model. Compared to Lupkes2012 scheme,
+      !!                 it considers specific skin and form drags (Andreas et al. 2010)
+      !!                 to compute neutral transfert coefficients for both heat and 
+      !!                 momemtum fluxes. Atmospheric stability effect on transfert
+      !!                 coefficient is also taken into account following Louis (1979).
+      !!
+      !! ** References : Lupkes et al. JGR 2015 (theory)
+      !!                 Lupkes et al. ECHAM6 documentation 2015 (implementation)
+      !!
+      !!----------------------------------------------------------------------
+      !
+      REAL(wp), DIMENSION(:,:), INTENT(inout) ::   Cd
+      REAL(wp), DIMENSION(:,:), INTENT(inout) ::   Ch
+      REAL(wp), DIMENSION(jpi,jpj)            ::   zst, zqo_sat, zqi_sat
+      !
+      ! ECHAM6 constants
+      REAL(wp), PARAMETER ::   z0_skin_ice  = 0.69e-3_wp  ! Eq. 43 [m]
+      REAL(wp), PARAMETER ::   z0_form_ice  = 0.57e-3_wp  ! Eq. 42 [m]
+      REAL(wp), PARAMETER ::   z0_ice       = 1.00e-3_wp  ! Eq. 15 [m]
+      REAL(wp), PARAMETER ::   zce10        = 2.80e-3_wp  ! Eq. 41
+      REAL(wp), PARAMETER ::   zbeta        = 1.1_wp      ! Eq. 41
+      REAL(wp), PARAMETER ::   zc           = 5._wp       ! Eq. 13
+      REAL(wp), PARAMETER ::   zc2          = zc * zc
+      REAL(wp), PARAMETER ::   zam          = 2. * zc     ! Eq. 14
+      REAL(wp), PARAMETER ::   zah          = 3. * zc     ! Eq. 30
+      REAL(wp), PARAMETER ::   z1_alpha     = 1._wp / 0.2_wp  ! Eq. 51
+      REAL(wp), PARAMETER ::   z1_alphaf    = z1_alpha    ! Eq. 56
+      REAL(wp), PARAMETER ::   zbetah       = 1.e-3_wp    ! Eq. 26
+      REAL(wp), PARAMETER ::   zgamma       = 1.25_wp     ! Eq. 26
+      REAL(wp), PARAMETER ::   z1_gamma     = 1._wp / zgamma
+      REAL(wp), PARAMETER ::   r1_3         = 1._wp / 3._wp
+      !
+      INTEGER  ::   ji, jj         ! dummy loop indices
+      REAL(wp) ::   zthetav_os, zthetav_is, zthetav_zu
+      REAL(wp) ::   zrib_o, zrib_i
+      REAL(wp) ::   zCdn_skin_ice, zCdn_form_ice, zCdn_ice
+      REAL(wp) ::   zChn_skin_ice, zChn_form_ice
+      REAL(wp) ::   z0w, z0i, zfmi, zfmw, zfhi, zfhw
+      REAL(wp) ::   zCdn_form_tmp
+      !!----------------------------------------------------------------------
+
+      ! Momentum Neutral Transfert Coefficients (should be a constant)
+      zCdn_form_tmp = zce10 * ( LOG( 10._wp / z0_form_ice + 1._wp ) / LOG( rn_zu / z0_form_ice + 1._wp ) )**2   ! Eq. 40
+      zCdn_skin_ice = ( vkarmn                                      / LOG( rn_zu / z0_skin_ice + 1._wp ) )**2   ! Eq. 7
+      zCdn_ice      = zCdn_skin_ice   ! Eq. 7 (cf Lupkes email for details)
+      !zCdn_ice     = 1.89e-3         ! old ECHAM5 value (cf Eq. 32)
+
+      ! Heat Neutral Transfert Coefficients
+      zChn_skin_ice = vkarmn**2 / ( LOG( rn_zu / z0_ice + 1._wp ) * LOG( rn_zu * z1_alpha / z0_skin_ice + 1._wp ) )   ! Eq. 50 + Eq. 52 (cf Lupkes email for details)
+     
+      ! Atmospheric and Surface Variables
+      zst(:,:)     = sst_m(:,:) + rt0                                       ! convert SST from Celcius to Kelvin
+      zqo_sat(:,:) = 0.98_wp * q_sat( zst(:,:)  , sf(jp_slp)%fnow(:,:,1) )  ! saturation humidity over ocean [kg/kg]
+      zqi_sat(:,:) = 0.98_wp * q_sat( tm_su(:,:), sf(jp_slp)%fnow(:,:,1) )  ! saturation humidity over ice   [kg/kg]
+      !
+      DO jj = 2, jpjm1           ! reduced loop is necessary for reproducibility
+         DO ji = fs_2, fs_jpim1
+            ! Virtual potential temperature [K]
+            zthetav_os = zst(ji,jj)   * ( 1._wp + rctv0 * zqo_sat(ji,jj) )   ! over ocean
+            zthetav_is = tm_su(ji,jj) * ( 1._wp + rctv0 * zqi_sat(ji,jj) )   ! ocean ice
+            zthetav_zu = t_zu (ji,jj) * ( 1._wp + rctv0 * q_zu(ji,jj)    )   ! at zu
+            
+            ! Bulk Richardson Number (could use Ri_bulk function from aerobulk instead)
+            zrib_o = grav / zthetav_os * ( zthetav_zu - zthetav_os ) * rn_zu / MAX( 0.5, wndm(ji,jj)     )**2   ! over ocean
+            zrib_i = grav / zthetav_is * ( zthetav_zu - zthetav_is ) * rn_zu / MAX( 0.5, wndm_ice(ji,jj) )**2   ! over ice
+            
+            ! Momentum and Heat Neutral Transfert Coefficients
+            zCdn_form_ice = zCdn_form_tmp * at_i_b(ji,jj) * ( 1._wp - at_i_b(ji,jj) )**zbeta  ! Eq. 40
+            zChn_form_ice = zCdn_form_ice / ( 1._wp + ( LOG( z1_alphaf ) / vkarmn ) * SQRT( zCdn_form_ice ) )               ! Eq. 53 
+                       
+            ! Momentum and Heat Stability functions (possibility to use psi_m_ecmwf instead)
+            z0w = rn_zu * EXP( -1._wp * vkarmn / SQRT( Cdn_oce(ji,jj) ) ) ! over water
+            z0i = z0_skin_ice                                             ! over ice (cf Lupkes email for details)
+            IF( zrib_o <= 0._wp ) THEN
+               zfmw = 1._wp - zam * zrib_o / ( 1._wp + 3._wp * zc2 * Cdn_oce(ji,jj) * SQRT( -zrib_o * ( rn_zu / z0w + 1._wp ) ) )  ! Eq. 10
+               zfhw = ( 1._wp + ( zbetah * ( zthetav_os - zthetav_zu )**r1_3 / ( Chn_oce(ji,jj) * MAX(0.01, wndm(ji,jj)) )   &     ! Eq. 26
+                  &             )**zgamma )**z1_gamma
+            ELSE
+               zfmw = 1._wp / ( 1._wp + zam * zrib_o / SQRT( 1._wp + zrib_o ) )   ! Eq. 12
+               zfhw = 1._wp / ( 1._wp + zah * zrib_o / SQRT( 1._wp + zrib_o ) )   ! Eq. 28
+            ENDIF
+            
+            IF( zrib_i <= 0._wp ) THEN
+               zfmi = 1._wp - zam * zrib_i / (1._wp + 3._wp * zc2 * zCdn_ice * SQRT( -zrib_i * ( rn_zu / z0i + 1._wp)))   ! Eq.  9
+               zfhi = 1._wp - zah * zrib_i / (1._wp + 3._wp * zc2 * zCdn_ice * SQRT( -zrib_i * ( rn_zu / z0i + 1._wp)))   ! Eq. 25
+            ELSE
+               zfmi = 1._wp / ( 1._wp + zam * zrib_i / SQRT( 1._wp + zrib_i ) )   ! Eq. 11
+               zfhi = 1._wp / ( 1._wp + zah * zrib_i / SQRT( 1._wp + zrib_i ) )   ! Eq. 27
+            ENDIF
+            
+            ! Momentum Transfert Coefficients (Eq. 38)
+            Cd(ji,jj) = zCdn_skin_ice *   zfmi +  &
+               &        zCdn_form_ice * ( zfmi * at_i_b(ji,jj) + zfmw * ( 1._wp - at_i_b(ji,jj) ) ) / MAX( 1.e-06, at_i_b(ji,jj) )
+            
+            ! Heat Transfert Coefficients (Eq. 49)
+            Ch(ji,jj) = zChn_skin_ice *   zfhi +  &
+               &        zChn_form_ice * ( zfhi * at_i_b(ji,jj) + zfhw * ( 1._wp - at_i_b(ji,jj) ) ) / MAX( 1.e-06, at_i_b(ji,jj) )
+            !
+         END DO
+      END DO
+      CALL lbc_lnk_multi( Cd, 'T',  1., Ch, 'T', 1. )
+      !
+   END SUBROUTINE Cdn10_Lupkes2015
+
+#endif
+
+   !!======================================================================
+END MODULE sbcblk
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/SBC/sbcblk_algo_coare.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/SBC/sbcblk_algo_coare.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/SBC/sbcblk_algo_coare.F90	(revision 9570)
@@ -0,0 +1,448 @@
+MODULE sbcblk_algo_coare
+   !!======================================================================
+   !!                       ***  MODULE  sbcblk_algo_coare  ***
+   !! Computes turbulent components of surface fluxes
+   !!         according to Fairall et al. 2003 (COARE v3)
+   !!
+   !!   * bulk transfer coefficients C_D, C_E and C_H
+   !!   * air temp. and spec. hum. adjusted from zt (2m) to zu (10m) if needed
+   !!   * the effective bulk wind speed at 10m U_blk
+   !!   => all these are used in bulk formulas in sbcblk.F90
+   !!
+   !!    Using the bulk formulation/param. of COARE v3, Fairall et al. 2003
+   !!
+   !!
+   !!       Routine turb_coare maintained and developed in AeroBulk
+   !!                     (http://aerobulk.sourceforge.net/)
+   !!
+   !!            Author: Laurent Brodeau, 2016, brodeau@gmail.com
+   !!
+   !!======================================================================
+   !! History :  3.6  !  2016-02  (L.Brodeau)   Original code
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   turb_coare  : computes the bulk turbulent transfer coefficients
+   !!                   adjusts t_air and q_air from zt to zu m
+   !!                   returns the effective bulk wind speed at 10m
+   !!----------------------------------------------------------------------
+   USE oce            ! ocean dynamics and tracers
+   USE dom_oce        ! ocean space and time domain
+   USE phycst         ! physical constants
+   USE sbc_oce        ! Surface boundary condition: ocean fields
+   USE sbcwave, ONLY  :  cdn_wave ! wave module
+#if defined key_si3 || defined key_cice
+   USE sbc_ice        ! Surface boundary condition: ice fields
+#endif
+   !
+   USE in_out_manager ! I/O manager
+   USE iom            ! I/O manager library
+   USE lib_mpp        ! distribued memory computing library
+   USE prtctl         ! Print control
+   USE lib_fortran    ! to use key_nosignedzero
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC ::   TURB_COARE   ! called by sbcblk.F90
+
+   !                                              !! COARE own values for given constants:
+   REAL(wp), PARAMETER ::   zi0     = 600._wp      ! scale height of the atmospheric boundary layer...
+   REAL(wp), PARAMETER ::   Beta0   =   1.250_wp   ! gustiness parameter
+   REAL(wp), PARAMETER ::   rctv0   =   0.608_wp   ! constant to obtain virtual temperature...
+
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE turb_coare( zt, zu, sst, t_zt, ssq, q_zt, U_zu, &
+      &                   Cd, Ch, Ce, t_zu, q_zu, U_blk,      &
+      &                   Cdn, Chn, Cen                       )
+      !!----------------------------------------------------------------------
+      !!                      ***  ROUTINE  turb_coare  ***
+      !!
+      !!            2015: L. Brodeau (brodeau@gmail.com)
+      !!
+      !! ** Purpose :   Computes turbulent transfert coefficients of surface
+      !!                fluxes according to Fairall et al. (2003)
+      !!                If relevant (zt /= zu), adjust temperature and humidity from height zt to zu
+      !!
+      !! ** Method : Monin Obukhov Similarity Theory
+      !!----------------------------------------------------------------------
+      !!
+      !! INPUT :
+      !! -------
+      !!    *  zt   : height for temperature and spec. hum. of air            [m]
+      !!    *  zu   : height for wind speed (generally 10m)                   [m]
+      !!    *  U_zu : scalar wind speed at 10m                                [m/s]
+      !!    *  sst  : SST                                                     [K]
+      !!    *  t_zt : potential air temperature at zt                         [K]
+      !!    *  ssq  : specific humidity at saturation at SST                  [kg/kg]
+      !!    *  q_zt : specific humidity of air at zt                          [kg/kg]
+      !!
+      !!
+      !! OUTPUT :
+      !! --------
+      !!    *  Cd     : drag coefficient
+      !!    *  Ch     : sensible heat coefficient
+      !!    *  Ce     : evaporation coefficient
+      !!    *  t_zu   : pot. air temperature adjusted at wind height zu       [K]
+      !!    *  q_zu   : specific humidity of air        //                    [kg/kg]
+      !!    *  U_blk  : bulk wind at 10m                                      [m/s]
+      !!----------------------------------------------------------------------
+      REAL(wp), INTENT(in   )                     ::   zt       ! height for t_zt and q_zt                    [m]
+      REAL(wp), INTENT(in   )                     ::   zu       ! height for U_zu                             [m]
+      REAL(wp), INTENT(in   ), DIMENSION(jpi,jpj) ::   sst      ! sea surface temperature                [Kelvin]
+      REAL(wp), INTENT(in   ), DIMENSION(jpi,jpj) ::   t_zt     ! potential air temperature              [Kelvin]
+      REAL(wp), INTENT(in   ), DIMENSION(jpi,jpj) ::   ssq      ! sea surface specific humidity           [kg/kg]
+      REAL(wp), INTENT(in   ), DIMENSION(jpi,jpj) ::   q_zt     ! specific air humidity at zt             [kg/kg]
+      REAL(wp), INTENT(in   ), DIMENSION(jpi,jpj) ::   U_zu     ! relative wind module at zu                [m/s]
+      REAL(wp), INTENT(  out), DIMENSION(jpi,jpj) ::   Cd       ! transfer coefficient for momentum         (tau)
+      REAL(wp), INTENT(  out), DIMENSION(jpi,jpj) ::   Ch       ! transfer coefficient for sensible heat (Q_sens)
+      REAL(wp), INTENT(  out), DIMENSION(jpi,jpj) ::   Ce       ! transfert coefficient for evaporation   (Q_lat)
+      REAL(wp), INTENT(  out), DIMENSION(jpi,jpj) ::   t_zu     ! pot. air temp. adjusted at zu               [K]
+      REAL(wp), INTENT(  out), DIMENSION(jpi,jpj) ::   q_zu     ! spec. humidity adjusted at zu           [kg/kg]
+      REAL(wp), INTENT(  out), DIMENSION(jpi,jpj) ::   U_blk    ! bulk wind at 10m                          [m/s]
+      REAL(wp), INTENT(  out), DIMENSION(jpi,jpj) ::   Cdn, Chn, Cen ! neutral transfer coefficients
+      !
+      INTEGER :: j_itt
+      LOGICAL ::   l_zt_equal_zu = .FALSE.      ! if q and t are given at same height as U
+      INTEGER , PARAMETER ::   nb_itt = 4       ! number of itterations
+
+      REAL(wp), DIMENSION(jpi,jpj) ::  &
+         &  u_star, t_star, q_star, &
+         &  dt_zu, dq_zu,    &
+         &  znu_a,           & !: Nu_air, Viscosity of air
+         &  z0, z0t
+      REAL(wp), DIMENSION(jpi,jpj) ::   zeta_u        ! stability parameter at height zu
+      REAL(wp), DIMENSION(jpi,jpj) ::   ztmp0, ztmp1, ztmp2
+      REAL(wp), DIMENSION(:,:), ALLOCATABLE ::   zeta_t        ! stability parameter at height zt
+      !!----------------------------------------------------------------------
+      !
+      l_zt_equal_zu = .FALSE.
+      IF( ABS(zu - zt) < 0.01 ) l_zt_equal_zu = .TRUE.    ! testing "zu == zt" is risky with double precision
+
+      IF( .NOT. l_zt_equal_zu )  ALLOCATE( zeta_t(jpi,jpj) )
+
+      !! First guess of temperature and humidity at height zu:
+      t_zu = MAX(t_zt , 0.0)    ! who knows what's given on masked-continental regions...
+      q_zu = MAX(q_zt , 1.e-6)  !               "
+
+      !! Pot. temp. difference (and we don't want it to be 0!)
+      dt_zu = t_zu - sst ;  dt_zu = SIGN( MAX(ABS(dt_zu),1.E-6), dt_zu )
+      dq_zu = q_zu - ssq ;  dq_zu = SIGN( MAX(ABS(dq_zu),1.E-9), dq_zu )
+
+      znu_a = visc_air(t_zt) ! Air viscosity (m^2/s) at zt given from temperature in (K)
+
+      ztmp2 = 0.5*0.5  ! initial guess for wind gustiness contribution
+      U_blk = SQRT(U_zu*U_zu + ztmp2)
+
+      ztmp2   = 10000.     ! optimization: ztmp2 == 1/z0 (with z0 first guess == 0.0001)
+      ztmp0   = LOG(zu*ztmp2)
+      ztmp1   = LOG(10.*ztmp2)
+      u_star = 0.035*U_blk*ztmp1/ztmp0       ! (u* = 0.035*Un10)
+
+
+      z0     = alfa_charn(U_blk)*u_star*u_star/grav + 0.11*znu_a/u_star
+      z0t    = 0.1*EXP(vkarmn/(0.00115/(vkarmn/ztmp1)))   !  WARNING: 1/z0t !
+
+      ztmp2  = vkarmn/ztmp0
+      Cd     = ztmp2*ztmp2    ! first guess of Cd
+
+      ztmp0 = vkarmn*vkarmn/LOG(zt*z0t)/Cd
+
+      !Ribcu = -zu/(zi0*0.004*Beta0**3) !! Saturation Rib, zi0 = tropicalbound. layer depth
+      ztmp2  = grav*zu*(dt_zu + rctv0*t_zu*dq_zu)/(t_zu*U_blk*U_blk)  !! Ribu Bulk Richardson number
+      ztmp1 = 0.5 + sign(0.5 , ztmp2)
+      ztmp0 = ztmp0*ztmp2
+      !!             Ribu < 0                                 Ribu > 0   Beta = 1.25
+      zeta_u = (1.-ztmp1) * (ztmp0/(1.+ztmp2/(-zu/(zi0*0.004*Beta0**3)))) &
+         &  +     ztmp1   * (ztmp0*(1. + 27./9.*ztmp2/ztmp0))
+
+      !! First guess M-O stability dependent scaling params.(u*,t*,q*) to estimate z0 and z/L
+      ztmp0  =  vkarmn/(LOG(zu*z0t) - psi_h_coare(zeta_u))
+
+      u_star = U_blk*vkarmn/(LOG(zu) - LOG(z0)  - psi_m_coare(zeta_u))
+      t_star = dt_zu*ztmp0
+      q_star = dq_zu*ztmp0
+
+      ! What's need to be done if zt /= zu:
+      IF( .NOT. l_zt_equal_zu ) THEN
+
+         zeta_t = zt*zeta_u/zu
+
+         !! First update of values at zu (or zt for wind)
+         ztmp0 = psi_h_coare(zeta_u) - psi_h_coare(zeta_t)
+         ztmp1 = log(zt/zu) + ztmp0
+         t_zu = t_zt - t_star/vkarmn*ztmp1
+         q_zu = q_zt - q_star/vkarmn*ztmp1
+         q_zu = (0.5 + sign(0.5,q_zu))*q_zu !Makes it impossible to have negative humidity :
+
+         dt_zu = t_zu - sst  ; dt_zu = SIGN( MAX(ABS(dt_zu),1.E-6), dt_zu )
+         dq_zu = q_zu - ssq  ; dq_zu = SIGN( MAX(ABS(dq_zu),1.E-9), dq_zu )
+
+      END IF
+
+      !! ITERATION BLOCK
+      DO j_itt = 1, nb_itt
+
+         !!Inverse of Monin-Obukov length (1/L) :
+         ztmp0 = One_on_L(t_zu, q_zu, u_star, t_star, q_star)  ! 1/L == 1/[Monin-Obukhov length]
+
+         ztmp1 = u_star*u_star   ! u*^2
+
+         !! Update wind at 10m taking into acount convection-related wind gustiness:
+         ! Ug = Beta*w*  (Beta = 1.25, Fairall et al. 2003, Eq.8):
+         ztmp2 = Beta0*Beta0*ztmp1*(MAX(-zi0*ztmp0/vkarmn,0.))**(2./3.)   ! => ztmp2 == Ug^2
+         !!   ! Only true when unstable (L<0) => when ztmp0 < 0 => explains "-" before 600.
+         U_blk = MAX(sqrt(U_zu*U_zu + ztmp2), 0.2)        ! include gustiness in bulk wind speed
+         ! => 0.2 prevents U_blk to be 0 in stable case when U_zu=0.
+
+         !! Updating Charnock parameter, increases with the wind (Fairall et al., 2003 p. 577-578)
+         ztmp2 = alfa_charn(U_blk)  ! alpha Charnock parameter
+
+         !! Roughness lengthes z0, z0t (z0q = z0t) :
+         z0   = ztmp2*ztmp1/grav + 0.11*znu_a/u_star ! Roughness length (eq.6)
+         ztmp1 = z0*u_star/znu_a                             ! Re_r: roughness Reynolds number
+         z0t  = min( 1.1E-4 , 5.5E-5*ztmp1**(-0.6) )         ! Scalar roughness for both theta and q (eq.28)
+
+         !! Stability parameters:
+         zeta_u = zu*ztmp0 ; zeta_u = sign( min(abs(zeta_u),50.0), zeta_u )
+         IF( .NOT. l_zt_equal_zu ) THEN
+            zeta_t = zt*ztmp0 ;  zeta_t = sign( min(abs(zeta_t),50.0), zeta_t )
+         END IF
+
+         !! Turbulent scales at zu=10m :
+         ztmp0   = psi_h_coare(zeta_u)
+         ztmp1   = vkarmn/(LOG(zu) -LOG(z0t) - ztmp0)
+
+         t_star = dt_zu*ztmp1
+         q_star = dq_zu*ztmp1
+         u_star = U_blk*vkarmn/(LOG(zu) -LOG(z0) - psi_m_coare(zeta_u))
+
+         IF( .NOT. l_zt_equal_zu ) THEN
+            ! What's need to be done if zt /= zu
+            !! Re-updating temperature and humidity at zu :
+            ztmp2 = ztmp0 - psi_h_coare(zeta_t)
+            ztmp1 = log(zt/zu) + ztmp2
+            t_zu = t_zt - t_star/vkarmn*ztmp1
+            q_zu = q_zt - q_star/vkarmn*ztmp1
+            dt_zu = t_zu - sst ;  dt_zu = SIGN( MAX(ABS(dt_zu),1.E-6), dt_zu )
+            dq_zu = q_zu - ssq ;  dq_zu = SIGN( MAX(ABS(dq_zu),1.E-9), dq_zu )
+         END IF
+
+      END DO
+      !
+      ! compute transfer coefficients at zu :
+      ztmp0 = u_star/U_blk
+      Cd   = ztmp0*ztmp0
+      Ch   = ztmp0*t_star/dt_zu
+      Ce   = ztmp0*q_star/dq_zu
+      !
+      ztmp1 = zu + z0
+      Cdn = vkarmn*vkarmn / (log(ztmp1/z0 )*log(ztmp1/z0 ))
+      Chn = vkarmn*vkarmn / (log(ztmp1/z0t)*log(ztmp1/z0t))
+      Cen = Chn
+      !
+      IF( .NOT. l_zt_equal_zu ) DEALLOCATE( zeta_t )
+      !
+   END SUBROUTINE turb_coare
+
+
+   FUNCTION alfa_charn( pwnd )
+      !!-------------------------------------------------------------------
+      !! Compute the Charnock parameter as a function of the wind speed
+      !!
+      !! (Fairall et al., 2003 p.577-578)
+      !!
+      !! Wind below 10 m/s :  alfa = 0.011
+      !! Wind between 10 and 18 m/s : linear increase from 0.011 to 0.018
+      !! Wind greater than 18 m/s :  alfa = 0.018
+      !!
+      !! Author: L. Brodeau, june 2016 / AeroBulk  (https://sourceforge.net/p/aerobulk)
+      !!-------------------------------------------------------------------
+      REAL(wp), DIMENSION(jpi,jpj) :: alfa_charn
+      REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pwnd   ! wind speed
+      !
+      INTEGER  ::   ji, jj         ! dummy loop indices
+      REAL(wp) :: zw, zgt10, zgt18
+      !!-------------------------------------------------------------------
+      !
+      DO jj = 1, jpj
+         DO ji = 1, jpi
+            !
+            zw = pwnd(ji,jj)   ! wind speed
+            !
+            ! Charnock's constant, increases with the wind :
+            zgt10 = 0.5 + SIGN(0.5,(zw - 10.)) ! If zw<10. --> 0, else --> 1
+            zgt18 = 0.5 + SIGN(0.5,(zw - 18.)) ! If zw<18. --> 0, else --> 1
+            !
+            alfa_charn(ji,jj) =  (1. - zgt10)*0.011    &    ! wind is lower than 10 m/s
+               &     + zgt10*((1. - zgt18)*(0.011 + (0.018 - 0.011) &
+               &      *(zw - 10.)/(18. - 10.)) + zgt18*( 0.018 ) )    ! Hare et al. (1999)
+            !
+         END DO
+      END DO
+      !
+   END FUNCTION alfa_charn
+
+
+   FUNCTION One_on_L( ptha, pqa, pus, pts, pqs )
+      !!------------------------------------------------------------------------
+      !!
+      !! Evaluates the 1./(Monin Obukhov length) from air temperature and
+      !!  specific humidity, and frictional scales u*, t* and q*
+      !!
+      !! Author: L. Brodeau, june 2016 / AeroBulk
+      !!         (https://sourceforge.net/p/aerobulk)
+      !!------------------------------------------------------------------------
+      REAL(wp), DIMENSION(jpi,jpj)             :: One_on_L         !: 1./(Monin Obukhov length) [m^-1]
+      REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ptha,  &  !: average potetntial air temperature [K]
+         &                                        pqa,   &  !: average specific humidity of air   [kg/kg]
+         &                                      pus, pts, pqs   !: frictional velocity, temperature and humidity
+      !
+      INTEGER  ::   ji, jj         ! dummy loop indices
+      REAL(wp) ::     zqa          ! local scalar
+      !!-------------------------------------------------------------------
+      !
+      DO jj = 1, jpj
+         DO ji = 1, jpi
+            !
+            zqa = (1. + rctv0*pqa(ji,jj))
+            !
+            One_on_L(ji,jj) =  grav*vkarmn*(pts(ji,jj)*zqa + rctv0*ptha(ji,jj)*pqs(ji,jj)) &
+               &                      / ( pus(ji,jj)*pus(ji,jj) * ptha(ji,jj)*zqa )
+            !
+         END DO
+      END DO
+      !
+   END FUNCTION One_on_L
+
+
+   FUNCTION psi_m_coare( pzeta )
+      !!----------------------------------------------------------------------------------
+      !! ** Purpose: compute the universal profile stability function for momentum
+      !!             COARE 3.0, Fairall et al. 2003
+      !!             pzeta : stability paramenter, z/L where z is altitude
+      !!                     measurement and L is M-O length
+      !!       Stability function for wind speed and scalars matching Kansas and free
+      !!       convection forms with weighting f convective form, follows Fairall et
+      !!       al (1996) with profile constants from Grachev et al (2000) BLM stable
+      !!       form from Beljaars and Holtslag (1991)
+      !!
+      !! ** Author: L. Brodeau, june 2016 / AeroBulk (https://sourceforge.net/p/aerobulk)
+      !!----------------------------------------------------------------------------------
+      REAL(wp), DIMENSION(jpi,jpj) :: psi_m_coare
+      REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pzeta
+      !
+      INTEGER  ::   ji, jj    ! dummy loop indices
+      REAL(wp) :: zta, zphi_m, zphi_c, zpsi_k, zpsi_c, zf, zc, zstab
+      !!----------------------------------------------------------------------------------
+      !
+      DO jj = 1, jpj
+         DO ji = 1, jpi
+            !
+            zta = pzeta(ji,jj)
+            !
+            zphi_m = ABS(1. - 15.*zta)**.25    !!Kansas unstable
+            !
+            zpsi_k = 2.*LOG((1. + zphi_m)/2.) + LOG((1. + zphi_m*zphi_m)/2.)   &
+               & - 2.*ATAN(zphi_m) + 0.5*rpi
+            !
+            zphi_c = ABS(1. - 10.15*zta)**.3333                   !!Convective
+            !
+            zpsi_c = 1.5*LOG((1. + zphi_c + zphi_c*zphi_c)/3.) &
+               &     - 1.7320508*ATAN((1. + 2.*zphi_c)/1.7320508) + 1.813799447
+            !
+            zf = zta*zta
+            zf = zf/(1. + zf)
+            zc = MIN(50., 0.35*zta)
+            zstab = 0.5 + SIGN(0.5, zta)
+            !
+            psi_m_coare(ji,jj) = (1. - zstab) * ( (1. - zf)*zpsi_k + zf*zpsi_c ) & ! (zta < 0)
+               &                -   zstab     * ( 1. + 1.*zta     &                ! (zta > 0)
+               &                         + 0.6667*(zta - 14.28)/EXP(zc) + 8.525 )   !     "
+            !
+         END DO
+      END DO
+      !
+   END FUNCTION psi_m_coare
+
+
+   FUNCTION psi_h_coare( pzeta )
+      !!---------------------------------------------------------------------
+      !! Universal profile stability function for temperature and humidity
+      !! COARE 3.0, Fairall et al. 2003
+      !!
+      !! pzeta : stability paramenter, z/L where z is altitude measurement
+      !!         and L is M-O length
+      !!
+      !! Stability function for wind speed and scalars matching Kansas and free
+      !! convection forms with weighting f convective form, follows Fairall et
+      !! al (1996) with profile constants from Grachev et al (2000) BLM stable
+      !! form from Beljaars and Holtslag (1991)
+      !!
+      !! Author: L. Brodeau, june 2016 / AeroBulk
+      !!         (https://sourceforge.net/p/aerobulk)
+      !!----------------------------------------------------------------
+      !!
+      REAL(wp), DIMENSION(jpi,jpj) :: psi_h_coare
+      REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pzeta
+      !
+      INTEGER  ::   ji, jj     ! dummy loop indices
+      REAL(wp) :: zta, zphi_h, zphi_c, zpsi_k, zpsi_c, zf, zc, zstab
+      !
+      DO jj = 1, jpj
+         DO ji = 1, jpi
+            !
+            zta = pzeta(ji,jj)
+            !
+            zphi_h = (ABS(1. - 15.*zta))**.5  !! Kansas unstable   (zphi_h = zphi_m**2 when unstable, zphi_m when stable)
+            !
+            zpsi_k = 2.*LOG((1. + zphi_h)/2.)
+            !
+            zphi_c = (ABS(1. - 34.15*zta))**.3333   !! Convective
+            !
+            zpsi_c = 1.5*LOG((1. + zphi_c + zphi_c*zphi_c)/3.) &
+               &    -1.7320508*ATAN((1. + 2.*zphi_c)/1.7320508) + 1.813799447
+            !
+            zf = zta*zta
+            zf = zf/(1. + zf)
+            zc = MIN(50.,0.35*zta)
+            zstab = 0.5 + SIGN(0.5, zta)
+            !
+            psi_h_coare(ji,jj) = (1. - zstab) * ( (1. - zf)*zpsi_k + zf*zpsi_c ) &
+               &                -   zstab     * ( (ABS(1. + 2.*zta/3.))**1.5     &
+               &                           + .6667*(zta - 14.28)/EXP(zc) + 8.525 )
+            !
+         END DO
+      END DO
+      !
+   END FUNCTION psi_h_coare
+
+
+   FUNCTION visc_air( ptak )
+      !!---------------------------------------------------------------------
+      !! Air kinetic viscosity (m^2/s) given from temperature in degrees...
+      !!
+      !! Author: L. Brodeau, june 2016 / AeroBulk
+      !!         (https://sourceforge.net/p/aerobulk)
+      !!---------------------------------------------------------------------
+      !!
+      REAL(wp), DIMENSION(jpi,jpj) :: visc_air
+      REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ptak  ! air temperature in (K)
+      !
+      INTEGER  ::   ji, jj         ! dummy loop indices
+      REAL(wp) ::   ztc, ztc2      ! local scalar
+      !
+      DO jj = 1, jpj
+         DO ji = 1, jpi
+            ztc  = ptak(ji,jj) - rt0   ! air temp, in deg. C
+            ztc2 = ztc*ztc
+            visc_air(ji,jj) = 1.326E-5*(1. + 6.542E-3*ztc + 8.301E-6*ztc2 - 4.84E-9*ztc2*ztc)
+         END DO
+      END DO
+      !
+   END FUNCTION visc_air
+
+
+END MODULE sbcblk_algo_coare
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/SBC/sbcblk_algo_coare3p5.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/SBC/sbcblk_algo_coare3p5.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/SBC/sbcblk_algo_coare3p5.F90	(revision 9570)
@@ -0,0 +1,417 @@
+MODULE sbcblk_algo_coare3p5
+   !!======================================================================
+   !!                       ***  MODULE  sbcblk_algo_coare3p5  ***
+   !! Computes turbulent components of surface fluxes
+   !!         according to Edson et al. 2013 (COARE v3.5) /JPO
+   !!
+   !!   * bulk transfer coefficients C_D, C_E and C_H
+   !!   * air temp. and spec. hum. adjusted from zt (2m) to zu (10m) if needed
+   !!   * the effective bulk wind speed at 10m U_blk
+   !!   => all these are used in bulk formulas in sbcblk.F90
+   !!
+   !!    Using the bulk formulation/param. of COARE v3.5, Edson et al. 2013
+   !!
+   !!
+   !!       Routine turb_coare3p5 maintained and developed in AeroBulk
+   !!                     (http://aerobulk.sourceforge.net/)
+   !!
+   !!            Author: Laurent Brodeau, 2016, brodeau@gmail.com
+   !!
+   !!======================================================================
+   !! History :  3.6  !  2016-02  (L.Brodeau)  Original code
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   turb_coare3p5  : computes the bulk turbulent transfer coefficients
+   !!                   adjusts t_air and q_air from zt to zu m
+   !!                   returns the effective bulk wind speed at 10m
+   !!----------------------------------------------------------------------
+   USE oce             ! ocean dynamics and tracers
+   USE dom_oce         ! ocean space and time domain
+   USE phycst          ! physical constants
+   USE sbc_oce         ! Surface boundary condition: ocean fields
+   USE sbcwave, ONLY   :  cdn_wave ! wave module
+#if defined key_si3 || defined key_cice
+   USE sbc_ice         ! Surface boundary condition: ice fields
+#endif
+   !
+   USE iom             ! I/O manager library
+   USE lib_mpp         ! distribued memory computing library
+   USE in_out_manager  ! I/O manager
+   USE prtctl          ! Print control
+   USE lib_fortran     ! to use key_nosignedzero
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC ::   TURB_COARE3P5   ! called by sbcblk.F90
+
+   !                                   ! COARE own values for given constants:
+   REAL(wp), PARAMETER ::   charn0_max =   0.028   ! value above which the Charnock paramter levels off for winds > 18
+   REAL(wp), PARAMETER ::   zi0        = 600.      ! scale height of the atmospheric boundary layer...1
+   REAL(wp), PARAMETER ::   Beta0      =   1.25    ! gustiness parameter
+   REAL(wp), PARAMETER ::   rctv0      =   0.608   ! constant to obtain virtual temperature...
+
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE turb_coare3p5( zt, zu, sst, t_zt, ssq, q_zt, U_zu,  &
+      &                      Cd, Ch, Ce, t_zu, q_zu, U_blk,       &
+      &                      Cdn, Chn, Cen                        )
+      !!----------------------------------------------------------------------------------
+      !!                      ***  ROUTINE  turb_coare3p5  ***
+      !!
+      !! ** Purpose :   Computes turbulent transfert coefficients of surface
+      !!                fluxes according to Fairall et al. (2003)
+      !!                If relevant (zt /= zu), adjust temperature and humidity from height zt to zu
+      !!
+      !! ** Method : Monin Obukhov Similarity Theory
+      !!
+      !! ** Author: L. Brodeau, june 2016 / AeroBulk (https://sourceforge.net/p/aerobulk) 
+      !!
+      !! INPUT :
+      !! -------
+      !!    *  zt   : height for temperature and spec. hum. of air            [m]
+      !!    *  zu   : height for wind speed (generally 10m)                   [m]
+      !!    *  U_zu : scalar wind speed at 10m                                [m/s]
+      !!    *  sst  : SST                                                     [K]
+      !!    *  t_zt : potential air temperature at zt                         [K]
+      !!    *  ssq  : specific humidity at saturation at SST                  [kg/kg]
+      !!    *  q_zt : specific humidity of air at zt                          [kg/kg]
+      !!
+      !!
+      !! OUTPUT :
+      !! --------
+      !!    *  Cd     : drag coefficient
+      !!    *  Ch     : sensible heat coefficient
+      !!    *  Ce     : evaporation coefficient
+      !!    *  t_zu   : pot. air temperature adjusted at wind height zu       [K]
+      !!    *  q_zu   : specific humidity of air        //                    [kg/kg]
+      !!    *  U_blk  : bulk wind at 10m                                      [m/s]
+      !!
+      !!----------------------------------------------------------------------------------
+      REAL(wp), INTENT(in   )                     ::   zt       ! height for t_zt and q_zt                   [m]
+      REAL(wp), INTENT(in   )                     ::   zu       ! height for U_zu                              [m]
+      REAL(wp), INTENT(in   ), DIMENSION(jpi,jpj) ::   sst      ! sea surface temperature              [Kelvin]
+      REAL(wp), INTENT(in   ), DIMENSION(jpi,jpj) ::   t_zt     ! potential air temperature            [Kelvin]
+      REAL(wp), INTENT(in   ), DIMENSION(jpi,jpj) ::   ssq      ! sea surface specific humidity         [kg/kg]
+      REAL(wp), INTENT(in   ), DIMENSION(jpi,jpj) ::   q_zt     ! specific air humidity                 [kg/kg]
+      REAL(wp), INTENT(in   ), DIMENSION(jpi,jpj) ::   U_zu     ! relative wind module at zu            [m/s]
+      REAL(wp), INTENT(  out), DIMENSION(jpi,jpj) ::   Cd       ! transfer coefficient for momentum         (tau)
+      REAL(wp), INTENT(  out), DIMENSION(jpi,jpj) ::   Ch       ! transfer coefficient for sensible heat (Q_sens)
+      REAL(wp), INTENT(  out), DIMENSION(jpi,jpj) ::   Ce       ! transfert coefficient for evaporation   (Q_lat)
+      REAL(wp), INTENT(  out), DIMENSION(jpi,jpj) ::   t_zu     ! pot. air temp. adjusted at zu             [K]
+      REAL(wp), INTENT(  out), DIMENSION(jpi,jpj) ::   q_zu     ! spec. humidity adjusted at zu             [kg/kg]
+      REAL(wp), INTENT(  out), DIMENSION(jpi,jpj) ::   U_blk    ! bulk wind at 10m                          [m/s]
+      REAL(wp), INTENT(  out), DIMENSION(jpi,jpj) ::   Cdn, Chn, Cen ! neutral transfer coefficients
+      !
+      INTEGER :: j_itt
+      LOGICAL ::   l_zt_equal_zu = .FALSE.      ! if q and t are given at same height as U
+      INTEGER , PARAMETER ::   nb_itt = 4       ! number of itterations
+      !
+      REAL(wp), DIMENSION(jpi,jpj) ::  &
+         &  u_star, t_star, q_star, &
+         &  dt_zu, dq_zu,    &
+         &  znu_a,           & !: Nu_air, Viscosity of air
+         &  z0, z0t
+      REAL(wp), DIMENSION(jpi,jpj) ::   zeta_u        ! stability parameter at height zu
+      REAL(wp), DIMENSION(jpi,jpj) ::   ztmp0, ztmp1, ztmp2
+      REAL(wp), DIMENSION(:,:), ALLOCATABLE ::   zeta_t        ! stability parameter at height zt
+      !!----------------------------------------------------------------------------------
+      !
+      l_zt_equal_zu = .FALSE.
+      IF( ABS(zu - zt) < 0.01 ) l_zt_equal_zu = .TRUE.    ! testing "zu == zt" is risky with double precision
+
+      IF( .NOT. l_zt_equal_zu )   ALLOCATE( zeta_t(jpi,jpj) )
+
+      !! First guess of temperature and humidity at height zu:
+      t_zu = MAX(t_zt , 0.0)    ! who knows what's given on masked-continental regions...
+      q_zu = MAX(q_zt , 1.E-6)  !               "
+
+      !! Pot. temp. difference (and we don't want it to be 0!)
+      dt_zu = t_zu - sst ;  dt_zu = SIGN( MAX(ABS(dt_zu),1.E-6), dt_zu )
+      dq_zu = q_zu - ssq ;  dq_zu = SIGN( MAX(ABS(dq_zu),1.E-9), dq_zu )
+
+      znu_a = visc_air(t_zt) ! Air viscosity (m^2/s) at zt given from temperature in (K)
+
+      ztmp2 = 0.5*0.5  ! initial guess for wind gustiness contribution
+      U_blk = SQRT(U_zu*U_zu + ztmp2)
+
+      ztmp2   = 10000.     ! optimization: ztmp2 == 1/z0 (with z0 first guess == 0.0001)
+      ztmp0   = LOG(zu*ztmp2)
+      ztmp1   = LOG(10.*ztmp2)
+      u_star = 0.035*U_blk*ztmp1/ztmp0       ! (u* = 0.035*Un10)
+
+      !! COARE 3.5 first guess of UN10 is U_zu
+      ztmp2 = MIN( 0.0017*U_zu - 0.005 , charn0_max)  ! alpha Charnock parameter (Eq. 13 Edson al. 2013)
+      ztmp2 = MAX( ztmp2 , 0. )                       ! alpha Charnock parameter (Eq. 13 Edson al. 2013)
+      z0     = ztmp2*u_star*u_star/grav + 0.11*znu_a/u_star
+      z0t    = 0.1*EXP(vkarmn/(0.00115/(vkarmn/ztmp1)))   !  WARNING: 1/z0t !
+
+      ztmp2  = vkarmn/ztmp0
+      Cd     = ztmp2*ztmp2    ! first guess of Cd
+
+      ztmp0 = vkarmn*vkarmn/LOG(zt*z0t)/Cd
+
+      !Ribcu = -zu/(zi0*0.004*Beta0**3) !! Saturation Rib, zi0 = tropicalbound. layer depth
+      ztmp2  = grav*zu*(dt_zu + rctv0*t_zu*dq_zu)/(t_zu*U_blk*U_blk)  !! Ribu Bulk Richardson number
+      ztmp1 = 0.5 + sign(0.5 , ztmp2)
+      ztmp0 = ztmp0*ztmp2
+      !!             Ribu < 0                                 Ribu > 0   Beta = 1.25
+      zeta_u = (1.-ztmp1) * (ztmp0/(1.+ztmp2/(-zu/(zi0*0.004*Beta0**3)))) &
+         &  +     ztmp1   * (ztmp0*(1. + 27./9.*ztmp2/ztmp0))
+
+      !! First guess M-O stability dependent scaling params.(u*,t*,q*) to estimate z0 and z/L
+      ztmp0  =  vkarmn/(LOG(zu*z0t) - psi_h_coare(zeta_u))
+
+      u_star = U_blk*vkarmn/(LOG(zu) - LOG(z0)  - psi_m_coare(zeta_u))
+      t_star = dt_zu*ztmp0
+      q_star = dq_zu*ztmp0
+
+      ! What's need to be done if zt /= zu:
+      IF( .NOT. l_zt_equal_zu ) THEN
+
+         zeta_t = zt*zeta_u/zu
+
+         !! First update of values at zu (or zt for wind)
+         ztmp0 = psi_h_coare(zeta_u) - psi_h_coare(zeta_t)
+         ztmp1 = log(zt/zu) + ztmp0
+         t_zu = t_zt - t_star/vkarmn*ztmp1
+         q_zu = q_zt - q_star/vkarmn*ztmp1
+         q_zu = (0.5 + sign(0.5,q_zu))*q_zu !Makes it impossible to have negative humidity :
+
+         dt_zu = t_zu - sst  ; dt_zu = SIGN( MAX(ABS(dt_zu),1.E-6), dt_zu )
+         dq_zu = q_zu - ssq  ; dq_zu = SIGN( MAX(ABS(dq_zu),1.E-9), dq_zu )
+
+      END IF
+
+      !! ITERATION BLOCK
+      DO j_itt = 1, nb_itt
+
+         !!Inverse of Monin-Obukov length (1/L) :
+         ztmp0 = One_on_L(t_zu, q_zu, u_star, t_star, q_star)  ! 1/L == 1/[Monin-Obukhov length]
+
+         ztmp1 = u_star*u_star   ! u*^2
+
+         !! Update wind at 10m taking into acount convection-related wind gustiness:
+         ! Ug = Beta*w*  (Beta = 1.25, Fairall et al. 2003, Eq.8):
+         ztmp2 = Beta0*Beta0*ztmp1*(MAX(-zi0*ztmp0/vkarmn,0.))**(2./3.)   ! => ztmp2 == Ug^2
+         !!   ! Only true when unstable (L<0) => when ztmp0 < 0 => explains "-" before 600.
+         U_blk = MAX(sqrt(U_zu*U_zu + ztmp2), 0.2)        ! include gustiness in bulk wind speed
+         ! => 0.2 prevents U_blk to be 0 in stable case when U_zu=0.
+
+         !! COARE 3.5: Charnock parameter is computed from the neutral wind speed at 10m: Eq. 13 (Edson al. 2013)
+         ztmp2 = u_star/vkarmn*LOG(10./z0)   ! UN10 Neutral wind at 10m!
+         ztmp2 = MIN( 0.0017*ztmp2 - 0.005 , charn0_max)  ! alpha Charnock parameter (Eq. 13 Edson al. 2013)
+         ztmp2 = MAX( ztmp2 , 0. )
+
+         !! Roughness lengthes z0, z0t (z0q = z0t) :
+         z0   = ztmp2*ztmp1/grav + 0.11*znu_a/u_star ! Roughness length (eq.6)
+         ztmp1 = z0*u_star/znu_a                             ! Re_r: roughness Reynolds number
+         !z0t  = MIN( 1.1E-4 , 5.5E-5*ztmp1**(-0.6) )   ! COARE 3.0
+         !! Chris Fairall and Jim Edsson, private communication, March 2016 / COARE 3.5 :
+         z0t   = MIN( 1.6e-4 , 5.8E-5*ztmp1**(-0.72)) ! These thermal roughness lengths give Stanton and
+         !z0q = z0t                                   ! Dalton numbers that closely approximate COARE3.0
+
+         !! Stability parameters:
+         zeta_u = zu*ztmp0 ; zeta_u = sign( min(abs(zeta_u),50.0), zeta_u )
+         IF( .NOT. l_zt_equal_zu ) THEN
+            zeta_t = zt*ztmp0 ;  zeta_t = sign( min(abs(zeta_t),50.0), zeta_t )
+         END IF
+
+         !! Turbulent scales at zu=10m :
+         ztmp0   = psi_h_coare(zeta_u)
+         ztmp1   = vkarmn/(LOG(zu) -LOG(z0t) - ztmp0)
+
+         t_star = dt_zu*ztmp1
+         q_star = dq_zu*ztmp1
+         u_star = U_blk*vkarmn/(LOG(zu) -LOG(z0) - psi_m_coare(zeta_u))
+
+         IF( .NOT. l_zt_equal_zu ) THEN
+            ! What's need to be done if zt /= zu
+            !! Re-updating temperature and humidity at zu :
+            ztmp2 = ztmp0 - psi_h_coare(zeta_t)
+            ztmp1 = log(zt/zu) + ztmp2
+            t_zu = t_zt - t_star/vkarmn*ztmp1
+            q_zu = q_zt - q_star/vkarmn*ztmp1
+            dt_zu = t_zu - sst ;  dt_zu = SIGN( MAX(ABS(dt_zu),1.E-6), dt_zu )
+            dq_zu = q_zu - ssq ;  dq_zu = SIGN( MAX(ABS(dq_zu),1.E-9), dq_zu )
+         END IF
+
+      END DO
+      !
+      ! compute transfer coefficients at zu :
+      ztmp0 = u_star/U_blk
+      Cd   = ztmp0*ztmp0
+      Ch   = ztmp0*t_star/dt_zu
+      Ce   = ztmp0*q_star/dq_zu
+      !
+      ztmp1 = zu + z0
+      Cdn = vkarmn*vkarmn / (log(ztmp1/z0 )*log(ztmp1/z0 ))
+      Chn = vkarmn*vkarmn / (log(ztmp1/z0t)*log(ztmp1/z0t))
+      Cen = Chn
+      !
+      IF( .NOT. l_zt_equal_zu ) DEALLOCATE( zeta_t )
+      !
+   END SUBROUTINE turb_coare3p5
+
+
+
+   FUNCTION One_on_L( ptha, pqa, pus, pts, pqs )
+      !!------------------------------------------------------------------------
+      !!
+      !! Evaluates the 1./(Monin Obukhov length) from air temperature and
+      !!  specific humidity, and frictional scales u*, t* and q*
+      !!
+      !! Author: L. Brodeau, june 2016 / AeroBulk
+      !!         (https://sourceforge.net/p/aerobulk)
+      !!------------------------------------------------------------------------
+      REAL(wp), DIMENSION(jpi,jpj)             :: One_on_L         !: 1./(Monin Obukhov length) [m^-1]
+      REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ptha,  &  !: average potetntial air temperature [K]
+         &                                        pqa,   &  !: average specific humidity of air   [kg/kg]
+         &                                      pus, pts, pqs   !: frictional velocity, temperature and humidity
+      !
+      INTEGER  ::   ji, jj         ! dummy loop indices
+      REAL(wp) ::     zqa          ! local scalar
+      !
+      DO jj = 1, jpj
+         DO ji = 1, jpi
+            !
+            zqa = (1. + rctv0*pqa(ji,jj))
+            !
+            One_on_L(ji,jj) =  grav*vkarmn*(pts(ji,jj)*zqa + rctv0*ptha(ji,jj)*pqs(ji,jj)) &
+               &                      / ( pus(ji,jj)*pus(ji,jj) * ptha(ji,jj)*zqa )
+            !
+         END DO
+      END DO
+      !
+   END FUNCTION One_on_L
+
+
+   FUNCTION psi_m_coare( pzeta )
+      !!----------------------------------------------------------------------------------
+      !! ** Purpose: compute the universal profile stability function for momentum
+      !!             COARE 3.0, Fairall et al. 2003
+      !!             pzeta : stability paramenter, z/L where z is altitude
+      !!                     measurement and L is M-O length
+      !!       Stability function for wind speed and scalars matching Kansas and free
+      !!       convection forms with weighting f convective form, follows Fairall et
+      !!       al (1996) with profile constants from Grachev et al (2000) BLM stable
+      !!       form from Beljaars and Holtslag (1991)
+      !!
+      !! ** Author: L. Brodeau, june 2016 / AeroBulk (https://sourceforge.net/p/aerobulk)
+      !!----------------------------------------------------------------------------------
+      REAL(wp), DIMENSION(jpi,jpj) :: psi_m_coare
+      REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pzeta
+      !
+      INTEGER  ::   ji, jj    ! dummy loop indices
+      REAL(wp) :: zta, zphi_m, zphi_c, zpsi_k, zpsi_c, zf, zc, zstab
+      !!----------------------------------------------------------------------------------
+      !
+      DO jj = 1, jpj
+         DO ji = 1, jpi
+            !
+            zta = pzeta(ji,jj)
+            !
+            zphi_m = ABS(1. - 15.*zta)**.25    !!Kansas unstable
+            !
+            zpsi_k = 2.*LOG((1. + zphi_m)/2.) + LOG((1. + zphi_m*zphi_m)/2.)   &
+               & - 2.*ATAN(zphi_m) + 0.5*rpi
+            !
+            zphi_c = ABS(1. - 10.15*zta)**.3333                   !!Convective
+            !
+            zpsi_c = 1.5*LOG((1. + zphi_c + zphi_c*zphi_c)/3.) &
+               &     - 1.7320508*ATAN((1. + 2.*zphi_c)/1.7320508) + 1.813799447
+            !
+            zf = zta*zta
+            zf = zf/(1. + zf)
+            zc = MIN(50., 0.35*zta)
+            zstab = 0.5 + SIGN(0.5, zta)
+            !
+            psi_m_coare(ji,jj) = (1. - zstab) * ( (1. - zf)*zpsi_k + zf*zpsi_c ) & ! (zta < 0)
+               &                -   zstab     * ( 1. + 1.*zta     &                ! (zta > 0)
+               &                         + 0.6667*(zta - 14.28)/EXP(zc) + 8.525 )   !     "
+            !
+         END DO
+      END DO
+      !
+   END FUNCTION psi_m_coare
+
+
+   FUNCTION psi_h_coare( pzeta )
+      !!---------------------------------------------------------------------
+      !! Universal profile stability function for temperature and humidity
+      !! COARE 3.0, Fairall et al. 2003
+      !!
+      !! pzeta : stability paramenter, z/L where z is altitude measurement
+      !!         and L is M-O length
+      !!
+      !! Stability function for wind speed and scalars matching Kansas and free
+      !! convection forms with weighting f convective form, follows Fairall et
+      !! al (1996) with profile constants from Grachev et al (2000) BLM stable
+      !! form from Beljaars and Holtslag (1991)
+      !!
+      !! Author: L. Brodeau, june 2016 / AeroBulk
+      !!         (https://sourceforge.net/p/aerobulk)
+      !!----------------------------------------------------------------
+      !!
+      REAL(wp), DIMENSION(jpi,jpj) :: psi_h_coare
+      REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pzeta
+      !
+      INTEGER  ::   ji, jj     ! dummy loop indices
+      REAL(wp) :: zta, zphi_h, zphi_c, zpsi_k, zpsi_c, zf, zc, zstab
+      !
+      DO jj = 1, jpj
+         DO ji = 1, jpi
+            !
+            zta = pzeta(ji,jj)
+            !
+            zphi_h = (ABS(1. - 15.*zta))**.5  !! Kansas unstable   (zphi_h = zphi_m**2 when unstable, zphi_m when stable)
+            !
+            zpsi_k = 2.*LOG((1. + zphi_h)/2.)
+            !
+            zphi_c = (ABS(1. - 34.15*zta))**.3333   !! Convective
+            !
+            zpsi_c = 1.5*LOG((1. + zphi_c + zphi_c*zphi_c)/3.) &
+               &    -1.7320508*ATAN((1. + 2.*zphi_c)/1.7320508) + 1.813799447
+            !
+            zf = zta*zta
+            zf = zf/(1. + zf)
+            zc = MIN(50.,0.35*zta)
+            zstab = 0.5 + SIGN(0.5, zta)
+            !
+            psi_h_coare(ji,jj) = (1. - zstab) * ( (1. - zf)*zpsi_k + zf*zpsi_c ) &
+               &                -   zstab     * ( (ABS(1. + 2.*zta/3.))**1.5     &
+               &                           + .6667*(zta - 14.28)/EXP(zc) + 8.525 )
+            !
+         END DO
+      END DO
+      !
+   END FUNCTION psi_h_coare
+
+
+   FUNCTION visc_air( ptak )
+      !!---------------------------------------------------------------------
+      !! Air kinetic viscosity (m^2/s) given from temperature in degrees...
+      !!
+      !! Author: L. Brodeau, june 2016 / AeroBulk
+      !!         (https://sourceforge.net/p/aerobulk)
+      !!---------------------------------------------------------------------
+      REAL(wp), DIMENSION(jpi,jpj)             ::   visc_air
+      REAL(wp), DIMENSION(jpi,jpj), INTENT(in) ::   ptak       ! air temperature   [K]
+      !
+      INTEGER  ::   ji, jj         ! dummy loop indices
+      REAL(wp) ::   ztc, ztc2      ! local scalar
+      !
+      DO jj = 1, jpj
+         DO ji = 1, jpi
+            ztc  = ptak(ji,jj) - rt0   ! air temp, in deg. C
+            ztc2 = ztc*ztc
+            visc_air(ji,jj) = 1.326E-5*(1. + 6.542E-3*ztc + 8.301E-6*ztc2 - 4.84E-9*ztc2*ztc)
+         END DO
+      END DO
+      !
+   END FUNCTION visc_air
+
+   !!======================================================================
+END MODULE sbcblk_algo_coare3p5
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/SBC/sbcblk_algo_ecmwf.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/SBC/sbcblk_algo_ecmwf.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/SBC/sbcblk_algo_ecmwf.F90	(revision 9570)
@@ -0,0 +1,427 @@
+MODULE sbcblk_algo_ecmwf
+   !!======================================================================
+   !!                       ***  MODULE  sbcblk_algo_ecmwf  ***
+   !! Computes turbulent components of surface fluxes
+   !!         according to the method in IFS of the ECMWF model
+   !!
+   !!   * bulk transfer coefficients C_D, C_E and C_H
+   !!   * air temp. and spec. hum. adjusted from zt (2m) to zu (10m) if needed
+   !!   * the effective bulk wind speed at 10m U_blk
+   !!   => all these are used in bulk formulas in sbcblk.F90
+   !!
+   !!    Using the bulk formulation/param. of IFS of ECMWF (cycle 31r2)
+   !!         based on IFS doc (avaible online on the ECMWF's website)
+   !!
+   !!
+   !!       Routine turb_ecmwf maintained and developed in AeroBulk
+   !!                     (http://aerobulk.sourceforge.net/)
+   !!
+   !! ** Author: L. Brodeau, june 2016 / AeroBulk (https://sourceforge.net/p/aerobulk)
+   !!----------------------------------------------------------------------
+   !! History :  4.0  !  2016-02  (L.Brodeau)   Original code
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   turb_ecmwf  : computes the bulk turbulent transfer coefficients
+   !!                   adjusts t_air and q_air from zt to zu m
+   !!                   returns the effective bulk wind speed at 10m
+   !!----------------------------------------------------------------------
+   USE oce             ! ocean dynamics and tracers
+   USE dom_oce         ! ocean space and time domain
+   USE phycst          ! physical constants
+   USE iom             ! I/O manager library
+   USE lib_mpp         ! distribued memory computing library
+   USE in_out_manager  ! I/O manager
+   USE prtctl          ! Print control
+   USE sbcwave, ONLY   :  cdn_wave ! wave module
+#if defined key_si3 || defined key_cice
+   USE sbc_ice         ! Surface boundary condition: ice fields
+#endif
+   USE lib_fortran     ! to use key_nosignedzero
+
+   USE sbc_oce         ! Surface boundary condition: ocean fields
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC ::   TURB_ECMWF   ! called by sbcblk.F90
+
+   !                   !! ECMWF own values for given constants, taken form IFS documentation...
+   REAL(wp), PARAMETER ::   charn0 = 0.018    ! Charnock constant (pretty high value here !!!
+   !                                          !    =>  Usually 0.011 for moderate winds)
+   REAL(wp), PARAMETER ::   zi0     = 1000.   ! scale height of the atmospheric boundary layer...1
+   REAL(wp), PARAMETER ::   Beta0    = 1.     ! gustiness parameter ( = 1.25 in COAREv3)
+   REAL(wp), PARAMETER ::   rctv0    = 0.608  ! constant to obtain virtual temperature...
+   REAL(wp), PARAMETER ::   Cp_dry = 1005.0   ! Specic heat of dry air, constant pressure      [J/K/kg]
+   REAL(wp), PARAMETER ::   Cp_vap = 1860.0   ! Specic heat of water vapor, constant pressure  [J/K/kg]
+   REAL(wp), PARAMETER ::   alpha_M = 0.11    ! For roughness length (smooth surface term)
+   REAL(wp), PARAMETER ::   alpha_H = 0.40    ! (Chapter 3, p.34, IFS doc Cy31r1)
+   REAL(wp), PARAMETER ::   alpha_Q = 0.62    !
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE TURB_ECMWF( zt, zu, sst, t_zt, ssq , q_zt , U_zu,   &
+      &                   Cd, Ch, Ce , t_zu, q_zu, U_blk,         &
+      &                   Cdn, Chn, Cen                           )
+      !!----------------------------------------------------------------------------------
+      !!                      ***  ROUTINE  turb_ecmwf  ***
+      !!
+      !!            2015: L. Brodeau (brodeau@gmail.com)
+      !!
+      !! ** Purpose :   Computes turbulent transfert coefficients of surface
+      !!                fluxes according to IFS doc. (cycle 31)
+      !!                If relevant (zt /= zu), adjust temperature and humidity from height zt to zu
+      !!
+      !! ** Method : Monin Obukhov Similarity Theory
+      !!
+      !! INPUT :
+      !! -------
+      !!    *  zt   : height for temperature and spec. hum. of air            [m]
+      !!    *  zu   : height for wind speed (generally 10m)                   [m]
+      !!    *  U_zu : scalar wind speed at 10m                                [m/s]
+      !!    *  sst  : SST                                                     [K]
+      !!    *  t_zt : potential air temperature at zt                         [K]
+      !!    *  ssq  : specific humidity at saturation at SST                  [kg/kg]
+      !!    *  q_zt : specific humidity of air at zt                          [kg/kg]
+      !!
+      !!
+      !! OUTPUT :
+      !! --------
+      !!    *  Cd     : drag coefficient
+      !!    *  Ch     : sensible heat coefficient
+      !!    *  Ce     : evaporation coefficient
+      !!    *  t_zu   : pot. air temperature adjusted at wind height zu       [K]
+      !!    *  q_zu   : specific humidity of air        //                    [kg/kg]
+      !!    *  U_blk  : bulk wind at 10m                                      [m/s]
+      !!
+      !!
+      !! ** Author: L. Brodeau, june 2016 / AeroBulk (https://sourceforge.net/p/aerobulk)
+      !!----------------------------------------------------------------------------------
+      REAL(wp), INTENT(in   )                     ::   zt       ! height for t_zt and q_zt                    [m]
+      REAL(wp), INTENT(in   )                     ::   zu       ! height for U_zu                             [m]
+      REAL(wp), INTENT(in   ), DIMENSION(jpi,jpj) ::   sst      ! sea surface temperature                [Kelvin]
+      REAL(wp), INTENT(in   ), DIMENSION(jpi,jpj) ::   t_zt     ! potential air temperature              [Kelvin]
+      REAL(wp), INTENT(in   ), DIMENSION(jpi,jpj) ::   ssq      ! sea surface specific humidity           [kg/kg]
+      REAL(wp), INTENT(in   ), DIMENSION(jpi,jpj) ::   q_zt     ! specific air humidity                   [kg/kg]
+      REAL(wp), INTENT(in   ), DIMENSION(jpi,jpj) ::   U_zu     ! relative wind module at zu                [m/s]
+      REAL(wp), INTENT(  out), DIMENSION(jpi,jpj) ::   Cd       ! transfer coefficient for momentum         (tau)
+      REAL(wp), INTENT(  out), DIMENSION(jpi,jpj) ::   Ch       ! transfer coefficient for sensible heat (Q_sens)
+      REAL(wp), INTENT(  out), DIMENSION(jpi,jpj) ::   Ce       ! transfert coefficient for evaporation   (Q_lat)
+      REAL(wp), INTENT(  out), DIMENSION(jpi,jpj) ::   t_zu     ! pot. air temp. adjusted at zu               [K]
+      REAL(wp), INTENT(  out), DIMENSION(jpi,jpj) ::   q_zu     ! spec. humidity adjusted at zu           [kg/kg]
+      REAL(wp), INTENT(  out), DIMENSION(jpi,jpj) ::   U_blk    ! bulk wind at 10m                          [m/s]
+      REAL(wp), INTENT(  out), DIMENSION(jpi,jpj) ::   Cdn, Chn, Cen ! neutral transfer coefficients
+      !
+      INTEGER :: j_itt
+      LOGICAL ::   l_zt_equal_zu = .FALSE.      ! if q and t are given at same height as U
+      INTEGER , PARAMETER ::   nb_itt = 4       ! number of itterations
+      !
+      REAL(wp), DIMENSION(jpi,jpj) ::   u_star, t_star, q_star,   &
+         &  dt_zu, dq_zu,    &
+         &  znu_a,           & !: Nu_air, Viscosity of air
+         &  Linv,            & !: 1/L (inverse of Monin Obukhov length...
+         &  z0, z0t, z0q
+      REAL(wp), DIMENSION(jpi,jpj) ::   func_m, func_h
+      REAL(wp), DIMENSION(jpi,jpj) ::   ztmp0, ztmp1, ztmp2
+      !!----------------------------------------------------------------------------------
+      !
+      ! Identical first gess as in COARE, with IFS parameter values though
+      !
+      l_zt_equal_zu = .FALSE.
+      IF( ABS(zu - zt) < 0.01 )   l_zt_equal_zu = .TRUE.    ! testing "zu == zt" is risky with double precision
+
+
+      !! First guess of temperature and humidity at height zu:
+      t_zu = MAX( t_zt , 0.0  )   ! who knows what's given on masked-continental regions...
+      q_zu = MAX( q_zt , 1.e-6)   !               "
+
+      !! Pot. temp. difference (and we don't want it to be 0!)
+      dt_zu = t_zu - sst   ;   dt_zu = SIGN( MAX(ABS(dt_zu),1.e-6), dt_zu )
+      dq_zu = q_zu - ssq   ;   dq_zu = SIGN( MAX(ABS(dq_zu),1.e-9), dq_zu )
+
+      znu_a = visc_air(t_zt) ! Air viscosity (m^2/s) at zt given from temperature in (K)
+
+      ztmp2 = 0.5 * 0.5  ! initial guess for wind gustiness contribution
+      U_blk = SQRT(U_zu*U_zu + ztmp2)
+
+      ! z0     = 0.0001
+      ztmp2   = 10000.     ! optimization: ztmp2 == 1/z0
+      ztmp0   = LOG(zu*ztmp2)
+      ztmp1   = LOG(10.*ztmp2)
+      u_star = 0.035*U_blk*ztmp1/ztmp0       ! (u* = 0.035*Un10)
+
+      z0     = charn0*u_star*u_star/grav + 0.11*znu_a/u_star
+      z0t    = 0.1*EXP(vkarmn/(0.00115/(vkarmn/ztmp1)))   !  WARNING: 1/z0t !
+
+      Cd     = (vkarmn/ztmp0)**2    ! first guess of Cd
+
+      ztmp0 = vkarmn*vkarmn/LOG(zt*z0t)/Cd
+
+      ztmp2 = Ri_bulk( zu, t_zu, dt_zu, q_zu, dq_zu, U_blk )   ! Ribu = Bulk Richardson number
+
+      !! First estimate of zeta_u, depending on the stability, ie sign of Ribu (ztmp2):
+      ztmp1 = 0.5 + SIGN( 0.5 , ztmp2 )
+      func_m = ztmp0*ztmp2 ! temporary array !!
+      !!             Ribu < 0                                 Ribu > 0   Beta = 1.25
+      func_h = (1.-ztmp1)*(func_m/(1.+ztmp2/(-zu/(zi0*0.004*Beta0**3)))) &  ! temporary array !!! func_h == zeta_u
+         &  +     ztmp1*(func_m*(1. + 27./9.*ztmp2/ztmp0))
+
+      !! First guess M-O stability dependent scaling params.(u*,t*,q*) to estimate z0 and z/L
+      ztmp0   =        vkarmn/(LOG(zu*z0t) - psi_h_ecmwf(func_h))
+
+      u_star = U_blk*vkarmn/(LOG(zu) - LOG(z0)  - psi_m_ecmwf(func_h))
+      t_star = dt_zu*ztmp0
+      q_star = dq_zu*ztmp0
+
+      ! What's need to be done if zt /= zu:
+      IF( .NOT. l_zt_equal_zu ) THEN
+         !
+         !! First update of values at zu (or zt for wind)
+         ztmp0 = psi_h_ecmwf(func_h) - psi_h_ecmwf(zt*func_h/zu)    ! zt*func_h/zu == zeta_t
+         ztmp1 = log(zt/zu) + ztmp0
+         t_zu = t_zt - t_star/vkarmn*ztmp1
+         q_zu = q_zt - q_star/vkarmn*ztmp1
+         q_zu = (0.5 + sign(0.5,q_zu))*q_zu !Makes it impossible to have negative humidity :
+
+         dt_zu = t_zu - sst  ; dt_zu = SIGN( MAX(ABS(dt_zu),1.E-6), dt_zu )
+         dq_zu = q_zu - ssq  ; dq_zu = SIGN( MAX(ABS(dq_zu),1.E-9), dq_zu )
+         !
+      ENDIF
+
+
+      !! => that was same first guess as in COARE...
+
+
+      !! First guess of inverse of Monin-Obukov length (1/L) :
+      ztmp0 = (1. + rctv0*q_zu)  ! the factor to apply to temp. to get virt. temp...
+      Linv  =  grav*vkarmn*(t_star*ztmp0 + rctv0*t_zu*q_star) / ( u_star*u_star * t_zu*ztmp0 )
+
+      !! Functions such as  u* = U_blk*vkarmn/func_m
+      ztmp1 = zu + z0
+      ztmp0 = ztmp1*Linv
+      func_m = LOG(ztmp1) -LOG(z0) - psi_m_ecmwf(ztmp0) + psi_m_ecmwf(z0*Linv)
+      func_h = LOG(ztmp1*z0t) - psi_h_ecmwf(ztmp0) + psi_h_ecmwf(1./z0t*Linv)
+
+
+      !! ITERATION BLOCK
+      !! ***************
+
+      DO j_itt = 1, nb_itt
+
+         !! Bulk Richardson Number at z=zu (Eq. 3.25)
+         ztmp0 = Ri_bulk(zu, t_zu, dt_zu, q_zu, dq_zu, U_blk)
+
+         !! New estimate of the inverse of the Monin-Obukhon length (Linv == zeta/zu) :
+         Linv = ztmp0*func_m*func_m/func_h / zu     ! From Eq. 3.23, Chap.3, p.33, IFS doc - Cy31r1
+
+         !! Update func_m with new Linv:
+         ztmp1 = zu + z0
+         func_m = LOG(ztmp1) -LOG(z0) - psi_m_ecmwf(ztmp1*Linv) + psi_m_ecmwf(z0*Linv)
+
+         !! Need to update roughness lengthes:
+         u_star = U_blk*vkarmn/func_m
+         ztmp2  = u_star*u_star
+         ztmp1  = znu_a/u_star
+         z0    = alpha_M*ztmp1 + charn0*ztmp2/grav
+         z0t    = alpha_H*ztmp1                              ! eq.3.26, Chap.3, p.34, IFS doc - Cy31r1
+         z0q    = alpha_Q*ztmp1
+
+         !! Update wind at 10m taking into acount convection-related wind gustiness:
+         ! Only true when unstable (L<0) => when ztmp0 < 0 => - !!!
+         ztmp2 = ztmp2 * (MAX(-zi0*Linv/vkarmn,0.))**(2./3.) ! => w*^2  (combining Eq. 3.8 and 3.18, hap.3, IFS doc - Cy31r1)
+         !! => equivalent using Beta=1 (gustiness parameter, 1.25 for COARE, also zi0=600 in COARE..)
+         U_blk = MAX(sqrt(U_zu*U_zu + ztmp2), 0.2)              ! eq.3.17, Chap.3, p.32, IFS doc - Cy31r1
+         ! => 0.2 prevents U_blk to be 0 in stable case when U_zu=0.
+
+
+         !! Need to update "theta" and "q" at zu in case they are given at different heights
+         !! as well the air-sea differences:
+         IF( .NOT. l_zt_equal_zu ) THEN
+
+            !! Arrays func_m and func_h are free for a while so using them as temporary arrays...
+            func_h = psi_h_ecmwf((zu+z0)*Linv) ! temporary array !!!
+            func_m = psi_h_ecmwf((zt+z0)*Linv) ! temporary array !!!
+
+            ztmp2  = psi_h_ecmwf(z0t*Linv)
+            ztmp0  = func_h - ztmp2
+            ztmp1  = vkarmn/(LOG(zu+z0) - LOG(z0t) - ztmp0)
+            t_star = dt_zu*ztmp1
+            ztmp2  = ztmp0 - func_m + ztmp2
+            ztmp1  = LOG(zt/zu) + ztmp2
+            t_zu   = t_zt - t_star/vkarmn*ztmp1
+
+            ztmp2  = psi_h_ecmwf(z0q*Linv)
+            ztmp0  = func_h - ztmp2
+            ztmp1  = vkarmn/(LOG(zu+z0) - LOG(z0q) - ztmp0)
+            q_star = dq_zu*ztmp1
+            ztmp2  = ztmp0 - func_m + ztmp2
+            ztmp1  = log(zt/zu) + ztmp2
+            q_zu   = q_zt - q_star/vkarmn*ztmp1
+
+            dt_zu = t_zu - sst ;  dt_zu = SIGN( MAX(ABS(dt_zu),1.E-6), dt_zu )
+            dq_zu = q_zu - ssq ;  dq_zu = SIGN( MAX(ABS(dq_zu),1.E-9), dq_zu )
+
+         END IF
+
+         !! Updating because of updated z0 and z0t and new Linv...
+         ztmp1 = zu + z0
+         ztmp0 = ztmp1*Linv
+         func_m = log(ztmp1) - LOG(z0 ) - psi_m_ecmwf(ztmp0) + psi_m_ecmwf(z0 *Linv)
+         func_h = log(ztmp1) - LOG(z0t) - psi_h_ecmwf(ztmp0) + psi_h_ecmwf(z0t*Linv)
+
+      END DO
+
+      Cd = vkarmn*vkarmn/(func_m*func_m)
+      Ch = vkarmn*vkarmn/(func_m*func_h)
+      ztmp1 = log((zu + z0)/z0q) - psi_h_ecmwf((zu + z0)*Linv) + psi_h_ecmwf(z0q*Linv)   ! func_q
+      Ce = vkarmn*vkarmn/(func_m*ztmp1)
+
+      ztmp1 = zu + z0
+      Cdn = vkarmn*vkarmn / (log(ztmp1/z0 )*log(ztmp1/z0 ))
+      Chn = vkarmn*vkarmn / (log(ztmp1/z0t)*log(ztmp1/z0t))
+      Cen = vkarmn*vkarmn / (log(ztmp1/z0q)*log(ztmp1/z0q))
+
+   END SUBROUTINE TURB_ECMWF
+
+
+   FUNCTION psi_m_ecmwf( pzeta )
+      !!----------------------------------------------------------------------------------
+      !! Universal profile stability function for momentum
+      !!     ECMWF / as in IFS cy31r1 documentation, available online
+      !!     at ecmwf.int
+      !!
+      !! pzeta : stability paramenter, z/L where z is altitude measurement
+      !!         and L is M-O length
+      !!
+      !! ** Author: L. Brodeau, june 2016 / AeroBulk (https://sourceforge.net/p/aerobulk)
+      !!----------------------------------------------------------------------------------
+      REAL(wp), DIMENSION(jpi,jpj) :: psi_m_ecmwf
+      REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pzeta
+      !
+      INTEGER  ::   ji, jj    ! dummy loop indices
+      REAL(wp) :: zzeta, zx, ztmp, psi_unst, psi_stab, stab
+      !!----------------------------------------------------------------------------------
+      !
+      DO jj = 1, jpj
+         DO ji = 1, jpi
+            !
+            zzeta = MIN( pzeta(ji,jj) , 5. ) !! Very stable conditions (L positif and big!):
+            !
+            ! Unstable (Paulson 1970):
+            !   eq.3.20, Chap.3, p.33, IFS doc - Cy31r1
+            zx = SQRT(ABS(1. - 16.*zzeta))
+            ztmp = 1. + SQRT(zx)
+            ztmp = ztmp*ztmp
+            psi_unst = LOG( 0.125*ztmp*(1. + zx) )   &
+               &       -2.*ATAN( SQRT(zx) ) + 0.5*rpi
+            !
+            ! Unstable:
+            ! eq.3.22, Chap.3, p.33, IFS doc - Cy31r1
+            psi_stab = -2./3.*(zzeta - 5./0.35)*EXP(-0.35*zzeta) &
+               &       - zzeta - 2./3.*5./0.35
+            !
+            ! Combining:
+            stab = 0.5 + SIGN(0.5, zzeta) ! zzeta > 0 => stab = 1
+            !
+            psi_m_ecmwf(ji,jj) = (1. - stab) * psi_unst & ! (zzeta < 0) Unstable
+               &                +      stab  * psi_stab   ! (zzeta > 0) Stable
+            !
+         END DO
+      END DO
+      !
+   END FUNCTION psi_m_ecmwf
+
+   
+   FUNCTION psi_h_ecmwf( pzeta )
+      !!----------------------------------------------------------------------------------
+      !! Universal profile stability function for temperature and humidity
+      !!     ECMWF / as in IFS cy31r1 documentation, available online
+      !!     at ecmwf.int
+      !!
+      !! pzeta : stability paramenter, z/L where z is altitude measurement
+      !!         and L is M-O length
+      !!
+      !! ** Author: L. Brodeau, june 2016 / AeroBulk (https://sourceforge.net/p/aerobulk)
+      !!----------------------------------------------------------------------------------
+      REAL(wp), DIMENSION(jpi,jpj) :: psi_h_ecmwf
+      REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pzeta
+      !
+      INTEGER  ::   ji, jj     ! dummy loop indices
+      REAL(wp) ::  zzeta, zx, psi_unst, psi_stab, stab
+      !!----------------------------------------------------------------------------------
+      !
+      DO jj = 1, jpj
+         DO ji = 1, jpi
+            !
+            zzeta = MIN(pzeta(ji,jj) , 5.)   ! Very stable conditions (L positif and big!):
+            !
+            zx  = ABS(1. - 16.*zzeta)**.25        ! this is actually (1/phi_m)**2  !!!
+            !                                     ! eq.3.19, Chap.3, p.33, IFS doc - Cy31r1
+            ! Unstable (Paulson 1970) :
+            psi_unst = 2.*LOG(0.5*(1. + zx*zx))   ! eq.3.20, Chap.3, p.33, IFS doc - Cy31r1
+            !
+            ! Stable:
+            psi_stab = -2./3.*(zzeta - 5./0.35)*EXP(-0.35*zzeta) & ! eq.3.22, Chap.3, p.33, IFS doc - Cy31r1
+               &       - ABS(1. + 2./3.*zzeta)**1.5 - 2./3.*5./0.35 + 1. 
+            ! LB: added ABS() to avoid NaN values when unstable, which contaminates the unstable solution...
+            !
+            stab = 0.5 + SIGN(0.5, zzeta) ! zzeta > 0 => stab = 1
+            !
+            !
+            psi_h_ecmwf(ji,jj) = (1. - stab) * psi_unst &   ! (zzeta < 0) Unstable
+               &                +    stab    * psi_stab     ! (zzeta > 0) Stable
+            !
+         END DO
+      END DO
+      !
+   END FUNCTION psi_h_ecmwf
+
+
+   FUNCTION Ri_bulk( pz, ptz, pdt, pqz, pdq, pub )
+      !!----------------------------------------------------------------------------------
+      !! Bulk Richardson number (Eq. 3.25 IFS doc)
+      !!
+      !! ** Author: L. Brodeau, june 2016 / AeroBulk (https://sourceforge.net/p/aerobulk)
+      !!----------------------------------------------------------------------------------
+      REAL(wp), DIMENSION(jpi,jpj) ::   Ri_bulk   !
+      !
+      REAL(wp)                    , INTENT(in) ::   pz    ! height above the sea        [m]
+      REAL(wp), DIMENSION(jpi,jpj), INTENT(in) ::   ptz   ! air temperature at pz m     [K]
+      REAL(wp), DIMENSION(jpi,jpj), INTENT(in) ::   pdt   ! ptz - sst                   [K]
+      REAL(wp), DIMENSION(jpi,jpj), INTENT(in) ::   pqz   ! air temperature at pz m [kg/kg]
+      REAL(wp), DIMENSION(jpi,jpj), INTENT(in) ::   pdq   ! pqz - ssq               [kg/kg]
+      REAL(wp), DIMENSION(jpi,jpj), INTENT(in) ::   pub   ! bulk wind speed           [m/s]
+      !!----------------------------------------------------------------------------------
+      !
+      Ri_bulk =   grav*pz/(pub*pub)                                          &
+         &      * ( pdt/(ptz - 0.5_wp*(pdt + grav*pz/(Cp_dry+Cp_vap*pqz)))   &
+         &          + rctv0*pdq )
+      !
+   END FUNCTION Ri_bulk
+
+
+   FUNCTION visc_air(ptak)
+      !!----------------------------------------------------------------------------------
+      !! Air kinetic viscosity (m^2/s) given from temperature in degrees...
+      !!
+      !! ** Author: L. Brodeau, june 2016 / AeroBulk (https://sourceforge.net/p/aerobulk)
+      !!----------------------------------------------------------------------------------
+      REAL(wp), DIMENSION(jpi,jpj)             ::   visc_air   !
+      REAL(wp), DIMENSION(jpi,jpj), INTENT(in) ::   ptak       ! air temperature in (K)
+      !
+      INTEGER  ::   ji, jj      ! dummy loop indices
+      REAL(wp) ::   ztc, ztc2   ! local scalar
+      !!----------------------------------------------------------------------------------
+      !
+      DO jj = 1, jpj
+         DO ji = 1, jpi
+            ztc  = ptak(ji,jj) - rt0   ! air temp, in deg. C
+            ztc2 = ztc*ztc
+            visc_air(ji,jj) = 1.326e-5*(1. + 6.542E-3*ztc + 8.301e-6*ztc2 - 4.84e-9*ztc2*ztc)
+         END DO
+      END DO
+      !
+   END FUNCTION visc_air
+
+   !!======================================================================
+END MODULE sbcblk_algo_ecmwf
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/SBC/sbcblk_algo_ncar.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/SBC/sbcblk_algo_ncar.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/SBC/sbcblk_algo_ncar.F90	(revision 9570)
@@ -0,0 +1,328 @@
+MODULE sbcblk_algo_ncar
+   !!======================================================================
+   !!                   ***  MODULE  sbcblk_algo_ncar  ***
+   !! Computes:
+   !!   * bulk transfer coefficients C_D, C_E and C_H
+   !!   * air temp. and spec. hum. adjusted from zt (2m) to zu (10m) if needed
+   !!   * the effective bulk wind speed at 10m U_blk
+   !!   => all these are used in bulk formulas in sbcblk.F90
+   !!
+   !!    Using the bulk formulation/param. of Large & Yeager 2008
+   !!
+   !!       Routine turb_ncar maintained and developed in AeroBulk
+   !!                     (http://aerobulk.sourceforge.net/)
+   !!
+   !!                         L. Brodeau, 2015
+   !!=====================================================================
+   !! History :  3.6  !  2016-02  (L.Brodeau) successor of old turb_ncar of former sbcblk_core.F90
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   turb_ncar  : computes the bulk turbulent transfer coefficients
+   !!                   adjusts t_air and q_air from zt to zu m
+   !!                   returns the effective bulk wind speed at 10m
+   !!----------------------------------------------------------------------
+   USE oce             ! ocean dynamics and tracers
+   USE dom_oce         ! ocean space and time domain
+   USE phycst          ! physical constants
+   USE sbc_oce         ! Surface boundary condition: ocean fields
+   USE sbcwave, ONLY   :  cdn_wave ! wave module
+#if defined key_si3 || defined key_cice
+   USE sbc_ice         ! Surface boundary condition: ice fields
+#endif
+   !
+   USE iom             ! I/O manager library
+   USE lib_mpp         ! distribued memory computing library
+   USE in_out_manager  ! I/O manager
+   USE prtctl          ! Print control
+   USE lib_fortran     ! to use key_nosignedzero
+
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC ::   TURB_NCAR   ! called by sbcblk.F90
+
+   !                              ! NCAR own values for given constants:
+   REAL(wp), PARAMETER ::   rctv0 = 0.608   ! constant to obtain virtual temperature...
+   
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE turb_ncar( zt, zu, sst, t_zt, ssq, q_zt, U_zu, &
+      &                  Cd, Ch, Ce, t_zu, q_zu, U_blk,      &
+      &                  Cdn, Chn, Cen                       )
+      !!----------------------------------------------------------------------------------
+      !!                      ***  ROUTINE  turb_ncar  ***
+      !!
+      !! ** Purpose :   Computes turbulent transfert coefficients of surface
+      !!                fluxes according to Large & Yeager (2004) and Large & Yeager (2008)
+      !!                If relevant (zt /= zu), adjust temperature and humidity from height zt to zu
+      !!                Returns the effective bulk wind speed at 10m to be used in the bulk formulas
+      !!
+      !! ** Method : Monin Obukhov Similarity Theory
+      !!             + Large & Yeager (2004,2008) closure: CD_n10 = f(U_n10)
+      !!
+      !! ** References :   Large & Yeager, 2004 / Large & Yeager, 2008
+      !!
+      !! ** Last update: Laurent Brodeau, June 2014:
+      !!    - handles both cases zt=zu and zt/=zu
+      !!    - optimized: less 2D arrays allocated and less operations
+      !!    - better first guess of stability by checking air-sea difference of virtual temperature
+      !!       rather than temperature difference only...
+      !!    - added function "cd_neutral_10m" that uses the improved parametrization of
+      !!      Large & Yeager 2008. Drag-coefficient reduction for Cyclone conditions!
+      !!    - using code-wide physical constants defined into "phycst.mod" rather than redifining them
+      !!      => 'vkarmn' and 'grav'
+      !!
+      !! ** Author: L. Brodeau, june 2016 / AeroBulk (https://sourceforge.net/p/aerobulk)
+      !!
+      !! INPUT :
+      !! -------
+      !!    *  zt   : height for temperature and spec. hum. of air            [m]
+      !!    *  zu   : height for wind speed (generally 10m)                   [m]
+      !!    *  U_zu : scalar wind speed at 10m                                [m/s]
+      !!    *  sst  : SST                                                     [K]
+      !!    *  t_zt : potential air temperature at zt                         [K]
+      !!    *  ssq  : specific humidity at saturation at SST                  [kg/kg]
+      !!    *  q_zt : specific humidity of air at zt                          [kg/kg]
+      !!
+      !!
+      !! OUTPUT :
+      !! --------
+      !!    *  Cd     : drag coefficient
+      !!    *  Ch     : sensible heat coefficient
+      !!    *  Ce     : evaporation coefficient
+      !!    *  t_zu   : pot. air temperature adjusted at wind height zu       [K]
+      !!    *  q_zu   : specific humidity of air        //                    [kg/kg]
+      !!    *  U_blk  : bulk wind at 10m                                      [m/s]
+      !!----------------------------------------------------------------------------------
+      REAL(wp), INTENT(in   )                     ::   zt       ! height for t_zt and q_zt                    [m]
+      REAL(wp), INTENT(in   )                     ::   zu       ! height for U_zu                             [m]
+      REAL(wp), INTENT(in   ), DIMENSION(jpi,jpj) ::   sst      ! sea surface temperature                [Kelvin]
+      REAL(wp), INTENT(in   ), DIMENSION(jpi,jpj) ::   t_zt     ! potential air temperature              [Kelvin]
+      REAL(wp), INTENT(in   ), DIMENSION(jpi,jpj) ::   ssq      ! sea surface specific humidity           [kg/kg]
+      REAL(wp), INTENT(in   ), DIMENSION(jpi,jpj) ::   q_zt     ! specific air humidity                   [kg/kg]
+      REAL(wp), INTENT(in   ), DIMENSION(jpi,jpj) ::   U_zu     ! relative wind module at zu                [m/s]
+      REAL(wp), INTENT(  out), DIMENSION(jpi,jpj) ::   Cd       ! transfer coefficient for momentum         (tau)
+      REAL(wp), INTENT(  out), DIMENSION(jpi,jpj) ::   Ch       ! transfer coefficient for sensible heat (Q_sens)
+      REAL(wp), INTENT(  out), DIMENSION(jpi,jpj) ::   Ce       ! transfert coefficient for evaporation   (Q_lat)
+      REAL(wp), INTENT(  out), DIMENSION(jpi,jpj) ::   t_zu     ! pot. air temp. adjusted at zu               [K]
+      REAL(wp), INTENT(  out), DIMENSION(jpi,jpj) ::   q_zu     ! spec. humidity adjusted at zu           [kg/kg]
+      REAL(wp), INTENT(  out), DIMENSION(jpi,jpj) ::   U_blk    ! bulk wind at 10m                          [m/s]
+      REAL(wp), INTENT(  out), DIMENSION(jpi,jpj) ::   Cdn, Chn, Cen ! neutral transfer coefficients
+      !
+      INTEGER ::   j_itt
+      LOGICAL ::   l_zt_equal_zu = .FALSE.      ! if q and t are given at same height as U
+      INTEGER , PARAMETER ::   nb_itt = 4       ! number of itterations
+      !
+      REAL(wp), DIMENSION(jpi,jpj) ::   Cx_n10        ! 10m neutral latent/sensible coefficient
+      REAL(wp), DIMENSION(jpi,jpj) ::   sqrt_Cd_n10   ! root square of Cd_n10
+      REAL(wp), DIMENSION(jpi,jpj) ::   zeta_u        ! stability parameter at height zu
+      REAL(wp), DIMENSION(jpi,jpj) ::   zpsi_h_u
+      REAL(wp), DIMENSION(jpi,jpj) ::   ztmp0, ztmp1, ztmp2
+      REAL(wp), DIMENSION(jpi,jpj) ::   stab          ! stability test integer
+      !!----------------------------------------------------------------------------------
+      !
+      l_zt_equal_zu = .FALSE.
+      IF( ABS(zu - zt) < 0.01 ) l_zt_equal_zu = .TRUE.    ! testing "zu == zt" is risky with double precision
+
+      U_blk = MAX( 0.5 , U_zu )   !  relative wind speed at zu (normally 10m), we don't want to fall under 0.5 m/s
+
+      !! First guess of stability:
+      ztmp0 = t_zt*(1. + rctv0*q_zt) - sst*(1. + rctv0*ssq) ! air-sea difference of virtual pot. temp. at zt
+      stab  = 0.5 + sign(0.5,ztmp0)                           ! stab = 1 if dTv > 0  => STABLE, 0 if unstable
+
+      !! Neutral coefficients at 10m:
+      IF( ln_cdgw ) THEN      ! wave drag case
+         cdn_wave(:,:) = cdn_wave(:,:) + rsmall * ( 1._wp - tmask(:,:,1) )
+         ztmp0   (:,:) = cdn_wave(:,:)
+      ELSE
+         ztmp0 = cd_neutral_10m( U_blk )
+      ENDIF
+
+      sqrt_Cd_n10 = SQRT( ztmp0 )
+
+      !! Initializing transf. coeff. with their first guess neutral equivalents :
+      Cd = ztmp0
+      Ce = 1.e-3*( 34.6 * sqrt_Cd_n10 )
+      Ch = 1.e-3*sqrt_Cd_n10*(18.*stab + 32.7*(1. - stab))
+      stab = sqrt_Cd_n10   ! Temporaty array !!! stab == SQRT(Cd)
+
+      !! Initializing values at z_u with z_t values:
+      t_zu = t_zt   ;   q_zu = q_zt
+
+      !!  * Now starting iteration loop
+      DO j_itt=1, nb_itt
+         !
+         ztmp1 = t_zu - sst   ! Updating air/sea differences
+         ztmp2 = q_zu - ssq
+
+         ! Updating turbulent scales :   (L&Y 2004 eq. (7))
+         ztmp1  = Ch/stab*ztmp1    ! theta*   (stab == SQRT(Cd))
+         ztmp2  = Ce/stab*ztmp2    ! q*       (stab == SQRT(Cd))
+
+         ztmp0 = 1. + rctv0*q_zu      ! multiply this with t and you have the virtual temperature
+
+         ! Estimate the inverse of Monin-Obukov length (1/L) at height zu:
+         ztmp0 =  (grav*vkarmn/(t_zu*ztmp0)*(ztmp1*ztmp0 + rctv0*t_zu*ztmp2)) / (Cd*U_blk*U_blk)
+         !                                                      ( Cd*U_blk*U_blk is U*^2 at zu )
+
+         !! Stability parameters :
+         zeta_u   = zu*ztmp0   ;  zeta_u = sign( min(abs(zeta_u),10.0), zeta_u )
+         zpsi_h_u = psi_h( zeta_u )
+
+         !! Shifting temperature and humidity at zu (L&Y 2004 eq. (9b-9c))
+         IF( .NOT. l_zt_equal_zu ) THEN
+            !! Array 'stab' is free for the moment so using it to store 'zeta_t'
+            stab = zt*ztmp0 ;  stab = SIGN( MIN(ABS(stab),10.0), stab )  ! Temporaty array stab == zeta_t !!!
+            stab = LOG(zt/zu) + zpsi_h_u - psi_h(stab)                   ! stab just used as temp array again!
+            t_zu = t_zt - ztmp1/vkarmn*stab    ! ztmp1 is still theta*  L&Y 2004 eq.(9b)
+            q_zu = q_zt - ztmp2/vkarmn*stab    ! ztmp2 is still q*      L&Y 2004 eq.(9c)
+            q_zu = max(0., q_zu)
+         END IF
+
+         ztmp2 = psi_m(zeta_u)
+         IF( ln_cdgw ) THEN      ! surface wave case
+            stab = vkarmn / ( vkarmn / sqrt_Cd_n10 - ztmp2 )  ! (stab == SQRT(Cd))
+            Cd      = stab * stab
+         ELSE
+            ! Update neutral wind speed at 10m and neutral Cd at 10m (L&Y 2004 eq. 9a)...
+            !   In very rare low-wind conditions, the old way of estimating the
+            !   neutral wind speed at 10m leads to a negative value that causes the code
+            !   to crash. To prevent this a threshold of 0.25m/s is imposed.
+            ztmp0 = MAX( 0.25 , U_blk/(1. + sqrt_Cd_n10/vkarmn*(LOG(zu/10.) - ztmp2)) ) ! U_n10 (ztmp2 == psi_m(zeta_u))
+            ztmp0 = cd_neutral_10m(ztmp0)                                               ! Cd_n10
+            Cdn(:,:) = ztmp0
+            sqrt_Cd_n10 = sqrt(ztmp0)
+
+            stab    = 0.5 + sign(0.5,zeta_u)                           ! update stability
+            Cx_n10  = 1.e-3*sqrt_Cd_n10*(18.*stab + 32.7*(1. - stab))  ! L&Y 2004 eq. (6c-6d)    (Cx_n10 == Ch_n10)
+            Chn(:,:) = Cx_n10
+
+            !! Update of transfer coefficients:
+            ztmp1 = 1. + sqrt_Cd_n10/vkarmn*(LOG(zu/10.) - ztmp2)   ! L&Y 2004 eq. (10a) (ztmp2 == psi_m(zeta_u))
+            Cd      = ztmp0 / ( ztmp1*ztmp1 )
+            stab = SQRT( Cd ) ! Temporary array !!! (stab == SQRT(Cd))
+         ENDIF
+
+         ztmp0 = (LOG(zu/10.) - zpsi_h_u) / vkarmn / sqrt_Cd_n10
+         ztmp2 = stab / sqrt_Cd_n10   ! (stab == SQRT(Cd))
+         ztmp1 = 1. + Cx_n10*ztmp0    ! (Cx_n10 == Ch_n10)
+         Ch  = Cx_n10*ztmp2 / ztmp1   ! L&Y 2004 eq. (10b)
+
+         Cx_n10  = 1.e-3 * (34.6 * sqrt_Cd_n10)  ! L&Y 2004 eq. (6b)    ! Cx_n10 == Ce_n10
+         Cen(:,:) = Cx_n10
+         ztmp1 = 1. + Cx_n10*ztmp0
+         Ce  = Cx_n10*ztmp2 / ztmp1  ! L&Y 2004 eq. (10c)
+         !
+      END DO
+      !
+   END SUBROUTINE turb_ncar
+
+
+   FUNCTION cd_neutral_10m( pw10 )
+      !!----------------------------------------------------------------------------------      
+      !! Estimate of the neutral drag coefficient at 10m as a function
+      !! of neutral wind  speed at 10m
+      !!
+      !! Origin: Large & Yeager 2008 eq.(11a) and eq.(11b)
+      !!
+      !! ** Author: L. Brodeau, june 2016 / AeroBulk (https://sourceforge.net/p/aerobulk)
+      !!----------------------------------------------------------------------------------
+      REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pw10           ! scalar wind speed at 10m (m/s)
+      REAL(wp), DIMENSION(jpi,jpj)             :: cd_neutral_10m
+      !
+      INTEGER  ::     ji, jj     ! dummy loop indices
+      REAL(wp) :: zgt33, zw, zw6 ! local scalars
+      !!----------------------------------------------------------------------------------
+      !
+      DO jj = 1, jpj
+         DO ji = 1, jpi
+            !
+            zw  = pw10(ji,jj)
+            zw6 = zw*zw*zw
+            zw6 = zw6*zw6
+            !
+            ! When wind speed > 33 m/s => Cyclone conditions => special treatment
+            zgt33 = 0.5 + SIGN( 0.5, (zw - 33.) )   ! If pw10 < 33. => 0, else => 1
+            !
+            cd_neutral_10m(ji,jj) = 1.e-3 * ( &
+               &       (1. - zgt33)*( 2.7/zw + 0.142 + zw/13.09 - 3.14807E-10*zw6) & ! wind <  33 m/s
+               &      +    zgt33   *      2.34 )                                     ! wind >= 33 m/s
+            !
+            cd_neutral_10m(ji,jj) = MAX(cd_neutral_10m(ji,jj), 1.E-6)
+            !
+         END DO
+      END DO
+      !
+   END FUNCTION cd_neutral_10m
+
+
+   FUNCTION psi_m( pzeta )
+      !!----------------------------------------------------------------------------------
+      !! Universal profile stability function for momentum
+      !!    !! Psis, L&Y 2004 eq. (8c), (8d), (8e)
+      !!     
+      !! pzet0 : stability paramenter, z/L where z is altitude measurement                                          
+      !!         and L is M-O length
+      !!
+      !! ** Author: L. Brodeau, june 2016 / AeroBulk (https://sourceforge.net/p/aerobulk)
+      !!----------------------------------------------------------------------------------
+      REAL(wp), DIMENSION(jpi,jpj), INTENT(in) ::   pzeta
+      REAL(wp), DIMENSION(jpi,jpj)             ::   psi_m
+      !
+      INTEGER  ::   ji, jj         ! dummy loop indices
+      REAL(wp) :: zx2, zx, zstab   ! local scalars
+      !!----------------------------------------------------------------------------------
+      !
+      DO jj = 1, jpj
+         DO ji = 1, jpi
+            zx2 = SQRT( ABS( 1. - 16.*pzeta(ji,jj) ) )
+            zx2 = MAX ( zx2 , 1. )
+            zx  = SQRT( zx2 )
+            zstab = 0.5 + SIGN( 0.5 , pzeta(ji,jj) )
+            !
+            psi_m(ji,jj) =        zstab  * (-5.*pzeta(ji,jj))       &          ! Stable
+               &          + (1. - zstab) * (2.*LOG((1. + zx)*0.5)   &          ! Unstable
+               &               + LOG((1. + zx2)*0.5) - 2.*ATAN(zx) + rpi*0.5)  !    "
+            !
+         END DO
+      END DO
+      !
+   END FUNCTION psi_m
+
+
+   FUNCTION psi_h( pzeta )
+      !!----------------------------------------------------------------------------------
+      !! Universal profile stability function for temperature and humidity
+      !!    !! Psis, L&Y 2004 eq. (8c), (8d), (8e)
+      !!
+      !! pzet0 : stability paramenter, z/L where z is altitude measurement                                          
+      !!         and L is M-O length
+      !!
+      !! ** Author: L. Brodeau, june 2016 / AeroBulk (https://sourceforge.net/p/aerobulk)
+      !!----------------------------------------------------------------------------------
+      REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pzeta
+      REAL(wp), DIMENSION(jpi,jpj)             :: psi_h
+      !
+      INTEGER  ::   ji, jj    ! dummy loop indices
+      REAL(wp) :: zx2, zstab  ! local scalars
+      !!----------------------------------------------------------------------------------
+      !
+      DO jj = 1, jpj
+         DO ji = 1, jpi
+            zx2 = SQRT( ABS( 1. - 16.*pzeta(ji,jj) ) )
+            zx2 = MAX ( zx2 , 1. )
+            zstab = 0.5 + SIGN( 0.5 , pzeta(ji,jj) )
+            !
+            psi_h(ji,jj) =         zstab  * (-5.*pzeta(ji,jj))        &  ! Stable
+               &           + (1. - zstab) * (2.*LOG( (1. + zx2)*0.5 ))   ! Unstable
+            !
+         END DO
+      END DO
+      !
+   END FUNCTION psi_h
+
+   !!======================================================================
+END MODULE sbcblk_algo_ncar
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/SBC/sbccpl.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/SBC/sbccpl.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/SBC/sbccpl.F90	(revision 9570)
@@ -0,0 +1,2699 @@
+MODULE sbccpl
+   !!======================================================================
+   !!                       ***  MODULE  sbccpl  ***
+   !! Surface Boundary Condition :  momentum, heat and freshwater fluxes in coupled mode
+   !!======================================================================
+   !! History :  2.0  ! 2007-06  (R. Redler, N. Keenlyside, W. Park) Original code split into flxmod & taumod
+   !!            3.0  ! 2008-02  (G. Madec, C Talandier)  surface module
+   !!            3.1  ! 2009_02  (G. Madec, S. Masson, E. Maisonave, A. Caubel) generic coupled interface
+   !!            3.4  ! 2011_11  (C. Harris) more flexibility + multi-category fields
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   namsbc_cpl      : coupled formulation namlist
+   !!   sbc_cpl_init    : initialisation of the coupled exchanges
+   !!   sbc_cpl_rcv     : receive fields from the atmosphere over the ocean (ocean only)
+   !!                     receive stress from the atmosphere over the ocean (ocean-ice case)
+   !!   sbc_cpl_ice_tau : receive stress from the atmosphere over ice
+   !!   sbc_cpl_ice_flx : receive fluxes from the atmosphere over ice
+   !!   sbc_cpl_snd     : send     fields to the atmosphere
+   !!----------------------------------------------------------------------
+   USE dom_oce         ! ocean space and time domain
+   USE sbc_oce         ! Surface boundary condition: ocean fields
+   USE trc_oce         ! share SMS/Ocean variables
+   USE sbc_ice         ! Surface boundary condition: ice fields
+   USE sbcapr          ! Stochastic param. : ???
+   USE sbcdcy          ! surface boundary condition: diurnal cycle
+   USE sbcwave         ! surface boundary condition: waves
+   USE phycst          ! physical constants
+#if defined key_si3
+   USE ice            ! ice variables
+#endif
+   USE cpl_oasis3     ! OASIS3 coupling
+   USE geo2ocean      ! 
+   USE oce     , ONLY : tsn, un, vn, sshn, ub, vb, sshb, fraqsr_1lev
+   USE ocealb         ! 
+   USE eosbn2         ! 
+   USE sbcrnf  , ONLY : l_rnfcpl
+   USE sbcisf  , ONLY : l_isfcpl
+#if defined key_cice
+   USE ice_domain_size, only: ncat
+#endif
+#if defined key_si3
+   USE icethd_dh      ! for CALL ice_thd_snwblow
+#endif
+   !
+   USE in_out_manager ! I/O manager
+   USE iom            ! NetCDF library
+   USE lib_mpp        ! distribued memory computing library
+   USE lbclnk         ! ocean lateral boundary conditions (or mpp link)
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   sbc_cpl_init      ! routine called by sbcmod.F90
+   PUBLIC   sbc_cpl_rcv       ! routine called by icestp.F90
+   PUBLIC   sbc_cpl_snd       ! routine called by step.F90
+   PUBLIC   sbc_cpl_ice_tau   ! routine called by icestp.F90
+   PUBLIC   sbc_cpl_ice_flx   ! routine called by icestp.F90
+   PUBLIC   sbc_cpl_alloc     ! routine called in sbcice_cice.F90
+
+   INTEGER, PARAMETER ::   jpr_otx1   =  1   ! 3 atmosphere-ocean stress components on grid 1
+   INTEGER, PARAMETER ::   jpr_oty1   =  2   ! 
+   INTEGER, PARAMETER ::   jpr_otz1   =  3   ! 
+   INTEGER, PARAMETER ::   jpr_otx2   =  4   ! 3 atmosphere-ocean stress components on grid 2
+   INTEGER, PARAMETER ::   jpr_oty2   =  5   ! 
+   INTEGER, PARAMETER ::   jpr_otz2   =  6   ! 
+   INTEGER, PARAMETER ::   jpr_itx1   =  7   ! 3 atmosphere-ice   stress components on grid 1
+   INTEGER, PARAMETER ::   jpr_ity1   =  8   ! 
+   INTEGER, PARAMETER ::   jpr_itz1   =  9   ! 
+   INTEGER, PARAMETER ::   jpr_itx2   = 10   ! 3 atmosphere-ice   stress components on grid 2
+   INTEGER, PARAMETER ::   jpr_ity2   = 11   ! 
+   INTEGER, PARAMETER ::   jpr_itz2   = 12   ! 
+   INTEGER, PARAMETER ::   jpr_qsroce = 13   ! Qsr above the ocean
+   INTEGER, PARAMETER ::   jpr_qsrice = 14   ! Qsr above the ice
+   INTEGER, PARAMETER ::   jpr_qsrmix = 15 
+   INTEGER, PARAMETER ::   jpr_qnsoce = 16   ! Qns above the ocean
+   INTEGER, PARAMETER ::   jpr_qnsice = 17   ! Qns above the ice
+   INTEGER, PARAMETER ::   jpr_qnsmix = 18
+   INTEGER, PARAMETER ::   jpr_rain   = 19   ! total liquid precipitation (rain)
+   INTEGER, PARAMETER ::   jpr_snow   = 20   ! solid precipitation over the ocean (snow)
+   INTEGER, PARAMETER ::   jpr_tevp   = 21   ! total evaporation
+   INTEGER, PARAMETER ::   jpr_ievp   = 22   ! solid evaporation (sublimation)
+   INTEGER, PARAMETER ::   jpr_sbpr   = 23   ! sublimation - liquid precipitation - solid precipitation
+   INTEGER, PARAMETER ::   jpr_semp   = 24   ! solid freshwater budget (sublimation - snow)
+   INTEGER, PARAMETER ::   jpr_oemp   = 25   ! ocean freshwater budget (evap - precip)
+   INTEGER, PARAMETER ::   jpr_w10m   = 26   ! 10m wind
+   INTEGER, PARAMETER ::   jpr_dqnsdt = 27   ! d(Q non solar)/d(temperature)
+   INTEGER, PARAMETER ::   jpr_rnf    = 28   ! runoffs
+   INTEGER, PARAMETER ::   jpr_cal    = 29   ! calving
+   INTEGER, PARAMETER ::   jpr_taum   = 30   ! wind stress module
+   INTEGER, PARAMETER ::   jpr_co2    = 31
+   INTEGER, PARAMETER ::   jpr_topm   = 32   ! topmeltn
+   INTEGER, PARAMETER ::   jpr_botm   = 33   ! botmeltn
+   INTEGER, PARAMETER ::   jpr_sflx   = 34   ! salt flux
+   INTEGER, PARAMETER ::   jpr_toce   = 35   ! ocean temperature
+   INTEGER, PARAMETER ::   jpr_soce   = 36   ! ocean salinity
+   INTEGER, PARAMETER ::   jpr_ocx1   = 37   ! ocean current on grid 1
+   INTEGER, PARAMETER ::   jpr_ocy1   = 38   !
+   INTEGER, PARAMETER ::   jpr_ssh    = 39   ! sea surface height
+   INTEGER, PARAMETER ::   jpr_fice   = 40   ! ice fraction          
+   INTEGER, PARAMETER ::   jpr_e3t1st = 41   ! first T level thickness 
+   INTEGER, PARAMETER ::   jpr_fraqsr = 42   ! fraction of solar net radiation absorbed in the first ocean level
+   INTEGER, PARAMETER ::   jpr_mslp   = 43   ! mean sea level pressure 
+   INTEGER, PARAMETER ::   jpr_hsig   = 44   ! Hsig 
+   INTEGER, PARAMETER ::   jpr_phioc  = 45   ! Wave=>ocean energy flux 
+   INTEGER, PARAMETER ::   jpr_sdrftx = 46   ! Stokes drift on grid 1 
+   INTEGER, PARAMETER ::   jpr_sdrfty = 47   ! Stokes drift on grid 2 
+   INTEGER, PARAMETER ::   jpr_wper   = 48   ! Mean wave period
+   INTEGER, PARAMETER ::   jpr_wnum   = 49   ! Mean wavenumber
+   INTEGER, PARAMETER ::   jpr_tauwoc = 50   ! Stress fraction adsorbed by waves
+   INTEGER, PARAMETER ::   jpr_wdrag  = 51   ! Neutral surface drag coefficient
+   INTEGER, PARAMETER ::   jpr_isf    = 52
+   INTEGER, PARAMETER ::   jpr_icb    = 53
+   INTEGER, PARAMETER ::   jpr_wfreq  = 54   ! Wave peak frequency
+   INTEGER, PARAMETER ::   jpr_tauwx  = 55   ! x component of the ocean stress from waves
+   INTEGER, PARAMETER ::   jpr_tauwy  = 56   ! y component of the ocean stress from waves
+   INTEGER, PARAMETER ::   jpr_ts_ice = 57   ! Sea ice surface temp
+
+   INTEGER, PARAMETER ::   jprcv      = 57   ! total number of fields received  
+
+   INTEGER, PARAMETER ::   jps_fice   =  1   ! ice fraction sent to the atmosphere
+   INTEGER, PARAMETER ::   jps_toce   =  2   ! ocean temperature
+   INTEGER, PARAMETER ::   jps_tice   =  3   ! ice   temperature
+   INTEGER, PARAMETER ::   jps_tmix   =  4   ! mixed temperature (ocean+ice)
+   INTEGER, PARAMETER ::   jps_albice =  5   ! ice   albedo
+   INTEGER, PARAMETER ::   jps_albmix =  6   ! mixed albedo
+   INTEGER, PARAMETER ::   jps_hice   =  7   ! ice  thickness
+   INTEGER, PARAMETER ::   jps_hsnw   =  8   ! snow thickness
+   INTEGER, PARAMETER ::   jps_ocx1   =  9   ! ocean current on grid 1
+   INTEGER, PARAMETER ::   jps_ocy1   = 10   !
+   INTEGER, PARAMETER ::   jps_ocz1   = 11   !
+   INTEGER, PARAMETER ::   jps_ivx1   = 12   ! ice   current on grid 1
+   INTEGER, PARAMETER ::   jps_ivy1   = 13   !
+   INTEGER, PARAMETER ::   jps_ivz1   = 14   !
+   INTEGER, PARAMETER ::   jps_co2    = 15
+   INTEGER, PARAMETER ::   jps_soce   = 16   ! ocean salinity
+   INTEGER, PARAMETER ::   jps_ssh    = 17   ! sea surface height
+   INTEGER, PARAMETER ::   jps_qsroce = 18   ! Qsr above the ocean
+   INTEGER, PARAMETER ::   jps_qnsoce = 19   ! Qns above the ocean
+   INTEGER, PARAMETER ::   jps_oemp   = 20   ! ocean freshwater budget (evap - precip)
+   INTEGER, PARAMETER ::   jps_sflx   = 21   ! salt flux
+   INTEGER, PARAMETER ::   jps_otx1   = 22   ! 2 atmosphere-ocean stress components on grid 1
+   INTEGER, PARAMETER ::   jps_oty1   = 23   ! 
+   INTEGER, PARAMETER ::   jps_rnf    = 24   ! runoffs
+   INTEGER, PARAMETER ::   jps_taum   = 25   ! wind stress module
+   INTEGER, PARAMETER ::   jps_fice2  = 26   ! ice fraction sent to OPA (by SAS when doing SAS-OPA coupling)
+   INTEGER, PARAMETER ::   jps_e3t1st = 27   ! first level depth (vvl)
+   INTEGER, PARAMETER ::   jps_fraqsr = 28   ! fraction of solar net radiation absorbed in the first ocean level
+   INTEGER, PARAMETER ::   jps_ficet  = 29   ! total ice fraction  
+   INTEGER, PARAMETER ::   jps_ocxw   = 30   ! currents on grid 1  
+   INTEGER, PARAMETER ::   jps_ocyw   = 31   ! currents on grid 2
+   INTEGER, PARAMETER ::   jps_wlev   = 32   ! water level 
+   INTEGER, PARAMETER ::   jps_fice1  = 33   ! first-order ice concentration (for semi-implicit coupling of atmos-ice fluxes)
+   INTEGER, PARAMETER ::   jps_a_p    = 34   ! meltpond area
+   INTEGER, PARAMETER ::   jps_ht_p   = 35   ! meltpond thickness
+   INTEGER, PARAMETER ::   jps_kice   = 36   ! sea ice effective conductivity
+   INTEGER, PARAMETER ::   jps_sstfrz = 37   ! sea surface freezing temperature
+   INTEGER, PARAMETER ::   jps_ttilyr = 38   ! sea ice top layer temp
+
+   INTEGER, PARAMETER ::   jpsnd      = 38   ! total number of fields sent 
+
+   !                                  !!** namelist namsbc_cpl **
+   TYPE ::   FLD_C                     !   
+      CHARACTER(len = 32) ::   cldes      ! desciption of the coupling strategy
+      CHARACTER(len = 32) ::   clcat      ! multiple ice categories strategy
+      CHARACTER(len = 32) ::   clvref     ! reference of vector ('spherical' or 'cartesian')
+      CHARACTER(len = 32) ::   clvor      ! orientation of vector fields ('eastward-northward' or 'local grid')
+      CHARACTER(len = 32) ::   clvgrd     ! grids on which is located the vector fields
+   END TYPE FLD_C
+   !                                   ! Send to the atmosphere  
+   TYPE(FLD_C) ::   sn_snd_temp  , sn_snd_alb , sn_snd_thick, sn_snd_crt   , sn_snd_co2,  &
+      &             sn_snd_thick1, sn_snd_cond, sn_snd_mpnd , sn_snd_sstfrz, sn_snd_ttilyr
+   !                                   ! Received from the atmosphere
+   TYPE(FLD_C) ::   sn_rcv_w10m, sn_rcv_taumod, sn_rcv_tau, sn_rcv_tauw, sn_rcv_dqnsdt, sn_rcv_qsr,  &
+      &             sn_rcv_qns , sn_rcv_emp   , sn_rcv_rnf, sn_rcv_ts_ice
+   TYPE(FLD_C) ::   sn_rcv_cal, sn_rcv_iceflx, sn_rcv_co2, sn_rcv_mslp, sn_rcv_icb, sn_rcv_isf
+   ! Send to waves 
+   TYPE(FLD_C) ::   sn_snd_ifrac, sn_snd_crtw, sn_snd_wlev 
+   ! Received from waves 
+   TYPE(FLD_C) ::   sn_rcv_hsig, sn_rcv_phioc, sn_rcv_sdrfx, sn_rcv_sdrfy, sn_rcv_wper, sn_rcv_wnum, sn_rcv_tauwoc, &
+                    sn_rcv_wdrag, sn_rcv_wfreq
+   !                                   ! Other namelist parameters
+   INTEGER     ::   nn_cplmodel           ! Maximum number of models to/from which NEMO is potentialy sending/receiving data
+   LOGICAL     ::   ln_usecplmask         !  use a coupling mask file to merge data received from several models
+                                          !   -> file cplmask.nc with the float variable called cplmask (jpi,jpj,nn_cplmodel)
+   TYPE ::   DYNARR     
+      REAL(wp), POINTER, DIMENSION(:,:,:) ::   z3   
+   END TYPE DYNARR
+
+   TYPE( DYNARR ), SAVE, DIMENSION(jprcv) ::   frcv                ! all fields recieved from the atmosphere
+
+   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   alb_oce_mix    ! ocean albedo sent to atmosphere (mix clear/overcast sky)
+
+   REAL(wp) ::   rpref = 101000._wp   ! reference atmospheric pressure[N/m2] 
+   REAL(wp) ::   r1_grau              ! = 1.e0 / (grav * rau0) 
+
+   INTEGER , ALLOCATABLE, SAVE, DIMENSION(:) ::   nrcvinfo           ! OASIS info argument
+
+   !! Substitution
+#  include "vectopt_loop_substitute.h90"
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO Consortium (2010)
+   !! $Id$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+  
+   INTEGER FUNCTION sbc_cpl_alloc()
+      !!----------------------------------------------------------------------
+      !!             ***  FUNCTION sbc_cpl_alloc  ***
+      !!----------------------------------------------------------------------
+      INTEGER :: ierr(4)
+      !!----------------------------------------------------------------------
+      ierr(:) = 0
+      !
+      ALLOCATE( alb_oce_mix(jpi,jpj), nrcvinfo(jprcv),  STAT=ierr(1) )
+      
+#if ! defined key_si3 && ! defined key_cice
+      ALLOCATE( a_i(jpi,jpj,1) , STAT=ierr(2) )  ! used in sbcice_if.F90 (done here as there is no sbc_ice_if_init)
+#endif
+      ALLOCATE( xcplmask(jpi,jpj,0:nn_cplmodel) , STAT=ierr(3) )
+      !
+      IF( .NOT. ln_apr_dyn ) ALLOCATE( ssh_ib(jpi,jpj), ssh_ibb(jpi,jpj), apr(jpi, jpj), STAT=ierr(4) ) 
+
+      sbc_cpl_alloc = MAXVAL( ierr )
+      IF( lk_mpp            )   CALL mpp_sum ( sbc_cpl_alloc )
+      IF( sbc_cpl_alloc > 0 )   CALL ctl_warn('sbc_cpl_alloc: allocation of arrays failed')
+      !
+   END FUNCTION sbc_cpl_alloc
+
+
+   SUBROUTINE sbc_cpl_init( k_ice )     
+      !!----------------------------------------------------------------------
+      !!             ***  ROUTINE sbc_cpl_init  ***
+      !!
+      !! ** Purpose :   Initialisation of send and received information from
+      !!                the atmospheric component
+      !!
+      !! ** Method  : * Read namsbc_cpl namelist 
+      !!              * define the receive interface
+      !!              * define the send    interface
+      !!              * initialise the OASIS coupler
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT(in) ::   k_ice   ! ice management in the sbc (=0/1/2/3)
+      !
+      INTEGER ::   jn          ! dummy loop index
+      INTEGER ::   ios, inum   ! Local integer
+      REAL(wp), DIMENSION(jpi,jpj) ::   zacs, zaos
+      !!
+      NAMELIST/namsbc_cpl/  sn_snd_temp  , sn_snd_alb   , sn_snd_thick, sn_snd_crt   , sn_snd_co2  ,   & 
+         &                  sn_rcv_w10m  , sn_rcv_taumod, sn_rcv_tau  , sn_rcv_dqnsdt, sn_rcv_qsr  ,   & 
+         &                  sn_snd_ifrac , sn_snd_crtw  , sn_snd_wlev , sn_rcv_hsig  , sn_rcv_phioc,   & 
+         &                  sn_rcv_sdrfx , sn_rcv_sdrfy , sn_rcv_wper , sn_rcv_wnum  , sn_rcv_tauwoc,   &
+         &                  sn_rcv_wdrag , sn_rcv_qns   , sn_rcv_emp  , sn_rcv_rnf   , sn_rcv_cal  ,   &
+         &                  sn_rcv_iceflx, sn_rcv_co2   , nn_cplmodel , ln_usecplmask, sn_rcv_mslp ,   &
+         &                  sn_rcv_icb   , sn_rcv_isf   , sn_rcv_wfreq , sn_rcv_tauw, nn_cats_cpl  
+
+      !!---------------------------------------------------------------------
+      !
+      ! ================================ !
+      !      Namelist informations       !
+      ! ================================ !
+      !
+      REWIND( numnam_ref )              ! Namelist namsbc_cpl in reference namelist : Variables for OASIS coupling
+      READ  ( numnam_ref, namsbc_cpl, IOSTAT = ios, ERR = 901)
+901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namsbc_cpl in reference namelist', lwp )
+      !
+      REWIND( numnam_cfg )              ! Namelist namsbc_cpl in configuration namelist : Variables for OASIS coupling
+      READ  ( numnam_cfg, namsbc_cpl, IOSTAT = ios, ERR = 902 )
+902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namsbc_cpl in configuration namelist', lwp )
+      IF(lwm) WRITE ( numond, namsbc_cpl )
+      !
+      IF(lwp) THEN                        ! control print
+         WRITE(numout,*)
+         WRITE(numout,*)'sbc_cpl_init : namsbc_cpl namelist '
+         WRITE(numout,*)'~~~~~~~~~~~~'
+      ENDIF
+      IF( lwp .AND. ln_cpl ) THEN                        ! control print
+         WRITE(numout,*)'  received fields (mutiple ice categogies)'
+         WRITE(numout,*)'      10m wind module                 = ', TRIM(sn_rcv_w10m%cldes  ), ' (', TRIM(sn_rcv_w10m%clcat  ), ')'
+         WRITE(numout,*)'      stress module                   = ', TRIM(sn_rcv_taumod%cldes), ' (', TRIM(sn_rcv_taumod%clcat), ')'
+         WRITE(numout,*)'      surface stress                  = ', TRIM(sn_rcv_tau%cldes   ), ' (', TRIM(sn_rcv_tau%clcat   ), ')'
+         WRITE(numout,*)'                     - referential    = ', sn_rcv_tau%clvref
+         WRITE(numout,*)'                     - orientation    = ', sn_rcv_tau%clvor
+         WRITE(numout,*)'                     - mesh           = ', sn_rcv_tau%clvgrd
+         WRITE(numout,*)'      non-solar heat flux sensitivity = ', TRIM(sn_rcv_dqnsdt%cldes), ' (', TRIM(sn_rcv_dqnsdt%clcat), ')'
+         WRITE(numout,*)'      solar heat flux                 = ', TRIM(sn_rcv_qsr%cldes   ), ' (', TRIM(sn_rcv_qsr%clcat   ), ')'
+         WRITE(numout,*)'      non-solar heat flux             = ', TRIM(sn_rcv_qns%cldes   ), ' (', TRIM(sn_rcv_qns%clcat   ), ')'
+         WRITE(numout,*)'      freshwater budget               = ', TRIM(sn_rcv_emp%cldes   ), ' (', TRIM(sn_rcv_emp%clcat   ), ')'
+         WRITE(numout,*)'      runoffs                         = ', TRIM(sn_rcv_rnf%cldes   ), ' (', TRIM(sn_rcv_rnf%clcat   ), ')'
+         WRITE(numout,*)'      calving                         = ', TRIM(sn_rcv_cal%cldes   ), ' (', TRIM(sn_rcv_cal%clcat   ), ')'
+         WRITE(numout,*)'      iceberg                         = ', TRIM(sn_rcv_icb%cldes   ), ' (', TRIM(sn_rcv_icb%clcat   ), ')'
+         WRITE(numout,*)'      ice shelf                       = ', TRIM(sn_rcv_isf%cldes   ), ' (', TRIM(sn_rcv_isf%clcat   ), ')'
+         WRITE(numout,*)'      sea ice heat fluxes             = ', TRIM(sn_rcv_iceflx%cldes), ' (', TRIM(sn_rcv_iceflx%clcat), ')'
+         WRITE(numout,*)'      atm co2                         = ', TRIM(sn_rcv_co2%cldes   ), ' (', TRIM(sn_rcv_co2%clcat   ), ')'
+         WRITE(numout,*)'      significant wave heigth         = ', TRIM(sn_rcv_hsig%cldes  ), ' (', TRIM(sn_rcv_hsig%clcat  ), ')' 
+         WRITE(numout,*)'      wave to oce energy flux         = ', TRIM(sn_rcv_phioc%cldes ), ' (', TRIM(sn_rcv_phioc%clcat ), ')' 
+         WRITE(numout,*)'      Surface Stokes drift grid u     = ', TRIM(sn_rcv_sdrfx%cldes ), ' (', TRIM(sn_rcv_sdrfx%clcat ), ')' 
+         WRITE(numout,*)'      Surface Stokes drift grid v     = ', TRIM(sn_rcv_sdrfy%cldes ), ' (', TRIM(sn_rcv_sdrfy%clcat ), ')' 
+         WRITE(numout,*)'      Mean wave period                = ', TRIM(sn_rcv_wper%cldes  ), ' (', TRIM(sn_rcv_wper%clcat  ), ')' 
+         WRITE(numout,*)'      Mean wave number                = ', TRIM(sn_rcv_wnum%cldes  ), ' (', TRIM(sn_rcv_wnum%clcat  ), ')' 
+         WRITE(numout,*)'      Wave peak frequency             = ', TRIM(sn_rcv_wfreq%cldes ), ' (', TRIM(sn_rcv_wfreq%clcat ), ')'
+         WRITE(numout,*)'      Stress frac adsorbed by waves   = ', TRIM(sn_rcv_tauwoc%cldes), ' (', TRIM(sn_rcv_tauwoc%clcat ), ')' 
+         WRITE(numout,*)'      Stress components by waves      = ', TRIM(sn_rcv_tauw%cldes  ), ' (', TRIM(sn_rcv_tauw%clcat  ), ')'
+         WRITE(numout,*)'      Neutral surf drag coefficient   = ', TRIM(sn_rcv_wdrag%cldes ), ' (', TRIM(sn_rcv_wdrag%clcat ), ')' 
+         WRITE(numout,*)'      Sea ice surface skin temperature= ', TRIM(sn_rcv_ts_ice%cldes), ' (', TRIM(sn_rcv_ts_ice%clcat), ')' 
+         WRITE(numout,*)'  sent fields (multiple ice categories)'
+         WRITE(numout,*)'      surface temperature             = ', TRIM(sn_snd_temp%cldes  ), ' (', TRIM(sn_snd_temp%clcat  ), ')'
+         WRITE(numout,*)'      top ice layer temperature       = ', TRIM(sn_snd_ttilyr%cldes), ' (', TRIM(sn_snd_ttilyr%clcat), ')'
+         WRITE(numout,*)'      albedo                          = ', TRIM(sn_snd_alb%cldes   ), ' (', TRIM(sn_snd_alb%clcat   ), ')'
+         WRITE(numout,*)'      ice/snow thickness              = ', TRIM(sn_snd_thick%cldes ), ' (', TRIM(sn_snd_thick%clcat ), ')'
+         WRITE(numout,*)'      total ice fraction              = ', TRIM(sn_snd_ifrac%cldes ), ' (', TRIM(sn_snd_ifrac%clcat ), ')' 
+         WRITE(numout,*)'      surface current                 = ', TRIM(sn_snd_crt%cldes   ), ' (', TRIM(sn_snd_crt%clcat   ), ')'
+         WRITE(numout,*)'                      - referential   = ', sn_snd_crt%clvref 
+         WRITE(numout,*)'                      - orientation   = ', sn_snd_crt%clvor
+         WRITE(numout,*)'                      - mesh          = ', sn_snd_crt%clvgrd
+         WRITE(numout,*)'      oce co2 flux                    = ', TRIM(sn_snd_co2%cldes   ), ' (', TRIM(sn_snd_co2%clcat   ), ')'
+         WRITE(numout,*)'      ice effective conductivity      = ', TRIM(sn_snd_cond%cldes  ), ' (', TRIM(sn_snd_cond%clcat  ), ')'
+         WRITE(numout,*)'      meltponds fraction and depth    = ', TRIM(sn_snd_mpnd%cldes  ), ' (', TRIM(sn_snd_mpnd%clcat  ), ')'
+         WRITE(numout,*)'      sea surface freezing temp       = ', TRIM(sn_snd_sstfrz%cldes), ' (', TRIM(sn_snd_sstfrz%clcat), ')'
+         WRITE(numout,*)'      water level                     = ', TRIM(sn_snd_wlev%cldes  ), ' (', TRIM(sn_snd_wlev%clcat  ), ')' 
+         WRITE(numout,*)'      mean sea level pressure         = ', TRIM(sn_rcv_mslp%cldes  ), ' (', TRIM(sn_rcv_mslp%clcat  ), ')' 
+         WRITE(numout,*)'      surface current to waves        = ', TRIM(sn_snd_crtw%cldes  ), ' (', TRIM(sn_snd_crtw%clcat  ), ')' 
+         WRITE(numout,*)'                      - referential   = ', sn_snd_crtw%clvref 
+         WRITE(numout,*)'                      - orientation   = ', sn_snd_crtw%clvor 
+         WRITE(numout,*)'                      - mesh          = ', sn_snd_crtw%clvgrd 
+         WRITE(numout,*)'  nn_cplmodel                         = ', nn_cplmodel
+         WRITE(numout,*)'  ln_usecplmask                       = ', ln_usecplmask
+         WRITE(numout,*)'  nn_cats_cpl                         = ', nn_cats_cpl
+      ENDIF
+
+      !                                   ! allocate sbccpl arrays
+      IF( sbc_cpl_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'sbc_cpl_alloc : unable to allocate arrays' )
+     
+      ! ================================ !
+      !   Define the receive interface   !
+      ! ================================ !
+      nrcvinfo(:) = OASIS_idle   ! needed by nrcvinfo(jpr_otx1) if we do not receive ocean stress 
+
+      ! for each field: define the OASIS name                              (srcv(:)%clname)
+      !                 define receive or not from the namelist parameters (srcv(:)%laction)
+      !                 define the north fold type of lbc                  (srcv(:)%nsgn)
+
+      ! default definitions of srcv
+      srcv(:)%laction = .FALSE.   ;   srcv(:)%clgrid = 'T'   ;   srcv(:)%nsgn = 1.   ;   srcv(:)%nct = 1
+
+      !                                                      ! ------------------------- !
+      !                                                      ! ice and ocean wind stress !   
+      !                                                      ! ------------------------- !
+      !                                                           ! Name 
+      srcv(jpr_otx1)%clname = 'O_OTaux1'      ! 1st ocean component on grid ONE (T or U)
+      srcv(jpr_oty1)%clname = 'O_OTauy1'      ! 2nd   -      -         -     - 
+      srcv(jpr_otz1)%clname = 'O_OTauz1'      ! 3rd   -      -         -     - 
+      srcv(jpr_otx2)%clname = 'O_OTaux2'      ! 1st ocean component on grid TWO (V)
+      srcv(jpr_oty2)%clname = 'O_OTauy2'      ! 2nd   -      -         -     - 
+      srcv(jpr_otz2)%clname = 'O_OTauz2'      ! 3rd   -      -         -     - 
+      !
+      srcv(jpr_itx1)%clname = 'O_ITaux1'      ! 1st  ice  component on grid ONE (T, F, I or U)
+      srcv(jpr_ity1)%clname = 'O_ITauy1'      ! 2nd   -      -         -     - 
+      srcv(jpr_itz1)%clname = 'O_ITauz1'      ! 3rd   -      -         -     - 
+      srcv(jpr_itx2)%clname = 'O_ITaux2'      ! 1st  ice  component on grid TWO (V)
+      srcv(jpr_ity2)%clname = 'O_ITauy2'      ! 2nd   -      -         -     - 
+      srcv(jpr_itz2)%clname = 'O_ITauz2'      ! 3rd   -      -         -     - 
+      ! 
+      ! Vectors: change of sign at north fold ONLY if on the local grid
+      IF( TRIM( sn_rcv_tau%cldes ) == 'oce only' .OR. TRIM(sn_rcv_tau%cldes ) == 'oce and ice') THEN ! avoid working with the atmospheric fields if they are not coupled
+      IF( TRIM( sn_rcv_tau%clvor ) == 'local grid' )   srcv(jpr_otx1:jpr_itz2)%nsgn = -1.
+      
+      !                                                           ! Set grid and action
+      SELECT CASE( TRIM( sn_rcv_tau%clvgrd ) )      !  'T', 'U,V', 'U,V,I', 'U,V,F', 'T,I', 'T,F', or 'T,U,V'
+      CASE( 'T' ) 
+         srcv(jpr_otx1:jpr_itz2)%clgrid  = 'T'        ! oce and ice components given at T-point
+         srcv(jpr_otx1:jpr_otz1)%laction = .TRUE.     ! receive oce components on grid 1 
+         srcv(jpr_itx1:jpr_itz1)%laction = .TRUE.     ! receive ice components on grid 1 
+      CASE( 'U,V' ) 
+         srcv(jpr_otx1:jpr_otz1)%clgrid  = 'U'        ! oce components given at U-point
+         srcv(jpr_otx2:jpr_otz2)%clgrid  = 'V'        !           and           V-point
+         srcv(jpr_itx1:jpr_itz1)%clgrid  = 'U'        ! ice components given at U-point
+         srcv(jpr_itx2:jpr_itz2)%clgrid  = 'V'        !           and           V-point
+         srcv(jpr_otx1:jpr_itz2)%laction = .TRUE.     ! receive oce and ice components on both grid 1 & 2
+      CASE( 'U,V,T' )
+         srcv(jpr_otx1:jpr_otz1)%clgrid  = 'U'        ! oce components given at U-point
+         srcv(jpr_otx2:jpr_otz2)%clgrid  = 'V'        !           and           V-point
+         srcv(jpr_itx1:jpr_itz1)%clgrid  = 'T'        ! ice components given at T-point
+         srcv(jpr_otx1:jpr_otz2)%laction = .TRUE.     ! receive oce components on grid 1 & 2
+         srcv(jpr_itx1:jpr_itz1)%laction = .TRUE.     ! receive ice components on grid 1 only
+      CASE( 'U,V,I' )
+         srcv(jpr_otx1:jpr_otz1)%clgrid  = 'U'        ! oce components given at U-point
+         srcv(jpr_otx2:jpr_otz2)%clgrid  = 'V'        !           and           V-point
+         srcv(jpr_itx1:jpr_itz1)%clgrid  = 'I'        ! ice components given at I-point
+         srcv(jpr_otx1:jpr_otz2)%laction = .TRUE.     ! receive oce components on grid 1 & 2
+         srcv(jpr_itx1:jpr_itz1)%laction = .TRUE.     ! receive ice components on grid 1 only
+      CASE( 'U,V,F' )
+         srcv(jpr_otx1:jpr_otz1)%clgrid  = 'U'        ! oce components given at U-point
+         srcv(jpr_otx2:jpr_otz2)%clgrid  = 'V'        !           and           V-point
+         srcv(jpr_itx1:jpr_itz1)%clgrid  = 'F'        ! ice components given at F-point
+         srcv(jpr_otx1:jpr_otz2)%laction = .TRUE.     ! receive oce components on grid 1 & 2
+         srcv(jpr_itx1:jpr_itz1)%laction = .TRUE.     ! receive ice components on grid 1 only
+      CASE( 'T,I' ) 
+         srcv(jpr_otx1:jpr_itz2)%clgrid  = 'T'        ! oce and ice components given at T-point
+         srcv(jpr_itx1:jpr_itz1)%clgrid  = 'I'        ! ice components given at I-point
+         srcv(jpr_otx1:jpr_otz1)%laction = .TRUE.     ! receive oce components on grid 1 
+         srcv(jpr_itx1:jpr_itz1)%laction = .TRUE.     ! receive ice components on grid 1 
+      CASE( 'T,F' ) 
+         srcv(jpr_otx1:jpr_itz2)%clgrid  = 'T'        ! oce and ice components given at T-point
+         srcv(jpr_itx1:jpr_itz1)%clgrid  = 'F'        ! ice components given at F-point
+         srcv(jpr_otx1:jpr_otz1)%laction = .TRUE.     ! receive oce components on grid 1 
+         srcv(jpr_itx1:jpr_itz1)%laction = .TRUE.     ! receive ice components on grid 1 
+      CASE( 'T,U,V' )
+         srcv(jpr_otx1:jpr_otz1)%clgrid  = 'T'        ! oce components given at T-point
+         srcv(jpr_itx1:jpr_itz1)%clgrid  = 'U'        ! ice components given at U-point
+         srcv(jpr_itx2:jpr_itz2)%clgrid  = 'V'        !           and           V-point
+         srcv(jpr_otx1:jpr_otz1)%laction = .TRUE.     ! receive oce components on grid 1 only
+         srcv(jpr_itx1:jpr_itz2)%laction = .TRUE.     ! receive ice components on grid 1 & 2
+      CASE default   
+         CALL ctl_stop( 'sbc_cpl_init: wrong definition of sn_rcv_tau%clvgrd' )
+      END SELECT
+      !
+      IF( TRIM( sn_rcv_tau%clvref ) == 'spherical' )   &           ! spherical: 3rd component not received
+         &     srcv( (/jpr_otz1, jpr_otz2, jpr_itz1, jpr_itz2/) )%laction = .FALSE. 
+      !
+      IF( TRIM( sn_rcv_tau%clvor  ) == 'local grid' ) THEN        ! already on local grid -> no need of the second grid
+            srcv(jpr_otx2:jpr_otz2)%laction = .FALSE. 
+            srcv(jpr_itx2:jpr_itz2)%laction = .FALSE. 
+            srcv(jpr_oty1)%clgrid = srcv(jpr_oty2)%clgrid   ! not needed but cleaner...
+            srcv(jpr_ity1)%clgrid = srcv(jpr_ity2)%clgrid   ! not needed but cleaner...
+      ENDIF
+      !
+      IF( TRIM( sn_rcv_tau%cldes ) /= 'oce and ice' ) THEN        ! 'oce and ice' case ocean stress on ocean mesh used
+         srcv(jpr_itx1:jpr_itz2)%laction = .FALSE.    ! ice components not received
+         srcv(jpr_itx1)%clgrid = 'U'                  ! ocean stress used after its transformation
+         srcv(jpr_ity1)%clgrid = 'V'                  ! i.e. it is always at U- & V-points for i- & j-comp. resp.
+      ENDIF
+      ENDIF
+
+      !                                                      ! ------------------------- !
+      !                                                      !    freshwater budget      !   E-P
+      !                                                      ! ------------------------- !
+      ! we suppose that atmosphere modele do not make the difference between precipiration (liquide or solid)
+      ! over ice of free ocean within the same atmospheric cell.cd 
+      srcv(jpr_rain)%clname = 'OTotRain'      ! Rain = liquid precipitation
+      srcv(jpr_snow)%clname = 'OTotSnow'      ! Snow = solid precipitation
+      srcv(jpr_tevp)%clname = 'OTotEvap'      ! total evaporation (over oce + ice sublimation)
+      srcv(jpr_ievp)%clname = 'OIceEvap'      ! evaporation over ice = sublimation
+      srcv(jpr_sbpr)%clname = 'OSubMPre'      ! sublimation - liquid precipitation - solid precipitation 
+      srcv(jpr_semp)%clname = 'OISubMSn'      ! ice solid water budget = sublimation - solid precipitation
+      srcv(jpr_oemp)%clname = 'OOEvaMPr'      ! ocean water budget = ocean Evap - ocean precip
+      SELECT CASE( TRIM( sn_rcv_emp%cldes ) )
+      CASE( 'none'          )       ! nothing to do
+      CASE( 'oce only'      )   ;   srcv(jpr_oemp)%laction = .TRUE. 
+      CASE( 'conservative'  )
+         srcv( (/jpr_rain, jpr_snow, jpr_ievp, jpr_tevp/) )%laction = .TRUE.
+         IF ( k_ice <= 1 )  srcv(jpr_ievp)%laction = .FALSE.
+      CASE( 'oce and ice'   )   ;   srcv( (/jpr_ievp, jpr_sbpr, jpr_semp, jpr_oemp/) )%laction = .TRUE.
+      CASE default              ;   CALL ctl_stop( 'sbc_cpl_init: wrong definition of sn_rcv_emp%cldes' )
+      END SELECT
+      !
+      !                                                      ! ------------------------- !
+      !                                                      !     Runoffs & Calving     !   
+      !                                                      ! ------------------------- !
+      srcv(jpr_rnf   )%clname = 'O_Runoff'
+      IF( TRIM( sn_rcv_rnf%cldes ) == 'coupled' ) THEN
+         srcv(jpr_rnf)%laction = .TRUE.
+         l_rnfcpl              = .TRUE.                      ! -> no need to read runoffs in sbcrnf
+         ln_rnf                = nn_components /= jp_iam_sas ! -> force to go through sbcrnf if not sas
+         IF(lwp) WRITE(numout,*)
+         IF(lwp) WRITE(numout,*) '   runoffs received from oasis -> force ln_rnf = ', ln_rnf
+      ENDIF
+      !
+      srcv(jpr_cal)%clname = 'OCalving'   ;  IF( TRIM( sn_rcv_cal%cldes) == 'coupled' )   srcv(jpr_cal)%laction = .TRUE.
+      srcv(jpr_isf)%clname = 'OIcshelf'   ;  IF( TRIM( sn_rcv_isf%cldes) == 'coupled' )   srcv(jpr_isf)%laction = .TRUE.
+      srcv(jpr_icb)%clname = 'OIceberg'   ;  IF( TRIM( sn_rcv_icb%cldes) == 'coupled' )   srcv(jpr_icb)%laction = .TRUE.
+
+      IF( srcv(jpr_isf)%laction .AND. ln_isf ) THEN
+         l_isfcpl             = .TRUE.                      ! -> no need to read isf in sbcisf
+         IF(lwp) WRITE(numout,*)
+         IF(lwp) WRITE(numout,*) '   iceshelf received from oasis '
+      ENDIF
+      !
+      !                                                      ! ------------------------- !
+      !                                                      !    non solar radiation    !   Qns
+      !                                                      ! ------------------------- !
+      srcv(jpr_qnsoce)%clname = 'O_QnsOce'
+      srcv(jpr_qnsice)%clname = 'O_QnsIce'
+      srcv(jpr_qnsmix)%clname = 'O_QnsMix'
+      SELECT CASE( TRIM( sn_rcv_qns%cldes ) )
+      CASE( 'none'          )       ! nothing to do
+      CASE( 'oce only'      )   ;   srcv(               jpr_qnsoce   )%laction = .TRUE.
+      CASE( 'conservative'  )   ;   srcv( (/jpr_qnsice, jpr_qnsmix/) )%laction = .TRUE.
+      CASE( 'oce and ice'   )   ;   srcv( (/jpr_qnsice, jpr_qnsoce/) )%laction = .TRUE.
+      CASE( 'mixed oce-ice' )   ;   srcv(               jpr_qnsmix   )%laction = .TRUE. 
+      CASE default              ;   CALL ctl_stop( 'sbc_cpl_init: wrong definition of sn_rcv_qns%cldes' )
+      END SELECT
+      IF( TRIM( sn_rcv_qns%cldes ) == 'mixed oce-ice' .AND. nn_cats_cpl > 1 ) &
+         CALL ctl_stop( 'sbc_cpl_init: sn_rcv_qns%cldes not currently allowed to be mixed oce-ice for multi-category ice' )
+      !
+      !                                                      ! ------------------------- !
+      !                                                      !    solar radiation        !   Qsr
+      !                                                      ! ------------------------- !
+      srcv(jpr_qsroce)%clname = 'O_QsrOce'
+      srcv(jpr_qsrice)%clname = 'O_QsrIce'
+      srcv(jpr_qsrmix)%clname = 'O_QsrMix'
+      SELECT CASE( TRIM( sn_rcv_qsr%cldes ) )
+      CASE( 'none'          )       ! nothing to do
+      CASE( 'oce only'      )   ;   srcv(               jpr_qsroce   )%laction = .TRUE.
+      CASE( 'conservative'  )   ;   srcv( (/jpr_qsrice, jpr_qsrmix/) )%laction = .TRUE.
+      CASE( 'oce and ice'   )   ;   srcv( (/jpr_qsrice, jpr_qsroce/) )%laction = .TRUE.
+      CASE( 'mixed oce-ice' )   ;   srcv(               jpr_qsrmix   )%laction = .TRUE. 
+      CASE default              ;   CALL ctl_stop( 'sbc_cpl_init: wrong definition of sn_rcv_qsr%cldes' )
+      END SELECT
+      IF( TRIM( sn_rcv_qsr%cldes ) == 'mixed oce-ice' .AND. nn_cats_cpl > 1 ) &
+         CALL ctl_stop( 'sbc_cpl_init: sn_rcv_qsr%cldes not currently allowed to be mixed oce-ice for multi-category ice' )
+      !
+      !                                                      ! ------------------------- !
+      !                                                      !   non solar sensitivity   !   d(Qns)/d(T)
+      !                                                      ! ------------------------- !
+      srcv(jpr_dqnsdt)%clname = 'O_dQnsdT'   
+      IF( TRIM( sn_rcv_dqnsdt%cldes ) == 'coupled' )   srcv(jpr_dqnsdt)%laction = .TRUE.
+      !
+      ! non solar sensitivity mandatory for mixed oce-ice solar radiation coupling technique
+      IF( TRIM( sn_rcv_dqnsdt%cldes ) == 'none' .AND. TRIM( sn_rcv_qns%cldes ) == 'mixed oce-ice' )  &
+         &   CALL ctl_stop( 'sbc_cpl_init: namsbc_cpl namelist mismatch between sn_rcv_qns%cldes and sn_rcv_dqnsdt%cldes' )
+      !
+      !                                                      ! ------------------------- !
+      !                                                      !      10m wind module      !   
+      !                                                      ! ------------------------- !
+      srcv(jpr_w10m)%clname = 'O_Wind10'   ;   IF( TRIM(sn_rcv_w10m%cldes  ) == 'coupled' )   srcv(jpr_w10m)%laction = .TRUE. 
+      !
+      !                                                      ! ------------------------- !
+      !                                                      !   wind stress module      !   
+      !                                                      ! ------------------------- !
+      srcv(jpr_taum)%clname = 'O_TauMod'   ;   IF( TRIM(sn_rcv_taumod%cldes) == 'coupled' )   srcv(jpr_taum)%laction = .TRUE.
+      lhftau = srcv(jpr_taum)%laction
+      !
+      !                                                      ! ------------------------- !
+      !                                                      !      Atmospheric CO2      !
+      !                                                      ! ------------------------- !
+      srcv(jpr_co2 )%clname = 'O_AtmCO2'   
+      IF( TRIM(sn_rcv_co2%cldes   ) == 'coupled' )  THEN
+         srcv(jpr_co2 )%laction = .TRUE.
+         l_co2cpl = .TRUE.
+         IF(lwp) WRITE(numout,*)
+         IF(lwp) WRITE(numout,*) '   Atmospheric pco2 received from oasis '
+         IF(lwp) WRITE(numout,*)
+      ENDIF
+      !
+      !                                                      ! ------------------------- ! 
+      !                                                      ! Mean Sea Level Pressure   ! 
+      !                                                      ! ------------------------- ! 
+      srcv(jpr_mslp)%clname = 'O_MSLP'     ;   IF( TRIM(sn_rcv_mslp%cldes  ) == 'coupled' )    srcv(jpr_mslp)%laction = .TRUE. 
+      !
+      !                                                      ! ------------------------- !
+      !                                                      !  ice topmelt and botmelt  !   
+      !                                                      ! ------------------------- !
+      srcv(jpr_topm )%clname = 'OTopMlt'
+      srcv(jpr_botm )%clname = 'OBotMlt'
+      IF( TRIM(sn_rcv_iceflx%cldes) == 'coupled' ) THEN
+         IF ( TRIM( sn_rcv_iceflx%clcat ) == 'yes' ) THEN
+            srcv(jpr_topm:jpr_botm)%nct = nn_cats_cpl
+         ELSE
+            CALL ctl_stop( 'sbc_cpl_init: sn_rcv_iceflx%clcat should always be set to yes currently' )
+         ENDIF
+         srcv(jpr_topm:jpr_botm)%laction = .TRUE.
+      ENDIF
+      !                                                      ! ------------------------- !
+      !                                                      !    ice skin temperature   !   
+      !                                                      ! ------------------------- !
+      srcv(jpr_ts_ice)%clname = 'OTsfIce'    ! needed by Met Office
+      IF ( TRIM( sn_rcv_ts_ice%cldes ) == 'ice' )   srcv(jpr_ts_ice)%laction = .TRUE.
+      IF ( TRIM( sn_rcv_ts_ice%clcat ) == 'yes' )   srcv(jpr_ts_ice)%nct     = nn_cats_cpl
+      IF ( TRIM( sn_rcv_emp%clcat    ) == 'yes' )   srcv(jpr_ievp)%nct       = nn_cats_cpl
+
+      !                                                      ! ------------------------- !
+      !                                                      !      Wave breaking        !    
+      !                                                      ! ------------------------- ! 
+      srcv(jpr_hsig)%clname  = 'O_Hsigwa'    ! significant wave height
+      IF( TRIM(sn_rcv_hsig%cldes  ) == 'coupled' )  THEN
+         srcv(jpr_hsig)%laction = .TRUE.
+         cpl_hsig = .TRUE.
+      ENDIF
+      srcv(jpr_phioc)%clname = 'O_PhiOce'    ! wave to ocean energy
+      IF( TRIM(sn_rcv_phioc%cldes ) == 'coupled' )  THEN
+         srcv(jpr_phioc)%laction = .TRUE.
+         cpl_phioc = .TRUE.
+      ENDIF
+      srcv(jpr_sdrftx)%clname = 'O_Sdrfx'    ! Stokes drift in the u direction
+      IF( TRIM(sn_rcv_sdrfx%cldes ) == 'coupled' )  THEN
+         srcv(jpr_sdrftx)%laction = .TRUE.
+         cpl_sdrftx = .TRUE.
+      ENDIF
+      srcv(jpr_sdrfty)%clname = 'O_Sdrfy'    ! Stokes drift in the v direction
+      IF( TRIM(sn_rcv_sdrfy%cldes ) == 'coupled' )  THEN
+         srcv(jpr_sdrfty)%laction = .TRUE.
+         cpl_sdrfty = .TRUE.
+      ENDIF
+      srcv(jpr_wper)%clname = 'O_WPer'       ! mean wave period
+      IF( TRIM(sn_rcv_wper%cldes  ) == 'coupled' )  THEN
+         srcv(jpr_wper)%laction = .TRUE.
+         cpl_wper = .TRUE.
+      ENDIF
+      srcv(jpr_wfreq)%clname = 'O_WFreq'     ! wave peak frequency 
+      IF( TRIM(sn_rcv_wfreq%cldes ) == 'coupled' )  THEN
+         srcv(jpr_wfreq)%laction = .TRUE.
+         cpl_wfreq = .TRUE.
+      ENDIF
+      srcv(jpr_wnum)%clname = 'O_WNum'       ! mean wave number
+      IF( TRIM(sn_rcv_wnum%cldes ) == 'coupled' )  THEN
+         srcv(jpr_wnum)%laction = .TRUE.
+         cpl_wnum = .TRUE.
+      ENDIF
+      srcv(jpr_tauwoc)%clname = 'O_TauOce'   ! stress fraction adsorbed by the wave
+      IF( TRIM(sn_rcv_tauwoc%cldes ) == 'coupled' )  THEN
+         srcv(jpr_tauwoc)%laction = .TRUE.
+         cpl_tauwoc = .TRUE.
+      ENDIF
+      srcv(jpr_tauwx)%clname = 'O_Tauwx'      ! ocean stress from wave in the x direction
+      srcv(jpr_tauwy)%clname = 'O_Tauwy'      ! ocean stress from wave in the y direction
+      IF( TRIM(sn_rcv_tauw%cldes ) == 'coupled' )  THEN
+         srcv(jpr_tauwx)%laction = .TRUE.
+         srcv(jpr_tauwy)%laction = .TRUE.
+         cpl_tauw = .TRUE.
+      ENDIF
+      srcv(jpr_wdrag)%clname = 'O_WDrag'     ! neutral surface drag coefficient
+      IF( TRIM(sn_rcv_wdrag%cldes ) == 'coupled' )  THEN
+         srcv(jpr_wdrag)%laction = .TRUE.
+         cpl_wdrag = .TRUE.
+      ENDIF
+      IF( srcv(jpr_tauwoc)%laction .AND. srcv(jpr_tauwx)%laction .AND. srcv(jpr_tauwy)%laction ) &
+            CALL ctl_stop( 'More than one method for modifying the ocean stress has been selected ', &
+                                     '(sn_rcv_tauwoc=coupled and sn_rcv_tauw=coupled)' )
+      !
+      !                                                      ! ------------------------------- !
+      !                                                      !   OPA-SAS coupling - rcv by opa !   
+      !                                                      ! ------------------------------- !
+      srcv(jpr_sflx)%clname = 'O_SFLX'
+      srcv(jpr_fice)%clname = 'RIceFrc'
+      !
+      IF( nn_components == jp_iam_opa ) THEN    ! OPA coupled to SAS via OASIS: force received field by OPA (sent by SAS)
+         srcv(:)%laction = .FALSE.   ! force default definition in case of opa <-> sas coupling
+         srcv(:)%clgrid  = 'T'       ! force default definition in case of opa <-> sas coupling
+         srcv(:)%nsgn    = 1.        ! force default definition in case of opa <-> sas coupling
+         srcv( (/jpr_qsroce, jpr_qnsoce, jpr_oemp, jpr_sflx, jpr_fice, jpr_otx1, jpr_oty1, jpr_taum/) )%laction = .TRUE.
+         srcv(jpr_otx1)%clgrid = 'U'        ! oce components given at U-point
+         srcv(jpr_oty1)%clgrid = 'V'        !           and           V-point
+         ! Vectors: change of sign at north fold ONLY if on the local grid
+         srcv( (/jpr_otx1,jpr_oty1/) )%nsgn = -1.
+         sn_rcv_tau%clvgrd = 'U,V'
+         sn_rcv_tau%clvor = 'local grid'
+         sn_rcv_tau%clvref = 'spherical'
+         sn_rcv_emp%cldes = 'oce only'
+         !
+         IF(lwp) THEN                        ! control print
+            WRITE(numout,*)
+            WRITE(numout,*)'               Special conditions for SAS-OPA coupling  '
+            WRITE(numout,*)'               OPA component  '
+            WRITE(numout,*)
+            WRITE(numout,*)'  received fields from SAS component '
+            WRITE(numout,*)'                  ice cover '
+            WRITE(numout,*)'                  oce only EMP  '
+            WRITE(numout,*)'                  salt flux  '
+            WRITE(numout,*)'                  mixed oce-ice solar flux  '
+            WRITE(numout,*)'                  mixed oce-ice non solar flux  '
+            WRITE(numout,*)'                  wind stress U,V on local grid and sperical coordinates '
+            WRITE(numout,*)'                  wind stress module'
+            WRITE(numout,*)
+         ENDIF
+      ENDIF
+      !                                                      ! -------------------------------- !
+      !                                                      !   OPA-SAS coupling - rcv by sas  !   
+      !                                                      ! -------------------------------- !
+      srcv(jpr_toce  )%clname = 'I_SSTSST'
+      srcv(jpr_soce  )%clname = 'I_SSSal'
+      srcv(jpr_ocx1  )%clname = 'I_OCurx1'
+      srcv(jpr_ocy1  )%clname = 'I_OCury1'
+      srcv(jpr_ssh   )%clname = 'I_SSHght'
+      srcv(jpr_e3t1st)%clname = 'I_E3T1st'   
+      srcv(jpr_fraqsr)%clname = 'I_FraQsr'   
+      !
+      IF( nn_components == jp_iam_sas ) THEN
+         IF( .NOT. ln_cpl ) srcv(:)%laction = .FALSE.   ! force default definition in case of opa <-> sas coupling
+         IF( .NOT. ln_cpl ) srcv(:)%clgrid  = 'T'       ! force default definition in case of opa <-> sas coupling
+         IF( .NOT. ln_cpl ) srcv(:)%nsgn    = 1.        ! force default definition in case of opa <-> sas coupling
+         srcv( (/jpr_toce, jpr_soce, jpr_ssh, jpr_fraqsr, jpr_ocx1, jpr_ocy1/) )%laction = .TRUE.
+         srcv( jpr_e3t1st )%laction = .NOT.ln_linssh
+         srcv(jpr_ocx1)%clgrid = 'U'        ! oce components given at U-point
+         srcv(jpr_ocy1)%clgrid = 'V'        !           and           V-point
+         ! Vectors: change of sign at north fold ONLY if on the local grid
+         srcv(jpr_ocx1:jpr_ocy1)%nsgn = -1.
+         ! Change first letter to couple with atmosphere if already coupled OPA
+         ! this is nedeed as each variable name used in the namcouple must be unique:
+         ! for example O_Runoff received by OPA from SAS and therefore O_Runoff received by SAS from the Atmosphere
+         DO jn = 1, jprcv
+            IF ( srcv(jn)%clname(1:1) == "O" ) srcv(jn)%clname = "S"//srcv(jn)%clname(2:LEN(srcv(jn)%clname))
+         END DO
+         !
+         IF(lwp) THEN                        ! control print
+            WRITE(numout,*)
+            WRITE(numout,*)'               Special conditions for SAS-OPA coupling  '
+            WRITE(numout,*)'               SAS component  '
+            WRITE(numout,*)
+            IF( .NOT. ln_cpl ) THEN
+               WRITE(numout,*)'  received fields from OPA component '
+            ELSE
+               WRITE(numout,*)'  Additional received fields from OPA component : '
+            ENDIF
+            WRITE(numout,*)'               sea surface temperature (Celsius) '
+            WRITE(numout,*)'               sea surface salinity ' 
+            WRITE(numout,*)'               surface currents ' 
+            WRITE(numout,*)'               sea surface height ' 
+            WRITE(numout,*)'               thickness of first ocean T level '        
+            WRITE(numout,*)'               fraction of solar net radiation absorbed in the first ocean level'
+            WRITE(numout,*)
+         ENDIF
+      ENDIF
+      
+      ! =================================================== !
+      ! Allocate all parts of frcv used for received fields !
+      ! =================================================== !
+      DO jn = 1, jprcv
+         IF ( srcv(jn)%laction ) ALLOCATE( frcv(jn)%z3(jpi,jpj,srcv(jn)%nct) )
+      END DO
+      ! Allocate taum part of frcv which is used even when not received as coupling field
+      IF ( .NOT. srcv(jpr_taum)%laction ) ALLOCATE( frcv(jpr_taum)%z3(jpi,jpj,srcv(jpr_taum)%nct) )
+      ! Allocate w10m part of frcv which is used even when not received as coupling field
+      IF ( .NOT. srcv(jpr_w10m)%laction ) ALLOCATE( frcv(jpr_w10m)%z3(jpi,jpj,srcv(jpr_w10m)%nct) )
+      ! Allocate jpr_otx1 part of frcv which is used even when not received as coupling field
+      IF ( .NOT. srcv(jpr_otx1)%laction ) ALLOCATE( frcv(jpr_otx1)%z3(jpi,jpj,srcv(jpr_otx1)%nct) )
+      IF ( .NOT. srcv(jpr_oty1)%laction ) ALLOCATE( frcv(jpr_oty1)%z3(jpi,jpj,srcv(jpr_oty1)%nct) )
+      ! Allocate itx1 and ity1 as they are used in sbc_cpl_ice_tau even if srcv(jpr_itx1)%laction = .FALSE.
+      IF( k_ice /= 0 ) THEN
+         IF ( .NOT. srcv(jpr_itx1)%laction ) ALLOCATE( frcv(jpr_itx1)%z3(jpi,jpj,srcv(jpr_itx1)%nct) )
+         IF ( .NOT. srcv(jpr_ity1)%laction ) ALLOCATE( frcv(jpr_ity1)%z3(jpi,jpj,srcv(jpr_ity1)%nct) )
+      END IF
+
+      ! ================================ !
+      !     Define the send interface    !
+      ! ================================ !
+      ! for each field: define the OASIS name                           (ssnd(:)%clname)
+      !                 define send or not from the namelist parameters (ssnd(:)%laction)
+      !                 define the north fold type of lbc               (ssnd(:)%nsgn)
+      
+      ! default definitions of nsnd
+      ssnd(:)%laction = .FALSE.   ;   ssnd(:)%clgrid = 'T'   ;   ssnd(:)%nsgn = 1.  ; ssnd(:)%nct = 1
+         
+      !                                                      ! ------------------------- !
+      !                                                      !    Surface temperature    !
+      !                                                      ! ------------------------- !
+      ssnd(jps_toce)%clname   = 'O_SSTSST'
+      ssnd(jps_tice)%clname   = 'O_TepIce'
+      ssnd(jps_ttilyr)%clname = 'O_TtiLyr'
+      ssnd(jps_tmix)%clname   = 'O_TepMix'
+      SELECT CASE( TRIM( sn_snd_temp%cldes ) )
+      CASE( 'none'                                 )       ! nothing to do
+      CASE( 'oce only'                             )   ;   ssnd( jps_toce )%laction = .TRUE.
+      CASE( 'oce and ice' , 'weighted oce and ice' , 'oce and weighted ice' )
+         ssnd( (/jps_toce, jps_tice/) )%laction = .TRUE.
+         IF ( TRIM( sn_snd_temp%clcat ) == 'yes' )  ssnd(jps_tice)%nct = nn_cats_cpl
+      CASE( 'mixed oce-ice'                        )   ;   ssnd( jps_tmix )%laction = .TRUE.
+      CASE default   ;   CALL ctl_stop( 'sbc_cpl_init: wrong definition of sn_snd_temp%cldes' )
+      END SELECT
+           
+      !                                                      ! ------------------------- !
+      !                                                      !          Albedo           !
+      !                                                      ! ------------------------- !
+      ssnd(jps_albice)%clname = 'O_AlbIce' 
+      ssnd(jps_albmix)%clname = 'O_AlbMix'
+      SELECT CASE( TRIM( sn_snd_alb%cldes ) )
+      CASE( 'none'                 )     ! nothing to do
+      CASE( 'ice' , 'weighted ice' )   ; ssnd(jps_albice)%laction = .TRUE.
+      CASE( 'mixed oce-ice'        )   ; ssnd(jps_albmix)%laction = .TRUE.
+      CASE default   ;   CALL ctl_stop( 'sbc_cpl_init: wrong definition of sn_snd_alb%cldes' )
+      END SELECT
+      !
+      ! Need to calculate oceanic albedo if
+      !     1. sending mixed oce-ice albedo or
+      !     2. receiving mixed oce-ice solar radiation 
+      IF ( TRIM ( sn_snd_alb%cldes ) == 'mixed oce-ice' .OR. TRIM ( sn_rcv_qsr%cldes ) == 'mixed oce-ice' ) THEN
+         CALL oce_alb( zaos, zacs )
+         ! Due to lack of information on nebulosity : mean clear/overcast sky
+         alb_oce_mix(:,:) = ( zacs(:,:) + zaos(:,:) ) * 0.5
+      ENDIF
+      !                                                      ! ------------------------- !
+      !                                                      !  Ice fraction & Thickness ! 
+      !                                                      ! ------------------------- !
+      ssnd(jps_fice)%clname  = 'OIceFrc'
+      ssnd(jps_ficet)%clname = 'OIceFrcT' 
+      ssnd(jps_hice)%clname  = 'OIceTck'
+      ssnd(jps_a_p)%clname   = 'OPndFrc'
+      ssnd(jps_ht_p)%clname  = 'OPndTck'
+      ssnd(jps_hsnw)%clname  = 'OSnwTck'
+      ssnd(jps_fice1)%clname = 'OIceFrd'
+      IF( k_ice /= 0 ) THEN
+         ssnd(jps_fice)%laction  = .TRUE.                 ! if ice treated in the ocean (even in climato case)
+         ssnd(jps_fice1)%laction = .TRUE.                 ! First-order regridded ice concentration, to be used producing atmos-to-ice fluxes (Met Office requirement)
+! Currently no namelist entry to determine sending of multi-category ice fraction so use the thickness entry for now
+         IF ( TRIM( sn_snd_thick%clcat  ) == 'yes' ) ssnd(jps_fice)%nct  = nn_cats_cpl
+         IF ( TRIM( sn_snd_thick1%clcat ) == 'yes' ) ssnd(jps_fice1)%nct = nn_cats_cpl
+      ENDIF
+      
+      IF (TRIM( sn_snd_ifrac%cldes )  == 'coupled') ssnd(jps_ficet)%laction = .TRUE. 
+
+      SELECT CASE ( TRIM( sn_snd_thick%cldes ) )
+      CASE( 'none'         )       ! nothing to do
+      CASE( 'ice and snow' ) 
+         ssnd(jps_hice:jps_hsnw)%laction = .TRUE.
+         IF ( TRIM( sn_snd_thick%clcat ) == 'yes' ) THEN
+            ssnd(jps_hice:jps_hsnw)%nct = nn_cats_cpl
+         ENDIF
+      CASE ( 'weighted ice and snow' ) 
+         ssnd(jps_hice:jps_hsnw)%laction = .TRUE.
+         IF ( TRIM( sn_snd_thick%clcat ) == 'yes' ) ssnd(jps_hice:jps_hsnw)%nct = nn_cats_cpl
+      CASE default   ;   CALL ctl_stop( 'sbc_cpl_init: wrong definition of sn_snd_thick%cldes' )
+      END SELECT
+
+      !                                                      ! ------------------------- ! 
+      !                                                      !      Ice Meltponds        ! 
+      !                                                      ! ------------------------- ! 
+      ! Needed by Met Office
+      ssnd(jps_a_p)%clname  = 'OPndFrc'    
+      ssnd(jps_ht_p)%clname = 'OPndTck'    
+      SELECT CASE ( TRIM( sn_snd_mpnd%cldes ) ) 
+      CASE ( 'none' ) 
+         ssnd(jps_a_p)%laction  = .FALSE. 
+         ssnd(jps_ht_p)%laction = .FALSE. 
+      CASE ( 'ice only' )  
+         ssnd(jps_a_p)%laction  = .TRUE. 
+         ssnd(jps_ht_p)%laction = .TRUE. 
+         IF ( TRIM( sn_snd_mpnd%clcat ) == 'yes' ) THEN 
+            ssnd(jps_a_p)%nct  = nn_cats_cpl 
+            ssnd(jps_ht_p)%nct = nn_cats_cpl 
+         ELSE 
+            IF ( nn_cats_cpl > 1 ) THEN 
+               CALL ctl_stop( 'sbc_cpl_init: use weighted ice option for sn_snd_mpnd%cldes if not exchanging category fields' ) 
+            ENDIF 
+         ENDIF 
+      CASE ( 'weighted ice' )  
+         ssnd(jps_a_p)%laction  = .TRUE. 
+         ssnd(jps_ht_p)%laction = .TRUE. 
+         IF ( TRIM( sn_snd_mpnd%clcat ) == 'yes' ) THEN 
+            ssnd(jps_a_p)%nct  = nn_cats_cpl  
+            ssnd(jps_ht_p)%nct = nn_cats_cpl  
+         ENDIF 
+      CASE default   ;   CALL ctl_stop( 'sbc_cpl_init: wrong definition of sn_snd_mpnd%cldes; '//sn_snd_mpnd%cldes ) 
+      END SELECT 
+ 
+      !                                                      ! ------------------------- !
+      !                                                      !      Surface current      !
+      !                                                      ! ------------------------- !
+      !        ocean currents              !            ice velocities
+      ssnd(jps_ocx1)%clname = 'O_OCurx1'   ;   ssnd(jps_ivx1)%clname = 'O_IVelx1'
+      ssnd(jps_ocy1)%clname = 'O_OCury1'   ;   ssnd(jps_ivy1)%clname = 'O_IVely1'
+      ssnd(jps_ocz1)%clname = 'O_OCurz1'   ;   ssnd(jps_ivz1)%clname = 'O_IVelz1'
+      ssnd(jps_ocxw)%clname = 'O_OCurxw' 
+      ssnd(jps_ocyw)%clname = 'O_OCuryw' 
+      !
+      ssnd(jps_ocx1:jps_ivz1)%nsgn = -1.   ! vectors: change of the sign at the north fold
+
+      IF( sn_snd_crt%clvgrd == 'U,V' ) THEN
+         ssnd(jps_ocx1)%clgrid = 'U' ; ssnd(jps_ocy1)%clgrid = 'V'
+      ELSE IF( sn_snd_crt%clvgrd /= 'T' ) THEN  
+         CALL ctl_stop( 'sn_snd_crt%clvgrd must be equal to T' )
+         ssnd(jps_ocx1:jps_ivz1)%clgrid  = 'T'      ! all oce and ice components on the same unique grid
+      ENDIF
+      ssnd(jps_ocx1:jps_ivz1)%laction = .TRUE.   ! default: all are send
+      IF( TRIM( sn_snd_crt%clvref ) == 'spherical' )   ssnd( (/jps_ocz1, jps_ivz1/) )%laction = .FALSE. 
+      IF( TRIM( sn_snd_crt%clvor ) == 'eastward-northward' ) ssnd(jps_ocx1:jps_ivz1)%nsgn = 1.
+      SELECT CASE( TRIM( sn_snd_crt%cldes ) )
+      CASE( 'none'                 )   ;   ssnd(jps_ocx1:jps_ivz1)%laction = .FALSE.
+      CASE( 'oce only'             )   ;   ssnd(jps_ivx1:jps_ivz1)%laction = .FALSE.
+      CASE( 'weighted oce and ice' )   !   nothing to do
+      CASE( 'mixed oce-ice'        )   ;   ssnd(jps_ivx1:jps_ivz1)%laction = .FALSE.
+      CASE default   ;   CALL ctl_stop( 'sbc_cpl_init: wrong definition of sn_snd_crt%cldes' )
+      END SELECT
+
+      ssnd(jps_ocxw:jps_ocyw)%nsgn = -1.   ! vectors: change of the sign at the north fold 
+        
+      IF( sn_snd_crtw%clvgrd == 'U,V' ) THEN 
+         ssnd(jps_ocxw)%clgrid = 'U' ; ssnd(jps_ocyw)%clgrid = 'V' 
+      ELSE IF( sn_snd_crtw%clvgrd /= 'T' ) THEN 
+         CALL ctl_stop( 'sn_snd_crtw%clvgrd must be equal to T' ) 
+      ENDIF 
+      IF( TRIM( sn_snd_crtw%clvor ) == 'eastward-northward' ) ssnd(jps_ocxw:jps_ocyw)%nsgn = 1. 
+      SELECT CASE( TRIM( sn_snd_crtw%cldes ) ) 
+         CASE( 'none'                 )   ; ssnd(jps_ocxw:jps_ocyw)%laction = .FALSE. 
+         CASE( 'oce only'             )   ; ssnd(jps_ocxw:jps_ocyw)%laction = .TRUE. 
+         CASE( 'weighted oce and ice' )   !   nothing to do 
+         CASE( 'mixed oce-ice'        )   ; ssnd(jps_ivx1:jps_ivz1)%laction = .FALSE. 
+         CASE default   ;   CALL ctl_stop( 'sbc_cpl_init: wrong definition of sn_snd_crtw%cldes' ) 
+      END SELECT 
+
+      !                                                      ! ------------------------- !
+      !                                                      !          CO2 flux         !
+      !                                                      ! ------------------------- !
+      ssnd(jps_co2)%clname = 'O_CO2FLX' ;  IF( TRIM(sn_snd_co2%cldes) == 'coupled' )    ssnd(jps_co2 )%laction = .TRUE.
+      ! 
+      !                                                      ! ------------------------- ! 
+      !                                                      ! Sea surface freezing temp ! 
+      !                                                      ! ------------------------- ! 
+      ! needed by Met Office
+      ssnd(jps_sstfrz)%clname = 'O_SSTFrz' ; IF( TRIM(sn_snd_sstfrz%cldes) == 'coupled' )  ssnd(jps_sstfrz)%laction = .TRUE. 
+      ! 
+      !                                                      ! ------------------------- ! 
+      !                                                      !    Ice conductivity       ! 
+      !                                                      ! ------------------------- ! 
+      ! needed by Met Office
+      ! Note that ultimately we will move to passing an ocean effective conductivity as well so there 
+      ! will be some changes to the parts of the code which currently relate only to ice conductivity 
+      ssnd(jps_ttilyr )%clname = 'O_TtiLyr' 
+      SELECT CASE ( TRIM( sn_snd_ttilyr%cldes ) ) 
+      CASE ( 'none' ) 
+         ssnd(jps_ttilyr)%laction = .FALSE. 
+      CASE ( 'ice only' ) 
+         ssnd(jps_ttilyr)%laction = .TRUE. 
+         IF ( TRIM( sn_snd_ttilyr%clcat ) == 'yes' ) THEN 
+            ssnd(jps_ttilyr)%nct = nn_cats_cpl 
+         ELSE 
+            IF ( nn_cats_cpl > 1 ) THEN 
+               CALL ctl_stop( 'sbc_cpl_init: use weighted ice option for sn_snd_ttilyr%cldes if not exchanging category fields' ) 
+            ENDIF 
+         ENDIF 
+      CASE ( 'weighted ice' ) 
+         ssnd(jps_ttilyr)%laction = .TRUE. 
+         IF ( TRIM( sn_snd_ttilyr%clcat ) == 'yes' ) ssnd(jps_ttilyr)%nct = nn_cats_cpl 
+      CASE default   ;   CALL ctl_stop( 'sbc_cpl_init: wrong definition of sn_snd_ttilyr%cldes;'//sn_snd_ttilyr%cldes ) 
+      END SELECT 
+
+      ssnd(jps_kice )%clname = 'OIceKn' 
+      SELECT CASE ( TRIM( sn_snd_cond%cldes ) ) 
+      CASE ( 'none' ) 
+         ssnd(jps_kice)%laction = .FALSE. 
+      CASE ( 'ice only' ) 
+         ssnd(jps_kice)%laction = .TRUE. 
+         IF ( TRIM( sn_snd_cond%clcat ) == 'yes' ) THEN 
+            ssnd(jps_kice)%nct = nn_cats_cpl 
+         ELSE 
+            IF ( nn_cats_cpl > 1 ) THEN 
+               CALL ctl_stop( 'sbc_cpl_init: use weighted ice option for sn_snd_cond%cldes if not exchanging category fields' ) 
+            ENDIF 
+         ENDIF 
+      CASE ( 'weighted ice' ) 
+         ssnd(jps_kice)%laction = .TRUE. 
+         IF ( TRIM( sn_snd_cond%clcat ) == 'yes' ) ssnd(jps_kice)%nct = nn_cats_cpl 
+      CASE default   ;   CALL ctl_stop( 'sbc_cpl_init: wrong definition of sn_snd_cond%cldes;'//sn_snd_cond%cldes ) 
+      END SELECT 
+      ! 
+      !                                                      ! ------------------------- ! 
+      !                                                      !     Sea surface height    ! 
+      !                                                      ! ------------------------- ! 
+      ssnd(jps_wlev)%clname = 'O_Wlevel' ;  IF( TRIM(sn_snd_wlev%cldes) == 'coupled' )   ssnd(jps_wlev)%laction = .TRUE. 
+
+      !                                                      ! ------------------------------- !
+      !                                                      !   OPA-SAS coupling - snd by opa !   
+      !                                                      ! ------------------------------- !
+      ssnd(jps_ssh   )%clname = 'O_SSHght' 
+      ssnd(jps_soce  )%clname = 'O_SSSal' 
+      ssnd(jps_e3t1st)%clname = 'O_E3T1st'   
+      ssnd(jps_fraqsr)%clname = 'O_FraQsr'
+      !
+      IF( nn_components == jp_iam_opa ) THEN
+         ssnd(:)%laction = .FALSE.   ! force default definition in case of opa <-> sas coupling
+         ssnd( (/jps_toce, jps_soce, jps_ssh, jps_fraqsr, jps_ocx1, jps_ocy1/) )%laction = .TRUE.
+         ssnd( jps_e3t1st )%laction = .NOT.ln_linssh
+         ! vector definition: not used but cleaner...
+         ssnd(jps_ocx1)%clgrid  = 'U'        ! oce components given at U-point
+         ssnd(jps_ocy1)%clgrid  = 'V'        !           and           V-point
+         sn_snd_crt%clvgrd = 'U,V'
+         sn_snd_crt%clvor = 'local grid'
+         sn_snd_crt%clvref = 'spherical'
+         !
+         IF(lwp) THEN                        ! control print
+            WRITE(numout,*)
+            WRITE(numout,*)'  sent fields to SAS component '
+            WRITE(numout,*)'               sea surface temperature (T before, Celsius) '
+            WRITE(numout,*)'               sea surface salinity ' 
+            WRITE(numout,*)'               surface currents U,V on local grid and spherical coordinates' 
+            WRITE(numout,*)'               sea surface height ' 
+            WRITE(numout,*)'               thickness of first ocean T level '        
+            WRITE(numout,*)'               fraction of solar net radiation absorbed in the first ocean level'
+            WRITE(numout,*)
+         ENDIF
+      ENDIF
+      !                                                      ! ------------------------------- !
+      !                                                      !   OPA-SAS coupling - snd by sas !   
+      !                                                      ! ------------------------------- !
+      ssnd(jps_sflx  )%clname = 'I_SFLX'     
+      ssnd(jps_fice2 )%clname = 'IIceFrc'
+      ssnd(jps_qsroce)%clname = 'I_QsrOce'   
+      ssnd(jps_qnsoce)%clname = 'I_QnsOce'   
+      ssnd(jps_oemp  )%clname = 'IOEvaMPr' 
+      ssnd(jps_otx1  )%clname = 'I_OTaux1'   
+      ssnd(jps_oty1  )%clname = 'I_OTauy1'   
+      ssnd(jps_rnf   )%clname = 'I_Runoff'   
+      ssnd(jps_taum  )%clname = 'I_TauMod'   
+      !
+      IF( nn_components == jp_iam_sas ) THEN
+         IF( .NOT. ln_cpl ) ssnd(:)%laction = .FALSE.   ! force default definition in case of opa <-> sas coupling
+         ssnd( (/jps_qsroce, jps_qnsoce, jps_oemp, jps_fice2, jps_sflx, jps_otx1, jps_oty1, jps_taum/) )%laction = .TRUE.
+         !
+         ! Change first letter to couple with atmosphere if already coupled with sea_ice
+         ! this is nedeed as each variable name used in the namcouple must be unique:
+         ! for example O_SSTSST sent by OPA to SAS and therefore S_SSTSST sent by SAS to the Atmosphere
+         DO jn = 1, jpsnd
+            IF ( ssnd(jn)%clname(1:1) == "O" ) ssnd(jn)%clname = "S"//ssnd(jn)%clname(2:LEN(ssnd(jn)%clname))
+         END DO
+         !
+         IF(lwp) THEN                        ! control print
+            WRITE(numout,*)
+            IF( .NOT. ln_cpl ) THEN
+               WRITE(numout,*)'  sent fields to OPA component '
+            ELSE
+               WRITE(numout,*)'  Additional sent fields to OPA component : '
+            ENDIF
+            WRITE(numout,*)'                  ice cover '
+            WRITE(numout,*)'                  oce only EMP  '
+            WRITE(numout,*)'                  salt flux  '
+            WRITE(numout,*)'                  mixed oce-ice solar flux  '
+            WRITE(numout,*)'                  mixed oce-ice non solar flux  '
+            WRITE(numout,*)'                  wind stress U,V components'
+            WRITE(numout,*)'                  wind stress module'
+         ENDIF
+      ENDIF
+
+      !
+      ! ================================ !
+      !   initialisation of the coupler  !
+      ! ================================ !
+
+      CALL cpl_define(jprcv, jpsnd, nn_cplmodel)
+      
+      IF (ln_usecplmask) THEN 
+         xcplmask(:,:,:) = 0.
+         CALL iom_open( 'cplmask', inum )
+         CALL iom_get( inum, jpdom_unknown, 'cplmask', xcplmask(1:nlci,1:nlcj,1:nn_cplmodel),   &
+            &          kstart = (/ mig(1),mjg(1),1 /), kcount = (/ nlci,nlcj,nn_cplmodel /) )
+         CALL iom_close( inum )
+      ELSE
+         xcplmask(:,:,:) = 1.
+      ENDIF
+      xcplmask(:,:,0) = 1. - SUM( xcplmask(:,:,1:nn_cplmodel), dim = 3 )
+      !
+      ncpl_qsr_freq = cpl_freq( 'O_QsrOce' ) + cpl_freq( 'O_QsrMix' ) + cpl_freq( 'I_QsrOce' ) + cpl_freq( 'I_QsrMix' )
+      IF( ln_dm2dc .AND. ln_cpl .AND. ncpl_qsr_freq /= 86400 )   &
+         &   CALL ctl_stop( 'sbc_cpl_init: diurnal cycle reconstruction (ln_dm2dc) needs daily couping for solar radiation' )
+      IF( ln_dm2dc .AND. ln_cpl ) ncpl_qsr_freq = 86400 / ncpl_qsr_freq
+      !
+   END SUBROUTINE sbc_cpl_init
+
+
+   SUBROUTINE sbc_cpl_rcv( kt, k_fsbc, k_ice )     
+      !!----------------------------------------------------------------------
+      !!             ***  ROUTINE sbc_cpl_rcv  ***
+      !!
+      !! ** Purpose :   provide the stress over the ocean and, if no sea-ice,
+      !!                provide the ocean heat and freshwater fluxes.
+      !!
+      !! ** Method  : - Receive all the atmospheric fields (stored in frcv array). called at each time step.
+      !!                OASIS controls if there is something do receive or not. nrcvinfo contains the info
+      !!                to know if the field was really received or not
+      !!
+      !!              --> If ocean stress was really received:
+      !!
+      !!                  - transform the received ocean stress vector from the received
+      !!                 referential and grid into an atmosphere-ocean stress in 
+      !!                 the (i,j) ocean referencial and at the ocean velocity point. 
+      !!                    The received stress are :
+      !!                     - defined by 3 components (if cartesian coordinate)
+      !!                            or by 2 components (if spherical)
+      !!                     - oriented along geographical   coordinate (if eastward-northward)
+      !!                            or  along the local grid coordinate (if local grid)
+      !!                     - given at U- and V-point, resp.   if received on 2 grids
+      !!                            or at T-point               if received on 1 grid
+      !!                    Therefore and if necessary, they are successively 
+      !!                  processed in order to obtain them 
+      !!                     first  as  2 components on the sphere 
+      !!                     second as  2 components oriented along the local grid
+      !!                     third  as  2 components on the U,V grid 
+      !!
+      !!              --> 
+      !!
+      !!              - In 'ocean only' case, non solar and solar ocean heat fluxes 
+      !!             and total ocean freshwater fluxes  
+      !!
+      !! ** Method  :   receive all fields from the atmosphere and transform 
+      !!              them into ocean surface boundary condition fields 
+      !!
+      !! ** Action  :   update  utau, vtau   ocean stress at U,V grid 
+      !!                        taum         wind stress module at T-point
+      !!                        wndm         wind speed  module at T-point over free ocean or leads in presence of sea-ice
+      !!                        qns          non solar heat fluxes including emp heat content    (ocean only case)
+      !!                                     and the latent heat flux of solid precip. melting
+      !!                        qsr          solar ocean heat fluxes   (ocean only case)
+      !!                        emp          upward mass flux [evap. - precip. (- runoffs) (- calving)] (ocean only case)
+      !!----------------------------------------------------------------------
+      USE zdf_oce,  ONLY :   ln_zdfswm
+      !
+      INTEGER, INTENT(in) ::   kt          ! ocean model time step index
+      INTEGER, INTENT(in) ::   k_fsbc      ! frequency of sbc (-> ice model) computation 
+      INTEGER, INTENT(in) ::   k_ice       ! ice management in the sbc (=0/1/2/3)
+      !!
+      LOGICAL  ::   llnewtx, llnewtau      ! update wind stress components and module??
+      INTEGER  ::   ji, jj, jn             ! dummy loop indices
+      INTEGER  ::   isec                   ! number of seconds since nit000 (assuming rdt did not change since nit000)
+      REAL(wp) ::   zcumulneg, zcumulpos   ! temporary scalars     
+      REAL(wp) ::   zcoef                  ! temporary scalar
+      REAL(wp) ::   zrhoa  = 1.22          ! Air density kg/m3
+      REAL(wp) ::   zcdrag = 1.5e-3        ! drag coefficient
+      REAL(wp) ::   zzx, zzy               ! temporary variables
+      REAL(wp), DIMENSION(jpi,jpj) ::   ztx, zty, zmsk, zemp, zqns, zqsr
+      !!----------------------------------------------------------------------
+      !
+      IF( ln_mixcpl )   zmsk(:,:) = 1. - xcplmask(:,:,0)
+      !
+      !                                                      ! ======================================================= !
+      !                                                      ! Receive all the atmos. fields (including ice information)
+      !                                                      ! ======================================================= !
+      isec = ( kt - nit000 ) * NINT( rdt )                      ! date of exchanges
+      DO jn = 1, jprcv                                          ! received fields sent by the atmosphere
+         IF( srcv(jn)%laction )   CALL cpl_rcv( jn, isec, frcv(jn)%z3, xcplmask(:,:,1:nn_cplmodel), nrcvinfo(jn) )
+      END DO
+
+      !                                                      ! ========================= !
+      IF( srcv(jpr_otx1)%laction ) THEN                      !  ocean stress components  !
+         !                                                   ! ========================= !
+         ! define frcv(jpr_otx1)%z3(:,:,1) and frcv(jpr_oty1)%z3(:,:,1): stress at U/V point along model grid
+         ! => need to be done only when we receive the field
+         IF(  nrcvinfo(jpr_otx1) == OASIS_Rcv ) THEN
+            !
+            IF( TRIM( sn_rcv_tau%clvref ) == 'cartesian' ) THEN            ! 2 components on the sphere
+               !                                                       ! (cartesian to spherical -> 3 to 2 components)
+               !
+               CALL geo2oce( frcv(jpr_otx1)%z3(:,:,1), frcv(jpr_oty1)%z3(:,:,1), frcv(jpr_otz1)%z3(:,:,1),   &
+                  &          srcv(jpr_otx1)%clgrid, ztx, zty )
+               frcv(jpr_otx1)%z3(:,:,1) = ztx(:,:)   ! overwrite 1st comp. on the 1st grid
+               frcv(jpr_oty1)%z3(:,:,1) = zty(:,:)   ! overwrite 2nd comp. on the 1st grid
+               !
+               IF( srcv(jpr_otx2)%laction ) THEN
+                  CALL geo2oce( frcv(jpr_otx2)%z3(:,:,1), frcv(jpr_oty2)%z3(:,:,1), frcv(jpr_otz2)%z3(:,:,1),   &
+                     &          srcv(jpr_otx2)%clgrid, ztx, zty )
+                  frcv(jpr_otx2)%z3(:,:,1) = ztx(:,:)   ! overwrite 1st comp. on the 2nd grid
+                  frcv(jpr_oty2)%z3(:,:,1) = zty(:,:)   ! overwrite 2nd comp. on the 2nd grid
+               ENDIF
+               !
+            ENDIF
+            !
+            IF( TRIM( sn_rcv_tau%clvor ) == 'eastward-northward' ) THEN   ! 2 components oriented along the local grid
+               !                                                       ! (geographical to local grid -> rotate the components)
+               CALL rot_rep( frcv(jpr_otx1)%z3(:,:,1), frcv(jpr_oty1)%z3(:,:,1), srcv(jpr_otx1)%clgrid, 'en->i', ztx )   
+               IF( srcv(jpr_otx2)%laction ) THEN
+                  CALL rot_rep( frcv(jpr_otx2)%z3(:,:,1), frcv(jpr_oty2)%z3(:,:,1), srcv(jpr_otx2)%clgrid, 'en->j', zty )   
+               ELSE
+                  CALL rot_rep( frcv(jpr_otx1)%z3(:,:,1), frcv(jpr_oty1)%z3(:,:,1), srcv(jpr_otx1)%clgrid, 'en->j', zty )  
+               ENDIF
+               frcv(jpr_otx1)%z3(:,:,1) = ztx(:,:)      ! overwrite 1st component on the 1st grid
+               frcv(jpr_oty1)%z3(:,:,1) = zty(:,:)      ! overwrite 2nd component on the 2nd grid
+            ENDIF
+            !                              
+            IF( srcv(jpr_otx1)%clgrid == 'T' ) THEN
+               DO jj = 2, jpjm1                                          ! T ==> (U,V)
+                  DO ji = fs_2, fs_jpim1   ! vector opt.
+                     frcv(jpr_otx1)%z3(ji,jj,1) = 0.5 * ( frcv(jpr_otx1)%z3(ji+1,jj  ,1) + frcv(jpr_otx1)%z3(ji,jj,1) )
+                     frcv(jpr_oty1)%z3(ji,jj,1) = 0.5 * ( frcv(jpr_oty1)%z3(ji  ,jj+1,1) + frcv(jpr_oty1)%z3(ji,jj,1) )
+                  END DO
+               END DO
+               CALL lbc_lnk_multi( frcv(jpr_otx1)%z3(:,:,1), 'U',  -1., frcv(jpr_oty1)%z3(:,:,1), 'V',  -1. )
+            ENDIF
+            llnewtx = .TRUE.
+         ELSE
+            llnewtx = .FALSE.
+         ENDIF
+         !                                                   ! ========================= !
+      ELSE                                                   !   No dynamical coupling   !
+         !                                                   ! ========================= !
+         frcv(jpr_otx1)%z3(:,:,1) = 0.e0                               ! here simply set to zero 
+         frcv(jpr_oty1)%z3(:,:,1) = 0.e0                               ! an external read in a file can be added instead
+         llnewtx = .TRUE.
+         !
+      ENDIF
+      !                                                      ! ========================= !
+      !                                                      !    wind stress module     !   (taum)
+      !                                                      ! ========================= !
+      IF( .NOT. srcv(jpr_taum)%laction ) THEN                    ! compute wind stress module from its components if not received 
+         ! => need to be done only when otx1 was changed
+         IF( llnewtx ) THEN
+            DO jj = 2, jpjm1
+               DO ji = fs_2, fs_jpim1   ! vect. opt.
+                  zzx = frcv(jpr_otx1)%z3(ji-1,jj  ,1) + frcv(jpr_otx1)%z3(ji,jj,1)
+                  zzy = frcv(jpr_oty1)%z3(ji  ,jj-1,1) + frcv(jpr_oty1)%z3(ji,jj,1)
+                  frcv(jpr_taum)%z3(ji,jj,1) = 0.5 * SQRT( zzx * zzx + zzy * zzy )
+               END DO
+            END DO
+            CALL lbc_lnk( frcv(jpr_taum)%z3(:,:,1), 'T', 1. )
+            llnewtau = .TRUE.
+         ELSE
+            llnewtau = .FALSE.
+         ENDIF
+      ELSE
+         llnewtau = nrcvinfo(jpr_taum) == OASIS_Rcv
+         ! Stress module can be negative when received (interpolation problem)
+         IF( llnewtau ) THEN 
+            frcv(jpr_taum)%z3(:,:,1) = MAX( 0._wp, frcv(jpr_taum)%z3(:,:,1) )
+         ENDIF
+      ENDIF
+      !
+      !                                                      ! ========================= !
+      !                                                      !      10 m wind speed      !   (wndm)
+      !                                                      ! ========================= !
+      IF( .NOT. srcv(jpr_w10m)%laction ) THEN                    ! compute wind spreed from wind stress module if not received  
+         ! => need to be done only when taumod was changed
+         IF( llnewtau ) THEN 
+            zcoef = 1. / ( zrhoa * zcdrag ) 
+            DO jj = 1, jpj
+               DO ji = 1, jpi 
+                  frcv(jpr_w10m)%z3(ji,jj,1) = SQRT( frcv(jpr_taum)%z3(ji,jj,1) * zcoef )
+               END DO
+            END DO
+         ENDIF
+      ENDIF
+
+      ! u(v)tau and taum will be modified by ice model
+      ! -> need to be reset before each call of the ice/fsbc      
+      IF( MOD( kt-1, k_fsbc ) == 0 ) THEN
+         !
+         IF( ln_mixcpl ) THEN
+            utau(:,:) = utau(:,:) * xcplmask(:,:,0) + frcv(jpr_otx1)%z3(:,:,1) * zmsk(:,:)
+            vtau(:,:) = vtau(:,:) * xcplmask(:,:,0) + frcv(jpr_oty1)%z3(:,:,1) * zmsk(:,:)
+            taum(:,:) = taum(:,:) * xcplmask(:,:,0) + frcv(jpr_taum)%z3(:,:,1) * zmsk(:,:)
+            wndm(:,:) = wndm(:,:) * xcplmask(:,:,0) + frcv(jpr_w10m)%z3(:,:,1) * zmsk(:,:)
+         ELSE
+            utau(:,:) = frcv(jpr_otx1)%z3(:,:,1)
+            vtau(:,:) = frcv(jpr_oty1)%z3(:,:,1)
+            taum(:,:) = frcv(jpr_taum)%z3(:,:,1)
+            wndm(:,:) = frcv(jpr_w10m)%z3(:,:,1)
+         ENDIF
+         CALL iom_put( "taum_oce", taum )   ! output wind stress module
+         !  
+      ENDIF
+
+      !                                                      ! ================== !
+      !                                                      ! atmosph. CO2 (ppm) !
+      !                                                      ! ================== !
+      IF( srcv(jpr_co2)%laction )   atm_co2(:,:) = frcv(jpr_co2)%z3(:,:,1)
+      !
+      !                                                      ! ================== !
+      !                                                      !   ice skin temp.   !
+      !                                                      ! ================== !
+#if defined key_si3
+      ! needed by Met Office
+      IF( srcv(jpr_ts_ice)%laction ) THEN 
+         WHERE    ( frcv(jpr_ts_ice)%z3(:,:,:) > 0.0  )   ;   tsfc_ice(:,:,:) = 0.0 
+         ELSEWHERE( frcv(jpr_ts_ice)%z3(:,:,:) < -60. )   ;   tsfc_ice(:,:,:) = -60.
+         ELSEWHERE                                        ;   tsfc_ice(:,:,:) = frcv(jpr_ts_ice)%z3(:,:,:)
+         END WHERE
+      ENDIF 
+#endif
+      !                                                      ! ========================= ! 
+      !                                                      ! Mean Sea Level Pressure   !   (taum) 
+      !                                                      ! ========================= ! 
+      IF( srcv(jpr_mslp)%laction ) THEN                    ! UKMO SHELF effect of atmospheric pressure on SSH 
+          IF( kt /= nit000 )   ssh_ibb(:,:) = ssh_ib(:,:)    !* Swap of ssh_ib fields 
+
+          r1_grau = 1.e0 / (grav * rau0)               !* constant for optimization 
+          ssh_ib(:,:) = - ( frcv(jpr_mslp)%z3(:,:,1) - rpref ) * r1_grau    ! equivalent ssh (inverse barometer) 
+          apr   (:,:) =     frcv(jpr_mslp)%z3(:,:,1)                         !atmospheric pressure 
+    
+          IF( kt == nit000 ) ssh_ibb(:,:) = ssh_ib(:,:)  ! correct this later (read from restart if possible) 
+      END IF 
+      !
+      IF( ln_sdw ) THEN  ! Stokes Drift correction activated
+      !                                                      ! ========================= ! 
+      !                                                      !       Stokes drift u      !
+      !                                                      ! ========================= ! 
+         IF( srcv(jpr_sdrftx)%laction ) ut0sd(:,:) = frcv(jpr_sdrftx)%z3(:,:,1)
+      !
+      !                                                      ! ========================= ! 
+      !                                                      !       Stokes drift v      !
+      !                                                      ! ========================= ! 
+         IF( srcv(jpr_sdrfty)%laction ) vt0sd(:,:) = frcv(jpr_sdrfty)%z3(:,:,1)
+      !
+      !                                                      ! ========================= ! 
+      !                                                      !      Wave mean period     !
+      !                                                      ! ========================= ! 
+         IF( srcv(jpr_wper)%laction ) wmp(:,:) = frcv(jpr_wper)%z3(:,:,1)
+      !
+      !                                                      ! ========================= ! 
+      !                                                      !  Significant wave height  !
+      !                                                      ! ========================= ! 
+         IF( srcv(jpr_hsig)%laction ) hsw(:,:) = frcv(jpr_hsig)%z3(:,:,1)
+      ! 
+      !                                                      ! ========================= !  
+      !                                                      !    Wave peak frequency    ! 
+      !                                                      ! ========================= !  
+         IF( srcv(jpr_wfreq)%laction ) wfreq(:,:) = frcv(jpr_wfreq)%z3(:,:,1)
+      !
+      !                                                      ! ========================= ! 
+      !                                                      !    Vertical mixing Qiao   !
+      !                                                      ! ========================= ! 
+         IF( srcv(jpr_wnum)%laction .AND. ln_zdfswm ) wnum(:,:) = frcv(jpr_wnum)%z3(:,:,1)
+
+         ! Calculate the 3D Stokes drift both in coupled and not fully uncoupled mode
+         IF( srcv(jpr_sdrftx)%laction .OR. srcv(jpr_sdrfty)%laction .OR. srcv(jpr_wper)%laction &
+                                      .OR. srcv(jpr_hsig)%laction   .OR. srcv(jpr_wfreq)%laction) THEN
+            CALL sbc_stokes()
+         ENDIF
+      ENDIF
+      !                                                      ! ========================= ! 
+      !                                                      ! Stress adsorbed by waves  !
+      !                                                      ! ========================= ! 
+      IF( srcv(jpr_tauwoc)%laction .AND. ln_tauwoc ) tauoc_wave(:,:) = frcv(jpr_tauwoc)%z3(:,:,1)
+
+      !                                                      ! ========================= !  
+      !                                                      ! Stress component by waves ! 
+      !                                                      ! ========================= !  
+      IF( srcv(jpr_tauwx)%laction .AND. srcv(jpr_tauwy)%laction .AND. ln_tauw ) THEN
+         tauw_x(:,:) = frcv(jpr_tauwx)%z3(:,:,1)
+         tauw_y(:,:) = frcv(jpr_tauwy)%z3(:,:,1)
+      ENDIF
+
+      !                                                      ! ========================= ! 
+      !                                                      !   Wave drag coefficient   !
+      !                                                      ! ========================= ! 
+      IF( srcv(jpr_wdrag)%laction .AND. ln_cdgw )   cdn_wave(:,:) = frcv(jpr_wdrag)%z3(:,:,1)
+
+      !  Fields received by SAS when OASIS coupling
+      !  (arrays no more filled at sbcssm stage)
+      !                                                      ! ================== !
+      !                                                      !        SSS         !
+      !                                                      ! ================== !
+      IF( srcv(jpr_soce)%laction ) THEN                      ! received by sas in case of opa <-> sas coupling
+         sss_m(:,:) = frcv(jpr_soce)%z3(:,:,1)
+         CALL iom_put( 'sss_m', sss_m )
+      ENDIF
+      !                                               
+      !                                                      ! ================== !
+      !                                                      !        SST         !
+      !                                                      ! ================== !
+      IF( srcv(jpr_toce)%laction ) THEN                      ! received by sas in case of opa <-> sas coupling
+         sst_m(:,:) = frcv(jpr_toce)%z3(:,:,1)
+         IF( srcv(jpr_soce)%laction .AND. l_useCT ) THEN    ! make sure that sst_m is the potential temperature
+            sst_m(:,:) = eos_pt_from_ct( sst_m(:,:), sss_m(:,:) )
+         ENDIF
+      ENDIF
+      !                                                      ! ================== !
+      !                                                      !        SSH         !
+      !                                                      ! ================== !
+      IF( srcv(jpr_ssh )%laction ) THEN                      ! received by sas in case of opa <-> sas coupling
+         ssh_m(:,:) = frcv(jpr_ssh )%z3(:,:,1)
+         CALL iom_put( 'ssh_m', ssh_m )
+      ENDIF
+      !                                                      ! ================== !
+      !                                                      !  surface currents  !
+      !                                                      ! ================== !
+      IF( srcv(jpr_ocx1)%laction ) THEN                      ! received by sas in case of opa <-> sas coupling
+         ssu_m(:,:) = frcv(jpr_ocx1)%z3(:,:,1)
+         ub (:,:,1) = ssu_m(:,:)                             ! will be used in icestp in the call of lim_sbc_tau
+         un (:,:,1) = ssu_m(:,:)                             ! will be used in sbc_cpl_snd if atmosphere coupling
+         CALL iom_put( 'ssu_m', ssu_m )
+      ENDIF
+      IF( srcv(jpr_ocy1)%laction ) THEN
+         ssv_m(:,:) = frcv(jpr_ocy1)%z3(:,:,1)
+         vb (:,:,1) = ssv_m(:,:)                             ! will be used in icestp in the call of lim_sbc_tau
+         vn (:,:,1) = ssv_m(:,:)                             ! will be used in sbc_cpl_snd if atmosphere coupling
+         CALL iom_put( 'ssv_m', ssv_m )
+      ENDIF
+      !                                                      ! ======================== !
+      !                                                      !  first T level thickness !
+      !                                                      ! ======================== !
+      IF( srcv(jpr_e3t1st )%laction ) THEN                   ! received by sas in case of opa <-> sas coupling
+         e3t_m(:,:) = frcv(jpr_e3t1st )%z3(:,:,1)
+         CALL iom_put( 'e3t_m', e3t_m(:,:) )
+      ENDIF
+      !                                                      ! ================================ !
+      !                                                      !  fraction of solar net radiation !
+      !                                                      ! ================================ !
+      IF( srcv(jpr_fraqsr)%laction ) THEN                    ! received by sas in case of opa <-> sas coupling
+         frq_m(:,:) = frcv(jpr_fraqsr)%z3(:,:,1)
+         CALL iom_put( 'frq_m', frq_m )
+      ENDIF
+      
+      !                                                      ! ========================= !
+      IF( k_ice <= 1 .AND. MOD( kt-1, k_fsbc ) == 0 ) THEN   !  heat & freshwater fluxes ! (Ocean only case)
+         !                                                   ! ========================= !
+         !
+         !                                                       ! total freshwater fluxes over the ocean (emp)
+         IF( srcv(jpr_oemp)%laction .OR. srcv(jpr_rain)%laction ) THEN
+            SELECT CASE( TRIM( sn_rcv_emp%cldes ) )                                    ! evaporation - precipitation
+            CASE( 'conservative' )
+               zemp(:,:) = frcv(jpr_tevp)%z3(:,:,1) - ( frcv(jpr_rain)%z3(:,:,1) + frcv(jpr_snow)%z3(:,:,1) )
+            CASE( 'oce only', 'oce and ice' )
+               zemp(:,:) = frcv(jpr_oemp)%z3(:,:,1)
+            CASE default
+               CALL ctl_stop( 'sbc_cpl_rcv: wrong definition of sn_rcv_emp%cldes' )
+            END SELECT
+         ELSE
+            zemp(:,:) = 0._wp
+         ENDIF
+         !
+         !                                                        ! runoffs and calving (added in emp)
+         IF( srcv(jpr_rnf)%laction )     rnf(:,:) = frcv(jpr_rnf)%z3(:,:,1)
+         IF( srcv(jpr_cal)%laction )     zemp(:,:) = zemp(:,:) - frcv(jpr_cal)%z3(:,:,1)
+ 
+         IF( srcv(jpr_icb)%laction )  THEN 
+             fwficb(:,:) = frcv(jpr_icb)%z3(:,:,1)
+             rnf(:,:)    = rnf(:,:) + fwficb(:,:)   ! iceberg added to runfofs
+         ENDIF
+         IF( srcv(jpr_isf)%laction )  fwfisf(:,:) = - frcv(jpr_isf)%z3(:,:,1)  ! fresh water flux from the isf (fwfisf <0 mean melting)  
+        
+         IF( ln_mixcpl ) THEN   ;   emp(:,:) = emp(:,:) * xcplmask(:,:,0) + zemp(:,:) * zmsk(:,:)
+         ELSE                   ;   emp(:,:) =                              zemp(:,:)
+         ENDIF
+         !
+         !                                                       ! non solar heat flux over the ocean (qns)
+         IF(      srcv(jpr_qnsoce)%laction ) THEN   ;   zqns(:,:) = frcv(jpr_qnsoce)%z3(:,:,1)
+         ELSE IF( srcv(jpr_qnsmix)%laction ) THEN   ;   zqns(:,:) = frcv(jpr_qnsmix)%z3(:,:,1)
+         ELSE                                       ;   zqns(:,:) = 0._wp
+         END IF
+         ! update qns over the free ocean with:
+         IF( nn_components /= jp_iam_opa ) THEN
+            zqns(:,:) =  zqns(:,:) - zemp(:,:) * sst_m(:,:) * rcp         ! remove heat content due to mass flux (assumed to be at SST)
+            IF( srcv(jpr_snow  )%laction ) THEN
+               zqns(:,:) = zqns(:,:) - frcv(jpr_snow)%z3(:,:,1) * lfus    ! energy for melting solid precipitation over the free ocean
+            ENDIF
+         ENDIF
+         !
+         IF( srcv(jpr_icb)%laction )  zqns(:,:) = zqns(:,:) - frcv(jpr_icb)%z3(:,:,1) * lfus ! remove heat content associated to iceberg melting
+         !
+         IF( ln_mixcpl ) THEN   ;   qns(:,:) = qns(:,:) * xcplmask(:,:,0) + zqns(:,:) * zmsk(:,:)
+         ELSE                   ;   qns(:,:) =                              zqns(:,:)
+         ENDIF
+
+         !                                                       ! solar flux over the ocean          (qsr)
+         IF     ( srcv(jpr_qsroce)%laction ) THEN   ;   zqsr(:,:) = frcv(jpr_qsroce)%z3(:,:,1)
+         ELSE IF( srcv(jpr_qsrmix)%laction ) then   ;   zqsr(:,:) = frcv(jpr_qsrmix)%z3(:,:,1)
+         ELSE                                       ;   zqsr(:,:) = 0._wp
+         ENDIF
+         IF( ln_dm2dc .AND. ln_cpl )   zqsr(:,:) = sbc_dcy( zqsr )   ! modify qsr to include the diurnal cycle
+         IF( ln_mixcpl ) THEN   ;   qsr(:,:) = qsr(:,:) * xcplmask(:,:,0) + zqsr(:,:) * zmsk(:,:)
+         ELSE                   ;   qsr(:,:) =                              zqsr(:,:)
+         ENDIF
+         !
+         ! salt flux over the ocean (received by opa in case of opa <-> sas coupling)
+         IF( srcv(jpr_sflx )%laction )   sfx(:,:) = frcv(jpr_sflx  )%z3(:,:,1)
+         ! Ice cover  (received by opa in case of opa <-> sas coupling)
+         IF( srcv(jpr_fice )%laction )   fr_i(:,:) = frcv(jpr_fice )%z3(:,:,1)
+         !
+      ENDIF
+      !
+   END SUBROUTINE sbc_cpl_rcv
+   
+
+   SUBROUTINE sbc_cpl_ice_tau( p_taui, p_tauj )     
+      !!----------------------------------------------------------------------
+      !!             ***  ROUTINE sbc_cpl_ice_tau  ***
+      !!
+      !! ** Purpose :   provide the stress over sea-ice in coupled mode 
+      !!
+      !! ** Method  :   transform the received stress from the atmosphere into
+      !!             an atmosphere-ice stress in the (i,j) ocean referencial
+      !!             and at the velocity point of the sea-ice model (cp_ice_msh):
+      !!                'C'-grid : i- (j-) components given at U- (V-) point 
+      !!                'I'-grid : B-grid lower-left corner: both components given at I-point 
+      !!
+      !!                The received stress are :
+      !!                 - defined by 3 components (if cartesian coordinate)
+      !!                        or by 2 components (if spherical)
+      !!                 - oriented along geographical   coordinate (if eastward-northward)
+      !!                        or  along the local grid coordinate (if local grid)
+      !!                 - given at U- and V-point, resp.   if received on 2 grids
+      !!                        or at a same point (T or I) if received on 1 grid
+      !!                Therefore and if necessary, they are successively 
+      !!             processed in order to obtain them 
+      !!                 first  as  2 components on the sphere 
+      !!                 second as  2 components oriented along the local grid
+      !!                 third  as  2 components on the cp_ice_msh point 
+      !!
+      !!                Except in 'oce and ice' case, only one vector stress field 
+      !!             is received. It has already been processed in sbc_cpl_rcv
+      !!             so that it is now defined as (i,j) components given at U-
+      !!             and V-points, respectively. Therefore, only the third
+      !!             transformation is done and only if the ice-grid is a 'I'-grid. 
+      !!
+      !! ** Action  :   return ptau_i, ptau_j, the stress over the ice at cp_ice_msh point
+      !!----------------------------------------------------------------------
+      REAL(wp), INTENT(out), DIMENSION(:,:) ::   p_taui   ! i- & j-components of atmos-ice stress [N/m2]
+      REAL(wp), INTENT(out), DIMENSION(:,:) ::   p_tauj   ! at I-point (B-grid) or U & V-point (C-grid)
+      !!
+      INTEGER ::   ji, jj   ! dummy loop indices
+      INTEGER ::   itx      ! index of taux over ice
+      REAL(wp), DIMENSION(jpi,jpj) ::   ztx, zty 
+      !!----------------------------------------------------------------------
+      !
+      IF( srcv(jpr_itx1)%laction ) THEN   ;   itx =  jpr_itx1   
+      ELSE                                ;   itx =  jpr_otx1
+      ENDIF
+
+      ! do something only if we just received the stress from atmosphere
+      IF(  nrcvinfo(itx) == OASIS_Rcv ) THEN
+         !                                                      ! ======================= !
+         IF( srcv(jpr_itx1)%laction ) THEN                      !   ice stress received   !
+            !                                                   ! ======================= !
+            !  
+            IF( TRIM( sn_rcv_tau%clvref ) == 'cartesian' ) THEN            ! 2 components on the sphere
+               !                                                       ! (cartesian to spherical -> 3 to 2 components)
+               CALL geo2oce(  frcv(jpr_itx1)%z3(:,:,1), frcv(jpr_ity1)%z3(:,:,1), frcv(jpr_itz1)%z3(:,:,1),   &
+                  &          srcv(jpr_itx1)%clgrid, ztx, zty )
+               frcv(jpr_itx1)%z3(:,:,1) = ztx(:,:)   ! overwrite 1st comp. on the 1st grid
+               frcv(jpr_ity1)%z3(:,:,1) = zty(:,:)   ! overwrite 2nd comp. on the 1st grid
+               !
+               IF( srcv(jpr_itx2)%laction ) THEN
+                  CALL geo2oce( frcv(jpr_itx2)%z3(:,:,1), frcv(jpr_ity2)%z3(:,:,1), frcv(jpr_itz2)%z3(:,:,1),   &
+                     &          srcv(jpr_itx2)%clgrid, ztx, zty )
+                  frcv(jpr_itx2)%z3(:,:,1) = ztx(:,:)   ! overwrite 1st comp. on the 2nd grid
+                  frcv(jpr_ity2)%z3(:,:,1) = zty(:,:)   ! overwrite 2nd comp. on the 2nd grid
+               ENDIF
+               !
+            ENDIF
+            !
+            IF( TRIM( sn_rcv_tau%clvor ) == 'eastward-northward' ) THEN   ! 2 components oriented along the local grid
+               !                                                       ! (geographical to local grid -> rotate the components)
+               CALL rot_rep( frcv(jpr_itx1)%z3(:,:,1), frcv(jpr_ity1)%z3(:,:,1), srcv(jpr_itx1)%clgrid, 'en->i', ztx )   
+               IF( srcv(jpr_itx2)%laction ) THEN
+                  CALL rot_rep( frcv(jpr_itx2)%z3(:,:,1), frcv(jpr_ity2)%z3(:,:,1), srcv(jpr_itx2)%clgrid, 'en->j', zty )   
+               ELSE
+                  CALL rot_rep( frcv(jpr_itx1)%z3(:,:,1), frcv(jpr_ity1)%z3(:,:,1), srcv(jpr_itx1)%clgrid, 'en->j', zty )  
+               ENDIF
+               frcv(jpr_itx1)%z3(:,:,1) = ztx(:,:)      ! overwrite 1st component on the 1st grid
+               frcv(jpr_ity1)%z3(:,:,1) = zty(:,:)      ! overwrite 2nd component on the 1st grid
+            ENDIF
+            !                                                   ! ======================= !
+         ELSE                                                   !     use ocean stress    !
+            !                                                   ! ======================= !
+            frcv(jpr_itx1)%z3(:,:,1) = frcv(jpr_otx1)%z3(:,:,1)
+            frcv(jpr_ity1)%z3(:,:,1) = frcv(jpr_oty1)%z3(:,:,1)
+            !
+         ENDIF
+         !                                                      ! ======================= !
+         !                                                      !     put on ice grid     !
+         !                                                      ! ======================= !
+         !    
+         !                                                  j+1   j     -----V---F
+         ! ice stress on ice velocity point (cp_ice_msh)                 !       |
+         ! (C-grid ==>(U,V) or B-grid ==> I or F)                 j      |   T   U
+         !                                                               |       |
+         !                                                   j    j-1   -I-------|
+         !                                               (for I)         |       |
+         !                                                              i-1  i   i
+         !                                                               i      i+1 (for I)
+         SELECT CASE ( cp_ice_msh )
+            !
+         CASE( 'I' )                                         ! B-grid ==> I
+            SELECT CASE ( srcv(jpr_itx1)%clgrid )
+            CASE( 'U' )
+               DO jj = 2, jpjm1                                   ! (U,V) ==> I
+                  DO ji = 2, jpim1   ! NO vector opt.
+                     p_taui(ji,jj) = 0.5 * ( frcv(jpr_itx1)%z3(ji-1,jj  ,1) + frcv(jpr_itx1)%z3(ji-1,jj-1,1) )
+                     p_tauj(ji,jj) = 0.5 * ( frcv(jpr_ity1)%z3(ji  ,jj-1,1) + frcv(jpr_ity1)%z3(ji-1,jj-1,1) )
+                  END DO
+               END DO
+            CASE( 'F' )
+               DO jj = 2, jpjm1                                   ! F ==> I
+                  DO ji = 2, jpim1   ! NO vector opt.
+                     p_taui(ji,jj) = frcv(jpr_itx1)%z3(ji-1,jj-1,1)
+                     p_tauj(ji,jj) = frcv(jpr_ity1)%z3(ji-1,jj-1,1)
+                  END DO
+               END DO
+            CASE( 'T' )
+               DO jj = 2, jpjm1                                   ! T ==> I
+                  DO ji = 2, jpim1   ! NO vector opt.
+                     p_taui(ji,jj) = 0.25 * ( frcv(jpr_itx1)%z3(ji,jj  ,1) + frcv(jpr_itx1)%z3(ji-1,jj  ,1)   &
+                        &                   + frcv(jpr_itx1)%z3(ji,jj-1,1) + frcv(jpr_itx1)%z3(ji-1,jj-1,1) ) 
+                     p_tauj(ji,jj) = 0.25 * ( frcv(jpr_ity1)%z3(ji,jj  ,1) + frcv(jpr_ity1)%z3(ji-1,jj  ,1)   &
+                        &                   + frcv(jpr_oty1)%z3(ji,jj-1,1) + frcv(jpr_ity1)%z3(ji-1,jj-1,1) )
+                  END DO
+               END DO
+            CASE( 'I' )
+               p_taui(:,:) = frcv(jpr_itx1)%z3(:,:,1)                   ! I ==> I
+               p_tauj(:,:) = frcv(jpr_ity1)%z3(:,:,1)
+            END SELECT
+            IF( srcv(jpr_itx1)%clgrid /= 'I' ) THEN 
+               CALL lbc_lnk_multi( p_taui, 'I',  -1., p_tauj, 'I',  -1. )
+            ENDIF
+            !
+         CASE( 'F' )                                         ! B-grid ==> F
+            SELECT CASE ( srcv(jpr_itx1)%clgrid )
+            CASE( 'U' )
+               DO jj = 2, jpjm1                                   ! (U,V) ==> F
+                  DO ji = fs_2, fs_jpim1   ! vector opt.
+                     p_taui(ji,jj) = 0.5 * ( frcv(jpr_itx1)%z3(ji,jj,1) + frcv(jpr_itx1)%z3(ji  ,jj+1,1) )
+                     p_tauj(ji,jj) = 0.5 * ( frcv(jpr_ity1)%z3(ji,jj,1) + frcv(jpr_ity1)%z3(ji+1,jj  ,1) )
+                  END DO
+               END DO
+            CASE( 'I' )
+               DO jj = 2, jpjm1                                   ! I ==> F
+                  DO ji = 2, jpim1   ! NO vector opt.
+                     p_taui(ji,jj) = frcv(jpr_itx1)%z3(ji+1,jj+1,1)
+                     p_tauj(ji,jj) = frcv(jpr_ity1)%z3(ji+1,jj+1,1)
+                  END DO
+               END DO
+            CASE( 'T' )
+               DO jj = 2, jpjm1                                   ! T ==> F
+                  DO ji = 2, jpim1   ! NO vector opt.
+                     p_taui(ji,jj) = 0.25 * ( frcv(jpr_itx1)%z3(ji,jj  ,1) + frcv(jpr_itx1)%z3(ji+1,jj  ,1)   &
+                        &                   + frcv(jpr_itx1)%z3(ji,jj+1,1) + frcv(jpr_itx1)%z3(ji+1,jj+1,1) ) 
+                     p_tauj(ji,jj) = 0.25 * ( frcv(jpr_ity1)%z3(ji,jj  ,1) + frcv(jpr_ity1)%z3(ji+1,jj  ,1)   &
+                        &                   + frcv(jpr_ity1)%z3(ji,jj+1,1) + frcv(jpr_ity1)%z3(ji+1,jj+1,1) )
+                  END DO
+               END DO
+            CASE( 'F' )
+               p_taui(:,:) = frcv(jpr_itx1)%z3(:,:,1)                   ! F ==> F
+               p_tauj(:,:) = frcv(jpr_ity1)%z3(:,:,1)
+            END SELECT
+            IF( srcv(jpr_itx1)%clgrid /= 'F' ) THEN 
+               CALL lbc_lnk_multi( p_taui, 'F',  -1., p_tauj, 'F',  -1. )
+            ENDIF
+            !
+         CASE( 'C' )                                         ! C-grid ==> U,V
+            SELECT CASE ( srcv(jpr_itx1)%clgrid )
+            CASE( 'U' )
+               p_taui(:,:) = frcv(jpr_itx1)%z3(:,:,1)                   ! (U,V) ==> (U,V)
+               p_tauj(:,:) = frcv(jpr_ity1)%z3(:,:,1)
+            CASE( 'F' )
+               DO jj = 2, jpjm1                                   ! F ==> (U,V)
+                  DO ji = fs_2, fs_jpim1   ! vector opt.
+                     p_taui(ji,jj) = 0.5 * ( frcv(jpr_itx1)%z3(ji,jj,1) + frcv(jpr_itx1)%z3(ji  ,jj-1,1) )
+                     p_tauj(ji,jj) = 0.5 * ( frcv(jpr_ity1)%z3(ji,jj,1) + frcv(jpr_ity1)%z3(ji-1,jj  ,1) )
+                  END DO
+               END DO
+            CASE( 'T' )
+               DO jj = 2, jpjm1                                   ! T ==> (U,V)
+                  DO ji = fs_2, fs_jpim1   ! vector opt.
+                     p_taui(ji,jj) = 0.5 * ( frcv(jpr_itx1)%z3(ji+1,jj  ,1) + frcv(jpr_itx1)%z3(ji,jj,1) )
+                     p_tauj(ji,jj) = 0.5 * ( frcv(jpr_ity1)%z3(ji  ,jj+1,1) + frcv(jpr_ity1)%z3(ji,jj,1) )
+                  END DO
+               END DO
+            CASE( 'I' )
+               DO jj = 2, jpjm1                                   ! I ==> (U,V)
+                  DO ji = 2, jpim1   ! NO vector opt.
+                     p_taui(ji,jj) = 0.5 * ( frcv(jpr_itx1)%z3(ji+1,jj+1,1) + frcv(jpr_itx1)%z3(ji+1,jj  ,1) )
+                     p_tauj(ji,jj) = 0.5 * ( frcv(jpr_ity1)%z3(ji+1,jj+1,1) + frcv(jpr_ity1)%z3(ji  ,jj+1,1) )
+                  END DO
+               END DO
+            END SELECT
+            IF( srcv(jpr_itx1)%clgrid /= 'U' ) THEN 
+               CALL lbc_lnk_multi( p_taui, 'U',  -1., p_tauj, 'V',  -1. )
+            ENDIF
+         END SELECT
+
+      ENDIF
+      !
+   END SUBROUTINE sbc_cpl_ice_tau
+   
+
+   SUBROUTINE sbc_cpl_ice_flx( picefr, palbi, psst, pist, phs, phi )
+      !!----------------------------------------------------------------------
+      !!             ***  ROUTINE sbc_cpl_ice_flx  ***
+      !!
+      !! ** Purpose :   provide the heat and freshwater fluxes of the ocean-ice system
+      !!
+      !! ** Method  :   transform the fields received from the atmosphere into
+      !!             surface heat and fresh water boundary condition for the 
+      !!             ice-ocean system. The following fields are provided:
+      !!               * total non solar, solar and freshwater fluxes (qns_tot, 
+      !!             qsr_tot and emp_tot) (total means weighted ice-ocean flux)
+      !!             NB: emp_tot include runoffs and calving.
+      !!               * fluxes over ice (qns_ice, qsr_ice, emp_ice) where
+      !!             emp_ice = sublimation - solid precipitation as liquid
+      !!             precipitation are re-routed directly to the ocean and 
+      !!             calving directly enter the ocean (runoffs are read but included in trasbc.F90)
+      !!               * solid precipitation (sprecip), used to add to qns_tot 
+      !!             the heat lost associated to melting solid precipitation
+      !!             over the ocean fraction.
+      !!               * heat content of rain, snow and evap can also be provided,
+      !!             otherwise heat flux associated with these mass flux are
+      !!             guessed (qemp_oce, qemp_ice)
+      !!
+      !!             - the fluxes have been separated from the stress as
+      !!               (a) they are updated at each ice time step compare to
+      !!               an update at each coupled time step for the stress, and
+      !!               (b) the conservative computation of the fluxes over the
+      !!               sea-ice area requires the knowledge of the ice fraction
+      !!               after the ice advection and before the ice thermodynamics,
+      !!               so that the stress is updated before the ice dynamics
+      !!               while the fluxes are updated after it.
+      !!
+      !! ** Details
+      !!             qns_tot = (1-a) * qns_oce + a * qns_ice               => provided
+      !!                     + qemp_oce + qemp_ice                         => recalculated and added up to qns
+      !!
+      !!             qsr_tot = (1-a) * qsr_oce + a * qsr_ice               => provided
+      !!
+      !!             emp_tot = emp_oce + emp_ice                           => calving is provided and added to emp_tot (and emp_oce).
+      !!                                                                      runoff (which includes rivers+icebergs) and iceshelf
+      !!                                                                      are provided but not included in emp here. Only runoff will
+      !!                                                                      be included in emp in other parts of NEMO code
+      !! ** Action  :   update at each nf_ice time step:
+      !!                   qns_tot, qsr_tot  non-solar and solar total heat fluxes
+      !!                   qns_ice, qsr_ice  non-solar and solar heat fluxes over the ice
+      !!                   emp_tot           total evaporation - precipitation(liquid and solid) (-calving)
+      !!                   emp_ice           ice sublimation - solid precipitation over the ice
+      !!                   dqns_ice          d(non-solar heat flux)/d(Temperature) over the ice
+      !!                   sprecip           solid precipitation over the ocean  
+      !!----------------------------------------------------------------------
+      REAL(wp), INTENT(in), DIMENSION(:,:)             ::   picefr     ! ice fraction                [0 to 1]
+      !                                                !!           ! optional arguments, used only in 'mixed oce-ice' case
+      REAL(wp), INTENT(in), DIMENSION(:,:,:), OPTIONAL ::   palbi      ! all skies ice albedo 
+      REAL(wp), INTENT(in), DIMENSION(:,:  ), OPTIONAL ::   psst       ! sea surface temperature     [Celsius]
+      REAL(wp), INTENT(in), DIMENSION(:,:,:), OPTIONAL ::   pist       ! ice surface temperature     [Kelvin]
+      REAL(wp), INTENT(in), DIMENSION(:,:,:), OPTIONAL ::   phs        ! snow depth                  [m]
+      REAL(wp), INTENT(in), DIMENSION(:,:,:), OPTIONAL ::   phi        ! ice thickness               [m]
+      !
+      INTEGER  ::   ji, jj, jl   ! dummy loop index
+      REAL(wp) ::   ztri         ! local scalar
+      REAL(wp), DIMENSION(jpi,jpj)     ::   zcptn, zcptrain, zcptsnw, ziceld, zmsk, zsnw
+      REAL(wp), DIMENSION(jpi,jpj)     ::   zemp_tot, zemp_ice, zemp_oce, ztprecip, zsprecip  , zevap_oce, zdevap_ice
+      REAL(wp), DIMENSION(jpi,jpj)     ::   zqns_tot, zqns_oce, zqsr_tot, zqsr_oce, zqprec_ice, zqemp_oce, zqemp_ice
+      REAL(wp), DIMENSION(jpi,jpj,jpl) ::   zqns_ice, zqsr_ice, zdqns_ice, zqevap_ice, zevap_ice    !!gm , zfrqsr_tr_i
+      !!----------------------------------------------------------------------
+      !
+      IF( ln_mixcpl )   zmsk(:,:) = 1. - xcplmask(:,:,0)
+      ziceld(:,:) = 1._wp - picefr(:,:)
+      zcptn (:,:) = rcp * sst_m(:,:)
+      !
+      !                                                      ! ========================= !
+      !                                                      !    freshwater budget      !   (emp_tot)
+      !                                                      ! ========================= !
+      !
+      !                                                           ! solid Precipitation                                (sprecip)
+      !                                                           ! liquid + solid Precipitation                       (tprecip)
+      !                                                           ! total Evaporation - total Precipitation            (emp_tot)
+      !                                                           ! sublimation - solid precipitation (cell average)   (emp_ice)
+      SELECT CASE( TRIM( sn_rcv_emp%cldes ) )
+      CASE( 'conservative' )   ! received fields: jpr_rain, jpr_snow, jpr_ievp, jpr_tevp
+         zsprecip(:,:) =   frcv(jpr_snow)%z3(:,:,1)                  ! May need to ensure positive here
+         ztprecip(:,:) =   frcv(jpr_rain)%z3(:,:,1) + zsprecip(:,:)  ! May need to ensure positive here
+         zemp_tot(:,:) =   frcv(jpr_tevp)%z3(:,:,1) - ztprecip(:,:)
+         zemp_ice(:,:) = ( frcv(jpr_ievp)%z3(:,:,1) - frcv(jpr_snow)%z3(:,:,1) ) * picefr(:,:)
+      CASE( 'oce and ice'   )   ! received fields: jpr_sbpr, jpr_semp, jpr_oemp, jpr_ievp
+         zemp_tot(:,:) = ziceld(:,:) * frcv(jpr_oemp)%z3(:,:,1) + picefr(:,:) * frcv(jpr_sbpr)%z3(:,:,1)
+         zemp_ice(:,:) = frcv(jpr_semp)%z3(:,:,1) * picefr(:,:)
+         zsprecip(:,:) = frcv(jpr_ievp)%z3(:,:,1) - frcv(jpr_semp)%z3(:,:,1)
+         ztprecip(:,:) = frcv(jpr_semp)%z3(:,:,1) - frcv(jpr_sbpr)%z3(:,:,1) + zsprecip(:,:)
+      END SELECT
+
+#if defined key_si3
+      ! zsnw = snow fraction over ice after wind blowing (=picefr if no blowing)
+      zsnw(:,:) = 0._wp   ;   CALL ice_thd_snwblow( ziceld, zsnw )
+      
+      ! --- evaporation minus precipitation corrected (because of wind blowing on snow) --- !
+      zemp_ice(:,:) = zemp_ice(:,:) + zsprecip(:,:) * ( picefr(:,:) - zsnw(:,:) )  ! emp_ice = A * sublimation - zsnw * sprecip
+      zemp_oce(:,:) = zemp_tot(:,:) - zemp_ice(:,:)                                ! emp_oce = emp_tot - emp_ice
+
+      ! --- evaporation over ocean (used later for qemp) --- !
+      zevap_oce(:,:) = frcv(jpr_tevp)%z3(:,:,1) - frcv(jpr_ievp)%z3(:,:,1) * picefr(:,:)
+
+      ! --- evaporation over ice (kg/m2/s) --- !
+      DO jl=1,jpl
+         IF (sn_rcv_emp%clcat == 'yes') THEN   ;   zevap_ice(:,:,jl) = frcv(jpr_ievp)%z3(:,:,jl)
+         ELSE                                  ;   zevap_ice(:,:,jl) = frcv(jpr_ievp)%z3(:,:,1 )   ;   ENDIF
+      ENDDO
+
+      ! since the sensitivity of evap to temperature (devap/dT) is not prescribed by the atmosphere, we set it to 0
+      ! therefore, sublimation is not redistributed over the ice categories when no subgrid scale fluxes are provided by atm.
+      zdevap_ice(:,:) = 0._wp
+      
+      ! --- Continental fluxes --- !
+      IF( srcv(jpr_rnf)%laction ) THEN   ! runoffs (included in emp later on)
+         rnf(:,:) = frcv(jpr_rnf)%z3(:,:,1)
+      ENDIF
+      IF( srcv(jpr_cal)%laction ) THEN   ! calving (put in emp_tot and emp_oce)
+         zemp_tot(:,:) = zemp_tot(:,:) - frcv(jpr_cal)%z3(:,:,1)
+         zemp_oce(:,:) = zemp_oce(:,:) - frcv(jpr_cal)%z3(:,:,1)
+      ENDIF
+      IF( srcv(jpr_icb)%laction ) THEN   ! iceberg added to runoffs
+         fwficb(:,:) = frcv(jpr_icb)%z3(:,:,1)
+         rnf(:,:)    = rnf(:,:) + fwficb(:,:)
+      ENDIF
+      IF( srcv(jpr_isf)%laction ) THEN   ! iceshelf (fwfisf <0 mean melting)
+        fwfisf(:,:) = - frcv(jpr_isf)%z3(:,:,1)  
+      ENDIF
+
+      IF( ln_mixcpl ) THEN
+         emp_tot(:,:) = emp_tot(:,:) * xcplmask(:,:,0) + zemp_tot(:,:) * zmsk(:,:)
+         emp_ice(:,:) = emp_ice(:,:) * xcplmask(:,:,0) + zemp_ice(:,:) * zmsk(:,:)
+         emp_oce(:,:) = emp_oce(:,:) * xcplmask(:,:,0) + zemp_oce(:,:) * zmsk(:,:)
+         sprecip(:,:) = sprecip(:,:) * xcplmask(:,:,0) + zsprecip(:,:) * zmsk(:,:)
+         tprecip(:,:) = tprecip(:,:) * xcplmask(:,:,0) + ztprecip(:,:) * zmsk(:,:)
+         DO jl = 1, jpl
+            evap_ice (:,:,jl) = evap_ice (:,:,jl) * xcplmask(:,:,0) + zevap_ice (:,:,jl) * zmsk(:,:)
+            devap_ice(:,:,jl) = devap_ice(:,:,jl) * xcplmask(:,:,0) + zdevap_ice(:,:)    * zmsk(:,:)
+         END DO
+      ELSE
+         emp_tot (:,:)   = zemp_tot (:,:)
+         emp_ice (:,:)   = zemp_ice (:,:)
+         emp_oce (:,:)   = zemp_oce (:,:)     
+         sprecip (:,:)   = zsprecip (:,:)
+         tprecip (:,:)   = ztprecip (:,:)
+         evap_ice(:,:,:) = zevap_ice(:,:,:)
+         DO jl = 1, jpl
+            devap_ice(:,:,jl) = zdevap_ice(:,:)
+         END DO
+      ENDIF
+
+#else
+      zsnw(:,:) = picefr(:,:)
+      ! --- Continental fluxes --- !
+      IF( srcv(jpr_rnf)%laction ) THEN   ! runoffs (included in emp later on)
+         rnf(:,:) = frcv(jpr_rnf)%z3(:,:,1)
+      ENDIF
+      IF( srcv(jpr_cal)%laction ) THEN   ! calving (put in emp_tot)
+         zemp_tot(:,:) = zemp_tot(:,:) - frcv(jpr_cal)%z3(:,:,1)
+      ENDIF
+      IF( srcv(jpr_icb)%laction ) THEN   ! iceberg added to runoffs
+         fwficb(:,:) = frcv(jpr_icb)%z3(:,:,1)
+         rnf(:,:)    = rnf(:,:) + fwficb(:,:)
+      ENDIF
+      IF( srcv(jpr_isf)%laction ) THEN   ! iceshelf (fwfisf <0 mean melting)
+        fwfisf(:,:) = - frcv(jpr_isf)%z3(:,:,1)
+      ENDIF
+      !
+      IF( ln_mixcpl ) THEN
+         emp_tot(:,:) = emp_tot(:,:) * xcplmask(:,:,0) + zemp_tot(:,:) * zmsk(:,:)
+         emp_ice(:,:) = emp_ice(:,:) * xcplmask(:,:,0) + zemp_ice(:,:) * zmsk(:,:)
+         sprecip(:,:) = sprecip(:,:) * xcplmask(:,:,0) + zsprecip(:,:) * zmsk(:,:)
+         tprecip(:,:) = tprecip(:,:) * xcplmask(:,:,0) + ztprecip(:,:) * zmsk(:,:)
+      ELSE
+         emp_tot(:,:) =                                  zemp_tot(:,:)
+         emp_ice(:,:) =                                  zemp_ice(:,:)
+         sprecip(:,:) =                                  zsprecip(:,:)
+         tprecip(:,:) =                                  ztprecip(:,:)
+      ENDIF
+      !
+#endif
+
+      ! outputs
+!!      IF( srcv(jpr_rnf)%laction )   CALL iom_put( 'runoffs' , rnf(:,:) * tmask(:,:,1)                                 )  ! runoff
+!!      IF( srcv(jpr_isf)%laction )   CALL iom_put( 'iceshelf_cea', -fwfisf(:,:) * tmask(:,:,1)                         )  ! iceshelf
+      IF( srcv(jpr_cal)%laction )   CALL iom_put( 'calving_cea' , frcv(jpr_cal)%z3(:,:,1) * tmask(:,:,1)                )  ! calving
+      IF( srcv(jpr_icb)%laction )   CALL iom_put( 'iceberg_cea' , frcv(jpr_icb)%z3(:,:,1) * tmask(:,:,1)                )  ! icebergs
+      IF( iom_use('snowpre') )      CALL iom_put( 'snowpre'     , sprecip(:,:)                                          )  ! Snow
+      IF( iom_use('precip') )       CALL iom_put( 'precip'      , tprecip(:,:)                                          )  ! total  precipitation
+      IF( iom_use('rain') )         CALL iom_put( 'rain'        , tprecip(:,:) - sprecip(:,:)                           )  ! liquid precipitation 
+      IF( iom_use('snow_ao_cea') )  CALL iom_put( 'snow_ao_cea' , sprecip(:,:) * ( 1._wp - zsnw(:,:) )                  )  ! Snow over ice-free ocean  (cell average)
+      IF( iom_use('snow_ai_cea') )  CALL iom_put( 'snow_ai_cea' , sprecip(:,:) *           zsnw(:,:)                    )  ! Snow over sea-ice         (cell average)
+      IF( iom_use('subl_ai_cea') )  CALL iom_put( 'subl_ai_cea' , frcv(jpr_ievp)%z3(:,:,1) * picefr(:,:) * tmask(:,:,1) )  ! Sublimation over sea-ice (cell average)
+      IF( iom_use('evap_ao_cea') )  CALL iom_put( 'evap_ao_cea' , ( frcv(jpr_tevp)%z3(:,:,1)  &
+         &                                                        - frcv(jpr_ievp)%z3(:,:,1) * picefr(:,:) ) * tmask(:,:,1) )  ! ice-free oce evap (cell average)
+      ! note: runoff output is done in sbcrnf (which includes icebergs too) and iceshelf output is done in sbcisf
+      !
+      !                                                      ! ========================= !
+      SELECT CASE( TRIM( sn_rcv_qns%cldes ) )                !   non solar heat fluxes   !   (qns)
+      !                                                      ! ========================= !
+      CASE( 'oce only' )         ! the required field is directly provided
+         zqns_tot(:,:) = frcv(jpr_qnsoce)%z3(:,:,1)
+      CASE( 'conservative' )     ! the required fields are directly provided
+         zqns_tot(:,:) = frcv(jpr_qnsmix)%z3(:,:,1)
+         IF ( TRIM(sn_rcv_qns%clcat) == 'yes' ) THEN
+            zqns_ice(:,:,1:jpl) = frcv(jpr_qnsice)%z3(:,:,1:jpl)
+         ELSE
+            DO jl = 1, jpl
+               zqns_ice(:,:,jl) = frcv(jpr_qnsice)%z3(:,:,1) ! Set all category values equal
+            END DO
+         ENDIF
+      CASE( 'oce and ice' )      ! the total flux is computed from ocean and ice fluxes
+         zqns_tot(:,:) =  ziceld(:,:) * frcv(jpr_qnsoce)%z3(:,:,1)
+         IF ( TRIM(sn_rcv_qns%clcat) == 'yes' ) THEN
+            DO jl=1,jpl
+               zqns_tot(:,:   ) = zqns_tot(:,:) + a_i(:,:,jl) * frcv(jpr_qnsice)%z3(:,:,jl)   
+               zqns_ice(:,:,jl) = frcv(jpr_qnsice)%z3(:,:,jl)
+            ENDDO
+         ELSE
+            qns_tot(:,:) = qns_tot(:,:) + picefr(:,:) * frcv(jpr_qnsice)%z3(:,:,1)
+            DO jl = 1, jpl
+               zqns_tot(:,:   ) = zqns_tot(:,:) + picefr(:,:) * frcv(jpr_qnsice)%z3(:,:,1)
+               zqns_ice(:,:,jl) = frcv(jpr_qnsice)%z3(:,:,1)
+            END DO
+         ENDIF
+      CASE( 'mixed oce-ice' )    ! the ice flux is cumputed from the total flux, the SST and ice informations
+! ** NEED TO SORT OUT HOW THIS SHOULD WORK IN THE MULTI-CATEGORY CASE - CURRENTLY NOT ALLOWED WHEN INTERFACE INITIALISED **
+         zqns_tot(:,:  ) = frcv(jpr_qnsmix)%z3(:,:,1)
+         zqns_ice(:,:,1) = frcv(jpr_qnsmix)%z3(:,:,1)    &
+            &            + frcv(jpr_dqnsdt)%z3(:,:,1) * ( pist(:,:,1) - ( (rt0 + psst(:,:  ) ) * ziceld(:,:)   &
+            &                                           + pist(:,:,1) * picefr(:,:) ) )
+      END SELECT
+      !                                     
+      ! --- calving (removed from qns_tot) --- !
+      IF( srcv(jpr_cal)%laction )   zqns_tot(:,:) = zqns_tot(:,:) - frcv(jpr_cal)%z3(:,:,1) * lfus  ! remove latent heat of calving
+                                                                                                    ! we suppose it melts at 0deg, though it should be temp. of surrounding ocean
+      ! --- iceberg (removed from qns_tot) --- !
+      IF( srcv(jpr_icb)%laction )   zqns_tot(:,:) = zqns_tot(:,:) - frcv(jpr_icb)%z3(:,:,1) * lfus  ! remove latent heat of iceberg melting
+
+#if defined key_si3      
+      ! --- non solar flux over ocean --- !
+      !         note: ziceld cannot be = 0 since we limit the ice concentration to amax
+      zqns_oce = 0._wp
+      WHERE( ziceld /= 0._wp )   zqns_oce(:,:) = ( zqns_tot(:,:) - SUM( a_i * zqns_ice, dim=3 ) ) / ziceld(:,:)
+
+      ! Heat content per unit mass of snow (J/kg)
+      WHERE( SUM( a_i, dim=3 ) > 1.e-10 )   ;   zcptsnw(:,:) = cpic * SUM( (tn_ice - rt0) * a_i, dim=3 ) / SUM( a_i, dim=3 )
+      ELSEWHERE                             ;   zcptsnw(:,:) = zcptn(:,:)
+      ENDWHERE
+      ! Heat content per unit mass of rain (J/kg)
+      zcptrain(:,:) = rcp * ( SUM( (tn_ice(:,:,:) - rt0) * a_i(:,:,:), dim=3 ) + sst_m(:,:) * ziceld(:,:) ) 
+
+      ! --- enthalpy of snow precip over ice in J/m3 (to be used in 1D-thermo) --- !
+      zqprec_ice(:,:) = rhosn * ( zcptsnw(:,:) - lfus )
+
+      ! --- heat content of evap over ice in W/m2 (to be used in 1D-thermo) --- !
+      DO jl = 1, jpl
+         zqevap_ice(:,:,jl) = 0._wp ! should be -evap * ( ( Tice - rt0 ) * cpic ) but atm. does not take it into account
+      END DO
+
+      ! --- heat flux associated with emp (W/m2) --- !
+      zqemp_oce(:,:) = -  zevap_oce(:,:)                                      *   zcptn   (:,:)   &        ! evap
+         &             + ( ztprecip(:,:) - zsprecip(:,:) )                    *   zcptrain(:,:)   &        ! liquid precip
+         &             +   zsprecip(:,:)                   * ( 1._wp - zsnw ) * ( zcptsnw (:,:) - lfus )   ! solid precip over ocean + snow melting
+      zqemp_ice(:,:) =     zsprecip(:,:)                   * zsnw             * ( zcptsnw (:,:) - lfus )   ! solid precip over ice (qevap_ice=0 since atm. does not take it into account)
+!!    zqemp_ice(:,:) = -   frcv(jpr_ievp)%z3(:,:,1)        * picefr(:,:)      *   zcptsnw (:,:)   &        ! ice evap
+!!       &             +   zsprecip(:,:)                   * zsnw             * zqprec_ice(:,:) * r1_rhosn ! solid precip over ice
+      
+      ! --- total non solar flux (including evap/precip) --- !
+      zqns_tot(:,:) = zqns_tot(:,:) + zqemp_ice(:,:) + zqemp_oce(:,:)
+
+      ! --- in case both coupled/forced are active, we must mix values --- ! 
+      IF( ln_mixcpl ) THEN
+         qns_tot(:,:) = qns_tot(:,:) * xcplmask(:,:,0) + zqns_tot(:,:)* zmsk(:,:)
+         qns_oce(:,:) = qns_oce(:,:) * xcplmask(:,:,0) + zqns_oce(:,:)* zmsk(:,:)
+         DO jl=1,jpl
+            qns_ice  (:,:,jl) = qns_ice  (:,:,jl) * xcplmask(:,:,0) +  zqns_ice  (:,:,jl)* zmsk(:,:)
+            qevap_ice(:,:,jl) = qevap_ice(:,:,jl) * xcplmask(:,:,0) +  zqevap_ice(:,:,jl)* zmsk(:,:)
+         ENDDO
+         qprec_ice(:,:) = qprec_ice(:,:) * xcplmask(:,:,0) + zqprec_ice(:,:)* zmsk(:,:)
+         qemp_oce (:,:) =  qemp_oce(:,:) * xcplmask(:,:,0) +  zqemp_oce(:,:)* zmsk(:,:)
+         qemp_ice (:,:) =  qemp_ice(:,:) * xcplmask(:,:,0) +  zqemp_ice(:,:)* zmsk(:,:)
+      ELSE
+         qns_tot  (:,:  ) = zqns_tot  (:,:  )
+         qns_oce  (:,:  ) = zqns_oce  (:,:  )
+         qns_ice  (:,:,:) = zqns_ice  (:,:,:)
+         qevap_ice(:,:,:) = zqevap_ice(:,:,:)
+         qprec_ice(:,:  ) = zqprec_ice(:,:  )
+         qemp_oce (:,:  ) = zqemp_oce (:,:  )
+         qemp_ice (:,:  ) = zqemp_ice (:,:  )
+      ENDIF
+
+#else
+      zcptsnw (:,:) = zcptn(:,:)
+      zcptrain(:,:) = zcptn(:,:)
+      
+      ! clem: this formulation is certainly wrong... but better than it was...
+      zqns_tot(:,:) = zqns_tot(:,:)                            &          ! zqns_tot update over free ocean with:
+         &          - (  ziceld(:,:) * zsprecip(:,:) * lfus )  &          ! remove the latent heat flux of solid precip. melting
+         &          - (  zemp_tot(:,:)                         &          ! remove the heat content of mass flux (assumed to be at SST)
+         &             - zemp_ice(:,:) ) * zcptn(:,:) 
+
+     IF( ln_mixcpl ) THEN
+         qns_tot(:,:) = qns(:,:) * ziceld(:,:) + SUM( qns_ice(:,:,:) * a_i(:,:,:), dim=3 )   ! total flux from blk
+         qns_tot(:,:) = qns_tot(:,:) * xcplmask(:,:,0) +  zqns_tot(:,:)* zmsk(:,:)
+         DO jl=1,jpl
+            qns_ice(:,:,jl) = qns_ice(:,:,jl) * xcplmask(:,:,0) +  zqns_ice(:,:,jl)* zmsk(:,:)
+         ENDDO
+      ELSE
+         qns_tot(:,:  ) = zqns_tot(:,:  )
+         qns_ice(:,:,:) = zqns_ice(:,:,:)
+      ENDIF
+
+#endif
+      ! outputs
+      IF ( srcv(jpr_cal)%laction       ) CALL iom_put('hflx_cal_cea'    , - frcv(jpr_cal)%z3(:,:,1) * lfus )                       ! latent heat from calving
+      IF ( srcv(jpr_icb)%laction       ) CALL iom_put('hflx_icb_cea'    , - frcv(jpr_icb)%z3(:,:,1) * lfus )                       ! latent heat from icebergs melting
+      IF ( iom_use('hflx_rain_cea')    ) CALL iom_put('hflx_rain_cea'   , ( tprecip(:,:) - sprecip(:,:) ) * zcptrain(:,:) )        ! heat flux from rain (cell average)
+      IF ( iom_use('hflx_evap_cea')    ) CALL iom_put('hflx_evap_cea'   , ( frcv(jpr_tevp)%z3(:,:,1) - frcv(jpr_ievp)%z3(:,:,1) &
+           &                                                              * picefr(:,:) ) * zcptn(:,:) * tmask(:,:,1) )            ! heat flux from evap (cell average)
+      IF ( iom_use('hflx_snow_cea')    ) CALL iom_put('hflx_snow_cea'   , sprecip(:,:) * ( zcptsnw(:,:) - Lfus )   )               ! heat flux from snow (cell average)
+      IF ( iom_use('hflx_snow_ao_cea') ) CALL iom_put('hflx_snow_ao_cea', sprecip(:,:) * ( zcptsnw(:,:) - Lfus ) &
+           &                                                              * ( 1._wp - zsnw(:,:) )                  )               ! heat flux from snow (over ocean)
+      IF ( iom_use('hflx_snow_ai_cea') ) CALL iom_put('hflx_snow_ai_cea', sprecip(:,:) * ( zcptsnw(:,:) - Lfus ) &
+           &                                                              *           zsnw(:,:)                    )               ! heat flux from snow (over ice)
+      ! note: hflx for runoff and iceshelf are done in sbcrnf and sbcisf resp.
+      !
+      !                                                      ! ========================= !
+      SELECT CASE( TRIM( sn_rcv_qsr%cldes ) )                !      solar heat fluxes    !   (qsr)
+      !                                                      ! ========================= !
+      CASE( 'oce only' )
+         zqsr_tot(:,:  ) = MAX( 0._wp , frcv(jpr_qsroce)%z3(:,:,1) )
+      CASE( 'conservative' )
+         zqsr_tot(:,:  ) = frcv(jpr_qsrmix)%z3(:,:,1)
+         IF ( TRIM(sn_rcv_qsr%clcat) == 'yes' ) THEN
+            zqsr_ice(:,:,1:jpl) = frcv(jpr_qsrice)%z3(:,:,1:jpl)
+         ELSE
+            ! Set all category values equal for the moment
+            DO jl = 1, jpl
+               zqsr_ice(:,:,jl) = frcv(jpr_qsrice)%z3(:,:,1)
+            END DO
+         ENDIF
+         zqsr_tot(:,:  ) = frcv(jpr_qsrmix)%z3(:,:,1)
+         zqsr_ice(:,:,1) = frcv(jpr_qsrice)%z3(:,:,1)
+      CASE( 'oce and ice' )
+         zqsr_tot(:,:  ) =  ziceld(:,:) * frcv(jpr_qsroce)%z3(:,:,1)
+         IF ( TRIM(sn_rcv_qsr%clcat) == 'yes' ) THEN
+            DO jl = 1, jpl
+               zqsr_tot(:,:   ) = zqsr_tot(:,:) + a_i(:,:,jl) * frcv(jpr_qsrice)%z3(:,:,jl)   
+               zqsr_ice(:,:,jl) = frcv(jpr_qsrice)%z3(:,:,jl)
+            END DO
+         ELSE
+            qsr_tot(:,:   ) = qsr_tot(:,:) + picefr(:,:) * frcv(jpr_qsrice)%z3(:,:,1)
+            DO jl = 1, jpl
+               zqsr_tot(:,:   ) = zqsr_tot(:,:) + picefr(:,:) * frcv(jpr_qsrice)%z3(:,:,1)
+               zqsr_ice(:,:,jl) = frcv(jpr_qsrice)%z3(:,:,1)
+            END DO
+         ENDIF
+      CASE( 'mixed oce-ice' )
+         zqsr_tot(:,:  ) = frcv(jpr_qsrmix)%z3(:,:,1)
+! ** NEED TO SORT OUT HOW THIS SHOULD WORK IN THE MULTI-CATEGORY CASE - CURRENTLY NOT ALLOWED WHEN INTERFACE INITIALISED **
+!       Create solar heat flux over ice using incoming solar heat flux and albedos
+!       ( see OASIS3 user guide, 5th edition, p39 )
+         zqsr_ice(:,:,1) = frcv(jpr_qsrmix)%z3(:,:,1) * ( 1.- palbi(:,:,1) )   &
+            &            / (  1.- ( alb_oce_mix(:,:  ) * ziceld(:,:)       &
+            &                     + palbi      (:,:,1) * picefr(:,:) ) )
+      END SELECT
+      IF( ln_dm2dc .AND. ln_cpl ) THEN   ! modify qsr to include the diurnal cycle
+         zqsr_tot(:,:  ) = sbc_dcy( zqsr_tot(:,:  ) )
+         DO jl = 1, jpl
+            zqsr_ice(:,:,jl) = sbc_dcy( zqsr_ice(:,:,jl) )
+         END DO
+      ENDIF
+
+#if defined key_si3
+      ! --- solar flux over ocean --- !
+      !         note: ziceld cannot be = 0 since we limit the ice concentration to amax
+      zqsr_oce = 0._wp
+      WHERE( ziceld /= 0._wp )  zqsr_oce(:,:) = ( zqsr_tot(:,:) - SUM( a_i * zqsr_ice, dim=3 ) ) / ziceld(:,:)
+
+      IF( ln_mixcpl ) THEN   ;   qsr_oce(:,:) = qsr_oce(:,:) * xcplmask(:,:,0) +  zqsr_oce(:,:)* zmsk(:,:)
+      ELSE                   ;   qsr_oce(:,:) = zqsr_oce(:,:)   ;   ENDIF
+#endif
+
+      IF( ln_mixcpl ) THEN
+         qsr_tot(:,:) = qsr(:,:) * ziceld(:,:) + SUM( qsr_ice(:,:,:) * a_i(:,:,:), dim=3 )   ! total flux from blk
+         qsr_tot(:,:) = qsr_tot(:,:) * xcplmask(:,:,0) +  zqsr_tot(:,:)* zmsk(:,:)
+         DO jl = 1, jpl
+            qsr_ice(:,:,jl) = qsr_ice(:,:,jl) * xcplmask(:,:,0) +  zqsr_ice(:,:,jl)* zmsk(:,:)
+         END DO
+      ELSE
+         qsr_tot(:,:  ) = zqsr_tot(:,:  )
+         qsr_ice(:,:,:) = zqsr_ice(:,:,:)
+      ENDIF
+
+      !                                                      ! ========================= !
+      SELECT CASE( TRIM( sn_rcv_dqnsdt%cldes ) )             !          d(qns)/dt        !
+      !                                                      ! ========================= !
+      CASE ('coupled')
+         IF ( TRIM(sn_rcv_dqnsdt%clcat) == 'yes' ) THEN
+            zdqns_ice(:,:,1:jpl) = frcv(jpr_dqnsdt)%z3(:,:,1:jpl)
+         ELSE
+            ! Set all category values equal for the moment
+            DO jl=1,jpl
+               zdqns_ice(:,:,jl) = frcv(jpr_dqnsdt)%z3(:,:,1)
+            ENDDO
+         ENDIF
+      END SELECT
+      
+      IF( ln_mixcpl ) THEN
+         DO jl=1,jpl
+            dqns_ice(:,:,jl) = dqns_ice(:,:,jl) * xcplmask(:,:,0) + zdqns_ice(:,:,jl) * zmsk(:,:)
+         ENDDO
+      ELSE
+         dqns_ice(:,:,:) = zdqns_ice(:,:,:)
+      ENDIF
+
+#if defined key_si3      
+      !                                                      ! ========================= !
+      SELECT CASE( TRIM( sn_rcv_iceflx%cldes ) )             !  ice topmelt and botmelt  !
+      !                                                      ! ========================= !
+      CASE ('coupled')
+         qml_ice(:,:,:) = frcv(jpr_topm)%z3(:,:,:) * a_i(:,:,:)
+         qcn_ice(:,:,:) = frcv(jpr_botm)%z3(:,:,:) * a_i(:,:,:)
+      END SELECT
+      !
+      !                                                      ! ========================= !
+      !                                                      !      Transmitted Qsr      !   [W/m2]
+      !                                                      ! ========================= !
+      SELECT CASE( nice_jules )
+      CASE( np_jules_OFF    )       !==  No Jules coupler  ==!
+         !
+         !                    ! ===> used prescribed cloud fraction representative for polar oceans in summer (0.81)
+         ztri = 0.18 * ( 1.0 - cldf_ice ) + 0.35 * cldf_ice    ! surface transmission parameter (Grenfell Maykut 77)
+         !
+         qsr_ice_tr(:,:,:) = ztri * qsr_ice(:,:,:)
+         WHERE( phs(:,:,:) >= 0.0_wp )   qsr_ice_tr(:,:,:) = 0._wp            ! snow fully opaque
+         WHERE( phi(:,:,:) <= 0.1_wp )   qsr_ice_tr(:,:,:) = qsr_ice(:,:,:)   ! thin ice transmits all solar radiation
+         !     
+      CASE( np_jules_ACTIVE )       !==  Jules coupler is active  ==!
+         !
+         !                    ! ===> here we must receive the qsr_ice_tr array from the coupler
+         !                           for now just assume zero (fully opaque ice)
+         qsr_ice_tr(:,:,:) = 0._wp
+         !
+      END SELECT
+      !
+#endif
+      !
+   END SUBROUTINE sbc_cpl_ice_flx
+   
+   
+   SUBROUTINE sbc_cpl_snd( kt )
+      !!----------------------------------------------------------------------
+      !!             ***  ROUTINE sbc_cpl_snd  ***
+      !!
+      !! ** Purpose :   provide the ocean-ice informations to the atmosphere
+      !!
+      !! ** Method  :   send to the atmosphere through a call to cpl_snd
+      !!              all the needed fields (as defined in sbc_cpl_init)
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT(in) ::   kt
+      !
+      INTEGER ::   ji, jj, jl   ! dummy loop indices
+      INTEGER ::   isec, info   ! local integer
+      REAL(wp) ::   zumax, zvmax
+      REAL(wp), DIMENSION(jpi,jpj)     ::   zfr_l, ztmp1, ztmp2, zotx1, zoty1, zotz1, zitx1, zity1, zitz1
+      REAL(wp), DIMENSION(jpi,jpj,jpl) ::   ztmp3, ztmp4   
+      !!----------------------------------------------------------------------
+      !
+      isec = ( kt - nit000 ) * NINT( rdt )        ! date of exchanges
+
+      zfr_l(:,:) = 1.- fr_i(:,:)
+      !                                                      ! ------------------------- !
+      !                                                      !    Surface temperature    !   in Kelvin
+      !                                                      ! ------------------------- !
+      IF( ssnd(jps_toce)%laction .OR. ssnd(jps_tice)%laction .OR. ssnd(jps_tmix)%laction ) THEN
+         
+         IF ( nn_components == jp_iam_opa ) THEN
+            ztmp1(:,:) = tsn(:,:,1,jp_tem)   ! send temperature as it is (potential or conservative) -> use of l_useCT on the received part
+         ELSE
+            ! we must send the surface potential temperature 
+            IF( l_useCT )  THEN    ;   ztmp1(:,:) = eos_pt_from_ct( tsn(:,:,1,jp_tem), tsn(:,:,1,jp_sal) )
+            ELSE                   ;   ztmp1(:,:) = tsn(:,:,1,jp_tem)
+            ENDIF
+            !
+            SELECT CASE( sn_snd_temp%cldes)
+            CASE( 'oce only'             )   ;   ztmp1(:,:) =   ztmp1(:,:) + rt0
+            CASE( 'oce and ice'          )   ;   ztmp1(:,:) =   ztmp1(:,:) + rt0
+               SELECT CASE( sn_snd_temp%clcat )
+               CASE( 'yes' )   
+                  ztmp3(:,:,1:jpl) = tn_ice(:,:,1:jpl)
+               CASE( 'no' )
+                  WHERE( SUM( a_i, dim=3 ) /= 0. )
+                     ztmp3(:,:,1) = SUM( tn_ice * a_i, dim=3 ) / SUM( a_i, dim=3 )
+                  ELSEWHERE
+                     ztmp3(:,:,1) = rt0
+                  END WHERE
+               CASE default   ;   CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_temp%clcat' )
+               END SELECT
+            CASE( 'weighted oce and ice' )   ;   ztmp1(:,:) = ( ztmp1(:,:) + rt0 ) * zfr_l(:,:)   
+               SELECT CASE( sn_snd_temp%clcat )
+               CASE( 'yes' )   
+                  ztmp3(:,:,1:jpl) = tn_ice(:,:,1:jpl) * a_i(:,:,1:jpl)
+               CASE( 'no' )
+                  ztmp3(:,:,:) = 0.0
+                  DO jl=1,jpl
+                     ztmp3(:,:,1) = ztmp3(:,:,1) + tn_ice(:,:,jl) * a_i(:,:,jl)
+                  ENDDO
+               CASE default                  ;   CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_temp%clcat' )
+               END SELECT
+            CASE( 'oce and weighted ice')    ;   ztmp1(:,:) =   tsn(:,:,1,jp_tem) + rt0  
+               SELECT CASE( sn_snd_temp%clcat ) 
+               CASE( 'yes' )    
+                  ztmp3(:,:,1:jpl) = tn_ice(:,:,1:jpl) * a_i(:,:,1:jpl) 
+               CASE( 'no' ) 
+                  ztmp3(:,:,:) = 0.0 
+                  DO jl=1,jpl 
+                     ztmp3(:,:,1) = ztmp3(:,:,1) + tn_ice(:,:,jl) * a_i(:,:,jl) 
+                  ENDDO 
+               CASE default                  ;   CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_temp%clcat' ) 
+               END SELECT 
+            CASE( 'mixed oce-ice'        )   
+               ztmp1(:,:) = ( ztmp1(:,:) + rt0 ) * zfr_l(:,:) 
+               DO jl=1,jpl
+                  ztmp1(:,:) = ztmp1(:,:) + tn_ice(:,:,jl) * a_i(:,:,jl)
+               ENDDO
+            CASE default                     ;   CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_temp%cldes' )
+            END SELECT
+         ENDIF
+         IF( ssnd(jps_toce)%laction )   CALL cpl_snd( jps_toce, isec, RESHAPE ( ztmp1, (/jpi,jpj,1/) ), info )
+         IF( ssnd(jps_tice)%laction )   CALL cpl_snd( jps_tice, isec, ztmp3, info )
+         IF( ssnd(jps_tmix)%laction )   CALL cpl_snd( jps_tmix, isec, RESHAPE ( ztmp1, (/jpi,jpj,1/) ), info )
+      ENDIF
+      !
+      !                                                      ! ------------------------- !
+      !                                                      ! 1st layer ice/snow temp.  !
+      !                                                      ! ------------------------- !
+#if defined key_si3
+      ! needed by  Met Office
+      IF( ssnd(jps_ttilyr)%laction) THEN
+         SELECT CASE( sn_snd_ttilyr%cldes)
+         CASE ('weighted ice')
+            ztmp3(:,:,1:jpl) = t1_ice(:,:,1:jpl) * a_i(:,:,1:jpl) 
+         CASE default                     ;   CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_ttilyr%cldes' )
+         END SELECT
+         IF( ssnd(jps_ttilyr)%laction )   CALL cpl_snd( jps_ttilyr, isec, ztmp3, info )
+      ENDIF
+#endif
+      !                                                      ! ------------------------- !
+      !                                                      !           Albedo          !
+      !                                                      ! ------------------------- !
+      IF( ssnd(jps_albice)%laction ) THEN                         ! ice 
+          SELECT CASE( sn_snd_alb%cldes )
+          CASE( 'ice' )
+             SELECT CASE( sn_snd_alb%clcat )
+             CASE( 'yes' )   
+                ztmp3(:,:,1:jpl) = alb_ice(:,:,1:jpl)
+             CASE( 'no' )
+                WHERE( SUM( a_i, dim=3 ) /= 0. )
+                   ztmp1(:,:) = SUM( alb_ice (:,:,1:jpl) * a_i(:,:,1:jpl), dim=3 ) / SUM( a_i(:,:,1:jpl), dim=3 )
+                ELSEWHERE
+                   ztmp1(:,:) = alb_oce_mix(:,:)
+                END WHERE
+             CASE default   ;   CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_alb%clcat' )
+             END SELECT
+          CASE( 'weighted ice' )   ;
+             SELECT CASE( sn_snd_alb%clcat )
+             CASE( 'yes' )   
+                ztmp3(:,:,1:jpl) =  alb_ice(:,:,1:jpl) * a_i(:,:,1:jpl)
+             CASE( 'no' )
+                WHERE( fr_i (:,:) > 0. )
+                   ztmp1(:,:) = SUM (  alb_ice(:,:,1:jpl) * a_i(:,:,1:jpl), dim=3 )
+                ELSEWHERE
+                   ztmp1(:,:) = 0.
+                END WHERE
+             CASE default   ;   CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_ice%clcat' )
+             END SELECT
+          CASE default      ;   CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_alb%cldes' )
+         END SELECT
+
+         SELECT CASE( sn_snd_alb%clcat )
+            CASE( 'yes' )   
+               CALL cpl_snd( jps_albice, isec, ztmp3, info )      !-> MV this has never been checked in coupled mode
+            CASE( 'no'  )   
+               CALL cpl_snd( jps_albice, isec, RESHAPE ( ztmp1, (/jpi,jpj,1/) ), info ) 
+         END SELECT
+      ENDIF
+
+      IF( ssnd(jps_albmix)%laction ) THEN                         ! mixed ice-ocean
+         ztmp1(:,:) = alb_oce_mix(:,:) * zfr_l(:,:)
+         DO jl = 1, jpl
+            ztmp1(:,:) = ztmp1(:,:) + alb_ice(:,:,jl) * a_i(:,:,jl)
+         END DO
+         CALL cpl_snd( jps_albmix, isec, RESHAPE ( ztmp1, (/jpi,jpj,1/) ), info )
+      ENDIF
+      !                                                      ! ------------------------- !
+      !                                                      !  Ice fraction & Thickness ! 
+      !                                                      ! ------------------------- !
+      ! Send ice fraction field to atmosphere
+      IF( ssnd(jps_fice)%laction ) THEN
+         SELECT CASE( sn_snd_thick%clcat )
+         CASE( 'yes' )   ;   ztmp3(:,:,1:jpl) =  a_i(:,:,1:jpl)
+         CASE( 'no'  )   ;   ztmp3(:,:,1    ) = fr_i(:,:      )
+         CASE default    ;   CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_thick%clcat' )
+         END SELECT
+         IF( ssnd(jps_fice)%laction )   CALL cpl_snd( jps_fice, isec, ztmp3, info )
+      ENDIF
+
+      IF( ssnd(jps_fice1)%laction ) THEN
+         SELECT CASE( sn_snd_thick1%clcat )
+         CASE( 'yes' )   ;   ztmp3(:,:,1:jpl) =  a_i(:,:,1:jpl)
+         CASE( 'no'  )   ;   ztmp3(:,:,1    ) = fr_i(:,:      )
+         CASE default    ;   CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_thick1%clcat' )
+         END SELECT
+         CALL cpl_snd( jps_fice1, isec, ztmp3, info )
+      ENDIF
+      
+      ! Send ice fraction field to OPA (sent by SAS in SAS-OPA coupling)
+      IF( ssnd(jps_fice2)%laction ) THEN
+         ztmp3(:,:,1) = fr_i(:,:)
+         IF( ssnd(jps_fice2)%laction )   CALL cpl_snd( jps_fice2, isec, ztmp3, info )
+      ENDIF
+
+      ! Send ice and snow thickness field 
+      IF( ssnd(jps_hice)%laction .OR. ssnd(jps_hsnw)%laction ) THEN 
+         SELECT CASE( sn_snd_thick%cldes)
+         CASE( 'none'                  )       ! nothing to do
+         CASE( 'weighted ice and snow' )   
+            SELECT CASE( sn_snd_thick%clcat )
+            CASE( 'yes' )   
+               ztmp3(:,:,1:jpl) =  h_i(:,:,1:jpl) * a_i(:,:,1:jpl)
+               ztmp4(:,:,1:jpl) =  h_s(:,:,1:jpl) * a_i(:,:,1:jpl)
+            CASE( 'no' )
+               ztmp3(:,:,:) = 0.0   ;  ztmp4(:,:,:) = 0.0
+               DO jl=1,jpl
+                  ztmp3(:,:,1) = ztmp3(:,:,1) + h_i(:,:,jl) * a_i(:,:,jl)
+                  ztmp4(:,:,1) = ztmp4(:,:,1) + h_s(:,:,jl) * a_i(:,:,jl)
+               ENDDO
+            CASE default                  ;   CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_thick%clcat' )
+            END SELECT
+         CASE( 'ice and snow'         )   
+            SELECT CASE( sn_snd_thick%clcat )
+            CASE( 'yes' )
+               ztmp3(:,:,1:jpl) = h_i(:,:,1:jpl)
+               ztmp4(:,:,1:jpl) = h_s(:,:,1:jpl)
+            CASE( 'no' )
+               WHERE( SUM( a_i, dim=3 ) /= 0. )
+                  ztmp3(:,:,1) = SUM( h_i * a_i, dim=3 ) / SUM( a_i, dim=3 )
+                  ztmp4(:,:,1) = SUM( h_s * a_i, dim=3 ) / SUM( a_i, dim=3 )
+               ELSEWHERE
+                 ztmp3(:,:,1) = 0.
+                 ztmp4(:,:,1) = 0.
+               END WHERE
+            CASE default                  ;   CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_thick%clcat' )
+            END SELECT
+         CASE default                     ;   CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_thick%cldes' )
+         END SELECT
+         IF( ssnd(jps_hice)%laction )   CALL cpl_snd( jps_hice, isec, ztmp3, info )
+         IF( ssnd(jps_hsnw)%laction )   CALL cpl_snd( jps_hsnw, isec, ztmp4, info )
+      ENDIF
+
+#if defined key_si3
+      !                                                      ! ------------------------- !
+      !                                                      !      Ice melt ponds       ! 
+      !                                                      ! ------------------------- !
+      ! needed by Met Office
+      IF( ssnd(jps_a_p)%laction .OR. ssnd(jps_ht_p)%laction ) THEN 
+         SELECT CASE( sn_snd_mpnd%cldes)  
+         CASE( 'ice only' )  
+            SELECT CASE( sn_snd_mpnd%clcat )  
+            CASE( 'yes' )  
+               ztmp3(:,:,1:jpl) =  a_ip(:,:,1:jpl)
+               ztmp4(:,:,1:jpl) =  v_ip(:,:,1:jpl)  
+            CASE( 'no' )  
+               ztmp3(:,:,:) = 0.0  
+               ztmp4(:,:,:) = 0.0  
+               DO jl=1,jpl  
+                 ztmp3(:,:,1) = ztmp3(:,:,1) + a_ip(:,:,jpl)  
+                 ztmp4(:,:,1) = ztmp4(:,:,1) + v_ip(:,:,jpl) 
+               ENDDO  
+            CASE default   ;   CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_mpnd%clcat' )  
+            END SELECT  
+         CASE default      ;   CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_mpnd%cldes' )     
+         END SELECT  
+         IF( ssnd(jps_a_p)%laction  )   CALL cpl_snd( jps_a_p , isec, ztmp3, info )     
+         IF( ssnd(jps_ht_p)%laction )   CALL cpl_snd( jps_ht_p, isec, ztmp4, info )     
+      ENDIF 
+      ! 
+      !                                                      ! ------------------------- !
+      !                                                      !     Ice conductivity      ! 
+      !                                                      ! ------------------------- !
+      ! needed by Met Office
+      IF( ssnd(jps_kice)%laction ) THEN 
+         SELECT CASE( sn_snd_cond%cldes) 
+         CASE( 'weighted ice' )    
+            SELECT CASE( sn_snd_cond%clcat ) 
+            CASE( 'yes' )    
+	       ztmp3(:,:,1:jpl) =  cnd_ice(:,:,1:jpl) * a_i(:,:,1:jpl) 
+            CASE( 'no' ) 
+               ztmp3(:,:,:) = 0.0 
+               DO jl=1,jpl 
+                 ztmp3(:,:,1) = ztmp3(:,:,1) + cnd_ice(:,:,jl) * a_i(:,:,jl) 
+               ENDDO 
+            CASE default   ;   CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_cond%clcat' ) 
+            END SELECT 
+         CASE( 'ice only' )    
+           ztmp3(:,:,1:jpl) = cnd_ice(:,:,1:jpl) 
+         CASE default      ;   CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_cond%cldes' )     
+         END SELECT 
+         IF( ssnd(jps_kice)%laction )   CALL cpl_snd( jps_kice, isec, ztmp3, info ) 
+      ENDIF 
+#endif
+
+      !                                                      ! ------------------------- !
+      !                                                      !  CO2 flux from PISCES     ! 
+      !                                                      ! ------------------------- !
+      IF( ssnd(jps_co2)%laction .AND. l_co2cpl )   CALL cpl_snd( jps_co2, isec, RESHAPE ( oce_co2, (/jpi,jpj,1/) ) , info )
+      !
+      !                                                      ! ------------------------- !
+      IF( ssnd(jps_ocx1)%laction ) THEN                      !      Surface current      !
+         !                                                   ! ------------------------- !
+         !    
+         !                                                  j+1   j     -----V---F
+         ! surface velocity always sent from T point                     !       |
+         !                                                        j      |   T   U
+         !                                                               |       |
+         !                                                   j    j-1   -I-------|
+         !                                               (for I)         |       |
+         !                                                              i-1  i   i
+         !                                                               i      i+1 (for I)
+         IF( nn_components == jp_iam_opa ) THEN
+            zotx1(:,:) = un(:,:,1)  
+            zoty1(:,:) = vn(:,:,1)  
+         ELSE        
+            SELECT CASE( TRIM( sn_snd_crt%cldes ) )
+            CASE( 'oce only'             )      ! C-grid ==> T
+               DO jj = 2, jpjm1
+                  DO ji = fs_2, fs_jpim1   ! vector opt.
+                     zotx1(ji,jj) = 0.5 * ( un(ji,jj,1) + un(ji-1,jj  ,1) )
+                     zoty1(ji,jj) = 0.5 * ( vn(ji,jj,1) + vn(ji  ,jj-1,1) ) 
+                  END DO
+               END DO
+            CASE( 'weighted oce and ice' )   
+               SELECT CASE ( cp_ice_msh )
+               CASE( 'C' )                      ! Ocean and Ice on C-grid ==> T
+                  DO jj = 2, jpjm1
+                     DO ji = fs_2, fs_jpim1   ! vector opt.
+                        zotx1(ji,jj) = 0.5 * ( un   (ji,jj,1) + un   (ji-1,jj  ,1) ) * zfr_l(ji,jj)  
+                        zoty1(ji,jj) = 0.5 * ( vn   (ji,jj,1) + vn   (ji  ,jj-1,1) ) * zfr_l(ji,jj)
+                        zitx1(ji,jj) = 0.5 * ( u_ice(ji,jj  ) + u_ice(ji-1,jj    ) ) *  fr_i(ji,jj)
+                        zity1(ji,jj) = 0.5 * ( v_ice(ji,jj  ) + v_ice(ji  ,jj-1  ) ) *  fr_i(ji,jj)
+                     END DO
+                  END DO
+               CASE( 'I' )                      ! Ocean on C grid, Ice on I-point (B-grid) ==> T
+                  DO jj = 2, jpjm1
+                     DO ji = 2, jpim1   ! NO vector opt.
+                        zotx1(ji,jj) = 0.5  * ( un(ji,jj,1)      + un(ji-1,jj  ,1) ) * zfr_l(ji,jj)  
+                        zoty1(ji,jj) = 0.5  * ( vn(ji,jj,1)      + vn(ji  ,jj-1,1) ) * zfr_l(ji,jj)  
+                        zitx1(ji,jj) = 0.25 * ( u_ice(ji+1,jj+1) + u_ice(ji,jj+1)                     &
+                           &                  + u_ice(ji+1,jj  ) + u_ice(ji,jj  )  ) *  fr_i(ji,jj)
+                        zity1(ji,jj) = 0.25 * ( v_ice(ji+1,jj+1) + v_ice(ji,jj+1)                     &
+                           &                  + v_ice(ji+1,jj  ) + v_ice(ji,jj  )  ) *  fr_i(ji,jj)
+                     END DO
+                  END DO
+               CASE( 'F' )                      ! Ocean on C grid, Ice on F-point (B-grid) ==> T
+                  DO jj = 2, jpjm1
+                     DO ji = 2, jpim1   ! NO vector opt.
+                        zotx1(ji,jj) = 0.5  * ( un(ji,jj,1)      + un(ji-1,jj  ,1) ) * zfr_l(ji,jj)  
+                        zoty1(ji,jj) = 0.5  * ( vn(ji,jj,1)      + vn(ji  ,jj-1,1) ) * zfr_l(ji,jj)  
+                        zitx1(ji,jj) = 0.25 * ( u_ice(ji-1,jj-1) + u_ice(ji,jj-1)                     &
+                           &                  + u_ice(ji-1,jj  ) + u_ice(ji,jj  )  ) *  fr_i(ji,jj)
+                        zity1(ji,jj) = 0.25 * ( v_ice(ji-1,jj-1) + v_ice(ji,jj-1)                     &
+                           &                  + v_ice(ji-1,jj  ) + v_ice(ji,jj  )  ) *  fr_i(ji,jj)
+                     END DO
+                  END DO
+               END SELECT
+               CALL lbc_lnk_multi( zitx1, 'T', -1., zity1, 'T', -1. )
+            CASE( 'mixed oce-ice'        )
+               SELECT CASE ( cp_ice_msh )
+               CASE( 'C' )                      ! Ocean and Ice on C-grid ==> T
+                  DO jj = 2, jpjm1
+                     DO ji = fs_2, fs_jpim1   ! vector opt.
+                        zotx1(ji,jj) = 0.5 * ( un   (ji,jj,1) + un   (ji-1,jj  ,1) ) * zfr_l(ji,jj)   &
+                           &         + 0.5 * ( u_ice(ji,jj  ) + u_ice(ji-1,jj    ) ) *  fr_i(ji,jj)
+                        zoty1(ji,jj) = 0.5 * ( vn   (ji,jj,1) + vn   (ji  ,jj-1,1) ) * zfr_l(ji,jj)   &
+                           &         + 0.5 * ( v_ice(ji,jj  ) + v_ice(ji  ,jj-1  ) ) *  fr_i(ji,jj)
+                     END DO
+                  END DO
+               CASE( 'I' )                      ! Ocean on C grid, Ice on I-point (B-grid) ==> T
+                  DO jj = 2, jpjm1
+                     DO ji = 2, jpim1   ! NO vector opt.
+                        zotx1(ji,jj) = 0.5  * ( un(ji,jj,1)      + un(ji-1,jj  ,1) ) * zfr_l(ji,jj)   &   
+                           &         + 0.25 * ( u_ice(ji+1,jj+1) + u_ice(ji,jj+1)                     &
+                           &                  + u_ice(ji+1,jj  ) + u_ice(ji,jj  )  ) *  fr_i(ji,jj)
+                        zoty1(ji,jj) = 0.5  * ( vn(ji,jj,1)      + vn(ji  ,jj-1,1) ) * zfr_l(ji,jj)   & 
+                           &         + 0.25 * ( v_ice(ji+1,jj+1) + v_ice(ji,jj+1)                     &
+                           &                  + v_ice(ji+1,jj  ) + v_ice(ji,jj  )  ) *  fr_i(ji,jj)
+                     END DO
+                  END DO
+               CASE( 'F' )                      ! Ocean on C grid, Ice on F-point (B-grid) ==> T
+                  DO jj = 2, jpjm1
+                     DO ji = 2, jpim1   ! NO vector opt.
+                        zotx1(ji,jj) = 0.5  * ( un(ji,jj,1)      + un(ji-1,jj  ,1) ) * zfr_l(ji,jj)   &   
+                           &         + 0.25 * ( u_ice(ji-1,jj-1) + u_ice(ji,jj-1)                     &
+                           &                  + u_ice(ji-1,jj  ) + u_ice(ji,jj  )  ) *  fr_i(ji,jj)
+                        zoty1(ji,jj) = 0.5  * ( vn(ji,jj,1)      + vn(ji  ,jj-1,1) ) * zfr_l(ji,jj)   & 
+                           &         + 0.25 * ( v_ice(ji-1,jj-1) + v_ice(ji,jj-1)                     &
+                           &                  + v_ice(ji-1,jj  ) + v_ice(ji,jj  )  ) *  fr_i(ji,jj)
+                     END DO
+                  END DO
+               END SELECT
+            END SELECT
+            CALL lbc_lnk_multi( zotx1, ssnd(jps_ocx1)%clgrid, -1.,  zoty1, ssnd(jps_ocy1)%clgrid, -1. )
+            !
+         ENDIF
+         !
+         !
+         IF( TRIM( sn_snd_crt%clvor ) == 'eastward-northward' ) THEN             ! Rotation of the components
+            !                                                                     ! Ocean component
+            CALL rot_rep( zotx1, zoty1, ssnd(jps_ocx1)%clgrid, 'ij->e', ztmp1 )       ! 1st component 
+            CALL rot_rep( zotx1, zoty1, ssnd(jps_ocx1)%clgrid, 'ij->n', ztmp2 )       ! 2nd component 
+            zotx1(:,:) = ztmp1(:,:)                                                   ! overwrite the components 
+            zoty1(:,:) = ztmp2(:,:)
+            IF( ssnd(jps_ivx1)%laction ) THEN                                     ! Ice component
+               CALL rot_rep( zitx1, zity1, ssnd(jps_ivx1)%clgrid, 'ij->e', ztmp1 )    ! 1st component 
+               CALL rot_rep( zitx1, zity1, ssnd(jps_ivx1)%clgrid, 'ij->n', ztmp2 )    ! 2nd component 
+               zitx1(:,:) = ztmp1(:,:)                                                ! overwrite the components 
+               zity1(:,:) = ztmp2(:,:)
+            ENDIF
+         ENDIF
+         !
+         ! spherical coordinates to cartesian -> 2 components to 3 components
+         IF( TRIM( sn_snd_crt%clvref ) == 'cartesian' ) THEN
+            ztmp1(:,:) = zotx1(:,:)                     ! ocean currents
+            ztmp2(:,:) = zoty1(:,:)
+            CALL oce2geo ( ztmp1, ztmp2, 'T', zotx1, zoty1, zotz1 )
+            !
+            IF( ssnd(jps_ivx1)%laction ) THEN           ! ice velocities
+               ztmp1(:,:) = zitx1(:,:)
+               ztmp1(:,:) = zity1(:,:)
+               CALL oce2geo ( ztmp1, ztmp2, 'T', zitx1, zity1, zitz1 )
+            ENDIF
+         ENDIF
+         !
+         IF( ssnd(jps_ocx1)%laction )   CALL cpl_snd( jps_ocx1, isec, RESHAPE ( zotx1, (/jpi,jpj,1/) ), info )   ! ocean x current 1st grid
+         IF( ssnd(jps_ocy1)%laction )   CALL cpl_snd( jps_ocy1, isec, RESHAPE ( zoty1, (/jpi,jpj,1/) ), info )   ! ocean y current 1st grid
+         IF( ssnd(jps_ocz1)%laction )   CALL cpl_snd( jps_ocz1, isec, RESHAPE ( zotz1, (/jpi,jpj,1/) ), info )   ! ocean z current 1st grid
+         !
+         IF( ssnd(jps_ivx1)%laction )   CALL cpl_snd( jps_ivx1, isec, RESHAPE ( zitx1, (/jpi,jpj,1/) ), info )   ! ice   x current 1st grid
+         IF( ssnd(jps_ivy1)%laction )   CALL cpl_snd( jps_ivy1, isec, RESHAPE ( zity1, (/jpi,jpj,1/) ), info )   ! ice   y current 1st grid
+         IF( ssnd(jps_ivz1)%laction )   CALL cpl_snd( jps_ivz1, isec, RESHAPE ( zitz1, (/jpi,jpj,1/) ), info )   ! ice   z current 1st grid
+         ! 
+      ENDIF
+      !
+      !                                                      ! ------------------------- ! 
+      !                                                      !  Surface current to waves ! 
+      !                                                      ! ------------------------- ! 
+      IF( ssnd(jps_ocxw)%laction .OR. ssnd(jps_ocyw)%laction ) THEN 
+          !     
+          !                                                  j+1  j     -----V---F 
+          ! surface velocity always sent from T point                    !       | 
+          !                                                       j      |   T   U 
+          !                                                              |       | 
+          !                                                   j   j-1   -I-------| 
+          !                                               (for I)        |       | 
+          !                                                             i-1  i   i 
+          !                                                              i      i+1 (for I) 
+          SELECT CASE( TRIM( sn_snd_crtw%cldes ) ) 
+          CASE( 'oce only'             )      ! C-grid ==> T 
+             DO jj = 2, jpjm1 
+                DO ji = fs_2, fs_jpim1   ! vector opt. 
+                   zotx1(ji,jj) = 0.5 * ( un(ji,jj,1) + un(ji-1,jj  ,1) ) 
+                   zoty1(ji,jj) = 0.5 * ( vn(ji,jj,1) + vn(ji , jj-1,1) )  
+                END DO 
+             END DO 
+          CASE( 'weighted oce and ice' )    
+             SELECT CASE ( cp_ice_msh ) 
+             CASE( 'C' )                      ! Ocean and Ice on C-grid ==> T 
+                DO jj = 2, jpjm1 
+                   DO ji = fs_2, fs_jpim1   ! vector opt. 
+                      zotx1(ji,jj) = 0.5 * ( un   (ji,jj,1) + un   (ji-1,jj  ,1) ) * zfr_l(ji,jj)   
+                      zoty1(ji,jj) = 0.5 * ( vn   (ji,jj,1) + vn   (ji  ,jj-1,1) ) * zfr_l(ji,jj) 
+                      zitx1(ji,jj) = 0.5 * ( u_ice(ji,jj  ) + u_ice(ji-1,jj    ) ) *  fr_i(ji,jj) 
+                      zity1(ji,jj) = 0.5 * ( v_ice(ji,jj  ) + v_ice(ji  ,jj-1  ) ) *  fr_i(ji,jj) 
+                   END DO 
+                END DO 
+             CASE( 'I' )                      ! Ocean on C grid, Ice on I-point (B-grid) ==> T 
+                DO jj = 2, jpjm1 
+                   DO ji = 2, jpim1   ! NO vector opt. 
+                      zotx1(ji,jj) = 0.5  * ( un(ji,jj,1)      + un(ji-1,jj  ,1) ) * zfr_l(ji,jj)   
+                      zoty1(ji,jj) = 0.5  * ( vn(ji,jj,1)      + vn(ji  ,jj-1,1) ) * zfr_l(ji,jj)   
+                      zitx1(ji,jj) = 0.25 * ( u_ice(ji+1,jj+1) + u_ice(ji,jj+1)                     & 
+                         &                  + u_ice(ji+1,jj  ) + u_ice(ji,jj  )  ) *  fr_i(ji,jj) 
+                      zity1(ji,jj) = 0.25 * ( v_ice(ji+1,jj+1) + v_ice(ji,jj+1)                     & 
+                         &                  + v_ice(ji+1,jj  ) + v_ice(ji,jj  )  ) *  fr_i(ji,jj) 
+                   END DO 
+                END DO 
+             CASE( 'F' )                      ! Ocean on C grid, Ice on F-point (B-grid) ==> T 
+                DO jj = 2, jpjm1 
+                   DO ji = 2, jpim1   ! NO vector opt. 
+                      zotx1(ji,jj) = 0.5  * ( un(ji,jj,1)      + un(ji-1,jj  ,1) ) * zfr_l(ji,jj)   
+                      zoty1(ji,jj) = 0.5  * ( vn(ji,jj,1)      + vn(ji  ,jj-1,1) ) * zfr_l(ji,jj)   
+                      zitx1(ji,jj) = 0.25 * ( u_ice(ji-1,jj-1) + u_ice(ji,jj-1)                     & 
+                         &                  + u_ice(ji-1,jj  ) + u_ice(ji,jj  )  ) *  fr_i(ji,jj) 
+                      zity1(ji,jj) = 0.25 * ( v_ice(ji-1,jj-1) + v_ice(ji,jj-1)                     & 
+                         &                  + v_ice(ji-1,jj  ) + v_ice(ji,jj  )  ) *  fr_i(ji,jj) 
+                   END DO 
+                END DO 
+             END SELECT 
+             CALL lbc_lnk_multi( zitx1, 'T', -1.,  zity1, 'T', -1. ) 
+          CASE( 'mixed oce-ice'        ) 
+             SELECT CASE ( cp_ice_msh ) 
+             CASE( 'C' )                      ! Ocean and Ice on C-grid ==> T 
+                DO jj = 2, jpjm1 
+                   DO ji = fs_2, fs_jpim1   ! vector opt. 
+                      zotx1(ji,jj) = 0.5 * ( un   (ji,jj,1) + un   (ji-1,jj  ,1) ) * zfr_l(ji,jj)   & 
+                         &         + 0.5 * ( u_ice(ji,jj  ) + u_ice(ji-1,jj    ) ) *  fr_i(ji,jj) 
+                      zoty1(ji,jj) = 0.5 * ( vn   (ji,jj,1) + vn   (ji  ,jj-1,1) ) * zfr_l(ji,jj)   & 
+                         &         + 0.5 * ( v_ice(ji,jj  ) + v_ice(ji  ,jj-1  ) ) *  fr_i(ji,jj) 
+                   END DO 
+                END DO 
+             CASE( 'I' )                      ! Ocean on C grid, Ice on I-point (B-grid) ==> T 
+                DO jj = 2, jpjm1 
+                   DO ji = 2, jpim1   ! NO vector opt. 
+                      zotx1(ji,jj) = 0.5  * ( un(ji,jj,1)      + un(ji-1,jj  ,1) ) * zfr_l(ji,jj)   &    
+                         &         + 0.25 * ( u_ice(ji+1,jj+1) + u_ice(ji,jj+1)                     & 
+                         &                  + u_ice(ji+1,jj  ) + u_ice(ji,jj  )  ) *  fr_i(ji,jj) 
+                      zoty1(ji,jj) = 0.5  * ( vn(ji,jj,1)      + vn(ji  ,jj-1,1) ) * zfr_l(ji,jj)   &  
+                         &         + 0.25 * ( v_ice(ji+1,jj+1) + v_ice(ji,jj+1)                     & 
+                         &                  + v_ice(ji+1,jj  ) + v_ice(ji,jj  )  ) *  fr_i(ji,jj) 
+                   END DO 
+                END DO 
+             CASE( 'F' )                      ! Ocean on C grid, Ice on F-point (B-grid) ==> T 
+                DO jj = 2, jpjm1 
+                   DO ji = 2, jpim1   ! NO vector opt. 
+                      zotx1(ji,jj) = 0.5  * ( un(ji,jj,1)      + un(ji-1,jj  ,1) ) * zfr_l(ji,jj)   &    
+                         &         + 0.25 * ( u_ice(ji-1,jj-1) + u_ice(ji,jj-1)                     & 
+                         &                  + u_ice(ji-1,jj  ) + u_ice(ji,jj  )  ) *  fr_i(ji,jj) 
+                      zoty1(ji,jj) = 0.5  * ( vn(ji,jj,1)      + vn(ji  ,jj-1,1) ) * zfr_l(ji,jj)   &  
+                         &         + 0.25 * ( v_ice(ji-1,jj-1) + v_ice(ji,jj-1)                     & 
+                         &                  + v_ice(ji-1,jj  ) + v_ice(ji,jj  )  ) *  fr_i(ji,jj) 
+                   END DO 
+                END DO 
+             END SELECT 
+          END SELECT 
+         CALL lbc_lnk_multi( zotx1, ssnd(jps_ocxw)%clgrid, -1., zoty1, ssnd(jps_ocyw)%clgrid, -1. ) 
+         ! 
+         ! 
+         IF( TRIM( sn_snd_crtw%clvor ) == 'eastward-northward' ) THEN             ! Rotation of the components 
+         !                                                                        ! Ocean component 
+            CALL rot_rep( zotx1, zoty1, ssnd(jps_ocxw)%clgrid, 'ij->e', ztmp1 )       ! 1st component  
+            CALL rot_rep( zotx1, zoty1, ssnd(jps_ocxw)%clgrid, 'ij->n', ztmp2 )       ! 2nd component  
+            zotx1(:,:) = ztmp1(:,:)                                                   ! overwrite the components  
+            zoty1(:,:) = ztmp2(:,:)  
+            IF( ssnd(jps_ivx1)%laction ) THEN                                     ! Ice component 
+               CALL rot_rep( zitx1, zity1, ssnd(jps_ivx1)%clgrid, 'ij->e', ztmp1 )    ! 1st component  
+               CALL rot_rep( zitx1, zity1, ssnd(jps_ivx1)%clgrid, 'ij->n', ztmp2 )    ! 2nd component  
+               zitx1(:,:) = ztmp1(:,:)                                                ! overwrite the components  
+               zity1(:,:) = ztmp2(:,:) 
+            ENDIF 
+         ENDIF 
+         ! 
+!         ! spherical coordinates to cartesian -> 2 components to 3 components 
+!         IF( TRIM( sn_snd_crtw%clvref ) == 'cartesian' ) THEN 
+!            ztmp1(:,:) = zotx1(:,:)                     ! ocean currents 
+!            ztmp2(:,:) = zoty1(:,:) 
+!            CALL oce2geo ( ztmp1, ztmp2, 'T', zotx1, zoty1, zotz1 ) 
+!            ! 
+!            IF( ssnd(jps_ivx1)%laction ) THEN           ! ice velocities 
+!               ztmp1(:,:) = zitx1(:,:) 
+!               ztmp1(:,:) = zity1(:,:) 
+!               CALL oce2geo ( ztmp1, ztmp2, 'T', zitx1, zity1, zitz1 ) 
+!            ENDIF 
+!         ENDIF 
+         ! 
+         IF( ssnd(jps_ocxw)%laction )   CALL cpl_snd( jps_ocxw, isec, RESHAPE ( zotx1, (/jpi,jpj,1/) ), info )   ! ocean x current 1st grid 
+         IF( ssnd(jps_ocyw)%laction )   CALL cpl_snd( jps_ocyw, isec, RESHAPE ( zoty1, (/jpi,jpj,1/) ), info )   ! ocean y current 1st grid 
+         !  
+      ENDIF 
+      ! 
+      IF( ssnd(jps_ficet)%laction ) THEN 
+         CALL cpl_snd( jps_ficet, isec, RESHAPE ( fr_i, (/jpi,jpj,1/) ), info ) 
+      END IF 
+      !                                                      ! ------------------------- ! 
+      !                                                      !   Water levels to waves   ! 
+      !                                                      ! ------------------------- ! 
+      IF( ssnd(jps_wlev)%laction ) THEN 
+         IF( ln_apr_dyn ) THEN  
+            IF( kt /= nit000 ) THEN  
+               ztmp1(:,:) = sshb(:,:) - 0.5 * ( ssh_ib(:,:) + ssh_ibb(:,:) )  
+            ELSE  
+               ztmp1(:,:) = sshb(:,:)  
+            ENDIF  
+         ELSE  
+            ztmp1(:,:) = sshn(:,:)  
+         ENDIF  
+         CALL cpl_snd( jps_wlev  , isec, RESHAPE ( ztmp1, (/jpi,jpj,1/) ), info ) 
+      END IF 
+      !
+      !  Fields sent by OPA to SAS when doing OPA<->SAS coupling
+      !                                                        ! SSH
+      IF( ssnd(jps_ssh )%laction )  THEN
+         !                          ! removed inverse barometer ssh when Patm
+         !                          forcing is used (for sea-ice dynamics)
+         IF( ln_apr_dyn ) THEN   ;   ztmp1(:,:) = sshb(:,:) - 0.5 * ( ssh_ib(:,:) + ssh_ibb(:,:) )
+         ELSE                    ;   ztmp1(:,:) = sshn(:,:)
+         ENDIF
+         CALL cpl_snd( jps_ssh   , isec, RESHAPE ( ztmp1            , (/jpi,jpj,1/) ), info )
+
+      ENDIF
+      !                                                        ! SSS
+      IF( ssnd(jps_soce  )%laction )  THEN
+         CALL cpl_snd( jps_soce  , isec, RESHAPE ( tsn(:,:,1,jp_sal), (/jpi,jpj,1/) ), info )
+      ENDIF
+      !                                                        ! first T level thickness 
+      IF( ssnd(jps_e3t1st )%laction )  THEN
+         CALL cpl_snd( jps_e3t1st, isec, RESHAPE ( e3t_n(:,:,1)   , (/jpi,jpj,1/) ), info )
+      ENDIF
+      !                                                        ! Qsr fraction
+      IF( ssnd(jps_fraqsr)%laction )  THEN
+         CALL cpl_snd( jps_fraqsr, isec, RESHAPE ( fraqsr_1lev(:,:) , (/jpi,jpj,1/) ), info )
+      ENDIF
+      !
+      !  Fields sent by SAS to OPA when OASIS coupling
+      !                                                        ! Solar heat flux
+      IF( ssnd(jps_qsroce)%laction )  CALL cpl_snd( jps_qsroce, isec, RESHAPE ( qsr , (/jpi,jpj,1/) ), info )
+      IF( ssnd(jps_qnsoce)%laction )  CALL cpl_snd( jps_qnsoce, isec, RESHAPE ( qns , (/jpi,jpj,1/) ), info )
+      IF( ssnd(jps_oemp  )%laction )  CALL cpl_snd( jps_oemp  , isec, RESHAPE ( emp , (/jpi,jpj,1/) ), info )
+      IF( ssnd(jps_sflx  )%laction )  CALL cpl_snd( jps_sflx  , isec, RESHAPE ( sfx , (/jpi,jpj,1/) ), info )
+      IF( ssnd(jps_otx1  )%laction )  CALL cpl_snd( jps_otx1  , isec, RESHAPE ( utau, (/jpi,jpj,1/) ), info )
+      IF( ssnd(jps_oty1  )%laction )  CALL cpl_snd( jps_oty1  , isec, RESHAPE ( vtau, (/jpi,jpj,1/) ), info )
+      IF( ssnd(jps_rnf   )%laction )  CALL cpl_snd( jps_rnf   , isec, RESHAPE ( rnf , (/jpi,jpj,1/) ), info )
+      IF( ssnd(jps_taum  )%laction )  CALL cpl_snd( jps_taum  , isec, RESHAPE ( taum, (/jpi,jpj,1/) ), info )
+
+#if defined key_si3
+      !                                                      ! ------------------------- !
+      !                                                      ! Sea surface freezing temp ! 
+      !                                                      ! ------------------------- !
+      ! needed by Met Office
+      CALL eos_fzp(tsn(:,:,1,jp_sal), sstfrz)
+      ztmp1(:,:) = sstfrz(:,:) + rt0
+      IF( ssnd(jps_sstfrz)%laction )  CALL cpl_snd( jps_sstfrz, isec, RESHAPE ( ztmp1, (/jpi,jpj,1/) ), info)
+#endif
+      !
+   END SUBROUTINE sbc_cpl_snd
+   
+   !!======================================================================
+END MODULE sbccpl
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/SBC/sbcdcy.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/SBC/sbcdcy.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/SBC/sbcdcy.F90	(revision 9570)
@@ -0,0 +1,248 @@
+MODULE sbcdcy
+   !!======================================================================
+   !!                    ***  MODULE  sbcdcy  ***
+   !! Ocean forcing:  compute the diurnal cycle
+   !!======================================================================
+   !! History : OPA  !  2005-02  (D. Bernie)  Original code
+   !!   NEMO    2.0  !  2006-02  (S. Masson, G. Madec)  adaptation to NEMO
+   !!           3.1  !  2009-07  (J.M. Molines)  adaptation to v3.1
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!  sbc_dcy : solar flux at kt from daily mean, taking diurnal cycle into account
+   !!----------------------------------------------------------------------
+   USE oce              ! ocean dynamics and tracers
+   USE phycst           ! ocean physics
+   USE dom_oce          ! ocean space and time domain
+   USE sbc_oce          ! Surface boundary condition: ocean fields
+   !
+   USE in_out_manager   ! I/O manager
+   USE lib_mpp          ! MPP library
+
+   IMPLICIT NONE
+   PRIVATE
+   
+   INTEGER, PUBLIC ::   nday_qsr   !: day when parameters were computed
+   
+   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   raa , rbb  , rcc  , rab     ! diurnal cycle parameters
+   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   rtmd, rdawn, rdusk, rscal   !    -      -       -
+  
+   PUBLIC   sbc_dcy        ! routine called by sbc
+
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO-consortium (2010) 
+   !! $Id$ 
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+      INTEGER FUNCTION sbc_dcy_alloc()
+         !!----------------------------------------------------------------------
+         !!                ***  FUNCTION sbc_dcy_alloc  ***
+         !!----------------------------------------------------------------------
+         ALLOCATE( raa (jpi,jpj) , rbb  (jpi,jpj) , rcc  (jpi,jpj) , rab  (jpi,jpj) ,     &
+            &      rtmd(jpi,jpj) , rdawn(jpi,jpj) , rdusk(jpi,jpj) , rscal(jpi,jpj) , STAT=sbc_dcy_alloc )
+            !
+         IF( lk_mpp             )   CALL mpp_sum ( sbc_dcy_alloc )
+         IF( sbc_dcy_alloc /= 0 )   CALL ctl_warn('sbc_dcy_alloc: failed to allocate arrays')
+      END FUNCTION sbc_dcy_alloc
+
+
+   FUNCTION sbc_dcy( pqsrin, l_mask ) RESULT( zqsrout )
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE sbc_dcy  ***
+      !!
+      !! ** Purpose : introduce a diurnal cycle of qsr from daily values
+      !!
+      !! ** Method  : see Appendix A of Bernie et al. 2007.
+      !!
+      !! ** Action  : redistribute daily QSR on each time step following the diurnal cycle
+      !!
+      !! reference  : Bernie, DJ, E Guilyardi, G Madec, JM Slingo, and SJ Woolnough, 2007
+      !!              Impact of resolving the diurnal cycle in an ocean--atmosphere GCM. 
+      !!              Part 1: a diurnally forced OGCM. Climate Dynamics 29:6, 575-590.
+      !!----------------------------------------------------------------------
+      LOGICAL , OPTIONAL          , INTENT(in) ::   l_mask    ! use the routine for night mask computation
+      REAL(wp), DIMENSION(jpi,jpj), INTENT(in) ::   pqsrin    ! input daily QSR flux 
+      REAL(wp), DIMENSION(jpi,jpj)             ::   zqsrout   ! output QSR flux with diurnal cycle
+      !!
+      INTEGER  ::   ji, jj                                       ! dummy loop indices
+      INTEGER, DIMENSION(jpi,jpj) :: imask_night ! night mask
+      REAL(wp) ::   ztwopi, zinvtwopi, zconvrad 
+      REAL(wp) ::   zlo, zup, zlousd, zupusd
+      REAL(wp) ::   zdsws, zdecrad, ztx, zsin, zcos
+      REAL(wp) ::   ztmp, ztmp1, ztmp2, ztest
+      REAL(wp) ::   ztmpm, ztmpm1, ztmpm2
+      !---------------------------statement functions------------------------
+      REAL(wp) ::   fintegral, pt1, pt2, paaa, pbbb, pccc        ! dummy statement function arguments
+      fintegral( pt1, pt2, paaa, pbbb, pccc ) =                         &
+         &   paaa * pt2 + zinvtwopi * pbbb * SIN(pccc + ztwopi * pt2)   &
+         & - paaa * pt1 - zinvtwopi * pbbb * SIN(pccc + ztwopi * pt1)
+      !!---------------------------------------------------------------------
+      !
+      ! Initialization
+      ! --------------
+      ztwopi    = 2._wp * rpi
+      zinvtwopi = 1._wp / ztwopi
+      zconvrad  = ztwopi / 360._wp
+
+      ! When are we during the day (from 0 to 1)
+      zlo = ( REAL(nsec_day, wp) - 0.5_wp * rdt ) / rday
+      zup = zlo + ( REAL(nn_fsbc, wp)     * rdt ) / rday
+      !                                          
+      IF( nday_qsr == -1 ) THEN       ! first time step only  
+         IF(lwp) THEN
+            WRITE(numout,*)
+            WRITE(numout,*) 'sbc_dcy : introduce diurnal cycle from daily mean qsr'
+            WRITE(numout,*) '~~~~~~~'
+            WRITE(numout,*)
+         ENDIF
+         ! allocate sbcdcy arrays
+         IF( sbc_dcy_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'sbc_dcy_alloc : unable to allocate arrays' )
+         ! Compute rcc needed to compute the time integral of the diurnal cycle
+         rcc(:,:) = zconvrad * glamt(:,:) - rpi
+         ! time of midday
+         rtmd(:,:) = 0.5_wp - glamt(:,:) / 360._wp
+         rtmd(:,:) = MOD( (rtmd(:,:) + 1._wp) , 1._wp)
+      ENDIF
+
+      ! If this is a new day, we have to update the dawn, dusk and scaling function  
+      !----------------------
+    
+      !     2.1 dawn and dusk  
+
+      ! nday is the number of days since the beginning of the current month 
+      IF( nday_qsr /= nday ) THEN 
+         ! save the day of the year and the daily mean of qsr
+         nday_qsr = nday 
+         ! number of days since the previous winter solstice (supposed to be always 21 December)         
+         zdsws = REAL(11 + nday_year, wp)
+         ! declination of the earths orbit
+         zdecrad = (-23.5_wp * zconvrad) * COS( zdsws * ztwopi / REAL(nyear_len(1),wp) )
+         ! Compute A and B needed to compute the time integral of the diurnal cycle
+
+         zsin = SIN( zdecrad )   ;   zcos = COS( zdecrad )
+         DO jj = 1, jpj
+            DO ji = 1, jpi
+               ztmp = zconvrad * gphit(ji,jj)
+               raa(ji,jj) = SIN( ztmp ) * zsin
+               rbb(ji,jj) = COS( ztmp ) * zcos
+            END DO  
+         END DO  
+         ! Compute the time of dawn and dusk
+
+         ! rab to test if the day time is equal to 0, less than 24h of full day        
+         rab(:,:) = -raa(:,:) / rbb(:,:)
+         DO jj = 1, jpj
+            DO ji = 1, jpi
+               IF ( ABS(rab(ji,jj)) < 1._wp ) THEN         ! day duration is less than 24h
+         ! When is it night?
+                  ztx = zinvtwopi * (ACOS(rab(ji,jj)) - rcc(ji,jj))
+                  ztest = -rbb(ji,jj) * SIN( rcc(ji,jj) + ztwopi * ztx )
+         ! is it dawn or dusk?
+                  IF ( ztest > 0._wp ) THEN
+                     rdawn(ji,jj) = ztx
+                     rdusk(ji,jj) = rtmd(ji,jj) + ( rtmd(ji,jj) - rdawn(ji,jj) )
+                  ELSE
+                     rdusk(ji,jj) = ztx
+                     rdawn(ji,jj) = rtmd(ji,jj) - ( rdusk(ji,jj) - rtmd(ji,jj) )
+                  ENDIF
+               ELSE
+                  rdawn(ji,jj) = rtmd(ji,jj) + 0.5_wp
+                  rdusk(ji,jj) = rdawn(ji,jj)
+               ENDIF
+             END DO  
+         END DO  
+         rdawn(:,:) = MOD( (rdawn(:,:) + 1._wp), 1._wp )
+         rdusk(:,:) = MOD( (rdusk(:,:) + 1._wp), 1._wp )
+         !     2.2 Compute the scaling function:
+         !         S* = the inverse of the time integral of the diurnal cycle from dawn to dusk
+         !         Avoid possible infinite scaling factor, associated with very short daylight
+         !         periods, by ignoring periods less than 1/1000th of a day (ticket #1040)
+         DO jj = 1, jpj
+            DO ji = 1, jpi
+               IF ( ABS(rab(ji,jj)) < 1._wp ) THEN         ! day duration is less than 24h
+                  rscal(ji,jj) = 0.0_wp
+                  IF ( rdawn(ji,jj) < rdusk(ji,jj) ) THEN      ! day time in one part
+                     IF( (rdusk(ji,jj) - rdawn(ji,jj) ) .ge. 0.001_wp ) THEN
+                       rscal(ji,jj) = fintegral(rdawn(ji,jj), rdusk(ji,jj), raa(ji,jj), rbb(ji,jj), rcc(ji,jj)) 
+                       rscal(ji,jj) = 1._wp / rscal(ji,jj)
+                     ENDIF
+                  ELSE                                         ! day time in two parts
+                     IF( (rdusk(ji,jj) + (1._wp - rdawn(ji,jj)) ) .ge. 0.001_wp ) THEN
+                       rscal(ji,jj) = fintegral(0._wp, rdusk(ji,jj), raa(ji,jj), rbb(ji,jj), rcc(ji,jj))   &
+                          &         + fintegral(rdawn(ji,jj), 1._wp, raa(ji,jj), rbb(ji,jj), rcc(ji,jj)) 
+                       rscal(ji,jj) = 1. / rscal(ji,jj)
+                     ENDIF
+                  ENDIF
+               ELSE
+                  IF ( raa(ji,jj) > rbb(ji,jj) ) THEN         ! 24h day
+                     rscal(ji,jj) = fintegral(0._wp, 1._wp, raa(ji,jj), rbb(ji,jj), rcc(ji,jj)) 
+                     rscal(ji,jj) = 1._wp / rscal(ji,jj)
+                  ELSE                                          ! No day
+                     rscal(ji,jj) = 0.0_wp
+                  ENDIF
+               ENDIF
+            END DO  
+         END DO  
+         !
+         ztmp = rday / ( rdt * REAL(nn_fsbc, wp) )
+         rscal(:,:) = rscal(:,:) * ztmp
+         !
+      ENDIF 
+         !     3. update qsr with the diurnal cycle
+         !     ------------------------------------
+
+      imask_night(:,:) = 0
+      DO jj = 1, jpj
+         DO ji = 1, jpi
+            ztmpm = 0._wp
+            IF( ABS(rab(ji,jj)) < 1. ) THEN         ! day duration is less than 24h
+               !
+               IF( rdawn(ji,jj) < rdusk(ji,jj) ) THEN       ! day time in one part
+                  zlousd = MAX(zlo, rdawn(ji,jj))
+                  zlousd = MIN(zlousd, zup)
+                  zupusd = MIN(zup, rdusk(ji,jj))
+                  zupusd = MAX(zupusd, zlo)
+                  ztmp = fintegral(zlousd, zupusd, raa(ji,jj), rbb(ji,jj), rcc(ji,jj)) 
+                  zqsrout(ji,jj) = pqsrin(ji,jj) * ztmp * rscal(ji,jj)
+                  ztmpm = zupusd - zlousd
+                  IF ( ztmpm .EQ. 0 ) imask_night(ji,jj) = 1
+                  !
+               ELSE                                         ! day time in two parts
+                  zlousd = MIN(zlo, rdusk(ji,jj))
+                  zupusd = MIN(zup, rdusk(ji,jj))
+                  ztmp1 = fintegral(zlousd, zupusd, raa(ji,jj), rbb(ji,jj), rcc(ji,jj)) 
+                  ztmpm1=zupusd-zlousd
+                  zlousd = MAX(zlo, rdawn(ji,jj))
+                  zupusd = MAX(zup, rdawn(ji,jj))
+                  ztmp2 = fintegral(zlousd, zupusd, raa(ji,jj), rbb(ji,jj), rcc(ji,jj)) 
+                  ztmpm2 =zupusd-zlousd
+                  ztmp = ztmp1 + ztmp2
+                  ztmpm = ztmpm1 + ztmpm2
+                  zqsrout(ji,jj) = pqsrin(ji,jj) * ztmp * rscal(ji,jj)
+                  IF (ztmpm .EQ. 0.) imask_night(ji,jj) = 1
+               ENDIF
+            ELSE                                   ! 24h light or 24h night
+               !
+               IF( raa(ji,jj) > rbb(ji,jj) ) THEN           ! 24h day
+                  ztmp = fintegral(zlo, zup, raa(ji,jj), rbb(ji,jj), rcc(ji,jj)) 
+                  zqsrout(ji,jj) = pqsrin(ji,jj) * ztmp * rscal(ji,jj)
+                  imask_night(ji,jj) = 0
+                  !
+               ELSE                                         ! No day
+                  zqsrout(ji,jj) = 0.0_wp
+                  imask_night(ji,jj) = 1
+               ENDIF
+            ENDIF
+         END DO  
+      END DO  
+      !
+      IF( PRESENT(l_mask) .AND. l_mask ) THEN
+         zqsrout(:,:) = float(imask_night(:,:))
+      ENDIF
+      !
+   END FUNCTION sbc_dcy
+
+   !!======================================================================
+END MODULE sbcdcy
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/SBC/sbcflx.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/SBC/sbcflx.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/SBC/sbcflx.F90	(revision 9570)
@@ -0,0 +1,175 @@
+MODULE sbcflx
+   !!======================================================================
+   !!                       ***  MODULE  sbcflx  ***
+   !! Ocean forcing:  momentum, heat and freshwater flux formulation
+   !!=====================================================================
+   !! History :  1.0  !  2006-06  (G. Madec)  Original code
+   !!            3.3  !  2010-10  (S. Masson)  add diurnal cycle
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   namflx   : flux formulation namlist
+   !!   sbc_flx  : flux formulation as ocean surface boundary condition (forced mode, fluxes read in NetCDF files)
+   !!----------------------------------------------------------------------
+   USE oce             ! ocean dynamics and tracers
+   USE dom_oce         ! ocean space and time domain
+   USE sbc_oce         ! surface boundary condition: ocean fields
+   USE sbcdcy          ! surface boundary condition: diurnal cycle on qsr
+   USE phycst          ! physical constants
+   !
+   USE fldread         ! read input fields
+   USE iom             ! IOM library
+   USE in_out_manager  ! I/O manager
+   USE lib_mpp         ! distribued memory computing library
+   USE lbclnk          ! ocean lateral boundary conditions (or mpp link)
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC sbc_flx       ! routine called by step.F90
+
+   INTEGER , PARAMETER ::   jpfld   = 5   ! maximum number of files to read 
+   INTEGER , PARAMETER ::   jp_utau = 1   ! index of wind stress (i-component) file
+   INTEGER , PARAMETER ::   jp_vtau = 2   ! index of wind stress (j-component) file
+   INTEGER , PARAMETER ::   jp_qtot = 3   ! index of total (non solar+solar) heat file
+   INTEGER , PARAMETER ::   jp_qsr  = 4   ! index of solar heat file
+   INTEGER , PARAMETER ::   jp_emp  = 5   ! index of evaporation-precipation file
+   TYPE(FLD), ALLOCATABLE, DIMENSION(:) ::   sf    ! structure of input fields (file informations, fields read)
+
+   !! * Substitutions
+#  include "vectopt_loop_substitute.h90"
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO-consortium (2010) 
+   !! $Id$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE sbc_flx( kt )
+      !!---------------------------------------------------------------------
+      !!                    ***  ROUTINE sbc_flx  ***
+      !!                   
+      !! ** Purpose :   provide at each time step the surface ocean fluxes
+      !!                (momentum, heat, freshwater and runoff) 
+      !!
+      !! ** Method  : - READ each fluxes in NetCDF files:
+      !!                   i-component of the stress              utau  (N/m2)
+      !!                   j-component of the stress              vtau  (N/m2)
+      !!                   net downward heat flux                 qtot  (watt/m2)
+      !!                   net downward radiative flux            qsr   (watt/m2)
+      !!                   net upward freshwater (evapo - precip) emp   (kg/m2/s)
+      !!
+      !!      CAUTION :  - never mask the surface stress fields
+      !!                 - the stress is assumed to be in the (i,j) mesh referential
+      !!
+      !! ** Action  :   update at each time-step
+      !!              - utau, vtau  i- and j-component of the wind stress
+      !!              - taum        wind stress module at T-point
+      !!              - wndm        10m wind module at T-point
+      !!              - qns         non solar heat flux including heat flux due to emp
+      !!              - qsr         solar heat flux
+      !!              - emp         upward mass flux (evap. - precip.)
+      !!              - sfx         salt flux; set to zero at nit000 but possibly non-zero
+      !!                            if ice is present (computed in limsbc(_2).F90)
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT(in) ::   kt   ! ocean time step
+      !!
+      INTEGER  ::   ji, jj, jf            ! dummy indices
+      INTEGER  ::   ierror                ! return error code
+      INTEGER  ::   ios                   ! Local integer output status for namelist read
+      REAL(wp) ::   zfact                 ! temporary scalar
+      REAL(wp) ::   zrhoa  = 1.22         ! Air density kg/m3
+      REAL(wp) ::   zcdrag = 1.5e-3       ! drag coefficient
+      REAL(wp) ::   ztx, zty, zmod, zcoef ! temporary variables
+      !!
+      CHARACTER(len=100) ::  cn_dir                               ! Root directory for location of flx files
+      TYPE(FLD_N), DIMENSION(jpfld) ::   slf_i                    ! array of namelist information structures
+      TYPE(FLD_N) ::   sn_utau, sn_vtau, sn_qtot, sn_qsr, sn_emp  ! informations about the fields to be read
+      NAMELIST/namsbc_flx/ cn_dir, sn_utau, sn_vtau, sn_qtot, sn_qsr, sn_emp
+      !!---------------------------------------------------------------------
+      !
+      IF( kt == nit000 ) THEN                ! First call kt=nit000  
+         ! set file information
+         REWIND( numnam_ref )              ! Namelist namsbc_flx in reference namelist : Files for fluxes
+         READ  ( numnam_ref, namsbc_flx, IOSTAT = ios, ERR = 901)
+901      IF( ios /= 0 )   CALL ctl_nam ( ios , 'namsbc_flx in reference namelist', lwp )
+
+         REWIND( numnam_cfg )              ! Namelist namsbc_flx in configuration namelist : Files for fluxes
+         READ  ( numnam_cfg, namsbc_flx, IOSTAT = ios, ERR = 902 )
+902      IF( ios >  0 )   CALL ctl_nam ( ios , 'namsbc_flx in configuration namelist', lwp )
+         IF(lwm) WRITE ( numond, namsbc_flx ) 
+         !
+         !                                         ! check: do we plan to use ln_dm2dc with non-daily forcing?
+         IF( ln_dm2dc .AND. sn_qsr%nfreqh /= 24 )   &
+            &   CALL ctl_stop( 'sbc_blk_core: ln_dm2dc can be activated only with daily short-wave forcing' ) 
+         !
+         !                                         ! store namelist information in an array
+         slf_i(jp_utau) = sn_utau   ;   slf_i(jp_vtau) = sn_vtau
+         slf_i(jp_qtot) = sn_qtot   ;   slf_i(jp_qsr ) = sn_qsr 
+         slf_i(jp_emp ) = sn_emp
+         !
+         ALLOCATE( sf(jpfld), STAT=ierror )        ! set sf structure
+         IF( ierror > 0 ) THEN   
+            CALL ctl_stop( 'sbc_flx: unable to allocate sf structure' )   ;   RETURN  
+         ENDIF
+         DO ji= 1, jpfld
+            ALLOCATE( sf(ji)%fnow(jpi,jpj,1) )
+            IF( slf_i(ji)%ln_tint ) ALLOCATE( sf(ji)%fdta(jpi,jpj,1,2) )
+         END DO
+         !                                         ! fill sf with slf_i and control print
+         CALL fld_fill( sf, slf_i, cn_dir, 'sbc_flx', 'flux formulation for ocean surface boundary condition', 'namsbc_flx' )
+         !
+         sfx(:,:) = 0.0_wp                         ! salt flux due to freezing/melting (non-zero only if ice is present; set in limsbc(_2).F90)
+         !
+      ENDIF
+
+      CALL fld_read( kt, nn_fsbc, sf )                            ! input fields provided at the current time-step
+     
+      IF( MOD( kt-1, nn_fsbc ) == 0 ) THEN                        ! update ocean fluxes at each SBC frequency
+
+         IF( ln_dm2dc ) THEN   ;   qsr(:,:) = sbc_dcy( sf(jp_qsr)%fnow(:,:,1) )   ! modify now Qsr to include the diurnal cycle
+         ELSE                  ;   qsr(:,:) =          sf(jp_qsr)%fnow(:,:,1)
+         ENDIF
+         DO jj = 1, jpj                                           ! set the ocean fluxes from read fields
+            DO ji = 1, jpi
+               utau(ji,jj) = sf(jp_utau)%fnow(ji,jj,1)
+               vtau(ji,jj) = sf(jp_vtau)%fnow(ji,jj,1)
+               qns (ji,jj) = sf(jp_qtot)%fnow(ji,jj,1) - sf(jp_qsr)%fnow(ji,jj,1)
+               emp (ji,jj) = sf(jp_emp )%fnow(ji,jj,1)
+            END DO
+         END DO
+         !                                                        ! add to qns the heat due to e-p
+         qns(:,:) = qns(:,:) - emp(:,:) * sst_m(:,:) * rcp        ! mass flux is at SST
+         !
+         !                                                        ! module of wind stress and wind speed at T-point
+         zcoef = 1. / ( zrhoa * zcdrag )
+         DO jj = 2, jpjm1
+            DO ji = fs_2, fs_jpim1   ! vect. opt.
+               ztx = utau(ji-1,jj  ) + utau(ji,jj) 
+               zty = vtau(ji  ,jj-1) + vtau(ji,jj) 
+               zmod = 0.5 * SQRT( ztx * ztx + zty * zty )
+               taum(ji,jj) = zmod
+               wndm(ji,jj) = SQRT( zmod * zcoef )
+            END DO
+         END DO
+         taum(:,:) = taum(:,:) * tmask(:,:,1) ; wndm(:,:) = wndm(:,:) * tmask(:,:,1)
+         CALL lbc_lnk( taum(:,:), 'T', 1. )   ;   CALL lbc_lnk( wndm(:,:), 'T', 1. )
+
+         IF( nitend-nit000 <= 100 .AND. lwp ) THEN                ! control print (if less than 100 time-step asked)
+            WRITE(numout,*) 
+            WRITE(numout,*) '        read daily momentum, heat and freshwater fluxes OK'
+            DO jf = 1, jpfld
+               IF( jf == jp_utau .OR. jf == jp_vtau )   zfact =     1.
+               IF( jf == jp_qtot .OR. jf == jp_qsr  )   zfact =     0.1
+               IF( jf == jp_emp                     )   zfact = 86400.
+               WRITE(numout,*) 
+               WRITE(numout,*) ' day: ', ndastp , TRIM(sf(jf)%clvar), ' * ', zfact
+            END DO
+         ENDIF
+         !
+      ENDIF
+      !
+   END SUBROUTINE sbc_flx
+
+   !!======================================================================
+END MODULE sbcflx
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/SBC/sbcfwb.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/SBC/sbcfwb.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/SBC/sbcfwb.F90	(revision 9570)
@@ -0,0 +1,211 @@
+MODULE sbcfwb
+   !!======================================================================
+   !!                       ***  MODULE  sbcfwb  ***
+   !! Ocean fluxes   : domain averaged freshwater budget
+   !!======================================================================
+   !! History :  OPA  ! 2001-02  (E. Durand)  Original code
+   !!   NEMO     1.0  ! 2002-06  (G. Madec)  F90: Free form and module
+   !!            3.0  ! 2006-08  (G. Madec)  Surface module
+   !!            3.2  ! 2009-07  (C. Talandier) emp mean s spread over erp area 
+   !!            3.6  ! 2014-11  (P. Mathiot  ) add ice shelf melting
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   sbc_fwb       : freshwater budget for global ocean configurations (free surface & forced mode)
+   !!----------------------------------------------------------------------
+   USE oce            ! ocean dynamics and tracers
+   USE dom_oce        ! ocean space and time domain
+   USE sbc_oce        ! surface ocean boundary condition
+   USE sbc_ice , ONLY : snwice_mass, snwice_mass_b, snwice_fmass
+   USE phycst         ! physical constants
+   USE sbcrnf         ! ocean runoffs
+   USE sbcisf         ! ice shelf melting contribution
+   USE sbcssr         ! Sea-Surface damping terms
+   !
+   USE in_out_manager ! I/O manager
+   USE lib_mpp        ! distribued memory computing library
+   USE timing         ! Timing
+   USE lbclnk         ! ocean lateral boundary conditions
+   USE lib_fortran    ! 
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   sbc_fwb    ! routine called by step
+
+   REAL(wp) ::   a_fwb_b   ! annual domain averaged freshwater budget
+   REAL(wp) ::   a_fwb     ! for 2 year before (_b) and before year.
+   REAL(wp) ::   fwfold    ! fwfold to be suppressed
+   REAL(wp) ::   area      ! global mean ocean surface (interior domain)
+
+   !! * Substitutions
+#  include "vectopt_loop_substitute.h90"
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO Consortium (2010)
+   !! $Id$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE sbc_fwb( kt, kn_fwb, kn_fsbc )
+      !!---------------------------------------------------------------------
+      !!                  ***  ROUTINE sbc_fwb  ***
+      !!
+      !! ** Purpose :   Control the mean sea surface drift
+      !!
+      !! ** Method  :   several ways  depending on kn_fwb
+      !!                =0 no control 
+      !!                =1 global mean of emp set to zero at each nn_fsbc time step
+      !!                =2 annual global mean corrected from previous year
+      !!                =3 global mean of emp set to zero at each nn_fsbc time step
+      !!                   & spread out over erp area depending its sign
+      !! Note: if sea ice is embedded it is taken into account when computing the budget 
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT( in ) ::   kt       ! ocean time-step index
+      INTEGER, INTENT( in ) ::   kn_fsbc  ! 
+      INTEGER, INTENT( in ) ::   kn_fwb   ! ocean time-step index
+      !
+      INTEGER  ::   inum, ikty, iyear     ! local integers
+      REAL(wp) ::   z_fwf, z_fwf_nsrf, zsum_fwf, zsum_erp                ! local scalars
+      REAL(wp) ::   zsurf_neg, zsurf_pos, zsurf_tospread, zcoef          !   -      -
+      REAL(wp), ALLOCATABLE, DIMENSION(:,:) ::   ztmsk_neg, ztmsk_pos, z_wgt ! 2D workspaces
+      REAL(wp), ALLOCATABLE, DIMENSION(:,:) ::   ztmsk_tospread, zerp_cor    !   -      -
+      !!----------------------------------------------------------------------
+      !
+      IF( kt == nit000 ) THEN
+         IF(lwp) THEN
+            WRITE(numout,*)
+            WRITE(numout,*) 'sbc_fwb : FreshWater Budget correction'
+            WRITE(numout,*) '~~~~~~~'
+            IF( kn_fwb == 1 )   WRITE(numout,*) '          instantaneously set to zero'
+            IF( kn_fwb == 2 )   WRITE(numout,*) '          adjusted from previous year budget'
+            IF( kn_fwb == 3 )   WRITE(numout,*) '          fwf set to zero and spread out over erp area'
+         ENDIF
+         !
+         IF( kn_fwb == 3 .AND. nn_sssr /= 2 )   CALL ctl_stop( 'sbc_fwb: nn_fwb = 3 requires nn_sssr = 2, we stop ' )
+         IF( kn_fwb == 3 .AND. ln_isfcav    )   CALL ctl_stop( 'sbc_fwb: nn_fwb = 3 with ln_isfcav = .TRUE. not working, we stop ' )
+         !
+         area = glob_sum( e1e2t(:,:) * tmask(:,:,1))           ! interior global domain surface
+         ! isf cavities are excluded because it can feedback to the melting with generation of inhibition of plumes
+         ! and in case of no melt, it can generate HSSW.
+         !
+#if ! defined key_si3 && ! defined key_cice
+         snwice_mass_b(:,:) = 0.e0               ! no sea-ice model is being used : no snow+ice mass
+         snwice_mass  (:,:) = 0.e0
+#endif
+         !
+      ENDIF
+
+      SELECT CASE ( kn_fwb )
+      !
+      CASE ( 1 )                             !==  global mean fwf set to zero  ==!
+         !
+         IF( MOD( kt-1, kn_fsbc ) == 0 ) THEN
+            z_fwf = glob_sum( e1e2t(:,:) * ( emp(:,:) - rnf(:,:) + fwfisf(:,:) - snwice_fmass(:,:) ) ) / area   ! sum over the global domain
+            zcoef = z_fwf * rcp
+            emp(:,:) = emp(:,:) - z_fwf              * tmask(:,:,1)
+            qns(:,:) = qns(:,:) + zcoef * sst_m(:,:) * tmask(:,:,1) ! account for change to the heat budget due to fw correction
+         ENDIF
+         !
+      CASE ( 2 )                             !==  fwf budget adjusted from the previous year  ==!
+         !
+         IF( kt == nit000 ) THEN                      ! initialisation
+            !                                         ! Read the corrective factor on precipitations (fwfold)
+            CALL ctl_opn( inum, 'EMPave_old.dat', 'OLD', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE. )
+            READ ( inum, "(24X,I8,2ES24.16)" ) iyear, a_fwb_b, a_fwb
+            CLOSE( inum )
+            fwfold = a_fwb                            ! current year freshwater budget correction
+            !                                         ! estimate from the previous year budget
+            IF(lwp)WRITE(numout,*)
+            IF(lwp)WRITE(numout,*)'sbc_fwb : year = ',iyear  , ' freshwater budget correction = ', fwfold
+            IF(lwp)WRITE(numout,*)'          year = ',iyear-1, ' freshwater budget read       = ', a_fwb
+            IF(lwp)WRITE(numout,*)'          year = ',iyear-2, ' freshwater budget read       = ', a_fwb_b
+         ENDIF   
+         !                                         ! Update fwfold if new year start
+         ikty = 365 * 86400 / rdt                  !!bug  use of 365 days leap year or 360d year !!!!!!!
+         IF( MOD( kt, ikty ) == 0 ) THEN
+            a_fwb_b = a_fwb                           ! mean sea level taking into account the ice+snow
+                                                      ! sum over the global domain
+            a_fwb   = glob_sum( e1e2t(:,:) * ( sshn(:,:) + snwice_mass(:,:) * r1_rau0 ) )
+            a_fwb   = a_fwb * 1.e+3 / ( area * rday * 365. )     ! convert in Kg/m3/s = mm/s
+!!gm        !                                                      !!bug 365d year 
+            fwfold =  a_fwb                           ! current year freshwater budget correction
+            !                                         ! estimate from the previous year budget
+         ENDIF
+         ! 
+         IF( MOD( kt-1, kn_fsbc ) == 0 ) THEN         ! correct the freshwater fluxes
+            zcoef = fwfold * rcp
+            emp(:,:) = emp(:,:) + fwfold             * tmask(:,:,1)
+            qns(:,:) = qns(:,:) - zcoef * sst_m(:,:) * tmask(:,:,1) ! account for change to the heat budget due to fw correction
+         ENDIF
+         !
+         IF( kt == nitend .AND. lwp ) THEN            ! save fwfold value in a file
+            CALL ctl_opn( inum, 'EMPave.dat', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE., narea )
+            WRITE( inum, "(24X,I8,2ES24.16)" ) nyear, a_fwb_b, a_fwb
+            CLOSE( inum )
+         ENDIF
+         !
+      CASE ( 3 )                             !==  global fwf set to zero and spread out over erp area  ==!
+         !
+         ALLOCATE( ztmsk_neg(jpi,jpj) , ztmsk_pos(jpi,jpj) , ztmsk_tospread(jpi,jpj) , z_wgt(jpi,jpj) , zerp_cor(jpi,jpj) )
+         !
+         IF( MOD( kt-1, kn_fsbc ) == 0 ) THEN
+            ztmsk_pos(:,:) = tmask_i(:,:)                      ! Select <0 and >0 area of erp
+            WHERE( erp < 0._wp )   ztmsk_pos = 0._wp
+            ztmsk_neg(:,:) = tmask_i(:,:) - ztmsk_pos(:,:)
+            !
+            zsurf_neg = glob_sum( e1e2t(:,:)*ztmsk_neg(:,:) )  ! Area filled by <0 and >0 erp 
+            zsurf_pos = glob_sum( e1e2t(:,:)*ztmsk_pos(:,:) )
+            !                                                  ! fwf global mean (excluding ocean to ice/snow exchanges) 
+            z_fwf     = glob_sum( e1e2t(:,:) * ( emp(:,:) - rnf(:,:) + fwfisf(:,:) - snwice_fmass(:,:) ) ) / area
+            !            
+            IF( z_fwf < 0._wp ) THEN         ! spread out over >0 erp area to increase evaporation
+                zsurf_tospread      = zsurf_pos
+                ztmsk_tospread(:,:) = ztmsk_pos(:,:)
+            ELSE                             ! spread out over <0 erp area to increase precipitation
+                zsurf_tospread      = zsurf_neg
+                ztmsk_tospread(:,:) = ztmsk_neg(:,:)
+            ENDIF
+            !
+            zsum_fwf   = glob_sum( e1e2t(:,:) * z_fwf )         ! fwf global mean over <0 or >0 erp area
+!!gm :  zsum_fwf   = z_fwf * area   ???  it is right?  I think so....
+            z_fwf_nsrf =  zsum_fwf / ( zsurf_tospread + rsmall )
+            !                                                  ! weight to respect erp field 2D structure 
+            zsum_erp   = glob_sum( ztmsk_tospread(:,:) * erp(:,:) * e1e2t(:,:) )
+            z_wgt(:,:) = ztmsk_tospread(:,:) * erp(:,:) / ( zsum_erp + rsmall )
+            !                                                  ! final correction term to apply
+            zerp_cor(:,:) = -1. * z_fwf_nsrf * zsurf_tospread * z_wgt(:,:)
+            !
+!!gm   ===>>>>  lbc_lnk should be useless as all the computation is done over the whole domain !
+            CALL lbc_lnk( zerp_cor, 'T', 1. )
+            !
+            emp(:,:) = emp(:,:) + zerp_cor(:,:)
+            qns(:,:) = qns(:,:) - zerp_cor(:,:) * rcp * sst_m(:,:)  ! account for change to the heat budget due to fw correction
+            erp(:,:) = erp(:,:) + zerp_cor(:,:)
+            !
+            IF( nprint == 1 .AND. lwp ) THEN                   ! control print
+               IF( z_fwf < 0._wp ) THEN
+                  WRITE(numout,*)'   z_fwf < 0'
+                  WRITE(numout,*)'   SUM(erp+)     = ', SUM( ztmsk_tospread(:,:)*erp(:,:)*e1e2t(:,:) )*1.e-9,' Sv'
+               ELSE
+                  WRITE(numout,*)'   z_fwf >= 0'
+                  WRITE(numout,*)'   SUM(erp-)     = ', SUM( ztmsk_tospread(:,:)*erp(:,:)*e1e2t(:,:) )*1.e-9,' Sv'
+               ENDIF
+               WRITE(numout,*)'   SUM(empG)     = ', SUM( z_fwf*e1e2t(:,:) )*1.e-9,' Sv'
+               WRITE(numout,*)'   z_fwf         = ', z_fwf      ,' Kg/m2/s'
+               WRITE(numout,*)'   z_fwf_nsrf    = ', z_fwf_nsrf ,' Kg/m2/s'
+               WRITE(numout,*)'   MIN(zerp_cor) = ', MINVAL(zerp_cor) 
+               WRITE(numout,*)'   MAX(zerp_cor) = ', MAXVAL(zerp_cor) 
+            ENDIF
+         ENDIF
+         DEALLOCATE( ztmsk_neg , ztmsk_pos , ztmsk_tospread , z_wgt , zerp_cor )
+         !
+      CASE DEFAULT                           !==  you should never be there  ==!
+         CALL ctl_stop( 'sbc_fwb : wrong nn_fwb value for the FreshWater Budget correction, choose either 1, 2 or 3' )
+         !
+      END SELECT
+      !
+   END SUBROUTINE sbc_fwb
+
+   !!======================================================================
+END MODULE sbcfwb
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/SBC/sbcice_cice.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/SBC/sbcice_cice.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/SBC/sbcice_cice.F90	(revision 9570)
@@ -0,0 +1,1067 @@
+MODULE sbcice_cice
+   !!======================================================================
+   !!                       ***  MODULE  sbcice_cice  ***
+   !! To couple with sea ice model CICE (LANL)
+   !!=====================================================================
+#if defined key_cice
+   !!----------------------------------------------------------------------
+   !!   'key_cice' :                                     CICE sea-ice model
+   !!----------------------------------------------------------------------
+   !!   sbc_ice_cice  : sea-ice model time-stepping and update ocean sbc over ice-covered area
+   !!----------------------------------------------------------------------
+   USE oce             ! ocean dynamics and tracers
+   USE dom_oce         ! ocean space and time domain
+   USE domvvl
+   USE phycst, only : rcp, rau0, r1_rau0, rhosn, rhoic
+   USE in_out_manager  ! I/O manager
+   USE iom, ONLY : iom_put,iom_use              ! I/O manager library !!Joakim edit
+   USE lib_mpp         ! distributed memory computing library
+   USE lbclnk          ! ocean lateral boundary conditions (or mpp link)
+   USE daymod          ! calendar
+   USE fldread         ! read input fields
+   USE sbc_oce         ! Surface boundary condition: ocean fields
+   USE sbc_ice         ! Surface boundary condition: ice   fields
+   USE sbcblk          ! Surface boundary condition: bulk
+   USE sbccpl
+
+   USE ice_kinds_mod
+   USE ice_blocks
+   USE ice_domain
+   USE ice_domain_size
+   USE ice_boundary
+   USE ice_constants
+   USE ice_gather_scatter
+   USE ice_calendar, only: dt
+   USE ice_state, only: aice,aicen,uvel,vvel,vsno,vsnon,vice,vicen
+# if defined key_cice4
+   USE ice_flux, only: strax,stray,strocnx,strocny,frain,fsnow,  &
+                strocnxT,strocnyT,                               & 
+                sst,sss,uocn,vocn,ss_tltx,ss_tlty,fsalt_gbm,     &
+                fresh_gbm,fhocn_gbm,fswthru_gbm,frzmlt,          &
+                flatn_f,fsurfn_f,fcondtopn_f,                    &
+                uatm,vatm,wind,fsw,flw,Tair,potT,Qa,rhoa,zlvl,   &
+                swvdr,swvdf,swidr,swidf
+   USE ice_therm_vertical, only: calc_Tsfc
+#else
+   USE ice_flux, only: strax,stray,strocnx,strocny,frain,fsnow,  &
+                strocnxT,strocnyT,                               & 
+                sst,sss,uocn,vocn,ss_tltx,ss_tlty,fsalt_ai,     &
+                fresh_ai,fhocn_ai,fswthru_ai,frzmlt,          &
+                flatn_f,fsurfn_f,fcondtopn_f,                    &
+                uatm,vatm,wind,fsw,flw,Tair,potT,Qa,rhoa,zlvl,   &
+                swvdr,swvdf,swidr,swidf
+   USE ice_therm_shared, only: calc_Tsfc
+#endif
+   USE ice_forcing, only: frcvdr,frcvdf,frcidr,frcidf
+   USE ice_atmo, only: calc_strair
+
+   USE CICE_InitMod
+   USE CICE_RunMod
+   USE CICE_FinalMod
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC cice_sbc_init   ! routine called by sbc_init
+   PUBLIC cice_sbc_final  ! routine called by sbc_final
+   PUBLIC sbc_ice_cice    ! routine called by sbc
+
+   INTEGER             ::   ji_off
+   INTEGER             ::   jj_off
+
+   INTEGER , PARAMETER ::   jpfld   = 13   ! maximum number of files to read 
+   INTEGER , PARAMETER ::   jp_snow = 1    ! index of snow file
+   INTEGER , PARAMETER ::   jp_rain = 2    ! index of rain file
+   INTEGER , PARAMETER ::   jp_sblm = 3    ! index of sublimation file
+   INTEGER , PARAMETER ::   jp_top1 = 4    ! index of category 1 topmelt file
+   INTEGER , PARAMETER ::   jp_top2 = 5    ! index of category 2 topmelt file
+   INTEGER , PARAMETER ::   jp_top3 = 6    ! index of category 3 topmelt file
+   INTEGER , PARAMETER ::   jp_top4 = 7    ! index of category 4 topmelt file
+   INTEGER , PARAMETER ::   jp_top5 = 8    ! index of category 5 topmelt file
+   INTEGER , PARAMETER ::   jp_bot1 = 9    ! index of category 1 botmelt file
+   INTEGER , PARAMETER ::   jp_bot2 = 10   ! index of category 2 botmelt file
+   INTEGER , PARAMETER ::   jp_bot3 = 11   ! index of category 3 botmelt file
+   INTEGER , PARAMETER ::   jp_bot4 = 12   ! index of category 4 botmelt file
+   INTEGER , PARAMETER ::   jp_bot5 = 13   ! index of category 5 botmelt file
+   TYPE(FLD), ALLOCATABLE, DIMENSION(:) ::   sf    ! structure of input fields (file informations, fields read)
+
+   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:), PRIVATE ::   png     ! local array used in sbc_cice_ice
+
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.7 , NEMO-consortium (2015) 
+   !! $Id$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   INTEGER FUNCTION sbc_ice_cice_alloc()
+      !!----------------------------------------------------------------------
+      !!                ***  FUNCTION sbc_ice_cice_alloc  ***
+      !!----------------------------------------------------------------------
+      ALLOCATE( png(jpi,jpj,jpnij), STAT=sbc_ice_cice_alloc )
+      IF( lk_mpp                 )   CALL mpp_sum ( sbc_ice_cice_alloc )
+      IF( sbc_ice_cice_alloc > 0 )   CALL ctl_warn('sbc_ice_cice_alloc: allocation of arrays failed.')
+   END FUNCTION sbc_ice_cice_alloc
+
+   SUBROUTINE sbc_ice_cice( kt, ksbc )
+      !!---------------------------------------------------------------------
+      !!                  ***  ROUTINE sbc_ice_cice  ***
+      !!                   
+      !! ** Purpose :   update the ocean surface boundary condition via the 
+      !!                CICE Sea Ice Model time stepping 
+      !!
+      !! ** Method  : - Get any extra forcing fields for CICE  
+      !!              - Prepare forcing fields
+      !!              - CICE model time stepping
+      !!              - call the routine that computes mass and 
+      !!                heat fluxes at the ice/ocean interface
+      !!
+      !! ** Action  : - time evolution of the CICE sea-ice model
+      !!              - update all sbc variables below sea-ice:
+      !!                utau, vtau, qns , qsr, emp , sfx
+      !!---------------------------------------------------------------------
+      INTEGER, INTENT(in) ::   kt      ! ocean time step
+      INTEGER, INTENT(in) ::   ksbc    ! surface forcing type
+      !!----------------------------------------------------------------------
+      !
+      !                                        !----------------------!
+      IF( MOD( kt-1, nn_fsbc ) == 0 ) THEN     !  Ice time-step only  !
+         !                                     !----------------------!
+
+         ! Make sure any fluxes required for CICE are set
+         IF      ( ksbc == jp_flx ) THEN
+            CALL cice_sbc_force(kt)
+         ELSE IF ( ksbc == jp_purecpl ) THEN
+            CALL sbc_cpl_ice_flx( fr_i )
+         ENDIF
+
+         CALL cice_sbc_in  ( kt, ksbc )
+         CALL CICE_Run
+         CALL cice_sbc_out ( kt, ksbc )
+
+         IF ( ksbc == jp_purecpl )  CALL cice_sbc_hadgam(kt+1)
+
+      ENDIF                                          ! End sea-ice time step only
+      !
+   END SUBROUTINE sbc_ice_cice
+
+
+   SUBROUTINE cice_sbc_init( ksbc )
+      !!---------------------------------------------------------------------
+      !!                    ***  ROUTINE cice_sbc_init  ***
+      !! ** Purpose: Initialise ice related fields for NEMO and coupling
+      !!
+      !!---------------------------------------------------------------------
+      INTEGER, INTENT( in  ) ::   ksbc                ! surface forcing type
+      REAL(wp), DIMENSION(jpi,jpj) :: ztmp1, ztmp2
+      REAL(wp) ::   zcoefu, zcoefv, zcoeff            ! local scalar
+      INTEGER  ::   ji, jj, jl, jk                    ! dummy loop indices
+      !!---------------------------------------------------------------------
+      !
+      IF(lwp) WRITE(numout,*)'cice_sbc_init'
+
+      ji_off = INT ( (jpiglo - nx_global) / 2 )
+      jj_off = INT ( (jpjglo - ny_global) / 2 )
+
+#if defined key_nemocice_decomp
+      ! Pass initial SST from NEMO to CICE so ice is initialised correctly if
+      ! there is no restart file.
+      ! Values from a CICE restart file would overwrite this
+      IF ( .NOT. ln_rstart ) THEN    
+         CALL nemo2cice( tsn(:,:,1,jp_tem) , sst , 'T' , 1.) 
+      ENDIF  
+#endif
+
+! Initialize CICE
+      CALL CICE_Initialize
+
+! Do some CICE consistency checks
+      IF ( (ksbc == jp_flx) .OR. (ksbc == jp_purecpl) ) THEN
+         IF ( calc_strair .OR. calc_Tsfc ) THEN
+            CALL ctl_stop( 'STOP', 'cice_sbc_init : Forcing option requires calc_strair=F and calc_Tsfc=F in ice_in' )
+         ENDIF
+      ELSEIF (ksbc == jp_blk) THEN
+         IF ( .NOT. (calc_strair .AND. calc_Tsfc) ) THEN
+            CALL ctl_stop( 'STOP', 'cice_sbc_init : Forcing option requires calc_strair=T and calc_Tsfc=T in ice_in' )
+         ENDIF
+      ENDIF
+
+
+! allocate sbc_ice and sbc_cice arrays
+      IF( sbc_ice_alloc()      /= 0 )   CALL ctl_stop( 'STOP', 'sbc_ice_cice_alloc : unable to allocate arrays' )
+      IF( sbc_ice_cice_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'sbc_ice_cice_alloc : unable to allocate cice arrays' )
+
+! Ensure ocean temperatures are nowhere below freezing if not a NEMO restart
+      IF( .NOT. ln_rstart ) THEN
+         tsn(:,:,:,jp_tem) = MAX (tsn(:,:,:,jp_tem),Tocnfrz)
+         tsb(:,:,:,jp_tem) = tsn(:,:,:,jp_tem)
+      ENDIF
+
+      fr_iu(:,:)=0.0
+      fr_iv(:,:)=0.0
+
+      CALL cice2nemo(aice,fr_i, 'T', 1. )
+      IF ( (ksbc == jp_flx) .OR. (ksbc == jp_purecpl) ) THEN
+         DO jl=1,ncat
+            CALL cice2nemo(aicen(:,:,jl,:),a_i(:,:,jl), 'T', 1. )
+         ENDDO
+      ENDIF
+
+! T point to U point
+! T point to V point
+      DO jj=1,jpjm1
+         DO ji=1,jpim1
+            fr_iu(ji,jj)=0.5*(fr_i(ji,jj)+fr_i(ji+1,jj))*umask(ji,jj,1)
+            fr_iv(ji,jj)=0.5*(fr_i(ji,jj)+fr_i(ji,jj+1))*vmask(ji,jj,1)
+         ENDDO
+      ENDDO
+
+      CALL lbc_lnk_multi( fr_iu , 'U', 1.,  fr_iv , 'V', 1. )
+
+      ! set the snow+ice mass
+      CALL cice2nemo(vsno(:,:,:),ztmp1,'T', 1. )
+      CALL cice2nemo(vice(:,:,:),ztmp2,'T', 1. )
+      snwice_mass  (:,:) = ( rhosn * ztmp1(:,:) + rhoic * ztmp2(:,:)  )
+      snwice_mass_b(:,:) = snwice_mass(:,:)
+
+      IF( .NOT.ln_rstart ) THEN
+         IF( ln_ice_embd ) THEN            ! embedded sea-ice: deplete the initial ssh below sea-ice area
+            sshn(:,:) = sshn(:,:) - snwice_mass(:,:) * r1_rau0
+            sshb(:,:) = sshb(:,:) - snwice_mass(:,:) * r1_rau0
+
+!!gm This should be put elsewhere....   (same remark for limsbc)
+!!gm especially here it is assumed zstar coordinate, but it can be ztilde....
+            IF( .NOT.ln_linssh ) THEN
+               !
+               DO jk = 1,jpkm1                     ! adjust initial vertical scale factors
+                  e3t_n(:,:,jk) = e3t_0(:,:,jk)*( 1._wp + sshn(:,:)*tmask(:,:,1)/(ht_0(:,:) + 1.0 - tmask(:,:,1)) )
+                  e3t_b(:,:,jk) = e3t_0(:,:,jk)*( 1._wp + sshb(:,:)*tmask(:,:,1)/(ht_0(:,:) + 1.0 - tmask(:,:,1)) )
+               ENDDO
+               e3t_a(:,:,:) = e3t_b(:,:,:)
+               ! Reconstruction of all vertical scale factors at now and before time-steps
+               ! =============================================================================
+               ! Horizontal scale factor interpolations
+               ! --------------------------------------
+               CALL dom_vvl_interpol( e3t_b(:,:,:), e3u_b(:,:,:), 'U' )
+               CALL dom_vvl_interpol( e3t_b(:,:,:), e3v_b(:,:,:), 'V' )
+               CALL dom_vvl_interpol( e3t_n(:,:,:), e3u_n(:,:,:), 'U' )
+               CALL dom_vvl_interpol( e3t_n(:,:,:), e3v_n(:,:,:), 'V' )
+               CALL dom_vvl_interpol( e3u_n(:,:,:), e3f_n(:,:,:), 'F' )
+               ! Vertical scale factor interpolations
+               ! ------------------------------------
+               CALL dom_vvl_interpol( e3t_n(:,:,:), e3w_n (:,:,:), 'W'  )
+               CALL dom_vvl_interpol( e3u_n(:,:,:), e3uw_n(:,:,:), 'UW' )
+               CALL dom_vvl_interpol( e3v_n(:,:,:), e3vw_n(:,:,:), 'VW' )
+               CALL dom_vvl_interpol( e3u_b(:,:,:), e3uw_b(:,:,:), 'UW' )
+               CALL dom_vvl_interpol( e3v_b(:,:,:), e3vw_b(:,:,:), 'VW' )
+               ! t- and w- points depth
+               ! ----------------------
+               gdept_n(:,:,1) = 0.5_wp * e3w_n(:,:,1)
+               gdepw_n(:,:,1) = 0.0_wp
+               gde3w_n(:,:,1) = gdept_n(:,:,1) - sshn(:,:)
+               DO jk = 2, jpk
+                  gdept_n(:,:,jk) = gdept_n(:,:,jk-1) + e3w_n(:,:,jk)
+                  gdepw_n(:,:,jk) = gdepw_n(:,:,jk-1) + e3t_n(:,:,jk-1)
+                  gde3w_n(:,:,jk) = gdept_n(:,:,jk  ) - sshn   (:,:)
+               END DO
+            ENDIF
+         ENDIF
+      ENDIF
+      !
+   END SUBROUTINE cice_sbc_init
+
+   
+   SUBROUTINE cice_sbc_in( kt, ksbc )
+      !!---------------------------------------------------------------------
+      !!                    ***  ROUTINE cice_sbc_in  ***
+      !! ** Purpose: Set coupling fields and pass to CICE
+      !!---------------------------------------------------------------------
+      INTEGER, INTENT(in   ) ::   kt   ! ocean time step
+      INTEGER, INTENT(in   ) ::   ksbc ! surface forcing type
+      !
+      INTEGER  ::   ji, jj, jl                   ! dummy loop indices      
+      REAL(wp), DIMENSION(jpi,jpj) :: ztmp, zpice
+      REAL(wp), DIMENSION(jpi,jpj,ncat) :: ztmpn
+      REAL(wp) ::   zintb, zintn  ! dummy argument
+      !!---------------------------------------------------------------------
+      !
+      IF( kt == nit000 )  THEN
+         IF(lwp) WRITE(numout,*)'cice_sbc_in'
+      ENDIF
+
+      ztmp(:,:)=0.0
+
+! Aggregate ice concentration already set in cice_sbc_out (or cice_sbc_init on 
+! the first time-step)
+
+! forced and coupled case 
+
+      IF ( (ksbc == jp_flx).OR.(ksbc == jp_purecpl) ) THEN
+
+         ztmpn(:,:,:)=0.0
+
+! x comp of wind stress (CI_1)
+! U point to F point
+         DO jj=1,jpjm1
+            DO ji=1,jpi
+               ztmp(ji,jj) = 0.5 * (  fr_iu(ji,jj) * utau(ji,jj)      &
+                                    + fr_iu(ji,jj+1) * utau(ji,jj+1) ) * fmask(ji,jj,1)
+            ENDDO
+         ENDDO
+         CALL nemo2cice(ztmp,strax,'F', -1. )
+
+! y comp of wind stress (CI_2)
+! V point to F point
+         DO jj=1,jpj
+            DO ji=1,jpim1
+               ztmp(ji,jj) = 0.5 * (  fr_iv(ji,jj) * vtau(ji,jj)      &
+                                    + fr_iv(ji+1,jj) * vtau(ji+1,jj) ) * fmask(ji,jj,1)
+            ENDDO
+         ENDDO
+         CALL nemo2cice(ztmp,stray,'F', -1. )
+
+! Surface downward latent heat flux (CI_5)
+         IF (ksbc == jp_flx) THEN
+            DO jl=1,ncat
+               ztmpn(:,:,jl)=qla_ice(:,:,1)*a_i(:,:,jl)
+            ENDDO
+         ELSE
+! emp_ice is set in sbc_cpl_ice_flx as sublimation-snow
+            qla_ice(:,:,1)= - ( emp_ice(:,:)+sprecip(:,:) ) * Lsub
+! End of temporary code
+            DO jj=1,jpj
+               DO ji=1,jpi
+                  IF (fr_i(ji,jj).eq.0.0) THEN
+                     DO jl=1,ncat
+                        ztmpn(ji,jj,jl)=0.0
+                     ENDDO
+                     ! This will then be conserved in CICE
+                     ztmpn(ji,jj,1)=qla_ice(ji,jj,1)
+                  ELSE
+                     DO jl=1,ncat
+                        ztmpn(ji,jj,jl)=qla_ice(ji,jj,1)*a_i(ji,jj,jl)/fr_i(ji,jj)
+                     ENDDO
+                  ENDIF
+               ENDDO
+            ENDDO
+         ENDIF
+         DO jl=1,ncat
+            CALL nemo2cice(ztmpn(:,:,jl),flatn_f(:,:,jl,:),'T', 1. )
+
+! GBM conductive flux through ice (CI_6)
+!  Convert to GBM
+            IF (ksbc == jp_flx) THEN
+               ztmp(:,:) = botmelt(:,:,jl)*a_i(:,:,jl)
+            ELSE
+               ztmp(:,:) = botmelt(:,:,jl)
+            ENDIF
+            CALL nemo2cice(ztmp,fcondtopn_f(:,:,jl,:),'T', 1. )
+
+! GBM surface heat flux (CI_7)
+!  Convert to GBM
+            IF (ksbc == jp_flx) THEN
+               ztmp(:,:) = (topmelt(:,:,jl)+botmelt(:,:,jl))*a_i(:,:,jl) 
+            ELSE
+               ztmp(:,:) = (topmelt(:,:,jl)+botmelt(:,:,jl))
+            ENDIF
+            CALL nemo2cice(ztmp,fsurfn_f(:,:,jl,:),'T', 1. )
+         ENDDO
+
+      ELSE IF (ksbc == jp_blk) THEN
+
+! Pass bulk forcing fields to CICE (which will calculate heat fluxes etc itself)
+! x comp and y comp of atmosphere surface wind (CICE expects on T points)
+         ztmp(:,:) = wndi_ice(:,:)
+         CALL nemo2cice(ztmp,uatm,'T', -1. )
+         ztmp(:,:) = wndj_ice(:,:)
+         CALL nemo2cice(ztmp,vatm,'T', -1. )
+         ztmp(:,:) = SQRT ( wndi_ice(:,:)**2 + wndj_ice(:,:)**2 )
+         CALL nemo2cice(ztmp,wind,'T', 1. )    ! Wind speed (m/s)
+         ztmp(:,:) = qsr_ice(:,:,1)
+         CALL nemo2cice(ztmp,fsw,'T', 1. )     ! Incoming short-wave (W/m^2)
+         ztmp(:,:) = qlw_ice(:,:,1)
+         CALL nemo2cice(ztmp,flw,'T', 1. )     ! Incoming long-wave (W/m^2)
+         ztmp(:,:) = tatm_ice(:,:)
+         CALL nemo2cice(ztmp,Tair,'T', 1. )    ! Air temperature (K)
+         CALL nemo2cice(ztmp,potT,'T', 1. )    ! Potential temp (K)
+! Following line uses MAX(....) to avoid problems if tatm_ice has unset halo rows  
+         ztmp(:,:) = 101000. / ( 287.04 * MAX(1.0,tatm_ice(:,:)) )    
+                                               ! Constant (101000.) atm pressure assumed
+         CALL nemo2cice(ztmp,rhoa,'T', 1. )    ! Air density (kg/m^3)
+         ztmp(:,:) = qatm_ice(:,:)
+         CALL nemo2cice(ztmp,Qa,'T', 1. )      ! Specific humidity (kg/kg)
+         ztmp(:,:)=10.0
+         CALL nemo2cice(ztmp,zlvl,'T', 1. )    ! Atmos level height (m)
+
+! May want to check all values are physically realistic (as in CICE routine 
+! prepare_forcing)?
+
+! Divide shortwave into spectral bands (as in prepare_forcing)
+         ztmp(:,:)=qsr_ice(:,:,1)*frcvdr       ! visible direct
+         CALL nemo2cice(ztmp,swvdr,'T', 1. )             
+         ztmp(:,:)=qsr_ice(:,:,1)*frcvdf       ! visible diffuse
+         CALL nemo2cice(ztmp,swvdf,'T', 1. )              
+         ztmp(:,:)=qsr_ice(:,:,1)*frcidr       ! near IR direct
+         CALL nemo2cice(ztmp,swidr,'T', 1. )
+         ztmp(:,:)=qsr_ice(:,:,1)*frcidf       ! near IR diffuse
+         CALL nemo2cice(ztmp,swidf,'T', 1. )
+
+      ENDIF
+
+! Snowfall
+! Ensure fsnow is positive (as in CICE routine prepare_forcing)
+      IF( iom_use('snowpre') )   CALL iom_put('snowpre',MAX( (1.0-fr_i(:,:))*sprecip(:,:) ,0.0)) !!Joakim edit  
+      ztmp(:,:)=MAX(fr_i(:,:)*sprecip(:,:),0.0)  
+      CALL nemo2cice(ztmp,fsnow,'T', 1. ) 
+
+! Rainfall
+      IF( iom_use('precip') )   CALL iom_put('precip', (1.0-fr_i(:,:))*(tprecip(:,:)-sprecip(:,:)) ) !!Joakim edit
+      ztmp(:,:)=fr_i(:,:)*(tprecip(:,:)-sprecip(:,:))
+      CALL nemo2cice(ztmp,frain,'T', 1. ) 
+
+! Freezing/melting potential
+! Calculated over NEMO leapfrog timestep (hence 2*dt)
+      nfrzmlt(:,:) = rau0 * rcp * e3t_m(:,:) * ( Tocnfrz-sst_m(:,:) ) / ( 2.0*dt )
+
+      ztmp(:,:) = nfrzmlt(:,:)
+      CALL nemo2cice(ztmp,frzmlt,'T', 1. )
+
+! SST  and SSS
+
+      CALL nemo2cice(sst_m,sst,'T', 1. )
+      CALL nemo2cice(sss_m,sss,'T', 1. )
+
+! x comp and y comp of surface ocean current
+! U point to F point
+      DO jj=1,jpjm1
+         DO ji=1,jpi
+            ztmp(ji,jj)=0.5*(ssu_m(ji,jj)+ssu_m(ji,jj+1))*fmask(ji,jj,1)
+         ENDDO
+      ENDDO
+      CALL nemo2cice(ztmp,uocn,'F', -1. )
+
+! V point to F point
+      DO jj=1,jpj
+         DO ji=1,jpim1
+            ztmp(ji,jj)=0.5*(ssv_m(ji,jj)+ssv_m(ji+1,jj))*fmask(ji,jj,1)
+         ENDDO
+      ENDDO
+      CALL nemo2cice(ztmp,vocn,'F', -1. )
+
+      IF( ln_ice_embd ) THEN             !== embedded sea ice: compute representative ice top surface ==!
+          !
+          ! average interpolation coeff as used in dynspg = (1/nn_fsbc) * {SUM[n/nn_fsbc], n=0,nn_fsbc-1}
+          !                                               = (1/nn_fsbc)^2 * {SUM[n], n=0,nn_fsbc-1}
+         zintn = REAL( nn_fsbc - 1 ) / REAL( nn_fsbc ) * 0.5_wp
+          !
+          ! average interpolation coeff as used in dynspg = (1/nn_fsbc) * {SUM[1-n/nn_fsbc], n=0,nn_fsbc-1}
+          !                                               = (1/nn_fsbc)^2 * (nn_fsbc^2 - {SUM[n], n=0,nn_fsbc-1})
+         zintb = REAL( nn_fsbc + 1 ) / REAL( nn_fsbc ) * 0.5_wp
+          !
+         zpice(:,:) = ssh_m(:,:) + (  zintn * snwice_mass(:,:) +  zintb * snwice_mass_b(:,:)  ) * r1_rau0
+          !
+         !
+      ELSE                                    !== non-embedded sea ice: use ocean surface for slope calculation ==!
+         zpice(:,:) = ssh_m(:,:)
+      ENDIF
+
+! x comp and y comp of sea surface slope (on F points)
+! T point to F point
+      DO jj = 1, jpjm1
+         DO ji = 1, jpim1
+            ztmp(ji,jj)=0.5 * (  (zpice(ji+1,jj  )-zpice(ji,jj  )) * r1_e1u(ji,jj  )    &
+               &               + (zpice(ji+1,jj+1)-zpice(ji,jj+1)) * r1_e1u(ji,jj+1)  ) * fmask(ji,jj,1)
+         END DO
+      END DO
+      CALL nemo2cice( ztmp,ss_tltx,'F', -1. )
+
+! T point to F point
+      DO jj = 1, jpjm1
+         DO ji = 1, jpim1
+            ztmp(ji,jj)=0.5 * (  (zpice(ji  ,jj+1)-zpice(ji  ,jj)) * r1_e2v(ji  ,jj)    &
+               &               + (zpice(ji+1,jj+1)-zpice(ji+1,jj)) * r1_e2v(ji+1,jj)  ) *  fmask(ji,jj,1)
+         END DO
+      END DO
+      CALL nemo2cice(ztmp,ss_tlty,'F', -1. )
+      !
+   END SUBROUTINE cice_sbc_in
+
+
+   SUBROUTINE cice_sbc_out( kt, ksbc )
+      !!---------------------------------------------------------------------
+      !!                    ***  ROUTINE cice_sbc_out  ***
+      !! ** Purpose: Get fields from CICE and set surface fields for NEMO
+      !!---------------------------------------------------------------------
+      INTEGER, INTENT( in  ) ::   kt   ! ocean time step
+      INTEGER, INTENT( in  ) ::   ksbc ! surface forcing type
+      
+      INTEGER  ::   ji, jj, jl                 ! dummy loop indices
+      REAL(wp), DIMENSION(jpi,jpj) :: ztmp1, ztmp2
+      !!---------------------------------------------------------------------
+      !
+      IF( kt == nit000 )  THEN
+         IF(lwp) WRITE(numout,*)'cice_sbc_out'
+      ENDIF
+      
+! x comp of ocean-ice stress 
+      CALL cice2nemo(strocnx,ztmp1,'F', -1. )
+      ss_iou(:,:)=0.0
+! F point to U point
+      DO jj=2,jpjm1
+         DO ji=2,jpim1
+            ss_iou(ji,jj) = 0.5 * ( ztmp1(ji,jj-1) + ztmp1(ji,jj) ) * umask(ji,jj,1)
+         ENDDO
+      ENDDO
+      CALL lbc_lnk( ss_iou , 'U', -1. )
+
+! y comp of ocean-ice stress 
+      CALL cice2nemo(strocny,ztmp1,'F', -1. )
+      ss_iov(:,:)=0.0
+! F point to V point
+
+      DO jj=1,jpjm1
+         DO ji=2,jpim1
+            ss_iov(ji,jj) = 0.5 * ( ztmp1(ji-1,jj) + ztmp1(ji,jj) ) * vmask(ji,jj,1)
+         ENDDO
+      ENDDO
+      CALL lbc_lnk( ss_iov , 'V', -1. )
+
+! x and y comps of surface stress
+! Combine wind stress and ocean-ice stress
+! [Note that fr_iu hasn't yet been updated, so still from start of CICE timestep]
+! strocnx and strocny already weighted by ice fraction in CICE so not done here 
+
+      utau(:,:)=(1.0-fr_iu(:,:))*utau(:,:)-ss_iou(:,:)
+      vtau(:,:)=(1.0-fr_iv(:,:))*vtau(:,:)-ss_iov(:,:)     
+ 
+! Also need ice/ocean stress on T points so that taum can be updated 
+! This interpolation is already done in CICE so best to use those values 
+      CALL cice2nemo(strocnxT,ztmp1,'T',-1.) 
+      CALL cice2nemo(strocnyT,ztmp2,'T',-1.) 
+ 
+! Update taum with modulus of ice-ocean stress 
+! strocnxT and strocnyT are not weighted by ice fraction in CICE so must be done here 
+taum(:,:)=(1.0-fr_i(:,:))*taum(:,:)+fr_i(:,:)*SQRT(ztmp1*ztmp1 + ztmp2*ztmp2) 
+
+! Freshwater fluxes 
+
+      IF (ksbc == jp_flx) THEN
+! Note that emp from the forcing files is evap*(1-aice)-(tprecip-aice*sprecip)
+! What we want here is evap*(1-aice)-tprecip*(1-aice) hence manipulation below
+! Not ideal since aice won't be the same as in the atmosphere.  
+! Better to use evap and tprecip? (but for now don't read in evap in this case)
+         emp(:,:)  = emp(:,:)+fr_i(:,:)*(tprecip(:,:)-sprecip(:,:))
+      ELSE IF (ksbc == jp_blk) THEN
+         emp(:,:)  = (1.0-fr_i(:,:))*emp(:,:)        
+      ELSE IF (ksbc == jp_purecpl) THEN
+! emp_tot is set in sbc_cpl_ice_flx (called from cice_sbc_in above) 
+! This is currently as required with the coupling fields from the UM atmosphere
+         emp(:,:) = emp_tot(:,:)+tprecip(:,:)*fr_i(:,:) 
+      ENDIF
+
+#if defined key_cice4
+      CALL cice2nemo(fresh_gbm,ztmp1,'T', 1. )
+      CALL cice2nemo(fsalt_gbm,ztmp2,'T', 1. )
+#else
+      CALL cice2nemo(fresh_ai,ztmp1,'T', 1. )
+      CALL cice2nemo(fsalt_ai,ztmp2,'T', 1. )
+#endif
+
+! Check to avoid unphysical expression when ice is forming (ztmp1 negative)
+! Otherwise we are effectively allowing ice of higher salinity than the ocean to form
+! which has to be compensated for by the ocean salinity potentially going negative
+! This check breaks conservation but seems reasonable until we have prognostic ice salinity
+! Note the 1000.0 below is to convert from kg salt to g salt (needed for PSU)
+      WHERE (ztmp1(:,:).lt.0.0) ztmp2(:,:)=MAX(ztmp2(:,:),ztmp1(:,:)*sss_m(:,:)/1000.0)
+      sfx(:,:)=ztmp2(:,:)*1000.0
+      emp(:,:)=emp(:,:)-ztmp1(:,:)
+      fmmflx(:,:) = ztmp1(:,:) !!Joakim edit
+      
+      CALL lbc_lnk_multi( emp , 'T', 1., sfx , 'T', 1. )
+
+! Solar penetrative radiation and non solar surface heat flux
+
+! Scale qsr and qns according to ice fraction (bulk formulae only)
+
+      IF (ksbc == jp_blk) THEN
+         qsr(:,:)=qsr(:,:)*(1.0-fr_i(:,:))
+         qns(:,:)=qns(:,:)*(1.0-fr_i(:,:))
+      ENDIF
+! Take into account snow melting except for fully coupled when already in qns_tot
+      IF (ksbc == jp_purecpl) THEN
+         qsr(:,:)= qsr_tot(:,:)
+         qns(:,:)= qns_tot(:,:)
+      ELSE
+         qns(:,:)= qns(:,:)-sprecip(:,:)*Lfresh*(1.0-fr_i(:,:))
+      ENDIF
+
+! Now add in ice / snow related terms
+! [fswthru will be zero unless running with calc_Tsfc=T in CICE]
+#if defined key_cice4
+      CALL cice2nemo(fswthru_gbm,ztmp1,'T', 1. )
+#else
+      CALL cice2nemo(fswthru_ai,ztmp1,'T', 1. )
+#endif
+      qsr(:,:)=qsr(:,:)+ztmp1(:,:)
+      CALL lbc_lnk( qsr , 'T', 1. )
+
+      DO jj=1,jpj
+         DO ji=1,jpi
+            nfrzmlt(ji,jj)=MAX(nfrzmlt(ji,jj),0.0)
+         ENDDO
+      ENDDO
+
+#if defined key_cice4
+      CALL cice2nemo(fhocn_gbm,ztmp1,'T', 1. )
+#else
+      CALL cice2nemo(fhocn_ai,ztmp1,'T', 1. )
+#endif
+      qns(:,:)=qns(:,:)+nfrzmlt(:,:)+ztmp1(:,:)
+
+      CALL lbc_lnk( qns , 'T', 1. )
+
+! Prepare for the following CICE time-step
+
+      CALL cice2nemo(aice,fr_i,'T', 1. )
+      IF ( (ksbc == jp_flx).OR.(ksbc == jp_purecpl) ) THEN
+         DO jl=1,ncat
+            CALL cice2nemo(aicen(:,:,jl,:),a_i(:,:,jl), 'T', 1. )
+         ENDDO
+      ENDIF
+
+! T point to U point
+! T point to V point
+      DO jj=1,jpjm1
+         DO ji=1,jpim1
+            fr_iu(ji,jj)=0.5*(fr_i(ji,jj)+fr_i(ji+1,jj))*umask(ji,jj,1)
+            fr_iv(ji,jj)=0.5*(fr_i(ji,jj)+fr_i(ji,jj+1))*vmask(ji,jj,1)
+         ENDDO
+      ENDDO
+
+      CALL lbc_lnk_multi( fr_iu , 'U', 1., fr_iv , 'V', 1. )
+
+      ! set the snow+ice mass
+      CALL cice2nemo(vsno(:,:,:),ztmp1,'T', 1. )
+      CALL cice2nemo(vice(:,:,:),ztmp2,'T', 1. )
+      snwice_mass  (:,:) = ( rhosn * ztmp1(:,:) + rhoic * ztmp2(:,:)  )
+      snwice_mass_b(:,:) = snwice_mass(:,:)
+      snwice_fmass (:,:) = ( snwice_mass(:,:) - snwice_mass_b(:,:) ) / dt
+      !
+   END SUBROUTINE cice_sbc_out
+
+
+   SUBROUTINE cice_sbc_hadgam( kt )
+      !!---------------------------------------------------------------------
+      !!                    ***  ROUTINE cice_sbc_hadgam  ***
+      !! ** Purpose: Prepare fields needed to pass to HadGAM3 atmosphere
+      !! 
+      !!
+      !!---------------------------------------------------------------------
+      INTEGER, INTENT( in  ) ::   kt   ! ocean time step
+      !!
+      INTEGER  ::   jl                        ! dummy loop index
+      INTEGER  ::   ierror
+      !!---------------------------------------------------------------------
+      !
+      IF( kt == nit000 )  THEN
+         IF(lwp) WRITE(numout,*)'cice_sbc_hadgam'
+         IF( sbc_cpl_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'sbc_cpl_alloc : unable to allocate arrays' )
+      ENDIF
+
+      !                                         ! =========================== !
+      !                                         !   Prepare Coupling fields   !
+      !                                         ! =========================== !
+      !
+      ! x and y comp of ice velocity
+      !
+      CALL cice2nemo(uvel,u_ice,'F', -1. )
+      CALL cice2nemo(vvel,v_ice,'F', -1. )
+      !
+      ! Ice concentration (CO_1) = a_i calculated at end of cice_sbc_out  
+      !
+      ! Snow and ice thicknesses (CO_2 and CO_3)
+      !
+      DO jl = 1, ncat
+         CALL cice2nemo( vsnon(:,:,jl,:), h_s(:,:,jl),'T', 1. )
+         CALL cice2nemo( vicen(:,:,jl,:), h_i(:,:,jl),'T', 1. )
+      END DO
+      !
+   END SUBROUTINE cice_sbc_hadgam
+
+
+   SUBROUTINE cice_sbc_final
+      !!---------------------------------------------------------------------
+      !!                    ***  ROUTINE cice_sbc_final  ***
+      !! ** Purpose: Finalize CICE
+      !!---------------------------------------------------------------------
+      !
+      IF(lwp) WRITE(numout,*)'cice_sbc_final'
+      !
+      CALL CICE_Finalize
+      !
+   END SUBROUTINE cice_sbc_final
+
+
+   SUBROUTINE cice_sbc_force (kt)
+      !!---------------------------------------------------------------------
+      !!                    ***  ROUTINE cice_sbc_force  ***
+      !! ** Purpose : Provide CICE forcing from files
+      !!
+      !!---------------------------------------------------------------------
+      !! ** Method  :   READ monthly flux file in NetCDF files
+      !!      
+      !!  snowfall    
+      !!  rainfall    
+      !!  sublimation rate    
+      !!  topmelt (category)
+      !!  botmelt (category)
+      !!
+      !! History :
+      !!----------------------------------------------------------------------
+      USE iom
+      !!
+      INTEGER, INTENT( in  ) ::   kt   ! ocean time step
+      !!
+      INTEGER  ::   ierror             ! return error code
+      INTEGER  ::   ifpr               ! dummy loop index
+      !!
+      CHARACTER(len=100) ::  cn_dir                            !   Root directory for location of CICE forcing files
+      TYPE(FLD_N), DIMENSION(jpfld) ::   slf_i                 ! array of namelist informations on the fields to read
+      TYPE(FLD_N) ::   sn_snow, sn_rain, sn_sblm               ! informations about the fields to be read
+      TYPE(FLD_N) ::   sn_top1, sn_top2, sn_top3, sn_top4, sn_top5
+      TYPE(FLD_N) ::   sn_bot1, sn_bot2, sn_bot3, sn_bot4, sn_bot5 
+      !!
+      NAMELIST/namsbc_cice/ cn_dir, sn_snow, sn_rain, sn_sblm,   &
+         &                          sn_top1, sn_top2, sn_top3, sn_top4, sn_top5,  &
+         &                          sn_bot1, sn_bot2, sn_bot3, sn_bot4, sn_bot5
+      INTEGER :: ios
+      !!---------------------------------------------------------------------
+
+      !                                         ! ====================== !
+      IF( kt == nit000 ) THEN                   !  First call kt=nit000  !
+         !                                      ! ====================== !
+         ! namsbc_cice is not yet in the reference namelist
+         ! set file information (default values)
+         cn_dir = './'       ! directory in which the model is executed
+
+         ! (NB: frequency positive => hours, negative => months)
+         !            !    file          ! frequency !  variable    ! time intep !  clim   ! 'yearly' or ! weights  ! rotation   ! landmask
+         !            !    name          !  (hours)  !   name       !   (T/F)    !  (T/F)  !  'monthly'  ! filename ! pairs      ! file
+         sn_snow = FLD_N( 'snowfall_1m'  ,    -1.    ,  'snowfall'  ,  .true.    , .true.  ,  ' yearly'  , ''       , ''         ,  ''    ) 
+         sn_rain = FLD_N( 'rainfall_1m'  ,    -1.    ,  'rainfall'  ,  .true.    , .true.  ,  ' yearly'  , ''       , ''         ,  ''    ) 
+         sn_sblm = FLD_N( 'sublim_1m'    ,    -1.    ,  'sublim'    ,  .true.    , .true.  ,  ' yearly'  , ''       , ''         ,  ''    )
+         sn_top1 = FLD_N( 'topmeltn1_1m' ,    -1.    ,  'topmeltn1' ,  .true.    , .true.  ,  ' yearly'  , ''       , ''         ,  ''    )
+         sn_top2 = FLD_N( 'topmeltn2_1m' ,    -1.    ,  'topmeltn2' ,  .true.    , .true.  ,  ' yearly'  , ''       , ''         ,  ''    )
+         sn_top3 = FLD_N( 'topmeltn3_1m' ,    -1.    ,  'topmeltn3' ,  .true.    , .true.  ,  ' yearly'  , ''       , ''         ,  ''    )
+         sn_top4 = FLD_N( 'topmeltn4_1m' ,    -1.    ,  'topmeltn4' ,  .true.    , .true.  ,  ' yearly'  , ''       , ''         ,  ''    )
+         sn_top5 = FLD_N( 'topmeltn5_1m' ,    -1.    ,  'topmeltn5' ,  .true.    , .true.  ,  ' yearly'  , ''       , ''         ,  ''    )
+         sn_bot1 = FLD_N( 'botmeltn1_1m' ,    -1.    ,  'botmeltn1' ,  .true.    , .true.  ,  ' yearly'  , ''       , ''         ,  ''    )
+         sn_bot2 = FLD_N( 'botmeltn2_1m' ,    -1.    ,  'botmeltn2' ,  .true.    , .true.  ,  ' yearly'  , ''       , ''         ,  ''    )
+         sn_bot3 = FLD_N( 'botmeltn3_1m' ,    -1.    ,  'botmeltn3' ,  .true.    , .true.  ,  ' yearly'  , ''       , ''         ,  ''    )
+         sn_bot4 = FLD_N( 'botmeltn4_1m' ,    -1.    ,  'botmeltn4' ,  .true.    , .true.  ,  ' yearly'  , ''       , ''         ,  ''    )
+         sn_bot5 = FLD_N( 'botmeltn5_1m' ,    -1.    ,  'botmeltn5' ,  .true.    , .true.  ,  ' yearly'  , ''       , ''         ,  ''    )
+
+         REWIND( numnam_ref )              ! Namelist namsbc_cice in reference namelist : 
+         READ  ( numnam_ref, namsbc_cice, IOSTAT = ios, ERR = 901)
+901      IF( ios /= 0 )   CALL ctl_nam ( ios , 'namsbc_cice in reference namelist', lwp )
+
+         REWIND( numnam_cfg )              ! Namelist namsbc_cice in configuration namelist : Parameters of the run
+         READ  ( numnam_cfg, namsbc_cice, IOSTAT = ios, ERR = 902 )
+902      IF( ios >  0 )   CALL ctl_nam ( ios , 'namsbc_cice in configuration namelist', lwp )
+         IF(lwm) WRITE ( numond, namsbc_cice )
+
+         ! store namelist information in an array
+         slf_i(jp_snow) = sn_snow   ;   slf_i(jp_rain) = sn_rain   ;   slf_i(jp_sblm) = sn_sblm
+         slf_i(jp_top1) = sn_top1   ;   slf_i(jp_top2) = sn_top2   ;   slf_i(jp_top3) = sn_top3
+         slf_i(jp_top4) = sn_top4   ;   slf_i(jp_top5) = sn_top5   ;   slf_i(jp_bot1) = sn_bot1
+         slf_i(jp_bot2) = sn_bot2   ;   slf_i(jp_bot3) = sn_bot3   ;   slf_i(jp_bot4) = sn_bot4
+         slf_i(jp_bot5) = sn_bot5
+         
+         ! set sf structure
+         ALLOCATE( sf(jpfld), STAT=ierror )
+         IF( ierror > 0 ) THEN
+            CALL ctl_stop( 'cice_sbc_force: unable to allocate sf structure' )   ;   RETURN
+         ENDIF
+
+         DO ifpr= 1, jpfld
+            ALLOCATE( sf(ifpr)%fnow(jpi,jpj,1) )
+            ALLOCATE( sf(ifpr)%fdta(jpi,jpj,1,2) )
+         END DO
+
+         ! fill sf with slf_i and control print
+         CALL fld_fill( sf, slf_i, cn_dir, 'cice_sbc_force', 'flux formulation for CICE', 'namsbc_cice' )
+         !
+      ENDIF
+
+      CALL fld_read( kt, nn_fsbc, sf )           ! Read input fields and provides the
+      !                                          ! input fields at the current time-step
+
+      ! set the fluxes from read fields
+      sprecip(:,:) = sf(jp_snow)%fnow(:,:,1)
+      tprecip(:,:) = sf(jp_snow)%fnow(:,:,1)+sf(jp_rain)%fnow(:,:,1)
+! May be better to do this conversion somewhere else
+      qla_ice(:,:,1) = -Lsub*sf(jp_sblm)%fnow(:,:,1)
+      topmelt(:,:,1) = sf(jp_top1)%fnow(:,:,1)
+      topmelt(:,:,2) = sf(jp_top2)%fnow(:,:,1)
+      topmelt(:,:,3) = sf(jp_top3)%fnow(:,:,1)
+      topmelt(:,:,4) = sf(jp_top4)%fnow(:,:,1)
+      topmelt(:,:,5) = sf(jp_top5)%fnow(:,:,1)
+      botmelt(:,:,1) = sf(jp_bot1)%fnow(:,:,1)
+      botmelt(:,:,2) = sf(jp_bot2)%fnow(:,:,1)
+      botmelt(:,:,3) = sf(jp_bot3)%fnow(:,:,1)
+      botmelt(:,:,4) = sf(jp_bot4)%fnow(:,:,1)
+      botmelt(:,:,5) = sf(jp_bot5)%fnow(:,:,1)
+
+      ! control print (if less than 100 time-step asked)
+      IF( nitend-nit000 <= 100 .AND. lwp ) THEN
+         WRITE(numout,*) 
+         WRITE(numout,*) '        read forcing fluxes for CICE OK'
+         CALL FLUSH(numout)
+      ENDIF
+
+   END SUBROUTINE cice_sbc_force
+
+   SUBROUTINE nemo2cice( pn, pc, cd_type, psgn)
+      !!---------------------------------------------------------------------
+      !!                    ***  ROUTINE nemo2cice  ***
+      !! ** Purpose :   Transfer field in NEMO array to field in CICE array.  
+#if defined key_nemocice_decomp
+      !!             
+      !!                NEMO and CICE PE sub domains are identical, hence
+      !!                there is no need to gather or scatter data from 
+      !!                one PE configuration to another.
+#else
+      !!                Automatically gather/scatter between 
+      !!                different processors and blocks
+      !! ** Method :    A. Ensure all haloes are filled in NEMO field (pn)
+      !!                B. Gather pn into global array (png)
+      !!                C. Map png into CICE global array (pcg)
+      !!                D. Scatter pcg to CICE blocks (pc) + update haloes  
+#endif
+      !!---------------------------------------------------------------------
+      CHARACTER(len=1), INTENT( in ) ::   &
+          cd_type       ! nature of pn grid-point
+          !             !   = T or F gridpoints
+      REAL(wp), INTENT( in ) ::   &
+          psgn          ! control of the sign change
+          !             !   =-1 , the sign is modified following the type of b.c. used
+          !             !   = 1 , no sign change
+      REAL(wp), DIMENSION(jpi,jpj) :: pn
+#if !defined key_nemocice_decomp
+      REAL(wp), DIMENSION(jpiglo,jpjglo) :: png2
+      REAL (kind=dbl_kind), dimension(nx_global,ny_global) :: pcg
+#endif
+      REAL (kind=dbl_kind), dimension(nx_block,ny_block,max_blocks) :: pc
+      INTEGER (int_kind) :: &
+         field_type,        &! id for type of field (scalar, vector, angle)
+         grid_loc            ! id for location on horizontal grid
+                            !  (center, NEcorner, Nface, Eface)
+
+      INTEGER  ::   ji, jj, jn                      ! dummy loop indices
+      !!---------------------------------------------------------------------
+
+!     A. Ensure all haloes are filled in NEMO field (pn)
+
+      CALL lbc_lnk( pn , cd_type, psgn )
+
+#if defined key_nemocice_decomp
+
+      ! Copy local domain data from NEMO to CICE field
+      pc(:,:,1)=0.0
+      DO jj=2,ny_block-1
+         DO ji=2,nx_block-1
+            pc(ji,jj,1)=pn(ji-1+ji_off,jj-1+jj_off)
+         ENDDO
+      ENDDO
+
+#else
+
+!     B. Gather pn into global array (png)
+
+      IF ( jpnij > 1) THEN
+         CALL mppsync
+         CALL mppgather (pn,0,png) 
+         CALL mppsync
+      ELSE
+         png(:,:,1)=pn(:,:)
+      ENDIF
+
+!     C. Map png into CICE global array (pcg)
+
+! Need to make sure this is robust to changes in NEMO halo rows....
+! (may be OK but not 100% sure)
+
+      IF (nproc==0) THEN     
+!        pcg(:,:)=0.0
+         DO jn=1,jpnij
+            DO jj=nldjt(jn),nlejt(jn)
+               DO ji=nldit(jn),nleit(jn)
+                  png2(ji+nimppt(jn)-1,jj+njmppt(jn)-1)=png(ji,jj,jn)
+               ENDDO
+            ENDDO
+         ENDDO
+         DO jj=1,ny_global
+            DO ji=1,nx_global
+               pcg(ji,jj)=png2(ji+ji_off,jj+jj_off)
+            ENDDO
+         ENDDO
+      ENDIF
+
+#endif
+
+      SELECT CASE ( cd_type )
+         CASE ( 'T' )
+            grid_loc=field_loc_center
+         CASE ( 'F' )                              
+            grid_loc=field_loc_NEcorner
+      END SELECT
+
+      SELECT CASE ( NINT(psgn) )
+         CASE ( -1 )
+            field_type=field_type_vector
+         CASE ( 1 )                              
+            field_type=field_type_scalar
+      END SELECT
+
+#if defined key_nemocice_decomp
+      ! Ensure CICE halos are up to date
+      CALL ice_HaloUpdate (pc, halo_info, grid_loc, field_type)
+#else
+!     D. Scatter pcg to CICE blocks (pc) + update halos
+      CALL scatter_global(pc, pcg, 0, distrb_info, grid_loc, field_type)
+#endif
+
+   END SUBROUTINE nemo2cice
+
+   SUBROUTINE cice2nemo ( pc, pn, cd_type, psgn )
+      !!---------------------------------------------------------------------
+      !!                    ***  ROUTINE cice2nemo  ***
+      !! ** Purpose :   Transfer field in CICE array to field in NEMO array.
+#if defined key_nemocice_decomp
+      !!             
+      !!                NEMO and CICE PE sub domains are identical, hence
+      !!                there is no need to gather or scatter data from 
+      !!                one PE configuration to another.
+#else 
+      !!                Automatically deal with scatter/gather between
+      !!                different processors and blocks
+      !! ** Method :    A. Gather CICE blocks (pc) into global array (pcg)
+      !!                B. Map pcg into NEMO global array (png)
+      !!                C. Scatter png into NEMO field (pn) for each processor
+      !!                D. Ensure all haloes are filled in pn 
+#endif
+      !!---------------------------------------------------------------------
+
+      CHARACTER(len=1), INTENT( in ) ::   &
+          cd_type       ! nature of pn grid-point
+          !             !   = T or F gridpoints
+      REAL(wp), INTENT( in ) ::   &
+          psgn          ! control of the sign change
+          !             !   =-1 , the sign is modified following the type of b.c. used
+          !             !   = 1 , no sign change
+      REAL(wp), DIMENSION(jpi,jpj) :: pn
+
+#if defined key_nemocice_decomp
+      INTEGER (int_kind) :: &
+         field_type,        & ! id for type of field (scalar, vector, angle)
+         grid_loc             ! id for location on horizontal grid
+                              ! (center, NEcorner, Nface, Eface)
+#else
+      REAL (kind=dbl_kind), dimension(nx_global,ny_global) :: pcg
+#endif
+
+      REAL (kind=dbl_kind), dimension(nx_block,ny_block,max_blocks) :: pc
+
+      INTEGER  ::   ji, jj, jn                      ! dummy loop indices
+
+
+#if defined key_nemocice_decomp
+
+      SELECT CASE ( cd_type )
+         CASE ( 'T' )
+            grid_loc=field_loc_center
+         CASE ( 'F' )                              
+            grid_loc=field_loc_NEcorner
+      END SELECT
+
+      SELECT CASE ( NINT(psgn) )
+         CASE ( -1 )
+            field_type=field_type_vector
+         CASE ( 1 )                              
+            field_type=field_type_scalar
+      END SELECT
+
+      CALL ice_HaloUpdate (pc, halo_info, grid_loc, field_type)
+
+
+      pn(:,:)=0.0
+      DO jj=1,jpjm1
+         DO ji=1,jpim1
+            pn(ji,jj)=pc(ji+1-ji_off,jj+1-jj_off,1)
+         ENDDO
+      ENDDO
+
+#else
+
+!      A. Gather CICE blocks (pc) into global array (pcg) 
+
+      CALL gather_global(pcg, pc, 0, distrb_info)
+
+!     B. Map pcg into NEMO global array (png)
+
+! Need to make sure this is robust to changes in NEMO halo rows....
+! (may be OK but not spent much time thinking about it)
+! Note that non-existent pcg elements may be used below, but
+! the lbclnk call on pn will replace these with sensible values
+
+      IF (nproc==0) THEN
+         png(:,:,:)=0.0
+         DO jn=1,jpnij
+            DO jj=nldjt(jn),nlejt(jn)
+               DO ji=nldit(jn),nleit(jn)
+                  png(ji,jj,jn)=pcg(ji+nimppt(jn)-1-ji_off,jj+njmppt(jn)-1-jj_off)
+               ENDDO
+            ENDDO
+         ENDDO
+      ENDIF
+
+!     C. Scatter png into NEMO field (pn) for each processor
+
+      IF ( jpnij > 1) THEN
+         CALL mppsync
+         CALL mppscatter (png,0,pn) 
+         CALL mppsync
+      ELSE
+         pn(:,:)=png(:,:,1)
+      ENDIF
+
+#endif
+
+!     D. Ensure all haloes are filled in pn
+
+      CALL lbc_lnk( pn , cd_type, psgn )
+
+   END SUBROUTINE cice2nemo
+
+#else
+   !!----------------------------------------------------------------------
+   !!   Default option           Dummy module         NO CICE sea-ice model
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE sbc_ice_cice ( kt, ksbc )     ! Dummy routine
+      WRITE(*,*) 'sbc_ice_cice: You should not have seen this print! error?', kt
+   END SUBROUTINE sbc_ice_cice
+
+   SUBROUTINE cice_sbc_init (ksbc)    ! Dummy routine
+      WRITE(*,*) 'cice_sbc_init: You should not have seen this print! error?'
+   END SUBROUTINE cice_sbc_init
+
+   SUBROUTINE cice_sbc_final     ! Dummy routine
+      WRITE(*,*) 'cice_sbc_final: You should not have seen this print! error?'
+   END SUBROUTINE cice_sbc_final
+
+#endif
+
+   !!======================================================================
+END MODULE sbcice_cice
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/SBC/sbcice_if.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/SBC/sbcice_if.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/SBC/sbcice_if.F90	(revision 9570)
@@ -0,0 +1,149 @@
+MODULE sbcice_if
+   !!======================================================================
+   !!                       ***  MODULE  sbcice  ***
+   !! Surface module :  update surface ocean boundary condition over ice
+   !!                   covered area using ice-if model
+   !!======================================================================
+   !! History :  3.0  !  2006-06  (G. Madec)  Original code
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   sbc_ice_if    : update sbc in ice-covered area
+   !!----------------------------------------------------------------------
+   USE oce            ! ocean dynamics and tracers
+   USE dom_oce        ! ocean space and time domain
+   USE phycst         ! physical constants
+   USE eosbn2         ! equation of state
+   USE sbc_oce        ! surface boundary condition: ocean fields
+#if defined key_si3
+   USE ice            , ONLY :   a_i
+#else
+   USE sbc_ice        , ONLY :   a_i 
+#endif
+   !
+   USE in_out_manager ! I/O manager
+   USE iom            ! I/O manager library
+   USE fldread        ! read input field
+   USE lib_mpp        ! MPP library
+   USE lib_fortran    ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined)  
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   sbc_ice_if      ! routine called in sbcmod
+
+   TYPE(FLD), ALLOCATABLE, DIMENSION(:) ::   sf_ice   ! structure of input ice-cover (file informations, fields read)
+   
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO Consortium (2010)
+   !! $Id$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE sbc_ice_if( kt )
+      !!---------------------------------------------------------------------
+      !!                     ***  ROUTINE sbc_ice_if  ***
+      !!
+      !! ** Purpose :   handle surface boundary condition over ice cover area
+      !!      when sea-ice model are not used
+      !!
+      !! ** Method  : - read sea-ice cover climatology
+      !!              - blah blah blah, ...
+      !!
+      !! ** Action  :   utau, vtau : remain unchanged
+      !!                taum, wndm : remain unchanged
+      !!                qns, qsr   : update heat flux below sea-ice
+      !!                emp, sfx   : update freshwater flux below sea-ice
+      !!                fr_i       : update the ice fraction
+      !!---------------------------------------------------------------------
+      INTEGER, INTENT(in) ::   kt   ! ocean time step
+      !
+      INTEGER  ::   ji, jj     ! dummy loop indices
+      INTEGER  ::   ierror     ! return error code
+      INTEGER  ::   ios        ! Local integer output status for namelist read
+      REAL(wp) ::   ztrp, zsice, zt_fzp, zfr_obs
+      REAL(wp) ::   zqri, zqrj, zqrp, zqi
+      !!
+      CHARACTER(len=100) ::   cn_dir              ! Root directory for location of ice-if files
+      TYPE(FLD_N)        ::   sn_ice              ! informations about the fields to be read
+      NAMELIST/namsbc_iif/ cn_dir, sn_ice
+      !!---------------------------------------------------------------------
+      !                                         ! ====================== !
+      IF( kt == nit000 ) THEN                   !  First call kt=nit000  !
+         !                                      ! ====================== !
+         ! set file information
+         REWIND( numnam_ref )              ! Namelist namsbc_iif in reference namelist : Ice if file
+         READ  ( numnam_ref, namsbc_iif, IOSTAT = ios, ERR = 901)
+901      IF( ios /= 0 )   CALL ctl_nam ( ios , 'namsbc_iif in reference namelist', lwp )
+
+         REWIND( numnam_cfg )              ! Namelist Namelist namsbc_iif in configuration namelist : Ice if file
+         READ  ( numnam_cfg, namsbc_iif, IOSTAT = ios, ERR = 902 )
+902      IF( ios >  0 )   CALL ctl_nam ( ios , 'namsbc_iif in configuration namelist', lwp )
+         IF(lwm) WRITE ( numond, namsbc_iif )
+
+         ALLOCATE( sf_ice(1), STAT=ierror )
+         IF( ierror > 0 )   CALL ctl_stop( 'STOP', 'sbc_ice_if: unable to allocate sf_ice structure' )
+         ALLOCATE( sf_ice(1)%fnow(jpi,jpj,1) )
+         IF( sn_ice%ln_tint )   ALLOCATE( sf_ice(1)%fdta(jpi,jpj,1,2) )
+
+         ! fill sf_ice with sn_ice and control print
+         CALL fld_fill( sf_ice, (/ sn_ice /), cn_dir, 'sbc_ice_if', 'ice-if sea-ice model', 'namsbc_iif' )
+         !
+      ENDIF
+
+      CALL fld_read( kt, nn_fsbc, sf_ice )           ! Read input fields and provides the
+      !                                              ! input fields at the current time-step
+      
+      IF( MOD( kt-1, nn_fsbc) == 0 ) THEN
+         !
+         ztrp = -40.             ! restoring terme for temperature (w/m2/k)
+         zsice = - 0.04 / 0.8    ! ratio of isohaline compressibility over isotherme compressibility
+                                 ! ( d rho / dt ) / ( d rho / ds )      ( s = 34, t = -1.8 )
+         
+         CALL eos_fzp( sss_m(:,:), fr_i(:,:) )       ! sea surface freezing temperature [Celsius]
+         fr_i(:,:) = fr_i(:,:) * tmask(:,:,1)
+
+         IF( ln_cpl )   a_i(:,:,1) = fr_i(:,:)         
+
+         ! Flux and ice fraction computation
+         DO jj = 1, jpj
+            DO ji = 1, jpi
+               !
+               zt_fzp  = fr_i(ji,jj)                        ! freezing point temperature
+               zfr_obs = sf_ice(1)%fnow(ji,jj,1)            ! observed ice cover
+               !                                            ! ocean ice fraction (0/1) from the freezing point temperature
+               IF( sst_m(ji,jj) <= zt_fzp ) THEN   ;   fr_i(ji,jj) = 1.e0
+               ELSE                                ;   fr_i(ji,jj) = 0.e0
+               ENDIF
+
+               tsn(ji,jj,1,jp_tem) = MAX( tsn(ji,jj,1,jp_tem), zt_fzp )     ! avoid over-freezing point temperature
+
+               qsr(ji,jj) = ( 1. - zfr_obs ) * qsr(ji,jj)   ! solar heat flux : zero below observed ice cover
+
+               !                                            ! non solar heat flux : add a damping term 
+               !      # ztrp*(t-(tgel-1.))  if observed ice and no opa ice   (zfr_obs=1 fr_i=0)
+               !      # ztrp*min(0,t-tgel)  if observed ice and opa ice      (zfr_obs=1 fr_i=1)
+               zqri = ztrp * ( tsb(ji,jj,1,jp_tem) - ( zt_fzp - 1.) )
+               zqrj = ztrp * MIN( 0., tsb(ji,jj,1,jp_tem) - zt_fzp )
+               zqrp = ( zfr_obs * ( (1. - fr_i(ji,jj) ) * zqri    &
+                 &                 +      fr_i(ji,jj)   * zqrj ) ) * tmask(ji,jj,1)
+
+               !                                            ! non-solar heat flux 
+               !      # qns unchanged              if no climatological ice              (zfr_obs=0)
+               !      # qns = zqrp                 if climatological ice and no opa ice  (zfr_obs=1, fr_i=0)
+               !      # qns = zqrp -2(-4) watt/m2  if climatological ice and opa ice     (zfr_obs=1, fr_i=1)
+               !                                   (-2=arctic, -4=antarctic)   
+               zqi = -3. + SIGN( 1._wp, ff_f(ji,jj) )
+               qns(ji,jj) = ( ( 1.- zfr_obs ) * qns(ji,jj)                             &
+                  &          +      zfr_obs   * fr_i(ji,jj) * zqi ) * tmask(ji,jj,1)   &
+                  &       + zqrp
+            END DO
+         END DO
+         !
+      ENDIF
+      !
+   END SUBROUTINE sbc_ice_if
+
+   !!======================================================================
+END MODULE sbcice_if
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/SBC/sbcisf.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/SBC/sbcisf.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/SBC/sbcisf.F90	(revision 9570)
@@ -0,0 +1,897 @@
+MODULE sbcisf
+   !!======================================================================
+   !!                       ***  MODULE  sbcisf  ***
+   !! Surface module :  update surface ocean boundary condition under ice
+   !!                   shelf
+   !!======================================================================
+   !! History :  3.2  !  2011-02  (C.Harris  ) Original code isf cav
+   !!            X.X  !  2006-02  (C. Wang   ) Original code bg03
+   !!            3.4  !  2013-03  (P. Mathiot) Merging + parametrization
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   sbc_isf       : update sbc under ice shelf
+   !!----------------------------------------------------------------------
+   USE oce            ! ocean dynamics and tracers
+   USE dom_oce        ! ocean space and time domain
+   USE phycst         ! physical constants
+   USE eosbn2         ! equation of state
+   USE sbc_oce        ! surface boundary condition: ocean fields
+   USE zdfdrg         ! vertical physics: top/bottom drag coef.
+   !
+   USE in_out_manager ! I/O manager
+   USE iom            ! I/O library
+   USE fldread        ! read input field at current time step
+   USE lbclnk         !
+   USE lib_fortran    ! glob_sum
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   sbc_isf, sbc_isf_init, sbc_isf_div, sbc_isf_alloc  ! routine called in sbcmod and divhor
+
+   ! public in order to be able to output then 
+
+   REAL(wp), PUBLIC ::   rn_hisf_tbl                 !: thickness of top boundary layer [m]
+   INTEGER , PUBLIC ::   nn_isf                      !: flag to choose between explicit/param/specified  
+   INTEGER , PUBLIC ::   nn_isfblk                   !: flag to choose the bulk formulation to compute the ice shelf melting
+   INTEGER , PUBLIC ::   nn_gammablk                 !: flag to choose how the exchange coefficient is computed
+   REAL(wp), PUBLIC ::   rn_gammat0                  !: temperature exchange coeficient []
+   REAL(wp), PUBLIC ::   rn_gammas0                  !: salinity    exchange coeficient []
+
+   INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   misfkt   , misfkb        !: Level of ice shelf base
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   rzisf_tbl                !: depth of calving front (shallowest point) nn_isf ==2/3
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   rhisf_tbl, rhisf_tbl_0   !: thickness of tbl  [m]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   r1_hisf_tbl              !: 1/thickness of tbl
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   ralpha                   !: proportion of bottom cell influenced by tbl 
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   risfLeff                 !: effective length (Leff) BG03 nn_isf==2
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   ttbl, stbl, utbl, vtbl   !: top boundary layer variable at T point
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   qisf                     !: net heat flux from ice shelf      [W/m2]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   risf_tsc_b, risf_tsc     !: before and now T & S isf contents [K.m/s & PSU.m/s]  
+
+   LOGICAL, PUBLIC ::   l_isfcpl = .false.       !: isf recieved from oasis
+
+   REAL(wp), PUBLIC, SAVE ::   rcpi     = 2000.0_wp     !: specific heat of ice shelf             [J/kg/K]
+   REAL(wp), PUBLIC, SAVE ::   rkappa   = 1.54e-6_wp    !: heat diffusivity through the ice-shelf [m2/s]
+   REAL(wp), PUBLIC, SAVE ::   rhoisf   = 920.0_wp      !: volumic mass of ice shelf              [kg/m3]
+   REAL(wp), PUBLIC, SAVE ::   tsurf    = -20.0_wp      !: air temperature on top of ice shelf    [C]
+   REAL(wp), PUBLIC, SAVE ::   rlfusisf = 0.334e6_wp    !: latent heat of fusion of ice shelf     [J/kg]
+
+!: Variable used in fldread to read the forcing file (nn_isf == 4 .OR. nn_isf == 3)
+   CHARACTER(len=100), PUBLIC           :: cn_dirisf  = './' !: Root directory for location of ssr files
+   TYPE(FLD_N)       , PUBLIC           :: sn_fwfisf         !: information about the isf melting file to be read
+   TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_fwfisf
+   TYPE(FLD_N)       , PUBLIC           :: sn_rnfisf         !: information about the isf melting param.   file to be read
+   TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_rnfisf           
+   TYPE(FLD_N)       , PUBLIC           :: sn_depmax_isf     !: information about the grounding line depth file to be read
+   TYPE(FLD_N)       , PUBLIC           :: sn_depmin_isf     !: information about the calving   line depth file to be read
+   TYPE(FLD_N)       , PUBLIC           :: sn_Leff_isf       !: information about the effective length     file to be read
+   
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 4.0 , LOCEAN-IPSL (2017)
+   !! $Id$
+   !! Software governed by the CeCILL licence (modipsl/doc/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+ 
+  SUBROUTINE sbc_isf( kt )
+      !!---------------------------------------------------------------------
+      !!                  ***  ROUTINE sbc_isf  ***
+      !!
+      !! ** Purpose : Compute Salt and Heat fluxes related to ice_shelf 
+      !!              melting and freezing 
+      !!
+      !! ** Method  :  4 parameterizations are available according to nn_isf 
+      !!               nn_isf = 1 : Realistic ice_shelf formulation
+      !!                        2 : Beckmann & Goose parameterization
+      !!                        3 : Specified runoff in deptht (Mathiot & al. )
+      !!                        4 : specified fwf and heat flux forcing beneath the ice shelf
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT(in) ::   kt   ! ocean time step
+      !
+      INTEGER ::   ji, jj, jk   ! loop index
+      INTEGER ::   ikt, ikb     ! local integers
+      REAL(wp), DIMENSION(jpi,jpj) ::   zt_frz, zdep   ! freezing temperature (zt_frz) at depth (zdep) 
+      REAL(wp), DIMENSION(:,:)  , ALLOCATABLE ::   zqhcisf2d
+      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::   zfwfisf3d, zqhcisf3d, zqlatisf3d
+      !!---------------------------------------------------------------------
+      !
+      IF( MOD( kt-1, nn_fsbc) == 0 ) THEN    ! compute salt and heat flux
+         !
+         SELECT CASE ( nn_isf )
+         CASE ( 1 )    ! realistic ice shelf formulation
+            ! compute T/S/U/V for the top boundary layer
+            CALL sbc_isf_tbl(tsn(:,:,:,jp_tem),ttbl(:,:),'T')
+            CALL sbc_isf_tbl(tsn(:,:,:,jp_sal),stbl(:,:),'T')
+            CALL sbc_isf_tbl(un(:,:,:)        ,utbl(:,:),'U')
+            CALL sbc_isf_tbl(vn(:,:,:)        ,vtbl(:,:),'V')
+            ! iom print
+            CALL iom_put('ttbl',ttbl(:,:))
+            CALL iom_put('stbl',stbl(:,:))
+            CALL iom_put('utbl',utbl(:,:) * (1._wp - tmask(:,:,1)) * ssmask(:,:))
+            CALL iom_put('vtbl',vtbl(:,:) * (1._wp - tmask(:,:,1)) * ssmask(:,:))
+            ! compute fwf and heat flux
+            ! compute fwf and heat flux
+            IF( .NOT.l_isfcpl ) THEN    ;   CALL sbc_isf_cav (kt)
+            ELSE                        ;   qisf(:,:)  = fwfisf(:,:) * rlfusisf  ! heat        flux
+            ENDIF
+            !
+         CASE ( 2 )    ! Beckmann and Goosse parametrisation 
+            stbl(:,:)   = soce
+            CALL sbc_isf_bg03(kt)
+            !
+         CASE ( 3 )    ! specified runoff in depth (Mathiot et al., XXXX in preparation)
+            ! specified runoff in depth (Mathiot et al., XXXX in preparation)
+            IF( .NOT.l_isfcpl ) THEN
+               CALL fld_read ( kt, nn_fsbc, sf_rnfisf   )
+               fwfisf(:,:) = - sf_rnfisf(1)%fnow(:,:,1)         ! fresh water flux from the isf (fwfisf <0 mean melting) 
+            ENDIF
+            qisf(:,:)   = fwfisf(:,:) * rlfusisf             ! heat flux
+            stbl(:,:)   = soce
+            !
+         CASE ( 4 )    ! specified fwf and heat flux forcing beneath the ice shelf
+            !          ! specified fwf and heat flux forcing beneath the ice shelf
+            IF( .NOT.l_isfcpl ) THEN
+               CALL fld_read ( kt, nn_fsbc, sf_fwfisf   )
+               !CALL fld_read ( kt, nn_fsbc, sf_qisf   )
+               fwfisf(:,:) = -sf_fwfisf(1)%fnow(:,:,1)            ! fwf
+            ENDIF
+            qisf(:,:)   = fwfisf(:,:) * rlfusisf               ! heat flux
+            stbl(:,:)   = soce
+            !
+         END SELECT
+
+         ! compute tsc due to isf
+         ! isf melting implemented as a volume flux and we assume that melt water is at 0 PSU.
+         ! WARNING water add at temp = 0C, need to add a correction term (fwfisf * tfreez / rau0).
+         ! compute freezing point beneath ice shelf (or top cell if nn_isf = 3)
+         DO jj = 1,jpj
+            DO ji = 1,jpi
+               zdep(ji,jj)=gdepw_n(ji,jj,misfkt(ji,jj))
+            END DO
+         END DO
+         CALL eos_fzp( stbl(:,:), zt_frz(:,:), zdep(:,:) )
+         
+         risf_tsc(:,:,jp_tem) = qisf(:,:) * r1_rau0_rcp - fwfisf(:,:) * zt_frz(:,:) * r1_rau0 !
+         risf_tsc(:,:,jp_sal) = 0.0_wp
+
+         ! lbclnk
+         CALL lbc_lnk_multi( risf_tsc(:,:,jp_tem), 'T', 1., risf_tsc(:,:,jp_sal), 'T', 1., fwfisf,'T', 1., qisf, 'T', 1.)
+         ! output
+         IF( iom_use('iceshelf_cea') )   CALL iom_put( 'iceshelf_cea', -fwfisf(:,:)                      )   ! isf mass flux
+         IF( iom_use('hflx_isf_cea') )   CALL iom_put( 'hflx_isf_cea', risf_tsc(:,:,jp_tem) * rau0 * rcp )   ! isf sensible+latent heat (W/m2)
+         IF( iom_use('qlatisf' ) )       CALL iom_put( 'qlatisf'     , qisf(:,:)                         )   ! isf latent heat
+         IF( iom_use('fwfisf'  ) )       CALL iom_put( 'fwfisf'      , fwfisf(:,:)                       )   ! isf mass flux (opposite sign)
+
+         ! Diagnostics
+         IF( iom_use('fwfisf3d') .OR. iom_use('qlatisf3d') .OR. iom_use('qhcisf3d') .OR. iom_use('qhcisf')) THEN
+            ALLOCATE( zfwfisf3d(jpi,jpj,jpk) , zqhcisf3d(jpi,jpj,jpk) , zqlatisf3d(jpi,jpj,jpk) )
+            ALLOCATE( zqhcisf2d(jpi,jpj) )
+            !
+            zfwfisf3d (:,:,:) = 0._wp                         ! 3d ice shelf melting (kg/m2/s)
+            zqhcisf3d (:,:,:) = 0._wp                         ! 3d heat content flux (W/m2)
+            zqlatisf3d(:,:,:) = 0._wp                         ! 3d ice shelf melting latent heat flux (W/m2)
+            zqhcisf2d (:,:)   = fwfisf(:,:) * zt_frz * rcp    ! 2d heat content flux (W/m2)
+            !
+            DO jj = 1,jpj
+               DO ji = 1,jpi
+                  ikt = misfkt(ji,jj)
+                  ikb = misfkb(ji,jj)
+                  DO jk = ikt, ikb - 1
+                     zfwfisf3d (ji,jj,jk) = zfwfisf3d (ji,jj,jk) + fwfisf   (ji,jj) * r1_hisf_tbl(ji,jj) * e3t_n(ji,jj,jk)
+                     zqhcisf3d (ji,jj,jk) = zqhcisf3d (ji,jj,jk) + zqhcisf2d(ji,jj) * r1_hisf_tbl(ji,jj) * e3t_n(ji,jj,jk)
+                     zqlatisf3d(ji,jj,jk) = zqlatisf3d(ji,jj,jk) + qisf     (ji,jj) * r1_hisf_tbl(ji,jj) * e3t_n(ji,jj,jk)
+                  END DO
+                  zfwfisf3d (ji,jj,jk) = zfwfisf3d (ji,jj,jk) + fwfisf   (ji,jj) * r1_hisf_tbl(ji,jj)   & 
+                     &                                                                   * ralpha(ji,jj) * e3t_n(ji,jj,jk)
+                  zqhcisf3d (ji,jj,jk) = zqhcisf3d (ji,jj,jk) + zqhcisf2d(ji,jj) * r1_hisf_tbl(ji,jj)   & 
+                     &                                                                   * ralpha(ji,jj) * e3t_n(ji,jj,jk)
+                  zqlatisf3d(ji,jj,jk) = zqlatisf3d(ji,jj,jk) + qisf     (ji,jj) * r1_hisf_tbl(ji,jj)   &  
+                     &                                                                   * ralpha(ji,jj) * e3t_n(ji,jj,jk)
+               END DO
+            END DO
+            !
+            CALL iom_put('fwfisf3d' , zfwfisf3d (:,:,:))
+            CALL iom_put('qlatisf3d', zqlatisf3d(:,:,:))
+            CALL iom_put('qhcisf3d' , zqhcisf3d (:,:,:))
+            CALL iom_put('qhcisf'   , zqhcisf2d (:,:  ))
+            !
+            DEALLOCATE( zfwfisf3d, zqhcisf3d, zqlatisf3d )
+            DEALLOCATE( zqhcisf2d )
+         ENDIF
+         !
+      ENDIF
+
+      IF( kt == nit000 ) THEN                         !   set the forcing field at nit000 - 1    !
+         IF( ln_rstart .AND.    &                     ! Restart: read in restart file
+            &   iom_varid( numror, 'fwf_isf_b', ldstop = .FALSE. ) > 0 ) THEN
+            IF(lwp) WRITE(numout,*) '          nit000-1 isf tracer content forcing fields read in the restart file'
+            CALL iom_get( numror, jpdom_autoglo, 'fwf_isf_b', fwfisf_b(:,:)         , ldxios = lrxios )   ! before salt content isf_tsc trend
+            CALL iom_get( numror, jpdom_autoglo, 'isf_sc_b' , risf_tsc_b(:,:,jp_sal), ldxios = lrxios )   ! before salt content isf_tsc trend
+            CALL iom_get( numror, jpdom_autoglo, 'isf_hc_b' , risf_tsc_b(:,:,jp_tem), ldxios = lrxios )   ! before salt content isf_tsc trend
+         ELSE
+            fwfisf_b(:,:)    = fwfisf(:,:)
+            risf_tsc_b(:,:,:)= risf_tsc(:,:,:)
+         ENDIF
+      ENDIF
+      ! 
+      IF( lrst_oce ) THEN
+         IF(lwp) WRITE(numout,*)
+         IF(lwp) WRITE(numout,*) 'sbc : isf surface tracer content forcing fields written in ocean restart file ',   &
+            &                    'at it= ', kt,' date= ', ndastp
+         IF(lwp) WRITE(numout,*) '~~~~'
+         IF( lwxios ) CALL iom_swap(      cwxios_context          )
+         CALL iom_rstput( kt, nitrst, numrow, 'fwf_isf_b', fwfisf(:,:)         , ldxios = lwxios )
+         CALL iom_rstput( kt, nitrst, numrow, 'isf_hc_b' , risf_tsc(:,:,jp_tem), ldxios = lwxios )
+         CALL iom_rstput( kt, nitrst, numrow, 'isf_sc_b' , risf_tsc(:,:,jp_sal), ldxios = lwxios )
+         IF( lwxios ) CALL iom_swap(      cxios_context          )
+      ENDIF
+      !
+   END SUBROUTINE sbc_isf
+
+
+   INTEGER FUNCTION sbc_isf_alloc()
+      !!----------------------------------------------------------------------
+      !!               ***  FUNCTION sbc_isf_rnf_alloc  ***
+      !!----------------------------------------------------------------------
+      sbc_isf_alloc = 0       ! set to zero if no array to be allocated
+      IF( .NOT. ALLOCATED( qisf ) ) THEN
+         ALLOCATE(  risf_tsc(jpi,jpj,jpts), risf_tsc_b(jpi,jpj,jpts), qisf(jpi,jpj)   , &
+               &    rhisf_tbl(jpi,jpj)    , r1_hisf_tbl(jpi,jpj), rzisf_tbl(jpi,jpj)  , &
+               &    ttbl(jpi,jpj)         , stbl(jpi,jpj)       , utbl(jpi,jpj)       , &
+               &    vtbl(jpi, jpj)        , risfLeff(jpi,jpj)   , rhisf_tbl_0(jpi,jpj), &
+               &    ralpha(jpi,jpj)       , misfkt(jpi,jpj)     , misfkb(jpi,jpj)     , &
+               &    STAT= sbc_isf_alloc )
+         !
+         IF( lk_mpp             )   CALL mpp_sum ( sbc_isf_alloc )
+         IF( sbc_isf_alloc /= 0 )   CALL ctl_warn('sbc_isf_alloc: failed to allocate arrays.')
+         !
+      ENDIF
+   END FUNCTION
+
+
+  SUBROUTINE sbc_isf_init
+      !!---------------------------------------------------------------------
+      !!                  ***  ROUTINE sbc_isf_init  ***
+      !!
+      !! ** Purpose : Initialisation of variables for iceshelf fluxes formulation
+      !!
+      !! ** Method  :  4 parameterizations are available according to nn_isf 
+      !!               nn_isf = 1 : Realistic ice_shelf formulation
+      !!                        2 : Beckmann & Goose parameterization
+      !!                        3 : Specified runoff in deptht (Mathiot & al. )
+      !!                        4 : specified fwf and heat flux forcing beneath the ice shelf
+      !!----------------------------------------------------------------------
+      INTEGER               :: ji, jj, jk           ! loop index
+      INTEGER               :: ik                   ! current level index
+      INTEGER               :: ikt, ikb             ! top and bottom level of the isf boundary layer
+      INTEGER               :: inum, ierror
+      INTEGER               :: ios                  ! Local integer output status for namelist read
+      REAL(wp)              :: zhk
+      CHARACTER(len=256)    :: cvarzisf, cvarhisf   ! name for isf file
+      CHARACTER(LEN=32 )    :: cvarLeff             ! variable name for efficient Length scale
+      !!----------------------------------------------------------------------
+      NAMELIST/namsbc_isf/ nn_isfblk, rn_hisf_tbl, rn_gammat0, rn_gammas0, nn_gammablk, nn_isf, &
+                         & sn_fwfisf, sn_rnfisf, sn_depmax_isf, sn_depmin_isf, sn_Leff_isf
+      !!----------------------------------------------------------------------
+
+      REWIND( numnam_ref )              ! Namelist namsbc_rnf in reference namelist : Runoffs 
+      READ  ( numnam_ref, namsbc_isf, IOSTAT = ios, ERR = 901)
+901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namsbc_isf in reference namelist', lwp )
+
+      REWIND( numnam_cfg )              ! Namelist namsbc_rnf in configuration namelist : Runoffs
+      READ  ( numnam_cfg, namsbc_isf, IOSTAT = ios, ERR = 902 )
+902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namsbc_isf in configuration namelist', lwp )
+      IF(lwm) WRITE ( numond, namsbc_isf )
+
+      IF(lwp) WRITE(numout,*)
+      IF(lwp) WRITE(numout,*) 'sbc_isf_init : heat flux of the ice shelf'
+      IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~'
+      IF(lwp) WRITE(numout,*) '   Namelist namsbc_isf :'
+      IF(lwp) WRITE(numout,*) '      type ice shelf melting/freezing         nn_isf      = ', nn_isf
+      IF(lwp) WRITE(numout,*) '      bulk formulation (nn_isf=1 only)        nn_isfblk   = ', nn_isfblk
+      IF(lwp) WRITE(numout,*) '      thickness of the top boundary layer     rn_hisf_tbl = ', rn_hisf_tbl
+      IF(lwp) WRITE(numout,*) '      gamma formulation                       nn_gammablk = ', nn_gammablk 
+      IF(lwp) WRITE(numout,*) '      gammat coefficient                      rn_gammat0  = ', rn_gammat0  
+      IF(lwp) WRITE(numout,*) '      gammas coefficient                      rn_gammas0  = ', rn_gammas0  
+      IF(lwp) WRITE(numout,*) '      top drag coef. used (from namdrg_top)   rn_Cd0      = ', r_Cdmin_top 
+
+
+                           !  1 = presence of ISF    2 = bg03 parametrisation 
+                           !  3 = rnf file for isf   4 = ISF fwf specified
+                           !  option 1 and 4 need ln_isfcav = .true. (domzgr)
+      !
+      ! Allocate public variable
+      IF ( sbc_isf_alloc()  /= 0 )         CALL ctl_stop( 'STOP', 'sbc_isf : unable to allocate arrays' )
+      !
+      ! initialisation
+      qisf    (:,:)    = 0._wp   ;   fwfisf  (:,:) = 0._wp
+      risf_tsc(:,:,:)  = 0._wp   ;   fwfisf_b(:,:) = 0._wp
+      !
+      ! define isf tbl tickness, top and bottom indice
+      SELECT CASE ( nn_isf )
+      CASE ( 1 ) 
+         IF(lwp) WRITE(numout,*)
+         IF(lwp) WRITE(numout,*) '      ==>>>   presence of under iceshelf seas (nn_isf = 1)'
+         rhisf_tbl(:,:) = rn_hisf_tbl
+         misfkt   (:,:) = mikt(:,:)         ! same indice for bg03 et cav => used in isfdiv
+         !
+      CASE ( 2 , 3 )
+         IF( .NOT.l_isfcpl ) THEN
+             ALLOCATE( sf_rnfisf(1), STAT=ierror )
+             ALLOCATE( sf_rnfisf(1)%fnow(jpi,jpj,1), sf_rnfisf(1)%fdta(jpi,jpj,1,2) )
+             CALL fld_fill( sf_rnfisf, (/ sn_rnfisf /), cn_dirisf, 'sbc_isf_init', 'read fresh water flux isf data', 'namsbc_isf' )
+          ENDIF
+          !  read effective lenght (BG03)
+          IF( nn_isf == 2 ) THEN
+            IF(lwp) WRITE(numout,*)
+            IF(lwp) WRITE(numout,*) '      ==>>>   bg03 parametrisation (nn_isf = 2)'
+            CALL iom_open( sn_Leff_isf%clname, inum )
+            cvarLeff = TRIM(sn_Leff_isf%clvar)
+            CALL iom_get( inum, jpdom_data, cvarLeff, risfLeff , 1)
+            CALL iom_close(inum)
+            !
+            risfLeff = risfLeff*1000.0_wp           !: convertion in m
+         ELSE
+            IF(lwp) WRITE(numout,*)
+            IF(lwp) WRITE(numout,*) '      ==>>>   rnf file for isf (nn_isf = 3)'
+         ENDIF
+         ! read depth of the top and bottom of the isf top boundary layer (in this case, isf front depth and grounding line depth)
+         CALL iom_open( sn_depmax_isf%clname, inum )
+         cvarhisf = TRIM(sn_depmax_isf%clvar)
+         CALL iom_get( inum, jpdom_data, cvarhisf, rhisf_tbl, 1) !: depth of deepest point of the ice shelf base
+         CALL iom_close(inum)
+         !
+         CALL iom_open( sn_depmin_isf%clname, inum )
+         cvarzisf = TRIM(sn_depmin_isf%clvar)
+         CALL iom_get( inum, jpdom_data, cvarzisf, rzisf_tbl, 1) !: depth of shallowest point of the ice shelves base
+         CALL iom_close(inum)
+         !
+         rhisf_tbl(:,:) = rhisf_tbl(:,:) - rzisf_tbl(:,:)        !: tickness isf boundary layer
+
+         !! compute first level of the top boundary layer
+         DO ji = 1, jpi
+            DO jj = 1, jpj
+                ik = 2
+!!gm potential bug: use gdepw_0 not _n
+                DO WHILE ( ik <= mbkt(ji,jj) .AND. gdepw_n(ji,jj,ik) < rzisf_tbl(ji,jj) ) ;  ik = ik + 1 ;  END DO
+                misfkt(ji,jj) = ik-1
+            END DO
+         END DO
+         !
+      CASE ( 4 ) 
+         IF(lwp) WRITE(numout,*)
+         IF(lwp) WRITE(numout,*) '      ==>>>   specified fresh water flux in ISF (nn_isf = 4)'
+         ! as in nn_isf == 1
+         rhisf_tbl(:,:) = rn_hisf_tbl
+         misfkt   (:,:) = mikt(:,:)         ! same indice for bg03 et cav => used in isfdiv
+         !
+         ! load variable used in fldread (use for temporal interpolation of isf fwf forcing)
+         IF( .NOT.l_isfcpl ) THEN
+           ALLOCATE( sf_fwfisf(1), STAT=ierror )
+           ALLOCATE( sf_fwfisf(1)%fnow(jpi,jpj,1), sf_fwfisf(1)%fdta(jpi,jpj,1,2) )
+           CALL fld_fill( sf_fwfisf, (/ sn_fwfisf /), cn_dirisf, 'sbc_isf_init', 'read fresh water flux isf data', 'namsbc_isf' )
+         ENDIF
+         !
+      CASE DEFAULT
+         CALL ctl_stop( 'sbc_isf_init: wrong value of nn_isf' )
+      END SELECT
+         
+      rhisf_tbl_0(:,:) = rhisf_tbl(:,:)
+
+      ! compute bottom level of isf tbl and thickness of tbl below the ice shelf
+      DO jj = 1,jpj
+         DO ji = 1,jpi
+            ikt = misfkt(ji,jj)
+            ikb = misfkt(ji,jj)
+            ! thickness of boundary layer at least the top level thickness
+            rhisf_tbl(ji,jj) = MAX(rhisf_tbl_0(ji,jj), e3t_n(ji,jj,ikt))
+
+            ! determine the deepest level influenced by the boundary layer
+            DO jk = ikt+1, mbkt(ji,jj)
+               IF( (SUM(e3t_n(ji,jj,ikt:jk-1)) < rhisf_tbl(ji,jj)) .AND. (tmask(ji,jj,jk) == 1) )   ikb = jk
+            END DO
+            rhisf_tbl(ji,jj) = MIN(rhisf_tbl(ji,jj), SUM(e3t_n(ji,jj,ikt:ikb))) ! limit the tbl to water thickness.
+            misfkb(ji,jj) = ikb                                                   ! last wet level of the tbl
+            r1_hisf_tbl(ji,jj) = 1._wp / rhisf_tbl(ji,jj)
+
+            zhk           = SUM( e3t_n(ji, jj, ikt:ikb - 1)) * r1_hisf_tbl(ji,jj) ! proportion of tbl cover by cell from ikt to ikb - 1
+            ralpha(ji,jj) = rhisf_tbl(ji,jj) * (1._wp - zhk ) / e3t_n(ji,jj,ikb)  ! proportion of bottom cell influenced by boundary layer
+         END DO
+      END DO
+
+      IF( lwxios ) THEN
+          CALL iom_set_rstw_var_active('fwf_isf_b')
+          CALL iom_set_rstw_var_active('isf_hc_b')
+          CALL iom_set_rstw_var_active('isf_sc_b')
+      ENDIF
+
+
+  END SUBROUTINE sbc_isf_init
+
+
+  SUBROUTINE sbc_isf_bg03(kt)
+      !!---------------------------------------------------------------------
+      !!                  ***  ROUTINE sbc_isf_bg03  ***
+      !!
+      !! ** Purpose : add net heat and fresh water flux from ice shelf melting
+      !!          into the adjacent ocean
+      !!
+      !! ** Method  :   See reference
+      !!
+      !! ** Reference : Beckmann and Goosse (2003), "A parameterization of ice shelf-ocean
+      !!         interaction for climate models", Ocean Modelling 5(2003) 157-170.
+      !!         (hereafter BG)
+      !! History :  06-02  (C. Wang) Original code
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT ( in ) :: kt
+      !
+      INTEGER  :: ji, jj, jk ! dummy loop index
+      INTEGER  :: ik         ! current level
+      REAL(wp) :: zt_sum     ! sum of the temperature between 200m and 600m
+      REAL(wp) :: zt_ave     ! averaged temperature between 200m and 600m
+      REAL(wp) :: zt_frz     ! freezing point temperature at depth z
+      REAL(wp) :: zpress     ! pressure to compute the freezing point in depth
+      !!----------------------------------------------------------------------
+      !
+      DO ji = 1, jpi
+         DO jj = 1, jpj
+            ik = misfkt(ji,jj)
+            !! Initialize arrays to 0 (each step)
+            zt_sum = 0.e0_wp
+            IF ( ik > 1 ) THEN
+               ! 1. -----------the average temperature between 200m and 600m ---------------------
+               DO jk = misfkt(ji,jj),misfkb(ji,jj)
+                  ! freezing point temperature  at ice shelf base BG eq. 2 (JMM sign pb ??? +7.64e-4 !!!)
+                  ! after verif with UNESCO, wrong sign in BG eq. 2
+                  ! Calculate freezing temperature
+                  CALL eos_fzp(stbl(ji,jj), zt_frz, zpress) 
+                  zt_sum = zt_sum + (tsn(ji,jj,jk,jp_tem)-zt_frz) * e3t_n(ji,jj,jk) * tmask(ji,jj,jk)  ! sum temp
+               END DO
+               zt_ave = zt_sum/rhisf_tbl(ji,jj) ! calcul mean value
+               ! 2. ------------Net heat flux and fresh water flux due to the ice shelf
+               ! For those corresponding to zonal boundary    
+               qisf(ji,jj) = - rau0 * rcp * rn_gammat0 * risfLeff(ji,jj) * e1t(ji,jj) * zt_ave  &
+                           & * r1_e1e2t(ji,jj) * tmask(ji,jj,jk)
+             
+               fwfisf(ji,jj) = qisf(ji,jj) / rlfusisf          !fresh water flux kg/(m2s)                  
+               fwfisf(ji,jj) = fwfisf(ji,jj) * ( soce / stbl(ji,jj) )
+               !add to salinity trend
+            ELSE
+               qisf(ji,jj) = 0._wp   ;   fwfisf(ji,jj) = 0._wp
+            END IF
+         END DO
+      END DO
+      !
+  END SUBROUTINE sbc_isf_bg03
+
+
+  SUBROUTINE sbc_isf_cav( kt )
+      !!---------------------------------------------------------------------
+      !!                     ***  ROUTINE sbc_isf_cav  ***
+      !!
+      !! ** Purpose :   handle surface boundary condition under ice shelf
+      !!
+      !! ** Method  : -
+      !!
+      !! ** Action  :   utau, vtau : remain unchanged
+      !!                taum, wndm : remain unchanged
+      !!                qns        : update heat flux below ice shelf
+      !!                emp, emps  : update freshwater flux below ice shelf
+      !!---------------------------------------------------------------------
+      INTEGER, INTENT(in) ::   kt   ! ocean time step
+      !
+      INTEGER  ::   ji, jj     ! dummy loop indices
+      INTEGER  ::   nit
+      LOGICAL  ::   lit
+      REAL(wp) ::   zlamb1, zlamb2, zlamb3
+      REAL(wp) ::   zeps1,zeps2,zeps3,zeps4,zeps6,zeps7
+      REAL(wp) ::   zaqe,zbqe,zcqe,zaqer,zdis,zsfrz,zcfac
+      REAL(wp) ::   zeps = 1.e-20_wp        
+      REAL(wp) ::   zerr
+      REAL(wp), DIMENSION(jpi,jpj) ::   zfrz
+      REAL(wp), DIMENSION(jpi,jpj) ::   zgammat, zgammas 
+      REAL(wp), DIMENSION(jpi,jpj) ::   zfwflx, zhtflx, zhtflx_b
+      !!---------------------------------------------------------------------
+      !
+      ! coeficient for linearisation of potential tfreez
+      ! Crude approximation for pressure (but commonly used)
+      zlamb1 =-0.0573_wp
+      zlamb2 = 0.0832_wp
+      zlamb3 =-7.53e-08_wp * grav * rau0
+      !
+      ! initialisation
+      zgammat(:,:) = rn_gammat0 ; zgammas (:,:) = rn_gammas0
+      zhtflx (:,:) = 0.0_wp     ; zhtflx_b(:,:) = 0.0_wp    
+      zfwflx (:,:) = 0.0_wp
+
+      ! compute ice shelf melting
+      nit = 1 ; lit = .TRUE.
+      DO WHILE ( lit )    ! maybe just a constant number of iteration as in blk_core is fine
+         SELECT CASE ( nn_isfblk )
+         CASE ( 1 )   !  ISOMIP formulation (2 equations) for volume flux (Hunter et al., 2006)
+            ! Calculate freezing temperature
+            CALL eos_fzp( stbl(:,:), zfrz(:,:), risfdep(:,:) )
+
+            ! compute gammat every where (2d)
+            CALL sbc_isf_gammats(zgammat, zgammas, zhtflx, zfwflx)
+            
+            ! compute upward heat flux zhtflx and upward water flux zwflx
+            DO jj = 1, jpj
+               DO ji = 1, jpi
+                  zhtflx(ji,jj) =   zgammat(ji,jj)*rcp*rau0*(ttbl(ji,jj)-zfrz(ji,jj))
+                  zfwflx(ji,jj) = - zhtflx(ji,jj)/rlfusisf
+               END DO
+            END DO
+
+            ! Compute heat flux and upward fresh water flux
+            qisf  (:,:) = - zhtflx(:,:) * (1._wp - tmask(:,:,1)) * ssmask(:,:)
+            fwfisf(:,:) =   zfwflx(:,:) * (1._wp - tmask(:,:,1)) * ssmask(:,:)
+
+         CASE ( 2 )  ! ISOMIP+ formulation (3 equations) for volume flux (Asay-Davis et al., 2015)
+            ! compute gammat every where (2d)
+            CALL sbc_isf_gammats(zgammat, zgammas, zhtflx, zfwflx)
+
+            ! compute upward heat flux zhtflx and upward water flux zwflx
+            ! Resolution of a 2d equation from equation 21, 22 and 23 to find Sb (Asay-Davis et al., 2015)
+            DO jj = 1, jpj
+               DO ji = 1, jpi
+                  ! compute coeficient to solve the 2nd order equation
+                  zeps1 = rcp*rau0*zgammat(ji,jj)
+                  zeps2 = rlfusisf*rau0*zgammas(ji,jj)
+                  zeps3 = rhoisf*rcpi*rkappa/MAX(risfdep(ji,jj),zeps)
+                  zeps4 = zlamb2+zlamb3*risfdep(ji,jj)
+                  zeps6 = zeps4-ttbl(ji,jj)
+                  zeps7 = zeps4-tsurf
+                  zaqe  = zlamb1 * (zeps1 + zeps3)
+                  zaqer = 0.5_wp/MIN(zaqe,-zeps)
+                  zbqe  = zeps1*zeps6+zeps3*zeps7-zeps2
+                  zcqe  = zeps2*stbl(ji,jj)
+                  zdis  = zbqe*zbqe-4.0_wp*zaqe*zcqe               
+
+                  ! Presumably zdis can never be negative because gammas is very small compared to gammat
+                  ! compute s freeze
+                  zsfrz=(-zbqe-SQRT(zdis))*zaqer
+                  IF ( zsfrz < 0.0_wp ) zsfrz=(-zbqe+SQRT(zdis))*zaqer
+
+                  ! compute t freeze (eq. 22)
+                  zfrz(ji,jj)=zeps4+zlamb1*zsfrz
+  
+                  ! zfwflx is upward water flux
+                  ! zhtflx is upward heat flux (out of ocean)
+                  ! compute the upward water and heat flux (eq. 28 and eq. 29)
+                  zfwflx(ji,jj) = rau0 * zgammas(ji,jj) * (zsfrz-stbl(ji,jj)) / MAX(zsfrz,zeps)
+                  zhtflx(ji,jj) = zgammat(ji,jj) * rau0 * rcp * (ttbl(ji,jj) - zfrz(ji,jj) ) 
+               END DO
+            END DO
+
+            ! compute heat and water flux
+            qisf  (:,:) = - zhtflx(:,:) * (1._wp - tmask(:,:,1)) * ssmask(:,:)
+            fwfisf(:,:) =   zfwflx(:,:) * (1._wp - tmask(:,:,1)) * ssmask(:,:)
+
+         END SELECT
+
+         ! define if we need to iterate (nn_gammablk 0/1 do not need iteration)
+         IF ( nn_gammablk <  2 ) THEN ; lit = .FALSE.
+         ELSE                           
+            ! check total number of iteration
+            IF (nit >= 100) THEN ; CALL ctl_stop( 'STOP', 'sbc_isf_hol99 : too many iteration ...' )
+            ELSE                 ; nit = nit + 1
+            END IF
+
+            ! compute error between 2 iterations
+            ! if needed save gammat and compute zhtflx_b for next iteration
+            zerr = MAXVAL(ABS(zhtflx-zhtflx_b))
+            IF ( zerr <= 0.01_wp ) THEN ; lit = .FALSE.
+            ELSE                        ; zhtflx_b(:,:) = zhtflx(:,:)
+            END IF
+         END IF
+      END DO
+      !
+      CALL iom_put('isfgammat', zgammat)
+      CALL iom_put('isfgammas', zgammas)
+      ! 
+   END SUBROUTINE sbc_isf_cav
+
+
+   SUBROUTINE sbc_isf_gammats(pgt, pgs, pqhisf, pqwisf )
+      !!----------------------------------------------------------------------
+      !! ** Purpose    : compute the coefficient echange for heat flux
+      !!
+      !! ** Method     : gamma assume constant or depends of u* and stability
+      !!
+      !! ** References : Holland and Jenkins, 1999, JPO, p1787-1800, eq 14
+      !!                Jenkins et al., 2010, JPO, p2298-2312
+      !!---------------------------------------------------------------------
+      REAL(wp), DIMENSION(:,:), INTENT(  out) ::   pgt   , pgs      ! 
+      REAL(wp), DIMENSION(:,:), INTENT(in   ) ::   pqhisf, pqwisf   ! 
+      !
+      INTEGER  :: ji, jj                     ! loop index
+      INTEGER  :: ikt                        ! local integer
+      REAL(wp) :: zdku, zdkv                 ! U, V shear 
+      REAL(wp) :: zPr, zSc, zRc              ! Prandtl, Scmidth and Richardson number 
+      REAL(wp) :: zmob, zmols                ! Monin Obukov length, coriolis factor at T point
+      REAL(wp) :: zbuofdep, zhnu             ! Bouyancy length scale, sublayer tickness
+      REAL(wp) :: zhmax                      ! limitation of mol
+      REAL(wp) :: zetastar                   ! stability parameter
+      REAL(wp) :: zgmolet, zgmoles, zgturb   ! contribution of modelecular sublayer and turbulence 
+      REAL(wp) :: zcoef                      ! temporary coef
+      REAL(wp) :: zdep
+      REAL(wp) :: zeps = 1.0e-20_wp    
+      REAL(wp), PARAMETER :: zxsiN = 0.052_wp   ! dimensionless constant
+      REAL(wp), PARAMETER :: znu   = 1.95e-6_wp ! kinamatic viscosity of sea water (m2.s-1)
+      REAL(wp), DIMENSION(2) :: zts, zab
+      REAL(wp), DIMENSION(jpi,jpj) :: zustar   ! U, V at T point and friction velocity
+      !!---------------------------------------------------------------------
+      !
+      SELECT CASE ( nn_gammablk )
+      CASE ( 0 ) ! gamma is constant (specified in namelist)
+         !! ISOMIP formulation (Hunter et al, 2006)
+         pgt(:,:) = rn_gammat0
+         pgs(:,:) = rn_gammas0
+
+      CASE ( 1 ) ! gamma is assume to be proportional to u*
+         !! Jenkins et al., 2010, JPO, p2298-2312
+         !! Adopted by Asay-Davis et al. (2015)
+         !! compute ustar (eq. 24)
+!!gm  NB  use pCdU here so that it will incorporate local boost of Cd0 and log layer case :
+!!         zustar(:,:) = SQRT( rCdU_top(:,:) * SQRT(utbl(:,:) * utbl(:,:) + vtbl(:,:) * vtbl(:,:) + r_ke0_top) )
+!! or better :  compute ustar in zdfdrg  and use it here as well as in TKE, GLS and Co
+!!
+!!     ===>>>>    GM  to be done this chrismas
+!!         
+!!gm end
+         zustar(:,:) = SQRT( r_Cdmin_top * (utbl(:,:) * utbl(:,:) + vtbl(:,:) * vtbl(:,:) + r_ke0_top) )
+
+         !! Compute gammats
+         pgt(:,:) = zustar(:,:) * rn_gammat0
+         pgs(:,:) = zustar(:,:) * rn_gammas0
+      
+      CASE ( 2 ) ! gamma depends of stability of boundary layer
+         !! Holland and Jenkins, 1999, JPO, p1787-1800, eq 14
+         !! as MOL depends of flux and flux depends of MOL, best will be iteration (TO DO)
+         !! compute ustar
+         zustar(:,:) = SQRT( r_Cdmin_top * (utbl(:,:) * utbl(:,:) + vtbl(:,:) * vtbl(:,:) + r_ke0_top) )
+
+         !! compute Pr and Sc number (can be improved)
+         zPr =   13.8_wp
+         zSc = 2432.0_wp
+
+         !! compute gamma mole
+         zgmolet = 12.5_wp * zPr ** (2.0/3.0) - 6.0_wp
+         zgmoles = 12.5_wp * zSc ** (2.0/3.0) - 6.0_wp
+
+         !! compute gamma
+         DO ji = 2, jpi
+            DO jj = 2, jpj
+               ikt = mikt(ji,jj)
+
+               IF( zustar(ji,jj) == 0._wp ) THEN           ! only for kt = 1 I think
+                  pgt = rn_gammat0
+                  pgs = rn_gammas0
+               ELSE
+                  !! compute Rc number (as done in zdfric.F90)
+!!gm better to do it like in the new zdfric.F90   i.e. avm weighted Ri computation
+!!gm moreover, use Max(rn2,0) to take care of static instabilities....
+                  zcoef = 0.5_wp / e3w_n(ji,jj,ikt)
+                  !                                            ! shear of horizontal velocity
+                  zdku = zcoef * (  un(ji-1,jj  ,ikt  ) + un(ji,jj,ikt  )  &
+                     &             -un(ji-1,jj  ,ikt+1) - un(ji,jj,ikt+1)  )
+                  zdkv = zcoef * (  vn(ji  ,jj-1,ikt  ) + vn(ji,jj,ikt  )  &
+                     &             -vn(ji  ,jj-1,ikt+1) - vn(ji,jj,ikt+1)  )
+                  !                                            ! richardson number (minimum value set to zero)
+                  zRc = rn2(ji,jj,ikt+1) / MAX( zdku*zdku + zdkv*zdkv, zeps )
+
+                  !! compute bouyancy 
+                  zts(jp_tem) = ttbl(ji,jj)
+                  zts(jp_sal) = stbl(ji,jj)
+                  zdep        = gdepw_n(ji,jj,ikt)
+                  !
+                  CALL eos_rab( zts, zdep, zab )
+                  !
+                  !! compute length scale 
+                  zbuofdep = grav * ( zab(jp_tem) * pqhisf(ji,jj) - zab(jp_sal) * pqwisf(ji,jj) )  !!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+                  !! compute Monin Obukov Length
+                  ! Maximum boundary layer depth
+                  zhmax = gdept_n(ji,jj,mbkt(ji,jj)) - gdepw_n(ji,jj,mikt(ji,jj)) -0.001_wp
+                  ! Compute Monin obukhov length scale at the surface and Ekman depth:
+                  zmob   = zustar(ji,jj) ** 3 / (vkarmn * (zbuofdep + zeps))
+                  zmols  = SIGN(1._wp, zmob) * MIN(ABS(zmob), zhmax) * tmask(ji,jj,ikt)
+
+                  !! compute eta* (stability parameter)
+                  zetastar = 1._wp / ( SQRT(1._wp + MAX(zxsiN * zustar(ji,jj) / ( ABS(ff_f(ji,jj)) * zmols * zRc ), 0._wp)))
+
+                  !! compute the sublayer thickness
+                  zhnu = 5 * znu / zustar(ji,jj)
+
+                  !! compute gamma turb
+                  zgturb = 1._wp / vkarmn * LOG(zustar(ji,jj) * zxsiN * zetastar * zetastar / ( ABS(ff_f(ji,jj)) * zhnu )) &
+                  &      + 1._wp / ( 2 * zxsiN * zetastar ) - 1._wp / vkarmn
+
+                  !! compute gammats
+                  pgt(ji,jj) = zustar(ji,jj) / (zgturb + zgmolet)
+                  pgs(ji,jj) = zustar(ji,jj) / (zgturb + zgmoles)
+               END IF
+            END DO
+         END DO
+         CALL lbc_lnk_multi( pgt, 'T', 1., pgs, 'T', 1.)
+      END SELECT
+      !
+   END SUBROUTINE sbc_isf_gammats
+
+
+   SUBROUTINE sbc_isf_tbl( pvarin, pvarout, cd_ptin )
+      !!----------------------------------------------------------------------
+      !!                  ***  SUBROUTINE sbc_isf_tbl  ***
+      !!
+      !! ** Purpose : compute mean T/S/U/V in the boundary layer at T- point
+      !!
+      !!----------------------------------------------------------------------
+      REAL(wp), DIMENSION(:,:,:), INTENT(in   ) :: pvarin
+      REAL(wp), DIMENSION(:,:)  , INTENT(  out) :: pvarout
+      CHARACTER(len=1),           INTENT(in   ) :: cd_ptin ! point of variable in/out
+      !
+      INTEGER ::   ji, jj, jk                ! loop index
+      INTEGER ::   ikt, ikb                    ! top and bottom index of the tbl
+      REAL(wp) ::   ze3, zhk
+      REAL(wp), DIMENSION(jpi,jpj) :: zhisf_tbl ! thickness of the tbl
+      !!----------------------------------------------------------------------
+      
+      ! initialisation
+      pvarout(:,:)=0._wp
+   
+      SELECT CASE ( cd_ptin )
+      CASE ( 'U' ) ! compute U in the top boundary layer at T- point 
+         DO jj = 1,jpj
+            DO ji = 1,jpi
+               ikt = miku(ji,jj) ; ikb = miku(ji,jj)
+               ! thickness of boundary layer at least the top level thickness
+               zhisf_tbl(ji,jj) = MAX( rhisf_tbl_0(ji,jj) , e3u_n(ji,jj,ikt) )
+
+               ! determine the deepest level influenced by the boundary layer
+               DO jk = ikt+1, mbku(ji,jj)
+                  IF ( (SUM(e3u_n(ji,jj,ikt:jk-1)) < zhisf_tbl(ji,jj)) .AND. (umask(ji,jj,jk) == 1) ) ikb = jk
+               END DO
+               zhisf_tbl(ji,jj) = MIN(zhisf_tbl(ji,jj), SUM(e3u_n(ji,jj,ikt:ikb)))  ! limit the tbl to water thickness.
+
+               ! level fully include in the ice shelf boundary layer
+               DO jk = ikt, ikb - 1
+                  ze3 = e3u_n(ji,jj,jk)
+                  pvarout(ji,jj) = pvarout(ji,jj) + pvarin(ji,jj,jk) / zhisf_tbl(ji,jj) * ze3
+               END DO
+
+               ! level partially include in ice shelf boundary layer 
+               zhk = SUM( e3u_n(ji, jj, ikt:ikb - 1)) / zhisf_tbl(ji,jj)
+               pvarout(ji,jj) = pvarout(ji,jj) + pvarin(ji,jj,ikb) * (1._wp - zhk)
+            END DO
+         END DO
+         DO jj = 2, jpj
+            DO ji = 2, jpi
+!!gm a wet-point only average should be used here !!!
+               pvarout(ji,jj) = 0.5_wp * (pvarout(ji,jj) + pvarout(ji-1,jj))
+            END DO
+         END DO
+         CALL lbc_lnk(pvarout,'T',-1.)
+      
+      CASE ( 'V' ) ! compute V in the top boundary layer at T- point 
+         DO jj = 1,jpj
+            DO ji = 1,jpi
+               ikt = mikv(ji,jj) ; ikb = mikv(ji,jj)
+               ! thickness of boundary layer at least the top level thickness
+               zhisf_tbl(ji,jj) = MAX(rhisf_tbl_0(ji,jj), e3v_n(ji,jj,ikt))
+
+               ! determine the deepest level influenced by the boundary layer
+               DO jk = ikt+1, mbkv(ji,jj)
+                  IF ( (SUM(e3v_n(ji,jj,ikt:jk-1)) < zhisf_tbl(ji,jj)) .AND. (vmask(ji,jj,jk) == 1) ) ikb = jk
+               END DO
+               zhisf_tbl(ji,jj) = MIN(zhisf_tbl(ji,jj), SUM(e3v_n(ji,jj,ikt:ikb)))  ! limit the tbl to water thickness.
+
+               ! level fully include in the ice shelf boundary layer
+               DO jk = ikt, ikb - 1
+                  ze3 = e3v_n(ji,jj,jk)
+                  pvarout(ji,jj) = pvarout(ji,jj) + pvarin(ji,jj,jk) / zhisf_tbl(ji,jj) * ze3
+               END DO
+
+               ! level partially include in ice shelf boundary layer 
+               zhk = SUM( e3v_n(ji, jj, ikt:ikb - 1)) / zhisf_tbl(ji,jj)
+               pvarout(ji,jj) = pvarout(ji,jj) + pvarin(ji,jj,ikb) * (1._wp - zhk)
+            END DO
+         END DO
+         DO jj = 2, jpj
+            DO ji = 2, jpi
+!!gm a wet-point only average should be used here !!!
+               pvarout(ji,jj) = 0.5_wp * (pvarout(ji,jj) + pvarout(ji,jj-1))
+            END DO
+         END DO
+         CALL lbc_lnk(pvarout,'T',-1.)
+
+      CASE ( 'T' ) ! compute T in the top boundary layer at T- point 
+         DO jj = 1,jpj
+            DO ji = 1,jpi
+               ikt = misfkt(ji,jj)
+               ikb = misfkb(ji,jj)
+
+               ! level fully include in the ice shelf boundary layer
+               DO jk = ikt, ikb - 1
+                  ze3 = e3t_n(ji,jj,jk)
+                  pvarout(ji,jj) = pvarout(ji,jj) + pvarin(ji,jj,jk) * r1_hisf_tbl(ji,jj) * ze3
+               END DO
+
+               ! level partially include in ice shelf boundary layer 
+               zhk = SUM( e3t_n(ji, jj, ikt:ikb - 1)) * r1_hisf_tbl(ji,jj)
+               pvarout(ji,jj) = pvarout(ji,jj) + pvarin(ji,jj,ikb) * (1._wp - zhk)
+            END DO
+         END DO
+      END SELECT
+      !
+      ! mask mean tbl value
+      pvarout(:,:) = pvarout(:,:) * ssmask(:,:)
+      !
+   END SUBROUTINE sbc_isf_tbl
+      
+
+   SUBROUTINE sbc_isf_div( phdivn )
+      !!----------------------------------------------------------------------
+      !!                  ***  SUBROUTINE sbc_isf_div  ***
+      !!       
+      !! ** Purpose :   update the horizontal divergence with the runoff inflow
+      !!
+      !! ** Method  :   
+      !!                CAUTION : risf_tsc(:,:,jp_sal) is negative (outflow) increase the 
+      !!                          divergence and expressed in m/s
+      !!
+      !! ** Action  :   phdivn   decreased by the runoff inflow
+      !!----------------------------------------------------------------------
+      REAL(wp), DIMENSION(:,:,:), INTENT( inout ) ::   phdivn   ! horizontal divergence
+      ! 
+      INTEGER  ::   ji, jj, jk   ! dummy loop indices
+      INTEGER  ::   ikt, ikb 
+      REAL(wp) ::   zhk
+      REAL(wp) ::   zfact     ! local scalar
+      !!----------------------------------------------------------------------
+      !
+      zfact   = 0.5_wp
+      !
+      IF(.NOT.ln_linssh ) THEN     ! need to re compute level distribution of isf fresh water
+         DO jj = 1,jpj
+            DO ji = 1,jpi
+               ikt = misfkt(ji,jj)
+               ikb = misfkt(ji,jj)
+               ! thickness of boundary layer at least the top level thickness
+               rhisf_tbl(ji,jj) = MAX(rhisf_tbl_0(ji,jj), e3t_n(ji,jj,ikt))
+
+               ! determine the deepest level influenced by the boundary layer
+               DO jk = ikt, mbkt(ji,jj)
+                  IF ( (SUM(e3t_n(ji,jj,ikt:jk-1)) .LT. rhisf_tbl(ji,jj)) .AND. (tmask(ji,jj,jk) == 1) ) ikb = jk
+               END DO
+               rhisf_tbl(ji,jj) = MIN(rhisf_tbl(ji,jj), SUM(e3t_n(ji,jj,ikt:ikb)))  ! limit the tbl to water thickness.
+               misfkb(ji,jj) = ikb                                                  ! last wet level of the tbl
+               r1_hisf_tbl(ji,jj) = 1._wp / rhisf_tbl(ji,jj)
+
+               zhk           = SUM( e3t_n(ji, jj, ikt:ikb - 1)) * r1_hisf_tbl(ji,jj)  ! proportion of tbl cover by cell from ikt to ikb - 1
+               ralpha(ji,jj) = rhisf_tbl(ji,jj) * (1._wp - zhk ) / e3t_n(ji,jj,ikb)  ! proportion of bottom cell influenced by boundary layer
+            END DO
+         END DO
+      END IF 
+      !
+      !==   ice shelf melting distributed over several levels   ==!
+      DO jj = 1,jpj
+         DO ji = 1,jpi
+               ikt = misfkt(ji,jj)
+               ikb = misfkb(ji,jj)
+               ! level fully include in the ice shelf boundary layer
+               DO jk = ikt, ikb - 1
+                  phdivn(ji,jj,jk) = phdivn(ji,jj,jk) + ( fwfisf(ji,jj) + fwfisf_b(ji,jj) ) &
+                    &              * r1_hisf_tbl(ji,jj) * r1_rau0 * zfact
+               END DO
+               ! level partially include in ice shelf boundary layer 
+               phdivn(ji,jj,ikb) = phdivn(ji,jj,ikb) + ( fwfisf(ji,jj) &
+                    &            + fwfisf_b(ji,jj) ) * r1_hisf_tbl(ji,jj) * r1_rau0 * zfact * ralpha(ji,jj) 
+         END DO
+      END DO
+      !
+   END SUBROUTINE sbc_isf_div
+
+   !!======================================================================
+END MODULE sbcisf
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/SBC/sbcmod.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/SBC/sbcmod.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/SBC/sbcmod.F90	(revision 9570)
@@ -0,0 +1,546 @@
+MODULE sbcmod
+   !!======================================================================
+   !!                       ***  MODULE  sbcmod  ***
+   !! Surface module :  provide to the ocean its surface boundary condition
+   !!======================================================================
+   !! History :  3.0  ! 2006-07  (G. Madec)  Original code
+   !!            3.1  ! 2008-08  (S. Masson, A. Caubel, E. Maisonnave, G. Madec) coupled interface
+   !!            3.3  ! 2010-04  (M. Leclair, G. Madec)  Forcing averaged over 2 time steps
+   !!            3.3  ! 2010-10  (S. Masson)  add diurnal cycle
+   !!            3.3  ! 2010-09  (D. Storkey) add ice boundary conditions (BDY)
+   !!             -   ! 2010-11  (G. Madec) ice-ocean stress always computed at each ocean time-step
+   !!             -   ! 2010-10  (J. Chanut, C. Bricaud, G. Madec)  add the surface pressure forcing
+   !!            3.4  ! 2011-11  (C. Harris) CICE added as an option
+   !!            3.5  ! 2012-11  (A. Coward, G. Madec) Rethink of heat, mass and salt surface fluxes
+   !!            3.6  ! 2014-11  (P. Mathiot, C. Harris) add ice shelves melting
+   !!            4.0  ! 2016-06  (L. Brodeau) new general bulk formulation
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   sbc_init      : read namsbc namelist
+   !!   sbc           : surface ocean momentum, heat and freshwater boundary conditions
+   !!   sbc_final     : Finalize CICE ice model (if used)
+   !!----------------------------------------------------------------------
+   USE oce            ! ocean dynamics and tracers
+   USE dom_oce        ! ocean space and time domain
+   USE phycst         ! physical constants
+   USE sbc_oce        ! Surface boundary condition: ocean fields
+   USE trc_oce        ! shared ocean-passive tracers variables
+   USE sbc_ice        ! Surface boundary condition: ice fields
+   USE sbcdcy         ! surface boundary condition: diurnal cycle
+   USE sbcssm         ! surface boundary condition: sea-surface mean variables
+   USE sbcflx         ! surface boundary condition: flux formulation
+   USE sbcblk         ! surface boundary condition: bulk formulation
+   USE sbcice_if      ! surface boundary condition: ice-if sea-ice model
+#if defined key_si3
+   USE icestp         ! surface boundary condition: LIM 3.0 sea-ice model
+#endif
+   USE sbcice_cice    ! surface boundary condition: CICE    sea-ice model
+   USE sbcisf         ! surface boundary condition: ice-shelf
+   USE sbccpl         ! surface boundary condition: coupled formulation
+   USE cpl_oasis3     ! OASIS routines for coupling
+   USE sbcssr         ! surface boundary condition: sea surface restoring
+   USE sbcrnf         ! surface boundary condition: runoffs
+   USE sbcapr         ! surface boundary condition: atmo pressure 
+   USE sbcisf         ! surface boundary condition: ice shelf
+   USE sbcfwb         ! surface boundary condition: freshwater budget
+   USE icbstp         ! Icebergs
+   USE traqsr         ! active tracers: light penetration
+   USE sbcwave        ! Wave module
+   USE bdy_oce   , ONLY: ln_bdy
+   USE usrdef_sbc     ! user defined: surface boundary condition
+   USE closea         ! closed sea
+   !
+   USE prtctl         ! Print control                    (prt_ctl routine)
+   USE iom            ! IOM library
+   USE in_out_manager ! I/O manager
+   USE lib_mpp        ! MPP library
+   USE timing         ! Timing
+   USE diurnal_bulk, ONLY:   ln_diurnal_only   ! diurnal SST diagnostic
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   sbc        ! routine called by step.F90
+   PUBLIC   sbc_init   ! routine called by opa.F90
+
+   INTEGER ::   nsbc   ! type of surface boundary condition (deduced from namsbc informations)
+
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 4.0 , NEMO-consortium (2016) 
+   !! $Id$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE sbc_init
+      !!---------------------------------------------------------------------
+      !!                    ***  ROUTINE sbc_init ***
+      !!
+      !! ** Purpose :   Initialisation of the ocean surface boundary computation
+      !!
+      !! ** Method  :   Read the namsbc namelist and set derived parameters
+      !!                Call init routines for all other SBC modules that have one
+      !!
+      !! ** Action  : - read namsbc parameters
+      !!              - nsbc: type of sbc
+      !!----------------------------------------------------------------------
+      INTEGER ::   ios, icpt                         ! local integer
+      LOGICAL ::   ll_purecpl, ll_opa, ll_not_nemo   ! local logical
+      !!
+      NAMELIST/namsbc/ nn_fsbc  ,                                                    &
+         &             ln_usr   , ln_flx   , ln_blk       ,                          &
+         &             ln_cpl   , ln_mixcpl, nn_components,                          &
+         &             nn_ice   , ln_ice_embd,                                       &
+         &             ln_traqsr, ln_dm2dc ,                                         &
+         &             ln_rnf   , nn_fwb   , ln_ssr   , ln_isf    , ln_apr_dyn ,     &
+         &             ln_wave  , ln_cdgw  , ln_sdw   , ln_tauwoc  , ln_stcor   ,     &
+         &             ln_tauw  , nn_lsm, nn_sdrift
+      !!----------------------------------------------------------------------
+      !
+      IF(lwp) THEN
+         WRITE(numout,*)
+         WRITE(numout,*) 'sbc_init : surface boundary condition setting'
+         WRITE(numout,*) '~~~~~~~~ '
+      ENDIF
+      !
+      !                       !**  read Surface Module namelist
+      REWIND( numnam_ref )          !* Namelist namsbc in reference namelist : Surface boundary
+      READ  ( numnam_ref, namsbc, IOSTAT = ios, ERR = 901)
+901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namsbc in reference namelist', lwp )
+      REWIND( numnam_cfg )          !* Namelist namsbc in configuration namelist : Parameters of the run
+      READ  ( numnam_cfg, namsbc, IOSTAT = ios, ERR = 902 )
+902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namsbc in configuration namelist', lwp )
+      IF(lwm) WRITE( numond, namsbc )
+      !
+      !                             !* overwrite namelist parameter using CPP key information
+#if defined key_agrif
+      IF( Agrif_Root() ) THEN                ! AGRIF zoom (cf r1242: possibility to run without ice in fine grid)
+         IF( lk_lim3 )   nn_ice      = 2
+         IF( lk_cice )   nn_ice      = 3
+      ENDIF
+#else
+      IF( lk_lim3 )   nn_ice      = 2
+      IF( lk_cice )   nn_ice      = 3
+#endif
+      !
+      IF(lwp) THEN                  !* Control print
+         WRITE(numout,*) '   Namelist namsbc (partly overwritten with CPP key setting)'
+         WRITE(numout,*) '      frequency update of sbc (and ice)             nn_fsbc       = ', nn_fsbc
+         WRITE(numout,*) '      Type of air-sea fluxes : '
+         WRITE(numout,*) '         user defined formulation                   ln_usr        = ', ln_usr
+         WRITE(numout,*) '         flux         formulation                   ln_flx        = ', ln_flx
+         WRITE(numout,*) '         bulk         formulation                   ln_blk        = ', ln_blk
+         WRITE(numout,*) '      Type of coupling (Ocean/Ice/Atmosphere) : '
+         WRITE(numout,*) '         ocean-atmosphere coupled formulation       ln_cpl        = ', ln_cpl
+         WRITE(numout,*) '         mixed forced-coupled     formulation       ln_mixcpl     = ', ln_mixcpl
+!!gm  lk_oasis is controlled by key_oasis3  ===>>>  It shoud be removed from the namelist 
+         WRITE(numout,*) '         OASIS coupling (with atm or sas)           lk_oasis      = ', lk_oasis
+         WRITE(numout,*) '         components of your executable              nn_components = ', nn_components
+         WRITE(numout,*) '      Sea-ice : '
+         WRITE(numout,*) '         ice management in the sbc (=0/1/2/3)       nn_ice        = ', nn_ice
+         WRITE(numout,*) '         ice embedded into ocean                    ln_ice_embd   = ', ln_ice_embd
+         WRITE(numout,*) '      Misc. options of sbc : '
+         WRITE(numout,*) '         Light penetration in temperature Eq.       ln_traqsr     = ', ln_traqsr
+         WRITE(numout,*) '            daily mean to diurnal cycle qsr            ln_dm2dc   = ', ln_dm2dc
+         WRITE(numout,*) '         Sea Surface Restoring on SST and/or SSS    ln_ssr        = ', ln_ssr
+         WRITE(numout,*) '         FreshWater Budget control  (=0/1/2)        nn_fwb        = ', nn_fwb
+         WRITE(numout,*) '         Patm gradient added in ocean & ice Eqs.    ln_apr_dyn    = ', ln_apr_dyn
+         WRITE(numout,*) '         runoff / runoff mouths                     ln_rnf        = ', ln_rnf
+         WRITE(numout,*) '         iceshelf formulation                       ln_isf        = ', ln_isf
+         WRITE(numout,*) '         nb of iterations if land-sea-mask applied  nn_lsm        = ', nn_lsm
+         WRITE(numout,*) '         surface wave                               ln_wave       = ', ln_wave
+         WRITE(numout,*) '               Stokes drift corr. to vert. velocity ln_sdw        = ', ln_sdw
+         WRITE(numout,*) '                  vertical parametrization          nn_sdrift     = ', nn_sdrift
+         WRITE(numout,*) '               wave modified ocean stress           ln_tauwoc     = ', ln_tauwoc
+         WRITE(numout,*) '               wave modified ocean stress component ln_tauw       = ', ln_tauw
+         WRITE(numout,*) '               Stokes coriolis term                 ln_stcor      = ', ln_stcor
+         WRITE(numout,*) '               neutral drag coefficient (CORE, MFS) ln_cdgw       = ', ln_cdgw
+      ENDIF
+      !
+      IF( ln_sdw ) THEN
+         IF( .NOT.(nn_sdrift==jp_breivik_2014 .OR. nn_sdrift==jp_li_2017 .OR. nn_sdrift==jp_peakfr) ) &
+            CALL ctl_stop( 'The chosen nn_sdrift for Stokes drift vertical velocity must be 0, 1, or 2' )
+      ENDIF
+      ll_st_bv2014  = ( nn_sdrift==jp_breivik_2014 )
+      ll_st_li2017  = ( nn_sdrift==jp_li_2017 )
+      ll_st_bv_li   = ( ll_st_bv2014 .OR. ll_st_li2017 )
+      ll_st_peakfr  = ( nn_sdrift==jp_peakfr )
+      IF( ln_tauwoc .AND. ln_tauw ) &
+         CALL ctl_stop( 'More than one method for modifying the ocean stress has been selected ', &
+                                  '(ln_tauwoc=.true. and ln_tauw=.true.)' )
+      IF( ln_tauwoc ) &
+         CALL ctl_warn( 'You are subtracting the wave stress to the ocean (ln_tauwoc=.true.)' )
+      IF( ln_tauw ) &
+         CALL ctl_warn( 'The wave modified ocean stress components are used (ln_tauw=.true.) ', &
+                              'This will override any other specification of the ocean stress' )
+      !
+      IF( .NOT.ln_usr ) THEN     ! the model calendar needs some specificities (except in user defined case)
+         IF( MOD( rday , rdt ) /= 0. )   CALL ctl_stop( 'the time step must devide the number of second of in a day' )
+         IF( MOD( rday , 2.  ) /= 0. )   CALL ctl_stop( 'the number of second of in a day must be an even number'    )
+         IF( MOD( rdt  , 2.  ) /= 0. )   CALL ctl_stop( 'the time step (in second) must be an even number'           )
+      ENDIF
+      !                       !**  check option consistency
+      !
+      IF(lwp) WRITE(numout,*)       !* Single / Multi - executable (NEMO / OPA+SAS) 
+      SELECT CASE( nn_components )
+      CASE( jp_iam_nemo )
+         IF(lwp) WRITE(numout,*) '   ==>>>   NEMO configured as a single executable (i.e. including both OPA and Surface module)'
+      CASE( jp_iam_opa  )
+         IF(lwp) WRITE(numout,*) '   ==>>>   Multi executable configuration. Here, OPA component'
+         IF( .NOT.lk_oasis )   CALL ctl_stop( 'sbc_init : OPA-SAS coupled via OASIS, but key_oasis3 disabled' )
+         IF( ln_cpl        )   CALL ctl_stop( 'sbc_init : OPA-SAS coupled via OASIS, but ln_cpl = T in OPA'   )
+         IF( ln_mixcpl     )   CALL ctl_stop( 'sbc_init : OPA-SAS coupled via OASIS, but ln_mixcpl = T in OPA' )
+      CASE( jp_iam_sas  )
+         IF(lwp) WRITE(numout,*) '   ==>>>   Multi executable configuration. Here, SAS component'
+         IF( .NOT.lk_oasis )   CALL ctl_stop( 'sbc_init : OPA-SAS coupled via OASIS, but key_oasis3 disabled' )
+         IF( ln_mixcpl     )   CALL ctl_stop( 'sbc_init : OPA-SAS coupled via OASIS, but ln_mixcpl = T in OPA' )
+      CASE DEFAULT
+         CALL ctl_stop( 'sbc_init : unsupported value for nn_components' )
+      END SELECT
+      !                             !* coupled options
+      IF( ln_cpl ) THEN
+         IF( .NOT. lk_oasis )   CALL ctl_stop( 'sbc_init : coupled mode with an atmosphere model (ln_cpl=T)',   &
+            &                                  '           required to defined key_oasis3' )
+      ENDIF
+      IF( ln_mixcpl ) THEN
+         IF( .NOT. lk_oasis )   CALL ctl_stop( 'sbc_init : mixed forced-coupled mode (ln_mixcpl=T) ',   &
+            &                                  '           required to defined key_oasis3' )
+         IF( .NOT.ln_cpl    )   CALL ctl_stop( 'sbc_init : mixed forced-coupled mode (ln_mixcpl=T) requires ln_cpl = T' )
+         IF( nn_components /= jp_iam_nemo )    &
+            &                   CALL ctl_stop( 'sbc_init : the mixed forced-coupled mode (ln_mixcpl=T) ',   &
+            &                                   '          not yet working with sas-opa coupling via oasis' )
+      ENDIF
+      !                             !* sea-ice
+      SELECT CASE( nn_ice )
+      CASE( 0 )                        !- no ice in the domain
+      CASE( 1 )                        !- Ice-cover climatology ("Ice-if" model)  
+      CASE( 2 )                        !- LIM3 ice model
+      CASE( 3 )                        !- CICE ice model
+         IF( .NOT.( ln_blk .OR. ln_cpl ) )   CALL ctl_stop( 'sbc_init : CICE sea-ice model requires ln_blk or ln_cpl = T' )
+         IF( lk_agrif                    )   CALL ctl_stop( 'sbc_init : CICE sea-ice model not currently available with AGRIF' ) 
+      CASE DEFAULT                     !- not supported
+      END SELECT
+      !
+      !                       !**  allocate and set required variables
+      !
+      !                             !* allocate sbc arrays
+      IF( sbc_oce_alloc() /= 0 )   CALL ctl_stop( 'sbc_init : unable to allocate sbc_oce arrays' )
+#if ! defined key_si3 && ! defined key_cice
+      IF( sbc_ice_alloc() /= 0 )   CALL ctl_stop( 'sbc_init : unable to allocate sbc_ice arrays' )
+#endif
+      !
+      IF( .NOT.ln_isf ) THEN        !* No ice-shelf in the domain : allocate and set to zero
+         IF( sbc_isf_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'sbc_init : unable to allocate sbc_isf arrays' )
+         fwfisf  (:,:)   = 0._wp   ;   risf_tsc  (:,:,:) = 0._wp
+         fwfisf_b(:,:)   = 0._wp   ;   risf_tsc_b(:,:,:) = 0._wp
+      END IF
+      IF( nn_ice == 0 ) THEN        !* No sea-ice in the domain : ice fraction is always zero
+         IF( nn_components /= jp_iam_opa )   fr_i(:,:) = 0._wp    ! except for OPA in SAS-OPA coupled case
+      ENDIF
+      !
+      sfx   (:,:) = 0._wp           !* salt flux due to freezing/melting
+      fmmflx(:,:) = 0._wp           !* freezing minus melting flux
+
+      taum(:,:) = 0._wp             !* wind stress module (needed in GLS in case of reduced restart)
+
+      !                          ! Choice of the Surface Boudary Condition (set nsbc)
+      IF( ln_dm2dc ) THEN           !* daily mean to diurnal cycle
+         nday_qsr = -1   ! allow initialization at the 1st call
+         IF( .NOT.( ln_flx .OR. ln_blk ) .AND. nn_components /= jp_iam_opa )   &
+            &   CALL ctl_stop( 'qsr diurnal cycle from daily values requires a flux or bulk formulation' )
+      ENDIF
+      !                             !* Choice of the Surface Boudary Condition
+      !                             (set nsbc)
+      !
+      ll_purecpl  = ln_cpl .AND. .NOT.ln_mixcpl
+      ll_opa      = nn_components == jp_iam_opa
+      ll_not_nemo = nn_components /= jp_iam_nemo
+      icpt = 0
+      !
+      IF( ln_usr          ) THEN   ;   nsbc = jp_usr     ; icpt = icpt + 1   ;   ENDIF       ! user defined         formulation
+      IF( ln_flx          ) THEN   ;   nsbc = jp_flx     ; icpt = icpt + 1   ;   ENDIF       ! flux                 formulation
+      IF( ln_blk          ) THEN   ;   nsbc = jp_blk     ; icpt = icpt + 1   ;   ENDIF       ! bulk                 formulation
+      IF( ll_purecpl      ) THEN   ;   nsbc = jp_purecpl ; icpt = icpt + 1   ;   ENDIF       ! Pure Coupled         formulation
+      IF( ll_opa          ) THEN   ;   nsbc = jp_none    ; icpt = icpt + 1   ;   ENDIF       ! opa coupling via SAS module
+      !
+      IF( icpt /= 1 )    CALL ctl_stop( 'sbc_init : choose ONE and only ONE sbc option' )
+      !
+      IF(lwp) THEN                     !- print the choice of surface flux formulation
+         WRITE(numout,*)
+         SELECT CASE( nsbc )
+         CASE( jp_usr     )   ;   WRITE(numout,*) '   ==>>>   user defined forcing formulation'
+         CASE( jp_flx     )   ;   WRITE(numout,*) '   ==>>>   flux formulation'
+         CASE( jp_blk     )   ;   WRITE(numout,*) '   ==>>>   bulk formulation'
+         CASE( jp_purecpl )   ;   WRITE(numout,*) '   ==>>>   pure coupled formulation'
+!!gm abusive use of jp_none ??   ===>>> need to be check and changed by adding a jp_sas parameter
+         CASE( jp_none    )   ;   WRITE(numout,*) '   ==>>>   OPA coupled to SAS via oasis'
+            IF( ln_mixcpl )       WRITE(numout,*) '               + forced-coupled mixed formulation'
+         END SELECT
+         IF( ll_not_nemo  )       WRITE(numout,*) '               + OASIS coupled SAS'
+      ENDIF
+      !
+      !                             !* OASIS initialization
+      !
+      IF( lk_oasis )   CALL sbc_cpl_init( nn_ice )   ! Must be done before: (1) first time step
+      !                                              !                      (2) the use of nn_fsbc
+      !     nn_fsbc initialization if OPA-SAS coupling via OASIS
+      !     SAS time-step has to be declared in OASIS (mandatory) -> nn_fsbc has to be modified accordingly
+      IF( nn_components /= jp_iam_nemo ) THEN
+         IF( nn_components == jp_iam_opa )   nn_fsbc = cpl_freq('O_SFLX') / NINT(rdt)
+         IF( nn_components == jp_iam_sas )   nn_fsbc = cpl_freq('I_SFLX') / NINT(rdt)
+         !
+         IF(lwp)THEN
+            WRITE(numout,*)
+            WRITE(numout,*)"   OPA-SAS coupled via OASIS : nn_fsbc re-defined from OASIS namcouple ", nn_fsbc
+            WRITE(numout,*)
+         ENDIF
+      ENDIF
+      !
+      !                             !* check consistency between model timeline and nn_fsbc
+      IF( MOD( nitend - nit000 + 1, nn_fsbc) /= 0 .OR.   &
+          MOD( nstock             , nn_fsbc) /= 0 ) THEN
+         WRITE(ctmp1,*) 'sbc_init : experiment length (', nitend - nit000 + 1, ') or nstock (', nstock,   &
+            &           ' is NOT a multiple of nn_fsbc (', nn_fsbc, ')'
+         CALL ctl_stop( ctmp1, 'Impossible to properly do model restart' )
+      ENDIF
+      !
+      IF( MOD( rday, REAL(nn_fsbc, wp) * rdt ) /= 0 )   &
+         &  CALL ctl_warn( 'sbc_init : nn_fsbc is NOT a multiple of the number of time steps in a day' )
+      !
+      IF( ln_dm2dc .AND. NINT(rday) / ( nn_fsbc * NINT(rdt) ) < 8  )   &
+         &   CALL ctl_warn( 'sbc_init : diurnal cycle for qsr: the sampling of the diurnal cycle is too small...' )
+      !
+   
+      !                       !**  associated modules : initialization
+      !
+                          CALL sbc_ssm_init            ! Sea-surface mean fields initialization
+      !
+      IF( ln_blk      )   CALL sbc_blk_init            ! bulk formulae initialization
+
+      IF( ln_ssr      )   CALL sbc_ssr_init            ! Sea-Surface Restoring initialization
+      !
+      IF( ln_isf      )   CALL sbc_isf_init            ! Compute iceshelves
+      !
+                          CALL sbc_rnf_init            ! Runof initialization
+      !
+      IF( ln_apr_dyn )    CALL sbc_apr_init            ! Atmo Pressure Forcing initialization
+      !
+#if defined key_si3
+      IF( lk_agrif .AND. nn_ice == 0 ) THEN            ! allocate ice arrays in case agrif + ice-model + no-ice in child grid
+                          IF( sbc_ice_alloc() /= 0 )   CALL ctl_stop('STOP', 'sbc_ice_alloc : unable to allocate arrays' )
+      ELSEIF( nn_ice == 2 ) THEN
+                          CALL ice_init                ! ICE initialization
+      ENDIF
+#endif
+      IF( nn_ice == 3 )   CALL cice_sbc_init( nsbc )   ! CICE initialization
+      !
+      IF( ln_wave     )   CALL sbc_wave_init           ! surface wave initialisation
+      !
+      IF( lwxios ) THEN
+         CALL iom_set_rstw_var_active('utau_b')
+         CALL iom_set_rstw_var_active('vtau_b')
+         CALL iom_set_rstw_var_active('qns_b')
+         ! The 3D heat content due to qsr forcing is treated in traqsr
+         ! CALL iom_set_rstw_var_active('qsr_b')
+         CALL iom_set_rstw_var_active('emp_b')
+         CALL iom_set_rstw_var_active('sfx_b')
+      ENDIF
+
+   END SUBROUTINE sbc_init
+
+
+   SUBROUTINE sbc( kt )
+      !!---------------------------------------------------------------------
+      !!                    ***  ROUTINE sbc  ***
+      !!
+      !! ** Purpose :   provide at each time-step the ocean surface boundary
+      !!                condition (momentum, heat and freshwater fluxes)
+      !!
+      !! ** Method  :   blah blah  to be written ?????????
+      !!                CAUTION : never mask the surface stress field (tke sbc)
+      !!
+      !! ** Action  : - set the ocean surface boundary condition at before and now
+      !!                time step, i.e.
+      !!                utau_b, vtau_b, qns_b, qsr_b, emp_n, sfx_b, qrp_b, erp_b
+      !!                utau  , vtau  , qns  , qsr  , emp  , sfx  , qrp  , erp
+      !!              - updte the ice fraction : fr_i
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT(in) ::   kt   ! ocean time step
+      !
+      LOGICAL ::   ll_sas, ll_opa   ! local logical
+      !!---------------------------------------------------------------------
+      !
+      IF( ln_timing )   CALL timing_start('sbc')
+      !
+      !                                            ! ---------------------------------------- !
+      IF( kt /= nit000 ) THEN                      !          Swap of forcing fields          !
+         !                                         ! ---------------------------------------- !
+         utau_b(:,:) = utau(:,:)                         ! Swap the ocean forcing fields
+         vtau_b(:,:) = vtau(:,:)                         ! (except at nit000 where before fields
+         qns_b (:,:) = qns (:,:)                         !  are set at the end of the routine)
+         emp_b (:,:) = emp (:,:)
+         sfx_b (:,:) = sfx (:,:)
+         IF ( ln_rnf ) THEN
+            rnf_b    (:,:  ) = rnf    (:,:  )
+            rnf_tsc_b(:,:,:) = rnf_tsc(:,:,:)
+         ENDIF
+         IF( ln_isf )  THEN
+            fwfisf_b  (:,:  ) = fwfisf  (:,:  )               
+            risf_tsc_b(:,:,:) = risf_tsc(:,:,:)              
+         ENDIF
+        !
+      ENDIF
+      !                                            ! ---------------------------------------- !
+      !                                            !        forcing field computation         !
+      !                                            ! ---------------------------------------- !
+      !
+      ll_sas = nn_components == jp_iam_sas               ! component flags
+      ll_opa = nn_components == jp_iam_opa
+      !
+      IF( .NOT.ll_sas )   CALL sbc_ssm ( kt )            ! mean ocean sea surface variables (sst_m, sss_m, ssu_m, ssv_m)
+      IF( ln_wave     )   CALL sbc_wave( kt )            ! surface waves
+
+      !
+      !                                            !==  sbc formulation  ==!
+      !                                                   
+      SELECT CASE( nsbc )                                ! Compute ocean surface boundary condition
+      !                                                  ! (i.e. utau,vtau, qns, qsr, emp, sfx)
+      CASE( jp_usr   )     ;   CALL usrdef_sbc_oce( kt )                    ! user defined formulation 
+      CASE( jp_flx     )   ;   CALL sbc_flx       ( kt )                    ! flux formulation
+      CASE( jp_blk     )
+         IF( ll_sas    )       CALL sbc_cpl_rcv   ( kt, nn_fsbc, nn_ice )   ! OPA-SAS coupling: SAS receiving fields from OPA
+                               CALL sbc_blk       ( kt )                    ! bulk formulation for the ocean
+                               !
+      CASE( jp_purecpl )   ;   CALL sbc_cpl_rcv   ( kt, nn_fsbc, nn_ice )   ! pure coupled formulation
+      CASE( jp_none    )
+         IF( ll_opa    )       CALL sbc_cpl_rcv   ( kt, nn_fsbc, nn_ice )   ! OPA-SAS coupling: OPA receiving fields from SAS
+      END SELECT
+      !
+      IF( ln_mixcpl )          CALL sbc_cpl_rcv   ( kt, nn_fsbc, nn_ice )   ! forced-coupled mixed formulation after forcing
+      !
+      IF ( ln_wave .AND. (ln_tauwoc .OR. ln_tauw) ) CALL sbc_wstress( )      ! Wind stress provided by waves 
+      !
+      !                                            !==  Misc. Options  ==!
+      !
+      SELECT CASE( nn_ice )                                       ! Update heat and freshwater fluxes over sea-ice areas
+      CASE(  1 )   ;         CALL sbc_ice_if   ( kt )             ! Ice-cover climatology ("Ice-if" model)
+#if defined key_si3
+      CASE(  2 )   ;         CALL ice_stp  ( kt, nsbc )           ! LIM-3 ice model
+#endif
+      CASE(  3 )   ;         CALL sbc_ice_cice ( kt, nsbc )       ! CICE ice model
+      END SELECT
+
+      IF( ln_icebergs    )   CALL icb_stp( kt )                   ! compute icebergs
+
+      IF( ln_isf         )   CALL sbc_isf( kt )                   ! compute iceshelves
+
+      IF( ln_rnf         )   CALL sbc_rnf( kt )                   ! add runoffs to fresh water fluxes
+
+      IF( ln_ssr         )   CALL sbc_ssr( kt )                   ! add SST/SSS damping term
+
+      IF( nn_fwb    /= 0 )   CALL sbc_fwb( kt, nn_fwb, nn_fsbc )  ! control the freshwater budget
+
+      ! Special treatment of freshwater fluxes over closed seas in the model domain
+      ! Should not be run if ln_diurnal_only
+      IF( l_sbc_clo .AND. (.NOT. ln_diurnal_only) )   CALL sbc_clo( kt )   
+
+!!$!RBbug do not understand why see ticket 667
+!!$!clem: it looks like it is necessary for the north fold (in certain circumstances). Don't know why.
+!!$      CALL lbc_lnk( emp, 'T', 1. )
+      !
+      IF( kt == nit000 ) THEN                          !   set the forcing field at nit000 - 1    !
+         !                                             ! ---------------------------------------- !
+         IF( ln_rstart .AND.    &                               !* Restart: read in restart file
+            & iom_varid( numror, 'utau_b', ldstop = .FALSE. ) > 0 ) THEN
+            IF(lwp) WRITE(numout,*) '          nit000-1 surface forcing fields red in the restart file'
+            CALL iom_get( numror, jpdom_autoglo, 'utau_b', utau_b, ldxios = lrxios )   ! before i-stress  (U-point)
+            CALL iom_get( numror, jpdom_autoglo, 'vtau_b', vtau_b, ldxios = lrxios )   ! before j-stress  (V-point)
+            CALL iom_get( numror, jpdom_autoglo, 'qns_b' , qns_b, ldxios = lrxios  )   ! before non solar heat flux (T-point)
+            ! The 3D heat content due to qsr forcing is treated in traqsr
+            ! CALL iom_get( numror, jpdom_autoglo, 'qsr_b' , qsr_b, ldxios = lrxios  ) ! before     solar heat flux (T-point)
+            CALL iom_get( numror, jpdom_autoglo, 'emp_b', emp_b, ldxios = lrxios  )    ! before     freshwater flux (T-point)
+            ! To ensure restart capability with 3.3x/3.4 restart files    !! to be removed in v3.6
+            IF( iom_varid( numror, 'sfx_b', ldstop = .FALSE. ) > 0 ) THEN
+               CALL iom_get( numror, jpdom_autoglo, 'sfx_b', sfx_b, ldxios = lrxios )  ! before salt flux (T-point)
+            ELSE
+               sfx_b (:,:) = sfx(:,:)
+            ENDIF
+         ELSE                                                   !* no restart: set from nit000 values
+            IF(lwp) WRITE(numout,*) '          nit000-1 surface forcing fields set to nit000'
+            utau_b(:,:) = utau(:,:)
+            vtau_b(:,:) = vtau(:,:)
+            qns_b (:,:) = qns (:,:)
+            emp_b (:,:) = emp (:,:)
+            sfx_b (:,:) = sfx (:,:)
+         ENDIF
+      ENDIF
+      !                                                ! ---------------------------------------- !
+      IF( lrst_oce ) THEN                              !      Write in the ocean restart file     !
+         !                                             ! ---------------------------------------- !
+         IF(lwp) WRITE(numout,*)
+         IF(lwp) WRITE(numout,*) 'sbc : ocean surface forcing fields written in ocean restart file ',   &
+            &                    'at it= ', kt,' date= ', ndastp
+         IF(lwp) WRITE(numout,*) '~~~~'
+         IF( lwxios ) CALL iom_swap(      cwxios_context          )
+         CALL iom_rstput( kt, nitrst, numrow, 'utau_b' , utau, ldxios = lwxios )
+         CALL iom_rstput( kt, nitrst, numrow, 'vtau_b' , vtau, ldxios = lwxios )
+         CALL iom_rstput( kt, nitrst, numrow, 'qns_b'  , qns, ldxios = lwxios  )
+         ! The 3D heat content due to qsr forcing is treated in traqsr
+         ! CALL iom_rstput( kt, nitrst, numrow, 'qsr_b'  , qsr  )
+         CALL iom_rstput( kt, nitrst, numrow, 'emp_b'  , emp, ldxios = lwxios  )
+         CALL iom_rstput( kt, nitrst, numrow, 'sfx_b'  , sfx, ldxios = lwxios  )
+         IF( lwxios ) CALL iom_swap(      cxios_context          )
+      ENDIF
+      !                                                ! ---------------------------------------- !
+      !                                                !        Outputs and control print         !
+      !                                                ! ---------------------------------------- !
+      IF( MOD( kt-1, nn_fsbc ) == 0 ) THEN
+         CALL iom_put( "empmr"  , emp    - rnf )                ! upward water flux
+         CALL iom_put( "empbmr" , emp_b  - rnf )                ! before upward water flux ( needed to recalculate the time evolution of ssh in offline )
+         CALL iom_put( "saltflx", sfx  )                        ! downward salt flux (includes virtual salt flux beneath ice in linear free surface case)
+         CALL iom_put( "fmmflx", fmmflx  )                      ! Freezing-melting water flux
+         CALL iom_put( "qt"    , qns  + qsr )                   ! total heat flux
+         CALL iom_put( "qns"   , qns        )                   ! solar heat flux
+         CALL iom_put( "qsr"   ,       qsr  )                   ! solar heat flux
+         IF( nn_ice > 0 .OR. ll_opa )   CALL iom_put( "ice_cover", fr_i )   ! ice fraction
+         CALL iom_put( "taum"  , taum       )                   ! wind stress module
+         CALL iom_put( "wspd"  , wndm       )                   ! wind speed  module over free ocean or leads in presence of sea-ice
+      ENDIF
+      !
+      CALL iom_put( "utau", utau )   ! i-wind stress   (stress can be updated at each time step in sea-ice)
+      CALL iom_put( "vtau", vtau )   ! j-wind stress
+      !
+      IF(ln_ctl) THEN         ! print mean trends (used for debugging)
+         CALL prt_ctl(tab2d_1=fr_i              , clinfo1=' fr_i    - : ', mask1=tmask )
+         CALL prt_ctl(tab2d_1=(emp-rnf + fwfisf), clinfo1=' emp-rnf - : ', mask1=tmask )
+         CALL prt_ctl(tab2d_1=(sfx-rnf + fwfisf), clinfo1=' sfx-rnf - : ', mask1=tmask )
+         CALL prt_ctl(tab2d_1=qns              , clinfo1=' qns      - : ', mask1=tmask )
+         CALL prt_ctl(tab2d_1=qsr              , clinfo1=' qsr      - : ', mask1=tmask )
+         CALL prt_ctl(tab3d_1=tmask            , clinfo1=' tmask    - : ', mask1=tmask, kdim=jpk )
+         CALL prt_ctl(tab3d_1=tsn(:,:,:,jp_tem), clinfo1=' sst      - : ', mask1=tmask, kdim=1   )
+         CALL prt_ctl(tab3d_1=tsn(:,:,:,jp_sal), clinfo1=' sss      - : ', mask1=tmask, kdim=1   )
+         CALL prt_ctl(tab2d_1=utau             , clinfo1=' utau     - : ', mask1=umask,                      &
+            &         tab2d_2=vtau             , clinfo2=' vtau     - : ', mask2=vmask )
+      ENDIF
+
+      IF( kt == nitend )   CALL sbc_final         ! Close down surface module if necessary
+      !
+      IF( ln_timing )   CALL timing_stop('sbc')
+      !
+   END SUBROUTINE sbc
+
+
+   SUBROUTINE sbc_final
+      !!---------------------------------------------------------------------
+      !!                    ***  ROUTINE sbc_final  ***
+      !!
+      !! ** Purpose :   Finalize CICE (if used)
+      !!---------------------------------------------------------------------
+      !
+      IF( nn_ice == 3 )   CALL cice_sbc_final
+      !
+   END SUBROUTINE sbc_final
+
+   !!======================================================================
+END MODULE sbcmod
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/SBC/sbcrnf.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/SBC/sbcrnf.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/SBC/sbcrnf.F90	(revision 9570)
@@ -0,0 +1,532 @@
+MODULE sbcrnf
+   !!======================================================================
+   !!                       ***  MODULE  sbcrnf  ***
+   !! Ocean forcing:  river runoff
+   !!=====================================================================
+   !! History :  OPA  ! 2000-11  (R. Hordoir, E. Durand)  NetCDF FORMAT
+   !!   NEMO     1.0  ! 2002-09  (G. Madec)  F90: Free form and module
+   !!            3.0  ! 2006-07  (G. Madec)  Surface module
+   !!            3.2  ! 2009-04  (B. Lemaire)  Introduce iom_put
+   !!            3.3  ! 2010-10  (R. Furner, G. Madec) runoff distributed over ocean levels
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   sbc_rnf       : monthly runoffs read in a NetCDF file
+   !!   sbc_rnf_init  : runoffs initialisation
+   !!   rnf_mouth     : set river mouth mask
+   !!----------------------------------------------------------------------
+   USE dom_oce        ! ocean space and time domain
+   USE phycst         ! physical constants
+   USE sbc_oce        ! surface boundary condition variables
+   USE sbcisf         ! PM we could remove it I think
+   USE eosbn2         ! Equation Of State
+   USE closea         ! closed seas
+   !
+   USE in_out_manager ! I/O manager
+   USE fldread        ! read input field at current time step
+   USE iom            ! I/O module
+   USE lib_mpp        ! MPP library
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   sbc_rnf       ! called in sbcmod module
+   PUBLIC   sbc_rnf_div   ! called in divhor module
+   PUBLIC   sbc_rnf_alloc ! called in sbcmod module
+   PUBLIC   sbc_rnf_init  ! called in sbcmod module
+   
+   !                                                !!* namsbc_rnf namelist *
+   CHARACTER(len=100)         ::   cn_dir            !: Root directory for location of rnf files
+   LOGICAL           , PUBLIC ::   ln_rnf_depth      !: depth       river runoffs attribute specified in a file
+   LOGICAL                    ::      ln_rnf_depth_ini  !: depth       river runoffs  computed at the initialisation
+   REAL(wp)                   ::      rn_rnf_max        !: maximum value of the runoff climatologie (ln_rnf_depth_ini =T)
+   REAL(wp)                   ::      rn_dep_max        !: depth over which runoffs is spread       (ln_rnf_depth_ini =T)
+   INTEGER                    ::      nn_rnf_depth_file !: create (=1) a runoff depth file or not (=0)
+   LOGICAL                    ::   ln_rnf_tem        !: temperature river runoffs attribute specified in a file
+   LOGICAL           , PUBLIC ::   ln_rnf_sal        !: salinity    river runoffs attribute specified in a file
+   TYPE(FLD_N)       , PUBLIC ::   sn_rnf            !: information about the runoff file to be read
+   TYPE(FLD_N)                ::   sn_cnf            !: information about the runoff mouth file to be read
+   TYPE(FLD_N)                ::   sn_s_rnf          !: information about the salinities of runoff file to be read
+   TYPE(FLD_N)                ::   sn_t_rnf          !: information about the temperatures of runoff file to be read
+   TYPE(FLD_N)                ::   sn_dep_rnf        !: information about the depth which river inflow affects
+   LOGICAL           , PUBLIC ::   ln_rnf_mouth      !: specific treatment in mouths vicinity
+   REAL(wp)                   ::   rn_hrnf           !: runoffs, depth over which enhanced vertical mixing is used
+   REAL(wp)          , PUBLIC ::   rn_avt_rnf        !: runoffs, value of the additional vertical mixing coef. [m2/s]
+   REAL(wp)          , PUBLIC ::   rn_rfact          !: multiplicative factor for runoff
+
+   LOGICAL , PUBLIC ::   l_rnfcpl = .false.   !: runoffs recieved from oasis
+   INTEGER , PUBLIC ::   nkrnf = 0            !: nb of levels over which Kz is increased at river mouths
+   
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   rnfmsk              !: river mouth mask (hori.)
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:)     ::   rnfmsk_z            !: river mouth mask (vert.)
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   h_rnf               !: depth of runoff in m
+   INTEGER,  PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   nk_rnf              !: depth of runoff in model levels
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   rnf_tsc_b, rnf_tsc  !: before and now T & S runoff contents   [K.m/s & PSU.m/s]   
+
+   TYPE(FLD),        ALLOCATABLE, DIMENSION(:) ::   sf_rnf       ! structure: river runoff (file information, fields read)
+   TYPE(FLD),        ALLOCATABLE, DIMENSION(:) ::   sf_s_rnf     ! structure: river runoff salinity (file information, fields read)  
+   TYPE(FLD),        ALLOCATABLE, DIMENSION(:) ::   sf_t_rnf     ! structure: river runoff temperature (file information, fields read)  
+ 
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO Consortium (2010)
+   !! $Id$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   INTEGER FUNCTION sbc_rnf_alloc()
+      !!----------------------------------------------------------------------
+      !!                ***  ROUTINE sbc_rnf_alloc  ***
+      !!----------------------------------------------------------------------
+      ALLOCATE( rnfmsk(jpi,jpj)         , rnfmsk_z(jpk)          ,     &
+         &      h_rnf (jpi,jpj)         , nk_rnf  (jpi,jpj)      ,     &
+         &      rnf_tsc_b(jpi,jpj,jpts) , rnf_tsc (jpi,jpj,jpts) , STAT=sbc_rnf_alloc )
+         !
+      IF( lk_mpp            )   CALL mpp_sum ( sbc_rnf_alloc )
+      IF( sbc_rnf_alloc > 0 )   CALL ctl_warn('sbc_rnf_alloc: allocation of arrays failed')
+   END FUNCTION sbc_rnf_alloc
+
+
+   SUBROUTINE sbc_rnf( kt )
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE sbc_rnf  ***
+      !!
+      !! ** Purpose :   Introduce a climatological run off forcing
+      !!
+      !! ** Method  :   Set each river mouth with a monthly climatology
+      !!                provided from different data.
+      !!                CAUTION : upward water flux, runoff forced to be < 0
+      !!
+      !! ** Action  :   runoff updated runoff field at time-step kt
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT(in) ::   kt          ! ocean time step
+      !
+      INTEGER  ::   ji, jj    ! dummy loop indices
+      INTEGER  ::   z_err = 0 ! dummy integer for error handling
+      !!----------------------------------------------------------------------
+      REAL(wp), DIMENSION(jpi,jpj) ::   ztfrz   ! freezing point used for temperature correction
+      !
+      !
+      !                                            !-------------------!
+      !                                            !   Update runoff   !
+      !                                            !-------------------!
+      !
+      IF( .NOT. l_rnfcpl )   CALL fld_read ( kt, nn_fsbc, sf_rnf   )    ! Read Runoffs data and provide it at kt
+      IF(   ln_rnf_tem   )   CALL fld_read ( kt, nn_fsbc, sf_t_rnf )    ! idem for runoffs temperature if required
+      IF(   ln_rnf_sal   )   CALL fld_read ( kt, nn_fsbc, sf_s_rnf )    ! idem for runoffs salinity    if required
+      !
+      IF( MOD( kt - 1, nn_fsbc ) == 0 ) THEN
+         !
+         IF( .NOT. l_rnfcpl )   rnf(:,:) = rn_rfact * ( sf_rnf(1)%fnow(:,:,1) )       ! updated runoff value at time step kt
+         !
+         !                                                           ! set temperature & salinity content of runoffs
+         IF( ln_rnf_tem ) THEN                                       ! use runoffs temperature data
+            rnf_tsc(:,:,jp_tem) = ( sf_t_rnf(1)%fnow(:,:,1) ) * rnf(:,:) * r1_rau0
+            CALL eos_fzp( sss_m(:,:), ztfrz(:,:) )
+            WHERE( sf_t_rnf(1)%fnow(:,:,1) == -999._wp )             ! if missing data value use SST as runoffs temperature
+               rnf_tsc(:,:,jp_tem) = sst_m(:,:) * rnf(:,:) * r1_rau0
+            END WHERE
+            WHERE( sf_t_rnf(1)%fnow(:,:,1) == -222._wp )             ! where fwf comes from melting of ice shelves or iceberg
+               rnf_tsc(:,:,jp_tem) = ztfrz(:,:) * rnf(:,:) * r1_rau0 - rnf(:,:) * rlfusisf * r1_rau0_rcp
+            END WHERE
+         ELSE                                                        ! use SST as runoffs temperature
+            !CEOD River is fresh water so must at least be 0 unless we consider ice
+            rnf_tsc(:,:,jp_tem) = MAX(sst_m(:,:),0.0_wp) * rnf(:,:) * r1_rau0
+         ENDIF
+         !                                                           ! use runoffs salinity data
+         IF( ln_rnf_sal )   rnf_tsc(:,:,jp_sal) = ( sf_s_rnf(1)%fnow(:,:,1) ) * rnf(:,:) * r1_rau0
+         !                                                           ! else use S=0 for runoffs (done one for all in the init)
+         IF( iom_use('runoffs') )        CALL iom_put( 'runoffs'     , rnf(:,:)                         )   ! output runoff mass flux
+         IF( iom_use('hflx_rnf_cea') )   CALL iom_put( 'hflx_rnf_cea', rnf_tsc(:,:,jp_tem) * rau0 * rcp )   ! output runoff sensible heat (W/m2)
+      ENDIF
+      !
+      !                                                ! ---------------------------------------- !
+      IF( kt == nit000 ) THEN                          !   set the forcing field at nit000 - 1    !
+         !                                             ! ---------------------------------------- !
+         IF( ln_rstart .AND.    &                               !* Restart: read in restart file
+            & iom_varid( numror, 'rnf_b', ldstop = .FALSE. ) > 0 ) THEN
+            IF(lwp) WRITE(numout,*) '          nit000-1 runoff forcing fields red in the restart file', lrxios
+            CALL iom_get( numror, jpdom_autoglo, 'rnf_b', rnf_b, ldxios = lrxios )     ! before runoff
+            CALL iom_get( numror, jpdom_autoglo, 'rnf_hc_b', rnf_tsc_b(:,:,jp_tem), ldxios = lrxios )   ! before heat content of runoff
+            CALL iom_get( numror, jpdom_autoglo, 'rnf_sc_b', rnf_tsc_b(:,:,jp_sal), ldxios = lrxios )   ! before salinity content of runoff
+         ELSE                                                   !* no restart: set from nit000 values
+            IF(lwp) WRITE(numout,*) '          nit000-1 runoff forcing fields set to nit000'
+            rnf_b    (:,:  ) = rnf    (:,:  )
+            rnf_tsc_b(:,:,:) = rnf_tsc(:,:,:)
+         ENDIF
+      ENDIF
+      !                                                ! ---------------------------------------- !
+      IF( lrst_oce ) THEN                              !      Write in the ocean restart file     !
+         !                                             ! ---------------------------------------- !
+         IF(lwp) WRITE(numout,*)
+         IF(lwp) WRITE(numout,*) 'sbcrnf : runoff forcing fields written in ocean restart file ',   &
+            &                    'at it= ', kt,' date= ', ndastp
+         IF(lwp) WRITE(numout,*) '~~~~'
+         IF( lwxios ) CALL iom_swap(      cwxios_context          )
+         CALL iom_rstput( kt, nitrst, numrow, 'rnf_b' , rnf, ldxios = lwxios )
+         CALL iom_rstput( kt, nitrst, numrow, 'rnf_hc_b', rnf_tsc(:,:,jp_tem), ldxios = lwxios )
+         CALL iom_rstput( kt, nitrst, numrow, 'rnf_sc_b', rnf_tsc(:,:,jp_sal), ldxios = lwxios )
+         IF( lwxios ) CALL iom_swap(      cxios_context          )
+      ENDIF
+      !
+   END SUBROUTINE sbc_rnf
+
+
+   SUBROUTINE sbc_rnf_div( phdivn )
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE sbc_rnf  ***
+      !!
+      !! ** Purpose :   update the horizontal divergence with the runoff inflow
+      !!
+      !! ** Method  :
+      !!                CAUTION : rnf is positive (inflow) decreasing the
+      !!                          divergence and expressed in m/s
+      !!
+      !! ** Action  :   phdivn   decreased by the runoff inflow
+      !!----------------------------------------------------------------------
+      REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   phdivn   ! horizontal divergence
+      !!
+      INTEGER  ::   ji, jj, jk   ! dummy loop indices
+      REAL(wp) ::   zfact     ! local scalar
+      !!----------------------------------------------------------------------
+      !
+      zfact = 0.5_wp
+      !
+      IF( ln_rnf_depth .OR. ln_rnf_depth_ini ) THEN      !==   runoff distributed over several levels   ==!
+         IF( ln_linssh ) THEN    !* constant volume case : just apply the runoff input flow
+            DO jj = 1, jpj
+               DO ji = 1, jpi
+                  DO jk = 1, nk_rnf(ji,jj)
+                     phdivn(ji,jj,jk) = phdivn(ji,jj,jk) - ( rnf(ji,jj) + rnf_b(ji,jj) ) * zfact * r1_rau0 / h_rnf(ji,jj)
+                  END DO
+               END DO
+            END DO
+         ELSE                    !* variable volume case
+            DO jj = 1, jpj                   ! update the depth over which runoffs are distributed
+               DO ji = 1, jpi
+                  h_rnf(ji,jj) = 0._wp
+                  DO jk = 1, nk_rnf(ji,jj)                           ! recalculates h_rnf to be the depth in metres
+                     h_rnf(ji,jj) = h_rnf(ji,jj) + e3t_n(ji,jj,jk)   ! to the bottom of the relevant grid box
+                  END DO
+                  !                          ! apply the runoff input flow
+                  DO jk = 1, nk_rnf(ji,jj)
+                     phdivn(ji,jj,jk) = phdivn(ji,jj,jk) - ( rnf(ji,jj) + rnf_b(ji,jj) ) * zfact * r1_rau0 / h_rnf(ji,jj)
+                  END DO
+               END DO
+            END DO
+         ENDIF
+      ELSE                       !==   runoff put only at the surface   ==!
+         h_rnf (:,:)   = e3t_n (:,:,1)        ! update h_rnf to be depth of top box
+         phdivn(:,:,1) = phdivn(:,:,1) - ( rnf(:,:) + rnf_b(:,:) ) * zfact * r1_rau0 / e3t_n(:,:,1)
+      ENDIF
+      !
+   END SUBROUTINE sbc_rnf_div
+
+
+   SUBROUTINE sbc_rnf_init
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE sbc_rnf_init  ***
+      !!
+      !! ** Purpose :   Initialisation of the runoffs if (ln_rnf=T)
+      !!
+      !! ** Method  : - read the runoff namsbc_rnf namelist
+      !!
+      !! ** Action  : - read parameters
+      !!----------------------------------------------------------------------
+      CHARACTER(len=32) ::   rn_dep_file   ! runoff file name
+      INTEGER           ::   ji, jj, jk, jm    ! dummy loop indices
+      INTEGER           ::   ierror, inum  ! temporary integer
+      INTEGER           ::   ios           ! Local integer output status for namelist read
+      INTEGER           ::   nbrec         ! temporary integer
+      REAL(wp)          ::   zacoef  
+      REAL(wp), DIMENSION(12)                 :: zrec             ! times records
+      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zrnfcl    
+      REAL(wp), DIMENSION(:,:  ), ALLOCATABLE :: zrnf
+      !!
+      NAMELIST/namsbc_rnf/ cn_dir            , ln_rnf_depth, ln_rnf_tem, ln_rnf_sal,   &
+         &                 sn_rnf, sn_cnf    , sn_s_rnf    , sn_t_rnf  , sn_dep_rnf,   &
+         &                 ln_rnf_mouth      , rn_hrnf     , rn_avt_rnf, rn_rfact,     &
+         &                 ln_rnf_depth_ini  , rn_dep_max  , rn_rnf_max, nn_rnf_depth_file
+      !!----------------------------------------------------------------------
+      !
+      !                                         !==  allocate runoff arrays
+      IF( sbc_rnf_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'sbc_rnf_alloc : unable to allocate arrays' )
+      !
+      IF( .NOT. ln_rnf ) THEN                      ! no specific treatment in vicinity of river mouths 
+         ln_rnf_mouth  = .FALSE.                   ! default definition needed for example by sbc_ssr or by tra_adv_muscl
+         nkrnf         = 0
+         rnf     (:,:) = 0.0_wp
+         rnf_b   (:,:) = 0.0_wp
+         rnfmsk  (:,:) = 0.0_wp
+         rnfmsk_z(:)   = 0.0_wp
+         RETURN
+      ENDIF
+      !
+      !                                   ! ============
+      !                                   !   Namelist
+      !                                   ! ============
+      !
+      REWIND( numnam_ref )              ! Namelist namsbc_rnf in reference namelist : Runoffs 
+      READ  ( numnam_ref, namsbc_rnf, IOSTAT = ios, ERR = 901)
+901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namsbc_rnf in reference namelist', lwp )
+
+      REWIND( numnam_cfg )              ! Namelist namsbc_rnf in configuration namelist : Runoffs
+      READ  ( numnam_cfg, namsbc_rnf, IOSTAT = ios, ERR = 902 )
+902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namsbc_rnf in configuration namelist', lwp )
+      IF(lwm) WRITE ( numond, namsbc_rnf )
+      !
+      !                                         ! Control print
+      IF(lwp) THEN
+         WRITE(numout,*)
+         WRITE(numout,*) 'sbc_rnf_init : runoff '
+         WRITE(numout,*) '~~~~~~~~~~~~ '
+         WRITE(numout,*) '   Namelist namsbc_rnf'
+         WRITE(numout,*) '      specific river mouths treatment            ln_rnf_mouth = ', ln_rnf_mouth
+         WRITE(numout,*) '      river mouth additional Kz                  rn_avt_rnf   = ', rn_avt_rnf
+         WRITE(numout,*) '      depth of river mouth additional mixing     rn_hrnf      = ', rn_hrnf
+         WRITE(numout,*) '      multiplicative factor for runoff           rn_rfact     = ', rn_rfact
+      ENDIF
+      !                                   ! ==================
+      !                                   !   Type of runoff
+      !                                   ! ==================
+      !
+      IF( .NOT. l_rnfcpl ) THEN                    
+         ALLOCATE( sf_rnf(1), STAT=ierror )         ! Create sf_rnf structure (runoff inflow)
+         IF(lwp) WRITE(numout,*)
+         IF(lwp) WRITE(numout,*) '   ==>>>   runoffs inflow read in a file'
+         IF( ierror > 0 ) THEN
+            CALL ctl_stop( 'sbc_rnf_init: unable to allocate sf_rnf structure' )   ;   RETURN
+         ENDIF
+         ALLOCATE( sf_rnf(1)%fnow(jpi,jpj,1)   )
+         IF( sn_rnf%ln_tint ) ALLOCATE( sf_rnf(1)%fdta(jpi,jpj,1,2) )
+         CALL fld_fill( sf_rnf, (/ sn_rnf /), cn_dir, 'sbc_rnf_init', 'read runoffs data', 'namsbc_rnf', no_print )
+      ENDIF
+      !
+      IF( ln_rnf_tem ) THEN                      ! Create (if required) sf_t_rnf structure
+         IF(lwp) WRITE(numout,*)
+         IF(lwp) WRITE(numout,*) '   ==>>>   runoffs temperatures read in a file'
+         ALLOCATE( sf_t_rnf(1), STAT=ierror  )
+         IF( ierror > 0 ) THEN
+            CALL ctl_stop( 'sbc_rnf_init: unable to allocate sf_t_rnf structure' )   ;   RETURN
+         ENDIF
+         ALLOCATE( sf_t_rnf(1)%fnow(jpi,jpj,1)   )
+         IF( sn_t_rnf%ln_tint ) ALLOCATE( sf_t_rnf(1)%fdta(jpi,jpj,1,2) )
+         CALL fld_fill (sf_t_rnf, (/ sn_t_rnf /), cn_dir, 'sbc_rnf_init', 'read runoff temperature data', 'namsbc_rnf', no_print )
+      ENDIF
+      !
+      IF( ln_rnf_sal  ) THEN                     ! Create (if required) sf_s_rnf and sf_t_rnf structures
+         IF(lwp) WRITE(numout,*)
+         IF(lwp) WRITE(numout,*) '   ==>>>   runoffs salinities read in a file'
+         ALLOCATE( sf_s_rnf(1), STAT=ierror  )
+         IF( ierror > 0 ) THEN
+            CALL ctl_stop( 'sbc_rnf_init: unable to allocate sf_s_rnf structure' )   ;   RETURN
+         ENDIF
+         ALLOCATE( sf_s_rnf(1)%fnow(jpi,jpj,1)   )
+         IF( sn_s_rnf%ln_tint ) ALLOCATE( sf_s_rnf(1)%fdta(jpi,jpj,1,2) )
+         CALL fld_fill (sf_s_rnf, (/ sn_s_rnf /), cn_dir, 'sbc_rnf_init', 'read runoff salinity data', 'namsbc_rnf', no_print )
+      ENDIF
+      !
+      IF( ln_rnf_depth ) THEN                    ! depth of runoffs set from a file
+         IF(lwp) WRITE(numout,*)
+         IF(lwp) WRITE(numout,*) '   ==>>>   runoffs depth read in a file'
+         rn_dep_file = TRIM( cn_dir )//TRIM( sn_dep_rnf%clname )
+         IF( .NOT. sn_dep_rnf%ln_clim ) THEN   ;   WRITE(rn_dep_file, '(a,"_y",i4)' ) TRIM( rn_dep_file ), nyear    ! add year 
+            IF( sn_dep_rnf%cltype == 'monthly' )   WRITE(rn_dep_file, '(a,"m",i2)'  ) TRIM( rn_dep_file ), nmonth   ! add month 
+         ENDIF
+         CALL iom_open ( rn_dep_file, inum )                           ! open file
+         CALL iom_get  ( inum, jpdom_data, sn_dep_rnf%clvar, h_rnf )   ! read the river mouth array
+         CALL iom_close( inum )                                        ! close file
+         !
+         nk_rnf(:,:) = 0                               ! set the number of level over which river runoffs are applied
+         DO jj = 1, jpj
+            DO ji = 1, jpi
+               IF( h_rnf(ji,jj) > 0._wp ) THEN
+                  jk = 2
+                  DO WHILE ( jk /= mbkt(ji,jj) .AND. gdept_0(ji,jj,jk) < h_rnf(ji,jj) ) ;  jk = jk + 1
+                  END DO
+                  nk_rnf(ji,jj) = jk
+               ELSEIF( h_rnf(ji,jj) == -1._wp   ) THEN   ;  nk_rnf(ji,jj) = 1
+               ELSEIF( h_rnf(ji,jj) == -999._wp ) THEN   ;  nk_rnf(ji,jj) = mbkt(ji,jj)
+               ELSE
+                  CALL ctl_stop( 'sbc_rnf_init: runoff depth not positive, and not -999 or -1, rnf value in file fort.999'  )
+                  WRITE(999,*) 'ji, jj, h_rnf(ji,jj) :', ji, jj, h_rnf(ji,jj)
+               ENDIF
+            END DO
+         END DO
+         DO jj = 1, jpj                                ! set the associated depth
+            DO ji = 1, jpi
+               h_rnf(ji,jj) = 0._wp
+               DO jk = 1, nk_rnf(ji,jj)
+                  h_rnf(ji,jj) = h_rnf(ji,jj) + e3t_n(ji,jj,jk)
+               END DO
+            END DO
+         END DO
+         !
+      ELSE IF( ln_rnf_depth_ini ) THEN           ! runoffs applied at the surface
+         !
+         IF(lwp) WRITE(numout,*)
+         IF(lwp) WRITE(numout,*) '   ==>>>   depth of runoff computed once from max value of runoff'
+         IF(lwp) WRITE(numout,*) '        max value of the runoff climatologie (over global domain) rn_rnf_max = ', rn_rnf_max
+         IF(lwp) WRITE(numout,*) '        depth over which runoffs is spread                        rn_dep_max = ', rn_dep_max
+         IF(lwp) WRITE(numout,*) '        create (=1) a runoff depth file or not (=0)      nn_rnf_depth_file  = ', nn_rnf_depth_file
+
+         CALL iom_open( TRIM( sn_rnf%clname ), inum )    !  open runoff file
+         CALL iom_gettime( inum, zrec, kntime=nbrec)
+         ALLOCATE( zrnfcl(jpi,jpj,nbrec) )     ;      ALLOCATE( zrnf(jpi,jpj) )
+         DO jm = 1, nbrec
+            CALL iom_get( inum, jpdom_data, TRIM( sn_rnf%clvar ), zrnfcl(:,:,jm), jm )
+         END DO
+         CALL iom_close( inum )
+         zrnf(:,:) = MAXVAL( zrnfcl(:,:,:), DIM=3 )   !  maximum value in time
+         DEALLOCATE( zrnfcl )
+         !
+         h_rnf(:,:) = 1.
+         !
+         zacoef = rn_dep_max / rn_rnf_max            ! coef of linear relation between runoff and its depth (150m for max of runoff)
+         !
+         WHERE( zrnf(:,:) > 0._wp )  h_rnf(:,:) = zacoef * zrnf(:,:)   ! compute depth for all runoffs
+         !
+         DO jj = 1, jpj                     ! take in account min depth of ocean rn_hmin
+            DO ji = 1, jpi
+               IF( zrnf(ji,jj) > 0._wp ) THEN
+                  jk = mbkt(ji,jj)
+                  h_rnf(ji,jj) = MIN( h_rnf(ji,jj), gdept_0(ji,jj,jk ) )
+               ENDIF
+            END DO
+         END DO
+         !
+         nk_rnf(:,:) = 0                       ! number of levels on which runoffs are distributed
+         DO jj = 1, jpj
+            DO ji = 1, jpi
+               IF( zrnf(ji,jj) > 0._wp ) THEN
+                  jk = 2
+                  DO WHILE ( jk /= mbkt(ji,jj) .AND. gdept_0(ji,jj,jk) < h_rnf(ji,jj) ) ;  jk = jk + 1
+                  END DO
+                  nk_rnf(ji,jj) = jk
+               ELSE
+                  nk_rnf(ji,jj) = 1
+               ENDIF
+            END DO
+         END DO
+         !
+         DEALLOCATE( zrnf )
+         !
+         DO jj = 1, jpj                                ! set the associated depth
+            DO ji = 1, jpi
+               h_rnf(ji,jj) = 0._wp
+               DO jk = 1, nk_rnf(ji,jj)
+                  h_rnf(ji,jj) = h_rnf(ji,jj) + e3t_n(ji,jj,jk)
+               END DO
+            END DO
+         END DO
+         !
+         IF( nn_rnf_depth_file == 1 ) THEN      !  save  output nb levels for runoff
+            IF(lwp) WRITE(numout,*) '   ==>>>   create runoff depht file'
+            CALL iom_open  ( TRIM( sn_dep_rnf%clname ), inum, ldwrt = .TRUE., kiolib = jprstlib )
+            CALL iom_rstput( 0, 0, inum, 'rodepth', h_rnf )
+            CALL iom_close ( inum )
+         ENDIF
+      ELSE                                       ! runoffs applied at the surface
+         nk_rnf(:,:) = 1
+         h_rnf (:,:) = e3t_n(:,:,1)
+      ENDIF
+      !
+      rnf(:,:) =  0._wp                         ! runoff initialisation
+      rnf_tsc(:,:,:) = 0._wp                    ! runoffs temperature & salinty contents initilisation
+      !
+      !                                   ! ========================
+      !                                   !   River mouth vicinity
+      !                                   ! ========================
+      !
+      IF( ln_rnf_mouth ) THEN                   ! Specific treatment in vicinity of river mouths :
+         !                                      !    - Increase Kz in surface layers ( rn_hrnf > 0 )
+         !                                      !    - set to zero SSS damping (ln_ssr=T)
+         !                                      !    - mixed upstream-centered (ln_traadv_cen2=T)
+         !
+         IF ( ln_rnf_depth )   CALL ctl_warn( 'sbc_rnf_init: increased mixing turned on but effects may already',   &
+            &                                              'be spread through depth by ln_rnf_depth'               )
+         !
+         nkrnf = 0                                  ! Number of level over which Kz increase
+         IF( rn_hrnf > 0._wp ) THEN
+            nkrnf = 2
+            DO WHILE( nkrnf /= jpkm1 .AND. gdepw_1d(nkrnf+1) < rn_hrnf )   ;   nkrnf = nkrnf + 1
+            END DO
+            IF( ln_sco )   CALL ctl_warn( 'sbc_rnf_init: number of levels over which Kz is increased is computed for zco...' )
+         ENDIF
+         IF(lwp) WRITE(numout,*)
+         IF(lwp) WRITE(numout,*) '   ==>>>   Specific treatment used in vicinity of river mouths :'
+         IF(lwp) WRITE(numout,*) '             - Increase Kz in surface layers (if rn_hrnf > 0 )'
+         IF(lwp) WRITE(numout,*) '               by ', rn_avt_rnf,' m2/s  over ', nkrnf, ' w-levels'
+         IF(lwp) WRITE(numout,*) '             - set to zero SSS damping       (if ln_ssr=T)'
+         IF(lwp) WRITE(numout,*) '             - mixed upstream-centered       (if ln_traadv_cen2=T)'
+         !
+         CALL rnf_mouth                             ! set river mouth mask
+         !
+      ELSE                                      ! No treatment at river mouths
+         IF(lwp) WRITE(numout,*)
+         IF(lwp) WRITE(numout,*) '   ==>>>   No specific treatment at river mouths'
+         rnfmsk  (:,:) = 0._wp
+         rnfmsk_z(:)   = 0._wp
+         nkrnf = 0
+      ENDIF
+      !
+      IF( lwxios ) THEN
+         CALL iom_set_rstw_var_active('rnf_b')
+         CALL iom_set_rstw_var_active('rnf_hc_b')
+         CALL iom_set_rstw_var_active('rnf_sc_b')
+      ENDIF
+
+   END SUBROUTINE sbc_rnf_init
+
+
+   SUBROUTINE rnf_mouth
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE rnf_mouth  ***
+      !!
+      !! ** Purpose :   define the river mouths mask
+      !!
+      !! ** Method  :   read the river mouth mask (=0/1) in the river runoff
+      !!                climatological file. Defined a given vertical structure.
+      !!                CAUTION, the vertical structure is hard coded on the
+      !!                first 5 levels.
+      !!                This fields can be used to:
+      !!                 - set an upstream advection scheme
+      !!                   (ln_rnf_mouth=T and ln_traadv_cen2=T)
+      !!                 - increase vertical on the top nn_krnf vertical levels
+      !!                   at river runoff input grid point (nn_krnf>=2, see step.F90)
+      !!                 - set to zero SSS restoring flux at river mouth grid points
+      !!
+      !! ** Action  :   rnfmsk   set to 1 at river runoff input, 0 elsewhere
+      !!                rnfmsk_z vertical structure
+      !!----------------------------------------------------------------------
+      INTEGER            ::   inum        ! temporary integers
+      CHARACTER(len=140) ::   cl_rnfile   ! runoff file name
+      !!----------------------------------------------------------------------
+      !
+      IF(lwp) WRITE(numout,*)
+      IF(lwp) WRITE(numout,*) '   rnf_mouth : river mouth mask'
+      IF(lwp) WRITE(numout,*) '   ~~~~~~~~~ '
+      !
+      cl_rnfile = TRIM( cn_dir )//TRIM( sn_cnf%clname )
+      IF( .NOT. sn_cnf%ln_clim ) THEN   ;   WRITE(cl_rnfile, '(a,"_y",i4)' ) TRIM( cl_rnfile ), nyear    ! add year
+         IF( sn_cnf%cltype == 'monthly' )   WRITE(cl_rnfile, '(a,"m",i2)'  ) TRIM( cl_rnfile ), nmonth   ! add month
+      ENDIF
+      !
+      ! horizontal mask (read in NetCDF file)
+      CALL iom_open ( cl_rnfile, inum )                           ! open file
+      CALL iom_get  ( inum, jpdom_data, sn_cnf%clvar, rnfmsk )    ! read the river mouth array
+      CALL iom_close( inum )                                      ! close file
+      !
+      IF( l_clo_rnf )   CALL clo_rnf( rnfmsk )   ! closed sea inflow set as river mouth
+      !
+      rnfmsk_z(:)   = 0._wp                                       ! vertical structure
+      rnfmsk_z(1)   = 1.0
+      rnfmsk_z(2)   = 1.0                                         ! **********
+      rnfmsk_z(3)   = 0.5                                         ! HARD CODED on the 5 first levels
+      rnfmsk_z(4)   = 0.25                                        ! **********
+      rnfmsk_z(5)   = 0.125
+      !
+   END SUBROUTINE rnf_mouth
+
+   !!======================================================================
+END MODULE sbcrnf
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/SBC/sbcssm.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/SBC/sbcssm.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/SBC/sbcssm.F90	(revision 9570)
@@ -0,0 +1,269 @@
+MODULE sbcssm
+   !!======================================================================
+   !!                       ***  MODULE  sbcssm  ***
+   !! Surface module :  provide time-mean ocean surface variables
+   !!======================================================================
+   !! History :  9.0  ! 2006-07  (G. Madec)  Original code
+   !!            3.3  ! 2010-10  (C. Bricaud, G. Madec)  add the Patm forcing for sea-ice
+   !!            3.7  ! 2015-11  (G. Madec)  non linear free surface by default: e3t_m always computed
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   sbc_ssm       : calculate sea surface mean currents, temperature,  
+   !!                   and salinity over nn_fsbc time-step
+   !!----------------------------------------------------------------------
+   USE oce            ! ocean dynamics and tracers
+   USE dom_oce        ! ocean space and time domain
+   USE sbc_oce        ! surface boundary condition: ocean fields
+   USE sbcapr         ! surface boundary condition: atmospheric pressure
+   USE eosbn2         ! equation of state and related derivatives
+   !
+   USE in_out_manager ! I/O manager
+   USE prtctl         ! Print control
+   USE iom            ! IOM library
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   sbc_ssm        ! routine called by step.F90
+   PUBLIC   sbc_ssm_init   ! routine called by sbcmod.F90
+
+   LOGICAL, SAVE ::   l_ssm_mean = .FALSE.   ! keep track of whether means have been read from restart file
+   
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO Consortium (2010)
+   !! $Id$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE sbc_ssm( kt )
+      !!---------------------------------------------------------------------
+      !!                     ***  ROUTINE sbc_oce  ***
+      !!                     
+      !! ** Purpose :   provide ocean surface variable to sea-surface boundary
+      !!                condition computation 
+      !!                
+      !! ** Method  :   compute mean surface velocity (2 components at U and 
+      !!      V-points) [m/s], temperature [Celsius] and salinity [psu] over
+      !!      the periode (kt - nn_fsbc) to kt
+      !!         Note that the inverse barometer ssh (i.e. ssh associated with Patm)
+      !!      is add to ssh_m when ln_apr_dyn = T. Required for sea-ice dynamics.
+      !!---------------------------------------------------------------------
+      INTEGER, INTENT(in) ::   kt   ! ocean time step
+      !
+      INTEGER  ::   ji, jj               ! loop index
+      REAL(wp) ::   zcoef, zf_sbc       ! local scalar
+      REAL(wp), DIMENSION(jpi,jpj,jpts) :: zts
+      !!---------------------------------------------------------------------
+      !
+      !                                        !* surface T-, U-, V- ocean level variables (T, S, depth, velocity)
+      DO jj = 1, jpj
+         DO ji = 1, jpi
+            zts(ji,jj,jp_tem) = tsn(ji,jj,mikt(ji,jj),jp_tem)
+            zts(ji,jj,jp_sal) = tsn(ji,jj,mikt(ji,jj),jp_sal)
+         END DO
+      END DO
+      !
+      IF( nn_fsbc == 1 ) THEN                             !   Instantaneous surface fields        !
+         !                                                ! ---------------------------------------- !
+         ssu_m(:,:) = ub(:,:,1)
+         ssv_m(:,:) = vb(:,:,1)
+         IF( l_useCT )  THEN    ;   sst_m(:,:) = eos_pt_from_ct( zts(:,:,jp_tem), zts(:,:,jp_sal) )
+         ELSE                    ;   sst_m(:,:) = zts(:,:,jp_tem)
+         ENDIF
+         sss_m(:,:) = zts(:,:,jp_sal)
+         !                          ! removed inverse barometer ssh when Patm forcing is used (for sea-ice dynamics)
+         IF( ln_apr_dyn ) THEN   ;   ssh_m(:,:) = sshn(:,:) - 0.5 * ( ssh_ib(:,:) + ssh_ibb(:,:) )
+         ELSE                    ;   ssh_m(:,:) = sshn(:,:)
+         ENDIF
+         !
+         e3t_m(:,:) = e3t_n(:,:,1)
+         !
+         frq_m(:,:) = fraqsr_1lev(:,:)
+         !
+      ELSE
+         !                                                ! ----------------------------------------------- !
+         IF( kt == nit000 .AND. .NOT. l_ssm_mean ) THEN   !   Initialisation: 1st time-step, no input means !
+            !                                             ! ----------------------------------------------- !
+            IF(lwp) WRITE(numout,*)
+            IF(lwp) WRITE(numout,*) 'sbc_ssm : mean fields initialised to instantaneous values'
+            IF(lwp) WRITE(numout,*) '~~~~~~~   '
+            zcoef = REAL( nn_fsbc - 1, wp )
+            ssu_m(:,:) = zcoef * ub(:,:,1)
+            ssv_m(:,:) = zcoef * vb(:,:,1)
+            IF( l_useCT )  THEN    ;   sst_m(:,:) = zcoef * eos_pt_from_ct( zts(:,:,jp_tem), zts(:,:,jp_sal) )
+            ELSE                    ;   sst_m(:,:) = zcoef * zts(:,:,jp_tem)
+            ENDIF
+            sss_m(:,:) = zcoef * zts(:,:,jp_sal)
+            !                          ! removed inverse barometer ssh when Patm forcing is used (for sea-ice dynamics)
+            IF( ln_apr_dyn ) THEN   ;   ssh_m(:,:) = zcoef * ( sshn(:,:) - 0.5 * ( ssh_ib(:,:) + ssh_ibb(:,:) ) )
+            ELSE                    ;   ssh_m(:,:) = zcoef * sshn(:,:)
+            ENDIF
+            !
+            e3t_m(:,:) = zcoef * e3t_n(:,:,1)
+            !
+            frq_m(:,:) = zcoef * fraqsr_1lev(:,:)
+            !                                             ! ---------------------------------------- !
+         ELSEIF( MOD( kt - 2 , nn_fsbc ) == 0 ) THEN      !   Initialisation: New mean computation   !
+            !                                             ! ---------------------------------------- !
+            ssu_m(:,:) = 0._wp     ! reset to zero ocean mean sbc fields
+            ssv_m(:,:) = 0._wp
+            sst_m(:,:) = 0._wp
+            sss_m(:,:) = 0._wp
+            ssh_m(:,:) = 0._wp
+            e3t_m(:,:) = 0._wp
+            frq_m(:,:) = 0._wp
+         ENDIF
+         !                                                ! ---------------------------------------- !
+         !                                                !        Cumulate at each time step        !
+         !                                                ! ---------------------------------------- !
+         ssu_m(:,:) = ssu_m(:,:) + ub(:,:,1)
+         ssv_m(:,:) = ssv_m(:,:) + vb(:,:,1)
+         IF( l_useCT )  THEN     ;   sst_m(:,:) = sst_m(:,:) + eos_pt_from_ct( zts(:,:,jp_tem), zts(:,:,jp_sal) )
+         ELSE                    ;   sst_m(:,:) = sst_m(:,:) + zts(:,:,jp_tem)
+         ENDIF
+         sss_m(:,:) = sss_m(:,:) + zts(:,:,jp_sal)
+         !                          ! removed inverse barometer ssh when Patm forcing is used (for sea-ice dynamics)
+         IF( ln_apr_dyn ) THEN   ;   ssh_m(:,:) = ssh_m(:,:) + sshn(:,:) - 0.5 * ( ssh_ib(:,:) + ssh_ibb(:,:) )
+         ELSE                    ;   ssh_m(:,:) = ssh_m(:,:) + sshn(:,:)
+         ENDIF
+         !
+         e3t_m(:,:) = e3t_m(:,:) + e3t_n(:,:,1)
+         !
+         frq_m(:,:) = frq_m(:,:) + fraqsr_1lev(:,:)
+
+         !                                                ! ---------------------------------------- !
+         IF( MOD( kt - 1 , nn_fsbc ) == 0 ) THEN          !   Mean value at each nn_fsbc time-step   !
+            !                                             ! ---------------------------------------- !
+            zcoef = 1. / REAL( nn_fsbc, wp )
+            sst_m(:,:) = sst_m(:,:) * zcoef     ! mean SST             [Celsius]
+            sss_m(:,:) = sss_m(:,:) * zcoef     ! mean SSS             [psu]
+            ssu_m(:,:) = ssu_m(:,:) * zcoef     ! mean suface current  [m/s]
+            ssv_m(:,:) = ssv_m(:,:) * zcoef     !
+            ssh_m(:,:) = ssh_m(:,:) * zcoef     ! mean SSH             [m]
+            e3t_m(:,:) = e3t_m(:,:) * zcoef     ! mean vertical scale factor [m]
+            frq_m(:,:) = frq_m(:,:) * zcoef     ! mean fraction of solar net radiation absorbed in the 1st T level [-]
+            !
+         ENDIF
+         !                                                ! ---------------------------------------- !
+         IF( lrst_oce ) THEN                              !      Write in the ocean restart file     !
+            !                                             ! ---------------------------------------- !
+            IF(lwp) WRITE(numout,*)
+            IF(lwp) WRITE(numout,*) 'sbc_ssm : sea surface mean fields written in ocean restart file ',   &
+               &                    'at it= ', kt,' date= ', ndastp
+            IF(lwp) WRITE(numout,*) '~~~~~~~'
+            zf_sbc = REAL( nn_fsbc, wp )
+            IF( lwxios ) CALL iom_swap(      cwxios_context          )
+            CALL iom_rstput( kt, nitrst, numrow, 'nn_fsbc', zf_sbc, ldxios = lwxios )    ! sbc frequency
+            CALL iom_rstput( kt, nitrst, numrow, 'ssu_m'  , ssu_m, ldxios = lwxios  )    ! sea surface mean fields
+            CALL iom_rstput( kt, nitrst, numrow, 'ssv_m'  , ssv_m, ldxios = lwxios  )
+            CALL iom_rstput( kt, nitrst, numrow, 'sst_m'  , sst_m, ldxios = lwxios  )
+            CALL iom_rstput( kt, nitrst, numrow, 'sss_m'  , sss_m, ldxios = lwxios  )
+            CALL iom_rstput( kt, nitrst, numrow, 'ssh_m'  , ssh_m, ldxios = lwxios  )
+            CALL iom_rstput( kt, nitrst, numrow, 'e3t_m'  , e3t_m, ldxios = lwxios  )
+            CALL iom_rstput( kt, nitrst, numrow, 'frq_m'  , frq_m, ldxios = lwxios  )
+            !
+            IF( lwxios ) CALL iom_swap(      cxios_context          )
+         ENDIF
+         !
+      ENDIF
+      !
+      IF( MOD( kt - 1 , nn_fsbc ) == 0 ) THEN          !   Mean value at each nn_fsbc time-step   !
+         CALL iom_put( 'ssu_m', ssu_m )
+         CALL iom_put( 'ssv_m', ssv_m )
+         CALL iom_put( 'sst_m', sst_m )
+         CALL iom_put( 'sss_m', sss_m )
+         CALL iom_put( 'ssh_m', ssh_m )
+         CALL iom_put( 'e3t_m', e3t_m )
+         CALL iom_put( 'frq_m', frq_m )
+      ENDIF
+      !
+   END SUBROUTINE sbc_ssm
+
+
+   SUBROUTINE sbc_ssm_init
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE sbc_ssm_init  ***
+      !!
+      !! ** Purpose :   Initialisation of the sbc data
+      !!
+      !! ** Action  : - read parameters
+      !!----------------------------------------------------------------------
+      REAL(wp) ::   zcoef, zf_sbc   ! local scalar
+      !!----------------------------------------------------------------------
+      !
+      IF( nn_fsbc == 1 ) THEN
+         !
+         IF(lwp) WRITE(numout,*)
+         IF(lwp) WRITE(numout,*) 'sbc_ssm_init : sea surface mean fields, nn_fsbc=1 : instantaneous values'
+         IF(lwp) WRITE(numout,*) '~~~~~~~~~~~ '
+         !
+      ELSE
+         !               
+         IF(lwp) WRITE(numout,*)
+         IF(lwp) WRITE(numout,*) 'sbc_ssm_init : sea surface mean fields'
+         IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~ '
+         !
+         IF( ln_rstart .AND. iom_varid( numror, 'nn_fsbc', ldstop = .FALSE. ) > 0 ) THEN
+            l_ssm_mean = .TRUE.
+            CALL iom_get( numror               , 'nn_fsbc', zf_sbc, ldxios = lrxios )    ! sbc frequency of previous run
+            CALL iom_get( numror, jpdom_autoglo, 'ssu_m'  , ssu_m, ldxios = lrxios  )    ! sea surface mean velocity    (U-point)
+            CALL iom_get( numror, jpdom_autoglo, 'ssv_m'  , ssv_m, ldxios = lrxios  )    !   "         "    velocity    (V-point)
+            CALL iom_get( numror, jpdom_autoglo, 'sst_m'  , sst_m, ldxios = lrxios  )    !   "         "    temperature (T-point)
+            CALL iom_get( numror, jpdom_autoglo, 'sss_m'  , sss_m, ldxios = lrxios  )    !   "         "    salinity    (T-point)
+            CALL iom_get( numror, jpdom_autoglo, 'ssh_m'  , ssh_m, ldxios = lrxios  )    !   "         "    height      (T-point)
+            CALL iom_get( numror, jpdom_autoglo, 'e3t_m'  , e3t_m, ldxios = lrxios  )    ! 1st level thickness          (T-point)
+            ! fraction of solar net radiation absorbed in 1st T level
+            IF( iom_varid( numror, 'frq_m', ldstop = .FALSE. ) > 0 ) THEN
+               CALL iom_get( numror, jpdom_autoglo, 'frq_m'  , frq_m, ldxios = lrxios  )
+            ELSE
+               frq_m(:,:) = 1._wp   ! default definition
+            ENDIF
+            !
+            IF( zf_sbc /= REAL( nn_fsbc, wp ) ) THEN      ! nn_fsbc has changed between 2 runs
+               IF(lwp) WRITE(numout,*) '   restart with a change in the frequency of mean from ', zf_sbc, ' to ', nn_fsbc 
+               zcoef = REAL( nn_fsbc - 1, wp ) / zf_sbc 
+               ssu_m(:,:) = zcoef * ssu_m(:,:) 
+               ssv_m(:,:) = zcoef * ssv_m(:,:)
+               sst_m(:,:) = zcoef * sst_m(:,:)
+               sss_m(:,:) = zcoef * sss_m(:,:)
+               ssh_m(:,:) = zcoef * ssh_m(:,:)
+               e3t_m(:,:) = zcoef * e3t_m(:,:)
+               frq_m(:,:) = zcoef * frq_m(:,:)
+            ELSE
+               IF(lwp) WRITE(numout,*) '   mean fields read in the ocean restart file'
+            ENDIF
+         ENDIF
+      ENDIF
+      !
+      IF( .NOT.l_ssm_mean ) THEN   ! default initialisation. needed by iceistate
+         !
+         IF(lwp) WRITE(numout,*) '   default initialisation of ss._m arrays'
+         ssu_m(:,:) = ub(:,:,1)
+         ssv_m(:,:) = vb(:,:,1)
+         IF( l_useCT )  THEN    ;   sst_m(:,:) = eos_pt_from_ct( tsn(:,:,1,jp_tem), tsn(:,:,1,jp_sal) )
+         ELSE                   ;   sst_m(:,:) = tsn(:,:,1,jp_tem)
+         ENDIF
+         sss_m(:,:) = tsn  (:,:,1,jp_sal)
+         ssh_m(:,:) = sshn (:,:)
+         e3t_m(:,:) = e3t_n(:,:,1)
+         frq_m(:,:) = 1._wp
+         !
+      ENDIF
+      !
+      IF( lwxios.AND.nn_fsbc > 1 ) THEN
+         CALL iom_set_rstw_var_active('nn_fsbc')
+         CALL iom_set_rstw_var_active('ssu_m')
+         CALL iom_set_rstw_var_active('ssv_m')
+         CALL iom_set_rstw_var_active('sst_m')
+         CALL iom_set_rstw_var_active('sss_m')
+         CALL iom_set_rstw_var_active('ssh_m')
+         CALL iom_set_rstw_var_active('e3t_m')
+         CALL iom_set_rstw_var_active('frq_m')
+      ENDIF
+
+   END SUBROUTINE sbc_ssm_init
+
+   !!======================================================================
+END MODULE sbcssm
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/SBC/sbcssr.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/SBC/sbcssr.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/SBC/sbcssr.F90	(revision 9570)
@@ -0,0 +1,225 @@
+MODULE sbcssr
+   !!======================================================================
+   !!                       ***  MODULE  sbcssr  ***
+   !! Surface module :  heat and fresh water fluxes a restoring term toward observed SST/SSS
+   !!======================================================================
+   !! History :  3.0  !  2006-06  (G. Madec)  Original code
+   !!            3.2  !  2009-04  (B. Lemaire)  Introduce iom_put
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   sbc_ssr       : add to sbc a restoring term toward SST/SSS climatology
+   !!   sbc_ssr_init  : initialisation of surface restoring
+   !!----------------------------------------------------------------------
+   USE oce            ! ocean dynamics and tracers
+   USE dom_oce        ! ocean space and time domain
+   USE sbc_oce        ! surface boundary condition
+   USE phycst         ! physical constants
+   USE sbcrnf         ! surface boundary condition : runoffs
+   !
+   USE fldread        ! read input fields
+   USE in_out_manager ! I/O manager
+   USE iom            ! I/O manager
+   USE lib_mpp        ! distribued memory computing library
+   USE lbclnk         ! ocean lateral boundary conditions (or mpp link)
+   USE lib_fortran    ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined)  
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   sbc_ssr        ! routine called in sbcmod
+   PUBLIC   sbc_ssr_init   ! routine called in sbcmod
+
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   erp   !: evaporation damping   [kg/m2/s]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   qrp   !: heat flux damping        [w/m2]
+
+   !                                   !!* Namelist namsbc_ssr *
+   INTEGER, PUBLIC ::   nn_sstr         ! SST/SSS restoring indicator
+   INTEGER, PUBLIC ::   nn_sssr         ! SST/SSS restoring indicator
+   REAL(wp)        ::   rn_dqdt         ! restoring factor on SST and SSS
+   REAL(wp)        ::   rn_deds         ! restoring factor on SST and SSS
+   LOGICAL         ::   ln_sssr_bnd     ! flag to bound erp term 
+   REAL(wp)        ::   rn_sssr_bnd     ! ABS(Max./Min.) value of erp term [mm/day]
+
+   REAL(wp) , ALLOCATABLE, DIMENSION(:) ::   buffer   ! Temporary buffer for exchange
+   TYPE(FLD), ALLOCATABLE, DIMENSION(:) ::   sf_sst   ! structure of input SST (file informations, fields read)
+   TYPE(FLD), ALLOCATABLE, DIMENSION(:) ::   sf_sss   ! structure of input SSS (file informations, fields read)
+
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 4.0 , NEMO Consortium (2011)
+   !! $Id$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE sbc_ssr( kt )
+      !!---------------------------------------------------------------------
+      !!                     ***  ROUTINE sbc_ssr  ***
+      !!
+      !! ** Purpose :   Add to heat and/or freshwater fluxes a damping term
+      !!                toward observed SST and/or SSS.
+      !!
+      !! ** Method  : - Read namelist namsbc_ssr
+      !!              - Read observed SST and/or SSS
+      !!              - at each nscb time step
+      !!                   add a retroaction term on qns    (nn_sstr = 1)
+      !!                   add a damping term on sfx        (nn_sssr = 1)
+      !!                   add a damping term on emp        (nn_sssr = 2)
+      !!---------------------------------------------------------------------
+      INTEGER, INTENT(in   ) ::   kt   ! ocean time step
+      !!
+      INTEGER  ::   ji, jj   ! dummy loop indices
+      REAL(wp) ::   zerp     ! local scalar for evaporation damping
+      REAL(wp) ::   zqrp     ! local scalar for heat flux damping
+      REAL(wp) ::   zsrp     ! local scalar for unit conversion of rn_deds factor
+      REAL(wp) ::   zerp_bnd ! local scalar for unit conversion of rn_epr_max factor
+      INTEGER  ::   ierror   ! return error code
+      !!
+      CHARACTER(len=100) ::  cn_dir          ! Root directory for location of ssr files
+      TYPE(FLD_N) ::   sn_sst, sn_sss        ! informations about the fields to be read
+      !!----------------------------------------------------------------------
+      !
+      IF( nn_sstr + nn_sssr /= 0 ) THEN
+         !
+         IF( nn_sstr == 1)   CALL fld_read( kt, nn_fsbc, sf_sst )   ! Read SST data and provides it at kt
+         IF( nn_sssr >= 1)   CALL fld_read( kt, nn_fsbc, sf_sss )   ! Read SSS data and provides it at kt
+         !
+         !                                         ! ========================= !
+         IF( MOD( kt-1, nn_fsbc ) == 0 ) THEN      !    Add restoring term     !
+            !                                      ! ========================= !
+            !
+            IF( nn_sstr == 1 ) THEN                                   !* Temperature restoring term
+               DO jj = 1, jpj
+                  DO ji = 1, jpi
+                     zqrp = rn_dqdt * ( sst_m(ji,jj) - sf_sst(1)%fnow(ji,jj,1) )
+                     qns(ji,jj) = qns(ji,jj) + zqrp
+                     qrp(ji,jj) = zqrp
+                  END DO
+               END DO
+               CALL iom_put( "qrp", qrp )                             ! heat flux damping
+            ENDIF
+            !
+            IF( nn_sssr == 1 ) THEN                                   !* Salinity damping term (salt flux only (sfx))
+               zsrp = rn_deds / rday                                  ! from [mm/day] to [kg/m2/s]
+               DO jj = 1, jpj
+                  DO ji = 1, jpi
+                     zerp = zsrp * ( 1. - 2.*rnfmsk(ji,jj) )   &      ! No damping in vicinity of river mouths
+                        &        * ( sss_m(ji,jj) - sf_sss(1)%fnow(ji,jj,1) ) 
+                     sfx(ji,jj) = sfx(ji,jj) + zerp                 ! salt flux
+                     erp(ji,jj) = zerp / MAX( sss_m(ji,jj), 1.e-20 ) ! converted into an equivalent volume flux (diagnostic only)
+                  END DO
+               END DO
+               CALL iom_put( "erp", erp )                             ! freshwater flux damping
+               !
+            ELSEIF( nn_sssr == 2 ) THEN                               !* Salinity damping term (volume flux (emp) and associated heat flux (qns)
+               zsrp = rn_deds / rday                                  ! from [mm/day] to [kg/m2/s]
+               zerp_bnd = rn_sssr_bnd / rday                          !       -              -    
+               DO jj = 1, jpj
+                  DO ji = 1, jpi                            
+                     zerp = zsrp * ( 1. - 2.*rnfmsk(ji,jj) )   &      ! No damping in vicinity of river mouths
+                        &        * ( sss_m(ji,jj) - sf_sss(1)%fnow(ji,jj,1) )   &
+                        &        / MAX(  sss_m(ji,jj), 1.e-20   )
+                     IF( ln_sssr_bnd )   zerp = SIGN( 1., zerp ) * MIN( zerp_bnd, ABS(zerp) )
+                     emp(ji,jj) = emp (ji,jj) + zerp
+                     qns(ji,jj) = qns(ji,jj) - zerp * rcp * sst_m(ji,jj)
+                     erp(ji,jj) = zerp
+                  END DO
+               END DO
+               CALL iom_put( "erp", erp )                             ! freshwater flux damping
+            ENDIF
+            !
+         ENDIF
+         !
+      ENDIF
+      !
+   END SUBROUTINE sbc_ssr
+
+ 
+   SUBROUTINE sbc_ssr_init
+      !!---------------------------------------------------------------------
+      !!                  ***  ROUTINE sbc_ssr_init  ***
+      !!
+      !! ** Purpose :   initialisation of surface damping term
+      !!
+      !! ** Method  : - Read namelist namsbc_ssr
+      !!              - Read observed SST and/or SSS if required
+      !!---------------------------------------------------------------------
+      INTEGER  ::   ji, jj   ! dummy loop indices
+      REAL(wp) ::   zerp     ! local scalar for evaporation damping
+      REAL(wp) ::   zqrp     ! local scalar for heat flux damping
+      REAL(wp) ::   zsrp     ! local scalar for unit conversion of rn_deds factor
+      REAL(wp) ::   zerp_bnd ! local scalar for unit conversion of rn_epr_max factor
+      INTEGER  ::   ierror   ! return error code
+      !!
+      CHARACTER(len=100) ::  cn_dir          ! Root directory for location of ssr files
+      TYPE(FLD_N) ::   sn_sst, sn_sss        ! informations about the fields to be read
+      NAMELIST/namsbc_ssr/ cn_dir, nn_sstr, nn_sssr, rn_dqdt, rn_deds, sn_sst, sn_sss, ln_sssr_bnd, rn_sssr_bnd
+      INTEGER     ::  ios
+      !!----------------------------------------------------------------------
+      !
+      IF(lwp) THEN
+         WRITE(numout,*)
+         WRITE(numout,*) 'sbc_ssr : SST and/or SSS damping term '
+         WRITE(numout,*) '~~~~~~~ '
+      ENDIF
+      ! 
+      REWIND( numnam_ref )              ! Namelist namsbc_ssr in reference namelist : 
+      READ  ( numnam_ref, namsbc_ssr, IOSTAT = ios, ERR = 901)
+901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namsbc_ssr in reference namelist', lwp )
+
+      REWIND( numnam_cfg )              ! Namelist namsbc_ssr in configuration namelist :
+      READ  ( numnam_cfg, namsbc_ssr, IOSTAT = ios, ERR = 902 )
+902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namsbc_ssr in configuration namelist', lwp )
+      IF(lwm) WRITE ( numond, namsbc_ssr )
+
+      IF(lwp) THEN                 !* control print
+         WRITE(numout,*) '   Namelist namsbc_ssr :'
+         WRITE(numout,*) '      SST restoring term (Yes=1)             nn_sstr        = ', nn_sstr
+         WRITE(numout,*) '         dQ/dT (restoring magnitude on SST)     rn_dqdt     = ', rn_dqdt, ' W/m2/K'
+         WRITE(numout,*) '      SSS damping term (Yes=1, salt   flux)  nn_sssr        = ', nn_sssr
+         WRITE(numout,*) '                       (Yes=2, volume flux) '
+         WRITE(numout,*) '         dE/dS (restoring magnitude on SST)     rn_deds     = ', rn_deds, ' mm/day'
+         WRITE(numout,*) '         flag to bound erp term                 ln_sssr_bnd = ', ln_sssr_bnd
+         WRITE(numout,*) '         ABS(Max./Min.) erp threshold           rn_sssr_bnd = ', rn_sssr_bnd, ' mm/day'
+      ENDIF
+      !
+      !                            !* Allocate erp and qrp array
+      ALLOCATE( qrp(jpi,jpj), erp(jpi,jpj), STAT=ierror )
+      IF( ierror > 0 )   CALL ctl_stop( 'STOP', 'sbc_ssr: unable to allocate erp and qrp array' )
+      !
+      IF( nn_sstr == 1 ) THEN      !* set sf_sst structure & allocate arrays
+         !
+         ALLOCATE( sf_sst(1), STAT=ierror )
+         IF( ierror > 0 )   CALL ctl_stop( 'STOP', 'sbc_ssr: unable to allocate sf_sst structure' )
+         ALLOCATE( sf_sst(1)%fnow(jpi,jpj,1), STAT=ierror )
+         IF( ierror > 0 )   CALL ctl_stop( 'STOP', 'sbc_ssr: unable to allocate sf_sst now array' )
+         !
+         ! fill sf_sst with sn_sst and control print
+         CALL fld_fill( sf_sst, (/ sn_sst /), cn_dir, 'sbc_ssr', 'SST restoring term toward SST data', 'namsbc_ssr', no_print )
+         IF( sf_sst(1)%ln_tint )   ALLOCATE( sf_sst(1)%fdta(jpi,jpj,1,2), STAT=ierror )
+         IF( ierror > 0 )   CALL ctl_stop( 'STOP', 'sbc_ssr: unable to allocate sf_sst data array' )
+         !
+      ENDIF
+      !
+      IF( nn_sssr >= 1 ) THEN      !* set sf_sss structure & allocate arrays
+         !
+         ALLOCATE( sf_sss(1), STAT=ierror )
+         IF( ierror > 0 )   CALL ctl_stop( 'STOP', 'sbc_ssr: unable to allocate sf_sss structure' )
+         ALLOCATE( sf_sss(1)%fnow(jpi,jpj,1), STAT=ierror )
+         IF( ierror > 0 )   CALL ctl_stop( 'STOP', 'sbc_ssr: unable to allocate sf_sss now array' )
+         !
+         ! fill sf_sss with sn_sss and control print
+         CALL fld_fill( sf_sss, (/ sn_sss /), cn_dir, 'sbc_ssr', 'SSS restoring term toward SSS data', 'namsbc_ssr', no_print )
+         IF( sf_sss(1)%ln_tint )   ALLOCATE( sf_sss(1)%fdta(jpi,jpj,1,2), STAT=ierror )
+         IF( ierror > 0 )   CALL ctl_stop( 'STOP', 'sbc_ssr: unable to allocate sf_sss data array' )
+         !
+      ENDIF
+      !
+      !                            !* Initialize qrp and erp if no restoring 
+      IF( nn_sstr /= 1                   )   qrp(:,:) = 0._wp
+      IF( nn_sssr /= 1 .OR. nn_sssr /= 2 )   erp(:,:) = 0._wp
+      !
+   END SUBROUTINE sbc_ssr_init
+      
+   !!======================================================================
+END MODULE sbcssr
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/SBC/sbctide.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/SBC/sbctide.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/SBC/sbctide.F90	(revision 9570)
@@ -0,0 +1,168 @@
+MODULE sbctide
+   !!======================================================================
+   !!                       ***  MODULE  sbctide  ***
+   !! Initialization of tidal forcing
+   !!======================================================================
+   !! History :  9.0  !  2007  (O. Le Galloudec)  Original code
+   !!----------------------------------------------------------------------
+   USE oce            ! ocean dynamics and tracers variables
+   USE dom_oce        ! ocean space and time domain
+   USE phycst         ! physical constant
+   USE daymod         ! calandar
+   USE tideini        ! 
+   !
+   USE in_out_manager ! I/O units
+   USE iom            ! xIOs server
+   USE ioipsl         ! NetCDF IPSL library
+   USE lbclnk         ! ocean lateral boundary conditions (or mpp link)
+
+   IMPLICIT NONE
+   PUBLIC
+
+   REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) ::   pot_astro   !
+
+   !!----------------------------------------------------------------------
+   !!   tidal potential
+   !!----------------------------------------------------------------------
+   !!   sbc_tide            : 
+   !!   tide_init_potential :
+   !!----------------------------------------------------------------------
+
+   REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) ::   amp_pot, phi_pot
+   REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) ::   amp_load, phi_load
+ 
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.5 , NEMO Consortium (2013)
+   !! $Id$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE sbc_tide( kt )
+      !!----------------------------------------------------------------------
+      !!                 ***  ROUTINE sbc_tide  ***
+      !!----------------------------------------------------------------------      
+      INTEGER, INTENT( in ) ::   kt     ! ocean time-step
+      INTEGER               ::   jk     ! dummy loop index
+      INTEGER               ::   nsec_day_orig     ! Temporary variable
+      !!----------------------------------------------------------------------
+      
+      IF( nsec_day == NINT(0.5_wp * rdt) .OR. kt == nit000 ) THEN      ! start a new day
+         !
+         IF( kt == nit000 )THEN
+            ALLOCATE( amp_pot(jpi,jpj,nb_harmo),                      &
+               &      phi_pot(jpi,jpj,nb_harmo), pot_astro(jpi,jpj)   )
+            IF( ln_read_load )THEN
+               ALLOCATE( amp_load(jpi,jpj,nb_harmo), phi_load(jpi,jpj,nb_harmo) )
+               CALL tide_init_load
+            ENDIF
+         ENDIF
+         !
+         IF( ln_read_load )THEN
+            amp_pot(:,:,:) = amp_load(:,:,:)
+            phi_pot(:,:,:) = phi_load(:,:,:)
+         ELSE 
+            amp_pot(:,:,:) = 0._wp
+            phi_pot(:,:,:) = 0._wp
+         ENDIF
+         pot_astro(:,:) = 0._wp
+         !
+         ! If the run does not start from midnight then need to initialise tides
+         ! at the start of the current day (only occurs when kt==nit000)
+         ! Temporarily set nsec_day to beginning of day.
+         nsec_day_orig = nsec_day
+         IF ( nsec_day /= NINT(0.5_wp * rdt) ) THEN 
+            kt_tide = kt - (nsec_day - 0.5_wp * rdt)/rdt
+            nsec_day = NINT(0.5_wp * rdt)
+         ELSE
+            kt_tide = kt 
+         ENDIF
+         CALL tide_harmo( omega_tide, v0tide, utide, ftide, ntide, nb_harmo )
+         !
+         !
+         IF(lwp) THEN
+            WRITE(numout,*)
+            WRITE(numout,*) 'sbc_tide : Update of the components and (re)Init. the potential at kt=', kt
+            WRITE(numout,*) '~~~~~~~~ '
+            DO jk = 1, nb_harmo
+               WRITE(numout,*) Wave(ntide(jk))%cname_tide, utide(jk), ftide(jk), v0tide(jk), omega_tide(jk)
+            END DO
+         ENDIF
+         !
+         IF( ln_tide_pot )   CALL tide_init_potential
+         !
+         ! Reset nsec_day
+         nsec_day = nsec_day_orig 
+      ENDIF
+      !
+   END SUBROUTINE sbc_tide
+
+
+   SUBROUTINE tide_init_potential
+      !!----------------------------------------------------------------------
+      !!                 ***  ROUTINE tide_init_potential  ***
+      !!----------------------------------------------------------------------
+      INTEGER  ::   ji, jj, jk   ! dummy loop indices
+      REAL(wp) ::   zcons, ztmp1, ztmp2, zlat, zlon, ztmp, zamp, zcs   ! local scalar
+      !!----------------------------------------------------------------------
+
+      DO jk = 1, nb_harmo
+         zcons = 0.7_wp * Wave(ntide(jk))%equitide * ftide(jk)
+         DO ji = 1, jpi
+            DO jj = 1, jpj
+               ztmp1 =  ftide(jk) * amp_pot(ji,jj,jk) * COS( phi_pot(ji,jj,jk) + v0tide(jk) + utide(jk) )
+               ztmp2 = -ftide(jk) * amp_pot(ji,jj,jk) * SIN( phi_pot(ji,jj,jk) + v0tide(jk) + utide(jk) )
+               zlat = gphit(ji,jj)*rad !! latitude en radian
+               zlon = glamt(ji,jj)*rad !! longitude en radian
+               ztmp = v0tide(jk) + utide(jk) + Wave(ntide(jk))%nutide * zlon
+               ! le potentiel est composé des effets des astres:
+               IF    ( Wave(ntide(jk))%nutide == 1 )  THEN  ;  zcs = zcons * SIN( 2._wp*zlat )
+               ELSEIF( Wave(ntide(jk))%nutide == 2 )  THEN  ;  zcs = zcons * COS( zlat )**2
+               ELSE                                         ;  zcs = 0._wp
+               ENDIF
+               ztmp1 = ztmp1 + zcs * COS( ztmp )
+               ztmp2 = ztmp2 - zcs * SIN( ztmp )
+               zamp = SQRT( ztmp1*ztmp1 + ztmp2*ztmp2 )
+               amp_pot(ji,jj,jk) = zamp
+               phi_pot(ji,jj,jk) = ATAN2( -ztmp2 / MAX( 1.e-10_wp , zamp ) ,   &
+                  &                        ztmp1 / MAX( 1.e-10_wp,  zamp )   )
+            END DO
+         END DO
+      END DO
+      !
+   END SUBROUTINE tide_init_potential
+
+   SUBROUTINE tide_init_load
+      !!----------------------------------------------------------------------
+      !!                 ***  ROUTINE tide_init_load  ***
+      !!----------------------------------------------------------------------
+      INTEGER :: inum                 ! Logical unit of input file
+      INTEGER :: ji, jj, itide        ! dummy loop indices
+      REAL(wp), DIMENSION(jpi,jpj) ::   ztr, zti   !: workspace to read in tidal harmonics data 
+      !!----------------------------------------------------------------------
+      IF(lwp) THEN
+         WRITE(numout,*)
+         WRITE(numout,*) 'tide_init_load : Initialization of load potential from file'
+         WRITE(numout,*) '~~~~~~~~~~~~~~ '
+      ENDIF
+      !
+      CALL iom_open ( cn_tide_load , inum )
+      !
+      DO itide = 1, nb_harmo
+         CALL iom_get  ( inum, jpdom_data,TRIM(Wave(ntide(itide))%cname_tide)//'_z1', ztr(:,:) )
+         CALL iom_get  ( inum, jpdom_data,TRIM(Wave(ntide(itide))%cname_tide)//'_z2', zti(:,:) )
+         !
+         DO ji=1,jpi
+            DO jj=1,jpj
+               amp_load(ji,jj,itide) =  SQRT( ztr(ji,jj)**2. + zti(ji,jj)**2. )
+               phi_load(ji,jj,itide) = ATAN2(-zti(ji,jj), ztr(ji,jj) )
+            END DO
+         END DO
+         !
+      END DO
+      CALL iom_close( inum )
+      !
+   END SUBROUTINE tide_init_load
+
+  !!======================================================================
+END MODULE sbctide
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/SBC/sbcwave.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/SBC/sbcwave.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/SBC/sbcwave.F90	(revision 9570)
@@ -0,0 +1,515 @@
+MODULE sbcwave
+   !!======================================================================
+   !!                       ***  MODULE  sbcwave  ***
+   !! Wave module 
+   !!======================================================================
+   !! History :  3.3  !  2011-09  (M. Adani)  Original code: Drag Coefficient 
+   !!         :  3.4  !  2012-10  (M. Adani)  Stokes Drift 
+   !!            3.6  !  2014-09  (E. Clementi,P. Oddo) New Stokes Drift Computation
+   !!             -   !  2016-12  (G. Madec, E. Clementi) update Stoke drift computation
+   !!                                                    + add sbc_wave_ini routine
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   sbc_stokes    : calculate 3D Stokes-drift velocities
+   !!   sbc_wave      : wave data from wave model in netcdf files 
+   !!   sbc_wave_init : initialisation fo surface waves 
+   !!----------------------------------------------------------------------
+   USE phycst         ! physical constants 
+   USE oce            ! ocean variables
+   USE sbc_oce	       ! Surface boundary condition: ocean fields
+   USE zdf_oce,  ONLY : ln_zdfswm
+   USE bdy_oce        ! open boundary condition variables
+   USE domvvl         ! domain: variable volume layers
+   !
+   USE iom            ! I/O manager library
+   USE in_out_manager ! I/O manager
+   USE lib_mpp        ! distribued memory computing library
+   USE fldread	       ! read input fields
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   sbc_stokes      ! routine called in sbccpl
+   PUBLIC   sbc_wstress     ! routine called in sbcmod 
+   PUBLIC   sbc_wave        ! routine called in sbcmod
+   PUBLIC   sbc_wave_init   ! routine called in sbcmod
+   
+   ! Variables checking if the wave parameters are coupled (if not, they are read from file)
+   LOGICAL, PUBLIC ::   cpl_hsig   = .FALSE.
+   LOGICAL, PUBLIC ::   cpl_phioc  = .FALSE.
+   LOGICAL, PUBLIC ::   cpl_sdrftx = .FALSE.
+   LOGICAL, PUBLIC ::   cpl_sdrfty = .FALSE.
+   LOGICAL, PUBLIC ::   cpl_wper   = .FALSE.
+   LOGICAL, PUBLIC ::   cpl_wfreq  = .FALSE.
+   LOGICAL, PUBLIC ::   cpl_wnum   = .FALSE.
+   LOGICAL, PUBLIC ::   cpl_tauwoc = .FALSE.
+   LOGICAL, PUBLIC ::   cpl_tauw   = .FALSE.
+   LOGICAL, PUBLIC ::   cpl_wdrag  = .FALSE.
+
+   INTEGER ::   jpfld    ! number of files to read for stokes drift
+   INTEGER ::   jp_usd   ! index of stokes drift  (i-component) (m/s)    at T-point
+   INTEGER ::   jp_vsd   ! index of stokes drift  (j-component) (m/s)    at T-point
+   INTEGER ::   jp_hsw   ! index of significant wave hight      (m)      at T-point
+   INTEGER ::   jp_wmp   ! index of mean wave period            (s)      at T-point
+   INTEGER ::   jp_wfr   ! index of wave peak frequency         (1/s)    at T-point
+
+   TYPE(FLD), ALLOCATABLE, DIMENSION(:) ::   sf_cd      ! structure of input fields (file informations, fields read) Drag Coefficient
+   TYPE(FLD), ALLOCATABLE, DIMENSION(:) ::   sf_sd      ! structure of input fields (file informations, fields read) Stokes Drift
+   TYPE(FLD), ALLOCATABLE, DIMENSION(:) ::   sf_wn      ! structure of input fields (file informations, fields read) wave number for Qiao
+   TYPE(FLD), ALLOCATABLE, DIMENSION(:) ::   sf_tauwoc  ! structure of input fields (file informations, fields read) normalized wave stress into the ocean
+   TYPE(FLD), ALLOCATABLE, DIMENSION(:) ::   sf_tauw    ! structure of input fields (file informations, fields read) ocean stress components from wave model
+
+   REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:)   ::   cdn_wave            !:
+   REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:)   ::   hsw, wmp, wnum      !: 
+   REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:)   ::   wfreq               !: 
+   REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:)   ::   tauoc_wave          !:  
+   REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:)   ::   tauw_x, tauw_y      !:  
+   REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:)   ::   tsd2d               !: 
+   REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:)   ::   div_sd              !: barotropic stokes drift divergence
+   REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:)   ::   ut0sd, vt0sd        !: surface Stokes drift velocities at t-point
+   REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:) ::   usd  , vsd  , wsd   !: Stokes drift velocities at u-, v- & w-points, resp.
+
+   !! * Substitutions
+#  include "vectopt_loop_substitute.h90"
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.7 , NEMO Consortium (2014) 
+   !! $Id$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE sbc_stokes( )
+      !!---------------------------------------------------------------------
+      !!                     ***  ROUTINE sbc_stokes  ***
+      !!
+      !! ** Purpose :   compute the 3d Stokes Drift according to Breivik et al.,
+      !!                2014 (DOI: 10.1175/JPO-D-14-0020.1)
+      !!
+      !! ** Method  : - Calculate Stokes transport speed 
+      !!              - Calculate horizontal divergence 
+      !!              - Integrate the horizontal divergenze from the bottom 
+      !! ** action  
+      !!---------------------------------------------------------------------
+      INTEGER  ::   jj, ji, jk   ! dummy loop argument
+      INTEGER  ::   ik           ! local integer 
+      REAL(wp) ::  ztransp, zfac, zsp0
+      REAL(wp) ::  zdepth, zsqrt_depth,  zexp_depth, z_two_thirds, zsqrtpi !sqrt of pi
+      REAL(wp) ::  zbot_u, zbot_v, zkb_u, zkb_v, zke3_u, zke3_v, zda_u, zda_v
+      REAL(wp) ::  zstokes_psi_u_bot, zstokes_psi_v_bot
+      REAL(wp) ::  zdep_u, zdep_v, zkh_u, zkh_v
+      REAL(wp), DIMENSION(:,:)  , ALLOCATABLE ::   zk_t, zk_u, zk_v, zu0_sd, zv0_sd     ! 2D workspace
+      REAL(wp), DIMENSION(:,:)  , ALLOCATABLE ::   zstokes_psi_u_top, zstokes_psi_v_top ! 2D workspace
+      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::   ze3divh                              ! 3D workspace
+      !!---------------------------------------------------------------------
+      !
+      ALLOCATE( ze3divh(jpi,jpj,jpk) )
+      ALLOCATE( zk_t(jpi,jpj), zk_u(jpi,jpj), zk_v(jpi,jpj), zu0_sd(jpi,jpj), zv0_sd(jpi,jpj) )
+      !
+      ! select parameterization for the calculation of vertical Stokes drift
+      ! exp. wave number at t-point
+      IF( ll_st_bv_li ) THEN   ! (Eq. (19) in Breivik et al. (2014) )
+         zfac = 2.0_wp * rpi / 16.0_wp
+         DO jj = 1, jpj
+            DO ji = 1, jpi
+               ! Stokes drift velocity estimated from Hs and Tmean
+               ztransp = zfac * hsw(ji,jj)*hsw(ji,jj) / MAX( wmp(ji,jj), 0.0000001_wp )
+               ! Stokes surface speed
+               tsd2d(ji,jj) = SQRT( ut0sd(ji,jj)*ut0sd(ji,jj) + vt0sd(ji,jj)*vt0sd(ji,jj))
+               ! Wavenumber scale
+               zk_t(ji,jj) = ABS( tsd2d(ji,jj) ) / MAX( ABS( 5.97_wp*ztransp ), 0.0000001_wp )
+            END DO
+         END DO
+         DO jj = 1, jpjm1              ! exp. wave number & Stokes drift velocity at u- & v-points
+            DO ji = 1, jpim1
+               zk_u(ji,jj) = 0.5_wp * ( zk_t(ji,jj) + zk_t(ji+1,jj) )
+               zk_v(ji,jj) = 0.5_wp * ( zk_t(ji,jj) + zk_t(ji,jj+1) )
+               !
+               zu0_sd(ji,jj) = 0.5_wp * ( ut0sd(ji,jj) + ut0sd(ji+1,jj) )
+               zv0_sd(ji,jj) = 0.5_wp * ( vt0sd(ji,jj) + vt0sd(ji,jj+1) )
+            END DO
+         END DO
+      ELSE IF( ll_st_peakfr ) THEN    ! peak wave number calculated from the peak frequency received by the wave model
+         DO jj = 1, jpjm1
+            DO ji = 1, jpim1
+               zk_u(ji,jj) = 0.5_wp * ( wfreq(ji,jj)*wfreq(ji,jj) + wfreq(ji+1,jj)*wfreq(ji+1,jj) ) / grav
+               zk_v(ji,jj) = 0.5_wp * ( wfreq(ji,jj)*wfreq(ji,jj) + wfreq(ji,jj+1)*wfreq(ji,jj+1) ) / grav
+               !
+               zu0_sd(ji,jj) = 0.5_wp * ( ut0sd(ji,jj) + ut0sd(ji+1,jj) )
+               zv0_sd(ji,jj) = 0.5_wp * ( vt0sd(ji,jj) + vt0sd(ji,jj+1) )
+            END DO
+         END DO
+      ENDIF
+      !
+      !                       !==  horizontal Stokes Drift 3D velocity  ==!
+      IF( ll_st_bv2014 ) THEN
+         DO jk = 1, jpkm1
+            DO jj = 2, jpjm1
+               DO ji = 2, jpim1
+                  zdep_u = 0.5_wp * ( gdept_n(ji,jj,jk) + gdept_n(ji+1,jj,jk) )
+                  zdep_v = 0.5_wp * ( gdept_n(ji,jj,jk) + gdept_n(ji,jj+1,jk) )
+                  !                          
+                  zkh_u = zk_u(ji,jj) * zdep_u     ! k * depth
+                  zkh_v = zk_v(ji,jj) * zdep_v
+                  !                                ! Depth attenuation
+                  zda_u = EXP( -2.0_wp*zkh_u ) / ( 1.0_wp + 8.0_wp*zkh_u )
+                  zda_v = EXP( -2.0_wp*zkh_v ) / ( 1.0_wp + 8.0_wp*zkh_v )
+                  !
+                  usd(ji,jj,jk) = zda_u * zu0_sd(ji,jj) * umask(ji,jj,jk)
+                  vsd(ji,jj,jk) = zda_v * zv0_sd(ji,jj) * vmask(ji,jj,jk)
+               END DO
+            END DO
+         END DO
+      ELSE IF( ll_st_li2017 .OR. ll_st_peakfr ) THEN
+         ALLOCATE( zstokes_psi_u_top(jpi,jpj), zstokes_psi_v_top(jpi,jpj) )
+         DO jj = 1, jpjm1              ! exp. wave number & Stokes drift velocity at u- & v-points
+            DO ji = 1, jpim1
+               zstokes_psi_u_top(ji,jj) = 0._wp
+               zstokes_psi_v_top(ji,jj) = 0._wp
+            END DO
+         END DO
+         zsqrtpi = SQRT(rpi)
+         z_two_thirds = 2.0_wp / 3.0_wp
+         DO jk = 1, jpkm1
+            DO jj = 2, jpjm1
+               DO ji = 2, jpim1
+                  zbot_u = ( gdepw_n(ji,jj,jk+1) + gdepw_n(ji+1,jj,jk+1) )  ! 2 * bottom depth
+                  zbot_v = ( gdepw_n(ji,jj,jk+1) + gdepw_n(ji,jj+1,jk+1) )  ! 2 * bottom depth
+                  zkb_u  = zk_u(ji,jj) * zbot_u                             ! 2 * k * bottom depth
+                  zkb_v  = zk_v(ji,jj) * zbot_v                             ! 2 * k * bottom depth
+                  !
+                  zke3_u = MAX(1.e-8_wp, 2.0_wp * zk_u(ji,jj) * e3u_n(ji,jj,jk))     ! 2k * thickness
+                  zke3_v = MAX(1.e-8_wp, 2.0_wp * zk_v(ji,jj) * e3v_n(ji,jj,jk))     ! 2k * thickness
+
+                  ! Depth attenuation .... do u component first..
+                  zdepth      = zkb_u
+                  zsqrt_depth = SQRT(zdepth)
+                  zexp_depth  = EXP(-zdepth)
+                  zstokes_psi_u_bot = 1.0_wp - zexp_depth  &
+                       &              - z_two_thirds * ( zsqrtpi*zsqrt_depth*zdepth*ERFC(zsqrt_depth) &
+                       &              + 1.0_wp - (1.0_wp + zdepth)*zexp_depth )
+                  zda_u                    = ( zstokes_psi_u_bot - zstokes_psi_u_top(ji,jj) ) / zke3_u
+                  zstokes_psi_u_top(ji,jj) =   zstokes_psi_u_bot
+
+                  !         ... and then v component
+                  zdepth      =zkb_v
+                  zsqrt_depth = SQRT(zdepth)
+                  zexp_depth  = EXP(-zdepth)
+                  zstokes_psi_v_bot = 1.0_wp - zexp_depth  &
+                       &              - z_two_thirds * ( zsqrtpi*zsqrt_depth*zdepth*ERFC(zsqrt_depth) &
+                       &              + 1.0_wp - (1.0_wp + zdepth)*zexp_depth )
+                  zda_v                    = ( zstokes_psi_v_bot - zstokes_psi_v_top(ji,jj) ) / zke3_v
+                  zstokes_psi_v_top(ji,jj) =   zstokes_psi_v_bot
+                  !
+                  usd(ji,jj,jk) = zda_u * zu0_sd(ji,jj) * umask(ji,jj,jk)
+                  vsd(ji,jj,jk) = zda_v * zv0_sd(ji,jj) * vmask(ji,jj,jk)
+               END DO
+            END DO
+         END DO
+         DEALLOCATE( zstokes_psi_u_top, zstokes_psi_v_top )
+      ENDIF
+
+      CALL lbc_lnk_multi( usd, 'U', -1., vsd, 'V', -1. )
+
+      !
+      !                       !==  vertical Stokes Drift 3D velocity  ==!
+      !
+      DO jk = 1, jpkm1               ! Horizontal e3*divergence
+         DO jj = 2, jpj
+            DO ji = fs_2, jpi
+               ze3divh(ji,jj,jk) = (  e2u(ji  ,jj) * e3u_n(ji  ,jj,jk) * usd(ji  ,jj,jk)    &
+                  &                 - e2u(ji-1,jj) * e3u_n(ji-1,jj,jk) * usd(ji-1,jj,jk)    &
+                  &                 + e1v(ji,jj  ) * e3v_n(ji,jj  ,jk) * vsd(ji,jj  ,jk)    &
+                  &                 - e1v(ji,jj-1) * e3v_n(ji,jj-1,jk) * vsd(ji,jj-1,jk)  ) * r1_e1e2t(ji,jj)
+            END DO
+         END DO
+      END DO
+      !
+#if defined key_agrif
+      IF( .NOT. Agrif_Root() ) THEN
+         IF( nbondi == -1 .OR. nbondi == 2 )   ze3divh( 2:nbghostcells+1,:        ,:) = 0._wp      ! west
+         IF( nbondi ==  1 .OR. nbondi == 2 )   ze3divh( nlci-nbghostcells:nlci-1,:,:) = 0._wp      ! east
+         IF( nbondj == -1 .OR. nbondj == 2 )   ze3divh( :,2:nbghostcells+1        ,:) = 0._wp      ! south
+         IF( nbondj ==  1 .OR. nbondj == 2 )   ze3divh( :,nlcj-nbghostcells:nlcj-1,:) = 0._wp      ! north
+      ENDIF
+#endif
+      !
+      CALL lbc_lnk( ze3divh, 'T', 1. )
+      !
+      IF( ln_linssh ) THEN   ;   ik = 1   ! none zero velocity through the sea surface
+      ELSE                   ;   ik = 2   ! w=0 at the surface (set one for all in sbc_wave_init)
+      ENDIF
+      DO jk = jpkm1, ik, -1          ! integrate from the bottom the hor. divergence (NB: at k=jpk w is always zero)
+         wsd(:,:,jk) = wsd(:,:,jk+1) - ze3divh(:,:,jk)
+      END DO
+      !
+      IF( ln_bdy ) THEN
+         DO jk = 1, jpkm1
+            wsd(:,:,jk) = wsd(:,:,jk) * bdytmask(:,:)
+         END DO
+      ENDIF
+      !                       !==  Horizontal divergence of barotropic Stokes transport  ==!
+      div_sd(:,:) = 0._wp
+      DO jk = 1, jpkm1                                 ! 
+        div_sd(:,:) = div_sd(:,:) + ze3divh(:,:,jk)
+      END DO
+      !
+      CALL iom_put( "ustokes",  usd  )
+      CALL iom_put( "vstokes",  vsd  )
+      CALL iom_put( "wstokes",  wsd  )
+      !
+      DEALLOCATE( ze3divh )
+      DEALLOCATE( zk_t, zk_u, zk_v, zu0_sd, zv0_sd )
+      !
+   END SUBROUTINE sbc_stokes
+
+
+   SUBROUTINE sbc_wstress( )
+      !!---------------------------------------------------------------------
+      !!                     ***  ROUTINE sbc_wstress  ***
+      !!
+      !! ** Purpose :   Updates the ocean momentum modified by waves
+      !!
+      !! ** Method  : - Calculate u,v components of stress depending on stress
+      !!                model 
+      !!              - Calculate the stress module
+      !!              - The wind module is not modified by waves 
+      !! ** action  
+      !!---------------------------------------------------------------------
+      INTEGER  ::   jj, ji   ! dummy loop argument
+      !
+      IF( ln_tauwoc ) THEN
+         utau(:,:) = utau(:,:)*tauoc_wave(:,:)
+         vtau(:,:) = vtau(:,:)*tauoc_wave(:,:)
+         taum(:,:) = taum(:,:)*tauoc_wave(:,:)
+      ENDIF
+      !
+      IF( ln_tauw ) THEN
+         DO jj = 1, jpjm1
+            DO ji = 1, jpim1
+               ! Stress components at u- & v-points
+               utau(ji,jj) = 0.5_wp * ( tauw_x(ji,jj) + tauw_x(ji+1,jj) )
+               vtau(ji,jj) = 0.5_wp * ( tauw_y(ji,jj) + tauw_y(ji,jj+1) )
+               !
+               ! Stress module at t points
+               taum(ji,jj) = SQRT( tauw_x(ji,jj)*tauw_x(ji,jj) + tauw_y(ji,jj)*tauw_y(ji,jj) )
+            END DO
+         END DO
+         CALL lbc_lnk_multi( utau(:,:), 'U', -1. , vtau(:,:), 'V', -1. , taum(:,:) , 'T', -1. )
+      ENDIF
+      !
+   END SUBROUTINE sbc_wstress
+
+
+   SUBROUTINE sbc_wave( kt )
+      !!---------------------------------------------------------------------
+      !!                     ***  ROUTINE sbc_wave  ***
+      !!
+      !! ** Purpose :   read wave parameters from wave model  in netcdf files.
+      !!
+      !! ** Method  : - Read namelist namsbc_wave
+      !!              - Read Cd_n10 fields in netcdf files 
+      !!              - Read stokes drift 2d in netcdf files 
+      !!              - Read wave number in netcdf files 
+      !!              - Compute 3d stokes drift using Breivik et al.,2014
+      !!                formulation
+      !! ** action  
+      !!---------------------------------------------------------------------
+      INTEGER, INTENT(in   ) ::   kt   ! ocean time step
+      !!---------------------------------------------------------------------
+      !
+      IF( ln_cdgw .AND. .NOT. cpl_wdrag ) THEN     !==  Neutral drag coefficient  ==!
+         CALL fld_read( kt, nn_fsbc, sf_cd )             ! read from external forcing
+         cdn_wave(:,:) = sf_cd(1)%fnow(:,:,1)
+      ENDIF
+
+      IF( ln_tauwoc .AND. .NOT. cpl_tauwoc ) THEN  !==  Wave induced stress  ==!
+         CALL fld_read( kt, nn_fsbc, sf_tauwoc )         ! read wave norm stress from external forcing
+         tauoc_wave(:,:) = sf_tauwoc(1)%fnow(:,:,1)
+      ENDIF
+
+      IF( ln_tauw .AND. .NOT. cpl_tauw ) THEN      !==  Wave induced stress  ==!
+         CALL fld_read( kt, nn_fsbc, sf_tauw )           ! read ocean stress components from external forcing (T grid)
+         tauw_x(:,:) = sf_tauw(1)%fnow(:,:,1)
+         tauw_y(:,:) = sf_tauw(2)%fnow(:,:,1)
+      ENDIF
+
+      IF( ln_sdw )  THEN                           !==  Computation of the 3d Stokes Drift  ==! 
+         !
+         IF( jpfld > 0 ) THEN                            ! Read from file only if the field is not coupled
+            CALL fld_read( kt, nn_fsbc, sf_sd )          ! read wave parameters from external forcing
+            IF( jp_hsw > 0 )   hsw  (:,:) = sf_sd(jp_hsw)%fnow(:,:,1)   ! significant wave height
+            IF( jp_wmp > 0 )   wmp  (:,:) = sf_sd(jp_wmp)%fnow(:,:,1)   ! wave mean period
+            IF( jp_wfr > 0 )   wfreq(:,:) = sf_sd(jp_wfr)%fnow(:,:,1)   ! Peak wave frequency
+            IF( jp_usd > 0 )   ut0sd(:,:) = sf_sd(jp_usd)%fnow(:,:,1)   ! 2D zonal Stokes Drift at T point
+            IF( jp_vsd > 0 )   vt0sd(:,:) = sf_sd(jp_vsd)%fnow(:,:,1)   ! 2D meridional Stokes Drift at T point
+         ENDIF
+         !
+         ! Read also wave number if needed, so that it is available in coupling routines
+         IF( ln_zdfswm .AND. .NOT.cpl_wnum ) THEN
+            CALL fld_read( kt, nn_fsbc, sf_wn )          ! read wave parameters from external forcing
+            wnum(:,:) = sf_wn(1)%fnow(:,:,1)
+         ENDIF
+           
+         ! Calculate only if required fields have been read
+         ! In coupled wave model-NEMO case the call is done after coupling
+         !
+         IF( ( ll_st_bv_li   .AND. jp_hsw>0 .AND. jp_wmp>0 .AND. jp_usd>0 .AND. jp_vsd>0 ) .OR. &
+           & ( ll_st_peakfr  .AND. jp_wfr>0 .AND. jp_usd>0 .AND. jp_vsd>0                ) ) CALL sbc_stokes()
+         !
+      ENDIF
+      !
+   END SUBROUTINE sbc_wave
+
+
+   SUBROUTINE sbc_wave_init
+      !!---------------------------------------------------------------------
+      !!                     ***  ROUTINE sbc_wave_init  ***
+      !!
+      !! ** Purpose :   read wave parameters from wave model  in netcdf files.
+      !!
+      !! ** Method  : - Read namelist namsbc_wave
+      !!              - Read Cd_n10 fields in netcdf files 
+      !!              - Read stokes drift 2d in netcdf files 
+      !!              - Read wave number in netcdf files 
+      !!              - Compute 3d stokes drift using Breivik et al.,2014
+      !!                formulation
+      !! ** action  
+      !!---------------------------------------------------------------------
+      INTEGER ::   ierror, ios   ! local integer
+      INTEGER ::   ifpr
+      !!
+      CHARACTER(len=100)     ::  cn_dir                            ! Root directory for location of drag coefficient files
+      TYPE(FLD_N), ALLOCATABLE, DIMENSION(:) ::   slf_i, slf_j     ! array of namelist informations on the fields to read
+      TYPE(FLD_N)            ::  sn_cdg, sn_usd, sn_vsd,  &
+                             &   sn_hsw, sn_wmp, sn_wfr, sn_wnum, &
+                             &   sn_tauwoc, sn_tauwx, sn_tauwy     ! informations about the fields to be read
+      !
+      NAMELIST/namsbc_wave/  sn_cdg, cn_dir, sn_usd, sn_vsd, sn_hsw, sn_wmp, sn_wfr, &
+                             sn_wnum, sn_tauwoc, sn_tauwx, sn_tauwy
+      !!---------------------------------------------------------------------
+      !
+      REWIND( numnam_ref )              ! Namelist namsbc_wave in reference namelist : File for drag coeff. from wave model
+      READ  ( numnam_ref, namsbc_wave, IOSTAT = ios, ERR = 901)
+901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namsbc_wave in reference namelist', lwp )
+         
+      REWIND( numnam_cfg )              ! Namelist namsbc_wave in configuration namelist : File for drag coeff. from wave model
+      READ  ( numnam_cfg, namsbc_wave, IOSTAT = ios, ERR = 902 )
+902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namsbc_wave in configuration namelist', lwp )
+      IF(lwm) WRITE ( numond, namsbc_wave )
+      !
+      IF( ln_cdgw ) THEN
+         IF( .NOT. cpl_wdrag ) THEN
+            ALLOCATE( sf_cd(1), STAT=ierror )               !* allocate and fill sf_wave with sn_cdg
+            IF( ierror > 0 )   CALL ctl_stop( 'STOP', 'sbc_wave_init: unable to allocate sf_wave structure' )
+            !
+                                   ALLOCATE( sf_cd(1)%fnow(jpi,jpj,1)   )
+            IF( sn_cdg%ln_tint )   ALLOCATE( sf_cd(1)%fdta(jpi,jpj,1,2) )
+            CALL fld_fill( sf_cd, (/ sn_cdg /), cn_dir, 'sbc_wave_init', 'Wave module ', 'namsbc_wave' )
+         ENDIF
+         ALLOCATE( cdn_wave(jpi,jpj) )
+      ENDIF
+
+      IF( ln_tauwoc ) THEN
+         IF( .NOT. cpl_tauwoc ) THEN
+            ALLOCATE( sf_tauwoc(1), STAT=ierror )           !* allocate and fill sf_wave with sn_tauwoc
+            IF( ierror > 0 )   CALL ctl_stop( 'STOP', 'sbc_wave_init: unable to allocate sf_wave structure' )
+            !
+                                     ALLOCATE( sf_tauwoc(1)%fnow(jpi,jpj,1)   )
+            IF( sn_tauwoc%ln_tint )  ALLOCATE( sf_tauwoc(1)%fdta(jpi,jpj,1,2) )
+            CALL fld_fill( sf_tauwoc, (/ sn_tauwoc /), cn_dir, 'sbc_wave_init', 'Wave module', 'namsbc_wave' )
+         ENDIF
+         ALLOCATE( tauoc_wave(jpi,jpj) )
+      ENDIF
+
+      IF( ln_tauw ) THEN
+         IF( .NOT. cpl_tauw ) THEN
+            ALLOCATE( sf_tauw(2), STAT=ierror )           !* allocate and fill sf_wave with sn_tauwx/y
+            IF( ierror > 0 )   CALL ctl_stop( 'STOP', 'sbc_wave_init: unable to allocate sf_tauw structure' )
+            !
+            ALLOCATE( slf_j(2) )
+            slf_j(1) = sn_tauwx
+            slf_j(2) = sn_tauwy
+                                    ALLOCATE( sf_tauw(1)%fnow(jpi,jpj,1)   )
+                                    ALLOCATE( sf_tauw(2)%fnow(jpi,jpj,1)   )
+            IF( slf_j(1)%ln_tint )  ALLOCATE( sf_tauw(1)%fdta(jpi,jpj,1,2) )
+            IF( slf_j(2)%ln_tint )  ALLOCATE( sf_tauw(2)%fdta(jpi,jpj,1,2) )
+            CALL fld_fill( sf_tauw, (/ slf_j /), cn_dir, 'sbc_wave_init', 'read wave input', 'namsbc_wave' )
+         ENDIF
+         ALLOCATE( tauw_x(jpi,jpj) )
+         ALLOCATE( tauw_y(jpi,jpj) )
+      ENDIF
+
+      IF( ln_sdw ) THEN   ! Find out how many fields have to be read from file if not coupled
+         jpfld=0
+         jp_usd=0   ;   jp_vsd=0   ;   jp_hsw=0   ;   jp_wmp=0   ;   jp_wfr=0
+         IF( .NOT. cpl_sdrftx ) THEN
+            jpfld  = jpfld + 1
+            jp_usd = jpfld
+         ENDIF
+         IF( .NOT. cpl_sdrfty ) THEN
+            jpfld  = jpfld + 1
+            jp_vsd = jpfld
+         ENDIF
+         IF( .NOT. cpl_hsig  .AND. ll_st_bv_li  ) THEN
+            jpfld  = jpfld + 1
+            jp_hsw = jpfld
+         ENDIF
+         IF( .NOT. cpl_wper  .AND. ll_st_bv_li  ) THEN
+            jpfld  = jpfld + 1
+            jp_wmp = jpfld
+         ENDIF
+         IF( .NOT. cpl_wfreq .AND. ll_st_peakfr ) THEN
+            jpfld  = jpfld + 1
+            jp_wfr = jpfld
+         ENDIF
+
+         ! Read from file only the non-coupled fields 
+         IF( jpfld > 0 ) THEN
+            ALLOCATE( slf_i(jpfld) )
+            IF( jp_usd > 0 )   slf_i(jp_usd) = sn_usd
+            IF( jp_vsd > 0 )   slf_i(jp_vsd) = sn_vsd
+            IF( jp_hsw > 0 )   slf_i(jp_hsw) = sn_hsw
+            IF( jp_wmp > 0 )   slf_i(jp_wmp) = sn_wmp
+            IF( jp_wfr > 0 )   slf_i(jp_wfr) = sn_wfr
+
+            ALLOCATE( sf_sd(jpfld), STAT=ierror )   !* allocate and fill sf_sd with stokes drift
+            IF( ierror > 0 )   CALL ctl_stop( 'STOP', 'sbc_wave_init: unable to allocate sf_wave structure' )
+            !
+            DO ifpr= 1, jpfld
+               ALLOCATE( sf_sd(ifpr)%fnow(jpi,jpj,1) )
+               IF( slf_i(ifpr)%ln_tint )   ALLOCATE( sf_sd(ifpr)%fdta(jpi,jpj,1,2) )
+            END DO
+            !
+            CALL fld_fill( sf_sd, slf_i, cn_dir, 'sbc_wave_init', 'Wave module ', 'namsbc_wave' )
+         ENDIF
+         ALLOCATE( usd  (jpi,jpj,jpk), vsd  (jpi,jpj,jpk), wsd(jpi,jpj,jpk) )
+         ALLOCATE( hsw  (jpi,jpj)    , wmp  (jpi,jpj)     )
+         ALLOCATE( wfreq(jpi,jpj) )
+         ALLOCATE( ut0sd(jpi,jpj)    , vt0sd(jpi,jpj)     )
+         ALLOCATE( div_sd(jpi,jpj) )
+         ALLOCATE( tsd2d (jpi,jpj) )
+
+         ut0sd(:,:) = 0._wp
+         vt0sd(:,:) = 0._wp
+         hsw(:,:) = 0._wp
+         wmp(:,:) = 0._wp
+
+         usd(:,:,:) = 0._wp
+         vsd(:,:,:) = 0._wp
+         wsd(:,:,:) = 0._wp
+         ! Wave number needed only if ln_zdfswm=T
+         IF( .NOT. cpl_wnum ) THEN
+            ALLOCATE( sf_wn(1), STAT=ierror )           !* allocate and fill sf_wave with sn_wnum
+            IF( ierror > 0 )   CALL ctl_stop( 'STOP', 'sbc_wave_init: unable toallocate sf_wave structure' )
+                                   ALLOCATE( sf_wn(1)%fnow(jpi,jpj,1)   )
+            IF( sn_wnum%ln_tint )  ALLOCATE( sf_wn(1)%fdta(jpi,jpj,1,2) )
+            CALL fld_fill( sf_wn, (/ sn_wnum /), cn_dir, 'sbc_wave', 'Wave module', 'namsbc_wave' )
+         ENDIF
+         ALLOCATE( wnum(jpi,jpj) )
+      ENDIF
+      !
+   END SUBROUTINE sbc_wave_init
+
+   !!======================================================================
+END MODULE sbcwave
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/SBC/tide.h90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/SBC/tide.h90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/SBC/tide.h90	(revision 9570)
@@ -0,0 +1,29 @@
+   !!----------------------------------------------------------------------
+   !! History :  3.2  !  2007  (O. Le Galloudec)  Original code
+   !!----------------------------------------------------------------------
+
+   !             !! name_tide , equitide , nutide , nt , ns , nh , np , np1 , shift , nksi , nnu0 , nnu1 , nnu2 , R , formula !!
+   !             !!           !          !        !    !    !    !    !     !       !      !      !      !      !   !         !!
+   Wave( 1) = tide(  'M2'     , 0.242297 ,    2   ,  2 , -2 ,  2 ,  0 ,  0  ,    0  ,  2   , -2   ,  0   ,  0   , 0 ,    78   )
+   Wave( 2) = tide(  'N2'     , 0.046313 ,    2   ,  2 , -3 ,  2 ,  1 ,  0  ,    0  ,  2   , -2   ,  0   ,  0   , 0 ,    78   )
+   Wave( 3) = tide( '2N2'     , 0.006184 ,    2   ,  2 , -4 ,  2 ,  2 ,  0  ,    0  ,  2   , -2   ,  0   ,  0   , 0 ,    78   )
+   Wave( 4) = tide(  'S2'     , 0.113572 ,    2   ,  2 ,  0 ,  0 ,  0 ,  0  ,    0  ,  0   ,  0   ,  0   ,  0   , 0 ,     0   )
+   Wave( 5) = tide(  'K2'     , 0.030875 ,    2   ,  2 ,  0 ,  2 ,  0 ,  0  ,    0  ,  0   ,  0   ,  0   , -2   , 0 ,   235   )
+   !              !           !          !        !    !    !    !    !     !       !      !      !      !      !   !         !
+   Wave( 6) = tide(  'K1'     , 0.142408 ,    1   ,  1 ,  0 ,  1 ,  0 ,  0  ,  -90  ,  0   ,  0   , -1   ,  0   , 0 ,   227   )
+   Wave( 7) = tide(  'O1'     , 0.101266 ,    1   ,  1 , -2 ,  1 ,  0 ,  0  ,  +90  ,  2   , -1   ,  0   ,  0   , 0 ,    75   )
+   Wave( 8) = tide(  'Q1'     , 0.019387 ,    1   ,  1 , -3 ,  1 ,  1 ,  0  ,  +90  ,  2   , -1   ,  0   ,  0   , 0 ,    75   )
+   Wave( 9) = tide(  'P1'     , 0.047129 ,    1   ,  1 ,  0 , -1 ,  0 ,  0  ,  +90  ,  0   ,  0   ,  0   ,  0   , 0 ,    0    )
+   !              !           !          !        !    !    !    !    !     !       !      !      !      !      !   !         !
+   Wave(10) = tide(  'M4'     , 0.000000 ,    4   ,  4 , -4 ,  4 ,  0 ,  0  ,    0  ,  4   , -4   ,  0   ,  0   , 0 ,    1    )
+   !              !           !          !        !    !    !    !    !     !       !      !      !      !      !   !         !
+   Wave(11) = tide(  'Mf'     , 0.042017 ,    0   ,  0 ,  2 ,  0 ,  0 ,  0  ,    0  , -2   ,  0   ,  0   ,  0   , 0 ,   74    )
+   Wave(12) = tide(  'Mm'     , 0.022191 ,    0   ,  0 ,  1 ,  0 , -1 ,  0  ,    0  ,  0   ,  0   ,  0   ,  0   , 0 ,   73    )
+   Wave(13) = tide(  'Msqm'   , 0.000667 ,    0   ,  0 ,  4 , -2 ,  0 ,  0  ,    0  , -2   ,  0   ,  0   ,  0   , 0 ,   74    )
+   Wave(14) = tide(  'Mtm'    , 0.008049 ,    0   ,  0 ,  3 ,  0 , -1 ,  0  ,    0  , -2   ,  0   ,  0   ,  0   , 0 ,   74    )
+   !              !           !          !        !    !    !    !    !     !       !      !      !      !      !   !         !
+   Wave(15) = tide(  'S1'     , 0.000000 ,    1   ,  1 ,  0 ,  0 ,  0 ,  0  ,    0  ,  0   ,  0   ,  0   ,  0   , 0 ,    0    )   
+   Wave(16) = tide(  'MU2'    , 0.005841 ,    2   ,  2 , -4 ,  4 ,  0 ,  0  ,    0  ,  2   , -2   ,  0   ,  0   , 0 ,   78    )
+   Wave(17) = tide(  'NU2'    , 0.009094 ,    2   ,  2 , -3 ,  4 , -1 ,  0  ,    0  ,  2   , -2   ,  0   ,  0   , 0 ,   78    ) 
+   Wave(18) = tide(  'L2'     , 0.006694 ,    2   ,  2 , -1 ,  2 , -1 ,  0  , +180  ,  2   , -2   ,  0   ,  0   , 0 ,  215    )
+   Wave(19) = tide(  'T2'     , 0.006614 ,    2   ,  2 ,  0 , -1 ,  0 ,  1  ,    0  ,  0   ,  0   ,  0   ,  0   , 0 ,    0    )
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/SBC/tide_mod.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/SBC/tide_mod.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/SBC/tide_mod.F90	(revision 9570)
@@ -0,0 +1,411 @@
+MODULE tide_mod
+   !!======================================================================
+   !!                       ***  MODULE  tide_mod  ***
+   !! Compute nodal modulations corrections and pulsations
+   !!======================================================================
+   !! History :  1.0  !  2007  (O. Le Galloudec)  Original code
+   !!----------------------------------------------------------------------
+   USE dom_oce        ! ocean space and time domain
+   USE phycst         ! physical constant
+   USE daymod         ! calendar
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   tide_harmo       ! called by tideini and diaharm modules
+   PUBLIC   tide_init_Wave   ! called by tideini and diaharm modules
+
+   INTEGER, PUBLIC, PARAMETER ::   jpmax_harmo = 19   !: maximum number of harmonic
+
+   TYPE, PUBLIC ::    tide
+      CHARACTER(LEN=4) ::   cname_tide
+      REAL(wp)         ::   equitide
+      INTEGER          ::   nutide
+      INTEGER          ::   nt, ns, nh, np, np1, shift
+      INTEGER          ::   nksi, nnu0, nnu1, nnu2, R
+      INTEGER          ::   nformula
+   END TYPE tide
+
+   TYPE(tide), PUBLIC, DIMENSION(jpmax_harmo) ::   Wave   !:
+
+   REAL(wp) ::   sh_T, sh_s, sh_h, sh_p, sh_p1             ! astronomic angles
+   REAL(wp) ::   sh_xi, sh_nu, sh_nuprim, sh_nusec, sh_R   !
+   REAL(wp) ::   sh_I, sh_x1ra, sh_N                       !
+
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , LOCEAN-IPSL (2010) 
+   !! $Id$ 
+   !! Software governed by the CeCILL licence (modipsl/doc/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE tide_init_Wave
+#     include "tide.h90"
+   END SUBROUTINE tide_init_Wave
+
+
+   SUBROUTINE tide_harmo( pomega, pvt, put , pcor, ktide ,kc)
+      !!----------------------------------------------------------------------
+      !!----------------------------------------------------------------------
+      INTEGER , DIMENSION(kc), INTENT(in ) ::   ktide            ! Indice of tidal constituents
+      INTEGER                , INTENT(in ) ::   kc               ! Total number of tidal constituents
+      REAL(wp), DIMENSION(kc), INTENT(out) ::   pomega           ! pulsation in radians/s
+      REAL(wp), DIMENSION(kc), INTENT(out) ::   pvt, put, pcor   !
+      !!----------------------------------------------------------------------
+      !
+      CALL astronomic_angle
+      CALL tide_pulse( pomega, ktide ,kc )
+      CALL tide_vuf  ( pvt, put, pcor, ktide ,kc )
+      !
+   END SUBROUTINE tide_harmo
+
+
+   SUBROUTINE astronomic_angle
+      !!----------------------------------------------------------------------
+      !!  tj is time elapsed since 1st January 1900, 0 hour, counted in julian
+      !!  century (e.g. time in days divide by 36525)
+      !!----------------------------------------------------------------------
+      REAL(wp) ::   cosI, p, q, t2, t4, sin2I, s2, tgI2, P1, sh_tgn2, at1, at2
+      REAL(wp) ::   zqy , zsy, zday, zdj, zhfrac
+      !!----------------------------------------------------------------------
+      !
+      zqy = AINT( (nyear-1901.)/4. )
+      zsy = nyear - 1900.
+      !
+      zdj  = dayjul( nyear, nmonth, nday )
+      zday = zdj + zqy - 1.
+      !
+      zhfrac = nsec_day / 3600.
+      !
+      !----------------------------------------------------------------------
+      !  Sh_n Longitude of ascending lunar node
+      !----------------------------------------------------------------------
+      sh_N=(259.1560564-19.328185764*zsy-.0529539336*zday-.0022064139*zhfrac)*rad
+      !----------------------------------------------------------------------
+      ! T mean solar angle (Greenwhich time)
+      !----------------------------------------------------------------------
+      sh_T=(180.+zhfrac*(360./24.))*rad
+      !----------------------------------------------------------------------
+      ! h mean solar Longitude
+      !----------------------------------------------------------------------
+      sh_h=(280.1895014-.238724988*zsy+.9856473288*zday+.0410686387*zhfrac)*rad
+      !----------------------------------------------------------------------
+      ! s mean lunar Longitude
+      !----------------------------------------------------------------------
+      sh_s=(277.0256206+129.38482032*zsy+13.176396768*zday+.549016532*zhfrac)*rad
+      !----------------------------------------------------------------------
+      ! p1 Longitude of solar perigee
+      !----------------------------------------------------------------------
+      sh_p1=(281.2208569+.01717836*zsy+.000047064*zday+.000001961*zhfrac)*rad
+      !----------------------------------------------------------------------
+      ! p Longitude of lunar perigee
+      !----------------------------------------------------------------------
+      sh_p=(334.3837214+40.66246584*zsy+.111404016*zday+.004641834*zhfrac)*rad
+
+      sh_N = MOD( sh_N ,2*rpi )
+      sh_s = MOD( sh_s ,2*rpi )
+      sh_h = MOD( sh_h, 2*rpi )
+      sh_p = MOD( sh_p, 2*rpi )
+      sh_p1= MOD( sh_p1,2*rpi )
+
+      cosI = 0.913694997 -0.035692561 *cos(sh_N)
+
+      sh_I = ACOS( cosI )
+
+      sin2I   = sin(sh_I)
+      sh_tgn2 = tan(sh_N/2.0)
+
+      at1=atan(1.01883*sh_tgn2)
+      at2=atan(0.64412*sh_tgn2)
+
+      sh_xi=-at1-at2+sh_N
+
+      IF( sh_N > rpi )   sh_xi=sh_xi-2.0*rpi
+
+      sh_nu = at1 - at2
+
+      !----------------------------------------------------------------------
+      ! For constituents l2 k1 k2
+      !----------------------------------------------------------------------
+
+      tgI2 = tan(sh_I/2.0)
+      P1   = sh_p-sh_xi
+
+      t2 = tgI2*tgI2
+      t4 = t2*t2
+      sh_x1ra = sqrt( 1.0-12.0*t2*cos(2.0*P1)+36.0*t4 )
+
+      p = sin(2.0*P1)
+      q = 1.0/(6.0*t2)-cos(2.0*P1)
+      sh_R = atan(p/q)
+
+      p = sin(2.0*sh_I)*sin(sh_nu)
+      q = sin(2.0*sh_I)*cos(sh_nu)+0.3347
+      sh_nuprim = atan(p/q)
+
+      s2 = sin(sh_I)*sin(sh_I)
+      p  = s2*sin(2.0*sh_nu)
+      q  = s2*cos(2.0*sh_nu)+0.0727
+      sh_nusec = 0.5*atan(p/q)
+      !
+   END SUBROUTINE astronomic_angle
+
+
+   SUBROUTINE tide_pulse( pomega, ktide ,kc )
+      !!----------------------------------------------------------------------
+      !!                     ***  ROUTINE tide_pulse  ***
+      !!                      
+      !! ** Purpose : Compute tidal frequencies
+      !!----------------------------------------------------------------------
+      INTEGER                , INTENT(in ) ::   kc       ! Total number of tidal constituents
+      INTEGER , DIMENSION(kc), INTENT(in ) ::   ktide    ! Indice of tidal constituents
+      REAL(wp), DIMENSION(kc), INTENT(out) ::   pomega   ! pulsation in radians/s
+      !
+      INTEGER  ::   jh
+      REAL(wp) ::   zscale
+      REAL(wp) ::   zomega_T =  13149000.0_wp
+      REAL(wp) ::   zomega_s =    481267.892_wp
+      REAL(wp) ::   zomega_h =     36000.76892_wp
+      REAL(wp) ::   zomega_p =      4069.0322056_wp
+      REAL(wp) ::   zomega_n =      1934.1423972_wp
+      REAL(wp) ::   zomega_p1=         1.719175_wp
+      !!----------------------------------------------------------------------
+      !
+      zscale =  rad / ( 36525._wp * 86400._wp ) 
+      !
+      DO jh = 1, kc
+         pomega(jh) = (  zomega_T * Wave( ktide(jh) )%nT   &
+            &          + zomega_s * Wave( ktide(jh) )%ns   &
+            &          + zomega_h * Wave( ktide(jh) )%nh   &
+            &          + zomega_p * Wave( ktide(jh) )%np   &
+            &          + zomega_p1* Wave( ktide(jh) )%np1  ) * zscale
+      END DO
+      !
+   END SUBROUTINE tide_pulse
+
+
+   SUBROUTINE tide_vuf( pvt, put, pcor, ktide ,kc )
+      !!----------------------------------------------------------------------
+      !!                     ***  ROUTINE tide_vuf  ***
+      !!                      
+      !! ** Purpose : Compute nodal modulation corrections
+      !!
+      !! ** Outputs : vt: Phase of tidal potential relative to Greenwich (radians)
+      !!              ut: Phase correction u due to nodal motion (radians)
+      !!              ft: Nodal correction factor
+      !!----------------------------------------------------------------------
+      INTEGER                , INTENT(in ) ::   kc               ! Total number of tidal constituents
+      INTEGER , DIMENSION(kc), INTENT(in ) ::   ktide            ! Indice of tidal constituents
+      REAL(wp), DIMENSION(kc), INTENT(out) ::   pvt, put, pcor   !
+      !
+      INTEGER ::   jh   ! dummy loop index
+      !!----------------------------------------------------------------------
+      !
+      DO jh = 1, kc
+         !  Phase of the tidal potential relative to the Greenwhich 
+         !  meridian (e.g. the position of the fictuous celestial body). Units are radian:
+         pvt(jh) = sh_T * Wave( ktide(jh) )%nT    &
+            &    + sh_s * Wave( ktide(jh) )%ns    &
+            &    + sh_h * Wave( ktide(jh) )%nh    &
+            &    + sh_p * Wave( ktide(jh) )%np    &
+            &    + sh_p1* Wave( ktide(jh) )%np1   &
+            &    +        Wave( ktide(jh) )%shift * rad
+         !
+         !  Phase correction u due to nodal motion. Units are radian:
+         put(jh) = sh_xi     * Wave( ktide(jh) )%nksi   &
+            &    + sh_nu     * Wave( ktide(jh) )%nnu0   &
+            &    + sh_nuprim * Wave( ktide(jh) )%nnu1   &
+            &    + sh_nusec  * Wave( ktide(jh) )%nnu2   &
+            &    + sh_R      * Wave( ktide(jh) )%R
+
+         !  Nodal correction factor:
+         pcor(jh) = nodal_factort( Wave( ktide(jh) )%nformula )
+      END DO
+      !
+   END SUBROUTINE tide_vuf
+
+
+   RECURSIVE FUNCTION nodal_factort( kformula ) RESULT( zf )
+      !!----------------------------------------------------------------------
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT(in) :: kformula
+      !
+      REAL(wp) :: zf
+      REAL(wp) :: zs, zf1, zf2
+      !!----------------------------------------------------------------------
+      !
+      SELECT CASE( kformula )
+      !
+      CASE( 0 )                  !==  formule 0, solar waves
+         zf = 1.0
+         !
+      CASE( 1 )                  !==  formule 1, compound waves (78 x 78)
+         zf=nodal_factort(78)
+         zf = zf * zf
+         !
+      CASE ( 2 )                 !==  formule 2, compound waves (78 x 0)  ===  (78) 
+       zf1= nodal_factort(78)
+       zf = nodal_factort( 0)
+       zf = zf1 * zf
+       !
+      CASE ( 4 )                 !==  formule 4,  compound waves (78 x 235) 
+         zf1 = nodal_factort( 78)
+         zf  = nodal_factort(235)
+         zf  = zf1 * zf
+         !
+      CASE ( 5 )                 !==  formule 5,  compound waves (78 *78 x 235)
+         zf1 = nodal_factort( 78)
+         zf  = nodal_factort(235)
+         zf  = zf * zf1 * zf1
+         !
+      CASE ( 6 )                 !==  formule 6,  compound waves (78 *78 x 0)
+         zf1 = nodal_factort(78)
+         zf  = nodal_factort( 0)
+         zf  = zf * zf1 * zf1 
+         !
+      CASE( 7 )                  !==  formule 7, compound waves (75 x 75)
+         zf = nodal_factort(75)
+         zf = zf * zf
+         !
+      CASE( 8 )                  !==  formule 8,  compound waves (78 x 0 x 235)
+         zf  = nodal_factort( 78)
+         zf1 = nodal_factort(  0)
+         zf2 = nodal_factort(235)
+         zf  = zf * zf1 * zf2
+         !
+      CASE( 9 )                  !==  formule 9,  compound waves (78 x 0 x 227)
+         zf  = nodal_factort( 78)
+         zf1 = nodal_factort(  0)
+         zf2 = nodal_factort(227)
+         zf  = zf * zf1 * zf2
+         !
+      CASE( 10 )                 !==  formule 10,  compound waves (78 x 227)
+         zf  = nodal_factort( 78)
+         zf1 = nodal_factort(227)
+         zf  = zf * zf1
+         !
+      CASE( 11 )                 !==  formule 11,  compound waves (75 x 0)
+!!gm bug???? zf 2 fois !
+         zf = nodal_factort(75)
+         zf1 = nodal_factort( 0)
+         zf = zf * zf1
+         !
+      CASE( 12 )                 !==  formule 12,  compound waves (78 x 78 x 78 x 0) 
+         zf1 = nodal_factort(78)
+         zf  = nodal_factort( 0)
+         zf  = zf * zf1 * zf1 * zf1
+         !
+      CASE( 13 )                 !==  formule 13, compound waves (78 x 75)
+         zf1 = nodal_factort(78)
+         zf  = nodal_factort(75)
+         zf  = zf * zf1
+         !
+      CASE( 14 )                 !==  formule 14, compound waves (235 x 0)  ===  (235)
+         zf  = nodal_factort(235)
+         zf1 = nodal_factort(  0)
+         zf  = zf * zf1
+         !
+      CASE( 15 )                 !==  formule 15, compound waves (235 x 75) 
+         zf  = nodal_factort(235)
+         zf1 = nodal_factort( 75)
+         zf  = zf * zf1
+         !
+      CASE( 16 )                 !==  formule 16, compound waves (78 x 0 x 0)  ===  (78)
+         zf  = nodal_factort(78)
+         zf1 = nodal_factort( 0)
+         zf  = zf * zf1 * zf1
+         !
+      CASE( 17 )                 !==  formule 17,  compound waves (227 x 0) 
+         zf1 = nodal_factort(227)
+         zf  = nodal_factort(  0)
+         zf  = zf * zf1
+         !
+      CASE( 18 )                 !==  formule 18,  compound waves (78 x 78 x 78 )
+         zf1 = nodal_factort(78)
+         zf  = zf1 * zf1 * zf1
+         !
+      CASE( 19 )                 !==  formule 19, compound waves (78 x 0 x 0 x 0)  ===  (78)
+!!gm bug2 ==>>>   here identical to formule 16,  a third multiplication by zf1 is missing
+         zf  = nodal_factort(78)
+         zf1 = nodal_factort( 0)
+         zf = zf * zf1 * zf1
+         !
+      CASE( 73 )                 !==  formule 73
+         zs = sin(sh_I)
+         zf = (2./3.-zs*zs)/0.5021
+         !
+      CASE( 74 )                 !==  formule 74
+         zs = sin(sh_I)
+         zf = zs * zs / 0.1578
+         !
+      CASE( 75 )                 !==  formule 75
+         zs = cos(sh_I/2)
+         zf = sin(sh_I) * zs * zs / 0.3800
+         !
+      CASE( 76 )                 !==  formule 76
+         zf = sin(2*sh_I) / 0.7214
+         !
+      CASE( 77 )                 !==  formule 77
+         zs = sin(sh_I/2)
+         zf = sin(sh_I) * zs * zs / 0.0164
+         !
+      CASE( 78 )                 !==  formule 78
+         zs = cos(sh_I/2)
+         zf = zs * zs * zs * zs / 0.9154
+         !
+      CASE( 79 )                 !==  formule 79
+         zs = sin(sh_I)
+         zf = zs * zs / 0.1565
+         !
+      CASE( 144 )                !==  formule 144
+         zs = sin(sh_I/2)
+         zf = ( 1-10*zs*zs+15*zs*zs*zs*zs ) * cos(sh_I/2) / 0.5873
+         !
+      CASE( 149 )                !==  formule 149
+         zs = cos(sh_I/2)
+         zf = zs*zs*zs*zs*zs*zs / 0.8758
+         !
+      CASE( 215 )                !==  formule 215
+         zs = cos(sh_I/2)
+         zf = zs*zs*zs*zs / 0.9154 * sh_x1ra
+         !
+      CASE( 227 )                !==  formule 227 
+         zs = sin(2*sh_I)
+         zf = sqrt( 0.8965*zs*zs+0.6001*zs*cos (sh_nu)+0.1006 )
+         !
+      CASE ( 235 )               !==  formule 235 
+         zs = sin(sh_I)
+         zf = sqrt( 19.0444*zs*zs*zs*zs + 2.7702*zs*zs*cos(2*sh_nu) + .0981 )
+         !
+      END SELECT
+      !
+   END FUNCTION nodal_factort
+
+
+   FUNCTION dayjul( kyr, kmonth, kday )
+      !!----------------------------------------------------------------------
+      !!  *** THIS ROUTINE COMPUTES THE JULIAN DAY (AS A REAL VARIABLE)
+      !!----------------------------------------------------------------------
+      INTEGER,INTENT(in) ::   kyr, kmonth, kday
+      !
+      INTEGER,DIMENSION(12) ::  idayt, idays
+      INTEGER  ::   inc, ji
+      REAL(wp) ::   dayjul, zyq
+      !
+      DATA idayt/0.,31.,59.,90.,120.,151.,181.,212.,243.,273.,304.,334./
+      !!----------------------------------------------------------------------
+      !
+      idays(1) = 0.
+      idays(2) = 31.
+      inc = 0.
+      zyq = MOD( kyr-1900. , 4. )
+      IF( zyq == 0.)   inc = 1.
+      DO ji = 3, 12
+         idays(ji)=idayt(ji)+inc
+      END DO
+      dayjul = idays(kmonth) + kday
+      !
+   END FUNCTION dayjul
+
+   !!======================================================================
+END MODULE tide_mod
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/SBC/tideini.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/SBC/tideini.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/SBC/tideini.F90	(revision 9570)
@@ -0,0 +1,134 @@
+MODULE tideini
+   !!======================================================================
+   !!                       ***  MODULE  tideini  ***
+   !! Initialization of tidal forcing
+   !!======================================================================
+   !! History :  1.0  !  2007  (O. Le Galloudec)  Original code
+   !!----------------------------------------------------------------------
+   USE oce            ! ocean dynamics and tracers variables
+   USE dom_oce        ! ocean space and time domain
+   USE phycst         ! physical constants
+   USE daymod         ! calendar
+   USE tide_mod       ! 
+   !
+   USE in_out_manager ! I/O units
+   USE iom            ! xIOs server
+   USE ioipsl         ! NetCDF IPSL library
+   USE lbclnk         ! ocean lateral boundary conditions (or mpp link)
+
+   IMPLICIT NONE
+   PUBLIC
+
+   REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:) ::   omega_tide   !:
+   REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:) ::   v0tide       !:
+   REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:) ::   utide        !:
+   REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:) ::   ftide        !:
+
+   LOGICAL , PUBLIC ::   ln_tide         !:
+   LOGICAL , PUBLIC ::   ln_tide_pot     !:
+   LOGICAL , PUBLIC ::   ln_read_load    !:
+   LOGICAL , PUBLIC ::   ln_scal_load    !:
+   LOGICAL , PUBLIC ::   ln_tide_ramp    !:
+   INTEGER , PUBLIC ::   nb_harmo        !:
+   INTEGER , PUBLIC ::   kt_tide         !:
+   REAL(wp), PUBLIC ::   rdttideramp     !:
+   REAL(wp), PUBLIC ::   rn_scal_load    !:
+   CHARACTER(lc), PUBLIC ::   cn_tide_load   !: 
+
+   INTEGER , PUBLIC, ALLOCATABLE, DIMENSION(:) ::   ntide   !:
+
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.5 , NEMO Consortium (2013)
+   !! $Id$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+   
+   SUBROUTINE tide_init
+      !!----------------------------------------------------------------------
+      !!                 ***  ROUTINE tide_init  ***
+      !!----------------------------------------------------------------------      
+      INTEGER  :: ji, jk
+      CHARACTER(LEN=4), DIMENSION(jpmax_harmo) :: clname
+      INTEGER  ::   ios                 ! Local integer output status for namelist read
+      !
+      NAMELIST/nam_tide/ln_tide, ln_tide_pot, ln_scal_load, ln_read_load, cn_tide_load, &
+                  &     ln_tide_ramp, rn_scal_load, rdttideramp, clname
+      !!----------------------------------------------------------------------
+      !
+      ! Read Namelist nam_tide
+      REWIND( numnam_ref )              ! Namelist nam_tide in reference namelist : Tides
+      READ  ( numnam_ref, nam_tide, IOSTAT = ios, ERR = 901)
+901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'nam_tide in reference namelist', lwp )
+      !
+      REWIND( numnam_cfg )              ! Namelist nam_tide in configuration namelist : Tides
+      READ  ( numnam_cfg, nam_tide, IOSTAT = ios, ERR = 902 )
+902   IF( ios >  0 )   CALL ctl_nam ( ios , 'nam_tide in configuration namelist', lwp )
+      IF(lwm) WRITE ( numond, nam_tide )
+      !
+      IF( ln_tide ) THEN
+         IF (lwp) THEN
+            WRITE(numout,*)
+            WRITE(numout,*) 'tide_init : Initialization of the tidal components'
+            WRITE(numout,*) '~~~~~~~~~ '
+            WRITE(numout,*) '   Namelist nam_tide'
+            WRITE(numout,*) '      Use tidal components                       ln_tide      = ', ln_tide
+            WRITE(numout,*) '         Apply astronomical potential            ln_tide_pot  = ', ln_tide_pot
+            WRITE(numout,*) '         Use scalar approx. for load potential   ln_scal_load = ', ln_scal_load
+            WRITE(numout,*) '         Read load potential from file           ln_read_load = ', ln_read_load
+            WRITE(numout,*) '         Apply ramp on tides at startup          ln_tide_ramp = ', ln_tide_ramp
+            WRITE(numout,*) '         Fraction of SSH used in scal. approx.   rn_scal_load = ', rn_scal_load
+            WRITE(numout,*) '         Duration (days) of ramp                 rdttideramp  = ', rdttideramp
+         ENDIF
+      ELSE
+         rn_scal_load = 0._wp 
+
+         IF(lwp) WRITE(numout,*)
+         IF(lwp) WRITE(numout,*) 'tide_init : tidal components not used (ln_tide = F)'
+         IF(lwp) WRITE(numout,*) '~~~~~~~~~ '
+         RETURN
+      ENDIF
+      !
+      CALL tide_init_Wave
+      !
+      nb_harmo=0
+      DO jk = 1, jpmax_harmo
+         DO ji = 1,jpmax_harmo
+            IF( TRIM(clname(jk)) == Wave(ji)%cname_tide )   nb_harmo = nb_harmo + 1
+         END DO
+      END DO
+      !       
+      ! Ensure that tidal components have been set in namelist_cfg
+      IF( nb_harmo == 0 )   CALL ctl_stop( 'tide_init : No tidal components set in nam_tide' )
+      !
+      IF( ln_read_load.AND.(.NOT.ln_tide_pot) ) &
+          &   CALL ctl_stop('ln_read_load requires ln_tide_pot')
+      IF( ln_scal_load.AND.(.NOT.ln_tide_pot) ) &
+          &   CALL ctl_stop('ln_scal_load requires ln_tide_pot')
+      IF( ln_scal_load.AND.ln_read_load ) &
+          &   CALL ctl_stop('Choose between ln_scal_load and ln_read_load')
+      IF( ln_tide_ramp.AND.((nitend-nit000+1)*rdt/rday < rdttideramp) )   &
+         &   CALL ctl_stop('rdttideramp must be lower than run duration')
+      IF( ln_tide_ramp.AND.(rdttideramp<0.) ) &
+         &   CALL ctl_stop('rdttideramp must be positive')
+      !
+      ALLOCATE( ntide(nb_harmo) )
+      DO jk = 1, nb_harmo
+         DO ji = 1, jpmax_harmo
+            IF( TRIM(clname(jk)) == Wave(ji)%cname_tide ) THEN
+               ntide(jk) = ji
+               EXIT
+            ENDIF
+         END DO
+      END DO
+      !
+      ALLOCATE( omega_tide(nb_harmo), v0tide    (nb_harmo),   &
+         &      utide     (nb_harmo), ftide     (nb_harmo)  )
+      kt_tide = nit000
+      !
+      IF (.NOT.ln_scal_load ) rn_scal_load = 0._wp
+      !
+   END SUBROUTINE tide_init
+     
+   !!======================================================================
+END MODULE tideini
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/SBC/updtide.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/SBC/updtide.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/SBC/updtide.F90	(revision 9570)
@@ -0,0 +1,81 @@
+MODULE updtide
+   !!======================================================================
+   !!                       ***  MODULE  updtide  ***
+   !! Initialization of tidal forcing
+   !!======================================================================
+   !! History :  9.0  !  07  (O. Le Galloudec)  Original code
+   !!----------------------------------------------------------------------
+   !!   upd_tide       : update tidal potential
+   !!----------------------------------------------------------------------
+   USE oce             ! ocean dynamics and tracers variables
+   USE dom_oce         ! ocean space and time domain
+   USE in_out_manager  ! I/O units
+   USE phycst          ! physical constant
+   USE sbctide         ! tide potential variable
+   USE tideini, ONLY: ln_tide_ramp, rdttideramp
+
+   IMPLICIT NONE
+   PUBLIC
+
+   PUBLIC   upd_tide   ! called in dynspg_... modules
+  
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO Consortium (2010)
+   !! $Id$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE upd_tide( kt, kit, time_offset )
+      !!----------------------------------------------------------------------
+      !!                 ***  ROUTINE upd_tide  ***
+      !!
+      !! ** Purpose :   provide at each time step the astronomical potential
+      !!
+      !! ** Method  :   computed from pulsation and amplitude of all tide components
+      !!
+      !! ** Action  :   pot_astro   actronomical potential
+      !!----------------------------------------------------------------------      
+      INTEGER, INTENT(in)           ::   kt      ! ocean time-step index
+      INTEGER, INTENT(in), OPTIONAL ::   kit     ! external mode sub-time-step index (lk_dynspg_ts=T)
+      INTEGER, INTENT(in), OPTIONAL ::   time_offset ! time offset in number 
+                                                     ! of internal steps             (lk_dynspg_ts=F)
+                                                     ! of external steps             (lk_dynspg_ts=T)
+      !
+      INTEGER  ::   joffset      ! local integer
+      INTEGER  ::   ji, jj, jk   ! dummy loop indices
+      REAL(wp) ::   zt, zramp    ! local scalar
+      REAL(wp), DIMENSION(nb_harmo) ::   zwt 
+      !!----------------------------------------------------------------------      
+      !
+      !                               ! tide pulsation at model time step (or sub-time-step)
+      zt = ( kt - kt_tide ) * rdt
+      !
+      joffset = 0
+      IF( PRESENT( time_offset ) )   joffset = time_offset
+      !
+      IF( PRESENT( kit ) )   THEN
+         zt = zt + ( kit +  joffset - 1 ) * rdt / REAL( nn_baro, wp )
+      ELSE
+         zt = zt + joffset * rdt
+      ENDIF
+      !
+      zwt(:) = omega_tide(:) * zt
+
+      pot_astro(:,:) = 0._wp          ! update tidal potential (sum of all harmonics)
+      DO jk = 1, nb_harmo   
+         pot_astro(:,:) = pot_astro(:,:) + amp_pot(:,:,jk) * COS( zwt(jk) + phi_pot(:,:,jk) )      
+      END DO
+      !
+      IF( ln_tide_ramp ) THEN         ! linear increase if asked
+         zt = ( kt - nit000 ) * rdt
+         IF( PRESENT( kit ) )   zt = zt + ( kit + joffset -1) * rdt / REAL( nn_baro, wp )
+         zramp = MIN(  MAX( zt / (rdttideramp*rday) , 0._wp ) , 1._wp  )
+         pot_astro(:,:) = zramp * pot_astro(:,:)
+      ENDIF
+      !
+   END SUBROUTINE upd_tide
+
+  !!======================================================================
+
+END MODULE updtide
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/STO/stopar.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/STO/stopar.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/STO/stopar.F90	(revision 9570)
@@ -0,0 +1,911 @@
+MODULE stopar
+   !!======================================================================
+   !!                       ***  MODULE  stopar  ***
+   !! Stochastic parameters : definition and time stepping
+   !!=====================================================================
+   !! History :  3.3  ! 2011-10 (J.-M. Brankart)  Original code
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   sto_par       : update the stochastic parameters
+   !!   sto_par_init  : define the stochastic parameterization
+   !!   sto_rst_read  : read restart file for stochastic parameters
+   !!   sto_rst_write : write restart file for stochastic parameters
+   !!   sto_par_white : fill input array with white Gaussian noise
+   !!   sto_par_flt   : apply horizontal Laplacian filter to input array
+   !!----------------------------------------------------------------------
+   USE storng          ! random number generator (external module)
+   USE par_oce         ! ocean parameters
+   USE dom_oce         ! ocean space and time domain variables
+   USE lbclnk          ! lateral boundary conditions (or mpp link)
+   USE in_out_manager  ! I/O manager
+   USE iom             ! I/O module
+   USE lib_mpp
+
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   sto_par_init    ! called by nemogcm.F90
+   PUBLIC   sto_par         ! called by step.F90
+   PUBLIC   sto_rst_write   ! called by step.F90
+
+   LOGICAL           :: ln_rststo = .FALSE.  ! restart stochastic parameters from restart file
+   LOGICAL           :: ln_rstseed = .FALSE. ! read seed of RNG from restart file
+   CHARACTER(len=32) :: cn_storst_in = "restart_sto"     ! suffix of sto restart name (input)
+   CHARACTER(len=32) :: cn_storst_out = "restart_sto"    ! suffix of sto restart name (output)
+   INTEGER           :: numstor, numstow     ! logical unit for restart (read and write)
+
+   INTEGER           :: jpsto2d = 0          ! number of 2D stochastic parameters
+   INTEGER           :: jpsto3d = 0          ! number of 3D stochastic parameters
+
+   REAL(wp), PUBLIC, DIMENSION(:,:,:),   ALLOCATABLE :: sto2d      ! 2D stochastic parameters
+   REAL(wp), PUBLIC, DIMENSION(:,:,:,:), ALLOCATABLE :: sto3d      ! 3D stochastic parameters
+   REAL(wp),         DIMENSION(:,:),     ALLOCATABLE :: sto_tmp    ! temporary workspace
+   REAL(wp),         DIMENSION(:,:),     ALLOCATABLE :: sto2d_abc  ! a, b, c parameters (for 2D arrays)
+   REAL(wp),         DIMENSION(:,:),     ALLOCATABLE :: sto3d_abc  ! a, b, c parameters (for 3D arrays)
+   REAL(wp),         DIMENSION(:),       ALLOCATABLE :: sto2d_ave  ! mean value (for 2D arrays)
+   REAL(wp),         DIMENSION(:),       ALLOCATABLE :: sto3d_ave  ! mean value (for 3D arrays)
+   REAL(wp),         DIMENSION(:),       ALLOCATABLE :: sto2d_std  ! standard deviation (for 2D arrays)
+   REAL(wp),         DIMENSION(:),       ALLOCATABLE :: sto3d_std  ! standard deviation (for 3D arrays)
+   REAL(wp),         DIMENSION(:),       ALLOCATABLE :: sto2d_lim  ! limitation factor (for 2D arrays)
+   REAL(wp),         DIMENSION(:),       ALLOCATABLE :: sto3d_lim  ! limitation factor (for 3D arrays)
+   REAL(wp),         DIMENSION(:),       ALLOCATABLE :: sto2d_tcor ! time correlation (for 2D arrays)
+   REAL(wp),         DIMENSION(:),       ALLOCATABLE :: sto3d_tcor ! time correlation (for 3D arrays)
+   INTEGER,          DIMENSION(:),       ALLOCATABLE :: sto2d_ord  ! order of autoregressive process
+   INTEGER,          DIMENSION(:),       ALLOCATABLE :: sto3d_ord  ! order of autoregressive process
+
+   CHARACTER(len=1), DIMENSION(:),       ALLOCATABLE :: sto2d_typ  ! nature of grid point (T, U, V, W, F, I)
+   CHARACTER(len=1), DIMENSION(:),       ALLOCATABLE :: sto3d_typ  ! nature of grid point (T, U, V, W, F, I)
+   REAL(wp),         DIMENSION(:),       ALLOCATABLE :: sto2d_sgn  ! control of the sign accross the north fold
+   REAL(wp),         DIMENSION(:),       ALLOCATABLE :: sto3d_sgn  ! control of the sign accross the north fold
+   INTEGER,          DIMENSION(:),       ALLOCATABLE :: sto2d_flt  ! number of passes of Laplacian filter
+   INTEGER,          DIMENSION(:),       ALLOCATABLE :: sto3d_flt  ! number of passes of Laplacian filter
+   REAL(wp),         DIMENSION(:),       ALLOCATABLE :: sto2d_fac  ! factor to restore std after filtering
+   REAL(wp),         DIMENSION(:),       ALLOCATABLE :: sto3d_fac  ! factor to restore std after filtering
+
+   LOGICAL, PUBLIC :: ln_sto_ldf = .FALSE.    ! stochastic lateral diffusion
+   INTEGER, PUBLIC :: jsto_ldf                ! index of lateral diffusion stochastic parameter
+   REAL(wp)        :: rn_ldf_std              ! lateral diffusion standard deviation (in percent)
+   REAL(wp)        :: rn_ldf_tcor             ! lateral diffusion correlation timescale (in timesteps)
+
+   LOGICAL, PUBLIC :: ln_sto_hpg = .FALSE.    ! stochastic horizontal pressure gradient
+   INTEGER, PUBLIC :: jsto_hpgi               ! index of stochastic hpg parameter (i direction)
+   INTEGER, PUBLIC :: jsto_hpgj               ! index of stochastic hpg parameter (j direction)
+   REAL(wp)        :: rn_hpg_std              ! density gradient standard deviation (in percent)
+   REAL(wp)        :: rn_hpg_tcor             ! density gradient correlation timescale (in timesteps)
+
+   LOGICAL, PUBLIC :: ln_sto_pstar = .FALSE.  ! stochastic ice strength
+   INTEGER, PUBLIC :: jsto_pstar              ! index of stochastic ice strength
+   REAL(wp), PUBLIC:: rn_pstar_std            ! ice strength standard deviation (in percent)
+   REAL(wp)        :: rn_pstar_tcor           ! ice strength correlation timescale (in timesteps)
+   INTEGER         :: nn_pstar_flt = 0        ! number of passes of Laplacian filter
+   INTEGER         :: nn_pstar_ord = 1        ! order of autoregressive processes
+
+   LOGICAL, PUBLIC :: ln_sto_trd = .FALSE.    ! stochastic model trend
+   INTEGER, PUBLIC :: jsto_trd                ! index of stochastic trend parameter
+   REAL(wp)        :: rn_trd_std              ! trend standard deviation (in percent)
+   REAL(wp)        :: rn_trd_tcor             ! trend correlation timescale (in timesteps)
+
+   LOGICAL, PUBLIC :: ln_sto_eos = .FALSE.    ! stochastic equation of state
+   INTEGER, PUBLIC :: nn_sto_eos = 1          ! number of degrees of freedom in stochastic equation of state
+   INTEGER, PUBLIC, DIMENSION(:), ALLOCATABLE :: jsto_eosi ! index of stochastic eos parameter (i direction)
+   INTEGER, PUBLIC, DIMENSION(:), ALLOCATABLE :: jsto_eosj ! index of stochastic eos parameter (j direction)
+   INTEGER, PUBLIC, DIMENSION(:), ALLOCATABLE :: jsto_eosk ! index of stochastic eos parameter (k direction)
+   REAL(wp)        :: rn_eos_stdxy            ! random walk horz. standard deviation (in grid points)
+   REAL(wp)        :: rn_eos_stdz             ! random walk vert. standard deviation (in grid points)
+   REAL(wp)        :: rn_eos_tcor             ! random walk correlation timescale (in timesteps)
+   REAL(wp)        :: rn_eos_lim = 3.0_wp     ! limitation factor
+   INTEGER         :: nn_eos_flt = 0          ! number of passes of Laplacian filter
+   INTEGER         :: nn_eos_ord = 1          ! order of autoregressive processes
+
+   LOGICAL, PUBLIC :: ln_sto_trc = .FALSE.    ! stochastic tracer dynamics
+   INTEGER, PUBLIC :: nn_sto_trc = 1          ! number of degrees of freedom in stochastic tracer dynamics
+   INTEGER, PUBLIC, DIMENSION(:), ALLOCATABLE :: jsto_trci ! index of stochastic trc parameter (i direction)
+   INTEGER, PUBLIC, DIMENSION(:), ALLOCATABLE :: jsto_trcj ! index of stochastic trc parameter (j direction)
+   INTEGER, PUBLIC, DIMENSION(:), ALLOCATABLE :: jsto_trck ! index of stochastic trc parameter (k direction)
+   REAL(wp)        :: rn_trc_stdxy            ! random walk horz. standard deviation (in grid points)
+   REAL(wp)        :: rn_trc_stdz             ! random walk vert. standard deviation (in grid points)
+   REAL(wp)        :: rn_trc_tcor             ! random walk correlation timescale (in timesteps)
+   REAL(wp)        :: rn_trc_lim = 3.0_wp     ! limitation factor
+   INTEGER         :: nn_trc_flt = 0          ! number of passes of Laplacian filter
+   INTEGER         :: nn_trc_ord = 1          ! order of autoregressive processes
+
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO Consortium (2010)
+   !! $Id: dynhpg.F90 2528 2010-12-27 17:33:53Z rblod $
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE sto_par( kt )
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE sto_par  ***
+      !!
+      !! ** Purpose :   update the stochastic parameters
+      !!
+      !! ** Method  :   model basic stochastic parameters
+      !!                as a first order autoregressive process AR(1),
+      !!                governed by the equation:
+      !!                   X(t) = a * X(t-1) + b * w + c
+      !!                where the parameters a, b and c are related
+      !!                to expected value, standard deviation
+      !!                and time correlation (all stationary in time) by:
+      !!                   E   [X(t)]        = c / ( 1 - a )
+      !!                   STD [X(t)]        = b / SQRT( 1 - a * a )
+      !!                   COR [X(t),X(t-k)] = a ** k
+      !!                and w is a Gaussian white noise.
+      !!
+      !!                Higher order autoregressive proces can be optionally generated
+      !!                by replacing the white noise by a lower order process.
+      !!
+      !!                1) The statistics of the stochastic parameters (X) are assumed
+      !!                constant in space (homogeneous) and time (stationary).
+      !!                This could be generalized by replacing the constant
+      !!                a, b, c parameters by functions of space and time.
+      !!
+      !!                2) The computation is performed independently for every model
+      !!                grid point, which corresponds to assume that the stochastic
+      !!                parameters are uncorrelated in space.
+      !!                This could be generalized by including a spatial filter: Y = Filt[ X ]
+      !!                (possibly non-homgeneous and non-stationary) in the computation,
+      !!                or by solving an elliptic equation: L[ Y ] = X.
+      !!
+      !!                3) The stochastic model for the parameters could also
+      !!                be generalized to depend on the current state of the ocean (not done here).
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT( in ) ::   kt   ! ocean time-step index
+      !!
+      INTEGER  :: ji, jj, jk, jsto, jflt
+      REAL(wp) :: stomax
+      !!----------------------------------------------------------------------
+      !
+      ! Update 2D stochastic arrays
+      !
+      DO jsto = 1, jpsto2d
+        ! Store array from previous time step
+        sto_tmp(:,:) = sto2d(:,:,jsto)
+
+        IF ( sto2d_ord(jsto) == 1 ) THEN
+          ! Draw new random numbers from N(0,1) --> w
+          CALL sto_par_white( sto2d(:,:,jsto) )
+          ! Apply horizontal Laplacian filter to w
+          DO jflt = 1, sto2d_flt(jsto)
+            CALL lbc_lnk( sto2d(:,:,jsto), sto2d_typ(jsto), sto2d_sgn(jsto) )
+            CALL sto_par_flt( sto2d(:,:,jsto) )
+          END DO
+          ! Factor to restore standard deviation after filtering
+          sto2d(:,:,jsto) = sto2d(:,:,jsto) * sto2d_fac(jsto)
+        ELSE
+          ! Use previous process (one order lower) instead of white noise
+          sto2d(:,:,jsto) = sto2d(:,:,jsto-1)
+        ENDIF
+
+        ! Multiply white noise (or lower order process) by b --> b * w
+        sto2d(:,:,jsto) = sto2d(:,:,jsto) * sto2d_abc(jsto,2)
+        ! Update autoregressive processes --> a * X(t-1) + b * w
+        sto2d(:,:,jsto) = sto2d(:,:,jsto) + sto_tmp(:,:) * sto2d_abc(jsto,1)
+        ! Add parameter c --> a * X(t-1) + b * w + c
+        sto2d(:,:,jsto) = sto2d(:,:,jsto) + sto2d_abc(jsto,3)
+        ! Limit random parameter anomalies to std times the limitation factor
+        stomax = sto2d_std(jsto) * sto2d_lim(jsto)
+        sto2d(:,:,jsto) = sto2d(:,:,jsto) - sto2d_ave(jsto)
+        sto2d(:,:,jsto) = SIGN(MIN(stomax,ABS(sto2d(:,:,jsto))),sto2d(:,:,jsto))
+        sto2d(:,:,jsto) = sto2d(:,:,jsto) + sto2d_ave(jsto)
+
+        ! Lateral boundary conditions on sto2d
+        CALL lbc_lnk( sto2d(:,:,jsto), sto2d_typ(jsto), sto2d_sgn(jsto) )
+      END DO
+      !
+      ! Update 3D stochastic arrays
+      !
+      DO jsto = 1, jpsto3d
+         DO jk = 1, jpk
+           ! Store array from previous time step
+           sto_tmp(:,:) = sto3d(:,:,jk,jsto)
+
+           IF ( sto3d_ord(jsto) == 1 ) THEN
+             ! Draw new random numbers from N(0,1) --> w
+             CALL sto_par_white( sto3d(:,:,jk,jsto) )
+             ! Apply horizontal Laplacian filter to w
+             DO jflt = 1, sto3d_flt(jsto)
+               CALL lbc_lnk( sto3d(:,:,jk,jsto), sto3d_typ(jsto), sto3d_sgn(jsto) )
+               CALL sto_par_flt( sto3d(:,:,jk,jsto) )
+             END DO
+             ! Factor to restore standard deviation after filtering
+             sto3d(:,:,jk,jsto) = sto3d(:,:,jk,jsto) * sto3d_fac(jsto)
+           ELSE
+             ! Use previous process (one order lower) instead of white noise
+             sto3d(:,:,jk,jsto) = sto3d(:,:,jk,jsto-1)
+           ENDIF
+
+           ! Multiply white noise by b --> b * w
+           sto3d(:,:,jk,jsto) = sto3d(:,:,jk,jsto) * sto3d_abc(jsto,2)
+           ! Update autoregressive processes --> a * X(t-1) + b * w
+           sto3d(:,:,jk,jsto) = sto3d(:,:,jk,jsto) + sto_tmp(:,:) * sto3d_abc(jsto,1)
+           ! Add parameter c --> a * X(t-1) + b * w + c
+           sto3d(:,:,jk,jsto) = sto3d(:,:,jk,jsto) + sto3d_abc(jsto,3)
+           ! Limit random parameters anomalies to std times the limitation factor
+           stomax = sto3d_std(jsto) * sto3d_lim(jsto)
+           sto3d(:,:,jk,jsto) = sto3d(:,:,jk,jsto) - sto3d_ave(jsto)
+           sto3d(:,:,jk,jsto) = SIGN(MIN(stomax,ABS(sto3d(:,:,jk,jsto))),sto3d(:,:,jk,jsto))
+           sto3d(:,:,jk,jsto) = sto3d(:,:,jk,jsto) + sto3d_ave(jsto)
+         END DO
+         ! Lateral boundary conditions on sto3d
+         CALL lbc_lnk( sto3d(:,:,:,jsto), sto3d_typ(jsto), sto3d_sgn(jsto) )
+      END DO
+      !
+   END SUBROUTINE sto_par
+
+
+   SUBROUTINE sto_par_init
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE sto_par_init  ***
+      !!
+      !! ** Purpose :   define the stochastic parameterization
+      !!----------------------------------------------------------------------
+      NAMELIST/namsto/ ln_sto_ldf, rn_ldf_std, rn_ldf_tcor, &
+        &              ln_sto_hpg, rn_hpg_std, rn_hpg_tcor, &
+        &              ln_sto_pstar, rn_pstar_std, rn_pstar_tcor, nn_pstar_flt, nn_pstar_ord, &
+        &              ln_sto_trd, rn_trd_std, rn_trd_tcor, &
+        &              ln_sto_eos, nn_sto_eos, rn_eos_stdxy, rn_eos_stdz, &
+        &              rn_eos_tcor, nn_eos_ord, nn_eos_flt, rn_eos_lim, &
+        &              ln_sto_trc, nn_sto_trc, rn_trc_stdxy, rn_trc_stdz, &
+        &              rn_trc_tcor, nn_trc_ord, nn_trc_flt, rn_trc_lim, &
+        &              ln_rststo, ln_rstseed, cn_storst_in, cn_storst_out
+      !!----------------------------------------------------------------------
+      INTEGER :: jsto, jmem, jarea, jdof, jord, jordm1, jk, jflt
+      INTEGER(KIND=8) :: zseed1, zseed2, zseed3, zseed4
+      REAL(wp) :: rinflate
+      INTEGER  ::   ios                 ! Local integer output status for namelist read
+
+      ! Read namsto namelist : stochastic parameterization
+      REWIND( numnam_ref )              ! Namelist namdyn_adv in reference namelist : Momentum advection scheme
+      READ  ( numnam_ref, namsto, IOSTAT = ios, ERR = 901)
+901   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsto in reference namelist', lwp )
+
+      REWIND( numnam_cfg )              ! Namelist namdyn_adv in configuration namelist : Momentum advection scheme
+      READ  ( numnam_cfg, namsto, IOSTAT = ios, ERR = 902 )
+902   IF( ios >  0 ) CALL ctl_nam ( ios , 'namsto in configuration namelist', lwp )
+      IF(lwm) WRITE ( numond, namsto )
+
+      IF( .NOT.ln_rststo ) THEN   ! no use of stochastic parameterization
+         IF(lwp) THEN
+            WRITE(numout,*)
+            WRITE(numout,*) 'sto_par_init : NO use of stochastic parameterization'
+            WRITE(numout,*) '~~~~~~~~~~~~'
+         ENDIF
+         RETURN
+      ENDIF
+
+      !IF(ln_ens_rst_in) cn_storst_in = cn_mem//cn_storst_in
+
+      ! Parameter print
+      IF(lwp) THEN
+         WRITE(numout,*)
+         WRITE(numout,*) 'sto_par_init : stochastic parameterization'
+         WRITE(numout,*) '~~~~~~~~~~~~'
+         WRITE(numout,*) '   Namelist namsto : stochastic parameterization'
+         WRITE(numout,*) '      restart stochastic parameters           ln_rststo     = ', ln_rststo
+         WRITE(numout,*) '      read seed of RNG from restart file      ln_rstseed    = ', ln_rstseed
+         WRITE(numout,*) '      suffix of sto restart name (input)      cn_storst_in  = ', cn_storst_in
+         WRITE(numout,*) '      suffix of sto restart name (output)     cn_storst_out = ', cn_storst_out
+
+         ! WRITE(numout,*) '      stochastic lateral diffusion            ln_sto_ldf    = ', ln_sto_ldf
+         ! WRITE(numout,*) '      lateral diffusion std (in percent)      rn_ldf_std    = ', rn_ldf_std
+         ! WRITE(numout,*) '      lateral diffusion tcor (in timesteps)   rn_ldf_tcor   = ', rn_ldf_tcor
+
+         ! WRITE(numout,*) '      stochastic horizontal pressure gradient ln_sto_hpg    = ', ln_sto_hpg
+         ! WRITE(numout,*) '      density gradient std (in percent)       rn_hpg_std    = ', rn_hpg_std
+         ! WRITE(numout,*) '      density gradient tcor (in timesteps)    rn_hpg_tcor   = ', rn_hpg_tcor
+
+         ! WRITE(numout,*) '      stochastic ice strength                 ln_sto_pstar  = ', ln_sto_pstar
+         ! WRITE(numout,*) '      ice strength std (in percent)           rn_pstar_std  = ', rn_pstar_std
+         ! WRITE(numout,*) '      ice strength tcor (in timesteps)        rn_pstar_tcor = ', rn_pstar_tcor
+         ! WRITE(numout,*) '      order of autoregressive  processes      nn_pstar_ord  = ', nn_pstar_ord
+         ! WRITE(numout,*) '      passes of Laplacian filter              nn_pstar_flt  = ', nn_pstar_flt
+
+         !WRITE(numout,*) '      stochastic trend                        ln_sto_trd    = ', ln_sto_trd
+         !WRITE(numout,*) '      trend std (in percent)                  rn_trd_std    = ', rn_trd_std
+         !WRITE(numout,*) '      trend tcor (in timesteps)               rn_trd_tcor   = ', rn_trd_tcor
+
+         WRITE(numout,*) '      stochastic equation of state            ln_sto_eos    = ', ln_sto_eos
+         WRITE(numout,*) '      number of degrees of freedom            nn_sto_eos    = ', nn_sto_eos
+         WRITE(numout,*) '      random walk horz. std (in grid points)  rn_eos_stdxy  = ', rn_eos_stdxy
+         WRITE(numout,*) '      random walk vert. std (in grid points)  rn_eos_stdz   = ', rn_eos_stdz
+         WRITE(numout,*) '      random walk tcor (in timesteps)         rn_eos_tcor   = ', rn_eos_tcor
+         WRITE(numout,*) '      order of autoregressive  processes      nn_eos_ord    = ', nn_eos_ord
+         WRITE(numout,*) '      passes of Laplacian filter              nn_eos_flt    = ', nn_eos_flt
+         WRITE(numout,*) '      limitation factor                       rn_eos_lim    = ', rn_eos_lim
+
+         ! WRITE(numout,*) '      stochastic tracers dynamics             ln_sto_trc    = ', ln_sto_trc
+         ! WRITE(numout,*) '      number of degrees of freedom            nn_sto_trc    = ', nn_sto_trc
+         ! WRITE(numout,*) '      random walk horz. std (in grid points)  rn_trc_stdxy  = ', rn_trc_stdxy
+         ! WRITE(numout,*) '      random walk vert. std (in grid points)  rn_trc_stdz   = ', rn_trc_stdz
+         ! WRITE(numout,*) '      random walk tcor (in timesteps)         rn_trc_tcor   = ', rn_trc_tcor
+         ! WRITE(numout,*) '      order of autoregressive  processes      nn_trc_ord    = ', nn_trc_ord
+         ! WRITE(numout,*) '      passes of Laplacian filter              nn_trc_flt    = ', nn_trc_flt
+         ! WRITE(numout,*) '      limitation factor                       rn_trc_lim    = ', rn_trc_lim
+
+      ENDIF
+
+      IF(lwp) WRITE(numout,*)
+      IF(lwp) WRITE(numout,*) '   stochastic parameterization :'
+
+      ! Set number of 2D stochastic arrays
+      jpsto2d = 0
+      IF( ln_sto_ldf ) THEN
+         IF(lwp) WRITE(numout,*) '       - stochastic lateral diffusion'
+         jpsto2d   = jpsto2d + 1
+         jsto_ldf  = jpsto2d
+      ENDIF
+      IF( ln_sto_pstar ) THEN
+         IF(lwp) WRITE(numout,*) '       - stochastic ice strength'
+         jpsto2d    = jpsto2d + 1 * nn_pstar_ord
+         jsto_pstar = jpsto2d
+      ENDIF
+      IF( ln_sto_eos ) THEN
+         IF ( lk_agrif ) CALL ctl_stop('EOS stochastic parametrization is not compatible with AGRIF')
+         IF(lwp) WRITE(numout,*) '       - stochastic equation of state'
+         ALLOCATE(jsto_eosi(nn_sto_eos))
+         ALLOCATE(jsto_eosj(nn_sto_eos))
+         ALLOCATE(jsto_eosk(nn_sto_eos))
+         DO jdof = 1, nn_sto_eos
+            jpsto2d   = jpsto2d + 3 * nn_eos_ord
+            jsto_eosi(jdof) = jpsto2d - 2 * nn_eos_ord
+            jsto_eosj(jdof) = jpsto2d - 1 * nn_eos_ord
+            jsto_eosk(jdof) = jpsto2d
+         END DO
+      ELSE
+         nn_sto_eos = 0
+      ENDIF
+      IF( ln_sto_trc ) THEN
+         IF(lwp) WRITE(numout,*) '       - stochastic tracers dynamics'
+         ALLOCATE(jsto_trci(nn_sto_trc))
+         ALLOCATE(jsto_trcj(nn_sto_trc))
+         ALLOCATE(jsto_trck(nn_sto_trc))
+         DO jdof = 1, nn_sto_trc
+            jpsto2d   = jpsto2d + 3 * nn_trc_ord
+            jsto_trci(jdof) = jpsto2d - 2 * nn_trc_ord
+            jsto_trcj(jdof) = jpsto2d - 1 * nn_trc_ord
+            jsto_trck(jdof) = jpsto2d
+         END DO
+      ELSE
+         nn_sto_trc = 0
+      ENDIF
+
+      ! Set number of 3D stochastic arrays
+      jpsto3d = 0
+      IF( ln_sto_hpg ) THEN
+         IF(lwp) WRITE(numout,*) '       - stochastic horizontal pressure gradient'
+         jpsto3d   = jpsto3d + 2
+         jsto_hpgi = jpsto3d - 1
+         jsto_hpgj = jpsto3d
+      ENDIF
+      IF( ln_sto_trd ) THEN
+         IF(lwp) WRITE(numout,*) '       - stochastic trend'
+         jpsto3d   = jpsto3d + 1
+         jsto_trd  = jpsto3d
+      ENDIF
+
+      ! Allocate 2D stochastic arrays
+      IF ( jpsto2d > 0 ) THEN
+         ALLOCATE ( sto2d(jpi,jpj,jpsto2d) )
+         ALLOCATE ( sto2d_abc(jpsto2d,3) )
+         ALLOCATE ( sto2d_ave(jpsto2d) )
+         ALLOCATE ( sto2d_std(jpsto2d) )
+         ALLOCATE ( sto2d_lim(jpsto2d) )
+         ALLOCATE ( sto2d_tcor(jpsto2d) )
+         ALLOCATE ( sto2d_ord(jpsto2d) )
+         ALLOCATE ( sto2d_typ(jpsto2d) )
+         ALLOCATE ( sto2d_sgn(jpsto2d) )
+         ALLOCATE ( sto2d_flt(jpsto2d) )
+         ALLOCATE ( sto2d_fac(jpsto2d) )
+      ENDIF
+
+      ! Allocate 3D stochastic arrays
+      IF ( jpsto3d > 0 ) THEN
+         ALLOCATE ( sto3d(jpi,jpj,jpk,jpsto3d) )
+         ALLOCATE ( sto3d_abc(jpsto3d,3) )
+         ALLOCATE ( sto3d_ave(jpsto3d) )
+         ALLOCATE ( sto3d_std(jpsto3d) )
+         ALLOCATE ( sto3d_lim(jpsto3d) )
+         ALLOCATE ( sto3d_tcor(jpsto3d) )
+         ALLOCATE ( sto3d_ord(jpsto3d) )
+         ALLOCATE ( sto3d_typ(jpsto3d) )
+         ALLOCATE ( sto3d_sgn(jpsto3d) )
+         ALLOCATE ( sto3d_flt(jpsto3d) )
+         ALLOCATE ( sto3d_fac(jpsto3d) )
+      ENDIF
+
+      ! Allocate temporary workspace
+      IF ( jpsto2d > 0 .OR. jpsto3d > 0 ) THEN
+         ALLOCATE ( sto_tmp(jpi,jpj) ) ; sto_tmp(:,:) = 0._wp
+      ENDIF
+
+      ! 1) For every stochastic parameter:
+      ! ----------------------------------
+      ! - set nature of grid point and control of the sign
+      !       across the north fold (sto2d_typ, sto2d_sgn)
+      ! - set number of passes of Laplacian filter (sto2d_flt)
+      ! - set order of every autoregressive process (sto2d_ord)
+      DO jsto = 1, jpsto2d
+         sto2d_typ(jsto) = 'T'
+         sto2d_sgn(jsto) = 1._wp
+         sto2d_flt(jsto) = 0
+         sto2d_ord(jsto) = 1
+         DO jord = 0, nn_pstar_ord-1
+            IF ( jsto+jord == jsto_pstar ) THEN ! Stochastic ice strength (ave=1)
+               sto2d_ord(jsto) = nn_pstar_ord - jord
+               sto2d_flt(jsto) = nn_pstar_flt
+            ENDIF
+         ENDDO
+         DO jdof = 1, nn_sto_eos
+         DO jord = 0, nn_eos_ord-1
+            IF ( jsto+jord == jsto_eosi(jdof) ) THEN ! Stochastic equation of state i (ave=0)
+               sto2d_ord(jsto) = nn_eos_ord - jord
+               sto2d_sgn(jsto) = -1._wp
+               sto2d_flt(jsto) = nn_eos_flt
+            ENDIF
+            IF ( jsto+jord == jsto_eosj(jdof) ) THEN ! Stochastic equation of state j (ave=0)
+               sto2d_ord(jsto) = nn_eos_ord - jord
+               sto2d_sgn(jsto) = -1._wp
+               sto2d_flt(jsto) = nn_eos_flt
+            ENDIF
+            IF ( jsto+jord == jsto_eosk(jdof) ) THEN ! Stochastic equation of state k (ave=0)
+               sto2d_ord(jsto) = nn_eos_ord - jord
+               sto2d_flt(jsto) = nn_eos_flt
+            ENDIF
+         END DO
+         END DO
+         DO jdof = 1, nn_sto_trc
+         DO jord = 0, nn_trc_ord-1
+            IF ( jsto+jord == jsto_trci(jdof) ) THEN ! Stochastic tracers dynamics i (ave=0)
+               sto2d_ord(jsto) = nn_trc_ord - jord
+               sto2d_sgn(jsto) = -1._wp
+               sto2d_flt(jsto) = nn_trc_flt
+            ENDIF
+            IF ( jsto+jord == jsto_trcj(jdof) ) THEN ! Stochastic tracers dynamics j (ave=0)
+               sto2d_ord(jsto) = nn_trc_ord - jord
+               sto2d_sgn(jsto) = -1._wp
+               sto2d_flt(jsto) = nn_trc_flt
+            ENDIF
+            IF ( jsto+jord == jsto_trck(jdof) ) THEN ! Stochastic tracers dynamics k (ave=0)
+               sto2d_ord(jsto) = nn_trc_ord - jord
+               sto2d_flt(jsto) = nn_trc_flt
+            ENDIF
+         END DO
+         END DO
+
+         sto2d_fac(jsto) = sto_par_flt_fac ( sto2d_flt(jsto) )
+      END DO
+      !
+      DO jsto = 1, jpsto3d
+         sto3d_typ(jsto) = 'T'
+         sto3d_sgn(jsto) = 1._wp
+         sto3d_flt(jsto) = 0
+         sto3d_ord(jsto) = 1
+         IF ( jsto == jsto_hpgi ) THEN ! Stochastic density gradient i (ave=1)
+            sto3d_typ(jsto) = 'U'
+         ENDIF
+         IF ( jsto == jsto_hpgj ) THEN ! Stochastic density gradient j (ave=1)
+            sto3d_typ(jsto) = 'V'
+         ENDIF
+         sto3d_fac(jsto) = sto_par_flt_fac ( sto3d_flt(jsto) )
+      END DO
+
+      ! 2) For every stochastic parameter:
+      ! ----------------------------------
+      ! set average, standard deviation and time correlation
+      DO jsto = 1, jpsto2d
+         sto2d_ave(jsto)  = 0._wp
+         sto2d_std(jsto)  = 1._wp
+         sto2d_tcor(jsto) = 1._wp
+         sto2d_lim(jsto)  = 3._wp
+         IF ( jsto == jsto_ldf  ) THEN ! Stochastic lateral diffusion (ave=1)
+            sto2d_ave(jsto)  = 1._wp
+            sto2d_std(jsto)  = rn_ldf_std
+            sto2d_tcor(jsto) = rn_ldf_tcor
+         ENDIF
+         DO jord = 0, nn_pstar_ord-1
+            IF ( jsto+jord == jsto_pstar ) THEN ! Stochastic ice strength (ave=1)
+               sto2d_std(jsto) = 1._wp
+               sto2d_tcor(jsto) = rn_pstar_tcor
+            ENDIF
+         ENDDO
+         DO jdof = 1, nn_sto_eos
+         DO jord = 0, nn_eos_ord-1
+            IF ( jsto+jord == jsto_eosi(jdof) ) THEN ! Stochastic equation of state i (ave=0)
+               sto2d_std(jsto)  = rn_eos_stdxy
+               sto2d_tcor(jsto) = rn_eos_tcor
+               sto2d_lim(jsto)  = rn_eos_lim
+            ENDIF
+            IF ( jsto+jord == jsto_eosj(jdof) ) THEN ! Stochastic equation of state j (ave=0)
+               sto2d_std(jsto)  = rn_eos_stdxy
+               sto2d_tcor(jsto) = rn_eos_tcor
+               sto2d_lim(jsto)  = rn_eos_lim
+            ENDIF
+            IF ( jsto+jord == jsto_eosk(jdof) ) THEN ! Stochastic equation of state k (ave=0)
+               sto2d_std(jsto)  = rn_eos_stdz
+               sto2d_tcor(jsto) = rn_eos_tcor
+               sto2d_lim(jsto)  = rn_eos_lim
+            ENDIF
+         END DO
+         END DO
+         DO jdof = 1, nn_sto_trc
+         DO jord = 0, nn_trc_ord-1
+            IF ( jsto+jord == jsto_trci(jdof) ) THEN ! Stochastic tracer dynamics i (ave=0)
+               sto2d_std(jsto)  = rn_trc_stdxy
+               sto2d_tcor(jsto) = rn_trc_tcor
+               sto2d_lim(jsto)  = rn_trc_lim
+            ENDIF
+            IF ( jsto+jord == jsto_trcj(jdof) ) THEN ! Stochastic tracer dynamics j (ave=0)
+               sto2d_std(jsto)  = rn_trc_stdxy
+               sto2d_tcor(jsto) = rn_trc_tcor
+               sto2d_lim(jsto)  = rn_trc_lim
+            ENDIF
+            IF ( jsto+jord == jsto_trck(jdof) ) THEN ! Stochastic tracer dynamics k (ave=0)
+               sto2d_std(jsto)  = rn_trc_stdz
+               sto2d_tcor(jsto) = rn_trc_tcor
+               sto2d_lim(jsto)  = rn_trc_lim
+            ENDIF
+         END DO
+         END DO
+
+      END DO
+      !
+      DO jsto = 1, jpsto3d
+         sto3d_ave(jsto)  = 0._wp
+         sto3d_std(jsto)  = 1._wp
+         sto3d_tcor(jsto) = 1._wp
+         sto3d_lim(jsto)  = 3._wp
+         IF ( jsto == jsto_hpgi ) THEN ! Stochastic density gradient i (ave=1)
+            sto3d_ave(jsto)  = 1._wp
+            sto3d_std(jsto)  = rn_hpg_std
+            sto3d_tcor(jsto) = rn_hpg_tcor
+         ENDIF
+         IF ( jsto == jsto_hpgj ) THEN ! Stochastic density gradient j (ave=1)
+            sto3d_ave(jsto)  = 1._wp
+            sto3d_std(jsto)  = rn_hpg_std
+            sto3d_tcor(jsto) = rn_hpg_tcor
+         ENDIF
+         IF ( jsto == jsto_trd ) THEN ! Stochastic trend (ave=1)
+            sto3d_ave(jsto)  = 1._wp
+            sto3d_std(jsto)  = rn_trd_std
+            sto3d_tcor(jsto) = rn_trd_tcor
+         ENDIF
+      END DO
+
+      ! 3) For every stochastic parameter:
+      ! ----------------------------------
+      ! - compute parameters (a, b, c) of the AR1 autoregressive process
+      !   from expected value (ave), standard deviation (std)
+      !   and time correlation (tcor):
+      !     a = EXP ( - 1 / tcor )           --> sto2d_abc(:,1)
+      !     b = std * SQRT( 1 - a * a )      --> sto2d_abc(:,2)
+      !     c = ave * ( 1 - a )              --> sto2d_abc(:,3)
+      ! - for higher order processes (ARn, n>1), use approximate formula
+      !   for the b parameter (valid for tcor>>1 time step)
+      DO jsto = 1, jpsto2d
+         IF ( sto2d_tcor(jsto) == 0._wp ) THEN
+            sto2d_abc(jsto,1) = 0._wp
+         ELSE
+            sto2d_abc(jsto,1) = EXP ( - 1._wp / sto2d_tcor(jsto) )
+         ENDIF
+         IF ( sto2d_ord(jsto) == 1 ) THEN      ! Exact formula for 1st order process
+            rinflate = sto2d_std(jsto)
+         ELSE
+            ! Approximate formula, valid for tcor >> 1
+            jordm1 = sto2d_ord(jsto) - 1
+            rinflate = SQRT ( REAL( jordm1 , wp ) / REAL( 2*(2*jordm1-1) , wp ) )
+         ENDIF
+         sto2d_abc(jsto,2) = rinflate * SQRT ( 1._wp - sto2d_abc(jsto,1) &
+                                                     * sto2d_abc(jsto,1) )
+         sto2d_abc(jsto,3) = sto2d_ave(jsto) * ( 1._wp - sto2d_abc(jsto,1) )
+      END DO
+      !
+      DO jsto = 1, jpsto3d
+         IF ( sto3d_tcor(jsto) == 0._wp ) THEN
+            sto3d_abc(jsto,1) = 0._wp
+         ELSE
+            sto3d_abc(jsto,1) = EXP ( - 1._wp / sto3d_tcor(jsto) )
+         ENDIF
+         IF ( sto3d_ord(jsto) == 1 ) THEN      ! Exact formula for 1st order process
+            rinflate = sto3d_std(jsto)
+         ELSE
+            ! Approximate formula, valid for tcor >> 1
+            jordm1 = sto3d_ord(jsto) - 1
+            rinflate = SQRT ( REAL( jordm1 , wp ) / REAL( 2*(2*jordm1-1) , wp ) )
+         ENDIF
+         sto3d_abc(jsto,2) = rinflate * SQRT ( 1._wp - sto3d_abc(jsto,1) &
+                                                     * sto3d_abc(jsto,1) )
+         sto3d_abc(jsto,3) = sto3d_ave(jsto) * ( 1._wp - sto3d_abc(jsto,1) )
+      END DO
+
+      ! 4) Initialize seeds for random number generator
+      ! -----------------------------------------------
+      ! using different seeds for different processors (jarea)
+      ! and different ensemble members (jmem)
+      CALL kiss_reset( )
+      DO jarea = 1, narea
+         !DO jmem = 0, nmember
+         zseed1 = kiss() ; zseed2 = kiss() ; zseed3 = kiss() ; zseed4 = kiss()
+         !END DO
+      END DO
+      CALL kiss_seed( zseed1, zseed2, zseed3, zseed4 )
+
+      ! 5) Initialize stochastic parameters to: ave + std * w
+      ! -----------------------------------------------------
+      DO jsto = 1, jpsto2d
+         ! Draw random numbers from N(0,1) --> w
+         CALL sto_par_white( sto2d(:,:,jsto) )
+         ! Apply horizontal Laplacian filter to w
+         DO jflt = 1, sto2d_flt(jsto)
+            CALL lbc_lnk( sto2d(:,:,jsto), sto2d_typ(jsto), sto2d_sgn(jsto) )
+            CALL sto_par_flt( sto2d(:,:,jsto) )
+         END DO
+         ! Factor to restore standard deviation after filtering
+         sto2d(:,:,jsto) = sto2d(:,:,jsto) * sto2d_fac(jsto)
+         ! Limit random parameter to the limitation factor
+         sto2d(:,:,jsto) = SIGN(MIN(sto2d_lim(jsto),ABS(sto2d(:,:,jsto))),sto2d(:,:,jsto))
+         ! Multiply by standard devation and add average value
+         sto2d(:,:,jsto) = sto2d(:,:,jsto) * sto2d_std(jsto) + sto2d_ave(jsto)
+      END DO
+      !
+      DO jsto = 1, jpsto3d
+         DO jk = 1, jpk
+            ! Draw random numbers from N(0,1) --> w
+            CALL sto_par_white( sto3d(:,:,jk,jsto) )
+            ! Apply horizontal Laplacian filter to w
+            DO jflt = 1, sto3d_flt(jsto)
+               CALL lbc_lnk( sto3d(:,:,jk,jsto), sto3d_typ(jsto), sto3d_sgn(jsto) )
+               CALL sto_par_flt( sto3d(:,:,jk,jsto) )
+            END DO
+            ! Factor to restore standard deviation after filtering
+            sto3d(:,:,jk,jsto) = sto3d(:,:,jk,jsto) * sto3d_fac(jsto)
+            ! Limit random parameter to the limitation factor
+            sto3d(:,:,jk,jsto) = SIGN(MIN(sto3d_lim(jsto),ABS(sto3d(:,:,jk,jsto))),sto3d(:,:,jk,jsto))
+            ! Multiply by standard devation and add average value
+            sto3d(:,:,jk,jsto) = sto3d(:,:,jk,jsto) * sto3d_std(jsto) + sto3d_ave(jsto)
+         END DO
+      END DO
+
+      ! 6) Restart stochastic parameters from file
+      ! ------------------------------------------
+      IF( ln_rststo ) CALL sto_rst_read
+
+   END SUBROUTINE sto_par_init
+
+
+   SUBROUTINE sto_rst_read
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE sto_rst_read  ***
+      !!
+      !! ** Purpose :   read stochastic parameters from restart file
+      !!----------------------------------------------------------------------
+      INTEGER  :: jsto, jseed
+      INTEGER(KIND=8)     ::   ziseed(4)           ! RNG seeds in integer type
+      REAL(KIND=8)        ::   zrseed(4)           ! RNG seeds in real type (with same bits to save in restart)
+      CHARACTER(LEN=9)    ::   clsto2d='sto2d_000' ! stochastic parameter variable name
+      CHARACTER(LEN=9)    ::   clsto3d='sto3d_000' ! stochastic parameter variable name
+      CHARACTER(LEN=10)   ::   clseed='seed0_0000' ! seed variable name
+      !!----------------------------------------------------------------------
+
+      IF ( jpsto2d > 0 .OR. jpsto3d > 0 ) THEN
+
+         IF(lwp) THEN
+            WRITE(numout,*)
+            WRITE(numout,*) 'sto_rst_read : read stochastic parameters from restart file'
+            WRITE(numout,*) '~~~~~~~~~~~~'
+         ENDIF
+
+         ! Open the restart file
+         CALL iom_open( cn_storst_in, numstor, kiolib = jprstlib )
+
+         ! Get stochastic parameters from restart file:
+         ! 2D stochastic parameters
+         DO jsto = 1 , jpsto2d
+            WRITE(clsto2d(7:9),'(i3.3)') jsto
+            CALL iom_get( numstor, jpdom_autoglo, clsto2d , sto2d(:,:,jsto) )
+         END DO
+         ! 3D stochastic parameters
+         DO jsto = 1 , jpsto3d
+            WRITE(clsto3d(7:9),'(i3.3)') jsto
+            CALL iom_get( numstor, jpdom_autoglo, clsto3d , sto3d(:,:,:,jsto) )
+         END DO
+
+         IF (ln_rstseed) THEN
+            ! Get saved state of the random number generator
+            DO jseed = 1 , 4
+               WRITE(clseed(5:5) ,'(i1.1)') jseed
+               WRITE(clseed(7:10),'(i4.4)') narea
+               CALL iom_get( numstor, clseed , zrseed(jseed) )
+            END DO
+            ziseed = TRANSFER( zrseed , ziseed)
+            CALL kiss_seed( ziseed(1) , ziseed(2) , ziseed(3) , ziseed(4) )
+         ENDIF
+
+         ! Close the restart file
+         CALL iom_close( numstor )
+
+      ENDIF
+
+   END SUBROUTINE sto_rst_read
+
+
+   SUBROUTINE sto_rst_write( kt )
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE sto_rst_write  ***
+      !!
+      !! ** Purpose :   write stochastic parameters in restart file
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT(in) ::   kt     ! ocean time-step
+      !!
+      INTEGER  :: jsto, jseed
+      INTEGER(KIND=8)     ::   ziseed(4)           ! RNG seeds in integer type
+      REAL(KIND=8)        ::   zrseed(4)           ! RNG seeds in real type (with same bits to save in restart)
+      CHARACTER(LEN=20)   ::   clkt                ! ocean time-step defined as a character
+      CHARACTER(LEN=50)   ::   clname              ! restart file name
+      CHARACTER(LEN=9)    ::   clsto2d='sto2d_000' ! stochastic parameter variable name
+      CHARACTER(LEN=9)    ::   clsto3d='sto3d_000' ! stochastic parameter variable name
+      CHARACTER(LEN=10)   ::   clseed='seed0_0000' ! seed variable name
+
+      IF ( jpsto2d > 0 .OR. jpsto3d > 0 ) THEN
+
+         IF( kt == nitrst .OR. kt == nitend ) THEN
+            IF(lwp) THEN
+               WRITE(numout,*)
+               WRITE(numout,*) 'sto_rst_write : write stochastic parameters in restart file'
+               WRITE(numout,*) '~~~~~~~~~~~~~'
+            ENDIF
+         ENDIF
+
+         ! Put stochastic parameters in restart files
+         ! (as opened at previous timestep, see below)
+         IF( kt > nit000) THEN
+         IF( kt == nitrst .OR. kt == nitend ) THEN
+            ! get and save current state of the random number generator
+            CALL kiss_state( ziseed(1) , ziseed(2) , ziseed(3) , ziseed(4) )
+            zrseed = TRANSFER( ziseed , zrseed)
+            DO jseed = 1 , 4
+               WRITE(clseed(5:5) ,'(i1.1)') jseed
+               WRITE(clseed(7:10),'(i4.4)') narea
+               CALL iom_rstput( kt, nitrst, numstow, clseed , zrseed(jseed) )
+            END DO
+            ! 2D stochastic parameters
+            DO jsto = 1 , jpsto2d
+               WRITE(clsto2d(7:9),'(i3.3)') jsto
+               CALL iom_rstput( kt, nitrst, numstow, clsto2d , sto2d(:,:,jsto) )
+            END DO
+            ! 3D stochastic parameters
+            DO jsto = 1 , jpsto3d
+               WRITE(clsto3d(7:9),'(i3.3)') jsto
+               CALL iom_rstput( kt, nitrst, numstow, clsto3d , sto3d(:,:,:,jsto) )
+            END DO
+            ! close the restart file
+            CALL iom_close( numstow )
+         ENDIF
+         ENDIF
+
+         ! Open the restart file one timestep before writing restart
+         IF( kt < nitend) THEN
+         IF( kt == nitrst - 1 .OR. nstock == 1 .OR. kt == nitend-1 ) THEN
+            ! create the filename
+            IF( nitrst > 999999999 ) THEN   ;   WRITE(clkt, *       ) nitrst
+            ELSE                            ;   WRITE(clkt, '(i8.8)') nitrst
+            ENDIF
+            clname = TRIM(cexper)//"_"//TRIM(ADJUSTL(clkt))//"_"//TRIM(cn_storst_out)
+            ! print information
+            IF(lwp) THEN
+               WRITE(numout,*) '             open stochastic parameters restart file: '//clname
+               IF( kt == nitrst - 1 ) THEN
+                  WRITE(numout,*) '             kt = nitrst - 1 = ', kt
+               ELSE
+                  WRITE(numout,*) '             kt = '             , kt
+               ENDIF
+            ENDIF
+            ! open the restart file
+            CALL iom_open( clname, numstow, ldwrt = .TRUE., kiolib = jprstlib )
+         ENDIF
+         ENDIF
+
+      ENDIF
+
+   END SUBROUTINE sto_rst_write
+
+
+   SUBROUTINE sto_par_white( psto )
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE sto_par_white  ***
+      !!
+      !! ** Purpose :   fill input array with white Gaussian noise
+      !!----------------------------------------------------------------------
+      REAL(wp), DIMENSION(jpi,jpj), INTENT(out)           ::   psto
+      !!
+      INTEGER  :: ji, jj
+      REAL(KIND=8) :: gran   ! Gaussian random number (forced KIND=8 as in kiss_gaussian)
+
+      DO jj = 1, jpj
+         DO ji = 1, jpi
+            CALL kiss_gaussian( gran )
+            psto(ji,jj) = gran
+         END DO
+      END DO
+
+   END SUBROUTINE sto_par_white
+
+
+   SUBROUTINE sto_par_flt( psto )
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE sto_par_flt  ***
+      !!
+      !! ** Purpose :   apply horizontal Laplacian filter to input array
+      !!----------------------------------------------------------------------
+      REAL(wp), DIMENSION(jpi,jpj), INTENT(out)           ::   psto
+      !!
+      INTEGER  :: ji, jj
+
+      DO jj = 2, jpj-1
+         DO ji = 2, jpi-1
+            psto(ji,jj) = 0.5_wp * psto(ji,jj) + 0.125_wp * &
+                              &  ( psto(ji-1,jj) + psto(ji+1,jj) +  &
+                              &    psto(ji,jj-1) + psto(ji,jj+1) )
+         END DO
+      END DO
+
+   END SUBROUTINE sto_par_flt
+
+
+   FUNCTION sto_par_flt_fac( kpasses )
+      !!----------------------------------------------------------------------
+      !!                  ***  FUNCTION sto_par_flt_fac  ***
+      !!
+      !! ** Purpose :   compute factor to restore standard deviation
+      !!                as a function of the number of passes
+      !!                of the Laplacian filter
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT(in) :: kpasses
+      REAL(wp) :: sto_par_flt_fac
+      !!
+      INTEGER :: jpasses, ji, jj, jflti, jfltj
+      INTEGER, DIMENSION(-1:1,-1:1) :: pflt0
+      REAL(wp), DIMENSION(:,:), ALLOCATABLE :: pfltb
+      REAL(wp), DIMENSION(:,:), ALLOCATABLE :: pflta
+      REAL(wp) :: ratio
+
+      pflt0(-1,-1) = 0 ; pflt0(-1,0) = 1 ; pflt0(-1,1) = 0
+      pflt0( 0,-1) = 1 ; pflt0( 0,0) = 4 ; pflt0( 0,1) = 1
+      pflt0( 1,-1) = 0 ; pflt0( 1,0) = 1 ; pflt0( 1,1) = 0
+
+      ALLOCATE(pfltb(-kpasses-1:kpasses+1,-kpasses-1:kpasses+1))
+      ALLOCATE(pflta(-kpasses-1:kpasses+1,-kpasses-1:kpasses+1))
+
+      pfltb(:,:) = 0
+      pfltb(0,0) = 1
+      DO jpasses = 1, kpasses
+        pflta(:,:) = 0
+        DO jflti= -1, 1
+        DO jfltj= -1, 1
+          DO ji= -kpasses, kpasses
+          DO jj= -kpasses, kpasses
+            pflta(ji,jj) = pflta(ji,jj) + pfltb(ji+jflti,jj+jfltj) * pflt0(jflti,jfltj)
+          ENDDO
+          ENDDO
+        ENDDO
+        ENDDO
+        pfltb(:,:) = pflta(:,:)
+      ENDDO
+
+      ratio = SUM(pfltb(:,:))
+      ratio = ratio * ratio / SUM(pfltb(:,:)*pfltb(:,:))
+      ratio = SQRT(ratio)
+
+      DEALLOCATE(pfltb,pflta)
+
+      sto_par_flt_fac = ratio
+
+   END FUNCTION sto_par_flt_fac
+
+
+END MODULE stopar
+
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/STO/stopts.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/STO/stopts.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/STO/stopts.F90	(revision 9570)
@@ -0,0 +1,146 @@
+MODULE stopts
+   !!==============================================================================
+   !!                       ***  MODULE  stopts  ***
+   !! Stochastic parameterization: compute stochastic tracer fluctuations
+   !!==============================================================================
+   !! History :  3.3  ! 2011-12 (J.-M. Brankart)  Original code
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   sto_pts        : compute current stochastic tracer fluctuations
+   !!   sto_pts_init   : initialisation for stochastic tracer fluctuations
+   !!----------------------------------------------------------------------
+   USE dom_oce         ! ocean space and time domain
+   USE lbclnk          ! lateral boundary conditions (or mpp link)
+   USE phycst          ! physical constants
+   USE stopar          ! stochastic parameterization
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   sto_pts         ! called by step.F90
+   PUBLIC   sto_pts_init    ! called by nemogcm.F90
+
+   ! Public array with random tracer fluctuations
+   REAL(wp), PUBLIC, DIMENSION(:,:,:,:,:), ALLOCATABLE :: pts_ran
+
+   !! * Substitutions
+#  include "vectopt_loop_substitute.h90"
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO Consortium (2010)
+   !! $Id: eosbn2.F90 2528 2010-12-27 17:33:53Z rblod $
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE sto_pts( pts )
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE sto_pts  ***
+      !!
+      !! ** Purpose :   Compute current stochastic tracer fluctuations
+      !!
+      !! ** Method  :   Compute tracer differences from a random walk
+      !!                around every model grid point
+      !!
+      !!----------------------------------------------------------------------
+      REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(inout) ::   pts   ! 1 : potential temperature  [Celsius]
+      !                                                               ! 2 : salinity               [psu]
+      INTEGER  ::   ji, jj, jk, jts, jdof ! dummy loop indices
+      INTEGER  ::   jim1, jjm1, jkm1  ! incremented indices
+      INTEGER  ::   jip1, jjp1, jkp1  !     -          -
+      REAL(wp) ::   zdtsim, zdtsjm, zdtskm         ! temporary scalars
+      REAL(wp) ::   zdtsip, zdtsjp, zdtskp, zdts   !     -        -
+      !!----------------------------------------------------------------------
+
+      DO jts = 1, jpts
+        CALL lbc_lnk( pts(:,:,:,jts), 'T' , 1._wp )
+      ENDDO
+
+      DO jdof = 1, nn_sto_eos
+        DO jts = 1, jpts
+           DO jk = 1, jpkm1
+              jkm1 = MAX(jk-1,1) ; jkp1 = MIN(jk+1,jpkm1)
+              DO jj = 1, jpj
+                 jjm1 = MAX(jj-1,1) ; jjp1 = MIN(jj+1,jpj)
+                 DO ji = 1, jpi
+                    jim1 = MAX(ji-1,1) ; jip1 = MIN(ji+1,jpi)
+                    !
+                    ! compute tracer gradient
+                    zdtsip = ( pts(jip1,jj,jk,jts) - pts(ji,jj,jk,jts) ) * tmask(jip1,jj,jk)
+                    zdtsim = ( pts(ji,jj,jk,jts) - pts(jim1,jj,jk,jts) ) * tmask(jim1,jj,jk)
+                    zdtsjp = ( pts(ji,jjp1,jk,jts) - pts(ji,jj,jk,jts) ) * tmask(ji,jjp1,jk)
+                    zdtsjm = ( pts(ji,jj,jk,jts) - pts(ji,jjm1,jk,jts) ) * tmask(ji,jjm1,jk)
+                    zdtskp = ( pts(ji,jj,jkp1,jts) - pts(ji,jj,jk,jts) ) * tmask(ji,jj,jkp1)
+                    zdtskm = ( pts(ji,jj,jk,jts) - pts(ji,jj,jkm1,jts) ) * tmask(ji,jj,jkm1)
+                    !
+                    ! compute random tracer fluctuation (zdts)
+                    zdts   = ( zdtsip + zdtsim ) * sto2d(ji,jj,jsto_eosi(jdof)) + &
+                           & ( zdtsjp + zdtsjm ) * sto2d(ji,jj,jsto_eosj(jdof)) + &
+                           & ( zdtskp + zdtskm ) * sto2d(ji,jj,jsto_eosk(jdof))
+!                   zdts   = zdtsip * MAX(sto2d(ji,jj,jsto_eosi),0._wp) + &
+!                          & zdtsim * MIN(sto2d(ji,jj,jsto_eosi),0._wp) + &
+!                          & zdtsjp * MAX(sto2d(ji,jj,jsto_eosj),0._wp) + &
+!                          & zdtsjm * MIN(sto2d(ji,jj,jsto_eosj),0._wp) + &
+!                          & zdtskp * MAX(sto2d(ji,jj,jsto_eosk),0._wp) + &
+!                          & zdtskm * MIN(sto2d(ji,jj,jsto_eosk),0._wp)
+                    zdts   = zdts  * tmask(ji,jj,jk) *SIN( gphit(ji,jj) * rad )
+                    pts_ran(ji,jj,jk,jts,jdof) = zdts * 0.5_wp
+                    !
+                  END DO
+               END DO
+            END DO
+         END DO
+      END DO
+
+      ! Eliminate any possible negative salinity
+      DO jdof = 1, nn_sto_eos
+         DO jk = 1, jpkm1
+            DO jj = 1, jpj
+               DO ji = 1, jpi
+                  pts_ran(ji,jj,jk,jp_sal,jdof) = MIN( ABS(pts_ran(ji,jj,jk,jp_sal,jdof)) ,  &
+                                                &      MAX(pts(ji,jj,jk,jp_sal),0._wp) )     &
+                                                &  * SIGN(1._wp,pts_ran(ji,jj,jk,jp_sal,jdof))
+               END DO
+            END DO
+         END DO
+      END DO
+
+      ! Eliminate any temperature lower than -2 degC
+!     DO jdof = 1, nn_sto_eos
+!        DO jk = 1, jpkm1
+!           DO jj = 1, jpj
+!              DO ji = 1, jpi
+!                 pts_ran(ji,jj,jk,jp_tem,jdof) = MIN( ABS(pts_ran(ji,jj,jk,jp_tem,jdof)) ,    &
+!                                               &      MAX(pts(ji,jj,jk,jp_tem)+2._wp,0._wp) ) &
+!                                               &  * SIGN(1._wp,pts_ran(ji,jj,jk,jp_tem,jdof))
+!              END DO
+!           END DO
+!        END DO
+!     END DO
+
+
+      ! Lateral boundary conditions on pts_ran
+      DO jdof = 1, nn_sto_eos
+         DO jts = 1, jpts
+            CALL lbc_lnk( pts_ran(:,:,:,jts,jdof), 'T' , 1._wp )
+         END DO
+      END DO
+
+   END SUBROUTINE sto_pts
+
+
+   SUBROUTINE sto_pts_init
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE sto_pts_init  ***
+      !!
+      !! ** Purpose :   Initialisation for stochastic tracer fluctuations
+      !!
+      !! ** Method  :   Allocate required array
+      !!
+      !!----------------------------------------------------------------------
+
+      ALLOCATE(pts_ran(jpi,jpj,jpk,jpts,nn_sto_eos))
+
+   END SUBROUTINE sto_pts_init
+
+END MODULE stopts
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/STO/storng.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/STO/storng.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/STO/storng.F90	(revision 9570)
@@ -0,0 +1,407 @@
+MODULE storng
+!$AGRIF_DO_NOT_TREAT
+   !!======================================================================
+   !!                       ***  MODULE  storng  ***
+   !! Random number generator, used in NEMO stochastic parameterization
+   !!
+   !!=====================================================================
+   !! History :  3.3  ! 2011-10 (J.-M. Brankart)  Original code
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !! The module is based on (and includes) the
+   !! 64-bit KISS (Keep It Simple Stupid) random number generator
+   !! distributed by George Marsaglia :
+   !! http://groups.google.com/group/comp.lang.fortran/
+   !!        browse_thread/thread/a85bf5f2a97f5a55
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   kiss          : 64-bit KISS random number generator (period ~ 2^250)
+   !!   kiss_seed     : Define seeds for KISS random number generator
+   !!   kiss_state    : Get current state of KISS random number generator
+   !!   kiss_save     : Save current state of KISS (for future restart)
+   !!   kiss_load     : Load the saved state of KISS
+   !!   kiss_reset    : Reset the default seeds
+   !!   kiss_check    : Check the KISS pseudo-random sequence
+   !!   kiss_uniform  : Real random numbers with uniform distribution in [0,1]
+   !!   kiss_gaussian : Real random numbers with Gaussian distribution N(0,1)
+   !!   kiss_gamma    : Real random numbers with Gamma distribution Gamma(k,1)
+   !!   kiss_sample   : Select a random sample from a set of integers
+   !!
+   !!   ---CURRENTLY NOT USED IN NEMO :
+   !!   kiss_save, kiss_load, kiss_check, kiss_gamma, kiss_sample
+   !!----------------------------------------------------------------------
+   USE par_kind
+   USE lib_mpp
+
+   IMPLICIT NONE
+   PRIVATE
+
+   ! Public functions/subroutines
+   PUBLIC :: kiss, kiss_seed, kiss_state, kiss_reset ! kiss_save, kiss_load, kiss_check
+   PUBLIC :: kiss_uniform, kiss_gaussian, kiss_gamma, kiss_sample
+
+   ! Default/initial seeds
+   INTEGER(KIND=i8) :: x=1234567890987654321_8
+   INTEGER(KIND=i8) :: y=362436362436362436_8
+   INTEGER(KIND=i8) :: z=1066149217761810_8
+   INTEGER(KIND=i8) :: w=123456123456123456_8
+
+   ! Parameters to generate real random variates
+   REAL(KIND=wp), PARAMETER :: huge64=9223372036854775808.0  ! +1
+   REAL(KIND=wp), PARAMETER :: zero=0.0, half=0.5, one=1.0, two=2.0
+
+   ! Variables to store 2 Gaussian random numbers with current index (ig)
+   INTEGER(KIND=i8), SAVE :: ig=1
+   REAL(KIND=wp), SAVE :: gran1, gran2
+
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO Consortium (2010)
+   !! $Id: dynhpg.F90 2528 2010-12-27 17:33:53Z rblod $
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   FUNCTION kiss()
+      !! --------------------------------------------------------------------
+      !!                  ***  FUNCTION kiss  ***
+      !!
+      !! ** Purpose :   64-bit KISS random number generator
+      !!
+      !! ** Method  :   combine several random number generators:
+      !!                (1) Xorshift (XSH), period 2^64-1,
+      !!                (2) Multiply-with-carry (MWC), period (2^121+2^63-1)
+      !!                (3) Congruential generator (CNG), period 2^64.
+      !!
+      !!                overall period:
+      !!                (2^250+2^192+2^64-2^186-2^129)/6
+      !!                            ~= 2^(247.42) or 10^(74.48)
+      !!
+      !!                set your own seeds with 'kiss_seed'
+      ! --------------------------------------------------------------------
+      IMPLICIT NONE
+      INTEGER(KIND=i8) :: kiss, t
+
+      t = ISHFT(x,58) + w
+      IF (s(x).eq.s(t)) THEN
+         w = ISHFT(x,-6) + s(x)
+      ELSE
+         w = ISHFT(x,-6) + 1 - s(x+t)
+      ENDIF
+      x = t + x
+      y = m( m( m(y,13_8), -17_8 ), 43_8 )
+      z = 6906969069_8 * z + 1234567_8
+
+      kiss = x + y + z
+
+      CONTAINS
+
+         FUNCTION s(k)
+            INTEGER(KIND=i8) :: s, k
+            s = ISHFT(k,-63)
+         END FUNCTION s
+
+         FUNCTION m(k, n)
+            INTEGER(KIND=i8) :: m, k, n
+            m =  IEOR(k, ISHFT(k, n) )
+         END FUNCTION m
+
+   END FUNCTION kiss
+
+
+   SUBROUTINE kiss_seed(ix, iy, iz, iw)
+      !! --------------------------------------------------------------------
+      !!                  ***  ROUTINE kiss_seed  ***
+      !!
+      !! ** Purpose :   Define seeds for KISS random number generator
+      !!
+      !! --------------------------------------------------------------------
+      IMPLICIT NONE
+      INTEGER(KIND=i8) :: ix, iy, iz, iw
+
+      x = ix
+      y = iy
+      z = iz
+      w = iw
+
+   END SUBROUTINE kiss_seed
+
+
+   SUBROUTINE kiss_state(ix, iy, iz, iw)
+      !! --------------------------------------------------------------------
+      !!                  ***  ROUTINE kiss_state  ***
+      !!
+      !! ** Purpose :   Get current state of KISS random number generator
+      !!
+      !! --------------------------------------------------------------------
+      IMPLICIT NONE
+      INTEGER(KIND=i8) :: ix, iy, iz, iw
+
+      ix = x
+      iy = y
+      iz = z
+      iw = w
+
+   END SUBROUTINE kiss_state
+
+
+   SUBROUTINE kiss_reset()
+      !! --------------------------------------------------------------------
+      !!                  ***  ROUTINE kiss_reset  ***
+      !!
+      !! ** Purpose :   Reset the default seeds for KISS random number generator
+      !!
+      !! --------------------------------------------------------------------
+      IMPLICIT NONE
+
+      x=1234567890987654321_8
+      y=362436362436362436_8
+      z=1066149217761810_8
+      w=123456123456123456_8
+
+    END SUBROUTINE kiss_reset
+
+
+   !  SUBROUTINE kiss_check(check_type)
+   !    !! --------------------------------------------------------------------
+   !    !!                  ***  ROUTINE kiss_check  ***
+   !    !!
+   !    !! ** Purpose :   Check the KISS pseudo-random sequence
+   !    !!
+   !    !! ** Method  :   Check that it reproduces the correct sequence
+   !    !!                from the default seed
+   !    !!
+   !    !! --------------------------------------------------------------------
+   !    IMPLICIT NONE
+   !    INTEGER(KIND=i8) :: iter, niter, correct, iran
+   !    CHARACTER(LEN=*) :: check_type
+   !    LOGICAL :: print_success
+
+   !    ! Save current state of KISS
+   !    CALL kiss_save()
+   !    ! Reset the default seed
+   !    CALL kiss_reset()
+
+   !    ! Select check type
+   !    SELECT CASE(check_type)
+   !    CASE('short')
+   !       niter = 5_8
+   !       correct = 542381058189297533
+   !       print_success = .FALSE.
+   !    CASE('long')
+   !       niter = 100000000_8
+   !       correct = 1666297717051644203 ! Check provided by G. Marsaglia
+   !       print_success = .TRUE.
+   !    CASE('default')
+   !    CASE DEFAULT
+   !       STOP 'Bad check type in kiss_check'
+   !    END SELECT
+
+   !    ! Run kiss for the required number of iterations (niter)
+   !    DO iter=1,niter
+   !       iran = kiss()
+   !    ENDDO
+
+   !    ! Check that last iterate is correct
+   !    IF (iran.NE.correct) THEN
+   !       STOP 'Check failed: KISS internal error !!'
+   !    ELSE
+   !       IF (print_success) PRINT *, 'Check successful: 100 million calls to KISS OK'
+   !    ENDIF
+
+   !    ! Reload the previous state of KISS
+   !    CALL kiss_load()
+
+   ! END SUBROUTINE kiss_check
+
+
+   ! SUBROUTINE kiss_save
+   !    !! --------------------------------------------------------------------
+   !    !!                  ***  ROUTINE kiss_save  ***
+   !    !!
+   !    !! ** Purpose :   Save current state of KISS random number generator
+   !    !!
+   !    !! --------------------------------------------------------------------
+   !    INTEGER :: inum     !! Local integer
+
+   !    IMPLICIT NONE
+
+   !    CALL ctl_opn( inum, '.kiss_restart', 'OLD', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp )
+
+   !    ! OPEN(UNIT=30,FILE='.kiss_restart')
+   !    WRITE(inum,*) x
+   !    WRITE(inum,*) y
+   !    WRITE(inum,*) z
+   !    WRITE(inum,*) w
+   !    CALL flush(inum)
+
+   !  END SUBROUTINE kiss_save
+
+
+   !  SUBROUTINE kiss_load
+   !    !! --------------------------------------------------------------------
+   !    !!                  ***  ROUTINE kiss_load  ***
+   !    !!
+   !    !! ** Purpose :   Load the saved state of KISS random number generator
+   !    !!
+   !    !! --------------------------------------------------------------------
+   !    IMPLICIT NONE
+   !    LOGICAL :: filexists
+   ! Use ctl_opn routine rather than fortran intrinsic functions
+   !    INQUIRE(FILE='.kiss_restart',EXIST=filexists)
+   !    IF (filexists) THEN
+   !       OPEN(UNIT=30,FILE='.kiss_restart')
+   !       READ(30,*) x
+   !       READ(30,*) y
+   !       READ(30,*) z
+   !       READ(30,*) w
+   !       CLOSE(30)
+   !    ENDIF
+
+   ! END SUBROUTINE kiss_load
+
+
+   SUBROUTINE kiss_uniform(uran)
+      !! --------------------------------------------------------------------
+      !!                  ***  ROUTINE kiss_uniform  ***
+      !!
+      !! ** Purpose :   Real random numbers with uniform distribution in [0,1]
+      !!
+      !! --------------------------------------------------------------------
+      IMPLICIT NONE
+      REAL(KIND=wp) :: uran
+
+      uran = half * ( one + REAL(kiss(),wp) / huge64 )
+
+   END SUBROUTINE kiss_uniform
+
+
+   SUBROUTINE kiss_gaussian(gran)
+      !! --------------------------------------------------------------------
+      !!                  ***  ROUTINE kiss_gaussian  ***
+      !!
+      !! ** Purpose :   Real random numbers with Gaussian distribution N(0,1)
+      !!
+      !! ** Method  :   Generate 2 new Gaussian draws (gran1 and gran2)
+      !!                from 2 uniform draws on [-1,1] (u1 and u2),
+      !!                using the Marsaglia polar method
+      !!                (see Devroye, Non-Uniform Random Variate Generation, p. 235-236)
+      !!
+      !! --------------------------------------------------------------------
+      IMPLICIT NONE
+      REAL(KIND=wp) :: gran, u1, u2, rsq, fac
+
+      IF (ig.EQ.1) THEN
+         rsq = two
+         DO WHILE ( (rsq.GE.one).OR. (rsq.EQ.zero) )
+            u1 = REAL(kiss(),wp) / huge64
+            u2 = REAL(kiss(),wp) / huge64
+            rsq = u1*u1 + u2*u2
+         ENDDO
+         fac = SQRT(-two*LOG(rsq)/rsq)
+         gran1 = u1 * fac
+         gran2 = u2 * fac
+      ENDIF
+
+      ! Output one of the 2 draws
+      IF (ig.EQ.1) THEN
+         gran = gran1 ; ig = 2
+      ELSE
+         gran = gran2 ; ig = 1
+      ENDIF
+
+   END SUBROUTINE kiss_gaussian
+
+
+   SUBROUTINE kiss_gamma(gamr,k)
+      !! --------------------------------------------------------------------
+      !!                  ***  ROUTINE kiss_gamma  ***
+      !!
+      !! ** Purpose :   Real random numbers with Gamma distribution Gamma(k,1)
+      !!
+      !! --------------------------------------------------------------------
+      IMPLICIT NONE
+      REAL(KIND=wp), PARAMETER :: p1 = 4.5_8
+      REAL(KIND=wp), PARAMETER :: p2 = 2.50407739677627_8  ! 1+LOG(9/2)
+      REAL(KIND=wp), PARAMETER :: p3 = 1.38629436111989_8  ! LOG(4)
+      REAL(KIND=wp) :: gamr, k, u1, u2, b, c, d, xx, yy, zz, rr, ee
+      LOGICAL :: accepted
+
+      IF (k.GT.one) THEN
+         ! Cheng's rejection algorithm
+         ! (see Devroye, Non-Uniform Random Variate Generation, p. 413)
+         b = k - p3 ; d = SQRT(two*k-one) ; c = k + d
+
+         accepted=.FALSE.
+         DO WHILE (.NOT.accepted)
+            CALL kiss_uniform(u1)
+            yy = LOG(u1/(one-u1)) / d  ! Mistake in Devroye: "* k" instead of "/ d"
+            xx = k * EXP(yy)
+            rr = b + c * yy - xx
+            CALL kiss_uniform(u2)
+            zz = u1 * u1 * u2
+
+            accepted = rr .GE. (zz*p1-p2)
+            IF (.NOT.accepted) accepted =  rr .GE. LOG(zz)
+         ENDDO
+
+         gamr = xx
+
+      ELSEIF (k.LT.one) THEN
+        ! Rejection from the Weibull density
+        ! (see Devroye, Non-Uniform Random Variate Generation, p. 415)
+        c = one/k ; d = (one-k) * EXP( (k/(one-k)) * LOG(k) )
+
+        accepted=.FALSE.
+        DO WHILE (.NOT.accepted)
+           CALL kiss_uniform(u1)
+           zz = -LOG(u1)
+           xx = EXP( c * LOG(zz) )
+           CALL kiss_uniform(u2)
+           ee = -LOG(u2)
+
+           accepted = (zz+ee) .GE. (d+xx)  ! Mistake in Devroye: "LE" instead of "GE"
+        ENDDO
+
+        gamr = xx
+
+      ELSE
+         ! Exponential distribution
+         CALL kiss_uniform(u1)
+         gamr = -LOG(u1)
+
+      ENDIF
+
+   END SUBROUTINE kiss_gamma
+
+
+   SUBROUTINE kiss_sample(a,n,k)
+      !! --------------------------------------------------------------------
+      !!                  ***  ROUTINE kiss_sample  ***
+      !!
+      !! ** Purpose :   Select a random sample of size k from a set of n integers
+      !!
+      !! ** Method  :   The sample is output in the first k elements of a
+      !!                Set k equal to n to obtain a random permutation
+      !!                  of the whole set of integers
+      !!
+      !! --------------------------------------------------------------------
+      IMPLICIT NONE
+      INTEGER(KIND=i8), DIMENSION(:) :: a
+      INTEGER(KIND=i8) :: n, k, i, j, atmp
+      REAL(KIND=wp) :: uran
+
+      ! Select the sample using the swapping method
+      ! (see Devroye, Non-Uniform Random Variate Generation, p. 612)
+      DO i=1,k
+         ! Randomly select the swapping element between i and n (inclusive)
+         CALL kiss_uniform(uran)
+         j = i - 1 + CEILING( REAL(n-i+1,8) * uran )
+         ! Swap elements i and j
+         atmp = a(i) ; a(i) = a(j) ; a(j) = atmp
+      ENDDO
+
+   END SUBROUTINE kiss_sample
+!$AGRIF_END_DO_NOT_TREAT
+END MODULE storng
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/TRA/eosbn2.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/TRA/eosbn2.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/TRA/eosbn2.F90	(revision 9570)
@@ -0,0 +1,1705 @@
+MODULE eosbn2
+   !!==============================================================================
+   !!                       ***  MODULE  eosbn2  ***
+   !! Equation Of Seawater : in situ density - Brunt-Vaisala frequency
+   !!==============================================================================
+   !! History :  OPA  ! 1989-03  (O. Marti)  Original code
+   !!            6.0  ! 1994-07  (G. Madec, M. Imbard)  add bn2
+   !!            6.0  ! 1994-08  (G. Madec)  Add Jackett & McDougall eos
+   !!            7.0  ! 1996-01  (G. Madec)  statement function for e3
+   !!            8.1  ! 1997-07  (G. Madec)  density instead of volumic mass
+   !!             -   ! 1999-02  (G. Madec, N. Grima) semi-implicit pressure gradient
+   !!            8.2  ! 2001-09  (M. Ben Jelloul)  bugfix on linear eos
+   !!   NEMO     1.0  ! 2002-10  (G. Madec)  add eos_init
+   !!             -   ! 2002-11  (G. Madec, A. Bozec)  partial step, eos_insitu_2d
+   !!             -   ! 2003-08  (G. Madec)  F90, free form
+   !!            3.0  ! 2006-08  (G. Madec)  add tfreez function (now eos_fzp function)
+   !!            3.3  ! 2010-05  (C. Ethe, G. Madec)  merge TRC-TRA
+   !!             -   ! 2010-10  (G. Nurser, G. Madec)  add alpha/beta used in ldfslp
+   !!            3.7  ! 2012-03  (F. Roquet, G. Madec)  add primitive of alpha and beta used in PE computation
+   !!             -   ! 2012-05  (F. Roquet)  add Vallis and original JM95 equation of state
+   !!             -   ! 2013-04  (F. Roquet, G. Madec)  add eos_rab, change bn2 computation and reorganize the module
+   !!             -   ! 2014-09  (F. Roquet)  add TEOS-10, S-EOS, and modify EOS-80
+   !!             -   ! 2015-06  (P.A. Bouttier) eos_fzp functions changed to subroutines for AGRIF
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   eos           : generic interface of the equation of state
+   !!   eos_insitu    : Compute the in situ density
+   !!   eos_insitu_pot: Compute the insitu and surface referenced potential volumic mass
+   !!   eos_insitu_2d : Compute the in situ density for 2d fields
+   !!   bn2           : Compute the Brunt-Vaisala frequency
+   !!   eos_rab       : generic interface of in situ thermal/haline expansion ratio 
+   !!   eos_rab_3d    : compute in situ thermal/haline expansion ratio
+   !!   eos_rab_2d    : compute in situ thermal/haline expansion ratio for 2d fields
+   !!   eos_fzp_2d    : freezing temperature for 2d fields
+   !!   eos_fzp_0d    : freezing temperature for scalar
+   !!   eos_init      : set eos parameters (namelist)
+   !!----------------------------------------------------------------------
+   USE dom_oce        ! ocean space and time domain
+   USE phycst         ! physical constants
+   USE stopar         ! Stochastic T/S fluctuations
+   USE stopts         ! Stochastic T/S fluctuations
+   !
+   USE in_out_manager ! I/O manager
+   USE lib_mpp        ! MPP library
+   USE lib_fortran    ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined)  
+   USE prtctl         ! Print control
+   USE lbclnk         ! ocean lateral boundary conditions
+   USE timing         ! Timing
+
+   IMPLICIT NONE
+   PRIVATE
+
+   !                  !! * Interface
+   INTERFACE eos
+      MODULE PROCEDURE eos_insitu, eos_insitu_pot, eos_insitu_2d
+   END INTERFACE
+   !
+   INTERFACE eos_rab
+      MODULE PROCEDURE rab_3d, rab_2d, rab_0d
+   END INTERFACE
+   !
+   INTERFACE eos_fzp 
+      MODULE PROCEDURE eos_fzp_2d, eos_fzp_0d
+   END INTERFACE
+   !
+   PUBLIC   eos            ! called by step, istate, tranpc and zpsgrd modules
+   PUBLIC   bn2            ! called by step module
+   PUBLIC   eos_rab        ! called by ldfslp, zdfddm, trabbl
+   PUBLIC   eos_pt_from_ct ! called by sbcssm
+   PUBLIC   eos_fzp        ! called by traadv_cen2 and sbcice_... modules
+   PUBLIC   eos_pen        ! used for pe diagnostics in trdpen module
+   PUBLIC   eos_init       ! called by istate module
+
+   !                               !!** Namelist nameos **
+   LOGICAL , PUBLIC ::   ln_TEOS10   ! determine if eos_pt_from_ct is used to compute sst_m
+   LOGICAL , PUBLIC ::   ln_EOS80   ! determine if eos_pt_from_ct is used to compute sst_m
+   LOGICAL , PUBLIC ::   ln_SEOS   ! determine if eos_pt_from_ct is used to compute sst_m
+
+   ! Parameters
+   LOGICAL , PUBLIC    ::   l_useCT         ! =T in ln_TEOS10=T (i.e. use eos_pt_from_ct to compute sst_m), =F otherwise
+   INTEGER , PUBLIC    ::   neos            ! Identifier for equation of state used
+
+   INTEGER , PARAMETER ::   np_teos10 = -1  ! parameter for using TEOS10
+   INTEGER , PARAMETER ::   np_eos80  =  0  ! parameter for using EOS80
+   INTEGER , PARAMETER ::   np_seos   = 1   ! parameter for using Simplified Equation of state
+
+   !                               !!!  simplified eos coefficients (default value: Vallis 2006)
+   REAL(wp) ::   rn_a0      = 1.6550e-1_wp     ! thermal expansion coeff. 
+   REAL(wp) ::   rn_b0      = 7.6554e-1_wp     ! saline  expansion coeff. 
+   REAL(wp) ::   rn_lambda1 = 5.9520e-2_wp     ! cabbeling coeff. in T^2        
+   REAL(wp) ::   rn_lambda2 = 5.4914e-4_wp     ! cabbeling coeff. in S^2        
+   REAL(wp) ::   rn_mu1     = 1.4970e-4_wp     ! thermobaric coeff. in T  
+   REAL(wp) ::   rn_mu2     = 1.1090e-5_wp     ! thermobaric coeff. in S  
+   REAL(wp) ::   rn_nu      = 2.4341e-3_wp     ! cabbeling coeff. in theta*salt  
+   
+   ! TEOS10/EOS80 parameters
+   REAL(wp) ::   r1_S0, r1_T0, r1_Z0, rdeltaS
+   
+   ! EOS parameters
+   REAL(wp) ::   EOS000 , EOS100 , EOS200 , EOS300 , EOS400 , EOS500 , EOS600
+   REAL(wp) ::   EOS010 , EOS110 , EOS210 , EOS310 , EOS410 , EOS510
+   REAL(wp) ::   EOS020 , EOS120 , EOS220 , EOS320 , EOS420
+   REAL(wp) ::   EOS030 , EOS130 , EOS230 , EOS330
+   REAL(wp) ::   EOS040 , EOS140 , EOS240
+   REAL(wp) ::   EOS050 , EOS150
+   REAL(wp) ::   EOS060
+   REAL(wp) ::   EOS001 , EOS101 , EOS201 , EOS301 , EOS401
+   REAL(wp) ::   EOS011 , EOS111 , EOS211 , EOS311
+   REAL(wp) ::   EOS021 , EOS121 , EOS221
+   REAL(wp) ::   EOS031 , EOS131
+   REAL(wp) ::   EOS041
+   REAL(wp) ::   EOS002 , EOS102 , EOS202
+   REAL(wp) ::   EOS012 , EOS112
+   REAL(wp) ::   EOS022
+   REAL(wp) ::   EOS003 , EOS103
+   REAL(wp) ::   EOS013 
+   
+   ! ALPHA parameters
+   REAL(wp) ::   ALP000 , ALP100 , ALP200 , ALP300 , ALP400 , ALP500
+   REAL(wp) ::   ALP010 , ALP110 , ALP210 , ALP310 , ALP410
+   REAL(wp) ::   ALP020 , ALP120 , ALP220 , ALP320
+   REAL(wp) ::   ALP030 , ALP130 , ALP230
+   REAL(wp) ::   ALP040 , ALP140
+   REAL(wp) ::   ALP050
+   REAL(wp) ::   ALP001 , ALP101 , ALP201 , ALP301
+   REAL(wp) ::   ALP011 , ALP111 , ALP211
+   REAL(wp) ::   ALP021 , ALP121
+   REAL(wp) ::   ALP031
+   REAL(wp) ::   ALP002 , ALP102
+   REAL(wp) ::   ALP012
+   REAL(wp) ::   ALP003
+   
+   ! BETA parameters
+   REAL(wp) ::   BET000 , BET100 , BET200 , BET300 , BET400 , BET500
+   REAL(wp) ::   BET010 , BET110 , BET210 , BET310 , BET410
+   REAL(wp) ::   BET020 , BET120 , BET220 , BET320
+   REAL(wp) ::   BET030 , BET130 , BET230
+   REAL(wp) ::   BET040 , BET140
+   REAL(wp) ::   BET050
+   REAL(wp) ::   BET001 , BET101 , BET201 , BET301
+   REAL(wp) ::   BET011 , BET111 , BET211
+   REAL(wp) ::   BET021 , BET121
+   REAL(wp) ::   BET031
+   REAL(wp) ::   BET002 , BET102
+   REAL(wp) ::   BET012
+   REAL(wp) ::   BET003
+
+   ! PEN parameters
+   REAL(wp) ::   PEN000 , PEN100 , PEN200 , PEN300 , PEN400
+   REAL(wp) ::   PEN010 , PEN110 , PEN210 , PEN310
+   REAL(wp) ::   PEN020 , PEN120 , PEN220
+   REAL(wp) ::   PEN030 , PEN130
+   REAL(wp) ::   PEN040
+   REAL(wp) ::   PEN001 , PEN101 , PEN201
+   REAL(wp) ::   PEN011 , PEN111
+   REAL(wp) ::   PEN021
+   REAL(wp) ::   PEN002 , PEN102
+   REAL(wp) ::   PEN012
+   
+   ! ALPHA_PEN parameters
+   REAL(wp) ::   APE000 , APE100 , APE200 , APE300
+   REAL(wp) ::   APE010 , APE110 , APE210
+   REAL(wp) ::   APE020 , APE120
+   REAL(wp) ::   APE030
+   REAL(wp) ::   APE001 , APE101
+   REAL(wp) ::   APE011
+   REAL(wp) ::   APE002
+
+   ! BETA_PEN parameters
+   REAL(wp) ::   BPE000 , BPE100 , BPE200 , BPE300
+   REAL(wp) ::   BPE010 , BPE110 , BPE210
+   REAL(wp) ::   BPE020 , BPE120
+   REAL(wp) ::   BPE030
+   REAL(wp) ::   BPE001 , BPE101
+   REAL(wp) ::   BPE011
+   REAL(wp) ::   BPE002
+
+   !! * Substitutions
+#  include "vectopt_loop_substitute.h90"
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.7 , NEMO Consortium (2014)
+   !! $Id$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE eos_insitu( pts, prd, pdep )
+      !!----------------------------------------------------------------------
+      !!                   ***  ROUTINE eos_insitu  ***
+      !!
+      !! ** Purpose :   Compute the in situ density (ratio rho/rau0) from
+      !!       potential temperature and salinity using an equation of state
+      !!       selected in the nameos namelist
+      !!
+      !! ** Method  :   prd(t,s,z) = ( rho(t,s,z) - rau0 ) / rau0
+      !!         with   prd    in situ density anomaly      no units
+      !!                t      TEOS10: CT or EOS80: PT      Celsius
+      !!                s      TEOS10: SA or EOS80: SP      TEOS10: g/kg or EOS80: psu
+      !!                z      depth                        meters
+      !!                rho    in situ density              kg/m^3
+      !!                rau0   reference density            kg/m^3
+      !!
+      !!     ln_teos10 : polynomial TEOS-10 equation of state is used for rho(t,s,z).
+      !!         Check value: rho = 1028.21993233072 kg/m^3 for z=3000 dbar, ct=3 Celsius, sa=35.5 g/kg
+      !!
+      !!     ln_eos80 : polynomial EOS-80 equation of state is used for rho(t,s,z).
+      !!         Check value: rho = 1028.35011066567 kg/m^3 for z=3000 dbar, pt=3 Celsius, sp=35.5 psu
+      !!
+      !!     ln_seos : simplified equation of state
+      !!              prd(t,s,z) = ( -a0*(1+lambda/2*(T-T0)+mu*z+nu*(S-S0))*(T-T0) + b0*(S-S0) ) / rau0
+      !!              linear case function of T only: rn_alpha<>0, other coefficients = 0
+      !!              linear eos function of T and S: rn_alpha and rn_beta<>0, other coefficients=0
+      !!              Vallis like equation: use default values of coefficients
+      !!
+      !! ** Action  :   compute prd , the in situ density (no units)
+      !!
+      !! References :   Roquet et al, Ocean Modelling, in preparation (2014)
+      !!                Vallis, Atmospheric and Oceanic Fluid Dynamics, 2006
+      !!                TEOS-10 Manual, 2010
+      !!----------------------------------------------------------------------
+      REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in   ) ::   pts   ! 1 : potential temperature  [Celsius]
+      !                                                               ! 2 : salinity               [psu]
+      REAL(wp), DIMENSION(jpi,jpj,jpk     ), INTENT(  out) ::   prd   ! in situ density            [-]
+      REAL(wp), DIMENSION(jpi,jpj,jpk     ), INTENT(in   ) ::   pdep  ! depth                      [m]
+      !
+      INTEGER  ::   ji, jj, jk                ! dummy loop indices
+      REAL(wp) ::   zt , zh , zs , ztm        ! local scalars
+      REAL(wp) ::   zn , zn0, zn1, zn2, zn3   !   -      -
+      !!----------------------------------------------------------------------
+      !
+      IF( ln_timing )   CALL timing_start('eos-insitu')
+      !
+      SELECT CASE( neos )
+      !
+      CASE( np_teos10, np_eos80 )                !==  polynomial TEOS-10 / EOS-80 ==!
+         !
+         DO jk = 1, jpkm1
+            DO jj = 1, jpj
+               DO ji = 1, jpi
+                  !
+                  zh  = pdep(ji,jj,jk) * r1_Z0                                  ! depth
+                  zt  = pts (ji,jj,jk,jp_tem) * r1_T0                           ! temperature
+                  zs  = SQRT( ABS( pts(ji,jj,jk,jp_sal) + rdeltaS ) * r1_S0 )   ! square root salinity
+                  ztm = tmask(ji,jj,jk)                                         ! tmask
+                  !
+                  zn3 = EOS013*zt   &
+                     &   + EOS103*zs+EOS003
+                     !
+                  zn2 = (EOS022*zt   &
+                     &   + EOS112*zs+EOS012)*zt   &
+                     &   + (EOS202*zs+EOS102)*zs+EOS002
+                     !
+                  zn1 = (((EOS041*zt   &
+                     &   + EOS131*zs+EOS031)*zt   &
+                     &   + (EOS221*zs+EOS121)*zs+EOS021)*zt   &
+                     &   + ((EOS311*zs+EOS211)*zs+EOS111)*zs+EOS011)*zt   &
+                     &   + (((EOS401*zs+EOS301)*zs+EOS201)*zs+EOS101)*zs+EOS001
+                     !
+                  zn0 = (((((EOS060*zt   &
+                     &   + EOS150*zs+EOS050)*zt   &
+                     &   + (EOS240*zs+EOS140)*zs+EOS040)*zt   &
+                     &   + ((EOS330*zs+EOS230)*zs+EOS130)*zs+EOS030)*zt   &
+                     &   + (((EOS420*zs+EOS320)*zs+EOS220)*zs+EOS120)*zs+EOS020)*zt   &
+                     &   + ((((EOS510*zs+EOS410)*zs+EOS310)*zs+EOS210)*zs+EOS110)*zs+EOS010)*zt   &
+                     &   + (((((EOS600*zs+EOS500)*zs+EOS400)*zs+EOS300)*zs+EOS200)*zs+EOS100)*zs+EOS000
+                     !
+                  zn  = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0
+                  !
+                  prd(ji,jj,jk) = (  zn * r1_rau0 - 1._wp  ) * ztm  ! density anomaly (masked)
+                  !
+               END DO
+            END DO
+         END DO
+         !
+      CASE( np_seos )                !==  simplified EOS  ==!
+         !
+         DO jk = 1, jpkm1
+            DO jj = 1, jpj
+               DO ji = 1, jpi
+                  zt  = pts  (ji,jj,jk,jp_tem) - 10._wp
+                  zs  = pts  (ji,jj,jk,jp_sal) - 35._wp
+                  zh  = pdep (ji,jj,jk)
+                  ztm = tmask(ji,jj,jk)
+                  !
+                  zn =  - rn_a0 * ( 1._wp + 0.5_wp*rn_lambda1*zt + rn_mu1*zh ) * zt   &
+                     &  + rn_b0 * ( 1._wp - 0.5_wp*rn_lambda2*zs - rn_mu2*zh ) * zs   &
+                     &  - rn_nu * zt * zs
+                     !                                 
+                  prd(ji,jj,jk) = zn * r1_rau0 * ztm                ! density anomaly (masked)
+               END DO
+            END DO
+         END DO
+         !
+      END SELECT
+      !
+      IF(ln_ctl)   CALL prt_ctl( tab3d_1=prd, clinfo1=' eos-insitu  : ', kdim=jpk )
+      !
+      IF( ln_timing )   CALL timing_stop('eos-insitu')
+      !
+   END SUBROUTINE eos_insitu
+
+
+   SUBROUTINE eos_insitu_pot( pts, prd, prhop, pdep )
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE eos_insitu_pot  ***
+      !!
+      !! ** Purpose :   Compute the in situ density (ratio rho/rau0) and the
+      !!      potential volumic mass (Kg/m3) from potential temperature and
+      !!      salinity fields using an equation of state selected in the
+      !!     namelist.
+      !!
+      !! ** Action  : - prd  , the in situ density (no units)
+      !!              - prhop, the potential volumic mass (Kg/m3)
+      !!
+      !!----------------------------------------------------------------------
+      REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in   ) ::   pts    ! 1 : potential temperature  [Celsius]
+      !                                                                ! 2 : salinity               [psu]
+      REAL(wp), DIMENSION(jpi,jpj,jpk     ), INTENT(  out) ::   prd    ! in situ density            [-]
+      REAL(wp), DIMENSION(jpi,jpj,jpk     ), INTENT(  out) ::   prhop  ! potential density (surface referenced)
+      REAL(wp), DIMENSION(jpi,jpj,jpk     ), INTENT(in   ) ::   pdep   ! depth                      [m]
+      !
+      INTEGER  ::   ji, jj, jk, jsmp             ! dummy loop indices
+      INTEGER  ::   jdof
+      REAL(wp) ::   zt , zh , zstemp, zs , ztm   ! local scalars
+      REAL(wp) ::   zn , zn0, zn1, zn2, zn3      !   -      -
+      REAL(wp), DIMENSION(:), ALLOCATABLE :: zn0_sto, zn_sto, zsign    ! local vectors
+      !!----------------------------------------------------------------------
+      !
+      IF( ln_timing )   CALL timing_start('eos-pot')
+      !
+      SELECT CASE ( neos )
+      !
+      CASE( np_teos10, np_eos80 )                !==  polynomial TEOS-10 / EOS-80 ==!
+         !
+         ! Stochastic equation of state
+         IF ( ln_sto_eos ) THEN
+            ALLOCATE(zn0_sto(1:2*nn_sto_eos))
+            ALLOCATE(zn_sto(1:2*nn_sto_eos))
+            ALLOCATE(zsign(1:2*nn_sto_eos))
+            DO jsmp = 1, 2*nn_sto_eos, 2
+              zsign(jsmp)   = 1._wp
+              zsign(jsmp+1) = -1._wp
+            END DO
+            !
+            DO jk = 1, jpkm1
+               DO jj = 1, jpj
+                  DO ji = 1, jpi
+                     !
+                     ! compute density (2*nn_sto_eos) times:
+                     ! (1) for t+dt, s+ds (with the random TS fluctutation computed in sto_pts)
+                     ! (2) for t-dt, s-ds (with the opposite fluctuation)
+                     DO jsmp = 1, nn_sto_eos*2
+                        jdof   = (jsmp + 1) / 2
+                        zh     = pdep(ji,jj,jk) * r1_Z0                                  ! depth
+                        zt     = (pts (ji,jj,jk,jp_tem) + pts_ran(ji,jj,jk,jp_tem,jdof) * zsign(jsmp)) * r1_T0    ! temperature
+                        zstemp = pts  (ji,jj,jk,jp_sal) + pts_ran(ji,jj,jk,jp_sal,jdof) * zsign(jsmp)
+                        zs     = SQRT( ABS( zstemp + rdeltaS ) * r1_S0 )   ! square root salinity
+                        ztm    = tmask(ji,jj,jk)                                         ! tmask
+                        !
+                        zn3 = EOS013*zt   &
+                           &   + EOS103*zs+EOS003
+                           !
+                        zn2 = (EOS022*zt   &
+                           &   + EOS112*zs+EOS012)*zt   &
+                           &   + (EOS202*zs+EOS102)*zs+EOS002
+                           !
+                        zn1 = (((EOS041*zt   &
+                           &   + EOS131*zs+EOS031)*zt   &
+                           &   + (EOS221*zs+EOS121)*zs+EOS021)*zt   &
+                           &   + ((EOS311*zs+EOS211)*zs+EOS111)*zs+EOS011)*zt   &
+                           &   + (((EOS401*zs+EOS301)*zs+EOS201)*zs+EOS101)*zs+EOS001
+                           !
+                        zn0_sto(jsmp) = (((((EOS060*zt   &
+                           &   + EOS150*zs+EOS050)*zt   &
+                           &   + (EOS240*zs+EOS140)*zs+EOS040)*zt   &
+                           &   + ((EOS330*zs+EOS230)*zs+EOS130)*zs+EOS030)*zt   &
+                           &   + (((EOS420*zs+EOS320)*zs+EOS220)*zs+EOS120)*zs+EOS020)*zt   &
+                           &   + ((((EOS510*zs+EOS410)*zs+EOS310)*zs+EOS210)*zs+EOS110)*zs+EOS010)*zt   &
+                           &   + (((((EOS600*zs+EOS500)*zs+EOS400)*zs+EOS300)*zs+EOS200)*zs+EOS100)*zs+EOS000
+                           !
+                        zn_sto(jsmp)  = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0_sto(jsmp)
+                     END DO
+                     !
+                     ! compute stochastic density as the mean of the (2*nn_sto_eos) densities
+                     prhop(ji,jj,jk) = 0._wp ; prd(ji,jj,jk) = 0._wp
+                     DO jsmp = 1, nn_sto_eos*2
+                        prhop(ji,jj,jk) = prhop(ji,jj,jk) + zn0_sto(jsmp)                      ! potential density referenced at the surface
+                        !
+                        prd(ji,jj,jk) = prd(ji,jj,jk) + (  zn_sto(jsmp) * r1_rau0 - 1._wp  )   ! density anomaly (masked)
+                     END DO
+                     prhop(ji,jj,jk) = 0.5_wp * prhop(ji,jj,jk) * ztm / nn_sto_eos
+                     prd  (ji,jj,jk) = 0.5_wp * prd  (ji,jj,jk) * ztm / nn_sto_eos
+                  END DO
+               END DO
+            END DO
+            DEALLOCATE(zn0_sto,zn_sto,zsign)
+         ! Non-stochastic equation of state
+         ELSE
+            DO jk = 1, jpkm1
+               DO jj = 1, jpj
+                  DO ji = 1, jpi
+                     !
+                     zh  = pdep(ji,jj,jk) * r1_Z0                                  ! depth
+                     zt  = pts (ji,jj,jk,jp_tem) * r1_T0                           ! temperature
+                     zs  = SQRT( ABS( pts(ji,jj,jk,jp_sal) + rdeltaS ) * r1_S0 )   ! square root salinity
+                     ztm = tmask(ji,jj,jk)                                         ! tmask
+                     !
+                     zn3 = EOS013*zt   &
+                        &   + EOS103*zs+EOS003
+                        !
+                     zn2 = (EOS022*zt   &
+                        &   + EOS112*zs+EOS012)*zt   &
+                        &   + (EOS202*zs+EOS102)*zs+EOS002
+                        !
+                     zn1 = (((EOS041*zt   &
+                        &   + EOS131*zs+EOS031)*zt   &
+                        &   + (EOS221*zs+EOS121)*zs+EOS021)*zt   &
+                        &   + ((EOS311*zs+EOS211)*zs+EOS111)*zs+EOS011)*zt   &
+                        &   + (((EOS401*zs+EOS301)*zs+EOS201)*zs+EOS101)*zs+EOS001
+                        !
+                     zn0 = (((((EOS060*zt   &
+                        &   + EOS150*zs+EOS050)*zt   &
+                        &   + (EOS240*zs+EOS140)*zs+EOS040)*zt   &
+                        &   + ((EOS330*zs+EOS230)*zs+EOS130)*zs+EOS030)*zt   &
+                        &   + (((EOS420*zs+EOS320)*zs+EOS220)*zs+EOS120)*zs+EOS020)*zt   &
+                        &   + ((((EOS510*zs+EOS410)*zs+EOS310)*zs+EOS210)*zs+EOS110)*zs+EOS010)*zt   &
+                        &   + (((((EOS600*zs+EOS500)*zs+EOS400)*zs+EOS300)*zs+EOS200)*zs+EOS100)*zs+EOS000
+                        !
+                     zn  = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0
+                     !
+                     prhop(ji,jj,jk) = zn0 * ztm                           ! potential density referenced at the surface
+                     !
+                     prd(ji,jj,jk) = (  zn * r1_rau0 - 1._wp  ) * ztm      ! density anomaly (masked)
+                  END DO
+               END DO
+            END DO
+         ENDIF
+         
+      CASE( np_seos )                !==  simplified EOS  ==!
+         !
+         DO jk = 1, jpkm1
+            DO jj = 1, jpj
+               DO ji = 1, jpi
+                  zt  = pts  (ji,jj,jk,jp_tem) - 10._wp
+                  zs  = pts  (ji,jj,jk,jp_sal) - 35._wp
+                  zh  = pdep (ji,jj,jk)
+                  ztm = tmask(ji,jj,jk)
+                  !                                                     ! potential density referenced at the surface
+                  zn =  - rn_a0 * ( 1._wp + 0.5_wp*rn_lambda1*zt ) * zt   &
+                     &  + rn_b0 * ( 1._wp - 0.5_wp*rn_lambda2*zs ) * zs   &
+                     &  - rn_nu * zt * zs
+                  prhop(ji,jj,jk) = ( rau0 + zn ) * ztm
+                  !                                                     ! density anomaly (masked)
+                  zn = zn - ( rn_a0 * rn_mu1 * zt + rn_b0 * rn_mu2 * zs ) * zh
+                  prd(ji,jj,jk) = zn * r1_rau0 * ztm
+                  !
+               END DO
+            END DO
+         END DO
+         !
+      END SELECT
+      !
+      IF(ln_ctl)   CALL prt_ctl( tab3d_1=prd, clinfo1=' eos-pot: ', tab3d_2=prhop, clinfo2=' pot : ', kdim=jpk )
+      !
+      IF( ln_timing )   CALL timing_stop('eos-pot')
+      !
+   END SUBROUTINE eos_insitu_pot
+
+
+   SUBROUTINE eos_insitu_2d( pts, pdep, prd )
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE eos_insitu_2d  ***
+      !!
+      !! ** Purpose :   Compute the in situ density (ratio rho/rau0) from
+      !!      potential temperature and salinity using an equation of state
+      !!      selected in the nameos namelist. * 2D field case
+      !!
+      !! ** Action  : - prd , the in situ density (no units) (unmasked)
+      !!
+      !!----------------------------------------------------------------------
+      REAL(wp), DIMENSION(jpi,jpj,jpts), INTENT(in   ) ::   pts   ! 1 : potential temperature  [Celsius]
+      !                                                           ! 2 : salinity               [psu]
+      REAL(wp), DIMENSION(jpi,jpj)     , INTENT(in   ) ::   pdep  ! depth                      [m]
+      REAL(wp), DIMENSION(jpi,jpj)     , INTENT(  out) ::   prd   ! in situ density
+      !
+      INTEGER  ::   ji, jj, jk                ! dummy loop indices
+      REAL(wp) ::   zt , zh , zs              ! local scalars
+      REAL(wp) ::   zn , zn0, zn1, zn2, zn3   !   -      -
+      !!----------------------------------------------------------------------
+      !
+      IF( ln_timing )   CALL timing_start('eos2d')
+      !
+      prd(:,:) = 0._wp
+      !
+      SELECT CASE( neos )
+      !
+      CASE( np_teos10, np_eos80 )                !==  polynomial TEOS-10 / EOS-80 ==!
+         !
+         DO jj = 1, jpjm1
+            DO ji = 1, fs_jpim1   ! vector opt.
+               !
+               zh  = pdep(ji,jj) * r1_Z0                                  ! depth
+               zt  = pts (ji,jj,jp_tem) * r1_T0                           ! temperature
+               zs  = SQRT( ABS( pts(ji,jj,jp_sal) + rdeltaS ) * r1_S0 )   ! square root salinity
+               !
+               zn3 = EOS013*zt   &
+                  &   + EOS103*zs+EOS003
+                  !
+               zn2 = (EOS022*zt   &
+                  &   + EOS112*zs+EOS012)*zt   &
+                  &   + (EOS202*zs+EOS102)*zs+EOS002
+                  !
+               zn1 = (((EOS041*zt   &
+                  &   + EOS131*zs+EOS031)*zt   &
+                  &   + (EOS221*zs+EOS121)*zs+EOS021)*zt   &
+                  &   + ((EOS311*zs+EOS211)*zs+EOS111)*zs+EOS011)*zt   &
+                  &   + (((EOS401*zs+EOS301)*zs+EOS201)*zs+EOS101)*zs+EOS001
+                  !
+               zn0 = (((((EOS060*zt   &
+                  &   + EOS150*zs+EOS050)*zt   &
+                  &   + (EOS240*zs+EOS140)*zs+EOS040)*zt   &
+                  &   + ((EOS330*zs+EOS230)*zs+EOS130)*zs+EOS030)*zt   &
+                  &   + (((EOS420*zs+EOS320)*zs+EOS220)*zs+EOS120)*zs+EOS020)*zt   &
+                  &   + ((((EOS510*zs+EOS410)*zs+EOS310)*zs+EOS210)*zs+EOS110)*zs+EOS010)*zt   &
+                  &   + (((((EOS600*zs+EOS500)*zs+EOS400)*zs+EOS300)*zs+EOS200)*zs+EOS100)*zs+EOS000
+                  !
+               zn  = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0
+               !
+               prd(ji,jj) = zn * r1_rau0 - 1._wp               ! unmasked in situ density anomaly
+               !
+            END DO
+         END DO
+         !
+         CALL lbc_lnk( prd, 'T', 1. )                    ! Lateral boundary conditions
+         !
+      CASE( np_seos )                !==  simplified EOS  ==!
+         !
+         DO jj = 1, jpjm1
+            DO ji = 1, fs_jpim1   ! vector opt.
+               !
+               zt    = pts  (ji,jj,jp_tem)  - 10._wp
+               zs    = pts  (ji,jj,jp_sal)  - 35._wp
+               zh    = pdep (ji,jj)                         ! depth at the partial step level
+               !
+               zn =  - rn_a0 * ( 1._wp + 0.5_wp*rn_lambda1*zt + rn_mu1*zh ) * zt   &
+                  &  + rn_b0 * ( 1._wp - 0.5_wp*rn_lambda2*zs - rn_mu2*zh ) * zs   &
+                  &  - rn_nu * zt * zs
+                  !
+               prd(ji,jj) = zn * r1_rau0               ! unmasked in situ density anomaly
+               !
+            END DO
+         END DO
+         !
+         CALL lbc_lnk( prd, 'T', 1. )                    ! Lateral boundary conditions
+         !
+      END SELECT
+      !
+      IF(ln_ctl)   CALL prt_ctl( tab2d_1=prd, clinfo1=' eos2d: ' )
+      !
+      IF( ln_timing )   CALL timing_stop('eos2d')
+      !
+   END SUBROUTINE eos_insitu_2d
+
+
+   SUBROUTINE rab_3d( pts, pab )
+      !!----------------------------------------------------------------------
+      !!                 ***  ROUTINE rab_3d  ***
+      !!
+      !! ** Purpose :   Calculates thermal/haline expansion ratio at T-points
+      !!
+      !! ** Method  :   calculates alpha / beta at T-points
+      !!
+      !! ** Action  : - pab     : thermal/haline expansion ratio at T-points
+      !!----------------------------------------------------------------------
+      REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in   ) ::   pts   ! pot. temperature & salinity
+      REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(  out) ::   pab   ! thermal/haline expansion ratio
+      !
+      INTEGER  ::   ji, jj, jk                ! dummy loop indices
+      REAL(wp) ::   zt , zh , zs , ztm        ! local scalars
+      REAL(wp) ::   zn , zn0, zn1, zn2, zn3   !   -      -
+      !!----------------------------------------------------------------------
+      !
+      IF( ln_timing )   CALL timing_start('rab_3d')
+      !
+      SELECT CASE ( neos )
+      !
+      CASE( np_teos10, np_eos80 )                !==  polynomial TEOS-10 / EOS-80 ==!
+         !
+         DO jk = 1, jpkm1
+            DO jj = 1, jpj
+               DO ji = 1, jpi
+                  !
+                  zh  = gdept_n(ji,jj,jk) * r1_Z0                                ! depth
+                  zt  = pts (ji,jj,jk,jp_tem) * r1_T0                           ! temperature
+                  zs  = SQRT( ABS( pts(ji,jj,jk,jp_sal) + rdeltaS ) * r1_S0 )   ! square root salinity
+                  ztm = tmask(ji,jj,jk)                                         ! tmask
+                  !
+                  ! alpha
+                  zn3 = ALP003
+                  !
+                  zn2 = ALP012*zt + ALP102*zs+ALP002
+                  !
+                  zn1 = ((ALP031*zt   &
+                     &   + ALP121*zs+ALP021)*zt   &
+                     &   + (ALP211*zs+ALP111)*zs+ALP011)*zt   &
+                     &   + ((ALP301*zs+ALP201)*zs+ALP101)*zs+ALP001
+                     !
+                  zn0 = ((((ALP050*zt   &
+                     &   + ALP140*zs+ALP040)*zt   &
+                     &   + (ALP230*zs+ALP130)*zs+ALP030)*zt   &
+                     &   + ((ALP320*zs+ALP220)*zs+ALP120)*zs+ALP020)*zt   &
+                     &   + (((ALP410*zs+ALP310)*zs+ALP210)*zs+ALP110)*zs+ALP010)*zt   &
+                     &   + ((((ALP500*zs+ALP400)*zs+ALP300)*zs+ALP200)*zs+ALP100)*zs+ALP000
+                     !
+                  zn  = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0
+                  !
+                  pab(ji,jj,jk,jp_tem) = zn * r1_rau0 * ztm
+                  !
+                  ! beta
+                  zn3 = BET003
+                  !
+                  zn2 = BET012*zt + BET102*zs+BET002
+                  !
+                  zn1 = ((BET031*zt   &
+                     &   + BET121*zs+BET021)*zt   &
+                     &   + (BET211*zs+BET111)*zs+BET011)*zt   &
+                     &   + ((BET301*zs+BET201)*zs+BET101)*zs+BET001
+                     !
+                  zn0 = ((((BET050*zt   &
+                     &   + BET140*zs+BET040)*zt   &
+                     &   + (BET230*zs+BET130)*zs+BET030)*zt   &
+                     &   + ((BET320*zs+BET220)*zs+BET120)*zs+BET020)*zt   &
+                     &   + (((BET410*zs+BET310)*zs+BET210)*zs+BET110)*zs+BET010)*zt   &
+                     &   + ((((BET500*zs+BET400)*zs+BET300)*zs+BET200)*zs+BET100)*zs+BET000
+                     !
+                  zn  = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0
+                  !
+                  pab(ji,jj,jk,jp_sal) = zn / zs * r1_rau0 * ztm
+                  !
+               END DO
+            END DO
+         END DO
+         !
+      CASE( np_seos )                  !==  simplified EOS  ==!
+         !
+         DO jk = 1, jpkm1
+            DO jj = 1, jpj
+               DO ji = 1, jpi
+                  zt  = pts (ji,jj,jk,jp_tem) - 10._wp   ! pot. temperature anomaly (t-T0)
+                  zs  = pts (ji,jj,jk,jp_sal) - 35._wp   ! abs. salinity anomaly (s-S0)
+                  zh  = gdept_n(ji,jj,jk)                ! depth in meters at t-point
+                  ztm = tmask(ji,jj,jk)                  ! land/sea bottom mask = surf. mask
+                  !
+                  zn  = rn_a0 * ( 1._wp + rn_lambda1*zt + rn_mu1*zh ) + rn_nu*zs
+                  pab(ji,jj,jk,jp_tem) = zn * r1_rau0 * ztm   ! alpha
+                  !
+                  zn  = rn_b0 * ( 1._wp - rn_lambda2*zs - rn_mu2*zh ) - rn_nu*zt
+                  pab(ji,jj,jk,jp_sal) = zn * r1_rau0 * ztm   ! beta
+                  !
+               END DO
+            END DO
+         END DO
+         !
+      CASE DEFAULT
+         IF(lwp) WRITE(numout,cform_err)
+         IF(lwp) WRITE(numout,*) '          bad flag value for neos = ', neos
+         nstop = nstop + 1
+         !
+      END SELECT
+      !
+      IF(ln_ctl)   CALL prt_ctl( tab3d_1=pab(:,:,:,jp_tem), clinfo1=' rab_3d_t: ', &
+         &                       tab3d_2=pab(:,:,:,jp_sal), clinfo2=' rab_3d_s : ', kdim=jpk )
+      !
+      IF( ln_timing )   CALL timing_stop('rab_3d')
+      !
+   END SUBROUTINE rab_3d
+
+
+   SUBROUTINE rab_2d( pts, pdep, pab )
+      !!----------------------------------------------------------------------
+      !!                 ***  ROUTINE rab_2d  ***
+      !!
+      !! ** Purpose :   Calculates thermal/haline expansion ratio for a 2d field (unmasked)
+      !!
+      !! ** Action  : - pab     : thermal/haline expansion ratio at T-points
+      !!----------------------------------------------------------------------
+      REAL(wp), DIMENSION(jpi,jpj,jpts)    , INTENT(in   ) ::   pts    ! pot. temperature & salinity
+      REAL(wp), DIMENSION(jpi,jpj)         , INTENT(in   ) ::   pdep   ! depth                  [m]
+      REAL(wp), DIMENSION(jpi,jpj,jpts)    , INTENT(  out) ::   pab    ! thermal/haline expansion ratio
+      !
+      INTEGER  ::   ji, jj, jk                ! dummy loop indices
+      REAL(wp) ::   zt , zh , zs              ! local scalars
+      REAL(wp) ::   zn , zn0, zn1, zn2, zn3   !   -      -
+      !!----------------------------------------------------------------------
+      !
+      IF( ln_timing )   CALL timing_start('rab_2d')
+      !
+      pab(:,:,:) = 0._wp
+      !
+      SELECT CASE ( neos )
+      !
+      CASE( np_teos10, np_eos80 )                !==  polynomial TEOS-10 / EOS-80 ==!
+         !
+         DO jj = 1, jpjm1
+            DO ji = 1, fs_jpim1   ! vector opt.
+               !
+               zh  = pdep(ji,jj) * r1_Z0                                  ! depth
+               zt  = pts (ji,jj,jp_tem) * r1_T0                           ! temperature
+               zs  = SQRT( ABS( pts(ji,jj,jp_sal) + rdeltaS ) * r1_S0 )   ! square root salinity
+               !
+               ! alpha
+               zn3 = ALP003
+               !
+               zn2 = ALP012*zt + ALP102*zs+ALP002
+               !
+               zn1 = ((ALP031*zt   &
+                  &   + ALP121*zs+ALP021)*zt   &
+                  &   + (ALP211*zs+ALP111)*zs+ALP011)*zt   &
+                  &   + ((ALP301*zs+ALP201)*zs+ALP101)*zs+ALP001
+                  !
+               zn0 = ((((ALP050*zt   &
+                  &   + ALP140*zs+ALP040)*zt   &
+                  &   + (ALP230*zs+ALP130)*zs+ALP030)*zt   &
+                  &   + ((ALP320*zs+ALP220)*zs+ALP120)*zs+ALP020)*zt   &
+                  &   + (((ALP410*zs+ALP310)*zs+ALP210)*zs+ALP110)*zs+ALP010)*zt   &
+                  &   + ((((ALP500*zs+ALP400)*zs+ALP300)*zs+ALP200)*zs+ALP100)*zs+ALP000
+                  !
+               zn  = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0
+               !
+               pab(ji,jj,jp_tem) = zn * r1_rau0
+               !
+               ! beta
+               zn3 = BET003
+               !
+               zn2 = BET012*zt + BET102*zs+BET002
+               !
+               zn1 = ((BET031*zt   &
+                  &   + BET121*zs+BET021)*zt   &
+                  &   + (BET211*zs+BET111)*zs+BET011)*zt   &
+                  &   + ((BET301*zs+BET201)*zs+BET101)*zs+BET001
+                  !
+               zn0 = ((((BET050*zt   &
+                  &   + BET140*zs+BET040)*zt   &
+                  &   + (BET230*zs+BET130)*zs+BET030)*zt   &
+                  &   + ((BET320*zs+BET220)*zs+BET120)*zs+BET020)*zt   &
+                  &   + (((BET410*zs+BET310)*zs+BET210)*zs+BET110)*zs+BET010)*zt   &
+                  &   + ((((BET500*zs+BET400)*zs+BET300)*zs+BET200)*zs+BET100)*zs+BET000
+                  !
+               zn  = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0
+               !
+               pab(ji,jj,jp_sal) = zn / zs * r1_rau0
+               !
+               !
+            END DO
+         END DO
+         !                            ! Lateral boundary conditions
+         CALL lbc_lnk_multi( pab(:,:,jp_tem), 'T', 1. , pab(:,:,jp_sal), 'T', 1. )                    
+         !
+      CASE( np_seos )                  !==  simplified EOS  ==!
+         !
+         DO jj = 1, jpjm1
+            DO ji = 1, fs_jpim1   ! vector opt.
+               !
+               zt    = pts  (ji,jj,jp_tem) - 10._wp   ! pot. temperature anomaly (t-T0)
+               zs    = pts  (ji,jj,jp_sal) - 35._wp   ! abs. salinity anomaly (s-S0)
+               zh    = pdep (ji,jj)                   ! depth at the partial step level
+               !
+               zn  = rn_a0 * ( 1._wp + rn_lambda1*zt + rn_mu1*zh ) + rn_nu*zs
+               pab(ji,jj,jp_tem) = zn * r1_rau0   ! alpha
+               !
+               zn  = rn_b0 * ( 1._wp - rn_lambda2*zs - rn_mu2*zh ) - rn_nu*zt
+               pab(ji,jj,jp_sal) = zn * r1_rau0   ! beta
+               !
+            END DO
+         END DO
+         !                            ! Lateral boundary conditions
+         CALL lbc_lnk_multi( pab(:,:,jp_tem), 'T', 1. , pab(:,:,jp_sal), 'T', 1. )                    
+         !
+      CASE DEFAULT
+         IF(lwp) WRITE(numout,cform_err)
+         IF(lwp) WRITE(numout,*) '          bad flag value for neos = ', neos
+         nstop = nstop + 1
+         !
+      END SELECT
+      !
+      IF(ln_ctl)   CALL prt_ctl( tab2d_1=pab(:,:,jp_tem), clinfo1=' rab_2d_t: ', &
+         &                       tab2d_2=pab(:,:,jp_sal), clinfo2=' rab_2d_s : ' )
+      !
+      IF( ln_timing )   CALL timing_stop('rab_2d')
+      !
+   END SUBROUTINE rab_2d
+
+
+   SUBROUTINE rab_0d( pts, pdep, pab )
+      !!----------------------------------------------------------------------
+      !!                 ***  ROUTINE rab_0d  ***
+      !!
+      !! ** Purpose :   Calculates thermal/haline expansion ratio for a 2d field (unmasked)
+      !!
+      !! ** Action  : - pab     : thermal/haline expansion ratio at T-points
+      !!----------------------------------------------------------------------
+      REAL(wp), DIMENSION(jpts)    , INTENT(in   ) ::   pts    ! pot. temperature & salinity
+      REAL(wp),                      INTENT(in   ) ::   pdep   ! depth                  [m]
+      REAL(wp), DIMENSION(jpts)    , INTENT(  out) ::   pab    ! thermal/haline expansion ratio
+      !
+      REAL(wp) ::   zt , zh , zs              ! local scalars
+      REAL(wp) ::   zn , zn0, zn1, zn2, zn3   !   -      -
+      !!----------------------------------------------------------------------
+      !
+      IF( ln_timing )   CALL timing_start('rab_2d')
+      !
+      pab(:) = 0._wp
+      !
+      SELECT CASE ( neos )
+      !
+      CASE( np_teos10, np_eos80 )      !==  polynomial TEOS-10 / EOS-80 ==!
+         !
+         !
+         zh  = pdep * r1_Z0                                  ! depth
+         zt  = pts (jp_tem) * r1_T0                           ! temperature
+         zs  = SQRT( ABS( pts(jp_sal) + rdeltaS ) * r1_S0 )   ! square root salinity
+         !
+         ! alpha
+         zn3 = ALP003
+         !
+         zn2 = ALP012*zt + ALP102*zs+ALP002
+         !
+         zn1 = ((ALP031*zt   &
+            &   + ALP121*zs+ALP021)*zt   &
+            &   + (ALP211*zs+ALP111)*zs+ALP011)*zt   &
+            &   + ((ALP301*zs+ALP201)*zs+ALP101)*zs+ALP001
+            !
+         zn0 = ((((ALP050*zt   &
+            &   + ALP140*zs+ALP040)*zt   &
+            &   + (ALP230*zs+ALP130)*zs+ALP030)*zt   &
+            &   + ((ALP320*zs+ALP220)*zs+ALP120)*zs+ALP020)*zt   &
+            &   + (((ALP410*zs+ALP310)*zs+ALP210)*zs+ALP110)*zs+ALP010)*zt   &
+            &   + ((((ALP500*zs+ALP400)*zs+ALP300)*zs+ALP200)*zs+ALP100)*zs+ALP000
+            !
+         zn  = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0
+         !
+         pab(jp_tem) = zn * r1_rau0
+         !
+         ! beta
+         zn3 = BET003
+         !
+         zn2 = BET012*zt + BET102*zs+BET002
+         !
+         zn1 = ((BET031*zt   &
+            &   + BET121*zs+BET021)*zt   &
+            &   + (BET211*zs+BET111)*zs+BET011)*zt   &
+            &   + ((BET301*zs+BET201)*zs+BET101)*zs+BET001
+            !
+         zn0 = ((((BET050*zt   &
+            &   + BET140*zs+BET040)*zt   &
+            &   + (BET230*zs+BET130)*zs+BET030)*zt   &
+            &   + ((BET320*zs+BET220)*zs+BET120)*zs+BET020)*zt   &
+            &   + (((BET410*zs+BET310)*zs+BET210)*zs+BET110)*zs+BET010)*zt   &
+            &   + ((((BET500*zs+BET400)*zs+BET300)*zs+BET200)*zs+BET100)*zs+BET000
+            !
+         zn  = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0
+         !
+         pab(jp_sal) = zn / zs * r1_rau0
+         !
+         !
+         !
+      CASE( np_seos )                  !==  simplified EOS  ==!
+         !
+         zt    = pts(jp_tem) - 10._wp   ! pot. temperature anomaly (t-T0)
+         zs    = pts(jp_sal) - 35._wp   ! abs. salinity anomaly (s-S0)
+         zh    = pdep                   ! depth at the partial step level
+         !
+         zn  = rn_a0 * ( 1._wp + rn_lambda1*zt + rn_mu1*zh ) + rn_nu*zs
+         pab(jp_tem) = zn * r1_rau0   ! alpha
+         !
+         zn  = rn_b0 * ( 1._wp - rn_lambda2*zs - rn_mu2*zh ) - rn_nu*zt
+         pab(jp_sal) = zn * r1_rau0   ! beta
+         !
+      CASE DEFAULT
+         IF(lwp) WRITE(numout,cform_err)
+         IF(lwp) WRITE(numout,*) '          bad flag value for neos = ', neos
+         nstop = nstop + 1
+         !
+      END SELECT
+      !
+      IF( ln_timing )   CALL timing_stop('rab_2d')
+      !
+   END SUBROUTINE rab_0d
+
+
+   SUBROUTINE bn2( pts, pab, pn2 )
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE bn2  ***
+      !!
+      !! ** Purpose :   Compute the local Brunt-Vaisala frequency at the 
+      !!                time-step of the input arguments
+      !!
+      !! ** Method  :   pn2 = grav * (alpha dk[T] + beta dk[S] ) / e3w
+      !!      where alpha and beta are given in pab, and computed on T-points.
+      !!      N.B. N^2 is set one for all to zero at jk=1 in istate module.
+      !!
+      !! ** Action  :   pn2 : square of the brunt-vaisala frequency at w-point 
+      !!
+      !!----------------------------------------------------------------------
+      REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in   ) ::  pts   ! pot. temperature and salinity   [Celsius,psu]
+      REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in   ) ::  pab   ! thermal/haline expansion coef.  [Celsius-1,psu-1]
+      REAL(wp), DIMENSION(jpi,jpj,jpk     ), INTENT(  out) ::  pn2   ! Brunt-Vaisala frequency squared [1/s^2]
+      !
+      INTEGER  ::   ji, jj, jk      ! dummy loop indices
+      REAL(wp) ::   zaw, zbw, zrw   ! local scalars
+      !!----------------------------------------------------------------------
+      !
+      IF( ln_timing )   CALL timing_start('bn2')
+      !
+      DO jk = 2, jpkm1           ! interior points only (2=< jk =< jpkm1 )
+         DO jj = 1, jpj          ! surface and bottom value set to zero one for all in istate.F90
+            DO ji = 1, jpi
+               zrw =   ( gdepw_n(ji,jj,jk  ) - gdept_n(ji,jj,jk) )   &
+                  &  / ( gdept_n(ji,jj,jk-1) - gdept_n(ji,jj,jk) ) 
+                  !
+               zaw = pab(ji,jj,jk,jp_tem) * (1. - zrw) + pab(ji,jj,jk-1,jp_tem) * zrw 
+               zbw = pab(ji,jj,jk,jp_sal) * (1. - zrw) + pab(ji,jj,jk-1,jp_sal) * zrw
+               !
+               pn2(ji,jj,jk) = grav * (  zaw * ( pts(ji,jj,jk-1,jp_tem) - pts(ji,jj,jk,jp_tem) )     &
+                  &                    - zbw * ( pts(ji,jj,jk-1,jp_sal) - pts(ji,jj,jk,jp_sal) )  )  &
+                  &            / e3w_n(ji,jj,jk) * wmask(ji,jj,jk)
+            END DO
+         END DO
+      END DO
+      !
+      IF(ln_ctl)   CALL prt_ctl( tab3d_1=pn2, clinfo1=' bn2  : ', kdim=jpk )
+      !
+      IF( ln_timing )   CALL timing_stop('bn2')
+      !
+   END SUBROUTINE bn2
+
+
+   FUNCTION eos_pt_from_ct( ctmp, psal ) RESULT( ptmp )
+      !!----------------------------------------------------------------------
+      !!                 ***  ROUTINE eos_pt_from_ct  ***
+      !!
+      !! ** Purpose :   Compute pot.temp. from cons. temp. [Celsius]
+      !!
+      !! ** Method  :   rational approximation (5/3th order) of TEOS-10 algorithm
+      !!       checkvalue: pt=20.02391895 Celsius for sa=35.7g/kg, ct=20degC
+      !!
+      !! Reference  :   TEOS-10, UNESCO
+      !!                Rational approximation to TEOS10 algorithm (rms error on WOA13 values: 4.0e-5 degC)
+      !!----------------------------------------------------------------------
+      REAL(wp), DIMENSION(jpi,jpj), INTENT(in   ) ::   ctmp   ! Cons. Temp   [Celsius]
+      REAL(wp), DIMENSION(jpi,jpj), INTENT(in   ) ::   psal   ! salinity     [psu]
+      ! Leave result array automatic rather than making explicitly allocated
+      REAL(wp), DIMENSION(jpi,jpj) ::   ptmp   ! potential temperature [Celsius]
+      !
+      INTEGER  ::   ji, jj               ! dummy loop indices
+      REAL(wp) ::   zt , zs , ztm        ! local scalars
+      REAL(wp) ::   zn , zd              ! local scalars
+      REAL(wp) ::   zdeltaS , z1_S0 , z1_T0
+      !!----------------------------------------------------------------------
+      !
+      IF( ln_timing )   CALL timing_start('eos_pt_from_ct')
+      !
+      zdeltaS = 5._wp
+      z1_S0   = 0.875_wp/35.16504_wp
+      z1_T0   = 1._wp/40._wp
+      !
+      DO jj = 1, jpj
+         DO ji = 1, jpi
+            !
+            zt  = ctmp   (ji,jj) * z1_T0
+            zs  = SQRT( ABS( psal(ji,jj) + zdeltaS ) * r1_S0 )
+            ztm = tmask(ji,jj,1)
+            !
+            zn = ((((-2.1385727895e-01_wp*zt   &
+               &   - 2.7674419971e-01_wp*zs+1.0728094330_wp)*zt   &
+               &   + (2.6366564313_wp*zs+3.3546960647_wp)*zs-7.8012209473_wp)*zt   &
+               &   + ((1.8835586562_wp*zs+7.3949191679_wp)*zs-3.3937395875_wp)*zs-5.6414948432_wp)*zt   &
+               &   + (((3.5737370589_wp*zs-1.5512427389e+01_wp)*zs+2.4625741105e+01_wp)*zs   &
+               &      +1.9912291000e+01_wp)*zs-3.2191146312e+01_wp)*zt   &
+               &   + ((((5.7153204649e-01_wp*zs-3.0943149543_wp)*zs+9.3052495181_wp)*zs   &
+               &      -9.4528934807_wp)*zs+3.1066408996_wp)*zs-4.3504021262e-01_wp
+               !
+            zd = (2.0035003456_wp*zt   &
+               &   -3.4570358592e-01_wp*zs+5.6471810638_wp)*zt   &
+               &   + (1.5393993508_wp*zs-6.9394762624_wp)*zs+1.2750522650e+01_wp
+               !
+            ptmp(ji,jj) = ( zt / z1_T0 + zn / zd ) * ztm
+               !
+         END DO
+      END DO
+      !
+      IF( ln_timing )   CALL timing_stop('eos_pt_from_ct')
+      !
+   END FUNCTION eos_pt_from_ct
+
+
+   SUBROUTINE  eos_fzp_2d( psal, ptf, pdep )
+      !!----------------------------------------------------------------------
+      !!                 ***  ROUTINE eos_fzp  ***
+      !!
+      !! ** Purpose :   Compute the freezing point temperature [Celsius]
+      !!
+      !! ** Method  :   UNESCO freezing point (ptf) in Celsius is given by
+      !!       ptf(t,z) = (-.0575+1.710523e-3*sqrt(abs(s))-2.154996e-4*s)*s - 7.53e-4*z
+      !!       checkvalue: tf=-2.588567 Celsius for s=40psu, z=500m
+      !!
+      !! Reference  :   UNESCO tech. papers in the marine science no. 28. 1978
+      !!----------------------------------------------------------------------
+      REAL(wp), DIMENSION(jpi,jpj), INTENT(in   )           ::   psal   ! salinity   [psu]
+      REAL(wp), DIMENSION(jpi,jpj), INTENT(in   ), OPTIONAL ::   pdep   ! depth      [m]
+      REAL(wp), DIMENSION(jpi,jpj), INTENT(out  )           ::   ptf    ! freezing temperature [Celsius]
+      !
+      INTEGER  ::   ji, jj          ! dummy loop indices
+      REAL(wp) ::   zt, zs, z1_S0   ! local scalars
+      !!----------------------------------------------------------------------
+      !
+      SELECT CASE ( neos )
+      !
+      CASE ( np_teos10, np_seos )      !==  CT,SA (TEOS-10 and S-EOS formulations) ==!
+         !
+         z1_S0 = 1._wp / 35.16504_wp
+         DO jj = 1, jpj
+            DO ji = 1, jpi
+               zs= SQRT( ABS( psal(ji,jj) ) * z1_S0 )           ! square root salinity
+               ptf(ji,jj) = ((((1.46873e-03_wp*zs-9.64972e-03_wp)*zs+2.28348e-02_wp)*zs &
+                  &          - 3.12775e-02_wp)*zs+2.07679e-02_wp)*zs-5.87701e-02_wp
+            END DO
+         END DO
+         ptf(:,:) = ptf(:,:) * psal(:,:)
+         !
+         IF( PRESENT( pdep ) )   ptf(:,:) = ptf(:,:) - 7.53e-4 * pdep(:,:)
+         !
+      CASE ( np_eos80 )                !==  PT,SP (UNESCO formulation)  ==!
+         !
+         ptf(:,:) = ( - 0.0575_wp + 1.710523e-3_wp * SQRT( psal(:,:) )   &
+            &                     - 2.154996e-4_wp *       psal(:,:)   ) * psal(:,:)
+            !
+         IF( PRESENT( pdep ) )   ptf(:,:) = ptf(:,:) - 7.53e-4 * pdep(:,:)
+         !
+      CASE DEFAULT
+         IF(lwp) WRITE(numout,cform_err)
+         IF(lwp) WRITE(numout,*) '          bad flag value for neos = ', neos
+         nstop = nstop + 1
+         !
+      END SELECT      
+      !
+  END SUBROUTINE eos_fzp_2d
+
+
+  SUBROUTINE eos_fzp_0d( psal, ptf, pdep )
+      !!----------------------------------------------------------------------
+      !!                 ***  ROUTINE eos_fzp  ***
+      !!
+      !! ** Purpose :   Compute the freezing point temperature [Celsius]
+      !!
+      !! ** Method  :   UNESCO freezing point (ptf) in Celsius is given by
+      !!       ptf(t,z) = (-.0575+1.710523e-3*sqrt(abs(s))-2.154996e-4*s)*s - 7.53e-4*z
+      !!       checkvalue: tf=-2.588567 Celsius for s=40psu, z=500m
+      !!
+      !! Reference  :   UNESCO tech. papers in the marine science no. 28. 1978
+      !!----------------------------------------------------------------------
+      REAL(wp), INTENT(in )           ::   psal         ! salinity   [psu]
+      REAL(wp), INTENT(in ), OPTIONAL ::   pdep         ! depth      [m]
+      REAL(wp), INTENT(out)           ::   ptf          ! freezing temperature [Celsius]
+      !
+      REAL(wp) :: zs   ! local scalars
+      !!----------------------------------------------------------------------
+      !
+      SELECT CASE ( neos )
+      !
+      CASE ( np_teos10, np_seos )      !==  CT,SA (TEOS-10 and S-EOS formulations) ==!
+         !
+         zs  = SQRT( ABS( psal ) / 35.16504_wp )           ! square root salinity
+         ptf = ((((1.46873e-03_wp*zs-9.64972e-03_wp)*zs+2.28348e-02_wp)*zs &
+                  &          - 3.12775e-02_wp)*zs+2.07679e-02_wp)*zs-5.87701e-02_wp
+         ptf = ptf * psal
+         !
+         IF( PRESENT( pdep ) )   ptf = ptf - 7.53e-4 * pdep
+         !
+      CASE ( np_eos80 )                !==  PT,SP (UNESCO formulation)  ==!
+         !
+         ptf = ( - 0.0575_wp + 1.710523e-3_wp * SQRT( psal )   &
+            &                - 2.154996e-4_wp *       psal   ) * psal
+            !
+         IF( PRESENT( pdep ) )   ptf = ptf - 7.53e-4 * pdep
+         !
+      CASE DEFAULT
+         IF(lwp) WRITE(numout,cform_err)
+         IF(lwp) WRITE(numout,*) '          bad flag value for neos = ', neos
+         nstop = nstop + 1
+         !
+      END SELECT
+      !
+   END SUBROUTINE eos_fzp_0d
+
+
+   SUBROUTINE eos_pen( pts, pab_pe, ppen )
+      !!----------------------------------------------------------------------
+      !!                 ***  ROUTINE eos_pen  ***
+      !!
+      !! ** Purpose :   Calculates nonlinear anomalies of alpha_PE, beta_PE and PE at T-points
+      !!
+      !! ** Method  :   PE is defined analytically as the vertical 
+      !!                   primitive of EOS times -g integrated between 0 and z>0.
+      !!                pen is the nonlinear bsq-PE anomaly: pen = ( PE - rau0 gz ) / rau0 gz - rd
+      !!                                                      = 1/z * /int_0^z rd dz - rd 
+      !!                                where rd is the density anomaly (see eos_rhd function)
+      !!                ab_pe are partial derivatives of PE anomaly with respect to T and S:
+      !!                    ab_pe(1) = - 1/(rau0 gz) * dPE/dT + drd/dT = - d(pen)/dT
+      !!                    ab_pe(2) =   1/(rau0 gz) * dPE/dS + drd/dS =   d(pen)/dS
+      !!
+      !! ** Action  : - pen         : PE anomaly given at T-points
+      !!            : - pab_pe  : given at T-points
+      !!                    pab_pe(:,:,:,jp_tem) is alpha_pe
+      !!                    pab_pe(:,:,:,jp_sal) is beta_pe
+      !!----------------------------------------------------------------------
+      REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in   ) ::   pts     ! pot. temperature & salinity
+      REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(  out) ::   pab_pe  ! alpha_pe and beta_pe
+      REAL(wp), DIMENSION(jpi,jpj,jpk)     , INTENT(  out) ::   ppen     ! potential energy anomaly
+      !
+      INTEGER  ::   ji, jj, jk                ! dummy loop indices
+      REAL(wp) ::   zt , zh , zs , ztm        ! local scalars
+      REAL(wp) ::   zn , zn0, zn1, zn2        !   -      -
+      !!----------------------------------------------------------------------
+      !
+      IF( ln_timing )   CALL timing_start('eos_pen')
+      !
+      SELECT CASE ( neos )
+      !
+      CASE( np_teos10, np_eos80 )                !==  polynomial TEOS-10 / EOS-80 ==!
+         !
+         DO jk = 1, jpkm1
+            DO jj = 1, jpj
+               DO ji = 1, jpi
+                  !
+                  zh  = gdept_n(ji,jj,jk) * r1_Z0                                ! depth
+                  zt  = pts (ji,jj,jk,jp_tem) * r1_T0                           ! temperature
+                  zs  = SQRT( ABS( pts(ji,jj,jk,jp_sal) + rdeltaS ) * r1_S0 )   ! square root salinity
+                  ztm = tmask(ji,jj,jk)                                         ! tmask
+                  !
+                  ! potential energy non-linear anomaly
+                  zn2 = (PEN012)*zt   &
+                     &   + PEN102*zs+PEN002
+                     !
+                  zn1 = ((PEN021)*zt   &
+                     &   + PEN111*zs+PEN011)*zt   &
+                     &   + (PEN201*zs+PEN101)*zs+PEN001
+                     !
+                  zn0 = ((((PEN040)*zt   &
+                     &   + PEN130*zs+PEN030)*zt   &
+                     &   + (PEN220*zs+PEN120)*zs+PEN020)*zt   &
+                     &   + ((PEN310*zs+PEN210)*zs+PEN110)*zs+PEN010)*zt   &
+                     &   + (((PEN400*zs+PEN300)*zs+PEN200)*zs+PEN100)*zs+PEN000
+                     !
+                  zn  = ( zn2 * zh + zn1 ) * zh + zn0
+                  !
+                  ppen(ji,jj,jk)  = zn * zh * r1_rau0 * ztm
+                  !
+                  ! alphaPE non-linear anomaly
+                  zn2 = APE002
+                  !
+                  zn1 = (APE011)*zt   &
+                     &   + APE101*zs+APE001
+                     !
+                  zn0 = (((APE030)*zt   &
+                     &   + APE120*zs+APE020)*zt   &
+                     &   + (APE210*zs+APE110)*zs+APE010)*zt   &
+                     &   + ((APE300*zs+APE200)*zs+APE100)*zs+APE000
+                     !
+                  zn  = ( zn2 * zh + zn1 ) * zh + zn0
+                  !                              
+                  pab_pe(ji,jj,jk,jp_tem) = zn * zh * r1_rau0 * ztm
+                  !
+                  ! betaPE non-linear anomaly
+                  zn2 = BPE002
+                  !
+                  zn1 = (BPE011)*zt   &
+                     &   + BPE101*zs+BPE001
+                     !
+                  zn0 = (((BPE030)*zt   &
+                     &   + BPE120*zs+BPE020)*zt   &
+                     &   + (BPE210*zs+BPE110)*zs+BPE010)*zt   &
+                     &   + ((BPE300*zs+BPE200)*zs+BPE100)*zs+BPE000
+                     !
+                  zn  = ( zn2 * zh + zn1 ) * zh + zn0
+                  !                              
+                  pab_pe(ji,jj,jk,jp_sal) = zn / zs * zh * r1_rau0 * ztm
+                  !
+               END DO
+            END DO
+         END DO
+         !
+      CASE( np_seos )                !==  Vallis (2006) simplified EOS  ==!
+         !
+         DO jk = 1, jpkm1
+            DO jj = 1, jpj
+               DO ji = 1, jpi
+                  zt  = pts(ji,jj,jk,jp_tem) - 10._wp  ! temperature anomaly (t-T0)
+                  zs = pts (ji,jj,jk,jp_sal) - 35._wp  ! abs. salinity anomaly (s-S0)
+                  zh  = gdept_n(ji,jj,jk)              ! depth in meters  at t-point
+                  ztm = tmask(ji,jj,jk)                ! tmask
+                  zn  = 0.5_wp * zh * r1_rau0 * ztm
+                  !                                    ! Potential Energy
+                  ppen(ji,jj,jk) = ( rn_a0 * rn_mu1 * zt + rn_b0 * rn_mu2 * zs ) * zn
+                  !                                    ! alphaPE
+                  pab_pe(ji,jj,jk,jp_tem) = - rn_a0 * rn_mu1 * zn
+                  pab_pe(ji,jj,jk,jp_sal) =   rn_b0 * rn_mu2 * zn
+                  !
+               END DO
+            END DO
+         END DO
+         !
+      CASE DEFAULT
+         IF(lwp) WRITE(numout,cform_err)
+         IF(lwp) WRITE(numout,*) '          bad flag value for neos = ', neos
+         nstop = nstop + 1
+         !
+      END SELECT
+      !
+      IF( ln_timing )   CALL timing_stop('eos_pen')
+      !
+   END SUBROUTINE eos_pen
+
+
+   SUBROUTINE eos_init
+      !!----------------------------------------------------------------------
+      !!                 ***  ROUTINE eos_init  ***
+      !!
+      !! ** Purpose :   initializations for the equation of state
+      !!
+      !! ** Method  :   Read the namelist nameos and control the parameters
+      !!----------------------------------------------------------------------
+      INTEGER  ::   ios   ! local integer
+      INTEGER  ::   ioptio   ! local integer
+      !!
+      NAMELIST/nameos/ ln_TEOS10, ln_EOS80, ln_SEOS, rn_a0, rn_b0, rn_lambda1, rn_mu1,   &
+         &                                             rn_lambda2, rn_mu2, rn_nu
+      !!----------------------------------------------------------------------
+      !
+      REWIND( numnam_ref )              ! Namelist nameos in reference namelist : equation of state
+      READ  ( numnam_ref, nameos, IOSTAT = ios, ERR = 901 )
+901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'nameos in reference namelist', lwp )
+      !
+      REWIND( numnam_cfg )              ! Namelist nameos in configuration namelist : equation of state
+      READ  ( numnam_cfg, nameos, IOSTAT = ios, ERR = 902 )
+902   IF( ios >  0 )   CALL ctl_nam ( ios , 'nameos in configuration namelist', lwp )
+      IF(lwm) WRITE( numond, nameos )
+      !
+      rau0        = 1026._wp                 !: volumic mass of reference     [kg/m3]
+      rcp         = 3991.86795711963_wp      !: heat capacity     [J/K]
+      !
+      IF(lwp) THEN                ! Control print
+         WRITE(numout,*)
+         WRITE(numout,*) 'eos_init : equation of state'
+         WRITE(numout,*) '~~~~~~~~'
+         WRITE(numout,*) '   Namelist nameos : Chosen the Equation Of Seawater (EOS)'
+         WRITE(numout,*) '      TEOS-10 : rho=F(Conservative Temperature, Absolute  Salinity, depth)   ln_TEOS10 = ', ln_TEOS10
+         WRITE(numout,*) '      EOS-80  : rho=F(Potential    Temperature, Practical Salinity, depth)   ln_EOS80  = ', ln_EOS80
+         WRITE(numout,*) '      S-EOS   : rho=F(Conservative Temperature, Absolute  Salinity, depth)   ln_SEOS   = ', ln_SEOS
+      ENDIF
+
+      ! Check options for equation of state & set neos based on logical flags
+      ioptio = 0
+      IF( ln_TEOS10 ) THEN   ;   ioptio = ioptio+1   ;   neos = np_teos10   ;   ENDIF
+      IF( ln_EOS80  ) THEN   ;   ioptio = ioptio+1   ;   neos = np_eos80    ;   ENDIF
+      IF( ln_SEOS   ) THEN   ;   ioptio = ioptio+1   ;   neos = np_seos     ;   ENDIF
+      IF( ioptio /= 1 )   CALL ctl_stop("Exactly one equation of state option must be selected")
+      !
+      SELECT CASE( neos )         ! check option
+      !
+      CASE( np_teos10 )                       !==  polynomial TEOS-10  ==!
+         IF(lwp) WRITE(numout,*)
+         IF(lwp) WRITE(numout,*) '   ==>>>   use of TEOS-10 equation of state (cons. temp. and abs. salinity)'
+         !
+         l_useCT = .TRUE.                          ! model temperature is Conservative temperature 
+         !
+         rdeltaS = 32._wp
+         r1_S0  = 0.875_wp/35.16504_wp
+         r1_T0  = 1._wp/40._wp
+         r1_Z0  = 1.e-4_wp
+         !
+         EOS000 = 8.0189615746e+02_wp
+         EOS100 = 8.6672408165e+02_wp
+         EOS200 = -1.7864682637e+03_wp
+         EOS300 = 2.0375295546e+03_wp
+         EOS400 = -1.2849161071e+03_wp
+         EOS500 = 4.3227585684e+02_wp
+         EOS600 = -6.0579916612e+01_wp
+         EOS010 = 2.6010145068e+01_wp
+         EOS110 = -6.5281885265e+01_wp
+         EOS210 = 8.1770425108e+01_wp
+         EOS310 = -5.6888046321e+01_wp
+         EOS410 = 1.7681814114e+01_wp
+         EOS510 = -1.9193502195_wp
+         EOS020 = -3.7074170417e+01_wp
+         EOS120 = 6.1548258127e+01_wp
+         EOS220 = -6.0362551501e+01_wp
+         EOS320 = 2.9130021253e+01_wp
+         EOS420 = -5.4723692739_wp
+         EOS030 = 2.1661789529e+01_wp
+         EOS130 = -3.3449108469e+01_wp
+         EOS230 = 1.9717078466e+01_wp
+         EOS330 = -3.1742946532_wp
+         EOS040 = -8.3627885467_wp
+         EOS140 = 1.1311538584e+01_wp
+         EOS240 = -5.3563304045_wp
+         EOS050 = 5.4048723791e-01_wp
+         EOS150 = 4.8169980163e-01_wp
+         EOS060 = -1.9083568888e-01_wp
+         EOS001 = 1.9681925209e+01_wp
+         EOS101 = -4.2549998214e+01_wp
+         EOS201 = 5.0774768218e+01_wp
+         EOS301 = -3.0938076334e+01_wp
+         EOS401 = 6.6051753097_wp
+         EOS011 = -1.3336301113e+01_wp
+         EOS111 = -4.4870114575_wp
+         EOS211 = 5.0042598061_wp
+         EOS311 = -6.5399043664e-01_wp
+         EOS021 = 6.7080479603_wp
+         EOS121 = 3.5063081279_wp
+         EOS221 = -1.8795372996_wp
+         EOS031 = -2.4649669534_wp
+         EOS131 = -5.5077101279e-01_wp
+         EOS041 = 5.5927935970e-01_wp
+         EOS002 = 2.0660924175_wp
+         EOS102 = -4.9527603989_wp
+         EOS202 = 2.5019633244_wp
+         EOS012 = 2.0564311499_wp
+         EOS112 = -2.1311365518e-01_wp
+         EOS022 = -1.2419983026_wp
+         EOS003 = -2.3342758797e-02_wp
+         EOS103 = -1.8507636718e-02_wp
+         EOS013 = 3.7969820455e-01_wp
+         !
+         ALP000 = -6.5025362670e-01_wp
+         ALP100 = 1.6320471316_wp
+         ALP200 = -2.0442606277_wp
+         ALP300 = 1.4222011580_wp
+         ALP400 = -4.4204535284e-01_wp
+         ALP500 = 4.7983755487e-02_wp
+         ALP010 = 1.8537085209_wp
+         ALP110 = -3.0774129064_wp
+         ALP210 = 3.0181275751_wp
+         ALP310 = -1.4565010626_wp
+         ALP410 = 2.7361846370e-01_wp
+         ALP020 = -1.6246342147_wp
+         ALP120 = 2.5086831352_wp
+         ALP220 = -1.4787808849_wp
+         ALP320 = 2.3807209899e-01_wp
+         ALP030 = 8.3627885467e-01_wp
+         ALP130 = -1.1311538584_wp
+         ALP230 = 5.3563304045e-01_wp
+         ALP040 = -6.7560904739e-02_wp
+         ALP140 = -6.0212475204e-02_wp
+         ALP050 = 2.8625353333e-02_wp
+         ALP001 = 3.3340752782e-01_wp
+         ALP101 = 1.1217528644e-01_wp
+         ALP201 = -1.2510649515e-01_wp
+         ALP301 = 1.6349760916e-02_wp
+         ALP011 = -3.3540239802e-01_wp
+         ALP111 = -1.7531540640e-01_wp
+         ALP211 = 9.3976864981e-02_wp
+         ALP021 = 1.8487252150e-01_wp
+         ALP121 = 4.1307825959e-02_wp
+         ALP031 = -5.5927935970e-02_wp
+         ALP002 = -5.1410778748e-02_wp
+         ALP102 = 5.3278413794e-03_wp
+         ALP012 = 6.2099915132e-02_wp
+         ALP003 = -9.4924551138e-03_wp
+         !
+         BET000 = 1.0783203594e+01_wp
+         BET100 = -4.4452095908e+01_wp
+         BET200 = 7.6048755820e+01_wp
+         BET300 = -6.3944280668e+01_wp
+         BET400 = 2.6890441098e+01_wp
+         BET500 = -4.5221697773_wp
+         BET010 = -8.1219372432e-01_wp
+         BET110 = 2.0346663041_wp
+         BET210 = -2.1232895170_wp
+         BET310 = 8.7994140485e-01_wp
+         BET410 = -1.1939638360e-01_wp
+         BET020 = 7.6574242289e-01_wp
+         BET120 = -1.5019813020_wp
+         BET220 = 1.0872489522_wp
+         BET320 = -2.7233429080e-01_wp
+         BET030 = -4.1615152308e-01_wp
+         BET130 = 4.9061350869e-01_wp
+         BET230 = -1.1847737788e-01_wp
+         BET040 = 1.4073062708e-01_wp
+         BET140 = -1.3327978879e-01_wp
+         BET050 = 5.9929880134e-03_wp
+         BET001 = -5.2937873009e-01_wp
+         BET101 = 1.2634116779_wp
+         BET201 = -1.1547328025_wp
+         BET301 = 3.2870876279e-01_wp
+         BET011 = -5.5824407214e-02_wp
+         BET111 = 1.2451933313e-01_wp
+         BET211 = -2.4409539932e-02_wp
+         BET021 = 4.3623149752e-02_wp
+         BET121 = -4.6767901790e-02_wp
+         BET031 = -6.8523260060e-03_wp
+         BET002 = -6.1618945251e-02_wp
+         BET102 = 6.2255521644e-02_wp
+         BET012 = -2.6514181169e-03_wp
+         BET003 = -2.3025968587e-04_wp
+         !
+         PEN000 = -9.8409626043_wp
+         PEN100 = 2.1274999107e+01_wp
+         PEN200 = -2.5387384109e+01_wp
+         PEN300 = 1.5469038167e+01_wp
+         PEN400 = -3.3025876549_wp
+         PEN010 = 6.6681505563_wp
+         PEN110 = 2.2435057288_wp
+         PEN210 = -2.5021299030_wp
+         PEN310 = 3.2699521832e-01_wp
+         PEN020 = -3.3540239802_wp
+         PEN120 = -1.7531540640_wp
+         PEN220 = 9.3976864981e-01_wp
+         PEN030 = 1.2324834767_wp
+         PEN130 = 2.7538550639e-01_wp
+         PEN040 = -2.7963967985e-01_wp
+         PEN001 = -1.3773949450_wp
+         PEN101 = 3.3018402659_wp
+         PEN201 = -1.6679755496_wp
+         PEN011 = -1.3709540999_wp
+         PEN111 = 1.4207577012e-01_wp
+         PEN021 = 8.2799886843e-01_wp
+         PEN002 = 1.7507069098e-02_wp
+         PEN102 = 1.3880727538e-02_wp
+         PEN012 = -2.8477365341e-01_wp
+         !
+         APE000 = -1.6670376391e-01_wp
+         APE100 = -5.6087643219e-02_wp
+         APE200 = 6.2553247576e-02_wp
+         APE300 = -8.1748804580e-03_wp
+         APE010 = 1.6770119901e-01_wp
+         APE110 = 8.7657703198e-02_wp
+         APE210 = -4.6988432490e-02_wp
+         APE020 = -9.2436260751e-02_wp
+         APE120 = -2.0653912979e-02_wp
+         APE030 = 2.7963967985e-02_wp
+         APE001 = 3.4273852498e-02_wp
+         APE101 = -3.5518942529e-03_wp
+         APE011 = -4.1399943421e-02_wp
+         APE002 = 7.1193413354e-03_wp
+         !
+         BPE000 = 2.6468936504e-01_wp
+         BPE100 = -6.3170583896e-01_wp
+         BPE200 = 5.7736640125e-01_wp
+         BPE300 = -1.6435438140e-01_wp
+         BPE010 = 2.7912203607e-02_wp
+         BPE110 = -6.2259666565e-02_wp
+         BPE210 = 1.2204769966e-02_wp
+         BPE020 = -2.1811574876e-02_wp
+         BPE120 = 2.3383950895e-02_wp
+         BPE030 = 3.4261630030e-03_wp
+         BPE001 = 4.1079296834e-02_wp
+         BPE101 = -4.1503681096e-02_wp
+         BPE011 = 1.7676120780e-03_wp
+         BPE002 = 1.7269476440e-04_wp
+         !
+      CASE( np_eos80 )                        !==  polynomial EOS-80 formulation  ==!
+         !
+         IF(lwp) WRITE(numout,*)
+         IF(lwp) WRITE(numout,*) '   ==>>>   use of EOS-80 equation of state (pot. temp. and pract. salinity)'
+         !
+         l_useCT = .FALSE.                         ! model temperature is Potential temperature
+         rdeltaS = 20._wp
+         r1_S0  = 1._wp/40._wp
+         r1_T0  = 1._wp/40._wp
+         r1_Z0  = 1.e-4_wp
+         !
+         EOS000 = 9.5356891948e+02_wp
+         EOS100 = 1.7136499189e+02_wp
+         EOS200 = -3.7501039454e+02_wp
+         EOS300 = 5.1856810420e+02_wp
+         EOS400 = -3.7264470465e+02_wp
+         EOS500 = 1.4302533998e+02_wp
+         EOS600 = -2.2856621162e+01_wp
+         EOS010 = 1.0087518651e+01_wp
+         EOS110 = -1.3647741861e+01_wp
+         EOS210 = 8.8478359933_wp
+         EOS310 = -7.2329388377_wp
+         EOS410 = 1.4774410611_wp
+         EOS510 = 2.0036720553e-01_wp
+         EOS020 = -2.5579830599e+01_wp
+         EOS120 = 2.4043512327e+01_wp
+         EOS220 = -1.6807503990e+01_wp
+         EOS320 = 8.3811577084_wp
+         EOS420 = -1.9771060192_wp
+         EOS030 = 1.6846451198e+01_wp
+         EOS130 = -2.1482926901e+01_wp
+         EOS230 = 1.0108954054e+01_wp
+         EOS330 = -6.2675951440e-01_wp
+         EOS040 = -8.0812310102_wp
+         EOS140 = 1.0102374985e+01_wp
+         EOS240 = -4.8340368631_wp
+         EOS050 = 1.2079167803_wp
+         EOS150 = 1.1515380987e-01_wp
+         EOS060 = -2.4520288837e-01_wp
+         EOS001 = 1.0748601068e+01_wp
+         EOS101 = -1.7817043500e+01_wp
+         EOS201 = 2.2181366768e+01_wp
+         EOS301 = -1.6750916338e+01_wp
+         EOS401 = 4.1202230403_wp
+         EOS011 = -1.5852644587e+01_wp
+         EOS111 = -7.6639383522e-01_wp
+         EOS211 = 4.1144627302_wp
+         EOS311 = -6.6955877448e-01_wp
+         EOS021 = 9.9994861860_wp
+         EOS121 = -1.9467067787e-01_wp
+         EOS221 = -1.2177554330_wp
+         EOS031 = -3.4866102017_wp
+         EOS131 = 2.2229155620e-01_wp
+         EOS041 = 5.9503008642e-01_wp
+         EOS002 = 1.0375676547_wp
+         EOS102 = -3.4249470629_wp
+         EOS202 = 2.0542026429_wp
+         EOS012 = 2.1836324814_wp
+         EOS112 = -3.4453674320e-01_wp
+         EOS022 = -1.2548163097_wp
+         EOS003 = 1.8729078427e-02_wp
+         EOS103 = -5.7238495240e-02_wp
+         EOS013 = 3.8306136687e-01_wp
+         !
+         ALP000 = -2.5218796628e-01_wp
+         ALP100 = 3.4119354654e-01_wp
+         ALP200 = -2.2119589983e-01_wp
+         ALP300 = 1.8082347094e-01_wp
+         ALP400 = -3.6936026529e-02_wp
+         ALP500 = -5.0091801383e-03_wp
+         ALP010 = 1.2789915300_wp
+         ALP110 = -1.2021756164_wp
+         ALP210 = 8.4037519952e-01_wp
+         ALP310 = -4.1905788542e-01_wp
+         ALP410 = 9.8855300959e-02_wp
+         ALP020 = -1.2634838399_wp
+         ALP120 = 1.6112195176_wp
+         ALP220 = -7.5817155402e-01_wp
+         ALP320 = 4.7006963580e-02_wp
+         ALP030 = 8.0812310102e-01_wp
+         ALP130 = -1.0102374985_wp
+         ALP230 = 4.8340368631e-01_wp
+         ALP040 = -1.5098959754e-01_wp
+         ALP140 = -1.4394226233e-02_wp
+         ALP050 = 3.6780433255e-02_wp
+         ALP001 = 3.9631611467e-01_wp
+         ALP101 = 1.9159845880e-02_wp
+         ALP201 = -1.0286156825e-01_wp
+         ALP301 = 1.6738969362e-02_wp
+         ALP011 = -4.9997430930e-01_wp
+         ALP111 = 9.7335338937e-03_wp
+         ALP211 = 6.0887771651e-02_wp
+         ALP021 = 2.6149576513e-01_wp
+         ALP121 = -1.6671866715e-02_wp
+         ALP031 = -5.9503008642e-02_wp
+         ALP002 = -5.4590812035e-02_wp
+         ALP102 = 8.6134185799e-03_wp
+         ALP012 = 6.2740815484e-02_wp
+         ALP003 = -9.5765341718e-03_wp
+         !
+         BET000 = 2.1420623987_wp
+         BET100 = -9.3752598635_wp
+         BET200 = 1.9446303907e+01_wp
+         BET300 = -1.8632235232e+01_wp
+         BET400 = 8.9390837485_wp
+         BET500 = -1.7142465871_wp
+         BET010 = -1.7059677327e-01_wp
+         BET110 = 2.2119589983e-01_wp
+         BET210 = -2.7123520642e-01_wp
+         BET310 = 7.3872053057e-02_wp
+         BET410 = 1.2522950346e-02_wp
+         BET020 = 3.0054390409e-01_wp
+         BET120 = -4.2018759976e-01_wp
+         BET220 = 3.1429341406e-01_wp
+         BET320 = -9.8855300959e-02_wp
+         BET030 = -2.6853658626e-01_wp
+         BET130 = 2.5272385134e-01_wp
+         BET230 = -2.3503481790e-02_wp
+         BET040 = 1.2627968731e-01_wp
+         BET140 = -1.2085092158e-01_wp
+         BET050 = 1.4394226233e-03_wp
+         BET001 = -2.2271304375e-01_wp
+         BET101 = 5.5453416919e-01_wp
+         BET201 = -6.2815936268e-01_wp
+         BET301 = 2.0601115202e-01_wp
+         BET011 = -9.5799229402e-03_wp
+         BET111 = 1.0286156825e-01_wp
+         BET211 = -2.5108454043e-02_wp
+         BET021 = -2.4333834734e-03_wp
+         BET121 = -3.0443885826e-02_wp
+         BET031 = 2.7786444526e-03_wp
+         BET002 = -4.2811838287e-02_wp
+         BET102 = 5.1355066072e-02_wp
+         BET012 = -4.3067092900e-03_wp
+         BET003 = -7.1548119050e-04_wp
+         !
+         PEN000 = -5.3743005340_wp
+         PEN100 = 8.9085217499_wp
+         PEN200 = -1.1090683384e+01_wp
+         PEN300 = 8.3754581690_wp
+         PEN400 = -2.0601115202_wp
+         PEN010 = 7.9263222935_wp
+         PEN110 = 3.8319691761e-01_wp
+         PEN210 = -2.0572313651_wp
+         PEN310 = 3.3477938724e-01_wp
+         PEN020 = -4.9997430930_wp
+         PEN120 = 9.7335338937e-02_wp
+         PEN220 = 6.0887771651e-01_wp
+         PEN030 = 1.7433051009_wp
+         PEN130 = -1.1114577810e-01_wp
+         PEN040 = -2.9751504321e-01_wp
+         PEN001 = -6.9171176978e-01_wp
+         PEN101 = 2.2832980419_wp
+         PEN201 = -1.3694684286_wp
+         PEN011 = -1.4557549876_wp
+         PEN111 = 2.2969116213e-01_wp
+         PEN021 = 8.3654420645e-01_wp
+         PEN002 = -1.4046808820e-02_wp
+         PEN102 = 4.2928871430e-02_wp
+         PEN012 = -2.8729602515e-01_wp
+         !
+         APE000 = -1.9815805734e-01_wp
+         APE100 = -9.5799229402e-03_wp
+         APE200 = 5.1430784127e-02_wp
+         APE300 = -8.3694846809e-03_wp
+         APE010 = 2.4998715465e-01_wp
+         APE110 = -4.8667669469e-03_wp
+         APE210 = -3.0443885826e-02_wp
+         APE020 = -1.3074788257e-01_wp
+         APE120 = 8.3359333577e-03_wp
+         APE030 = 2.9751504321e-02_wp
+         APE001 = 3.6393874690e-02_wp
+         APE101 = -5.7422790533e-03_wp
+         APE011 = -4.1827210323e-02_wp
+         APE002 = 7.1824006288e-03_wp
+         !
+         BPE000 = 1.1135652187e-01_wp
+         BPE100 = -2.7726708459e-01_wp
+         BPE200 = 3.1407968134e-01_wp
+         BPE300 = -1.0300557601e-01_wp
+         BPE010 = 4.7899614701e-03_wp
+         BPE110 = -5.1430784127e-02_wp
+         BPE210 = 1.2554227021e-02_wp
+         BPE020 = 1.2166917367e-03_wp
+         BPE120 = 1.5221942913e-02_wp
+         BPE030 = -1.3893222263e-03_wp
+         BPE001 = 2.8541225524e-02_wp
+         BPE101 = -3.4236710714e-02_wp
+         BPE011 = 2.8711395266e-03_wp
+         BPE002 = 5.3661089288e-04_wp
+         !
+      CASE( np_seos )                        !==  Simplified EOS     ==!
+         IF(lwp) THEN
+            WRITE(numout,*)
+            WRITE(numout,*) '   ==>>>   use of simplified eos:    '
+            WRITE(numout,*) '              rhd(dT=T-10,dS=S-35,Z) = [-a0*(1+lambda1/2*dT+mu1*Z)*dT '
+            WRITE(numout,*) '                                       + b0*(1+lambda2/2*dT+mu2*Z)*dS - nu*dT*dS] / rau0'
+            WRITE(numout,*) '              with the following coefficients :'
+            WRITE(numout,*) '                 thermal exp. coef.    rn_a0      = ', rn_a0
+            WRITE(numout,*) '                 saline  cont. coef.   rn_b0      = ', rn_b0
+            WRITE(numout,*) '                 cabbeling coef.       rn_lambda1 = ', rn_lambda1
+            WRITE(numout,*) '                 cabbeling coef.       rn_lambda2 = ', rn_lambda2
+            WRITE(numout,*) '                 thermobar. coef.      rn_mu1     = ', rn_mu1
+            WRITE(numout,*) '                 thermobar. coef.      rn_mu2     = ', rn_mu2
+            WRITE(numout,*) '                 2nd cabbel. coef.     rn_nu      = ', rn_nu
+            WRITE(numout,*) '              Caution: rn_beta0=0 incompatible with ddm parameterization '
+         ENDIF
+         l_useCT = .TRUE.          ! Use conservative temperature
+         !
+      CASE DEFAULT                     !==  ERROR in neos  ==!
+         WRITE(ctmp1,*) '          bad flag value for neos = ', neos, '. You should never see this error'
+         CALL ctl_stop( ctmp1 )
+         !
+      END SELECT
+      !
+      rau0_rcp    = rau0 * rcp 
+      r1_rau0     = 1._wp / rau0
+      r1_rcp      = 1._wp / rcp
+      r1_rau0_rcp = 1._wp / rau0_rcp 
+      !
+      IF(lwp) THEN
+         IF( l_useCT )   THEN
+            WRITE(numout,*)
+            WRITE(numout,*) '   ==>>>   model uses Conservative Temperature'
+            WRITE(numout,*) '           Important: model must be initialized with CT and SA fields'
+         ELSE
+            WRITE(numout,*)
+            WRITE(numout,*) '   ==>>>   model does not use Conservative Temperature'
+         ENDIF
+      ENDIF
+      !
+      IF(lwp) WRITE(numout,*)
+      IF(lwp) WRITE(numout,*) '   Associated physical constant'
+      IF(lwp) WRITE(numout,*) '      volumic mass of reference           rau0  = ', rau0   , ' kg/m^3'
+      IF(lwp) WRITE(numout,*) '      1. / rau0                        r1_rau0  = ', r1_rau0, ' m^3/kg'
+      IF(lwp) WRITE(numout,*) '      ocean specific heat                 rcp   = ', rcp    , ' J/Kelvin'
+      IF(lwp) WRITE(numout,*) '      rau0 * rcp                       rau0_rcp = ', rau0_rcp
+      IF(lwp) WRITE(numout,*) '      1. / ( rau0 * rcp )           r1_rau0_rcp = ', r1_rau0_rcp
+      !
+   END SUBROUTINE eos_init
+
+   !!======================================================================
+END MODULE eosbn2
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/TRA/traadv.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/TRA/traadv.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/TRA/traadv.F90	(revision 9570)
@@ -0,0 +1,274 @@
+MODULE traadv
+   !!==============================================================================
+   !!                       ***  MODULE  traadv  ***
+   !! Ocean active tracers:  advection trend 
+   !!==============================================================================
+   !! History :  2.0  !  2005-11  (G. Madec)  Original code
+   !!            3.3  !  2010-09  (C. Ethe, G. Madec)  merge TRC-TRA + switch from velocity to transport
+   !!            3.6  !  2011-06  (G. Madec)  Addition of Mixed Layer Eddy parameterisation
+   !!            3.7  !  2014-05  (G. Madec)  Add 2nd/4th order cases for CEN and FCT schemes 
+   !!             -   !  2014-12  (G. Madec) suppression of cross land advection option
+   !!            3.6  !  2015-06  (E. Clementi) Addition of Stokes drift in case of wave coupling
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   tra_adv       : compute ocean tracer advection trend
+   !!   tra_adv_init  : control the different options of advection scheme
+   !!----------------------------------------------------------------------
+   USE oce            ! ocean dynamics and active tracers
+   USE dom_oce        ! ocean space and time domain
+   USE domvvl         ! variable vertical scale factors
+   USE sbcwave        ! wave module
+   USE sbc_oce        ! surface boundary condition: ocean
+   USE traadv_cen     ! centered scheme            (tra_adv_cen  routine)
+   USE traadv_fct     ! FCT      scheme            (tra_adv_fct  routine)
+   USE traadv_mus     ! MUSCL    scheme            (tra_adv_mus  routine)
+   USE traadv_ubs     ! UBS      scheme            (tra_adv_ubs  routine)
+   USE traadv_qck     ! QUICKEST scheme            (tra_adv_qck  routine)
+   USE tramle         ! Mixed Layer Eddy transport (tra_mle_trp  routine)
+   USE ldftra         ! Eddy Induced transport     (ldf_eiv_trp  routine)
+   USE ldfslp         ! Lateral diffusion: slopes of neutral surfaces
+   USE trd_oce        ! trends: ocean variables
+   USE trdtra         ! trends manager: tracers 
+   USE diaptr         ! Poleward heat transport 
+   !
+   USE in_out_manager ! I/O manager
+   USE iom            ! I/O module
+   USE prtctl         ! Print control
+   USE lib_mpp        ! MPP library
+   USE timing         ! Timing
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   tra_adv        ! called by step.F90
+   PUBLIC   tra_adv_init   ! called by nemogcm.F90
+
+   !                            !!* Namelist namtra_adv *
+   LOGICAL ::   ln_traadv_OFF    ! no advection on T and S
+   LOGICAL ::   ln_traadv_cen    ! centered scheme flag
+   INTEGER ::      nn_cen_h, nn_cen_v   ! =2/4 : horizontal and vertical choices of the order of CEN scheme
+   LOGICAL ::   ln_traadv_fct    ! FCT scheme flag
+   INTEGER ::      nn_fct_h, nn_fct_v   ! =2/4 : horizontal and vertical choices of the order of FCT scheme
+   LOGICAL ::   ln_traadv_mus    ! MUSCL scheme flag
+   LOGICAL ::      ln_mus_ups           ! use upstream scheme in vivcinity of river mouths
+   LOGICAL ::   ln_traadv_ubs    ! UBS scheme flag
+   INTEGER ::      nn_ubs_v             ! =2/4 : vertical choice of the order of UBS scheme
+   LOGICAL ::   ln_traadv_qck    ! QUICKEST scheme flag
+
+   INTEGER ::   nadv             ! choice of the type of advection scheme
+   !                             ! associated indices:
+   INTEGER, PARAMETER ::   np_NO_adv  = 0   ! no T-S advection
+   INTEGER, PARAMETER ::   np_CEN     = 1   ! 2nd/4th order centered scheme
+   INTEGER, PARAMETER ::   np_FCT     = 2   ! 2nd/4th order Flux Corrected Transport scheme
+   INTEGER, PARAMETER ::   np_MUS     = 3   ! MUSCL scheme
+   INTEGER, PARAMETER ::   np_UBS     = 4   ! 3rd order Upstream Biased Scheme
+   INTEGER, PARAMETER ::   np_QCK     = 5   ! QUICK scheme
+   
+   !! * Substitutions
+#  include "vectopt_loop_substitute.h90"
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 4.0 , NEMO Consortium (2017)
+   !! $Id$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE tra_adv( kt )
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE tra_adv  ***
+      !!
+      !! ** Purpose :   compute the ocean tracer advection trend.
+      !!
+      !! ** Method  : - Update (ua,va) with the advection term following nadv
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT(in) ::   kt   ! ocean time-step index
+      !
+      INTEGER ::   jk   ! dummy loop index
+      REAL(wp), DIMENSION(jpi,jpj,jpk)        :: zun, zvn, zwn   ! 3D workspace
+      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::   ztrdt, ztrds
+      !!----------------------------------------------------------------------
+      !
+      IF( ln_timing )   CALL timing_start('tra_adv')
+      !
+      !                                          ! set time step
+      IF( neuler == 0 .AND. kt == nit000 ) THEN   ;   r2dt =         rdt   ! at nit000             (Euler)
+      ELSEIF( kt <= nit000 + 1 )           THEN   ;   r2dt = 2._wp * rdt   ! at nit000 or nit000+1 (Leapfrog)
+      ENDIF
+      !
+      !                                         !==  effective transport  ==!
+      zun(:,:,jpk) = 0._wp
+      zvn(:,:,jpk) = 0._wp
+      zwn(:,:,jpk) = 0._wp
+      IF( ln_wave .AND. ln_sdw )  THEN
+         DO jk = 1, jpkm1                                                       ! eulerian transport + Stokes Drift
+            zun(:,:,jk) = e2u  (:,:) * e3u_n(:,:,jk) * ( un(:,:,jk) + usd(:,:,jk) )
+            zvn(:,:,jk) = e1v  (:,:) * e3v_n(:,:,jk) * ( vn(:,:,jk) + vsd(:,:,jk) )
+            zwn(:,:,jk) = e1e2t(:,:)                 * ( wn(:,:,jk) + wsd(:,:,jk) )
+         END DO
+      ELSE
+         DO jk = 1, jpkm1
+            zun(:,:,jk) = e2u  (:,:) * e3u_n(:,:,jk) * un(:,:,jk)               ! eulerian transport only
+            zvn(:,:,jk) = e1v  (:,:) * e3v_n(:,:,jk) * vn(:,:,jk)
+            zwn(:,:,jk) = e1e2t(:,:)                 * wn(:,:,jk)
+         END DO
+      ENDIF
+      !
+      IF( ln_vvl_ztilde .OR. ln_vvl_layer ) THEN                                ! add z-tilde and/or vvl corrections
+         zun(:,:,:) = zun(:,:,:) + un_td(:,:,:)
+         zvn(:,:,:) = zvn(:,:,:) + vn_td(:,:,:)
+      ENDIF
+      !
+      zun(:,:,jpk) = 0._wp                                                      ! no transport trough the bottom
+      zvn(:,:,jpk) = 0._wp
+      zwn(:,:,jpk) = 0._wp
+      !
+      IF( ln_ldfeiv .AND. .NOT. ln_traldf_triad )   &
+         &              CALL ldf_eiv_trp( kt, nit000, zun, zvn, zwn, 'TRA' )   ! add the eiv transport (if necessary)
+      !
+      IF( ln_mle    )   CALL tra_mle_trp( kt, nit000, zun, zvn, zwn, 'TRA' )   ! add the mle transport (if necessary)
+      !
+      CALL iom_put( "uocetr_eff", zun )                                        ! output effective transport      
+      CALL iom_put( "vocetr_eff", zvn )
+      CALL iom_put( "wocetr_eff", zwn )
+      !
+!!gm ???
+      IF( ln_diaptr )   CALL dia_ptr( zvn )                                    ! diagnose the effective MSF 
+!!gm ???
+      !
+      IF( l_trdtra )   THEN                    !* Save ta and sa trends
+         ALLOCATE( ztrdt(jpi,jpj,jpk), ztrds(jpi,jpj,jpk) )
+         ztrdt(:,:,:) = tsa(:,:,:,jp_tem)
+         ztrds(:,:,:) = tsa(:,:,:,jp_sal)
+      ENDIF
+      !
+      SELECT CASE ( nadv )                      !==  compute advection trend and add it to general trend  ==!
+      !
+      CASE ( np_CEN )                                 ! Centered scheme : 2nd / 4th order
+         CALL tra_adv_cen    ( kt, nit000, 'TRA',         zun, zvn, zwn     , tsn, tsa, jpts, nn_cen_h, nn_cen_v )
+      CASE ( np_FCT )                                 ! FCT scheme      : 2nd / 4th order
+         CALL tra_adv_fct    ( kt, nit000, 'TRA', r2dt, zun, zvn, zwn, tsb, tsn, tsa, jpts, nn_fct_h, nn_fct_v )
+      CASE ( np_MUS )                                 ! MUSCL
+         CALL tra_adv_mus    ( kt, nit000, 'TRA', r2dt, zun, zvn, zwn, tsb,      tsa, jpts        , ln_mus_ups ) 
+      CASE ( np_UBS )                                 ! UBS
+         CALL tra_adv_ubs    ( kt, nit000, 'TRA', r2dt, zun, zvn, zwn, tsb, tsn, tsa, jpts        , nn_ubs_v   )
+      CASE ( np_QCK )                                 ! QUICKEST
+         CALL tra_adv_qck    ( kt, nit000, 'TRA', r2dt, zun, zvn, zwn, tsb, tsn, tsa, jpts                     )
+      !
+      END SELECT
+      !
+      IF( l_trdtra )   THEN                      ! save the advective trends for further diagnostics
+         DO jk = 1, jpkm1
+            ztrdt(:,:,jk) = tsa(:,:,jk,jp_tem) - ztrdt(:,:,jk)
+            ztrds(:,:,jk) = tsa(:,:,jk,jp_sal) - ztrds(:,:,jk)
+         END DO
+         CALL trd_tra( kt, 'TRA', jp_tem, jptra_totad, ztrdt )
+         CALL trd_tra( kt, 'TRA', jp_sal, jptra_totad, ztrds )
+         DEALLOCATE( ztrdt, ztrds )
+      ENDIF
+      !                                              ! print mean trends (used for debugging)
+      IF(ln_ctl)   CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' adv  - Ta: ', mask1=tmask,               &
+         &                       tab3d_2=tsa(:,:,:,jp_sal), clinfo2=       ' Sa: ', mask2=tmask, clinfo3='tra' )
+      !
+      IF( ln_timing )   CALL timing_stop( 'tra_adv' )
+      !
+   END SUBROUTINE tra_adv
+
+
+   SUBROUTINE tra_adv_init
+      !!---------------------------------------------------------------------
+      !!                  ***  ROUTINE tra_adv_init  ***
+      !!                
+      !! ** Purpose :   Control the consistency between namelist options for 
+      !!              tracer advection schemes and set nadv
+      !!----------------------------------------------------------------------
+      INTEGER ::   ioptio, ios   ! Local integers
+      !
+      NAMELIST/namtra_adv/ ln_traadv_OFF,                        &   ! No advection
+         &                 ln_traadv_cen , nn_cen_h, nn_cen_v,   &   ! CEN
+         &                 ln_traadv_fct , nn_fct_h, nn_fct_v,   &   ! FCT
+         &                 ln_traadv_mus , ln_mus_ups,           &   ! MUSCL
+         &                 ln_traadv_ubs ,           nn_ubs_v,   &   ! UBS
+         &                 ln_traadv_qck                             ! QCK
+      !!----------------------------------------------------------------------
+      !
+      !                                !==  Namelist  ==!
+      REWIND( numnam_ref )                   ! Namelist namtra_adv in reference namelist : Tracer advection scheme
+      READ  ( numnam_ref, namtra_adv, IOSTAT = ios, ERR = 901)
+901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namtra_adv in reference namelist', lwp )
+      !
+      REWIND( numnam_cfg )                   ! Namelist namtra_adv in configuration namelist : Tracer advection scheme
+      READ  ( numnam_cfg, namtra_adv, IOSTAT = ios, ERR = 902 )
+902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namtra_adv in configuration namelist', lwp )
+      IF(lwm) WRITE( numond, namtra_adv )
+      !
+      IF(lwp) THEN                           ! Namelist print
+         WRITE(numout,*)
+         WRITE(numout,*) 'tra_adv_init : choice/control of the tracer advection scheme'
+         WRITE(numout,*) '~~~~~~~~~~~~'
+         WRITE(numout,*) '   Namelist namtra_adv : chose a advection scheme for tracers'
+         WRITE(numout,*) '      No advection on T & S                     ln_traadv_OFF = ', ln_traadv_OFF
+         WRITE(numout,*) '      centered scheme                           ln_traadv_cen = ', ln_traadv_cen
+         WRITE(numout,*) '            horizontal 2nd/4th order               nn_cen_h   = ', nn_fct_h
+         WRITE(numout,*) '            vertical   2nd/4th order               nn_cen_v   = ', nn_fct_v
+         WRITE(numout,*) '      Flux Corrected Transport scheme           ln_traadv_fct = ', ln_traadv_fct
+         WRITE(numout,*) '            horizontal 2nd/4th order               nn_fct_h   = ', nn_fct_h
+         WRITE(numout,*) '            vertical   2nd/4th order               nn_fct_v   = ', nn_fct_v
+         WRITE(numout,*) '      MUSCL scheme                              ln_traadv_mus = ', ln_traadv_mus
+         WRITE(numout,*) '            + upstream scheme near river mouths    ln_mus_ups = ', ln_mus_ups
+         WRITE(numout,*) '      UBS scheme                                ln_traadv_ubs = ', ln_traadv_ubs
+         WRITE(numout,*) '            vertical   2nd/4th order               nn_ubs_v   = ', nn_ubs_v
+         WRITE(numout,*) '      QUICKEST scheme                           ln_traadv_qck = ', ln_traadv_qck
+      ENDIF
+      !
+      !                                !==  Parameter control & set nadv ==!
+      ioptio = 0                       
+      IF( ln_traadv_OFF ) THEN   ;   ioptio = ioptio + 1   ;   nadv = np_NO_adv   ;   ENDIF
+      IF( ln_traadv_cen ) THEN   ;   ioptio = ioptio + 1   ;   nadv = np_CEN      ;   ENDIF
+      IF( ln_traadv_fct ) THEN   ;   ioptio = ioptio + 1   ;   nadv = np_FCT      ;   ENDIF
+      IF( ln_traadv_mus ) THEN   ;   ioptio = ioptio + 1   ;   nadv = np_MUS      ;   ENDIF
+      IF( ln_traadv_ubs ) THEN   ;   ioptio = ioptio + 1   ;   nadv = np_UBS      ;   ENDIF
+      IF( ln_traadv_qck ) THEN   ;   ioptio = ioptio + 1   ;   nadv = np_QCK      ;   ENDIF
+      !
+      IF( ioptio /= 1 )   CALL ctl_stop( 'tra_adv_init: Choose ONE advection option in namelist namtra_adv' )
+      !
+      IF( ln_traadv_cen .AND. ( nn_cen_h /= 2 .AND. nn_cen_h /= 4 )   &          ! Centered
+                        .AND. ( nn_cen_v /= 2 .AND. nn_cen_v /= 4 )   ) THEN
+        CALL ctl_stop( 'tra_adv_init: CEN scheme, choose 2nd or 4th order' )
+      ENDIF
+      IF( ln_traadv_fct .AND. ( nn_fct_h /= 2 .AND. nn_fct_h /= 4 )   &          ! FCT
+                        .AND. ( nn_fct_v /= 2 .AND. nn_fct_v /= 4 )   ) THEN
+        CALL ctl_stop( 'tra_adv_init: FCT scheme, choose 2nd or 4th order' )
+      ENDIF
+      IF( ln_traadv_ubs .AND. ( nn_ubs_v /= 2 .AND. nn_ubs_v /= 4 )   ) THEN     ! UBS
+        CALL ctl_stop( 'tra_adv_init: UBS scheme, choose 2nd or 4th order' )
+      ENDIF
+      IF( ln_traadv_ubs .AND. nn_ubs_v == 4 ) THEN
+         CALL ctl_warn( 'tra_adv_init: UBS scheme, only 2nd FCT scheme available on the vertical. It will be used' )
+      ENDIF
+      IF( ln_isfcav ) THEN                                                       ! ice-shelf cavities
+         IF(  ln_traadv_cen .AND. nn_cen_v == 4    .OR.   &                            ! NO 4th order with ISF
+            & ln_traadv_fct .AND. nn_fct_v == 4   )   CALL ctl_stop( 'tra_adv_init: 4th order COMPACT scheme not allowed with ISF' )
+      ENDIF
+      !
+      !                                !==  Print the choice  ==!  
+      IF(lwp) THEN
+         WRITE(numout,*)
+         SELECT CASE ( nadv )
+         CASE( np_NO_adv  )   ;   WRITE(numout,*) '   ==>>>   NO T-S advection'
+         CASE( np_CEN     )   ;   WRITE(numout,*) '   ==>>>   CEN      scheme is used. Horizontal order: ', nn_cen_h,   &
+            &                                                                        ' Vertical   order: ', nn_cen_v
+         CASE( np_FCT     )   ;   WRITE(numout,*) '   ==>>>   FCT      scheme is used. Horizontal order: ', nn_fct_h,   &
+            &                                                                        ' Vertical   order: ', nn_fct_v
+         CASE( np_MUS     )   ;   WRITE(numout,*) '   ==>>>   MUSCL    scheme is used'
+         CASE( np_UBS     )   ;   WRITE(numout,*) '   ==>>>   UBS      scheme is used'
+         CASE( np_QCK     )   ;   WRITE(numout,*) '   ==>>>   QUICKEST scheme is used'
+         END SELECT
+      ENDIF
+      !
+      CALL tra_mle_init            !== initialisation of the Mixed Layer Eddy parametrisation (MLE)  ==!
+      !
+   END SUBROUTINE tra_adv_init
+
+  !!======================================================================
+END MODULE traadv
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/TRA/traadv_cen.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/TRA/traadv_cen.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/TRA/traadv_cen.F90	(revision 9570)
@@ -0,0 +1,207 @@
+MODULE traadv_cen
+   !!======================================================================
+   !!                     ***  MODULE  traadv_cen  ***
+   !! Ocean  tracers:   advective trend (2nd/4th order centered)
+   !!======================================================================
+   !! History :  3.7  ! 2014-05  (G. Madec)  original code
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   tra_adv_cen   : update the tracer trend with the advection trends using a centered or scheme (2nd or 4th order)
+   !!                   NB: on the vertical it is actually a 4th order COMPACT scheme which is used
+   !!----------------------------------------------------------------------
+   USE dom_oce        ! ocean space and time domain
+   USE eosbn2         ! equation of state
+   USE traadv_fct     ! acces to routine interp_4th_cpt 
+   USE trd_oce        ! trends: ocean variables
+   USE trdtra         ! trends manager: tracers 
+   USE diaptr         ! poleward transport diagnostics
+   USE diaar5         ! AR5 diagnostics
+   !
+   USE in_out_manager ! I/O manager
+   USE iom            ! IOM library
+   USE trc_oce        ! share passive tracers/Ocean variables
+   USE lib_mpp        ! MPP library
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   tra_adv_cen   ! called by traadv.F90
+   
+   REAL(wp) ::   r1_6 = 1._wp / 6._wp   ! =1/6
+
+   LOGICAL ::   l_trd   ! flag to compute trends
+   LOGICAL ::   l_ptr   ! flag to compute poleward transport
+   LOGICAL ::   l_hst   ! flag to compute heat/salt transport
+
+   !! * Substitutions
+#  include "vectopt_loop_substitute.h90"
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 4.0, NEMO Consortium (2017)
+   !! $Id:$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE tra_adv_cen( kt, kit000, cdtype, pun, pvn, pwn,     &
+      &                                        ptn, pta, kjpt, kn_cen_h, kn_cen_v ) 
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE tra_adv_cen  ***
+      !!                 
+      !! ** Purpose :   Compute the now trend due to the advection of tracers
+      !!      and add it to the general trend of passive tracer equations.
+      !!
+      !! ** Method  :   The advection is evaluated by a 2nd or 4th order scheme
+      !!               using now fields (leap-frog scheme). 
+      !!       kn_cen_h = 2  ==>> 2nd order centered scheme on the horizontal
+      !!                = 4  ==>> 4th order    -        -       -      -
+      !!       kn_cen_v = 2  ==>> 2nd order centered scheme on the vertical
+      !!                = 4  ==>> 4th order COMPACT  scheme     -      -
+      !!
+      !! ** Action : - update pta  with the now advective tracer trends
+      !!             - send trends to trdtra module for further diagnostcs (l_trdtra=T)
+      !!             - htr_adv, str_adv : poleward advective heat and salt transport (ln_diaptr=T)
+      !!----------------------------------------------------------------------
+      INTEGER                              , INTENT(in   ) ::   kt              ! ocean time-step index
+      INTEGER                              , INTENT(in   ) ::   kit000          ! first time step index
+      CHARACTER(len=3)                     , INTENT(in   ) ::   cdtype          ! =TRA or TRC (tracer indicator)
+      INTEGER                              , INTENT(in   ) ::   kjpt            ! number of tracers
+      INTEGER                              , INTENT(in   ) ::   kn_cen_h        ! =2/4 (2nd or 4th order scheme)
+      INTEGER                              , INTENT(in   ) ::   kn_cen_v        ! =2/4 (2nd or 4th order scheme)
+      REAL(wp), DIMENSION(jpi,jpj,jpk     ), INTENT(in   ) ::   pun, pvn, pwn   ! 3 ocean velocity components
+      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   ) ::   ptn             ! now tracer fields
+      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) ::   pta             ! tracer trend 
+      !
+      INTEGER  ::   ji, jj, jk, jn   ! dummy loop indices
+      INTEGER  ::   ierr             ! local integer
+      REAL(wp) ::   zC2t_u, zC4t_u   ! local scalars
+      REAL(wp) ::   zC2t_v, zC4t_v   !   -      -
+      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zwx, zwy, zwz, ztu, ztv, ztw
+      !!----------------------------------------------------------------------
+      !
+      IF( kt == kit000 )  THEN
+         IF(lwp) WRITE(numout,*)
+         IF(lwp) WRITE(numout,*) 'tra_adv_cen : centered advection scheme on ', cdtype, ' order h/v =', kn_cen_h,'/', kn_cen_v
+         IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~ '
+      ENDIF
+      !                          ! set local switches
+      l_trd = .FALSE.
+      l_hst = .FALSE.
+      l_ptr = .FALSE.
+      IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype == 'TRC' .AND. l_trdtrc ) )        l_trd = .TRUE.
+      IF(   cdtype == 'TRA' .AND. ln_diaptr )                                                 l_ptr = .TRUE. 
+      IF(   cdtype == 'TRA' .AND. ( iom_use("uadv_heattr") .OR. iom_use("vadv_heattr") .OR. &
+         &                          iom_use("uadv_salttr") .OR. iom_use("vadv_salttr")  ) )   l_hst = .TRUE.
+      !
+      !                    
+      zwz(:,:, 1 ) = 0._wp       ! surface & bottom vertical flux set to zero for all tracers
+      zwz(:,:,jpk) = 0._wp
+      !
+      DO jn = 1, kjpt            !==  loop over the tracers  ==!
+         !
+         SELECT CASE( kn_cen_h )       !--  Horizontal fluxes  --!
+         !
+         CASE(  2  )                         !* 2nd order centered
+            DO jk = 1, jpkm1
+               DO jj = 1, jpjm1
+                  DO ji = 1, fs_jpim1   ! vector opt.
+                     zwx(ji,jj,jk) = 0.5_wp * pun(ji,jj,jk) * ( ptn(ji,jj,jk,jn) + ptn(ji+1,jj  ,jk,jn) )
+                     zwy(ji,jj,jk) = 0.5_wp * pvn(ji,jj,jk) * ( ptn(ji,jj,jk,jn) + ptn(ji  ,jj+1,jk,jn) )
+                  END DO
+               END DO
+            END DO
+            !
+         CASE(  4  )                         !* 4th order centered
+            ztu(:,:,jpk) = 0._wp                   ! Bottom value : flux set to zero
+            ztv(:,:,jpk) = 0._wp
+            DO jk = 1, jpkm1                       ! masked gradient
+               DO jj = 2, jpjm1
+                  DO ji = fs_2, fs_jpim1   ! vector opt.
+                     ztu(ji,jj,jk) = ( ptn(ji+1,jj  ,jk,jn) - ptn(ji,jj,jk,jn) ) * umask(ji,jj,jk)
+                     ztv(ji,jj,jk) = ( ptn(ji  ,jj+1,jk,jn) - ptn(ji,jj,jk,jn) ) * vmask(ji,jj,jk)
+                  END DO
+               END DO
+            END DO
+            CALL lbc_lnk_multi( ztu, 'U', -1. , ztv, 'V', -1. )   ! Lateral boundary cond.
+            !
+            DO jk = 1, jpkm1                       ! Horizontal advective fluxes
+               DO jj = 2, jpjm1
+                  DO ji = 1, fs_jpim1   ! vector opt.
+                     zC2t_u = ptn(ji,jj,jk,jn) + ptn(ji+1,jj  ,jk,jn)   ! C2 interpolation of T at u- & v-points (x2)
+                     zC2t_v = ptn(ji,jj,jk,jn) + ptn(ji  ,jj+1,jk,jn)
+                     !                                                  ! C4 interpolation of T at u- & v-points (x2)
+                     zC4t_u =  zC2t_u + r1_6 * ( ztu(ji-1,jj,jk) - ztu(ji+1,jj,jk) )
+                     zC4t_v =  zC2t_v + r1_6 * ( ztv(ji,jj-1,jk) - ztv(ji,jj+1,jk) )
+                     !                                                  ! C4 fluxes
+                     zwx(ji,jj,jk) =  0.5_wp * pun(ji,jj,jk) * zC4t_u
+                     zwy(ji,jj,jk) =  0.5_wp * pvn(ji,jj,jk) * zC4t_v
+                  END DO
+               END DO
+            END DO         
+            !
+         CASE DEFAULT
+            CALL ctl_stop( 'traadv_fct: wrong value for nn_fct' )
+         END SELECT
+         !
+         SELECT CASE( kn_cen_v )       !--  Vertical fluxes  --!   (interior)
+         !
+         CASE(  2  )                         !* 2nd order centered
+            DO jk = 2, jpk
+               DO jj = 2, jpjm1
+                  DO ji = fs_2, fs_jpim1   ! vector opt.
+                     zwz(ji,jj,jk) = 0.5 * pwn(ji,jj,jk) * ( ptn(ji,jj,jk,jn) + ptn(ji,jj,jk-1,jn) ) * wmask(ji,jj,jk)
+                  END DO
+               END DO
+            END DO
+            !
+         CASE(  4  )                         !* 4th order compact
+            CALL interp_4th_cpt( ptn(:,:,:,jn) , ztw )      ! ztw = interpolated value of T at w-point
+            DO jk = 2, jpkm1
+               DO jj = 2, jpjm1
+                  DO ji = fs_2, fs_jpim1
+                     zwz(ji,jj,jk) = pwn(ji,jj,jk) * ztw(ji,jj,jk) * wmask(ji,jj,jk)
+                  END DO
+               END DO
+            END DO
+            !
+         END SELECT
+         !
+         IF( ln_linssh ) THEN                !* top value   (linear free surf. only as zwz is multiplied by wmask)
+            IF( ln_isfcav ) THEN                  ! ice-shelf cavities (top of the ocean)
+               DO jj = 1, jpj
+                  DO ji = 1, jpi
+                     zwz(ji,jj, mikt(ji,jj) ) = pwn(ji,jj,mikt(ji,jj)) * ptn(ji,jj,mikt(ji,jj),jn) 
+                  END DO
+               END DO   
+            ELSE                                   ! no ice-shelf cavities (only ocean surface)
+               zwz(:,:,1) = pwn(:,:,1) * ptn(:,:,1,jn)
+            ENDIF
+         ENDIF
+         !               
+         DO jk = 1, jpkm1              !--  Divergence of advective fluxes  --!
+            DO jj = 2, jpjm1
+               DO ji = fs_2, fs_jpim1   ! vector opt.
+                  pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn)    &
+                     &             - (  zwx(ji,jj,jk) - zwx(ji-1,jj  ,jk  )    &
+                     &                + zwy(ji,jj,jk) - zwy(ji  ,jj-1,jk  )    &
+                     &                + zwz(ji,jj,jk) - zwz(ji  ,jj  ,jk+1)  ) * r1_e1e2t(ji,jj) / e3t_n(ji,jj,jk)
+               END DO
+            END DO
+         END DO
+         !                             ! trend diagnostics
+         IF( l_trd ) THEN
+            CALL trd_tra( kt, cdtype, jn, jptra_xad, zwx, pun, ptn(:,:,:,jn) )
+            CALL trd_tra( kt, cdtype, jn, jptra_yad, zwy, pvn, ptn(:,:,:,jn) )
+            CALL trd_tra( kt, cdtype, jn, jptra_zad, zwz, pwn, ptn(:,:,:,jn) )
+         END IF
+         !                                 ! "Poleward" heat and salt transports 
+         IF( l_ptr )   CALL dia_ptr_hst( jn, 'adv', zwy(:,:,:) )
+         !                                 !  heat and salt transport
+         IF( l_hst )   CALL dia_ar5_hst( jn, 'adv', zwx(:,:,:), zwy(:,:,:) )
+         !
+      END DO
+      !
+   END SUBROUTINE tra_adv_cen
+   
+   !!======================================================================
+END MODULE traadv_cen
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/TRA/traadv_fct.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/TRA/traadv_fct.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/TRA/traadv_fct.F90	(revision 9570)
@@ -0,0 +1,685 @@
+MODULE traadv_fct
+   !!==============================================================================
+   !!                       ***  MODULE  traadv_fct  ***
+   !! Ocean  tracers:  horizontal & vertical advective trend (2nd/4th order Flux Corrected Transport method)
+   !!==============================================================================
+   !! History :  3.7  !  2015-09  (L. Debreu, G. Madec)  original code (inspired from traadv_tvd.F90)
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!  tra_adv_fct    : update the tracer trend with a 3D advective trends using a 2nd or 4th order FCT scheme
+   !!                   with sub-time-stepping in the vertical direction
+   !!  nonosc         : compute monotonic tracer fluxes by a non-oscillatory algorithm 
+   !!  interp_4th_cpt : 4th order compact scheme for the vertical component of the advection
+   !!----------------------------------------------------------------------
+   USE oce            ! ocean dynamics and active tracers
+   USE dom_oce        ! ocean space and time domain
+   USE trc_oce        ! share passive tracers/Ocean variables
+   USE trd_oce        ! trends: ocean variables
+   USE trdtra         ! tracers trends
+   USE diaptr         ! poleward transport diagnostics
+   USE diaar5         ! AR5 diagnostics
+   USE phycst  , ONLY : rau0_rcp
+   !
+   USE in_out_manager ! I/O manager
+   USE iom            ! 
+   USE lib_mpp        ! MPP library
+   USE lbclnk         ! ocean lateral boundary condition (or mpp link) 
+   USE lib_fortran    ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined)  
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   tra_adv_fct        ! called by traadv.F90
+   PUBLIC   interp_4th_cpt     ! called by traadv_cen.F90
+
+   LOGICAL  ::   l_trd   ! flag to compute trends
+   LOGICAL  ::   l_ptr   ! flag to compute poleward transport
+   LOGICAL  ::   l_hst   ! flag to compute heat/salt transport
+   REAL(wp) ::   r1_6 = 1._wp / 6._wp   ! =1/6
+
+   !                                        ! tridiag solver associated indices:
+   INTEGER, PARAMETER ::   np_NH   = 0   ! Neumann homogeneous boundary condition
+   INTEGER, PARAMETER ::   np_CEN2 = 1   ! 2nd order centered  boundary condition
+
+   !! * Substitutions
+#  include "vectopt_loop_substitute.h90"
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 4.0 , NEMO Consortium (2017)
+   !! $Id$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE tra_adv_fct( kt, kit000, cdtype, p2dt, pun, pvn, pwn,       &
+      &                                              ptb, ptn, pta, kjpt, kn_fct_h, kn_fct_v )
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE tra_adv_fct  ***
+      !! 
+      !! **  Purpose :   Compute the now trend due to total advection of tracers
+      !!               and add it to the general trend of tracer equations
+      !!
+      !! **  Method  : - 2nd or 4th FCT scheme on the horizontal direction
+      !!               (choice through the value of kn_fct)
+      !!               - on the vertical the 4th order is a compact scheme 
+      !!               - corrected flux (monotonic correction) 
+      !!
+      !! ** Action : - update pta  with the now advective tracer trends
+      !!             - send trends to trdtra module for further diagnostics (l_trdtra=T)
+      !!             - htr_adv, str_adv : poleward advective heat and salt transport (ln_diaptr=T)
+      !!----------------------------------------------------------------------
+      INTEGER                              , INTENT(in   ) ::   kt              ! ocean time-step index
+      INTEGER                              , INTENT(in   ) ::   kit000          ! first time step index
+      CHARACTER(len=3)                     , INTENT(in   ) ::   cdtype          ! =TRA or TRC (tracer indicator)
+      INTEGER                              , INTENT(in   ) ::   kjpt            ! number of tracers
+      INTEGER                              , INTENT(in   ) ::   kn_fct_h        ! order of the FCT scheme (=2 or 4)
+      INTEGER                              , INTENT(in   ) ::   kn_fct_v        ! order of the FCT scheme (=2 or 4)
+      REAL(wp)                             , INTENT(in   ) ::   p2dt            ! tracer time-step
+      REAL(wp), DIMENSION(jpi,jpj,jpk     ), INTENT(in   ) ::   pun, pvn, pwn   ! 3 ocean velocity components
+      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   ) ::   ptb, ptn        ! before and now tracer fields
+      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) ::   pta             ! tracer trend 
+      !
+      INTEGER  ::   ji, jj, jk, jn                           ! dummy loop indices  
+      REAL(wp) ::   ztra                                     ! local scalar
+      REAL(wp) ::   zfp_ui, zfp_vj, zfp_wk, zC2t_u, zC4t_u   !   -      -
+      REAL(wp) ::   zfm_ui, zfm_vj, zfm_wk, zC2t_v, zC4t_v   !   -      -
+      REAL(wp), DIMENSION(jpi,jpj,jpk)        ::   zwi, zwx, zwy, zwz, ztu, ztv, zltu, zltv, ztw
+      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::   ztrdx, ztrdy, ztrdz, zptry
+      !!----------------------------------------------------------------------
+      !
+      IF( kt == kit000 )  THEN
+         IF(lwp) WRITE(numout,*)
+         IF(lwp) WRITE(numout,*) 'tra_adv_fct : FCT advection scheme on ', cdtype
+         IF(lwp) WRITE(numout,*) '~~~~~~~~~~~'
+      ENDIF
+      !
+      l_trd = .FALSE.            ! set local switches
+      l_hst = .FALSE.
+      l_ptr = .FALSE.
+      IF( ( cdtype =='TRA' .AND. l_trdtra  ) .OR. ( cdtype =='TRC' .AND. l_trdtrc ) )       l_trd = .TRUE.
+      IF(   cdtype =='TRA' .AND. ln_diaptr )                                                l_ptr = .TRUE. 
+      IF(   cdtype =='TRA' .AND. ( iom_use("uadv_heattr") .OR. iom_use("vadv_heattr") .OR.  &
+         &                         iom_use("uadv_salttr") .OR. iom_use("vadv_salttr")  ) )  l_hst = .TRUE.
+      !
+      IF( l_trd .OR. l_hst )  THEN
+         ALLOCATE( ztrdx(jpi,jpj,jpk), ztrdy(jpi,jpj,jpk), ztrdz(jpi,jpj,jpk) )
+         ztrdx(:,:,:) = 0._wp   ;    ztrdy(:,:,:) = 0._wp   ;   ztrdz(:,:,:) = 0._wp
+      ENDIF
+      !
+      IF( l_ptr ) THEN  
+         ALLOCATE( zptry(jpi,jpj,jpk) )
+         zptry(:,:,:) = 0._wp
+      ENDIF
+      !                          ! surface & bottom value : flux set to zero one for all
+      zwz(:,:, 1 ) = 0._wp            
+      zwx(:,:,jpk) = 0._wp   ;   zwy(:,:,jpk) = 0._wp    ;    zwz(:,:,jpk) = 0._wp
+      !
+      zwi(:,:,:) = 0._wp        
+      !
+      DO jn = 1, kjpt            !==  loop over the tracers  ==!
+         !
+         !        !==  upstream advection with initial mass fluxes & intermediate update  ==!
+         !                    !* upstream tracer flux in the i and j direction 
+         DO jk = 1, jpkm1
+            DO jj = 1, jpjm1
+               DO ji = 1, fs_jpim1   ! vector opt.
+                  ! upstream scheme
+                  zfp_ui = pun(ji,jj,jk) + ABS( pun(ji,jj,jk) )
+                  zfm_ui = pun(ji,jj,jk) - ABS( pun(ji,jj,jk) )
+                  zfp_vj = pvn(ji,jj,jk) + ABS( pvn(ji,jj,jk) )
+                  zfm_vj = pvn(ji,jj,jk) - ABS( pvn(ji,jj,jk) )
+                  zwx(ji,jj,jk) = 0.5 * ( zfp_ui * ptb(ji,jj,jk,jn) + zfm_ui * ptb(ji+1,jj  ,jk,jn) )
+                  zwy(ji,jj,jk) = 0.5 * ( zfp_vj * ptb(ji,jj,jk,jn) + zfm_vj * ptb(ji  ,jj+1,jk,jn) )
+               END DO
+            END DO
+         END DO
+         !                    !* upstream tracer flux in the k direction *!
+         DO jk = 2, jpkm1        ! Interior value ( multiplied by wmask)
+            DO jj = 1, jpj
+               DO ji = 1, jpi
+                  zfp_wk = pwn(ji,jj,jk) + ABS( pwn(ji,jj,jk) )
+                  zfm_wk = pwn(ji,jj,jk) - ABS( pwn(ji,jj,jk) )
+                  zwz(ji,jj,jk) = 0.5 * ( zfp_wk * ptb(ji,jj,jk,jn) + zfm_wk * ptb(ji,jj,jk-1,jn) ) * wmask(ji,jj,jk)
+               END DO
+            END DO
+         END DO
+         IF( ln_linssh ) THEN    ! top ocean value (only in linear free surface as zwz has been w-masked)
+            IF( ln_isfcav ) THEN             ! top of the ice-shelf cavities and at the ocean surface
+               DO jj = 1, jpj
+                  DO ji = 1, jpi
+                     zwz(ji,jj, mikt(ji,jj) ) = pwn(ji,jj,mikt(ji,jj)) * ptb(ji,jj,mikt(ji,jj),jn)   ! linear free surface 
+                  END DO
+               END DO   
+            ELSE                             ! no cavities: only at the ocean surface
+               zwz(:,:,1) = pwn(:,:,1) * ptb(:,:,1,jn)
+            ENDIF
+         ENDIF
+         !               
+         DO jk = 1, jpkm1     !* trend and after field with monotonic scheme
+            DO jj = 2, jpjm1
+               DO ji = fs_2, fs_jpim1   ! vector opt.
+                  !                             ! total intermediate advective trends
+                  ztra = - (  zwx(ji,jj,jk) - zwx(ji-1,jj  ,jk  )   &
+                     &      + zwy(ji,jj,jk) - zwy(ji  ,jj-1,jk  )   &
+                     &      + zwz(ji,jj,jk) - zwz(ji  ,jj  ,jk+1) ) * r1_e1e2t(ji,jj)
+                  !                             ! update and guess with monotonic sheme
+                  pta(ji,jj,jk,jn) =                     pta(ji,jj,jk,jn) +        ztra   / e3t_n(ji,jj,jk) * tmask(ji,jj,jk)
+                  zwi(ji,jj,jk)    = ( e3t_b(ji,jj,jk) * ptb(ji,jj,jk,jn) + p2dt * ztra ) / e3t_a(ji,jj,jk) * tmask(ji,jj,jk)
+               END DO
+            END DO
+         END DO
+         CALL lbc_lnk( zwi, 'T', 1. )  ! Lateral boundary conditions on zwi  (unchanged sign)
+         !                
+         IF( l_trd .OR. l_hst )  THEN             ! trend diagnostics (contribution of upstream fluxes)
+            ztrdx(:,:,:) = zwx(:,:,:)   ;   ztrdy(:,:,:) = zwy(:,:,:)   ;   ztrdz(:,:,:) = zwz(:,:,:)
+         END IF
+         !                             ! "Poleward" heat and salt transports (contribution of upstream fluxes)
+         IF( l_ptr )   zptry(:,:,:) = zwy(:,:,:) 
+         !
+         !        !==  anti-diffusive flux : high order minus low order  ==!
+         !
+         SELECT CASE( kn_fct_h )    !* horizontal anti-diffusive fluxes
+         !
+         CASE(  2  )                   !- 2nd order centered
+            DO jk = 1, jpkm1
+               DO jj = 1, jpjm1
+                  DO ji = 1, fs_jpim1   ! vector opt.
+                     zwx(ji,jj,jk) = 0.5_wp * pun(ji,jj,jk) * ( ptn(ji,jj,jk,jn) + ptn(ji+1,jj,jk,jn) ) - zwx(ji,jj,jk)
+                     zwy(ji,jj,jk) = 0.5_wp * pvn(ji,jj,jk) * ( ptn(ji,jj,jk,jn) + ptn(ji,jj+1,jk,jn) ) - zwy(ji,jj,jk)
+                  END DO
+               END DO
+            END DO
+            !
+         CASE(  4  )                   !- 4th order centered
+            zltu(:,:,jpk) = 0._wp            ! Bottom value : flux set to zero
+            zltv(:,:,jpk) = 0._wp
+            DO jk = 1, jpkm1                 ! Laplacian
+               DO jj = 1, jpjm1                    ! 1st derivative (gradient)
+                  DO ji = 1, fs_jpim1   ! vector opt.
+                     ztu(ji,jj,jk) = ( ptn(ji+1,jj  ,jk,jn) - ptn(ji,jj,jk,jn) ) * umask(ji,jj,jk)
+                     ztv(ji,jj,jk) = ( ptn(ji  ,jj+1,jk,jn) - ptn(ji,jj,jk,jn) ) * vmask(ji,jj,jk)
+                  END DO
+               END DO
+               DO jj = 2, jpjm1                    ! 2nd derivative * 1/ 6
+                  DO ji = fs_2, fs_jpim1   ! vector opt.
+                     zltu(ji,jj,jk) = (  ztu(ji,jj,jk) + ztu(ji-1,jj,jk)  ) * r1_6
+                     zltv(ji,jj,jk) = (  ztv(ji,jj,jk) + ztv(ji,jj-1,jk)  ) * r1_6
+                  END DO
+               END DO
+            END DO
+            CALL lbc_lnk_multi( zltu, 'T', 1. , zltv, 'T', 1. )   ! Lateral boundary cond. (unchanged sgn)
+            !
+            DO jk = 1, jpkm1                 ! Horizontal advective fluxes
+               DO jj = 1, jpjm1
+                  DO ji = 1, fs_jpim1   ! vector opt.
+                     zC2t_u = ptn(ji,jj,jk,jn) + ptn(ji+1,jj  ,jk,jn)   ! 2 x C2 interpolation of T at u- & v-points
+                     zC2t_v = ptn(ji,jj,jk,jn) + ptn(ji  ,jj+1,jk,jn)
+                     !                                                  ! C4 minus upstream advective fluxes 
+                     zwx(ji,jj,jk) =  0.5_wp * pun(ji,jj,jk) * ( zC2t_u + zltu(ji,jj,jk) - zltu(ji+1,jj,jk) ) - zwx(ji,jj,jk)
+                     zwy(ji,jj,jk) =  0.5_wp * pvn(ji,jj,jk) * ( zC2t_v + zltv(ji,jj,jk) - zltv(ji,jj+1,jk) ) - zwy(ji,jj,jk)
+                  END DO
+               END DO
+            END DO         
+            !
+         CASE(  41 )                   !- 4th order centered       ==>>   !!gm coding attempt   need to be tested
+            ztu(:,:,jpk) = 0._wp             ! Bottom value : flux set to zero
+            ztv(:,:,jpk) = 0._wp
+            DO jk = 1, jpkm1                 ! 1st derivative (gradient)
+               DO jj = 1, jpjm1
+                  DO ji = 1, fs_jpim1   ! vector opt.
+                     ztu(ji,jj,jk) = ( ptn(ji+1,jj  ,jk,jn) - ptn(ji,jj,jk,jn) ) * umask(ji,jj,jk)
+                     ztv(ji,jj,jk) = ( ptn(ji  ,jj+1,jk,jn) - ptn(ji,jj,jk,jn) ) * vmask(ji,jj,jk)
+                  END DO
+               END DO
+            END DO
+            CALL lbc_lnk_multi( ztu, 'U', -1. , ztv, 'V', -1. )   ! Lateral boundary cond. (unchanged sgn)
+            !
+            DO jk = 1, jpkm1                 ! Horizontal advective fluxes
+               DO jj = 2, jpjm1
+                  DO ji = 2, fs_jpim1   ! vector opt.
+                     zC2t_u = ptn(ji,jj,jk,jn) + ptn(ji+1,jj  ,jk,jn)   ! 2 x C2 interpolation of T at u- & v-points (x2)
+                     zC2t_v = ptn(ji,jj,jk,jn) + ptn(ji  ,jj+1,jk,jn)
+                     !                                                  ! C4 interpolation of T at u- & v-points (x2)
+                     zC4t_u =  zC2t_u + r1_6 * ( ztu(ji-1,jj  ,jk) - ztu(ji+1,jj  ,jk) )
+                     zC4t_v =  zC2t_v + r1_6 * ( ztv(ji  ,jj-1,jk) - ztv(ji  ,jj+1,jk) )
+                     !                                                  ! C4 minus upstream advective fluxes 
+                     zwx(ji,jj,jk) =  0.5_wp * pun(ji,jj,jk) * zC4t_u - zwx(ji,jj,jk)
+                     zwy(ji,jj,jk) =  0.5_wp * pvn(ji,jj,jk) * zC4t_v - zwy(ji,jj,jk)
+                  END DO
+               END DO
+            END DO
+            !
+         END SELECT
+         !                      
+         SELECT CASE( kn_fct_v )    !* vertical anti-diffusive fluxes (w-masked interior values)
+         !
+         CASE(  2  )                   !- 2nd order centered
+            DO jk = 2, jpkm1    
+               DO jj = 2, jpjm1
+                  DO ji = fs_2, fs_jpim1
+                     zwz(ji,jj,jk) =  (  pwn(ji,jj,jk) * 0.5_wp * ( ptn(ji,jj,jk,jn) + ptn(ji,jj,jk-1,jn) )   &
+                        &              - zwz(ji,jj,jk)  ) * wmask(ji,jj,jk)
+                  END DO
+               END DO
+            END DO
+            !
+         CASE(  4  )                   !- 4th order COMPACT
+            CALL interp_4th_cpt( ptn(:,:,:,jn) , ztw )   ! zwt = COMPACT interpolation of T at w-point
+            DO jk = 2, jpkm1
+               DO jj = 2, jpjm1
+                  DO ji = fs_2, fs_jpim1
+                     zwz(ji,jj,jk) = ( pwn(ji,jj,jk) * ztw(ji,jj,jk) - zwz(ji,jj,jk) ) * wmask(ji,jj,jk)
+                  END DO
+               END DO
+            END DO
+            !
+         END SELECT
+         IF( ln_linssh ) THEN    ! top ocean value: high order = upstream  ==>>  zwz=0
+            zwz(:,:,1) = 0._wp   ! only ocean surface as interior zwz values have been w-masked
+         ENDIF
+         !
+         CALL lbc_lnk_multi( zwx, 'U', -1. , zwy, 'V', -1.,  zwz, 'W',  1. )
+         !
+         !        !==  monotonicity algorithm  ==!
+         !
+         CALL nonosc( ptb(:,:,:,jn), zwx, zwy, zwz, zwi, p2dt )
+         !
+         !        !==  final trend with corrected fluxes  ==!
+         !
+         DO jk = 1, jpkm1
+            DO jj = 2, jpjm1
+               DO ji = fs_2, fs_jpim1   ! vector opt.  
+                  pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) - (  zwx(ji,jj,jk) - zwx(ji-1,jj  ,jk  )   &
+                     &                                   + zwy(ji,jj,jk) - zwy(ji  ,jj-1,jk  )   &
+                     &                                   + zwz(ji,jj,jk) - zwz(ji  ,jj  ,jk+1) ) &
+                     &                                * r1_e1e2t(ji,jj) / e3t_n(ji,jj,jk)
+               END DO
+            END DO
+         END DO
+         !
+         IF( l_trd .OR. l_hst ) THEN   ! trend diagnostics // heat/salt transport
+            ztrdx(:,:,:) = ztrdx(:,:,:) + zwx(:,:,:)  ! <<< add anti-diffusive fluxes 
+            ztrdy(:,:,:) = ztrdy(:,:,:) + zwy(:,:,:)  !     to upstream fluxes
+            ztrdz(:,:,:) = ztrdz(:,:,:) + zwz(:,:,:)  !
+            !
+            IF( l_trd ) THEN              ! trend diagnostics
+               CALL trd_tra( kt, cdtype, jn, jptra_xad, ztrdx, pun, ptn(:,:,:,jn) )
+               CALL trd_tra( kt, cdtype, jn, jptra_yad, ztrdy, pvn, ptn(:,:,:,jn) )
+               CALL trd_tra( kt, cdtype, jn, jptra_zad, ztrdz, pwn, ptn(:,:,:,jn) )
+            ENDIF
+            !                             ! heat/salt transport
+            IF( l_hst )   CALL dia_ar5_hst( jn, 'adv', ztrdx(:,:,:), ztrdy(:,:,:) )
+            !
+            DEALLOCATE( ztrdx, ztrdy, ztrdz )
+         ENDIF
+         IF( l_ptr ) THEN              ! "Poleward" transports
+            zptry(:,:,:) = zptry(:,:,:) + zwy(:,:,:)  ! <<< add anti-diffusive fluxes
+            CALL dia_ptr_hst( jn, 'adv', zptry(:,:,:) )
+            DEALLOCATE( zptry )
+         ENDIF
+         !
+      END DO                     ! end of tracer loop
+      !
+   END SUBROUTINE tra_adv_fct
+
+
+   SUBROUTINE nonosc( pbef, paa, pbb, pcc, paft, p2dt )
+      !!---------------------------------------------------------------------
+      !!                    ***  ROUTINE nonosc  ***
+      !!     
+      !! **  Purpose :   compute monotonic tracer fluxes from the upstream 
+      !!       scheme and the before field by a nonoscillatory algorithm 
+      !!
+      !! **  Method  :   ... ???
+      !!       warning : pbef and paft must be masked, but the boundaries
+      !!       conditions on the fluxes are not necessary zalezak (1979)
+      !!       drange (1995) multi-dimensional forward-in-time and upstream-
+      !!       in-space based differencing for fluid
+      !!----------------------------------------------------------------------
+      REAL(wp)                         , INTENT(in   ) ::   p2dt            ! tracer time-step
+      REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT(in   ) ::   pbef, paft      ! before & after field
+      REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT(inout) ::   paa, pbb, pcc   ! monotonic fluxes in the 3 directions
+      !
+      INTEGER  ::   ji, jj, jk   ! dummy loop indices
+      INTEGER  ::   ikm1         ! local integer
+      REAL(wp) ::   zpos, zneg, zbt, za, zb, zc, zbig, zrtrn    ! local scalars
+      REAL(wp) ::   zau, zbu, zcu, zav, zbv, zcv, zup, zdo            !   -      -
+      REAL(wp), DIMENSION(jpi,jpj,jpk) :: zbetup, zbetdo, zbup, zbdo
+      !!----------------------------------------------------------------------
+      !
+      zbig  = 1.e+40_wp
+      zrtrn = 1.e-15_wp
+      zbetup(:,:,:) = 0._wp   ;   zbetdo(:,:,:) = 0._wp
+
+      ! Search local extrema
+      ! --------------------
+      ! max/min of pbef & paft with large negative/positive value (-/+zbig) inside land
+      zbup = MAX( pbef * tmask - zbig * ( 1._wp - tmask ),   &
+         &        paft * tmask - zbig * ( 1._wp - tmask )  )
+      zbdo = MIN( pbef * tmask + zbig * ( 1._wp - tmask ),   &
+         &        paft * tmask + zbig * ( 1._wp - tmask )  )
+
+      DO jk = 1, jpkm1
+         ikm1 = MAX(jk-1,1)
+         DO jj = 2, jpjm1
+            DO ji = fs_2, fs_jpim1   ! vector opt.
+
+               ! search maximum in neighbourhood
+               zup = MAX(  zbup(ji  ,jj  ,jk  ),   &
+                  &        zbup(ji-1,jj  ,jk  ), zbup(ji+1,jj  ,jk  ),   &
+                  &        zbup(ji  ,jj-1,jk  ), zbup(ji  ,jj+1,jk  ),   &
+                  &        zbup(ji  ,jj  ,ikm1), zbup(ji  ,jj  ,jk+1)  )
+
+               ! search minimum in neighbourhood
+               zdo = MIN(  zbdo(ji  ,jj  ,jk  ),   &
+                  &        zbdo(ji-1,jj  ,jk  ), zbdo(ji+1,jj  ,jk  ),   &
+                  &        zbdo(ji  ,jj-1,jk  ), zbdo(ji  ,jj+1,jk  ),   &
+                  &        zbdo(ji  ,jj  ,ikm1), zbdo(ji  ,jj  ,jk+1)  )
+
+               ! positive part of the flux
+               zpos = MAX( 0., paa(ji-1,jj  ,jk  ) ) - MIN( 0., paa(ji  ,jj  ,jk  ) )   &
+                  & + MAX( 0., pbb(ji  ,jj-1,jk  ) ) - MIN( 0., pbb(ji  ,jj  ,jk  ) )   &
+                  & + MAX( 0., pcc(ji  ,jj  ,jk+1) ) - MIN( 0., pcc(ji  ,jj  ,jk  ) )
+
+               ! negative part of the flux
+               zneg = MAX( 0., paa(ji  ,jj  ,jk  ) ) - MIN( 0., paa(ji-1,jj  ,jk  ) )   &
+                  & + MAX( 0., pbb(ji  ,jj  ,jk  ) ) - MIN( 0., pbb(ji  ,jj-1,jk  ) )   &
+                  & + MAX( 0., pcc(ji  ,jj  ,jk  ) ) - MIN( 0., pcc(ji  ,jj  ,jk+1) )
+
+               ! up & down beta terms
+               zbt = e1e2t(ji,jj) * e3t_n(ji,jj,jk) / p2dt
+               zbetup(ji,jj,jk) = ( zup            - paft(ji,jj,jk) ) / ( zpos + zrtrn ) * zbt
+               zbetdo(ji,jj,jk) = ( paft(ji,jj,jk) - zdo            ) / ( zneg + zrtrn ) * zbt
+            END DO
+         END DO
+      END DO
+      CALL lbc_lnk_multi( zbetup, 'T', 1. , zbetdo, 'T', 1. )   ! lateral boundary cond. (unchanged sign)
+
+      ! 3. monotonic flux in the i & j direction (paa & pbb)
+      ! ----------------------------------------
+      DO jk = 1, jpkm1
+         DO jj = 2, jpjm1
+            DO ji = fs_2, fs_jpim1   ! vector opt.
+               zau = MIN( 1._wp, zbetdo(ji,jj,jk), zbetup(ji+1,jj,jk) )
+               zbu = MIN( 1._wp, zbetup(ji,jj,jk), zbetdo(ji+1,jj,jk) )
+               zcu =       ( 0.5  + SIGN( 0.5 , paa(ji,jj,jk) ) )
+               paa(ji,jj,jk) = paa(ji,jj,jk) * ( zcu * zau + ( 1._wp - zcu) * zbu )
+
+               zav = MIN( 1._wp, zbetdo(ji,jj,jk), zbetup(ji,jj+1,jk) )
+               zbv = MIN( 1._wp, zbetup(ji,jj,jk), zbetdo(ji,jj+1,jk) )
+               zcv =       ( 0.5  + SIGN( 0.5 , pbb(ji,jj,jk) ) )
+               pbb(ji,jj,jk) = pbb(ji,jj,jk) * ( zcv * zav + ( 1._wp - zcv) * zbv )
+
+      ! monotonic flux in the k direction, i.e. pcc
+      ! -------------------------------------------
+               za = MIN( 1., zbetdo(ji,jj,jk+1), zbetup(ji,jj,jk) )
+               zb = MIN( 1., zbetup(ji,jj,jk+1), zbetdo(ji,jj,jk) )
+               zc =       ( 0.5  + SIGN( 0.5 , pcc(ji,jj,jk+1) ) )
+               pcc(ji,jj,jk+1) = pcc(ji,jj,jk+1) * ( zc * za + ( 1._wp - zc) * zb )
+            END DO
+         END DO
+      END DO
+      CALL lbc_lnk_multi( paa, 'U', -1. , pbb, 'V', -1. )   ! lateral boundary condition (changed sign)
+      !
+   END SUBROUTINE nonosc
+
+
+   SUBROUTINE interp_4th_cpt_org( pt_in, pt_out )
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE interp_4th_cpt_org  ***
+      !! 
+      !! **  Purpose :   Compute the interpolation of tracer at w-point
+      !!
+      !! **  Method  :   4th order compact interpolation
+      !!----------------------------------------------------------------------
+      REAL(wp),DIMENSION(jpi,jpj,jpk), INTENT(in   ) ::   pt_in    ! now tracer fields
+      REAL(wp),DIMENSION(jpi,jpj,jpk), INTENT(  out) ::   pt_out   ! now tracer field interpolated at w-pts
+      !
+      INTEGER :: ji, jj, jk   ! dummy loop integers
+      REAL(wp),DIMENSION(jpi,jpj,jpk) :: zwd, zwi, zws, zwrm, zwt
+      !!----------------------------------------------------------------------
+      
+      DO jk = 3, jpkm1        !==  build the three diagonal matrix  ==!
+         DO jj = 1, jpj
+            DO ji = 1, jpi
+               zwd (ji,jj,jk) = 4._wp
+               zwi (ji,jj,jk) = 1._wp
+               zws (ji,jj,jk) = 1._wp
+               zwrm(ji,jj,jk) = 3._wp * ( pt_in(ji,jj,jk-1) + pt_in(ji,jj,jk) )
+               !
+               IF( tmask(ji,jj,jk+1) == 0._wp) THEN   ! Switch to second order centered at bottom
+                  zwd (ji,jj,jk) = 1._wp
+                  zwi (ji,jj,jk) = 0._wp
+                  zws (ji,jj,jk) = 0._wp
+                  zwrm(ji,jj,jk) = 0.5 * ( pt_in(ji,jj,jk-1) + pt_in(ji,jj,jk) )    
+               ENDIF
+            END DO
+         END DO
+      END DO
+      !
+      jk = 2                                          ! Switch to second order centered at top
+      DO jj = 1, jpj
+         DO ji = 1, jpi
+            zwd (ji,jj,jk) = 1._wp
+            zwi (ji,jj,jk) = 0._wp
+            zws (ji,jj,jk) = 0._wp
+            zwrm(ji,jj,jk) = 0.5 * ( pt_in(ji,jj,jk-1) + pt_in(ji,jj,jk) )
+         END DO
+      END DO   
+      !
+      !                       !==  tridiagonal solve  ==!
+      DO jj = 1, jpj                ! first recurrence
+         DO ji = 1, jpi
+            zwt(ji,jj,2) = zwd(ji,jj,2)
+         END DO
+      END DO
+      DO jk = 3, jpkm1
+         DO jj = 1, jpj
+            DO ji = 1, jpi
+               zwt(ji,jj,jk) = zwd(ji,jj,jk) - zwi(ji,jj,jk) * zws(ji,jj,jk-1) /zwt(ji,jj,jk-1)
+            END DO
+         END DO
+      END DO
+      !
+      DO jj = 1, jpj                ! second recurrence:    Zk = Yk - Ik / Tk-1  Zk-1
+         DO ji = 1, jpi
+            pt_out(ji,jj,2) = zwrm(ji,jj,2)
+         END DO
+      END DO
+      DO jk = 3, jpkm1
+         DO jj = 1, jpj
+            DO ji = 1, jpi
+               pt_out(ji,jj,jk) = zwrm(ji,jj,jk) - zwi(ji,jj,jk) / zwt(ji,jj,jk-1) *pt_out(ji,jj,jk-1)             
+            END DO
+         END DO
+      END DO
+
+      DO jj = 1, jpj                ! third recurrence: Xk = (Zk - Sk Xk+1 ) / Tk
+         DO ji = 1, jpi
+            pt_out(ji,jj,jpkm1) = pt_out(ji,jj,jpkm1) / zwt(ji,jj,jpkm1)
+         END DO
+      END DO
+      DO jk = jpk-2, 2, -1
+         DO jj = 1, jpj
+            DO ji = 1, jpi
+               pt_out(ji,jj,jk) = ( pt_out(ji,jj,jk) - zws(ji,jj,jk) * pt_out(ji,jj,jk+1) ) / zwt(ji,jj,jk)
+            END DO
+         END DO
+      END DO
+      !    
+   END SUBROUTINE interp_4th_cpt_org
+   
+
+   SUBROUTINE interp_4th_cpt( pt_in, pt_out )
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE interp_4th_cpt  ***
+      !! 
+      !! **  Purpose :   Compute the interpolation of tracer at w-point
+      !!
+      !! **  Method  :   4th order compact interpolation
+      !!----------------------------------------------------------------------
+      REAL(wp),DIMENSION(jpi,jpj,jpk), INTENT(in   ) ::   pt_in    ! field at t-point
+      REAL(wp),DIMENSION(jpi,jpj,jpk), INTENT(  out) ::   pt_out   ! field interpolated at w-point
+      !
+      INTEGER ::   ji, jj, jk   ! dummy loop integers
+      INTEGER ::   ikt, ikb     ! local integers
+      REAL(wp),DIMENSION(jpi,jpj,jpk) :: zwd, zwi, zws, zwrm, zwt
+      !!----------------------------------------------------------------------
+      !
+      !                      !==  build the three diagonal matrix & the RHS  ==!
+      !
+      DO jk = 3, jpkm1                 ! interior (from jk=3 to jpk-1)
+         DO jj = 2, jpjm1
+            DO ji = fs_2, fs_jpim1
+               zwd (ji,jj,jk) = 3._wp * wmask(ji,jj,jk) + 1._wp                 !       diagonal
+               zwi (ji,jj,jk) =         wmask(ji,jj,jk)                         ! lower diagonal
+               zws (ji,jj,jk) =         wmask(ji,jj,jk)                         ! upper diagonal
+               zwrm(ji,jj,jk) = 3._wp * wmask(ji,jj,jk)                     &   ! RHS
+                  &           *       ( pt_in(ji,jj,jk) + pt_in(ji,jj,jk-1) )
+            END DO
+         END DO
+      END DO
+      !
+!!gm
+!      SELECT CASE( kbc )               !* boundary condition
+!      CASE( np_NH   )   ! Neumann homogeneous at top & bottom
+!      CASE( np_CEN2 )   ! 2nd order centered  at top & bottom
+!      END SELECT
+!!gm  
+      !
+      DO jj = 2, jpjm1                 ! 2nd order centered at top & bottom
+         DO ji = fs_2, fs_jpim1
+            ikt = mikt(ji,jj) + 1            ! w-point below the 1st  wet point
+            ikb = mbkt(ji,jj)                !     -   above the last wet point
+            !
+            zwd (ji,jj,ikt) = 1._wp          ! top
+            zwi (ji,jj,ikt) = 0._wp
+            zws (ji,jj,ikt) = 0._wp
+            zwrm(ji,jj,ikt) = 0.5_wp * ( pt_in(ji,jj,jk-1) + pt_in(ji,jj,jk) )
+            !
+            zwd (ji,jj,ikb) = 1._wp          ! bottom
+            zwi (ji,jj,ikb) = 0._wp
+            zws (ji,jj,ikb) = 0._wp
+            zwrm(ji,jj,ikb) = 0.5_wp * ( pt_in(ji,jj,jk-1) + pt_in(ji,jj,jk) )            
+         END DO
+      END DO   
+      !
+      !                       !==  tridiagonal solver  ==!
+      !
+      DO jj = 2, jpjm1              !* 1st recurrence:   Tk = Dk - Ik Sk-1 / Tk-1
+         DO ji = fs_2, fs_jpim1
+            zwt(ji,jj,2) = zwd(ji,jj,2)
+         END DO
+      END DO
+      DO jk = 3, jpkm1
+         DO jj = 2, jpjm1
+            DO ji = fs_2, fs_jpim1
+               zwt(ji,jj,jk) = zwd(ji,jj,jk) - zwi(ji,jj,jk) * zws(ji,jj,jk-1) /zwt(ji,jj,jk-1)
+            END DO
+         END DO
+      END DO
+      !
+      DO jj = 2, jpjm1              !* 2nd recurrence:    Zk = Yk - Ik / Tk-1  Zk-1
+         DO ji = fs_2, fs_jpim1
+            pt_out(ji,jj,2) = zwrm(ji,jj,2)
+         END DO
+      END DO
+      DO jk = 3, jpkm1
+         DO jj = 2, jpjm1
+            DO ji = fs_2, fs_jpim1
+               pt_out(ji,jj,jk) = zwrm(ji,jj,jk) - zwi(ji,jj,jk) / zwt(ji,jj,jk-1) *pt_out(ji,jj,jk-1)             
+            END DO
+         END DO
+      END DO
+
+      DO jj = 2, jpjm1              !* 3d recurrence:    Xk = (Zk - Sk Xk+1 ) / Tk
+         DO ji = fs_2, fs_jpim1
+            pt_out(ji,jj,jpkm1) = pt_out(ji,jj,jpkm1) / zwt(ji,jj,jpkm1)
+         END DO
+      END DO
+      DO jk = jpk-2, 2, -1
+         DO jj = 2, jpjm1
+            DO ji = fs_2, fs_jpim1
+               pt_out(ji,jj,jk) = ( pt_out(ji,jj,jk) - zws(ji,jj,jk) * pt_out(ji,jj,jk+1) ) / zwt(ji,jj,jk)
+            END DO
+         END DO
+      END DO
+      !    
+   END SUBROUTINE interp_4th_cpt
+
+
+   SUBROUTINE tridia_solver( pD, pU, pL, pRHS, pt_out , klev )
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE tridia_solver  ***
+      !! 
+      !! **  Purpose :   solve a symmetric 3diagonal system
+      !!
+      !! **  Method  :   solve M.t_out = RHS(t)  where M is a tri diagonal matrix ( jpk*jpk )
+      !!     
+      !!             ( D_1 U_1  0   0   0  )( t_1 )   ( RHS_1 )
+      !!             ( L_2 D_2 U_2  0   0  )( t_2 )   ( RHS_2 )
+      !!             (  0  L_3 D_3 U_3  0  )( t_3 ) = ( RHS_3 )
+      !!             (        ...          )( ... )   ( ...  )
+      !!             (  0   0   0  L_k D_k )( t_k )   ( RHS_k )
+      !!     
+      !!        M is decomposed in the product of an upper and lower triangular matrix.
+      !!        The tri-diagonals matrix is given as input 3D arrays:   pD, pU, pL 
+      !!        (i.e. the Diagonal, the Upper diagonal, and the Lower diagonal).
+      !!        The solution is pta.
+      !!        The 3d array zwt is used as a work space array.
+      !!----------------------------------------------------------------------
+      REAL(wp),DIMENSION(:,:,:), INTENT(in   ) ::   pD, pU, PL    ! 3-diagonal matrix
+      REAL(wp),DIMENSION(:,:,:), INTENT(in   ) ::   pRHS          ! Right-Hand-Side
+      REAL(wp),DIMENSION(:,:,:), INTENT(  out) ::   pt_out        !!gm field at level=F(klev)
+      INTEGER                  , INTENT(in   ) ::   klev          ! =1 pt_out at w-level 
+      !                                                           ! =0 pt at t-level
+      INTEGER ::   ji, jj, jk   ! dummy loop integers
+      INTEGER ::   kstart       ! local indices
+      REAL(wp),DIMENSION(jpi,jpj,jpk) ::   zwt   ! 3D work array
+      !!----------------------------------------------------------------------
+      !
+      kstart =  1  + klev
+      !
+      DO jj = 2, jpjm1              !* 1st recurrence:   Tk = Dk - Ik Sk-1 / Tk-1
+         DO ji = fs_2, fs_jpim1
+            zwt(ji,jj,kstart) = pD(ji,jj,kstart)
+         END DO
+      END DO
+      DO jk = kstart+1, jpkm1
+         DO jj = 2, jpjm1
+            DO ji = fs_2, fs_jpim1
+               zwt(ji,jj,jk) = pD(ji,jj,jk) - pL(ji,jj,jk) * pU(ji,jj,jk-1) /zwt(ji,jj,jk-1)
+            END DO
+         END DO
+      END DO
+      !
+      DO jj = 2, jpjm1              !* 2nd recurrence:    Zk = Yk - Ik / Tk-1  Zk-1
+         DO ji = fs_2, fs_jpim1
+            pt_out(ji,jj,kstart) = pRHS(ji,jj,kstart)
+         END DO
+      END DO
+      DO jk = kstart+1, jpkm1
+         DO jj = 2, jpjm1
+            DO ji = fs_2, fs_jpim1
+               pt_out(ji,jj,jk) = pRHS(ji,jj,jk) - pL(ji,jj,jk) / zwt(ji,jj,jk-1) *pt_out(ji,jj,jk-1)             
+            END DO
+         END DO
+      END DO
+
+      DO jj = 2, jpjm1              !* 3d recurrence:    Xk = (Zk - Sk Xk+1 ) / Tk
+         DO ji = fs_2, fs_jpim1
+            pt_out(ji,jj,jpkm1) = pt_out(ji,jj,jpkm1) / zwt(ji,jj,jpkm1)
+         END DO
+      END DO
+      DO jk = jpk-2, kstart, -1
+         DO jj = 2, jpjm1
+            DO ji = fs_2, fs_jpim1
+               pt_out(ji,jj,jk) = ( pt_out(ji,jj,jk) - pU(ji,jj,jk) * pt_out(ji,jj,jk+1) ) / zwt(ji,jj,jk)
+            END DO
+         END DO
+      END DO
+      !
+   END SUBROUTINE tridia_solver
+
+   !!======================================================================
+END MODULE traadv_fct
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/TRA/traadv_mus.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/TRA/traadv_mus.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/TRA/traadv_mus.F90	(revision 9570)
@@ -0,0 +1,277 @@
+MODULE traadv_mus
+   !!======================================================================
+   !!                       ***  MODULE  traadv_mus  ***
+   !! Ocean  tracers:  horizontal & vertical advective trend
+   !!======================================================================
+   !! History :       !  2000-06  (A.Estublier)  for passive tracers
+   !!                 !  2001-08  (E.Durand, G.Madec)  adapted for T & S
+   !!   NEMO     1.0  !  2002-06  (G. Madec)  F90: Free form and module
+   !!            3.2  !  2010-05  (C. Ethe, G. Madec)  merge TRC-TRA + switch from velocity to transport
+   !!            3.4  !  2012-06  (P. Oddo, M. Vichi) include the upstream where needed
+   !!            3.7  !  2015-09  (G. Madec) add the ice-shelf cavities boundary condition
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   tra_adv_mus   : update the tracer trend with the horizontal
+   !!                   and vertical advection trends using MUSCL scheme
+   !!----------------------------------------------------------------------
+   USE oce            ! ocean dynamics and active tracers
+   USE trc_oce        ! share passive tracers/Ocean variables
+   USE dom_oce        ! ocean space and time domain
+   USE trd_oce        ! trends: ocean variables
+   USE trdtra         ! tracers trends manager
+   USE sbcrnf         ! river runoffs
+   USE diaptr         ! poleward transport diagnostics
+   USE diaar5         ! AR5 diagnostics
+
+   !
+   USE iom            ! XIOS library
+   USE in_out_manager ! I/O manager
+   USE lib_mpp        ! distribued memory computing
+   USE lbclnk         ! ocean lateral boundary condition (or mpp link) 
+   USE lib_fortran    ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined)  
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   tra_adv_mus   ! routine called by traadv.F90
+   
+   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   upsmsk   !: mixed upstream/centered scheme near some straits
+   !                                                           !  and in closed seas (orca 2 and 1 configurations)
+   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   xind     !: mixed upstream/centered index
+   
+   LOGICAL  ::   l_trd   ! flag to compute trends
+   LOGICAL  ::   l_ptr   ! flag to compute poleward transport
+   LOGICAL  ::   l_hst   ! flag to compute heat/salt transport
+
+   !! * Substitutions
+#  include "vectopt_loop_substitute.h90"
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO Consortium (2010)
+   !! $Id$ 
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE tra_adv_mus( kt, kit000, cdtype, p2dt, pun, pvn, pwn,             &
+      &                                              ptb, pta, kjpt, ld_msc_ups )
+      !!----------------------------------------------------------------------
+      !!                    ***  ROUTINE tra_adv_mus  ***
+      !!
+      !! ** Purpose :   Compute the now trend due to total advection of tracers
+      !!              using a MUSCL scheme (Monotone Upstream-centered Scheme for
+      !!              Conservation Laws) and add it to the general tracer trend.
+      !!
+      !! ** Method  : MUSCL scheme plus centered scheme at ocean boundaries
+      !!              ld_msc_ups=T : 
+      !!
+      !! ** Action : - update pta  with the now advective tracer trends
+      !!             - send trends to trdtra module for further diagnostcs (l_trdtra=T)
+      !!             - htr_adv, str_adv : poleward advective heat and salt transport (ln_diaptr=T)
+      !!
+      !! References : Estubier, A., and M. Levy, Notes Techn. Pole de Modelisation
+      !!              IPSL, Sept. 2000 (http://www.lodyc.jussieu.fr/opa)
+      !!----------------------------------------------------------------------
+      INTEGER                              , INTENT(in   ) ::   kt              ! ocean time-step index
+      INTEGER                              , INTENT(in   ) ::   kit000          ! first time step index
+      CHARACTER(len=3)                     , INTENT(in   ) ::   cdtype          ! =TRA or TRC (tracer indicator)
+      INTEGER                              , INTENT(in   ) ::   kjpt            ! number of tracers
+      LOGICAL                              , INTENT(in   ) ::   ld_msc_ups      ! use upstream scheme within muscl
+      REAL(wp)                             , INTENT(in   ) ::   p2dt            ! tracer time-step
+      REAL(wp), DIMENSION(jpi,jpj,jpk     ), INTENT(in   ) ::   pun, pvn, pwn   ! 3 ocean velocity components
+      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   ) ::   ptb             ! before tracer field
+      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) ::   pta             ! tracer trend 
+      !
+      INTEGER  ::   ji, jj, jk, jn   ! dummy loop indices
+      INTEGER  ::   ierr             ! local integer
+      REAL(wp) ::   zu, z0u, zzwx, zw , zalpha   ! local scalars
+      REAL(wp) ::   zv, z0v, zzwy, z0w           !   -      -
+      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zwx, zslpx   ! 3D workspace
+      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zwy, zslpy   ! -      - 
+      !!----------------------------------------------------------------------
+      !
+      IF( kt == kit000 )  THEN
+         IF(lwp) WRITE(numout,*)
+         IF(lwp) WRITE(numout,*) 'tra_adv : MUSCL advection scheme on ', cdtype
+         IF(lwp) WRITE(numout,*) '        : mixed up-stream           ', ld_msc_ups
+         IF(lwp) WRITE(numout,*) '~~~~~~~'
+         IF(lwp) WRITE(numout,*)
+         !
+         ! Upstream / MUSCL scheme indicator
+         !
+         ALLOCATE( xind(jpi,jpj,jpk), STAT=ierr )
+         xind(:,:,:) = 1._wp              ! set equal to 1 where up-stream is not needed
+         !
+         IF( ld_msc_ups ) THEN            ! define the upstream indicator (if asked)
+            ALLOCATE( upsmsk(jpi,jpj), STAT=ierr )
+            upsmsk(:,:) = 0._wp                             ! not upstream by default
+            !
+            DO jk = 1, jpkm1
+               xind(:,:,jk) = 1._wp                              &                 ! =>1 where up-stream is not needed
+                  &         - MAX ( rnfmsk(:,:) * rnfmsk_z(jk),  &                 ! =>0 near runoff mouths (& closed sea outflows)
+                  &                 upsmsk(:,:)                ) * tmask(:,:,jk)   ! =>0 in some user defined area
+            END DO
+         ENDIF 
+         !
+      ENDIF 
+      !      
+      l_trd = .FALSE.
+      l_hst = .FALSE.
+      l_ptr = .FALSE.
+      IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype == 'TRC' .AND. l_trdtrc ) )      l_trd = .TRUE.
+      IF(   cdtype == 'TRA' .AND. ln_diaptr )                                               l_ptr = .TRUE. 
+      IF(   cdtype == 'TRA' .AND. ( iom_use("uadv_heattr") .OR. iom_use("vadv_heattr") .OR. &
+         &                          iom_use("uadv_salttr") .OR. iom_use("vadv_salttr")  ) ) l_hst = .TRUE.
+      !
+      DO jn = 1, kjpt            !==  loop over the tracers  ==!
+         !
+         !                          !* Horizontal advective fluxes
+         !
+         !                                !-- first guess of the slopes
+         zwx(:,:,jpk) = 0._wp                   ! bottom values
+         zwy(:,:,jpk) = 0._wp  
+         DO jk = 1, jpkm1                       ! interior values
+            DO jj = 1, jpjm1      
+               DO ji = 1, fs_jpim1   ! vector opt.
+                  zwx(ji,jj,jk) = umask(ji,jj,jk) * ( ptb(ji+1,jj,jk,jn) - ptb(ji,jj,jk,jn) )
+                  zwy(ji,jj,jk) = vmask(ji,jj,jk) * ( ptb(ji,jj+1,jk,jn) - ptb(ji,jj,jk,jn) )
+               END DO
+           END DO
+         END DO
+         ! lateral boundary conditions   (changed sign)
+         CALL lbc_lnk_multi( zwx, 'U', -1. , zwy, 'V', -1. )
+         !                                !-- Slopes of tracer
+         zslpx(:,:,jpk) = 0._wp                 ! bottom values
+         zslpy(:,:,jpk) = 0._wp
+         DO jk = 1, jpkm1                       ! interior values
+            DO jj = 2, jpj
+               DO ji = fs_2, jpi   ! vector opt.
+                  zslpx(ji,jj,jk) =                    ( zwx(ji,jj,jk) + zwx(ji-1,jj  ,jk) )   &
+                     &            * ( 0.25 + SIGN( 0.25, zwx(ji,jj,jk) * zwx(ji-1,jj  ,jk) ) )
+                  zslpy(ji,jj,jk) =                    ( zwy(ji,jj,jk) + zwy(ji  ,jj-1,jk) )   &
+                     &            * ( 0.25 + SIGN( 0.25, zwy(ji,jj,jk) * zwy(ji  ,jj-1,jk) ) )
+               END DO
+            END DO
+         END DO
+         !
+         DO jk = 1, jpkm1                 !-- Slopes limitation
+            DO jj = 2, jpj
+               DO ji = fs_2, jpi   ! vector opt.
+                  zslpx(ji,jj,jk) = SIGN( 1., zslpx(ji,jj,jk) ) * MIN(    ABS( zslpx(ji  ,jj,jk) ),   &
+                     &                                                 2.*ABS( zwx  (ji-1,jj,jk) ),   &
+                     &                                                 2.*ABS( zwx  (ji  ,jj,jk) ) )
+                  zslpy(ji,jj,jk) = SIGN( 1., zslpy(ji,jj,jk) ) * MIN(    ABS( zslpy(ji,jj  ,jk) ),   &
+                     &                                                 2.*ABS( zwy  (ji,jj-1,jk) ),   &
+                     &                                                 2.*ABS( zwy  (ji,jj  ,jk) ) )
+               END DO
+           END DO
+         END DO
+         !
+         DO jk = 1, jpkm1                 !-- MUSCL horizontal advective fluxes
+            DO jj = 2, jpjm1
+               DO ji = fs_2, fs_jpim1   ! vector opt.
+                  ! MUSCL fluxes
+                  z0u = SIGN( 0.5, pun(ji,jj,jk) )
+                  zalpha = 0.5 - z0u
+                  zu  = z0u - 0.5 * pun(ji,jj,jk) * p2dt * r1_e1e2u(ji,jj) / e3u_n(ji,jj,jk)
+                  zzwx = ptb(ji+1,jj,jk,jn) + xind(ji,jj,jk) * zu * zslpx(ji+1,jj,jk)
+                  zzwy = ptb(ji  ,jj,jk,jn) + xind(ji,jj,jk) * zu * zslpx(ji  ,jj,jk)
+                  zwx(ji,jj,jk) = pun(ji,jj,jk) * ( zalpha * zzwx + (1.-zalpha) * zzwy )
+                  !
+                  z0v = SIGN( 0.5, pvn(ji,jj,jk) )
+                  zalpha = 0.5 - z0v
+                  zv  = z0v - 0.5 * pvn(ji,jj,jk) * p2dt * r1_e1e2v(ji,jj) / e3v_n(ji,jj,jk)
+                  zzwx = ptb(ji,jj+1,jk,jn) + xind(ji,jj,jk) * zv * zslpy(ji,jj+1,jk)
+                  zzwy = ptb(ji,jj  ,jk,jn) + xind(ji,jj,jk) * zv * zslpy(ji,jj  ,jk)
+                  zwy(ji,jj,jk) = pvn(ji,jj,jk) * ( zalpha * zzwx + (1.-zalpha) * zzwy )
+               END DO
+            END DO
+         END DO
+         CALL lbc_lnk_multi( zwx, 'U', -1. , zwy, 'V', -1. )   ! lateral boundary conditions   (changed sign)
+         !
+         DO jk = 1, jpkm1                 !-- Tracer advective trend
+            DO jj = 2, jpjm1      
+               DO ji = fs_2, fs_jpim1   ! vector opt.
+                  pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) - ( zwx(ji,jj,jk) - zwx(ji-1,jj  ,jk  )       &
+                  &                                     + zwy(ji,jj,jk) - zwy(ji  ,jj-1,jk  ) )     &
+                  &                                   * r1_e1e2t(ji,jj) / e3t_n(ji,jj,jk)
+               END DO
+           END DO
+         END DO        
+         !                                ! trend diagnostics
+         IF( l_trd )  THEN
+            CALL trd_tra( kt, cdtype, jn, jptra_xad, zwx, pun, ptb(:,:,:,jn) )
+            CALL trd_tra( kt, cdtype, jn, jptra_yad, zwy, pvn, ptb(:,:,:,jn) )
+         END IF
+         !                                 ! "Poleward" heat and salt transports 
+         IF( l_ptr )  CALL dia_ptr_hst( jn, 'adv', zwy(:,:,:) )
+         !                                 !  heat transport
+         IF( l_hst )  CALL dia_ar5_hst( jn, 'adv', zwx(:,:,:), zwy(:,:,:) )
+         !
+         !                          !* Vertical advective fluxes
+         !
+         !                                !-- first guess of the slopes
+         zwx(:,:, 1 ) = 0._wp                   ! surface & bottom boundary conditions
+         zwx(:,:,jpk) = 0._wp
+         DO jk = 2, jpkm1                       ! interior values
+            zwx(:,:,jk) = tmask(:,:,jk) * ( ptb(:,:,jk-1,jn) - ptb(:,:,jk,jn) )
+         END DO
+         !                                !-- Slopes of tracer
+         zslpx(:,:,1) = 0._wp                   ! surface values
+         DO jk = 2, jpkm1                       ! interior value
+            DO jj = 1, jpj
+               DO ji = 1, jpi
+                  zslpx(ji,jj,jk) =                     ( zwx(ji,jj,jk) + zwx(ji,jj,jk+1) )  &
+                     &            * (  0.25 + SIGN( 0.25, zwx(ji,jj,jk) * zwx(ji,jj,jk+1) )  )
+               END DO
+            END DO
+         END DO
+         DO jk = 2, jpkm1                 !-- Slopes limitation
+            DO jj = 1, jpj                      ! interior values
+               DO ji = 1, jpi
+                  zslpx(ji,jj,jk) = SIGN( 1., zslpx(ji,jj,jk) ) * MIN(    ABS( zslpx(ji,jj,jk  ) ),   &
+                     &                                                 2.*ABS( zwx  (ji,jj,jk+1) ),   &
+                     &                                                 2.*ABS( zwx  (ji,jj,jk  ) )  )
+               END DO
+            END DO
+         END DO
+         DO jk = 1, jpk-2                 !-- vertical advective flux
+            DO jj = 2, jpjm1      
+               DO ji = fs_2, fs_jpim1   ! vector opt.
+                  z0w = SIGN( 0.5, pwn(ji,jj,jk+1) )
+                  zalpha = 0.5 + z0w
+                  zw  = z0w - 0.5 * pwn(ji,jj,jk+1) * p2dt * r1_e1e2t(ji,jj) / e3w_n(ji,jj,jk+1)
+                  zzwx = ptb(ji,jj,jk+1,jn) + xind(ji,jj,jk) * zw * zslpx(ji,jj,jk+1)
+                  zzwy = ptb(ji,jj,jk  ,jn) + xind(ji,jj,jk) * zw * zslpx(ji,jj,jk  )
+                  zwx(ji,jj,jk+1) = pwn(ji,jj,jk+1) * ( zalpha * zzwx + (1.-zalpha) * zzwy ) * wmask(ji,jj,jk)
+               END DO 
+            END DO
+         END DO
+         IF( ln_linssh ) THEN                   ! top values, linear free surface only
+            IF( ln_isfcav ) THEN                      ! ice-shelf cavities (top of the ocean)
+               DO jj = 1, jpj
+                  DO ji = 1, jpi
+                     zwx(ji,jj, mikt(ji,jj) ) = pwn(ji,jj,mikt(ji,jj)) * ptb(ji,jj,mikt(ji,jj),jn)
+                  END DO
+               END DO   
+            ELSE                                      ! no cavities: only at the ocean surface
+               zwx(:,:,1) = pwn(:,:,1) * ptb(:,:,1,jn)
+            ENDIF
+         ENDIF
+         !
+         DO jk = 1, jpkm1                 !-- vertical advective trend
+            DO jj = 2, jpjm1      
+               DO ji = fs_2, fs_jpim1   ! vector opt.
+                  pta(ji,jj,jk,jn) =  pta(ji,jj,jk,jn) - ( zwx(ji,jj,jk) - zwx(ji,jj,jk+1) ) * r1_e1e2t(ji,jj) / e3t_n(ji,jj,jk)
+               END DO
+            END DO
+         END DO
+         !                                ! send trends for diagnostic
+         IF( l_trd )  CALL trd_tra( kt, cdtype, jn, jptra_zad, zwx, pwn, ptb(:,:,:,jn) )
+         !
+      END DO                     ! end of tracer loop
+      !
+   END SUBROUTINE tra_adv_mus
+
+   !!======================================================================
+END MODULE traadv_mus
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/TRA/traadv_qck.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/TRA/traadv_qck.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/TRA/traadv_qck.F90	(revision 9570)
@@ -0,0 +1,458 @@
+MODULE traadv_qck
+   !!==============================================================================
+   !!                       ***  MODULE  traadv_qck  ***
+   !! Ocean tracers:  horizontal & vertical advective trend
+   !!==============================================================================
+   !! History :  3.0  !  2008-07  (G. Reffray)  Original code
+   !!            3.3  !  2010-05  (C.Ethe, G. Madec)  merge TRC-TRA + switch from velocity to transport
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   tra_adv_qck    : update the tracer trend with the horizontal advection
+   !!                    trends using a 3rd order finite difference scheme
+   !!   tra_adv_qck_i  : apply QUICK scheme in i-direction
+   !!   tra_adv_qck_j  : apply QUICK scheme in j-direction
+   !!   tra_adv_cen2_k : 2nd centered scheme for the vertical advection
+   !!----------------------------------------------------------------------
+   USE oce             ! ocean dynamics and active tracers
+   USE dom_oce         ! ocean space and time domain
+   USE trc_oce         ! share passive tracers/Ocean variables
+   USE trd_oce         ! trends: ocean variables
+   USE trdtra          ! trends manager: tracers 
+   USE diaptr          ! poleward transport diagnostics
+   !
+   USE in_out_manager  ! I/O manager
+   USE lib_mpp         ! distribued memory computing
+   USE lbclnk          ! ocean lateral boundary condition (or mpp link)
+   USE lib_fortran     ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined)  
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   tra_adv_qck   ! routine called by step.F90
+
+   REAL(wp) :: r1_6 = 1./ 6.   ! 1/6 ratio
+
+   LOGICAL  ::   l_trd   ! flag to compute trends
+   LOGICAL  ::   l_ptr   ! flag to compute poleward transport
+
+
+   !! * Substitutions
+#  include "vectopt_loop_substitute.h90"
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 4.0 , NEMO Consortium (2017)
+   !! $Id$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE tra_adv_qck ( kt, kit000, cdtype, p2dt, pun, pvn, pwn,      &
+      &                                       ptb, ptn, pta, kjpt )
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE tra_adv_qck  ***
+      !!
+      !! ** Purpose :   Compute the now trend due to the advection of tracers
+      !!      and add it to the general trend of passive tracer equations.
+      !!
+      !! ** Method :   The advection is evaluated by a third order scheme
+      !!             For a positive velocity u :              u(i)>0
+      !!                                          |--FU--|--FC--|--FD--|------|
+      !!                                             i-1    i      i+1   i+2
+      !!
+      !!             For a negative velocity u :              u(i)<0
+      !!                                          |------|--FD--|--FC--|--FU--|
+      !!                                             i-1    i      i+1   i+2
+      !!             where  FU is the second upwind point
+      !!                    FD is the first douwning point
+      !!                    FC is the central point (or the first upwind point)
+      !!
+      !!      Flux(i) = u(i) * { 0.5(FC+FD)  -0.5C(i)(FD-FC)  -((1-C(i))/6)(FU+FD-2FC) }
+      !!                with C(i)=|u(i)|dx(i)/dt (=Courant number)
+      !!
+      !!         dt = 2*rdtra and the scalar values are tb and sb
+      !!
+      !!       On the vertical, the simple centered scheme used ptn
+      !!
+      !!               The fluxes are bounded by the ULTIMATE limiter to
+      !!             guarantee the monotonicity of the solution and to
+      !!            prevent the appearance of spurious numerical oscillations
+      !!
+      !! ** Action : - update pta  with the now advective tracer trends
+      !!             - send trends to trdtra module for further diagnostcs (l_trdtra=T)
+      !!             - htr_adv, str_adv : poleward advective heat and salt transport (ln_diaptr=T)
+      !!
+      !! ** Reference : Leonard (1979, 1991)
+      !!----------------------------------------------------------------------
+      INTEGER                              , INTENT(in   ) ::   kt              ! ocean time-step index
+      INTEGER                              , INTENT(in   ) ::   kit000          ! first time step index
+      CHARACTER(len=3)                     , INTENT(in   ) ::   cdtype          ! =TRA or TRC (tracer indicator)
+      INTEGER                              , INTENT(in   ) ::   kjpt            ! number of tracers
+      REAL(wp)                             , INTENT(in   ) ::   p2dt            ! tracer time-step
+      REAL(wp), DIMENSION(jpi,jpj,jpk     ), INTENT(in   ) ::   pun, pvn, pwn   ! 3 ocean velocity components
+      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   ) ::   ptb, ptn        ! before and now tracer fields
+      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) ::   pta             ! tracer trend 
+      !!----------------------------------------------------------------------
+      !
+      IF( kt == kit000 )  THEN
+         IF(lwp) WRITE(numout,*)
+         IF(lwp) WRITE(numout,*) 'tra_adv_qck : 3rd order quickest advection scheme on ', cdtype
+         IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~'
+         IF(lwp) WRITE(numout,*)
+      ENDIF
+      !
+      l_trd = .FALSE.
+      l_ptr = .FALSE.
+      IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype == 'TRC' .AND. l_trdtrc ) )      l_trd = .TRUE.
+      IF(   cdtype == 'TRA' .AND. ln_diaptr )                                               l_ptr = .TRUE. 
+      !
+      !
+      !        ! horizontal fluxes are computed with the QUICKEST + ULTIMATE scheme
+      CALL tra_adv_qck_i( kt, cdtype, p2dt, pun, ptb, ptn, pta, kjpt ) 
+      CALL tra_adv_qck_j( kt, cdtype, p2dt, pvn, ptb, ptn, pta, kjpt ) 
+
+      !        ! vertical fluxes are computed with the 2nd order centered scheme
+      CALL tra_adv_cen2_k( kt, cdtype, pwn,         ptn, pta, kjpt )
+      !
+   END SUBROUTINE tra_adv_qck
+
+
+   SUBROUTINE tra_adv_qck_i( kt, cdtype, p2dt, pun,                  &
+      &                                        ptb, ptn, pta, kjpt   )
+      !!----------------------------------------------------------------------
+      !!
+      !!----------------------------------------------------------------------
+      INTEGER                              , INTENT(in   ) ::   kt         ! ocean time-step index
+      CHARACTER(len=3)                     , INTENT(in   ) ::   cdtype     ! =TRA or TRC (tracer indicator)
+      INTEGER                              , INTENT(in   ) ::   kjpt       ! number of tracers
+      REAL(wp)                             , INTENT(in   ) ::   p2dt       ! tracer time-step
+      REAL(wp), DIMENSION(jpi,jpj,jpk     ), INTENT(in   ) ::   pun        ! i-velocity components
+      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   ) ::   ptb, ptn   ! before and now tracer fields
+      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) ::   pta        ! tracer trend 
+      !!
+      INTEGER  ::   ji, jj, jk, jn   ! dummy loop indices
+      REAL(wp) ::   ztra, zbtr, zdir, zdx, zmsk   ! local scalars
+      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zwx, zfu, zfc, zfd
+      !----------------------------------------------------------------------
+      !
+      !                                                          ! ===========
+      DO jn = 1, kjpt                                            ! tracer loop
+         !                                                       ! ===========
+         zfu(:,:,:) = 0._wp     ;   zfc(:,:,:) = 0._wp 
+         zfd(:,:,:) = 0._wp     ;   zwx(:,:,:) = 0._wp   
+         !
+!!gm why not using a SHIFT instruction...
+         DO jk = 1, jpkm1     !--- Computation of the ustream and downstream value of the tracer and the mask
+            DO jj = 2, jpjm1
+               DO ji = fs_2, fs_jpim1   ! vector opt.
+                  zfc(ji,jj,jk) = ptb(ji-1,jj,jk,jn)        ! Upstream   in the x-direction for the tracer
+                  zfd(ji,jj,jk) = ptb(ji+1,jj,jk,jn)        ! Downstream in the x-direction for the tracer
+               END DO
+            END DO
+         END DO
+         CALL lbc_lnk_multi( zfc(:,:,:), 'T', 1. , zfd(:,:,:), 'T', 1. )   ! Lateral boundary conditions 
+         
+         !
+         ! Horizontal advective fluxes
+         ! ---------------------------
+         DO jk = 1, jpkm1                             
+            DO jj = 2, jpjm1
+               DO ji = fs_2, fs_jpim1   ! vector opt.         
+                  zdir = 0.5 + SIGN( 0.5, pun(ji,jj,jk) )   ! if pun > 0 : zdir = 1 otherwise zdir = 0 
+                  zfu(ji,jj,jk) = zdir * zfc(ji,jj,jk ) + ( 1. - zdir ) * zfd(ji+1,jj,jk)  ! FU in the x-direction for T 
+               END DO
+            END DO
+         END DO
+         !
+         DO jk = 1, jpkm1  
+            DO jj = 2, jpjm1
+               DO ji = fs_2, fs_jpim1   ! vector opt.   
+                  zdir = 0.5 + SIGN( 0.5, pun(ji,jj,jk) )   ! if pun > 0 : zdir = 1 otherwise zdir = 0 
+                  zdx = ( zdir * e1t(ji,jj) + ( 1. - zdir ) * e1t(ji+1,jj) ) * e2u(ji,jj) * e3u_n(ji,jj,jk)
+                  zwx(ji,jj,jk)  = ABS( pun(ji,jj,jk) ) * p2dt / zdx    ! (0<zc_cfl<1 : Courant number on x-direction)
+                  zfc(ji,jj,jk)  = zdir * ptb(ji  ,jj,jk,jn) + ( 1. - zdir ) * ptb(ji+1,jj,jk,jn)  ! FC in the x-direction for T
+                  zfd(ji,jj,jk)  = zdir * ptb(ji+1,jj,jk,jn) + ( 1. - zdir ) * ptb(ji  ,jj,jk,jn)  ! FD in the x-direction for T
+               END DO
+            END DO
+         END DO 
+         !--- Lateral boundary conditions 
+         CALL lbc_lnk_multi( zfu(:,:,:), 'T', 1. , zfd(:,:,:), 'T', 1., zfc(:,:,:), 'T', 1.,  zwx(:,:,:), 'T', 1. )
+
+         !--- QUICKEST scheme
+         CALL quickest( zfu, zfd, zfc, zwx )
+         !
+         ! Mask at the T-points in the x-direction (mask=0 or mask=1)
+         DO jk = 1, jpkm1  
+            DO jj = 2, jpjm1
+               DO ji = fs_2, fs_jpim1   ! vector opt.               
+                  zfu(ji,jj,jk) = tmask(ji-1,jj,jk) + tmask(ji,jj,jk) + tmask(ji+1,jj,jk) - 2.
+               END DO
+            END DO
+         END DO
+         CALL lbc_lnk( zfu(:,:,:), 'T', 1. )      ! Lateral boundary conditions 
+
+         !
+         ! Tracer flux on the x-direction
+         DO jk = 1, jpkm1  
+            !
+            DO jj = 2, jpjm1
+               DO ji = fs_2, fs_jpim1   ! vector opt.               
+                  zdir = 0.5 + SIGN( 0.5, pun(ji,jj,jk) )   ! if pun > 0 : zdir = 1 otherwise zdir = 0 
+                  !--- If the second ustream point is a land point
+                  !--- the flux is computed by the 1st order UPWIND scheme
+                  zmsk = zdir * zfu(ji,jj,jk) + ( 1. - zdir ) * zfu(ji+1,jj,jk)
+                  zwx(ji,jj,jk) = zmsk * zwx(ji,jj,jk) + ( 1. - zmsk ) * zfc(ji,jj,jk)
+                  zwx(ji,jj,jk) = zwx(ji,jj,jk) * pun(ji,jj,jk)
+               END DO
+            END DO
+         END DO
+         !
+         CALL lbc_lnk( zwx(:,:,:), 'T', 1. ) ! Lateral boundary conditions
+         !
+         ! Computation of the trend
+         DO jk = 1, jpkm1  
+            DO jj = 2, jpjm1
+               DO ji = fs_2, fs_jpim1   ! vector opt.  
+                  zbtr = r1_e1e2t(ji,jj) / e3t_n(ji,jj,jk)
+                  ! horizontal advective trends
+                  ztra = - zbtr * ( zwx(ji,jj,jk) - zwx(ji-1,jj,jk) )
+                  !--- add it to the general tracer trends
+                  pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) + ztra
+               END DO
+            END DO
+         END DO
+         !                                 ! trend diagnostics
+         IF( l_trd )   CALL trd_tra( kt, cdtype, jn, jptra_xad, zwx, pun, ptn(:,:,:,jn) )
+         !
+      END DO
+      !
+   END SUBROUTINE tra_adv_qck_i
+
+
+   SUBROUTINE tra_adv_qck_j( kt, cdtype, p2dt, pvn,                &
+      &                                        ptb, ptn, pta, kjpt )
+      !!----------------------------------------------------------------------
+      !!
+      !!----------------------------------------------------------------------
+      INTEGER                              , INTENT(in   ) ::   kt         ! ocean time-step index
+      CHARACTER(len=3)                     , INTENT(in   ) ::   cdtype     ! =TRA or TRC (tracer indicator)
+      INTEGER                              , INTENT(in   ) ::   kjpt       ! number of tracers
+      REAL(wp)                             , INTENT(in   ) ::   p2dt       ! tracer time-step
+      REAL(wp), DIMENSION(jpi,jpj,jpk     ), INTENT(in   ) ::   pvn        ! j-velocity components
+      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   ) ::   ptb, ptn   ! before and now tracer fields
+      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) ::   pta        ! tracer trend 
+      !!
+      INTEGER  :: ji, jj, jk, jn                ! dummy loop indices
+      REAL(wp) :: ztra, zbtr, zdir, zdx, zmsk   ! local scalars
+      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zwy, zfu, zfc, zfd   ! 3D workspace
+      !----------------------------------------------------------------------
+      !
+      !                                                          ! ===========
+      DO jn = 1, kjpt                                            ! tracer loop
+         !                                                       ! ===========
+         zfu(:,:,:) = 0.0     ;   zfc(:,:,:) = 0.0  
+         zfd(:,:,:) = 0.0     ;   zwy(:,:,:) = 0.0     
+         !                                                  
+         DO jk = 1, jpkm1                                
+            !                                             
+            !--- Computation of the ustream and downstream value of the tracer and the mask
+            DO jj = 2, jpjm1
+               DO ji = fs_2, fs_jpim1   ! vector opt.
+                  ! Upstream in the x-direction for the tracer
+                  zfc(ji,jj,jk) = ptb(ji,jj-1,jk,jn)
+                  ! Downstream in the x-direction for the tracer
+                  zfd(ji,jj,jk) = ptb(ji,jj+1,jk,jn)
+               END DO
+            END DO
+         END DO
+         CALL lbc_lnk_multi( zfc(:,:,:), 'T', 1. , zfd(:,:,:), 'T', 1. )   ! Lateral boundary conditions 
+
+         
+         !
+         ! Horizontal advective fluxes
+         ! ---------------------------
+         !
+         DO jk = 1, jpkm1                             
+            DO jj = 2, jpjm1
+               DO ji = fs_2, fs_jpim1   ! vector opt.         
+                  zdir = 0.5 + SIGN( 0.5, pvn(ji,jj,jk) )   ! if pun > 0 : zdir = 1 otherwise zdir = 0 
+                  zfu(ji,jj,jk) = zdir * zfc(ji,jj,jk ) + ( 1. - zdir ) * zfd(ji,jj+1,jk)  ! FU in the x-direction for T 
+               END DO
+            END DO
+         END DO
+         !
+         DO jk = 1, jpkm1  
+            DO jj = 2, jpjm1
+               DO ji = fs_2, fs_jpim1   ! vector opt.   
+                  zdir = 0.5 + SIGN( 0.5, pvn(ji,jj,jk) )   ! if pun > 0 : zdir = 1 otherwise zdir = 0 
+                  zdx = ( zdir * e2t(ji,jj) + ( 1. - zdir ) * e2t(ji,jj+1) ) * e1v(ji,jj) * e3v_n(ji,jj,jk)
+                  zwy(ji,jj,jk)  = ABS( pvn(ji,jj,jk) ) * p2dt / zdx    ! (0<zc_cfl<1 : Courant number on x-direction)
+                  zfc(ji,jj,jk)  = zdir * ptb(ji,jj  ,jk,jn) + ( 1. - zdir ) * ptb(ji,jj+1,jk,jn)  ! FC in the x-direction for T
+                  zfd(ji,jj,jk)  = zdir * ptb(ji,jj+1,jk,jn) + ( 1. - zdir ) * ptb(ji,jj  ,jk,jn)  ! FD in the x-direction for T
+               END DO
+            END DO
+         END DO
+
+         !--- Lateral boundary conditions 
+         CALL lbc_lnk_multi( zfu(:,:,:), 'T', 1. , zfd(:,:,:), 'T', 1., zfc(:,:,:), 'T', 1., zwy(:,:,:), 'T', 1. )
+
+         !--- QUICKEST scheme
+         CALL quickest( zfu, zfd, zfc, zwy )
+         !
+         ! Mask at the T-points in the x-direction (mask=0 or mask=1)
+         DO jk = 1, jpkm1  
+            DO jj = 2, jpjm1
+               DO ji = fs_2, fs_jpim1   ! vector opt.               
+                  zfu(ji,jj,jk) = tmask(ji,jj-1,jk) + tmask(ji,jj,jk) + tmask(ji,jj+1,jk) - 2.
+               END DO
+            END DO
+         END DO
+         CALL lbc_lnk( zfu(:,:,:), 'T', 1. )    !--- Lateral boundary conditions 
+         !
+         ! Tracer flux on the x-direction
+         DO jk = 1, jpkm1  
+            !
+            DO jj = 2, jpjm1
+               DO ji = fs_2, fs_jpim1   ! vector opt.               
+                  zdir = 0.5 + SIGN( 0.5, pvn(ji,jj,jk) )   ! if pun > 0 : zdir = 1 otherwise zdir = 0 
+                  !--- If the second ustream point is a land point
+                  !--- the flux is computed by the 1st order UPWIND scheme
+                  zmsk = zdir * zfu(ji,jj,jk) + ( 1. - zdir ) * zfu(ji,jj+1,jk)
+                  zwy(ji,jj,jk) = zmsk * zwy(ji,jj,jk) + ( 1. - zmsk ) * zfc(ji,jj,jk)
+                  zwy(ji,jj,jk) = zwy(ji,jj,jk) * pvn(ji,jj,jk)
+               END DO
+            END DO
+         END DO
+         !
+         CALL lbc_lnk( zwy(:,:,:), 'T', 1. ) ! Lateral boundary conditions
+         !
+         ! Computation of the trend
+         DO jk = 1, jpkm1  
+            DO jj = 2, jpjm1
+               DO ji = fs_2, fs_jpim1   ! vector opt.  
+                  zbtr = r1_e1e2t(ji,jj) / e3t_n(ji,jj,jk)
+                  ! horizontal advective trends
+                  ztra = - zbtr * ( zwy(ji,jj,jk) - zwy(ji,jj-1,jk) )
+                  !--- add it to the general tracer trends
+                  pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) + ztra
+               END DO
+            END DO
+         END DO
+         !                                 ! trend diagnostics
+         IF( l_trd )   CALL trd_tra( kt, cdtype, jn, jptra_yad, zwy, pvn, ptn(:,:,:,jn) )
+         !                                 ! "Poleward" heat and salt transports (contribution of upstream fluxes)
+         IF( l_ptr )   CALL dia_ptr_hst( jn, 'adv', zwy(:,:,:) )
+         !
+      END DO
+      !
+   END SUBROUTINE tra_adv_qck_j
+
+
+   SUBROUTINE tra_adv_cen2_k( kt, cdtype, pwn,           &
+     &                                    ptn, pta, kjpt )
+      !!----------------------------------------------------------------------
+      !!
+      !!----------------------------------------------------------------------
+      INTEGER                              , INTENT(in   ) ::   kt       ! ocean time-step index
+      CHARACTER(len=3)                     , INTENT(in   ) ::   cdtype   ! =TRA or TRC (tracer indicator)
+      INTEGER                              , INTENT(in   ) ::   kjpt     ! number of tracers
+      REAL(wp), DIMENSION(jpi,jpj,jpk     ), INTENT(in   ) ::   pwn      ! vertical velocity 
+      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   ) ::   ptn      ! before and now tracer fields
+      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) ::   pta      ! tracer trend 
+      !
+      INTEGER  ::   ji, jj, jk, jn   ! dummy loop indices
+      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zwz   ! 3D workspace
+      !!----------------------------------------------------------------------
+      !
+      zwz(:,:, 1 ) = 0._wp       ! surface & bottom values set to zero for all tracers
+      zwz(:,:,jpk) = 0._wp
+      !
+      !                                                          ! ===========
+      DO jn = 1, kjpt                                            ! tracer loop
+         !                                                       ! ===========
+         !
+         DO jk = 2, jpkm1                    !* Interior point   (w-masked 2nd order centered flux)
+            DO jj = 2, jpjm1
+               DO ji = fs_2, fs_jpim1   ! vector opt.
+                  zwz(ji,jj,jk) = 0.5 * pwn(ji,jj,jk) * ( ptn(ji,jj,jk-1,jn) + ptn(ji,jj,jk,jn) ) * wmask(ji,jj,jk)
+               END DO
+            END DO
+         END DO
+         IF( ln_linssh ) THEN                !* top value   (only in linear free surf. as zwz is multiplied by wmask)
+            IF( ln_isfcav ) THEN                  ! ice-shelf cavities (top of the ocean)
+               DO jj = 1, jpj
+                  DO ji = 1, jpi
+                     zwz(ji,jj, mikt(ji,jj) ) = pwn(ji,jj,mikt(ji,jj)) * ptn(ji,jj,mikt(ji,jj),jn)   ! linear free surface 
+                  END DO
+               END DO   
+            ELSE                                   ! no ocean cavities (only ocean surface)
+               zwz(:,:,1) = pwn(:,:,1) * ptn(:,:,1,jn)
+            ENDIF
+         ENDIF
+         !
+         DO jk = 1, jpkm1          !==  Tracer flux divergence added to the general trend  ==!
+            DO jj = 2, jpjm1
+               DO ji = fs_2, fs_jpim1   ! vector opt.
+                  pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) - ( zwz(ji,jj,jk) - zwz(ji,jj,jk+1) )   &
+                     &                                * r1_e1e2t(ji,jj) / e3t_n(ji,jj,jk)
+               END DO
+            END DO
+         END DO
+         !                                 ! Send trends for diagnostic
+         IF( l_trd )  CALL trd_tra( kt, cdtype, jn, jptra_zad, zwz, pwn, ptn(:,:,:,jn) )
+         !
+      END DO
+      !
+   END SUBROUTINE tra_adv_cen2_k
+
+
+   SUBROUTINE quickest( pfu, pfd, pfc, puc )
+      !!----------------------------------------------------------------------
+      !!
+      !! ** Purpose :  Computation of advective flux with Quickest scheme
+      !!
+      !! ** Method :   
+      !!----------------------------------------------------------------------
+      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in   ) ::   pfu   ! second upwind point
+      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in   ) ::   pfd   ! first douwning point
+      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in   ) ::   pfc   ! the central point (or the first upwind point)
+      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   puc   ! input as Courant number ; output as flux
+      !!
+      INTEGER  ::  ji, jj, jk               ! dummy loop indices 
+      REAL(wp) ::  zcoef1, zcoef2, zcoef3   ! local scalars          
+      REAL(wp) ::  zc, zcurv, zfho          !   -      -
+      !----------------------------------------------------------------------
+      !
+      DO jk = 1, jpkm1
+         DO jj = 1, jpj
+            DO ji = 1, jpi
+               zc     = puc(ji,jj,jk)                         ! Courant number
+               zcurv  = pfd(ji,jj,jk) + pfu(ji,jj,jk) - 2. * pfc(ji,jj,jk)
+               zcoef1 = 0.5 *      ( pfc(ji,jj,jk) + pfd(ji,jj,jk) )
+               zcoef2 = 0.5 * zc * ( pfd(ji,jj,jk) - pfc(ji,jj,jk) )
+               zcoef3 = ( 1. - ( zc * zc ) ) * r1_6 * zcurv
+               zfho   = zcoef1 - zcoef2 - zcoef3              !  phi_f QUICKEST 
+               !
+               zcoef1 = pfd(ji,jj,jk) - pfu(ji,jj,jk)
+               zcoef2 = ABS( zcoef1 )
+               zcoef3 = ABS( zcurv )
+               IF( zcoef3 >= zcoef2 ) THEN
+                  zfho = pfc(ji,jj,jk) 
+               ELSE
+                  zcoef3 = pfu(ji,jj,jk) + ( ( pfc(ji,jj,jk) - pfu(ji,jj,jk) ) / MAX( zc, 1.e-9 ) )    ! phi_REF
+                  IF( zcoef1 >= 0. ) THEN
+                     zfho = MAX( pfc(ji,jj,jk), zfho ) 
+                     zfho = MIN( zfho, MIN( zcoef3, pfd(ji,jj,jk) ) ) 
+                  ELSE
+                     zfho = MIN( pfc(ji,jj,jk), zfho ) 
+                     zfho = MAX( zfho, MAX( zcoef3, pfd(ji,jj,jk) ) ) 
+                  ENDIF
+               ENDIF
+               puc(ji,jj,jk) = zfho
+            END DO
+         END DO
+      END DO
+      !
+   END SUBROUTINE quickest
+
+   !!======================================================================
+END MODULE traadv_qck
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/TRA/traadv_ubs.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/TRA/traadv_ubs.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/TRA/traadv_ubs.F90	(revision 9570)
@@ -0,0 +1,377 @@
+MODULE traadv_ubs
+   !!==============================================================================
+   !!                       ***  MODULE  traadv_ubs  ***
+   !! Ocean active tracers:  horizontal & vertical advective trend
+   !!==============================================================================
+   !! History :  1.0  !  2006-08  (L. Debreu, R. Benshila)  Original code
+   !!            3.3  !  2010-05  (C. Ethe, G. Madec)  merge TRC-TRA + switch from velocity to transport
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   tra_adv_ubs : update the tracer trend with the horizontal
+   !!                 advection trends using a third order biaised scheme  
+   !!----------------------------------------------------------------------
+   USE oce            ! ocean dynamics and active tracers
+   USE dom_oce        ! ocean space and time domain
+   USE trc_oce        ! share passive tracers/Ocean variables
+   USE trd_oce        ! trends: ocean variables
+   USE traadv_fct      ! acces to routine interp_4th_cpt 
+   USE trdtra         ! trends manager: tracers 
+   USE diaptr         ! poleward transport diagnostics
+   USE diaar5         ! AR5 diagnostics
+   !
+   USE iom            ! I/O library
+   USE in_out_manager ! I/O manager
+   USE lib_mpp        ! massively parallel library
+   USE lbclnk         ! ocean lateral boundary condition (or mpp link)
+   USE lib_fortran    ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined)  
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   tra_adv_ubs   ! routine called by traadv module
+
+   LOGICAL :: l_trd   ! flag to compute trends
+   LOGICAL :: l_ptr   ! flag to compute poleward transport
+   LOGICAL :: l_hst   ! flag to compute heat transport
+
+
+   !! * Substitutions
+#  include "vectopt_loop_substitute.h90"
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.7 , NEMO Consortium (2015)
+   !! $Id$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE tra_adv_ubs( kt, kit000, cdtype, p2dt, pun, pvn, pwn,          &
+      &                                                ptb, ptn, pta, kjpt, kn_ubs_v )
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE tra_adv_ubs  ***
+      !!                 
+      !! ** Purpose :   Compute the now trend due to the advection of tracers
+      !!      and add it to the general trend of passive tracer equations.
+      !!
+      !! ** Method  :   The 3rd order Upstream Biased Scheme (UBS) is based on an
+      !!      upstream-biased parabolic interpolation (Shchepetkin and McWilliams 2005)
+      !!      It is only used in the horizontal direction.
+      !!      For example the i-component of the advective fluxes are given by :
+      !!                !  e2u e3u un ( mi(Tn) - zltu(i  ) )   if un(i) >= 0
+      !!          ztu = !  or 
+      !!                !  e2u e3u un ( mi(Tn) - zltu(i+1) )   if un(i) < 0
+      !!      where zltu is the second derivative of the before temperature field:
+      !!          zltu = 1/e3t di[ e2u e3u / e1u di[Tb] ]
+      !!        This results in a dissipatively dominant (i.e. hyper-diffusive) 
+      !!      truncation error. The overall performance of the advection scheme 
+      !!      is similar to that reported in (Farrow and Stevens, 1995). 
+      !!        For stability reasons, the first term of the fluxes which corresponds
+      !!      to a second order centered scheme is evaluated using the now velocity 
+      !!      (centered in time) while the second term which is the diffusive part 
+      !!      of the scheme, is evaluated using the before velocity (forward in time). 
+      !!      Note that UBS is not positive. Do not use it on passive tracers.
+      !!                On the vertical, the advection is evaluated using a FCT scheme,
+      !!      as the UBS have been found to be too diffusive. 
+      !!                kn_ubs_v argument controles whether the FCT is based on 
+      !!      a 2nd order centrered scheme (kn_ubs_v=2) or on a 4th order compact 
+      !!      scheme (kn_ubs_v=4).
+      !!
+      !! ** Action : - update pta  with the now advective tracer trends
+      !!             - send trends to trdtra module for further diagnostcs (l_trdtra=T)
+      !!             - htr_adv, str_adv : poleward advective heat and salt transport (ln_diaptr=T)
+      !!
+      !! Reference : Shchepetkin, A. F., J. C. McWilliams, 2005, Ocean Modelling, 9, 347-404. 
+      !!             Farrow, D.E., Stevens, D.P., 1995, J. Phys. Ocean. 25, 1731Ð1741. 
+      !!----------------------------------------------------------------------
+      INTEGER                              , INTENT(in   ) ::   kt              ! ocean time-step index
+      INTEGER                              , INTENT(in   ) ::   kit000          ! first time step index
+      CHARACTER(len=3)                     , INTENT(in   ) ::   cdtype          ! =TRA or TRC (tracer indicator)
+      INTEGER                              , INTENT(in   ) ::   kjpt            ! number of tracers
+      INTEGER                              , INTENT(in   ) ::   kn_ubs_v        ! number of tracers
+      REAL(wp)                             , INTENT(in   ) ::   p2dt            ! tracer time-step
+      REAL(wp), DIMENSION(jpi,jpj,jpk     ), INTENT(in   ) ::   pun, pvn, pwn   ! 3 ocean transport components
+      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   ) ::   ptb, ptn        ! before and now tracer fields
+      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) ::   pta             ! tracer trend 
+      !
+      INTEGER  ::   ji, jj, jk, jn   ! dummy loop indices
+      REAL(wp) ::   ztra, zbtr, zcoef                       ! local scalars
+      REAL(wp) ::   zfp_ui, zfm_ui, zcenut, ztak, zfp_wk, zfm_wk   !   -      -
+      REAL(wp) ::   zfp_vj, zfm_vj, zcenvt, zeeu, zeev, z_hdivn    !   -      -
+      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   ztu, ztv, zltu, zltv, zti, ztw   ! 3D workspace
+      !!----------------------------------------------------------------------
+      !
+      IF( kt == kit000 )  THEN
+         IF(lwp) WRITE(numout,*)
+         IF(lwp) WRITE(numout,*) 'tra_adv_ubs :  horizontal UBS advection scheme on ', cdtype
+         IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~'
+      ENDIF
+      !
+      l_trd = .FALSE.
+      l_hst = .FALSE.
+      l_ptr = .FALSE.
+      IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype == 'TRC' .AND. l_trdtrc ) )      l_trd = .TRUE.
+      IF(   cdtype == 'TRA' .AND. ln_diaptr )                                               l_ptr = .TRUE. 
+      IF(   cdtype == 'TRA' .AND. ( iom_use("uadv_heattr") .OR. iom_use("vadv_heattr") .OR. &
+         &                          iom_use("uadv_salttr") .OR. iom_use("vadv_salttr")  ) ) l_hst = .TRUE.
+      !
+      ztw (:,:, 1 ) = 0._wp      ! surface & bottom value : set to zero for all tracers
+      zltu(:,:,jpk) = 0._wp   ;   zltv(:,:,jpk) = 0._wp
+      ztw (:,:,jpk) = 0._wp   ;   zti (:,:,jpk) = 0._wp
+      !
+      !                                                          ! ===========
+      DO jn = 1, kjpt                                            ! tracer loop
+         !                                                       ! ===========
+         !                                              
+         DO jk = 1, jpkm1        !==  horizontal laplacian of before tracer ==!
+            DO jj = 1, jpjm1              ! First derivative (masked gradient)
+               DO ji = 1, fs_jpim1   ! vector opt.
+                  zeeu = e2_e1u(ji,jj) * e3u_n(ji,jj,jk) * umask(ji,jj,jk)
+                  zeev = e1_e2v(ji,jj) * e3v_n(ji,jj,jk) * vmask(ji,jj,jk)
+                  ztu(ji,jj,jk) = zeeu * ( ptb(ji+1,jj  ,jk,jn) - ptb(ji,jj,jk,jn) )
+                  ztv(ji,jj,jk) = zeev * ( ptb(ji  ,jj+1,jk,jn) - ptb(ji,jj,jk,jn) )
+               END DO
+            END DO
+            DO jj = 2, jpjm1              ! Second derivative (divergence)
+               DO ji = fs_2, fs_jpim1   ! vector opt.
+                  zcoef = 1._wp / ( 6._wp * e3t_n(ji,jj,jk) )
+                  zltu(ji,jj,jk) = (  ztu(ji,jj,jk) - ztu(ji-1,jj,jk)  ) * zcoef
+                  zltv(ji,jj,jk) = (  ztv(ji,jj,jk) - ztv(ji,jj-1,jk)  ) * zcoef
+               END DO
+            END DO
+            !                                    
+         END DO         
+         CALL lbc_lnk( zltu, 'T', 1. )   ;    CALL lbc_lnk( zltv, 'T', 1. )   ! Lateral boundary cond. (unchanged sgn)
+         !    
+         DO jk = 1, jpkm1        !==  Horizontal advective fluxes  ==!     (UBS)
+            DO jj = 1, jpjm1
+               DO ji = 1, fs_jpim1   ! vector opt.
+                  zfp_ui = pun(ji,jj,jk) + ABS( pun(ji,jj,jk) )      ! upstream transport (x2)
+                  zfm_ui = pun(ji,jj,jk) - ABS( pun(ji,jj,jk) )
+                  zfp_vj = pvn(ji,jj,jk) + ABS( pvn(ji,jj,jk) )
+                  zfm_vj = pvn(ji,jj,jk) - ABS( pvn(ji,jj,jk) )
+                  !                                                  ! 2nd order centered advective fluxes (x2)
+                  zcenut = pun(ji,jj,jk) * ( ptn(ji,jj,jk,jn) + ptn(ji+1,jj  ,jk,jn) )
+                  zcenvt = pvn(ji,jj,jk) * ( ptn(ji,jj,jk,jn) + ptn(ji  ,jj+1,jk,jn) )
+                  !                                                  ! UBS advective fluxes
+                  ztu(ji,jj,jk) = 0.5 * ( zcenut - zfp_ui * zltu(ji,jj,jk) - zfm_ui * zltu(ji+1,jj,jk) )
+                  ztv(ji,jj,jk) = 0.5 * ( zcenvt - zfp_vj * zltv(ji,jj,jk) - zfm_vj * zltv(ji,jj+1,jk) )
+               END DO
+            END DO
+         END DO         
+         !
+         zltu(:,:,:) = pta(:,:,:,jn)      ! store the initial trends before its update
+         !
+         DO jk = 1, jpkm1        !==  add the horizontal advective trend  ==!
+            DO jj = 2, jpjm1
+               DO ji = fs_2, fs_jpim1   ! vector opt.
+                  pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn)                        &
+                     &             - (  ztu(ji,jj,jk) - ztu(ji-1,jj  ,jk)    &
+                     &                + ztv(ji,jj,jk) - ztv(ji  ,jj-1,jk)  ) * r1_e1e2t(ji,jj) / e3t_n(ji,jj,jk)
+               END DO
+            END DO
+            !                                             
+         END DO
+         !
+         zltu(:,:,:) = pta(:,:,:,jn) - zltu(:,:,:)    ! Horizontal advective trend used in vertical 2nd order FCT case
+         !                                            ! and/or in trend diagnostic (l_trd=T) 
+         !                
+         IF( l_trd ) THEN                  ! trend diagnostics
+             CALL trd_tra( kt, cdtype, jn, jptra_xad, ztu, pun, ptn(:,:,:,jn) )
+             CALL trd_tra( kt, cdtype, jn, jptra_yad, ztv, pvn, ptn(:,:,:,jn) )
+         END IF
+         !     
+         !                                ! "Poleward" heat and salt transports (contribution of upstream fluxes)
+         IF( l_ptr )  CALL dia_ptr_hst( jn, 'adv', ztv(:,:,:) )
+         !                                !  heati/salt transport
+         IF( l_hst )  CALL dia_ar5_hst( jn, 'adv', ztu(:,:,:), ztv(:,:,:) )
+         !
+         !
+         !                       !== vertical advective trend  ==!
+         !
+         SELECT CASE( kn_ubs_v )       ! select the vertical advection scheme
+         !
+         CASE(  2  )                   ! 2nd order FCT 
+            !         
+            IF( l_trd )   zltv(:,:,:) = pta(:,:,:,jn)          ! store pta if trend diag.
+            !
+            !                          !*  upstream advection with initial mass fluxes & intermediate update  ==!
+            DO jk = 2, jpkm1                 ! Interior value (w-masked)
+               DO jj = 1, jpj
+                  DO ji = 1, jpi
+                     zfp_wk = pwn(ji,jj,jk) + ABS( pwn(ji,jj,jk) )
+                     zfm_wk = pwn(ji,jj,jk) - ABS( pwn(ji,jj,jk) )
+                     ztw(ji,jj,jk) = 0.5_wp * (  zfp_wk * ptb(ji,jj,jk,jn) + zfm_wk * ptb(ji,jj,jk-1,jn)  ) * wmask(ji,jj,jk)
+                  END DO
+               END DO
+            END DO 
+            IF( ln_linssh ) THEN             ! top ocean value (only in linear free surface as ztw has been w-masked)
+               IF( ln_isfcav ) THEN                ! top of the ice-shelf cavities and at the ocean surface
+                  DO jj = 1, jpj
+                     DO ji = 1, jpi
+                        ztw(ji,jj, mikt(ji,jj) ) = pwn(ji,jj,mikt(ji,jj)) * ptb(ji,jj,mikt(ji,jj),jn)   ! linear free surface 
+                     END DO
+                  END DO   
+               ELSE                                ! no cavities: only at the ocean surface
+                  ztw(:,:,1) = pwn(:,:,1) * ptb(:,:,1,jn)
+               ENDIF
+            ENDIF
+            !
+            DO jk = 1, jpkm1           !* trend and after field with monotonic scheme
+               DO jj = 2, jpjm1
+                  DO ji = fs_2, fs_jpim1   ! vector opt.
+                     ztak = - ( ztw(ji,jj,jk) - ztw(ji,jj,jk+1) ) * r1_e1e2t(ji,jj) / e3t_n(ji,jj,jk)
+                     pta(ji,jj,jk,jn) =   pta(ji,jj,jk,jn) +  ztak 
+                     zti(ji,jj,jk)    = ( ptb(ji,jj,jk,jn) + p2dt * ( ztak + zltu(ji,jj,jk) ) ) * tmask(ji,jj,jk)
+                  END DO
+               END DO
+            END DO
+            CALL lbc_lnk( zti, 'T', 1. )      ! Lateral boundary conditions on zti, zsi   (unchanged sign)
+            !
+            !                          !*  anti-diffusive flux : high order minus low order
+            DO jk = 2, jpkm1        ! Interior value  (w-masked)
+               DO jj = 1, jpj
+                  DO ji = 1, jpi
+                     ztw(ji,jj,jk) = (   0.5_wp * pwn(ji,jj,jk) * ( ptn(ji,jj,jk,jn) + ptn(ji,jj,jk-1,jn) )   &
+                        &              - ztw(ji,jj,jk)   ) * wmask(ji,jj,jk)
+                  END DO
+               END DO
+            END DO
+            !                                            ! top ocean value: high order == upstream  ==>>  zwz=0
+            IF( ln_linssh )   ztw(:,:, 1 ) = 0._wp       ! only ocean surface as interior zwz values have been w-masked
+            !
+            CALL nonosc_z( ptb(:,:,:,jn), ztw, zti, p2dt )      !  monotonicity algorithm
+            !
+         CASE(  4  )                               ! 4th order COMPACT
+            CALL interp_4th_cpt( ptn(:,:,:,jn) , ztw )         ! 4th order compact interpolation of T at w-point
+            DO jk = 2, jpkm1
+               DO jj = 2, jpjm1
+                  DO ji = fs_2, fs_jpim1
+                     ztw(ji,jj,jk) = pwn(ji,jj,jk) * ztw(ji,jj,jk) * wmask(ji,jj,jk)
+                  END DO
+               END DO
+            END DO
+            IF( ln_linssh )   ztw(:,:, 1 ) = pwn(:,:,1) * ptn(:,:,1,jn)     !!gm ISF & 4th COMPACT doesn't work
+            !
+         END SELECT
+         !
+         DO jk = 1, jpkm1        !  final trend with corrected fluxes
+            DO jj = 2, jpjm1 
+               DO ji = fs_2, fs_jpim1   ! vector opt.   
+                  pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) - ( ztw(ji,jj,jk) - ztw(ji,jj,jk+1) ) * r1_e1e2t(ji,jj) / e3t_n(ji,jj,jk)
+               END DO
+            END DO
+         END DO
+         !
+         IF( l_trd )  THEN       ! vertical advective trend diagnostics
+            DO jk = 1, jpkm1                       ! (compute -w.dk[ptn]= -dk[w.ptn] + ptn.dk[w])
+               DO jj = 2, jpjm1
+                  DO ji = fs_2, fs_jpim1   ! vector opt.
+                     zltv(ji,jj,jk) = pta(ji,jj,jk,jn) - zltv(ji,jj,jk)                          &
+                        &           + ptn(ji,jj,jk,jn) * (  pwn(ji,jj,jk) - pwn(ji,jj,jk+1)  )   &
+                        &                              * r1_e1e2t(ji,jj) / e3t_n(ji,jj,jk)
+                  END DO
+               END DO
+            END DO
+            CALL trd_tra( kt, cdtype, jn, jptra_zad, zltv )
+         ENDIF
+         !
+      END DO
+      !
+   END SUBROUTINE tra_adv_ubs
+
+
+   SUBROUTINE nonosc_z( pbef, pcc, paft, p2dt )
+      !!---------------------------------------------------------------------
+      !!                    ***  ROUTINE nonosc_z  ***
+      !!     
+      !! **  Purpose :   compute monotonic tracer fluxes from the upstream 
+      !!       scheme and the before field by a nonoscillatory algorithm 
+      !!
+      !! **  Method  :   ... ???
+      !!       warning : pbef and paft must be masked, but the boundaries
+      !!       conditions on the fluxes are not necessary zalezak (1979)
+      !!       drange (1995) multi-dimensional forward-in-time and upstream-
+      !!       in-space based differencing for fluid
+      !!----------------------------------------------------------------------
+      REAL(wp), INTENT(in   )                          ::   p2dt   ! tracer time-step
+      REAL(wp),                DIMENSION (jpi,jpj,jpk) ::   pbef   ! before field
+      REAL(wp), INTENT(inout), DIMENSION (jpi,jpj,jpk) ::   paft   ! after field
+      REAL(wp), INTENT(inout), DIMENSION (jpi,jpj,jpk) ::   pcc    ! monotonic flux in the k direction
+      !
+      INTEGER  ::   ji, jj, jk   ! dummy loop indices
+      INTEGER  ::   ikm1         ! local integer
+      REAL(wp) ::   zpos, zneg, zbt, za, zb, zc, zbig, zrtrn   ! local scalars
+      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zbetup, zbetdo     ! 3D workspace
+      !!----------------------------------------------------------------------
+      !
+      zbig  = 1.e+40_wp
+      zrtrn = 1.e-15_wp
+      zbetup(:,:,:) = 0._wp   ;   zbetdo(:,:,:) = 0._wp
+      !
+      ! Search local extrema
+      ! --------------------
+      !                    ! large negative value (-zbig) inside land
+      pbef(:,:,:) = pbef(:,:,:) * tmask(:,:,:) - zbig * ( 1.e0 - tmask(:,:,:) )
+      paft(:,:,:) = paft(:,:,:) * tmask(:,:,:) - zbig * ( 1.e0 - tmask(:,:,:) )
+      !
+      DO jk = 1, jpkm1     ! search maximum in neighbourhood
+         ikm1 = MAX(jk-1,1)
+         DO jj = 2, jpjm1
+            DO ji = fs_2, fs_jpim1   ! vector opt.
+               zbetup(ji,jj,jk) = MAX(  pbef(ji  ,jj  ,jk  ), paft(ji  ,jj  ,jk  ),   &
+                  &                     pbef(ji  ,jj  ,ikm1), pbef(ji  ,jj  ,jk+1),   &
+                  &                     paft(ji  ,jj  ,ikm1), paft(ji  ,jj  ,jk+1)  )
+            END DO
+         END DO
+      END DO
+      !                    ! large positive value (+zbig) inside land
+      pbef(:,:,:) = pbef(:,:,:) * tmask(:,:,:) + zbig * ( 1.e0 - tmask(:,:,:) )
+      paft(:,:,:) = paft(:,:,:) * tmask(:,:,:) + zbig * ( 1.e0 - tmask(:,:,:) )
+      !
+      DO jk = 1, jpkm1     ! search minimum in neighbourhood
+         ikm1 = MAX(jk-1,1)
+         DO jj = 2, jpjm1
+            DO ji = fs_2, fs_jpim1   ! vector opt.
+               zbetdo(ji,jj,jk) = MIN(  pbef(ji  ,jj  ,jk  ), paft(ji  ,jj  ,jk  ),   &
+                  &                     pbef(ji  ,jj  ,ikm1), pbef(ji  ,jj  ,jk+1),   &
+                  &                     paft(ji  ,jj  ,ikm1), paft(ji  ,jj  ,jk+1)  )
+            END DO
+         END DO
+      END DO
+      !                    ! restore masked values to zero
+      pbef(:,:,:) = pbef(:,:,:) * tmask(:,:,:)
+      paft(:,:,:) = paft(:,:,:) * tmask(:,:,:)
+      !
+      ! Positive and negative part of fluxes and beta terms
+      ! ---------------------------------------------------
+      DO jk = 1, jpkm1
+         DO jj = 2, jpjm1
+            DO ji = fs_2, fs_jpim1   ! vector opt.
+               ! positive & negative part of the flux
+               zpos = MAX( 0., pcc(ji  ,jj  ,jk+1) ) - MIN( 0., pcc(ji  ,jj  ,jk  ) )
+               zneg = MAX( 0., pcc(ji  ,jj  ,jk  ) ) - MIN( 0., pcc(ji  ,jj  ,jk+1) )
+               ! up & down beta terms
+               zbt = e1e2t(ji,jj) * e3t_n(ji,jj,jk) / p2dt
+               zbetup(ji,jj,jk) = ( zbetup(ji,jj,jk) - paft(ji,jj,jk) ) / (zpos+zrtrn) * zbt
+               zbetdo(ji,jj,jk) = ( paft(ji,jj,jk) - zbetdo(ji,jj,jk) ) / (zneg+zrtrn) * zbt
+            END DO
+         END DO
+      END DO
+      !
+      ! monotonic flux in the k direction, i.e. pcc
+      ! -------------------------------------------
+      DO jk = 2, jpkm1
+         DO jj = 2, jpjm1
+            DO ji = fs_2, fs_jpim1   ! vector opt.
+               za = MIN( 1., zbetdo(ji,jj,jk), zbetup(ji,jj,jk-1) )
+               zb = MIN( 1., zbetup(ji,jj,jk), zbetdo(ji,jj,jk-1) )
+               zc = 0.5 * ( 1.e0 + SIGN( 1.e0, pcc(ji,jj,jk) ) )
+               pcc(ji,jj,jk) = pcc(ji,jj,jk) * ( zc * za + ( 1.e0 - zc) * zb )
+            END DO
+         END DO
+      END DO
+      !
+   END SUBROUTINE nonosc_z
+
+   !!======================================================================
+END MODULE traadv_ubs
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/TRA/trabbc.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/TRA/trabbc.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/TRA/trabbc.F90	(revision 9570)
@@ -0,0 +1,194 @@
+MODULE trabbc
+   !!==============================================================================
+   !!                       ***  MODULE  trabbc  ***
+   !! Ocean active tracers:  bottom boundary condition (geothermal heat flux)
+   !!==============================================================================
+   !! History :  OPA  ! 1999-10 (G. Madec)  original code
+   !!   NEMO     1.0  ! 2002-08 (G. Madec)  free form + modules
+   !!             -   ! 2002-11 (A. Bozec)  tra_bbc_init: original code
+   !!            3.3  ! 2010-10 (G. Madec)  dynamical allocation + suppression of key_trabbc
+   !!             -   ! 2010-11 (G. Madec)  use mbkt array (deepest ocean t-level)
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   tra_bbc       : update the tracer trend at ocean bottom 
+   !!   tra_bbc_init  : initialization of geothermal heat flux trend
+   !!----------------------------------------------------------------------
+   USE oce            ! ocean variables
+   USE dom_oce        ! domain: ocean
+   USE phycst         ! physical constants
+   USE trd_oce        ! trends: ocean variables
+   USE trdtra         ! trends manager: tracers 
+   !
+   USE in_out_manager ! I/O manager
+   USE iom            ! xIOS 
+   USE fldread        ! read input fields
+   USE lbclnk         ! ocean lateral boundary conditions (or mpp link)
+   USE lib_mpp        ! distributed memory computing library
+   USE prtctl         ! Print control
+   USE timing         ! Timing
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC tra_bbc          ! routine called by step.F90
+   PUBLIC tra_bbc_init     ! routine called by opa.F90
+
+   !                                 !!* Namelist nambbc: bottom boundary condition *
+   LOGICAL, PUBLIC ::   ln_trabbc     !: Geothermal heat flux flag
+   INTEGER         ::   nn_geoflx     !  Geothermal flux (=1:constant flux, =2:read in file )
+   REAL(wp)        ::   rn_geoflx_cst !  Constant value of geothermal heat flux
+
+   REAL(wp), PUBLIC , ALLOCATABLE, DIMENSION(:,:) ::   qgh_trd0   ! geothermal heating trend
+
+   TYPE(FLD), ALLOCATABLE, DIMENSION(:) ::   sf_qgh   ! structure of input qgh (file informations, fields read)
+ 
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO Consortium (2010)
+   !! $Id$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE tra_bbc( kt )
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE tra_bbc  ***
+      !!
+      !! ** Purpose :   Compute the bottom boundary contition on temperature 
+      !!              associated with geothermal heating and add it to the 
+      !!              general trend of temperature equations.
+      !!
+      !! ** Method  :   The geothermal heat flux set to its constant value of 
+      !!              86.4 mW/m2 (Stein and Stein 1992, Huang 1999).
+      !!       The temperature trend associated to this heat flux through the
+      !!       ocean bottom can be computed once and is added to the temperature
+      !!       trend juste above the bottom at each time step:
+      !!            ta = ta + Qsf / (rau0 rcp e3T) for k= mbkt
+      !!       Where Qsf is the geothermal heat flux.
+      !!
+      !! ** Action  : - update the temperature trends with geothermal heating trend
+      !!              - send the trend for further diagnostics (ln_trdtra=T)
+      !!
+      !! References : Stein, C. A., and S. Stein, 1992, Nature, 359, 123-129.
+      !!              Emile-Geay and Madec, 2009, Ocean Science.
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT(in) ::   kt   ! ocean time-step index
+      !
+      INTEGER  ::   ji, jj    ! dummy loop indices
+      REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) ::   ztrdt   ! 3D workspace
+      !!----------------------------------------------------------------------
+      !
+      IF( ln_timing )   CALL timing_start('tra_bbc')
+      !
+      IF( l_trdtra )   THEN         ! Save the input temperature trend
+         ALLOCATE( ztrdt(jpi,jpj,jpk) )
+         ztrdt(:,:,:) = tsa(:,:,:,jp_tem)
+      ENDIF
+      !                             !  Add the geothermal trend on temperature
+      DO jj = 2, jpjm1
+         DO ji = 2, jpim1
+            tsa(ji,jj,mbkt(ji,jj),jp_tem) = tsa(ji,jj,mbkt(ji,jj),jp_tem) + qgh_trd0(ji,jj) / e3t_n(ji,jj,mbkt(ji,jj))
+         END DO
+      END DO
+      !
+      CALL lbc_lnk( tsa(:,:,:,jp_tem) , 'T', 1. )
+      !
+      IF( l_trdtra ) THEN        ! Send the trend for diagnostics
+         ztrdt(:,:,:) = tsa(:,:,:,jp_tem) - ztrdt(:,:,:)
+         CALL trd_tra( kt, 'TRA', jp_tem, jptra_bbc, ztrdt )
+         DEALLOCATE( ztrdt )
+      ENDIF
+      !
+      IF(ln_ctl)   CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' bbc  - Ta: ', mask1=tmask, clinfo3='tra-ta' )
+      !
+      IF( ln_timing )   CALL timing_stop('tra_bbc')
+      !
+   END SUBROUTINE tra_bbc
+
+
+   SUBROUTINE tra_bbc_init
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE tra_bbc_init  ***
+      !!
+      !! ** Purpose :   Compute once for all the trend associated with geothermal
+      !!              heating that will be applied at each time step at the
+      !!              last ocean level
+      !!
+      !! ** Method  :   Read the nambbc namelist and check the parameters.
+      !!
+      !! ** Input   : - Namlist nambbc
+      !!              - NetCDF file  : geothermal_heating.nc ( if necessary )
+      !!
+      !! ** Action  : - read/fix the geothermal heat qgh_trd0
+      !!----------------------------------------------------------------------
+      INTEGER  ::   ji, jj              ! dummy loop indices
+      INTEGER  ::   inum                ! temporary logical unit
+      INTEGER  ::   ios                 ! Local integer output status for namelist read
+      INTEGER  ::   ierror              ! local integer
+      !
+      TYPE(FLD_N)        ::   sn_qgh    ! informations about the geotherm. field to be read
+      CHARACTER(len=256) ::   cn_dir    ! Root directory for location of ssr files
+      !!
+      NAMELIST/nambbc/ln_trabbc, nn_geoflx, rn_geoflx_cst, sn_qgh, cn_dir 
+      !!----------------------------------------------------------------------
+      !
+      REWIND( numnam_ref )              ! Namelist nambbc in reference namelist : Bottom momentum boundary condition
+      READ  ( numnam_ref, nambbc, IOSTAT = ios, ERR = 901)
+901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'nambbc in reference namelist', lwp )
+      !
+      REWIND( numnam_cfg )              ! Namelist nambbc in configuration namelist : Bottom momentum boundary condition
+      READ  ( numnam_cfg, nambbc, IOSTAT = ios, ERR = 902 )
+902   IF( ios >  0 )   CALL ctl_nam ( ios , 'nambbc in configuration namelist', lwp )
+      IF(lwm) WRITE ( numond, nambbc )
+      !
+      IF(lwp) THEN                     ! Control print
+         WRITE(numout,*)
+         WRITE(numout,*) 'tra_bbc : Bottom Boundary Condition (bbc), apply a Geothermal heating'
+         WRITE(numout,*) '~~~~~~~   '
+         WRITE(numout,*) '   Namelist nambbc : set bbc parameters'
+         WRITE(numout,*) '      Apply a geothermal heating at ocean bottom   ln_trabbc     = ', ln_trabbc
+         WRITE(numout,*) '      type of geothermal flux                      nn_geoflx     = ', nn_geoflx
+         WRITE(numout,*) '      Constant geothermal flux value               rn_geoflx_cst = ', rn_geoflx_cst
+         WRITE(numout,*)
+      ENDIF
+      !
+      IF( ln_trabbc ) THEN             !==  geothermal heating  ==!
+         !
+         ALLOCATE( qgh_trd0(jpi,jpj) )    ! allocation
+         !
+         SELECT CASE ( nn_geoflx )        ! geothermal heat flux / (rauO * Cp)
+         !
+         CASE ( 1 )                          !* constant flux
+            IF(lwp) WRITE(numout,*) '   ==>>>   constant heat flux  =   ', rn_geoflx_cst
+            qgh_trd0(:,:) = r1_rau0_rcp * rn_geoflx_cst
+            !
+         CASE ( 2 )                          !* variable geothermal heat flux : read the geothermal fluxes in mW/m2
+            IF(lwp) WRITE(numout,*) '   ==>>>   variable geothermal heat flux'
+            !
+            ALLOCATE( sf_qgh(1), STAT=ierror )
+            IF( ierror > 0 ) THEN
+               CALL ctl_stop( 'tra_bbc_init: unable to allocate sf_qgh structure' )   ;
+               RETURN
+            ENDIF
+            ALLOCATE( sf_qgh(1)%fnow(jpi,jpj,1)   )
+            IF( sn_qgh%ln_tint )   ALLOCATE( sf_qgh(1)%fdta(jpi,jpj,1,2) )
+            ! fill sf_chl with sn_chl and control print
+            CALL fld_fill( sf_qgh, (/ sn_qgh /), cn_dir, 'tra_bbc_init',   &
+               &          'bottom temperature boundary condition', 'nambbc', no_print )
+
+            CALL fld_read( nit000, 1, sf_qgh )                         ! Read qgh data
+            qgh_trd0(:,:) = r1_rau0_rcp * sf_qgh(1)%fnow(:,:,1) * 1.e-3 ! conversion in W/m2
+            !
+         CASE DEFAULT
+            WRITE(ctmp1,*) '     bad flag value for nn_geoflx = ', nn_geoflx
+            CALL ctl_stop( ctmp1 )
+         END SELECT
+         !
+      ELSE
+         IF(lwp) WRITE(numout,*) '   ==>>>   no geothermal heat flux'
+      ENDIF
+      !
+   END SUBROUTINE tra_bbc_init
+
+   !!======================================================================
+END MODULE trabbc
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/TRA/trabbl.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/TRA/trabbl.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/TRA/trabbl.F90	(revision 9570)
@@ -0,0 +1,559 @@
+MODULE trabbl
+   !!==============================================================================
+   !!                       ***  MODULE  trabbl  ***
+   !! Ocean physics :  advective and/or diffusive bottom boundary layer scheme
+   !!==============================================================================
+   !! History :  OPA  ! 1996-06  (L. Mortier)  Original code
+   !!            8.0  ! 1997-11  (G. Madec)    Optimization
+   !!   NEMO     1.0  ! 2002-08  (G. Madec)  free form + modules
+   !!             -   ! 2004-01  (A. de Miranda, G. Madec, J.M. Molines ) add advective bbl
+   !!            3.3  ! 2009-11  (G. Madec)  merge trabbl and trabbl_adv + style + optimization
+   !!             -   ! 2010-04  (G. Madec)  Campin & Goosse advective bbl
+   !!             -   ! 2010-06  (C. Ethe, G. Madec)  merge TRA-TRC
+   !!             -   ! 2010-11  (G. Madec) add mbk. arrays associated to the deepest ocean level
+   !!             -   ! 2013-04  (F. Roquet, G. Madec)  use of eosbn2 instead of local hard coded alpha and beta
+   !!            4.0  ! 2017-04  (G. Madec)  ln_trabbl namelist variable instead of a CPP key
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   tra_bbl_alloc : allocate trabbl arrays
+   !!   tra_bbl       : update the tracer trends due to the bottom boundary layer (advective and/or diffusive)
+   !!   tra_bbl_dif   : generic routine to compute bbl diffusive trend
+   !!   tra_bbl_adv   : generic routine to compute bbl advective trend
+   !!   bbl           : computation of bbl diffu. flux coef. & transport in bottom boundary layer
+   !!   tra_bbl_init  : initialization, namelist read, parameters control
+   !!----------------------------------------------------------------------
+   USE oce            ! ocean dynamics and active tracers
+   USE dom_oce        ! ocean space and time domain
+   USE phycst         ! physical constant
+   USE eosbn2         ! equation of state
+   USE trd_oce        ! trends: ocean variables
+   USE trdtra         ! trends: active tracers
+   !
+   USE iom            ! IOM library               
+   USE in_out_manager ! I/O manager
+   USE lbclnk         ! ocean lateral boundary conditions
+   USE prtctl         ! Print control
+   USE timing         ! Timing
+   USE lib_fortran    ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined)  
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   tra_bbl       !  routine called by step.F90
+   PUBLIC   tra_bbl_init  !  routine called by nemogcm.F90
+   PUBLIC   tra_bbl_dif   !  routine called by trcbbl.F90
+   PUBLIC   tra_bbl_adv   !     -      -          -
+   PUBLIC   bbl           !  routine called by trcbbl.F90 and dtadyn.F90
+
+   !                                !!* Namelist nambbl *
+   LOGICAL , PUBLIC ::   ln_trabbl   !: bottom boundary layer flag
+   INTEGER , PUBLIC ::   nn_bbl_ldf  !: =1   : diffusive bbl or not (=0)
+   INTEGER , PUBLIC ::   nn_bbl_adv  !: =1/2 : advective bbl or not (=0)
+   !                                            !  =1 : advective bbl using the bottom ocean velocity
+   !                                            !  =2 :     -      -  using utr_bbl proportional to grad(rho)
+   REAL(wp), PUBLIC ::   rn_ahtbbl   !: along slope bbl diffusive coefficient [m2/s]
+   REAL(wp), PUBLIC ::   rn_gambbl   !: lateral coeff. for bottom boundary layer scheme [s]
+
+   LOGICAL , PUBLIC ::   l_bbl       !: flag to compute bbl diffu. flux coef and transport
+
+   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), PUBLIC ::   utr_bbl  , vtr_bbl   ! u- (v-) transport in the bottom boundary layer
+   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), PUBLIC ::   ahu_bbl  , ahv_bbl   ! masked diffusive bbl coeff. at u & v-pts
+
+   INTEGER , ALLOCATABLE, SAVE, DIMENSION(:,:), PUBLIC ::   mbku_d   , mbkv_d      ! vertical index of the "lower" bottom ocean U/V-level (PUBLIC for TAM)
+   INTEGER , ALLOCATABLE, SAVE, DIMENSION(:,:), PUBLIC ::   mgrhu    , mgrhv       ! = +/-1, sign of grad(H) in u-(v-)direction (PUBLIC for TAM)
+   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:)         ::   ahu_bbl_0, ahv_bbl_0   ! diffusive bbl flux coefficients at u and v-points
+   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), PUBLIC ::   e3u_bbl_0, e3v_bbl_0   ! thichness of the bbl (e3) at u and v-points (PUBLIC for TAM)
+
+   !! * Substitutions
+#  include "vectopt_loop_substitute.h90"
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO Consortium (2010)
+   !! $Id$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   INTEGER FUNCTION tra_bbl_alloc()
+      !!----------------------------------------------------------------------
+      !!                ***  FUNCTION tra_bbl_alloc  ***
+      !!----------------------------------------------------------------------
+      ALLOCATE( utr_bbl  (jpi,jpj) , ahu_bbl  (jpi,jpj) , mbku_d(jpi,jpj) , mgrhu(jpi,jpj) ,     &
+         &      vtr_bbl  (jpi,jpj) , ahv_bbl  (jpi,jpj) , mbkv_d(jpi,jpj) , mgrhv(jpi,jpj) ,     &
+         &      ahu_bbl_0(jpi,jpj) , ahv_bbl_0(jpi,jpj) ,                                        &
+         &      e3u_bbl_0(jpi,jpj) , e3v_bbl_0(jpi,jpj) ,                                    STAT=tra_bbl_alloc )
+         !
+      IF( lk_mpp            )   CALL mpp_sum ( tra_bbl_alloc )
+      IF( tra_bbl_alloc > 0 )   CALL ctl_warn('tra_bbl_alloc: allocation of arrays failed.')
+   END FUNCTION tra_bbl_alloc
+
+
+   SUBROUTINE tra_bbl( kt )
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE bbl  ***
+      !!
+      !! ** Purpose :   Compute the before tracer (t & s) trend associated
+      !!              with the bottom boundary layer and add it to the general
+      !!              trend of tracer equations.
+      !!
+      !! ** Method  :   Depending on namtra_bbl namelist parameters the bbl
+      !!              diffusive and/or advective contribution to the tracer trend
+      !!              is added to the general tracer trend
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT( in ) ::   kt   ! ocean time-step
+      !
+      REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) ::   ztrdt, ztrds
+      !!----------------------------------------------------------------------
+      !
+      IF( ln_timing )   CALL timing_start( 'tra_bbl')
+      !
+      IF( l_trdtra )   THEN                         !* Save the T-S input trends
+         ALLOCATE( ztrdt(jpi,jpj,jpk) , ztrds(jpi,jpj,jpk) )
+         ztrdt(:,:,:) = tsa(:,:,:,jp_tem)
+         ztrds(:,:,:) = tsa(:,:,:,jp_sal)
+      ENDIF
+
+      IF( l_bbl )   CALL bbl( kt, nit000, 'TRA' )   !* bbl coef. and transport (only if not already done in trcbbl)
+
+      IF( nn_bbl_ldf == 1 ) THEN                    !* Diffusive bbl
+         !
+         CALL tra_bbl_dif( tsb, tsa, jpts )
+         IF( ln_ctl )  &
+         CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' bbl_ldf  - Ta: ', mask1=tmask, &
+            &          tab3d_2=tsa(:,:,:,jp_sal), clinfo2=           ' Sa: ', mask2=tmask, clinfo3='tra' )
+         ! lateral boundary conditions ; just need for outputs
+         CALL lbc_lnk_multi( ahu_bbl, 'U', 1. , ahv_bbl, 'V', 1. )
+         CALL iom_put( "ahu_bbl", ahu_bbl )   ! bbl diffusive flux i-coef
+         CALL iom_put( "ahv_bbl", ahv_bbl )   ! bbl diffusive flux j-coef
+         !
+      ENDIF
+      !
+      IF( nn_bbl_adv /= 0 ) THEN                    !* Advective bbl
+         !
+         CALL tra_bbl_adv( tsb, tsa, jpts )
+         IF(ln_ctl)   &
+         CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' bbl_adv  - Ta: ', mask1=tmask,   &
+            &          tab3d_2=tsa(:,:,:,jp_sal), clinfo2=           ' Sa: ', mask2=tmask, clinfo3='tra' )
+         ! lateral boundary conditions ; just need for outputs
+         CALL lbc_lnk_multi( utr_bbl, 'U', 1. , vtr_bbl, 'V', 1. )
+         CALL iom_put( "uoce_bbl", utr_bbl )  ! bbl i-transport
+         CALL iom_put( "voce_bbl", vtr_bbl )  ! bbl j-transport
+         !
+      ENDIF
+
+      IF( l_trdtra )   THEN                      ! send the trends for further diagnostics
+         ztrdt(:,:,:) = tsa(:,:,:,jp_tem) - ztrdt(:,:,:)
+         ztrds(:,:,:) = tsa(:,:,:,jp_sal) - ztrds(:,:,:)
+         CALL trd_tra( kt, 'TRA', jp_tem, jptra_bbl, ztrdt )
+         CALL trd_tra( kt, 'TRA', jp_sal, jptra_bbl, ztrds )
+         DEALLOCATE( ztrdt, ztrds )
+      ENDIF
+      !
+      IF( ln_timing )  CALL timing_stop( 'tra_bbl')
+      !
+   END SUBROUTINE tra_bbl
+
+
+   SUBROUTINE tra_bbl_dif( ptb, pta, kjpt )
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE tra_bbl_dif  ***
+      !!
+      !! ** Purpose :   Computes the bottom boundary horizontal and vertical
+      !!                advection terms.
+      !!
+      !! ** Method  : * diffusive bbl only (nn_bbl_ldf=1) :
+      !!        When the product grad( rho) * grad(h) < 0 (where grad is an
+      !!      along bottom slope gradient) an additional lateral 2nd order
+      !!      diffusion along the bottom slope is added to the general
+      !!      tracer trend, otherwise the additional trend is set to 0.
+      !!      A typical value of ahbt is 2000 m2/s (equivalent to
+      !!      a downslope velocity of 20 cm/s if the condition for slope
+      !!      convection is satified)
+      !!
+      !! ** Action  :   pta   increased by the bbl diffusive trend
+      !!
+      !! References : Beckmann, A., and R. Doscher, 1997, J. Phys.Oceanogr., 581-591.
+      !!              Campin, J.-M., and H. Goosse, 1999, Tellus, 412-430.
+      !!----------------------------------------------------------------------
+      INTEGER                              , INTENT(in   ) ::   kjpt   ! number of tracers
+      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   ) ::   ptb    ! before and now tracer fields
+      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) ::   pta    ! tracer trend
+      !
+      INTEGER  ::   ji, jj, jn   ! dummy loop indices
+      INTEGER  ::   ik           ! local integers
+      REAL(wp) ::   zbtr         ! local scalars
+      REAL(wp), DIMENSION(jpi,jpj) ::   zptb   ! workspace
+      !!----------------------------------------------------------------------
+      !
+      DO jn = 1, kjpt                                     ! tracer loop
+         !                                                ! ===========
+         DO jj = 1, jpj
+            DO ji = 1, jpi
+               ik = mbkt(ji,jj)                             ! bottom T-level index
+               zptb(ji,jj) = ptb(ji,jj,ik,jn)               ! bottom before T and S
+            END DO
+         END DO
+         !               
+         DO jj = 2, jpjm1                                    ! Compute the trend
+            DO ji = 2, jpim1
+               ik = mbkt(ji,jj)                            ! bottom T-level index
+               pta(ji,jj,ik,jn) = pta(ji,jj,ik,jn)                                                  &
+                  &             + (  ahu_bbl(ji  ,jj  ) * ( zptb(ji+1,jj  ) - zptb(ji  ,jj  ) )     &
+                  &                - ahu_bbl(ji-1,jj  ) * ( zptb(ji  ,jj  ) - zptb(ji-1,jj  ) )     &
+                  &                + ahv_bbl(ji  ,jj  ) * ( zptb(ji  ,jj+1) - zptb(ji  ,jj  ) )     &
+                  &                - ahv_bbl(ji  ,jj-1) * ( zptb(ji  ,jj  ) - zptb(ji  ,jj-1) )  )  &
+                  &             * r1_e1e2t(ji,jj) / e3t_n(ji,jj,ik)
+            END DO
+         END DO
+         !                                                  ! ===========
+      END DO                                                ! end tracer
+      !                                                     ! ===========
+   END SUBROUTINE tra_bbl_dif
+
+
+   SUBROUTINE tra_bbl_adv( ptb, pta, kjpt )
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE trc_bbl  ***
+      !!
+      !! ** Purpose :   Compute the before passive tracer trend associated
+      !!     with the bottom boundary layer and add it to the general trend
+      !!     of tracer equations.
+      !! ** Method  :   advective bbl (nn_bbl_adv = 1 or 2) :
+      !!      nn_bbl_adv = 1   use of the ocean near bottom velocity as bbl velocity
+      !!      nn_bbl_adv = 2   follow Campin and Goosse (1999) implentation i.e.
+      !!                       transport proportional to the along-slope density gradient
+      !!
+      !! References : Beckmann, A., and R. Doscher, 1997, J. Phys.Oceanogr., 581-591.
+      !!              Campin, J.-M., and H. Goosse, 1999, Tellus, 412-430.
+      !!----------------------------------------------------------------------
+      INTEGER                              , INTENT(in   ) ::   kjpt   ! number of tracers
+      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   ) ::   ptb    ! before and now tracer fields
+      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) ::   pta    ! tracer trend
+      !
+      INTEGER  ::   ji, jj, jk, jn           ! dummy loop indices
+      INTEGER  ::   iis , iid , ijs , ijd    ! local integers
+      INTEGER  ::   ikus, ikud, ikvs, ikvd   !   -       -
+      REAL(wp) ::   zbtr, ztra               ! local scalars
+      REAL(wp) ::   zu_bbl, zv_bbl           !   -      -
+      !!----------------------------------------------------------------------
+      !
+      !                                                          ! ===========
+      DO jn = 1, kjpt                                            ! tracer loop
+         !                                                       ! ===========
+         DO jj = 1, jpjm1
+            DO ji = 1, jpim1            ! CAUTION start from i=1 to update i=2 when cyclic east-west
+               IF( utr_bbl(ji,jj) /= 0.e0 ) THEN            ! non-zero i-direction bbl advection
+                  ! down-slope i/k-indices (deep)      &   up-slope i/k indices (shelf)
+                  iid  = ji + MAX( 0, mgrhu(ji,jj) )   ;   iis  = ji + 1 - MAX( 0, mgrhu(ji,jj) )
+                  ikud = mbku_d(ji,jj)                 ;   ikus = mbku(ji,jj)
+                  zu_bbl = ABS( utr_bbl(ji,jj) )
+                  !
+                  !                                               ! up  -slope T-point (shelf bottom point)
+                  zbtr = r1_e1e2t(iis,jj) / e3t_n(iis,jj,ikus)
+                  ztra = zu_bbl * ( ptb(iid,jj,ikus,jn) - ptb(iis,jj,ikus,jn) ) * zbtr
+                  pta(iis,jj,ikus,jn) = pta(iis,jj,ikus,jn) + ztra
+                  !
+                  DO jk = ikus, ikud-1                            ! down-slope upper to down T-point (deep column)
+                     zbtr = r1_e1e2t(iid,jj) / e3t_n(iid,jj,jk)
+                     ztra = zu_bbl * ( ptb(iid,jj,jk+1,jn) - ptb(iid,jj,jk,jn) ) * zbtr
+                     pta(iid,jj,jk,jn) = pta(iid,jj,jk,jn) + ztra
+                  END DO
+                  !
+                  zbtr = r1_e1e2t(iid,jj) / e3t_n(iid,jj,ikud)
+                  ztra = zu_bbl * ( ptb(iis,jj,ikus,jn) - ptb(iid,jj,ikud,jn) ) * zbtr
+                  pta(iid,jj,ikud,jn) = pta(iid,jj,ikud,jn) + ztra
+               ENDIF
+               !
+               IF( vtr_bbl(ji,jj) /= 0.e0 ) THEN            ! non-zero j-direction bbl advection
+                  ! down-slope j/k-indices (deep)        &   up-slope j/k indices (shelf)
+                  ijd  = jj + MAX( 0, mgrhv(ji,jj) )     ;   ijs  = jj + 1 - MAX( 0, mgrhv(ji,jj) )
+                  ikvd = mbkv_d(ji,jj)                   ;   ikvs = mbkv(ji,jj)
+                  zv_bbl = ABS( vtr_bbl(ji,jj) )
+                  !
+                  ! up  -slope T-point (shelf bottom point)
+                  zbtr = r1_e1e2t(ji,ijs) / e3t_n(ji,ijs,ikvs)
+                  ztra = zv_bbl * ( ptb(ji,ijd,ikvs,jn) - ptb(ji,ijs,ikvs,jn) ) * zbtr
+                  pta(ji,ijs,ikvs,jn) = pta(ji,ijs,ikvs,jn) + ztra
+                  !
+                  DO jk = ikvs, ikvd-1                            ! down-slope upper to down T-point (deep column)
+                     zbtr = r1_e1e2t(ji,ijd) / e3t_n(ji,ijd,jk)
+                     ztra = zv_bbl * ( ptb(ji,ijd,jk+1,jn) - ptb(ji,ijd,jk,jn) ) * zbtr
+                     pta(ji,ijd,jk,jn) = pta(ji,ijd,jk,jn)  + ztra
+                  END DO
+                  !                                               ! down-slope T-point (deep bottom point)
+                  zbtr = r1_e1e2t(ji,ijd) / e3t_n(ji,ijd,ikvd)
+                  ztra = zv_bbl * ( ptb(ji,ijs,ikvs,jn) - ptb(ji,ijd,ikvd,jn) ) * zbtr
+                  pta(ji,ijd,ikvd,jn) = pta(ji,ijd,ikvd,jn) + ztra
+               ENDIF
+            END DO
+            !
+         END DO
+         !                                                  ! ===========
+      END DO                                                ! end tracer
+      !                                                     ! ===========
+   END SUBROUTINE tra_bbl_adv
+
+
+   SUBROUTINE bbl( kt, kit000, cdtype )
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE bbl  ***
+      !!
+      !! ** Purpose :   Computes the bottom boundary horizontal and vertical
+      !!                advection terms.
+      !!
+      !! ** Method  : * diffusive bbl (nn_bbl_ldf=1) :
+      !!        When the product grad( rho) * grad(h) < 0 (where grad is an
+      !!      along bottom slope gradient) an additional lateral 2nd order
+      !!      diffusion along the bottom slope is added to the general
+      !!      tracer trend, otherwise the additional trend is set to 0.
+      !!      A typical value of ahbt is 2000 m2/s (equivalent to
+      !!      a downslope velocity of 20 cm/s if the condition for slope
+      !!      convection is satified)
+      !!              * advective bbl (nn_bbl_adv=1 or 2) :
+      !!      nn_bbl_adv = 1   use of the ocean velocity as bbl velocity
+      !!      nn_bbl_adv = 2   follow Campin and Goosse (1999) implentation
+      !!        i.e. transport proportional to the along-slope density gradient
+      !!
+      !!      NB: the along slope density gradient is evaluated using the
+      !!      local density (i.e. referenced at a common local depth).
+      !!
+      !! References : Beckmann, A., and R. Doscher, 1997, J. Phys.Oceanogr., 581-591.
+      !!              Campin, J.-M., and H. Goosse, 1999, Tellus, 412-430.
+      !!----------------------------------------------------------------------
+      INTEGER         , INTENT(in   ) ::   kt       ! ocean time-step index
+      INTEGER         , INTENT(in   ) ::   kit000   ! first time step index
+      CHARACTER(len=3), INTENT(in   ) ::   cdtype   ! =TRA or TRC (tracer indicator)
+      !
+      INTEGER  ::   ji, jj                    ! dummy loop indices
+      INTEGER  ::   ik                        ! local integers
+      INTEGER  ::   iis, iid, ikus, ikud      !   -       -
+      INTEGER  ::   ijs, ijd, ikvs, ikvd      !   -       -
+      REAL(wp) ::   za, zb, zgdrho            ! local scalars
+      REAL(wp) ::   zsign, zsigna, zgbbl      !   -      -
+      REAL(wp), DIMENSION(jpi,jpj,jpts)   :: zts, zab         ! 3D workspace
+      REAL(wp), DIMENSION(jpi,jpj)        :: zub, zvb, zdep   ! 2D workspace
+      !!----------------------------------------------------------------------
+      !
+      IF( kt == kit000 )  THEN
+         IF(lwp)  WRITE(numout,*)
+         IF(lwp)  WRITE(numout,*) 'trabbl:bbl : Compute bbl velocities and diffusive coefficients in ', cdtype
+         IF(lwp)  WRITE(numout,*) '~~~~~~~~~~'
+      ENDIF
+      !                                        !* bottom variables (T, S, alpha, beta, depth, velocity)
+      DO jj = 1, jpj
+         DO ji = 1, jpi
+            ik = mbkt(ji,jj)                             ! bottom T-level index
+            zts (ji,jj,jp_tem) = tsb(ji,jj,ik,jp_tem)    ! bottom before T and S
+            zts (ji,jj,jp_sal) = tsb(ji,jj,ik,jp_sal)
+            !
+            zdep(ji,jj) = gdept_n(ji,jj,ik)              ! bottom T-level reference depth
+            zub (ji,jj) = un(ji,jj,mbku(ji,jj))          ! bottom velocity
+            zvb (ji,jj) = vn(ji,jj,mbkv(ji,jj))
+         END DO
+      END DO
+      !
+      CALL eos_rab( zts, zdep, zab )
+      !
+      !                                   !-------------------!
+      IF( nn_bbl_ldf == 1 ) THEN          !   diffusive bbl   !
+         !                                !-------------------!
+         DO jj = 1, jpjm1                      ! (criteria for non zero flux: grad(rho).grad(h) < 0 )
+            DO ji = 1, fs_jpim1   ! vector opt.
+               !                                                   ! i-direction
+               za = zab(ji+1,jj,jp_tem) + zab(ji,jj,jp_tem)              ! 2*(alpha,beta) at u-point
+               zb = zab(ji+1,jj,jp_sal) + zab(ji,jj,jp_sal)
+               !                                                         ! 2*masked bottom density gradient
+               zgdrho = (  za * ( zts(ji+1,jj,jp_tem) - zts(ji,jj,jp_tem) )    &
+                  &      - zb * ( zts(ji+1,jj,jp_sal) - zts(ji,jj,jp_sal) )  ) * umask(ji,jj,1)
+               !
+               zsign  = SIGN(  0.5, -zgdrho * REAL( mgrhu(ji,jj) )  )    ! sign of ( i-gradient * i-slope )
+               ahu_bbl(ji,jj) = ( 0.5 - zsign ) * ahu_bbl_0(ji,jj)       ! masked diffusive flux coeff.
+               !
+               !                                                   ! j-direction
+               za = zab(ji,jj+1,jp_tem) + zab(ji,jj,jp_tem)              ! 2*(alpha,beta) at v-point
+               zb = zab(ji,jj+1,jp_sal) + zab(ji,jj,jp_sal)
+               !                                                         ! 2*masked bottom density gradient
+               zgdrho = (  za * ( zts(ji,jj+1,jp_tem) - zts(ji,jj,jp_tem) )    &
+                  &      - zb * ( zts(ji,jj+1,jp_sal) - zts(ji,jj,jp_sal) )  ) * vmask(ji,jj,1)
+               !
+               zsign = SIGN(  0.5, -zgdrho * REAL( mgrhv(ji,jj) )  )     ! sign of ( j-gradient * j-slope )
+               ahv_bbl(ji,jj) = ( 0.5 - zsign ) * ahv_bbl_0(ji,jj)
+            END DO
+         END DO
+         !
+      ENDIF
+      !
+      !                                   !-------------------!
+      IF( nn_bbl_adv /= 0 ) THEN          !   advective bbl   !
+         !                                !-------------------!
+         SELECT CASE ( nn_bbl_adv )             !* bbl transport type
+         !
+         CASE( 1 )                                   != use of upper velocity
+            DO jj = 1, jpjm1                                 ! criteria: grad(rho).grad(h)<0  and grad(rho).grad(h)<0
+               DO ji = 1, fs_jpim1   ! vector opt.
+                  !                                                  ! i-direction
+                  za = zab(ji+1,jj,jp_tem) + zab(ji,jj,jp_tem)               ! 2*(alpha,beta) at u-point
+                  zb = zab(ji+1,jj,jp_sal) + zab(ji,jj,jp_sal)
+                  !                                                          ! 2*masked bottom density gradient 
+                  zgdrho = (  za * ( zts(ji+1,jj,jp_tem) - zts(ji,jj,jp_tem) )    &
+                            - zb * ( zts(ji+1,jj,jp_sal) - zts(ji,jj,jp_sal) )  ) * umask(ji,jj,1)
+                  !
+                  zsign = SIGN(  0.5, - zgdrho   * REAL( mgrhu(ji,jj) )  )   ! sign of i-gradient * i-slope
+                  zsigna= SIGN(  0.5, zub(ji,jj) * REAL( mgrhu(ji,jj) )  )   ! sign of u * i-slope
+                  !
+                  !                                                          ! bbl velocity
+                  utr_bbl(ji,jj) = ( 0.5 + zsigna ) * ( 0.5 - zsign ) * e2u(ji,jj) * e3u_bbl_0(ji,jj) * zub(ji,jj)
+                  !
+                  !                                                  ! j-direction
+                  za = zab(ji,jj+1,jp_tem) + zab(ji,jj,jp_tem)               ! 2*(alpha,beta) at v-point
+                  zb = zab(ji,jj+1,jp_sal) + zab(ji,jj,jp_sal)
+                  !                                                          ! 2*masked bottom density gradient
+                  zgdrho = (  za * ( zts(ji,jj+1,jp_tem) - zts(ji,jj,jp_tem) )    &
+                     &      - zb * ( zts(ji,jj+1,jp_sal) - zts(ji,jj,jp_sal) )  ) * vmask(ji,jj,1)
+                  zsign = SIGN(  0.5, - zgdrho   * REAL( mgrhv(ji,jj) )  )   ! sign of j-gradient * j-slope
+                  zsigna= SIGN(  0.5, zvb(ji,jj) * REAL( mgrhv(ji,jj) )  )   ! sign of u * i-slope
+                  !
+                  !                                                          ! bbl transport
+                  vtr_bbl(ji,jj) = ( 0.5 + zsigna ) * ( 0.5 - zsign ) * e1v(ji,jj) * e3v_bbl_0(ji,jj) * zvb(ji,jj)
+               END DO
+            END DO
+            !
+         CASE( 2 )                                 != bbl velocity = F( delta rho )
+            zgbbl = grav * rn_gambbl
+            DO jj = 1, jpjm1                            ! criteria: rho_up > rho_down
+               DO ji = 1, fs_jpim1   ! vector opt.
+                  !                                                  ! i-direction
+                  ! down-slope T-point i/k-index (deep)  &   up-slope T-point i/k-index (shelf)
+                  iid  = ji + MAX( 0, mgrhu(ji,jj) )
+                  iis  = ji + 1 - MAX( 0, mgrhu(ji,jj) )
+                  !
+                  ikud = mbku_d(ji,jj)
+                  ikus = mbku(ji,jj)
+                  !
+                  za = zab(ji+1,jj,jp_tem) + zab(ji,jj,jp_tem)               ! 2*(alpha,beta) at u-point
+                  zb = zab(ji+1,jj,jp_sal) + zab(ji,jj,jp_sal)
+                  !                                                          !   masked bottom density gradient
+                  zgdrho = 0.5 * (  za * ( zts(iid,jj,jp_tem) - zts(iis,jj,jp_tem) )    &
+                     &            - zb * ( zts(iid,jj,jp_sal) - zts(iis,jj,jp_sal) )  ) * umask(ji,jj,1)
+                  zgdrho = MAX( 0.e0, zgdrho )                               ! only if shelf is denser than deep
+                  !
+                  !                                                          ! bbl transport (down-slope direction)
+                  utr_bbl(ji,jj) = e2u(ji,jj) * e3u_bbl_0(ji,jj) * zgbbl * zgdrho * REAL( mgrhu(ji,jj) )
+                  !
+                  !                                                  ! j-direction
+                  !  down-slope T-point j/k-index (deep)  &   of the up  -slope T-point j/k-index (shelf)
+                  ijd  = jj + MAX( 0, mgrhv(ji,jj) )
+                  ijs  = jj + 1 - MAX( 0, mgrhv(ji,jj) )
+                  !
+                  ikvd = mbkv_d(ji,jj)
+                  ikvs = mbkv(ji,jj)
+                  !
+                  za = zab(ji,jj+1,jp_tem) + zab(ji,jj,jp_tem)               ! 2*(alpha,beta) at v-point
+                  zb = zab(ji,jj+1,jp_sal) + zab(ji,jj,jp_sal)
+                  !                                                          !   masked bottom density gradient
+                  zgdrho = 0.5 * (  za * ( zts(ji,ijd,jp_tem) - zts(ji,ijs,jp_tem) )    &
+                     &            - zb * ( zts(ji,ijd,jp_sal) - zts(ji,ijs,jp_sal) )  ) * vmask(ji,jj,1)
+                  zgdrho = MAX( 0.e0, zgdrho )                               ! only if shelf is denser than deep
+                  !
+                  !                                                          ! bbl transport (down-slope direction)
+                  vtr_bbl(ji,jj) = e1v(ji,jj) * e3v_bbl_0(ji,jj) * zgbbl * zgdrho * REAL( mgrhv(ji,jj) )
+               END DO
+            END DO
+         END SELECT
+         !
+      ENDIF
+      !
+   END SUBROUTINE bbl
+
+
+   SUBROUTINE tra_bbl_init
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE tra_bbl_init  ***
+      !!
+      !! ** Purpose :   Initialization for the bottom boundary layer scheme.
+      !!
+      !! ** Method  :   Read the nambbl namelist and check the parameters
+      !!              called by nemo_init at the first timestep (kit000)
+      !!----------------------------------------------------------------------
+      INTEGER ::   ji, jj                      ! dummy loop indices
+      INTEGER ::   ii0, ii1, ij0, ij1, ios     ! local integer
+      REAL(wp), DIMENSION(jpi,jpj) ::   zmbku, zmbkv   ! workspace
+      !!
+      NAMELIST/nambbl/ ln_trabbl, nn_bbl_ldf, nn_bbl_adv, rn_ahtbbl, rn_gambbl
+      !!----------------------------------------------------------------------
+      !
+      REWIND( numnam_ref )              ! Namelist nambbl in reference namelist : Bottom boundary layer scheme
+      READ  ( numnam_ref, nambbl, IOSTAT = ios, ERR = 901)
+901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'nambbl in reference namelist', lwp )
+      !
+      REWIND( numnam_cfg )              ! Namelist nambbl in configuration namelist : Bottom boundary layer scheme
+      READ  ( numnam_cfg, nambbl, IOSTAT = ios, ERR = 902 )
+902   IF( ios >  0 )   CALL ctl_nam ( ios , 'nambbl in configuration namelist', lwp )
+      IF(lwm) WRITE ( numond, nambbl )
+      !
+      l_bbl = .TRUE.                 !* flag to compute bbl coef and transport
+      !
+      IF(lwp) THEN                   !* Parameter control and print
+         WRITE(numout,*)
+         WRITE(numout,*) 'tra_bbl_init : bottom boundary layer initialisation'
+         WRITE(numout,*) '~~~~~~~~~~~~'
+         WRITE(numout,*) '       Namelist nambbl : set bbl parameters'
+         WRITE(numout,*) '          bottom boundary layer flag          ln_trabbl  = ', ln_trabbl
+      ENDIF
+      IF( .NOT.ln_trabbl )   RETURN
+      !
+      IF(lwp) THEN
+         WRITE(numout,*) '          diffusive bbl (=1)   or not (=0)    nn_bbl_ldf = ', nn_bbl_ldf
+         WRITE(numout,*) '          advective bbl (=1/2) or not (=0)    nn_bbl_adv = ', nn_bbl_adv
+         WRITE(numout,*) '          diffusive bbl coefficient           rn_ahtbbl  = ', rn_ahtbbl, ' m2/s'
+         WRITE(numout,*) '          advective bbl coefficient           rn_gambbl  = ', rn_gambbl, ' s'
+      ENDIF
+      !
+      !                              ! allocate trabbl arrays
+      IF( tra_bbl_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'tra_bbl_init : unable to allocate arrays' )
+      !
+      IF( nn_bbl_adv == 1 )    WRITE(numout,*) '       * Advective BBL using upper velocity'
+      IF( nn_bbl_adv == 2 )    WRITE(numout,*) '       * Advective BBL using velocity = F( delta rho)'
+      !
+      !                             !* vertical index of  "deep" bottom u- and v-points
+      DO jj = 1, jpjm1                    ! (the "shelf" bottom k-indices are mbku and mbkv)
+         DO ji = 1, jpim1
+            mbku_d(ji,jj) = MAX(  mbkt(ji+1,jj  ) , mbkt(ji,jj)  )   ! >= 1 as mbkt=1 over land
+            mbkv_d(ji,jj) = MAX(  mbkt(ji  ,jj+1) , mbkt(ji,jj)  )
+         END DO
+      END DO
+      ! converte into REAL to use lbc_lnk ; impose a min value of 1 as a zero can be set in lbclnk
+      zmbku(:,:) = REAL( mbku_d(:,:), wp )   ;     zmbkv(:,:) = REAL( mbkv_d(:,:), wp )  
+      CALL lbc_lnk_multi( zmbku,'U',1., zmbkv,'V',1.) 
+      mbku_d(:,:) = MAX( INT( zmbku(:,:) ), 1 ) ;  mbkv_d(:,:) = MAX( INT( zmbkv(:,:) ), 1 )
+      !
+      !                             !* sign of grad(H) at u- and v-points; zero if grad(H) = 0
+      mgrhu(:,:) = 0   ;   mgrhv(:,:) = 0
+      DO jj = 1, jpjm1
+         DO ji = 1, jpim1
+            IF( gdept_0(ji+1,jj,mbkt(ji+1,jj)) - gdept_0(ji,jj,mbkt(ji,jj)) /= 0._wp ) THEN
+               mgrhu(ji,jj) = INT(  SIGN( 1.e0, gdept_0(ji+1,jj,mbkt(ji+1,jj)) - gdept_0(ji,jj,mbkt(ji,jj)) )  )
+            ENDIF
+            !
+            IF( gdept_0(ji,jj+1,mbkt(ji,jj+1)) - gdept_0(ji,jj,mbkt(ji,jj)) /= 0._wp ) THEN
+               mgrhv(ji,jj) = INT(  SIGN( 1.e0, gdept_0(ji,jj+1,mbkt(ji,jj+1)) - gdept_0(ji,jj,mbkt(ji,jj)) )  )
+            ENDIF
+         END DO
+      END DO
+      !
+      DO jj = 1, jpjm1              !* bbl thickness at u- (v-) point
+         DO ji = 1, jpim1                 ! minimum of top & bottom e3u_0 (e3v_0)
+            e3u_bbl_0(ji,jj) = MIN( e3u_0(ji,jj,mbkt(ji+1,jj  )), e3u_0(ji,jj,mbkt(ji,jj)) )
+            e3v_bbl_0(ji,jj) = MIN( e3v_0(ji,jj,mbkt(ji  ,jj+1)), e3v_0(ji,jj,mbkt(ji,jj)) )
+         END DO
+      END DO
+      CALL lbc_lnk_multi( e3u_bbl_0, 'U', 1. , e3v_bbl_0, 'V', 1. )      ! lateral boundary conditions
+      !
+      !                             !* masked diffusive flux coefficients
+      ahu_bbl_0(:,:) = rn_ahtbbl * e2_e1u(:,:) * e3u_bbl_0(:,:) * umask(:,:,1)
+      ahv_bbl_0(:,:) = rn_ahtbbl * e1_e2v(:,:) * e3v_bbl_0(:,:) * vmask(:,:,1)
+      !
+   END SUBROUTINE tra_bbl_init
+
+   !!======================================================================
+END MODULE trabbl
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/TRA/tradmp.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/TRA/tradmp.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/TRA/tradmp.F90	(revision 9570)
@@ -0,0 +1,228 @@
+MODULE tradmp
+   !!======================================================================
+   !!                       ***  MODULE  tradmp  ***
+   !! Ocean physics: internal restoring trend on active tracers (T and S)
+   !!======================================================================
+   !! History :  OPA  ! 1991-03  (O. Marti, G. Madec)  Original code
+   !!                 ! 1992-06  (M. Imbard)  doctor norme
+   !!                 ! 1998-07  (M. Imbard, G. Madec) ORCA version
+   !!            7.0  ! 2001-02  (M. Imbard)  add distance to coast, Original code
+   !!            8.1  ! 2001-02  (G. Madec, E. Durand)  cleaning
+   !!  NEMO      1.0  ! 2002-08  (G. Madec, E. Durand)  free form + modules
+   !!            3.2  ! 2009-08  (G. Madec, C. Talandier)  DOCTOR norm for namelist parameter
+   !!            3.3  ! 2010-06  (C. Ethe, G. Madec) merge TRA-TRC 
+   !!            3.4  ! 2011-04  (G. Madec, C. Ethe) Merge of dtatem and dtasal + suppression of CPP keys
+   !!            3.6  ! 2015-06  (T. Graham)  read restoring coefficient in a file
+   !!            3.7  ! 2015-10  (G. Madec)  remove useless trends arrays
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   tra_dmp_alloc : allocate tradmp arrays
+   !!   tra_dmp       : update the tracer trend with the internal damping
+   !!   tra_dmp_init  : initialization, namlist read, parameters control
+   !!----------------------------------------------------------------------
+   USE oce            ! ocean: variables
+   USE dom_oce        ! ocean: domain variables
+   USE c1d            ! 1D vertical configuration
+   USE trd_oce        ! trends: ocean variables
+   USE trdtra         ! trends manager: tracers 
+   USE zdf_oce        ! ocean: vertical physics
+   USE phycst         ! physical constants
+   USE dtatsd         ! data: temperature & salinity
+   USE zdfmxl         ! vertical physics: mixed layer depth
+   !
+   USE in_out_manager ! I/O manager
+   USE iom            ! XIOS
+   USE lib_mpp        ! MPP library
+   USE prtctl         ! Print control
+   USE timing         ! Timing
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   tra_dmp        ! called by step.F90
+   PUBLIC   tra_dmp_init   ! called by nemogcm.F90
+
+   !                                           !!* Namelist namtra_dmp : T & S newtonian damping *
+   LOGICAL            , PUBLIC ::   ln_tradmp   !: internal damping flag
+   INTEGER            , PUBLIC ::   nn_zdmp     !: = 0/1/2 flag for damping in the mixed layer
+   CHARACTER(LEN=200) , PUBLIC ::   cn_resto    !: name of netcdf file containing restoration coefficient field
+   !
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   resto    !: restoring coeff. on T and S (s-1)
+
+   !! * Substitutions
+#  include "vectopt_loop_substitute.h90"
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO Consortium (2010)
+   !! $Id$ 
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   INTEGER FUNCTION tra_dmp_alloc()
+      !!----------------------------------------------------------------------
+      !!                ***  FUNCTION tra_dmp_alloc  ***
+      !!----------------------------------------------------------------------
+      ALLOCATE( resto(jpi,jpj,jpk), STAT= tra_dmp_alloc )
+      !
+      IF( lk_mpp            )   CALL mpp_sum ( tra_dmp_alloc )
+      IF( tra_dmp_alloc > 0 )   CALL ctl_warn('tra_dmp_alloc: allocation of arrays failed')
+      !
+   END FUNCTION tra_dmp_alloc
+
+
+   SUBROUTINE tra_dmp( kt )
+      !!----------------------------------------------------------------------
+      !!                   ***  ROUTINE tra_dmp  ***
+      !!                  
+      !! ** Purpose :   Compute the tracer trend due to a newtonian damping
+      !!      of the tracer field towards given data field and add it to the
+      !!      general tracer trends.
+      !!
+      !! ** Method  :   Newtonian damping towards t_dta and s_dta computed 
+      !!      and add to the general tracer trends:
+      !!                     ta = ta + resto * (t_dta - tb)
+      !!                     sa = sa + resto * (s_dta - sb)
+      !!         The trend is computed either throughout the water column
+      !!      (nlmdmp=0) or in area of weak vertical mixing (nlmdmp=1) or
+      !!      below the well mixed layer (nlmdmp=2)
+      !!
+      !! ** Action  : - tsa: tracer trends updated with the damping trend
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT(in) ::   kt   ! ocean time-step index
+      !
+      INTEGER ::   ji, jj, jk, jn   ! dummy loop indices
+      REAL(wp), DIMENSION(jpi,jpj,jpk,jpts)     ::  zts_dta
+      REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE ::  ztrdts
+      !!----------------------------------------------------------------------
+      !
+      IF( ln_timing )   CALL timing_start('tra_dmp')
+      !
+      IF( l_trdtra )   THEN                    !* Save ta and sa trends
+         ALLOCATE( ztrdts(jpi,jpj,jpk,jpts) ) 
+         ztrdts(:,:,:,:) = tsa(:,:,:,:) 
+      ENDIF
+      !                           !==  input T-S data at kt  ==!
+      CALL dta_tsd( kt, zts_dta )            ! read and interpolates T-S data at kt
+      !
+      SELECT CASE ( nn_zdmp )     !==  type of damping  ==!
+      !
+      CASE( 0 )                        !*  newtonian damping throughout the water column  *!
+         DO jn = 1, jpts
+            DO jk = 1, jpkm1
+               DO jj = 2, jpjm1
+                  DO ji = fs_2, fs_jpim1   ! vector opt.
+                     tsa(ji,jj,jk,jn) = tsa(ji,jj,jk,jn) + resto(ji,jj,jk) * ( zts_dta(ji,jj,jk,jn) - tsb(ji,jj,jk,jn) )
+                  END DO
+               END DO
+            END DO
+         END DO
+         !
+      CASE ( 1 )                       !*  no damping in the turbocline (avt > 5 cm2/s)  *!
+         DO jk = 1, jpkm1
+            DO jj = 2, jpjm1
+               DO ji = fs_2, fs_jpim1   ! vector opt.
+                  IF( avt(ji,jj,jk) <= 5.e-4_wp ) THEN
+                     tsa(ji,jj,jk,jp_tem) = tsa(ji,jj,jk,jp_tem)   &
+                        &                 + resto(ji,jj,jk) * ( zts_dta(ji,jj,jk,jp_tem) - tsb(ji,jj,jk,jp_tem) )
+                     tsa(ji,jj,jk,jp_sal) = tsa(ji,jj,jk,jp_sal)   &
+                        &                 + resto(ji,jj,jk) * ( zts_dta(ji,jj,jk,jp_sal) - tsb(ji,jj,jk,jp_sal) )
+                  ENDIF
+               END DO
+            END DO
+         END DO
+         !
+      CASE ( 2 )                       !*  no damping in the mixed layer   *!
+         DO jk = 1, jpkm1
+            DO jj = 2, jpjm1
+               DO ji = fs_2, fs_jpim1   ! vector opt.
+                  IF( gdept_n(ji,jj,jk) >= hmlp (ji,jj) ) THEN
+                     tsa(ji,jj,jk,jp_tem) = tsa(ji,jj,jk,jp_tem)   &
+                        &                 + resto(ji,jj,jk) * ( zts_dta(ji,jj,jk,jp_tem) - tsb(ji,jj,jk,jp_tem) )
+                     tsa(ji,jj,jk,jp_sal) = tsa(ji,jj,jk,jp_sal)   &
+                        &                 + resto(ji,jj,jk) * ( zts_dta(ji,jj,jk,jp_sal) - tsb(ji,jj,jk,jp_sal) )
+                  ENDIF
+               END DO
+            END DO
+         END DO
+         !
+      END SELECT
+      !
+      IF( l_trdtra )   THEN       ! trend diagnostic
+         ztrdts(:,:,:,:) = tsa(:,:,:,:) - ztrdts(:,:,:,:)
+         CALL trd_tra( kt, 'TRA', jp_tem, jptra_dmp, ztrdts(:,:,:,jp_tem) )
+         CALL trd_tra( kt, 'TRA', jp_sal, jptra_dmp, ztrdts(:,:,:,jp_sal) )
+         DEALLOCATE( ztrdts ) 
+      ENDIF
+      !                           ! Control print
+      IF(ln_ctl)   CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' dmp  - Ta: ', mask1=tmask,   &
+         &                       tab3d_2=tsa(:,:,:,jp_sal), clinfo2=       ' Sa: ', mask2=tmask, clinfo3='tra' )
+      !
+      IF( ln_timing )   CALL timing_stop('tra_dmp')
+      !
+   END SUBROUTINE tra_dmp
+
+
+   SUBROUTINE tra_dmp_init
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE tra_dmp_init  ***
+      !! 
+      !! ** Purpose :   Initialization for the newtonian damping 
+      !!
+      !! ** Method  :   read the namtra_dmp namelist and check the parameters
+      !!----------------------------------------------------------------------
+      INTEGER ::   ios, imask   ! local integers 
+      !
+      NAMELIST/namtra_dmp/ ln_tradmp, nn_zdmp, cn_resto
+      !!----------------------------------------------------------------------
+      !
+      REWIND( numnam_ref )   ! Namelist namtra_dmp in reference namelist : T & S relaxation
+      READ  ( numnam_ref, namtra_dmp, IOSTAT = ios, ERR = 901)
+901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namtra_dmp in reference namelist', lwp )
+      !
+      REWIND( numnam_cfg )   ! Namelist namtra_dmp in configuration namelist : T & S relaxation
+      READ  ( numnam_cfg, namtra_dmp, IOSTAT = ios, ERR = 902 )
+902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namtra_dmp in configuration namelist', lwp )
+      IF(lwm) WRITE ( numond, namtra_dmp )
+      !
+      IF(lwp) THEN                  ! Namelist print
+         WRITE(numout,*)
+         WRITE(numout,*) 'tra_dmp_init : T and S newtonian relaxation'
+         WRITE(numout,*) '~~~~~~~~~~~~'
+         WRITE(numout,*) '   Namelist namtra_dmp : set relaxation parameters'
+         WRITE(numout,*) '      Apply relaxation   or not       ln_tradmp   = ', ln_tradmp
+         WRITE(numout,*) '         mixed layer damping option      nn_zdmp  = ', nn_zdmp
+         WRITE(numout,*) '         Damping file name               cn_resto = ', cn_resto
+         WRITE(numout,*)
+      ENDIF
+      !
+      IF( ln_tradmp ) THEN
+         !                          ! Allocate arrays
+         IF( tra_dmp_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'tra_dmp_init: unable to allocate arrays' )
+         !
+         SELECT CASE (nn_zdmp)      ! Check values of nn_zdmp
+         CASE ( 0 )   ;   IF(lwp) WRITE(numout,*) '   tracer damping as specified by mask'
+         CASE ( 1 )   ;   IF(lwp) WRITE(numout,*) '   no tracer damping in the mixing layer (kz > 5 cm2/s)'
+         CASE ( 2 )   ;   IF(lwp) WRITE(numout,*) '   no tracer damping in the mixed  layer'
+         CASE DEFAULT
+            CALL ctl_stop('tra_dmp_init : wrong value of nn_zdmp')
+         END SELECT
+         !
+         !!TG: Initialisation of dtatsd - Would it be better to have dmpdta routine
+         !    so can damp to something other than intitial conditions files?
+         !!gm: In principle yes. Nevertheless, we can't anticipate demands that have never been formulated.
+         IF( .NOT.ln_tsd_dmp ) THEN
+            IF(lwp) WRITE(numout,*)
+            IF(lwp) WRITE(numout, *)  '   read T-S data not initialized, we force ln_tsd_dmp=T'
+            CALL dta_tsd_init( ld_tradmp=ln_tradmp )        ! forces the initialisation of T-S data
+         ENDIF
+         !                          ! Read in mask from file
+         CALL iom_open ( cn_resto, imask)
+         CALL iom_get  ( imask, jpdom_autoglo, 'resto', resto )
+         CALL iom_close( imask )
+      ENDIF
+      !
+   END SUBROUTINE tra_dmp_init
+
+   !!======================================================================
+END MODULE tradmp
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/TRA/traldf.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/TRA/traldf.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/TRA/traldf.F90	(revision 9570)
@@ -0,0 +1,128 @@
+MODULE traldf
+   !!======================================================================
+   !!                       ***  MODULE  traldf  ***
+   !! Ocean Active tracers : lateral diffusive trends 
+   !!=====================================================================
+   !! History :  9.0  ! 2005-11  (G. Madec)  Original code
+   !!  NEMO      3.0  ! 2008-01  (C. Ethe, G. Madec)  merge TRC-TRA 
+   !!            3.7  ! 2013-12  (G. Madec) remove the optional computation from T & S anomaly profiles and traldf_bilapg
+   !!             -   ! 2013-12  (F. Lemarie, G. Madec)  triad operator (Griffies) + Method of Stabilizing Correction
+   !!             -   ! 2014-01  (G. Madec, S. Masson)  restructuration/simplification of lateral diffusive operators
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   tra_ldf       : update the tracer trend with the lateral diffusion trend
+   !!   tra_ldf_init  : initialization, namelist read, and parameters control
+   !!----------------------------------------------------------------------
+   USE oce            ! ocean dynamics and tracers
+   USE dom_oce        ! ocean space and time domain
+   USE phycst         ! physical constants
+   USE ldftra         ! lateral diffusion: eddy diffusivity & EIV coeff.
+   USE ldfslp         ! lateral diffusion: iso-neutral slope
+   USE traldf_lap_blp ! lateral diffusion: laplacian iso-level            operator  (tra_ldf_lap/_blp   routines)
+   USE traldf_iso     ! lateral diffusion: laplacian iso-neutral standard operator  (tra_ldf_iso        routine )
+   USE traldf_triad   ! lateral diffusion: laplacian iso-neutral triad    operator  (tra_ldf_triad      routine )
+   USE trd_oce        ! trends: ocean variables
+   USE trdtra         ! ocean active tracers trends
+   !
+   USE prtctl         ! Print control
+   USE in_out_manager ! I/O manager
+   USE lib_mpp        ! distribued memory computing library
+   USE lbclnk         ! ocean lateral boundary conditions (or mpp link)
+   USE timing         ! Timing
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   tra_ldf        ! called by step.F90 
+   PUBLIC   tra_ldf_init   ! called by nemogcm.F90 
+   
+   !! * Substitutions
+#  include "vectopt_loop_substitute.h90"
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 4.0 , NEMO Consortium (2018)
+   !! $Id$ 
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE tra_ldf( kt )
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE tra_ldf  ***
+      !! 
+      !! ** Purpose :   compute the lateral ocean tracer physics.
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT( in ) ::   kt   ! ocean time-step index
+      !!
+      REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) ::   ztrdt, ztrds
+      !!----------------------------------------------------------------------
+      !
+      IF( ln_timing )   CALL timing_start('tra_ldf')
+      !
+      IF( l_trdtra )   THEN                    !* Save ta and sa trends
+         ALLOCATE( ztrdt(jpi,jpj,jpk) , ztrds(jpi,jpj,jpk) ) 
+         ztrdt(:,:,:) = tsa(:,:,:,jp_tem) 
+         ztrds(:,:,:) = tsa(:,:,:,jp_sal)
+      ENDIF
+      !
+      SELECT CASE ( nldf_tra )                 !* compute lateral mixing trend and add it to the general trend
+      CASE ( np_lap   )                                  ! laplacian: iso-level operator
+         CALL tra_ldf_lap  ( kt, nit000,'TRA', ahtu, ahtv, gtsu, gtsv, gtui, gtvi, tsb,      tsa, jpts,  1   )
+      CASE ( np_lap_i )                                  ! laplacian: standard iso-neutral operator (Madec)
+         CALL tra_ldf_iso  ( kt, nit000,'TRA', ahtu, ahtv, gtsu, gtsv, gtui, gtvi, tsb, tsb, tsa, jpts,  1   )
+      CASE ( np_lap_it )                                 ! laplacian: triad iso-neutral operator (griffies)
+         CALL tra_ldf_triad( kt, nit000,'TRA', ahtu, ahtv, gtsu, gtsv, gtui, gtvi, tsb, tsb, tsa, jpts,  1   )
+      CASE ( np_blp , np_blp_i , np_blp_it )             ! bilaplacian: iso-level & iso-neutral operators
+         CALL tra_ldf_blp  ( kt, nit000,'TRA', ahtu, ahtv, gtsu, gtsv, gtui, gtvi, tsb      , tsa, jpts, nldf_tra )
+      END SELECT
+      !
+      IF( l_trdtra )   THEN                    !* save the horizontal diffusive trends for further diagnostics
+         ztrdt(:,:,:) = tsa(:,:,:,jp_tem) - ztrdt(:,:,:)
+         ztrds(:,:,:) = tsa(:,:,:,jp_sal) - ztrds(:,:,:)
+         CALL trd_tra( kt, 'TRA', jp_tem, jptra_ldf, ztrdt )
+         CALL trd_tra( kt, 'TRA', jp_sal, jptra_ldf, ztrds )
+         DEALLOCATE( ztrdt, ztrds ) 
+      ENDIF
+      !                                        !* print mean trends (used for debugging)
+      IF(ln_ctl)   CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' ldf  - Ta: ', mask1=tmask,               &
+         &                       tab3d_2=tsa(:,:,:,jp_sal), clinfo2=       ' Sa: ', mask2=tmask, clinfo3='tra' )
+      !
+      IF( ln_timing )   CALL timing_stop('tra_ldf')
+      !
+   END SUBROUTINE tra_ldf
+
+
+   SUBROUTINE tra_ldf_init
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE tra_ldf_init  ***
+      !! 
+      !! ** Purpose :   Choice of the operator for the lateral tracer diffusion
+      !!
+      !! ** Method  :   set nldf_tra from the namtra_ldf logicals
+      !!----------------------------------------------------------------------
+      INTEGER ::   ioptio, ierr   ! temporary integers 
+      !!----------------------------------------------------------------------
+      !
+      IF(lwp) THEN                     !==  Namelist print  ==!
+         WRITE(numout,*)
+         WRITE(numout,*) 'tra_ldf_init : lateral tracer diffusive operator'
+         WRITE(numout,*) '~~~~~~~~~~~~'
+         WRITE(numout,*) '   Namelist namtra_ldf: already read in ldftra module'
+         WRITE(numout,*) '      see ldf_tra_init report for lateral mixing parameters'
+         WRITE(numout,*)
+         !
+         SELECT CASE( nldf_tra )             ! print the choice of operator
+         CASE( np_no_ldf )   ;   WRITE(numout,*) '   ==>>>   NO lateral diffusion'
+         CASE( np_lap    )   ;   WRITE(numout,*) '   ==>>>   laplacian iso-level operator'
+         CASE( np_lap_i  )   ;   WRITE(numout,*) '   ==>>>   Rotated laplacian operator (standard)'
+         CASE( np_lap_it )   ;   WRITE(numout,*) '   ==>>>   Rotated laplacian operator (triad)'
+         CASE( np_blp    )   ;   WRITE(numout,*) '   ==>>>   bilaplacian iso-level operator'
+         CASE( np_blp_i  )   ;   WRITE(numout,*) '   ==>>>   Rotated bilaplacian operator (standard)'
+         CASE( np_blp_it )   ;   WRITE(numout,*) '   ==>>>   Rotated bilaplacian operator (triad)'
+         END SELECT
+      ENDIF
+      !
+   END SUBROUTINE tra_ldf_init
+
+   !!======================================================================
+END MODULE traldf
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/TRA/traldf_iso.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/TRA/traldf_iso.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/TRA/traldf_iso.F90	(revision 9570)
@@ -0,0 +1,385 @@
+MODULE traldf_iso
+   !!======================================================================
+   !!                   ***  MODULE  traldf_iso  ***
+   !! Ocean  tracers:  horizontal component of the lateral tracer mixing trend
+   !!======================================================================
+   !! History :  OPA  ! 1994-08  (G. Madec, M. Imbard)
+   !!            8.0  ! 1997-05  (G. Madec)  split into traldf and trazdf
+   !!            NEMO ! 2002-08  (G. Madec)  Free form, F90
+   !!            1.0  ! 2005-11  (G. Madec)  merge traldf and trazdf :-)
+   !!            3.3  ! 2010-09  (C. Ethe, G. Madec) Merge TRA-TRC
+   !!            3.7  ! 2014-01  (G. Madec, S. Masson)  restructuration/simplification of aht/aeiv specification
+   !!             -   ! 2014-02  (F. Lemarie, G. Madec)  triad operator (Griffies) + Method of Stabilizing Correction
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   tra_ldf_iso   : update the tracer trend with the horizontal component of a iso-neutral laplacian operator
+   !!                   and with the vertical part of the isopycnal or geopotential s-coord. operator 
+   !!----------------------------------------------------------------------
+   USE oce            ! ocean dynamics and active tracers
+   USE dom_oce        ! ocean space and time domain
+   USE trc_oce        ! share passive tracers/Ocean variables
+   USE zdf_oce        ! ocean vertical physics
+   USE ldftra         ! lateral diffusion: tracer eddy coefficients
+   USE ldfslp         ! iso-neutral slopes
+   USE diaptr         ! poleward transport diagnostics
+   USE diaar5         ! AR5 diagnostics
+   !
+   USE in_out_manager ! I/O manager
+   USE iom            ! I/O library
+   USE phycst         ! physical constants
+   USE lbclnk         ! ocean lateral boundary conditions (or mpp link)
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   tra_ldf_iso   ! routine called by step.F90
+
+   LOGICAL  ::   l_ptr   ! flag to compute poleward transport
+   LOGICAL  ::   l_hst   ! flag to compute heat transport
+
+   !! * Substitutions
+#  include "vectopt_loop_substitute.h90"
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.7 , NEMO Consortium (2015)
+   !! $Id$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+  SUBROUTINE tra_ldf_iso( kt, kit000, cdtype, pahu, pahv, pgu , pgv ,   &
+      &                                                   pgui, pgvi,   &
+      &                                       ptb , ptbb, pta , kjpt, kpass )
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE tra_ldf_iso  ***
+      !!
+      !! ** Purpose :   Compute the before horizontal tracer (t & s) diffusive 
+      !!      trend for a laplacian tensor (ezxcept the dz[ dz[.] ] term) and 
+      !!      add it to the general trend of tracer equation.
+      !!
+      !! ** Method  :   The horizontal component of the lateral diffusive trends 
+      !!      is provided by a 2nd order operator rotated along neural or geopo-
+      !!      tential surfaces to which an eddy induced advection can be added
+      !!      It is computed using before fields (forward in time) and isopyc-
+      !!      nal or geopotential slopes computed in routine ldfslp.
+      !!
+      !!      1st part :  masked horizontal derivative of T  ( di[ t ] )
+      !!      ========    with partial cell update if ln_zps=T
+      !!                  with top     cell update if ln_isfcav
+      !!
+      !!      2nd part :  horizontal fluxes of the lateral mixing operator
+      !!      ========    
+      !!         zftu =  pahu e2u*e3u/e1u di[ tb ]
+      !!               - pahu e2u*uslp    dk[ mi(mk(tb)) ]
+      !!         zftv =  pahv e1v*e3v/e2v dj[ tb ]
+      !!               - pahv e2u*vslp    dk[ mj(mk(tb)) ]
+      !!      take the horizontal divergence of the fluxes:
+      !!         difft = 1/(e1e2t*e3t) {  di-1[ zftu ] +  dj-1[ zftv ]  }
+      !!      Add this trend to the general trend (ta,sa):
+      !!         ta = ta + difft
+      !!
+      !!      3rd part: vertical trends of the lateral mixing operator
+      !!      ========  (excluding the vertical flux proportional to dk[t] )
+      !!      vertical fluxes associated with the rotated lateral mixing:
+      !!         zftw = - {  mi(mk(pahu)) * e2t*wslpi di[ mi(mk(tb)) ]
+      !!                   + mj(mk(pahv)) * e1t*wslpj dj[ mj(mk(tb)) ]  }
+      !!      take the horizontal divergence of the fluxes:
+      !!         difft = 1/(e1e2t*e3t) dk[ zftw ]
+      !!      Add this trend to the general trend (ta,sa):
+      !!         pta = pta + difft
+      !!
+      !! ** Action :   Update pta arrays with the before rotated diffusion
+      !!----------------------------------------------------------------------
+      INTEGER                              , INTENT(in   ) ::   kt         ! ocean time-step index
+      INTEGER                              , INTENT(in   ) ::   kit000     ! first time step index
+      CHARACTER(len=3)                     , INTENT(in   ) ::   cdtype     ! =TRA or TRC (tracer indicator)
+      INTEGER                              , INTENT(in   ) ::   kjpt       ! number of tracers
+      INTEGER                              , INTENT(in   ) ::   kpass      ! =1/2 first or second passage
+      REAL(wp), DIMENSION(jpi,jpj,jpk)     , INTENT(in   ) ::   pahu, pahv ! eddy diffusivity at u- and v-points  [m2/s]
+      REAL(wp), DIMENSION(jpi,jpj    ,kjpt), INTENT(in   ) ::   pgu, pgv   ! tracer gradient at pstep levels
+      REAL(wp), DIMENSION(jpi,jpj,    kjpt), INTENT(in   ) ::   pgui, pgvi ! tracer gradient at top   levels
+      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   ) ::   ptb        ! tracer (kpass=1) or laplacian of tracer (kpass=2)
+      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   ) ::   ptbb       ! tracer (only used in kpass=2)
+      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) ::   pta        ! tracer trend
+      !
+      INTEGER  ::  ji, jj, jk, jn   ! dummy loop indices
+      INTEGER  ::  ikt
+      INTEGER  ::  ierr             ! local integer
+      REAL(wp) ::  zmsku, zahu_w, zabe1, zcof1, zcoef3   ! local scalars
+      REAL(wp) ::  zmskv, zahv_w, zabe2, zcof2, zcoef4   !   -      -
+      REAL(wp) ::  zcoef0, ze3w_2, zsign, z2dt, z1_2dt   !   -      -
+      REAL(wp), DIMENSION(jpi,jpj)     ::   zdkt, zdk1t, z2d
+      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zdit, zdjt, zftu, zftv, ztfw 
+      !!----------------------------------------------------------------------
+      !
+      IF( kt == kit000 )  THEN
+         IF(lwp) WRITE(numout,*)
+         IF(lwp) WRITE(numout,*) 'tra_ldf_iso : rotated laplacian diffusion operator on ', cdtype
+         IF(lwp) WRITE(numout,*) '~~~~~~~~~~~'
+         !
+         akz     (:,:,:) = 0._wp      
+         ah_wslp2(:,:,:) = 0._wp
+      ENDIF
+      !   
+      l_hst = .FALSE.
+      l_ptr = .FALSE.
+      IF( cdtype == 'TRA' .AND. ln_diaptr )                                                 l_ptr = .TRUE. 
+      IF( cdtype == 'TRA' .AND. ( iom_use("uadv_heattr") .OR. iom_use("vadv_heattr") .OR. &
+         &                        iom_use("uadv_salttr") .OR. iom_use("vadv_salttr")  ) )   l_hst = .TRUE.
+      !
+      !                                            ! set time step size (Euler/Leapfrog)
+      IF( neuler == 0 .AND. kt == nit000 ) THEN   ;   z2dt =     rdt      ! at nit000   (Euler)
+      ELSE                                        ;   z2dt = 2.* rdt      !             (Leapfrog)
+      ENDIF
+      z1_2dt = 1._wp / z2dt
+      !
+      IF( kpass == 1 ) THEN   ;   zsign =  1._wp      ! bilaplacian operator require a minus sign (eddy diffusivity >0)
+      ELSE                    ;   zsign = -1._wp
+      ENDIF
+         
+      !!----------------------------------------------------------------------
+      !!   0 - calculate  ah_wslp2 and akz
+      !!----------------------------------------------------------------------
+      !
+      IF( kpass == 1 ) THEN                  !==  first pass only  ==!
+         !
+         DO jk = 2, jpkm1
+            DO jj = 2, jpjm1
+               DO ji = fs_2, fs_jpim1   ! vector opt.
+                  !
+                  zmsku = wmask(ji,jj,jk) / MAX(   umask(ji  ,jj,jk-1) + umask(ji-1,jj,jk)          &
+                     &                           + umask(ji-1,jj,jk-1) + umask(ji  ,jj,jk) , 1._wp  )
+                  zmskv = wmask(ji,jj,jk) / MAX(   vmask(ji,jj  ,jk-1) + vmask(ji,jj-1,jk)          &
+                     &                           + vmask(ji,jj-1,jk-1) + vmask(ji,jj  ,jk) , 1._wp  )
+                     !
+                  zahu_w = (   pahu(ji  ,jj,jk-1) + pahu(ji-1,jj,jk)    &
+                     &       + pahu(ji-1,jj,jk-1) + pahu(ji  ,jj,jk)  ) * zmsku
+                  zahv_w = (   pahv(ji,jj  ,jk-1) + pahv(ji,jj-1,jk)    &
+                     &       + pahv(ji,jj-1,jk-1) + pahv(ji,jj  ,jk)  ) * zmskv
+                     !
+                  ah_wslp2(ji,jj,jk) = zahu_w * wslpi(ji,jj,jk) * wslpi(ji,jj,jk)   &
+                     &               + zahv_w * wslpj(ji,jj,jk) * wslpj(ji,jj,jk)
+               END DO
+            END DO
+         END DO
+         !
+         IF( ln_traldf_msc ) THEN                ! stabilizing vertical diffusivity coefficient
+            DO jk = 2, jpkm1
+               DO jj = 2, jpjm1
+                  DO ji = fs_2, fs_jpim1
+                     akz(ji,jj,jk) = 0.25_wp * (                                                                     &
+                        &              ( pahu(ji  ,jj,jk) + pahu(ji  ,jj,jk-1) ) / ( e1u(ji  ,jj) * e1u(ji  ,jj) )   &
+                        &            + ( pahu(ji-1,jj,jk) + pahu(ji-1,jj,jk-1) ) / ( e1u(ji-1,jj) * e1u(ji-1,jj) )   &
+                        &            + ( pahv(ji,jj  ,jk) + pahv(ji,jj  ,jk-1) ) / ( e2v(ji,jj  ) * e2v(ji,jj  ) )   &
+                        &            + ( pahv(ji,jj-1,jk) + pahv(ji,jj-1,jk-1) ) / ( e2v(ji,jj-1) * e2v(ji,jj-1) )   )
+                  END DO
+               END DO
+            END DO
+            !
+            IF( ln_traldf_blp ) THEN                ! bilaplacian operator
+               DO jk = 2, jpkm1
+                  DO jj = 1, jpjm1
+                     DO ji = 1, fs_jpim1
+                        akz(ji,jj,jk) = 16._wp * ah_wslp2(ji,jj,jk)   &
+                           &          * (  akz(ji,jj,jk) + ah_wslp2(ji,jj,jk) / ( e3w_n(ji,jj,jk) * e3w_n(ji,jj,jk) )  )
+                     END DO
+                  END DO
+               END DO
+            ELSEIF( ln_traldf_lap ) THEN              ! laplacian operator
+               DO jk = 2, jpkm1
+                  DO jj = 1, jpjm1
+                     DO ji = 1, fs_jpim1
+                        ze3w_2 = e3w_n(ji,jj,jk) * e3w_n(ji,jj,jk)
+                        zcoef0 = z2dt * (  akz(ji,jj,jk) + ah_wslp2(ji,jj,jk) / ze3w_2  )
+                        akz(ji,jj,jk) = MAX( zcoef0 - 0.5_wp , 0._wp ) * ze3w_2 * z1_2dt
+                     END DO
+                  END DO
+               END DO
+           ENDIF
+           !
+         ELSE                                    ! 33 flux set to zero with akz=ah_wslp2 ==>> computed in full implicit
+            akz(:,:,:) = ah_wslp2(:,:,:)      
+         ENDIF
+      ENDIF
+      !
+      !                                                          ! ===========
+      DO jn = 1, kjpt                                            ! tracer loop
+         !                                                       ! ===========
+         !                                               
+         !!----------------------------------------------------------------------
+         !!   I - masked horizontal derivative 
+         !!----------------------------------------------------------------------
+!!gm : bug.... why (x,:,:)?   (1,jpj,:) and (jpi,1,:) should be sufficient....
+         zdit (1,:,:) = 0._wp     ;     zdit (jpi,:,:) = 0._wp
+         zdjt (1,:,:) = 0._wp     ;     zdjt (jpi,:,:) = 0._wp
+         !!end
+
+         ! Horizontal tracer gradient 
+         DO jk = 1, jpkm1
+            DO jj = 1, jpjm1
+               DO ji = 1, fs_jpim1   ! vector opt.
+                  zdit(ji,jj,jk) = ( ptb(ji+1,jj  ,jk,jn) - ptb(ji,jj,jk,jn) ) * umask(ji,jj,jk)
+                  zdjt(ji,jj,jk) = ( ptb(ji  ,jj+1,jk,jn) - ptb(ji,jj,jk,jn) ) * vmask(ji,jj,jk)
+               END DO
+            END DO
+         END DO
+         IF( ln_zps ) THEN      ! botton and surface ocean correction of the horizontal gradient
+            DO jj = 1, jpjm1              ! bottom correction (partial bottom cell)
+               DO ji = 1, fs_jpim1   ! vector opt.
+                  zdit(ji,jj,mbku(ji,jj)) = pgu(ji,jj,jn)          
+                  zdjt(ji,jj,mbkv(ji,jj)) = pgv(ji,jj,jn)
+               END DO
+            END DO
+            IF( ln_isfcav ) THEN      ! first wet level beneath a cavity
+               DO jj = 1, jpjm1
+                  DO ji = 1, fs_jpim1   ! vector opt.
+                     IF( miku(ji,jj) > 1 )   zdit(ji,jj,miku(ji,jj)) = pgui(ji,jj,jn)          
+                     IF( mikv(ji,jj) > 1 )   zdjt(ji,jj,mikv(ji,jj)) = pgvi(ji,jj,jn)     
+                  END DO
+               END DO
+            ENDIF
+         ENDIF
+         !
+         !!----------------------------------------------------------------------
+         !!   II - horizontal trend  (full)
+         !!----------------------------------------------------------------------
+         !
+         DO jk = 1, jpkm1                                 ! Horizontal slab
+            !
+            !                             !== Vertical tracer gradient
+            zdk1t(:,:) = ( ptb(:,:,jk,jn) - ptb(:,:,jk+1,jn) ) * wmask(:,:,jk+1)     ! level jk+1
+            !
+            IF( jk == 1 ) THEN   ;   zdkt(:,:) = zdk1t(:,:)                          ! surface: zdkt(jk=1)=zdkt(jk=2)
+            ELSE                 ;   zdkt(:,:) = ( ptb(:,:,jk-1,jn) - ptb(:,:,jk,jn) ) * wmask(:,:,jk)
+            ENDIF
+            DO jj = 1 , jpjm1            !==  Horizontal fluxes
+               DO ji = 1, fs_jpim1   ! vector opt.
+                  zabe1 = pahu(ji,jj,jk) * e2_e1u(ji,jj) * e3u_n(ji,jj,jk)
+                  zabe2 = pahv(ji,jj,jk) * e1_e2v(ji,jj) * e3v_n(ji,jj,jk)
+                  !
+                  zmsku = 1. / MAX(  wmask(ji+1,jj,jk  ) + wmask(ji,jj,jk+1)   &
+                     &             + wmask(ji+1,jj,jk+1) + wmask(ji,jj,jk  ), 1. )
+                  !
+                  zmskv = 1. / MAX(  wmask(ji,jj+1,jk  ) + wmask(ji,jj,jk+1)   &
+                     &             + wmask(ji,jj+1,jk+1) + wmask(ji,jj,jk  ), 1. )
+                  !
+                  zcof1 = - pahu(ji,jj,jk) * e2u(ji,jj) * uslp(ji,jj,jk) * zmsku
+                  zcof2 = - pahv(ji,jj,jk) * e1v(ji,jj) * vslp(ji,jj,jk) * zmskv
+                  !
+                  zftu(ji,jj,jk ) = (  zabe1 * zdit(ji,jj,jk)   &
+                     &               + zcof1 * (  zdkt (ji+1,jj) + zdk1t(ji,jj)      &
+                     &                          + zdk1t(ji+1,jj) + zdkt (ji,jj)  )  ) * umask(ji,jj,jk)
+                  zftv(ji,jj,jk) = (  zabe2 * zdjt(ji,jj,jk)   &
+                     &               + zcof2 * (  zdkt (ji,jj+1) + zdk1t(ji,jj)      &
+                     &                          + zdk1t(ji,jj+1) + zdkt (ji,jj)  )  ) * vmask(ji,jj,jk)                  
+               END DO
+            END DO
+            !
+            DO jj = 2 , jpjm1          !== horizontal divergence and add to pta
+               DO ji = fs_2, fs_jpim1   ! vector opt.
+                  pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) + zsign * (  zftu(ji,jj,jk) - zftu(ji-1,jj,jk)      &
+                     &                                           + zftv(ji,jj,jk) - zftv(ji,jj-1,jk)  )   &
+                     &                                        * r1_e1e2t(ji,jj) / e3t_n(ji,jj,jk)
+               END DO
+            END DO
+         END DO                                        !   End of slab  
+
+         !!----------------------------------------------------------------------
+         !!   III - vertical trend (full)
+         !!----------------------------------------------------------------------
+         !
+         ztfw(1,:,:) = 0._wp     ;     ztfw(jpi,:,:) = 0._wp
+         !
+         ! Vertical fluxes
+         ! ---------------
+         !                          ! Surface and bottom vertical fluxes set to zero
+         ztfw(:,:, 1 ) = 0._wp      ;      ztfw(:,:,jpk) = 0._wp
+         
+         DO jk = 2, jpkm1           ! interior (2=<jk=<jpk-1)
+            DO jj = 2, jpjm1
+               DO ji = fs_2, fs_jpim1   ! vector opt.
+                  !
+                  zmsku = wmask(ji,jj,jk) / MAX(   umask(ji  ,jj,jk-1) + umask(ji-1,jj,jk)          &
+                     &                           + umask(ji-1,jj,jk-1) + umask(ji  ,jj,jk) , 1._wp  )
+                  zmskv = wmask(ji,jj,jk) / MAX(   vmask(ji,jj  ,jk-1) + vmask(ji,jj-1,jk)          &
+                     &                           + vmask(ji,jj-1,jk-1) + vmask(ji,jj  ,jk) , 1._wp  )
+                     !
+                  zahu_w = (   pahu(ji  ,jj,jk-1) + pahu(ji-1,jj,jk)    &
+                     &       + pahu(ji-1,jj,jk-1) + pahu(ji  ,jj,jk)  ) * zmsku
+                  zahv_w = (   pahv(ji,jj  ,jk-1) + pahv(ji,jj-1,jk)    &
+                     &       + pahv(ji,jj-1,jk-1) + pahv(ji,jj  ,jk)  ) * zmskv
+                     !
+                  zcoef3 = - zahu_w * e2t(ji,jj) * zmsku * wslpi (ji,jj,jk)   !wslpi & j are already w-masked
+                  zcoef4 = - zahv_w * e1t(ji,jj) * zmskv * wslpj (ji,jj,jk)
+                  !
+                  ztfw(ji,jj,jk) = zcoef3 * (   zdit(ji  ,jj  ,jk-1) + zdit(ji-1,jj  ,jk)      &
+                     &                        + zdit(ji-1,jj  ,jk-1) + zdit(ji  ,jj  ,jk)  )   &
+                     &           + zcoef4 * (   zdjt(ji  ,jj  ,jk-1) + zdjt(ji  ,jj-1,jk)      &
+                     &                        + zdjt(ji  ,jj-1,jk-1) + zdjt(ji  ,jj  ,jk)  )
+               END DO
+            END DO
+         END DO
+         !                                !==  add the vertical 33 flux  ==!
+         IF( ln_traldf_lap ) THEN               ! laplacian case: eddy coef = ah_wslp2 - akz
+            DO jk = 2, jpkm1       
+               DO jj = 1, jpjm1
+                  DO ji = fs_2, fs_jpim1
+                     ztfw(ji,jj,jk) = ztfw(ji,jj,jk) + e1e2t(ji,jj) / e3w_n(ji,jj,jk) * wmask(ji,jj,jk)   &
+                        &                            * ( ah_wslp2(ji,jj,jk) - akz(ji,jj,jk) )             &
+                        &                            * ( ptb(ji,jj,jk-1,jn) - ptb(ji,jj,jk,jn) )
+                  END DO
+               END DO
+            END DO
+            !
+         ELSE                                   ! bilaplacian 
+            SELECT CASE( kpass )
+            CASE(  1  )                            ! 1st pass : eddy coef = ah_wslp2
+               DO jk = 2, jpkm1 
+                  DO jj = 1, jpjm1
+                     DO ji = fs_2, fs_jpim1
+                        ztfw(ji,jj,jk) = ztfw(ji,jj,jk)    &
+                           &           + ah_wslp2(ji,jj,jk) * e1e2t(ji,jj)   &
+                           &           * ( ptb(ji,jj,jk-1,jn) - ptb(ji,jj,jk,jn) ) / e3w_n(ji,jj,jk) * wmask(ji,jj,jk)
+                     END DO
+                  END DO
+               END DO 
+            CASE(  2  )                         ! 2nd pass : eddy flux = ah_wslp2 and akz applied on ptb  and ptbb gradients, resp.
+               DO jk = 2, jpkm1 
+                  DO jj = 1, jpjm1
+                     DO ji = fs_2, fs_jpim1
+                        ztfw(ji,jj,jk) = ztfw(ji,jj,jk) + e1e2t(ji,jj) / e3w_n(ji,jj,jk) * wmask(ji,jj,jk)                      &
+                           &                            * (  ah_wslp2(ji,jj,jk) * ( ptb (ji,jj,jk-1,jn) - ptb (ji,jj,jk,jn) )   &
+                           &                               + akz     (ji,jj,jk) * ( ptbb(ji,jj,jk-1,jn) - ptbb(ji,jj,jk,jn) )   )
+                     END DO
+                  END DO
+               END DO
+            END SELECT
+         ENDIF
+         !         
+         DO jk = 1, jpkm1                 !==  Divergence of vertical fluxes added to pta  ==!
+            DO jj = 2, jpjm1
+               DO ji = fs_2, fs_jpim1   ! vector opt.
+                  pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) + zsign * (  ztfw (ji,jj,jk) - ztfw(ji,jj,jk+1)  )   &
+                     &                                        * r1_e1e2t(ji,jj) / e3t_n(ji,jj,jk)
+               END DO
+            END DO
+         END DO
+         !
+         IF( ( kpass == 1 .AND. ln_traldf_lap ) .OR.  &     !==  first pass only (  laplacian)  ==!
+             ( kpass == 2 .AND. ln_traldf_blp ) ) THEN      !==  2nd   pass      (bilaplacian)  ==!
+            !
+            !                             ! "Poleward" diffusive heat or salt transports (T-S case only)
+               ! note sign is reversed to give down-gradient diffusive transports )
+            IF( l_ptr )  CALL dia_ptr_hst( jn, 'ldf', -zftv(:,:,:)  )
+            !                          ! Diffusive heat transports
+            IF( l_hst )  CALL dia_ar5_hst( jn, 'ldf', -zftu(:,:,:), -zftv(:,:,:) )
+            !
+         ENDIF                                                    !== end pass selection  ==!
+         !
+         !                                                        ! ===============
+      END DO                                                      ! end tracer loop
+      !
+   END SUBROUTINE tra_ldf_iso
+
+   !!==============================================================================
+END MODULE traldf_iso
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/TRA/traldf_lap_blp.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/TRA/traldf_lap_blp.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/TRA/traldf_lap_blp.F90	(revision 9570)
@@ -0,0 +1,234 @@
+MODULE traldf_lap_blp
+   !!==============================================================================
+   !!                       ***  MODULE  traldf_lap_blp  ***
+   !! Ocean tracers:  lateral diffusivity trend  (laplacian and bilaplacian)
+   !!==============================================================================
+   !! History :  3.7  ! 2014-01  (G. Madec, S. Masson)  Original code, re-entrant laplacian 
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   tra_ldf_lap   : tracer trend update with iso-level laplacian diffusive operator
+   !!   tra_ldf_blp   : tracer trend update with iso-level or iso-neutral bilaplacian operator
+   !!----------------------------------------------------------------------
+   USE oce            ! ocean dynamics and active tracers
+   USE dom_oce        ! ocean space and time domain
+   USE ldftra         ! lateral physics: eddy diffusivity
+   USE traldf_iso     ! iso-neutral lateral diffusion (standard operator)     (tra_ldf_iso   routine)
+   USE traldf_triad   ! iso-neutral lateral diffusion (triad    operator)     (tra_ldf_triad routine)
+   USE diaptr         ! poleward transport diagnostics
+   USE diaar5         ! AR5 diagnostics
+   USE trc_oce        ! share passive tracers/Ocean variables
+   USE zpshde         ! partial step: hor. derivative     (zps_hde routine)
+   !
+   USE in_out_manager ! I/O manager
+   USE iom            ! I/O library
+   USE lbclnk         ! ocean lateral boundary conditions (or mpp link)
+   USE lib_mpp        ! distribued memory computing library
+   USE timing         ! Timing
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   tra_ldf_lap   ! called by traldf.F90
+   PUBLIC   tra_ldf_blp   ! called by traldf.F90
+
+   LOGICAL  ::   l_ptr   ! flag to compute poleward transport
+   LOGICAL  ::   l_hst   ! flag to compute heat transport
+
+   !! * Substitutions
+#  include "vectopt_loop_substitute.h90"
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.7 , NEMO Consortium (2014)
+   !! $Id$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE tra_ldf_lap( kt, kit000, cdtype, pahu, pahv, pgu , pgv ,   &
+      &                                                    pgui, pgvi,   &
+      &                                        ptb , pta , kjpt, kpass ) 
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE tra_ldf_lap  ***
+      !!                   
+      !! ** Purpose :   Compute the before horizontal tracer (t & s) diffusive 
+      !!      trend and add it to the general trend of tracer equation.
+      !!
+      !! ** Method  :   Second order diffusive operator evaluated using before
+      !!      fields (forward time scheme). The horizontal diffusive trends of 
+      !!      the tracer is given by:
+      !!          difft = 1/(e1e2t*e3t) {  di-1[ pahu e2u*e3u/e1u di(tb) ]
+      !!                                 + dj-1[ pahv e1v*e3v/e2v dj(tb) ] }
+      !!      Add this trend to the general tracer trend pta :
+      !!          pta = pta + difft
+      !!
+      !! ** Action  : - Update pta arrays with the before iso-level 
+      !!                harmonic mixing trend.
+      !!----------------------------------------------------------------------
+      INTEGER                              , INTENT(in   ) ::   kt         ! ocean time-step index
+      INTEGER                              , INTENT(in   ) ::   kit000     ! first time step index
+      CHARACTER(len=3)                     , INTENT(in   ) ::   cdtype     ! =TRA or TRC (tracer indicator)
+      INTEGER                              , INTENT(in   ) ::   kjpt       ! number of tracers
+      INTEGER                              , INTENT(in   ) ::   kpass      ! =1/2 first or second passage
+      REAL(wp), DIMENSION(jpi,jpj,jpk)     , INTENT(in   ) ::   pahu, pahv ! eddy diffusivity at u- and v-points  [m2/s]
+      REAL(wp), DIMENSION(jpi,jpj    ,kjpt), INTENT(in   ) ::   pgu, pgv   ! tracer gradient at pstep levels
+      REAL(wp), DIMENSION(jpi,jpj,    kjpt), INTENT(in   ) ::   pgui, pgvi ! tracer gradient at top   levels
+      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   ) ::   ptb        ! before and now tracer fields
+      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) ::   pta        ! tracer trend 
+      !
+      INTEGER  ::   ji, jj, jk, jn   ! dummy loop indices
+      REAL(wp) ::   zsign            ! local scalars
+      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   ztu, ztv, zaheeu, zaheev
+      !!----------------------------------------------------------------------
+      !
+      IF( kt == nit000 .AND. lwp )  THEN
+         WRITE(numout,*)
+         WRITE(numout,*) 'tra_ldf_lap : iso-level laplacian diffusion on ', cdtype, ', pass=', kpass
+         WRITE(numout,*) '~~~~~~~~~~~ '
+      ENDIF
+      !
+      l_hst = .FALSE.
+      l_ptr = .FALSE.
+      IF( cdtype == 'TRA' .AND. ln_diaptr )                                                l_ptr = .TRUE. 
+      IF( cdtype == 'TRA' .AND. ( iom_use("uadv_heattr") .OR. iom_use("vadv_heattr") .OR. &
+         &                        iom_use("uadv_salttr") .OR. iom_use("vadv_salttr")  ) )  l_hst = .TRUE.
+      !
+      !                                !==  Initialization of metric arrays used for all tracers  ==!
+      IF( kpass == 1 ) THEN   ;   zsign =  1._wp      ! bilaplacian operator require a minus sign (eddy diffusivity >0)
+      ELSE                    ;   zsign = -1._wp
+      ENDIF
+      DO jk = 1, jpkm1
+         DO jj = 1, jpjm1
+            DO ji = 1, fs_jpim1   ! vector opt.
+               zaheeu(ji,jj,jk) = zsign * pahu(ji,jj,jk) * e2_e1u(ji,jj) * e3u_n(ji,jj,jk)   !!gm   * umask(ji,jj,jk) pah masked!
+               zaheev(ji,jj,jk) = zsign * pahv(ji,jj,jk) * e1_e2v(ji,jj) * e3v_n(ji,jj,jk)   !!gm   * vmask(ji,jj,jk)
+            END DO
+         END DO
+      END DO
+      !
+      !                             ! =========== !
+      DO jn = 1, kjpt               ! tracer loop !
+         !                          ! =========== !    
+         !                               
+         DO jk = 1, jpkm1              !== First derivative (gradient)  ==!
+            DO jj = 1, jpjm1
+               DO ji = 1, fs_jpim1
+                  ztu(ji,jj,jk) = zaheeu(ji,jj,jk) * ( ptb(ji+1,jj  ,jk,jn) - ptb(ji,jj,jk,jn) )
+                  ztv(ji,jj,jk) = zaheev(ji,jj,jk) * ( ptb(ji  ,jj+1,jk,jn) - ptb(ji,jj,jk,jn) )
+               END DO
+            END DO
+         END DO  
+         IF( ln_zps ) THEN                ! set gradient at bottom/top ocean level
+            DO jj = 1, jpjm1                    ! bottom
+               DO ji = 1, fs_jpim1
+                  ztu(ji,jj,mbku(ji,jj)) = zaheeu(ji,jj,mbku(ji,jj)) * pgu(ji,jj,jn)
+                  ztv(ji,jj,mbkv(ji,jj)) = zaheev(ji,jj,mbkv(ji,jj)) * pgv(ji,jj,jn)
+               END DO
+            END DO  
+            IF( ln_isfcav ) THEN                ! top in ocean cavities only
+               DO jj = 1, jpjm1
+                  DO ji = 1, fs_jpim1   ! vector opt.
+                     IF( miku(ji,jj) > 1 )   ztu(ji,jj,miku(ji,jj)) = zaheeu(ji,jj,miku(ji,jj)) * pgui(ji,jj,jn) 
+                     IF( mikv(ji,jj) > 1 )   ztv(ji,jj,mikv(ji,jj)) = zaheev(ji,jj,mikv(ji,jj)) * pgvi(ji,jj,jn) 
+                  END DO
+               END DO
+            ENDIF
+         ENDIF
+         !
+         DO jk = 1, jpkm1              !== Second derivative (divergence) added to the general tracer trends  ==!
+            DO jj = 2, jpjm1
+               DO ji = fs_2, fs_jpim1
+                  pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) + (  ztu(ji,jj,jk) - ztu(ji-1,jj,jk)     &
+                     &                                   + ztv(ji,jj,jk) - ztv(ji,jj-1,jk) )   &
+                     &                                / ( e1e2t(ji,jj) * e3t_n(ji,jj,jk) )
+               END DO
+            END DO
+         END DO  
+         !
+         !                             !== "Poleward" diffusive heat or salt transports  ==!
+         IF( ( kpass == 1 .AND. .NOT.ln_traldf_blp ) .OR.  &     !==  first pass only (  laplacian)  ==!
+             ( kpass == 2 .AND.      ln_traldf_blp ) ) THEN      !==  2nd   pass only (bilaplacian)  ==!
+
+            IF( l_ptr )  CALL dia_ptr_hst( jn, 'ldf', -ztv(:,:,:)  )
+            IF( l_hst )  CALL dia_ar5_hst( jn, 'ldf', -ztu(:,:,:), -ztv(:,:,:) )
+         ENDIF
+         !                          ! ==================
+      END DO                        ! end of tracer loop
+      !                             ! ==================
+      !
+   END SUBROUTINE tra_ldf_lap
+   
+
+   SUBROUTINE tra_ldf_blp( kt, kit000, cdtype, pahu, pahv, pgu , pgv ,   &
+      &                                                    pgui, pgvi,   &
+      &                                                    ptb , pta , kjpt, kldf )
+      !!----------------------------------------------------------------------
+      !!                 ***  ROUTINE tra_ldf_blp  ***
+      !!                    
+      !! ** Purpose :   Compute the before lateral tracer diffusive 
+      !!      trend and add it to the general trend of tracer equation.
+      !!
+      !! ** Method  :   The lateral diffusive trends is provided by a bilaplacian
+      !!      operator applied to before field (forward in time).
+      !!      It is computed by two successive calls to laplacian routine
+      !!
+      !! ** Action :   pta   updated with the before rotated bilaplacian diffusion
+      !!----------------------------------------------------------------------
+      INTEGER                              , INTENT(in   ) ::   kt         ! ocean time-step index
+      INTEGER                              , INTENT(in   ) ::   kit000     ! first time step index
+      CHARACTER(len=3)                     , INTENT(in   ) ::   cdtype     ! =TRA or TRC (tracer indicator)
+      INTEGER                              , INTENT(in   ) ::   kjpt       ! number of tracers
+      INTEGER                              , INTENT(in   ) ::   kldf       ! type of operator used
+      REAL(wp), DIMENSION(jpi,jpj,jpk)     , INTENT(in   ) ::   pahu, pahv ! eddy diffusivity at u- and v-points  [m2/s]
+      REAL(wp), DIMENSION(jpi,jpj    ,kjpt), INTENT(in   ) ::   pgu, pgv   ! tracer gradient at pstep levels
+      REAL(wp), DIMENSION(jpi,jpj,    kjpt), INTENT(in   ) ::   pgui, pgvi ! tracer gradient at top levels
+      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   ) ::   ptb        ! before and now tracer fields
+      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) ::   pta        ! tracer trend
+      !
+      INTEGER ::   ji, jj, jk, jn   ! dummy loop indices
+      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt) :: zlap         ! laplacian at t-point
+      REAL(wp), DIMENSION(jpi,jpj,    kjpt) :: zglu, zglv   ! bottom GRADh of the laplacian (u- and v-points)
+      REAL(wp), DIMENSION(jpi,jpj,    kjpt) :: zgui, zgvi   ! top    GRADh of the laplacian (u- and v-points)
+      !!---------------------------------------------------------------------
+      !
+      IF( kt == kit000 .AND. lwp )  THEN
+         WRITE(numout,*)
+         SELECT CASE ( kldf )
+         CASE ( np_blp    )   ;   WRITE(numout,*) 'tra_ldf_blp : iso-level   bilaplacian operator on ', cdtype
+         CASE ( np_blp_i  )   ;   WRITE(numout,*) 'tra_ldf_blp : iso-neutral bilaplacian operator on ', cdtype, ' (Standard)'
+         CASE ( np_blp_it )   ;   WRITE(numout,*) 'tra_ldf_blp : iso-neutral bilaplacian operator on ', cdtype, ' (triad)'
+         END SELECT
+         WRITE(numout,*) '~~~~~~~~~~~'
+      ENDIF
+
+      zlap(:,:,:,:) = 0._wp
+      !
+      SELECT CASE ( kldf )       !==  1st laplacian applied to ptb (output in zlap)  ==!
+      !
+      CASE ( np_blp    )               ! iso-level bilaplacian
+         CALL tra_ldf_lap  ( kt, kit000, cdtype, pahu, pahv, pgu, pgv, pgui, pgvi, ptb,      zlap, kjpt, 1 )
+      CASE ( np_blp_i  )               ! rotated   bilaplacian : standard operator (Madec)
+         CALL tra_ldf_iso  ( kt, kit000, cdtype, pahu, pahv, pgu, pgv, pgui, pgvi, ptb, ptb, zlap, kjpt, 1 )
+      CASE ( np_blp_it )               ! rotated  bilaplacian : triad operator (griffies)
+         CALL tra_ldf_triad( kt, kit000, cdtype, pahu, pahv, pgu, pgv, pgui, pgvi, ptb, ptb, zlap, kjpt, 1 )
+      END SELECT
+      !
+      CALL lbc_lnk( zlap(:,:,:,:) , 'T', 1. )     ! Lateral boundary conditions (unchanged sign)
+      !                                               ! Partial top/bottom cell: GRADh( zlap )  
+      IF( ln_isfcav .AND. ln_zps ) THEN   ;   CALL zps_hde_isf( kt, kjpt, zlap, zglu, zglv, zgui, zgvi )  ! both top & bottom
+      ELSEIF(             ln_zps ) THEN   ;   CALL zps_hde    ( kt, kjpt, zlap, zglu, zglv )              ! only bottom 
+      ENDIF
+      !
+      SELECT CASE ( kldf )       !==  2nd laplacian applied to zlap (output in pta)  ==!
+      !
+      CASE ( np_blp    )               ! iso-level bilaplacian
+         CALL tra_ldf_lap  ( kt, kit000, cdtype, pahu, pahv, zglu, zglv, zgui, zgvi, zlap, pta,      kjpt, 2 )
+      CASE ( np_blp_i  )               ! rotated   bilaplacian : standard operator (Madec)
+         CALL tra_ldf_iso  ( kt, kit000, cdtype, pahu, pahv, zglu, zglv, zgui, zgvi, zlap, ptb, pta, kjpt, 2 )
+      CASE ( np_blp_it )               ! rotated  bilaplacian : triad operator (griffies)
+         CALL tra_ldf_triad( kt, kit000, cdtype, pahu, pahv, zglu, zglv, zgui, zgvi, zlap, ptb, pta, kjpt, 2 )
+      END SELECT
+      !
+   END SUBROUTINE tra_ldf_blp
+
+   !!==============================================================================
+END MODULE traldf_lap_blp
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/TRA/traldf_triad.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/TRA/traldf_triad.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/TRA/traldf_triad.F90	(revision 9570)
@@ -0,0 +1,432 @@
+MODULE traldf_triad
+   !!======================================================================
+   !!                   ***  MODULE  traldf_triad  ***
+   !! Ocean  tracers:  horizontal component of the lateral tracer mixing trend
+   !!======================================================================
+   !! History :  3.3  ! 2010-10  (G. Nurser, C. Harris, G. Madec)  Griffies operator (original code)
+   !!            3.7  ! 2013-12  (F. Lemarie, G. Madec)  triad operator (Griffies) + Method of Stabilizing Correction
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   tra_ldf_triad : update the tracer trend with the iso-neutral laplacian triad-operator
+   !!----------------------------------------------------------------------
+   USE oce            ! ocean dynamics and active tracers
+   USE dom_oce        ! ocean space and time domain
+   USE phycst         ! physical constants
+   USE trc_oce        ! share passive tracers/Ocean variables
+   USE zdf_oce        ! ocean vertical physics
+   USE ldftra         ! lateral physics: eddy diffusivity
+   USE ldfslp         ! lateral physics: iso-neutral slopes
+   USE traldf_iso     ! lateral diffusion (Madec operator)         (tra_ldf_iso routine)
+   USE diaptr         ! poleward transport diagnostics
+   USE diaar5         ! AR5 diagnostics
+   USE zpshde         ! partial step: hor. derivative     (zps_hde routine)
+   !
+   USE in_out_manager ! I/O manager
+   USE iom            ! I/O library
+   USE lbclnk         ! ocean lateral boundary conditions (or mpp link)
+   USE lib_mpp        ! MPP library
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   tra_ldf_triad   ! routine called by traldf.F90
+
+   REAL(wp), DIMENSION(:,:,:), ALLOCATABLE, SAVE ::   zdkt3d   !: vertical tracer gradient at 2 levels
+
+   LOGICAL  ::   l_ptr   ! flag to compute poleward transport
+   LOGICAL  ::   l_hst   ! flag to compute heat transport
+
+
+   !! * Substitutions
+#  include "vectopt_loop_substitute.h90"
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.7 , NEMO Consortium (2015)
+   !! $Id$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+  SUBROUTINE tra_ldf_triad( kt, kit000, cdtype, pahu, pahv, pgu , pgv ,   &
+      &                                                     pgui, pgvi,   &
+      &                                         ptb , ptbb, pta , kjpt, kpass )
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE tra_ldf_triad  ***
+      !!
+      !! ** Purpose :   Compute the before horizontal tracer (t & s) diffusive
+      !!      trend for a laplacian tensor (ezxcept the dz[ dz[.] ] term) and
+      !!      add it to the general trend of tracer equation.
+      !!
+      !! ** Method  :   The horizontal component of the lateral diffusive trends
+      !!      is provided by a 2nd order operator rotated along neural or geopo-
+      !!      tential surfaces to which an eddy induced advection can be added
+      !!      It is computed using before fields (forward in time) and isopyc-
+      !!      nal or geopotential slopes computed in routine ldfslp.
+      !!
+      !!      see documentation for the desciption
+      !!
+      !! ** Action :   pta   updated with the before rotated diffusion
+      !!               ah_wslp2 ....
+      !!               akz   stabilizing vertical diffusivity coefficient (used in trazdf_imp)
+      !!----------------------------------------------------------------------
+      INTEGER                              , INTENT(in   ) ::   kt         ! ocean time-step index
+      INTEGER                              , INTENT(in   ) ::   kit000     ! first time step index
+      CHARACTER(len=3)                     , INTENT(in   ) ::   cdtype     ! =TRA or TRC (tracer indicator)
+      INTEGER                              , INTENT(in   ) ::   kjpt       ! number of tracers
+      INTEGER                              , INTENT(in   ) ::   kpass      ! =1/2 first or second passage
+      REAL(wp), DIMENSION(jpi,jpj,jpk)     , INTENT(in   ) ::   pahu, pahv ! eddy diffusivity at u- and v-points  [m2/s]
+      REAL(wp), DIMENSION(jpi,jpj    ,kjpt), INTENT(in   ) ::   pgu , pgv  ! tracer gradient at pstep levels
+      REAL(wp), DIMENSION(jpi,jpj,    kjpt), INTENT(in   ) ::   pgui, pgvi ! tracer gradient at top   levels
+      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   ) ::   ptb        ! tracer (kpass=1) or laplacian of tracer (kpass=2)
+      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   ) ::   ptbb       ! tracer (only used in kpass=2)
+      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) ::   pta        ! tracer trend
+      !
+      INTEGER  ::  ji, jj, jk, jn   ! dummy loop indices
+      INTEGER  ::  ip,jp,kp         ! dummy loop indices
+      INTEGER  ::  ierr            ! local integer
+      REAL(wp) ::  zmsku, zabe1, zcof1, zcoef3          ! local scalars
+      REAL(wp) ::  zmskv, zabe2, zcof2, zcoef4          !   -      -
+      REAL(wp) ::  zcoef0, ze3w_2, zsign, z2dt, z1_2dt  !   -      -
+      !
+      REAL(wp) ::   zslope_skew, zslope_iso, zslope2, zbu, zbv
+      REAL(wp) ::   ze1ur, ze2vr, ze3wr, zdxt, zdyt, zdzt
+      REAL(wp) ::   zah, zah_slp, zaei_slp
+      REAL(wp), DIMENSION(jpi,jpj    ) ::   z2d                                              ! 2D workspace
+      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zdit, zdjt, zftu, zftv, ztfw, zpsi_uw, zpsi_vw   ! 3D     -
+      !!----------------------------------------------------------------------
+      !
+      IF( .NOT.ALLOCATED(zdkt3d) )  THEN
+         ALLOCATE( zdkt3d(jpi,jpj,0:1) , STAT=ierr )
+         IF( lk_mpp   )   CALL mpp_sum ( ierr )
+         IF( ierr > 0 )   CALL ctl_stop('STOP', 'tra_ldf_triad: unable to allocate arrays')
+      ENDIF
+     !
+      IF( kpass == 1 .AND. kt == kit000 )  THEN
+         IF(lwp) WRITE(numout,*)
+         IF(lwp) WRITE(numout,*) 'tra_ldf_triad : rotated laplacian diffusion operator on ', cdtype
+         IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~'
+      ENDIF
+      !   
+      l_hst = .FALSE.
+      l_ptr = .FALSE.
+      IF( cdtype == 'TRA' .AND. ln_diaptr )                                                 l_ptr = .TRUE. 
+      IF( cdtype == 'TRA' .AND. ( iom_use("uadv_heattr") .OR. iom_use("vadv_heattr") .OR. &
+         &                        iom_use("uadv_salttr") .OR. iom_use("vadv_salttr")  ) )   l_hst = .TRUE.
+      !
+      !                                                        ! set time step size (Euler/Leapfrog)
+      IF( neuler == 0 .AND. kt == kit000 ) THEN   ;   z2dt =     rdt      ! at nit000   (Euler)
+      ELSE                                        ;   z2dt = 2.* rdt      !             (Leapfrog)
+      ENDIF
+      z1_2dt = 1._wp / z2dt
+      !
+      IF( kpass == 1 ) THEN   ;   zsign =  1._wp      ! bilaplacian operator require a minus sign (eddy diffusivity >0)
+      ELSE                    ;   zsign = -1._wp
+      ENDIF
+      !    
+      !!----------------------------------------------------------------------
+      !!   0 - calculate  ah_wslp2, akz, and optionally zpsi_uw, zpsi_vw
+      !!----------------------------------------------------------------------
+      !
+      IF( kpass == 1 ) THEN         !==  first pass only  and whatever the tracer is  ==!
+         !
+         akz     (:,:,:) = 0._wp      
+         ah_wslp2(:,:,:) = 0._wp
+         IF( ln_ldfeiv_dia ) THEN
+            zpsi_uw(:,:,:) = 0._wp
+            zpsi_vw(:,:,:) = 0._wp
+         ENDIF
+         !
+         DO ip = 0, 1                            ! i-k triads
+            DO kp = 0, 1
+               DO jk = 1, jpkm1
+                  DO jj = 1, jpjm1
+                     DO ji = 1, fs_jpim1
+                        ze3wr = 1._wp / e3w_n(ji+ip,jj,jk+kp)
+                        zbu   = e1e2u(ji,jj) * e3u_n(ji,jj,jk)
+                        zah   = 0.25_wp * pahu(ji,jj,jk)
+                        zslope_skew = triadi_g(ji+ip,jj,jk,1-ip,kp)
+                        ! Subtract s-coordinate slope at t-points to give slope rel to s-surfaces (do this by *adding* gradient of depth)
+                        zslope2 = zslope_skew + ( gdept_n(ji+1,jj,jk) - gdept_n(ji,jj,jk) ) * r1_e1u(ji,jj) * umask(ji,jj,jk+kp)
+                        zslope2 = zslope2 *zslope2
+                        ah_wslp2(ji+ip,jj,jk+kp) = ah_wslp2(ji+ip,jj,jk+kp) + zah * zbu * ze3wr * r1_e1e2t(ji+ip,jj) * zslope2
+                        akz     (ji+ip,jj,jk+kp) = akz     (ji+ip,jj,jk+kp) + zah * r1_e1u(ji,jj)       &
+                           &                                                      * r1_e1u(ji,jj) * umask(ji,jj,jk+kp)
+                           !
+                       IF( ln_ldfeiv_dia )   zpsi_uw(ji,jj,jk+kp) = zpsi_uw(ji,jj,jk+kp)   &
+                           &                                       + 0.25_wp * aeiu(ji,jj,jk) * e2u(ji,jj) * zslope_skew
+                     END DO
+                  END DO
+               END DO
+            END DO
+         END DO
+         !
+         DO jp = 0, 1                            ! j-k triads 
+            DO kp = 0, 1
+               DO jk = 1, jpkm1
+                  DO jj = 1, jpjm1
+                     DO ji = 1, fs_jpim1
+                        ze3wr = 1.0_wp / e3w_n(ji,jj+jp,jk+kp)
+                        zbv   = e1e2v(ji,jj) * e3v_n(ji,jj,jk)
+                        zah   = 0.25_wp * pahv(ji,jj,jk)
+                        zslope_skew = triadj_g(ji,jj+jp,jk,1-jp,kp)
+                        ! Subtract s-coordinate slope at t-points to give slope rel to s surfaces
+                        !    (do this by *adding* gradient of depth)
+                        zslope2 = zslope_skew + ( gdept_n(ji,jj+1,jk) - gdept_n(ji,jj,jk) ) * r1_e2v(ji,jj) * vmask(ji,jj,jk+kp)
+                        zslope2 = zslope2 * zslope2
+                        ah_wslp2(ji,jj+jp,jk+kp) = ah_wslp2(ji,jj+jp,jk+kp) + zah * zbv * ze3wr * r1_e1e2t(ji,jj+jp) * zslope2
+                        akz     (ji,jj+jp,jk+kp) = akz     (ji,jj+jp,jk+kp) + zah * r1_e2v(ji,jj)     &
+                           &                                                      * r1_e2v(ji,jj) * vmask(ji,jj,jk+kp)
+                        !
+                        IF( ln_ldfeiv_dia )   zpsi_vw(ji,jj,jk+kp) = zpsi_vw(ji,jj,jk+kp)   &
+                           &                                       + 0.25 * aeiv(ji,jj,jk) * e1v(ji,jj) * zslope_skew
+                     END DO
+                  END DO
+               END DO
+            END DO
+         END DO
+         !
+         IF( ln_traldf_msc ) THEN                ! stabilizing vertical diffusivity coefficient
+            !
+            IF( ln_traldf_blp ) THEN                ! bilaplacian operator
+               DO jk = 2, jpkm1
+                  DO jj = 1, jpjm1
+                     DO ji = 1, fs_jpim1
+                        akz(ji,jj,jk) = 16._wp * ah_wslp2(ji,jj,jk)   &
+                           &          * (  akz(ji,jj,jk) + ah_wslp2(ji,jj,jk) / ( e3w_n(ji,jj,jk) * e3w_n(ji,jj,jk) )  )
+                     END DO
+                  END DO
+               END DO
+            ELSEIF( ln_traldf_lap ) THEN              ! laplacian operator
+               DO jk = 2, jpkm1
+                  DO jj = 1, jpjm1
+                     DO ji = 1, fs_jpim1
+                        ze3w_2 = e3w_n(ji,jj,jk) * e3w_n(ji,jj,jk)
+                        zcoef0 = z2dt * (  akz(ji,jj,jk) + ah_wslp2(ji,jj,jk) / ze3w_2  )
+                        akz(ji,jj,jk) = MAX( zcoef0 - 0.5_wp , 0._wp ) * ze3w_2 * z1_2dt
+                     END DO
+                  END DO
+               END DO
+           ENDIF
+           !
+         ELSE                                    ! 33 flux set to zero with akz=ah_wslp2 ==>> computed in full implicit
+            akz(:,:,:) = ah_wslp2(:,:,:)      
+         ENDIF
+         !
+         IF( ln_ldfeiv_dia .AND. cdtype == 'TRA' )   CALL ldf_eiv_dia( zpsi_uw, zpsi_vw )
+         !
+      ENDIF                                  !==  end 1st pass only  ==!
+      !
+      !                                                           ! ===========
+      DO jn = 1, kjpt                                             ! tracer loop
+         !                                                        ! ===========
+         ! Zero fluxes for each tracer
+!!gm  this should probably be done outside the jn loop
+         ztfw(:,:,:) = 0._wp
+         zftu(:,:,:) = 0._wp
+         zftv(:,:,:) = 0._wp
+         !
+         DO jk = 1, jpkm1        !==  before lateral T & S gradients at T-level jk  ==!
+            DO jj = 1, jpjm1
+               DO ji = 1, fs_jpim1   ! vector opt.
+                  zdit(ji,jj,jk) = ( ptb(ji+1,jj  ,jk,jn) - ptb(ji,jj,jk,jn) ) * umask(ji,jj,jk)
+                  zdjt(ji,jj,jk) = ( ptb(ji  ,jj+1,jk,jn) - ptb(ji,jj,jk,jn) ) * vmask(ji,jj,jk)
+               END DO
+            END DO
+         END DO
+         IF( ln_zps .AND. l_grad_zps ) THEN    ! partial steps: correction at top/bottom ocean level
+            DO jj = 1, jpjm1                       ! bottom level
+               DO ji = 1, fs_jpim1   ! vector opt.
+                  zdit(ji,jj,mbku(ji,jj)) = pgu(ji,jj,jn)
+                  zdjt(ji,jj,mbkv(ji,jj)) = pgv(ji,jj,jn)
+               END DO
+            END DO
+            IF( ln_isfcav ) THEN                   ! top level (ocean cavities only)
+               DO jj = 1, jpjm1
+                  DO ji = 1, fs_jpim1   ! vector opt.
+                     IF( miku(ji,jj)  > 1 )   zdit(ji,jj,miku(ji,jj) ) = pgui(ji,jj,jn) 
+                     IF( mikv(ji,jj)  > 1 )   zdjt(ji,jj,mikv(ji,jj) ) = pgvi(ji,jj,jn) 
+                  END DO
+               END DO
+            ENDIF
+         ENDIF
+         !
+         !!----------------------------------------------------------------------
+         !!   II - horizontal trend  (full)
+         !!----------------------------------------------------------------------
+         !
+         DO jk = 1, jpkm1
+            !                    !==  Vertical tracer gradient at level jk and jk+1
+            zdkt3d(:,:,1) = ( ptb(:,:,jk,jn) - ptb(:,:,jk+1,jn) ) * tmask(:,:,jk+1)
+            !
+            !                    ! surface boundary condition: zdkt3d(jk=0)=zdkt3d(jk=1)
+            IF( jk == 1 ) THEN   ;   zdkt3d(:,:,0) = zdkt3d(:,:,1)
+            ELSE                 ;   zdkt3d(:,:,0) = ( ptb(:,:,jk-1,jn) - ptb(:,:,jk,jn) ) * tmask(:,:,jk)
+            ENDIF
+            !
+            zaei_slp = 0._wp
+            !
+            IF( ln_botmix_triad ) THEN
+               DO ip = 0, 1              !==  Horizontal & vertical fluxes
+                  DO kp = 0, 1
+                     DO jj = 1, jpjm1
+                        DO ji = 1, fs_jpim1
+                           ze1ur = r1_e1u(ji,jj)
+                           zdxt  = zdit(ji,jj,jk) * ze1ur
+                           ze3wr = 1._wp / e3w_n(ji+ip,jj,jk+kp)
+                           zdzt  = zdkt3d(ji+ip,jj,kp) * ze3wr
+                           zslope_skew = triadi_g(ji+ip,jj,jk,1-ip,kp)
+                           zslope_iso  = triadi  (ji+ip,jj,jk,1-ip,kp)
+                           !
+                           zbu = 0.25_wp * e1e2u(ji,jj) * e3u_n(ji,jj,jk)
+                           ! ln_botmix_triad is .T. don't mask zah for bottom half cells    !!gm ?????   ahu is masked....
+                           zah = pahu(ji,jj,jk)
+                           zah_slp  = zah * zslope_iso
+                           IF( ln_ldfeiv )   zaei_slp = aeiu(ji,jj,jk) * zslope_skew
+                           zftu(ji   ,jj,jk   ) = zftu(ji   ,jj,jk   ) - ( zah * zdxt + (zah_slp - zaei_slp) * zdzt ) * zbu * ze1ur
+                           ztfw(ji+ip,jj,jk+kp) = ztfw(ji+ip,jj,jk+kp) - ( zah_slp + zaei_slp) * zdxt                 * zbu * ze3wr
+                        END DO
+                     END DO
+                  END DO
+               END DO
+               !
+               DO jp = 0, 1
+                  DO kp = 0, 1
+                     DO jj = 1, jpjm1
+                        DO ji = 1, fs_jpim1
+                           ze2vr = r1_e2v(ji,jj)
+                           zdyt  = zdjt(ji,jj,jk) * ze2vr
+                           ze3wr = 1._wp / e3w_n(ji,jj+jp,jk+kp)
+                           zdzt  = zdkt3d(ji,jj+jp,kp) * ze3wr
+                           zslope_skew = triadj_g(ji,jj+jp,jk,1-jp,kp)
+                           zslope_iso  = triadj(ji,jj+jp,jk,1-jp,kp)
+                           zbv = 0.25_wp * e1e2v(ji,jj) * e3v_n(ji,jj,jk)
+                           ! ln_botmix_triad is .T. don't mask zah for bottom half cells    !!gm ?????  ahv is masked...
+                           zah = pahv(ji,jj,jk)
+                           zah_slp = zah * zslope_iso
+                           IF( ln_ldfeiv )   zaei_slp = aeiv(ji,jj,jk) * zslope_skew
+                           zftv(ji,jj   ,jk   ) = zftv(ji,jj   ,jk   ) - ( zah * zdyt + (zah_slp - zaei_slp) * zdzt ) * zbv * ze2vr
+                           ztfw(ji,jj+jp,jk+kp) = ztfw(ji,jj+jp,jk+kp) - ( zah_slp + zaei_slp ) * zdyt                * zbv * ze3wr
+                        END DO
+                     END DO
+                  END DO
+               END DO
+               !
+            ELSE
+               !
+               DO ip = 0, 1               !==  Horizontal & vertical fluxes
+                  DO kp = 0, 1
+                     DO jj = 1, jpjm1
+                        DO ji = 1, fs_jpim1
+                           ze1ur = r1_e1u(ji,jj)
+                           zdxt  = zdit(ji,jj,jk) * ze1ur
+                           ze3wr = 1._wp / e3w_n(ji+ip,jj,jk+kp)
+                           zdzt  = zdkt3d(ji+ip,jj,kp) * ze3wr
+                           zslope_skew = triadi_g(ji+ip,jj,jk,1-ip,kp)
+                           zslope_iso  = triadi(ji+ip,jj,jk,1-ip,kp)
+                           !
+                           zbu = 0.25_wp * e1e2u(ji,jj) * e3u_n(ji,jj,jk)
+                           ! ln_botmix_triad is .F. mask zah for bottom half cells
+                           zah = pahu(ji,jj,jk) * umask(ji,jj,jk+kp)         ! pahu(ji+ip,jj,jk)   ===>>  ????
+                           zah_slp  = zah * zslope_iso
+                           IF( ln_ldfeiv )   zaei_slp = aeiu(ji,jj,jk) * zslope_skew        ! aeit(ji+ip,jj,jk)*zslope_skew
+                           zftu(ji   ,jj,jk   ) = zftu(ji   ,jj,jk   ) - ( zah * zdxt + (zah_slp - zaei_slp) * zdzt ) * zbu * ze1ur
+                           ztfw(ji+ip,jj,jk+kp) = ztfw(ji+ip,jj,jk+kp) - (zah_slp + zaei_slp) * zdxt * zbu * ze3wr
+                        END DO
+                     END DO
+                  END DO
+               END DO
+               !
+               DO jp = 0, 1
+                  DO kp = 0, 1
+                     DO jj = 1, jpjm1
+                        DO ji = 1, fs_jpim1
+                           ze2vr = r1_e2v(ji,jj)
+                           zdyt  = zdjt(ji,jj,jk) * ze2vr
+                           ze3wr = 1._wp / e3w_n(ji,jj+jp,jk+kp)
+                           zdzt  = zdkt3d(ji,jj+jp,kp) * ze3wr
+                           zslope_skew = triadj_g(ji,jj+jp,jk,1-jp,kp)
+                           zslope_iso  = triadj(ji,jj+jp,jk,1-jp,kp)
+                           zbv = 0.25_wp * e1e2v(ji,jj) * e3v_n(ji,jj,jk)
+                           ! ln_botmix_triad is .F. mask zah for bottom half cells
+                           zah = pahv(ji,jj,jk) * vmask(ji,jj,jk+kp)         ! pahv(ji,jj+jp,jk)  ????
+                           zah_slp = zah * zslope_iso
+                           IF( ln_ldfeiv )   zaei_slp = aeiv(ji,jj,jk) * zslope_skew        ! aeit(ji,jj+jp,jk)*zslope_skew
+                           zftv(ji,jj,jk) = zftv(ji,jj,jk) - ( zah * zdyt + (zah_slp - zaei_slp) * zdzt ) * zbv * ze2vr
+                           ztfw(ji,jj+jp,jk+kp) = ztfw(ji,jj+jp,jk+kp) - (zah_slp + zaei_slp) * zdyt * zbv * ze3wr
+                        END DO
+                     END DO
+                  END DO
+               END DO
+            ENDIF
+            !                             !==  horizontal divergence and add to the general trend  ==!
+            DO jj = 2 , jpjm1
+               DO ji = fs_2, fs_jpim1  ! vector opt.
+                  pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) + zsign * (  zftu(ji-1,jj,jk) - zftu(ji,jj,jk)       &
+                     &                                           + zftv(ji,jj-1,jk) - zftv(ji,jj,jk)   )   &
+                     &                                        / (  e1e2t(ji,jj) * e3t_n(ji,jj,jk)  )
+               END DO
+            END DO
+            !
+         END DO
+         !
+         !                                !==  add the vertical 33 flux  ==!
+         IF( ln_traldf_lap ) THEN               ! laplacian case: eddy coef = ah_wslp2 - akz
+            DO jk = 2, jpkm1       
+               DO jj = 1, jpjm1
+                  DO ji = fs_2, fs_jpim1
+                     ztfw(ji,jj,jk) = ztfw(ji,jj,jk) - e1e2t(ji,jj) / e3w_n(ji,jj,jk) * tmask(ji,jj,jk)   &
+                        &                            * ( ah_wslp2(ji,jj,jk) - akz(ji,jj,jk) )             &
+                        &                            * ( ptb(ji,jj,jk-1,jn) - ptb(ji,jj,jk,jn) )
+                  END DO
+               END DO
+            END DO
+         ELSE                                   ! bilaplacian 
+            SELECT CASE( kpass )
+            CASE(  1  )                            ! 1st pass : eddy coef = ah_wslp2
+               DO jk = 2, jpkm1 
+                  DO jj = 1, jpjm1
+                     DO ji = fs_2, fs_jpim1
+                        ztfw(ji,jj,jk) = ztfw(ji,jj,jk) - e1e2t(ji,jj) / e3w_n(ji,jj,jk) * tmask(ji,jj,jk)             &
+                           &                            * ah_wslp2(ji,jj,jk) * ( ptb(ji,jj,jk-1,jn) - ptb(ji,jj,jk,jn) )
+                     END DO
+                  END DO
+               END DO 
+            CASE(  2  )                            ! 2nd pass : eddy flux = ah_wslp2 and akz applied on ptb  and ptbb gradients, resp.
+               DO jk = 2, jpkm1 
+                  DO jj = 1, jpjm1
+                     DO ji = fs_2, fs_jpim1
+                        ztfw(ji,jj,jk) = ztfw(ji,jj,jk) - e1e2t(ji,jj) / e3w_n(ji,jj,jk) * tmask(ji,jj,jk)                      &
+                           &                            * (  ah_wslp2(ji,jj,jk) * ( ptb (ji,jj,jk-1,jn) - ptb (ji,jj,jk,jn) )   &
+                           &                               + akz     (ji,jj,jk) * ( ptbb(ji,jj,jk-1,jn) - ptbb(ji,jj,jk,jn) )   )
+                     END DO
+                  END DO
+               END DO
+            END SELECT 
+         ENDIF
+         !
+         DO jk = 1, jpkm1                 !==  Divergence of vertical fluxes added to pta  ==!
+            DO jj = 2, jpjm1
+               DO ji = fs_2, fs_jpim1  ! vector opt.
+                  pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) + zsign * (  ztfw(ji,jj,jk+1) - ztfw(ji,jj,jk)  )   &
+                     &                                        / ( e1e2t(ji,jj) * e3t_n(ji,jj,jk) )
+               END DO
+            END DO
+         END DO
+         !
+         IF( ( kpass == 1 .AND. ln_traldf_lap ) .OR.  &     !==  first pass only (  laplacian)  ==!
+             ( kpass == 2 .AND. ln_traldf_blp ) ) THEN      !==  2nd   pass      (bilaplacian)  ==!
+            !
+            !                          ! "Poleward" diffusive heat or salt transports (T-S case only)
+            IF( l_ptr )  CALL dia_ptr_hst( jn, 'ldf', zftv(:,:,:)  )
+            !                          ! Diffusive heat transports
+            IF( l_hst )  CALL dia_ar5_hst( jn, 'ldf', zftu(:,:,:), zftv(:,:,:) )
+            !
+         ENDIF                                                    !== end pass selection  ==!
+         !
+         !                                                        ! ===============
+      END DO                                                      ! end tracer loop
+      !                                                           ! ===============
+   END SUBROUTINE tra_ldf_triad
+
+   !!==============================================================================
+END MODULE traldf_triad
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/TRA/tramle.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/TRA/tramle.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/TRA/tramle.F90	(revision 9570)
@@ -0,0 +1,340 @@
+MODULE tramle
+   !!======================================================================
+   !!                    ***  MODULE  tramle  ***
+   !! Ocean tracers: Mixed Layer Eddy induced transport
+   !!======================================================================
+   !! History :  3.3  !  2010-08  (G. Madec)  Original code
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   tra_mle_trp   : update the effective transport with the Mixed Layer Eddy induced transport
+   !!   tra_mle_init  : initialisation of the Mixed Layer Eddy induced transport computation
+   !!----------------------------------------------------------------------
+   USE oce            ! ocean dynamics and tracers variables
+   USE dom_oce        ! ocean space and time domain variables
+   USE phycst         ! physical constant
+   USE zdfmxl         ! mixed layer depth
+   !
+   USE in_out_manager ! I/O manager
+   USE iom            ! IOM library
+   USE lib_mpp        ! MPP library
+   USE lbclnk         ! lateral boundary condition / mpp link
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   tra_mle_trp        ! routine called in traadv.F90
+   PUBLIC   tra_mle_init   ! routine called in traadv.F90
+
+   !                                    !!* namelist namtra_mle *
+   LOGICAL, PUBLIC ::   ln_mle           !: flag to activate the Mixed Layer Eddy (MLE) parameterisation
+   INTEGER         ::      nn_mle           ! MLE type: =0 standard Fox-Kemper ; =1 new formulation
+   INTEGER         ::      nn_mld_uv        ! space interpolation of MLD at u- & v-pts (0=min,1=averaged,2=max)
+   INTEGER         ::      nn_conv          ! =1 no MLE in case of convection ; =0 always MLE
+   REAL(wp)        ::      rn_ce            ! MLE coefficient
+   !                                        ! parameters used in nn_mle = 0 case
+   REAL(wp)        ::      rn_lf               ! typical scale of mixed layer front
+   REAL(wp)        ::      rn_time             ! time scale for mixing momentum across the mixed layer
+   !                                        ! parameters used in nn_mle = 1 case
+   REAL(wp)        ::      rn_lat              ! reference latitude for a 5 km scale of ML front
+   REAL(wp)        ::      rn_rho_c_mle        ! Density criterion for definition of MLD used by FK
+
+   REAL(wp) ::   r5_21 = 5.e0 / 21.e0   ! factor used in mle streamfunction computation
+   REAL(wp) ::   rb_c                   ! ML buoyancy criteria = g rho_c /rau0 where rho_c is defined in zdfmld
+   REAL(wp) ::   rc_f                   ! MLE coefficient (= rn_ce / (5 km * fo) ) in nn_mle=1 case
+
+   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   rfu, rfv   ! modified Coriolis parameter (f+tau) at u- & v-pts
+   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   r1_ft      ! inverse of the modified Coriolis parameter at t-pts
+
+   !! * Substitutions
+#  include "vectopt_loop_substitute.h90"
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 4.0 , NEMO Consortium (2015)
+   !! $Id$
+   !! Software governed by the CeCILL licence (modipsl/doc/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE tra_mle_trp( kt, kit000, pu, pv, pw, cdtype )
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE tra_mle_trp  ***
+      !!
+      !! ** Purpose :   Add to the transport the Mixed Layer Eddy induced transport
+      !!
+      !! ** Method  :   The 3 components of the Mixed Layer Eddy (MLE) induced
+      !!              transport are computed as follows :
+      !!                zu_mle = dk[ zpsi_uw ]
+      !!                zv_mle = dk[ zpsi_vw ]
+      !!                zw_mle = - di[ zpsi_uw ] - dj[ zpsi_vw ]
+      !!                where zpsi is the MLE streamfunction at uw and vw points (see the doc)
+      !!              and added to the input velocity :
+      !!                p.n = p.n + z._mle
+      !!
+      !! ** Action  : - (pun,pvn,pwn) increased by the mle transport
+      !!                CAUTION, the transport is not updated at the last line/raw
+      !!                         this may be a problem for some advection schemes
+      !!
+      !! References: Fox-Kemper et al., JPO, 38, 1145-1165, 2008
+      !!             Fox-Kemper and Ferrari, JPO, 38, 1166-1179, 2008
+      !!----------------------------------------------------------------------
+      INTEGER                         , INTENT(in   ) ::   kt         ! ocean time-step index
+      INTEGER                         , INTENT(in   ) ::   kit000     ! first time step index
+      CHARACTER(len=3)                , INTENT(in   ) ::   cdtype     ! =TRA or TRC (tracer indicator)
+      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pu         ! in : 3 ocean transport components
+      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pv         ! out: same 3  transport components
+      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pw         !   increased by the MLE induced transport
+      !
+      INTEGER  ::   ji, jj, jk          ! dummy loop indices
+      INTEGER  ::   ii, ij, ik, ikmax   ! local integers
+      REAL(wp) ::   zcuw, zmuw, zc      ! local scalar
+      REAL(wp) ::   zcvw, zmvw          !   -      -
+      INTEGER , DIMENSION(jpi,jpj)     :: inml_mle
+      REAL(wp), DIMENSION(jpi,jpj)     :: zpsim_u, zpsim_v, zmld, zbm, zhu, zhv, zn2, zLf_NH, zLf_MH
+      REAL(wp), DIMENSION(jpi,jpj,jpk) :: zpsi_uw, zpsi_vw
+      !!----------------------------------------------------------------------
+      !
+      !                                      !==  MLD used for MLE  ==!
+      !                                                ! compute from the 10m density to deal with the diurnal cycle
+      inml_mle(:,:) = mbkt(:,:) + 1                    ! init. to number of ocean w-level (T-level + 1)
+      DO jk = jpkm1, nlb10, -1                         ! from the bottom to nlb10 (10m)
+         DO jj = 1, jpj
+            DO ji = 1, jpi                             ! index of the w-level at the ML based
+               IF( rhop(ji,jj,jk) > rhop(ji,jj,nla10) + rn_rho_c_mle )   inml_mle(ji,jj) = jk      ! Mixed layer
+            END DO
+         END DO
+      END DO
+      ikmax = MIN( MAXVAL( inml_mle(:,:) ), jpkm1 )                  ! max level of the computation
+      !
+      !
+      zmld(:,:) = 0._wp                      !==   Horizontal shape of the MLE  ==!
+      zbm (:,:) = 0._wp
+      zn2 (:,:) = 0._wp
+      DO jk = 1, ikmax                                 ! MLD and mean buoyancy and N2 over the mixed layer
+         DO jj = 1, jpj
+            DO ji = 1, jpi
+               zc = e3t_n(ji,jj,jk) * REAL( MIN( MAX( 0, inml_mle(ji,jj)-jk ) , 1  )  )    ! zc being 0 outside the ML t-points
+               zmld(ji,jj) = zmld(ji,jj) + zc
+               zbm (ji,jj) = zbm (ji,jj) + zc * (rau0 - rhop(ji,jj,jk) ) * r1_rau0
+               zn2 (ji,jj) = zn2 (ji,jj) + zc * (rn2(ji,jj,jk)+rn2(ji,jj,jk+1))*0.5_wp
+            END DO
+         END DO
+      END DO
+
+      SELECT CASE( nn_mld_uv )                         ! MLD at u- & v-pts
+      CASE ( 0 )                                               != min of the 2 neighbour MLDs
+         DO jj = 1, jpjm1
+            DO ji = 1, fs_jpim1   ! vector opt.
+               zhu(ji,jj) = MIN( zmld(ji+1,jj), zmld(ji,jj) )
+               zhv(ji,jj) = MIN( zmld(ji,jj+1), zmld(ji,jj) )
+            END DO
+         END DO
+      CASE ( 1 )                                               != average of the 2 neighbour MLDs
+         DO jj = 1, jpjm1
+            DO ji = 1, fs_jpim1   ! vector opt.
+               zhu(ji,jj) = ( zmld(ji+1,jj) + zmld(ji,jj) ) * 0.5_wp
+               zhv(ji,jj) = ( zmld(ji,jj+1) + zmld(ji,jj) ) * 0.5_wp
+            END DO
+         END DO
+      CASE ( 2 )                                               != max of the 2 neighbour MLDs
+         DO jj = 1, jpjm1
+            DO ji = 1, fs_jpim1   ! vector opt.
+               zhu(ji,jj) = MAX( zmld(ji+1,jj), zmld(ji,jj) )
+               zhv(ji,jj) = MAX( zmld(ji,jj+1), zmld(ji,jj) )
+            END DO
+         END DO
+      END SELECT
+      !                                                ! convert density into buoyancy
+      zbm(:,:) = + grav * zbm(:,:) / MAX( e3t_n(:,:,1), zmld(:,:) )
+      !
+      !
+      !                                      !==  Magnitude of the MLE stream function  ==!
+      !
+      !                 di[bm]  Ds
+      ! Psi = Ce  H^2 ---------------- e2u  mu(z)   where fu Lf = MAX( fu*rn_fl , (Db H)^1/2 )
+      !                  e1u   Lf fu                      and the e2u for the "transport"
+      !                                                      (not *e3u as divided by e3u at the end)
+      !
+      IF( nn_mle == 0 ) THEN           ! Fox-Kemper et al. 2010 formulation
+         DO jj = 1, jpjm1
+            DO ji = 1, fs_jpim1   ! vector opt.
+               zpsim_u(ji,jj) = rn_ce * zhu(ji,jj) * zhu(ji,jj)  * e2_e1u(ji,jj)                                            &
+                  &           * ( zbm(ji+1,jj) - zbm(ji,jj) ) * MIN( 111.e3_wp , e1u(ji,jj) )   &
+                  &           / (  MAX( rn_lf * rfu(ji,jj) , SQRT( rb_c * zhu(ji,jj) ) )   )
+                  !
+               zpsim_v(ji,jj) = rn_ce * zhv(ji,jj) * zhv(ji,jj)  * e1_e2v(ji,jj)                                            &
+                  &           * ( zbm(ji,jj+1) - zbm(ji,jj) ) * MIN( 111.e3_wp , e2v(ji,jj) )   &
+                  &           / (  MAX( rn_lf * rfv(ji,jj) , SQRT( rb_c * zhv(ji,jj) ) )   )
+            END DO
+         END DO
+         !
+      ELSEIF( nn_mle == 1 ) THEN       ! New formulation (Lf = 5km fo/ff with fo=Coriolis parameter at latitude rn_lat)
+         DO jj = 1, jpjm1
+            DO ji = 1, fs_jpim1   ! vector opt.
+               zpsim_u(ji,jj) = rc_f *   zhu(ji,jj)   * zhu(ji,jj)   * e2_e1u(ji,jj)               &
+                  &                  * ( zbm(ji+1,jj) - zbm(ji,jj) ) * MIN( 111.e3_wp , e1u(ji,jj) )
+                  !
+               zpsim_v(ji,jj) = rc_f *   zhv(ji,jj)   * zhv(ji,jj)   * e1_e2v(ji,jj)               &
+                  &                  * ( zbm(ji,jj+1) - zbm(ji,jj) ) * MIN( 111.e3_wp , e2v(ji,jj) )
+            END DO
+         END DO
+      ENDIF
+      !
+      IF( nn_conv == 1 ) THEN              ! No MLE in case of convection
+         DO jj = 1, jpjm1
+            DO ji = 1, fs_jpim1   ! vector opt.
+               IF( MIN( zn2(ji,jj) , zn2(ji+1,jj) ) < 0._wp )   zpsim_u(ji,jj) = 0._wp
+               IF( MIN( zn2(ji,jj) , zn2(ji,jj+1) ) < 0._wp )   zpsim_v(ji,jj) = 0._wp
+            END DO
+         END DO
+      ENDIF
+      !
+      !                                      !==  structure function value at uw- and vw-points  ==!
+      DO jj = 1, jpjm1
+         DO ji = 1, fs_jpim1   ! vector opt.
+            zhu(ji,jj) = 1._wp / zhu(ji,jj)                   ! hu --> 1/hu
+            zhv(ji,jj) = 1._wp / zhv(ji,jj)
+         END DO
+      END DO
+      !
+      zpsi_uw(:,:,:) = 0._wp
+      zpsi_vw(:,:,:) = 0._wp
+      !
+      DO jk = 2, ikmax                                ! start from 2 : surface value = 0
+         DO jj = 1, jpjm1
+            DO ji = 1, fs_jpim1   ! vector opt.
+               zcuw = 1._wp - ( gdepw_n(ji+1,jj,jk) + gdepw_n(ji,jj,jk) ) * zhu(ji,jj)
+               zcvw = 1._wp - ( gdepw_n(ji,jj+1,jk) + gdepw_n(ji,jj,jk) ) * zhv(ji,jj)
+               zcuw = zcuw * zcuw
+               zcvw = zcvw * zcvw
+               zmuw = MAX(  0._wp , ( 1._wp - zcuw ) * ( 1._wp + r5_21 * zcuw )  )
+               zmvw = MAX(  0._wp , ( 1._wp - zcvw ) * ( 1._wp + r5_21 * zcvw )  )
+               !
+               zpsi_uw(ji,jj,jk) = zpsim_u(ji,jj) * zmuw * umask(ji,jj,jk)
+               zpsi_vw(ji,jj,jk) = zpsim_v(ji,jj) * zmvw * vmask(ji,jj,jk)
+            END DO
+         END DO
+      END DO
+      !
+      !                                      !==  transport increased by the MLE induced transport ==!
+      DO jk = 1, ikmax
+         DO jj = 1, jpjm1                          ! CAUTION pu,pv must be defined at row/column i=1 / j=1
+            DO ji = 1, fs_jpim1   ! vector opt.
+               pu(ji,jj,jk) = pu(ji,jj,jk) + ( zpsi_uw(ji,jj,jk) - zpsi_uw(ji,jj,jk+1) )
+               pv(ji,jj,jk) = pv(ji,jj,jk) + ( zpsi_vw(ji,jj,jk) - zpsi_vw(ji,jj,jk+1) )
+            END DO
+         END DO
+         DO jj = 2, jpjm1
+            DO ji = fs_2, fs_jpim1   ! vector opt.
+               pw(ji,jj,jk) = pw(ji,jj,jk) - ( zpsi_uw(ji,jj,jk) - zpsi_uw(ji-1,jj,jk)   &
+                  &                          + zpsi_vw(ji,jj,jk) - zpsi_vw(ji,jj-1,jk) )
+            END DO
+         END DO
+      END DO
+
+      IF( cdtype == 'TRA') THEN              !==  outputs  ==!
+         !
+         zLf_NH(:,:) = SQRT( rb_c * zmld(:,:) ) * r1_ft(:,:)      ! Lf = N H / f
+         CALL iom_put( "Lf_NHpf" , zLf_NH  )    ! Lf = N H / f
+         !
+         ! divide by cross distance to give streamfunction with dimensions m^2/s
+         DO jk = 1, ikmax+1
+            zpsi_uw(:,:,jk) = zpsi_uw(:,:,jk) * r1_e2u(:,:)
+            zpsi_vw(:,:,jk) = zpsi_vw(:,:,jk) * r1_e1v(:,:)
+         END DO
+         CALL iom_put( "psiu_mle", zpsi_uw )    ! i-mle streamfunction
+         CALL iom_put( "psiv_mle", zpsi_vw )    ! j-mle streamfunction
+      ENDIF
+      !
+   END SUBROUTINE tra_mle_trp
+
+
+   SUBROUTINE tra_mle_init
+      !!---------------------------------------------------------------------
+      !!                  ***  ROUTINE tra_mle_init  ***
+      !!
+      !! ** Purpose :   Control the consistency between namelist options for
+      !!              tracer advection schemes and set nadv
+      !!----------------------------------------------------------------------
+      INTEGER  ::   ji, jj, jk   ! dummy loop indices
+      INTEGER  ::   ierr
+      INTEGER ::    ios                 ! Local integer output status for namelist read
+      REAL(wp) ::   z1_t2, zfu, zfv                                !    -         -
+      !
+      NAMELIST/namtra_mle/ ln_mle , nn_mle, rn_ce, rn_lf, rn_time, rn_lat, nn_mld_uv, nn_conv, rn_rho_c_mle
+      !!----------------------------------------------------------------------
+
+      REWIND( numnam_ref )              ! Namelist namtra_mle in reference namelist : Tracer advection scheme
+      READ  ( numnam_ref, namtra_mle, IOSTAT = ios, ERR = 901)
+901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namtra_mle in reference namelist', lwp )
+
+      REWIND( numnam_cfg )              ! Namelist namtra_mle in configuration namelist : Tracer advection scheme
+      READ  ( numnam_cfg, namtra_mle, IOSTAT = ios, ERR = 902 )
+902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namtra_mle in configuration namelist', lwp )
+      IF(lwm) WRITE ( numond, namtra_mle )
+
+      IF(lwp) THEN                     ! Namelist print
+         WRITE(numout,*)
+         WRITE(numout,*) 'tra_mle_init : mixed layer eddy (MLE) advection acting on tracers'
+         WRITE(numout,*) '~~~~~~~~~~~~~'
+         WRITE(numout,*) '   Namelist namtra_mle : mixed layer eddy advection applied on tracers'
+         WRITE(numout,*) '      use mixed layer eddy (MLE, i.e. Fox-Kemper param) (T/F)      ln_mle       = ', ln_mle
+         WRITE(numout,*) '         MLE type: =0 standard Fox-Kemper ; =1 new formulation        nn_mle    = ', nn_mle
+         WRITE(numout,*) '         magnitude of the MLE (typical value: 0.06 to 0.08)           rn_ce     = ', rn_ce
+         WRITE(numout,*) '         scale of ML front (ML radius of deformation) (rn_mle=0)      rn_lf     = ', rn_lf, 'm'
+         WRITE(numout,*) '         maximum time scale of MLE                    (rn_mle=0)      rn_time   = ', rn_time, 's'
+         WRITE(numout,*) '         reference latitude (degrees) of MLE coef.    (rn_mle=1)      rn_lat    = ', rn_lat, 'deg'
+         WRITE(numout,*) '         space interp. of MLD at u-(v-)pts (0=min,1=averaged,2=max)   nn_mld_uv = ', nn_mld_uv
+         WRITE(numout,*) '         =1 no MLE in case of convection ; =0 always MLE              nn_conv   = ', nn_conv
+         WRITE(numout,*) '         Density difference used to define ML for FK              rn_rho_c_mle  = ', rn_rho_c_mle
+      ENDIF
+      !
+      IF(lwp) THEN
+         WRITE(numout,*)
+         IF( ln_mle ) THEN
+            WRITE(numout,*) '   ==>>>   Mixed Layer Eddy induced transport added to tracer advection'
+            IF( nn_mle == 0 )   WRITE(numout,*) '              Fox-Kemper et al 2010 formulation'
+            IF( nn_mle == 1 )   WRITE(numout,*) '              New formulation'
+         ELSE
+            WRITE(numout,*) '   ==>>>   Mixed Layer Eddy parametrisation NOT used'
+         ENDIF
+      ENDIF
+      !
+      IF( ln_mle ) THEN                ! MLE initialisation
+         !
+         rb_c = grav * rn_rho_c_mle /rau0        ! Mixed Layer buoyancy criteria
+         IF(lwp) WRITE(numout,*)
+         IF(lwp) WRITE(numout,*) '      ML buoyancy criteria = ', rb_c, ' m/s2 '
+         IF(lwp) WRITE(numout,*) '      associated ML density criteria defined in zdfmxl = ', rho_c, 'kg/m3'
+         !
+         IF( nn_mle == 0 ) THEN           ! MLE array allocation & initialisation
+            ALLOCATE( rfu(jpi,jpj) , rfv(jpi,jpj) , STAT= ierr )
+            IF( ierr /= 0 )   CALL ctl_stop( 'tra_adv_mle_init: failed to allocate arrays' )
+            z1_t2 = 1._wp / ( rn_time * rn_time )
+            DO jj = 2, jpj                           ! "coriolis+ time^-1" at u- & v-points
+               DO ji = fs_2, jpi   ! vector opt.
+                  zfu = ( ff_f(ji,jj) + ff_f(ji,jj-1) ) * 0.5_wp
+                  zfv = ( ff_f(ji,jj) + ff_f(ji-1,jj) ) * 0.5_wp
+                  rfu(ji,jj) = SQRT(  zfu * zfu + z1_t2 )
+                  rfv(ji,jj) = SQRT(  zfv * zfv + z1_t2 )
+               END DO
+            END DO
+            CALL lbc_lnk_multi( rfu, 'U', 1. , rfv, 'V', 1. )
+            !
+         ELSEIF( nn_mle == 1 ) THEN           ! MLE array allocation & initialisation
+            rc_f = rn_ce / (  5.e3_wp * 2._wp * omega * SIN( rad * rn_lat )  )
+            !
+         ENDIF
+         !
+         !                                ! 1/(f^2+tau^2)^1/2 at t-point (needed in both nn_mle case)
+         ALLOCATE( r1_ft(jpi,jpj) , STAT= ierr )
+         IF( ierr /= 0 )   CALL ctl_stop( 'tra_adv_mle_init: failed to allocate r1_ft array' )
+         !
+         z1_t2 = 1._wp / ( rn_time * rn_time )
+         r1_ft(:,:) = 1._wp / SQRT(  ff_t(:,:) * ff_t(:,:) + z1_t2  )
+         !
+      ENDIF
+      !
+   END SUBROUTINE tra_mle_init
+
+   !!==============================================================================
+END MODULE tramle
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/TRA/tranpc.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/TRA/tranpc.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/TRA/tranpc.F90	(revision 9570)
@@ -0,0 +1,325 @@
+MODULE tranpc
+   !!==============================================================================
+   !!                       ***  MODULE  tranpc  ***
+   !! Ocean active tracers:  non penetrative convective adjustment scheme
+   !!==============================================================================
+   !! History :  1.0  ! 1990-09  (G. Madec)  Original code
+   !!                 ! 1996-01  (G. Madec)  statement function for e3
+   !!   NEMO     1.0  ! 2002-06  (G. Madec)  free form F90
+   !!            3.0  ! 2008-06  (G. Madec)  applied on ta, sa and called before tranxt in step.F90
+   !!            3.3  ! 2010-05  (C. Ethe, G. Madec)  merge TRC-TRA
+   !!            3.6  ! 2015-05  (L. Brodeau) new algorithm based on local Brunt-Vaisala freq.
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   tra_npc       : apply the non penetrative convection scheme
+   !!----------------------------------------------------------------------
+   USE oce            ! ocean dynamics and active tracers
+   USE dom_oce        ! ocean space and time domain
+   USE phycst         ! physical constants
+   USE zdf_oce        ! ocean vertical physics
+   USE trd_oce        ! ocean active tracer trends
+   USE trdtra         ! ocean active tracer trends
+   USE eosbn2         ! equation of state (eos routine)
+   !
+   USE lbclnk         ! lateral boundary conditions (or mpp link)
+   USE in_out_manager ! I/O manager
+   USE lib_mpp        ! MPP library
+   USE timing         ! Timing
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   tra_npc    ! routine called by step.F90
+
+   !! * Substitutions
+#  include "vectopt_loop_substitute.h90"
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.6 , NEMO Consortium (2014)
+   !! $Id$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE tra_npc( kt )
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE tranpc  ***
+      !!
+      !! ** Purpose : Non-penetrative convective adjustment scheme. solve
+      !!      the static instability of the water column on after fields
+      !!      while conserving heat and salt contents.
+      !!
+      !! ** Method  : updated algorithm able to deal with non-linear equation of state
+      !!              (i.e. static stability computed locally)
+      !!
+      !! ** Action  : - tsa: after tracers with the application of the npc scheme
+      !!              - send the associated trends for on-line diagnostics (l_trdtra=T)
+      !!
+      !! References :     Madec, et al., 1991, JPO, 21, 9, 1349-1371.
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT(in) ::   kt   ! ocean time-step index
+      !
+      INTEGER  ::   ji, jj, jk   ! dummy loop indices
+      INTEGER  ::   inpcc        ! number of statically instable water column
+      INTEGER  ::   jiter, ikbot, ikp, ikup, ikdown, ilayer, ik_low   ! local integers
+      LOGICAL  ::   l_bottom_reached, l_column_treated
+      REAL(wp) ::   zta, zalfa, zsum_temp, zsum_alfa, zaw, zdz, zsum_z
+      REAL(wp) ::   zsa, zbeta, zsum_sali, zsum_beta, zbw, zrw, z1_r2dt
+      REAL(wp), PARAMETER ::   zn2_zero = 1.e-14_wp      ! acceptance criteria for neutrality (N2==0)
+      REAL(wp), DIMENSION(        jpk     ) ::   zvn2         ! vertical profile of N2 at 1 given point...
+      REAL(wp), DIMENSION(        jpk,jpts) ::   zvts, zvab   ! vertical profile of T & S , and  alpha & betaat 1 given point
+      REAL(wp), DIMENSION(jpi,jpj,jpk     ) ::   zn2          ! N^2 
+      REAL(wp), DIMENSION(jpi,jpj,jpk,jpts) ::   zab          ! alpha and beta
+      REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) ::   ztrdt, ztrds   ! 3D workspace
+      !
+      LOGICAL, PARAMETER :: l_LB_debug = .FALSE. ! set to true if you want to follow what is
+      INTEGER :: ilc1, jlc1, klc1, nncpu         ! actually happening in a water column at point "ilc1, jlc1"
+      LOGICAL :: lp_monitor_point = .FALSE.      ! in CPU domain "nncpu"
+      !!----------------------------------------------------------------------
+      !
+      IF( ln_timing )   CALL timing_start('tra_npc')
+      !
+      IF( MOD( kt, nn_npc ) == 0 ) THEN
+         !
+         IF( l_trdtra )   THEN                    !* Save initial after fields
+            ALLOCATE( ztrdt(jpi,jpj,jpk) , ztrds(jpi,jpj,jpk) )
+            ztrdt(:,:,:) = tsa(:,:,:,jp_tem) 
+            ztrds(:,:,:) = tsa(:,:,:,jp_sal)
+         ENDIF
+         !
+         IF( l_LB_debug ) THEN
+            ! Location of 1 known convection site to follow what's happening in the water column
+            ilc1 = 45 ;  jlc1 = 3 ; !  ORCA2 4x4, Antarctic coast, more than 2 unstable portions in the  water column...           
+            nncpu = 1  ;            ! the CPU domain contains the convection spot
+            klc1 =  mbkt(ilc1,jlc1) ! bottom of the ocean for debug point...          
+         ENDIF
+         !
+         CALL eos_rab( tsa, zab )         ! after alpha and beta (given on T-points)
+         CALL bn2    ( tsa, zab, zn2 )    ! after Brunt-Vaisala  (given on W-points)
+         !
+         inpcc = 0
+         !
+         DO jj = 2, jpjm1                 ! interior column only
+            DO ji = fs_2, fs_jpim1
+               !
+               IF( tmask(ji,jj,2) == 1 ) THEN      ! At least 2 ocean points
+                  !                                     ! consider one ocean column 
+                  zvts(:,jp_tem) = tsa(ji,jj,:,jp_tem)      ! temperature
+                  zvts(:,jp_sal) = tsa(ji,jj,:,jp_sal)      ! salinity
+                  !
+                  zvab(:,jp_tem)  = zab(ji,jj,:,jp_tem)     ! Alpha 
+                  zvab(:,jp_sal)  = zab(ji,jj,:,jp_sal)     ! Beta  
+                  zvn2(:)         = zn2(ji,jj,:)            ! N^2 
+                  !
+                  IF( l_LB_debug ) THEN                  !LB debug:
+                     lp_monitor_point = .FALSE.
+                     IF( ( ji == ilc1 ).AND.( jj == jlc1 ) ) lp_monitor_point = .TRUE.
+                     ! writing only if on CPU domain where conv region is:
+                     lp_monitor_point = (narea == nncpu).AND.lp_monitor_point                      
+                  ENDIF                                  !LB debug  end
+                  !
+                  ikbot = mbkt(ji,jj)   ! ikbot: ocean bottom T-level
+                  ikp = 1                  ! because N2 is irrelevant at the surface level (will start at ikp=2)
+                  ilayer = 0
+                  jiter  = 0
+                  l_column_treated = .FALSE.
+                  !
+                  DO WHILE ( .NOT. l_column_treated )
+                     !
+                     jiter = jiter + 1
+                     ! 
+                     IF( jiter >= 400 ) EXIT
+                     !
+                     l_bottom_reached = .FALSE.
+                     !
+                     DO WHILE ( .NOT. l_bottom_reached )
+                        !
+                        ikp = ikp + 1
+                        !
+                        !! Testing level ikp for instability
+                        !! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+                        IF( zvn2(ikp) <  -zn2_zero ) THEN ! Instability found!
+                           !
+                           ilayer = ilayer + 1    ! yet another instable portion of the water column found....
+                           !
+                           IF( lp_monitor_point ) THEN 
+                              WRITE(numout,*)
+                              IF( ilayer == 1 .AND. jiter == 1 ) THEN   ! first time a column is spoted with an instability
+                                 WRITE(numout,*)
+                                 WRITE(numout,*) 'Time step = ',kt,' !!!'
+                              ENDIF
+                              WRITE(numout,*)  ' * Iteration #',jiter,': found instable portion #',ilayer,   &
+                                 &                                    ' in column! Starting at ikp =', ikp
+                              WRITE(numout,*)  ' *** N2 for point (i,j) = ',ji,' , ',jj
+                              DO jk = 1, klc1
+                                 WRITE(numout,*) jk, zvn2(jk)
+                              END DO
+                              WRITE(numout,*)
+                           ENDIF
+                           !
+                           IF( jiter == 1 )   inpcc = inpcc + 1 
+                           !
+                           IF( lp_monitor_point )   WRITE(numout, *) 'Negative N2 at ikp =',ikp,' for layer #', ilayer
+                           !
+                           !! ikup is the uppermost point where mixing will start:
+                           ikup = ikp - 1 ! ikup is always "at most at ikp-1", less if neutral levels overlying
+                           !
+                           !! If the points above ikp-1 have N2 == 0 they must also be mixed:
+                           IF( ikp > 2 ) THEN
+                              DO jk = ikp-1, 2, -1
+                                 IF( ABS(zvn2(jk)) < zn2_zero ) THEN
+                                    ikup = ikup - 1  ! 1 more upper level has N2=0 and must be added for the mixing
+                                 ELSE
+                                    EXIT
+                                 ENDIF
+                              END DO
+                           ENDIF
+                           !
+                           IF( ikup < 1 )   CALL ctl_stop( 'tra_npc :  PROBLEM #1')
+                           !
+                           zsum_temp = 0._wp
+                           zsum_sali = 0._wp
+                           zsum_alfa = 0._wp
+                           zsum_beta = 0._wp
+                           zsum_z    = 0._wp
+                                                    
+                           DO jk = ikup, ikbot      ! Inside the instable (and overlying neutral) portion of the column
+                              !
+                              zdz       = e3t_n(ji,jj,jk)
+                              zsum_temp = zsum_temp + zvts(jk,jp_tem)*zdz
+                              zsum_sali = zsum_sali + zvts(jk,jp_sal)*zdz
+                              zsum_alfa = zsum_alfa + zvab(jk,jp_tem)*zdz
+                              zsum_beta = zsum_beta + zvab(jk,jp_sal)*zdz
+                              zsum_z    = zsum_z    + zdz
+                              !                              
+                              IF( jk == ikbot ) EXIT ! avoid array-index overshoot in case ikbot = jpk, cause we're calling jk+1 next line
+                              !! EXIT when we have reached the last layer that is instable (N2<0) or neutral (N2=0):
+                              IF( zvn2(jk+1) > zn2_zero ) EXIT
+                           END DO
+                          
+                           ikdown = jk ! for the current unstable layer, ikdown is the deepest point with a negative or neutral N2
+                           IF( ikup == ikdown )   CALL ctl_stop( 'tra_npc :  PROBLEM #2')
+
+                           ! Mixing Temperature, salinity, alpha and beta from ikup to ikdown included:
+                           zta   = zsum_temp/zsum_z
+                           zsa   = zsum_sali/zsum_z
+                           zalfa = zsum_alfa/zsum_z
+                           zbeta = zsum_beta/zsum_z
+
+                           IF( lp_monitor_point ) THEN
+                              WRITE(numout,*) 'MIXED T, S, alfa and beta between ikup =',ikup,   &
+                                 &            ' and ikdown =',ikdown,', in layer #',ilayer
+                              WRITE(numout,*) '  => Mean temp. in that portion =', zta
+                              WRITE(numout,*) '  => Mean sali. in that portion =', zsa
+                              WRITE(numout,*) '  => Mean Alfa  in that portion =', zalfa
+                              WRITE(numout,*) '  => Mean Beta  in that portion =', zbeta
+                           ENDIF
+
+                           !! Homogenaizing the temperature, salinity, alpha and beta in this portion of the column
+                           DO jk = ikup, ikdown
+                              zvts(jk,jp_tem) = zta
+                              zvts(jk,jp_sal) = zsa
+                              zvab(jk,jp_tem) = zalfa
+                              zvab(jk,jp_sal) = zbeta
+                           END DO
+                           
+                           
+                           !! Updating N2 in the relvant portion of the water column
+                           !! Temperature, Salinity, Alpha and Beta have been homogenized in the unstable portion
+                           !! => Need to re-compute N2! will use Alpha and Beta!
+                           
+                           ikup   = MAX(2,ikup)         ! ikup can never be 1 !
+                           ik_low = MIN(ikdown+1,ikbot) ! we must go 1 point deeper than ikdown!
+                           
+                           DO jk = ikup, ik_low              ! we must go 1 point deeper than ikdown!
+
+                              !! Interpolating alfa and beta at W point:
+                              zrw =  (gdepw_n(ji,jj,jk  ) - gdept_n(ji,jj,jk)) &
+                                 & / (gdept_n(ji,jj,jk-1) - gdept_n(ji,jj,jk))
+                              zaw = zvab(jk,jp_tem) * (1._wp - zrw) + zvab(jk-1,jp_tem) * zrw
+                              zbw = zvab(jk,jp_sal) * (1._wp - zrw) + zvab(jk-1,jp_sal) * zrw
+
+                              !! N2 at W point, doing exactly as in eosbn2.F90:
+                              zvn2(jk) = grav*( zaw * ( zvts(jk-1,jp_tem) - zvts(jk,jp_tem) )     &
+                                 &            - zbw * ( zvts(jk-1,jp_sal) - zvts(jk,jp_sal) )  )  &
+                                 &       / e3w_n(ji,jj,jk) * tmask(ji,jj,jk)
+
+                              !! OR, faster  => just considering the vertical gradient of density
+                              !! as only the signa maters...
+                              !zvn2(jk) = (  zaw * ( zvts(jk-1,jp_tem) - zvts(jk,jp_tem) )     &
+                              !     &      - zbw * ( zvts(jk-1,jp_sal) - zvts(jk,jp_sal) )  )
+
+                           END DO
+                        
+                           ikp = MIN(ikdown+1,ikbot)
+                           
+
+                        ENDIF  !IF( zvn2(ikp) < 0. )
+
+
+                        IF( ikp == ikbot ) l_bottom_reached = .TRUE.
+                        !
+                     END DO ! DO WHILE ( .NOT. l_bottom_reached )
+
+                     IF( ikp /= ikbot )   CALL ctl_stop( 'tra_npc :  PROBLEM #3')
+                    
+                     ! ******* At this stage ikp == ikbot ! *******
+                    
+                     IF( ilayer > 0 ) THEN      !! least an unstable layer has been found
+                        !
+                        IF( lp_monitor_point ) THEN
+                           WRITE(numout,*)
+                           WRITE(numout,*) 'After ',jiter,' iteration(s), we neutralized ',ilayer,' instable layer(s)'
+                           WRITE(numout,*) '   ==> N2 at i,j=',ji,',',jj,' now looks like this:'
+                           DO jk = 1, klc1
+                              WRITE(numout,*) jk, zvn2(jk)
+                           END DO
+                           WRITE(numout,*)
+                        ENDIF
+                        !
+                        ikp    = 1     ! starting again at the surface for the next iteration
+                        ilayer = 0
+                     ENDIF
+                     !
+                     IF( ikp >= ikbot )   l_column_treated = .TRUE.
+                     !
+                  END DO ! DO WHILE ( .NOT. l_column_treated )
+
+                  !! Updating tsa:
+                  tsa(ji,jj,:,jp_tem) = zvts(:,jp_tem)
+                  tsa(ji,jj,:,jp_sal) = zvts(:,jp_sal)
+
+                  !! LB:  Potentially some other global variable beside theta and S can be treated here
+                  !!      like BGC tracers.
+
+                  IF( lp_monitor_point )   WRITE(numout,*)
+
+               ENDIF ! IF( tmask(ji,jj,3) == 1 ) THEN
+
+            END DO ! ji
+         END DO ! jj
+         !
+         IF( l_trdtra ) THEN         ! send the Non penetrative mixing trends for diagnostic
+            z1_r2dt = 1._wp / (2._wp * rdt)
+            ztrdt(:,:,:) = ( tsa(:,:,:,jp_tem) - ztrdt(:,:,:) ) * z1_r2dt
+            ztrds(:,:,:) = ( tsa(:,:,:,jp_sal) - ztrds(:,:,:) ) * z1_r2dt
+            CALL trd_tra( kt, 'TRA', jp_tem, jptra_npc, ztrdt )
+            CALL trd_tra( kt, 'TRA', jp_sal, jptra_npc, ztrds )
+            DEALLOCATE( ztrdt, ztrds )
+         ENDIF
+         !
+         CALL lbc_lnk_multi( tsa(:,:,:,jp_tem), 'T', 1., tsa(:,:,:,jp_sal), 'T', 1. )
+         !
+         IF( lwp .AND. l_LB_debug ) THEN
+            WRITE(numout,*) 'Exiting tra_npc , kt = ',kt,', => numb. of statically instable water-columns: ', inpcc
+            WRITE(numout,*)
+         ENDIF
+         !
+      ENDIF   ! IF( MOD( kt, nn_npc ) == 0 ) THEN
+      !
+      IF( ln_timing )   CALL timing_stop('tra_npc')
+      !
+   END SUBROUTINE tra_npc
+
+   !!======================================================================
+END MODULE tranpc
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/TRA/tranxt.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/TRA/tranxt.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/TRA/tranxt.F90	(revision 9570)
@@ -0,0 +1,383 @@
+MODULE tranxt
+   !!======================================================================
+   !!                       ***  MODULE  tranxt  ***
+   !! Ocean active tracers:  time stepping on temperature and salinity
+   !!======================================================================
+   !! History :  OPA  !  1991-11  (G. Madec)  Original code
+   !!            7.0  !  1993-03  (M. Guyon)  symetrical conditions
+   !!            8.0  !  1996-02  (G. Madec & M. Imbard)  opa release 8.0
+   !!             -   !  1996-04  (A. Weaver)  Euler forward step
+   !!            8.2  !  1999-02  (G. Madec, N. Grima)  semi-implicit pressure grad.
+   !!  NEMO      1.0  !  2002-08  (G. Madec)  F90: Free form and module
+   !!             -   !  2002-11  (C. Talandier, A-M Treguier) Open boundaries
+   !!             -   !  2005-04  (C. Deltel) Add Asselin trend in the ML budget
+   !!            2.0  !  2006-02  (L. Debreu, C. Mazauric) Agrif implementation
+   !!            3.0  !  2008-06  (G. Madec)  time stepping always done in trazdf
+   !!            3.1  !  2009-02  (G. Madec, R. Benshila)  re-introduce the vvl option
+   !!            3.3  !  2010-04  (M. Leclair, G. Madec)  semi-implicit hpg with asselin filter + modified LF-RA
+   !!             -   !  2010-05  (C. Ethe, G. Madec)  merge TRC-TRA
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   tra_nxt       : time stepping on tracers
+   !!   tra_nxt_fix   : time stepping on tracers : fixed    volume case
+   !!   tra_nxt_vvl   : time stepping on tracers : variable volume case
+   !!----------------------------------------------------------------------
+   USE oce             ! ocean dynamics and tracers variables
+   USE dom_oce         ! ocean space and time domain variables 
+   USE sbc_oce         ! surface boundary condition: ocean
+   USE sbcrnf          ! river runoffs
+   USE sbcisf          ! ice shelf melting
+   USE zdf_oce         ! ocean vertical mixing
+   USE domvvl          ! variable volume
+   USE trd_oce         ! trends: ocean variables
+   USE trdtra          ! trends manager: tracers 
+   USE traqsr          ! penetrative solar radiation (needed for nksr)
+   USE phycst          ! physical constant
+   USE ldftra          ! lateral physics : tracers
+   USE ldfslp          ! lateral physics : slopes
+   USE bdy_oce  , ONLY : ln_bdy
+   USE bdytra          ! open boundary condition (bdy_tra routine)
+   !
+   USE in_out_manager  ! I/O manager
+   USE lbclnk          ! ocean lateral boundary conditions (or mpp link)
+   USE prtctl          ! Print control
+   USE timing          ! Timing
+#if defined key_agrif
+   USE agrif_oce_interp
+#endif
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   tra_nxt       ! routine called by step.F90
+   PUBLIC   tra_nxt_fix   ! to be used in trcnxt
+   PUBLIC   tra_nxt_vvl   ! to be used in trcnxt
+
+   !! * Substitutions
+#  include "vectopt_loop_substitute.h90"
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO-Consortium (2010) 
+   !! $Id$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE tra_nxt( kt )
+      !!----------------------------------------------------------------------
+      !!                   ***  ROUTINE tranxt  ***
+      !!
+      !! ** Purpose :   Apply the boundary condition on the after temperature  
+      !!             and salinity fields, achieved the time stepping by adding
+      !!             the Asselin filter on now fields and swapping the fields.
+      !! 
+      !! ** Method  :   At this stage of the computation, ta and sa are the 
+      !!             after temperature and salinity as the time stepping has
+      !!             been performed in trazdf_imp or trazdf_exp module.
+      !!
+      !!              - Apply lateral boundary conditions on (ta,sa) 
+      !!             at the local domain   boundaries through lbc_lnk call, 
+      !!             at the one-way open boundaries (ln_bdy=T), 
+      !!             at the AGRIF zoom   boundaries (lk_agrif=T)
+      !!
+      !!              - Update lateral boundary conditions on AGRIF children
+      !!             domains (lk_agrif=T)
+      !!
+      !! ** Action  : - tsb & tsn ready for the next time step
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT(in) ::   kt    ! ocean time-step index
+      !!
+      INTEGER  ::   ji, jj, jk, jn   ! dummy loop indices
+      REAL(wp) ::   zfact            ! local scalars
+      REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) ::   ztrdt, ztrds
+      !!----------------------------------------------------------------------
+      !
+      IF( ln_timing )   CALL timing_start( 'tra_nxt')
+      !
+      IF( kt == nit000 ) THEN
+         IF(lwp) WRITE(numout,*)
+         IF(lwp) WRITE(numout,*) 'tra_nxt : achieve the time stepping by Asselin filter and array swap'
+         IF(lwp) WRITE(numout,*) '~~~~~~~'
+      ENDIF
+
+      ! Update after tracer on domain lateral boundaries
+      ! 
+#if defined key_agrif
+      CALL Agrif_tra                     ! AGRIF zoom boundaries
+#endif
+      !                                              ! local domain boundaries  (T-point, unchanged sign)
+      CALL lbc_lnk_multi( tsa(:,:,:,jp_tem), 'T', 1., tsa(:,:,:,jp_sal), 'T', 1. )
+      !
+      IF( ln_bdy )   CALL bdy_tra( kt )  ! BDY open boundaries
+ 
+      ! set time step size (Euler/Leapfrog)
+      IF( neuler == 0 .AND. kt == nit000 ) THEN   ;   r2dt =        rdt   ! at nit000             (Euler)
+      ELSEIF( kt <= nit000 + 1 )           THEN   ;   r2dt = 2._wp* rdt   ! at nit000 or nit000+1 (Leapfrog)
+      ENDIF
+
+      ! trends computation initialisation
+      IF( l_trdtra )   THEN                    
+         ALLOCATE( ztrdt(jpi,jpj,jpk) , ztrds(jpi,jpj,jpk) )
+         ztrdt(:,:,jpk) = 0._wp
+         ztrds(:,:,jpk) = 0._wp
+         IF( ln_traldf_iso ) THEN              ! diagnose the "pure" Kz diffusive trend 
+            CALL trd_tra( kt, 'TRA', jp_tem, jptra_zdfp, ztrdt )
+            CALL trd_tra( kt, 'TRA', jp_sal, jptra_zdfp, ztrds )
+         ENDIF
+         ! total trend for the non-time-filtered variables. 
+         zfact = 1.0 / rdt
+         ! G Nurser 23 Mar 2017. Recalculate trend as Delta(e3t*T)/e3tn; e3tn cancel from tsn terms
+         DO jk = 1, jpkm1
+            ztrdt(:,:,jk) = ( tsa(:,:,jk,jp_tem)*e3t_a(:,:,jk) / e3t_n(:,:,jk) - tsn(:,:,jk,jp_tem)) * zfact
+            ztrds(:,:,jk) = ( tsa(:,:,jk,jp_sal)*e3t_a(:,:,jk) / e3t_n(:,:,jk) - tsn(:,:,jk,jp_sal)) * zfact
+         END DO
+         CALL trd_tra( kt, 'TRA', jp_tem, jptra_tot, ztrdt )
+         CALL trd_tra( kt, 'TRA', jp_sal, jptra_tot, ztrds )
+         IF( ln_linssh ) THEN       ! linear sea surface height only
+            ! Store now fields before applying the Asselin filter 
+            ! in order to calculate Asselin filter trend later.
+            ztrdt(:,:,:) = tsn(:,:,:,jp_tem) 
+            ztrds(:,:,:) = tsn(:,:,:,jp_sal)
+         ENDIF
+      ENDIF
+
+      IF( neuler == 0 .AND. kt == nit000 ) THEN       ! Euler time-stepping at first time-step (only swap)
+         DO jn = 1, jpts
+            DO jk = 1, jpkm1
+               tsn(:,:,jk,jn) = tsa(:,:,jk,jn)    
+            END DO
+         END DO
+         IF (l_trdtra .AND. .NOT. ln_linssh ) THEN   ! Zero Asselin filter contribution must be explicitly written out since for vvl
+            !                                        ! Asselin filter is output by tra_nxt_vvl that is not called on this time step
+            ztrdt(:,:,:) = 0._wp
+            ztrds(:,:,:) = 0._wp
+            CALL trd_tra( kt, 'TRA', jp_tem, jptra_atf, ztrdt )
+            CALL trd_tra( kt, 'TRA', jp_sal, jptra_atf, ztrds )
+         END IF
+         !
+      ELSE                                            ! Leap-Frog + Asselin filter time stepping
+         !
+         IF( ln_linssh ) THEN   ;   CALL tra_nxt_fix( kt, nit000,      'TRA', tsb, tsn, tsa, jpts )  ! linear free surface 
+         ELSE                   ;   CALL tra_nxt_vvl( kt, nit000, rdt, 'TRA', tsb, tsn, tsa,   &
+           &                                                                sbc_tsc, sbc_tsc_b, jpts )  ! non-linear free surface
+         ENDIF
+         !
+         CALL lbc_lnk_multi( tsb(:,:,:,jp_tem), 'T', 1., tsb(:,:,:,jp_sal), 'T', 1., &
+                  &          tsn(:,:,:,jp_tem), 'T', 1., tsn(:,:,:,jp_sal), 'T', 1., &
+                  &          tsa(:,:,:,jp_tem), 'T', 1., tsa(:,:,:,jp_sal), 'T', 1.  )
+         !
+      ENDIF     
+      !
+      IF( l_trdtra .AND. ln_linssh ) THEN      ! trend of the Asselin filter (tb filtered - tb)/dt     
+         zfact = 1._wp / r2dt             
+         DO jk = 1, jpkm1
+            ztrdt(:,:,jk) = ( tsb(:,:,jk,jp_tem) - ztrdt(:,:,jk) ) * zfact
+            ztrds(:,:,jk) = ( tsb(:,:,jk,jp_sal) - ztrds(:,:,jk) ) * zfact
+         END DO
+         CALL trd_tra( kt, 'TRA', jp_tem, jptra_atf, ztrdt )
+         CALL trd_tra( kt, 'TRA', jp_sal, jptra_atf, ztrds )
+      END IF
+      IF( l_trdtra )   DEALLOCATE( ztrdt , ztrds )
+      !
+      !                        ! control print
+      IF(ln_ctl)   CALL prt_ctl( tab3d_1=tsn(:,:,:,jp_tem), clinfo1=' nxt  - Tn: ', mask1=tmask,   &
+         &                       tab3d_2=tsn(:,:,:,jp_sal), clinfo2=       ' Sn: ', mask2=tmask )
+      !
+      IF( ln_timing )   CALL timing_stop('tra_nxt')
+      !
+   END SUBROUTINE tra_nxt
+
+
+   SUBROUTINE tra_nxt_fix( kt, kit000, cdtype, ptb, ptn, pta, kjpt )
+      !!----------------------------------------------------------------------
+      !!                   ***  ROUTINE tra_nxt_fix  ***
+      !!
+      !! ** Purpose :   fixed volume: apply the Asselin time filter and 
+      !!                swap the tracer fields.
+      !! 
+      !! ** Method  : - Apply a Asselin time filter on now fields.
+      !!              - swap tracer fields to prepare the next time_step.
+      !!
+      !! ** Action  : - tsb & tsn ready for the next time step
+      !!----------------------------------------------------------------------
+      INTEGER                              , INTENT(in   ) ::  kt        ! ocean time-step index
+      INTEGER                              , INTENT(in   ) ::  kit000    ! first time step index
+      CHARACTER(len=3)                     , INTENT(in   ) ::  cdtype    ! =TRA or TRC (tracer indicator)
+      INTEGER                              , INTENT(in   ) ::  kjpt      ! number of tracers
+      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) ::  ptb       ! before tracer fields
+      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) ::  ptn       ! now tracer fields
+      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) ::  pta       ! tracer trend
+      !
+      INTEGER  ::   ji, jj, jk, jn   ! dummy loop indices
+      REAL(wp) ::   ztn, ztd         ! local scalars
+      !!----------------------------------------------------------------------
+      !
+      IF( kt == kit000 )  THEN
+         IF(lwp) WRITE(numout,*)
+         IF(lwp) WRITE(numout,*) 'tra_nxt_fix : time stepping', cdtype
+         IF(lwp) WRITE(numout,*) '~~~~~~~~~~~'
+      ENDIF
+      !
+      DO jn = 1, kjpt
+         !
+         DO jk = 1, jpkm1
+            DO jj = 2, jpjm1
+               DO ji = fs_2, fs_jpim1
+                  ztn = ptn(ji,jj,jk,jn)                                    
+                  ztd = pta(ji,jj,jk,jn) - 2._wp * ztn + ptb(ji,jj,jk,jn)  ! time laplacian on tracers
+                  !
+                  ptb(ji,jj,jk,jn) = ztn + atfp * ztd                      ! ptb <-- filtered ptn 
+                  ptn(ji,jj,jk,jn) = pta(ji,jj,jk,jn)                      ! ptn <-- pta
+               END DO
+           END DO
+         END DO
+         !
+      END DO
+      !
+   END SUBROUTINE tra_nxt_fix
+
+
+   SUBROUTINE tra_nxt_vvl( kt, kit000, p2dt, cdtype, ptb, ptn, pta, psbc_tc, psbc_tc_b, kjpt )
+      !!----------------------------------------------------------------------
+      !!                   ***  ROUTINE tra_nxt_vvl  ***
+      !!
+      !! ** Purpose :   Time varying volume: apply the Asselin time filter  
+      !!                and swap the tracer fields.
+      !! 
+      !! ** Method  : - Apply a thickness weighted Asselin time filter on now fields.
+      !!              - swap tracer fields to prepare the next time_step.
+      !!             tb  = ( e3t_n*tn + atfp*[ e3t_b*tb - 2 e3t_n*tn + e3t_a*ta ] )
+      !!                  /( e3t_n    + atfp*[ e3t_b    - 2 e3t_n    + e3t_a    ] )
+      !!             tn  = ta 
+      !!
+      !! ** Action  : - tsb & tsn ready for the next time step
+      !!----------------------------------------------------------------------
+      INTEGER                              , INTENT(in   ) ::  kt        ! ocean time-step index
+      INTEGER                              , INTENT(in   ) ::  kit000    ! first time step index
+      REAL(wp)                             , INTENT(in   ) ::  p2dt      ! time-step
+      CHARACTER(len=3)                     , INTENT(in   ) ::  cdtype    ! =TRA or TRC (tracer indicator)
+      INTEGER                              , INTENT(in   ) ::  kjpt      ! number of tracers
+      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) ::  ptb       ! before tracer fields
+      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) ::  ptn       ! now tracer fields
+      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) ::  pta       ! tracer trend
+      REAL(wp), DIMENSION(jpi,jpj    ,kjpt), INTENT(in   ) ::  psbc_tc   ! surface tracer content
+      REAL(wp), DIMENSION(jpi,jpj    ,kjpt), INTENT(in   ) ::  psbc_tc_b ! before surface tracer content
+      !
+      LOGICAL  ::   ll_traqsr, ll_rnf, ll_isf   ! local logical
+      INTEGER  ::   ji, jj, jk, jn              ! dummy loop indices
+      REAL(wp) ::   zfact, zfact1, ztc_a , ztc_n , ztc_b , ztc_f , ztc_d    ! local scalar
+      REAL(wp) ::   zfact2, ze3t_b, ze3t_n, ze3t_a, ze3t_f, ze3t_d   !   -      -
+      REAL(wp), ALLOCATABLE, DIMENSION(:,:,:,:) ::   ztrd_atf
+      !!----------------------------------------------------------------------
+      !
+      IF( kt == kit000 )  THEN
+         IF(lwp) WRITE(numout,*)
+         IF(lwp) WRITE(numout,*) 'tra_nxt_vvl : time stepping', cdtype
+         IF(lwp) WRITE(numout,*) '~~~~~~~~~~~'
+      ENDIF
+      !
+      IF( cdtype == 'TRA' )  THEN   
+         ll_traqsr  = ln_traqsr        ! active  tracers case  and  solar penetration
+         ll_rnf     = ln_rnf           ! active  tracers case  and  river runoffs
+         ll_isf     = ln_isf           ! active  tracers case  and  ice shelf melting
+      ELSE                          ! passive tracers case
+         ll_traqsr  = .FALSE.          ! NO solar penetration
+         ll_rnf     = .FALSE.          ! NO river runoffs ????          !!gm BUG ?  
+         ll_isf     = .FALSE.          ! NO ice shelf melting/freezing  !!gm BUG ?? 
+      ENDIF
+      !
+      IF( ( l_trdtra .AND. cdtype == 'TRA' ) .OR. ( l_trdtrc .AND. cdtype == 'TRC' ) )   THEN
+         ALLOCATE( ztrd_atf(jpi,jpj,jpk,kjpt) )
+         ztrd_atf(:,:,:,:) = 0.0_wp
+      ENDIF
+      zfact = 1._wp / r2dt
+      zfact1 = atfp * p2dt
+      zfact2 = zfact1 * r1_rau0
+      DO jn = 1, kjpt      
+         DO jk = 1, jpkm1
+            DO jj = 2, jpjm1
+               DO ji = fs_2, fs_jpim1
+                  ze3t_b = e3t_b(ji,jj,jk)
+                  ze3t_n = e3t_n(ji,jj,jk)
+                  ze3t_a = e3t_a(ji,jj,jk)
+                  !                                         ! tracer content at Before, now and after
+                  ztc_b  = ptb(ji,jj,jk,jn) * ze3t_b
+                  ztc_n  = ptn(ji,jj,jk,jn) * ze3t_n
+                  ztc_a  = pta(ji,jj,jk,jn) * ze3t_a
+                  !
+                  ze3t_d = ze3t_a - 2. * ze3t_n + ze3t_b
+                  ztc_d  = ztc_a  - 2. * ztc_n  + ztc_b
+                  !
+                  ze3t_f = ze3t_n + atfp * ze3t_d
+                  ztc_f  = ztc_n  + atfp * ztc_d
+                  !
+                  IF( jk == mikt(ji,jj) ) THEN           ! first level 
+                     ze3t_f = ze3t_f - zfact2 * ( (emp_b(ji,jj)    - emp(ji,jj)   )  &
+                            &                   + (fwfisf_b(ji,jj) - fwfisf(ji,jj))  )
+                     ztc_f  = ztc_f  - zfact1 * ( psbc_tc(ji,jj,jn) - psbc_tc_b(ji,jj,jn) )
+                  ENDIF
+                  IF( ln_rnf_depth ) THEN
+                     ! Rivers are not just at the surface must go down to nk_rnf(ji,jj)
+                     IF( mikt(ji,jj) <=jk .and. jk <= nk_rnf(ji,jj)  ) THEN
+                        ze3t_f = ze3t_f - zfact2 * ( - (rnf_b(ji,jj) - rnf(ji,jj)   )  ) &
+                    &                            * ( e3t_n(ji,jj,jk) / h_rnf(ji,jj) ) 
+                     ENDIF
+                  ELSE
+                     IF( jk == mikt(ji,jj) ) THEN           ! first level 
+                        ze3t_f = ze3t_f - zfact2 * ( - (rnf_b(ji,jj)    - rnf(ji,jj)   ) ) 
+                     ENDIF
+                  ENDIF
+
+                  !
+                  ! solar penetration (temperature only)
+                  IF( ll_traqsr .AND. jn == jp_tem .AND. jk <= nksr )                            & 
+                     &     ztc_f  = ztc_f  - zfact1 * ( qsr_hc(ji,jj,jk) - qsr_hc_b(ji,jj,jk) ) 
+                     !
+                  ! river runoff
+                  IF( ll_rnf .AND. jk <= nk_rnf(ji,jj) )                                          &
+                     &     ztc_f  = ztc_f  - zfact1 * ( rnf_tsc(ji,jj,jn) - rnf_tsc_b(ji,jj,jn) ) & 
+                     &                              * e3t_n(ji,jj,jk) / h_rnf(ji,jj)
+                     !
+                  ! ice shelf
+                  IF( ll_isf ) THEN
+                     ! level fully include in the Losch_2008 ice shelf boundary layer
+                     IF ( jk >= misfkt(ji,jj) .AND. jk < misfkb(ji,jj) )                          &
+                        ztc_f  = ztc_f  - zfact1 * ( risf_tsc(ji,jj,jn) - risf_tsc_b(ji,jj,jn) )  &
+                               &                 * e3t_n(ji,jj,jk) * r1_hisf_tbl (ji,jj)
+                     ! level partially include in Losch_2008 ice shelf boundary layer 
+                     IF ( jk == misfkb(ji,jj) )                                                   &
+                        ztc_f  = ztc_f  - zfact1 * ( risf_tsc(ji,jj,jn) - risf_tsc_b(ji,jj,jn) )  &
+                               &                 * e3t_n(ji,jj,jk) * r1_hisf_tbl (ji,jj) * ralpha(ji,jj)
+                  END IF
+                  !
+                  ze3t_f = 1.e0 / ze3t_f
+                  ptb(ji,jj,jk,jn) = ztc_f * ze3t_f       ! ptb <-- ptn filtered
+                  ptn(ji,jj,jk,jn) = pta(ji,jj,jk,jn)     ! ptn <-- pta
+                  !
+                  IF( ( l_trdtra .and. cdtype == 'TRA' ) .OR. ( l_trdtrc .and. cdtype == 'TRC' ) ) THEN
+                     ztrd_atf(ji,jj,jk,jn) = (ztc_f - ztc_n) * zfact/ze3t_n
+                  ENDIF
+                  !
+               END DO
+            END DO
+         END DO
+         ! 
+      END DO
+      !
+      IF( ( l_trdtra .AND. cdtype == 'TRA' ) .OR. ( l_trdtrc .AND. cdtype == 'TRC' ) )   THEN
+         IF( l_trdtra .AND. cdtype == 'TRA' ) THEN 
+            CALL trd_tra( kt, cdtype, jp_tem, jptra_atf, ztrd_atf(:,:,:,jp_tem) )
+            CALL trd_tra( kt, cdtype, jp_sal, jptra_atf, ztrd_atf(:,:,:,jp_sal) )
+         ENDIF
+         IF( l_trdtrc .AND. cdtype == 'TRC' ) THEN
+            DO jn = 1, kjpt
+               CALL trd_tra( kt, cdtype, jn, jptra_atf, ztrd_atf(:,:,:,jn) )
+            END DO
+         ENDIF
+         DEALLOCATE( ztrd_atf )
+      ENDIF
+      !
+   END SUBROUTINE tra_nxt_vvl
+
+   !!======================================================================
+END MODULE tranxt
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/TRA/traqsr.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/TRA/traqsr.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/TRA/traqsr.F90	(revision 9570)
@@ -0,0 +1,438 @@
+MODULE traqsr
+   !!======================================================================
+   !!                       ***  MODULE  traqsr  ***
+   !! Ocean physics:   solar radiation penetration in the top ocean levels
+   !!======================================================================
+   !! History :  OPA  !  1990-10  (B. Blanke)  Original code
+   !!            7.0  !  1991-11  (G. Madec)
+   !!                 !  1996-01  (G. Madec)  s-coordinates
+   !!   NEMO     1.0  !  2002-06  (G. Madec)  F90: Free form and module
+   !!             -   !  2005-11  (G. Madec) zco, zps, sco coordinate
+   !!            3.2  !  2009-04  (G. Madec & NEMO team) 
+   !!            3.6  !  2012-05  (C. Rousset) store attenuation coef for use in ice model 
+   !!            3.6  !  2015-12  (O. Aumont, J. Jouanno, C. Ethe) use vertical profile of chlorophyll
+   !!            3.7  !  2015-11  (G. Madec, A. Coward)  remove optimisation for fix volume 
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   tra_qsr       : temperature trend due to the penetration of solar radiation 
+   !!   tra_qsr_init  : initialization of the qsr penetration 
+   !!----------------------------------------------------------------------
+   USE oce            ! ocean dynamics and active tracers
+   USE phycst         ! physical constants
+   USE dom_oce        ! ocean space and time domain
+   USE sbc_oce        ! surface boundary condition: ocean
+   USE trc_oce        ! share SMS/Ocean variables
+   USE trd_oce        ! trends: ocean variables
+   USE trdtra         ! trends manager: tracers
+   !
+   USE in_out_manager ! I/O manager
+   USE prtctl         ! Print control
+   USE iom            ! I/O library
+   USE fldread        ! read input fields
+   USE restart        ! ocean restart
+   USE lib_mpp        ! MPP library
+   USE lbclnk         ! ocean lateral boundary conditions (or mpp link)
+   USE timing         ! Timing
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   tra_qsr       ! routine called by step.F90 (ln_traqsr=T)
+   PUBLIC   tra_qsr_init  ! routine called by nemogcm.F90
+
+   !                                 !!* Namelist namtra_qsr: penetrative solar radiation
+   LOGICAL , PUBLIC ::   ln_traqsr    !: light absorption (qsr) flag
+   LOGICAL , PUBLIC ::   ln_qsr_rgb   !: Red-Green-Blue light absorption flag  
+   LOGICAL , PUBLIC ::   ln_qsr_2bd   !: 2 band         light absorption flag
+   LOGICAL , PUBLIC ::   ln_qsr_bio   !: bio-model      light absorption flag
+   INTEGER , PUBLIC ::   nn_chldta    !: use Chlorophyll data (=1) or not (=0)
+   REAL(wp), PUBLIC ::   rn_abs       !: fraction absorbed in the very near surface (RGB & 2 bands)
+   REAL(wp), PUBLIC ::   rn_si0       !: very near surface depth of extinction      (RGB & 2 bands)
+   REAL(wp), PUBLIC ::   rn_si1       !: deepest depth of extinction (water type I)       (2 bands)
+   !
+   INTEGER , PUBLIC ::   nksr         !: levels below which the light cannot penetrate (depth larger than 391 m)
+ 
+   INTEGER, PARAMETER ::   np_RGB  = 1   ! R-G-B     light penetration with constant Chlorophyll
+   INTEGER, PARAMETER ::   np_RGBc = 2   ! R-G-B     light penetration with Chlorophyll data
+   INTEGER, PARAMETER ::   np_2BD  = 3   ! 2 bands   light penetration
+   INTEGER, PARAMETER ::   np_BIO  = 4   ! bio-model light penetration
+   !
+   INTEGER  ::   nqsr    ! user choice of the type of light penetration
+   REAL(wp) ::   xsi0r   ! inverse of rn_si0
+   REAL(wp) ::   xsi1r   ! inverse of rn_si1
+   !
+   REAL(wp) , DIMENSION(3,61)           ::   rkrgb    ! tabulated attenuation coefficients for RGB absorption
+   TYPE(FLD), ALLOCATABLE, DIMENSION(:) ::   sf_chl   ! structure of input Chl (file informations, fields read)
+
+   !! * Substitutions
+#  include "vectopt_loop_substitute.h90"
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO Consortium (2010)
+   !! $Id$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE tra_qsr( kt )
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE tra_qsr  ***
+      !!
+      !! ** Purpose :   Compute the temperature trend due to the solar radiation
+      !!              penetration and add it to the general temperature trend.
+      !!
+      !! ** Method  : The profile of the solar radiation within the ocean is defined
+      !!      through 2 wavebands (rn_si0,rn_si1) or 3 wavebands (RGB) and a ratio rn_abs
+      !!      Considering the 2 wavebands case:
+      !!         I(k) = Qsr*( rn_abs*EXP(z(k)/rn_si0) + (1.-rn_abs)*EXP(z(k)/rn_si1) )
+      !!         The temperature trend associated with the solar radiation penetration 
+      !!         is given by : zta = 1/e3t dk[ I ] / (rau0*Cp)
+      !!         At the bottom, boudary condition for the radiation is no flux :
+      !!      all heat which has not been absorbed in the above levels is put
+      !!      in the last ocean level.
+      !!         The computation is only done down to the level where 
+      !!      I(k) < 1.e-15 W/m2 (i.e. over the top nksr levels) . 
+      !!
+      !! ** Action  : - update ta with the penetrative solar radiation trend
+      !!              - send  trend for further diagnostics (l_trdtra=T)
+      !!
+      !! Reference  : Jerlov, N. G., 1968 Optical Oceanography, Elsevier, 194pp.
+      !!              Lengaigne et al. 2007, Clim. Dyn., V28, 5, 503-516.
+      !!              Morel, A. et Berthon, JF, 1989, Limnol Oceanogr 34(8), 1545-1562
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT(in) ::   kt     ! ocean time-step
+      !
+      INTEGER  ::   ji, jj, jk               ! dummy loop indices
+      INTEGER  ::   irgb                     ! local integers
+      REAL(wp) ::   zchl, zcoef, z1_2        ! local scalars
+      REAL(wp) ::   zc0 , zc1 , zc2 , zc3    !    -         -
+      REAL(wp) ::   zzc0, zzc1, zzc2, zzc3   !    -         -
+      REAL(wp) ::   zz0 , zz1                !    -         -
+      REAL(wp) ::   zCb, zCmax, zze, zpsi, zpsimax, zdelpsi, zCtot, zCze
+      REAL(wp) ::   zlogc, zlogc2, zlogc3 
+      REAL(wp), ALLOCATABLE, DIMENSION(:,:)   :: zekb, zekg, zekr
+      REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: ze0, ze1, ze2, ze3, zea, ztrdt
+      REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zetot, zchl3d
+      !!----------------------------------------------------------------------
+      !
+      IF( ln_timing )   CALL timing_start('tra_qsr')
+      !
+      IF( kt == nit000 ) THEN
+         IF(lwp) WRITE(numout,*)
+         IF(lwp) WRITE(numout,*) 'tra_qsr : penetration of the surface solar radiation'
+         IF(lwp) WRITE(numout,*) '~~~~~~~'
+      ENDIF
+      !
+      IF( l_trdtra ) THEN      ! trends diagnostic: save the input temperature trend
+         ALLOCATE( ztrdt(jpi,jpj,jpk) ) 
+         ztrdt(:,:,:) = tsa(:,:,:,jp_tem)
+      ENDIF
+      !
+      !                         !-----------------------------------!
+      !                         !  before qsr induced heat content  !
+      !                         !-----------------------------------!
+      IF( kt == nit000 ) THEN          !==  1st time step  ==!
+!!gm case neuler  not taken into account....
+         IF( ln_rstart .AND. iom_varid( numror, 'qsr_hc_b', ldstop = .FALSE. ) > 0 ) THEN    ! read in restart
+            IF(lwp) WRITE(numout,*) '          nit000-1 qsr tracer content forcing field read in the restart file'
+            z1_2 = 0.5_wp
+            CALL iom_get( numror, jpdom_autoglo, 'qsr_hc_b', qsr_hc_b, ldxios = lrxios )   ! before heat content trend due to Qsr flux
+         ELSE                                           ! No restart or restart not found: Euler forward time stepping
+            z1_2 = 1._wp
+            qsr_hc_b(:,:,:) = 0._wp
+         ENDIF
+      ELSE                             !==  Swap of qsr heat content  ==!
+         z1_2 = 0.5_wp
+         qsr_hc_b(:,:,:) = qsr_hc(:,:,:)
+      ENDIF
+      !
+      !                         !--------------------------------!
+      SELECT CASE( nqsr )       !  now qsr induced heat content  !
+      !                         !--------------------------------!
+      !
+      CASE( np_BIO )                   !==  bio-model fluxes  ==!
+         !
+         DO jk = 1, nksr
+            qsr_hc(:,:,jk) = r1_rau0_rcp * ( etot3(:,:,jk) - etot3(:,:,jk+1) )
+         END DO
+         !
+      CASE( np_RGB , np_RGBc )         !==  R-G-B fluxes  ==!
+         !
+         ALLOCATE( zekb(jpi,jpj)     , zekg(jpi,jpj)     , zekr  (jpi,jpj)     , &
+            &      ze0 (jpi,jpj,jpk) , ze1 (jpi,jpj,jpk) , ze2   (jpi,jpj,jpk) , &
+            &      ze3 (jpi,jpj,jpk) , zea (jpi,jpj,jpk) , zchl3d(jpi,jpj,jpk)   ) 
+         !
+         IF( nqsr == np_RGBc ) THEN          !*  Variable Chlorophyll
+            CALL fld_read( kt, 1, sf_chl )         ! Read Chl data and provides it at the current time step
+            DO jk = 1, nksr + 1
+               DO jj = 2, jpjm1                       ! Separation in R-G-B depending of the surface Chl
+                  DO ji = fs_2, fs_jpim1
+                     zchl    = sf_chl(1)%fnow(ji,jj,1)
+                     zCtot   = 40.6  * zchl**0.459
+                     zze     = 568.2 * zCtot**(-0.746)
+                     IF( zze > 102. ) zze = 200.0 * zCtot**(-0.293)
+                     zpsi    = gdepw_n(ji,jj,jk) / zze
+                     !
+                     zlogc   = LOG( zchl )
+                     zlogc2  = zlogc * zlogc
+                     zlogc3  = zlogc * zlogc * zlogc
+                     zCb     = 0.768 + 0.087 * zlogc - 0.179 * zlogc2 - 0.025 * zlogc3
+                     zCmax   = 0.299 - 0.289 * zlogc + 0.579 * zlogc2
+                     zpsimax = 0.6   - 0.640 * zlogc + 0.021 * zlogc2 + 0.115 * zlogc3
+                     zdelpsi = 0.710 + 0.159 * zlogc + 0.021 * zlogc2
+                     zCze    = 1.12  * (zchl)**0.803 
+                     !
+                     zchl3d(ji,jj,jk) = zCze * ( zCb + zCmax * EXP( -( (zpsi - zpsimax) / zdelpsi )**2 ) )
+                  END DO
+                  !
+               END DO
+            END DO
+         ELSE                                !* constant chrlorophyll
+           DO jk = 1, nksr + 1
+              zchl3d(:,:,jk) = 0.05 
+            ENDDO
+         ENDIF
+         !
+         zcoef  = ( 1. - rn_abs ) / 3._wp    !* surface equi-partition in R-G-B
+         DO jj = 2, jpjm1
+            DO ji = fs_2, fs_jpim1
+               ze0(ji,jj,1) = rn_abs * qsr(ji,jj)
+               ze1(ji,jj,1) = zcoef  * qsr(ji,jj)
+               ze2(ji,jj,1) = zcoef  * qsr(ji,jj)
+               ze3(ji,jj,1) = zcoef  * qsr(ji,jj)
+               zea(ji,jj,1) =          qsr(ji,jj)
+            END DO
+         END DO
+         !
+         DO jk = 2, nksr+1                   !* interior equi-partition in R-G-B depending of vertical profile of Chl
+            DO jj = 2, jpjm1
+               DO ji = fs_2, fs_jpim1
+                  zchl = MIN( 10. , MAX( 0.03, zchl3d(ji,jj,jk) ) )
+                  irgb = NINT( 41 + 20.*LOG10(zchl) + 1.e-15 )
+                  zekb(ji,jj) = rkrgb(1,irgb)
+                  zekg(ji,jj) = rkrgb(2,irgb)
+                  zekr(ji,jj) = rkrgb(3,irgb)
+               END DO
+            END DO
+
+            DO jj = 2, jpjm1
+               DO ji = fs_2, fs_jpim1
+                  zc0 = ze0(ji,jj,jk-1) * EXP( - e3t_n(ji,jj,jk-1) * xsi0r       )
+                  zc1 = ze1(ji,jj,jk-1) * EXP( - e3t_n(ji,jj,jk-1) * zekb(ji,jj) )
+                  zc2 = ze2(ji,jj,jk-1) * EXP( - e3t_n(ji,jj,jk-1) * zekg(ji,jj) )
+                  zc3 = ze3(ji,jj,jk-1) * EXP( - e3t_n(ji,jj,jk-1) * zekr(ji,jj) )
+                  ze0(ji,jj,jk) = zc0
+                  ze1(ji,jj,jk) = zc1
+                  ze2(ji,jj,jk) = zc2
+                  ze3(ji,jj,jk) = zc3
+                  zea(ji,jj,jk) = ( zc0 + zc1 + zc2 + zc3 ) * wmask(ji,jj,jk)
+               END DO
+            END DO
+         END DO
+         !
+         DO jk = 1, nksr                     !* now qsr induced heat content
+            DO jj = 2, jpjm1
+               DO ji = fs_2, fs_jpim1
+                  qsr_hc(ji,jj,jk) = r1_rau0_rcp * ( zea(ji,jj,jk) - zea(ji,jj,jk+1) )
+               END DO
+            END DO
+         END DO
+         !
+         DEALLOCATE( zekb , zekg , zekr , ze0 , ze1 , ze2 , ze3 , zea , zchl3d ) 
+         !
+      CASE( np_2BD  )            !==  2-bands fluxes  ==!
+         !
+         zz0 =        rn_abs   * r1_rau0_rcp      ! surface equi-partition in 2-bands
+         zz1 = ( 1. - rn_abs ) * r1_rau0_rcp
+         DO jk = 1, nksr                          ! solar heat absorbed at T-point in the top 400m 
+            DO jj = 2, jpjm1
+               DO ji = fs_2, fs_jpim1
+                  zc0 = zz0 * EXP( -gdepw_n(ji,jj,jk  )*xsi0r ) + zz1 * EXP( -gdepw_n(ji,jj,jk  )*xsi1r )
+                  zc1 = zz0 * EXP( -gdepw_n(ji,jj,jk+1)*xsi0r ) + zz1 * EXP( -gdepw_n(ji,jj,jk+1)*xsi1r )
+                  qsr_hc(ji,jj,jk) = qsr(ji,jj) * ( zc0 * wmask(ji,jj,jk) - zc1 * wmask(ji,jj,jk+1) ) 
+               END DO
+            END DO
+         END DO
+         !
+      END SELECT
+      !
+      !                          !-----------------------------!
+      DO jk = 1, nksr            !  update to the temp. trend  !
+         DO jj = 2, jpjm1        !-----------------------------!
+            DO ji = fs_2, fs_jpim1   ! vector opt.
+               tsa(ji,jj,jk,jp_tem) = tsa(ji,jj,jk,jp_tem)   &
+                  &                 + z1_2 * ( qsr_hc_b(ji,jj,jk) + qsr_hc(ji,jj,jk) ) / e3t_n(ji,jj,jk)
+            END DO
+         END DO
+      END DO
+      !
+      ! sea-ice: store the 1st ocean level attenuation coefficient
+      DO jj = 2, jpjm1 
+         DO ji = fs_2, fs_jpim1   ! vector opt.
+            IF( qsr(ji,jj) /= 0._wp ) THEN   ;   fraqsr_1lev(ji,jj) = qsr_hc(ji,jj,1) / ( r1_rau0_rcp * qsr(ji,jj) )
+            ELSE                             ;   fraqsr_1lev(ji,jj) = 1._wp
+            ENDIF
+         END DO
+      END DO
+      CALL lbc_lnk( fraqsr_1lev(:,:), 'T', 1._wp )
+      !
+      IF( iom_use('qsr3d') ) THEN      ! output the shortwave Radiation distribution
+         ALLOCATE( zetot(jpi,jpj,jpk) )
+         zetot(:,:,nksr+1:jpk) = 0._wp     ! below ~400m set to zero
+         DO jk = nksr, 1, -1
+            zetot(:,:,jk) = zetot(:,:,jk+1) + qsr_hc(:,:,jk) * rau0_rcp
+         END DO         
+         CALL iom_put( 'qsr3d', zetot )   ! 3D distribution of shortwave Radiation
+         DEALLOCATE( zetot ) 
+      ENDIF
+      !
+      IF( lrst_oce ) THEN     ! write in the ocean restart file
+         IF( lwxios ) CALL iom_swap(      cwxios_context          )
+         CALL iom_rstput( kt, nitrst, numrow, 'qsr_hc_b'   , qsr_hc     , ldxios = lwxios )
+         CALL iom_rstput( kt, nitrst, numrow, 'fraqsr_1lev', fraqsr_1lev, ldxios = lwxios ) 
+         IF( lwxios ) CALL iom_swap(      cxios_context          )
+      ENDIF
+      !
+      IF( l_trdtra ) THEN     ! qsr tracers trends saved for diagnostics
+         ztrdt(:,:,:) = tsa(:,:,:,jp_tem) - ztrdt(:,:,:)
+         CALL trd_tra( kt, 'TRA', jp_tem, jptra_qsr, ztrdt )
+         DEALLOCATE( ztrdt ) 
+      ENDIF
+      !                       ! print mean trends (used for debugging)
+      IF(ln_ctl)   CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' qsr  - Ta: ', mask1=tmask, clinfo3='tra-ta' )
+      !
+      IF( ln_timing )   CALL timing_stop('tra_qsr')
+      !
+   END SUBROUTINE tra_qsr
+
+
+   SUBROUTINE tra_qsr_init
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE tra_qsr_init  ***
+      !!
+      !! ** Purpose :   Initialization for the penetrative solar radiation
+      !!
+      !! ** Method  :   The profile of solar radiation within the ocean is set
+      !!      from two length scale of penetration (rn_si0,rn_si1) and a ratio
+      !!      (rn_abs). These parameters are read in the namtra_qsr namelist. The
+      !!      default values correspond to clear water (type I in Jerlov' 
+      !!      (1968) classification.
+      !!         called by tra_qsr at the first timestep (nit000)
+      !!
+      !! ** Action  : - initialize rn_si0, rn_si1 and rn_abs
+      !!
+      !! Reference : Jerlov, N. G., 1968 Optical Oceanography, Elsevier, 194pp.
+      !!----------------------------------------------------------------------
+      INTEGER  ::   ji, jj, jk                  ! dummy loop indices
+      INTEGER  ::   ios, irgb, ierror, ioptio   ! local integer
+      REAL(wp) ::   zz0, zc0 , zc1, zcoef      ! local scalars
+      REAL(wp) ::   zz1, zc2 , zc3, zchl       !   -      -
+      !
+      CHARACTER(len=100) ::   cn_dir   ! Root directory for location of ssr files
+      TYPE(FLD_N)        ::   sn_chl   ! informations about the chlorofyl field to be read
+      !!
+      NAMELIST/namtra_qsr/  sn_chl, cn_dir, ln_qsr_rgb, ln_qsr_2bd, ln_qsr_bio,  &
+         &                  nn_chldta, rn_abs, rn_si0, rn_si1
+      !!----------------------------------------------------------------------
+      !
+      REWIND( numnam_ref )              ! Namelist namtra_qsr in reference     namelist
+      READ  ( numnam_ref, namtra_qsr, IOSTAT = ios, ERR = 901)
+901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namtra_qsr in reference namelist', lwp )
+      !
+      REWIND( numnam_cfg )              ! Namelist namtra_qsr in configuration namelist
+      READ  ( numnam_cfg, namtra_qsr, IOSTAT = ios, ERR = 902 )
+902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namtra_qsr in configuration namelist', lwp )
+      IF(lwm) WRITE ( numond, namtra_qsr )
+      !
+      IF(lwp) THEN                ! control print
+         WRITE(numout,*)
+         WRITE(numout,*) 'tra_qsr_init : penetration of the surface solar radiation'
+         WRITE(numout,*) '~~~~~~~~~~~~'
+         WRITE(numout,*) '   Namelist namtra_qsr : set the parameter of penetration'
+         WRITE(numout,*) '      RGB (Red-Green-Blue) light penetration       ln_qsr_rgb = ', ln_qsr_rgb
+         WRITE(numout,*) '      2 band               light penetration       ln_qsr_2bd = ', ln_qsr_2bd
+         WRITE(numout,*) '      bio-model            light penetration       ln_qsr_bio = ', ln_qsr_bio
+         WRITE(numout,*) '      RGB : Chl data (=1) or cst value (=0)        nn_chldta  = ', nn_chldta
+         WRITE(numout,*) '      RGB & 2 bands: fraction of light (rn_si1)    rn_abs     = ', rn_abs
+         WRITE(numout,*) '      RGB & 2 bands: shortess depth of extinction  rn_si0     = ', rn_si0
+         WRITE(numout,*) '      2 bands: longest depth of extinction         rn_si1     = ', rn_si1
+         WRITE(numout,*)
+      ENDIF
+      !
+      ioptio = 0                    ! Parameter control
+      IF( ln_qsr_rgb  )   ioptio = ioptio + 1
+      IF( ln_qsr_2bd  )   ioptio = ioptio + 1
+      IF( ln_qsr_bio  )   ioptio = ioptio + 1
+      !
+      IF( ioptio /= 1 )   CALL ctl_stop( 'Choose ONE type of light penetration in namelist namtra_qsr',  &
+         &                               ' 2 bands, 3 RGB bands or bio-model light penetration' )
+      !
+      IF( ln_qsr_rgb .AND. nn_chldta == 0 )   nqsr = np_RGB 
+      IF( ln_qsr_rgb .AND. nn_chldta == 1 )   nqsr = np_RGBc
+      IF( ln_qsr_2bd                      )   nqsr = np_2BD
+      IF( ln_qsr_bio                      )   nqsr = np_BIO
+      !
+      !                             ! Initialisation
+      xsi0r = 1._wp / rn_si0
+      xsi1r = 1._wp / rn_si1
+      !
+      SELECT CASE( nqsr )
+      !                               
+      CASE( np_RGB , np_RGBc )         !==  Red-Green-Blue light penetration  ==!
+         !                             
+         IF(lwp)   WRITE(numout,*) '   ==>>>   R-G-B   light penetration '
+         !
+         CALL trc_oce_rgb( rkrgb )                 ! tabulated attenuation coef.
+         !                                   
+         nksr = trc_oce_ext_lev( r_si2, 33._wp )   ! level of light extinction
+         !
+         IF(lwp) WRITE(numout,*) '        level of light extinction = ', nksr, ' ref depth = ', gdepw_1d(nksr+1), ' m'
+         !
+         IF( nqsr == np_RGBc ) THEN                ! Chl data : set sf_chl structure
+            IF(lwp) WRITE(numout,*) '   ==>>>   Chlorophyll read in a file'
+            ALLOCATE( sf_chl(1), STAT=ierror )
+            IF( ierror > 0 ) THEN
+               CALL ctl_stop( 'tra_qsr_init: unable to allocate sf_chl structure' )   ;   RETURN
+            ENDIF
+            ALLOCATE( sf_chl(1)%fnow(jpi,jpj,1)   )
+            IF( sn_chl%ln_tint )   ALLOCATE( sf_chl(1)%fdta(jpi,jpj,1,2) )
+            !                                        ! fill sf_chl with sn_chl and control print
+            CALL fld_fill( sf_chl, (/ sn_chl /), cn_dir, 'tra_qsr_init',   &
+               &           'Solar penetration function of read chlorophyll', 'namtra_qsr' , no_print )
+         ENDIF
+         IF( nqsr == np_RGB ) THEN                 ! constant Chl
+            IF(lwp) WRITE(numout,*) '   ==>>>   Constant Chlorophyll concentration = 0.05'
+         ENDIF
+         !
+      CASE( np_2BD )                   !==  2 bands light penetration  ==!
+         !
+         IF(lwp)  WRITE(numout,*) '   ==>>>   2 bands light penetration'
+         !
+         nksr = trc_oce_ext_lev( rn_si1, 100._wp )    ! level of light extinction
+         IF(lwp) WRITE(numout,*) '        level of light extinction = ', nksr, ' ref depth = ', gdepw_1d(nksr+1), ' m'
+         !
+      CASE( np_BIO )                   !==  BIO light penetration  ==!
+         !
+         IF(lwp) WRITE(numout,*) '   ==>>>   bio-model light penetration'
+         IF( .NOT.lk_top )   CALL ctl_stop( 'No bio model : ln_qsr_bio = true impossible ' )
+         !
+      END SELECT
+      !
+      qsr_hc(:,:,:) = 0._wp     ! now qsr heat content set to zero where it will not be computed
+      !
+      ! 1st ocean level attenuation coefficient (used in sbcssm)
+      IF( iom_varid( numror, 'fraqsr_1lev', ldstop = .FALSE. ) > 0 ) THEN
+         CALL iom_get( numror, jpdom_autoglo, 'fraqsr_1lev'  , fraqsr_1lev, ldxios = lrxios  )
+      ELSE
+         fraqsr_1lev(:,:) = 1._wp   ! default : no penetration
+      ENDIF
+      !
+      IF( lwxios ) THEN
+         CALL iom_set_rstw_var_active('qsr_hc_b')
+         CALL iom_set_rstw_var_active('fraqsr_1lev')
+      ENDIF
+      !
+   END SUBROUTINE tra_qsr_init
+
+   !!======================================================================
+END MODULE traqsr
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/TRA/trasbc.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/TRA/trasbc.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/TRA/trasbc.F90	(revision 9570)
@@ -0,0 +1,289 @@
+MODULE trasbc
+   !!==============================================================================
+   !!                       ***  MODULE  trasbc  ***
+   !! Ocean active tracers:  surface boundary condition
+   !!==============================================================================
+   !! History :  OPA  !  1998-10  (G. Madec, G. Roullet, M. Imbard)  Original code
+   !!            8.2  !  2001-02  (D. Ludicone)  sea ice and free surface
+   !!  NEMO      1.0  !  2002-06  (G. Madec)  F90: Free form and module
+   !!            3.3  !  2010-04  (M. Leclair, G. Madec)  Forcing averaged over 2 time steps
+   !!             -   !  2010-09  (C. Ethe, G. Madec) Merge TRA-TRC
+   !!            3.6  !  2014-11  (P. Mathiot) isf melting forcing 
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   tra_sbc       : update the tracer trend at ocean surface
+   !!----------------------------------------------------------------------
+   USE oce            ! ocean dynamics and active tracers
+   USE sbc_oce        ! surface boundary condition: ocean
+   USE dom_oce        ! ocean space domain variables
+   USE phycst         ! physical constant
+   USE eosbn2         ! Equation Of State
+   USE sbcmod         ! ln_rnf  
+   USE sbcrnf         ! River runoff  
+   USE sbcisf         ! Ice shelf   
+   USE iscplini       ! Ice sheet coupling
+   USE traqsr         ! solar radiation penetration
+   USE trd_oce        ! trends: ocean variables
+   USE trdtra         ! trends manager: tracers 
+   USE wet_dry,  ONLY : ll_wd, rn_wdmin1, r_rn_wdmin1   ! Wetting and drying
+#if defined key_asminc   
+   USE asminc         ! Assimilation increment
+#endif
+   !
+   USE in_out_manager ! I/O manager
+   USE prtctl         ! Print control
+   USE iom            ! xIOS server
+   USE lbclnk         ! ocean lateral boundary conditions (or mpp link)
+   USE timing         ! Timing
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   tra_sbc   ! routine called by step.F90
+
+   !! * Substitutions
+#  include "vectopt_loop_substitute.h90"
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.7 , NEMO Consortium (2014)
+   !! $Id$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE tra_sbc ( kt )
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE tra_sbc  ***
+      !!                   
+      !! ** Purpose :   Compute the tracer surface boundary condition trend of
+      !!      (flux through the interface, concentration/dilution effect)
+      !!      and add it to the general trend of tracer equations.
+      !!
+      !! ** Method :   The (air+ice)-sea flux has two components: 
+      !!      (1) Fext, external forcing (i.e. flux through the (air+ice)-sea interface); 
+      !!      (2) Fwe , tracer carried with the water that is exchanged with air+ice. 
+      !!               The input forcing fields (emp, rnf, sfx, isf) contain Fext+Fwe,
+      !!             they are simply added to the tracer trend (tsa).
+      !!               In linear free surface case (ln_linssh=T), the volume of the
+      !!             ocean does not change with the water exchanges at the (air+ice)-sea
+      !!             interface. Therefore another term has to be added, to mimic the
+      !!             concentration/dilution effect associated with water exchanges.
+      !!
+      !! ** Action  : - Update tsa with the surface boundary condition trend 
+      !!              - send trends to trdtra module for further diagnostics(l_trdtra=T)
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT(in) ::   kt   ! ocean time-step index
+      !
+      INTEGER  ::   ji, jj, jk, jn              ! dummy loop indices  
+      INTEGER  ::   ikt, ikb                    ! local integers
+      REAL(wp) ::   zfact, z1_e3t, zdep, ztim   ! local scalar
+      REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) ::  ztrdt, ztrds
+      !!----------------------------------------------------------------------
+      !
+      IF( ln_timing )   CALL timing_start('tra_sbc')
+      !
+      IF( kt == nit000 ) THEN
+         IF(lwp) WRITE(numout,*)
+         IF(lwp) WRITE(numout,*) 'tra_sbc : TRAcer Surface Boundary Condition'
+         IF(lwp) WRITE(numout,*) '~~~~~~~ '
+      ENDIF
+      !
+      IF( l_trdtra ) THEN                    !* Save ta and sa trends
+         ALLOCATE( ztrdt(jpi,jpj,jpk) , ztrds(jpi,jpj,jpk) ) 
+         ztrdt(:,:,:) = tsa(:,:,:,jp_tem)
+         ztrds(:,:,:) = tsa(:,:,:,jp_sal)
+      ENDIF
+      !
+!!gm  This should be moved into sbcmod.F90 module ? (especially now that ln_traqsr is read in namsbc namelist)
+      IF( .NOT.ln_traqsr ) THEN     ! no solar radiation penetration
+         qns(:,:) = qns(:,:) + qsr(:,:)      ! total heat flux in qns
+         qsr(:,:) = 0._wp                     ! qsr set to zero
+      ENDIF
+
+      !----------------------------------------
+      !        EMP, SFX and QNS effects
+      !----------------------------------------
+      !                             !==  Set before sbc tracer content fields  ==!
+      IF( kt == nit000 ) THEN             !* 1st time-step
+         IF( ln_rstart .AND.    &               ! Restart: read in restart file
+              & iom_varid( numror, 'sbc_hc_b', ldstop = .FALSE. ) > 0 ) THEN
+            IF(lwp) WRITE(numout,*) '          nit000-1 sbc tracer content field read in the restart file'
+            zfact = 0.5_wp
+            sbc_tsc(:,:,:) = 0._wp
+            CALL iom_get( numror, jpdom_autoglo, 'sbc_hc_b', sbc_tsc_b(:,:,jp_tem), ldxios = lrxios )   ! before heat content sbc trend
+            CALL iom_get( numror, jpdom_autoglo, 'sbc_sc_b', sbc_tsc_b(:,:,jp_sal), ldxios = lrxios )   ! before salt content sbc trend
+         ELSE                                   ! No restart or restart not found: Euler forward time stepping
+            zfact = 1._wp
+            sbc_tsc(:,:,:) = 0._wp
+            sbc_tsc_b(:,:,:) = 0._wp
+         ENDIF
+      ELSE                                !* other time-steps: swap of forcing fields
+         zfact = 0.5_wp
+         sbc_tsc_b(:,:,:) = sbc_tsc(:,:,:)
+      ENDIF
+      !                             !==  Now sbc tracer content fields  ==!
+      DO jj = 2, jpj
+         DO ji = fs_2, fs_jpim1   ! vector opt.
+            IF ( ll_wd ) THEN     ! If near WAD point limit the flux for now
+               IF ( sshn(ji,jj) + ht_0(ji,jj) >  2._wp * rn_wdmin1 ) THEN
+                  sbc_tsc(ji,jj,jp_tem) = r1_rau0_rcp * qns(ji,jj)   ! non solar heat flux
+               ELSE IF ( sshn(ji,jj) + ht_0(ji,jj) >  rn_wdmin1 ) THEN
+                  sbc_tsc(ji,jj,jp_tem) = r1_rau0_rcp * qns(ji,jj) &
+                       &                * tanh ( 5._wp * ( ( sshn(ji,jj) + ht_0(ji,jj) -  rn_wdmin1 ) * r_rn_wdmin1 ) )
+               ELSE
+                  sbc_tsc(ji,jj,jp_tem) = 0._wp
+               ENDIF
+            ELSE 
+               sbc_tsc(ji,jj,jp_tem) = r1_rau0_rcp * qns(ji,jj)   ! non solar heat flux
+            ENDIF
+
+            sbc_tsc(ji,jj,jp_sal) = r1_rau0     * sfx(ji,jj)   ! salt flux due to freezing/melting
+         END DO
+      END DO
+      IF( ln_linssh ) THEN                !* linear free surface  
+         DO jj = 2, jpj                         !==>> add concentration/dilution effect due to constant volume cell
+            DO ji = fs_2, fs_jpim1   ! vector opt.
+               sbc_tsc(ji,jj,jp_tem) = sbc_tsc(ji,jj,jp_tem) + r1_rau0 * emp(ji,jj) * tsn(ji,jj,1,jp_tem)
+               sbc_tsc(ji,jj,jp_sal) = sbc_tsc(ji,jj,jp_sal) + r1_rau0 * emp(ji,jj) * tsn(ji,jj,1,jp_sal)
+            END DO
+         END DO                                 !==>> output c./d. term
+         IF( iom_use('emp_x_sst') )   CALL iom_put( "emp_x_sst", emp (:,:) * tsn(:,:,1,jp_tem) )
+         IF( iom_use('emp_x_sss') )   CALL iom_put( "emp_x_sss", emp (:,:) * tsn(:,:,1,jp_sal) )
+      ENDIF
+      !
+      DO jn = 1, jpts               !==  update tracer trend  ==!
+         DO jj = 2, jpj
+            DO ji = fs_2, fs_jpim1   ! vector opt.  
+               tsa(ji,jj,1,jn) = tsa(ji,jj,1,jn) + zfact * ( sbc_tsc_b(ji,jj,jn) + sbc_tsc(ji,jj,jn) ) / e3t_n(ji,jj,1)
+            END DO
+         END DO
+      END DO
+      !                  
+      IF( lrst_oce ) THEN           !==  write sbc_tsc in the ocean restart file  ==!
+         IF( lwxios ) CALL iom_swap(      cwxios_context          )
+         CALL iom_rstput( kt, nitrst, numrow, 'sbc_hc_b', sbc_tsc(:,:,jp_tem), ldxios = lwxios )
+         CALL iom_rstput( kt, nitrst, numrow, 'sbc_sc_b', sbc_tsc(:,:,jp_sal), ldxios = lwxios )
+         IF( lwxios ) CALL iom_swap(      cxios_context          )
+      ENDIF
+      !
+      !----------------------------------------
+      !       Ice Shelf effects (ISF)
+      !     tbl treated as in Losh (2008) JGR
+      !----------------------------------------
+      !
+!!gm BUG ?   Why no differences between non-linear and linear free surface ?
+!!gm         probably taken into account in r1_hisf_tbl : to be verified
+      IF( ln_isf ) THEN
+         zfact = 0.5_wp
+         DO jj = 2, jpj
+            DO ji = fs_2, fs_jpim1
+               !
+               ikt = misfkt(ji,jj)
+               ikb = misfkb(ji,jj)
+               !
+               ! level fully include in the ice shelf boundary layer
+               ! sign - because fwf sign of evapo (rnf sign of precip)
+               DO jk = ikt, ikb - 1
+               ! compute trend
+                  tsa(ji,jj,jk,jp_tem) = tsa(ji,jj,jk,jp_tem)                                                &
+                     &           + zfact * ( risf_tsc_b(ji,jj,jp_tem) + risf_tsc(ji,jj,jp_tem) )             &
+                     &           * r1_hisf_tbl(ji,jj)
+               END DO
+   
+               ! level partially include in ice shelf boundary layer 
+               ! compute trend
+               tsa(ji,jj,ikb,jp_tem) = tsa(ji,jj,ikb,jp_tem)                                                 &
+                  &              + zfact * ( risf_tsc_b(ji,jj,jp_tem) + risf_tsc(ji,jj,jp_tem) )             &
+                  &              * r1_hisf_tbl(ji,jj) * ralpha(ji,jj)
+
+            END DO
+         END DO
+      END IF
+      !
+      !----------------------------------------
+      !        River Runoff effects
+      !----------------------------------------
+      !
+      IF( ln_rnf ) THEN         ! input of heat and salt due to river runoff 
+         zfact = 0.5_wp
+         DO jj = 2, jpj 
+            DO ji = fs_2, fs_jpim1
+               IF( rnf(ji,jj) /= 0._wp ) THEN
+                  zdep = zfact / h_rnf(ji,jj)
+                  DO jk = 1, nk_rnf(ji,jj)
+                                        tsa(ji,jj,jk,jp_tem) = tsa(ji,jj,jk,jp_tem)                                 &
+                                           &                 +  ( rnf_tsc_b(ji,jj,jp_tem) + rnf_tsc(ji,jj,jp_tem) ) * zdep
+                     IF( ln_rnf_sal )   tsa(ji,jj,jk,jp_sal) = tsa(ji,jj,jk,jp_sal)                                 &
+                                           &                 +  ( rnf_tsc_b(ji,jj,jp_sal) + rnf_tsc(ji,jj,jp_sal) ) * zdep 
+                  END DO
+               ENDIF
+            END DO  
+         END DO  
+      ENDIF
+
+      IF( iom_use('rnf_x_sst') )   CALL iom_put( "rnf_x_sst", rnf*tsn(:,:,1,jp_tem) )   ! runoff term on sst
+      IF( iom_use('rnf_x_sss') )   CALL iom_put( "rnf_x_sss", rnf*tsn(:,:,1,jp_sal) )   ! runoff term on sss
+
+#if defined key_asminc
+      !
+      !----------------------------------------
+      !        Assmilation effects
+      !----------------------------------------
+      !
+      IF( ln_sshinc ) THEN         ! input of heat and salt due to assimilation
+      	 !
+         IF( ln_linssh ) THEN 
+            DO jj = 2, jpj 
+               DO ji = fs_2, fs_jpim1
+                  ztim = ssh_iau(ji,jj) / e3t_n(ji,jj,1)
+                  tsa(ji,jj,1,jp_tem) = tsa(ji,jj,1,jp_tem) + tsn(ji,jj,1,jp_tem) * ztim
+                  tsa(ji,jj,1,jp_sal) = tsa(ji,jj,1,jp_sal) + tsn(ji,jj,1,jp_sal) * ztim
+               END DO
+            END DO
+         ELSE
+            DO jj = 2, jpj 
+               DO ji = fs_2, fs_jpim1
+                  ztim = ssh_iau(ji,jj) / ( ht_n(ji,jj) + 1. - ssmask(ji, jj) )
+                  tsa(ji,jj,:,jp_tem) = tsa(ji,jj,:,jp_tem) + tsn(ji,jj,:,jp_tem) * ztim
+                  tsa(ji,jj,:,jp_sal) = tsa(ji,jj,:,jp_sal) + tsn(ji,jj,:,jp_sal) * ztim
+               END DO  
+            END DO  
+         ENDIF
+         !
+      ENDIF
+      !
+#endif
+      !
+      !----------------------------------------
+      !        Ice Sheet coupling imbalance correction to have conservation
+      !----------------------------------------
+      !
+      IF( ln_iscpl .AND. ln_hsb) THEN         ! input of heat and salt due to river runoff 
+         DO jk = 1,jpk
+            DO jj = 2, jpj 
+               DO ji = fs_2, fs_jpim1
+                  zdep = 1._wp / e3t_n(ji,jj,jk) 
+                  tsa(ji,jj,jk,jp_tem) = tsa(ji,jj,jk,jp_tem) - htsc_iscpl(ji,jj,jk,jp_tem) * zdep
+                  tsa(ji,jj,jk,jp_sal) = tsa(ji,jj,jk,jp_sal) - htsc_iscpl(ji,jj,jk,jp_sal) * zdep  
+               END DO  
+            END DO  
+         END DO
+      ENDIF
+
+      IF( l_trdtra )   THEN                      ! save the horizontal diffusive trends for further diagnostics
+         ztrdt(:,:,:) = tsa(:,:,:,jp_tem) - ztrdt(:,:,:)
+         ztrds(:,:,:) = tsa(:,:,:,jp_sal) - ztrds(:,:,:)
+         CALL trd_tra( kt, 'TRA', jp_tem, jptra_nsr, ztrdt )
+         CALL trd_tra( kt, 'TRA', jp_sal, jptra_nsr, ztrds )
+         DEALLOCATE( ztrdt , ztrds ) 
+      ENDIF
+      !
+      IF(ln_ctl)   CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' sbc  - Ta: ', mask1=tmask,   &
+         &                       tab3d_2=tsa(:,:,:,jp_sal), clinfo2=       ' Sa: ', mask2=tmask, clinfo3='tra' )
+      !
+      IF( ln_timing )   CALL timing_stop('tra_sbc')
+      !
+   END SUBROUTINE tra_sbc
+
+   !!======================================================================
+END MODULE trasbc
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/TRA/trazdf.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/TRA/trazdf.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/TRA/trazdf.F90	(revision 9570)
@@ -0,0 +1,257 @@
+MODULE trazdf
+   !!==============================================================================
+   !!                 ***  MODULE  trazdf  ***
+   !! Ocean active tracers:  vertical component of the tracer mixing trend
+   !!==============================================================================
+   !! History :  1.0  !  2005-11  (G. Madec)  Original code
+   !!            3.0  !  2008-01  (C. Ethe, G. Madec)  merge TRC-TRA
+   !!            4.0  !  2017-06  (G. Madec)  remove explict time-stepping option
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   tra_zdf       : Update the tracer trend with the vertical diffusion
+   !!----------------------------------------------------------------------
+   USE oce            ! ocean dynamics and tracers variables
+   USE dom_oce        ! ocean space and time domain variables 
+   USE domvvl         ! variable volume
+   USE phycst         ! physical constant
+   USE zdf_oce        ! ocean vertical physics variables
+   USE sbc_oce        ! surface boundary condition: ocean
+   USE ldftra         ! lateral diffusion: eddy diffusivity
+   USE ldfslp         ! lateral diffusion: iso-neutral slope 
+   USE trd_oce        ! trends: ocean variables
+   USE trdtra         ! trends: tracer trend manager
+   !
+   USE in_out_manager ! I/O manager
+   USE prtctl         ! Print control
+   USE lbclnk         ! ocean lateral boundary conditions (or mpp link)
+   USE lib_mpp        ! MPP library
+   USE timing         ! Timing
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   tra_zdf       ! called by step.F90
+   PUBLIC   tra_zdf_imp   ! called by trczdf.F90
+
+   !! * Substitutions
+#  include "vectopt_loop_substitute.h90"
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 4.0 , NEMO Consortium (2017)
+   !! $Id$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE tra_zdf( kt )
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE tra_zdf  ***
+      !!
+      !! ** Purpose :   compute the vertical ocean tracer physics.
+      !!---------------------------------------------------------------------
+      INTEGER, INTENT(in) ::   kt   ! ocean time-step index
+      !
+      INTEGER  ::   jk   ! Dummy loop indices
+      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::   ztrdt, ztrds   ! 3D workspace
+      !!---------------------------------------------------------------------
+      !
+      IF( ln_timing )   CALL timing_start('tra_zdf')
+      !
+      IF( kt == nit000 )  THEN
+         IF(lwp)WRITE(numout,*)
+         IF(lwp)WRITE(numout,*) 'tra_zdf : implicit vertical mixing on T & S'
+         IF(lwp)WRITE(numout,*) '~~~~~~~ '
+      ENDIF
+      !
+      IF( neuler == 0 .AND. kt == nit000 ) THEN   ;   r2dt =      rdt   ! at nit000, =   rdt (restarting with Euler time stepping)
+      ELSEIF( kt <= nit000 + 1           ) THEN   ;   r2dt = 2. * rdt   ! otherwise, = 2 rdt (leapfrog)
+      ENDIF
+      !
+      IF( l_trdtra )   THEN                  !* Save ta and sa trends
+         ALLOCATE( ztrdt(jpi,jpj,jpk) , ztrds(jpi,jpj,jpk) )
+         ztrdt(:,:,:) = tsa(:,:,:,jp_tem)
+         ztrds(:,:,:) = tsa(:,:,:,jp_sal)
+      ENDIF
+      !
+      !                                      !* compute lateral mixing trend and add it to the general trend
+      CALL tra_zdf_imp( kt, nit000, 'TRA', r2dt, tsb, tsa, jpts ) 
+
+!!gm WHY here !   and I don't like that !
+      ! DRAKKAR SSS control {
+      ! JMM avoid negative salinities near river outlet ! Ugly fix
+      ! JMM : restore negative salinities to small salinities:
+      WHERE( tsa(:,:,:,jp_sal) < 0._wp )   tsa(:,:,:,jp_sal) = 0.1_wp
+!!gm
+
+      IF( l_trdtra )   THEN                      ! save the vertical diffusive trends for further diagnostics
+         DO jk = 1, jpkm1
+            ztrdt(:,:,jk) = ( ( tsa(:,:,jk,jp_tem)*e3t_a(:,:,jk) - tsb(:,:,jk,jp_tem)*e3t_b(:,:,jk) ) &
+               &          / (e3t_n(:,:,jk)*r2dt) ) - ztrdt(:,:,jk)
+            ztrds(:,:,jk) = ( ( tsa(:,:,jk,jp_sal)*e3t_a(:,:,jk) - tsb(:,:,jk,jp_sal)*e3t_b(:,:,jk) ) &
+              &           / (e3t_n(:,:,jk)*r2dt) ) - ztrds(:,:,jk)
+         END DO
+!!gm this should be moved in trdtra.F90 and done on all trends
+         CALL lbc_lnk_multi( ztrdt, 'T', 1. , ztrds, 'T', 1. )
+!!gm
+         CALL trd_tra( kt, 'TRA', jp_tem, jptra_zdf, ztrdt )
+         CALL trd_tra( kt, 'TRA', jp_sal, jptra_zdf, ztrds )
+         DEALLOCATE( ztrdt , ztrds )
+      ENDIF
+      !                                          ! print mean trends (used for debugging)
+      IF(ln_ctl)   CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' zdf  - Ta: ', mask1=tmask,               &
+         &                       tab3d_2=tsa(:,:,:,jp_sal), clinfo2=       ' Sa: ', mask2=tmask, clinfo3='tra' )
+      !
+      IF( ln_timing )   CALL timing_stop('tra_zdf')
+      !
+   END SUBROUTINE tra_zdf
+
+ 
+   SUBROUTINE tra_zdf_imp( kt, kit000, cdtype, p2dt, ptb, pta, kjpt ) 
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE tra_zdf_imp  ***
+      !!
+      !! ** Purpose :   Compute the after tracer through a implicit computation
+      !!     of the vertical tracer diffusion (including the vertical component 
+      !!     of lateral mixing (only for 2nd order operator, for fourth order 
+      !!     it is already computed and add to the general trend in traldf) 
+      !!
+      !! ** Method  :  The vertical diffusion of a tracer ,t , is given by:
+      !!          difft = dz( avt dz(t) ) = 1/e3t dk+1( avt/e3w dk(t) )
+      !!      It is computed using a backward time scheme (t=after field)
+      !!      which provide directly the after tracer field.
+      !!      If ln_zdfddm=T, use avs for salinity or for passive tracers
+      !!      Surface and bottom boundary conditions: no diffusive flux on
+      !!      both tracers (bottom, applied through the masked field avt).
+      !!      If iso-neutral mixing, add to avt the contribution due to lateral mixing.
+      !!
+      !! ** Action  : - pta  becomes the after tracer
+      !!---------------------------------------------------------------------
+      INTEGER                              , INTENT(in   ) ::   kt       ! ocean time-step index
+      INTEGER                              , INTENT(in   ) ::   kit000   ! first time step index
+      CHARACTER(len=3)                     , INTENT(in   ) ::   cdtype   ! =TRA or TRC (tracer indicator)
+      INTEGER                              , INTENT(in   ) ::   kjpt     ! number of tracers
+      REAL(wp)                             , INTENT(in   ) ::   p2dt     ! tracer time-step
+      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   ) ::   ptb      ! before and now tracer fields
+      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) ::   pta      ! in: tracer trend ; out: after tracer field
+      !
+      INTEGER  ::  ji, jj, jk, jn   ! dummy loop indices
+      REAL(wp) ::  zrhs             ! local scalars
+      REAL(wp), DIMENSION(jpi,jpj,jpk) ::  zwi, zwt, zwd, zws
+      !!---------------------------------------------------------------------
+      !
+      !                                               ! ============= !
+      DO jn = 1, kjpt                                 !  tracer loop  !
+         !                                            ! ============= !
+         !  Matrix construction
+         ! --------------------
+         ! Build matrix if temperature or salinity (only in double diffusion case) or first passive tracer
+         !
+         IF(  ( cdtype == 'TRA' .AND. ( jn == jp_tem .OR. ( jn == jp_sal .AND. ln_zdfddm ) ) ) .OR.   &
+            & ( cdtype == 'TRC' .AND. jn == 1 )  )  THEN
+            !
+            ! vertical mixing coef.: avt for temperature, avs for salinity and passive tracers
+            IF( cdtype == 'TRA' .AND. jn == jp_tem ) THEN   ;   zwt(:,:,2:jpk) = avt(:,:,2:jpk)
+            ELSE                                            ;   zwt(:,:,2:jpk) = avs(:,:,2:jpk)
+            ENDIF
+            zwt(:,:,1) = 0._wp
+            !
+            IF( l_ldfslp ) THEN            ! isoneutral diffusion: add the contribution 
+               IF( ln_traldf_msc  ) THEN     ! MSC iso-neutral operator 
+                  DO jk = 2, jpkm1
+                     DO jj = 2, jpjm1
+                        DO ji = fs_2, fs_jpim1   ! vector opt.
+                           zwt(ji,jj,jk) = zwt(ji,jj,jk) + akz(ji,jj,jk)  
+                        END DO
+                     END DO
+                  END DO
+               ELSE                          ! standard or triad iso-neutral operator
+                  DO jk = 2, jpkm1
+                     DO jj = 2, jpjm1
+                        DO ji = fs_2, fs_jpim1   ! vector opt.
+                           zwt(ji,jj,jk) = zwt(ji,jj,jk) + ah_wslp2(ji,jj,jk)
+                        END DO
+                     END DO
+                  END DO
+               ENDIF
+            ENDIF
+            !
+            ! Diagonal, lower (i), upper (s)  (including the bottom boundary condition since avt is masked)
+            DO jk = 1, jpkm1
+               DO jj = 2, jpjm1
+                  DO ji = fs_2, fs_jpim1   ! vector opt.
+!!gm BUG  I think, use e3w_a instead of e3w_n, not sure of that
+                     zwi(ji,jj,jk) = - p2dt * zwt(ji,jj,jk  ) / e3w_n(ji,jj,jk  )
+                     zws(ji,jj,jk) = - p2dt * zwt(ji,jj,jk+1) / e3w_n(ji,jj,jk+1)
+                     zwd(ji,jj,jk) = e3t_a(ji,jj,jk) - zwi(ji,jj,jk) - zws(ji,jj,jk)
+                 END DO
+               END DO
+            END DO
+            !
+            !! Matrix inversion from the first level
+            !!----------------------------------------------------------------------
+            !   solve m.x = y  where m is a tri diagonal matrix ( jpk*jpk )
+            !
+            !        ( zwd1 zws1   0    0    0  )( zwx1 ) ( zwy1 )
+            !        ( zwi2 zwd2 zws2   0    0  )( zwx2 ) ( zwy2 )
+            !        (  0   zwi3 zwd3 zws3   0  )( zwx3 )=( zwy3 )
+            !        (        ...               )( ...  ) ( ...  )
+            !        (  0    0    0   zwik zwdk )( zwxk ) ( zwyk )
+            !
+            !   m is decomposed in the product of an upper and lower triangular matrix.
+            !   The 3 diagonal terms are in 3d arrays: zwd, zws, zwi.
+            !   Suffices i,s and d indicate "inferior" (below diagonal), diagonal
+            !   and "superior" (above diagonal) components of the tridiagonal system.
+            !   The solution will be in the 4d array pta.
+            !   The 3d array zwt is used as a work space array.
+            !   En route to the solution pta is used a to evaluate the rhs and then 
+            !   used as a work space array: its value is modified.
+            !
+            DO jj = 2, jpjm1        !* 1st recurrence:   Tk = Dk - Ik Sk-1 / Tk-1   (increasing k)
+               DO ji = fs_2, fs_jpim1            ! done one for all passive tracers (so included in the IF instruction)
+                  zwt(ji,jj,1) = zwd(ji,jj,1)
+               END DO
+            END DO
+            DO jk = 2, jpkm1
+               DO jj = 2, jpjm1
+                  DO ji = fs_2, fs_jpim1
+                     zwt(ji,jj,jk) = zwd(ji,jj,jk) - zwi(ji,jj,jk) * zws(ji,jj,jk-1) / zwt(ji,jj,jk-1)
+                  END DO
+               END DO
+            END DO
+            !
+         ENDIF 
+         !         
+         DO jj = 2, jpjm1           !* 2nd recurrence:    Zk = Yk - Ik / Tk-1  Zk-1
+            DO ji = fs_2, fs_jpim1
+               pta(ji,jj,1,jn) = e3t_b(ji,jj,1) * ptb(ji,jj,1,jn) + p2dt * e3t_n(ji,jj,1) * pta(ji,jj,1,jn)
+            END DO
+         END DO
+         DO jk = 2, jpkm1
+            DO jj = 2, jpjm1
+               DO ji = fs_2, fs_jpim1
+                  zrhs = e3t_b(ji,jj,jk) * ptb(ji,jj,jk,jn) + p2dt * e3t_n(ji,jj,jk) * pta(ji,jj,jk,jn)   ! zrhs=right hand side
+                  pta(ji,jj,jk,jn) = zrhs - zwi(ji,jj,jk) / zwt(ji,jj,jk-1) * pta(ji,jj,jk-1,jn)
+               END DO
+            END DO
+         END DO
+         !
+         DO jj = 2, jpjm1           !* 3d recurrence:    Xk = (Zk - Sk Xk+1 ) / Tk   (result is the after tracer)
+            DO ji = fs_2, fs_jpim1
+               pta(ji,jj,jpkm1,jn) = pta(ji,jj,jpkm1,jn) / zwt(ji,jj,jpkm1) * tmask(ji,jj,jpkm1)
+            END DO
+         END DO
+         DO jk = jpk-2, 1, -1
+            DO jj = 2, jpjm1
+               DO ji = fs_2, fs_jpim1
+                  pta(ji,jj,jk,jn) = ( pta(ji,jj,jk,jn) - zws(ji,jj,jk) * pta(ji,jj,jk+1,jn) )   &
+                     &             / zwt(ji,jj,jk) * tmask(ji,jj,jk)
+               END DO
+            END DO
+         END DO
+         !                                            ! ================= !
+      END DO                                          !  end tracer loop  !
+      !                                               ! ================= !
+   END SUBROUTINE tra_zdf_imp
+
+   !!==============================================================================
+END MODULE trazdf
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/TRA/zpshde.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/TRA/zpshde.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/TRA/zpshde.F90	(revision 9570)
@@ -0,0 +1,460 @@
+MODULE zpshde
+   !!======================================================================
+   !!                       ***  MODULE zpshde   ***
+   !! z-coordinate + partial step : Horizontal Derivative at ocean bottom level
+   !!======================================================================
+   !! History :  OPA  !  2002-04  (A. Bozec)  Original code
+   !!   NEMO     1.0  !  2002-08  (G. Madec E. Durand)  Optimization and Free form
+   !!             -   !  2004-03  (C. Ethe)  adapted for passive tracers
+   !!            3.3  !  2010-05  (C. Ethe, G. Madec)  merge TRC-TRA 
+   !!            3.6  !  2014-11  (P. Mathiot) Add zps_hde_isf (needed to open a cavity)
+   !!======================================================================
+   
+   !!----------------------------------------------------------------------
+   !!   zps_hde      :  Horizontal DErivative of T, S and rd at the last
+   !!                   ocean level (Z-coord. with Partial Steps)
+   !!----------------------------------------------------------------------
+   USE oce             ! ocean: dynamics and tracers variables
+   USE dom_oce         ! domain: ocean variables
+   USE phycst          ! physical constants
+   USE eosbn2          ! ocean equation of state
+   USE in_out_manager  ! I/O manager
+   USE lbclnk          ! lateral boundary conditions (or mpp link)
+   USE lib_mpp         ! MPP library
+   USE timing          ! Timing
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   zps_hde     ! routine called by step.F90
+   PUBLIC   zps_hde_isf ! routine called by step.F90
+
+   !! * Substitutions
+#  include "vectopt_loop_substitute.h90"
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO Consortium (2010)
+   !! $Id$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE zps_hde( kt, kjpt, pta, pgtu, pgtv,   &
+      &                          prd, pgru, pgrv    )
+      !!----------------------------------------------------------------------
+      !!                     ***  ROUTINE zps_hde  ***
+      !!                    
+      !! ** Purpose :   Compute the horizontal derivative of T, S and rho
+      !!      at u- and v-points with a linear interpolation for z-coordinate
+      !!      with partial steps.
+      !!
+      !! ** Method  :   In z-coord with partial steps, scale factors on last 
+      !!      levels are different for each grid point, so that T, S and rd 
+      !!      points are not at the same depth as in z-coord. To have horizontal
+      !!      gradients again, we interpolate T and S at the good depth : 
+      !!      Linear interpolation of T, S   
+      !!         Computation of di(tb) and dj(tb) by vertical interpolation:
+      !!          di(t) = t~ - t(i,j,k) or t(i+1,j,k) - t~
+      !!          dj(t) = t~ - t(i,j,k) or t(i,j+1,k) - t~
+      !!         This formulation computes the two cases:
+      !!                 CASE 1                   CASE 2  
+      !!         k-1  ___ ___________   k-1   ___ ___________
+      !!                    Ti  T~                  T~  Ti+1
+      !!                  _____                        _____
+      !!         k        |   |Ti+1     k           Ti |   |
+      !!                  |   |____                ____|   |
+      !!              ___ |   |   |           ___  |   |   |
+      !!                  
+      !!      case 1->   e3w(i+1) >= e3w(i) ( and e3w(j+1) >= e3w(j) ) then
+      !!          t~ = t(i+1,j  ,k) + (e3w(i+1) - e3w(i)) * dk(Ti+1)/e3w(i+1)
+      !!        ( t~ = t(i  ,j+1,k) + (e3w(j+1) - e3w(j)) * dk(Tj+1)/e3w(j+1)  )
+      !!          or
+      !!      case 2->   e3w(i+1) <= e3w(i) ( and e3w(j+1) <= e3w(j) ) then
+      !!          t~ = t(i,j,k) + (e3w(i) - e3w(i+1)) * dk(Ti)/e3w(i )
+      !!        ( t~ = t(i,j,k) + (e3w(j) - e3w(j+1)) * dk(Tj)/e3w(j ) )
+      !!          Idem for di(s) and dj(s)          
+      !!
+      !!      For rho, we call eos which will compute rd~(t~,s~) at the right
+      !!      depth zh from interpolated T and S for the different formulations
+      !!      of the equation of state (eos).
+      !!      Gradient formulation for rho :
+      !!          di(rho) = rd~ - rd(i,j,k)   or   rd(i+1,j,k) - rd~
+      !!
+      !! ** Action  : compute for top interfaces
+      !!              - pgtu, pgtv: horizontal gradient of tracer at u- & v-points
+      !!              - pgru, pgrv: horizontal gradient of rho (if present) at u- & v-points
+      !!----------------------------------------------------------------------
+      INTEGER                              , INTENT(in   )           ::  kt          ! ocean time-step index
+      INTEGER                              , INTENT(in   )           ::  kjpt        ! number of tracers
+      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   )           ::  pta         ! 4D tracers fields
+      REAL(wp), DIMENSION(jpi,jpj,    kjpt), INTENT(  out)           ::  pgtu, pgtv  ! hor. grad. of ptra at u- & v-pts 
+      REAL(wp), DIMENSION(jpi,jpj,jpk     ), INTENT(in   ), OPTIONAL ::  prd         ! 3D density anomaly fields
+      REAL(wp), DIMENSION(jpi,jpj         ), INTENT(  out), OPTIONAL ::  pgru, pgrv  ! hor. grad of prd at u- & v-pts (bottom)
+      !
+      INTEGER  ::   ji, jj, jn                  ! Dummy loop indices
+      INTEGER  ::   iku, ikv, ikum1, ikvm1      ! partial step level (ocean bottom level) at u- and v-points
+      REAL(wp) ::   ze3wu, ze3wv, zmaxu, zmaxv  ! local scalars
+      REAL(wp), DIMENSION(jpi,jpj)      ::   zri, zrj, zhi, zhj   ! NB: 3rd dim=1 to use eos
+      REAL(wp), DIMENSION(jpi,jpj,kjpt) ::   zti, ztj             ! 
+      !!----------------------------------------------------------------------
+      !
+      IF( ln_timing )   CALL timing_start( 'zps_hde')
+      !
+      pgtu(:,:,:) = 0._wp   ;   zti (:,:,:) = 0._wp   ;   zhi (:,:) = 0._wp
+      pgtv(:,:,:) = 0._wp   ;   ztj (:,:,:) = 0._wp   ;   zhj (:,:) = 0._wp
+      !
+      DO jn = 1, kjpt      !==   Interpolation of tracers at the last ocean level   ==!
+         !
+         DO jj = 1, jpjm1
+            DO ji = 1, jpim1
+               iku = mbku(ji,jj)   ;   ikum1 = MAX( iku - 1 , 1 )    ! last and before last ocean level at u- & v-points
+               ikv = mbkv(ji,jj)   ;   ikvm1 = MAX( ikv - 1 , 1 )    ! if level first is a p-step, ik.m1=1
+!!gm BUG ? when applied to before fields, e3w_b should be used....
+               ze3wu = e3w_n(ji+1,jj  ,iku) - e3w_n(ji,jj,iku)
+               ze3wv = e3w_n(ji  ,jj+1,ikv) - e3w_n(ji,jj,ikv)
+               !
+               ! i- direction
+               IF( ze3wu >= 0._wp ) THEN      ! case 1
+                  zmaxu =  ze3wu / e3w_n(ji+1,jj,iku)
+                  ! interpolated values of tracers
+                  zti (ji,jj,jn) = pta(ji+1,jj,iku,jn) + zmaxu * ( pta(ji+1,jj,ikum1,jn) - pta(ji+1,jj,iku,jn) )
+                  ! gradient of  tracers
+                  pgtu(ji,jj,jn) = umask(ji,jj,1) * ( zti(ji,jj,jn) - pta(ji,jj,iku,jn) )
+               ELSE                           ! case 2
+                  zmaxu = -ze3wu / e3w_n(ji,jj,iku)
+                  ! interpolated values of tracers
+                  zti (ji,jj,jn) = pta(ji,jj,iku,jn) + zmaxu * ( pta(ji,jj,ikum1,jn) - pta(ji,jj,iku,jn) )
+                  ! gradient of tracers
+                  pgtu(ji,jj,jn) = umask(ji,jj,1) * ( pta(ji+1,jj,iku,jn) - zti(ji,jj,jn) )
+               ENDIF
+               !
+               ! j- direction
+               IF( ze3wv >= 0._wp ) THEN      ! case 1
+                  zmaxv =  ze3wv / e3w_n(ji,jj+1,ikv)
+                  ! interpolated values of tracers
+                  ztj (ji,jj,jn) = pta(ji,jj+1,ikv,jn) + zmaxv * ( pta(ji,jj+1,ikvm1,jn) - pta(ji,jj+1,ikv,jn) )
+                  ! gradient of tracers
+                  pgtv(ji,jj,jn) = vmask(ji,jj,1) * ( ztj(ji,jj,jn) - pta(ji,jj,ikv,jn) )
+               ELSE                           ! case 2
+                  zmaxv =  -ze3wv / e3w_n(ji,jj,ikv)
+                  ! interpolated values of tracers
+                  ztj (ji,jj,jn) = pta(ji,jj,ikv,jn) + zmaxv * ( pta(ji,jj,ikvm1,jn) - pta(ji,jj,ikv,jn) )
+                  ! gradient of tracers
+                  pgtv(ji,jj,jn) = vmask(ji,jj,1) * ( pta(ji,jj+1,ikv,jn) - ztj(ji,jj,jn) )
+               ENDIF
+            END DO
+         END DO
+         CALL lbc_lnk_multi( pgtu(:,:,jn), 'U', -1. , pgtv(:,:,jn), 'V', -1. )   ! Lateral boundary cond.
+         !
+      END DO
+      !                
+      IF( PRESENT( prd ) ) THEN    !==  horizontal derivative of density anomalies (rd)  ==!    (optional part)
+         pgru(:,:) = 0._wp
+         pgrv(:,:) = 0._wp                ! depth of the partial step level
+         DO jj = 1, jpjm1
+            DO ji = 1, jpim1
+               iku = mbku(ji,jj)
+               ikv = mbkv(ji,jj)
+               ze3wu  = e3w_n(ji+1,jj  ,iku) - e3w_n(ji,jj,iku)
+               ze3wv  = e3w_n(ji  ,jj+1,ikv) - e3w_n(ji,jj,ikv)
+               IF( ze3wu >= 0._wp ) THEN   ;   zhi(ji,jj) = gdept_n(ji  ,jj,iku)     ! i-direction: case 1
+               ELSE                        ;   zhi(ji,jj) = gdept_n(ji+1,jj,iku)     ! -     -      case 2
+               ENDIF
+               IF( ze3wv >= 0._wp ) THEN   ;   zhj(ji,jj) = gdept_n(ji,jj  ,ikv)     ! j-direction: case 1
+               ELSE                        ;   zhj(ji,jj) = gdept_n(ji,jj+1,ikv)     ! -     -      case 2
+               ENDIF
+            END DO
+         END DO
+         !
+         CALL eos( zti, zhi, zri )        ! interpolated density from zti, ztj 
+         CALL eos( ztj, zhj, zrj )        ! at the partial step depth output in  zri, zrj 
+         !
+         DO jj = 1, jpjm1                 ! Gradient of density at the last level 
+            DO ji = 1, jpim1
+               iku = mbku(ji,jj)
+               ikv = mbkv(ji,jj)
+               ze3wu  = e3w_n(ji+1,jj  ,iku) - e3w_n(ji,jj,iku)
+               ze3wv  = e3w_n(ji  ,jj+1,ikv) - e3w_n(ji,jj,ikv)
+               IF( ze3wu >= 0._wp ) THEN   ;   pgru(ji,jj) = umask(ji,jj,1) * ( zri(ji  ,jj    ) - prd(ji,jj,iku) )   ! i: 1
+               ELSE                        ;   pgru(ji,jj) = umask(ji,jj,1) * ( prd(ji+1,jj,iku) - zri(ji,jj    ) )   ! i: 2
+               ENDIF
+               IF( ze3wv >= 0._wp ) THEN   ;   pgrv(ji,jj) = vmask(ji,jj,1) * ( zrj(ji,jj      ) - prd(ji,jj,ikv) )   ! j: 1
+               ELSE                        ;   pgrv(ji,jj) = vmask(ji,jj,1) * ( prd(ji,jj+1,ikv) - zrj(ji,jj    ) )   ! j: 2
+               ENDIF
+            END DO
+         END DO
+         CALL lbc_lnk_multi( pgru , 'U', -1. , pgrv , 'V', -1. )   ! Lateral boundary conditions
+         !
+      END IF
+      !
+      IF( ln_timing )   CALL timing_stop( 'zps_hde')
+      !
+   END SUBROUTINE zps_hde
+
+
+   SUBROUTINE zps_hde_isf( kt, kjpt, pta, pgtu, pgtv, pgtui, pgtvi,  &
+      &                          prd, pgru, pgrv, pgrui, pgrvi )
+      !!----------------------------------------------------------------------
+      !!                     ***  ROUTINE zps_hde_isf  ***
+      !!                    
+      !! ** Purpose :   Compute the horizontal derivative of T, S and rho
+      !!      at u- and v-points with a linear interpolation for z-coordinate
+      !!      with partial steps for top (ice shelf) and bottom.
+      !!
+      !! ** Method  :   In z-coord with partial steps, scale factors on last 
+      !!      levels are different for each grid point, so that T, S and rd 
+      !!      points are not at the same depth as in z-coord. To have horizontal
+      !!      gradients again, we interpolate T and S at the good depth :
+      !!      For the bottom case:
+      !!      Linear interpolation of T, S   
+      !!         Computation of di(tb) and dj(tb) by vertical interpolation:
+      !!          di(t) = t~ - t(i,j,k) or t(i+1,j,k) - t~
+      !!          dj(t) = t~ - t(i,j,k) or t(i,j+1,k) - t~
+      !!         This formulation computes the two cases:
+      !!                 CASE 1                   CASE 2  
+      !!         k-1  ___ ___________   k-1   ___ ___________
+      !!                    Ti  T~                  T~  Ti+1
+      !!                  _____                        _____
+      !!         k        |   |Ti+1     k           Ti |   |
+      !!                  |   |____                ____|   |
+      !!              ___ |   |   |           ___  |   |   |
+      !!                  
+      !!      case 1->   e3w(i+1) >= e3w(i) ( and e3w(j+1) >= e3w(j) ) then
+      !!          t~ = t(i+1,j  ,k) + (e3w(i+1) - e3w(i)) * dk(Ti+1)/e3w(i+1)
+      !!        ( t~ = t(i  ,j+1,k) + (e3w(j+1) - e3w(j)) * dk(Tj+1)/e3w(j+1)  )
+      !!          or
+      !!      case 2->   e3w(i+1) <= e3w(i) ( and e3w(j+1) <= e3w(j) ) then
+      !!          t~ = t(i,j,k) + (e3w(i) - e3w(i+1)) * dk(Ti)/e3w(i )
+      !!        ( t~ = t(i,j,k) + (e3w(j) - e3w(j+1)) * dk(Tj)/e3w(j ) )
+      !!          Idem for di(s) and dj(s)          
+      !!
+      !!      For rho, we call eos which will compute rd~(t~,s~) at the right
+      !!      depth zh from interpolated T and S for the different formulations
+      !!      of the equation of state (eos).
+      !!      Gradient formulation for rho :
+      !!          di(rho) = rd~ - rd(i,j,k)   or   rd(i+1,j,k) - rd~
+      !!
+      !!      For the top case (ice shelf): As for the bottom case but upside down
+      !!
+      !! ** Action  : compute for top and bottom interfaces
+      !!              - pgtu, pgtv, pgtui, pgtvi: horizontal gradient of tracer at u- & v-points
+      !!              - pgru, pgrv, pgrui, pgtvi: horizontal gradient of rho (if present) at u- & v-points
+      !!----------------------------------------------------------------------
+      INTEGER                              , INTENT(in   )           ::  kt           ! ocean time-step index
+      INTEGER                              , INTENT(in   )           ::  kjpt         ! number of tracers
+      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   )           ::  pta          ! 4D tracers fields
+      REAL(wp), DIMENSION(jpi,jpj,    kjpt), INTENT(  out)           ::  pgtu, pgtv   ! hor. grad. of ptra at u- & v-pts 
+      REAL(wp), DIMENSION(jpi,jpj,    kjpt), INTENT(  out)           ::  pgtui, pgtvi ! hor. grad. of stra at u- & v-pts (ISF)
+      REAL(wp), DIMENSION(jpi,jpj,jpk     ), INTENT(in   ), OPTIONAL ::  prd          ! 3D density anomaly fields
+      REAL(wp), DIMENSION(jpi,jpj         ), INTENT(  out), OPTIONAL ::  pgru, pgrv   ! hor. grad of prd at u- & v-pts (bottom)
+      REAL(wp), DIMENSION(jpi,jpj         ), INTENT(  out), OPTIONAL ::  pgrui, pgrvi ! hor. grad of prd at u- & v-pts (top)
+      !
+      INTEGER  ::   ji, jj, jn      ! Dummy loop indices
+      INTEGER  ::   iku, ikv, ikum1, ikvm1,ikup1, ikvp1   ! partial step level (ocean bottom level) at u- and v-points
+      REAL(wp) ::  ze3wu, ze3wv, zmaxu, zmaxv             ! temporary scalars
+      REAL(wp), DIMENSION(jpi,jpj)      ::  zri, zrj, zhi, zhj   ! NB: 3rd dim=1 to use eos
+      REAL(wp), DIMENSION(jpi,jpj,kjpt) ::  zti, ztj             ! 
+      !!----------------------------------------------------------------------
+      !
+      IF( ln_timing )   CALL timing_start( 'zps_hde_isf')
+      !
+      pgtu (:,:,:) = 0._wp   ;   pgtv (:,:,:) =0._wp
+      pgtui(:,:,:) = 0._wp   ;   pgtvi(:,:,:) =0._wp
+      zti  (:,:,:) = 0._wp   ;   ztj  (:,:,:) =0._wp
+      zhi  (:,:  ) = 0._wp   ;   zhj  (:,:  ) =0._wp
+      !
+      DO jn = 1, kjpt      !==   Interpolation of tracers at the last ocean level   ==!
+         !
+         DO jj = 1, jpjm1
+            DO ji = 1, jpim1
+
+               iku = mbku(ji,jj); ikum1 = MAX( iku - 1 , 1 )    ! last and before last ocean level at u- & v-points
+               ikv = mbkv(ji,jj); ikvm1 = MAX( ikv - 1 , 1 )    ! if level first is a p-step, ik.m1=1
+               ze3wu = gdept_n(ji+1,jj,iku) - gdept_n(ji,jj,iku)
+               ze3wv = gdept_n(ji,jj+1,ikv) - gdept_n(ji,jj,ikv)
+               !
+               ! i- direction
+               IF( ze3wu >= 0._wp ) THEN      ! case 1
+                  zmaxu =  ze3wu / e3w_n(ji+1,jj,iku)
+                  ! interpolated values of tracers
+                  zti (ji,jj,jn) = pta(ji+1,jj,iku,jn) + zmaxu * ( pta(ji+1,jj,ikum1,jn) - pta(ji+1,jj,iku,jn) )
+                  ! gradient of  tracers
+                  pgtu(ji,jj,jn) = ssumask(ji,jj) * ( zti(ji,jj,jn) - pta(ji,jj,iku,jn) )
+               ELSE                           ! case 2
+                  zmaxu = -ze3wu / e3w_n(ji,jj,iku)
+                  ! interpolated values of tracers
+                  zti (ji,jj,jn) = pta(ji,jj,iku,jn) + zmaxu * ( pta(ji,jj,ikum1,jn) - pta(ji,jj,iku,jn) )
+                  ! gradient of tracers
+                  pgtu(ji,jj,jn) = ssumask(ji,jj) * ( pta(ji+1,jj,iku,jn) - zti(ji,jj,jn) )
+               ENDIF
+               !
+               ! j- direction
+               IF( ze3wv >= 0._wp ) THEN      ! case 1
+                  zmaxv =  ze3wv / e3w_n(ji,jj+1,ikv)
+                  ! interpolated values of tracers
+                  ztj (ji,jj,jn) = pta(ji,jj+1,ikv,jn) + zmaxv * ( pta(ji,jj+1,ikvm1,jn) - pta(ji,jj+1,ikv,jn) )
+                  ! gradient of tracers
+                  pgtv(ji,jj,jn) = ssvmask(ji,jj) * ( ztj(ji,jj,jn) - pta(ji,jj,ikv,jn) )
+               ELSE                           ! case 2
+                  zmaxv =  -ze3wv / e3w_n(ji,jj,ikv)
+                  ! interpolated values of tracers
+                  ztj (ji,jj,jn) = pta(ji,jj,ikv,jn) + zmaxv * ( pta(ji,jj,ikvm1,jn) - pta(ji,jj,ikv,jn) )
+                  ! gradient of tracers
+                  pgtv(ji,jj,jn) = ssvmask(ji,jj) * ( pta(ji,jj+1,ikv,jn) - ztj(ji,jj,jn) )
+               ENDIF
+
+            END DO
+         END DO
+         CALL lbc_lnk_multi( pgtu(:,:,jn), 'U', -1. , pgtv(:,:,jn), 'V', -1. )   ! Lateral boundary cond.
+         !
+      END DO
+
+      ! horizontal derivative of density anomalies (rd)
+      IF( PRESENT( prd ) ) THEN         ! depth of the partial step level
+         pgru(:,:)=0.0_wp   ; pgrv(:,:)=0.0_wp ; 
+         !
+         DO jj = 1, jpjm1
+            DO ji = 1, jpim1
+
+               iku = mbku(ji,jj)
+               ikv = mbkv(ji,jj)
+               ze3wu = gdept_n(ji+1,jj,iku) - gdept_n(ji,jj,iku)
+               ze3wv = gdept_n(ji,jj+1,ikv) - gdept_n(ji,jj,ikv)
+               !
+               IF( ze3wu >= 0._wp ) THEN   ;   zhi(ji,jj) = gdept_n(ji  ,jj,iku)    ! i-direction: case 1
+               ELSE                        ;   zhi(ji,jj) = gdept_n(ji+1,jj,iku)    ! -     -      case 2
+               ENDIF
+               IF( ze3wv >= 0._wp ) THEN   ;   zhj(ji,jj) = gdept_n(ji,jj  ,ikv)    ! j-direction: case 1
+               ELSE                        ;   zhj(ji,jj) = gdept_n(ji,jj+1,ikv)    ! -     -      case 2
+               ENDIF
+
+            END DO
+         END DO
+
+         ! Compute interpolated rd from zti, ztj for the 2 cases at the depth of the partial
+         ! step and store it in  zri, zrj for each  case
+         CALL eos( zti, zhi, zri )
+         CALL eos( ztj, zhj, zrj )
+
+         DO jj = 1, jpjm1                 ! Gradient of density at the last level 
+            DO ji = 1, jpim1
+               iku = mbku(ji,jj)
+               ikv = mbkv(ji,jj)
+               ze3wu = gdept_n(ji+1,jj,iku) - gdept_n(ji,jj,iku)
+               ze3wv = gdept_n(ji,jj+1,ikv) - gdept_n(ji,jj,ikv)
+
+               IF( ze3wu >= 0._wp ) THEN   ;   pgru(ji,jj) = ssumask(ji,jj) * ( zri(ji  ,jj    ) - prd(ji,jj,iku) )   ! i: 1
+               ELSE                        ;   pgru(ji,jj) = ssumask(ji,jj) * ( prd(ji+1,jj,iku) - zri(ji,jj    ) )   ! i: 2
+               ENDIF
+               IF( ze3wv >= 0._wp ) THEN   ;   pgrv(ji,jj) = ssvmask(ji,jj) * ( zrj(ji,jj      ) - prd(ji,jj,ikv) )   ! j: 1
+               ELSE                        ;   pgrv(ji,jj) = ssvmask(ji,jj) * ( prd(ji,jj+1,ikv) - zrj(ji,jj    ) )   ! j: 2
+               ENDIF
+
+            END DO
+         END DO
+
+         CALL lbc_lnk_multi( pgru , 'U', -1. , pgrv , 'V', -1. )   ! Lateral boundary conditions
+         !
+      END IF
+      !
+      !     !==  (ISH)  compute grui and gruvi  ==!
+      !
+      DO jn = 1, kjpt      !==   Interpolation of tracers at the last ocean level   ==!            !
+         DO jj = 1, jpjm1
+            DO ji = 1, jpim1
+               iku = miku(ji,jj); ikup1 = miku(ji,jj) + 1
+               ikv = mikv(ji,jj); ikvp1 = mikv(ji,jj) + 1
+               !
+               ! (ISF) case partial step top and bottom in adjacent cell in vertical
+               ! cannot used e3w because if 2 cell water column, we have ps at top and bottom
+               ! in this case e3w(i,j) - e3w(i,j+1) is not the distance between Tj~ and Tj
+               ! the only common depth between cells (i,j) and (i,j+1) is gdepw_0
+               ze3wu  =  gdept_n(ji,jj,iku) - gdept_n(ji+1,jj,iku)
+               ze3wv  =  gdept_n(ji,jj,ikv) - gdept_n(ji,jj+1,ikv) 
+
+               ! i- direction
+               IF( ze3wu >= 0._wp ) THEN      ! case 1
+                  zmaxu = ze3wu / e3w_n(ji+1,jj,ikup1)
+                  ! interpolated values of tracers
+                  zti(ji,jj,jn) = pta(ji+1,jj,iku,jn) + zmaxu * ( pta(ji+1,jj,ikup1,jn) - pta(ji+1,jj,iku,jn) )
+                  ! gradient of tracers
+                  pgtui(ji,jj,jn) = ssumask(ji,jj) * ( zti(ji,jj,jn) - pta(ji,jj,iku,jn) )
+               ELSE                           ! case 2
+                  zmaxu = - ze3wu / e3w_n(ji,jj,ikup1)
+                  ! interpolated values of tracers
+                  zti(ji,jj,jn) = pta(ji,jj,iku,jn) + zmaxu * ( pta(ji,jj,ikup1,jn) - pta(ji,jj,iku,jn) )
+                  ! gradient of  tracers
+                  pgtui(ji,jj,jn) = ssumask(ji,jj) * ( pta(ji+1,jj,iku,jn) - zti(ji,jj,jn) )
+               ENDIF
+               !
+               ! j- direction
+               IF( ze3wv >= 0._wp ) THEN      ! case 1
+                  zmaxv =  ze3wv / e3w_n(ji,jj+1,ikvp1)
+                  ! interpolated values of tracers
+                  ztj(ji,jj,jn) = pta(ji,jj+1,ikv,jn) + zmaxv * ( pta(ji,jj+1,ikvp1,jn) - pta(ji,jj+1,ikv,jn) )
+                  ! gradient of tracers
+                  pgtvi(ji,jj,jn) = ssvmask(ji,jj) * ( ztj(ji,jj,jn) - pta(ji,jj,ikv,jn) )
+               ELSE                           ! case 2
+                  zmaxv =  - ze3wv / e3w_n(ji,jj,ikvp1)
+                  ! interpolated values of tracers
+                  ztj(ji,jj,jn) = pta(ji,jj,ikv,jn) + zmaxv * ( pta(ji,jj,ikvp1,jn) - pta(ji,jj,ikv,jn) )
+                  ! gradient of tracers
+                  pgtvi(ji,jj,jn) = ssvmask(ji,jj) * ( pta(ji,jj+1,ikv,jn) - ztj(ji,jj,jn) )
+               ENDIF
+
+            END DO
+         END DO
+         !
+      END DO
+      CALL lbc_lnk_multi( pgtui(:,:,:), 'U', -1. , pgtvi(:,:,:), 'V', -1. )   ! Lateral boundary cond.
+
+      IF( PRESENT( prd ) ) THEN    !==  horizontal derivative of density anomalies (rd)  ==!    (optional part)
+         !
+         pgrui(:,:)  =0.0_wp; pgrvi(:,:)  =0.0_wp;
+         DO jj = 1, jpjm1
+            DO ji = 1, jpim1
+
+               iku = miku(ji,jj)
+               ikv = mikv(ji,jj)
+               ze3wu  =  gdept_n(ji,jj,iku) - gdept_n(ji+1,jj,iku)
+               ze3wv  =  gdept_n(ji,jj,ikv) - gdept_n(ji,jj+1,ikv) 
+               !
+               IF( ze3wu >= 0._wp ) THEN   ;   zhi(ji,jj) = gdept_n(ji  ,jj,iku)    ! i-direction: case 1
+               ELSE                        ;   zhi(ji,jj) = gdept_n(ji+1,jj,iku)    ! -     -      case 2
+               ENDIF
+
+               IF( ze3wv >= 0._wp ) THEN   ;   zhj(ji,jj) = gdept_n(ji,jj  ,ikv)    ! j-direction: case 1
+               ELSE                        ;   zhj(ji,jj) = gdept_n(ji,jj+1,ikv)    ! -     -      case 2
+               ENDIF
+
+            END DO
+         END DO
+         !
+         CALL eos( zti, zhi, zri )        ! interpolated density from zti, ztj 
+         CALL eos( ztj, zhj, zrj )        ! at the partial step depth output in  zri, zrj 
+         !
+         DO jj = 1, jpjm1                 ! Gradient of density at the last level 
+            DO ji = 1, jpim1
+               iku = miku(ji,jj) 
+               ikv = mikv(ji,jj) 
+               ze3wu  =  gdept_n(ji,jj,iku) - gdept_n(ji+1,jj,iku)
+               ze3wv  =  gdept_n(ji,jj,ikv) - gdept_n(ji,jj+1,ikv) 
+
+               IF( ze3wu >= 0._wp ) THEN ; pgrui(ji,jj) = ssumask(ji,jj) * ( zri(ji  ,jj      ) - prd(ji,jj,iku) ) ! i: 1
+               ELSE                      ; pgrui(ji,jj) = ssumask(ji,jj) * ( prd(ji+1,jj  ,iku) - zri(ji,jj    ) ) ! i: 2
+               ENDIF
+               IF( ze3wv >= 0._wp ) THEN ; pgrvi(ji,jj) = ssvmask(ji,jj) * ( zrj(ji  ,jj      ) - prd(ji,jj,ikv) ) ! j: 1
+               ELSE                      ; pgrvi(ji,jj) = ssvmask(ji,jj) * ( prd(ji  ,jj+1,ikv) - zrj(ji,jj    ) ) ! j: 2
+               ENDIF
+
+            END DO
+         END DO
+         CALL lbc_lnk_multi( pgrui, 'U', -1. , pgrvi, 'V', -1. )   ! Lateral boundary conditions
+         !
+      END IF  
+      !
+      IF( ln_timing )   CALL timing_stop( 'zps_hde_isf')
+      !
+   END SUBROUTINE zps_hde_isf
+
+   !!======================================================================
+END MODULE zpshde
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/TRD/trd_oce.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/TRD/trd_oce.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/TRD/trd_oce.F90	(revision 9570)
@@ -0,0 +1,82 @@
+MODULE trd_oce
+   !!======================================================================
+   !!                   ***  MODULE trd_oce  ***
+   !! Ocean trends :   set tracer and momentum trend variables
+   !!======================================================================
+   !! History :  1.0  !  2004-08  (C. Talandier) Original code
+   !!----------------------------------------------------------------------
+   USE par_oce                 ! ocean parameters
+   USE trdmxl_oce              ! ocean active mixed layer tracers trends variables
+   USE trdvor_oce              ! ocean vorticity trends variables
+
+   IMPLICIT NONE
+   PUBLIC
+
+   !                                                   !!* Namelist namtrd:  diagnostics on dynamics/tracer trends *
+   LOGICAL , PUBLIC  ::   ln_dyn_trd   = .FALSE.        !: (T) 3D momentum             trends or (F) not
+   LOGICAL , PUBLIC  ::   ln_tra_trd   = .FALSE.        !: (T) 3D tracer               trends or (F) not
+   LOGICAL , PUBLIC  ::   ln_KE_trd    = .FALSE.        !: (T) 3D Kinetic   Energy     trends or (F) not
+   LOGICAL , PUBLIC  ::   ln_PE_trd    = .FALSE.        !: (T) 3D Potential Energy     trends or (F) not
+   LOGICAL , PUBLIC  ::   ln_vor_trd   = .FALSE.        !: (T) 3D barotropic vorticity trends or (F) not
+   LOGICAL , PUBLIC  ::   ln_glo_trd   = .FALSE.        !: (T) global domain averaged diag for T, T^2, KE, and PE
+   LOGICAL , PUBLIC  ::   ln_dyn_mxl   = .FALSE.        !: (T) 2D tracer   trends averaged over the mixed layer 
+   LOGICAL , PUBLIC  ::   ln_tra_mxl   = .FALSE.        !: (T) 2D momentum trends averaged over the mixed layer 
+   INTEGER , PUBLIC  ::   nn_trd       = 10             !: time step frequency for ln_glo_trd=T only
+
+   LOGICAL , PUBLIC ::   l_trdtra        !: tracers  trend flag (set from namelist in trdini)
+   LOGICAL , PUBLIC ::   l_trddyn        !: momentum trend flag (set from namelist in trdini)
+   
+# if ( defined key_trdtrc && defined key_iomput )  ||  defined key_trdmxl_trc
+   LOGICAL , PUBLIC ::   l_trdtrc = .TRUE.        !: tracers  trend flag
+# else
+   LOGICAL , PUBLIC ::   l_trdtrc = .FALSE.       !: tracers  trend flag
+# endif
+   !                                                  !!!* Active tracers trends indexes
+   INTEGER, PUBLIC, PARAMETER ::   jptot_tra  = 20     !: Total trend nb: change it when adding/removing one indice below
+   !                               ===============     !  
+   INTEGER, PUBLIC, PARAMETER ::   jptra_xad  =  1     !: x- horizontal advection
+   INTEGER, PUBLIC, PARAMETER ::   jptra_yad  =  2     !: y- horizontal advection
+   INTEGER, PUBLIC, PARAMETER ::   jptra_zad  =  3     !: z- vertical   advection
+   INTEGER, PUBLIC, PARAMETER ::   jptra_sad  =  4     !: z- vertical   advection
+   INTEGER, PUBLIC, PARAMETER ::   jptra_totad  =  5   !: total         advection
+   INTEGER, PUBLIC, PARAMETER ::   jptra_ldf  =  6     !: lateral       diffusion
+   INTEGER, PUBLIC, PARAMETER ::   jptra_zdf  =  7     !: vertical      diffusion
+   INTEGER, PUBLIC, PARAMETER ::   jptra_zdfp =  8     !: "PURE" vert.  diffusion (ln_traldf_iso=T)
+   INTEGER, PUBLIC, PARAMETER ::   jptra_evd  =  9     !: EVD term (convection)
+   INTEGER, PUBLIC, PARAMETER ::   jptra_bbc  = 10     !: Bottom Boundary Condition (geoth. heating) 
+   INTEGER, PUBLIC, PARAMETER ::   jptra_bbl  = 11     !: Bottom Boundary Layer (diffusive and/or advective)
+   INTEGER, PUBLIC, PARAMETER ::   jptra_npc  = 12     !: non-penetrative convection treatment
+   INTEGER, PUBLIC, PARAMETER ::   jptra_dmp  = 13     !: internal restoring (damping)
+   INTEGER, PUBLIC, PARAMETER ::   jptra_qsr  = 14     !: penetrative solar radiation
+   INTEGER, PUBLIC, PARAMETER ::   jptra_nsr  = 15     !: non solar radiation / C/D on salinity  (+runoff if ln_rnf=T)
+   INTEGER, PUBLIC, PARAMETER ::   jptra_atf  = 16     !: Asselin time filter
+   INTEGER, PUBLIC, PARAMETER ::   jptra_tot  = 17     !: Model total trend
+   !
+   !                                                  !!!* Passive tracers trends indices (use if "key_top" defined)
+   INTEGER, PUBLIC, PARAMETER ::   jptra_sms  = 18     !: sources m. sinks
+   INTEGER, PUBLIC, PARAMETER ::   jptra_radn = 19     !: corr. trn<0 in trcrad
+   INTEGER, PUBLIC, PARAMETER ::   jptra_radb = 20     !: corr. trb<0 in trcrad (like atf)
+   !
+   !                                                  !!!* Momentum trends indices
+   INTEGER, PUBLIC, PARAMETER ::   jptot_dyn  = 13     !: Total trend nb: change it when adding/removing one indice below
+   !                               ===============     !  
+   INTEGER, PUBLIC, PARAMETER ::   jpdyn_hpg  =  1     !: hydrostatic pressure gradient 
+   INTEGER, PUBLIC, PARAMETER ::   jpdyn_spg  =  2     !: surface     pressure gradient
+   INTEGER, PUBLIC, PARAMETER ::   jpdyn_keg  =  3     !: kinetic energy gradient  or horizontal advection
+   INTEGER, PUBLIC, PARAMETER ::   jpdyn_rvo  =  4     !: relative  vorticity      or metric term
+   INTEGER, PUBLIC, PARAMETER ::   jpdyn_pvo  =  5     !: planetary vorticity
+   INTEGER, PUBLIC, PARAMETER ::   jpdyn_zad  =  6     !: vertical advection
+   INTEGER, PUBLIC, PARAMETER ::   jpdyn_ldf  =  7     !: horizontal diffusion   
+   INTEGER, PUBLIC, PARAMETER ::   jpdyn_zdf  =  8     !: vertical   diffusion
+   INTEGER, PUBLIC, PARAMETER ::   jpdyn_bfr  =  9     !: bottom  stress 
+   INTEGER, PUBLIC, PARAMETER ::   jpdyn_atf  = 10     !: Asselin time filter
+   INTEGER, PUBLIC, PARAMETER ::   jpdyn_tau  = 11     !: surface stress
+   INTEGER, PUBLIC, PARAMETER ::   jpdyn_bfri = 12     !: implicit bottom friction (ln_drgimp=.TRUE.)
+   INTEGER, PUBLIC, PARAMETER ::   jpdyn_ken  = 13     !: use for calculation of KE
+   !
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.7 , NEMO Consortium (2015)
+   !! $Id$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!======================================================================
+END MODULE trd_oce
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/TRD/trddyn.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/TRD/trddyn.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/TRD/trddyn.F90	(revision 9570)
@@ -0,0 +1,183 @@
+MODULE trddyn
+   !!======================================================================
+   !!                       ***  MODULE  trddyn  ***
+   !! Ocean diagnostics:  ocean dynamic trends
+   !!=====================================================================
+   !! History :  3.5  !  2012-02  (G. Madec) creation from trdmod: split DYN and TRA trends
+   !!                                        and manage  3D trends output for U, V, and KE
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   trd_dyn       : manage the type of momentum trend diagnostics (3D I/O, domain averaged, KE)
+   !!   trd_dyn_iom   : output 3D momentum and/or tracer trends using IOM
+   !!   trd_dyn_init  : initialization step
+   !!----------------------------------------------------------------------
+   USE oce            ! ocean dynamics and tracers variables
+   USE dom_oce        ! ocean space and time domain variables
+   USE phycst         ! physical constants
+   USE sbc_oce        ! surface boundary condition: ocean
+   USE zdf_oce        ! ocean vertical physics: variables
+!!gm   USE zdfdrg         ! ocean vertical physics: bottom friction
+   USE trd_oce        ! trends: ocean variables
+   USE trdken         ! trends: Kinetic ENergy 
+   USE trdglo         ! trends: global domain averaged
+   USE trdvor         ! trends: vertical averaged vorticity 
+   USE trdmxl         ! trends: mixed layer averaged 
+   !
+   USE in_out_manager ! I/O manager
+   USE lbclnk         ! lateral boundary condition 
+   USE iom            ! I/O manager library
+   USE lib_mpp        ! MPP library
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC trd_dyn        ! called by all dynXXX modules
+
+   !! * Substitutions
+#  include "vectopt_loop_substitute.h90"
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 4.0 , NEMO Consortium (2017)
+   !! $Id$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE trd_dyn( putrd, pvtrd, ktrd, kt )
+      !!---------------------------------------------------------------------
+      !!                  ***  ROUTINE trd_mod  ***
+      !! 
+      !! ** Purpose :   Dispatch momentum trend computation, e.g. 3D output, 
+      !!              integral constraints, barotropic vorticity, kinetic enrgy, 
+      !!              and/or mixed layer budget.
+      !!----------------------------------------------------------------------
+      REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   putrd, pvtrd   ! U and V trends 
+      INTEGER                   , INTENT(in   ) ::   ktrd           ! trend index
+      INTEGER                   , INTENT(in   ) ::   kt             ! time step
+      !!----------------------------------------------------------------------
+      !
+      putrd(:,:,:) = putrd(:,:,:) * umask(:,:,:)                       ! mask the trends
+      pvtrd(:,:,:) = pvtrd(:,:,:) * vmask(:,:,:)
+      !
+
+!!gm NB : here a lbc_lnk should probably be added
+
+      !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+      !   3D output of momentum and/or tracers trends using IOM interface
+      !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+      IF( ln_dyn_trd )   CALL trd_dyn_iom( putrd, pvtrd, ktrd, kt )
+         
+      !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+      !  Integral Constraints Properties for momentum and/or tracers trends
+      !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+      IF( ln_glo_trd )   CALL trd_glo( putrd, pvtrd, ktrd, 'DYN', kt )
+
+      !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+      !  Kinetic Energy trends
+      !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+      IF( ln_KE_trd  )   CALL trd_ken( putrd, pvtrd, ktrd, kt )
+
+      !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+      !  Vorticity trends
+      !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+      IF( ln_vor_trd )   CALL trd_vor( putrd, pvtrd, ktrd, kt )
+
+      !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+      !  Mixed layer trends for active tracers
+      !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+!!gm      IF( ln_dyn_mxl )   CALL trd_mxl_dyn   
+      !
+   END SUBROUTINE trd_dyn
+
+
+   SUBROUTINE trd_dyn_iom( putrd, pvtrd, ktrd, kt )
+      !!---------------------------------------------------------------------
+      !!                  ***  ROUTINE trd_dyn_iom  ***
+      !! 
+      !! ** Purpose :   output 3D trends using IOM
+      !!----------------------------------------------------------------------
+      REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   putrd, pvtrd   ! U and V trends
+      INTEGER                   , INTENT(in   ) ::   ktrd           ! trend index
+      INTEGER                   , INTENT(in   ) ::   kt             ! time step
+      !
+      INTEGER ::   ji, jj, jk   ! dummy loop indices
+      INTEGER ::   ikbu, ikbv   ! local integers
+      REAL(wp), ALLOCATABLE, DIMENSION(:,:)   ::   z2dx, z2dy   ! 2D workspace 
+      REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) ::   z3dx, z3dy   ! 3D workspace 
+      !!----------------------------------------------------------------------
+      !
+      SELECT CASE( ktrd )
+      CASE( jpdyn_hpg )   ;   CALL iom_put( "utrd_hpg", putrd )    ! hydrostatic pressure gradient
+                              CALL iom_put( "vtrd_hpg", pvtrd )
+      CASE( jpdyn_spg )   ;   CALL iom_put( "utrd_spg", putrd )    ! surface pressure gradient
+                              CALL iom_put( "vtrd_spg", pvtrd )
+      CASE( jpdyn_pvo )   ;   CALL iom_put( "utrd_pvo", putrd )    ! planetary vorticity
+                              CALL iom_put( "vtrd_pvo", pvtrd )
+      CASE( jpdyn_rvo )   ;   CALL iom_put( "utrd_rvo", putrd )    ! relative  vorticity     (or metric term)
+                              CALL iom_put( "vtrd_rvo", pvtrd )
+      CASE( jpdyn_keg )   ;   CALL iom_put( "utrd_keg", putrd )    ! Kinetic Energy gradient (or had)
+                              CALL iom_put( "vtrd_keg", pvtrd )
+                              ALLOCATE( z3dx(jpi,jpj,jpk) , z3dy(jpi,jpj,jpk) )
+                              z3dx(:,:,:) = 0._wp                  ! U.dxU & V.dyV (approximation)
+                              z3dy(:,:,:) = 0._wp
+                              DO jk = 1, jpkm1   ! no mask as un,vn are masked
+                                 DO jj = 2, jpjm1
+                                    DO ji = 2, jpim1
+                                       z3dx(ji,jj,jk) = un(ji,jj,jk) * ( un(ji+1,jj,jk) - un(ji-1,jj,jk) ) / ( 2._wp * e1u(ji,jj) )
+                                       z3dy(ji,jj,jk) = vn(ji,jj,jk) * ( vn(ji,jj+1,jk) - vn(ji,jj-1,jk) ) / ( 2._wp * e2v(ji,jj) )
+                                    END DO
+                                 END DO
+                              END DO
+                              CALL lbc_lnk_multi( z3dx, 'U', -1., z3dy, 'V', -1. )
+                              CALL iom_put( "utrd_udx", z3dx  )
+                              CALL iom_put( "vtrd_vdy", z3dy  )
+                              DEALLOCATE( z3dx , z3dy )
+      CASE( jpdyn_zad )   ;   CALL iom_put( "utrd_zad", putrd )    ! vertical advection
+                              CALL iom_put( "vtrd_zad", pvtrd )
+      CASE( jpdyn_ldf )   ;   CALL iom_put( "utrd_ldf", putrd )    ! lateral  diffusion
+                              CALL iom_put( "vtrd_ldf", pvtrd )
+      CASE( jpdyn_zdf )   ;   CALL iom_put( "utrd_zdf", putrd )    ! vertical diffusion 
+                              CALL iom_put( "vtrd_zdf", pvtrd )
+                              !
+                              !                                    ! wind stress trends
+                              ALLOCATE( z2dx(jpi,jpj) , z2dy(jpi,jpj) )
+                              z2dx(:,:) = ( utau_b(:,:) + utau(:,:) ) / ( e3u_n(:,:,1) * rau0 )
+                              z2dy(:,:) = ( vtau_b(:,:) + vtau(:,:) ) / ( e3v_n(:,:,1) * rau0 )
+                              CALL iom_put( "utrd_tau", z2dx )
+                              CALL iom_put( "vtrd_tau", z2dy )
+                              DEALLOCATE( z2dx , z2dy )
+!!gm  to be changed : computation should be done in dynzdf.F90
+!!gm                + missing the top friction 
+!                              !                                    ! bottom stress tends (implicit case)
+!                              IF( ln_drgimp ) THEN
+!                                 ALLOCATE( z3dx(jpi,jpj,jpk) , z3dy(jpi,jpj,jpk) )
+!                             z3dx(:,:,:) = 0._wp   ;   z3dy(:,:,:) = 0._wp  ! after velocity known (now filed at this stage)
+!                            DO jk = 1, jpkm1
+!                                    DO jj = 2, jpjm1
+!                                       DO ji = 2, jpim1
+!                                      ikbu = mbku(ji,jj)          ! deepest ocean u- & v-levels
+!                                          ikbv = mbkv(ji,jj)
+!                                          z3dx(ji,jj,jk) = 0.5 * ( rCdU_bot(ji+1,jj) + rCdU_bot(ji,jj) ) & 
+!                                               &         * un(ji,jj,ikbu) / e3u_n(ji,jj,ikbu)
+!                                          z3dy(ji,jj,jk) = 0.5 * ( rCdU_bot(ji,jj+1) + rCdU_bot(ji,jj) ) &
+!                                               &         * vn(ji,jj,ikbv) / e3v_n(ji,jj,ikbv)
+!                                    END DO
+!                                 END DO
+!                              END DO
+!                              CALL lbc_lnk_multi( z3dx, 'U', -1., z3dy, 'V', -1. )
+!                              CALL iom_put( "utrd_bfr", z3dx )
+!                              CALL iom_put( "vtrd_bfr", z3dy )
+!                                 DEALLOCATE( z3dx , z3dy )
+!                              ENDIF
+!!gm end
+      CASE( jpdyn_bfr )       ! called if ln_drgimp=F
+                              CALL iom_put( "utrd_bfr", putrd )    ! bottom friction (explicit case)
+                              CALL iom_put( "vtrd_bfr", pvtrd )
+      CASE( jpdyn_atf )   ;   CALL iom_put( "utrd_atf", putrd )        ! asselin filter trends 
+                              CALL iom_put( "vtrd_atf", pvtrd )
+      END SELECT
+      !
+   END SUBROUTINE trd_dyn_iom
+
+   !!======================================================================
+END MODULE trddyn
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/TRD/trdglo.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/TRD/trdglo.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/TRD/trdglo.F90	(revision 9570)
@@ -0,0 +1,559 @@
+MODULE trdglo
+   !!======================================================================
+   !!                       ***  MODULE  trdglo  ***
+   !! Ocean diagnostics:  global domain averaged tracer and momentum trends
+   !!=====================================================================
+   !! History :  1.0  !  2004-08  (C. Talandier) New trends organization
+   !!            3.5  !  2012-02  (G. Madec)  add 3D tracer zdf trend output using iom
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   trd_glo       : domain averaged budget of trends (including kinetic energy and T^2 trends)
+   !!   glo_dyn_wri   : print dynamic trends in ocean.output file
+   !!   glo_tra_wri   : print global T & T^2 trends in ocean.output file
+   !!   trd_glo_init  : initialization step
+   !!----------------------------------------------------------------------
+   USE oce            ! ocean dynamics and tracers variables
+   USE dom_oce        ! ocean space and time domain variables
+   USE sbc_oce        ! surface boundary condition: ocean
+   USE trd_oce        ! trends: ocean variables
+   USE phycst         ! physical constants
+   USE ldftra         ! lateral diffusion: eddy diffusivity & EIV coeff.
+   USE ldfdyn         ! ocean dynamics: lateral physics
+   USE zdf_oce        ! ocean vertical physics
+!!gm   USE zdfdrg         ! ocean vertical physics: bottom friction
+   USE zdfddm         ! ocean vertical physics: double diffusion
+   USE eosbn2         ! equation of state
+   USE phycst         ! physical constants
+   !
+   USE lib_mpp        ! distibuted memory computing library
+   USE in_out_manager ! I/O manager
+   USE iom            ! I/O manager library
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   trd_glo       ! called by trdtra and trddyn modules
+   PUBLIC   trd_glo_init  ! called by trdini module
+
+   !                     !!! Variables used for diagnostics
+   REAL(wp) ::   tvolt    ! volume of the whole ocean computed at t-points
+   REAL(wp) ::   tvolu    ! volume of the whole ocean computed at u-points
+   REAL(wp) ::   tvolv    ! volume of the whole ocean computed at v-points
+   REAL(wp) ::   rpktrd   ! potential to kinetic energy conversion
+   REAL(wp) ::   peke     ! conversion potential energy - kinetic energy trend
+
+   !                     !!! domain averaged trends
+   REAL(wp), DIMENSION(jptot_tra) ::   tmo, smo   ! temperature and salinity trends 
+   REAL(wp), DIMENSION(jptot_tra) ::   t2 , s2    ! T^2 and S^2 trends 
+   REAL(wp), DIMENSION(jptot_dyn) ::   umo, vmo   ! momentum trends 
+   REAL(wp), DIMENSION(jptot_dyn) ::   hke        ! kinetic energy trends (u^2+v^2) 
+
+   !! * Substitutions
+#  include "vectopt_loop_substitute.h90"
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO Consortium (2010)
+   !! $Id$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE trd_glo( ptrdx, ptrdy, ktrd, ctype, kt )
+      !!---------------------------------------------------------------------
+      !!                  ***  ROUTINE trd_glo  ***
+      !! 
+      !! ** Purpose :   compute and print global domain averaged trends for 
+      !!              T, T^2, momentum, KE, and KE<->PE
+      !!
+      !!----------------------------------------------------------------------
+      REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   ptrdx   ! Temperature or U trend 
+      REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   ptrdy   ! Salinity    or V trend
+      INTEGER                   , INTENT(in   ) ::   ktrd    ! tracer trend index
+      CHARACTER(len=3)          , INTENT(in   ) ::   ctype   ! momentum or tracers trends type (='DYN'/'TRA')
+      INTEGER                   , INTENT(in   ) ::   kt      ! time step
+      !!
+      INTEGER ::   ji, jj, jk      ! dummy loop indices
+      INTEGER ::   ikbu, ikbv      ! local integers
+      REAL(wp)::   zvm, zvt, zvs, z1_2rau0   ! local scalars
+      REAL(wp), DIMENSION(jpi,jpj)  :: ztswu, ztswv, z2dx, z2dy   ! 2D workspace 
+      !!----------------------------------------------------------------------
+      !
+      IF( MOD(kt,nn_trd) == 0 .OR. kt == nit000 .OR. kt == nitend ) THEN
+         !
+      	SELECT CASE( ctype )
+      	!
+      	CASE( 'TRA' )          !==  Tracers (T & S)  ==!
+      	   DO jk = 1, jpkm1       ! global sum of mask volume trend and trend*T (including interior mask)
+      	      DO jj = 1, jpj
+      	         DO ji = 1, jpi        
+      	            zvm = e1e2t(ji,jj) * e3t_n(ji,jj,jk) * tmask(ji,jj,jk) * tmask_i(ji,jj)
+      	            zvt = ptrdx(ji,jj,jk) * zvm
+      	            zvs = ptrdy(ji,jj,jk) * zvm
+         	         tmo(ktrd) = tmo(ktrd) + zvt   
+         	         smo(ktrd) = smo(ktrd) + zvs
+         	         t2 (ktrd) = t2(ktrd)  + zvt * tsn(ji,jj,jk,jp_tem)
+         	         s2 (ktrd) = s2(ktrd)  + zvs * tsn(ji,jj,jk,jp_sal)
+                  END DO
+               END DO
+            END DO
+            !                       ! linear free surface: diagnose advective flux trough the fixed k=1 w-surface
+            IF( ln_linssh .AND. ktrd == jptra_zad ) THEN  
+               tmo(jptra_sad) = SUM( wn(:,:,1) * tsn(:,:,1,jp_tem) * e1e2t(:,:) * tmask_i(:,:) )
+               smo(jptra_sad) = SUM( wn(:,:,1) * tsn(:,:,1,jp_sal) * e1e2t(:,:) * tmask_i(:,:)  )
+               t2 (jptra_sad) = SUM( wn(:,:,1) * tsn(:,:,1,jp_tem) * tsn(:,:,1,jp_tem) * e1e2t(:,:) * tmask_i(:,:)  )
+               s2 (jptra_sad) = SUM( wn(:,:,1) * tsn(:,:,1,jp_sal) * tsn(:,:,1,jp_sal) * e1e2t(:,:) * tmask_i(:,:)  )
+            ENDIF
+            !
+            IF( ktrd == jptra_atf ) THEN     ! last trend (asselin time filter)
+               ! 
+               CALL glo_tra_wri( kt )             ! print the results in ocean.output
+               !                
+	            tmo(:) = 0._wp                     ! prepare the next time step (domain averaged array reset to zero)
+   	         smo(:) = 0._wp
+               t2 (:) = 0._wp
+               s2 (:) = 0._wp
+               !
+            ENDIF
+            !
+         CASE( 'DYN' )          !==  Momentum and KE  ==!        
+            DO jk = 1, jpkm1
+               DO jj = 1, jpjm1
+                  DO ji = 1, jpim1
+                     zvt = ptrdx(ji,jj,jk) * tmask_i(ji+1,jj) * tmask_i(ji,jj) * umask(ji,jj,jk)   &
+                        &                                     * e1e2u  (ji,jj) * e3u_n(ji,jj,jk)
+                     zvs = ptrdy(ji,jj,jk) * tmask_i(ji,jj+1) * tmask_i(ji,jj) * vmask(ji,jj,jk)   &
+                        &                                     * e1e2v  (ji,jj) * e3u_n(ji,jj,jk)
+                     umo(ktrd) = umo(ktrd) + zvt
+                     vmo(ktrd) = vmo(ktrd) + zvs
+                     hke(ktrd) = hke(ktrd) + un(ji,jj,jk) * zvt + vn(ji,jj,jk) * zvs
+                  END DO
+               END DO
+            END DO
+            !                 
+            IF( ktrd == jpdyn_zdf ) THEN      ! zdf trend: compute separately the surface forcing trend
+               z1_2rau0 = 0.5_wp / rau0
+               DO jj = 1, jpjm1
+                  DO ji = 1, jpim1
+                     zvt = ( utau_b(ji,jj) + utau(ji,jj) ) * tmask_i(ji+1,jj) * tmask_i(ji,jj) * umask(ji,jj,jk)   &
+                        &                                                     * z1_2rau0       * e1e2u(ji,jj)
+                     zvs = ( vtau_b(ji,jj) + vtau(ji,jj) ) * tmask_i(ji,jj+1) * tmask_i(ji,jj) * vmask(ji,jj,jk)   &
+                        &                                                     * z1_2rau0       * e1e2v(ji,jj)
+                     umo(jpdyn_tau) = umo(jpdyn_tau) + zvt
+                     vmo(jpdyn_tau) = vmo(jpdyn_tau) + zvs
+                     hke(jpdyn_tau) = hke(jpdyn_tau) + un(ji,jj,1) * zvt + vn(ji,jj,1) * zvs
+                  END DO
+               END DO
+            ENDIF
+            !                       
+!!gm  miss placed calculation   ===>>>> to be done in dynzdf.F90
+!            IF( ktrd == jpdyn_atf ) THEN     ! last trend (asselin time filter)
+!               !
+!               IF( ln_drgimp ) THEN                   ! implicit drag case: compute separately the bottom friction 
+!                  z1_2rau0 = 0.5_wp / rau0
+!                  DO jj = 1, jpjm1
+!                     DO ji = 1, jpim1
+!                        ikbu = mbku(ji,jj)                  ! deepest ocean u- & v-levels
+!                        ikbv = mbkv(ji,jj)
+!                        zvt = 0.5*( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) ) * un(ji,jj,ikbu) * e1e2u(ji,jj)
+!                        zvs = 0.5*( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) ) * vn(ji,jj,ikbv) * e1e2v(ji,jj)
+!                        umo(jpdyn_bfri) = umo(jpdyn_bfri) + zvt
+!                        vmo(jpdyn_bfri) = vmo(jpdyn_bfri) + zvs
+!                        hke(jpdyn_bfri) = hke(jpdyn_bfri) + un(ji,jj,ikbu) * zvt + vn(ji,jj,ikbv) * zvs
+!                     END DO
+!                  END DO
+!               ENDIF
+!
+!!gm top drag case is missing 
+!
+!               ! 
+!               CALL glo_dyn_wri( kt )                 ! print the results in ocean.output
+!               !                
+!               umo(:) = 0._wp                         ! reset for the next time step
+!               vmo(:) = 0._wp
+!               hke(:) = 0._wp
+!               !
+!            ENDIF
+!!gm end
+            !
+         END SELECT
+         !
+      ENDIF
+      !
+   END SUBROUTINE trd_glo
+
+
+   SUBROUTINE glo_dyn_wri( kt )
+      !!---------------------------------------------------------------------
+      !!                  ***  ROUTINE glo_dyn_wri  ***
+      !! 
+      !! ** Purpose :  write global averaged U, KE, PE<->KE trends in ocean.output 
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT(in) ::   kt   ! ocean time-step index
+      !
+      INTEGER  ::   ji, jj, jk   ! dummy loop indices
+      REAL(wp) ::   zcof         ! local scalar
+      REAL(wp), DIMENSION(jpi,jpj,jpk)  ::  zkx, zky, zkz, zkepe  
+      !!----------------------------------------------------------------------
+
+      ! I. Momentum trends
+      ! -------------------
+
+      IF( MOD( kt, nn_trd ) == 0 .OR. kt == nit000 .OR. kt == nitend ) THEN
+
+         ! I.1 Conversion potential energy - kinetic energy
+         ! --------------------------------------------------
+         ! c a u t i o n here, trends are computed at kt+1 (now , but after the swap)
+         zkx  (:,:,:) = 0._wp
+         zky  (:,:,:) = 0._wp
+         zkz  (:,:,:) = 0._wp
+         zkepe(:,:,:) = 0._wp
+   
+         CALL eos( tsn, rhd, rhop )       ! now potential density
+
+         zcof = 0.5_wp / rau0             ! Density flux at w-point
+         zkz(:,:,1) = 0._wp
+         DO jk = 2, jpk
+            zkz(:,:,jk) = zcof * e1e2t(:,:) * wn(:,:,jk) * ( rhop(:,:,jk) + rhop(:,:,jk-1) ) * tmask_i(:,:)
+         END DO
+         
+         zcof   = 0.5_wp / rau0           ! Density flux at u and v-points
+         DO jk = 1, jpkm1
+            DO jj = 1, jpjm1
+               DO ji = 1, jpim1
+                  zkx(ji,jj,jk) = zcof * e2u(ji,jj) * e3u_n(ji,jj,jk) * un(ji,jj,jk) * ( rhop(ji,jj,jk) + rhop(ji+1,jj,jk) )
+                  zky(ji,jj,jk) = zcof * e1v(ji,jj) * e3v_n(ji,jj,jk) * vn(ji,jj,jk) * ( rhop(ji,jj,jk) + rhop(ji,jj+1,jk) )
+               END DO
+            END DO
+         END DO
+         
+         DO jk = 1, jpkm1                 ! Density flux divergence at t-point
+            DO jj = 2, jpjm1
+               DO ji = 2, jpim1
+                  zkepe(ji,jj,jk) = - (  zkz(ji,jj,jk) - zkz(ji  ,jj  ,jk+1)               &
+                     &                 + zkx(ji,jj,jk) - zkx(ji-1,jj  ,jk  )               &
+                     &                 + zky(ji,jj,jk) - zky(ji  ,jj-1,jk  )   )           &
+                     &              / ( e1e2t(ji,jj) * e3t_n(ji,jj,jk) ) * tmask(ji,jj,jk) * tmask_i(ji,jj)
+               END DO
+            END DO
+         END DO
+
+         ! I.2 Basin averaged kinetic energy trend
+         ! ----------------------------------------
+         peke = 0._wp
+         DO jk = 1, jpkm1
+            peke = peke + SUM( zkepe(:,:,jk) * gdept_n(:,:,jk) * e1e2t(:,:) * e3t_n(:,:,jk) )
+         END DO
+         peke = grav * peke
+
+         ! I.3 Sums over the global domain
+         ! ---------------------------------
+         IF( lk_mpp ) THEN
+            CALL mpp_sum( peke )
+            CALL mpp_sum( umo , jptot_dyn )
+            CALL mpp_sum( vmo , jptot_dyn )
+            CALL mpp_sum( hke , jptot_dyn )
+         ENDIF
+
+         ! I.2 Print dynamic trends in the ocean.output file
+         ! --------------------------------------------------
+
+         IF(lwp) THEN
+            WRITE (numout,*)
+            WRITE (numout,*)
+            WRITE (numout,9500) kt
+            WRITE (numout,9501) umo(jpdyn_hpg) / tvolu, vmo(jpdyn_hpg) / tvolv
+            WRITE (numout,9502) umo(jpdyn_keg) / tvolu, vmo(jpdyn_keg) / tvolv
+            WRITE (numout,9503) umo(jpdyn_rvo) / tvolu, vmo(jpdyn_rvo) / tvolv
+            WRITE (numout,9504) umo(jpdyn_pvo) / tvolu, vmo(jpdyn_pvo) / tvolv
+            WRITE (numout,9505) umo(jpdyn_zad) / tvolu, vmo(jpdyn_zad) / tvolv
+            WRITE (numout,9506) umo(jpdyn_ldf) / tvolu, vmo(jpdyn_ldf) / tvolv
+            WRITE (numout,9507) umo(jpdyn_zdf) / tvolu, vmo(jpdyn_zdf) / tvolv
+            WRITE (numout,9508) umo(jpdyn_spg) / tvolu, vmo(jpdyn_spg) / tvolv
+            WRITE (numout,9509) umo(jpdyn_bfr) / tvolu, vmo(jpdyn_bfr) / tvolv
+            WRITE (numout,9510) umo(jpdyn_atf) / tvolu, vmo(jpdyn_atf) / tvolv
+            WRITE (numout,9511)
+            WRITE (numout,9512)                                                 &
+            &     (  umo(jpdyn_hpg) + umo(jpdyn_keg) + umo(jpdyn_rvo) + umo(jpdyn_pvo)   &
+            &      + umo(jpdyn_zad) + umo(jpdyn_ldf) + umo(jpdyn_zdf) + umo(jpdyn_spg)   &
+            &      + umo(jpdyn_bfr) + umo(jpdyn_atf) ) / tvolu,   &
+            &     (  vmo(jpdyn_hpg) + vmo(jpdyn_keg) + vmo(jpdyn_rvo) + vmo(jpdyn_pvo)   &
+            &      + vmo(jpdyn_zad) + vmo(jpdyn_ldf) + vmo(jpdyn_zdf) + vmo(jpdyn_spg)   &
+            &      + vmo(jpdyn_bfr) + vmo(jpdyn_atf) ) / tvolv
+            WRITE (numout,9513) umo(jpdyn_tau) / tvolu, vmo(jpdyn_tau) / tvolv
+!!gm            IF( ln_drgimp )   WRITE (numout,9514) umo(jpdyn_bfri) / tvolu, vmo(jpdyn_bfri) / tvolv
+         ENDIF
+
+ 9500    FORMAT(' momentum trend at it= ', i6, ' :', /' ==============================')
+ 9501    FORMAT(' hydro pressure gradient    u= ', e20.13, '    v= ', e20.13)
+ 9502    FORMAT(' ke gradient                u= ', e20.13, '    v= ', e20.13)
+ 9503    FORMAT(' relative vorticity term    u= ', e20.13, '    v= ', e20.13)
+ 9504    FORMAT(' planetary vorticity term   u= ', e20.13, '    v= ', e20.13)
+ 9505    FORMAT(' vertical advection         u= ', e20.13, '    v= ', e20.13)
+ 9506    FORMAT(' horizontal diffusion       u= ', e20.13, '    v= ', e20.13)
+ 9507    FORMAT(' vertical diffusion         u= ', e20.13, '    v= ', e20.13)
+ 9508    FORMAT(' surface pressure gradient  u= ', e20.13, '    v= ', e20.13)
+ 9509    FORMAT(' explicit bottom friction   u= ', e20.13, '    v= ', e20.13)
+ 9510    FORMAT(' Asselin time filter        u= ', e20.13, '    v= ', e20.13)
+ 9511    FORMAT(' -----------------------------------------------------------------------------')
+ 9512    FORMAT(' total trend                u= ', e20.13, '    v= ', e20.13)
+ 9513    FORMAT(' incl. surface wind stress  u= ', e20.13, '    v= ', e20.13)
+ 9514    FORMAT('       bottom stress        u= ', e20.13, '    v= ', e20.13)
+
+         IF(lwp) THEN
+            WRITE (numout,*)
+            WRITE (numout,*)
+            WRITE (numout,9520) kt
+            WRITE (numout,9521) hke(jpdyn_hpg) / tvolt
+            WRITE (numout,9522) hke(jpdyn_keg) / tvolt
+            WRITE (numout,9523) hke(jpdyn_rvo) / tvolt
+            WRITE (numout,9524) hke(jpdyn_pvo) / tvolt
+            WRITE (numout,9525) hke(jpdyn_zad) / tvolt
+            WRITE (numout,9526) hke(jpdyn_ldf) / tvolt
+            WRITE (numout,9527) hke(jpdyn_zdf) / tvolt
+            WRITE (numout,9528) hke(jpdyn_spg) / tvolt
+            WRITE (numout,9529) hke(jpdyn_bfr) / tvolt
+            WRITE (numout,9530) hke(jpdyn_atf) / tvolt
+            WRITE (numout,9531)
+            WRITE (numout,9532)   &
+            &     (  hke(jpdyn_hpg) + hke(jpdyn_keg) + hke(jpdyn_rvo) + hke(jpdyn_pvo)   &
+            &      + hke(jpdyn_zad) + hke(jpdyn_ldf) + hke(jpdyn_zdf) + hke(jpdyn_spg)   &
+            &      + hke(jpdyn_bfr) + hke(jpdyn_atf) ) / tvolt
+            WRITE (numout,9533) hke(jpdyn_tau) / tvolt
+!!gm            IF( ln_drgimp )   WRITE (numout,9534) hke(jpdyn_bfri) / tvolt
+         ENDIF
+
+ 9520    FORMAT(' kinetic energy trend at it= ', i6, ' :', /' ====================================')
+ 9521    FORMAT(' hydro pressure gradient   u2= ', e20.13)
+ 9522    FORMAT(' ke gradient               u2= ', e20.13)
+ 9523    FORMAT(' relative vorticity term   u2= ', e20.13)
+ 9524    FORMAT(' planetary vorticity term  u2= ', e20.13)
+ 9525    FORMAT(' vertical advection        u2= ', e20.13)
+ 9526    FORMAT(' horizontal diffusion      u2= ', e20.13)
+ 9527    FORMAT(' vertical diffusion        u2= ', e20.13)
+ 9528    FORMAT(' surface pressure gradient u2= ', e20.13)
+ 9529    FORMAT(' explicit bottom friction  u2= ', e20.13)
+ 9530    FORMAT(' Asselin time filter       u2= ', e20.13)
+ 9531    FORMAT(' --------------------------------------------------')
+ 9532    FORMAT(' total trend               u2= ', e20.13)
+ 9533    FORMAT(' incl. surface wind stress u2= ', e20.13)
+ 9534    FORMAT('       bottom stress       u2= ', e20.13)
+
+         IF(lwp) THEN
+            WRITE (numout,*)
+            WRITE (numout,*)
+            WRITE (numout,9540) kt
+            WRITE (numout,9541) ( hke(jpdyn_keg) + hke(jpdyn_rvo) + hke(jpdyn_zad) ) / tvolt
+            WRITE (numout,9542) ( hke(jpdyn_keg) + hke(jpdyn_zad) ) / tvolt
+            WRITE (numout,9543) ( hke(jpdyn_pvo) ) / tvolt
+            WRITE (numout,9544) ( hke(jpdyn_rvo) ) / tvolt
+            WRITE (numout,9545) ( hke(jpdyn_spg) ) / tvolt
+            WRITE (numout,9546) ( hke(jpdyn_ldf) ) / tvolt
+            WRITE (numout,9547) ( hke(jpdyn_zdf) ) / tvolt
+            WRITE (numout,9548) ( hke(jpdyn_hpg) ) / tvolt, rpktrd / tvolt
+            WRITE (numout,*)
+            WRITE (numout,*)
+         ENDIF
+
+ 9540    FORMAT(' energetic consistency at it= ', i6, ' :', /' =========================================')
+ 9541    FORMAT(' 0 = non linear term (true if KE conserved)                : ', e20.13)
+ 9542    FORMAT(' 0 = ke gradient + vertical advection                      : ', e20.13)
+ 9543    FORMAT(' 0 = coriolis term  (true if KE conserving scheme)         : ', e20.13)
+ 9544    FORMAT(' 0 = vorticity term (true if KE conserving scheme)         : ', e20.13)
+ 9545    FORMAT(' 0 = surface pressure gradient  ???                        : ', e20.13)
+ 9546    FORMAT(' 0 < horizontal diffusion                                  : ', e20.13)
+ 9547    FORMAT(' 0 < vertical diffusion                                    : ', e20.13)
+ 9548    FORMAT(' pressure gradient u2 = - 1/rau0 u.dz(rhop)                : ', e20.13, '  u.dz(rhop) =', e20.13)
+         !
+         ! Save potential to kinetic energy conversion for next time step
+         rpktrd = peke
+         !
+      ENDIF
+      !
+   END SUBROUTINE glo_dyn_wri
+
+
+   SUBROUTINE glo_tra_wri( kt )
+      !!---------------------------------------------------------------------
+      !!                  ***  ROUTINE glo_tra_wri  ***
+      !! 
+      !! ** Purpose :  write global domain averaged of T and T^2 trends in ocean.output 
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT(in) ::   kt   ! ocean time-step index
+      !
+      INTEGER  ::   jk   ! loop indices
+      !!----------------------------------------------------------------------
+
+      ! I. Tracers trends
+      ! -----------------
+
+      IF( MOD(kt,nn_trd) == 0 .OR. kt == nit000 .OR. kt == nitend ) THEN
+
+         ! I.1 Sums over the global domain
+         ! -------------------------------
+         IF( lk_mpp ) THEN
+            CALL mpp_sum( tmo, jptot_tra )   
+            CALL mpp_sum( smo, jptot_tra )
+            CALL mpp_sum( t2 , jptot_tra )
+            CALL mpp_sum( s2 , jptot_tra )
+         ENDIF
+
+         ! I.2 Print tracers trends in the ocean.output file
+         ! --------------------------------------------------
+         
+         IF(lwp) THEN
+            WRITE (numout,*)
+            WRITE (numout,*)
+            WRITE (numout,9400) kt
+            WRITE (numout,9401)  tmo(jptra_xad) / tvolt, smo(jptra_xad) / tvolt
+            WRITE (numout,9411)  tmo(jptra_yad) / tvolt, smo(jptra_yad) / tvolt
+            WRITE (numout,9402)  tmo(jptra_zad) / tvolt, smo(jptra_zad) / tvolt
+            WRITE (numout,9403)  tmo(jptra_ldf) / tvolt, smo(jptra_ldf) / tvolt
+            WRITE (numout,9404)  tmo(jptra_zdf) / tvolt, smo(jptra_zdf) / tvolt
+            WRITE (numout,9405)  tmo(jptra_npc) / tvolt, smo(jptra_npc) / tvolt
+            WRITE (numout,9406)  tmo(jptra_dmp) / tvolt, smo(jptra_dmp) / tvolt
+            WRITE (numout,9407)  tmo(jptra_qsr) / tvolt
+            WRITE (numout,9408)  tmo(jptra_nsr) / tvolt, smo(jptra_nsr) / tvolt
+            WRITE (numout,9409) 
+            WRITE (numout,9410) (  tmo(jptra_xad) + tmo(jptra_yad) + tmo(jptra_zad) + tmo(jptra_ldf) + tmo(jptra_zdf)   &
+            &                    + tmo(jptra_npc) + tmo(jptra_dmp) + tmo(jptra_qsr) + tmo(jptra_nsr) ) / tvolt,   &
+            &                   (  smo(jptra_xad) + smo(jptra_yad) + smo(jptra_zad) + smo(jptra_ldf) + smo(jptra_zdf)   &
+            &                    + smo(jptra_npc) + smo(jptra_dmp)                   + smo(jptra_nsr) ) / tvolt
+         ENDIF
+
+9400     FORMAT(' tracer trend at it= ',i6,' :     temperature',   &
+              '              salinity',/' ============================')
+9401     FORMAT(' zonal      advection        ',e20.13,'     ',e20.13)
+9411     FORMAT(' meridional advection        ',e20.13,'     ',e20.13)
+9402     FORMAT(' vertical advection          ',e20.13,'     ',e20.13)
+9403     FORMAT(' horizontal diffusion        ',e20.13,'     ',e20.13)
+9404     FORMAT(' vertical diffusion          ',e20.13,'     ',e20.13)
+9405     FORMAT(' static instability mixing   ',e20.13,'     ',e20.13)
+9406     FORMAT(' damping term                ',e20.13,'     ',e20.13)
+9407     FORMAT(' penetrative qsr             ',e20.13)
+9408     FORMAT(' non solar radiation         ',e20.13,'     ',e20.13)
+9409     FORMAT(' -------------------------------------------------------------------------')
+9410     FORMAT(' total trend                 ',e20.13,'     ',e20.13)
+
+
+         IF(lwp) THEN
+            WRITE (numout,*)
+            WRITE (numout,*)
+            WRITE (numout,9420) kt
+            WRITE (numout,9421)   t2(jptra_xad) / tvolt, s2(jptra_xad) / tvolt
+            WRITE (numout,9431)   t2(jptra_yad) / tvolt, s2(jptra_yad) / tvolt
+            WRITE (numout,9422)   t2(jptra_zad) / tvolt, s2(jptra_zad) / tvolt
+            WRITE (numout,9423)   t2(jptra_ldf) / tvolt, s2(jptra_ldf) / tvolt
+            WRITE (numout,9424)   t2(jptra_zdf) / tvolt, s2(jptra_zdf) / tvolt
+            WRITE (numout,9425)   t2(jptra_npc) / tvolt, s2(jptra_npc) / tvolt
+            WRITE (numout,9426)   t2(jptra_dmp) / tvolt, s2(jptra_dmp) / tvolt
+            WRITE (numout,9427)   t2(jptra_qsr) / tvolt
+            WRITE (numout,9428)   t2(jptra_nsr) / tvolt, s2(jptra_nsr) / tvolt
+            WRITE (numout,9429)
+            WRITE (numout,9430) (  t2(jptra_xad) + t2(jptra_yad) + t2(jptra_zad) + t2(jptra_ldf) + t2(jptra_zdf)   &
+            &                    + t2(jptra_npc) + t2(jptra_dmp) + t2(jptra_qsr) + t2(jptra_nsr) ) / tvolt,   &
+            &                   (  s2(jptra_xad) + s2(jptra_yad) + s2(jptra_zad) + s2(jptra_ldf) + s2(jptra_zdf)   &
+            &                    + s2(jptra_npc) + s2(jptra_dmp)                  + s2(jptra_nsr) ) / tvolt
+         ENDIF
+
+9420     FORMAT(' tracer**2 trend at it= ', i6, ' :      temperature',   &
+            '               salinity', /, ' ===============================')
+9421     FORMAT(' zonal      advection      * t   ', e20.13, '     ', e20.13)
+9431     FORMAT(' meridional advection      * t   ', e20.13, '     ', e20.13)
+9422     FORMAT(' vertical advection        * t   ', e20.13, '     ', e20.13)
+9423     FORMAT(' horizontal diffusion      * t   ', e20.13, '     ', e20.13)
+9424     FORMAT(' vertical diffusion        * t   ', e20.13, '     ', e20.13)
+9425     FORMAT(' static instability mixing * t   ', e20.13, '     ', e20.13)
+9426     FORMAT(' damping term              * t   ', e20.13, '     ', e20.13)
+9427     FORMAT(' penetrative qsr           * t   ', e20.13)
+9428     FORMAT(' non solar radiation       * t   ', e20.13, '     ', e20.13)
+9429     FORMAT(' -----------------------------------------------------------------------------')
+9430     FORMAT(' total trend                *t = ', e20.13, '  *s = ', e20.13)
+
+
+         IF(lwp) THEN
+            WRITE (numout,*)
+            WRITE (numout,*)
+            WRITE (numout,9440) kt
+            WRITE (numout,9441) ( tmo(jptra_xad)+tmo(jptra_yad)+tmo(jptra_zad) )/tvolt,   &
+            &                   ( smo(jptra_xad)+smo(jptra_yad)+smo(jptra_zad) )/tvolt
+            WRITE (numout,9442)   tmo(jptra_sad)/tvolt,  smo(jptra_sad)/tvolt
+            WRITE (numout,9443)   tmo(jptra_ldf)/tvolt,  smo(jptra_ldf)/tvolt
+            WRITE (numout,9444)   tmo(jptra_zdf)/tvolt,  smo(jptra_zdf)/tvolt
+            WRITE (numout,9445)   tmo(jptra_npc)/tvolt,  smo(jptra_npc)/tvolt
+            WRITE (numout,9446) ( t2(jptra_xad)+t2(jptra_yad)+t2(jptra_zad) )/tvolt,    &
+            &                   ( s2(jptra_xad)+s2(jptra_yad)+s2(jptra_zad) )/tvolt
+            WRITE (numout,9447)   t2(jptra_ldf)/tvolt,   s2(jptra_ldf)/tvolt
+            WRITE (numout,9448)   t2(jptra_zdf)/tvolt,   s2(jptra_zdf)/tvolt
+            WRITE (numout,9449)   t2(jptra_npc)/tvolt,   s2(jptra_npc)/tvolt
+         ENDIF
+
+9440     FORMAT(' tracer consistency at it= ',i6,   &
+            ' :         temperature','                salinity',/,   &
+            ' ==================================')
+9441     FORMAT(' 0 = horizontal+vertical advection +    ',e20.13,'       ',e20.13)
+9442     FORMAT('     1st lev vertical advection         ',e20.13,'       ',e20.13)
+9443     FORMAT(' 0 = horizontal diffusion               ',e20.13,'       ',e20.13)
+9444     FORMAT(' 0 = vertical diffusion                 ',e20.13,'       ',e20.13)
+9445     FORMAT(' 0 = static instability mixing          ',e20.13,'       ',e20.13)
+9446     FORMAT(' 0 = horizontal+vertical advection * t  ',e20.13,'       ',e20.13)
+9447     FORMAT(' 0 > horizontal diffusion          * t  ',e20.13,'       ',e20.13)
+9448     FORMAT(' 0 > vertical diffusion            * t  ',e20.13,'       ',e20.13)
+9449     FORMAT(' 0 > static instability mixing     * t  ',e20.13,'       ',e20.13)
+         !
+      ENDIF
+      !
+   END SUBROUTINE glo_tra_wri
+
+
+   SUBROUTINE trd_glo_init
+      !!---------------------------------------------------------------------
+      !!                  ***  ROUTINE trd_glo_init  ***
+      !! 
+      !! ** Purpose :   Read the namtrd namelist
+      !!----------------------------------------------------------------------
+      INTEGER  ::   ji, jj, jk   ! dummy loop indices
+      !!----------------------------------------------------------------------
+
+      IF(lwp) THEN
+         WRITE(numout,*)
+         WRITE(numout,*) 'trd_glo_init : integral constraints properties trends'
+         WRITE(numout,*) '~~~~~~~~~~~~~'
+      ENDIF
+
+      ! Total volume at t-points:
+      tvolt = 0._wp
+      DO jk = 1, jpkm1
+         tvolt = tvolt + SUM( e1e2t(:,:) * e3t_n(:,:,jk) * tmask(:,:,jk) * tmask_i(:,:) )
+      END DO
+      IF( lk_mpp )   CALL mpp_sum( tvolt )   ! sum over the global domain
+
+      IF(lwp) WRITE(numout,*) '                total ocean volume at T-point   tvolt = ',tvolt
+
+      ! Initialization of potential to kinetic energy conversion
+      rpktrd = 0._wp
+
+      ! Total volume at u-, v- points:
+!!gm :  bug?  je suis quasi sur que le produit des tmask_i ne correspond pas exactement au umask_i et vmask_i !
+      tvolu = 0._wp
+      tvolv = 0._wp
+
+      DO jk = 1, jpk
+         DO jj = 2, jpjm1
+            DO ji = fs_2, fs_jpim1   ! vector opt.
+               tvolu = tvolu + e1u(ji,jj) * e2u(ji,jj) * e3u_n(ji,jj,jk) * tmask_i(ji+1,jj  ) * tmask_i(ji,jj) * umask(ji,jj,jk)
+               tvolv = tvolv + e1v(ji,jj) * e2v(ji,jj) * e3v_n(ji,jj,jk) * tmask_i(ji  ,jj+1) * tmask_i(ji,jj) * vmask(ji,jj,jk)
+            END DO
+         END DO
+      END DO
+      IF( lk_mpp )   CALL mpp_sum( tvolu )   ! sums over the global domain
+      IF( lk_mpp )   CALL mpp_sum( tvolv )
+
+      IF(lwp) THEN
+         WRITE(numout,*) '                total ocean volume at U-point   tvolu = ',tvolu
+         WRITE(numout,*) '                total ocean volume at V-point   tvolv = ',tvolv
+      ENDIF
+      !
+   END SUBROUTINE trd_glo_init
+
+   !!======================================================================
+END MODULE trdglo
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/TRD/trdini.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/TRD/trdini.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/TRD/trdini.F90	(revision 9570)
@@ -0,0 +1,107 @@
+MODULE trdini
+   !!======================================================================
+   !!                       ***  MODULE  trdini  ***
+   !! Ocean diagnostics:  ocean tracers and dynamic trends
+   !!=====================================================================
+   !! History :   3.5  !  2012-02  (G. Madec) add 3D trends output for T, S, U, V, PE and KE
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   trd_init      : initialization step
+   !!----------------------------------------------------------------------
+   USE dom_oce        ! ocean domain
+   USE trd_oce        ! trends: ocean variables
+   USE trdken         ! trends: 3D kinetic   energy
+   USE trdpen         ! trends: 3D potential energy
+   USE trdglo         ! trends: global domain averaged tracers and dynamics
+   USE trdmxl         ! trends: mixed layer averaged trends (tracer only)
+   USE trdvor         ! trends: vertical averaged vorticity 
+   USE in_out_manager ! I/O manager
+   USE lib_mpp        ! MPP library
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   trd_init   ! called by nemogcm.F90 module
+
+   !! * Substitutions
+#  include "vectopt_loop_substitute.h90"
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO Consortium (2010)
+   !! $Id$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE trd_init
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE trd_init  ***
+      !! 
+      !! ** Purpose :   Initialization of trend diagnostics
+      !!----------------------------------------------------------------------
+      INTEGER ::   ios   ! local integer
+      !!
+      NAMELIST/namtrd/ ln_dyn_trd, ln_KE_trd, ln_vor_trd, ln_dyn_mxl,   &
+         &             ln_tra_trd, ln_PE_trd, ln_glo_trd, ln_tra_mxl, nn_trd 
+      !!----------------------------------------------------------------------
+      !
+      REWIND( numnam_ref )              ! Namelist namtrd in reference namelist : trends diagnostic
+      READ  ( numnam_ref, namtrd, IOSTAT = ios, ERR = 901 )
+901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namtrd in reference namelist', lwp )
+      !
+      REWIND( numnam_cfg )              ! Namelist namtrd in configuration namelist : trends diagnostic
+      READ  ( numnam_cfg, namtrd, IOSTAT = ios, ERR = 902 )
+902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namtrd in configuration namelist', lwp )
+      IF(lwm) WRITE( numond, namtrd )
+      !
+      IF(lwp) THEN                  ! control print
+         WRITE(numout,*)
+         WRITE(numout,*) 'trd_init : Momentum/Tracers trends'
+         WRITE(numout,*) '~~~~~~~~'
+         WRITE(numout,*) '   Namelist namtrd : set trends parameters'
+         WRITE(numout,*) '      global domain averaged dyn & tra trends   ln_glo_trd  = ', ln_glo_trd
+         WRITE(numout,*) '      U & V trends: 3D output                   ln_dyn_trd  = ', ln_dyn_trd
+         WRITE(numout,*) '      U & V trends: Mixed Layer averaged        ln_dyn_mxl  = ', ln_dyn_mxl
+         WRITE(numout,*) '      T & S trends: 3D output                   ln_tra_trd  = ', ln_tra_trd
+         WRITE(numout,*) '      T & S trends: Mixed Layer averaged        ln_tra_mxl  = ', ln_tra_mxl
+         WRITE(numout,*) '      Kinetic   Energy trends                   ln_KE_trd   = ', ln_KE_trd
+         WRITE(numout,*) '      Potential Energy trends                   ln_PE_trd   = ', ln_PE_trd
+         WRITE(numout,*) '      Barotropic vorticity trends               ln_vor_trd  = ', ln_vor_trd
+         !
+         WRITE(numout,*) '      frequency of trends diagnostics (glo)     nn_trd      = ', nn_trd
+      ENDIF
+      !
+      !                             ! trend extraction flags  
+      l_trdtra = .FALSE.                                                       ! tracers  
+      IF ( ln_tra_trd .OR. ln_PE_trd .OR. ln_tra_mxl .OR.   &
+         & ln_glo_trd                                       )   l_trdtra = .TRUE. 
+      !
+      l_trddyn = .FALSE.                                                       ! momentum
+      IF ( ln_dyn_trd .OR. ln_KE_trd .OR. ln_dyn_mxl .OR.   &
+         & ln_vor_trd .OR. ln_glo_trd                       )   l_trddyn = .TRUE.
+      !
+
+!!gm check the stop below      
+      IF( ln_dyn_mxl )   CALL ctl_stop( 'ML diag on momentum are not yet coded we stop' )
+      !
+
+!!gm end
+      IF( ln_tra_mxl .OR. ln_vor_trd )   CALL ctl_stop( 'ML tracer and Barotropic vorticity diags are still using old IOIPSL' )
+!!gm end
+      !
+!      IF( .NOT.ln_linssh .AND. ( l_trdtra .OR. l_trddyn ) )  CALL ctl_stop( 'trend diagnostics with variable volume not validated' )
+      
+!!gm  : Potential BUG : 3D output only for vector invariant form!  add a ctl_stop or code the flux form case
+!!gm  : bug/pb for vertical advection of tracer in vvl case: add T.dt[eta] in the output... 
+
+      !                             ! diagnostic initialization  
+      IF( ln_glo_trd )   CALL trd_glo_init      ! global domain averaged trends
+      IF( ln_tra_mxl )   CALL trd_mxl_init      ! mixed-layer          trends  
+      IF( ln_vor_trd )   CALL trd_vor_init      ! barotropic vorticity trends
+      IF( ln_KE_trd  )   CALL trd_ken_init      ! 3D Kinetic    energy trends
+      IF( ln_PE_trd  )   CALL trd_pen_init      ! 3D Potential  energy trends
+      !
+   END SUBROUTINE trd_init
+
+   !!======================================================================
+END MODULE trdini
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/TRD/trdken.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/TRD/trdken.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/TRD/trdken.F90	(revision 9570)
@@ -0,0 +1,256 @@
+MODULE trdken
+   !!======================================================================
+   !!                       ***  MODULE  trdken  ***
+   !! Ocean diagnostics:  compute and output 3D kinetic energy trends
+   !!=====================================================================
+   !! History :  3.5  !  2012-02  (G. Madec) original code
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   trd_ken       : compute and output 3D Kinetic energy trends using IOM
+   !!   trd_ken_init  : initialisation
+   !!----------------------------------------------------------------------
+   USE oce            ! ocean dynamics and tracers variables
+   USE dom_oce        ! ocean space and time domain variables
+   USE phycst         ! physical constants
+   USE sbc_oce        ! surface boundary condition: ocean
+   USE zdf_oce        ! ocean vertical physics variables
+!!gm   USE zdfdrg         ! ocean vertical physics: bottom friction
+   USE ldftra         ! ocean active tracers lateral physics
+   USE trd_oce        ! trends: ocean variables
+   USE trdvor         ! ocean vorticity trends 
+   USE trdglo         ! trends:global domain averaged
+   USE trdmxl         ! ocean active mixed layer tracers trends
+   !
+   USE in_out_manager ! I/O manager
+   USE iom            ! I/O manager library
+   USE lib_mpp        ! MPP library
+   USE ldfslp         ! Isopycnal slopes
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   trd_ken       ! called by trddyn module
+   PUBLIC   trd_ken_init  ! called by trdini module
+
+   INTEGER ::   nkstp       ! current time step 
+
+   REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) ::   bu, bv   ! volume of u- and v-boxes
+   REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) ::   r1_bt    ! inverse of t-box volume
+
+   !! * Substitutions
+#  include "vectopt_loop_substitute.h90"
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO Consortium (2010)
+   !! $Id$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   INTEGER FUNCTION trd_ken_alloc()
+      !!---------------------------------------------------------------------
+      !!                  ***  FUNCTION trd_ken_alloc  ***
+      !!---------------------------------------------------------------------
+      ALLOCATE( bu(jpi,jpj,jpk) , bv(jpi,jpj,jpk) , r1_bt(jpi,jpj,jpk) , STAT= trd_ken_alloc )
+      !
+      IF( lk_mpp             )   CALL mpp_sum ( trd_ken_alloc )
+      IF( trd_ken_alloc /= 0 )   CALL ctl_warn('trd_ken_alloc: failed to allocate arrays')
+   END FUNCTION trd_ken_alloc
+
+
+   SUBROUTINE trd_ken( putrd, pvtrd, ktrd, kt )
+      !!---------------------------------------------------------------------
+      !!                  ***  ROUTINE trd_ken  ***
+      !! 
+      !! ** Purpose :   output 3D Kinetic Energy trends using IOM
+      !!
+      !! ** Method  : - apply lbc to the input masked velocity trends 
+      !!              - compute the associated KE trend:
+      !!          zke = 0.5 * (  mi-1[ un * putrd * bu ] + mj-1[ vn * pvtrd * bv]  ) / bt
+      !!      where bu, bv, bt are the volume of u-, v- and t-boxes. 
+      !!              - vertical diffusion case (jpdyn_zdf): 
+      !!          diagnose separately the KE trend associated with wind stress
+      !!              - bottom friction case (jpdyn_bfr):
+      !!          explicit case (ln_drgimp=F): bottom trend put in the 1st level 
+      !!                                       of putrd, pvtrd
+      !
+      !
+      !!----------------------------------------------------------------------
+      REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   putrd, pvtrd   ! U and V masked trends
+      INTEGER                   , INTENT(in   ) ::   ktrd           ! trend index
+      INTEGER                   , INTENT(in   ) ::   kt             ! time step
+      !
+      INTEGER ::   ji, jj, jk       ! dummy loop indices
+      INTEGER ::   ikbu  , ikbv     ! local integers
+      INTEGER ::   ikbum1, ikbvm1   !   -       -
+      REAL(wp), DIMENSION(:,:), ALLOCATABLE ::   z2dx, z2dy, zke2d   ! 2D workspace 
+      REAL(wp), DIMENSION(jpi,jpj,jpk)      ::   zke                 ! 3D workspace 
+      !!----------------------------------------------------------------------
+      !
+      CALL lbc_lnk_multi( putrd, 'U', -1. , pvtrd, 'V', -1. )      ! lateral boundary conditions
+      !
+      nkstp = kt
+      DO jk = 1, jpkm1
+         bu   (:,:,jk) =    e1e2u(:,:) * e3u_n(:,:,jk)
+         bv   (:,:,jk) =    e1e2v(:,:) * e3v_n(:,:,jk)
+         r1_bt(:,:,jk) = r1_e1e2t(:,:) / e3t_n(:,:,jk) * tmask(:,:,jk)
+      END DO
+      !
+      zke(:,:,jpk) = 0._wp
+      zke(1,:, : ) = 0._wp
+      zke(:,1, : ) = 0._wp
+      DO jk = 1, jpkm1
+         DO jj = 2, jpj
+            DO ji = 2, jpi
+               zke(ji,jj,jk) = 0.5_wp * rau0 *( un(ji  ,jj,jk) * putrd(ji  ,jj,jk) * bu(ji  ,jj,jk)  &
+                  &                           + un(ji-1,jj,jk) * putrd(ji-1,jj,jk) * bu(ji-1,jj,jk)  &
+                  &                           + vn(ji,jj  ,jk) * pvtrd(ji,jj  ,jk) * bv(ji,jj  ,jk)  &
+                  &                           + vn(ji,jj-1,jk) * pvtrd(ji,jj-1,jk) * bv(ji,jj-1,jk)  ) * r1_bt(ji,jj,jk)
+            END DO
+         END DO
+      END DO
+      !
+      SELECT CASE( ktrd )
+         CASE( jpdyn_hpg )   ;   CALL iom_put( "ketrd_hpg"   , zke )    ! hydrostatic pressure gradient
+         CASE( jpdyn_spg )   ;   CALL iom_put( "ketrd_spg"   , zke )    ! surface pressure gradient
+         CASE( jpdyn_pvo )   ;   CALL iom_put( "ketrd_pvo"   , zke )    ! planetary vorticity
+         CASE( jpdyn_rvo )   ;   CALL iom_put( "ketrd_rvo"   , zke )    ! relative  vorticity     (or metric term)
+         CASE( jpdyn_keg )   ;   CALL iom_put( "ketrd_keg"   , zke )    ! Kinetic Energy gradient (or had)
+         CASE( jpdyn_zad )   ;   CALL iom_put( "ketrd_zad"   , zke )    ! vertical   advection
+         CASE( jpdyn_ldf )   ;   CALL iom_put( "ketrd_ldf"   , zke )    ! lateral diffusion
+         CASE( jpdyn_zdf )   ;   CALL iom_put( "ketrd_zdf"   , zke )    ! vertical diffusion 
+         !                   !                                          ! wind stress trends
+                                 ALLOCATE( z2dx(jpi,jpj) , z2dy(jpi,jpj) , zke2d(jpi,jpj) )
+                           z2dx(:,:) = un(:,:,1) * ( utau_b(:,:) + utau(:,:) ) * e1e2u(:,:) * umask(:,:,1)
+                           z2dy(:,:) = vn(:,:,1) * ( vtau_b(:,:) + vtau(:,:) ) * e1e2v(:,:) * vmask(:,:,1)
+                           zke2d(1,:) = 0._wp   ;   zke2d(:,1) = 0._wp
+                           DO jj = 2, jpj
+                              DO ji = 2, jpi
+                                 zke2d(ji,jj) = r1_rau0 * 0.5_wp * (   z2dx(ji,jj) + z2dx(ji-1,jj)   &
+                                 &                                   + z2dy(ji,jj) + z2dy(ji,jj-1)   ) * r1_bt(ji,jj,1)
+                              END DO
+                           END DO
+                                 CALL iom_put( "ketrd_tau"   , zke2d )  ! 
+                                 DEALLOCATE( z2dx , z2dy , zke2d )
+         CASE( jpdyn_bfr )   ;   CALL iom_put( "ketrd_bfr"   , zke )    ! bottom friction (explicit case) 
+!!gm TO BE DONE properly
+!!gm only valid if ln_drgimp=F otherwise the bottom stress as to be recomputed at the end of the computation....
+!         IF(.NOT. ln_drgimp) THEN
+!            DO jj = 1, jpj    !   
+!               DO ji = 1, jpi
+!                  ikbu = mbku(ji,jj)         ! deepest ocean u- & v-levels
+!                  ikbv = mbkv(ji,jj)   
+!                  z2dx(ji,jj) = un(ji,jj,ikbu) * bfrua(ji,jj) * un(ji,jj,ikbu)
+!                  z2dy(ji,jj) = vn(ji,jj,ikbu) * bfrva(ji,jj) * vn(ji,jj,ikbv)
+!               END DO
+!            END DO
+!            zke2d(1,:) = 0._wp   ;   zke2d(:,1) = 0._wp
+!            DO jj = 2, jpj
+!               DO ji = 2, jpi
+!                  zke2d(ji,jj) = 0.5_wp * (   z2dx(ji,jj) + z2dx(ji-1,jj)   &
+!                     &                      + z2dy(ji,jj) + z2dy(ji,jj-1)   ) * r1_bt(ji,jj,  BEURK!!!
+!               END DO
+!            END DO
+!                                    CALL iom_put( "ketrd_bfr"  , zke2d )   ! bottom friction (explicit case)
+!         ENDIF
+!!gm end
+         CASE( jpdyn_atf )   ;   CALL iom_put( "ketrd_atf"   , zke )    ! asselin filter trends 
+!! a faire !!!!  idee changer dynnxt pour avoir un appel a jpdyn_bfr avant le swap !!!
+!! reflechir a une possible sauvegarde du "vrai" un,vn pour le calcul de atf....
+!
+!         IF( ln_drgimp ) THEN                                          ! bottom friction (implicit case)
+!            DO jj = 1, jpj                                                  ! after velocity known (now filed at this stage)
+!               DO ji = 1, jpi
+!                  ikbu = mbku(ji,jj)          ! deepest ocean u- & v-levels
+!                  ikbv = mbkv(ji,jj)
+!                  z2dx(ji,jj) = un(ji,jj,ikbu) * bfrua(ji,jj) * un(ji,jj,ikbu) / e3u_n(ji,jj,ikbu)
+!                  z2dy(ji,jj) = un(ji,jj,ikbu) * bfrva(ji,jj) * vn(ji,jj,ikbv) / e3v_n(ji,jj,ikbv)
+!               END DO
+!            END DO
+!            zke2d(1,:) = 0._wp   ;   zke2d(:,1) = 0._wp
+!            DO jj = 2, jpj
+!               DO ji = 2, jpi
+!                  zke2d(ji,jj) = 0.5_wp * (   z2dx(ji,jj) + z2dx(ji-1,jj)   &
+!                     &                      + z2dy(ji,jj) + z2dy(ji,jj-1)   )
+!               END DO
+!            END DO
+!                              CALL iom_put( "ketrd_bfri", zke2d )
+!         ENDIF
+        CASE( jpdyn_ken )   ;   ! kinetic energy
+                    ! called in dynnxt.F90 before asselin time filter
+                    ! with putrd=ua and pvtrd=va
+                    zke(:,:,:) = 0.5_wp * zke(:,:,:)
+                    CALL iom_put( "KE", zke )
+                    !
+                    CALL ken_p2k( kt , zke )
+                      CALL iom_put( "ketrd_convP2K", zke )     ! conversion -rau*g*w
+         !
+      END SELECT
+      !
+   END SUBROUTINE trd_ken
+
+
+   SUBROUTINE ken_p2k( kt , pconv )
+      !!---------------------------------------------------------------------
+      !!                 ***  ROUTINE ken_p2k  ***
+      !!                    
+      !! ** Purpose :   compute rate of conversion from potential to kinetic energy
+      !!
+      !! ** Method  : - compute conv defined as -rau*g*w on T-grid points
+      !! 
+      !! ** Work only for full steps and partial steps (ln_hpg_zco or ln_hpg_zps)
+      !!---------------------------------------------------------------------- 
+      INTEGER                   , INTENT(in   ) ::   kt      ! ocean time-step index
+      REAL(wp), DIMENSION(:,:,:), INTENT(  out) ::   pconv   ! 
+      !
+      INTEGER  ::   ji, jj, jk   ! dummy loop indices
+      INTEGER  ::   iku, ikv     ! local integers
+      REAL(wp) ::   zcoef        ! local scalars
+      REAL(wp), DIMENSION(jpi,jpj,jpk) ::  zconv  ! 3D workspace
+      !!----------------------------------------------------------------------
+      !
+      ! Local constant initialization 
+      zcoef = - rau0 * grav * 0.5_wp      
+      
+      !  Surface value (also valid in partial step case)
+      zconv(:,:,1) = zcoef * ( 2._wp * rhd(:,:,1) ) * wn(:,:,1) * e3w_n(:,:,1)
+
+      ! interior value (2=<jk=<jpkm1)
+      DO jk = 2, jpk
+         zconv(:,:,jk) = zcoef * ( rhd(:,:,jk) + rhd(:,:,jk-1) ) * wn(:,:,jk) * e3w_n(:,:,jk)
+      END DO
+
+      ! conv value on T-point
+      DO jk = 1, jpkm1
+         DO jj = 1, jpj
+            DO ji = 1, jpi
+               zcoef = 0.5_wp / e3t_n(ji,jj,jk)
+               pconv(ji,jj,jk) = zcoef * ( zconv(ji,jj,jk) + zconv(ji,jj,jk+1) ) * tmask(ji,jj,jk)
+            END DO
+         END DO
+      END DO
+      !
+   END SUBROUTINE ken_p2k
+
+
+   SUBROUTINE trd_ken_init
+      !!---------------------------------------------------------------------
+      !!                  ***  ROUTINE trd_ken_init  ***
+      !! 
+      !! ** Purpose :   initialisation of 3D Kinetic Energy trend diagnostic
+      !!----------------------------------------------------------------------
+      INTEGER  ::   ji, jj, jk   ! dummy loop indices
+      !!----------------------------------------------------------------------
+      !
+      IF(lwp) THEN
+         WRITE(numout,*)
+         WRITE(numout,*) 'trd_ken_init : 3D Kinetic Energy trends'
+         WRITE(numout,*) '~~~~~~~~~~~~~'
+      ENDIF
+      !                           ! allocate box volume arrays
+      IF( trd_ken_alloc() /= 0 )   CALL ctl_stop('trd_ken_alloc: failed to allocate arrays')
+      !
+   END SUBROUTINE trd_ken_init
+
+   !!======================================================================
+END MODULE trdken
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/TRD/trdmxl.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/TRD/trdmxl.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/TRD/trdmxl.F90	(revision 9570)
@@ -0,0 +1,870 @@
+MODULE trdmxl
+   !!======================================================================
+   !!                       ***  MODULE  trdmxl  ***
+   !! Ocean diagnostics:  mixed layer T-S trends 
+   !!======================================================================
+   !! History :  OPA  !  1995-04  (J. Vialard)    Original code
+   !!                 !  1997-02  (E. Guilyardi)  Adaptation global + base cmo
+   !!                 !  1999-09  (E. Guilyardi)  Re-writing + netCDF output
+   !!   NEMO     1.0  !  2002-06  (G. Madec)      F90: Free form and module
+   !!             -   !  2004-08  (C. Talandier)  New trends organization
+   !!            2.0  !  2005-05  (C. Deltel)     Diagnose trends of time averaged ML T & S
+   !!            3.5  !  2012-03  (G. Madec)      complete reorganisation + change in the time averaging
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   trd_mxl          : T and S cumulated trends averaged over the mixed layer
+   !!   trd_mxl_zint     : T and S trends vertical integration
+   !!   trd_mxl_init     : initialization step
+   !!----------------------------------------------------------------------
+   USE oce             ! ocean dynamics and tracers variables
+   USE dom_oce         ! ocean space and time domain variables
+   USE trd_oce         ! trends: ocean variables
+   USE trdmxl_oce      ! ocean variables trends
+   USE ldftra          ! lateral diffusion: eddy diffusivity & EIV coeff.
+   USE zdf_oce         ! ocean vertical physics
+   USE phycst          ! Define parameters for the routines
+   USE dianam          ! build the name of file (routine)
+   USE ldfslp          ! iso-neutral slopes 
+   USE zdfmxl          ! mixed layer depth
+   USE zdfddm          ! ocean vertical physics: double diffusion
+   USE lbclnk          ! ocean lateral boundary conditions (or mpp link)
+   USE trdmxl_rst      ! restart for diagnosing the ML trends
+   !
+   USE in_out_manager  ! I/O manager
+   USE ioipsl          ! NetCDF library
+   USE prtctl          ! Print control
+   USE restart         ! for lrst_oce
+   USE lib_mpp         ! MPP library
+   USE iom
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   trd_mxl        ! routine called by step.F90
+   PUBLIC   trd_mxl_init   ! routine called by opa.F90
+   PUBLIC   trd_mxl_zint   ! routine called by tracers routines
+
+   INTEGER ::   nkstp       ! current time step 
+
+!!gm  to be moved from trdmxl_oce
+!   REAL(wp), ALLOCATABLE, DIMENSION(:,:) ::   hml                ! ML depth (sum of e3t over nmln-1 levels) [m] 
+!   REAL(wp), ALLOCATABLE, DIMENSION(:,:) ::   tml    , sml       ! now ML averaged T & S 
+!   REAL(wp), ALLOCATABLE, DIMENSION(:,:) ::   tmlb_nf, smlb_nf   ! not filtered before ML averaged T & S
+!
+!
+!   REAL(wp), ALLOCATABLE, DIMENSION(:,:) ::   hmlb, hmln         ! before, now, and after Mixed Layer depths [m]
+!   
+!   REAL(wp), ALLOCATABLE, DIMENSION(:,:) ::   tb_mlb, tb_mln     ! before (not filtered) tracer averaged over before and now ML 
+!
+!   REAL(wp), ALLOCATABLE, DIMENSION(:,:) ::   tn_mln             ! now tracer averaged over now ML
+!!gm end   
+   
+   CHARACTER (LEN=40) ::  clhstnam         ! name of the trends NetCDF file
+   INTEGER ::   nh_t, nmoymltrd
+   INTEGER ::   nidtrd
+   INTEGER, ALLOCATABLE, SAVE, DIMENSION(:) ::   ndextrd1
+   INTEGER ::   ndimtrd1                        
+   INTEGER ::   ionce, icount                   
+
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO Consortium (2010)
+   !! $Id$ 
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   INTEGER FUNCTION trd_mxl_alloc()
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE trd_mxl_alloc  ***
+      !!----------------------------------------------------------------------
+      ALLOCATE( ndextrd1(jpi*jpj) , STAT=trd_mxl_alloc )
+      !
+      IF( lk_mpp             )   CALL mpp_sum ( trd_mxl_alloc )
+      IF( trd_mxl_alloc /= 0 )   CALL ctl_warn('trd_mxl_alloc: failed to allocate array ndextrd1')
+   END FUNCTION trd_mxl_alloc
+
+
+   SUBROUTINE trd_tra_mxl( ptrdx, ptrdy, ktrd, kt, p2dt, kmxln )
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE trd_tra_mng  ***
+      !! 
+      !! ** Purpose :   Dispatch all trends computation, e.g. 3D output, integral
+      !!                constraints, barotropic vorticity, kinetic enrgy, 
+      !!                potential energy, and/or mixed layer budget.
+      !!----------------------------------------------------------------------
+      REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   ptrdx   ! Temperature or U trend 
+      REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   ptrdy   ! Salinity    or V trend
+      INTEGER                   , INTENT(in   ) ::   ktrd    ! tracer trend index
+      INTEGER                   , INTENT(in   ) ::   kt      ! time step index
+      REAL(wp)                  , INTENT(in   ) ::   p2dt    ! time step  [s]
+      REAL(wp), DIMENSION(:,:)  , INTENT(in   ) ::   kmxln   ! number of t-box for the vertical average 
+      !
+      INTEGER ::   ji, jj, jk   ! dummy loop indices
+      !!----------------------------------------------------------------------
+
+      !                         !==============================!
+      IF ( kt /= nkstp ) THEN   !=  1st call at kt time step  =!
+         !                      !==============================!
+         nkstp = kt
+         
+         
+         !                          !==  reset trend arrays to zero  ==!
+         tmltrd(:,:,:) = 0._wp    ;    smltrd(:,:,:) = 0._wp    
+         
+         
+         !
+         wkx(:,:,:) = 0._wp         !==  now ML weights for vertical averaging  ==!
+         DO jk = 1, jpktrd               ! initialize wkx with vertical scale factor in mixed-layer
+            DO jj = 1,jpj
+               DO ji = 1,jpi
+                  IF( jk - kmxln(ji,jj) < 0 )   wkx(ji,jj,jk) = e3t_n(ji,jj,jk) * tmask(ji,jj,jk)
+               END DO
+            END DO
+         END DO
+         hmxl(:,:) = 0._wp               ! NOW mixed-layer depth
+         DO jk = 1, jpktrd
+            hmxl(:,:) = hmxl(:,:) + wkx(:,:,jk)
+         END DO
+         DO jk = 1, jpktrd               ! integration weights
+            wkx(:,:,jk) = wkx(:,:,jk) / MAX( 1.e-20_wp, hmxl(:,:) ) * tmask(:,:,1)
+         END DO
+         
+         
+         !
+         !                          !==  Vertically averaged T and S  ==!
+         tml(:,:) = 0._wp   ;   sml(:,:) = 0._wp
+         DO jk = 1, jpktrd
+            tml(:,:) = tml(:,:) + wkx(:,:,jk) * tsn(:,:,jk,jp_tem)
+            sml(:,:) = sml(:,:) + wkx(:,:,jk) * tsn(:,:,jk,jp_sal)
+         END DO
+         !
+      ENDIF
+
+
+
+      ! mean now trends over the now ML 
+      tmltrd(:,:,ktrd) = tmltrd(:,:,ktrd) + ptrdx(:,:,jk) * wkx(:,:,jk)   ! temperature
+      smltrd(:,:,ktrd) = smltrd(:,:,ktrd) + ptrdy(:,:,jk) * wkx(:,:,jk)   ! salinity
+ 
+
+ 
+!!gm to be put juste before the output !
+!      ! Lateral boundary conditions
+!      CALL lbc_lnk_multi( tmltrd(:,:,jl), 'T', 1. , smltrd(:,:,jl), 'T', 1. )
+!!gm end
+
+
+
+         SELECT CASE( ktrd )
+         CASE( jptra_npc  )               ! non-penetrative convection: regrouped with zdf
+!!gm : to be completed ! 
+!		   IF( ....
+!!gm end
+         CASE( jptra_zdfp )               ! iso-neutral diffusion: "pure" vertical diffusion
+!                                   ! regroup iso-neutral diffusion in one term
+         tmltrd(:,:,jpmxl_ldf) = tmltrd(:,:,jpmxl_ldf) + ( tmltrd(:,:,jpmxl_zdf) - tmltrd(:,:,jpmxl_zdfp) )
+         smltrd(:,:,jpmxl_ldf) = smltrd(:,:,jpmxl_ldf) + ( smltrd(:,:,jpmxl_zdf) - smltrd(:,:,jpmxl_zdfp) )
+         !                                   ! put in zdf the dia-neutral diffusion
+         tmltrd(:,:,jpmxl_zdf) = tmltrd(:,:,jpmxl_zdfp)
+         smltrd(:,:,jpmxl_zdf) = smltrd(:,:,jpmxl_zdfp)
+         IF( ln_zdfnpc ) THEN
+            tmltrd(:,:,jpmxl_zdf) = tmltrd(:,:,jpmxl_zdf) + tmltrd(:,:,jpmxl_npc)
+            smltrd(:,:,jpmxl_zdf) = smltrd(:,:,jpmxl_zdf) + smltrd(:,:,jpmxl_npc)
+         ENDIF
+         !
+      CASE( jptra_atf  )               ! last trends of the current time step: perform the time averaging & output
+         !
+         ! after ML           :   zhmla                      NB will be swaped to provide hmln and hmlb
+         !
+         ! entrainement ent_1 :   tb_mln - tb_mlb        ==>> use previous timestep ztn_mla = tb_mln
+         !                                                    "     "         "     tn_mln = tb_mlb  (unfiltered tb!)
+         !                                                   NB: tn_mln itself comes from the 2 time step before (ta_mla)
+         !
+         ! atf trend          :   ztbf_mln - tb_mln      ==>> use previous timestep tn_mla = tb_mln
+         !                                                   need to compute tbf_mln, using the current tb
+         !                                                   which is the before fitered tracer
+         !
+         ! entrainement ent_2 :   zta_mla - zta_mln      ==>> need to compute zta_mla and zta_mln
+         !
+         ! time averaging     :   mean: CALL trd_mean( kt, ptrd, ptrdm )
+         !                              and out put the starting mean value and the total trends
+         !                              (i.e. difference between starting and ending values)
+         !                        hat : CALL trd_hat ( kt, ptrd, ptrdm )
+         !                              and output the starting hat value and the total hat trends
+         !
+         ! swaps              :   hmlb   <==   hmln   <== zhmla
+         !                        tb_mlb <==  tn_mln  <== zta_mla
+         !                        tb_mln <== ztn_mla     ==>> now T over after h, need to be computed here 
+         !                                                    to be used at next time step (unfiltered before)
+         !
+      END SELECT
+      !
+   END SUBROUTINE trd_tra_mxl
+
+
+   SUBROUTINE trd_mean( kt, ptrd, ptrdm )
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE trd_mean  ***
+      !! 
+      !! ** Purpose :   
+      !!----------------------------------------------------------------------
+      REAL(wp), DIMENSION(:,:,:), INTENT(in   ) ::   ptrd    ! trend at kt
+      REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   ptrdm   ! cumulative trends at kt
+      INTEGER                   , INTENT(in   ) ::   kt      ! time step index
+      !!----------------------------------------------------------------------
+      !
+      IF ( kt == nn_it000 )   ptrdm(:,:,:) = 0._wp
+      !
+      ptrdm(:,:,:) = ptrdm(:,:,:) + ptrd(:,:,:)
+      !
+      IF ( MOD( kt - nn_it000 + 1, nn_trd ) == 0 ) THEN
+         !
+         ! call iom put????  avec en argument le tableau de nom des trends?
+         !
+      ENDIF
+      !
+   END SUBROUTINE trd_mean
+
+
+   SUBROUTINE trd_mxl_zint( pttrdmxl, pstrdmxl, ktrd, ctype )
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE trd_mxl_zint  ***
+      !! 
+      !! ** Purpose :   Compute the vertical average of the 3D fields given as arguments 
+      !!                to the subroutine. This vertical average is performed from ocean
+      !!                surface down to a chosen control surface.
+      !!
+      !! ** Method/usage :
+      !!      The control surface can be either a mixed layer depth (time varying)
+      !!      or a fixed surface (jk level or bowl). 
+      !!      Choose control surface with nn_ctls in namelist NAMTRD :
+      !!        nn_ctls = 0  : use mixed layer with density criterion 
+      !!        nn_ctls = 1  : read index from file 'ctlsurf_idx'
+      !!        nn_ctls > 1  : use fixed level surface jk = nn_ctls
+      !!      Note: in the remainder of the routine, the volume between the 
+      !!            surface and the control surface is called "mixed-layer"
+      !!----------------------------------------------------------------------
+      INTEGER                         , INTENT( in ) ::   ktrd       ! ocean trend index
+      CHARACTER(len=2)                , INTENT( in ) ::   ctype      ! 2D surface/bottom or 3D interior physics
+      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT( in ) ::   pttrdmxl   ! temperature trend 
+      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT( in ) ::   pstrdmxl   ! salinity trend 
+      !
+      INTEGER ::   ji, jj, jk, isum
+      REAL(wp), DIMENSION(jpi,jpj)  :: zvlmsk 
+      !!----------------------------------------------------------------------
+
+      ! I. Definition of control surface and associated fields
+      ! ------------------------------------------------------
+      !            ==> only once per time step <== 
+
+      IF( icount == 1 ) THEN        
+         !
+         
+!!gm BUG?
+!!gm CAUTION:  double check the definition of nmln  it is the nb of w-level, not t-level I guess
+
+         
+         ! ... Set nmxl(ji,jj) = index of first T point below control surf. or outside mixed-layer
+         IF( nn_ctls == 0 ) THEN       ! * control surface = mixed-layer with density criterion 
+            nmxl(:,:) = nmln(:,:)    ! array nmln computed in zdfmxl.F90
+         ELSEIF( nn_ctls == 1 ) THEN   ! * control surface = read index from file 
+            nmxl(:,:) = nbol(:,:)
+         ELSEIF( nn_ctls >= 2 ) THEN   ! * control surface = model level
+            nn_ctls = MIN( nn_ctls, jpktrd - 1 )
+            nmxl(:,:) = nn_ctls + 1
+         ENDIF
+
+      END IF
+      !
+   END SUBROUTINE trd_mxl_zint
+    
+
+   SUBROUTINE trd_mxl( kt, p2dt )
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE trd_mxl  ***
+      !! 
+      !! ** Purpose :  Compute and cumulate the mixed layer trends over an analysis
+      !!               period, and write NetCDF outputs.
+      !!
+      !! ** Method/usage :
+      !!          The stored trends can be chosen twofold (according to the ln_trdmxl_instant 
+      !!          logical namelist variable) :
+      !!          1) to explain the difference between initial and final 
+      !!             mixed-layer T & S (where initial and final relate to the
+      !!             current analysis window, defined by nn_trd in the namelist)
+      !!          2) to explain the difference between the current and previous 
+      !!             TIME-AVERAGED mixed-layer T & S (where time-averaging is
+      !!             performed over each analysis window).
+      !!
+      !! ** Consistency check : 
+      !!        If the control surface is fixed ( nn_ctls > 1 ), the residual term (dh/dt
+      !!        entrainment) should be zero, at machine accuracy. Note that in the case
+      !!        of time-averaged mixed-layer fields, this residual WILL NOT BE ZERO
+      !!        over the first two analysis windows (except if restart).
+      !!        N.B. For ORCA2_LIM, use e.g. nn_trd=5, rn_ucf=1., nn_ctls=8
+      !!             for checking residuals.
+      !!             On a NEC-SX5 computer, this typically leads to:
+      !!                   O(1.e-20) temp. residuals (tml_res) when ln_trdmxl_instant=.false.
+      !!                   O(1.e-21) temp. residuals (tml_res) when ln_trdmxl_instant=.true.
+      !!
+      !! ** Action :
+      !!       At each time step, mixed-layer averaged trends are stored in the 
+      !!       tmltrd(:,:,jpmxl_xxx) array (see trdmxl_oce.F90 for definitions of jpmxl_xxx).
+      !!       This array is known when trd_mxl is called, at the end of the stp subroutine, 
+      !!       except for the purely vertical K_z diffusion term, which is embedded in the
+      !!       lateral diffusion trend.
+      !!
+      !!       In I), this K_z term is diagnosed and stored, thus its contribution is removed
+      !!       from the lateral diffusion trend.
+      !!       In II), the instantaneous mixed-layer T & S are computed, and misc. cumulative
+      !!       arrays are updated.
+      !!       In III), called only once per analysis window, we compute the total trends,
+      !!       along with the residuals and the Asselin correction terms.
+      !!       In IV), the appropriate trends are written in the trends NetCDF file.
+      !!
+      !! References :  Vialard et al.,2001, JPO.
+      !!----------------------------------------------------------------------
+      INTEGER , INTENT(in   ) ::   kt     ! ocean time-step index
+      REAL(wp), INTENT(in   ) ::   p2dt   ! time step  [s]
+      !
+      INTEGER :: ji, jj, jk, jl, ik, it, itmod
+      LOGICAL :: lldebug = .TRUE.
+      REAL(wp) :: zavt, zfn, zfn2
+      !                                              ! z(ts)mltot : dT/dt over the anlysis window (including Asselin)
+      !                                              ! z(ts)mlres : residual = dh/dt entrainment term
+      REAL(wp), DIMENSION(jpi,jpj  )   ::  ztmltot , zsmltot , ztmlres , zsmlres , ztmlatf , zsmlatf
+      REAL(wp), DIMENSION(jpi,jpj  )   ::  ztmltot2, zsmltot2, ztmlres2, zsmlres2, ztmlatf2, zsmlatf2, ztmltrdm2, zsmltrdm2  
+      REAL(wp), DIMENSION(jpi,jpj,jpk) ::  ztmltrd2, zsmltrd2   ! only needed for mean diagnostics
+      !!----------------------------------------------------------------------
+  
+      ! ======================================================================
+      ! II. Cumulate the trends over the analysis window
+      ! ======================================================================
+
+      ztmltrd2(:,:,:) = 0.e0   ;    zsmltrd2(:,:,:) = 0.e0  ! <<< reset arrays to zero
+      ztmltot2(:,:)   = 0.e0   ;    zsmltot2(:,:)   = 0.e0
+      ztmlres2(:,:)   = 0.e0   ;    zsmlres2(:,:)   = 0.e0
+      ztmlatf2(:,:)   = 0.e0   ;    zsmlatf2(:,:)   = 0.e0
+
+      ! II.1 Set before values of vertically average T and S 
+      ! ----------------------------------------------------
+      IF( kt > nit000 ) THEN
+         !   ... temperature ...                    ... salinity ...
+         tmlb   (:,:) = tml   (:,:)             ;   smlb   (:,:) = sml   (:,:)
+         tmlatfn(:,:) = tmltrd(:,:,jpmxl_atf)   ;   smlatfn(:,:) = smltrd(:,:,jpmxl_atf)
+      END IF
+
+
+      ! II.3 Initialize mixed-layer "before" arrays for the 1rst analysis window    
+      ! ------------------------------------------------------------------------
+      IF( kt == 2 ) THEN  !  i.e. ( .NOT. ln_rstart ).AND.( kt == nit000 + 1)
+         !
+         !   ... temperature ...                ... salinity ...
+         tmlbb  (:,:) = tmlb   (:,:)   ;   smlbb  (:,:) = smlb   (:,:)
+         tmlbn  (:,:) = tml    (:,:)   ;   smlbn  (:,:) = sml    (:,:)
+         tmlatfb(:,:) = tmlatfn(:,:)   ;   smlatfb(:,:) = smlatfn(:,:)
+         
+         tmltrd_csum_ub (:,:,:) = 0.e0  ;   smltrd_csum_ub (:,:,:) = 0.e0
+         tmltrd_atf_sumb(:,:)   = 0.e0  ;   smltrd_atf_sumb(:,:)   = 0.e0
+
+         hmxlbn(:,:) = hmxl(:,:)
+
+         IF( ln_ctl ) THEN
+            WRITE(numout,*) '             we reach kt == nit000 + 1 = ', nit000+1
+            CALL prt_ctl(tab2d_1=tmlbb   , clinfo1=' tmlbb   -   : ', mask1=tmask)
+            CALL prt_ctl(tab2d_1=tmlbn   , clinfo1=' tmlbn   -   : ', mask1=tmask)
+            CALL prt_ctl(tab2d_1=tmlatfb , clinfo1=' tmlatfb -   : ', mask1=tmask)
+         END IF
+         !
+      END IF
+
+      IF( ( ln_rstart ) .AND. ( kt == nit000 ) .AND. ( ln_ctl ) ) THEN
+         IF( ln_trdmxl_instant ) THEN
+            WRITE(numout,*) '             restart from kt == nit000 = ', nit000
+            CALL prt_ctl(tab2d_1=tmlbb   , clinfo1=' tmlbb   -   : ', mask1=tmask)
+            CALL prt_ctl(tab2d_1=tmlbn   , clinfo1=' tmlbn   -   : ', mask1=tmask)
+            CALL prt_ctl(tab2d_1=tmlatfb , clinfo1=' tmlatfb -   : ', mask1=tmask)
+         ELSE
+            WRITE(numout,*) '             restart from kt == nit000 = ', nit000
+            CALL prt_ctl(tab2d_1=tmlbn          , clinfo1=' tmlbn           -  : ', mask1=tmask)
+            CALL prt_ctl(tab2d_1=hmxlbn         , clinfo1=' hmxlbn          -  : ', mask1=tmask)
+            CALL prt_ctl(tab2d_1=tml_sumb       , clinfo1=' tml_sumb        -  : ', mask1=tmask)
+            CALL prt_ctl(tab2d_1=tmltrd_atf_sumb, clinfo1=' tmltrd_atf_sumb -  : ', mask1=tmask)
+            CALL prt_ctl(tab3d_1=tmltrd_csum_ub , clinfo1=' tmltrd_csum_ub  -  : ', mask1=tmask, kdim=1)
+         END IF
+      END IF
+
+      ! II.4 Cumulated trends over the analysis period
+      ! ----------------------------------------------
+      !
+      !         [  1rst analysis window ] [     2nd analysis window     ]                       
+      !
+      !     o---[--o-----o-----o-----o--]-[--o-----o-----o-----o-----o--]---o-----o--> time steps
+      !                          nn_trd                           2*nn_trd       etc.
+      !     1      2     3     4    =5 e.g.                          =10
+      !
+      IF( ( kt >= 2 ).OR.( ln_rstart ) ) THEN
+         !
+         nmoymltrd = nmoymltrd + 1
+         
+         ! ... Cumulate over BOTH physical contributions AND over time steps
+         DO jl = 1, jpltrd
+            tmltrdm(:,:) = tmltrdm(:,:) + tmltrd(:,:,jl)
+            smltrdm(:,:) = smltrdm(:,:) + smltrd(:,:,jl)
+         END DO
+
+         ! ... Special handling of the Asselin trend 
+         tmlatfm(:,:) = tmlatfm(:,:) + tmlatfn(:,:)
+         smlatfm(:,:) = smlatfm(:,:) + smlatfn(:,:)
+
+         ! ... Trends associated with the time mean of the ML T/S
+         tmltrd_sum    (:,:,:) = tmltrd_sum    (:,:,:) + tmltrd    (:,:,:) ! tem
+         tmltrd_csum_ln(:,:,:) = tmltrd_csum_ln(:,:,:) + tmltrd_sum(:,:,:)
+         tml_sum       (:,:)   = tml_sum       (:,:)   + tml       (:,:)
+         smltrd_sum    (:,:,:) = smltrd_sum    (:,:,:) + smltrd    (:,:,:) ! sal
+         smltrd_csum_ln(:,:,:) = smltrd_csum_ln(:,:,:) + smltrd_sum(:,:,:)
+         sml_sum       (:,:)   = sml_sum       (:,:)   + sml       (:,:)
+         hmxl_sum      (:,:)   = hmxl_sum      (:,:)   + hmxl      (:,:)   ! rmxl
+         !
+      END IF
+
+      ! ======================================================================
+      ! III. Prepare fields for output (get here ONCE PER ANALYSIS PERIOD)
+      ! ======================================================================
+
+      ! Convert to appropriate physical units
+      ! N.B. It may be useful to check IOIPSL time averaging with :
+      !      tmltrd (:,:,:) = 1. ; smltrd (:,:,:) = 1.
+      tmltrd(:,:,:) = tmltrd(:,:,:) * rn_ucf   ! (actually needed for 1:jpltrd-1, but trdmxl(:,:,jpltrd)
+      smltrd(:,:,:) = smltrd(:,:,:) * rn_ucf   !  is no longer used, and is reset to 0. at next time step)
+      
+      ! define time axis
+      it = kt
+      itmod = kt - nit000 + 1
+
+      MODULO_NTRD : IF( MOD( itmod, nn_trd ) == 0 ) THEN        ! nitend MUST be multiple of nn_trd
+         !
+         ztmltot (:,:) = 0.e0   ;   zsmltot (:,:) = 0.e0   ! reset arrays to zero
+         ztmlres (:,:) = 0.e0   ;   zsmlres (:,:) = 0.e0
+         ztmltot2(:,:) = 0.e0   ;   zsmltot2(:,:) = 0.e0
+         ztmlres2(:,:) = 0.e0   ;   zsmlres2(:,:) = 0.e0
+      
+         zfn  = REAL( nmoymltrd, wp )   ;   zfn2 = zfn * zfn
+         
+         ! III.1 Prepare fields for output ("instantaneous" diagnostics) 
+         ! -------------------------------------------------------------
+         
+         !-- Compute total trends
+         ztmltot(:,:) = ( tml(:,:) - tmlbn(:,:) + tmlb(:,:) - tmlbb(:,:) ) / p2dt
+         zsmltot(:,:) = ( sml(:,:) - smlbn(:,:) + smlb(:,:) - smlbb(:,:) ) / p2dt
+         
+         !-- Compute residuals
+         ztmlres(:,:) = ztmltot(:,:) - ( tmltrdm(:,:) - tmlatfn(:,:) + tmlatfb(:,:) )
+         zsmlres(:,:) = zsmltot(:,:) - ( smltrdm(:,:) - smlatfn(:,:) + smlatfb(:,:) )
+      
+         !-- Diagnose Asselin trend over the analysis window 
+         ztmlatf(:,:) = tmlatfm(:,:) - tmlatfn(:,:) + tmlatfb(:,:)
+         zsmlatf(:,:) = smlatfm(:,:) - smlatfn(:,:) + smlatfb(:,:)
+         
+         !-- Lateral boundary conditions
+         !         ... temperature ...                    ... salinity ...
+         CALL lbc_lnk_multi( ztmltot , 'T', 1., zsmltot , 'T', 1., &
+                  &          ztmlres , 'T', 1., zsmlres , 'T', 1., &
+                  &          ztmlatf , 'T', 1., zsmlatf , 'T', 1. )
+
+
+         ! III.2 Prepare fields for output ("mean" diagnostics) 
+         ! ----------------------------------------------------
+         
+         !-- Update the ML depth time sum (to build the Leap-Frog time mean)
+         hmxl_sum(:,:) = hmxlbn(:,:) + 2 * ( hmxl_sum(:,:) - hmxl(:,:) ) + hmxl(:,:)
+
+         !-- Compute temperature total trends
+         tml_sum (:,:) = tmlbn(:,:) + 2 * ( tml_sum(:,:) - tml(:,:) ) + tml(:,:)
+         ztmltot2(:,:) = ( tml_sum(:,:) - tml_sumb(:,:) ) / p2dt    ! now in degC/s
+         
+         !-- Compute salinity total trends
+         sml_sum (:,:) = smlbn(:,:) + 2 * ( sml_sum(:,:) - sml(:,:) ) + sml(:,:)
+         zsmltot2(:,:) = ( sml_sum(:,:) - sml_sumb(:,:) ) / p2dt    ! now in psu/s
+         
+         !-- Compute temperature residuals
+         DO jl = 1, jpltrd
+            ztmltrd2(:,:,jl) = tmltrd_csum_ub(:,:,jl) + tmltrd_csum_ln(:,:,jl)
+         END DO
+
+         ztmltrdm2(:,:) = 0.e0
+         DO jl = 1, jpltrd
+            ztmltrdm2(:,:) = ztmltrdm2(:,:) + ztmltrd2(:,:,jl)
+         END DO
+
+         ztmlres2(:,:) =  ztmltot2(:,:)  -       &
+              ( ztmltrdm2(:,:) - tmltrd_sum(:,:,jpmxl_atf) + tmltrd_atf_sumb(:,:) )
+         
+         !-- Compute salinity residuals
+         DO jl = 1, jpltrd
+            zsmltrd2(:,:,jl) = smltrd_csum_ub(:,:,jl) + smltrd_csum_ln(:,:,jl)
+         END DO
+
+         zsmltrdm2(:,:) = 0.
+         DO jl = 1, jpltrd
+            zsmltrdm2(:,:) = zsmltrdm2(:,:) + zsmltrd2(:,:,jl)
+         END DO
+
+         zsmlres2(:,:) =  zsmltot2(:,:)  -       &
+              ( zsmltrdm2(:,:) - smltrd_sum(:,:,jpmxl_atf) + smltrd_atf_sumb(:,:) )
+         
+         !-- Diagnose Asselin trend over the analysis window
+         ztmlatf2(:,:) = ztmltrd2(:,:,jpmxl_atf) - tmltrd_sum(:,:,jpmxl_atf) + tmltrd_atf_sumb(:,:)
+         zsmlatf2(:,:) = zsmltrd2(:,:,jpmxl_atf) - smltrd_sum(:,:,jpmxl_atf) + smltrd_atf_sumb(:,:)
+
+         !-- Lateral boundary conditions
+         !         ... temperature ...                    ... salinity ...
+         CALL lbc_lnk_multi( ztmltot2, 'T', 1., zsmltot2, 'T', 1., &
+                  &          ztmlres2, 'T', 1., zsmlres2, 'T', 1. )
+         !
+         CALL lbc_lnk_multi( ztmltrd2(:,:,:), 'T', 1., zsmltrd2(:,:,:), 'T', 1. ) ! /  in the NetCDF trends file
+         
+         ! III.3 Time evolution array swap
+         ! -------------------------------
+         
+         ! For T/S instantaneous diagnostics 
+         !   ... temperature ...               ... salinity ...
+         tmlbb  (:,:) = tmlb   (:,:)  ;   smlbb  (:,:) = smlb   (:,:)
+         tmlbn  (:,:) = tml    (:,:)  ;   smlbn  (:,:) = sml    (:,:)
+         tmlatfb(:,:) = tmlatfn(:,:)  ;   smlatfb(:,:) = smlatfn(:,:)
+
+         ! For T mean diagnostics 
+         tmltrd_csum_ub (:,:,:) = zfn * tmltrd_sum(:,:,:) - tmltrd_csum_ln(:,:,:)
+         tml_sumb       (:,:)   = tml_sum(:,:)
+         tmltrd_atf_sumb(:,:)   = tmltrd_sum(:,:,jpmxl_atf)
+         
+         ! For S mean diagnostics 
+         smltrd_csum_ub (:,:,:) = zfn * smltrd_sum(:,:,:) - smltrd_csum_ln(:,:,:)
+         sml_sumb       (:,:)   = sml_sum(:,:)
+         smltrd_atf_sumb(:,:)   = smltrd_sum(:,:,jpmxl_atf)
+         
+         ! ML depth
+         hmxlbn         (:,:)   = hmxl    (:,:)
+         
+         IF( ln_ctl ) THEN
+            IF( ln_trdmxl_instant ) THEN
+               CALL prt_ctl(tab2d_1=tmlbb   , clinfo1=' tmlbb   -   : ', mask1=tmask)
+               CALL prt_ctl(tab2d_1=tmlbn   , clinfo1=' tmlbn   -   : ', mask1=tmask)
+               CALL prt_ctl(tab2d_1=tmlatfb , clinfo1=' tmlatfb -   : ', mask1=tmask)
+            ELSE
+               CALL prt_ctl(tab2d_1=tmlbn          , clinfo1=' tmlbn           -  : ', mask1=tmask)
+               CALL prt_ctl(tab2d_1=hmxlbn         , clinfo1=' hmxlbn          -  : ', mask1=tmask)
+               CALL prt_ctl(tab2d_1=tml_sumb       , clinfo1=' tml_sumb        -  : ', mask1=tmask)
+               CALL prt_ctl(tab2d_1=tmltrd_atf_sumb, clinfo1=' tmltrd_atf_sumb -  : ', mask1=tmask)
+               CALL prt_ctl(tab3d_1=tmltrd_csum_ub , clinfo1=' tmltrd_csum_ub  -  : ', mask1=tmask, kdim=1)
+            END IF
+         END IF
+
+         ! III.4 Convert to appropriate physical units
+         ! -------------------------------------------
+
+         !    ... temperature ...                         ... salinity ...
+         ztmltot (:,:)   = ztmltot(:,:)   * rn_ucf/zfn  ; zsmltot (:,:)   = zsmltot(:,:)   * rn_ucf/zfn
+         ztmlres (:,:)   = ztmlres(:,:)   * rn_ucf/zfn  ; zsmlres (:,:)   = zsmlres(:,:)   * rn_ucf/zfn
+         ztmlatf (:,:)   = ztmlatf(:,:)   * rn_ucf/zfn  ; zsmlatf (:,:)   = zsmlatf(:,:)   * rn_ucf/zfn
+
+         tml_sum (:,:)   = tml_sum (:,:)  /  (2*zfn) ; sml_sum (:,:)   = sml_sum (:,:)  /  (2*zfn)
+         ztmltot2(:,:)   = ztmltot2(:,:)  * rn_ucf/zfn2 ; zsmltot2(:,:)   = zsmltot2(:,:)  * rn_ucf/zfn2
+         ztmltrd2(:,:,:) = ztmltrd2(:,:,:)* rn_ucf/zfn2 ; zsmltrd2(:,:,:) = zsmltrd2(:,:,:)* rn_ucf/zfn2
+         ztmlatf2(:,:)   = ztmlatf2(:,:)  * rn_ucf/zfn2 ; zsmlatf2(:,:)   = zsmlatf2(:,:)  * rn_ucf/zfn2
+         ztmlres2(:,:)   = ztmlres2(:,:)  * rn_ucf/zfn2 ; zsmlres2(:,:)   = zsmlres2(:,:)  * rn_ucf/zfn2
+
+         hmxl_sum(:,:)   = hmxl_sum(:,:)  /  (2*zfn)  ! similar to tml_sum and sml_sum
+
+         ! * Debugging information *
+         IF( lldebug ) THEN
+            !
+            WRITE(numout,*)
+            WRITE(numout,*) 'trd_mxl : write trends in the Mixed Layer for debugging process:'
+            WRITE(numout,*) '~~~~~~~  '
+            WRITE(numout,*) '          TRA kt = ', kt, 'nmoymltrd = ', nmoymltrd
+            WRITE(numout,*)
+            WRITE(numout,*) '          >>>>>>>>>>>>>>>>>>  TRA TEMPERATURE <<<<<<<<<<<<<<<<<<'
+            WRITE(numout,*) '          TRA ztmlres    : ', SUM(ztmlres(:,:))
+            WRITE(numout,*) '          TRA ztmltot    : ', SUM(ztmltot(:,:))
+            WRITE(numout,*) '          TRA tmltrdm    : ', SUM(tmltrdm(:,:))
+            WRITE(numout,*) '          TRA tmlatfb    : ', SUM(tmlatfb(:,:))
+            WRITE(numout,*) '          TRA tmlatfn    : ', SUM(tmlatfn(:,:))
+            DO jl = 1, jpltrd
+               WRITE(numout,*) '          * TRA TREND INDEX jpmxl_xxx = jl = ', jl, &
+                    & ' tmltrd : ', SUM(tmltrd(:,:,jl))
+            END DO
+            WRITE(numout,*) '          TRA ztmlres (jpi/2,jpj/2) : ', ztmlres (jpi/2,jpj/2)
+            WRITE(numout,*) '          TRA ztmlres2(jpi/2,jpj/2) : ', ztmlres2(jpi/2,jpj/2)
+            WRITE(numout,*)
+            WRITE(numout,*) '          >>>>>>>>>>>>>>>>>>  TRA SALINITY <<<<<<<<<<<<<<<<<<'
+            WRITE(numout,*) '          TRA zsmlres    : ', SUM(zsmlres(:,:))
+            WRITE(numout,*) '          TRA zsmltot    : ', SUM(zsmltot(:,:))
+            WRITE(numout,*) '          TRA smltrdm    : ', SUM(smltrdm(:,:))
+            WRITE(numout,*) '          TRA smlatfb    : ', SUM(smlatfb(:,:))
+            WRITE(numout,*) '          TRA smlatfn    : ', SUM(smlatfn(:,:))
+            DO jl = 1, jpltrd
+               WRITE(numout,*) '          * TRA TREND INDEX jpmxl_xxx = jl = ', jl, &
+                    & ' smltrd : ', SUM(smltrd(:,:,jl))
+            END DO
+            WRITE(numout,*) '          TRA zsmlres (jpi/2,jpj/2) : ', zsmlres (jpi/2,jpj/2)
+            WRITE(numout,*) '          TRA zsmlres2(jpi/2,jpj/2) : ', zsmlres2(jpi/2,jpj/2)
+            !
+         END IF
+         !
+      END IF MODULO_NTRD
+
+      ! ======================================================================
+      ! IV. Write trends in the NetCDF file
+      ! ======================================================================
+
+      !-- Write the trends for T/S instantaneous diagnostics 
+      
+      IF( ln_trdmxl_instant ) THEN           
+
+         CALL iom_put( "mxl_depth", hmxl(:,:) )
+         
+         !................................. ( ML temperature ) ...................................
+         
+         !-- Output the fields
+         CALL iom_put( "tml"     , tml    (:,:) ) 
+         CALL iom_put( "tml_tot" , ztmltot(:,:) ) 
+         CALL iom_put( "tml_res" , ztmlres(:,:) ) 
+         
+         DO jl = 1, jpltrd - 1
+            CALL iom_put( trim("tml"//ctrd(jl,2)), tmltrd (:,:,jl) )
+         END DO
+         
+         CALL iom_put( trim("tml"//ctrd(jpmxl_atf,2)), ztmlatf(:,:) )
+         
+         !.................................. ( ML salinity ) .....................................
+         
+         !-- Output the fields
+         CALL iom_put( "sml"    , sml    (:,:) )
+         CALL iom_put( "sml_tot", zsmltot(:,:) ) 
+         CALL iom_put( "sml_res", zsmlres(:,:) ) 
+         
+         DO jl = 1, jpltrd - 1
+            CALL iom_put( trim("sml"//ctrd(jl,2)), smltrd(:,:,jl) )
+         END DO
+         
+         CALL iom_put( trim("sml"//ctrd(jpmxl_atf,2)), zsmlatf(:,:) )
+
+
+         
+      ELSE      !-- Write the trends for T/S mean diagnostics 
+
+         CALL iom_put( "mxl_depth", hmxl_sum(:,:) )
+         
+         !................................. ( ML temperature ) ...................................
+         
+         !-- Output the fields
+         CALL iom_put( "tml"     , tml_sum (:,:) ) 
+         CALL iom_put( "tml_tot" , ztmltot2(:,:) ) 
+         CALL iom_put( "tml_res" , ztmlres2(:,:) ) 
+
+         DO jl = 1, jpltrd - 1
+            CALL iom_put( trim("tml"//ctrd(jl,2)), ztmltrd2(:,:,jl) )
+         END DO
+         
+         CALL iom_put( trim("tml"//ctrd(jpmxl_atf,2)), ztmlatf2(:,:) )
+         
+         !.................................. ( ML salinity ) .....................................
+                     
+         !-- Output the fields
+         CALL iom_put( "sml"    , sml_sum (:,:) )
+         CALL iom_put( "sml_tot", zsmltot2(:,:) ) 
+         CALL iom_put( "sml_res", zsmlres2(:,:) ) 
+
+         DO jl = 1, jpltrd - 1
+            CALL iom_put( trim("sml"//ctrd(jl,2)), zsmltrd2(:,:,jl) )
+         END DO
+         
+         CALL iom_put( trim("sml"//ctrd(jpmxl_atf,2)), zsmlatf2(:,:) )
+         !
+      END IF
+      !
+
+      IF( MOD( itmod, nn_trd ) == 0 ) THEN
+         !
+         ! III.5 Reset cumulative arrays to zero
+         ! -------------------------------------
+         nmoymltrd = 0
+         
+         !   ... temperature ...               ... salinity ...
+         tmltrdm        (:,:)   = 0.e0   ;   smltrdm        (:,:)   = 0.e0
+         tmlatfm        (:,:)   = 0.e0   ;   smlatfm        (:,:)   = 0.e0
+         tml_sum        (:,:)   = 0.e0   ;   sml_sum        (:,:)   = 0.e0
+         tmltrd_csum_ln (:,:,:) = 0.e0   ;   smltrd_csum_ln (:,:,:) = 0.e0
+         tmltrd_sum     (:,:,:) = 0.e0   ;   smltrd_sum     (:,:,:) = 0.e0
+
+         hmxl_sum       (:,:)   = 0.e0
+         !
+      END IF
+
+      ! ======================================================================
+      ! V. Write restart file
+      ! ======================================================================
+
+      IF( lrst_oce )   CALL trd_mxl_rst_write( kt ) 
+
+      !
+   END SUBROUTINE trd_mxl
+
+
+   SUBROUTINE trd_mxl_init
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE trd_mxl_init  ***
+      !! 
+      !! ** Purpose :   computation of vertically integrated T and S budgets
+      !!      from ocean surface down to control surface (NetCDF output)
+      !!----------------------------------------------------------------------
+      INTEGER  ::   jl     ! dummy loop indices
+      INTEGER  ::   inum   ! logical unit
+      INTEGER  ::   ios    ! local integer
+      REAL(wp) ::   zjulian, zsto, zout
+      CHARACTER (LEN=40) ::   clop
+      CHARACTER (LEN=12) ::   clmxl, cltu, clsu
+      !!
+      NAMELIST/namtrd_mxl/ nn_trd , cn_trdrst_in , ln_trdmxl_restart,       &
+         &                 nn_ctls, cn_trdrst_out, ln_trdmxl_instant, rn_ucf, rn_rho_c
+      !!----------------------------------------------------------------------
+      !
+      REWIND( numnam_ref )              ! Namelist namtrd_mxl in reference namelist : mixed layer trends diagnostic
+      READ  ( numnam_ref, namtrd_mxl, IOSTAT = ios, ERR = 901 )
+901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namtrd_mxl in reference namelist', lwp )
+
+      REWIND( numnam_cfg )              ! Namelist namtrd_mxl in configuration namelist : mixed layer trends diagnostic
+      READ  ( numnam_cfg, namtrd_mxl, IOSTAT = ios, ERR = 902 )
+902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namtrd_mxl in configuration namelist', lwp )
+      IF(lwm) WRITE( numond, namtrd_mxl )
+      !
+      IF(lwp) THEN                      ! control print
+         WRITE(numout,*)
+         WRITE(numout,*) ' trd_mxl_init : Mixed-layer trends'
+         WRITE(numout,*) ' ~~~~~~~~~~'
+         WRITE(numout,*) '   Namelist namtrd : set trends parameters'
+         WRITE(numout,*) '      frequency of trends diagnostics (glo)      nn_trd             = ', nn_trd
+         WRITE(numout,*) '      density criteria used to defined the MLD   rn_rho_c           = ', rn_rho_c
+         WRITE(numout,*) '      control surface type            (mld)      nn_ctls            = ', nn_ctls
+         WRITE(numout,*) '      restart for ML diagnostics                 ln_trdmxl_restart  = ', ln_trdmxl_restart
+         WRITE(numout,*) '      instantaneous or mean ML T/S               ln_trdmxl_instant  = ', ln_trdmxl_instant
+         WRITE(numout,*) '      unit conversion factor                     rn_ucf             = ', rn_ucf
+         WRITE(numout,*) '      criteria to compute the MLD                rn_rho_c           = ', rn_rho_c
+      ENDIF
+
+
+
+      ! I.1 Check consistency of user defined preferences
+      ! -------------------------------------------------
+      
+      IF ( rn_rho_c /= rho_c )   CALL ctl_warn( 'Unless you have good reason to do so, you should use the value ',    &
+         &                                      'defined in zdfmxl.F90 module to calculate the mixed layer depth' )
+
+      IF( MOD( nitend, nn_trd ) /= 0 ) THEN
+         WRITE(numout,cform_err)
+         WRITE(numout,*) '                Your nitend parameter, nitend = ', nitend
+         WRITE(numout,*) '                is no multiple of the trends diagnostics frequency        '
+         WRITE(numout,*) '                          you defined, nn_trd   = ', nn_trd
+         WRITE(numout,*) '                This will not allow you to restart from this simulation.  '
+         WRITE(numout,*) '                You should reconsider this choice.                        ' 
+         WRITE(numout,*) 
+         WRITE(numout,*) '                N.B. the nitend parameter is also constrained to be a     '
+         WRITE(numout,*) '                     multiple of the nn_fsbc parameter '
+         CALL ctl_stop( 'trd_mxl_init: see comment just above' )
+      END IF
+
+      !                                   ! allocate trdmxl arrays
+      IF( trd_mxl_alloc()    /= 0 )   CALL ctl_stop( 'STOP', 'trd_mxl_init : unable to allocate trdmxl     arrays' )
+      IF( trdmxl_oce_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'trd_mxl_init : unable to allocate trdmxl_oce arrays' )
+
+
+
+      nkstp     = nit000 - 1              ! current time step indicator initialization
+
+
+
+
+      ! I.2 Initialize arrays to zero or read a restart file
+      ! ----------------------------------------------------
+
+      nmoymltrd = 0
+
+      !     ... temperature ...                  ... salinity ...
+      tml            (:,:)   = 0.e0    ;    sml            (:,:)   = 0.e0     ! inst.
+      tmltrdm        (:,:)   = 0.e0    ;    smltrdm        (:,:)   = 0.e0
+      tmlatfm        (:,:)   = 0.e0    ;    smlatfm        (:,:)   = 0.e0
+      tml_sum        (:,:)   = 0.e0    ;    sml_sum        (:,:)   = 0.e0     ! mean
+      tmltrd_sum     (:,:,:) = 0.e0    ;    smltrd_sum     (:,:,:) = 0.e0
+      tmltrd_csum_ln (:,:,:) = 0.e0    ;    smltrd_csum_ln (:,:,:) = 0.e0
+
+      hmxl           (:,:)   = 0.e0            
+      hmxl_sum       (:,:)   = 0.e0
+
+      IF( ln_rstart .AND. ln_trdmxl_restart ) THEN
+         CALL trd_mxl_rst_read
+      ELSE
+         !     ... temperature ...                  ... salinity ...
+         tmlb           (:,:)   = 0.e0    ;    smlb           (:,:)   = 0.e0  ! inst.
+         tmlbb          (:,:)   = 0.e0    ;    smlbb          (:,:)   = 0.e0  
+         tmlbn          (:,:)   = 0.e0    ;    smlbn          (:,:)   = 0.e0  
+         tml_sumb       (:,:)   = 0.e0    ;    sml_sumb       (:,:)   = 0.e0  ! mean
+         tmltrd_csum_ub (:,:,:) = 0.e0    ;    smltrd_csum_ub (:,:,:) = 0.e0
+         tmltrd_atf_sumb(:,:)   = 0.e0    ;    smltrd_atf_sumb(:,:)   = 0.e0  
+      END IF
+
+      icount = 1   ;   ionce  = 1                            ! open specifier
+
+      ! I.3 Read control surface from file ctlsurf_idx
+      ! ----------------------------------------------
+ 
+      IF( nn_ctls == 1 ) THEN
+         CALL ctl_opn( inum, 'ctlsurf_idx', 'OLD', 'UNFORMATTED', 'SEQUENTIAL', -1, numout, lwp )
+         READ ( inum, * ) nbol
+         CLOSE( inum )
+      END IF
+
+      ! ======================================================================
+      ! II. netCDF output initialization
+      ! ======================================================================
+
+      ! clmxl = legend root for netCDF output
+      IF( nn_ctls == 0 ) THEN      ! control surface = mixed-layer with density criterion
+         clmxl = 'Mixed Layer '  !                   (array nmln computed in zdfmxl.F90)
+      ELSE IF( nn_ctls == 1 ) THEN ! control surface = read index from file 
+         clmxl = '      Bowl '
+      ELSE IF( nn_ctls >= 2 ) THEN ! control surface = model level
+         WRITE(clmxl,'(A10,I2,1X)') 'Levels 1 -', nn_ctls
+      END IF
+
+
+
+      ! II.3 Define the T grid trend file (nidtrd)
+      ! ------------------------------------------
+      !-- Define long and short names for the NetCDF output variables
+      !       ==> choose them according to trdmxl_oce.F90 <==
+
+      ctrd(jpmxl_xad,1) = " Zonal advection"                  ;   ctrd(jpmxl_xad,2) = "_xad"
+      ctrd(jpmxl_yad,1) = " Meridional advection"             ;   ctrd(jpmxl_yad,2) = "_yad"
+      ctrd(jpmxl_zad,1) = " Vertical advection"               ;   ctrd(jpmxl_zad,2) = "_zad"
+      ctrd(jpmxl_ldf,1) = " Lateral diffusion"                ;   ctrd(jpmxl_ldf,2) = "_ldf"
+      ctrd(jpmxl_for,1) = " Forcing"                          ;   ctrd(jpmxl_for,2) = "_for"
+      ctrd(jpmxl_zdf,1) = " Vertical diff. (Kz)"              ;   ctrd(jpmxl_zdf,2) = "_zdf"
+      ctrd(jpmxl_bbc,1) = " Geothermal flux"                  ;   ctrd(jpmxl_bbc,2) = "_bbc"
+      ctrd(jpmxl_bbl,1) = " Adv/diff. Bottom boundary layer"  ;   ctrd(jpmxl_bbl,2) = "_bbl"
+      ctrd(jpmxl_dmp,1) = " Tracer damping"                   ;   ctrd(jpmxl_dmp,2) = "_dmp"
+      ctrd(jpmxl_npc,1) = " Non penetrative convec. adjust."  ;   ctrd(jpmxl_npc,2) = "_npc"
+      ctrd(jpmxl_atf,1) = " Asselin time filter"              ;   ctrd(jpmxl_atf,2) = "_atf"
+                                                                  
+
+      !-- Define physical units
+      IF     ( rn_ucf == 1.       ) THEN   ;   cltu = "degC/s"     ;   clsu = "p.s.u./s"
+      ELSEIF ( rn_ucf == 3600.*24.) THEN   ;   cltu = "degC/day"   ;   clsu = "p.s.u./day"
+      ELSE                                 ;   cltu = "unknown?"   ;   clsu = "unknown?"
+      END IF
+      !
+   END SUBROUTINE trd_mxl_init
+
+   !!======================================================================
+END MODULE trdmxl
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/TRD/trdmxl_oce.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/TRD/trdmxl_oce.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/TRD/trdmxl_oce.F90	(revision 9570)
@@ -0,0 +1,135 @@
+MODULE trdmxl_oce
+   !!======================================================================
+   !!                   ***  MODULE trdmxl_oce  ***
+   !! Ocean trends :   set tracer and momentum trend variables
+   !!======================================================================
+   !! History :  1.0  ! 2004-08  (C. Talandier)  New trends organization
+   !!            3.5  ! 2012-02  (G. Madec) suppress the trend keys + new trdmxl formulation
+   !!----------------------------------------------------------------------
+   USE par_oce        ! ocean parameters
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   trdmxl_oce_alloc    ! Called in trdmxl.F90
+
+   !                                                !* mixed layer trend indices
+   INTEGER, PUBLIC, PARAMETER ::   jpltrd = 12      !: number of mixed-layer trends arrays
+   INTEGER, PUBLIC            ::   jpktrd           !: max level for mixed-layer trends diag.
+   !
+   INTEGER, PUBLIC, PARAMETER ::   jpmxl_xad =  1   !: i-componant of advection   
+   INTEGER, PUBLIC, PARAMETER ::   jpmxl_yad =  2   !: j-componant of advection
+   INTEGER, PUBLIC, PARAMETER ::   jpmxl_zad =  3   !: k-component of advection 
+   INTEGER, PUBLIC, PARAMETER ::   jpmxl_ldf =  4   !: lateral diffusion (geopot. or iso-neutral)
+   INTEGER, PUBLIC, PARAMETER ::   jpmxl_zdf =  5   !: vertical diffusion  
+   INTEGER, PUBLIC, PARAMETER ::   jpmxl_npc =  6   !: non penetrative convective adjustment
+   INTEGER, PUBLIC, PARAMETER ::   jpmxl_bbc =  7   !: geothermal flux
+   INTEGER, PUBLIC, PARAMETER ::   jpmxl_bbl =  8   !: bottom boundary layer (advective/diffusive)
+   INTEGER, PUBLIC, PARAMETER ::   jpmxl_for =  9   !: forcing 
+   INTEGER, PUBLIC, PARAMETER ::   jpmxl_dmp = 10   !: internal restoring trend
+   INTEGER, PUBLIC, PARAMETER ::   jpmxl_zdfp = 11  !: ! iso-neutral diffusion:"pure" vertical diffusion
+   INTEGER, PUBLIC, PARAMETER ::   jpmxl_atf  = 12  !: asselin trend (**MUST BE THE LAST ONE**)
+   !                                                            !!* Namelist namtrd_mxl:  trend diagnostics in the mixed layer *
+   INTEGER           , PUBLIC ::   nn_ctls  = 0                  !: control surface type for trends vertical integration
+   REAL(wp)          , PUBLIC ::   rn_rho_c = 0.01               !: density criteria for MLD definition
+   REAL(wp)          , PUBLIC ::   rn_ucf   = 1.                 !: unit conversion factor (for netCDF trends outputs)
+                                                                 !  =1. (=86400.) for degC/s (degC/day) and psu/s (psu/day)
+   CHARACTER(len=32), PUBLIC ::   cn_trdrst_in  = "restart_mxl"  !: suffix of ocean restart name (input)
+   CHARACTER(len=32), PUBLIC ::   cn_trdrst_out = "restart_mxl"  !: suffix of ocean restart name (output)
+   LOGICAL          , PUBLIC ::   ln_trdmxl_instant = .FALSE.    !: flag to diagnose inst./mean ML T/S trends
+   LOGICAL          , PUBLIC ::   ln_trdmxl_restart = .FALSE.    !: flag to restart mixed-layer diagnostics
+
+
+   !! Arrays used for diagnosing mixed-layer trends 
+   !!---------------------------------------------------------------------
+   CHARACTER(LEN=80) , PUBLIC :: clname, ctrd(jpltrd+1,2)
+
+   INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   nmxl   !: mixed layer depth indexes 
+   INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   nbol   !: mixed-layer depth indexes when read from file
+
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   wkx    !:
+
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::  &
+      hmxl   ,                      & !: mixed layer depth (m) corresponding to nmld
+      tml    , sml  ,               & !: \ "now" mixed layer temperature/salinity
+      tmlb   , smlb ,               & !: /  and associated "before" fields
+      tmlbb  , smlbb,               & !: \  idem, but valid at the 1rst time step of the
+      tmlbn  , smlbn,               & !: /  current analysis window
+      tmltrdm, smltrdm,             & !: total cumulative trends over the analysis window
+      tml_sum,                      & !: mixed layer T, summed over the current analysis period
+      tml_sumb,                     & !: idem, but from the previous analysis period
+      tmltrd_atf_sumb,              & !: Asselin trends, summed over the previous analysis period
+      sml_sum,                      & !: 
+      sml_sumb,                     & !:    ( idem for salinity )
+      smltrd_atf_sumb,              & !: 
+      hmxl_sum, hmxlbn                !: needed to compute the leap-frog time mean of the ML depth
+
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::  &
+      tmlatfb, tmlatfn ,            & !: "before" Asselin contribution at begining of the averaging
+      smlatfb, smlatfn,             & !: period (i.e. last contrib. from previous such period) and 
+                                      !: "now" Asselin contribution to the ML temp. & salinity trends
+      tmlatfm, smlatfm                !: accumulator for Asselin trends (needed for storage only)
+
+   REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:) ::  &
+      tmltrd,                       & !: \ physical contributions to the total trend (for T/S),
+      smltrd,                       & !: / cumulated over the current analysis window
+      tmltrd_sum,                   & !: sum of these trends over the analysis period
+      tmltrd_csum_ln,               & !: now cumulated sum of the trends over the "lower triangle"
+      tmltrd_csum_ub,               & !: before (prev. analysis period) cumulated sum over the upper triangle
+      smltrd_sum,                   & !: 
+      smltrd_csum_ln,               & !:    ( idem for salinity )
+      smltrd_csum_ub                  !: 
+
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 4.0 , NEMO Consortium (2011)
+   !! $Id$ 
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+  INTEGER FUNCTION trdmxl_oce_alloc()
+     !!----------------------------------------------------------------------
+     !!                 ***  FUNCTION trdmxl_oce_alloc   ***
+     !!----------------------------------------------------------------------
+     USE lib_mpp
+     INTEGER :: ierr(5)
+     !!----------------------------------------------------------------------
+
+     ! Initialise jpktrd here as can no longer do it in MODULE body since
+     ! jpk is now a variable.
+     jpktrd = jpk   !: max level for mixed-layer trends diag.
+
+     ierr(:) = 0
+
+     ALLOCATE( nmxl (jpi,jpj)    , nbol (jpi,jpj),    &
+        &      wkx  (jpi,jpj,jpk), hmxl (jpi,jpj),    & 
+        &      tml  (jpi,jpj)    , sml  (jpi,jpj),    & 
+        &      tmlb (jpi,jpj)    , smlb (jpi,jpj),    &
+        &      tmlbb(jpi,jpj)    , smlbb(jpi,jpj), STAT = ierr(1) )
+
+     ALLOCATE( tmlbn(jpi,jpj)  , smlbn(jpi,jpj),   &
+        &      tmltrdm(jpi,jpj), smltrdm(jpi,jpj), &
+        &      tml_sum(jpi,jpj), tml_sumb(jpi,jpj),&
+        &      tmltrd_atf_sumb(jpi,jpj)           , STAT=ierr(2) )
+
+     ALLOCATE( sml_sum(jpi,jpj), sml_sumb(jpi,jpj), &
+        &      smltrd_atf_sumb(jpi,jpj),            &
+        &      hmxl_sum(jpi,jpj), hmxlbn(jpi,jpj),  &
+        &      tmlatfb(jpi,jpj), tmlatfn(jpi,jpj), STAT = ierr(3) )
+
+     ALLOCATE( smlatfb(jpi,jpj), smlatfn(jpi,jpj), & 
+        &      tmlatfm(jpi,jpj), smlatfm(jpi,jpj), &
+        &      tmltrd(jpi,jpj,jpltrd),   smltrd(jpi,jpj,jpltrd), STAT=ierr(4))
+
+     ALLOCATE( tmltrd_sum(jpi,jpj,jpltrd),tmltrd_csum_ln(jpi,jpj,jpltrd),      &
+        &      tmltrd_csum_ub(jpi,jpj,jpltrd), smltrd_sum(jpi,jpj,jpltrd),     &
+        &      smltrd_csum_ln(jpi,jpj,jpltrd), smltrd_csum_ub(jpi,jpj,jpltrd), STAT=ierr(5) )
+      !
+      trdmxl_oce_alloc = MAXVAL( ierr )
+      IF( lk_mpp                )   CALL mpp_sum ( trdmxl_oce_alloc )
+      IF( trdmxl_oce_alloc /= 0 )   CALL ctl_warn('trdmxl_oce_alloc: failed to allocate arrays')
+      !
+   END FUNCTION trdmxl_oce_alloc
+
+   !!======================================================================
+END MODULE trdmxl_oce
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/TRD/trdmxl_rst.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/TRD/trdmxl_rst.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/TRD/trdmxl_rst.F90	(revision 9570)
@@ -0,0 +1,191 @@
+MODULE trdmxl_rst
+   !!=================================================================================
+   !!                       ***  MODULE  trdmxl_rst  ***
+   !! Ocean dynamic :  Input/Output files for restart on mixed-layer diagnostics
+   !!=================================================================================
+   !! History :  1.0  ! 2005-05 (C. Deltel)  Original code
+   !!---------------------------------------------------------------------------------
+
+   !!---------------------------------------------------------------------------------
+   !!  trd_mxl_rst_write : write mixed layer trend restart
+   !!  trd_mxl_rst_read  : read  mixed layer trend restart
+   !!---------------------------------------------------------------------------------
+   USE dom_oce         ! ocean space and time domain
+   USE trd_oce         ! trends: ocean variables
+   USE in_out_manager  ! I/O manager
+   USE iom             ! I/O module
+   USE restart         ! only for lrst_oce
+
+   IMPLICIT NONE
+   PRIVATE
+  
+   PUBLIC   trd_mxl_rst_read    ! routine called by trd_mxl_init
+   PUBLIC   trd_mxl_rst_write   ! routine called by step.F90
+  
+   INTEGER ::   nummxlw         ! logical unit for mxl restart
+
+   !!---------------------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO Consortium (2010)
+   !! $Id$
+   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
+   !!---------------------------------------------------------------------------------
+CONTAINS
+  
+   SUBROUTINE trd_mxl_rst_write( kt )
+      !!--------------------------------------------------------------------------------
+      !!                  ***  SUBROUTINE trd_mxl_rst_wri  ***
+      !!                
+      !! ** Purpose :   Write mixed-layer diagnostics restart fields.
+      !!--------------------------------------------------------------------------------
+      INTEGER, INTENT( in ) ::   kt   ! ocean time-step index
+      !
+      CHARACTER (len=35) :: charout
+      INTEGER ::   jk                 ! loop indice
+      CHARACTER(LEN=20)   ::   clkt     ! ocean time-step deine as a character
+      CHARACTER(LEN=50)   ::   clname   ! output restart file name
+      CHARACTER(LEN=256)  ::   clpath   ! full path to restart file
+      !!--------------------------------------------------------------------------------
+
+      ! to get better performances with NetCDF format:
+      ! we open and define the ocean restart_mxl file one time step before writing the data (-> at nitrst - 1)
+      ! except if we write ocean restart_mxl files every time step or if an ocean restart_mxl file was writen at nitend - 1
+      IF( kt == nitrst - 1 .OR. nstock == 1 .OR. ( kt == nitend .AND. MOD( nitend - 1, nstock ) == 0 ) ) THEN
+         ! beware of the format used to write kt (default is i8.8, that should be large enough...)
+         IF( nitrst > 999999999 ) THEN   ;   WRITE(clkt, *       ) nitrst
+         ELSE                            ;   WRITE(clkt, '(i8.8)') nitrst
+         ENDIF
+         ! create the file
+         clname = TRIM(cexper)//"_"//TRIM(ADJUSTL(clkt))//"_"//TRIM(cn_trdrst_out)
+         clpath = TRIM(cn_ocerst_outdir)
+         IF( clpath(LEN_TRIM(clpath):) /= '/' ) clpath = TRIM(clpath) // '/'
+         IF(lwp) THEN
+            WRITE(numout,*)
+            SELECT CASE ( jprstlib )
+            CASE DEFAULT         ;   WRITE(numout,*) '             open ocean restart_mxl NetCDF file: '//clname
+            END SELECT
+            IF( kt == nitrst - 1 ) THEN   ;   WRITE(numout,*) '             kt = nitrst - 1 = ', kt,' date= ', ndastp
+            ELSE                          ;   WRITE(numout,*) '             kt = '             , kt,' date= ', ndastp
+            ENDIF
+         ENDIF
+
+         CALL iom_open( TRIM(clpath)//TRIM(clname), nummxlw, ldwrt = .TRUE., kiolib = jprstlib )
+      ENDIF
+
+      IF( kt == nitrst .AND. lwp ) THEN
+         WRITE(numout,*)
+         WRITE(numout,*) 'trdmxl_rst: output for ML diags. restart, with trd_mxl_rst_write routine kt =', kt
+         WRITE(numout,*) '~~~~~~~~~~'
+         WRITE(numout,*)
+      ENDIF
+
+      IF( ln_trdmxl_instant ) THEN 
+         !-- Temperature
+         CALL iom_rstput( kt, nitrst, nummxlw, 'tmlbb'           , tmlbb           )
+         CALL iom_rstput( kt, nitrst, nummxlw, 'tmlbn'           , tmlbn           )
+         CALL iom_rstput( kt, nitrst, nummxlw, 'tmlatfb'         , tmlatfb         )
+
+         !-- Salinity
+         CALL iom_rstput( kt, nitrst, nummxlw, 'smlbb'           , smlbb           )
+         CALL iom_rstput( kt, nitrst, nummxlw, 'smlbn'           , smlbn           )
+         CALL iom_rstput( kt, nitrst, nummxlw, 'smlatfb'         , smlatfb         )
+      ELSE
+         CALL iom_rstput( kt, nitrst, nummxlw, 'hmxlbn'          , hmxlbn          )
+
+         !-- Temperature
+         CALL iom_rstput( kt, nitrst, nummxlw, 'tmlbn'           , tmlbn           )
+         CALL iom_rstput( kt, nitrst, nummxlw, 'tml_sumb'        , tml_sumb        )
+         DO jk = 1, jpltrd
+            IF( jk < 10 ) THEN   ;   WRITE(charout,FMT="('tmltrd_csum_ub_', I1)")   jk
+            ELSE                 ;   WRITE(charout,FMT="('tmltrd_csum_ub_', I2)")   jk
+            ENDIF
+            CALL iom_rstput( kt, nitrst, nummxlw, charout,  tmltrd_csum_ub(:,:,jk) )
+         ENDDO
+         CALL iom_rstput( kt, nitrst, nummxlw, 'tmltrd_atf_sumb' , tmltrd_atf_sumb )
+
+         !-- Salinity
+         CALL iom_rstput( kt, nitrst, nummxlw, 'smlbn'           , smlbn           )
+         CALL iom_rstput( kt, nitrst, nummxlw, 'sml_sumb'        , sml_sumb        )
+         DO jk = 1, jpltrd
+            IF( jk < 10 ) THEN   ;   WRITE(charout,FMT="('smltrd_csum_ub_', I1)")   jk
+            ELSE                 ;   WRITE(charout,FMT="('smltrd_csum_ub_', I2)")   jk
+            ENDIF
+            CALL iom_rstput( kt, nitrst, nummxlw, charout , smltrd_csum_ub(:,:,jk) )
+         ENDDO
+         CALL iom_rstput( kt, nitrst, nummxlw, 'smltrd_atf_sumb' , smltrd_atf_sumb )
+      ENDIF
+      !
+      IF( kt == nitrst ) THEN
+         CALL iom_close( nummxlw )     ! close the restart file (only at last time step)
+         lrst_oce = .FALSE.
+      ENDIF
+      ! 
+   END SUBROUTINE trd_mxl_rst_write
+
+
+   SUBROUTINE trd_mxl_rst_read
+      !!----------------------------------------------------------------------------
+      !!                   ***  SUBROUTINE trd_mxl_rst_lec  ***
+      !!                   
+      !! ** Purpose :   Read file for mixed-layer diagnostics restart.
+      !!----------------------------------------------------------------------------
+      INTEGER  ::  inum       ! temporary logical unit
+      !
+      CHARACTER (len=35) :: charout
+      INTEGER ::   jk         ! loop indice
+      INTEGER ::   jlibalt = jprstlib
+      LOGICAL ::   llok
+      CHARACTER(LEN=256)  ::   clpath   ! full path to restart file
+      !!-----------------------------------------------------------------------------
+
+      IF(lwp)  THEN
+         WRITE(numout,*)
+         WRITE(numout,*) ' trd_mxl_rst_read : read the NetCDF mixed layer trend restart file'
+         WRITE(numout,*) ' ~~~~~~~~~~~~~~~~'
+      ENDIF
+
+      clpath = TRIM(cn_ocerst_indir)
+      IF( clpath(LEN_TRIM(clpath):) /= '/' ) clpath = TRIM(clpath) // '/'
+      CALL iom_open( TRIM(clpath)//TRIM(cn_trdrst_in), inum, kiolib = jlibalt ) 
+
+      IF( ln_trdmxl_instant ) THEN 
+         !-- Temperature
+         CALL iom_get( inum, jpdom_autoglo, 'tmlbb'           , tmlbb          )
+         CALL iom_get( inum, jpdom_autoglo, 'tmlbn'           , tmlbn          )
+         CALL iom_get( inum, jpdom_autoglo, 'tmlatfb'         , tmlatfb        )
+         !
+         !-- Salinity
+         CALL iom_get( inum, jpdom_autoglo, 'smlbb'           , smlbb          )
+         CALL iom_get( inum, jpdom_autoglo, 'smlbn'           , smlbn          )
+         CALL iom_get( inum, jpdom_autoglo, 'smlatfb'         , smlatfb        )
+      ELSE
+         CALL iom_get( inum, jpdom_autoglo, 'hmxlbn'          , hmxlbn         ) ! needed for hmxl_sum
+         !
+         !-- Temperature
+         CALL iom_get( inum, jpdom_autoglo, 'tmlbn'           , tmlbn          ) ! needed for tml_sum
+         CALL iom_get( inum, jpdom_autoglo, 'tml_sumb'        , tml_sumb       )
+         DO jk = 1, jpltrd
+            IF( jk < 10 ) THEN   ;   WRITE(charout,FMT="('tmltrd_csum_ub_', I1)")   jk
+            ELSE                 ;   WRITE(charout,FMT="('tmltrd_csum_ub_', I2)")   jk
+            ENDIF
+            CALL iom_get( inum, jpdom_autoglo, charout, tmltrd_csum_ub(:,:,jk) )
+         END DO
+         CALL iom_get( inum, jpdom_autoglo, 'tmltrd_atf_sumb' , tmltrd_atf_sumb)
+         !
+         !-- Salinity
+         CALL iom_get( inum, jpdom_autoglo, 'smlbn'           , smlbn          ) ! needed for sml_sum
+         CALL iom_get( inum, jpdom_autoglo, 'sml_sumb'        , sml_sumb       )
+         DO jk = 1, jpltrd
+            IF( jk < 10 ) THEN   ;   WRITE(charout,FMT="('smltrd_csum_ub_', I1)")   jk
+            ELSE                 ;   WRITE(charout,FMT="('smltrd_csum_ub_', I2)")   jk
+            ENDIF
+            CALL iom_get( inum, jpdom_autoglo, charout, smltrd_csum_ub(:,:,jk) )
+         END DO
+         CALL iom_get( inum, jpdom_autoglo, 'smltrd_atf_sumb' , smltrd_atf_sumb)
+         !
+         CALL iom_close( inum )
+      ENDIF
+      !
+   END SUBROUTINE trd_mxl_rst_read
+  
+  !!=================================================================================
+END MODULE trdmxl_rst
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/TRD/trdpen.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/TRD/trdpen.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/TRD/trdpen.F90	(revision 9570)
@@ -0,0 +1,155 @@
+MODULE trdpen
+   !!======================================================================
+   !!                       ***  MODULE  trdpen  ***
+   !! Ocean diagnostics:  Potential Energy trends
+   !!=====================================================================
+   !! History :  3.5  !  2012-02  (G. Madec) original code 
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   trd_pen       : compute and output Potential Energy trends from T & S trends
+   !!   trd_pen_init  : initialisation of PE trends
+   !!----------------------------------------------------------------------
+   USE oce            ! ocean dynamics and tracers variables
+   USE dom_oce        ! ocean domain 
+   USE sbc_oce        ! surface boundary condition: ocean
+   USE zdf_oce        ! ocean vertical physics
+   USE trd_oce        ! trends: ocean variables
+   USE eosbn2         ! equation of state and related derivatives
+   USE ldftra         ! lateral diffusion: eddy diffusivity & EIV coeff.
+   USE zdfddm         ! vertical physics: double diffusion
+   USE phycst         ! physical constants
+   !
+   USE in_out_manager ! I/O manager
+   USE iom            ! I/O manager library
+   USE lib_mpp        ! MPP library
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   trd_pen        ! called by all trdtra module
+   PUBLIC   trd_pen_init   ! called by all nemogcm module
+
+   INTEGER ::   nkstp   ! current time step 
+
+   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) ::   rab_pe   ! partial derivatives of PE anomaly with respect to T and S
+
+   !! * Substitutions
+#  include "vectopt_loop_substitute.h90"
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO Consortium (2010)
+   !! $Id$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   INTEGER FUNCTION trd_pen_alloc()
+      !!---------------------------------------------------------------------
+      !!                  ***  FUNCTION trd_tra_alloc  ***
+      !!---------------------------------------------------------------------
+      ALLOCATE( rab_pe(jpi,jpj,jpk,jpts) , STAT= trd_pen_alloc )
+      !
+      IF( lk_mpp             )   CALL mpp_sum ( trd_pen_alloc )
+      IF( trd_pen_alloc /= 0 )   CALL ctl_warn( 'trd_pen_alloc: failed to allocate arrays' )
+   END FUNCTION trd_pen_alloc
+
+
+   SUBROUTINE trd_pen( ptrdx, ptrdy, ktrd, kt, pdt )
+      !!---------------------------------------------------------------------
+      !!                  ***  ROUTINE trd_tra_mng  ***
+      !! 
+      !! ** Purpose :   Dispatch all trends computation, e.g. 3D output, integral
+      !!                constraints, barotropic vorticity, kinetic enrgy, 
+      !!                potential energy, and/or mixed layer budget.
+      !!----------------------------------------------------------------------
+      REAL(wp), DIMENSION(:,:,:), INTENT(in) ::   ptrdx, ptrdy   ! Temperature & Salinity trends
+      INTEGER                   , INTENT(in) ::   ktrd           ! tracer trend index
+      INTEGER                   , INTENT(in) ::   kt             ! time step index
+      REAL(wp)                  , INTENT(in) ::   pdt            ! time step [s]
+      !
+      INTEGER ::   jk                                            ! dummy loop indices
+      REAL(wp), ALLOCATABLE, DIMENSION(:,:)      ::   z2d            ! 2D workspace 
+      REAL(wp), DIMENSION(jpi,jpj,jpk)           ::   zpe            ! 3D workspace 
+      !!----------------------------------------------------------------------
+      !
+      zpe(:,:,:) = 0._wp
+      !
+      IF( kt /= nkstp ) THEN     ! full eos: set partial derivatives at the 1st call of kt time step
+         nkstp = kt
+         CALL eos_pen( tsn, rab_PE, zpe )
+         CALL iom_put( "alphaPE", rab_pe(:,:,:,jp_tem) )
+         CALL iom_put( "betaPE" , rab_pe(:,:,:,jp_sal) )
+         CALL iom_put( "PEanom" , zpe )
+      ENDIF
+      !
+      zpe(:,:,jpk) = 0._wp
+      DO jk = 1, jpkm1
+         zpe(:,:,jk) = ( - ( rab_n(:,:,jk,jp_tem) + rab_pe(:,:,jk,jp_tem) ) * ptrdx(:,:,jk)   &
+            &            + ( rab_n(:,:,jk,jp_sal) + rab_pe(:,:,jk,jp_sal) ) * ptrdy(:,:,jk)  )
+      END DO
+
+      SELECT CASE ( ktrd )
+      CASE ( jptra_xad  )   ;   CALL iom_put( "petrd_xad", zpe )   ! zonal    advection
+      CASE ( jptra_yad  )   ;   CALL iom_put( "petrd_yad", zpe )   ! merid.   advection
+      CASE ( jptra_zad  )   ;   CALL iom_put( "petrd_zad", zpe )   ! vertical advection
+                                IF( ln_linssh ) THEN                   ! cst volume : adv flux through z=0 surface
+                                   ALLOCATE( z2d(jpi,jpj) )
+                                   z2d(:,:) = wn(:,:,1) * ( &
+                                     &   - ( rab_n(:,:,1,jp_tem) + rab_pe(:,:,1,jp_tem) ) * tsn(:,:,1,jp_tem)    &
+                                     &   + ( rab_n(:,:,1,jp_sal) + rab_pe(:,:,1,jp_sal) ) * tsn(:,:,1,jp_sal)    &
+                                     & ) / e3t_n(:,:,1)
+                                   CALL iom_put( "petrd_sad" , z2d )
+                                   DEALLOCATE( z2d )
+                                ENDIF
+      CASE ( jptra_ldf  )   ;   CALL iom_put( "petrd_ldf" , zpe )   ! lateral  diffusion
+      CASE ( jptra_zdf  )   ;   CALL iom_put( "petrd_zdf" , zpe )   ! lateral  diffusion (K_z)
+      CASE ( jptra_zdfp )   ;   CALL iom_put( "petrd_zdfp", zpe )   ! vertical diffusion (K_z)
+      CASE ( jptra_dmp  )   ;   CALL iom_put( "petrd_dmp" , zpe )   ! internal 3D restoring (tradmp)
+      CASE ( jptra_bbl  )   ;   CALL iom_put( "petrd_bbl" , zpe )   ! bottom boundary layer
+      CASE ( jptra_npc  )   ;   CALL iom_put( "petrd_npc" , zpe )   ! non penetr convect adjustment
+      CASE ( jptra_nsr  )   ;   CALL iom_put( "petrd_nsr" , zpe )   ! surface forcing + runoff (ln_rnf=T)
+      CASE ( jptra_qsr  )   ;   CALL iom_put( "petrd_qsr" , zpe )   ! air-sea : penetrative sol radiat
+      CASE ( jptra_bbc  )   ;   CALL iom_put( "petrd_bbc" , zpe )   ! bottom bound cond (geoth flux)
+      CASE ( jptra_atf  )   ;   CALL iom_put( "petrd_atf" , zpe )   ! asselin time filter (last trend)
+                                !IF( ln_linssh ) THEN                   ! cst volume : ssh term (otherwise include in e3t variation)
+                                !   ALLOCATE( z2d(jpi,jpj) )
+                                !   z2d(:,:) = ( ssha(:,:) - sshb(:,:) )                 &
+                                !      &     * (   dPE_dt(:,:,1) * tsn(:,:,1,jp_tem)    &
+                                !      &         + dPE_ds(:,:,1) * tsn(:,:,1,jp_sal)  ) / ( e3t_n(:,:,1) * pdt )
+                                !   CALL iom_put( "petrd_sad" , z2d )
+                                !   DEALLOCATE( z2d )
+                                !ENDIF
+         !
+      END SELECT
+      !
+      !
+   END SUBROUTINE trd_pen
+
+
+   SUBROUTINE trd_pen_init
+      !!---------------------------------------------------------------------
+      !!                  ***  ROUTINE trd_pen_init  ***
+      !! 
+      !! ** Purpose :   initialisation of 3D Kinetic Energy trend diagnostic
+      !!----------------------------------------------------------------------
+      INTEGER  ::   ji, jj, jk   ! dummy loop indices
+      !!----------------------------------------------------------------------
+      !
+      IF(lwp) THEN
+         WRITE(numout,*)
+         WRITE(numout,*) 'trd_pen_init : 3D Potential ENergy trends'
+         WRITE(numout,*) '~~~~~~~~~~~~~'
+      ENDIF
+      !                           ! allocate box volume arrays
+      IF ( trd_pen_alloc() /= 0 )   CALL ctl_stop('trd_pen_alloc: failed to allocate arrays')
+      !
+      rab_pe(:,:,:,:) = 0._wp
+      !
+      IF( .NOT.ln_linssh )   CALL ctl_stop('trd_pen_init : PE trends not coded for variable volume')
+      !
+      nkstp     = nit000 - 1
+      !
+   END SUBROUTINE trd_pen_init
+
+   !!======================================================================
+END MODULE trdpen
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/TRD/trdtra.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/TRD/trdtra.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/TRD/trdtra.F90	(revision 9570)
@@ -0,0 +1,414 @@
+MODULE trdtra
+   !!======================================================================
+   !!                       ***  MODULE  trdtra  ***
+   !! Ocean diagnostics:  ocean tracers trends pre-processing
+   !!=====================================================================
+   !! History :  3.3  !  2010-06  (C. Ethe) creation for the TRA/TRC merge
+   !!            3.5  !  2012-02  (G. Madec) update the comments 
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   trd_tra       : pre-process the tracer trends
+   !!   trd_tra_adv   : transform a div(U.T) trend into a U.grad(T) trend
+   !!   trd_tra_mng   : tracer trend manager: dispatch to the diagnostic modules
+   !!   trd_tra_iom   : output 3D tracer trends using IOM
+   !!----------------------------------------------------------------------
+   USE oce            ! ocean dynamics and tracers variables
+   USE dom_oce        ! ocean domain 
+   USE sbc_oce        ! surface boundary condition: ocean
+   USE zdf_oce        ! ocean vertical physics
+   USE trd_oce        ! trends: ocean variables
+   USE trdtrc         ! ocean passive mixed layer tracers trends 
+   USE trdglo         ! trends: global domain averaged
+   USE trdpen         ! trends: Potential ENergy
+   USE trdmxl         ! ocean active mixed layer tracers trends 
+   USE ldftra         ! ocean active tracers lateral physics
+   USE ldfslp
+   USE zdfddm         ! vertical physics: double diffusion
+   USE phycst         ! physical constants
+   !
+   USE in_out_manager ! I/O manager
+   USE iom            ! I/O manager library
+   USE lib_mpp        ! MPP library
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   trd_tra   ! called by all tra_... modules
+
+   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   trdtx, trdty, trdt   ! use to store the temperature trends
+   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   avt_evd  ! store avt_evd to calculate EVD trend
+
+   !! * Substitutions
+#  include "vectopt_loop_substitute.h90"
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO Consortium (2010)
+   !! $Id$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   INTEGER FUNCTION trd_tra_alloc()
+      !!---------------------------------------------------------------------
+      !!                  ***  FUNCTION trd_tra_alloc  ***
+      !!---------------------------------------------------------------------
+      ALLOCATE( trdtx(jpi,jpj,jpk) , trdty(jpi,jpj,jpk) , trdt(jpi,jpj,jpk) , avt_evd(jpi,jpj,jpk), STAT= trd_tra_alloc )
+      !
+      IF( lk_mpp             )   CALL mpp_sum ( trd_tra_alloc )
+      IF( trd_tra_alloc /= 0 )   CALL ctl_warn('trd_tra_alloc: failed to allocate arrays')
+   END FUNCTION trd_tra_alloc
+
+
+   SUBROUTINE trd_tra( kt, ctype, ktra, ktrd, ptrd, pun, ptra )
+      !!---------------------------------------------------------------------
+      !!                  ***  ROUTINE trd_tra  ***
+      !! 
+      !! ** Purpose : pre-process tracer trends
+      !!
+      !! ** Method  : - mask the trend
+      !!              - advection (ptra present) converte the incoming flux (U.T) 
+      !!              into trend (U.T => -U.grat(T)=div(U.T)-T.div(U)) through a 
+      !!              call to trd_tra_adv
+      !!              - 'TRA' case : regroup T & S trends
+      !!              - send the trends to trd_tra_mng (trdtrc) for further processing
+      !!----------------------------------------------------------------------
+      INTEGER                         , INTENT(in)           ::   kt      ! time step
+      CHARACTER(len=3)                , INTENT(in)           ::   ctype   ! tracers trends type 'TRA'/'TRC'
+      INTEGER                         , INTENT(in)           ::   ktra    ! tracer index
+      INTEGER                         , INTENT(in)           ::   ktrd    ! tracer trend index
+      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in)           ::   ptrd    ! tracer trend  or flux
+      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in), OPTIONAL ::   pun     ! now velocity 
+      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in), OPTIONAL ::   ptra    ! now tracer variable
+      !
+      INTEGER ::   jk   ! loop indices
+      REAL(wp),        DIMENSION(jpi,jpj,jpk) ::   ztrds             ! 3D workspace
+      REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) ::   zwt, zws, ztrdt   ! 3D workspace
+      !!----------------------------------------------------------------------
+      !      
+      IF( .NOT. ALLOCATED( trdtx ) ) THEN      ! allocate trdtra arrays
+         IF( trd_tra_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'trd_tra : unable to allocate arrays' )
+      ENDIF
+
+      IF( ctype == 'TRA' .AND. ktra == jp_tem ) THEN   !==  Temperature trend  ==!
+         !
+         SELECT CASE( ktrd )
+         !                            ! advection: transform the advective flux into a trend
+         CASE( jptra_xad )   ;   CALL trd_tra_adv( ptrd, pun, ptra, 'X', trdtx ) 
+         CASE( jptra_yad )   ;   CALL trd_tra_adv( ptrd, pun, ptra, 'Y', trdty ) 
+         CASE( jptra_zad )   ;   CALL trd_tra_adv( ptrd, pun, ptra, 'Z', trdt  ) 
+         CASE( jptra_bbc,    &        ! qsr, bbc: on temperature only, send to trd_tra_mng
+            &  jptra_qsr )   ;   trdt(:,:,:) = ptrd(:,:,:) * tmask(:,:,:)
+                                 ztrds(:,:,:) = 0._wp
+                                 CALL trd_tra_mng( trdt, ztrds, ktrd, kt )
+ !!gm Gurvan, verify the jptra_evd trend please !
+         CASE( jptra_evd )   ;   avt_evd(:,:,:) = ptrd(:,:,:) * tmask(:,:,:)
+         CASE DEFAULT                 ! other trends: masked trends
+            trdt(:,:,:) = ptrd(:,:,:) * tmask(:,:,:)              ! mask & store
+         END SELECT
+         !
+      ENDIF
+
+      IF( ctype == 'TRA' .AND. ktra == jp_sal ) THEN      !==  Salinity trends  ==!
+         !
+         SELECT CASE( ktrd )
+         !                            ! advection: transform the advective flux into a trend
+         !                            !            and send T & S trends to trd_tra_mng
+         CASE( jptra_xad  )   ;   CALL trd_tra_adv( ptrd , pun  , ptra, 'X'  , ztrds ) 
+                                  CALL trd_tra_mng( trdtx, ztrds, ktrd, kt   )
+         CASE( jptra_yad  )   ;   CALL trd_tra_adv( ptrd , pun  , ptra, 'Y'  , ztrds ) 
+                                  CALL trd_tra_mng( trdty, ztrds, ktrd, kt   )
+         CASE( jptra_zad  )   ;   CALL trd_tra_adv( ptrd , pun  , ptra, 'Z'  , ztrds ) 
+                                  CALL trd_tra_mng( trdt , ztrds, ktrd, kt   )
+         CASE( jptra_zdfp )           ! diagnose the "PURE" Kz trend (here: just before the swap)
+            !                         ! iso-neutral diffusion case otherwise jptra_zdf is "PURE"
+            ALLOCATE( zwt(jpi,jpj,jpk), zws(jpi,jpj,jpk), ztrdt(jpi,jpj,jpk) )
+            !
+            zwt(:,:, 1 ) = 0._wp   ;   zws(:,:, 1 ) = 0._wp            ! vertical diffusive fluxes
+            zwt(:,:,jpk) = 0._wp   ;   zws(:,:,jpk) = 0._wp
+            DO jk = 2, jpk
+               zwt(:,:,jk) = avt(:,:,jk) * ( tsa(:,:,jk-1,jp_tem) - tsa(:,:,jk,jp_tem) ) / e3w_n(:,:,jk) * tmask(:,:,jk)
+               zws(:,:,jk) = avs(:,:,jk) * ( tsa(:,:,jk-1,jp_sal) - tsa(:,:,jk,jp_sal) ) / e3w_n(:,:,jk) * tmask(:,:,jk)
+            END DO
+            !
+            ztrdt(:,:,jpk) = 0._wp   ;   ztrds(:,:,jpk) = 0._wp
+            DO jk = 1, jpkm1
+               ztrdt(:,:,jk) = ( zwt(:,:,jk) - zwt(:,:,jk+1) ) / e3t_n(:,:,jk)
+               ztrds(:,:,jk) = ( zws(:,:,jk) - zws(:,:,jk+1) ) / e3t_n(:,:,jk) 
+            END DO
+            CALL trd_tra_mng( ztrdt, ztrds, jptra_zdfp, kt )  
+            !
+            !                         ! Also calculate EVD trend at this point. 
+            zwt(:,:,:) = 0._wp   ;   zws(:,:,:) = 0._wp            ! vertical diffusive fluxes
+            DO jk = 2, jpk
+               zwt(:,:,jk) = avt_evd(:,:,jk) * ( tsa(:,:,jk-1,jp_tem) - tsa(:,:,jk,jp_tem) ) / e3w_n(:,:,jk) * tmask(:,:,jk)
+               zws(:,:,jk) = avt_evd(:,:,jk) * ( tsa(:,:,jk-1,jp_sal) - tsa(:,:,jk,jp_sal) ) / e3w_n(:,:,jk) * tmask(:,:,jk)
+            END DO
+            !
+            ztrdt(:,:,jpk) = 0._wp   ;   ztrds(:,:,jpk) = 0._wp
+            DO jk = 1, jpkm1
+               ztrdt(:,:,jk) = ( zwt(:,:,jk) - zwt(:,:,jk+1) ) / e3t_n(:,:,jk)
+               ztrds(:,:,jk) = ( zws(:,:,jk) - zws(:,:,jk+1) ) / e3t_n(:,:,jk) 
+            END DO
+            CALL trd_tra_mng( ztrdt, ztrds, jptra_evd, kt )  
+            !
+            DEALLOCATE( zwt, zws, ztrdt )
+            !
+         CASE DEFAULT                 ! other trends: mask and send T & S trends to trd_tra_mng
+            ztrds(:,:,:) = ptrd(:,:,:) * tmask(:,:,:)
+            CALL trd_tra_mng( trdt, ztrds, ktrd, kt )  
+         END SELECT
+      ENDIF
+
+      IF( ctype == 'TRC' ) THEN                           !==  passive tracer trend  ==!
+         !
+         SELECT CASE( ktrd )
+         !                            ! advection: transform the advective flux into a masked trend
+         CASE( jptra_xad )   ;   CALL trd_tra_adv( ptrd , pun , ptra, 'X', ztrds ) 
+         CASE( jptra_yad )   ;   CALL trd_tra_adv( ptrd , pun , ptra, 'Y', ztrds ) 
+         CASE( jptra_zad )   ;   CALL trd_tra_adv( ptrd , pun , ptra, 'Z', ztrds ) 
+         CASE DEFAULT                 ! other trends: just masked 
+                                 ztrds(:,:,:) = ptrd(:,:,:) * tmask(:,:,:)
+         END SELECT
+         !                            ! send trend to trd_trc
+         CALL trd_trc( ztrds, ktra, ktrd, kt ) 
+         !
+      ENDIF
+      !
+   END SUBROUTINE trd_tra
+
+
+   SUBROUTINE trd_tra_adv( pf, pun, ptn, cdir, ptrd )
+      !!---------------------------------------------------------------------
+      !!                  ***  ROUTINE trd_tra_adv  ***
+      !! 
+      !! ** Purpose :   transformed a advective flux into a masked advective trends
+      !!
+      !! ** Method  :   use the following transformation: -div(U.T) = - U grad(T) + T.div(U)
+      !!       i-advective trends = -un. di-1[T] = -( di-1[fi] - tn di-1[un] )
+      !!       j-advective trends = -un. di-1[T] = -( dj-1[fi] - tn dj-1[un] )
+      !!       k-advective trends = -un. di+1[T] = -( dk+1[fi] - tn dk+1[un] )
+      !!                where fi is the incoming advective flux.
+      !!----------------------------------------------------------------------
+      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in   ) ::   pf      ! advective flux in one direction
+      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in   ) ::   pun     ! now velocity   in one direction
+      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in   ) ::   ptn     ! now or before tracer 
+      CHARACTER(len=1)                , INTENT(in   ) ::   cdir    ! X/Y/Z direction
+      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(  out) ::   ptrd    ! advective trend in one direction
+      !
+      INTEGER  ::   ji, jj, jk   ! dummy loop indices
+      INTEGER  ::   ii, ij, ik   ! index shift as function of the direction
+      !!----------------------------------------------------------------------
+      !
+      SELECT CASE( cdir )      ! shift depending on the direction
+      CASE( 'X' )   ;   ii = 1   ;   ij = 0   ;   ik = 0      ! i-trend
+      CASE( 'Y' )   ;   ii = 0   ;   ij = 1   ;   ik = 0      ! j-trend
+      CASE( 'Z' )   ;   ii = 0   ;   ij = 0   ;   ik =-1      ! k-trend
+      END SELECT
+      !
+      !                        ! set to zero uncomputed values
+      ptrd(jpi,:,:) = 0._wp   ;   ptrd(1,:,:) = 0._wp
+      ptrd(:,jpj,:) = 0._wp   ;   ptrd(:,1,:) = 0._wp
+      ptrd(:,:,jpk) = 0._wp
+      !
+      DO jk = 1, jpkm1         ! advective trend
+         DO jj = 2, jpjm1
+            DO ji = fs_2, fs_jpim1   ! vector opt.
+               ptrd(ji,jj,jk) = - (     pf (ji,jj,jk) - pf (ji-ii,jj-ij,jk-ik)                        &
+                 &                  - ( pun(ji,jj,jk) - pun(ji-ii,jj-ij,jk-ik) ) * ptn(ji,jj,jk)  )   &
+                 &              * r1_e1e2t(ji,jj) / e3t_n(ji,jj,jk) * tmask(ji,jj,jk)
+            END DO
+         END DO
+      END DO
+      !
+   END SUBROUTINE trd_tra_adv
+
+
+   SUBROUTINE trd_tra_mng( ptrdx, ptrdy, ktrd, kt )
+      !!---------------------------------------------------------------------
+      !!                  ***  ROUTINE trd_tra_mng  ***
+      !! 
+      !! ** Purpose :   Dispatch all tracer trends computation, e.g. 3D output,
+      !!                integral constraints, potential energy, and/or 
+      !!                mixed layer budget.
+      !!----------------------------------------------------------------------
+      REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   ptrdx   ! Temperature or U trend 
+      REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   ptrdy   ! Salinity    or V trend
+      INTEGER                   , INTENT(in   ) ::   ktrd    ! tracer trend index
+      INTEGER                   , INTENT(in   ) ::   kt      ! time step
+      !!----------------------------------------------------------------------
+
+      IF( neuler == 0 .AND. kt == nit000    ) THEN   ;   r2dt =      rdt      ! = rdt (restart with Euler time stepping)
+      ELSEIF(               kt <= nit000 + 1) THEN   ;   r2dt = 2. * rdt      ! = 2 rdt (leapfrog)
+      ENDIF
+
+      !                   ! 3D output of tracers trends using IOM interface
+      IF( ln_tra_trd )   CALL trd_tra_iom ( ptrdx, ptrdy, ktrd, kt )
+
+      !                   ! Integral Constraints Properties for tracers trends                                       !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+      IF( ln_glo_trd )   CALL trd_glo( ptrdx, ptrdy, ktrd, 'TRA', kt )
+
+      !                   ! Potential ENergy trends
+      IF( ln_PE_trd  )   CALL trd_pen( ptrdx, ptrdy, ktrd, kt, r2dt )
+
+      !                   ! Mixed layer trends for active tracers
+      IF( ln_tra_mxl )   THEN   
+         !-----------------------------------------------------------------------------------------------
+         ! W.A.R.N.I.N.G :
+         ! jptra_ldf : called by traldf.F90
+         !                 at this stage we store:
+         !                  - the lateral geopotential diffusion (here, lateral = horizontal)
+         !                  - and the iso-neutral diffusion if activated 
+         ! jptra_zdf : called by trazdf.F90
+         !                 * in case of iso-neutral diffusion we store the vertical diffusion component in the 
+         !                   lateral trend including the K_z contrib, which will be removed later (see trd_mxl)
+         !-----------------------------------------------------------------------------------------------
+
+         SELECT CASE ( ktrd )
+         CASE ( jptra_xad )        ;   CALL trd_mxl_zint( ptrdx, ptrdy, jpmxl_xad, '3D' )   ! zonal    advection
+         CASE ( jptra_yad )        ;   CALL trd_mxl_zint( ptrdx, ptrdy, jpmxl_yad, '3D' )   ! merid.   advection
+         CASE ( jptra_zad )        ;   CALL trd_mxl_zint( ptrdx, ptrdy, jpmxl_zad, '3D' )   ! vertical advection
+         CASE ( jptra_ldf )        ;   CALL trd_mxl_zint( ptrdx, ptrdy, jpmxl_ldf, '3D' )   ! lateral  diffusion
+         CASE ( jptra_bbl )        ;   CALL trd_mxl_zint( ptrdx, ptrdy, jpmxl_bbl, '3D' )   ! bottom boundary layer
+         CASE ( jptra_zdf )
+            IF( ln_traldf_iso ) THEN ; CALL trd_mxl_zint( ptrdx, ptrdy, jpmxl_ldf, '3D' )   ! lateral  diffusion (K_z)
+            ELSE                   ;   CALL trd_mxl_zint( ptrdx, ptrdy, jpmxl_zdf, '3D' )   ! vertical diffusion (K_z)
+            ENDIF
+         CASE ( jptra_dmp )        ;   CALL trd_mxl_zint( ptrdx, ptrdy, jpmxl_dmp, '3D' )   ! internal 3D restoring (tradmp)
+         CASE ( jptra_qsr )        ;   CALL trd_mxl_zint( ptrdx, ptrdy, jpmxl_for, '3D' )   ! air-sea : penetrative sol radiat
+         CASE ( jptra_nsr )        ;   ptrdx(:,:,2:jpk) = 0._wp   ;   ptrdy(:,:,2:jpk) = 0._wp
+                                       CALL trd_mxl_zint( ptrdx, ptrdy, jpmxl_for, '2D' )   ! air-sea : non penetr sol radiation
+         CASE ( jptra_bbc )        ;   CALL trd_mxl_zint( ptrdx, ptrdy, jpmxl_bbc, '3D' )   ! bottom bound cond (geoth flux)
+         CASE ( jptra_npc )        ;   CALL trd_mxl_zint( ptrdx, ptrdy, jpmxl_npc, '3D' )   ! non penetr convect adjustment
+         CASE ( jptra_atf )        ;   CALL trd_mxl_zint( ptrdx, ptrdy, jpmxl_atf, '3D' )   ! asselin time filter (last trend)
+                                   !
+                                       CALL trd_mxl( kt, r2dt )                             ! trends: Mixed-layer (output)
+         END SELECT
+         !
+      ENDIF
+      !
+   END SUBROUTINE trd_tra_mng
+
+
+   SUBROUTINE trd_tra_iom( ptrdx, ptrdy, ktrd, kt )
+      !!---------------------------------------------------------------------
+      !!                  ***  ROUTINE trd_tra_iom  ***
+      !! 
+      !! ** Purpose :   output 3D tracer trends using IOM
+      !!----------------------------------------------------------------------
+      REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   ptrdx   ! Temperature or U trend 
+      REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   ptrdy   ! Salinity    or V trend
+      INTEGER                   , INTENT(in   ) ::   ktrd    ! tracer trend index
+      INTEGER                   , INTENT(in   ) ::   kt      ! time step
+      !!
+      INTEGER ::   ji, jj, jk   ! dummy loop indices
+      INTEGER ::   ikbu, ikbv   ! local integers
+      REAL(wp), ALLOCATABLE, DIMENSION(:,:)   ::   z2dx, z2dy   ! 2D workspace 
+      !!----------------------------------------------------------------------
+      !
+!!gm Rq: mask the trends already masked in trd_tra, but lbc_lnk should probably be added
+      !
+      ! Trends evaluated every time step that could go to the standard T file and can be output every ts into a 1ts file if 1ts output is selected
+      SELECT CASE( ktrd )
+      ! This total trend is done every time step
+      CASE( jptra_tot  )   ;   CALL iom_put( "ttrd_tot" , ptrdx )           ! model total trend
+                               CALL iom_put( "strd_tot" , ptrdy )
+      END SELECT
+      !
+      ! These trends are done every second time step. When 1ts output is selected must go different (2ts) file from standard T-file
+      IF( MOD( kt, 2 ) == 0 ) THEN
+         SELECT CASE( ktrd )
+         CASE( jptra_xad  )   ;   CALL iom_put( "ttrd_xad"  , ptrdx )        ! x- horizontal advection
+                                  CALL iom_put( "strd_xad"  , ptrdy )
+         CASE( jptra_yad  )   ;   CALL iom_put( "ttrd_yad"  , ptrdx )        ! y- horizontal advection
+                                  CALL iom_put( "strd_yad"  , ptrdy )
+         CASE( jptra_zad  )   ;   CALL iom_put( "ttrd_zad"  , ptrdx )        ! z- vertical   advection
+                                  CALL iom_put( "strd_zad"  , ptrdy )
+                                  IF( ln_linssh ) THEN                   ! cst volume : adv flux through z=0 surface
+                                     ALLOCATE( z2dx(jpi,jpj), z2dy(jpi,jpj) )
+                                     z2dx(:,:) = wn(:,:,1) * tsn(:,:,1,jp_tem) / e3t_n(:,:,1)
+                                     z2dy(:,:) = wn(:,:,1) * tsn(:,:,1,jp_sal) / e3t_n(:,:,1)
+                                     CALL iom_put( "ttrd_sad", z2dx )
+                                     CALL iom_put( "strd_sad", z2dy )
+                                     DEALLOCATE( z2dx, z2dy )
+                                  ENDIF
+         CASE( jptra_totad  ) ;   CALL iom_put( "ttrd_totad", ptrdx )        ! total   advection
+                                  CALL iom_put( "strd_totad", ptrdy )
+         CASE( jptra_ldf  )   ;   CALL iom_put( "ttrd_ldf"  , ptrdx )        ! lateral diffusion
+                                  CALL iom_put( "strd_ldf"  , ptrdy )
+         CASE( jptra_zdf  )   ;   CALL iom_put( "ttrd_zdf"  , ptrdx )        ! vertical diffusion (including Kz contribution)
+                                  CALL iom_put( "strd_zdf"  , ptrdy )
+         CASE( jptra_zdfp )   ;   CALL iom_put( "ttrd_zdfp" , ptrdx )        ! PURE vertical diffusion (no isoneutral contribution)
+                                  CALL iom_put( "strd_zdfp" , ptrdy )
+         CASE( jptra_evd )    ;   CALL iom_put( "ttrd_evd"  , ptrdx )        ! EVD trend (convection)
+                                  CALL iom_put( "strd_evd"  , ptrdy )
+         CASE( jptra_dmp  )   ;   CALL iom_put( "ttrd_dmp"  , ptrdx )        ! internal restoring (damping)
+                                  CALL iom_put( "strd_dmp"  , ptrdy )
+         CASE( jptra_bbl  )   ;   CALL iom_put( "ttrd_bbl"  , ptrdx )        ! bottom boundary layer
+                                  CALL iom_put( "strd_bbl"  , ptrdy )
+         CASE( jptra_npc  )   ;   CALL iom_put( "ttrd_npc"  , ptrdx )        ! static instability mixing
+                                  CALL iom_put( "strd_npc"  , ptrdy )
+         CASE( jptra_bbc  )   ;   CALL iom_put( "ttrd_bbc"  , ptrdx )        ! geothermal heating   (only on temperature)
+         CASE( jptra_nsr  )   ;   CALL iom_put( "ttrd_qns"  , ptrdx(:,:,1) ) ! surface forcing + runoff (ln_rnf=T)
+                                  CALL iom_put( "strd_cdt"  , ptrdy(:,:,1) )        ! output as 2D surface fields
+         CASE( jptra_qsr  )   ;   CALL iom_put( "ttrd_qsr"  , ptrdx )        ! penetrative solar radiat. (only on temperature)
+         END SELECT
+         ! the Asselin filter trend  is also every other time step but needs to be lagged one time step
+         ! Even when 1ts output is selected can go to the same (2ts) file as the trends plotted every even time step.
+      ELSE IF( MOD( kt, 2 ) == 1 ) THEN
+         SELECT CASE( ktrd )
+         CASE( jptra_atf  )   ;   CALL iom_put( "ttrd_atf" , ptrdx )        ! asselin time Filter
+            CALL iom_put( "strd_atf" , ptrdy )
+         END SELECT
+      END IF
+      !
+      ! These trends are done every second time step. When 1ts output is selected must go different (2ts) file from standard T-file
+      IF( MOD( kt, 2 ) == 0 ) THEN
+         SELECT CASE( ktrd )
+         CASE( jptra_xad  )   ;   CALL iom_put( "ttrd_xad"  , ptrdx )         ! x- horizontal advection
+                                  CALL iom_put( "strd_xad"  , ptrdy )
+         CASE( jptra_yad  )   ;   CALL iom_put( "ttrd_yad"  , ptrdx )         ! y- horizontal advection
+                                  CALL iom_put( "strd_yad"  , ptrdy )
+         CASE( jptra_zad  )   ;   CALL iom_put( "ttrd_zad"  , ptrdx )         ! z- vertical   advection
+                                  CALL iom_put( "strd_zad"  , ptrdy )
+                                  IF( ln_linssh ) THEN                   ! cst volume : adv flux through z=0 surface
+                                     ALLOCATE( z2dx(jpi,jpj) , z2dy(jpi,jpj) )
+                                     z2dx(:,:) = wn(:,:,1) * tsn(:,:,1,jp_tem) / e3t_n(:,:,1)
+                                     z2dy(:,:) = wn(:,:,1) * tsn(:,:,1,jp_sal) / e3t_n(:,:,1)
+                                     CALL iom_put( "ttrd_sad", z2dx )
+                                     CALL iom_put( "strd_sad", z2dy )
+                                     DEALLOCATE( z2dx, z2dy )
+                                  ENDIF
+         CASE( jptra_totad  ) ;   CALL iom_put( "ttrd_totad", ptrdx )         ! total   advection
+                                  CALL iom_put( "strd_totad", ptrdy )
+         CASE( jptra_ldf  )   ;   CALL iom_put( "ttrd_ldf"  , ptrdx )         ! lateral diffusion
+                                  CALL iom_put( "strd_ldf"  , ptrdy )
+         CASE( jptra_zdf  )   ;   CALL iom_put( "ttrd_zdf"  , ptrdx )         ! vertical diffusion (including Kz contribution)
+                                  CALL iom_put( "strd_zdf"  , ptrdy )
+         CASE( jptra_zdfp )   ;   CALL iom_put( "ttrd_zdfp" , ptrdx )         ! PURE vertical diffusion (no isoneutral contribution)
+                                  CALL iom_put( "strd_zdfp" , ptrdy )
+         CASE( jptra_evd )    ;   CALL iom_put( "ttrd_evd"  , ptrdx )         ! EVD trend (convection)
+                                  CALL iom_put( "strd_evd"  , ptrdy )
+         CASE( jptra_dmp  )   ;   CALL iom_put( "ttrd_dmp"  , ptrdx )         ! internal restoring (damping)
+                                  CALL iom_put( "strd_dmp"  , ptrdy )
+         CASE( jptra_bbl  )   ;   CALL iom_put( "ttrd_bbl"  , ptrdx )         ! bottom boundary layer
+                                  CALL iom_put( "strd_bbl"  , ptrdy )
+         CASE( jptra_npc  )   ;   CALL iom_put( "ttrd_npc"  , ptrdx )         ! static instability mixing
+                                  CALL iom_put( "strd_npc"  , ptrdy )
+         CASE( jptra_bbc  )   ;   CALL iom_put( "ttrd_bbc"  , ptrdx )         ! geothermal heating   (only on temperature)
+         CASE( jptra_nsr  )   ;   CALL iom_put( "ttrd_qns"  , ptrdx(:,:,1) )  ! surface forcing + runoff (ln_rnf=T)
+                                  CALL iom_put( "strd_cdt"  , ptrdy(:,:,1) )        ! output as 2D surface fields
+         CASE( jptra_qsr  )   ;   CALL iom_put( "ttrd_qsr"  , ptrdx )         ! penetrative solar radiat. (only on temperature)
+         END SELECT
+         ! the Asselin filter trend  is also every other time step but needs to be lagged one time step
+         ! Even when 1ts output is selected can go to the same (2ts) file as the trends plotted every even time step.
+      ELSEIF( MOD( kt, 2 ) == 1 ) THEN
+         SELECT CASE( ktrd )
+         CASE( jptra_atf  )   ;   CALL iom_put( "ttrd_atf" , ptrdx )        ! asselin time Filter
+                                  CALL iom_put( "strd_atf" , ptrdy )
+         END SELECT
+      ENDIF
+      !
+   END SUBROUTINE trd_tra_iom
+
+   !!======================================================================
+END MODULE trdtra
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/TRD/trdtrc.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/TRD/trdtrc.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/TRD/trdtrc.F90	(revision 9570)
@@ -0,0 +1,23 @@
+MODULE trdtrc
+   !!======================================================================
+   !!                       ***  MODULE trdtrc  ***
+   !!  Dummy module
+   !!======================================================================
+   !!----------------------------------------------------------------------
+   !!   Dummy module                                             NO TOP use
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE trd_trc( ptrtrd, kjn, ktrd, kt )
+      INTEGER ::   kt, kjn, ktrd   
+      REAL    ::   ptrtrd(:,:,:)  
+      WRITE(*,*) 'trd_trc : You should not have seen this print! error?', ptrtrd(1,1,1)
+      WRITE(*,*) '  "      "      : You should not have seen this print! error?', kjn, ktrd, kt
+   END SUBROUTINE trd_trc
+
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO Consortium (2010)
+   !! $Id$
+   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
+   !!======================================================================
+END MODULE trdtrc
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/TRD/trdvor.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/TRD/trdvor.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/TRD/trdvor.F90	(revision 9570)
@@ -0,0 +1,570 @@
+MODULE trdvor
+   !!======================================================================
+   !!                       ***  MODULE  trdvor  ***
+   !! Ocean diagnostics:  momentum trends
+   !!=====================================================================
+   !! History :  1.0  !  2006-01  (L. Brunier, A-M. Treguier) Original code 
+   !!            2.0  !  2008-04  (C. Talandier) New trends organization
+   !!            3.5  !  2012-02  (G. Madec) regroup beta.V computation with pvo trend
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   trd_vor      : momentum trends averaged over the depth
+   !!   trd_vor_zint : vorticity vertical integration
+   !!   trd_vor_init : initialization step
+   !!----------------------------------------------------------------------
+   USE oce             ! ocean dynamics and tracers variables
+   USE dom_oce         ! ocean space and time domain variables
+   USE trd_oce         ! trends: ocean variables
+   USE zdf_oce         ! ocean vertical physics
+   USE sbc_oce         ! surface boundary condition: ocean
+   USE phycst          ! Define parameters for the routines
+   USE ldfdyn          ! ocean active tracers: lateral physics
+   USE dianam          ! build the name of file (routine)
+   USE zdfmxl          ! mixed layer depth
+   !
+   USE in_out_manager  ! I/O manager
+   USE ioipsl          ! NetCDF library
+   USE lbclnk          ! ocean lateral boundary conditions (or mpp link)
+   USE lib_mpp         ! MPP library
+
+   IMPLICIT NONE
+   PRIVATE
+
+   INTERFACE trd_vor_zint
+      MODULE PROCEDURE trd_vor_zint_2d, trd_vor_zint_3d
+   END INTERFACE
+
+   PUBLIC   trd_vor        ! routine called by trddyn.F90
+   PUBLIC   trd_vor_init   ! routine called by opa.F90
+   PUBLIC   trd_vor_alloc  ! routine called by nemogcm.F90
+
+   INTEGER ::   nh_t, nmoydpvor, nidvor, nhoridvor, ndimvor1, icount   ! needs for IOIPSL output
+   INTEGER, SAVE, ALLOCATABLE, DIMENSION(:) ::   ndexvor1   ! needed for IOIPSL output
+   INTEGER ::   ndebug     ! (0/1) set it to 1 in case of problem to have more print
+
+   REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:)   ::   vor_avr      ! average
+   REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:)   ::   vor_avrb     ! before vorticity (kt-1)
+   REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:)   ::   vor_avrbb    ! vorticity at begining of the nwrite-1 timestep averaging period
+   REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:)   ::   vor_avrbn    ! after vorticity at time step after the
+   REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:)   ::   rotot        ! begining of the NWRITE-1 timesteps
+   REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:)   ::   vor_avrtot   !
+   REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:)   ::   vor_avrres   !
+   REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:,:) ::   vortrd       ! curl of trends
+         
+   CHARACTER(len=12) ::   cvort
+
+   !! * Substitutions
+#  include "vectopt_loop_substitute.h90"
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO Consortium (2010)
+   !! $Id$ 
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   INTEGER FUNCTION trd_vor_alloc()
+      !!----------------------------------------------------------------------------
+      !!                  ***  ROUTINE trd_vor_alloc  ***
+      !!----------------------------------------------------------------------------
+      ALLOCATE( vor_avr   (jpi,jpj) , vor_avrb(jpi,jpj) , vor_avrbb (jpi,jpj) ,   &
+         &      vor_avrbn (jpi,jpj) , rotot   (jpi,jpj) , vor_avrtot(jpi,jpj) ,   &
+         &      vor_avrres(jpi,jpj) , vortrd  (jpi,jpj,jpltot_vor) ,              &
+         &      ndexvor1  (jpi*jpj)                                ,   STAT= trd_vor_alloc )
+         !
+      IF( lk_mpp             )   CALL mpp_sum ( trd_vor_alloc )
+      IF( trd_vor_alloc /= 0 )   CALL ctl_warn('trd_vor_alloc: failed to allocate arrays')
+   END FUNCTION trd_vor_alloc
+
+
+   SUBROUTINE trd_vor( putrd, pvtrd, ktrd, kt )
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE trd_vor  ***
+      !! 
+      !! ** Purpose :  computation of cumulated trends over analysis period
+      !!               and make outputs (NetCDF format)
+      !!----------------------------------------------------------------------
+      REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   putrd, pvtrd   ! U and V trends 
+      INTEGER                   , INTENT(in   ) ::   ktrd           ! trend index
+      INTEGER                   , INTENT(in   ) ::   kt             ! time step
+      !
+      INTEGER ::   ji, jj   ! dummy loop indices
+      REAL(wp), DIMENSION(jpi,jpj) ::   ztswu, ztswv    ! 2D workspace 
+      !!----------------------------------------------------------------------
+
+      SELECT CASE( ktrd ) 
+      CASE( jpdyn_hpg )   ;   CALL trd_vor_zint( putrd, pvtrd, jpvor_prg )   ! Hydrostatique Pressure Gradient 
+      CASE( jpdyn_keg )   ;   CALL trd_vor_zint( putrd, pvtrd, jpvor_keg )   ! KE Gradient 
+      CASE( jpdyn_rvo )   ;   CALL trd_vor_zint( putrd, pvtrd, jpvor_rvo )   ! Relative Vorticity 
+      CASE( jpdyn_pvo )   ;   CALL trd_vor_zint( putrd, pvtrd, jpvor_pvo )   ! Planetary Vorticity Term 
+      CASE( jpdyn_ldf )   ;   CALL trd_vor_zint( putrd, pvtrd, jpvor_ldf )   ! Horizontal Diffusion 
+      CASE( jpdyn_zad )   ;   CALL trd_vor_zint( putrd, pvtrd, jpvor_zad )   ! Vertical Advection 
+      CASE( jpdyn_spg )   ;   CALL trd_vor_zint( putrd, pvtrd, jpvor_spg )   ! Surface Pressure Grad. 
+      CASE( jpdyn_zdf )                                                      ! Vertical Diffusion 
+         ztswu(:,:) = 0.e0   ;   ztswv(:,:) = 0.e0
+         DO jj = 2, jpjm1                                                             ! wind stress trends
+            DO ji = fs_2, fs_jpim1   ! vector opt.
+               ztswu(ji,jj) = 0.5 * ( utau_b(ji,jj) + utau(ji,jj) ) / ( e3u_n(ji,jj,1) * rau0 )
+               ztswv(ji,jj) = 0.5 * ( vtau_b(ji,jj) + vtau(ji,jj) ) / ( e3v_n(ji,jj,1) * rau0 )
+            END DO
+         END DO
+         !
+         CALL trd_vor_zint( putrd, pvtrd, jpvor_zdf )                             ! zdf trend including surf./bot. stresses 
+         CALL trd_vor_zint( ztswu, ztswv, jpvor_swf )                             ! surface wind stress 
+      CASE( jpdyn_bfr )
+         CALL trd_vor_zint( putrd, pvtrd, jpvor_bfr )                             ! Bottom stress
+         !
+      CASE( jpdyn_atf )       ! last trends: perform the output of 2D vorticity trends
+         CALL trd_vor_iom( kt )
+      END SELECT
+      !
+   END SUBROUTINE trd_vor
+
+
+   SUBROUTINE trd_vor_zint_2d( putrdvor, pvtrdvor, ktrd )
+      !!----------------------------------------------------------------------------
+      !!                  ***  ROUTINE trd_vor_zint  ***
+      !!
+      !! ** Purpose :   computation of vertically integrated vorticity budgets
+      !!              from ocean surface down to control surface (NetCDF output)
+      !!
+      !! ** Method/usage :   integration done over nwrite-1 time steps
+      !!
+      !! ** Action :   trends :
+      !!                  vortrd (,, 1) = Pressure Gradient Trend
+      !!                  vortrd (,, 2) = KE Gradient Trend
+      !!                  vortrd (,, 3) = Relative Vorticity Trend
+      !!                  vortrd (,, 4) = Coriolis Term Trend
+      !!                  vortrd (,, 5) = Horizontal Diffusion Trend
+      !!                  vortrd (,, 6) = Vertical Advection Trend
+      !!                  vortrd (,, 7) = Vertical Diffusion Trend
+      !!                  vortrd (,, 8) = Surface Pressure Grad. Trend
+      !!                  vortrd (,, 9) = Beta V
+      !!                  vortrd (,,10) = forcing term
+      !!		              vortrd (,,11) = bottom friction term
+      !!                  rotot(,) : total cumulative trends over nwrite-1 time steps
+      !!                  vor_avrtot(,) : first membre of vrticity equation
+      !!                  vor_avrres(,) : residual = dh/dt entrainment
+      !!
+      !!      trends output in netCDF format using ioipsl
+      !!----------------------------------------------------------------------
+      INTEGER                     , INTENT(in   ) ::   ktrd       ! ocean trend index
+      REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) ::   putrdvor   ! u vorticity trend 
+      REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) ::   pvtrdvor   ! v vorticity trend
+      !
+      INTEGER ::   ji, jj       ! dummy loop indices
+      INTEGER ::   ikbu, ikbv   ! local integers
+      REAL(wp), DIMENSION(jpi,jpj) :: zudpvor, zvdpvor  ! total cmulative trends
+      !!----------------------------------------------------------------------
+
+      !
+
+      zudpvor(:,:) = 0._wp                 ;   zvdpvor(:,:) = 0._wp                    ! Initialisation
+      CALL lbc_lnk_multi( putrdvor, 'U', -1. , pvtrdvor, 'V', -1. )      ! lateral boundary condition
+      
+
+      !  =====================================
+      !  I vertical integration of 2D trends
+      !  =====================================
+
+      SELECT CASE( ktrd ) 
+      !
+      CASE( jpvor_bfr )        ! bottom friction
+         DO jj = 2, jpjm1
+            DO ji = fs_2, fs_jpim1 
+               ikbu = mbkv(ji,jj)
+               ikbv = mbkv(ji,jj)            
+               zudpvor(ji,jj) = putrdvor(ji,jj) * e3u_n(ji,jj,ikbu) * e1u(ji,jj) * umask(ji,jj,ikbu)
+               zvdpvor(ji,jj) = pvtrdvor(ji,jj) * e3v_n(ji,jj,ikbv) * e2v(ji,jj) * vmask(ji,jj,ikbv)
+            END DO
+         END DO
+         !
+      CASE( jpvor_swf )        ! wind stress
+         zudpvor(:,:) = putrdvor(:,:) * e3u_n(:,:,1) * e1u(:,:) * umask(:,:,1)
+         zvdpvor(:,:) = pvtrdvor(:,:) * e3v_n(:,:,1) * e2v(:,:) * vmask(:,:,1)
+         !
+      END SELECT
+
+      ! Average except for Beta.V
+      zudpvor(:,:) = zudpvor(:,:) * r1_hu_n(:,:)
+      zvdpvor(:,:) = zvdpvor(:,:) * r1_hv_n(:,:)
+   
+      ! Curl
+      DO ji = 1, jpim1
+         DO jj = 1, jpjm1
+            vortrd(ji,jj,ktrd) = (    zvdpvor(ji+1,jj) - zvdpvor(ji,jj)       &
+                 &                - ( zudpvor(ji,jj+1) - zudpvor(ji,jj) )   ) / ( e1f(ji,jj) * e2f(ji,jj) )
+         END DO
+      END DO
+      vortrd(:,:,ktrd) = vortrd(:,:,ktrd) * fmask(:,:,1)      ! Surface mask
+
+      IF( ndebug /= 0 ) THEN
+         IF(lwp) WRITE(numout,*) ' debuging trd_vor_zint: I done'
+         CALL FLUSH(numout)
+      ENDIF
+      !
+   END SUBROUTINE trd_vor_zint_2d
+
+
+   SUBROUTINE trd_vor_zint_3d( putrdvor, pvtrdvor, ktrd )
+      !!----------------------------------------------------------------------------
+      !!                  ***  ROUTINE trd_vor_zint  ***
+      !!
+      !! ** Purpose :   computation of vertically integrated vorticity budgets
+      !!              from ocean surface down to control surface (NetCDF output)
+      !!
+      !! ** Method/usage :   integration done over nwrite-1 time steps
+      !!
+      !! ** Action :     trends :
+      !!                  vortrd (,,1) = Pressure Gradient Trend
+      !!                  vortrd (,,2) = KE Gradient Trend
+      !!                  vortrd (,,3) = Relative Vorticity Trend
+      !!                  vortrd (,,4) = Coriolis Term Trend
+      !!                  vortrd (,,5) = Horizontal Diffusion Trend
+      !!                  vortrd (,,6) = Vertical Advection Trend
+      !!                  vortrd (,,7) = Vertical Diffusion Trend
+      !!                  vortrd (,,8) = Surface Pressure Grad. Trend
+      !!                  vortrd (,,9) = Beta V
+      !!                  vortrd (,,10) = forcing term
+      !!		  vortrd (,,11) = bottom friction term
+      !!                  rotot(,) : total cumulative trends over nwrite-1 time steps
+      !!                  vor_avrtot(,) : first membre of vrticity equation
+      !!                  vor_avrres(,) : residual = dh/dt entrainment
+      !!
+      !!      trends output in netCDF format using ioipsl
+      !!----------------------------------------------------------------------
+      !
+      INTEGER                         , INTENT(in   ) ::   ktrd       ! ocean trend index
+      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   putrdvor   ! u vorticity trend 
+      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pvtrdvor   ! v vorticity trend
+      !
+      INTEGER ::   ji, jj, jk   ! dummy loop indices
+      REAL(wp), DIMENSION(jpi,jpj) :: zubet  , zvbet    ! Beta.V   
+      REAL(wp), DIMENSION(jpi,jpj) :: zudpvor, zvdpvor  ! total cmulative trends
+      !!----------------------------------------------------------------------
+     
+      ! Initialization
+      zubet  (:,:) = 0._wp
+      zvbet  (:,:) = 0._wp
+      zudpvor(:,:) = 0._wp
+      zvdpvor(:,:) = 0._wp
+      !                            ! lateral boundary condition on input momentum trends
+      CALL lbc_lnk_multi( putrdvor, 'U', -1. , pvtrdvor, 'V', -1. )
+
+      !  =====================================
+      !  I vertical integration of 3D trends
+      !  =====================================
+      ! putrdvor and pvtrdvor terms
+      DO jk = 1,jpk
+        zudpvor(:,:) = zudpvor(:,:) + putrdvor(:,:,jk) * e3u_n(:,:,jk) * e1u(:,:) * umask(:,:,jk)
+        zvdpvor(:,:) = zvdpvor(:,:) + pvtrdvor(:,:,jk) * e3v_n(:,:,jk) * e2v(:,:) * vmask(:,:,jk)
+      END DO
+
+      ! Planetary vorticity: 2nd computation (Beta.V term) store the vertical sum
+      ! as Beta.V term need intergration, not average
+      IF( ktrd == jpvor_pvo ) THEN 
+         zubet(:,:) = zudpvor(:,:)
+         zvbet(:,:) = zvdpvor(:,:)
+         DO ji = 1, jpim1
+            DO jj = 1, jpjm1
+               vortrd(ji,jj,jpvor_bev) = (    zvbet(ji+1,jj) - zvbet(ji,jj)     &
+                  &                       - ( zubet(ji,jj+1) - zubet(ji,jj) ) ) / ( e1f(ji,jj) * e2f(ji,jj) )
+            END DO
+         END DO
+         ! Average of the Curl and Surface mask
+         vortrd(:,:,jpvor_bev) = vortrd(:,:,jpvor_bev) * r1_hu_n(:,:) * fmask(:,:,1)
+      ENDIF
+      !
+      ! Average 
+      zudpvor(:,:) = zudpvor(:,:) * r1_hu_n(:,:)
+      zvdpvor(:,:) = zvdpvor(:,:) * r1_hv_n(:,:)
+      !
+      ! Curl
+      DO ji=1,jpim1
+         DO jj=1,jpjm1
+            vortrd(ji,jj,ktrd) = (    zvdpvor(ji+1,jj) - zvdpvor(ji,jj)     &
+               &                  - ( zudpvor(ji,jj+1) - zudpvor(ji,jj) ) ) / ( e1f(ji,jj) * e2f(ji,jj) )
+         END DO
+      END DO
+      ! Surface mask
+      vortrd(:,:,ktrd) = vortrd(:,:,ktrd) * fmask(:,:,1)
+   
+      IF( ndebug /= 0 ) THEN
+         IF(lwp) WRITE(numout,*) ' debuging trd_vor_zint: I done'
+         CALL FLUSH(numout)
+      ENDIF
+      !
+   END SUBROUTINE trd_vor_zint_3d
+
+
+   SUBROUTINE trd_vor_iom( kt )
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE trd_vor  ***
+      !! 
+      !! ** Purpose :  computation of cumulated trends over analysis period
+      !!               and make outputs (NetCDF format)
+      !!----------------------------------------------------------------------
+      INTEGER                   , INTENT(in   ) ::   kt             ! time step
+      !
+      INTEGER  ::   ji, jj, jk, jl   ! dummy loop indices
+      INTEGER  ::   it, itmod        ! local integers
+      REAL(wp) ::   zmean            ! local scalars
+      REAL(wp), DIMENSION(jpi,jpj) :: zun, zvn
+      !!----------------------------------------------------------------------
+
+      !  =================
+      !  I. Initialization
+      !  =================
+     
+     
+      ! I.1 set before values of vertically average u and v
+      ! ---------------------------------------------------
+
+      IF( kt > nit000 )   vor_avrb(:,:) = vor_avr(:,:)
+
+      ! I.2 vertically integrated vorticity
+      !  ----------------------------------
+
+      vor_avr   (:,:) = 0._wp
+      zun       (:,:) = 0._wp
+      zvn       (:,:) = 0._wp
+      vor_avrtot(:,:) = 0._wp
+      vor_avrres(:,:) = 0._wp
+      
+      ! Vertically averaged velocity
+      DO jk = 1, jpk - 1
+         zun(:,:) = zun(:,:) + e1u(:,:) * un(:,:,jk) * e3u_n(:,:,jk)
+         zvn(:,:) = zvn(:,:) + e2v(:,:) * vn(:,:,jk) * e3v_n(:,:,jk)
+      END DO
+ 
+      zun(:,:) = zun(:,:) * r1_hu_n(:,:)
+      zvn(:,:) = zvn(:,:) * r1_hv_n(:,:)
+
+      ! Curl
+      DO ji = 1, jpim1
+         DO jj = 1, jpjm1
+            vor_avr(ji,jj) = (  ( zvn(ji+1,jj) - zvn(ji,jj) )    &
+               &              - ( zun(ji,jj+1) - zun(ji,jj) ) ) / ( e1f(ji,jj) * e2f(ji,jj) ) * fmask(ji,jj,1)
+         END DO
+      END DO
+      
+      !  =================================
+      !   II. Cumulated trends
+      !  =================================
+
+      ! II.1 set `before' mixed layer values for kt = nit000+1
+      ! ------------------------------------------------------
+      IF( kt == nit000+1 ) THEN
+         vor_avrbb(:,:) = vor_avrb(:,:)
+         vor_avrbn(:,:) = vor_avr (:,:)
+      ENDIF
+
+      ! II.2 cumulated trends over analysis period (kt=2 to nwrite)
+      ! ----------------------
+      ! trends cumulated over nwrite-2 time steps
+
+      IF( kt >= nit000+2 ) THEN
+         nmoydpvor = nmoydpvor + 1
+         DO jl = 1, jpltot_vor
+            IF( jl /= 9 ) THEN
+               rotot(:,:) = rotot(:,:) + vortrd(:,:,jl)
+            ENDIF
+         END DO
+      ENDIF
+
+      !  =============================================
+      !   III. Output in netCDF + residual computation
+      !  =============================================
+
+      ! define time axis
+      it    = kt
+      itmod = kt - nit000 + 1
+
+      IF( MOD( it, nn_trd ) == 0 ) THEN
+
+         ! III.1 compute total trend
+         ! ------------------------
+         zmean = 1._wp / (  REAL( nmoydpvor, wp ) * 2._wp * rdt  )
+         vor_avrtot(:,:) = (  vor_avr(:,:) - vor_avrbn(:,:) + vor_avrb(:,:) - vor_avrbb(:,:) ) * zmean
+
+
+         ! III.2 compute residual
+         ! ---------------------
+         zmean = 1._wp / REAL( nmoydpvor, wp )
+         vor_avrres(:,:) = vor_avrtot(:,:) - rotot(:,:) / zmean
+
+         ! Boundary conditions
+         CALL lbc_lnk_multi( vor_avrtot, 'F', 1. , vor_avrres, 'F', 1. )
+
+
+         ! III.3 time evolution array swap
+         ! ------------------------------
+         vor_avrbb(:,:) = vor_avrb(:,:)
+         vor_avrbn(:,:) = vor_avr (:,:)
+         !
+         nmoydpvor = 0
+         !
+      ENDIF
+
+      ! III.4 write trends to output
+      ! ---------------------------
+
+      IF( kt >=  nit000+1 ) THEN
+
+         IF( lwp .AND. MOD( itmod, nn_trd ) == 0 ) THEN
+            WRITE(numout,*) ''
+            WRITE(numout,*) 'trd_vor : write trends in the NetCDF file at kt = ', kt
+            WRITE(numout,*) '~~~~~~~  '
+         ENDIF
+ 
+         CALL histwrite( nidvor,"sovortPh",it,vortrd(:,:,jpvor_prg),ndimvor1,ndexvor1)  ! grad Ph
+         CALL histwrite( nidvor,"sovortEk",it,vortrd(:,:,jpvor_keg),ndimvor1,ndexvor1)  ! Energy
+         CALL histwrite( nidvor,"sovozeta",it,vortrd(:,:,jpvor_rvo),ndimvor1,ndexvor1)  ! rel vorticity
+         CALL histwrite( nidvor,"sovortif",it,vortrd(:,:,jpvor_pvo),ndimvor1,ndexvor1)  ! coriolis
+         CALL histwrite( nidvor,"sovodifl",it,vortrd(:,:,jpvor_ldf),ndimvor1,ndexvor1)  ! lat diff
+         CALL histwrite( nidvor,"sovoadvv",it,vortrd(:,:,jpvor_zad),ndimvor1,ndexvor1)  ! vert adv
+         CALL histwrite( nidvor,"sovodifv",it,vortrd(:,:,jpvor_zdf),ndimvor1,ndexvor1)  ! vert diff
+         CALL histwrite( nidvor,"sovortPs",it,vortrd(:,:,jpvor_spg),ndimvor1,ndexvor1)  ! grad Ps
+         CALL histwrite( nidvor,"sovortbv",it,vortrd(:,:,jpvor_bev),ndimvor1,ndexvor1)  ! beta.V
+         CALL histwrite( nidvor,"sovowind",it,vortrd(:,:,jpvor_swf),ndimvor1,ndexvor1) ! wind stress
+         CALL histwrite( nidvor,"sovobfri",it,vortrd(:,:,jpvor_bfr),ndimvor1,ndexvor1) ! bottom friction
+         CALL histwrite( nidvor,"1st_mbre",it,vor_avrtot    ,ndimvor1,ndexvor1) ! First membre
+         CALL histwrite( nidvor,"sovorgap",it,vor_avrres    ,ndimvor1,ndexvor1) ! gap between 1st and 2 nd mbre
+         !
+         IF( ndebug /= 0 ) THEN
+            WRITE(numout,*) ' debuging trd_vor: III.4 done'
+            CALL FLUSH(numout)
+         ENDIF
+         !
+      ENDIF
+      !
+      IF( MOD( it, nn_trd ) == 0 ) rotot(:,:)=0
+      !
+      IF( kt == nitend )   CALL histclo( nidvor )
+      !
+   END SUBROUTINE trd_vor_iom
+
+
+   SUBROUTINE trd_vor_init
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE trd_vor_init  ***
+      !! 
+      !! ** Purpose :   computation of vertically integrated T and S budgets
+      !!      from ocean surface down to control surface (NetCDF output)
+      !!----------------------------------------------------------------------
+      REAL(wp) ::   zjulian, zsto, zout
+      CHARACTER (len=40) ::   clhstnam
+      CHARACTER (len=40) ::   clop
+      !!----------------------------------------------------------------------
+
+      !  ===================
+      !   I. initialization
+      !  ===================
+
+      cvort='averaged-vor'
+
+      ! Open specifier
+      ndebug = 0      ! set it to 1 in case of problem to have more Print
+
+      IF(lwp) THEN
+         WRITE(numout,*) ' '
+         WRITE(numout,*) ' trd_vor_init: vorticity trends'
+         WRITE(numout,*) ' ~~~~~~~~~~~~'
+         WRITE(numout,*) ' '
+         WRITE(numout,*) '               ##########################################################################'
+         WRITE(numout,*) '                CAUTION: The interpretation of the vorticity trends is'
+         WRITE(numout,*) '                not obvious, please contact Anne-Marie TREGUIER at: treguier@ifremer.fr '
+         WRITE(numout,*) '               ##########################################################################'
+         WRITE(numout,*) ' '
+      ENDIF
+
+      IF( trd_vor_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'trd_vor_init : unable to allocate trdvor arrays' )
+
+
+      ! cumulated trends array init
+      nmoydpvor = 0
+      rotot(:,:)=0
+      vor_avrtot(:,:)=0
+      vor_avrres(:,:)=0
+
+      IF( ndebug /= 0 ) THEN
+         WRITE(numout,*) ' debuging trd_vor_init: I. done'
+         CALL FLUSH(numout)
+      ENDIF
+
+      !  =================================
+      !   II. netCDF output initialization
+      !  =================================
+
+      !-----------------------------------------
+      ! II.1 Define frequency of output and means
+      ! -----------------------------------------
+      IF( ln_mskland )   THEN   ;   clop = "only(x)"   ! put 1.e+20 on land (very expensive!!)
+      ELSE                      ;   clop = "x"         ! no use of the mask value (require less cpu time)
+      ENDIF
+#if defined key_diainstant
+      zsto = nwrite*rdt
+      clop = "inst("//TRIM(clop)//")"
+#else
+      zsto = rdt
+      clop = "ave("//TRIM(clop)//")"
+#endif
+      zout = nn_trd*rdt
+
+      IF(lwp) WRITE(numout,*) '               netCDF initialization'
+
+      ! II.2 Compute julian date from starting date of the run
+      ! ------------------------
+      CALL ymds2ju( nyear, nmonth, nday, rdt, zjulian )
+      zjulian = zjulian - adatrj   !   set calendar origin to the beginning of the experiment
+      IF(lwp) WRITE(numout,*)' '  
+      IF(lwp) WRITE(numout,*)'               Date 0 used :',nit000,    &
+         &                   ' YEAR ', nyear,' MONTH '      , nmonth,   &
+         &                   ' DAY ' , nday, 'Julian day : ', zjulian
+
+      ! II.3 Define the T grid trend file (nidvor)
+      ! ---------------------------------
+      CALL dia_nam( clhstnam, nn_trd, 'vort' )                  ! filename
+      IF(lwp) WRITE(numout,*) ' Name of NETCDF file ', clhstnam
+      CALL histbeg( clhstnam, jpi, glamf, jpj, gphif,1, jpi,   &  ! Horizontal grid : glamt and gphit
+         &          1, jpj, nit000-1, zjulian, rdt, nh_t, nidvor, domain_id=nidom, snc4chunks=snc4set )
+      CALL wheneq( jpi*jpj, fmask, 1, 1., ndexvor1, ndimvor1 )    ! surface
+
+      ! Declare output fields as netCDF variables
+      CALL histdef( nidvor, "sovortPh", cvort//"grad Ph" , "s-2",        & ! grad Ph
+         &          jpi,jpj,nh_t,1,1,1,-99,32,clop,zsto,zout)
+      CALL histdef( nidvor, "sovortEk", cvort//"Energy", "s-2",          & ! Energy
+         &          jpi,jpj,nh_t,1,1,1,-99,32,clop,zsto,zout)
+      CALL histdef( nidvor, "sovozeta", cvort//"rel vorticity", "s-2",   & ! rel vorticity
+         &          jpi,jpj,nh_t,1,1,1,-99,32,clop,zsto,zout)
+      CALL histdef( nidvor, "sovortif", cvort//"coriolis", "s-2",        & ! coriolis
+         &          jpi,jpj,nh_t,1,1,1,-99,32,clop,zsto,zout)
+      CALL histdef( nidvor, "sovodifl", cvort//"lat diff ", "s-2",       & ! lat diff
+         &          jpi,jpj,nh_t,1,1,1,-99,32,clop,zsto,zout)
+      CALL histdef( nidvor, "sovoadvv", cvort//"vert adv", "s-2",        & ! vert adv
+         &          jpi,jpj,nh_t,1,1,1,-99,32,clop,zsto,zout)
+      CALL histdef( nidvor, "sovodifv", cvort//"vert diff" , "s-2",      & ! vert diff
+         &          jpi,jpj,nh_t,1,1,1,-99,32,clop,zsto,zout)
+      CALL histdef( nidvor, "sovortPs", cvort//"grad Ps", "s-2",         & ! grad Ps
+         &          jpi,jpj,nh_t,1,1,1,-99,32,clop,zsto,zout)
+      CALL histdef( nidvor, "sovortbv", cvort//"Beta V", "s-2",          & ! beta.V
+         &          jpi,jpj,nh_t,1,1,1,-99,32,clop,zsto,zout)
+      CALL histdef( nidvor, "sovowind", cvort//"wind stress", "s-2",     & ! wind stress
+         &          jpi,jpj,nh_t,1,1,1,-99,32,clop,zsto,zout)
+      CALL histdef( nidvor, "sovobfri", cvort//"bottom friction", "s-2", & ! bottom friction
+         &          jpi,jpj,nh_t,1,1,1,-99,32,clop,zsto,zout)
+      CALL histdef( nidvor, "1st_mbre", cvort//"1st mbre", "s-2",        & ! First membre
+         &          jpi,jpj,nh_t,1,1,1,-99,32,clop,zsto,zout)
+      CALL histdef( nidvor, "sovorgap", cvort//"gap", "s-2",             & ! gap between 1st and 2 nd mbre
+         &          jpi,jpj,nh_t,1,1,1,-99,32,clop,zsto,zout)
+      CALL histend( nidvor, snc4set )
+
+      IF( ndebug /= 0 ) THEN
+         WRITE(numout,*) ' debuging trd_vor_init: II. done'
+         CALL FLUSH(numout)
+      ENDIF
+      !
+   END SUBROUTINE trd_vor_init
+
+   !!======================================================================
+END MODULE trdvor
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/TRD/trdvor_oce.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/TRD/trdvor_oce.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/TRD/trdvor_oce.F90	(revision 9570)
@@ -0,0 +1,34 @@
+MODULE trdvor_oce
+   !!======================================================================
+   !!                   ***  MODULE trdvor_oce  ***
+   !! Ocean trends :   set vorticity trend variables
+   !!======================================================================
+   !! History :  1.0  !  04-2006  (L. Brunier, A-M. Treguier) Original code 
+   !!----------------------------------------------------------------------
+   
+   USE par_oce      ! ocean parameters
+
+   IMPLICIT NONE
+   PRIVATE
+
+   !                                               !!* vorticity trends index
+   INTEGER, PUBLIC, PARAMETER ::   jpltot_vor = 11  !: Number of vorticity trend terms
+   !
+   INTEGER, PUBLIC, PARAMETER ::   jpvor_prg =  1   !: Pressure Gradient Trend
+   INTEGER, PUBLIC, PARAMETER ::   jpvor_keg =  2   !: KE Gradient Trend
+   INTEGER, PUBLIC, PARAMETER ::   jpvor_rvo =  3   !: Relative Vorticity Trend
+   INTEGER, PUBLIC, PARAMETER ::   jpvor_pvo =  4   !: Planetary Vorticity Term Trend
+   INTEGER, PUBLIC, PARAMETER ::   jpvor_ldf =  5   !: Horizontal Diffusion Trend
+   INTEGER, PUBLIC, PARAMETER ::   jpvor_zad =  6   !: Vertical Advection Trend
+   INTEGER, PUBLIC, PARAMETER ::   jpvor_zdf =  7   !: Vertical Diffusion Trend
+   INTEGER, PUBLIC, PARAMETER ::   jpvor_spg =  8   !: Surface Pressure Grad. Trend
+   INTEGER, PUBLIC, PARAMETER ::   jpvor_bev =  9   !: Beta V
+   INTEGER, PUBLIC, PARAMETER ::   jpvor_swf = 10   !: wind stress forcing term
+   INTEGER, PUBLIC, PARAMETER ::   jpvor_bfr = 11   !: bottom friction term
+
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO Consortium (2010)
+   !! $Id$ 
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!======================================================================
+END MODULE trdvor_oce
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/USR/usrdef_fmask.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/USR/usrdef_fmask.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/USR/usrdef_fmask.F90	(revision 9570)
@@ -0,0 +1,150 @@
+MODULE usrdef_fmask
+   !!======================================================================
+   !!                     ***  MODULE usrdef_fmask   ***
+   !!
+   !!                      ===  ORCA configuration  ===
+   !!                            (2 and 1 degrees)
+   !!
+   !! User defined : alteration of land/sea f-point mask in some straits
+   !!======================================================================
+   !! History :  4.0  ! 2016-06  (G. Madec, S. Flavoni)  Original code
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   usr_def_fmask  : alteration of f-point land/ocean mask in some straits
+   !!----------------------------------------------------------------------
+   USE oce             ! ocean dynamics and tracers
+   USE dom_oce         ! ocean space and time domain
+   !
+   USE in_out_manager  ! I/O manager
+   USE lbclnk          ! ocean lateral boundary conditions (or mpp link)
+   USE lib_mpp         ! Massively Parallel Processing library
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   usr_def_fmask    ! routine called by dommsk.F90
+
+   !! * Substitutions
+#  include "vectopt_loop_substitute.h90"
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 4.0 , NEMO Consortium  (2016)
+   !! $Id:$ 
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE usr_def_fmask( cd_cfg, kcfg, pfmsk )
+      !!---------------------------------------------------------------------
+      !!                 ***  ROUTINE dom_msk  ***
+      !!
+      !! ** Purpose :   User defined alteration of the lateral boundary 
+      !!              condition on velocity.
+      !!
+      !! ** Method  :   Local change of the value of fmask at lateral ocean/land 
+      !!              boundary in straits in order to increase the viscous 
+      !!              boundary layer and thus reduce the transport through the 
+      !!              corresponding straits.
+      !!                Here only alterations in ORCA R2 and R1 cases
+      !!
+      !! ** Action :   fmask : land/ocean mask at f-point with increased value 
+      !!                       in some user defined straits
+      !!----------------------------------------------------------------------
+      CHARACTER(len=*)          , INTENT(in   ) ::   cd_cfg   ! configuration name
+      INTEGER                   , INTENT(in   ) ::   kcfg     ! configuration identifier 
+      REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   pfmsk    ! Ocean/Land f-point mask including lateral boundary cond.
+      !
+      INTEGER  ::   iif, iil, ii0, ii1, ii   ! local integers
+      INTEGER  ::   ijf, ijl, ij0, ij1       !   -       -
+      INTEGER  ::   isrow                    ! index for ORCA1 starting row
+      !!----------------------------------------------------------------------
+      !
+      IF( TRIM( cd_cfg ) == "orca" ) THEN      !==  ORCA Configurations  ==!
+         !
+         SELECT CASE ( kcfg )
+         !
+         CASE( 2 )                           !  R2 case
+            IF(lwp) WRITE(numout,*)
+            IF(lwp) WRITE(numout,*) 'usr_def_fmask : ORCA_R2: increase lateral friction near the following straits:'
+            IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~'
+            !
+            IF(lwp) WRITE(numout,*) '      Gibraltar '
+            ij0 = 101   ;   ij1 = 101           ! Gibraltar strait  : partial slip (pfmsk=0.5)
+            ii0 = 139   ;   ii1 = 140   ;   pfmsk( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , 1:jpk ) =  0.5_wp
+            ij0 = 102   ;   ij1 = 102
+            ii0 = 139   ;   ii1 = 140   ;   pfmsk( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , 1:jpk ) =  0.5_wp
+            !
+            IF(lwp) WRITE(numout,*) '      Bab el Mandeb '
+            ij0 =  87   ;   ij1 =  88           ! Bab el Mandeb : partial slip (pfmsk=1)
+            ii0 = 160   ;   ii1 = 160   ;   pfmsk( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , 1:jpk ) =  1._wp
+            ij0 =  88   ;   ij1 =  88
+            ii0 = 159   ;   ii1 = 159   ;   pfmsk( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , 1:jpk ) =  1._wp
+            !
+            ! We keep this as an example but it is instable in this case 
+            !IF(lwp) WRITE(numout,*) '      Danish straits '
+            !         ij0 = 115   ;   ij1 = 115 ! Danish straits  : strong slip (pfmsk > 2)
+            !         ii0 = 145   ;   ii1 = 146   ;   pfmsk( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , 1:jpk ) = 4._wp
+            !         ij0 = 116   ;   ij1 = 116
+            !         ii0 = 145   ;   ii1 = 146   ;   pfmsk( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , 1:jpk ) = 4._wp
+            !
+         CASE( 1 )                           ! R1 case
+            IF(lwp) WRITE(numout,*)
+            IF(lwp) WRITE(numout,*) 'usr_def_fmask : ORCA_R1: increase lateral friction near the following straits:'
+            IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~'   
+!!gm    ! This dirty section will be suppressed by simplification process:
+!!gm    ! all this will come back in input files
+!!gm    ! Currently these hard-wired indices relate to configuration with extend grid (jpjglo=332)
+            !
+            isrow = 332 - jpjglo
+            !
+            IF(lwp) WRITE(numout,*)
+            IF(lwp) WRITE(numout,*) '   orca_r1: increase friction near the following straits : '
+            IF(lwp) WRITE(numout,*) '      Gibraltar '
+            ii0 = 282           ;   ii1 = 283        ! Gibraltar Strait 
+            ij0 = 241 - isrow   ;   ij1 = 241 - isrow   ;   pfmsk( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp  
+            !
+            IF(lwp) WRITE(numout,*) '      Bhosporus '
+            ii0 = 314           ;   ii1 = 315        ! Bhosporus Strait 
+            ij0 = 248 - isrow   ;   ij1 = 248 - isrow   ;   pfmsk( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp  
+            !
+            IF(lwp) WRITE(numout,*) '      Makassar (Top) '
+            ii0 =  48           ;   ii1 =  48        ! Makassar Strait (Top) 
+            ij0 = 189 - isrow   ;   ij1 = 190 - isrow   ;   pfmsk( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 3._wp  
+            !
+            IF(lwp) WRITE(numout,*) '      Lombok '
+            ii0 =  44           ;   ii1 =  44        ! Lombok Strait 
+            ij0 = 164 - isrow   ;   ij1 = 165 - isrow   ;   pfmsk( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp  
+            !
+            IF(lwp) WRITE(numout,*) '      Ombai '
+            ii0 =  53           ;   ii1 =  53        ! Ombai Strait 
+            ij0 = 164 - isrow   ;   ij1 = 165 - isrow   ;   pfmsk( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp  
+            !
+            IF(lwp) WRITE(numout,*) '      Timor Passage '
+            ii0 =  56           ;   ii1 =  56        ! Timor Passage 
+            ij0 = 164 - isrow   ;   ij1 = 165 - isrow   ;   pfmsk( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp  
+            !
+            IF(lwp) WRITE(numout,*) '      West Halmahera '
+            ii0 =  58           ;   ii1 =  58        ! West Halmahera Strait 
+            ij0 = 181 - isrow   ;   ij1 = 182 - isrow   ;   pfmsk( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 3._wp  
+            !
+            IF(lwp) WRITE(numout,*) '      East Halmahera '
+            ii0 =  55           ;   ii1 =  55        ! East Halmahera Strait 
+            ij0 = 181 - isrow   ;   ij1 = 182 - isrow   ;   pfmsk( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 3._wp  
+            !
+         CASE DEFAULT
+            IF(lwp) WRITE(numout,*)
+            IF(lwp) WRITE(numout,*) 'usr_def_fmask : ORCA_R', kcfg,' : NO alteration of fmask in specific straits '
+            IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~'   
+         END SELECT
+      ELSE
+         IF(lwp) WRITE(numout,*)
+         IF(lwp) WRITE(numout,*) 'usr_def_fmask : NO alteration of fmask in specific straits '
+         IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~'
+      ENDIF
+      !
+      CALL lbc_lnk( pfmsk, 'F', 1._wp )      ! Lateral boundary conditions on fmask
+      !
+   END SUBROUTINE usr_def_fmask
+   
+   !!======================================================================
+END MODULE usrdef_fmask
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/USR/usrdef_hgr.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/USR/usrdef_hgr.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/USR/usrdef_hgr.F90	(revision 9570)
@@ -0,0 +1,172 @@
+MODULE usrdef_hgr
+   !!======================================================================
+   !!                     ***  MODULE usrdef_hgr   ***
+   !!
+   !!                     ===  GYRE configuration  ===
+   !!
+   !! User defined :   mesh and Coriolis parameter of a user configuration
+   !!======================================================================
+   !! History :  4.0 ! 2016-03  (S. Flavoni) 
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   usr_def_hgr   : initialize the horizontal mesh 
+   !!----------------------------------------------------------------------
+   USE dom_oce  , ONLY: nimpp, njmpp       ! ocean space and time domain
+   USE par_oce        ! ocean space and time domain
+   USE phycst         ! physical constants
+   USE usrdef_nam     !
+   !
+   USE in_out_manager ! I/O manager
+   USE lib_mpp        ! MPP library
+   
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   usr_def_hgr   ! called in domhgr.F90
+
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 4.0 , NEMO Consortium (2016)
+   !! $Id:$ 
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE usr_def_hgr( plamt , plamu , plamv  , plamf  ,   &   ! geographic position (required)
+      &                    pphit , pphiu , pphiv  , pphif  ,   &   !
+      &                    kff   , pff_f , pff_t  ,            &   ! Coriolis parameter  (if domain not on the sphere)
+      &                    pe1t  , pe1u  , pe1v   , pe1f   ,   &   ! scale factors       (required)
+      &                    pe2t  , pe2u  , pe2v   , pe2f   ,   &   !
+      &                    ke1e2u_v      , pe1e2u , pe1e2v     )   ! u- & v-surfaces (if gridsize reduction is used in strait(s))
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE usr_def_hgr  ***
+      !!
+      !! ** Purpose :   user defined mesh and Coriolis parameter
+      !!
+      !! ** Method  :   set all intent(out) argument to a proper value
+      !!
+      !!                Here GYRE configuration :
+      !!          Rectangular mid-latitude domain 
+      !!          - with axes rotated by 45 degrees
+      !!          - a constant horizontal resolution of 106 km 
+      !!          - on a beta-plane
+      !!
+      !! ** Action  : - define longitude & latitude of t-, u-, v- and f-points (in degrees) 
+      !!              - define coriolis parameter at f-point if the domain in not on the sphere (on beta-plane)
+      !!              - define i- & j-scale factors at t-, u-, v- and f-points (in meters)
+      !!              - define u- & v-surfaces (if gridsize reduction is used in some straits) (in m2)
+      !!----------------------------------------------------------------------
+      REAL(wp), DIMENSION(:,:), INTENT(out) ::   plamt, plamu, plamv, plamf   ! longitude outputs                     [degrees]
+      REAL(wp), DIMENSION(:,:), INTENT(out) ::   pphit, pphiu, pphiv, pphif   ! latitude outputs                      [degrees]
+      INTEGER                 , INTENT(out) ::   kff                          ! =1 Coriolis parameter computed here, =0 otherwise
+      REAL(wp), DIMENSION(:,:), INTENT(out) ::   pff_f, pff_t                 ! Coriolis factor at f-point                [1/s]
+      REAL(wp), DIMENSION(:,:), INTENT(out) ::   pe1t, pe1u, pe1v, pe1f       ! i-scale factors                             [m]
+      REAL(wp), DIMENSION(:,:), INTENT(out) ::   pe2t, pe2u, pe2v, pe2f       ! j-scale factors                             [m]
+      INTEGER                 , INTENT(out) ::   ke1e2u_v                     ! =1 u- & v-surfaces computed here, =0 otherwise 
+      REAL(wp), DIMENSION(:,:), INTENT(out) ::   pe1e2u, pe1e2v               ! u- & v-surfaces (if reduction in strait)   [m2]
+      !
+      INTEGER  ::   ji, jj               ! dummy loop indices
+      REAL(wp) ::   zlam1, zlam0, zcos_alpha, zim1 , zjm1 , ze1  , ze1deg, zf0 ! local scalars
+      REAL(wp) ::   zphi1, zphi0, zsin_alpha, zim05, zjm05, zbeta, znorme      !   -      -
+      !!-------------------------------------------------------------------------------
+      !
+      !     !==  beta-plane with regular grid-spacing and rotated domain ==!  (GYRE configuration)
+      !
+      IF(lwp) WRITE(numout,*)
+      IF(lwp) WRITE(numout,*) 'usr_def_hgr : GYRE configuration (beta-plane with rotated regular grid-spacing)'
+      IF(lwp) WRITE(numout,*) '~~~~~~~~~~~'
+      !
+      !
+      !                       !==  grid point position  ==!
+      !
+      zlam1 = -85._wp                           ! position of gridpoint (i,j) = (1,jpjglo)
+      zphi1 =  29._wp
+      !
+      ze1 = 106000._wp / REAL( nn_GYRE , wp )   ! gridspacing in meters
+      !
+      zsin_alpha = - SQRT( 2._wp ) * 0.5_wp     ! angle: 45 degrees
+      zcos_alpha =   SQRT( 2._wp ) * 0.5_wp
+      ze1deg = ze1 / (ra * rad)
+      zlam0 = zlam1 + zcos_alpha * ze1deg * REAL( jpjglo-2 , wp )
+      zphi0 = zphi1 + zsin_alpha * ze1deg * REAL( jpjglo-2 , wp )
+
+#if defined key_agrif
+      ! ! Upper left longitude and latitude from parent:
+      IF (.NOT.Agrif_root()) THEN
+         zlam0 = zlam1 + Agrif_irhox() * REAL(Agrif_Parent(jpjglo)-2 , wp) * ze1deg * zcos_alpha  &
+                   &   + ( Agrif_Ix()*Agrif_irhox()-(0.5_wp+nbghostcells)) * ze1deg * zcos_alpha  &
+                   &   + ( Agrif_Iy()*Agrif_irhoy()-(0.5_wp+nbghostcells)) * ze1deg * zsin_alpha
+         zphi0 = zphi1 + Agrif_irhoy() * REAL(Agrif_Parent(jpjglo)-2 , wp) * ze1deg * zsin_alpha  &
+                   &   - ( Agrif_Ix()*Agrif_irhox()-nbghostcells )         * ze1deg * zsin_alpha  &
+                   &   + ( Agrif_Iy()*Agrif_irhoy()-nbghostcells )         * ze1deg * zcos_alpha
+      ENDIF 
+#endif
+      !   
+      IF( ln_bench ) THEN     ! benchmark: forced the resolution to be 106 km 
+         ze1 = 106000._wp     ! but keep (lat,lon) at the right nn_GYRE resolution
+         CALL ctl_warn( ' GYRE used as Benchmark: e1=e2=106km, no need to adjust rdt, ahm,aht ' )
+      ENDIF
+      IF( nprint==1 .AND. lwp )   THEN
+         WRITE(numout,*) 'ze1', ze1, 'cosalpha', zcos_alpha, 'sinalpha', zsin_alpha
+         WRITE(numout,*) 'ze1deg', ze1deg, 'zlam0', zlam0, 'zphi0', zphi0
+      ENDIF
+      !   
+      DO jj = 1, jpj 
+         DO ji = 1, jpi 
+            zim1 = REAL( ji + nimpp - 1 ) - 1.   ;   zim05 = REAL( ji + nimpp - 1 ) - 1.5 
+            zjm1 = REAL( jj + njmpp - 1 ) - 1.   ;   zjm05 = REAL( jj + njmpp - 1 ) - 1.5 
+            !   
+            !glamt(i,j) longitude at T-point
+            !gphit(i,j) latitude at T-point  
+            plamt(ji,jj) = zlam0 + zim05 * ze1deg * zcos_alpha + zjm05 * ze1deg * zsin_alpha
+            pphit(ji,jj) = zphi0 - zim05 * ze1deg * zsin_alpha + zjm05 * ze1deg * zcos_alpha
+            !   
+            !glamu(i,j) longitude at U-point
+            !gphiu(i,j) latitude at U-point
+            plamu(ji,jj) = zlam0 + zim1  * ze1deg * zcos_alpha + zjm05 * ze1deg * zsin_alpha
+            pphiu(ji,jj) = zphi0 - zim1  * ze1deg * zsin_alpha + zjm05 * ze1deg * zcos_alpha
+            !   
+            !glamv(i,j) longitude at V-point
+            !gphiv(i,j) latitude at V-point
+            plamv(ji,jj) = zlam0 + zim05 * ze1deg * zcos_alpha + zjm1  * ze1deg * zsin_alpha
+            pphiv(ji,jj) = zphi0 - zim05 * ze1deg * zsin_alpha + zjm1  * ze1deg * zcos_alpha
+            !
+            !glamf(i,j) longitude at F-point
+            !gphif(i,j) latitude at F-point 
+            plamf(ji,jj) = zlam0 + zim1  * ze1deg * zcos_alpha + zjm1  * ze1deg * zsin_alpha
+            pphif(ji,jj) = zphi0 - zim1  * ze1deg * zsin_alpha + zjm1  * ze1deg * zcos_alpha
+         END DO
+      END DO
+      !
+      !                       !== Horizontal scale factors ==! (in meters)
+      !                     
+      !                                         ! constant grid spacing
+      pe1t(:,:) =  ze1     ;      pe2t(:,:) = ze1
+      pe1u(:,:) =  ze1     ;      pe2u(:,:) = ze1
+      pe1v(:,:) =  ze1     ;      pe2v(:,:) = ze1
+      pe1f(:,:) =  ze1     ;      pe2f(:,:) = ze1
+      !
+      !                                         ! NO reduction of grid size in some straits 
+      ke1e2u_v = 0                              !    ==>> u_ & v_surfaces will be computed in dom_ghr routine
+      pe1e2u(:,:) = 0._wp                       !    CAUTION: set to zero to avoid error with some compilers that
+      pe1e2v(:,:) = 0._wp                       !             require an initialization of INTENT(out) arguments
+      !
+      !
+      !                       !==  Coriolis parameter  ==!
+      kff = 1                                            !  indicate not to compute ff afterward
+      !
+      zbeta = 2. * omega * COS( rad * zphi1 ) / ra       ! beta at latitude zphi1
+      !SF we overwrite zphi0 (south point in latitude) used just above to define pphif (value of zphi0=15.5190567531966)
+      !SF for computation of Coriolis we keep the parameter of Hazeleger, W., and S. S. Drijfhout, JPO 1998.
+      zphi0 = 15._wp                                     !  latitude of the most southern grid point  
+      zf0   = 2. * omega * SIN( rad * zphi0 )            !  compute f0 1st point south
+      !
+      pff_f(:,:) = ( zf0 + zbeta * ABS( pphif(:,:) - zphi0 ) * rad * ra ) ! f = f0 +beta* y ( y=0 at south)
+      pff_t(:,:) = ( zf0 + zbeta * ABS( pphit(:,:) - zphi0 ) * rad * ra ) ! f = f0 +beta* y ( y=0 at south)
+      !
+      IF(lwp) WRITE(numout,*) '                           beta-plane used. beta = ', zbeta, ' 1/(s.m)'
+      !
+   END SUBROUTINE usr_def_hgr
+
+   !!======================================================================
+END MODULE usrdef_hgr
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/USR/usrdef_istate.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/USR/usrdef_istate.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/USR/usrdef_istate.F90	(revision 9570)
@@ -0,0 +1,85 @@
+MODULE usrdef_istate
+   !!======================================================================
+   !!                   ***  MODULE  usrdef_istate   ***
+   !!
+   !!                     ===  GYRE configuration  ===
+   !!
+   !! User defined : set the initial state of a user configuration
+   !!======================================================================
+   !! History :  4.0 ! 2016-03  (S. Flavoni) Original code
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!  usr_def_istate : initial state in Temperature and salinity
+   !!----------------------------------------------------------------------
+   USE par_oce        ! ocean space and time domain
+   USE phycst         ! physical constants
+   !
+   USE in_out_manager ! I/O manager
+   USE lib_mpp        ! MPP library
+   
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   usr_def_istate   ! called in istate.F90
+
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 4.0 , NEMO Consortium (2016)
+   !! $Id:$ 
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+  
+   SUBROUTINE usr_def_istate( pdept, ptmask, pts, pu, pv, pssh )
+      !!----------------------------------------------------------------------
+      !!                   ***  ROUTINE usr_def_istate  ***
+      !! 
+      !! ** Purpose :   Initialization of the dynamics and tracers
+      !!                Here GYRE configuration example : (double gyre with rotated domain)
+      !!
+      !! ** Method  : - set temprature field
+      !!              - set salinity   field
+      !!----------------------------------------------------------------------
+      REAL(wp), DIMENSION(jpi,jpj,jpk)     , INTENT(in   ) ::   pdept   ! depth of t-point               [m]
+      REAL(wp), DIMENSION(jpi,jpj,jpk)     , INTENT(in   ) ::   ptmask  ! t-point ocean mask             [m]
+      REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(  out) ::   pts     ! T & S fields      [Celsius ; g/kg]
+      REAL(wp), DIMENSION(jpi,jpj,jpk)     , INTENT(  out) ::   pu      ! i-component of the velocity  [m/s] 
+      REAL(wp), DIMENSION(jpi,jpj,jpk)     , INTENT(  out) ::   pv      ! j-component of the velocity  [m/s] 
+      REAL(wp), DIMENSION(jpi,jpj)         , INTENT(  out) ::   pssh    ! sea-surface height
+      !
+      INTEGER :: ji, jj, jk  ! dummy loop indices
+      !!----------------------------------------------------------------------
+      !
+      IF(lwp) WRITE(numout,*)
+      IF(lwp) WRITE(numout,*) 'usr_def_istate : analytical definition of initial state '
+      IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~~   Ocean at rest, with an horizontally uniform T and S profiles'
+      !
+      pu  (:,:,:) = 0._wp        ! ocean at rest
+      pv  (:,:,:) = 0._wp
+      pssh(:,:)   = 0._wp
+      !
+      DO jk = 1, jpk             ! horizontally uniform T & S profiles
+         DO jj = 1, jpj
+            DO ji = 1, jpi
+               pts(ji,jj,jk,jp_tem) =  (  (  16. - 12. * TANH( (pdept(ji,jj,jk) - 400) / 700 ) )   &
+                    &           * (-TANH( (500. - pdept(ji,jj,jk)) / 150. ) + 1.) / 2.             &
+                    &           + ( 15. * ( 1. - TANH( (pdept(ji,jj,jk)-50.) / 1500.) )            &
+                    &           - 1.4 * TANH((pdept(ji,jj,jk)-100.) / 100.)                        &
+                    &           + 7.  * (1500. - pdept(ji,jj,jk) ) / 1500.)                        &
+                    &           * (-TANH( (pdept(ji,jj,jk) - 500.) / 150.) + 1.) / 2.  ) * ptmask(ji,jj,jk)
+
+               pts(ji,jj,jk,jp_sal) =  (  (  36.25 - 1.13 * TANH( (pdept(ji,jj,jk) - 305) / 460 ) )  &
+                    &         * (-TANH((500. - pdept(ji,jj,jk)) / 150.) + 1.) / 2                  &
+                    &         + ( 35.55 + 1.25 * (5000. - pdept(ji,jj,jk)) / 5000.                 &
+                    &         - 1.62 * TANH( (pdept(ji,jj,jk) - 60.  ) / 650. )                    &
+                    &         + 0.2  * TANH( (pdept(ji,jj,jk) - 35.  ) / 100. )                    &
+                    &         + 0.2  * TANH( (pdept(ji,jj,jk) - 1000.) / 5000.) )                  &
+                    &         * (-TANH( (pdept(ji,jj,jk) - 500.) / 150.) + 1.) / 2  ) * ptmask(ji,jj,jk)
+            END DO
+         END DO
+      END DO
+      !   
+   END SUBROUTINE usr_def_istate
+
+   !!======================================================================
+END MODULE usrdef_istate
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/USR/usrdef_nam.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/USR/usrdef_nam.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/USR/usrdef_nam.F90	(revision 9570)
@@ -0,0 +1,112 @@
+MODULE usrdef_nam
+   !!======================================================================
+   !!                     ***  MODULE usrdef_nam   ***
+   !!
+   !!                     ===  GYRE configuration  ===
+   !!
+   !! User defined : set the domain characteristics of a user configuration
+   !!======================================================================
+   !! History :  4.0  ! 2016-03  (S. Flavoni, G. Madec)  Original code
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   usr_def_nam   : read user defined namelist and set global domain size
+   !!   usr_def_hgr   : initialize the horizontal mesh 
+   !!----------------------------------------------------------------------
+   USE dom_oce  , ONLY: nimpp, njmpp       ! ocean space and time domain
+   USE par_oce        ! ocean space and time domain
+   USE phycst         ! physical constants
+   !
+   USE in_out_manager ! I/O manager
+   USE lib_mpp        ! MPP library
+   
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   usr_def_nam   ! called in nemogcm.F90 module
+
+   !                              !!* namusr_def namelist *!!
+   LOGICAL, PUBLIC ::   ln_bench   ! =T benchmark test with gyre: the gridsize is constant (no need to adjust timestep or viscosity)
+   INTEGER, PUBLIC ::   nn_GYRE    ! 1/nn_GYRE = the resolution chosen in degrees and thus defining the horizontal domain size
+
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 4.0 , NEMO Consortium (2016)
+   !! $Id:$ 
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE usr_def_nam( ldtxt, ldnam, cd_cfg, kk_cfg, kpi, kpj, kpk, kperio )
+      !!----------------------------------------------------------------------
+      !!                     ***  ROUTINE dom_nam  ***
+      !!                    
+      !! ** Purpose :   read user defined namelist and define the domain size
+      !!
+      !! ** Method  :   read in namusr_def containing all the user specific namelist parameter
+      !!
+      !!                Here GYRE configuration
+      !!
+      !! ** input   : - namusr_def namelist found in namelist_cfg
+      !!----------------------------------------------------------------------
+      CHARACTER(len=*), DIMENSION(:), INTENT(out) ::   ldtxt, ldnam    ! stored print information
+      CHARACTER(len=*)              , INTENT(out) ::   cd_cfg          ! configuration name
+      INTEGER                       , INTENT(out) ::   kk_cfg          ! configuration resolution
+      INTEGER                       , INTENT(out) ::   kpi, kpj, kpk   ! global domain sizes 
+      INTEGER                       , INTENT(out) ::   kperio          ! lateral global domain b.c. 
+      !
+      INTEGER ::   ios, ii   ! Local integer
+      !!
+      NAMELIST/namusr_def/ nn_GYRE, ln_bench, jpkglo
+      !!----------------------------------------------------------------------
+      !
+      ii = 1
+      !
+      REWIND( numnam_cfg )          ! Namelist namusr_def (exist in namelist_cfg only)
+      READ  ( numnam_cfg, namusr_def, IOSTAT = ios, ERR = 902 )
+902   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namusr_def in configuration namelist', .TRUE. )
+      !
+      WRITE( ldnam(:), namusr_def )
+      !
+      cd_cfg = 'GYRE'               ! name & resolution (not used)
+#if defined key_agrif
+      IF (.NOT.Agrif_root()) nn_GYRE = Agrif_parent(nn_GYRE) * Agrif_irhox()
+#endif
+      kk_cfg = nn_GYRE
+      !
+      kpi = 30 * nn_GYRE + 2        ! Global Domain size
+      kpj = 20 * nn_GYRE + 2
+#if defined key_agrif
+      IF( .NOT. Agrif_Root() ) THEN
+         kpi  = nbcellsx + 2 + 2*nbghostcells
+         kpj  = nbcellsy + 2 + 2*nbghostcells
+      ENDIF
+#endif
+      kpk = jpkglo
+      !
+      !                             ! control print
+      WRITE(ldtxt(ii),*) '   '                                                                            ;   ii = ii + 1
+      WRITE(ldtxt(ii),*) 'usr_def_nam  : read the user defined namelist (namusr_def) in namelist_cfg'     ;   ii = ii + 1
+      WRITE(ldtxt(ii),*) '~~~~~~~~~~~ '                                                                   ;   ii = ii + 1
+      WRITE(ldtxt(ii),*) '   Namelist namusr_def : GYRE case'                                             ;   ii = ii + 1
+      WRITE(ldtxt(ii),*) '      GYRE used as Benchmark (=T)                      ln_bench  = ', ln_bench  ;   ii = ii + 1
+      WRITE(ldtxt(ii),*) '      inverse resolution & implied domain size         nn_GYRE   = ', nn_GYRE   ;   ii = ii + 1
+#if defined key_agrif
+      IF( Agrif_Root() ) THEN
+#endif
+      WRITE(ldtxt(ii),*) '         jpiglo = 30*nn_GYRE+2                            jpiglo = ', kpi       ;   ii = ii + 1
+      WRITE(ldtxt(ii),*) '         jpjglo = 20*nn_GYRE+2                            jpjglo = ', kpj       ;   ii = ii + 1
+#if defined key_agrif
+      ENDIF
+#endif
+      WRITE(ldtxt(ii),*) '      number of model levels                              jpkglo = ', kpk       ;   ii = ii + 1
+      !
+      !                             ! Set the lateral boundary condition of the global domain
+      kperio = 0                    ! GYRE configuration : closed domain
+      !
+      WRITE(ldtxt(ii),*) '   '                                                                            ;   ii = ii + 1
+      WRITE(ldtxt(ii),*) '   Lateral b.c. of the global domain set to closed     jperio = ', kperio       ;   ii = ii + 1
+      !
+   END SUBROUTINE usr_def_nam
+
+   !!======================================================================
+END MODULE usrdef_nam
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/USR/usrdef_sbc.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/USR/usrdef_sbc.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/USR/usrdef_sbc.F90	(revision 9570)
@@ -0,0 +1,240 @@
+MODULE usrdef_sbc
+   !!======================================================================
+   !!                     ***  MODULE  usrdef_sbc  ***
+   !!
+   !!                     ===  GYRE configuration  ===
+   !!
+   !! User defined :   surface forcing of a user configuration
+   !!======================================================================
+   !! History :  4.0   ! 2016-03  (S. Flavoni, G. Madec)  user defined interface
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   usrdef_sbc    : user defined surface bounday conditions in GYRE case
+   !!----------------------------------------------------------------------
+   USE oce            ! ocean dynamics and tracers
+   USE dom_oce        ! ocean space and time domain
+   USE sbc_oce        ! Surface boundary condition: ocean fields
+   USE phycst         ! physical constants
+   !
+   USE in_out_manager ! I/O manager
+   USE lib_mpp        ! distribued memory computing library
+   USE lbclnk         ! ocean lateral boundary conditions (or mpp link)
+   USE lib_fortran    !
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   usrdef_sbc_oce       ! routine called in sbcmod module
+   PUBLIC   usrdef_sbc_ice_tau   ! routine called by icestp.F90 for ice dynamics
+   PUBLIC   usrdef_sbc_ice_flx   ! routine called by icestp.F90 for ice thermo
+
+   !! * Substitutions
+#  include "vectopt_loop_substitute.h90"
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 4.0 , NEMO Consortium (2016)
+   !! $Id:$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE usrdef_sbc_oce( kt )
+      !!---------------------------------------------------------------------
+      !!                    ***  ROUTINE usrdef_sbc  ***
+      !!              
+      !! ** Purpose :   provide at each time-step the GYRE surface boundary
+      !!              condition, i.e. the momentum, heat and freshwater fluxes.
+      !!
+      !! ** Method  :   analytical seasonal cycle for GYRE configuration.
+      !!                CAUTION : never mask the surface stress field !
+      !!
+      !! ** Action  : - set the ocean surface boundary condition, i.e.   
+      !!                   utau, vtau, taum, wndm, qns, qsr, emp, sfx
+      !!
+      !! Reference : Hazeleger, W., and S. Drijfhout, JPO, 30, 677-695, 2000.
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT(in) ::   kt   ! ocean time step
+      !!
+      INTEGER  ::   ji, jj                 ! dummy loop indices
+      INTEGER  ::   zyear0                 ! initial year 
+      INTEGER  ::   zmonth0                ! initial month
+      INTEGER  ::   zday0                  ! initial day
+      INTEGER  ::   zday_year0             ! initial day since january 1st
+      REAL(wp) ::   ztau     , ztau_sais   ! wind intensity and of the seasonal cycle
+      REAL(wp) ::   ztime                  ! time in hour
+      REAL(wp) ::   ztimemax , ztimemin    ! 21th June, and 21th decem. if date0 = 1st january
+      REAL(wp) ::   ztimemax1, ztimemin1   ! 21th June, and 21th decem. if date0 = 1st january
+      REAL(wp) ::   ztimemax2, ztimemin2   ! 21th June, and 21th decem. if date0 = 1st january
+      REAL(wp) ::   ztaun                  ! intensity
+      REAL(wp) ::   zemp_s, zemp_n, zemp_sais, ztstar
+      REAL(wp) ::   zcos_sais1, zcos_sais2, ztrp, zconv, t_star
+      REAL(wp) ::   zsumemp, zsurf
+      REAL(wp) ::   zrhoa  = 1.22         ! Air density kg/m3
+      REAL(wp) ::   zcdrag = 1.5e-3       ! drag coefficient
+      REAL(wp) ::   ztx, zty, zmod, zcoef ! temporary variables
+      REAL(wp) ::   zyydd                 ! number of days in one year
+      !!---------------------------------------------------------------------
+      zyydd = REAL(nyear_len(1),wp)
+
+      ! ---------------------------- !
+      !  heat and freshwater fluxes  !
+      ! ---------------------------- !
+      !same temperature, E-P as in HAZELEGER 2000
+
+      zyear0     =   ndate0 / 10000                             ! initial year
+      zmonth0    = ( ndate0 - zyear0 * 10000 ) / 100            ! initial month
+      zday0      =   ndate0 - zyear0 * 10000 - zmonth0 * 100    ! initial day betwen 1 and 30
+      zday_year0 = ( zmonth0 - 1 ) * 30.+zday0                  ! initial day betwen 1 and 360
+
+      ! current day (in hours) since january the 1st of the current year
+      ztime = REAL( kt ) * rdt / (rmmss * rhhmm)   &       !  total incrementation (in hours)
+         &      - (nyear  - 1) * rjjhh * zyydd             !  minus years since beginning of experiment (in hours)
+
+      ztimemax1 = ((5.*30.)+21.)* 24.                      ! 21th june     at 24h in hours
+      ztimemin1 = ztimemax1 + rjjhh * zyydd / 2            ! 21th december        in hours
+      ztimemax2 = ((6.*30.)+21.)* 24.                      ! 21th july     at 24h in hours
+      ztimemin2 = ztimemax2 - rjjhh * zyydd / 2            ! 21th january         in hours
+      !                                                    ! NB: rjjhh * zyydd / 4 = one seasonal cycle in hours
+
+      ! amplitudes
+      zemp_S    = 0.7       ! intensity of COS in the South
+      zemp_N    = 0.8       ! intensity of COS in the North
+      zemp_sais = 0.1
+      zTstar    = 28.3      ! intemsity from 28.3 a -5 deg
+
+      ! 1/2 period between 21th June and 21th December and between 21th July and 21th January
+      zcos_sais1 = COS( (ztime - ztimemax1) / (ztimemin1 - ztimemax1) * rpi ) 
+      zcos_sais2 = COS( (ztime - ztimemax2) / (ztimemax2 - ztimemin2) * rpi )
+
+      ztrp= - 40.e0        ! retroaction term on heat fluxes (W/m2/K)
+      zconv = 3.16e-5      ! convertion factor: 1 m/yr => 3.16e-5 mm/s
+      DO jj = 1, jpj
+         DO ji = 1, jpi
+            ! domain from 15 deg to 50 deg between 27 and 28  degC at 15N, -3
+            ! and 13 degC at 50N 53.5 + or - 11 = 1/4 period :
+            ! 64.5 in summer, 42.5 in winter
+            t_star = zTstar * ( 1. + 1. / 50. * zcos_sais2 )                &
+               &                    * COS( rpi * (gphit(ji,jj) - 5.)               &
+               &                    / ( 53.5 * ( 1 + 11 / 53.5 * zcos_sais2 ) * 2.) )
+            ! 23.5 deg : tropics
+            qsr (ji,jj) =  230 * COS( 3.1415 * ( gphit(ji,jj) - 23.5 * zcos_sais1 ) / ( 0.9 * 180 ) )
+            qns (ji,jj) = ztrp * ( tsb(ji,jj,1,jp_tem) - t_star ) - qsr(ji,jj)
+            IF( gphit(ji,jj) >= 14.845 .AND. 37.2 >= gphit(ji,jj) ) THEN    ! zero at 37.8 deg, max at 24.6 deg
+               emp  (ji,jj) =   zemp_S * zconv   &
+                  &         * SIN( rpi / 2 * (gphit(ji,jj) - 37.2) / (24.6 - 37.2) )  &
+                  &         * ( 1 - zemp_sais / zemp_S * zcos_sais1)
+            ELSE
+               emp (ji,jj) =  - zemp_N * zconv   &
+                  &         * SIN( rpi / 2 * (gphit(ji,jj) - 37.2) / (46.8 - 37.2) )  &
+                  &         * ( 1 - zemp_sais / zemp_N * zcos_sais1 )
+            ENDIF
+         END DO
+      END DO
+
+      zsumemp = GLOB_SUM( emp  (:,:)   ) 
+      zsurf   = GLOB_SUM( tmask(:,:,1) ) 
+      zsumemp = zsumemp / zsurf         ! Default GYRE configuration
+
+      ! freshwater (mass flux) and update of qns with heat content of emp
+      emp (:,:) = emp(:,:) - zsumemp * tmask(:,:,1)        ! freshwater flux (=0 in domain average)
+      sfx (:,:) = 0.0_wp                                   ! no salt flux
+      qns (:,:) = qns(:,:) - emp(:,:) * sst_m(:,:) * rcp   ! evap and precip are at SST
+
+
+      ! ---------------------------- !
+      !       momentum fluxes        !
+      ! ---------------------------- !
+      ! same wind as in Wico
+      !test date0 : ndate0 = 010203
+      zyear0  =   ndate0 / 10000
+      zmonth0 = ( ndate0 - zyear0 * 10000 ) / 100
+      zday0   =   ndate0 - zyear0 * 10000 - zmonth0 * 100
+      !Calculates nday_year, day since january 1st
+      zday_year0 = (zmonth0-1)*30.+zday0
+
+      !accumulates days of previous months of this year
+      ! day (in hours) since january the 1st
+      ztime = FLOAT( kt ) * rdt / (rmmss * rhhmm)  &  ! incrementation in hour
+         &     - (nyear - 1) * rjjhh * zyydd          !  - nber of hours the precedent years
+      ztimemax = ((5.*30.)+21.)* 24.               ! 21th june     in hours
+      ztimemin = ztimemax + rjjhh * zyydd / 2      ! 21th december in hours
+      !                                            ! NB: rjjhh * zyydd / 4 = 1 seasonal cycle in hours
+
+      ! mean intensity at 0.105 ; srqt(2) because projected with 45deg angle
+      ztau = 0.105 / SQRT( 2. )
+      ! seasonal oscillation intensity
+      ztau_sais = 0.015
+      ztaun = ztau - ztau_sais * COS( (ztime - ztimemax) / (ztimemin - ztimemax) * rpi )
+      DO jj = 1, jpj
+         DO ji = 1, jpi
+           ! domain from 15deg to 50deg and 1/2 period along 14deg
+           ! so 5/4 of half period with seasonal cycle
+           utau(ji,jj) = - ztaun * SIN( rpi * (gphiu(ji,jj) - 15.) / (29.-15.) )
+           vtau(ji,jj) =   ztaun * SIN( rpi * (gphiv(ji,jj) - 15.) / (29.-15.) )
+         END DO
+      END DO
+
+      ! module of wind stress and wind speed at T-point
+      zcoef = 1. / ( zrhoa * zcdrag ) 
+      DO jj = 2, jpjm1
+         DO ji = fs_2, fs_jpim1   ! vect. opt.
+            ztx = utau(ji-1,jj  ) + utau(ji,jj) 
+            zty = vtau(ji  ,jj-1) + vtau(ji,jj) 
+            zmod = 0.5 * SQRT( ztx * ztx + zty * zty )
+            taum(ji,jj) = zmod
+            wndm(ji,jj) = SQRT( zmod * zcoef )
+         END DO
+      END DO
+      CALL lbc_lnk_multi( taum(:,:), 'T', 1. , wndm(:,:), 'T', 1. )
+
+      ! ---------------------------------- !
+      !  control print at first time-step  !
+      ! ---------------------------------- !
+      IF( kt == nit000 .AND. lwp ) THEN 
+         WRITE(numout,*)
+         WRITE(numout,*)'usrdef_sbc_oce : analytical surface fluxes for GYRE configuration'               
+         WRITE(numout,*)'~~~~~~~~~~~ ' 
+         WRITE(numout,*)'           nyear      = ', nyear
+         WRITE(numout,*)'           nmonth     = ', nmonth
+         WRITE(numout,*)'           nday       = ', nday
+         WRITE(numout,*)'           nday_year  = ', nday_year
+         WRITE(numout,*)'           ztime      = ', ztime
+         WRITE(numout,*)'           ztimemax   = ', ztimemax
+         WRITE(numout,*)'           ztimemin   = ', ztimemin
+         WRITE(numout,*)'           ztimemax1  = ', ztimemax1
+         WRITE(numout,*)'           ztimemin1  = ', ztimemin1
+         WRITE(numout,*)'           ztimemax2  = ', ztimemax2
+         WRITE(numout,*)'           ztimemin2  = ', ztimemin2
+         WRITE(numout,*)'           zyear0     = ', zyear0
+         WRITE(numout,*)'           zmonth0    = ', zmonth0
+         WRITE(numout,*)'           zday0      = ', zday0
+         WRITE(numout,*)'           zday_year0 = ', zday_year0
+         WRITE(numout,*)'           zyydd      = ', zyydd
+         WRITE(numout,*)'           zemp_S     = ', zemp_S
+         WRITE(numout,*)'           zemp_N     = ', zemp_N
+         WRITE(numout,*)'           zemp_sais  = ', zemp_sais
+         WRITE(numout,*)'           zTstar     = ', zTstar
+         WRITE(numout,*)'           zsumemp    = ', zsumemp
+         WRITE(numout,*)'           zsurf      = ', zsurf
+         WRITE(numout,*)'           ztrp       = ', ztrp
+         WRITE(numout,*)'           zconv      = ', zconv
+         WRITE(numout,*)'           ndastp     = ', ndastp
+         WRITE(numout,*)'           adatrj     = ', adatrj
+      ENDIF
+      !
+   END SUBROUTINE usrdef_sbc_oce
+
+
+   SUBROUTINE usrdef_sbc_ice_tau( kt )
+      INTEGER, INTENT(in) ::   kt   ! ocean time step
+   END SUBROUTINE usrdef_sbc_ice_tau
+
+
+   SUBROUTINE usrdef_sbc_ice_flx( kt, phs, phi )
+      INTEGER, INTENT(in) ::   kt   ! ocean time step
+      REAL(wp), DIMENSION(:,:,:), INTENT(in)  ::   phs    ! snow thickness
+      REAL(wp), DIMENSION(:,:,:), INTENT(in)  ::   phi    ! ice thickness
+   END SUBROUTINE usrdef_sbc_ice_flx
+
+   !!======================================================================
+END MODULE usrdef_sbc
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/USR/usrdef_zgr.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/USR/usrdef_zgr.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/USR/usrdef_zgr.F90	(revision 9570)
@@ -0,0 +1,248 @@
+MODULE usrdef_zgr
+   !!======================================================================
+   !!                       ***  MODULE  usrdef_zgr  ***
+   !!
+   !!                       ===  GYRE configuration  ===
+   !!
+   !! User defined : vertical coordinate system of a user configuration
+   !!======================================================================
+   !! History :  4.0  ! 2016-06  (G. Madec)  Original code
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   usr_def_zgr   : user defined vertical coordinate system
+   !!      zgr_z      : reference 1D z-coordinate 
+   !!      zgr_top_bot: ocean top and bottom level indices
+   !!      zgr_zco    : 3D verticl coordinate in pure z-coordinate case
+   !!---------------------------------------------------------------------
+   USE oce            ! ocean variables
+   USE dom_oce        ! ocean domain
+   USE depth_e3       ! depth <=> e3
+   !
+   USE in_out_manager ! I/O manager
+   USE lbclnk         ! ocean lateral boundary conditions (or mpp link)
+   USE lib_mpp        ! distributed memory computing library
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   usr_def_zgr        ! called by domzgr.F90
+
+   !! * Substitutions
+#  include "vectopt_loop_substitute.h90"
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 4.0 , NEMO Consortium (2016)
+   !! $Id:$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS             
+
+   SUBROUTINE usr_def_zgr( ld_zco  , ld_zps  , ld_sco  , ld_isfcav,    &   ! type of vertical coordinate
+      &                    pdept_1d, pdepw_1d, pe3t_1d , pe3w_1d  ,    &   ! 1D reference vertical coordinate
+      &                    pdept , pdepw ,                             &   ! 3D t & w-points depth
+      &                    pe3t  , pe3u  , pe3v   , pe3f ,             &   ! vertical scale factors
+      &                    pe3w  , pe3uw , pe3vw         ,             &   !     -      -      -
+      &                    k_top  , k_bot    )                             ! top & bottom ocean level
+      !!---------------------------------------------------------------------
+      !!              ***  ROUTINE usr_def_zgr  ***
+      !!
+      !! ** Purpose :   User defined the vertical coordinates
+      !!
+      !!----------------------------------------------------------------------
+      LOGICAL                   , INTENT(out) ::   ld_zco, ld_zps, ld_sco      ! vertical coordinate flags
+      LOGICAL                   , INTENT(out) ::   ld_isfcav                   ! under iceshelf cavity flag
+      REAL(wp), DIMENSION(:)    , INTENT(out) ::   pdept_1d, pdepw_1d          ! 1D grid-point depth     [m]
+      REAL(wp), DIMENSION(:)    , INTENT(out) ::   pe3t_1d , pe3w_1d           ! 1D grid-point depth     [m]
+      REAL(wp), DIMENSION(:,:,:), INTENT(out) ::   pdept, pdepw                ! grid-point depth        [m]
+      REAL(wp), DIMENSION(:,:,:), INTENT(out) ::   pe3t , pe3u , pe3v , pe3f   ! vertical scale factors  [m]
+      REAL(wp), DIMENSION(:,:,:), INTENT(out) ::   pe3w , pe3uw, pe3vw         ! i-scale factors 
+      INTEGER , DIMENSION(:,:)  , INTENT(out) ::   k_top, k_bot                ! first & last ocean level
+      !
+      INTEGER  ::   inum   ! local logical unit
+      REAL(WP) ::   z_zco, z_zps, z_sco, z_cav
+      REAL(wp), DIMENSION(jpi,jpj) ::   z2d   ! 2D workspace
+      !!----------------------------------------------------------------------
+      !
+      IF(lwp) WRITE(numout,*)
+      IF(lwp) WRITE(numout,*) 'usr_def_zgr : GYRE configuration (z-coordinate closed flat box ocean without cavities)'
+      IF(lwp) WRITE(numout,*) '~~~~~~~~~~~'
+      !
+      !
+      ! type of vertical coordinate
+      ! ---------------------------
+      ld_zco    = .TRUE.         ! GYRE case:  z-coordinate without ocean cavities
+      ld_zps    = .FALSE.
+      ld_sco    = .FALSE.
+      ld_isfcav = .FALSE.
+      !
+      !
+      ! Build the vertical coordinate system
+      ! ------------------------------------
+      CALL zgr_z( pdept_1d, pdepw_1d, pe3t_1d , pe3w_1d )   ! Reference z-coordinate system
+      !
+      CALL zgr_msk_top_bot( k_top , k_bot )                 ! masked top and bottom ocean t-level indices
+      !
+      !                                                     ! z-coordinate (3D arrays) from the 1D z-coord.
+      CALL zgr_zco( pdept_1d, pdepw_1d, pe3t_1d, pe3w_1d,   &   ! in  : 1D reference vertical coordinate
+         &          pdept   , pdepw   ,                     &   ! out : 3D t & w-points depth
+         &          pe3t    , pe3u    , pe3v   , pe3f   ,   &   !       vertical scale factors
+         &          pe3w    , pe3uw   , pe3vw             )     !           -      -      -
+      !
+   END SUBROUTINE usr_def_zgr
+
+
+   SUBROUTINE zgr_z( pdept_1d, pdepw_1d, pe3t_1d , pe3w_1d )   ! 1D reference vertical coordinate
+      !!----------------------------------------------------------------------
+      !!                   ***  ROUTINE zgr_z  ***
+      !!
+      !! ** Purpose :   set the 1D depth of model levels and the resulting 
+      !!              vertical scale factors.
+      !!
+      !! ** Method  :   1D z-coordinate system (use in all type of coordinate)
+      !!       The depth of model levels is set from dep(k), an analytical function:
+      !!                   w-level: depw_1d  = dep(k)
+      !!                   t-level: dept_1d  = dep(k+0.5)
+      !!       The scale factors are the discrete derivative of the depth:
+      !!                   e3w_1d(jk) = dk[ dept_1d ] 
+      !!                   e3t_1d(jk) = dk[ depw_1d ]
+      !!           with at top and bottom :
+      !!                   e3w_1d( 1 ) = 2 * ( dept_1d( 1 ) - depw_1d( 1 ) )
+      !!                   e3t_1d(jpk) = 2 * ( dept_1d(jpk) - depw_1d(jpk) )
+      !!       The depth are then re-computed from the sum of e3. This ensures 
+      !!    that depths are identical when reading domain configuration file. 
+      !!    Indeed, only e3. are saved in this file, depth are compute by a call
+      !!    to the e3_to_depth subroutine.
+      !!
+      !!       Here the Madec & Imbard (1996) function is used.
+      !!
+      !! ** Action  : - pdept_1d, pdepw_1d : depth of T- and W-point (m)
+      !!              - pe3t_1d , pe3w_1d  : scale factors at T- and W-levels (m)
+      !!
+      !! Reference : Marti, Madec & Delecluse, 1992, JGR, 97, No8, 12,763-12,766.
+      !!             Madec and Imbard, 1996, Clim. Dyn.
+      !!----------------------------------------------------------------------
+      REAL(wp), DIMENSION(:)    , INTENT(out) ::   pdept_1d, pdepw_1d   ! 1D grid-point depth        [m]
+      REAL(wp), DIMENSION(:)    , INTENT(out) ::   pe3t_1d , pe3w_1d    ! 1D vertical scale factors  [m]
+      !
+      INTEGER  ::   jk       ! dummy loop indices
+      REAL(wp) ::   zt, zw   ! local scalars
+      REAL(wp) ::   zsur, za0, za1, zkth, zacr   ! Values for the Madec & Imbard (1996) function  
+      !!----------------------------------------------------------------------
+      !
+      ! Set parameters of z(k) function
+      ! -------------------------------
+      zsur = -2033.194295283385_wp       
+      za0  =   155.8325369664153_wp 
+      za1  =   146.3615918601890_wp
+      zkth =    17.28520372419791_wp   
+      zacr =     5.0_wp       
+      !
+      IF(lwp) THEN            ! Parameter print
+         WRITE(numout,*)
+         WRITE(numout,*) '    zgr_z   : Reference vertical z-coordinates '
+         WRITE(numout,*) '    ~~~~~~~'
+         WRITE(numout,*) '       GYRE case : MI96 function with the following coefficients :'
+         WRITE(numout,*) '                 zsur = ', zsur
+         WRITE(numout,*) '                 za0  = ', za0
+         WRITE(numout,*) '                 za1  = ', za1
+         WRITE(numout,*) '                 zkth = ', zkth
+         WRITE(numout,*) '                 zacr = ', zacr
+      ENDIF
+
+      !
+      ! 1D Reference z-coordinate    (using Madec & Imbard 1996 function)
+      ! -------------------------
+      !
+      DO jk = 1, jpk          ! depth at T and W-points
+         zw = REAL( jk , wp )
+         zt = REAL( jk , wp ) + 0.5_wp
+         pdepw_1d(jk) = ( zsur + za0 * zw + za1 * zacr *  LOG( COSH( (zw-zkth) / zacr ) )  )
+         pdept_1d(jk) = ( zsur + za0 * zt + za1 * zacr *  LOG( COSH( (zt-zkth) / zacr ) )  )
+      END DO
+      !
+      !                       ! e3t and e3w from depth
+      CALL depth_to_e3( pdept_1d, pdepw_1d, pe3t_1d, pe3w_1d ) 
+      !
+      !                       ! recompute depths from SUM(e3)  <== needed
+      CALL e3_to_depth( pe3t_1d, pe3w_1d, pdept_1d, pdepw_1d ) 
+      !
+      IF(lwp) THEN                        ! control print
+         WRITE(numout,*)
+         WRITE(numout,*) '              Reference 1D z-coordinate depth and scale factors:'
+         WRITE(numout, "(9x,' level  gdept_1d  gdepw_1d  e3t_1d   e3w_1d  ')" )
+         WRITE(numout, "(10x, i4, 4f9.2)" ) ( jk, pdept_1d(jk), pdepw_1d(jk), pe3t_1d(jk), pe3w_1d(jk), jk = 1, jpk )
+      ENDIF
+      !
+   END SUBROUTINE zgr_z
+
+
+   SUBROUTINE zgr_msk_top_bot( k_top , k_bot )
+      !!----------------------------------------------------------------------
+      !!                    ***  ROUTINE zgr_msk_top_bot  ***
+      !!
+      !! ** Purpose :   set the masked top and bottom ocean t-levels
+      !!
+      !! ** Method  :   GYRE case = closed flat box ocean without ocean cavities
+      !!                   k_top = 1     except along north, south, east and west boundaries
+      !!                   k_bot = jpk-1 except along north, south, east and west boundaries
+      !!
+      !! ** Action  : - k_top : first wet ocean level index
+      !!              - k_bot : last  wet ocean level index
+      !!----------------------------------------------------------------------
+      INTEGER , DIMENSION(:,:), INTENT(out) ::   k_top , k_bot   ! first & last wet ocean level
+      !
+      REAL(wp), DIMENSION(jpi,jpj) ::   z2d   ! 2D local workspace
+      !!----------------------------------------------------------------------
+      !
+      IF(lwp) WRITE(numout,*)
+      IF(lwp) WRITE(numout,*) '    zgr_top_bot : defines the top and bottom wet ocean levels.'
+      IF(lwp) WRITE(numout,*) '    ~~~~~~~~~~~'
+      IF(lwp) WRITE(numout,*) '       GYRE case : closed flat box ocean without ocean cavities'
+      !
+      z2d(:,:) = REAL( jpkm1 , wp )          ! flat bottom
+      !
+      CALL lbc_lnk( z2d, 'T', 1. )           ! set surrounding land to zero (here jperio=0 ==>> closed)
+      !
+      k_bot(:,:) = INT( z2d(:,:) )           ! =jpkm1 over the ocean point, =0 elsewhere
+      !
+      k_top(:,:) = MIN( 1 , k_bot(:,:) )     ! = 1    over the ocean point, =0 elsewhere
+      !
+   END SUBROUTINE zgr_msk_top_bot
+   
+
+   SUBROUTINE zgr_zco( pdept_1d, pdepw_1d, pe3t_1d, pe3w_1d,   &   ! in : 1D reference vertical coordinate
+      &                pdept   , pdepw   ,                     &   ! out: 3D t & w-points depth
+      &                pe3t    , pe3u    , pe3v   , pe3f   ,   &   !      vertical scale factors
+      &                pe3w    , pe3uw   , pe3vw             )     !          -      -      -
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE zgr_zco  ***
+      !!
+      !! ** Purpose :   define the reference z-coordinate system
+      !!
+      !! ** Method  :   set 3D coord. arrays to reference 1D array 
+      !!----------------------------------------------------------------------
+      REAL(wp), DIMENSION(:)    , INTENT(in   ) ::   pdept_1d, pdepw_1d          ! 1D grid-point depth       [m]
+      REAL(wp), DIMENSION(:)    , INTENT(in   ) ::   pe3t_1d , pe3w_1d           ! 1D vertical scale factors [m]
+      REAL(wp), DIMENSION(:,:,:), INTENT(  out) ::   pdept, pdepw                ! grid-point depth          [m]
+      REAL(wp), DIMENSION(:,:,:), INTENT(  out) ::   pe3t , pe3u , pe3v , pe3f   ! vertical scale factors    [m]
+      REAL(wp), DIMENSION(:,:,:), INTENT(  out) ::   pe3w , pe3uw, pe3vw         !    -       -      -
+      !
+      INTEGER  ::   jk
+      !!----------------------------------------------------------------------
+      !
+      DO jk = 1, jpk
+         pdept(:,:,jk) = pdept_1d(jk)
+         pdepw(:,:,jk) = pdepw_1d(jk)
+         pe3t (:,:,jk) = pe3t_1d (jk)
+         pe3u (:,:,jk) = pe3t_1d (jk)
+         pe3v (:,:,jk) = pe3t_1d (jk)
+         pe3f (:,:,jk) = pe3t_1d (jk)
+         pe3w (:,:,jk) = pe3w_1d (jk)
+         pe3uw(:,:,jk) = pe3w_1d (jk)
+         pe3vw(:,:,jk) = pe3w_1d (jk)
+      END DO
+      !
+   END SUBROUTINE zgr_zco
+
+   !!======================================================================
+END MODULE usrdef_zgr
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/ZDF/zdf_oce.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/ZDF/zdf_oce.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/ZDF/zdf_oce.F90	(revision 9570)
@@ -0,0 +1,74 @@
+MODULE zdf_oce
+   !!======================================================================
+   !!              ***  MODULE  zdf_oce  ***
+   !! Ocean physics : define vertical mixing variables
+   !!=====================================================================
+   !! history :  1.0  !  2002-06  (G. Madec)  Original code
+   !!            3.2  !  2009-07  (G. Madec)  addition of avm
+   !!            4.0  !  2017-05  (G. Madec)  avm and drag coef. defined at t-point
+   !!----------------------------------------------------------------------
+   USE par_oce        ! ocean parameters
+   USE in_out_manager ! I/O manager
+   USE lib_mpp        ! MPP library
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC  zdf_oce_alloc    ! Called in nemogcm.F90
+
+   !                            !!* namelist namzdf: vertical physics *
+   !                             ! vertical closure scheme flags
+   LOGICAL , PUBLIC ::   ln_zdfcst   !: constant coefficients
+   LOGICAL , PUBLIC ::   ln_zdfric   !: Richardson depend coefficients
+   LOGICAL , PUBLIC ::   ln_zdftke   !: Turbulent Kinetic Energy closure
+   LOGICAL , PUBLIC ::   ln_zdfgls   !: Generic Length Scale closure
+   LOGICAL , PUBLIC ::   ln_zdfosm   !: OSMOSIS BL closure
+   !                             ! convection
+   LOGICAL , PUBLIC ::   ln_zdfevd   !: convection: enhanced vertical diffusion flag
+   INTEGER , PUBLIC ::      nn_evdm     !: =0/1 flag to apply enhanced avm or not
+   REAL(wp), PUBLIC ::      rn_evd      !: vertical eddy coeff. for enhanced vert. diff. (m2/s)
+   LOGICAL , PUBLIC ::   ln_zdfnpc   !: convection: non-penetrative convection flag
+   INTEGER , PUBLIC ::      nn_npc      !: non penetrative convective scheme call  frequency
+   INTEGER , PUBLIC ::      nn_npcp     !: non penetrative convective scheme print frequency
+   !                             ! double diffusion
+   LOGICAL , PUBLIC ::   ln_zdfddm   !: double diffusive mixing flag
+   REAL(wp), PUBLIC ::      rn_avts     !: maximum value of avs for salt fingering
+   REAL(wp), PUBLIC ::      rn_hsbfr    !: heat/salt buoyancy flux ratio
+   !                             ! gravity wave-induced vertical mixing
+   LOGICAL , PUBLIC ::   ln_zdfswm   !: surface  wave-induced mixing flag
+   LOGICAL , PUBLIC ::   ln_zdfiwm   !: internal wave-induced mixing flag
+   !                             ! coefficients 
+   REAL(wp), PUBLIC ::   rn_avm0     !: vertical eddy viscosity (m2/s)
+   REAL(wp), PUBLIC ::   rn_avt0     !: vertical eddy diffusivity (m2/s)
+   INTEGER , PUBLIC ::   nn_avb      !: constant or profile background on avt (=0/1)
+   INTEGER , PUBLIC ::   nn_havtb    !: horizontal shape or not for avtb (=0/1)   !                             ! convection
+
+
+   REAL(wp), PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:,:,:) ::   avm, avt, avs  !: vertical mixing coefficients (w-point) [m2/s]
+   REAL(wp), PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:,:,:) ::   avm_k , avt_k  !: Kz computed by turbulent closure alone [m2/s]
+   REAL(wp), PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:,:,:) ::   en             !: now turbulent kinetic energy          [m2/s2]
+   REAL(wp), PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:)     ::   avmb , avtb    !: background profile of avm and avt      [m2/s]
+   REAL(wp), PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:,:)   ::   avtb_2d        !: horizontal shape of background Kz profile [-]
+
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 4.0 , NEMO Consortium (2017)
+   !! $Id$ 
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   INTEGER FUNCTION zdf_oce_alloc()
+      !!----------------------------------------------------------------------
+      !!            *** FUNCTION zdf_oce_alloc ***
+      !!----------------------------------------------------------------------
+      !
+      ALLOCATE( avm (jpi,jpj,jpk) , avm_k(jpi,jpj,jpk) , avs(jpi,jpj,jpk) ,   &
+         &      avt (jpi,jpj,jpk) , avt_k(jpi,jpj,jpk) , en (jpi,jpj,jpk) ,   & 
+         &      avmb(jpk)         , avtb(jpk)          , avtb_2d(jpi,jpj) , STAT = zdf_oce_alloc )
+         !
+      IF( zdf_oce_alloc /= 0 )   CALL ctl_warn('zdf_oce_alloc: failed to allocate arrays')
+      !
+   END FUNCTION zdf_oce_alloc
+
+   !!======================================================================
+END MODULE zdf_oce
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/ZDF/zdfddm.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/ZDF/zdfddm.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/ZDF/zdfddm.F90	(revision 9570)
@@ -0,0 +1,172 @@
+MODULE zdfddm
+   !!======================================================================
+   !!                       ***  MODULE  zdfddm  ***
+   !! Ocean physics : double diffusion mixing parameterization
+   !!======================================================================
+   !! History :  OPA  ! 2000-08  (G. Madec)  double diffusive mixing
+   !!   NEMO     1.0  ! 2002-06  (G. Madec)  F90: Free form and module
+   !!            3.3  ! 2010-10  (C. Ethe, G. Madec) reorganisation of initialisation phase
+   !!            3.6  ! 2013-04  (G. Madec, F. Roquet) zrau compute locally using interpolation of alpha & beta
+   !!            4.0  !  2017-04  (G. Madec)  remove CPP ddm key & avm at t-point only 
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   zdf_ddm       : compute the Kz for salinity
+   !!----------------------------------------------------------------------
+   USE oce            ! ocean dynamics and tracers variables
+   USE dom_oce        ! ocean space and time domain variables
+   USE zdf_oce        ! ocean vertical physics variables
+   USE eosbn2         ! equation of state
+   !
+   USE in_out_manager ! I/O manager
+   USE lbclnk         ! ocean lateral boundary conditions (or mpp link)
+   USE prtctl         ! Print control
+   USE lib_mpp        ! MPP library
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   zdf_ddm       ! called by step.F90
+
+   !! * Substitutions
+#  include "vectopt_loop_substitute.h90"
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.7 , NEMO Consortium (2014)
+   !! $Id$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE zdf_ddm( kt, p_avm, p_avt, p_avs )
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE zdf_ddm  ***
+      !!                    
+      !! ** Purpose :   Add to the vertical eddy diffusivity coefficient the 
+      !!              effect of salt fingering and diffusive convection. 
+      !!
+      !! ** Method  :   Diapycnal mixing is increased in case of double
+      !!      diffusive mixing (i.e. salt fingering and diffusive layering)
+      !!      following Merryfield et al. (1999). The rate of double diffusive 
+      !!      mixing depend on the buoyancy ratio (R=alpha/beta dk[T]/dk[S]):
+      !!         * salt fingering (Schmitt 1981):
+      !!      for R > 1 and rn2 > 0 : zavfs = rn_avts / ( 1 + (R/rn_hsbfr)^6 )
+      !!      for R > 1 and rn2 > 0 : zavfs = O
+      !!      otherwise                : zavft = 0.7 zavs / R
+      !!         * diffusive layering (Federov 1988):
+      !!      for 0< R < 1 and N^2 > 0 : zavdt = 1.3635e-6 * exp( 4.6 exp(-0.54 (1/R-1) ) )
+      !!      otherwise                   : zavdt = 0 
+      !!      for .5 < R < 1 and N^2 > 0 : zavds = zavdt (1.885 R -0.85)
+      !!      for  0 < R <.5 and N^2 > 0 : zavds = zavdt 0.15 R      
+      !!      otherwise                     : zavds = 0 
+      !!         * update the eddy diffusivity:
+      !!      avt = avt + zavft + zavdt
+      !!      avs = avs + zavfs + zavds
+      !!      avm is required to remain at least above avt and avs.
+      !!      
+      !! ** Action  :   avt, avs : updated vertical eddy diffusivity coef. for T & S
+      !!
+      !! References :   Merryfield et al., JPO, 29, 1124-1142, 1999.
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT(in   ) ::   kt       ! ocean time-step indexocean time step
+      REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   p_avm   !  Kz on momentum    (w-points)
+      REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   p_avt   !  Kz on temperature (w-points)
+      REAL(wp), DIMENSION(:,:,:), INTENT(  out) ::   p_avs   !  Kz on salinity    (w-points)
+      !
+      INTEGER  ::   ji, jj , jk     ! dummy loop indices
+      REAL(wp) ::   zaw, zbw, zrw   ! local scalars
+      REAL(wp) ::   zdt, zds
+      REAL(wp) ::   zinr, zrr       !   -      -
+      REAL(wp) ::   zavft, zavfs    !   -      -
+      REAL(wp) ::   zavdt, zavds    !   -      -
+      REAL(wp), DIMENSION(jpi,jpj) ::   zrau, zmsks, zmskf, zmskd1, zmskd2, zmskd3
+      !!----------------------------------------------------------------------
+      !
+      !                                                ! ===============
+      DO jk = 2, jpkm1                                 ! Horizontal slab
+         !                                             ! ===============
+         ! Define the mask 
+         ! ---------------
+!!gm  WORK to be done:   change the code from vector optimisation to scalar one.
+!!gm                     ==>>>  test in the loop instead of use of mask arrays
+!!gm                            and many acces in memory
+         
+         DO jj = 1, jpj                !==  R=zrau = (alpha / beta) (dk[t] / dk[s])  ==!
+            DO ji = 1, jpi
+               zrw =   ( gdepw_n(ji,jj,jk  ) - gdept_n(ji,jj,jk) )   &
+!!gm please, use e3w_n below 
+                  &  / ( gdept_n(ji,jj,jk-1) - gdept_n(ji,jj,jk) ) 
+               !
+               zaw = (  rab_n(ji,jj,jk,jp_tem) * (1. - zrw) + rab_n(ji,jj,jk-1,jp_tem) * zrw  )  &
+                   &    * tmask(ji,jj,jk) * tmask(ji,jj,jk-1)
+               zbw = (  rab_n(ji,jj,jk,jp_sal) * (1. - zrw) + rab_n(ji,jj,jk-1,jp_sal) * zrw  )  &
+                   &    * tmask(ji,jj,jk) * tmask(ji,jj,jk-1)
+               !
+               zdt = zaw * ( tsn(ji,jj,jk-1,jp_tem) - tsn(ji,jj,jk,jp_tem) )
+               zds = zbw * ( tsn(ji,jj,jk-1,jp_sal) - tsn(ji,jj,jk,jp_sal) ) 
+               IF( ABS( zds) <= 1.e-20_wp )   zds = 1.e-20_wp
+               zrau(ji,jj) = MAX(  1.e-20, zdt / zds  )    ! only retains positive value of zrau
+            END DO
+         END DO
+
+         DO jj = 1, jpj                !==  indicators  ==!
+            DO ji = 1, jpi
+               ! stability indicator: msks=1 if rn2>0; 0 elsewhere
+               IF( rn2(ji,jj,jk) + 1.e-12  <= 0. ) THEN   ;   zmsks(ji,jj) = 0._wp
+               ELSE                                       ;   zmsks(ji,jj) = 1._wp
+               ENDIF
+               ! salt fingering indicator: msksf=1 if R>1; 0 elsewhere            
+               IF( zrau(ji,jj) <= 1.             ) THEN   ;   zmskf(ji,jj) = 0._wp
+               ELSE                                       ;   zmskf(ji,jj) = 1._wp
+               ENDIF
+               ! diffusive layering indicators: 
+               !     ! mskdl1=1 if 0< R <1; 0 elsewhere
+               IF( zrau(ji,jj) >= 1.             ) THEN   ;   zmskd1(ji,jj) = 0._wp
+               ELSE                                       ;   zmskd1(ji,jj) = 1._wp
+               ENDIF
+               !     ! mskdl2=1 if 0< R <0.5; 0 elsewhere
+               IF( zrau(ji,jj) >= 0.5            ) THEN   ;   zmskd2(ji,jj) = 0._wp
+               ELSE                                       ;   zmskd2(ji,jj) = 1._wp
+               ENDIF
+               !   mskdl3=1 if 0.5< R <1; 0 elsewhere
+               IF( zrau(ji,jj) <= 0.5 .OR. zrau(ji,jj) >= 1. ) THEN   ;   zmskd3(ji,jj) = 0._wp
+               ELSE                                                   ;   zmskd3(ji,jj) = 1._wp
+               ENDIF
+            END DO
+         END DO
+         ! mask zmsk in order to have avt and avs masked
+         zmsks(:,:) = zmsks(:,:) * wmask(:,:,jk)
+
+
+         ! Update avt and avs
+         ! ------------------
+         ! Constant eddy coefficient: reset to the background value
+         DO jj = 1, jpj
+            DO ji = 1, jpi
+               zinr = 1._wp / zrau(ji,jj)
+               ! salt fingering
+               zrr = zrau(ji,jj) / rn_hsbfr
+               zrr = zrr * zrr
+               zavfs = rn_avts / ( 1 + zrr*zrr*zrr ) * zmsks(ji,jj) * zmskf(ji,jj)
+               zavft = 0.7 * zavfs * zinr
+               ! diffusive layering
+               zavdt = 1.3635e-6 * EXP(  4.6 * EXP( -0.54*(zinr-1.) )  ) * zmsks(ji,jj) * zmskd1(ji,jj)
+               zavds = zavdt * zmsks(ji,jj) * (  ( 1.85 * zrau(ji,jj) - 0.85 ) * zmskd3(ji,jj)   &
+                  &                             +  0.15 * zrau(ji,jj)          * zmskd2(ji,jj)  )
+               ! add to the eddy viscosity coef. previously computed
+               p_avs(ji,jj,jk) = p_avt(ji,jj,jk) + zavfs + zavds
+               p_avt(ji,jj,jk) = p_avt(ji,jj,jk) + zavft + zavdt
+               p_avm(ji,jj,jk) = p_avm(ji,jj,jk) + MAX( zavft + zavdt, zavfs + zavds )
+            END DO
+         END DO
+         !                                                ! ===============
+      END DO                                              !   End of slab
+      !                                                   ! ===============
+      !
+      IF(ln_ctl) THEN
+         CALL prt_ctl(tab3d_1=avt , clinfo1=' ddm  - t: ', tab3d_2=avs , clinfo2=' s: ', kdim=jpk)
+      ENDIF
+      !
+   END SUBROUTINE zdf_ddm
+   
+   !!======================================================================
+END MODULE zdfddm
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/ZDF/zdfdrg.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/ZDF/zdfdrg.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/ZDF/zdfdrg.F90	(revision 9570)
@@ -0,0 +1,457 @@
+MODULE zdfdrg
+   !!======================================================================
+   !!                       ***  MODULE  zdfdrg  ***
+   !! Ocean physics: top and/or Bottom friction 
+   !!======================================================================
+   !! History :  OPA  ! 1997-06  (G. Madec, A.-M. Treguier)  Original code
+   !!   NEMO     1.0  ! 2002-06  (G. Madec)  F90: Free form and module
+   !!            3.2  ! 2009-09  (A.C.Coward)  Correction to include barotropic contribution
+   !!            3.3  ! 2010-10  (C. Ethe, G. Madec) reorganisation of initialisation phase
+   !!            3.4  ! 2011-11  (H. Liu) implementation of semi-implicit bottom friction option
+   !!                 ! 2012-06  (H. Liu) implementation of Log Layer bottom friction option
+   !!            4.0  ! 2017-05  (G. Madec) zdfbfr becomes zdfdrg + variable names change
+   !!                                     + drag defined at t-point + new user interface + top drag (ocean cavities)
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   zdf_drg       : update bottom friction coefficient (non-linear bottom friction only)
+   !!   zdf_drg_exp   : compute the top & bottom friction in explicit case
+   !!   zdf_drg_init  : read in namdrg namelist and control the bottom friction parameters.
+   !!       drg_init  :
+   !!----------------------------------------------------------------------
+   USE oce            ! ocean dynamics and tracers variables
+   USE phycst  , ONLY : vkarmn
+   USE dom_oce        ! ocean space and time domain variables
+   USE zdf_oce        ! ocean vertical physics variables
+   USE trd_oce        ! trends: ocean variables
+   USE trddyn         ! trend manager: dynamics
+   !
+   USE in_out_manager ! I/O manager
+   USE iom            ! I/O module
+   USE lbclnk         ! ocean lateral boundary conditions (or mpp link)
+   USE lib_mpp        ! distributed memory computing
+   USE prtctl         ! Print control
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   zdf_drg         ! called by zdf_phy
+   PUBLIC   zdf_drg_exp     ! called by dyn_zdf
+   PUBLIC   zdf_drg_init    ! called by zdf_phy_init
+
+   !                                 !!* Namelist namdrg: nature of drag coefficient namelist *
+   LOGICAL          ::   ln_OFF       ! free-slip       : Cd = 0
+   LOGICAL          ::   ln_lin       !     linear  drag: Cd = Cd0_lin
+   LOGICAL          ::   ln_non_lin   ! non-linear  drag: Cd = Cd0_nl |U|
+   LOGICAL          ::   ln_loglayer  ! logarithmic drag: Cd = vkarmn/log(z/z0)
+   LOGICAL , PUBLIC ::   ln_drgimp    ! implicit top/bottom friction flag
+
+   !                                 !!* Namelist namdrg_top & _bot: TOP or BOTTOM coefficient namelist *
+   REAL(wp)         ::   rn_Cd0       !: drag coefficient                                           [ - ]
+   REAL(wp)         ::   rn_Uc0       !: characteristic velocity (linear case: tau=rho*Cd0*Uc0*u)   [m/s]
+   REAL(wp)         ::   rn_Cdmax     !: drag value maximum (ln_loglayer=T)                         [ - ]
+   REAL(wp)         ::   rn_z0        !: roughness          (ln_loglayer=T)                         [ m ]
+   REAL(wp)         ::   rn_ke0       !: background kinetic energy (non-linear case)                [m2/s2]
+   LOGICAL          ::   ln_boost     !: =T regional boost of Cd0 ; =F Cd0 horizontally uniform
+   REAL(wp)         ::   rn_boost     !: local boost factor                                         [ - ]
+
+   REAL(wp), PUBLIC ::   r_Cdmin_top, r_Cdmax_top, r_z0_top, r_ke0_top   ! set from namdrg_top namelist values
+   REAL(wp), PUBLIC ::   r_Cdmin_bot, r_Cdmax_bot, r_z0_bot, r_ke0_bot   !  -    -  namdrg_bot    -       -
+
+   INTEGER ::              ndrg       ! choice of the type of drag coefficient
+   !                                  ! associated indices:
+   INTEGER, PARAMETER ::   np_OFF      = 0   ! free-slip: drag set to zero
+   INTEGER, PARAMETER ::   np_lin      = 1   !     linear drag: Cd = Cd0_lin
+   INTEGER, PARAMETER ::   np_non_lin  = 2   ! non-linear drag: Cd = Cd0_nl |U|
+   INTEGER, PARAMETER ::   np_loglayer = 3   ! non linear drag (logarithmic formulation): Cd = vkarmn/log(z/z0)
+
+   LOGICAL , PUBLIC ::   l_zdfdrg           !: flag to update at each time step the top/bottom Cd
+   LOGICAL          ::   l_log_not_linssh   !: flag to update at each time step the position ot the velocity point 
+   !
+   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), PUBLIC ::   rCd0_top, rCd0_bot   !: precomputed top/bottom drag coeff. at t-point (>0)
+   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), PUBLIC ::   rCdU_top, rCdU_bot   !: top/bottom drag coeff. at t-point (<0)  [m/s]
+
+   !! * Substitutions
+#  include "vectopt_loop_substitute.h90"
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 4.0 , NEMO Consortium (2011)
+   !! $Id: zdfdrg.F90 7753 2017-03-03 11:46:59Z gm $
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE zdf_drg( kt, k_mk, pCdmin, pCdmax, pz0, pke0, pCd0,   &   ! <<== in 
+      &                                                     pCdU )      ! ==>> out : bottom drag [m/s]
+      !!----------------------------------------------------------------------
+      !!                   ***  ROUTINE zdf_drg  ***
+      !!
+      !! ** Purpose :   update the top/bottom drag coefficient (non-linear case only)
+      !!
+      !! ** Method  :   In non linear friction case, the drag coeficient is
+      !!              a function of the velocity:
+      !!                          Cd = cd0 * |U+Ut|   
+      !!              where U is the top or bottom velocity and
+      !!                    Ut a tidal velocity (Ut^2 = Tidal kinetic energy 
+      !!                       assumed here here to be constant) 
+      !!              Depending on the input variable, the top- or bottom drag is compted
+      !!
+      !! ** Action  :   p_Cd   drag coefficient at t-point
+      !!----------------------------------------------------------------------
+      INTEGER                 , INTENT(in   ) ::   kt       ! ocean time-step index
+      !                       !               !!         !==  top or bottom variables  ==!
+      INTEGER , DIMENSION(:,:), INTENT(in   ) ::   k_mk     ! wet level (1st or last)
+      REAL(wp)                , INTENT(in   ) ::   pCdmin   ! min drag value
+      REAL(wp)                , INTENT(in   ) ::   pCdmax   ! max drag value
+      REAL(wp)                , INTENT(in   ) ::   pz0      ! roughness
+      REAL(wp)                , INTENT(in   ) ::   pke0     ! background tidal KE
+      REAL(wp), DIMENSION(:,:), INTENT(in   ) ::   pCd0     ! masked precomputed part of Cd0
+      REAL(wp), DIMENSION(:,:), INTENT(  out) ::   pCdU     ! = - Cd*|U|   (t-points) [m/s]
+      !!
+      INTEGER ::   ji, jj   ! dummy loop indices
+      INTEGER ::   imk      ! local integers
+      REAL(wp)::   zzz, zut, zvt, zcd   ! local scalars
+      !!----------------------------------------------------------------------
+      !
+      IF( l_log_not_linssh ) THEN     !==  "log layer"  ==!   compute Cd and -Cd*|U|
+         DO jj = 2, jpjm1
+            DO ji = 2, jpim1
+               imk = k_mk(ji,jj)          ! ocean bottom level at t-points
+               zut = un(ji,jj,imk) + un(ji-1,jj,imk)     ! 2 x velocity at t-point
+               zvt = vn(ji,jj,imk) + vn(ji,jj-1,imk)
+               zzz = 0.5_wp * e3t_n(ji,jj,imk)           ! altitude below/above (top/bottom) the boundary
+               !
+!!JC: possible WAD implementation should modify line below if layers vanish
+               zcd = (  vkarmn / LOG( zzz / pz0 )  )**2
+               zcd = pCd0(ji,jj) * MIN(  MAX( pCdmin , zcd ) , pCdmax  )   ! here pCd0 = mask*boost
+               pCdU(ji,jj) = - zcd * SQRT(  0.25 * ( zut*zut + zvt*zvt ) + pke0  )
+            END DO
+         END DO
+      ELSE                                            !==  standard Cd  ==!
+         DO jj = 2, jpjm1
+            DO ji = 2, jpim1
+               imk = k_mk(ji,jj)    ! ocean bottom level at t-points
+               zut = un(ji,jj,imk) + un(ji-1,jj,imk)     ! 2 x velocity at t-point
+               zvt = vn(ji,jj,imk) + vn(ji,jj-1,imk)
+               !                                                           ! here pCd0 = mask*boost * drag
+               pCdU(ji,jj) = - pCd0(ji,jj) * SQRT(  0.25 * ( zut*zut + zvt*zvt ) + pke0  )
+            END DO
+         END DO
+      ENDIF
+      !
+      IF(ln_ctl)   CALL prt_ctl( tab2d_1=pCdU, clinfo1=' Cd*U ')
+      !
+   END SUBROUTINE zdf_drg
+
+
+   SUBROUTINE zdf_drg_exp( kt, pub, pvb, pua, pva )
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE zdf_drg_exp  ***
+      !!
+      !! ** Purpose :   compute and add the explicit top and bottom frictions.
+      !!
+      !! ** Method  :   in explicit case, 
+      !!
+      !!              NB: in implicit case the calculation is performed in dynzdf.F90
+      !!
+      !! ** Action  :   (pua,pva)   momentum trend increased by top & bottom friction trend
+      !!---------------------------------------------------------------------
+      INTEGER                         , INTENT(in   ) ::   kt         ! ocean time-step index
+      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pub, pvb   ! the two components of the before velocity
+      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pua, pva   ! the two components of the velocity tendency
+      !! 
+      INTEGER  ::   ji, jj       ! dummy loop indexes
+      INTEGER  ::   ikbu, ikbv   ! local integers
+      REAL(wp) ::   zm1_2dt      ! local scalar
+      REAL(wp) ::   zCdu, zCdv   !   -      -
+      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::   ztrdu, ztrdv
+      !!---------------------------------------------------------------------
+      !
+!!gm bug : time step is only rdt (not 2 rdt if euler start !)
+      zm1_2dt = - 1._wp / ( 2._wp * rdt )
+
+      IF( l_trddyn ) THEN      ! trends: store the input trends
+         ALLOCATE( ztrdu(jpi,jpj,jpk) , ztrdv(jpi,jpj,jpk) )
+         ztrdu(:,:,:) = pua(:,:,:)
+         ztrdv(:,:,:) = pva(:,:,:)
+      ENDIF
+
+      DO jj = 2, jpjm1
+         DO ji = 2, jpim1
+            ikbu = mbku(ji,jj)          ! deepest wet ocean u- & v-levels
+            ikbv = mbkv(ji,jj)
+            !
+            ! Apply stability criteria on absolute value  : abs(bfr/e3) < 1/(2dt) => bfr/e3 > -1/(2dt)
+            zCdu = 0.5*( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) ) / e3u_n(ji,jj,ikbu)
+            zCdv = 0.5*( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) ) / e3v_n(ji,jj,ikbv)
+            !
+            pua(ji,jj,ikbu) = pua(ji,jj,ikbu) + MAX(  zCdu , zm1_2dt  ) * pub(ji,jj,ikbu)
+            pva(ji,jj,ikbv) = pva(ji,jj,ikbv) + MAX(  zCdv , zm1_2dt  ) * pvb(ji,jj,ikbv)
+         END DO
+      END DO
+      !
+      IF( ln_isfcav ) THEN        ! ocean cavities
+         DO jj = 2, jpjm1
+            DO ji = 2, jpim1
+               ikbu = miku(ji,jj)          ! first wet ocean u- & v-levels
+               ikbv = mikv(ji,jj)
+               !
+               ! Apply stability criteria on absolute value  : abs(bfr/e3) < 1/(2dt) => bfr/e3 > -1/(2dt)
+               zCdu = 0.5*( rCdU_top(ji+1,jj)+rCdU_top(ji,jj) ) / e3u_n(ji,jj,ikbu)    ! NB: Cdtop masked
+               zCdv = 0.5*( rCdU_top(ji,jj+1)+rCdU_top(ji,jj) ) / e3v_n(ji,jj,ikbv)
+               !
+               pua(ji,jj,ikbu) = pua(ji,jj,ikbu) + MAX(  zCdu , zm1_2dt  ) * pub(ji,jj,ikbu)
+               pva(ji,jj,ikbv) = pva(ji,jj,ikbv) + MAX(  zCdv , zm1_2dt  ) * pvb(ji,jj,ikbv)
+           END DO
+         END DO
+      ENDIF
+      !
+      IF( l_trddyn ) THEN      ! trends: send trends to trddyn for further diagnostics
+         ztrdu(:,:,:) = pua(:,:,:) - ztrdu(:,:,:)
+         ztrdv(:,:,:) = pva(:,:,:) - ztrdv(:,:,:)
+         CALL trd_dyn( ztrdu(:,:,:), ztrdv(:,:,:), jpdyn_bfr, kt )
+         DEALLOCATE( ztrdu, ztrdv )
+      ENDIF
+      !                                          ! print mean trends (used for debugging)
+      IF(ln_ctl)   CALL prt_ctl( tab3d_1=pua, clinfo1=' bfr  - Ua: ', mask1=umask,               &
+         &                       tab3d_2=pva, clinfo2=       ' Va: ', mask2=vmask, clinfo3='dyn' )
+      !
+   END SUBROUTINE zdf_drg_exp
+
+
+   SUBROUTINE zdf_drg_init
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE zdf_brg_init  ***
+      !!
+      !! ** Purpose :   Initialization of the bottom friction
+      !!
+      !! ** Method  :   Read the namdrg namelist and check their consistency
+      !!                called at the first timestep (nit000)
+      !!----------------------------------------------------------------------
+      INTEGER   ::   ji, jj      ! dummy loop indexes
+      INTEGER   ::   ios, ioptio   ! local integers
+      !!
+      NAMELIST/namdrg/ ln_OFF, ln_lin, ln_non_lin, ln_loglayer, ln_drgimp
+      !!----------------------------------------------------------------------
+      !
+      !                     !==  drag nature  ==!
+      !
+      REWIND( numnam_ref )                   ! Namelist namdrg in reference namelist
+      READ  ( numnam_ref, namdrg, IOSTAT = ios, ERR = 901)
+901   IF( ios /= 0 )   CALL ctl_nam( ios , 'namdrg in reference namelist', lwp )
+      REWIND( numnam_cfg )                   ! Namelist namdrg in configuration namelist
+      READ  ( numnam_cfg, namdrg, IOSTAT = ios, ERR = 902 )
+902   IF( ios >  0 )   CALL ctl_nam( ios , 'namdrg in configuration namelist', lwp )
+      IF(lwm) WRITE ( numond, namdrg )
+      !
+      IF(lwp) THEN
+         WRITE(numout,*)
+         WRITE(numout,*) 'zdf_drg_init : top and/or bottom drag setting'
+         WRITE(numout,*) '~~~~~~~~~~~~'
+         WRITE(numout,*) '   Namelist namdrg : top/bottom friction choices'
+         WRITE(numout,*) '      free-slip       : Cd = 0                  ln_OFF      = ', ln_OFF 
+         WRITE(numout,*) '      linear  drag    : Cd = Cd0                ln_lin      = ', ln_lin
+         WRITE(numout,*) '      non-linear  drag: Cd = Cd0_nl |U|         ln_non_lin  = ', ln_non_lin
+         WRITE(numout,*) '      logarithmic drag: Cd = vkarmn/log(z/z0)   ln_loglayer = ', ln_loglayer
+         WRITE(numout,*) '      implicit friction                         ln_drgimp   = ', ln_drgimp
+      ENDIF
+      !
+      ioptio = 0                       ! set ndrg and control check
+      IF( ln_OFF      ) THEN   ;   ndrg = np_OFF        ;   ioptio = ioptio + 1   ;   ENDIF
+      IF( ln_lin      ) THEN   ;   ndrg = np_lin        ;   ioptio = ioptio + 1   ;   ENDIF
+      IF( ln_non_lin  ) THEN   ;   ndrg = np_non_lin    ;   ioptio = ioptio + 1   ;   ENDIF
+      IF( ln_loglayer ) THEN   ;   ndrg = np_loglayer   ;   ioptio = ioptio + 1   ;   ENDIF
+      !
+      IF( ioptio /= 1 )   CALL ctl_stop( 'zdf_drg_init: Choose ONE type of drag coef in namdrg' )
+      !
+      !
+      !                     !==  BOTTOM drag setting  ==!   (applied at seafloor)
+      !
+      ALLOCATE( rCd0_bot(jpi,jpj), rCdU_bot(jpi,jpj) )
+      CALL drg_init( 'BOTTOM'   , mbkt       ,                                         &   ! <== in
+         &           r_Cdmin_bot, r_Cdmax_bot, r_z0_bot, r_ke0_bot, rCd0_bot, rCdU_bot )   ! ==> out
+
+      !
+      !                     !==  TOP drag setting  ==!   (applied at the top of ocean cavities)
+      !
+      IF( ln_isfcav ) THEN              ! Ocean cavities: top friction setting
+         ALLOCATE( rCd0_top(jpi,jpj), rCdU_top(jpi,jpj) )
+         CALL drg_init( 'TOP   '   , mikt       ,                                         &   ! <== in
+            &           r_Cdmin_top, r_Cdmax_top, r_z0_top, r_ke0_top, rCd0_top, rCdU_top )   ! ==> out
+      ENDIF
+      !
+   END SUBROUTINE zdf_drg_init
+
+
+   SUBROUTINE drg_init( cd_topbot, k_mk,  &
+      &                 pCdmin, pCdmax, pz0, pke0, pCd0, pCdU ) 
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE drg_init  ***
+      !!
+      !! ** Purpose :   Initialization of the top/bottom friction CdO and Cd
+      !!              from namelist parameters
+      !!----------------------------------------------------------------------
+      CHARACTER(len=6)        , INTENT(in   ) ::   cd_topbot       ! top/ bot indicator
+      INTEGER , DIMENSION(:,:), INTENT(in   ) ::   k_mk            ! 1st/last  wet level 
+      REAL(wp)                , INTENT(  out) ::   pCdmin, pCdmax  ! min and max drag coef. [-]
+      REAL(wp)                , INTENT(  out) ::   pz0             ! roughness              [m]
+      REAL(wp)                , INTENT(  out) ::   pke0            ! background KE          [m2/s2]
+      REAL(wp), DIMENSION(:,:), INTENT(  out) ::   pCd0            ! masked precomputed part of the non-linear drag coefficient
+      REAL(wp), DIMENSION(:,:), INTENT(  out) ::   pCdU            ! minus linear drag*|U| at t-points  [m/s]
+      !!
+      CHARACTER(len=40) ::   cl_namdrg, cl_file, cl_varname, cl_namref, cl_namcfg  ! local names 
+      INTEGER ::   ji, jj              ! dummy loop indexes
+      LOGICAL ::   ll_top, ll_bot      ! local logical
+      INTEGER ::   ios, inum, imk      ! local integers
+      REAL(wp)::   zmsk, zzz, zcd      ! local scalars
+      REAL(wp), DIMENSION(jpi,jpj) ::   zmsk_boost   ! 2D workspace
+      !!
+      NAMELIST/namdrg_top/ rn_Cd0, rn_Uc0, rn_Cdmax, rn_ke0, rn_z0, ln_boost, rn_boost
+      NAMELIST/namdrg_bot/ rn_Cd0, rn_Uc0, rn_Cdmax, rn_ke0, rn_z0, ln_boost, rn_boost
+      !!----------------------------------------------------------------------
+      !
+      !                          !==  set TOP / BOTTOM specificities  ==!
+      ll_top = .FALSE.
+      ll_bot = .FALSE.
+      !
+      SELECT CASE (cd_topbot)
+      CASE( 'TOP   ' )
+         ll_top = .TRUE.
+         cl_namdrg  = 'namdrg_top'
+         cl_namref  = 'namdrg_top in reference     namelist'
+         cl_namcfg  = 'namdrg_top in configuration namelist'
+         cl_file    = 'tfr_coef.nc'
+         cl_varname = 'tfr_coef'
+      CASE( 'BOTTOM' )
+         ll_bot = .TRUE.
+         cl_namdrg  = 'namdrg_bot'
+         cl_namref  = 'namdrg_bot  in reference     namelist'
+         cl_namcfg  = 'namdrg_bot  in configuration namelist'
+         cl_file    = 'bfr_coef.nc'
+         cl_varname = 'bfr_coef'
+      CASE DEFAULT
+         CALL ctl_stop( 'drg_init: bad value for cd_topbot ' )
+      END SELECT
+      !
+      !                          !==  read namlist  ==!
+      !
+      REWIND( numnam_ref )                   ! Namelist cl_namdrg in reference namelist
+      IF(ll_top)   READ  ( numnam_ref, namdrg_top, IOSTAT = ios, ERR = 901)
+      IF(ll_bot)   READ  ( numnam_ref, namdrg_bot, IOSTAT = ios, ERR = 901)
+901   IF( ios /= 0 )   CALL ctl_nam( ios , TRIM(cl_namref), lwp )
+      REWIND( numnam_cfg )                   ! Namelist cd_namdrg in configuration namelist
+      IF(ll_top)   READ  ( numnam_cfg, namdrg_top, IOSTAT = ios, ERR = 902 )
+      IF(ll_bot)   READ  ( numnam_cfg, namdrg_bot, IOSTAT = ios, ERR = 902 )
+902   IF( ios >  0 )   CALL ctl_nam( ios , TRIM(cl_namcfg), lwp )
+      IF(lwm .AND. ll_top)   WRITE ( numond, namdrg_top )
+      IF(lwm .AND. ll_bot)   WRITE ( numond, namdrg_bot )
+      !
+      IF(lwp) THEN
+         WRITE(numout,*)
+         WRITE(numout,*) '   Namelist ',TRIM(cl_namdrg),' : set ',TRIM(cd_topbot),' friction parameters'
+         WRITE(numout,*) '      drag coefficient                        rn_Cd0   = ', rn_Cd0
+         WRITE(numout,*) '      characteristic velocity (linear case)   rn_Uc0   = ', rn_Uc0, ' m/s'
+         WRITE(numout,*) '      non-linear drag maximum                 rn_Cdmax = ', rn_Cdmax
+         WRITE(numout,*) '      background kinetic energy  (n-l case)   rn_ke0   = ', rn_ke0
+         WRITE(numout,*) '      bottom roughness           (n-l case)   rn_z0    = ', rn_z0
+         WRITE(numout,*) '      set a regional boost of Cd0             ln_boost = ', ln_boost
+         WRITE(numout,*) '         associated boost factor              rn_boost = ', rn_boost
+      ENDIF
+      !
+      !                          !==  return some namelist parametres  ==!   (used in non_lin and loglayer cases)
+      pCdmin = rn_Cd0
+      pCdmax = rn_Cdmax
+      pz0    = rn_z0
+      pke0   = rn_ke0
+      !
+      !                          !==  mask * boost factor  ==!
+      !
+      IF( ln_boost ) THEN           !* regional boost:   boost factor = 1 + regional boost
+         IF(lwp) WRITE(numout,*)
+         IF(lwp) WRITE(numout,*) '   ==>>>   use a regional boost read in ', TRIM(cl_file), ' file'
+         IF(lwp) WRITE(numout,*) '           using enhancement factor of ', rn_boost
+         ! cl_varname is a coefficient in [0,1] giving where to apply the regional boost
+         CALL iom_open ( TRIM(cl_file), inum )
+         CALL iom_get  ( inum, jpdom_data, TRIM(cl_varname), zmsk_boost, 1 )
+         CALL iom_close( inum)
+         zmsk_boost(:,:) = 1._wp + rn_boost * zmsk_boost(:,:)
+         !
+      ELSE                          !* no boost:   boost factor = 1
+         zmsk_boost(:,:) = 1._wp
+      ENDIF
+      !                             !* mask outside ocean cavities area (top) or land area (bot)
+      IF(ll_top)   zmsk_boost(:,:) = zmsk_boost(:,:) * ssmask(:,:) * (1. - tmask(:,:,1) )  ! none zero in ocean cavities only
+      IF(ll_bot)   zmsk_boost(:,:) = zmsk_boost(:,:) * ssmask(:,:)                         ! x seafloor mask
+      !
+      !
+      SELECT CASE( ndrg )
+      !
+      CASE( np_OFF  )            !==  No top/bottom friction  ==!   (pCdU = 0)
+         IF(lwp) WRITE(numout,*)
+         IF(lwp) WRITE(numout,*) '   ==>>>   ',TRIM(cd_topbot),' free-slip, friction set to zero'
+         !
+         l_zdfdrg = .FALSE.         ! no time variation of the drag: set it one for all
+         !
+         pCdU(:,:) = 0._wp
+         pCd0(:,:) = 0._wp
+         !
+      CASE( np_lin )             !==  linear friction  ==!   (pCdU = Cd0 * Uc0)
+         IF(lwp) WRITE(numout,*)
+         IF(lwp) WRITE(numout,*) '   ==>>>   linear ',TRIM(cd_topbot),' friction (constant coef = Cd0*Uc0 = ', rn_Cd0*rn_Uc0, ')'
+         !
+         l_zdfdrg = .FALSE.         ! no time variation of the Cd*|U| : set it one for all
+         !                      
+         pCd0(:,:) = rn_Cd0 * zmsk_boost(:,:)  !* constant in time drag coefficient (= mask (and boost) Cd0)
+         pCdU(:,:) = - pCd0(:,:) * rn_Uc0      !  using a constant velocity
+         !
+      CASE( np_non_lin )         !== non-linear friction  ==!   (pCd0 = Cd0 )
+         IF(lwp) WRITE(numout,*)
+         IF(lwp) WRITE(numout,*) '   ==>>>   quadratic ',TRIM(cd_topbot),' friction (propotional to module of the velocity)'
+         IF(lwp) WRITE(numout,*) '   with    a drag coefficient Cd0 = ', rn_Cd0, ', and'
+         IF(lwp) WRITE(numout,*) '           a background velocity module of (rn_ke0)^1/2 = ', SQRT(rn_ke0), 'm/s)'
+         !
+         l_zdfdrg = .TRUE.          !* Cd*|U| updated at each time-step (it depends on ocean velocity)
+         !
+         pCd0(:,:) = rn_Cd0 * zmsk_boost(:,:)  !* constant in time proportionality coefficient (= mask (and boost) Cd0)
+         pCdU(:,:) = 0._wp                     !  
+         !
+      CASE( np_loglayer )       !== logarithmic layer formulation of friction  ==!   (CdU = (vkarman log(z/z0))^2 |U| )
+         IF(lwp) WRITE(numout,*)
+         IF(lwp) WRITE(numout,*) '   ==>>>   quadratic ',TRIM(cd_topbot),' drag (propotional to module of the velocity)'
+         IF(lwp) WRITE(numout,*) '   with   a logarithmic Cd0 formulation Cd0 = ( vkarman log(z/z0) )^2 ,'
+         IF(lwp) WRITE(numout,*) '          a background velocity module of (rn_ke0)^1/2 = ', SQRT(pke0), 'm/s), '
+         IF(lwp) WRITE(numout,*) '          a logarithmic formulation: a roughness of ', pz0, ' meters,   and '
+         IF(lwp) WRITE(numout,*) '          a proportionality factor bounded by min/max values of ', pCdmin, pCdmax
+         !
+         l_zdfdrg = .TRUE.          !* Cd*|U| updated at each time-step (it depends on ocean velocity)
+         !
+         IF( ln_linssh ) THEN       !* pCd0 = (v log(z/z0))^2   as velocity points have a fixed z position
+            IF(lwp) WRITE(numout,*)
+            IF(lwp) WRITE(numout,*) '   N.B.   linear free surface case, Cd0 computed one for all'
+            !
+            l_log_not_linssh = .FALSE.    !- don't update Cd at each time step
+            !
+            DO jj = 1, jpj                   ! pCd0 = mask (and boosted) logarithmic drag coef. 
+               DO ji = 1, jpi
+                  zzz =  0.5_wp * e3t_0(ji,jj,k_mk(ji,jj))
+                  zcd = (  vkarmn / LOG( zzz / rn_z0 )  )**2
+                  pCd0(ji,jj) = zmsk_boost(ji,jj) * MIN(  MAX( rn_Cd0 , zcd ) , rn_Cdmax  )  ! rn_Cd0 < Cd0 < rn_Cdmax
+               END DO
+            END DO
+         ELSE                       !* Cd updated at each time-step ==> pCd0 = mask * boost
+            IF(lwp) WRITE(numout,*)
+            IF(lwp) WRITE(numout,*) '   N.B.   non-linear free surface case, Cd0 updated at each time-step '
+            !
+            l_log_not_linssh = .TRUE.     ! compute the drag coef. at each time-step 
+            !
+            pCd0(:,:) = zmsk_boost(:,:)
+         ENDIF
+         pCdU(:,:) = 0._wp          ! initialisation to zero (will be updated at each time step)
+         !
+      CASE DEFAULT
+         CALL ctl_stop( 'drg_init: bad flag value for ndrg ' )
+      END SELECT
+      !
+   END SUBROUTINE drg_init
+
+   !!======================================================================
+END MODULE zdfdrg
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/ZDF/zdfevd.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/ZDF/zdfevd.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/ZDF/zdfevd.F90	(revision 9570)
@@ -0,0 +1,124 @@
+MODULE zdfevd
+   !!======================================================================
+   !!                       ***  MODULE  zdfevd  ***
+   !! Ocean physics: parameterization of convection through an enhancement
+   !!                of vertical eddy mixing coefficient
+   !!======================================================================
+   !! History :  OPA  !  1997-06  (G. Madec, A. Lazar)  Original code
+   !!   NEMO     1.0  !  2002-06  (G. Madec)  F90: Free form and module
+   !!            3.2  !  2009-03  (M. Leclair, G. Madec, R. Benshila) test on both before & after
+   !!            4.0  !  2017-04  (G. Madec)  evd applied on avm (at t-point) 
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   zdf_evd       : increase the momentum and tracer Kz at the location of
+   !!                   statically unstable portion of the water column (ln_zdfevd=T)
+   !!----------------------------------------------------------------------
+   USE oce             ! ocean dynamics and tracers variables
+   USE dom_oce         ! ocean space and time domain variables
+   USE zdf_oce         ! ocean vertical physics variables
+   USE trd_oce         ! trends: ocean variables
+   USE trdtra          ! trends manager: tracers 
+   !
+   USE in_out_manager  ! I/O manager
+   USE iom             ! for iom_put
+   USE lbclnk          ! ocean lateral boundary conditions (or mpp link)
+   USE timing          ! Timing
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   zdf_evd    ! called by step.F90
+
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 4.0 , NEMO Consortium (2011)
+   !! $Id$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE zdf_evd( kt, p_avm, p_avt )
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE zdf_evd  ***
+      !!                   
+      !! ** Purpose :   Local increased the vertical eddy viscosity and diffu-
+      !!      sivity coefficients when a static instability is encountered.
+      !!
+      !! ** Method  :   tracer (and momentum if nn_evdm=1) vertical mixing 
+      !!              coefficients are set to rn_evd (namelist parameter) 
+      !!              if the water column is statically unstable.
+      !!                The test of static instability is performed using
+      !!              Brunt-Vaisala frequency (rn2 < -1.e-12) of to successive
+      !!              time-step (Leap-Frog environnement): before and
+      !!              now time-step.
+      !!
+      !! ** Action  :   avt, avm   enhanced where static instability occurs
+      !!----------------------------------------------------------------------
+      INTEGER                    , INTENT(in   ) ::   kt             ! ocean time-step indexocean time step
+      REAL(wp), DIMENSION(:,:,:) , INTENT(inout) ::   p_avm, p_avt   !  momentum and tracer Kz (w-points)
+      !
+      INTEGER ::   ji, jj, jk   ! dummy loop indices
+      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zavt_evd, zavm_evd
+      !!----------------------------------------------------------------------
+      !
+      IF( kt == nit000 ) THEN
+         IF(lwp) WRITE(numout,*)
+         IF(lwp) WRITE(numout,*) 'zdf_evd : Enhanced Vertical Diffusion (evd)'
+         IF(lwp) WRITE(numout,*) '~~~~~~~ '
+         IF(lwp) WRITE(numout,*)
+      ENDIF
+      !
+      !
+      zavt_evd(:,:,:) = p_avt(:,:,:)         ! set avt prior to evd application
+      !
+      SELECT CASE ( nn_evdm )
+      !
+      CASE ( 1 )           !==  enhance tracer & momentum Kz  ==!   (if rn2<-1.e-12)
+         !
+         zavm_evd(:,:,:) = p_avm(:,:,:)      ! set avm prior to evd application
+         !
+!! change last digits results
+!         WHERE( MAX( rn2(2:jpi,2:jpj,2:jpkm1), rn2b(2:jpi,2:jpj,2:jpkm1) )  <= -1.e-12 ) THEN
+!            p_avt(2:jpi,2:jpj,2:jpkm1) = rn_evd * wmask(2:jpi,2:jpj,2:jpkm1)
+!            p_avm(2:jpi,2:jpj,2:jpkm1) = rn_evd * wmask(2:jpi,2:jpj,2:jpkm1)
+!         END WHERE
+         !
+         DO jk = 1, jpkm1 
+            DO jj = 2, jpjm1
+               DO ji = 2, jpim1
+                  IF(  MIN( rn2(ji,jj,jk), rn2b(ji,jj,jk) ) <= -1.e-12 ) THEN
+                     p_avt(ji,jj,jk) = rn_evd * wmask(ji,jj,jk)
+                     p_avm(ji,jj,jk) = rn_evd * wmask(ji,jj,jk)
+                  ENDIF
+               END DO
+            END DO
+         END DO 
+         !
+         zavm_evd(:,:,:) = p_avm(:,:,:) - zavm_evd(:,:,:)   ! change in avm due to evd
+         CALL iom_put( "avm_evd", zavm_evd )                ! output this change
+         !
+      CASE DEFAULT         !==  enhance tracer Kz  ==!   (if rn2<-1.e-12) 
+!! change last digits results
+!         WHERE( MAX( rn2(2:jpi,2:jpj,2:jpkm1), rn2b(2:jpi,2:jpj,2:jpkm1) )  <= -1.e-12 )
+!            p_avt(2:jpi,2:jpj,2:jpkm1) = rn_evd * wmask(2:jpi,2:jpj,2:jpkm1)
+!         END WHERE
+
+         DO jk = 1, jpkm1
+            DO jj = 2, jpjm1
+               DO ji = 2, jpim1
+                  IF(  MIN( rn2(ji,jj,jk), rn2b(ji,jj,jk) ) <= -1.e-12 )   &
+                     p_avt(ji,jj,jk) = rn_evd * wmask(ji,jj,jk)
+               END DO
+            END DO
+         END DO
+         !
+      END SELECT 
+      !
+      zavt_evd(:,:,:) = p_avt(:,:,:) - zavt_evd(:,:,:)   ! change in avt due to evd
+      CALL iom_put( "avt_evd", zavt_evd )              ! output this change
+      IF( l_trdtra ) CALL trd_tra( kt, 'TRA', jp_tem, jptra_evd, zavt_evd )
+      !
+   END SUBROUTINE zdf_evd
+
+   !!======================================================================
+END MODULE zdfevd
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/ZDF/zdfgls.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/ZDF/zdfgls.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/ZDF/zdfgls.F90	(revision 9570)
@@ -0,0 +1,1200 @@
+MODULE zdfgls
+   !!======================================================================
+   !!                       ***  MODULE  zdfgls  ***
+   !! Ocean physics:  vertical mixing coefficient computed from the gls 
+   !!                 turbulent closure parameterization
+   !!======================================================================
+   !! History :  3.0  !  2009-09  (G. Reffray)  Original code
+   !!            3.3  !  2010-10  (C. Bricaud)  Add in the reference
+   !!            4.0  !  2017-04  (G. Madec)  remove CPP keys & avm at t-point only 
+   !!             -   !  2017-05  (G. Madec)  add top friction as boundary condition
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   zdf_gls       : update momentum and tracer Kz from a gls scheme
+   !!   zdf_gls_init  : initialization, namelist read, and parameters control
+   !!   gls_rst       : read/write gls restart in ocean restart file
+   !!----------------------------------------------------------------------
+   USE oce            ! ocean dynamics and active tracers 
+   USE dom_oce        ! ocean space and time domain
+   USE domvvl         ! ocean space and time domain : variable volume layer
+   USE zdfdrg  , ONLY : r_z0_top , r_z0_bot   ! top/bottom roughness
+   USE zdfdrg  , ONLY : rCdU_top , rCdU_bot   ! top/bottom friction
+   USE sbc_oce        ! surface boundary condition: ocean
+   USE phycst         ! physical constants
+   USE zdfmxl         ! mixed layer
+   USE sbcwave , ONLY : hsw   ! significant wave height
+   !
+   USE lbclnk         ! ocean lateral boundary conditions (or mpp link)
+   USE lib_mpp        ! MPP manager
+   USE prtctl         ! Print control
+   USE in_out_manager ! I/O manager
+   USE iom            ! I/O manager library
+   USE lib_fortran    ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined)
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   zdf_gls        ! called in zdfphy
+   PUBLIC   zdf_gls_init   ! called in zdfphy
+   PUBLIC   gls_rst        ! called in zdfphy
+
+   !
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   hmxl_n    !: now mixing length
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   zwall   !: wall function
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   ustar2_surf !: Squared surface velocity scale at T-points
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   ustar2_top  !: Squared top     velocity scale at T-points
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   ustar2_bot  !: Squared bottom  velocity scale at T-points
+
+   !                              !! ** Namelist  namzdf_gls  **
+   LOGICAL  ::   ln_length_lim     ! use limit on the dissipation rate under stable stratification (Galperin et al. 1988)
+   LOGICAL  ::   ln_sigpsi         ! Activate Burchard (2003) modification for k-eps closure & wave breaking mixing
+   INTEGER  ::   nn_bc_surf        ! surface boundary condition (=0/1)
+   INTEGER  ::   nn_bc_bot         ! bottom boundary condition (=0/1)
+   INTEGER  ::   nn_z0_met         ! Method for surface roughness computation
+   INTEGER  ::   nn_stab_func      ! stability functions G88, KC or Canuto (=0/1/2)
+   INTEGER  ::   nn_clos           ! closure 0/1/2/3 MY82/k-eps/k-w/gen
+   REAL(wp) ::   rn_clim_galp      ! Holt 2008 value for k-eps: 0.267
+   REAL(wp) ::   rn_epsmin         ! minimum value of dissipation (m2/s3)
+   REAL(wp) ::   rn_emin           ! minimum value of TKE (m2/s2)
+   REAL(wp) ::   rn_charn          ! Charnock constant for surface breaking waves mixing : 1400. (standard) or 2.e5 (Stacey value)
+   REAL(wp) ::   rn_crban          ! Craig and Banner constant for surface breaking waves mixing
+   REAL(wp) ::   rn_hsro           ! Minimum surface roughness
+   REAL(wp) ::   rn_frac_hs        ! Fraction of wave height as surface roughness (if nn_z0_met > 1) 
+
+   REAL(wp) ::   rcm_sf        =  0.73_wp     ! Shear free turbulence parameters
+   REAL(wp) ::   ra_sf         = -2.0_wp      ! Must be negative -2 < ra_sf < -1 
+   REAL(wp) ::   rl_sf         =  0.2_wp      ! 0 <rl_sf<vkarmn    
+   REAL(wp) ::   rghmin        = -0.28_wp
+   REAL(wp) ::   rgh0          =  0.0329_wp
+   REAL(wp) ::   rghcri        =  0.03_wp
+   REAL(wp) ::   ra1           =  0.92_wp
+   REAL(wp) ::   ra2           =  0.74_wp
+   REAL(wp) ::   rb1           = 16.60_wp
+   REAL(wp) ::   rb2           = 10.10_wp         
+   REAL(wp) ::   re2           =  1.33_wp         
+   REAL(wp) ::   rl1           =  0.107_wp
+   REAL(wp) ::   rl2           =  0.0032_wp
+   REAL(wp) ::   rl3           =  0.0864_wp
+   REAL(wp) ::   rl4           =  0.12_wp
+   REAL(wp) ::   rl5           = 11.9_wp
+   REAL(wp) ::   rl6           =  0.4_wp
+   REAL(wp) ::   rl7           =  0.0_wp
+   REAL(wp) ::   rl8           =  0.48_wp
+   REAL(wp) ::   rm1           =  0.127_wp
+   REAL(wp) ::   rm2           =  0.00336_wp
+   REAL(wp) ::   rm3           =  0.0906_wp
+   REAL(wp) ::   rm4           =  0.101_wp
+   REAL(wp) ::   rm5           = 11.2_wp
+   REAL(wp) ::   rm6           =  0.4_wp
+   REAL(wp) ::   rm7           =  0.0_wp
+   REAL(wp) ::   rm8           =  0.318_wp
+   REAL(wp) ::   rtrans        =  0.1_wp
+   REAL(wp) ::   rc02, rc02r, rc03, rc04                          ! coefficients deduced from above parameters
+   REAL(wp) ::   rsbc_tke1, rsbc_tke2, rfact_tke                  !     -           -           -        -
+   REAL(wp) ::   rsbc_psi1, rsbc_psi2, rfact_psi                  !     -           -           -        -
+   REAL(wp) ::   rsbc_zs1, rsbc_zs2                               !     -           -           -        -
+   REAL(wp) ::   rc0, rc2, rc3, rf6, rcff, rc_diff                !     -           -           -        -
+   REAL(wp) ::   rs0, rs1, rs2, rs4, rs5, rs6                     !     -           -           -        -
+   REAL(wp) ::   rd0, rd1, rd2, rd3, rd4, rd5                     !     -           -           -        -
+   REAL(wp) ::   rsc_tke, rsc_psi, rpsi1, rpsi2, rpsi3, rsc_psi0  !     -           -           -        -
+   REAL(wp) ::   rpsi3m, rpsi3p, rpp, rmm, rnn                    !     -           -           -        -
+   !
+   REAL(wp) ::   r2_3 = 2._wp/3._wp   ! constant=2/3
+
+   !! * Substitutions
+#  include "vectopt_loop_substitute.h90"
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO Consortium (2010)
+   !! $Id$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   INTEGER FUNCTION zdf_gls_alloc()
+      !!----------------------------------------------------------------------
+      !!                ***  FUNCTION zdf_gls_alloc  ***
+      !!----------------------------------------------------------------------
+      ALLOCATE( hmxl_n(jpi,jpj,jpk) , ustar2_surf(jpi,jpj) ,                     &
+         &      zwall (jpi,jpj,jpk) , ustar2_top (jpi,jpj) , ustar2_bot(jpi,jpj) , STAT= zdf_gls_alloc )
+         !
+      IF( lk_mpp             )   CALL mpp_sum ( zdf_gls_alloc )
+      IF( zdf_gls_alloc /= 0 )   CALL ctl_warn('zdf_gls_alloc: failed to allocate arrays')
+   END FUNCTION zdf_gls_alloc
+
+
+   SUBROUTINE zdf_gls( kt, p_sh2, p_avm, p_avt )
+      !!----------------------------------------------------------------------
+      !!                   ***  ROUTINE zdf_gls  ***
+      !!
+      !! ** Purpose :   Compute the vertical eddy viscosity and diffusivity
+      !!              coefficients using the GLS turbulent closure scheme.
+      !!----------------------------------------------------------------------
+      USE zdf_oce , ONLY : en, avtb, avmb   ! ocean vertical physics
+      !!
+      INTEGER                   , INTENT(in   ) ::   kt             ! ocean time step
+      REAL(wp), DIMENSION(:,:,:), INTENT(in   ) ::   p_sh2          ! shear production term
+      REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   p_avm, p_avt   !  momentum and tracer Kz (w-points)
+      !
+      INTEGER  ::   ji, jj, jk    ! dummy loop arguments
+      INTEGER  ::   ibot, ibotm1  ! local integers
+      INTEGER  ::   itop, itopp1  !   -       -
+      REAL(wp) ::   zesh2, zsigpsi, zcoef, zex1 , zex2  ! local scalars
+      REAL(wp) ::   ztx2, zty2, zup, zdown, zcof, zdir  !   -      - 
+      REAL(wp) ::   zratio, zrn2, zflxb, sh     , z_en  !   -      -
+      REAL(wp) ::   prod, buoy, diss, zdiss, sm         !   -      -
+      REAL(wp) ::   gh, gm, shr, dif, zsqen, zavt, zavm !   -      -
+      REAL(wp) ::   zmsku, zmskv                        !   -      -
+      REAL(wp), DIMENSION(jpi,jpj)     ::   zdep
+      REAL(wp), DIMENSION(jpi,jpj)     ::   zkar
+      REAL(wp), DIMENSION(jpi,jpj)     ::   zflxs       ! Turbulence fluxed induced by internal waves 
+      REAL(wp), DIMENSION(jpi,jpj)     ::   zhsro       ! Surface roughness (surface waves)
+      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   eb          ! tke at time before
+      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   hmxl_b      ! mixing length at time before
+      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   eps         ! dissipation rate
+      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zwall_psi   ! Wall function use in the wb case (ln_sigpsi)
+      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   psi         ! psi at time now
+      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zd_lw, zd_up, zdiag   ! lower, upper  and diagonal of the matrix
+      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zstt, zstm  ! stability function on tracer and momentum
+      !!--------------------------------------------------------------------
+      !
+      ! Preliminary computing
+
+      ustar2_surf(:,:) = 0._wp   ;         psi(:,:,:) = 0._wp   
+      ustar2_top (:,:) = 0._wp   ;   zwall_psi(:,:,:) = 0._wp
+      ustar2_bot (:,:) = 0._wp
+
+      ! Compute surface, top and bottom friction at T-points
+      DO jj = 2, jpjm1          
+         DO ji = fs_2, fs_jpim1   ! vector opt.         
+            !
+            ! surface friction
+            ustar2_surf(ji,jj) = r1_rau0 * taum(ji,jj) * tmask(ji,jj,1)
+            !   
+!!gm Rq we may add here r_ke0(_top/_bot) ?  ==>> think about that...
+          ! bottom friction (explicit before friction)
+          zmsku = ( 2._wp - umask(ji-1,jj,mbkt(ji,jj)) * umask(ji,jj,mbkt(ji,jj)) )
+          zmskv = ( 2._wp - vmask(ji,jj-1,mbkt(ji,jj)) * vmask(ji,jj,mbkt(ji,jj)) )     ! (CAUTION: CdU<0)
+          ustar2_bot(ji,jj) = - rCdU_bot(ji,jj) * SQRT(  ( zmsku*( ub(ji,jj,mbkt(ji,jj))+ub(ji-1,jj,mbkt(ji,jj)) ) )**2  &
+             &                                         + ( zmskv*( vb(ji,jj,mbkt(ji,jj))+vb(ji,jj-1,mbkt(ji,jj)) ) )**2  )
+         END DO
+      END DO
+      IF( ln_isfcav ) THEN       !top friction
+         DO jj = 2, jpjm1
+            DO ji = fs_2, fs_jpim1   ! vector opt.
+               zmsku = ( 2. - umask(ji-1,jj,mikt(ji,jj)) * umask(ji,jj,mikt(ji,jj)) )
+               zmskv = ( 2. - vmask(ji,jj-1,mikt(ji,jj)) * vmask(ji,jj,mikt(ji,jj)) )     ! (CAUTION: CdU<0)
+               ustar2_top(ji,jj) = - rCdU_top(ji,jj) * SQRT(  ( zmsku*( ub(ji,jj,mikt(ji,jj))+ub(ji-1,jj,mikt(ji,jj)) ) )**2  &
+                  &                                         + ( zmskv*( vb(ji,jj,mikt(ji,jj))+vb(ji,jj-1,mikt(ji,jj)) ) )**2  )
+            END DO
+         END DO
+      ENDIF
+   
+      SELECT CASE ( nn_z0_met )      !==  Set surface roughness length  ==!
+      CASE ( 0 )                          ! Constant roughness          
+         zhsro(:,:) = rn_hsro
+      CASE ( 1 )             ! Standard Charnock formula
+         zhsro(:,:) = MAX( rsbc_zs1 * ustar2_surf(:,:) , rn_hsro )
+      CASE ( 2 )             ! Roughness formulae according to Rascle et al., Ocean Modelling (2008)
+!!gm faster coding : the 2 comment lines should be used
+!!gm         zcof = 2._wp * 0.6_wp / 28._wp
+!!gm         zdep(:,:)  = 30._wp * TANH(  zcof/ SQRT( MAX(ustar2_surf(:,:),rsmall) )  )       ! Wave age (eq. 10)
+         zdep (:,:) = 30.*TANH( 2.*0.3/(28.*SQRT(MAX(ustar2_surf(:,:),rsmall))) )         ! Wave age (eq. 10)
+         zhsro(:,:) = MAX(rsbc_zs2 * ustar2_surf(:,:) * zdep(:,:)**1.5, rn_hsro)          ! zhsro = rn_frac_hs * Hsw (eq. 11)
+      CASE ( 3 )             ! Roughness given by the wave model (coupled or read in file)
+         zhsro(:,:) = rn_frac_hs * hsw(:,:)   ! (rn_frac_hs=1.6 see Eq. (5) of Rascle et al. 2008 )
+      END SELECT
+      !
+      DO jk = 2, jpkm1              !==  Compute dissipation rate  ==!
+         DO jj = 1, jpjm1
+            DO ji = 1, jpim1
+               eps(ji,jj,jk)  = rc03 * en(ji,jj,jk) * SQRT( en(ji,jj,jk) ) / hmxl_n(ji,jj,jk)
+            END DO
+         END DO
+      END DO
+
+      ! Save tke at before time step
+      eb    (:,:,:) = en    (:,:,:)
+      hmxl_b(:,:,:) = hmxl_n(:,:,:)
+
+      IF( nn_clos == 0 ) THEN    ! Mellor-Yamada
+         DO jk = 2, jpkm1
+            DO jj = 2, jpjm1 
+               DO ji = fs_2, fs_jpim1   ! vector opt.
+                  zup   = hmxl_n(ji,jj,jk) * gdepw_n(ji,jj,mbkt(ji,jj)+1)
+                  zdown = vkarmn * gdepw_n(ji,jj,jk) * ( -gdepw_n(ji,jj,jk) + gdepw_n(ji,jj,mbkt(ji,jj)+1) )
+                  zcoef = ( zup / MAX( zdown, rsmall ) )
+                  zwall (ji,jj,jk) = ( 1._wp + re2 * zcoef*zcoef ) * tmask(ji,jj,jk)
+               END DO
+            END DO
+         END DO
+      ENDIF
+
+      !!---------------------------------!!
+      !!   Equation to prognostic k      !!
+      !!---------------------------------!!
+      !
+      ! Now Turbulent kinetic energy (output in en)
+      ! -------------------------------
+      ! Resolution of a tridiagonal linear system by a "methode de chasse"
+      ! computation from level 2 to jpkm1  (e(1) computed after and e(jpk)=0 ).
+      ! The surface boundary condition are set after
+      ! The bottom boundary condition are also set after. In standard e(bottom)=0.
+      ! zdiag : diagonal zd_up : upper diagonal zd_lw : lower diagonal
+      ! Warning : after this step, en : right hand side of the matrix
+
+      DO jk = 2, jpkm1
+         DO jj = 2, jpjm1
+            DO ji = 2, jpim1
+               !
+               buoy = - p_avt(ji,jj,jk) * rn2(ji,jj,jk)     ! stratif. destruction
+               !
+               diss = eps(ji,jj,jk)                         ! dissipation
+               !
+               zdir = 0.5_wp + SIGN( 0.5_wp, p_sh2(ji,jj,jk) + buoy )   ! zdir =1(=0) if shear(ji,jj,jk)+buoy >0(<0)
+               !
+               zesh2 = zdir*(p_sh2(ji,jj,jk)+buoy)+(1._wp-zdir)*p_sh2(ji,jj,jk)          ! production term
+               zdiss = zdir*(diss/en(ji,jj,jk))   +(1._wp-zdir)*(diss-buoy)/en(ji,jj,jk) ! dissipation term
+!!gm better coding, identical results
+!               zesh2 =   p_sh2(ji,jj,jk) + zdir*buoy               ! production term
+!               zdiss = ( diss - (1._wp-zdir)*buoy ) / en(ji,jj,jk) ! dissipation term
+!!gm
+               !
+               ! Compute a wall function from 1. to rsc_psi*zwall/rsc_psi0
+               ! Note that as long that Dirichlet boundary conditions are NOT set at the first and last levels (GOTM style)
+               ! there is no need to set a boundary condition for zwall_psi at the top and bottom boundaries.
+               ! Otherwise, this should be rsc_psi/rsc_psi0
+               IF( ln_sigpsi ) THEN
+                  zsigpsi = MIN( 1._wp, zesh2 / eps(ji,jj,jk) )     ! 0. <= zsigpsi <= 1.
+                  zwall_psi(ji,jj,jk) = rsc_psi /   & 
+                     &     (  zsigpsi * rsc_psi + (1._wp-zsigpsi) * rsc_psi0 / MAX( zwall(ji,jj,jk), 1._wp )  )
+               ELSE
+                  zwall_psi(ji,jj,jk) = 1._wp
+               ENDIF
+               !
+               ! building the matrix
+               zcof = rfact_tke * tmask(ji,jj,jk)
+               !                                               ! lower diagonal
+               zd_lw(ji,jj,jk) = zcof * ( p_avm(ji,jj,jk  ) + p_avm(ji,jj,jk-1) ) / ( e3t_n(ji,jj,jk-1) * e3w_n(ji,jj,jk) )
+               !                                               ! upper diagonal
+               zd_up(ji,jj,jk) = zcof * ( p_avm(ji,jj,jk+1) + p_avm(ji,jj,jk  ) ) / ( e3t_n(ji,jj,jk  ) * e3w_n(ji,jj,jk) )
+               !                                               ! diagonal
+               zdiag(ji,jj,jk) = 1._wp - zd_lw(ji,jj,jk) - zd_up(ji,jj,jk)  + rdt * zdiss * wmask(ji,jj,jk) 
+               !                                               ! right hand side in en
+               en(ji,jj,jk) = en(ji,jj,jk) + rdt * zesh2 * wmask(ji,jj,jk)
+            END DO
+         END DO
+      END DO
+      !
+      zdiag(:,:,jpk) = 1._wp
+      !
+      ! Set surface condition on zwall_psi (1 at the bottom)
+      zwall_psi(:,:, 1 ) = zwall_psi(:,:,2)
+      zwall_psi(:,:,jpk) = 1._wp
+      !
+      ! Surface boundary condition on tke
+      ! ---------------------------------
+      !
+      SELECT CASE ( nn_bc_surf )
+      !
+      CASE ( 0 )             ! Dirichlet boundary condition (set e at k=1 & 2) 
+      ! First level
+      en   (:,:,1) = MAX(  rn_emin , rc02r * ustar2_surf(:,:) * (1._wp + rsbc_tke1)**r2_3  )
+      zd_lw(:,:,1) = en(:,:,1)
+      zd_up(:,:,1) = 0._wp
+      zdiag(:,:,1) = 1._wp
+      ! 
+      ! One level below
+      en   (:,:,2) =  MAX(  rc02r * ustar2_surf(:,:) * (  1._wp + rsbc_tke1 * ((zhsro(:,:)+gdepw_n(:,:,2))   &
+         &                 / zhsro(:,:) )**(1.5_wp*ra_sf)  )**(2._wp/3._wp)                      , rn_emin   )
+      zd_lw(:,:,2) = 0._wp 
+      zd_up(:,:,2) = 0._wp
+      zdiag(:,:,2) = 1._wp
+      !
+      !
+      CASE ( 1 )             ! Neumann boundary condition (set d(e)/dz)
+      !
+      ! Dirichlet conditions at k=1
+      en   (:,:,1) = MAX(  rc02r * ustar2_surf(:,:) * (1._wp + rsbc_tke1)**r2_3 , rn_emin  )
+      zd_lw(:,:,1) = en(:,:,1)
+      zd_up(:,:,1) = 0._wp
+      zdiag(:,:,1) = 1._wp
+      !
+      ! at k=2, set de/dz=Fw
+      !cbr
+      zdiag(:,:,2) = zdiag(:,:,2) +  zd_lw(:,:,2) ! Remove zd_lw from zdiag
+      zd_lw(:,:,2) = 0._wp
+      zkar (:,:)   = (rl_sf + (vkarmn-rl_sf)*(1.-EXP(-rtrans*gdept_n(:,:,1)/zhsro(:,:)) ))
+      zflxs(:,:)   = rsbc_tke2 * ustar2_surf(:,:)**1.5_wp * zkar(:,:) &
+          &                    * (  ( zhsro(:,:)+gdept_n(:,:,1) ) / zhsro(:,:)  )**(1.5_wp*ra_sf)
+!!gm why not   :                        * ( 1._wp + gdept_n(:,:,1) / zhsro(:,:) )**(1.5_wp*ra_sf)
+      en(:,:,2) = en(:,:,2) + zflxs(:,:) / e3w_n(:,:,2)
+      !
+      !
+      END SELECT
+
+      ! Bottom boundary condition on tke
+      ! --------------------------------
+      !
+      SELECT CASE ( nn_bc_bot )
+      !
+      CASE ( 0 )             ! Dirichlet 
+         !                      ! en(ibot) = u*^2 / Co2 and hmxl_n(ibot) = rn_lmin
+         !                      ! Balance between the production and the dissipation terms
+         DO jj = 2, jpjm1
+            DO ji = fs_2, fs_jpim1   ! vector opt.
+!!gm This means that bottom and ocean w-level above have a specified "en" value.   Sure ????
+!!   With thick deep ocean level thickness, this may be quite large, no ???
+!!   in particular in ocean cavities where top stratification can be large...
+               ibot   = mbkt(ji,jj) + 1      ! k   bottom level of w-point
+               ibotm1 = mbkt(ji,jj)          ! k-1 bottom level of w-point but >=1
+               !
+               z_en =  MAX( rc02r * ustar2_bot(ji,jj), rn_emin )
+               !
+               ! Dirichlet condition applied at: 
+               !     Bottom level (ibot)      &      Just above it (ibotm1)   
+               zd_lw(ji,jj,ibot) = 0._wp   ;   zd_lw(ji,jj,ibotm1) = 0._wp
+               zd_up(ji,jj,ibot) = 0._wp   ;   zd_up(ji,jj,ibotm1) = 0._wp
+               zdiag(ji,jj,ibot) = 1._wp   ;   zdiag(ji,jj,ibotm1) = 1._wp
+               en   (ji,jj,ibot) = z_en    ;   en   (ji,jj,ibotm1) = z_en
+            END DO
+         END DO
+         !
+         IF( ln_isfcav) THEN     ! top boundary   (ocean cavity)
+            DO jj = 2, jpjm1
+               DO ji = fs_2, fs_jpim1   ! vector opt.
+                  itop   = mikt(ji,jj)       ! k   top w-point
+                  itopp1 = mikt(ji,jj) + 1   ! k+1 1st w-point below the top one
+                  !                                                ! mask at the ocean surface points
+                  z_en = MAX( rc02r * ustar2_top(ji,jj), rn_emin ) * ( 1._wp - tmask(ji,jj,1) )
+                  !
+ !!gm TO BE VERIFIED !!!
+                  ! Dirichlet condition applied at: 
+                  !     top level (itop)         &      Just below it (itopp1)   
+                  zd_lw(ji,jj,itop) = 0._wp   ;   zd_lw(ji,jj,itopp1) = 0._wp
+                  zd_up(ji,jj,itop) = 0._wp   ;   zd_up(ji,jj,itopp1) = 0._wp
+                  zdiag(ji,jj,itop) = 1._wp   ;   zdiag(ji,jj,itopp1) = 1._wp
+                  en   (ji,jj,itop) = z_en    ;   en   (ji,jj,itopp1) = z_en
+               END DO
+            END DO
+         ENDIF
+         !
+      CASE ( 1 )             ! Neumman boundary condition
+         !                      
+         DO jj = 2, jpjm1
+            DO ji = fs_2, fs_jpim1   ! vector opt.
+               ibot   = mbkt(ji,jj) + 1      ! k   bottom level of w-point
+               ibotm1 = mbkt(ji,jj)          ! k-1 bottom level of w-point but >=1
+               !
+               z_en =  MAX( rc02r * ustar2_bot(ji,jj), rn_emin )
+               !
+               ! Bottom level Dirichlet condition:
+               !     Bottom level (ibot)      &      Just above it (ibotm1)   
+               !         Dirichlet            !         Neumann
+               zd_lw(ji,jj,ibot) = 0._wp   !   ! Remove zd_up from zdiag
+               zdiag(ji,jj,ibot) = 1._wp   ;   zdiag(ji,jj,ibotm1) = zdiag(ji,jj,ibotm1) + zd_up(ji,jj,ibotm1)
+               zd_up(ji,jj,ibot) = 0._wp   ;   zd_up(ji,jj,ibotm1) = 0._wp
+            END DO
+         END DO
+         IF( ln_isfcav) THEN     ! top boundary   (ocean cavity)
+            DO jj = 2, jpjm1
+               DO ji = fs_2, fs_jpim1   ! vector opt.
+                  itop   = mikt(ji,jj)       ! k   top w-point
+                  itopp1 = mikt(ji,jj) + 1   ! k+1 1st w-point below the top one
+                  !                                                ! mask at the ocean surface points
+                  z_en = MAX( rc02r * ustar2_top(ji,jj), rn_emin ) * ( 1._wp - tmask(ji,jj,1) )
+                  !
+                  ! Bottom level Dirichlet condition:
+                  !     Bottom level (ibot)      &      Just above it (ibotm1)   
+                  !         Dirichlet            !         Neumann
+                  zd_lw(ji,jj,itop) = 0._wp   !   ! Remove zd_up from zdiag
+                  zdiag(ji,jj,itop) = 1._wp   ;   zdiag(ji,jj,itopp1) = zdiag(ji,jj,itopp1) + zd_up(ji,jj,itopp1)
+                  zd_up(ji,jj,itop) = 0._wp   ;   zd_up(ji,jj,itopp1) = 0._wp
+               END DO
+            END DO
+         ENDIF
+         !
+      END SELECT
+
+      ! Matrix inversion (en prescribed at surface and the bottom)
+      ! ----------------------------------------------------------
+      !
+      DO jk = 2, jpkm1                             ! First recurrence : Dk = Dk - Lk * Uk-1 / Dk-1
+         DO jj = 2, jpjm1
+            DO ji = fs_2, fs_jpim1    ! vector opt.
+               zdiag(ji,jj,jk) = zdiag(ji,jj,jk) - zd_lw(ji,jj,jk) * zd_up(ji,jj,jk-1) / zdiag(ji,jj,jk-1)
+            END DO
+         END DO
+      END DO
+      DO jk = 2, jpk                               ! Second recurrence : Lk = RHSk - Lk / Dk-1 * Lk-1
+         DO jj = 2, jpjm1
+            DO ji = fs_2, fs_jpim1    ! vector opt.
+               zd_lw(ji,jj,jk) = en(ji,jj,jk) - zd_lw(ji,jj,jk) / zdiag(ji,jj,jk-1) * zd_lw(ji,jj,jk-1)
+            END DO
+         END DO
+      END DO
+      DO jk = jpk-1, 2, -1                         ! thrid recurrence : Ek = ( Lk - Uk * Ek+1 ) / Dk
+         DO jj = 2, jpjm1
+            DO ji = fs_2, fs_jpim1    ! vector opt.
+               en(ji,jj,jk) = ( zd_lw(ji,jj,jk) - zd_up(ji,jj,jk) * en(ji,jj,jk+1) ) / zdiag(ji,jj,jk)
+            END DO
+         END DO
+      END DO
+      !                                            ! set the minimum value of tke 
+      en(:,:,:) = MAX( en(:,:,:), rn_emin )
+
+      !!----------------------------------------!!
+      !!   Solve prognostic equation for psi    !!
+      !!----------------------------------------!!
+
+      ! Set psi to previous time step value
+      !
+      SELECT CASE ( nn_clos )
+      !
+      CASE( 0 )               ! k-kl  (Mellor-Yamada)
+         DO jk = 2, jpkm1
+            DO jj = 2, jpjm1
+               DO ji = fs_2, fs_jpim1   ! vector opt.
+                  psi(ji,jj,jk)  = eb(ji,jj,jk) * hmxl_b(ji,jj,jk)
+               END DO
+            END DO
+         END DO
+         !
+      CASE( 1 )               ! k-eps
+         DO jk = 2, jpkm1
+            DO jj = 2, jpjm1
+               DO ji = fs_2, fs_jpim1   ! vector opt.
+                  psi(ji,jj,jk)  = eps(ji,jj,jk)
+               END DO
+            END DO
+         END DO
+         !
+      CASE( 2 )               ! k-w
+         DO jk = 2, jpkm1
+            DO jj = 2, jpjm1
+               DO ji = fs_2, fs_jpim1   ! vector opt.
+                  psi(ji,jj,jk)  = SQRT( eb(ji,jj,jk) ) / ( rc0 * hmxl_b(ji,jj,jk) )
+               END DO
+            END DO
+         END DO
+         !
+      CASE( 3 )               ! generic
+         DO jk = 2, jpkm1
+            DO jj = 2, jpjm1
+               DO ji = fs_2, fs_jpim1   ! vector opt.
+                  psi(ji,jj,jk)  = rc02 * eb(ji,jj,jk) * hmxl_b(ji,jj,jk)**rnn 
+               END DO
+            END DO
+         END DO
+         !
+      END SELECT
+      !
+      ! Now gls (output in psi)
+      ! -------------------------------
+      ! Resolution of a tridiagonal linear system by a "methode de chasse"
+      ! computation from level 2 to jpkm1  (e(1) already computed and e(jpk)=0 ).
+      ! zdiag : diagonal zd_up : upper diagonal zd_lw : lower diagonal
+      ! Warning : after this step, en : right hand side of the matrix
+
+      DO jk = 2, jpkm1
+         DO jj = 2, jpjm1
+            DO ji = fs_2, fs_jpim1   ! vector opt.
+               !
+               ! psi / k
+               zratio = psi(ji,jj,jk) / eb(ji,jj,jk) 
+               !
+               ! psi3+ : stable : B=-KhN²<0 => N²>0 if rn2>0 zdir = 1 (stable) otherwise zdir = 0 (unstable)
+               zdir = 0.5_wp + SIGN( 0.5_wp, rn2(ji,jj,jk) )
+               !
+               rpsi3 = zdir * rpsi3m + ( 1._wp - zdir ) * rpsi3p
+               !
+               ! shear prod. - stratif. destruction
+               prod = rpsi1 * zratio * p_sh2(ji,jj,jk)
+               !
+               ! stratif. destruction
+               buoy = rpsi3 * zratio * (- p_avt(ji,jj,jk) * rn2(ji,jj,jk) )
+               !
+               ! shear prod. - stratif. destruction
+               diss = rpsi2 * zratio * zwall(ji,jj,jk) * eps(ji,jj,jk)
+               !
+               zdir = 0.5_wp + SIGN( 0.5_wp, prod + buoy )     ! zdir =1(=0) if shear(ji,jj,jk)+buoy >0(<0)
+               !
+               zesh2 = zdir * ( prod + buoy )          + (1._wp - zdir ) * prod                        ! production term
+               zdiss = zdir * ( diss / psi(ji,jj,jk) ) + (1._wp - zdir ) * (diss-buoy) / psi(ji,jj,jk) ! dissipation term
+               !                                                        
+               ! building the matrix
+               zcof = rfact_psi * zwall_psi(ji,jj,jk) * tmask(ji,jj,jk)
+               !                                               ! lower diagonal
+               zd_lw(ji,jj,jk) = zcof * ( p_avm(ji,jj,jk  ) + p_avm(ji,jj,jk-1) ) / ( e3t_n(ji,jj,jk-1) * e3w_n(ji,jj,jk) )
+               !                                               ! upper diagonal
+               zd_up(ji,jj,jk) = zcof * ( p_avm(ji,jj,jk+1) + p_avm(ji,jj,jk  ) ) / ( e3t_n(ji,jj,jk  ) * e3w_n(ji,jj,jk) )
+               !                                               ! diagonal
+               zdiag(ji,jj,jk) = 1._wp - zd_lw(ji,jj,jk) - zd_up(ji,jj,jk) + rdt * zdiss * wmask(ji,jj,jk)
+               !                                               ! right hand side in psi
+               psi(ji,jj,jk) = psi(ji,jj,jk) + rdt * zesh2 * wmask(ji,jj,jk)
+            END DO
+         END DO
+      END DO
+      !
+      zdiag(:,:,jpk) = 1._wp
+
+      ! Surface boundary condition on psi
+      ! ---------------------------------
+      !
+      SELECT CASE ( nn_bc_surf )
+      !
+      CASE ( 0 )             ! Dirichlet boundary conditions
+         !
+         ! Surface value
+         zdep    (:,:)   = zhsro(:,:) * rl_sf ! Cosmetic
+         psi     (:,:,1) = rc0**rpp * en(:,:,1)**rmm * zdep(:,:)**rnn * tmask(:,:,1)
+         zd_lw(:,:,1) = psi(:,:,1)
+         zd_up(:,:,1) = 0._wp
+         zdiag(:,:,1) = 1._wp
+         !
+         ! One level below
+         zkar    (:,:)   = (rl_sf + (vkarmn-rl_sf)*(1._wp-EXP(-rtrans*gdepw_n(:,:,2)/zhsro(:,:) )))
+         zdep    (:,:)   = (zhsro(:,:) + gdepw_n(:,:,2)) * zkar(:,:)
+         psi     (:,:,2) = rc0**rpp * en(:,:,2)**rmm * zdep(:,:)**rnn * tmask(:,:,1)
+         zd_lw(:,:,2) = 0._wp
+         zd_up(:,:,2) = 0._wp
+         zdiag(:,:,2) = 1._wp
+         ! 
+      CASE ( 1 )             ! Neumann boundary condition on d(psi)/dz
+         !
+         ! Surface value: Dirichlet
+         zdep    (:,:)   = zhsro(:,:) * rl_sf
+         psi     (:,:,1) = rc0**rpp * en(:,:,1)**rmm * zdep(:,:)**rnn * tmask(:,:,1)
+         zd_lw(:,:,1) = psi(:,:,1)
+         zd_up(:,:,1) = 0._wp
+         zdiag(:,:,1) = 1._wp
+         !
+         ! Neumann condition at k=2
+         zdiag(:,:,2) = zdiag(:,:,2) +  zd_lw(:,:,2) ! Remove zd_lw from zdiag
+         zd_lw(:,:,2) = 0._wp
+         !
+         ! Set psi vertical flux at the surface:
+         zkar (:,:)   = rl_sf + (vkarmn-rl_sf)*(1._wp-EXP(-rtrans*gdept_n(:,:,1)/zhsro(:,:) )) ! Lengh scale slope
+         zdep (:,:)   = ((zhsro(:,:) + gdept_n(:,:,1)) / zhsro(:,:))**(rmm*ra_sf)
+         zflxs(:,:)   = (rnn + rsbc_tke1 * (rnn + rmm*ra_sf) * zdep(:,:))*(1._wp + rsbc_tke1*zdep(:,:))**(2._wp*rmm/3._wp-1_wp)
+         zdep (:,:)   = rsbc_psi1 * (zwall_psi(:,:,1)*p_avm(:,:,1)+zwall_psi(:,:,2)*p_avm(:,:,2)) * &
+            &           ustar2_surf(:,:)**rmm * zkar(:,:)**rnn * (zhsro(:,:) + gdept_n(:,:,1))**(rnn-1.)
+         zflxs(:,:)   = zdep(:,:) * zflxs(:,:)
+         psi  (:,:,2) = psi(:,:,2) + zflxs(:,:) / e3w_n(:,:,2)
+         !
+      END SELECT
+
+      ! Bottom boundary condition on psi
+      ! --------------------------------
+      !
+!!gm should be done for ISF (top boundary cond.)
+!!gm so, totally new staff needed      ===>>> think about that !
+!
+      SELECT CASE ( nn_bc_bot )     ! bottom boundary
+      !
+      CASE ( 0 )             ! Dirichlet 
+         !                      ! en(ibot) = u*^2 / Co2 and hmxl_n(ibot) = vkarmn * r_z0_bot
+         !                      ! Balance between the production and the dissipation terms
+         DO jj = 2, jpjm1
+            DO ji = fs_2, fs_jpim1   ! vector opt.
+               ibot   = mbkt(ji,jj) + 1      ! k   bottom level of w-point
+               ibotm1 = mbkt(ji,jj)          ! k-1 bottom level of w-point but >=1
+               zdep(ji,jj) = vkarmn * r_z0_bot
+               psi (ji,jj,ibot) = rc0**rpp * en(ji,jj,ibot)**rmm * zdep(ji,jj)**rnn
+               zd_lw(ji,jj,ibot) = 0._wp
+               zd_up(ji,jj,ibot) = 0._wp
+               zdiag(ji,jj,ibot) = 1._wp
+               !
+               ! Just above last level, Dirichlet condition again (GOTM like)
+               zdep(ji,jj) = vkarmn * ( r_z0_bot + e3t_n(ji,jj,ibotm1) )
+               psi (ji,jj,ibotm1) = rc0**rpp * en(ji,jj,ibot  )**rmm * zdep(ji,jj)**rnn
+               zd_lw(ji,jj,ibotm1) = 0._wp
+               zd_up(ji,jj,ibotm1) = 0._wp
+               zdiag(ji,jj,ibotm1) = 1._wp
+            END DO
+         END DO
+         !
+      CASE ( 1 )             ! Neumman boundary condition
+         !                      
+         DO jj = 2, jpjm1
+            DO ji = fs_2, fs_jpim1   ! vector opt.
+               ibot   = mbkt(ji,jj) + 1      ! k   bottom level of w-point
+               ibotm1 = mbkt(ji,jj)          ! k-1 bottom level of w-point but >=1
+               !
+               ! Bottom level Dirichlet condition:
+               zdep(ji,jj) = vkarmn * r_z0_bot
+               psi (ji,jj,ibot) = rc0**rpp * en(ji,jj,ibot)**rmm * zdep(ji,jj)**rnn
+               !
+               zd_lw(ji,jj,ibot) = 0._wp
+               zd_up(ji,jj,ibot) = 0._wp
+               zdiag(ji,jj,ibot) = 1._wp
+               !
+               ! Just above last level: Neumann condition with flux injection
+               zdiag(ji,jj,ibotm1) = zdiag(ji,jj,ibotm1) + zd_up(ji,jj,ibotm1) ! Remove zd_up from zdiag
+               zd_up(ji,jj,ibotm1) = 0.
+               !
+               ! Set psi vertical flux at the bottom:
+               zdep(ji,jj) = r_z0_bot + 0.5_wp*e3t_n(ji,jj,ibotm1)
+               zflxb = rsbc_psi2 * ( p_avm(ji,jj,ibot) + p_avm(ji,jj,ibotm1) )   &
+                  &  * (0.5_wp*(en(ji,jj,ibot)+en(ji,jj,ibotm1)))**rmm * zdep(ji,jj)**(rnn-1._wp)
+               psi(ji,jj,ibotm1) = psi(ji,jj,ibotm1) + zflxb / e3w_n(ji,jj,ibotm1)
+            END DO
+         END DO
+         !
+      END SELECT
+
+      ! Matrix inversion
+      ! ----------------
+      !
+      DO jk = 2, jpkm1                             ! First recurrence : Dk = Dk - Lk * Uk-1 / Dk-1
+         DO jj = 2, jpjm1
+            DO ji = fs_2, fs_jpim1    ! vector opt.
+               zdiag(ji,jj,jk) = zdiag(ji,jj,jk) - zd_lw(ji,jj,jk) * zd_up(ji,jj,jk-1) / zdiag(ji,jj,jk-1)
+            END DO
+         END DO
+      END DO
+      DO jk = 2, jpk                               ! Second recurrence : Lk = RHSk - Lk / Dk-1 * Lk-1
+         DO jj = 2, jpjm1
+            DO ji = fs_2, fs_jpim1    ! vector opt.
+               zd_lw(ji,jj,jk) = psi(ji,jj,jk) - zd_lw(ji,jj,jk) / zdiag(ji,jj,jk-1) * zd_lw(ji,jj,jk-1)
+            END DO
+         END DO
+      END DO
+      DO jk = jpk-1, 2, -1                         ! Third recurrence : Ek = ( Lk - Uk * Ek+1 ) / Dk
+         DO jj = 2, jpjm1
+            DO ji = fs_2, fs_jpim1    ! vector opt.
+               psi(ji,jj,jk) = ( zd_lw(ji,jj,jk) - zd_up(ji,jj,jk) * psi(ji,jj,jk+1) ) / zdiag(ji,jj,jk)
+            END DO
+         END DO
+      END DO
+
+      ! Set dissipation
+      !----------------
+
+      SELECT CASE ( nn_clos )
+      !
+      CASE( 0 )               ! k-kl  (Mellor-Yamada)
+         DO jk = 1, jpkm1
+            DO jj = 2, jpjm1
+               DO ji = fs_2, fs_jpim1   ! vector opt.
+                  eps(ji,jj,jk) = rc03 * en(ji,jj,jk) * en(ji,jj,jk) * SQRT( en(ji,jj,jk) ) / MAX( psi(ji,jj,jk), rn_epsmin)
+               END DO
+            END DO
+         END DO
+         !
+      CASE( 1 )               ! k-eps
+         DO jk = 1, jpkm1
+            DO jj = 2, jpjm1
+               DO ji = fs_2, fs_jpim1   ! vector opt.
+                  eps(ji,jj,jk) = psi(ji,jj,jk)
+               END DO
+            END DO
+         END DO
+         !
+      CASE( 2 )               ! k-w
+         DO jk = 1, jpkm1
+            DO jj = 2, jpjm1
+               DO ji = fs_2, fs_jpim1   ! vector opt.
+                  eps(ji,jj,jk) = rc04 * en(ji,jj,jk) * psi(ji,jj,jk) 
+               END DO
+            END DO
+         END DO
+         !
+      CASE( 3 )               ! generic
+         zcoef = rc0**( 3._wp  + rpp/rnn )
+         zex1  =      ( 1.5_wp + rmm/rnn )
+         zex2  = -1._wp / rnn
+         DO jk = 1, jpkm1
+            DO jj = 2, jpjm1
+               DO ji = fs_2, fs_jpim1   ! vector opt.
+                  eps(ji,jj,jk) = zcoef * en(ji,jj,jk)**zex1 * psi(ji,jj,jk)**zex2
+               END DO
+            END DO
+         END DO
+         !
+      END SELECT
+
+      ! Limit dissipation rate under stable stratification
+      ! --------------------------------------------------
+      DO jk = 1, jpkm1 ! Note that this set boundary conditions on hmxl_n at the same time
+         DO jj = 2, jpjm1
+            DO ji = fs_2, fs_jpim1    ! vector opt.
+               ! limitation
+               eps   (ji,jj,jk)  = MAX( eps(ji,jj,jk), rn_epsmin )
+               hmxl_n(ji,jj,jk)  = rc03 * en(ji,jj,jk) * SQRT( en(ji,jj,jk) ) / eps(ji,jj,jk)
+               ! Galperin criterium (NOTE : Not required if the proper value of C3 in stable cases is calculated) 
+               zrn2 = MAX( rn2(ji,jj,jk), rsmall )
+               IF( ln_length_lim )   hmxl_n(ji,jj,jk) = MIN(  rn_clim_galp * SQRT( 2._wp * en(ji,jj,jk) / zrn2 ), hmxl_n(ji,jj,jk) )
+            END DO
+         END DO
+      END DO 
+
+      !
+      ! Stability function and vertical viscosity and diffusivity
+      ! ---------------------------------------------------------
+      !
+      SELECT CASE ( nn_stab_func )
+      !
+      CASE ( 0 , 1 )             ! Galperin or Kantha-Clayson stability functions
+         DO jk = 2, jpkm1
+            DO jj = 2, jpjm1
+               DO ji = fs_2, fs_jpim1   ! vector opt.
+                  ! zcof =  l²/q²
+                  zcof = hmxl_b(ji,jj,jk) * hmxl_b(ji,jj,jk) / ( 2._wp*eb(ji,jj,jk) )
+                  ! Gh = -N²l²/q²
+                  gh = - rn2(ji,jj,jk) * zcof
+                  gh = MIN( gh, rgh0   )
+                  gh = MAX( gh, rghmin )
+                  ! Stability functions from Kantha and Clayson (if C2=C3=0 => Galperin)
+                  sh = ra2*( 1._wp-6._wp*ra1/rb1 ) / ( 1.-3.*ra2*gh*(6.*ra1+rb2*( 1._wp-rc3 ) ) )
+                  sm = ( rb1**(-1._wp/3._wp) + ( 18._wp*ra1*ra1 + 9._wp*ra1*ra2*(1._wp-rc2) )*sh*gh ) / (1._wp-9._wp*ra1*ra2*gh)
+                  !
+                  ! Store stability function in zstt and zstm
+                  zstt(ji,jj,jk) = rc_diff * sh * tmask(ji,jj,jk)
+                  zstm(ji,jj,jk) = rc_diff * sm * tmask(ji,jj,jk)
+               END DO
+            END DO
+         END DO
+         !
+      CASE ( 2, 3 )               ! Canuto stability functions
+         DO jk = 2, jpkm1
+            DO jj = 2, jpjm1
+               DO ji = fs_2, fs_jpim1   ! vector opt.
+                  ! zcof =  l²/q²
+                  zcof = hmxl_b(ji,jj,jk)*hmxl_b(ji,jj,jk) / ( 2._wp * eb(ji,jj,jk) )
+                  ! Gh = -N²l²/q²
+                  gh = - rn2(ji,jj,jk) * zcof
+                  gh = MIN( gh, rgh0   )
+                  gh = MAX( gh, rghmin )
+                  gh = gh * rf6
+                  ! Gm =  M²l²/q² Shear number
+                  shr = p_sh2(ji,jj,jk) / MAX( p_avm(ji,jj,jk), rsmall )
+                  gm = MAX( shr * zcof , 1.e-10 )
+                  gm = gm * rf6
+                  gm = MIN ( (rd0 - rd1*gh + rd3*gh*gh) / (rd2-rd4*gh) , gm )
+                  ! Stability functions from Canuto
+                  rcff = rd0 - rd1*gh +rd2*gm + rd3*gh*gh - rd4*gh*gm + rd5*gm*gm
+                  sm = (rs0 - rs1*gh + rs2*gm) / rcff
+                  sh = (rs4 - rs5*gh + rs6*gm) / rcff
+                  !
+                  ! Store stability function in zstt and zstm
+                  zstt(ji,jj,jk) = rc_diff * sh * tmask(ji,jj,jk)
+                  zstm(ji,jj,jk) = rc_diff * sm * tmask(ji,jj,jk)
+               END DO
+            END DO
+         END DO
+         !
+      END SELECT
+
+      ! Boundary conditions on stability functions for momentum (Neumann):
+      ! Lines below are useless if GOTM style Dirichlet conditions are used
+
+      zstm(:,:,1) = zstm(:,:,2)
+
+      DO jj = 2, jpjm1
+         DO ji = fs_2, fs_jpim1   ! vector opt.
+            zstm(ji,jj,mbkt(ji,jj)+1) = zstm(ji,jj,mbkt(ji,jj))
+         END DO
+      END DO
+!!gm should be done for ISF (top boundary cond.)
+!!gm so, totally new staff needed!!gm
+
+      ! Compute diffusivities/viscosities
+      ! The computation below could be restrained to jk=2 to jpkm1 if GOTM style Dirichlet conditions are used
+      DO jk = 1, jpk
+         DO jj = 2, jpjm1
+            DO ji = fs_2, fs_jpim1   ! vector opt.
+               zsqen = SQRT( 2._wp * en(ji,jj,jk) ) * hmxl_n(ji,jj,jk)
+               zavt  = zsqen * zstt(ji,jj,jk)
+               zavm  = zsqen * zstm(ji,jj,jk)
+               p_avt(ji,jj,jk) = MAX( zavt, avtb(jk) ) * wmask(ji,jj,jk) ! apply mask for zdfmxl routine
+               p_avm(ji,jj,jk) = MAX( zavm, avmb(jk) )                   ! Note that avm is not masked at the surface and the bottom
+            END DO
+         END DO
+      END DO
+      p_avt(:,:,1) = 0._wp
+      !
+      IF(ln_ctl) THEN
+         CALL prt_ctl( tab3d_1=en   , clinfo1=' gls  - e: ', tab3d_2=p_avt, clinfo2=' t: ', kdim=jpk)
+         CALL prt_ctl( tab3d_1=p_avm, clinfo1=' gls  - m: ', kdim=jpk )
+      ENDIF
+      !
+   END SUBROUTINE zdf_gls
+
+
+   SUBROUTINE zdf_gls_init
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE zdf_gls_init  ***
+      !!                     
+      !! ** Purpose :   Initialization of the vertical eddy diffivity and 
+      !!              viscosity computed using a GLS turbulent closure scheme
+      !!
+      !! ** Method  :   Read the namzdf_gls namelist and check the parameters
+      !!
+      !! ** input   :   Namlist namzdf_gls
+      !!
+      !! ** Action  :   Increase by 1 the nstop flag is setting problem encounter
+      !!
+      !!----------------------------------------------------------------------
+      INTEGER ::   jk    ! dummy loop indices
+      INTEGER ::   ios   ! Local integer output status for namelist read
+      REAL(wp)::   zcr   ! local scalar
+      !!
+      NAMELIST/namzdf_gls/rn_emin, rn_epsmin, ln_length_lim, &
+         &            rn_clim_galp, ln_sigpsi, rn_hsro,      &
+         &            rn_crban, rn_charn, rn_frac_hs,        &
+         &            nn_bc_surf, nn_bc_bot, nn_z0_met,      &
+         &            nn_stab_func, nn_clos
+      !!----------------------------------------------------------
+      !
+      REWIND( numnam_ref )              ! Namelist namzdf_gls in reference namelist : Vertical eddy diffivity and viscosity using gls turbulent closure scheme
+      READ  ( numnam_ref, namzdf_gls, IOSTAT = ios, ERR = 901)
+901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namzdf_gls in reference namelist', lwp )
+
+      REWIND( numnam_cfg )              ! Namelist namzdf_gls in configuration namelist : Vertical eddy diffivity and viscosity using gls turbulent closure scheme
+      READ  ( numnam_cfg, namzdf_gls, IOSTAT = ios, ERR = 902 )
+902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namzdf_gls in configuration namelist', lwp )
+      IF(lwm) WRITE ( numond, namzdf_gls )
+
+      IF(lwp) THEN                     !* Control print
+         WRITE(numout,*)
+         WRITE(numout,*) 'zdf_gls_init : GLS turbulent closure scheme'
+         WRITE(numout,*) '~~~~~~~~~~~~'
+         WRITE(numout,*) '   Namelist namzdf_gls : set gls mixing parameters'
+         WRITE(numout,*) '      minimum value of en                           rn_emin        = ', rn_emin
+         WRITE(numout,*) '      minimum value of eps                          rn_epsmin      = ', rn_epsmin
+         WRITE(numout,*) '      Limit dissipation rate under stable stratif.  ln_length_lim  = ', ln_length_lim
+         WRITE(numout,*) '      Galperin limit (Standard: 0.53, Holt: 0.26)   rn_clim_galp   = ', rn_clim_galp
+         WRITE(numout,*) '      TKE Surface boundary condition                nn_bc_surf     = ', nn_bc_surf
+         WRITE(numout,*) '      TKE Bottom boundary condition                 nn_bc_bot      = ', nn_bc_bot
+         WRITE(numout,*) '      Modify psi Schmidt number (wb case)           ln_sigpsi      = ', ln_sigpsi
+         WRITE(numout,*) '      Craig and Banner coefficient                  rn_crban       = ', rn_crban
+         WRITE(numout,*) '      Charnock coefficient                          rn_charn       = ', rn_charn
+         WRITE(numout,*) '      Surface roughness formula                     nn_z0_met      = ', nn_z0_met
+         WRITE(numout,*) '      Wave height frac. (used if nn_z0_met=2)       rn_frac_hs     = ', rn_frac_hs
+         WRITE(numout,*) '      Stability functions                           nn_stab_func   = ', nn_stab_func
+         WRITE(numout,*) '      Type of closure                               nn_clos        = ', nn_clos
+         WRITE(numout,*) '      Surface roughness (m)                         rn_hsro        = ', rn_hsro
+         WRITE(numout,*)
+         WRITE(numout,*) '   Namelist namdrg_top/_bot:   used values:'
+         WRITE(numout,*) '      top    ocean cavity roughness (m)             rn_z0(_top)   = ', r_z0_top
+         WRITE(numout,*) '      Bottom seafloor     roughness (m)             rn_z0(_bot)   = ', r_z0_bot
+         WRITE(numout,*)
+      ENDIF
+
+      !                                !* allocate GLS arrays
+      IF( zdf_gls_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'zdf_gls_init : unable to allocate arrays' )
+
+      !                                !* Check of some namelist values
+      IF( nn_bc_surf < 0   .OR. nn_bc_surf   > 1 )   CALL ctl_stop( 'zdf_gls_init: bad flag: nn_bc_surf is 0 or 1' )
+      IF( nn_bc_surf < 0   .OR. nn_bc_surf   > 1 )   CALL ctl_stop( 'zdf_gls_init: bad flag: nn_bc_surf is 0 or 1' )
+      IF( nn_z0_met  < 0   .OR. nn_z0_met    > 3 )   CALL ctl_stop( 'zdf_gls_init: bad flag: nn_z0_met is 0, 1, 2 or 3' )
+      IF( nn_z0_met == 3  .AND. .NOT.ln_wave     )   CALL ctl_stop( 'zdf_gls_init: nn_z0_met=3 requires ln_wave=T' )
+      IF( nn_stab_func < 0 .OR. nn_stab_func > 3 )   CALL ctl_stop( 'zdf_gls_init: bad flag: nn_stab_func is 0, 1, 2 and 3' )
+      IF( nn_clos      < 0 .OR. nn_clos      > 3 )   CALL ctl_stop( 'zdf_gls_init: bad flag: nn_clos is 0, 1, 2 or 3' )
+
+      SELECT CASE ( nn_clos )          !* set the parameters for the chosen closure
+      !
+      CASE( 0 )                              ! k-kl  (Mellor-Yamada)
+         !
+         IF(lwp) WRITE(numout,*) '   ==>>   k-kl closure chosen (i.e. closed to the classical Mellor-Yamada)'
+         IF(lwp) WRITE(numout,*)
+         rpp     = 0._wp
+         rmm     = 1._wp
+         rnn     = 1._wp
+         rsc_tke = 1.96_wp
+         rsc_psi = 1.96_wp
+         rpsi1   = 0.9_wp
+         rpsi3p  = 1._wp
+         rpsi2   = 0.5_wp
+         !
+         SELECT CASE ( nn_stab_func )
+         CASE( 0, 1 )   ;   rpsi3m = 2.53_wp       ! G88 or KC stability functions
+         CASE( 2 )      ;   rpsi3m = 2.62_wp       ! Canuto A stability functions
+         CASE( 3 )      ;   rpsi3m = 2.38          ! Canuto B stability functions (caution : constant not identified)
+         END SELECT
+         !
+      CASE( 1 )                              ! k-eps
+         !
+         IF(lwp) WRITE(numout,*) '   ==>>   k-eps closure chosen'
+         IF(lwp) WRITE(numout,*)
+         rpp     =  3._wp
+         rmm     =  1.5_wp
+         rnn     = -1._wp
+         rsc_tke =  1._wp
+         rsc_psi =  1.2_wp  ! Schmidt number for psi
+         rpsi1   =  1.44_wp
+         rpsi3p  =  1._wp
+         rpsi2   =  1.92_wp
+         !
+         SELECT CASE ( nn_stab_func )
+         CASE( 0, 1 )   ;   rpsi3m = -0.52_wp      ! G88 or KC stability functions
+         CASE( 2 )      ;   rpsi3m = -0.629_wp     ! Canuto A stability functions
+         CASE( 3 )      ;   rpsi3m = -0.566        ! Canuto B stability functions
+         END SELECT
+         !
+      CASE( 2 )                              ! k-omega
+         !
+         IF(lwp) WRITE(numout,*) '   ==>>   k-omega closure chosen'
+         IF(lwp) WRITE(numout,*)
+         rpp     = -1._wp
+         rmm     =  0.5_wp
+         rnn     = -1._wp
+         rsc_tke =  2._wp
+         rsc_psi =  2._wp
+         rpsi1   =  0.555_wp
+         rpsi3p  =  1._wp
+         rpsi2   =  0.833_wp
+         !
+         SELECT CASE ( nn_stab_func )
+         CASE( 0, 1 )   ;   rpsi3m = -0.58_wp       ! G88 or KC stability functions
+         CASE( 2 )      ;   rpsi3m = -0.64_wp       ! Canuto A stability functions
+         CASE( 3 )      ;   rpsi3m = -0.64_wp       ! Canuto B stability functions caution : constant not identified)
+         END SELECT
+         !
+      CASE( 3 )                              ! generic
+         !
+         IF(lwp) WRITE(numout,*) '   ==>>   generic closure chosen'
+         IF(lwp) WRITE(numout,*)
+         rpp     = 2._wp
+         rmm     = 1._wp
+         rnn     = -0.67_wp
+         rsc_tke = 0.8_wp
+         rsc_psi = 1.07_wp
+         rpsi1   = 1._wp
+         rpsi3p  = 1._wp
+         rpsi2   = 1.22_wp
+         !
+         SELECT CASE ( nn_stab_func )
+         CASE( 0, 1 )   ;   rpsi3m = 0.1_wp         ! G88 or KC stability functions
+         CASE( 2 )      ;   rpsi3m = 0.05_wp        ! Canuto A stability functions
+         CASE( 3 )      ;   rpsi3m = 0.05_wp        ! Canuto B stability functions caution : constant not identified)
+         END SELECT
+         !
+      END SELECT
+
+      !
+      SELECT CASE ( nn_stab_func )     !* set the parameters of the stability functions
+      !
+      CASE ( 0 )                             ! Galperin stability functions
+         !
+         IF(lwp) WRITE(numout,*) '   ==>>   Stability functions from Galperin'
+         rc2     =  0._wp
+         rc3     =  0._wp
+         rc_diff =  1._wp
+         rc0     =  0.5544_wp
+         rcm_sf  =  0.9884_wp
+         rghmin  = -0.28_wp
+         rgh0    =  0.0233_wp
+         rghcri  =  0.02_wp
+         !
+      CASE ( 1 )                             ! Kantha-Clayson stability functions
+         !
+         IF(lwp) WRITE(numout,*) '   ==>>   Stability functions from Kantha-Clayson'
+         rc2     =  0.7_wp
+         rc3     =  0.2_wp
+         rc_diff =  1._wp
+         rc0     =  0.5544_wp
+         rcm_sf  =  0.9884_wp
+         rghmin  = -0.28_wp
+         rgh0    =  0.0233_wp
+         rghcri  =  0.02_wp
+         !
+      CASE ( 2 )                             ! Canuto A stability functions
+         !
+         IF(lwp) WRITE(numout,*) '   ==>>   Stability functions from Canuto A'
+         rs0 = 1.5_wp * rl1 * rl5*rl5
+         rs1 = -rl4*(rl6+rl7) + 2._wp*rl4*rl5*(rl1-(1._wp/3._wp)*rl2-rl3) + 1.5_wp*rl1*rl5*rl8
+         rs2 = -(3._wp/8._wp) * rl1*(rl6*rl6-rl7*rl7)
+         rs4 = 2._wp * rl5
+         rs5 = 2._wp * rl4
+         rs6 = (2._wp/3._wp) * rl5 * ( 3._wp*rl3*rl3 - rl2*rl2 ) - 0.5_wp * rl5*rl1 * (3._wp*rl3-rl2)   &
+            &                                                    + 0.75_wp * rl1 * ( rl6 - rl7 )
+         rd0 = 3._wp * rl5*rl5
+         rd1 = rl5 * ( 7._wp*rl4 + 3._wp*rl8 )
+         rd2 = rl5*rl5 * ( 3._wp*rl3*rl3 - rl2*rl2 ) - 0.75_wp*(rl6*rl6 - rl7*rl7 )
+         rd3 = rl4 * ( 4._wp*rl4 + 3._wp*rl8)
+         rd4 = rl4 * ( rl2 * rl6 - 3._wp*rl3*rl7 - rl5*(rl2*rl2 - rl3*rl3 ) ) + rl5*rl8 * ( 3._wp*rl3*rl3 - rl2*rl2 )
+         rd5 = 0.25_wp * ( rl2*rl2 - 3._wp *rl3*rl3 ) * ( rl6*rl6 - rl7*rl7 )
+         rc0 = 0.5268_wp
+         rf6 = 8._wp / (rc0**6._wp)
+         rc_diff = SQRT(2._wp) / (rc0**3._wp)
+         rcm_sf  =  0.7310_wp
+         rghmin  = -0.28_wp
+         rgh0    =  0.0329_wp
+         rghcri  =  0.03_wp
+         !
+      CASE ( 3 )                             ! Canuto B stability functions
+         !
+         IF(lwp) WRITE(numout,*) '   ==>>   Stability functions from Canuto B'
+         rs0 = 1.5_wp * rm1 * rm5*rm5
+         rs1 = -rm4 * (rm6+rm7) + 2._wp * rm4*rm5*(rm1-(1._wp/3._wp)*rm2-rm3) + 1.5_wp * rm1*rm5*rm8
+         rs2 = -(3._wp/8._wp) * rm1 * (rm6*rm6-rm7*rm7 )
+         rs4 = 2._wp * rm5
+         rs5 = 2._wp * rm4
+         rs6 = (2._wp/3._wp) * rm5 * (3._wp*rm3*rm3-rm2*rm2) - 0.5_wp * rm5*rm1*(3._wp*rm3-rm2) + 0.75_wp * rm1*(rm6-rm7)
+         rd0 = 3._wp * rm5*rm5
+         rd1 = rm5 * (7._wp*rm4 + 3._wp*rm8)
+         rd2 = rm5*rm5 * (3._wp*rm3*rm3 - rm2*rm2) - 0.75_wp * (rm6*rm6 - rm7*rm7)
+         rd3 = rm4 * ( 4._wp*rm4 + 3._wp*rm8 )
+         rd4 = rm4 * ( rm2*rm6 -3._wp*rm3*rm7 - rm5*(rm2*rm2 - rm3*rm3) ) + rm5 * rm8 * ( 3._wp*rm3*rm3 - rm2*rm2 )
+         rd5 = 0.25_wp * ( rm2*rm2 - 3._wp*rm3*rm3 ) * ( rm6*rm6 - rm7*rm7 )
+         rc0 = 0.5268_wp            !!       rc0 = 0.5540_wp (Warner ...) to verify !
+         rf6 = 8._wp / ( rc0**6._wp )
+         rc_diff = SQRT(2._wp)/(rc0**3.)
+         rcm_sf  =  0.7470_wp
+         rghmin  = -0.28_wp
+         rgh0    =  0.0444_wp
+         rghcri  =  0.0414_wp
+         !
+      END SELECT
+    
+      !                                !* Set Schmidt number for psi diffusion in the wave breaking case
+      !                                     ! See Eq. (13) of Carniel et al, OM, 30, 225-239, 2009
+      !                                     !  or Eq. (17) of Burchard, JPO, 31, 3133-3145, 2001
+      IF( ln_sigpsi ) THEN
+         ra_sf = -1.5 ! Set kinetic energy slope, then deduce rsc_psi and rl_sf 
+         ! Verification: retrieve Burchard (2001) results by uncomenting the line below:
+         ! Note that the results depend on the value of rn_cm_sf which is constant (=rc0) in his work
+         ! ra_sf = -SQRT(2./3.*rc0**3./rn_cm_sf*rn_sc_tke)/vkarmn
+         rsc_psi0 = rsc_tke/(24.*rpsi2)*(-1.+(4.*rnn + ra_sf*(1.+4.*rmm))**2./(ra_sf**2.))
+      ELSE
+         rsc_psi0 = rsc_psi
+      ENDIF
+ 
+      !                                !* Shear free turbulence parameters
+      !
+      ra_sf  = -4._wp*rnn*SQRT(rsc_tke) / ( (1._wp+4._wp*rmm)*SQRT(rsc_tke) &
+               &                              - SQRT(rsc_tke + 24._wp*rsc_psi0*rpsi2 ) )
+
+      IF ( rn_crban==0._wp ) THEN
+         rl_sf = vkarmn
+      ELSE
+         rl_sf = rc0 * SQRT(rc0/rcm_sf) * SQRT( ( (1._wp + 4._wp*rmm + 8._wp*rmm**2_wp) * rsc_tke        &
+            &                                            + 12._wp*rsc_psi0*rpsi2 - (1._wp + 4._wp*rmm)   &
+            &                                                     *SQRT(rsc_tke*(rsc_tke                 &
+            &                                                        + 24._wp*rsc_psi0*rpsi2)) )         &
+            &                                              /(12._wp*rnn**2.)                             )
+      ENDIF
+
+      !
+      IF(lwp) THEN                     !* Control print
+         WRITE(numout,*)
+         WRITE(numout,*) '   Limit values :'
+         WRITE(numout,*) '      Parameter  m = ', rmm
+         WRITE(numout,*) '      Parameter  n = ', rnn
+         WRITE(numout,*) '      Parameter  p = ', rpp
+         WRITE(numout,*) '      rpsi1    = ', rpsi1
+         WRITE(numout,*) '      rpsi2    = ', rpsi2
+         WRITE(numout,*) '      rpsi3m   = ', rpsi3m
+         WRITE(numout,*) '      rpsi3p   = ', rpsi3p
+         WRITE(numout,*) '      rsc_tke  = ', rsc_tke
+         WRITE(numout,*) '      rsc_psi  = ', rsc_psi
+         WRITE(numout,*) '      rsc_psi0 = ', rsc_psi0
+         WRITE(numout,*) '      rc0      = ', rc0
+         WRITE(numout,*)
+         WRITE(numout,*) '   Shear free turbulence parameters:'
+         WRITE(numout,*) '      rcm_sf   = ', rcm_sf
+         WRITE(numout,*) '      ra_sf    = ', ra_sf
+         WRITE(numout,*) '      rl_sf    = ', rl_sf
+      ENDIF
+
+      !                                !* Constants initialization
+      rc02  = rc0  * rc0   ;   rc02r = 1. / rc02
+      rc03  = rc02 * rc0
+      rc04  = rc03 * rc0
+      rsbc_tke1 = -3._wp/2._wp*rn_crban*ra_sf*rl_sf                      ! Dirichlet + Wave breaking
+      rsbc_tke2 = rdt * rn_crban / rl_sf                                 ! Neumann + Wave breaking 
+      zcr = MAX(rsmall, rsbc_tke1**(1./(-ra_sf*3._wp/2._wp))-1._wp )
+      rtrans = 0.2_wp / zcr                                              ! Ad. inverse transition length between log and wave layer 
+      rsbc_zs1  = rn_charn/grav                                          ! Charnock formula for surface roughness
+      rsbc_zs2  = rn_frac_hs / 0.85_wp / grav * 665._wp                  ! Rascle formula for surface roughness 
+      rsbc_psi1 = -0.5_wp * rdt * rc0**(rpp-2._wp*rmm) / rsc_psi
+      rsbc_psi2 = -0.5_wp * rdt * rc0**rpp * rnn * vkarmn**rnn / rsc_psi ! Neumann + NO Wave breaking 
+      !
+      rfact_tke = -0.5_wp / rsc_tke * rdt                                ! Cst used for the Diffusion term of tke
+      rfact_psi = -0.5_wp / rsc_psi * rdt                                ! Cst used for the Diffusion term of tke
+      !
+      !                                !* Wall proximity function
+!!gm tmask or wmask ????
+      zwall(:,:,:) = 1._wp * tmask(:,:,:)
+
+      !                                !* read or initialize all required files  
+      CALL gls_rst( nit000, 'READ' )      ! (en, avt_k, avm_k, hmxl_n)
+      !
+      IF( lwxios ) THEN
+         CALL iom_set_rstw_var_active('en')
+         CALL iom_set_rstw_var_active('avt_k')
+         CALL iom_set_rstw_var_active('avm_k')
+         CALL iom_set_rstw_var_active('hmxl_n')
+      ENDIF
+      !
+   END SUBROUTINE zdf_gls_init
+
+
+   SUBROUTINE gls_rst( kt, cdrw )
+      !!---------------------------------------------------------------------
+      !!                   ***  ROUTINE gls_rst  ***
+      !!                     
+      !! ** Purpose :   Read or write TKE file (en) in restart file
+      !!
+      !! ** Method  :   use of IOM library
+      !!                if the restart does not contain TKE, en is either 
+      !!                set to rn_emin or recomputed (nn_igls/=0)
+      !!----------------------------------------------------------------------
+      USE zdf_oce , ONLY : en, avt_k, avm_k   ! ocean vertical physics
+      !!
+      INTEGER         , INTENT(in) ::   kt     ! ocean time-step
+      CHARACTER(len=*), INTENT(in) ::   cdrw   ! "READ"/"WRITE" flag
+      !
+      INTEGER ::   jit, jk   ! dummy loop indices
+      INTEGER ::   id1, id2, id3, id4
+      INTEGER ::   ji, jj, ikbu, ikbv
+      REAL(wp)::   cbx, cby
+      !!----------------------------------------------------------------------
+      !
+      IF( TRIM(cdrw) == 'READ' ) THEN        ! Read/initialise 
+         !                                   ! ---------------
+         IF( ln_rstart ) THEN                   !* Read the restart file
+            id1 = iom_varid( numror, 'en'    , ldstop = .FALSE. )
+            id2 = iom_varid( numror, 'avt_k' , ldstop = .FALSE. )
+            id3 = iom_varid( numror, 'avm_k' , ldstop = .FALSE. )
+            id4 = iom_varid( numror, 'hmxl_n', ldstop = .FALSE. )
+            !
+            IF( MIN( id1, id2, id3, id4 ) > 0 ) THEN        ! all required arrays exist
+               CALL iom_get( numror, jpdom_autoglo, 'en'    , en    , ldxios = lrxios )
+               CALL iom_get( numror, jpdom_autoglo, 'avt_k' , avt_k , ldxios = lrxios )
+               CALL iom_get( numror, jpdom_autoglo, 'avm_k' , avm_k , ldxios = lrxios )
+               CALL iom_get( numror, jpdom_autoglo, 'hmxl_n', hmxl_n, ldxios = lrxios )
+            ELSE                        
+               IF(lwp) WRITE(numout,*)
+               IF(lwp) WRITE(numout,*) '   ==>>   previous run without GLS scheme, set en and hmxl_n to background values'
+               en    (:,:,:) = rn_emin
+               hmxl_n(:,:,:) = 0.05_wp
+               ! avt_k, avm_k already set to the background value in zdf_phy_init
+            ENDIF
+         ELSE                                   !* Start from rest
+            IF(lwp) WRITE(numout,*)
+            IF(lwp) WRITE(numout,*) '   ==>>   start from rest, set en and hmxl_n by background values'
+            en    (:,:,:) = rn_emin
+            hmxl_n(:,:,:) = 0.05_wp
+            ! avt_k, avm_k already set to the background value in zdf_phy_init
+         ENDIF
+         !
+      ELSEIF( TRIM(cdrw) == 'WRITE' ) THEN   ! Create restart file
+         !                                   ! -------------------
+         IF(lwp) WRITE(numout,*) '---- gls-rst ----'
+         IF( lwxios ) CALL iom_swap(      cwxios_context         )
+         CALL iom_rstput( kt, nitrst, numrow, 'en'    , en    , ldxios = lwxios )
+         CALL iom_rstput( kt, nitrst, numrow, 'avt_k' , avt_k , ldxios = lwxios )
+         CALL iom_rstput( kt, nitrst, numrow, 'avm_k' , avm_k , ldxios = lwxios )
+         CALL iom_rstput( kt, nitrst, numrow, 'hmxl_n', hmxl_n, ldxios = lwxios )
+         IF( lwxios ) CALL iom_swap(      cxios_context          )
+         !
+      ENDIF
+      !
+   END SUBROUTINE gls_rst
+
+   !!======================================================================
+END MODULE zdfgls
+
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/ZDF/zdfiwm.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/ZDF/zdfiwm.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/ZDF/zdfiwm.F90	(revision 9570)
@@ -0,0 +1,477 @@
+MODULE zdfiwm
+   !!========================================================================
+   !!                       ***  MODULE  zdfiwm  ***
+   !! Ocean physics: Internal gravity wave-driven vertical mixing
+   !!========================================================================
+   !! History :  1.0  !  2004-04  (L. Bessieres, G. Madec)  Original code
+   !!             -   !  2006-08  (A. Koch-Larrouy)  Indonesian strait
+   !!            3.3  !  2010-10  (C. Ethe, G. Madec)  reorganisation of initialisation phase
+   !!            3.6  !  2016-03  (C. de Lavergne)  New param: internal wave-driven mixing 
+   !!            4.0  !  2017-04  (G. Madec)  renamed module, remove the old param. and the CPP keys
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   zdf_iwm       : global     momentum & tracer Kz with wave induced Kz
+   !!   zdf_iwm_init  : global     momentum & tracer Kz with wave induced Kz
+   !!----------------------------------------------------------------------
+   USE oce            ! ocean dynamics and tracers variables
+   USE dom_oce        ! ocean space and time domain variables
+   USE zdf_oce        ! ocean vertical physics variables
+   USE zdfddm         ! ocean vertical physics: double diffusive mixing
+   USE lbclnk         ! ocean lateral boundary conditions (or mpp link)
+   USE eosbn2         ! ocean equation of state
+   USE phycst         ! physical constants
+   !
+   USE prtctl         ! Print control
+   USE in_out_manager ! I/O manager
+   USE iom            ! I/O Manager
+   USE lib_mpp        ! MPP library
+   USE lib_fortran    ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined)  
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   zdf_iwm        ! called in step module 
+   PUBLIC   zdf_iwm_init   ! called in nemogcm module 
+
+   !                      !!* Namelist  namzdf_iwm : internal wave-driven mixing *
+   INTEGER ::  nn_zpyc     ! pycnocline-intensified mixing energy proportional to N (=1) or N^2 (=2)
+   LOGICAL ::  ln_mevar    ! variable (=T) or constant (=F) mixing efficiency
+   LOGICAL ::  ln_tsdiff   ! account for differential T/S wave-driven mixing (=T) or not (=F)
+
+   REAL(wp)::  r1_6 = 1._wp / 6._wp
+
+   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   ebot_iwm   ! power available from high-mode wave breaking (W/m2)
+   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   epyc_iwm   ! power available from low-mode, pycnocline-intensified wave breaking (W/m2)
+   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   ecri_iwm   ! power available from low-mode, critical slope wave breaking (W/m2)
+   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hbot_iwm   ! WKB decay scale for high-mode energy dissipation (m)
+   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hcri_iwm   ! decay scale for low-mode critical slope dissipation (m)
+
+   !! * Substitutions
+#  include "vectopt_loop_substitute.h90"
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 4.0 , NEMO Consortium (2016)
+   !! $Id: zdfiwm.F90 8093 2017-05-30 08:13:14Z gm $
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   INTEGER FUNCTION zdf_iwm_alloc()
+      !!----------------------------------------------------------------------
+      !!                ***  FUNCTION zdf_iwm_alloc  ***
+      !!----------------------------------------------------------------------
+      ALLOCATE( ebot_iwm(jpi,jpj),  epyc_iwm(jpi,jpj),  ecri_iwm(jpi,jpj) ,     &
+      &         hbot_iwm(jpi,jpj),  hcri_iwm(jpi,jpj)                     , STAT=zdf_iwm_alloc )
+      !
+      IF( lk_mpp             )   CALL mpp_sum ( zdf_iwm_alloc )
+      IF( zdf_iwm_alloc /= 0 )   CALL ctl_warn('zdf_iwm_alloc: failed to allocate arrays')
+   END FUNCTION zdf_iwm_alloc
+
+
+   SUBROUTINE zdf_iwm( kt, p_avm, p_avt, p_avs )
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE zdf_iwm  ***
+      !!                   
+      !! ** Purpose :   add to the vertical mixing coefficients the effect of
+      !!              breaking internal waves.
+      !!
+      !! ** Method  : - internal wave-driven vertical mixing is given by:
+      !!                  Kz_wave = min(  100 cm2/s, f(  Reb = zemx_iwm /( Nu * N^2 )  )
+      !!              where zemx_iwm is the 3D space distribution of the wave-breaking 
+      !!              energy and Nu the molecular kinematic viscosity.
+      !!              The function f(Reb) is linear (constant mixing efficiency)
+      !!              if the namelist parameter ln_mevar = F and nonlinear if ln_mevar = T.
+      !!
+      !!              - Compute zemx_iwm, the 3D power density that allows to compute
+      !!              Reb and therefrom the wave-induced vertical diffusivity.
+      !!              This is divided into three components:
+      !!                 1. Bottom-intensified low-mode dissipation at critical slopes
+      !!                     zemx_iwm(z) = ( ecri_iwm / rau0 ) * EXP( -(H-z)/hcri_iwm )
+      !!                                   / ( 1. - EXP( - H/hcri_iwm ) ) * hcri_iwm
+      !!              where hcri_iwm is the characteristic length scale of the bottom 
+      !!              intensification, ecri_iwm a map of available power, and H the ocean depth.
+      !!                 2. Pycnocline-intensified low-mode dissipation
+      !!                     zemx_iwm(z) = ( epyc_iwm / rau0 ) * ( sqrt(rn2(z))^nn_zpyc )
+      !!                                   / SUM( sqrt(rn2(z))^nn_zpyc * e3w(z) )
+      !!              where epyc_iwm is a map of available power, and nn_zpyc
+      !!              is the chosen stratification-dependence of the internal wave
+      !!              energy dissipation.
+      !!                 3. WKB-height dependent high mode dissipation
+      !!                     zemx_iwm(z) = ( ebot_iwm / rau0 ) * rn2(z) * EXP(-z_wkb(z)/hbot_iwm)
+      !!                                   / SUM( rn2(z) * EXP(-z_wkb(z)/hbot_iwm) * e3w(z) )
+      !!              where hbot_iwm is the characteristic length scale of the WKB bottom 
+      !!              intensification, ebot_iwm is a map of available power, and z_wkb is the
+      !!              WKB-stretched height above bottom defined as
+      !!                    z_wkb(z) = H * SUM( sqrt(rn2(z'>=z)) * e3w(z'>=z) )
+      !!                                 / SUM( sqrt(rn2(z'))    * e3w(z')    )
+      !!
+      !!              - update the model vertical eddy viscosity and diffusivity: 
+      !!                     avt  = avt  +    av_wave
+      !!                     avm  = avm  +    av_wave
+      !!
+      !!              - if namelist parameter ln_tsdiff = T, account for differential mixing:
+      !!                     avs  = avt  +    av_wave * diffusivity_ratio(Reb)
+      !!
+      !! ** Action  : - avt, avs, avm, increased by tide internal wave-driven mixing    
+      !!
+      !! References :  de Lavergne et al. 2015, JPO; 2016, in prep.
+      !!----------------------------------------------------------------------
+      INTEGER                    , INTENT(in   ) ::   kt             ! ocean time step
+      REAL(wp), DIMENSION(:,:,:) , INTENT(inout) ::   p_avm          ! momentum Kz (w-points)
+      REAL(wp), DIMENSION(:,:,:) , INTENT(inout) ::   p_avt, p_avs   ! tracer   Kz (w-points)
+      !
+      INTEGER  ::   ji, jj, jk   ! dummy loop indices
+      REAL(wp) ::   zztmp        ! scalar workspace
+      REAL(wp), DIMENSION(jpi,jpj)     ::   zfact       ! Used for vertical structure
+      REAL(wp), DIMENSION(jpi,jpj)     ::   zhdep       ! Ocean depth
+      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zwkb        ! WKB-stretched height above bottom
+      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zweight     ! Weight for high mode vertical distribution
+      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   znu_t       ! Molecular kinematic viscosity (T grid)
+      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   znu_w       ! Molecular kinematic viscosity (W grid)
+      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zReb        ! Turbulence intensity parameter
+      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zemx_iwm    ! local energy density available for mixing (W/kg)
+      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zav_ratio   ! S/T diffusivity ratio (only for ln_tsdiff=T)
+      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zav_wave    ! Internal wave-induced diffusivity
+      REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) ::   z3d  ! 3D workspace used for iom_put 
+      REAL(wp), ALLOCATABLE, DIMENSION(:,:)   ::   z2d  ! 2D     -      -    -     -
+      !!----------------------------------------------------------------------
+      !
+      !                       !* Set to zero the 1st and last vertical levels of appropriate variables
+      zemx_iwm (:,:,1) = 0._wp   ;   zemx_iwm (:,:,jpk) = 0._wp
+      zav_ratio(:,:,1) = 0._wp   ;   zav_ratio(:,:,jpk) = 0._wp
+      zav_wave (:,:,1) = 0._wp   ;   zav_wave (:,:,jpk) = 0._wp
+      !
+      !                       ! ----------------------------- !
+      !                       !  Internal wave-driven mixing  !  (compute zav_wave)
+      !                       ! ----------------------------- !
+      !                             
+      !                       !* Critical slope mixing: distribute energy over the time-varying ocean depth,
+      !                                                 using an exponential decay from the seafloor.
+      DO jj = 1, jpj                ! part independent of the level
+         DO ji = 1, jpi
+            zhdep(ji,jj) = gdepw_0(ji,jj,mbkt(ji,jj)+1)       ! depth of the ocean
+            zfact(ji,jj) = rau0 * (  1._wp - EXP( -zhdep(ji,jj) / hcri_iwm(ji,jj) )  )
+            IF( zfact(ji,jj) /= 0._wp )   zfact(ji,jj) = ecri_iwm(ji,jj) / zfact(ji,jj)
+         END DO
+      END DO
+!!gm gde3w ==>>>  check for ssh taken into account.... seem OK gde3w_n=gdept_n - sshn
+      DO jk = 2, jpkm1              ! complete with the level-dependent part
+         zemx_iwm(:,:,jk) = zfact(:,:) * (  EXP( ( gde3w_n(:,:,jk  ) - zhdep(:,:) ) / hcri_iwm(:,:) )                      &
+            &                             - EXP( ( gde3w_n(:,:,jk-1) - zhdep(:,:) ) / hcri_iwm(:,:) )  ) * wmask(:,:,jk)   &
+            &                          / ( gde3w_n(:,:,jk) - gde3w_n(:,:,jk-1) )
+
+!!gm delta(gde3w_n) = e3t_n  !!  Please verify the grid-point position w versus t-point
+!!gm it seems to me that only 1/hcri_iwm  is used ==>  compute it one for all
+
+      END DO
+
+      !                        !* Pycnocline-intensified mixing: distribute energy over the time-varying 
+      !                        !* ocean depth as proportional to sqrt(rn2)^nn_zpyc
+      !                                          ! (NB: N2 is masked, so no use of wmask here)
+      SELECT CASE ( nn_zpyc )
+      !
+      CASE ( 1 )               ! Dissipation scales as N (recommended)
+         !
+         zfact(:,:) = 0._wp
+         DO jk = 2, jpkm1              ! part independent of the level
+            zfact(:,:) = zfact(:,:) + e3w_n(:,:,jk) * SQRT(  MAX( 0._wp, rn2(:,:,jk) )  ) * wmask(:,:,jk)
+         END DO
+         !
+         DO jj = 1, jpj
+            DO ji = 1, jpi
+               IF( zfact(ji,jj) /= 0 )   zfact(ji,jj) = epyc_iwm(ji,jj) / ( rau0 * zfact(ji,jj) )
+            END DO
+         END DO
+         !
+         DO jk = 2, jpkm1              ! complete with the level-dependent part
+            zemx_iwm(:,:,jk) = zemx_iwm(:,:,jk) + zfact(:,:) * SQRT(  MAX( 0._wp, rn2(:,:,jk) )  ) * wmask(:,:,jk)
+         END DO
+         !
+      CASE ( 2 )               ! Dissipation scales as N^2
+         !
+         zfact(:,:) = 0._wp
+         DO jk = 2, jpkm1              ! part independent of the level
+            zfact(:,:) = zfact(:,:) + e3w_n(:,:,jk) * MAX( 0._wp, rn2(:,:,jk) ) * wmask(:,:,jk)
+         END DO
+         !
+         DO jj= 1, jpj
+            DO ji = 1, jpi
+               IF( zfact(ji,jj) /= 0 )   zfact(ji,jj) = epyc_iwm(ji,jj) / ( rau0 * zfact(ji,jj) )
+            END DO
+         END DO
+         !
+         DO jk = 2, jpkm1              ! complete with the level-dependent part
+            zemx_iwm(:,:,jk) = zemx_iwm(:,:,jk) + zfact(:,:) * MAX( 0._wp, rn2(:,:,jk) ) * wmask(:,:,jk)
+         END DO
+         !
+      END SELECT
+
+      !                        !* WKB-height dependent mixing: distribute energy over the time-varying 
+      !                        !* ocean depth as proportional to rn2 * exp(-z_wkb/rn_hbot)
+      !
+      zwkb (:,:,:) = 0._wp
+      zfact(:,:)   = 0._wp
+      DO jk = 2, jpkm1
+         zfact(:,:) = zfact(:,:) + e3w_n(:,:,jk) * SQRT(  MAX( 0._wp, rn2(:,:,jk) )  ) * wmask(:,:,jk)
+         zwkb(:,:,jk) = zfact(:,:)
+      END DO
+!!gm even better:
+!      DO jk = 2, jpkm1
+!         zwkb(:,:) = zwkb(:,:) + e3w_n(:,:,jk) * SQRT(  MAX( 0._wp, rn2(:,:,jk) )  )
+!      END DO
+!      zfact(:,:) = zwkb(:,:,jpkm1)
+!!gm or just use zwkb(k=jpk-1) instead of zfact...
+!!gm
+      !
+      DO jk = 2, jpkm1
+         DO jj = 1, jpj
+            DO ji = 1, jpi
+               IF( zfact(ji,jj) /= 0 )   zwkb(ji,jj,jk) = zhdep(ji,jj) * ( zfact(ji,jj) - zwkb(ji,jj,jk) )   &
+                  &                                     * wmask(ji,jj,jk) / zfact(ji,jj)
+            END DO
+         END DO
+      END DO
+      zwkb(:,:,1) = zhdep(:,:) * wmask(:,:,1)
+      !
+      zweight(:,:,:) = 0._wp
+      DO jk = 2, jpkm1
+         zweight(:,:,jk) = MAX( 0._wp, rn2(:,:,jk) ) * hbot_iwm(:,:) * wmask(:,:,jk)                    &
+            &   * (  EXP( -zwkb(:,:,jk) / hbot_iwm(:,:) ) - EXP( -zwkb(:,:,jk-1) / hbot_iwm(:,:) )  )
+      END DO
+      !
+      zfact(:,:) = 0._wp
+      DO jk = 2, jpkm1              ! part independent of the level
+         zfact(:,:) = zfact(:,:) + zweight(:,:,jk)
+      END DO
+      !
+      DO jj = 1, jpj
+         DO ji = 1, jpi
+            IF( zfact(ji,jj) /= 0 )   zfact(ji,jj) = ebot_iwm(ji,jj) / ( rau0 * zfact(ji,jj) )
+         END DO
+      END DO
+      !
+      DO jk = 2, jpkm1              ! complete with the level-dependent part
+         zemx_iwm(:,:,jk) = zemx_iwm(:,:,jk) + zweight(:,:,jk) * zfact(:,:) * wmask(:,:,jk)   &
+            &                                / ( gde3w_n(:,:,jk) - gde3w_n(:,:,jk-1) )
+!!gm  use of e3t_n just above?
+      END DO
+      !
+!!gm  this is to be replaced by just a constant value znu=1.e-6 m2/s
+      ! Calculate molecular kinematic viscosity
+      znu_t(:,:,:) = 1.e-4_wp * (  17.91_wp - 0.53810_wp * tsn(:,:,:,jp_tem) + 0.00694_wp * tsn(:,:,:,jp_tem) * tsn(:,:,:,jp_tem)  &
+         &                                  + 0.02305_wp * tsn(:,:,:,jp_sal)  ) * tmask(:,:,:) * r1_rau0
+      DO jk = 2, jpkm1
+         znu_w(:,:,jk) = 0.5_wp * ( znu_t(:,:,jk-1) + znu_t(:,:,jk) ) * wmask(:,:,jk)
+      END DO
+!!gm end
+      !
+      ! Calculate turbulence intensity parameter Reb
+      DO jk = 2, jpkm1
+         zReb(:,:,jk) = zemx_iwm(:,:,jk) / MAX( 1.e-20_wp, znu_w(:,:,jk) * rn2(:,:,jk) )
+      END DO
+      !
+      ! Define internal wave-induced diffusivity
+      DO jk = 2, jpkm1
+         zav_wave(:,:,jk) = znu_w(:,:,jk) * zReb(:,:,jk) * r1_6   ! This corresponds to a constant mixing efficiency of 1/6
+      END DO
+      !
+      IF( ln_mevar ) THEN              ! Variable mixing efficiency case : modify zav_wave in the
+         DO jk = 2, jpkm1              ! energetic (Reb > 480) and buoyancy-controlled (Reb <10.224 ) regimes
+            DO jj = 1, jpj
+               DO ji = 1, jpi
+                  IF( zReb(ji,jj,jk) > 480.00_wp ) THEN
+                     zav_wave(ji,jj,jk) = 3.6515_wp * znu_w(ji,jj,jk) * SQRT( zReb(ji,jj,jk) )
+                  ELSEIF( zReb(ji,jj,jk) < 10.224_wp ) THEN
+                     zav_wave(ji,jj,jk) = 0.052125_wp * znu_w(ji,jj,jk) * zReb(ji,jj,jk) * SQRT( zReb(ji,jj,jk) )
+                  ENDIF
+               END DO
+            END DO
+         END DO
+      ENDIF
+      !
+      DO jk = 2, jpkm1                 ! Bound diffusivity by molecular value and 100 cm2/s
+         zav_wave(:,:,jk) = MIN(  MAX( 1.4e-7_wp, zav_wave(:,:,jk) ), 1.e-2_wp  ) * wmask(:,:,jk)
+      END DO
+      !
+      IF( kt == nit000 ) THEN        !* Control print at first time-step: diagnose the energy consumed by zav_wave
+         zztmp = 0._wp
+!!gm used of glosum 3D....
+         DO jk = 2, jpkm1
+            DO jj = 1, jpj
+               DO ji = 1, jpi
+                  zztmp = zztmp + e3w_n(ji,jj,jk) * e1e2t(ji,jj)   &
+                     &          * MAX( 0._wp, rn2(ji,jj,jk) ) * zav_wave(ji,jj,jk) * wmask(ji,jj,jk) * tmask_i(ji,jj)
+               END DO
+            END DO
+         END DO
+         IF( lk_mpp )   CALL mpp_sum( zztmp )
+         zztmp = rau0 * zztmp ! Global integral of rauo * Kz * N^2 = power contributing to mixing 
+         !
+         IF(lwp) THEN
+            WRITE(numout,*)
+            WRITE(numout,*) 'zdf_iwm : Internal wave-driven mixing (iwm)'
+            WRITE(numout,*) '~~~~~~~ '
+            WRITE(numout,*)
+            WRITE(numout,*) '      Total power consumption by av_wave =  ', zztmp * 1.e-12_wp, 'TW'
+         ENDIF
+      ENDIF
+
+      !                          ! ----------------------- !
+      !                          !   Update  mixing coefs  !                          
+      !                          ! ----------------------- !
+      !      
+      IF( ln_tsdiff ) THEN          !* Option for differential mixing of salinity and temperature
+         DO jk = 2, jpkm1              ! Calculate S/T diffusivity ratio as a function of Reb
+            DO jj = 1, jpj
+               DO ji = 1, jpi
+                  zav_ratio(ji,jj,jk) = ( 0.505_wp + 0.495_wp *                                                                  &
+                      &   TANH(    0.92_wp * (   LOG10(  MAX( 1.e-20_wp, zReb(ji,jj,jk) * 5._wp * r1_6 )  ) - 0.60_wp   )    )   &
+                      &                 ) * wmask(ji,jj,jk)
+               END DO
+            END DO
+         END DO
+         CALL iom_put( "av_ratio", zav_ratio )
+         DO jk = 2, jpkm1           !* update momentum & tracer diffusivity with wave-driven mixing
+            p_avs(:,:,jk) = p_avs(:,:,jk) + zav_wave(:,:,jk) * zav_ratio(:,:,jk)
+            p_avt(:,:,jk) = p_avt(:,:,jk) + zav_wave(:,:,jk)
+            p_avm(:,:,jk) = p_avm(:,:,jk) + zav_wave(:,:,jk)
+         END DO
+         !
+      ELSE                          !* update momentum & tracer diffusivity with wave-driven mixing
+         DO jk = 2, jpkm1
+            p_avs(:,:,jk) = p_avs(:,:,jk) + zav_wave(:,:,jk)
+            p_avt(:,:,jk) = p_avt(:,:,jk) + zav_wave(:,:,jk)
+            p_avm(:,:,jk) = p_avm(:,:,jk) + zav_wave(:,:,jk)
+         END DO
+      ENDIF
+
+      !                             !* output internal wave-driven mixing coefficient
+      CALL iom_put( "av_wave", zav_wave )
+                                    !* output useful diagnostics: Kz*N^2 , 
+!!gm Kz*N2 should take into account the ratio avs/avt if it is used.... (see diaar5)
+                                    !  vertical integral of rau0 * Kz * N^2 , energy density (zemx_iwm)
+      IF( iom_use("bflx_iwm") .OR. iom_use("pcmap_iwm") ) THEN
+         ALLOCATE( z2d(jpi,jpj) , z3d(jpi,jpj,jpk) )
+         z3d(:,:,:) = MAX( 0._wp, rn2(:,:,:) ) * zav_wave(:,:,:)
+         z2d(:,:) = 0._wp
+         DO jk = 2, jpkm1
+            z2d(:,:) = z2d(:,:) + e3w_n(:,:,jk) * z3d(:,:,jk) * wmask(:,:,jk)
+         END DO
+         z2d(:,:) = rau0 * z2d(:,:)
+         CALL iom_put( "bflx_iwm", z3d )
+         CALL iom_put( "pcmap_iwm", z2d )
+         DEALLOCATE( z2d , z3d )
+      ENDIF
+      CALL iom_put( "emix_iwm", zemx_iwm )
+      
+      IF(ln_ctl)   CALL prt_ctl(tab3d_1=zav_wave , clinfo1=' iwm - av_wave: ', tab3d_2=avt, clinfo2=' avt: ', kdim=jpk)
+      !
+   END SUBROUTINE zdf_iwm
+
+
+   SUBROUTINE zdf_iwm_init
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE zdf_iwm_init  ***
+      !!                     
+      !! ** Purpose :   Initialization of the wave-driven vertical mixing, reading
+      !!              of input power maps and decay length scales in netcdf files.
+      !!
+      !! ** Method  : - Read the namzdf_iwm namelist and check the parameters
+      !!
+      !!              - Read the input data in NetCDF files :
+      !!              power available from high-mode wave breaking (mixing_power_bot.nc)
+      !!              power available from pycnocline-intensified wave-breaking (mixing_power_pyc.nc)
+      !!              power available from critical slope wave-breaking (mixing_power_cri.nc)
+      !!              WKB decay scale for high-mode wave-breaking (decay_scale_bot.nc)
+      !!              decay scale for critical slope wave-breaking (decay_scale_cri.nc)
+      !!
+      !! ** input   : - Namlist namzdf_iwm
+      !!              - NetCDF files : mixing_power_bot.nc, mixing_power_pyc.nc, mixing_power_cri.nc,
+      !!              decay_scale_bot.nc decay_scale_cri.nc
+      !!
+      !! ** Action  : - Increase by 1 the nstop flag is setting problem encounter
+      !!              - Define ebot_iwm, epyc_iwm, ecri_iwm, hbot_iwm, hcri_iwm
+      !!
+      !! References : de Lavergne et al. JPO, 2015 ; de Lavergne PhD 2016
+      !!              de Lavergne et al. in prep., 2017
+      !!----------------------------------------------------------------------
+      INTEGER  ::   ji, jj, jk   ! dummy loop indices
+      INTEGER  ::   inum         ! local integer
+      INTEGER  ::   ios
+      REAL(wp) ::   zbot, zpyc, zcri   ! local scalars
+      !!
+      NAMELIST/namzdf_iwm/ nn_zpyc, ln_mevar, ln_tsdiff
+      !!----------------------------------------------------------------------
+      !
+      REWIND( numnam_ref )              ! Namelist namzdf_iwm in reference namelist : Wave-driven mixing
+      READ  ( numnam_ref, namzdf_iwm, IOSTAT = ios, ERR = 901)
+901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namzdf_iwm in reference namelist', lwp )
+      !
+      REWIND( numnam_cfg )              ! Namelist namzdf_iwm in configuration namelist : Wave-driven mixing
+      READ  ( numnam_cfg, namzdf_iwm, IOSTAT = ios, ERR = 902 )
+902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namzdf_iwm in configuration namelist', lwp )
+      IF(lwm) WRITE ( numond, namzdf_iwm )
+      !
+      IF(lwp) THEN                  ! Control print
+         WRITE(numout,*)
+         WRITE(numout,*) 'zdf_iwm_init : internal wave-driven mixing'
+         WRITE(numout,*) '~~~~~~~~~~~~'
+         WRITE(numout,*) '   Namelist namzdf_iwm : set wave-driven mixing parameters'
+         WRITE(numout,*) '      Pycnocline-intensified diss. scales as N (=1) or N^2 (=2) = ', nn_zpyc
+         WRITE(numout,*) '      Variable (T) or constant (F) mixing efficiency            = ', ln_mevar
+         WRITE(numout,*) '      Differential internal wave-driven mixing (T) or not (F)   = ', ln_tsdiff
+      ENDIF
+      
+      ! The new wave-driven mixing parameterization elevates avt and avm in the interior, and
+      ! ensures that avt remains larger than its molecular value (=1.4e-7). Therefore, avtb should 
+      ! be set here to a very small value, and avmb to its (uniform) molecular value (=1.4e-6).
+      avmb(:) = 1.4e-6_wp        ! viscous molecular value
+      avtb(:) = 1.e-10_wp        ! very small diffusive minimum (background avt is specified in zdf_iwm)    
+      avtb_2d(:,:) = 1.e0_wp     ! uniform 
+      IF(lwp) THEN                  ! Control print
+         WRITE(numout,*)
+         WRITE(numout,*) '   Force the background value applied to avm & avt in TKE to be everywhere ',   &
+            &               'the viscous molecular value & a very small diffusive value, resp.'
+      ENDIF
+            
+      !                             ! allocate iwm arrays
+      IF( zdf_iwm_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'zdf_iwm_init : unable to allocate iwm arrays' )
+      !
+      !                             ! read necessary fields
+      CALL iom_open('mixing_power_bot',inum)       ! energy flux for high-mode wave breaking [W/m2]
+      CALL iom_get  (inum, jpdom_data, 'field', ebot_iwm, 1 ) 
+      CALL iom_close(inum)
+      !
+      CALL iom_open('mixing_power_pyc',inum)       ! energy flux for pynocline-intensified wave breaking [W/m2]
+      CALL iom_get  (inum, jpdom_data, 'field', epyc_iwm, 1 )
+      CALL iom_close(inum)
+      !
+      CALL iom_open('mixing_power_cri',inum)       ! energy flux for critical slope wave breaking [W/m2]
+      CALL iom_get  (inum, jpdom_data, 'field', ecri_iwm, 1 )
+      CALL iom_close(inum)
+      !
+      CALL iom_open('decay_scale_bot',inum)        ! spatially variable decay scale for high-mode wave breaking [m]
+      CALL iom_get  (inum, jpdom_data, 'field', hbot_iwm, 1 )
+      CALL iom_close(inum)
+      !
+      CALL iom_open('decay_scale_cri',inum)        ! spatially variable decay scale for critical slope wave breaking [m]
+      CALL iom_get  (inum, jpdom_data, 'field', hcri_iwm, 1 )
+      CALL iom_close(inum)
+
+      ebot_iwm(:,:) = ebot_iwm(:,:) * ssmask(:,:)
+      epyc_iwm(:,:) = epyc_iwm(:,:) * ssmask(:,:)
+      ecri_iwm(:,:) = ecri_iwm(:,:) * ssmask(:,:)
+
+      zbot = glob_sum( e1e2t(:,:) * ebot_iwm(:,:) )
+      zpyc = glob_sum( e1e2t(:,:) * epyc_iwm(:,:) )
+      zcri = glob_sum( e1e2t(:,:) * ecri_iwm(:,:) )
+      IF(lwp) THEN
+         WRITE(numout,*) '      High-mode wave-breaking energy:             ', zbot * 1.e-12_wp, 'TW'
+         WRITE(numout,*) '      Pycnocline-intensifed wave-breaking energy: ', zpyc * 1.e-12_wp, 'TW'
+         WRITE(numout,*) '      Critical slope wave-breaking energy:        ', zcri * 1.e-12_wp, 'TW'
+      ENDIF
+      !
+   END SUBROUTINE zdf_iwm_init
+
+   !!======================================================================
+END MODULE zdfiwm
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/ZDF/zdfmxl.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/ZDF/zdfmxl.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/ZDF/zdfmxl.F90	(revision 9570)
@@ -0,0 +1,144 @@
+MODULE zdfmxl
+   !!======================================================================
+   !!                       ***  MODULE  zdfmxl  ***
+   !! Ocean physics: mixed layer depth 
+   !!======================================================================
+   !! History :  1.0  ! 2003-08  (G. Madec)  original code
+   !!            3.2  ! 2009-07  (S. Masson, G. Madec)  IOM + merge of DO-loop
+   !!            3.7  ! 2012-03  (G. Madec)  make public the density criteria for trdmxl 
+   !!             -   ! 2014-02  (F. Roquet)  mixed layer depth calculated using N2 instead of rhop 
+   !!----------------------------------------------------------------------
+   !!   zdf_mxl      : Compute the turbocline and mixed layer depths.
+   !!----------------------------------------------------------------------
+   USE oce            ! ocean dynamics and tracers variables
+   USE dom_oce        ! ocean space and time domain variables
+   USE trc_oce  , ONLY: l_offline         ! ocean space and time domain variables
+   USE zdf_oce        ! ocean vertical physics
+   !
+   USE in_out_manager ! I/O manager
+   USE prtctl         ! Print control
+   USE phycst         ! physical constants
+   USE iom            ! I/O library
+   USE lib_mpp        ! MPP library
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   zdf_mxl   ! called by zdfphy.F90
+
+   INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   nmln    !: number of level in the mixed layer (used by LDF, ZDF, TRD, TOP)
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hmld    !: mixing layer depth (turbocline)      [m]   (used by TOP)
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hmlp    !: mixed layer depth  (rho=rho0+zdcrit) [m]   (used by LDF)
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hmlpt   !: depth of the last T-point inside the mixed layer [m] (used by LDF)
+
+   REAL(wp), PUBLIC ::   rho_c = 0.01_wp    !: density criterion for mixed layer depth
+   REAL(wp)         ::   avt_c = 5.e-4_wp   ! Kz criterion for the turbocline depth
+
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 4.0 , NEMO Consortium (2017)
+   !! $Id$ 
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   INTEGER FUNCTION zdf_mxl_alloc()
+      !!----------------------------------------------------------------------
+      !!               ***  FUNCTION zdf_mxl_alloc  ***
+      !!----------------------------------------------------------------------
+      zdf_mxl_alloc = 0      ! set to zero if no array to be allocated
+      IF( .NOT. ALLOCATED( nmln ) ) THEN
+         ALLOCATE( nmln(jpi,jpj), hmld(jpi,jpj), hmlp(jpi,jpj), hmlpt(jpi,jpj), STAT= zdf_mxl_alloc )
+         !
+         IF( lk_mpp             )   CALL mpp_sum ( zdf_mxl_alloc )
+         IF( zdf_mxl_alloc /= 0 )   CALL ctl_warn('zdf_mxl_alloc: failed to allocate arrays.')
+         !
+      ENDIF
+   END FUNCTION zdf_mxl_alloc
+
+
+   SUBROUTINE zdf_mxl( kt )
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE zdfmxl  ***
+      !!                   
+      !! ** Purpose :   Compute the turbocline depth and the mixed layer depth
+      !!              with density criteria.
+      !!
+      !! ** Method  :   The mixed layer depth is the shallowest W depth with 
+      !!      the density of the corresponding T point (just bellow) bellow a
+      !!      given value defined locally as rho(10m) + rho_c
+      !!               The turbocline depth is the depth at which the vertical
+      !!      eddy diffusivity coefficient (resulting from the vertical physics
+      !!      alone, not the isopycnal part, see trazdf.F) fall below a given
+      !!      value defined locally (avt_c here taken equal to 5 cm/s2 by default)
+      !!
+      !! ** Action  :   nmln, hmld, hmlp, hmlpt
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT(in) ::   kt   ! ocean time-step index
+      !
+      INTEGER  ::   ji, jj, jk      ! dummy loop indices
+      INTEGER  ::   iikn, iiki, ikt ! local integer
+      REAL(wp) ::   zN2_c           ! local scalar
+      INTEGER, DIMENSION(jpi,jpj) ::   imld   ! 2D workspace
+      !!----------------------------------------------------------------------
+      !
+      IF( kt == nit000 ) THEN
+         IF(lwp) WRITE(numout,*)
+         IF(lwp) WRITE(numout,*) 'zdf_mxl : mixed layer depth'
+         IF(lwp) WRITE(numout,*) '~~~~~~~ '
+         !                             ! allocate zdfmxl arrays
+         IF( zdf_mxl_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'zdf_mxl : unable to allocate arrays' )
+      ENDIF
+      !
+      ! w-level of the mixing and mixed layers
+      nmln(:,:)  = nlb10               ! Initialization to the number of w ocean point
+      hmlp(:,:)  = 0._wp               ! here hmlp used as a dummy variable, integrating vertically N^2
+      zN2_c = grav * rho_c * r1_rau0   ! convert density criteria into N^2 criteria
+      DO jk = nlb10, jpkm1
+         DO jj = 1, jpj                ! Mixed layer level: w-level 
+            DO ji = 1, jpi
+               ikt = mbkt(ji,jj)
+               hmlp(ji,jj) = hmlp(ji,jj) + MAX( rn2b(ji,jj,jk) , 0._wp ) * e3w_n(ji,jj,jk)
+               IF( hmlp(ji,jj) < zN2_c )   nmln(ji,jj) = MIN( jk , ikt ) + 1   ! Mixed layer level
+            END DO
+         END DO
+      END DO
+      !
+      ! w-level of the turbocline and mixing layer (iom_use)
+      imld(:,:) = mbkt(:,:) + 1        ! Initialization to the number of w ocean point
+      DO jk = jpkm1, nlb10, -1         ! from the bottom to nlb10 
+         DO jj = 1, jpj
+            DO ji = 1, jpi
+               IF( avt (ji,jj,jk) < avt_c * wmask(ji,jj,jk) )   imld(ji,jj) = jk      ! Turbocline 
+            END DO
+         END DO
+      END DO
+      ! depth of the mixing and mixed layers
+      DO jj = 1, jpj
+         DO ji = 1, jpi
+            iiki = imld(ji,jj)
+            iikn = nmln(ji,jj)
+            hmld (ji,jj) = gdepw_n(ji,jj,iiki  ) * ssmask(ji,jj)    ! Turbocline depth 
+            hmlp (ji,jj) = gdepw_n(ji,jj,iikn  ) * ssmask(ji,jj)    ! Mixed layer depth
+            hmlpt(ji,jj) = gdept_n(ji,jj,iikn-1) * ssmask(ji,jj)    ! depth of the last T-point inside the mixed layer
+         END DO
+      END DO
+      !
+      IF( .NOT.l_offline ) THEN
+         IF( iom_use("mldr10_1") ) THEN
+            IF( ln_isfcav ) THEN  ;  CALL iom_put( "mldr10_1", hmlp - risfdep)   ! mixed layer thickness
+            ELSE                  ;  CALL iom_put( "mldr10_1", hmlp )            ! mixed layer depth
+            END IF
+         END IF
+         IF( iom_use("mldkz5") ) THEN
+            IF( ln_isfcav ) THEN  ;  CALL iom_put( "mldkz5"  , hmld - risfdep )   ! turbocline thickness
+            ELSE                  ;  CALL iom_put( "mldkz5"  , hmld )             ! turbocline depth
+            END IF
+         ENDIF
+      ENDIF
+      !
+      IF(ln_ctl)   CALL prt_ctl( tab2d_1=REAL(nmln,wp), clinfo1=' nmln : ', tab2d_2=hmlp, clinfo2=' hmlp : ' )
+      !
+   END SUBROUTINE zdf_mxl
+
+   !!======================================================================
+END MODULE zdfmxl
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/ZDF/zdfosm.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/ZDF/zdfosm.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/ZDF/zdfosm.F90	(revision 9570)
@@ -0,0 +1,1725 @@
+MODULE zdfosm
+   !!======================================================================
+   !!                       ***  MODULE  zdfosm  ***
+   !! Ocean physics:  vertical mixing coefficient compute from the OSMOSIS
+   !!                 turbulent closure parameterization
+   !!=====================================================================
+   !!  History : NEMO 4.0  ! A. Grant, G. Nurser
+   !! 15/03/2017  Changed calculation of pycnocline thickness in unstable conditions and stable conditions AG
+   !! 15/03/2017  Calculation of pycnocline gradients for stable conditions changed. Pycnocline gradients now depend on stability of the OSBL. A.G
+   !! 06/06/2017  (1) Checks on sign of buoyancy jump in calculation of  OSBL depth.  A.G.
+   !!             (2) Removed variable zbrad0, zbradh and zbradav since they are not used.
+   !!             (3) Approximate treatment for shear turbulence.
+   !!                        Minimum values for zustar and zustke.
+   !!                        Add velocity scale, zvstr, that tends to zustar for large Langmuir numbers.
+   !!                        Limit maximum value for Langmuir number.
+   !!                        Use zvstr in definition of stability parameter zhol.
+   !!             (4) Modified parametrization of entrainment flux, changing original coefficient 0.0485 for Langmuir contribution to 0.135 * zla
+   !!             (5) For stable boundary layer add factor that depends on length of timestep to 'slow' collapse and growth. Make sure buoyancy jump not negative.
+   !!             (6) For unstable conditions when growth is over multiple levels, limit change to maximum of one level per cycle through loop.
+   !!             (7) Change lower limits for loops that calculate OSBL averages from 1 to 2. Large gradients between levels 1 and 2 can cause problems.
+   !!             (8) Change upper limits from ibld-1 to ibld.
+   !!             (9) Calculation of pycnocline thickness in unstable conditions. Check added to ensure that buoyancy jump is positive before calculating Ri.
+   !!            (10) Thickness of interface layer at base of the stable OSBL set by Richardson number. Gives continuity in transition from unstable OSBL.
+   !!            (11) Checks that buoyancy jump is poitive when calculating pycnocline profiles.
+   !!            (12) Replace zwstrl with zvstr in calculation of eddy viscosity.
+   !! 27/09/2017 (13) Calculate Stokes drift and Stokes penetration depth from wave information
+   !!            (14) Bouyancy flux due to entrainment changed to include contribution from shear turbulence (for testing commented out).
+   !! 28/09/2017 (15) Calculation of Stokes drift moved into separate do-loops to allow for different options for the determining the Stokes drift to be added.
+   !!            (16) Calculation of Stokes drift from windspeed for PM spectrum (for testing, commented out)
+   !!            (17) Modification to Langmuir velocity scale to include effects due to the Stokes penetration depth (for testing, commented out)
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   'key_zdfosm'                                             OSMOSIS scheme
+   !!----------------------------------------------------------------------
+   !!   zdf_osm       : update momentum and tracer Kz from osm scheme
+   !!   zdf_osm_init  : initialization, namelist read, and parameters control
+   !!   osm_rst       : read (or initialize) and write osmosis restart fields
+   !!   tra_osm       : compute and add to the T & S trend the non-local flux
+   !!   trc_osm       : compute and add to the passive tracer trend the non-local flux (TBD)
+   !!   dyn_osm       : compute and add to u & v trensd the non-local flux
+   !!----------------------------------------------------------------------
+   USE oce            ! ocean dynamics and active tracers
+                      ! uses wn from previous time step (which is now wb) to calculate hbl
+   USE dom_oce        ! ocean space and time domain
+   USE zdf_oce        ! ocean vertical physics
+   USE sbc_oce        ! surface boundary condition: ocean
+   USE sbcwave        ! surface wave parameters
+   USE phycst         ! physical constants
+   USE eosbn2         ! equation of state
+   USE traqsr         ! details of solar radiation absorption
+   USE zdfddm         ! double diffusion mixing (avs array)
+   USE iom            ! I/O library
+   USE lib_mpp        ! MPP library
+   USE trd_oce        ! ocean trends definition
+   USE trdtra         ! tracers trends
+   !
+   USE in_out_manager ! I/O manager
+   USE lbclnk         ! ocean lateral boundary conditions (or mpp link)
+   USE prtctl         ! Print control
+   USE lib_fortran    ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined)
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   zdf_osm       ! routine called by step.F90
+   PUBLIC   zdf_osm_init  ! routine called by nemogcm.F90
+   PUBLIC   osm_rst       ! routine called by step.F90
+   PUBLIC   tra_osm       ! routine called by step.F90
+   PUBLIC   trc_osm       ! routine called by trcstp.F90
+   PUBLIC   dyn_osm       ! routine called by 'step.F90'
+
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   ghamu    !: non-local u-momentum flux
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   ghamv    !: non-local v-momentum flux
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   ghamt    !: non-local temperature flux (gamma/<ws>o)
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   ghams    !: non-local salinity flux (gamma/<ws>o)
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   etmean   !: averaging operator for avt
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   hbl      !: boundary layer depth
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   hbli     !: intial boundary layer depth for stable blayer
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   dstokes  !: penetration depth of the Stokes drift.
+
+   !                      !!** Namelist  namzdf_osm  **
+   LOGICAL  ::   ln_use_osm_la      ! Use namelist  rn_osm_la
+   REAL(wp) ::   rn_osm_la          ! Turbulent Langmuir number
+   REAL(wp) ::   rn_osm_dstokes     ! Depth scale of Stokes drift
+   REAL(wp) ::   rn_osm_hbl0 = 10._wp       ! Initial value of hbl for 1D runs
+   INTEGER  ::   nn_ave             ! = 0/1 flag for horizontal average on avt
+   INTEGER  ::   nn_osm_wave = 0    ! = 0/1/2 flag for getting stokes drift from La# / PM wind-waves/Inputs into sbcwave
+   LOGICAL  ::   ln_dia_osm         ! Use namelist  rn_osm_la
+
+
+   LOGICAL  ::   ln_kpprimix  = .true.  ! Shear instability mixing
+   REAL(wp) ::   rn_riinfty   = 0.7     ! local Richardson Number limit for shear instability
+   REAL(wp) ::   rn_difri    =  0.005   ! maximum shear mixing at Rig = 0    (m2/s)
+   LOGICAL  ::   ln_convmix  = .true.   ! Convective instability mixing
+   REAL(wp) ::   rn_difconv = 1._wp     ! diffusivity when unstable below BL  (m2/s)
+
+   !                                    !!! ** General constants  **
+   REAL(wp) ::   epsln   = 1.0e-20_wp   ! a small positive number
+   REAL(wp) ::   pthird  = 1._wp/3._wp  ! 1/3
+   REAL(wp) ::   p2third = 2._wp/3._wp  ! 2/3
+
+   INTEGER :: idebug = 236
+   INTEGER :: jdebug = 228
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 4.0 , NEMO Consortium (2011)
+   !! $Id$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   INTEGER FUNCTION zdf_osm_alloc()
+      !!----------------------------------------------------------------------
+      !!                 ***  FUNCTION zdf_osm_alloc  ***
+      !!----------------------------------------------------------------------
+     ALLOCATE( ghamu(jpi,jpj,jpk), ghamv(jpi,jpj,jpk), ghamt(jpi,jpj,jpk), ghams(jpi,jpj,jpk), &
+          &      hbl(jpi,jpj)    ,  hbli(jpi,jpj)    , dstokes(jpi, jpj) ,                     &
+          &   etmean(jpi,jpj,jpk),  STAT= zdf_osm_alloc )
+     IF( zdf_osm_alloc /= 0 )   CALL ctl_warn('zdf_osm_alloc: failed to allocate zdf_osm arrays')
+     IF( lk_mpp             )   CALL mpp_sum ( zdf_osm_alloc )
+   END FUNCTION zdf_osm_alloc
+
+
+   SUBROUTINE zdf_osm( kt, p_avm, p_avt )
+      !!----------------------------------------------------------------------
+      !!                   ***  ROUTINE zdf_osm  ***
+      !!
+      !! ** Purpose :   Compute the vertical eddy viscosity and diffusivity
+      !!      coefficients and non local mixing using the OSMOSIS scheme
+      !!
+      !! ** Method :   The boundary layer depth hosm is diagnosed at tracer points
+      !!      from profiles of buoyancy, and shear, and the surface forcing.
+      !!      Above hbl (sigma=-z/hbl <1) the mixing coefficients are computed from
+      !!
+      !!                      Kx =  hosm  Wx(sigma) G(sigma)
+      !!
+      !!             and the non local term ghamt = Cs / Ws(sigma) / hosm
+      !!      Below hosm  the coefficients are the sum of mixing due to internal waves
+      !!      shear instability and double diffusion.
+      !!
+      !!      -1- Compute the now interior vertical mixing coefficients at all depths.
+      !!      -2- Diagnose the boundary layer depth.
+      !!      -3- Compute the now boundary layer vertical mixing coefficients.
+      !!      -4- Compute the now vertical eddy vicosity and diffusivity.
+      !!      -5- Smoothing
+      !!
+      !!        N.B. The computation is done from jk=2 to jpkm1
+      !!             Surface value of avt are set once a time to zero
+      !!             in routine zdf_osm_init.
+      !!
+      !! ** Action  :   update the non-local terms ghamts
+      !!                update avt (before vertical eddy coef.)
+      !!
+      !! References : Large W.G., Mc Williams J.C. and Doney S.C.
+      !!         Reviews of Geophysics, 32, 4, November 1994
+      !!         Comments in the code refer to this paper, particularly
+      !!         the equation number. (LMD94, here after)
+      !!----------------------------------------------------------------------
+      INTEGER                   , INTENT(in   ) ::   kt            ! ocean time step
+      REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::  p_avm, p_avt   ! momentum and tracer Kz (w-points)
+      !!
+      INTEGER ::   ji, jj, jk                   ! dummy loop indices
+      INTEGER ::   ikbot, jkmax, jkm1, jkp2     !
+
+      REAL(wp) ::   ztx, zty, zflageos, zstabl, zbuofdep,zucube      !
+      REAL(wp) ::   zbeta, zthermal                                  !
+      REAL(wp) ::   zehat, zeta, zhrib, zsig, zscale, zwst, zws, zwm ! Velocity scales
+      REAL(wp) ::   zwsun, zwmun, zcons, zconm, zwcons, zwconm       !
+      REAL(wp) ::   zsr, zbw, ze, zb, zd, zc, zaw, za, zb1, za1, zkw, zk0, zcomp , zrhd,zrhdr,zbvzed   ! In situ density
+      INTEGER  ::   jm                          ! dummy loop indices
+      REAL(wp) ::   zr1, zr2, zr3, zr4, zrhop   ! Compression terms
+      REAL(wp) ::   zflag, zrn2, zdep21, zdep32, zdep43
+      REAL(wp) ::   zesh2, zri, zfri            ! Interior richardson mixing
+      REAL(wp) ::   zdelta, zdelta2, zdzup, zdzdn, zdzh, zvath, zgat1, zdat1, zkm1m, zkm1t
+      REAL(wp) :: zt,zs,zu,zv,zrh               ! variables used in constructing averages
+! Scales
+      REAL(wp), DIMENSION(jpi,jpj) :: zrad0     ! Surface solar temperature flux (deg m/s)
+      REAL(wp), DIMENSION(jpi,jpj) :: zradh     ! Radiative flux at bl base (Buoyancy units)
+      REAL(wp), DIMENSION(jpi,jpj) :: zradav    ! Radiative flux, bl average (Buoyancy Units)
+      REAL(wp), DIMENSION(jpi,jpj) :: zustar    ! friction velocity
+      REAL(wp), DIMENSION(jpi,jpj) :: zwstrl    ! Langmuir velocity scale
+      REAL(wp), DIMENSION(jpi,jpj) :: zvstr     ! Velocity scale that ends to zustar for large Langmuir number.
+      REAL(wp), DIMENSION(jpi,jpj) :: zwstrc    ! Convective velocity scale
+      REAL(wp), DIMENSION(jpi,jpj) :: zuw0      ! Surface u-momentum flux
+      REAL(wp), DIMENSION(jpi,jpj) :: zvw0      ! Surface v-momentum flux
+      REAL(wp), DIMENSION(jpi,jpj) :: zwth0     ! Surface heat flux (Kinematic)
+      REAL(wp), DIMENSION(jpi,jpj) :: zws0      ! Surface freshwater flux
+      REAL(wp), DIMENSION(jpi,jpj) :: zwb0      ! Surface buoyancy flux
+      REAL(wp), DIMENSION(jpi,jpj) :: zwthav    ! Heat flux - bl average
+      REAL(wp), DIMENSION(jpi,jpj) :: zwsav     ! freshwater flux - bl average
+      REAL(wp), DIMENSION(jpi,jpj) :: zwbav     ! Buoyancy flux - bl average
+      REAL(wp), DIMENSION(jpi,jpj) :: zwb_ent   ! Buoyancy entrainment flux
+      REAL(wp), DIMENSION(jpi,jpj) :: zustke    ! Surface Stokes drift
+      REAL(wp), DIMENSION(jpi,jpj) :: zla       ! Trubulent Langmuir number
+      REAL(wp), DIMENSION(jpi,jpj) :: zcos_wind ! Cos angle of surface stress
+      REAL(wp), DIMENSION(jpi,jpj) :: zsin_wind ! Sin angle of surface stress
+      REAL(wp), DIMENSION(jpi,jpj) :: zhol      ! Stability parameter for boundary layer
+      LOGICAL, DIMENSION(:,:), ALLOCATABLE :: lconv ! unstable/stable bl
+
+      ! mixed-layer variables
+
+      INTEGER, DIMENSION(jpi,jpj) :: ibld ! level of boundary layer base
+      INTEGER, DIMENSION(jpi,jpj) :: imld ! level of mixed-layer depth (pycnocline top)
+
+      REAL(wp) :: ztgrad,zsgrad,zbgrad ! Temporary variables used to calculate pycnocline gradients
+      REAL(wp) :: zugrad,zvgrad        ! temporary variables for calculating pycnocline shear
+
+      REAL(wp), DIMENSION(jpi,jpj) :: zhbl  ! bl depth - grid
+      REAL(wp), DIMENSION(jpi,jpj) :: zhml  ! ml depth - grid
+      REAL(wp), DIMENSION(jpi,jpj) :: zdh   ! pycnocline depth - grid
+      REAL(wp), DIMENSION(jpi,jpj) :: zdhdt ! BL depth tendency
+      REAL(wp), DIMENSION(jpi,jpj) :: zt_bl,zs_bl,zu_bl,zv_bl,zrh_bl  ! averages over the depth of the blayer
+      REAL(wp), DIMENSION(jpi,jpj) :: zt_ml,zs_ml,zu_ml,zv_ml,zrh_ml  ! averages over the depth of the mixed layer
+      REAL(wp), DIMENSION(jpi,jpj) :: zdt_bl,zds_bl,zdu_bl,zdv_bl,zdrh_bl,zdb_bl ! difference between blayer average and parameter at base of blayer
+      REAL(wp), DIMENSION(jpi,jpj) :: zdt_ml,zds_ml,zdu_ml,zdv_ml,zdrh_ml,zdb_ml ! difference between mixed layer average and parameter at base of blayer
+      REAL(wp), DIMENSION(jpi,jpj) :: zwth_ent,zws_ent ! heat and salinity fluxes at the top of the pycnocline
+      REAL(wp), DIMENSION(jpi,jpj) :: zuw_bse,zvw_bse  ! momentum fluxes at the top of the pycnocline
+      REAL(wp), DIMENSION(jpi,jpj,jpk) :: zdtdz_pyc    ! parametrized gradient of temperature in pycnocline
+      REAL(wp), DIMENSION(jpi,jpj,jpk) :: zdsdz_pyc    ! parametrised gradient of salinity in pycnocline
+      REAL(wp), DIMENSION(jpi,jpj,jpk) :: zdbdz_pyc    ! parametrised gradient of buoyancy in the pycnocline
+      REAL(wp), DIMENSION(jpi,jpj,jpk) :: zdudz_pyc    ! u-shear across the pycnocline
+      REAL(wp), DIMENSION(jpi,jpj,jpk) :: zdvdz_pyc    ! v-shear across the pycnocline
+
+      ! Flux-gradient relationship variables
+
+      REAL(wp) :: zl_c,zl_l,zl_eps  ! Used to calculate turbulence length scale.
+
+      REAL(wp), DIMENSION(jpi,jpj) :: zdifml_sc,zvisml_sc,zdifpyc_sc,zvispyc_sc,zbeta_d_sc,zbeta_v_sc ! Scales for eddy diffusivity/viscosity
+      REAL(wp), DIMENSION(jpi,jpj) :: zsc_wth_1,zsc_ws_1 ! Temporary scales used to calculate scalar non-gradient terms.
+      REAL(wp), DIMENSION(jpi,jpj) :: zsc_uw_1,zsc_uw_2,zsc_vw_1,zsc_vw_2 ! Temporary scales for non-gradient momentum flux terms.
+      REAL(wp), DIMENSION(jpi,jpj) :: zhbl_t ! holds boundary layer depth updated by full timestep
+
+      ! For calculating Ri#-dependent mixing
+      REAL(wp), DIMENSION(jpi,jpj,jpk) :: z3du   ! u-shear^2
+      REAL(wp), DIMENSION(jpi,jpj,jpk) :: z3dv   ! v-shear^2
+      REAL(wp), DIMENSION(jpi,jpj,jpk) :: zrimix ! spatial form of ri#-induced diffusion
+
+      ! Temporary variables
+      INTEGER :: inhml
+      INTEGER :: i_lconv_alloc
+      REAL(wp) :: znd,znd_d,zznd_ml,zznd_pyc,zznd_d ! temporary non-dimensional depths used in various routines
+      REAL(wp) :: ztemp, zari, zpert, zzdhdt, zdb   ! temporary variables
+      REAL(wp) :: zthick, zz0, zz1 ! temporary variables
+      REAL(wp) :: zvel_max, zhbl_s ! temporary variables
+      REAL(wp) :: zfac             ! temporary variable
+      REAL(wp) :: zus_x, zus_y     ! temporary Stokes drift
+      REAL(wp), DIMENSION(jpi,jpj,jpk) :: zviscos ! viscosity
+      REAL(wp), DIMENSION(jpi,jpj,jpk) :: zdiffut ! t-diffusivity
+
+      ! For debugging
+      INTEGER :: ikt
+      !!--------------------------------------------------------------------
+      !
+      ALLOCATE( lconv(jpi,jpj),  STAT= i_lconv_alloc )
+      IF( i_lconv_alloc /= 0 )   CALL ctl_warn('zdf_osm: failed to allocate lconv')
+
+      ibld(:,:)   = 0     ; imld(:,:)  = 0
+      zrad0(:,:)  = 0._wp ; zradh(:,:) = 0._wp ; zradav(:,:)    = 0._wp ; zustar(:,:)    = 0._wp
+      zwstrl(:,:) = 0._wp ; zvstr(:,:) = 0._wp ; zwstrc(:,:)    = 0._wp ; zuw0(:,:)      = 0._wp
+      zvw0(:,:)   = 0._wp ; zwth0(:,:) = 0._wp ; zws0(:,:)      = 0._wp ; zwb0(:,:)      = 0._wp
+      zwthav(:,:) = 0._wp ; zwsav(:,:) = 0._wp ; zwbav(:,:)     = 0._wp ; zwb_ent(:,:)   = 0._wp
+      zustke(:,:) = 0._wp ; zla(:,:)   = 0._wp ; zcos_wind(:,:) = 0._wp ; zsin_wind(:,:) = 0._wp
+      zhol(:,:)   = 0._wp
+      lconv(:,:)  = .FALSE.
+      ! mixed layer
+      ! no initialization of zhbl or zhml (or zdh?)
+      zhbl(:,:)    = 1._wp ; zhml(:,:)    = 1._wp ; zdh(:,:)      = 1._wp ; zdhdt(:,:)   = 0._wp
+      zt_bl(:,:)   = 0._wp ; zs_bl(:,:)   = 0._wp ; zu_bl(:,:)    = 0._wp ; zv_bl(:,:)   = 0._wp
+      zrh_bl(:,:)  = 0._wp ; zt_ml(:,:)   = 0._wp ; zs_ml(:,:)    = 0._wp ; zu_ml(:,:)   = 0._wp
+      zv_ml(:,:)   = 0._wp ; zrh_ml(:,:)  = 0._wp ; zdt_bl(:,:)   = 0._wp ; zds_bl(:,:)  = 0._wp
+      zdu_bl(:,:)  = 0._wp ; zdv_bl(:,:)  = 0._wp ; zdrh_bl(:,:)  = 0._wp ; zdb_bl(:,:)  = 0._wp
+      zdt_ml(:,:)  = 0._wp ; zds_ml(:,:)  = 0._wp ; zdu_ml(:,:)   = 0._wp ; zdv_ml(:,:)  = 0._wp
+      zdrh_ml(:,:) = 0._wp ; zdb_ml(:,:)  = 0._wp ; zwth_ent(:,:) = 0._wp ; zws_ent(:,:) = 0._wp
+      zuw_bse(:,:) = 0._wp ; zvw_bse(:,:) = 0._wp
+      !
+      zdtdz_pyc(:,:,:) = 0._wp ; zdsdz_pyc(:,:,:) = 0._wp ; zdbdz_pyc(:,:,:) = 0._wp
+      zdudz_pyc(:,:,:) = 0._wp ; zdvdz_pyc(:,:,:) = 0._wp
+      !
+      ! Flux-Gradient arrays.
+      zdifml_sc(:,:)  = 0._wp ; zvisml_sc(:,:)  = 0._wp ; zdifpyc_sc(:,:) = 0._wp
+      zvispyc_sc(:,:) = 0._wp ; zbeta_d_sc(:,:) = 0._wp ; zbeta_v_sc(:,:) = 0._wp
+      zsc_wth_1(:,:)  = 0._wp ; zsc_ws_1(:,:)   = 0._wp ; zsc_uw_1(:,:)   = 0._wp
+      zsc_uw_2(:,:)   = 0._wp ; zsc_vw_1(:,:)   = 0._wp ; zsc_vw_2(:,:)   = 0._wp
+      zhbl_t(:,:)     = 0._wp ; zdhdt(:,:)      = 0._wp
+
+      zdiffut(:,:,:) = 0._wp ; zviscos(:,:,:) = 0._wp ; ghamt(:,:,:) = 0._wp
+      ghams(:,:,:)   = 0._wp ; ghamu(:,:,:)   = 0._wp ; ghamv(:,:,:) = 0._wp
+
+      ! hbl = MAX(hbl,epsln)
+      !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+      ! Calculate boundary layer scales
+      !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+
+      ! Assume two-band radiation model for depth of OSBL
+     zz0 =       rn_abs       ! surface equi-partition in 2-bands
+     zz1 =  1. - rn_abs
+     DO jj = 2, jpjm1
+        DO ji = 2, jpim1
+           ! Surface downward irradiance (so always +ve)
+           zrad0(ji,jj) = qsr(ji,jj) * r1_rau0_rcp
+           ! Downwards irradiance at base of boundary layer
+           zradh(ji,jj) = zrad0(ji,jj) * ( zz0 * EXP( -hbl(ji,jj)/rn_si0 ) + zz1 * EXP( -hbl(ji,jj)/rn_si1) )
+           ! Downwards irradiance averaged over depth of the OSBL
+           zradav(ji,jj) = zrad0(ji,jj) * ( zz0 * ( 1.0 - EXP( -hbl(ji,jj)/rn_si0 ) )*rn_si0 &
+                 &                         + zz1 * ( 1.0 - EXP( -hbl(ji,jj)/rn_si1 ) )*rn_si1 ) / hbl(ji,jj)
+        END DO
+     END DO
+     ! Turbulent surface fluxes and fluxes averaged over depth of the OSBL
+     DO jj = 2, jpjm1
+        DO ji = 2, jpim1
+           zthermal = rab_n(ji,jj,1,jp_tem)
+           zbeta    = rab_n(ji,jj,1,jp_sal)
+           ! Upwards surface Temperature flux for non-local term
+           zwth0(ji,jj) = - qns(ji,jj) * r1_rau0_rcp * tmask(ji,jj,1)
+           ! Upwards surface salinity flux for non-local term
+           zws0(ji,jj) = - ( ( emp(ji,jj)-rnf(ji,jj) ) * tsn(ji,jj,1,jp_sal)  + sfx(ji,jj) ) * r1_rau0 * tmask(ji,jj,1)
+           ! Non radiative upwards surface buoyancy flux
+           zwb0(ji,jj) = grav * zthermal * zwth0(ji,jj) -  grav * zbeta * zws0(ji,jj)
+           ! turbulent heat flux averaged over depth of OSBL
+           zwthav(ji,jj) = 0.5 * zwth0(ji,jj) - ( 0.5*( zrad0(ji,jj) + zradh(ji,jj) ) - zradav(ji,jj) )
+           ! turbulent salinity flux averaged over depth of the OBSL
+           zwsav(ji,jj) = 0.5 * zws0(ji,jj)
+           ! turbulent buoyancy flux averaged over the depth of the OBSBL
+           zwbav(ji,jj) = grav  * zthermal * zwthav(ji,jj) - grav  * zbeta * zwsav(ji,jj)
+           ! Surface upward velocity fluxes
+           zuw0(ji,jj) = -utau(ji,jj) * r1_rau0 * tmask(ji,jj,1)
+           zvw0(ji,jj) = -vtau(ji,jj) * r1_rau0 * tmask(ji,jj,1)
+           ! Friction velocity (zustar), at T-point : LMD94 eq. 2
+           zustar(ji,jj) = MAX( SQRT( SQRT( zuw0(ji,jj) * zuw0(ji,jj) + zvw0(ji,jj) * zvw0(ji,jj) ) ), 1.0e-8 )
+           zcos_wind(ji,jj) = -zuw0(ji,jj) / ( zustar(ji,jj) * zustar(ji,jj) )
+           zsin_wind(ji,jj) = -zvw0(ji,jj) / ( zustar(ji,jj) * zustar(ji,jj) )
+        END DO
+     END DO
+     ! Calculate Stokes drift in direction of wind (zustke) and Stokes penetration depth (dstokes)
+     SELECT CASE (nn_osm_wave)
+     ! Assume constant La#=0.3
+     CASE(0)
+        DO jj = 2, jpjm1
+           DO ji = 2, jpim1
+              zus_x = zcos_wind(ji,jj) * zustar(ji,jj) / 0.3**2
+              zus_y = zsin_wind(ji,jj) * zustar(ji,jj) / 0.3**2
+              zustke(ji,jj) = MAX ( SQRT( zus_x*zus_x + zus_y*zus_y), 1.0e-8 )
+              ! dstokes(ji,jj) set to constant value rn_osm_dstokes from namelist in zdf_osm_init
+           END DO
+        END DO
+     ! Assume Pierson-Moskovitz wind-wave spectrum
+     CASE(1)
+        DO jj = 2, jpjm1
+           DO ji = 2, jpim1
+              ! Use wind speed wndm included in sbc_oce module
+              zustke(ji,jj) = MAX ( 0.016 * wndm(ji,jj), 1.0e-8 )
+              dstokes(ji,jj) = 0.12 * wndm(ji,jj)**2 / grav
+           END DO
+        END DO
+     ! Use ECMWF wave fields as output from SBCWAVE
+     CASE(2)
+        zfac =  2.0_wp * rpi / 16.0_wp
+        DO jj = 2, jpjm1
+           DO ji = 2, jpim1
+              ! The Langmur number from the ECMWF model appears to give La<0.3 for wind-driven seas.
+              !    The coefficient 0.8 gives La=0.3  in this situation.
+              ! It could represent the effects of the spread of wave directions
+              ! around the mean wind. The effect of this adjustment needs to be tested.
+              zustke(ji,jj) = MAX ( 1.0 * ( zcos_wind(ji,jj) * ut0sd(ji,jj ) + zsin_wind(ji,jj)  * vt0sd(ji,jj) ), &
+                   &                zustar(ji,jj) / ( 0.45 * 0.45 )                                                  )
+              dstokes(ji,jj) = MAX(zfac * hsw(ji,jj)*hsw(ji,jj) / ( MAX(zustke(ji,jj)*wmp(ji,jj), 1.0e-7 ) ), 5.0e-1) !rn_osm_dstokes !
+           END DO
+        END DO
+     END SELECT
+
+     ! Langmuir velocity scale (zwstrl), La # (zla)
+     ! mixed scale (zvstr), convective velocity scale (zwstrc)
+     DO jj = 2, jpjm1
+        DO ji = 2, jpim1
+           ! Langmuir velocity scale (zwstrl), at T-point
+           zwstrl(ji,jj) = ( zustar(ji,jj) * zustar(ji,jj) * zustke(ji,jj) )**pthird
+           ! Modify zwstrl to allow for small and large values of dstokes/hbl.
+           ! Intended as a possible test. Doesn't affect LES results for entrainment,
+           !  but hasn't been shown to be correct as dstokes/h becomes large or small.
+           zwstrl(ji,jj) = zwstrl(ji,jj) *  &
+                & (1.12 * ( 1.0 - ( 1.0 - EXP( -hbl(ji,jj) / dstokes(ji,jj) ) ) * dstokes(ji,jj) / hbl(ji,jj) ))**pthird * &
+                & ( 1.0 - EXP( -15.0 * dstokes(ji,jj) / hbl(ji,jj) ))
+           ! define La this way so effects of Stokes penetration depth on velocity scale are included
+           zla(ji,jj) = SQRT ( zustar(ji,jj) / zwstrl(ji,jj) )**3
+           ! Velocity scale that tends to zustar for large Langmuir numbers
+           zvstr(ji,jj) = ( zwstrl(ji,jj)**3  + &
+                & ( 1.0 - EXP( -0.5 * zla(ji,jj)**2 ) ) * zustar(ji,jj) * zustar(ji,jj) * zustar(ji,jj) )**pthird
+
+           ! limit maximum value of Langmuir number as approximate treatment for shear turbulence.
+           ! Note zustke and zwstrl are not amended.
+           IF ( zla(ji,jj) >= 0.45 ) zla(ji,jj) = 0.45
+           !
+           ! get convective velocity (zwstrc), stabilty scale (zhol) and logical conection flag lconv
+           IF ( zwbav(ji,jj) > 0.0) THEN
+              zwstrc(ji,jj) = ( 2.0 * zwbav(ji,jj) * 0.9 * hbl(ji,jj) )**pthird
+              zhol(ji,jj) = -0.9 * hbl(ji,jj) * 2.0 * zwbav(ji,jj) / (zvstr(ji,jj)**3 + epsln )
+              lconv(ji,jj) = .TRUE.
+           ELSE
+              zhol(ji,jj) = -hbl(ji,jj) *  2.0 * zwbav(ji,jj)/ (zvstr(ji,jj)**3  + epsln )
+              lconv(ji,jj) = .FALSE.
+           ENDIF
+        END DO
+     END DO
+
+     !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+     ! Mixed-layer model - calculate averages over the boundary layer, and the change in the boundary layer depth
+     !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+     ! BL must be always 2 levels deep.
+      hbl(:,:) = MAX(hbl(:,:), gdepw_n(:,:,3) )
+      ibld(:,:) = 3
+      DO jk = 4, jpkm1
+         DO jj = 2, jpjm1
+            DO ji = 2, jpim1
+               IF ( hbl(ji,jj) >= gdepw_n(ji,jj,jk) ) THEN
+                  ibld(ji,jj) = MIN(mbkt(ji,jj), jk)
+               ENDIF
+            END DO
+         END DO
+      END DO
+
+      DO jj = 2, jpjm1                                 !  Vertical slab
+         DO ji = 2, jpim1
+               zthermal = rab_n(ji,jj,1,jp_tem) !ideally use ibld not 1??
+               zbeta    = rab_n(ji,jj,1,jp_sal)
+               zt   = 0._wp
+               zs   = 0._wp
+               zu   = 0._wp
+               zv   = 0._wp
+               ! average over depth of boundary layer
+               zthick=0._wp
+               DO jm = 2, ibld(ji,jj)
+                  zthick=zthick+e3t_n(ji,jj,jm)
+                  zt   = zt  + e3t_n(ji,jj,jm) * tsn(ji,jj,jm,jp_tem)
+                  zs   = zs  + e3t_n(ji,jj,jm) * tsn(ji,jj,jm,jp_sal)
+                  zu   = zu  + e3t_n(ji,jj,jm) &
+                     &            * ( ub(ji,jj,jm) + ub(ji - 1,jj,jm) ) &
+                     &            / MAX( 1. , umask(ji,jj,jm) + umask(ji - 1,jj,jm) )
+                  zv   = zv  + e3t_n(ji,jj,jm) &
+                     &            * ( vb(ji,jj,jm) + vb(ji,jj - 1,jm) ) &
+                     &            / MAX( 1. , vmask(ji,jj,jm) + vmask(ji,jj - 1,jm) )
+               END DO
+               zt_bl(ji,jj) = zt / zthick
+               zs_bl(ji,jj) = zs / zthick
+               zu_bl(ji,jj) = zu / zthick
+               zv_bl(ji,jj) = zv / zthick
+               zdt_bl(ji,jj) = zt_bl(ji,jj) - tsn(ji,jj,ibld(ji,jj),jp_tem)
+               zds_bl(ji,jj) = zs_bl(ji,jj) - tsn(ji,jj,ibld(ji,jj),jp_sal)
+               zdu_bl(ji,jj) = zu_bl(ji,jj) - ( ub(ji,jj,ibld(ji,jj)) + ub(ji-1,jj,ibld(ji,jj) ) ) &
+                     &    / MAX(1. , umask(ji,jj,ibld(ji,jj) ) + umask(ji-1,jj,ibld(ji,jj) ) )
+               zdv_bl(ji,jj) = zv_bl(ji,jj) - ( vb(ji,jj,ibld(ji,jj)) + vb(ji,jj-1,ibld(ji,jj) ) ) &
+                     &   / MAX(1. , vmask(ji,jj,ibld(ji,jj) ) + vmask(ji,jj-1,ibld(ji,jj) ) )
+               zdb_bl(ji,jj) = grav * zthermal * zdt_bl(ji,jj) - grav * zbeta * zds_bl(ji,jj)
+               IF ( lconv(ji,jj) ) THEN    ! Convective
+                      zwb_ent(ji,jj) = -( 2.0 * 0.2 * zwbav(ji,jj) &
+                           &            + 0.135 * zla(ji,jj) * zwstrl(ji,jj)**3/hbl(ji,jj) )
+
+                      zvel_max =  - ( 1.0 + 1.0 * ( zwstrl(ji,jj)**3 + 0.5 * zwstrc(ji,jj)**3 )**pthird * rn_rdt / hbl(ji,jj) ) &
+                           &   * zwb_ent(ji,jj) / ( zwstrl(ji,jj)**3 + 0.5 * zwstrc(ji,jj)**3 )**pthird
+! Entrainment including component due to shear turbulence. Modified Langmuir component, but gives same result for La=0.3 For testing uncomment.
+!                      zwb_ent(ji,jj) = -( 2.0 * 0.2 * zwbav(ji,jj) &
+!                           &            + ( 0.15 * ( 1.0 - EXP( -0.5 * zla(ji,jj) ) ) + 0.03 / zla(ji,jj)**2 ) * zustar(ji,jj)**3/hbl(ji,jj) )
+
+!                      zvel_max = - ( 1.0 + 1.0 * ( zvstr(ji,jj)**3 + 0.5 * zwstrc(ji,jj)**3 )**pthird * rn_rdt / zhbl(ji,jj) ) * zwb_ent(ji,jj) / &
+!                           &       ( zvstr(ji,jj)**3 + 0.5 * zwstrc(ji,jj)**3 )**pthird
+                      zzdhdt = - zwb_ent(ji,jj) / ( zvel_max + MAX(zdb_bl(ji,jj),0.0) )
+               ELSE                        ! Stable
+                      zzdhdt = 0.32 * ( hbli(ji,jj) / hbl(ji,jj) -1.0 ) * zwstrl(ji,jj)**3 / hbli(ji,jj) &
+                           &   + ( ( 0.32 / 3.0 ) * exp ( -2.5 * ( hbli(ji,jj) / hbl(ji,jj) - 1.0 ) ) &
+                           & - ( 0.32 / 3.0 - 0.135 * zla(ji,jj) ) * exp ( -12.5 * ( hbli(ji,jj) / hbl(ji,jj) ) ) ) &
+                           &  * zwstrl(ji,jj)**3 / hbli(ji,jj)
+                      zzdhdt = zzdhdt + zwbav(ji,jj)
+                      IF ( zzdhdt < 0._wp ) THEN
+                      ! For long timsteps factor in brackets slows the rapid collapse of the OSBL
+                         zpert   = 2.0 * ( 1.0 + 2.0 * zwstrl(ji,jj) * rn_rdt / hbl(ji,jj) ) * zwstrl(ji,jj)**2 / hbl(ji,jj)
+                      ELSE
+                         zpert   = 2.0 * ( 1.0 + 2.0 * zwstrl(ji,jj) * rn_rdt / hbl(ji,jj) ) * zwstrl(ji,jj)**2 / hbl(ji,jj) &
+                              &  + MAX( zdb_bl(ji,jj), 0.0 )
+                      ENDIF
+                      zzdhdt = 2.0 * zzdhdt / zpert
+               ENDIF
+               zdhdt(ji,jj) = zzdhdt
+           END DO
+      END DO
+
+      ! Calculate averages over depth of boundary layer
+      imld = ibld           ! use imld to hold previous blayer index
+      ibld(:,:) = 3
+
+      zhbl_t(:,:) = hbl(:,:) + (zdhdt(:,:) - wn(ji,jj,ibld(ji,jj)))* rn_rdt ! certainly need wb here, so subtract it
+      zhbl_t(:,:) = MIN(zhbl_t(:,:), ht_n(:,:))
+      zdhdt(:,:) = MIN(zdhdt(:,:), (zhbl_t(:,:) - hbl(:,:))/rn_rdt + wn(ji,jj,ibld(ji,jj))) ! adjustment to represent limiting by ocean bottom
+
+      DO jk = 4, jpkm1
+         DO jj = 2, jpjm1
+            DO ji = 2, jpim1
+               IF ( zhbl_t(ji,jj) >= gdepw_n(ji,jj,jk) ) THEN
+                  ibld(ji,jj) =  MIN(mbkt(ji,jj), jk)
+               ENDIF
+            END DO
+         END DO
+      END DO
+
+!
+! Step through model levels taking account of buoyancy change to determine the effect on dhdt
+!
+      DO jj = 2, jpjm1
+         DO ji = 2, jpim1
+            IF ( ibld(ji,jj) - imld(ji,jj) > 1 ) THEN
+!
+! If boundary layer changes by more than one level, need to check for stable layers between initial and final depths.
+!
+               zhbl_s = hbl(ji,jj)
+               jm = imld(ji,jj)
+               zthermal = rab_n(ji,jj,1,jp_tem)
+               zbeta = rab_n(ji,jj,1,jp_sal)
+               IF ( lconv(ji,jj) ) THEN
+!unstable
+                  zvel_max =  - ( 1.0 + 1.0 * ( zvstr(ji,jj)**3 + 0.5 * zwstrc(ji,jj)**3 )**pthird * rn_rdt / hbl(ji,jj) ) &
+                       &   * zwb_ent(ji,jj) / ( zvstr(ji,jj)**3 + 0.5 * zwstrc(ji,jj)**3 )**pthird
+
+                  DO jk = imld(ji,jj), ibld(ji,jj)
+                     zdb = MAX( grav * ( zthermal * ( zt_bl(ji,jj) - tsn(ji,jj,jm,jp_tem) ) &
+                          & - zbeta * ( zs_bl(ji,jj) - tsn(ji,jj,jm,jp_sal) ) ), 0.0 ) + zvel_max
+
+                     zhbl_s = zhbl_s + MIN( - zwb_ent(ji,jj) / zdb * rn_rdt / FLOAT(ibld(ji,jj)-imld(ji,jj) ), e3w_n(ji,jj,jk) )
+                     zhbl_s = MIN(zhbl_s, ht_n(ji,jj))
+
+                     IF ( zhbl_s >= gdepw_n(ji,jj,jm+1) ) jm = jm + 1
+                  END DO
+                  hbl(ji,jj) = zhbl_s
+                  ibld(ji,jj) = jm
+                  hbli(ji,jj) = hbl(ji,jj)
+               ELSE
+! stable
+                  DO jk = imld(ji,jj), ibld(ji,jj)
+                     zdb = MAX( grav * ( zthermal * ( zt_bl(ji,jj) - tsn(ji,jj,jm,jp_tem) )          &
+                          &               - zbeta * ( zs_bl(ji,jj) - tsn(ji,jj,jm,jp_sal) ) ), 0.0 ) &
+                          & + 2.0 * zwstrl(ji,jj)**2 / zhbl_s
+
+                     zhbl_s = zhbl_s +  (                                                                                &
+                          &                     0.32         *                         ( hbli(ji,jj) / zhbl_s -1.0 )     &
+                          &               * zwstrl(ji,jj)**3 / hbli(ji,jj)                                               &
+                          &               + ( ( 0.32 / 3.0 )           * EXP( -  2.5 * ( hbli(ji,jj) / zhbl_s -1.0 ) )   &
+                          &               -   ( 0.32 / 3.0  - 0.0485 ) * EXP( - 12.5 * ( hbli(ji,jj) / zhbl_s      ) ) ) &
+                          &          * zwstrl(ji,jj)**3 / hbli(ji,jj) ) / zdb * e3w_n(ji,jj,jk) / zdhdt(ji,jj)  ! ALMG to investigate whether need to include wn here
+
+                     zhbl_s = MIN(zhbl_s, ht_n(ji,jj))
+                     IF ( zhbl_s >= gdepw_n(ji,jj,jm) ) jm = jm + 1
+                  END DO
+                  hbl(ji,jj) = MAX(zhbl_s, gdepw_n(ji,jj,3) )
+                  ibld(ji,jj) = MAX(jm, 3 )
+                  IF ( hbl(ji,jj) > hbli(ji,jj) ) hbli(ji,jj) = hbl(ji,jj)
+               ENDIF   ! IF ( lconv )
+            ELSE
+! change zero or one model level.
+               hbl(ji,jj) = zhbl_t(ji,jj)
+               IF ( lconv(ji,jj) ) THEN
+                  hbli(ji,jj) = hbl(ji,jj)
+               ELSE
+                  hbl(ji,jj) = MAX(hbl(ji,jj), gdepw_n(ji,jj,3) )
+                  IF ( hbl(ji,jj) > hbli(ji,jj) ) hbli(ji,jj) = hbl(ji,jj)
+               ENDIF
+            ENDIF
+            zhbl(ji,jj) = gdepw_n(ji,jj,ibld(ji,jj))
+         END DO
+      END DO
+      dstokes(:,:) = MIN ( dstokes(:,:), hbl(:,:)/3. )  !  Limit delta for shallow boundary layers for calculating flux-gradient terms.
+
+! Recalculate averages over boundary layer after depth updated
+     ! Consider later  combining this into the loop above and looking for columns
+     ! where the index for base of the boundary layer have changed
+      DO jj = 2, jpjm1                                 !  Vertical slab
+         DO ji = 2, jpim1
+               zthermal = rab_n(ji,jj,1,jp_tem) !ideally use ibld not 1??
+               zbeta    = rab_n(ji,jj,1,jp_sal)
+               zt   = 0._wp
+               zs   = 0._wp
+               zu   = 0._wp
+               zv   = 0._wp
+               ! average over depth of boundary layer
+               zthick=0._wp
+               DO jm = 2, ibld(ji,jj)
+                  zthick=zthick+e3t_n(ji,jj,jm)
+                  zt   = zt  + e3t_n(ji,jj,jm) * tsn(ji,jj,jm,jp_tem)
+                  zs   = zs  + e3t_n(ji,jj,jm) * tsn(ji,jj,jm,jp_sal)
+                  zu   = zu  + e3t_n(ji,jj,jm) &
+                     &            * ( ub(ji,jj,jm) + ub(ji - 1,jj,jm) ) &
+                     &            / MAX( 1. , umask(ji,jj,jm) + umask(ji - 1,jj,jm) )
+                  zv   = zv  + e3t_n(ji,jj,jm) &
+                     &            * ( vb(ji,jj,jm) + vb(ji,jj - 1,jm) ) &
+                     &            / MAX( 1. , vmask(ji,jj,jm) + vmask(ji,jj - 1,jm) )
+               END DO
+               zt_bl(ji,jj) = zt / zthick
+               zs_bl(ji,jj) = zs / zthick
+               zu_bl(ji,jj) = zu / zthick
+               zv_bl(ji,jj) = zv / zthick
+               zdt_bl(ji,jj) = zt_bl(ji,jj) - tsn(ji,jj,ibld(ji,jj),jp_tem)
+               zds_bl(ji,jj) = zs_bl(ji,jj) - tsn(ji,jj,ibld(ji,jj),jp_sal)
+               zdu_bl(ji,jj) = zu_bl(ji,jj) - ( ub(ji,jj,ibld(ji,jj)) + ub(ji-1,jj,ibld(ji,jj) ) ) &
+                      &   / MAX(1. , umask(ji,jj,ibld(ji,jj) ) + umask(ji-1,jj,ibld(ji,jj) ) )
+               zdv_bl(ji,jj) = zv_bl(ji,jj) - ( vb(ji,jj,ibld(ji,jj)) + vb(ji,jj-1,ibld(ji,jj) ) ) &
+                      &  / MAX(1. , vmask(ji,jj,ibld(ji,jj) ) + vmask(ji,jj-1,ibld(ji,jj) ) )
+               zdb_bl(ji,jj) = grav * zthermal * zdt_bl(ji,jj) - grav * zbeta * zds_bl(ji,jj)
+               zhbl(ji,jj) = gdepw_n(ji,jj,ibld(ji,jj))
+               IF ( lconv(ji,jj) ) THEN
+                  IF ( zdb_bl(ji,jj) > 0._wp )THEN
+                     IF ( ( zwstrc(ji,jj) / zvstr(ji,jj) )**3 <= 0.5 ) THEN  ! near neutral stability
+                           zari = 4.5 * ( zvstr(ji,jj)**2 ) &
+                             & / ( zdb_bl(ji,jj) * zhbl(ji,jj) ) + 0.01
+                     ELSE                                                     ! unstable
+                           zari = 4.5 * ( zwstrc(ji,jj)**2 ) &
+                             & / ( zdb_bl(ji,jj) * zhbl(ji,jj) ) + 0.01
+                     ENDIF
+                     IF ( zari > 0.2 ) THEN                                                ! This test checks for weakly stratified pycnocline
+                        zari = 0.2
+                        zwb_ent(ji,jj) = 0._wp
+                     ENDIF
+                     inhml = MAX( INT( zari * zhbl(ji,jj) / e3t_n(ji,jj,ibld(ji,jj)) ) , 1 )
+                     imld(ji,jj) = MAX( ibld(ji,jj) - inhml, 1)
+                     zhml(ji,jj) = gdepw_n(ji,jj,imld(ji,jj))
+                     zdh(ji,jj) = zhbl(ji,jj) - zhml(ji,jj)
+                  ELSE  ! IF (zdb_bl)
+                     imld(ji,jj) = ibld(ji,jj) - 1
+                     zhml(ji,jj) = gdepw_n(ji,jj,imld(ji,jj))
+                     zdh(ji,jj) = zhbl(ji,jj) - zhml(ji,jj)
+                  ENDIF
+               ELSE   ! IF (lconv)
+                  IF ( zdhdt(ji,jj) >= 0.0 ) THEN    ! probably shouldn't include wm here
+                  ! boundary layer deepening
+                     IF ( zdb_bl(ji,jj) > 0._wp ) THEN
+                  ! pycnocline thickness set by stratification - use same relationship as for neutral conditions.
+                        zari = MIN( 4.5 * ( zvstr(ji,jj)**2 ) &
+                          & / ( zdb_bl(ji,jj) * zhbl(ji,jj) ) + 0.01  , 0.2 )
+                        inhml = MAX( INT( zari * zhbl(ji,jj) / e3t_n(ji,jj,ibld(ji,jj)) ) , 1 )
+                        imld(ji,jj) = MAX( ibld(ji,jj) - inhml, 1)
+                        zhml(ji,jj) = gdepw_n(ji,jj,imld(ji,jj))
+                        zdh(ji,jj) = zhbl(ji,jj) - zhml(ji,jj)
+                     ELSE
+                        imld(ji,jj) = ibld(ji,jj) - 1
+                        zhml(ji,jj) = gdepw_n(ji,jj,imld(ji,jj))
+                        zdh(ji,jj) = zhbl(ji,jj) - zhml(ji,jj)
+                     ENDIF ! IF (zdb_bl > 0.0)
+                  ELSE     ! IF(dhdt >= 0)
+                  ! boundary layer collapsing.
+                     imld(ji,jj) = ibld(ji,jj)
+                     zhml(ji,jj) = zhbl(ji,jj)
+                     zdh(ji,jj) = 0._wp
+                  ENDIF    ! IF (dhdt >= 0)
+               ENDIF       ! IF (lconv)
+         END DO
+      END DO
+
+      ! Average over the depth of the mixed layer in the convective boundary layer
+      ! Also calculate entrainment fluxes for temperature and salinity
+      DO jj = 2, jpjm1                                 !  Vertical slab
+         DO ji = 2, jpim1
+            zthermal = rab_n(ji,jj,1,jp_tem) !ideally use ibld not 1??
+            zbeta    = rab_n(ji,jj,1,jp_sal)
+            IF ( lconv(ji,jj) ) THEN
+               zt   = 0._wp
+               zs   = 0._wp
+               zu   = 0._wp
+               zv   = 0._wp
+               ! average over depth of boundary layer
+               zthick=0._wp
+               DO jm = 2, imld(ji,jj)
+                  zthick=zthick+e3t_n(ji,jj,jm)
+                  zt   = zt  + e3t_n(ji,jj,jm) * tsn(ji,jj,jm,jp_tem)
+                  zs   = zs  + e3t_n(ji,jj,jm) * tsn(ji,jj,jm,jp_sal)
+                  zu   = zu  + e3t_n(ji,jj,jm) &
+                     &            * ( ub(ji,jj,jm) + ub(ji - 1,jj,jm) ) &
+                     &            / MAX( 1. , umask(ji,jj,jm) + umask(ji - 1,jj,jm) )
+                  zv   = zv  + e3t_n(ji,jj,jm) &
+                     &            * ( vb(ji,jj,jm) + vb(ji,jj - 1,jm) ) &
+                     &            / MAX( 1. , vmask(ji,jj,jm) + vmask(ji,jj - 1,jm) )
+               END DO
+               zt_ml(ji,jj) = zt / zthick
+               zs_ml(ji,jj) = zs / zthick
+               zu_ml(ji,jj) = zu / zthick
+               zv_ml(ji,jj) = zv / zthick
+               zdt_ml(ji,jj) = zt_ml(ji,jj) - tsn(ji,jj,ibld(ji,jj),jp_tem)
+               zds_ml(ji,jj) = zs_ml(ji,jj) - tsn(ji,jj,ibld(ji,jj),jp_sal)
+               zdu_ml(ji,jj) = zu_ml(ji,jj) - ( ub(ji,jj,ibld(ji,jj)) + ub(ji-1,jj,ibld(ji,jj) ) ) &
+                     &    / MAX(1. , umask(ji,jj,ibld(ji,jj) ) + umask(ji-1,jj,ibld(ji,jj) ) )
+               zdv_ml(ji,jj) = zv_ml(ji,jj) - ( vb(ji,jj,ibld(ji,jj)) + vb(ji,jj-1,ibld(ji,jj) ) ) &
+                     &    / MAX(1. , vmask(ji,jj,ibld(ji,jj) ) + vmask(ji,jj-1,ibld(ji,jj) ) )
+               zdb_ml(ji,jj) = grav * zthermal * zdt_ml(ji,jj) - grav * zbeta * zds_ml(ji,jj)
+            ELSE
+            ! stable, if entraining calulate average below interface layer.
+               IF ( zdhdt(ji,jj) >= 0._wp ) THEN
+                  zt   = 0._wp
+                  zs   = 0._wp
+                  zu   = 0._wp
+                  zv   = 0._wp
+                  ! average over depth of boundary layer
+                  zthick=0._wp
+                  DO jm = 2, imld(ji,jj)
+                     zthick=zthick+e3t_n(ji,jj,jm)
+                     zt   = zt  + e3t_n(ji,jj,jm) * tsn(ji,jj,jm,jp_tem)
+                     zs   = zs  + e3t_n(ji,jj,jm) * tsn(ji,jj,jm,jp_sal)
+                     zu   = zu  + e3t_n(ji,jj,jm) &
+                        &            * ( ub(ji,jj,jm) + ub(ji - 1,jj,jm) ) &
+                        &            / MAX( 1. , umask(ji,jj,jm) + umask(ji - 1,jj,jm) )
+                     zv   = zv  + e3t_n(ji,jj,jm) &
+                        &            * ( vb(ji,jj,jm) + vb(ji,jj - 1,jm) ) &
+                        &            / MAX( 1. , vmask(ji,jj,jm) + vmask(ji,jj - 1,jm) )
+                  END DO
+                  zt_ml(ji,jj) = zt / zthick
+                  zs_ml(ji,jj) = zs / zthick
+                  zu_ml(ji,jj) = zu / zthick
+                  zv_ml(ji,jj) = zv / zthick
+                  zdt_ml(ji,jj) = zt_ml(ji,jj) - tsn(ji,jj,ibld(ji,jj),jp_tem)
+                  zds_ml(ji,jj) = zs_ml(ji,jj) - tsn(ji,jj,ibld(ji,jj),jp_sal)
+                  zdu_ml(ji,jj) = zu_ml(ji,jj) - ( ub(ji,jj,ibld(ji,jj)) + ub(ji-1,jj,ibld(ji,jj) ) ) &
+                        &    / MAX(1. , umask(ji,jj,ibld(ji,jj) ) + umask(ji-1,jj,ibld(ji,jj) ) )
+                  zdv_ml(ji,jj) = zv_ml(ji,jj) - ( vb(ji,jj,ibld(ji,jj)) + vb(ji,jj-1,ibld(ji,jj) ) ) &
+                        &    / MAX(1. , vmask(ji,jj,ibld(ji,jj) ) + vmask(ji,jj-1,ibld(ji,jj) ) )
+                  zdb_ml(ji,jj) = grav * zthermal * zdt_ml(ji,jj) - grav * zbeta * zds_ml(ji,jj)
+               ENDIF
+            ENDIF
+         END DO
+      END DO
+    !
+    ! rotate mean currents and changes onto wind align co-ordinates
+    !
+
+      DO jj = 2, jpjm1
+         DO ji = 2, jpim1
+            ztemp = zu_ml(ji,jj)
+            zu_ml(ji,jj) = zu_ml(ji,jj) * zcos_wind(ji,jj) + zv_ml(ji,jj) * zsin_wind(ji,jj)
+            zv_ml(ji,jj) = zv_ml(ji,jj) * zcos_wind(ji,jj) - ztemp * zsin_wind(ji,jj)
+            ztemp = zdu_ml(ji,jj)
+            zdu_ml(ji,jj) = zdu_ml(ji,jj) * zcos_wind(ji,jj) + zdv_ml(ji,jj) * zsin_wind(ji,jj)
+            zdv_ml(ji,jj) = zdv_ml(ji,jj) * zsin_wind(ji,jj) - ztemp * zsin_wind(ji,jj)
+    !
+            ztemp = zu_bl(ji,jj)
+            zu_bl = zu_bl(ji,jj) * zcos_wind(ji,jj) + zv_bl(ji,jj) * zsin_wind(ji,jj)
+            zv_bl(ji,jj) = zv_bl(ji,jj) * zcos_wind(ji,jj) - ztemp * zsin_wind(ji,jj)
+            ztemp = zdu_bl(ji,jj)
+            zdu_bl(ji,jj) = zdu_bl(ji,jj) * zcos_wind(ji,jj) + zdv_bl(ji,jj) * zsin_wind(ji,jj)
+            zdv_bl(ji,jj) = zdv_bl(ji,jj) * zsin_wind(ji,jj) - ztemp * zsin_wind(ji,jj)
+         END DO
+      END DO
+
+     zuw_bse = 0._wp
+     zvw_bse = 0._wp
+     DO jj = 2, jpjm1
+        DO ji = 2, jpim1
+
+           IF ( lconv(ji,jj) ) THEN
+              IF ( zdb_bl(ji,jj) > 0._wp ) THEN
+                 zwth_ent(ji,jj) = zwb_ent(ji,jj) * zdt_ml(ji,jj) / (zdb_ml(ji,jj) + epsln)
+                 zws_ent(ji,jj) = zwb_ent(ji,jj) * zds_ml(ji,jj) / (zdb_ml(ji,jj) + epsln)
+              ENDIF
+           ELSE
+              zwth_ent(ji,jj) = -2.0 * zwthav(ji,jj) * ( (1.0 - 0.8) - ( 1.0 - 0.8)**(3.0/2.0) )
+              zws_ent(ji,jj) = -2.0 * zwsav(ji,jj) * ( (1.0 - 0.8 ) - ( 1.0 - 0.8 )**(3.0/2.0) )
+           ENDIF
+        END DO
+     END DO
+
+      !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+      !  Pycnocline gradients for scalars and velocity
+      !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+
+       DO jj = 2, jpjm1
+          DO ji = 2, jpim1
+          !
+             IF ( lconv (ji,jj) ) THEN
+             ! Unstable conditions
+                IF( zdb_bl(ji,jj) > 0._wp ) THEN
+                ! calculate pycnocline profiles, no need if zdb_bl <= 0. since profile is zero and arrays have been initialized to zero
+                   ztgrad = ( zdt_ml(ji,jj) / zdh(ji,jj) )
+                   zsgrad = ( zds_ml(ji,jj) / zdh(ji,jj) )
+                   zbgrad = ( zdb_ml(ji,jj) / zdh(ji,jj) )
+                   DO jk = 2 , ibld(ji,jj)
+                      znd = -( gdepw_n(ji,jj,jk) - zhml(ji,jj) ) / zdh(ji,jj)
+                      zdtdz_pyc(ji,jj,jk) =  ztgrad * EXP( -1.75 * ( znd + 0.75 )**2 )
+                      zdbdz_pyc(ji,jj,jk) =  zbgrad * EXP( -1.75 * ( znd + 0.75 )**2 )
+                      zdsdz_pyc(ji,jj,jk) =  zsgrad * EXP( -1.75 * ( znd + 0.75 )**2 )
+                   END DO
+                ENDIF
+             ELSE
+             ! stable conditions
+             ! if pycnocline profile only defined when depth steady of increasing.
+                IF ( zdhdt(ji,jj) >= 0.0 ) THEN        ! Depth increasing, or steady.
+                   IF ( zdb_bl(ji,jj) > 0._wp ) THEN
+                     IF ( zhol(ji,jj) >= 0.5 ) THEN      ! Very stable - 'thick' pycnocline
+                         ztgrad = zdt_bl(ji,jj) / zhbl(ji,jj)
+                         zsgrad = zds_bl(ji,jj) / zhbl(ji,jj)
+                         zbgrad = zdb_bl(ji,jj) / zhbl(ji,jj)
+                         DO jk = 2, ibld(ji,jj)
+                            znd = gdepw_n(ji,jj,jk) / zhbl(ji,jj)
+                            zdtdz_pyc(ji,jj,jk) =  ztgrad * EXP( -15.0 * ( znd - 0.9 )**2 )
+                            zdbdz_pyc(ji,jj,jk) =  zbgrad * EXP( -15.0 * ( znd - 0.9 )**2 )
+                            zdsdz_pyc(ji,jj,jk) =  zsgrad * EXP( -15.0 * ( znd - 0.9 )**2 )
+                         END DO
+                     ELSE                                   ! Slightly stable - 'thin' pycnoline - needed when stable layer begins to form.
+                         ztgrad = zdt_bl(ji,jj) / zdh(ji,jj)
+                         zsgrad = zds_bl(ji,jj) / zdh(ji,jj)
+                         zbgrad = zdb_bl(ji,jj) / zdh(ji,jj)
+                         DO jk = 2, ibld(ji,jj)
+                            znd = -( gdepw_n(ji,jj,jk) - zhml(ji,jj) ) / zdh(ji,jj)
+                            zdtdz_pyc(ji,jj,jk) =  ztgrad * EXP( -1.75 * ( znd + 0.75 )**2 )
+                            zdbdz_pyc(ji,jj,jk) =  zbgrad * EXP( -1.75 * ( znd + 0.75 )**2 )
+                            zdsdz_pyc(ji,jj,jk) =  zsgrad * EXP( -1.75 * ( znd + 0.75 )**2 )
+                         END DO
+                      ENDIF ! IF (zhol >=0.5)
+                   ENDIF    ! IF (zdb_bl> 0.)
+                ENDIF       ! IF (zdhdt >= 0) zdhdt < 0 not considered since pycnocline profile is zero, profile arrays are intialized to zero
+             ENDIF          ! IF (lconv)
+            !
+          END DO
+       END DO
+!
+       DO jj = 2, jpjm1
+          DO ji = 2, jpim1
+          !
+             IF ( lconv (ji,jj) ) THEN
+             ! Unstable conditions
+                 zugrad = ( zdu_ml(ji,jj) / zdh(ji,jj) ) + 0.275 * zustar(ji,jj)*zustar(ji,jj) / &
+               & (( zwstrl(ji,jj)**3 + 0.5 * zwstrc(ji,jj)**3 )**pthird * zhml(ji,jj) ) / zla(ji,jj)**(8.0/3.0)
+                zvgrad = ( zdv_ml(ji,jj) / zdh(ji,jj) ) + 3.5 * ff_t(ji,jj) * zustke(ji,jj) / &
+              & ( zwstrl(ji,jj)**3 + 0.5 * zwstrc(ji,jj)**3 )**pthird
+                DO jk = 2 , ibld(ji,jj)-1
+                   znd = -( gdepw_n(ji,jj,jk) - zhml(ji,jj) ) / zdh(ji,jj)
+                   zdudz_pyc(ji,jj,jk) =  zugrad * EXP( -1.75 * ( znd + 0.75 )**2 )
+                   zdvdz_pyc(ji,jj,jk) = zvgrad * EXP( -1.75 * ( znd + 0.75 )**2 )
+                END DO
+             ELSE
+             ! stable conditions
+                zugrad = 3.25 * zdu_bl(ji,jj) / zhbl(ji,jj)
+                zvgrad = 2.75 * zdv_bl(ji,jj) / zhbl(ji,jj)
+                DO jk = 2, ibld(ji,jj)
+                   znd = gdepw_n(ji,jj,jk) / zhbl(ji,jj)
+                   IF ( znd < 1.0 ) THEN
+                      zdudz_pyc(ji,jj,jk) = zugrad * EXP( -40.0 * ( znd - 1.0 )**2 )
+                   ELSE
+                      zdudz_pyc(ji,jj,jk) = zugrad * EXP( -20.0 * ( znd - 1.0 )**2 )
+                   ENDIF
+                   zdvdz_pyc(ji,jj,jk) = zvgrad * EXP( -20.0 * ( znd - 0.85 )**2 )
+                END DO
+             ENDIF
+            !
+          END DO
+       END DO
+       !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+       ! Eddy viscosity/diffusivity and non-gradient terms in the flux-gradient relationship
+       !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+
+      ! WHERE ( lconv )
+      !     zdifml_sc = zhml * ( zwstrl**3 + 0.5 * zwstrc**3 )**pthird
+      !     zvisml_sc = zdifml_sc
+      !     zdifpyc_sc = 0.165 * ( zwstrl**3 + zwstrc**3 )**pthird * ( zhbl - zhml )
+      !     zvispyc_sc = 0.142 * ( zwstrl**3 + 0.5 * zwstrc**3 )**pthird * ( zhbl - zhml )
+      !     zbeta_d_sc = 1.0 - (0.165 / 0.8 * ( zhbl - zhml ) / zhbl )**p2third
+      !     zbeta_v_sc = 1.0 -  2.0 * (0.142 /0.375) * (zhbl - zhml ) / zhml
+      !  ELSEWHERE
+      !     zdifml_sc = zwstrl * zhbl * EXP ( -( zhol / 0.183_wp )**2 )
+      !     zvisml_sc = zwstrl * zhbl * EXP ( -( zhol / 0.183_wp )**2 )
+      !  ENDWHERE
+       DO jj = 2, jpjm1
+          DO ji = 2, jpim1
+             IF ( lconv(ji,jj) ) THEN
+               zdifml_sc(ji,jj) = zhml(ji,jj) * ( zvstr(ji,jj)**3 + 0.5 * zwstrc(ji,jj)**3 )**pthird
+               zvisml_sc(ji,jj) = zdifml_sc(ji,jj)
+               zdifpyc_sc(ji,jj) = 0.165 * ( zvstr(ji,jj)**3 + 0.5 *zwstrc(ji,jj)**3 )**pthird * zdh(ji,jj)
+               zvispyc_sc(ji,jj) = 0.142 * ( zvstr(ji,jj)**3 + 0.5 * zwstrc(ji,jj)**3 )**pthird * zdh(ji,jj)
+               zbeta_d_sc(ji,jj) = 1.0 - (0.165 / 0.8 * zdh(ji,jj) / zhbl(ji,jj) )**p2third
+               zbeta_v_sc(ji,jj) = 1.0 -  2.0 * (0.142 /0.375) * zdh(ji,jj) / zhml(ji,jj)
+             ELSE
+               zdifml_sc(ji,jj) = zvstr(ji,jj) * zhbl(ji,jj) * EXP ( -( zhol(ji,jj) / 0.6_wp )**2 )
+               zvisml_sc(ji,jj) = zvstr(ji,jj) * zhbl(ji,jj) * EXP ( -( zhol(ji,jj) / 0.6_wp )**2 )
+            END IF
+        END DO
+    END DO
+!
+       DO jj = 2, jpjm1
+          DO ji = 2, jpim1
+             IF ( lconv(ji,jj) ) THEN
+                DO jk = 2, imld(ji,jj)   ! mixed layer diffusivity
+                    zznd_ml = gdepw_n(ji,jj,jk) / zhml(ji,jj)
+                    !
+                    zdiffut(ji,jj,jk) = 0.8   * zdifml_sc(ji,jj) * zznd_ml * ( 1.0 - zbeta_d_sc(ji,jj) * zznd_ml    )**1.5
+                    !
+                    zviscos(ji,jj,jk) = 0.375 * zvisml_sc(ji,jj) * zznd_ml * ( 1.0 - zbeta_v_sc(ji,jj) * zznd_ml    ) &
+                         &            *                                      ( 1.0 -               0.5 * zznd_ml**2 )
+                END DO
+                ! pycnocline - if present linear profile
+                IF ( zdh(ji,jj) > 0._wp ) THEN
+                   DO jk = imld(ji,jj)+1 , ibld(ji,jj)
+                       zznd_pyc = -( gdepw_n(ji,jj,jk) - zhml(ji,jj) ) / zdh(ji,jj)
+                       !
+                       zdiffut(ji,jj,jk) = zdifpyc_sc(ji,jj) * ( 1.0 + zznd_pyc )
+                       !
+                       zviscos(ji,jj,jk) = zvispyc_sc(ji,jj) * ( 1.0 + zznd_pyc )
+                   END DO
+                ENDIF
+                ! Temporay fix to ensure zdiffut is +ve; won't be necessary with wn taken out
+                zdiffut(ji,jj,ibld(ji,jj)) = zdhdt(ji,jj)* e3t_n(ji,jj,ibld(ji,jj))
+                ! could be taken out, take account of entrainment represents as a diffusivity
+                ! should remove w from here, represents entrainment
+             ELSE
+             ! stable conditions
+                DO jk = 2, ibld(ji,jj)
+                   zznd_ml = gdepw_n(ji,jj,jk) / zhbl(ji,jj)
+                   zdiffut(ji,jj,jk) = 0.75 * zdifml_sc(ji,jj) * zznd_ml * ( 1.0 - zznd_ml )**1.5
+                   zviscos(ji,jj,jk) = 0.375 * zvisml_sc(ji,jj) * zznd_ml * (1.0 - zznd_ml) * ( 1.0 - zznd_ml**2 )
+                END DO
+             ENDIF   ! end if ( lconv )
+!
+          END DO  ! end of ji loop
+       END DO     ! end of jj loop
+
+       !
+       ! calculate non-gradient components of the flux-gradient relationships
+       !
+! Stokes term in scalar flux, flux-gradient relationship
+       WHERE ( lconv )
+          zsc_wth_1 = zwstrl**3 * zwth0 / ( zvstr**3 + 0.5 * zwstrc**3 + epsln)
+          !
+          zsc_ws_1 = zwstrl**3 * zws0 / ( zvstr**3 + 0.5 * zwstrc**3 + epsln )
+       ELSEWHERE
+          zsc_wth_1 = 2.0 * zwthav
+          !
+          zsc_ws_1 = 2.0 * zwsav
+       ENDWHERE
+
+
+       DO jj = 2, jpjm1
+          DO ji = 2, jpim1
+            IF ( lconv(ji,jj) ) THEN
+              DO jk = 2, imld(ji,jj)
+                 zznd_d = gdepw_n(ji,jj,jk) / dstokes(ji,jj)
+                 ghamt(ji,jj,jk) = ghamt(ji,jj,jk) + 1.35 * EXP ( -zznd_d ) * ( 1.0 - EXP ( -2.0 * zznd_d ) ) * zsc_wth_1(ji,jj)
+                 !
+                 ghams(ji,jj,jk) = ghams(ji,jj,jk) + 1.35 * EXP ( -zznd_d ) * ( 1.0 - EXP ( -2.0 * zznd_d ) ) *  zsc_ws_1(ji,jj)
+              END DO ! end jk loop
+            ELSE     ! else for if (lconv)
+ ! Stable conditions
+               DO jk = 2, ibld(ji,jj)
+                  zznd_d=gdepw_n(ji,jj,jk) / dstokes(ji,jj)
+                  ghamt(ji,jj,jk) = ghamt(ji,jj,jk) + 1.5 * EXP ( -0.9 * zznd_d ) &
+                       &          *                 ( 1.0 - EXP ( -4.0 * zznd_d ) ) * zsc_wth_1(ji,jj)
+                  !
+                  ghams(ji,jj,jk) = ghams(ji,jj,jk) + 1.5 * EXP ( -0.9 * zznd_d ) &
+                       &          *                 ( 1.0 - EXP ( -4.0 * zznd_d ) ) *  zsc_ws_1(ji,jj)
+               END DO
+            ENDIF               ! endif for check on lconv
+
+          END DO  ! end of ji loop
+       END DO     ! end of jj loop
+
+
+! Stokes term in flux-gradient relationship (note in zsc_uw_n don't use zvstr since term needs to go to zero as zwstrl goes to zero)
+       WHERE ( lconv )
+          zsc_uw_1 = ( zwstrl**3 + 0.5 * zwstrc**3 )**pthird * zustke /( 1.0 - 1.0 * 6.5 * zla**(8.0/3.0) )
+          zsc_uw_2 = ( zwstrl**3 + 0.5 * zwstrc**3 )**pthird * zustke / ( zla**(8.0/3.0) + epsln )
+          zsc_vw_1 = ff_t * zhml * zustke**3 * zla**(8.0/3.0) / ( ( zvstr**3 + 0.5 * zwstrc**3 )**(2.0/3.0) + epsln )
+       ELSEWHERE
+          zsc_uw_1 = zustar**2
+          zsc_vw_1 = ff_t * zhbl * zustke**3 * zla**(8.0/3.0) / (zvstr**2 + epsln)
+       ENDWHERE
+
+       DO jj = 2, jpjm1
+          DO ji = 2, jpim1
+             IF ( lconv(ji,jj) ) THEN
+                DO jk = 2, imld(ji,jj)
+                   zznd_d = gdepw_n(ji,jj,jk) / dstokes(ji,jj)
+                   ghamu(ji,jj,jk) = ghamu(ji,jj,jk) +      ( -0.05 * EXP ( -0.4 * zznd_d )   * zsc_uw_1(ji,jj)   &
+                        &          +                        0.00125 * EXP (      - zznd_d )   * zsc_uw_2(ji,jj) ) &
+                        &          *                          ( 1.0 - EXP ( -2.0 * zznd_d ) )
+!
+                   ghamv(ji,jj,jk) = ghamv(ji,jj,jk) - 0.65 *  0.15 * EXP (      - zznd_d )                       &
+                        &          *                          ( 1.0 - EXP ( -2.0 * zznd_d ) ) * zsc_vw_1(ji,jj)
+                END DO   ! end jk loop
+             ELSE
+! Stable conditions
+                DO jk = 2, ibld(ji,jj) ! corrected to ibld
+                   zznd_d = gdepw_n(ji,jj,jk) / dstokes(ji,jj)
+                   ghamu(ji,jj,jk) = ghamu(ji,jj,jk) - 0.75 *   1.3 * EXP ( -0.5 * zznd_d )                       &
+                        &                                   * ( 1.0 - EXP ( -4.0 * zznd_d ) ) * zsc_uw_1(ji,jj)
+                   ghamv(ji,jj,jk) = ghamv(ji,jj,jk) + 0._wp
+                END DO   ! end jk loop
+             ENDIF
+          END DO  ! ji loop
+       END DO     ! jj loo
+
+! Buoyancy term in flux-gradient relationship [note : includes ROI ratio (X0.3) and pressure (X0.5)]
+
+       WHERE ( lconv )
+          zsc_wth_1 = zwbav * zwth0 * ( 1.0 + EXP ( 0.2 * zhol ) ) / ( zvstr**3 + 0.5 * zwstrc**3 + epsln )
+          zsc_ws_1  = zwbav * zws0  * ( 1.0 + EXP ( 0.2 * zhol ) ) / ( zvstr**3 + 0.5 * zwstrc**3 + epsln )
+       ELSEWHERE
+          zsc_wth_1 = 0._wp
+          zsc_ws_1 = 0._wp
+       ENDWHERE
+
+       DO jj = 2, jpjm1
+          DO ji = 2, jpim1
+             IF (lconv(ji,jj) ) THEN
+                DO jk = 2, imld(ji,jj)
+                   zznd_ml = gdepw_n(ji,jj,jk) / zhml(ji,jj)
+                   ! calculate turbulent length scale
+                   zl_c = 0.9 * ( 1.0 - EXP ( - 7.0 * ( zznd_ml - zznd_ml**3 / 3.0 ) ) )                                           &
+                        &     * ( 1.0 - EXP ( -15.0 * (     1.1 - zznd_ml          ) ) )
+                   zl_l = 2.0 * ( 1.0 - EXP ( - 2.0 * ( zznd_ml - zznd_ml**3 / 3.0 ) ) )                                           &
+                        &     * ( 1.0 - EXP ( - 5.0 * (     1.0 - zznd_ml          ) ) ) * ( 1.0 + dstokes(ji,jj) / zhml (ji,jj) )
+                   zl_eps = zl_l + ( zl_c - zl_l ) / ( 1.0 + EXP ( 3.0 * LOG10 ( - zhol(ji,jj) ) ) ) ** (3.0/2.0)
+                   ! non-gradient buoyancy terms
+                   ghamt(ji,jj,jk) = ghamt(ji,jj,jk) + 0.3 * 0.5 * zsc_wth_1(ji,jj) * zl_eps * zhml(ji,jj) / ( 0.15 + zznd_ml )
+                   ghams(ji,jj,jk) = ghams(ji,jj,jk) + 0.3 * 0.5 *  zsc_ws_1(ji,jj) * zl_eps * zhml(ji,jj) / ( 0.15 + zznd_ml )
+                END DO
+             ELSE
+                DO jk = 2, ibld(ji,jj)
+                   ghamt(ji,jj,jk) = ghamt(ji,jj,jk) + zsc_wth_1(ji,jj)
+                   ghams(ji,jj,jk) = ghams(ji,jj,jk) +  zsc_ws_1(ji,jj)
+                END DO
+             ENDIF
+          END DO   ! ji loop
+       END DO      ! jj loop
+
+
+       WHERE ( lconv )
+          zsc_uw_1 = -zwb0 * zustar**2 * zhml / ( zvstr**3 + 0.5 * zwstrc**3 + epsln )
+          zsc_uw_2 =  zwb0 * zustke    * zhml / ( zvstr**3 + 0.5 * zwstrc**3 + epsln )**(2.0/3.0)
+          zsc_vw_1 = 0._wp
+       ELSEWHERE
+         zsc_uw_1 = 0._wp
+         zsc_vw_1 = 0._wp
+       ENDWHERE
+
+       DO jj = 2, jpjm1
+          DO ji = 2, jpim1
+             IF ( lconv(ji,jj) ) THEN
+                DO jk = 2 , imld(ji,jj)
+                   zznd_d = gdepw_n(ji,jj,jk) / dstokes(ji,jj)
+                   ghamu(ji,jj,jk) = ghamu(ji,jj,jk) + 0.3 * 0.5 * ( zsc_uw_1(ji,jj) +   0.125 * EXP( -0.5 * zznd_d )     &
+                        &                                                            * (   1.0 - EXP( -0.5 * zznd_d ) )   &
+                        &                                          * zsc_uw_2(ji,jj)                                    )
+                   ghamv(ji,jj,jk) = ghamv(ji,jj,jk) + zsc_vw_1(ji,jj)
+                END DO  ! jk loop
+             ELSE
+             ! stable conditions
+                DO jk = 2, ibld(ji,jj)
+                   ghamu(ji,jj,jk) = ghamu(ji,jj,jk) + zsc_uw_1(ji,jj)
+                   ghamv(ji,jj,jk) = ghamv(ji,jj,jk) + zsc_vw_1(ji,jj)
+                END DO
+             ENDIF
+          END DO        ! ji loop
+       END DO           ! jj loop
+
+! Transport term in flux-gradient relationship [note : includes ROI ratio (X0.3) ]
+
+       WHERE ( lconv )
+          zsc_wth_1 = zwth0
+          zsc_ws_1 = zws0
+       ELSEWHERE
+          zsc_wth_1 = 2.0 * zwthav
+          zsc_ws_1 = zws0
+       ENDWHERE
+
+       DO jj = 2, jpjm1
+          DO ji = 2, jpim1
+            IF ( lconv(ji,jj) ) THEN
+               DO jk = 2, imld(ji,jj)
+                  zznd_ml=gdepw_n(ji,jj,jk) / zhml(ji,jj)
+                  ghamt(ji,jj,jk) = ghamt(ji,jj,jk) + 0.3 * zsc_wth_1(ji,jj)                &
+                       &          * ( -2.0 + 2.75 * (       ( 1.0 + 0.6 * zznd_ml**4 )      &
+                       &                               - EXP(     - 6.0 * zznd_ml    ) ) )  &
+                       &          * ( 1.0 - EXP( - 15.0 * (         1.0 - zznd_ml    ) ) )
+                  !
+                  ghams(ji,jj,jk) = ghams(ji,jj,jk) + 0.3 * zsc_ws_1(ji,jj)  &
+                       &          * ( -2.0 + 2.75 * (       ( 1.0 + 0.6 * zznd_ml**4 )      &
+                       &                               - EXP(     - 6.0 * zznd_ml    ) ) )  &
+                       &          * ( 1.0 - EXP ( -15.0 * (         1.0 - zznd_ml    ) ) )
+               END DO
+            ELSE
+               DO jk = 2, ibld(ji,jj)
+                  zznd_d = gdepw_n(ji,jj,jk) / dstokes(ji,jj)
+                  znd = gdepw_n(ji,jj,jk) / zhbl(ji,jj)
+                  ghamt(ji,jj,jk) = ghamt(ji,jj,jk) + 0.3 * ( -4.06 * EXP( -2.0 * zznd_d ) * (1.0 - EXP( -4.0 * zznd_d ) ) + &
+               &  7.5 * EXP ( -10.0 * ( 0.95 - znd )**2 ) * ( 1.0 - znd ) ) * zsc_wth_1(ji,jj)
+                  ghams(ji,jj,jk) = ghams(ji,jj,jk) + 0.3 * ( -4.06 * EXP( -2.0 * zznd_d ) * (1.0 - EXP( -4.0 * zznd_d ) ) + &
+               &  7.5 * EXP ( -10.0 * ( 0.95 - znd )**2 ) * ( 1.0 - znd ) ) * zsc_ws_1(ji,jj)
+               END DO
+            ENDIF
+          ENDDO    ! ji loop
+       END DO      ! jj loop
+
+
+       WHERE ( lconv )
+          zsc_uw_1 = zustar**2
+          zsc_vw_1 = ff_t * zustke * zhml
+       ELSEWHERE
+          zsc_uw_1 = zustar**2
+          zsc_uw_2 = (2.25 - 3.0 * ( 1.0 - EXP( -1.25 * 2.0 ) ) ) * ( 1.0 - EXP( -4.0 * 2.0 ) ) * zsc_uw_1
+          zsc_vw_1 = ff_t * zustke * zhbl
+          zsc_vw_2 = -0.11 * SIN( 3.14159 * ( 2.0 + 0.4 ) ) * EXP(-( 1.5 + 2.0 )**2 ) * zsc_vw_1
+       ENDWHERE
+
+       DO jj = 2, jpjm1
+          DO ji = 2, jpim1
+             IF ( lconv(ji,jj) ) THEN
+               DO jk = 2, imld(ji,jj)
+                  zznd_ml = gdepw_n(ji,jj,jk) / zhml(ji,jj)
+                  zznd_d = gdepw_n(ji,jj,jk) / dstokes(ji,jj)
+                  ghamu(ji,jj,jk) = ghamu(ji,jj,jk)&
+                       & + 0.3 * ( -2.0 + 2.5 * ( 1.0 + 0.1 * zznd_ml**4 ) - EXP ( -8.0 * zznd_ml ) ) * zsc_uw_1(ji,jj)
+                  !
+                  ghamv(ji,jj,jk) = ghamv(ji,jj,jk)&
+                       & + 0.3 * 0.1 * ( EXP( -zznd_d ) + EXP( -5.0 * ( 1.0 - zznd_ml ) ) ) * zsc_vw_1(ji,jj)
+               END DO
+             ELSE
+               DO jk = 2, ibld(ji,jj)
+                  znd = gdepw_n(ji,jj,jk) / zhbl(ji,jj)
+                  zznd_d = gdepw_n(ji,jj,jk) / dstokes(ji,jj)
+                  IF ( zznd_d <= 2.0 ) THEN
+                     ghamu(ji,jj,jk) = ghamu(ji,jj,jk) + 0.5 * 0.3 &
+                          &*  ( 2.25 - 3.0  * ( 1.0 - EXP( - 1.25 * zznd_d ) ) * ( 1.0 - EXP( -2.0 * zznd_d ) ) ) * zsc_uw_1(ji,jj)
+                     !
+                  ELSE
+                     ghamu(ji,jj,jk) = ghamu(ji,jj,jk)&
+                          & + 0.5 * 0.3 * ( 1.0 - EXP( -5.0 * ( 1.0 - znd ) ) ) * zsc_uw_2(ji,jj)
+                     !
+                  ENDIF
+
+                  ghamv(ji,jj,jk) = ghamv(ji,jj,jk)&
+                       & + 0.3 * 0.15 * SIN( 3.14159 * ( 0.65 * zznd_d ) ) * EXP( -0.25 * zznd_d**2 ) * zsc_vw_1(ji,jj)
+                  ghamv(ji,jj,jk) = ghamv(ji,jj,jk)&
+                       & + 0.3 * 0.15 * EXP( -5.0 * ( 1.0 - znd ) ) * ( 1.0 - EXP( -20.0 * ( 1.0 - znd ) ) ) * zsc_vw_2(ji,jj)
+               END DO
+             ENDIF
+          END DO
+       END DO
+!
+! Make surface forced velocity non-gradient terms go to zero at the base of the mixed layer.
+
+      DO jj = 2, jpjm1
+         DO ji = 2, jpim1
+            IF ( lconv(ji,jj) ) THEN
+               DO jk = 2, ibld(ji,jj)
+                  znd = ( gdepw_n(ji,jj,jk) - zhml(ji,jj) ) / zhml(ji,jj) !ALMG to think about
+                  IF ( znd >= 0.0 ) THEN
+                     ghamu(ji,jj,jk) = ghamu(ji,jj,jk) * ( 1.0 - EXP( -30.0 * znd**2 ) )
+                     ghamv(ji,jj,jk) = ghamv(ji,jj,jk) * ( 1.0 - EXP( -30.0 * znd**2 ) )
+                  ELSE
+                     ghamu(ji,jj,jk) = 0._wp
+                     ghamv(ji,jj,jk) = 0._wp
+                  ENDIF
+               END DO
+            ELSE
+               DO jk = 2, ibld(ji,jj)
+                  znd = ( gdepw_n(ji,jj,jk) - zhml(ji,jj) ) / zhml(ji,jj) !ALMG to think about
+                  IF ( znd >= 0.0 ) THEN
+                     ghamu(ji,jj,jk) = ghamu(ji,jj,jk) * ( 1.0 - EXP( -10.0 * znd**2 ) )
+                     ghamv(ji,jj,jk) = ghamv(ji,jj,jk) * ( 1.0 - EXP( -10.0 * znd**2 ) )
+                  ELSE
+                     ghamu(ji,jj,jk) = 0._wp
+                     ghamv(ji,jj,jk) = 0._wp
+                  ENDIF
+               END DO
+            ENDIF
+         END DO
+      END DO
+
+      ! pynocline contributions
+       ! Temporary fix to avoid instabilities when zdb_bl becomes very very small
+       zsc_uw_1 = 0._wp ! 50.0 * zla**(8.0/3.0) * zustar**2 * zhbl / ( zdb_bl + epsln )
+       DO jj = 2, jpjm1
+          DO ji = 2, jpim1
+             DO jk= 2, ibld(ji,jj)
+                znd = gdepw_n(ji,jj,jk) / zhbl(ji,jj)
+                ghamt(ji,jj,jk) = ghamt(ji,jj,jk) + zdiffut(ji,jj,jk) * zdtdz_pyc(ji,jj,jk)
+                ghams(ji,jj,jk) = ghams(ji,jj,jk) + zdiffut(ji,jj,jk) * zdsdz_pyc(ji,jj,jk)
+                ghamu(ji,jj,jk) = ghamu(ji,jj,jk) + zviscos(ji,jj,jk) * zdudz_pyc(ji,jj,jk)
+                ghamu(ji,jj,jk) = ghamu(ji,jj,jk) + zsc_uw_1(ji,jj) * ( 1.0 - znd )**(7.0/4.0) * zdbdz_pyc(ji,jj,jk)
+                ghamv(ji,jj,jk) = ghamv(ji,jj,jk) + zviscos(ji,jj,jk) * zdvdz_pyc(ji,jj,jk)
+             END DO
+           END DO
+       END DO
+
+! Entrainment contribution.
+
+       DO jj=2, jpjm1
+          DO ji = 2, jpim1
+             IF ( lconv(ji,jj) ) THEN
+               DO jk = 1, imld(ji,jj) - 1
+                  znd=gdepw_n(ji,jj,jk) / zhml(ji,jj)
+                  ghamt(ji,jj,jk) = ghamt(ji,jj,jk) + zwth_ent(ji,jj) * znd
+                  ghams(ji,jj,jk) = ghams(ji,jj,jk) + zws_ent(ji,jj) * znd
+                  ghamu(ji,jj,jk) = ghamu(ji,jj,jk) + zuw_bse(ji,jj) * znd
+                  ghamv(ji,jj,jk) = ghamv(ji,jj,jk) + zvw_bse(ji,jj) * znd
+               END DO
+               DO jk = imld(ji,jj), ibld(ji,jj)
+                  znd = -( gdepw_n(ji,jj,jk) - zhml(ji,jj) ) / zdh(ji,jj)
+                  ghamt(ji,jj,jk) = ghamt(ji,jj,jk) + zwth_ent(ji,jj) * ( 1.0 + znd )
+                  ghams(ji,jj,jk) = ghams(ji,jj,jk) + zws_ent(ji,jj) * ( 1.0 + znd )
+                  ghamu(ji,jj,jk) = ghamu(ji,jj,jk) + zuw_bse(ji,jj) * ( 1.0 + znd )
+                  ghamv(ji,jj,jk) = ghamv(ji,jj,jk) + zvw_bse(ji,jj) * ( 1.0 + znd )
+                END DO
+             ENDIF
+             ghamt(ji,jj,ibld(ji,jj)) = 0._wp
+             ghams(ji,jj,ibld(ji,jj)) = 0._wp
+             ghamu(ji,jj,ibld(ji,jj)) = 0._wp
+             ghamv(ji,jj,ibld(ji,jj)) = 0._wp
+          END DO       ! ji loop
+       END DO          ! jj loop
+
+
+       !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+       ! Need to put in code for contributions that are applied explicitly to
+       ! the prognostic variables
+       !  1. Entrainment flux
+       !
+       !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+
+
+
+       ! rotate non-gradient velocity terms back to model reference frame
+
+       DO jj = 2, jpjm1
+          DO ji = 2, jpim1
+             DO jk = 2, ibld(ji,jj)
+                ztemp = ghamu(ji,jj,jk)
+                ghamu(ji,jj,jk) = ghamu(ji,jj,jk) * zcos_wind(ji,jj) - ghamv(ji,jj,jk) * zsin_wind(ji,jj)
+                ghamv(ji,jj,jk) = ghamv(ji,jj,jk) * zcos_wind(ji,jj) + ztemp * zsin_wind(ji,jj)
+             END DO
+          END DO
+       END DO
+
+       IF(ln_dia_osm) THEN
+          IF ( iom_use("zdtdz_pyc") ) CALL iom_put( "zdtdz_pyc", wmask*zdtdz_pyc )
+       END IF
+
+! KPP-style Ri# mixing
+       IF( ln_kpprimix) THEN
+          DO jk = 2, jpkm1           !* Shear production at uw- and vw-points (energy conserving form)
+             DO jj = 1, jpjm1
+                DO ji = 1, jpim1   ! vector opt.
+                   z3du(ji,jj,jk) = 0.5 * (  un(ji,jj,jk-1) -  un(ji  ,jj,jk) )   &
+                        &                 * (  ub(ji,jj,jk-1) -  ub(ji  ,jj,jk) ) * wumask(ji,jj,jk) &
+                        &                 / (  e3uw_n(ji,jj,jk) * e3uw_b(ji,jj,jk) )
+                   z3dv(ji,jj,jk) = 0.5 * (  vn(ji,jj,jk-1) -  vn(ji,jj  ,jk) )   &
+                        &                 * (  vb(ji,jj,jk-1) -  vb(ji,jj  ,jk) ) * wvmask(ji,jj,jk) &
+                        &                 / (  e3vw_n(ji,jj,jk) * e3vw_b(ji,jj,jk) )
+                END DO
+             END DO
+          END DO
+      !
+         DO jk = 2, jpkm1
+            DO jj = 2, jpjm1
+               DO ji = 2, jpim1   ! vector opt.
+                  !                                          ! shear prod. at w-point weightened by mask
+                  zesh2  =  ( z3du(ji-1,jj,jk) + z3du(ji,jj,jk) ) / MAX( 1._wp , umask(ji-1,jj,jk) + umask(ji,jj,jk) )   &
+                     &    + ( z3dv(ji,jj-1,jk) + z3dv(ji,jj,jk) ) / MAX( 1._wp , vmask(ji,jj-1,jk) + vmask(ji,jj,jk) )
+                  !                                          ! local Richardson number
+                  zri   = MAX( rn2b(ji,jj,jk), 0._wp ) / MAX(zesh2, epsln)
+                  zfri =  MIN( zri / rn_riinfty , 1.0_wp )
+                  zfri  = ( 1.0_wp - zfri * zfri )
+                  zrimix(ji,jj,jk)  =  zfri * zfri  * zfri * wmask(ji, jj, jk)
+                END DO
+             END DO
+          END DO
+
+          DO jj = 2, jpjm1
+             DO ji = 2, jpim1
+                DO jk = ibld(ji,jj) + 1, jpkm1
+                   zdiffut(ji,jj,jk) = zrimix(ji,jj,jk)*rn_difri
+                   zviscos(ji,jj,jk) = zrimix(ji,jj,jk)*rn_difri
+                END DO
+             END DO
+          END DO
+
+       END IF ! ln_kpprimix = .true.
+
+! KPP-style set diffusivity large if unstable below BL
+       IF( ln_convmix) THEN
+          DO jj = 2, jpjm1
+             DO ji = 2, jpim1
+                DO jk = ibld(ji,jj) + 1, jpkm1
+                  IF(  MIN( rn2(ji,jj,jk), rn2b(ji,jj,jk) ) <= -1.e-12 ) zdiffut(ji,jj,jk) = rn_difconv
+                END DO
+             END DO
+          END DO
+       END IF ! ln_convmix = .true.
+
+       ! Lateral boundary conditions on zvicos (sign unchanged), needed to caclulate viscosities on u and v grids
+       CALL lbc_lnk( zviscos(:,:,:), 'W', 1. )
+
+       ! GN 25/8: need to change tmask --> wmask
+
+     DO jk = 2, jpkm1
+         DO jj = 2, jpjm1
+             DO ji = 2, jpim1
+                p_avt(ji,jj,jk) = MAX( zdiffut(ji,jj,jk), avtb(jk) ) * tmask(ji,jj,jk)
+                p_avm(ji,jj,jk) = MAX( zviscos(ji,jj,jk), avmb(jk) ) * tmask(ji,jj,jk)
+             END DO
+         END DO
+     END DO
+      ! Lateral boundary conditions on ghamu and ghamv, currently on W-grid  (sign unchanged), needed to caclulate gham[uv] on u and v grids
+     CALL lbc_lnk_multi( p_avt, 'W', 1. , p_avm, 'W', 1.,   &
+      &                  ghamu, 'W', 1. , ghamv, 'W', 1. )
+       DO jk = 2, jpkm1
+           DO jj = 2, jpjm1
+               DO ji = 2, jpim1
+                  ghamu(ji,jj,jk) = ( ghamu(ji,jj,jk) + ghamu(ji+1,jj,jk) ) &
+                     &  / MAX( 1., tmask(ji,jj,jk) + tmask (ji + 1,jj,jk) ) * umask(ji,jj,jk)
+
+                  ghamv(ji,jj,jk) = ( ghamv(ji,jj,jk) + ghamv(ji,jj+1,jk) ) &
+                      &  / MAX( 1., tmask(ji,jj,jk) + tmask (ji,jj+1,jk) ) * vmask(ji,jj,jk)
+
+                  ghamt(ji,jj,jk) =  ghamt(ji,jj,jk) * tmask(ji,jj,jk)
+                  ghams(ji,jj,jk) =  ghams(ji,jj,jk) * tmask(ji,jj,jk)
+               END DO
+           END DO
+        END DO
+        ! Lateral boundary conditions on final outputs for gham[ts],  on W-grid  (sign unchanged)
+        ! Lateral boundary conditions on final outputs for gham[uv],  on [UV]-grid  (sign unchanged)
+        CALL lbc_lnk_multi( ghamt, 'W', 1. , ghams, 'W', 1.,   &
+         &                  ghamu, 'U', 1. , ghamv, 'V', 1. )
+
+       IF(ln_dia_osm) THEN
+         SELECT CASE (nn_osm_wave)
+         ! Stokes drift set by assumimg onstant La#=0.3(=0)  or Pierson-Moskovitz spectrum (=1).
+         CASE(0:1)
+            IF ( iom_use("us_x") ) CALL iom_put( "us_x", tmask(:,:,1)*zustke*zcos_wind )   ! x surface Stokes drift
+            IF ( iom_use("us_y") ) CALL iom_put( "us_y", tmask(:,:,1)*zustke*zsin_wind )  ! y surface Stokes drift
+            IF ( iom_use("wind_wave_abs_power") ) CALL iom_put( "wind_wave_abs_power", 1000.*rau0*tmask(:,:,1)*zustar**2*zustke )
+         ! Stokes drift read in from sbcwave  (=2).
+         CASE(2)
+            IF ( iom_use("us_x") ) CALL iom_put( "us_x", ut0sd )               ! x surface Stokes drift
+            IF ( iom_use("us_y") ) CALL iom_put( "us_y", vt0sd )               ! y surface Stokes drift
+            IF ( iom_use("wind_wave_abs_power") ) CALL iom_put( "wind_wave_abs_power", 1000.*rau0*tmask(:,:,1)*zustar**2* &
+                 & SQRT(ut0sd**2 + vt0sd**2 ) )
+         END SELECT
+         IF ( iom_use("ghamt") ) CALL iom_put( "ghamt", tmask*ghamt )            ! <Tw_NL>
+         IF ( iom_use("ghams") ) CALL iom_put( "ghams", tmask*ghams )            ! <Sw_NL>
+         IF ( iom_use("ghamu") ) CALL iom_put( "ghamu", umask*ghamu )            ! <uw_NL>
+         IF ( iom_use("ghamv") ) CALL iom_put( "ghamv", vmask*ghamv )            ! <vw_NL>
+         IF ( iom_use("zwth0") ) CALL iom_put( "zwth0", tmask(:,:,1)*zwth0 )            ! <Tw_0>
+         IF ( iom_use("zws0") ) CALL iom_put( "zws0", tmask(:,:,1)*zws0 )                ! <Sw_0>
+         IF ( iom_use("hbl") ) CALL iom_put( "hbl", tmask(:,:,1)*hbl )                  ! boundary-layer depth
+         IF ( iom_use("hbli") ) CALL iom_put( "hbli", tmask(:,:,1)*hbli )               ! Initial boundary-layer depth
+         IF ( iom_use("dstokes") ) CALL iom_put( "dstokes", tmask(:,:,1)*dstokes )      ! Stokes drift penetration depth
+         IF ( iom_use("zustke") ) CALL iom_put( "zustke", tmask(:,:,1)*zustke )            ! Stokes drift magnitude at T-points
+         IF ( iom_use("zwstrc") ) CALL iom_put( "zwstrc", tmask(:,:,1)*zwstrc )         ! convective velocity scale
+         IF ( iom_use("zwstrl") ) CALL iom_put( "zwstrl", tmask(:,:,1)*zwstrl )         ! Langmuir velocity scale
+         IF ( iom_use("zustar") ) CALL iom_put( "zustar", tmask(:,:,1)*zustar )         ! friction velocity scale
+         IF ( iom_use("wind_power") ) CALL iom_put( "wind_power", 1000.*rau0*tmask(:,:,1)*zustar**3 ) ! BL depth internal to zdf_osm routine
+         IF ( iom_use("wind_wave_power") ) CALL iom_put( "wind_wave_power", 1000.*rau0*tmask(:,:,1)*zustar**2*zustke )
+         IF ( iom_use("zhbl") ) CALL iom_put( "zhbl", tmask(:,:,1)*zhbl )               ! BL depth internal to zdf_osm routine
+         IF ( iom_use("zhml") ) CALL iom_put( "zhml", tmask(:,:,1)*zhml )               ! ML depth internal to zdf_osm routine
+         IF ( iom_use("zdh") ) CALL iom_put( "zdh", tmask(:,:,1)*zdh )               ! ML depth internal to zdf_osm routine
+         IF ( iom_use("zhol") ) CALL iom_put( "zhol", tmask(:,:,1)*zhol )               ! ML depth internal to zdf_osm routine
+         IF ( iom_use("zwthav") ) CALL iom_put( "zwthav", tmask(:,:,1)*zwthav )               ! ML depth internal to zdf_osm routine
+         IF ( iom_use("zwth_ent") ) CALL iom_put( "zwth_ent", tmask(:,:,1)*zwth_ent )               ! ML depth internal to zdf_osm routine
+         IF ( iom_use("zt_ml") ) CALL iom_put( "zt_ml", tmask(:,:,1)*zt_ml )               ! average T in ML
+      END IF
+      ! Lateral boundary conditions on p_avt  (sign unchanged)
+      CALL lbc_lnk( p_avt(:,:,:), 'W', 1. )
+      !
+   END SUBROUTINE zdf_osm
+
+
+   SUBROUTINE zdf_osm_init
+     !!----------------------------------------------------------------------
+     !!                  ***  ROUTINE zdf_osm_init  ***
+     !!
+     !! ** Purpose :   Initialization of the vertical eddy diffivity and
+     !!      viscosity when using a osm turbulent closure scheme
+     !!
+     !! ** Method  :   Read the namosm namelist and check the parameters
+     !!      called at the first timestep (nit000)
+     !!
+     !! ** input   :   Namlist namosm
+     !!----------------------------------------------------------------------
+     INTEGER  ::   ios            ! local integer
+     INTEGER  ::   ji, jj, jk     ! dummy loop indices
+     !!
+     NAMELIST/namzdf_osm/ ln_use_osm_la, rn_osm_la, rn_osm_dstokes, nn_ave &
+          & ,nn_osm_wave, ln_dia_osm, rn_osm_hbl0 &
+          & ,ln_kpprimix, rn_riinfty, rn_difri, ln_convmix, rn_difconv
+     !!----------------------------------------------------------------------
+     !
+     REWIND( numnam_ref )              ! Namelist namzdf_osm in reference namelist : Osmosis ML model
+     READ  ( numnam_ref, namzdf_osm, IOSTAT = ios, ERR = 901)
+901  IF( ios /= 0 ) CALL ctl_nam ( ios , 'namzdf_osm in reference namelist', lwp )
+
+     REWIND( numnam_cfg )              ! Namelist namzdf_tke in configuration namelist : Turbulent Kinetic Energy
+     READ  ( numnam_cfg, namzdf_osm, IOSTAT = ios, ERR = 902 )
+902  IF( ios >  0 ) CALL ctl_nam ( ios , 'namzdf_osm in configuration namelist', lwp )
+     IF(lwm) WRITE ( numond, namzdf_osm )
+
+     IF(lwp) THEN                    ! Control print
+        WRITE(numout,*)
+        WRITE(numout,*) 'zdf_osm_init : OSMOSIS Parameterisation'
+        WRITE(numout,*) '~~~~~~~~~~~~'
+        WRITE(numout,*) '   Namelist namzdf_osm : set tke mixing parameters'
+        WRITE(numout,*) '     Use namelist  rn_osm_la                     ln_use_osm_la = ', ln_use_osm_la
+        WRITE(numout,*) '     Turbulent Langmuir number                     rn_osm_la   = ', rn_osm_la
+        WRITE(numout,*) '     Initial hbl for 1D runs                       rn_osm_hbl0   = ', rn_osm_hbl0
+        WRITE(numout,*) '     Depth scale of Stokes drift                rn_osm_dstokes = ', rn_osm_dstokes
+        WRITE(numout,*) '     horizontal average flag                       nn_ave      = ', nn_ave
+        WRITE(numout,*) '     Stokes drift                                  nn_osm_wave = ', nn_osm_wave
+        SELECT CASE (nn_osm_wave)
+        CASE(0)
+           WRITE(numout,*) '     calculated assuming constant La#=0.3'
+        CASE(1)
+           WRITE(numout,*) '     calculated from Pierson Moskowitz wind-waves'
+        CASE(2)
+           WRITE(numout,*) '     calculated from ECMWF wave fields'
+        END SELECT
+        WRITE(numout,*) '     Output osm diagnostics                       ln_dia_osm  = ',  ln_dia_osm
+        WRITE(numout,*) '     Use KPP-style shear instability mixing       ln_kpprimix = ', ln_kpprimix
+        WRITE(numout,*) '     local Richardson Number limit for shear instability rn_riinfty = ', rn_riinfty
+        WRITE(numout,*) '     maximum shear diffusivity at Rig = 0    (m2/s) rn_difri = ', rn_difri
+        WRITE(numout,*) '     Use large mixing below BL when unstable       ln_convmix = ', ln_convmix
+        WRITE(numout,*) '     diffusivity when unstable below BL     (m2/s) rn_difconv = ', rn_difconv
+     ENDIF
+
+     !                              ! allocate zdfosm arrays
+     IF( zdf_osm_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'zdf_osm_init : unable to allocate arrays' )
+
+     call osm_rst( nit000, 'READ' ) !* read or initialize hbl
+
+     IF( ln_zdfddm) THEN
+        IF(lwp) THEN
+           WRITE(numout,*)
+           WRITE(numout,*) '    Double diffusion mixing on temperature and salinity '
+           WRITE(numout,*) '    CAUTION : done in routine zdfosm, not in routine zdfddm '
+        ENDIF
+     ENDIF
+
+
+     !set constants not in namelist
+     !-----------------------------
+
+     IF(lwp) THEN
+        WRITE(numout,*)
+     ENDIF
+
+     IF (nn_osm_wave == 0) THEN
+        dstokes(:,:) = rn_osm_dstokes
+     END IF
+
+     ! Horizontal average : initialization of weighting arrays
+     ! -------------------
+
+     SELECT CASE ( nn_ave )
+
+     CASE ( 0 )                ! no horizontal average
+        IF(lwp) WRITE(numout,*) '          no horizontal average on avt'
+        IF(lwp) WRITE(numout,*) '          only in very high horizontal resolution !'
+        ! weighting mean arrays etmean
+        !           ( 1  1 )
+        ! avt = 1/4 ( 1  1 )
+        !
+        etmean(:,:,:) = 0.e0
+
+        DO jk = 1, jpkm1
+           DO jj = 2, jpjm1
+              DO ji = 2, jpim1   ! vector opt.
+                 etmean(ji,jj,jk) = tmask(ji,jj,jk)                     &
+                      &  / MAX( 1.,  umask(ji-1,jj  ,jk) + umask(ji,jj,jk)   &
+                      &            + vmask(ji  ,jj-1,jk) + vmask(ji,jj,jk)  )
+              END DO
+           END DO
+        END DO
+
+     CASE ( 1 )                ! horizontal average
+        IF(lwp) WRITE(numout,*) '          horizontal average on avt'
+        ! weighting mean arrays etmean
+        !           ( 1/2  1  1/2 )
+        ! avt = 1/8 ( 1    2  1   )
+        !           ( 1/2  1  1/2 )
+        etmean(:,:,:) = 0.e0
+
+        DO jk = 1, jpkm1
+           DO jj = 2, jpjm1
+              DO ji = 2, jpim1   ! vector opt.
+                 etmean(ji,jj,jk) = tmask(ji, jj,jk)                           &
+                      & / MAX( 1., 2.* tmask(ji,jj,jk)                           &
+                      &      +.5 * ( tmask(ji-1,jj+1,jk) + tmask(ji-1,jj-1,jk)   &
+                      &             +tmask(ji+1,jj+1,jk) + tmask(ji+1,jj-1,jk) ) &
+                      &      +1. * ( tmask(ji-1,jj  ,jk) + tmask(ji  ,jj+1,jk)   &
+                      &             +tmask(ji  ,jj-1,jk) + tmask(ji+1,jj  ,jk) ) )
+              END DO
+           END DO
+        END DO
+
+     CASE DEFAULT
+        WRITE(ctmp1,*) '          bad flag value for nn_ave = ', nn_ave
+        CALL ctl_stop( ctmp1 )
+
+     END SELECT
+
+     ! Initialization of vertical eddy coef. to the background value
+     ! -------------------------------------------------------------
+     DO jk = 1, jpk
+        avt (:,:,jk) = avtb(jk) * tmask(:,:,jk)
+     END DO
+
+     ! zero the surface flux for non local term and osm mixed layer depth
+     ! ------------------------------------------------------------------
+     ghamt(:,:,:) = 0.
+     ghams(:,:,:) = 0.
+     ghamu(:,:,:) = 0.
+     ghamv(:,:,:) = 0.
+     !
+     IF( lwxios ) THEN
+        CALL iom_set_rstw_var_active('wn')
+        CALL iom_set_rstw_var_active('hbl')
+        CALL iom_set_rstw_var_active('hbli')
+     ENDIF
+   END SUBROUTINE zdf_osm_init
+
+
+   SUBROUTINE osm_rst( kt, cdrw )
+     !!---------------------------------------------------------------------
+     !!                   ***  ROUTINE osm_rst  ***
+     !!
+     !! ** Purpose :   Read or write BL fields in restart file
+     !!
+     !! ** Method  :   use of IOM library. If the restart does not contain
+     !!                required fields, they are recomputed from stratification
+     !!----------------------------------------------------------------------
+
+     INTEGER, INTENT(in) :: kt
+     CHARACTER(len=*), INTENT(in) ::   cdrw   ! "READ"/"WRITE" flag
+
+     INTEGER ::   id1, id2   ! iom enquiry index
+     INTEGER  ::   ji, jj, jk     ! dummy loop indices
+     INTEGER  ::   iiki, ikt ! local integer
+     REAL(wp) ::   zhbf           ! tempory scalars
+     REAL(wp) ::   zN2_c           ! local scalar
+     REAL(wp) ::   rho_c = 0.01_wp    !: density criterion for mixed layer depth
+     INTEGER, DIMENSION(:,:), ALLOCATABLE :: imld_rst ! level of mixed-layer depth (pycnocline top)
+     !!----------------------------------------------------------------------
+     !
+     !!-----------------------------------------------------------------------------
+     ! If READ/WRITE Flag is 'READ', try to get hbl from restart file. If successful then return
+     !!-----------------------------------------------------------------------------
+     IF( TRIM(cdrw) == 'READ'.AND. ln_rstart) THEN
+        id1 = iom_varid( numror, 'wn'   , ldstop = .FALSE. )
+        IF( id1 > 0 ) THEN                       ! 'wn' exists; read
+           CALL iom_get( numror, jpdom_autoglo, 'wn', wn, ldxios = lrxios )
+           WRITE(numout,*) ' ===>>>> :  wn read from restart file'
+        ELSE
+           wn(:,:,:) = 0._wp
+           WRITE(numout,*) ' ===>>>> :  wn not in restart file, set to zero initially'
+        END IF
+        id1 = iom_varid( numror, 'hbl'   , ldstop = .FALSE. )
+        id2 = iom_varid( numror, 'hbli'   , ldstop = .FALSE. )
+        IF( id1 > 0 .AND. id2 > 0) THEN                       ! 'hbl' exists; read and return
+           CALL iom_get( numror, jpdom_autoglo, 'hbl' , hbl , ldxios = lrxios )
+           CALL iom_get( numror, jpdom_autoglo, 'hbli', hbli, ldxios = lrxios  )
+           WRITE(numout,*) ' ===>>>> :  hbl & hbli read from restart file'
+           RETURN
+        ELSE                      ! 'hbl' & 'hbli' not in restart file, recalculate
+           WRITE(numout,*) ' ===>>>> : previous run without osmosis scheme, hbl computed from stratification'
+        END IF
+     END IF
+
+     !!-----------------------------------------------------------------------------
+     ! If READ/WRITE Flag is 'WRITE', write hbl into the restart file, then return
+     !!-----------------------------------------------------------------------------
+     IF( TRIM(cdrw) == 'WRITE') THEN     !* Write hbli into the restart file, then return
+        IF(lwp) WRITE(numout,*) '---- osm-rst ----'
+         CALL iom_rstput( kt, nitrst, numrow, 'wn'     , wn  , ldxios = lwxios )
+         CALL iom_rstput( kt, nitrst, numrow, 'hbl'    , hbl , ldxios = lwxios )
+         CALL iom_rstput( kt, nitrst, numrow, 'hbli'   , hbli, ldxios = lwxios )
+        RETURN
+     END IF
+
+     !!-----------------------------------------------------------------------------
+     ! Getting hbl, no restart file with hbl, so calculate from surface stratification
+     !!-----------------------------------------------------------------------------
+     IF( lwp ) WRITE(numout,*) ' ===>>>> : calculating hbl computed from stratification'
+     ALLOCATE( imld_rst(jpi,jpj) )
+     ! w-level of the mixing and mixed layers
+     CALL eos_rab( tsn, rab_n )
+     CALL bn2(tsn, rab_n, rn2)
+     imld_rst(:,:)  = nlb10         ! Initialization to the number of w ocean point
+     hbl(:,:)  = 0._wp              ! here hbl used as a dummy variable, integrating vertically N^2
+     zN2_c = grav * rho_c * r1_rau0 ! convert density criteria into N^2 criteria
+     !
+     hbl(:,:)  = 0._wp              ! here hbl used as a dummy variable, integrating vertically N^2
+     DO jk = 1, jpkm1
+        DO jj = 1, jpj              ! Mixed layer level: w-level
+           DO ji = 1, jpi
+              ikt = mbkt(ji,jj)
+              hbl(ji,jj) = hbl(ji,jj) + MAX( rn2(ji,jj,jk) , 0._wp ) * e3w_n(ji,jj,jk)
+              IF( hbl(ji,jj) < zN2_c )   imld_rst(ji,jj) = MIN( jk , ikt ) + 1   ! Mixed layer level
+           END DO
+        END DO
+     END DO
+     !
+     DO jj = 1, jpj
+        DO ji = 1, jpi
+           iiki = imld_rst(ji,jj)
+           hbl (ji,jj) = gdepw_n(ji,jj,iiki  ) * ssmask(ji,jj)    ! Turbocline depth
+        END DO
+     END DO
+     hbl = MAX(hbl,epsln)
+     hbli(:,:) = hbl(:,:)
+     DEALLOCATE( imld_rst )
+     WRITE(numout,*) ' ===>>>> : hbl computed from stratification'
+   END SUBROUTINE osm_rst
+
+
+   SUBROUTINE tra_osm( kt )
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE tra_osm  ***
+      !!
+      !! ** Purpose :   compute and add to the tracer trend the non-local tracer flux
+      !!
+      !! ** Method  :   ???
+      !!----------------------------------------------------------------------
+      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::   ztrdt, ztrds   ! 3D workspace
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT(in) :: kt
+      INTEGER :: ji, jj, jk
+      !
+      IF( kt == nit000 ) THEN
+         IF(lwp) WRITE(numout,*)
+         IF(lwp) WRITE(numout,*) 'tra_osm : OSM non-local tracer fluxes'
+         IF(lwp) WRITE(numout,*) '~~~~~~~   '
+      ENDIF
+
+      IF( l_trdtra )   THEN                    !* Save ta and sa trends
+         ALLOCATE( ztrdt(jpi,jpj,jpk) )   ;    ztrdt(:,:,:) = tsa(:,:,:,jp_tem)
+         ALLOCATE( ztrds(jpi,jpj,jpk) )   ;    ztrds(:,:,:) = tsa(:,:,:,jp_sal)
+      ENDIF
+
+      ! add non-local temperature and salinity flux
+      DO jk = 1, jpkm1
+         DO jj = 2, jpjm1
+            DO ji = 2, jpim1
+               tsa(ji,jj,jk,jp_tem) =  tsa(ji,jj,jk,jp_tem)                      &
+                  &                 - (  ghamt(ji,jj,jk  )  &
+                  &                    - ghamt(ji,jj,jk+1) ) /e3t_n(ji,jj,jk)
+               tsa(ji,jj,jk,jp_sal) =  tsa(ji,jj,jk,jp_sal)                      &
+                  &                 - (  ghams(ji,jj,jk  )  &
+                  &                    - ghams(ji,jj,jk+1) ) / e3t_n(ji,jj,jk)
+            END DO
+         END DO
+      END DO
+
+
+      ! save the non-local tracer flux trends for diagnostic
+      IF( l_trdtra )   THEN
+         ztrdt(:,:,:) = tsa(:,:,:,jp_tem) - ztrdt(:,:,:)
+         ztrds(:,:,:) = tsa(:,:,:,jp_sal) - ztrds(:,:,:)
+!!bug gm jpttdzdf ==> jpttosm
+         CALL trd_tra( kt, 'TRA', jp_tem, jptra_zdf, ztrdt )
+         CALL trd_tra( kt, 'TRA', jp_sal, jptra_zdf, ztrds )
+         DEALLOCATE( ztrdt )      ;     DEALLOCATE( ztrds )
+      ENDIF
+
+      IF(ln_ctl) THEN
+         CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' osm  - Ta: ', mask1=tmask,   &
+         &             tab3d_2=tsa(:,:,:,jp_sal), clinfo2=       ' Sa: ', mask2=tmask, clinfo3='tra' )
+      ENDIF
+      !
+   END SUBROUTINE tra_osm
+
+
+   SUBROUTINE trc_osm( kt )          ! Dummy routine
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE trc_osm  ***
+      !!
+      !! ** Purpose :   compute and add to the passive tracer trend the non-local
+      !!                 passive tracer flux
+      !!
+      !!
+      !! ** Method  :   ???
+      !!----------------------------------------------------------------------
+      !
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT(in) :: kt
+      WRITE(*,*) 'trc_osm: Not written yet', kt
+   END SUBROUTINE trc_osm
+
+
+   SUBROUTINE dyn_osm( kt )
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE dyn_osm  ***
+      !!
+      !! ** Purpose :   compute and add to the velocity trend the non-local flux
+      !! copied/modified from tra_osm
+      !!
+      !! ** Method  :   ???
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT(in) ::   kt   !
+      !
+      INTEGER :: ji, jj, jk   ! dummy loop indices
+      !!----------------------------------------------------------------------
+      !
+      IF( kt == nit000 ) THEN
+         IF(lwp) WRITE(numout,*)
+         IF(lwp) WRITE(numout,*) 'dyn_osm : OSM non-local velocity'
+         IF(lwp) WRITE(numout,*) '~~~~~~~   '
+      ENDIF
+      !code saving tracer trends removed, replace with trdmxl_oce
+
+      DO jk = 1, jpkm1           ! add non-local u and v fluxes
+         DO jj = 2, jpjm1
+            DO ji = 2, jpim1
+               ua(ji,jj,jk) =  ua(ji,jj,jk)                      &
+                  &                 - (  ghamu(ji,jj,jk  )  &
+                  &                    - ghamu(ji,jj,jk+1) ) / e3u_n(ji,jj,jk)
+               va(ji,jj,jk) =  va(ji,jj,jk)                      &
+                  &                 - (  ghamv(ji,jj,jk  )  &
+                  &                    - ghamv(ji,jj,jk+1) ) / e3v_n(ji,jj,jk)
+            END DO
+         END DO
+      END DO
+      !
+      ! code for saving tracer trends removed
+      !
+   END SUBROUTINE dyn_osm
+
+   !!======================================================================
+END MODULE zdfosm
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/ZDF/zdfphy.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/ZDF/zdfphy.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/ZDF/zdfphy.F90	(revision 9570)
@@ -0,0 +1,320 @@
+MODULE zdfphy
+   !!======================================================================
+   !!                      ***  MODULE  zdfphy  ***
+   !! Vertical ocean physics :   manager of all vertical physics packages
+   !!======================================================================
+   !! History :  4.0  !  2017-04  (G. Madec)  original code
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   zdf_phy_init  : initialization of all vertical physics packages
+   !!   zdf_phy       : upadate at each time-step the vertical mixing coeff. 
+   !!----------------------------------------------------------------------
+   USE oce            ! ocean dynamics and tracers variables
+   USE zdf_oce        ! vertical physics: shared variables         
+   USE zdfdrg         ! vertical physics: top/bottom drag coef.
+   USE zdfsh2         ! vertical physics: shear production term of TKE
+   USE zdfric         ! vertical physics: RIChardson dependent vertical mixing   
+   USE zdftke         ! vertical physics: TKE vertical mixing
+   USE zdfgls         ! vertical physics: GLS vertical mixing
+   USE zdfosm         ! vertical physics: OSMOSIS vertical mixing
+   USE zdfddm         ! vertical physics: double diffusion mixing      
+   USE zdfevd         ! vertical physics: convection via enhanced vertical diffusion  
+   USE zdfiwm         ! vertical physics: internal wave-induced mixing  
+   USE zdfswm         ! vertical physics: surface  wave-induced mixing
+   USE zdfmxl         ! vertical physics: mixed layer
+   USE tranpc         ! convection: non penetrative adjustment
+   USE trc_oce        ! variables shared between passive tracer & ocean           
+   USE sbc_oce        ! surface module (only for nn_isf in the option compatibility test)
+   USE sbcrnf         ! surface boundary condition: runoff variables
+#if defined key_agrif
+   USE agrif_oce_interp   ! interpavm
+#endif
+   !
+   USE in_out_manager ! I/O manager
+   USE iom            ! IOM library
+   USE lbclnk         ! lateral boundary conditions
+   USE lib_mpp        ! distribued memory computing
+   USE timing         ! Timing
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   zdf_phy_init  ! called by nemogcm.F90
+   PUBLIC   zdf_phy       ! called by step.F90
+
+   INTEGER ::   nzdf_phy   ! type of vertical closure used 
+   !                       ! associated indicators
+   INTEGER, PARAMETER ::   np_CST = 1   ! Constant Kz
+   INTEGER, PARAMETER ::   np_RIC = 2   ! Richardson number dependent Kz
+   INTEGER, PARAMETER ::   np_TKE = 3   ! Turbulente Kinetic Eenergy closure scheme for Kz
+   INTEGER, PARAMETER ::   np_GLS = 4   ! Generic Length Scale closure scheme for Kz
+   INTEGER, PARAMETER ::   np_OSM = 5   ! OSMOSIS-OBL closure scheme for Kz
+
+   LOGICAL ::   l_zdfsh2   ! shear production term flag (=F for CST, =T otherwise (i.e. TKE, GLS, RIC))
+
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 4.0 , NEMO Consortium (2017)
+   !! $Id: zdfphy.F90 8160 2017-06-10 07:31:34Z gm $
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE zdf_phy_init
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE zdf_phy_init  ***
+      !! 
+      !! ** Purpose :   initializations of the vertical ocean physics
+      !!
+      !! ** Method  :   Read namelist namzdf, control logicals 
+      !!                set horizontal shape and vertical profile of background mixing coef.
+      !!----------------------------------------------------------------------
+      INTEGER ::   jk            ! dummy loop indices
+      INTEGER ::   ioptio, ios   ! local integers
+      !!
+      NAMELIST/namzdf/ ln_zdfcst, ln_zdfric, ln_zdftke, ln_zdfgls,   &     ! type of closure scheme
+         &             ln_zdfosm,                                    &     ! type of closure scheme
+         &             ln_zdfevd, nn_evdm, rn_evd ,                  &     ! convection : evd
+         &             ln_zdfnpc, nn_npc , nn_npcp,                  &     ! convection : npc
+         &             ln_zdfddm, rn_avts, rn_hsbfr,                 &     ! double diffusion
+         &             ln_zdfswm,                                    &     ! surface  wave-induced mixing
+         &             ln_zdfiwm,                                    &     ! internal  -      -      -
+         &             rn_avm0, rn_avt0, nn_avb, nn_havtb                  ! coefficients
+      !!----------------------------------------------------------------------
+      !
+      IF(lwp) THEN
+         WRITE(numout,*)
+         WRITE(numout,*) 'zdf_phy_init: ocean vertical physics'
+         WRITE(numout,*) '~~~~~~~~~~~~'
+      ENDIF
+      !
+      !                           !==  Namelist  ==!
+      REWIND( numnam_ref )              ! Namelist namzdf in reference namelist : Vertical mixing parameters
+      READ  ( numnam_ref, namzdf, IOSTAT = ios, ERR = 901)
+901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namzdf in reference namelist', lwp )
+      !
+      REWIND( numnam_cfg )              ! Namelist namzdf in reference namelist : Vertical mixing parameters
+      READ  ( numnam_cfg, namzdf, IOSTAT = ios, ERR = 902 )
+902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namzdf in configuration namelist', lwp )
+      IF(lwm)   WRITE ( numond, namzdf )
+      !
+      IF(lwp) THEN                      ! Parameter print
+         WRITE(numout,*) '   Namelist namzdf : set vertical mixing mixing parameters'
+         WRITE(numout,*) '      vertical closure scheme'
+         WRITE(numout,*) '         constant vertical mixing coefficient    ln_zdfcst = ', ln_zdfcst
+         WRITE(numout,*) '         Richardson number dependent closure     ln_zdfric = ', ln_zdfric
+         WRITE(numout,*) '         Turbulent Kinetic Energy closure (TKE)  ln_zdftke = ', ln_zdftke
+         WRITE(numout,*) '         Generic Length Scale closure (GLS)      ln_zdfgls = ', ln_zdfgls
+         WRITE(numout,*) '         OSMOSIS-OBL closure (OSM)               ln_zdfosm = ', ln_zdfosm
+         WRITE(numout,*) '      convection: '
+         WRITE(numout,*) '         enhanced vertical diffusion             ln_zdfevd = ', ln_zdfevd
+         WRITE(numout,*) '            applied on momentum (=1/0)             nn_evdm = ', nn_evdm
+         WRITE(numout,*) '            vertical coefficient for evd           rn_evd  = ', rn_evd
+         WRITE(numout,*) '         non-penetrative convection (npc)        ln_zdfnpc = ', ln_zdfnpc
+         WRITE(numout,*) '            npc call  frequency                    nn_npc  = ', nn_npc
+         WRITE(numout,*) '            npc print frequency                    nn_npcp = ', nn_npcp
+         WRITE(numout,*) '      double diffusive mixing                    ln_zdfddm = ', ln_zdfddm
+         WRITE(numout,*) '         maximum avs for dd mixing                 rn_avts = ', rn_avts
+         WRITE(numout,*) '         heat/salt buoyancy flux ratio             rn_hsbfr= ', rn_hsbfr
+         WRITE(numout,*) '      gravity wave-induced mixing'
+         WRITE(numout,*) '         surface  wave (Qiao et al 2010)         ln_zdfswm = ', ln_zdfswm                                          ! surface wave induced mixing
+         WRITE(numout,*) '         internal wave (de Lavergne et al 2017)  ln_zdfiwm = ', ln_zdfiwm
+         WRITE(numout,*) '      coefficients : '
+         WRITE(numout,*) '         vertical eddy viscosity                 rn_avm0   = ', rn_avm0
+         WRITE(numout,*) '         vertical eddy diffusivity               rn_avt0   = ', rn_avt0
+         WRITE(numout,*) '         constant background or profile          nn_avb    = ', nn_avb
+         WRITE(numout,*) '         horizontal variation for avtb           nn_havtb  = ', nn_havtb
+      ENDIF
+
+      !                          !==  Background eddy viscosity and diffusivity  ==!
+      IF( nn_avb == 0 ) THEN             ! Define avmb, avtb from namelist parameter
+         avmb(:) = rn_avm0
+         avtb(:) = rn_avt0                     
+      ELSE                               ! Background profile of avt (fit a theoretical/observational profile (Krauss 1990)
+         avmb(:) = rn_avm0
+         avtb(:) = rn_avt0 + ( 3.e-4_wp - 2._wp * rn_avt0 ) * 1.e-4_wp * gdepw_1d(:)   ! m2/s
+         IF(ln_sco .AND. lwp)   CALL ctl_warn( 'avtb profile not valid in sco' )
+      ENDIF
+      !                                  ! 2D shape of the avtb
+      avtb_2d(:,:) = 1._wp                   ! uniform 
+      !
+      IF( nn_havtb == 1 ) THEN               ! decrease avtb by a factor of ten in the equatorial band
+           !                                 !   -15S -5S : linear decrease from avt0 to avt0/10.
+           !                                 !   -5S  +5N : cst value avt0/10.
+           !                                 !    5N  15N : linear increase from avt0/10, to avt0
+           WHERE(-15. <= gphit .AND. gphit < -5 )   avtb_2d = (1.  - 0.09 * (gphit + 15.))
+           WHERE( -5. <= gphit .AND. gphit <  5 )   avtb_2d =  0.1
+           WHERE(  5. <= gphit .AND. gphit < 15 )   avtb_2d = (0.1 + 0.09 * (gphit -  5.))
+      ENDIF
+      !
+      DO jk = 1, jpk                      ! set turbulent closure Kz to the background value (avt_k, avm_k)
+         avt_k(:,:,jk) = avtb_2d(:,:) * avtb(jk) * wmask (:,:,jk)
+         avm_k(:,:,jk) =                avmb(jk) * wmask (:,:,jk)
+      END DO
+!!gm  to be tested only the 1st & last levels
+!      avt  (:,:, 1 ) = 0._wp   ;   avs(:,:, 1 ) = 0._wp   ;   avm  (:,:, 1 ) = 0._wp
+!      avt  (:,:,jpk) = 0._wp   ;   avs(:,:,jpk) = 0._wp   ;   avm  (:,:,jpk) = 0._wp
+!!gm
+      avt  (:,:,:) = 0._wp   ;   avs(:,:,:) = 0._wp   ;   avm  (:,:,:) = 0._wp
+
+      !                          !==  Convection  ==!
+      !
+      IF( ln_zdfnpc .AND. ln_zdfevd )   CALL ctl_stop( 'zdf_phy_init: chose between ln_zdfnpc and ln_zdfevd' )
+      IF( ln_zdfosm .AND. ln_zdfevd )   CALL ctl_stop( 'zdf_phy_init: chose between ln_zdfosm and ln_zdfevd' )
+      IF( lk_top    .AND. ln_zdfnpc )   CALL ctl_stop( 'zdf_phy_init: npc scheme is not working with key_top' )
+      IF( lk_top    .AND. ln_zdfosm )   CALL ctl_stop( 'zdf_phy_init: osmosis scheme is not working with key_top' )
+      IF(lwp) THEN
+         WRITE(numout,*)
+         IF    ( ln_zdfnpc ) THEN  ;   WRITE(numout,*) '   ==>>>   convection: use non penetrative convective scheme'
+         ELSEIF( ln_zdfevd ) THEN  ;   WRITE(numout,*) '   ==>>>   convection: use enhanced vertical diffusion scheme'
+         ELSE                      ;   WRITE(numout,*) '   ==>>>   convection: no specific scheme used'
+         ENDIF
+      ENDIF
+
+      IF(lwp) THEN               !==  Double Diffusion Mixing parameterization  ==!   (ddm)
+         WRITE(numout,*)
+         IF( ln_zdfddm ) THEN   ;   WRITE(numout,*) '   ==>>>   use double diffusive mixing: avs /= avt'
+         ELSE                   ;   WRITE(numout,*) '   ==>>>   No  double diffusive mixing: avs = avt'
+         ENDIF
+      ENDIF
+
+      !                          !==  type of vertical turbulent closure  ==!    (set nzdf_phy)
+      ioptio = 0 
+      IF( ln_zdfcst ) THEN   ;   ioptio = ioptio + 1   ;    nzdf_phy = np_CST   ;   ENDIF
+      IF( ln_zdfric ) THEN   ;   ioptio = ioptio + 1   ;    nzdf_phy = np_RIC   ;   CALL zdf_ric_init   ;   ENDIF
+      IF( ln_zdftke ) THEN   ;   ioptio = ioptio + 1   ;    nzdf_phy = np_TKE   ;   CALL zdf_tke_init   ;   ENDIF
+      IF( ln_zdfgls ) THEN   ;   ioptio = ioptio + 1   ;    nzdf_phy = np_GLS   ;   CALL zdf_gls_init   ;   ENDIF
+      IF( ln_zdfosm ) THEN   ;   ioptio = ioptio + 1   ;    nzdf_phy = np_OSM   ;   CALL zdf_osm_init   ;   ENDIF
+      !
+      IF( ioptio /= 1 )    CALL ctl_stop( 'zdf_phy_init: one and only one vertical diffusion option has to be defined ' )
+      IF( ln_isfcav ) THEN
+      IF( ln_zdfric .OR. ln_zdfgls )    CALL ctl_stop( 'zdf_phy_init: zdfric and zdfgls never tested with ice shelves cavities ' )
+      ENDIF
+      !                                ! shear production term flag
+      IF( ln_zdfcst ) THEN   ;   l_zdfsh2 = .FALSE.
+      ELSE                   ;   l_zdfsh2 = .TRUE.
+      ENDIF
+
+      !                          !== gravity wave-driven mixing  ==!
+      IF( ln_zdfiwm )   CALL zdf_iwm_init       ! internal wave-driven mixing
+      IF( ln_zdfswm )   CALL zdf_swm_init       ! surface  wave-driven mixing
+
+      !                          !== top/bottom friction  ==!
+      CALL zdf_drg_init
+      !
+      !                          !== time-stepping  ==!
+      ! Check/update of time stepping done in dynzdf_init/trazdf_init
+      !!gm move it here ?
+      !
+   END SUBROUTINE zdf_phy_init
+
+
+   SUBROUTINE zdf_phy( kt )
+      !!----------------------------------------------------------------------
+      !!                     ***  ROUTINE zdf_phy  ***
+      !!
+      !! ** Purpose :  Update ocean physics at each time-step
+      !!
+      !! ** Method  : 
+      !!
+      !! ** Action  :   avm, avt vertical eddy viscosity and diffusivity at w-points
+      !!                nmld ??? mixed layer depth in level and meters   <<<<====verifier !
+      !!                bottom stress.....                               <<<<====verifier !
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT(in) ::   kt   ! ocean time-step index
+      !
+      INTEGER ::   ji, jj, jk   ! dummy loop indice
+      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zsh2   ! shear production
+      !! ---------------------------------------------------------------------
+      !
+      IF( ln_timing )   CALL timing_start('zdf_phy')
+      !
+      IF( l_zdfdrg ) THEN     !==  update top/bottom drag  ==!   (non-linear cases)
+         !
+         !                       !* bottom drag
+         CALL zdf_drg( kt, mbkt    , r_Cdmin_bot, r_Cdmax_bot,   &   ! <<== in 
+            &              r_z0_bot,   r_ke0_bot,    rCd0_bot,   &
+            &                                        rCdU_bot  )     ! ==>> out : bottom drag [m/s]
+         IF( ln_isfcav ) THEN    !* top drag   (ocean cavities)
+            CALL zdf_drg( kt, mikt    , r_Cdmin_top, r_Cdmax_top,   &   ! <<== in 
+               &              r_z0_top,   r_ke0_top,    rCd0_top,   &
+               &                                        rCdU_top  )     ! ==>> out : bottom drag [m/s]
+         ENDIF
+      ENDIF
+      !
+      !                       !==  Kz from chosen turbulent closure  ==!   (avm_k, avt_k)
+      !
+      IF( l_zdfsh2 )   &         !* shear production at w-points (energy conserving form)
+         CALL zdf_sh2( ub, vb, un, vn, avm_k,   &     ! <<== in
+            &                           zsh2    )     ! ==>> out : shear production
+      !
+      SELECT CASE ( nzdf_phy )                  !* Vertical eddy viscosity and diffusivity coefficients at w-points
+      CASE( np_RIC )   ;   CALL zdf_ric( kt, gdept_n, zsh2, avm_k, avt_k )    ! Richardson number dependent Kz
+      CASE( np_TKE )   ;   CALL zdf_tke( kt         , zsh2, avm_k, avt_k )    ! TKE closure scheme for Kz
+      CASE( np_GLS )   ;   CALL zdf_gls( kt         , zsh2, avm_k, avt_k )    ! GLS closure scheme for Kz
+      CASE( np_OSM )   ;   CALL zdf_osm( kt               , avm_k, avt_k )    ! OSMOSIS closure scheme for Kz
+!     CASE( np_CST )                                  ! Constant Kz (reset avt, avm to the background value)
+!         ! avt_k and avm_k set one for all at initialisation phase
+!!gm         avt(2:jpim1,2:jpjm1,1:jpkm1) = rn_avt0 * wmask(2:jpim1,2:jpjm1,1:jpkm1)
+!!gm         avm(2:jpim1,2:jpjm1,1:jpkm1) = rn_avm0 * wmask(2:jpim1,2:jpjm1,1:jpkm1)
+      END SELECT
+      !  
+      !                          !==  ocean Kz  ==!   (avt, avs, avm)
+      !
+      !                                         !* start from turbulent closure values
+      avt(:,:,2:jpkm1) = avt_k(:,:,2:jpkm1)
+      avm(:,:,2:jpkm1) = avm_k(:,:,2:jpkm1)
+      !
+      IF( ln_rnf_mouth ) THEN                   !* increase diffusivity at rivers mouths
+         DO jk = 2, nkrnf
+            avt(:,:,jk) = avt(:,:,jk) + 2._wp * rn_avt_rnf * rnfmsk(:,:) * wmask(:,:,jk)
+         END DO
+      ENDIF
+      !
+      IF( ln_zdfevd )   CALL zdf_evd( kt, avm, avt )  !* convection: enhanced vertical eddy diffusivity
+      !
+      !                                         !* double diffusive mixing
+      IF( ln_zdfddm ) THEN                            ! update avt and compute avs
+                        CALL zdf_ddm( kt, avm, avt, avs )
+      ELSE                                            ! same mixing on all tracers
+         avs(2:jpim1,2:jpjm1,1:jpkm1) = avt(2:jpim1,2:jpjm1,1:jpkm1)
+      ENDIF
+      !
+      !                                         !* wave-induced mixing 
+      IF( ln_zdfswm )   CALL zdf_swm( kt, avm, avt, avs )   ! surface  wave (Qiao et al. 2004) 
+      IF( ln_zdfiwm )   CALL zdf_iwm( kt, avm, avt, avs )   ! internal wave (de Lavergne et al 2017)
+
+#if defined key_agrif 
+      ! interpolation parent grid => child grid for avm_k ( ex : at west border: update column 1 and 2)
+      IF( l_zdfsh2 )   CALL Agrif_avm
+#endif
+
+      !                                         !* Lateral boundary conditions (sign unchanged)
+      IF( l_zdfsh2 ) THEN
+         CALL lbc_lnk_multi( avm_k, 'W', 1. , avt_k, 'W', 1.,   &
+            &                avm  , 'W', 1. , avt  , 'W', 1. , avs , 'W', 1. )
+      ELSE
+         CALL lbc_lnk_multi( avm  , 'W', 1. , avt  , 'W', 1. , avs , 'W', 1. )
+      ENDIF
+      !
+      IF( l_zdfdrg ) THEN     ! drag  have been updated (non-linear cases)
+         IF( ln_isfcav ) THEN   ;  CALL lbc_lnk_multi( rCdU_top, 'T', 1. , rCdU_bot, 'T', 1. )   ! top & bot drag
+         ELSE                   ;  CALL lbc_lnk      ( rCdU_bot, 'T', 1. )                       ! bottom drag only
+         ENDIF
+      ENDIF
+      !
+      CALL zdf_mxl( kt )                        !* mixed layer depth, and level
+      !
+      IF( lrst_oce ) THEN                       !* write TKE, GLS or RIC fields in the restart file
+         IF( ln_zdftke )   CALL tke_rst( kt, 'WRITE' )
+         IF( ln_zdfgls )   CALL gls_rst( kt, 'WRITE' )
+         IF( ln_zdfric )   CALL ric_rst( kt, 'WRITE' ) 
+         ! NB. OSMOSIS restart (osm_rst) will be called in step.F90 after wn has been updated
+      ENDIF
+      !
+      IF( ln_timing )   CALL timing_stop('zdf_phy')
+      !
+   END SUBROUTINE zdf_phy
+
+   !!======================================================================
+END MODULE zdfphy
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/ZDF/zdfric.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/ZDF/zdfric.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/ZDF/zdfric.F90	(revision 9570)
@@ -0,0 +1,247 @@
+MODULE zdfric
+   !!======================================================================
+   !!                       ***  MODULE  zdfric  ***
+   !! Ocean physics:  vertical mixing coefficient compute from the local
+   !!                 Richardson number dependent formulation
+   !!======================================================================
+   !! History :  OPA  !  1987-09  (P. Andrich)  Original code
+   !!            4.0  !  1991-11  (G. Madec)
+   !!            7.0  !  1996-01  (G. Madec)  complete rewriting of multitasking suppression of common work arrays
+   !!            8.0  !  1997-06  (G. Madec)  complete rewriting of zdfmix
+   !!   NEMO     1.0  !  2002-06  (G. Madec)  F90: Free form and module
+   !!            3.3  !  2010-10  (C. Ethe, G. Madec) reorganisation of initialisation phase
+   !!            3.3.1!  2011-09  (P. Oddo) Mixed layer depth parameterization
+   !!            4.0  !  2017-04  (G. Madec)  remove CPP ddm key & avm at t-point only 
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   zdf_ric_init  : initialization, namelist read, & parameters control
+   !!   zdf_ric       : update momentum and tracer Kz from the Richardson number
+   !!   ric_rst       : read/write RIC restart in ocean restart file
+   !!----------------------------------------------------------------------
+   USE oce            ! ocean dynamics and tracers variables
+   USE dom_oce        ! ocean space and time domain variables
+   USE zdf_oce        ! vertical physics: variables
+   USE phycst         ! physical constants
+   USE sbc_oce,  ONLY :   taum
+   !
+   USE in_out_manager ! I/O manager
+   USE iom            ! I/O manager library
+   USE lib_fortran    ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined)  
+
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   zdf_ric         ! called by zdfphy.F90
+   PUBLIC   ric_rst         ! called by zdfphy.F90
+   PUBLIC   zdf_ric_init    ! called by nemogcm.F90
+
+   !                        !!* Namelist namzdf_ric : Richardson number dependent Kz *
+   INTEGER  ::   nn_ric      ! coefficient of the parameterization
+   REAL(wp) ::   rn_avmri    ! maximum value of the vertical eddy viscosity
+   REAL(wp) ::   rn_alp      ! coefficient of the parameterization
+   REAL(wp) ::   rn_ekmfc    ! Ekman Factor Coeff
+   REAL(wp) ::   rn_mldmin   ! minimum mixed layer (ML) depth    
+   REAL(wp) ::   rn_mldmax   ! maximum mixed layer depth
+   REAL(wp) ::   rn_wtmix    ! Vertical eddy Diff. in the ML
+   REAL(wp) ::   rn_wvmix    ! Vertical eddy Visc. in the ML
+   LOGICAL  ::   ln_mldw     ! Use or not the MLD parameters
+
+   !! * Substitutions
+#  include "vectopt_loop_substitute.h90"
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 4.0 , NEMO Consortium (2017)
+   !! $Id$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE zdf_ric_init
+      !!----------------------------------------------------------------------
+      !!                 ***  ROUTINE zdf_ric_init  ***
+      !!                    
+      !! ** Purpose :   Initialization of the vertical eddy diffusivity and
+      !!      viscosity coef. for the Richardson number dependent formulation.
+      !!
+      !! ** Method  :   Read the namzdf_ric namelist and check the parameter values
+      !!
+      !! ** input   :   Namelist namzdf_ric
+      !!
+      !! ** Action  :   increase by 1 the nstop flag is setting problem encounter
+      !!----------------------------------------------------------------------
+      INTEGER ::   ji, jj, jk   ! dummy loop indices
+      INTEGER ::   ios          ! Local integer output status for namelist read
+      !!
+      NAMELIST/namzdf_ric/ rn_avmri, rn_alp   , nn_ric  , rn_ekmfc,  &
+         &                rn_mldmin, rn_mldmax, rn_wtmix, rn_wvmix, ln_mldw
+      !!----------------------------------------------------------------------
+      !
+      REWIND( numnam_ref )              ! Namelist namzdf_ric in reference namelist : Vertical diffusion Kz depends on Richardson number
+      READ  ( numnam_ref, namzdf_ric, IOSTAT = ios, ERR = 901)
+901   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namzdf_ric in reference namelist', lwp )
+
+      REWIND( numnam_cfg )              ! Namelist namzdf_ric in configuration namelist : Vertical diffusion Kz depends on Richardson number
+      READ  ( numnam_cfg, namzdf_ric, IOSTAT = ios, ERR = 902 )
+902   IF( ios >  0 ) CALL ctl_nam ( ios , 'namzdf_ric in configuration namelist', lwp )
+      IF(lwm) WRITE ( numond, namzdf_ric )
+      !
+      IF(lwp) THEN                   ! Control print
+         WRITE(numout,*)
+         WRITE(numout,*) 'zdf_ric_init : Ri depend vertical mixing scheme'
+         WRITE(numout,*) '~~~~~~~~~~~~'
+         WRITE(numout,*) '   Namelist namzdf_ric : set Kz=F(Ri) parameters'
+         WRITE(numout,*) '      maximum vertical viscosity        rn_avmri  = ', rn_avmri
+         WRITE(numout,*) '      coefficient                       rn_alp    = ', rn_alp
+         WRITE(numout,*) '      exponent                          nn_ric    = ', nn_ric
+         WRITE(numout,*) '      Ekman layer enhanced mixing       ln_mldw   = ', ln_mldw
+         WRITE(numout,*) '         Ekman Factor Coeff             rn_ekmfc  = ', rn_ekmfc
+         WRITE(numout,*) '         minimum mixed layer depth      rn_mldmin = ', rn_mldmin
+         WRITE(numout,*) '         maximum mixed layer depth      rn_mldmax = ', rn_mldmax
+         WRITE(numout,*) '         Vertical eddy Diff. in the ML  rn_wtmix  = ', rn_wtmix
+         WRITE(numout,*) '         Vertical eddy Visc. in the ML  rn_wvmix  = ', rn_wvmix
+      ENDIF
+      !
+      CALL ric_rst( nit000, 'READ' )  !* read or initialize all required files
+      !
+      IF( lwxios ) THEN
+         CALL iom_set_rstw_var_active('avt_k')
+         CALL iom_set_rstw_var_active('avm_k')
+      ENDIF
+   END SUBROUTINE zdf_ric_init
+
+
+   SUBROUTINE zdf_ric( kt, pdept, p_sh2, p_avm, p_avt )
+      !!----------------------------------------------------------------------
+      !!                 ***  ROUTINE zdfric  ***
+      !!                    
+      !! ** Purpose :   Compute the before eddy viscosity and diffusivity as
+      !!                a function of the local richardson number.
+      !!
+      !! ** Method  :   Local richardson number dependent formulation of the 
+      !!                vertical eddy viscosity and diffusivity coefficients. 
+      !!                The eddy coefficients are given by:
+      !!                    avm = avm0 + avmb
+      !!                    avt = avm0 / (1 + rn_alp*ri)
+      !!                with ri  = N^2 / dz(u)**2
+      !!                         = e3w**2 * rn2/[ mi( dk(ub) )+mj( dk(vb) ) ]
+      !!                    avm0= rn_avmri / (1 + rn_alp*Ri)**nn_ric
+      !!                where ri is the before local Richardson number,
+      !!                rn_avmri is the maximum value reaches by avm and avt 
+      !!                and rn_alp, nn_ric are adjustable parameters.
+      !!                Typical values : rn_alp=5. and nn_ric=2.
+      !!
+      !!      As second step compute Ekman depth from wind stress forcing
+      !!      and apply namelist provided vertical coeff within this depth.
+      !!      The Ekman depth is:
+      !!              Ustar = SQRT(Taum/rho0)
+      !!              ekd= rn_ekmfc * Ustar / f0
+      !!      Large et al. (1994, eq.24) suggest rn_ekmfc=0.7; however, the derivation
+      !!      of the above equation indicates the value is somewhat arbitrary; therefore
+      !!      we allow the freedom to increase or decrease this value, if the
+      !!      Ekman depth estimate appears too shallow or too deep, respectively.
+      !!      Ekd is then limited by rn_mldmin and rn_mldmax provided in the
+      !!      namelist
+      !!        N.B. the mask are required for implicit scheme, and surface
+      !!      and bottom value already set in zdfphy.F90
+      !!
+      !! ** Action  :   avm, avt  mixing coeff (inner domain values only)
+      !!
+      !! References : Pacanowski & Philander 1981, JPO, 1441-1451.
+      !!              PFJ Lermusiaux 2001.
+      !!----------------------------------------------------------------------
+      INTEGER                   , INTENT(in   ) ::   kt             ! ocean time-step
+      REAL(wp), DIMENSION(:,:,:), INTENT(in   ) ::   pdept          ! depth of t-point  [m]
+      REAL(wp), DIMENSION(:,:,:), INTENT(in   ) ::   p_sh2          ! shear production term
+      REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   p_avm, p_avt   ! momentum and tracer Kz (w-points)
+      !!
+      INTEGER  ::   ji, jj, jk                  ! dummy loop indices
+      REAL(wp) ::   zcfRi, zav, zustar, zhek    ! local scalars
+      REAL(wp), DIMENSION(jpi,jpj) ::   zh_ekm  ! 2D workspace
+      !!----------------------------------------------------------------------
+      !
+      !                       !==  avm and avt = F(Richardson number)  ==!
+      DO jk = 2, jpkm1
+         DO jj = 1, jpjm1
+            DO ji = 1, jpim1              ! coefficient = F(richardson number) (avm-weighted Ri)
+               zcfRi = 1._wp / (  1._wp + rn_alp * MAX(  0._wp , avm(ji,jj,jk) * rn2(ji,jj,jk) / ( p_sh2(ji,jj,jk) + 1.e-20 ) )  )
+               zav   = rn_avmri * zcfRi**nn_ric
+               !                          ! avm and avt coefficients
+               p_avm(ji,jj,jk) = MAX(  zav         , avmb(jk)  ) * wmask(ji,jj,jk)
+               p_avt(ji,jj,jk) = MAX(  zav * zcfRi , avtb(jk)  ) * wmask(ji,jj,jk)
+            END DO
+         END DO
+      END DO
+      !
+!!gm BUG <<<<====  This param can't work at low latitude 
+!!gm               it provides there much to thick mixed layer ( summer 150m in GYRE configuration !!! )
+      !
+      IF( ln_mldw ) THEN      !==  set a minimum value in the Ekman layer  ==!
+         !
+         DO jj = 2, jpjm1        !* Ekman depth
+            DO ji = 2, jpim1
+               zustar = SQRT( taum(ji,jj) * r1_rau0 )
+               zhek   = rn_ekmfc * zustar / ( ABS( ff_t(ji,jj) ) + rsmall )   ! Ekman depth
+               zh_ekm(ji,jj) = MAX(  rn_mldmin , MIN( zhek , rn_mldmax )  )   ! set allowed range
+            END DO
+         END DO
+         DO jk = 2, jpkm1        !* minimum mixing coeff. within the Ekman layer
+            DO jj = 2, jpjm1
+               DO ji = 2, jpim1
+                  IF( pdept(ji,jj,jk) < zh_ekm(ji,jj) ) THEN
+                     p_avm(ji,jj,jk) = MAX(  p_avm(ji,jj,jk), rn_wvmix  ) * wmask(ji,jj,jk)
+                     p_avt(ji,jj,jk) = MAX(  p_avt(ji,jj,jk), rn_wtmix  ) * wmask(ji,jj,jk)
+                  ENDIF
+               END DO
+            END DO
+         END DO
+      ENDIF
+      !
+   END SUBROUTINE zdf_ric
+
+
+   SUBROUTINE ric_rst( kt, cdrw )
+      !!---------------------------------------------------------------------
+      !!                   ***  ROUTINE ric_rst  ***
+      !!                     
+      !! ** Purpose :   Read or write TKE file (en) in restart file
+      !!
+      !! ** Method  :   use of IOM library
+      !!                if the restart does not contain TKE, en is either 
+      !!                set to rn_emin or recomputed 
+      !!----------------------------------------------------------------------
+      INTEGER         , INTENT(in) ::   kt     ! ocean time-step
+      CHARACTER(len=*), INTENT(in) ::   cdrw   ! "READ"/"WRITE" flag
+      !
+      INTEGER ::   jit, jk    ! dummy loop indices
+      INTEGER ::   id1, id2   ! local integers
+      !!----------------------------------------------------------------------
+      !
+      IF( TRIM(cdrw) == 'READ' ) THEN        ! Read/initialise 
+         !                                   ! ---------------
+         !           !* Read the restart file
+         IF( ln_rstart ) THEN
+            id1 = iom_varid( numror, 'avt_k', ldstop = .FALSE. )
+            id2 = iom_varid( numror, 'avm_k', ldstop = .FALSE. )
+            !
+            IF( MIN( id1, id2 ) > 0 ) THEN         ! restart exists => read it
+               CALL iom_get( numror, jpdom_autoglo, 'avt_k', avt_k, ldxios = lrxios )
+               CALL iom_get( numror, jpdom_autoglo, 'avm_k', avm_k, ldxios = lrxios )
+            ENDIF
+         ENDIF
+         !           !* otherwise Kz already set to the background value in zdf_phy_init
+         !
+      ELSEIF( TRIM(cdrw) == 'WRITE' ) THEN   ! Create restart file
+         !                                   ! -------------------
+         IF(lwp) WRITE(numout,*) '---- ric-rst ----'
+         IF( lwxios ) CALL iom_swap(      cwxios_context          )
+         CALL iom_rstput( kt, nitrst, numrow, 'avt_k', avt_k, ldxios = lwxios )
+         CALL iom_rstput( kt, nitrst, numrow, 'avm_k', avm_k, ldxios = lwxios)
+         IF( lwxios ) CALL iom_swap(      cxios_context          )
+         !
+      ENDIF
+      !
+   END SUBROUTINE ric_rst
+
+   !!======================================================================
+END MODULE zdfric
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/ZDF/zdfsh2.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/ZDF/zdfsh2.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/ZDF/zdfsh2.F90	(revision 9570)
@@ -0,0 +1,79 @@
+MODULE zdfsh2
+   !!======================================================================
+   !!                       ***  MODULE  zdfsh2  ***
+   !! Ocean physics:  shear production term of TKE 
+   !!=====================================================================
+   !! History :   -   !  2014-10  (A. Barthelemy, G. Madec)  original code
+   !!   NEMO     4.0  !  2017-04  (G. Madec)  remove u-,v-pts avm
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   zdf_sh2       : compute mixing the shear production term of TKE
+   !!----------------------------------------------------------------------
+   USE dom_oce        ! domain: ocean
+   !
+   USE in_out_manager ! I/O manager
+   USE lib_mpp        ! MPP library
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   zdf_sh2        ! called by zdftke, zdfglf, and zdfric
+   
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 4.0 , NEMO Consortium (2017)
+   !! $Id: $
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE zdf_sh2( pub, pvb, pun, pvn, p_avm, p_sh2  ) 
+      !!----------------------------------------------------------------------
+      !!                   ***  ROUTINE zdf_sh2  ***
+      !!
+      !! ** Purpose :   Compute the shear production term of a TKE equation
+      !!
+      !! ** Method  : - a stable discretization of this term is linked to the
+      !!                time-space discretization of the vertical diffusion
+      !!                of the OGCM. NEMO uses C-grid, a leap-frog environment 
+      !!                and an implicit computation of vertical mixing term,
+      !!                so the shear production at w-point is given by:
+      !!                   sh2 = mi[   mi(avm) * dk[ub]/e3ub * dk[un]/e3un   ] 
+      !!                       + mj[   mj(avm) * dk[vb]/e3vb * dk[vn]/e3vn   ] 
+      !!                NB: wet-point only horizontal averaging of shear
+      !!
+      !! ** Action  : - p_sh2 shear prod. term at w-point (inner domain only)
+      !!                                                   *****
+      !! References :   Bruchard, OM 2002
+      !! ---------------------------------------------------------------------
+      REAL(wp), DIMENSION(:,:,:) , INTENT(in   ) ::   pub, pvb, pun, pvn   ! before, now horizontal velocities
+      REAL(wp), DIMENSION(:,:,:) , INTENT(in   ) ::   p_avm                ! vertical eddy viscosity (w-points)
+      REAL(wp), DIMENSION(:,:,:) , INTENT(  out) ::   p_sh2                ! shear production of TKE (w-points)
+      !
+      INTEGER  ::   ji, jj, jk   ! dummy loop arguments
+      REAL(wp), DIMENSION(jpi,jpj) ::   zsh2u, zsh2v   ! 2D workspace
+      !!--------------------------------------------------------------------
+      !
+      DO jk = 2, jpkm1
+         DO jj = 1, jpjm1        !* 2 x shear production at uw- and vw-points (energy conserving form)
+            DO ji = 1, jpim1
+               zsh2u(ji,jj) = ( p_avm(ji+1,jj,jk) + p_avm(ji,jj,jk) ) &
+                  &         * (   pun(ji,jj,jk-1) -   pun(ji,jj,jk) ) &
+                  &         * (   pub(ji,jj,jk-1) -   pub(ji,jj,jk) ) / ( e3uw_n(ji,jj,jk) * e3uw_b(ji,jj,jk) ) * wumask(ji,jj,jk)
+               zsh2v(ji,jj) = ( p_avm(ji,jj+1,jk) + p_avm(ji,jj,jk) ) &
+                  &         * (   pvn(ji,jj,jk-1) -   pvn(ji,jj,jk) ) &
+                  &         * (   pvb(ji,jj,jk-1) -   pvb(ji,jj,jk) ) / ( e3vw_n(ji,jj,jk) * e3vw_b(ji,jj,jk) ) * wvmask(ji,jj,jk)
+            END DO
+         END DO
+         DO jj = 2, jpjm1        !* shear production at w-point
+            DO ji = 2, jpim1           ! coast mask: =2 at the coast ; =1 otherwise (NB: wmask useless as zsh2 are masked)
+               p_sh2(ji,jj,jk) = 0.25 * (   ( zsh2u(ji-1,jj) + zsh2u(ji,jj) ) * ( 2. - umask(ji-1,jj,jk) * umask(ji,jj,jk) )   &
+                  &                       + ( zsh2v(ji,jj-1) + zsh2v(ji,jj) ) * ( 2. - vmask(ji,jj-1,jk) * vmask(ji,jj,jk) )   )
+            END DO
+         END DO
+      END DO 
+      !
+   END SUBROUTINE zdf_sh2
+
+   !!======================================================================
+END MODULE zdfsh2
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/ZDF/zdfswm.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/ZDF/zdfswm.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/ZDF/zdfswm.F90	(revision 9570)
@@ -0,0 +1,97 @@
+MODULE zdfswm
+   !!======================================================================
+   !!                       ***  MODULE  zdfswm  ***
+   !! vertical physics :   surface wave-induced mixing 
+   !!======================================================================
+   !! History :  3.6  !  2014-10  (E. Clementi)  Original code
+   !!            4.0  !  2017-04  (G. Madec)  debug + simplifications
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   zdf_swm      : update Kz due to surface wave-induced mixing 
+   !!   zdf_swm_init : initilisation
+   !!----------------------------------------------------------------------
+   USE dom_oce        ! ocean domain variable
+   USE zdf_oce        ! vertical physics: mixing coefficients
+   USE sbc_oce        ! Surface boundary condition: ocean fields
+   USE sbcwave        ! wave module
+   !
+   USE in_out_manager ! I/O manager
+   USE lbclnk         ! ocean lateral boundary conditions (or mpp link)  
+   USE lib_mpp        ! distribued memory computing library
+   
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC zdf_swm         ! routine called in zdp_phy
+   PUBLIC zdf_swm_init    ! routine called in zdf_phy_init
+
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 4.0 , NEMO Consortium (2017) 
+   !! $Id:$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE zdf_swm( kt, p_avm, p_avt, p_avs )
+      !!---------------------------------------------------------------------
+      !!                     ***  ROUTINE zdf_swm ***
+      !!
+      !! ** Purpose :Compute the swm term (qbv) to be added to
+      !!             vertical viscosity and diffusivity coeffs.  
+      !!
+      !! ** Method  :   Compute the swm term Bv (zqb) and added it to
+      !!               vertical viscosity and diffusivity coefficients
+      !!                   zqb = alpha * A * Us(0) * exp (3 * k * z)
+      !!               where alpha is set here to 1
+      !!             
+      !! ** action  :    avt, avs, avm updated by the surface wave-induced mixing
+      !!                               (inner domain only)
+      !!               
+      !! reference : Qiao et al. GRL, 2004
+      !!---------------------------------------------------------------------
+      INTEGER                    , INTENT(in   ) ::   kt             ! ocean time step
+      REAL(wp), DIMENSION(:,:,:) , INTENT(inout) ::   p_avm          ! momentum Kz (w-points)
+      REAL(wp), DIMENSION(:,:,:) , INTENT(inout) ::   p_avt, p_avs   ! tracer   Kz (w-points)
+      !
+      INTEGER ::   ji, jj, jk   ! dummy loop indices
+      REAL(wp)::   zcoef, zqb   ! local scalar
+      !!---------------------------------------------------------------------
+      !
+      zcoef = 1._wp * 0.353553_wp
+      DO jk = 2, jpkm1
+         DO jj = 2, jpjm1
+            DO ji = 2, jpim1
+               zqb = zcoef * hsw(ji,jj) * tsd2d(ji,jj) * EXP( -3. * wnum(ji,jj) * gdepw_n(ji,jj,jk) ) * wmask(ji,jj,jk)
+               !
+               p_avt(ji,jj,jk) = p_avt(ji,jj,jk) + zqb
+               p_avs(ji,jj,jk) = p_avs(ji,jj,jk) + zqb
+               p_avm(ji,jj,jk) = p_avm(ji,jj,jk) + zqb
+            END DO
+         END DO
+      END DO
+      !
+   END SUBROUTINE zdf_swm
+   
+   
+   SUBROUTINE zdf_swm_init
+      !!---------------------------------------------------------------------
+      !!                     ***  ROUTINE zdf_swm_init ***
+      !!
+      !! ** Purpose :   surface wave-induced mixing initialisation  
+      !!
+      !! ** Method  :   check the availability of surface wave fields
+      !!---------------------------------------------------------------------
+      !
+      IF(lwp) THEN                  ! Control print
+         WRITE(numout,*)
+         WRITE(numout,*) 'zdf_swm_init : surface wave-driven mixing'
+         WRITE(numout,*) '~~~~~~~~~~~~'
+      ENDIF
+      IF(  .NOT.ln_wave .OR.   &
+         & .NOT.ln_sdw    )   CALL ctl_stop ( 'zdf_swm_init: ln_zdfswm=T but ln_wave and ln_sdw /= T')
+      !
+   END SUBROUTINE zdf_swm_init
+
+   !!======================================================================
+END MODULE zdfswm
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/ZDF/zdftke.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/ZDF/zdftke.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/ZDF/zdftke.F90	(revision 9570)
@@ -0,0 +1,803 @@
+MODULE zdftke
+   !!======================================================================
+   !!                       ***  MODULE  zdftke  ***
+   !! Ocean physics:  vertical mixing coefficient computed from the tke 
+   !!                 turbulent closure parameterization
+   !!=====================================================================
+   !! History :  OPA  !  1991-03  (b. blanke)  Original code
+   !!            7.0  !  1991-11  (G. Madec)   bug fix
+   !!            7.1  !  1992-10  (G. Madec)   new mixing length and eav
+   !!            7.2  !  1993-03  (M. Guyon)   symetrical conditions
+   !!            7.3  !  1994-08  (G. Madec, M. Imbard)  nn_pdl flag
+   !!            7.5  !  1996-01  (G. Madec)   s-coordinates
+   !!            8.0  !  1997-07  (G. Madec)   lbc
+   !!            8.1  !  1999-01  (E. Stretta) new option for the mixing length
+   !!  NEMO      1.0  !  2002-06  (G. Madec) add tke_init routine
+   !!             -   !  2004-10  (C. Ethe )  1D configuration
+   !!            2.0  !  2006-07  (S. Masson)  distributed restart using iom
+   !!            3.0  !  2008-05  (C. Ethe,  G.Madec) : update TKE physics:
+   !!                 !           - tke penetration (wind steering)
+   !!                 !           - suface condition for tke & mixing length
+   !!                 !           - Langmuir cells
+   !!             -   !  2008-05  (J.-M. Molines, G. Madec)  2D form of avtb
+   !!             -   !  2008-06  (G. Madec)  style + DOCTOR name for namelist parameters
+   !!             -   !  2008-12  (G. Reffray) stable discretization of the production term 
+   !!            3.2  !  2009-06  (G. Madec, S. Masson) TKE restart compatible with key_cpl 
+   !!                 !                                + cleaning of the parameters + bugs correction
+   !!            3.3  !  2010-10  (C. Ethe, G. Madec) reorganisation of initialisation phase
+   !!            3.6  !  2014-11  (P. Mathiot) add ice shelf capability
+   !!            4.0  !  2017-04  (G. Madec)  remove CPP ddm key & avm at t-point only 
+   !!             -   !  2017-05  (G. Madec)  add top/bottom friction as boundary condition (ln_drg)
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   zdf_tke       : update momentum and tracer Kz from a tke scheme
+   !!   tke_tke       : tke time stepping: update tke at now time step (en)
+   !!   tke_avn       : compute mixing length scale and deduce avm and avt
+   !!   zdf_tke_init  : initialization, namelist read, and parameters control
+   !!   tke_rst       : read/write tke restart in ocean restart file
+   !!----------------------------------------------------------------------
+   USE oce            ! ocean: dynamics and active tracers variables
+   USE phycst         ! physical constants
+   USE dom_oce        ! domain: ocean
+   USE domvvl         ! domain: variable volume layer
+   USE sbc_oce        ! surface boundary condition: ocean
+   USE zdfdrg         ! vertical physics: top/bottom drag coef.
+   USE zdfmxl         ! vertical physics: mixed layer
+   !
+   USE in_out_manager ! I/O manager
+   USE iom            ! I/O manager library
+   USE lib_mpp        ! MPP library
+   USE lbclnk         ! ocean lateral boundary conditions (or mpp link)
+   USE prtctl         ! Print control
+   USE lib_fortran    ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined)  
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   zdf_tke        ! routine called in step module
+   PUBLIC   zdf_tke_init   ! routine called in opa module
+   PUBLIC   tke_rst        ! routine called in step module
+
+   !                      !!** Namelist  namzdf_tke  **
+   LOGICAL  ::   ln_mxl0   ! mixing length scale surface value as function of wind stress or not
+   INTEGER  ::   nn_mxl    ! type of mixing length (=0/1/2/3)
+   REAL(wp) ::   rn_mxl0   ! surface  min value of mixing length (kappa*z_o=0.4*0.1 m)  [m]
+   INTEGER  ::   nn_pdl    ! Prandtl number or not (ratio avt/avm) (=0/1)
+   REAL(wp) ::   rn_ediff  ! coefficient for avt: avt=rn_ediff*mxl*sqrt(e)
+   REAL(wp) ::   rn_ediss  ! coefficient of the Kolmogoroff dissipation 
+   REAL(wp) ::   rn_ebb    ! coefficient of the surface input of tke
+   REAL(wp) ::   rn_emin   ! minimum value of tke           [m2/s2]
+   REAL(wp) ::   rn_emin0  ! surface minimum value of tke   [m2/s2]
+   REAL(wp) ::   rn_bshear ! background shear (>0) currently a numerical threshold (do not change it)
+   LOGICAL  ::   ln_drg    ! top/bottom friction forcing flag 
+   INTEGER  ::   nn_etau   ! type of depth penetration of surface tke (=0/1/2/3)
+   INTEGER  ::      nn_htau   ! type of tke profile of penetration (=0/1)
+   REAL(wp) ::      rn_efr    ! fraction of TKE surface value which penetrates in the ocean
+   REAL(wp) ::      rn_eice   ! =0 ON below sea-ice, =4 OFF when ice fraction > 1/4   
+   LOGICAL  ::   ln_lc     ! Langmuir cells (LC) as a source term of TKE or not
+   REAL(wp) ::      rn_lc     ! coef to compute vertical velocity of Langmuir cells
+
+   REAL(wp) ::   ri_cri    ! critic Richardson number (deduced from rn_ediff and rn_ediss values)
+   REAL(wp) ::   rmxl_min  ! minimum mixing length value (deduced from rn_ediff and rn_emin values)  [m]
+   REAL(wp) ::   rhftau_add = 1.e-3_wp     ! add offset   applied to HF part of taum  (nn_etau=3)
+   REAL(wp) ::   rhftau_scl = 1.0_wp       ! scale factor applied to HF part of taum  (nn_etau=3)
+
+   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   htau    ! depth of tke penetration (nn_htau)
+   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   dissl   ! now mixing lenght of dissipation
+   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   apdlr   ! now mixing lenght of dissipation
+
+   !! * Substitutions
+#  include "vectopt_loop_substitute.h90"
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.7 , NEMO Consortium (2015)
+   !! $Id$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   INTEGER FUNCTION zdf_tke_alloc()
+      !!----------------------------------------------------------------------
+      !!                ***  FUNCTION zdf_tke_alloc  ***
+      !!----------------------------------------------------------------------
+      ALLOCATE( htau(jpi,jpj) , dissl(jpi,jpj,jpk) , apdlr(jpi,jpj,jpk) ,   STAT= zdf_tke_alloc )
+      !
+      IF( lk_mpp             )   CALL mpp_sum ( zdf_tke_alloc )
+      IF( zdf_tke_alloc /= 0 )   CALL ctl_warn('zdf_tke_alloc: failed to allocate arrays')
+      !
+   END FUNCTION zdf_tke_alloc
+
+
+   SUBROUTINE zdf_tke( kt, p_sh2, p_avm, p_avt )
+      !!----------------------------------------------------------------------
+      !!                   ***  ROUTINE zdf_tke  ***
+      !!
+      !! ** Purpose :   Compute the vertical eddy viscosity and diffusivity
+      !!              coefficients using a turbulent closure scheme (TKE).
+      !!
+      !! ** Method  :   The time evolution of the turbulent kinetic energy (tke)
+      !!              is computed from a prognostic equation :
+      !!         d(en)/dt = avm (d(u)/dz)**2             ! shear production
+      !!                  + d( avm d(en)/dz )/dz         ! diffusion of tke
+      !!                  + avt N^2                      ! stratif. destruc.
+      !!                  - rn_ediss / emxl en**(2/3)    ! Kolmogoroff dissipation
+      !!      with the boundary conditions:
+      !!         surface: en = max( rn_emin0, rn_ebb * taum )
+      !!         bottom : en = rn_emin
+      !!      The associated critical Richardson number is: ri_cri = 2/(2+rn_ediss/rn_ediff) 
+      !!
+      !!        The now Turbulent kinetic energy is computed using the following 
+      !!      time stepping: implicit for vertical diffusion term, linearized semi
+      !!      implicit for kolmogoroff dissipation term, and explicit forward for 
+      !!      both buoyancy and shear production terms. Therefore a tridiagonal 
+      !!      linear system is solved. Note that buoyancy and shear terms are
+      !!      discretized in a energy conserving form (Bruchard 2002).
+      !!
+      !!        The dissipative and mixing length scale are computed from en and
+      !!      the stratification (see tke_avn)
+      !!
+      !!        The now vertical eddy vicosity and diffusivity coefficients are
+      !!      given by: 
+      !!              avm = max( avtb, rn_ediff * zmxlm * en^1/2 )
+      !!              avt = max( avmb, pdl * avm                 )  
+      !!              eav = max( avmb, avm )
+      !!      where pdl, the inverse of the Prandtl number is 1 if nn_pdl=0 and
+      !!      given by an empirical funtion of the localRichardson number if nn_pdl=1 
+      !!
+      !! ** Action  :   compute en (now turbulent kinetic energy)
+      !!                update avt, avm (before vertical eddy coef.)
+      !!
+      !! References : Gaspar et al., JGR, 1990,
+      !!              Blanke and Delecluse, JPO, 1991
+      !!              Mellor and Blumberg, JPO 2004
+      !!              Axell, JGR, 2002
+      !!              Bruchard OM 2002
+      !!----------------------------------------------------------------------
+      INTEGER                   , INTENT(in   ) ::   kt             ! ocean time step
+      REAL(wp), DIMENSION(:,:,:), INTENT(in   ) ::   p_sh2          ! shear production term
+      REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   p_avm, p_avt   !  momentum and tracer Kz (w-points)
+      !!----------------------------------------------------------------------
+      !
+      CALL tke_tke( gdepw_n, e3t_n, e3w_n, p_sh2, p_avm, p_avt )   ! now tke (en)
+      !
+      CALL tke_avn( gdepw_n, e3t_n, e3w_n,        p_avm, p_avt )   ! now avt, avm, dissl
+      !
+  END SUBROUTINE zdf_tke
+
+
+   SUBROUTINE tke_tke( pdepw, p_e3t, p_e3w, p_sh2, p_avm, p_avt )
+      !!----------------------------------------------------------------------
+      !!                   ***  ROUTINE tke_tke  ***
+      !!
+      !! ** Purpose :   Compute the now Turbulente Kinetic Energy (TKE)
+      !!
+      !! ** Method  : - TKE surface boundary condition
+      !!              - source term due to Langmuir cells (Axell JGR 2002) (ln_lc=T)
+      !!              - source term due to shear (= Kz dz[Ub] * dz[Un] )
+      !!              - Now TKE : resolution of the TKE equation by inverting
+      !!                a tridiagonal linear system by a "methode de chasse"
+      !!              - increase TKE due to surface and internal wave breaking
+      !!             NB: when sea-ice is present, both LC parameterization 
+      !!                 and TKE penetration are turned off when the ice fraction 
+      !!                 is smaller than 0.25 
+      !!
+      !! ** Action  : - en : now turbulent kinetic energy)
+      !! ---------------------------------------------------------------------
+      USE zdf_oce , ONLY : en   ! ocean vertical physics
+      !!
+      REAL(wp), DIMENSION(:,:,:) , INTENT(in   ) ::   pdepw          ! depth of w-points
+      REAL(wp), DIMENSION(:,:,:) , INTENT(in   ) ::   p_e3t, p_e3w   ! level thickness (t- & w-points)
+      REAL(wp), DIMENSION(:,:,:) , INTENT(in   ) ::   p_sh2          ! shear production term
+      REAL(wp), DIMENSION(:,:,:) , INTENT(in   ) ::   p_avm, p_avt   ! vertical eddy viscosity & diffusivity (w-points)
+      !
+      INTEGER ::   ji, jj, jk              ! dummy loop arguments
+      REAL(wp) ::   zetop, zebot, zmsku, zmskv ! local scalars
+      REAL(wp) ::   zrhoa  = 1.22              ! Air density kg/m3
+      REAL(wp) ::   zcdrag = 1.5e-3            ! drag coefficient
+      REAL(wp) ::   zbbrau, zri                ! local scalars
+      REAL(wp) ::   zfact1, zfact2, zfact3     !   -         -
+      REAL(wp) ::   ztx2  , zty2  , zcof       !   -         -
+      REAL(wp) ::   ztau  , zdif               !   -         -
+      REAL(wp) ::   zus   , zwlc  , zind       !   -         -
+      REAL(wp) ::   zzd_up, zzd_lw             !   -         -
+      INTEGER , DIMENSION(jpi,jpj)     ::   imlc
+      REAL(wp), DIMENSION(jpi,jpj)     ::   zhlc
+      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zpelc, zdiag, zd_up, zd_lw
+      !!--------------------------------------------------------------------
+      !
+      zbbrau = rn_ebb / rau0       ! Local constant initialisation
+      zfact1 = -.5_wp * rdt 
+      zfact2 = 1.5_wp * rdt * rn_ediss
+      zfact3 = 0.5_wp       * rn_ediss
+      !
+      !                     !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+      !                     !  Surface/top/bottom boundary condition on tke
+      !                     !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+      
+      DO jj = 2, jpjm1            ! en(1)   = rn_ebb taum / rau0  (min value rn_emin0)
+         DO ji = fs_2, fs_jpim1   ! vector opt.
+            en(ji,jj,1) = MAX( rn_emin0, zbbrau * taum(ji,jj) ) * tmask(ji,jj,1)
+         END DO
+      END DO
+      IF ( ln_isfcav ) THEN
+         DO jj = 2, jpjm1            ! en(mikt(ji,jj))   = rn_emin
+            DO ji = fs_2, fs_jpim1   ! vector opt.
+               en(ji,jj,mikt(ji,jj)) = rn_emin * tmask(ji,jj,1)
+            END DO
+         END DO
+      ENDIF
+      !
+      !                     !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+      !                     !  Bottom boundary condition on tke
+      !                     !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+      !
+      !   en(bot)   = (ebb0/rau0)*0.5*sqrt(u_botfr^2+v_botfr^2) (min value rn_emin)
+      ! where ebb0 does not includes surface wave enhancement (i.e. ebb0=3.75)
+      ! Note that stress averaged is done using an wet-only calculation of u and v at t-point like in zdfsh2
+      !
+      IF( ln_drg ) THEN       !== friction used as top/bottom boundary condition on TKE
+         !
+         DO jj = 2, jpjm1           ! bottom friction
+            DO ji = fs_2, fs_jpim1     ! vector opt.
+               zmsku = ( 2. - umask(ji-1,jj,mbkt(ji,jj)) * umask(ji,jj,mbkt(ji,jj)) )
+               zmskv = ( 2. - vmask(ji,jj-1,mbkt(ji,jj)) * vmask(ji,jj,mbkt(ji,jj)) )
+               !                       ! where 0.001875 = (rn_ebb0/rau0) * 0.5 = 3.75*0.5/1000. (CAUTION CdU<0)
+               zebot = - 0.001875_wp * rCdU_bot(ji,jj) * SQRT(  ( zmsku*( ub(ji,jj,mbkt(ji,jj))+ub(ji-1,jj,mbkt(ji,jj)) ) )**2  &
+                  &                                           + ( zmskv*( vb(ji,jj,mbkt(ji,jj))+vb(ji,jj-1,mbkt(ji,jj)) ) )**2  )
+               en(ji,jj,mbkt(ji,jj)+1) = MAX( zebot, rn_emin ) * ssmask(ji,jj)
+            END DO
+         END DO
+         IF( ln_isfcav ) THEN       ! top friction
+            DO jj = 2, jpjm1
+               DO ji = fs_2, fs_jpim1   ! vector opt.
+                  zmsku = ( 2. - umask(ji-1,jj,mikt(ji,jj)) * umask(ji,jj,mikt(ji,jj)) )
+                  zmskv = ( 2. - vmask(ji,jj-1,mikt(ji,jj)) * vmask(ji,jj,mikt(ji,jj)) )
+                  !                             ! where 0.001875 = (rn_ebb0/rau0) * 0.5 = 3.75*0.5/1000.  (CAUTION CdU<0)
+                  zetop = - 0.001875_wp * rCdU_top(ji,jj) * SQRT(  ( zmsku*( ub(ji,jj,mikt(ji,jj))+ub(ji-1,jj,mikt(ji,jj)) ) )**2  &
+                     &                                           + ( zmskv*( vb(ji,jj,mikt(ji,jj))+vb(ji,jj-1,mikt(ji,jj)) ) )**2  )
+                  en(ji,jj,mikt(ji,jj)) = MAX( zetop, rn_emin ) * (1._wp - tmask(ji,jj,1))   ! masked at ocean surface
+               END DO
+            END DO
+         ENDIF
+         !
+      ENDIF
+      !
+      !                     !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+      IF( ln_lc ) THEN      !  Langmuir circulation source term added to tke   !   (Axell JGR 2002)
+         !                  !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+         !
+         !                        !* total energy produce by LC : cumulative sum over jk
+         zpelc(:,:,1) =  MAX( rn2b(:,:,1), 0._wp ) * pdepw(:,:,1) * p_e3w(:,:,1)
+         DO jk = 2, jpk
+            zpelc(:,:,jk)  = zpelc(:,:,jk-1) + MAX( rn2b(:,:,jk), 0._wp ) * pdepw(:,:,jk) * p_e3w(:,:,jk)
+         END DO
+         !                        !* finite Langmuir Circulation depth
+         zcof = 0.5 * 0.016 * 0.016 / ( zrhoa * zcdrag )
+         imlc(:,:) = mbkt(:,:) + 1       ! Initialization to the number of w ocean point (=2 over land)
+         DO jk = jpkm1, 2, -1
+            DO jj = 1, jpj               ! Last w-level at which zpelc>=0.5*us*us 
+               DO ji = 1, jpi            !      with us=0.016*wind(starting from jpk-1)
+                  zus  = zcof * taum(ji,jj)
+                  IF( zpelc(ji,jj,jk) > zus )   imlc(ji,jj) = jk
+               END DO
+            END DO
+         END DO
+         !                               ! finite LC depth
+         DO jj = 1, jpj 
+            DO ji = 1, jpi
+               zhlc(ji,jj) = pdepw(ji,jj,imlc(ji,jj))
+            END DO
+         END DO
+         zcof = 0.016 / SQRT( zrhoa * zcdrag )
+         DO jk = 2, jpkm1         !* TKE Langmuir circulation source term added to en
+            DO jj = 2, jpjm1
+               DO ji = fs_2, fs_jpim1   ! vector opt.
+                  zus  = zcof * SQRT( taum(ji,jj) )           ! Stokes drift
+                  !                                           ! vertical velocity due to LC
+                  zind = 0.5 - SIGN( 0.5, pdepw(ji,jj,jk) - zhlc(ji,jj) )
+                  zwlc = zind * rn_lc * zus * SIN( rpi * pdepw(ji,jj,jk) / zhlc(ji,jj) )
+                  !                                           ! TKE Langmuir circulation source term
+                  en(ji,jj,jk) = en(ji,jj,jk) + rdt * MAX(0.,1._wp - 4.*fr_i(ji,jj) ) * ( zwlc * zwlc * zwlc )   &
+                     &                              / zhlc(ji,jj) * wmask(ji,jj,jk) * tmask(ji,jj,1)
+               END DO
+            END DO
+         END DO
+         !
+      ENDIF
+      !
+      !                     !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+      !                     !  Now Turbulent kinetic energy (output in en)
+      !                     !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+      !                     ! Resolution of a tridiagonal linear system by a "methode de chasse"
+      !                     ! computation from level 2 to jpkm1  (e(1) already computed and e(jpk)=0 ).
+      !                     ! zdiag : diagonal zd_up : upper diagonal zd_lw : lower diagonal
+      !
+      IF( nn_pdl == 1 ) THEN      !* Prandtl number = F( Ri )
+         DO jk = 2, jpkm1
+            DO jj = 2, jpjm1
+               DO ji = 2, jpim1
+                  !                             ! local Richardson number
+                  zri = MAX( rn2b(ji,jj,jk), 0._wp ) * p_avm(ji,jj,jk) / ( p_sh2(ji,jj,jk) + rn_bshear )
+                  !                             ! inverse of Prandtl number
+                  apdlr(ji,jj,jk) = MAX(  0.1_wp,  ri_cri / MAX( ri_cri , zri )  )
+               END DO
+            END DO
+         END DO
+      ENDIF
+      !         
+      DO jk = 2, jpkm1           !* Matrix and right hand side in en
+         DO jj = 2, jpjm1
+            DO ji = fs_2, fs_jpim1   ! vector opt.
+               zcof   = zfact1 * tmask(ji,jj,jk)
+               !                                   ! A minimum of 2.e-5 m2/s is imposed on TKE vertical
+               !                                   ! eddy coefficient (ensure numerical stability)
+               zzd_up = zcof * MAX(  p_avm(ji,jj,jk+1) + p_avm(ji,jj,jk  ) , 2.e-5_wp  )   &  ! upper diagonal
+                  &          /    (  p_e3t(ji,jj,jk  ) * p_e3w(ji,jj,jk  )  )
+               zzd_lw = zcof * MAX(  p_avm(ji,jj,jk  ) + p_avm(ji,jj,jk-1) , 2.e-5_wp  )   &  ! lower diagonal
+                  &          /    (  p_e3t(ji,jj,jk-1) * p_e3w(ji,jj,jk  )  )
+               !
+               zd_up(ji,jj,jk) = zzd_up            ! Matrix (zdiag, zd_up, zd_lw)
+               zd_lw(ji,jj,jk) = zzd_lw
+               zdiag(ji,jj,jk) = 1._wp - zzd_lw - zzd_up + zfact2 * dissl(ji,jj,jk) * wmask(ji,jj,jk)
+               !
+               !                                   ! right hand side in en
+               en(ji,jj,jk) = en(ji,jj,jk) + rdt * (  p_sh2(ji,jj,jk)                          &   ! shear
+                  &                                 - p_avt(ji,jj,jk) * rn2(ji,jj,jk)          &   ! stratification
+                  &                                 + zfact3 * dissl(ji,jj,jk) * en(ji,jj,jk)  &   ! dissipation
+                  &                                ) * wmask(ji,jj,jk)
+            END DO
+         END DO
+      END DO
+      !                          !* Matrix inversion from level 2 (tke prescribed at level 1)
+      DO jk = 3, jpkm1                             ! First recurrence : Dk = Dk - Lk * Uk-1 / Dk-1
+         DO jj = 2, jpjm1
+            DO ji = fs_2, fs_jpim1    ! vector opt.
+               zdiag(ji,jj,jk) = zdiag(ji,jj,jk) - zd_lw(ji,jj,jk) * zd_up(ji,jj,jk-1) / zdiag(ji,jj,jk-1)
+            END DO
+         END DO
+      END DO
+      DO jj = 2, jpjm1                             ! Second recurrence : Lk = RHSk - Lk / Dk-1 * Lk-1
+         DO ji = fs_2, fs_jpim1   ! vector opt.
+            zd_lw(ji,jj,2) = en(ji,jj,2) - zd_lw(ji,jj,2) * en(ji,jj,1)    ! Surface boudary conditions on tke
+         END DO
+      END DO
+      DO jk = 3, jpkm1
+         DO jj = 2, jpjm1
+            DO ji = fs_2, fs_jpim1    ! vector opt.
+               zd_lw(ji,jj,jk) = en(ji,jj,jk) - zd_lw(ji,jj,jk) / zdiag(ji,jj,jk-1) *zd_lw(ji,jj,jk-1)
+            END DO
+         END DO
+      END DO
+      DO jj = 2, jpjm1                             ! thrid recurrence : Ek = ( Lk - Uk * Ek+1 ) / Dk
+         DO ji = fs_2, fs_jpim1   ! vector opt.
+            en(ji,jj,jpkm1) = zd_lw(ji,jj,jpkm1) / zdiag(ji,jj,jpkm1)
+         END DO
+      END DO
+      DO jk = jpk-2, 2, -1
+         DO jj = 2, jpjm1
+            DO ji = fs_2, fs_jpim1    ! vector opt.
+               en(ji,jj,jk) = ( zd_lw(ji,jj,jk) - zd_up(ji,jj,jk) * en(ji,jj,jk+1) ) / zdiag(ji,jj,jk)
+            END DO
+         END DO
+      END DO
+      DO jk = 2, jpkm1                             ! set the minimum value of tke
+         DO jj = 2, jpjm1
+            DO ji = fs_2, fs_jpim1   ! vector opt.
+               en(ji,jj,jk) = MAX( en(ji,jj,jk), rn_emin ) * wmask(ji,jj,jk)
+            END DO
+         END DO
+      END DO
+      !
+      !                            !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+      !                            !  TKE due to surface and internal wave breaking
+      !                            !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+!!gm BUG : in the exp  remove the depth of ssh !!!
+!!gm       i.e. use gde3w in argument (pdepw)
+      
+      
+      IF( nn_etau == 1 ) THEN           !* penetration below the mixed layer (rn_efr fraction)
+         DO jk = 2, jpkm1                       ! rn_eice =0 ON below sea-ice, =4 OFF when ice fraction > 0.25
+            DO jj = 2, jpjm1
+               DO ji = fs_2, fs_jpim1   ! vector opt.
+                  en(ji,jj,jk) = en(ji,jj,jk) + rn_efr * en(ji,jj,1) * EXP( -pdepw(ji,jj,jk) / htau(ji,jj) )   &
+                     &                                 * MAX(0.,1._wp - rn_eice *fr_i(ji,jj) )  * wmask(ji,jj,jk) * tmask(ji,jj,1)
+               END DO
+            END DO
+         END DO
+      ELSEIF( nn_etau == 2 ) THEN       !* act only at the base of the mixed layer (jk=nmln)  (rn_efr fraction)
+         DO jj = 2, jpjm1
+            DO ji = fs_2, fs_jpim1   ! vector opt.
+               jk = nmln(ji,jj)
+               en(ji,jj,jk) = en(ji,jj,jk) + rn_efr * en(ji,jj,1) * EXP( -pdepw(ji,jj,jk) / htau(ji,jj) )   &
+                  &                                 * MAX(0.,1._wp - rn_eice *fr_i(ji,jj) )  * wmask(ji,jj,jk) * tmask(ji,jj,1)
+            END DO
+         END DO
+      ELSEIF( nn_etau == 3 ) THEN       !* penetration belox the mixed layer (HF variability)
+         DO jk = 2, jpkm1
+            DO jj = 2, jpjm1
+               DO ji = fs_2, fs_jpim1   ! vector opt.
+                  ztx2 = utau(ji-1,jj  ) + utau(ji,jj)
+                  zty2 = vtau(ji  ,jj-1) + vtau(ji,jj)
+                  ztau = 0.5_wp * SQRT( ztx2 * ztx2 + zty2 * zty2 ) * tmask(ji,jj,1)    ! module of the mean stress 
+                  zdif = taum(ji,jj) - ztau                            ! mean of modulus - modulus of the mean 
+                  zdif = rhftau_scl * MAX( 0._wp, zdif + rhftau_add )  ! apply some modifications...
+                  en(ji,jj,jk) = en(ji,jj,jk) + zbbrau * zdif * EXP( -pdepw(ji,jj,jk) / htau(ji,jj) )   &
+                     &                        * MAX(0.,1._wp - rn_eice *fr_i(ji,jj) ) * wmask(ji,jj,jk) * tmask(ji,jj,1)
+               END DO
+            END DO
+         END DO
+      ENDIF
+      !
+   END SUBROUTINE tke_tke
+
+
+   SUBROUTINE tke_avn( pdepw, p_e3t, p_e3w, p_avm, p_avt )
+      !!----------------------------------------------------------------------
+      !!                   ***  ROUTINE tke_avn  ***
+      !!
+      !! ** Purpose :   Compute the vertical eddy viscosity and diffusivity
+      !!
+      !! ** Method  :   At this stage, en, the now TKE, is known (computed in 
+      !!              the tke_tke routine). First, the now mixing lenth is 
+      !!      computed from en and the strafification (N^2), then the mixings
+      !!      coefficients are computed.
+      !!              - Mixing length : a first evaluation of the mixing lengh
+      !!      scales is:
+      !!                      mxl = sqrt(2*en) / N  
+      !!      where N is the brunt-vaisala frequency, with a minimum value set
+      !!      to rmxl_min (rn_mxl0) in the interior (surface) ocean.
+      !!        The mixing and dissipative length scale are bound as follow : 
+      !!         nn_mxl=0 : mxl bounded by the distance to surface and bottom.
+      !!                        zmxld = zmxlm = mxl
+      !!         nn_mxl=1 : mxl bounded by the e3w and zmxld = zmxlm = mxl
+      !!         nn_mxl=2 : mxl bounded such that the vertical derivative of mxl is 
+      !!                    less than 1 (|d/dz(mxl)|<1) and zmxld = zmxlm = mxl
+      !!         nn_mxl=3 : mxl is bounded from the surface to the bottom usings
+      !!                    |d/dz(xml)|<1 to obtain lup, and from the bottom to 
+      !!                    the surface to obtain ldown. the resulting length 
+      !!                    scales are:
+      !!                        zmxld = sqrt( lup * ldown ) 
+      !!                        zmxlm = min ( lup , ldown )
+      !!              - Vertical eddy viscosity and diffusivity:
+      !!                      avm = max( avtb, rn_ediff * zmxlm * en^1/2 )
+      !!                      avt = max( avmb, pdlr * avm )  
+      !!      with pdlr=1 if nn_pdl=0, pdlr=1/pdl=F(Ri) otherwise.
+      !!
+      !! ** Action  : - avt, avm : now vertical eddy diffusivity and viscosity (w-point)
+      !!----------------------------------------------------------------------
+      USE zdf_oce , ONLY : en, avtb, avmb, avtb_2d   ! ocean vertical physics
+      !!
+      REAL(wp), DIMENSION(:,:,:), INTENT(in   ) ::   pdepw          ! depth (w-points)
+      REAL(wp), DIMENSION(:,:,:), INTENT(in   ) ::   p_e3t, p_e3w   ! level thickness (t- & w-points)
+      REAL(wp), DIMENSION(:,:,:), INTENT(  out) ::   p_avm, p_avt   ! vertical eddy viscosity & diffusivity (w-points)
+      !
+      INTEGER  ::   ji, jj, jk   ! dummy loop indices
+      REAL(wp) ::   zrn2, zraug, zcoef, zav   ! local scalars
+      REAL(wp) ::   zdku,   zdkv, zsqen       !   -      -
+      REAL(wp) ::   zemxl, zemlm, zemlp       !   -      -
+      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zmxlm, zmxld   ! 3D workspace
+      !!--------------------------------------------------------------------
+      !
+      !                     !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+      !                     !  Mixing length
+      !                     !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+      !
+      !                     !* Buoyancy length scale: l=sqrt(2*e/n**2)
+      !
+      ! initialisation of interior minimum value (avoid a 2d loop with mikt)
+      zmxlm(:,:,:)  = rmxl_min    
+      zmxld(:,:,:)  = rmxl_min
+      !
+      IF( ln_mxl0 ) THEN            ! surface mixing length = F(stress) : l=vkarmn*2.e5*taum/(rau0*g)
+         zraug = vkarmn * 2.e5_wp / ( rau0 * grav )
+         DO jj = 2, jpjm1
+            DO ji = fs_2, fs_jpim1
+               zmxlm(ji,jj,1) = MAX( rn_mxl0, zraug * taum(ji,jj) * tmask(ji,jj,1) )
+            END DO
+         END DO
+      ELSE 
+         zmxlm(:,:,1) = rn_mxl0
+      ENDIF
+      !
+      DO jk = 2, jpkm1              ! interior value : l=sqrt(2*e/n^2)
+         DO jj = 2, jpjm1
+            DO ji = fs_2, fs_jpim1   ! vector opt.
+               zrn2 = MAX( rn2(ji,jj,jk), rsmall )
+               zmxlm(ji,jj,jk) = MAX(  rmxl_min,  SQRT( 2._wp * en(ji,jj,jk) / zrn2 )  )
+            END DO
+         END DO
+      END DO
+      !
+      !                     !* Physical limits for the mixing length
+      !
+      zmxld(:,:, 1 ) = zmxlm(:,:,1)   ! surface set to the minimum value 
+      zmxld(:,:,jpk) = rmxl_min       ! last level  set to the minimum value
+      !
+      SELECT CASE ( nn_mxl )
+      !
+ !!gm Not sure of that coding for ISF....
+      ! where wmask = 0 set zmxlm == p_e3w
+      CASE ( 0 )           ! bounded by the distance to surface and bottom
+         DO jk = 2, jpkm1
+            DO jj = 2, jpjm1
+               DO ji = fs_2, fs_jpim1   ! vector opt.
+                  zemxl = MIN( pdepw(ji,jj,jk) - pdepw(ji,jj,mikt(ji,jj)), zmxlm(ji,jj,jk),   &
+                  &            pdepw(ji,jj,mbkt(ji,jj)+1) - pdepw(ji,jj,jk) )
+                  ! wmask prevent zmxlm = 0 if jk = mikt(ji,jj)
+                  zmxlm(ji,jj,jk) = zemxl * wmask(ji,jj,jk) + MIN( zmxlm(ji,jj,jk) , p_e3w(ji,jj,jk) ) * (1 - wmask(ji,jj,jk))
+                  zmxld(ji,jj,jk) = zemxl * wmask(ji,jj,jk) + MIN( zmxlm(ji,jj,jk) , p_e3w(ji,jj,jk) ) * (1 - wmask(ji,jj,jk))
+               END DO
+            END DO
+         END DO
+         !
+      CASE ( 1 )           ! bounded by the vertical scale factor
+         DO jk = 2, jpkm1
+            DO jj = 2, jpjm1
+               DO ji = fs_2, fs_jpim1   ! vector opt.
+                  zemxl = MIN( p_e3w(ji,jj,jk), zmxlm(ji,jj,jk) )
+                  zmxlm(ji,jj,jk) = zemxl
+                  zmxld(ji,jj,jk) = zemxl
+               END DO
+            END DO
+         END DO
+         !
+      CASE ( 2 )           ! |dk[xml]| bounded by e3t :
+         DO jk = 2, jpkm1         ! from the surface to the bottom :
+            DO jj = 2, jpjm1
+               DO ji = fs_2, fs_jpim1   ! vector opt.
+                  zmxlm(ji,jj,jk) = MIN( zmxlm(ji,jj,jk-1) + p_e3t(ji,jj,jk-1), zmxlm(ji,jj,jk) )
+               END DO
+            END DO
+         END DO
+         DO jk = jpkm1, 2, -1     ! from the bottom to the surface :
+            DO jj = 2, jpjm1
+               DO ji = fs_2, fs_jpim1   ! vector opt.
+                  zemxl = MIN( zmxlm(ji,jj,jk+1) + p_e3t(ji,jj,jk+1), zmxlm(ji,jj,jk) )
+                  zmxlm(ji,jj,jk) = zemxl
+                  zmxld(ji,jj,jk) = zemxl
+               END DO
+            END DO
+         END DO
+         !
+      CASE ( 3 )           ! lup and ldown, |dk[xml]| bounded by e3t :
+         DO jk = 2, jpkm1         ! from the surface to the bottom : lup
+            DO jj = 2, jpjm1
+               DO ji = fs_2, fs_jpim1   ! vector opt.
+                  zmxld(ji,jj,jk) = MIN( zmxld(ji,jj,jk-1) + p_e3t(ji,jj,jk-1), zmxlm(ji,jj,jk) )
+               END DO
+            END DO
+         END DO
+         DO jk = jpkm1, 2, -1     ! from the bottom to the surface : ldown
+            DO jj = 2, jpjm1
+               DO ji = fs_2, fs_jpim1   ! vector opt.
+                  zmxlm(ji,jj,jk) = MIN( zmxlm(ji,jj,jk+1) + p_e3t(ji,jj,jk+1), zmxlm(ji,jj,jk) )
+               END DO
+            END DO
+         END DO
+         DO jk = 2, jpkm1
+            DO jj = 2, jpjm1
+               DO ji = fs_2, fs_jpim1   ! vector opt.
+                  zemlm = MIN ( zmxld(ji,jj,jk),  zmxlm(ji,jj,jk) )
+                  zemlp = SQRT( zmxld(ji,jj,jk) * zmxlm(ji,jj,jk) )
+                  zmxlm(ji,jj,jk) = zemlm
+                  zmxld(ji,jj,jk) = zemlp
+               END DO
+            END DO
+         END DO
+         !
+      END SELECT
+      !
+      !                     !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+      !                     !  Vertical eddy viscosity and diffusivity  (avm and avt)
+      !                     !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+      DO jk = 1, jpkm1            !* vertical eddy viscosity & diffivity at w-points
+         DO jj = 2, jpjm1
+            DO ji = fs_2, fs_jpim1   ! vector opt.
+               zsqen = SQRT( en(ji,jj,jk) )
+               zav   = rn_ediff * zmxlm(ji,jj,jk) * zsqen
+               p_avm(ji,jj,jk) = MAX( zav,                  avmb(jk) ) * wmask(ji,jj,jk)
+               p_avt(ji,jj,jk) = MAX( zav, avtb_2d(ji,jj) * avtb(jk) ) * wmask(ji,jj,jk)
+               dissl(ji,jj,jk) = zsqen / zmxld(ji,jj,jk)
+            END DO
+         END DO
+      END DO
+      !
+      !
+      IF( nn_pdl == 1 ) THEN      !* Prandtl number case: update avt
+         DO jk = 2, jpkm1
+            DO jj = 2, jpjm1
+               DO ji = fs_2, fs_jpim1   ! vector opt.
+                  p_avt(ji,jj,jk)   = MAX( apdlr(ji,jj,jk) * p_avt(ji,jj,jk), avtb_2d(ji,jj) * avtb(jk) ) * tmask(ji,jj,jk)
+              END DO
+            END DO
+         END DO
+      ENDIF
+      !
+      IF(ln_ctl) THEN
+         CALL prt_ctl( tab3d_1=en   , clinfo1=' tke  - e: ', tab3d_2=p_avt, clinfo2=' t: ', kdim=jpk)
+         CALL prt_ctl( tab3d_1=p_avm, clinfo1=' tke  - m: ', kdim=jpk )
+      ENDIF
+      !
+   END SUBROUTINE tke_avn
+
+
+   SUBROUTINE zdf_tke_init
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE zdf_tke_init  ***
+      !!                     
+      !! ** Purpose :   Initialization of the vertical eddy diffivity and 
+      !!              viscosity when using a tke turbulent closure scheme
+      !!
+      !! ** Method  :   Read the namzdf_tke namelist and check the parameters
+      !!              called at the first timestep (nit000)
+      !!
+      !! ** input   :   Namlist namzdf_tke
+      !!
+      !! ** Action  :   Increase by 1 the nstop flag is setting problem encounter
+      !!----------------------------------------------------------------------
+      USE zdf_oce , ONLY : ln_zdfiwm   ! Internal Wave Mixing flag
+      !!
+      INTEGER ::   ji, jj, jk   ! dummy loop indices
+      INTEGER ::   ios
+      !!
+      NAMELIST/namzdf_tke/ rn_ediff, rn_ediss , rn_ebb , rn_emin  ,          &
+         &                 rn_emin0, rn_bshear, nn_mxl , ln_mxl0  ,          &
+         &                 rn_mxl0 , nn_pdl   , ln_drg , ln_lc    , rn_lc,   &
+         &                 nn_etau , nn_htau  , rn_efr , rn_eice  
+      !!----------------------------------------------------------------------
+      !
+      REWIND( numnam_ref )              ! Namelist namzdf_tke in reference namelist : Turbulent Kinetic Energy
+      READ  ( numnam_ref, namzdf_tke, IOSTAT = ios, ERR = 901)
+901   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namzdf_tke in reference namelist', lwp )
+
+      REWIND( numnam_cfg )              ! Namelist namzdf_tke in configuration namelist : Turbulent Kinetic Energy
+      READ  ( numnam_cfg, namzdf_tke, IOSTAT = ios, ERR = 902 )
+902   IF( ios >  0 ) CALL ctl_nam ( ios , 'namzdf_tke in configuration namelist', lwp )
+      IF(lwm) WRITE ( numond, namzdf_tke )
+      !
+      ri_cri   = 2._wp    / ( 2._wp + rn_ediss / rn_ediff )   ! resulting critical Richardson number
+      !
+      IF(lwp) THEN                    !* Control print
+         WRITE(numout,*)
+         WRITE(numout,*) 'zdf_tke_init : tke turbulent closure scheme - initialisation'
+         WRITE(numout,*) '~~~~~~~~~~~~'
+         WRITE(numout,*) '   Namelist namzdf_tke : set tke mixing parameters'
+         WRITE(numout,*) '      coef. to compute avt                        rn_ediff  = ', rn_ediff
+         WRITE(numout,*) '      Kolmogoroff dissipation coef.               rn_ediss  = ', rn_ediss
+         WRITE(numout,*) '      tke surface input coef.                     rn_ebb    = ', rn_ebb
+         WRITE(numout,*) '      minimum value of tke                        rn_emin   = ', rn_emin
+         WRITE(numout,*) '      surface minimum value of tke                rn_emin0  = ', rn_emin0
+         WRITE(numout,*) '      prandl number flag                          nn_pdl    = ', nn_pdl
+         WRITE(numout,*) '      background shear (>0)                       rn_bshear = ', rn_bshear
+         WRITE(numout,*) '      mixing length type                          nn_mxl    = ', nn_mxl
+         WRITE(numout,*) '         surface mixing length = F(stress) or not    ln_mxl0   = ', ln_mxl0
+         WRITE(numout,*) '         surface  mixing length minimum value        rn_mxl0   = ', rn_mxl0
+         WRITE(numout,*) '      top/bottom friction forcing flag            ln_drg    = ', ln_drg
+         WRITE(numout,*) '      Langmuir cells parametrization              ln_lc     = ', ln_lc
+         WRITE(numout,*) '         coef to compute vertical velocity of LC     rn_lc  = ', rn_lc
+         WRITE(numout,*) '      test param. to add tke induced by wind      nn_etau   = ', nn_etau
+         WRITE(numout,*) '          type of tke penetration profile            nn_htau   = ', nn_htau
+         WRITE(numout,*) '          fraction of TKE that penetrates            rn_efr    = ', rn_efr
+         WRITE(numout,*) '          below sea-ice:  =0 ON                      rn_eice   = ', rn_eice
+         WRITE(numout,*) '          =4 OFF when ice fraction > 1/4   '
+         IF( ln_drg ) THEN
+            WRITE(numout,*)
+            WRITE(numout,*) '   Namelist namdrg_top/_bot:   used values:'
+            WRITE(numout,*) '      top    ocean cavity roughness (m)          rn_z0(_top)= ', r_z0_top
+            WRITE(numout,*) '      Bottom seafloor     roughness (m)          rn_z0(_bot)= ', r_z0_bot
+         ENDIF
+         WRITE(numout,*)
+         WRITE(numout,*) '   ==>>>   critical Richardson nb with your parameters  ri_cri = ', ri_cri
+         WRITE(numout,*)
+      ENDIF
+      !
+      IF( ln_zdfiwm ) THEN          ! Internal wave-driven mixing
+         rn_emin  = 1.e-10_wp             ! specific values of rn_emin & rmxl_min are used
+         rmxl_min = 1.e-03_wp             ! associated avt minimum = molecular salt diffusivity (10^-9 m2/s)
+         IF(lwp) WRITE(numout,*) '   ==>>>   Internal wave-driven mixing case:   force   rn_emin = 1.e-10 and rmxl_min = 1.e-3'
+      ELSE                          ! standard case : associated avt minimum = molecular viscosity (10^-6 m2/s)
+         rmxl_min = 1.e-6_wp / ( rn_ediff * SQRT( rn_emin ) )    ! resulting minimum length to recover molecular viscosity
+         IF(lwp) WRITE(numout,*) '   ==>>>   minimum mixing length with your parameters rmxl_min = ', rmxl_min
+      ENDIF
+      !
+      !                              ! allocate tke arrays
+      IF( zdf_tke_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'zdf_tke_init : unable to allocate arrays' )
+      !
+      !                               !* Check of some namelist values
+      IF( nn_mxl  < 0   .OR.  nn_mxl  > 3 )   CALL ctl_stop( 'bad flag: nn_mxl is  0, 1 or 2 ' )
+      IF( nn_pdl  < 0   .OR.  nn_pdl  > 1 )   CALL ctl_stop( 'bad flag: nn_pdl is  0 or 1    ' )
+      IF( nn_htau < 0   .OR.  nn_htau > 1 )   CALL ctl_stop( 'bad flag: nn_htau is 0, 1 or 2 ' )
+      IF( nn_etau == 3 .AND. .NOT. ln_cpl )   CALL ctl_stop( 'nn_etau == 3 : HF taum only known in coupled mode' )
+      !
+      IF( ln_mxl0 ) THEN
+         IF(lwp) WRITE(numout,*)
+         IF(lwp) WRITE(numout,*) '   ==>>>   use a surface mixing length = F(stress) :   set rn_mxl0 = rmxl_min'
+         rn_mxl0 = rmxl_min
+      ENDIF
+      
+      IF( nn_etau == 2  )   CALL zdf_mxl( nit000 )      ! Initialization of nmln 
+
+      !                               !* depth of penetration of surface tke
+      IF( nn_etau /= 0 ) THEN      
+         SELECT CASE( nn_htau )             ! Choice of the depth of penetration
+         CASE( 0 )                                 ! constant depth penetration (here 10 meters)
+            htau(:,:) = 10._wp
+         CASE( 1 )                                 ! F(latitude) : 0.5m to 30m poleward of 40 degrees
+            htau(:,:) = MAX(  0.5_wp, MIN( 30._wp, 45._wp* ABS( SIN( rpi/180._wp * gphit(:,:) ) ) )   )            
+         END SELECT
+      ENDIF
+      !                                !* read or initialize all required files
+      CALL tke_rst( nit000, 'READ' )      ! (en, avt_k, avm_k, dissl) 
+      !
+      IF( lwxios ) THEN
+         CALL iom_set_rstw_var_active('en')
+         CALL iom_set_rstw_var_active('avt_k')
+         CALL iom_set_rstw_var_active('avm_k')
+         CALL iom_set_rstw_var_active('dissl')
+      ENDIF
+   END SUBROUTINE zdf_tke_init
+
+
+   SUBROUTINE tke_rst( kt, cdrw )
+      !!---------------------------------------------------------------------
+      !!                   ***  ROUTINE tke_rst  ***
+      !!                     
+      !! ** Purpose :   Read or write TKE file (en) in restart file
+      !!
+      !! ** Method  :   use of IOM library
+      !!                if the restart does not contain TKE, en is either 
+      !!                set to rn_emin or recomputed 
+      !!----------------------------------------------------------------------
+      USE zdf_oce , ONLY : en, avt_k, avm_k   ! ocean vertical physics
+      !!
+      INTEGER         , INTENT(in) ::   kt     ! ocean time-step
+      CHARACTER(len=*), INTENT(in) ::   cdrw   ! "READ"/"WRITE" flag
+      !
+      INTEGER ::   jit, jk              ! dummy loop indices
+      INTEGER ::   id1, id2, id3, id4   ! local integers
+      !!----------------------------------------------------------------------
+      !
+      IF( TRIM(cdrw) == 'READ' ) THEN        ! Read/initialise 
+         !                                   ! ---------------
+         IF( ln_rstart ) THEN                   !* Read the restart file
+            id1 = iom_varid( numror, 'en'   , ldstop = .FALSE. )
+            id2 = iom_varid( numror, 'avt_k', ldstop = .FALSE. )
+            id3 = iom_varid( numror, 'avm_k', ldstop = .FALSE. )
+            id4 = iom_varid( numror, 'dissl', ldstop = .FALSE. )
+            !
+            IF( MIN( id1, id2, id3, id4 ) > 0 ) THEN      ! fields exist
+               CALL iom_get( numror, jpdom_autoglo, 'en'   , en   , ldxios = lrxios )
+               CALL iom_get( numror, jpdom_autoglo, 'avt_k', avt_k, ldxios = lrxios )
+               CALL iom_get( numror, jpdom_autoglo, 'avm_k', avm_k, ldxios = lrxios )
+               CALL iom_get( numror, jpdom_autoglo, 'dissl', dissl, ldxios = lrxios )
+            ELSE                                          ! start TKE from rest
+               IF(lwp) WRITE(numout,*)
+               IF(lwp) WRITE(numout,*) '   ==>>>   previous run without TKE scheme, set en to background values'
+               en   (:,:,:) = rn_emin * wmask(:,:,:)
+               dissl(:,:,:) = 1.e-12_wp
+               ! avt_k, avm_k already set to the background value in zdf_phy_init
+            ENDIF
+         ELSE                                   !* Start from rest
+            IF(lwp) WRITE(numout,*)
+            IF(lwp) WRITE(numout,*) '   ==>>>   start from rest: set en to the background value'
+            en   (:,:,:) = rn_emin * wmask(:,:,:)
+            dissl(:,:,:) = 1.e-12_wp
+            ! avt_k, avm_k already set to the background value in zdf_phy_init
+         ENDIF
+         !
+      ELSEIF( TRIM(cdrw) == 'WRITE' ) THEN   ! Create restart file
+         !                                   ! -------------------
+         IF(lwp) WRITE(numout,*) '---- tke_rst ----'
+         IF( lwxios ) CALL iom_swap(      cwxios_context          ) 
+         CALL iom_rstput( kt, nitrst, numrow, 'en'   , en   , ldxios = lwxios )
+         CALL iom_rstput( kt, nitrst, numrow, 'avt_k', avt_k, ldxios = lwxios )
+         CALL iom_rstput( kt, nitrst, numrow, 'avm_k', avm_k, ldxios = lwxios )
+         CALL iom_rstput( kt, nitrst, numrow, 'dissl', dissl, ldxios = lwxios )
+         IF( lwxios ) CALL iom_swap(      cxios_context          )
+         !
+      ENDIF
+      !
+   END SUBROUTINE tke_rst
+
+   !!======================================================================
+END MODULE zdftke
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/lib_cray.f90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/lib_cray.f90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/lib_cray.f90	(revision 9570)
@@ -0,0 +1,34 @@
+!  Cray subroutines or functions used by OPA model and possibly 
+!  not found on other platforms.
+!
+!  check their existence
+!  
+!  wheneq
+!!----------------------------------------------------------------------
+!!  OPA 9.0 , LOCEAN-IPSL (2005) 
+!! $Id$ 
+!! This software is governed by the CeCILL licence see modipsl/doc/NEMO_CeCILL.txt 
+!!----------------------------------------------------------------------
+SUBROUTINE lib_cray
+      WRITE(*,*) 'lib_cray: You should not have seen this print! error?'
+END SUBROUTINE lib_cray
+
+SUBROUTINE wheneq ( i, x, j, t, ind, nn )
+        IMPLICIT NONE
+
+        INTEGER , INTENT (  in ) :: i, j
+        INTEGER , INTENT ( out ) :: nn
+        REAL    , INTENT (  in ), DIMENSION (1+(i-1)*j) :: x
+        REAL    , INTENT (  in ) :: t
+        INTEGER , INTENT ( out ), DIMENSION (1+(i-1)*j) :: ind
+        INTEGER :: n, k
+        nn = 0
+        DO n = 1, i
+          k = 1 + (n-1) * j
+          IF ( x ( k) == t ) THEN 
+              nn = nn + 1
+              ind (nn) = k
+          ENDIF
+        END DO 
+
+END SUBROUTINE wheneq
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/lib_fortran.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/lib_fortran.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/lib_fortran.F90	(revision 9570)
@@ -0,0 +1,629 @@
+MODULE lib_fortran
+   !!======================================================================
+   !!                       ***  MODULE  lib_fortran  ***
+   !! Fortran utilities:  includes some low levels fortran functionality
+   !!======================================================================
+   !! History :  3.2  !  2010-05  (M. Dunphy, R. Benshila)  Original code
+   !!            3.4  !  2013-06  (C. Rousset)  add glob_min, glob_max 
+   !!                                           + 3d dim. of input is fexible (jpk, jpl...) 
+   !!            4.0  !  2016-06  (T. Lovato)  double precision global sum by default 
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   glob_sum    : generic interface for global masked summation over
+   !!                 the interior domain for 1 or 2 2D or 3D arrays
+   !!                 it works only for T points
+   !!   SIGN        : generic interface for SIGN to overwrite f95 behaviour
+   !!                 of intrinsinc sign function
+   !!----------------------------------------------------------------------
+   USE par_oce         ! Ocean parameter
+   USE dom_oce         ! ocean domain
+   USE in_out_manager  ! I/O manager
+   USE lib_mpp         ! distributed memory computing
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   glob_sum      ! used in many places (masked with tmask_i)
+   PUBLIC   glob_sum_full ! used in many places (masked with tmask_h, ie only over the halos)
+   PUBLIC   DDPDD         ! also used in closea module
+   PUBLIC   glob_min, glob_max
+#if defined key_nosignedzero
+   PUBLIC SIGN
+#endif
+
+   INTERFACE glob_sum
+      MODULE PROCEDURE glob_sum_1d, glob_sum_2d, glob_sum_3d, &
+         &             glob_sum_2d_a, glob_sum_3d_a
+   END INTERFACE
+   INTERFACE glob_sum_full
+      MODULE PROCEDURE glob_sum_full_2d, glob_sum_full_3d
+   END INTERFACE
+   INTERFACE glob_min
+      MODULE PROCEDURE glob_min_2d, glob_min_3d,glob_min_2d_a, glob_min_3d_a 
+   END INTERFACE
+   INTERFACE glob_max
+      MODULE PROCEDURE glob_max_2d, glob_max_3d,glob_max_2d_a, glob_max_3d_a 
+   END INTERFACE
+
+#if defined key_nosignedzero
+   INTERFACE SIGN
+      MODULE PROCEDURE SIGN_SCALAR, SIGN_ARRAY_1D, SIGN_ARRAY_2D, SIGN_ARRAY_3D,   &
+         &             SIGN_ARRAY_1D_A, SIGN_ARRAY_2D_A, SIGN_ARRAY_3D_A,          &
+         &             SIGN_ARRAY_1D_B, SIGN_ARRAY_2D_B, SIGN_ARRAY_3D_B
+   END INTERFACE
+#endif
+
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO Consortium (2010)
+   !! $Id$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   ! --- SUM ---
+   FUNCTION glob_sum_1d( ptab, kdim )
+      !!----------------------------------------------------------------------
+      !!                  ***  FUNCTION  glob_sum_1d ***
+      !!
+      !! ** Purpose : perform a sum in calling DDPDD routine
+      !!----------------------------------------------------------------------
+      INTEGER , INTENT(in) :: kdim
+      REAL(wp), INTENT(in), DIMENSION(kdim) ::   ptab
+      REAL(wp)                              ::   glob_sum_1d   ! global sum
+      !!
+      COMPLEX(wp)::   ctmp
+      REAL(wp)   ::   ztmp
+      INTEGER    ::   ji   ! dummy loop indices
+      !!-----------------------------------------------------------------------
+      !
+      ztmp = 0.e0
+      ctmp = CMPLX( 0.e0, 0.e0, wp )
+      DO ji = 1, kdim
+         ztmp =  ptab(ji)
+         CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp )
+         END DO
+      IF( lk_mpp )   CALL mpp_sum( ctmp )   ! sum over the global domain
+      glob_sum_1d = REAL(ctmp,wp)
+      !
+   END FUNCTION glob_sum_1d
+
+   FUNCTION glob_sum_2d( ptab )
+      !!----------------------------------------------------------------------
+      !!                  ***  FUNCTION  glob_sum_2d ***
+      !!
+      !! ** Purpose : perform a sum in calling DDPDD routine
+      !!----------------------------------------------------------------------
+      REAL(wp), INTENT(in), DIMENSION(:,:) ::   ptab
+      REAL(wp)                             ::   glob_sum_2d   ! global masked sum
+      !!
+      COMPLEX(wp)::   ctmp
+      REAL(wp)   ::   ztmp
+      INTEGER    ::   ji, jj   ! dummy loop indices
+      !!-----------------------------------------------------------------------
+      !
+      ztmp = 0.e0
+      ctmp = CMPLX( 0.e0, 0.e0, wp )
+      DO jj = 1, jpj
+         DO ji =1, jpi
+         ztmp =  ptab(ji,jj) * tmask_i(ji,jj)
+         CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp )
+         END DO
+      END DO
+      IF( lk_mpp )   CALL mpp_sum( ctmp )   ! sum over the global domain
+      glob_sum_2d = REAL(ctmp,wp)
+      !
+   END FUNCTION glob_sum_2d
+
+
+   FUNCTION glob_sum_3d( ptab )
+      !!----------------------------------------------------------------------
+      !!                  ***  FUNCTION  glob_sum_3d ***
+      !!
+      !! ** Purpose : perform a sum on a 3D array in calling DDPDD routine
+      !!----------------------------------------------------------------------
+      REAL(wp), INTENT(in), DIMENSION(:,:,:) ::   ptab
+      REAL(wp)                               ::   glob_sum_3d   ! global masked sum
+      !!
+      COMPLEX(wp)::   ctmp
+      REAL(wp)   ::   ztmp
+      INTEGER    ::   ji, jj, jk   ! dummy loop indices
+      INTEGER    ::   ijpk ! local variables: size of ptab
+      !!-----------------------------------------------------------------------
+      !
+      ijpk = SIZE(ptab,3)
+      !
+      ztmp = 0.e0
+      ctmp = CMPLX( 0.e0, 0.e0, wp )
+      DO jk = 1, ijpk
+         DO jj = 1, jpj
+            DO ji =1, jpi
+            ztmp =  ptab(ji,jj,jk) * tmask_i(ji,jj)
+            CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp )
+            END DO
+         END DO
+      END DO
+      IF( lk_mpp )   CALL mpp_sum( ctmp )   ! sum over the global domain
+      glob_sum_3d = REAL(ctmp,wp)
+      !
+   END FUNCTION glob_sum_3d
+
+
+   FUNCTION glob_sum_2d_a( ptab1, ptab2 )
+      !!----------------------------------------------------------------------
+      !!                  ***  FUNCTION  glob_sum_2d_a ***
+      !!
+      !! ** Purpose : perform a sum on two 2D arrays in calling DDPDD routine
+      !!----------------------------------------------------------------------
+      REAL(wp), INTENT(in), DIMENSION(:,:) ::   ptab1, ptab2
+      REAL(wp)                             ::   glob_sum_2d_a   ! global masked sum
+      !!
+      COMPLEX(wp)::   ctmp
+      REAL(wp)   ::   ztmp
+      INTEGER    ::   ji, jj   ! dummy loop indices
+      !!-----------------------------------------------------------------------
+      !
+      ztmp = 0.e0
+      ctmp = CMPLX( 0.e0, 0.e0, wp )
+      DO jj = 1, jpj
+         DO ji =1, jpi
+         ztmp =  ptab1(ji,jj) * tmask_i(ji,jj)
+         CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp )
+         ztmp =  ptab2(ji,jj) * tmask_i(ji,jj)
+         CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp )
+         END DO
+      END DO
+      IF( lk_mpp )   CALL mpp_sum( ctmp )   ! sum over the global domain
+      glob_sum_2d_a = REAL(ctmp,wp)
+      !
+   END FUNCTION glob_sum_2d_a
+
+
+   FUNCTION glob_sum_3d_a( ptab1, ptab2 )
+      !!----------------------------------------------------------------------
+      !!                  ***  FUNCTION  glob_sum_3d_a ***
+      !!
+      !! ** Purpose : perform a sum on two 3D array in calling DDPDD routine
+      !!----------------------------------------------------------------------
+      REAL(wp), INTENT(in), DIMENSION(:,:,:) ::   ptab1, ptab2
+      REAL(wp)                               ::   glob_sum_3d_a   ! global masked sum
+      !!
+      COMPLEX(wp)::   ctmp
+      REAL(wp)   ::   ztmp
+      INTEGER    ::   ji, jj, jk   ! dummy loop indices
+      INTEGER    ::   ijpk ! local variables: size of ptab
+      !!-----------------------------------------------------------------------
+      !
+      ijpk = SIZE(ptab1,3)
+      !
+      ztmp = 0.e0
+      ctmp = CMPLX( 0.e0, 0.e0, wp )
+      DO jk = 1, ijpk
+         DO jj = 1, jpj
+            DO ji = 1, jpi
+               ztmp =  ptab1(ji,jj,jk) * tmask_i(ji,jj)
+               CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp )
+               ztmp =  ptab2(ji,jj,jk) * tmask_i(ji,jj)
+               CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp )
+            END DO
+         END DO    
+      END DO
+      IF( lk_mpp )   CALL mpp_sum( ctmp )   ! sum over the global domain
+      glob_sum_3d_a = REAL(ctmp,wp)
+      !
+   END FUNCTION glob_sum_3d_a   
+
+   FUNCTION glob_sum_full_2d( ptab )
+      !!----------------------------------------------------------------------
+      !!                  ***  FUNCTION  glob_sum_full_2d ***
+      !!
+      !! ** Purpose : perform a sum in calling DDPDD routine
+      !!----------------------------------------------------------------------
+      REAL(wp), INTENT(in), DIMENSION(:,:) ::   ptab
+      REAL(wp)                             ::   glob_sum_full_2d   ! global sum (nomask)
+      !!
+      COMPLEX(wp)::   ctmp
+      REAL(wp)   ::   ztmp
+      INTEGER    ::   ji, jj   ! dummy loop indices
+      !!-----------------------------------------------------------------------
+      !
+      ztmp = 0.e0
+      ctmp = CMPLX( 0.e0, 0.e0, wp )
+      DO jj = 1, jpj
+         DO ji =1, jpi
+         ztmp =  ptab(ji,jj) * tmask_h(ji,jj) 
+         CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp )
+         END DO
+      END DO
+      IF( lk_mpp )   CALL mpp_sum( ctmp )   ! sum over the global domain
+      glob_sum_full_2d = REAL(ctmp,wp)
+      !
+   END FUNCTION glob_sum_full_2d
+
+   FUNCTION glob_sum_full_3d( ptab )
+      !!----------------------------------------------------------------------
+      !!                  ***  FUNCTION  glob_sum_full_3d ***
+      !!
+      !! ** Purpose : perform a sum on a 3D array in calling DDPDD routine
+      !!----------------------------------------------------------------------
+      REAL(wp), INTENT(in), DIMENSION(:,:,:) ::   ptab
+      REAL(wp)                               ::   glob_sum_full_3d   ! global sum (nomask)
+      !!
+      COMPLEX(wp)::   ctmp
+      REAL(wp)   ::   ztmp
+      INTEGER    ::   ji, jj, jk   ! dummy loop indices
+      INTEGER    ::   ijpk ! local variables: size of ptab
+      !!-----------------------------------------------------------------------
+      !
+      ijpk = SIZE(ptab,3)
+      !
+      ztmp = 0.e0
+      ctmp = CMPLX( 0.e0, 0.e0, wp )
+      DO jk = 1, ijpk
+         DO jj = 1, jpj
+            DO ji =1, jpi
+            ztmp =  ptab(ji,jj,jk) * tmask_h(ji,jj)
+            CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp )
+            END DO
+         END DO
+      END DO
+      IF( lk_mpp )   CALL mpp_sum( ctmp )   ! sum over the global domain
+      glob_sum_full_3d = REAL(ctmp,wp)
+      !
+   END FUNCTION glob_sum_full_3d
+
+   ! --- MIN ---
+   FUNCTION glob_min_2d( ptab ) 
+      !!-----------------------------------------------------------------------
+      !!                  ***  FUNCTION  glob_min_2D  ***
+      !!
+      !! ** Purpose : perform a masked min on the inner global domain of a 2D array
+      !!-----------------------------------------------------------------------
+      REAL(wp), INTENT(in), DIMENSION(:,:) ::   ptab          ! input 2D array
+      REAL(wp)                             ::   glob_min_2d   ! global masked min
+      !!-----------------------------------------------------------------------
+      !
+      glob_min_2d = MINVAL( ptab(:,:)*tmask_i(:,:) )
+      IF( lk_mpp )   CALL mpp_min( glob_min_2d )
+      !
+   END FUNCTION glob_min_2d
+ 
+   FUNCTION glob_min_3d( ptab ) 
+      !!-----------------------------------------------------------------------
+      !!                  ***  FUNCTION  glob_min_3D  ***
+      !!
+      !! ** Purpose : perform a masked min on the inner global domain of a 3D array
+      !!-----------------------------------------------------------------------
+      REAL(wp), INTENT(in), DIMENSION(:,:,:) ::   ptab          ! input 3D array
+      REAL(wp)                               ::   glob_min_3d   ! global masked min
+      !!
+      INTEGER :: jk
+      INTEGER :: ijpk ! local variable: size of the 3d dimension of ptab
+      !!-----------------------------------------------------------------------
+      !
+      ijpk = SIZE(ptab,3)
+      !
+      glob_min_3d = MINVAL( ptab(:,:,1)*tmask_i(:,:) )
+      DO jk = 2, ijpk
+         glob_min_3d = MIN( glob_min_3d, MINVAL( ptab(:,:,jk)*tmask_i(:,:) ) )
+      END DO
+      IF( lk_mpp )   CALL mpp_min( glob_min_3d )
+      !
+   END FUNCTION glob_min_3d
+
+
+   FUNCTION glob_min_2d_a( ptab1, ptab2 ) 
+      !!-----------------------------------------------------------------------
+      !!                  ***  FUNCTION  glob_min_2D _a ***
+      !!
+      !! ** Purpose : perform a masked min on the inner global domain of two 2D array
+      !!-----------------------------------------------------------------------
+      REAL(wp), INTENT(in), DIMENSION(:,:) ::   ptab1, ptab2    ! input 2D array
+      REAL(wp)            , DIMENSION(2)   ::   glob_min_2d_a   ! global masked min
+      !!-----------------------------------------------------------------------
+      !             
+      glob_min_2d_a(1) = MINVAL( ptab1(:,:)*tmask_i(:,:) )
+      glob_min_2d_a(2) = MINVAL( ptab2(:,:)*tmask_i(:,:) )
+      IF( lk_mpp )   CALL mpp_min( glob_min_2d_a, 2 )
+      !
+   END FUNCTION glob_min_2d_a
+ 
+ 
+   FUNCTION glob_min_3d_a( ptab1, ptab2 ) 
+      !!-----------------------------------------------------------------------
+      !!                  ***  FUNCTION  glob_min_3D_a ***
+      !!
+      !! ** Purpose : perform a masked min on the inner global domain of two 3D array
+      !!-----------------------------------------------------------------------
+      REAL(wp), INTENT(in), DIMENSION(:,:,:) ::   ptab1, ptab2    ! input 3D array
+      REAL(wp)            , DIMENSION(2)     ::   glob_min_3d_a   ! global masked min
+      !!
+      INTEGER :: jk
+      INTEGER :: ijpk ! local variable: size of the 3d dimension of ptab
+      !!-----------------------------------------------------------------------
+      !
+      ijpk = SIZE(ptab1,3)
+      !
+      glob_min_3d_a(1) = MINVAL( ptab1(:,:,1)*tmask_i(:,:) )
+      glob_min_3d_a(2) = MINVAL( ptab2(:,:,1)*tmask_i(:,:) )
+      DO jk = 2, ijpk
+         glob_min_3d_a(1) = MIN( glob_min_3d_a(1), MINVAL( ptab1(:,:,jk)*tmask_i(:,:) ) )
+         glob_min_3d_a(2) = MIN( glob_min_3d_a(2), MINVAL( ptab2(:,:,jk)*tmask_i(:,:) ) )
+      END DO
+      IF( lk_mpp )   CALL mpp_min( glob_min_3d_a, 2 )
+      !
+   END FUNCTION glob_min_3d_a
+
+   ! --- MAX ---
+   FUNCTION glob_max_2d( ptab ) 
+      !!-----------------------------------------------------------------------
+      !!                  ***  FUNCTION  glob_max_2D  ***
+      !!
+      !! ** Purpose : perform a masked max on the inner global domain of a 2D array
+      !!-----------------------------------------------------------------------
+      REAL(wp), INTENT(in), DIMENSION(:,:) ::   ptab          ! input 2D array
+      REAL(wp)                             ::   glob_max_2d   ! global masked max
+      !!-----------------------------------------------------------------------
+      !
+      glob_max_2d = MAXVAL( ptab(:,:)*tmask_i(:,:) )
+      IF( lk_mpp )   CALL mpp_max( glob_max_2d )
+      !
+   END FUNCTION glob_max_2d
+ 
+   FUNCTION glob_max_3d( ptab ) 
+      !!-----------------------------------------------------------------------
+      !!                  ***  FUNCTION  glob_max_3D  ***
+      !!
+      !! ** Purpose : perform a masked max on the inner global domain of a 3D array
+      !!-----------------------------------------------------------------------
+      REAL(wp), INTENT(in), DIMENSION(:,:,:) ::   ptab          ! input 3D array
+      REAL(wp)                               ::   glob_max_3d   ! global masked max
+      !!
+      INTEGER :: jk
+      INTEGER :: ijpk ! local variable: size of the 3d dimension of ptab
+      !!-----------------------------------------------------------------------
+      !
+      ijpk = SIZE(ptab,3)
+      !
+      glob_max_3d = MAXVAL( ptab(:,:,1)*tmask_i(:,:) )
+      DO jk = 2, ijpk
+         glob_max_3d = MAX( glob_max_3d, MAXVAL( ptab(:,:,jk)*tmask_i(:,:) ) )
+      END DO
+      IF( lk_mpp )   CALL mpp_max( glob_max_3d )
+      !
+   END FUNCTION glob_max_3d
+
+
+   FUNCTION glob_max_2d_a( ptab1, ptab2 ) 
+      !!-----------------------------------------------------------------------
+      !!                  ***  FUNCTION  glob_max_2D _a ***
+      !!
+      !! ** Purpose : perform a masked max on the inner global domain of two 2D array
+      !!-----------------------------------------------------------------------
+      REAL(wp), INTENT(in), DIMENSION(:,:) ::   ptab1, ptab2    ! input 2D array
+      REAL(wp)            , DIMENSION(2)   ::   glob_max_2d_a   ! global masked max
+      !!-----------------------------------------------------------------------
+      !             
+      glob_max_2d_a(1) = MAXVAL( ptab1(:,:)*tmask_i(:,:) )
+      glob_max_2d_a(2) = MAXVAL( ptab2(:,:)*tmask_i(:,:) )
+      IF( lk_mpp )   CALL mpp_max( glob_max_2d_a, 2 )
+      !
+   END FUNCTION glob_max_2d_a
+ 
+ 
+   FUNCTION glob_max_3d_a( ptab1, ptab2 ) 
+      !!-----------------------------------------------------------------------
+      !!                  ***  FUNCTION  glob_max_3D_a ***
+      !!
+      !! ** Purpose : perform a masked max on the inner global domain of two 3D array
+      !!-----------------------------------------------------------------------
+      REAL(wp), INTENT(in), DIMENSION(:,:,:) ::   ptab1, ptab2    ! input 3D array
+      REAL(wp)            , DIMENSION(2)     ::   glob_max_3d_a   ! global masked max
+      !!
+      INTEGER :: jk
+      INTEGER :: ijpk ! local variable: size of the 3d dimension of ptab
+      !!-----------------------------------------------------------------------
+      !
+      ijpk = SIZE(ptab1,3)
+      !
+      glob_max_3d_a(1) = MAXVAL( ptab1(:,:,1)*tmask_i(:,:) )
+      glob_max_3d_a(2) = MAXVAL( ptab2(:,:,1)*tmask_i(:,:) )
+      DO jk = 2, ijpk
+         glob_max_3d_a(1) = MAX( glob_max_3d_a(1), MAXVAL( ptab1(:,:,jk)*tmask_i(:,:) ) )
+         glob_max_3d_a(2) = MAX( glob_max_3d_a(2), MAXVAL( ptab2(:,:,jk)*tmask_i(:,:) ) )
+      END DO
+      IF( lk_mpp )   CALL mpp_max( glob_max_3d_a, 2 )
+      !
+   END FUNCTION glob_max_3d_a
+
+
+   SUBROUTINE DDPDD( ydda, yddb )
+      !!----------------------------------------------------------------------
+      !!               ***  ROUTINE DDPDD ***
+      !!
+      !! ** Purpose : Add a scalar element to a sum
+      !!
+      !!
+      !! ** Method  : The code uses the compensated summation with doublet
+      !!              (sum,error) emulated useing complex numbers. ydda is the
+      !!               scalar to add to the summ yddb
+      !!
+      !! ** Action  : This does only work for MPI.
+      !!
+      !! References : Using Acurate Arithmetics to Improve Numerical
+      !!              Reproducibility and Sability in Parallel Applications
+      !!              Yun HE and Chris H. Q. DING, Journal of Supercomputing 18, 259-277, 2001
+      !!----------------------------------------------------------------------
+      COMPLEX(wp), INTENT(in   ) ::   ydda
+      COMPLEX(wp), INTENT(inout) ::   yddb
+      !
+      REAL(wp) :: zerr, zt1, zt2  ! local work variables
+      !!-----------------------------------------------------------------------
+      !
+      ! Compute ydda + yddb using Knuth's trick.
+      zt1  = REAL(ydda) + REAL(yddb)
+      zerr = zt1 - REAL(ydda)
+      zt2  = ( (REAL(yddb) - zerr) + (REAL(ydda) - (zt1 - zerr)) )   &
+         &   + AIMAG(ydda)         + AIMAG(yddb)
+      !
+      ! The result is t1 + t2, after normalization.
+      yddb = CMPLX( zt1 + zt2, zt2 - ((zt1 + zt2) - zt1), wp )
+      !
+   END SUBROUTINE DDPDD
+
+#if defined key_nosignedzero
+   !!----------------------------------------------------------------------
+   !!   'key_nosignedzero'                                         F90 SIGN
+   !!----------------------------------------------------------------------
+
+   FUNCTION SIGN_SCALAR( pa, pb )
+      !!-----------------------------------------------------------------------
+      !!                  ***  FUNCTION SIGN_SCALAR  ***
+      !!
+      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
+      !!-----------------------------------------------------------------------
+      REAL(wp) :: pa,pb          ! input
+      REAL(wp) :: SIGN_SCALAR    ! result
+      !!-----------------------------------------------------------------------
+      IF ( pb >= 0.e0) THEN   ;   SIGN_SCALAR = ABS(pa)
+      ELSE                    ;   SIGN_SCALAR =-ABS(pa)
+      ENDIF
+   END FUNCTION SIGN_SCALAR
+
+
+   FUNCTION SIGN_ARRAY_1D( pa, pb )
+      !!-----------------------------------------------------------------------
+      !!                  ***  FUNCTION SIGN_ARRAY_1D  ***
+      !!
+      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
+      !!-----------------------------------------------------------------------
+      REAL(wp) :: pa,pb(:)                   ! input
+      REAL(wp) :: SIGN_ARRAY_1D(SIZE(pb,1))  ! result
+      !!-----------------------------------------------------------------------
+      WHERE ( pb >= 0.e0 )   ;   SIGN_ARRAY_1D = ABS(pa)
+      ELSEWHERE              ;   SIGN_ARRAY_1D =-ABS(pa)
+      END WHERE
+   END FUNCTION SIGN_ARRAY_1D
+
+
+   FUNCTION SIGN_ARRAY_2D(pa,pb)
+      !!-----------------------------------------------------------------------
+      !!                  ***  FUNCTION SIGN_ARRAY_2D  ***
+      !!
+      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
+      !!-----------------------------------------------------------------------
+      REAL(wp) :: pa,pb(:,:)      ! input
+      REAL(wp) :: SIGN_ARRAY_2D(SIZE(pb,1),SIZE(pb,2))  ! result
+      !!-----------------------------------------------------------------------
+      WHERE ( pb >= 0.e0 )   ;   SIGN_ARRAY_2D = ABS(pa)
+      ELSEWHERE              ;   SIGN_ARRAY_2D =-ABS(pa)
+      END WHERE
+   END FUNCTION SIGN_ARRAY_2D
+
+   FUNCTION SIGN_ARRAY_3D(pa,pb)
+      !!-----------------------------------------------------------------------
+      !!                  ***  FUNCTION SIGN_ARRAY_3D  ***
+      !!
+      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
+      !!-----------------------------------------------------------------------
+      REAL(wp) :: pa,pb(:,:,:)      ! input
+      REAL(wp) :: SIGN_ARRAY_3D(SIZE(pb,1),SIZE(pb,2),SIZE(pb,3))  ! result
+      !!-----------------------------------------------------------------------
+      WHERE ( pb >= 0.e0 )   ;   SIGN_ARRAY_3D = ABS(pa)
+      ELSEWHERE              ;   SIGN_ARRAY_3D =-ABS(pa)
+      END WHERE
+   END FUNCTION SIGN_ARRAY_3D
+
+
+   FUNCTION SIGN_ARRAY_1D_A(pa,pb)
+      !!-----------------------------------------------------------------------
+      !!                  ***  FUNCTION SIGN_ARRAY_1D_A  ***
+      !!
+      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
+      !!-----------------------------------------------------------------------
+      REAL(wp) :: pa(:),pb(:)      ! input
+      REAL(wp) :: SIGN_ARRAY_1D_A(SIZE(pb,1))  ! result
+      !!-----------------------------------------------------------------------
+      WHERE ( pb >= 0.e0 )   ;   SIGN_ARRAY_1D_A = ABS(pa)
+      ELSEWHERE              ;   SIGN_ARRAY_1D_A =-ABS(pa)
+      END WHERE
+   END FUNCTION SIGN_ARRAY_1D_A
+
+
+   FUNCTION SIGN_ARRAY_2D_A(pa,pb)
+      !!-----------------------------------------------------------------------
+      !!                  ***  FUNCTION SIGN_ARRAY_2D_A  ***
+      !!
+      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
+      !!-----------------------------------------------------------------------
+      REAL(wp) :: pa(:,:),pb(:,:)      ! input
+      REAL(wp) :: SIGN_ARRAY_2D_A(SIZE(pb,1),SIZE(pb,2))  ! result
+      !!-----------------------------------------------------------------------
+      WHERE ( pb >= 0.e0 )   ;   SIGN_ARRAY_2D_A = ABS(pa)
+      ELSEWHERE              ;   SIGN_ARRAY_2D_A =-ABS(pa)
+      END WHERE
+   END FUNCTION SIGN_ARRAY_2D_A
+
+
+   FUNCTION SIGN_ARRAY_3D_A(pa,pb)
+      !!-----------------------------------------------------------------------
+      !!                  ***  FUNCTION SIGN_ARRAY_3D_A  ***
+      !!
+      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
+      !!-----------------------------------------------------------------------
+      REAL(wp) :: pa(:,:,:),pb(:,:,:)  ! input
+      REAL(wp) :: SIGN_ARRAY_3D_A(SIZE(pb,1),SIZE(pb,2),SIZE(pb,3)) ! result
+      !!-----------------------------------------------------------------------
+      WHERE ( pb >= 0.e0 )   ;   SIGN_ARRAY_3D_A = ABS(pa)
+      ELSEWHERE              ;   SIGN_ARRAY_3D_A =-ABS(pa)
+      END WHERE
+   END FUNCTION SIGN_ARRAY_3D_A
+
+
+   FUNCTION SIGN_ARRAY_1D_B(pa,pb)
+      !!-----------------------------------------------------------------------
+      !!                  ***  FUNCTION SIGN_ARRAY_1D_B  ***
+      !!
+      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
+      !!-----------------------------------------------------------------------
+      REAL(wp) :: pa(:),pb      ! input
+      REAL(wp) :: SIGN_ARRAY_1D_B(SIZE(pa,1))  ! result
+      !!-----------------------------------------------------------------------
+      IF( pb >= 0.e0 ) THEN   ;   SIGN_ARRAY_1D_B = ABS(pa)
+      ELSE                    ;   SIGN_ARRAY_1D_B =-ABS(pa)
+      ENDIF
+   END FUNCTION SIGN_ARRAY_1D_B
+
+
+   FUNCTION SIGN_ARRAY_2D_B(pa,pb)
+      !!-----------------------------------------------------------------------
+      !!                  ***  FUNCTION SIGN_ARRAY_2D_B  ***
+      !!
+      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
+      !!-----------------------------------------------------------------------
+      REAL(wp) :: pa(:,:),pb      ! input
+      REAL(wp) :: SIGN_ARRAY_2D_B(SIZE(pa,1),SIZE(pa,2))  ! result
+      !!-----------------------------------------------------------------------
+      IF( pb >= 0.e0 ) THEN   ;   SIGN_ARRAY_2D_B = ABS(pa)
+      ELSE                    ;   SIGN_ARRAY_2D_B =-ABS(pa)
+      ENDIF
+   END FUNCTION SIGN_ARRAY_2D_B
+
+
+   FUNCTION SIGN_ARRAY_3D_B(pa,pb)
+      !!-----------------------------------------------------------------------
+      !!                  ***  FUNCTION SIGN_ARRAY_3D_B  ***
+      !!
+      !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function
+      !!-----------------------------------------------------------------------
+      REAL(wp) :: pa(:,:,:),pb      ! input
+      REAL(wp) :: SIGN_ARRAY_3D_B(SIZE(pa,1),SIZE(pa,2),SIZE(pa,3))  ! result
+      !!-----------------------------------------------------------------------
+      IF( pb >= 0.e0 ) THEN   ;   SIGN_ARRAY_3D_B = ABS(pa)
+      ELSE                    ;   SIGN_ARRAY_3D_B =-ABS(pa)
+      ENDIF
+   END FUNCTION SIGN_ARRAY_3D_B
+#endif
+
+   !!======================================================================
+END MODULE lib_fortran
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/module_example
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/module_example	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/module_example	(revision 9570)
@@ -0,0 +1,194 @@
+MODULE exampl
+   !!======================================================================
+   !!                       ***  MODULE  exampl  ***
+   !! Ocean physics:  brief description of the purpose of the module
+   !!                 (please no more than 2 lines)
+   !!======================================================================
+   !! History : 3.0  !  2008-06  (Author Names)  Original code
+   !!            -   !  2008-08  (Author names)  brief description of modifications
+   !!           3.3  !  2010-11  (Author names)        -              -
+   !!----------------------------------------------------------------------
+#if defined key_example
+   !!----------------------------------------------------------------------
+   !!   'key_example'  :                brief description of the key option
+   !!----------------------------------------------------------------------
+   !!   exa_mpl       : list of module subroutine (caution, never use the
+   !!   exa_mpl_init  : name of the module for a routine)
+   !!   exa_mpl_stp   : Please try to use 3 letter block for routine names
+   !!----------------------------------------------------------------------
+   USE module_name1   ! brief description of the used module
+   USE module_name2   ! ....
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   exa_mpl        ! routine called in xxx.F90 module
+   PUBLIC   exa_mpl_init   ! routine called in nemogcm.F90 module
+
+   TYPE ::   FLD_E                !: Structure type definition
+      CHARACTER(lc) ::   clname      ! clname description (default length, lc, is 256, see par_kind.F90)
+      INTEGER       ::   nfreqh      ! nfreqh description 
+   END TYPE FLD_E 
+
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   var1         !: var1 description. CAUTION always use !: to describe
+   !                                                          !  a PUBLIC variable: simplify its search : 
+   !                                                          !  grep var1 *90 | grep '!:'
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   var2, var2   !: several variable on a same line OK, but 
+   !                                                          !  DO NOT use continuation lines in declaration
+
+   !                               !!* namelist nam_xxx *
+   LOGICAL   ::   ln_opt = .TRUE.   ! give the default value of each namelist parameter
+   CHARACTER ::   cn_tex = 'T'      ! short description  of the variable
+   INTEGER   ::   nn_opt = 1        ! please respect the DOCTOR norm for namelist variable
+   REAL(wp)  ::   rn_var = 2._wp    ! (it becomes easy to identify them in the code)
+   TYPE(FLD) ::   sn_ex             ! structure
+
+   INTEGER                          ::   nint    ! nint  description (local permanent variable)
+   REAL(wp)                         ::   var     ! var         -                -
+   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   array   ! array       -                -
+
+   !! * Substitutions
+#  include "exampl_substitute.h90"
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO Consortium (2010)
+   !! $Id$ 
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   INTEGER FUNCTION exa_mpl_alloc()
+      !!----------------------------------------------------------------------
+      !!                ***  FUNCTION exa_mpl_alloc  ***
+      !!----------------------------------------------------------------------
+      ALLOCATE( array(jpi,jpj,jpk) , STAT= exa_mpl_alloc )   ! Module array                                                                
+      !
+      IF( lk_mpp             )   CALL mpp_sum ( exa_mpl_alloc )
+      IF( exa_mpl_alloc /= 0 )   CALL ctl_warn('exa_mpl_alloc: failed to allocate arrays')
+      !
+   END FUNCTION exa_mpl_alloc
+   
+
+   SUBROUTINE exa_mpl( kt, pvar1, pvar2, ptab )
+      !!----------------------------------------------------------------------
+      !!                    ***  ROUTINE exa_mpl  ***
+      !!
+      !! ** Purpose :   Brief description of the routine
+      !!
+      !! ** Method  :   description of the methodoloy used to achieve the
+      !!                objectives of the routine. Be as clear as possible!
+      !!
+      !! ** Action  : - first action (share memory array/varible modified
+      !!                in this routine
+      !!              - second action .....
+      !!              - .....
+      !!
+      !! References :   Author et al., Short_name_review, Year
+      !!                Give references if exist otherwise suppress these lines
+      !!----------------------------------------------------------------------
+      INTEGER , INTENT(in   )                     ::   kt      ! short description 
+      INTEGER , INTENT(inout)                     ::   pvar1   !   -         -
+      REAL(wp), INTENT(  out)                     ::   pvar2   !   -         -
+      REAL(wp), INTENT(  out), DIMENSION(jpi,jpj) ::   pvar2   !   -         -
+      !!
+      INTEGER  ::   ji, jj, jk       ! dummy loop arguments  (DOCTOR : start with j, but not jp)
+      INTEGER  ::   itoto, itata     ! temporary integers    (DOCTOR : start with i
+      REAL(wp) ::   zmlmin, zbbrau   ! temporary scalars     (DOCTOR : start with z)
+      REAL(wp) ::   zfact1, zfact2   ! do not use continuation lines in declaration
+      REAL(wp), DIMENSION(jpi,jpj) ::   zwrk_2d   ! 2D workspace
+      !!--------------------------------------------------------------------
+      !
+      IF( kt == nit000  )   CALL exa_mpl_init    ! Initialization (first time-step only)
+
+      zmlmin = 1.e-8                             ! Local constant initialization
+      zbbrau =  .5 * ebb / rau0
+      zfact1 = -.5 * rdt * efave
+      zfact2 = 1.5 * rdt * ediss
+
+      SELECT CASE ( npdl )                       ! short description of the action
+      !
+      CASE ( 0 )                                      ! describe case 1
+         DO jk = 2, jpkm1
+            DO jj = 2, jpjm1
+               DO ji = fs_2, fs_jpim1   ! vector opt.
+                  avm(ji,jj,jk) = ....
+               END DO
+            END DO
+         END DO
+         !
+      CASE ( 1 )                                      ! describe case 2
+         DO jk = 2, jpkm1
+            DO jj = 2, jpjm1
+               DO ji = fs_2, fs_jpim1   ! vector opt.
+                  avm(ji,jj,jk) = ...
+               END DO
+            END DO
+         END DO
+         !
+      END SELECT
+      !
+      CALL lbc_lnk( avm, 'T', 1. )              ! Lateral boundary conditions (unchanged sign)
+      !
+   END SUBROUTINE exa_mpl
+
+
+   SUBROUTINE exa_mpl_init
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE exa_mpl_init  ***
+      !!                   
+      !! ** Purpose :   initialization of ....
+      !!
+      !! ** Method  :   blah blah blah ...
+      !!
+      !! ** input   :   Namlist namexa
+      !!
+      !! ** Action  :   ...  
+      !!----------------------------------------------------------------------
+      INTEGER ::   ji, jj, jk, jit   ! dummy loop indices
+      INTEGER  ::   ios              ! Local integer output status for namelist read
+      !!
+      NAMELIST/namexa/ exa_v1, exa_v2, nexa_0, sn_ex     
+      !!----------------------------------------------------------------------
+      !
+      REWIND( numnam_ref )              ! Namelist namexa in reference namelist : Example
+      READ  ( numnam_ref, namexa, IOSTAT = ios, ERR = 901)
+901   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namexa in reference namelist', lwp )
+      !
+      REWIND( numnam_cfg )              ! Namelist namexa in configuration namelist : Example
+      READ  ( numnam_cfg, namexa, IOSTAT = ios, ERR = 902 )
+902   IF( ios >  0 ) CALL ctl_nam ( ios , 'namexa in configuration namelist', lwp )
+   ! Output namelist for control
+      WRITE ( numond, namexa )
+      !
+      IF(lwp) THEN                              ! Control print
+         WRITE(numout,*)
+         WRITE(numout,*) 'exa_mpl_init : example '
+         WRITE(numout,*) '~~~~~~~~~~~~'
+         WRITE(numout,*) '   Namelist namexa : set example parameters'
+         WRITE(numout,*) '      brief desciption               exa_v1  = ', exa_v1
+         WRITE(numout,*) '      brief desciption               exa_v2  = ', exa_v2
+         WRITE(numout,*) '      brief desciption               nexa_0  = ', nexa_0
+         WRITE(numout,*) '      brief desciption          sn_ex%clname = ', sn_ex%clname
+         WRITE(numout,*) '      brief desciption          sn_ex%nfreqh = ', sn_ex%nfreqh
+      ENDIF
+      !
+      !                              ! allocate exa_mpl arrays      
+      IF( exa_mpl_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'exa_mpl_init : unable to allocate arrays' )
+      !                              ! Parameter control
+      IF( ln_opt      )   CALL ctl_stop( 'exa_mpl_init: this work and option xxx are incompatible'   )
+      IF( nn_opt == 2 )   CALL ctl_warn( 'exa_mpl_init: this work and option yyy may cause problems' )
+      !
+   END SUBROUTINE exa_mpl_init
+
+#else
+   !!----------------------------------------------------------------------
+   !!   Default option :                                         NO example
+   !!----------------------------------------------------------------------
+CONTAINS
+   SUBROUTINE exa_mpl( kt, pvar1, pvar2, ptab )              ! Empty routine
+      REAL::   ptab(:,:)
+      WRITE(*,*) 'exa_mpl: You should not have seen this print! error?', kt, pvar1, pvar2, ptab(1,1)
+   END SUBROUTINE exa_mpl
+#endif
+
+   !!======================================================================
+END MODULE exampl
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/nemo.f90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/nemo.f90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/nemo.f90	(revision 9570)
@@ -0,0 +1,21 @@
+PROGRAM nemo
+   !!======================================================================
+   !!                     ***  PROGRAM nemo  ***
+   !!
+   !! ** Purpose :   encapsulate nemo_gcm so that it can also be called
+   !!              together with the linear tangent and adjoint models
+   !!======================================================================
+   !! History :   OPA  ! 2001-02  (M. Imbard, A. Weaver)  Original code
+   !!   NEMO      1.0  ! 2003-10  (G. Madec) F90
+   !!----------------------------------------------------------------------
+   USE nemogcm   ! NEMO system   (nemo_gcm routine)
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO Consortium (2010)
+   !! $Id$ 
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+   !
+   CALL nemo_gcm           ! NEMO direct code
+   ! 
+   !!======================================================================
+END PROGRAM nemo
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/nemogcm.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/nemogcm.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/nemogcm.F90	(revision 9570)
@@ -0,0 +1,615 @@
+MODULE nemogcm
+   !!======================================================================
+   !!                       ***  MODULE nemogcm   ***
+   !! Ocean system   : NEMO GCM (ocean dynamics, on-line tracers, biochemistry and sea-ice)
+   !!======================================================================
+   !! History :  OPA  ! 1990-10  (C. Levy, G. Madec)  Original code
+   !!            7.0  ! 1991-11  (M. Imbard, C. Levy, G. Madec)
+   !!            7.1  ! 1993-03  (M. Imbard, C. Levy, G. Madec, O. Marti, M. Guyon, A. Lazar,
+   !!                             P. Delecluse, C. Perigaud, G. Caniaux, B. Colot, C. Maes) release 7.1
+   !!             -   ! 1992-06  (L.Terray)  coupling implementation
+   !!             -   ! 1993-11  (M.A. Filiberti) IGLOO sea-ice
+   !!            8.0  ! 1996-03  (M. Imbard, C. Levy, G. Madec, O. Marti, M. Guyon, A. Lazar,
+   !!                             P. Delecluse, L.Terray, M.A. Filiberti, J. Vialar, A.M. Treguier, M. Levy) release 8.0
+   !!            8.1  ! 1997-06  (M. Imbard, G. Madec)
+   !!            8.2  ! 1999-11  (M. Imbard, H. Goosse)  LIM sea-ice model
+   !!                 ! 1999-12  (V. Thierry, A-M. Treguier, M. Imbard, M-A. Foujols)  OPEN-MP
+   !!                 ! 2000-07  (J-M Molines, M. Imbard)  Open Boundary Conditions  (CLIPPER)
+   !!   NEMO     1.0  ! 2002-08  (G. Madec)  F90: Free form and modules
+   !!             -   ! 2004-06  (R. Redler, NEC CCRLE, Germany) add OASIS[3/4] coupled interfaces
+   !!             -   ! 2004-08  (C. Talandier) New trends organization
+   !!             -   ! 2005-06  (C. Ethe) Add the 1D configuration possibility
+   !!             -   ! 2005-11  (V. Garnier) Surface pressure gradient organization
+   !!             -   ! 2006-03  (L. Debreu, C. Mazauric)  Agrif implementation
+   !!             -   ! 2006-04  (G. Madec, R. Benshila)  Step reorganization
+   !!             -   ! 2007-07  (J. Chanut, A. Sellar) Unstructured open boundaries (BDY)
+   !!            3.2  ! 2009-08  (S. Masson)  open/write in the listing file in mpp
+   !!            3.3  ! 2010-05  (K. Mogensen, A. Weaver, M. Martin, D. Lea) Assimilation interface
+   !!             -   ! 2010-10  (C. Ethe, G. Madec) reorganisation of initialisation phase
+   !!            3.3.1! 2011-01  (A. R. Porter, STFC Daresbury) dynamical allocation
+   !!             -   ! 2011-11  (C. Harris) decomposition changes for running with CICE
+   !!            3.6  ! 2012-05  (C. Calone, J. Simeon, G. Madec, C. Ethe) Add grid coarsening 
+   !!             -   ! 2014-12  (G. Madec) remove KPP scheme and cross-land advection (cla)
+   !!            4.0  ! 2016-10  (G. Madec, S. Flavoni)  domain configuration / user defined interface
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   nemo_gcm      : solve ocean dynamics, tracer, biogeochemistry and/or sea-ice
+   !!   nemo_init     : initialization of the NEMO system
+   !!   nemo_ctl      : initialisation of the contol print
+   !!   nemo_closefile: close remaining open files
+   !!   nemo_alloc    : dynamical allocation
+   !!----------------------------------------------------------------------
+   USE step_oce       ! module used in the ocean time stepping module (step.F90)
+   USE phycst         ! physical constant                  (par_cst routine)
+   USE domain         ! domain initialization   (dom_init & dom_cfg routines)
+   USE closea         ! treatment of closed seas (for ln_closea)
+   USE usrdef_nam     ! user defined configuration
+   USE tideini        ! tidal components initialization   (tide_ini routine)
+   USE bdy_oce,  ONLY : ln_bdy
+   USE bdyini         ! open boundary cond. setting       (bdy_init routine)
+   USE istate         ! initial state setting          (istate_init routine)
+   USE ldfdyn         ! lateral viscosity setting      (ldfdyn_init routine)
+   USE ldftra         ! lateral diffusivity setting    (ldftra_init routine)
+   USE trdini         ! dyn/tra trends initialization     (trd_init routine)
+   USE asminc         ! assimilation increments     
+   USE asmbkg         ! writing out state trajectory
+   USE diaptr         ! poleward transports           (dia_ptr_init routine)
+   USE diadct         ! sections transports           (dia_dct_init routine)
+   USE diaobs         ! Observation diagnostics       (dia_obs_init routine)
+   USE diacfl         ! CFL diagnostics               (dia_cfl_init routine)
+   USE step           ! NEMO time-stepping                 (stp     routine)
+   USE icbini         ! handle bergs, initialisation
+   USE icbstp         ! handle bergs, calving, themodynamics and transport
+   USE cpl_oasis3     ! OASIS3 coupling
+   USE c1d            ! 1D configuration
+   USE step_c1d       ! Time stepping loop for the 1D configuration
+   USE dyndmp         ! Momentum damping
+   USE stopar         ! Stochastic param.: ???
+   USE stopts         ! Stochastic param.: ???
+   USE diurnal_bulk   ! diurnal bulk SST 
+   USE step_diu       ! diurnal bulk SST timestepping (called from here if run offline)
+   USE crsini         ! initialise grid coarsening utility
+   USE diatmb         ! Top,middle,bottom output
+   USE dia25h         ! 25h mean output
+   USE sbc_oce , ONLY : lk_oasis
+   USE wet_dry        ! Wetting and drying setting   (wad_init routine)
+#if defined key_top
+   USE trcini         ! passive tracer initialisation
+#endif
+#if defined key_nemocice_decomp
+   USE ice_domain_size, only: nx_global, ny_global
+#endif
+   !
+   USE lib_mpp        ! distributed memory computing
+   USE mppini         ! shared/distributed memory setting (mpp_init routine)
+   USE lbcnfd  , ONLY : isendto, nsndto, nfsloop, nfeloop   ! Setup of north fold exchanges 
+   USE lib_fortran    ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined)
+#if defined key_iomput
+   USE xios           ! xIOserver
+#endif
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   nemo_gcm    ! called by model.F90
+   PUBLIC   nemo_init   ! needed by AGRIF
+   PUBLIC   nemo_alloc  ! needed by TAM
+
+   CHARACTER(lc) ::   cform_aaa="( /, 'AAAAAAAA', / ) "     ! flag for output listing
+
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 4.0 , NEMO Consortium (2018)
+   !! $Id$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE nemo_gcm
+      !!----------------------------------------------------------------------
+      !!                     ***  ROUTINE nemo_gcm  ***
+      !!
+      !! ** Purpose :   NEMO solves the primitive equations on an orthogonal
+      !!              curvilinear mesh on the sphere.
+      !!
+      !! ** Method  : - model general initialization
+      !!              - launch the time-stepping (stp routine)
+      !!              - finalize the run by closing files and communications
+      !!
+      !! References : Madec, Delecluse, Imbard, and Levy, 1997:  internal report, IPSL.
+      !!              Madec, 2008, internal report, IPSL.
+      !!----------------------------------------------------------------------
+      INTEGER ::   istp   ! time step index
+      !!----------------------------------------------------------------------
+      !
+#if defined key_agrif
+      CALL Agrif_Init_Grids()      ! AGRIF: set the meshes
+#endif
+      !                            !-----------------------!
+      CALL nemo_init               !==  Initialisations  ==!
+      !                            !-----------------------!
+#if defined key_agrif
+      CALL Agrif_Declare_Var_dom   ! AGRIF: set the meshes for DOM
+      CALL Agrif_Declare_Var       !  "      "   "   "      "  DYN/TRA 
+# if defined key_top
+      CALL Agrif_Declare_Var_top   !  "      "   "   "      "  TOP
+# endif
+# if defined key_si3
+      CALL Agrif_Declare_Var_si3  !  "      "   "   "      "  LIM3
+# endif
+#endif
+      ! check that all process are still there... If some process have an error,
+      ! they will never enter in step and other processes will wait until the end of the cpu time!
+      IF( lk_mpp )   CALL mpp_max( nstop )
+
+      IF(lwp) WRITE(numout,cform_aaa)   ! Flag AAAAAAA
+
+      !                            !-----------------------!
+      !                            !==   time stepping   ==!
+      !                            !-----------------------!
+      istp = nit000
+      !
+#if defined key_c1d
+      DO WHILE ( istp <= nitend .AND. nstop == 0 )    !==  C1D time-stepping  ==!
+         CALL stp_c1d( istp )
+         istp = istp + 1
+      END DO
+#else
+      !
+# if defined key_agrif
+      !                                               !==  AGRIF time-stepping  ==!
+      CALL Agrif_Regrid()
+      !
+      DO WHILE( istp <= nitend .AND. nstop == 0 )
+         CALL stp
+         istp = istp + 1
+      END DO
+      !
+      IF( .NOT. Agrif_Root() ) THEN
+         CALL Agrif_ParentGrid_To_ChildGrid()
+         IF( ln_diaobs )   CALL dia_obs_wri
+         IF( ln_timing )   CALL timing_finalize
+         CALL Agrif_ChildGrid_To_ParentGrid()
+      ENDIF
+      !
+# else
+      !
+      IF( .NOT.ln_diurnal_only ) THEN                 !==  Standard time-stepping  ==!
+         !
+         DO WHILE( istp <= nitend .AND. nstop == 0 )
+            CALL stp        ( istp ) 
+            istp = istp + 1
+         END DO
+         !
+      ELSE                                            !==  diurnal SST time-steeping only  ==!
+         !
+         DO WHILE( istp <= nitend .AND. nstop == 0 )
+            CALL stp_diurnal( istp )   ! time step only the diurnal SST 
+            istp = istp + 1
+         END DO
+         !
+      ENDIF
+      !
+# endif
+      !
+#endif
+      !
+      IF( ln_diaobs   )   CALL dia_obs_wri
+      !
+      IF( ln_icebergs )   CALL icb_end( nitend )
+
+      !                            !------------------------!
+      !                            !==  finalize the run  ==!
+      !                            !------------------------!
+      IF(lwp) WRITE(numout,cform_aaa)        ! Flag AAAAAAA
+      !
+      IF( nstop /= 0 .AND. lwp ) THEN        ! error print
+         WRITE(numout,cform_err)
+         WRITE(numout,*) '   ==>>>   nemo_gcm: a total of ', nstop, ' errors have been found'
+         WRITE(numout,*)
+      ENDIF
+      !
+      IF( ln_timing )   CALL timing_finalize
+      !
+      CALL nemo_closefile
+      !
+#if defined key_iomput
+                                    CALL xios_finalize  ! end mpp communications with xios
+      IF( lk_oasis     )            CALL cpl_finalize   ! end coupling and mpp communications with OASIS
+#else
+      IF    ( lk_oasis ) THEN   ;   CALL cpl_finalize   ! end coupling and mpp communications with OASIS
+      ELSEIF( lk_mpp   ) THEN   ;   CALL mppstop        ! end mpp communications
+      ENDIF
+#endif
+      !
+   END SUBROUTINE nemo_gcm
+
+
+   SUBROUTINE nemo_init
+      !!----------------------------------------------------------------------
+      !!                     ***  ROUTINE nemo_init  ***
+      !!
+      !! ** Purpose :   initialization of the NEMO GCM
+      !!----------------------------------------------------------------------
+      INTEGER  ::   ji                 ! dummy loop indices
+      INTEGER  ::   ios, ilocal_comm   ! local integers
+      CHARACTER(len=120), DIMENSION(60) ::   cltxt, cltxt2, clnam
+      !!
+      NAMELIST/namctl/ ln_ctl   , nn_print, nn_ictls, nn_ictle,   &
+         &             nn_isplt , nn_jsplt, nn_jctls, nn_jctle,   &
+         &             ln_timing, ln_diacfl
+      NAMELIST/namcfg/ ln_read_cfg, cn_domcfg, ln_closea, ln_write_cfg, cn_domcfg_out, ln_use_jattr
+      !!----------------------------------------------------------------------
+      !
+      cltxt  = ''
+      cltxt2 = ''
+      clnam  = ''  
+      cxios_context = 'nemo'
+      !
+      !                             ! Open reference namelist and configuration namelist files
+      CALL ctl_opn( numnam_ref, 'namelist_ref', 'OLD', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. )
+      CALL ctl_opn( numnam_cfg, 'namelist_cfg', 'OLD', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. )
+      !
+      REWIND( numnam_ref )              ! Namelist namctl in reference namelist
+      READ  ( numnam_ref, namctl, IOSTAT = ios, ERR = 901 )
+901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namctl in reference namelist', .TRUE. )
+      REWIND( numnam_cfg )              ! Namelist namctl in confguration namelist
+      READ  ( numnam_cfg, namctl, IOSTAT = ios, ERR = 902 )
+902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namctl in configuration namelist', .TRUE. )
+      !
+      REWIND( numnam_ref )              ! Namelist namcfg in reference namelist
+      READ  ( numnam_ref, namcfg, IOSTAT = ios, ERR = 903 )
+903   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namcfg in reference namelist', .TRUE. )
+      REWIND( numnam_cfg )              ! Namelist namcfg in confguration namelist
+      READ  ( numnam_cfg, namcfg, IOSTAT = ios, ERR = 904 )
+904   IF( ios >  0 )   CALL ctl_nam ( ios , 'namcfg in configuration namelist', .TRUE. )   
+
+      !                             !--------------------------!
+      !                             !  Set global domain size  !   (control print return in cltxt2)
+      !                             !--------------------------!
+      IF( ln_read_cfg ) THEN              ! Read sizes in domain configuration file
+         CALL domain_cfg ( cltxt2,        cn_cfg, nn_cfg, jpiglo, jpjglo, jpkglo, jperio )
+         !
+      ELSE                                ! user-defined namelist
+         CALL usr_def_nam( cltxt2, clnam, cn_cfg, nn_cfg, jpiglo, jpjglo, jpkglo, jperio )
+      ENDIF
+      !
+      !
+      !                             !--------------------------------------------!
+      !                             !  set communicator & select the local node  !
+      !                             !  NB: mynode also opens output.namelist.dyn !
+      !                             !      on unit number numond on first proc   !
+      !                             !--------------------------------------------!
+#if defined key_iomput
+      IF( Agrif_Root() ) THEN
+         IF( lk_oasis ) THEN
+            CALL cpl_init( "oceanx", ilocal_comm )                               ! nemo local communicator given by oasis
+            CALL xios_initialize( "not used"       ,local_comm= ilocal_comm )    ! send nemo communicator to xios
+         ELSE
+            CALL xios_initialize( "for_xios_mpi_id",return_comm=ilocal_comm )    ! nemo local communicator given by xios
+         ENDIF
+      ENDIF
+      ! Nodes selection (control print return in cltxt)
+      narea = mynode( cltxt, 'output.namelist.dyn', numnam_ref, numnam_cfg, numond , nstop, ilocal_comm )
+#else
+      IF( lk_oasis ) THEN
+         IF( Agrif_Root() ) THEN
+            CALL cpl_init( "oceanx", ilocal_comm )          ! nemo local communicator given by oasis
+         ENDIF
+         ! Nodes selection (control print return in cltxt)
+         narea = mynode( cltxt, 'output.namelist.dyn', numnam_ref, numnam_cfg, numond , nstop, ilocal_comm )
+      ELSE
+         ilocal_comm = 0                                    ! Nodes selection (control print return in cltxt)
+         narea = mynode( cltxt, 'output.namelist.dyn', numnam_ref, numnam_cfg, numond , nstop )
+      ENDIF
+#endif
+
+      narea = narea + 1                                     ! mynode return the rank of proc (0 --> jpnij -1 )
+
+      lwm = (narea == 1)                                    ! control of output namelists
+      lwp = (narea == 1) .OR. ln_ctl                        ! control of all listing output print
+
+      IF(lwm) THEN               ! write merged namelists from earlier to output namelist 
+         !                       ! now that the file has been opened in call to mynode. 
+         !                       ! NB: nammpp has already been written in mynode (if lk_mpp_mpi)
+         WRITE( numond, namctl )
+         WRITE( numond, namcfg )
+         IF( .NOT.ln_read_cfg ) THEN
+            DO ji = 1, SIZE(clnam)
+               IF( TRIM(clnam(ji)) /= '' )   WRITE(numond, * ) clnam(ji)     ! namusr_def print
+            END DO
+         ENDIF
+      ENDIF
+
+      IF(lwp) THEN                            ! open listing units
+         !
+         CALL ctl_opn( numout, 'ocean.output', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE., narea )
+         !
+         WRITE(numout,*)
+         WRITE(numout,*) '   CNRS - NERC - Met OFFICE - MERCATOR-ocean - INGV - CMCC'
+         WRITE(numout,*) '                       NEMO team'
+         WRITE(numout,*) '            Ocean General Circulation Model'
+         WRITE(numout,*) '                NEMO version 4.0  (2017) '
+         WRITE(numout,*)
+         WRITE(numout,*)
+         DO ji = 1, SIZE(cltxt)
+            IF( TRIM(cltxt (ji)) /= '' )   WRITE(numout,*) cltxt(ji)    ! control print of mynode
+         END DO
+         WRITE(numout,*)
+         WRITE(numout,*)
+         DO ji = 1, SIZE(cltxt2)
+            IF( TRIM(cltxt2(ji)) /= '' )   WRITE(numout,*) cltxt2(ji)   ! control print of domain size
+         END DO
+         !
+         WRITE(numout,cform_aaa)                                        ! Flag AAAAAAA
+         !
+      ENDIF
+      !                                      ! Domain decomposition
+      CALL mpp_init                          ! MPP
+
+      ! Now we know the dimensions of the grid and numout has been set: we can allocate arrays
+      CALL nemo_alloc()
+
+      !                             !-------------------------------!
+      !                             !  NEMO general initialization  !
+      !                             !-------------------------------!
+
+      CALL nemo_ctl                          ! Control prints
+      !
+      !                                      ! General initialization
+      IF( ln_timing    )   CALL timing_init     ! timing
+      IF( ln_timing    )   CALL timing_start( 'nemo_init')
+      !
+                           CALL     phy_cst         ! Physical constants
+                           CALL     eos_init        ! Equation of state
+      IF( lk_c1d       )   CALL     c1d_init        ! 1D column configuration
+                           CALL     wad_init        ! Wetting and drying options
+                           CALL     dom_init("OPA") ! Domain
+      IF( ln_crs       )   CALL     crs_init        ! coarsened grid: domain initialization 
+      IF( ln_ctl       )   CALL prt_ctl_init        ! Print control
+      
+      CALL diurnal_sst_bulk_init                ! diurnal sst
+      IF( ln_diurnal   )   CALL diurnal_sst_coolskin_init   ! cool skin   
+      !                            
+      IF( ln_diurnal_only ) THEN                   ! diurnal only: a subset of the initialisation routines
+         CALL  istate_init                            ! ocean initial state (Dynamics and tracers)
+         CALL     sbc_init                            ! Forcings : surface module
+         CALL tra_qsr_init                            ! penetrative solar radiation qsr
+         IF( ln_diaobs ) THEN                         ! Observation & model comparison
+            CALL dia_obs_init                            ! Initialize observational data
+            CALL dia_obs( nit000 - 1 )                   ! Observation operator for restart
+         ENDIF     
+         IF( lk_asminc )   CALL asm_inc_init          ! Assimilation increments
+         !
+         RETURN                                       ! end of initialization
+      ENDIF
+      
+                           CALL  istate_init    ! ocean initial state (Dynamics and tracers)
+
+      !                                      ! external forcing 
+                           CALL    tide_init    ! tidal harmonics
+                           CALL     sbc_init    ! surface boundary conditions (including sea-ice)
+                           CALL     bdy_init    ! Open boundaries initialisation
+
+      !                                      ! Ocean physics
+                           CALL zdf_phy_init    ! Vertical physics
+                                     
+      !                                         ! Lateral physics
+                           CALL ldf_tra_init      ! Lateral ocean tracer physics
+                           CALL ldf_eiv_init      ! eddy induced velocity param.
+                           CALL ldf_dyn_init      ! Lateral ocean momentum physics
+
+      !                                      ! Active tracers
+      IF( ln_traqsr    )   CALL tra_qsr_init      ! penetrative solar radiation qsr
+                           CALL tra_bbc_init      ! bottom heat flux
+      IF( ln_trabbl    )   CALL tra_bbl_init      ! advective (and/or diffusive) bottom boundary layer scheme
+                           CALL tra_dmp_init      ! internal tracer damping
+                           CALL tra_adv_init      ! horizontal & vertical advection
+                           CALL tra_ldf_init      ! lateral mixing
+
+      !                                      ! Dynamics
+      IF( lk_c1d       )   CALL dyn_dmp_init      ! internal momentum damping
+                           CALL dyn_adv_init      ! advection (vector or flux form)
+                           CALL dyn_vor_init      ! vorticity term including Coriolis
+                           CALL dyn_ldf_init      ! lateral mixing
+                           CALL dyn_hpg_init      ! horizontal gradient of Hydrostatic pressure
+                           CALL dyn_spg_init      ! surface pressure gradient
+
+#if defined key_top
+      !                                      ! Passive tracers
+                           CALL     trc_init
+#endif
+      IF( l_ldfslp     )   CALL ldf_slp_init    ! slope of lateral mixing
+
+      !                                      ! Icebergs
+                           CALL icb_init( rdt, nit000)   ! initialise icebergs instance
+
+      !                                      ! Misc. options
+                           CALL sto_par_init    ! Stochastic parametrization
+      IF( ln_sto_eos   )   CALL sto_pts_init    ! RRandom T/S fluctuations
+     
+      !                                      ! Diagnostics
+      IF( lk_floats    )   CALL     flo_init    ! drifting Floats
+      IF( ln_diacfl    )   CALL dia_cfl_init    ! Initialise CFL diagnostics
+                           CALL dia_ptr_init    ! Poleward TRansports initialization
+      IF( lk_diadct    )   CALL dia_dct_init    ! Sections tranports
+                           CALL dia_hsb_init    ! heat content, salt content and volume budgets
+                           CALL     trd_init    ! Mixed-layer/Vorticity/Integral constraints trends
+                           CALL dia_obs_init    ! Initialize observational data
+                           CALL dia_tmb_init    ! TMB outputs
+                           CALL dia_25h_init    ! 25h mean  outputs
+      IF( ln_diaobs    )   CALL dia_obs( nit000-1 )   ! Observation operator for restart
+
+      !                                      ! Assimilation increments
+      IF( lk_asminc    )   CALL asm_inc_init    ! Initialize assimilation increments
+      !
+      IF(lwp) WRITE(numout,cform_aaa)           ! Flag AAAAAAA
+      !
+      IF( ln_timing    )   CALL timing_stop( 'nemo_init')
+      !
+   END SUBROUTINE nemo_init
+
+
+   SUBROUTINE nemo_ctl
+      !!----------------------------------------------------------------------
+      !!                     ***  ROUTINE nemo_ctl  ***
+      !!
+      !! ** Purpose :   control print setting
+      !!
+      !! ** Method  : - print namctl information and check some consistencies
+      !!----------------------------------------------------------------------
+      !
+      IF(lwp) THEN                  ! control print
+         WRITE(numout,*)
+         WRITE(numout,*) 'nemo_ctl: Control prints'
+         WRITE(numout,*) '~~~~~~~~'
+         WRITE(numout,*) '   Namelist namctl'
+         WRITE(numout,*) '      run control (for debugging)     ln_ctl     = ', ln_ctl
+         WRITE(numout,*) '      level of print                  nn_print   = ', nn_print
+         WRITE(numout,*) '      Start i indice for SUM control  nn_ictls   = ', nn_ictls
+         WRITE(numout,*) '      End i indice for SUM control    nn_ictle   = ', nn_ictle
+         WRITE(numout,*) '      Start j indice for SUM control  nn_jctls   = ', nn_jctls
+         WRITE(numout,*) '      End j indice for SUM control    nn_jctle   = ', nn_jctle
+         WRITE(numout,*) '      number of proc. following i     nn_isplt   = ', nn_isplt
+         WRITE(numout,*) '      number of proc. following j     nn_jsplt   = ', nn_jsplt
+         WRITE(numout,*) '      timing by routine               ln_timing  = ', ln_timing
+         WRITE(numout,*) '      CFL diagnostics                 ln_diacfl  = ', ln_diacfl
+      ENDIF
+      !
+      nprint    = nn_print          ! convert DOCTOR namelist names into OLD names
+      nictls    = nn_ictls
+      nictle    = nn_ictle
+      njctls    = nn_jctls
+      njctle    = nn_jctle
+      isplt     = nn_isplt
+      jsplt     = nn_jsplt
+
+      IF(lwp) THEN                  ! control print
+         WRITE(numout,*)
+         WRITE(numout,*) '   Namelist namcfg'
+         WRITE(numout,*) '      read domain configuration file                ln_read_cfg      = ', ln_read_cfg
+         WRITE(numout,*) '         filename to be read                           cn_domcfg     = ', TRIM(cn_domcfg)
+         WRITE(numout,*) '         keep closed seas in the domain (if exist)     ln_closea     = ', ln_closea
+         WRITE(numout,*) '      create a configuration definition file        ln_write_cfg     = ', ln_write_cfg
+         WRITE(numout,*) '         filename to be written                        cn_domcfg_out = ', TRIM(cn_domcfg_out)
+         WRITE(numout,*) '      use file attribute if exists as i/p j-start   ln_use_jattr     = ', ln_use_jattr
+      ENDIF
+      IF( .NOT.ln_read_cfg )   ln_closea = .false.   ! dealing possible only with a domcfg file
+      !
+      !                             ! Parameter control
+      !
+      IF( ln_ctl ) THEN                 ! sub-domain area indices for the control prints
+         IF( lk_mpp .AND. jpnij > 1 ) THEN
+            isplt = jpni   ;   jsplt = jpnj   ;   ijsplt = jpni*jpnj   ! the domain is forced to the real split domain
+         ELSE
+            IF( isplt == 1 .AND. jsplt == 1  ) THEN
+               CALL ctl_warn( ' - isplt & jsplt are equal to 1',   &
+                  &           ' - the print control will be done over the whole domain' )
+            ENDIF
+            ijsplt = isplt * jsplt            ! total number of processors ijsplt
+         ENDIF
+         IF(lwp) WRITE(numout,*)'          - The total number of processors over which the'
+         IF(lwp) WRITE(numout,*)'            print control will be done is ijsplt : ', ijsplt
+         !
+         !                              ! indices used for the SUM control
+         IF( nictls+nictle+njctls+njctle == 0 )   THEN    ! print control done over the default area
+            lsp_area = .FALSE.
+         ELSE                                             ! print control done over a specific  area
+            lsp_area = .TRUE.
+            IF( nictls < 1 .OR. nictls > jpiglo )   THEN
+               CALL ctl_warn( '          - nictls must be 1<=nictls>=jpiglo, it is forced to 1' )
+               nictls = 1
+            ENDIF
+            IF( nictle < 1 .OR. nictle > jpiglo )   THEN
+               CALL ctl_warn( '          - nictle must be 1<=nictle>=jpiglo, it is forced to jpiglo' )
+               nictle = jpiglo
+            ENDIF
+            IF( njctls < 1 .OR. njctls > jpjglo )   THEN
+               CALL ctl_warn( '          - njctls must be 1<=njctls>=jpjglo, it is forced to 1' )
+               njctls = 1
+            ENDIF
+            IF( njctle < 1 .OR. njctle > jpjglo )   THEN
+               CALL ctl_warn( '          - njctle must be 1<=njctle>=jpjglo, it is forced to jpjglo' )
+               njctle = jpjglo
+            ENDIF
+         ENDIF
+      ENDIF
+      !
+      IF( 1._wp /= SIGN(1._wp,-0._wp)  )   CALL ctl_stop( 'nemo_ctl: The intrinsec SIGN function follows f2003 standard.',  &
+         &                                                'Compile with key_nosignedzero enabled' )
+      !
+#if defined key_agrif
+      IF( ln_timing )   CALL ctl_stop( 'AGRIF not implemented with ln_timing = true')
+#endif
+      !
+   END SUBROUTINE nemo_ctl
+
+
+   SUBROUTINE nemo_closefile
+      !!----------------------------------------------------------------------
+      !!                     ***  ROUTINE nemo_closefile  ***
+      !!
+      !! ** Purpose :   Close the files
+      !!----------------------------------------------------------------------
+      !
+      IF( lk_mpp )   CALL mppsync
+      !
+      CALL iom_close                                 ! close all input/output files managed by iom_*
+      !
+      IF( numstp          /= -1 )   CLOSE( numstp          )   ! time-step file
+      IF( numrun          /= -1 )   CLOSE( numrun          )   ! run statistics file
+      IF( numnam_ref      /= -1 )   CLOSE( numnam_ref      )   ! oce reference namelist
+      IF( numnam_cfg      /= -1 )   CLOSE( numnam_cfg      )   ! oce configuration namelist
+      IF( lwm.AND.numond  /= -1 )   CLOSE( numond          )   ! oce output namelist
+      IF( numnam_ice_ref  /= -1 )   CLOSE( numnam_ice_ref  )   ! ice reference namelist
+      IF( numnam_ice_cfg  /= -1 )   CLOSE( numnam_ice_cfg  )   ! ice configuration namelist
+      IF( lwm.AND.numoni  /= -1 )   CLOSE( numoni          )   ! ice output namelist
+      IF( numevo_ice      /= -1 )   CLOSE( numevo_ice      )   ! ice variables (temp. evolution)
+      IF( numout          /=  6 )   CLOSE( numout          )   ! standard model output file
+      IF( numdct_vol      /= -1 )   CLOSE( numdct_vol      )   ! volume transports
+      IF( numdct_heat     /= -1 )   CLOSE( numdct_heat     )   ! heat transports
+      IF( numdct_salt     /= -1 )   CLOSE( numdct_salt     )   ! salt transports
+      !
+      numout = 6                                     ! redefine numout in case it is used after this point...
+      !
+   END SUBROUTINE nemo_closefile
+
+
+   SUBROUTINE nemo_alloc
+      !!----------------------------------------------------------------------
+      !!                     ***  ROUTINE nemo_alloc  ***
+      !!
+      !! ** Purpose :   Allocate all the dynamic arrays of the OPA modules
+      !!
+      !! ** Method  :
+      !!----------------------------------------------------------------------
+      USE diawri    , ONLY : dia_wri_alloc
+      USE dom_oce   , ONLY : dom_oce_alloc
+      USE trc_oce   , ONLY : trc_oce_alloc
+      USE bdy_oce   , ONLY : bdy_oce_alloc
+#if defined key_diadct 
+      USE diadct    , ONLY : diadct_alloc 
+#endif 
+      !
+      INTEGER :: ierr
+      !!----------------------------------------------------------------------
+      !
+      ierr =        oce_alloc    ()    ! ocean 
+      ierr = ierr + dia_wri_alloc()
+      ierr = ierr + dom_oce_alloc()    ! ocean domain
+      ierr = ierr + zdf_oce_alloc()    ! ocean vertical physics
+      ierr = ierr + trc_oce_alloc()    ! shared TRC / TRA arrays
+      ierr = ierr + bdy_oce_alloc()    ! bdy masks (incl. initialization)
+      !
+#if defined key_diadct 
+      ierr = ierr + diadct_alloc ()    ! 
+#endif 
+      !
+      IF( lk_mpp    )   CALL mpp_sum( ierr )
+      IF( ierr /= 0 )   CALL ctl_stop( 'STOP', 'nemo_alloc: unable to allocate standard ocean arrays' )
+      !
+   END SUBROUTINE nemo_alloc
+
+   !!======================================================================
+END MODULE nemogcm
+
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/oce.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/oce.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/oce.F90	(revision 9570)
@@ -0,0 +1,120 @@
+MODULE oce
+   !!======================================================================
+   !!                      ***  MODULE  oce  ***
+   !! Ocean        :  dynamics and active tracers defined in memory 
+   !!======================================================================
+   !! History :  1.0  !  2002-11  (G. Madec)  F90: Free form and module
+   !!            3.1  !  2009-02  (G. Madec, M. Leclair)  pure z* coordinate
+   !!            3.3  !  2010-09  (C. Ethe) TRA-TRC merge: add ts, gtsu, gtsv 4D arrays
+   !!            3.7  !  2014-01  (G. Madec) suppression of curl and before hdiv from in-core memory
+   !!----------------------------------------------------------------------
+   USE par_oce        ! ocean parameters
+   USE lib_mpp        ! MPP library
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC oce_alloc ! routine called by nemo_init in nemogcm.F90
+
+   !! dynamics and tracer fields                            ! before ! now    ! after  ! the after trends becomes the fields
+   !! --------------------------                            ! fields ! fields ! trends ! only after tra_zdf and dyn_spg
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)   ::   ub   ,  un    , ua     !: i-horizontal velocity        [m/s]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)   ::   vb   ,  vn    , va     !: j-horizontal velocity        [m/s]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)   ::           wn             !: vertical velocity            [m/s]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)   ::           hdivn          !: horizontal divergence        [s-1]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) ::   tsb  ,  tsn   , tsa    !: 4D T-S fields                  [Celsius,psu] 
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) ::   rab_b,  rab_n          !: thermal/haline expansion coef. [Celsius-1,psu-1]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)   ::   rn2b ,  rn2            !: brunt-vaisala frequency**2     [s-2]
+   !
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   rhd    !: in situ density anomalie rhd=(rho-rau0)/rau0  [no units]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   rhop   !: potential volumic mass                           [kg/m3]
+
+   !! free surface                                      !  before  ! now    ! after  !
+   !! ------------                                      !  fields  ! fields ! fields !
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   ub_b   ,  un_b  ,  ua_b  !: Barotropic velocities at u-point [m/s]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   vb_b   ,  vn_b  ,  va_b  !: Barotropic velocities at v-point [m/s]
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   sshb   ,  sshn  ,  ssha  !: sea surface height at t-point [m]
+
+   !! Arrays at barotropic time step:                   ! befbefore! before !  now   ! after  !
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   ubb_e  ,  ub_e  ,  un_e  , ua_e   !: u-external velocity
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   vbb_e  ,  vb_e  ,  vn_e  , va_e   !: v-external velocity
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   sshbb_e,  sshb_e,  sshn_e, ssha_e !: external ssh
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::                              hu_e   !: external u-depth
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::                              hv_e   !: external v-depth
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::                              hur_e  !: inverse of u-depth
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::                              hvr_e  !: inverse of v-depth
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   ub2_b  , vb2_b           !: Half step fluxes (ln_bt_fw=T)
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   un_bf  , vn_bf           !: Asselin filtered half step fluxes (ln_bt_fw=T)
+#if defined key_agrif
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   ub2_i_b, vb2_i_b         !: Half step time integrated fluxes 
+#endif
+   !
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   spgu, spgv               !: horizontal surface pressure gradient
+
+   !! interpolated gradient (only used in zps case)
+   !! ---------------------
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   gtsu, gtsv   !: horizontal gradient of T, S bottom u-point 
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   gru , grv    !: horizontal gradient of rd at bottom u-point
+
+   !! (ISF) interpolated gradient (only used for ice shelf case) 
+   !! --------------------- 
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   gtui, gtvi   !: horizontal gradient of T, S and rd at top u-point 
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   grui, grvi   !: horizontal gradient of T, S and rd at top v-point  
+   !! (ISF) ice load
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   riceload
+
+   !! Energy budget of the leads (open water embedded in sea ice)
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   fraqsr_1lev        !: fraction of solar net radiation absorbed in the first ocean level [-]
+
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.7 , NEMO Consortium (2014)
+   !! $Id$ 
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   INTEGER FUNCTION oce_alloc()
+      !!----------------------------------------------------------------------
+      !!                   ***  FUNCTION oce_alloc  ***
+      !!----------------------------------------------------------------------
+      INTEGER :: ierr(6)
+      !!----------------------------------------------------------------------
+      !
+      ierr(:) = 0 
+      ALLOCATE( ub   (jpi,jpj,jpk)      , un   (jpi,jpj,jpk)      , ua(jpi,jpj,jpk)       ,     &
+         &      vb   (jpi,jpj,jpk)      , vn   (jpi,jpj,jpk)      , va(jpi,jpj,jpk)       ,     &          
+         &      wn   (jpi,jpj,jpk)      , hdivn(jpi,jpj,jpk)      ,                             &
+         &      tsb  (jpi,jpj,jpk,jpts) , tsn  (jpi,jpj,jpk,jpts) , tsa(jpi,jpj,jpk,jpts) ,     &
+         &      rab_b(jpi,jpj,jpk,jpts) , rab_n(jpi,jpj,jpk,jpts) ,                             &
+         &      rn2b (jpi,jpj,jpk)      , rn2  (jpi,jpj,jpk)      ,                             &
+         &      rhd  (jpi,jpj,jpk)      , rhop (jpi,jpj,jpk)                              , STAT=ierr(1) )
+         !
+      ALLOCATE( sshb(jpi,jpj)     , sshn(jpi,jpj)   , ssha(jpi,jpj)   ,     &
+         &      ub_b(jpi,jpj)     , un_b(jpi,jpj)   , ua_b(jpi,jpj)   ,     &
+         &      vb_b(jpi,jpj)     , vn_b(jpi,jpj)   , va_b(jpi,jpj)   ,     &
+         &      spgu  (jpi,jpj)   , spgv(jpi,jpj)                     ,     &
+         &      gtsu(jpi,jpj,jpts), gtsv(jpi,jpj,jpts)                ,     &
+         &      gru(jpi,jpj)      , grv(jpi,jpj)                      ,     &
+         &      gtui(jpi,jpj,jpts), gtvi(jpi,jpj,jpts)                ,     &
+         &      grui(jpi,jpj)     , grvi(jpi,jpj)                     ,     &
+         &      riceload(jpi,jpj)                                     , STAT=ierr(2) )
+         !
+      ALLOCATE( fraqsr_1lev(jpi,jpj) , STAT=ierr(3) )
+         !
+      ALLOCATE( ssha_e(jpi,jpj),  sshn_e(jpi,jpj), sshb_e(jpi,jpj), sshbb_e(jpi,jpj), &
+         &        ua_e(jpi,jpj),    un_e(jpi,jpj),   ub_e(jpi,jpj),   ubb_e(jpi,jpj), &
+         &        va_e(jpi,jpj),    vn_e(jpi,jpj),   vb_e(jpi,jpj),   vbb_e(jpi,jpj), &
+         &        hu_e(jpi,jpj),   hur_e(jpi,jpj),   hv_e(jpi,jpj),   hvr_e(jpi,jpj), STAT=ierr(4) )
+         !
+      ALLOCATE( ub2_b(jpi,jpj), vb2_b(jpi,jpj), un_bf(jpi,jpj), vn_bf(jpi,jpj)      , STAT=ierr(6) )
+#if defined key_agrif
+      ALLOCATE( ub2_i_b(jpi,jpj), vb2_i_b(jpi,jpj)                                  , STAT=ierr(6) )
+#endif
+         !
+      oce_alloc = MAXVAL( ierr )
+      IF( oce_alloc /= 0 )   CALL ctl_warn('oce_alloc: failed to allocate arrays')
+      !
+   END FUNCTION oce_alloc
+
+   !!======================================================================
+END MODULE oce
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/par_kind.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/par_kind.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/par_kind.F90	(revision 9570)
@@ -0,0 +1,40 @@
+MODULE par_kind
+   !!======================================================================
+   !!                   ***  MODULE par_kind  ***
+   !! Ocean :  define the kind of real for the whole model
+   !!======================================================================
+   !! History :  1.0  ! 2002-06  (G. Madec)  Original code
+   !!            3.3  ! 2010-12  (G. Madec)  add a standard length of character strings
+   !!----------------------------------------------------------------------
+
+   IMPLICIT NONE
+   PRIVATE
+
+   INTEGER, PUBLIC, PARAMETER ::   jpbyt   = 8    !: real size for mpp communications
+   INTEGER, PUBLIC, PARAMETER ::   jpbytda = 4    !: real size in input data files 4 or 8
+
+   ! Number model from which the SELECTED_*_KIND are requested:
+   !             4 byte REAL       8 byte REAL
+   ! CRAY:           -            precision = 13
+   !                              exponent = 2465
+   ! IEEE:      precision = 6     precision = 15
+   !            exponent = 37     exponent = 307
+
+   !                                                                !!** Floating point **
+   INTEGER, PUBLIC, PARAMETER ::   sp = SELECTED_REAL_KIND( 6, 37)   !: single precision (real 4)
+   INTEGER, PUBLIC, PARAMETER ::   dp = SELECTED_REAL_KIND(12,307)   !: double precision (real 8)
+   INTEGER, PUBLIC, PARAMETER ::   wp = dp                              !: working precision
+
+   !                                                                !!** Integer **
+   INTEGER, PUBLIC, PARAMETER ::   i4 = SELECTED_INT_KIND( 9)        !: single precision (integer 4)
+   INTEGER, PUBLIC, PARAMETER ::   i8 = SELECTED_INT_KIND(14)        !: double precision (integer 8)
+   
+   !                                                                !!** Integer **
+   INTEGER, PUBLIC, PARAMETER ::   lc = 256                          !: Lenght of Character strings
+
+   !!----------------------------------------------------------------------
+   !! NEMO 3.3 , NEMO Consortium (2010)
+   !! $Id$ 
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+END MODULE par_kind
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/par_oce.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/par_oce.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/par_oce.F90	(revision 9570)
@@ -0,0 +1,83 @@
+MODULE par_oce
+   !!======================================================================
+   !!                        ***  par_oce  ***
+   !! Ocean :   set the ocean parameters
+   !!======================================================================
+   !! History :  OPA  !  1991     (Imbard, Levy, Madec)  Original code
+   !!   NEMO     1.0  !  2004-01  (G. Madec, J.-M. Molines)  Free form and module
+   !!            3.3  !  2010-09  (C. Ethe) TRA-TRC merge: add jpts, jp_tem & jp_sal
+   !!----------------------------------------------------------------------
+   USE par_kind          ! kind parameters
+
+   IMPLICIT NONE
+   PUBLIC
+
+   !!----------------------------------------------------------------------
+   !!                   namcfg namelist parameters
+   !!----------------------------------------------------------------------
+   LOGICAL       ::   ln_read_cfg      !: (=T) read the domain configuration file or (=F) not
+   CHARACTER(lc) ::      cn_domcfg        !: filename the configuration file to be read
+   LOGICAL       ::   ln_write_cfg     !: (=T) create the domain configuration file
+   CHARACTER(lc) ::      cn_domcfg_out    !: filename the configuration file to be read
+   !
+   LOGICAL       ::   ln_use_jattr     !: input file read offset
+   !                                   !  Use file global attribute: open_ocean_jstart to determine start j-row 
+   !                                   !  when reading input from those netcdf files that have the 
+   !                                   !  attribute defined. This is designed to enable input files associated 
+   !                                   !  with the extended grids used in the under ice shelf configurations to 
+   !                                   !  be used without redundant rows when the ice shelves are not in use.
+   ! 
+
+   !!---------------------------------------------------------------------
+   !! Domain Matrix size 
+   !!---------------------------------------------------------------------
+   ! configuration name & resolution   (required only in ORCA family case)
+   CHARACTER(lc) ::   cn_cfg           !: name of the configuration
+   INTEGER       ::   nn_cfg           !: resolution of the configuration 
+
+   ! global domain size               !!! * total computational domain *
+   INTEGER       ::   jpiglo           !: 1st dimension of global domain --> i-direction
+   INTEGER       ::   jpjglo           !: 2nd    -                  -    --> j-direction
+   INTEGER       ::   jpkglo           !: 3nd    -                  -    --> k levels
+
+   ! global domain size for AGRIF     !!! * total AGRIF computational domain *
+   INTEGER, PUBLIC            ::   nbug_in_agrif_conv_do_not_remove_or_modify = 1 - 1
+   INTEGER, PUBLIC, PARAMETER ::   nbghostcells = 1                             !: number of ghost cells
+   INTEGER, PUBLIC            ::   nbcellsx   ! = jpiglo - 2 - 2*nbghostcells   !: number of cells in i-direction
+   INTEGER, PUBLIC            ::   nbcellsy   ! = jpjglo - 2 - 2*nbghostcells   !: number of cells in j-direction
+
+   ! local domain size                !!! * local computational domain *
+   INTEGER, PUBLIC ::   jpi   !                                                    !: first  dimension
+   INTEGER, PUBLIC ::   jpj   !                                                    !: second dimension
+   INTEGER, PUBLIC ::   jpk   ! = jpkglo                                           !: third  dimension
+   INTEGER, PUBLIC ::   jpim1 ! = jpi-1                                            !: inner domain indices
+   INTEGER, PUBLIC ::   jpjm1 ! = jpj-1                                            !:   -     -      -
+   INTEGER, PUBLIC ::   jpkm1 ! = jpk-1                                            !:   -     -      -
+   INTEGER, PUBLIC ::   jpij  ! = jpi*jpj                                          !:  jpi x jpj
+   INTEGER, PUBLIC ::   jpimax! = ( jpiglo-2*nn_hls + (jpni-1) ) / jpni + 2*nn_hls !: maximum jpi
+   INTEGER, PUBLIC ::   jpjmax! = ( jpjglo-2*nn_hls + (jpnj-1) ) / jpnj + 2*nn_hls !: maximum jpj
+
+   !!---------------------------------------------------------------------
+   !! Active tracer parameters
+   !!---------------------------------------------------------------------
+   INTEGER, PUBLIC, PARAMETER ::   jpts   = 2    !: Number of active tracers (=2, i.e. T & S )
+   INTEGER, PUBLIC, PARAMETER ::   jp_tem = 1    !: indice for temperature
+   INTEGER, PUBLIC, PARAMETER ::   jp_sal = 2    !: indice for salinity
+
+   !!----------------------------------------------------------------------
+   !!   Domain decomposition
+   !!----------------------------------------------------------------------
+   !! if we dont use massively parallel computer (parameters jpni=jpnj=1) so jpiglo=jpi and jpjglo=jpj
+   INTEGER, PUBLIC            ::   jpni         !: number of processors following i 
+   INTEGER, PUBLIC            ::   jpnj         !: number of processors following j
+   INTEGER, PUBLIC            ::   jpnij        !: nb of local domain = nb of processors ( <= jpni x jpnj )
+   INTEGER, PUBLIC, PARAMETER ::   jpr2di = 0   !: number of columns for extra outer halo 
+   INTEGER, PUBLIC, PARAMETER ::   jpr2dj = 0   !: number of rows    for extra outer halo 
+   INTEGER, PUBLIC, PARAMETER ::   nn_hls = 1   !: halo width (applies to both rows and columns)
+
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 4.0 , NEMO Consortium (2016)
+   !! $Id$ 
+   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
+   !!======================================================================
+END MODULE par_oce
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/step.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/step.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/step.F90	(revision 9570)
@@ -0,0 +1,342 @@
+MODULE step
+   !!======================================================================
+   !!                       ***  MODULE step  ***
+   !! Time-stepping   : manager of the ocean, tracer and ice time stepping
+   !!======================================================================
+   !! History :  OPA  !  1991-03  (G. Madec)  Original code
+   !!             -   !  1991-11  (G. Madec)
+   !!             -   !  1992-06  (M. Imbard)  add a first output record
+   !!             -   !  1996-04  (G. Madec)  introduction of dynspg
+   !!             -   !  1996-04  (M.A. Foujols)  introduction of passive tracer
+   !!            8.0  !  1997-06  (G. Madec)  new architecture of call
+   !!            8.2  !  1997-06  (G. Madec, M. Imbard, G. Roullet)  free surface
+   !!             -   !  1999-02  (G. Madec, N. Grima)  hpg implicit
+   !!             -   !  2000-07  (J-M Molines, M. Imbard)  Open Bondary Conditions
+   !!   NEMO     1.0  !  2002-06  (G. Madec)  free form, suppress macro-tasking
+   !!             -   !  2004-08  (C. Talandier) New trends organization
+   !!             -   !  2005-01  (C. Ethe) Add the KPP closure scheme
+   !!             -   !  2005-11  (G. Madec)  Reorganisation of tra and dyn calls
+   !!             -   !  2006-01  (L. Debreu, C. Mazauric)  Agrif implementation
+   !!             -   !  2006-07  (S. Masson)  restart using iom
+   !!            3.2  !  2009-02  (G. Madec, R. Benshila)  reintroduicing z*-coordinate
+   !!             -   !  2009-06  (S. Masson, G. Madec)  TKE restart compatible with key_cpl
+   !!            3.3  !  2010-05  (K. Mogensen, A. Weaver, M. Martin, D. Lea) Assimilation interface
+   !!             -   !  2010-10  (C. Ethe, G. Madec) reorganisation of initialisation phase + merge TRC-TRA
+   !!            3.4  !  2011-04  (G. Madec, C. Ethe) Merge of dtatem and dtasal
+   !!            3.6  !  2012-07  (J. Simeon, G. Madec. C. Ethe)  Online coarsening of outputs
+   !!            3.6  !  2014-04  (F. Roquet, G. Madec) New equations of state
+   !!            3.6  !  2014-10  (E. Clementi, P. Oddo) Add Qiao vertical mixing in case of waves
+   !!            3.7  !  2014-10  (G. Madec)  LDF simplication 
+   !!             -   !  2014-12  (G. Madec) remove KPP scheme
+   !!             -   !  2015-11  (J. Chanut) free surface simplification (remove filtered free surface)
+   !!            4.0  !  2017-05  (G. Madec)  introduction of the vertical physics manager (zdfphy)
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   stp             : OPA system time-stepping
+   !!----------------------------------------------------------------------
+   USE step_oce         ! time stepping definition modules
+   !
+   USE iom              ! xIOs server
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   stp   ! called by nemogcm.F90
+
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 4.0 , NEMO Consortium (2017)
+   !! $Id$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+#if defined key_agrif
+   RECURSIVE SUBROUTINE stp( )
+      INTEGER             ::   kstp   ! ocean time-step index
+#else
+   SUBROUTINE stp( kstp )
+      INTEGER, INTENT(in) ::   kstp   ! ocean time-step index
+#endif
+      !!----------------------------------------------------------------------
+      !!                     ***  ROUTINE stp  ***
+      !!
+      !! ** Purpose : - Time stepping of OPA  (momentum and active tracer eqs.)
+      !!              - Time stepping of SI3 (dynamic and thermodynamic eqs.)
+      !!              - Time stepping of TRC  (passive tracer eqs.)
+      !!
+      !! ** Method  : -1- Update forcings and data
+      !!              -2- Update ocean physics
+      !!              -3- Compute the t and s trends
+      !!              -4- Update t and s
+      !!              -5- Compute the momentum trends
+      !!              -6- Update the horizontal velocity
+      !!              -7- Compute the diagnostics variables (rd,N2, hdiv,w)
+      !!              -8- Outputs and diagnostics
+      !!----------------------------------------------------------------------
+      INTEGER ::   ji, jj, jk   ! dummy loop indice
+      INTEGER ::   indic        ! error indicator if < 0
+!!gm kcall can be removed, I guess
+      INTEGER ::   kcall        ! optional integer argument (dom_vvl_sf_nxt)
+      !! ---------------------------------------------------------------------
+#if defined key_agrif
+      kstp = nit000 + Agrif_Nb_Step()
+      IF( lk_agrif_debug ) THEN
+         IF( Agrif_Root() .and. lwp)   WRITE(*,*) '---'
+         IF(lwp)   WRITE(*,*) 'Grid Number', Agrif_Fixed(),' time step ', kstp, 'int tstep', Agrif_NbStepint()
+      ENDIF
+      IF( kstp == nit000 + 1 )   lk_agrif_fstep = .FALSE.
+# if defined key_iomput
+      IF( Agrif_Nbstepint() == 0 )   CALL iom_swap( cxios_context )
+# endif
+#endif
+      !
+      IF( ln_timing )   CALL timing_start('stp')
+      !
+      !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+      ! update I/O and calendar 
+      !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+                             indic = 0                ! reset to no error condition
+                             
+      IF( kstp == nit000 ) THEN                       ! initialize IOM context (must be done after nemo_init for AGRIF+XIOS+OASIS)
+                             CALL iom_init(      cxios_context          )  ! for model grid (including passible AGRIF zoom)
+         IF( ln_crs      )   CALL iom_init( TRIM(cxios_context)//"_crs" )  ! for coarse grid
+      ENDIF
+      IF( kstp /= nit000 )   CALL day( kstp )         ! Calendar (day was already called at nit000 in day_init)
+                             CALL iom_setkt( kstp - nit000 + 1,      cxios_context          )   ! tell IOM we are at time step kstp
+      IF( ln_crs         )   CALL iom_setkt( kstp - nit000 + 1, TRIM(cxios_context)//"_crs" )   ! tell IOM we are at time step kstp
+
+      !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+      ! Update external forcing (tides, open boundaries, and surface boundary condition (including sea-ice)
+      !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+      IF( ln_tide    )   CALL sbc_tide( kstp )                   ! update tide potential
+      IF( ln_apr_dyn )   CALL sbc_apr ( kstp )                   ! atmospheric pressure (NB: call before bdy_dta which needs ssh_ib) 
+      IF( ln_bdy     )   CALL bdy_dta ( kstp, time_offset=+1 )   ! update dynamic & tracer data at open boundaries
+                         CALL sbc     ( kstp )                   ! Sea Boundary Condition (including sea-ice)
+
+      !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+      ! Update stochastic parameters and random T/S fluctuations
+      !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+      IF( ln_sto_eos ) CALL sto_par( kstp )          ! Stochastic parameters
+      IF( ln_sto_eos ) CALL sto_pts( tsn  )          ! Random T/S fluctuations
+
+      !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+      ! Ocean physics update
+      !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+      !  THERMODYNAMICS
+                         CALL eos_rab( tsb, rab_b )       ! before local thermal/haline expension ratio at T-points
+                         CALL eos_rab( tsn, rab_n )       ! now    local thermal/haline expension ratio at T-points
+                         CALL bn2    ( tsb, rab_b, rn2b ) ! before Brunt-Vaisala frequency
+                         CALL bn2    ( tsn, rab_n, rn2  ) ! now    Brunt-Vaisala frequency
+
+      !  VERTICAL PHYSICS
+                         CALL zdf_phy( kstp )         ! vertical physics update (top/bot drag, avt, avs, avm + MLD)
+
+      !  LATERAL  PHYSICS
+      !
+      IF( l_ldfslp ) THEN                             ! slope of lateral mixing
+                         CALL eos( tsb, rhd, gdept_0(:,:,:) )               ! before in situ density
+
+         IF( ln_zps .AND. .NOT. ln_isfcav)                               &
+            &            CALL zps_hde    ( kstp, jpts, tsb, gtsu, gtsv,  &  ! Partial steps: before horizontal gradient
+            &                                          rhd, gru , grv    )  ! of t, s, rd at the last ocean level
+
+         IF( ln_zps .AND.       ln_isfcav)                               &
+            &            CALL zps_hde_isf( kstp, jpts, tsb, gtsu, gtsv, gtui, gtvi,  &  ! Partial steps for top cell (ISF)
+            &                                          rhd, gru , grv , grui, grvi   )  ! of t, s, rd at the first ocean level
+         IF( ln_traldf_triad ) THEN 
+                         CALL ldf_slp_triad( kstp )                       ! before slope for triad operator
+         ELSE     
+                         CALL ldf_slp     ( kstp, rhd, rn2b )             ! before slope for standard operator
+         ENDIF
+      ENDIF
+      !                                                                   ! eddy diffusivity coeff.
+      IF( l_ldftra_time .OR. l_ldfeiv_time )   CALL ldf_tra( kstp )       !       and/or eiv coeff.
+      IF( l_ldfdyn_time                    )   CALL ldf_dyn( kstp )       ! eddy viscosity coeff. 
+
+      !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+      !  Ocean dynamics : hdiv, ssh, e3, u, v, w
+      !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+
+                            CALL ssh_nxt       ( kstp )  ! after ssh (includes call to div_hor)
+      IF(.NOT.ln_linssh )   CALL dom_vvl_sf_nxt( kstp )  ! after vertical scale factors 
+                            CALL wzv           ( kstp )  ! now cross-level velocity 
+                            CALL eos    ( tsn, rhd, rhop, gdept_n(:,:,:) )  ! now in situ density for hpg computation
+                            
+!!jc: fs simplification
+!!jc: lines below are useless if ln_linssh=F. Keep them here (which maintains a bug if ln_linssh=T and ln_zps=T, cf ticket #1636) 
+!!                                         but ensures reproductible results
+!!                                         with previous versions using split-explicit free surface          
+            IF( ln_zps .AND. .NOT. ln_isfcav )                               &
+               &            CALL zps_hde    ( kstp, jpts, tsn, gtsu, gtsv,   &  ! Partial steps: before horizontal gradient
+               &                                          rhd, gru , grv     )  ! of t, s, rd at the last ocean level
+            IF( ln_zps .AND.       ln_isfcav )                                          &
+               &            CALL zps_hde_isf( kstp, jpts, tsn, gtsu, gtsv, gtui, gtvi,  &  ! Partial steps for top cell (ISF)
+               &                                          rhd, gru , grv , grui, grvi   )  ! of t, s, rd at the first ocean level
+!!jc: fs simplification
+                            
+                         ua(:,:,:) = 0._wp            ! set dynamics trends to zero
+                         va(:,:,:) = 0._wp
+
+      IF(  lk_asminc .AND. ln_asmiau .AND. ln_dyninc )   &
+               &         CALL dyn_asm_inc   ( kstp )  ! apply dynamics assimilation increment
+      IF( ln_bdy     )   CALL bdy_dyn3d_dmp ( kstp )  ! bdy damping trends
+#if defined key_agrif
+      IF(.NOT. Agrif_Root())  & 
+               &         CALL Agrif_Sponge_dyn        ! momentum sponge
+#endif
+                         CALL dyn_adv       ( kstp )  ! advection (vector or flux form)
+                         CALL dyn_vor       ( kstp )  ! vorticity term including Coriolis
+                         CALL dyn_ldf       ( kstp )  ! lateral mixing
+      IF( ln_zdfosm  )   CALL dyn_osm       ( kstp )  ! OSMOSIS non-local velocity fluxes
+                         CALL dyn_hpg       ( kstp )  ! horizontal gradient of Hydrostatic pressure
+                         CALL dyn_spg       ( kstp )  ! surface pressure gradient
+
+                                                      ! With split-explicit free surface, since now transports have been updated and ssha as well
+      IF( ln_dynspg_ts ) THEN                         ! vertical scale factors and vertical velocity need to be updated
+                            CALL div_hor    ( kstp )              ! Horizontal divergence  (2nd call in time-split case)
+         IF(.NOT.ln_linssh) CALL dom_vvl_sf_nxt( kstp, kcall=2 )  ! after vertical scale factors (update depth average component)
+                            CALL wzv        ( kstp )              ! now cross-level velocity 
+      ENDIF
+      
+                         CALL dyn_zdf       ( kstp )  ! vertical diffusion
+
+      !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+      ! cool skin
+      !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<      
+      IF ( ln_diurnal )  CALL stp_diurnal( kstp )
+      
+      !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+      ! diagnostics and outputs
+      !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+      IF( lk_floats  )   CALL flo_stp ( kstp )        ! drifting Floats
+      IF( ln_diacfl  )   CALL dia_cfl ( kstp )        ! Courant number diagnostics
+      IF( lk_diahth  )   CALL dia_hth ( kstp )        ! Thermocline depth (20 degres isotherm depth)
+      IF( lk_diadct  )   CALL dia_dct ( kstp )        ! Transports
+                         CALL dia_ar5 ( kstp )        ! ar5 diag
+      IF( lk_diaharm )   CALL dia_harm( kstp )        ! Tidal harmonic analysis
+                         CALL dia_wri ( kstp )        ! ocean model: outputs
+      !
+      IF( ln_crs     )   CALL crs_fld       ( kstp )  ! ocean model: online field coarsening & output
+      
+#if defined key_top
+      !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+      ! Passive Tracer Model
+      !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+                         CALL trc_stp       ( kstp )  ! time-stepping
+#endif
+
+      !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+      ! Active tracers                              
+      !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+                         tsa(:,:,:,:) = 0._wp         ! set tracer trends to zero
+
+      IF(  lk_asminc .AND. ln_asmiau .AND. &
+         & ln_trainc )   CALL tra_asm_inc   ( kstp )  ! apply tracer assimilation increment
+                         CALL tra_sbc       ( kstp )  ! surface boundary condition
+      IF( ln_traqsr  )   CALL tra_qsr       ( kstp )  ! penetrative solar radiation qsr
+      IF( ln_trabbc  )   CALL tra_bbc       ( kstp )  ! bottom heat flux
+      IF( ln_trabbl  )   CALL tra_bbl       ( kstp )  ! advective (and/or diffusive) bottom boundary layer scheme
+      IF( ln_tradmp  )   CALL tra_dmp       ( kstp )  ! internal damping trends
+      IF( ln_bdy     )   CALL bdy_tra_dmp   ( kstp )  ! bdy damping trends
+#if defined key_agrif
+      IF(.NOT. Agrif_Root())  & 
+               &         CALL Agrif_Sponge_tra        ! tracers sponge
+#endif
+                         CALL tra_adv       ( kstp )  ! horizontal & vertical advection
+      IF( ln_zdfosm  )   CALL tra_osm       ( kstp )  ! OSMOSIS non-local tracer fluxes
+      IF( lrst_oce .AND. ln_zdfosm ) &
+           &             CALL osm_rst( kstp, 'WRITE' )! write OSMOSIS outputs + wn (so must do here) to restarts
+                         CALL tra_ldf       ( kstp )  ! lateral mixing
+
+!!gm : why CALL to dia_ptr has been moved here??? (use trends info?)
+      IF( ln_diaptr  )   CALL dia_ptr                 ! Poleward adv/ldf TRansports diagnostics
+!!gm
+                         CALL tra_zdf       ( kstp )  ! vertical mixing and after tracer fields
+      IF( ln_zdfnpc  )   CALL tra_npc       ( kstp )  ! update after fields by non-penetrative convection
+
+      !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+      ! Set boundary conditions and Swap
+      !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+!!jc1: For agrif, it would be much better to finalize tracers/momentum here (e.g. bdy conditions) and move the swap 
+!!    (and time filtering) after Agrif update. Then restart would be done after and would contain updated fields. 
+!!    If so: 
+!!    (i) no need to call agrif update at initialization time
+!!    (ii) no need to update "before" fields 
+!!
+!!    Apart from creating new tra_swp/dyn_swp routines, this however: 
+!!    (i) makes boundary conditions at initialization time computed from updated fields which is not the case between 
+!!    two restarts => restartability issue. One can circumvent this, maybe, by assuming "interface separation", 
+!!    e.g. a shift of the feedback interface inside child domain. 
+!!    (ii) requires that all restart outputs of updated variables by agrif (e.g. passive tracers/tke/barotropic arrays) are done at the same
+!!    place.
+!! 
+!!jc2: dynnxt must be the latest call. e3t_b are indeed updated in that routine
+                         CALL tra_nxt       ( kstp )  ! finalize (bcs) tracer fields at next time step and swap
+                         CALL dyn_nxt       ( kstp )  ! finalize (bcs) velocities at next time step and swap (always called after tra_nxt)
+                         CALL ssh_swp       ( kstp )  ! swap of sea surface height
+      IF(.NOT.ln_linssh) CALL dom_vvl_sf_swp( kstp )  ! swap of vertical scale factors
+      !
+      IF( ln_diahsb  )   CALL dia_hsb       ( kstp )  ! - ML - global conservation diagnostics
+
+!!gm : This does not only concern the dynamics ==>>> add a new title
+!!gm2: why ouput restart before AGRIF update?
+!!
+!!jc: That would be better, but see comment above
+!!
+      IF( lrst_oce   )   CALL rst_write    ( kstp )   ! write output ocean restart file
+      IF( ln_sto_eos )   CALL sto_rst_write( kstp )   ! write restart file for stochastic parameters
+
+#if defined key_agrif
+      !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+      ! AGRIF
+      !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<      
+                         CALL Agrif_Integrate_ChildGrids( stp )  ! allows to finish all the Child Grids before updating
+
+      IF( Agrif_NbStepint() == 0 ) THEN               ! AGRIF Update from zoom N to zoom 1 then to Parent 
+!!jc in fact update is useless at last time step, but do it for global diagnostics
+#if defined key_si3
+                              CALL Agrif_Update_si3( kstp )   ! update sea-ice
+#endif
+                              CALL Agrif_Update_ssh()          ! Update ssh
+         IF(.NOT.ln_linssh)   CALL Agrif_Update_vvl()          ! Update vertical scale factors  
+                              CALL Agrif_Update_Tra()          ! Update active tracers
+                              CALL Agrif_Update_Dyn()          ! Update momentum
+# if defined key_top
+                              CALL Agrif_Update_Trc()          ! Update passive tracers
+# endif
+      ENDIF
+#endif
+      IF( ln_diaobs  )   CALL dia_obs      ( kstp )      ! obs-minus-model (assimilation) diagnostics (call after dynamics update)
+
+      !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+      ! Control
+      !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+                         CALL stp_ctl      ( kstp, indic )
+                         
+      IF( kstp == nit000 ) THEN                          ! 1st time step only
+                                        CALL iom_close( numror )   ! close input  ocean restart file
+         IF(lwm)                        CALL FLUSH    ( numond )   ! flush output namelist oce
+         IF(lwm .AND. numoni /= -1 )    CALL FLUSH    ( numoni )   ! flush output namelist ice (if exist)
+      ENDIF
+
+      !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+      ! Coupled mode
+      !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+!!gm why lk_oasis and not lk_cpl ????
+      IF( lk_oasis   )   CALL sbc_cpl_snd( kstp )     ! coupled mode : field exchanges
+      !
+#if defined key_iomput
+      IF( kstp == nitend .OR. indic < 0 ) THEN 
+                      CALL iom_context_finalize(      cxios_context          ) ! needed for XIOS+AGRIF
+                      IF(lrxios) CALL iom_context_finalize(      crxios_context          )
+         IF( ln_crs ) CALL iom_context_finalize( trim(cxios_context)//"_crs" ) ! 
+      ENDIF
+#endif
+      !
+      IF( ln_timing )   CALL timing_stop('stp')
+      !
+   END SUBROUTINE stp
+   
+   !!======================================================================
+END MODULE step
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/step_oce.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/step_oce.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/step_oce.F90	(revision 9570)
@@ -0,0 +1,122 @@
+MODULE step_oce
+   !!======================================================================
+   !!                       ***  MODULE step_oce  ***
+   !! Ocean time-stepping : module used in both initialisation phase and time stepping
+   !!======================================================================
+   !! History :   3.3  !  2010-08  (C. Ethe)  Original code - reorganisation of the initial phase
+   !!             3.7  !  2014-01  (G. Madec) LDF simplication 
+   !!----------------------------------------------------------------------
+   USE oce             ! ocean dynamics and tracers variables
+   USE dom_oce         ! ocean space and time domain variables
+   USE zdf_oce         ! ocean vertical physics variables
+   USE zdfdrg  ,  ONLY : ln_drgimp   ! implicit top/bottom friction
+
+   USE daymod          ! calendar                         (day     routine)
+
+   USE sbc_oce         ! surface boundary condition: ocean
+   USE sbcmod          ! surface boundary condition       (sbc     routine)
+   USE sbcrnf          ! surface boundary condition: runoff variables
+   USE sbccpl          ! surface boundary condition: coupled formulation (call send at end of step)
+   USE sbcapr          ! surface boundary condition: atmospheric pressure
+   USE sbctide         ! Tide initialisation
+   USE sbcwave         ! Wave intialisation
+
+   USE traqsr          ! solar radiation penetration      (tra_qsr routine)
+   USE trasbc          ! surface boundary condition       (tra_sbc routine)
+   USE trabbc          ! bottom boundary condition        (tra_bbc routine)
+   USE trabbl          ! bottom boundary layer            (tra_bbl routine)
+   USE tradmp          ! internal damping                 (tra_dmp routine)
+   USE traadv          ! advection scheme control     (tra_adv_ctl routine)
+   USE traldf          ! lateral mixing                   (tra_ldf routine)
+   USE trazdf          ! vertical mixing                  (tra_zdf routine)
+   USE tranxt          ! time-stepping                    (tra_nxt routine)
+   USE tranpc          ! non-penetrative convection       (tra_npc routine)
+
+   USE eosbn2          ! equation of state                (eos_bn2 routine)
+
+   USE divhor          ! horizontal divergence            (div_hor routine)
+   USE dynadv          ! advection                        (dyn_adv routine)
+   USE dynvor          ! vorticity term                   (dyn_vor routine)
+   USE dynhpg          ! hydrostatic pressure grad.       (dyn_hpg routine)
+   USE dynldf          ! lateral momentum diffusion       (dyn_ldf routine)
+   USE dynzdf          ! vertical diffusion               (dyn_zdf routine)
+   USE dynspg          ! surface pressure gradient        (dyn_spg routine)
+
+   USE dynnxt          ! time-stepping                    (dyn_nxt routine)
+
+   USE stopar          ! Stochastic parametrization       (sto_par routine)
+   USE stopts 
+
+   USE bdy_oce  , ONLY : ln_bdy
+   USE bdydta          ! open boundary condition data     (bdy_dta routine)
+   USE bdytra          ! bdy cond. for tracers            (bdy_tra routine)
+   USE bdydyn3d        ! bdy cond. for baroclinic vel.  (bdy_dyn3d routine)
+
+   USE sshwzv          ! vertical velocity and ssh        (ssh_nxt routine)
+   !                                                       (ssh_swp routine)
+   !                                                       (wzv     routine)
+   USE domvvl          ! variable vertical scale factors  (dom_vvl_sf_nxt routine)
+   !                                                       (dom_vvl_sf_swp routine)
+
+   USE ldfslp          ! iso-neutral slopes               (ldf_slp routine)
+   USE ldfdyn          ! lateral eddy viscosity coef.     (ldf_dyn routine)
+   USE ldftra          ! lateral eddy diffusive coef.     (ldf_tra routine)
+
+   USE zdfphy          ! vertical physics manager      (zdf_phy_init routine)
+   USE zdfosm  , ONLY : osm_rst, dyn_osm, tra_osm      ! OSMOSIS routines used in step.F90
+
+   USE step_diu        ! Time stepping for diurnal sst
+   USE diurnal_bulk    ! diurnal SST bulk routines  (diurnal_sst_takaya routine) 
+   USE cool_skin       ! diurnal cool skin correction (diurnal_sst_coolskin routine)   
+   USE sbc_oce         ! surface fluxes  
+   
+   USE zpshde          ! partial step: hor. derivative     (zps_hde routine)
+
+   USE diawri          ! Standard run outputs             (dia_wri routine)
+   USE diaptr          ! poleward transports              (dia_ptr routine)
+   USE diadct          ! sections transports              (dia_dct routine)
+   USE diaar5          ! AR5 diagnosics                   (dia_ar5 routine)
+   USE diahth          ! thermocline depth                (dia_hth routine)
+   USE diahsb          ! heat, salt and volume budgets    (dia_hsb routine)
+   USE diaharm
+   USE diacfl
+   USE diaobs          ! Observation operator
+   USE flo_oce         ! floats variables
+   USE floats          ! floats computation               (flo_stp routine)
+
+   USE crsfld          ! Standard output on coarse grid   (crs_fld routine)
+
+   USE asminc          ! assimilation increments      (tra_asm_inc routine)
+   !                                                   (dyn_asm_inc routine)
+   USE asmbkg
+   USE stpctl          ! time stepping control            (stp_ctl routine)
+   USE restart         ! ocean restart                    (rst_wri routine)
+   USE prtctl          ! Print control                    (prt_ctl routine)
+
+   USE in_out_manager  ! I/O manager
+   USE iom             !
+   USE lbclnk
+   USE timing          ! Timing
+
+#if defined key_iomput
+   USE xios            ! I/O server
+#endif
+#if defined key_agrif
+   USE agrif_oce_sponge ! Momemtum and tracers sponges
+   USE agrif_oce_update ! Update (2-way nesting)
+#if defined key_si3
+   USE agrif_si3_update
+#endif
+#if defined key_top
+   USE agrif_top_update ! passive tracers update (2-way nesting)
+#endif
+#endif
+#if defined key_top
+   USE trcstp           ! passive tracer time-stepping      (trc_stp routine)
+#endif
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.7 , NEMO Consortium (2014)
+   !! $Id$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!======================================================================
+END MODULE step_oce
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/stpctl.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/stpctl.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/stpctl.F90	(revision 9570)
@@ -0,0 +1,172 @@
+MODULE stpctl
+   !!======================================================================
+   !!                       ***  MODULE  stpctl  ***
+   !! Ocean run control :  gross check of the ocean time stepping
+   !!======================================================================
+   !! History :  OPA  ! 1991-03  (G. Madec) Original code
+   !!            6.0  ! 1992-06  (M. Imbard)
+   !!            8.0  ! 1997-06  (A.M. Treguier)
+   !!   NEMO     1.0  ! 2002-06  (G. Madec)  F90: Free form and module
+   !!            2.0  ! 2009-07  (G. Madec)  Add statistic for time-spliting
+   !!            3.7  ! 2016-09  (G. Madec)  Remove solver
+   !!            4.0  ! 2017-04  (G. Madec)  regroup global communications
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   stp_ctl      : Control the run
+   !!----------------------------------------------------------------------
+   USE oce             ! ocean dynamics and tracers variables
+   USE dom_oce         ! ocean space and time domain variables 
+   USE c1d             ! 1D vertical configuration
+   USE diawri          ! Standard run outputs       (dia_wri_state routine)
+   !
+   USE in_out_manager  ! I/O manager
+   USE lbclnk          ! ocean lateral boundary conditions (or mpp link)
+   USE lib_mpp         ! distributed memory computing
+   USE wet_dry,   ONLY : ll_wd, ssh_ref    ! reference depth for negative bathy
+
+   USE netcdf          ! NetCDF library
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC stp_ctl           ! routine called by step.F90
+
+   INTEGER  ::   idrun, idtime, idssh, idu, ids, istatus
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 4.0 , NEMO Consortium (2017)
+   !! $Id$
+   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE stp_ctl( kt, kindic )
+      !!----------------------------------------------------------------------
+      !!                    ***  ROUTINE stp_ctl  ***
+      !!                     
+      !! ** Purpose :   Control the run
+      !!
+      !! ** Method  : - Save the time step in numstp
+      !!              - Print it each 50 time steps
+      !!              - Stop the run IF problem encountered by setting indic=-3
+      !!                Problems checked: |ssh| maximum larger than 10 m
+      !!                                  |U|   maximum larger than 10 m/s 
+      !!                                  negative sea surface salinity
+      !!
+      !! ** Actions :   "time.step" file = last ocean time-step
+      !!                "run.stat"  file = run statistics
+      !!                nstop indicator sheared among all local domain (lk_mpp=T)
+      !!----------------------------------------------------------------------
+      INTEGER, INTENT(in   ) ::   kt       ! ocean time-step index
+      INTEGER, INTENT(inout) ::   kindic   ! error indicator
+      !!
+      INTEGER  ::   ji, jj, jk             ! dummy loop indices
+      INTEGER  ::   iih, ijh               ! local integers
+      INTEGER  ::   iiu, iju, iku          !   -       -
+      INTEGER  ::   iis, ijs, iks          !   -       -
+      REAL(wp) ::   zzz                    ! local real 
+      INTEGER , DIMENSION(3) ::   ilocu, ilocs
+      INTEGER , DIMENSION(2) ::   iloch
+      REAL(wp), DIMENSION(4) ::   zmax
+      CHARACTER(len=20) :: clname
+      !!----------------------------------------------------------------------
+      !
+      IF( kt == nit000 .AND. lwp ) THEN
+         WRITE(numout,*)
+         WRITE(numout,*) 'stp_ctl : time-stepping control'
+         WRITE(numout,*) '~~~~~~~'
+         !                                ! open time.step file
+         CALL ctl_opn( numstp, 'time.step', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp, narea )
+         !                                ! open run.stat file
+         CALL ctl_opn( numrun, 'run.stat', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp, narea )
+
+         IF( lwm ) THEN
+            clname = 'run.stat.nc'
+            IF( .NOT. Agrif_Root() )   clname = TRIM(Agrif_CFixed())//"_"//TRIM(clname)
+            istatus = NF90_CREATE( TRIM(clname), NF90_CLOBBER, idrun )
+            istatus = NF90_DEF_DIM( idrun, 'time', NF90_UNLIMITED, idtime )
+            istatus = NF90_DEF_VAR( idrun, 'abs_ssh_max', NF90_DOUBLE, (/ idtime /), idssh )
+            istatus = NF90_DEF_VAR( idrun,   'abs_u_max', NF90_DOUBLE, (/ idtime /), idu )
+            istatus = NF90_DEF_VAR( idrun,       's_min', NF90_DOUBLE, (/ idtime /), ids )
+            istatus = NF90_ENDDEF(idrun)
+         ENDIF
+         
+      ENDIF
+      !
+      IF(lwp) THEN                        !==  current time step  ==!   ("time.step" file)
+         WRITE ( numstp, '(1x, i8)' )   kt
+         REWIND( numstp )
+      ENDIF
+      !
+      !                                   !==  test of extrema  ==!
+      IF( ll_wd ) THEN
+         zmax(1) = MAXVAL(  ABS( sshn(:,:) + ssh_ref*tmask(:,:,1) )  )        ! ssh max 
+      ELSE
+         zmax(1) = MAXVAL(  ABS( sshn(:,:) )  )                               ! ssh max
+      ENDIF
+      zmax(2) = MAXVAL(  ABS( un(:,:,:) )  )                                  ! velocity max (zonal only)
+      zmax(3) = MAXVAL( -tsn(:,:,:,jp_sal) , mask = tmask(:,:,:) == 1._wp )   ! minus salinity max
+      zmax(4) = REAL( nstop , wp )                                            ! stop indicator
+      !
+      IF( lk_mpp ) THEN
+         CALL mpp_max_multiple( zmax(:), 4 )    ! max over the global domain
+         !
+         nstop = INT( zmax(4) )                 ! nstop indicator sheared among all local domains
+      ENDIF
+      !
+      IF( MOD( kt, nwrite ) == 1 .AND. lwp ) THEN
+         WRITE(numout,*) ' ==>> time-step= ', kt, ' |ssh| max: ',   zmax(1), ' |U| max: ', zmax(2),   &
+            &                                     ' S min: '    , - zmax(3)
+      ENDIF
+      !
+      IF (  zmax(1) >  15._wp .OR.   &                     ! too large sea surface height ( > 10 m)
+         &  zmax(2) >  10._wp .OR.   &                     ! too large velocity ( > 10 m/s)
+         &  zmax(3) >=  0._wp .OR.   &                     ! negative or zero sea surface salinity
+         &  ISNAN( zmax(1) + zmax(2) + zmax(3) )  ) THEN   ! NaN encounter in the tests
+         IF( lk_mpp ) THEN
+            CALL mpp_maxloc( ABS(sshn)        , ssmask(:,:)  , zzz, iih, ijh )
+            CALL mpp_maxloc( ABS(un)          , umask (:,:,:), zzz, iiu, iju, iku )
+            CALL mpp_minloc( tsn(:,:,:,jp_sal), tmask (:,:,:), zzz, iis, ijs, iks )
+         ELSE
+            iloch = MINLOC( ABS( sshn(:,:)   )                               )
+            ilocu = MAXLOC( ABS( un  (:,:,:) )                               )
+            ilocs = MINLOC( tsn(:,:,:,jp_sal) , mask = tmask(:,:,:) == 1._wp )
+            iih = iloch(1) + nimpp - 1   ;   ijh = iloch(2) + njmpp - 1
+            iiu = ilocu(1) + nimpp - 1   ;   iju = ilocu(2) + njmpp - 1   ;   iku = ilocu(3)
+            iis = ilocs(1) + nimpp - 1   ;   ijs = ilocs(2) + njmpp - 1   ;   iks = ilocu(3)
+         ENDIF
+         IF(lwp) THEN
+            WRITE(numout,cform_err)
+            WRITE(numout,*) ' stp_ctl: |ssh| > 10 m   or   |U| > 10 m/s   or   S < 0   or   NaN encounter in the tests'
+            WRITE(numout,*) ' ======= '
+            WRITE(numout,9100) kt,   zmax(1), iih, ijh
+            WRITE(numout,9200) kt,   zmax(2), iiu, iju, iku
+            WRITE(numout,9300) kt, - zmax(3), iis, ijs, iks
+            WRITE(numout,*)
+            WRITE(numout,*) '          output of last computed fields in output.abort.nc file'
+         ENDIF
+         kindic = -3
+         !
+         nstop = nstop + 1                            ! increase nstop by 1 (on all local domains)
+         CALL dia_wri_state( 'output.abort', kt )     ! create an output.abort file
+         !
+      ENDIF
+9100  FORMAT (' kt=',i8,'   |ssh| max: ',1pg11.4,', at  i j  : ',2i5)
+9200  FORMAT (' kt=',i8,'   |U|   max: ',1pg11.4,', at  i j k: ',3i5)
+9300  FORMAT (' kt=',i8,'   S     min: ',1pg11.4,', at  i j  : ',2i5)
+      !
+      !                                            !==  run statistics  ==!   ("run.stat" file)
+      IF(lwp) WRITE(numrun,9400) kt, zmax(1), zmax(2), - zmax(3)
+      IF( lwm ) THEN
+         istatus = NF90_PUT_VAR( idrun, idssh, (/ zmax(1)/), (/kt/), (/1/) )
+         istatus = NF90_PUT_VAR( idrun,   idu, (/ zmax(2)/), (/kt/), (/1/) )
+         istatus = NF90_PUT_VAR( idrun,   ids, (/-zmax(3)/), (/kt/), (/1/) )
+         IF( MOD( kt , 100 ) == 0 ) istatus = NF90_SYNC(idrun)
+         IF( kt == nitend         ) istatus = NF90_CLOSE(idrun)
+      END IF
+      !
+9400  FORMAT(' it :', i8, '    |ssh|_max: ', D23.16, ' |U|_max: ', D23.16,' S_min: ', D23.16)
+      !
+   END SUBROUTINE stp_ctl
+
+   !!======================================================================
+END MODULE stpctl
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/timing.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/timing.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/timing.F90	(revision 9570)
@@ -0,0 +1,800 @@
+MODULE timing
+   !!========================================================================
+   !!                     ***  MODULE  timing  ***
+   !!========================================================================
+   !! History : 4.0  ! 2001-05  (R. Benshila)   
+   !!------------------------------------------------------------------------
+
+   !!------------------------------------------------------------------------
+   !!   timming_init    : initialize timing process 
+   !!   timing_start    : start Timer
+   !!   timing_stop     : stop  Timer
+   !!   timing_reset    : end timing variable creation
+   !!   timing_finalize : compute stats and write output in calling w*_info 
+   !!   timing_ini_var  : create timing variables 
+   !!   timing_listing  : print instumented subroutines in ocean.output
+   !!   wcurrent_info   : compute and print detailed stats on the current CPU
+   !!   wave_info       : compute and print averaged statson all processors
+   !!   wmpi_info       : compute and write global stats  
+   !!   supress         : suppress an element of the timing linked list  
+   !!   insert          : insert an element of the timing linked list  
+   !!------------------------------------------------------------------------
+   USE in_out_manager  ! I/O manager 
+   USE dom_oce         ! ocean domain
+   USE lib_mpp          
+   
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   timing_init, timing_finalize   ! called in nemogcm module 
+   PUBLIC   timing_reset                   ! called in step module 
+   PUBLIC   timing_start, timing_stop      ! called in each routine to time 
+   
+#if defined key_mpp_mpi
+   INCLUDE 'mpif.h'
+#endif
+
+   ! Variables for fine grain timing
+   TYPE timer
+      CHARACTER(LEN=20)  :: cname
+   	  REAL(wp)  :: t_cpu, t_clock, tsum_cpu, tsum_clock, tmax_cpu, tmax_clock, tmin_cpu, tmin_clock, tsub_cpu, tsub_clock
+      INTEGER :: ncount, ncount_max, ncount_rate  
+      INTEGER :: niter
+      LOGICAL :: l_tdone
+      TYPE(timer), POINTER :: next => NULL()
+      TYPE(timer), POINTER :: prev => NULL()
+      TYPE(timer), POINTER :: parent_section => NULL()
+   END TYPE timer
+    
+   TYPE alltimer
+      CHARACTER(LEN=20), DIMENSION(:), POINTER :: cname => NULL()
+   	  REAL(wp), DIMENSION(:), POINTER :: tsum_cpu   => NULL()
+   	  REAL(wp), DIMENSION(:), POINTER :: tsum_clock => NULL()
+   	  INTEGER, DIMENSION(:), POINTER :: niter => NULL()
+      TYPE(alltimer), POINTER :: next => NULL()
+      TYPE(alltimer), POINTER :: prev => NULL()
+   END TYPE alltimer 
+ 
+   TYPE(timer), POINTER :: s_timer_root => NULL()
+   TYPE(timer), POINTER :: s_timer      => NULL()
+   TYPE(timer), POINTER :: s_wrk        => NULL()
+   REAL(wp) :: t_overclock, t_overcpu
+   LOGICAL :: l_initdone = .FALSE.
+   INTEGER :: nsize
+   
+   ! Variables for coarse grain timing
+   REAL(wp) :: tot_etime, tot_ctime
+   REAL(kind=wp), DIMENSION(2)     :: t_elaps, t_cpu
+   REAL(wp), ALLOCATABLE, DIMENSION(:) :: all_etime, all_ctime
+   INTEGER :: nfinal_count, ncount, ncount_rate, ncount_max
+   INTEGER, DIMENSION(8)           :: nvalues
+   CHARACTER(LEN=8), DIMENSION(2)  :: cdate
+   CHARACTER(LEN=10), DIMENSION(2) :: ctime
+   CHARACTER(LEN=5)                :: czone
+    
+   ! From of ouput file (1/proc or one global)   !RB to put in nammpp or namctl
+   LOGICAL :: ln_onefile = .TRUE. 
+   LOGICAL :: lwriter
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 4.0 , NEMO Consortium (2011)
+   !! $Id$
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE timing_start(cdinfo)
+      !!----------------------------------------------------------------------
+      !!               ***  ROUTINE timing_start  ***
+      !! ** Purpose :   collect execution time
+      !!----------------------------------------------------------------------
+      CHARACTER(len=*), INTENT(in) :: cdinfo
+      !
+       
+      ! Create timing structure at first call
+      IF( .NOT. l_initdone ) THEN
+         CALL timing_ini_var(cdinfo)
+      ELSE
+         s_timer => s_timer_root
+         DO WHILE( TRIM(s_timer%cname) /= TRIM(cdinfo) ) 
+            IF( ASSOCIATED(s_timer%next) ) s_timer => s_timer%next
+         END DO
+      ENDIF         
+      s_timer%l_tdone = .FALSE.
+      s_timer%niter = s_timer%niter + 1
+      s_timer%t_cpu = 0.
+      s_timer%t_clock = 0.
+                  
+      ! CPU time collection
+      CALL CPU_TIME( s_timer%t_cpu  )
+      ! clock time collection
+#if defined key_mpp_mpi
+      s_timer%t_clock= MPI_Wtime()
+#else
+      CALL SYSTEM_CLOCK(COUNT_RATE=s_timer%ncount_rate, COUNT_MAX=s_timer%ncount_max)
+      CALL SYSTEM_CLOCK(COUNT = s_timer%ncount)
+#endif
+      !
+   END SUBROUTINE timing_start
+
+
+   SUBROUTINE timing_stop(cdinfo, csection)
+      !!----------------------------------------------------------------------
+      !!               ***  ROUTINE timing_stop  ***
+      !! ** Purpose :   finalize timing and output
+      !!----------------------------------------------------------------------
+      CHARACTER(len=*), INTENT(in) :: cdinfo
+      CHARACTER(len=*), INTENT(in), OPTIONAL :: csection
+      !
+      INTEGER  :: ifinal_count, iperiods    
+      REAL(wp) :: zcpu_end, zmpitime
+      !
+      s_wrk => NULL()
+
+      ! clock time collection
+#if defined key_mpp_mpi
+      zmpitime = MPI_Wtime()
+#else
+      CALL SYSTEM_CLOCK(COUNT = ifinal_count)
+#endif
+      ! CPU time collection
+      CALL CPU_TIME( zcpu_end )
+
+      s_timer => s_timer_root
+      DO WHILE( TRIM(s_timer%cname) /= TRIM(cdinfo) ) 
+         IF( ASSOCIATED(s_timer%next) ) s_timer => s_timer%next
+      END DO
+ 
+      ! CPU time correction
+      s_timer%t_cpu  = zcpu_end - s_timer%t_cpu - t_overcpu - s_timer%tsub_cpu
+  
+      ! clock time correction
+#if defined key_mpp_mpi
+      s_timer%t_clock = zmpitime - s_timer%t_clock - t_overclock - s_timer%tsub_clock
+#else
+      iperiods = ifinal_count - s_timer%ncount
+      IF( ifinal_count < s_timer%ncount )  &
+          iperiods = iperiods + s_timer%ncount_max 
+      s_timer%t_clock  = REAL(iperiods) / s_timer%ncount_rate - t_overclock - s_timer%tsub_clock
+#endif
+      
+      ! Correction of parent section
+      IF( .NOT. PRESENT(csection) ) THEN
+         s_wrk => s_timer
+         DO WHILE ( ASSOCIATED(s_wrk%parent_section ) )
+            s_wrk => s_wrk%parent_section
+            s_wrk%tsub_cpu   = s_wrk%tsub_cpu   + s_timer%t_cpu 
+            s_wrk%tsub_clock = s_wrk%tsub_clock + s_timer%t_clock              
+         END DO
+      ENDIF
+            
+      ! time diagnostics 
+      s_timer%tsum_clock = s_timer%tsum_clock + s_timer%t_clock 
+      s_timer%tsum_cpu   = s_timer%tsum_cpu   + s_timer%t_cpu
+!RB to use to get min/max during a time integration
+!      IF( .NOT. l_initdone ) THEN
+!         s_timer%tmin_clock = s_timer%t_clock 
+!         s_timer%tmin_cpu   = s_timer%t_cpu 
+!      ELSE
+!         s_timer%tmin_clock = MIN( s_timer%tmin_clock, s_timer%t_clock ) 
+!         s_timer%tmin_cpu   = MIN( s_timer%tmin_cpu  , s_timer%t_cpu   ) 
+!      ENDIF   
+!      s_timer%tmax_clock = MAX( s_timer%tmax_clock, s_timer%t_clock ) 
+!      s_timer%tmax_cpu   = MAX( s_timer%tmax_cpu  , s_timer%t_cpu   )  
+      !
+      s_timer%tsub_clock = 0.
+      s_timer%tsub_cpu = 0.
+      s_timer%l_tdone = .TRUE.
+      !
+   END SUBROUTINE timing_stop
+ 
+ 
+   SUBROUTINE timing_init
+      !!----------------------------------------------------------------------
+      !!               ***  ROUTINE timing_init  ***
+      !! ** Purpose :   open timing output file
+      !!----------------------------------------------------------------------
+      INTEGER :: iperiods, istart_count, ifinal_count
+      REAL(wp) :: zdum
+      LOGICAL :: ll_f
+             
+      IF( ln_onefile ) THEN
+         IF( lwp) CALL ctl_opn( numtime, 'timing.output', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout,.TRUE., narea )
+         lwriter = lwp
+      ELSE
+         CALL ctl_opn( numtime, 'timing.output', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout,.FALSE., narea )
+         lwriter = .TRUE.
+      ENDIF
+      
+      IF( lwriter) THEN      
+         WRITE(numtime,*)
+         WRITE(numtime,*) '      CNRS - NERC - Met OFFICE - MERCATOR-ocean - CMCC - INGV'
+         WRITE(numtime,*) '                             NEMO team'
+         WRITE(numtime,*) '                  Ocean General Circulation Model'
+         WRITE(numtime,*) '                        version 3.6  (2015) '
+         WRITE(numtime,*)
+         WRITE(numtime,*) '                        Timing Informations '
+         WRITE(numtime,*)
+         WRITE(numtime,*)
+      ENDIF   
+      
+      ! Compute clock function overhead
+#if defined key_mpp_mpi        
+      t_overclock = MPI_WTIME()
+      t_overclock = MPI_WTIME() - t_overclock
+#else        
+      CALL SYSTEM_CLOCK(COUNT_RATE=ncount_rate, COUNT_MAX=ncount_max)
+      CALL SYSTEM_CLOCK(COUNT = istart_count)
+      CALL SYSTEM_CLOCK(COUNT = ifinal_count)
+      iperiods = ifinal_count - istart_count
+      IF( ifinal_count < istart_count )  &
+          iperiods = iperiods + ncount_max 
+      t_overclock = REAL(iperiods) / ncount_rate
+#endif
+
+      ! Compute cpu_time function overhead
+      CALL CPU_TIME(zdum)
+      CALL CPU_TIME(t_overcpu)
+      
+      ! End overhead omputation  
+      t_overcpu = t_overcpu - zdum        
+      t_overclock = t_overcpu + t_overclock        
+
+      ! Timing on date and time
+      CALL DATE_AND_TIME(cdate(1),ctime(1),czone,nvalues)
+    
+      CALL CPU_TIME(t_cpu(1))      
+#if defined key_mpp_mpi        
+      ! Start elapsed and CPU time counters
+      t_elaps(1) = MPI_WTIME()
+#else
+      CALL SYSTEM_CLOCK(COUNT_RATE=ncount_rate, COUNT_MAX=ncount_max)
+      CALL SYSTEM_CLOCK(COUNT = ncount)
+#endif                 
+      !
+   END SUBROUTINE timing_init
+
+
+   SUBROUTINE timing_finalize
+      !!----------------------------------------------------------------------
+      !!               ***  ROUTINE timing_finalize ***
+      !! ** Purpose :  compute average time 
+      !!               write timing output file
+      !!----------------------------------------------------------------------
+      TYPE(timer), POINTER :: s_temp
+      INTEGER :: idum, iperiods, icode
+      LOGICAL :: ll_ord, ll_averep
+      CHARACTER(len=120) :: clfmt            
+      
+      ll_averep = .TRUE.
+    
+      ! total CPU and elapse
+      CALL CPU_TIME(t_cpu(2))
+      t_cpu(2)   = t_cpu(2)    - t_cpu(1)   - t_overcpu
+#if defined key_mpp_mpi
+      t_elaps(2) = MPI_WTIME() - t_elaps(1) - t_overclock
+#else
+      CALL SYSTEM_CLOCK(COUNT = nfinal_count)
+      iperiods = nfinal_count - ncount
+      IF( nfinal_count < ncount )  &
+          iperiods = iperiods + ncount_max 
+      t_elaps(2) = REAL(iperiods) / ncount_rate - t_overclock
+#endif      
+
+      ! End of timings on date & time
+      CALL DATE_AND_TIME(cdate(2),ctime(2),czone,nvalues)
+       
+      ! Compute the numer of routines
+      nsize = 0 
+      s_timer => s_timer_root
+      DO WHILE( ASSOCIATED(s_timer) )
+         nsize = nsize + 1
+         s_timer => s_timer%next
+      END DO
+      idum = nsize
+      IF(lk_mpp) CALL mpp_sum(idum)
+      IF( idum/jpnij /= nsize ) THEN
+         IF( lwriter ) WRITE(numtime,*) '        ===> W A R N I N G: '
+         IF( lwriter ) WRITE(numtime,*) ' Some CPU have different number of routines instrumented for timing'
+         IF( lwriter ) WRITE(numtime,*) ' No detailed report on averaged timing can be provided'
+         IF( lwriter ) WRITE(numtime,*) ' The following detailed report only deals with the current processor'
+         IF( lwriter ) WRITE(numtime,*)
+         ll_averep = .FALSE.
+      ENDIF   
+
+#if defined key_mpp_mpi      
+      ! in MPI gather some info
+      ALLOCATE( all_etime(jpnij), all_ctime(jpnij) )
+      CALL MPI_ALLGATHER(t_elaps(2), 1, MPI_DOUBLE_PRECISION,   &
+                         all_etime , 1, MPI_DOUBLE_PRECISION,   &
+                         MPI_COMM_OCE, icode)
+      CALL MPI_ALLGATHER(t_cpu(2) , 1, MPI_DOUBLE_PRECISION,   &
+                         all_ctime, 1, MPI_DOUBLE_PRECISION,   &
+                         MPI_COMM_OCE, icode)
+      tot_etime = SUM(all_etime(:))
+      tot_ctime = SUM(all_ctime(:))
+#else
+      tot_etime = t_elaps(2)
+      tot_ctime = t_cpu  (2)           
+#endif
+
+      ! write output file
+      IF( lwriter ) WRITE(numtime,*) 'Total timing (sum) :'
+      IF( lwriter ) WRITE(numtime,*) '--------------------'
+      IF( lwriter ) WRITE(numtime,"('Elapsed Time (s)  CPU Time (s)')")
+      IF( lwriter ) WRITE(numtime,'(5x,f12.3,1x,f12.3)')  tot_etime, tot_ctime
+      IF( lwriter ) WRITE(numtime,*) 
+#if defined key_mpp_mpi
+      IF( ll_averep ) CALL waver_info
+      CALL wmpi_info
+#endif      
+      IF( lwriter ) CALL wcurrent_info
+      
+      clfmt='(1X,"Timing started on ",2(A2,"/"),A4," at ",2(A2,":"),A2," MET ",A3,":",A2," from GMT")'
+      IF( lwriter ) WRITE(numtime, TRIM(clfmt)) &           
+      &       cdate(1)(7:8), cdate(1)(5:6), cdate(1)(1:4),   &
+      &       ctime(1)(1:2), ctime(1)(3:4), ctime(1)(5:6),   &
+      &       czone(1:3),    czone(4:5)                     
+      clfmt='(1X,  "Timing   ended on ",2(A2,"/"),A4," at ",2(A2,":"),A2," MET ",A3,":",A2," from GMT")'
+      IF( lwriter ) WRITE(numtime, TRIM(clfmt)) &           
+      &       cdate(2)(7:8), cdate(2)(5:6), cdate(2)(1:4),   &
+      &       ctime(2)(1:2), ctime(2)(3:4), ctime(2)(5:6),   &
+      &       czone(1:3),    czone(4:5)
+
+      IF( lwriter ) CLOSE(numtime) 
+      !
+   END SUBROUTINE timing_finalize
+   
+
+   SUBROUTINE wcurrent_info
+      !!----------------------------------------------------------------------
+      !!               ***  ROUTINE wcurrent_info ***
+      !! ** Purpose :  compute and write timing output file
+      !!----------------------------------------------------------------------
+      LOGICAL :: ll_ord
+      CHARACTER(len=2048) :: clfmt            
+   
+      ! reorder the current list by elapse time      
+      s_wrk => NULL()
+      s_timer => s_timer_root
+      DO
+         ll_ord = .TRUE.
+         s_timer => s_timer_root
+         DO WHILE ( ASSOCIATED( s_timer%next ) )
+         IF (.NOT. ASSOCIATED(s_timer%next)) EXIT
+            IF ( s_timer%tsum_clock < s_timer%next%tsum_clock ) THEN 
+               ALLOCATE(s_wrk)
+               s_wrk = s_timer%next
+               CALL insert  (s_timer, s_timer_root, s_wrk)
+               CALL suppress(s_timer%next)            
+               ll_ord = .FALSE.
+               CYCLE            
+            ENDIF           
+         IF( ASSOCIATED(s_timer%next) ) s_timer => s_timer%next
+         END DO         
+         IF( ll_ord ) EXIT
+      END DO
+            
+      ! write current info
+      WRITE(numtime,*) 'Detailed timing for proc :', narea-1
+      WRITE(numtime,*) '--------------------------'
+      WRITE(numtime,*) 'Section             ',            &
+      &   'Elapsed Time (s)  ','Elapsed Time (%)  ',   &
+      &   'CPU Time(s)  ','CPU Time (%)  ','CPU/Elapsed  ','Frequency' 
+      s_timer => s_timer_root  
+      clfmt = '(1x,a,4x,f12.3,6x,f12.3,x,f12.3,2x,f12.3,6x,f7.3,2x,i9)'
+      DO WHILE ( ASSOCIATED(s_timer) )
+         WRITE(numtime,TRIM(clfmt))   s_timer%cname,   &
+         &   s_timer%tsum_clock,s_timer%tsum_clock*100./t_elaps(2),            &
+         &   s_timer%tsum_cpu  ,s_timer%tsum_cpu*100./t_cpu(2)    ,            &
+         &   s_timer%tsum_cpu/s_timer%tsum_clock, s_timer%niter
+         s_timer => s_timer%next
+      END DO
+      WRITE(numtime,*)
+      !                  
+   END SUBROUTINE wcurrent_info
+
+#if defined key_mpp_mpi     
+   SUBROUTINE waver_info
+      !!----------------------------------------------------------------------
+      !!               ***  ROUTINE wcurrent_info ***
+      !! ** Purpose :  compute and write averaged timing informations
+      !!----------------------------------------------------------------------
+      TYPE(alltimer), POINTER :: sl_timer_glob_root => NULL()
+      TYPE(alltimer), POINTER :: sl_timer_glob      => NULL()
+      TYPE(timer), POINTER :: sl_timer_ave_root => NULL()
+      TYPE(timer), POINTER :: sl_timer_ave      => NULL()
+      INTEGER :: icode
+      INTEGER :: ierr
+      LOGICAL :: ll_ord           
+      CHARACTER(len=200) :: clfmt              
+                 
+      ! Initialised the global strucutre   
+      ALLOCATE(sl_timer_glob_root, Stat=ierr)
+      IF(ierr /= 0)THEN
+         WRITE(numtime,*) 'Failed to allocate global timing structure in waver_info'
+         RETURN
+      END IF
+
+      ALLOCATE(sl_timer_glob_root%cname     (jpnij), &
+               sl_timer_glob_root%tsum_cpu  (jpnij), &
+               sl_timer_glob_root%tsum_clock(jpnij), &
+               sl_timer_glob_root%niter     (jpnij), Stat=ierr)
+      IF(ierr /= 0)THEN
+         WRITE(numtime,*) 'Failed to allocate global timing structure in waver_info'
+         RETURN
+      END IF
+      sl_timer_glob_root%cname(:)       = ''
+      sl_timer_glob_root%tsum_cpu(:)   = 0._wp
+      sl_timer_glob_root%tsum_clock(:) = 0._wp
+      sl_timer_glob_root%niter(:)      = 0
+      sl_timer_glob_root%next => NULL()
+      sl_timer_glob_root%prev => NULL()
+      !ARPDBG - don't need to allocate a pointer that's immediately then
+      !         set to point to some other object.
+      !ALLOCATE(sl_timer_glob)
+      !ALLOCATE(sl_timer_glob%cname     (jpnij))
+      !ALLOCATE(sl_timer_glob%tsum_cpu  (jpnij))
+      !ALLOCATE(sl_timer_glob%tsum_clock(jpnij))
+      !ALLOCATE(sl_timer_glob%niter     (jpnij))
+      sl_timer_glob => sl_timer_glob_root
+      !
+      IF( narea .EQ. 1 ) THEN
+         ALLOCATE(sl_timer_ave_root)
+         sl_timer_ave_root%cname       = ''
+         sl_timer_ave_root%t_cpu      = 0._wp
+         sl_timer_ave_root%t_clock    = 0._wp
+         sl_timer_ave_root%tsum_cpu   = 0._wp
+         sl_timer_ave_root%tsum_clock = 0._wp
+         sl_timer_ave_root%tmax_cpu   = 0._wp
+         sl_timer_ave_root%tmax_clock = 0._wp
+         sl_timer_ave_root%tmin_cpu   = 0._wp
+         sl_timer_ave_root%tmin_clock = 0._wp
+         sl_timer_ave_root%tsub_cpu   = 0._wp
+         sl_timer_ave_root%tsub_clock = 0._wp
+         sl_timer_ave_root%ncount      = 0
+         sl_timer_ave_root%ncount_rate = 0
+         sl_timer_ave_root%ncount_max  = 0
+         sl_timer_ave_root%niter       = 0
+         sl_timer_ave_root%l_tdone  = .FALSE.
+         sl_timer_ave_root%next => NULL()
+         sl_timer_ave_root%prev => NULL()
+         sl_timer_ave => sl_timer_ave_root            
+      ENDIF 
+
+      ! Gather info from all processors
+      s_timer => s_timer_root
+      DO WHILE ( ASSOCIATED(s_timer) )
+         CALL MPI_GATHER(s_timer%cname     , 20, MPI_CHARACTER,   &
+                         sl_timer_glob%cname, 20, MPI_CHARACTER,   &
+                         0, MPI_COMM_OCE, icode)
+         CALL MPI_GATHER(s_timer%tsum_clock     , 1, MPI_DOUBLE_PRECISION,   &
+                         sl_timer_glob%tsum_clock, 1, MPI_DOUBLE_PRECISION,   &
+                         0, MPI_COMM_OCE, icode)
+         CALL MPI_GATHER(s_timer%tsum_cpu     , 1, MPI_DOUBLE_PRECISION,   &
+                         sl_timer_glob%tsum_cpu, 1, MPI_DOUBLE_PRECISION,   &
+                         0, MPI_COMM_OCE, icode)
+         CALL MPI_GATHER(s_timer%niter     , 1, MPI_INTEGER,   &
+                         sl_timer_glob%niter, 1, MPI_INTEGER,   &
+                         0, MPI_COMM_OCE, icode)
+
+         IF( narea == 1 .AND. ASSOCIATED(s_timer%next) ) THEN
+            ALLOCATE(sl_timer_glob%next)
+            ALLOCATE(sl_timer_glob%next%cname     (jpnij))
+            ALLOCATE(sl_timer_glob%next%tsum_cpu  (jpnij))
+            ALLOCATE(sl_timer_glob%next%tsum_clock(jpnij))
+            ALLOCATE(sl_timer_glob%next%niter     (jpnij))
+            sl_timer_glob%next%prev => sl_timer_glob
+            sl_timer_glob%next%next => NULL()
+            sl_timer_glob           => sl_timer_glob%next
+         ENDIF              
+         s_timer => s_timer%next
+      END DO      
+
+         WRITE(*,*) 'ARPDBG: timing: done gathers'
+      
+      IF( narea == 1 ) THEN    
+         ! Compute some stats
+         sl_timer_glob => sl_timer_glob_root
+         DO WHILE( ASSOCIATED(sl_timer_glob) )
+            sl_timer_ave%cname  = sl_timer_glob%cname(1)
+            sl_timer_ave%tsum_cpu   = SUM   (sl_timer_glob%tsum_cpu  (:)) / jpnij
+            sl_timer_ave%tsum_clock = SUM   (sl_timer_glob%tsum_clock(:)) / jpnij
+            sl_timer_ave%tmax_cpu   = MAXVAL(sl_timer_glob%tsum_cpu  (:))
+            sl_timer_ave%tmax_clock = MAXVAL(sl_timer_glob%tsum_clock(:))
+            sl_timer_ave%tmin_cpu   = MINVAL(sl_timer_glob%tsum_cpu  (:))
+            sl_timer_ave%tmin_clock = MINVAL(sl_timer_glob%tsum_clock(:))
+            sl_timer_ave%niter      = SUM   (sl_timer_glob%niter     (:))
+            !
+            IF( ASSOCIATED(sl_timer_glob%next) ) THEN
+               ALLOCATE(sl_timer_ave%next)          
+               sl_timer_ave%next%prev => sl_timer_ave
+               sl_timer_ave%next%next => NULL()           
+               sl_timer_ave           => sl_timer_ave%next
+            ENDIF
+            sl_timer_glob => sl_timer_glob%next                                
+         END DO
+
+         WRITE(*,*) 'ARPDBG: timing: done computing stats'
+      
+         ! reorder the averaged list by CPU time      
+         s_wrk => NULL()
+         sl_timer_ave => sl_timer_ave_root
+         DO
+            ll_ord = .TRUE.
+            sl_timer_ave => sl_timer_ave_root
+            DO WHILE( ASSOCIATED( sl_timer_ave%next ) )
+
+               IF( .NOT. ASSOCIATED(sl_timer_ave%next) ) EXIT
+
+               IF ( sl_timer_ave%tsum_clock < sl_timer_ave%next%tsum_clock ) THEN 
+                  ALLOCATE(s_wrk)
+                  ! Copy data into the new object pointed to by s_wrk
+                  s_wrk = sl_timer_ave%next
+                  ! Insert this new timer object before our current position
+                  CALL insert  (sl_timer_ave, sl_timer_ave_root, s_wrk)
+                  ! Remove the old object from the list
+                  CALL suppress(sl_timer_ave%next)            
+                  ll_ord = .FALSE.
+                  CYCLE            
+               ENDIF           
+               IF( ASSOCIATED(sl_timer_ave%next) ) sl_timer_ave => sl_timer_ave%next
+            END DO         
+            IF( ll_ord ) EXIT
+         END DO
+
+         ! write averaged info
+         WRITE(numtime,"('Averaged timing on all processors :')")
+         WRITE(numtime,"('-----------------------------------')")
+         WRITE(numtime,"('Section',13x,'Elap. Time(s)',2x,'Elap. Time(%)',2x, &
+         &   'CPU Time(s)',2x,'CPU Time(%)',2x,'CPU/Elap',1x,   &
+         &   'Max elap(%)',2x,'Min elap(%)',2x,            &           
+         &   'Freq')")
+         sl_timer_ave => sl_timer_ave_root  
+         clfmt = '((A),E15.7,2x,f6.2,5x,f12.2,5x,f6.2,5x,f7.2,2x,f12.2,4x,f6.2,2x,f9.2)'
+         DO WHILE ( ASSOCIATED(sl_timer_ave) )
+            WRITE(numtime,TRIM(clfmt))   sl_timer_ave%cname(1:18),                            &
+            &   sl_timer_ave%tsum_clock,sl_timer_ave%tsum_clock*100.*jpnij/tot_etime,   &
+            &   sl_timer_ave%tsum_cpu  ,sl_timer_ave%tsum_cpu*100.*jpnij/tot_ctime  ,   &
+            &   sl_timer_ave%tsum_cpu/sl_timer_ave%tsum_clock,                          &
+            &   sl_timer_ave%tmax_clock*100.*jpnij/tot_etime,                           &
+            &   sl_timer_ave%tmin_clock*100.*jpnij/tot_etime,                           &                                               
+            &   sl_timer_ave%niter/REAL(jpnij)
+            sl_timer_ave => sl_timer_ave%next
+         END DO
+         WRITE(numtime,*)
+         !
+         DEALLOCATE(sl_timer_ave_root)
+      ENDIF
+      !
+      DEALLOCATE(sl_timer_glob_root%cname     , &
+                 sl_timer_glob_root%tsum_cpu  , &
+                 sl_timer_glob_root%tsum_clock, &
+                 sl_timer_glob_root%niter)
+      !
+      DEALLOCATE(sl_timer_glob_root)
+      !                  
+   END SUBROUTINE waver_info
+  
+  
+   SUBROUTINE wmpi_info
+      !!----------------------------------------------------------------------
+      !!               ***  ROUTINE wmpi_time  ***
+      !! ** Purpose :   compute and write a summary of MPI infos 
+      !!----------------------------------------------------------------------   
+      !   
+      INTEGER                            :: idum, icode
+      INTEGER, ALLOCATABLE, DIMENSION(:) :: iall_rank
+      REAL(wp) :: ztot_ratio
+      REAL(wp) :: zmax_etime, zmax_ctime, zmax_ratio, zmin_etime, zmin_ctime, zmin_ratio
+      REAL(wp) :: zavg_etime, zavg_ctime, zavg_ratio
+      REAL(wp), ALLOCATABLE, DIMENSION(:) :: zall_ratio
+      CHARACTER(LEN=128), dimension(8) :: cllignes
+      CHARACTER(LEN=128)               :: clhline, clstart_date, clfinal_date
+      CHARACTER(LEN=2048)              :: clfmt    
+   
+      ! Gather all times
+      ALLOCATE( zall_ratio(jpnij), iall_rank(jpnij) )
+      IF( narea == 1 ) THEN
+         iall_rank(:) = (/ (idum,idum=0,jpnij-1) /)
+   
+         ! Compute elapse user time
+         zavg_etime = tot_etime/REAL(jpnij,wp)
+         zmax_etime = MAXVAL(all_etime(:))
+         zmin_etime = MINVAL(all_etime(:))
+
+         ! Compute CPU user time
+         zavg_ctime = tot_ctime/REAL(jpnij,wp)
+         zmax_ctime = MAXVAL(all_ctime(:))
+         zmin_ctime = MINVAL(all_ctime(:))
+   
+         ! Compute cpu/elapsed ratio
+         zall_ratio(:) = all_ctime(:) / all_etime(:)
+         ztot_ratio    = SUM(zall_ratio(:))
+         zavg_ratio    = ztot_ratio/REAL(jpnij,wp)
+         zmax_ratio    = MAXVAL(zall_ratio(:))
+         zmin_ratio    = MINVAL(zall_ratio(:))   
+   
+         ! Output Format
+         clhline    ='1x,13("-"),"|",18("-"),"|",14("-"),"|",18("-"),/,'
+         cllignes(1)='(1x,"MPI summary report :",/,'
+         cllignes(2)='1x,"--------------------",//,'
+         cllignes(3)='1x,"Process Rank |"," Elapsed Time (s) |"," CPU Time (s) |"," Ratio CPU/Elapsed",/,'
+         cllignes(4)='    (1x,i4,9x,"|",f12.3,6x,"|",f12.3,2x,"|",4x,f7.3,/),'
+         WRITE(cllignes(4)(1:4),'(I4)') jpnij
+         cllignes(5)='1x,"Total        |",f12.3,6x,"|",F12.3,2x,"|",4x,f7.3,/,'
+         cllignes(6)='1x,"Minimum      |",f12.3,6x,"|",F12.3,2x,"|",4x,f7.3,/,'
+         cllignes(7)='1x,"Maximum      |",f12.3,6x,"|",F12.3,2x,"|",4x,f7.3,/,'
+         cllignes(8)='1x,"Average      |",f12.3,6x,"|",F12.3,2x,"|",4x,f7.3)'
+         clfmt=TRIM(cllignes(1))// TRIM(cllignes(2))//TRIM(cllignes(3))//          &
+           & TRIM(clhline)//TRIM(cllignes(4))//TRIM(clhline)//TRIM(cllignes(5))//  &
+           & TRIM(clhline)//TRIM(cllignes(6))//TRIM(clhline)//TRIM(cllignes(7))//  &
+           & TRIM(clhline)//TRIM(cllignes(8))
+         WRITE(numtime, TRIM(clfmt)) &
+             (iall_rank(idum),all_etime(idum),all_ctime(idum),zall_ratio(idum),idum=1, jpnij), &
+             tot_etime,     tot_ctime,     ztot_ratio,   &
+             zmin_etime,    zmin_ctime,    zmin_ratio,   &
+             zmax_etime,    zmax_ctime,    zmax_ratio,   &
+             zavg_etime,    zavg_ctime,    zavg_ratio
+         WRITE(numtime,*)    
+      END IF
+      !
+      DEALLOCATE(zall_ratio, iall_rank)
+      !
+   END SUBROUTINE wmpi_info
+#endif   
+
+
+   SUBROUTINE timing_ini_var(cdinfo)
+      !!----------------------------------------------------------------------
+      !!               ***  ROUTINE timing_ini_var  ***
+      !! ** Purpose :   create timing structure 
+      !!----------------------------------------------------------------------
+      CHARACTER(len=*), INTENT(in) :: cdinfo
+      LOGICAL :: ll_section
+       
+      !
+      IF( .NOT. ASSOCIATED(s_timer_root) ) THEN
+         ALLOCATE(s_timer_root)
+         s_timer_root%cname       = cdinfo
+         s_timer_root%t_cpu      = 0._wp
+         s_timer_root%t_clock    = 0._wp
+         s_timer_root%tsum_cpu   = 0._wp
+         s_timer_root%tsum_clock = 0._wp
+         s_timer_root%tmax_cpu   = 0._wp
+         s_timer_root%tmax_clock = 0._wp
+         s_timer_root%tmin_cpu   = 0._wp
+         s_timer_root%tmin_clock = 0._wp
+         s_timer_root%tsub_cpu   = 0._wp
+         s_timer_root%tsub_clock = 0._wp
+         s_timer_root%ncount      = 0
+         s_timer_root%ncount_rate = 0
+         s_timer_root%ncount_max  = 0
+         s_timer_root%niter       = 0
+         s_timer_root%l_tdone  = .FALSE.
+         s_timer_root%next => NULL()
+         s_timer_root%prev => NULL()
+         s_timer => s_timer_root
+         !
+         s_wrk => NULL()
+         
+      ELSE
+         s_timer => s_timer_root
+         ! case of already existing area (typically inside a loop)
+         DO WHILE( ASSOCIATED(s_timer) ) 
+            IF( TRIM(s_timer%cname) .EQ. TRIM(cdinfo) ) RETURN
+            s_timer => s_timer%next
+         END DO
+         
+         ! end of the chain
+         s_timer => s_timer_root
+         DO WHILE( ASSOCIATED(s_timer%next) )
+            s_timer => s_timer%next
+         END DO
+          
+         ALLOCATE(s_timer%next)      
+         s_timer%next%cname       = cdinfo
+         s_timer%next%t_cpu      = 0._wp
+         s_timer%next%t_clock    = 0._wp
+         s_timer%next%tsum_cpu   = 0._wp
+         s_timer%next%tsum_clock = 0._wp  
+         s_timer%next%tmax_cpu   = 0._wp
+         s_timer%next%tmax_clock = 0._wp
+         s_timer%next%tmin_cpu   = 0._wp
+         s_timer%next%tmin_clock = 0._wp
+         s_timer%next%tsub_cpu   = 0._wp
+         s_timer%next%tsub_clock = 0._wp
+         s_timer%next%ncount      = 0
+         s_timer%next%ncount_rate = 0
+         s_timer%next%ncount_max  = 0
+         s_timer%next%niter       = 0
+         s_timer%next%l_tdone  = .FALSE.
+         s_timer%next%parent_section => NULL()
+         s_timer%next%prev => s_timer
+         s_timer%next%next => NULL()
+         s_timer => s_timer%next
+
+         ! are we inside a section
+         s_wrk => s_timer%prev
+         ll_section = .FALSE.
+         DO WHILE( ASSOCIATED(s_wrk) .AND. .NOT. ll_section )
+            IF( .NOT. s_wrk%l_tdone ) THEN
+               ll_section = .TRUE.
+               s_timer%parent_section => s_wrk 
+            ENDIF
+            s_wrk => s_wrk%prev
+         END DO 
+      ENDIF         
+      !
+   END SUBROUTINE timing_ini_var
+
+
+   SUBROUTINE timing_reset
+      !!----------------------------------------------------------------------
+      !!               ***  ROUTINE timing_reset  ***
+      !! ** Purpose :   go to root of timing tree 
+      !!----------------------------------------------------------------------
+      l_initdone = .TRUE. 
+!      IF(lwp) WRITE(numout,*)
+!      IF(lwp) WRITE(numout,*) 'timing_reset : instrumented routines for timing'
+!      IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~'
+!      CALL timing_list(s_timer_root)
+!      WRITE(numout,*)
+      !
+   END SUBROUTINE timing_reset
+
+
+   RECURSIVE SUBROUTINE timing_list(ptr)
+   
+      TYPE(timer), POINTER, INTENT(inout) :: ptr
+      !
+      IF( ASSOCIATED(ptr%next) ) CALL timing_list(ptr%next)
+      IF(lwp) WRITE(numout,*)'   ', ptr%cname   
+      !
+   END SUBROUTINE timing_list
+
+
+   SUBROUTINE insert(sd_current, sd_root ,sd_ptr)
+      !!----------------------------------------------------------------------
+      !!               ***  ROUTINE insert  ***
+      !! ** Purpose :   insert an element in timer structure
+      !!----------------------------------------------------------------------
+      TYPE(timer), POINTER, INTENT(inout) :: sd_current, sd_root, sd_ptr
+      !
+     
+      IF( ASSOCIATED( sd_current, sd_root ) ) THEN
+         ! If our current element is the root element then
+         ! replace it with the one being inserted
+         sd_root => sd_ptr
+      ELSE
+         sd_current%prev%next => sd_ptr
+      END IF
+      sd_ptr%next     => sd_current
+      sd_ptr%prev     => sd_current%prev
+      sd_current%prev => sd_ptr
+      ! Nullify the pointer to the new element now that it is held
+      ! within the list. If we don't do this then a subsequent call
+      ! to ALLOCATE memory to this pointer will fail.
+      sd_ptr => NULL()
+      !    
+   END SUBROUTINE insert
+  
+  
+   SUBROUTINE suppress(sd_ptr)
+      !!----------------------------------------------------------------------
+      !!               ***  ROUTINE suppress  ***
+      !! ** Purpose :   supress an element in timer structure
+      !!----------------------------------------------------------------------
+      TYPE(timer), POINTER, INTENT(inout) :: sd_ptr
+      !
+      TYPE(timer), POINTER :: sl_temp
+    
+      sl_temp => sd_ptr
+      sd_ptr => sd_ptr%next    
+      IF ( ASSOCIATED(sl_temp%next) ) sl_temp%next%prev => sl_temp%prev
+      DEALLOCATE(sl_temp)
+      sl_temp => NULL()
+      !
+    END SUBROUTINE suppress
+
+   !!=====================================================================
+END MODULE timing
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/trc_oce.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/trc_oce.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/trc_oce.F90	(revision 9570)
@@ -0,0 +1,259 @@
+MODULE trc_oce
+   !!======================================================================
+   !!                      ***  MODULE  trc_oce  ***
+   !! Ocean passive tracer  :  share SMS/Ocean variables
+   !!======================================================================
+   !! History :  1.0  !  2004-03  (C. Ethe)  Original code
+   !!----------------------------------------------------------------------
+
+   !!----------------------------------------------------------------------
+   !!   trc_oce_rgb   : tabulated attenuation coefficients for RGB light penetration         
+   !!----------------------------------------------------------------------
+   USE par_oce        ! ocean parameters
+   USE dom_oce        ! ocean space and time domain
+   !
+   USE in_out_manager ! I/O manager
+   USE lib_mpp        ! MPP library
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC   trc_oce_rgb        ! routine called by traqsr.F90
+   PUBLIC   trc_oce_rgb_read   ! routine called by traqsr.F90
+   PUBLIC   trc_oce_ext_lev    ! function called by traqsr.F90 at least
+   PUBLIC   trc_oce_alloc      ! function called by nemogcm.F90
+
+   LOGICAL , PUBLIC ::   l_co2cpl  = .false.   !: atmospheric pco2 recieved from oasis
+   LOGICAL , PUBLIC ::   l_offline = .false.   !: offline passive tracers flag
+   INTEGER , PUBLIC ::   nn_dttrc              !: frequency of step on passive tracers
+   REAL(wp), PUBLIC ::   r_si2                 !: largest depth of extinction (blue & 0.01 mg.m-3)  (RGB)
+   !
+   REAL(wp), PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:,:,:) ::   etot3     !: light absortion coefficient
+   REAL(wp), PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:,:)   ::   oce_co2   !: ocean carbon flux
+
+#if defined key_top 
+   !!----------------------------------------------------------------------
+   !!   'key_top'                                                 bio-model          
+   !!----------------------------------------------------------------------
+   LOGICAL, PUBLIC, PARAMETER ::   lk_top     = .TRUE.   !: TOP model
+#else
+   !!----------------------------------------------------------------------
+   !! Default option                          No bio-model light absorption      
+   !!----------------------------------------------------------------------
+   LOGICAL, PUBLIC, PARAMETER ::   lk_top     = .FALSE.   !: TOP model
+#endif
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.3 , NEMO Consortium (2010)
+   !! $Id$ 
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   INTEGER FUNCTION trc_oce_alloc()
+      !!----------------------------------------------------------------------
+      !!                  ***  trc_oce_alloc  ***
+      !!----------------------------------------------------------------------
+      ALLOCATE( etot3(jpi,jpj,jpk), oce_co2(jpi,jpj), STAT=trc_oce_alloc )
+      IF( trc_oce_alloc /= 0 )   CALL ctl_warn('trc_oce_alloc: failed to allocate etot3 array')
+      !
+   END FUNCTION trc_oce_alloc
+
+
+   SUBROUTINE trc_oce_rgb( prgb )
+      !!---------------------------------------------------------------------
+      !!                  ***  ROUTINE p4z_opt_init  ***
+      !!
+      !! ** Purpose :   Initialization of of the optical scheme
+      !!
+      !! ** Method  :   Set a look up table for the optical coefficients
+      !!                i.e. the attenuation coefficient for R-G-B light 
+      !!                tabulated in Chlorophyll class (from JM Andre)
+      !!
+      !! ** Action  :   prgb(3,61) tabulated R-G-B attenuation coef. 
+      !!
+      !! Reference  : Lengaigne et al. 2007, Clim. Dyn., V28, 5, 503-516.
+      !!----------------------------------------------------------------------
+      REAL(wp), DIMENSION(3,61), INTENT(out) ::   prgb   ! tabulated attenuation coefficient
+      !
+      INTEGER  ::   jc     ! dummy loop indice
+      INTEGER  ::   irgb   ! temporary integer
+      REAL(wp) ::   zchl   ! temporary scalar
+      REAL(wp), DIMENSION(4,61) ::   zrgb   ! tabulated attenuation coefficient (formerly read in 'kRGB61.txt')
+      !!----------------------------------------------------------------------
+      !
+      IF(lwp) THEN
+         WRITE(numout,*)
+         WRITE(numout,*) '   trc_oce_rgb : Initialisation of the optical look-up table'
+         WRITE(numout,*) '   ~~~~~~~~~~~ '
+      ENDIF
+      !
+      !  Chlorophyll        !     Blue attenuation     !     Green attenuation    !     Red attenuation      !
+      zrgb(1, 1) =  0.010   ;   zrgb(2, 1) = 0.01618   ;   zrgb(3, 1) = 0.07464   ;   zrgb(4, 1) = 0.37807
+      zrgb(1, 2) =  0.011   ;   zrgb(2, 2) = 0.01654   ;   zrgb(3, 2) = 0.07480   ;   zrgb(4, 2) = 0.37823
+      zrgb(1, 3) =  0.013   ;   zrgb(2, 3) = 0.01693   ;   zrgb(3, 3) = 0.07499   ;   zrgb(4, 3) = 0.37840
+      zrgb(1, 4) =  0.014   ;   zrgb(2, 4) = 0.01736   ;   zrgb(3, 4) = 0.07518   ;   zrgb(4, 4) = 0.37859
+      zrgb(1, 5) =  0.016   ;   zrgb(2, 5) = 0.01782   ;   zrgb(3, 5) = 0.07539   ;   zrgb(4, 5) = 0.37879
+      zrgb(1, 6) =  0.018   ;   zrgb(2, 6) = 0.01831   ;   zrgb(3, 6) = 0.07562   ;   zrgb(4, 6) = 0.37900
+      zrgb(1, 7) =  0.020   ;   zrgb(2, 7) = 0.01885   ;   zrgb(3, 7) = 0.07586   ;   zrgb(4, 7) = 0.37923
+      zrgb(1, 8) =  0.022   ;   zrgb(2, 8) = 0.01943   ;   zrgb(3, 8) = 0.07613   ;   zrgb(4, 8) = 0.37948
+      zrgb(1, 9) =  0.025   ;   zrgb(2, 9) = 0.02005   ;   zrgb(3, 9) = 0.07641   ;   zrgb(4, 9) = 0.37976
+      zrgb(1,10) =  0.028   ;   zrgb(2,10) = 0.02073   ;   zrgb(3,10) = 0.07672   ;   zrgb(4,10) = 0.38005
+      zrgb(1,11) =  0.032   ;   zrgb(2,11) = 0.02146   ;   zrgb(3,11) = 0.07705   ;   zrgb(4,11) = 0.38036
+      zrgb(1,12) =  0.035   ;   zrgb(2,12) = 0.02224   ;   zrgb(3,12) = 0.07741   ;   zrgb(4,12) = 0.38070
+      zrgb(1,13) =  0.040   ;   zrgb(2,13) = 0.02310   ;   zrgb(3,13) = 0.07780   ;   zrgb(4,13) = 0.38107
+      zrgb(1,14) =  0.045   ;   zrgb(2,14) = 0.02402   ;   zrgb(3,14) = 0.07821   ;   zrgb(4,14) = 0.38146
+      zrgb(1,15) =  0.050   ;   zrgb(2,15) = 0.02501   ;   zrgb(3,15) = 0.07866   ;   zrgb(4,15) = 0.38189
+      zrgb(1,16) =  0.056   ;   zrgb(2,16) = 0.02608   ;   zrgb(3,16) = 0.07914   ;   zrgb(4,16) = 0.38235
+      zrgb(1,17) =  0.063   ;   zrgb(2,17) = 0.02724   ;   zrgb(3,17) = 0.07967   ;   zrgb(4,17) = 0.38285
+      zrgb(1,18) =  0.071   ;   zrgb(2,18) = 0.02849   ;   zrgb(3,18) = 0.08023   ;   zrgb(4,18) = 0.38338
+      zrgb(1,19) =  0.079   ;   zrgb(2,19) = 0.02984   ;   zrgb(3,19) = 0.08083   ;   zrgb(4,19) = 0.38396
+      zrgb(1,20) =  0.089   ;   zrgb(2,20) = 0.03131   ;   zrgb(3,20) = 0.08149   ;   zrgb(4,20) = 0.38458
+      zrgb(1,21) =  0.100   ;   zrgb(2,21) = 0.03288   ;   zrgb(3,21) = 0.08219   ;   zrgb(4,21) = 0.38526
+      zrgb(1,22) =  0.112   ;   zrgb(2,22) = 0.03459   ;   zrgb(3,22) = 0.08295   ;   zrgb(4,22) = 0.38598
+      zrgb(1,23) =  0.126   ;   zrgb(2,23) = 0.03643   ;   zrgb(3,23) = 0.08377   ;   zrgb(4,23) = 0.38676
+      zrgb(1,24) =  0.141   ;   zrgb(2,24) = 0.03842   ;   zrgb(3,24) = 0.08466   ;   zrgb(4,24) = 0.38761
+      zrgb(1,25) =  0.158   ;   zrgb(2,25) = 0.04057   ;   zrgb(3,25) = 0.08561   ;   zrgb(4,25) = 0.38852
+      zrgb(1,26) =  0.178   ;   zrgb(2,26) = 0.04289   ;   zrgb(3,26) = 0.08664   ;   zrgb(4,26) = 0.38950
+      zrgb(1,27) =  0.200   ;   zrgb(2,27) = 0.04540   ;   zrgb(3,27) = 0.08775   ;   zrgb(4,27) = 0.39056
+      zrgb(1,28) =  0.224   ;   zrgb(2,28) = 0.04811   ;   zrgb(3,28) = 0.08894   ;   zrgb(4,28) = 0.39171
+      zrgb(1,29) =  0.251   ;   zrgb(2,29) = 0.05103   ;   zrgb(3,29) = 0.09023   ;   zrgb(4,29) = 0.39294
+      zrgb(1,30) =  0.282   ;   zrgb(2,30) = 0.05420   ;   zrgb(3,30) = 0.09162   ;   zrgb(4,30) = 0.39428
+      zrgb(1,31) =  0.316   ;   zrgb(2,31) = 0.05761   ;   zrgb(3,31) = 0.09312   ;   zrgb(4,31) = 0.39572
+      zrgb(1,32) =  0.355   ;   zrgb(2,32) = 0.06130   ;   zrgb(3,32) = 0.09474   ;   zrgb(4,32) = 0.39727
+      zrgb(1,33) =  0.398   ;   zrgb(2,33) = 0.06529   ;   zrgb(3,33) = 0.09649   ;   zrgb(4,33) = 0.39894
+      zrgb(1,34) =  0.447   ;   zrgb(2,34) = 0.06959   ;   zrgb(3,34) = 0.09837   ;   zrgb(4,34) = 0.40075
+      zrgb(1,35) =  0.501   ;   zrgb(2,35) = 0.07424   ;   zrgb(3,35) = 0.10040   ;   zrgb(4,35) = 0.40270
+      zrgb(1,36) =  0.562   ;   zrgb(2,36) = 0.07927   ;   zrgb(3,36) = 0.10259   ;   zrgb(4,36) = 0.40480
+      zrgb(1,37) =  0.631   ;   zrgb(2,37) = 0.08470   ;   zrgb(3,37) = 0.10495   ;   zrgb(4,37) = 0.40707
+      zrgb(1,38) =  0.708   ;   zrgb(2,38) = 0.09056   ;   zrgb(3,38) = 0.10749   ;   zrgb(4,38) = 0.40952
+      zrgb(1,39) =  0.794   ;   zrgb(2,39) = 0.09690   ;   zrgb(3,39) = 0.11024   ;   zrgb(4,39) = 0.41216
+      zrgb(1,40) =  0.891   ;   zrgb(2,40) = 0.10374   ;   zrgb(3,40) = 0.11320   ;   zrgb(4,40) = 0.41502
+      zrgb(1,41) =  1.000   ;   zrgb(2,41) = 0.11114   ;   zrgb(3,41) = 0.11639   ;   zrgb(4,41) = 0.41809
+      zrgb(1,42) =  1.122   ;   zrgb(2,42) = 0.11912   ;   zrgb(3,42) = 0.11984   ;   zrgb(4,42) = 0.42142
+      zrgb(1,43) =  1.259   ;   zrgb(2,43) = 0.12775   ;   zrgb(3,43) = 0.12356   ;   zrgb(4,43) = 0.42500
+      zrgb(1,44) =  1.413   ;   zrgb(2,44) = 0.13707   ;   zrgb(3,44) = 0.12757   ;   zrgb(4,44) = 0.42887
+      zrgb(1,45) =  1.585   ;   zrgb(2,45) = 0.14715   ;   zrgb(3,45) = 0.13189   ;   zrgb(4,45) = 0.43304
+      zrgb(1,46) =  1.778   ;   zrgb(2,46) = 0.15803   ;   zrgb(3,46) = 0.13655   ;   zrgb(4,46) = 0.43754
+      zrgb(1,47) =  1.995   ;   zrgb(2,47) = 0.16978   ;   zrgb(3,47) = 0.14158   ;   zrgb(4,47) = 0.44240
+      zrgb(1,48) =  2.239   ;   zrgb(2,48) = 0.18248   ;   zrgb(3,48) = 0.14701   ;   zrgb(4,48) = 0.44765
+      zrgb(1,49) =  2.512   ;   zrgb(2,49) = 0.19620   ;   zrgb(3,49) = 0.15286   ;   zrgb(4,49) = 0.45331
+      zrgb(1,50) =  2.818   ;   zrgb(2,50) = 0.21102   ;   zrgb(3,50) = 0.15918   ;   zrgb(4,50) = 0.45942
+      zrgb(1,51) =  3.162   ;   zrgb(2,51) = 0.22703   ;   zrgb(3,51) = 0.16599   ;   zrgb(4,51) = 0.46601
+      zrgb(1,52) =  3.548   ;   zrgb(2,52) = 0.24433   ;   zrgb(3,52) = 0.17334   ;   zrgb(4,52) = 0.47313
+      zrgb(1,53) =  3.981   ;   zrgb(2,53) = 0.26301   ;   zrgb(3,53) = 0.18126   ;   zrgb(4,53) = 0.48080
+      zrgb(1,54) =  4.467   ;   zrgb(2,54) = 0.28320   ;   zrgb(3,54) = 0.18981   ;   zrgb(4,54) = 0.48909
+      zrgb(1,55) =  5.012   ;   zrgb(2,55) = 0.30502   ;   zrgb(3,55) = 0.19903   ;   zrgb(4,55) = 0.49803
+      zrgb(1,56) =  5.623   ;   zrgb(2,56) = 0.32858   ;   zrgb(3,56) = 0.20898   ;   zrgb(4,56) = 0.50768
+      zrgb(1,57) =  6.310   ;   zrgb(2,57) = 0.35404   ;   zrgb(3,57) = 0.21971   ;   zrgb(4,57) = 0.51810
+      zrgb(1,58) =  7.079   ;   zrgb(2,58) = 0.38154   ;   zrgb(3,58) = 0.23129   ;   zrgb(4,58) = 0.52934
+      zrgb(1,59) =  7.943   ;   zrgb(2,59) = 0.41125   ;   zrgb(3,59) = 0.24378   ;   zrgb(4,59) = 0.54147
+      zrgb(1,60) =  8.912   ;   zrgb(2,60) = 0.44336   ;   zrgb(3,60) = 0.25725   ;   zrgb(4,60) = 0.55457
+      zrgb(1,61) = 10.000   ;   zrgb(2,61) = 0.47804   ;   zrgb(3,61) = 0.27178   ;   zrgb(4,61) = 0.56870
+      !
+      prgb(:,:) = zrgb(2:4,:)
+      !
+      r_si2 = 1.e0 / zrgb(2, 1)        ! blue with the smallest chlorophyll concentration)
+      IF(lwp) WRITE(numout,*) '      RGB longest depth of extinction    r_si2 = ', r_si2
+      !
+      DO jc = 1, 61                         ! check
+         zchl = zrgb(1,jc)
+         irgb = NINT( 41 + 20.* LOG10( zchl ) + 1.e-15 )
+         IF(lwp .AND. nn_print >= 1 ) WRITE(numout,*) '    jc =', jc, '  Chl = ', zchl, '  irgb = ', irgb
+         IF( irgb /= jc ) THEN
+            IF(lwp) WRITE(numout,*) '    jc =', jc, '  Chl = ', zchl, '  Chl class = ', irgb
+            CALL ctl_stop( 'trc_oce_rgb : inconsistency in Chl tabulated attenuation coeff.' )
+         ENDIF
+      END DO
+      !
+   END SUBROUTINE trc_oce_rgb
+
+
+   SUBROUTINE trc_oce_rgb_read( prgb )
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE p4z_opt_init  ***
+      !!
+      !! ** Purpose :   Initialization of of the optical scheme
+      !!
+      !! ** Method  :   read the look up table for the optical coefficients
+      !!
+      !! ** input   :   xkrgb(61) precomputed array corresponding to the  
+      !!                          attenuation coefficient (from JM Andre)
+      !!----------------------------------------------------------------------
+      REAL(wp), DIMENSION(3,61), INTENT(out) ::   prgb   ! tabulated attenuation coefficient
+      !
+      INTEGER  ::   jc, jb ! dummy loop indice
+      INTEGER  ::   irgb   ! temporary integer
+      REAL(wp) ::   zchl   ! temporary scalar
+      INTEGER  ::   numlight
+      !!----------------------------------------------------------------------
+      !
+      IF(lwp) THEN                         ! control print
+         WRITE(numout,*)
+         WRITE(numout,*) ' trc_oce_rgb_read : optical look-up table read in kRGB61.txt file'
+         WRITE(numout,*) ' ~~~~~~~~~~~~~~~~'
+         WRITE(numout,*) 
+      ENDIF
+      !
+      CALL ctl_opn( numlight, 'kRGB61.txt', 'OLD', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp )
+      DO jc = 1, 61
+         READ(numlight,*) zchl, ( prgb(jb,jc), jb = 1, 3 )
+         irgb = NINT( 41 + 20.* LOG10( zchl ) + 1.e-15 )   
+         IF(lwp) WRITE(numout,*) '    jc =', jc, '  Chl = ', zchl, '  irgb = ', irgb  
+         IF( irgb /= jc ) THEN  
+            IF(lwp) WRITE(numout,*) '    jc =', jc, '  Chl = ', zchl, '  Chl class = ', irgb
+            CALL ctl_stop( 'trc_oce_rgb_read : inconsistency in Chl tabulated attenuation coeff.' )
+         ENDIF
+      END DO
+      CLOSE( numlight )
+      !
+      r_si2 = 1.e0 / prgb(1, 1)      ! blue with the smallest chlorophyll concentration)
+      IF(lwp) WRITE(numout,*) '      RGB longest depth of extinction    r_si2 = ', r_si2
+      !
+   END SUBROUTINE trc_oce_rgb_read
+
+
+   FUNCTION trc_oce_ext_lev( prldex, pqsr_frc ) RESULT( pjl )
+      !!----------------------------------------------------------------------
+      !!                 ***  ROUTINE trc_oce_ext_lev  ***
+      !!       
+      !! ** Purpose :   compute max. level for light penetration
+      !!          
+      !! ** Method  :   the function provides the level at which irradiance 
+      !!                becomes negligible (i.e. = 1.e-15 W/m2) for 3 or 2 bands light
+      !!                penetration: I(z) = pqsr_frc * EXP(hext/prldex) = 1.e-15 W/m2
+      !!                # prldex is the longest depth of extinction:
+      !!                   - prldex = 23 m (2 bands case)
+      !!                   - prldex = 62 m (3 bands case: blue waveband & 0.01 mg/m2 for the chlorophyll)
+      !!                # pqsr_frc is the fraction of solar radiation which penetrates,
+      !!                considering Qsr=240 W/m2 and rn_abs = 0.58:
+      !!                   - pqsr_frc = Qsr * (1-rn_abs)   = 1.00e2 W/m2 (2 bands case)
+      !!                   - pqsr_frc = Qsr * (1-rn_abs)/3 = 0.33e2 W/m2 (3 bands case & equi-partition)
+      !!
+      !!----------------------------------------------------------------------
+      REAL(wp), INTENT(in) ::   prldex    ! longest depth of extinction
+      REAL(wp), INTENT(in) ::   pqsr_frc  ! frac. solar radiation which penetrates 
+      !
+      INTEGER  ::   jk, pjl            ! levels
+      REAL(wp) ::   zhext              ! deepest level till which light penetrates
+      REAL(wp) ::   zprec = 15._wp     ! precision to reach -LOG10(1.e-15)
+      REAL(wp) ::   zem                ! temporary scalar 
+      !!----------------------------------------------------------------------
+      !
+      ! It is not necessary to compute anything below the following depth
+      zhext = prldex * ( LOG(10._wp) * zprec + LOG(pqsr_frc) )
+      !
+      ! Level of light extinction
+      pjl = jpkm1
+      DO jk = jpkm1, 1, -1
+         IF(SUM(tmask(:,:,jk)) > 0 ) THEN
+            zem = MAXVAL( gdepw_0(:,:,jk+1) * tmask(:,:,jk) )
+            IF( zem >= zhext )   pjl = jk                       ! last T-level reached by Qsr
+         ELSE
+            pjl = jk                                            ! or regional sea-bed depth 
+         ENDIF
+      END DO
+      !
+   END FUNCTION trc_oce_ext_lev
+
+   !!======================================================================
+END MODULE trc_oce
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/vectopt_loop_substitute.h90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/vectopt_loop_substitute.h90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/OCE_SRC/vectopt_loop_substitute.h90	(revision 9570)
@@ -0,0 +1,18 @@
+   !!----------------------------------------------------------------------
+   !!                   ***  vectopt_loop_substitute  ***
+   !!----------------------------------------------------------------------
+   !! ** purpose :   substitute the inner loop start/end indices with CPP macro
+   !!                allow unrolling of do-loop (useful with vector processors)
+   !!----------------------------------------------------------------------
+   !!----------------------------------------------------------------------
+   !! NEMO/OCE 3.7 , NEMO Consortium (2014)
+   !! $Id$ 
+   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+#if defined key_vectopt_loop
+#  define   fs_2       1
+#  define   fs_jpim1   jpi
+#else
+#  define   fs_2       2
+#  define   fs_jpim1   jpim1
+#endif
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/SAO_SRC/nemogcm.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/SAO_SRC/nemogcm.F90	(revision 9569)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/SAO_SRC/nemogcm.F90	(revision 9570)
@@ -4,5 +4,5 @@
    !! Ocean system   : NEMO GCM (ocean dynamics, on-line tracers, biochemistry and sea-ice)
    !!======================================================================
-   !! History :  3.6  ! 2015-12  (A. Ryan) Original code   (from OPA_SRC/) 
+   !! History :  3.6  ! 2015-12  (A. Ryan) Original code   (from OCE_SRC/) 
    !!            4.0  ! 2016-11  (G. Madec, S. Flavoni)  domain configuration / user defined interface
    !!----------------------------------------------------------------------
@@ -47,5 +47,5 @@
 
    !!----------------------------------------------------------------------
-   !! NEMO/OPA 4.0 , NEMO Consortium (2016)
+   !! NEMO/OCE 4.0 , NEMO Consortium (2016)
    !! $Id$
    !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/SAO_SRC/sao_data.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/SAO_SRC/sao_data.F90	(revision 9569)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/SAO_SRC/sao_data.F90	(revision 9570)
@@ -20,5 +20,5 @@
    
    !!----------------------------------------------------------------------
-   !! NEMO/OPA 3.7 , NEMO Consortium (2015)
+   !! NEMO/OCE 3.7 , NEMO Consortium (2015)
    !! $Id: trazdf_imp.F90 6140 2015-12-21 11:35:23Z timgraham $
    !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/SAO_SRC/sao_intp.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/SAO_SRC/sao_intp.F90	(revision 9569)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/SAO_SRC/sao_intp.F90	(revision 9570)
@@ -19,5 +19,5 @@
 
    !!----------------------------------------------------------------------
-   !! NEMO/OPA 3.7 , NEMO Consortium (2015)
+   !! NEMO/OCE 3.7 , NEMO Consortium (2015)
    !! $Id: trazdf_imp.F90 6140 2015-12-21 11:35:23Z timgraham $
    !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/SAO_SRC/sao_read.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/SAO_SRC/sao_read.F90	(revision 9569)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/SAO_SRC/sao_read.F90	(revision 9570)
@@ -22,5 +22,5 @@
 
    !!----------------------------------------------------------------------
-   !! NEMO/OPA 3.7 , NEMO Consortium (2015)
+   !! NEMO/OCE 3.7 , NEMO Consortium (2015)
    !! $Id: trazdf_imp.F90 6140 2015-12-21 11:35:23Z timgraham $
    !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/SAS_SRC/daymod.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/SAS_SRC/daymod.F90	(revision 9569)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/SAS_SRC/daymod.F90	(revision 9570)
@@ -44,5 +44,5 @@
 
    !!----------------------------------------------------------------------
-   !! NEMO/OPA 4.0 , NEMO Consortium (2016)
+   !! NEMO/OCE 4.0 , NEMO Consortium (2016)
    !! $Id$
    !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/SAS_SRC/diawri.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/SAS_SRC/diawri.F90	(revision 9569)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/SAS_SRC/diawri.F90	(revision 9570)
@@ -38,5 +38,5 @@
    USE iom
    USE ioipsl
-#if defined key_lim3
+#if defined key_si3
    USE icewri
 #endif
@@ -60,5 +60,5 @@
 #  include "vectopt_loop_substitute.h90"
    !!----------------------------------------------------------------------
-   !! NEMO/OPA 3.3 , NEMO Consortium (2010)
+   !! NEMO/OCE 3.3 , NEMO Consortium (2010)
    !! $Id$
    !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
@@ -394,5 +394,5 @@
          &          jpi, jpj, nh_i, 1  , 1, 1  , -99 , 32, clop, zsto, zout )
 
-#if defined key_lim3
+#if defined key_si3
       IF( nn_ice == 2 ) THEN   ! condition needed in case agrif + lim but no-ice in child grid
          CALL ice_wri_state( kt, id_i, nh_i )
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/SAS_SRC/nemogcm.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/SAS_SRC/nemogcm.F90	(revision 9569)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/SAS_SRC/nemogcm.F90	(revision 9570)
@@ -50,5 +50,5 @@
 
    !!----------------------------------------------------------------------
-   !! NEMO/OPA 4.0 , NEMO Consortium (2018)
+   !! NEMO/OCE 4.0 , NEMO Consortium (2018)
    !! $Id$
    !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
@@ -85,6 +85,6 @@
       CALL Agrif_Declare_Var_top   !  "      "   "   "      "  TOP
 # endif
-# if defined key_lim3
-      CALL Agrif_Declare_Var_lim3  !  "      "   "   "      "  LIM3
+# if defined key_si3
+      CALL Agrif_Declare_Var_si3  !  "      "   "   "      "  LIM3
 # endif
 #endif
@@ -475,5 +475,5 @@
       ierr =        dia_wri_alloc()
       ierr = ierr + dom_oce_alloc()          ! ocean domain
-      ierr = ierr + oce_alloc    ()          ! (tsn...) needed for agrif and/or ESIM and bdy
+      ierr = ierr + oce_alloc    ()          ! (tsn...) needed for agrif and/or SI3 and bdy
       ierr = ierr + bdy_oce_alloc()          ! bdy masks (incl. initialization)
       !
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/SAS_SRC/step.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/SAS_SRC/step.F90	(revision 9569)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/SAS_SRC/step.F90	(revision 9570)
@@ -38,6 +38,6 @@
 #if defined key_agrif
    USE agrif_oce, ONLY: lk_agrif_debug
-#if defined key_lim3
-   USE agrif_lim3_update
+#if defined key_si3
+   USE agrif_si3_update
 #endif
 #endif
@@ -49,5 +49,5 @@
 
    !!----------------------------------------------------------------------
-   !! NEMO/OPA 4.0 , NEMO Consortium (2017)
+   !! NEMO/OCE 4.0 , NEMO Consortium (2017)
    !! $Id$
    !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
@@ -109,6 +109,6 @@
 
       IF( Agrif_NbStepint() == 0 ) THEN               ! AGRIF Update from zoom N to zoom 1 then to Parent 
-#if defined key_lim3
-                             CALL Agrif_Update_lim3( kstp )   ! update sea-ice
+#if defined key_si3
+                             CALL Agrif_Update_si3( kstp )   ! update sea-ice
 #endif
       ENDIF
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/SAS_SRC/stpctl.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/SAS_SRC/stpctl.F90	(revision 9569)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/SAS_SRC/stpctl.F90	(revision 9570)
@@ -33,5 +33,5 @@
    INTEGER  ::   idrun, idtime, idssh, idu, ids, istatus
    !!----------------------------------------------------------------------
-   !! NEMO/OPA 4.0 , NEMO Consortium (2017)
+   !! NEMO/OCE 4.0 , NEMO Consortium (2017)
    !! $Id$
    !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/TOP_SRC/C14/trcatm_c14.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/TOP_SRC/C14/trcatm_c14.F90	(revision 9569)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/TOP_SRC/C14/trcatm_c14.F90	(revision 9570)
@@ -22,5 +22,5 @@
    !
    !!----------------------------------------------------------------------
-   !! NEMO/OPA 3.3 , NEMO Consortium (2010)
+   !! NEMO/OCE 3.3 , NEMO Consortium (2010)
    !! $Id: trcatm_c14.F90 .... $ 
    !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zbio.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zbio.F90	(revision 9569)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zbio.F90	(revision 9570)
@@ -15,10 +15,10 @@
    USE p4zsink         !  vertical flux of particulate matter due to sinking
    USE p4zopt          !  optical model
-   USE p4zlim          !  Co-limitations of differents nutrients
+   USE p4zice          !  Co-limitations of differents nutrients
    USE p4zprod         !  Growth rate of the 2 phyto groups
    USE p4zmort         !  Mortality terms for phytoplankton
    USE p4zmicro        !  Sources and sinks of microzooplankton
    USE p4zmeso         !  Sources and sinks of mesozooplankton
-   USE p5zlim          !  Co-limitations of differents nutrients
+   USE p5zice          !  Co-limitations of differents nutrients
    USE p5zprod         !  Growth rate of the 2 phyto groups
    USE p5zmort         !  Mortality terms for phytoplankton
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zice.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zice.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zice.F90	(revision 9570)
@@ -0,0 +1,313 @@
+MODULE p4zice
+   !!======================================================================
+   !!                         ***  MODULE p4zice  ***
+   !! TOP :   PISCES 
+   !!======================================================================
+   !! History :   1.0  !  2004     (O. Aumont) Original code
+   !!             2.0  !  2007-12  (C. Ethe, G. Madec)  F90
+   !!             3.4  !  2011-04  (O. Aumont, C. Ethe) Limitation for iron modelled in quota 
+   !!----------------------------------------------------------------------
+   !!   p4z_lim        :   Compute the nutrients limitation terms 
+   !!   p4z_lim_init   :   Read the namelist 
+   !!----------------------------------------------------------------------
+   USE oce_trc         ! Shared ocean-passive tracers variables
+   USE trc             ! Tracers defined
+   USE sms_pisces      ! PISCES variables
+   USE iom             !  I/O manager
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC p4z_lim    
+   PUBLIC p4z_lim_init    
+   PUBLIC p4z_lim_alloc
+
+   !! * Shared module variables
+   REAL(wp), PUBLIC ::  concnno3    !:  NO3, PO4 half saturation   
+   REAL(wp), PUBLIC ::  concdno3    !:  Phosphate half saturation for diatoms  
+   REAL(wp), PUBLIC ::  concnnh4    !:  NH4 half saturation for phyto  
+   REAL(wp), PUBLIC ::  concdnh4    !:  NH4 half saturation for diatoms
+   REAL(wp), PUBLIC ::  concnfer    !:  Iron half saturation for nanophyto 
+   REAL(wp), PUBLIC ::  concdfer    !:  Iron half saturation for diatoms  
+   REAL(wp), PUBLIC ::  concbno3    !:  NO3 half saturation  for bacteria 
+   REAL(wp), PUBLIC ::  concbnh4    !:  NH4 half saturation for bacteria
+   REAL(wp), PUBLIC ::  xsizedia    !:  Minimum size criteria for diatoms
+   REAL(wp), PUBLIC ::  xsizephy    !:  Minimum size criteria for nanophyto
+   REAL(wp), PUBLIC ::  xsizern     !:  Size ratio for nanophytoplankton
+   REAL(wp), PUBLIC ::  xsizerd     !:  Size ratio for diatoms
+   REAL(wp), PUBLIC ::  xksi1       !:  half saturation constant for Si uptake 
+   REAL(wp), PUBLIC ::  xksi2       !:  half saturation constant for Si/C 
+   REAL(wp), PUBLIC ::  xkdoc       !:  2nd half-sat. of DOC remineralization  
+   REAL(wp), PUBLIC ::  concbfe     !:  Fe half saturation for bacteria 
+   REAL(wp), PUBLIC ::  oxymin      !:  half saturation constant for anoxia
+   REAL(wp), PUBLIC ::  qnfelim     !:  optimal Fe quota for nanophyto
+   REAL(wp), PUBLIC ::  qdfelim     !:  optimal Fe quota for diatoms
+   REAL(wp), PUBLIC ::  caco3r      !:  mean rainratio 
+
+   !!* Phytoplankton limitation terms
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)  ::   xnanono3   !: ???
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)  ::   xdiatno3   !: ???
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)  ::   xnanonh4   !: ???
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)  ::   xdiatnh4   !: ???
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)  ::   xnanopo4   !: ???
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)  ::   xdiatpo4   !: ???
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)  ::   xlimphy    !: ???
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)  ::   xlimdia    !: ???
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)  ::   xlimnfe    !: ???
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)  ::   xlimdfe    !: ???
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)  ::   xlimsi     !: ???
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)  ::   xlimbac    !: ??
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)  ::   xlimbacl   !: ??
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)  ::   concdfe    !: ???
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)  ::   concnfe    !: ???
+
+   ! Coefficient for iron limitation
+   REAL(wp) ::  xcoef1   = 0.0016  / 55.85  
+   REAL(wp) ::  xcoef2   = 1.21E-5 * 14. / 55.85 / 7.625 * 0.5 * 1.5
+   REAL(wp) ::  xcoef3   = 1.15E-4 * 14. / 55.85 / 7.625 * 0.5 
+
+   !!----------------------------------------------------------------------
+   !! NEMO/TOP 3.3 , NEMO Consortium (2010)
+   !! $Id: p4zice.F90 3160 2011-11-20 14:27:18Z cetlod $ 
+   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+CONTAINS
+
+   SUBROUTINE p4z_lim( kt, knt )
+      !!---------------------------------------------------------------------
+      !!                     ***  ROUTINE p4z_lim  ***
+      !!
+      !! ** Purpose :   Compute the co-limitations by the various nutrients
+      !!              for the various phytoplankton species
+      !!
+      !! ** Method  : - ???
+      !!---------------------------------------------------------------------
+      INTEGER, INTENT(in)  :: kt, knt
+      !
+      INTEGER  ::   ji, jj, jk
+      REAL(wp) ::   zlim1, zlim2, zlim3, zlim4, zno3, zferlim
+      REAL(wp) ::   zconcd, zconcd2, zconcn, zconcn2
+      REAL(wp) ::   z1_trbdia, z1_trbphy, ztem1, ztem2, zetot1, zetot2
+      REAL(wp) ::   zdenom, zratio, zironmin
+      REAL(wp) ::   zconc1d, zconc1dnh4, zconc0n, zconc0nnh4   
+      !!---------------------------------------------------------------------
+      !
+      IF( ln_timing )   CALL timing_start('p4z_lim')
+      !
+      DO jk = 1, jpkm1
+         DO jj = 1, jpj
+            DO ji = 1, jpi
+               
+               ! Tuning of the iron concentration to a minimum level that is set to the detection limit
+               !-------------------------------------
+               zno3    = trb(ji,jj,jk,jpno3) / 40.e-6
+               zferlim = MAX( 3e-11 * zno3 * zno3, 5e-12 )
+               zferlim = MIN( zferlim, 7e-11 )
+               trb(ji,jj,jk,jpfer) = MAX( trb(ji,jj,jk,jpfer), zferlim )
+
+               ! Computation of a variable Ks for iron on diatoms taking into account
+               ! that increasing biomass is made of generally bigger cells
+               !------------------------------------------------
+               zconcd   = MAX( 0.e0 , trb(ji,jj,jk,jpdia) - xsizedia )
+               zconcd2  = trb(ji,jj,jk,jpdia) - zconcd
+               zconcn   = MAX( 0.e0 , trb(ji,jj,jk,jpphy) - xsizephy )
+               zconcn2  = trb(ji,jj,jk,jpphy) - zconcn
+               z1_trbphy   = 1. / ( trb(ji,jj,jk,jpphy) + rtrn )
+               z1_trbdia   = 1. / ( trb(ji,jj,jk,jpdia) + rtrn )
+
+               concdfe(ji,jj,jk) = MAX( concdfer, ( zconcd2 * concdfer + concdfer * xsizerd * zconcd ) * z1_trbdia )
+               zconc1d           = MAX( concdno3, ( zconcd2 * concdno3 + concdno3 * xsizerd * zconcd ) * z1_trbdia )
+               zconc1dnh4        = MAX( concdnh4, ( zconcd2 * concdnh4 + concdnh4 * xsizerd * zconcd ) * z1_trbdia )
+
+               concnfe(ji,jj,jk) = MAX( concnfer, ( zconcn2 * concnfer + concnfer * xsizern * zconcn ) * z1_trbphy )
+               zconc0n           = MAX( concnno3, ( zconcn2 * concnno3 + concnno3 * xsizern * zconcn ) * z1_trbphy )
+               zconc0nnh4        = MAX( concnnh4, ( zconcn2 * concnnh4 + concnnh4 * xsizern * zconcn ) * z1_trbphy )
+
+               ! Michaelis-Menten Limitation term for nutrients Small bacteria
+               ! -------------------------------------------------------------
+               zdenom = 1. /  ( concbno3 * concbnh4 + concbnh4 * trb(ji,jj,jk,jpno3) + concbno3 * trb(ji,jj,jk,jpnh4) )
+               xnanono3(ji,jj,jk) = trb(ji,jj,jk,jpno3) * concbnh4 * zdenom
+               xnanonh4(ji,jj,jk) = trb(ji,jj,jk,jpnh4) * concbno3 * zdenom
+               !
+               zlim1    = xnanono3(ji,jj,jk) + xnanonh4(ji,jj,jk)
+               zlim2    = trb(ji,jj,jk,jppo4) / ( trb(ji,jj,jk,jppo4) + concbnh4 )
+               zlim3    = trb(ji,jj,jk,jpfer) / ( concbfe + trb(ji,jj,jk,jpfer) )
+               zlim4    = trb(ji,jj,jk,jpdoc) / ( xkdoc   + trb(ji,jj,jk,jpdoc) )
+               xlimbacl(ji,jj,jk) = MIN( zlim1, zlim2, zlim3 )
+               xlimbac (ji,jj,jk) = MIN( zlim1, zlim2, zlim3 ) * zlim4
+
+               ! Michaelis-Menten Limitation term for nutrients Small flagellates
+               ! -----------------------------------------------
+               zdenom = 1. /  ( zconc0n * zconc0nnh4 + zconc0nnh4 * trb(ji,jj,jk,jpno3) + zconc0n * trb(ji,jj,jk,jpnh4) )
+               xnanono3(ji,jj,jk) = trb(ji,jj,jk,jpno3) * zconc0nnh4 * zdenom
+               xnanonh4(ji,jj,jk) = trb(ji,jj,jk,jpnh4) * zconc0n    * zdenom
+               !
+               zlim1    = xnanono3(ji,jj,jk) + xnanonh4(ji,jj,jk)
+               zlim2    = trb(ji,jj,jk,jppo4) / ( trb(ji,jj,jk,jppo4) + zconc0nnh4 )
+               zratio   = trb(ji,jj,jk,jpnfe) * z1_trbphy 
+               zironmin = xcoef1 * trb(ji,jj,jk,jpnch) * z1_trbphy + xcoef2 * zlim1 + xcoef3 * xnanono3(ji,jj,jk)
+               zlim3    = MAX( 0.,( zratio - zironmin ) / qnfelim )
+               xnanopo4(ji,jj,jk) = zlim2
+               xlimnfe (ji,jj,jk) = MIN( 1., zlim3 )
+               xlimphy (ji,jj,jk) = MIN( zlim1, zlim2, zlim3 )
+               !
+               !   Michaelis-Menten Limitation term for nutrients Diatoms
+               !   ----------------------------------------------
+               zdenom   = 1. / ( zconc1d * zconc1dnh4 + zconc1dnh4 * trb(ji,jj,jk,jpno3) + zconc1d * trb(ji,jj,jk,jpnh4) )
+               xdiatno3(ji,jj,jk) = trb(ji,jj,jk,jpno3) * zconc1dnh4 * zdenom
+               xdiatnh4(ji,jj,jk) = trb(ji,jj,jk,jpnh4) * zconc1d    * zdenom
+               !
+               zlim1    = xdiatno3(ji,jj,jk) + xdiatnh4(ji,jj,jk)
+               zlim2    = trb(ji,jj,jk,jppo4) / ( trb(ji,jj,jk,jppo4) + zconc1dnh4  )
+               zlim3    = trb(ji,jj,jk,jpsil) / ( trb(ji,jj,jk,jpsil) + xksi(ji,jj) )
+               zratio   = trb(ji,jj,jk,jpdfe) * z1_trbdia
+               zironmin = xcoef1 * trb(ji,jj,jk,jpdch) * z1_trbdia + xcoef2 * zlim1 + xcoef3 * xdiatno3(ji,jj,jk)
+               zlim4    = MAX( 0., ( zratio - zironmin ) / qdfelim )
+               xdiatpo4(ji,jj,jk) = zlim2
+               xlimdfe (ji,jj,jk) = MIN( 1., zlim4 )
+               xlimdia (ji,jj,jk) = MIN( zlim1, zlim2, zlim3, zlim4 )
+               xlimsi  (ji,jj,jk) = MIN( zlim1, zlim2, zlim4 )
+           END DO
+         END DO
+      END DO
+
+      ! Compute the fraction of nanophytoplankton that is made of calcifiers
+      ! --------------------------------------------------------------------
+      DO jk = 1, jpkm1
+         DO jj = 1, jpj
+            DO ji = 1, jpi
+               zlim1 =  ( trb(ji,jj,jk,jpno3) * concnnh4 + trb(ji,jj,jk,jpnh4) * concnno3 )    &
+                  &   / ( concnno3 * concnnh4 + concnnh4 * trb(ji,jj,jk,jpno3) + concnno3 * trb(ji,jj,jk,jpnh4) ) 
+               zlim2  = trb(ji,jj,jk,jppo4) / ( trb(ji,jj,jk,jppo4) + concnnh4 )
+               zlim3  = trb(ji,jj,jk,jpfer) / ( trb(ji,jj,jk,jpfer) +  5.E-11   )
+               ztem1  = MAX( 0., tsn(ji,jj,jk,jp_tem) )
+               ztem2  = tsn(ji,jj,jk,jp_tem) - 10.
+               zetot1 = MAX( 0., etot_ndcy(ji,jj,jk) - 1.) / ( 4. + etot_ndcy(ji,jj,jk) ) 
+               zetot2 = 30. / ( 30. + etot_ndcy(ji,jj,jk) ) 
+
+               xfracal(ji,jj,jk) = caco3r * MIN( zlim1, zlim2, zlim3 )                  &
+                  &                       * ztem1 / ( 0.1 + ztem1 )                     &
+                  &                       * MAX( 1., trb(ji,jj,jk,jpphy) * 1.e6 / 2. )  &
+                  &                       * zetot1 * zetot2               &
+                  &                       * ( 1. + EXP(-ztem2 * ztem2 / 25. ) )         &
+                  &                       * MIN( 1., 50. / ( hmld(ji,jj) + rtrn ) )
+               xfracal(ji,jj,jk) = MIN( 0.8 , xfracal(ji,jj,jk) )
+               xfracal(ji,jj,jk) = MAX( 0.02, xfracal(ji,jj,jk) )
+            END DO
+         END DO
+      END DO
+      !
+      DO jk = 1, jpkm1
+         DO jj = 1, jpj
+            DO ji = 1, jpi
+               ! denitrification factor computed from O2 levels
+               nitrfac(ji,jj,jk) = MAX(  0.e0, 0.4 * ( 6.e-6  - trb(ji,jj,jk,jpoxy) )    &
+                  &                                / ( oxymin + trb(ji,jj,jk,jpoxy) )  )
+               nitrfac(ji,jj,jk) = MIN( 1., nitrfac(ji,jj,jk) )
+               !
+               ! denitrification factor computed from NO3 levels
+               nitrfac2(ji,jj,jk) = MAX( 0.e0,       ( 1.E-6 - trb(ji,jj,jk,jpno3) )  &
+                  &                                / ( 1.E-6 + trb(ji,jj,jk,jpno3) ) )
+               nitrfac2(ji,jj,jk) = MIN( 1., nitrfac2(ji,jj,jk) )
+            END DO
+         END DO
+      END DO
+      !
+      IF( lk_iomput .AND. knt == nrdttrc ) THEN        ! save output diagnostics
+        IF( iom_use( "xfracal" ) )   CALL iom_put( "xfracal", xfracal(:,:,:) * tmask(:,:,:) )  ! euphotic layer deptht
+        IF( iom_use( "LNnut"   ) )   CALL iom_put( "LNnut"  , xlimphy(:,:,:) * tmask(:,:,:) )  ! Nutrient limitation term
+        IF( iom_use( "LDnut"   ) )   CALL iom_put( "LDnut"  , xlimdia(:,:,:) * tmask(:,:,:) )  ! Nutrient limitation term
+        IF( iom_use( "LNFe"    ) )   CALL iom_put( "LNFe"   , xlimnfe(:,:,:) * tmask(:,:,:) )  ! Iron limitation term
+        IF( iom_use( "LDFe"    ) )   CALL iom_put( "LDFe"   , xlimdfe(:,:,:) * tmask(:,:,:) )  ! Iron limitation term
+      ENDIF
+      !
+      IF( ln_timing )   CALL timing_stop('p4z_lim')
+      !
+   END SUBROUTINE p4z_lim
+
+
+   SUBROUTINE p4z_lim_init
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE p4z_lim_init  ***
+      !!
+      !! ** Purpose :   Initialization of nutrient limitation parameters
+      !!
+      !! ** Method  :   Read the nampislim namelist and check the parameters
+      !!      called at the first timestep (nittrc000)
+      !!
+      !! ** input   :   Namelist nampislim
+      !!
+      !!----------------------------------------------------------------------
+      INTEGER ::   ios   ! Local integer
+      !
+      NAMELIST/namp4zice/ concnno3, concdno3, concnnh4, concdnh4, concnfer, concdfer, concbfe,   &
+         &                concbno3, concbnh4, xsizedia, xsizephy, xsizern, xsizerd,          & 
+         &                xksi1, xksi2, xkdoc, qnfelim, qdfelim, caco3r, oxymin
+      !!----------------------------------------------------------------------
+      !
+      IF(lwp) THEN
+         WRITE(numout,*)
+         WRITE(numout,*) 'p4z_lim_init : initialization of nutrient limitations'
+         WRITE(numout,*) '~~~~~~~~~~~~'
+      ENDIF
+      !
+      REWIND( numnatp_ref )              ! Namelist nampislim in reference namelist : Pisces nutrient limitation parameters
+      READ  ( numnatp_ref, namp4zice, IOSTAT = ios, ERR = 901)
+901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namp4zice in reference namelist', lwp )
+      REWIND( numnatp_cfg )              ! Namelist nampislim in configuration namelist : Pisces nutrient limitation parameters 
+      READ  ( numnatp_cfg, namp4zice, IOSTAT = ios, ERR = 902 )
+902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namp4zice in configuration namelist', lwp )
+      IF(lwm) WRITE( numonp, namp4zice )
+      !
+      IF(lwp) THEN                         ! control print
+         WRITE(numout,*) '   Namelist : namp4zice'
+         WRITE(numout,*) '      mean rainratio                           caco3r    = ', caco3r
+         WRITE(numout,*) '      NO3 half saturation of nanophyto         concnno3  = ', concnno3
+         WRITE(numout,*) '      NO3 half saturation of diatoms           concdno3  = ', concdno3
+         WRITE(numout,*) '      NH4 half saturation for phyto            concnnh4  = ', concnnh4
+         WRITE(numout,*) '      NH4 half saturation for diatoms          concdnh4  = ', concdnh4
+         WRITE(numout,*) '      half saturation constant for Si uptake   xksi1     = ', xksi1
+         WRITE(numout,*) '      half saturation constant for Si/C        xksi2     = ', xksi2
+         WRITE(numout,*) '      half-sat. of DOC remineralization        xkdoc     = ', xkdoc
+         WRITE(numout,*) '      Iron half saturation for nanophyto       concnfer  = ', concnfer
+         WRITE(numout,*) '      Iron half saturation for diatoms         concdfer  = ', concdfer
+         WRITE(numout,*) '      size ratio for nanophytoplankton         xsizern   = ', xsizern
+         WRITE(numout,*) '      size ratio for diatoms                   xsizerd   = ', xsizerd
+         WRITE(numout,*) '      NO3 half saturation of bacteria          concbno3  = ', concbno3
+         WRITE(numout,*) '      NH4 half saturation for bacteria         concbnh4  = ', concbnh4
+         WRITE(numout,*) '      Minimum size criteria for diatoms        xsizedia  = ', xsizedia
+         WRITE(numout,*) '      Minimum size criteria for nanophyto      xsizephy  = ', xsizephy
+         WRITE(numout,*) '      Fe half saturation for bacteria          concbfe   = ', concbfe
+         WRITE(numout,*) '      halk saturation constant for anoxia       oxymin   =' , oxymin
+         WRITE(numout,*) '      optimal Fe quota for nano.               qnfelim   = ', qnfelim
+         WRITE(numout,*) '      Optimal Fe quota for diatoms             qdfelim   = ', qdfelim
+      ENDIF
+      !
+      nitrfac (:,:,:) = 0._wp
+      !
+   END SUBROUTINE p4z_lim_init
+
+
+   INTEGER FUNCTION p4z_lim_alloc()
+      !!----------------------------------------------------------------------
+      !!                     ***  ROUTINE p5z_lim_alloc  ***
+      !!----------------------------------------------------------------------
+      USE lib_mpp , ONLY: ctl_warn
+      !!----------------------------------------------------------------------
+
+      !*  Biological arrays for phytoplankton growth
+      ALLOCATE( xnanono3(jpi,jpj,jpk), xdiatno3(jpi,jpj,jpk),       &
+         &      xnanonh4(jpi,jpj,jpk), xdiatnh4(jpi,jpj,jpk),       &
+         &      xnanopo4(jpi,jpj,jpk), xdiatpo4(jpi,jpj,jpk),       &
+         &      xlimphy (jpi,jpj,jpk), xlimdia (jpi,jpj,jpk),       &
+         &      xlimnfe (jpi,jpj,jpk), xlimdfe (jpi,jpj,jpk),       &
+         &      xlimbac (jpi,jpj,jpk), xlimbacl(jpi,jpj,jpk),       &
+         &      concnfe (jpi,jpj,jpk), concdfe (jpi,jpj,jpk),       &
+         &      xlimsi  (jpi,jpj,jpk), STAT=p4z_lim_alloc )
+      !
+      IF( p4z_lim_alloc /= 0 ) CALL ctl_warn('p4z_lim_alloc : failed to allocate arrays.')
+      !
+   END FUNCTION p4z_lim_alloc
+
+   !!======================================================================
+END MODULE p4zice
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zlim.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zlim.F90	(revision 9569)
+++ 	(revision )
@@ -1,313 +1,0 @@
-MODULE p4zlim
-   !!======================================================================
-   !!                         ***  MODULE p4zlim  ***
-   !! TOP :   PISCES 
-   !!======================================================================
-   !! History :   1.0  !  2004     (O. Aumont) Original code
-   !!             2.0  !  2007-12  (C. Ethe, G. Madec)  F90
-   !!             3.4  !  2011-04  (O. Aumont, C. Ethe) Limitation for iron modelled in quota 
-   !!----------------------------------------------------------------------
-   !!   p4z_lim        :   Compute the nutrients limitation terms 
-   !!   p4z_lim_init   :   Read the namelist 
-   !!----------------------------------------------------------------------
-   USE oce_trc         ! Shared ocean-passive tracers variables
-   USE trc             ! Tracers defined
-   USE sms_pisces      ! PISCES variables
-   USE iom             !  I/O manager
-
-   IMPLICIT NONE
-   PRIVATE
-
-   PUBLIC p4z_lim    
-   PUBLIC p4z_lim_init    
-   PUBLIC p4z_lim_alloc
-
-   !! * Shared module variables
-   REAL(wp), PUBLIC ::  concnno3    !:  NO3, PO4 half saturation   
-   REAL(wp), PUBLIC ::  concdno3    !:  Phosphate half saturation for diatoms  
-   REAL(wp), PUBLIC ::  concnnh4    !:  NH4 half saturation for phyto  
-   REAL(wp), PUBLIC ::  concdnh4    !:  NH4 half saturation for diatoms
-   REAL(wp), PUBLIC ::  concnfer    !:  Iron half saturation for nanophyto 
-   REAL(wp), PUBLIC ::  concdfer    !:  Iron half saturation for diatoms  
-   REAL(wp), PUBLIC ::  concbno3    !:  NO3 half saturation  for bacteria 
-   REAL(wp), PUBLIC ::  concbnh4    !:  NH4 half saturation for bacteria
-   REAL(wp), PUBLIC ::  xsizedia    !:  Minimum size criteria for diatoms
-   REAL(wp), PUBLIC ::  xsizephy    !:  Minimum size criteria for nanophyto
-   REAL(wp), PUBLIC ::  xsizern     !:  Size ratio for nanophytoplankton
-   REAL(wp), PUBLIC ::  xsizerd     !:  Size ratio for diatoms
-   REAL(wp), PUBLIC ::  xksi1       !:  half saturation constant for Si uptake 
-   REAL(wp), PUBLIC ::  xksi2       !:  half saturation constant for Si/C 
-   REAL(wp), PUBLIC ::  xkdoc       !:  2nd half-sat. of DOC remineralization  
-   REAL(wp), PUBLIC ::  concbfe     !:  Fe half saturation for bacteria 
-   REAL(wp), PUBLIC ::  oxymin      !:  half saturation constant for anoxia
-   REAL(wp), PUBLIC ::  qnfelim     !:  optimal Fe quota for nanophyto
-   REAL(wp), PUBLIC ::  qdfelim     !:  optimal Fe quota for diatoms
-   REAL(wp), PUBLIC ::  caco3r      !:  mean rainratio 
-
-   !!* Phytoplankton limitation terms
-   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)  ::   xnanono3   !: ???
-   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)  ::   xdiatno3   !: ???
-   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)  ::   xnanonh4   !: ???
-   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)  ::   xdiatnh4   !: ???
-   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)  ::   xnanopo4   !: ???
-   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)  ::   xdiatpo4   !: ???
-   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)  ::   xlimphy    !: ???
-   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)  ::   xlimdia    !: ???
-   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)  ::   xlimnfe    !: ???
-   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)  ::   xlimdfe    !: ???
-   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)  ::   xlimsi     !: ???
-   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)  ::   xlimbac    !: ??
-   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)  ::   xlimbacl   !: ??
-   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)  ::   concdfe    !: ???
-   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)  ::   concnfe    !: ???
-
-   ! Coefficient for iron limitation
-   REAL(wp) ::  xcoef1   = 0.0016  / 55.85  
-   REAL(wp) ::  xcoef2   = 1.21E-5 * 14. / 55.85 / 7.625 * 0.5 * 1.5
-   REAL(wp) ::  xcoef3   = 1.15E-4 * 14. / 55.85 / 7.625 * 0.5 
-
-   !!----------------------------------------------------------------------
-   !! NEMO/TOP 3.3 , NEMO Consortium (2010)
-   !! $Id: p4zlim.F90 3160 2011-11-20 14:27:18Z cetlod $ 
-   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
-   !!----------------------------------------------------------------------
-CONTAINS
-
-   SUBROUTINE p4z_lim( kt, knt )
-      !!---------------------------------------------------------------------
-      !!                     ***  ROUTINE p4z_lim  ***
-      !!
-      !! ** Purpose :   Compute the co-limitations by the various nutrients
-      !!              for the various phytoplankton species
-      !!
-      !! ** Method  : - ???
-      !!---------------------------------------------------------------------
-      INTEGER, INTENT(in)  :: kt, knt
-      !
-      INTEGER  ::   ji, jj, jk
-      REAL(wp) ::   zlim1, zlim2, zlim3, zlim4, zno3, zferlim
-      REAL(wp) ::   zconcd, zconcd2, zconcn, zconcn2
-      REAL(wp) ::   z1_trbdia, z1_trbphy, ztem1, ztem2, zetot1, zetot2
-      REAL(wp) ::   zdenom, zratio, zironmin
-      REAL(wp) ::   zconc1d, zconc1dnh4, zconc0n, zconc0nnh4   
-      !!---------------------------------------------------------------------
-      !
-      IF( ln_timing )   CALL timing_start('p4z_lim')
-      !
-      DO jk = 1, jpkm1
-         DO jj = 1, jpj
-            DO ji = 1, jpi
-               
-               ! Tuning of the iron concentration to a minimum level that is set to the detection limit
-               !-------------------------------------
-               zno3    = trb(ji,jj,jk,jpno3) / 40.e-6
-               zferlim = MAX( 3e-11 * zno3 * zno3, 5e-12 )
-               zferlim = MIN( zferlim, 7e-11 )
-               trb(ji,jj,jk,jpfer) = MAX( trb(ji,jj,jk,jpfer), zferlim )
-
-               ! Computation of a variable Ks for iron on diatoms taking into account
-               ! that increasing biomass is made of generally bigger cells
-               !------------------------------------------------
-               zconcd   = MAX( 0.e0 , trb(ji,jj,jk,jpdia) - xsizedia )
-               zconcd2  = trb(ji,jj,jk,jpdia) - zconcd
-               zconcn   = MAX( 0.e0 , trb(ji,jj,jk,jpphy) - xsizephy )
-               zconcn2  = trb(ji,jj,jk,jpphy) - zconcn
-               z1_trbphy   = 1. / ( trb(ji,jj,jk,jpphy) + rtrn )
-               z1_trbdia   = 1. / ( trb(ji,jj,jk,jpdia) + rtrn )
-
-               concdfe(ji,jj,jk) = MAX( concdfer, ( zconcd2 * concdfer + concdfer * xsizerd * zconcd ) * z1_trbdia )
-               zconc1d           = MAX( concdno3, ( zconcd2 * concdno3 + concdno3 * xsizerd * zconcd ) * z1_trbdia )
-               zconc1dnh4        = MAX( concdnh4, ( zconcd2 * concdnh4 + concdnh4 * xsizerd * zconcd ) * z1_trbdia )
-
-               concnfe(ji,jj,jk) = MAX( concnfer, ( zconcn2 * concnfer + concnfer * xsizern * zconcn ) * z1_trbphy )
-               zconc0n           = MAX( concnno3, ( zconcn2 * concnno3 + concnno3 * xsizern * zconcn ) * z1_trbphy )
-               zconc0nnh4        = MAX( concnnh4, ( zconcn2 * concnnh4 + concnnh4 * xsizern * zconcn ) * z1_trbphy )
-
-               ! Michaelis-Menten Limitation term for nutrients Small bacteria
-               ! -------------------------------------------------------------
-               zdenom = 1. /  ( concbno3 * concbnh4 + concbnh4 * trb(ji,jj,jk,jpno3) + concbno3 * trb(ji,jj,jk,jpnh4) )
-               xnanono3(ji,jj,jk) = trb(ji,jj,jk,jpno3) * concbnh4 * zdenom
-               xnanonh4(ji,jj,jk) = trb(ji,jj,jk,jpnh4) * concbno3 * zdenom
-               !
-               zlim1    = xnanono3(ji,jj,jk) + xnanonh4(ji,jj,jk)
-               zlim2    = trb(ji,jj,jk,jppo4) / ( trb(ji,jj,jk,jppo4) + concbnh4 )
-               zlim3    = trb(ji,jj,jk,jpfer) / ( concbfe + trb(ji,jj,jk,jpfer) )
-               zlim4    = trb(ji,jj,jk,jpdoc) / ( xkdoc   + trb(ji,jj,jk,jpdoc) )
-               xlimbacl(ji,jj,jk) = MIN( zlim1, zlim2, zlim3 )
-               xlimbac (ji,jj,jk) = MIN( zlim1, zlim2, zlim3 ) * zlim4
-
-               ! Michaelis-Menten Limitation term for nutrients Small flagellates
-               ! -----------------------------------------------
-               zdenom = 1. /  ( zconc0n * zconc0nnh4 + zconc0nnh4 * trb(ji,jj,jk,jpno3) + zconc0n * trb(ji,jj,jk,jpnh4) )
-               xnanono3(ji,jj,jk) = trb(ji,jj,jk,jpno3) * zconc0nnh4 * zdenom
-               xnanonh4(ji,jj,jk) = trb(ji,jj,jk,jpnh4) * zconc0n    * zdenom
-               !
-               zlim1    = xnanono3(ji,jj,jk) + xnanonh4(ji,jj,jk)
-               zlim2    = trb(ji,jj,jk,jppo4) / ( trb(ji,jj,jk,jppo4) + zconc0nnh4 )
-               zratio   = trb(ji,jj,jk,jpnfe) * z1_trbphy 
-               zironmin = xcoef1 * trb(ji,jj,jk,jpnch) * z1_trbphy + xcoef2 * zlim1 + xcoef3 * xnanono3(ji,jj,jk)
-               zlim3    = MAX( 0.,( zratio - zironmin ) / qnfelim )
-               xnanopo4(ji,jj,jk) = zlim2
-               xlimnfe (ji,jj,jk) = MIN( 1., zlim3 )
-               xlimphy (ji,jj,jk) = MIN( zlim1, zlim2, zlim3 )
-               !
-               !   Michaelis-Menten Limitation term for nutrients Diatoms
-               !   ----------------------------------------------
-               zdenom   = 1. / ( zconc1d * zconc1dnh4 + zconc1dnh4 * trb(ji,jj,jk,jpno3) + zconc1d * trb(ji,jj,jk,jpnh4) )
-               xdiatno3(ji,jj,jk) = trb(ji,jj,jk,jpno3) * zconc1dnh4 * zdenom
-               xdiatnh4(ji,jj,jk) = trb(ji,jj,jk,jpnh4) * zconc1d    * zdenom
-               !
-               zlim1    = xdiatno3(ji,jj,jk) + xdiatnh4(ji,jj,jk)
-               zlim2    = trb(ji,jj,jk,jppo4) / ( trb(ji,jj,jk,jppo4) + zconc1dnh4  )
-               zlim3    = trb(ji,jj,jk,jpsil) / ( trb(ji,jj,jk,jpsil) + xksi(ji,jj) )
-               zratio   = trb(ji,jj,jk,jpdfe) * z1_trbdia
-               zironmin = xcoef1 * trb(ji,jj,jk,jpdch) * z1_trbdia + xcoef2 * zlim1 + xcoef3 * xdiatno3(ji,jj,jk)
-               zlim4    = MAX( 0., ( zratio - zironmin ) / qdfelim )
-               xdiatpo4(ji,jj,jk) = zlim2
-               xlimdfe (ji,jj,jk) = MIN( 1., zlim4 )
-               xlimdia (ji,jj,jk) = MIN( zlim1, zlim2, zlim3, zlim4 )
-               xlimsi  (ji,jj,jk) = MIN( zlim1, zlim2, zlim4 )
-           END DO
-         END DO
-      END DO
-
-      ! Compute the fraction of nanophytoplankton that is made of calcifiers
-      ! --------------------------------------------------------------------
-      DO jk = 1, jpkm1
-         DO jj = 1, jpj
-            DO ji = 1, jpi
-               zlim1 =  ( trb(ji,jj,jk,jpno3) * concnnh4 + trb(ji,jj,jk,jpnh4) * concnno3 )    &
-                  &   / ( concnno3 * concnnh4 + concnnh4 * trb(ji,jj,jk,jpno3) + concnno3 * trb(ji,jj,jk,jpnh4) ) 
-               zlim2  = trb(ji,jj,jk,jppo4) / ( trb(ji,jj,jk,jppo4) + concnnh4 )
-               zlim3  = trb(ji,jj,jk,jpfer) / ( trb(ji,jj,jk,jpfer) +  5.E-11   )
-               ztem1  = MAX( 0., tsn(ji,jj,jk,jp_tem) )
-               ztem2  = tsn(ji,jj,jk,jp_tem) - 10.
-               zetot1 = MAX( 0., etot_ndcy(ji,jj,jk) - 1.) / ( 4. + etot_ndcy(ji,jj,jk) ) 
-               zetot2 = 30. / ( 30. + etot_ndcy(ji,jj,jk) ) 
-
-               xfracal(ji,jj,jk) = caco3r * MIN( zlim1, zlim2, zlim3 )                  &
-                  &                       * ztem1 / ( 0.1 + ztem1 )                     &
-                  &                       * MAX( 1., trb(ji,jj,jk,jpphy) * 1.e6 / 2. )  &
-                  &                       * zetot1 * zetot2               &
-                  &                       * ( 1. + EXP(-ztem2 * ztem2 / 25. ) )         &
-                  &                       * MIN( 1., 50. / ( hmld(ji,jj) + rtrn ) )
-               xfracal(ji,jj,jk) = MIN( 0.8 , xfracal(ji,jj,jk) )
-               xfracal(ji,jj,jk) = MAX( 0.02, xfracal(ji,jj,jk) )
-            END DO
-         END DO
-      END DO
-      !
-      DO jk = 1, jpkm1
-         DO jj = 1, jpj
-            DO ji = 1, jpi
-               ! denitrification factor computed from O2 levels
-               nitrfac(ji,jj,jk) = MAX(  0.e0, 0.4 * ( 6.e-6  - trb(ji,jj,jk,jpoxy) )    &
-                  &                                / ( oxymin + trb(ji,jj,jk,jpoxy) )  )
-               nitrfac(ji,jj,jk) = MIN( 1., nitrfac(ji,jj,jk) )
-               !
-               ! denitrification factor computed from NO3 levels
-               nitrfac2(ji,jj,jk) = MAX( 0.e0,       ( 1.E-6 - trb(ji,jj,jk,jpno3) )  &
-                  &                                / ( 1.E-6 + trb(ji,jj,jk,jpno3) ) )
-               nitrfac2(ji,jj,jk) = MIN( 1., nitrfac2(ji,jj,jk) )
-            END DO
-         END DO
-      END DO
-      !
-      IF( lk_iomput .AND. knt == nrdttrc ) THEN        ! save output diagnostics
-        IF( iom_use( "xfracal" ) )   CALL iom_put( "xfracal", xfracal(:,:,:) * tmask(:,:,:) )  ! euphotic layer deptht
-        IF( iom_use( "LNnut"   ) )   CALL iom_put( "LNnut"  , xlimphy(:,:,:) * tmask(:,:,:) )  ! Nutrient limitation term
-        IF( iom_use( "LDnut"   ) )   CALL iom_put( "LDnut"  , xlimdia(:,:,:) * tmask(:,:,:) )  ! Nutrient limitation term
-        IF( iom_use( "LNFe"    ) )   CALL iom_put( "LNFe"   , xlimnfe(:,:,:) * tmask(:,:,:) )  ! Iron limitation term
-        IF( iom_use( "LDFe"    ) )   CALL iom_put( "LDFe"   , xlimdfe(:,:,:) * tmask(:,:,:) )  ! Iron limitation term
-      ENDIF
-      !
-      IF( ln_timing )   CALL timing_stop('p4z_lim')
-      !
-   END SUBROUTINE p4z_lim
-
-
-   SUBROUTINE p4z_lim_init
-      !!----------------------------------------------------------------------
-      !!                  ***  ROUTINE p4z_lim_init  ***
-      !!
-      !! ** Purpose :   Initialization of nutrient limitation parameters
-      !!
-      !! ** Method  :   Read the nampislim namelist and check the parameters
-      !!      called at the first timestep (nittrc000)
-      !!
-      !! ** input   :   Namelist nampislim
-      !!
-      !!----------------------------------------------------------------------
-      INTEGER ::   ios   ! Local integer
-      !
-      NAMELIST/namp4zlim/ concnno3, concdno3, concnnh4, concdnh4, concnfer, concdfer, concbfe,   &
-         &                concbno3, concbnh4, xsizedia, xsizephy, xsizern, xsizerd,          & 
-         &                xksi1, xksi2, xkdoc, qnfelim, qdfelim, caco3r, oxymin
-      !!----------------------------------------------------------------------
-      !
-      IF(lwp) THEN
-         WRITE(numout,*)
-         WRITE(numout,*) 'p4z_lim_init : initialization of nutrient limitations'
-         WRITE(numout,*) '~~~~~~~~~~~~'
-      ENDIF
-      !
-      REWIND( numnatp_ref )              ! Namelist nampislim in reference namelist : Pisces nutrient limitation parameters
-      READ  ( numnatp_ref, namp4zlim, IOSTAT = ios, ERR = 901)
-901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namp4zlim in reference namelist', lwp )
-      REWIND( numnatp_cfg )              ! Namelist nampislim in configuration namelist : Pisces nutrient limitation parameters 
-      READ  ( numnatp_cfg, namp4zlim, IOSTAT = ios, ERR = 902 )
-902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namp4zlim in configuration namelist', lwp )
-      IF(lwm) WRITE( numonp, namp4zlim )
-      !
-      IF(lwp) THEN                         ! control print
-         WRITE(numout,*) '   Namelist : namp4zlim'
-         WRITE(numout,*) '      mean rainratio                           caco3r    = ', caco3r
-         WRITE(numout,*) '      NO3 half saturation of nanophyto         concnno3  = ', concnno3
-         WRITE(numout,*) '      NO3 half saturation of diatoms           concdno3  = ', concdno3
-         WRITE(numout,*) '      NH4 half saturation for phyto            concnnh4  = ', concnnh4
-         WRITE(numout,*) '      NH4 half saturation for diatoms          concdnh4  = ', concdnh4
-         WRITE(numout,*) '      half saturation constant for Si uptake   xksi1     = ', xksi1
-         WRITE(numout,*) '      half saturation constant for Si/C        xksi2     = ', xksi2
-         WRITE(numout,*) '      half-sat. of DOC remineralization        xkdoc     = ', xkdoc
-         WRITE(numout,*) '      Iron half saturation for nanophyto       concnfer  = ', concnfer
-         WRITE(numout,*) '      Iron half saturation for diatoms         concdfer  = ', concdfer
-         WRITE(numout,*) '      size ratio for nanophytoplankton         xsizern   = ', xsizern
-         WRITE(numout,*) '      size ratio for diatoms                   xsizerd   = ', xsizerd
-         WRITE(numout,*) '      NO3 half saturation of bacteria          concbno3  = ', concbno3
-         WRITE(numout,*) '      NH4 half saturation for bacteria         concbnh4  = ', concbnh4
-         WRITE(numout,*) '      Minimum size criteria for diatoms        xsizedia  = ', xsizedia
-         WRITE(numout,*) '      Minimum size criteria for nanophyto      xsizephy  = ', xsizephy
-         WRITE(numout,*) '      Fe half saturation for bacteria          concbfe   = ', concbfe
-         WRITE(numout,*) '      halk saturation constant for anoxia       oxymin   =' , oxymin
-         WRITE(numout,*) '      optimal Fe quota for nano.               qnfelim   = ', qnfelim
-         WRITE(numout,*) '      Optimal Fe quota for diatoms             qdfelim   = ', qdfelim
-      ENDIF
-      !
-      nitrfac (:,:,:) = 0._wp
-      !
-   END SUBROUTINE p4z_lim_init
-
-
-   INTEGER FUNCTION p4z_lim_alloc()
-      !!----------------------------------------------------------------------
-      !!                     ***  ROUTINE p5z_lim_alloc  ***
-      !!----------------------------------------------------------------------
-      USE lib_mpp , ONLY: ctl_warn
-      !!----------------------------------------------------------------------
-
-      !*  Biological arrays for phytoplankton growth
-      ALLOCATE( xnanono3(jpi,jpj,jpk), xdiatno3(jpi,jpj,jpk),       &
-         &      xnanonh4(jpi,jpj,jpk), xdiatnh4(jpi,jpj,jpk),       &
-         &      xnanopo4(jpi,jpj,jpk), xdiatpo4(jpi,jpj,jpk),       &
-         &      xlimphy (jpi,jpj,jpk), xlimdia (jpi,jpj,jpk),       &
-         &      xlimnfe (jpi,jpj,jpk), xlimdfe (jpi,jpj,jpk),       &
-         &      xlimbac (jpi,jpj,jpk), xlimbacl(jpi,jpj,jpk),       &
-         &      concnfe (jpi,jpj,jpk), concdfe (jpi,jpj,jpk),       &
-         &      xlimsi  (jpi,jpj,jpk), STAT=p4z_lim_alloc )
-      !
-      IF( p4z_lim_alloc /= 0 ) CALL ctl_warn('p4z_lim_alloc : failed to allocate arrays.')
-      !
-   END FUNCTION p4z_lim_alloc
-
-   !!======================================================================
-END MODULE p4zlim
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zmicro.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zmicro.F90	(revision 9569)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zmicro.F90	(revision 9570)
@@ -14,5 +14,5 @@
    USE trc             ! passive tracers common variables 
    USE sms_pisces      ! PISCES Source Minus Sink variables
-   USE p4zlim          ! Co-limitations
+   USE p4zice          ! Co-limitations
    USE p4zprod         ! production
    USE iom             ! I/O manager
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zmort.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zmort.F90	(revision 9569)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zmort.F90	(revision 9570)
@@ -14,5 +14,5 @@
    USE sms_pisces      ! PISCES Source Minus Sink variables
    USE p4zprod         ! Primary productivity 
-   USE p4zlim          ! Phytoplankton limitation terms
+   USE p4zice          ! Phytoplankton limitation terms
    USE prtctl_trc      ! print control for debugging
 
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zprod.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zprod.F90	(revision 9569)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zprod.F90	(revision 9570)
@@ -15,5 +15,5 @@
    USE trc             ! passive tracers common variables 
    USE sms_pisces      ! PISCES Source Minus Sink variables
-   USE p4zlim          ! Co-limitations of differents nutrients
+   USE p4zice          ! Co-limitations of differents nutrients
    USE prtctl_trc      ! print control for debugging
    USE iom             ! I/O manager
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zrem.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zrem.F90	(revision 9569)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zrem.F90	(revision 9570)
@@ -17,5 +17,5 @@
    USE p4zche          !  chemical model
    USE p4zprod         !  Growth rate of the 2 phyto groups
-   USE p4zlim
+   USE p4zice
    USE prtctl_trc      !  print control for debugging
    USE iom             !  I/O manager
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zsed.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zsed.F90	(revision 9569)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zsed.F90	(revision 9570)
@@ -14,5 +14,5 @@
    USE trc             !  passive tracers common variables 
    USE sms_pisces      !  PISCES Source Minus Sink variables
-   USE p4zlim          !  Co-limitations of differents nutrients
+   USE p4zice          !  Co-limitations of differents nutrients
    USE p4zsbc          !  External source of nutrients 
    USE p4zint          !  interpolation and computation of various fields
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p5zice.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p5zice.F90	(revision 9570)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p5zice.F90	(revision 9570)
@@ -0,0 +1,602 @@
+MODULE p5zice
+   !!======================================================================
+   !!                         ***  MODULE p5zice  ***
+   !! TOP :   PISCES with variable stoichiometry 
+   !!======================================================================
+   !! History :   1.0  !  2004     (O. Aumont) Original code
+   !!             2.0  !  2007-12  (C. Ethe, G. Madec)  F90
+   !!             3.4  !  2011-04  (O. Aumont, C. Ethe) Limitation for iron modelled in quota 
+   !!             3.6  !  2015-05  (O. Aumont) PISCES quota
+   !!----------------------------------------------------------------------
+   !!   p5z_lim        :   Compute the nutrients limitation terms 
+   !!   p5z_lim_init   :   Read the namelist 
+   !!----------------------------------------------------------------------
+   USE oce_trc         ! Shared ocean-passive tracers variables
+   USE trc             ! Tracers defined
+   USE sms_pisces      ! PISCES variables
+   USE iom             !  I/O manager
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC p5z_lim    
+   PUBLIC p5z_lim_init    
+   PUBLIC p5z_lim_alloc
+
+   !! * Shared module variables
+   REAL(wp), PUBLIC ::  concnno3    !:  NO3, PO4 half saturation   
+   REAL(wp), PUBLIC ::  concpno3    !:  NO3, PO4 half saturation   
+   REAL(wp), PUBLIC ::  concdno3    !:  Phosphate half saturation for diatoms  
+   REAL(wp), PUBLIC ::  concnnh4    !:  NH4 half saturation for phyto  
+   REAL(wp), PUBLIC ::  concpnh4    !:  NH4 half saturation for phyto  
+   REAL(wp), PUBLIC ::  concdnh4    !:  NH4 half saturation for diatoms
+   REAL(wp), PUBLIC ::  concnpo4    !:  NH4 half saturation for diatoms
+   REAL(wp), PUBLIC ::  concppo4    !:  NH4 half saturation for diatoms
+   REAL(wp), PUBLIC ::  concdpo4    !:  NH4 half saturation for diatoms
+   REAL(wp), PUBLIC ::  concnfer    !:  Iron half saturation for nanophyto 
+   REAL(wp), PUBLIC ::  concpfer    !:  Iron half saturation for nanophyto 
+   REAL(wp), PUBLIC ::  concdfer    !:  Iron half saturation for diatoms  
+   REAL(wp), PUBLIC ::  concbno3    !:  NO3 half saturation  for bacteria 
+   REAL(wp), PUBLIC ::  concbnh4    !:  NH4 half saturation for bacteria
+   REAL(wp), PUBLIC ::  concbpo4    !:  PO4 half saturation for bacteria
+   REAL(wp), PUBLIC ::  xsizedia    !:  Minimum size criteria for diatoms
+   REAL(wp), PUBLIC ::  xsizepic    !:  Minimum size criteria for diatoms
+   REAL(wp), PUBLIC ::  xsizephy    !:  Minimum size criteria for nanophyto
+   REAL(wp), PUBLIC ::  xsizern     !:  Size ratio for nanophytoplankton
+   REAL(wp), PUBLIC ::  xsizerp     !:  Size ratio for nanophytoplankton
+   REAL(wp), PUBLIC ::  xsizerd     !:  Size ratio for diatoms
+   REAL(wp), PUBLIC ::  xksi1       !:  half saturation constant for Si uptake 
+   REAL(wp), PUBLIC ::  xksi2       !:  half saturation constant for Si/C 
+   REAL(wp), PUBLIC ::  xkdoc       !:  2nd half-sat. of DOC remineralization  
+   REAL(wp), PUBLIC ::  concbfe     !:  Fe half saturation for bacteria 
+   REAL(wp), PUBLIC ::  oxymin      !:  half saturation constant for anoxia
+   REAL(wp), PUBLIC ::  qfnopt      !:  optimal Fe quota for nanophyto
+   REAL(wp), PUBLIC ::  qfpopt      !:  optimal Fe quota for nanophyto
+   REAL(wp), PUBLIC ::  qfdopt      !:  optimal Fe quota for diatoms
+   REAL(wp), PUBLIC ::  caco3r      !:  mean rainratio 
+   REAL(wp), PUBLIC ::  qnnmin      !:  optimal Fe quota for diatoms
+   REAL(wp), PUBLIC ::  qnnmax      !:  optimal Fe quota for diatoms
+   REAL(wp), PUBLIC ::  qpnmin      !:  optimal Fe quota for diatoms
+   REAL(wp), PUBLIC ::  qpnmax      !:  optimal Fe quota for diatoms
+   REAL(wp), PUBLIC ::  qnpmin      !:  optimal Fe quota for diatoms
+   REAL(wp), PUBLIC ::  qnpmax      !:  optimal Fe quota for diatoms
+   REAL(wp), PUBLIC ::  qppmin      !:  optimal Fe quota for diatoms
+   REAL(wp), PUBLIC ::  qppmax      !:  optimal Fe quota for diatoms
+   REAL(wp), PUBLIC ::  qndmin      !:  optimal Fe quota for diatoms
+   REAL(wp), PUBLIC ::  qndmax      !:  optimal Fe quota for diatoms
+   REAL(wp), PUBLIC ::  qpdmin      !:  optimal Fe quota for diatoms
+   REAL(wp), PUBLIC ::  qpdmax      !:  optimal Fe quota for diatoms
+   REAL(wp), PUBLIC ::  qfnmax      !:  optimal Fe quota for diatoms
+   REAL(wp), PUBLIC ::  qfpmax      !:  optimal Fe quota for diatoms
+   REAL(wp), PUBLIC ::  qfdmax      !:  optimal Fe quota for diatoms
+   REAL(wp), PUBLIC ::  zpsinh4
+   REAL(wp), PUBLIC ::  zpsino3
+   REAL(wp), PUBLIC ::  zpsiuptk
+
+   !!*  Allometric variations of the quotas
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE,   DIMENSION(:,:,:)  ::   xqnnmin    !: ???
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE,   DIMENSION(:,:,:)  ::   xqnnmax    !: ???
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE,   DIMENSION(:,:,:)  ::   xqpnmin    !: ???
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE,   DIMENSION(:,:,:)  ::   xqpnmax    !: ???
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE,   DIMENSION(:,:,:)  ::   xqnpmin    !: ???
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE,   DIMENSION(:,:,:)  ::   xqnpmax    !: ???
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE,   DIMENSION(:,:,:)  ::   xqppmin    !: ???
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE,   DIMENSION(:,:,:)  ::   xqppmax    !: ???
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE,   DIMENSION(:,:,:)  ::   xqndmin    !: ???
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE,   DIMENSION(:,:,:)  ::   xqndmax    !: ???
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE,   DIMENSION(:,:,:)  ::   xqpdmin    !: ???
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE,   DIMENSION(:,:,:)  ::   xqpdmax    !: ???
+
+   !!* Phytoplankton limitation terms
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)  ::   xnanono3   !: ???
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)  ::   xdiatno3   !: ???
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)  ::   xnanonh4   !: ???
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)  ::   xdiatnh4   !: ???
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)  ::   xnanopo4   !: ???
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)  ::   xdiatpo4   !: ???
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)  ::   xlimphy    !: ???
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)  ::   xlimdia    !: ???
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)  ::   xlimnfe    !: ???
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)  ::   xlimdfe    !: ???
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)  ::   xlimsi     !: ???
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)  ::   xlimbac    !: ??
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)  ::   xlimbacl   !: ??
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)  ::   xpicono3   !: ???
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)  ::   xpiconh4   !: ???
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)  ::   xpicopo4   !: ???
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)  ::   xnanodop   !: ???
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)  ::   xpicodop   !: ???
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)  ::   xdiatdop   !: ???
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)  ::   xnanofer   !: ???
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)  ::   xpicofer   !: ???
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)  ::   xdiatfer   !: ???
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)  ::   xlimpic    !: ???
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)  ::   xlimpfe    !: ???
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)  ::   fvnuptk
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)  ::   fvpuptk
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)  ::   fvduptk
+
+   ! Coefficient for iron limitation
+   REAL(wp) ::  xcoef1   = 0.00167  / 55.85
+   REAL(wp) ::  xcoef2   = 1.21E-5 * 14. / 55.85 / 7.625 * 0.5 * 1.5
+   REAL(wp) ::  xcoef3   = 1.15E-4 * 14. / 55.85 / 7.625 * 0.5 
+   !!----------------------------------------------------------------------
+   !! NEMO/TOP 3.3 , NEMO Consortium (2010)
+   !! $Id: p4zice.F90 3160 2011-11-20 14:27:18Z cetlod $ 
+   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
+
+CONTAINS
+
+   SUBROUTINE p5z_lim( kt, knt )
+      !!---------------------------------------------------------------------
+      !!                     ***  ROUTINE p5z_lim  ***
+      !!
+      !! ** Purpose :   Compute the co-limitations by the various nutrients
+      !!              for the various phytoplankton species
+      !!
+      !! ** Method  : - ???
+      !!---------------------------------------------------------------------
+      !
+      INTEGER, INTENT(in)  :: kt, knt
+      !
+      INTEGER  ::   ji, jj, jk
+      REAL(wp) ::   zlim1, zlim2, zlim3, zlim4, zno3, zferlim
+      REAL(wp) ::   z1_trndia, z1_trnpic, z1_trnphy, ztem1, ztem2, zetot1
+      REAL(wp) ::   zratio, zration, zratiof, znutlim, zfalim
+      REAL(wp) ::   zconc1d, zconc1dnh4, zconc0n, zconc0nnh4, zconc0npo4, zconc0dpo4
+      REAL(wp) ::   zconc0p, zconc0pnh4, zconc0ppo4, zconcpfe, zconcnfe, zconcdfe
+      REAL(wp) ::   fanano, fananop, fananof, fadiat, fadiatp, fadiatf
+      REAL(wp) ::   fapico, fapicop, fapicof
+      REAL(wp) ::   zrpho, zrass, zcoef, zfuptk, zratchl
+      REAL(wp) ::   zfvn, zfvp, zfvf, zsizen, zsizep, zsized, znanochl, zpicochl, zdiatchl
+      REAL(wp) ::   zqfemn, zqfemp, zqfemd, zbactno3, zbactnh4
+      !!---------------------------------------------------------------------
+      !
+      IF( ln_timing )   CALL timing_start('p5z_lim')
+      !
+      zratchl = 6.0
+      !
+      DO jk = 1, jpkm1
+         DO jj = 1, jpj
+            DO ji = 1, jpi
+               ! 
+               ! Tuning of the iron concentration to a minimum level that is set to the detection limit
+               !-------------------------------------
+               zno3    = trb(ji,jj,jk,jpno3) / 40.e-6
+               zferlim = MAX( 3e-11 * zno3 * zno3, 5e-12 )
+               zferlim = MIN( zferlim, 7e-11 )
+               trb(ji,jj,jk,jpfer) = MAX( trb(ji,jj,jk,jpfer), zferlim )
+
+               ! Computation of the mean relative size of each community
+               ! -------------------------------------------------------
+               z1_trnphy   = 1. / ( trb(ji,jj,jk,jpphy) + rtrn )
+               z1_trnpic   = 1. / ( trb(ji,jj,jk,jppic) + rtrn )
+               z1_trndia   = 1. / ( trb(ji,jj,jk,jpdia) + rtrn )
+               znanochl = trb(ji,jj,jk,jpnch) * z1_trnphy
+               zpicochl = trb(ji,jj,jk,jppch) * z1_trnpic
+               zdiatchl = trb(ji,jj,jk,jpdch) * z1_trndia
+
+               ! Computation of a variable Ks for iron on diatoms taking into account
+               ! that increasing biomass is made of generally bigger cells
+               !------------------------------------------------
+               zsized            = sized(ji,jj,jk)**0.81
+               zconcdfe          = concdfer * zsized
+               zconc1d           = concdno3 * zsized
+               zconc1dnh4        = concdnh4 * zsized
+               zconc0dpo4        = concdpo4 * zsized
+
+               zsizep            = 1.
+               zconcpfe          = concpfer * zsizep
+               zconc0p           = concpno3 * zsizep
+               zconc0pnh4        = concpnh4 * zsizep
+               zconc0ppo4        = concppo4 * zsizep
+
+               zsizen            = 1.
+               zconcnfe          = concnfer * zsizen
+               zconc0n           = concnno3 * zsizen
+               zconc0nnh4        = concnnh4 * zsizen
+               zconc0npo4        = concnpo4 * zsizen
+
+               ! Allometric variations of the minimum and maximum quotas
+               ! From Talmy et al. (2014) and Maranon et al. (2013)
+               ! -------------------------------------------------------
+               xqnnmin(ji,jj,jk) = qnnmin
+               xqnnmax(ji,jj,jk) = qnnmax
+               xqndmin(ji,jj,jk) = qndmin * sized(ji,jj,jk)**(-0.27) 
+               xqndmax(ji,jj,jk) = qndmax
+               xqnpmin(ji,jj,jk) = qnpmin
+               xqnpmax(ji,jj,jk) = qnpmax
+
+               ! Computation of the optimal allocation parameters
+               ! Based on the different papers by Pahlow et al., and Smith et al.
+               ! -----------------------------------------------------------------
+               znutlim = MAX( trb(ji,jj,jk,jpnh4) / zconc0nnh4,    &
+                 &         trb(ji,jj,jk,jpno3) / zconc0n)
+               fanano = MAX(0.01, MIN(0.99, 1. / ( SQRT(znutlim) + 1.) ) )
+               znutlim = trb(ji,jj,jk,jppo4) / zconc0npo4
+               fananop = MAX(0.01, MIN(0.99, 1. / ( SQRT(znutlim) + 1.) ) )
+               znutlim = biron(ji,jj,jk) / zconcnfe
+               fananof = MAX(0.01, MIN(0.99, 1. / ( SQRT(znutlim) + 1.) ) )
+               znutlim = MAX( trb(ji,jj,jk,jpnh4) / zconc0pnh4,    &
+                 &         trb(ji,jj,jk,jpno3) / zconc0p)
+               fapico = MAX(0.01, MIN(0.99, 1. / ( SQRT(znutlim) + 1.) ) )
+               znutlim = trb(ji,jj,jk,jppo4) / zconc0ppo4
+               fapicop = MAX(0.01, MIN(0.99, 1. / ( SQRT(znutlim) + 1.) ) )
+               znutlim = biron(ji,jj,jk) / zconcpfe
+               fapicof = MAX(0.01, MIN(0.99, 1. / ( SQRT(znutlim) + 1.) ) )
+               znutlim = MAX( trb(ji,jj,jk,jpnh4) / zconc1dnh4,    &
+                 &         trb(ji,jj,jk,jpno3) / zconc1d )
+               fadiat = MAX(0.01, MIN(0.99, 1. / ( SQRT(znutlim) + 1.) ) )
+               znutlim = trb(ji,jj,jk,jppo4) / zconc0dpo4
+               fadiatp = MAX(0.01, MIN(0.99, 1. / ( SQRT(znutlim) + 1.) ) )
+               znutlim = biron(ji,jj,jk) / zconcdfe
+               fadiatf = MAX(0.01, MIN(0.99, 1. / ( SQRT(znutlim) + 1.) ) )
+               !
+               ! Michaelis-Menten Limitation term for nutrients Small bacteria
+               ! -------------------------------------------------------------
+               zbactnh4 = trb(ji,jj,jk,jpnh4) / ( concbnh4 + trb(ji,jj,jk,jpnh4) )
+               zbactno3 = trb(ji,jj,jk,jpno3) / ( concbno3 + trb(ji,jj,jk,jpno3) ) * (1. - zbactnh4)
+               !
+               zlim1    = zbactno3 + zbactnh4
+               zlim2    = trb(ji,jj,jk,jppo4) / ( trb(ji,jj,jk,jppo4) + concbpo4)
+               zlim3    = biron(ji,jj,jk) / ( concbfe + biron(ji,jj,jk) )
+               zlim4    = trb(ji,jj,jk,jpdoc) / ( xkdoc   + trb(ji,jj,jk,jpdoc) )
+               xlimbacl(ji,jj,jk) = MIN( zlim1, zlim2, zlim3 )
+               xlimbac (ji,jj,jk) = xlimbacl(ji,jj,jk) * zlim4
+               !
+               ! Michaelis-Menten Limitation term for nutrients Small flagellates
+               ! -----------------------------------------------
+               zfalim = (1.-fanano) / fanano
+               xnanonh4(ji,jj,jk) = (1. - fanano) * trb(ji,jj,jk,jpnh4) / ( zfalim * zconc0nnh4 + trb(ji,jj,jk,jpnh4) )
+               xnanono3(ji,jj,jk) = (1. - fanano) * trb(ji,jj,jk,jpno3) / ( zfalim * zconc0n + trb(ji,jj,jk,jpno3) )  &
+               &                    * (1. - xnanonh4(ji,jj,jk))
+               !
+               zfalim = (1.-fananop) / fananop
+               xnanopo4(ji,jj,jk) = (1. - fananop) * trb(ji,jj,jk,jppo4) / ( trb(ji,jj,jk,jppo4) + zfalim * zconc0npo4 )
+               xnanodop(ji,jj,jk) = trb(ji,jj,jk,jpdop) / ( trb(ji,jj,jk,jpdop) + xkdoc )   &
+               &                    * ( 1.0 - xnanopo4(ji,jj,jk) )
+               xnanodop(ji,jj,jk) = 0.
+               !
+               zfalim = (1.-fananof) / fananof
+               xnanofer(ji,jj,jk) = (1. - fananof) * biron(ji,jj,jk) / ( biron(ji,jj,jk) + zfalim * zconcnfe )
+               !
+               zratiof   = trb(ji,jj,jk,jpnfe) * z1_trnphy
+               zqfemn = xcoef1 * znanochl + xcoef2 + xcoef3 * xnanono3(ji,jj,jk)
+               !
+               zration = trb(ji,jj,jk,jpnph) * z1_trnphy
+               zration = MIN(xqnnmax(ji,jj,jk), MAX( 2. * xqnnmin(ji,jj,jk), zration ))
+               fvnuptk(ji,jj,jk) = 1. / zpsiuptk * rno3 * 2. * xqnnmin(ji,jj,jk) / (zration + rtrn)  &
+               &                   * MAX(0., (1. - zratchl * znanochl / 12. ) )
+               !
+               zlim1    = max(0., (zration - 2. * xqnnmin(ji,jj,jk) )  &
+               &          / (xqnnmax(ji,jj,jk) - 2. * xqnnmin(ji,jj,jk) ) ) * xqnnmax(ji,jj,jk)  &
+               &          / (zration + rtrn)
+               zlim3    = MAX( 0.,( zratiof - zqfemn ) / qfnopt ) 
+               xlimnfe(ji,jj,jk) = MIN( 1., zlim3 )
+               xlimphy(ji,jj,jk) = MIN( 1., zlim1, zlim3 )
+               !
+               ! Michaelis-Menten Limitation term for nutrients picophytoplankton
+               ! ----------------------------------------------------------------
+               zfalim = (1.-fapico) / fapico 
+               xpiconh4(ji,jj,jk) = (1. - fapico) * trb(ji,jj,jk,jpnh4) / ( zfalim * zconc0pnh4 + trb(ji,jj,jk,jpnh4) )
+               xpicono3(ji,jj,jk) = (1. - fapico) * trb(ji,jj,jk,jpno3) / ( zfalim * zconc0p + trb(ji,jj,jk,jpno3) )  &
+               &                    * (1. - xpiconh4(ji,jj,jk))
+               !
+               zfalim = (1.-fapicop) / fapicop 
+               xpicopo4(ji,jj,jk) = (1. - fapicop) * trb(ji,jj,jk,jppo4) / ( trb(ji,jj,jk,jppo4) + zfalim * zconc0ppo4 )
+               xpicodop(ji,jj,jk) = trb(ji,jj,jk,jpdop) / ( trb(ji,jj,jk,jpdop) + xkdoc )   &
+               &                    * ( 1.0 - xpicopo4(ji,jj,jk) )
+               xpicodop(ji,jj,jk) = 0.
+               !
+               zfalim = (1.-fapicof) / fapicof
+               xpicofer(ji,jj,jk) = (1. - fapicof) * biron(ji,jj,jk) / ( biron(ji,jj,jk) + zfalim * zconcpfe )
+               !
+               zratiof   = trb(ji,jj,jk,jppfe) * z1_trnpic
+               zqfemp = xcoef1 * zpicochl + xcoef2 + xcoef3 * xpicono3(ji,jj,jk)
+               !
+               zration   = trb(ji,jj,jk,jpnpi) * z1_trnpic
+               zration = MIN(xqnpmax(ji,jj,jk), MAX( 2. * xqnpmin(ji,jj,jk), zration ))
+               fvpuptk(ji,jj,jk) = 1. / zpsiuptk * rno3 * 2. * xqnpmin(ji,jj,jk) / (zration + rtrn)  &
+               &                   * MAX(0., (1. - zratchl * zpicochl / 12. ) ) 
+               !
+               zlim1    = max(0., (zration - 2. * xqnpmin(ji,jj,jk) )  &
+               &          / (xqnpmax(ji,jj,jk) - 2. * xqnpmin(ji,jj,jk) ) ) * xqnpmax(ji,jj,jk)  &
+               &          / (zration + rtrn)
+               zlim3    = MAX( 0.,( zratiof - zqfemp ) / qfpopt )
+               xlimpfe(ji,jj,jk) = MIN( 1., zlim3 )
+               xlimpic(ji,jj,jk) = MIN( 1., zlim1, zlim3 )
+               !
+               !   Michaelis-Menten Limitation term for nutrients Diatoms
+               !   ------------------------------------------------------
+               zfalim = (1.-fadiat) / fadiat 
+               xdiatnh4(ji,jj,jk) = (1. - fadiat) * trb(ji,jj,jk,jpnh4) / ( zfalim * zconc1dnh4 + trb(ji,jj,jk,jpnh4) )
+               xdiatno3(ji,jj,jk) = (1. - fadiat) * trb(ji,jj,jk,jpno3) / ( zfalim * zconc1d + trb(ji,jj,jk,jpno3) )  &
+               &                    * (1. - xdiatnh4(ji,jj,jk))
+               !
+               zfalim = (1.-fadiatp) / fadiatp
+               xdiatpo4(ji,jj,jk) = (1. - fadiatp) * trb(ji,jj,jk,jppo4) / ( trb(ji,jj,jk,jppo4) + zfalim * zconc0dpo4 )
+               xdiatdop(ji,jj,jk) = trb(ji,jj,jk,jpdop) / ( trb(ji,jj,jk,jpdop) + xkdoc )  &
+               &                    * ( 1.0 - xdiatpo4(ji,jj,jk) )
+               xdiatdop(ji,jj,jk) = 0.
+               !
+               zfalim = (1.-fadiatf) / fadiatf
+               xdiatfer(ji,jj,jk) = (1. - fadiatf) * biron(ji,jj,jk) / ( biron(ji,jj,jk) + zfalim * zconcdfe )
+               !
+               zratiof   = trb(ji,jj,jk,jpdfe) * z1_trndia
+               zqfemd = xcoef1 * zdiatchl + xcoef2 + xcoef3 * xdiatno3(ji,jj,jk)
+               !
+               zration   = trb(ji,jj,jk,jpndi) * z1_trndia
+               zration = MIN(xqndmax(ji,jj,jk), MAX( 2. * xqndmin(ji,jj,jk), zration ))
+               fvduptk(ji,jj,jk) = 1. / zpsiuptk * rno3 * 2. * xqndmin(ji,jj,jk) / (zration + rtrn)   &
+               &                   * MAX(0., (1. - zratchl * zdiatchl / 12. ) ) 
+               !
+               zlim1    = max(0., (zration - 2. * xqndmin(ji,jj,jk) )    &
+               &          / (xqndmax(ji,jj,jk) - 2. * xqndmin(ji,jj,jk) ) )   &
+               &          * xqndmax(ji,jj,jk) / (zration + rtrn)
+               zlim3    = trb(ji,jj,jk,jpsil) / ( trb(ji,jj,jk,jpsil) + xksi(ji,jj) )
+               zlim4    = MAX( 0., ( zratiof - zqfemd ) / qfdopt )
+               xlimdfe(ji,jj,jk) = MIN( 1., zlim4 )
+               xlimdia(ji,jj,jk) = MIN( 1., zlim1, zlim3, zlim4 )
+               xlimsi(ji,jj,jk)  = MIN( zlim1, zlim4 )
+            END DO
+         END DO
+      END DO
+      !
+      ! Compute the phosphorus quota values. It is based on Litchmann et al., 2004 and Daines et al, 2013.
+      ! The relative contribution of three fonctional pools are computed: light harvesting apparatus, 
+      ! nutrient uptake pool and assembly machinery. DNA is assumed to represent 1% of the dry mass of 
+      ! phytoplankton (see Daines et al., 2013). 
+      ! --------------------------------------------------------------------------------------------------
+      DO jk = 1, jpkm1
+         DO jj = 1, jpj
+            DO ji = 1, jpi
+               ! Size estimation of nanophytoplankton
+               ! ------------------------------------
+               zfvn = 2. * fvnuptk(ji,jj,jk)
+               sizen(ji,jj,jk) = MAX(1., MIN(xsizern, 1.0 / ( MAX(rtrn, zfvn) ) ) )
+
+               ! N/P ratio of nanophytoplankton
+               ! ------------------------------
+               zfuptk = 0.23 * zfvn
+               zrpho = 2.24 * trb(ji,jj,jk,jpnch) / ( trb(ji,jj,jk,jpnph) * rno3 * 15. + rtrn )
+               zrass = 1. - 0.2 - zrpho - zfuptk
+               xqpnmax(ji,jj,jk) = ( zfuptk + zrpho ) * 0.0128 * 16. + zrass * 1./ 7.2 * 16.
+               xqpnmax(ji,jj,jk) = xqpnmax(ji,jj,jk) * trb(ji,jj,jk,jpnph) / ( trb(ji,jj,jk,jpphy) + rtrn ) + 0.13
+               xqpnmin(ji,jj,jk) = 0.13 + 0.23 * 0.0128 * 16.
+
+               ! Size estimation of picophytoplankton
+               ! ------------------------------------
+               zfvn = 2. * fvpuptk(ji,jj,jk)
+               sizep(ji,jj,jk) = MAX(1., MIN(xsizerp, 1.0 / ( MAX(rtrn, zfvn) ) ) )
+
+               ! N/P ratio of picophytoplankton
+               ! ------------------------------
+               zfuptk = 0.35 * zfvn
+               zrpho = 2.24 * trb(ji,jj,jk,jppch) / ( trb(ji,jj,jk,jpnpi) * rno3 * 15. + rtrn )
+               zrass = 1. - 0.4 - zrpho - zfuptk
+               xqppmax(ji,jj,jk) =  (zrpho + zfuptk) * 0.0128 * 16. + zrass * 1./ 9. * 16.
+               xqppmax(ji,jj,jk) = xqppmax(ji,jj,jk) * trb(ji,jj,jk,jpnpi) / ( trb(ji,jj,jk,jppic) + rtrn ) + 0.13
+               xqppmin(ji,jj,jk) = 0.13
+
+               ! Size estimation of diatoms
+               ! --------------------------
+               zfvn = 2. * fvduptk(ji,jj,jk)
+               sized(ji,jj,jk) = MAX(1., MIN(xsizerd, 1.0 / ( MAX(rtrn, zfvn) ) ) )
+               zcoef = trb(ji,jj,jk,jpdia) - MIN(xsizedia, trb(ji,jj,jk,jpdia) )
+               sized(ji,jj,jk) = 1. + xsizerd * zcoef *1E6 / ( 1. + zcoef * 1E6 )
+
+               ! N/P ratio of diatoms
+               ! --------------------
+               zfuptk = 0.2 * zfvn
+               zrpho = 2.24 * trb(ji,jj,jk,jpdch) / ( trb(ji,jj,jk,jpndi) * rno3 * 15. + rtrn )
+               zrass = 1. - 0.2 - zrpho - zfuptk
+               xqpdmax(ji,jj,jk) = ( zfuptk + zrpho ) * 0.0128 * 16. + zrass * 1./ 7.2 * 16.
+               xqpdmax(ji,jj,jk) = xqpdmax(ji,jj,jk) * trb(ji,jj,jk,jpndi) / ( trb(ji,jj,jk,jpdia) + rtrn ) + 0.13
+               xqpdmin(ji,jj,jk) = 0.13 + 0.2 * 0.0128 * 16.
+
+            END DO
+         END DO
+      END DO
+
+      ! Compute the fraction of nanophytoplankton that is made of calcifiers
+      ! --------------------------------------------------------------------
+      DO jk = 1, jpkm1
+         DO jj = 1, jpj
+            DO ji = 1, jpi
+               zlim1 =  trb(ji,jj,jk,jpnh4) / ( trb(ji,jj,jk,jpnh4) + concnnh4 ) + trb(ji,jj,jk,jpno3)    &
+               &        / ( trb(ji,jj,jk,jpno3) + concnno3 ) * ( 1.0 - trb(ji,jj,jk,jpnh4)   &
+               &        / ( trb(ji,jj,jk,jpnh4) + concnnh4 ) )
+               zlim2  = trb(ji,jj,jk,jppo4) / ( trb(ji,jj,jk,jppo4) + concnpo4 )
+               zlim3  = trb(ji,jj,jk,jpfer) / ( trb(ji,jj,jk,jpfer) +  5.E-11 ) 
+               ztem1  = MAX( 0., tsn(ji,jj,jk,jp_tem) )
+               ztem2  = tsn(ji,jj,jk,jp_tem) - 10.
+               zetot1 = MAX( 0., etot(ji,jj,jk) - 1.) / ( 4. + etot(ji,jj,jk) ) * 20. / ( 20. + etot(ji,jj,jk) ) 
+
+!               xfracal(ji,jj,jk) = caco3r * MIN( zlim1, zlim2, zlim3 )                  &
+               xfracal(ji,jj,jk) = caco3r                 &
+               &                   * ztem1 / ( 1. + ztem1 ) * MAX( 1., trb(ji,jj,jk,jpphy)*1E6 )   &
+                  &                * ( 1. + EXP(-ztem2 * ztem2 / 25. ) )         &
+                  &                * zetot1 * MIN( 1., 50. / ( hmld(ji,jj) + rtrn ) )
+               xfracal(ji,jj,jk) = MAX( 0.02, MIN( 0.8 , xfracal(ji,jj,jk) ) )
+            END DO
+         END DO
+      END DO
+      !
+      DO jk = 1, jpkm1
+         DO jj = 1, jpj
+            DO ji = 1, jpi
+               ! denitrification factor computed from O2 levels
+               nitrfac(ji,jj,jk) = MAX(  0.e0, 0.4 * ( 6.e-6  - trb(ji,jj,jk,jpoxy) )    &
+                  &                                / ( oxymin + trb(ji,jj,jk,jpoxy) )  )
+               nitrfac(ji,jj,jk) = MIN( 1., nitrfac(ji,jj,jk) )
+            END DO
+         END DO
+      END DO
+      !
+      IF( lk_iomput .AND. knt == nrdttrc ) THEN        ! save output diagnostics
+        IF( iom_use( "xfracal" ) ) CALL iom_put( "xfracal", xfracal(:,:,:) * tmask(:,:,:) )  ! euphotic layer deptht
+        IF( iom_use( "LNnut"   ) ) CALL iom_put( "LNnut"  , xlimphy(:,:,:) * tmask(:,:,:) )  ! Nutrient limitation term
+        IF( iom_use( "LPnut"   ) ) CALL iom_put( "LPnut"  , xlimpic(:,:,:) * tmask(:,:,:) )  ! Nutrient limitation term
+        IF( iom_use( "LDnut"   ) ) CALL iom_put( "LDnut"  , xlimdia(:,:,:) * tmask(:,:,:) )  ! Nutrient limitation term
+        IF( iom_use( "LNFe"    ) ) CALL iom_put( "LNFe"   , xlimnfe(:,:,:) * tmask(:,:,:) )  ! Iron limitation term
+        IF( iom_use( "LPFe"    ) ) CALL iom_put( "LPFe"   , xlimpfe(:,:,:) * tmask(:,:,:) )  ! Iron limitation term
+        IF( iom_use( "LDFe"    ) ) CALL iom_put( "LDFe"   , xlimdfe(:,:,:) * tmask(:,:,:) )  ! Iron limitation term
+        IF( iom_use( "SIZEN"   ) ) CALL iom_put( "SIZEN"  , sizen(:,:,:) * tmask(:,:,:) )  ! Iron limitation term
+        IF( iom_use( "SIZEP"   ) ) CALL iom_put( "SIZEP"  , sizep(:,:,:) * tmask(:,:,:) )  ! Iron limitation term
+        IF( iom_use( "SIZED"   ) ) CALL iom_put( "SIZED"  , sized(:,:,:) * tmask(:,:,:) )  ! Iron limitation term
+      ENDIF
+      !
+      IF( ln_timing )  CALL timing_stop('p5z_lim')
+      !
+   END SUBROUTINE p5z_lim
+
+
+   SUBROUTINE p5z_lim_init
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE p5z_lim_init  ***
+      !!
+      !! ** Purpose :   Initialization of nutrient limitation parameters
+      !!
+      !! ** Method  :   Read the nampislim and nampisquota namelists and check
+      !!      the parameters called at the first timestep (nittrc000)
+      !!
+      !! ** input   :   Namelist nampislim
+      !!
+      !!----------------------------------------------------------------------
+      INTEGER :: ios                 ! Local integer output status for namelist read
+      !!
+      NAMELIST/namp5zice/ concnno3, concpno3, concdno3, concnnh4, concpnh4, concdnh4,  &
+         &                concnfer, concpfer, concdfer, concbfe, concnpo4, concppo4,   &
+         &                concdpo4, concbno3, concbnh4, concbpo4, xsizedia, xsizepic,  &
+         &                xsizephy, xsizern, xsizerp, xsizerd, xksi1, xksi2, xkdoc,    &
+         &                caco3r, oxymin
+         !
+      NAMELIST/namp5zquota/ qnnmin, qnnmax, qpnmin, qpnmax, qnpmin, qnpmax, qppmin,      &
+         &                  qppmax, qndmin, qndmax, qpdmin, qpdmax, qfnmax, qfpmax, qfdmax,  &
+         &                  qfnopt, qfpopt, qfdopt
+      !!----------------------------------------------------------------------
+      !
+      REWIND( numnatp_ref )              ! Namelist nampislim in reference namelist : Pisces nutrient limitation parameters
+      READ  ( numnatp_ref, namp5zice, IOSTAT = ios, ERR = 901)
+901   IF( ios /= 0 ) CALL ctl_nam ( ios , 'nampislim in reference namelist', lwp )
+      !
+      REWIND( numnatp_cfg )              ! Namelist nampislim in configuration namelist : Pisces nutrient limitation parameters 
+      READ  ( numnatp_cfg, namp5zice, IOSTAT = ios, ERR = 902 )
+902   IF( ios >  0 ) CALL ctl_nam ( ios , 'nampislim in configuration namelist', lwp )
+      IF(lwm) WRITE ( numonp, namp5zice )
+      !
+      IF(lwp) THEN                         ! control print
+         WRITE(numout,*) ' '
+         WRITE(numout,*) ' Namelist parameters for nutrient limitations, namp5zice'
+         WRITE(numout,*) ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
+         WRITE(numout,*) '    mean rainratio                           caco3r    = ', caco3r
+         WRITE(numout,*) '    NO3 half saturation of nanophyto         concnno3  = ', concnno3
+         WRITE(numout,*) '    NO3 half saturation of picophyto         concpno3  = ', concpno3
+         WRITE(numout,*) '    NO3 half saturation of diatoms           concdno3  = ', concdno3
+         WRITE(numout,*) '    NH4 half saturation for phyto            concnnh4  = ', concnnh4
+         WRITE(numout,*) '    NH4 half saturation for pico             concpnh4  = ', concpnh4
+         WRITE(numout,*) '    NH4 half saturation for diatoms          concdnh4  = ', concdnh4
+         WRITE(numout,*) '    PO4 half saturation for phyto            concnpo4  = ', concnpo4
+         WRITE(numout,*) '    PO4 half saturation for pico             concppo4  = ', concppo4
+         WRITE(numout,*) '    PO4 half saturation for diatoms          concdpo4  = ', concdpo4
+         WRITE(numout,*) '    half saturation constant for Si uptake   xksi1     = ', xksi1
+         WRITE(numout,*) '    half saturation constant for Si/C        xksi2     = ', xksi2
+         WRITE(numout,*) '    half-sat. of DOC remineralization        xkdoc     = ', xkdoc
+         WRITE(numout,*) '    Iron half saturation for nanophyto       concnfer  = ', concnfer
+         WRITE(numout,*) '    Iron half saturation for picophyto       concpfer  = ', concpfer
+         WRITE(numout,*) '    Iron half saturation for diatoms         concdfer  = ', concdfer
+         WRITE(numout,*) '    size ratio for nanophytoplankton         xsizern   = ', xsizern
+         WRITE(numout,*) '    size ratio for picophytoplankton         xsizerp   = ', xsizerp
+         WRITE(numout,*) '    size ratio for diatoms                   xsizerd   = ', xsizerd
+         WRITE(numout,*) '    NO3 half saturation of bacteria          concbno3  = ', concbno3
+         WRITE(numout,*) '    NH4 half saturation for bacteria         concbnh4  = ', concbnh4
+         WRITE(numout,*) '    Minimum size criteria for diatoms        xsizedia  = ', xsizedia
+         WRITE(numout,*) '    Minimum size criteria for picophyto      xsizepic  = ', xsizepic
+         WRITE(numout,*) '    Minimum size criteria for nanophyto      xsizephy  = ', xsizephy
+         WRITE(numout,*) '    Fe half saturation for bacteria          concbfe   = ', concbfe
+         WRITE(numout,*) '    halk saturation constant for anoxia       oxymin   =' , oxymin
+      ENDIF
+
+      REWIND( numnatp_ref )              ! Namelist nampislim in reference namelist : Pisces nutrient limitation parameters
+      READ  ( numnatp_ref, namp5zquota, IOSTAT = ios, ERR = 903)
+903   IF( ios /= 0 ) CALL ctl_nam ( ios , 'nampisquota in reference namelist', lwp )
+      !
+      REWIND( numnatp_cfg )              ! Namelist nampislim in configuration namelist : Pisces nutrient limitation parameters 
+      READ  ( numnatp_cfg, namp5zquota, IOSTAT = ios, ERR = 904 )
+904   IF( ios >  0 ) CALL ctl_nam ( ios , 'nampisquota in configuration namelist', lwp )
+      IF(lwm) WRITE ( numonp, namp5zquota )
+      !
+      IF(lwp) THEN                         ! control print
+         WRITE(numout,*) ' '
+         WRITE(numout,*) ' Namelist parameters for nutrient limitations, namp5zquota'
+         WRITE(numout,*) ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
+         WRITE(numout,*) '    optimal Fe quota for nano.               qfnopt    = ', qfnopt
+         WRITE(numout,*) '    optimal Fe quota for pico.               qfpopt    = ', qfpopt
+         WRITE(numout,*) '    Optimal Fe quota for diatoms             qfdopt    = ', qfdopt
+         WRITE(numout,*) '    Minimal N quota for nano                 qnnmin    = ', qnnmin
+         WRITE(numout,*) '    Maximal N quota for nano                 qnnmax    = ', qnnmax
+         WRITE(numout,*) '    Minimal P quota for nano                 qpnmin    = ', qpnmin
+         WRITE(numout,*) '    Maximal P quota for nano                 qpnmax    = ', qpnmax
+         WRITE(numout,*) '    Minimal N quota for pico                 qnpmin    = ', qnpmin
+         WRITE(numout,*) '    Maximal N quota for pico                 qnpmax    = ', qnpmax
+         WRITE(numout,*) '    Minimal P quota for pico                 qppmin    = ', qppmin
+         WRITE(numout,*) '    Maximal P quota for pico                 qppmax    = ', qppmax
+         WRITE(numout,*) '    Minimal N quota for diatoms              qndmin    = ', qndmin
+         WRITE(numout,*) '    Maximal N quota for diatoms              qndmax    = ', qndmax
+         WRITE(numout,*) '    Minimal P quota for diatoms              qpdmin    = ', qpdmin
+         WRITE(numout,*) '    Maximal P quota for diatoms              qpdmax    = ', qpdmax
+         WRITE(numout,*) '    Maximal Fe quota for nanophyto.          qfnmax    = ', qfnmax
+         WRITE(numout,*) '    Maximal Fe quota for picophyto.          qfpmax    = ', qfpmax
+         WRITE(numout,*) '    Maximal Fe quota for diatoms             qfdmax    = ', qfdmax
+      ENDIF
+      !
+      zpsino3 = 2.3 * rno3
+      zpsinh4 = 1.8 * rno3
+      zpsiuptk = 2.3 * rno3
+      !
+      nitrfac (:,:,:) = 0._wp
+      !
+   END SUBROUTINE p5z_lim_init
+
+
+   INTEGER FUNCTION p5z_lim_alloc()
+      !!----------------------------------------------------------------------
+      !!                     ***  ROUTINE p5z_lim_alloc  ***
+      !!----------------------------------------------------------------------
+      USE lib_mpp , ONLY: ctl_warn
+      INTEGER ::   ierr(2)        ! Local variables
+      !!----------------------------------------------------------------------
+      ierr(:) = 0
+      !
+      !*  Biological arrays for phytoplankton growth
+      ALLOCATE( xpicono3(jpi,jpj,jpk), xpiconh4(jpi,jpj,jpk),       &
+         &      xpicopo4(jpi,jpj,jpk), xpicodop(jpi,jpj,jpk),       &
+         &      xnanodop(jpi,jpj,jpk), xdiatdop(jpi,jpj,jpk),       &
+         &      xnanono3(jpi,jpj,jpk), xdiatno3(jpi,jpj,jpk),       &
+         &      xnanonh4(jpi,jpj,jpk), xdiatnh4(jpi,jpj,jpk),       &
+         &      xnanopo4(jpi,jpj,jpk), xdiatpo4(jpi,jpj,jpk),       &
+         &      xlimphy (jpi,jpj,jpk), xlimdia (jpi,jpj,jpk),       &
+         &      xlimnfe (jpi,jpj,jpk), xlimdfe (jpi,jpj,jpk),       &
+         &      xlimbac (jpi,jpj,jpk), xlimbacl(jpi,jpj,jpk),       &
+         &      xnanofer(jpi,jpj,jpk), xdiatfer(jpi,jpj,jpk),       &
+         &      xpicofer(jpi,jpj,jpk), xlimpfe (jpi,jpj,jpk),       &
+         &      fvnuptk (jpi,jpj,jpk), fvduptk (jpi,jpj,jpk),       &
+         &      fvpuptk (jpi,jpj,jpk), xlimpic (jpi,jpj,jpk),       &
+         &      xlimsi  (jpi,jpj,jpk), STAT=ierr(1) )
+         !
+      !*  Minimum/maximum quotas of phytoplankton
+      ALLOCATE( xqnnmin (jpi,jpj,jpk), xqnnmax(jpi,jpj,jpk),       &
+         &      xqpnmin (jpi,jpj,jpk), xqpnmax(jpi,jpj,jpk),       &
+         &      xqnpmin (jpi,jpj,jpk), xqnpmax(jpi,jpj,jpk),       &
+         &      xqppmin (jpi,jpj,jpk), xqppmax(jpi,jpj,jpk),       &
+         &      xqndmin (jpi,jpj,jpk), xqndmax(jpi,jpj,jpk),       &
+         &      xqpdmin (jpi,jpj,jpk), xqpdmax(jpi,jpj,jpk),     STAT=ierr(2) )
+         !
+      p5z_lim_alloc = MAXVAL( ierr )
+      !
+      IF( p5z_lim_alloc /= 0 ) CALL ctl_warn('p5z_lim_alloc : failed to allocate arrays.')
+      !
+   END FUNCTION p5z_lim_alloc
+   !!======================================================================
+END MODULE  p5zice
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p5zlim.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p5zlim.F90	(revision 9569)
+++ 	(revision )
@@ -1,602 +1,0 @@
-MODULE p5zlim
-   !!======================================================================
-   !!                         ***  MODULE p5zlim  ***
-   !! TOP :   PISCES with variable stoichiometry 
-   !!======================================================================
-   !! History :   1.0  !  2004     (O. Aumont) Original code
-   !!             2.0  !  2007-12  (C. Ethe, G. Madec)  F90
-   !!             3.4  !  2011-04  (O. Aumont, C. Ethe) Limitation for iron modelled in quota 
-   !!             3.6  !  2015-05  (O. Aumont) PISCES quota
-   !!----------------------------------------------------------------------
-   !!   p5z_lim        :   Compute the nutrients limitation terms 
-   !!   p5z_lim_init   :   Read the namelist 
-   !!----------------------------------------------------------------------
-   USE oce_trc         ! Shared ocean-passive tracers variables
-   USE trc             ! Tracers defined
-   USE sms_pisces      ! PISCES variables
-   USE iom             !  I/O manager
-
-   IMPLICIT NONE
-   PRIVATE
-
-   PUBLIC p5z_lim    
-   PUBLIC p5z_lim_init    
-   PUBLIC p5z_lim_alloc
-
-   !! * Shared module variables
-   REAL(wp), PUBLIC ::  concnno3    !:  NO3, PO4 half saturation   
-   REAL(wp), PUBLIC ::  concpno3    !:  NO3, PO4 half saturation   
-   REAL(wp), PUBLIC ::  concdno3    !:  Phosphate half saturation for diatoms  
-   REAL(wp), PUBLIC ::  concnnh4    !:  NH4 half saturation for phyto  
-   REAL(wp), PUBLIC ::  concpnh4    !:  NH4 half saturation for phyto  
-   REAL(wp), PUBLIC ::  concdnh4    !:  NH4 half saturation for diatoms
-   REAL(wp), PUBLIC ::  concnpo4    !:  NH4 half saturation for diatoms
-   REAL(wp), PUBLIC ::  concppo4    !:  NH4 half saturation for diatoms
-   REAL(wp), PUBLIC ::  concdpo4    !:  NH4 half saturation for diatoms
-   REAL(wp), PUBLIC ::  concnfer    !:  Iron half saturation for nanophyto 
-   REAL(wp), PUBLIC ::  concpfer    !:  Iron half saturation for nanophyto 
-   REAL(wp), PUBLIC ::  concdfer    !:  Iron half saturation for diatoms  
-   REAL(wp), PUBLIC ::  concbno3    !:  NO3 half saturation  for bacteria 
-   REAL(wp), PUBLIC ::  concbnh4    !:  NH4 half saturation for bacteria
-   REAL(wp), PUBLIC ::  concbpo4    !:  PO4 half saturation for bacteria
-   REAL(wp), PUBLIC ::  xsizedia    !:  Minimum size criteria for diatoms
-   REAL(wp), PUBLIC ::  xsizepic    !:  Minimum size criteria for diatoms
-   REAL(wp), PUBLIC ::  xsizephy    !:  Minimum size criteria for nanophyto
-   REAL(wp), PUBLIC ::  xsizern     !:  Size ratio for nanophytoplankton
-   REAL(wp), PUBLIC ::  xsizerp     !:  Size ratio for nanophytoplankton
-   REAL(wp), PUBLIC ::  xsizerd     !:  Size ratio for diatoms
-   REAL(wp), PUBLIC ::  xksi1       !:  half saturation constant for Si uptake 
-   REAL(wp), PUBLIC ::  xksi2       !:  half saturation constant for Si/C 
-   REAL(wp), PUBLIC ::  xkdoc       !:  2nd half-sat. of DOC remineralization  
-   REAL(wp), PUBLIC ::  concbfe     !:  Fe half saturation for bacteria 
-   REAL(wp), PUBLIC ::  oxymin      !:  half saturation constant for anoxia
-   REAL(wp), PUBLIC ::  qfnopt      !:  optimal Fe quota for nanophyto
-   REAL(wp), PUBLIC ::  qfpopt      !:  optimal Fe quota for nanophyto
-   REAL(wp), PUBLIC ::  qfdopt      !:  optimal Fe quota for diatoms
-   REAL(wp), PUBLIC ::  caco3r      !:  mean rainratio 
-   REAL(wp), PUBLIC ::  qnnmin      !:  optimal Fe quota for diatoms
-   REAL(wp), PUBLIC ::  qnnmax      !:  optimal Fe quota for diatoms
-   REAL(wp), PUBLIC ::  qpnmin      !:  optimal Fe quota for diatoms
-   REAL(wp), PUBLIC ::  qpnmax      !:  optimal Fe quota for diatoms
-   REAL(wp), PUBLIC ::  qnpmin      !:  optimal Fe quota for diatoms
-   REAL(wp), PUBLIC ::  qnpmax      !:  optimal Fe quota for diatoms
-   REAL(wp), PUBLIC ::  qppmin      !:  optimal Fe quota for diatoms
-   REAL(wp), PUBLIC ::  qppmax      !:  optimal Fe quota for diatoms
-   REAL(wp), PUBLIC ::  qndmin      !:  optimal Fe quota for diatoms
-   REAL(wp), PUBLIC ::  qndmax      !:  optimal Fe quota for diatoms
-   REAL(wp), PUBLIC ::  qpdmin      !:  optimal Fe quota for diatoms
-   REAL(wp), PUBLIC ::  qpdmax      !:  optimal Fe quota for diatoms
-   REAL(wp), PUBLIC ::  qfnmax      !:  optimal Fe quota for diatoms
-   REAL(wp), PUBLIC ::  qfpmax      !:  optimal Fe quota for diatoms
-   REAL(wp), PUBLIC ::  qfdmax      !:  optimal Fe quota for diatoms
-   REAL(wp), PUBLIC ::  zpsinh4
-   REAL(wp), PUBLIC ::  zpsino3
-   REAL(wp), PUBLIC ::  zpsiuptk
-
-   !!*  Allometric variations of the quotas
-   REAL(wp), PUBLIC, ALLOCATABLE, SAVE,   DIMENSION(:,:,:)  ::   xqnnmin    !: ???
-   REAL(wp), PUBLIC, ALLOCATABLE, SAVE,   DIMENSION(:,:,:)  ::   xqnnmax    !: ???
-   REAL(wp), PUBLIC, ALLOCATABLE, SAVE,   DIMENSION(:,:,:)  ::   xqpnmin    !: ???
-   REAL(wp), PUBLIC, ALLOCATABLE, SAVE,   DIMENSION(:,:,:)  ::   xqpnmax    !: ???
-   REAL(wp), PUBLIC, ALLOCATABLE, SAVE,   DIMENSION(:,:,:)  ::   xqnpmin    !: ???
-   REAL(wp), PUBLIC, ALLOCATABLE, SAVE,   DIMENSION(:,:,:)  ::   xqnpmax    !: ???
-   REAL(wp), PUBLIC, ALLOCATABLE, SAVE,   DIMENSION(:,:,:)  ::   xqppmin    !: ???
-   REAL(wp), PUBLIC, ALLOCATABLE, SAVE,   DIMENSION(:,:,:)  ::   xqppmax    !: ???
-   REAL(wp), PUBLIC, ALLOCATABLE, SAVE,   DIMENSION(:,:,:)  ::   xqndmin    !: ???
-   REAL(wp), PUBLIC, ALLOCATABLE, SAVE,   DIMENSION(:,:,:)  ::   xqndmax    !: ???
-   REAL(wp), PUBLIC, ALLOCATABLE, SAVE,   DIMENSION(:,:,:)  ::   xqpdmin    !: ???
-   REAL(wp), PUBLIC, ALLOCATABLE, SAVE,   DIMENSION(:,:,:)  ::   xqpdmax    !: ???
-
-   !!* Phytoplankton limitation terms
-   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)  ::   xnanono3   !: ???
-   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)  ::   xdiatno3   !: ???
-   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)  ::   xnanonh4   !: ???
-   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)  ::   xdiatnh4   !: ???
-   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)  ::   xnanopo4   !: ???
-   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)  ::   xdiatpo4   !: ???
-   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)  ::   xlimphy    !: ???
-   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)  ::   xlimdia    !: ???
-   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)  ::   xlimnfe    !: ???
-   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)  ::   xlimdfe    !: ???
-   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)  ::   xlimsi     !: ???
-   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)  ::   xlimbac    !: ??
-   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)  ::   xlimbacl   !: ??
-   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)  ::   xpicono3   !: ???
-   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)  ::   xpiconh4   !: ???
-   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)  ::   xpicopo4   !: ???
-   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)  ::   xnanodop   !: ???
-   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)  ::   xpicodop   !: ???
-   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)  ::   xdiatdop   !: ???
-   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)  ::   xnanofer   !: ???
-   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)  ::   xpicofer   !: ???
-   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)  ::   xdiatfer   !: ???
-   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)  ::   xlimpic    !: ???
-   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)  ::   xlimpfe    !: ???
-   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)  ::   fvnuptk
-   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)  ::   fvpuptk
-   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)  ::   fvduptk
-
-   ! Coefficient for iron limitation
-   REAL(wp) ::  xcoef1   = 0.00167  / 55.85
-   REAL(wp) ::  xcoef2   = 1.21E-5 * 14. / 55.85 / 7.625 * 0.5 * 1.5
-   REAL(wp) ::  xcoef3   = 1.15E-4 * 14. / 55.85 / 7.625 * 0.5 
-   !!----------------------------------------------------------------------
-   !! NEMO/TOP 3.3 , NEMO Consortium (2010)
-   !! $Id: p4zlim.F90 3160 2011-11-20 14:27:18Z cetlod $ 
-   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
-   !!----------------------------------------------------------------------
-
-CONTAINS
-
-   SUBROUTINE p5z_lim( kt, knt )
-      !!---------------------------------------------------------------------
-      !!                     ***  ROUTINE p5z_lim  ***
-      !!
-      !! ** Purpose :   Compute the co-limitations by the various nutrients
-      !!              for the various phytoplankton species
-      !!
-      !! ** Method  : - ???
-      !!---------------------------------------------------------------------
-      !
-      INTEGER, INTENT(in)  :: kt, knt
-      !
-      INTEGER  ::   ji, jj, jk
-      REAL(wp) ::   zlim1, zlim2, zlim3, zlim4, zno3, zferlim
-      REAL(wp) ::   z1_trndia, z1_trnpic, z1_trnphy, ztem1, ztem2, zetot1
-      REAL(wp) ::   zratio, zration, zratiof, znutlim, zfalim
-      REAL(wp) ::   zconc1d, zconc1dnh4, zconc0n, zconc0nnh4, zconc0npo4, zconc0dpo4
-      REAL(wp) ::   zconc0p, zconc0pnh4, zconc0ppo4, zconcpfe, zconcnfe, zconcdfe
-      REAL(wp) ::   fanano, fananop, fananof, fadiat, fadiatp, fadiatf
-      REAL(wp) ::   fapico, fapicop, fapicof
-      REAL(wp) ::   zrpho, zrass, zcoef, zfuptk, zratchl
-      REAL(wp) ::   zfvn, zfvp, zfvf, zsizen, zsizep, zsized, znanochl, zpicochl, zdiatchl
-      REAL(wp) ::   zqfemn, zqfemp, zqfemd, zbactno3, zbactnh4
-      !!---------------------------------------------------------------------
-      !
-      IF( ln_timing )   CALL timing_start('p5z_lim')
-      !
-      zratchl = 6.0
-      !
-      DO jk = 1, jpkm1
-         DO jj = 1, jpj
-            DO ji = 1, jpi
-               ! 
-               ! Tuning of the iron concentration to a minimum level that is set to the detection limit
-               !-------------------------------------
-               zno3    = trb(ji,jj,jk,jpno3) / 40.e-6
-               zferlim = MAX( 3e-11 * zno3 * zno3, 5e-12 )
-               zferlim = MIN( zferlim, 7e-11 )
-               trb(ji,jj,jk,jpfer) = MAX( trb(ji,jj,jk,jpfer), zferlim )
-
-               ! Computation of the mean relative size of each community
-               ! -------------------------------------------------------
-               z1_trnphy   = 1. / ( trb(ji,jj,jk,jpphy) + rtrn )
-               z1_trnpic   = 1. / ( trb(ji,jj,jk,jppic) + rtrn )
-               z1_trndia   = 1. / ( trb(ji,jj,jk,jpdia) + rtrn )
-               znanochl = trb(ji,jj,jk,jpnch) * z1_trnphy
-               zpicochl = trb(ji,jj,jk,jppch) * z1_trnpic
-               zdiatchl = trb(ji,jj,jk,jpdch) * z1_trndia
-
-               ! Computation of a variable Ks for iron on diatoms taking into account
-               ! that increasing biomass is made of generally bigger cells
-               !------------------------------------------------
-               zsized            = sized(ji,jj,jk)**0.81
-               zconcdfe          = concdfer * zsized
-               zconc1d           = concdno3 * zsized
-               zconc1dnh4        = concdnh4 * zsized
-               zconc0dpo4        = concdpo4 * zsized
-
-               zsizep            = 1.
-               zconcpfe          = concpfer * zsizep
-               zconc0p           = concpno3 * zsizep
-               zconc0pnh4        = concpnh4 * zsizep
-               zconc0ppo4        = concppo4 * zsizep
-
-               zsizen            = 1.
-               zconcnfe          = concnfer * zsizen
-               zconc0n           = concnno3 * zsizen
-               zconc0nnh4        = concnnh4 * zsizen
-               zconc0npo4        = concnpo4 * zsizen
-
-               ! Allometric variations of the minimum and maximum quotas
-               ! From Talmy et al. (2014) and Maranon et al. (2013)
-               ! -------------------------------------------------------
-               xqnnmin(ji,jj,jk) = qnnmin
-               xqnnmax(ji,jj,jk) = qnnmax
-               xqndmin(ji,jj,jk) = qndmin * sized(ji,jj,jk)**(-0.27) 
-               xqndmax(ji,jj,jk) = qndmax
-               xqnpmin(ji,jj,jk) = qnpmin
-               xqnpmax(ji,jj,jk) = qnpmax
-
-               ! Computation of the optimal allocation parameters
-               ! Based on the different papers by Pahlow et al., and Smith et al.
-               ! -----------------------------------------------------------------
-               znutlim = MAX( trb(ji,jj,jk,jpnh4) / zconc0nnh4,    &
-                 &         trb(ji,jj,jk,jpno3) / zconc0n)
-               fanano = MAX(0.01, MIN(0.99, 1. / ( SQRT(znutlim) + 1.) ) )
-               znutlim = trb(ji,jj,jk,jppo4) / zconc0npo4
-               fananop = MAX(0.01, MIN(0.99, 1. / ( SQRT(znutlim) + 1.) ) )
-               znutlim = biron(ji,jj,jk) / zconcnfe
-               fananof = MAX(0.01, MIN(0.99, 1. / ( SQRT(znutlim) + 1.) ) )
-               znutlim = MAX( trb(ji,jj,jk,jpnh4) / zconc0pnh4,    &
-                 &         trb(ji,jj,jk,jpno3) / zconc0p)
-               fapico = MAX(0.01, MIN(0.99, 1. / ( SQRT(znutlim) + 1.) ) )
-               znutlim = trb(ji,jj,jk,jppo4) / zconc0ppo4
-               fapicop = MAX(0.01, MIN(0.99, 1. / ( SQRT(znutlim) + 1.) ) )
-               znutlim = biron(ji,jj,jk) / zconcpfe
-               fapicof = MAX(0.01, MIN(0.99, 1. / ( SQRT(znutlim) + 1.) ) )
-               znutlim = MAX( trb(ji,jj,jk,jpnh4) / zconc1dnh4,    &
-                 &         trb(ji,jj,jk,jpno3) / zconc1d )
-               fadiat = MAX(0.01, MIN(0.99, 1. / ( SQRT(znutlim) + 1.) ) )
-               znutlim = trb(ji,jj,jk,jppo4) / zconc0dpo4
-               fadiatp = MAX(0.01, MIN(0.99, 1. / ( SQRT(znutlim) + 1.) ) )
-               znutlim = biron(ji,jj,jk) / zconcdfe
-               fadiatf = MAX(0.01, MIN(0.99, 1. / ( SQRT(znutlim) + 1.) ) )
-               !
-               ! Michaelis-Menten Limitation term for nutrients Small bacteria
-               ! -------------------------------------------------------------
-               zbactnh4 = trb(ji,jj,jk,jpnh4) / ( concbnh4 + trb(ji,jj,jk,jpnh4) )
-               zbactno3 = trb(ji,jj,jk,jpno3) / ( concbno3 + trb(ji,jj,jk,jpno3) ) * (1. - zbactnh4)
-               !
-               zlim1    = zbactno3 + zbactnh4
-               zlim2    = trb(ji,jj,jk,jppo4) / ( trb(ji,jj,jk,jppo4) + concbpo4)
-               zlim3    = biron(ji,jj,jk) / ( concbfe + biron(ji,jj,jk) )
-               zlim4    = trb(ji,jj,jk,jpdoc) / ( xkdoc   + trb(ji,jj,jk,jpdoc) )
-               xlimbacl(ji,jj,jk) = MIN( zlim1, zlim2, zlim3 )
-               xlimbac (ji,jj,jk) = xlimbacl(ji,jj,jk) * zlim4
-               !
-               ! Michaelis-Menten Limitation term for nutrients Small flagellates
-               ! -----------------------------------------------
-               zfalim = (1.-fanano) / fanano
-               xnanonh4(ji,jj,jk) = (1. - fanano) * trb(ji,jj,jk,jpnh4) / ( zfalim * zconc0nnh4 + trb(ji,jj,jk,jpnh4) )
-               xnanono3(ji,jj,jk) = (1. - fanano) * trb(ji,jj,jk,jpno3) / ( zfalim * zconc0n + trb(ji,jj,jk,jpno3) )  &
-               &                    * (1. - xnanonh4(ji,jj,jk))
-               !
-               zfalim = (1.-fananop) / fananop
-               xnanopo4(ji,jj,jk) = (1. - fananop) * trb(ji,jj,jk,jppo4) / ( trb(ji,jj,jk,jppo4) + zfalim * zconc0npo4 )
-               xnanodop(ji,jj,jk) = trb(ji,jj,jk,jpdop) / ( trb(ji,jj,jk,jpdop) + xkdoc )   &
-               &                    * ( 1.0 - xnanopo4(ji,jj,jk) )
-               xnanodop(ji,jj,jk) = 0.
-               !
-               zfalim = (1.-fananof) / fananof
-               xnanofer(ji,jj,jk) = (1. - fananof) * biron(ji,jj,jk) / ( biron(ji,jj,jk) + zfalim * zconcnfe )
-               !
-               zratiof   = trb(ji,jj,jk,jpnfe) * z1_trnphy
-               zqfemn = xcoef1 * znanochl + xcoef2 + xcoef3 * xnanono3(ji,jj,jk)
-               !
-               zration = trb(ji,jj,jk,jpnph) * z1_trnphy
-               zration = MIN(xqnnmax(ji,jj,jk), MAX( 2. * xqnnmin(ji,jj,jk), zration ))
-               fvnuptk(ji,jj,jk) = 1. / zpsiuptk * rno3 * 2. * xqnnmin(ji,jj,jk) / (zration + rtrn)  &
-               &                   * MAX(0., (1. - zratchl * znanochl / 12. ) )
-               !
-               zlim1    = max(0., (zration - 2. * xqnnmin(ji,jj,jk) )  &
-               &          / (xqnnmax(ji,jj,jk) - 2. * xqnnmin(ji,jj,jk) ) ) * xqnnmax(ji,jj,jk)  &
-               &          / (zration + rtrn)
-               zlim3    = MAX( 0.,( zratiof - zqfemn ) / qfnopt ) 
-               xlimnfe(ji,jj,jk) = MIN( 1., zlim3 )
-               xlimphy(ji,jj,jk) = MIN( 1., zlim1, zlim3 )
-               !
-               ! Michaelis-Menten Limitation term for nutrients picophytoplankton
-               ! ----------------------------------------------------------------
-               zfalim = (1.-fapico) / fapico 
-               xpiconh4(ji,jj,jk) = (1. - fapico) * trb(ji,jj,jk,jpnh4) / ( zfalim * zconc0pnh4 + trb(ji,jj,jk,jpnh4) )
-               xpicono3(ji,jj,jk) = (1. - fapico) * trb(ji,jj,jk,jpno3) / ( zfalim * zconc0p + trb(ji,jj,jk,jpno3) )  &
-               &                    * (1. - xpiconh4(ji,jj,jk))
-               !
-               zfalim = (1.-fapicop) / fapicop 
-               xpicopo4(ji,jj,jk) = (1. - fapicop) * trb(ji,jj,jk,jppo4) / ( trb(ji,jj,jk,jppo4) + zfalim * zconc0ppo4 )
-               xpicodop(ji,jj,jk) = trb(ji,jj,jk,jpdop) / ( trb(ji,jj,jk,jpdop) + xkdoc )   &
-               &                    * ( 1.0 - xpicopo4(ji,jj,jk) )
-               xpicodop(ji,jj,jk) = 0.
-               !
-               zfalim = (1.-fapicof) / fapicof
-               xpicofer(ji,jj,jk) = (1. - fapicof) * biron(ji,jj,jk) / ( biron(ji,jj,jk) + zfalim * zconcpfe )
-               !
-               zratiof   = trb(ji,jj,jk,jppfe) * z1_trnpic
-               zqfemp = xcoef1 * zpicochl + xcoef2 + xcoef3 * xpicono3(ji,jj,jk)
-               !
-               zration   = trb(ji,jj,jk,jpnpi) * z1_trnpic
-               zration = MIN(xqnpmax(ji,jj,jk), MAX( 2. * xqnpmin(ji,jj,jk), zration ))
-               fvpuptk(ji,jj,jk) = 1. / zpsiuptk * rno3 * 2. * xqnpmin(ji,jj,jk) / (zration + rtrn)  &
-               &                   * MAX(0., (1. - zratchl * zpicochl / 12. ) ) 
-               !
-               zlim1    = max(0., (zration - 2. * xqnpmin(ji,jj,jk) )  &
-               &          / (xqnpmax(ji,jj,jk) - 2. * xqnpmin(ji,jj,jk) ) ) * xqnpmax(ji,jj,jk)  &
-               &          / (zration + rtrn)
-               zlim3    = MAX( 0.,( zratiof - zqfemp ) / qfpopt )
-               xlimpfe(ji,jj,jk) = MIN( 1., zlim3 )
-               xlimpic(ji,jj,jk) = MIN( 1., zlim1, zlim3 )
-               !
-               !   Michaelis-Menten Limitation term for nutrients Diatoms
-               !   ------------------------------------------------------
-               zfalim = (1.-fadiat) / fadiat 
-               xdiatnh4(ji,jj,jk) = (1. - fadiat) * trb(ji,jj,jk,jpnh4) / ( zfalim * zconc1dnh4 + trb(ji,jj,jk,jpnh4) )
-               xdiatno3(ji,jj,jk) = (1. - fadiat) * trb(ji,jj,jk,jpno3) / ( zfalim * zconc1d + trb(ji,jj,jk,jpno3) )  &
-               &                    * (1. - xdiatnh4(ji,jj,jk))
-               !
-               zfalim = (1.-fadiatp) / fadiatp
-               xdiatpo4(ji,jj,jk) = (1. - fadiatp) * trb(ji,jj,jk,jppo4) / ( trb(ji,jj,jk,jppo4) + zfalim * zconc0dpo4 )
-               xdiatdop(ji,jj,jk) = trb(ji,jj,jk,jpdop) / ( trb(ji,jj,jk,jpdop) + xkdoc )  &
-               &                    * ( 1.0 - xdiatpo4(ji,jj,jk) )
-               xdiatdop(ji,jj,jk) = 0.
-               !
-               zfalim = (1.-fadiatf) / fadiatf
-               xdiatfer(ji,jj,jk) = (1. - fadiatf) * biron(ji,jj,jk) / ( biron(ji,jj,jk) + zfalim * zconcdfe )
-               !
-               zratiof   = trb(ji,jj,jk,jpdfe) * z1_trndia
-               zqfemd = xcoef1 * zdiatchl + xcoef2 + xcoef3 * xdiatno3(ji,jj,jk)
-               !
-               zration   = trb(ji,jj,jk,jpndi) * z1_trndia
-               zration = MIN(xqndmax(ji,jj,jk), MAX( 2. * xqndmin(ji,jj,jk), zration ))
-               fvduptk(ji,jj,jk) = 1. / zpsiuptk * rno3 * 2. * xqndmin(ji,jj,jk) / (zration + rtrn)   &
-               &                   * MAX(0., (1. - zratchl * zdiatchl / 12. ) ) 
-               !
-               zlim1    = max(0., (zration - 2. * xqndmin(ji,jj,jk) )    &
-               &          / (xqndmax(ji,jj,jk) - 2. * xqndmin(ji,jj,jk) ) )   &
-               &          * xqndmax(ji,jj,jk) / (zration + rtrn)
-               zlim3    = trb(ji,jj,jk,jpsil) / ( trb(ji,jj,jk,jpsil) + xksi(ji,jj) )
-               zlim4    = MAX( 0., ( zratiof - zqfemd ) / qfdopt )
-               xlimdfe(ji,jj,jk) = MIN( 1., zlim4 )
-               xlimdia(ji,jj,jk) = MIN( 1., zlim1, zlim3, zlim4 )
-               xlimsi(ji,jj,jk)  = MIN( zlim1, zlim4 )
-            END DO
-         END DO
-      END DO
-      !
-      ! Compute the phosphorus quota values. It is based on Litchmann et al., 2004 and Daines et al, 2013.
-      ! The relative contribution of three fonctional pools are computed: light harvesting apparatus, 
-      ! nutrient uptake pool and assembly machinery. DNA is assumed to represent 1% of the dry mass of 
-      ! phytoplankton (see Daines et al., 2013). 
-      ! --------------------------------------------------------------------------------------------------
-      DO jk = 1, jpkm1
-         DO jj = 1, jpj
-            DO ji = 1, jpi
-               ! Size estimation of nanophytoplankton
-               ! ------------------------------------
-               zfvn = 2. * fvnuptk(ji,jj,jk)
-               sizen(ji,jj,jk) = MAX(1., MIN(xsizern, 1.0 / ( MAX(rtrn, zfvn) ) ) )
-
-               ! N/P ratio of nanophytoplankton
-               ! ------------------------------
-               zfuptk = 0.23 * zfvn
-               zrpho = 2.24 * trb(ji,jj,jk,jpnch) / ( trb(ji,jj,jk,jpnph) * rno3 * 15. + rtrn )
-               zrass = 1. - 0.2 - zrpho - zfuptk
-               xqpnmax(ji,jj,jk) = ( zfuptk + zrpho ) * 0.0128 * 16. + zrass * 1./ 7.2 * 16.
-               xqpnmax(ji,jj,jk) = xqpnmax(ji,jj,jk) * trb(ji,jj,jk,jpnph) / ( trb(ji,jj,jk,jpphy) + rtrn ) + 0.13
-               xqpnmin(ji,jj,jk) = 0.13 + 0.23 * 0.0128 * 16.
-
-               ! Size estimation of picophytoplankton
-               ! ------------------------------------
-               zfvn = 2. * fvpuptk(ji,jj,jk)
-               sizep(ji,jj,jk) = MAX(1., MIN(xsizerp, 1.0 / ( MAX(rtrn, zfvn) ) ) )
-
-               ! N/P ratio of picophytoplankton
-               ! ------------------------------
-               zfuptk = 0.35 * zfvn
-               zrpho = 2.24 * trb(ji,jj,jk,jppch) / ( trb(ji,jj,jk,jpnpi) * rno3 * 15. + rtrn )
-               zrass = 1. - 0.4 - zrpho - zfuptk
-               xqppmax(ji,jj,jk) =  (zrpho + zfuptk) * 0.0128 * 16. + zrass * 1./ 9. * 16.
-               xqppmax(ji,jj,jk) = xqppmax(ji,jj,jk) * trb(ji,jj,jk,jpnpi) / ( trb(ji,jj,jk,jppic) + rtrn ) + 0.13
-               xqppmin(ji,jj,jk) = 0.13
-
-               ! Size estimation of diatoms
-               ! --------------------------
-               zfvn = 2. * fvduptk(ji,jj,jk)
-               sized(ji,jj,jk) = MAX(1., MIN(xsizerd, 1.0 / ( MAX(rtrn, zfvn) ) ) )
-               zcoef = trb(ji,jj,jk,jpdia) - MIN(xsizedia, trb(ji,jj,jk,jpdia) )
-               sized(ji,jj,jk) = 1. + xsizerd * zcoef *1E6 / ( 1. + zcoef * 1E6 )
-
-               ! N/P ratio of diatoms
-               ! --------------------
-               zfuptk = 0.2 * zfvn
-               zrpho = 2.24 * trb(ji,jj,jk,jpdch) / ( trb(ji,jj,jk,jpndi) * rno3 * 15. + rtrn )
-               zrass = 1. - 0.2 - zrpho - zfuptk
-               xqpdmax(ji,jj,jk) = ( zfuptk + zrpho ) * 0.0128 * 16. + zrass * 1./ 7.2 * 16.
-               xqpdmax(ji,jj,jk) = xqpdmax(ji,jj,jk) * trb(ji,jj,jk,jpndi) / ( trb(ji,jj,jk,jpdia) + rtrn ) + 0.13
-               xqpdmin(ji,jj,jk) = 0.13 + 0.2 * 0.0128 * 16.
-
-            END DO
-         END DO
-      END DO
-
-      ! Compute the fraction of nanophytoplankton that is made of calcifiers
-      ! --------------------------------------------------------------------
-      DO jk = 1, jpkm1
-         DO jj = 1, jpj
-            DO ji = 1, jpi
-               zlim1 =  trb(ji,jj,jk,jpnh4) / ( trb(ji,jj,jk,jpnh4) + concnnh4 ) + trb(ji,jj,jk,jpno3)    &
-               &        / ( trb(ji,jj,jk,jpno3) + concnno3 ) * ( 1.0 - trb(ji,jj,jk,jpnh4)   &
-               &        / ( trb(ji,jj,jk,jpnh4) + concnnh4 ) )
-               zlim2  = trb(ji,jj,jk,jppo4) / ( trb(ji,jj,jk,jppo4) + concnpo4 )
-               zlim3  = trb(ji,jj,jk,jpfer) / ( trb(ji,jj,jk,jpfer) +  5.E-11 ) 
-               ztem1  = MAX( 0., tsn(ji,jj,jk,jp_tem) )
-               ztem2  = tsn(ji,jj,jk,jp_tem) - 10.
-               zetot1 = MAX( 0., etot(ji,jj,jk) - 1.) / ( 4. + etot(ji,jj,jk) ) * 20. / ( 20. + etot(ji,jj,jk) ) 
-
-!               xfracal(ji,jj,jk) = caco3r * MIN( zlim1, zlim2, zlim3 )                  &
-               xfracal(ji,jj,jk) = caco3r                 &
-               &                   * ztem1 / ( 1. + ztem1 ) * MAX( 1., trb(ji,jj,jk,jpphy)*1E6 )   &
-                  &                * ( 1. + EXP(-ztem2 * ztem2 / 25. ) )         &
-                  &                * zetot1 * MIN( 1., 50. / ( hmld(ji,jj) + rtrn ) )
-               xfracal(ji,jj,jk) = MAX( 0.02, MIN( 0.8 , xfracal(ji,jj,jk) ) )
-            END DO
-         END DO
-      END DO
-      !
-      DO jk = 1, jpkm1
-         DO jj = 1, jpj
-            DO ji = 1, jpi
-               ! denitrification factor computed from O2 levels
-               nitrfac(ji,jj,jk) = MAX(  0.e0, 0.4 * ( 6.e-6  - trb(ji,jj,jk,jpoxy) )    &
-                  &                                / ( oxymin + trb(ji,jj,jk,jpoxy) )  )
-               nitrfac(ji,jj,jk) = MIN( 1., nitrfac(ji,jj,jk) )
-            END DO
-         END DO
-      END DO
-      !
-      IF( lk_iomput .AND. knt == nrdttrc ) THEN        ! save output diagnostics
-        IF( iom_use( "xfracal" ) ) CALL iom_put( "xfracal", xfracal(:,:,:) * tmask(:,:,:) )  ! euphotic layer deptht
-        IF( iom_use( "LNnut"   ) ) CALL iom_put( "LNnut"  , xlimphy(:,:,:) * tmask(:,:,:) )  ! Nutrient limitation term
-        IF( iom_use( "LPnut"   ) ) CALL iom_put( "LPnut"  , xlimpic(:,:,:) * tmask(:,:,:) )  ! Nutrient limitation term
-        IF( iom_use( "LDnut"   ) ) CALL iom_put( "LDnut"  , xlimdia(:,:,:) * tmask(:,:,:) )  ! Nutrient limitation term
-        IF( iom_use( "LNFe"    ) ) CALL iom_put( "LNFe"   , xlimnfe(:,:,:) * tmask(:,:,:) )  ! Iron limitation term
-        IF( iom_use( "LPFe"    ) ) CALL iom_put( "LPFe"   , xlimpfe(:,:,:) * tmask(:,:,:) )  ! Iron limitation term
-        IF( iom_use( "LDFe"    ) ) CALL iom_put( "LDFe"   , xlimdfe(:,:,:) * tmask(:,:,:) )  ! Iron limitation term
-        IF( iom_use( "SIZEN"   ) ) CALL iom_put( "SIZEN"  , sizen(:,:,:) * tmask(:,:,:) )  ! Iron limitation term
-        IF( iom_use( "SIZEP"   ) ) CALL iom_put( "SIZEP"  , sizep(:,:,:) * tmask(:,:,:) )  ! Iron limitation term
-        IF( iom_use( "SIZED"   ) ) CALL iom_put( "SIZED"  , sized(:,:,:) * tmask(:,:,:) )  ! Iron limitation term
-      ENDIF
-      !
-      IF( ln_timing )  CALL timing_stop('p5z_lim')
-      !
-   END SUBROUTINE p5z_lim
-
-
-   SUBROUTINE p5z_lim_init
-      !!----------------------------------------------------------------------
-      !!                  ***  ROUTINE p5z_lim_init  ***
-      !!
-      !! ** Purpose :   Initialization of nutrient limitation parameters
-      !!
-      !! ** Method  :   Read the nampislim and nampisquota namelists and check
-      !!      the parameters called at the first timestep (nittrc000)
-      !!
-      !! ** input   :   Namelist nampislim
-      !!
-      !!----------------------------------------------------------------------
-      INTEGER :: ios                 ! Local integer output status for namelist read
-      !!
-      NAMELIST/namp5zlim/ concnno3, concpno3, concdno3, concnnh4, concpnh4, concdnh4,  &
-         &                concnfer, concpfer, concdfer, concbfe, concnpo4, concppo4,   &
-         &                concdpo4, concbno3, concbnh4, concbpo4, xsizedia, xsizepic,  &
-         &                xsizephy, xsizern, xsizerp, xsizerd, xksi1, xksi2, xkdoc,    &
-         &                caco3r, oxymin
-         !
-      NAMELIST/namp5zquota/ qnnmin, qnnmax, qpnmin, qpnmax, qnpmin, qnpmax, qppmin,      &
-         &                  qppmax, qndmin, qndmax, qpdmin, qpdmax, qfnmax, qfpmax, qfdmax,  &
-         &                  qfnopt, qfpopt, qfdopt
-      !!----------------------------------------------------------------------
-      !
-      REWIND( numnatp_ref )              ! Namelist nampislim in reference namelist : Pisces nutrient limitation parameters
-      READ  ( numnatp_ref, namp5zlim, IOSTAT = ios, ERR = 901)
-901   IF( ios /= 0 ) CALL ctl_nam ( ios , 'nampislim in reference namelist', lwp )
-      !
-      REWIND( numnatp_cfg )              ! Namelist nampislim in configuration namelist : Pisces nutrient limitation parameters 
-      READ  ( numnatp_cfg, namp5zlim, IOSTAT = ios, ERR = 902 )
-902   IF( ios >  0 ) CALL ctl_nam ( ios , 'nampislim in configuration namelist', lwp )
-      IF(lwm) WRITE ( numonp, namp5zlim )
-      !
-      IF(lwp) THEN                         ! control print
-         WRITE(numout,*) ' '
-         WRITE(numout,*) ' Namelist parameters for nutrient limitations, namp5zlim'
-         WRITE(numout,*) ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
-         WRITE(numout,*) '    mean rainratio                           caco3r    = ', caco3r
-         WRITE(numout,*) '    NO3 half saturation of nanophyto         concnno3  = ', concnno3
-         WRITE(numout,*) '    NO3 half saturation of picophyto         concpno3  = ', concpno3
-         WRITE(numout,*) '    NO3 half saturation of diatoms           concdno3  = ', concdno3
-         WRITE(numout,*) '    NH4 half saturation for phyto            concnnh4  = ', concnnh4
-         WRITE(numout,*) '    NH4 half saturation for pico             concpnh4  = ', concpnh4
-         WRITE(numout,*) '    NH4 half saturation for diatoms          concdnh4  = ', concdnh4
-         WRITE(numout,*) '    PO4 half saturation for phyto            concnpo4  = ', concnpo4
-         WRITE(numout,*) '    PO4 half saturation for pico             concppo4  = ', concppo4
-         WRITE(numout,*) '    PO4 half saturation for diatoms          concdpo4  = ', concdpo4
-         WRITE(numout,*) '    half saturation constant for Si uptake   xksi1     = ', xksi1
-         WRITE(numout,*) '    half saturation constant for Si/C        xksi2     = ', xksi2
-         WRITE(numout,*) '    half-sat. of DOC remineralization        xkdoc     = ', xkdoc
-         WRITE(numout,*) '    Iron half saturation for nanophyto       concnfer  = ', concnfer
-         WRITE(numout,*) '    Iron half saturation for picophyto       concpfer  = ', concpfer
-         WRITE(numout,*) '    Iron half saturation for diatoms         concdfer  = ', concdfer
-         WRITE(numout,*) '    size ratio for nanophytoplankton         xsizern   = ', xsizern
-         WRITE(numout,*) '    size ratio for picophytoplankton         xsizerp   = ', xsizerp
-         WRITE(numout,*) '    size ratio for diatoms                   xsizerd   = ', xsizerd
-         WRITE(numout,*) '    NO3 half saturation of bacteria          concbno3  = ', concbno3
-         WRITE(numout,*) '    NH4 half saturation for bacteria         concbnh4  = ', concbnh4
-         WRITE(numout,*) '    Minimum size criteria for diatoms        xsizedia  = ', xsizedia
-         WRITE(numout,*) '    Minimum size criteria for picophyto      xsizepic  = ', xsizepic
-         WRITE(numout,*) '    Minimum size criteria for nanophyto      xsizephy  = ', xsizephy
-         WRITE(numout,*) '    Fe half saturation for bacteria          concbfe   = ', concbfe
-         WRITE(numout,*) '    halk saturation constant for anoxia       oxymin   =' , oxymin
-      ENDIF
-
-      REWIND( numnatp_ref )              ! Namelist nampislim in reference namelist : Pisces nutrient limitation parameters
-      READ  ( numnatp_ref, namp5zquota, IOSTAT = ios, ERR = 903)
-903   IF( ios /= 0 ) CALL ctl_nam ( ios , 'nampisquota in reference namelist', lwp )
-      !
-      REWIND( numnatp_cfg )              ! Namelist nampislim in configuration namelist : Pisces nutrient limitation parameters 
-      READ  ( numnatp_cfg, namp5zquota, IOSTAT = ios, ERR = 904 )
-904   IF( ios >  0 ) CALL ctl_nam ( ios , 'nampisquota in configuration namelist', lwp )
-      IF(lwm) WRITE ( numonp, namp5zquota )
-      !
-      IF(lwp) THEN                         ! control print
-         WRITE(numout,*) ' '
-         WRITE(numout,*) ' Namelist parameters for nutrient limitations, namp5zquota'
-         WRITE(numout,*) ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
-         WRITE(numout,*) '    optimal Fe quota for nano.               qfnopt    = ', qfnopt
-         WRITE(numout,*) '    optimal Fe quota for pico.               qfpopt    = ', qfpopt
-         WRITE(numout,*) '    Optimal Fe quota for diatoms             qfdopt    = ', qfdopt
-         WRITE(numout,*) '    Minimal N quota for nano                 qnnmin    = ', qnnmin
-         WRITE(numout,*) '    Maximal N quota for nano                 qnnmax    = ', qnnmax
-         WRITE(numout,*) '    Minimal P quota for nano                 qpnmin    = ', qpnmin
-         WRITE(numout,*) '    Maximal P quota for nano                 qpnmax    = ', qpnmax
-         WRITE(numout,*) '    Minimal N quota for pico                 qnpmin    = ', qnpmin
-         WRITE(numout,*) '    Maximal N quota for pico                 qnpmax    = ', qnpmax
-         WRITE(numout,*) '    Minimal P quota for pico                 qppmin    = ', qppmin
-         WRITE(numout,*) '    Maximal P quota for pico                 qppmax    = ', qppmax
-         WRITE(numout,*) '    Minimal N quota for diatoms              qndmin    = ', qndmin
-         WRITE(numout,*) '    Maximal N quota for diatoms              qndmax    = ', qndmax
-         WRITE(numout,*) '    Minimal P quota for diatoms              qpdmin    = ', qpdmin
-         WRITE(numout,*) '    Maximal P quota for diatoms              qpdmax    = ', qpdmax
-         WRITE(numout,*) '    Maximal Fe quota for nanophyto.          qfnmax    = ', qfnmax
-         WRITE(numout,*) '    Maximal Fe quota for picophyto.          qfpmax    = ', qfpmax
-         WRITE(numout,*) '    Maximal Fe quota for diatoms             qfdmax    = ', qfdmax
-      ENDIF
-      !
-      zpsino3 = 2.3 * rno3
-      zpsinh4 = 1.8 * rno3
-      zpsiuptk = 2.3 * rno3
-      !
-      nitrfac (:,:,:) = 0._wp
-      !
-   END SUBROUTINE p5z_lim_init
-
-
-   INTEGER FUNCTION p5z_lim_alloc()
-      !!----------------------------------------------------------------------
-      !!                     ***  ROUTINE p5z_lim_alloc  ***
-      !!----------------------------------------------------------------------
-      USE lib_mpp , ONLY: ctl_warn
-      INTEGER ::   ierr(2)        ! Local variables
-      !!----------------------------------------------------------------------
-      ierr(:) = 0
-      !
-      !*  Biological arrays for phytoplankton growth
-      ALLOCATE( xpicono3(jpi,jpj,jpk), xpiconh4(jpi,jpj,jpk),       &
-         &      xpicopo4(jpi,jpj,jpk), xpicodop(jpi,jpj,jpk),       &
-         &      xnanodop(jpi,jpj,jpk), xdiatdop(jpi,jpj,jpk),       &
-         &      xnanono3(jpi,jpj,jpk), xdiatno3(jpi,jpj,jpk),       &
-         &      xnanonh4(jpi,jpj,jpk), xdiatnh4(jpi,jpj,jpk),       &
-         &      xnanopo4(jpi,jpj,jpk), xdiatpo4(jpi,jpj,jpk),       &
-         &      xlimphy (jpi,jpj,jpk), xlimdia (jpi,jpj,jpk),       &
-         &      xlimnfe (jpi,jpj,jpk), xlimdfe (jpi,jpj,jpk),       &
-         &      xlimbac (jpi,jpj,jpk), xlimbacl(jpi,jpj,jpk),       &
-         &      xnanofer(jpi,jpj,jpk), xdiatfer(jpi,jpj,jpk),       &
-         &      xpicofer(jpi,jpj,jpk), xlimpfe (jpi,jpj,jpk),       &
-         &      fvnuptk (jpi,jpj,jpk), fvduptk (jpi,jpj,jpk),       &
-         &      fvpuptk (jpi,jpj,jpk), xlimpic (jpi,jpj,jpk),       &
-         &      xlimsi  (jpi,jpj,jpk), STAT=ierr(1) )
-         !
-      !*  Minimum/maximum quotas of phytoplankton
-      ALLOCATE( xqnnmin (jpi,jpj,jpk), xqnnmax(jpi,jpj,jpk),       &
-         &      xqpnmin (jpi,jpj,jpk), xqpnmax(jpi,jpj,jpk),       &
-         &      xqnpmin (jpi,jpj,jpk), xqnpmax(jpi,jpj,jpk),       &
-         &      xqppmin (jpi,jpj,jpk), xqppmax(jpi,jpj,jpk),       &
-         &      xqndmin (jpi,jpj,jpk), xqndmax(jpi,jpj,jpk),       &
-         &      xqpdmin (jpi,jpj,jpk), xqpdmax(jpi,jpj,jpk),     STAT=ierr(2) )
-         !
-      p5z_lim_alloc = MAXVAL( ierr )
-      !
-      IF( p5z_lim_alloc /= 0 ) CALL ctl_warn('p5z_lim_alloc : failed to allocate arrays.')
-      !
-   END FUNCTION p5z_lim_alloc
-   !!======================================================================
-END MODULE  p5zlim
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p5zmicro.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p5zmicro.F90	(revision 9569)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p5zmicro.F90	(revision 9570)
@@ -15,5 +15,5 @@
    USE trc             !  passive tracers common variables 
    USE sms_pisces      !  PISCES Source Minus Sink variables
-   USE p5zlim          !  Phytoplankton limitation terms
+   USE p5zice          !  Phytoplankton limitation terms
    USE iom             !  I/O manager
    USE prtctl_trc      !  print control for debugging
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p5zmort.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p5zmort.F90	(revision 9569)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p5zmort.F90	(revision 9570)
@@ -14,5 +14,5 @@
    USE trc             !  passive tracers common variables 
    USE sms_pisces      !  PISCES Source Minus Sink variables
-   USE p5zlim          !  Phytoplankton limitation terms
+   USE p5zice          !  Phytoplankton limitation terms
    USE prtctl_trc      !  print control for debugging
 
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p5zprod.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p5zprod.F90	(revision 9569)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p5zprod.F90	(revision 9570)
@@ -16,5 +16,5 @@
    USE trc             !  passive tracers common variables 
    USE sms_pisces      !  PISCES Source Minus Sink variables
-   USE p5zlim          !  Co-limitations of differents nutrients
+   USE p5zice          !  Co-limitations of differents nutrients
    USE prtctl_trc      !  print control for debugging
    USE iom             !  I/O manager
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/TOP_SRC/PISCES/trcini_pisces.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/TOP_SRC/PISCES/trcini_pisces.F90	(revision 9569)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/TOP_SRC/PISCES/trcini_pisces.F90	(revision 9570)
@@ -61,5 +61,5 @@
       USE p4zrem          !  Remineralisation of organic matter
       USE p4zflx          !  Gas exchange
-      USE p4zlim          !  Co-limitations of differents nutrients
+      USE p4zice          !  Co-limitations of differents nutrients
       USE p4zprod         !  Growth rate of the 2 phyto groups
       USE p4zmicro        !  Sources and sinks of microzooplankton
@@ -70,5 +70,5 @@
       USE p4zpoc          !  Remineralization of organic particles
       USE p4zligand       !  Remineralization of organic ligands
-      USE p5zlim          !  Co-limitations of differents nutrients
+      USE p5zice          !  Co-limitations of differents nutrients
       USE p5zprod         !  Growth rate of the 2 phyto groups
       USE p5zmicro        !  Sources and sinks of microzooplankton
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/TOP_SRC/trcbdy.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/TOP_SRC/trcbdy.F90	(revision 9569)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/TOP_SRC/trcbdy.F90	(revision 9570)
@@ -31,5 +31,5 @@
 
    !!----------------------------------------------------------------------
-   !! NEMO/OPA 4.0 , NEMO Consortium (2016)
+   !! NEMO/OCE 4.0 , NEMO Consortium (2016)
    !! $Id$ 
    !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/TOP_SRC/trcdta.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/TOP_SRC/trcdta.F90	(revision 9569)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/TOP_SRC/trcdta.F90	(revision 9570)
@@ -40,5 +40,5 @@
 
    !!----------------------------------------------------------------------
-   !! NEMO/OPA 3.3 , NEMO Consortium (2010)
+   !! NEMO/OCE 3.3 , NEMO Consortium (2010)
    !! $Id$ 
    !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
Index: branches/2017/dev_merge_2017/NEMOGCM/NEMO/TOP_SRC/trcsub.F90
===================================================================
--- branches/2017/dev_merge_2017/NEMOGCM/NEMO/TOP_SRC/trcsub.F90	(revision 9569)
+++ branches/2017/dev_merge_2017/NEMOGCM/NEMO/TOP_SRC/trcsub.F90	(revision 9570)
@@ -24,6 +24,6 @@
    USE lbclnk
 #if defined key_agrif
-   USE agrif_opa_update
-   USE agrif_opa_interp
+   USE agrif_oce_update
+   USE agrif_oce_interp
 #endif
 
