New URL for NEMO forge!   http://forge.nemo-ocean.eu

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.
Changeset 5313 for branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO – NEMO

Ignore:
Timestamp:
2015-05-29T11:46:03+02:00 (9 years ago)
Author:
timgraham
Message:

Merged head of trunk (r5302) into branch

Location:
branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO
Files:
3 deleted
143 edited
1 copied

Legend:

Unmodified
Added
Removed

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/LIM_SRC_2/ice_2.F90

    r5312 r5313  
    3737   INTEGER , PUBLIC ::   nbiter      !: number of sub-time steps for relaxation 
    3838   INTEGER , PUBLIC ::   nbitdr      !: maximum number of iterations for relaxation 
    39    INTEGER , PUBLIC ::   nevp        !: number of EVP subcycling iterations 
     39   INTEGER , PUBLIC ::   nn_nevp     !: number of EVP subcycling iterations 
    4040   INTEGER , PUBLIC ::   telast      !: timescale for EVP elastic waves 
    4141   REAL(wp), PUBLIC ::   epsd        !: tolerance parameter for dynamic 
    … …  
    4949   REAL(wp), PUBLIC ::   c_rhg       !: second bulk-rhelogy parameter 
    5050   REAL(wp), PUBLIC ::   etamn       !: minimun value for viscosity 
    51    REAL(wp), PUBLIC ::   creepl      !: creep limit 
    52    REAL(wp), PUBLIC ::   ecc         !: eccentricity of the elliptical yield curve 
     51   REAL(wp), PUBLIC ::   rn_creepl   !: creep limit 
     52   REAL(wp), PUBLIC ::   rn_ecc      !: eccentricity of the elliptical yield curve 
    5353   REAL(wp), PUBLIC ::   ahi0        !: sea-ice hor. eddy diffusivity coeff. (m2/s) 
    5454   REAL(wp), PUBLIC ::   alphaevp    !: coefficient for the solution of EVP int. stresses 
    55    REAL(wp), PUBLIC ::   hminrhg = 0.001_wp    !: clem : ice volume (a*h in m) below which ice velocity is set to ocean velocity 
    56  
    57    REAL(wp), PUBLIC ::   usecc2                !:  = 1.0 / ( ecc * ecc ) 
     55 
     56   REAL(wp), PUBLIC ::   usecc2                !:  = 1.0 / ( rn_ecc * rn_ecc ) 
    5857   REAL(wp), PUBLIC ::   rhoco                 !: = rau0 * cw 
    5958   REAL(wp), PUBLIC ::   sangvg, cangvg        !: sin and cos of the turning angle for ocean stress 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/LIM_SRC_2/limdyn_2.F90

    r5312 r5313  
    227227      NAMELIST/namicedyn/ epsd, alpha,     & 
    228228         &                dm, nbiter, nbitdr, om, resl, cw, angvg, pstar,   & 
    229          &                c_rhg, etamn, creepl, ecc, ahi0,                  & 
    230          &                nevp, telast, alphaevp, hminrhg 
     229         &                c_rhg, etamn, rn_creepl, rn_ecc, ahi0,                  & 
     230         &                nn_nevp, telast, alphaevp 
    231231      !!------------------------------------------------------------------- 
    232232                     
    … …  
    256256         WRITE(numout,*) '       second bulk-rhelogy parameter                    c_rhg  = ', c_rhg 
    257257         WRITE(numout,*) '       minimun value for viscosity                      etamn  = ', etamn 
    258          WRITE(numout,*) '       creep limit                                      creepl = ', creepl 
    259          WRITE(numout,*) '       eccentricity of the elliptical yield curve       ecc    = ', ecc 
     258         WRITE(numout,*) '       creep limit                                      rn_creepl = ', rn_creepl 
     259         WRITE(numout,*) '       eccentricity of the elliptical yield curve       rn_ecc = ', rn_ecc 
    260260         WRITE(numout,*) '       horizontal diffusivity coeff. for sea-ice        ahi0   = ', ahi0 
    261          WRITE(numout,*) '       number of iterations for subcycling nevp   = ', nevp 
     261         WRITE(numout,*) '       number of iterations for subcycling              nn_nevp= ', nn_nevp 
    262262         WRITE(numout,*) '       timescale for elastic waves telast = ', telast 
    263263         WRITE(numout,*) '       coefficient for the solution of int. stresses alphaevp = ', alphaevp 
    264          WRITE(numout,*) '       min ice thickness for rheology calculations     hminrhg = ', hminrhg 
    265264      ENDIF 
    266265      ! 
    … …  
    272271 
    273272      !  Initialization 
    274       usecc2 = 1.0 / ( ecc * ecc ) 
     273      usecc2 = 1.0 / ( rn_ecc * rn_ecc ) 
    275274      rhoco  = rau0 * cw 
    276275      angvg  = angvg * rad      ! convert angvg from degree to radian 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/LIM_SRC_2/limrhg_2.F90

    r5312 r5313  
    266266 
    267267               !  Creep limit depends on the size of the grid. 
    268                zdelta = MAX( SQRT( ztrace2 + ( ztrace2 - 4._wp * zdeter ) * usecc2 ),  creepl) 
     268               zdelta = MAX( SQRT( ztrace2 + ( ztrace2 - 4._wp * zdeter ) * usecc2 ),  rn_creepl) 
    269269 
    270270               !-  Computation of viscosities. 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/LIM_SRC_3/dom_ice.F90

    r5312 r5313  
    55   !!====================================================================== 
    66   !! History :  3.0  ! 2003-08  (M. Vancoppenolle)  LIM-3 original code 
    7    !!            4.0  ! 2011-02  (G. Madec) dynamical allocation 
     7   !!            3.5  ! 2011-02  (G. Madec) dynamical allocation 
    88   !!---------------------------------------------------------------------- 
    9    USE par_ice        ! LIM-3 parameter 
    109   USE in_out_manager ! I/O manager 
    1110   USE lib_mpp        ! MPP library 
    … …  
    2120   INTEGER, PUBLIC ::   njeq , njeqm1        !: j-index of the equator if it is inside the domain 
    2221 
    23    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   fcor       !: coriolis coefficient 
    24    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   covrai     !: sine of geographic latitude 
    25    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   area       !: surface of grid cell  
    26    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   tms, tmi   !: temperature mask, mask for stress 
    27    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   tmu, tmv   !: mask at u and v velocity points 
    28    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   tmf        !: mask at f-point 
    29  
     22   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)     ::   fcor   !: coriolis coefficient 
    3023   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) ::   wght   !: weight of the 4 neighbours to compute averages 
    3124 
    … …  
    4437      !!------------------------------------------------------------------- 
    4538      ! 
    46       ALLOCATE( fcor(jpi,jpj)                   ,      & 
    47          &      covrai(jpi,jpj) , area(jpi,jpj) ,      & 
    48          &      tms   (jpi,jpj) , tmi (jpi,jpj) ,      & 
    49          &      tmu   (jpi,jpj) , tmv (jpi,jpj) ,      & 
    50          &      tmf   (jpi,jpj) ,                      & 
    51          &      wght(jpi,jpj,2,2)               , STAT = dom_ice_alloc ) 
     39      ALLOCATE( fcor(jpi,jpj), wght(jpi,jpj,2,2), STAT = dom_ice_alloc ) 
    5240      ! 
    5341      IF( dom_ice_alloc /= 0 )   CALL ctl_warn( 'dom_ice_alloc: failed to allocate arrays.' ) 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/LIM_SRC_3/ice.F90

    r5312 r5313  
    1111   !!   'key_lim3'                                      LIM-3 sea-ice model 
    1212   !!---------------------------------------------------------------------- 
    13    USE par_ice        ! LIM sea-ice parameters 
    1413   USE in_out_manager ! I/O manager 
    1514   USE lib_mpp        ! MPP library 
    … …  
    1817   PRIVATE 
    1918 
    20    PUBLIC    ice_alloc  !  Called in iceini.F90 
     19   PUBLIC    ice_alloc  !  Called in sbc_lim_init 
    2120 
    2221   !!====================================================================== 
    … …  
    110109   !! smv_i       |      -      |    Sea ice salt content         | ppt.m | 
    111110   !! oa_i        !      -      !    Sea ice areal age content    | day   | 
    112    !! e_i         !      -      !    Ice enthalpy                 | 10^9 J|  
     111   !! e_i         !      -      !    Ice enthalpy                 | J/m2  |  
    113112   !!      -      ! q_i_1d      !    Ice enthalpy per unit vol.   | J/m3  |  
    114    !! e_s         !      -      !    Snow enthalpy                | 10^9 J|  
     113   !! e_s         !      -      !    Snow enthalpy                | J/m2  |  
    115114   !!      -      ! q_s_1d      !    Snow enthalpy per unit vol.  | J/m3  |  
    116115   !!                                                                     | 
    … …  
    148147   !! tm_i        |      -      |    Mean sea ice temperature     | K     | 
    149148   !! ot_i        !      -      !    Sea ice areal age content    | day   | 
    150    !! et_i        !      -      !    Total ice enthalpy           | 10^9 J|  
    151    !! et_s        !      -      !    Total snow enthalpy          | 10^9 J|  
     149   !! et_i        !      -      !    Total ice enthalpy           | J/m2  |  
     150   !! et_s        !      -      !    Total snow enthalpy          | J/m2  |  
    152151   !! bv_i        !      -      !    Mean relative brine volume   | ???   |  
    153152   !!===================================================================== 
    … …  
    165164   REAL(wp), PUBLIC ::   r1_rdtice        !: = 1. / rdt_ice 
    166165 
    167    !                                     !!** ice-dynamic namelist (namicedyn) ** 
    168    INTEGER , PUBLIC ::   nevp             !: number of iterations for subcycling 
    169    REAL(wp), PUBLIC ::   epsd             !: tolerance parameter for dynamic 
    170    REAL(wp), PUBLIC ::   om               !: relaxation constant 
    171    REAL(wp), PUBLIC ::   cw               !: drag coefficient for oceanic stress 
    172    REAL(wp), PUBLIC ::   pstar            !: determines ice strength (N/M), Hibler JPO79 
    173    REAL(wp), PUBLIC ::   c_rhg            !: determines changes in ice strength 
    174    REAL(wp), PUBLIC ::   creepl           !: creep limit : has to be under 1.0e-9 
    175    REAL(wp), PUBLIC ::   ecc              !: eccentricity of the elliptical yield curve 
    176    REAL(wp), PUBLIC ::   ahi0             !: sea-ice hor. eddy diffusivity coeff. (m2/s) 
    177    REAL(wp), PUBLIC ::   telast           !: timescale for elastic waves (s) 
    178    REAL(wp), PUBLIC ::   relast           !: ratio => telast/rdt_ice (1/3 or 1/9 depending on nb of subcycling nevp)  
    179    REAL(wp), PUBLIC ::   alphaevp         !: coeficient of the internal stresses  
    180    REAL(wp), PUBLIC ::   hminrhg          !: ice volume (a*h, in m) below which ice velocity is set to ocean velocity 
     166   !                                     !!** ice-thickness distribution namelist (namiceitd) ** 
     167   INTEGER , PUBLIC ::   nn_catbnd        !: categories distribution following: tanh function (1), or h^(-alpha) function (2) 
     168   REAL(wp), PUBLIC ::   rn_himean        !: mean thickness of the domain (used to compute the distribution, nn_itdshp = 2 only) 
     169 
     170   !                                     !!** ice-dynamics namelist (namicedyn) ** 
     171   LOGICAL , PUBLIC ::   ln_icestr_bvf    !: use brine volume to diminish ice strength 
     172   INTEGER , PUBLIC ::   nn_icestr        !: ice strength parameterization (0=Hibler79 1=Rothrock75) 
     173   INTEGER , PUBLIC ::   nn_nevp          !: number of iterations for subcycling 
     174   INTEGER , PUBLIC ::   nn_ahi0          !: sea-ice hor. eddy diffusivity coeff. (3 ways of calculation) 
     175   REAL(wp), PUBLIC ::   rn_pe_rdg        !: ridging work divided by pot. energy change in ridging, nn_icestr = 1 
     176   REAL(wp), PUBLIC ::   rn_cio           !: drag coefficient for oceanic stress 
     177   REAL(wp), PUBLIC ::   rn_pstar         !: determines ice strength (N/M), Hibler JPO79 
     178   REAL(wp), PUBLIC ::   rn_crhg          !: determines changes in ice strength 
     179   REAL(wp), PUBLIC ::   rn_creepl        !: creep limit : has to be under 1.0e-9 
     180   REAL(wp), PUBLIC ::   rn_ecc           !: eccentricity of the elliptical yield curve 
     181   REAL(wp), PUBLIC ::   rn_ahi0_ref      !: sea-ice hor. eddy diffusivity coeff. (m2/s) 
     182   REAL(wp), PUBLIC ::   rn_relast        !: ratio => telast/rdt_ice (1/3 or 1/9 depending on nb of subcycling nevp)  
    181183 
    182184   !                                     !!** ice-salinity namelist (namicesal) ** 
    183    REAL(wp), PUBLIC ::   s_i_max          !: maximum ice salinity [PSU] 
    184    REAL(wp), PUBLIC ::   s_i_min          !: minimum ice salinity [PSU] 
    185    REAL(wp), PUBLIC ::   s_i_0            !: 1st sal. value for the computation of sal .prof. [PSU] 
    186    REAL(wp), PUBLIC ::   s_i_1            !: 2nd sal. value for the computation of sal .prof. [PSU] 
    187    REAL(wp), PUBLIC ::   sal_G            !: restoring salinity for gravity drainage [PSU] 
    188    REAL(wp), PUBLIC ::   sal_F            !: restoring salinity for flushing [PSU] 
    189    REAL(wp), PUBLIC ::   time_G           !: restoring time constant for gravity drainage (= 20 days) [s] 
    190    REAL(wp), PUBLIC ::   time_F           !: restoring time constant for gravity drainage (= 10 days) [s] 
    191    REAL(wp), PUBLIC ::   bulk_sal         !: bulk salinity (ppt) in case of constant salinity 
     185   REAL(wp), PUBLIC ::   rn_simax         !: maximum ice salinity [PSU] 
     186   REAL(wp), PUBLIC ::   rn_simin         !: minimum ice salinity [PSU] 
     187   REAL(wp), PUBLIC ::   rn_sal_gd        !: restoring salinity for gravity drainage [PSU] 
     188   REAL(wp), PUBLIC ::   rn_sal_fl        !: restoring salinity for flushing [PSU] 
     189   REAL(wp), PUBLIC ::   rn_time_gd       !: restoring time constant for gravity drainage (= 20 days) [s] 
     190   REAL(wp), PUBLIC ::   rn_time_fl       !: restoring time constant for gravity drainage (= 10 days) [s] 
     191   REAL(wp), PUBLIC ::   rn_icesal        !: bulk salinity (ppt) in case of constant salinity 
    192192 
    193193   !                                     !!** ice-salinity namelist (namicesal) ** 
    194    INTEGER , PUBLIC ::   num_sal             !: salinity configuration used in the model 
     194   INTEGER , PUBLIC ::   nn_icesal           !: salinity configuration used in the model 
    195195   !                                         ! 1 - constant salinity in both space and time 
    196196   !                                         ! 2 - prognostic salinity (s(z,t)) 
    197197   !                                         ! 3 - salinity profile, constant in time 
    198    INTEGER , PUBLIC ::   thcon_i_swi         !: thermal conductivity: =0 Untersteiner (1964) ; =1 Pringle et al (2007) 
     198   INTEGER , PUBLIC ::   nn_ice_thcon        !: thermal conductivity: =0 Untersteiner (1964) ; =1 Pringle et al (2007) 
     199   INTEGER , PUBLIC ::   nn_monocat          !: virtual ITD mono-category parameterizations (1) or not (0) 
     200   LOGICAL , PUBLIC ::   ln_it_qnsice        !: iterate surface flux with changing surface temperature or not (F) 
    199201 
    200202   !                                     !!** ice-mechanical redistribution namelist (namiceitdme) 
    201    REAL(wp), PUBLIC ::   Cs               !: fraction of shearing energy contributing to ridging             
    202    REAL(wp), PUBLIC ::   Cf               !: ratio of ridging work to PE loss 
    203    REAL(wp), PUBLIC ::   fsnowrdg         !: fractional snow loss to the ocean during ridging 
    204    REAL(wp), PUBLIC ::   fsnowrft         !: fractional snow loss to the ocean during ridging 
    205    REAL(wp), PUBLIC ::   Gstar            !: fractional area of young ice contributing to ridging 
    206    REAL(wp), PUBLIC ::   astar            !: equivalent of G* for an exponential participation function 
    207    REAL(wp), PUBLIC ::   Hstar            !: thickness that determines the maximal thickness of ridged ice 
    208    REAL(wp), PUBLIC ::   hparmeter        !: threshold thickness (m) for rafting / ridging  
    209    REAL(wp), PUBLIC ::   Craft            !: coefficient for smoothness of the hyperbolic tangent in rafting 
    210    REAL(wp), PUBLIC ::   ridge_por        !: initial porosity of ridges (0.3 regular value) 
    211    REAL(wp), PUBLIC ::   betas            !: coef. for partitioning of snowfall between leads and sea ice 
    212    REAL(wp), PUBLIC ::   kappa_i          !: coef. for the extinction of radiation Grenfell et al. (2006) [1/m] 
    213    REAL(wp), PUBLIC ::   nconv_i_thd      !: maximal number of iterations for heat diffusion 
    214    REAL(wp), PUBLIC ::   maxer_i_thd      !: maximal tolerated error (C) for heat diffusion 
     203   REAL(wp), PUBLIC ::   rn_cs            !: fraction of shearing energy contributing to ridging             
     204   REAL(wp), PUBLIC ::   rn_fsnowrdg      !: fractional snow loss to the ocean during ridging 
     205   REAL(wp), PUBLIC ::   rn_fsnowrft      !: fractional snow loss to the ocean during ridging 
     206   REAL(wp), PUBLIC ::   rn_gstar         !: fractional area of young ice contributing to ridging 
     207   REAL(wp), PUBLIC ::   rn_astar         !: equivalent of G* for an exponential participation function 
     208   REAL(wp), PUBLIC ::   rn_hstar         !: thickness that determines the maximal thickness of ridged ice 
     209   REAL(wp), PUBLIC ::   rn_hraft         !: threshold thickness (m) for rafting / ridging  
     210   REAL(wp), PUBLIC ::   rn_craft         !: coefficient for smoothness of the hyperbolic tangent in rafting 
     211   REAL(wp), PUBLIC ::   rn_por_rdg       !: initial porosity of ridges (0.3 regular value) 
     212   REAL(wp), PUBLIC ::   rn_betas         !: coef. for partitioning of snowfall between leads and sea ice 
     213   REAL(wp), PUBLIC ::   rn_kappa_i       !: coef. for the extinction of radiation Grenfell et al. (2006) [1/m] 
     214   REAL(wp), PUBLIC ::   nn_conv_dif      !: maximal number of iterations for heat diffusion 
     215   REAL(wp), PUBLIC ::   rn_terr_dif      !: maximal tolerated error (C) for heat diffusion 
    215216 
    216217   !                                     !!** ice-mechanical redistribution namelist (namiceitdme) 
    217    INTEGER , PUBLIC ::   ridge_scheme_swi !: scheme used for ice ridging 
    218    INTEGER , PUBLIC ::   raft_swi         !: rafting of ice or not                         
    219    INTEGER , PUBLIC ::   partfun_swi      !: participation function: =0 Thorndike et al. (1975), =1 Lipscomb et al. (2007) 
    220    INTEGER , PUBLIC ::   brinstren_swi    !: use brine volume to diminish ice strength 
    221  
    222    REAL(wp), PUBLIC ::   usecc2           !:  = 1.0 / ( ecc * ecc ) 
    223    REAL(wp), PUBLIC ::   rhoco            !: = rau0 * cw 
    224  
     218   LOGICAL , PUBLIC ::   ln_rafting      !: rafting of ice or not                         
     219   INTEGER , PUBLIC ::   nn_partfun      !: participation function: =0 Thorndike et al. (1975), =1 Lipscomb et al. (2007) 
     220 
     221   REAL(wp), PUBLIC ::   usecc2           !:  = 1.0 / ( rn_ecc * rn_ecc ) 
     222   REAL(wp), PUBLIC ::   rhoco            !: = rau0 * cio 
     223   REAL(wp), PUBLIC ::   r1_nlay_i        !: 1 / nlay_i 
     224   REAL(wp), PUBLIC ::   r1_nlay_s        !: 1 / nlay_s  
     225   ! 
    225226   !                                     !!** switch for presence of ice or not  
    226227   REAL(wp), PUBLIC ::   rswitch 
    227  
     228   ! 
    228229   !                                     !!** define some parameters  
    229    REAL(wp), PUBLIC, PARAMETER ::   unit_fac = 1.e+09_wp  !: conversion factor for ice / snow enthalpy 
    230230   REAL(wp), PUBLIC, PARAMETER ::   epsi06   = 1.e-06_wp  !: small number  
    231231   REAL(wp), PUBLIC, PARAMETER ::   epsi10   = 1.e-10_wp  !: small number  
    … …  
    266266   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_res    !: residual component of wfx_ice [kg/m2] 
    267267 
     268   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   afx_tot     !: ice concentration tendency (total) [s-1] 
     269   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   afx_thd     !: ice concentration tendency (thermodynamics) [s-1] 
     270   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   afx_dyn     !: ice concentration tendency (dynamics) [s-1] 
     271 
    268272   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   sfx_bog     !: salt flux due to ice growth/melt                      [PSU/m2/s] 
    269273   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   sfx_bom     !: salt flux due to ice growth/melt                      [PSU/m2/s] 
    … …  
    282286   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_snw     !: heat flux for snow melt  
    283287   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_err     !: heat flux error after heat diffusion  
     288   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_err_dif !: heat flux remaining due to change in non-solar flux 
    284289   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_err_rem !: heat flux error after heat remapping  
    285290   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_in      !: heat flux available for thermo transformations  
    … …  
    296301 
    297302   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   ftr_ice   !: transmitted solar radiation under ice 
    298  
    299    ! temporary arrays for dummy version of the code 
    300    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   dh_i_surf2D, dh_i_bott2D, q_s 
    301303 
    302304   !!-------------------------------------------------------------------------- 
    … …  
    333335       
    334336   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) ::   t_i        !: ice temperatures          [K] 
    335    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) ::   e_i        !: ice thermal contents [Giga J] 
     337   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) ::   e_i        !: ice thermal contents    [J/m2] 
    336338   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) ::   s_i        !: ice salinities          [PSU] 
    337339 
    … …  
    356358   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) ::   e_i_b                      !: ice temperatures 
    357359   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)     ::   u_ice_b, v_ice_b           !: ice velocity 
    358        
    359  
    360    !!-------------------------------------------------------------------------- 
    361    !! * Increment of global variables 
    362    !!-------------------------------------------------------------------------- 
     360             
     361   !!-------------------------------------------------------------------------- 
     362   !! * Ice thickness distribution variables 
     363   !!-------------------------------------------------------------------------- 
     364   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:)   ::   hi_max         !: Boundary of ice thickness categories in thickness space 
     365   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:)   ::   hi_mean        !: Mean ice thickness in catgories  
     366 
     367   !!-------------------------------------------------------------------------- 
     368   !! * Ice Run 
     369   !!-------------------------------------------------------------------------- 
     370   !                                                  !!: ** Namelist namicerun read in sbc_lim_init ** 
     371   INTEGER          , PUBLIC ::   jpl             !: number of ice  categories  
     372   INTEGER          , PUBLIC ::   nlay_i          !: number of ice  layers  
     373   INTEGER          , PUBLIC ::   nlay_s          !: number of snow layers  
     374   CHARACTER(len=32), PUBLIC ::   cn_icerst_in    !: suffix of ice restart name (input) 
     375   CHARACTER(len=200), PUBLIC ::   cn_icerst_indir !: ice restart input directory 
     376   CHARACTER(len=32), PUBLIC ::   cn_icerst_out   !: suffix of ice restart name (output) 
     377   CHARACTER(len=200), PUBLIC ::   cn_icerst_outdir!: ice restart output directory 
     378   LOGICAL          , PUBLIC ::   ln_limdyn       !: flag for ice dynamics (T) or not (F) 
     379   LOGICAL          , PUBLIC ::   ln_icectl       !: flag for sea-ice points output (T) or not (F) 
     380   REAL(wp)         , PUBLIC ::   rn_amax         !: maximum ice concentration 
     381   INTEGER          , PUBLIC ::   iiceprt         !: debug i-point 
     382   INTEGER          , PUBLIC ::   jiceprt         !: debug j-point 
     383   ! 
     384   !!-------------------------------------------------------------------------- 
     385   !! * Ice diagnostics 
     386   !!-------------------------------------------------------------------------- 
     387   ! Increment of global variables 
    363388   ! thd refers to changes induced by thermodynamics 
    364389   ! trp   ''         ''     ''       advection (transport of ice) 
    365    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   d_a_i_thd  , d_a_i_trp                 !: icefractions                   
    366    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   d_v_s_thd  , d_v_s_trp                 !: snow volume 
    367    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   d_v_i_thd  , d_v_i_trp                 !: ice  volume 
    368    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   d_smv_i_thd, d_smv_i_trp               !:      
    369    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   d_sm_i_fl  , d_sm_i_gd                 !: 
    370    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   d_sm_i_se  , d_sm_i_si  , d_sm_i_la    !: 
    371    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   d_oa_i_thd , d_oa_i_trp                !: 
    372  
    373    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) ::   d_e_s_thd  , d_e_s_trp     !: 
    374    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) ::   d_e_i_thd  , d_e_i_trp     !: 
    375    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)     ::   d_u_ice_dyn, d_v_ice_dyn   !: ice velocity  
    376        
    377    !!-------------------------------------------------------------------------- 
    378    !! * Ice thickness distribution variables 
    379    !!-------------------------------------------------------------------------- 
    380    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:)   ::   hi_max         !: Boundary of ice thickness categories in thickness space 
    381    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:)   ::   hi_mean        !: Mean ice thickness in catgories  
    382  
    383    !!-------------------------------------------------------------------------- 
    384    !! * Ice Run 
    385    !!-------------------------------------------------------------------------- 
    386    !                                                  !!: ** Namelist namicerun read in iceini ** 
    387    CHARACTER(len=32)     , PUBLIC ::   cn_icerst_in    !: suffix of ice restart name (input) 
    388    CHARACTER(len=200)    , PUBLIC ::   cn_icerst_indir !: ice restart input directory  
    389    CHARACTER(len=32)     , PUBLIC ::   cn_icerst_out   !: suffix of ice restart name (output) 
    390    CHARACTER(len=200)    , PUBLIC ::   cn_icerst_outdir!: ice restart output directory  
    391    LOGICAL               , PUBLIC ::   ln_limdyn       !: flag for ice dynamics (T) or not (F) 
    392    LOGICAL               , PUBLIC ::   ln_nicep        !: flag for sea-ice points output (T) or not (F) 
    393    REAL(wp)              , PUBLIC ::   cai             !: atmospheric drag over sea ice 
    394    REAL(wp)              , PUBLIC ::   cao             !: atmospheric drag over ocean 
    395    REAL(wp)              , PUBLIC ::   amax            !: maximum ice concentration 
     390   LOGICAL , PUBLIC                                        ::   ln_limdiahsb  !: flag for ice diag (T) or not (F) 
     391   LOGICAL , PUBLIC                                        ::   ln_limdiaout  !: flag for ice diag (T) or not (F) 
     392   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)     ::   diag_trp_vi   !: transport of ice volume 
     393   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)     ::   diag_trp_vs   !: transport of snw volume 
     394   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)     ::   diag_trp_ei   !: transport of ice enthalpy (W/m2) 
     395   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)     ::   diag_trp_es   !: transport of snw enthalpy (W/m2) 
     396   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)     ::   diag_trp_smv  !: transport of salt content 
    396397   ! 
    397    !!-------------------------------------------------------------------------- 
    398    !! * Ice diagnostics 
    399    !!-------------------------------------------------------------------------- 
    400    !! Check if everything down here is necessary 
    401    LOGICAL , PUBLIC                                      ::   ln_limdiahsb  !: flag for ice diag (T) or not (F) 
    402    LOGICAL , PUBLIC                                      ::   ln_limdiaout  !: flag for ice diag (T) or not (F) 
    403    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   dv_dt_thd     !: thermodynamic growth rates  
    404    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   diag_trp_vi   !: transport of ice volume 
    405    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   diag_trp_vs   !: transport of snw volume 
    406    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   diag_trp_ei   !: transport of ice enthalpy (W/m2) 
    407    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   diag_trp_es   !: transport of snw enthalpy (W/m2) 
     398   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)     ::   diag_heat     !: snw/ice heat content variation   [W/m2]  
     399   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)     ::   diag_smvi     !: ice salt content variation   []  
     400   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)     ::   diag_vice     !: ice volume variation   [m/s]  
     401   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)     ::   diag_vsnw     !: snw volume variation   [m/s]  
    408402   ! 
    409    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   diag_heat_dhc !: snw/ice heat content variation   [W/m2]  
    410    ! 
    411    INTEGER , PUBLIC ::   jiindx, jjindx        !: indexes of the debugging point 
    412  
    413403   !!---------------------------------------------------------------------- 
    414404   !! NEMO/LIM3 4.0 , UCL - NEMO Consortium (2010) 
    … …  
    424414      INTEGER :: ice_alloc 
    425415      ! 
    426       INTEGER :: ierr(19), ii 
     416      INTEGER :: ierr(17), ii 
    427417      !!----------------------------------------------------------------- 
    428418 
    … …  
    441431 
    442432      ii = ii + 1 
    443       ALLOCATE( sist   (jpi,jpj) , icethi (jpi,jpj) , t_bo   (jpi,jpj) ,      & 
    444          &      frld   (jpi,jpj) , pfrld  (jpi,jpj) , phicif (jpi,jpj) ,      & 
    445          &      wfx_snw(jpi,jpj) , wfx_ice(jpi,jpj) , wfx_sub(jpi,jpj) ,    & 
     433      ALLOCATE( sist   (jpi,jpj) , icethi (jpi,jpj) , t_bo   (jpi,jpj) ,                        & 
     434         &      frld   (jpi,jpj) , pfrld  (jpi,jpj) , phicif (jpi,jpj) ,                        & 
     435         &      wfx_snw(jpi,jpj) , wfx_ice(jpi,jpj) , wfx_sub(jpi,jpj) ,                        & 
    446436         &      wfx_bog(jpi,jpj) , wfx_dyn(jpi,jpj) , wfx_bom(jpi,jpj) , wfx_sum(jpi,jpj) ,     & 
    447          &      wfx_res(jpi,jpj) , wfx_sni(jpi,jpj) , wfx_opw(jpi,jpj) , wfx_spr(jpi,jpj) ,  qlead  (jpi,jpj) ,     & 
    448          &      fhtur  (jpi,jpj) , ftr_ice(jpi,jpj,jpl) ,      & 
    449          &      sfx_res(jpi,jpj) , sfx_bri(jpi,jpj) , sfx_dyn(jpi,jpj) ,      & 
    450          &      sfx_bog(jpi,jpj) , sfx_bom(jpi,jpj) , sfx_sum(jpi,jpj) , sfx_sni(jpi,jpj) , sfx_opw(jpi,jpj) ,   & 
    451          &      hfx_res(jpi,jpj) , hfx_snw(jpi,jpj) , hfx_sub(jpi,jpj) , hfx_err(jpi,jpj) , hfx_err_rem(jpi,jpj), & 
    452          &      hfx_in (jpi,jpj) , hfx_out(jpi,jpj) , fhld(jpi,jpj) ,  & 
    453          &      hfx_sum(jpi,jpj) , hfx_bom(jpi,jpj) , hfx_bog(jpi,jpj) , hfx_dif(jpi,jpj) , hfx_opw(jpi,jpj) , & 
     437         &      wfx_res(jpi,jpj) , wfx_sni(jpi,jpj) , wfx_opw(jpi,jpj) , wfx_spr(jpi,jpj) ,     & 
     438         &      afx_tot(jpi,jpj) , afx_thd(jpi,jpj),  afx_dyn(jpi,jpj) ,                        & 
     439         &      fhtur  (jpi,jpj) , ftr_ice(jpi,jpj,jpl), qlead  (jpi,jpj) ,                     & 
     440         &      sfx_res(jpi,jpj) , sfx_bri(jpi,jpj) , sfx_dyn(jpi,jpj) ,                        & 
     441         &      sfx_bog(jpi,jpj) , sfx_bom(jpi,jpj) , sfx_sum(jpi,jpj) , sfx_sni(jpi,jpj) , sfx_opw(jpi,jpj) ,    & 
     442         &      hfx_res(jpi,jpj) , hfx_snw(jpi,jpj) , hfx_sub(jpi,jpj) , hfx_err(jpi,jpj) ,     &  
     443         &      hfx_err_dif(jpi,jpj) , hfx_err_rem(jpi,jpj) ,                                   & 
     444         &      hfx_in (jpi,jpj) , hfx_out(jpi,jpj) , fhld(jpi,jpj) ,                           & 
     445         &      hfx_sum(jpi,jpj) , hfx_bom(jpi,jpj) , hfx_bog(jpi,jpj) , hfx_dif(jpi,jpj) , hfx_opw(jpi,jpj) ,    & 
    454446         &      hfx_thd(jpi,jpj) , hfx_dyn(jpi,jpj) , hfx_spr(jpi,jpj) ,  STAT=ierr(ii) ) 
    455447 
    … …  
    466458         &      bv_i (jpi,jpj) , smt_i(jpi,jpj)                                   , STAT=ierr(ii) ) 
    467459      ii = ii + 1 
    468       ALLOCATE( t_s(jpi,jpj,nlay_s,jpl) ,                            & 
    469          &      e_s(jpi,jpj,nlay_s,jpl) , STAT=ierr(ii) ) 
    470       ii = ii + 1 
    471       ALLOCATE( t_i(jpi,jpj,nlay_i+1,jpl) , e_i(jpi,jpj,nlay_i+1,jpl) , s_i(jpi,jpj,nlay_i+1,jpl) , STAT=ierr(ii) ) 
     460      ALLOCATE( t_s(jpi,jpj,nlay_s,jpl) , e_s(jpi,jpj,nlay_s,jpl) , STAT=ierr(ii) ) 
     461      ii = ii + 1 
     462      ALLOCATE( t_i(jpi,jpj,nlay_i,jpl) , e_i(jpi,jpj,nlay_i,jpl) , s_i(jpi,jpj,nlay_i,jpl) , STAT=ierr(ii) ) 
    472463 
    473464      ! * Moments for advection 
    … …  
    485476         &      STAT=ierr(ii) ) 
    486477      ii = ii + 1 
    487       ALLOCATE( sxe (jpi,jpj,nlay_i+1,jpl) , sye (jpi,jpj,nlay_i+1,jpl) , sxxe(jpi,jpj,nlay_i+1,jpl) ,     & 
    488          &      syye(jpi,jpj,nlay_i+1,jpl) , sxye(jpi,jpj,nlay_i+1,jpl)                           , STAT=ierr(ii) ) 
     478      ALLOCATE( sxe (jpi,jpj,nlay_i,jpl) , sye (jpi,jpj,nlay_i,jpl) , sxxe(jpi,jpj,nlay_i,jpl) ,     & 
     479         &      syye(jpi,jpj,nlay_i,jpl) , sxye(jpi,jpj,nlay_i,jpl)                            , STAT=ierr(ii) ) 
    489480 
    490481      ! * Old values of global variables 
    491482      ii = ii + 1 
    492483      ALLOCATE( v_s_b  (jpi,jpj,jpl) , v_i_b  (jpi,jpj,jpl) , e_s_b(jpi,jpj,nlay_s,jpl) ,     & 
    493          &      a_i_b  (jpi,jpj,jpl) , smv_i_b(jpi,jpj,jpl) , e_i_b(jpi,jpj,nlay_i+1 ,jpl) ,     & 
    494          &      oa_i_b (jpi,jpj,jpl)                                                        ,     & 
    495          &      u_ice_b(jpi,jpj)     , v_ice_b(jpi,jpj)                                   , STAT=ierr(ii) ) 
    496  
    497       ! * Increment of global variables 
    498       ii = ii + 1 
    499       ALLOCATE( d_a_i_thd(jpi,jpj,jpl) , d_a_i_trp (jpi,jpj,jpl) , d_v_s_thd  (jpi,jpj,jpl) , d_v_s_trp  (jpi,jpj,jpl) ,   & 
    500          &      d_v_i_thd(jpi,jpj,jpl) , d_v_i_trp (jpi,jpj,jpl) , d_smv_i_thd(jpi,jpj,jpl) , d_smv_i_trp(jpi,jpj,jpl) ,   &      
    501          &      d_sm_i_fl(jpi,jpj,jpl) , d_sm_i_gd (jpi,jpj,jpl) , d_sm_i_se  (jpi,jpj,jpl) , d_sm_i_si  (jpi,jpj,jpl) ,   & 
    502          &      d_sm_i_la(jpi,jpj,jpl) , d_oa_i_thd(jpi,jpj,jpl) , d_oa_i_trp (jpi,jpj,jpl) ,   & 
    503          &     STAT=ierr(ii) ) 
    504       ii = ii + 1 
    505       ALLOCATE( d_e_s_thd(jpi,jpj,nlay_s,jpl) , d_e_i_thd(jpi,jpj,nlay_i,jpl) , d_u_ice_dyn(jpi,jpj) ,     & 
    506          &      d_e_s_trp(jpi,jpj,nlay_s,jpl) , d_e_i_trp(jpi,jpj,nlay_i,jpl) , d_v_ice_dyn(jpi,jpj) , STAT=ierr(ii) ) 
     484         &      a_i_b  (jpi,jpj,jpl) , smv_i_b(jpi,jpj,jpl) , e_i_b(jpi,jpj,nlay_i,jpl) ,     & 
     485         &      oa_i_b (jpi,jpj,jpl) , u_ice_b(jpi,jpj)     , v_ice_b(jpi,jpj)          , STAT=ierr(ii) ) 
    507486       
    508487      ! * Ice thickness distribution variables 
    … …  
    512491      ! * Ice diagnostics 
    513492      ii = ii + 1 
    514       ALLOCATE( dv_dt_thd(jpi,jpj,jpl),    & 
    515          &      diag_trp_vi(jpi,jpj), diag_trp_vs  (jpi,jpj), diag_trp_ei(jpi,jpj),   &  
    516          &      diag_trp_es(jpi,jpj), diag_heat_dhc(jpi,jpj), STAT=ierr(ii) ) 
     493      ALLOCATE( diag_trp_vi(jpi,jpj), diag_trp_vs (jpi,jpj), diag_trp_ei(jpi,jpj),   &  
     494         &      diag_trp_es(jpi,jpj), diag_trp_smv(jpi,jpj), diag_heat  (jpi,jpj),   & 
     495         &      diag_smvi  (jpi,jpj), diag_vice   (jpi,jpj), diag_vsnw  (jpi,jpj), STAT=ierr(ii) ) 
    517496 
    518497      ice_alloc = MAXVAL( ierr(:) ) 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/LIM_SRC_3/limadv.F90

    r5312 r5313  
    6363      !!  
    6464      INTEGER  ::   ji, jj                               ! dummy loop indices 
    65       REAL(wp) ::   zs1max, zrdt, zslpmax, ztemp, zin0   ! local scalars 
     65      REAL(wp) ::   zs1max, zrdt, zslpmax, ztemp         ! local scalars 
    6666      REAL(wp) ::   zs1new, zalf , zalfq , zbt           !   -      - 
    6767      REAL(wp) ::   zs2new, zalf1, zalf1q, zbt1          !   -      - 
    … …  
    8585            zs2new  = MIN(  2.0 * zslpmax - 0.3334 * ABS( zs1new ),      & 
    8686               &            MAX( ABS( zs1new ) - zslpmax, psxx(ji,jj) )  ) 
    87             zin0    = ( 1.0 - MAX( 0._wp, SIGN( 1._wp, -zslpmax) ) ) * tms(ji,jj)   ! Case of empty boxes & Apply mask 
     87            rswitch = ( 1.0 - MAX( 0._wp, SIGN( 1._wp, -zslpmax) ) ) * tmask(ji,jj,1)   ! Case of empty boxes & Apply mask 
    8888 
    8989            ps0 (ji,jj) = zslpmax   
    90             psx (ji,jj) = zs1new      * zin0 
    91             psxx(ji,jj) = zs2new      * zin0 
    92             psy (ji,jj) = psy (ji,jj) * zin0 
    93             psyy(ji,jj) = psyy(ji,jj) * zin0 
    94             psxy(ji,jj) = MIN( zslpmax, MAX( -zslpmax, psxy(ji,jj) ) ) * zin0 
     90            psx (ji,jj) = zs1new      * rswitch 
     91            psxx(ji,jj) = zs2new      * rswitch 
     92            psy (ji,jj) = psy (ji,jj) * rswitch 
     93            psyy(ji,jj) = psyy(ji,jj) * rswitch 
     94            psxy(ji,jj) = MIN( zslpmax, MAX( -zslpmax, psxy(ji,jj) ) ) * rswitch 
    9595         END DO 
    9696      END DO 
    9797 
    9898      !  Initialize volumes of boxes  (=area if adv_x first called, =psm otherwise)                                      
    99       psm (:,:)  = MAX( pcrh * area(:,:) + ( 1.0 - pcrh ) * psm(:,:) , epsi20 ) 
     99      psm (:,:)  = MAX( pcrh * e12t(:,:) + ( 1.0 - pcrh ) * psm(:,:) , epsi20 ) 
    100100 
    101101      !  Calculate fluxes and moments between boxes i<-->i+1               
    … …  
    248248      !! 
    249249      INTEGER  ::   ji, jj                               ! dummy loop indices 
    250       REAL(wp) ::   zs1max, zrdt, zslpmax, ztemp, zin0   ! temporary scalars 
     250      REAL(wp) ::   zs1max, zrdt, zslpmax, ztemp         ! temporary scalars 
    251251      REAL(wp) ::   zs1new, zalf , zalfq , zbt           !    -         - 
    252252      REAL(wp) ::   zs2new, zalf1, zalf1q, zbt1          !    -         - 
    … …  
    270270            zs2new  = MIN(  ( 2.0 * zslpmax - 0.3334 * ABS( zs1new ) ),   & 
    271271               &             MAX( ABS( zs1new )-zslpmax, psyy(ji,jj) )  ) 
    272             zin0    = ( 1.0 - MAX( 0._wp, SIGN( 1._wp, -zslpmax) ) ) * tms(ji,jj)   ! Case of empty boxes & Apply mask 
     272            rswitch = ( 1.0 - MAX( 0._wp, SIGN( 1._wp, -zslpmax) ) ) * tmask(ji,jj,1)   ! Case of empty boxes & Apply mask 
    273273            ! 
    274274            ps0 (ji,jj) = zslpmax   
    275             psx (ji,jj) = psx (ji,jj) * zin0 
    276             psxx(ji,jj) = psxx(ji,jj) * zin0 
    277             psy (ji,jj) = zs1new * zin0 
    278             psyy(ji,jj) = zs2new * zin0 
    279             psxy(ji,jj) = MIN( zslpmax, MAX( -zslpmax, psxy(ji,jj) ) ) * zin0 
     275            psx (ji,jj) = psx (ji,jj) * rswitch 
     276            psxx(ji,jj) = psxx(ji,jj) * rswitch 
     277            psy (ji,jj) = zs1new * rswitch 
     278            psyy(ji,jj) = zs2new * rswitch 
     279            psxy(ji,jj) = MIN( zslpmax, MAX( -zslpmax, psxy(ji,jj) ) ) * rswitch 
    280280         END DO 
    281281      END DO 
    282282 
    283283      !  Initialize volumes of boxes (=area if adv_x first called, =psm otherwise) 
    284       psm(:,:)  = MAX(  pcrh * area(:,:) + ( 1.0 - pcrh ) * psm(:,:) , epsi20  ) 
     284      psm(:,:)  = MAX(  pcrh * e12t(:,:) + ( 1.0 - pcrh ) * psm(:,:) , epsi20  ) 
    285285 
    286286      !  Calculate fluxes and moments between boxes j<-->j+1               

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/LIM_SRC_3/limcons.F90

    r5312 r5313  
    66   !! History :   -   ! Original code from William H. Lipscomb, LANL 
    77   !!            3.0  ! 2004-06  (M. Vancoppenolle)   Energy Conservation  
    8    !!            4.0  ! 2011-02  (G. Madec)  add mpp considerations 
     8   !!            3.5  ! 2011-02  (G. Madec)  add mpp considerations 
    99   !!             -   ! 2014-05  (C. Rousset) add lim_cons_hsm 
     10   !!             -   ! 2015-03  (C. Rousset) add lim_cons_final 
    1011   !!---------------------------------------------------------------------- 
    1112#if defined key_lim3 
    … …  
    1617   !!---------------------------------------------------------------------- 
    1718   USE phycst         ! physical constants 
    18    USE par_ice        ! LIM-3 parameter 
    1919   USE ice            ! LIM-3 variables 
    2020   USE dom_ice        ! LIM-3 domain 
    … …  
    2323   USE lib_mpp        ! MPP library 
    2424   USE lib_fortran    ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined)   
     25   USE sbc_oce , ONLY : sfx  ! Surface boundary condition: ocean fields 
    2526 
    2627   IMPLICIT NONE 
    … …  
    3132   PUBLIC   lim_cons_check 
    3233   PUBLIC   lim_cons_hsm 
     34   PUBLIC   lim_cons_final 
    3335 
    3436   !!---------------------------------------------------------------------- 
    … …  
    7375      !! ** Method  : Arithmetics 
    7476      !!--------------------------------------------------------------------- 
    75       INTEGER                                  , INTENT(in   ) ::   ksum   !: number of categories 
    76       INTEGER                                  , INTENT(in   ) ::   klay   !: number of vertical layers 
    77       REAL(wp), DIMENSION(jpi,jpj,nlay_i+1,jpl), INTENT(in   ) ::   pin   !: input field 
    78       REAL(wp), DIMENSION(jpi,jpj)             , INTENT(  out) ::   pout   !: output field 
     77      INTEGER                                , INTENT(in   ) ::   ksum   !: number of categories 
     78      INTEGER                                , INTENT(in   ) ::   klay   !: number of vertical layers 
     79      REAL(wp), DIMENSION(jpi,jpj,nlay_i,jpl), INTENT(in   ) ::   pin    !: input field 
     80      REAL(wp), DIMENSION(jpi,jpj)           , INTENT(  out) ::   pout   !: output field 
    7981      ! 
    8082      INTEGER ::   jk, jl   ! dummy loop indices 
    … …  
    156158 
    157159   SUBROUTINE lim_cons_hsm( icount, cd_routine, zvi_b, zsmv_b, zei_b, zfw_b, zfs_b, zft_b ) 
    158       !!------------------------------------------------------------------- 
    159       !!               ***  ROUTINE lim_cons_hsm *** 
    160       !! 
    161       !! ** Purpose : Test the conservation of heat, salt and mass for each routine 
    162       !! 
    163       !! ** Method  : 
    164       !!--------------------------------------------------------------------- 
    165       INTEGER         , INTENT(in)    :: icount      ! determine wether this is the beggining of the routine (0) or the end (1) 
    166       CHARACTER(len=*), INTENT(in)    :: cd_routine  ! name of the routine 
     160      !!-------------------------------------------------------------------------------------------------------- 
     161      !!                                        ***  ROUTINE lim_cons_hsm *** 
     162      !! 
     163      !! ** Purpose : Test the conservation of heat, salt and mass for each ice routine 
     164      !!                     + test if ice concentration and volume are > 0 
     165      !! 
     166      !! ** Method  : This is an online diagnostics which can be activated with ln_limdiahsb=true 
     167      !!              It prints in ocean.output if there is a violation of conservation at each time-step 
     168      !!              The thresholds (zv_sill, zs_sill, zh_sill) which determine violations are set to 
     169      !!              a minimum of 1 mm of ice (over the ice area) that is lost/gained spuriously during 100 years. 
     170      !!              For salt and heat thresholds, ice is considered to have a salinity of 10  
     171      !!              and a heat content of 3e5 J/kg (=latent heat of fusion)  
     172      !!-------------------------------------------------------------------------------------------------------- 
     173      INTEGER         , INTENT(in)    :: icount        ! determine wether this is the beggining of the routine (0) or the end (1) 
     174      CHARACTER(len=*), INTENT(in)    :: cd_routine    ! name of the routine 
    167175      REAL(wp)        , INTENT(inout) :: zvi_b, zsmv_b, zei_b, zfs_b, zfw_b, zft_b  
    168176      REAL(wp)                        :: zvi,   zsmv,   zei,   zfs,   zfw,   zft 
    169177      REAL(wp)                        :: zvmin, zamin, zamax  
     178      REAL(wp)                        :: zvtrp, zetrp 
     179      REAL(wp)                        :: zarea, zv_sill, zs_sill, zh_sill 
     180      REAL(wp), PARAMETER             :: zconv = 1.e-9 ! convert W to GW and kg to Mt 
    170181 
    171182      IF( icount == 0 ) THEN 
    172183 
    173          zvi_b  = glob_sum( SUM(   v_i(:,:,:)*rhoic + v_s(:,:,:)*rhosn, dim=3 ) * area(:,:) * tms(:,:) ) 
    174          zsmv_b = glob_sum( SUM( smv_i(:,:,:), dim=3 ) * area(:,:) * tms(:,:) ) 
    175          zei_b  = glob_sum( SUM(   e_i(:,:,1:nlay_i,:), dim=3 ) + SUM( e_s(:,:,1:nlay_s,:), dim=3 ) ) 
    176          zfw_b  = glob_sum( - ( wfx_bog(:,:) + wfx_bom(:,:) + wfx_sum(:,:) + wfx_sni(:,:) + wfx_opw(:,:) +  & 
    177             &                   wfx_res(:,:) + wfx_dyn(:,:) + wfx_snw(:,:) + wfx_sub(:,:) + wfx_spr(:,:)    & 
    178             &             ) * area(:,:) * tms(:,:) ) 
    179          zfs_b  = glob_sum(   ( sfx_bri(:,:) + sfx_bog(:,:) + sfx_bom(:,:) + sfx_sum(:,:) + sfx_sni(:,:) +  & 
    180             &                   sfx_opw(:,:) + sfx_res(:,:) + sfx_dyn(:,:)                                  & 
    181             &                 ) * area(:,:) * tms(:,:) ) 
    182          zft_b  = glob_sum(   ( hfx_sum(:,:) + hfx_bom(:,:) + hfx_bog(:,:) + hfx_dif(:,:) + hfx_opw(:,:) + hfx_snw(:,:)  &  
    183             &                 - hfx_thd(:,:) - hfx_dyn(:,:) - hfx_res(:,:) - hfx_sub(:,:) - hfx_spr(:,:)   & 
    184             &                  ) * area(:,:) / unit_fac * tms(:,:) ) 
     184         ! salt flux 
     185         zfs_b  = glob_sum(  ( sfx_bri(:,:) + sfx_bog(:,:) + sfx_bom(:,:) + sfx_sum(:,:) + sfx_sni(:,:) +  & 
     186            &                  sfx_opw(:,:) + sfx_res(:,:) + sfx_dyn(:,:)                                  & 
     187            &                ) *  e12t(:,:) * tmask(:,:,1) * zconv ) 
     188 
     189         ! water flux 
     190         zfw_b  = glob_sum( -( wfx_bog(:,:) + wfx_bom(:,:) + wfx_sum(:,:) + wfx_sni(:,:) + wfx_opw(:,:) +  & 
     191            &                  wfx_res(:,:) + wfx_dyn(:,:) + wfx_snw(:,:) + wfx_sub(:,:) + wfx_spr(:,:)    & 
     192            &                ) *  e12t(:,:) * tmask(:,:,1) * zconv ) 
     193 
     194         ! heat flux 
     195         zft_b  = glob_sum(  ( hfx_sum(:,:) + hfx_bom(:,:) + hfx_bog(:,:) + hfx_dif(:,:) + hfx_opw(:,:) + hfx_snw(:,:)  &  
     196            &                - hfx_thd(:,:) - hfx_dyn(:,:) - hfx_res(:,:) - hfx_sub(:,:) - hfx_spr(:,:)   & 
     197            &                ) *  e12t(:,:) * tmask(:,:,1) * zconv ) 
     198 
     199         zvi_b  = glob_sum( SUM( v_i * rhoic + v_s * rhosn, dim=3 ) * e12t * tmask(:,:,1) * zconv ) 
     200 
     201         zsmv_b = glob_sum( SUM( smv_i * rhoic            , dim=3 ) * e12t * tmask(:,:,1) * zconv ) 
     202 
     203         zei_b  = glob_sum( ( SUM( SUM( e_i(:,:,1:nlay_i,:), dim=4 ), dim=3 ) +  & 
     204            &                 SUM( SUM( e_s(:,:,1:nlay_s,:), dim=4 ), dim=3 )    & 
     205                            ) * e12t * tmask(:,:,1) * zconv ) 
    185206 
    186207      ELSEIF( icount == 1 ) THEN 
    187208 
    188          zfs  = glob_sum(   ( sfx_bri(:,:) + sfx_bog(:,:) + sfx_bom(:,:) + sfx_sum(:,:) + sfx_sni(:,:) +  & 
    189             &                 sfx_opw(:,:) + sfx_res(:,:) + sfx_dyn(:,:)                                  &  
    190             &                ) * area(:,:) * tms(:,:) ) - zfs_b 
    191          zfw  = glob_sum( - ( wfx_bog(:,:) + wfx_bom(:,:) + wfx_sum(:,:) + wfx_sni(:,:) + wfx_opw(:,:) +  & 
    192             &                 wfx_res(:,:) + wfx_dyn(:,:) + wfx_snw(:,:) + wfx_sub(:,:) + wfx_spr(:,:)    & 
    193             &                ) * area(:,:) * tms(:,:) ) - zfw_b 
    194          zft  = glob_sum(   ( hfx_sum(:,:) + hfx_bom(:,:) + hfx_bog(:,:) + hfx_dif(:,:) + hfx_opw(:,:) + hfx_snw(:,:)  &  
    195             &               - hfx_thd(:,:) - hfx_dyn(:,:) - hfx_res(:,:) - hfx_sub(:,:) - hfx_spr(:,:)   & 
    196             &                ) * area(:,:) / unit_fac * tms(:,:) ) - zft_b 
     209         ! salt flux 
     210         zfs  = glob_sum(  ( sfx_bri(:,:) + sfx_bog(:,:) + sfx_bom(:,:) + sfx_sum(:,:) + sfx_sni(:,:) +  & 
     211            &                sfx_opw(:,:) + sfx_res(:,:) + sfx_dyn(:,:)                                  &  
     212            &              ) * e12t(:,:) * tmask(:,:,1) * zconv ) - zfs_b 
     213 
     214         ! water flux 
     215         zfw  = glob_sum( -( wfx_bog(:,:) + wfx_bom(:,:) + wfx_sum(:,:) + wfx_sni(:,:) + wfx_opw(:,:) +  & 
     216            &                wfx_res(:,:) + wfx_dyn(:,:) + wfx_snw(:,:) + wfx_sub(:,:) + wfx_spr(:,:)    & 
     217            &              ) * e12t(:,:) * tmask(:,:,1) * zconv ) - zfw_b 
     218 
     219         ! heat flux 
     220         zft  = glob_sum(  ( hfx_sum(:,:) + hfx_bom(:,:) + hfx_bog(:,:) + hfx_dif(:,:) + hfx_opw(:,:) + hfx_snw(:,:)  &  
     221            &              - hfx_thd(:,:) - hfx_dyn(:,:) - hfx_res(:,:) - hfx_sub(:,:) - hfx_spr(:,:)   & 
     222            &              ) * e12t(:,:) * tmask(:,:,1) * zconv ) - zft_b 
    197223  
    198          zvi  = ( glob_sum( SUM(   v_i(:,:,:)*rhoic + v_s(:,:,:)*rhosn, dim=3 ) * area(:,:) * tms(:,:) ) - zvi_b ) * r1_rdtice - zfw  
    199          zsmv = ( glob_sum( SUM( smv_i(:,:,:), dim=3 ) * area(:,:) * tms(:,:) ) - zsmv_b ) * r1_rdtice + ( zfs / rhoic ) 
    200          zei  =   glob_sum( SUM( e_i(:,:,1:nlay_i,:), dim=3 ) + SUM( e_s(:,:,1:nlay_s,:), dim=3 ) ) * r1_rdtice - zei_b * r1_rdtice + zft 
    201  
    202          zvmin = glob_min(v_i) 
    203          zamax = glob_max(SUM(a_i,dim=3)) 
    204          zamin = glob_min(a_i) 
    205         
     224         ! outputs 
     225         zvi  = ( ( glob_sum( SUM( v_i * rhoic + v_s * rhosn, dim=3 )  & 
     226            &                    * e12t * tmask(:,:,1) * zconv ) - zvi_b ) * r1_rdtice - zfw ) * rday 
     227 
     228         zsmv = ( ( glob_sum( SUM( smv_i * rhoic            , dim=3 )  & 
     229            &                    * e12t * tmask(:,:,1) * zconv ) - zsmv_b ) * r1_rdtice + zfs ) * rday 
     230 
     231         zei  =   glob_sum( ( SUM( SUM( e_i(:,:,1:nlay_i,:), dim=4 ), dim=3 ) +  & 
     232            &                 SUM( SUM( e_s(:,:,1:nlay_s,:), dim=4 ), dim=3 )    & 
     233            &                ) * e12t * tmask(:,:,1) * zconv ) * r1_rdtice - zei_b * r1_rdtice + zft 
     234 
     235         ! zvtrp and zetrp must be close to 0 if the advection scheme is conservative 
     236         zvtrp = glob_sum( ( diag_trp_vi * rhoic + diag_trp_vs * rhosn ) * e12t * tmask(:,:,1) * zconv ) * rday  
     237         zetrp = glob_sum( ( diag_trp_ei         + diag_trp_es         ) * e12t * tmask(:,:,1) * zconv ) 
     238 
     239         zvmin = glob_min( v_i ) 
     240         zamax = glob_max( SUM( a_i, dim=3 ) ) 
     241         zamin = glob_min( a_i ) 
     242 
     243         ! set threshold values and calculate the ice area (+epsi10 to set a threshold > 0 when there is no ice)  
     244         zarea   = glob_sum( SUM( a_i + epsi10, dim=3 ) * e12t * zconv ) ! in 1.e9 m2 
     245         zv_sill = zarea * 2.5e-5 
     246         zs_sill = zarea * 25.e-5 
     247         zh_sill = zarea * 10.e-5 
     248 
    206249         IF(lwp) THEN 
    207             IF ( ABS( zvi    ) >  1.e-4 ) WRITE(numout,*) 'violation volume [kg/day]     (',cd_routine,') = ',(zvi * rday) 
    208             IF ( ABS( zsmv   ) >  1.e-4 ) WRITE(numout,*) 'violation saline [psu*m3/day] (',cd_routine,') = ',(zsmv * rday) 
    209             IF ( ABS( zei    ) >  1.    ) WRITE(numout,*) 'violation enthalpy [1e9 J]    (',cd_routine,') = ',(zei) 
    210             IF ( zvmin <  0.            ) WRITE(numout,*) 'violation v_i<0  [m]          (',cd_routine,') = ',(zvmin) 
    211             IF( cd_routine /= 'limtrp' .AND. cd_routine /= 'limitd_me' .AND. zamax > amax+1.e-10 ) THEN 
    212                                           WRITE(numout,*) 'violation a_i>amax            (',cd_routine,') = ',zamax 
     250            IF ( ABS( zvi  ) > zv_sill ) WRITE(numout,*) 'violation volume [Mt/day]     (',cd_routine,') = ',zvi 
     251            IF ( ABS( zsmv ) > zs_sill ) WRITE(numout,*) 'violation saline [psu*Mt/day] (',cd_routine,') = ',zsmv 
     252            IF ( ABS( zei  ) > zh_sill ) WRITE(numout,*) 'violation enthalpy [GW]       (',cd_routine,') = ',zei 
     253            IF ( ABS(zvtrp ) > zv_sill .AND. cd_routine == 'limtrp' ) THEN 
     254                                         WRITE(numout,*) 'violation vtrp [Mt/day]       (',cd_routine,') = ',zvtrp 
     255                                         WRITE(numout,*) 'violation etrp [GW]           (',cd_routine,') = ',zetrp 
    213256            ENDIF 
    214             IF ( zamin <  0.            ) WRITE(numout,*) 'violation a_i<0               (',cd_routine,') = ',zamin 
     257            IF (     zvmin   < -epsi10 ) WRITE(numout,*) 'violation v_i<0  [m]          (',cd_routine,') = ',zvmin 
     258            IF (     zamax   > rn_amax+epsi10 .AND. cd_routine /= 'limtrp' .AND. cd_routine /= 'limitd_me' ) THEN 
     259                                         WRITE(numout,*) 'violation a_i>amax            (',cd_routine,') = ',zamax 
     260            ENDIF 
     261            IF (      zamin  < -epsi10 ) WRITE(numout,*) 'violation a_i<0               (',cd_routine,') = ',zamin 
    215262         ENDIF 
    216263 
    … …  
    218265 
    219266   END SUBROUTINE lim_cons_hsm 
     267 
     268   SUBROUTINE lim_cons_final( cd_routine ) 
     269      !!--------------------------------------------------------------------------------------------------------- 
     270      !!                                   ***  ROUTINE lim_cons_final *** 
     271      !! 
     272      !! ** Purpose : Test the conservation of heat, salt and mass at the end of each ice time-step 
     273      !! 
     274      !! ** Method  : This is an online diagnostics which can be activated with ln_limdiahsb=true 
     275      !!              It prints in ocean.output if there is a violation of conservation at each time-step 
     276      !!              The thresholds (zv_sill, zs_sill, zh_sill) which determine the violation are set to 
     277      !!              a minimum of 1 mm of ice (over the ice area) that is lost/gained spuriously during 100 years. 
     278      !!              For salt and heat thresholds, ice is considered to have a salinity of 10  
     279      !!              and a heat content of 3e5 J/kg (=latent heat of fusion)  
     280      !!-------------------------------------------------------------------------------------------------------- 
     281      CHARACTER(len=*), INTENT(in)    :: cd_routine    ! name of the routine 
     282      REAL(wp)                        :: zhfx, zsfx, zvfx 
     283      REAL(wp)                        :: zarea, zv_sill, zs_sill, zh_sill 
     284      REAL(wp), PARAMETER             :: zconv = 1.e-9 ! convert W to GW and kg to Mt 
     285 
     286#if ! defined key_bdy 
     287      ! heat flux 
     288      zhfx  = glob_sum( ( hfx_in - hfx_out - diag_heat - diag_trp_ei - diag_trp_es - hfx_sub ) * e12t * tmask(:,:,1) * zconv )  
     289      ! salt flux 
     290      zsfx  = glob_sum( ( sfx + diag_smvi ) * e12t * tmask(:,:,1) * zconv ) * rday 
     291      ! water flux 
     292      zvfx  = glob_sum( ( wfx_ice + wfx_snw + wfx_spr + wfx_sub + diag_vice + diag_vsnw ) * e12t * tmask(:,:,1) * zconv ) * rday 
     293 
     294      ! set threshold values and calculate the ice area (+epsi10 to set a threshold > 0 when there is no ice)  
     295      zarea   = glob_sum( SUM( a_i + epsi10, dim=3 ) * e12t * zconv ) ! in 1.e9 m2 
     296      zv_sill = zarea * 2.5e-5 
     297      zs_sill = zarea * 25.e-5 
     298      zh_sill = zarea * 10.e-5 
     299 
     300      IF( ABS( zvfx ) > zv_sill ) WRITE(numout,*) 'violation vfx    [Mt/day]       (',cd_routine,')  = ',(zvfx) 
     301      IF( ABS( zsfx ) > zs_sill ) WRITE(numout,*) 'violation sfx    [psu*Mt/day]   (',cd_routine,')  = ',(zsfx) 
     302      IF( ABS( zhfx ) > zh_sill ) WRITE(numout,*) 'violation hfx    [GW]           (',cd_routine,')  = ',(zhfx) 
     303#endif 
     304 
     305   END SUBROUTINE lim_cons_final 
    220306 
    221307#else 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/LIM_SRC_3/limdiahsb.F90

    r5312 r5313  
    1414   !!---------------------------------------------------------------------- 
    1515   USE ice             ! LIM-3: sea-ice variable 
    16    USE par_ice         ! LIM-3: ice parameters 
    1716   USE dom_ice         ! LIM-3: sea-ice domain 
    1817   USE dom_oce         ! ocean domain 
    … …  
    3231 
    3332   PUBLIC   lim_diahsb        ! routine called by ice_step.F90 
    34    !!PUBLIC   lim_diahsb_init   ! routine called by ice_init.F90 
    35    !!PUBLIC   lim_diahsb_rst   ! routine called by ice_init.F90 
    3633 
    3734   real(wp) ::   frc_sal, frc_vol   ! global forcing trends 
    … …  
    7471 
    7572      ! 1/area 
    76       z1_area = 1._wp / MAX( glob_sum( area(:,:) * tms(:,:) ), epsi06 ) 
    77  
    78       rswitch = MAX( 0._wp , SIGN( 1._wp , glob_sum( area(:,:) * tms(:,:) ) - epsi06 ) ) 
     73      z1_area = 1._wp / MAX( glob_sum( e12t(:,:) * tmask(:,:,1) ), epsi06 ) 
     74 
     75      rswitch = MAX( 0._wp , SIGN( 1._wp , glob_sum( e12t(:,:) * tmask(:,:,1) ) - epsi06 ) ) 
    7976      ! ----------------------- ! 
    8077      ! 1 -  Content variations ! 
    8178      ! ----------------------- ! 
    82       zbg_ivo = glob_sum( vt_i(:,:) * area(:,:) * tms(:,:) ) ! volume ice  
    83       zbg_svo = glob_sum( vt_s(:,:) * area(:,:) * tms(:,:) ) ! volume snow 
    84       zbg_are = glob_sum( at_i(:,:) * area(:,:) * tms(:,:) ) ! area 
    85       zbg_sal = glob_sum( SUM( smv_i(:,:,:), dim=3 ) * area(:,:) * tms(:,:) )       ! mean salt content 
    86       zbg_tem = glob_sum( ( tm_i(:,:) - rtt ) * vt_i(:,:) * area(:,:) * tms(:,:) )  ! mean temp content 
    87  
    88       !zbg_ihc = glob_sum( et_i(:,:) * area(:,:) * tms(:,:) ) / MAX( zbg_ivo,epsi06 ) ! ice heat content 
    89       !zbg_shc = glob_sum( et_s(:,:) * area(:,:) * tms(:,:) ) / MAX( zbg_svo,epsi06 ) ! snow heat content 
     79      zbg_ivo = glob_sum( vt_i(:,:) * e12t(:,:) * tmask(:,:,1) ) ! volume ice  
     80      zbg_svo = glob_sum( vt_s(:,:) * e12t(:,:) * tmask(:,:,1) ) ! volume snow 
     81      zbg_are = glob_sum( at_i(:,:) * e12t(:,:) * tmask(:,:,1) ) ! area 
     82      zbg_sal = glob_sum( SUM( smv_i(:,:,:), dim=3 ) * e12t(:,:) * tmask(:,:,1) )       ! mean salt content 
     83      zbg_tem = glob_sum( ( tm_i(:,:) - rt0 ) * vt_i(:,:) * e12t(:,:) * tmask(:,:,1) )  ! mean temp content 
     84 
     85      !zbg_ihc = glob_sum( et_i(:,:) * e12t(:,:) * tmask(:,:,1) ) / MAX( zbg_ivo,epsi06 ) ! ice heat content 
     86      !zbg_shc = glob_sum( et_s(:,:) * e12t(:,:) * tmask(:,:,1) ) / MAX( zbg_svo,epsi06 ) ! snow heat content 
    9087 
    9188      ! Volume 
    9289      ztmp = rswitch * z1_area * r1_rau0 * rday 
    93       zbg_vfx     = ztmp * glob_sum(     emp(:,:) * area(:,:) * tms(:,:) ) 
    94       zbg_vfx_bog = ztmp * glob_sum( wfx_bog(:,:) * area(:,:) * tms(:,:) ) 
    95       zbg_vfx_opw = ztmp * glob_sum( wfx_opw(:,:) * area(:,:) * tms(:,:) ) 
    96       zbg_vfx_sni = ztmp * glob_sum( wfx_sni(:,:) * area(:,:) * tms(:,:) ) 
    97       zbg_vfx_dyn = ztmp * glob_sum( wfx_dyn(:,:) * area(:,:) * tms(:,:) ) 
    98       zbg_vfx_bom = ztmp * glob_sum( wfx_bom(:,:) * area(:,:) * tms(:,:) ) 
    99       zbg_vfx_sum = ztmp * glob_sum( wfx_sum(:,:) * area(:,:) * tms(:,:) ) 
    100       zbg_vfx_res = ztmp * glob_sum( wfx_res(:,:) * area(:,:) * tms(:,:) ) 
    101       zbg_vfx_spr = ztmp * glob_sum( wfx_spr(:,:) * area(:,:) * tms(:,:) ) 
    102       zbg_vfx_snw = ztmp * glob_sum( wfx_snw(:,:) * area(:,:) * tms(:,:) ) 
    103       zbg_vfx_sub = ztmp * glob_sum( wfx_sub(:,:) * area(:,:) * tms(:,:) ) 
     90      zbg_vfx     = ztmp * glob_sum(     emp(:,:) * e12t(:,:) * tmask(:,:,1) ) 
     91      zbg_vfx_bog = ztmp * glob_sum( wfx_bog(:,:) * e12t(:,:) * tmask(:,:,1) ) 
     92      zbg_vfx_opw = ztmp * glob_sum( wfx_opw(:,:) * e12t(:,:) * tmask(:,:,1) ) 
     93      zbg_vfx_sni = ztmp * glob_sum( wfx_sni(:,:) * e12t(:,:) * tmask(:,:,1) ) 
     94      zbg_vfx_dyn = ztmp * glob_sum( wfx_dyn(:,:) * e12t(:,:) * tmask(:,:,1) ) 
     95      zbg_vfx_bom = ztmp * glob_sum( wfx_bom(:,:) * e12t(:,:) * tmask(:,:,1) ) 
     96      zbg_vfx_sum = ztmp * glob_sum( wfx_sum(:,:) * e12t(:,:) * tmask(:,:,1) ) 
     97      zbg_vfx_res = ztmp * glob_sum( wfx_res(:,:) * e12t(:,:) * tmask(:,:,1) ) 
     98      zbg_vfx_spr = ztmp * glob_sum( wfx_spr(:,:) * e12t(:,:) * tmask(:,:,1) ) 
     99      zbg_vfx_snw = ztmp * glob_sum( wfx_snw(:,:) * e12t(:,:) * tmask(:,:,1) ) 
     100      zbg_vfx_sub = ztmp * glob_sum( wfx_sub(:,:) * e12t(:,:) * tmask(:,:,1) ) 
    104101 
    105102      ! Salt 
    106       zbg_sfx     = ztmp * glob_sum(     sfx(:,:) * area(:,:) * tms(:,:) ) 
    107       zbg_sfx_bri = ztmp * glob_sum( sfx_bri(:,:) * area(:,:) * tms(:,:) ) 
    108       zbg_sfx_res = ztmp * glob_sum( sfx_res(:,:) * area(:,:) * tms(:,:) ) 
    109       zbg_sfx_dyn = ztmp * glob_sum( sfx_dyn(:,:) * area(:,:) * tms(:,:) ) 
    110  
    111       zbg_sfx_bog = ztmp * glob_sum( sfx_bog(:,:) * area(:,:) * tms(:,:) ) 
    112       zbg_sfx_opw = ztmp * glob_sum( sfx_opw(:,:) * area(:,:) * tms(:,:) ) 
    113       zbg_sfx_sni = ztmp * glob_sum( sfx_sni(:,:) * area(:,:) * tms(:,:) ) 
    114       zbg_sfx_bom = ztmp * glob_sum( sfx_bom(:,:) * area(:,:) * tms(:,:) ) 
    115       zbg_sfx_sum = ztmp * glob_sum( sfx_sum(:,:) * area(:,:) * tms(:,:) ) 
     103      zbg_sfx     = ztmp * glob_sum(     sfx(:,:) * e12t(:,:) * tmask(:,:,1) ) 
     104      zbg_sfx_bri = ztmp * glob_sum( sfx_bri(:,:) * e12t(:,:) * tmask(:,:,1) ) 
     105      zbg_sfx_res = ztmp * glob_sum( sfx_res(:,:) * e12t(:,:) * tmask(:,:,1) ) 
     106      zbg_sfx_dyn = ztmp * glob_sum( sfx_dyn(:,:) * e12t(:,:) * tmask(:,:,1) ) 
     107 
     108      zbg_sfx_bog = ztmp * glob_sum( sfx_bog(:,:) * e12t(:,:) * tmask(:,:,1) ) 
     109      zbg_sfx_opw = ztmp * glob_sum( sfx_opw(:,:) * e12t(:,:) * tmask(:,:,1) ) 
     110      zbg_sfx_sni = ztmp * glob_sum( sfx_sni(:,:) * e12t(:,:) * tmask(:,:,1) ) 
     111      zbg_sfx_bom = ztmp * glob_sum( sfx_bom(:,:) * e12t(:,:) * tmask(:,:,1) ) 
     112      zbg_sfx_sum = ztmp * glob_sum( sfx_sum(:,:) * e12t(:,:) * tmask(:,:,1) ) 
    116113 
    117114      ! Heat budget 
    118       zbg_ihc      = glob_sum( et_i(:,:) * 1.e-20 ) ! ice heat content  [1.e-20 J] 
    119       zbg_shc      = glob_sum( et_s(:,:) * 1.e-20 ) ! snow heat content [1.e-20 J] 
    120       zbg_hfx_dhc  = glob_sum( diag_heat_dhc(:,:) * area(:,:) * tms(:,:) ) ! [in W] 
    121       zbg_hfx_spr  = glob_sum( hfx_spr(:,:) * area(:,:) * tms(:,:) ) ! [in W] 
    122  
    123       zbg_hfx_thd  = glob_sum( hfx_thd(:,:) * area(:,:) * tms(:,:) ) ! [in W] 
    124       zbg_hfx_dyn  = glob_sum( hfx_dyn(:,:) * area(:,:) * tms(:,:) ) ! [in W] 
    125       zbg_hfx_res  = glob_sum( hfx_res(:,:) * area(:,:) * tms(:,:) ) ! [in W] 
    126       zbg_hfx_sub  = glob_sum( hfx_sub(:,:) * area(:,:) * tms(:,:) ) ! [in W] 
    127       zbg_hfx_snw  = glob_sum( hfx_snw(:,:) * area(:,:) * tms(:,:) ) ! [in W] 
    128       zbg_hfx_sum  = glob_sum( hfx_sum(:,:) * area(:,:) * tms(:,:) ) ! [in W] 
    129       zbg_hfx_bom  = glob_sum( hfx_bom(:,:) * area(:,:) * tms(:,:) ) ! [in W] 
    130       zbg_hfx_bog  = glob_sum( hfx_bog(:,:) * area(:,:) * tms(:,:) ) ! [in W] 
    131       zbg_hfx_dif  = glob_sum( hfx_dif(:,:) * area(:,:) * tms(:,:) ) ! [in W] 
    132       zbg_hfx_opw  = glob_sum( hfx_opw(:,:) * area(:,:) * tms(:,:) ) ! [in W] 
    133       zbg_hfx_out  = glob_sum( hfx_out(:,:) * area(:,:) * tms(:,:) ) ! [in W] 
    134       zbg_hfx_in   = glob_sum(  hfx_in(:,:) * area(:,:) * tms(:,:) ) ! [in W] 
     115      zbg_ihc      = glob_sum( et_i(:,:) * e12t(:,:) * 1.e-20 ) ! ice heat content  [1.e20 J] 
     116      zbg_shc      = glob_sum( et_s(:,:) * e12t(:,:) * 1.e-20 ) ! snow heat content [1.e20 J] 
     117      zbg_hfx_dhc  = glob_sum( diag_heat(:,:) * e12t(:,:) * tmask(:,:,1) ) ! [in W] 
     118      zbg_hfx_spr  = glob_sum( hfx_spr(:,:) * e12t(:,:) * tmask(:,:,1) ) ! [in W] 
     119 
     120      zbg_hfx_thd  = glob_sum( hfx_thd(:,:) * e12t(:,:) * tmask(:,:,1) ) ! [in W] 
     121      zbg_hfx_dyn  = glob_sum( hfx_dyn(:,:) * e12t(:,:) * tmask(:,:,1) ) ! [in W] 
     122      zbg_hfx_res  = glob_sum( hfx_res(:,:) * e12t(:,:) * tmask(:,:,1) ) ! [in W] 
     123      zbg_hfx_sub  = glob_sum( hfx_sub(:,:) * e12t(:,:) * tmask(:,:,1) ) ! [in W] 
     124      zbg_hfx_snw  = glob_sum( hfx_snw(:,:) * e12t(:,:) * tmask(:,:,1) ) ! [in W] 
     125      zbg_hfx_sum  = glob_sum( hfx_sum(:,:) * e12t(:,:) * tmask(:,:,1) ) ! [in W] 
     126      zbg_hfx_bom  = glob_sum( hfx_bom(:,:) * e12t(:,:) * tmask(:,:,1) ) ! [in W] 
     127      zbg_hfx_bog  = glob_sum( hfx_bog(:,:) * e12t(:,:) * tmask(:,:,1) ) ! [in W] 
     128      zbg_hfx_dif  = glob_sum( hfx_dif(:,:) * e12t(:,:) * tmask(:,:,1) ) ! [in W] 
     129      zbg_hfx_opw  = glob_sum( hfx_opw(:,:) * e12t(:,:) * tmask(:,:,1) ) ! [in W] 
     130      zbg_hfx_out  = glob_sum( hfx_out(:,:) * e12t(:,:) * tmask(:,:,1) ) ! [in W] 
     131      zbg_hfx_in   = glob_sum(  hfx_in(:,:) * e12t(:,:) * tmask(:,:,1) ) ! [in W] 
    135132     
    136133      ! --------------------------------------------- ! 
    137134      ! 2 - Trends due to forcing and ice growth/melt ! 
    138135      ! --------------------------------------------- ! 
    139       z_frc_vol = r1_rau0 * glob_sum( - emp(:,:) * area(:,:) * tms(:,:) ) ! volume fluxes 
    140       z_frc_sal = r1_rau0 * glob_sum(   sfx(:,:) * area(:,:) * tms(:,:) ) ! salt fluxes 
     136      z_frc_vol = r1_rau0 * glob_sum( - emp(:,:) * e12t(:,:) * tmask(:,:,1) ) ! volume fluxes 
     137      z_frc_sal = r1_rau0 * glob_sum(   sfx(:,:) * e12t(:,:) * tmask(:,:,1) ) ! salt fluxes 
    141138      z_bg_grme = glob_sum( - ( wfx_bog(:,:) + wfx_opw(:,:) + wfx_sni(:,:) + wfx_dyn(:,:) + & 
    142                           &     wfx_bom(:,:) + wfx_sum(:,:) + wfx_res(:,:) + wfx_snw(:,:) + wfx_sub(:,:) ) * area(:,:) * tms(:,:) ) ! volume fluxes 
     139                          &     wfx_bom(:,:) + wfx_sum(:,:) + wfx_res(:,:) + wfx_snw(:,:) + & 
     140                          &     wfx_sub(:,:) ) * e12t(:,:) * tmask(:,:,1) ) ! volume fluxes 
    143141      ! 
    144142      frc_vol  = frc_vol  + z_frc_vol  * rdt_ice 
    … …  
    247245         WRITE(numout,*) '~~~~~~~~~~~~' 
    248246      ENDIF 
    249  
    250       ! ---------------------------------- ! 
    251       ! 2 - initial conservation variables ! 
    252       ! ---------------------------------- ! 
    253       !frc_vol = 0._wp                                          ! volume       trend due to forcing 
    254       !frc_sal = 0._wp                                          ! salt content   -    -   -    -          
    255       !bg_grme = 0._wp                                          ! ice growth + melt volume trend 
    256247      ! 
    257248      CALL lim_diahsb_rst( nstart, 'READ' )  !* read or initialize all required files 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/LIM_SRC_3/limdyn.F90

    r5312 r5313  
    66   !! history :  1.0  ! 2002-08  (C. Ethe, G. Madec)  original VP code  
    77   !!            3.0  ! 2007-03  (MA Morales Maqueda, S. Bouillon, M. Vancoppenolle)  LIM3: EVP-Cgrid 
    8    !!            4.0  ! 2011-02  (G. Madec) dynamical allocation 
     8   !!            3.5  ! 2011-02  (G. Madec) dynamical allocation 
    99   !!---------------------------------------------------------------------- 
    1010#if defined key_lim3 
    … …  
    2020   USE sbc_ice          ! Surface boundary condition: ice   fields 
    2121   USE ice              ! LIM-3 variables 
    22    USE par_ice          ! LIM-3 parameters 
    2322   USE dom_ice          ! LIM-3 domain 
    2423   USE limrhg           ! LIM-3 rheology 
    … …  
    3130   USE timing          ! Timing 
    3231   USE limcons        ! conservation tests 
     32   USE limvar 
    3333 
    3434   IMPLICIT NONE 
    … …  
    7676      CALL wrk_alloc( jpj, zswitch, zmsk ) 
    7777 
     78      CALL lim_var_agg(1)             ! aggregate ice categories 
     79 
    7880      IF( kt == nit000 )   CALL lim_dyn_init   ! Initialization (first time-step only) 
    7981 
    … …  
    8385         IF( ln_limdiahsb ) CALL lim_cons_hsm(0, 'limdyn', zvi_b, zsmv_b, zei_b, zfw_b, zfs_b, zft_b) 
    8486 
    85          u_ice_b(:,:) = u_ice(:,:) * tmu(:,:) 
    86          v_ice_b(:,:) = v_ice(:,:) * tmv(:,:) 
     87         u_ice_b(:,:) = u_ice(:,:) * umask(:,:,1) 
     88         v_ice_b(:,:) = v_ice(:,:) * vmask(:,:,1) 
    8789 
    8890         ! Rheology (ice dynamics) 
    … …  
    101103            DO jj = 1, jpj 
    102104               zswitch(jj) = SUM( 1.0 - at_i(:,jj) )   ! = REAL(jpj) if ocean everywhere on a j-line 
    103                zmsk(jj) = SUM( tmask(:,jj,1)    )   ! = 0         if land  everywhere on a j-line 
     105               zmsk   (jj) = SUM( tmask(:,jj,1)    )   ! = 0         if land  everywhere on a j-line 
    104106            END DO 
    105107 
    … …  
    157159         zv_io(:,:) = v_ice(:,:) - ssv_m(:,:) 
    158160         ! frictional velocity at T-point 
    159          zcoef = 0.5_wp * cw 
     161         zcoef = 0.5_wp * rn_cio 
    160162         DO jj = 2, jpjm1  
    161163            DO ji = fs_2, fs_jpim1   ! vector opt. 
    162164               ust2s(ji,jj) = zcoef * (  zu_io(ji,jj) * zu_io(ji,jj) + zu_io(ji-1,jj) * zu_io(ji-1,jj)   & 
    163                   &                    + zv_io(ji,jj) * zv_io(ji,jj) + zv_io(ji,jj-1) * zv_io(ji,jj-1)   ) * tms(ji,jj) 
     165                  &                    + zv_io(ji,jj) * zv_io(ji,jj) + zv_io(ji,jj-1) * zv_io(ji,jj-1) ) * tmask(ji,jj,1) 
    164166            END DO 
    165167         END DO 
    … …  
    170172      ELSE      ! no ice dynamics : transmit directly the atmospheric stress to the ocean 
    171173         ! 
    172          zcoef = SQRT( 0.5_wp ) / rau0 
     174         zcoef = SQRT( 0.5_wp ) * r1_rau0 
    173175         DO jj = 2, jpjm1 
    174176            DO ji = fs_2, fs_jpim1   ! vector opt. 
    175177               ust2s(ji,jj) = zcoef * SQRT(  utau(ji,jj) * utau(ji,jj) + utau(ji-1,jj) * utau(ji-1,jj)   & 
    176                   &                        + vtau(ji,jj) * vtau(ji,jj) + vtau(ji,jj-1) * vtau(ji,jj-1)   ) * tms(ji,jj) 
     178                  &                        + vtau(ji,jj) * vtau(ji,jj) + vtau(ji,jj-1) * vtau(ji,jj-1) ) * tmask(ji,jj,1) 
    177179            END DO 
    178180         END DO 
    … …  
    189191         CALL prt_ctl(tab2d_1=delta_i   , clinfo1=' lim_dyn  : delta_i   :') 
    190192         CALL prt_ctl(tab2d_1=strength  , clinfo1=' lim_dyn  : strength  :') 
    191          CALL prt_ctl(tab2d_1=area      , clinfo1=' lim_dyn  : cell area :') 
     193         CALL prt_ctl(tab2d_1=e12t      , clinfo1=' lim_dyn  : cell area :') 
    192194         CALL prt_ctl(tab2d_1=at_i      , clinfo1=' lim_dyn  : at_i      :') 
    193195         CALL prt_ctl(tab2d_1=vt_i      , clinfo1=' lim_dyn  : vt_i      :') 
    … …  
    241243      !!------------------------------------------------------------------- 
    242244      INTEGER  ::   ios                 ! Local integer output status for namelist read 
    243       NAMELIST/namicedyn/ epsd, om, cw, pstar,   & 
    244          &                c_rhg, creepl, ecc, ahi0,     & 
    245          &                nevp, relast, alphaevp, hminrhg 
     245      NAMELIST/namicedyn/ nn_icestr, ln_icestr_bvf, rn_pe_rdg, rn_pstar, rn_crhg, rn_cio,  rn_creepl, rn_ecc, & 
     246         &                nn_nevp, rn_relast, nn_ahi0, rn_ahi0_ref 
     247      INTEGER  ::   ji, jj 
     248      REAL(wp) ::   za00, zd_max 
    246249      !!------------------------------------------------------------------- 
    247250 
    … …  
    259262         WRITE(numout,*) 'lim_dyn_init : ice parameters for ice dynamics ' 
    260263         WRITE(numout,*) '~~~~~~~~~~~~' 
    261          WRITE(numout,*) '   tolerance parameter                              epsd   = ', epsd 
    262          WRITE(numout,*) '   relaxation constant                              om     = ', om 
    263          WRITE(numout,*) '   drag coefficient for oceanic stress              cw     = ', cw 
    264          WRITE(numout,*) '   first bulk-rheology parameter                    pstar  = ', pstar 
    265          WRITE(numout,*) '   second bulk-rhelogy parameter                    c_rhg  = ', c_rhg 
    266          WRITE(numout,*) '   creep limit                                      creepl = ', creepl 
    267          WRITE(numout,*) '   eccentricity of the elliptical yield curve       ecc    = ', ecc 
    268          WRITE(numout,*) '   horizontal diffusivity coeff. for sea-ice        ahi0   = ', ahi0 
    269          WRITE(numout,*) '   number of iterations for subcycling              nevp   = ', nevp 
    270          WRITE(numout,*) '   ratio of elastic timescale over ice time step    relast = ', relast 
    271          WRITE(numout,*) '   coefficient for the solution of int. stresses  alphaevp = ', alphaevp 
    272          WRITE(numout,*) '   min ice thickness for rheology calculations     hminrhg = ', hminrhg 
     264         WRITE(numout,*)'    ice strength parameterization (0=Hibler 1=Rothrock)  nn_icestr     = ', nn_icestr  
     265         WRITE(numout,*)'    Including brine volume in ice strength comp.         ln_icestr_bvf = ', ln_icestr_bvf 
     266         WRITE(numout,*)'   Ratio of ridging work to PotEner change in ridging    rn_pe_rdg     = ', rn_pe_rdg  
     267         WRITE(numout,*) '   drag coefficient for oceanic stress                  rn_cio        = ', rn_cio 
     268         WRITE(numout,*) '   first bulk-rheology parameter                        rn_pstar      = ', rn_pstar 
     269         WRITE(numout,*) '   second bulk-rhelogy parameter                        rn_crhg       = ', rn_crhg 
     270         WRITE(numout,*) '   creep limit                                          rn_creepl     = ', rn_creepl 
     271         WRITE(numout,*) '   eccentricity of the elliptical yield curve           rn_ecc        = ', rn_ecc 
     272         WRITE(numout,*) '   number of iterations for subcycling                  nn_nevp       = ', nn_nevp 
     273         WRITE(numout,*) '   ratio of elastic timescale over ice time step        rn_relast     = ', rn_relast 
     274         WRITE(numout,*) '   horizontal diffusivity calculation                   nn_ahi0       = ', nn_ahi0 
     275         WRITE(numout,*) '   horizontal diffusivity coeff. (orca2 grid)           rn_ahi0_ref   = ', rn_ahi0_ref 
    273276      ENDIF 
    274277      ! 
    275       usecc2 = 1._wp / ( ecc * ecc ) 
    276       rhoco  = rau0  * cw 
    277  
    278       ! elastic damping 
    279       telast = relast * rdt_ice 
    280  
    281       !  Diffusion coefficients. 
    282       ahiu(:,:) = ahi0 * umask(:,:,1) 
    283       ahiv(:,:) = ahi0 * vmask(:,:,1) 
    284       ! 
     278      usecc2 = 1._wp / ( rn_ecc * rn_ecc ) 
     279      rhoco  = rau0  * rn_cio 
     280      ! 
     281      !  Diffusion coefficients 
     282      SELECT CASE( nn_ahi0 ) 
     283 
     284      CASE( 0 ) 
     285         ahiu(:,:) = rn_ahi0_ref 
     286         ahiv(:,:) = rn_ahi0_ref 
     287 
     288         IF(lwp) WRITE(numout,*) '' 
     289         IF(lwp) WRITE(numout,*) '   laplacian operator: ahim constant = rn_ahi0_ref' 
     290 
     291      CASE( 1 )  
     292 
     293         zd_max = MAX( MAXVAL( e1t(:,:) ), MAXVAL( e2t(:,:) ) ) 
     294         IF( lk_mpp )   CALL mpp_max( zd_max )          ! max over the global domain 
     295          
     296         ahiu(:,:) = rn_ahi0_ref * zd_max * 1.e-05_wp   ! 1.e05 = 100km = max grid space at 60° latitude in orca2 
     297                                                        !                    (60° = min latitude for ice cover)   
     298         ahiv(:,:) = rn_ahi0_ref * zd_max * 1.e-05_wp 
     299 
     300         IF(lwp) WRITE(numout,*) '' 
     301         IF(lwp) WRITE(numout,*) '   laplacian operator: ahim proportional to max of e1 e2 over the domain (', zd_max, ')' 
     302         IF(lwp) WRITE(numout,*) '   value for ahim = ', rn_ahi0_ref * zd_max * 1.e-05_wp  
     303          
     304      CASE( 2 )  
     305 
     306         zd_max = MAX( MAXVAL( e1t(:,:) ), MAXVAL( e2t(:,:) ) ) 
     307         IF( lk_mpp )   CALL mpp_max( zd_max )   ! max over the global domain 
     308          
     309         za00 = rn_ahi0_ref * 1.e-05_wp          ! 1.e05 = 100km = max grid space at 60° latitude in orca2 
     310                                                 !                    (60° = min latitude for ice cover)   
     311         DO jj = 1, jpj 
     312            DO ji = 1, jpi 
     313               ahiu(ji,jj) = za00 * MAX( e1t(ji,jj), e2t(ji,jj) ) * umask(ji,jj,1) 
     314               ahiv(ji,jj) = za00 * MAX( e1f(ji,jj), e2f(ji,jj) ) * vmask(ji,jj,1) 
     315            END DO 
     316         END DO 
     317         ! 
     318         IF(lwp) WRITE(numout,*) '' 
     319         IF(lwp) WRITE(numout,*) '   laplacian operator: ahim proportional to e1' 
     320         IF(lwp) WRITE(numout,*) '   maximum grid-spacing = ', zd_max, ' maximum value for ahim = ', za00*zd_max 
     321          
     322      END SELECT 
     323 
    285324   END SUBROUTINE lim_dyn_init 
    286325 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/LIM_SRC_3/limhdf.F90

    r5312 r5313  
    2626   PRIVATE 
    2727 
    28    PUBLIC   lim_hdf     ! called by lim_tra 
     28   PUBLIC   lim_hdf     ! called by lim_trp 
    2929 
    30    LOGICAL  ::   linit = .TRUE.              ! initialization flag (set to flase after the 1st call) 
    31    REAL(wp) ::   epsi04 = 1.e-04              ! constant 
     30   LOGICAL  ::   linit = .TRUE.                             ! initialization flag (set to flase after the 1st call) 
    3231   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   efact   ! metric coefficient 
    3332 
    … …  
    5453      REAL(wp), DIMENSION(jpi,jpj), INTENT( inout ) ::   ptab    ! Field on which the diffusion is applied 
    5554      ! 
    56       INTEGER  ::  ji, jj                   ! dummy loop indices 
    57       INTEGER  ::  its, iter, ierr          ! local integers 
    58       REAL(wp) ::   zalfa, zrlxint, zconv   ! local scalars 
    59       REAL(wp), POINTER, DIMENSION(:,:) ::   zrlx, zflu, zflv, zdiv0, zdiv, ztab0 
    60       CHARACTER(lc) ::   charout   ! local character 
     55      INTEGER                           ::  ji, jj                    ! dummy loop indices 
     56      INTEGER                           ::  iter, ierr           ! local integers 
     57      REAL(wp)                          ::  zrlxint, zconv     ! local scalars 
     58      REAL(wp), POINTER, DIMENSION(:,:) ::  zrlx, zflu, zflv, zdiv0, zdiv, ztab0 
     59      CHARACTER(lc)                     ::  charout                   ! local character 
     60      REAL(wp), PARAMETER               ::  zrelax = 0.5_wp           ! relaxation constant for iterative procedure 
     61      REAL(wp), PARAMETER               ::  zalfa  = 0.5_wp           ! =1.0/0.5/0.0 = implicit/Cranck-Nicholson/explicit 
     62      INTEGER , PARAMETER               ::  its    = 100              ! Maximum number of iteration 
    6163      !!------------------------------------------------------------------- 
    6264       
    … …  
    7173         DO jj = 2, jpjm1   
    7274            DO ji = fs_2 , fs_jpim1   ! vector opt. 
    73                efact(ji,jj) = ( e2u(ji,jj) + e2u(ji-1,jj) + e1v(ji,jj) + e1v(ji,jj-1) ) / ( e1t(ji,jj) * e2t(ji,jj) ) 
     75               efact(ji,jj) = ( e2u(ji,jj) + e2u(ji-1,jj) + e1v(ji,jj) + e1v(ji,jj-1) ) * r1_e12t(ji,jj) 
    7476            END DO 
    7577         END DO 
    … …  
    7779      ENDIF 
    7880      !                             ! Time integration parameters 
    79       zalfa = 0.5_wp                      ! =1.0/0.5/0.0 = implicit/Cranck-Nicholson/explicit 
    80       its   = 100                         ! Maximum number of iteration 
    8181      ! 
    8282      ztab0(:, : ) = ptab(:,:)      ! Arrays initialization 
    … …  
    9191      iter  = 0 
    9292      ! 
    93       DO WHILE( zconv > ( 2._wp * epsi04 ) .AND. iter <= its )   ! Sub-time step loop 
     93      DO WHILE( zconv > ( 2._wp * 1.e-04 ) .AND. iter <= its )   ! Sub-time step loop 
    9494         ! 
    9595         iter = iter + 1                                 ! incrementation of the sub-time step number 
    … …  
    9797         DO jj = 1, jpjm1                                ! diffusive fluxes in U- and V- direction 
    9898            DO ji = 1 , fs_jpim1   ! vector opt. 
    99                zflu(ji,jj) = pahu(ji,jj) * e2u(ji,jj) / e1u(ji,jj) * ( ptab(ji+1,jj) - ptab(ji,jj) ) 
    100                zflv(ji,jj) = pahv(ji,jj) * e1v(ji,jj) / e2v(ji,jj) * ( ptab(ji,jj+1) - ptab(ji,jj) ) 
     99               zflu(ji,jj) = pahu(ji,jj) * e2u(ji,jj) * r1_e1u(ji,jj) * ( ptab(ji+1,jj) - ptab(ji,jj) ) 
     100               zflv(ji,jj) = pahv(ji,jj) * e1v(ji,jj) * r1_e2v(ji,jj) * ( ptab(ji,jj+1) - ptab(ji,jj) ) 
    101101            END DO 
    102102         END DO 
    … …  
    104104         DO jj= 2, jpjm1                                 ! diffusive trend : divergence of the fluxes 
    105105            DO ji = fs_2 , fs_jpim1   ! vector opt.  
    106                zdiv (ji,jj) = (  zflu(ji,jj) - zflu(ji-1,jj  )   & 
    107                   &            + zflv(ji,jj) - zflv(ji  ,jj-1)  ) / ( e1t (ji,jj) * e2t (ji,jj) ) 
     106               zdiv(ji,jj) = ( zflu(ji,jj) - zflu(ji-1,jj) + zflv(ji,jj) - zflv(ji,jj-1) ) * r1_e12t(ji,jj) 
    108107            END DO 
    109108         END DO 
    … …  
    115114               zrlxint = (   ztab0(ji,jj)    & 
    116115                  &       +  rdt_ice * (           zalfa   * ( zdiv(ji,jj) + efact(ji,jj) * ptab(ji,jj) )   & 
    117                   &                      + ( 1.0 - zalfa ) *   zdiv0(ji,jj) )  )                             &  
    118                   &    / ( 1.0 + zalfa * rdt_ice * efact(ji,jj) ) 
    119                zrlx(ji,jj) = ptab(ji,jj) + om * ( zrlxint - ptab(ji,jj) ) 
     116                  &                      + ( 1.0 - zalfa ) *   zdiv0(ji,jj) )                               &  
     117                  &      ) / ( 1.0 + zalfa * rdt_ice * efact(ji,jj) ) 
     118               zrlx(ji,jj) = ptab(ji,jj) + zrelax * ( zrlxint - ptab(ji,jj) ) 
    120119            END DO 
    121120         END DO 
    … …  
    138137      DO jj = 1, jpjm1                                ! diffusive fluxes in U- and V- direction 
    139138         DO ji = 1 , fs_jpim1   ! vector opt. 
    140             zflu(ji,jj) = pahu(ji,jj) * e2u(ji,jj) / e1u(ji,jj) * ( ptab(ji+1,jj) - ptab(ji,jj) ) 
    141             zflv(ji,jj) = pahv(ji,jj) * e1v(ji,jj) / e2v(ji,jj) * ( ptab(ji,jj+1) - ptab(ji,jj) ) 
     139            zflu(ji,jj) = pahu(ji,jj) * e2u(ji,jj) * r1_e1u(ji,jj) * ( ptab(ji+1,jj) - ptab(ji,jj) ) 
     140            zflv(ji,jj) = pahv(ji,jj) * e1v(ji,jj) * r1_e2v(ji,jj) * ( ptab(ji,jj+1) - ptab(ji,jj) ) 
    142141         END DO 
    143142      END DO 
    … …  
    145144      DO jj= 2, jpjm1                                 ! diffusive trend : divergence of the fluxes 
    146145         DO ji = fs_2 , fs_jpim1   ! vector opt.  
    147             zdiv (ji,jj) = (  zflu(ji,jj) - zflu(ji-1,jj  )   & 
    148                  &            + zflv(ji,jj) - zflv(ji  ,jj-1)  ) / ( e1t (ji,jj) * e2t (ji,jj) ) 
     146            zdiv(ji,jj) = ( zflu(ji,jj) - zflu(ji-1,jj) + zflv(ji,jj) - zflv(ji,jj-1) ) * r1_e12t(ji,jj) 
    149147            ptab(ji,jj) = ztab0(ji,jj) + 0.5 * ( zdiv(ji,jj) + zdiv0(ji,jj) ) 
    150148         END DO 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/LIM_SRC_3/limistate.F90

    r5312 r5313  
    2222   USE eosbn2           ! equation of state 
    2323   USE ice              ! sea-ice variables 
    24    USE par_ice          ! ice parameters 
    2524   USE par_oce          ! ocean parameters 
    2625   USE dom_ice          ! sea-ice domain 
    … …  
    3635 
    3736   !                          !!** init namelist (namiceini) ** 
    38    REAL(wp) ::   thres_sst   ! threshold water temperature for initial sea ice 
    39    REAL(wp) ::   hts_ini_n   ! initial snow thickness in the north 
    40    REAL(wp) ::   hts_ini_s   ! initial snow thickness in the south 
    41    REAL(wp) ::   hti_ini_n   ! initial ice thickness in the north 
    42    REAL(wp) ::   hti_ini_s   ! initial ice thickness in the south 
    43    REAL(wp) ::   ati_ini_n   ! initial leads area in the north 
    44    REAL(wp) ::   ati_ini_s   ! initial leads area in the south 
    45    REAL(wp) ::   smi_ini_n   ! initial salinity  
    46    REAL(wp) ::   smi_ini_s   ! initial salinity 
    47    REAL(wp) ::   tmi_ini_n   ! initial temperature 
    48    REAL(wp) ::   tmi_ini_s   ! initial temperature 
    49  
    50    LOGICAL  ::  ln_limini    ! initialization or not 
     37   REAL(wp) ::   rn_thres_sst   ! threshold water temperature for initial sea ice 
     38   REAL(wp) ::   rn_hts_ini_n   ! initial snow thickness in the north 
     39   REAL(wp) ::   rn_hts_ini_s   ! initial snow thickness in the south 
     40   REAL(wp) ::   rn_hti_ini_n   ! initial ice thickness in the north 
     41   REAL(wp) ::   rn_hti_ini_s   ! initial ice thickness in the south 
     42   REAL(wp) ::   rn_ati_ini_n   ! initial leads area in the north 
     43   REAL(wp) ::   rn_ati_ini_s   ! initial leads area in the south 
     44   REAL(wp) ::   rn_smi_ini_n   ! initial salinity  
     45   REAL(wp) ::   rn_smi_ini_s   ! initial salinity 
     46   REAL(wp) ::   rn_tmi_ini_n   ! initial temperature 
     47   REAL(wp) ::   rn_tmi_ini_s   ! initial temperature 
     48 
     49   LOGICAL  ::  ln_iceini    ! initialization or not 
    5150   !!---------------------------------------------------------------------- 
    5251   !!   LIM 3.0,  UCL-LOCEAN-IPSL (2008) 
    … …  
    8786      !! * Local variables 
    8887      INTEGER    :: ji, jj, jk, jl             ! dummy loop indices 
    89       REAL(wp)   :: epsi20, ztmelts, zdh 
     88      REAL(wp)   :: ztmelts, zdh 
    9089      INTEGER    :: i_hemis, i_fill, jl0   
    9190      REAL(wp)   :: ztest_1, ztest_2, ztest_3, ztest_4, ztests, zsigma, zarg, zA, zV, zA_cons, zV_cons, zconv 
    … …  
    101100      CALL wrk_alloc(   2,      zht_i_ini, zat_i_ini, zvt_i_ini, zht_s_ini, zsm_i_ini, ztm_i_ini ) 
    102101 
    103       epsi20   = 1.e-20_wp 
    104  
    105102      IF(lwp) WRITE(numout,*) 
    106103      IF(lwp) WRITE(numout,*) 'lim_istate : Ice initialization ' 
    … …  
    115112      ! surface temperature 
    116113      DO jl = 1, jpl ! loop over categories 
    117          t_su  (:,:,jl) = rtt * tms(:,:) 
    118          tn_ice(:,:,jl) = rtt * tms(:,:) 
     114         t_su  (:,:,jl) = rt0 * tmask(:,:,1) 
     115         tn_ice(:,:,jl) = rt0 * tmask(:,:,1) 
    119116      END DO 
    120117 
    121118      ! basal temperature (considered at freezing point) 
    122       t_bo(:,:) = ( eos_fzp( tsn(:,:,1,jp_sal) ) + rt0 ) * tms(:,:)  
    123  
    124       IF( ln_limini ) THEN 
     119      t_bo(:,:) = ( eos_fzp( tsn(:,:,1,jp_sal) ) + rt0 ) * tmask(:,:,1)  
     120 
     121      IF( ln_iceini ) THEN 
    125122 
    126123      !-------------------------------------------------------------------- 
    … …  
    130127      DO jj = 1, jpj                                       ! ice if sst <= t-freez + ttest 
    131128         DO ji = 1, jpi 
    132             IF( ( tsn(ji,jj,1,jp_tem)  - ( t_bo(ji,jj) - rt0 ) ) * tms(ji,jj) >= thres_sst ) THEN  
    133                zswitch(ji,jj) = 0._wp * tms(ji,jj)    ! no ice 
     129            IF( ( tsn(ji,jj,1,jp_tem)  - ( t_bo(ji,jj) - rt0 ) ) * tmask(ji,jj,1) >= rn_thres_sst ) THEN  
     130               zswitch(ji,jj) = 0._wp * tmask(ji,jj,1)    ! no ice 
    134131            ELSE                                                                                    
    135                zswitch(ji,jj) = 1._wp * tms(ji,jj)    !    ice 
     132               zswitch(ji,jj) = 1._wp * tmask(ji,jj,1)    !    ice 
    136133            ENDIF 
    137134         END DO 
    … …  
    158155      !----------------------------- 
    159156      ! assign initial thickness, concentration, snow depth and salinity to an hemisphere-dependent array 
    160       zht_i_ini(1) = hti_ini_n ; zht_i_ini(2) = hti_ini_s  ! ice thickness 
    161       zht_s_ini(1) = hts_ini_n ; zht_s_ini(2) = hts_ini_s  ! snow depth 
    162       zat_i_ini(1) = ati_ini_n ; zat_i_ini(2) = ati_ini_s  ! ice concentration 
    163       zsm_i_ini(1) = smi_ini_n ; zsm_i_ini(2) = smi_ini_s  ! bulk ice salinity 
    164       ztm_i_ini(1) = tmi_ini_n ; ztm_i_ini(2) = tmi_ini_s  ! temperature (ice and snow) 
     157      zht_i_ini(1) = rn_hti_ini_n ; zht_i_ini(2) = rn_hti_ini_s  ! ice thickness 
     158      zht_s_ini(1) = rn_hts_ini_n ; zht_s_ini(2) = rn_hts_ini_s  ! snow depth 
     159      zat_i_ini(1) = rn_ati_ini_n ; zat_i_ini(2) = rn_ati_ini_s  ! ice concentration 
     160      zsm_i_ini(1) = rn_smi_ini_n ; zsm_i_ini(2) = rn_smi_ini_s  ! bulk ice salinity 
     161      ztm_i_ini(1) = rn_tmi_ini_n ; ztm_i_ini(2) = rn_tmi_ini_s  ! temperature (ice and snow) 
    165162 
    166163      zvt_i_ini(:) = zht_i_ini(:) * zat_i_ini(:)   ! ice volume 
    … …  
    197194               !--- Ice thicknesses in the i_fill - 1 first categories 
    198195               DO jl = 1, i_fill - 1 
    199                   zh_i_ini(jl,i_hemis)    = 0.5 * ( hi_max(jl) + hi_max(jl-1) ) 
     196                  zh_i_ini(jl,i_hemis) = hi_mean(jl) 
    200197               END DO 
    201198                
    202199               !--- jl0: most likely index where cc will be maximum 
    203200               DO jl = 1, jpl 
    204                   IF ( ( zht_i_ini(i_hemis) .GT. hi_max(jl-1) ) .AND. & 
    205                      ( zht_i_ini(i_hemis) .LE. hi_max(jl)   ) ) THEN 
     201                  IF ( ( zht_i_ini(i_hemis) > hi_max(jl-1) ) .AND. & 
     202                     & ( zht_i_ini(i_hemis) <= hi_max(jl)   ) ) THEN 
    206203                     jl0 = jl 
    207204                  ENDIF 
    … …  
    267264 
    268265            ! Test 3: thickness of the last category is in-bounds ? 
    269             IF ( zh_i_ini(i_fill, i_hemis) .GT. hi_max(i_fill-1) ) THEN 
     266            IF ( zh_i_ini(i_fill, i_hemis) > hi_max(i_fill-1) ) THEN 
    270267               ztest_3 = 1 
    271268            ELSE 
    … …  
    317314            DO ji = 1, jpi 
    318315               a_i(ji,jj,jl)   = zswitch(ji,jj) * za_i_ini (jl,zhemis(ji,jj))  ! concentration 
    319                ht_i(ji,jj,jl)  = zswitch(ji,jj) * zh_i_ini(jl,zhemis(ji,jj))  ! ice thickness 
     316               ht_i(ji,jj,jl)  = zswitch(ji,jj) * zh_i_ini(jl,zhemis(ji,jj))   ! ice thickness 
    320317               ht_s(ji,jj,jl)  = ht_i(ji,jj,jl) * ( zht_s_ini( zhemis(ji,jj) ) / zht_i_ini( zhemis(ji,jj) ) )  ! snow depth 
    321                sm_i(ji,jj,jl)  = zswitch(ji,jj) * zsm_i_ini(zhemis(ji,jj)) !+ ( 1._wp - zswitch(ji,jj) ) * s_i_min ! salinity 
    322                o_i(ji,jj,jl)   = zswitch(ji,jj) * 1._wp + ( 1._wp - zswitch(ji,jj) ) ! age 
    323                t_su(ji,jj,jl)  = zswitch(ji,jj) * ztm_i_ini(zhemis(ji,jj)) + ( 1._wp - zswitch(ji,jj) ) * rtt ! surf temp 
     318               sm_i(ji,jj,jl)  = zswitch(ji,jj) * zsm_i_ini(zhemis(ji,jj))     ! salinity 
     319               o_i(ji,jj,jl)   = zswitch(ji,jj) * 1._wp                        ! age (1 day) 
     320               t_su(ji,jj,jl)  = zswitch(ji,jj) * ztm_i_ini(zhemis(ji,jj)) + ( 1._wp - zswitch(ji,jj) ) * rt0 ! surf temp 
    324321 
    325322               ! This case below should not be used if (ht_s/ht_i) is ok in namelist 
    … …  
    329326               ! recompute ht_i, ht_s avoiding out of bounds values 
    330327               ht_i(ji,jj,jl) = MIN( hi_max(jl), ht_i(ji,jj,jl) + zdh ) 
    331                ht_s(ji,jj,jl) = MAX( 0._wp, ht_s(ji,jj,jl) - zdh * rhoic / rhosn ) 
     328               ht_s(ji,jj,jl) = MAX( 0._wp, ht_s(ji,jj,jl) - zdh * rhoic * r1_rhosn ) 
    332329 
    333330               ! ice volume, salt content, age content 
    … …  
    336333               smv_i(ji,jj,jl) = MIN( sm_i(ji,jj,jl) , sss_m(ji,jj) ) * v_i(ji,jj,jl) ! salt content 
    337334               oa_i(ji,jj,jl)  = o_i(ji,jj,jl) * a_i(ji,jj,jl)               ! age content 
    338             END DO ! ji 
    339          END DO ! jj 
    340       END DO ! jl 
     335            END DO 
     336         END DO 
     337      END DO 
    341338 
    342339      ! Snow temperature and heat content 
    … …  
    345342            DO jj = 1, jpj 
    346343               DO ji = 1, jpi 
    347                    t_s(ji,jj,jk,jl) = zswitch(ji,jj) * ztm_i_ini(zhemis(ji,jj)) + ( 1._wp - zswitch(ji,jj) ) * rtt 
     344                   t_s(ji,jj,jk,jl) = zswitch(ji,jj) * ztm_i_ini(zhemis(ji,jj)) + ( 1._wp - zswitch(ji,jj) ) * rt0 
    348345                   ! Snow energy of melting 
    349                    e_s(ji,jj,jk,jl) = zswitch(ji,jj) * rhosn * ( cpic * ( rtt - t_s(ji,jj,jk,jl) ) + lfus ) 
    350                    ! Change dimensions 
    351                    e_s(ji,jj,jk,jl) = e_s(ji,jj,jk,jl) / unit_fac 
    352                    ! Multiply by volume, so that heat content in Joules 
    353                    e_s(ji,jj,jk,jl) = e_s(ji,jj,jk,jl) * area(ji,jj) * v_s(ji,jj,jl) / nlay_s 
    354                END DO ! ji 
    355             END DO ! jj 
    356          END DO ! jl 
    357       END DO ! jk 
     346                   e_s(ji,jj,jk,jl) = zswitch(ji,jj) * rhosn * ( cpic * ( rt0 - t_s(ji,jj,jk,jl) ) + lfus ) 
     347 
     348                   ! Mutliply by volume, and divide by number of layers to get heat content in J/m2 
     349                   e_s(ji,jj,jk,jl) = e_s(ji,jj,jk,jl) * v_s(ji,jj,jl) * r1_nlay_s 
     350               END DO 
     351            END DO 
     352         END DO 
     353      END DO 
    358354 
    359355      ! Ice salinity, temperature and heat content 
    … …  
    362358            DO jj = 1, jpj 
    363359               DO ji = 1, jpi 
    364                    t_i(ji,jj,jk,jl) = zswitch(ji,jj) * ztm_i_ini(zhemis(ji,jj)) + ( 1._wp - zswitch(ji,jj) ) * rtt  
    365                    s_i(ji,jj,jk,jl) = zswitch(ji,jj) * zsm_i_ini(zhemis(ji,jj)) !+ ( 1._wp - zswitch(ji,jj) ) * s_i_min 
    366                    ztmelts          = - tmut * s_i(ji,jj,jk,jl) + rtt !Melting temperature in K 
     360                   t_i(ji,jj,jk,jl) = zswitch(ji,jj) * ztm_i_ini(zhemis(ji,jj)) + ( 1._wp - zswitch(ji,jj) ) * rt0  
     361                   s_i(ji,jj,jk,jl) = zswitch(ji,jj) * zsm_i_ini(zhemis(ji,jj)) !+ ( 1._wp - zswitch(ji,jj) ) * rn_simin 
     362                   ztmelts          = - tmut * s_i(ji,jj,jk,jl) + rt0 !Melting temperature in K 
    367363 
    368364                   ! heat content per unit volume 
    369365                   e_i(ji,jj,jk,jl) = zswitch(ji,jj) * rhoic * (   cpic    * ( ztmelts - t_i(ji,jj,jk,jl) ) & 
    370                       +   lfus    * ( 1._wp - (ztmelts-rtt) / MIN((t_i(ji,jj,jk,jl)-rtt),-epsi20) ) & 
    371                       -   rcp     * ( ztmelts - rtt ) ) 
    372  
    373                    ! Correct dimensions to avoid big values 
    374                    e_i(ji,jj,jk,jl) = e_i(ji,jj,jk,jl) / unit_fac  
    375  
    376                    ! Mutliply by ice volume, and divide by number of layers to get heat content in J 
    377                    e_i(ji,jj,jk,jl) = e_i(ji,jj,jk,jl) * area(ji,jj) * v_i(ji,jj,jl) / nlay_i 
    378                END DO ! ji 
    379             END DO ! jj 
    380          END DO ! jl 
    381       END DO ! jk 
     366                      +   lfus    * ( 1._wp - (ztmelts-rt0) / MIN((t_i(ji,jj,jk,jl)-rt0),-epsi20) ) & 
     367                      -   rcp     * ( ztmelts - rt0 ) ) 
     368 
     369                   ! Mutliply by ice volume, and divide by number of layers to get heat content in J/m2 
     370                   e_i(ji,jj,jk,jl) = e_i(ji,jj,jk,jl) * v_i(ji,jj,jl) * r1_nlay_i 
     371               END DO 
     372            END DO 
     373         END DO 
     374      END DO 
    382375 
    383376      tn_ice (:,:,:) = t_su (:,:,:) 
    384377 
    385378      ELSE  
    386          ! if ln_limini=false 
     379         ! if ln_iceini=false 
    387380         a_i  (:,:,:) = 0._wp 
    388381         v_i  (:,:,:) = 0._wp 
    … …  
    400393         DO jl = 1, jpl 
    401394            DO jk = 1, nlay_i 
    402                t_i(:,:,jk,jl) = rtt * tms(:,:) 
     395               t_i(:,:,jk,jl) = rt0 * tmask(:,:,1) 
    403396            END DO 
    404397            DO jk = 1, nlay_s 
    405                t_s(:,:,jk,jl) = rtt * tms(:,:) 
     398               t_s(:,:,jk,jl) = rt0 * tmask(:,:,1) 
    406399            END DO 
    407400         END DO 
    408401       
    409       ENDIF ! ln_limini 
     402      ENDIF ! ln_iceini 
    410403       
    411404      at_i (:,:) = 0.0_wp 
    … …  
    481474      !!  8.5  ! 07-11 (M. Vancoppenolle) rewritten initialization 
    482475      !!----------------------------------------------------------------------------- 
    483       NAMELIST/namiceini/ ln_limini, thres_sst, hts_ini_n, hts_ini_s, hti_ini_n, hti_ini_s,  & 
    484          &                                      ati_ini_n, ati_ini_s, smi_ini_n, smi_ini_s, tmi_ini_n, tmi_ini_s 
     476      NAMELIST/namiceini/ ln_iceini, rn_thres_sst, rn_hts_ini_n, rn_hts_ini_s, rn_hti_ini_n, rn_hti_ini_s,  & 
     477         &                                      rn_ati_ini_n, rn_ati_ini_s, rn_smi_ini_n, rn_smi_ini_s, rn_tmi_ini_n, rn_tmi_ini_s 
    485478      INTEGER :: ios                 ! Local integer output status for namelist read 
    486479      !!----------------------------------------------------------------------------- 
    … …  
    502495         WRITE(numout,*) 'lim_istate_init : ice parameters inititialisation ' 
    503496         WRITE(numout,*) '~~~~~~~~~~~~~~~' 
    504          WRITE(numout,*) '   initialization with ice (T) or not (F)       ln_limini   = ', ln_limini 
    505          WRITE(numout,*) '   threshold water temp. for initial sea-ice    thres_sst  = ', thres_sst 
    506          WRITE(numout,*) '   initial snow thickness in the north          hts_ini_n  = ', hts_ini_n 
    507          WRITE(numout,*) '   initial snow thickness in the south          hts_ini_s  = ', hts_ini_s  
    508          WRITE(numout,*) '   initial ice thickness  in the north          hti_ini_n  = ', hti_ini_n 
    509          WRITE(numout,*) '   initial ice thickness  in the south          hti_ini_s  = ', hti_ini_s 
    510          WRITE(numout,*) '   initial ice concentr.  in the north          ati_ini_n  = ', ati_ini_n 
    511          WRITE(numout,*) '   initial ice concentr.  in the north          ati_ini_s  = ', ati_ini_s 
    512          WRITE(numout,*) '   initial  ice salinity  in the north          smi_ini_n  = ', smi_ini_n 
    513          WRITE(numout,*) '   initial  ice salinity  in the south          smi_ini_s  = ', smi_ini_s 
    514          WRITE(numout,*) '   initial  ice/snw temp  in the north          tmi_ini_n  = ', tmi_ini_n 
    515          WRITE(numout,*) '   initial  ice/snw temp  in the south          tmi_ini_s  = ', tmi_ini_s 
     497         WRITE(numout,*) '   initialization with ice (T) or not (F)       ln_iceini     = ', ln_iceini 
     498         WRITE(numout,*) '   threshold water temp. for initial sea-ice    rn_thres_sst  = ', rn_thres_sst 
     499         WRITE(numout,*) '   initial snow thickness in the north          rn_hts_ini_n  = ', rn_hts_ini_n 
     500         WRITE(numout,*) '   initial snow thickness in the south          rn_hts_ini_s  = ', rn_hts_ini_s  
     501         WRITE(numout,*) '   initial ice thickness  in the north          rn_hti_ini_n  = ', rn_hti_ini_n 
     502         WRITE(numout,*) '   initial ice thickness  in the south          rn_hti_ini_s  = ', rn_hti_ini_s 
     503         WRITE(numout,*) '   initial ice concentr.  in the north          rn_ati_ini_n  = ', rn_ati_ini_n 
     504         WRITE(numout,*) '   initial ice concentr.  in the north          rn_ati_ini_s  = ', rn_ati_ini_s 
     505         WRITE(numout,*) '   initial  ice salinity  in the north          rn_smi_ini_n  = ', rn_smi_ini_n 
     506         WRITE(numout,*) '   initial  ice salinity  in the south          rn_smi_ini_s  = ', rn_smi_ini_s 
     507         WRITE(numout,*) '   initial  ice/snw temp  in the north          rn_tmi_ini_n  = ', rn_tmi_ini_n 
     508         WRITE(numout,*) '   initial  ice/snw temp  in the south          rn_tmi_ini_s  = ', rn_tmi_ini_s 
    516509      ENDIF 
    517510 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/LIM_SRC_3/limitd_me.F90

    r5312 r5313  
    1818   USE thd_ice          ! LIM thermodynamics 
    1919   USE ice              ! LIM variables 
    20    USE par_ice          ! LIM parameters 
    2120   USE dom_ice          ! LIM domain 
    22    USE limthd_lac       ! LIM 
    2321   USE limvar           ! LIM 
    24    USE in_out_manager   ! I/O manager 
    2522   USE lbclnk           ! lateral boundary condition - MPP exchanges 
    2623   USE lib_mpp          ! MPP library 
    2724   USE wrk_nemo         ! work arrays 
    2825   USE prtctl           ! Print control 
    29   ! Check budget (Rousset) 
     26 
     27   USE in_out_manager   ! I/O manager 
    3028   USE iom              ! I/O manager 
    3129   USE lib_fortran      ! glob_sum 
    … …  
    4038   PUBLIC   lim_itd_me_icestrength 
    4139   PUBLIC   lim_itd_me_init 
    42    PUBLIC   lim_itd_me_zapsmall 
    43    PUBLIC   lim_itd_me_alloc        ! called by iceini.F90 
     40   PUBLIC   lim_itd_me_alloc        ! called by sbc_lim_init  
    4441 
    4542   !----------------------------------------------------------------------- 
    … …  
    125122      !!  and Elizabeth C. Hunke, LANL are gratefully acknowledged 
    126123      !!--------------------------------------------------------------------! 
    127       INTEGER ::   ji, jj, jk, jl   ! dummy loop index 
    128       INTEGER ::   niter, nitermax = 20   ! local integer  
    129       LOGICAL  ::   asum_error            ! flag for asum .ne. 1 
     124      INTEGER  ::   ji, jj, jk, jl        ! dummy loop index 
     125      INTEGER  ::   niter                 ! local integer  
    130126      INTEGER  ::   iterate_ridging       ! if true, repeat the ridging 
    131       REAL(wp) ::   w1, tmpfac            ! local scalar 
     127      REAL(wp) ::   za, zfac              ! local scalar 
    132128      CHARACTER (len = 15) ::   fieldid 
    133       REAL(wp), POINTER, DIMENSION(:,:) ::   closing_net     ! net rate at which area is removed    (1/s) 
    134                                                              ! (ridging ice area - area of new ridges) / dt 
    135       REAL(wp), POINTER, DIMENSION(:,:) ::   divu_adv        ! divu as implied by transport scheme  (1/s) 
    136       REAL(wp), POINTER, DIMENSION(:,:) ::   opning          ! rate of opening due to divergence/shear 
    137       REAL(wp), POINTER, DIMENSION(:,:) ::   closing_gross   ! rate at which area removed, not counting area of new ridges 
    138       REAL(wp), POINTER, DIMENSION(:,:) ::   msnow_mlt       ! mass of snow added to ocean (kg m-2) 
    139       REAL(wp), POINTER, DIMENSION(:,:) ::   esnow_mlt       ! energy needed to melt snow in ocean (J m-2) 
    140       REAL(wp), POINTER, DIMENSION(:,:) ::   vt_i_init, vt_i_final  !  ice volume summed over categories 
     129      REAL(wp), POINTER, DIMENSION(:,:)   ::   closing_net     ! net rate at which area is removed    (1/s) 
     130                                                               ! (ridging ice area - area of new ridges) / dt 
     131      REAL(wp), POINTER, DIMENSION(:,:)   ::   divu_adv        ! divu as implied by transport scheme  (1/s) 
     132      REAL(wp), POINTER, DIMENSION(:,:)   ::   opning          ! rate of opening due to divergence/shear 
     133      REAL(wp), POINTER, DIMENSION(:,:)   ::   closing_gross   ! rate at which area removed, not counting area of new ridges 
     134      REAL(wp), POINTER, DIMENSION(:,:)   ::   msnow_mlt       ! mass of snow added to ocean (kg m-2) 
     135      REAL(wp), POINTER, DIMENSION(:,:)   ::   esnow_mlt       ! energy needed to melt snow in ocean (J m-2) 
     136      REAL(wp), POINTER, DIMENSION(:,:)   ::   vt_i_init, vt_i_final  !  ice volume summed over categories 
     137      ! 
     138      INTEGER, PARAMETER ::   nitermax = 20     
    141139      ! 
    142140      REAL(wp) :: zvi_b, zsmv_b, zei_b, zfs_b, zfw_b, zft_b  
    … …  
    144142      IF( nn_timing == 1 )  CALL timing_start('limitd_me') 
    145143 
    146       CALL wrk_alloc( jpi, jpj, closing_net, divu_adv, opning, closing_gross, msnow_mlt, esnow_mlt, vt_i_init, vt_i_final ) 
     144      CALL wrk_alloc( jpi,jpj, closing_net, divu_adv, opning, closing_gross, msnow_mlt, esnow_mlt, vt_i_init, vt_i_final ) 
    147145 
    148146      IF(ln_ctl) THEN 
    … …  
    156154      IF( ln_limdiahsb ) CALL lim_cons_hsm(0, 'limitd_me', zvi_b, zsmv_b, zei_b, zfw_b, zfs_b, zft_b) 
    157155 
     156      CALL lim_var_zapsmall 
     157      CALL lim_var_glo2eqv            ! equivalent variables, requested for rafting 
     158 
    158159      !-----------------------------------------------------------------------------! 
    159160      ! 1) Thickness categories boundaries, ice / o.w. concentrations, init_ons 
    160161      !-----------------------------------------------------------------------------! 
    161       Cp = 0.5 * grav * (rau0-rhoic) * rhoic / rau0                ! proport const for PE 
     162      Cp = 0.5 * grav * (rau0-rhoic) * rhoic * r1_rau0             ! proport const for PE 
    162163      ! 
    163164      CALL lim_itd_me_ridgeprep                                    ! prepare ridging 
    … …  
    193194            !  (thick, newly ridged ice). 
    194195 
    195             closing_net(ji,jj) = Cs * 0.5 * ( Delta_i(ji,jj) - ABS( divu_i(ji,jj) ) ) - MIN( divu_i(ji,jj), 0._wp ) 
     196            closing_net(ji,jj) = rn_cs * 0.5 * ( delta_i(ji,jj) - ABS( divu_i(ji,jj) ) ) - MIN( divu_i(ji,jj), 0._wp ) 
    196197 
    197198            ! 2.2 divu_adv 
    … …  
    237238               ! Reduce the closing rate if more than 100% of the open water  
    238239               ! would be removed.  Reduce the opening rate proportionately. 
    239                IF ( ato_i(ji,jj) .GT. epsi10 .AND. athorn(ji,jj,0) .GT. 0.0 ) THEN 
    240                   w1 = athorn(ji,jj,0) * closing_gross(ji,jj) * rdt_ice 
    241                   IF ( w1 .GT. ato_i(ji,jj)) THEN 
    242                      tmpfac = ato_i(ji,jj) / w1 
    243                      closing_gross(ji,jj) = closing_gross(ji,jj) * tmpfac 
    244                      opning(ji,jj) = opning(ji,jj) * tmpfac 
    245                   ENDIF !w1 
    246                ENDIF !at0i and athorn 
    247  
    248             END DO ! ji 
    249          END DO ! jj 
     240               za   = athorn(ji,jj,0) * closing_gross(ji,jj) * rdt_ice 
     241               IF( za > epsi20 ) THEN 
     242                  zfac = MIN( 1._wp, ato_i(ji,jj) / za ) 
     243                  closing_gross(ji,jj) = closing_gross(ji,jj) * zfac 
     244                  opning       (ji,jj) = opning       (ji,jj) * zfac 
     245               ENDIF 
     246 
     247            END DO 
     248         END DO 
    250249 
    251250         ! correction to closing rate / opening if excessive ice removal 
    … …  
    253252         ! Reduce the closing rate if more than 100% of any ice category  
    254253         ! would be removed.  Reduce the opening rate proportionately. 
    255  
    256254         DO jl = 1, jpl 
    257255            DO jj = 1, jpj 
    258256               DO ji = 1, jpi 
    259                   IF ( a_i(ji,jj,jl) > epsi10 .AND. athorn(ji,jj,jl) > 0._wp )THEN 
    260                      w1 = athorn(ji,jj,jl) * closing_gross(ji,jj) * rdt_ice 
    261                      IF ( w1  >  a_i(ji,jj,jl) ) THEN 
    262                         tmpfac = a_i(ji,jj,jl) / w1 
    263                         closing_gross(ji,jj) = closing_gross(ji,jj) * tmpfac 
    264                         opning       (ji,jj) = opning       (ji,jj) * tmpfac 
    265                      ENDIF 
     257                  za = athorn(ji,jj,jl) * closing_gross(ji,jj) * rdt_ice 
     258                  IF( za  >  epsi20 ) THEN 
     259                     zfac = MIN( 1._wp, a_i(ji,jj,jl) / za ) 
     260                     closing_gross(ji,jj) = closing_gross(ji,jj) * zfac 
     261                     opning       (ji,jj) = opning       (ji,jj) * zfac 
    266262                  ENDIF 
    267                END DO !ji 
    268             END DO ! jj 
    269          END DO !jl 
     263               END DO 
     264            END DO 
     265         END DO 
    270266 
    271267         ! 3.3 Redistribute area, volume, and energy. 
    … …  
    276272         ! 3.4 Compute total area of ice plus open water after ridging. 
    277273         !-----------------------------------------------------------------------------! 
    278  
    279          CALL lim_itd_me_asumr 
     274         ! This is in general not equal to one because of divergence during transport 
     275         asum(:,:) = ato_i(:,:) 
     276         DO jl = 1, jpl 
     277            asum(:,:) = asum(:,:) + a_i(:,:,jl) 
     278         END DO 
    280279 
    281280         ! 3.5 Do we keep on iterating ??? 
    … …  
    288287         DO jj = 1, jpj 
    289288            DO ji = 1, jpi 
    290                IF (ABS(asum(ji,jj) - kamax ) .LT. epsi10) THEN 
     289               IF (ABS(asum(ji,jj) - kamax ) < epsi10) THEN 
    291290                  closing_net(ji,jj) = 0._wp 
    292291                  opning     (ji,jj) = 0._wp 
    … …  
    324323      ! Convert ridging rate diagnostics to correct units. 
    325324      ! Update fresh water and heat fluxes due to snow melt. 
    326  
    327       asum_error = .false.  
    328  
    329325      DO jj = 1, jpj 
    330326         DO ji = 1, jpi 
    331  
    332             IF(ABS(asum(ji,jj) - kamax) > epsi10 ) asum_error = .true. 
    333327 
    334328            dardg1dt(ji,jj) = dardg1dt(ji,jj) * r1_rdtice 
    … …  
    341335            !-----------------------------------------------------------------------------! 
    342336            wfx_snw(ji,jj) = wfx_snw(ji,jj) + msnow_mlt(ji,jj) * r1_rdtice     ! fresh water source for ocean 
    343             hfx_dyn(ji,jj) = hfx_dyn(ji,jj) + esnow_mlt(ji,jj) * unit_fac / area(ji,jj) * r1_rdtice  ! heat sink for ocean (<0, W.m-2) 
     337            hfx_dyn(ji,jj) = hfx_dyn(ji,jj) + esnow_mlt(ji,jj) * r1_rdtice     ! heat sink for ocean (<0, W.m-2) 
    344338 
    345339         END DO 
    … …  
    347341 
    348342      ! Check if there is a ridging error 
    349       DO jj = 1, jpj 
    350          DO ji = 1, jpi 
    351             IF( ABS( asum(ji,jj) - kamax)  >  epsi10 ) THEN   ! there is a bug 
    352                WRITE(numout,*) ' ' 
    353                WRITE(numout,*) ' ALERTE : Ridging error: total area = ', asum(ji,jj) 
    354                WRITE(numout,*) ' limitd_me ' 
    355                WRITE(numout,*) ' POINT : ', ji, jj 
    356                WRITE(numout,*) ' jpl, a_i, athorn ' 
    357                WRITE(numout,*) 0, ato_i(ji,jj), athorn(ji,jj,0) 
    358                DO jl = 1, jpl 
    359                   WRITE(numout,*) jl, a_i(ji,jj,jl), athorn(ji,jj,jl) 
    360                END DO 
    361             ENDIF  ! asum 
    362  
    363          END DO !ji 
    364       END DO !jj 
     343      IF( lwp ) THEN 
     344         DO jj = 1, jpj 
     345            DO ji = 1, jpi 
     346               IF( ABS( asum(ji,jj) - kamax)  >  epsi10 ) THEN   ! there is a bug 
     347                  WRITE(numout,*) ' ' 
     348                  WRITE(numout,*) ' ALERTE : Ridging error: total area = ', asum(ji,jj) 
     349                  WRITE(numout,*) ' limitd_me ' 
     350                  WRITE(numout,*) ' POINT : ', ji, jj 
     351                  WRITE(numout,*) ' jpl, a_i, athorn ' 
     352                  WRITE(numout,*) 0, ato_i(ji,jj), athorn(ji,jj,0) 
     353                  DO jl = 1, jpl 
     354                     WRITE(numout,*) jl, a_i(ji,jj,jl), athorn(ji,jj,jl) 
     355                  END DO 
     356               ENDIF 
     357            END DO 
     358         END DO 
     359      END IF 
    365360 
    366361      ! Conservation check 
    … …  
    371366      ENDIF 
    372367 
     368      CALL lim_var_agg( 1 )  
     369 
    373370      !-----------------------------------------------------------------------------! 
    374       ! 6) Updating state variables and trend terms (done in limupdate) 
     371      ! control prints 
    375372      !-----------------------------------------------------------------------------! 
    376       CALL lim_var_glo2eqv 
    377       CALL lim_itd_me_zapsmall 
    378  
    379  
    380       IF(ln_ctl) THEN     ! Control print 
     373      IF(ln_ctl) THEN  
     374         CALL lim_var_glo2eqv 
     375 
    381376         CALL prt_ctl_info(' ') 
    382377         CALL prt_ctl_info(' - Cell values : ') 
    383378         CALL prt_ctl_info('   ~~~~~~~~~~~~~ ') 
    384          CALL prt_ctl(tab2d_1=area , clinfo1=' lim_itd_me  : cell area :') 
     379         CALL prt_ctl(tab2d_1=e12t , clinfo1=' lim_itd_me  : cell area :') 
    385380         CALL prt_ctl(tab2d_1=at_i , clinfo1=' lim_itd_me  : at_i      :') 
    386381         CALL prt_ctl(tab2d_1=vt_i , clinfo1=' lim_itd_me  : vt_i      :') 
    … …  
    436431      !!---------------------------------------------------------------------- 
    437432      INTEGER, INTENT(in) ::   kstrngth    ! = 1 for Rothrock formulation, 0 for Hibler (1979) 
    438  
    439       INTEGER ::   ji,jj, jl   ! dummy loop indices 
    440       INTEGER ::   ksmooth     ! smoothing the resistance to deformation 
    441       INTEGER ::   numts_rm    ! number of time steps for the P smoothing 
    442       REAL(wp) ::   hi, zw1, zp, zdummy, zzc, z1_3   ! local scalars 
     433      INTEGER             ::   ji,jj, jl   ! dummy loop indices 
     434      INTEGER             ::   ksmooth     ! smoothing the resistance to deformation 
     435      INTEGER             ::   numts_rm    ! number of time steps for the P smoothing 
     436      REAL(wp)            ::   zhi, zp, z1_3  ! local scalars 
    443437      REAL(wp), POINTER, DIMENSION(:,:) ::   zworka   ! temporary array used here 
    444438      !!---------------------------------------------------------------------- 
    … …  
    466460                  ! 
    467461                  IF( a_i(ji,jj,jl) > epsi10 .AND. athorn(ji,jj,jl) > 0._wp ) THEN 
    468                      hi = v_i(ji,jj,jl) / a_i(ji,jj,jl) 
     462                     zhi = v_i(ji,jj,jl) / a_i(ji,jj,jl) 
    469463                     !---------------------------- 
    470464                     ! PE loss from deforming ice 
    471465                     !---------------------------- 
    472                      strength(ji,jj) = strength(ji,jj) - athorn(ji,jj,jl) * hi * hi 
     466                     strength(ji,jj) = strength(ji,jj) - athorn(ji,jj,jl) * zhi * zhi 
    473467 
    474468                     !-------------------------- 
    475469                     ! PE gain from rafting ice 
    476470                     !-------------------------- 
    477                      strength(ji,jj) = strength(ji,jj) + 2._wp * araft(ji,jj,jl) * hi * hi 
     471                     strength(ji,jj) = strength(ji,jj) + 2._wp * araft(ji,jj,jl) * zhi * zhi 
    478472 
    479473                     !---------------------------- 
    480474                     ! PE gain from ridging ice 
    481475                     !---------------------------- 
    482                      strength(ji,jj) = strength(ji,jj) + aridge(ji,jj,jl)/krdg(ji,jj,jl)     & 
    483                         * z1_3 * (hrmax(ji,jj,jl)**3 - hrmin(ji,jj,jl)**3) / ( hrmax(ji,jj,jl)-hrmin(ji,jj,jl) )    
    484 !!gm Optimization:  (a**3-b**3)/(a-b) = a*a+ab+b*b   ==> less costly operations even if a**3 is replaced by a*a*a...                     
    485                   ENDIF            ! aicen > epsi10 
     476                     strength(ji,jj) = strength(ji,jj) + aridge(ji,jj,jl) / krdg(ji,jj,jl)     & 
     477                        * z1_3 * ( hrmax(ji,jj,jl)**2 + hrmin(ji,jj,jl)**2 +  hrmax(ji,jj,jl) * hrmin(ji,jj,jl) )   
     478                        !!(a**3-b**3)/(a-b) = a*a+ab+b*b                       
     479                  ENDIF 
    486480                  ! 
    487                END DO ! ji 
    488             END DO !jj 
    489          END DO !jl 
    490  
    491          zzc = Cf * Cp     ! where Cp = (g/2)*(rhow-rhoi)*(rhoi/rhow) and Cf accounts for frictional dissipation 
    492          strength(:,:) = zzc * strength(:,:) / aksum(:,:) 
    493  
     481               END DO 
     482            END DO 
     483         END DO 
     484    
     485         strength(:,:) = rn_pe_rdg * Cp * strength(:,:) / aksum(:,:) 
     486                         ! where Cp = (g/2)*(rhow-rhoi)*(rhoi/rhow) and rn_pe_rdg accounts for frictional dissipation 
    494487         ksmooth = 1 
    495488 
    … …  
    499492      ELSE                      ! kstrngth ne 1:  Hibler (1979) form 
    500493         ! 
    501          strength(:,:) = Pstar * vt_i(:,:) * EXP( - C_rhg * ( 1._wp - at_i(:,:) )  ) 
     494         strength(:,:) = rn_pstar * vt_i(:,:) * EXP( - rn_crhg * ( 1._wp - at_i(:,:) )  ) 
    502495         ! 
    503496         ksmooth = 1 
    … …  
    511504      ! CAN BE REMOVED 
    512505      ! 
    513       IF ( brinstren_swi == 1 ) THEN 
     506      IF( ln_icestr_bvf ) THEN 
    514507 
    515508         DO jj = 1, jpj 
    516509            DO ji = 1, jpi 
    517                IF ( bv_i(ji,jj) .GT. 0.0 ) THEN 
    518                   zdummy = MIN ( bv_i(ji,jj), 0.10 ) * MIN( bv_i(ji,jj), 0.10 ) 
    519                ELSE 
    520                   zdummy = 0.0 
    521                ENDIF 
    522510               strength(ji,jj) = strength(ji,jj) * exp(-5.88*SQRT(MAX(bv_i(ji,jj),0.0))) 
    523             END DO              ! j 
    524          END DO                 ! i 
     511            END DO 
     512         END DO 
    525513 
    526514      ENDIF 
    … …  
    538526         CALL lbc_lnk( strength, 'T', 1. ) 
    539527 
    540          DO jj = 2, jpj - 1 
    541             DO ji = 2, jpi - 1 
    542                IF ( ( asum(ji,jj) - ato_i(ji,jj) ) .GT. epsi10) THEN ! ice is 
    543                   ! present 
    544                   zworka(ji,jj) = 4.0 * strength(ji,jj)              & 
    545                      &          + strength(ji-1,jj) * tms(ji-1,jj) &   
    546                      &          + strength(ji+1,jj) * tms(ji+1,jj) &   
    547                      &          + strength(ji,jj-1) * tms(ji,jj-1) &   
    548                      &          + strength(ji,jj+1) * tms(ji,jj+1)     
    549  
    550                   zw1 = 4.0 + tms(ji-1,jj) + tms(ji+1,jj) + tms(ji,jj-1) + tms(ji,jj+1) 
    551                   zworka(ji,jj) = zworka(ji,jj) / zw1 
     528         DO jj = 2, jpjm1 
     529            DO ji = 2, jpim1 
     530               IF ( ( asum(ji,jj) - ato_i(ji,jj) ) > 0._wp) THEN  
     531                  zworka(ji,jj) = ( 4.0 * strength(ji,jj)              & 
     532                     &                  + strength(ji-1,jj) * tmask(ji-1,jj,1) + strength(ji+1,jj) * tmask(ji+1,jj,1) &   
     533                     &                  + strength(ji,jj-1) * tmask(ji,jj-1,1) + strength(ji,jj+1) * tmask(ji,jj+1,1) & 
     534                     &            ) / ( 4.0 + tmask(ji-1,jj,1) + tmask(ji+1,jj,1) + tmask(ji,jj-1,1) + tmask(ji,jj+1,1) ) 
    552535               ELSE 
    553536                  zworka(ji,jj) = 0._wp 
    … …  
    556539         END DO 
    557540 
    558          DO jj = 2, jpj - 1 
    559             DO ji = 2, jpi - 1 
     541         DO jj = 2, jpjm1 
     542            DO ji = 2, jpim1 
    560543               strength(ji,jj) = zworka(ji,jj) 
    561544            END DO 
    … …  
    563546         CALL lbc_lnk( strength, 'T', 1. ) 
    564547 
    565       ENDIF ! ksmooth 
     548      ENDIF 
    566549 
    567550      !-------------------- 
    … …  
    580563         DO jj = 1, jpj - 1 
    581564            DO ji = 1, jpi - 1 
    582                IF ( ( asum(ji,jj) - ato_i(ji,jj) ) .GT. epsi10) THEN       ! ice is present 
     565               IF ( ( asum(ji,jj) - ato_i(ji,jj) ) > 0._wp) THEN  
    583566                  numts_rm = 1 ! number of time steps for the running mean 
    584                   IF ( strp1(ji,jj) .GT. 0.0 ) numts_rm = numts_rm + 1 
    585                   IF ( strp2(ji,jj) .GT. 0.0 ) numts_rm = numts_rm + 1 
     567                  IF ( strp1(ji,jj) > 0.0 ) numts_rm = numts_rm + 1 
     568                  IF ( strp2(ji,jj) > 0.0 ) numts_rm = numts_rm + 1 
    586569                  zp = ( strength(ji,jj) + strp1(ji,jj) + strp2(ji,jj) ) / numts_rm 
    587570                  strp2(ji,jj) = strp1(ji,jj) 
    … …  
    612595      !!---------------------------------------------------------------------! 
    613596      INTEGER ::   ji,jj, jl    ! dummy loop indices 
    614       REAL(wp) ::   Gstari, astari, hi, hrmean, zdummy   ! local scalar 
     597      REAL(wp) ::   Gstari, astari, zhi, hrmean, zdummy   ! local scalar 
    615598      REAL(wp), POINTER, DIMENSION(:,:)   ::   zworka    ! temporary array used here 
    616599      REAL(wp), POINTER, DIMENSION(:,:,:) ::   Gsum      ! Gsum(n) = sum of areas in categories 0 to n 
    … …  
    620603      CALL wrk_alloc( jpi,jpj,jpl+2, Gsum, kkstart = -1 ) 
    621604 
    622       Gstari     = 1.0/Gstar     
    623       astari     = 1.0/astar     
     605      Gstari     = 1.0/rn_gstar     
     606      astari     = 1.0/rn_astar     
    624607      aksum(:,:)    = 0.0 
    625608      athorn(:,:,:) = 0.0 
    … …  
    632615 
    633616      !     ! Zero out categories with very small areas 
    634       CALL lim_itd_me_zapsmall 
     617      CALL lim_var_zapsmall 
    635618 
    636619      !------------------------------------------------------------------------------! 
    … …  
    639622 
    640623      ! Compute total area of ice plus open water. 
    641       CALL lim_itd_me_asumr 
    642       ! This is in general not equal to one  
    643       ! because of divergence during transport 
     624      ! This is in general not equal to one because of divergence during transport 
     625      asum(:,:) = ato_i(:,:) 
     626      DO jl = 1, jpl 
     627         asum(:,:) = asum(:,:) + a_i(:,:,jl) 
     628      END DO 
    644629 
    645630      ! Compute cumulative thickness distribution function 
    … …  
    649634 
    650635      Gsum(:,:,-1) = 0._wp 
    651  
    652       DO jj = 1, jpj 
    653          DO ji = 1, jpi 
    654             IF( ato_i(ji,jj) > epsi10 ) THEN   ;   Gsum(ji,jj,0) = ato_i(ji,jj) 
    655             ELSE                               ;   Gsum(ji,jj,0) = 0._wp 
    656             ENDIF 
    657          END DO 
    658       END DO 
     636      Gsum(:,:,0 ) = ato_i(:,:) 
    659637 
    660638      ! for each value of h, you have to add ice concentration then 
    661639      DO jl = 1, jpl 
    662          DO jj = 1, jpj  
    663             DO ji = 1, jpi 
    664                IF( a_i(ji,jj,jl) .GT. epsi10 ) THEN   ;   Gsum(ji,jj,jl) = Gsum(ji,jj,jl-1) + a_i(ji,jj,jl) 
    665                ELSE                                   ;   Gsum(ji,jj,jl) = Gsum(ji,jj,jl-1) 
    666                ENDIF 
    667             END DO 
    668          END DO 
     640         Gsum(:,:,jl) = Gsum(:,:,jl-1) + a_i(:,:,jl) 
    669641      END DO 
    670642 
    … …  
    687659      !----------------------------------------------------------------- 
    688660 
    689       IF( partfun_swi == 0 ) THEN       !--- Linear formulation (Thorndike et al., 1975) 
     661      IF( nn_partfun == 0 ) THEN       !--- Linear formulation (Thorndike et al., 1975) 
    690662         DO jl = 0, jpl     
    691663            DO jj = 1, jpj  
    692664               DO ji = 1, jpi 
    693                   IF( Gsum(ji,jj,jl) < Gstar) THEN 
    694                      athorn(ji,jj,jl) = Gstari * (Gsum(ji,jj,jl)-Gsum(ji,jj,jl-1)) * & 
    695                         (2.0 - (Gsum(ji,jj,jl-1)+Gsum(ji,jj,jl))*Gstari) 
    696                   ELSEIF (Gsum(ji,jj,jl-1) < Gstar) THEN 
    697                      athorn(ji,jj,jl) = Gstari * (Gstar-Gsum(ji,jj,jl-1)) *  & 
    698                         (2.0 - (Gsum(ji,jj,jl-1)+Gstar)*Gstari) 
     665                  IF( Gsum(ji,jj,jl) < rn_gstar) THEN 
     666                     athorn(ji,jj,jl) = Gstari * ( Gsum(ji,jj,jl) - Gsum(ji,jj,jl-1) ) * & 
     667                        &                        ( 2.0 - (Gsum(ji,jj,jl-1) + Gsum(ji,jj,jl) ) * Gstari ) 
     668                  ELSEIF (Gsum(ji,jj,jl-1) < rn_gstar) THEN 
     669                     athorn(ji,jj,jl) = Gstari * ( rn_gstar - Gsum(ji,jj,jl-1) ) *  & 
     670                        &                        ( 2.0 - ( Gsum(ji,jj,jl-1) + rn_gstar ) * Gstari ) 
    699671                  ELSE 
    700672                     athorn(ji,jj,jl) = 0.0 
    701673                  ENDIF 
    702                END DO ! ji 
    703             END DO ! jj 
    704          END DO ! jl  
     674               END DO 
     675            END DO 
     676         END DO 
    705677 
    706678      ELSE                             !--- Exponential, more stable formulation (Lipscomb et al, 2007) 
    707679         !                         
    708680         zdummy = 1._wp / ( 1._wp - EXP(-astari) )        ! precompute exponential terms using Gsum as a work array 
    709  
    710681         DO jl = -1, jpl 
    711682            Gsum(:,:,jl) = EXP( -Gsum(:,:,jl) * astari ) * zdummy 
    712          END DO !jl 
     683         END DO 
    713684         DO jl = 0, jpl 
    714685             athorn(:,:,jl) = Gsum(:,:,jl-1) - Gsum(:,:,jl) 
    715686         END DO 
    716687         ! 
    717       ENDIF ! partfun_swi 
    718  
    719       IF( raft_swi == 1 ) THEN      ! Ridging and rafting ice participation functions 
     688      ENDIF 
     689 
     690      IF( ln_rafting ) THEN      ! Ridging and rafting ice participation functions 
    720691         ! 
    721692         DO jl = 1, jpl 
    722693            DO jj = 1, jpj  
    723694               DO ji = 1, jpi 
    724                   IF ( athorn(ji,jj,jl) .GT. 0._wp ) THEN 
     695                  IF ( athorn(ji,jj,jl) > 0._wp ) THEN 
    725696!!gm  TANH( -X ) = - TANH( X )  so can be computed only 1 time.... 
    726                      aridge(ji,jj,jl) = ( TANH (  Craft * ( ht_i(ji,jj,jl) - hparmeter ) ) + 1.0 ) * 0.5 * athorn(ji,jj,jl) 
    727                      araft (ji,jj,jl) = ( TANH ( -Craft * ( ht_i(ji,jj,jl) - hparmeter ) ) + 1.0 ) * 0.5 * athorn(ji,jj,jl) 
     697                     aridge(ji,jj,jl) = ( TANH (  rn_craft * ( ht_i(ji,jj,jl) - rn_hraft ) ) + 1.0 ) * 0.5 * athorn(ji,jj,jl) 
     698                     araft (ji,jj,jl) = ( TANH ( -rn_craft * ( ht_i(ji,jj,jl) - rn_hraft ) ) + 1.0 ) * 0.5 * athorn(ji,jj,jl) 
    728699                     IF ( araft(ji,jj,jl) < epsi06 )   araft(ji,jj,jl)  = 0._wp 
    729700                     aridge(ji,jj,jl) = MAX( athorn(ji,jj,jl) - araft(ji,jj,jl), 0.0 ) 
    730                   ENDIF ! athorn 
    731                END DO ! ji 
    732             END DO ! jj 
    733          END DO ! jl 
    734  
    735       ELSE  ! raft_swi = 0 
     701                  ENDIF 
     702               END DO 
     703            END DO 
     704         END DO 
     705 
     706      ELSE 
    736707         ! 
    737708         DO jl = 1, jpl 
    … …  
    741712      ENDIF 
    742713 
    743       IF ( raft_swi == 1 ) THEN 
    744  
    745          IF( MAXVAL(aridge + araft - athorn(:,:,1:jpl)) .GT. epsi10 ) THEN 
     714      IF( ln_rafting ) THEN 
     715 
     716         IF( MAXVAL(aridge + araft - athorn(:,:,1:jpl)) > epsi10 .AND. lwp ) THEN 
    746717            DO jl = 1, jpl 
    747718               DO jj = 1, jpj 
    748719                  DO ji = 1, jpi 
    749                      IF ( aridge(ji,jj,jl) + araft(ji,jj,jl) - athorn(ji,jj,jl) .GT. epsi10 ) THEN 
     720                     IF ( aridge(ji,jj,jl) + araft(ji,jj,jl) - athorn(ji,jj,jl) > epsi10 ) THEN 
    750721                        WRITE(numout,*) ' ALERTE 96 : wrong participation function ... ' 
    751722                        WRITE(numout,*) ' ji, jj, jl : ', ji, jj, jl 
    … …  
    793764            DO ji = 1, jpi 
    794765 
    795                IF (a_i(ji,jj,jl) .GT. epsi10 .AND. athorn(ji,jj,jl) .GT. 0.0 ) THEN 
    796                   hi = v_i(ji,jj,jl) / a_i(ji,jj,jl) 
    797                   hrmean          = MAX(SQRT(Hstar*hi), hi*krdgmin) 
    798                   hrmin(ji,jj,jl) = MIN(2.0*hi, 0.5*(hrmean + hi)) 
     766               IF (a_i(ji,jj,jl) > epsi10 .AND. athorn(ji,jj,jl) > 0.0 ) THEN 
     767                  zhi = v_i(ji,jj,jl) / a_i(ji,jj,jl) 
     768                  hrmean          = MAX(SQRT(rn_hstar*zhi), zhi*krdgmin) 
     769                  hrmin(ji,jj,jl) = MIN(2.0*zhi, 0.5*(hrmean + zhi)) 
    799770                  hrmax(ji,jj,jl) = 2.0*hrmean - hrmin(ji,jj,jl) 
    800                   hraft(ji,jj,jl) = kraft*hi 
    801                   krdg(ji,jj,jl)  = hrmean / hi 
     771                  hraft(ji,jj,jl) = kraft*zhi 
     772                  krdg(ji,jj,jl)  = hrmean / zhi 
    802773               ELSE 
    803774                  hraft(ji,jj,jl) = 0.0 
    … …  
    807778               ENDIF 
    808779 
    809             END DO ! ji 
    810          END DO ! jj 
    811       END DO ! jl 
     780            END DO 
     781         END DO 
     782      END DO 
    812783 
    813784      ! Normalization factor : aksum, ensures mass conservation 
    … …  
    841812      LOGICAL, PARAMETER ::   l_conservation_check = .true.  ! if true, check conservation (useful for debugging) 
    842813      ! 
    843       LOGICAL ::   neg_ato_i      ! flag for ato_i(i,j) < -puny 
    844       LOGICAL ::   large_afrac    ! flag for afrac > 1 
    845       LOGICAL ::   large_afrft    ! flag for afrac > 1 
    846814      INTEGER ::   ji, jj, jl, jl1, jl2, jk   ! dummy loop indices 
    847815      INTEGER ::   ij                ! horizontal index, combines i and j loops 
    848816      INTEGER ::   icells            ! number of cells with aicen > puny 
    849       REAL(wp) ::   hL, hR, farea, zdummy, zdummy0, ztmelts    ! left and right limits of integration 
    850       REAL(wp) ::   zsstK            ! SST in Kelvin 
     817      REAL(wp) ::   hL, hR, farea, ztmelts    ! left and right limits of integration 
    851818 
    852819      INTEGER , POINTER, DIMENSION(:) ::   indxi, indxj   ! compressed indices 
    … …  
    864831      REAL(wp), POINTER, DIMENSION(:,:) ::   ardg1 , ardg2    ! area of ice ridged & new ridges 
    865832      REAL(wp), POINTER, DIMENSION(:,:) ::   vsrdg , esrdg    ! snow volume & energy of ridging ice 
    866       REAL(wp), POINTER, DIMENSION(:,:) ::   oirdg1, oirdg2   ! areal age content of ridged & rifging ice 
    867833      REAL(wp), POINTER, DIMENSION(:,:) ::   dhr   , dhr2     ! hrmax - hrmin  &  hrmax^2 - hrmin^2 
    868834 
    … …  
    873839      REAL(wp), POINTER, DIMENSION(:,:) ::   srdg2   ! sal*volume of new ridges 
    874840      REAL(wp), POINTER, DIMENSION(:,:) ::   smsw    ! sal*volume of water trapped into ridges 
     841      REAL(wp), POINTER, DIMENSION(:,:) ::   oirdg1, oirdg2   ! ice age of ice ridged 
    875842 
    876843      REAL(wp), POINTER, DIMENSION(:,:) ::   afrft            ! fraction of category area rafted 
    … …  
    878845      REAL(wp), POINTER, DIMENSION(:,:) ::   virft , vsrft    ! ice & snow volume of rafting ice 
    879846      REAL(wp), POINTER, DIMENSION(:,:) ::   esrft , smrft    ! snow energy & salinity of rafting ice 
    880       REAL(wp), POINTER, DIMENSION(:,:) ::   oirft1, oirft2   ! areal age content of rafted ice & rafting ice 
     847      REAL(wp), POINTER, DIMENSION(:,:) ::   oirft1, oirft2   ! ice age of ice rafted 
    881848 
    882849      REAL(wp), POINTER, DIMENSION(:,:,:) ::   eirft      ! ice energy of rafting ice 
    … …  
    886853      !!---------------------------------------------------------------------- 
    887854 
    888       CALL wrk_alloc( (jpi+1)*(jpj+1),      indxi, indxj ) 
    889       CALL wrk_alloc( jpi, jpj,             vice_init, vice_final, eice_init, eice_final ) 
    890       CALL wrk_alloc( jpi, jpj,             afrac, fvol , ardg1, ardg2, vsrdg, esrdg, oirdg1, oirdg2, dhr, dhr2 ) 
    891       CALL wrk_alloc( jpi, jpj,             vrdg1, vrdg2, vsw  , srdg1, srdg2, smsw ) 
    892       CALL wrk_alloc( jpi, jpj,             afrft, arft1, arft2, virft, vsrft, esrft, smrft, oirft1, oirft2 ) 
    893       CALL wrk_alloc( jpi, jpj, jpl,        aicen_init, vicen_init, vsnwn_init, esnwn_init, smv_i_init, oa_i_init ) 
    894       CALL wrk_alloc( jpi, jpj, nlay_i+1,      eirft, erdg1, erdg2, ersw ) 
    895       CALL wrk_alloc( jpi, jpj, nlay_i+1, jpl, eicen_init ) 
     855      CALL wrk_alloc( (jpi+1)*(jpj+1),       indxi, indxj ) 
     856      CALL wrk_alloc( jpi, jpj,              vice_init, vice_final, eice_init, eice_final ) 
     857      CALL wrk_alloc( jpi, jpj,              afrac, fvol , ardg1, ardg2, vsrdg, esrdg, dhr, dhr2 ) 
     858      CALL wrk_alloc( jpi, jpj,              vrdg1, vrdg2, vsw  , srdg1, srdg2, smsw, oirdg1, oirdg2 ) 
     859      CALL wrk_alloc( jpi, jpj,              afrft, arft1, arft2, virft, vsrft, esrft, smrft, oirft1, oirft2 ) 
     860      CALL wrk_alloc( jpi, jpj, jpl,         aicen_init, vicen_init, vsnwn_init, esnwn_init, smv_i_init, oa_i_init ) 
     861      CALL wrk_alloc( jpi, jpj, nlay_i,      eirft, erdg1, erdg2, ersw ) 
     862      CALL wrk_alloc( jpi, jpj, nlay_i, jpl, eicen_init ) 
    896863 
    897864      ! Conservation check 
    … …  
    901868         CALL lim_column_sum        (jpl,    v_i,       vice_init ) 
    902869         CALL lim_column_sum_energy (jpl, nlay_i,  e_i, eice_init ) 
    903          DO ji = mi0(jiindx), mi1(jiindx) 
    904             DO jj = mj0(jjindx), mj1(jjindx) 
     870         DO ji = mi0(iiceprt), mi1(iiceprt) 
     871            DO jj = mj0(jiceprt), mj1(jiceprt) 
    905872               WRITE(numout,*) ' vice_init  : ', vice_init(ji,jj) 
    906873               WRITE(numout,*) ' eice_init  : ', eice_init(ji,jj) 
    … …  
    912879      ! 1) Compute change in open water area due to closing and opening. 
    913880      !------------------------------------------------------------------------------- 
    914  
    915       neg_ato_i = .false. 
    916  
    917881      DO jj = 1, jpj 
    918882         DO ji = 1, jpi 
    919883            ato_i(ji,jj) = ato_i(ji,jj) - athorn(ji,jj,0) * closing_gross(ji,jj) * rdt_ice        & 
    920884               &                        + opning(ji,jj)                          * rdt_ice 
    921             IF( ato_i(ji,jj) < -epsi10 ) THEN 
    922                neg_ato_i = .TRUE. 
    923             ELSEIF( ato_i(ji,jj) < 0._wp ) THEN    ! roundoff error 
     885            IF    ( ato_i(ji,jj) < -epsi10 ) THEN    ! there is a bug 
     886               IF(lwp)   WRITE(numout,*) 'Ridging error: ato_i < 0 -- ato_i : ',ato_i(ji,jj) 
     887            ELSEIF( ato_i(ji,jj) < 0._wp   ) THEN    ! roundoff error 
    924888               ato_i(ji,jj) = 0._wp 
    925889            ENDIF 
    926          END DO !jj 
    927       END DO !ji 
    928  
    929       ! if negative open water area alert it 
    930       IF( neg_ato_i ) THEN       ! there is a bug 
    931          DO jj = 1, jpj  
    932             DO ji = 1, jpi 
    933                IF( ato_i(ji,jj) < -epsi10 ) THEN  
    934                   WRITE(numout,*) ''   
    935                   WRITE(numout,*) 'Ridging error: ato_i < 0' 
    936                   WRITE(numout,*) 'ato_i : ', ato_i(ji,jj) 
    937                ENDIF               ! ato_i < -epsi10 
    938             END DO 
    939          END DO 
    940       ENDIF 
     890         END DO 
     891      END DO 
    941892 
    942893      !----------------------------------------------------------------- 
    943894      ! 2) Save initial state variables 
    944895      !----------------------------------------------------------------- 
    945  
    946       DO jl = 1, jpl 
    947          aicen_init(:,:,jl) = a_i(:,:,jl) 
    948          vicen_init(:,:,jl) = v_i(:,:,jl) 
    949          vsnwn_init(:,:,jl) = v_s(:,:,jl) 
    950          ! 
    951          smv_i_init(:,:,jl) = smv_i(:,:,jl) 
    952          oa_i_init (:,:,jl) = oa_i (:,:,jl) 
    953       END DO !jl 
    954  
    955       esnwn_init(:,:,:) = e_s(:,:,1,:) 
    956  
    957       DO jl = 1, jpl   
    958          DO jk = 1, nlay_i 
    959             eicen_init(:,:,jk,jl) = e_i(:,:,jk,jl) 
    960          END DO 
    961       END DO 
     896      aicen_init(:,:,:)   = a_i  (:,:,:) 
     897      vicen_init(:,:,:)   = v_i  (:,:,:) 
     898      vsnwn_init(:,:,:)   = v_s  (:,:,:) 
     899      smv_i_init(:,:,:)   = smv_i(:,:,:) 
     900      esnwn_init(:,:,:)   = e_s  (:,:,1,:) 
     901      eicen_init(:,:,:,:) = e_i  (:,:,:,:) 
     902      oa_i_init (:,:,:)   = oa_i (:,:,:) 
    962903 
    963904      ! 
    … …  
    982923                  indxi(icells) = ji 
    983924                  indxj(icells) = jj 
    984                ENDIF ! test on a_icen_init  
    985             END DO ! ji 
    986          END DO ! jj 
    987  
    988          large_afrac = .false. 
    989          large_afrft = .false. 
    990  
    991 !CDIR NODEP 
     925               ENDIF 
     926            END DO 
     927         END DO 
     928 
    992929         DO ij = 1, icells 
    993930            ji = indxi(ij) 
    … …  
    1003940            arft2(ji,jj) = arft1(ji,jj) / kraft 
    1004941 
    1005             oirdg1(ji,jj)= aridge(ji,jj,jl1)*closing_gross(ji,jj)*rdt_ice 
    1006             oirft1(ji,jj)= araft (ji,jj,jl1)*closing_gross(ji,jj)*rdt_ice 
    1007             oirdg2(ji,jj)= oirdg1(ji,jj) / krdg(ji,jj,jl1) 
    1008             oirft2(ji,jj)= oirft1(ji,jj) / kraft 
    1009  
    1010942            !--------------------------------------------------------------- 
    1011943            ! 3.3) Compute ridging /rafting fractions, make sure afrac <=1  
    … …  
    1015947            afrft(ji,jj) = arft1(ji,jj) / aicen_init(ji,jj,jl1) !rafting 
    1016948 
    1017             IF (afrac(ji,jj) > kamax + epsi10) THEN  !riging 
    1018                large_afrac = .true. 
    1019             ELSEIF (afrac(ji,jj) > kamax) THEN  ! roundoff error 
     949            IF( afrac(ji,jj) > kamax + epsi10 ) THEN  ! there is a bug 
     950               IF(lwp)   WRITE(numout,*) ' ardg > a_i -- ardg, aicen_init : ', ardg1(ji,jj), aicen_init(ji,jj,jl1) 
     951            ELSEIF( afrac(ji,jj) > kamax ) THEN       ! roundoff error 
    1020952               afrac(ji,jj) = kamax 
    1021953            ENDIF 
    1022             IF (afrft(ji,jj) > kamax + epsi10) THEN !rafting 
    1023                large_afrft = .true. 
    1024             ELSEIF (afrft(ji,jj) > kamax) THEN  ! roundoff error 
     954 
     955            IF( afrft(ji,jj) > kamax + epsi10 ) THEN ! there is a bug 
     956               IF(lwp)   WRITE(numout,*) ' arft > a_i -- arft, aicen_init : ', arft1(ji,jj), aicen_init(ji,jj,jl1)  
     957            ELSEIF( afrft(ji,jj) > kamax) THEN       ! roundoff error 
    1025958               afrft(ji,jj) = kamax 
    1026959            ENDIF 
    … …  
    1031964            !-------------------------------------------------------------------------- 
    1032965            vrdg1(ji,jj) = vicen_init(ji,jj,jl1) * afrac(ji,jj) 
    1033             vrdg2(ji,jj) = vrdg1(ji,jj) * ( 1. + ridge_por ) 
    1034             vsw  (ji,jj) = vrdg1(ji,jj) * ridge_por 
    1035  
    1036             vsrdg(ji,jj) = vsnwn_init(ji,jj,jl1) * afrac(ji,jj) 
    1037             esrdg(ji,jj) = esnwn_init(ji,jj,jl1) * afrac(ji,jj) 
    1038             srdg1(ji,jj) = smv_i_init(ji,jj,jl1) * afrac(ji,jj) 
    1039             srdg2(ji,jj) = smv_i_init(ji,jj,jl1) * afrac(ji,jj) !! MV HC 2014 this line seems useless 
     966            vrdg2(ji,jj) = vrdg1(ji,jj) * ( 1. + rn_por_rdg ) 
     967            vsw  (ji,jj) = vrdg1(ji,jj) * rn_por_rdg 
     968 
     969            vsrdg (ji,jj) = vsnwn_init(ji,jj,jl1) * afrac(ji,jj) 
     970            esrdg (ji,jj) = esnwn_init(ji,jj,jl1) * afrac(ji,jj) 
     971            srdg1 (ji,jj) = smv_i_init(ji,jj,jl1) * afrac(ji,jj) 
     972            oirdg1(ji,jj) = oa_i_init (ji,jj,jl1) * afrac(ji,jj) 
     973            oirdg2(ji,jj) = oa_i_init (ji,jj,jl1) * afrac(ji,jj) / krdg(ji,jj,jl1)  
    1040974 
    1041975            ! rafting volumes, heat contents ... 
    1042             virft(ji,jj) = vicen_init(ji,jj,jl1) * afrft(ji,jj) 
    1043             vsrft(ji,jj) = vsnwn_init(ji,jj,jl1) * afrft(ji,jj) 
    1044             esrft(ji,jj) = esnwn_init(ji,jj,jl1) * afrft(ji,jj) 
    1045             smrft(ji,jj) = smv_i_init(ji,jj,jl1) * afrft(ji,jj)  
     976            virft (ji,jj) = vicen_init(ji,jj,jl1) * afrft(ji,jj) 
     977            vsrft (ji,jj) = vsnwn_init(ji,jj,jl1) * afrft(ji,jj) 
     978            esrft (ji,jj) = esnwn_init(ji,jj,jl1) * afrft(ji,jj) 
     979            smrft (ji,jj) = smv_i_init(ji,jj,jl1) * afrft(ji,jj)  
     980            oirft1(ji,jj) = oa_i_init (ji,jj,jl1) * afrft(ji,jj)  
     981            oirft2(ji,jj) = oa_i_init (ji,jj,jl1) * afrft(ji,jj) / kraft  
    1046982 
    1047983            ! substract everything 
    1048             a_i(ji,jj,jl1)   = a_i(ji,jj,jl1)   - ardg1(ji,jj)  - arft1(ji,jj) 
    1049             v_i(ji,jj,jl1)   = v_i(ji,jj,jl1)   - vrdg1(ji,jj)  - virft(ji,jj) 
    1050             v_s(ji,jj,jl1)   = v_s(ji,jj,jl1)   - vsrdg(ji,jj)  - vsrft(ji,jj) 
    1051             e_s(ji,jj,1,jl1) = e_s(ji,jj,1,jl1) - esrdg(ji,jj)  - esrft(ji,jj) 
     984            a_i(ji,jj,jl1)   = a_i(ji,jj,jl1)   - ardg1 (ji,jj) - arft1 (ji,jj) 
     985            v_i(ji,jj,jl1)   = v_i(ji,jj,jl1)   - vrdg1 (ji,jj) - virft (ji,jj) 
     986            v_s(ji,jj,jl1)   = v_s(ji,jj,jl1)   - vsrdg (ji,jj) - vsrft (ji,jj) 
     987            e_s(ji,jj,1,jl1) = e_s(ji,jj,1,jl1) - esrdg (ji,jj) - esrft (ji,jj) 
     988            smv_i(ji,jj,jl1) = smv_i(ji,jj,jl1) - srdg1 (ji,jj) - smrft (ji,jj) 
    1052989            oa_i(ji,jj,jl1)  = oa_i(ji,jj,jl1)  - oirdg1(ji,jj) - oirft1(ji,jj) 
    1053             smv_i(ji,jj,jl1) = smv_i(ji,jj,jl1) - srdg1(ji,jj)  - smrft(ji,jj) 
    1054990 
    1055991            !----------------------------------------------------------------- 
    1056992            ! 3.5) Compute properties of new ridges 
    1057993            !----------------------------------------------------------------- 
    1058             !------------- 
     994            !--------- 
    1059995            ! Salinity 
    1060             !------------- 
     996            !--------- 
    1061997            smsw(ji,jj)  = vsw(ji,jj) * sss_m(ji,jj)                      ! salt content of seawater frozen in voids !! MV HC2014 
    1062998            srdg2(ji,jj) = srdg1(ji,jj) + smsw(ji,jj)                     ! salt content of new ridge 
    1063999 
    1064             !srdg2(ji,jj) = MIN( s_i_max * vrdg2(ji,jj) , zsrdg2 )         ! impose a maximum salinity 
     1000            !srdg2(ji,jj) = MIN( rn_simax * vrdg2(ji,jj) , zsrdg2 )         ! impose a maximum salinity 
    10651001             
    10661002            sfx_dyn(ji,jj) = sfx_dyn(ji,jj) - smsw(ji,jj) * rhoic * r1_rdtice 
    1067             wfx_dyn(ji,jj) = wfx_dyn(ji,jj) - vsw (ji,jj) * rhoic * r1_rdtice   ! gurvan: increase in ice volume du to seawater frozen in voids              
     1003            wfx_dyn(ji,jj) = wfx_dyn(ji,jj) - vsw (ji,jj) * rhoic * r1_rdtice   ! increase in ice volume du to seawater frozen in voids              
    10681004 
    10691005            !------------------------------------             
    … …  
    10911027            !           ij looping 1-icells 
    10921028 
    1093             msnow_mlt(ji,jj) = msnow_mlt(ji,jj) + rhosn*vsrdg(ji,jj)*(1.0-fsnowrdg)   &   ! rafting included 
    1094                &                                + rhosn*vsrft(ji,jj)*(1.0-fsnowrft) 
    1095  
    1096             ! in 1e-9 Joules (same as e_s) 
    1097             esnow_mlt(ji,jj) = esnow_mlt(ji,jj) - esrdg(ji,jj)*(1.0-fsnowrdg)         &   !rafting included 
    1098                &                                - esrft(ji,jj)*(1.0-fsnowrft)           
     1029            msnow_mlt(ji,jj) = msnow_mlt(ji,jj) + rhosn*vsrdg(ji,jj)*(1.0-rn_fsnowrdg)   &   ! rafting included 
     1030               &                                + rhosn*vsrft(ji,jj)*(1.0-rn_fsnowrft) 
     1031 
     1032            ! in J/m2 (same as e_s) 
     1033            esnow_mlt(ji,jj) = esnow_mlt(ji,jj) - esrdg(ji,jj)*(1.0-rn_fsnowrdg)         &   !rafting included 
     1034               &                                - esrft(ji,jj)*(1.0-rn_fsnowrft)           
    10991035 
    11001036            !----------------------------------------------------------------- 
    … …  
    11091045            dhr2(ji,jj) = hrmax(ji,jj,jl1) * hrmax(ji,jj,jl1) - hrmin(ji,jj,jl1) * hrmin(ji,jj,jl1) 
    11101046 
    1111          END DO                 ! ij 
     1047         END DO 
    11121048 
    11131049         !-------------------------------------------------------------------- 
    … …  
    11161052         !-------------------------------------------------------------------- 
    11171053         DO jk = 1, nlay_i 
    1118 !CDIR NODEP 
    11191054            DO ij = 1, icells 
    11201055               ji = indxi(ij) 
    … …  
    11281063               ! enthalpy of the trapped seawater (J/m2, >0) 
    11291064               ! clem: if sst>0, then ersw <0 (is that possible?) 
    1130                zsstK  = sst_m(ji,jj) + rt0 
    1131                ersw(ji,jj,jk)   = - rhoic * vsw(ji,jj) * rcp * ( zsstK - rt0 ) / REAL( nlay_i ) 
     1065               ersw(ji,jj,jk)   = - rhoic * vsw(ji,jj) * rcp * sst_m(ji,jj) * r1_nlay_i 
    11321066 
    11331067               ! heat flux to the ocean 
    11341068               hfx_dyn(ji,jj) = hfx_dyn(ji,jj) + ersw(ji,jj,jk) * r1_rdtice  ! > 0 [W.m-2] ocean->ice flux  
    11351069 
    1136                ! Correct dimensions to avoid big values 
    1137                ersw(ji,jj,jk)   = ersw(ji,jj,jk) / unit_fac 
    1138  
    1139                ! Mutliply by ice volume, and divide by number of layers to get heat content in 1.e9 J 
    1140                ! it is added to sea ice because the sign convention is the opposite of the sign convention for the ocean  
    1141                !! MV HC 2014 
    1142                ersw (ji,jj,jk)  = ersw(ji,jj,jk) * area(ji,jj) 
    1143  
     1070               ! it is added to sea ice because the sign convention is the opposite of the sign convention for the ocean 
    11441071               erdg2(ji,jj,jk)  = erdg1(ji,jj,jk) + ersw(ji,jj,jk) 
    11451072 
    1146             END DO ! ij 
    1147          END DO !jk 
     1073            END DO 
     1074         END DO 
    11481075 
    11491076 
    11501077         IF( con_i ) THEN 
    11511078            DO jk = 1, nlay_i 
    1152 !CDIR NODEP 
    11531079               DO ij = 1, icells 
    11541080                  ji = indxi(ij) 
    11551081                  jj = indxj(ij) 
    11561082                  eice_init(ji,jj) = eice_init(ji,jj) + erdg2(ji,jj,jk) - erdg1(ji,jj,jk) 
    1157                END DO ! ij 
    1158             END DO !jk 
    1159          ENDIF 
    1160  
    1161          IF( large_afrac ) THEN   ! there is a bug 
    1162 !CDIR NODEP 
    1163             DO ij = 1, icells 
    1164                ji = indxi(ij) 
    1165                jj = indxj(ij) 
    1166                IF( afrac(ji,jj) > kamax + epsi10 ) THEN  
    1167                   WRITE(numout,*) '' 
    1168                   WRITE(numout,*) ' ardg > a_i' 
    1169                   WRITE(numout,*) ' ardg, aicen_init : ', ardg1(ji,jj), aicen_init(ji,jj,jl1) 
    1170                ENDIF 
    1171             END DO 
    1172          ENDIF 
    1173          IF( large_afrft ) THEN  ! there is a bug 
    1174 !CDIR NODEP 
    1175             DO ij = 1, icells 
    1176                ji = indxi(ij) 
    1177                jj = indxj(ij) 
    1178                IF( afrft(ji,jj) > kamax + epsi10 ) THEN  
    1179                   WRITE(numout,*) '' 
    1180                   WRITE(numout,*) ' arft > a_i' 
    1181                   WRITE(numout,*) ' arft, aicen_init : ', arft1(ji,jj), aicen_init(ji,jj,jl1) 
    1182                ENDIF 
     1083               END DO 
    11831084            END DO 
    11841085         ENDIF 
    … …  
    11901091         DO jl2  = 1, jpl  
    11911092            ! over categories to which ridged ice is transferred 
    1192 !CDIR NODEP 
    11931093            DO ij = 1, icells 
    11941094               ji = indxi(ij) 
    … …  
    11991099               ! Transfer area, volume, and energy accordingly. 
    12001100 
    1201                IF( hrmin(ji,jj,jl1) >= hi_max(jl2)  .OR.        & 
    1202                    hrmax(ji,jj,jl1) <= hi_max(jl2-1) ) THEN 
     1101               IF( hrmin(ji,jj,jl1) >= hi_max(jl2) .OR. hrmax(ji,jj,jl1) <= hi_max(jl2-1) ) THEN 
    12031102                  hL = 0._wp 
    12041103                  hR = 0._wp 
    … …  
    12141113               a_i  (ji,jj  ,jl2) = a_i  (ji,jj  ,jl2) + ardg2 (ji,jj) * farea 
    12151114               v_i  (ji,jj  ,jl2) = v_i  (ji,jj  ,jl2) + vrdg2 (ji,jj) * fvol(ji,jj) 
    1216                v_s  (ji,jj  ,jl2) = v_s  (ji,jj  ,jl2) + vsrdg (ji,jj) * fvol(ji,jj) * fsnowrdg 
    1217                e_s  (ji,jj,1,jl2) = e_s  (ji,jj,1,jl2) + esrdg (ji,jj) * fvol(ji,jj) * fsnowrdg 
     1115               v_s  (ji,jj  ,jl2) = v_s  (ji,jj  ,jl2) + vsrdg (ji,jj) * fvol(ji,jj) * rn_fsnowrdg 
     1116               e_s  (ji,jj,1,jl2) = e_s  (ji,jj,1,jl2) + esrdg (ji,jj) * fvol(ji,jj) * rn_fsnowrdg 
    12181117               smv_i(ji,jj  ,jl2) = smv_i(ji,jj  ,jl2) + srdg2 (ji,jj) * fvol(ji,jj) 
    12191118               oa_i (ji,jj  ,jl2) = oa_i (ji,jj  ,jl2) + oirdg2(ji,jj) * farea 
    12201119 
    1221             END DO ! ij 
     1120            END DO 
    12221121 
    12231122            ! Transfer ice energy to category jl2 by ridging 
    12241123            DO jk = 1, nlay_i 
    1225 !CDIR NODEP 
    12261124               DO ij = 1, icells 
    12271125                  ji = indxi(ij) 
    12281126                  jj = indxj(ij) 
    1229                   e_i(ji,jj,jk,jl2) = e_i(ji,jj,jk,jl2) + fvol(ji,jj)*erdg2(ji,jj,jk) 
     1127                  e_i(ji,jj,jk,jl2) = e_i(ji,jj,jk,jl2) + fvol(ji,jj) * erdg2(ji,jj,jk) 
    12301128               END DO 
    12311129            END DO 
    … …  
    12351133         DO jl2 = 1, jpl  
    12361134 
    1237 !CDIR NODEP 
    12381135            DO ij = 1, icells 
    12391136               ji = indxi(ij) 
    … …  
    12421139               ! thickness category jl2, transfer area, volume, and energy accordingly. 
    12431140               ! 
    1244                IF( hraft(ji,jj,jl1) <= hi_max(jl2)  .AND.        & 
    1245                    hraft(ji,jj,jl1) >  hi_max(jl2-1) ) THEN 
     1141               IF( hraft(ji,jj,jl1) <= hi_max(jl2) .AND. hraft(ji,jj,jl1) >  hi_max(jl2-1) ) THEN 
    12461142                  a_i  (ji,jj  ,jl2) = a_i  (ji,jj  ,jl2) + arft2 (ji,jj) 
    12471143                  v_i  (ji,jj  ,jl2) = v_i  (ji,jj  ,jl2) + virft (ji,jj) 
    1248                   v_s  (ji,jj  ,jl2) = v_s  (ji,jj  ,jl2) + vsrft (ji,jj) * fsnowrft 
    1249                   e_s  (ji,jj,1,jl2) = e_s  (ji,jj,1,jl2) + esrft (ji,jj) * fsnowrft 
     1144                  v_s  (ji,jj  ,jl2) = v_s  (ji,jj  ,jl2) + vsrft (ji,jj) * rn_fsnowrft 
     1145                  e_s  (ji,jj,1,jl2) = e_s  (ji,jj,1,jl2) + esrft (ji,jj) * rn_fsnowrft 
    12501146                  smv_i(ji,jj  ,jl2) = smv_i(ji,jj  ,jl2) + smrft (ji,jj)     
    1251                   oa_i (ji,jj  ,jl2) = oa_i (ji,jj  ,jl2) + oirft2(ji,jj)     
    1252                ENDIF ! hraft 
     1147                  oa_i (ji,jj  ,jl2) = oa_i (ji,jj  ,jl2) + oirft2(ji,jj) 
     1148               ENDIF 
    12531149               ! 
    1254             END DO ! ij 
     1150            END DO 
    12551151 
    12561152            ! Transfer rafted ice energy to category jl2  
    12571153            DO jk = 1, nlay_i 
    1258 !CDIR NODEP 
    12591154               DO ij = 1, icells 
    12601155                  ji = indxi(ij) 
    12611156                  jj = indxj(ij) 
    1262                   IF(  hraft(ji,jj,jl1)  <=  hi_max(jl2)   .AND.        & 
    1263                        hraft(ji,jj,jl1)  >   hi_max(jl2-1)  ) THEN 
     1157                  IF( hraft(ji,jj,jl1) <= hi_max(jl2) .AND. hraft(ji,jj,jl1) > hi_max(jl2-1)  ) THEN 
    12641158                     e_i(ji,jj,jk,jl2) = e_i(ji,jj,jk,jl2) + eirft(ji,jj,jk) 
    12651159                  ENDIF 
    1266                END DO           ! ij 
    1267             END DO !jk 
    1268  
    1269          END DO ! jl2 
     1160               END DO 
     1161            END DO 
     1162 
     1163         END DO 
    12701164 
    12711165      END DO ! jl1 (deforming categories) 
    … …  
    12811175         CALL lim_cons_check (eice_init, eice_final, 1.0e-2, fieldid)  
    12821176 
    1283          DO ji = mi0(jiindx), mi1(jiindx) 
    1284             DO jj = mj0(jjindx), mj1(jjindx) 
     1177         DO ji = mi0(iiceprt), mi1(iiceprt) 
     1178            DO jj = mj0(jiceprt), mj1(jiceprt) 
    12851179               WRITE(numout,*) ' vice_init  : ', vice_init (ji,jj) 
    12861180               WRITE(numout,*) ' vice_final : ', vice_final(ji,jj) 
    … …  
    12911185      ENDIF 
    12921186      ! 
    1293       CALL wrk_dealloc( (jpi+1)*(jpj+1),      indxi, indxj ) 
    1294       CALL wrk_dealloc( jpi, jpj,             vice_init, vice_final, eice_init, eice_final ) 
    1295       CALL wrk_dealloc( jpi, jpj,             afrac, fvol , ardg1, ardg2, vsrdg, esrdg, oirdg1, oirdg2, dhr, dhr2 ) 
    1296       CALL wrk_dealloc( jpi, jpj,             vrdg1, vrdg2, vsw  , srdg1, srdg2, smsw ) 
    1297       CALL wrk_dealloc( jpi, jpj,             afrft, arft1, arft2, virft, vsrft, esrft, smrft, oirft1, oirft2 ) 
    1298       CALL wrk_dealloc( jpi, jpj, jpl,        aicen_init, vicen_init, vsnwn_init, esnwn_init, smv_i_init, oa_i_init ) 
    1299       CALL wrk_dealloc( jpi, jpj, nlay_i+1,      eirft, erdg1, erdg2, ersw ) 
    1300       CALL wrk_dealloc( jpi, jpj, nlay_i+1, jpl, eicen_init ) 
     1187      CALL wrk_dealloc( (jpi+1)*(jpj+1),        indxi, indxj ) 
     1188      CALL wrk_dealloc( jpi, jpj,               vice_init, vice_final, eice_init, eice_final ) 
     1189      CALL wrk_dealloc( jpi, jpj,               afrac, fvol , ardg1, ardg2, vsrdg, esrdg, dhr, dhr2 ) 
     1190      CALL wrk_dealloc( jpi, jpj,               vrdg1, vrdg2, vsw  , srdg1, srdg2, smsw, oirdg1, oirdg2 ) 
     1191      CALL wrk_dealloc( jpi, jpj,               afrft, arft1, arft2, virft, vsrft, esrft, smrft, oirft1, oirft2 ) 
     1192      CALL wrk_dealloc( jpi, jpj, jpl,          aicen_init, vicen_init, vsnwn_init, esnwn_init, smv_i_init, oa_i_init ) 
     1193      CALL wrk_dealloc( jpi, jpj, nlay_i,       eirft, erdg1, erdg2, ersw ) 
     1194      CALL wrk_dealloc( jpi, jpj, nlay_i, jpl, eicen_init ) 
    13011195      ! 
    13021196   END SUBROUTINE lim_itd_me_ridgeshift 
    1303  
    1304  
    1305    SUBROUTINE lim_itd_me_asumr 
    1306       !!----------------------------------------------------------------------------- 
    1307       !!                ***  ROUTINE lim_itd_me_asumr *** 
    1308       !! 
    1309       !! ** Purpose :   finds total fractional area 
    1310       !! 
    1311       !! ** Method  :   Find the total area of ice plus open water in each grid cell. 
    1312       !!              This is similar to the aggregate_area subroutine except that the 
    1313       !!              total area can be greater than 1, so the open water area is  
    1314       !!              included in the sum instead of being computed as a residual.  
    1315       !!----------------------------------------------------------------------------- 
    1316       INTEGER ::   jl   ! dummy loop index 
    1317       !!----------------------------------------------------------------------------- 
    1318       ! 
    1319       asum(:,:) = ato_i(:,:)                    ! open water 
    1320       DO jl = 1, jpl                            ! ice categories 
    1321          asum(:,:) = asum(:,:) + a_i(:,:,jl) 
    1322       END DO 
    1323       ! 
    1324    END SUBROUTINE lim_itd_me_asumr 
    1325  
    13261197 
    13271198   SUBROUTINE lim_itd_me_init 
    … …  
    13391210      !!------------------------------------------------------------------- 
    13401211      INTEGER :: ios                 ! Local integer output status for namelist read 
    1341       NAMELIST/namiceitdme/ ridge_scheme_swi, Cs, Cf, fsnowrdg, fsnowrft,              &  
    1342         &                   Gstar, astar, Hstar, raft_swi, hparmeter, Craft, ridge_por, & 
    1343         &                   partfun_swi, brinstren_swi 
     1212      NAMELIST/namiceitdme/ rn_cs, rn_fsnowrdg, rn_fsnowrft,              &  
     1213        &                   rn_gstar, rn_astar, rn_hstar, ln_rafting, rn_hraft, rn_craft, rn_por_rdg, & 
     1214        &                   nn_partfun 
    13441215      !!------------------------------------------------------------------- 
    13451216      ! 
    … …  
    13571228         WRITE(numout,*)' lim_itd_me_init : ice parameters for mechanical ice redistribution ' 
    13581229         WRITE(numout,*)' ~~~~~~~~~~~~~~~' 
    1359          WRITE(numout,*)'   Switch choosing the ice redistribution scheme           ridge_scheme_swi', ridge_scheme_swi  
    1360          WRITE(numout,*)'   Fraction of shear energy contributing to ridging        Cs              ', Cs  
    1361          WRITE(numout,*)'   Ratio of ridging work to PotEner change in ridging      Cf              ', Cf  
    1362          WRITE(numout,*)'   Fraction of snow volume conserved during ridging        fsnowrdg        ', fsnowrdg  
    1363          WRITE(numout,*)'   Fraction of snow volume conserved during ridging        fsnowrft        ', fsnowrft  
    1364          WRITE(numout,*)'   Fraction of total ice coverage contributing to ridging  Gstar           ', Gstar 
    1365          WRITE(numout,*)'   Equivalent to G* for an exponential part function       astar           ', astar 
    1366          WRITE(numout,*)'   Quantity playing a role in max ridged ice thickness     Hstar           ', Hstar 
    1367          WRITE(numout,*)'   Rafting of ice sheets or not                            raft_swi        ', raft_swi 
    1368          WRITE(numout,*)'   Parmeter thickness (threshold between ridge-raft)       hparmeter       ', hparmeter 
    1369          WRITE(numout,*)'   Rafting hyperbolic tangent coefficient                  Craft           ', Craft   
    1370          WRITE(numout,*)'   Initial porosity of ridges                              ridge_por       ', ridge_por 
    1371          WRITE(numout,*)'   Switch for part. function (0) linear (1) exponential    partfun_swi     ', partfun_swi 
    1372          WRITE(numout,*)'   Switch for including brine volume in ice strength comp. brinstren_swi   ', brinstren_swi 
     1230         WRITE(numout,*)'   Fraction of shear energy contributing to ridging        rn_cs       = ', rn_cs  
     1231         WRITE(numout,*)'   Fraction of snow volume conserved during ridging        rn_fsnowrdg = ', rn_fsnowrdg  
     1232         WRITE(numout,*)'   Fraction of snow volume conserved during ridging        rn_fsnowrft = ', rn_fsnowrft  
     1233         WRITE(numout,*)'   Fraction of total ice coverage contributing to ridging  rn_gstar    = ', rn_gstar 
     1234         WRITE(numout,*)'   Equivalent to G* for an exponential part function       rn_astar    = ', rn_astar 
     1235         WRITE(numout,*)'   Quantity playing a role in max ridged ice thickness     rn_hstar    = ', rn_hstar 
     1236         WRITE(numout,*)'   Rafting of ice sheets or not                            ln_rafting  = ', ln_rafting 
     1237         WRITE(numout,*)'   Parmeter thickness (threshold between ridge-raft)       rn_hraft    = ', rn_hraft 
     1238         WRITE(numout,*)'   Rafting hyperbolic tangent coefficient                  rn_craft    = ', rn_craft   
     1239         WRITE(numout,*)'   Initial porosity of ridges                              rn_por_rdg  = ', rn_por_rdg 
     1240         WRITE(numout,*)'   Switch for part. function (0) linear (1) exponential    nn_partfun  = ', nn_partfun 
    13731241      ENDIF 
    13741242      ! 
    13751243   END SUBROUTINE lim_itd_me_init 
    1376  
    1377  
    1378    SUBROUTINE lim_itd_me_zapsmall 
    1379       !!------------------------------------------------------------------- 
    1380       !!                   ***  ROUTINE lim_itd_me_zapsmall *** 
    1381       !! 
    1382       !! ** Purpose :   Remove too small sea ice areas and correct salt fluxes 
    1383       !! 
    1384       !! history : 
    1385       !! author: William H. Lipscomb, LANL 
    1386       !! Nov 2003:  Modified by Julie Schramm to conserve volume and energy 
    1387       !! Sept 2004: Modified by William Lipscomb; replaced normalize_state with 
    1388       !!            additions to local freshwater, salt, and heat fluxes 
    1389       !!  9.0, LIM3.0 - 02-2006 (M. Vancoppenolle) original code 
    1390       !!------------------------------------------------------------------- 
    1391       INTEGER ::   ji, jj, jl, jk   ! dummy loop indices 
    1392       INTEGER ::   icells           ! number of cells with ice to zap 
    1393  
    1394       REAL(wp), POINTER, DIMENSION(:,:) ::   zmask   ! 2D workspace 
    1395       REAL(wp)                          ::   zmask_glo, zsal, zvi, zvs, zei, zes 
    1396 !!gm      REAL(wp) ::   xtmp      ! temporary variable 
    1397       !!------------------------------------------------------------------- 
    1398  
    1399       CALL wrk_alloc( jpi, jpj, zmask ) 
    1400  
    1401       ! to be sure that at_i is the sum of a_i(jl) 
    1402       at_i(:,:) = SUM( a_i(:,:,:), dim=3 ) 
    1403  
    1404       DO jl = 1, jpl 
    1405          !----------------------------------------------------------------- 
    1406          ! Count categories to be zapped. 
    1407          !----------------------------------------------------------------- 
    1408          icells = 0 
    1409          zmask(:,:)  = 0._wp 
    1410          DO jj = 1, jpj 
    1411             DO ji = 1, jpi 
    1412                IF( a_i(ji,jj,jl) <= epsi10 .OR. v_i(ji,jj,jl) <= epsi10 .OR. at_i(ji,jj) <= epsi10 ) THEN 
    1413                   zmask(ji,jj) = 1._wp 
    1414                ENDIF 
    1415             END DO 
    1416          END DO 
    1417          !zmask_glo = glob_sum(zmask) 
    1418          !IF( ln_nicep .AND. lwp ) WRITE(numout,*) zmask_glo, ' cells of ice zapped in the ocean ' 
    1419  
    1420          !----------------------------------------------------------------- 
    1421          ! Zap ice energy and use ocean heat to melt ice 
    1422          !----------------------------------------------------------------- 
    1423  
    1424          DO jk = 1, nlay_i 
    1425             DO jj = 1 , jpj 
    1426                DO ji = 1 , jpi 
    1427                   zei  = e_i(ji,jj,jk,jl) 
    1428                   e_i(ji,jj,jk,jl) = e_i(ji,jj,jk,jl) * ( 1._wp - zmask(ji,jj) ) 
    1429                   t_i(ji,jj,jk,jl) = t_i(ji,jj,jk,jl) * ( 1._wp - zmask(ji,jj) ) + rtt * zmask(ji,jj) 
    1430                   ! update exchanges with ocean 
    1431                   hfx_res(ji,jj)   = hfx_res(ji,jj) + ( e_i(ji,jj,jk,jl) - zei ) * unit_fac / area(ji,jj) * r1_rdtice ! W.m-2 <0 
    1432                END DO 
    1433             END DO 
    1434          END DO 
    1435  
    1436          DO jj = 1 , jpj 
    1437             DO ji = 1 , jpi 
    1438                 
    1439                zsal = smv_i(ji,jj,jl) 
    1440                zvi  = v_i(ji,jj,jl) 
    1441                zvs  = v_s(ji,jj,jl) 
    1442                zes  = e_s(ji,jj,1,jl) 
    1443                !----------------------------------------------------------------- 
    1444                ! Zap snow energy and use ocean heat to melt snow 
    1445                !----------------------------------------------------------------- 
    1446                !           xtmp = esnon(i,j,n) / dt ! < 0 
    1447                !           fhnet(i,j)      = fhnet(i,j)      + xtmp 
    1448                !           fhnet_hist(i,j) = fhnet_hist(i,j) + xtmp 
    1449                ! xtmp is greater than 0 
    1450                ! fluxes are positive to the ocean 
    1451                ! here the flux has to be negative for the ocean 
    1452                t_s(ji,jj,1,jl) = rtt * zmask(ji,jj) + t_s(ji,jj,1,jl) * ( 1._wp - zmask(ji,jj) ) 
    1453  
    1454                !----------------------------------------------------------------- 
    1455                ! zap ice and snow volume, add water and salt to ocean 
    1456                !----------------------------------------------------------------- 
    1457                ato_i(ji,jj)    = a_i  (ji,jj,jl) *           zmask(ji,jj)   + ato_i(ji,jj) 
    1458                a_i  (ji,jj,jl) = a_i  (ji,jj,jl) * ( 1._wp - zmask(ji,jj) ) 
    1459                v_i  (ji,jj,jl) = v_i  (ji,jj,jl) * ( 1._wp - zmask(ji,jj) ) 
    1460                v_s  (ji,jj,jl) = v_s  (ji,jj,jl) * ( 1._wp - zmask(ji,jj) ) 
    1461                t_su (ji,jj,jl) = t_su (ji,jj,jl) * ( 1._wp - zmask(ji,jj) ) + t_bo(ji,jj) * zmask(ji,jj) 
    1462                oa_i (ji,jj,jl) = oa_i (ji,jj,jl) * ( 1._wp - zmask(ji,jj) ) 
    1463                smv_i(ji,jj,jl) = smv_i(ji,jj,jl) * ( 1._wp - zmask(ji,jj) ) 
    1464                e_s(ji,jj,1,jl) = e_s(ji,jj,1,jl) * ( 1._wp - zmask(ji,jj) ) 
    1465                ! additional condition 
    1466                IF( v_s(ji,jj,jl) <= epsi10 ) THEN 
    1467                   v_s(ji,jj,jl)   = 0._wp 
    1468                   e_s(ji,jj,1,jl) = 0._wp 
    1469                ENDIF 
    1470                ! update exchanges with ocean 
    1471                sfx_res(ji,jj)  = sfx_res(ji,jj) - ( smv_i(ji,jj,jl) - zsal ) * rhoic * r1_rdtice 
    1472                wfx_res(ji,jj)  = wfx_res(ji,jj) - ( v_i(ji,jj,jl)   - zvi  ) * rhoic * r1_rdtice 
    1473                wfx_snw(ji,jj)  = wfx_snw(ji,jj) - ( v_s(ji,jj,jl)   - zvs  ) * rhosn * r1_rdtice 
    1474                hfx_res(ji,jj)  = hfx_res(ji,jj) + ( e_s(ji,jj,1,jl) - zes ) * unit_fac / area(ji,jj) * r1_rdtice ! W.m-2 <0 
    1475             END DO 
    1476          END DO 
    1477       END DO ! jl  
    1478  
    1479       ! to be sure that at_i is the sum of a_i(jl) 
    1480       at_i(:,:) = SUM( a_i(:,:,:), dim=3 ) 
    1481       ! 
    1482       CALL wrk_dealloc( jpi, jpj, zmask ) 
    1483       ! 
    1484    END SUBROUTINE lim_itd_me_zapsmall 
    14851244 
    14861245#else 
    … …  
    14931252   SUBROUTINE lim_itd_me_icestrength 
    14941253   END SUBROUTINE lim_itd_me_icestrength 
    1495    SUBROUTINE lim_itd_me_sort 
    1496    END SUBROUTINE lim_itd_me_sort 
    14971254   SUBROUTINE lim_itd_me_init 
    14981255   END SUBROUTINE lim_itd_me_init 
    1499    SUBROUTINE lim_itd_me_zapsmall 
    1500    END SUBROUTINE lim_itd_me_zapsmall 
    15011256#endif 
    15021257   !!====================================================================== 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/LIM_SRC_3/limitd_th.F90

    r5312 r5313  
    1313   !!   'key_lim3' :                                   LIM3 sea-ice model 
    1414   !!---------------------------------------------------------------------- 
    15    !!   lim_itd_th       : thermodynamics of ice thickness distribution 
    1615   !!   lim_itd_th_rem   : 
    1716   !!   lim_itd_th_reb   : 
    … …  
    2524   USE thd_ice          ! LIM-3 thermodynamic variables 
    2625   USE ice              ! LIM-3 variables 
    27    USE par_ice          ! LIM-3 parameters 
    28    USE limthd_lac       ! LIM-3 lateral accretion 
    2926   USE limvar           ! LIM-3 variables 
    30    USE limcons          ! LIM-3 conservation 
    3127   USE prtctl           ! Print control 
    3228   USE in_out_manager   ! I/O manager 
    … …  
    3430   USE wrk_nemo         ! work arrays 
    3531   USE lib_fortran      ! to use key_nosignedzero 
    36    USE timing          ! Timing 
    37    USE limcons        ! conservation tests 
     32   USE limcons          ! conservation tests 
    3833 
    3934   IMPLICIT NONE 
    4035   PRIVATE 
    4136 
    42    PUBLIC   lim_itd_th         ! called by ice_stp 
    4337   PUBLIC   lim_itd_th_rem 
    4438   PUBLIC   lim_itd_th_reb 
    45    PUBLIC   lim_itd_fitline 
    46    PUBLIC   lim_itd_shiftice 
    4739 
    4840   !!---------------------------------------------------------------------- 
    … …  
    5244   !!---------------------------------------------------------------------- 
    5345CONTAINS 
    54  
    55    SUBROUTINE lim_itd_th( kt ) 
    56       !!------------------------------------------------------------------ 
    57       !!                ***  ROUTINE lim_itd_th *** 
    58       !! 
    59       !! ** Purpose :   computes the thermodynamics of ice thickness distribution 
    60       !! 
    61       !! ** Method  : 
    62       !!------------------------------------------------------------------ 
    63       INTEGER, INTENT(in) ::   kt   ! time step index 
    64       ! 
    65       INTEGER ::   ji, jj, jk, jl   ! dummy loop index          
    66       ! 
    67       REAL(wp) :: zvi_b, zsmv_b, zei_b, zfs_b, zfw_b, zft_b  
    68       !!------------------------------------------------------------------ 
    69       IF( nn_timing == 1 )  CALL timing_start('limitd_th') 
    70  
    71       ! conservation test 
    72       IF( ln_limdiahsb ) CALL lim_cons_hsm(0, 'limitd_th', zvi_b, zsmv_b, zei_b, zfw_b, zfs_b, zft_b) 
    73  
    74       IF( kt == nit000 .AND. lwp ) THEN 
    75          WRITE(numout,*) 
    76          WRITE(numout,*) 'lim_itd_th  : Thermodynamics of the ice thickness distribution' 
    77          WRITE(numout,*) '~~~~~~~~~~~' 
    78       ENDIF 
    79  
    80       !------------------------------------------------------------------------------| 
    81       !  1) Transport of ice between thickness categories.                           | 
    82       !------------------------------------------------------------------------------| 
    83       ! Given thermodynamic growth rates, transport ice between 
    84       ! thickness categories. 
    85       IF( jpl > 1 )   CALL lim_itd_th_rem( 1, jpl, kt ) 
    86       ! 
    87       CALL lim_var_glo2eqv    ! only for info 
    88       CALL lim_var_agg(1) 
    89  
    90       !------------------------------------------------------------------------------| 
    91       !  3) Add frazil ice growing in leads. 
    92       !------------------------------------------------------------------------------| 
    93       CALL lim_thd_lac 
    94       CALL lim_var_glo2eqv    ! only for info 
    95       
    96       IF(ln_ctl) THEN   ! Control print 
    97          CALL prt_ctl_info(' ') 
    98          CALL prt_ctl_info(' - Cell values : ') 
    99          CALL prt_ctl_info('   ~~~~~~~~~~~~~ ') 
    100          CALL prt_ctl(tab2d_1=area , clinfo1=' lim_itd_th  : cell area :') 
    101          CALL prt_ctl(tab2d_1=at_i , clinfo1=' lim_itd_th  : at_i      :') 
    102          CALL prt_ctl(tab2d_1=vt_i , clinfo1=' lim_itd_th  : vt_i      :') 
    103          CALL prt_ctl(tab2d_1=vt_s , clinfo1=' lim_itd_th  : vt_s      :') 
    104          DO jl = 1, jpl 
    105             CALL prt_ctl_info(' ') 
    106             CALL prt_ctl_info(' - Category : ', ivar1=jl) 
    107             CALL prt_ctl_info('   ~~~~~~~~~~') 
    108             CALL prt_ctl(tab2d_1=a_i   (:,:,jl)   , clinfo1= ' lim_itd_th  : a_i      : ') 
    109             CALL prt_ctl(tab2d_1=ht_i  (:,:,jl)   , clinfo1= ' lim_itd_th  : ht_i     : ') 
    110             CALL prt_ctl(tab2d_1=ht_s  (:,:,jl)   , clinfo1= ' lim_itd_th  : ht_s     : ') 
    111             CALL prt_ctl(tab2d_1=v_i   (:,:,jl)   , clinfo1= ' lim_itd_th  : v_i      : ') 
    112             CALL prt_ctl(tab2d_1=v_s   (:,:,jl)   , clinfo1= ' lim_itd_th  : v_s      : ') 
    113             CALL prt_ctl(tab2d_1=e_s   (:,:,1,jl) , clinfo1= ' lim_itd_th  : e_s      : ') 
    114             CALL prt_ctl(tab2d_1=t_su  (:,:,jl)   , clinfo1= ' lim_itd_th  : t_su     : ') 
    115             CALL prt_ctl(tab2d_1=t_s   (:,:,1,jl) , clinfo1= ' lim_itd_th  : t_snow   : ') 
    116             CALL prt_ctl(tab2d_1=sm_i  (:,:,jl)   , clinfo1= ' lim_itd_th  : sm_i     : ') 
    117             CALL prt_ctl(tab2d_1=smv_i (:,:,jl)   , clinfo1= ' lim_itd_th  : smv_i    : ') 
    118             DO jk = 1, nlay_i 
    119                CALL prt_ctl_info(' ') 
    120                CALL prt_ctl_info(' - Layer : ', ivar1=jk) 
    121                CALL prt_ctl_info('   ~~~~~~~') 
    122                CALL prt_ctl(tab2d_1=t_i(:,:,jk,jl) , clinfo1= ' lim_itd_th  : t_i      : ') 
    123                CALL prt_ctl(tab2d_1=e_i(:,:,jk,jl) , clinfo1= ' lim_itd_th  : e_i      : ') 
    124             END DO 
    125          END DO 
    126       ENDIF 
    127       ! 
    128       ! conservation test 
    129       IF( ln_limdiahsb ) CALL lim_cons_hsm(1, 'limitd_th', zvi_b, zsmv_b, zei_b, zfw_b, zfs_b, zft_b) 
    130       ! 
    131      IF( nn_timing == 1 )  CALL timing_stop('limitd_th') 
    132    END SUBROUTINE lim_itd_th 
    133    ! 
    13446 
    13547   SUBROUTINE lim_itd_th_rem( klbnd, kubnd, kt ) 
    … …  
    15365      REAL(wp) ::   zx1, zwk1, zdh0, zetamin, zdamax   ! local scalars 
    15466      REAL(wp) ::   zx2, zwk2, zda0, zetamax           !   -      - 
    155       REAL(wp) ::   zx3,             zareamin          !   -      - 
     67      REAL(wp) ::   zx3         
    15668      CHARACTER (len = 15) :: fieldid 
    15769 
    … …  
    188100      CALL wrk_alloc( jpi,jpj, zhb0,zhb1,vt_i_init,vt_i_final,vt_s_init,vt_s_final,et_i_init,et_i_final,et_s_init,et_s_final ) 
    189101 
    190       zareamin = epsi10   !minimum area in thickness categories tolerated by the conceptors of the model 
    191  
    192102      !!---------------------------------------------------------------------------------------------- 
    193103      !! 0) Conservation checkand changes in each ice category 
    … …  
    216126         DO jj = 1, jpj 
    217127            DO ji = 1, jpi 
    218                rswitch             = 1.0 - MAX( 0.0, SIGN( 1.0, - a_i(ji,jj,jl) + epsi10 ) )     !0 if no ice and 1 if yes 
     128               rswitch           = MAX( 0.0, SIGN( 1.0, a_i(ji,jj,jl) - epsi10 ) )     !0 if no ice and 1 if yes 
    219129               ht_i(ji,jj,jl)    = v_i(ji,jj,jl) / MAX( a_i(ji,jj,jl), epsi10 ) * rswitch 
    220                rswitch             = 1.0 - MAX( 0.0, SIGN( 1.0, - a_i_b(ji,jj,jl) + epsi10) ) !0 if no ice and 1 if yes 
     130               rswitch           = MAX( 0.0, SIGN( 1.0, a_i_b(ji,jj,jl) - epsi10) )    !0 if no ice and 1 if yes 
    221131               zht_i_b(ji,jj,jl) = v_i_b(ji,jj,jl) / MAX( a_i_b(ji,jj,jl), epsi10 ) * rswitch 
    222                IF( a_i(ji,jj,jl) > epsi10 )   zdhice(ji,jj,jl) = ht_i(ji,jj,jl) - zht_i_b(ji,jj,jl)  
     132               zdhice(ji,jj,jl) = ht_i(ji,jj,jl) - zht_i_b(ji,jj,jl)  
    223133            END DO 
    224134         END DO 
    … …  
    239149      DO jj = 1, jpj 
    240150         DO ji = 1, jpi 
    241             IF ( at_i(ji,jj) .gt. zareamin ) THEN 
     151            IF ( at_i(ji,jj) > epsi10 ) THEN 
    242152               nbrem         = nbrem + 1 
    243153               nind_i(nbrem) = ji 
    … …  
    247157               zremap_flag(ji,jj) = 0 
    248158            ENDIF 
    249          END DO !ji 
    250       END DO !jj 
     159         END DO 
     160      END DO 
    251161 
    252162      !----------------------------------------------------------------------------------------------- 
    … …  
    254164      !----------------------------------------------------------------------------------------------- 
    255165      !- 4.1 Compute category boundaries 
    256       ! Tricky trick see limitd_me.F90 
    257       ! will be soon removed, CT 
    258       ! hi_max(kubnd) = 99. 
    259166      zhbnew(:,:,:) = 0._wp 
    260167 
    … …  
    291198         END DO 
    292199 
    293       END DO !jl 
     200      END DO 
    294201 
    295202      !----------------------------------------------------------------------------------------------- 
    … …  
    318225 
    319226            IF( a_i(ji,jj,kubnd) > epsi10 ) THEN 
    320                zhbnew(ji,jj,kubnd) = 3._wp * ht_i(ji,jj,kubnd) - 2._wp * zhbnew(ji,jj,kubnd-1) 
     227               zhbnew(ji,jj,kubnd) = MAX( hi_max(kubnd-1), 3._wp * ht_i(ji,jj,kubnd) - 2._wp * zhbnew(ji,jj,kubnd-1) ) 
    321228            ELSE 
    322229               zhbnew(ji,jj,kubnd) = hi_max(kubnd)   
    … …  
    325232            ENDIF 
    326233 
    327             IF( zhbnew(ji,jj,kubnd) < hi_max(kubnd-1) ) zhbnew(ji,jj,kubnd) = hi_max(kubnd-1) 
    328  
    329          END DO !jj 
    330       END DO !jj 
     234         END DO 
     235      END DO 
    331236 
    332237      !----------------------------------------------------------------------------------------------- 
    … …  
    334239      !----------------------------------------------------------------------------------------------- 
    335240      !- 7.1 g(h) for category 1 at start of time step 
    336       CALL lim_itd_fitline( klbnd, zhb0, zhb1, zht_i_b(:,:,klbnd),         & 
    337          &                  g0(:,:,klbnd), g1(:,:,klbnd), hL(:,:,klbnd),   & 
     241      CALL lim_itd_fitline( klbnd, zhb0, zhb1, zht_i_b(:,:,klbnd), g0(:,:,klbnd), g1(:,:,klbnd), hL(:,:,klbnd),   & 
    338242         &                  hR(:,:,klbnd), zremap_flag ) 
    339243 
    … …  
    343247         ij = nind_j(ji)  
    344248 
    345          !ji 
    346          IF (a_i(ii,ij,klbnd) .gt. epsi10) THEN 
     249         IF( a_i(ii,ij,klbnd) > epsi10 ) THEN 
    347250            zdh0 = zdhice(ii,ij,klbnd) !decrease of ice thickness in the lower category 
    348             ! ji, a_i > epsi10 
    349             IF (zdh0 .lt. 0.0) THEN !remove area from category 1 
    350                ! ji, a_i > epsi10; zdh0 < 0 
    351                zdh0 = MIN(-zdh0,hi_max(klbnd)) 
     251            IF( zdh0 < 0.0 ) THEN !remove area from category 1 
     252               zdh0 = MIN( -zdh0, hi_max(klbnd) ) 
    352253 
    353254               !Integrate g(1) from 0 to dh0 to estimate area melted 
    354                zetamax = MIN(zdh0,hR(ii,ij,klbnd)) - hL(ii,ij,klbnd) 
    355                IF (zetamax.gt.0.0) THEN 
     255               zetamax = MIN( zdh0, hR(ii,ij,klbnd) ) - hL(ii,ij,klbnd) 
     256               IF( zetamax > 0.0 ) THEN 
    356257                  zx1  = zetamax 
    357                   zx2  = 0.5 * zetamax*zetamax  
     258                  zx2  = 0.5 * zetamax * zetamax  
    358259                  zda0 = g1(ii,ij,klbnd) * zx2 + g0(ii,ij,klbnd) * zx1 !ice area removed 
    359260                  ! Constrain new thickness <= ht_i 
    360                   zdamax = a_i(ii,ij,klbnd) * &  
    361                      (1.0 - ht_i(ii,ij,klbnd)/zht_i_b(ii,ij,klbnd)) ! zdamax > 0 
     261                  zdamax = a_i(ii,ij,klbnd) * (1.0 - ht_i(ii,ij,klbnd) / zht_i_b(ii,ij,klbnd) ) ! zdamax > 0 
    362262                  !ice area lost due to melting of thin ice 
    363                   zda0   = MIN(zda0, zdamax) 
     263                  zda0   = MIN( zda0, zdamax ) 
    364264 
    365265                  ! Remove area, conserving volume 
    366                   ht_i(ii,ij,klbnd) = ht_i(ii,ij,klbnd) &  
    367                      * a_i(ii,ij,klbnd) / ( a_i(ii,ij,klbnd) - zda0 ) 
     266                  ht_i(ii,ij,klbnd) = ht_i(ii,ij,klbnd) * a_i(ii,ij,klbnd) / ( a_i(ii,ij,klbnd) - zda0 ) 
    368267                  a_i(ii,ij,klbnd)  = a_i(ii,ij,klbnd) - zda0 
    369                   v_i(ii,ij,klbnd)  = a_i(ii,ij,klbnd)*ht_i(ii,ij,klbnd) ! clem-useless ? 
    370                ENDIF     ! zetamax > 0 
    371                ! ji, a_i > epsi10 
    372  
    373             ELSE ! if ice accretion 
    374                ! ji, a_i > epsi10; zdh0 > 0 
    375                zhbnew(ii,ij,klbnd-1) = MIN(zdh0,hi_max(klbnd))  
     268                  v_i(ii,ij,klbnd)  = a_i(ii,ij,klbnd) * ht_i(ii,ij,klbnd) ! clem-useless ? 
     269               ENDIF 
     270 
     271            ELSE ! if ice accretion ! a_i > epsi10; zdh0 > 0 
     272               zhbnew(ii,ij,klbnd-1) = MIN( zdh0, hi_max(klbnd) )  
    376273               ! zhbnew was 0, and is shifted to the right to account for thin ice 
    377274               ! growth in openwater (F0 = f1) 
    378275            ENDIF ! zdh0  
    379276 
    380             ! a_i > epsi10 
    381277         ENDIF ! a_i > epsi10 
    382278 
    383       END DO ! ji 
     279      END DO 
    384280 
    385281      !- 7.3 g(h) for each thickness category   
    386282      DO jl = klbnd, kubnd 
    387          CALL lim_itd_fitline(jl, zhbnew(:,:,jl-1), zhbnew(:,:,jl), ht_i(:,:,jl), & 
    388             g0(:,:,jl), g1(:,:,jl), hL(:,:,jl), hR(:,:,jl), zremap_flag) 
     283         CALL lim_itd_fitline( jl, zhbnew(:,:,jl-1), zhbnew(:,:,jl), ht_i(:,:,jl), & 
     284            &                  g0(:,:,jl), g1(:,:,jl), hL(:,:,jl), hR(:,:,jl), zremap_flag ) 
    389285      END DO 
    390286 
    … …  
    406302            ij = nind_j(ji) 
    407303 
    408             IF (zhbnew(ii,ij,jl) .gt. hi_max(jl)) THEN ! transfer from jl to jl+1 
     304            IF (zhbnew(ii,ij,jl) > hi_max(jl)) THEN ! transfer from jl to jl+1 
    409305 
    410306               ! left and right integration limits in eta space 
    411                zvetamin(ji) = MAX(hi_max(jl), hL(ii,ij,jl)) - hL(ii,ij,jl) 
    412                zvetamax(ji) = MIN(zhbnew(ii,ij,jl), hR(ii,ij,jl)) - hL(ii,ij,jl) 
     307               zvetamin(ji) = MAX( hi_max(jl), hL(ii,ij,jl) ) - hL(ii,ij,jl) 
     308               zvetamax(ji) = MIN (zhbnew(ii,ij,jl), hR(ii,ij,jl) ) - hL(ii,ij,jl) 
    413309               zdonor(ii,ij,jl) = jl 
    414310 
    … …  
    417313               ! left and right integration limits in eta space 
    418314               zvetamin(ji) = 0.0 
    419                zvetamax(ji) = MIN(hi_max(jl), hR(ii,ij,jl+1)) - hL(ii,ij,jl+1) 
     315               zvetamax(ji) = MIN( hi_max(jl), hR(ii,ij,jl+1) ) - hL(ii,ij,jl+1) 
    420316               zdonor(ii,ij,jl) = jl + 1 
    421317 
    422318            ENDIF  ! zhbnew(jl) > hi_max(jl) 
    423319 
    424             zetamax = MAX(zvetamax(ji), zvetamin(ji)) ! no transfer if etamax < etamin 
     320            zetamax = MAX( zvetamax(ji), zvetamin(ji) ) ! no transfer if etamax < etamin 
    425321            zetamin = zvetamin(ji) 
    426322 
    427323            zx1  = zetamax - zetamin 
    428             zwk1 = zetamin*zetamin 
    429             zwk2 = zetamax*zetamax 
    430             zx2  = 0.5 * (zwk2 - zwk1) 
     324            zwk1 = zetamin * zetamin 
     325            zwk2 = zetamax * zetamax 
     326            zx2  = 0.5 * ( zwk2 - zwk1 ) 
    431327            zwk1 = zwk1 * zetamin 
    432328            zwk2 = zwk2 * zetamax 
    433             zx3  = 1.0/3.0 * (zwk2 - zwk1) 
     329            zx3  = 1.0 / 3.0 * ( zwk2 - zwk1 ) 
    434330            nd   = zdonor(ii,ij,jl) 
    435331            zdaice(ii,ij,jl) = g1(ii,ij,nd)*zx2 + g0(ii,ij,nd)*zx1 
    436332            zdvice(ii,ij,jl) = g1(ii,ij,nd)*zx3 + g0(ii,ij,nd)*zx2 + zdaice(ii,ij,jl)*hL(ii,ij,nd) 
    437333 
    438          END DO ! ji 
     334         END DO 
    439335      END DO ! jl klbnd -> kubnd - 1 
    440336 
    … …  
    451347         ii = nind_i(ji) 
    452348         ij = nind_j(ji) 
    453          IF ( a_i(ii,ij,1) > epsi10 .AND. ht_i(ii,ij,1) < hiclim ) THEN 
    454             a_i(ii,ij,1)  = a_i(ii,ij,1) * ht_i(ii,ij,1) / hiclim  
    455             ht_i(ii,ij,1) = hiclim 
     349         IF ( a_i(ii,ij,1) > epsi10 .AND. ht_i(ii,ij,1) < rn_himin ) THEN 
     350            a_i (ii,ij,1) = a_i(ii,ij,1) * ht_i(ii,ij,1) / rn_himin  
     351            ht_i(ii,ij,1) = rn_himin 
    456352         ENDIF 
    457       END DO !ji 
     353      END DO 
    458354 
    459355      !!---------------------------------------------------------------------------------------------- 
    … …  
    491387 
    492388 
    493    SUBROUTINE lim_itd_fitline( num_cat, HbL, Hbr, hice,   & 
    494       &                        g0, g1, hL, hR, zremap_flag ) 
     389   SUBROUTINE lim_itd_fitline( num_cat, HbL, Hbr, hice, g0, g1, hL, hR, zremap_flag ) 
    495390      !!------------------------------------------------------------------ 
    496391      !!                ***  ROUTINE lim_itd_fitline *** 
    … …  
    532427               ! Change hL or hR if hice falls outside central third of range 
    533428 
    534                zh13 = 1.0/3.0 * (2.0*hL(ji,jj) + hR(ji,jj)) 
    535                zh23 = 1.0/3.0 * (hL(ji,jj) + 2.0*hR(ji,jj)) 
     429               zh13 = 1.0 / 3.0 * ( 2.0 * hL(ji,jj) + hR(ji,jj) ) 
     430               zh23 = 1.0 / 3.0 * ( hL(ji,jj) + 2.0 * hR(ji,jj) ) 
    536431 
    537432               IF    ( hice(ji,jj) < zh13 ) THEN   ;   hR(ji,jj) = 3._wp * hice(ji,jj) - 2._wp * hL(ji,jj) 
    … …  
    544439               zwk1 = 6._wp * a_i(ji,jj,num_cat) * zdhr 
    545440               zwk2 = ( hice(ji,jj) - hL(ji,jj) ) * zdhr 
    546                g0(ji,jj) = zwk1 * ( 2._wp/3._wp - zwk2 ) 
    547                g1(ji,jj) = 2._wp * zdhr * zwk1 * (zwk2 - 0.5) 
     441               g0(ji,jj) = zwk1 * ( 2._wp / 3._wp - zwk2 ) 
     442               g1(ji,jj) = 2._wp * zdhr * zwk1 * ( zwk2 - 0.5 ) 
    548443               ! 
    549444            ELSE                   ! remap_flag = .false. or a_i < epsi10  
    … …  
    606501 
    607502      DO jl = klbnd, kubnd 
    608          zaTsfn(:,:,jl) = a_i(:,:,jl)*t_su(:,:,jl) 
    609       END DO 
    610  
    611       !---------------------------------------------------------------------------------------------- 
    612       ! 2) Check for daice or dvice out of range, allowing for roundoff error 
    613       !---------------------------------------------------------------------------------------------- 
    614       ! Note: zdaice < 0 or zdvice < 0 usually happens when category jl 
    615       ! has a small area, with h(n) very close to a boundary.  Then 
    616       ! the coefficients of g(h) are large, and the computed daice and 
    617       ! dvice can be in error. If this happens, it is best to transfer 
    618       ! either the entire category or nothing at all, depending on which 
    619       ! side of the boundary hice(n) lies. 
    620       !----------------------------------------------------------------- 
    621       DO jl = klbnd, kubnd-1 
    622  
    623          zdaice_negative = .false. 
    624          zdvice_negative = .false. 
    625          zdaice_greater_aicen = .false. 
    626          zdvice_greater_vicen = .false. 
    627  
    628          DO jj = 1, jpj 
    629             DO ji = 1, jpi 
    630  
    631                IF (zdonor(ji,jj,jl) .GT. 0) THEN 
    632                   jl1 = zdonor(ji,jj,jl) 
    633  
    634                   IF (zdaice(ji,jj,jl) .LT. 0.0) THEN 
    635                      IF (zdaice(ji,jj,jl) .GT. -epsi10) THEN 
    636                         IF ( ( jl1.EQ.jl   .AND. ht_i(ji,jj,jl1) .GT. hi_max(jl) )           & 
    637                            .OR.                                      & 
    638                            ( jl1.EQ.jl+1 .AND. ht_i(ji,jj,jl1) .LE. hi_max(jl) )           &   
    639                            ) THEN                                                              
    640                            zdaice(ji,jj,jl) = a_i(ji,jj,jl1)  ! shift entire category 
    641                            zdvice(ji,jj,jl) = v_i(ji,jj,jl1) 
    642                         ELSE 
    643                            zdaice(ji,jj,jl) = 0.0 ! shift no ice 
    644                            zdvice(ji,jj,jl) = 0.0 
    645                         ENDIF 
    646                      ELSE 
    647                         zdaice_negative = .true. 
    648                      ENDIF 
    649                   ENDIF 
    650  
    651                   IF (zdvice(ji,jj,jl) .LT. 0.0) THEN 
    652                      IF (zdvice(ji,jj,jl) .GT. -epsi10 ) THEN 
    653                         IF ( ( jl1.EQ.jl .AND. ht_i(ji,jj,jl1).GT.hi_max(jl) )     & 
    654                            .OR.                                     & 
    655                            ( jl1.EQ.jl+1 .AND. ht_i(ji,jj,jl1) .LE. hi_max(jl) ) & 
    656                            ) THEN 
    657                            zdaice(ji,jj,jl) = a_i(ji,jj,jl1) ! shift entire category 
    658                            zdvice(ji,jj,jl) = v_i(ji,jj,jl1)  
    659                         ELSE 
    660                            zdaice(ji,jj,jl) = 0.0    ! shift no ice 
    661                            zdvice(ji,jj,jl) = 0.0 
    662                         ENDIF 
    663                      ELSE 
    664                         zdvice_negative = .true. 
    665                      ENDIF 
    666                   ENDIF 
    667  
    668                   ! If daice is close to aicen, set daice = aicen. 
    669                   IF (zdaice(ji,jj,jl) .GT. a_i(ji,jj,jl1) - epsi10 ) THEN 
    670                      IF (zdaice(ji,jj,jl) .LT. a_i(ji,jj,jl1)+epsi10) THEN 
    671                         zdaice(ji,jj,jl) = a_i(ji,jj,jl1) 
    672                         zdvice(ji,jj,jl) = v_i(ji,jj,jl1)  
    673                      ELSE 
    674                         zdaice_greater_aicen = .true. 
    675                      ENDIF 
    676                   ENDIF 
    677  
    678                   IF (zdvice(ji,jj,jl) .GT. v_i(ji,jj,jl1)-epsi10) THEN 
    679                      IF (zdvice(ji,jj,jl) .LT. v_i(ji,jj,jl1)+epsi10) THEN 
    680                         zdaice(ji,jj,jl) = a_i(ji,jj,jl1) 
    681                         zdvice(ji,jj,jl) = v_i(ji,jj,jl1)  
    682                      ELSE 
    683                         zdvice_greater_vicen = .true. 
    684                      ENDIF 
    685                   ENDIF 
    686  
    687                ENDIF               ! donor > 0 
    688             END DO                   ! i 
    689          END DO                 ! j 
    690  
    691       END DO !jl 
    692  
     503         zaTsfn(:,:,jl) = a_i(:,:,jl) * t_su(:,:,jl) 
     504      END DO 
     505 
     506!clem: I think the following is wrong (if enabled, it creates negative concentration/volume around -epsi10) 
     507!      !---------------------------------------------------------------------------------------------- 
     508!      ! 2) Check for daice or dvice out of range, allowing for roundoff error 
     509!      !---------------------------------------------------------------------------------------------- 
     510!      ! Note: zdaice < 0 or zdvice < 0 usually happens when category jl 
     511!      ! has a small area, with h(n) very close to a boundary.  Then 
     512!      ! the coefficients of g(h) are large, and the computed daice and 
     513!      ! dvice can be in error. If this happens, it is best to transfer 
     514!      ! either the entire category or nothing at all, depending on which 
     515!      ! side of the boundary hice(n) lies. 
     516!      !----------------------------------------------------------------- 
     517!      DO jl = klbnd, kubnd-1 
     518! 
     519!         zdaice_negative = .false. 
     520!         zdvice_negative = .false. 
     521!         zdaice_greater_aicen = .false. 
     522!         zdvice_greater_vicen = .false. 
     523! 
     524!         DO jj = 1, jpj 
     525!            DO ji = 1, jpi 
     526! 
     527!               IF (zdonor(ji,jj,jl) > 0) THEN 
     528!                  jl1 = zdonor(ji,jj,jl) 
     529! 
     530!                  IF (zdaice(ji,jj,jl) < 0.0) THEN 
     531!                     IF (zdaice(ji,jj,jl) > -epsi10) THEN 
     532!                        IF ( ( jl1 == jl   .AND. ht_i(ji,jj,jl1) >  hi_max(jl) ) .OR.  & 
     533!                             ( jl1 == jl+1 .AND. ht_i(ji,jj,jl1) <= hi_max(jl) ) ) THEN 
     534!                           zdaice(ji,jj,jl) = a_i(ji,jj,jl1)  ! shift entire category 
     535!                           zdvice(ji,jj,jl) = v_i(ji,jj,jl1) 
     536!                        ELSE 
     537!                           zdaice(ji,jj,jl) = 0.0 ! shift no ice 
     538!                           zdvice(ji,jj,jl) = 0.0 
     539!                        ENDIF 
     540!                     ELSE 
     541!                        zdaice_negative = .true. 
     542!                     ENDIF 
     543!                  ENDIF 
     544! 
     545!                  IF (zdvice(ji,jj,jl) < 0.0) THEN 
     546!                     IF (zdvice(ji,jj,jl) > -epsi10 ) THEN 
     547!                        IF ( ( jl1 == jl   .AND. ht_i(ji,jj,jl1) >  hi_max(jl) ) .OR.  & 
     548!                             ( jl1 == jl+1 .AND. ht_i(ji,jj,jl1) <= hi_max(jl) ) ) THEN 
     549!                           zdaice(ji,jj,jl) = a_i(ji,jj,jl1) ! shift entire category 
     550!                           zdvice(ji,jj,jl) = v_i(ji,jj,jl1)  
     551!                        ELSE 
     552!                           zdaice(ji,jj,jl) = 0.0    ! shift no ice 
     553!                           zdvice(ji,jj,jl) = 0.0 
     554!                        ENDIF 
     555!                    ELSE 
     556!                       zdvice_negative = .true. 
     557!                    ENDIF 
     558!                 ENDIF 
     559! 
     560!                  ! If daice is close to aicen, set daice = aicen. 
     561!                  IF (zdaice(ji,jj,jl) > a_i(ji,jj,jl1) - epsi10 ) THEN 
     562!                     IF (zdaice(ji,jj,jl) < a_i(ji,jj,jl1)+epsi10) THEN 
     563!                        zdaice(ji,jj,jl) = a_i(ji,jj,jl1) 
     564!                        zdvice(ji,jj,jl) = v_i(ji,jj,jl1)  
     565!                    ELSE 
     566!                       zdaice_greater_aicen = .true. 
     567!                    ENDIF 
     568!                  ENDIF 
     569! 
     570!                  IF (zdvice(ji,jj,jl) > v_i(ji,jj,jl1)-epsi10) THEN 
     571!                     IF (zdvice(ji,jj,jl) < v_i(ji,jj,jl1)+epsi10) THEN 
     572!                        zdaice(ji,jj,jl) = a_i(ji,jj,jl1) 
     573!                        zdvice(ji,jj,jl) = v_i(ji,jj,jl1)  
     574!                     ELSE 
     575!                        zdvice_greater_vicen = .true. 
     576!                     ENDIF 
     577!                  ENDIF 
     578! 
     579!               ENDIF               ! donor > 0 
     580!            END DO 
     581!         END DO 
     582! 
     583!      END DO 
     584!clem 
    693585      !------------------------------------------------------------------------------- 
    694586      ! 3) Transfer volume and energy between categories 
    … …  
    699591         DO jj = 1, jpj 
    700592            DO ji = 1, jpi 
    701                IF (zdaice(ji,jj,jl) .GT. 0.0 ) THEN ! daice(n) can be < puny 
     593               IF (zdaice(ji,jj,jl) > 0.0 ) THEN ! daice(n) can be < puny 
    702594                  nbrem = nbrem + 1 
    703595                  nind_i(nbrem) = ji 
    704596                  nind_j(nbrem) = jj 
    705                ENDIF ! tmask 
     597               ENDIF 
    706598            END DO 
    707599         END DO 
    … …  
    712604 
    713605            jl1 = zdonor(ii,ij,jl) 
    714             rswitch             = MAX( 0.0 , SIGN( 1.0 , v_i(ii,ij,jl1) - epsi10 ) ) 
    715             zworka(ii,ij)   = zdvice(ii,ij,jl) / MAX(v_i(ii,ij,jl1),epsi10) * rswitch 
     606            rswitch       = MAX( 0._wp , SIGN( 1._wp , v_i(ii,ij,jl1) - epsi20 ) ) 
     607            zworka(ii,ij) = zdvice(ii,ij,jl) / MAX( v_i(ii,ij,jl1), epsi20 ) * rswitch 
    716608            IF( jl1 == jl) THEN   ;   jl2 = jl1+1 
    717             ELSE                    ;   jl2 = jl  
     609            ELSE                  ;   jl2 = jl  
    718610            ENDIF 
    719611 
    … …  
    772664            zaTsfn(ii,ij,jl2)  = zaTsfn(ii,ij,jl2) + zdaTsf  
    773665 
    774          END DO                 ! ji 
     666         END DO 
    775667 
    776668         !------------------ 
    … …  
    779671 
    780672         DO jk = 1, nlay_i 
    781 !CDIR NODEP 
    782673            DO ji = 1, nbrem 
    783674               ii = nind_i(ji) 
    … …  
    785676 
    786677               jl1 = zdonor(ii,ij,jl) 
    787                IF (jl1 .EQ. jl) THEN 
     678               IF (jl1 == jl) THEN 
    788679                  jl2 = jl+1 
    789680               ELSE             ! n1 = n+1 
    … …  
    794685               e_i(ii,ij,jk,jl1) =  e_i(ii,ij,jk,jl1) - zdeice 
    795686               e_i(ii,ij,jk,jl2) =  e_i(ii,ij,jk,jl2) + zdeice  
    796             END DO              ! ji 
    797          END DO                 ! jk 
     687            END DO 
     688         END DO 
    798689 
    799690      END DO                   ! boundaries, 1 to ncat-1 
    … …  
    809700                  ht_i(ji,jj,jl)  =  v_i   (ji,jj,jl) / a_i(ji,jj,jl)  
    810701                  t_su(ji,jj,jl)  =  zaTsfn(ji,jj,jl) / a_i(ji,jj,jl)  
    811                   rswitch         =  1.0 - MAX(0.0,SIGN(1.0,-v_s(ji,jj,jl)+epsi10)) !0 if no ice and 1 if yes 
    812702               ELSE 
    813703                  ht_i(ji,jj,jl)  = 0._wp 
    814                   t_su(ji,jj,jl)  = rtt 
     704                  t_su(ji,jj,jl)  = rt0 
    815705               ENDIF 
    816             END DO                 ! ji 
    817          END DO                 ! jj 
    818       END DO                    ! jl 
     706            END DO 
     707         END DO 
     708      END DO 
    819709      ! 
    820710      CALL wrk_dealloc( jpi,jpj,jpl, zaTsfn ) 
    … …  
    846736      REAL(wp), POINTER, DIMENSION(:,:) ::   vt_s_init, vt_s_final   ! snow volume summed over categories 
    847737      !!------------------------------------------------------------------ 
    848       !! clem 2014/04: be carefull, rebining does not conserve salt(maybe?) => the difference is taken into account in limupdate 
    849738       
    850739      CALL wrk_alloc( jpi,jpj,jpl, zdonor )   ! interger 
    … …  
    864753         DO jj = 1, jpj 
    865754            DO ji = 1, jpi  
    866                IF( a_i(ji,jj,jl) > epsi10 ) THEN  
    867                   ht_i(ji,jj,jl) = v_i(ji,jj,jl) / a_i(ji,jj,jl) 
    868                ELSE 
    869                   ht_i(ji,jj,jl) = 0._wp 
    870                ENDIF 
     755               rswitch = MAX( 0._wp , SIGN( 1._wp, a_i(ji,jj,jl) - epsi10 ) ) 
     756               ht_i(ji,jj,jl) = v_i (ji,jj,jl) / MAX( a_i(ji,jj,jl) , epsi10 ) * rswitch 
    871757            END DO 
    872758         END DO 
    … …  
    874760 
    875761      !------------------------------------------------------------------------------ 
    876       ! 2) Make sure thickness of cat klbnd is at least hi_max(klbnd) 
    877       !------------------------------------------------------------------------------ 
    878       DO jj = 1, jpj  
    879          DO ji = 1, jpi  
    880             IF( a_i(ji,jj,klbnd) > epsi10 ) THEN 
    881                IF( ht_i(ji,jj,klbnd) <= hi_max(0) .AND. hi_max(0) > 0._wp ) THEN 
    882                   a_i(ji,jj,klbnd)  = v_i(ji,jj,klbnd) / hi_max(0)  
    883                   ht_i(ji,jj,klbnd) = hi_max(0) 
    884                ENDIF 
    885             ENDIF 
    886          END DO 
    887       END DO 
    888  
    889       !------------------------------------------------------------------------------ 
    890       ! 3) If a category thickness is not in bounds, shift the 
     762      ! 2) If a category thickness is not in bounds, shift the 
    891763      ! entire area, volume, and energy to the neighboring category 
    892764      !------------------------------------------------------------------------------ 
    … …  
    917789                  zdonor(ji,jj,jl)  = jl  
    918790                  ! begin TECLIM change 
    919                   !zdaice(ji,jj,jl)  = a_i(ji,jj,jl) 
    920                   !zdvice(ji,jj,jl)  = v_i(ji,jj,jl) 
    921791                  !zdaice(ji,jj,jl)  = a_i(ji,jj,jl) * 0.5_wp 
    922792                  !zdvice(ji,jj,jl)  = v_i(ji,jj,jl)-zdaice(ji,jj,jl)*(hi_max(jl)+hi_max(jl-1)) * 0.5_wp 
    923793                  ! end TECLIM change  
    924794                  ! clem: how much of a_i you send in cat sup is somewhat arbitrary 
    925                   zdaice(ji,jj,jl)  = a_i(ji,jj,jl) * ( ht_i(ji,jj,jl) - hi_max(jl) + epsi10 ) / ht_i(ji,jj,jl)   
    926                   zdvice(ji,jj,jl)  = v_i(ji,jj,jl) - ( a_i(ji,jj,jl) - zdaice(ji,jj,jl) ) * ( hi_max(jl) - epsi10 ) 
     795                  zdaice(ji,jj,jl)  = a_i(ji,jj,jl) * ( ht_i(ji,jj,jl) - hi_max(jl) + epsi20 ) / ht_i(ji,jj,jl)   
     796                  zdvice(ji,jj,jl)  = v_i(ji,jj,jl) - ( a_i(ji,jj,jl) - zdaice(ji,jj,jl) ) * ( hi_max(jl) - epsi20 ) 
    927797               ENDIF 
    928             END DO                 ! ji 
    929          END DO                 ! jj 
     798            END DO 
     799         END DO 
    930800         IF(lk_mpp)   CALL mpp_max( zshiftflag ) 
    931801 
    … …  
    938808         ENDIF 
    939809         ! 
    940       END DO                    ! jl 
     810      END DO 
    941811 
    942812      !---------------------------- 
    … …  
    951821         zshiftflag = 0 
    952822 
    953 !clem-change 
    954823         DO jj = 1, jpj 
    955824            DO ji = 1, jpi 
    … …  
    961830                  zdvice(ji,jj,jl) = v_i(ji,jj,jl+1) 
    962831               ENDIF 
    963             END DO                 ! ji 
    964          END DO                 ! jj 
     832            END DO 
     833         END DO 
    965834 
    966835         IF(lk_mpp)   CALL mpp_max( zshiftflag ) 
    … …  
    973842            zdvice(:,:,jl) = 0._wp 
    974843         ENDIF 
    975 !clem-change 
    976  
    977 !         ! clem-change begin: why not doing that? 
    978 !         DO jj = 1, jpj 
    979 !            DO ji = 1, jpi 
    980 !               IF( a_i(ji,jj,jl+1) > epsi10 .AND. ht_i(ji,jj,jl+1) <= hi_max(jl) ) THEN 
    981 !                  ht_i(ji,jj,jl+1) = hi_max(jl) + epsi10 
    982 !                  a_i (ji,jj,jl+1) = v_i(ji,jj,jl+1) / ht_i(ji,jj,jl+1)  
    983 !               ENDIF 
    984 !            END DO                 ! ji 
    985 !         END DO                 ! jj 
    986          ! clem-change end 
    987  
    988       END DO                    ! jl 
     844 
     845      END DO 
    989846 
    990847      !------------------------------------------------------------------------------ 
    991       ! 4) Conservation check 
     848      ! 3) Conservation check 
    992849      !------------------------------------------------------------------------------ 
    993850 
    … …  
    1013870   !!---------------------------------------------------------------------- 
    1014871CONTAINS 
    1015    SUBROUTINE lim_itd_th           ! Empty routines 
    1016    END SUBROUTINE lim_itd_th 
    1017    SUBROUTINE lim_itd_th_ini 
    1018    END SUBROUTINE lim_itd_th_ini 
    1019872   SUBROUTINE lim_itd_th_rem 
    1020873   END SUBROUTINE lim_itd_th_rem 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/LIM_SRC_3/limmsh.F90

    r5312 r5313  
    2323   PRIVATE 
    2424 
    25    PUBLIC   lim_msh   ! routine called by ice_ini.F90 
     25   PUBLIC   lim_msh   ! routine called by sbcice_lim.F90 
    2626 
    2727   !!---------------------------------------------------------------------- 
    … …  
    4141      !!              - Definition of some constants linked with the grid 
    4242      !!              - Definition of the metric coef. for the sea/ice 
    43       !!              - Initialization of the ice masks (tmsk, umsk) 
    4443      !!  
    4544      !! Reference  : Deleersnijder et al. Ocean Modelling 100, 7-10  
    … …  
    103102!!gm end 
    104103 
    105       !                           !==  ice masks  ==! 
    106       tms(:,:) = tmask(:,:,1)             ! ice T-point  : use surface tmask 
    107       tmu(:,:) = umask(:,:,1)             ! ice U-point  : use surface umask  (C-grid EVP) 
    108       tmv(:,:) = vmask(:,:,1)             ! ice V-point  : use surface vmask  (C-grid EVP) 
    109       DO jj = 1, jpjm1                    ! ice F-point  : recompute fmask (due to nn_shlat) 
    110          DO ji = 1 , jpim1   ! NO vector opt. 
    111             tmf(ji,jj) =  tms(ji,jj) * tms(ji+1,jj) * tms(ji,jj+1) * tms(ji+1,jj+1) 
    112          END DO 
    113       END DO 
    114       CALL lbc_lnk( tmf(:,:), 'F', 1. )           ! lateral boundary conditions 
    115  
    116       !                           !==  unmasked and masked area of T-grid cell 
    117       area(:,:) = e1t(:,:) * e2t(:,:) 
    118104      ! 
    119105   END SUBROUTINE lim_msh 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/LIM_SRC_3/limrhg.F90

    r5312 r5313  
    102102      !!                 and charge ellipse. 
    103103      !!                 The user should make sure that the parameters 
    104       !!                 nevp, telast and creepl maintain stress state 
     104      !!                 nn_nevp, elastic time scale and rn_creepl maintain stress state 
    105105      !!                 on the charge ellipse for plastic flow 
    106106      !!                 e.g. in the Canadian Archipelago 
    … …  
    108108      !! References : Hunke and Dukowicz, JPO97 
    109109      !!              Bouillon et al., Ocean Modelling 2009 
    110       !!              Vancoppenolle et al., Ocean Modelling 2008 
    111110      !!------------------------------------------------------------------- 
    112111      INTEGER, INTENT(in) ::   k_j1    ! southern j-index for ice computation 
    … …  
    117116      CHARACTER (len=50) ::   charout 
    118117      REAL(wp) ::   zt11, zt12, zt21, zt22, ztagnx, ztagny, delta                         ! 
    119       REAL(wp) ::   za, zstms, zmask   ! local scalars 
    120       REAL(wp) ::   zc1, zc2, zc3             ! ice mass 
    121  
    122       REAL(wp) ::   dtevp              ! time step for subcycling 
    123       REAL(wp) ::   dtotel, ecc2, ecci ! square of yield ellipse eccenticity 
    124       REAL(wp) ::   z0, zr, zcca, zccb ! temporary scalars 
    125       REAL(wp) ::   zu_ice2, zv_ice1   ! 
    126       REAL(wp) ::   zddc, zdtc         ! delta on corners and on centre 
    127       REAL(wp) ::   zdst               ! shear at the center of the grid point 
    128       REAL(wp) ::   zdsshx, zdsshy     ! term for the gradient of ocean surface 
    129       REAL(wp) ::   sigma1, sigma2     ! internal ice stress 
     118      REAL(wp) ::   za, zstms          ! local scalars 
     119      REAL(wp) ::   zc1, zc2, zc3      ! ice mass 
     120 
     121      REAL(wp) ::   dtevp , z1_dtevp              ! time step for subcycling 
     122      REAL(wp) ::   dtotel, z1_dtotel, ecc2, ecci ! square of yield ellipse eccenticity 
     123      REAL(wp) ::   z0, zr, zcca, zccb            ! temporary scalars 
     124      REAL(wp) ::   zu_ice2, zv_ice1              ! 
     125      REAL(wp) ::   zddc, zdtc                    ! delta on corners and on centre 
     126      REAL(wp) ::   zdst                          ! shear at the center of the grid point 
     127      REAL(wp) ::   zdsshx, zdsshy                ! term for the gradient of ocean surface 
     128      REAL(wp) ::   sigma1, sigma2                ! internal ice stress 
    130129 
    131130      REAL(wp) ::   zresm         ! Maximal error on ice velocity 
    132       REAL(wp) ::   zdummy        ! dummy argument 
    133131      REAL(wp) ::   zintb, zintn  ! dummy argument 
    134132 
    … …  
    139137      REAL(wp), POINTER, DIMENSION(:,:) ::   zcorl1, zcorl2   ! coriolis parameter on U/V points 
    140138      REAL(wp), POINTER, DIMENSION(:,:) ::   za1ct , za2ct    ! temporary arrays 
    141       REAL(wp), POINTER, DIMENSION(:,:) ::   u_oce1, v_oce1   ! ocean u/v component on U points                            
    142       REAL(wp), POINTER, DIMENSION(:,:) ::   u_oce2, v_oce2   ! ocean u/v component on V points 
     139      REAL(wp), POINTER, DIMENSION(:,:) ::   v_oce1           ! ocean u/v component on U points                            
     140      REAL(wp), POINTER, DIMENSION(:,:) ::   u_oce2           ! ocean u/v component on V points 
    143141      REAL(wp), POINTER, DIMENSION(:,:) ::   u_ice2, v_ice1   ! ice u/v component on V/U point 
    144142      REAL(wp), POINTER, DIMENSION(:,:) ::   zf1   , zf2      ! arrays for internal stresses 
     143      REAL(wp), POINTER, DIMENSION(:,:) ::   zmask            ! mask ocean grid points 
    145144       
    146145      REAL(wp), POINTER, DIMENSION(:,:) ::   zdt              ! tension at centre of grid cells 
    … …  
    152151                                                              !   ocean surface (ssh_m) if ice is not embedded 
    153152                                                              !   ice top surface if ice is embedded    
     153 
     154      REAL(wp), PARAMETER               ::   zepsi = 1.0e-20_wp ! tolerance parameter 
     155      REAL(wp), PARAMETER               ::   zvmin = 1.0e-03_wp ! ice volume below which ice velocity equals ocean velocity 
    154156      !!------------------------------------------------------------------- 
    155157 
    156158      CALL wrk_alloc( jpi,jpj, zpresh, zfrld1, zmass1, zcorl1, za1ct , zpreshc, zfrld2, zmass2, zcorl2, za2ct ) 
    157       CALL wrk_alloc( jpi,jpj, u_oce1, u_oce2, u_ice2, v_oce1 , v_oce2, v_ice1                ) 
     159      CALL wrk_alloc( jpi,jpj, u_oce2, u_ice2, v_oce1 , v_ice1 , zmask               ) 
    158160      CALL wrk_alloc( jpi,jpj, zf1   , zu_ice, zf2   , zv_ice , zdt    , zds  ) 
    159161      CALL wrk_alloc( jpi,jpj, zdt   , zds   , zs1   , zs2   , zs12   , zresr , zpice                 ) 
    … …  
    161163#if  defined key_lim2 && ! defined key_lim2_vp 
    162164# if defined key_agrif 
    163      USE ice_2, vt_s => hsnm 
    164      USE ice_2, vt_i => hicm 
     165      USE ice_2, vt_s => hsnm 
     166      USE ice_2, vt_i => hicm 
    165167# else 
    166      vt_s => hsnm 
    167      vt_i => hicm 
     168      vt_s => hsnm 
     169      vt_i => hicm 
    168170# endif 
    169      at_i(:,:) = 1. - frld(:,:) 
     171      at_i(:,:) = 1. - frld(:,:) 
    170172#endif 
    171173#if defined key_agrif && defined key_lim2  
    172     CALL agrif_rhg_lim2_load      ! First interpolation of coarse values 
     174      CALL agrif_rhg_lim2_load      ! First interpolation of coarse values 
    173175#endif 
    174176      ! 
    … …  
    186188 
    187189#if defined key_lim3 
    188       CALL lim_itd_me_icestrength( ridge_scheme_swi )      ! LIM-3: Ice strength on T-points 
    189 #endif 
    190  
    191 !CDIR NOVERRCHK 
     190      CALL lim_itd_me_icestrength( nn_icestr )      ! LIM-3: Ice strength on T-points 
     191#endif 
     192 
    192193      DO jj = k_j1 , k_jpj       ! Ice mass and temp variables 
    193 !CDIR NOVERRCHK 
    194194         DO ji = 1 , jpi 
    195195#if defined key_lim3 
    196             zpresh(ji,jj) = tms(ji,jj) *  strength(ji,jj) 
     196            zpresh(ji,jj) = tmask(ji,jj,1) *  strength(ji,jj) 
    197197#endif 
    198198#if defined key_lim2 
    199             zpresh(ji,jj) = tms(ji,jj) *  pstar * vt_i(ji,jj) * EXP( -c_rhg * (1. - at_i(ji,jj) ) ) 
    200 #endif 
    201             ! tmi = 1 where there is ice or on land 
    202             tmi(ji,jj)    = 1._wp - ( 1._wp - MAX( 0._wp , SIGN ( 1._wp , vt_i(ji,jj) - epsd ) ) ) * tms(ji,jj) 
     199            zpresh(ji,jj) = tmask(ji,jj,1) *  pstar * vt_i(ji,jj) * EXP( -c_rhg * (1. - at_i(ji,jj) ) ) 
     200#endif 
     201            ! zmask = 1 where there is ice or on land 
     202            zmask(ji,jj)    = 1._wp - ( 1._wp - MAX( 0._wp , SIGN ( 1._wp , vt_i(ji,jj) - zepsi ) ) ) * tmask(ji,jj,1) 
    203203         END DO 
    204204      END DO 
    … …  
    206206      ! Ice strength on grid cell corners (zpreshc) 
    207207      ! needed for calculation of shear stress  
    208 !CDIR NOVERRCHK 
    209208      DO jj = k_j1+1, k_jpj-1 
    210 !CDIR NOVERRCHK 
    211209         DO ji = 2, jpim1 !RB caution no fs_ (ji+1,jj+1) 
    212             zstms          =  tms(ji+1,jj+1) * wght(ji+1,jj+1,2,2) + & 
    213                &              tms(ji,jj+1)   * wght(ji+1,jj+1,1,2) + & 
    214                &              tms(ji+1,jj)   * wght(ji+1,jj+1,2,1) + & 
    215                &              tms(ji,jj)     * wght(ji+1,jj+1,1,1) 
    216             zpreshc(ji,jj) = (  zpresh(ji+1,jj+1) * wght(ji+1,jj+1,2,2) + & 
    217                &                zpresh(ji,jj+1)   * wght(ji+1,jj+1,1,2) + & 
    218                &                zpresh(ji+1,jj)   * wght(ji+1,jj+1,2,1) + &  
    219                &                zpresh(ji,jj)     * wght(ji+1,jj+1,1,1)   & 
    220                &             ) / MAX( zstms, epsd ) 
     210            zstms          =  tmask(ji+1,jj+1,1) * wght(ji+1,jj+1,2,2) + tmask(ji,jj+1,1) * wght(ji+1,jj+1,1,2) +   & 
     211               &              tmask(ji+1,jj,1)   * wght(ji+1,jj+1,2,1) + tmask(ji,jj,1)   * wght(ji+1,jj+1,1,1) 
     212            zpreshc(ji,jj) = ( zpresh(ji+1,jj+1) * wght(ji+1,jj+1,2,2) + zpresh(ji,jj+1) * wght(ji+1,jj+1,1,2) +   & 
     213               &               zpresh(ji+1,jj)   * wght(ji+1,jj+1,2,1) + zpresh(ji,jj)   * wght(ji+1,jj+1,1,1)     & 
     214               &             ) / MAX( zstms, zepsi ) 
    221215         END DO 
    222216      END DO 
    223  
    224217      CALL lbc_lnk( zpreshc(:,:), 'F', 1. ) 
    225218      ! 
    … …  
    236229      !  zcorl2: Coriolis parameter on V-points                             
    237230      !  (ztagnx,ztagny): wind stress on U/V points                        
    238       !  u_oce1: ocean u component on u points                            
    239231      !  v_oce1: ocean v component on u points                           
    240232      !  u_oce2: ocean u component on v points                          
    241       !  v_oce2: ocean v component on v points                         
    242233 
    243234      IF( nn_ice_embd == 2 ) THEN             !== embedded sea ice: compute representative ice top surface ==! 
    244           !                                             
    245           ! average interpolation coeff as used in dynspg = (1/nn_fsbc) * {SUM[n/nn_fsbc], n=0,nn_fsbc-1} 
    246           !                                               = (1/nn_fsbc)^2 * {SUM[n], n=0,nn_fsbc-1} 
     235         !                                             
     236         ! average interpolation coeff as used in dynspg = (1/nn_fsbc) * {SUM[n/nn_fsbc], n=0,nn_fsbc-1} 
     237         !                                               = (1/nn_fsbc)^2 * {SUM[n], n=0,nn_fsbc-1} 
    247238         zintn = REAL( nn_fsbc - 1 ) / REAL( nn_fsbc ) * 0.5_wp      
    248           ! 
    249           ! average interpolation coeff as used in dynspg = (1/nn_fsbc) * {SUM[1-n/nn_fsbc], n=0,nn_fsbc-1} 
    250           !                                               = (1/nn_fsbc)^2 * (nn_fsbc^2 - {SUM[n], n=0,nn_fsbc-1}) 
     239         ! 
     240         ! average interpolation coeff as used in dynspg = (1/nn_fsbc) * {SUM[1-n/nn_fsbc], n=0,nn_fsbc-1} 
     241         !                                               = (1/nn_fsbc)^2 * (nn_fsbc^2 - {SUM[n], n=0,nn_fsbc-1}) 
    251242         zintb = REAL( nn_fsbc + 1 ) / REAL( nn_fsbc ) * 0.5_wp 
    252           ! 
     243         ! 
    253244         zpice(:,:) = ssh_m(:,:) + (  zintn * snwice_mass(:,:) +  zintb * snwice_mass_b(:,:)  ) * r1_rau0 
    254           ! 
     245         ! 
    255246      ELSE                                    !== non-embedded sea ice: use ocean surface for slope calculation ==! 
    256247         zpice(:,:) = ssh_m(:,:) 
    … …  
    260251         DO ji = fs_2, fs_jpim1 
    261252 
    262             zc1 = tms(ji  ,jj  ) * ( rhosn * vt_s(ji  ,jj  ) + rhoic * vt_i(ji  ,jj  ) ) 
    263             zc2 = tms(ji+1,jj  ) * ( rhosn * vt_s(ji+1,jj  ) + rhoic * vt_i(ji+1,jj  ) ) 
    264             zc3 = tms(ji  ,jj+1) * ( rhosn * vt_s(ji  ,jj+1) + rhoic * vt_i(ji  ,jj+1) ) 
    265  
    266             zt11 = tms(ji  ,jj) * e1t(ji  ,jj) 
    267             zt12 = tms(ji+1,jj) * e1t(ji+1,jj) 
    268             zt21 = tms(ji,jj  ) * e2t(ji,jj  ) 
    269             zt22 = tms(ji,jj+1) * e2t(ji,jj+1) 
     253            zc1 = tmask(ji  ,jj  ,1) * ( rhosn * vt_s(ji  ,jj  ) + rhoic * vt_i(ji  ,jj  ) ) 
     254            zc2 = tmask(ji+1,jj  ,1) * ( rhosn * vt_s(ji+1,jj  ) + rhoic * vt_i(ji+1,jj  ) ) 
     255            zc3 = tmask(ji  ,jj+1,1) * ( rhosn * vt_s(ji  ,jj+1) + rhoic * vt_i(ji  ,jj+1) ) 
     256 
     257            zt11 = tmask(ji  ,jj,1) * e1t(ji  ,jj) 
     258            zt12 = tmask(ji+1,jj,1) * e1t(ji+1,jj) 
     259            zt21 = tmask(ji,jj  ,1) * e2t(ji,jj  ) 
     260            zt22 = tmask(ji,jj+1,1) * e2t(ji,jj+1) 
    270261 
    271262            ! Leads area. 
    272             zfrld1(ji,jj) = ( zt12 * ( 1.0 - at_i(ji,jj) ) + zt11 * ( 1.0 - at_i(ji+1,jj) ) ) / ( zt11 + zt12 + epsd ) 
    273             zfrld2(ji,jj) = ( zt22 * ( 1.0 - at_i(ji,jj) ) + zt21 * ( 1.0 - at_i(ji,jj+1) ) ) / ( zt21 + zt22 + epsd ) 
     263            zfrld1(ji,jj) = ( zt12 * ( 1.0 - at_i(ji,jj) ) + zt11 * ( 1.0 - at_i(ji+1,jj) ) ) / ( zt11 + zt12 + zepsi ) 
     264            zfrld2(ji,jj) = ( zt22 * ( 1.0 - at_i(ji,jj) ) + zt21 * ( 1.0 - at_i(ji,jj+1) ) ) / ( zt21 + zt22 + zepsi ) 
    274265 
    275266            ! Mass, coriolis coeff. and currents 
    276             zmass1(ji,jj) = ( zt12*zc1 + zt11*zc2 ) / (zt11+zt12+epsd) 
    277             zmass2(ji,jj) = ( zt22*zc1 + zt21*zc3 ) / (zt21+zt22+epsd) 
    278             zcorl1(ji,jj) = zmass1(ji,jj) * ( e1t(ji+1,jj)*fcor(ji,jj) + e1t(ji,jj)*fcor(ji+1,jj) )   & 
    279                &                          / ( e1t(ji,jj) + e1t(ji+1,jj) + epsd ) 
    280             zcorl2(ji,jj) = zmass2(ji,jj) * ( e2t(ji,jj+1)*fcor(ji,jj) + e2t(ji,jj)*fcor(ji,jj+1) )   & 
    281                &                          / ( e2t(ji,jj+1) + e2t(ji,jj) + epsd ) 
     267            zmass1(ji,jj) = ( zt12 * zc1 + zt11 * zc2 ) / ( zt11 + zt12 + zepsi ) 
     268            zmass2(ji,jj) = ( zt22 * zc1 + zt21 * zc3 ) / ( zt21 + zt22 + zepsi ) 
     269            zcorl1(ji,jj) = zmass1(ji,jj) * ( e1t(ji+1,jj) * fcor(ji,jj) + e1t(ji,jj) * fcor(ji+1,jj) )   & 
     270               &                          / ( e1t(ji,jj) + e1t(ji+1,jj) + zepsi ) 
     271            zcorl2(ji,jj) = zmass2(ji,jj) * ( e2t(ji,jj+1) * fcor(ji,jj) + e2t(ji,jj) * fcor(ji,jj+1) )   & 
     272               &                          / ( e2t(ji,jj+1) + e2t(ji,jj) + zepsi ) 
    282273            ! 
    283             u_oce1(ji,jj)  = u_oce(ji,jj) 
    284             v_oce2(ji,jj)  = v_oce(ji,jj) 
    285  
    286274            ! Ocean has no slip boundary condition 
    287             v_oce1(ji,jj)  = 0.5*( (v_oce(ji,jj)+v_oce(ji,jj-1))*e1t(ji,jj)    & 
    288                &                 +(v_oce(ji+1,jj)+v_oce(ji+1,jj-1))*e1t(ji+1,jj)) & 
    289                &               /(e1t(ji+1,jj)+e1t(ji,jj)) * tmu(ji,jj)   
    290  
    291             u_oce2(ji,jj)  = 0.5*((u_oce(ji,jj)+u_oce(ji-1,jj))*e2t(ji,jj)     & 
    292                &                 +(u_oce(ji,jj+1)+u_oce(ji-1,jj+1))*e2t(ji,jj+1)) & 
    293                &                / (e2t(ji,jj+1)+e2t(ji,jj)) * tmv(ji,jj) 
     275            v_oce1(ji,jj)  = 0.5 * ( ( v_oce(ji  ,jj) + v_oce(ji  ,jj-1) ) * e1t(ji,jj)      & 
     276               &                   + ( v_oce(ji+1,jj) + v_oce(ji+1,jj-1) ) * e1t(ji+1,jj) ) & 
     277               &                   / ( e1t(ji+1,jj) + e1t(ji,jj) ) * umask(ji,jj,1)   
     278 
     279            u_oce2(ji,jj)  = 0.5 * ( ( u_oce(ji,jj  ) + u_oce(ji-1,jj  ) ) * e2t(ji,jj)      & 
     280               &                   + ( u_oce(ji,jj+1) + u_oce(ji-1,jj+1) ) * e2t(ji,jj+1) ) & 
     281               &                   / ( e2t(ji,jj+1) + e2t(ji,jj) ) * vmask(ji,jj,1) 
    294282 
    295283            ! Wind stress at U,V-point 
    … …  
    303291            ! include it later 
    304292 
    305             zdsshx =  ( zpice(ji+1,jj) - zpice(ji,jj) ) / e1u(ji,jj) 
    306             zdsshy =  ( zpice(ji,jj+1) - zpice(ji,jj) ) / e2v(ji,jj) 
     293            zdsshx =  ( zpice(ji+1,jj) - zpice(ji,jj) ) * r1_e1u(ji,jj) 
     294            zdsshy =  ( zpice(ji,jj+1) - zpice(ji,jj) ) * r1_e2v(ji,jj) 
    307295 
    308296            za1ct(ji,jj) = ztagnx - zmass1(ji,jj) * grav * zdsshx 
    … …  
    318306      ! 
    319307      ! Time step for subcycling 
    320       dtevp  = rdt_ice / nevp 
     308      dtevp  = rdt_ice / nn_nevp 
     309#if defined key_lim3 
     310      dtotel = dtevp / ( 2._wp * rn_relast * rdt_ice ) 
     311#else 
    321312      dtotel = dtevp / ( 2._wp * telast ) 
    322  
     313#endif 
     314      z1_dtotel = 1._wp / ( 1._wp + dtotel ) 
     315      z1_dtevp  = 1._wp / dtevp 
    323316      !-ecc2: square of yield ellipse eccenticrity (reminder: must become a namelist parameter) 
    324       ecc2 = ecc * ecc 
     317      ecc2 = rn_ecc * rn_ecc 
    325318      ecci = 1. / ecc2 
    326319 
    … …  
    331324 
    332325      !                                               !----------------------! 
    333       DO jter = 1 , nevp                              !    loop over jter    ! 
     326      DO jter = 1 , nn_nevp                           !    loop over jter    ! 
    334327         !                                            !----------------------!         
    335328         DO jj = k_j1, k_jpj-1 
    … …  
    339332 
    340333         DO jj = k_j1+1, k_jpj-1 
    341             DO ji = fs_2, jpim1   !RB bug no vect opt due to tmi 
     334            DO ji = fs_2, fs_jpim1   !RB bug no vect opt due to zmask 
    342335 
    343336               !   
    … …  
    360353               ! 
    361354               ! 
    362                divu_i(ji,jj) = ( e2u(ji,jj)*u_ice(ji,jj)                      & 
    363                   &             -e2u(ji-1,jj)*u_ice(ji-1,jj)                  & 
    364                   &             +e1v(ji,jj)*v_ice(ji,jj)                      & 
    365                   &             -e1v(ji,jj-1)*v_ice(ji,jj-1)                  & 
    366                   &             )                                             & 
    367                   &            / area(ji,jj) 
    368  
    369                zdt(ji,jj) = ( ( u_ice(ji,jj)/e2u(ji,jj)                    & 
    370                   &            -u_ice(ji-1,jj)/e2u(ji-1,jj)                & 
    371                   &           )*e2t(ji,jj)*e2t(ji,jj)                      & 
    372                   &          -( v_ice(ji,jj)/e1v(ji,jj)                    & 
    373                   &            -v_ice(ji,jj-1)/e1v(ji,jj-1)                & 
    374                   &           )*e1t(ji,jj)*e1t(ji,jj)                      & 
    375                   &         )                                              & 
    376                   &        / area(ji,jj) 
     355               divu_i(ji,jj) = (  e2u(ji,jj) * u_ice(ji,jj) - e2u(ji-1,jj) * u_ice(ji-1,jj)   & 
     356                  &             + e1v(ji,jj) * v_ice(ji,jj) - e1v(ji,jj-1) * v_ice(ji,jj-1)   & 
     357                  &            ) * r1_e12t(ji,jj) 
     358 
     359               zdt(ji,jj) = ( ( u_ice(ji,jj) * r1_e2u(ji,jj) - u_ice(ji-1,jj) * r1_e2u(ji-1,jj) ) * e2t(ji,jj) * e2t(ji,jj)   & 
     360                  &         - ( v_ice(ji,jj) * r1_e1v(ji,jj) - v_ice(ji,jj-1) * r1_e1v(ji,jj-1) ) * e1t(ji,jj) * e1t(ji,jj)   & 
     361                  &         ) * r1_e12t(ji,jj) 
    377362 
    378363               ! 
    379                zds(ji,jj) = ( ( u_ice(ji,jj+1)/e1u(ji,jj+1)                & 
    380                   &            -u_ice(ji,jj)/e1u(ji,jj)                    & 
    381                   &           )*e1f(ji,jj)*e1f(ji,jj)                      & 
    382                   &          +( v_ice(ji+1,jj)/e2v(ji+1,jj)                & 
    383                   &            -v_ice(ji,jj)/e2v(ji,jj)                    & 
    384                   &           )*e2f(ji,jj)*e2f(ji,jj)                      & 
    385                   &         )                                              & 
    386                   &        / ( e1f(ji,jj) * e2f(ji,jj) ) * ( 2.0 - tmf(ji,jj) ) & 
    387                   &        * tmi(ji,jj) * tmi(ji,jj+1)                     & 
    388                   &        * tmi(ji+1,jj) * tmi(ji+1,jj+1) 
    389  
    390  
    391                v_ice1(ji,jj)  = 0.5*( (v_ice(ji,jj)+v_ice(ji,jj-1))*e1t(ji+1,jj)   & 
    392                   &                 +(v_ice(ji+1,jj)+v_ice(ji+1,jj-1))*e1t(ji,jj)) & 
    393                   &               /(e1t(ji+1,jj)+e1t(ji,jj)) * tmu(ji,jj)  
    394  
    395                u_ice2(ji,jj)  = 0.5*( (u_ice(ji,jj)+u_ice(ji-1,jj))*e2t(ji,jj+1)   & 
    396                   &                 +(u_ice(ji,jj+1)+u_ice(ji-1,jj+1))*e2t(ji,jj)) & 
    397                   &               /(e2t(ji,jj+1)+e2t(ji,jj)) * tmv(ji,jj) 
    398  
    399             END DO 
    400          END DO 
    401          CALL lbc_lnk( v_ice1, 'U', -1. )   ;   CALL lbc_lnk( u_ice2, 'V', -1. )      ! lateral boundary cond. 
    402  
    403 !CDIR NOVERRCHK 
     364               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)   & 
     365                  &         + ( v_ice(ji+1,jj) * r1_e2v(ji+1,jj) - v_ice(ji,jj) * r1_e2v(ji,jj) ) * e2f(ji,jj) * e2f(ji,jj)   & 
     366                  &         ) * r1_e12f(ji,jj) * ( 2._wp - fmask(ji,jj,1) )   & 
     367                  &         * zmask(ji,jj) * zmask(ji,jj+1) * zmask(ji+1,jj) * zmask(ji+1,jj+1) 
     368 
     369 
     370               v_ice1(ji,jj)  = 0.5_wp * ( ( v_ice(ji  ,jj) + v_ice(ji  ,jj-1) ) * e1t(ji+1,jj)     & 
     371                  &                      + ( v_ice(ji+1,jj) + v_ice(ji+1,jj-1) ) * e1t(ji  ,jj) )   & 
     372                  &                      / ( e1t(ji+1,jj) + e1t(ji,jj) ) * umask(ji,jj,1)  
     373 
     374               u_ice2(ji,jj)  = 0.5_wp * ( ( u_ice(ji,jj  ) + u_ice(ji-1,jj  ) ) * e2t(ji,jj+1)     & 
     375                  &                      + ( u_ice(ji,jj+1) + u_ice(ji-1,jj+1) ) * e2t(ji,jj  ) )   & 
     376                  &                      / ( e2t(ji,jj+1) + e2t(ji,jj) ) * vmask(ji,jj,1) 
     377            END DO 
     378         END DO 
     379         CALL lbc_lnk( v_ice1  , 'U', -1. )   ;   CALL lbc_lnk( u_ice2  , 'V', -1. )      ! lateral boundary cond. 
     380 
    404381         DO jj = k_j1+1, k_jpj-1 
    405 !CDIR NOVERRCHK 
    406382            DO ji = fs_2, fs_jpim1 
    407383 
    408384               !- Calculate Delta at centre of grid cells 
    409                zdst      = (  e2u(ji  , jj) * v_ice1(ji  ,jj)          & 
    410                   &          - e2u(ji-1, jj) * v_ice1(ji-1,jj)          & 
    411                   &          + e1v(ji, jj  ) * u_ice2(ji,jj  )          & 
    412                   &          - e1v(ji, jj-1) * u_ice2(ji,jj-1)          & 
    413                   &          )                                          & 
    414                   &         / area(ji,jj) 
    415  
    416                delta = SQRT( divu_i(ji,jj)*divu_i(ji,jj) + ( zdt(ji,jj)*zdt(ji,jj) + zdst*zdst ) * usecc2 )   
    417                delta_i(ji,jj) = delta + creepl 
    418                !-Calculate stress tensor components zs1 and zs2  
    419                !-at centre of grid cells (see section 3.5 of CICE user's guide). 
    420                zs1(ji,jj) = ( zs1(ji,jj) + dtotel * ( ( divu_i(ji,jj) / delta_i(ji,jj) - delta / delta_i(ji,jj) )  & 
    421                   &         * zpresh(ji,jj) ) ) / ( 1._wp + dtotel ) 
    422                zs2(ji,jj) = ( zs2(ji,jj) + dtotel * ( ecci * zdt(ji,jj) / delta_i(ji,jj) * zpresh(ji,jj) ) )  & 
    423                   &         / ( 1._wp + dtotel ) 
    424  
    425             END DO 
    426          END DO 
    427  
    428          CALL lbc_lnk( zs1(:,:), 'T', 1. ) 
    429          CALL lbc_lnk( zs2(:,:), 'T', 1. ) 
    430  
    431 !CDIR NOVERRCHK 
    432          DO jj = k_j1+1, k_jpj-1 
    433 !CDIR NOVERRCHK 
    434             DO ji = fs_2, fs_jpim1 
     385               zdst          = ( e2u(ji,jj) * v_ice1(ji,jj) - e2u(ji-1,jj  ) * v_ice1(ji-1,jj  )   & 
     386                  &            + e1v(ji,jj) * u_ice2(ji,jj) - e1v(ji  ,jj-1) * u_ice2(ji  ,jj-1)   & 
     387                  &            ) * r1_e12t(ji,jj) 
     388 
     389               delta          = SQRT( divu_i(ji,jj)**2 + ( zdt(ji,jj)**2 + zdst**2 ) * usecc2 )   
     390               delta_i(ji,jj) = delta + rn_creepl 
     391 
    435392               !- Calculate Delta on corners 
    436                zddc  =      ( ( v_ice1(ji,jj+1)/e1u(ji,jj+1)                & 
    437                   &            -v_ice1(ji,jj)/e1u(ji,jj)                    & 
    438                   &           )*e1f(ji,jj)*e1f(ji,jj)                       & 
    439                   &          +( u_ice2(ji+1,jj)/e2v(ji+1,jj)                & 
    440                   &            -u_ice2(ji,jj)/e2v(ji,jj)                    & 
    441                   &           )*e2f(ji,jj)*e2f(ji,jj)                       & 
    442                   &         )                                               & 
    443                   &        / ( e1f(ji,jj) * e2f(ji,jj) ) 
    444  
    445                zdtc  =      (-( v_ice1(ji,jj+1)/e1u(ji,jj+1)                & 
    446                   &            -v_ice1(ji,jj)/e1u(ji,jj)                    & 
    447                   &           )*e1f(ji,jj)*e1f(ji,jj)                       & 
    448                   &          +( u_ice2(ji+1,jj)/e2v(ji+1,jj)                & 
    449                   &            -u_ice2(ji,jj)/e2v(ji,jj)                    & 
    450                   &           )*e2f(ji,jj)*e2f(ji,jj)                       & 
    451                   &         )                                               & 
    452                   &        / ( e1f(ji,jj) * e2f(ji,jj) ) 
    453  
    454                zddc = SQRT(zddc**2+(zdtc**2+zds(ji,jj)**2)*usecc2) + creepl 
    455  
    456                !-Calculate stress tensor component zs12 at corners (see section 3.5 of CICE user's guide). 
    457                zs12(ji,jj) = ( zs12(ji,jj) + dtotel *  & 
    458                   &          ( ecci * zds(ji,jj) / ( 2._wp * zddc ) * zpreshc(ji,jj) ) )  & 
    459                   &          / ( 1.0 + dtotel )  
    460  
    461             END DO ! ji 
    462          END DO ! jj 
    463  
    464          CALL lbc_lnk( zs12(:,:), 'F', 1. ) 
     393               zddc  = (  ( v_ice1(ji,jj+1) * r1_e1u(ji,jj+1) - v_ice1(ji,jj) * r1_e1u(ji,jj) ) * e1f(ji,jj) * e1f(ji,jj)  & 
     394                  &     + ( u_ice2(ji+1,jj) * r1_e2v(ji+1,jj) - u_ice2(ji,jj) * r1_e2v(ji,jj) ) * e2f(ji,jj) * e2f(ji,jj)  & 
     395                  &    ) * r1_e12f(ji,jj) 
     396 
     397               zdtc  = (- ( v_ice1(ji,jj+1) * r1_e1u(ji,jj+1) - v_ice1(ji,jj) * r1_e1u(ji,jj) ) * e1f(ji,jj) * e1f(ji,jj)  & 
     398                  &     + ( u_ice2(ji+1,jj) * r1_e2v(ji+1,jj) - u_ice2(ji,jj) * r1_e2v(ji,jj) ) * e2f(ji,jj) * e2f(ji,jj)  & 
     399                  &    ) * r1_e12f(ji,jj) 
     400 
     401               zddc = SQRT( zddc**2 + ( zdtc**2 + zds(ji,jj)**2 ) * usecc2 ) + rn_creepl 
     402 
     403               !-Calculate stress tensor components zs1 and zs2 at centre of grid cells (see section 3.5 of CICE user's guide). 
     404               zs1(ji,jj)  = ( zs1 (ji,jj) + dtotel * ( divu_i(ji,jj) - delta ) / delta_i(ji,jj)   * zpresh(ji,jj)   & 
     405                  &          ) * z1_dtotel 
     406               zs2(ji,jj)  = ( zs2 (ji,jj) + dtotel *         ecci * zdt(ji,jj) / delta_i(ji,jj)   * zpresh(ji,jj)   & 
     407                  &          ) * z1_dtotel 
     408               !-Calculate stress tensor component zs12 at corners 
     409               zs12(ji,jj) = ( zs12(ji,jj) + dtotel *         ecci * zds(ji,jj) / ( 2._wp * zddc ) * zpreshc(ji,jj)  & 
     410                  &          ) * z1_dtotel  
     411 
     412            END DO 
     413         END DO 
     414         CALL lbc_lnk( zs1 , 'T', 1. )   ;   CALL lbc_lnk( zs2, 'T', 1. ) 
     415         CALL lbc_lnk( zs12, 'F', 1. ) 
    465416 
    466417         ! Ice internal stresses (Appendix C of Hunke and Dukowicz, 2002) 
    … …  
    468419            DO ji = fs_2, fs_jpim1 
    469420               !- contribution of zs1, zs2 and zs12 to zf1 
    470                zf1(ji,jj) = 0.5*( (zs1(ji+1,jj)-zs1(ji,jj))*e2u(ji,jj) & 
    471                   &              +(zs2(ji+1,jj)*e2t(ji+1,jj)**2-zs2(ji,jj)*e2t(ji,jj)**2)/e2u(ji,jj) & 
    472                   &              +2.0*(zs12(ji,jj)*e1f(ji,jj)**2-zs12(ji,jj-1)*e1f(ji,jj-1)**2)/e1u(ji,jj) & 
    473                   &             ) / ( e1u(ji,jj)*e2u(ji,jj) ) 
     421               zf1(ji,jj) = 0.5 * ( ( zs1(ji+1,jj) - zs1(ji,jj) ) * e2u(ji,jj) & 
     422                  &             + ( zs2(ji+1,jj) * e2t(ji+1,jj)**2 - zs2(ji,jj) * e2t(ji,jj)**2 ) * r1_e2u(ji,jj)          & 
     423                  &             + 2.0 * ( zs12(ji,jj) * e1f(ji,jj)**2 - zs12(ji,jj-1) * e1f(ji,jj-1)**2 ) * r1_e1u(ji,jj) & 
     424                  &                ) * r1_e12u(ji,jj) 
    474425               ! contribution of zs1, zs2 and zs12 to zf2 
    475                zf2(ji,jj) = 0.5*( (zs1(ji,jj+1)-zs1(ji,jj))*e1v(ji,jj) & 
    476                   &              -(zs2(ji,jj+1)*e1t(ji,jj+1)**2 - zs2(ji,jj)*e1t(ji,jj)**2)/e1v(ji,jj) & 
    477                   &              + 2.0*(zs12(ji,jj)*e2f(ji,jj)**2 -    & 
    478                   zs12(ji-1,jj)*e2f(ji-1,jj)**2)/e2v(ji,jj) & 
    479                   &             ) / ( e1v(ji,jj)*e2v(ji,jj) ) 
     426               zf2(ji,jj) = 0.5 * ( ( zs1(ji,jj+1) - zs1(ji,jj) ) * e1v(ji,jj)  & 
     427                  &             - ( zs2(ji,jj+1) * e1t(ji,jj+1)**2 - zs2(ji,jj) * e1t(ji,jj)**2 ) * r1_e1v(ji,jj)          & 
     428                  &             + 2.0 * ( zs12(ji,jj) * e2f(ji,jj)**2 - zs12(ji-1,jj) * e2f(ji-1,jj)**2 ) * r1_e2v(ji,jj)  & 
     429                  &               )  * r1_e12v(ji,jj) 
    480430            END DO 
    481431         END DO 
    … …  
    487437         IF (MOD(jter,2).eq.0) THEN  
    488438 
    489 !CDIR NOVERRCHK 
    490439            DO jj = k_j1+1, k_jpj-1 
    491 !CDIR NOVERRCHK 
    492440               DO ji = fs_2, fs_jpim1 
    493                   zmask        = (1.0-MAX(0._wp,SIGN(1._wp,-zmass1(ji,jj))))*tmu(ji,jj) 
    494                   z0           = zmass1(ji,jj)/dtevp 
     441                  rswitch      = ( 1.0 - MAX( 0._wp, SIGN( 1._wp, -zmass1(ji,jj) ) ) ) * umask(ji,jj,1) 
     442                  z0           = zmass1(ji,jj) * z1_dtevp 
    495443 
    496444                  ! SB modif because ocean has no slip boundary condition 
    497                   zv_ice1       = 0.5*( (v_ice(ji,jj)+v_ice(ji,jj-1))*e1t(ji,jj)         & 
    498                      &                 +(v_ice(ji+1,jj)+v_ice(ji+1,jj-1))*e1t(ji+1,jj))   & 
    499                      &               /(e1t(ji+1,jj)+e1t(ji,jj)) * tmu(ji,jj) 
    500                   za           = rhoco*SQRT((u_ice(ji,jj)-u_oce1(ji,jj))**2 + & 
    501                      (zv_ice1-v_oce1(ji,jj))**2) * (1.0-zfrld1(ji,jj)) 
    502                   zr           = z0*u_ice(ji,jj) + zf1(ji,jj) + za1ct(ji,jj) + & 
    503                      za*(u_oce1(ji,jj)) 
    504                   zcca         = z0+za 
     445                  zv_ice1      = 0.5 * ( ( v_ice(ji  ,jj) + v_ice(ji  ,jj-1) ) * e1t(ji  ,jj)     & 
     446                     &                 + ( v_ice(ji+1,jj) + v_ice(ji+1,jj-1) ) * e1t(ji+1,jj) )   & 
     447                     &                 / ( e1t(ji+1,jj) + e1t(ji,jj) ) * umask(ji,jj,1) 
     448                  za           = rhoco * SQRT( ( u_ice(ji,jj) - u_oce(ji,jj) )**2 +  & 
     449                     &                         ( zv_ice1 - v_oce1(ji,jj) )**2 ) * ( 1.0 - zfrld1(ji,jj) ) 
     450                  zr           = z0 * u_ice(ji,jj) + zf1(ji,jj) + za1ct(ji,jj) + za * u_oce(ji,jj) 
     451                  zcca         = z0 + za 
    505452                  zccb         = zcorl1(ji,jj) 
    506                   u_ice(ji,jj) = (zr+zccb*zv_ice1)/(zcca+epsd)*zmask  
    507  
     453                  u_ice(ji,jj) = ( zr + zccb * zv_ice1 ) / ( zcca + zepsi ) * rswitch  
    508454               END DO 
    509455            END DO 
    … …  
    511457            CALL lbc_lnk( u_ice(:,:), 'U', -1. ) 
    512458#if defined key_agrif && defined key_lim2 
    513             CALL agrif_rhg_lim2( jter, nevp, 'U' ) 
     459            CALL agrif_rhg_lim2( jter, nn_nevp, 'U' ) 
    514460#endif 
    515461#if defined key_bdy 
    … …  
    517463#endif          
    518464 
    519 !CDIR NOVERRCHK 
    520465            DO jj = k_j1+1, k_jpj-1 
    521 !CDIR NOVERRCHK 
    522466               DO ji = fs_2, fs_jpim1 
    523467 
    524                   zmask        = (1.0-MAX(0._wp,SIGN(1._wp,-zmass2(ji,jj))))*tmv(ji,jj) 
    525                   z0           = zmass2(ji,jj)/dtevp 
     468                  rswitch      = ( 1.0 - MAX( 0._wp, SIGN( 1._wp, -zmass2(ji,jj) ) ) ) * vmask(ji,jj,1) 
     469                  z0           = zmass2(ji,jj) * z1_dtevp 
    526470                  ! SB modif because ocean has no slip boundary condition 
    527                   zu_ice2       = 0.5*( (u_ice(ji,jj)+u_ice(ji-1,jj))*e2t(ji,jj)     & 
    528                      &                 + (u_ice(ji,jj+1)+u_ice(ji-1,jj+1))*e2t(ji,jj+1))   & 
    529                      &               /(e2t(ji,jj+1)+e2t(ji,jj)) * tmv(ji,jj) 
    530                   za           = rhoco*SQRT((zu_ice2-u_oce2(ji,jj))**2 + &  
    531                      (v_ice(ji,jj)-v_oce2(ji,jj))**2)*(1.0-zfrld2(ji,jj)) 
    532                   zr           = z0*v_ice(ji,jj) + zf2(ji,jj) + & 
    533                      za2ct(ji,jj) + za*(v_oce2(ji,jj)) 
    534                   zcca         = z0+za 
     471                  zu_ice2      = 0.5 * ( ( u_ice(ji,jj  ) + u_ice(ji-1,jj  ) ) * e2t(ji,jj)       & 
     472                     &                 + ( u_ice(ji,jj+1) + u_ice(ji-1,jj+1) ) * e2t(ji,jj+1) )   & 
     473                     &                 / ( e2t(ji,jj+1) + e2t(ji,jj) ) * vmask(ji,jj,1) 
     474                  za           = rhoco * SQRT( ( zu_ice2 - u_oce2(ji,jj) )**2 +  &  
     475                     &                         ( v_ice(ji,jj) - v_oce(ji,jj))**2 ) * ( 1.0 - zfrld2(ji,jj) ) 
     476                  zr           = z0 * v_ice(ji,jj) + zf2(ji,jj) + za2ct(ji,jj) + za * v_oce(ji,jj) 
     477                  zcca         = z0 + za 
    535478                  zccb         = zcorl2(ji,jj) 
    536                   v_ice(ji,jj) = (zr-zccb*zu_ice2)/(zcca+epsd)*zmask 
    537  
     479                  v_ice(ji,jj) = ( zr - zccb * zu_ice2 ) / ( zcca + zepsi ) * rswitch 
    538480               END DO 
    539481            END DO 
    … …  
    541483            CALL lbc_lnk( v_ice(:,:), 'V', -1. ) 
    542484#if defined key_agrif && defined key_lim2 
    543             CALL agrif_rhg_lim2( jter, nevp, 'V' ) 
     485            CALL agrif_rhg_lim2( jter, nn_nevp, 'V' ) 
    544486#endif 
    545487#if defined key_bdy 
    … …  
    548490 
    549491         ELSE  
    550 !CDIR NOVERRCHK 
    551492            DO jj = k_j1+1, k_jpj-1 
    552 !CDIR NOVERRCHK 
    553493               DO ji = fs_2, fs_jpim1 
    554                   zmask        = (1.0-MAX(0._wp,SIGN(1._wp,-zmass2(ji,jj))))*tmv(ji,jj) 
    555                   z0           = zmass2(ji,jj)/dtevp 
     494                  rswitch      = ( 1.0 - MAX( 0._wp, SIGN( 1._wp, -zmass2(ji,jj) ) ) ) * vmask(ji,jj,1) 
     495                  z0           = zmass2(ji,jj) * z1_dtevp 
    556496                  ! SB modif because ocean has no slip boundary condition 
    557                   zu_ice2       = 0.5*( (u_ice(ji,jj)+u_ice(ji-1,jj))*e2t(ji,jj)      & 
    558                      &                 +(u_ice(ji,jj+1)+u_ice(ji-1,jj+1))*e2t(ji,jj+1))   & 
    559                      &               /(e2t(ji,jj+1)+e2t(ji,jj)) * tmv(ji,jj)    
    560  
    561                   za           = rhoco*SQRT((zu_ice2-u_oce2(ji,jj))**2 + & 
    562                      (v_ice(ji,jj)-v_oce2(ji,jj))**2)*(1.0-zfrld2(ji,jj)) 
    563                   zr           = z0*v_ice(ji,jj) + zf2(ji,jj) + & 
    564                      za2ct(ji,jj) + za*(v_oce2(ji,jj)) 
    565                   zcca         = z0+za 
     497                  zu_ice2      = 0.5 * ( ( u_ice(ji,jj  ) + u_ice(ji-1,jj  ) ) * e2t(ji,jj)       & 
     498                     &                  +( u_ice(ji,jj+1) + u_ice(ji-1,jj+1) ) * e2t(ji,jj+1) )   & 
     499                     &                 / ( e2t(ji,jj+1) + e2t(ji,jj) ) * vmask(ji,jj,1)    
     500 
     501                  za           = rhoco * SQRT( ( zu_ice2 - u_oce2(ji,jj) )**2 +  & 
     502                     &                         ( v_ice(ji,jj) - v_oce(ji,jj) )**2 ) * ( 1.0 - zfrld2(ji,jj) ) 
     503                  zr           = z0 * v_ice(ji,jj) + zf2(ji,jj) + za2ct(ji,jj) + za * v_oce(ji,jj) 
     504                  zcca         = z0 + za 
    566505                  zccb         = zcorl2(ji,jj) 
    567                   v_ice(ji,jj) = (zr-zccb*zu_ice2)/(zcca+epsd)*zmask 
    568  
     506                  v_ice(ji,jj) = ( zr - zccb * zu_ice2 ) / ( zcca + zepsi ) * rswitch 
    569507               END DO 
    570508            END DO 
    … …  
    572510            CALL lbc_lnk( v_ice(:,:), 'V', -1. ) 
    573511#if defined key_agrif && defined key_lim2 
    574             CALL agrif_rhg_lim2( jter, nevp, 'V' ) 
     512            CALL agrif_rhg_lim2( jter, nn_nevp, 'V' ) 
    575513#endif 
    576514#if defined key_bdy 
    … …  
    578516#endif          
    579517 
    580 !CDIR NOVERRCHK 
    581518            DO jj = k_j1+1, k_jpj-1 
    582 !CDIR NOVERRCHK 
    583519               DO ji = fs_2, fs_jpim1 
    584                   zmask        = (1.0-MAX(0._wp,SIGN(1._wp,-zmass1(ji,jj))))*tmu(ji,jj) 
    585                   z0           = zmass1(ji,jj)/dtevp 
    586                   zv_ice1       = 0.5*( (v_ice(ji,jj)+v_ice(ji,jj-1))*e1t(ji,jj)      & 
    587                      &                 +(v_ice(ji+1,jj)+v_ice(ji+1,jj-1))*e1t(ji+1,jj))   & 
    588                      &               /(e1t(ji+1,jj)+e1t(ji,jj)) * tmu(ji,jj) 
    589  
    590                   za           = rhoco*SQRT((u_ice(ji,jj)-u_oce1(ji,jj))**2 + & 
    591                      (zv_ice1-v_oce1(ji,jj))**2)*(1.0-zfrld1(ji,jj)) 
    592                   zr           = z0*u_ice(ji,jj) + zf1(ji,jj) + za1ct(ji,jj) + & 
    593                      za*(u_oce1(ji,jj)) 
    594                   zcca         = z0+za 
     520                  rswitch      = ( 1.0 - MAX( 0._wp, SIGN( 1._wp, -zmass1(ji,jj) ) ) ) * umask(ji,jj,1) 
     521                  z0           = zmass1(ji,jj) * z1_dtevp 
     522                  zv_ice1      = 0.5 * ( ( v_ice(ji  ,jj) + v_ice(ji  ,jj-1) ) * e1t(ji,jj)       & 
     523                     &                 + ( v_ice(ji+1,jj) + v_ice(ji+1,jj-1) ) * e1t(ji+1,jj) )   & 
     524                     &                 / ( e1t(ji+1,jj) + e1t(ji,jj) ) * umask(ji,jj,1) 
     525 
     526                  za           = rhoco * SQRT( ( u_ice(ji,jj) - u_oce(ji,jj) )**2 +  & 
     527                     &                         ( zv_ice1 - v_oce1(ji,jj) )**2 ) * ( 1.0 - zfrld1(ji,jj) ) 
     528                  zr           = z0 * u_ice(ji,jj) + zf1(ji,jj) + za1ct(ji,jj) + za * u_oce(ji,jj) 
     529                  zcca         = z0 + za 
    595530                  zccb         = zcorl1(ji,jj) 
    596                   u_ice(ji,jj) = (zr+zccb*zv_ice1)/(zcca+epsd)*zmask  
    597                END DO ! ji 
    598             END DO ! jj 
     531                  u_ice(ji,jj) = ( zr + zccb * zv_ice1 ) / ( zcca + zepsi ) * rswitch  
     532               END DO 
     533            END DO 
    599534 
    600535            CALL lbc_lnk( u_ice(:,:), 'U', -1. ) 
    601536#if defined key_agrif && defined key_lim2 
    602             CALL agrif_rhg_lim2( jter, nevp, 'U' ) 
     537            CALL agrif_rhg_lim2( jter, nn_nevp, 'U' ) 
    603538#endif 
    604539#if defined key_bdy 
    … …  
    611546            !---  Convergence test. 
    612547            DO jj = k_j1+1 , k_jpj-1 
    613                zresr(:,jj) = MAX( ABS( u_ice(:,jj) - zu_ice(:,jj) ) ,           & 
    614                   ABS( v_ice(:,jj) - zv_ice(:,jj) ) ) 
    615             END DO 
    616             zresm = MAXVAL( zresr( 1:jpi , k_j1+1:k_jpj-1 ) ) 
     548               zresr(:,jj) = MAX( ABS( u_ice(:,jj) - zu_ice(:,jj) ), ABS( v_ice(:,jj) - zv_ice(:,jj) ) ) 
     549            END DO 
     550            zresm = MAXVAL( zresr( 1:jpi, k_j1+1:k_jpj-1 ) ) 
    617551            IF( lk_mpp )   CALL mpp_max( zresm )   ! max over the global domain 
    618552         ENDIF 
    … …  
    625559      ! 4) Prevent ice velocities when the ice is thin 
    626560      !------------------------------------------------------------------------------! 
    627       ! If the ice thickness is below hminrhg (5cm) then ice velocity should equal the 
    628       ! ocean velocity,  
    629       ! This prevents high velocity when ice is thin 
    630 !CDIR NOVERRCHK 
     561      ! If the ice volume is below zvmin then ice velocity should equal the 
     562      ! ocean velocity. This prevents high velocity when ice is thin 
    631563      DO jj = k_j1+1, k_jpj-1 
    632 !CDIR NOVERRCHK 
    633564         DO ji = fs_2, fs_jpim1 
    634             zdummy = vt_i(ji,jj) 
    635             IF ( zdummy .LE. hminrhg ) THEN 
     565            IF ( vt_i(ji,jj) <= zvmin ) THEN 
    636566               u_ice(ji,jj) = u_oce(ji,jj) 
    637567               v_ice(ji,jj) = v_oce(ji,jj) 
    638             ENDIF ! zdummy 
     568            ENDIF 
    639569         END DO 
    640570      END DO 
    … …  
    643573      CALL lbc_lnk( v_ice(:,:), 'V', -1. )  
    644574#if defined key_agrif && defined key_lim2 
    645       CALL agrif_rhg_lim2( nevp , nevp, 'U' ) 
    646       CALL agrif_rhg_lim2( nevp , nevp, 'V' ) 
     575      CALL agrif_rhg_lim2( nn_nevp , nn_nevp, 'U' ) 
     576      CALL agrif_rhg_lim2( nn_nevp , nn_nevp, 'V' ) 
    647577#endif 
    648578#if defined key_bdy 
    … …  
    653583      DO jj = k_j1+1, k_jpj-1  
    654584         DO ji = fs_2, fs_jpim1 
    655             zdummy = vt_i(ji,jj) 
    656             IF ( zdummy .LE. hminrhg ) THEN 
    657                v_ice1(ji,jj)  = 0.5*( (v_ice(ji,jj)+v_ice(ji,jj-1))*e1t(ji+1,jj)   & 
    658                   &                 +(v_ice(ji+1,jj)+v_ice(ji+1,jj-1))*e1t(ji,jj)) & 
    659                   &               /(e1t(ji+1,jj)+e1t(ji,jj)) * tmu(ji,jj) 
    660  
    661                u_ice2(ji,jj)  = 0.5*( (u_ice(ji,jj)+u_ice(ji-1,jj))*e2t(ji,jj+1)   & 
    662                   &                 +(u_ice(ji,jj+1)+u_ice(ji-1,jj+1))*e2t(ji,jj)) & 
    663                   &               /(e2t(ji,jj+1)+e2t(ji,jj)) * tmv(ji,jj) 
    664             ENDIF ! zdummy 
     585            IF ( vt_i(ji,jj) <= zvmin ) THEN 
     586               v_ice1(ji,jj)  = 0.5_wp * ( ( v_ice(ji  ,jj) + v_ice(ji,  jj-1) ) * e1t(ji+1,jj)     & 
     587                  &                      + ( v_ice(ji+1,jj) + v_ice(ji+1,jj-1) ) * e1t(ji  ,jj) )   & 
     588                  &                      / ( e1t(ji+1,jj) + e1t(ji,jj) ) * umask(ji,jj,1) 
     589 
     590               u_ice2(ji,jj)  = 0.5_wp * ( ( u_ice(ji,jj  ) + u_ice(ji-1,jj  ) ) * e2t(ji,jj+1)     & 
     591                  &                      + ( u_ice(ji,jj+1) + u_ice(ji-1,jj+1) ) * e2t(ji,jj  ) )   & 
     592                  &                      / ( e2t(ji,jj+1) + e2t(ji,jj) ) * vmask(ji,jj,1) 
     593            ENDIF  
    665594         END DO 
    666595      END DO 
    … …  
    670599 
    671600      ! Recompute delta, shear and div, inputs for mechanical redistribution  
    672 !CDIR NOVERRCHK 
    673601      DO jj = k_j1+1, k_jpj-1 
    674 !CDIR NOVERRCHK 
    675          DO ji = fs_2, jpim1   !RB bug no vect opt due to tmi 
     602         DO ji = fs_2, jpim1   !RB bug no vect opt due to zmask 
    676603            !- divu_i(:,:), zdt(:,:): divergence and tension at centre  
    677604            !- zds(:,:): shear on northeast corner of grid cells 
    678             zdummy = vt_i(ji,jj) 
    679             IF ( zdummy .LE. hminrhg ) THEN 
    680  
    681                divu_i(ji,jj) = ( e2u(ji,jj)*u_ice(ji,jj)                      & 
    682                   &             -e2u(ji-1,jj)*u_ice(ji-1,jj)                  & 
    683                   &             +e1v(ji,jj)*v_ice(ji,jj)                      & 
    684                   &             -e1v(ji,jj-1)*v_ice(ji,jj-1)                  & 
    685                   &            )                                              & 
    686                   &            / area(ji,jj) 
    687  
    688                zdt(ji,jj) = ( ( u_ice(ji,jj)/e2u(ji,jj)                    & 
    689                   &            -u_ice(ji-1,jj)/e2u(ji-1,jj)                & 
    690                   &           )*e2t(ji,jj)*e2t(ji,jj)                      & 
    691                   &          -( v_ice(ji,jj)/e1v(ji,jj)                    & 
    692                   &            -v_ice(ji,jj-1)/e1v(ji,jj-1)                & 
    693                   &           )*e1t(ji,jj)*e1t(ji,jj)                      & 
    694                   &         )                                              & 
    695                   &        / area(ji,jj) 
     605            IF ( vt_i(ji,jj) <= zvmin ) THEN 
     606 
     607               divu_i(ji,jj) = (  e2u(ji,jj) * u_ice(ji,jj) - e2u(ji-1,jj  ) * u_ice(ji-1,jj  )   & 
     608                  &             + e1v(ji,jj) * v_ice(ji,jj) - e1v(ji  ,jj-1) * v_ice(ji  ,jj-1)   & 
     609                  &            ) * r1_e12t(ji,jj) 
     610 
     611               zdt(ji,jj) = ( ( u_ice(ji,jj) * r1_e2u(ji,jj) - u_ice(ji-1,jj) * r1_e2u(ji-1,jj) ) * e2t(ji,jj) * e2t(ji,jj)  & 
     612                  &          -( v_ice(ji,jj) * r1_e1v(ji,jj) - v_ice(ji,jj-1) * r1_e1v(ji,jj-1) ) * e1t(ji,jj) * e1t(ji,jj)  & 
     613                  &         ) * r1_e12t(ji,jj) 
    696614               ! 
    697615               ! SB modif because ocean has no slip boundary condition  
    698                zds(ji,jj) = ( ( u_ice(ji,jj+1) / e1u(ji,jj+1)              & 
    699                   &           - u_ice(ji,jj)   / e1u(ji,jj) )              & 
    700                   &           * e1f(ji,jj) * e1f(ji,jj)                    & 
    701                   &          + ( v_ice(ji+1,jj) / e2v(ji+1,jj)             & 
    702                   &            - v_ice(ji,jj)  / e2v(ji,jj) )              & 
    703                   &           * e2f(ji,jj) * e2f(ji,jj) )                  & 
    704                   &        / ( e1f(ji,jj) * e2f(ji,jj) ) * ( 2.0 - tmf(ji,jj) ) & 
    705                   &        * tmi(ji,jj) * tmi(ji,jj+1)                     & 
    706                   &        * tmi(ji+1,jj) * tmi(ji+1,jj+1) 
    707  
    708                zdst = (  e2u( ji  , jj   ) * v_ice1(ji  ,jj  )    & 
    709                   &           - e2u( ji-1, jj   ) * v_ice1(ji-1,jj  )    & 
    710                   &           + e1v( ji  , jj   ) * u_ice2(ji  ,jj  )    & 
    711                   &           - e1v( ji  , jj-1 ) * u_ice2(ji  ,jj-1)  ) / area(ji,jj) 
    712  
    713                delta = SQRT( divu_i(ji,jj)*divu_i(ji,jj) + ( zdt(ji,jj)*zdt(ji,jj) + zdst*zdst ) * usecc2 )   
    714                delta_i(ji,jj) = delta + creepl 
     616               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)  & 
     617                  &          +( v_ice(ji+1,jj) * r1_e2v(ji+1,jj) - v_ice(ji,jj) * r1_e2v(ji,jj) ) * e2f(ji,jj) * e2f(ji,jj)  & 
     618                  &         ) * r1_e12f(ji,jj) * ( 2.0 - fmask(ji,jj,1) )                                     & 
     619                  &         * zmask(ji,jj) * zmask(ji,jj+1) * zmask(ji+1,jj) * zmask(ji+1,jj+1) 
     620 
     621               zdst = ( e2u(ji,jj) * v_ice1(ji,jj) - e2u(ji-1,jj  ) * v_ice1(ji-1,jj  )    & 
     622                  &   + e1v(ji,jj) * u_ice2(ji,jj) - e1v(ji  ,jj-1) * u_ice2(ji  ,jj-1) ) * r1_e12t(ji,jj) 
     623 
     624               delta = SQRT( divu_i(ji,jj)**2 + ( zdt(ji,jj)**2 + zdst**2 ) * usecc2 )   
     625               delta_i(ji,jj) = delta + rn_creepl 
    715626             
    716             ENDIF ! zdummy 
    717  
    718          END DO !jj 
    719       END DO !ji 
     627            ENDIF 
     628         END DO 
     629      END DO 
    720630      ! 
    721631      !------------------------------------------------------------------------------! 
    722632      ! 5) Store stress tensor and its invariants 
    723633      !------------------------------------------------------------------------------! 
    724       ! 
    725634      ! * Invariants of the stress tensor are required for limitd_me 
    726635      !   (accelerates convergence and improves stability) 
    727636      DO jj = k_j1+1, k_jpj-1 
    728637         DO ji = fs_2, fs_jpim1 
    729             ! begin TECLIM change  
    730             zdst= (  e2u( ji  , jj   ) * v_ice1(ji,jj)           &    
    731                &          - e2u( ji-1, jj   ) * v_ice1(ji-1,jj)         &    
    732                &          + e1v( ji  , jj   ) * u_ice2(ji,jj)           &    
    733                &          - e1v( ji  , jj-1 ) * u_ice2(ji,jj-1) ) / area(ji,jj)  
     638            zdst           = (  e2u(ji,jj) * v_ice1(ji,jj) - e2u( ji-1, jj   ) * v_ice1(ji-1,jj)  &    
     639               &              + e1v(ji,jj) * u_ice2(ji,jj) - e1v( ji  , jj-1 ) * u_ice2(ji,jj-1) ) * r1_e12t(ji,jj)  
    734640            shear_i(ji,jj) = SQRT( zdt(ji,jj) * zdt(ji,jj) + zdst * zdst ) 
    735             ! end TECLIM change 
    736641         END DO 
    737642      END DO 
    … …  
    772677            DO jj = k_j1+1, k_jpj-1 
    773678               DO ji = 2, jpim1 
    774                   IF (zpresh(ji,jj) .GT. 1.0) THEN 
     679                  IF (zpresh(ji,jj) > 1.0) THEN 
    775680                     sigma1 = ( zs1(ji,jj) + (zs2(ji,jj)**2 + 4*zs12(ji,jj)**2 )**0.5 ) / ( 2*zpresh(ji,jj) )  
    776681                     sigma2 = ( zs1(ji,jj) - (zs2(ji,jj)**2 + 4*zs12(ji,jj)**2 )**0.5 ) / ( 2*zpresh(ji,jj) ) 
    … …  
    786691      ! 
    787692      CALL wrk_dealloc( jpi,jpj, zpresh, zfrld1, zmass1, zcorl1, za1ct , zpreshc, zfrld2, zmass2, zcorl2, za2ct ) 
    788       CALL wrk_dealloc( jpi,jpj, u_oce1, u_oce2, u_ice2, v_oce1 , v_oce2, v_ice1                ) 
     693      CALL wrk_dealloc( jpi,jpj, u_oce2, u_ice2, v_oce1 , v_ice1 , zmask               ) 
    789694      CALL wrk_dealloc( jpi,jpj, zf1   , zu_ice, zf2   , zv_ice , zdt    , zds  ) 
    790695      CALL wrk_dealloc( jpi,jpj, zdt   , zds   , zs1   , zs2   , zs12   , zresr , zpice                 ) 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/LIM_SRC_3/limrst.F90

    r5312 r5313  
    1818   USE ice            ! sea-ice variables 
    1919   USE oce     , ONLY :  snwice_mass, snwice_mass_b 
    20    USE par_ice        ! sea-ice parameters 
    2120   USE dom_oce        ! ocean domain 
    2221   USE sbc_oce        ! Surface boundary condition: ocean fields 
    … …  
    2726   USE wrk_nemo       ! work arrays 
    2827   USE lib_fortran    ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined)   
     28   USE limctl 
    2929 
    3030   IMPLICIT NONE 
    … …  
    3333   PUBLIC   lim_rst_opn    ! routine called by icestep.F90 
    3434   PUBLIC   lim_rst_write  ! routine called by icestep.F90 
    35    PUBLIC   lim_rst_read   ! routine called by iceini.F90 
     35   PUBLIC   lim_rst_read   ! routine called by sbc_lim_init 
    3636 
    3737   LOGICAL, PUBLIC ::   lrst_ice         !: logical to control the ice restart write  
    … …  
    9393      ENDIF 
    9494      ! 
     95      IF( ln_icectl )   CALL lim_prt( kt, iiceprt, jiceprt, 1, ' - Beginning the time step - ' )   ! control print 
    9596   END SUBROUTINE lim_rst_opn 
    9697 
    … …  
    172173      CALL iom_rstput( iter, nitrst, numriw, 'stress2_i'    , stress2_i  ) 
    173174      CALL iom_rstput( iter, nitrst, numriw, 'stress12_i'   , stress12_i ) 
    174       CALL iom_rstput( iter, nitrst, numriw, 'snwice_mass'  , snwice_mass )   !clem modif 
    175       CALL iom_rstput( iter, nitrst, numriw, 'snwice_mass_b', snwice_mass_b ) !clem modif 
     175      CALL iom_rstput( iter, nitrst, numriw, 'snwice_mass'  , snwice_mass ) 
     176      CALL iom_rstput( iter, nitrst, numriw, 'snwice_mass_b', snwice_mass_b ) 
    176177 
    177178      DO jl = 1, jpl  
    … …  
    313314      !! ** purpose  :   read of sea-ice variable restart in a netcdf file 
    314315      !!---------------------------------------------------------------------- 
    315       INTEGER :: ji, jj, jk, jl, indx 
     316      INTEGER :: ji, jj, jk, jl 
    316317      REAL(wp) ::   zfice, ziter 
    317       REAL(wp) ::   zs_inf, z_slope_s, zsmax, zsmin, zalpha   ! local scalars used for the salinity profile 
    318       REAL(wp), POINTER, DIMENSION(:)   ::   zs_zero  
    319318      REAL(wp), POINTER, DIMENSION(:,:) ::   z2d 
    320319      CHARACTER(len=15) ::   znam 
    … …  
    324323      !!---------------------------------------------------------------------- 
    325324 
    326       CALL wrk_alloc( nlay_i, zs_zero ) 
    327325      CALL wrk_alloc( jpi, jpj, z2d ) 
    328326 
    … …  
    402400      CALL iom_get( numrir, jpdom_autoglo, 'stress2_i' , stress2_i  ) 
    403401      CALL iom_get( numrir, jpdom_autoglo, 'stress12_i', stress12_i ) 
    404       CALL iom_get( numrir, jpdom_autoglo, 'snwice_mass'  , snwice_mass )   !clem modif 
    405       CALL iom_get( numrir, jpdom_autoglo, 'snwice_mass_b', snwice_mass_b ) !clem modif 
     402      CALL iom_get( numrir, jpdom_autoglo, 'snwice_mass'  , snwice_mass ) 
     403      CALL iom_get( numrir, jpdom_autoglo, 'snwice_mass_b', snwice_mass_b ) 
    406404 
    407405      DO jl = 1, jpl  
    … …  
    528526      ! 
    529527      ! clem: I do not understand why the following IF is needed 
    530       !       I suspect something inconsistent in the main code with option num_sal=1 
    531       IF( num_sal == 1 ) THEN 
     528      !       I suspect something inconsistent in the main code with option nn_icesal=1 
     529      IF( nn_icesal == 1 ) THEN 
    532530         DO jl = 1, jpl  
    533             sm_i(:,:,jl) = bulk_sal 
     531            sm_i(:,:,jl) = rn_icesal 
    534532            DO jk = 1, nlay_i  
    535                s_i(:,:,jk,jl) = bulk_sal 
     533               s_i(:,:,jk,jl) = rn_icesal 
    536534            END DO 
    537535         END DO 
    … …  
    540538      !CALL iom_close( numrir ) !clem: closed in sbcice_lim.F90 
    541539      ! 
    542       CALL wrk_dealloc( nlay_i, zs_zero ) 
    543540      CALL wrk_dealloc( jpi, jpj, z2d ) 
    544541      ! 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/LIM_SRC_3/limsbc.F90

    r5312 r5313  
    2525   USE par_oce          ! ocean parameters 
    2626   USE phycst           ! physical constants 
    27    USE par_ice          ! ice parameters 
    2827   USE dom_oce          ! ocean domain 
    29    USE dom_ice,    ONLY : tms, area 
    3028   USE ice              ! LIM sea-ice variables 
    3129   USE sbc_ice          ! Surface boundary condition: sea-ice fields 
    … …  
    4038   USE prtctl           ! Print control 
    4139   USE lib_fortran      ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined)   
    42    USE traqsr           ! clem: add penetration of solar flux into the calculation of heat budget 
     40   USE traqsr           ! add penetration of solar flux in the calculation of heat budget 
    4341   USE iom 
    4442   USE domvvl           ! Variable volume 
     43   USE limctl 
     44   USE limcons 
    4545 
    4646   IMPLICIT NONE 
    4747   PRIVATE 
    4848 
    49    PUBLIC   lim_sbc_init   ! called by ice_init 
     49   PUBLIC   lim_sbc_init   ! called by sbc_lim_init 
    5050   PUBLIC   lim_sbc_flx    ! called by sbc_ice_lim 
    5151   PUBLIC   lim_sbc_tau    ! called by sbc_ice_lim 
    … …  
    9999      !!              Tartinville et al. 2001 Ocean Modelling, 3, 95-108. 
    100100      !!              These refs are now obsolete since everything has been revised 
    101       !!              The ref should be Rousset et al., 2015? 
     101      !!              The ref should be Rousset et al., 2015 
    102102      !!--------------------------------------------------------------------- 
    103103      INTEGER, INTENT(in) ::   kt                                   ! number of iteration 
    104       ! 
    105104      INTEGER  ::   ji, jj, jl, jk                                  ! dummy loop indices 
    106       ! 
    107       REAL(wp) ::   zemp                                            !  local scalars 
     105      REAL(wp) ::   zemp                                            ! local scalars 
    108106      REAL(wp) ::   zf_mass                                         ! Heat flux associated with mass exchange ice->ocean (W.m-2) 
    109107      REAL(wp) ::   zfcm1                                           ! New solar flux received by the ocean 
    … …  
    149147            hfx_out(ji,jj) = hfx_out(ji,jj) + zf_mass + zfcm1 
    150148 
     149            ! Add the residual from heat diffusion equation (W.m-2) 
     150            !------------------------------------------------------- 
     151            hfx_out(ji,jj) = hfx_out(ji,jj) + hfx_err_dif(ji,jj) 
     152 
    151153            ! New qsr and qns used to compute the oceanic heat flux at the next time step 
    152154            !--------------------------------------------------- 
    … …  
    167169            !  computing freshwater exchanges at the ice/ocean interface 
    168170            IF( lk_cpl ) THEN  
    169                zemp = - emp_tot(ji,jj) + emp_ice(ji,jj) * ( 1. - pfrld(ji,jj) )    &   ! 
    170                   &   + wfx_snw(ji,jj) 
     171                zemp =   emp_tot(ji,jj)                                    &   ! net mass flux over grid cell 
     172                   &   - emp_ice(ji,jj) * ( 1._wp - pfrld(ji,jj) )         &   ! minus the mass flux intercepted by sea ice 
     173                   &   + sprecip(ji,jj) * ( pfrld(ji,jj) - pfrld(ji,jj)**rn_betas )   ! 
    171174            ELSE 
    172175               zemp =   emp(ji,jj)     *           pfrld(ji,jj)            &   ! evaporation over oceanic fraction 
    173176                  &   - tprecip(ji,jj) * ( 1._wp - pfrld(ji,jj) )          &   ! all precipitation reach the ocean 
    174                   &   + sprecip(ji,jj) * ( 1._wp - pfrld(ji,jj)**betas )       ! except solid precip intercepted by sea-ice 
     177                  &   + sprecip(ji,jj) * ( 1._wp - pfrld(ji,jj)**rn_betas )       ! except solid precip intercepted by sea-ice 
    175178            ENDIF 
    176179 
    … …  
    180183 
    181184            ! mass flux at the ocean/ice interface 
    182             fmmflx(ji,jj) = - wfx_ice(ji,jj) * r1_rdtice                    ! F/M mass flux save at least for biogeochemical model 
    183             emp(ji,jj)    = zemp - wfx_ice(ji,jj) - wfx_snw(ji,jj)       ! mass flux + F/M mass flux (always ice/ocean mass exchange) 
     185            fmmflx(ji,jj) = - ( wfx_ice(ji,jj) + wfx_snw(ji,jj) ) * r1_rdtice  ! F/M mass flux save at least for biogeochemical model 
     186            emp(ji,jj)    = zemp - wfx_ice(ji,jj) - wfx_snw(ji,jj)             ! mass flux + F/M mass flux (always ice/ocean mass exchange) 
    184187             
    185188         END DO 
    … …  
    199202         snwice_mass_b(:,:) = snwice_mass(:,:)                   
    200203         ! new mass per unit area 
    201          snwice_mass  (:,:) = tms(:,:) * ( rhosn * vt_s(:,:) + rhoic * vt_i(:,:)  )  
     204         snwice_mass  (:,:) = tmask(:,:,1) * ( rhosn * vt_s(:,:) + rhoic * vt_i(:,:)  )  
    202205         ! time evolution of snow+ice mass 
    203206         snwice_fmass (:,:) = ( snwice_mass(:,:) - snwice_mass_b(:,:) ) * r1_rdtice 
    … …  
    225228      ENDIF 
    226229 
     230      ! conservation test 
     231      IF( ln_limdiahsb ) CALL lim_cons_final( 'limsbc' ) 
     232 
     233      ! control prints 
     234      IF( ln_icectl )   CALL lim_prt( kt, iiceprt, jiceprt, 3, ' - Final state lim_sbc - ' ) 
    227235 
    228236      IF(ln_ctl) THEN 
    … …  
    270278      ! 
    271279      IF( MOD( kt-1, nn_fsbc ) == 0 ) THEN     !==  Ice time-step only  ==!   (i.e. surface module time-step) 
    272 !CDIR NOVERRCHK 
    273280         DO jj = 2, jpjm1                             !* update the modulus of stress at ocean surface (T-point) 
    274 !CDIR NOVERRCHK 
    275281            DO ji = fs_2, fs_jpim1 
    276282               !                                               ! 2*(U_ice-U_oce) at T-point 
    … …  
    322328      !! ** input   : Namelist namicedia 
    323329      !!------------------------------------------------------------------- 
    324       REAL(wp) :: zsum, zarea 
    325       ! 
    326330      INTEGER  ::   ji, jj, jk                       ! dummy loop indices 
    327331      REAL(wp) ::   zcoefu, zcoefv, zcoeff          ! local scalar 
    … …  
    343347         END WHERE 
    344348      ENDIF 
    345       ! clem modif 
     349       
    346350      IF( .NOT. ln_rstart ) THEN 
    347351         fraqsr_1lev(:,:) = 1._wp 
    348352      ENDIF 
    349353      ! 
    350       ! clem: snwice_mass in the restart file now 
    351354      IF( .NOT. ln_rstart ) THEN 
    352355         !                                      ! embedded sea ice 
    353356         IF( nn_ice_embd /= 0 ) THEN            ! mass exchanges between ice and ocean (case 1 or 2) set the snow+ice mass 
    354             snwice_mass  (:,:) = tms(:,:) * ( rhosn * vt_s(:,:) + rhoic * vt_i(:,:)  ) 
     357            snwice_mass  (:,:) = tmask(:,:,1) * ( rhosn * vt_s(:,:) + rhoic * vt_i(:,:)  ) 
    355358            snwice_mass_b(:,:) = snwice_mass(:,:) 
    356359         ELSE 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/LIM_SRC_3/limthd.F90

    r5312 r5313  
    2424   USE oce     , ONLY : fraqsr_1lev  
    2525   USE ice            ! LIM: sea-ice variables 
    26    USE par_ice        ! LIM: sea-ice parameters 
    2726   USE sbc_oce        ! Surface boundary condition: ocean fields 
    2827   USE sbc_ice        ! Surface boundary condition: ice fields 
    … …  
    3433   USE limthd_sal     ! LIM: thermodynamics, ice salinity 
    3534   USE limthd_ent     ! LIM: thermodynamics, ice enthalpy redistribution 
     35   USE limthd_lac     ! LIM-3 lateral accretion 
     36   USE limitd_th      ! remapping thickness distribution 
    3637   USE limtab         ! LIM: 1D <==> 2D transformation 
    3738   USE limvar         ! LIM: sea-ice variables 
    … …  
    4445   USE timing         ! Timing 
    4546   USE limcons        ! conservation tests 
     47   USE limctl 
    4648 
    4749   IMPLICIT NONE 
    … …  
    4951 
    5052   PUBLIC   lim_thd        ! called by limstp module 
    51    PUBLIC   lim_thd_init   ! called by iceini module 
     53   PUBLIC   lim_thd_init   ! called by sbc_lim_init 
    5254 
    5355   !! * Substitutions 
    … …  
    8082      !! ** References :  
    8183      !!--------------------------------------------------------------------- 
    82       INTEGER, INTENT(in) ::   kt    ! number of iteration 
     84      INTEGER, INTENT(in) :: kt    ! number of iteration 
    8385      !! 
    8486      INTEGER  :: ji, jj, jk, jl   ! dummy loop indices 
    85       INTEGER  :: nbpb             ! nb of icy pts for thermo. cal. 
     87      INTEGER  :: nbpb             ! nb of icy pts for vertical thermo calculations 
    8688      INTEGER  :: ii, ij           ! temporary dummy loop index 
    87       REAL(wp) :: zfric_umin = 0._wp        ! lower bound for the friction velocity (cice value=5.e-04) 
    88       REAL(wp) :: zch        = 0.0057_wp    ! heat transfer coefficient 
    89       REAL(wp) :: zareamin  
    9089      REAL(wp) :: zfric_u, zqld, zqfr 
    91       ! 
    9290      REAL(wp) :: zvi_b, zsmv_b, zei_b, zfs_b, zfw_b, zft_b  
     91      REAL(wp), PARAMETER :: zfric_umin = 0._wp           ! lower bound for the friction velocity (cice value=5.e-04) 
     92      REAL(wp), PARAMETER :: zch        = 0.0057_wp       ! heat transfer coefficient 
    9393      ! 
    9494      REAL(wp), POINTER, DIMENSION(:,:) ::  zqsr, zqns 
    9595      !!------------------------------------------------------------------- 
    96       CALL wrk_alloc( jpi, jpj, zqsr, zqns ) 
     96      CALL wrk_alloc( jpi,jpj, zqsr, zqns ) 
    9797 
    9898      IF( nn_timing == 1 )  CALL timing_start('limthd') 
    … …  
    101101      IF( ln_limdiahsb ) CALL lim_cons_hsm(0, 'limthd', zvi_b, zsmv_b, zei_b, zfw_b, zfs_b, zft_b) 
    102102 
     103      CALL lim_var_glo2eqv 
    103104      !------------------------------------------------------------------------! 
    104105      ! 1) Initialization of some variables                                    ! 
    … …  
    106107      ftr_ice(:,:,:) = 0._wp  ! part of solar radiation transmitted through the ice 
    107108 
    108  
    109109      !-------------------- 
    110110      ! 1.2) Heat content     
    111111      !-------------------- 
    112       ! Change the units of heat content; from global units to J.m3 
     112      ! Change the units of heat content; from J/m2 to J/m3 
    113113      DO jl = 1, jpl 
    114114         DO jk = 1, nlay_i 
    … …  
    116116               DO ji = 1, jpi 
    117117                  !0 if no ice and 1 if yes 
    118                   rswitch = 1.0 - MAX(  0.0 , SIGN( 1.0 , - v_i(ji,jj,jl) + epsi10 )  ) 
     118                  rswitch = MAX(  0._wp , SIGN( 1._wp , v_i(ji,jj,jl) - epsi20 )  ) 
    119119                  !Energy of melting q(S,T) [J.m-3] 
    120                   e_i(ji,jj,jk,jl) = rswitch * e_i(ji,jj,jk,jl) / ( area(ji,jj) * MAX( v_i(ji,jj,jl) , epsi10 ) ) * REAL( nlay_i ) 
    121                   !convert units ! very important that this line is here         
    122                   e_i(ji,jj,jk,jl) = e_i(ji,jj,jk,jl) * unit_fac  
     120                  e_i(ji,jj,jk,jl) = rswitch * e_i(ji,jj,jk,jl) / MAX( v_i(ji,jj,jl) , epsi20 ) * REAL( nlay_i ) 
    123121               END DO 
    124122            END DO 
    … …  
    128126               DO ji = 1, jpi 
    129127                  !0 if no ice and 1 if yes 
    130                   rswitch = 1.0 - MAX(  0.0 , SIGN( 1.0 , - v_s(ji,jj,jl) + epsi10 )  ) 
     128                  rswitch = MAX(  0._wp , SIGN( 1._wp , v_s(ji,jj,jl) - epsi20 )  ) 
    131129                  !Energy of melting q(S,T) [J.m-3] 
    132                   e_s(ji,jj,jk,jl) = rswitch * e_s(ji,jj,jk,jl) / ( area(ji,jj) * MAX( v_s(ji,jj,jl) , epsi10 ) ) * REAL( nlay_s ) 
    133                   !convert units ! very important that this line is here 
    134                   e_s(ji,jj,jk,jl) = e_s(ji,jj,jk,jl) * unit_fac  
     130                  e_s(ji,jj,jk,jl) = rswitch * e_s(ji,jj,jk,jl) / MAX( v_s(ji,jj,jl) , epsi20 ) * REAL( nlay_s ) 
    135131               END DO 
    136132            END DO 
    … …  
    161157      ENDIF 
    162158 
    163 !CDIR NOVERRCHK 
    164159      DO jj = 1, jpj 
    165 !CDIR NOVERRCHK 
    166160         DO ji = 1, jpi 
    167             rswitch          = tms(ji,jj) * ( 1._wp - MAX( 0._wp , SIGN( 1._wp , - at_i(ji,jj) + epsi10 ) ) ) ! 0 if no ice 
     161            rswitch  = tmask(ji,jj,1) * MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) - epsi10 ) ) ! 0 if no ice 
    168162            ! 
    169163            !           !  solar irradiance transmission at the mixed layer bottom and used in the lead heat budget 
    … …  
    178172            ! precip is included in qns but not in qns_ice 
    179173            IF ( lk_cpl ) THEN 
    180                zqld =  tms(ji,jj) * rdt_ice *  & 
     174               zqld =  tmask(ji,jj,1) * rdt_ice *  & 
    181175                  &    (   zqsr(ji,jj) * fraqsr_1lev(ji,jj) + zqns(ji,jj)               &   ! pfrld already included in coupled mode 
    182                   &    + ( pfrld(ji,jj)**betas - pfrld(ji,jj) ) * sprecip(ji,jj)  *     &   ! heat content of precip 
    183                   &      ( cpic * ( MIN( tatm_ice(ji,jj), rt0_snow ) - rtt ) - lfus )   & 
    184                   &    + ( 1._wp - pfrld(ji,jj) ) * ( tprecip(ji,jj) - sprecip(ji,jj) ) * rcp * ( tatm_ice(ji,jj) - rtt ) ) 
     176                  &    + ( pfrld(ji,jj)**rn_betas - pfrld(ji,jj) ) * sprecip(ji,jj)  *     &   ! heat content of precip 
     177                  &      ( cpic * ( MIN( tatm_ice(ji,jj), rt0_snow ) - rt0 ) - lfus )   & 
     178                  &    + ( 1._wp - pfrld(ji,jj) ) * ( tprecip(ji,jj) - sprecip(ji,jj) ) * rcp * ( tatm_ice(ji,jj) - rt0 ) ) 
    185179            ELSE 
    186                zqld =  tms(ji,jj) * rdt_ice *  & 
     180               zqld =  tmask(ji,jj,1) * rdt_ice *  & 
    187181                  &      ( pfrld(ji,jj) * ( zqsr(ji,jj) * fraqsr_1lev(ji,jj) + zqns(ji,jj) )    & 
    188                   &    + ( pfrld(ji,jj)**betas - pfrld(ji,jj) ) * sprecip(ji,jj)  *             &  ! heat content of precip 
    189                   &      ( cpic * ( MIN( tatm_ice(ji,jj), rt0_snow ) - rtt ) - lfus )           & 
    190                   &    + ( 1._wp - pfrld(ji,jj) ) * ( tprecip(ji,jj) - sprecip(ji,jj) ) * rcp * ( tatm_ice(ji,jj) - rtt ) ) 
     182                  &    + ( pfrld(ji,jj)**rn_betas - pfrld(ji,jj) ) * sprecip(ji,jj)  *             &  ! heat content of precip 
     183                  &      ( cpic * ( MIN( tatm_ice(ji,jj), rt0_snow ) - rt0 ) - lfus )           & 
     184                  &    + ( 1._wp - pfrld(ji,jj) ) * ( tprecip(ji,jj) - sprecip(ji,jj) ) * rcp * ( tatm_ice(ji,jj) - rt0 ) ) 
    191185            ENDIF 
    192186 
    193             !-- Energy needed to bring ocean surface layer until its freezing (<0, J.m-2) --- ! 
    194             zqfr = tms(ji,jj) * rau0 * rcp * fse3t_m(ji,jj) * ( t_bo(ji,jj) - ( sst_m(ji,jj) + rt0 ) ) 
     187            ! --- Energy needed to bring ocean surface layer until its freezing (<0, J.m-2) --- ! 
     188            zqfr = tmask(ji,jj,1) * rau0 * rcp * fse3t_m(ji,jj) * ( t_bo(ji,jj) - ( sst_m(ji,jj) + rt0 ) ) 
     189 
     190            ! --- Energy from the turbulent oceanic heat flux (W/m2) --- ! 
     191            zfric_u      = MAX( SQRT( ust2s(ji,jj) ), zfric_umin )  
     192            fhtur(ji,jj) = MAX( 0._wp, rswitch * rau0 * rcp * zch  * zfric_u * ( ( sst_m(ji,jj) + rt0 ) - t_bo(ji,jj) ) ) ! W.m-2 
     193            fhtur(ji,jj) = rswitch * MIN( fhtur(ji,jj), - zqfr * r1_rdtice / MAX( at_i(ji,jj), epsi10 ) ) 
     194            ! upper bound for fhtur: the heat retrieved from the ocean must be smaller than the heat necessary to reach  
     195            !                        the freezing point, so that we do not have SST < T_freeze 
     196            !                        This implies: - ( fhtur(ji,jj) * at_i(ji,jj) * rtdice ) - zqfr >= 0 
    195197 
    196198            !-- Energy Budget of the leads (J.m-2). Must be < 0 to form ice 
    197             qlead(ji,jj) = MIN( 0._wp , zqld - zqfr )  
     199            qlead(ji,jj) = MIN( 0._wp , zqld - ( fhtur(ji,jj) * at_i(ji,jj) * rdt_ice ) - zqfr ) 
    198200 
    199201            ! If there is ice and leads are warming, then transfer energy from the lead budget and use it for bottom melting  
    200             IF( at_i(ji,jj) > epsi10 .AND. zqld > 0._wp ) THEN 
    201                fhld (ji,jj) = zqld * r1_rdtice / at_i(ji,jj) ! divided by at_i since this is (re)multiplied by a_i in limthd_dh.F90 
     202            IF( zqld > 0._wp ) THEN 
     203               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 limthd_dh.F90 
    202204               qlead(ji,jj) = 0._wp 
    203205            ELSE 
    … …  
    205207            ENDIF 
    206208            ! 
    207             !-- Energy from the turbulent oceanic heat flux --- ! 
    208             !clem zfric_u        = MAX ( MIN( SQRT( ust2s(ji,jj) ) , zfric_umax ) , zfric_umin ) 
    209             zfric_u      = MAX( SQRT( ust2s(ji,jj) ), zfric_umin )  
    210             fhtur(ji,jj) = MAX( 0._wp, rswitch * rau0 * rcp * zch  * zfric_u * ( ( sst_m(ji,jj) + rt0 ) - t_bo(ji,jj) ) ) ! W.m-2  
    211             ! upper bound for fhtur: we do not want SST to drop below Tfreeze.  
    212             ! So we say that the heat retrieved from the ocean (fhtur+fhld) must be < to the heat necessary to reach Tfreeze (zqfr)    
    213             ! This is not a clean budget, so that should be corrected at some point 
    214             fhtur(ji,jj) = rswitch * MIN( fhtur(ji,jj), - fhld(ji,jj) - zqfr * r1_rdtice / MAX( at_i(ji,jj), epsi10 ) ) 
    215  
    216209            ! ----------------------------------------- 
    217210            ! Net heat flux on top of ice-ocean [W.m-2] 
    218211            ! ----------------------------------------- 
    219             !     First  step here      : heat flux at the ocean surface + precip 
    220             !     Second step below     : heat flux at the ice   surface (after limthd_dif)  
     212            !     heat flux at the ocean surface + precip 
     213            !   + heat flux at the ice   surface  
    221214            hfx_in(ji,jj) = hfx_in(ji,jj)                                                                                         &  
    222215               ! heat flux above the ocean 
    223216               &    +             pfrld(ji,jj)   * ( zqns(ji,jj) + zqsr(ji,jj) )                                                  & 
    224217               ! latent heat of precip (note that precip is included in qns but not in qns_ice) 
    225                &    +   ( 1._wp - pfrld(ji,jj) ) * sprecip(ji,jj) * ( cpic * ( MIN( tatm_ice(ji,jj), rt0_snow ) - rtt ) - lfus )  & 
    226                &    +   ( 1._wp - pfrld(ji,jj) ) * ( tprecip(ji,jj) - sprecip(ji,jj) ) * rcp * ( tatm_ice(ji,jj) - rtt ) 
     218               &    +   ( 1._wp - pfrld(ji,jj) ) * sprecip(ji,jj) * ( cpic * ( MIN( tatm_ice(ji,jj), rt0_snow ) - rt0 ) - lfus )  & 
     219               &    +   ( 1._wp - pfrld(ji,jj) ) * ( tprecip(ji,jj) - sprecip(ji,jj) ) * rcp * ( tatm_ice(ji,jj) - rt0 )          & 
     220               ! heat flux above the ice 
     221               &    +   SUM(    a_i_b(ji,jj,:)   * ( qns_ice(ji,jj,:) + qsr_ice(ji,jj,:) ) ) 
    227222 
    228223            ! ----------------------------------------------------------------------------- 
    … …  
    234229            hfx_out(ji,jj) = hfx_out(ji,jj)                                                                                       &  
    235230               ! Non solar heat flux received by the ocean 
    236                &    +        pfrld(ji,jj) * qns(ji,jj)                                                                            & 
     231               &    +        pfrld(ji,jj) * zqns(ji,jj)                                                                            & 
    237232               ! latent heat of precip (note that precip is included in qns but not in qns_ice) 
    238                &    +      ( pfrld(ji,jj)**betas - pfrld(ji,jj) ) * sprecip(ji,jj)       & 
    239                &         * ( cpic * ( MIN( tatm_ice(ji,jj), rt0_snow ) - rtt ) - lfus )  & 
    240                &    +      ( 1._wp - pfrld(ji,jj) ) * ( tprecip(ji,jj) - sprecip(ji,jj) ) * rcp * ( tatm_ice(ji,jj) - rtt )       & 
     233               &    +      ( pfrld(ji,jj)**rn_betas - pfrld(ji,jj) ) * sprecip(ji,jj)       & 
     234               &         * ( cpic * ( MIN( tatm_ice(ji,jj), rt0_snow ) - rt0 ) - lfus )  & 
     235               &    +      ( 1._wp - pfrld(ji,jj) ) * ( tprecip(ji,jj) - sprecip(ji,jj) ) * rcp * ( tatm_ice(ji,jj) - rt0 )       & 
    241236               ! heat flux taken from the ocean where there is open water ice formation 
    242237               &    -      qlead(ji,jj) * r1_rdtice                                                                               & 
    … …  
    259254         ENDIF 
    260255 
    261          zareamin = epsi10 
    262256         nbpb = 0 
    263257         DO jj = 1, jpj 
    264258            DO ji = 1, jpi 
    265                IF ( a_i(ji,jj,jl) .gt. zareamin ) THEN      
     259               IF ( a_i(ji,jj,jl) > epsi10 ) THEN      
    266260                  nbpb      = nbpb  + 1 
    267261                  npb(nbpb) = (jj - 1) * jpi + ji 
    … …  
    272266         ! debug point to follow 
    273267         jiindex_1d = 0 
    274          IF( ln_nicep ) THEN 
    275             DO ji = mi0(jiindx), mi1(jiindx) 
    276                DO jj = mj0(jjindx), mj1(jjindx) 
     268         IF( ln_icectl ) THEN 
     269            DO ji = mi0(iiceprt), mi1(iiceprt) 
     270               DO jj = mj0(jiceprt), mj1(jiceprt) 
    277271                  jiindex_1d = (jj - 1) * jpi + ji 
    278272                  WRITE(numout,*) ' lim_thd : Category no : ', jl  
    … …  
    289283         IF( nbpb > 0 ) THEN  ! If there is no ice, do nothing. 
    290284 
    291             !------------------------- 
    292             ! 4.1 Move to 1D arrays 
    293             !------------------------- 
    294  
    295             CALL tab_2d_1d( nbpb, at_i_1d     (1:nbpb), at_i            , jpi, jpj, npb(1:nbpb) ) 
    296             CALL tab_2d_1d( nbpb, a_i_1d      (1:nbpb), a_i(:,:,jl)     , jpi, jpj, npb(1:nbpb) ) 
    297             CALL tab_2d_1d( nbpb, ht_i_1d     (1:nbpb), ht_i(:,:,jl)    , jpi, jpj, npb(1:nbpb) ) 
    298             CALL tab_2d_1d( nbpb, ht_s_1d     (1:nbpb), ht_s(:,:,jl)    , jpi, jpj, npb(1:nbpb) ) 
    299  
    300             CALL tab_2d_1d( nbpb, t_su_1d     (1:nbpb), t_su(:,:,jl)    , jpi, jpj, npb(1:nbpb) ) 
    301             CALL tab_2d_1d( nbpb, sm_i_1d     (1:nbpb), sm_i(:,:,jl)    , jpi, jpj, npb(1:nbpb) ) 
    302             DO jk = 1, nlay_s 
    303                CALL tab_2d_1d( nbpb, t_s_1d(1:nbpb,jk), t_s(:,:,jk,jl)  , jpi, jpj, npb(1:nbpb) ) 
    304                CALL tab_2d_1d( nbpb, q_s_1d(1:nbpb,jk), e_s(:,:,jk,jl)  , jpi, jpj, npb(1:nbpb) ) 
    305             END DO 
    306             DO jk = 1, nlay_i 
    307                CALL tab_2d_1d( nbpb, t_i_1d(1:nbpb,jk), t_i(:,:,jk,jl)  , jpi, jpj, npb(1:nbpb) ) 
    308                CALL tab_2d_1d( nbpb, q_i_1d(1:nbpb,jk), e_i(:,:,jk,jl)  , jpi, jpj, npb(1:nbpb) ) 
    309                CALL tab_2d_1d( nbpb, s_i_1d(1:nbpb,jk), s_i(:,:,jk,jl)  , jpi, jpj, npb(1:nbpb) ) 
    310             END DO 
    311  
    312             CALL tab_2d_1d( nbpb, tatm_ice_1d(1:nbpb), tatm_ice(:,:)   , jpi, jpj, npb(1:nbpb) ) 
    313             CALL tab_2d_1d( nbpb, qsr_ice_1d (1:nbpb), qsr_ice(:,:,jl) , jpi, jpj, npb(1:nbpb) ) 
    314             CALL tab_2d_1d( nbpb, fr1_i0_1d  (1:nbpb), fr1_i0          , jpi, jpj, npb(1:nbpb) ) 
    315             CALL tab_2d_1d( nbpb, fr2_i0_1d  (1:nbpb), fr2_i0          , jpi, jpj, npb(1:nbpb) ) 
    316             CALL tab_2d_1d( nbpb, qns_ice_1d (1:nbpb), qns_ice(:,:,jl) , jpi, jpj, npb(1:nbpb) ) 
    317             CALL tab_2d_1d( nbpb, ftr_ice_1d (1:nbpb), ftr_ice(:,:,jl) , jpi, jpj, npb(1:nbpb) ) 
    318             IF( .NOT. lk_cpl ) THEN 
    319                CALL tab_2d_1d( nbpb, qla_ice_1d (1:nbpb), qla_ice(:,:,jl) , jpi, jpj, npb(1:nbpb) ) 
    320                CALL tab_2d_1d( nbpb, dqla_ice_1d(1:nbpb), dqla_ice(:,:,jl), jpi, jpj, npb(1:nbpb) ) 
    321             ENDIF 
    322             CALL tab_2d_1d( nbpb, dqns_ice_1d(1:nbpb), dqns_ice(:,:,jl), jpi, jpj, npb(1:nbpb) ) 
    323             CALL tab_2d_1d( nbpb, t_bo_1d     (1:nbpb), t_bo            , jpi, jpj, npb(1:nbpb) ) 
    324             CALL tab_2d_1d( nbpb, sprecip_1d (1:nbpb), sprecip         , jpi, jpj, npb(1:nbpb) )  
    325             CALL tab_2d_1d( nbpb, fhtur_1d   (1:nbpb), fhtur           , jpi, jpj, npb(1:nbpb) ) 
    326             CALL tab_2d_1d( nbpb, qlead_1d   (1:nbpb), qlead           , jpi, jpj, npb(1:nbpb) ) 
    327             CALL tab_2d_1d( nbpb, fhld_1d    (1:nbpb), fhld            , jpi, jpj, npb(1:nbpb) ) 
    328  
    329             CALL tab_2d_1d( nbpb, wfx_snw_1d (1:nbpb), wfx_snw         , jpi, jpj, npb(1:nbpb) ) 
    330             CALL tab_2d_1d( nbpb, wfx_sub_1d (1:nbpb), wfx_sub         , jpi, jpj, npb(1:nbpb) ) 
    331  
    332             CALL tab_2d_1d( nbpb, wfx_bog_1d (1:nbpb), wfx_bog         , jpi, jpj, npb(1:nbpb) ) 
    333             CALL tab_2d_1d( nbpb, wfx_bom_1d (1:nbpb), wfx_bom         , jpi, jpj, npb(1:nbpb) ) 
    334             CALL tab_2d_1d( nbpb, wfx_sum_1d (1:nbpb), wfx_sum         , jpi, jpj, npb(1:nbpb) ) 
    335             CALL tab_2d_1d( nbpb, wfx_sni_1d (1:nbpb), wfx_sni         , jpi, jpj, npb(1:nbpb) ) 
    336             CALL tab_2d_1d( nbpb, wfx_res_1d (1:nbpb), wfx_res         , jpi, jpj, npb(1:nbpb) ) 
    337             CALL tab_2d_1d( nbpb, wfx_spr_1d (1:nbpb), wfx_spr         , jpi, jpj, npb(1:nbpb) ) 
    338  
    339             CALL tab_2d_1d( nbpb, sfx_bog_1d (1:nbpb), sfx_bog         , jpi, jpj, npb(1:nbpb) ) 
    340             CALL tab_2d_1d( nbpb, sfx_bom_1d (1:nbpb), sfx_bom         , jpi, jpj, npb(1:nbpb) ) 
    341             CALL tab_2d_1d( nbpb, sfx_sum_1d (1:nbpb), sfx_sum         , jpi, jpj, npb(1:nbpb) ) 
    342             CALL tab_2d_1d( nbpb, sfx_sni_1d (1:nbpb), sfx_sni         , jpi, jpj, npb(1:nbpb) ) 
    343             CALL tab_2d_1d( nbpb, sfx_bri_1d (1:nbpb), sfx_bri         , jpi, jpj, npb(1:nbpb) ) 
    344             CALL tab_2d_1d( nbpb, sfx_res_1d (1:nbpb), sfx_res         , jpi, jpj, npb(1:nbpb) ) 
    345  
    346             CALL tab_2d_1d( nbpb, hfx_thd_1d (1:nbpb), hfx_thd         , jpi, jpj, npb(1:nbpb) ) 
    347             CALL tab_2d_1d( nbpb, hfx_spr_1d (1:nbpb), hfx_spr         , jpi, jpj, npb(1:nbpb) ) 
    348             CALL tab_2d_1d( nbpb, hfx_sum_1d (1:nbpb), hfx_sum         , jpi, jpj, npb(1:nbpb) ) 
    349             CALL tab_2d_1d( nbpb, hfx_bom_1d (1:nbpb), hfx_bom         , jpi, jpj, npb(1:nbpb) ) 
    350             CALL tab_2d_1d( nbpb, hfx_bog_1d (1:nbpb), hfx_bog         , jpi, jpj, npb(1:nbpb) ) 
    351             CALL tab_2d_1d( nbpb, hfx_dif_1d (1:nbpb), hfx_dif         , jpi, jpj, npb(1:nbpb) ) 
    352             CALL tab_2d_1d( nbpb, hfx_opw_1d (1:nbpb), hfx_opw         , jpi, jpj, npb(1:nbpb) ) 
    353             CALL tab_2d_1d( nbpb, hfx_snw_1d (1:nbpb), hfx_snw         , jpi, jpj, npb(1:nbpb) ) 
    354             CALL tab_2d_1d( nbpb, hfx_sub_1d (1:nbpb), hfx_sub         , jpi, jpj, npb(1:nbpb) ) 
    355             CALL tab_2d_1d( nbpb, hfx_err_1d (1:nbpb), hfx_err         , jpi, jpj, npb(1:nbpb) ) 
    356             CALL tab_2d_1d( nbpb, hfx_res_1d (1:nbpb), hfx_res         , jpi, jpj, npb(1:nbpb) ) 
    357             CALL tab_2d_1d( nbpb, hfx_err_rem_1d (1:nbpb), hfx_err_rem , jpi, jpj, npb(1:nbpb) ) 
    358  
    359             !-------------------------------- 
    360             ! 4.3) Thermodynamic processes 
    361             !-------------------------------- 
     285            !-------------------------! 
     286            ! --- Move to 1D arrays --- 
     287            !-------------------------! 
     288            CALL lim_thd_1d2d( nbpb, jl, 1 ) 
     289 
     290            !--------------------------------------! 
     291            ! --- Ice/Snow Temperature profile --- ! 
     292            !--------------------------------------! 
     293            CALL lim_thd_dif( 1, nbpb ) 
    362294 
    363295            !---------------------------------! 
    364             ! Ice/Snow Temperature profile    ! 
    365             !---------------------------------! 
    366             CALL lim_thd_dif( 1, nbpb ) 
    367  
    368             !---------------------------------! 
    369             ! Ice/Snow thicnkess              ! 
     296            ! --- Ice/Snow thickness ---      ! 
    370297            !---------------------------------! 
    371298            CALL lim_thd_dh( 1, nbpb )     
    … …  
    375302                                             
    376303            !---------------------------------! 
    377             ! --- Ice salinity --- ! 
     304            ! --- Ice salinity ---            ! 
    378305            !---------------------------------! 
    379306            CALL lim_thd_sal( 1, nbpb )     
    380307 
    381308            !---------------------------------! 
    382             ! --- temperature update --- ! 
     309            ! --- temperature update ---      ! 
    383310            !---------------------------------! 
    384311            CALL lim_thd_temp( 1, nbpb ) 
    385312 
    386             !-------------------------------- 
    387             ! 4.4) Move 1D to 2D vectors 
    388             !-------------------------------- 
    389  
    390                CALL tab_1d_2d( nbpb, at_i          , npb, at_i_1d    (1:nbpb)   , jpi, jpj ) 
    391                CALL tab_1d_2d( nbpb, ht_i(:,:,jl)  , npb, ht_i_1d    (1:nbpb)   , jpi, jpj ) 
    392                CALL tab_1d_2d( nbpb, ht_s(:,:,jl)  , npb, ht_s_1d    (1:nbpb)   , jpi, jpj ) 
    393                CALL tab_1d_2d( nbpb, a_i (:,:,jl)  , npb, a_i_1d     (1:nbpb)   , jpi, jpj ) 
    394                CALL tab_1d_2d( nbpb, t_su(:,:,jl)  , npb, t_su_1d    (1:nbpb)   , jpi, jpj ) 
    395                CALL tab_1d_2d( nbpb, sm_i(:,:,jl)  , npb, sm_i_1d    (1:nbpb)   , jpi, jpj ) 
    396             DO jk = 1, nlay_s 
    397                CALL tab_1d_2d( nbpb, t_s(:,:,jk,jl), npb, t_s_1d     (1:nbpb,jk), jpi, jpj) 
    398                CALL tab_1d_2d( nbpb, e_s(:,:,jk,jl), npb, q_s_1d     (1:nbpb,jk), jpi, jpj) 
    399             END DO 
    400             DO jk = 1, nlay_i 
    401                CALL tab_1d_2d( nbpb, t_i(:,:,jk,jl), npb, t_i_1d     (1:nbpb,jk), jpi, jpj) 
    402                CALL tab_1d_2d( nbpb, e_i(:,:,jk,jl), npb, q_i_1d     (1:nbpb,jk), jpi, jpj) 
    403                CALL tab_1d_2d( nbpb, s_i(:,:,jk,jl), npb, s_i_1d     (1:nbpb,jk), jpi, jpj) 
    404             END DO 
    405                CALL tab_1d_2d( nbpb, qlead         , npb, qlead_1d  (1:nbpb)   , jpi, jpj ) 
    406  
    407                CALL tab_1d_2d( nbpb, wfx_snw       , npb, wfx_snw_1d(1:nbpb)   , jpi, jpj ) 
    408                CALL tab_1d_2d( nbpb, wfx_sub       , npb, wfx_sub_1d(1:nbpb)   , jpi, jpj ) 
    409  
    410                CALL tab_1d_2d( nbpb, wfx_bog       , npb, wfx_bog_1d(1:nbpb)   , jpi, jpj ) 
    411                CALL tab_1d_2d( nbpb, wfx_bom       , npb, wfx_bom_1d(1:nbpb)   , jpi, jpj ) 
    412                CALL tab_1d_2d( nbpb, wfx_sum       , npb, wfx_sum_1d(1:nbpb)   , jpi, jpj ) 
    413                CALL tab_1d_2d( nbpb, wfx_sni       , npb, wfx_sni_1d(1:nbpb)   , jpi, jpj ) 
    414                CALL tab_1d_2d( nbpb, wfx_res       , npb, wfx_res_1d(1:nbpb)   , jpi, jpj ) 
    415                CALL tab_1d_2d( nbpb, wfx_spr       , npb, wfx_spr_1d(1:nbpb)   , jpi, jpj ) 
    416  
    417                CALL tab_1d_2d( nbpb, sfx_bog       , npb, sfx_bog_1d(1:nbpb)   , jpi, jpj ) 
    418                CALL tab_1d_2d( nbpb, sfx_bom       , npb, sfx_bom_1d(1:nbpb)   , jpi, jpj ) 
    419                CALL tab_1d_2d( nbpb, sfx_sum       , npb, sfx_sum_1d(1:nbpb)   , jpi, jpj ) 
    420                CALL tab_1d_2d( nbpb, sfx_sni       , npb, sfx_sni_1d(1:nbpb)   , jpi, jpj ) 
    421                CALL tab_1d_2d( nbpb, sfx_res       , npb, sfx_res_1d(1:nbpb)   , jpi, jpj ) 
    422                CALL tab_1d_2d( nbpb, sfx_bri       , npb, sfx_bri_1d(1:nbpb)   , jpi, jpj ) 
    423  
    424               CALL tab_1d_2d( nbpb, hfx_thd       , npb, hfx_thd_1d(1:nbpb)   , jpi, jpj ) 
    425               CALL tab_1d_2d( nbpb, hfx_spr       , npb, hfx_spr_1d(1:nbpb)   , jpi, jpj ) 
    426               CALL tab_1d_2d( nbpb, hfx_sum       , npb, hfx_sum_1d(1:nbpb)   , jpi, jpj ) 
    427               CALL tab_1d_2d( nbpb, hfx_bom       , npb, hfx_bom_1d(1:nbpb)   , jpi, jpj ) 
    428               CALL tab_1d_2d( nbpb, hfx_bog       , npb, hfx_bog_1d(1:nbpb)   , jpi, jpj ) 
    429               CALL tab_1d_2d( nbpb, hfx_dif       , npb, hfx_dif_1d(1:nbpb)   , jpi, jpj ) 
    430               CALL tab_1d_2d( nbpb, hfx_opw       , npb, hfx_opw_1d(1:nbpb)   , jpi, jpj ) 
    431               CALL tab_1d_2d( nbpb, hfx_snw       , npb, hfx_snw_1d(1:nbpb)   , jpi, jpj ) 
    432               CALL tab_1d_2d( nbpb, hfx_sub       , npb, hfx_sub_1d(1:nbpb)   , jpi, jpj ) 
    433               CALL tab_1d_2d( nbpb, hfx_err       , npb, hfx_err_1d(1:nbpb)   , jpi, jpj ) 
    434               CALL tab_1d_2d( nbpb, hfx_res       , npb, hfx_res_1d(1:nbpb)   , jpi, jpj ) 
    435               CALL tab_1d_2d( nbpb, hfx_err_rem   , npb, hfx_err_rem_1d(1:nbpb)   , jpi, jpj ) 
    436             ! 
    437               CALL tab_1d_2d( nbpb, qns_ice(:,:,jl), npb, qns_ice_1d(1:nbpb) , jpi, jpj) 
    438               CALL tab_1d_2d( nbpb, ftr_ice(:,:,jl), npb, ftr_ice_1d(1:nbpb) , jpi, jpj ) 
     313            !------------------------------------! 
     314            ! --- lateral melting if monocat --- ! 
     315            !------------------------------------! 
     316            IF ( ( nn_monocat == 1 .OR. nn_monocat == 4 ) .AND. jpl == 1 ) THEN 
     317               CALL lim_thd_lam( 1, nbpb ) 
     318            END IF 
     319 
     320            !-------------------------! 
     321            ! --- Move to 2D arrays --- 
     322            !-------------------------! 
     323            CALL lim_thd_1d2d( nbpb, jl, 2 ) 
     324 
    439325            ! 
    440326            IF( lk_mpp )   CALL mpp_comm_free( ncomm_ice ) !RB necessary ?? 
    441327         ENDIF 
    442328         ! 
    443       END DO 
     329      END DO !jl 
    444330 
    445331      !------------------------------------------------------------------------------! 
    … …  
    448334 
    449335      !------------------------ 
    450       ! 5.1) Ice heat content               
     336      ! Ice heat content               
    451337      !------------------------ 
    452       ! Enthalpies are global variables we have to readjust the units (heat content in Joules) 
     338      ! Enthalpies are global variables we have to readjust the units (heat content in J/m2) 
    453339      DO jl = 1, jpl 
    454340         DO jk = 1, nlay_i 
    455             e_i(:,:,jk,jl) = e_i(:,:,jk,jl) * area(:,:) * a_i(:,:,jl) * ht_i(:,:,jl) / ( unit_fac * REAL( nlay_i ) ) 
     341            e_i(:,:,jk,jl) = e_i(:,:,jk,jl) * a_i(:,:,jl) * ht_i(:,:,jl) * r1_nlay_i 
    456342         END DO 
    457343      END DO 
    458344 
    459345      !------------------------ 
    460       ! 5.2) Snow heat content               
     346      ! Snow heat content               
    461347      !------------------------ 
    462       ! Enthalpies are global variables we have to readjust the units (heat content in Joules) 
     348      ! Enthalpies are global variables we have to readjust the units (heat content in J/m2) 
    463349      DO jl = 1, jpl 
    464350         DO jk = 1, nlay_s 
    465             e_s(:,:,jk,jl) = e_s(:,:,jk,jl) * area(:,:) * a_i(:,:,jl) * ht_s(:,:,jl) / ( unit_fac * REAL( nlay_s ) ) 
     351            e_s(:,:,jk,jl) = e_s(:,:,jk,jl) * a_i(:,:,jl) * ht_s(:,:,jl) * r1_nlay_s 
    466352         END DO 
    467353      END DO 
    468  
     354  
    469355      !---------------------------------- 
    470       ! 5.3) Change thickness to volume 
     356      ! Change thickness to volume 
    471357      !---------------------------------- 
    472       CALL lim_var_eqv2glo 
     358      v_i(:,:,:)   = ht_i(:,:,:) * a_i(:,:,:) 
     359      v_s(:,:,:)   = ht_s(:,:,:) * a_i(:,:,:) 
     360      smv_i(:,:,:) = sm_i(:,:,:) * v_i(:,:,:) 
     361 
     362      ! update ice age (in case a_i changed, i.e. becomes 0 or lateral melting in monocat) 
     363      DO jl  = 1, jpl 
     364         DO jj = 1, jpj 
     365            DO ji = 1, jpi 
     366               rswitch = MAX( 0._wp , SIGN( 1._wp, a_i_b(ji,jj,jl) - epsi10 ) ) 
     367               oa_i(ji,jj,jl) = rswitch * oa_i(ji,jj,jl) * a_i(ji,jj,jl) / MAX( a_i_b(ji,jj,jl), epsi10 ) 
     368            END DO 
     369         END DO 
     370      END DO 
     371 
     372      CALL lim_var_zapsmall 
    473373 
    474374      !-------------------------------------------- 
    475       ! 5.4) Diagnostic thermodynamic growth rates 
     375      ! Diagnostic thermodynamic growth rates 
    476376      !-------------------------------------------- 
     377      IF( ln_icectl )   CALL lim_prt( kt, iiceprt, jiceprt, 1, ' - ice thermodyn. - ' )   ! control print 
     378 
    477379      IF(ln_ctl) THEN            ! Control print 
    478380         CALL prt_ctl_info(' ') 
    479381         CALL prt_ctl_info(' - Cell values : ') 
    480382         CALL prt_ctl_info('   ~~~~~~~~~~~~~ ') 
    481          CALL prt_ctl(tab2d_1=area , clinfo1=' lim_thd  : cell area :') 
     383         CALL prt_ctl(tab2d_1=e12t , clinfo1=' lim_thd  : cell area :') 
    482384         CALL prt_ctl(tab2d_1=at_i , clinfo1=' lim_thd  : at_i      :') 
    483385         CALL prt_ctl(tab2d_1=vt_i , clinfo1=' lim_thd  : vt_i      :') 
    … …  
    508410      ! 
    509411      ! 
    510       CALL wrk_dealloc( jpi, jpj, zqsr, zqns ) 
    511  
    512       ! 
    513       ! conservation test 
    514412      IF( ln_limdiahsb ) CALL lim_cons_hsm(1, 'limthd', zvi_b, zsmv_b, zei_b, zfw_b, zfs_b, zft_b) 
     413 
     414      CALL wrk_dealloc( jpi,jpj, zqsr, zqns ) 
     415 
     416      !------------------------------------------------------------------------------| 
     417      !  6) Transport of ice between thickness categories.                           | 
     418      !------------------------------------------------------------------------------| 
     419      ! Given thermodynamic growth rates, transport ice between thickness categories. 
     420      IF( ln_limdiahsb ) CALL lim_cons_hsm(0, 'limitd_th_rem', zvi_b, zsmv_b, zei_b, zfw_b, zfs_b, zft_b) 
     421 
     422      IF( jpl > 1 )      CALL lim_itd_th_rem( 1, jpl, kt ) 
     423 
     424      IF( ln_limdiahsb ) CALL lim_cons_hsm(1, 'limitd_th_rem', zvi_b, zsmv_b, zei_b, zfw_b, zfs_b, zft_b) 
     425 
     426      !------------------------------------------------------------------------------| 
     427      !  7) Add frazil ice growing in leads. 
     428      !------------------------------------------------------------------------------| 
     429      IF( ln_limdiahsb ) CALL lim_cons_hsm(0, 'limthd_lac', zvi_b, zsmv_b, zei_b, zfw_b, zfs_b, zft_b) 
     430 
     431      CALL lim_thd_lac 
     432       
     433      IF( ln_limdiahsb ) CALL lim_cons_hsm(1, 'limthd_lac', zvi_b, zsmv_b, zei_b, zfw_b, zfs_b, zft_b) 
     434 
     435      ! Control print 
     436      IF(ln_ctl) THEN 
     437         CALL lim_var_glo2eqv 
     438 
     439         CALL prt_ctl_info(' ') 
     440         CALL prt_ctl_info(' - Cell values : ') 
     441         CALL prt_ctl_info('   ~~~~~~~~~~~~~ ') 
     442         CALL prt_ctl(tab2d_1=e12t , clinfo1=' lim_itd_th  : cell area :') 
     443         CALL prt_ctl(tab2d_1=at_i , clinfo1=' lim_itd_th  : at_i      :') 
     444         CALL prt_ctl(tab2d_1=vt_i , clinfo1=' lim_itd_th  : vt_i      :') 
     445         CALL prt_ctl(tab2d_1=vt_s , clinfo1=' lim_itd_th  : vt_s      :') 
     446         DO jl = 1, jpl 
     447            CALL prt_ctl_info(' ') 
     448            CALL prt_ctl_info(' - Category : ', ivar1=jl) 
     449            CALL prt_ctl_info('   ~~~~~~~~~~') 
     450            CALL prt_ctl(tab2d_1=a_i   (:,:,jl)   , clinfo1= ' lim_itd_th  : a_i      : ') 
     451            CALL prt_ctl(tab2d_1=ht_i  (:,:,jl)   , clinfo1= ' lim_itd_th  : ht_i     : ') 
     452            CALL prt_ctl(tab2d_1=ht_s  (:,:,jl)   , clinfo1= ' lim_itd_th  : ht_s     : ') 
     453            CALL prt_ctl(tab2d_1=v_i   (:,:,jl)   , clinfo1= ' lim_itd_th  : v_i      : ') 
     454            CALL prt_ctl(tab2d_1=v_s   (:,:,jl)   , clinfo1= ' lim_itd_th  : v_s      : ') 
     455            CALL prt_ctl(tab2d_1=e_s   (:,:,1,jl) , clinfo1= ' lim_itd_th  : e_s      : ') 
     456            CALL prt_ctl(tab2d_1=t_su  (:,:,jl)   , clinfo1= ' lim_itd_th  : t_su     : ') 
     457            CALL prt_ctl(tab2d_1=t_s   (:,:,1,jl) , clinfo1= ' lim_itd_th  : t_snow   : ') 
     458            CALL prt_ctl(tab2d_1=sm_i  (:,:,jl)   , clinfo1= ' lim_itd_th  : sm_i     : ') 
     459            CALL prt_ctl(tab2d_1=smv_i (:,:,jl)   , clinfo1= ' lim_itd_th  : smv_i    : ') 
     460            DO jk = 1, nlay_i 
     461               CALL prt_ctl_info(' ') 
     462               CALL prt_ctl_info(' - Layer : ', ivar1=jk) 
     463               CALL prt_ctl_info('   ~~~~~~~') 
     464               CALL prt_ctl(tab2d_1=t_i(:,:,jk,jl) , clinfo1= ' lim_itd_th  : t_i      : ') 
     465               CALL prt_ctl(tab2d_1=e_i(:,:,jk,jl) , clinfo1= ' lim_itd_th  : e_i      : ') 
     466            END DO 
     467         END DO 
     468      ENDIF 
    515469      ! 
    516470      IF( nn_timing == 1 )  CALL timing_stop('limthd') 
    … …  
    534488      DO jk = 1, nlay_i 
    535489         DO ji = kideb, kiut 
    536             ztmelts       =  -tmut * s_i_1d(ji,jk) + rtt 
     490            ztmelts       =  -tmut * s_i_1d(ji,jk) + rt0 
    537491            ! Conversion q(S,T) -> T (second order equation) 
    538492            zaaa          =  cpic 
    539             zbbb          =  ( rcp - cpic ) * ( ztmelts - rtt ) + q_i_1d(ji,jk) / rhoic - lfus 
    540             zccc          =  lfus * ( ztmelts - rtt ) 
     493            zbbb          =  ( rcp - cpic ) * ( ztmelts - rt0 ) + q_i_1d(ji,jk) * r1_rhoic - lfus 
     494            zccc          =  lfus * ( ztmelts - rt0 ) 
    541495            zdiscrim      =  SQRT( MAX( zbbb * zbbb - 4._wp * zaaa * zccc, 0._wp ) ) 
    542             t_i_1d(ji,jk) =  rtt - ( zbbb + zdiscrim ) / ( 2._wp * zaaa ) 
     496            t_i_1d(ji,jk) =  rt0 - ( zbbb + zdiscrim ) / ( 2._wp * zaaa ) 
    543497             
    544498            ! mask temperature 
    545499            rswitch       =  1._wp - MAX( 0._wp , SIGN( 1._wp , - ht_i_1d(ji) ) )  
    546             t_i_1d(ji,jk) =  rswitch * t_i_1d(ji,jk) + ( 1._wp - rswitch ) * rtt 
     500            t_i_1d(ji,jk) =  rswitch * t_i_1d(ji,jk) + ( 1._wp - rswitch ) * rt0 
    547501         END DO  
    548502      END DO  
    549503 
    550504   END SUBROUTINE lim_thd_temp 
     505 
     506   SUBROUTINE lim_thd_lam( kideb, kiut ) 
     507      !!----------------------------------------------------------------------- 
     508      !!                   ***  ROUTINE lim_thd_lam ***  
     509      !!                  
     510      !! ** Purpose :   Lateral melting in case monocategory 
     511      !!                          ( dA = A/2h dh ) 
     512      !!----------------------------------------------------------------------- 
     513      INTEGER, INTENT(in) ::   kideb, kiut        ! bounds for the spatial loop 
     514      INTEGER             ::   ji                 ! dummy loop indices 
     515      REAL(wp)            ::   zhi_bef            ! ice thickness before thermo 
     516      REAL(wp)            ::   zdh_mel, zda_mel   ! net melting 
     517      REAL(wp)            ::   zvi, zvs           ! ice/snow volumes  
     518 
     519      DO ji = kideb, kiut 
     520         zdh_mel = MIN( 0._wp, dh_i_surf(ji) + dh_i_bott(ji) + dh_snowice(ji) ) 
     521         IF( zdh_mel < 0._wp .AND. a_i_1d(ji) > 0._wp )  THEN 
     522            zvi          = a_i_1d(ji) * ht_i_1d(ji) 
     523            zvs          = a_i_1d(ji) * ht_s_1d(ji) 
     524            ! lateral melting = concentration change 
     525            zhi_bef     = ht_i_1d(ji) - zdh_mel 
     526            rswitch     = MAX( 0._wp , SIGN( 1._wp , zhi_bef - epsi20 ) ) 
     527            zda_mel     = rswitch * a_i_1d(ji) * zdh_mel / ( 2._wp * MAX( zhi_bef, epsi20 ) ) 
     528            a_i_1d(ji)  = MAX( epsi20, a_i_1d(ji) + zda_mel )  
     529             ! adjust thickness 
     530            ht_i_1d(ji) = zvi / a_i_1d(ji)             
     531            ht_s_1d(ji) = zvs / a_i_1d(ji)             
     532            ! retrieve total concentration 
     533            at_i_1d(ji) = a_i_1d(ji) 
     534         END IF 
     535      END DO 
     536       
     537   END SUBROUTINE lim_thd_lam 
     538 
     539   SUBROUTINE lim_thd_1d2d( nbpb, jl, kn ) 
     540      !!----------------------------------------------------------------------- 
     541      !!                   ***  ROUTINE lim_thd_1d2d ***  
     542      !!                  
     543      !! ** Purpose :   move arrays from 1d to 2d and the reverse 
     544      !!----------------------------------------------------------------------- 
     545      INTEGER, INTENT(in) ::   kn       ! 1= from 2D to 1D 
     546                                        ! 2= from 1D to 2D 
     547      INTEGER, INTENT(in) ::   nbpb     ! size of 1D arrays 
     548      INTEGER, INTENT(in) ::   jl       ! ice cat 
     549      INTEGER             ::   jk       ! dummy loop indices 
     550 
     551      SELECT CASE( kn ) 
     552 
     553      CASE( 1 ) 
     554 
     555         CALL tab_2d_1d( nbpb, at_i_1d     (1:nbpb), at_i            , jpi, jpj, npb(1:nbpb) ) 
     556         CALL tab_2d_1d( nbpb, a_i_1d      (1:nbpb), a_i(:,:,jl)     , jpi, jpj, npb(1:nbpb) ) 
     557         CALL tab_2d_1d( nbpb, ht_i_1d     (1:nbpb), ht_i(:,:,jl)    , jpi, jpj, npb(1:nbpb) ) 
     558         CALL tab_2d_1d( nbpb, ht_s_1d     (1:nbpb), ht_s(:,:,jl)    , jpi, jpj, npb(1:nbpb) ) 
     559          
     560         CALL tab_2d_1d( nbpb, t_su_1d     (1:nbpb), t_su(:,:,jl)    , jpi, jpj, npb(1:nbpb) ) 
     561         CALL tab_2d_1d( nbpb, sm_i_1d     (1:nbpb), sm_i(:,:,jl)    , jpi, jpj, npb(1:nbpb) ) 
     562         DO jk = 1, nlay_s 
     563            CALL tab_2d_1d( nbpb, t_s_1d(1:nbpb,jk), t_s(:,:,jk,jl)  , jpi, jpj, npb(1:nbpb) ) 
     564            CALL tab_2d_1d( nbpb, q_s_1d(1:nbpb,jk), e_s(:,:,jk,jl)  , jpi, jpj, npb(1:nbpb) ) 
     565         END DO 
     566         DO jk = 1, nlay_i 
     567            CALL tab_2d_1d( nbpb, t_i_1d(1:nbpb,jk), t_i(:,:,jk,jl)  , jpi, jpj, npb(1:nbpb) ) 
     568            CALL tab_2d_1d( nbpb, q_i_1d(1:nbpb,jk), e_i(:,:,jk,jl)  , jpi, jpj, npb(1:nbpb) ) 
     569            CALL tab_2d_1d( nbpb, s_i_1d(1:nbpb,jk), s_i(:,:,jk,jl)  , jpi, jpj, npb(1:nbpb) ) 
     570         END DO 
     571          
     572         CALL tab_2d_1d( nbpb, tatm_ice_1d(1:nbpb), tatm_ice(:,:)   , jpi, jpj, npb(1:nbpb) ) 
     573         CALL tab_2d_1d( nbpb, qsr_ice_1d (1:nbpb), qsr_ice(:,:,jl) , jpi, jpj, npb(1:nbpb) ) 
     574         CALL tab_2d_1d( nbpb, fr1_i0_1d  (1:nbpb), fr1_i0          , jpi, jpj, npb(1:nbpb) ) 
     575         CALL tab_2d_1d( nbpb, fr2_i0_1d  (1:nbpb), fr2_i0          , jpi, jpj, npb(1:nbpb) ) 
     576         CALL tab_2d_1d( nbpb, qns_ice_1d (1:nbpb), qns_ice(:,:,jl) , jpi, jpj, npb(1:nbpb) ) 
     577         CALL tab_2d_1d( nbpb, ftr_ice_1d (1:nbpb), ftr_ice(:,:,jl) , jpi, jpj, npb(1:nbpb) ) 
     578         IF( .NOT. lk_cpl ) THEN 
     579            CALL tab_2d_1d( nbpb, qla_ice_1d (1:nbpb), qla_ice(:,:,jl) , jpi, jpj, npb(1:nbpb) ) 
     580            CALL tab_2d_1d( nbpb, dqla_ice_1d(1:nbpb), dqla_ice(:,:,jl), jpi, jpj, npb(1:nbpb) ) 
     581         ENDIF 
     582         CALL tab_2d_1d( nbpb, dqns_ice_1d(1:nbpb), dqns_ice(:,:,jl), jpi, jpj, npb(1:nbpb) ) 
     583         CALL tab_2d_1d( nbpb, t_bo_1d     (1:nbpb), t_bo            , jpi, jpj, npb(1:nbpb) ) 
     584         CALL tab_2d_1d( nbpb, sprecip_1d (1:nbpb), sprecip         , jpi, jpj, npb(1:nbpb) )  
     585         CALL tab_2d_1d( nbpb, fhtur_1d   (1:nbpb), fhtur           , jpi, jpj, npb(1:nbpb) ) 
     586         CALL tab_2d_1d( nbpb, qlead_1d   (1:nbpb), qlead           , jpi, jpj, npb(1:nbpb) ) 
     587         CALL tab_2d_1d( nbpb, fhld_1d    (1:nbpb), fhld            , jpi, jpj, npb(1:nbpb) ) 
     588          
     589         CALL tab_2d_1d( nbpb, wfx_snw_1d (1:nbpb), wfx_snw         , jpi, jpj, npb(1:nbpb) ) 
     590         CALL tab_2d_1d( nbpb, wfx_sub_1d (1:nbpb), wfx_sub         , jpi, jpj, npb(1:nbpb) ) 
     591          
     592         CALL tab_2d_1d( nbpb, wfx_bog_1d (1:nbpb), wfx_bog         , jpi, jpj, npb(1:nbpb) ) 
     593         CALL tab_2d_1d( nbpb, wfx_bom_1d (1:nbpb), wfx_bom         , jpi, jpj, npb(1:nbpb) ) 
     594         CALL tab_2d_1d( nbpb, wfx_sum_1d (1:nbpb), wfx_sum         , jpi, jpj, npb(1:nbpb) ) 
     595         CALL tab_2d_1d( nbpb, wfx_sni_1d (1:nbpb), wfx_sni         , jpi, jpj, npb(1:nbpb) ) 
     596         CALL tab_2d_1d( nbpb, wfx_res_1d (1:nbpb), wfx_res         , jpi, jpj, npb(1:nbpb) ) 
     597         CALL tab_2d_1d( nbpb, wfx_spr_1d (1:nbpb), wfx_spr         , jpi, jpj, npb(1:nbpb) ) 
     598          
     599         CALL tab_2d_1d( nbpb, sfx_bog_1d (1:nbpb), sfx_bog         , jpi, jpj, npb(1:nbpb) ) 
     600         CALL tab_2d_1d( nbpb, sfx_bom_1d (1:nbpb), sfx_bom         , jpi, jpj, npb(1:nbpb) ) 
     601         CALL tab_2d_1d( nbpb, sfx_sum_1d (1:nbpb), sfx_sum         , jpi, jpj, npb(1:nbpb) ) 
     602         CALL tab_2d_1d( nbpb, sfx_sni_1d (1:nbpb), sfx_sni         , jpi, jpj, npb(1:nbpb) ) 
     603         CALL tab_2d_1d( nbpb, sfx_bri_1d (1:nbpb), sfx_bri         , jpi, jpj, npb(1:nbpb) ) 
     604         CALL tab_2d_1d( nbpb, sfx_res_1d (1:nbpb), sfx_res         , jpi, jpj, npb(1:nbpb) ) 
     605          
     606         CALL tab_2d_1d( nbpb, hfx_thd_1d (1:nbpb), hfx_thd         , jpi, jpj, npb(1:nbpb) ) 
     607         CALL tab_2d_1d( nbpb, hfx_spr_1d (1:nbpb), hfx_spr         , jpi, jpj, npb(1:nbpb) ) 
     608         CALL tab_2d_1d( nbpb, hfx_sum_1d (1:nbpb), hfx_sum         , jpi, jpj, npb(1:nbpb) ) 
     609         CALL tab_2d_1d( nbpb, hfx_bom_1d (1:nbpb), hfx_bom         , jpi, jpj, npb(1:nbpb) ) 
     610         CALL tab_2d_1d( nbpb, hfx_bog_1d (1:nbpb), hfx_bog         , jpi, jpj, npb(1:nbpb) ) 
     611         CALL tab_2d_1d( nbpb, hfx_dif_1d (1:nbpb), hfx_dif         , jpi, jpj, npb(1:nbpb) ) 
     612         CALL tab_2d_1d( nbpb, hfx_opw_1d (1:nbpb), hfx_opw         , jpi, jpj, npb(1:nbpb) ) 
     613         CALL tab_2d_1d( nbpb, hfx_snw_1d (1:nbpb), hfx_snw         , jpi, jpj, npb(1:nbpb) ) 
     614         CALL tab_2d_1d( nbpb, hfx_sub_1d (1:nbpb), hfx_sub         , jpi, jpj, npb(1:nbpb) ) 
     615         CALL tab_2d_1d( nbpb, hfx_err_1d (1:nbpb), hfx_err         , jpi, jpj, npb(1:nbpb) ) 
     616         CALL tab_2d_1d( nbpb, hfx_res_1d (1:nbpb), hfx_res         , jpi, jpj, npb(1:nbpb) ) 
     617         CALL tab_2d_1d( nbpb, hfx_err_dif_1d (1:nbpb), hfx_err_dif , jpi, jpj, npb(1:nbpb) ) 
     618         CALL tab_2d_1d( nbpb, hfx_err_rem_1d (1:nbpb), hfx_err_rem , jpi, jpj, npb(1:nbpb) ) 
     619 
     620      CASE( 2 ) 
     621 
     622         CALL tab_1d_2d( nbpb, at_i          , npb, at_i_1d    (1:nbpb)   , jpi, jpj ) 
     623         CALL tab_1d_2d( nbpb, ht_i(:,:,jl)  , npb, ht_i_1d    (1:nbpb)   , jpi, jpj ) 
     624         CALL tab_1d_2d( nbpb, ht_s(:,:,jl)  , npb, ht_s_1d    (1:nbpb)   , jpi, jpj ) 
     625         CALL tab_1d_2d( nbpb, a_i (:,:,jl)  , npb, a_i_1d     (1:nbpb)   , jpi, jpj ) 
     626         CALL tab_1d_2d( nbpb, t_su(:,:,jl)  , npb, t_su_1d    (1:nbpb)   , jpi, jpj ) 
     627         CALL tab_1d_2d( nbpb, sm_i(:,:,jl)  , npb, sm_i_1d    (1:nbpb)   , jpi, jpj ) 
     628         DO jk = 1, nlay_s 
     629            CALL tab_1d_2d( nbpb, t_s(:,:,jk,jl), npb, t_s_1d     (1:nbpb,jk), jpi, jpj) 
     630            CALL tab_1d_2d( nbpb, e_s(:,:,jk,jl), npb, q_s_1d     (1:nbpb,jk), jpi, jpj) 
     631         END DO 
     632         DO jk = 1, nlay_i 
     633            CALL tab_1d_2d( nbpb, t_i(:,:,jk,jl), npb, t_i_1d     (1:nbpb,jk), jpi, jpj) 
     634            CALL tab_1d_2d( nbpb, e_i(:,:,jk,jl), npb, q_i_1d     (1:nbpb,jk), jpi, jpj) 
     635            CALL tab_1d_2d( nbpb, s_i(:,:,jk,jl), npb, s_i_1d     (1:nbpb,jk), jpi, jpj) 
     636         END DO 
     637         CALL tab_1d_2d( nbpb, qlead         , npb, qlead_1d  (1:nbpb)   , jpi, jpj ) 
     638          
     639         CALL tab_1d_2d( nbpb, wfx_snw       , npb, wfx_snw_1d(1:nbpb)   , jpi, jpj ) 
     640         CALL tab_1d_2d( nbpb, wfx_sub       , npb, wfx_sub_1d(1:nbpb)   , jpi, jpj ) 
     641          
     642         CALL tab_1d_2d( nbpb, wfx_bog       , npb, wfx_bog_1d(1:nbpb)   , jpi, jpj ) 
     643         CALL tab_1d_2d( nbpb, wfx_bom       , npb, wfx_bom_1d(1:nbpb)   , jpi, jpj ) 
     644         CALL tab_1d_2d( nbpb, wfx_sum       , npb, wfx_sum_1d(1:nbpb)   , jpi, jpj ) 
     645         CALL tab_1d_2d( nbpb, wfx_sni       , npb, wfx_sni_1d(1:nbpb)   , jpi, jpj ) 
     646         CALL tab_1d_2d( nbpb, wfx_res       , npb, wfx_res_1d(1:nbpb)   , jpi, jpj ) 
     647         CALL tab_1d_2d( nbpb, wfx_spr       , npb, wfx_spr_1d(1:nbpb)   , jpi, jpj ) 
     648          
     649         CALL tab_1d_2d( nbpb, sfx_bog       , npb, sfx_bog_1d(1:nbpb)   , jpi, jpj ) 
     650         CALL tab_1d_2d( nbpb, sfx_bom       , npb, sfx_bom_1d(1:nbpb)   , jpi, jpj ) 
     651         CALL tab_1d_2d( nbpb, sfx_sum       , npb, sfx_sum_1d(1:nbpb)   , jpi, jpj ) 
     652         CALL tab_1d_2d( nbpb, sfx_sni       , npb, sfx_sni_1d(1:nbpb)   , jpi, jpj ) 
     653         CALL tab_1d_2d( nbpb, sfx_res       , npb, sfx_res_1d(1:nbpb)   , jpi, jpj ) 
     654         CALL tab_1d_2d( nbpb, sfx_bri       , npb, sfx_bri_1d(1:nbpb)   , jpi, jpj ) 
     655          
     656         CALL tab_1d_2d( nbpb, hfx_thd       , npb, hfx_thd_1d(1:nbpb)   , jpi, jpj ) 
     657         CALL tab_1d_2d( nbpb, hfx_spr       , npb, hfx_spr_1d(1:nbpb)   , jpi, jpj ) 
     658         CALL tab_1d_2d( nbpb, hfx_sum       , npb, hfx_sum_1d(1:nbpb)   , jpi, jpj ) 
     659         CALL tab_1d_2d( nbpb, hfx_bom       , npb, hfx_bom_1d(1:nbpb)   , jpi, jpj ) 
     660         CALL tab_1d_2d( nbpb, hfx_bog       , npb, hfx_bog_1d(1:nbpb)   , jpi, jpj ) 
     661         CALL tab_1d_2d( nbpb, hfx_dif       , npb, hfx_dif_1d(1:nbpb)   , jpi, jpj ) 
     662         CALL tab_1d_2d( nbpb, hfx_opw       , npb, hfx_opw_1d(1:nbpb)   , jpi, jpj ) 
     663         CALL tab_1d_2d( nbpb, hfx_snw       , npb, hfx_snw_1d(1:nbpb)   , jpi, jpj ) 
     664         CALL tab_1d_2d( nbpb, hfx_sub       , npb, hfx_sub_1d(1:nbpb)   , jpi, jpj ) 
     665         CALL tab_1d_2d( nbpb, hfx_err       , npb, hfx_err_1d(1:nbpb)   , jpi, jpj ) 
     666         CALL tab_1d_2d( nbpb, hfx_res       , npb, hfx_res_1d(1:nbpb)   , jpi, jpj ) 
     667         CALL tab_1d_2d( nbpb, hfx_err_rem   , npb, hfx_err_rem_1d(1:nbpb), jpi, jpj ) 
     668         CALL tab_1d_2d( nbpb, hfx_err_dif   , npb, hfx_err_dif_1d(1:nbpb), jpi, jpj ) 
     669         ! 
     670         CALL tab_1d_2d( nbpb, qns_ice(:,:,jl), npb, qns_ice_1d(1:nbpb) , jpi, jpj) 
     671         CALL tab_1d_2d( nbpb, ftr_ice(:,:,jl), npb, ftr_ice_1d(1:nbpb) , jpi, jpj ) 
     672                   
     673      END SELECT 
     674 
     675   END SUBROUTINE lim_thd_1d2d 
     676 
    551677 
    552678   SUBROUTINE lim_thd_init 
    … …  
    563689      !!------------------------------------------------------------------- 
    564690      INTEGER  ::   ios                 ! Local integer output status for namelist read 
    565       NAMELIST/namicethd/ hmelt , hiccrit, fraz_swi, maxfrazb, vfrazb, Cfrazb,   & 
    566          &                hiclim, hnzst, parsub, betas,                          &  
    567          &                kappa_i, nconv_i_thd, maxer_i_thd, thcon_i_swi 
     691      NAMELIST/namicethd/ rn_hnewice, ln_frazil, rn_maxfrazb, rn_vfrazb, rn_Cfrazb,                       & 
     692         &                rn_himin, rn_betas, rn_kappa_i, nn_conv_dif, rn_terr_dif, nn_ice_thcon, & 
     693         &                nn_monocat, ln_it_qnsice 
    568694      !!------------------------------------------------------------------- 
    569695      ! 
    … …  
    582708902   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namicethd in configuration namelist', lwp ) 
    583709      IF(lwm) WRITE ( numoni, namicethd ) 
    584  
    585       IF( lk_cpl .AND. parsub /= 0.0 )   CALL ctl_stop( 'In coupled mode, use parsub = 0. or send dqla' ) 
     710      ! 
     711      IF ( ( jpl > 1 ) .AND. ( nn_monocat == 1 ) ) THEN  
     712         nn_monocat = 0 
     713         IF(lwp) WRITE(numout, *) '   nn_monocat must be 0 in multi-category case ' 
     714      ENDIF 
     715 
    586716      ! 
    587717      IF(lwp) THEN                          ! control print 
    588718         WRITE(numout,*) 
    589719         WRITE(numout,*)'   Namelist of ice parameters for ice thermodynamic computation ' 
    590          WRITE(numout,*)'      maximum melting at the bottom                           hmelt        = ', hmelt 
    591          WRITE(numout,*)'      ice thick. for lateral accretion                        hiccrit      = ', hiccrit 
    592          WRITE(numout,*)'      Frazil ice thickness as a function of wind or not       fraz_swi     = ', fraz_swi 
    593          WRITE(numout,*)'      Maximum proportion of frazil ice collecting at bottom   maxfrazb     = ', maxfrazb 
    594          WRITE(numout,*)'      Thresold relative drift speed for collection of frazil  vfrazb       = ', vfrazb 
    595          WRITE(numout,*)'      Squeezing coefficient for collection of frazil          Cfrazb       = ', Cfrazb 
    596          WRITE(numout,*)'      minimum ice thickness                                   hiclim       = ', hiclim  
     720         WRITE(numout,*)'      ice thick. for lateral accretion                        rn_hnewice   = ', rn_hnewice 
     721         WRITE(numout,*)'      Frazil ice thickness as a function of wind or not       ln_frazil    = ', ln_frazil 
     722         WRITE(numout,*)'      Maximum proportion of frazil ice collecting at bottom   rn_maxfrazb  = ', rn_maxfrazb 
     723         WRITE(numout,*)'      Thresold relative drift speed for collection of frazil  rn_vfrazb    = ', rn_vfrazb 
     724         WRITE(numout,*)'      Squeezing coefficient for collection of frazil          rn_Cfrazb    = ', rn_Cfrazb 
     725         WRITE(numout,*)'      minimum ice thickness                                   rn_himin     = ', rn_himin  
    597726         WRITE(numout,*)'      numerical carac. of the scheme for diffusion in ice ' 
    598          WRITE(numout,*)'      thickness of the surf. layer in temp. computation       hnzst        = ', hnzst 
    599          WRITE(numout,*)'      switch for snow sublimation  (=1) or not (=0)           parsub       = ', parsub   
    600          WRITE(numout,*)'      coefficient for ice-lead partition of snowfall          betas        = ', betas 
    601          WRITE(numout,*)'      extinction radiation parameter in sea ice (1.0)         kappa_i      = ', kappa_i 
    602          WRITE(numout,*)'      maximal n. of iter. for heat diffusion computation      nconv_i_thd  = ', nconv_i_thd 
    603          WRITE(numout,*)'      maximal err. on T for heat diffusion computation        maxer_i_thd  = ', maxer_i_thd 
    604          WRITE(numout,*)'      switch for comp. of thermal conductivity in the ice     thcon_i_swi  = ', thcon_i_swi 
     727         WRITE(numout,*)'      coefficient for ice-lead partition of snowfall          rn_betas     = ', rn_betas 
     728         WRITE(numout,*)'      extinction radiation parameter in sea ice               rn_kappa_i   = ', rn_kappa_i 
     729         WRITE(numout,*)'      maximal n. of iter. for heat diffusion computation      nn_conv_dif  = ', nn_conv_dif 
     730         WRITE(numout,*)'      maximal err. on T for heat diffusion computation        rn_terr_dif  = ', rn_terr_dif 
     731         WRITE(numout,*)'      switch for comp. of thermal conductivity in the ice     nn_ice_thcon = ', nn_ice_thcon 
    605732         WRITE(numout,*)'      check heat conservation in the ice/snow                 con_i        = ', con_i 
     733         WRITE(numout,*)'      virtual ITD mono-category parameterizations (1) or not  nn_monocat   = ', nn_monocat 
     734         WRITE(numout,*)'      iterate the surface non-solar flux (T) or not (F)       ln_it_qnsice = ', ln_it_qnsice 
    606735      ENDIF 
    607736      ! 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/LIM_SRC_3/limthd_dh.F90

    r5312 r5313  
    2020   USE sbc_oce        ! Surface boundary condition: ocean fields 
    2121   USE ice            ! LIM variables 
    22    USE par_ice        ! LIM parameters 
    2322   USE thd_ice        ! LIM thermodynamics 
    2423   USE in_out_manager ! I/O manager 
    … …  
    7069 
    7170      REAL(wp) ::   ztmelts             ! local scalar 
    72       REAL(wp) ::   zdh, zfdum  ! 
     71      REAL(wp) ::   zfdum        
    7372      REAL(wp) ::   zfracs       ! fractionation coefficient for bottom salt entrapment 
    7473      REAL(wp) ::   zcoeff       ! dummy argument for snowfall partitioning over ice and leads 
    … …  
    8786      REAL(wp) ::   zsstK        ! SST in Kelvin 
    8887 
    89       REAL(wp), POINTER, DIMENSION(:) ::   zh_s        ! snow layer thickness 
    9088      REAL(wp), POINTER, DIMENSION(:) ::   zqprec      ! energy of fallen snow                       (J.m-3) 
    9189      REAL(wp), POINTER, DIMENSION(:) ::   zq_su       ! heat for surface ablation                   (J.m-2) 
    9290      REAL(wp), POINTER, DIMENSION(:) ::   zq_bo       ! heat for bottom ablation                    (J.m-2) 
    93       REAL(wp), POINTER, DIMENSION(:) ::   zq_1cat     ! corrected heat in case 1-cat and hmelt>15cm (J.m-2) 
    9491      REAL(wp), POINTER, DIMENSION(:) ::   zq_rema     ! remaining heat at the end of the routine    (J.m-2) 
    95       REAL(wp), POINTER, DIMENSION(:) ::   zf_tt     ! Heat budget to determine melting or freezing(W.m-2) 
    96       INTEGER , POINTER, DIMENSION(:) ::   icount      ! number of layers vanished by melting  
     92      REAL(wp), POINTER, DIMENSION(:) ::   zf_tt       ! Heat budget to determine melting or freezing(W.m-2) 
    9793 
    9894      REAL(wp), POINTER, DIMENSION(:) ::   zdh_s_mel   ! snow melt  
    … …  
    10298      REAL(wp), POINTER, DIMENSION(:,:) ::   zdeltah 
    10399      REAL(wp), POINTER, DIMENSION(:,:) ::   zh_i      ! ice layer thickness 
     100      INTEGER , POINTER, DIMENSION(:,:) ::   icount    ! number of layers vanished by melting  
    104101 
    105102      REAL(wp), POINTER, DIMENSION(:) ::   zqh_i       ! total ice heat content  (J.m-2) 
    … …  
    107104      REAL(wp), POINTER, DIMENSION(:) ::   zq_s        ! total snow enthalpy     (J.m-3) 
    108105 
    109       ! mass and salt flux (clem) 
    110       REAL(wp) :: zdvres, zswitch_sal 
     106      REAL(wp) :: zswitch_sal 
    111107 
    112108      ! Heat conservation  
    … …  
    115111      !!------------------------------------------------------------------ 
    116112 
    117       ! Discriminate between varying salinity (num_sal=2) and prescribed cases (other values) 
    118       SELECT CASE( num_sal )                       ! varying salinity or not 
     113      ! Discriminate between varying salinity (nn_icesal=2) and prescribed cases (other values) 
     114      SELECT CASE( nn_icesal )                       ! varying salinity or not 
    119115         CASE( 1, 3, 4 ) ;   zswitch_sal = 0       ! prescribed salinity profile 
    120116         CASE( 2 )       ;   zswitch_sal = 1       ! varying salinity profile 
    121117      END SELECT 
    122118 
    123       CALL wrk_alloc( jpij, zh_s, zqprec, zq_su, zq_bo, zf_tt, zq_1cat, zq_rema ) 
     119      CALL wrk_alloc( jpij, zqprec, zq_su, zq_bo, zf_tt, zq_rema ) 
    124120      CALL wrk_alloc( jpij, zdh_s_mel, zdh_s_pre, zdh_s_sub, zqh_i, zqh_s, zq_s ) 
    125       CALL wrk_alloc( jpij, nlay_i+1, zdeltah, zh_i ) 
    126       CALL wrk_alloc( jpij, icount ) 
     121      CALL wrk_alloc( jpij, nlay_i, zdeltah, zh_i ) 
     122      CALL wrk_alloc( jpij, nlay_i, icount ) 
    127123       
    128124      dh_i_surf  (:) = 0._wp ; dh_i_bott  (:) = 0._wp ; dh_snowice(:) = 0._wp 
    … …  
    130126  
    131127      zqprec (:) = 0._wp ; zq_su  (:) = 0._wp ; zq_bo  (:) = 0._wp ; zf_tt  (:) = 0._wp 
    132       zq_1cat(:) = 0._wp ; zq_rema(:) = 0._wp 
    133  
    134       zh_s     (:) = 0._wp        
     128      zq_rema(:) = 0._wp 
     129 
    135130      zdh_s_pre(:) = 0._wp 
    136131      zdh_s_mel(:) = 0._wp 
    … …  
    141136      zh_i      (:,:) = 0._wp        
    142137      zdeltah   (:,:) = 0._wp        
    143       icount    (:)   = 0 
     138      icount    (:,:) = 0 
     139 
     140      ! Initialize enthalpy at nlay_i+1 
     141      DO ji = kideb, kiut 
     142         q_i_1d(ji,nlay_i+1) = 0._wp 
     143      END DO 
    144144 
    145145      ! initialize layer thicknesses and enthalpies 
    … …  
    148148      DO jk = 1, nlay_i 
    149149         DO ji = kideb, kiut 
    150             h_i_old (ji,jk) = ht_i_1d(ji) / REAL( nlay_i ) 
     150            h_i_old (ji,jk) = ht_i_1d(ji) * r1_nlay_i 
    151151            qh_i_old(ji,jk) = q_i_1d(ji,jk) * h_i_old(ji,jk) 
    152152         ENDDO 
    … …  
    158158      ! 
    159159      DO ji = kideb, kiut 
    160          rswitch       = 1._wp - MAX(  0._wp , SIGN( 1._wp , - ht_s_1d(ji) ) ) 
    161          ztmelts       = rswitch * rtt + ( 1._wp - rswitch ) * rtt 
    162  
    163160         zfdum      = qns_ice_1d(ji) + ( 1._wp - i0(ji) ) * qsr_ice_1d(ji) - fc_su(ji)  
    164161         zf_tt(ji)  = fc_bo_i(ji) + fhtur_1d(ji) + fhld_1d(ji)  
    165162 
    166          zq_su (ji) = MAX( 0._wp, zfdum     * rdt_ice ) * MAX( 0._wp , SIGN( 1._wp, t_su_1d(ji) - ztmelts ) ) 
     163         zq_su (ji) = MAX( 0._wp, zfdum     * rdt_ice ) * MAX( 0._wp , SIGN( 1._wp, t_su_1d(ji) - rt0 ) ) 
    167164         zq_bo (ji) = MAX( 0._wp, zf_tt(ji) * rdt_ice ) 
    168165      END DO 
    … …  
    174171      !------------------------------------------------------------------------------! 
    175172      DO ji = kideb, kiut 
    176          IF( t_s_1d(ji,1) > rtt ) THEN !!! Internal melting 
     173         IF( t_s_1d(ji,1) > rt0 ) THEN !!! Internal melting 
    177174            ! Contribution to heat flux to the ocean [W.m-2], < 0   
    178175            hfx_res_1d(ji) = hfx_res_1d(ji) + q_s_1d(ji,1) * ht_s_1d(ji) * a_i_1d(ji) * r1_rdtice 
    … …  
    182179            ht_s_1d(ji)   = 0._wp 
    183180            q_s_1d (ji,1) = 0._wp 
    184             t_s_1d (ji,1) = rtt 
     181            t_s_1d (ji,1) = rt0 
    185182         END IF 
    186183      END DO 
    … …  
    190187      !------------------------------------------------------------! 
    191188      ! 
    192       DO ji = kideb, kiut      
    193          zh_s(ji) = ht_s_1d(ji) / REAL( nlay_s ) 
    194       END DO 
    195       ! 
    196189      DO jk = 1, nlay_s 
    197190         DO ji = kideb, kiut 
    198             zqh_s(ji) =  zqh_s(ji) + q_s_1d(ji,jk) * zh_s(ji) 
     191            zqh_s(ji) =  zqh_s(ji) + q_s_1d(ji,jk) * ht_s_1d(ji) * r1_nlay_s 
    199192         END DO 
    200193      END DO 
    … …  
    202195      DO jk = 1, nlay_i 
    203196         DO ji = kideb, kiut 
    204             zh_i(ji,jk) = ht_i_1d(ji) / REAL( nlay_i ) 
     197            zh_i(ji,jk) = ht_i_1d(ji) * r1_nlay_i 
    205198            zqh_i(ji)   = zqh_i(ji) + q_i_1d(ji,jk) * zh_i(ji,jk) 
    206199         END DO 
    … …  
    225218      ! Martin Vancoppenolle, December 2006 
    226219 
     220      zdeltah(:,:) = 0._wp 
    227221      DO ji = kideb, kiut 
    228222         !----------- 
    … …  
    230224         !----------- 
    231225         ! thickness change 
    232          zcoeff = ( 1._wp - ( 1._wp - at_i_1d(ji) )**betas ) / at_i_1d(ji)  
    233          zdh_s_pre(ji) = zcoeff * sprecip_1d(ji) * rdt_ice / rhosn 
     226         zcoeff = ( 1._wp - ( 1._wp - at_i_1d(ji) )**rn_betas ) / at_i_1d(ji)  
     227         zdh_s_pre(ji) = zcoeff * sprecip_1d(ji) * rdt_ice * r1_rhosn 
    234228         ! enthalpy of the precip (>0, J.m-3) (tatm_ice is now in K) 
    235          zqprec   (ji) = rhosn * ( cpic * ( rtt - MIN( tatm_ice_1d(ji), rt0_snow) ) + lfus )    
     229         zqprec   (ji) = rhosn * ( cpic * ( rt0 - MIN( tatm_ice_1d(ji), rt0_snow) ) + lfus )    
    236230         IF( sprecip_1d(ji) == 0._wp ) zqprec(ji) = 0._wp 
    237231         ! heat flux from snow precip (>0, W.m-2) 
    … …  
    239233         ! mass flux, <0 
    240234         wfx_spr_1d(ji) = wfx_spr_1d(ji) - rhosn * a_i_1d(ji) * zdh_s_pre(ji) * r1_rdtice 
    241          ! update thickness 
    242          ht_s_1d    (ji) = MAX( 0._wp , ht_s_1d(ji) + zdh_s_pre(ji) ) 
    243235 
    244236         !--------------------- 
    … …  
    246238         !--------------------- 
    247239         ! thickness change 
    248          IF( zdh_s_pre(ji) > 0._wp ) THEN 
    249          rswitch        = 1._wp - MAX( 0._wp , SIGN( 1._wp , - zqprec(ji) + epsi20 ) ) 
    250          zdh_s_mel (ji) = - rswitch * zq_su(ji) / MAX( zqprec(ji) , epsi20 ) 
    251          zdh_s_mel (ji) = MAX( - zdh_s_pre(ji), zdh_s_mel(ji) ) ! bound melting  
     240         rswitch        = MAX( 0._wp , SIGN( 1._wp , zqprec(ji) - epsi20 ) ) 
     241         zdeltah (ji,1) = - rswitch * zq_su(ji) / MAX( zqprec(ji) , epsi20 ) 
     242         zdeltah (ji,1) = MAX( - zdh_s_pre(ji), zdeltah(ji,1) ) ! bound melting  
    252243         ! heat used to melt snow (W.m-2, >0) 
    253          hfx_snw_1d(ji) = hfx_snw_1d(ji) - zdh_s_mel(ji) * a_i_1d(ji) * zqprec(ji) * r1_rdtice 
     244         hfx_snw_1d(ji) = hfx_snw_1d(ji) - zdeltah(ji,1) * a_i_1d(ji) * zqprec(ji) * r1_rdtice 
    254245         ! snow melting only = water into the ocean (then without snow precip), >0 
    255          wfx_snw_1d(ji) = wfx_snw_1d(ji) - rhosn * a_i_1d(ji) * zdh_s_mel(ji) * r1_rdtice 
    256           
    257          ! updates available heat + thickness 
    258          zq_su (ji) = MAX( 0._wp , zq_su (ji) + zdh_s_mel(ji) * zqprec(ji) )       
    259          ht_s_1d(ji) = MAX( 0._wp , ht_s_1d(ji) + zdh_s_mel(ji) ) 
    260          zh_s  (ji) = ht_s_1d(ji) / REAL( nlay_s ) 
    261  
    262          ENDIF 
    263       END DO 
    264  
    265       ! If heat still available, then melt more snow 
    266       zdeltah(:,:) = 0._wp ! important 
     246         wfx_snw_1d(ji) = wfx_snw_1d(ji) - rhosn * a_i_1d(ji) * zdeltah(ji,1) * r1_rdtice     
     247         ! updates available heat + precipitations after melting 
     248         zq_su     (ji) = MAX( 0._wp , zq_su (ji) + zdeltah(ji,1) * zqprec(ji) )       
     249         zdh_s_pre (ji) = zdh_s_pre(ji) + zdeltah(ji,1) 
     250 
     251         ! update thickness 
     252         ht_s_1d(ji) = MAX( 0._wp , ht_s_1d(ji) + zdh_s_pre(ji) ) 
     253      END DO 
     254 
     255      ! If heat still available (zq_su > 0), then melt more snow 
     256      zdeltah(:,:) = 0._wp 
    267257      DO jk = 1, nlay_s 
    268258         DO ji = kideb, kiut 
    269259            ! thickness change 
    270260            rswitch          = 1._wp - MAX( 0._wp, SIGN( 1._wp, - ht_s_1d(ji) ) )  
    271             rswitch          = rswitch * ( 1._wp - MAX( 0._wp, SIGN( 1._wp, - q_s_1d(ji,jk) + epsi20 ) ) )  
     261            rswitch          = rswitch * ( MAX( 0._wp, SIGN( 1._wp, q_s_1d(ji,jk) - epsi20 ) ) )  
    272262            zdeltah  (ji,jk) = - rswitch * zq_su(ji) / MAX( q_s_1d(ji,jk), epsi20 ) 
    273             zdeltah  (ji,jk) = MAX( zdeltah(ji,jk) , - zh_s(ji) ) ! bound melting 
     263            zdeltah  (ji,jk) = MAX( zdeltah(ji,jk) , - ht_s_1d(ji) ) ! bound melting 
    274264            zdh_s_mel(ji)    = zdh_s_mel(ji) + zdeltah(ji,jk)     
    275265            ! heat used to melt snow(W.m-2, >0) 
    … …  
    277267            ! snow melting only = water into the ocean (then without snow precip) 
    278268            wfx_snw_1d(ji)   = wfx_snw_1d(ji) - rhosn * a_i_1d(ji) * zdeltah(ji,jk) * r1_rdtice 
    279  
    280269            ! updates available heat + thickness 
    281             zq_su (ji) = MAX( 0._wp , zq_su (ji) + zdeltah(ji,jk) * q_s_1d(ji,jk) ) 
     270            zq_su (ji)  = MAX( 0._wp , zq_su (ji) + zdeltah(ji,jk) * q_s_1d(ji,jk) ) 
    282271            ht_s_1d(ji) = MAX( 0._wp , ht_s_1d(ji) + zdeltah(ji,jk) ) 
    283  
    284272         END DO 
    285273      END DO 
    … …  
    289277      !---------------------- 
    290278      ! qla_ice is always >=0 (upwards), heat goes to the atmosphere, therefore snow sublimates 
    291       ! clem comment: not counted in mass exchange in limsbc since this is an exchange with atm. (not ocean) 
     279      ! clem comment: not counted in mass/heat exchange in limsbc since this is an exchange with atm. (not ocean) 
    292280      ! clem comment: ice should also sublimate 
     281      zdeltah(:,:) = 0._wp 
    293282      IF( lk_cpl ) THEN 
    294283         ! coupled mode: sublimation already included in emp_ice (to do in limsbc_ice) 
    … …  
    297286         ! forced  mode: snow thickness change due to sublimation 
    298287         DO ji = kideb, kiut 
    299             zdh_s_sub(ji)  =  MAX( - ht_s_1d(ji) , - parsub * qla_ice_1d(ji) / ( rhosn * lsub ) * rdt_ice ) 
     288            zdh_s_sub(ji)  =  MAX( - ht_s_1d(ji) , - qla_ice_1d(ji) / ( rhosn * lsub ) * rdt_ice ) 
    300289            ! Heat flux by sublimation [W.m-2], < 0 
    301290            !      sublimate first snow that had fallen, then pre-existing snow 
    302             zcoeff         =      ( MAX( zdh_s_sub(ji), - MAX( 0._wp, zdh_s_pre(ji) + zdh_s_mel(ji) ) )   * zqprec(ji) +   & 
    303                &  ( zdh_s_sub(ji) - MAX( zdh_s_sub(ji), - MAX( 0._wp, zdh_s_pre(ji) + zdh_s_mel(ji) ) ) ) * q_s_1d(ji,1) )  & 
    304                &  * a_i_1d(ji) * r1_rdtice 
    305             hfx_sub_1d(ji) = hfx_sub_1d(ji) + zcoeff 
     291            zdeltah(ji,1)  = MAX( zdh_s_sub(ji), - zdh_s_pre(ji) ) 
     292            hfx_sub_1d(ji) = hfx_sub_1d(ji) + ( zdeltah(ji,1) * zqprec(ji) + ( zdh_s_sub(ji) - zdeltah(ji,1) ) * q_s_1d(ji,1)  & 
     293               &                              ) * a_i_1d(ji) * r1_rdtice 
    306294            ! Mass flux by sublimation 
    307295            wfx_sub_1d(ji) =  wfx_sub_1d(ji) - rhosn * a_i_1d(ji) * zdh_s_sub(ji) * r1_rdtice 
    308296            ! new snow thickness 
    309             ht_s_1d(ji)     =  MAX( 0._wp , ht_s_1d(ji) + zdh_s_sub(ji) ) 
     297            ht_s_1d(ji)    =  MAX( 0._wp , ht_s_1d(ji) + zdh_s_sub(ji) ) 
     298            ! update precipitations after sublimation and correct sublimation 
     299            zdh_s_pre(ji) = zdh_s_pre(ji) + zdeltah(ji,1) 
     300            zdh_s_sub(ji) = zdh_s_sub(ji) - zdeltah(ji,1) 
    310301         END DO 
    311302      ENDIF 
    … …  
    313304      ! --- Update snow diags --- ! 
    314305      DO ji = kideb, kiut 
    315          dh_s_tot(ji)   = zdh_s_mel(ji) + zdh_s_pre(ji) + zdh_s_sub(ji) 
    316          zh_s(ji)       = ht_s_1d(ji) / REAL( nlay_s ) 
    317       END DO ! ji 
     306         dh_s_tot(ji) = zdh_s_mel(ji) + zdh_s_pre(ji) + zdh_s_sub(ji) 
     307      END DO 
    318308 
    319309      !------------------------------------------- 
    … …  
    324314      DO jk = 1, nlay_s 
    325315         DO ji = kideb,kiut 
    326             rswitch       =  MAX(  0._wp , SIGN( 1._wp, - ht_s_1d(ji) + epsi20 )  ) 
    327             q_s_1d(ji,jk) = ( 1._wp - rswitch ) / MAX( ht_s_1d(ji), epsi20 ) *             & 
    328               &            ( (   MAX( 0._wp, dh_s_tot(ji) )              ) * zqprec(ji) +  & 
    329               &              ( - MAX( 0._wp, dh_s_tot(ji) ) + ht_s_1d(ji) ) * rhosn * ( cpic * ( rtt - t_s_1d(ji,jk) ) + lfus ) ) 
     316            rswitch       = MAX(  0._wp , SIGN( 1._wp, ht_s_1d(ji) - epsi20 )  ) 
     317            q_s_1d(ji,jk) = rswitch / MAX( ht_s_1d(ji), epsi20 ) *                          & 
     318              &            ( (   zdh_s_pre(ji)             ) * zqprec(ji) +  & 
     319              &              (   ht_s_1d(ji) - zdh_s_pre(ji) ) * rhosn * ( cpic * ( rt0 - t_s_1d(ji,jk) ) + lfus ) ) 
    330320            zq_s(ji)     =  zq_s(ji) + q_s_1d(ji,jk) 
    331321         END DO 
    … …  
    337327      zdeltah(:,:) = 0._wp ! important 
    338328      DO jk = 1, nlay_i 
    339          DO ji = kideb, kiut  
    340             zEi            = - q_i_1d(ji,jk) / rhoic                ! Specific enthalpy of layer k [J/kg, <0] 
    341  
    342             ztmelts        = - tmut * s_i_1d(ji,jk) + rtt           ! Melting point of layer k [K] 
    343  
    344             zEw            =    rcp * ( ztmelts - rt0 )            ! Specific enthalpy of resulting meltwater [J/kg, <0] 
    345  
    346             zdE            =    zEi - zEw                          ! Specific enthalpy difference < 0 
    347  
    348             zfmdt          = - zq_su(ji) / zdE                     ! Mass flux to the ocean [kg/m2, >0] 
    349  
    350             zdeltah(ji,jk) = - zfmdt / rhoic                       ! Melt of layer jk [m, <0] 
    351  
    352             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] 
    353  
    354             zq_su(ji)      = MAX( 0._wp , zq_su(ji) - zdeltah(ji,jk) * rhoic * zdE ) ! update available heat 
    355  
    356             dh_i_surf(ji)  = dh_i_surf(ji) + zdeltah(ji,jk)        ! Cumulate surface melt 
    357  
    358             zfmdt          = - rhoic * zdeltah(ji,jk)              ! Recompute mass flux [kg/m2, >0] 
    359  
    360             zQm            = zfmdt * zEw                           ! Energy of the melt water sent to the ocean [J/m2, <0] 
    361  
    362             ! Contribution to salt flux (clem: using sm_i_1d and not s_i_1d(jk) is ok) 
    363             sfx_sum_1d(ji)   = sfx_sum_1d(ji) - sm_i_1d(ji) * a_i_1d(ji) * zdeltah(ji,jk) * rhoic * r1_rdtice 
    364  
    365             ! Contribution to heat flux [W.m-2], < 0 
    366             hfx_thd_1d(ji) = hfx_thd_1d(ji) + zfmdt * a_i_1d(ji) * zEw * r1_rdtice 
    367  
    368             ! Total heat flux used in this process [W.m-2], > 0   
    369             hfx_sum_1d(ji) = hfx_sum_1d(ji) - zfmdt * a_i_1d(ji) * zdE * r1_rdtice 
    370  
    371             ! Contribution to mass flux 
    372             wfx_sum_1d(ji) =  wfx_sum_1d(ji) - rhoic * a_i_1d(ji) * zdeltah(ji,jk) * r1_rdtice 
    373             
     329         DO ji = kideb, kiut 
     330            ztmelts           = - tmut * s_i_1d(ji,jk) + rt0          ! Melting point of layer k [K] 
     331             
     332            IF( t_i_1d(ji,jk) >= ztmelts ) THEN !!! Internal melting 
     333 
     334               zEi            = - q_i_1d(ji,jk) * r1_rhoic            ! Specific enthalpy of layer k [J/kg, <0]        
     335               zdE            = 0._wp                                 ! Specific enthalpy difference   (J/kg, <0) 
     336                                                                      ! set up at 0 since no energy is needed to melt water...(it is already melted) 
     337               zdeltah(ji,jk) = MIN( 0._wp , - zh_i(ji,jk) )          ! internal melting occurs when the internal temperature is above freezing      
     338                                                                      ! this should normally not happen, but sometimes, heat diffusion leads to this 
     339               zfmdt          = - zdeltah(ji,jk) * rhoic              ! Mass flux x time step > 0 
     340                          
     341               dh_i_surf(ji)  = dh_i_surf(ji) + zdeltah(ji,jk)        ! Cumulate surface melt 
     342                
     343               zfmdt          = - rhoic * zdeltah(ji,jk)              ! Recompute mass flux [kg/m2, >0] 
     344 
     345               ! Contribution to heat flux to the ocean [W.m-2], <0 (ice enthalpy zEi is "sent" to the ocean)  
     346               hfx_res_1d(ji) = hfx_res_1d(ji) + zfmdt * a_i_1d(ji) * zEi * r1_rdtice 
     347                
     348               ! Contribution to salt flux (clem: using sm_i_1d and not s_i_1d(jk) is ok) 
     349               sfx_res_1d(ji) = sfx_res_1d(ji) - rhoic * a_i_1d(ji) * zdeltah(ji,jk) * sm_i_1d(ji) * r1_rdtice 
     350                
     351               ! Contribution to mass flux 
     352               wfx_res_1d(ji) =  wfx_res_1d(ji) - rhoic * a_i_1d(ji) * zdeltah(ji,jk) * r1_rdtice 
     353 
     354            ELSE                                !!! Surface melting 
     355                
     356               zEi            = - q_i_1d(ji,jk) * r1_rhoic            ! Specific enthalpy of layer k [J/kg, <0] 
     357               zEw            =    rcp * ( ztmelts - rt0 )            ! Specific enthalpy of resulting meltwater [J/kg, <0] 
     358               zdE            =    zEi - zEw                          ! Specific enthalpy difference < 0 
     359                
     360               zfmdt          = - zq_su(ji) / zdE                     ! Mass flux to the ocean [kg/m2, >0] 
     361                
     362               zdeltah(ji,jk) = - zfmdt * r1_rhoic                    ! Melt of layer jk [m, <0] 
     363                
     364               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] 
     365                
     366               zq_su(ji)      = MAX( 0._wp , zq_su(ji) - zdeltah(ji,jk) * rhoic * zdE ) ! update available heat 
     367                
     368               dh_i_surf(ji)  = dh_i_surf(ji) + zdeltah(ji,jk)        ! Cumulate surface melt 
     369                
     370               zfmdt          = - rhoic * zdeltah(ji,jk)              ! Recompute mass flux [kg/m2, >0] 
     371                
     372               zQm            = zfmdt * zEw                           ! Energy of the melt water sent to the ocean [J/m2, <0] 
     373                
     374               ! Contribution to salt flux (clem: using sm_i_1d and not s_i_1d(jk) is ok) 
     375               sfx_sum_1d(ji) = sfx_sum_1d(ji) - rhoic * a_i_1d(ji) * zdeltah(ji,jk) * sm_i_1d(ji) * r1_rdtice 
     376                
     377               ! Contribution to heat flux [W.m-2], < 0 
     378               hfx_thd_1d(ji) = hfx_thd_1d(ji) + zfmdt * a_i_1d(ji) * zEw * r1_rdtice 
     379                
     380               ! Total heat flux used in this process [W.m-2], > 0   
     381               hfx_sum_1d(ji) = hfx_sum_1d(ji) - zfmdt * a_i_1d(ji) * zdE * r1_rdtice 
     382                
     383               ! Contribution to mass flux 
     384               wfx_sum_1d(ji) =  wfx_sum_1d(ji) - rhoic * a_i_1d(ji) * zdeltah(ji,jk) * r1_rdtice 
     385                
     386            END IF 
    374387            ! record which layers have disappeared (for bottom melting)  
    375388            !    => icount=0 : no layer has vanished 
    376389            !    => icount=5 : 5 layers have vanished 
    377             rswitch     = MAX( 0._wp , SIGN( 1._wp , - ( zh_i(ji,jk) + zdeltah(ji,jk) ) ) )  
    378             icount(ji)  = icount(ji) + NINT( rswitch ) 
    379             zh_i(ji,jk) = MAX( 0._wp , zh_i(ji,jk) + zdeltah(ji,jk) ) 
     390            rswitch       = MAX( 0._wp , SIGN( 1._wp , - ( zh_i(ji,jk) + zdeltah(ji,jk) ) ) )  
     391            icount(ji,jk) = NINT( rswitch ) 
     392            zh_i(ji,jk)   = MAX( 0._wp , zh_i(ji,jk) + zdeltah(ji,jk) ) 
    380393 
    381394            ! update heat content (J.m-2) and layer thickness 
    … …  
    408421      ! -> need for an iterative procedure, which converges quickly 
    409422 
    410       IF ( num_sal == 2 ) THEN 
    411          num_iter_max = 5 
    412       ELSE 
    413          num_iter_max = 1 
    414       ENDIF 
    415  
    416       !clem debug. Just to be sure that enthalpy at nlay_i+1 is null 
    417       DO ji = kideb, kiut 
    418          q_i_1d(ji,nlay_i+1) = 0._wp 
    419       END DO 
     423      num_iter_max = 1 
     424      IF( nn_icesal == 2 ) num_iter_max = 5 
    420425 
    421426      ! Iterative procedure 
    … …  
    440445                                  + ( 1. - zswitch_sal ) * sm_i_1d(ji)  
    441446               ! New ice growth 
    442                ztmelts            = - tmut * s_i_new(ji) + rtt          ! New ice melting point (K) 
     447               ztmelts            = - tmut * s_i_new(ji) + rt0          ! New ice melting point (K) 
    443448 
    444449               zt_i_new           = zswitch_sal * t_bo_1d(ji) + ( 1. - zswitch_sal) * t_i_1d(ji, nlay_i) 
    445450                
    446451               zEi                = cpic * ( zt_i_new - ztmelts ) &     ! Specific enthalpy of forming ice (J/kg, <0)       
    447                   &               - lfus * ( 1.0 - ( ztmelts - rtt ) / ( zt_i_new - rtt ) )   & 
    448                   &               + rcp  * ( ztmelts-rtt )           
     452                  &               - lfus * ( 1.0 - ( ztmelts - rt0 ) / ( zt_i_new - rt0 ) )   & 
     453                  &               + rcp  * ( ztmelts-rt0 )           
    449454 
    450455               zEw                = rcp  * ( t_bo_1d(ji) - rt0 )         ! Specific enthalpy of seawater (J/kg, < 0) 
    … …  
    456461               q_i_1d(ji,nlay_i+1) = -zEi * rhoic                        ! New ice energy of melting (J/m3, >0) 
    457462                
    458             ENDIF ! fc_bo_i 
    459          END DO ! ji 
    460       END DO ! iter 
     463            ENDIF 
     464         END DO 
     465      END DO 
    461466 
    462467      ! Contribution to Energy and Salt Fluxes 
    … …  
    467472            zfmdt          = - rhoic * dh_i_bott(ji)             ! Mass flux x time step (kg/m2, < 0) 
    468473 
    469             ztmelts        = - tmut * s_i_new(ji) + rtt          ! New ice melting point (K) 
     474            ztmelts        = - tmut * s_i_new(ji) + rt0          ! New ice melting point (K) 
    470475             
    471476            zt_i_new       = zswitch_sal * t_bo_1d(ji) + ( 1. - zswitch_sal) * t_i_1d(ji, nlay_i) 
    472477             
    473478            zEi            = cpic * ( zt_i_new - ztmelts ) &     ! Specific enthalpy of forming ice (J/kg, <0)       
    474                &               - lfus * ( 1.0 - ( ztmelts - rtt ) / ( zt_i_new - rtt ) )   & 
    475                &               + rcp  * ( ztmelts-rtt )           
     479               &               - lfus * ( 1.0 - ( ztmelts - rt0 ) / ( zt_i_new - rt0 ) )   & 
     480               &               + rcp  * ( ztmelts-rt0 )           
    476481             
    477482            zEw            = rcp  * ( t_bo_1d(ji) - rt0 )         ! Specific enthalpy of seawater (J/kg, < 0) 
    … …  
    486491             
    487492            ! Contribution to salt flux, <0 
    488             sfx_bog_1d(ji) = sfx_bog_1d(ji) + s_i_new(ji) * a_i_1d(ji) * zfmdt * r1_rdtice 
     493            sfx_bog_1d(ji) = sfx_bog_1d(ji) - rhoic * a_i_1d(ji) * dh_i_bott(ji) * s_i_new(ji) * r1_rdtice 
    489494 
    490495            ! Contribution to mass flux, <0 
    … …  
    503508      DO jk = nlay_i, 1, -1 
    504509         DO ji = kideb, kiut 
    505             IF(  zf_tt(ji)  >=  0._wp  .AND. jk > icount(ji) ) THEN   ! do not calculate where layer has already disappeared from surface melting  
    506  
    507                ztmelts = - tmut * s_i_1d(ji,jk) + rtt  ! Melting point of layer jk (K) 
     510            IF(  zf_tt(ji)  >  0._wp  .AND. jk > icount(ji,jk) ) THEN   ! do not calculate where layer has already disappeared by surface melting  
     511 
     512               ztmelts = - tmut * s_i_1d(ji,jk) + rt0  ! Melting point of layer jk (K) 
    508513 
    509514               IF( t_i_1d(ji,jk) >= ztmelts ) THEN !!! Internal melting 
    510515 
    511                   zEi               = - q_i_1d(ji,jk) / rhoic        ! Specific enthalpy of melting ice (J/kg, <0) 
    512  
    513                   !!zEw               = rcp * ( t_i_1d(ji,jk) - rtt )  ! Specific enthalpy of meltwater at T = t_i_1d (J/kg, <0) 
    514  
     516                  zEi               = - q_i_1d(ji,jk) * r1_rhoic    ! Specific enthalpy of melting ice (J/kg, <0) 
    515517                  zdE               = 0._wp                         ! Specific enthalpy difference   (J/kg, <0) 
    516518                                                                    ! set up at 0 since no energy is needed to melt water...(it is already melted) 
    517  
    518                   zdeltah   (ji,jk) = MIN( 0._wp , - zh_i(ji,jk) ) ! internal melting occurs when the internal temperature is above freezing      
    519                                                                    ! this should normally not happen, but sometimes, heat diffusion leads to this 
     519                  zdeltah   (ji,jk) = MIN( 0._wp , - zh_i(ji,jk) )  ! internal melting occurs when the internal temperature is above freezing      
     520                                                                    ! this should normally not happen, but sometimes, heat diffusion leads to this 
    520521 
    521522                  dh_i_bott (ji)    = dh_i_bott(ji) + zdeltah(ji,jk) 
    522523 
    523                   zfmdt             = - zdeltah(ji,jk) * rhoic          ! Mass flux x time step > 0 
     524                  zfmdt             = - zdeltah(ji,jk) * rhoic      ! Mass flux x time step > 0 
    524525 
    525526                  ! Contribution to heat flux to the ocean [W.m-2], <0 (ice enthalpy zEi is "sent" to the ocean)  
    … …  
    527528 
    528529                  ! Contribution to salt flux (clem: using sm_i_1d and not s_i_1d(jk) is ok) 
    529                   sfx_res_1d(ji) = sfx_res_1d(ji) - sm_i_1d(ji) * a_i_1d(ji) * zdeltah(ji,jk) * rhoic * r1_rdtice 
     530                  sfx_res_1d(ji) = sfx_res_1d(ji) - rhoic * a_i_1d(ji) * zdeltah(ji,jk) * sm_i_1d(ji) * r1_rdtice 
    530531                                     
    531532                  ! Contribution to mass flux 
    … …  
    538539               ELSE                               !!! Basal melting 
    539540 
    540                   zEi               = - q_i_1d(ji,jk) / rhoic ! Specific enthalpy of melting ice (J/kg, <0) 
    541  
    542                   zEw               = rcp * ( ztmelts - rtt )! Specific enthalpy of meltwater (J/kg, <0) 
    543  
    544                   zdE               = zEi - zEw              ! Specific enthalpy difference   (J/kg, <0) 
    545  
    546                   zfmdt             = - zq_bo(ji) / zdE  ! Mass flux x time step (kg/m2, >0) 
    547  
    548                   zdeltah(ji,jk)    = - zfmdt / rhoic        ! Gross thickness change 
    549  
    550                   zdeltah(ji,jk)    = MIN( 0._wp , MAX( zdeltah(ji,jk), - zh_i(ji,jk) ) ) ! bound thickness change 
     541                  zEi             = - q_i_1d(ji,jk) * r1_rhoic ! Specific enthalpy of melting ice (J/kg, <0) 
     542                  zEw             = rcp * ( ztmelts - rt0 )    ! Specific enthalpy of meltwater (J/kg, <0) 
     543                  zdE             = zEi - zEw                  ! Specific enthalpy difference   (J/kg, <0) 
     544 
     545                  zfmdt           = - zq_bo(ji) / zdE          ! Mass flux x time step (kg/m2, >0) 
     546 
     547                  zdeltah(ji,jk)  = - zfmdt * r1_rhoic         ! Gross thickness change 
     548 
     549                  zdeltah(ji,jk)  = MIN( 0._wp , MAX( zdeltah(ji,jk), - zh_i(ji,jk) ) ) ! bound thickness change 
    551550                   
    552                   zq_bo(ji)         = MAX( 0._wp , zq_bo(ji) - zdeltah(ji,jk) * rhoic * zdE ) ! update available heat. MAX is necessary for roundup errors 
    553  
    554                   dh_i_bott(ji)     = dh_i_bott(ji) + zdeltah(ji,jk)    ! Update basal melt 
    555  
    556                   zfmdt             = - zdeltah(ji,jk) * rhoic          ! Mass flux x time step > 0 
    557  
    558                   zQm               = zfmdt * zEw         ! Heat exchanged with ocean 
     551                  zq_bo(ji)       = MAX( 0._wp , zq_bo(ji) - zdeltah(ji,jk) * rhoic * zdE ) ! update available heat. MAX is necessary for roundup errors 
     552 
     553                  dh_i_bott(ji)   = dh_i_bott(ji) + zdeltah(ji,jk)    ! Update basal melt 
     554 
     555                  zfmdt           = - zdeltah(ji,jk) * rhoic          ! Mass flux x time step > 0 
     556 
     557                  zQm             = zfmdt * zEw         ! Heat exchanged with ocean 
    559558 
    560559                  ! Contribution to heat flux to the ocean [W.m-2], <0   
    561                   hfx_thd_1d(ji) = hfx_thd_1d(ji) + zfmdt * a_i_1d(ji) * zEw * r1_rdtice 
     560                  hfx_thd_1d(ji)  = hfx_thd_1d(ji) + zfmdt * a_i_1d(ji) * zEw * r1_rdtice 
    562561 
    563562                  ! Contribution to salt flux (clem: using sm_i_1d and not s_i_1d(jk) is ok) 
    564                   sfx_bom_1d(ji) = sfx_bom_1d(ji) - sm_i_1d(ji) * a_i_1d(ji) * zdeltah(ji,jk) * rhoic * r1_rdtice 
     563                  sfx_bom_1d(ji)  = sfx_bom_1d(ji) - rhoic *  a_i_1d(ji) * zdeltah(ji,jk) * sm_i_1d(ji) * r1_rdtice 
    565564                   
    566565                  ! Total heat flux used in this process [W.m-2], >0   
    567                   hfx_bom_1d(ji) = hfx_bom_1d(ji) - zfmdt * a_i_1d(ji) * zdE * r1_rdtice 
     566                  hfx_bom_1d(ji)  = hfx_bom_1d(ji) - zfmdt * a_i_1d(ji) * zdE * r1_rdtice 
    568567                   
    569568                  ! Contribution to mass flux 
    570                   wfx_bom_1d(ji) =  wfx_bom_1d(ji) - rhoic * a_i_1d(ji) * zdeltah(ji,jk) * r1_rdtice 
     569                  wfx_bom_1d(ji)  =  wfx_bom_1d(ji) - rhoic * a_i_1d(ji) * zdeltah(ji,jk) * r1_rdtice 
    571570 
    572571                  ! update heat content (J.m-2) and layer thickness 
    … …  
    576575            
    577576            ENDIF 
    578          END DO ! ji 
    579       END DO ! jk 
    580  
    581       !------------------------------------------------------------------------------! 
    582       ! Excessive ablation in a 1-category model 
    583       !     in a 1-category sea ice model, bottom ablation must not exceed hmelt (-0.15) 
    584       !------------------------------------------------------------------------------! 
    585       ! ??? keep ??? 
    586       ! clem bug: I think this should be included above, so we would not have to  
    587       !           track heat/salt/mass fluxes backwards 
    588 !      IF( jpl == 1 ) THEN 
    589 !         DO ji = kideb, kiut 
    590 !            IF(  zf_tt(ji)  >=  0._wp  ) THEN 
    591 !               zdh            = MAX( hmelt , dh_i_bott(ji) ) 
    592 !               zdvres         = zdh - dh_i_bott(ji) ! >=0 
    593 !               dh_i_bott(ji)  = zdh 
    594 ! 
    595 !               ! excessive energy is sent to lateral ablation 
    596 !               rswitch = MAX( 0._wp, SIGN( 1._wp , 1._wp - at_i_1d(ji) - epsi20 ) ) 
    597 !               zq_1cat(ji) =  rswitch * rhoic * lfus * at_i_1d(ji) / MAX( 1._wp - at_i_1d(ji) , epsi20 ) * zdvres ! J.m-2 >=0 
    598 ! 
    599 !               ! correct salt and mass fluxes 
    600 !               sfx_bom_1d(ji) = sfx_bom_1d(ji) - sm_i_1d(ji) * a_i_1d(ji) * zdvres * rhoic * r1_rdtice ! this is only a raw approximation 
    601 !               wfx_bom_1d(ji) = wfx_bom_1d(ji) - rhoic * a_i_1d(ji) * zdvres * r1_rdtice 
    602 !            ENDIF 
    603 !         END DO 
    604 !      ENDIF 
     577         END DO 
     578      END DO 
    605579 
    606580      !------------------------------------------- 
    … …  
    619593      DO ji = kideb, kiut 
    620594         zq_rema(ji)     = zq_su(ji) + zq_bo(ji)  
    621 !         zindh           = 1._wp - MAX( 0._wp, SIGN( 1._wp, - ht_s_1d(ji) ) )   ! =1 if snow 
    622 !         zindq           = 1._wp - MAX( 0._wp, SIGN( 1._wp, - zq_s(ji) + epsi20 ) ) 
    623 !         zdeltah  (ji,1) = - zindh * zindq * zq_rema(ji) / MAX( zq_s(ji), epsi20 ) 
    624 !         zdeltah  (ji,1) = MIN( 0._wp , MAX( zdeltah(ji,1) , - ht_s_1d(ji) ) ) ! bound melting 
    625 !         zdh_s_mel(ji)   = zdh_s_mel(ji) + zdeltah(ji,1)     
    626 !         dh_s_tot (ji)   = dh_s_tot(ji) + zdeltah(ji,1) 
    627 !         ht_s_1d   (ji)   = ht_s_1d(ji)   + zdeltah(ji,1) 
    628 !         
    629 !         zq_rema(ji)     = zq_rema(ji) + zdeltah(ji,1) * zq_s(ji)                ! update available heat (J.m-2) 
    630 !         ! heat used to melt snow 
    631 !         hfx_snw_1d(ji)  = hfx_snw_1d(ji) - zdeltah(ji,1) * a_i_1d(ji) * zq_s(ji) * r1_rdtice ! W.m-2 (>0) 
    632 !         ! Contribution to mass flux 
    633 !         wfx_snw_1d(ji)  =  wfx_snw_1d(ji) - rhosn * a_i_1d(ji) * zdeltah(ji,1) * r1_rdtice 
    634 !     
     595         rswitch         = 1._wp - MAX( 0._wp, SIGN( 1._wp, - ht_s_1d(ji) ) )   ! =1 if snow 
     596         rswitch         = rswitch * MAX( 0._wp, SIGN( 1._wp, q_s_1d(ji,1) - epsi20 ) ) 
     597         zdeltah  (ji,1) = - rswitch * zq_rema(ji) / MAX( q_s_1d(ji,1), epsi20 ) 
     598         zdeltah  (ji,1) = MIN( 0._wp , MAX( zdeltah(ji,1) , - ht_s_1d(ji) ) ) ! bound melting 
     599         dh_s_tot (ji)   = dh_s_tot(ji)  + zdeltah(ji,1) 
     600         ht_s_1d   (ji)  = ht_s_1d(ji)   + zdeltah(ji,1) 
     601         
     602         zq_rema(ji)     = zq_rema(ji) + zdeltah(ji,1) * q_s_1d(ji,1)                ! update available heat (J.m-2) 
     603         ! heat used to melt snow 
     604         hfx_snw_1d(ji)  = hfx_snw_1d(ji) - zdeltah(ji,1) * a_i_1d(ji) * q_s_1d(ji,1) * r1_rdtice ! W.m-2 (>0) 
     605         ! Contribution to mass flux 
     606         wfx_snw_1d(ji)  =  wfx_snw_1d(ji) - rhosn * a_i_1d(ji) * zdeltah(ji,1) * r1_rdtice 
     607         !     
    635608         ii = MOD( npb(ji) - 1, jpi ) + 1 ; ij = ( npb(ji) - 1 ) / jpi + 1 
    636609         ! Remaining heat flux (W.m-2) is sent to the ocean heat budget 
    637          hfx_out(ii,ij)  = hfx_out(ii,ij) + ( zq_1cat(ji) + zq_rema(ji) * a_i_1d(ji) ) * r1_rdtice 
    638  
    639          IF( ln_nicep .AND. zq_rema(ji) < 0. .AND. lwp ) WRITE(numout,*) 'ALERTE zq_rema <0 = ', zq_rema(ji) 
     610         hfx_out(ii,ij)  = hfx_out(ii,ij) + ( zq_rema(ji) * a_i_1d(ji) ) * r1_rdtice 
     611 
     612         IF( ln_icectl .AND. zq_rema(ji) < 0. .AND. lwp ) WRITE(numout,*) 'ALERTE zq_rema <0 = ', zq_rema(ji) 
    640613      END DO 
    641614       
    … …  
    650623         dh_snowice(ji) = MAX(  0._wp , ( rhosn * ht_s_1d(ji) + (rhoic-rau0) * ht_i_1d(ji) ) / ( rhosn+rau0-rhoic )  ) 
    651624 
    652          ht_i_1d(ji)     = ht_i_1d(ji) + dh_snowice(ji) 
    653          ht_s_1d(ji)     = ht_s_1d(ji) - dh_snowice(ji) 
     625         ht_i_1d(ji)    = ht_i_1d(ji) + dh_snowice(ji) 
     626         ht_s_1d(ji)    = ht_s_1d(ji) - dh_snowice(ji) 
    654627 
    655628         ! Salinity of snow ice 
    656629         ii = MOD( npb(ji) - 1, jpi ) + 1 ; ij = ( npb(ji) - 1 ) / jpi + 1 
    657          zs_snic = zswitch_sal * sss_m(ii,ij) * ( rhoic - rhosn ) / rhoic + ( 1. - zswitch_sal ) * sm_i_1d(ji) 
     630         zs_snic = zswitch_sal * sss_m(ii,ij) * ( rhoic - rhosn ) * r1_rhoic + ( 1. - zswitch_sal ) * sm_i_1d(ji) 
    658631 
    659632         ! entrapment during snow ice formation 
    660          ! new salinity difference stored (to be used in limthd_ent.F90) 
    661          IF (  num_sal == 2  ) THEN 
    662             rswitch = MAX( 0._wp , SIGN( 1._wp , ht_i_1d(ji) - epsi10 ) ) 
     633         ! new salinity difference stored (to be used in limthd_sal.F90) 
     634         IF (  nn_icesal == 2  ) THEN 
     635            rswitch = MAX( 0._wp , SIGN( 1._wp , ht_i_1d(ji) - epsi20 ) ) 
    663636            ! salinity dif due to snow-ice formation 
    664             dsm_i_si_1d(ji) = ( zs_snic - sm_i_1d(ji) ) * dh_snowice(ji) / MAX( ht_i_1d(ji), epsi10 ) * rswitch      
     637            dsm_i_si_1d(ji) = ( zs_snic - sm_i_1d(ji) ) * dh_snowice(ji) / MAX( ht_i_1d(ji), epsi20 ) * rswitch      
    665638            ! salinity dif due to bottom growth  
    666639            IF (  zf_tt(ji)  < 0._wp ) THEN 
    667                dsm_i_se_1d(ji) = ( s_i_new(ji) - sm_i_1d(ji) ) * dh_i_bott(ji) / MAX( ht_i_1d(ji), epsi10 ) * rswitch 
     640               dsm_i_se_1d(ji) = ( s_i_new(ji) - sm_i_1d(ji) ) * dh_i_bott(ji) / MAX( ht_i_1d(ji), epsi20 ) * rswitch 
    668641            ENDIF 
    669642         ENDIF 
    … …  
    691664         h_i_old (ji,0) = h_i_old (ji,0) + dh_snowice(ji) 
    692665          
    693          ! Total ablation (to debug) 
    694          IF( ht_i_1d(ji) <= 0._wp )   a_i_1d(ji) = 0._wp 
    695  
    696       END DO !ji 
     666      END DO 
    697667 
    698668      ! 
    … …  
    700670      ! Update temperature, energy 
    701671      !------------------------------------------- 
    702       !clem bug: we should take snow into account here 
    703672      DO ji = kideb, kiut 
    704673         rswitch     =  1.0 - MAX( 0._wp , SIGN( 1._wp , - ht_i_1d(ji) ) )  
    705          t_su_1d(ji) =  rswitch * t_su_1d(ji) + ( 1.0 - rswitch ) * rtt 
    706       END DO  ! ji 
     674         t_su_1d(ji) =  rswitch * t_su_1d(ji) + ( 1.0 - rswitch ) * rt0 
     675      END DO 
    707676 
    708677      DO jk = 1, nlay_s 
    709678         DO ji = kideb,kiut 
    710679            ! mask enthalpy 
    711             rswitch       = MAX(  0._wp , SIGN( 1._wp, - ht_s_1d(ji) )  ) 
    712             q_s_1d(ji,jk) = ( 1.0 - rswitch ) * q_s_1d(ji,jk) 
     680            rswitch       = 1._wp - MAX(  0._wp , SIGN( 1._wp, - ht_s_1d(ji) )  ) 
     681            q_s_1d(ji,jk) = rswitch * q_s_1d(ji,jk) 
    713682            ! recalculate t_s_1d from q_s_1d 
    714             t_s_1d(ji,jk) = rtt + ( 1._wp - rswitch ) * ( - q_s_1d(ji,jk) / ( rhosn * cpic ) + lfus / cpic ) 
    715          END DO 
    716       END DO 
    717  
    718       CALL wrk_dealloc( jpij, zh_s, zqprec, zq_su, zq_bo, zf_tt, zq_1cat, zq_rema ) 
     683            t_s_1d(ji,jk) = rt0 + rswitch * ( - q_s_1d(ji,jk) / ( rhosn * cpic ) + lfus / cpic ) 
     684         END DO 
     685      END DO 
     686 
     687      ! --- ensure that a_i = 0 where ht_i = 0 --- 
     688      WHERE( ht_i_1d == 0._wp ) a_i_1d = 0._wp 
     689       
     690      CALL wrk_dealloc( jpij, zqprec, zq_su, zq_bo, zf_tt, zq_rema ) 
    719691      CALL wrk_dealloc( jpij, zdh_s_mel, zdh_s_pre, zdh_s_sub, zqh_i, zqh_s, zq_s ) 
    720       CALL wrk_dealloc( jpij, nlay_i+1, zdeltah, zh_i ) 
    721       CALL wrk_dealloc( jpij, icount ) 
     692      CALL wrk_dealloc( jpij, nlay_i, zdeltah, zh_i ) 
     693      CALL wrk_dealloc( jpij, nlay_i, icount ) 
    722694      ! 
    723695      ! 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/LIM_SRC_3/limthd_dif.F90

    r5312 r5313  
    1919   USE phycst         ! physical constants (ocean directory)  
    2020   USE ice            ! LIM-3 variables 
    21    USE par_ice        ! LIM-3 parameters 
    2221   USE thd_ice        ! LIM-3: thermodynamics 
    2322   USE in_out_manager ! I/O manager 
    … …  
    10099      INTEGER ::   nconv       ! number of iterations in iterative procedure 
    101100      INTEGER ::   minnumeqmin, maxnumeqmax 
     101       
    102102      INTEGER, POINTER, DIMENSION(:) ::   numeqmin   ! reference number of top equation 
    103103      INTEGER, POINTER, DIMENSION(:) ::   numeqmax   ! reference number of bottom equation 
    104       INTEGER, POINTER, DIMENSION(:) ::   isnow      ! switch for presence (1) or absence (0) of snow 
     104       
    105105      REAL(wp) ::   zg1s      =  2._wp        ! for the tridiagonal system 
    106106      REAL(wp) ::   zg1       =  2._wp        ! 
    … …  
    112112      REAL(wp) ::   ztmelt_i    ! ice melting temperature 
    113113      REAL(wp) ::   zerritmax   ! current maximal error on temperature  
    114       REAL(wp), POINTER, DIMENSION(:) ::   ztfs        ! ice melting point 
    115       REAL(wp), POINTER, DIMENSION(:) ::   ztsub       ! old surface temperature (before the iterative procedure ) 
    116       REAL(wp), POINTER, DIMENSION(:) ::   ztsubit     ! surface temperature at previous iteration 
    117       REAL(wp), POINTER, DIMENSION(:) ::   zh_i        ! ice layer thickness 
    118       REAL(wp), POINTER, DIMENSION(:) ::   zh_s        ! snow layer thickness 
    119       REAL(wp), POINTER, DIMENSION(:) ::   zfsw        ! solar radiation absorbed at the surface 
    120       REAL(wp), POINTER, DIMENSION(:) ::   zf          ! surface flux function 
    121       REAL(wp), POINTER, DIMENSION(:) ::   dzf         ! derivative of the surface flux function 
    122       REAL(wp), POINTER, DIMENSION(:) ::   zerrit      ! current error on temperature 
    123       REAL(wp), POINTER, DIMENSION(:) ::   zdifcase    ! case of the equation resolution (1->4) 
    124       REAL(wp), POINTER, DIMENSION(:) ::   zftrice     ! solar radiation transmitted through the ice 
    125       REAL(wp), POINTER, DIMENSION(:) ::   zihic, zhsu 
    126       REAL(wp), POINTER, DIMENSION(:,:) ::   ztcond_i    ! Ice thermal conductivity 
    127       REAL(wp), POINTER, DIMENSION(:,:) ::   zradtr_i    ! Radiation transmitted through the ice 
    128       REAL(wp), POINTER, DIMENSION(:,:) ::   zradab_i    ! Radiation absorbed in the ice 
    129       REAL(wp), POINTER, DIMENSION(:,:) ::   zkappa_i    ! Kappa factor in the ice 
    130       REAL(wp), POINTER, DIMENSION(:,:) ::   ztib        ! Old temperature in the ice 
    131       REAL(wp), POINTER, DIMENSION(:,:) ::   zeta_i      ! Eta factor in the ice 
    132       REAL(wp), POINTER, DIMENSION(:,:) ::   ztitemp     ! Temporary temperature in the ice to check the convergence 
    133       REAL(wp), POINTER, DIMENSION(:,:) ::   zspeche_i   ! Ice specific heat 
    134       REAL(wp), POINTER, DIMENSION(:,:) ::   z_i         ! Vertical cotes of the layers in the ice 
    135       REAL(wp), POINTER, DIMENSION(:,:) ::   zradtr_s    ! Radiation transmited through the snow 
    136       REAL(wp), POINTER, DIMENSION(:,:) ::   zradab_s    ! Radiation absorbed in the snow 
    137       REAL(wp), POINTER, DIMENSION(:,:) ::   zkappa_s    ! Kappa factor in the snow 
    138       REAL(wp), POINTER, DIMENSION(:,:) ::   zeta_s      ! Eta factor in the snow 
    139       REAL(wp), POINTER, DIMENSION(:,:) ::   ztstemp     ! Temporary temperature in the snow to check the convergence 
    140       REAL(wp), POINTER, DIMENSION(:,:) ::   ztsb        ! Temporary temperature in the snow 
    141       REAL(wp), POINTER, DIMENSION(:,:) ::   z_s         ! Vertical cotes of the layers in the snow 
    142       REAL(wp), POINTER, DIMENSION(:,:) ::   zswiterm    ! Independent term 
    143       REAL(wp), POINTER, DIMENSION(:,:) ::   zswitbis    ! temporary independent term 
    144       REAL(wp), POINTER, DIMENSION(:,:) ::   zdiagbis 
    145       REAL(wp), POINTER, DIMENSION(:,:,:) ::   ztrid     ! tridiagonal system terms 
     114      REAL(wp) ::   zhsu 
     115       
     116      REAL(wp), POINTER, DIMENSION(:)     ::   isnow       ! switch for presence (1) or absence (0) of snow 
     117      REAL(wp), POINTER, DIMENSION(:)     ::   ztsub       ! old surface temperature (before the iterative procedure ) 
     118      REAL(wp), POINTER, DIMENSION(:)     ::   ztsubit     ! surface temperature at previous iteration 
     119      REAL(wp), POINTER, DIMENSION(:)     ::   zh_i        ! ice layer thickness 
     120      REAL(wp), POINTER, DIMENSION(:)     ::   zh_s        ! snow layer thickness 
     121      REAL(wp), POINTER, DIMENSION(:)     ::   zfsw        ! solar radiation absorbed at the surface 
     122      REAL(wp), POINTER, DIMENSION(:)     ::   zqns_ice_b  ! solar radiation absorbed at the surface 
     123      REAL(wp), POINTER, DIMENSION(:)     ::   zf          ! surface flux function 
     124      REAL(wp), POINTER, DIMENSION(:)     ::   dzf         ! derivative of the surface flux function 
     125      REAL(wp), POINTER, DIMENSION(:)     ::   zerrit      ! current error on temperature 
     126      REAL(wp), POINTER, DIMENSION(:)     ::   zdifcase    ! case of the equation resolution (1->4) 
     127      REAL(wp), POINTER, DIMENSION(:)     ::   zftrice     ! solar radiation transmitted through the ice 
     128      REAL(wp), POINTER, DIMENSION(:)     ::   zihic 
     129       
     130      REAL(wp), POINTER, DIMENSION(:,:)   ::   ztcond_i    ! Ice thermal conductivity 
     131      REAL(wp), POINTER, DIMENSION(:,:)   ::   zradtr_i    ! Radiation transmitted through the ice 
     132      REAL(wp), POINTER, DIMENSION(:,:)   ::   zradab_i    ! Radiation absorbed in the ice 
     133      REAL(wp), POINTER, DIMENSION(:,:)   ::   zkappa_i    ! Kappa factor in the ice 
     134      REAL(wp), POINTER, DIMENSION(:,:)   ::   ztib        ! Old temperature in the ice 
     135      REAL(wp), POINTER, DIMENSION(:,:)   ::   zeta_i      ! Eta factor in the ice 
     136      REAL(wp), POINTER, DIMENSION(:,:)   ::   ztitemp     ! Temporary temperature in the ice to check the convergence 
     137      REAL(wp), POINTER, DIMENSION(:,:)   ::   zspeche_i   ! Ice specific heat 
     138      REAL(wp), POINTER, DIMENSION(:,:)   ::   z_i         ! Vertical cotes of the layers in the ice 
     139      REAL(wp), POINTER, DIMENSION(:,:)   ::   zradtr_s    ! Radiation transmited through the snow 
     140      REAL(wp), POINTER, DIMENSION(:,:)   ::   zradab_s    ! Radiation absorbed in the snow 
     141      REAL(wp), POINTER, DIMENSION(:,:)   ::   zkappa_s    ! Kappa factor in the snow 
     142      REAL(wp), POINTER, DIMENSION(:,:)   ::   zeta_s      ! Eta factor in the snow 
     143      REAL(wp), POINTER, DIMENSION(:,:)   ::   ztstemp     ! Temporary temperature in the snow to check the convergence 
     144      REAL(wp), POINTER, DIMENSION(:,:)   ::   ztsb        ! Temporary temperature in the snow 
     145      REAL(wp), POINTER, DIMENSION(:,:)   ::   z_s         ! Vertical cotes of the layers in the snow 
     146      REAL(wp), POINTER, DIMENSION(:,:)   ::   zindterm    ! 'Ind'ependent term 
     147      REAL(wp), POINTER, DIMENSION(:,:)   ::   zindtbis    ! Temporary 'ind'ependent term 
     148      REAL(wp), POINTER, DIMENSION(:,:)   ::   zdiagbis    ! Temporary 'dia'gonal term 
     149      REAL(wp), POINTER, DIMENSION(:,:,:) ::   ztrid       ! Tridiagonal system terms 
     150       
    146151      ! diag errors on heat 
    147       REAL(wp), POINTER, DIMENSION(:) :: zdq, zq_ini, zhfx_err 
     152      REAL(wp), POINTER, DIMENSION(:)     :: zdq, zq_ini, zhfx_err 
     153       
     154      ! Mono-category 
     155      REAL(wp)                            :: zepsilon      ! determines thres. above which computation of G(h) is done 
     156      REAL(wp)                            :: zratio_s      ! dummy factor 
     157      REAL(wp)                            :: zratio_i      ! dummy factor 
     158      REAL(wp)                            :: zh_thres      ! thickness thres. for G(h) computation 
     159      REAL(wp)                            :: zhe           ! dummy factor 
     160      REAL(wp)                            :: zkimean       ! mean sea ice thermal conductivity 
     161      REAL(wp)                            :: zfac          ! dummy factor 
     162      REAL(wp)                            :: zihe          ! dummy factor 
     163      REAL(wp)                            :: zheshth       ! dummy factor 
     164       
     165      REAL(wp), POINTER, DIMENSION(:)     :: zghe          ! G(he), th. conduct enhancement factor, mono-cat 
     166       
    148167      !!------------------------------------------------------------------      
    149168      !  
    150       CALL wrk_alloc( jpij, numeqmin, numeqmax, isnow ) 
    151       CALL wrk_alloc( jpij, ztfs, ztsub, ztsubit, zh_i, zh_s, zfsw ) 
    152       CALL wrk_alloc( jpij, zf, dzf, zerrit, zdifcase, zftrice, zihic, zhsu ) 
    153       CALL wrk_alloc( jpij, nlay_i+1, ztcond_i, zradtr_i, zradab_i, zkappa_i, ztib, zeta_i, ztitemp, z_i, zspeche_i, kjstart=0) 
    154       CALL wrk_alloc( jpij, nlay_s+1,           zradtr_s, zradab_s, zkappa_s, ztsb, zeta_s, ztstemp, z_s, kjstart=0) 
    155       CALL wrk_alloc( jpij, nlay_i+3, zswiterm, zswitbis, zdiagbis  ) 
    156       CALL wrk_alloc( jpij, nlay_i+3, 3, ztrid ) 
     169      CALL wrk_alloc( jpij, numeqmin, numeqmax ) 
     170      CALL wrk_alloc( jpij, isnow, ztsub, ztsubit, zh_i, zh_s, zfsw ) 
     171      CALL wrk_alloc( jpij, zf, dzf, zqns_ice_b, zerrit, zdifcase, zftrice, zihic, zghe ) 
     172      CALL wrk_alloc( jpij,nlay_i+1, ztcond_i, zradtr_i, zradab_i, zkappa_i, ztib, zeta_i, ztitemp, z_i, zspeche_i, kjstart=0 ) 
     173      CALL wrk_alloc( jpij,nlay_s+1,           zradtr_s, zradab_s, zkappa_s, ztsb, zeta_s, ztstemp, z_s, kjstart=0 ) 
     174      CALL wrk_alloc( jpij,nlay_i+3, zindterm, zindtbis, zdiagbis  ) 
     175      CALL wrk_alloc( jpij,nlay_i+3,3, ztrid ) 
    157176 
    158177      CALL wrk_alloc( jpij, zdq, zq_ini, zhfx_err ) 
    … …  
    161180      zdq(:) = 0._wp ; zq_ini(:) = 0._wp       
    162181      DO ji = kideb, kiut 
    163          zq_ini(ji) = ( SUM( q_i_1d(ji,1:nlay_i) ) * ht_i_1d(ji) / REAL( nlay_i ) +  & 
    164             &           SUM( q_s_1d(ji,1:nlay_s) ) * ht_s_1d(ji) / REAL( nlay_s ) )  
     182         zq_ini(ji) = ( SUM( q_i_1d(ji,1:nlay_i) ) * ht_i_1d(ji) * r1_nlay_i +  & 
     183            &           SUM( q_s_1d(ji,1:nlay_s) ) * ht_s_1d(ji) * r1_nlay_s )  
    165184      END DO 
    166185 
    … …  
    168187      ! 1) Initialization                                                            ! 
    169188      !------------------------------------------------------------------------------! 
    170       ! clem clean: replace just ztfs by rtt 
    171189      DO ji = kideb , kiut 
    172          ! is there snow or not 
    173          isnow(ji)= NINT(  1._wp - MAX( 0._wp , SIGN(1._wp, - ht_s_1d(ji) ) )  ) 
    174          ! surface temperature of fusion 
    175          ztfs(ji) = REAL( isnow(ji) ) * rtt + REAL( 1 - isnow(ji) ) * rtt 
     190         isnow(ji)= 1._wp - MAX( 0._wp , SIGN(1._wp, - ht_s_1d(ji) ) )  ! is there snow or not 
    176191         ! layer thickness 
    177          zh_i(ji) = ht_i_1d(ji) / REAL( nlay_i ) 
    178          zh_s(ji) = ht_s_1d(ji) / REAL( nlay_s ) 
     192         zh_i(ji) = ht_i_1d(ji) * r1_nlay_i 
     193         zh_s(ji) = ht_s_1d(ji) * r1_nlay_s 
    179194      END DO 
    180195 
    … …  
    188203      DO jk = 1, nlay_s            ! vert. coord of the up. lim. of the layer-th snow layer 
    189204         DO ji = kideb , kiut 
    190             z_s(ji,jk) = z_s(ji,jk-1) + ht_s_1d(ji) / REAL( nlay_s ) 
     205            z_s(ji,jk) = z_s(ji,jk-1) + ht_s_1d(ji) * r1_nlay_s 
    191206         END DO 
    192207      END DO 
    … …  
    194209      DO jk = 1, nlay_i            ! vert. coord of the up. lim. of the layer-th ice layer 
    195210         DO ji = kideb , kiut 
    196             z_i(ji,jk) = z_i(ji,jk-1) + ht_i_1d(ji) / REAL( nlay_i ) 
     211            z_i(ji,jk) = z_i(ji,jk-1) + ht_i_1d(ji) * r1_nlay_i 
    197212         END DO 
    198213      END DO 
    199214      ! 
    200215      !------------------------------------------------------------------------------| 
    201       ! 2) Radiations                                                                | 
     216      ! 2) Radiation                                                       | 
    202217      !------------------------------------------------------------------------------| 
    203218      ! 
    … …  
    212227      ! zftrice = io.qsr_ice       is below the surface  
    213228      ! ftr_ice = io.qsr_ice.exp(-k(h_i)) transmitted below the ice  
    214  
     229      ! fr1_i0_1d = i0 for a thin ice cover, fr1_i0_2d = i0 for a thick ice cover 
     230      zhsu = 0.1_wp ! threshold for the computation of i0 
    215231      DO ji = kideb , kiut 
    216232         ! switches 
    217          isnow(ji) = NINT(  1._wp - MAX( 0._wp , SIGN( 1._wp , - ht_s_1d(ji) ) ) )  
     233         isnow(ji) = 1._wp - MAX( 0._wp , SIGN( 1._wp , - ht_s_1d(ji) ) )  
    218234         ! hs > 0, isnow = 1 
    219          zhsu (ji) = hnzst  ! threshold for the computation of i0 
    220          zihic(ji) = MAX( 0._wp , 1._wp - ( ht_i_1d(ji) / zhsu(ji) ) )      
    221  
    222          i0(ji)    = REAL( 1 - isnow(ji) ) * ( fr1_i0_1d(ji) + zihic(ji) * fr2_i0_1d(ji) ) 
    223          !fr1_i0_1d = i0 for a thin ice surface 
    224          !fr1_i0_2d = i0 for a thick ice surface 
    225          !            a function of the cloud cover 
    226          ! 
    227          !i0(ji)     =  (1.0-FLOAT(isnow(ji)))*3.0/(100*ht_s_1d(ji)+10.0) 
    228          !formula used in Cice 
     235         zihic(ji) = MAX( 0._wp , 1._wp - ( ht_i_1d(ji) / zhsu ) )      
     236 
     237         i0(ji)    = ( 1._wp - isnow(ji) ) * ( fr1_i0_1d(ji) + zihic(ji) * fr2_i0_1d(ji) ) 
    229238      END DO 
    230239 
    … …  
    234243      !------------------------------------------------------- 
    235244      DO ji = kideb , kiut 
    236          zfsw   (ji) =  qsr_ice_1d(ji) * ( 1 - i0(ji) )   ! Shortwave radiation absorbed at surface 
    237          zftrice(ji) =  qsr_ice_1d(ji) *       i0(ji)     ! Solar radiation transmitted below the surface layer 
    238          dzf    (ji) = dqns_ice_1d(ji)                    ! derivative of incoming nonsolar flux  
     245         zfsw   (ji)    =  qsr_ice_1d(ji) * ( 1 - i0(ji) )   ! Shortwave radiation absorbed at surface 
     246         zftrice(ji)    =  qsr_ice_1d(ji) *       i0(ji)     ! Solar radiation transmitted below the surface layer 
     247         dzf    (ji)    = dqns_ice_1d(ji)                    ! derivative of incoming nonsolar flux  
     248         zqns_ice_b(ji) = qns_ice_1d(ji)                     ! store previous qns_ice_1d value 
    239249      END DO 
    240250 
    … …  
    257267 
    258268      DO ji = kideb, kiut           ! ice initialization 
    259          zradtr_i(ji,0) = zradtr_s(ji,nlay_s) * REAL( isnow(ji) ) + zftrice(ji) * REAL( 1 - isnow(ji) ) 
     269         zradtr_i(ji,0) = zradtr_s(ji,nlay_s) * isnow(ji) + zftrice(ji) * ( 1._wp - isnow(ji) ) 
    260270      END DO 
    261271 
    … …  
    263273         DO ji = kideb, kiut 
    264274            !                             ! radiation transmitted below the layer-th ice layer 
    265             zradtr_i(ji,jk) = zradtr_i(ji,0) * EXP( - kappa_i * ( MAX ( 0._wp , z_i(ji,jk) ) ) ) 
     275            zradtr_i(ji,jk) = zradtr_i(ji,0) * EXP( - rn_kappa_i * ( MAX ( 0._wp , z_i(ji,jk) ) ) ) 
    266276            !                             ! radiation absorbed by the layer-th ice layer 
    267277            zradab_i(ji,jk) = zradtr_i(ji,jk-1) - zradtr_i(ji,jk) 
    … …  
    281291         ztsub  (ji) =  t_su_1d(ji)                              ! temperature at the beg of iter pr. 
    282292         ztsubit(ji) =  t_su_1d(ji)                              ! temperature at the previous iter 
    283          t_su_1d   (ji) =  MIN( t_su_1d(ji), ztfs(ji) - ztsu_err )  ! necessary 
    284          zerrit   (ji) =  1000._wp                                ! initial value of error 
     293         t_su_1d(ji) =  MIN( t_su_1d(ji), rt0 - ztsu_err )       ! necessary 
     294         zerrit (ji) =  1000._wp                                 ! initial value of error 
    285295      END DO 
    286296 
    … …  
    300310      zerritmax =  1000._wp    ! maximal value of error on all points 
    301311 
    302       DO WHILE ( zerritmax > maxer_i_thd .AND. nconv < nconv_i_thd ) 
     312      DO WHILE ( zerritmax > rn_terr_dif .AND. nconv < nn_conv_dif ) 
    303313         ! 
    304314         nconv = nconv + 1 
    … …  
    308318         !------------------------------------------------------------------------------| 
    309319         ! 
    310          IF( thcon_i_swi == 0 ) THEN      ! Untersteiner (1964) formula 
    311             DO ji = kideb , kiut 
    312                ztcond_i(ji,0)        = rcdic + zbeta*s_i_1d(ji,1) / MIN(-epsi10,t_i_1d(ji,1)-rtt) 
    313                ztcond_i(ji,0)        = MAX(ztcond_i(ji,0),zkimin) 
     320         IF( nn_ice_thcon == 0 ) THEN      ! Untersteiner (1964) formula 
     321            DO ji = kideb , kiut 
     322               ztcond_i(ji,0) = rcdic + zbeta * s_i_1d(ji,1) / MIN( -epsi10, t_i_1d(ji,1) - rt0 ) 
     323               ztcond_i(ji,0) = MAX( ztcond_i(ji,0), zkimin ) 
    314324            END DO 
    315325            DO jk = 1, nlay_i-1 
    316326               DO ji = kideb , kiut 
    317                   ztcond_i(ji,jk) = rcdic + zbeta*( s_i_1d(ji,jk) + s_i_1d(ji,jk+1) ) /  & 
    318                      MIN(-2.0_wp * epsi10, t_i_1d(ji,jk)+t_i_1d(ji,jk+1) - 2.0_wp * rtt) 
    319                   ztcond_i(ji,jk) = MAX(ztcond_i(ji,jk),zkimin) 
     327                  ztcond_i(ji,jk) = rcdic + zbeta * ( s_i_1d(ji,jk) + s_i_1d(ji,jk+1) ) /  & 
     328                     MIN(-2.0_wp * epsi10, t_i_1d(ji,jk) + t_i_1d(ji,jk+1) - 2.0_wp * rt0) 
     329                  ztcond_i(ji,jk) = MAX( ztcond_i(ji,jk), zkimin ) 
    320330               END DO 
    321331            END DO 
    322332         ENDIF 
    323333 
    324          IF( thcon_i_swi == 1 ) THEN      ! Pringle et al formula included: 2.11 + 0.09 S/T - 0.011.T 
    325             DO ji = kideb , kiut 
    326                ztcond_i(ji,0) = rcdic + 0.090_wp * s_i_1d(ji,1) / MIN( -epsi10, t_i_1d(ji,1)-rtt )   & 
    327                   &                   - 0.011_wp * ( t_i_1d(ji,1) - rtt )   
     334         IF( nn_ice_thcon == 1 ) THEN      ! Pringle et al formula included: 2.11 + 0.09 S/T - 0.011.T 
     335            DO ji = kideb , kiut 
     336               ztcond_i(ji,0) = rcdic + 0.090_wp * s_i_1d(ji,1) / MIN( -epsi10, t_i_1d(ji,1) - rt0 )   & 
     337                  &                   - 0.011_wp * ( t_i_1d(ji,1) - rt0 )   
    328338               ztcond_i(ji,0) = MAX( ztcond_i(ji,0), zkimin ) 
    329339            END DO 
    330340            DO jk = 1, nlay_i-1 
    331341               DO ji = kideb , kiut 
    332                   ztcond_i(ji,jk) = rcdic +                                                                     &  
    333                      &                 0.090_wp * ( s_i_1d(ji,jk) + s_i_1d(ji,jk+1) )                          & 
    334                      &                 / MIN(-2.0_wp * epsi10, t_i_1d(ji,jk)+t_i_1d(ji,jk+1) - 2.0_wp * rtt)   & 
    335                      &               - 0.0055_wp* ( t_i_1d(ji,jk) + t_i_1d(ji,jk+1) - 2.0*rtt )   
     342                  ztcond_i(ji,jk) = rcdic +                                                                       &  
     343                     &                 0.09_wp * ( s_i_1d(ji,jk) + s_i_1d(ji,jk+1) )                              & 
     344                     &                 / MIN( -2._wp * epsi10, t_i_1d(ji,jk) + t_i_1d(ji,jk+1) - 2.0_wp * rt0 )   & 
     345                     &               - 0.0055_wp * ( t_i_1d(ji,jk) + t_i_1d(ji,jk+1) - 2.0 * rt0 )   
    336346                  ztcond_i(ji,jk) = MAX( ztcond_i(ji,jk), zkimin ) 
    337347               END DO 
    338348            END DO 
    339349            DO ji = kideb , kiut 
    340                ztcond_i(ji,nlay_i) = rcdic + 0.090_wp * s_i_1d(ji,nlay_i) / MIN(-epsi10,t_bo_1d(ji)-rtt)   & 
    341                   &                        - 0.011_wp * ( t_bo_1d(ji) - rtt )   
     350               ztcond_i(ji,nlay_i) = rcdic + 0.090_wp * s_i_1d(ji,nlay_i) / MIN( -epsi10, t_bo_1d(ji) - rt0 )   & 
     351                  &                        - 0.011_wp * ( t_bo_1d(ji) - rt0 )   
    342352               ztcond_i(ji,nlay_i) = MAX( ztcond_i(ji,nlay_i), zkimin ) 
    343353            END DO 
    344354         ENDIF 
    345          ! 
    346          !------------------------------------------------------------------------------| 
    347          !  5) kappa factors                                                            | 
    348          !------------------------------------------------------------------------------| 
    349          ! 
     355          
     356         ! 
     357         !------------------------------------------------------------------------------| 
     358         !  5) G(he) - enhancement of thermal conductivity in mono-category case        | 
     359         !------------------------------------------------------------------------------| 
     360         ! 
     361         ! Computation of effective thermal conductivity G(h) 
     362         ! Used in mono-category case only to simulate an ITD implicitly 
     363         ! Fichefet and Morales Maqueda, JGR 1997 
     364 
     365         zghe(:) = 1._wp 
     366 
     367         SELECT CASE ( nn_monocat ) 
     368 
     369         CASE (1,3) ! LIM3 
     370 
     371            zepsilon = 0.1_wp 
     372            zh_thres = EXP( 1._wp ) * zepsilon * 0.5_wp 
     373 
     374            DO ji = kideb, kiut 
     375    
     376               ! Mean sea ice thermal conductivity 
     377               zkimean  = SUM( ztcond_i(ji,0:nlay_i) ) / REAL( nlay_i+1, wp ) 
     378 
     379               ! Effective thickness he (zhe) 
     380               zfac     = 1._wp / ( rcdsn + zkimean ) 
     381               zratio_s = rcdsn   * zfac 
     382               zratio_i = zkimean * zfac 
     383               zhe      = zratio_s * ht_i_1d(ji) + zratio_i * ht_s_1d(ji) 
     384 
     385               ! G(he) 
     386               rswitch  = MAX( 0._wp , SIGN( 1._wp , zhe - zh_thres ) )  ! =0 if zhe < zh_thres, if > 
     387               zghe(ji) = ( 1._wp - rswitch ) + rswitch * 0.5_wp * ( 1._wp + LOG( 2._wp * zhe / zepsilon ) ) 
     388    
     389               ! Impose G(he) < 2. 
     390               zghe(ji) = MIN( zghe(ji), 2._wp ) 
     391 
     392            END DO 
     393 
     394         END SELECT 
     395 
     396         ! 
     397         !------------------------------------------------------------------------------| 
     398         !  6) kappa factors                                                            | 
     399         !------------------------------------------------------------------------------| 
     400         ! 
     401         !--- Snow 
    350402         DO ji = kideb, kiut 
    351  
    352             !-- Snow kappa factors 
    353             zkappa_s(ji,0)         = rcdsn / MAX(epsi10,zh_s(ji)) 
    354             zkappa_s(ji,nlay_s)    = rcdsn / MAX(epsi10,zh_s(ji)) 
     403            zfac                  =  1. / MAX( epsi10 , zh_s(ji) ) 
     404            zkappa_s(ji,0)        = zghe(ji) * rcdsn * zfac 
     405            zkappa_s(ji,nlay_s)   = zghe(ji) * rcdsn * zfac 
    355406         END DO 
    356407 
    357408         DO jk = 1, nlay_s-1 
    358409            DO ji = kideb , kiut 
    359                zkappa_s(ji,jk)  = 2.0 * rcdsn / & 
    360                   MAX(epsi10,2.0*zh_s(ji)) 
    361             END DO 
    362          END DO 
    363  
     410               zkappa_s(ji,jk)    = zghe(ji) * 2.0 * rcdsn / MAX( epsi10, 2.0 * zh_s(ji) ) 
     411            END DO 
     412         END DO 
     413 
     414         !--- Ice 
    364415         DO jk = 1, nlay_i-1 
    365416            DO ji = kideb , kiut 
    366                !-- Ice kappa factors 
    367                zkappa_i(ji,jk)  = 2.0*ztcond_i(ji,jk)/ & 
    368                   MAX(epsi10,2.0*zh_i(ji))  
    369             END DO 
    370          END DO 
    371  
    372          DO ji = kideb , kiut 
    373             zkappa_i(ji,0)        = ztcond_i(ji,0)/MAX(epsi10,zh_i(ji)) 
    374             zkappa_i(ji,nlay_i)   = ztcond_i(ji,nlay_i) / MAX(epsi10,zh_i(ji)) 
    375             !-- Interface 
    376             zkappa_s(ji,nlay_s)   = 2.0*rcdsn*ztcond_i(ji,0)/MAX(epsi10, & 
    377                (ztcond_i(ji,0)*zh_s(ji) + rcdsn*zh_i(ji))) 
    378             zkappa_i(ji,0)        = zkappa_s(ji,nlay_s)*REAL( isnow(ji) ) & 
    379                + zkappa_i(ji,0)*REAL( 1 - isnow(ji) ) 
    380          END DO 
    381          ! 
    382          !------------------------------------------------------------------------------| 
    383          ! 6) Sea ice specific heat, eta factors                                        | 
     417               zkappa_i(ji,jk)    = zghe(ji) * 2.0 * ztcond_i(ji,jk) / MAX( epsi10 , 2.0 * zh_i(ji) ) 
     418            END DO 
     419         END DO 
     420 
     421         !--- Snow-ice interface 
     422         DO ji = kideb , kiut 
     423            zfac                  = 1./ MAX( epsi10 , zh_i(ji) ) 
     424            zkappa_i(ji,0)        = zghe(ji) * ztcond_i(ji,0) * zfac 
     425            zkappa_i(ji,nlay_i)   = zghe(ji) * ztcond_i(ji,nlay_i) * zfac 
     426            zkappa_s(ji,nlay_s)   = zghe(ji) * zghe(ji) * 2.0 * rcdsn * ztcond_i(ji,0) / &  
     427           &                        MAX( epsi10, ( zghe(ji) * ztcond_i(ji,0) * zh_s(ji) + zghe(ji) * rcdsn * zh_i(ji) ) ) 
     428            zkappa_i(ji,0)        = zkappa_s(ji,nlay_s) * isnow(ji) + zkappa_i(ji,0) * ( 1._wp - isnow(ji) ) 
     429         END DO 
     430 
     431         ! 
     432         !------------------------------------------------------------------------------| 
     433         ! 7) Sea ice specific heat, eta factors                                        | 
    384434         !------------------------------------------------------------------------------| 
    385435         ! 
    … …  
    387437            DO ji = kideb , kiut 
    388438               ztitemp(ji,jk)   = t_i_1d(ji,jk) 
    389                zspeche_i(ji,jk) = cpic + zgamma*s_i_1d(ji,jk)/ & 
    390                   MAX((t_i_1d(ji,jk)-rtt)*(ztib(ji,jk)-rtt),epsi10) 
    391                zeta_i(ji,jk)    = rdt_ice / MAX(rhoic*zspeche_i(ji,jk)*zh_i(ji), & 
    392                   epsi10) 
     439               zspeche_i(ji,jk) = cpic + zgamma * s_i_1d(ji,jk) / MAX( ( t_i_1d(ji,jk) - rt0 ) * ( ztib(ji,jk) - rt0 ), epsi10 ) 
     440               zeta_i(ji,jk)    = rdt_ice / MAX( rhoic * zspeche_i(ji,jk) * zh_i(ji), epsi10 ) 
    393441            END DO 
    394442         END DO 
    … …  
    397445            DO ji = kideb , kiut 
    398446               ztstemp(ji,jk) = t_s_1d(ji,jk) 
    399                zeta_s(ji,jk)  = rdt_ice / MAX(rhosn*cpic*zh_s(ji),epsi10) 
    400             END DO 
    401          END DO 
    402          ! 
    403          !------------------------------------------------------------------------------| 
    404          ! 7) surface flux computation                                                  | 
    405          !------------------------------------------------------------------------------| 
    406          ! 
    407          IF( .NOT. lk_cpl ) THEN   !--- forced atmosphere case 
     447               zeta_s(ji,jk)  = rdt_ice / MAX( rhosn * cpic * zh_s(ji), epsi10 ) 
     448            END DO 
     449         END DO 
     450 
     451         ! 
     452         !------------------------------------------------------------------------------| 
     453         ! 8) surface flux computation                                                  | 
     454         !------------------------------------------------------------------------------| 
     455         ! 
     456         IF ( ln_it_qnsice ) THEN  
    408457            DO ji = kideb , kiut 
    409458               ! update of the non solar flux according to the update in T_su 
    … …  
    415464         DO ji = kideb , kiut 
    416465            ! update incoming flux 
    417             zf(ji)    =   zfsw(ji)              & ! net absorbed solar radiation 
    418                + qns_ice_1d(ji)                   ! non solar total flux  
    419             ! (LWup, LWdw, SH, LH) 
    420          END DO 
    421  
    422          ! 
    423          !------------------------------------------------------------------------------| 
    424          ! 8) tridiagonal system terms                                                  | 
     466            zf(ji)    =          zfsw(ji)              & ! net absorbed solar radiation 
     467               &         + qns_ice_1d(ji)                ! non solar total flux (LWup, LWdw, SH, LH) 
     468         END DO 
     469 
     470         ! 
     471         !------------------------------------------------------------------------------| 
     472         ! 9) tridiagonal system terms                                                  | 
    425473         !------------------------------------------------------------------------------| 
    426474         ! 
    … …  
    437485               ztrid(ji,numeq,2) = 0. 
    438486               ztrid(ji,numeq,3) = 0. 
    439                zswiterm(ji,numeq)= 0. 
    440                zswitbis(ji,numeq)= 0. 
     487               zindterm(ji,numeq)= 0. 
     488               zindtbis(ji,numeq)= 0. 
    441489               zdiagbis(ji,numeq)= 0. 
    442490            ENDDO 
    … …  
    445493         DO numeq = nlay_s + 2, nlay_s + nlay_i  
    446494            DO ji = kideb , kiut 
    447                jk              = numeq - nlay_s - 1 
    448                ztrid(ji,numeq,1)  =  - zeta_i(ji,jk)*zkappa_i(ji,jk-1) 
    449                ztrid(ji,numeq,2)  =  1.0 + zeta_i(ji,jk)*(zkappa_i(ji,jk-1) + & 
    450                   zkappa_i(ji,jk)) 
    451                ztrid(ji,numeq,3)  =  - zeta_i(ji,jk)*zkappa_i(ji,jk) 
    452                zswiterm(ji,numeq) =  ztib(ji,jk) + zeta_i(ji,jk)* & 
    453                   zradab_i(ji,jk) 
     495               jk                 = numeq - nlay_s - 1 
     496               ztrid(ji,numeq,1)  =  - zeta_i(ji,jk) * zkappa_i(ji,jk-1) 
     497               ztrid(ji,numeq,2)  =  1.0 + zeta_i(ji,jk) * ( zkappa_i(ji,jk-1) + zkappa_i(ji,jk) ) 
     498               ztrid(ji,numeq,3)  =  - zeta_i(ji,jk) * zkappa_i(ji,jk) 
     499               zindterm(ji,numeq) =  ztib(ji,jk) + zeta_i(ji,jk) * zradab_i(ji,jk) 
    454500            END DO 
    455501         ENDDO 
    … …  
    459505            !!ice bottom term 
    460506            ztrid(ji,numeq,1)  =  - zeta_i(ji,nlay_i)*zkappa_i(ji,nlay_i-1)    
    461             ztrid(ji,numeq,2)  =  1.0 + zeta_i(ji,nlay_i)*( zkappa_i(ji,nlay_i)*zg1 & 
    462                +  zkappa_i(ji,nlay_i-1) ) 
     507            ztrid(ji,numeq,2)  =  1.0 + zeta_i(ji,nlay_i) * ( zkappa_i(ji,nlay_i) * zg1 + zkappa_i(ji,nlay_i-1) ) 
    463508            ztrid(ji,numeq,3)  =  0.0 
    464             zswiterm(ji,numeq) =  ztib(ji,nlay_i) + zeta_i(ji,nlay_i)* & 
    465                ( zradab_i(ji,nlay_i) + zkappa_i(ji,nlay_i)*zg1 & 
    466                *  t_bo_1d(ji) )  
     509            zindterm(ji,numeq) =  ztib(ji,nlay_i) + zeta_i(ji,nlay_i) *  & 
     510               &                  ( zradab_i(ji,nlay_i) + zkappa_i(ji,nlay_i) * zg1 *  t_bo_1d(ji) )  
    467511         ENDDO 
    468512 
    469513 
    470514         DO ji = kideb , kiut 
    471             IF ( ht_s_1d(ji).gt.0.0 ) THEN 
     515            IF ( ht_s_1d(ji) > 0.0 ) THEN 
    472516               ! 
    473517               !------------------------------------------------------------------------------| 
    … …  
    477521               !!snow interior terms (bottom equation has the same form as the others) 
    478522               DO numeq = 3, nlay_s + 1 
    479                   jk =  numeq - 1 
    480                   ztrid(ji,numeq,1)   =  - zeta_s(ji,jk)*zkappa_s(ji,jk-1) 
    481                   ztrid(ji,numeq,2)   =  1.0 + zeta_s(ji,jk)*( zkappa_s(ji,jk-1) + & 
    482                      zkappa_s(ji,jk) ) 
     523                  jk                  =  numeq - 1 
     524                  ztrid(ji,numeq,1)   =  - zeta_s(ji,jk) * zkappa_s(ji,jk-1) 
     525                  ztrid(ji,numeq,2)   =  1.0 + zeta_s(ji,jk) * ( zkappa_s(ji,jk-1) + zkappa_s(ji,jk) ) 
    483526                  ztrid(ji,numeq,3)   =  - zeta_s(ji,jk)*zkappa_s(ji,jk) 
    484                   zswiterm(ji,numeq)  =  ztsb(ji,jk) + zeta_s(ji,jk)* & 
    485                      zradab_s(ji,jk) 
     527                  zindterm(ji,numeq)  =  ztsb(ji,jk) + zeta_s(ji,jk) * zradab_s(ji,jk) 
    486528               END DO 
    487529 
    … …  
    489531               IF ( nlay_i.eq.1 ) THEN 
    490532                  ztrid(ji,nlay_s+2,3)    =  0.0 
    491                   zswiterm(ji,nlay_s+2)   =  zswiterm(ji,nlay_s+2) + zkappa_i(ji,1)* & 
    492                      t_bo_1d(ji)  
     533                  zindterm(ji,nlay_s+2)   =  zindterm(ji,nlay_s+2) + zkappa_i(ji,1) * t_bo_1d(ji)  
    493534               ENDIF 
    494535 
    495                IF ( t_su_1d(ji) .LT. rtt ) THEN 
     536               IF ( t_su_1d(ji) < rt0 ) THEN 
    496537 
    497538                  !------------------------------------------------------------------------------| 
    … …  
    503544 
    504545                  !!surface equation 
    505                   ztrid(ji,1,1) = 0.0 
    506                   ztrid(ji,1,2) = dzf(ji) - zg1s*zkappa_s(ji,0) 
    507                   ztrid(ji,1,3) = zg1s*zkappa_s(ji,0) 
    508                   zswiterm(ji,1) = dzf(ji)*t_su_1d(ji)  - zf(ji) 
     546                  ztrid(ji,1,1)  = 0.0 
     547                  ztrid(ji,1,2)  = dzf(ji) - zg1s * zkappa_s(ji,0) 
     548                  ztrid(ji,1,3)  = zg1s * zkappa_s(ji,0) 
     549                  zindterm(ji,1) = dzf(ji) * t_su_1d(ji) - zf(ji) 
    509550 
    510551                  !!first layer of snow equation 
    511                   ztrid(ji,2,1)  =  - zkappa_s(ji,0)*zg1s*zeta_s(ji,1) 
    512                   ztrid(ji,2,2)  =  1.0 + zeta_s(ji,1)*(zkappa_s(ji,1) + zkappa_s(ji,0)*zg1s) 
     552                  ztrid(ji,2,1)  =  - zkappa_s(ji,0) * zg1s * zeta_s(ji,1) 
     553                  ztrid(ji,2,2)  =  1.0 + zeta_s(ji,1) * ( zkappa_s(ji,1) + zkappa_s(ji,0) * zg1s ) 
    513554                  ztrid(ji,2,3)  =  - zeta_s(ji,1)* zkappa_s(ji,1) 
    514                   zswiterm(ji,2) =  ztsb(ji,1) + zeta_s(ji,1)*zradab_s(ji,1) 
     555                  zindterm(ji,2) =  ztsb(ji,1) + zeta_s(ji,1) * zradab_s(ji,1) 
    515556 
    516557               ELSE  
    … …  
    526567                  !!first layer of snow equation 
    527568                  ztrid(ji,2,1)  =  0.0 
    528                   ztrid(ji,2,2)  =  1.0 + zeta_s(ji,1) * ( zkappa_s(ji,1) + & 
    529                      zkappa_s(ji,0) * zg1s ) 
     569                  ztrid(ji,2,2)  =  1.0 + zeta_s(ji,1) * ( zkappa_s(ji,1) + zkappa_s(ji,0) * zg1s ) 
    530570                  ztrid(ji,2,3)  =  - zeta_s(ji,1)*zkappa_s(ji,1)  
    531                   zswiterm(ji,2) = ztsb(ji,1) + zeta_s(ji,1) *            & 
    532                      ( zradab_s(ji,1) +                         & 
    533                      zkappa_s(ji,0) * zg1s * t_su_1d(ji) )  
     571                  zindterm(ji,2) = ztsb(ji,1) + zeta_s(ji,1) *  & 
     572                     &             ( zradab_s(ji,1) + zkappa_s(ji,0) * zg1s * t_su_1d(ji) )  
    534573               ENDIF 
    535574            ELSE 
    … …  
    539578               !------------------------------------------------------------------------------| 
    540579               ! 
    541                IF (t_su_1d(ji) .LT. rtt) THEN 
     580               IF ( t_su_1d(ji) < rt0 ) THEN 
    542581                  ! 
    543582                  !------------------------------------------------------------------------------| 
    … …  
    553592                  ztrid(ji,numeqmin(ji),2)   =  dzf(ji) - zkappa_i(ji,0)*zg1     
    554593                  ztrid(ji,numeqmin(ji),3)   =  zkappa_i(ji,0)*zg1 
    555                   zswiterm(ji,numeqmin(ji))  =  dzf(ji)*t_su_1d(ji) - zf(ji) 
     594                  zindterm(ji,numeqmin(ji))  =  dzf(ji)*t_su_1d(ji) - zf(ji) 
    556595 
    557596                  !!first layer of ice equation 
    558597                  ztrid(ji,numeqmin(ji)+1,1) =  - zkappa_i(ji,0) * zg1 * zeta_i(ji,1) 
    559                   ztrid(ji,numeqmin(ji)+1,2) =  1.0 + zeta_i(ji,1) * ( zkappa_i(ji,1) &  
    560                      + zkappa_i(ji,0) * zg1 ) 
    561                   ztrid(ji,numeqmin(ji)+1,3) =  - zeta_i(ji,1)*zkappa_i(ji,1)   
    562                   zswiterm(ji,numeqmin(ji)+1)=  ztib(ji,1) + zeta_i(ji,1)*zradab_i(ji,1)   
     598                  ztrid(ji,numeqmin(ji)+1,2) =  1.0 + zeta_i(ji,1) * ( zkappa_i(ji,1) + zkappa_i(ji,0) * zg1 ) 
     599                  ztrid(ji,numeqmin(ji)+1,3) =  - zeta_i(ji,1) * zkappa_i(ji,1)   
     600                  zindterm(ji,numeqmin(ji)+1)=  ztib(ji,1) + zeta_i(ji,1) * zradab_i(ji,1)   
    563601 
    564602                  !!case of only one layer in the ice (surface & ice equations are altered) 
    565603 
    566                   IF (nlay_i.eq.1) THEN 
     604                  IF ( nlay_i == 1 ) THEN 
    567605                     ztrid(ji,numeqmin(ji),1)    =  0.0 
    568                      ztrid(ji,numeqmin(ji),2)    =  dzf(ji) - zkappa_i(ji,0)*2.0 
    569                      ztrid(ji,numeqmin(ji),3)    =  zkappa_i(ji,0)*2.0 
    570                      ztrid(ji,numeqmin(ji)+1,1)  =  -zkappa_i(ji,0)*2.0*zeta_i(ji,1) 
    571                      ztrid(ji,numeqmin(ji)+1,2)  =  1.0 + zeta_i(ji,1)*(zkappa_i(ji,0)*2.0 + & 
    572                         zkappa_i(ji,1)) 
     606                     ztrid(ji,numeqmin(ji),2)    =  dzf(ji) - zkappa_i(ji,0) * 2.0 
     607                     ztrid(ji,numeqmin(ji),3)    =  zkappa_i(ji,0) * 2.0 
     608                     ztrid(ji,numeqmin(ji)+1,1)  =  -zkappa_i(ji,0) * 2.0 * zeta_i(ji,1) 
     609                     ztrid(ji,numeqmin(ji)+1,2)  =  1.0 + zeta_i(ji,1) * ( zkappa_i(ji,0) * 2.0 + zkappa_i(ji,1) ) 
    573610                     ztrid(ji,numeqmin(ji)+1,3)  =  0.0 
    574611 
    575                      zswiterm(ji,numeqmin(ji)+1) =  ztib(ji,1) + zeta_i(ji,1)* & 
    576                         ( zradab_i(ji,1) + zkappa_i(ji,1)*t_bo_1d(ji) ) 
     612                     zindterm(ji,numeqmin(ji)+1) =  ztib(ji,1) + zeta_i(ji,1) * & 
     613                        &                          ( zradab_i(ji,1) + zkappa_i(ji,1) * t_bo_1d(ji) ) 
    577614                  ENDIF 
    578615 
    … …  
    590627                  !!first layer of ice equation 
    591628                  ztrid(ji,numeqmin(ji),1)      =  0.0 
    592                   ztrid(ji,numeqmin(ji),2)      =  1.0 + zeta_i(ji,1)*(zkappa_i(ji,1) + zkappa_i(ji,0)* & 
    593                      zg1)   
     629                  ztrid(ji,numeqmin(ji),2)      =  1.0 + zeta_i(ji,1) * ( zkappa_i(ji,1) + zkappa_i(ji,0) * zg1 )   
    594630                  ztrid(ji,numeqmin(ji),3)      =  - zeta_i(ji,1) * zkappa_i(ji,1) 
    595                   zswiterm(ji,numeqmin(ji))     =  ztib(ji,1) + zeta_i(ji,1)*( zradab_i(ji,1) + & 
    596                      zkappa_i(ji,0) * zg1 * t_su_1d(ji) )  
     631                  zindterm(ji,numeqmin(ji))     =  ztib(ji,1) + zeta_i(ji,1) * & 
     632                     &                             ( zradab_i(ji,1) + zkappa_i(ji,0) * zg1 * t_su_1d(ji) )  
    597633 
    598634                  !!case of only one layer in the ice (surface & ice equations are altered) 
    599                   IF (nlay_i.eq.1) THEN 
     635                  IF ( nlay_i == 1 ) THEN 
    600636                     ztrid(ji,numeqmin(ji),1)  =  0.0 
    601                      ztrid(ji,numeqmin(ji),2)  =  1.0 + zeta_i(ji,1)*(zkappa_i(ji,0)*2.0 + & 
    602                         zkappa_i(ji,1)) 
     637                     ztrid(ji,numeqmin(ji),2)  =  1.0 + zeta_i(ji,1) * ( zkappa_i(ji,0) * 2.0 + zkappa_i(ji,1) ) 
    603638                     ztrid(ji,numeqmin(ji),3)  =  0.0 
    604                      zswiterm(ji,numeqmin(ji)) =  ztib(ji,1) + zeta_i(ji,1)* & 
    605                         (zradab_i(ji,1) + zkappa_i(ji,1)*t_bo_1d(ji)) & 
    606                         + t_su_1d(ji)*zeta_i(ji,1)*zkappa_i(ji,0)*2.0 
     639                     zindterm(ji,numeqmin(ji)) =  ztib(ji,1) + zeta_i(ji,1) * ( zradab_i(ji,1) + zkappa_i(ji,1) * t_bo_1d(ji) )  & 
     640                        &                       + t_su_1d(ji) * zeta_i(ji,1) * zkappa_i(ji,0) * 2.0 
    607641                  ENDIF 
    608642 
    … …  
    614648         ! 
    615649         !------------------------------------------------------------------------------| 
    616          ! 9) tridiagonal system solving                                                | 
     650         ! 10) tridiagonal system solving                                               | 
    617651         !------------------------------------------------------------------------------| 
    618652         ! 
    … …  
    626660 
    627661         DO ji = kideb , kiut 
    628             zswitbis(ji,numeqmin(ji)) =  zswiterm(ji,numeqmin(ji)) 
     662            zindtbis(ji,numeqmin(ji)) =  zindterm(ji,numeqmin(ji)) 
    629663            zdiagbis(ji,numeqmin(ji)) =  ztrid(ji,numeqmin(ji),2) 
    630664            minnumeqmin               =  MIN(numeqmin(ji),minnumeqmin) 
    … …  
    635669            DO ji = kideb , kiut 
    636670               numeq               =  min(max(numeqmin(ji)+1,jk),numeqmax(ji)) 
    637                zdiagbis(ji,numeq)  =  ztrid(ji,numeq,2) - ztrid(ji,numeq,1)* & 
    638                   ztrid(ji,numeq-1,3)/zdiagbis(ji,numeq-1) 
    639                zswitbis(ji,numeq)  =  zswiterm(ji,numeq) - ztrid(ji,numeq,1)* & 
    640                   zswitbis(ji,numeq-1)/zdiagbis(ji,numeq-1) 
     671               zdiagbis(ji,numeq)  =  ztrid(ji,numeq,2)  - ztrid(ji,numeq,1) * ztrid(ji,numeq-1,3)  / zdiagbis(ji,numeq-1) 
     672               zindtbis(ji,numeq)  =  zindterm(ji,numeq) - ztrid(ji,numeq,1) * zindtbis(ji,numeq-1) / zdiagbis(ji,numeq-1) 
    641673            END DO 
    642674         END DO 
    … …  
    644676         DO ji = kideb , kiut 
    645677            ! ice temperatures 
    646             t_i_1d(ji,nlay_i)    =  zswitbis(ji,numeqmax(ji))/zdiagbis(ji,numeqmax(ji)) 
    647          END DO 
    648  
    649          DO numeq = nlay_i + nlay_s + 1, nlay_s + 2, -1 
     678            t_i_1d(ji,nlay_i)    =  zindtbis(ji,numeqmax(ji)) / zdiagbis(ji,numeqmax(ji)) 
     679         END DO 
     680 
     681         DO numeq = nlay_i + nlay_s, nlay_s + 2, -1 
    650682            DO ji = kideb , kiut 
    651683               jk    =  numeq - nlay_s - 1 
    652                t_i_1d(ji,jk)  =  (zswitbis(ji,numeq) - ztrid(ji,numeq,3)* & 
    653                   t_i_1d(ji,jk+1))/zdiagbis(ji,numeq) 
     684               t_i_1d(ji,jk)  =  ( zindtbis(ji,numeq) - ztrid(ji,numeq,3) * t_i_1d(ji,jk+1) ) / zdiagbis(ji,numeq) 
    654685            END DO 
    655686         END DO 
    … …  
    657688         DO ji = kideb , kiut 
    658689            ! snow temperatures       
    659             IF (ht_s_1d(ji).GT.0._wp) & 
    660                t_s_1d(ji,nlay_s)     =  (zswitbis(ji,nlay_s+1) - ztrid(ji,nlay_s+1,3) & 
    661                *  t_i_1d(ji,1))/zdiagbis(ji,nlay_s+1) & 
    662                *        MAX(0.0,SIGN(1.0,ht_s_1d(ji)))  
     690            IF (ht_s_1d(ji) > 0._wp) & 
     691               t_s_1d(ji,nlay_s)     =  ( zindtbis(ji,nlay_s+1) - ztrid(ji,nlay_s+1,3) * t_i_1d(ji,1) )  & 
     692               &                        / zdiagbis(ji,nlay_s+1) * MAX( 0.0, SIGN( 1.0, ht_s_1d(ji) ) )  
    663693 
    664694            ! surface temperature 
    665             isnow(ji)     = NINT(  1.0 - MAX( 0.0 , SIGN( 1.0 , -ht_s_1d(ji) )  ) ) 
     695            isnow(ji)   = 1._wp - MAX( 0._wp , SIGN( 1._wp , -ht_s_1d(ji) ) ) 
    666696            ztsubit(ji) = t_su_1d(ji) 
    667             IF( t_su_1d(ji) < ztfs(ji) ) & 
    668                t_su_1d(ji) = ( zswitbis(ji,numeqmin(ji)) - ztrid(ji,numeqmin(ji),3)* ( REAL( isnow(ji) )*t_s_1d(ji,1)   & 
    669                &          + REAL( 1 - isnow(ji) )*t_i_1d(ji,1) ) ) / zdiagbis(ji,numeqmin(ji))   
     697            IF( t_su_1d(ji) < rt0 ) & 
     698               t_su_1d(ji) = ( zindtbis(ji,numeqmin(ji)) - ztrid(ji,numeqmin(ji),3) *  & 
     699               &             ( isnow(ji) * t_s_1d(ji,1) + ( 1._wp - isnow(ji) ) * t_i_1d(ji,1) ) ) / zdiagbis(ji,numeqmin(ji))   
    670700         END DO 
    671701         ! 
    672702         !-------------------------------------------------------------------------- 
    673          !  10) Has the scheme converged ?, end of the iterative procedure         | 
     703         !  11) Has the scheme converged ?, end of the iterative procedure         | 
    674704         !-------------------------------------------------------------------------- 
    675705         ! 
    676706         ! check that nowhere it has started to melt 
    677          ! zerrit(ji) is a measure of error, it has to be under maxer_i_thd 
    678          DO ji = kideb , kiut 
    679             t_su_1d(ji) =  MAX(  MIN( t_su_1d(ji) , ztfs(ji) ) , 190._wp  ) 
    680             zerrit(ji) =  ABS( t_su_1d(ji) - ztsubit(ji) )      
     707         ! zerrit(ji) is a measure of error, it has to be under terr_dif 
     708         DO ji = kideb , kiut 
     709            t_su_1d(ji) =  MAX(  MIN( t_su_1d(ji) , rt0 ) , 190._wp  ) 
     710            zerrit(ji)  =  ABS( t_su_1d(ji) - ztsubit(ji) )      
    681711         END DO 
    682712 
    683713         DO jk  =  1, nlay_s 
    684714            DO ji = kideb , kiut 
    685                t_s_1d(ji,jk) = MAX(  MIN( t_s_1d(ji,jk), rtt ), 190._wp  ) 
    686                zerrit(ji)      = MAX(zerrit(ji),ABS(t_s_1d(ji,jk) - ztstemp(ji,jk))) 
     715               t_s_1d(ji,jk) = MAX(  MIN( t_s_1d(ji,jk), rt0 ), 190._wp  ) 
     716               zerrit(ji)    = MAX( zerrit(ji), ABS( t_s_1d(ji,jk) - ztstemp(ji,jk) ) ) 
    687717            END DO 
    688718         END DO 
    … …  
    690720         DO jk  =  1, nlay_i 
    691721            DO ji = kideb , kiut 
    692                ztmelt_i        = -tmut * s_i_1d(ji,jk) + rtt  
    693                t_i_1d(ji,jk) =  MAX(MIN(t_i_1d(ji,jk),ztmelt_i), 190._wp) 
    694                zerrit(ji)      =  MAX(zerrit(ji),ABS(t_i_1d(ji,jk) - ztitemp(ji,jk))) 
     722               ztmelt_i      = -tmut * s_i_1d(ji,jk) + rt0  
     723               t_i_1d(ji,jk) =  MAX( MIN( t_i_1d(ji,jk), ztmelt_i ), 190._wp ) 
     724               zerrit(ji)    =  MAX( zerrit(ji), ABS( t_i_1d(ji,jk) - ztitemp(ji,jk) ) ) 
    695725            END DO 
    696726         END DO 
    … …  
    706736      END DO  ! End of the do while iterative procedure 
    707737 
    708       IF( ln_nicep .AND. lwp ) THEN 
     738      IF( ln_icectl .AND. lwp ) THEN 
    709739         WRITE(numout,*) ' zerritmax : ', zerritmax 
    710740         WRITE(numout,*) ' nconv     : ', nconv 
    … …  
    713743      ! 
    714744      !-------------------------------------------------------------------------! 
    715       !   11) Fluxes at the interfaces                                          ! 
     745      !   12) Fluxes at the interfaces                                          ! 
    716746      !-------------------------------------------------------------------------! 
    717747      DO ji = kideb, kiut 
    … …  
    719749         IF( .NOT. lk_cpl) qla_ice_1d (ji) = MAX( 0._wp, qla_ice_1d (ji) + dqla_ice_1d(ji) * ( t_su_1d(ji) - ztsub(ji) ) ) 
    720750         !                                ! surface ice conduction flux 
    721          isnow(ji)       = NINT(  1._wp - MAX( 0._wp, SIGN( 1._wp, -ht_s_1d(ji) ) ) ) 
    722          fc_su(ji)       =  -     REAL( isnow(ji) ) * zkappa_s(ji,0) * zg1s * (t_s_1d(ji,1) - t_su_1d(ji))   & 
    723             &               - REAL( 1 - isnow(ji) ) * zkappa_i(ji,0) * zg1  * (t_i_1d(ji,1) - t_su_1d(ji)) 
     751         isnow(ji)       = 1._wp - MAX( 0._wp, SIGN( 1._wp, -ht_s_1d(ji) ) ) 
     752         fc_su(ji)       =  -           isnow(ji)  * zkappa_s(ji,0) * zg1s * (t_s_1d(ji,1) - t_su_1d(ji))   & 
     753            &               - ( 1._wp - isnow(ji) ) * zkappa_i(ji,0) * zg1  * (t_i_1d(ji,1) - t_su_1d(ji)) 
    724754         !                                ! bottom ice conduction flux 
    725755         fc_bo_i(ji)     =  - zkappa_i(ji,nlay_i) * ( zg1*(t_bo_1d(ji) - t_i_1d(ji,nlay_i)) ) 
    726756      END DO 
     757 
     758      ! --- computes sea ice energy of melting compulsory for limthd_dh --- ! 
     759      CALL lim_thd_enmelt( kideb, kiut ) 
     760 
     761      ! --- diagnose the change in non-solar flux due to surface temperature change --- ! 
     762      IF ( ln_it_qnsice ) hfx_err_dif_1d(:) = hfx_err_dif_1d(:) - ( qns_ice_1d(:)  - zqns_ice_b(:) ) * a_i_1d(:)  
     763 
     764      ! --- diag conservation imbalance on heat diffusion - PART 2 --- ! 
     765      DO ji = kideb, kiut 
     766         zdq(ji)        = - zq_ini(ji) + ( SUM( q_i_1d(ji,1:nlay_i) ) * ht_i_1d(ji) * r1_nlay_i +  & 
     767            &                              SUM( q_s_1d(ji,1:nlay_s) ) * ht_s_1d(ji) * r1_nlay_s ) 
     768         IF( t_su_1d(ji) < rt0 ) THEN  ! case T_su < 0degC 
     769            zhfx_err(ji) = qns_ice_1d(ji) + qsr_ice_1d(ji) - zradtr_i(ji,nlay_i) - fc_bo_i(ji) + zdq(ji) * r1_rdtice  
     770         ELSE                          ! case T_su = 0degC 
     771            zhfx_err(ji) = fc_su(ji) + i0(ji) * qsr_ice_1d(ji) - zradtr_i(ji,nlay_i) - fc_bo_i(ji) + zdq(ji) * r1_rdtice  
     772         ENDIF 
     773         hfx_err_1d(ji) = hfx_err_1d(ji) + zhfx_err(ji) * a_i_1d(ji) 
     774 
     775         ! total heat that is sent to the ocean (i.e. not used in the heat diffusion equation) 
     776         hfx_err_dif_1d(ji) = hfx_err_dif_1d(ji) + zhfx_err(ji) * a_i_1d(ji) 
     777      END DO  
    727778 
    728779      !----------------------------------------- 
    … …  
    730781      !----------------------------------------- 
    731782      DO ji = kideb, kiut 
    732          IF( t_su_1d(ji) < rtt ) THEN  ! case T_su < 0degC 
     783         IF( t_su_1d(ji) < rt0 ) THEN  ! case T_su < 0degC 
    733784            hfx_dif_1d(ji) = hfx_dif_1d(ji)  +   & 
    734785               &            ( qns_ice_1d(ji) + qsr_ice_1d(ji) - zradtr_i(ji,nlay_i) - fc_bo_i(ji) ) * a_i_1d(ji) 
    735          ELSE                         ! case T_su = 0degC 
     786         ELSE                          ! case T_su = 0degC 
    736787            hfx_dif_1d(ji) = hfx_dif_1d(ji) +    & 
    737788               &             ( fc_su(ji) + i0(ji) * qsr_ice_1d(ji) - zradtr_i(ji,nlay_i) - fc_bo_i(ji) ) * a_i_1d(ji) 
    738789         ENDIF 
    739       END DO 
    740  
    741       ! --- computes sea ice energy of melting compulsory for limthd_dh --- ! 
    742       CALL lim_thd_enmelt( kideb, kiut ) 
    743  
    744       ! --- diag conservation imbalance on heat diffusion - PART 2 --- ! 
    745       DO ji = kideb, kiut 
    746          zdq(ji)        = - zq_ini(ji) + ( SUM( q_i_1d(ji,1:nlay_i) ) * ht_i_1d(ji) / REAL( nlay_i ) +  & 
    747             &                              SUM( q_s_1d(ji,1:nlay_s) ) * ht_s_1d(ji) / REAL( nlay_s ) ) 
    748          zhfx_err(ji)   = ( fc_su(ji) + i0(ji) * qsr_ice_1d(ji) - zradtr_i(ji,nlay_i) - fc_bo_i(ji) + zdq(ji) * r1_rdtice )  
    749          hfx_err_1d(ji) = hfx_err_1d(ji) + zhfx_err(ji) * a_i_1d(ji) 
    750       END DO  
    751  
    752       ! diagnose external surface (forced case) or bottom (forced case) from heat conservation 
    753       IF( .NOT. lk_cpl ) THEN   ! --- forced case: qns_ice and fc_su are diagnosed 
    754          ! 
    755          DO ji = kideb, kiut 
    756             qns_ice_1d(ji) = qns_ice_1d(ji) - zhfx_err(ji) 
    757             fc_su     (ji) = fc_su(ji)      - zhfx_err(ji) 
    758          END DO 
    759          ! 
    760       ELSE                      ! --- coupled case: ocean turbulent heat flux is diagnosed 
    761          ! 
    762          DO ji = kideb, kiut 
    763             fhtur_1d  (ji) = fhtur_1d(ji)   - zhfx_err(ji) 
    764          END DO 
    765          ! 
    766       ENDIF 
    767  
    768       ! --- compute diagnostic net heat flux at the surface of the snow-ice system (W.m2) 
    769       DO ji = kideb, kiut 
    770          ii = MOD( npb(ji) - 1, jpi ) + 1 ; ij = ( npb(ji) - 1 ) / jpi + 1 
    771          hfx_in (ii,ij) = hfx_in (ii,ij) + a_i_1d(ji) * ( qsr_ice_1d(ji) + qns_ice_1d(ji) ) 
    772       END DO 
    773     
     790         ! correction on the diagnosed heat flux due to non-convergence of the algorithm used to solve heat equation 
     791         hfx_dif_1d(ji) = hfx_dif_1d(ji) - zhfx_err(ji) * a_i_1d(ji) 
     792      END DO    
    774793      ! 
    775       CALL wrk_dealloc( jpij, numeqmin, numeqmax, isnow ) 
    776       CALL wrk_dealloc( jpij, ztfs, ztsub, ztsubit, zh_i, zh_s, zfsw ) 
    777       CALL wrk_dealloc( jpij, zf, dzf, zerrit, zdifcase, zftrice, zihic, zhsu ) 
    778       CALL wrk_dealloc( jpij, nlay_i+1, ztcond_i, zradtr_i, zradab_i, zkappa_i,   & 
    779          &              ztib, zeta_i, ztitemp, z_i, zspeche_i, kjstart = 0 ) 
    780       CALL wrk_dealloc( jpij, nlay_s+1,           zradtr_s, zradab_s, zkappa_s, ztsb, zeta_s, ztstemp, z_s, kjstart = 0 ) 
    781       CALL wrk_dealloc( jpij, nlay_i+3, zswiterm, zswitbis, zdiagbis ) 
    782       CALL wrk_dealloc( jpij, nlay_i+3, 3, ztrid ) 
     794      CALL wrk_dealloc( jpij, numeqmin, numeqmax ) 
     795      CALL wrk_dealloc( jpij, isnow, ztsub, ztsubit, zh_i, zh_s, zfsw ) 
     796      CALL wrk_dealloc( jpij, zf, dzf, zerrit, zdifcase, zftrice, zihic, zghe ) 
     797      CALL wrk_dealloc( jpij,nlay_i+1, ztcond_i, zradtr_i, zradab_i, zkappa_i, ztib, zeta_i, ztitemp, z_i, zspeche_i, kjstart = 0 ) 
     798      CALL wrk_dealloc( jpij,nlay_s+1,           zradtr_s, zradab_s, zkappa_s, ztsb, zeta_s, ztstemp, z_s, kjstart = 0 ) 
     799      CALL wrk_dealloc( jpij,nlay_i+3, zindterm, zindtbis, zdiagbis ) 
     800      CALL wrk_dealloc( jpij,nlay_i+3,3, ztrid ) 
    783801      CALL wrk_dealloc( jpij, zdq, zq_ini, zhfx_err ) 
    784802 
    … …  
    801819      DO jk = 1, nlay_i             ! Sea ice energy of melting 
    802820         DO ji = kideb, kiut 
    803             ztmelts      = - tmut  * s_i_1d(ji,jk) + rtt  
    804             rswitch      = MAX( 0._wp , SIGN( 1._wp , -(t_i_1d(ji,jk) - rtt) - epsi10 ) ) 
    805             q_i_1d(ji,jk) = rhoic * ( cpic * ( ztmelts - t_i_1d(ji,jk) )                                             & 
    806                &                   + lfus * ( 1.0 - rswitch * ( ztmelts-rtt ) / MIN( t_i_1d(ji,jk)-rtt, -epsi10 ) )   & 
    807                &                   - rcp  *                 ( ztmelts-rtt )  )  
     821            ztmelts      = - tmut  * s_i_1d(ji,jk) + rt0 
     822            t_i_1d(ji,jk) = MIN( t_i_1d(ji,jk), ztmelts ) ! Force t_i_1d to be lower than melting point 
     823                                                          !   (sometimes dif scheme produces abnormally high temperatures)    
     824            q_i_1d(ji,jk) = rhoic * ( cpic * ( ztmelts - t_i_1d(ji,jk) )                           & 
     825               &                    + lfus * ( 1.0 - ( ztmelts-rt0 ) / ( t_i_1d(ji,jk) - rt0 ) )   & 
     826               &                    - rcp  *         ( ztmelts-rt0 )  )  
    808827         END DO 
    809828      END DO 
    810829      DO jk = 1, nlay_s             ! Snow energy of melting 
    811830         DO ji = kideb, kiut 
    812             q_s_1d(ji,jk) = rhosn * ( cpic * ( rtt - t_s_1d(ji,jk) ) + lfus ) 
     831            q_s_1d(ji,jk) = rhosn * ( cpic * ( rt0 - t_s_1d(ji,jk) ) + lfus ) 
    813832         END DO 
    814833      END DO 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/LIM_SRC_3/limthd_ent.F90

    r5312 r5313  
    2525   USE sbc_oce        ! Surface boundary condition: ocean fields 
    2626   USE ice            ! LIM variables 
    27    USE par_ice        ! LIM parameters 
    2827   USE thd_ice        ! LIM thermodynamics 
    2928   USE limvar         ! LIM variables 
    … …  
    8786 
    8887      !-------------------------------------------------------------------------- 
    89       !  1) Cumulative integral of old enthalpy * thicnkess and layers interfaces 
     88      !  1) Cumulative integral of old enthalpy * thickness and layers interfaces 
    9089      !-------------------------------------------------------------------------- 
    9190      zqh_cum0(:,0:nlay_i+2) = 0._wp  
    … …  
    103102      ! new layer thickesses 
    104103      DO ji = kideb, kiut 
    105          zhnew(ji) = SUM( h_i_old(ji,0:nlay_i+1) ) / REAL( nlay_i )   
     104         zhnew(ji) = SUM( h_i_old(ji,0:nlay_i+1) ) * r1_nlay_i   
    106105      ENDDO 
    107106 
    … …  
    133132      DO jk1 = 1, nlay_i 
    134133         DO ji = kideb, kiut 
    135             rswitch      = 1._wp - MAX( 0._wp , SIGN( 1._wp , - zhnew(ji) + epsi10 ) )  
    136             qnew(ji,jk1) = rswitch * ( zqh_cum1(ji,jk1) - zqh_cum1(ji,jk1-1) ) / MAX( zhnew(ji), epsi10 ) 
     134            rswitch      = MAX( 0._wp , SIGN( 1._wp , zhnew(ji) - epsi20 ) )  
     135            qnew(ji,jk1) = rswitch * ( zqh_cum1(ji,jk1) - zqh_cum1(ji,jk1-1) ) / MAX( zhnew(ji), epsi20 ) 
    137136         ENDDO 
    138137      ENDDO 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/LIM_SRC_3/limthd_lac.F90

    r5312 r5313  
    2222   USE thd_ice        ! LIM thermodynamics 
    2323   USE dom_ice        ! LIM domain 
    24    USE par_ice        ! LIM parameters 
    2524   USE ice            ! LIM variables 
    2625   USE limtab         ! LIM 2D <==> 1D 
    … …  
    3231   USE lib_fortran    ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined)   
    3332   USE limthd_ent 
     33   USE limvar 
    3434 
    3535   IMPLICIT NONE 
    … …  
    106106      REAL(wp), POINTER, DIMENSION(:,:) ::   za_i_1d   ! 1-D version of a_i 
    107107      REAL(wp), POINTER, DIMENSION(:,:) ::   zv_i_1d   ! 1-D version of v_i 
    108       REAL(wp), POINTER, DIMENSION(:,:) ::   zoa_i_1d  ! 1-D version of oa_i 
    109108      REAL(wp), POINTER, DIMENSION(:,:) ::   zsmv_i_1d ! 1-D version of smv_i 
    110109 
    … …  
    112111 
    113112      REAL(wp), POINTER, DIMENSION(:,:) ::   zvrel                   ! relative ice / frazil velocity 
     113 
     114      REAL(wp) :: zcai = 1.4e-3_wp 
    114115      !!-----------------------------------------------------------------------! 
    115116 
    … …  
    117118      CALL wrk_alloc( jpij, zswinew, zv_newice, za_newice, zh_newice, ze_newice, zs_newice, zo_newice ) 
    118119      CALL wrk_alloc( jpij, zdv_res, zda_res, zat_i_1d, zv_frazb, zvrel_1d ) 
    119       CALL wrk_alloc( jpij,jpl, zv_b, za_b, za_i_1d, zv_i_1d, zoa_i_1d, zsmv_i_1d ) 
    120       CALL wrk_alloc( jpij,nlay_i+1,jpl, ze_i_1d ) 
     120      CALL wrk_alloc( jpij,jpl, zv_b, za_b, za_i_1d, zv_i_1d, zsmv_i_1d ) 
     121      CALL wrk_alloc( jpij,nlay_i,jpl, ze_i_1d ) 
    121122      CALL wrk_alloc( jpi,jpj, zvrel ) 
    122123 
     124      CALL lim_var_agg(1) 
     125      CALL lim_var_glo2eqv 
    123126      !------------------------------------------------------------------------------| 
    124127      ! 2) Convert units for ice internal energy 
    … …  
    129132               DO ji = 1, jpi 
    130133                  !Energy of melting q(S,T) [J.m-3] 
    131                   rswitch          = 1._wp - MAX(  0._wp , SIGN( 1._wp , -v_i(ji,jj,jl) + epsi10 )  )   !0 if no ice and 1 if yes 
    132                   e_i(ji,jj,jk,jl) = rswitch * e_i(ji,jj,jk,jl) & 
    133                       &   / ( area(ji,jj) * MAX( v_i(ji,jj,jl) ,  epsi10 ) ) * REAL( nlay_i, wp ) 
    134                   e_i(ji,jj,jk,jl) = e_i(ji,jj,jk,jl) * unit_fac 
     134                  rswitch          = MAX(  0._wp , SIGN( 1._wp , v_i(ji,jj,jl) - epsi20 )  )   !0 if no ice 
     135                  e_i(ji,jj,jk,jl) = rswitch * e_i(ji,jj,jk,jl) / MAX( v_i(ji,jj,jl), epsi20 ) * REAL( nlay_i, wp ) 
    135136               END DO 
    136137            END DO 
    … …  
    155156 
    156157      ! Default new ice thickness  
    157       hicol(:,:) = hiccrit 
    158  
    159       IF( fraz_swi == 1 ) THEN 
     158      hicol(:,:) = rn_hnewice 
     159 
     160      IF( ln_frazil ) THEN 
    160161 
    161162         !-------------------- 
    … …  
    166167         zhicrit = 0.04 ! frazil ice thickness 
    167168         ztwogp  = 2. * rau0 / ( grav * 0.3 * ( rau0 - rhoic ) ) ! reduced grav 
    168          zsqcd   = 1.0 / SQRT( 1.3 * cai ) ! 1/SQRT(airdensity*drag) 
     169         zsqcd   = 1.0 / SQRT( 1.3 * zcai ) ! 1/SQRT(airdensity*drag) 
    169170         zgamafr = 0.03 
    170171 
    … …  
    176177                  !------------- 
    177178                  ! C-grid wind stress components 
    178                   ztaux         = ( utau_ice(ji-1,jj  ) * tmu(ji-1,jj  )   & 
    179                      &          +   utau_ice(ji  ,jj  ) * tmu(ji  ,jj  ) ) * 0.5_wp 
    180                   ztauy         = ( vtau_ice(ji  ,jj-1) * tmv(ji  ,jj-1)   & 
    181                      &          +   vtau_ice(ji  ,jj  ) * tmv(ji  ,jj  ) ) * 0.5_wp 
     179                  ztaux         = ( utau_ice(ji-1,jj  ) * umask(ji-1,jj  ,1)   & 
     180                     &          +   utau_ice(ji  ,jj  ) * umask(ji  ,jj  ,1) ) * 0.5_wp 
     181                  ztauy         = ( vtau_ice(ji  ,jj-1) * vmask(ji  ,jj-1,1)   & 
     182                     &          +   vtau_ice(ji  ,jj  ) * vmask(ji  ,jj  ,1) ) * 0.5_wp 
    182183                  ! Square root of wind stress 
    183184                  ztenagm       =  SQRT( SQRT( ztaux**2 + ztauy**2 ) ) 
    … …  
    195196                  ! C-grid ice velocity 
    196197                  rswitch = MAX(  0._wp, SIGN( 1._wp , at_i(ji,jj) )  ) 
    197                   zvgx    = rswitch * ( u_ice(ji-1,jj  ) * tmu(ji-1,jj  )  + u_ice(ji,jj) * tmu(ji,jj) ) * 0.5_wp 
    198                   zvgy    = rswitch * ( v_ice(ji  ,jj-1) * tmv(ji  ,jj-1)  + v_ice(ji,jj) * tmv(ji,jj) ) * 0.5_wp 
     198                  zvgx    = rswitch * ( u_ice(ji-1,jj  ) * umask(ji-1,jj  ,1)  + u_ice(ji,jj) * umask(ji,jj,1) ) * 0.5_wp 
     199                  zvgy    = rswitch * ( v_ice(ji  ,jj-1) * vmask(ji  ,jj-1,1)  + v_ice(ji,jj) * vmask(ji,jj,1) ) * 0.5_wp 
    199200 
    200201                  !----------------------------------- 
    … …  
    222223                  iterate_frazil = .true. 
    223224 
    224                   DO WHILE ( iter .LT. 100 .AND. iterate_frazil )  
     225                  DO WHILE ( iter < 100 .AND. iterate_frazil )  
    225226                     zf = ( hicol(ji,jj) - zhicrit ) * ( hicol(ji,jj)**2 - zhicrit**2 ) & 
    226227                        - hicol(ji,jj) * zhicrit * ztwogp * zvrel2 
    … …  
    266267      ! debug point to follow 
    267268      jiindex_1d = 0 
    268       IF( ln_nicep ) THEN 
    269          DO ji = mi0(jiindx), mi1(jiindx) 
    270             DO jj = mj0(jjindx), mj1(jjindx) 
     269      IF( ln_icectl ) THEN 
     270         DO ji = mi0(iiceprt), mi1(iiceprt) 
     271            DO jj = mj0(jiceprt), mj1(jiceprt) 
    271272               IF ( qlead(ji,jj)  <  0._wp ) THEN 
    272273                  jiindex_1d = (jj - 1) * jpi + ji 
    … …  
    276277      ENDIF 
    277278    
    278       IF( ln_nicep ) WRITE(numout,*) 'lim_thd_lac : nbpac = ', nbpac 
     279      IF( ln_icectl ) WRITE(numout,*) 'lim_thd_lac : nbpac = ', nbpac 
    279280 
    280281      !------------------------------ 
    … …  
    290291            CALL tab_2d_1d( nbpac, za_i_1d  (1:nbpac,jl), a_i  (:,:,jl), jpi, jpj, npac(1:nbpac) ) 
    291292            CALL tab_2d_1d( nbpac, zv_i_1d  (1:nbpac,jl), v_i  (:,:,jl), jpi, jpj, npac(1:nbpac) ) 
    292             CALL tab_2d_1d( nbpac, zoa_i_1d (1:nbpac,jl), oa_i (:,:,jl), jpi, jpj, npac(1:nbpac) ) 
    293293            CALL tab_2d_1d( nbpac, zsmv_i_1d(1:nbpac,jl), smv_i(:,:,jl), jpi, jpj, npac(1:nbpac) ) 
    294294            DO jk = 1, nlay_i 
    295295               CALL tab_2d_1d( nbpac, ze_i_1d(1:nbpac,jk,jl), e_i(:,:,jk,jl) , jpi, jpj, npac(1:nbpac) ) 
    296             END DO ! jk 
    297          END DO ! jl 
     296            END DO 
     297         END DO 
    298298 
    299299         CALL tab_2d_1d( nbpac, qlead_1d  (1:nbpac)     , qlead  , jpi, jpj, npac(1:nbpac) ) 
    … …  
    320320         !---------------------- 
    321321         DO ji = 1, nbpac 
    322             zh_newice(ji) = hiccrit 
    323          END DO 
    324          IF( fraz_swi == 1 ) zh_newice(1:nbpac) = hicol_1d(1:nbpac) 
     322            zh_newice(ji) = rn_hnewice 
     323         END DO 
     324         IF( ln_frazil ) zh_newice(1:nbpac) = hicol_1d(1:nbpac) 
    325325 
    326326         !---------------------- 
    327327         ! Salinity of new ice  
    328328         !---------------------- 
    329          SELECT CASE ( num_sal ) 
     329         SELECT CASE ( nn_icesal ) 
    330330         CASE ( 1 )                    ! Sice = constant  
    331             zs_newice(1:nbpac) = bulk_sal 
     331            zs_newice(1:nbpac) = rn_icesal 
    332332         CASE ( 2 )                    ! Sice = F(z,t) [Vancoppenolle et al (2005)] 
    333333            DO ji = 1, nbpac 
    334334               ii =   MOD( npac(ji) - 1 , jpi ) + 1 
    335335               ij =      ( npac(ji) - 1 ) / jpi + 1 
    336                zs_newice(ji) = MIN(  4.606 + 0.91 / zh_newice(ji) , s_i_max , 0.5 * sss_m(ii,ij)  ) 
     336               zs_newice(ji) = MIN(  4.606 + 0.91 / zh_newice(ji) , rn_simax , 0.5 * sss_m(ii,ij)  ) 
    337337            END DO 
    338338         CASE ( 3 )                    ! Sice = F(z) [multiyear ice] 
    … …  
    345345         ! We assume that new ice is formed at the seawater freezing point 
    346346         DO ji = 1, nbpac 
    347             ztmelts       = - tmut * zs_newice(ji) + rtt                  ! Melting point (K) 
     347            ztmelts       = - tmut * zs_newice(ji) + rt0                  ! Melting point (K) 
    348348            ze_newice(ji) =   rhoic * (  cpic * ( ztmelts - t_bo_1d(ji) )                             & 
    349                &                       + lfus * ( 1.0 - ( ztmelts - rtt ) / MIN( t_bo_1d(ji) - rtt, -epsi10 ) )   & 
    350                &                       - rcp  *         ( ztmelts - rtt )  ) 
    351          END DO ! ji 
     349               &                       + lfus * ( 1.0 - ( ztmelts - rt0 ) / MIN( t_bo_1d(ji) - rt0, -epsi10 ) )   & 
     350               &                       - rcp  *         ( ztmelts - rt0 )  ) 
     351         END DO 
    352352 
    353353         !---------------- 
    … …  
    356356         DO ji = 1, nbpac 
    357357            zo_newice(ji) = 0._wp 
    358          END DO ! ji 
     358         END DO 
    359359 
    360360         !------------------- 
    … …  
    363363         DO ji = 1, nbpac 
    364364 
    365             zEi           = - ze_newice(ji) / rhoic                ! specific enthalpy of forming ice [J/kg] 
    366  
    367             zEw           = rcp * ( t_bo_1d(ji) - rt0 )             ! specific enthalpy of seawater at t_bo_1d [J/kg] 
     365            zEi           = - ze_newice(ji) * r1_rhoic             ! specific enthalpy of forming ice [J/kg] 
     366 
     367            zEw           = rcp * ( t_bo_1d(ji) - rt0 )            ! specific enthalpy of seawater at t_bo_1d [J/kg] 
    368368                                                                   ! clem: we suppose we are already at the freezing point (condition qlead<0 is satisfyied)  
    369369                                                                    
    … …  
    372372            zfmdt         = - qlead_1d(ji) / zdE                   ! Fm.dt [kg/m2] (<0)  
    373373                                                                   ! clem: we use qlead instead of zqld (limthd) because we suppose we are at the freezing point    
    374             zv_newice(ji) = - zfmdt / rhoic 
     374            zv_newice(ji) = - zfmdt * r1_rhoic 
    375375 
    376376            zQm           = zfmdt * zEw                            ! heat to the ocean >0 associated with mass flux   
    … …  
    387387            ! A fraction zfrazb of frazil ice is accreted at the ice bottom 
    388388            rswitch       = 1._wp - MAX( 0._wp, SIGN( 1._wp , - zat_i_1d(ji) ) ) 
    389             zfrazb        = rswitch * ( TANH ( Cfrazb * ( zvrel_1d(ji) - vfrazb ) ) + 1.0 ) * 0.5 * maxfrazb 
     389            zfrazb        = rswitch * ( TANH ( rn_Cfrazb * ( zvrel_1d(ji) - rn_vfrazb ) ) + 1.0 ) * 0.5 * rn_maxfrazb 
    390390            zv_frazb(ji)  =         zfrazb   * zv_newice(ji) 
    391391            zv_newice(ji) = ( 1.0 - zfrazb ) * zv_newice(ji) 
    … …  
    409409         ! we keep the excessive volume in memory and attribute it later to bottom accretion 
    410410         DO ji = 1, nbpac 
    411             IF ( za_newice(ji) >  ( amax - zat_i_1d(ji) ) ) THEN 
    412                zda_res(ji)   = za_newice(ji) - ( amax - zat_i_1d(ji) ) 
     411            IF ( za_newice(ji) >  ( rn_amax - zat_i_1d(ji) ) ) THEN 
     412               zda_res(ji)   = za_newice(ji) - ( rn_amax - zat_i_1d(ji) ) 
    413413               zdv_res(ji)   = zda_res  (ji) * zh_newice(ji)  
    414414               za_newice(ji) = za_newice(ji) - zda_res  (ji) 
    … …  
    459459            DO jk = 1, nlay_i 
    460460               DO ji = 1, nbpac 
    461                   h_i_old (ji,jk) = zv_i_1d(ji,jl) / REAL( nlay_i ) 
     461                  h_i_old (ji,jk) = zv_i_1d(ji,jl) * r1_nlay_i 
    462462                  qh_i_old(ji,jk) = ze_i_1d(ji,jk,jl) * h_i_old(ji,jk) 
    463463               END DO 
    … …  
    478478         ENDDO 
    479479 
    480          !------------ 
    481          ! Update age  
    482          !------------ 
    483          DO jl = 1, jpl 
    484             DO ji = 1, nbpac 
    485                rswitch          = 1._wp - MAX( 0._wp , SIGN( 1._wp , - za_i_1d(ji,jl) + epsi20 ) )  ! 0 if no ice and 1 if yes 
    486                zoa_i_1d(ji,jl)  = za_b(ji,jl) * zoa_i_1d(ji,jl) / MAX( za_i_1d(ji,jl) , epsi20 ) * rswitch    
    487             END DO  
    488          END DO    
    489  
    490480         !----------------- 
    491481         ! Update salinity 
    … …  
    504494            CALL tab_1d_2d( nbpac, a_i (:,:,jl), npac(1:nbpac), za_i_1d (1:nbpac,jl), jpi, jpj ) 
    505495            CALL tab_1d_2d( nbpac, v_i (:,:,jl), npac(1:nbpac), zv_i_1d (1:nbpac,jl), jpi, jpj ) 
    506             CALL tab_1d_2d( nbpac, oa_i(:,:,jl), npac(1:nbpac), zoa_i_1d(1:nbpac,jl), jpi, jpj ) 
    507496            CALL tab_1d_2d( nbpac, smv_i (:,:,jl), npac(1:nbpac), zsmv_i_1d(1:nbpac,jl) , jpi, jpj ) 
    508497            DO jk = 1, nlay_i 
    … …  
    525514            DO jj = 1, jpj 
    526515               DO ji = 1, jpi 
    527                   ! heat content in Joules 
    528                   e_i(ji,jj,jk,jl) = e_i(ji,jj,jk,jl) * area(ji,jj) * v_i(ji,jj,jl) / ( REAL( nlay_i ,wp ) * unit_fac )  
     516                  ! heat content in J/m2 
     517                  e_i(ji,jj,jk,jl) = e_i(ji,jj,jk,jl) * v_i(ji,jj,jl) * r1_nlay_i  
    529518               END DO 
    530519            END DO 
    … …  
    536525      CALL wrk_dealloc( jpij, zswinew, zv_newice, za_newice, zh_newice, ze_newice, zs_newice, zo_newice ) 
    537526      CALL wrk_dealloc( jpij, zdv_res, zda_res, zat_i_1d, zv_frazb, zvrel_1d ) 
    538       CALL wrk_dealloc( jpij,jpl, zv_b, za_b, za_i_1d, zv_i_1d, zoa_i_1d, zsmv_i_1d ) 
    539       CALL wrk_dealloc( jpij,nlay_i+1,jpl, ze_i_1d ) 
     527      CALL wrk_dealloc( jpij,jpl, zv_b, za_b, za_i_1d, zv_i_1d, zsmv_i_1d ) 
     528      CALL wrk_dealloc( jpij,nlay_i,jpl, ze_i_1d ) 
    540529      CALL wrk_dealloc( jpi,jpj, zvrel ) 
    541530      ! 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/LIM_SRC_3/limthd_sal.F90

    r5312 r5313  
    1818   USE sbc_oce        ! Surface boundary condition: ocean fields 
    1919   USE ice            ! LIM variables 
    20    USE par_ice        ! LIM parameters 
    2120   USE thd_ice        ! LIM thermodynamics 
    2221   USE limvar         ! LIM variables 
    … …  
    3029 
    3130   PUBLIC   lim_thd_sal        ! called by limthd module 
    32    PUBLIC   lim_thd_sal_init   ! called by iceini module 
     31   PUBLIC   lim_thd_sal_init   ! called by sbc_lim_init 
    3332 
    3433   !!---------------------------------------------------------------------- 
    … …  
    4645      !! 
    4746      !! ** Method  :  3 possibilities 
    48       !!               -> num_sal = 1 -> Sice = cst    [ice salinity constant in both time & space]  
    49       !!               -> num_sal = 2 -> Sice = S(z,t) [Vancoppenolle et al. 2005] 
    50       !!               -> num_sal = 3 -> Sice = S(z)   [multiyear ice] 
     47      !!               -> nn_icesal = 1 -> Sice = cst    [ice salinity constant in both time & space]  
     48      !!               -> nn_icesal = 2 -> Sice = S(z,t) [Vancoppenolle et al. 2005] 
     49      !!               -> nn_icesal = 3 -> Sice = S(z)   [multiyear ice] 
    5150      !!--------------------------------------------------------------------- 
    5251      INTEGER, INTENT(in) ::   kideb, kiut   ! thickness category index 
    … …  
    6665      ! 1) Constant salinity, constant in time                                       | 
    6766      !------------------------------------------------------------------------------| 
    68 !!gm comment: if num_sal = 1 s_i_new, s_i_1d and sm_i_1d can be set to bulk_sal one for all in the initialisation phase !! 
    69 !!gm           ===>>>   simplification of almost all test on num_sal value 
    70       IF(  num_sal == 1  ) THEN 
    71             s_i_1d (kideb:kiut,1:nlay_i) =  bulk_sal 
    72             sm_i_1d(kideb:kiut)          =  bulk_sal  
    73             s_i_new(kideb:kiut)          =  bulk_sal 
     67!!gm comment: if nn_icesal = 1 s_i_new, s_i_1d and sm_i_1d can be set to rn_icesal one for all in the initialisation phase !! 
     68!!gm           ===>>>   simplification of almost all test on nn_icesal value 
     69      IF(  nn_icesal == 1  ) THEN 
     70            s_i_1d (kideb:kiut,1:nlay_i) =  rn_icesal 
     71            sm_i_1d(kideb:kiut)          =  rn_icesal  
     72            s_i_new(kideb:kiut)          =  rn_icesal 
    7473      ENDIF 
    7574 
    … …  
    7776      !  Module 2 : Constant salinity varying in time                                | 
    7877      !------------------------------------------------------------------------------| 
    79       IF(  num_sal == 2  ) THEN 
     78      IF(  nn_icesal == 2  ) THEN 
    8079 
    8180         DO ji = kideb, kiut 
    … …  
    8382            ! Switches  
    8483            !---------- 
    85             iflush  = MAX( 0._wp , SIGN( 1._wp , t_su_1d(ji) - rtt )        )     ! =1 if summer  
     84            iflush  = MAX( 0._wp , SIGN( 1._wp , t_su_1d(ji) - rt0 )        )     ! =1 if summer  
    8685            igravdr = MAX( 0._wp , SIGN( 1._wp , t_bo_1d(ji) - t_su_1d(ji) ) )    ! =1 if t_su < t_bo 
    8786 
    … …  
    9089            !--------------------- 
    9190            ! drainage by gravity drainage 
    92             dsm_i_gd_1d(ji) = - igravdr * MAX( sm_i_1d(ji) - sal_G , 0._wp ) / time_G * rdt_ice  
     91            dsm_i_gd_1d(ji) = - igravdr * MAX( sm_i_1d(ji) - rn_sal_gd , 0._wp ) / rn_time_gd * rdt_ice  
    9392            ! drainage by flushing   
    94             dsm_i_fl_1d(ji) = - iflush  * MAX( sm_i_1d(ji) - sal_F , 0._wp ) / time_F * rdt_ice 
     93            dsm_i_fl_1d(ji) = - iflush  * MAX( sm_i_1d(ji) - rn_sal_fl , 0._wp ) / rn_time_fl * rdt_ice 
    9594 
    9695            !----------------- 
    … …  
    116115      !  Module 3 : Profile of salinity, constant in time                            | 
    117116      !------------------------------------------------------------------------------| 
    118       IF(  num_sal == 3  )   CALL lim_var_salprof1d( kideb, kiut ) 
     117      IF(  nn_icesal == 3  )   CALL lim_var_salprof1d( kideb, kiut ) 
    119118 
    120119      ! 
    … …  
    134133      !!------------------------------------------------------------------- 
    135134      INTEGER  ::   ios                 ! Local integer output status for namelist read 
    136       NAMELIST/namicesal/ num_sal, bulk_sal, sal_G, time_G, sal_F, time_F,   & 
    137          &                s_i_max, s_i_min, s_i_0, s_i_1 
     135      NAMELIST/namicesal/ nn_icesal, rn_icesal, rn_sal_gd, rn_time_gd, rn_sal_fl, rn_time_fl,   & 
     136         &                rn_simax, rn_simin  
    138137      !!------------------------------------------------------------------- 
    139138      ! 
    … …  
    151150         WRITE(numout,*) 'lim_thd_sal_init : Ice parameters for salinity ' 
    152151         WRITE(numout,*) '~~~~~~~~~~~~~~~~' 
    153          WRITE(numout,*) ' switch for salinity num_sal        : ', num_sal 
    154          WRITE(numout,*) ' bulk salinity value if num_sal = 1 : ', bulk_sal 
    155          WRITE(numout,*) ' restoring salinity for GD          : ', sal_G 
    156          WRITE(numout,*) ' restoring time for GD              : ', time_G 
    157          WRITE(numout,*) ' restoring salinity for flushing    : ', sal_F 
    158          WRITE(numout,*) ' restoring time for flushing        : ', time_F 
    159          WRITE(numout,*) ' Maximum tolerated ice salinity     : ', s_i_max 
    160          WRITE(numout,*) ' Minimum tolerated ice salinity     : ', s_i_min 
    161          WRITE(numout,*) ' 1st salinity for salinity profile  : ', s_i_0 
    162          WRITE(numout,*) ' 2nd salinity for salinity profile  : ', s_i_1 
     152         WRITE(numout,*) '   switch for salinity nn_icesal        = ', nn_icesal 
     153         WRITE(numout,*) '   bulk salinity value if nn_icesal = 1 = ', rn_icesal 
     154         WRITE(numout,*) '   restoring salinity for GD            = ', rn_sal_gd 
     155         WRITE(numout,*) '   restoring time for GD                = ', rn_time_gd 
     156         WRITE(numout,*) '   restoring salinity for flushing      = ', rn_sal_fl 
     157         WRITE(numout,*) '   restoring time for flushing          = ', rn_time_fl 
     158         WRITE(numout,*) '   Maximum tolerated ice salinity       = ', rn_simax 
     159         WRITE(numout,*) '   Minimum tolerated ice salinity       = ', rn_simin 
    163160      ENDIF 
    164161      ! 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/LIM_SRC_3/limtrp.F90

    r5312 r5313  
    1717   USE dom_oce        ! ocean domain 
    1818   USE sbc_oce        ! ocean surface boundary condition 
    19    USE par_ice        ! ice parameter 
    2019   USE dom_ice        ! ice domain 
    2120   USE ice            ! ice variables 
    2221   USE limadv         ! ice advection 
    2322   USE limhdf         ! ice horizontal diffusion 
     23   USE limvar         !  
     24   ! 
    2425   USE in_out_manager ! I/O manager 
    2526   USE lbclnk         ! lateral boundary conditions -- MPP exchanges 
    … …  
    2829   USE prtctl         ! Print control 
    2930   USE lib_fortran    ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined)   
    30    USE limvar          ! clem for ice thickness correction 
    31    USE timing          ! Timing 
     31   USE timing         ! Timing 
    3232   USE limcons        ! conservation tests 
     33   USE limctl         ! control prints 
    3334 
    3435   IMPLICIT NONE 
    3536   PRIVATE 
    3637 
    37    PUBLIC   lim_trp    ! called by ice_step 
     38   PUBLIC   lim_trp    ! called by sbcice_lim 
     39 
     40   INTEGER  ::   ncfl                 ! number of ice time step with CFL>1/2   
    3841 
    3942   !! * Substitution 
    … …  
    5861      !! ** action : 
    5962      !!--------------------------------------------------------------------- 
    60       INTEGER, INTENT(in) ::   kt   ! number of iteration 
     63      INTEGER, INTENT(in) ::   kt           ! number of iteration 
    6164      ! 
    62       INTEGER  ::   ji, jj, jk, jl, jn      ! dummy loop indices 
     65      INTEGER  ::   ji, jj, jk, jl, jt      ! dummy loop indices 
    6366      INTEGER  ::   initad                  ! number of sub-timestep for the advection 
    6467      REAL(wp) ::   zcfl , zusnit           !   -      - 
     68      CHARACTER(len=80) ::   cltmp 
    6569      ! 
    66       REAL(wp), POINTER, DIMENSION(:,:)      ::   zui_u, zvi_v, zsm, zs0at, zs0ow 
    67       REAL(wp), POINTER, DIMENSION(:,:,:)    ::   zs0ice, zs0sn, zs0a, zs0c0 , zs0sm , zs0oi 
    68       REAL(wp), POINTER, DIMENSION(:,:,:,:)  ::   zs0e 
    69       REAL(wp), POINTER, DIMENSION(:,:,:)    ::   zviold, zvsold   ! old ice volume... 
    70       REAL(wp), POINTER, DIMENSION(:,:,:)    ::   zaiold, zhimax   ! old ice concentration and thickness 
    71       REAL(wp), POINTER, DIMENSION(:,:)      ::   zeiold, zesold   ! old enthalpies 
    72       REAL(wp) :: zdv, zda, zvi, zvs, zsmv, zes, zei 
    73       ! 
    74       REAL(wp) :: zvi_b, zsmv_b, zei_b, zfs_b, zfw_b, zft_b  
     70      REAL(wp), POINTER, DIMENSION(:,:)      ::   zsm 
     71      REAL(wp), POINTER, DIMENSION(:,:,:)    ::   z0ice, z0snw, z0ai, z0es , z0smi , z0oi 
     72      REAL(wp), POINTER, DIMENSION(:,:,:)    ::   z0opw 
     73      REAL(wp), POINTER, DIMENSION(:,:,:,:)  ::   z0ei 
     74      REAL(wp), POINTER, DIMENSION(:,:,:)    ::   zviold, zvsold, zsmvold  ! old ice volume... 
     75      REAL(wp), POINTER, DIMENSION(:,:,:)    ::   zhimax                   ! old ice thickness 
     76      REAL(wp), POINTER, DIMENSION(:,:)      ::   zatold, zeiold, zesold   ! old concentration, enthalpies 
     77      REAL(wp) ::    zdv, zvi, zvs, zsmv, zes, zei 
     78      REAL(wp) ::    zvi_b, zsmv_b, zei_b, zfs_b, zfw_b, zft_b 
    7579      !!--------------------------------------------------------------------- 
    7680      IF( nn_timing == 1 )  CALL timing_start('limtrp') 
    7781 
    78       CALL wrk_alloc( jpi, jpj, zui_u, zvi_v, zsm, zs0at, zs0ow, zeiold, zesold ) 
    79       CALL wrk_alloc( jpi, jpj, jpl, zs0ice, zs0sn, zs0a, zs0c0 , zs0sm , zs0oi ) 
    80       CALL wrk_alloc( jpi, jpj, nlay_i+1, jpl, zs0e ) 
    81  
    82       CALL wrk_alloc( jpi, jpj, jpl, zaiold, zhimax, zviold, zvsold )   ! clem 
     82      CALL wrk_alloc( jpi,jpj,            zsm, zatold, zeiold, zesold ) 
     83      CALL wrk_alloc( jpi,jpj,jpl,        z0ice, z0snw, z0ai, z0es , z0smi , z0oi ) 
     84      CALL wrk_alloc( jpi,jpj,1,          z0opw ) 
     85      CALL wrk_alloc( jpi,jpj,nlay_i,jpl, z0ei ) 
     86      CALL wrk_alloc( jpi,jpj,jpl,        zhimax, zviold, zvsold, zsmvold ) 
    8387 
    8488      IF( numit == nstart .AND. lwp ) THEN 
    … …  
    8892         ENDIF 
    8993         WRITE(numout,*) '~~~~~~~~~~~~' 
     94         ncfl = 0                ! nb of time step with CFL > 1/2 
    9095      ENDIF 
     96 
     97      zsm(:,:) = e12t(:,:) 
    9198       
    92       zsm(:,:) = area(:,:) 
    93  
    9499      !                             !-------------------------------------! 
    95100      IF( ln_limdyn ) THEN          !   Advection of sea ice properties   ! 
    … …  
    97102 
    98103         ! conservation test 
    99          IF( ln_limdiahsb ) CALL lim_cons_hsm(0, 'limtrp', zvi_b, zsmv_b, zei_b, zfw_b, zfs_b, zft_b) 
    100  
    101          ! mass and salt flux init (clem) 
     104         IF( ln_limdiahsb )   CALL lim_cons_hsm(0, 'limtrp', zvi_b, zsmv_b, zei_b, zfw_b, zfs_b, zft_b) 
     105 
     106         ! mass and salt flux init 
    102107         zviold(:,:,:)  = v_i(:,:,:) 
    103          zeiold(:,:)  = SUM( SUM( e_i(:,:,1:nlay_i,:), dim=4 ), dim=3 )  
    104          zesold(:,:)  = SUM( SUM( e_s(:,:,1:nlay_s,:), dim=4 ), dim=3 )  
    105  
    106          !--- Thickness correction init. (clem) ------------------------------- 
    107          CALL lim_var_glo2eqv 
    108          zaiold(:,:,:) = a_i(:,:,:) 
     108         zvsold(:,:,:)  = v_s(:,:,:) 
     109         zsmvold(:,:,:) = smv_i(:,:,:) 
     110         zeiold(:,:)    = SUM( SUM( e_i(:,:,1:nlay_i,:), dim=4 ), dim=3 )  
     111         zesold(:,:)    = SUM( SUM( e_s(:,:,1:nlay_s,:), dim=4 ), dim=3 )  
     112 
     113         !--- Thickness correction init. ------------------------------- 
     114         zatold(:,:) = SUM( a_i(:,:,:), dim=3 ) 
     115         DO jl = 1, jpl 
     116            DO jj = 1, jpj 
     117               DO ji = 1, jpi 
     118                  rswitch          = MAX( 0._wp , SIGN( 1._wp, a_i(ji,jj,jl) - epsi20 ) ) 
     119                  ht_i  (ji,jj,jl) = v_i (ji,jj,jl) / MAX( a_i(ji,jj,jl) , epsi20 ) * rswitch 
     120                  ht_s  (ji,jj,jl) = v_s (ji,jj,jl) / MAX( a_i(ji,jj,jl) , epsi20 ) * rswitch 
     121               END DO 
     122            END DO 
     123         END DO 
    109124         !--------------------------------------------------------------------- 
    110          ! Record max of the surrounding ice thicknesses for correction in limupdate 
     125         ! Record max of the surrounding ice thicknesses for correction 
    111126         ! in case advection creates ice too thick. 
    112127         !--------------------------------------------------------------------- 
    113          zhimax(:,:,:) = ht_i(:,:,:) 
     128         zhimax(:,:,:) = ht_i(:,:,:) + ht_s(:,:,:) 
    114129         DO jl = 1, jpl 
    115130            DO jj = 2, jpjm1 
    116131               DO ji = 2, jpim1 
    117                   zhimax(ji,jj,jl) = MAXVAL( ht_i(ji-1:ji+1,jj-1:jj+1,jl) ) 
    118                   !zhimax(ji,jj,jl) = ( ht_i(ji  ,jj  ,jl) * tmask(ji,  jj  ,1) + ht_i(ji-1,jj-1,jl) * tmask(ji-1,jj-1,1) + ht_i(ji+1,jj+1,jl) * tmask(ji+1,jj+1,1) & 
    119                   !     &             + ht_i(ji-1,jj  ,jl) * tmask(ji-1,jj  ,1) + ht_i(ji  ,jj-1,jl) * tmask(ji  ,jj-1,1) & 
    120                   !     &             + ht_i(ji+1,jj  ,jl) * tmask(ji+1,jj  ,1) + ht_i(ji  ,jj+1,jl) * tmask(ji  ,jj+1,1) & 
    121                   !     &             + ht_i(ji-1,jj+1,jl) * tmask(ji-1,jj+1,1) + ht_i(ji+1,jj-1,jl) * tmask(ji+1,jj-1,1) ) 
     132                  zhimax(ji,jj,jl) = MAXVAL( ht_i(ji-1:ji+1,jj-1:jj+1,jl) + ht_s(ji-1:ji+1,jj-1:jj+1,jl) ) 
    122133               END DO 
    123134            END DO 
    … …  
    125136         END DO 
    126137          
     138         !=============================! 
     139         !==      Prather scheme     ==! 
     140         !=============================! 
     141 
     142         ! If ice drift field is too fast, use an appropriate time step for advection.          
     143         zcfl  =            MAXVAL( ABS( u_ice(:,:) ) * rdt_ice * r1_e1u(:,:) )         ! CFL test for stability 
     144         zcfl  = MAX( zcfl, MAXVAL( ABS( v_ice(:,:) ) * rdt_ice * r1_e2v(:,:) ) ) 
     145         IF(lk_mpp )   CALL mpp_max( zcfl ) 
     146 
     147         IF( zcfl > 0.5 ) THEN   ;   initad = 2   ;   zusnit = 0.5_wp 
     148         ELSE                    ;   initad = 1   ;   zusnit = 1.0_wp 
     149         ENDIF 
     150 
     151         IF( zcfl > 0.5_wp .AND. lwp )   ncfl = ncfl + 1 
     152!!         IF( lwp ) THEN 
     153!!            IF( ncfl > 0 ) THEN    
     154!!               WRITE(cltmp,'(i6.1)') ncfl 
     155!!               CALL ctl_warn( 'lim_trp: ncfl= ', TRIM(cltmp), 'advective ice time-step using a split in sub-time-step ') 
     156!!            ELSE 
     157!!            !  WRITE(numout,*) 'lim_trp : CFL criterion for ice advection is always smaller than 1/2 ' 
     158!!            ENDIF 
     159!!         ENDIF 
     160 
    127161         !------------------------- 
    128162         ! transported fields                                         
    129163         !------------------------- 
    130          ! Snow vol, ice vol, salt and age contents, area 
    131          zs0ow(:,:) = ato_i(:,:) * area(:,:)               ! Open water area  
    132          DO jl = 1, jpl 
    133             zs0sn (:,:,jl)   = v_s  (:,:,jl) * area(:,:)    ! Snow volume 
    134             zs0ice(:,:,jl)   = v_i  (:,:,jl) * area(:,:)    ! Ice  volume 
    135             zs0a  (:,:,jl)   = a_i  (:,:,jl) * area(:,:)    ! Ice area 
    136             zs0sm (:,:,jl)   = smv_i(:,:,jl) * area(:,:)    ! Salt content 
    137             zs0oi (:,:,jl)   = oa_i (:,:,jl) * area(:,:)    ! Age content 
    138             zs0c0 (:,:,jl)   = e_s  (:,:,1,jl)              ! Snow heat content 
    139             zs0e  (:,:,:,jl) = e_i  (:,:,:,jl)              ! Ice  heat content 
    140          END DO 
    141  
    142          !-------------------------- 
    143          ! Advection of Ice fields  (Prather scheme)                                             
    144          !-------------------------- 
    145          ! If ice drift field is too fast, use an appropriate time step for advection.          
    146          ! CFL test for stability 
    147          zcfl  =            MAXVAL( ABS( u_ice(:,:) ) * rdt_ice / e1u(:,:) ) 
    148          zcfl  = MAX( zcfl, MAXVAL( ABS( v_ice(:,:) ) * rdt_ice / e2v(:,:) ) ) 
    149          IF(lk_mpp )   CALL mpp_max( zcfl ) 
    150 !!gm more readability: 
    151 !         IF( zcfl > 0.5 ) THEN   ;   initad = 2   ;   zusnit = 0.5_wp 
    152 !         ELSE                    ;   initad = 1   ;   zusnit = 1.0_wp 
    153 !         ENDIF 
    154 !!gm end 
    155          initad = 1 + NINT( MAX( 0._wp, SIGN( 1._wp, zcfl-0.5 ) ) ) 
    156          zusnit = 1.0 / REAL( initad )  
    157          IF( zcfl > 0.5 .AND. lwp )   & 
    158             WRITE(numout,*) 'lim_trp   : CFL violation at day ', nday, ', cfl = ', zcfl,   & 
    159                &                        ': the ice time stepping is split in two' 
     164         z0opw(:,:,1) = ato_i(:,:) * e12t(:,:)             ! Open water area  
     165         DO jl = 1, jpl 
     166            z0snw (:,:,jl)  = v_s  (:,:,jl) * e12t(:,:)    ! Snow volume 
     167            z0ice(:,:,jl)   = v_i  (:,:,jl) * e12t(:,:)    ! Ice  volume 
     168            z0ai  (:,:,jl)  = a_i  (:,:,jl) * e12t(:,:)    ! Ice area 
     169            z0smi (:,:,jl)  = smv_i(:,:,jl) * e12t(:,:)    ! Salt content 
     170            z0oi (:,:,jl)   = oa_i (:,:,jl) * e12t(:,:)    ! Age content 
     171            z0es (:,:,jl)   = e_s  (:,:,1,jl) * e12t(:,:)  ! Snow heat content 
     172            DO jk = 1, nlay_i 
     173               z0ei  (:,:,jk,jl) = e_i  (:,:,jk,jl) * e12t(:,:) ! Ice  heat content 
     174            END DO 
     175         END DO 
     176 
    160177 
    161178         IF( MOD( ( kt - 1) / nn_fsbc , 2 ) == 0 ) THEN       !==  odd ice time step:  adv_x then adv_y  ==! 
    162             DO jn = 1,initad 
    163                CALL lim_adv_x( zusnit, u_ice, 1._wp , zsm, zs0ow (:,:), sxopw(:,:),   &             !--- ice open water area 
    164                   &                                       sxxopw(:,:), syopw(:,:), syyopw(:,:), sxyopw(:,:)  ) 
    165                CALL lim_adv_y( zusnit, v_ice, 0._wp, zsm, zs0ow (:,:), sxopw(:,:),   & 
    166                   &                                       sxxopw(:,:), syopw(:,:), syyopw(:,:), sxyopw(:,:)  ) 
     179            DO jt = 1, initad 
     180               CALL lim_adv_x( zusnit, u_ice, 1._wp, zsm, z0opw (:,:,1), sxopw(:,:),   &             !--- ice open water area 
     181                  &                                       sxxopw(:,:)  , syopw(:,:), syyopw(:,:), sxyopw(:,:)  ) 
     182               CALL lim_adv_y( zusnit, v_ice, 0._wp, zsm, z0opw (:,:,1), sxopw(:,:),   & 
     183                  &                                       sxxopw(:,:)  , syopw(:,:), syyopw(:,:), sxyopw(:,:)  ) 
    167184               DO jl = 1, jpl 
    168                   CALL lim_adv_x( zusnit, u_ice, 1._wp , zsm, zs0ice(:,:,jl), sxice(:,:,jl),   &    !--- ice volume  --- 
     185                  CALL lim_adv_x( zusnit, u_ice, 1._wp, zsm, z0ice (:,:,jl), sxice(:,:,jl),   &    !--- ice volume  --- 
    169186                     &                                       sxxice(:,:,jl), syice(:,:,jl), syyice(:,:,jl), sxyice(:,:,jl)  ) 
    170                   CALL lim_adv_y( zusnit, v_ice, 0._wp, zsm, zs0ice(:,:,jl), sxice(:,:,jl),   & 
     187                  CALL lim_adv_y( zusnit, v_ice, 0._wp, zsm, z0ice (:,:,jl), sxice(:,:,jl),   & 
    171188                     &                                       sxxice(:,:,jl), syice(:,:,jl), syyice(:,:,jl), sxyice(:,:,jl)  ) 
    172                   CALL lim_adv_x( zusnit, u_ice, 1._wp , zsm, zs0sn (:,:,jl), sxsn (:,:,jl),   &    !--- snow volume  --- 
     189                  CALL lim_adv_x( zusnit, u_ice, 1._wp, zsm, z0snw (:,:,jl), sxsn (:,:,jl),   &    !--- snow volume  --- 
    173190                     &                                       sxxsn (:,:,jl), sysn (:,:,jl), syysn (:,:,jl), sxysn (:,:,jl)  ) 
    174                   CALL lim_adv_y( zusnit, v_ice, 0._wp, zsm, zs0sn (:,:,jl), sxsn (:,:,jl),   & 
     191                  CALL lim_adv_y( zusnit, v_ice, 0._wp, zsm, z0snw (:,:,jl), sxsn (:,:,jl),   & 
    175192                     &                                       sxxsn (:,:,jl), sysn (:,:,jl), syysn (:,:,jl), sxysn (:,:,jl)  ) 
    176                   CALL lim_adv_x( zusnit, u_ice, 1._wp , zsm, zs0sm (:,:,jl), sxsal(:,:,jl),   &    !--- ice salinity --- 
     193                  CALL lim_adv_x( zusnit, u_ice, 1._wp, zsm, z0smi (:,:,jl), sxsal(:,:,jl),   &    !--- ice salinity --- 
    177194                     &                                       sxxsal(:,:,jl), sysal(:,:,jl), syysal(:,:,jl), sxysal(:,:,jl)  ) 
    178                   CALL lim_adv_y( zusnit, v_ice, 0._wp, zsm, zs0sm (:,:,jl), sxsal(:,:,jl),   & 
     195                  CALL lim_adv_y( zusnit, v_ice, 0._wp, zsm, z0smi (:,:,jl), sxsal(:,:,jl),   & 
    179196                     &                                       sxxsal(:,:,jl), sysal(:,:,jl), syysal(:,:,jl), sxysal(:,:,jl)  ) 
    180                   CALL lim_adv_x( zusnit, u_ice, 1._wp , zsm, zs0oi (:,:,jl), sxage(:,:,jl),   &   !--- ice age      ---      
     197                  CALL lim_adv_x( zusnit, u_ice, 1._wp, zsm, z0oi  (:,:,jl), sxage(:,:,jl),   &    !--- ice age      ---      
    181198                     &                                       sxxage(:,:,jl), syage(:,:,jl), syyage(:,:,jl), sxyage(:,:,jl)  ) 
    182                   CALL lim_adv_y( zusnit, v_ice, 0._wp, zsm, zs0oi (:,:,jl), sxage(:,:,jl),   & 
     199                  CALL lim_adv_y( zusnit, v_ice, 0._wp, zsm, z0oi (:,:,jl), sxage(:,:,jl),   & 
    183200                     &                                       sxxage(:,:,jl), syage(:,:,jl), syyage(:,:,jl), sxyage(:,:,jl)  ) 
    184                   CALL lim_adv_x( zusnit, u_ice, 1._wp , zsm, zs0a  (:,:,jl), sxa  (:,:,jl),   &   !--- ice concentrations --- 
     201                  CALL lim_adv_x( zusnit, u_ice, 1._wp, zsm, z0ai  (:,:,jl), sxa  (:,:,jl),   &    !--- ice concentrations --- 
    185202                     &                                       sxxa  (:,:,jl), sya  (:,:,jl), syya  (:,:,jl), sxya  (:,:,jl)  ) 
    186                   CALL lim_adv_y( zusnit, v_ice, 0._wp, zsm, zs0a  (:,:,jl), sxa  (:,:,jl),   &  
     203                  CALL lim_adv_y( zusnit, v_ice, 0._wp, zsm, z0ai  (:,:,jl), sxa  (:,:,jl),   &  
    187204                     &                                       sxxa  (:,:,jl), sya  (:,:,jl), syya  (:,:,jl), sxya  (:,:,jl)  ) 
    188                   CALL lim_adv_x( zusnit, u_ice, 1._wp , zsm, zs0c0 (:,:,jl), sxc0 (:,:,jl),   &  !--- snow heat contents --- 
     205                  CALL lim_adv_x( zusnit, u_ice, 1._wp, zsm, z0es  (:,:,jl), sxc0 (:,:,jl),   &    !--- snow heat contents --- 
    189206                     &                                       sxxc0 (:,:,jl), syc0 (:,:,jl), syyc0 (:,:,jl), sxyc0 (:,:,jl)  ) 
    190                   CALL lim_adv_y( zusnit, v_ice, 0._wp, zsm, zs0c0 (:,:,jl), sxc0 (:,:,jl),   & 
     207                  CALL lim_adv_y( zusnit, v_ice, 0._wp, zsm, z0es (:,:,jl), sxc0 (:,:,jl),   & 
    191208                     &                                       sxxc0 (:,:,jl), syc0 (:,:,jl), syyc0 (:,:,jl), sxyc0 (:,:,jl)  ) 
    192                   DO jk = 1, nlay_i                                                           !--- ice heat contents --- 
    193                      CALL lim_adv_x( zusnit, u_ice, 1._wp , zsm, zs0e(:,:,jk,jl), sxe (:,:,jk,jl),   &  
     209                  DO jk = 1, nlay_i                                                                !--- ice heat contents --- 
     210                     CALL lim_adv_x( zusnit, u_ice, 1._wp, zsm, z0ei(:,:,jk,jl), sxe (:,:,jk,jl),   &  
    194211                        &                                       sxxe(:,:,jk,jl), sye (:,:,jk,jl),   & 
    195212                        &                                       syye(:,:,jk,jl), sxye(:,:,jk,jl) ) 
    196                      CALL lim_adv_y( zusnit, v_ice, 0._wp, zsm, zs0e(:,:,jk,jl), sxe (:,:,jk,jl),   &  
     213                     CALL lim_adv_y( zusnit, v_ice, 0._wp, zsm, z0ei(:,:,jk,jl), sxe (:,:,jk,jl),   &  
    197214                        &                                       sxxe(:,:,jk,jl), sye (:,:,jk,jl),   & 
    198215                        &                                       syye(:,:,jk,jl), sxye(:,:,jk,jl) ) 
    … …  
    201218            END DO 
    202219         ELSE 
    203             DO jn = 1, initad 
    204                CALL lim_adv_y( zusnit, v_ice, 1._wp , zsm, zs0ow (:,:), sxopw(:,:),   &             !--- ice open water area 
    205                   &                                       sxxopw(:,:), syopw(:,:), syyopw(:,:), sxyopw(:,:)  ) 
    206                CALL lim_adv_x( zusnit, u_ice, 0._wp, zsm, zs0ow (:,:), sxopw(:,:),   & 
    207                   &                                       sxxopw(:,:), syopw(:,:), syyopw(:,:), sxyopw(:,:)  ) 
     220            DO jt = 1, initad 
     221               CALL lim_adv_y( zusnit, v_ice, 1._wp, zsm, z0opw (:,:,1), sxopw(:,:),   &             !--- ice open water area 
     222                  &                                       sxxopw(:,:)  , syopw(:,:), syyopw(:,:), sxyopw(:,:)  ) 
     223               CALL lim_adv_x( zusnit, u_ice, 0._wp, zsm, z0opw (:,:,1), sxopw(:,:),   & 
     224                  &                                       sxxopw(:,:)  , syopw(:,:), syyopw(:,:), sxyopw(:,:)  ) 
    208225               DO jl = 1, jpl 
    209                   CALL lim_adv_y( zusnit, v_ice, 1._wp , zsm, zs0ice(:,:,jl), sxice(:,:,jl),   &    !--- ice volume  --- 
     226                  CALL lim_adv_y( zusnit, v_ice, 1._wp, zsm, z0ice (:,:,jl), sxice(:,:,jl),   &    !--- ice volume  --- 
    210227                     &                                       sxxice(:,:,jl), syice(:,:,jl), syyice(:,:,jl), sxyice(:,:,jl)  ) 
    211                   CALL lim_adv_x( zusnit, u_ice, 0._wp, zsm, zs0ice(:,:,jl), sxice(:,:,jl),   & 
     228                  CALL lim_adv_x( zusnit, u_ice, 0._wp, zsm, z0ice (:,:,jl), sxice(:,:,jl),   & 
    212229                     &                                       sxxice(:,:,jl), syice(:,:,jl), syyice(:,:,jl), sxyice(:,:,jl)  ) 
    213                   CALL lim_adv_y( zusnit, v_ice, 1._wp , zsm, zs0sn (:,:,jl), sxsn (:,:,jl),   &    !--- snow volume  --- 
     230                  CALL lim_adv_y( zusnit, v_ice, 1._wp, zsm, z0snw (:,:,jl), sxsn (:,:,jl),   &    !--- snow volume  --- 
    214231                     &                                       sxxsn (:,:,jl), sysn (:,:,jl), syysn (:,:,jl), sxysn (:,:,jl)  ) 
    215                   CALL lim_adv_x( zusnit, u_ice, 0._wp, zsm, zs0sn (:,:,jl), sxsn (:,:,jl),   & 
     232                  CALL lim_adv_x( zusnit, u_ice, 0._wp, zsm, z0snw (:,:,jl), sxsn (:,:,jl),   & 
    216233                     &                                       sxxsn (:,:,jl), sysn (:,:,jl), syysn (:,:,jl), sxysn (:,:,jl)  ) 
    217                   CALL lim_adv_y( zusnit, v_ice, 1._wp , zsm, zs0sm (:,:,jl), sxsal(:,:,jl),   &    !--- ice salinity --- 
     234                  CALL lim_adv_y( zusnit, v_ice, 1._wp, zsm, z0smi (:,:,jl), sxsal(:,:,jl),   &    !--- ice salinity --- 
    218235                     &                                       sxxsal(:,:,jl), sysal(:,:,jl), syysal(:,:,jl), sxysal(:,:,jl)  ) 
    219                   CALL lim_adv_x( zusnit, u_ice, 0._wp, zsm, zs0sm (:,:,jl), sxsal(:,:,jl),   & 
     236                  CALL lim_adv_x( zusnit, u_ice, 0._wp, zsm, z0smi (:,:,jl), sxsal(:,:,jl),   & 
    220237                     &                                       sxxsal(:,:,jl), sysal(:,:,jl), syysal(:,:,jl), sxysal(:,:,jl)  ) 
    221  
    222                   CALL lim_adv_y( zusnit, v_ice, 1._wp , zsm, zs0oi (:,:,jl), sxage(:,:,jl),   &   !--- ice age      --- 
     238                  CALL lim_adv_y( zusnit, v_ice, 1._wp, zsm, z0oi  (:,:,jl), sxage(:,:,jl),   &   !--- ice age      --- 
    223239                     &                                       sxxage(:,:,jl), syage(:,:,jl), syyage(:,:,jl), sxyage(:,:,jl)  ) 
    224                   CALL lim_adv_x( zusnit, u_ice, 0._wp, zsm, zs0oi (:,:,jl), sxage(:,:,jl),   & 
     240                  CALL lim_adv_x( zusnit, u_ice, 0._wp, zsm, z0oi (:,:,jl), sxage(:,:,jl),   & 
    225241                     &                                       sxxage(:,:,jl), syage(:,:,jl), syyage(:,:,jl), sxyage(:,:,jl)  ) 
    226                   CALL lim_adv_y( zusnit, v_ice, 1._wp , zsm, zs0a  (:,:,jl), sxa  (:,:,jl),   &   !--- ice concentrations --- 
     242                  CALL lim_adv_y( zusnit, v_ice, 1._wp, zsm, z0ai  (:,:,jl), sxa  (:,:,jl),   &   !--- ice concentrations --- 
    227243                     &                                       sxxa  (:,:,jl), sya  (:,:,jl), syya  (:,:,jl), sxya  (:,:,jl)  ) 
    228                   CALL lim_adv_x( zusnit, u_ice, 0._wp, zsm, zs0a  (:,:,jl), sxa  (:,:,jl),   & 
     244                  CALL lim_adv_x( zusnit, u_ice, 0._wp, zsm, z0ai  (:,:,jl), sxa  (:,:,jl),   & 
    229245                     &                                       sxxa  (:,:,jl), sya  (:,:,jl), syya  (:,:,jl), sxya  (:,:,jl)  ) 
    230                   CALL lim_adv_y( zusnit, v_ice, 1._wp , zsm, zs0c0 (:,:,jl), sxc0 (:,:,jl),   &  !--- snow heat contents --- 
     246                  CALL lim_adv_y( zusnit, v_ice, 1._wp, zsm, z0es (:,:,jl), sxc0 (:,:,jl),   &  !--- snow heat contents --- 
    231247                     &                                       sxxc0 (:,:,jl), syc0 (:,:,jl), syyc0 (:,:,jl), sxyc0 (:,:,jl)  ) 
    232                   CALL lim_adv_x( zusnit, u_ice, 0._wp, zsm, zs0c0 (:,:,jl), sxc0 (:,:,jl),   & 
     248                  CALL lim_adv_x( zusnit, u_ice, 0._wp, zsm, z0es (:,:,jl), sxc0 (:,:,jl),   & 
    233249                     &                                       sxxc0 (:,:,jl), syc0 (:,:,jl), syyc0 (:,:,jl), sxyc0 (:,:,jl)  ) 
    234250                  DO jk = 1, nlay_i                                                           !--- ice heat contents --- 
    235                      CALL lim_adv_y( zusnit, v_ice, 1._wp , zsm, zs0e(:,:,jk,jl), sxe (:,:,jk,jl),   &  
     251                     CALL lim_adv_y( zusnit, v_ice, 1._wp, zsm, z0ei(:,:,jk,jl), sxe (:,:,jk,jl),   &  
    236252                        &                                       sxxe(:,:,jk,jl), sye (:,:,jk,jl),   & 
    237253                        &                                       syye(:,:,jk,jl), sxye(:,:,jk,jl) ) 
    238                      CALL lim_adv_x( zusnit, u_ice, 0._wp, zsm, zs0e(:,:,jk,jl), sxe (:,:,jk,jl),   &  
     254                     CALL lim_adv_x( zusnit, u_ice, 0._wp, zsm, z0ei(:,:,jk,jl), sxe (:,:,jk,jl),   &  
    239255                        &                                       sxxe(:,:,jk,jl), sye (:,:,jk,jl),   & 
    240256                        &                                       syye(:,:,jk,jl), sxye(:,:,jk,jl) ) 
    … …  
    247263         ! Recover the properties from their contents 
    248264         !------------------------------------------- 
    249          zs0ow(:,:) = zs0ow(:,:) / area(:,:) 
    250          DO jl = 1, jpl 
    251             zs0ice(:,:,jl) = zs0ice(:,:,jl) / area(:,:) 
    252             zs0sn (:,:,jl) = zs0sn (:,:,jl) / area(:,:) 
    253             zs0sm (:,:,jl) = zs0sm (:,:,jl) / area(:,:) 
    254             zs0oi (:,:,jl) = zs0oi (:,:,jl) / area(:,:) 
    255             zs0a  (:,:,jl) = zs0a  (:,:,jl) / area(:,:) 
    256             ! 
     265         ato_i(:,:) = z0opw(:,:,1) * r1_e12t(:,:) 
     266         DO jl = 1, jpl 
     267            v_i  (:,:,jl)   = z0ice(:,:,jl) * r1_e12t(:,:) 
     268            v_s  (:,:,jl)   = z0snw(:,:,jl) * r1_e12t(:,:) 
     269            smv_i(:,:,jl)   = z0smi(:,:,jl) * r1_e12t(:,:) 
     270            oa_i (:,:,jl)   = z0oi (:,:,jl) * r1_e12t(:,:) 
     271            a_i  (:,:,jl)   = z0ai (:,:,jl) * r1_e12t(:,:) 
     272            e_s  (:,:,1,jl) = z0es (:,:,jl) * r1_e12t(:,:) 
     273            DO jk = 1, nlay_i 
     274               e_i(:,:,jk,jl) = z0ei(:,:,jk,jl) * r1_e12t(:,:) 
     275            END DO 
     276         END DO 
     277 
     278         at_i(:,:) = a_i(:,:,1)      ! total ice fraction 
     279         DO jl = 2, jpl 
     280            at_i(:,:) = at_i(:,:) + a_i(:,:,jl) 
    257281         END DO 
    258282 
    259283         !------------------------------------------------------------------------------! 
    260          ! 4) Diffusion of Ice fields                   
     284         ! Diffusion of Ice fields                   
    261285         !------------------------------------------------------------------------------! 
    262286 
     287         ! 
    263288         !-------------------------------- 
    264289         !  diffusion of open water area 
    265290         !-------------------------------- 
    266          zs0at(:,:) = zs0a(:,:,1)      ! total ice fraction 
    267          DO jl = 2, jpl 
    268             zs0at(:,:) = zs0at(:,:) + zs0a(:,:,jl) 
    269          END DO 
    270          ! 
    271291         !                             ! Masked eddy diffusivity coefficient at ocean U- and V-points 
    272292         DO jj = 1, jpjm1                    ! NB: has not to be defined on jpj line and jpi row 
    273293            DO ji = 1 , fs_jpim1   ! vector opt. 
    274                pahu(ji,jj) = ( 1._wp - MAX( 0._wp, SIGN( 1._wp, -zs0at(ji  ,jj) ) ) )   & 
    275                   &        * ( 1._wp - MAX( 0._wp, SIGN( 1._wp, -zs0at(ji+1,jj) ) ) ) * ahiu(ji,jj) 
    276                pahv(ji,jj) = ( 1._wp - MAX( 0._wp, SIGN( 1._wp, -zs0at(ji,jj  ) ) ) )   & 
    277                   &        * ( 1._wp - MAX( 0._wp, SIGN( 1._wp,- zs0at(ji,jj+1) ) ) ) * ahiv(ji,jj) 
     294               pahu(ji,jj) = ( 1._wp - MAX( 0._wp, SIGN( 1._wp, -at_i(ji  ,jj) ) ) )   & 
     295                  &        * ( 1._wp - MAX( 0._wp, SIGN( 1._wp, -at_i(ji+1,jj) ) ) ) * ahiu(ji,jj) 
     296               pahv(ji,jj) = ( 1._wp - MAX( 0._wp, SIGN( 1._wp, -at_i(ji,jj  ) ) ) )   & 
     297                  &        * ( 1._wp - MAX( 0._wp, SIGN( 1._wp,- at_i(ji,jj+1) ) ) ) * ahiv(ji,jj) 
    278298            END DO 
    279299         END DO 
    280300         ! 
    281          CALL lim_hdf( zs0ow (:,:) )   ! Diffusion 
     301         CALL lim_hdf( ato_i (:,:) ) 
    282302 
    283303         !------------------------------------ 
    … …  
    288308            DO jj = 1, jpjm1                 ! NB: has not to be defined on jpj line and jpi row 
    289309               DO ji = 1 , fs_jpim1   ! vector opt. 
    290                   pahu(ji,jj) = ( 1._wp - MAX( 0._wp, SIGN( 1._wp, -zs0a(ji  ,jj,jl) ) ) )   & 
    291                      &        * ( 1._wp - MAX( 0._wp, SIGN( 1._wp, -zs0a(ji+1,jj,jl) ) ) ) * ahiu(ji,jj) 
    292                   pahv(ji,jj) = ( 1._wp - MAX( 0._wp, SIGN( 1._wp, -zs0a(ji,jj  ,jl) ) ) )   & 
    293                      &        * ( 1._wp - MAX( 0._wp, SIGN( 1._wp,- zs0a(ji,jj+1,jl) ) ) ) * ahiv(ji,jj) 
    294                END DO 
    295             END DO 
    296  
    297             CALL lim_hdf( zs0ice (:,:,jl) ) 
    298             CALL lim_hdf( zs0sn  (:,:,jl) ) 
    299             CALL lim_hdf( zs0sm  (:,:,jl) ) 
    300             CALL lim_hdf( zs0oi  (:,:,jl) ) 
    301             CALL lim_hdf( zs0a   (:,:,jl) ) 
    302             CALL lim_hdf( zs0c0  (:,:,jl) ) 
     310                  pahu(ji,jj) = ( 1._wp - MAX( 0._wp, SIGN( 1._wp, -a_i(ji  ,jj,jl) ) ) )   & 
     311                     &        * ( 1._wp - MAX( 0._wp, SIGN( 1._wp, -a_i(ji+1,jj,jl) ) ) ) * ahiu(ji,jj) 
     312                  pahv(ji,jj) = ( 1._wp - MAX( 0._wp, SIGN( 1._wp, -a_i(ji,jj  ,jl) ) ) )   & 
     313                     &        * ( 1._wp - MAX( 0._wp, SIGN( 1._wp,- a_i(ji,jj+1,jl) ) ) ) * ahiv(ji,jj) 
     314               END DO 
     315            END DO 
     316 
     317            CALL lim_hdf( v_i  (:,:,  jl) ) 
     318            CALL lim_hdf( v_s  (:,:,  jl) ) 
     319            CALL lim_hdf( smv_i(:,:,  jl) ) 
     320            CALL lim_hdf( oa_i (:,:,  jl) ) 
     321            CALL lim_hdf( a_i  (:,:,  jl) ) 
     322            CALL lim_hdf( e_s  (:,:,1,jl) ) 
    303323            DO jk = 1, nlay_i 
    304                CALL lim_hdf( zs0e (:,:,jk,jl) ) 
     324               CALL lim_hdf( e_i(:,:,jk,jl) ) 
    305325            END DO 
    306326         END DO 
    307327 
    308328         !------------------------------------------------------------------------------! 
    309          ! 5) Update and limit ice properties after transport                            
     329         ! limit ice properties after transport                            
    310330         !------------------------------------------------------------------------------! 
    311  
    312          !-------------------------------------------------- 
    313          ! 5.1) Recover mean values over the grid squares. 
    314          !-------------------------------------------------- 
    315          zs0at(:,:) = 0._wp 
     331!!gm & cr   :  MAX should not be active if adv scheme is positive ! 
    316332         DO jl = 1, jpl 
    317333            DO jj = 1, jpj 
    318334               DO ji = 1, jpi 
    319                   zs0sn (ji,jj,jl) = MAX( 0._wp, zs0sn (ji,jj,jl) ) 
    320                   zs0ice(ji,jj,jl) = MAX( 0._wp, zs0ice(ji,jj,jl) ) 
    321                   zs0sm (ji,jj,jl) = MAX( 0._wp, zs0sm (ji,jj,jl) ) 
    322                   zs0oi (ji,jj,jl) = MAX( 0._wp, zs0oi (ji,jj,jl) ) 
    323                   zs0a  (ji,jj,jl) = MAX( 0._wp, zs0a  (ji,jj,jl) ) 
    324                   zs0c0 (ji,jj,jl) = MAX( 0._wp, zs0c0 (ji,jj,jl) ) 
    325                   zs0at (ji,jj)    = zs0at(ji,jj) + zs0a(ji,jj,jl) 
    326                END DO 
    327             END DO 
    328          END DO 
    329  
    330          !--------------------------------------------------------- 
    331          ! 5.2) Update and mask variables 
    332          !--------------------------------------------------------- 
    333          DO jl = 1, jpl           
    334             DO jj = 1, jpj 
    335                DO ji = 1, jpi 
    336                   rswitch = MAX( 0._wp , SIGN( 1._wp, zs0a(ji,jj,jl) - epsi10 ) ) 
    337  
    338                   zvi  = zs0ice(ji,jj,jl) 
    339                   zvs  = zs0sn (ji,jj,jl) 
    340                   zes  = zs0c0 (ji,jj,jl)       
    341                   zsmv = zs0sm (ji,jj,jl) 
    342                   ! 
    343                   ! Remove very small areas 
    344                   v_s(ji,jj,jl)   = rswitch * zs0sn (ji,jj,jl)  
    345                   v_i(ji,jj,jl)   = rswitch * zs0ice(ji,jj,jl) 
    346                   a_i(ji,jj,jl)   = rswitch * zs0a  (ji,jj,jl) 
    347                   e_s(ji,jj,1,jl) = rswitch * zs0c0 (ji,jj,jl)       
    348                   ! Ice salinity and age 
    349                   IF(  num_sal == 2  ) THEN 
    350                      smv_i(ji,jj,jl) = MAX( MIN( s_i_max * v_i(ji,jj,jl), zsmv ), s_i_min * v_i(ji,jj,jl) ) 
    351                   ENDIF 
    352                   oa_i(ji,jj,jl) = MAX( rswitch * zs0oi(ji,jj,jl) / MAX( a_i(ji,jj,jl), epsi10 ), 0._wp ) * a_i(ji,jj,jl) 
    353  
    354                  ! Update fluxes 
    355                   wfx_res(ji,jj) = wfx_res(ji,jj) - ( v_i(ji,jj,jl) - zvi ) * rhoic * r1_rdtice  
    356                   wfx_snw(ji,jj) = wfx_snw(ji,jj) - ( v_s(ji,jj,jl) - zvs ) * rhosn * r1_rdtice 
    357                   sfx_res(ji,jj) = sfx_res(ji,jj) - ( smv_i(ji,jj,jl) - zsmv ) * rhoic * r1_rdtice  
    358                   hfx_res(ji,jj) = hfx_res(ji,jj) + ( e_s(ji,jj,1,jl) - zes ) * unit_fac / area(ji,jj) * r1_rdtice ! W.m-2 <0 
    359               END DO 
    360             END DO 
    361          END DO 
    362  
    363          DO jl = 1, jpl 
     335                  v_s  (ji,jj,jl)   = MAX( 0._wp, v_s  (ji,jj,jl) ) 
     336                  v_i  (ji,jj,jl)   = MAX( 0._wp, v_i  (ji,jj,jl) ) 
     337                  smv_i(ji,jj,jl)   = MAX( 0._wp, smv_i(ji,jj,jl) ) 
     338                  oa_i (ji,jj,jl)   = MAX( 0._wp, oa_i (ji,jj,jl) ) 
     339                  a_i  (ji,jj,jl)   = MAX( 0._wp, a_i  (ji,jj,jl) ) 
     340                  e_s  (ji,jj,1,jl) = MAX( 0._wp, e_s  (ji,jj,1,jl) ) 
     341               END DO 
     342            END DO 
     343 
    364344            DO jk = 1, nlay_i 
    365345               DO jj = 1, jpj 
    366346                  DO ji = 1, jpi 
    367                      rswitch          = MAX( 0._wp , SIGN( 1._wp, zs0a(ji,jj,jl) - epsi10 ) ) 
    368                      zei              = zs0e(ji,jj,jk,jl)       
    369                      e_i(ji,jj,jk,jl) = rswitch * MAX( 0._wp, zs0e(ji,jj,jk,jl) ) 
    370                      ! Update fluxes 
    371                      hfx_res(ji,jj) = hfx_res(ji,jj) + ( e_i(ji,jj,jk,jl) - zei ) * unit_fac / area(ji,jj) * r1_rdtice ! W.m-2 <0 
    372                   END DO !ji 
    373                END DO ! jj 
    374             END DO ! jk 
    375          END DO ! jl 
    376  
    377          !--- Thickness correction in case too high (clem) -------------------------------------------------------- 
    378          CALL lim_var_glo2eqv 
     347                     e_i(ji,jj,jk,jl) = MAX( 0._wp, e_i(ji,jj,jk,jl) ) 
     348                  END DO 
     349               END DO 
     350            END DO 
     351         END DO 
     352!!gm & cr  
     353 
     354         ! --- diags --- 
     355         DO jj = 1, jpj 
     356            DO ji = 1, jpi 
     357               diag_trp_ei(ji,jj) = ( SUM( e_i(ji,jj,1:nlay_i,:) ) - zeiold(ji,jj) ) * r1_rdtice 
     358               diag_trp_es(ji,jj) = ( SUM( e_s(ji,jj,1:nlay_s,:) ) - zesold(ji,jj) ) * r1_rdtice 
     359 
     360               diag_trp_vi (ji,jj) = SUM(   v_i(ji,jj,:) -  zviold(ji,jj,:) ) * r1_rdtice 
     361               diag_trp_vs (ji,jj) = SUM(   v_s(ji,jj,:) -  zvsold(ji,jj,:) ) * r1_rdtice 
     362               diag_trp_smv(ji,jj) = SUM( smv_i(ji,jj,:) - zsmvold(ji,jj,:) ) * r1_rdtice 
     363            END DO 
     364         END DO 
     365 
     366         ! zap small areas 
     367         CALL lim_var_zapsmall 
     368 
     369         !--- Thickness correction in case too high -------------------------------------------------------- 
    379370         DO jl = 1, jpl 
    380371            DO jj = 1, jpj 
    … …  
    382373 
    383374                  IF ( v_i(ji,jj,jl) > 0._wp ) THEN 
     375 
     376                     rswitch          = MAX( 0._wp , SIGN( 1._wp, a_i(ji,jj,jl) - epsi20 ) ) 
     377                     ht_i  (ji,jj,jl) = v_i (ji,jj,jl) / MAX( a_i(ji,jj,jl) , epsi20 ) * rswitch 
     378                     ht_s  (ji,jj,jl) = v_s (ji,jj,jl) / MAX( a_i(ji,jj,jl) , epsi20 ) * rswitch 
     379                      
    384380                     zvi  = v_i  (ji,jj,jl) 
    385381                     zvs  = v_s  (ji,jj,jl) 
    … …  
    387383                     zes  = e_s  (ji,jj,1,jl) 
    388384                     zei  = SUM( e_i(ji,jj,1:nlay_i,jl) ) 
    389                      zdv  = v_i(ji,jj,jl) - zviold(ji,jj,jl)    
    390                      !zda = a_i(ji,jj,jl) - zaiold(ji,jj,jl)    
    391                       
    392                      rswitch = 1._wp 
    393                      IF ( ( zdv > 0.0 .AND. ht_i(ji,jj,jl) > zhimax(ji,jj,jl) .AND. SUM( zaiold(ji,jj,1:jpl) ) < 0.80 ) .OR. & 
    394                         & ( zdv < 0.0 .AND. ht_i(ji,jj,jl) > zhimax(ji,jj,jl) ) ) THEN                                           
    395                         ht_i(ji,jj,jl) = MIN( zhimax(ji,jj,jl), hi_max(jl) ) 
    396                         rswitch        = MAX( 0._wp, SIGN( 1._wp, ht_i(ji,jj,jl) - epsi20 ) ) 
    397                         a_i(ji,jj,jl)  = rswitch * v_i(ji,jj,jl) / MAX( ht_i(ji,jj,jl), epsi20 ) 
    398                      ELSE 
    399                         ht_i(ji,jj,jl) = MAX( MIN( ht_i(ji,jj,jl), hi_max(jl) ), hi_max(jl-1) ) 
    400                         rswitch        = MAX( 0._wp, SIGN( 1._wp, ht_i(ji,jj,jl) - epsi20 ) ) 
    401                         a_i(ji,jj,jl)  = rswitch * v_i(ji,jj,jl) / MAX( ht_i(ji,jj,jl), epsi20 ) 
     385 
     386                     zdv  = v_i(ji,jj,jl) + v_s(ji,jj,jl) - zviold(ji,jj,jl) - zvsold(ji,jj,jl)   
     387 
     388                     IF ( ( zdv >  0.0 .AND. (ht_i(ji,jj,jl)+ht_s(ji,jj,jl)) > zhimax(ji,jj,jl) .AND. zatold(ji,jj) < 0.80 ) .OR. & 
     389                        & ( zdv <= 0.0 .AND. (ht_i(ji,jj,jl)+ht_s(ji,jj,jl)) > zhimax(ji,jj,jl) ) ) THEN 
     390 
     391                        rswitch        = MAX( 0._wp, SIGN( 1._wp, zhimax(ji,jj,jl) - epsi20 ) ) 
     392                        a_i(ji,jj,jl)  = rswitch * ( v_i(ji,jj,jl) + v_s(ji,jj,jl) ) / MAX( zhimax(ji,jj,jl), epsi20 ) 
     393 
     394                        ! small correction due to *rswitch for a_i 
     395                        v_i  (ji,jj,jl)        = rswitch * v_i  (ji,jj,jl) 
     396                        v_s  (ji,jj,jl)        = rswitch * v_s  (ji,jj,jl) 
     397                        smv_i(ji,jj,jl)        = rswitch * smv_i(ji,jj,jl) 
     398                        e_s(ji,jj,1,jl)        = rswitch * e_s(ji,jj,1,jl) 
     399                        e_i(ji,jj,1:nlay_i,jl) = rswitch * e_i(ji,jj,1:nlay_i,jl) 
     400 
     401                        ! Update mass fluxes 
     402                        wfx_res(ji,jj) = wfx_res(ji,jj) - ( v_i(ji,jj,jl) - zvi ) * rhoic * r1_rdtice 
     403                        wfx_snw(ji,jj) = wfx_snw(ji,jj) - ( v_s(ji,jj,jl) - zvs ) * rhosn * r1_rdtice 
     404                        sfx_res(ji,jj) = sfx_res(ji,jj) - ( smv_i(ji,jj,jl) - zsmv ) * rhoic * r1_rdtice  
     405                        hfx_res(ji,jj) = hfx_res(ji,jj) + ( e_s(ji,jj,1,jl) - zes ) * r1_rdtice ! W.m-2 <0 
     406                        hfx_res(ji,jj) = hfx_res(ji,jj) + ( SUM( e_i(ji,jj,1:nlay_i,jl) ) - zei ) * r1_rdtice ! W.m-2 <0 
     407 
    402408                     ENDIF 
    403409 
    404                      ! small correction due to *rswitch for a_i 
    405                      v_i  (ji,jj,jl) = rswitch * v_i  (ji,jj,jl) 
    406                      v_s  (ji,jj,jl) = rswitch * v_s  (ji,jj,jl) 
    407                      smv_i(ji,jj,jl) = rswitch * smv_i(ji,jj,jl) 
    408                      e_s(ji,jj,1,jl) = rswitch * e_s(ji,jj,1,jl) 
    409                      e_i(ji,jj,1:nlay_i,jl) = rswitch * e_i(ji,jj,1:nlay_i,jl) 
    410  
    411                      ! Update mass fluxes 
    412                      wfx_res(ji,jj) = wfx_res(ji,jj) - ( v_i(ji,jj,jl) - zvi ) * rhoic * r1_rdtice 
    413                      wfx_snw(ji,jj) = wfx_snw(ji,jj) - ( v_s(ji,jj,jl) - zvs ) * rhosn * r1_rdtice 
    414                      sfx_res(ji,jj) = sfx_res(ji,jj) - ( smv_i(ji,jj,jl) - zsmv ) * rhoic * r1_rdtice  
    415                      hfx_res(ji,jj) = hfx_res(ji,jj) + ( e_s(ji,jj,1,jl) - zes ) * unit_fac / area(ji,jj) * r1_rdtice ! W.m-2 <0 
    416                      hfx_res(ji,jj) = hfx_res(ji,jj) + ( SUM( e_i(ji,jj,1:nlay_i,jl) ) - zei ) * unit_fac / area(ji,jj) * r1_rdtice ! W.m-2 <0 
    417410                  ENDIF 
     411 
    418412               END DO 
    419413            END DO 
    420414         END DO 
    421415         ! ------------------------------------------------- 
    422  
    423          ! --- diags --- 
    424          DO jj = 1, jpj 
    425             DO ji = 1, jpi 
    426                diag_trp_ei(ji,jj) = ( SUM( e_i(ji,jj,1:nlay_i,:) ) - zeiold(ji,jj) ) / area(ji,jj) * unit_fac * r1_rdtice 
    427                diag_trp_es(ji,jj) = ( SUM( e_s(ji,jj,1:nlay_s,:) ) - zesold(ji,jj) ) / area(ji,jj) * unit_fac * r1_rdtice 
    428  
    429                diag_trp_vi(ji,jj) = SUM( v_i(ji,jj,:) - zviold(ji,jj,:) ) * r1_rdtice 
    430                diag_trp_vs(ji,jj) = SUM( v_s(ji,jj,:) - zvsold(ji,jj,:) ) * r1_rdtice 
    431             END DO 
    432          END DO 
     416          
     417         !-------------------------------------- 
     418         ! Impose a_i < amax in mono-category 
     419         !-------------------------------------- 
     420         ! 
     421         IF ( ( nn_monocat == 2 ) .AND. ( jpl == 1 ) ) THEN ! simple conservative piling, comparable with LIM2 
     422            DO jj = 1, jpj 
     423               DO ji = 1, jpi 
     424                  a_i(ji,jj,1)  = MIN( a_i(ji,jj,1), rn_amax ) 
     425               END DO 
     426            END DO 
     427         ENDIF 
    433428 
    434429         ! --- agglomerate variables ----------------- 
    … …  
    436431         vt_s (:,:) = 0._wp 
    437432         at_i (:,:) = 0._wp 
    438          ! 
    439433         DO jl = 1, jpl 
    440434            DO jj = 1, jpj 
    441435               DO ji = 1, jpi 
    442                   ! 
    443                   vt_i(ji,jj) = vt_i(ji,jj) + v_i(ji,jj,jl) ! ice volume 
    444                   vt_s(ji,jj) = vt_s(ji,jj) + v_s(ji,jj,jl) ! snow volume 
    445                   at_i(ji,jj) = at_i(ji,jj) + a_i(ji,jj,jl) ! ice concentration 
    446                END DO 
    447             END DO 
    448          END DO 
    449          ! ------------------------------------------------- 
    450  
    451          ! open water 
     436                  vt_i(ji,jj) = vt_i(ji,jj) + v_i(ji,jj,jl) 
     437                  vt_s(ji,jj) = vt_s(ji,jj) + v_s(ji,jj,jl) 
     438                  at_i(ji,jj) = at_i(ji,jj) + a_i(ji,jj,jl) 
     439               END DO 
     440            END DO 
     441         END DO 
     442 
     443         ! --- open water = 1 if at_i=0 -------------------------------- 
    452444         DO jj = 1, jpj 
    453445            DO ji = 1, jpi 
    454                ! open water = 1 if at_i=0 
    455446               rswitch      = MAX( 0._wp , SIGN( 1._wp, - at_i(ji,jj) ) ) 
    456                ato_i(ji,jj) = rswitch + (1._wp - rswitch ) * zs0ow(ji,jj) 
     447               ato_i(ji,jj) = rswitch + (1._wp - rswitch ) * ato_i(ji,jj) 
    457448            END DO 
    458449         END DO       
    … …  
    463454      ENDIF 
    464455 
    465       IF(ln_ctl) THEN   ! Control print 
    466          CALL prt_ctl_info(' ') 
    467          CALL prt_ctl_info(' - Cell values : ') 
    468          CALL prt_ctl_info('   ~~~~~~~~~~~~~ ') 
    469          CALL prt_ctl(tab2d_1=area , clinfo1=' lim_trp  : cell area :') 
    470          CALL prt_ctl(tab2d_1=at_i , clinfo1=' lim_trp  : at_i      :') 
    471          CALL prt_ctl(tab2d_1=vt_i , clinfo1=' lim_trp  : vt_i      :') 
    472          CALL prt_ctl(tab2d_1=vt_s , clinfo1=' lim_trp  : vt_s      :') 
    473          DO jl = 1, jpl 
    474             CALL prt_ctl_info(' ') 
    475             CALL prt_ctl_info(' - Category : ', ivar1=jl) 
    476             CALL prt_ctl_info('   ~~~~~~~~~~') 
    477             CALL prt_ctl(tab2d_1=a_i   (:,:,jl)   , clinfo1= ' lim_trp  : a_i      : ') 
    478             CALL prt_ctl(tab2d_1=ht_i  (:,:,jl)   , clinfo1= ' lim_trp  : ht_i     : ') 
    479             CALL prt_ctl(tab2d_1=ht_s  (:,:,jl)   , clinfo1= ' lim_trp  : ht_s     : ') 
    480             CALL prt_ctl(tab2d_1=v_i   (:,:,jl)   , clinfo1= ' lim_trp  : v_i      : ') 
    481             CALL prt_ctl(tab2d_1=v_s   (:,:,jl)   , clinfo1= ' lim_trp  : v_s      : ') 
    482             CALL prt_ctl(tab2d_1=e_s   (:,:,1,jl) , clinfo1= ' lim_trp  : e_s      : ') 
    483             CALL prt_ctl(tab2d_1=t_su  (:,:,jl)   , clinfo1= ' lim_trp  : t_su     : ') 
    484             CALL prt_ctl(tab2d_1=t_s   (:,:,1,jl) , clinfo1= ' lim_trp  : t_snow   : ') 
    485             CALL prt_ctl(tab2d_1=sm_i  (:,:,jl)   , clinfo1= ' lim_trp  : sm_i     : ') 
    486             CALL prt_ctl(tab2d_1=smv_i (:,:,jl)   , clinfo1= ' lim_trp  : smv_i    : ') 
    487             DO jk = 1, nlay_i 
    488                CALL prt_ctl_info(' ') 
    489                CALL prt_ctl_info(' - Layer : ', ivar1=jk) 
    490                CALL prt_ctl_info('   ~~~~~~~') 
    491                CALL prt_ctl(tab2d_1=t_i(:,:,jk,jl) , clinfo1= ' lim_trp  : t_i      : ') 
    492                CALL prt_ctl(tab2d_1=e_i(:,:,jk,jl) , clinfo1= ' lim_trp  : e_i      : ') 
    493             END DO 
    494          END DO 
    495       ENDIF 
     456      ! ------------------------------------------------- 
     457      ! control prints 
     458      ! ------------------------------------------------- 
     459      IF( ln_icectl )   CALL lim_prt( kt, iiceprt, jiceprt,-1, ' - ice dyn & trp - ' ) 
    496460      ! 
    497       CALL wrk_dealloc( jpi, jpj, zui_u, zvi_v, zsm, zs0at, zs0ow, zeiold, zesold ) 
    498       CALL wrk_dealloc( jpi, jpj, jpl, zs0ice, zs0sn, zs0a, zs0c0 , zs0sm , zs0oi ) 
    499       CALL wrk_dealloc( jpi, jpj, nlay_i+1, jpl, zs0e ) 
    500  
    501       CALL wrk_dealloc( jpi, jpj, jpl, zviold, zvsold, zaiold, zhimax )   ! clem 
     461      CALL wrk_dealloc( jpi,jpj,            zsm, zatold, zeiold, zesold ) 
     462      CALL wrk_dealloc( jpi,jpj,jpl,        z0ice, z0snw, z0ai, z0es , z0smi , z0oi ) 
     463      CALL wrk_dealloc( jpi,jpj,1,          z0opw ) 
     464      CALL wrk_dealloc( jpi,jpj,nlay_i,jpl, z0ei ) 
     465      CALL wrk_dealloc( jpi,jpj,jpl,        zviold, zvsold, zhimax, zsmvold ) 
    502466      ! 
    503467      IF( nn_timing == 1 )  CALL timing_stop('limtrp') 
     468 
    504469   END SUBROUTINE lim_trp 
    505470 
    … …  
    512477   END SUBROUTINE lim_trp 
    513478#endif 
    514  
    515479   !!====================================================================== 
    516480END MODULE limtrp 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/LIM_SRC_3/limupdate1.F90

    r5312 r5313  
    55   !!====================================================================== 
    66   !! History :  3.0  !  2006-04  (M. Vancoppenolle) Original code 
    7    !!            3.6  !  2014-06  (C. Rousset)       Complete rewriting/cleaning 
     7   !!            3.5  !  2014-06  (C. Rousset)       Complete rewriting/cleaning 
    88   !!---------------------------------------------------------------------- 
    99#if defined key_lim3 
    … …  
    1313   !!    lim_update1   : computes update of sea-ice global variables from trend terms 
    1414   !!---------------------------------------------------------------------- 
    15    USE limrhg          ! ice rheology 
    16  
    17    USE dom_oce 
    18    USE oce             ! dynamics and tracers variables 
    19    USE in_out_manager 
    2015   USE sbc_oce         ! Surface boundary condition: ocean fields 
    2116   USE sbc_ice         ! Surface boundary condition: ice fields 
    2217   USE dom_ice 
     18   USE dom_oce 
    2319   USE phycst          ! physical constants 
    2420   USE ice 
    25    USE limdyn 
    26    USE limtrp 
    27    USE limthd 
    28    USE limsbc 
    29    USE limdiahsb 
    30    USE limwri 
    31    USE limrst 
    3221   USE thd_ice         ! LIM thermodynamic sea-ice variables 
    33    USE par_ice 
    3422   USE limitd_th 
    35    USE limitd_me 
    3623   USE limvar 
    37    USE prtctl           ! Print control 
    38    USE lbclnk           ! lateral boundary condition - MPP exchanges 
    39    USE wrk_nemo         ! work arrays 
    40    USE lib_fortran     ! glob_sum 
    41    USE in_out_manager   ! I/O manager 
    42    USE iom              ! I/O manager 
    43    USE lib_mpp          ! MPP library 
     24   USE prtctl          ! Print control 
     25   USE wrk_nemo        ! work arrays 
    4426   USE timing          ! Timing 
    45    USE limcons        ! conservation tests 
     27   USE limcons         ! conservation tests 
     28   USE lib_mpp         ! MPP library 
     29   USE lib_fortran     ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined)   
     30   USE in_out_manager  ! I/O manager 
    4631 
    4732   IMPLICIT NONE 
    4833   PRIVATE 
    4934 
    50    PUBLIC   lim_update1   ! routine called by ice_step 
     35   PUBLIC   lim_update1 
    5136 
    5237   !! * Substitutions 
    … …  
    5944CONTAINS 
    6045 
    61    SUBROUTINE lim_update1 
     46   SUBROUTINE lim_update1( kt ) 
    6247      !!------------------------------------------------------------------- 
    6348      !!               ***  ROUTINE lim_update1  *** 
    … …  
    6752      !!                 
    6853      !!--------------------------------------------------------------------- 
     54      INTEGER, INTENT(in) ::   kt    ! number of iteration 
    6955      INTEGER  ::   ji, jj, jk, jl   ! dummy loop indices 
    70       INTEGER  ::   i_ice_switch 
    7156      REAL(wp) ::   zsal 
    72       ! 
    73       REAL(wp) :: zvi_b, zsmv_b, zei_b, zfs_b, zfw_b, zft_b  
     57      REAL(wp) ::   zvi_b, zsmv_b, zei_b, zfs_b, zfw_b, zft_b  
    7458      !!------------------------------------------------------------------- 
    7559      IF( nn_timing == 1 )  CALL timing_start('limupdate1') 
    … …  
    7761      IF( ln_limdyn ) THEN  
    7862 
     63      IF( kt == nit000 .AND. lwp ) THEN 
     64         WRITE(numout,*) ' lim_update1 '  
     65         WRITE(numout,*) ' ~~~~~~~~~~~ ' 
     66      ENDIF 
     67 
    7968      ! conservation test 
    8069      IF( ln_limdiahsb ) CALL lim_cons_hsm(0, 'limupdate1', zvi_b, zsmv_b, zei_b, zfw_b, zfs_b, zft_b) 
    8170 
    82       !----------------- 
    83       ! zap small values 
    84       !----------------- 
    85       CALL lim_itd_me_zapsmall 
    86  
    87       CALL lim_var_glo2eqv 
    88       
    8971      !---------------------------------------------------- 
    90       ! Rebin categories with thickness out of bounds 
    91       !---------------------------------------------------- 
    92       IF ( jpl > 1 )   CALL lim_itd_th_reb(1, jpl) 
    93  
     72      ! ice concentration should not exceed amax  
     73      !----------------------------------------------------- 
    9474      at_i(:,:) = 0._wp 
    9575      DO jl = 1, jpl 
    … …  
    9777      END DO 
    9878 
    99       !---------------------------------------------------- 
    100       ! ice concentration should not exceed amax  
    101       !----------------------------------------------------- 
    10279      DO jl  = 1, jpl 
    10380         DO jj = 1, jpj 
    10481            DO ji = 1, jpi 
    105                IF( at_i(ji,jj) > amax .AND. a_i(ji,jj,jl) > 0._wp ) THEN 
    106                   a_i(ji,jj,jl)  = a_i(ji,jj,jl) * ( 1._wp - ( 1._wp - amax / at_i(ji,jj) ) ) 
    107                   ht_i(ji,jj,jl) = v_i(ji,jj,jl) / a_i(ji,jj,jl) 
     82               IF( at_i(ji,jj) > rn_amax .AND. a_i(ji,jj,jl) > 0._wp ) THEN 
     83                  a_i (ji,jj,jl) = a_i (ji,jj,jl) * ( 1._wp - ( 1._wp - rn_amax / at_i(ji,jj) ) ) 
     84                  oa_i(ji,jj,jl) = oa_i(ji,jj,jl) * ( 1._wp - ( 1._wp - rn_amax / at_i(ji,jj) ) ) 
    10885               ENDIF 
    10986            END DO 
    11087         END DO 
    11188      END DO 
    112  
    113       at_i(:,:) = 0._wp 
    114       DO jl = 1, jpl 
    115          at_i(:,:) = a_i(:,:,jl) + at_i(:,:) 
    116       END DO 
    11789     
    118       ! -------------------------------------- 
    119       ! Final thickness distribution rebinning 
    120       ! -------------------------------------- 
    121       IF ( jpl > 1 ) CALL lim_itd_th_reb(1, jpl) 
    122  
    123       !----------------- 
    124       ! zap small values 
    125       !----------------- 
    126       CALL lim_itd_me_zapsmall 
    127  
    12890      !--------------------- 
    12991      ! Ice salinity bounds 
    13092      !--------------------- 
    131       IF (  num_sal == 2  ) THEN  
     93      IF (  nn_icesal == 2  ) THEN  
    13294         DO jl = 1, jpl 
    13395            DO jj = 1, jpj  
    13496               DO ji = 1, jpi 
    13597                  zsal            = smv_i(ji,jj,jl) 
    136                   smv_i(ji,jj,jl) = sm_i(ji,jj,jl) * v_i(ji,jj,jl) 
    13798                  ! salinity stays in bounds 
    138                   i_ice_switch    = 1._wp - MAX( 0._wp, SIGN( 1._wp, - v_i(ji,jj,jl) ) ) 
    139                   smv_i(ji,jj,jl) = i_ice_switch * MAX( MIN( s_i_max * v_i(ji,jj,jl), smv_i(ji,jj,jl) ), s_i_min * v_i(ji,jj,jl) ) 
     99                  rswitch         = 1._wp - MAX( 0._wp, SIGN( 1._wp, - v_i(ji,jj,jl) ) ) 
     100                  smv_i(ji,jj,jl) = rswitch * MAX( MIN( rn_simax * v_i(ji,jj,jl), smv_i(ji,jj,jl) ), rn_simin * v_i(ji,jj,jl) ) 
    140101                  ! associated salt flux 
    141102                  sfx_res(ji,jj) = sfx_res(ji,jj) - ( smv_i(ji,jj,jl) - zsal ) * rhoic * r1_rdtice 
    … …  
    145106      ENDIF 
    146107 
     108      !---------------------------------------------------- 
     109      ! Rebin categories with thickness out of bounds 
     110      !---------------------------------------------------- 
     111      IF ( jpl > 1 ) CALL lim_itd_th_reb(1, jpl) 
     112 
     113      !----------------- 
     114      ! zap small values 
     115      !----------------- 
     116      CALL lim_var_zapsmall 
     117 
    147118      ! ------------------------------------------------- 
    148119      ! Diagnostics 
    149120      ! ------------------------------------------------- 
    150       d_u_ice_dyn(:,:)     = u_ice(:,:)     - u_ice_b(:,:) 
    151       d_v_ice_dyn(:,:)     = v_ice(:,:)     - v_ice_b(:,:) 
    152       d_a_i_trp  (:,:,:)   = a_i  (:,:,:)   - a_i_b  (:,:,:) 
    153       d_v_s_trp  (:,:,:)   = v_s  (:,:,:)   - v_s_b  (:,:,:)   
    154       d_v_i_trp  (:,:,:)   = v_i  (:,:,:)   - v_i_b  (:,:,:)    
    155       d_e_s_trp  (:,:,:,:) = e_s  (:,:,:,:) - e_s_b  (:,:,:,:)   
    156       d_e_i_trp  (:,:,1:nlay_i,:) = e_i  (:,:,1:nlay_i,:) - e_i_b(:,:,1:nlay_i,:) 
    157       d_oa_i_trp (:,:,:)   = oa_i (:,:,:)   - oa_i_b (:,:,:) 
    158       d_smv_i_trp(:,:,:)   = 0._wp 
    159       IF(  num_sal == 2  ) d_smv_i_trp(:,:,:) = smv_i(:,:,:) - smv_i_b(:,:,:) 
     121      DO jl  = 1, jpl 
     122         afx_dyn(:,:) = afx_dyn(:,:) + ( a_i(:,:,jl) - a_i_b(:,:,jl) ) * r1_rdtice 
     123      END DO 
     124 
     125      DO jj = 1, jpj 
     126         DO ji = 1, jpi             
     127            ! heat content variation (W.m-2) 
     128            diag_heat(ji,jj) = - ( SUM( e_i(ji,jj,1:nlay_i,:) - e_i_b(ji,jj,1:nlay_i,:) ) +  &  
     129               &                   SUM( e_s(ji,jj,1:nlay_s,:) - e_s_b(ji,jj,1:nlay_s,:) )    & 
     130               &                 ) * r1_rdtice 
     131            ! salt, volume 
     132            diag_smvi(ji,jj) = SUM( smv_i(ji,jj,:) - smv_i_b(ji,jj,:) ) * rhoic * r1_rdtice 
     133            diag_vice(ji,jj) = SUM( v_i  (ji,jj,:) - v_i_b  (ji,jj,:) ) * rhoic * r1_rdtice 
     134            diag_vsnw(ji,jj) = SUM( v_s  (ji,jj,:) - v_s_b  (ji,jj,:) ) * rhosn * r1_rdtice 
     135         END DO 
     136      END DO 
    160137 
    161138      ! conservation test 
    162139      IF( ln_limdiahsb ) CALL lim_cons_hsm(1, 'limupdate1', zvi_b, zsmv_b, zei_b, zfw_b, zfs_b, zft_b) 
    163140 
     141      ! ------------------------------------------------- 
     142      ! control prints 
     143      ! ------------------------------------------------- 
    164144      IF(ln_ctl) THEN   ! Control print 
    165145         CALL prt_ctl_info(' ') 
    166146         CALL prt_ctl_info(' - Cell values : ') 
    167147         CALL prt_ctl_info('   ~~~~~~~~~~~~~ ') 
    168          CALL prt_ctl(tab2d_1=area       , clinfo1=' lim_update1  : cell area   :') 
     148         CALL prt_ctl(tab2d_1=e12t       , clinfo1=' lim_update1  : cell area   :') 
    169149         CALL prt_ctl(tab2d_1=at_i       , clinfo1=' lim_update1  : at_i        :') 
    170150         CALL prt_ctl(tab2d_1=vt_i       , clinfo1=' lim_update1  : vt_i        :') 
    … …  
    172152         CALL prt_ctl(tab2d_1=strength   , clinfo1=' lim_update1  : strength    :') 
    173153         CALL prt_ctl(tab2d_1=u_ice      , clinfo1=' lim_update1  : u_ice       :', tab2d_2=v_ice      , clinfo2=' v_ice       :') 
    174          CALL prt_ctl(tab2d_1=d_u_ice_dyn, clinfo1=' lim_update1  : d_u_ice_dyn :', tab2d_2=d_v_ice_dyn, clinfo2=' d_v_ice_dyn :') 
    175154         CALL prt_ctl(tab2d_1=u_ice_b    , clinfo1=' lim_update1  : u_ice_b     :', tab2d_2=v_ice_b    , clinfo2=' v_ice_b     :') 
    176155 
    … …  
    187166            CALL prt_ctl(tab2d_1=a_i        (:,:,jl)        , clinfo1= ' lim_update1  : a_i         : ') 
    188167            CALL prt_ctl(tab2d_1=a_i_b      (:,:,jl)        , clinfo1= ' lim_update1  : a_i_b       : ') 
    189             CALL prt_ctl(tab2d_1=d_a_i_trp  (:,:,jl)        , clinfo1= ' lim_update1  : d_a_i_trp   : ') 
    190168            CALL prt_ctl(tab2d_1=v_i        (:,:,jl)        , clinfo1= ' lim_update1  : v_i         : ') 
    191169            CALL prt_ctl(tab2d_1=v_i_b      (:,:,jl)        , clinfo1= ' lim_update1  : v_i_b       : ') 
    192             CALL prt_ctl(tab2d_1=d_v_i_trp  (:,:,jl)        , clinfo1= ' lim_update1  : d_v_i_trp   : ') 
    193170            CALL prt_ctl(tab2d_1=v_s        (:,:,jl)        , clinfo1= ' lim_update1  : v_s         : ') 
    194171            CALL prt_ctl(tab2d_1=v_s_b      (:,:,jl)        , clinfo1= ' lim_update1  : v_s_b       : ') 
    195             CALL prt_ctl(tab2d_1=d_v_s_trp  (:,:,jl)        , clinfo1= ' lim_update1  : d_v_s_trp   : ') 
    196             CALL prt_ctl(tab2d_1=e_i        (:,:,1,jl)/1.0e9, clinfo1= ' lim_update1  : e_i1        : ') 
    197             CALL prt_ctl(tab2d_1=e_i_b      (:,:,1,jl)/1.0e9, clinfo1= ' lim_update1  : e_i1_b      : ') 
    198             CALL prt_ctl(tab2d_1=d_e_i_trp  (:,:,1,jl)/1.0e9, clinfo1= ' lim_update1  : de_i1_trp   : ') 
    199             CALL prt_ctl(tab2d_1=e_i        (:,:,2,jl)/1.0e9, clinfo1= ' lim_update1  : e_i2        : ') 
    200             CALL prt_ctl(tab2d_1=e_i_b      (:,:,2,jl)/1.0e9, clinfo1= ' lim_update1  : e_i2_b      : ') 
    201             CALL prt_ctl(tab2d_1=d_e_i_trp  (:,:,2,jl)/1.0e9, clinfo1= ' lim_update1  : de_i2_trp   : ') 
     172            CALL prt_ctl(tab2d_1=e_i        (:,:,1,jl)      , clinfo1= ' lim_update1  : e_i1        : ') 
     173            CALL prt_ctl(tab2d_1=e_i_b      (:,:,1,jl)      , clinfo1= ' lim_update1  : e_i1_b      : ') 
     174            CALL prt_ctl(tab2d_1=e_i        (:,:,2,jl)      , clinfo1= ' lim_update1  : e_i2        : ') 
     175            CALL prt_ctl(tab2d_1=e_i_b      (:,:,2,jl)      , clinfo1= ' lim_update1  : e_i2_b      : ') 
    202176            CALL prt_ctl(tab2d_1=e_s        (:,:,1,jl)      , clinfo1= ' lim_update1  : e_snow      : ') 
    203177            CALL prt_ctl(tab2d_1=e_s_b      (:,:,1,jl)      , clinfo1= ' lim_update1  : e_snow_b    : ') 
    204             CALL prt_ctl(tab2d_1=d_e_s_trp  (:,:,1,jl)/1.0e9, clinfo1= ' lim_update1  : d_e_s_trp   : ') 
    205178            CALL prt_ctl(tab2d_1=smv_i      (:,:,jl)        , clinfo1= ' lim_update1  : smv_i       : ') 
    206179            CALL prt_ctl(tab2d_1=smv_i_b    (:,:,jl)        , clinfo1= ' lim_update1  : smv_i_b     : ') 
    207             CALL prt_ctl(tab2d_1=d_smv_i_trp(:,:,jl)        , clinfo1= ' lim_update1  : d_smv_i_trp : ') 
    208180            CALL prt_ctl(tab2d_1=oa_i       (:,:,jl)        , clinfo1= ' lim_update1  : oa_i        : ') 
    209181            CALL prt_ctl(tab2d_1=oa_i_b     (:,:,jl)        , clinfo1= ' lim_update1  : oa_i_b      : ') 
    210             CALL prt_ctl(tab2d_1=d_oa_i_trp (:,:,jl)        , clinfo1= ' lim_update1  : d_oa_i_trp  : ') 
    211182 
    212183            DO jk = 1, nlay_i 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/LIM_SRC_3/limupdate2.F90

    r5312 r5313  
    55   !!====================================================================== 
    66   !! History :  3.0  !  2006-04  (M. Vancoppenolle) Original code 
    7    !!            3.6  !  2014-06  (C. Rousset)       Complete rewriting/cleaning 
     7   !!            3.5  !  2014-06  (C. Rousset)       Complete rewriting/cleaning 
    88   !!---------------------------------------------------------------------- 
    99#if defined key_lim3 
    … …  
    1313   !!    lim_update2   : computes update of sea-ice global variables from trend terms 
    1414   !!---------------------------------------------------------------------- 
    15    USE limrhg          ! ice rheology 
    16  
    17    USE dom_oce 
    18    USE oce             ! dynamics and tracers variables 
    19    USE in_out_manager 
    2015   USE sbc_oce         ! Surface boundary condition: ocean fields 
    2116   USE sbc_ice         ! Surface boundary condition: ice fields 
    2217   USE dom_ice 
     18   USE dom_oce 
    2319   USE phycst          ! physical constants 
    2420   USE ice 
    25    USE limdyn 
    26    USE limtrp 
    27    USE limthd 
    28    USE limsbc 
    29    USE limdiahsb 
    30    USE limwri 
    31    USE limrst 
    3221   USE thd_ice         ! LIM thermodynamic sea-ice variables 
    33    USE par_ice 
    3422   USE limitd_th 
    35    USE limitd_me 
    3623   USE limvar 
    37    USE prtctl           ! Print control 
    38    USE lbclnk           ! lateral boundary condition - MPP exchanges 
    39    USE wrk_nemo         ! work arrays 
    40    USE lib_fortran     ! glob_sum 
     24   USE prtctl          ! Print control 
     25   USE lbclnk          ! lateral boundary condition - MPP exchanges 
     26   USE wrk_nemo        ! work arrays 
    4127   USE timing          ! Timing 
    42    USE limcons        ! conservation tests 
     28   USE limcons         ! conservation tests 
     29   USE limctl 
     30   USE lib_mpp         ! MPP library 
     31   USE lib_fortran     ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined)   
     32   USE in_out_manager 
    4333 
    4434   IMPLICIT NONE 
    … …  
    5646CONTAINS 
    5747 
    58    SUBROUTINE lim_update2 
     48   SUBROUTINE lim_update2( kt ) 
    5949      !!------------------------------------------------------------------- 
    6050      !!               ***  ROUTINE lim_update2  *** 
    … …  
    6454      !! 
    6555      !!--------------------------------------------------------------------- 
    66       INTEGER  ::   ji, jj, jk, jl    ! dummy loop indices 
    67       INTEGER  ::   i_ice_switch 
    68       REAL(wp) ::   zh, zsal 
    69       ! 
    70       REAL(wp) :: zvi_b, zsmv_b, zei_b, zfs_b, zfw_b, zft_b  
     56      INTEGER, INTENT(in) ::   kt    ! number of iteration 
     57      INTEGER  ::   ji, jj, jk, jl   ! dummy loop indices 
     58      REAL(wp) ::   zsal 
     59      REAL(wp) ::   zvi_b, zsmv_b, zei_b, zfs_b, zfw_b, zft_b  
    7160      !!------------------------------------------------------------------- 
    7261      IF( nn_timing == 1 )  CALL timing_start('limupdate2') 
    7362 
     63      IF( kt == nit000 .AND. lwp ) THEN 
     64         WRITE(numout,*) ' lim_update2 ' 
     65         WRITE(numout,*) ' ~~~~~~~~~~~ ' 
     66      ENDIF 
     67 
    7468      ! conservation test 
    7569      IF( ln_limdiahsb ) CALL lim_cons_hsm(0, 'limupdate2', zvi_b, zsmv_b, zei_b, zfw_b, zfs_b, zft_b) 
    7670 
    77       !----------------- 
    78       ! zap small values 
    79       !----------------- 
    80       CALL lim_itd_me_zapsmall 
    81  
    82       CALL lim_var_glo2eqv 
    83  
    84       !---------------------------------------------------- 
    85       ! Rebin categories with thickness out of bounds 
    86       !---------------------------------------------------- 
    87       IF ( jpl > 1 )   CALL lim_itd_th_reb(1, jpl) 
    88  
    8971      !---------------------------------------------------------------------- 
    90       ! Constrain the thickness of the smallest category above hiclim 
     72      ! Constrain the thickness of the smallest category above himin 
    9173      !---------------------------------------------------------------------- 
    9274      DO jj = 1, jpj  
    9375         DO ji = 1, jpi 
    94             IF( v_i(ji,jj,1) > 0._wp .AND. ht_i(ji,jj,1) < hiclim ) THEN 
    95                zh             = hiclim / ht_i(ji,jj,1) 
    96                ht_s(ji,jj,1) = ht_s(ji,jj,1) * zh 
    97                ht_i(ji,jj,1) = ht_i(ji,jj,1) * zh 
    98                a_i (ji,jj,1) = a_i(ji,jj,1)  / zh 
     76            rswitch = MAX( 0._wp , SIGN( 1._wp, a_i(ji,jj,1) - epsi20 ) )   !0 if no ice and 1 if yes 
     77            ht_i(ji,jj,1) = v_i (ji,jj,1) / MAX( a_i(ji,jj,1) , epsi20 ) * rswitch 
     78            IF( v_i(ji,jj,1) > 0._wp .AND. ht_i(ji,jj,1) < rn_himin ) THEN 
     79               a_i (ji,jj,1) = a_i (ji,jj,1) * ht_i(ji,jj,1) / rn_himin 
     80               oa_i(ji,jj,1) = oa_i(ji,jj,1) * ht_i(ji,jj,1) / rn_himin 
    9981            ENDIF 
    10082         END DO 
    … …  
    11294         DO jj = 1, jpj 
    11395            DO ji = 1, jpi 
    114                IF( at_i(ji,jj) > amax .AND. a_i(ji,jj,jl) > 0._wp ) THEN 
    115                   a_i(ji,jj,jl)  = a_i(ji,jj,jl) * ( 1._wp - ( 1._wp - amax / at_i(ji,jj) ) ) 
    116                   ht_i(ji,jj,jl) = v_i(ji,jj,jl) / a_i(ji,jj,jl) 
     96               IF( at_i(ji,jj) > rn_amax .AND. a_i(ji,jj,jl) > 0._wp ) THEN 
     97                  a_i (ji,jj,jl) = a_i (ji,jj,jl) * ( 1._wp - ( 1._wp - rn_amax / at_i(ji,jj) ) ) 
     98                  oa_i(ji,jj,jl) = oa_i(ji,jj,jl) * ( 1._wp - ( 1._wp - rn_amax / at_i(ji,jj) ) ) 
    11799               ENDIF 
    118100            END DO 
    … …  
    120102      END DO 
    121103 
    122       at_i(:,:) = 0.0 
    123       DO jl = 1, jpl 
    124          at_i(:,:) = a_i(:,:,jl) + at_i(:,:) 
    125       END DO 
    126  
    127       ! -------------------------------------- 
    128       ! Final thickness distribution rebinning 
    129       ! -------------------------------------- 
    130       IF ( jpl > 1 ) CALL lim_itd_th_reb( 1, jpl ) 
    131  
    132       !----------------- 
    133       ! zap small values 
    134       !----------------- 
    135       CALL lim_itd_me_zapsmall 
    136  
    137104      !--------------------- 
    138       ! 2.11) Ice salinity 
     105      ! Ice salinity 
    139106      !--------------------- 
    140       IF (  num_sal == 2  ) THEN  
     107      IF (  nn_icesal == 2  ) THEN  
    141108         DO jl = 1, jpl 
    142109            DO jj = 1, jpj  
    143110               DO ji = 1, jpi 
    144111                  zsal            = smv_i(ji,jj,jl) 
    145                   smv_i(ji,jj,jl) = sm_i(ji,jj,jl) * v_i(ji,jj,jl) 
    146112                  ! salinity stays in bounds 
    147                   i_ice_switch    = 1._wp - MAX( 0._wp, SIGN( 1._wp, - v_i(ji,jj,jl) ) ) 
    148                   smv_i(ji,jj,jl) = i_ice_switch * MAX( MIN( s_i_max * v_i(ji,jj,jl), smv_i(ji,jj,jl) ), s_i_min * v_i(ji,jj,jl) ) !+ s_i_min * ( 1._wp - i_ice_switch ) * v_i(ji,jj,jl) 
     113                  rswitch         = 1._wp - MAX( 0._wp, SIGN( 1._wp, - v_i(ji,jj,jl) ) ) 
     114                  smv_i(ji,jj,jl) = rswitch * MAX( MIN( rn_simax * v_i(ji,jj,jl), smv_i(ji,jj,jl) ), rn_simin * v_i(ji,jj,jl) ) 
    149115                  ! associated salt flux 
    150116                  sfx_res(ji,jj) = sfx_res(ji,jj) - ( smv_i(ji,jj,jl) - zsal ) * rhoic * r1_rdtice 
    151                END DO ! ji 
    152             END DO ! jj 
    153          END DO !jl 
     117               END DO 
     118            END DO 
     119         END DO 
    154120      ENDIF 
    155121 
     122      !---------------------------------------------------- 
     123      ! Rebin categories with thickness out of bounds 
     124      !---------------------------------------------------- 
     125      IF ( jpl > 1 ) CALL lim_itd_th_reb( 1, jpl ) 
     126 
     127      !----------------- 
     128      ! zap small values 
     129      !----------------- 
     130      CALL lim_var_zapsmall 
     131 
    156132      !------------------------------------------------------------------------------ 
    157       ! 2) Corrections to avoid wrong values                                        | 
     133      ! Corrections to avoid wrong values                                        | 
    158134      !------------------------------------------------------------------------------ 
    159135      ! Ice drift 
    … …  
    173149      CALL lbc_lnk( v_ice(:,:), 'V', -1. ) 
    174150      !mask velocities 
    175       u_ice(:,:) = u_ice(:,:) * tmu(:,:) 
    176       v_ice(:,:) = v_ice(:,:) * tmv(:,:) 
     151      u_ice(:,:) = u_ice(:,:) * umask(:,:,1) 
     152      v_ice(:,:) = v_ice(:,:) * vmask(:,:,1) 
    177153  
    178154      ! ------------------------------------------------- 
    179155      ! Diagnostics 
    180156      ! ------------------------------------------------- 
    181       d_a_i_thd(:,:,:)   = a_i(:,:,:)   - a_i_b(:,:,:)  
    182       d_v_s_thd(:,:,:)   = v_s(:,:,:)   - v_s_b(:,:,:) 
    183       d_v_i_thd(:,:,:)   = v_i(:,:,:)   - v_i_b(:,:,:)   
    184       d_e_s_thd(:,:,:,:) = e_s(:,:,:,:) - e_s_b(:,:,:,:)  
    185       d_e_i_thd(:,:,1:nlay_i,:) = e_i(:,:,1:nlay_i,:) - e_i_b(:,:,1:nlay_i,:) 
    186       !?? d_oa_i_thd(:,:,:)  = oa_i (:,:,:) - oa_i_b (:,:,:) 
    187       d_smv_i_thd(:,:,:) = 0._wp 
    188       IF( num_sal == 2 )   d_smv_i_thd(:,:,:) = smv_i(:,:,:) - smv_i_b(:,:,:) 
    189       ! diag only (clem) 
    190       dv_dt_thd(:,:,:) = d_v_i_thd(:,:,:) * r1_rdtice * rday 
    191  
    192       ! heat content variation (W.m-2) 
     157      DO jl  = 1, jpl 
     158         oa_i(:,:,jl) = oa_i(:,:,jl) + a_i(:,:,jl) * rdt_ice / rday   ! ice natural aging 
     159         afx_thd(:,:) = afx_thd(:,:) + ( a_i(:,:,jl) - a_i_b(:,:,jl) ) * r1_rdtice 
     160      END DO 
     161      afx_tot = afx_thd + afx_dyn 
     162 
    193163      DO jj = 1, jpj 
    194164         DO ji = 1, jpi             
    195             diag_heat_dhc(ji,jj) = ( SUM( d_e_i_trp(ji,jj,1:nlay_i,:) + d_e_i_thd(ji,jj,1:nlay_i,:) ) +  &  
    196                &                     SUM( d_e_s_trp(ji,jj,1:nlay_s,:) + d_e_s_thd(ji,jj,1:nlay_s,:) )    & 
    197                &                   ) * unit_fac * r1_rdtice / area(ji,jj)    
     165            ! heat content variation (W.m-2) 
     166            diag_heat(ji,jj) = diag_heat(ji,jj) -  & 
     167               &               ( SUM( e_i(ji,jj,1:nlay_i,:) - e_i_b(ji,jj,1:nlay_i,:) ) +  &  
     168               &                 SUM( e_s(ji,jj,1:nlay_s,:) - e_s_b(ji,jj,1:nlay_s,:) )    & 
     169               &               ) * r1_rdtice    
     170            ! salt, volume 
     171            diag_smvi(ji,jj) = diag_smvi(ji,jj) + SUM( smv_i(ji,jj,:) - smv_i_b(ji,jj,:) ) * rhoic * r1_rdtice 
     172            diag_vice(ji,jj) = diag_vice(ji,jj) + SUM( v_i  (ji,jj,:) - v_i_b  (ji,jj,:) ) * rhoic * r1_rdtice 
     173            diag_vsnw(ji,jj) = diag_vsnw(ji,jj) + SUM( v_s  (ji,jj,:) - v_s_b  (ji,jj,:) ) * rhosn * r1_rdtice 
    198174         END DO 
    199175      END DO 
    200176 
    201177      ! conservation test 
    202       IF( ln_limdiahsb ) CALL lim_cons_hsm(0, 'limupdate2', zvi_b, zsmv_b, zei_b, zfw_b, zfs_b, zft_b) 
     178      IF( ln_limdiahsb ) CALL lim_cons_hsm(1, 'limupdate2', zvi_b, zsmv_b, zei_b, zfw_b, zfs_b, zft_b) 
     179 
     180      ! for outputs 
     181      CALL lim_var_glo2eqv 
     182      CALL lim_var_agg(2) 
     183 
     184      ! ------------------------------------------------- 
     185      ! control prints 
     186      ! ------------------------------------------------- 
     187      IF( ln_icectl )   CALL lim_prt( kt, iiceprt, jiceprt, 2, ' - Final state - ' )   ! control print 
    203188 
    204189      IF(ln_ctl) THEN   ! Control print 
    … …  
    206191         CALL prt_ctl_info(' - Cell values : ') 
    207192         CALL prt_ctl_info('   ~~~~~~~~~~~~~ ') 
    208          CALL prt_ctl(tab2d_1=area       , clinfo1=' lim_update2  : cell area   :') 
     193         CALL prt_ctl(tab2d_1=e12t       , clinfo1=' lim_update2  : cell area   :') 
    209194         CALL prt_ctl(tab2d_1=at_i       , clinfo1=' lim_update2  : at_i        :') 
    210195         CALL prt_ctl(tab2d_1=vt_i       , clinfo1=' lim_update2  : vt_i        :') 
    … …  
    226211            CALL prt_ctl(tab2d_1=a_i        (:,:,jl)        , clinfo1= ' lim_update2  : a_i         : ') 
    227212            CALL prt_ctl(tab2d_1=a_i_b      (:,:,jl)        , clinfo1= ' lim_update2  : a_i_b       : ') 
    228             CALL prt_ctl(tab2d_1=d_a_i_thd  (:,:,jl)        , clinfo1= ' lim_update2  : d_a_i_thd   : ') 
    229213            CALL prt_ctl(tab2d_1=v_i        (:,:,jl)        , clinfo1= ' lim_update2  : v_i         : ') 
    230214            CALL prt_ctl(tab2d_1=v_i_b      (:,:,jl)        , clinfo1= ' lim_update2  : v_i_b       : ') 
    231             CALL prt_ctl(tab2d_1=d_v_i_thd  (:,:,jl)        , clinfo1= ' lim_update2  : d_v_i_thd   : ') 
    232215            CALL prt_ctl(tab2d_1=v_s        (:,:,jl)        , clinfo1= ' lim_update2  : v_s         : ') 
    233216            CALL prt_ctl(tab2d_1=v_s_b      (:,:,jl)        , clinfo1= ' lim_update2  : v_s_b       : ') 
    234             CALL prt_ctl(tab2d_1=d_v_s_thd  (:,:,jl)        , clinfo1= ' lim_update2  : d_v_s_thd   : ') 
    235             CALL prt_ctl(tab2d_1=e_i        (:,:,1,jl)/1.0e9, clinfo1= ' lim_update2  : e_i1        : ') 
    236             CALL prt_ctl(tab2d_1=e_i_b      (:,:,1,jl)/1.0e9, clinfo1= ' lim_update2  : e_i1_b      : ') 
    237             CALL prt_ctl(tab2d_1=d_e_i_thd  (:,:,1,jl)/1.0e9, clinfo1= ' lim_update2  : de_i1_thd   : ') 
    238             CALL prt_ctl(tab2d_1=e_i        (:,:,2,jl)/1.0e9, clinfo1= ' lim_update2  : e_i2        : ') 
    239             CALL prt_ctl(tab2d_1=e_i_b      (:,:,2,jl)/1.0e9, clinfo1= ' lim_update2  : e_i2_b      : ') 
    240             CALL prt_ctl(tab2d_1=d_e_i_thd  (:,:,2,jl)/1.0e9, clinfo1= ' lim_update2  : de_i2_thd   : ') 
     217            CALL prt_ctl(tab2d_1=e_i        (:,:,1,jl)      , clinfo1= ' lim_update2  : e_i1        : ') 
     218            CALL prt_ctl(tab2d_1=e_i_b      (:,:,1,jl)      , clinfo1= ' lim_update2  : e_i1_b      : ') 
     219            CALL prt_ctl(tab2d_1=e_i        (:,:,2,jl)      , clinfo1= ' lim_update2  : e_i2        : ') 
     220            CALL prt_ctl(tab2d_1=e_i_b      (:,:,2,jl)      , clinfo1= ' lim_update2  : e_i2_b      : ') 
    241221            CALL prt_ctl(tab2d_1=e_s        (:,:,1,jl)      , clinfo1= ' lim_update2  : e_snow      : ') 
    242222            CALL prt_ctl(tab2d_1=e_s_b      (:,:,1,jl)      , clinfo1= ' lim_update2  : e_snow_b    : ') 
    243             CALL prt_ctl(tab2d_1=d_e_s_thd  (:,:,1,jl)/1.0e9, clinfo1= ' lim_update2  : d_e_s_thd   : ') 
    244223            CALL prt_ctl(tab2d_1=smv_i      (:,:,jl)        , clinfo1= ' lim_update2  : smv_i       : ') 
    245224            CALL prt_ctl(tab2d_1=smv_i_b    (:,:,jl)        , clinfo1= ' lim_update2  : smv_i_b     : ') 
    246             CALL prt_ctl(tab2d_1=d_smv_i_thd(:,:,jl)        , clinfo1= ' lim_update2  : d_smv_i_thd : ') 
    247225            CALL prt_ctl(tab2d_1=oa_i       (:,:,jl)        , clinfo1= ' lim_update2  : oa_i        : ') 
    248226            CALL prt_ctl(tab2d_1=oa_i_b     (:,:,jl)        , clinfo1= ' lim_update2  : oa_i_b      : ') 
    249             CALL prt_ctl(tab2d_1=d_oa_i_thd (:,:,jl)        , clinfo1= ' lim_update2  : d_oa_i_thd  : ') 
    250227 
    251228            DO jk = 1, nlay_i 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/LIM_SRC_3/limvar.F90

    r5312 r5313  
    3030   !!====================================================================== 
    3131   !! History :   -   ! 2006-01 (M. Vancoppenolle) Original code 
    32    !!            4.0  ! 2011-02 (G. Madec) dynamical allocation 
     32   !!            3.4  ! 2011-02 (G. Madec) dynamical allocation 
    3333   !!---------------------------------------------------------------------- 
    3434#if defined key_lim3 
    … …  
    3636   !!   'key_lim3'                                      LIM3 sea-ice model 
    3737   !!---------------------------------------------------------------------- 
    38    !!   lim_var_agg       :  
    39    !!   lim_var_glo2eqv   : 
    40    !!   lim_var_eqv2glo   : 
    41    !!   lim_var_salprof   :  
    42    !!   lim_var_salprof1d : 
    43    !!   lim_var_bv        : 
    44    !!---------------------------------------------------------------------- 
    4538   USE par_oce        ! ocean parameters 
    4639   USE phycst         ! physical constants (ocean directory)  
    4740   USE sbc_oce        ! Surface boundary condition: ocean fields 
    4841   USE ice            ! ice variables 
    49    USE par_ice        ! ice parameters 
    5042   USE thd_ice        ! ice variables (thermodynamics) 
    5143   USE dom_ice        ! ice domain 
    … …  
    5850   PRIVATE 
    5951 
    60    PUBLIC   lim_var_agg          ! 
    61    PUBLIC   lim_var_glo2eqv      ! 
    62    PUBLIC   lim_var_eqv2glo      ! 
    63    PUBLIC   lim_var_salprof      ! 
    64    PUBLIC   lim_var_icetm        ! 
    65    PUBLIC   lim_var_bv           ! 
    66    PUBLIC   lim_var_salprof1d    ! 
     52   PUBLIC   lim_var_agg           
     53   PUBLIC   lim_var_glo2eqv       
     54   PUBLIC   lim_var_eqv2glo       
     55   PUBLIC   lim_var_salprof       
     56   PUBLIC   lim_var_icetm         
     57   PUBLIC   lim_var_bv            
     58   PUBLIC   lim_var_salprof1d     
     59   PUBLIC   lim_var_zapsmall 
     60   PUBLIC   lim_var_itd 
    6761 
    6862   !!---------------------------------------------------------------------- 
    69    !! NEMO/LIM3 4.0 , UCL - NEMO Consortium (2011) 
     63   !! NEMO/LIM3 3.5 , UCL - NEMO Consortium (2011) 
    7064   !! $Id$ 
    7165   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
    … …  
    129123            DO jj = 1, jpj 
    130124               DO ji = 1, jpi 
    131                   et_s(ji,jj)  = et_s(ji,jj)  + e_s(ji,jj,1,jl)                                       ! snow heat content 
    132                   rswitch = MAX( 0._wp , SIGN( 1._wp , vt_i(ji,jj) - epsi10 ) )  
    133                   smt_i(ji,jj) = smt_i(ji,jj) + smv_i(ji,jj,jl) / MAX( vt_i(ji,jj) , epsi10 ) * rswitch   ! ice salinity 
    134                   rswitch = MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) - epsi10 ) )  
    135                   ot_i(ji,jj)  = ot_i(ji,jj)  + oa_i(ji,jj,jl)  / MAX( at_i(ji,jj) , epsi10 ) * rswitch   ! ice age 
     125                  et_s(ji,jj)  = et_s(ji,jj)  + e_s(ji,jj,1,jl)                                           ! snow heat content 
     126                  rswitch = MAX( 0._wp , SIGN( 1._wp , vt_i(ji,jj) - epsi20 ) )  
     127                  smt_i(ji,jj) = smt_i(ji,jj) + smv_i(ji,jj,jl) / MAX( vt_i(ji,jj) , epsi20 ) * rswitch   ! ice salinity 
     128                  rswitch = MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) - epsi20 ) )  
     129                  ot_i(ji,jj)  = ot_i(ji,jj)  + oa_i(ji,jj,jl)  / MAX( at_i(ji,jj) , epsi20 ) * rswitch   ! ice age 
    136130               END DO 
    137131            END DO 
    … …  
    167161         DO jj = 1, jpj 
    168162            DO ji = 1, jpi 
    169                rswitch = 1._wp - MAX( 0._wp , SIGN( 1._wp,- a_i(ji,jj,jl) + epsi10 ) )   !0 if no ice and 1 if yes 
    170                ht_i(ji,jj,jl) = v_i (ji,jj,jl) / MAX( a_i(ji,jj,jl) , epsi10 ) * rswitch 
    171                ht_s(ji,jj,jl) = v_s (ji,jj,jl) / MAX( a_i(ji,jj,jl) , epsi10 ) * rswitch 
    172                o_i(ji,jj,jl)  = oa_i(ji,jj,jl) / MAX( a_i(ji,jj,jl) , epsi10 ) * rswitch 
    173             END DO 
    174          END DO 
    175       END DO 
    176  
    177       IF(  num_sal == 2  )THEN 
     163               rswitch = MAX( 0._wp , SIGN( 1._wp, a_i(ji,jj,jl) - epsi20 ) )   !0 if no ice and 1 if yes 
     164               ht_i(ji,jj,jl) = v_i (ji,jj,jl) / MAX( a_i(ji,jj,jl) , epsi20 ) * rswitch 
     165               ht_s(ji,jj,jl) = v_s (ji,jj,jl) / MAX( a_i(ji,jj,jl) , epsi20 ) * rswitch 
     166               o_i(ji,jj,jl)  = oa_i(ji,jj,jl) / MAX( a_i(ji,jj,jl) , epsi20 ) * rswitch 
     167            END DO 
     168         END DO 
     169      END DO 
     170 
     171      IF(  nn_icesal == 2  )THEN 
    178172         DO jl = 1, jpl 
    179173            DO jj = 1, jpj 
    180174               DO ji = 1, jpi 
    181                   rswitch = 1._wp - MAX( 0._wp , SIGN( 1._wp,- a_i(ji,jj,jl) + epsi10 ) )   !0 if no ice and 1 if yes 
    182                   sm_i(ji,jj,jl) = smv_i(ji,jj,jl) / MAX( v_i(ji,jj,jl) , epsi10 ) * rswitch 
     175                  rswitch = MAX( 0._wp , SIGN( 1._wp, v_i(ji,jj,jl) - epsi20 ) )   !0 if no ice and 1 if yes 
     176                  sm_i(ji,jj,jl) = smv_i(ji,jj,jl) / MAX( v_i(ji,jj,jl) , epsi20 ) * rswitch 
     177                  !                                      ! bounding salinity 
     178                  sm_i(ji,jj,jl) = MAX( sm_i(ji,jj,jl), rn_simin ) 
    183179               END DO 
    184180            END DO 
    … …  
    191187      ! Ice temperatures 
    192188      !------------------- 
    193 !CDIR NOVERRCHK 
    194       DO jl = 1, jpl 
    195 !CDIR NOVERRCHK 
     189      DO jl = 1, jpl 
    196190         DO jk = 1, nlay_i 
    197 !CDIR NOVERRCHK 
    198191            DO jj = 1, jpj 
    199 !CDIR NOVERRCHK 
    200192               DO ji = 1, jpi 
    201193                  !                                                              ! Energy of melting q(S,T) [J.m-3] 
    202                   rswitch   = 1.0 - MAX( 0.0 , SIGN( 1.0 , - v_i(ji,jj,jl) + epsi10 ) )     ! rswitch = 0 if no ice and 1 if yes 
    203                   zq_i    = rswitch * e_i(ji,jj,jk,jl) / area(ji,jj) / MAX( v_i(ji,jj,jl) , epsi10 ) * REAL(nlay_i,wp)  
    204                   zq_i    = zq_i * unit_fac                             !convert units 
    205                   ztmelts = -tmut * s_i(ji,jj,jk,jl) + rtt                       ! Ice layer melt temperature 
     194                  rswitch = MAX( 0.0 , SIGN( 1.0 , v_i(ji,jj,jl) - epsi20 ) )     ! rswitch = 0 if no ice and 1 if yes 
     195                  zq_i    = rswitch * e_i(ji,jj,jk,jl) / MAX( v_i(ji,jj,jl) , epsi20 ) * REAL(nlay_i,wp)  
     196                  ztmelts = -tmut * s_i(ji,jj,jk,jl) + rt0              ! Ice layer melt temperature 
    206197                  ! 
    207198                  zaaa       =  cpic                  ! Conversion q(S,T) -> T (second order equation) 
    208                   zbbb       =  ( rcp - cpic ) * ( ztmelts - rtt ) + zq_i / rhoic - lfus 
    209                   zccc       =  lfus * (ztmelts-rtt) 
     199                  zbbb       =  ( rcp - cpic ) * ( ztmelts - rt0 ) + zq_i * r1_rhoic - lfus 
     200                  zccc       =  lfus * (ztmelts-rt0) 
    210201                  zdiscrim   =  SQRT( MAX(zbbb*zbbb - 4._wp*zaaa*zccc , 0._wp) ) 
    211                   t_i(ji,jj,jk,jl) = rtt + rswitch *( - zbbb - zdiscrim ) / ( 2.0 *zaaa ) 
    212                   t_i(ji,jj,jk,jl) = MIN( rtt, MAX( 173.15_wp, t_i(ji,jj,jk,jl) ) )       ! 100-rtt < t_i < rtt 
     202                  t_i(ji,jj,jk,jl) = rt0 + rswitch *( - zbbb - zdiscrim ) / ( 2.0 *zaaa ) 
     203                  t_i(ji,jj,jk,jl) = MIN( ztmelts, MAX( rt0 - 100._wp, t_i(ji,jj,jk,jl) ) )  ! -100 < t_i < ztmelts 
    213204               END DO 
    214205            END DO 
    … …  
    226217               DO ji = 1, jpi 
    227218                  !Energy of melting q(S,T) [J.m-3] 
    228                   rswitch = 1._wp - MAX( 0._wp , SIGN( 1._wp , - v_s(ji,jj,jl) + epsi10 ) )     ! rswitch = 0 if no ice and 1 if yes 
    229                   zq_s  = rswitch * e_s(ji,jj,jk,jl) / ( area(ji,jj) * MAX( v_s(ji,jj,jl) , epsi10 ) ) * REAL(nlay_s,wp) 
    230                   zq_s  = zq_s * unit_fac                                    ! convert units 
     219                  rswitch = MAX( 0._wp , SIGN( 1._wp , v_s(ji,jj,jl) - epsi20 ) )     ! rswitch = 0 if no ice and 1 if yes 
     220                  zq_s  = rswitch * e_s(ji,jj,jk,jl) / MAX( v_s(ji,jj,jl) , epsi20 ) * REAL(nlay_s,wp) 
    231221                  ! 
    232                   t_s(ji,jj,jk,jl) = rtt + rswitch * ( - zfac1 * zq_s + zfac2 ) 
    233                   t_s(ji,jj,jk,jl) = MIN( rtt, MAX( 173.15, t_s(ji,jj,jk,jl) ) )     ! 100-rtt < t_i < rtt 
     222                  t_s(ji,jj,jk,jl) = rt0 + rswitch * ( - zfac1 * zq_s + zfac2 ) 
     223                  t_s(ji,jj,jk,jl) = MIN( rt0, MAX( rt0 - 100._wp , t_s(ji,jj,jk,jl) ) )     ! -100 < t_s < rt0 
    234224               END DO 
    235225            END DO 
    … …  
    240230      ! Mean temperature 
    241231      !------------------- 
     232      vt_i (:,:) = 0._wp 
     233      DO jl = 1, jpl 
     234         vt_i(:,:) = vt_i(:,:) + v_i(:,:,jl) 
     235      END DO 
     236 
    242237      tm_i(:,:) = 0._wp 
    243238      DO jl = 1, jpl 
    … …  
    245240            DO jj = 1, jpj 
    246241               DO ji = 1, jpi 
    247                   rswitch = (  1._wp - MAX( 0._wp , SIGN( 1._wp , - vt_i(ji,jj) + epsi10 ) )  ) 
    248                   tm_i(ji,jj) = tm_i(ji,jj) + rswitch * t_i(ji,jj,jk,jl) * v_i(ji,jj,jl)   & 
    249                      &                      / (  REAL(nlay_i,wp) * MAX( vt_i(ji,jj) , epsi10 )  ) 
    250                END DO 
    251             END DO 
    252          END DO 
    253       END DO 
     242                  rswitch = MAX( 0._wp , SIGN( 1._wp , vt_i(ji,jj) - epsi10 ) ) 
     243                  tm_i(ji,jj) = tm_i(ji,jj) + r1_nlay_i * rswitch * ( t_i(ji,jj,jk,jl) - rt0 ) * v_i(ji,jj,jl)  & 
     244                     &            / MAX( vt_i(ji,jj) , epsi10 ) 
     245               END DO 
     246            END DO 
     247         END DO 
     248      END DO 
     249      tm_i = tm_i + rt0 
    254250      ! 
    255251   END SUBROUTINE lim_var_glo2eqv 
    … …  
    270266      v_s(:,:,:)   = ht_s(:,:,:) * a_i(:,:,:) 
    271267      smv_i(:,:,:) = sm_i(:,:,:) * v_i(:,:,:) 
    272       oa_i (:,:,:) = o_i (:,:,:) * a_i(:,:,:) 
    273268      ! 
    274269   END SUBROUTINE lim_var_eqv2glo 
    … …  
    281276      !! ** Purpose :   computes salinity profile in function of bulk salinity      
    282277      !! 
    283       !! ** Method  : If bulk salinity greater than s_i_1,  
     278      !! ** Method  : If bulk salinity greater than zsi1,  
    284279      !!              the profile is assumed to be constant (S_inf) 
    285       !!              If bulk salinity lower than s_i_0, 
     280      !!              If bulk salinity lower than zsi0, 
    286281      !!              the profile is linear with 0 at the surface (S_zero) 
    287       !!              If it is between s_i_0 and s_i_1, it is a 
     282      !!              If it is between zsi0 and zsi1, it is a 
    288283      !!              alpha-weighted linear combination of s_inf and s_zero 
    289284      !! 
    290       !! ** References : Vancoppenolle et al., 2007 (in preparation) 
     285      !! ** References : Vancoppenolle et al., 2007 
    291286      !!------------------------------------------------------------------ 
    292287      INTEGER  ::   ji, jj, jk, jl   ! dummy loop index 
    293       REAL(wp) ::   dummy_fac0, dummy_fac1, dummy_fac, zsal      ! local scalar 
    294       REAL(wp) ::   zswi0, zswi01, zswibal, zargtemp , zs_zero   !   -      - 
    295       REAL(wp), POINTER, DIMENSION(:,:,:) ::   z_slope_s, zalpha   ! 3D pointer 
     288      REAL(wp) ::   zfac0, zfac1, zsal 
     289      REAL(wp) ::   zswi0, zswi01, zargtemp , zs_zero    
     290      REAL(wp), POINTER, DIMENSION(:,:,:) ::   z_slope_s, zalpha 
     291      REAL(wp), PARAMETER :: zsi0 = 3.5_wp 
     292      REAL(wp), PARAMETER :: zsi1 = 4.5_wp 
    296293      !!------------------------------------------------------------------ 
    297294 
    … …  
    301298      ! Vertically constant, constant in time 
    302299      !--------------------------------------- 
    303       IF(  num_sal == 1  )   s_i(:,:,:,:) = bulk_sal 
     300      IF(  nn_icesal == 1  )   s_i(:,:,:,:) = rn_icesal 
    304301 
    305302      !----------------------------------- 
    306303      ! Salinity profile, varying in time 
    307304      !----------------------------------- 
    308       IF(  num_sal == 2  ) THEN 
     305      IF(  nn_icesal == 2  ) THEN 
    309306         ! 
    310307         DO jk = 1, nlay_i 
    … …  
    315312            DO jj = 1, jpj 
    316313               DO ji = 1, jpi 
    317                   z_slope_s(ji,jj,jl) = 2._wp * sm_i(ji,jj,jl) / MAX( epsi10 , ht_i(ji,jj,jl) ) 
    318                END DO 
    319             END DO 
    320          END DO 
    321          ! 
    322          dummy_fac0 = 1._wp / ( s_i_0 - s_i_1 )       ! Weighting factor between zs_zero and zs_inf 
    323          dummy_fac1 = s_i_1 / ( s_i_1 - s_i_0 ) 
     314                  rswitch = MAX( 0._wp , SIGN( 1._wp , ht_i(ji,jj,jl) - epsi20 ) ) 
     315                  z_slope_s(ji,jj,jl) = rswitch * 2._wp * sm_i(ji,jj,jl) / MAX( epsi20 , ht_i(ji,jj,jl) ) 
     316               END DO 
     317            END DO 
     318         END DO 
     319         ! 
     320         zfac0 = 1._wp / ( zsi0 - zsi1 )       ! Weighting factor between zs_zero and zs_inf 
     321         zfac1 = zsi1  / ( zsi1 - zsi0 ) 
    324322         ! 
    325323         zalpha(:,:,:) = 0._wp 
    … …  
    327325            DO jj = 1, jpj 
    328326               DO ji = 1, jpi 
    329                   ! zswi0 = 1 if sm_i le s_i_0 and 0 otherwise 
    330                   zswi0  = MAX( 0._wp   , SIGN( 1._wp  , s_i_0 - sm_i(ji,jj,jl) ) )  
    331                   ! zswi01 = 1 if sm_i is between s_i_0 and s_i_1 and 0 othws  
    332                   zswi01 = ( 1._wp - zswi0 ) * MAX( 0._wp   , SIGN( 1._wp  , s_i_1 - sm_i(ji,jj,jl) ) )  
    333                   ! If 2.sm_i GE sss_m then zswibal = 1 
     327                  ! zswi0 = 1 if sm_i le zsi0 and 0 otherwise 
     328                  zswi0  = MAX( 0._wp   , SIGN( 1._wp  , zsi0 - sm_i(ji,jj,jl) ) )  
     329                  ! zswi01 = 1 if sm_i is between zsi0 and zsi1 and 0 othws  
     330                  zswi01 = ( 1._wp - zswi0 ) * MAX( 0._wp   , SIGN( 1._wp  , zsi1 - sm_i(ji,jj,jl) ) )  
     331                  ! If 2.sm_i GE sss_m then rswitch = 1 
    334332                  ! this is to force a constant salinity profile in the Baltic Sea 
    335                   zswibal = MAX( 0._wp , SIGN( 1._wp , 2._wp * sm_i(ji,jj,jl) - sss_m(ji,jj) ) ) 
    336                   zalpha(ji,jj,jl) = zswi0  + zswi01 * ( sm_i(ji,jj,jl) * dummy_fac0 + dummy_fac1 ) 
    337                   zalpha(ji,jj,jl) = zalpha(ji,jj,jl) * ( 1._wp - zswibal ) 
    338                END DO 
    339             END DO 
    340          END DO 
    341  
    342          dummy_fac = 1._wp / REAL( nlay_i )                   ! Computation of the profile 
     333                  rswitch = MAX( 0._wp , SIGN( 1._wp , 2._wp * sm_i(ji,jj,jl) - sss_m(ji,jj) ) ) 
     334                  zalpha(ji,jj,jl) = zswi0  + zswi01 * ( sm_i(ji,jj,jl) * zfac0 + zfac1 ) 
     335                  zalpha(ji,jj,jl) = zalpha(ji,jj,jl) * ( 1._wp - rswitch ) 
     336               END DO 
     337            END DO 
     338         END DO 
     339 
     340         ! Computation of the profile 
    343341         DO jl = 1, jpl 
    344342            DO jk = 1, nlay_i 
    … …  
    346344                  DO ji = 1, jpi 
    347345                     !                                      ! linear profile with 0 at the surface 
    348                      zs_zero = z_slope_s(ji,jj,jl) * ( REAL(jk,wp) - 0.5_wp ) * ht_i(ji,jj,jl) * dummy_fac 
     346                     zs_zero = z_slope_s(ji,jj,jl) * ( REAL(jk,wp) - 0.5_wp ) * ht_i(ji,jj,jl) * r1_nlay_i 
    349347                     !                                      ! weighting the profile 
    350348                     s_i(ji,jj,jk,jl) = zalpha(ji,jj,jl) * zs_zero + ( 1._wp - zalpha(ji,jj,jl) ) * sm_i(ji,jj,jl) 
    351                   END DO ! ji 
    352                END DO ! jj 
    353             END DO ! jk 
    354          END DO ! jl 
    355          ! 
    356       ENDIF ! num_sal 
     349                     !                                      ! bounding salinity 
     350                     s_i(ji,jj,jk,jl) = MIN( rn_simax, MAX( s_i(ji,jj,jk,jl), rn_simin ) ) 
     351                  END DO 
     352               END DO 
     353            END DO 
     354         END DO 
     355         ! 
     356      ENDIF ! nn_icesal 
    357357 
    358358      !------------------------------------------------------- 
    … …  
    360360      !------------------------------------------------------- 
    361361 
    362       IF(  num_sal == 3  ) THEN      ! Schwarzacher (1959) multiyear salinity profile (mean = 2.30) 
     362      IF(  nn_icesal == 3  ) THEN      ! Schwarzacher (1959) multiyear salinity profile (mean = 2.30) 
    363363         ! 
    364364         sm_i(:,:,:) = 2.30_wp 
    365365         ! 
    366366         DO jl = 1, jpl 
    367 !CDIR NOVERRCHK 
    368367            DO jk = 1, nlay_i 
    369                zargtemp  = ( REAL(jk,wp) - 0.5_wp ) / REAL(nlay_i,wp) 
     368               zargtemp  = ( REAL(jk,wp) - 0.5_wp ) * r1_nlay_i 
    370369               zsal =  1.6_wp * (  1._wp - COS( rpi * zargtemp**(0.407_wp/(0.573_wp+zargtemp)) )  ) 
    371370               s_i(:,:,jk,jl) =  zsal 
    … …  
    373372         END DO 
    374373         ! 
    375       ENDIF ! num_sal 
     374      ENDIF ! nn_icesal 
    376375      ! 
    377376      CALL wrk_dealloc( jpi, jpj, jpl, z_slope_s, zalpha ) 
    … …  
    390389 
    391390      ! Mean sea ice temperature 
     391      vt_i (:,:) = 0._wp 
     392      DO jl = 1, jpl 
     393         vt_i(:,:) = vt_i(:,:) + v_i(:,:,jl) 
     394      END DO 
     395 
    392396      tm_i(:,:) = 0._wp 
    393397      DO jl = 1, jpl 
    … …  
    395399            DO jj = 1, jpj 
    396400               DO ji = 1, jpi 
    397                   rswitch = (  1._wp - MAX( 0._wp , SIGN( 1._wp , - vt_i(ji,jj) + epsi10 ) )  ) 
    398                   tm_i(ji,jj) = tm_i(ji,jj) + rswitch * t_i(ji,jj,jk,jl) * v_i(ji,jj,jl)   & 
    399                      &                      / (  REAL(nlay_i,wp) * MAX( vt_i(ji,jj) , epsi10 )  ) 
    400                END DO 
    401             END DO 
    402          END DO 
    403       END DO 
     401                  rswitch = MAX( 0._wp , SIGN( 1._wp , vt_i(ji,jj) - epsi10 ) ) 
     402                  tm_i(ji,jj) = tm_i(ji,jj) + r1_nlay_i * rswitch * ( t_i(ji,jj,jk,jl) - rt0 ) * v_i(ji,jj,jl)  & 
     403                     &            / MAX( vt_i(ji,jj) , epsi10 ) 
     404               END DO 
     405            END DO 
     406         END DO 
     407      END DO 
     408      tm_i = tm_i + rt0 
    404409 
    405410   END SUBROUTINE lim_var_icetm 
    … …  
    420425      !!------------------------------------------------------------------ 
    421426      ! 
     427      vt_i (:,:) = 0._wp 
     428      DO jl = 1, jpl 
     429         vt_i(:,:) = vt_i(:,:) + v_i(:,:,jl) 
     430      END DO 
     431 
    422432      bv_i(:,:) = 0._wp 
    423433      DO jl = 1, jpl 
    … …  
    425435            DO jj = 1, jpj 
    426436               DO ji = 1, jpi 
    427                   rswitch = (  1._wp - MAX( 0._wp , SIGN( 1._wp , (t_i(ji,jj,jk,jl) - rtt) + epsi10 ) )  ) 
    428                   zbvi  = - rswitch * tmut * s_i(ji,jj,jk,jl) / MIN( t_i(ji,jj,jk,jl) - rtt, - epsi10 )   & 
    429                      &                   * v_i(ji,jj,jl)    / REAL(nlay_i,wp) 
    430                   rswitch = (  1._wp - MAX( 0._wp , SIGN( 1._wp , - vt_i(ji,jj) + epsi10 ) )  ) 
    431                   bv_i(ji,jj) = bv_i(ji,jj) + rswitch * zbvi  / MAX( vt_i(ji,jj) , epsi10 ) 
     437                  rswitch = (  1._wp - MAX( 0._wp , SIGN( 1._wp , (t_i(ji,jj,jk,jl) - rt0) + epsi10 ) )  ) 
     438                  zbvi  = - rswitch * tmut * s_i(ji,jj,jk,jl) / MIN( t_i(ji,jj,jk,jl) - rt0, - epsi10 )   & 
     439                     &                   * v_i(ji,jj,jl) * r1_nlay_i 
     440                  rswitch = (  1._wp - MAX( 0._wp , SIGN( 1._wp , - vt_i(ji,jj) + epsi20 ) )  ) 
     441                  bv_i(ji,jj) = bv_i(ji,jj) + rswitch * zbvi  / MAX( vt_i(ji,jj) , epsi20 ) 
    432442               END DO 
    433443            END DO 
    … …  
    448458      ! 
    449459      INTEGER  ::   ji, jk    ! dummy loop indices 
    450       INTEGER  ::   ii, ij  ! local integers 
    451       REAL(wp) ::   dummy_fac0, dummy_fac1, dummy_fac2, zargtemp, zsal   ! local scalars 
    452       REAL(wp) ::   zalpha, zswi0, zswi01, zswibal, zs_zero              !   -      - 
     460      INTEGER  ::   ii, ij    ! local integers 
     461      REAL(wp) ::   zfac0, zfac1, zargtemp, zsal   ! local scalars 
     462      REAL(wp) ::   zalpha, zswi0, zswi01, zs_zero              !   -      - 
    453463      ! 
    454464      REAL(wp), POINTER, DIMENSION(:) ::   z_slope_s 
     465      REAL(wp), PARAMETER :: zsi0 = 3.5_wp 
     466      REAL(wp), PARAMETER :: zsi1 = 4.5_wp 
    455467      !!--------------------------------------------------------------------- 
    456468 
    … …  
    460472      ! Vertically constant, constant in time 
    461473      !--------------------------------------- 
    462       IF( num_sal == 1 )   s_i_1d(:,:) = bulk_sal 
     474      IF( nn_icesal == 1 )   s_i_1d(:,:) = rn_icesal 
    463475 
    464476      !------------------------------------------------------ 
    … …  
    466478      !------------------------------------------------------ 
    467479 
    468       IF(  num_sal == 2  ) THEN 
     480      IF(  nn_icesal == 2  ) THEN 
    469481         ! 
    470482         DO ji = kideb, kiut          ! Slope of the linear profile zs_zero 
    471             z_slope_s(ji) = 2._wp * sm_i_1d(ji) / MAX( epsi10 , ht_i_1d(ji) ) 
     483            rswitch = MAX( 0._wp , SIGN( 1._wp , ht_i_1d(ji) - epsi20 ) ) 
     484            z_slope_s(ji) = rswitch * 2._wp * sm_i_1d(ji) / MAX( epsi20 , ht_i_1d(ji) ) 
    472485         END DO 
    473486 
    474487         ! Weighting factor between zs_zero and zs_inf 
    475488         !--------------------------------------------- 
    476          dummy_fac0 = 1._wp / ( s_i_0 - s_i_1 ) 
    477          dummy_fac1 = s_i_1 / ( s_i_1 - s_i_0 ) 
    478          dummy_fac2 = 1._wp / REAL(nlay_i,wp) 
    479  
    480 !CDIR NOVERRCHK 
     489         zfac0 = 1._wp / ( zsi0 - zsi1 ) 
     490         zfac1 = zsi1 / ( zsi1 - zsi0 ) 
    481491         DO jk = 1, nlay_i 
    482 !CDIR NOVERRCHK 
    483492            DO ji = kideb, kiut 
    484493               ii =  MOD( npb(ji) - 1 , jpi ) + 1 
    485494               ij =     ( npb(ji) - 1 ) / jpi + 1 
    486                ! zswi0 = 1 if sm_i le s_i_0 and 0 otherwise 
    487                zswi0  = MAX( 0._wp , SIGN( 1._wp  , s_i_0 - sm_i_1d(ji) ) )  
    488                ! zswi01 = 1 if sm_i is between s_i_0 and s_i_1 and 0 othws  
    489                zswi01 = ( 1._wp - zswi0 ) * MAX( 0._wp , SIGN( 1._wp , s_i_1 - sm_i_1d(ji) ) )  
    490                ! if 2.sm_i GE sss_m then zswibal = 1 
     495               ! zswi0 = 1 if sm_i le zsi0 and 0 otherwise 
     496               zswi0  = MAX( 0._wp , SIGN( 1._wp  , zsi0 - sm_i_1d(ji) ) )  
     497               ! zswi01 = 1 if sm_i is between zsi0 and zsi1 and 0 othws  
     498               zswi01 = ( 1._wp - zswi0 ) * MAX( 0._wp , SIGN( 1._wp , zsi1 - sm_i_1d(ji) ) )  
     499               ! if 2.sm_i GE sss_m then rswitch = 1 
    491500               ! this is to force a constant salinity profile in the Baltic Sea 
    492                zswibal = MAX( 0._wp , SIGN( 1._wp , 2._wp * sm_i_1d(ji) - sss_m(ii,ij) ) ) 
     501               rswitch = MAX( 0._wp , SIGN( 1._wp , 2._wp * sm_i_1d(ji) - sss_m(ii,ij) ) ) 
    493502               ! 
    494                zalpha = (  zswi0 + zswi01 * ( sm_i_1d(ji) * dummy_fac0 + dummy_fac1 )  ) * ( 1.0 - zswibal ) 
     503               zalpha = (  zswi0 + zswi01 * ( sm_i_1d(ji) * zfac0 + zfac1 )  ) * ( 1._wp - rswitch ) 
    495504               ! 
    496                zs_zero = z_slope_s(ji) * ( REAL(jk,wp) - 0.5_wp ) * ht_i_1d(ji) * dummy_fac2 
     505               zs_zero = z_slope_s(ji) * ( REAL(jk,wp) - 0.5_wp ) * ht_i_1d(ji) * r1_nlay_i 
    497506               ! weighting the profile 
    498507               s_i_1d(ji,jk) = zalpha * zs_zero + ( 1._wp - zalpha ) * sm_i_1d(ji) 
    499             END DO ! ji 
    500          END DO ! jk 
    501  
    502       ENDIF ! num_sal 
     508               ! bounding salinity 
     509               s_i_1d(ji,jk) = MIN( rn_simax, MAX( s_i_1d(ji,jk), rn_simin ) ) 
     510            END DO  
     511         END DO  
     512 
     513      ENDIF  
    503514 
    504515      !------------------------------------------------------- 
    … …  
    506517      !------------------------------------------------------- 
    507518 
    508       IF( num_sal == 3 ) THEN      ! Schwarzacher (1959) multiyear salinity profile (mean = 2.30) 
     519      IF( nn_icesal == 3 ) THEN      ! Schwarzacher (1959) multiyear salinity profile (mean = 2.30) 
    509520         ! 
    510521         sm_i_1d(:) = 2.30_wp 
    511522         ! 
    512 !CDIR NOVERRCHK 
    513523         DO jk = 1, nlay_i 
    514             zargtemp  = ( REAL(jk,wp) - 0.5_wp ) / REAL(nlay_i,wp) 
    515             zsal =  1.6_wp * (  1._wp - COS( rpi * zargtemp**(0.407_wp/(0.573_wp+zargtemp)) ) ) 
     524            zargtemp  = ( REAL(jk,wp) - 0.5_wp ) * r1_nlay_i 
     525            zsal =  1.6_wp * ( 1._wp - COS( rpi * zargtemp**( 0.407_wp / ( 0.573_wp + zargtemp ) ) ) ) 
    516526            DO ji = kideb, kiut 
    517527               s_i_1d(ji,jk) = zsal 
    … …  
    524534      ! 
    525535   END SUBROUTINE lim_var_salprof1d 
     536 
     537   SUBROUTINE lim_var_zapsmall 
     538      !!------------------------------------------------------------------- 
     539      !!                   ***  ROUTINE lim_var_zapsmall *** 
     540      !! 
     541      !! ** Purpose :   Remove too small sea ice areas and correct fluxes 
     542      !! 
     543      !! history : LIM3.5 - 01-2014 (C. Rousset) original code 
     544      !!------------------------------------------------------------------- 
     545      INTEGER  ::   ji, jj, jl, jk   ! dummy loop indices 
     546      REAL(wp) ::   zsal, zvi, zvs, zei, zes 
     547      !!------------------------------------------------------------------- 
     548      at_i (:,:) = 0._wp 
     549      DO jl = 1, jpl 
     550         at_i(:,:) = at_i(:,:) + a_i(:,:,jl) 
     551      END DO 
     552 
     553      DO jl = 1, jpl 
     554 
     555         !----------------------------------------------------------------- 
     556         ! Zap ice energy and use ocean heat to melt ice 
     557         !----------------------------------------------------------------- 
     558         DO jk = 1, nlay_i 
     559            DO jj = 1 , jpj 
     560               DO ji = 1 , jpi 
     561                  rswitch          = MAX( 0._wp , SIGN( 1._wp, a_i(ji,jj,jl) - epsi10 ) ) 
     562                  rswitch          = MAX( 0._wp , SIGN( 1._wp, at_i(ji,jj  ) - epsi10 ) ) * rswitch 
     563                  rswitch          = MAX( 0._wp , SIGN( 1._wp, v_i(ji,jj,jl) - epsi10 ) ) * rswitch 
     564                  rswitch          = MAX( 0._wp , SIGN( 1._wp, v_i(ji,jj,jl) * rswitch  & 
     565                     &                                       / MAX( a_i(ji,jj,jl), epsi10 ) - epsi10 ) ) * rswitch 
     566                  zei              = e_i(ji,jj,jk,jl) 
     567                  e_i(ji,jj,jk,jl) = e_i(ji,jj,jk,jl) * rswitch 
     568                  t_i(ji,jj,jk,jl) = t_i(ji,jj,jk,jl) * rswitch + rt0 * ( 1._wp - rswitch ) 
     569                  ! update exchanges with ocean 
     570                  hfx_res(ji,jj)   = hfx_res(ji,jj) + ( e_i(ji,jj,jk,jl) - zei ) * r1_rdtice ! W.m-2 <0 
     571               END DO 
     572            END DO 
     573         END DO 
     574 
     575         DO jj = 1 , jpj 
     576            DO ji = 1 , jpi 
     577               rswitch = MAX( 0._wp , SIGN( 1._wp, a_i(ji,jj,jl) - epsi10 ) ) 
     578               rswitch = MAX( 0._wp , SIGN( 1._wp, at_i(ji,jj  ) - epsi10 ) ) * rswitch 
     579               rswitch = MAX( 0._wp , SIGN( 1._wp, v_i(ji,jj,jl) - epsi10 ) ) * rswitch 
     580               rswitch = MAX( 0._wp , SIGN( 1._wp, v_i(ji,jj,jl) * rswitch  & 
     581                  &                              / MAX( a_i(ji,jj,jl), epsi10 ) - epsi10 ) ) * rswitch 
     582               zsal = smv_i(ji,jj,  jl) 
     583               zvi  = v_i  (ji,jj,  jl) 
     584               zvs  = v_s  (ji,jj,  jl) 
     585               zes  = e_s  (ji,jj,1,jl) 
     586               !----------------------------------------------------------------- 
     587               ! Zap snow energy  
     588               !----------------------------------------------------------------- 
     589               t_s(ji,jj,1,jl) = t_s(ji,jj,1,jl) * rswitch + rt0 * ( 1._wp - rswitch ) 
     590               e_s(ji,jj,1,jl) = e_s(ji,jj,1,jl) * rswitch 
     591 
     592               !----------------------------------------------------------------- 
     593               ! zap ice and snow volume, add water and salt to ocean 
     594               !----------------------------------------------------------------- 
     595               ato_i(ji,jj)    = a_i  (ji,jj,jl) * ( 1._wp - rswitch ) + ato_i(ji,jj) 
     596               a_i  (ji,jj,jl) = a_i  (ji,jj,jl) * rswitch 
     597               v_i  (ji,jj,jl) = v_i  (ji,jj,jl) * rswitch 
     598               v_s  (ji,jj,jl) = v_s  (ji,jj,jl) * rswitch 
     599               t_su (ji,jj,jl) = t_su (ji,jj,jl) * rswitch + t_bo(ji,jj) * ( 1._wp - rswitch ) 
     600               oa_i (ji,jj,jl) = oa_i (ji,jj,jl) * rswitch 
     601               smv_i(ji,jj,jl) = smv_i(ji,jj,jl) * rswitch 
     602 
     603               ! update exchanges with ocean 
     604               sfx_res(ji,jj)  = sfx_res(ji,jj) - ( smv_i(ji,jj,jl) - zsal ) * rhoic * r1_rdtice 
     605               wfx_res(ji,jj)  = wfx_res(ji,jj) - ( v_i(ji,jj,jl)   - zvi  ) * rhoic * r1_rdtice 
     606               wfx_snw(ji,jj)  = wfx_snw(ji,jj) - ( v_s(ji,jj,jl)   - zvs  ) * rhosn * r1_rdtice 
     607               hfx_res(ji,jj)  = hfx_res(ji,jj) + ( e_s(ji,jj,1,jl) - zes ) * r1_rdtice ! W.m-2 <0 
     608            END DO 
     609         END DO 
     610      END DO  
     611 
     612      ! to be sure that at_i is the sum of a_i(jl) 
     613      at_i (:,:) = 0._wp 
     614      DO jl = 1, jpl 
     615         at_i(:,:) = at_i(:,:) + a_i(:,:,jl) 
     616      END DO 
     617 
     618      ! open water = 1 if at_i=0 
     619      DO jj = 1, jpj 
     620         DO ji = 1, jpi 
     621            rswitch      = MAX( 0._wp , SIGN( 1._wp, - at_i(ji,jj) ) ) 
     622            ato_i(ji,jj) = rswitch + (1._wp - rswitch ) * ato_i(ji,jj) 
     623         END DO 
     624      END DO 
     625 
     626      ! 
     627   END SUBROUTINE lim_var_zapsmall 
     628 
     629   SUBROUTINE lim_var_itd( zhti, zhts, zai, zht_i, zht_s, za_i ) 
     630      !!------------------------------------------------------------------ 
     631      !!                ***  ROUTINE lim_var_itd   *** 
     632      !! 
     633      !! ** Purpose :  converting 1-cat ice to multiple ice categories 
     634      !! 
     635      !!                  ice thickness distribution follows a gaussian law 
     636      !!               around the concentration of the most likely ice thickness 
     637      !!                           (similar as limistate.F90) 
     638      !! 
     639      !! ** Method:   Iterative procedure 
     640      !!                 
     641      !!               1) Try to fill the jpl ice categories (bounds hi_max(0:jpl)) with a gaussian 
     642      !! 
     643      !!               2) Check whether the distribution conserves area and volume, positivity and 
     644      !!                  category boundaries 
     645      !!               
     646      !!               3) If not (input ice is too thin), the last category is empty and 
     647      !!                  the number of categories is reduced (jpl-1) 
     648      !! 
     649      !!               4) Iterate until ok (SUM(itest(:) = 4) 
     650      !! 
     651      !! ** Arguments : zhti: 1-cat ice thickness 
     652      !!                zhts: 1-cat snow depth 
     653      !!                zai : 1-cat ice concentration 
     654      !! 
     655      !! ** Output    : jpl-cat  
     656      !! 
     657      !!  (Example of application: BDY forcings when input are cell averaged)   
     658      !! 
     659      !!------------------------------------------------------------------- 
     660      !! History : LIM3.5 - 2012    (M. Vancoppenolle)  Original code 
     661      !!                    2014    (C. Rousset)        Rewriting 
     662      !!------------------------------------------------------------------- 
     663      !! Local variables 
     664      INTEGER  :: ji, jk, jl             ! dummy loop indices 
     665      INTEGER  :: ijpij, i_fill, jl0   
     666      REAL(wp) :: zarg, zV, zconv, zdh 
     667      REAL(wp), DIMENSION(:),   INTENT(in)    ::   zhti, zhts, zai    ! input ice/snow variables 
     668      REAL(wp), DIMENSION(:,:), INTENT(inout) ::   zht_i, zht_s, za_i ! output ice/snow variables 
     669      INTEGER , POINTER, DIMENSION(:)         ::   itest 
     670  
     671      CALL wrk_alloc( 4, itest ) 
     672      !-------------------------------------------------------------------- 
     673      ! initialisation of variables 
     674      !-------------------------------------------------------------------- 
     675      ijpij = SIZE(zhti,1) 
     676      zht_i(1:ijpij,1:jpl) = 0._wp 
     677      zht_s(1:ijpij,1:jpl) = 0._wp 
     678      za_i (1:ijpij,1:jpl) = 0._wp 
     679 
     680      ! ---------------------------------------- 
     681      ! distribution over the jpl ice categories 
     682      ! ---------------------------------------- 
     683      DO ji = 1, ijpij 
     684          
     685         IF( zhti(ji) > 0._wp ) THEN 
     686 
     687         ! initialisation of tests 
     688         itest(:)  = 0 
     689          
     690         i_fill = jpl + 1                                             !==================================== 
     691         DO WHILE ( ( SUM( itest(:) ) /= 4 ) .AND. ( i_fill >= 2 ) )  ! iterative loop on i_fill categories   
     692            ! iteration                                               !==================================== 
     693            i_fill = i_fill - 1 
     694             
     695            ! initialisation of ice variables for each try 
     696            zht_i(ji,1:jpl) = 0._wp 
     697            za_i (ji,1:jpl) = 0._wp 
     698             
     699            ! *** case very thin ice: fill only category 1 
     700            IF ( i_fill == 1 ) THEN 
     701               zht_i(ji,1) = zhti(ji) 
     702               za_i (ji,1) = zai (ji) 
     703 
     704            ! *** case ice is thicker: fill categories >1 
     705            ELSE 
     706 
     707               ! Fill ice thicknesses except the last one (i_fill) by hmean  
     708               DO jl = 1, i_fill - 1 
     709                  zht_i(ji,jl) = hi_mean(jl) 
     710               END DO 
     711                
     712               ! find which category (jl0) the input ice thickness falls into 
     713               jl0 = i_fill 
     714               DO jl = 1, i_fill 
     715                  IF ( ( zhti(ji) >= hi_max(jl-1) ) .AND. ( zhti(ji) < hi_max(jl) ) ) THEN 
     716                     jl0 = jl 
     717           CYCLE 
     718                  ENDIF 
     719               END DO 
     720                
     721               ! Concentrations in the (i_fill-1) categories  
     722               za_i(ji,jl0) = zai(ji) / SQRT(REAL(jpl)) 
     723               DO jl = 1, i_fill - 1 
     724                  IF ( jl == jl0 ) CYCLE 
     725                  zarg        = ( zht_i(ji,jl) - zhti(ji) ) / ( zhti(ji) * 0.5_wp ) 
     726                  za_i(ji,jl) =   za_i (ji,jl0) * EXP(-zarg**2) 
     727               END DO 
     728                
     729               ! Concentration in the last (i_fill) category 
     730               za_i(ji,i_fill) = zai(ji) - SUM( za_i(ji,1:i_fill-1) ) 
     731                
     732               ! Ice thickness in the last (i_fill) category 
     733               zV = SUM( za_i(ji,1:i_fill-1) * zht_i(ji,1:i_fill-1) ) 
     734               zht_i(ji,i_fill) = ( zhti(ji) * zai(ji) - zV ) / za_i(ji,i_fill)  
     735                
     736            ENDIF ! case ice is thick or thin 
     737             
     738            !--------------------- 
     739            ! Compatibility tests 
     740            !---------------------  
     741            ! Test 1: area conservation 
     742            zconv = ABS( zai(ji) - SUM( za_i(ji,1:jpl) ) ) 
     743            IF ( zconv < epsi06 ) itest(1) = 1 
     744             
     745            ! Test 2: volume conservation 
     746            zconv = ABS( zhti(ji)*zai(ji) - SUM( za_i(ji,1:jpl)*zht_i(ji,1:jpl) ) ) 
     747            IF ( zconv < epsi06 ) itest(2) = 1 
     748             
     749            ! Test 3: thickness of the last category is in-bounds ? 
     750            IF ( zht_i(ji,i_fill) >= hi_max(i_fill-1) ) itest(3) = 1 
     751             
     752            ! Test 4: positivity of ice concentrations 
     753            itest(4) = 1 
     754            DO jl = 1, i_fill 
     755               IF ( za_i(ji,jl) < 0._wp ) itest(4) = 0 
     756            END DO             
     757                                                           !============================ 
     758         END DO                                            ! end iteration on categories 
     759                                                           !============================ 
     760         ENDIF ! if zhti > 0 
     761      END DO ! i loop 
     762 
     763      ! ------------------------------------------------ 
     764      ! Adding Snow in each category where za_i is not 0 
     765      ! ------------------------------------------------  
     766      DO jl = 1, jpl 
     767         DO ji = 1, ijpij 
     768            IF( za_i(ji,jl) > 0._wp ) THEN 
     769               zht_s(ji,jl) = zht_i(ji,jl) * ( zhts(ji) / zhti(ji) ) 
     770               ! In case snow load is in excess that would lead to transformation from snow to ice 
     771               ! Then, transfer the snow excess into the ice (different from limthd_dh) 
     772               zdh = MAX( 0._wp, ( rhosn * zht_s(ji,jl) + ( rhoic - rau0 ) * zht_i(ji,jl) ) * r1_rau0 )  
     773               ! recompute ht_i, ht_s avoiding out of bounds values 
     774               zht_i(ji,jl) = MIN( hi_max(jl), zht_i(ji,jl) + zdh ) 
     775               zht_s(ji,jl) = MAX( 0._wp, zht_s(ji,jl) - zdh * rhoic * r1_rhosn ) 
     776            ENDIF 
     777         ENDDO 
     778      ENDDO 
     779 
     780      CALL wrk_dealloc( 4, itest ) 
     781      ! 
     782    END SUBROUTINE lim_var_itd 
     783 
    526784 
    527785#else 
    … …  
    542800   SUBROUTINE lim_var_salprof1d    ! Emtpy routines 
    543801   END SUBROUTINE lim_var_salprof1d 
     802   SUBROUTINE lim_var_zapsmall 
     803   END SUBROUTINE lim_var_zapsmall 
     804   SUBROUTINE lim_var_itd 
     805   END SUBROUTINE lim_var_itd 
    544806#endif 
    545807 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/LIM_SRC_3/limwri.F90

    r5312 r5313  
    2424   USE lib_mpp         ! MPP library 
    2525   USE wrk_nemo        ! work arrays 
    26    USE par_ice 
    2726   USE iom 
    2827   USE timing          ! Timing 
    … …  
    7372      ! Mean category values 
    7473      !----------------------------- 
     74      z1_365 = 1._wp / 365._wp 
    7575 
    7676      CALL lim_var_icetm      ! mean sea ice temperature 
    … …  
    107107         DO jj = 2 , jpjm1 
    108108            DO ji = 2 , jpim1 
    109                z2da(ji,jj)  = (  u_ice(ji,jj) * tmu(ji,jj) + u_ice(ji-1,jj) * tmu(ji-1,jj) ) * 0.5_wp 
    110                z2db(ji,jj)  = (  v_ice(ji,jj) * tmv(ji,jj) + v_ice(ji,jj-1) * tmv(ji,jj-1) ) * 0.5_wp 
     109               z2da(ji,jj)  = (  u_ice(ji,jj) * umask(ji,jj,1) + u_ice(ji-1,jj) * umask(ji-1,jj,1) ) * 0.5_wp 
     110               z2db(ji,jj)  = (  v_ice(ji,jj) * vmask(ji,jj,1) + v_ice(ji,jj-1) * vmask(ji,jj-1,1) ) * 0.5_wp 
    111111           END DO 
    112112         END DO 
    113113         CALL lbc_lnk( z2da, 'T', -1. ) 
    114114         CALL lbc_lnk( z2db, 'T', -1. ) 
    115          CALL iom_put( "uice_ipa"     , z2da                )       ! ice velocity u component 
    116          CALL iom_put( "vice_ipa"     , z2db                )       ! ice velocity v component 
     115         CALL iom_put( "uice_ipa"     , z2da             )       ! ice velocity u component 
     116         CALL iom_put( "vice_ipa"     , z2db             )       ! ice velocity v component 
    117117         DO jj = 1, jpj                                  
    118118            DO ji = 1, jpi 
    … …  
    120120            END DO 
    121121         END DO 
    122          CALL iom_put( "icevel"       , z2d                 )       ! ice velocity module 
     122         CALL iom_put( "icevel"       , z2d              )       ! ice velocity module 
    123123      ENDIF 
    124124      ! 
    … …  
    128128            DO jj = 1, jpj 
    129129               DO ji = 1, jpi 
    130                   z2d(ji,jj) = z2d(ji,jj) + zswi(ji,jj) * oa_i(ji,jj,jl) 
     130                  rswitch    = MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) - 0.1 ) ) 
     131                  z2d(ji,jj) = z2d(ji,jj) + rswitch * oa_i(ji,jj,jl) / MAX( at_i(ji,jj), 0.1 ) 
    131132               END DO 
    132133            END DO 
    133134         END DO 
    134          z1_365 = 1._wp / 365._wp 
    135          CALL iom_put( "miceage"     , z2d * z1_365         )        ! mean ice age 
     135         CALL iom_put( "miceage"     , z2d * z1_365      )        ! mean ice age 
    136136      ENDIF 
    137137 
    … …  
    139139         DO jj = 1, jpj 
    140140            DO ji = 1, jpi 
    141                z2d(ji,jj) = ( tm_i(ji,jj) - rtt ) * zswi(ji,jj) 
    142             END DO 
    143          END DO 
    144          CALL iom_put( "micet"       , z2d                  )        ! mean ice temperature 
     141               z2d(ji,jj) = ( tm_i(ji,jj) - rt0 ) * zswi(ji,jj) 
     142            END DO 
     143         END DO 
     144         CALL iom_put( "micet"       , z2d               )        ! mean ice temperature 
    145145      ENDIF 
    146146      ! 
    … …  
    150150            DO jj = 1, jpj 
    151151               DO ji = 1, jpi 
    152                   z2d(ji,jj) = z2d(ji,jj) + zswi(ji,jj) * ( t_su(ji,jj,jl) - rtt ) * a_i(ji,jj,jl) / MAX( at_i(ji,jj) , epsi06 ) 
     152                  z2d(ji,jj) = z2d(ji,jj) + zswi(ji,jj) * ( t_su(ji,jj,jl) - rt0 ) * a_i(ji,jj,jl) / MAX( at_i(ji,jj) , epsi06 ) 
    153153               END DO 
    154154            END DO 
    155155         END DO 
    156          CALL iom_put( "icest"       , z2d                 )        ! ice surface temperature 
     156         CALL iom_put( "icest"       , z2d              )        ! ice surface temperature 
    157157      ENDIF 
    158158 
    … …  
    164164            END DO 
    165165         END DO 
    166          CALL iom_put( "icecolf"     , z2d                 )        ! frazil ice collection thickness 
     166         CALL iom_put( "icecolf"     , z2d              )        ! frazil ice collection thickness 
    167167      ENDIF 
    168168 
    … …  
    186186      CALL iom_put( "icetrp"      , diag_trp_vi * rday  )        ! ice volume transport 
    187187      CALL iom_put( "snwtrp"      , diag_trp_vs * rday  )        ! snw volume transport 
     188      CALL iom_put( "saltrp"      , diag_trp_smv * rday * rhoic ) ! salt content transport 
    188189      CALL iom_put( "deitrp"      , diag_trp_ei         )        ! advected ice enthalpy (W/m2) 
    189190      CALL iom_put( "destrp"      , diag_trp_es         )        ! advected snw enthalpy (W/m2) 
    … …  
    200201 
    201202      ztmp = rday / rhoic 
    202       CALL iom_put( "vfxres"     , wfx_res * ztmp  )             ! daily prod./melting due to limupdate  
    203       CALL iom_put( "vfxopw"     , wfx_opw * ztmp  )             ! daily lateral thermodynamic ice production 
    204       CALL iom_put( "vfxsni"     , wfx_sni * ztmp  )             ! daily snowice ice production 
    205       CALL iom_put( "vfxbog"     , wfx_bog * ztmp  )             ! daily bottom thermodynamic ice production 
    206       CALL iom_put( "vfxdyn"     , wfx_dyn * ztmp  )             ! daily dynamic ice production (rid/raft) 
    207       CALL iom_put( "vfxsum"     , wfx_sum * ztmp  )             ! surface melt  
    208       CALL iom_put( "vfxbom"     , wfx_bom * ztmp  )             ! bottom melt  
    209       CALL iom_put( "vfxice"     , wfx_ice * ztmp  )             ! total ice growth/melt  
    210       CALL iom_put( "vfxsnw"     , wfx_snw * ztmp  )             ! total snw growth/melt  
    211       CALL iom_put( "vfxsub"     , wfx_sub * ztmp  )             ! sublimation (snow)  
    212       CALL iom_put( "vfxspr"     , wfx_spr * ztmp  )             ! precip (snow)  
    213  
    214       CALL iom_put ('hfxthd', hfx_thd(:,:) )   !   
    215       CALL iom_put ('hfxdyn', hfx_dyn(:,:) )   !   
    216       CALL iom_put ('hfxres', hfx_res(:,:) )   !   
    217       CALL iom_put ('hfxout', hfx_out(:,:) )   !   
    218       CALL iom_put ('hfxin' , hfx_in(:,:) )   !   
    219       CALL iom_put ('hfxsnw', hfx_snw(:,:) )   !   
    220       CALL iom_put ('hfxsub', hfx_sub(:,:) )   !   
    221       CALL iom_put ('hfxerr', hfx_err(:,:) )   !   
    222       CALL iom_put ('hfxerr_rem', hfx_err_rem(:,:) )   !   
    223        
    224       CALL iom_put ('hfxsum', hfx_sum(:,:) )   !   
    225       CALL iom_put ('hfxbom', hfx_bom(:,:) )   !   
    226       CALL iom_put ('hfxbog', hfx_bog(:,:) )   !   
    227       CALL iom_put ('hfxdif', hfx_dif(:,:) )   !   
    228       CALL iom_put ('hfxopw', hfx_opw(:,:) )   !   
    229       CALL iom_put ('hfxtur', fhtur(:,:) * at_i(:,:) )   ! turbulent heat flux at ice base  
    230       CALL iom_put ('hfxdhc', diag_heat_dhc(:,:) )          ! Heat content variation in snow and ice  
    231       CALL iom_put ('hfxspr', hfx_spr(:,:) )          ! Heat content of snow precip  
     203      CALL iom_put( "vfxres"     , wfx_res * ztmp       )        ! daily prod./melting due to limupdate  
     204      CALL iom_put( "vfxopw"     , wfx_opw * ztmp       )        ! daily lateral thermodynamic ice production 
     205      CALL iom_put( "vfxsni"     , wfx_sni * ztmp       )        ! daily snowice ice production 
     206      CALL iom_put( "vfxbog"     , wfx_bog * ztmp       )        ! daily bottom thermodynamic ice production 
     207      CALL iom_put( "vfxdyn"     , wfx_dyn * ztmp       )        ! daily dynamic ice production (rid/raft) 
     208      CALL iom_put( "vfxsum"     , wfx_sum * ztmp       )        ! surface melt  
     209      CALL iom_put( "vfxbom"     , wfx_bom * ztmp       )        ! bottom melt  
     210      CALL iom_put( "vfxice"     , wfx_ice * ztmp       )        ! total ice growth/melt  
     211      CALL iom_put( "vfxsnw"     , wfx_snw * ztmp       )        ! total snw growth/melt  
     212      CALL iom_put( "vfxsub"     , wfx_sub * ztmp       )        ! sublimation (snow)  
     213      CALL iom_put( "vfxspr"     , wfx_spr * ztmp       )        ! precip (snow) 
     214       
     215      CALL iom_put( "afxtot"     , afx_tot * rday       )        ! concentration tendency (total) 
     216      CALL iom_put( "afxdyn"     , afx_dyn * rday       )        ! concentration tendency (dynamics) 
     217      CALL iom_put( "afxthd"     , afx_thd * rday       )        ! concentration tendency (thermo) 
     218 
     219      CALL iom_put ('hfxthd'     , hfx_thd(:,:)         )   !   
     220      CALL iom_put ('hfxdyn'     , hfx_dyn(:,:)         )   !   
     221      CALL iom_put ('hfxres'     , hfx_res(:,:)         )   !   
     222      CALL iom_put ('hfxout'     , hfx_out(:,:)         )   !   
     223      CALL iom_put ('hfxin'      , hfx_in(:,:)          )   !   
     224      CALL iom_put ('hfxsnw'     , hfx_snw(:,:)         )   !   
     225      CALL iom_put ('hfxsub'     , hfx_sub(:,:)         )   !   
     226      CALL iom_put ('hfxerr'     , hfx_err(:,:)         )   !   
     227      CALL iom_put ('hfxerr_rem' , hfx_err_rem(:,:)     )   !   
     228       
     229      CALL iom_put ('hfxsum'     , hfx_sum(:,:)         )   !   
     230      CALL iom_put ('hfxbom'     , hfx_bom(:,:)         )   !   
     231      CALL iom_put ('hfxbog'     , hfx_bog(:,:)         )   !   
     232      CALL iom_put ('hfxdif'     , hfx_dif(:,:)         )   !   
     233      CALL iom_put ('hfxopw'     , hfx_opw(:,:)         )   !   
     234      CALL iom_put ('hfxtur'     , fhtur(:,:) * at_i(:,:) ) ! turbulent heat flux at ice base  
     235      CALL iom_put ('hfxdhc'     , diag_heat(:,:)       )   ! Heat content variation in snow and ice  
     236      CALL iom_put ('hfxspr'     , hfx_spr(:,:)         )   ! Heat content of snow precip  
    232237       
    233238      !-------------------------------- 
    … …  
    244249            DO jj = 1, jpj 
    245250               DO ji = 1, jpi 
    246                   rswitch = MAX( 0._wp , SIGN( 1._wp , a_i(ji,jj,jl) - epsi06 ) ) 
    247                   zoi(ji,jj,jl) = oa_i(ji,jj,jl)  / MAX( a_i(ji,jj,jl) , epsi06 ) * rswitch 
     251                  rswitch = MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) - 0.1 ) ) 
     252                  rswitch = rswitch * MAX( 0._wp , SIGN( 1._wp , a_i(ji,jj,jl) - 0.1 ) ) 
     253                  zoi(ji,jj,jl) = oa_i(ji,jj,jl)  / MAX( a_i(ji,jj,jl) , 0.1 ) * rswitch 
    248254               END DO 
    249255            END DO 
    250256         END DO 
    251          CALL iom_put( "iceage_cat"     , zoi        )        ! ice age for categories 
     257         CALL iom_put( "iceage_cat"   , zoi * z1_365 )        ! ice age for categories 
    252258      ENDIF 
    253259 
    … …  
    260266                  DO ji = 1, jpi 
    261267                     rswitch = MAX( 0._wp , SIGN( 1._wp , a_i(ji,jj,jl) - epsi06 ) ) 
    262                      zei(ji,jj,jl) = zei(ji,jj,jl) + 100.0* & 
    263                         ( - tmut * s_i(ji,jj,jk,jl) / MIN( ( t_i(ji,jj,jk,jl) - rtt ), - epsi06 ) ) * & 
    264                         rswitch / nlay_i 
     268                     zei(ji,jj,jl) = zei(ji,jj,jl) + 100.0 * & 
     269                        ( - tmut * s_i(ji,jj,jk,jl) / MIN( ( t_i(ji,jj,jk,jl) - rt0 ), - epsi06 ) ) * & 
     270                        rswitch * r1_nlay_i 
    265271                  END DO 
    266272               END DO 
    267273            END DO 
    268274         END DO 
    269          CALL iom_put( "brinevol_cat"     , zei         )        ! brine volume for categories 
     275         CALL iom_put( "brinevol_cat"     , zei      )        ! brine volume for categories 
    270276      ENDIF 
    271277 
    … …  
    348354      CALL histwrite( kid, "iicethic", kt, icethi        , jpi*jpj, (/1/) )     
    349355      CALL histwrite( kid, "iiceconc", kt, at_i          , jpi*jpj, (/1/) ) 
    350       CALL histwrite( kid, "iicetemp", kt, tm_i - rtt    , jpi*jpj, (/1/) ) 
     356      CALL histwrite( kid, "iicetemp", kt, tm_i - rt0    , jpi*jpj, (/1/) ) 
    351357      CALL histwrite( kid, "iicevelu", kt, u_ice          , jpi*jpj, (/1/) ) 
    352358      CALL histwrite( kid, "iicevelv", kt, v_ice          , jpi*jpj, (/1/) ) 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/LIM_SRC_3/limwri_dimg.h90

    r5312 r5313  
    9292         zinda  = MAX( 0._wp , SIGN( 1._wp , ( 1.0 - frld(ji,jj) ) - 0.10 ) ) 
    9393         zindb  = zindh * zinda 
    94          ztmu   = MAX( 0.5 * 1._wp , ( tmu(ji,jj) + tmu(ji+1,jj) + tmu(ji,jj+1) + tmu(ji+1,jj+1) ) )  
     94         ztmu   = MAX( 0.5 * 1._wp , ( umask(ji,jj,1) + umask(ji+1,jj,1) + umask(ji,jj+1,1) + umask(ji+1,jj+1,1) ) )  
    9595         zcmo(ji,jj,1)  = ht_s (ji,jj,1) 
    9696         zcmo(ji,jj,2)  = ht_i (ji,jj,1) 
    … …  
    9999         zcmo(ji,jj,5)  = sist  (ji,jj) 
    100100         zcmo(ji,jj,6)  = fhtur  (ji,jj) 
    101          zcmo(ji,jj,7)  = zindb * (  u_ice(ji,jj  ) * tmu(ji,jj  ) + u_ice(ji+1,jj  ) * tmu(ji+1,jj  )   & 
    102             + u_ice(ji,jj+1) * tmu(ji,jj+1) + u_ice(ji+1,jj+1) * tmu(ji+1,jj+1) ) & 
     101         zcmo(ji,jj,7)  = zindb * (  u_ice(ji,jj  ) * umask(ji,jj,1) + u_ice(ji+1,jj  ) * umask(ji+1,jj,1)   & 
     102            + u_ice(ji,jj+1) * umask(ji,jj+1,1) + u_ice(ji+1,jj+1) * umask(ji+1,jj+1,1) ) & 
    103103            / ztmu  
    104104 
    105          zcmo(ji,jj,8)  = zindb * (  v_ice(ji,jj  ) * tmu(ji,jj  ) + v_ice(ji+1,jj  ) * tmu(ji+1,jj  )   & 
    106             + v_ice(ji,jj+1) * tmu(ji,jj+1) + v_ice(ji+1,jj+1) * tmu(ji+1,jj+1) ) & 
     105         zcmo(ji,jj,8)  = zindb * (  v_ice(ji,jj  ) * umask(ji,jj,1) + v_ice(ji+1,jj  ) * umask(ji+1,jj,1)   & 
     106            + v_ice(ji,jj+1) * umask(ji,jj+1,1) + v_ice(ji+1,jj+1) * umask(ji+1,jj+1,1) ) & 
    107107            / ztmu 
    108108         zcmo(ji,jj,9)  = sst_m(ji,jj) 
    … …  
    135135               zinda  = MAX( 0._wp , SIGN( 1._wp , ( 1.0 - frld(ji,jj) ) - 0.10 ) ) 
    136136               zindb  = zindh * zinda 
    137                ztmu   = MAX( 0.5 * 1._wp , ( tmu(ji,jj) + tmu(ji+1,jj) + tmu(ji,jj+1) + tmu(ji+1,jj+1) ) ) 
     137               ztmu   = MAX( 0.5 * 1._wp , ( umask(ji,jj,1) + umask(ji+1,jj,1) + umask(ji,jj+1,1) + umask(ji+1,jj+1,1) ) ) 
    138138               rcmoy(ji,jj,1)  = ht_s (ji,jj,1) 
    139139               rcmoy(ji,jj,2)  = ht_i (ji,jj,1) 
    … …  
    142142               rcmoy(ji,jj,5)  = sist  (ji,jj) 
    143143               rcmoy(ji,jj,6)  = fhtur  (ji,jj) 
    144                rcmoy(ji,jj,7)  = zindb * (  u_ice(ji,jj  ) * tmu(ji,jj  ) + u_ice(ji+1,jj  ) * tmu(ji+1,jj  )   & 
    145                   + u_ice(ji,jj+1) * tmu(ji,jj+1) + u_ice(ji+1,jj+1) * tmu(ji+1,jj+1) ) & 
     144               rcmoy(ji,jj,7)  = zindb * (  u_ice(ji,jj  ) * umask(ji,jj,1) + u_ice(ji+1,jj  ) * umask(ji+1,jj,1)   & 
     145                  + u_ice(ji,jj+1) * umask(ji,jj+1,1) + u_ice(ji+1,jj+1) * umask(ji+1,jj+1,1) ) & 
    146146                  / ztmu 
    147147 
    148                rcmoy(ji,jj,8)  = zindb * (  v_ice(ji,jj  ) * tmu(ji,jj  ) + v_ice(ji+1,jj  ) * tmu(ji+1,jj  )   & 
    149                   + v_ice(ji,jj+1) * tmu(ji,jj+1) + v_ice(ji+1,jj+1) * tmu(ji+1,jj+1) ) & 
     148               rcmoy(ji,jj,8)  = zindb * (  v_ice(ji,jj  ) * umask(ji,jj,1) + v_ice(ji+1,jj  ) * umask(ji+1,jj,1)   & 
     149                  + v_ice(ji,jj+1) * umask(ji,jj+1,1) + v_ice(ji+1,jj+1) * umask(ji+1,jj+1,1) ) & 
    150150                  / ztmu 
    151151               rcmoy(ji,jj,9)  = sst_m(ji,jj) 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/LIM_SRC_3/thd_ice.F90

    r5312 r5313  
    66   !! History :  3.0  !  2002-11  (C. Ethe)  F90: Free form and module 
    77   !!---------------------------------------------------------------------- 
    8    USE par_ice        ! LIM-3 parameters 
    98   USE in_out_manager ! I/O manager 
    109   USE lib_mpp        ! MPP library 
     10   USE ice, ONLY :   nlay_i, nlay_s 
    1111 
    1212   IMPLICIT NONE 
    … …  
    1919   !!--------------------------- 
    2020   !                               !!! ** ice-thermo namelist (namicethd) ** 
    21    REAL(wp), PUBLIC ::   hmelt       !: maximum melting at the bottom; active only for one category 
    22    REAL(wp), PUBLIC ::   hiclim      !: minimum ice thickness 
    23    REAL(wp), PUBLIC ::   hnzst       !: thick. of the surf. layer in temp. comp. 
    24    REAL(wp), PUBLIC ::   parsub      !: switch for snow sublimation or not 
    25    REAL(wp), PUBLIC ::   maxfrazb    !: maximum portion of frazil ice collecting at the ice bottom 
    26    REAL(wp), PUBLIC ::   vfrazb      !: threshold drift speed for collection of bottom frazil ice 
    27    REAL(wp), PUBLIC ::   Cfrazb      !: squeezing coefficient for collection of bottom frazil ice 
    28    REAL(wp), PUBLIC ::   hiccrit     !: ice th. for lateral accretion in the NH (SH) (m) 
     21   REAL(wp), PUBLIC ::   rn_himin    !: minimum ice thickness 
     22   REAL(wp), PUBLIC ::   rn_maxfrazb !: maximum portion of frazil ice collecting at the ice bottom 
     23   REAL(wp), PUBLIC ::   rn_vfrazb   !: threshold drift speed for collection of bottom frazil ice 
     24   REAL(wp), PUBLIC ::   rn_Cfrazb   !: squeezing coefficient for collection of bottom frazil ice 
     25   REAL(wp), PUBLIC ::   rn_hnewice  !: thickness for new ice formation (m) 
    2926 
    30    INTEGER , PUBLIC ::   fraz_swi    !: use of frazil ice collection in function of wind (1) or not (0) 
     27   LOGICAL , PUBLIC ::   ln_frazil   !: use of frazil ice collection as function of wind (T) or not (F) 
    3128 
    3229   !!----------------------------- 
    … …  
    3734   !: are the variables corresponding to 2d vectors 
    3835 
    39    INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   npb    !: number of points where computations has to be done 
    40    INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   npac   !: correspondance between points (lateral accretion) 
     36   INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   npb    !: address vector for 1d vertical thermo computations 
     37   INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   nplm   !: address vector for mono-category lateral melting 
     38   INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   npac   !: address vector for new ice formation 
    4139 
    4240   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   qlead_1d      
    … …  
    5654   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   hfx_err_1d 
    5755   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   hfx_err_rem_1d 
     56   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   hfx_err_dif_1d 
    5857 
    5958   ! heat flux associated with ice-atmosphere mass exchange 
    … …  
    140139      !!---------------------------------------------------------------------! 
    141140 
    142       ALLOCATE( npb      (jpij) , npac     (jpij),                          & 
    143          !                                                                  ! 
    144          &      qlead_1d (jpij) , ftr_ice_1d  (jpij) ,     & 
    145          &      qsr_ice_1d (jpij) ,     & 
    146          &      fr1_i0_1d(jpij) , fr2_i0_1d(jpij) , qns_ice_1d(jpij) ,     & 
    147          &      t_bo_1d   (jpij) ,                                          & 
    148          &      hfx_sum_1d(jpij) , hfx_bom_1d(jpij) ,hfx_bog_1d(jpij) ,     &  
    149          &      hfx_dif_1d(jpij) ,hfx_opw_1d(jpij) , & 
    150          &      hfx_thd_1d(jpij) , hfx_spr_1d(jpij) , & 
    151          &      hfx_snw_1d(jpij) , hfx_sub_1d(jpij) , hfx_err_1d(jpij) , & 
    152          &      hfx_res_1d(jpij) , hfx_err_rem_1d(jpij),       STAT=ierr(1) ) 
     141      ALLOCATE( npb      (jpij) , nplm      (jpij) , npac       (jpij) ,   & 
     142         &      qlead_1d (jpij) , ftr_ice_1d(jpij) , qsr_ice_1d (jpij) ,   & 
     143         &      fr1_i0_1d(jpij) , fr2_i0_1d (jpij) , qns_ice_1d(jpij)  ,   & 
     144         &      t_bo_1d   (jpij) ,                                         & 
     145         &      hfx_sum_1d(jpij) , hfx_bom_1d(jpij) ,hfx_bog_1d(jpij) ,    &  
     146         &      hfx_dif_1d(jpij) , hfx_opw_1d(jpij) ,                      & 
     147         &      hfx_thd_1d(jpij) , hfx_spr_1d(jpij) ,                      & 
     148         &      hfx_snw_1d(jpij) , hfx_sub_1d(jpij) , hfx_err_1d(jpij) ,   & 
     149         &      hfx_res_1d(jpij) , hfx_err_rem_1d(jpij) , hfx_err_dif_1d(jpij) , STAT=ierr(1) ) 
    153150      ! 
    154       ALLOCATE( sprecip_1d (jpij) , frld_1d    (jpij) , at_i_1d     (jpij) ,     & 
    155          &      fhtur_1d   (jpij) , wfx_snw_1d (jpij) , wfx_spr_1d (jpij) ,     & 
    156          &      fhld_1d    (jpij) , wfx_sub_1d (jpij) , wfx_bog_1d(jpij) , wfx_bom_1d(jpij) , & 
    157          &      wfx_sum_1d(jpij)  , wfx_sni_1d (jpij) , wfx_opw_1d (jpij) ,  wfx_res_1d (jpij) ,  & 
    158          &      dqns_ice_1d(jpij) , qla_ice_1d (jpij) , dqla_ice_1d(jpij) ,     & 
    159          &      tatm_ice_1d(jpij) ,      &    
    160          &      i0         (jpij) ,     &   
    161          &      sfx_bri_1d (jpij) , sfx_bog_1d (jpij) , sfx_bom_1d (jpij) ,sfx_sum_1d (jpij) ,   & 
    162          &      sfx_sni_1d (jpij) , sfx_opw_1d (jpij) , sfx_res_1d (jpij) , & 
    163          &      dsm_i_fl_1d(jpij) , dsm_i_gd_1d(jpij) , dsm_i_se_1d(jpij) ,     &      
     151      ALLOCATE( sprecip_1d (jpij) , frld_1d    (jpij) , at_i_1d    (jpij) ,                     & 
     152         &      fhtur_1d   (jpij) , wfx_snw_1d (jpij) , wfx_spr_1d (jpij) ,                     & 
     153         &      fhld_1d    (jpij) , wfx_sub_1d (jpij) , wfx_bog_1d (jpij) , wfx_bom_1d(jpij) ,  & 
     154         &      wfx_sum_1d(jpij)  , wfx_sni_1d (jpij) , wfx_opw_1d (jpij) , wfx_res_1d(jpij) ,  & 
     155         &      dqns_ice_1d(jpij) , qla_ice_1d (jpij) , dqla_ice_1d(jpij) ,                     & 
     156         &      tatm_ice_1d(jpij) , i0         (jpij) ,                                         &   
     157         &      sfx_bri_1d (jpij) , sfx_bog_1d (jpij) , sfx_bom_1d (jpij) , sfx_sum_1d (jpij),  & 
     158         &      sfx_sni_1d (jpij) , sfx_opw_1d (jpij) , sfx_res_1d (jpij) ,                     & 
     159         &      dsm_i_fl_1d(jpij) , dsm_i_gd_1d(jpij) , dsm_i_se_1d(jpij) ,                     &      
    164160         &      dsm_i_si_1d(jpij) , hicol_1d    (jpij)                     , STAT=ierr(2) ) 
    165161      ! 
    166       ALLOCATE( t_su_1d    (jpij) , a_i_1d    (jpij) , ht_i_1d   (jpij) ,    &    
    167          &      ht_s_1d    (jpij) , fc_su    (jpij) , fc_bo_i  (jpij) ,    &     
     162      ALLOCATE( t_su_1d   (jpij) , a_i_1d   (jpij) , ht_i_1d  (jpij) ,    &    
     163         &      ht_s_1d   (jpij) , fc_su    (jpij) , fc_bo_i  (jpij) ,    &     
    168164         &      dh_s_tot  (jpij) , dh_i_surf(jpij) , dh_i_bott(jpij) ,    &     
    169          &      dh_snowice(jpij) , sm_i_1d   (jpij) , s_i_new  (jpij) ,    & 
    170          &      t_s_1d(jpij,nlay_s),                                       & 
    171          &      t_i_1d(jpij,nlay_i+1), s_i_1d(jpij,nlay_i+1)                ,     &             
    172          &      q_i_1d(jpij,nlay_i+1), q_s_1d(jpij,nlay_i+1)                ,     & 
     165         &      dh_snowice(jpij) , sm_i_1d  (jpij) , s_i_new  (jpij) ,    & 
     166         &      t_s_1d(jpij,nlay_s) , t_i_1d(jpij,nlay_i) , s_i_1d(jpij,nlay_i) ,  &             
     167         &      q_i_1d(jpij,nlay_i+1) , q_s_1d(jpij,nlay_s) ,                        & 
    173168         &      qh_i_old(jpij,0:nlay_i+1), h_i_old(jpij,0:nlay_i+1) , STAT=ierr(3)) 
    174169      ! 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OFF_SRC/dommsk.F90

    r5312 r5313  
    1515   USE in_out_manager  ! I/O manager 
    1616   USE wrk_nemo   
     17   USE lbclnk   
    1718 
    1819   IMPLICIT NONE 
    … …  
    4849      !!---------------------------------------------------------------------- 
    4950      ! 
    50       INTEGER  ::   ji, jk                   ! dummy loop indices 
     51      INTEGER  ::   ji, jj, jk                   ! dummy loop indices 
    5152      INTEGER  ::   iif, iil, ijf, ijl       ! local integers 
    5253      INTEGER, POINTER, DIMENSION(:,:) ::  imsk  
    … …  
    8384      ENDIF  
    8485      ! 
     86      ! (ISF) MIN(1,SUM(umask)) is here to check if you have effectively at 
     87      ! least 1 wet u point 
     88      DO jj = 1, jpjm1 
     89         DO ji = 1, fs_jpim1   ! vector loop 
     90            umask_i(ji,jj)  = ssmask(ji,jj) * ssmask(ji+1,jj  )  * MIN(1._wp,SUM(umask(ji,jj,:))) 
     91            vmask_i(ji,jj)  = ssmask(ji,jj) * ssmask(ji  ,jj+1)  * MIN(1._wp,SUM(vmask(ji,jj,:))) 
     92         END DO 
     93         DO ji = 1, jpim1      ! NO vector opt. 
     94            fmask_i(ji,jj) =  ssmask(ji,jj  ) * ssmask(ji+1,jj  )   & 
     95               &            * ssmask(ji,jj+1) * ssmask(ji+1,jj+1) * MIN(1._wp,SUM(fmask(ji,jj,:))) 
     96         END DO 
     97      END DO 
     98      CALL lbc_lnk( umask_i, 'U', 1._wp )      ! Lateral boundary conditions 
     99      CALL lbc_lnk( vmask_i, 'V', 1._wp ) 
     100      CALL lbc_lnk( fmask_i, 'F', 1._wp ) 
     101 
     102      ! 3. Ocean/land mask at wu-, wv- and w points  
     103      !---------------------------------------------- 
     104      wmask (:,:,1) = tmask(:,:,1) ! ???????? 
     105      wumask(:,:,1) = umask(:,:,1) ! ???????? 
     106      wvmask(:,:,1) = vmask(:,:,1) ! ???????? 
     107      DO jk=2,jpk 
     108         wmask (:,:,jk)=tmask(:,:,jk) * tmask(:,:,jk-1) 
     109         wumask(:,:,jk)=umask(:,:,jk) * umask(:,:,jk-1)    
     110         wvmask(:,:,jk)=vmask(:,:,jk) * vmask(:,:,jk-1) 
     111      END DO 
     112      ! 
    85113      IF( nprint == 1 .AND. lwp ) THEN    ! Control print 
    86114         imsk(:,:) = INT( tmask_i(:,:) ) 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OFF_SRC/dtadyn.F90

    r5312 r5313  
    245245      tsn(:,:,:,jp_sal) = sf_dyn(jf_sal)%fnow(:,:,:)  * tmask(:,:,:)    ! salinity 
    246246      ! 
    247       CALL eos    ( tsn, rhd, rhop, gdept_0(:,:,:) )                                       ! In any case, we need rhop 
     247      ! 
     248      CALL eos    ( tsn, rhd, rhop, gdept_0(:,:,:) ) ! In any case, we need rhop 
     249      CALL eos_rab( tsn, rab_n )       ! now    local thermal/haline expension ratio at T-points 
     250      CALL bn2    ( tsn, rab_n, rn2 ) ! before Brunt-Vaisala frequency need for zdfmxl 
     251 
     252      rn2b(:,:,:) = rn2(:,:,:)         ! need for zdfmxl 
    248253      CALL zdf_mxl( kt )                                                   ! In any case, we need mxl  
    249254      ! 
    … …  
    535540      !!--------------------------------------------------------------------- 
    536541#if defined key_ldfslp && ! defined key_c1d 
     542      CALL eos    ( pts, rhd, rhop, gdept_0(:,:,:) ) 
    537543      CALL eos_rab( pts, rab_n )       ! now local thermal/haline expension ratio at T-points 
    538544      CALL bn2    ( pts, rab_n, rn2  ) ! now    Brunt-Vaisala 
    539       IF( ln_zps )   & ! Partial steps: before Horizontal DErivative 
    540         &    CALL zps_hde( kt, jpts, pts, gtsu, gtsv,  &        ! Partial steps: before horizontal gradient 
    541         &                                        rhd, gru , grv , aru , arv , gzu , gzv , ge3ru , ge3rv ,   &             ! 
    542         &                                 gtui, gtvi, grui, grvi, arui, arvi, gzui, gzvi, ge3rui, ge3rvi    )  ! of t, s, rd at the last ocean level 
    543         ! only gtsu, gtsv, rhd, gru , grv are used  
    544  
    545  
    546          !                                                            ! of t, s, rd at the bottom ocean level 
     545 
     546      ! Partial steps: before Horizontal DErivative 
     547      IF( ln_zps  .AND. .NOT. ln_isfcav)                            & 
     548         &            CALL zps_hde    ( kt, jpts, pts, gtsu, gtsv,  &  ! Partial steps: before horizontal gradient 
     549         &                                        rhd, gru , grv    )  ! of t, s, rd at the last ocean level 
     550      IF( ln_zps .AND.        ln_isfcav)                            & 
     551         &            CALL zps_hde_isf( kt, jpts, pts, gtsu, gtsv,  &    ! Partial steps for top cell (ISF) 
     552         &                                        rhd, gru , grv , aru , arv , gzu , gzv , ge3ru , ge3rv ,   & 
     553         &                                 gtui, gtvi, grui, grvi, arui, arvi, gzui, gzvi, ge3rui, ge3rvi    ) ! of t, s, rd at the first ocean level 
     554 
     555      rn2b(:,:,:) = rn2(:,:,:)         ! need for zdfmxl 
    547556      CALL zdf_mxl( kt )            ! mixed layer depth 
    548557      CALL ldf_slp( kt, rhd, rn2 )  ! slopes 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OFF_SRC/nemogcm.F90

    r5312 r5313  
    149149         &             nn_bench, nn_timing 
    150150      NAMELIST/namcfg/ cp_cfg, cp_cfz, jp_cfg, jpidta, jpjdta, jpkdta, jpiglo, jpjglo, & 
    151          &             jpizoom, jpjzoom, jperio 
     151         &             jpizoom, jpjzoom, jperio, ln_use_jattr 
    152152      !!---------------------------------------------------------------------- 
    153153      cltxt = '' 
    … …  
    233233         WRITE(numout,*) '                       NEMO team' 
    234234         WRITE(numout,*) '            Ocean General Circulation Model' 
    235          WRITE(numout,*) '                  version 3.5  (2012) ' 
     235         WRITE(numout,*) '                  version 3.6  (2015) ' 
    236236         WRITE(numout,*) 
    237237         WRITE(numout,*) 
    … …  
    359359         WRITE(numout,*) '      left bottom j index of the zoom (in data domain) jpizoom = ', jpjzoom 
    360360         WRITE(numout,*) '      lateral cond. type (between 0 and 6) jperio = ', jperio    
     361         WRITE(numout,*) '      use file attribute if exists as i/p j-start ln_use_jattr = ', ln_use_jattr 
    361362      ENDIF 
    362363      !                             ! Parameter control 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OOO_SRC/nemogcm.F90

    r5312 r5313  
    129129         &             nn_bench, nn_timing 
    130130      NAMELIST/namcfg/ cp_cfg, cp_cfz, jp_cfg, jpidta, jpjdta, jpkdta, jpiglo, jpjglo, & 
    131          &             jpizoom, jpjzoom, jperio 
     131         &             jpizoom, jpjzoom, jperio, ln_use_jattr 
    132132      !!---------------------------------------------------------------------- 
    133133      ! 
    … …  
    233233         WRITE(numout,*) '                       NEMO team' 
    234234         WRITE(numout,*) '            Ocean General Circulation Model' 
    235          WRITE(numout,*) '                  version 3.4  (2011) ' 
     235         WRITE(numout,*) '                  version 3.6  (2015) ' 
    236236         WRITE(numout,*) 
    237237         WRITE(numout,*) 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OOO_SRC/ooo_data.F90

    r5312 r5313  
    4040   CHARACTER(len=128) :: & 
    4141      & alt_file                       !: altimeter file 
     42   !! $Id$ 
    4243CONTAINS 
    4344   SUBROUTINE ooo_data_init( ld_cl4 ) 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OOO_SRC/ooo_intp.F90

    r5312 r5313  
    1616   PUBLIC ooo_interp 
    1717 
     18   !! $Id$ 
    1819   CONTAINS 
    1920 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OOO_SRC/ooo_read.F90

    r5312 r5313  
    2222   PUBLIC ooo_rea_dri 
    2323 
     24   !! $Id$ 
    2425CONTAINS 
    2526   SUBROUTINE ooo_rea_dri(kfile) 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OOO_SRC/ooo_utils.F90

    r5312 r5313  
    1010   REAL(kind=dp), PARAMETER :: obfilldbl=99999. 
    1111 
     12   !! $Id$ 
    1213   CONTAINS 
    1314 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OOO_SRC/ooo_write.F90

    r5312 r5313  
    2929   END INTERFACE 
    3030 
     31   !! $Id$ 
    3132   CONTAINS 
    3233 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/ASM/asminc.F90

    r5312 r5313  
    746746 
    747747 
    748             IF( ln_zps .AND. .NOT. lk_c1d ) & 
    749                &  CALL zps_hde( nit000, jpts, tsb, gtsu, gtsv,  &        ! Partial steps: before horizontal gradient 
    750                &                rhd, gru , grv, aru, arv, gzu, gzv, ge3ru, ge3rv,  &             ! 
    751                &                gtui, gtvi, grui, grvi, arui, arvi, gzui, gzvi, ge3rui, ge3rvi  )  ! of t, s, rd at the last ocean level 
     748            IF( ln_zps .AND. .NOT. lk_c1d .AND. .NOT. ln_isfcav)      & 
     749               &  CALL zps_hde    ( kt, jpts, tsb, gtsu, gtsv,        &  ! Partial steps: before horizontal gradient 
     750               &                              rhd, gru , grv          )  ! of t, s, rd at the last ocean level 
     751            IF( ln_zps .AND. .NOT. lk_c1d .AND.       ln_isfcav)      & 
     752               &  CALL zps_hde_isf( nit000, jpts, tsb, gtsu, gtsv,    &    ! Partial steps for top cell (ISF) 
     753               &                                  rhd, gru , grv , aru , arv , gzu , gzv , ge3ru , ge3rv ,   & 
     754               &                           gtui, gtvi, grui, grvi, arui, arvi, gzui, gzvi, ge3rui, ge3rvi    ) ! of t, s, rd at the last ocean level 
    752755 
    753756#if defined key_zdfkpp 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/BDY/bdydta.F90

    r5312 r5313  
    3333   USE ice_2 
    3434#elif defined key_lim3 
    35    USE par_ice 
    3635   USE ice 
    37    USE limcat_1D          ! redistribute ice input into categories 
     36   USE limvar          ! redistribute ice input into categories 
    3837#endif 
    3938   USE sbcapr 
    … …  
    380379#if defined key_lim3 
    381380               IF( .NOT. ll_bdylim3 .AND. cn_ice_lim(ib_bdy) /= 'none' .AND. nn_ice_lim_dta(ib_bdy) == 1 ) THEN ! bdy ice input (case input is lim2 type) 
    382                 CALL lim_cat_1D ( bf(jfld_hti)%fnow(:,1,1), bf(jfld_hts)%fnow(:,1,1), bf(jfld_ai)%fnow(:,1,1), & 
     381                CALL lim_var_itd ( bf(jfld_hti)%fnow(:,1,1), bf(jfld_hts)%fnow(:,1,1), bf(jfld_ai)%fnow(:,1,1), & 
    383382                                  & dta_bdy(ib_bdy)%ht_i,     dta_bdy(ib_bdy)%ht_s,     dta_bdy(ib_bdy)%a_i     ) 
    384383               ENDIF 
    … …  
    734733         IF( blf_i(jfld)%ln_tint ) ALLOCATE( bf(jfld)%fdta(ilen1(jfld),1,ilen3(jfld),2) ) 
    735734         nbmap_ptr(jfld)%ptr => idx_bdy(ibdy(jfld))%nbmap(:,igrid(jfld)) 
     735         nbmap_ptr(jfld)%ll_unstruc = ln_coords_file(ibdy(jfld)) 
    736736      ENDDO 
    737737 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/BDY/bdyice_lim.F90

    r5312 r5313  
    2626   USE dom_ice_2       ! sea-ice domain 
    2727#elif defined key_lim3 
    28    USE par_ice 
    2928   USE ice             ! LIM_3 ice variables 
    3029   USE dom_ice         ! sea-ice domain 
     30   USE limvar 
    3131#endif  
    3232   USE par_oce         ! ocean parameters 
    … …  
    4242   PRIVATE 
    4343 
    44    PUBLIC   bdy_ice_lim    ! routine called in sbcmod 
     44   PUBLIC   bdy_ice_lim     ! routine called in sbcmod 
    4545   PUBLIC   bdy_ice_lim_dyn ! routine called in limrhg 
    4646 
    … …  
    6060      !!---------------------------------------------------------------------- 
    6161      INTEGER, INTENT( in ) :: kt     ! Main time step counter 
    62       !! 
    6362      INTEGER               :: ib_bdy ! Loop index 
     63 
     64#if defined key_lim3 
     65      CALL lim_var_glo2eqv 
     66#endif 
     67 
    6468      DO ib_bdy=1, nb_bdy 
    6569 
    … …  
    7276            CALL ctl_stop( 'bdy_ice_lim : unrecognised option for open boundaries for ice fields' ) 
    7377         END SELECT 
    74       ENDDO 
     78 
     79      END DO 
     80 
     81#if defined key_lim3 
     82      CALL lim_var_zapsmall 
     83      CALL lim_var_agg(1) 
     84#endif 
    7585 
    7686   END SUBROUTINE bdy_ice_lim 
    … …  
    8999      TYPE(OBC_DATA),  INTENT(in) ::   dta  ! OBC external data 
    90100      INTEGER,         INTENT(in) ::   kt   ! main time-step counter 
    91       INTEGER,         INTENT(in) ::   ib_bdy  ! BDY set index      !! 
     101      INTEGER,         INTENT(in) ::   ib_bdy  ! BDY set index 
    92102 
    93103      INTEGER  ::   jpbound            ! 0 = incoming ice 
    … …  
    169179            jpbound = 0; ii = ji; ij = jj; 
    170180 
    171             IF ( u_ice(ji+1,jj  ) < 0. .AND. umask(ji-1,jj  ,1) == 0. ) jpbound = 1; ii = ji+1; ij = jj 
    172             IF ( u_ice(ji-1,jj  ) > 0. .AND. umask(ji+1,jj  ,1) == 0. ) jpbound = 1; ii = ji-1; ij = jj 
    173             IF ( v_ice(ji  ,jj+1) < 0. .AND. vmask(ji  ,jj-1,1) == 0. ) jpbound = 1; ii = ji  ; ij = jj+1 
    174             IF ( v_ice(ji  ,jj-1) > 0. .AND. vmask(ji  ,jj+1,1) == 0. ) jpbound = 1; ii = ji  ; ij = jj-1 
    175  
    176             rswitch = 1.0 - MAX( 0.0_wp , SIGN ( 1.0_wp , - at_i(ii,ij) + 0.01 ) ) ! 0 if no ice 
     181            IF( u_ice(ji+1,jj  ) < 0. .AND. umask(ji-1,jj  ,1) == 0. ) jpbound = 1; ii = ji+1; ij = jj 
     182            IF( u_ice(ji-1,jj  ) > 0. .AND. umask(ji+1,jj  ,1) == 0. ) jpbound = 1; ii = ji-1; ij = jj 
     183            IF( v_ice(ji  ,jj+1) < 0. .AND. vmask(ji  ,jj-1,1) == 0. ) jpbound = 1; ii = ji  ; ij = jj+1 
     184            IF( v_ice(ji  ,jj-1) > 0. .AND. vmask(ji  ,jj+1,1) == 0. ) jpbound = 1; ii = ji  ; ij = jj-1 
     185 
     186            IF( nn_ice_lim_dta(ib_bdy) == 0 ) jpbound = 0; ii = ji; ij = jj   ! case ice boundaries = initial conditions 
     187                                                                              !      do not make state variables dependent on velocity 
     188                
     189 
     190            rswitch = MAX( 0.0_wp , SIGN ( 1.0_wp , at_i(ii,ij) - 0.01 ) ) ! 0 if no ice 
    177191 
    178192            ! concentration and thickness 
    … …  
    190204 
    191205               ! Ice salinity, age, temperature 
    192                sm_i(ji,jj,jl)   = rswitch * rn_ice_sal(ib_bdy)  + ( 1.0 - rswitch ) * s_i_min 
    193                o_i(ji,jj,jl)    = rswitch * rn_ice_age(ib_bdy)  + ( 1.0 - rswitch ) 
     206               sm_i(ji,jj,jl)   = rswitch * rn_ice_sal(ib_bdy)  + ( 1.0 - rswitch ) * rn_simin 
     207               oa_i(ji,jj,jl)   = rswitch * rn_ice_age(ib_bdy) * a_i(ji,jj,jl) 
    194208               t_su(ji,jj,jl)   = rswitch * rn_ice_tem(ib_bdy)  + ( 1.0 - rswitch ) * rn_ice_tem(ib_bdy) 
    195209               DO jk = 1, nlay_s 
    196                   t_s(ji,jj,jk,jl) = rswitch * rn_ice_tem(ib_bdy) + ( 1.0 - rswitch ) * rtt 
     210                  t_s(ji,jj,jk,jl) = rswitch * rn_ice_tem(ib_bdy) + ( 1.0 - rswitch ) * rt0 
    197211               END DO 
    198212               DO jk = 1, nlay_i 
    199                   t_i(ji,jj,jk,jl) = rswitch * rn_ice_tem(ib_bdy) + ( 1.0 - rswitch ) * rtt  
    200                   s_i(ji,jj,jk,jl) = rswitch * rn_ice_sal(ib_bdy) + ( 1.0 - rswitch ) * s_i_min 
     213                  t_i(ji,jj,jk,jl) = rswitch * rn_ice_tem(ib_bdy) + ( 1.0 - rswitch ) * rt0  
     214                  s_i(ji,jj,jk,jl) = rswitch * rn_ice_sal(ib_bdy) + ( 1.0 - rswitch ) * rn_simin 
    201215               END DO 
    202216                
    … …  
    204218  
    205219               ! Ice salinity, age, temperature 
    206                sm_i(ji,jj,jl)   = rswitch * sm_i(ii,ij,jl)  + ( 1.0 - rswitch ) * s_i_min 
    207                o_i(ji,jj,jl)    = rswitch * o_i(ii,ij,jl)   + ( 1.0 - rswitch ) 
    208                t_su(ji,jj,jl)   = rswitch * t_su(ii,ij,jl)  + ( 1.0 - rswitch ) * rtt 
     220               sm_i(ji,jj,jl)   = rswitch * sm_i(ii,ij,jl)  + ( 1.0 - rswitch ) * rn_simin 
     221               oa_i(ji,jj,jl)   = rswitch * oa_i(ii,ij,jl) 
     222               t_su(ji,jj,jl)   = rswitch * t_su(ii,ij,jl)  + ( 1.0 - rswitch ) * rt0 
    209223               DO jk = 1, nlay_s 
    210                   t_s(ji,jj,jk,jl) = rswitch * t_s(ii,ij,jk,jl) + ( 1.0 - rswitch ) * rtt 
     224                  t_s(ji,jj,jk,jl) = rswitch * t_s(ii,ij,jk,jl) + ( 1.0 - rswitch ) * rt0 
    211225               END DO 
    212226               DO jk = 1, nlay_i 
    213                   t_i(ji,jj,jk,jl) = rswitch * t_i(ii,ij,jk,jl) + ( 1.0 - rswitch ) * rtt 
    214                   s_i(ji,jj,jk,jl) = rswitch * s_i(ii,ij,jk,jl) + ( 1.0 - rswitch ) * s_i_min 
     227                  t_i(ji,jj,jk,jl) = rswitch * t_i(ii,ij,jk,jl) + ( 1.0 - rswitch ) * rt0 
     228                  s_i(ji,jj,jk,jl) = rswitch * s_i(ii,ij,jk,jl) + ( 1.0 - rswitch ) * rn_simin 
    215229               END DO 
    216230 
    … …  
    218232 
    219233            ! if salinity is constant, then overwrite rn_ice_sal 
    220             IF( num_sal == 1 ) THEN 
    221                sm_i(ji,jj,jl)   = bulk_sal 
    222                s_i (ji,jj,:,jl) = bulk_sal 
     234            IF( nn_icesal == 1 ) THEN 
     235               sm_i(ji,jj,jl)   = rn_icesal 
     236               s_i (ji,jj,:,jl) = rn_icesal 
    223237            ENDIF 
    224238 
    225239            ! contents 
    226240            smv_i(ji,jj,jl)  = MIN( sm_i(ji,jj,jl) , sss_m(ji,jj) ) * v_i(ji,jj,jl) 
    227             oa_i(ji,jj,jl)   = o_i(ji,jj,jl) * a_i(ji,jj,jl) 
    228241            DO jk = 1, nlay_s 
    229242               ! Snow energy of melting 
    230                e_s(ji,jj,jk,jl) = rswitch * rhosn * ( cpic * ( rtt - t_s(ji,jj,jk,jl) ) + lfus ) 
    231                ! Change dimensions 
    232                e_s(ji,jj,jk,jl) = e_s(ji,jj,jk,jl) / unit_fac 
    233                ! Multiply by volume, so that heat content in 10^9 Joules 
    234                e_s(ji,jj,jk,jl) = e_s(ji,jj,jk,jl) * area(ji,jj) * v_s(ji,jj,jl) / nlay_s 
     243               e_s(ji,jj,jk,jl) = rswitch * rhosn * ( cpic * ( rt0 - t_s(ji,jj,jk,jl) ) + lfus ) 
     244               ! Multiply by volume, so that heat content in J/m2 
     245               e_s(ji,jj,jk,jl) = e_s(ji,jj,jk,jl) * v_s(ji,jj,jl) * r1_nlay_s 
    235246            END DO 
    236247            DO jk = 1, nlay_i 
    237                ztmelts          = - tmut * s_i(ji,jj,jk,jl) + rtt !Melting temperature in K                   
     248               ztmelts          = - tmut * s_i(ji,jj,jk,jl) + rt0 !Melting temperature in K                   
    238249               ! heat content per unit volume 
    239250               e_i(ji,jj,jk,jl) = rswitch * rhoic * & 
    240251                  (   cpic    * ( ztmelts - t_i(ji,jj,jk,jl) ) & 
    241                   +   lfus    * ( 1.0 - (ztmelts-rtt) / MIN((t_i(ji,jj,jk,jl)-rtt),-epsi20) ) & 
    242                   - rcp      * ( ztmelts - rtt ) ) 
    243                ! Correct dimensions to avoid big values 
    244                e_i(ji,jj,jk,jl) = e_i(ji,jj,jk,jl) / unit_fac  
    245                ! Mutliply by ice volume, and divide by number of layers to get heat content in 10^9 J 
    246                e_i(ji,jj,jk,jl) = e_i(ji,jj,jk,jl) * area(ji,jj) * a_i(ji,jj,jl) * ht_i(ji,jj,jl) / nlay_i 
     252                  +   lfus    * ( 1.0 - (ztmelts-rt0) / MIN((t_i(ji,jj,jk,jl)-rt0),-epsi20) ) & 
     253                  - rcp      * ( ztmelts - rt0 ) ) 
     254               ! Mutliply by ice volume, and divide by number of layers to get heat content in J/m2 
     255               e_i(ji,jj,jk,jl) = e_i(ji,jj,jk,jl) * a_i(ji,jj,jl) * ht_i(ji,jj,jl) * r1_nlay_i 
    247256            END DO 
    248257 
    249  
    250          END DO !jb 
     258         END DO 
    251259  
    252          CALL lbc_bdy_lnk(  a_i(:,:,jl), 'T', 1., ib_bdy )                                         ! lateral boundary conditions 
     260         CALL lbc_bdy_lnk(  a_i(:,:,jl), 'T', 1., ib_bdy ) 
    253261         CALL lbc_bdy_lnk( ht_i(:,:,jl), 'T', 1., ib_bdy ) 
    254262         CALL lbc_bdy_lnk( ht_s(:,:,jl), 'T', 1., ib_bdy ) 
    … …  
    259267         CALL lbc_bdy_lnk(  sm_i(:,:,jl), 'T', 1., ib_bdy ) 
    260268         CALL lbc_bdy_lnk(  oa_i(:,:,jl), 'T', 1., ib_bdy ) 
    261          CALL lbc_bdy_lnk(   o_i(:,:,jl), 'T', 1., ib_bdy ) 
    262269         CALL lbc_bdy_lnk(  t_su(:,:,jl), 'T', 1., ib_bdy ) 
    263270         DO jk = 1, nlay_s 
    … …  
    291298      !! 
    292299      CHARACTER(len=1), INTENT(in)  ::   cd_type   ! nature of velocity grid-points 
    293       INTEGER  ::   jb, jgrd   ! dummy loop indices 
     300      INTEGER  ::   jb, jgrd           ! dummy loop indices 
    294301      INTEGER  ::   ji, jj             ! local scalar 
    295       INTEGER  ::   ib_bdy ! Loop index 
     302      INTEGER  ::   ib_bdy             ! Loop index 
    296303      REAL(wp) ::   zmsk1, zmsk2, zflag 
    297304     !!------------------------------------------------------------------------------ 
    … …  
    309316         CASE('frs') 
    310317             
    311  
     318            IF( nn_ice_lim_dta(ib_bdy) == 0 ) CYCLE            ! case ice boundaries = initial conditions  
     319                                                               !      do not change ice velocity (it is only computed by rheology) 
     320  
    312321            SELECT CASE ( cd_type ) 
    313  
     322                
    314323            CASE ( 'U' ) 
    315324                
    … …  
    326335                      
    327336                     ! u_ice = u_ice of the adjacent grid point except if this grid point is ice-free (then u_ice = u_oce) 
    328                      u_ice (ji,jj) = u_ice(ji+1,jj) * 0.5 * ABS( zflag + 1._wp ) * zmsk1 + & 
    329                         &            u_ice(ji-1,jj) * 0.5 * ABS( zflag - 1._wp ) * zmsk2 + & 
     337                     u_ice (ji,jj) = u_ice(ji+1,jj) * 0.5_wp * ABS( zflag + 1._wp ) * zmsk1 + & 
     338                        &            u_ice(ji-1,jj) * 0.5_wp * ABS( zflag - 1._wp ) * zmsk2 + & 
    330339                        &            u_oce(ji  ,jj) * ( 1._wp - MIN( 1._wp, zmsk1 + zmsk2 ) ) 
    331340                  ELSE                             ! everywhere else 
    … …  
    334343                  ENDIF 
    335344                  ! mask ice velocities 
    336                   rswitch = 1.0 - MAX( 0.0_wp , SIGN ( 1.0_wp , - at_i(ji,jj) + 0.01 ) ) ! 0 if no ice 
     345                  rswitch = MAX( 0.0_wp , SIGN ( 1.0_wp , at_i(ji,jj) - 0.01_wp ) ) ! 0 if no ice 
    337346                  u_ice(ji,jj) = rswitch * u_ice(ji,jj) 
    338347                   
    339348               ENDDO 
    340  
     349                
    341350               CALL lbc_bdy_lnk( u_ice(:,:), 'U', -1., ib_bdy ) 
    342351                
    … …  
    355364                      
    356365                     ! u_ice = u_ice of the adjacent grid point except if this grid point is ice-free (then u_ice = u_oce) 
    357                      v_ice (ji,jj) = v_ice(ji,jj+1) * 0.5 * ABS( zflag + 1._wp ) * zmsk1 + & 
    358                         &            v_ice(ji,jj-1) * 0.5 * ABS( zflag - 1._wp ) * zmsk2 + & 
     366                     v_ice (ji,jj) = v_ice(ji,jj+1) * 0.5_wp * ABS( zflag + 1._wp ) * zmsk1 + & 
     367                        &            v_ice(ji,jj-1) * 0.5_wp * ABS( zflag - 1._wp ) * zmsk2 + & 
    359368                        &            v_oce(ji,jj  ) * ( 1._wp - MIN( 1._wp, zmsk1 + zmsk2 ) ) 
    360369                  ELSE                             ! everywhere else 
    … …  
    363372                  ENDIF 
    364373                  ! mask ice velocities 
    365                   rswitch = 1.0 - MAX( 0.0_wp , SIGN ( 1.0_wp , - at_i(ji,jj) + 0.01 ) ) ! 0 if no ice 
     374                  rswitch = MAX( 0.0_wp , SIGN ( 1.0_wp , at_i(ji,jj) - 0.01 ) ) ! 0 if no ice 
    366375                  v_ice(ji,jj) = rswitch * v_ice(ji,jj) 
    367376                   
    … …  
    369378                
    370379               CALL lbc_bdy_lnk( v_ice(:,:), 'V', -1., ib_bdy ) 
    371                 
     380                   
    372381            END SELECT 
    373382             

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/BDY/bdytides.F90

    r5312 r5313  
    3232   USE tideini 
    3333!   USE tide_mod       ! Useless ?? 
    34    USE fldread, ONLY: fld_map 
     34   USE fldread 
    3535   USE dynspg_oce, ONLY: lk_dynspg_ts 
    3636 
    … …  
    8888      !! 
    8989      TYPE(TIDES_DATA),  POINTER                ::   td                  !: local short cut    
     90      TYPE(MAP_POINTER), DIMENSION(jpbgrd)      ::   ibmap_ptr           !: array of pointers to nbmap 
    9091      !! 
    9192      NAMELIST/nambdy_tide/filtide, ln_bdytide_2ddta, ln_bdytide_conj 
    … …  
    220221               !  
    221222               ALLOCATE( dta_read( MAXVAL(ilen0(1:3)), 1, 1 ) ) 
     223               ! 
     224               ! Set map structure 
     225               ibmap_ptr(1)%ptr => idx_bdy(ib_bdy)%nbmap(:,1) 
     226               ibmap_ptr(1)%ll_unstruc = ln_coords_file(ib_bdy) 
     227               ibmap_ptr(2)%ptr => idx_bdy(ib_bdy)%nbmap(:,2) 
     228               ibmap_ptr(2)%ll_unstruc = ln_coords_file(ib_bdy) 
     229               ibmap_ptr(3)%ptr => idx_bdy(ib_bdy)%nbmap(:,3) 
     230               ibmap_ptr(3)%ll_unstruc = ln_coords_file(ib_bdy) 
    222231 
    223232               ! Open files and read in tidal forcing data 
    … …  
    228237                  clfile = TRIM(filtide)//TRIM(Wave(ntide(itide))%cname_tide)//'_grid_T.nc' 
    229238                  CALL iom_open( clfile, inum ) 
    230                   CALL fld_map( inum, 'z1' , dta_read(1:ilen0(1),1:1,1:1) , 1, idx_bdy(ib_bdy)%nbmap(:,1) ) 
     239                  CALL fld_map( inum, 'z1' , dta_read(1:ilen0(1),1:1,1:1) , 1,  ibmap_ptr(1) ) 
    231240                  td%ssh0(:,itide,1) = dta_read(1:ilen0(1),1,1) 
    232                   CALL fld_map( inum, 'z2' , dta_read(1:ilen0(1),1:1,1:1) , 1, idx_bdy(ib_bdy)%nbmap(:,1) ) 
     241                  CALL fld_map( inum, 'z2' , dta_read(1:ilen0(1),1:1,1:1) , 1,  ibmap_ptr(1) ) 
    233242                  td%ssh0(:,itide,2) = dta_read(1:ilen0(1),1,1) 
    234243                  CALL iom_close( inum ) 
    … …  
    236245                  clfile = TRIM(filtide)//TRIM(Wave(ntide(itide))%cname_tide)//'_grid_U.nc' 
    237246                  CALL iom_open( clfile, inum ) 
    238                   CALL fld_map( inum, 'u1' , dta_read(1:ilen0(2),1:1,1:1) , 1, idx_bdy(ib_bdy)%nbmap(:,2) ) 
     247                  CALL fld_map( inum, 'u1' , dta_read(1:ilen0(2),1:1,1:1) , 1, ibmap_ptr(2) ) 
    239248                  td%u0(:,itide,1) = dta_read(1:ilen0(2),1,1) 
    240                   CALL fld_map( inum, 'u2' , dta_read(1:ilen0(2),1:1,1:1) , 1, idx_bdy(ib_bdy)%nbmap(:,2) ) 
     249                  CALL fld_map( inum, 'u2' , dta_read(1:ilen0(2),1:1,1:1) , 1, ibmap_ptr(2) ) 
    241250                  td%u0(:,itide,2) = dta_read(1:ilen0(2),1,1) 
    242251                  CALL iom_close( inum ) 
    … …  
    244253                  clfile = TRIM(filtide)//TRIM(Wave(ntide(itide))%cname_tide)//'_grid_V.nc' 
    245254                  CALL iom_open( clfile, inum ) 
    246                   CALL fld_map( inum, 'v1' , dta_read(1:ilen0(3),1:1,1:1) , 1, idx_bdy(ib_bdy)%nbmap(:,3) ) 
     255                  CALL fld_map( inum, 'v1' , dta_read(1:ilen0(3),1:1,1:1) , 1, ibmap_ptr(3) ) 
    247256                  td%v0(:,itide,1) = dta_read(1:ilen0(3),1,1) 
    248                   CALL fld_map( inum, 'v2' , dta_read(1:ilen0(3),1:1,1:1) , 1, idx_bdy(ib_bdy)%nbmap(:,3) ) 
     257                  CALL fld_map( inum, 'v2' , dta_read(1:ilen0(3),1:1,1:1) , 1, ibmap_ptr(3) ) 
    249258                  td%v0(:,itide,2) = dta_read(1:ilen0(3),1,1) 
    250259                  CALL iom_close( inum ) 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/C1D/step_c1d.F90

    r5312 r5313  
    7272      ! Ocean physics update                (ua, va, ta, sa used as workspace) 
    7373      !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 
     74                         CALL eos_rab( tsb, rab_b )   ! before local thermal/haline expension ratio at T-points 
     75                         CALL eos_rab( tsn, rab_n )   ! now    local thermal/haline expension ratio at T-points 
    7476                         CALL bn2( tsb, rab_b, rn2b ) ! before Brunt-Vaisala frequency 
    7577                         CALL bn2( tsn, rab_n, rn2  ) ! now    Brunt-Vaisala frequency 
    … …  
    132134                        CALL tra_nxt( kstp )       ! tracer fields at next time step 
    133135 
     136 
     137 
    134138      !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 
    135139      ! Dynamics                                    (ta, sa used as workspace) 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/CRS/crs.F90

    r5312 r5313  
    164164 
    165165 
     166   !! $Id$ 
    166167CONTAINS 
    167168    

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/CRS/crsdom.F90

    r5312 r5313  
    5757#  include "domzgr_substitute.h90" 
    5858    
     59   !! $Id$ 
    5960CONTAINS 
    6061 
    … …  
    18821883      CALL crs_lbc_lnk( p_surf_crs_msk, cd_type, 1.0, pval=1.0 ) 
    18831884 
    1884       CALL wrk_dealloc( jpi, jpj, jpk, zsurf, zsurfmsk ) 
     1885      CALL wrk_dealloc( jpi, jpj, jpk, zsurfmsk, zsurf ) 
    18851886 
    18861887   END SUBROUTINE crs_dom_sfc 
    … …  
    22742275      ENDDO 
    22752276      
    2276       CALL wrk_alloc( jpi_crs, jpj_crs, zmbk ) 
    2277  
    22782277      zmbk(:,:) = 0.0 
    22792278      zmbk(:,:) = REAL( mbathy_crs(:,:), wp ) ;   CALL crs_lbc_lnk(zmbk,'T',1.0)   ;   mbathy_crs(:,:) = INT( zmbk(:,:) ) 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/CRS/crsdomwri.F90

    r5312 r5313  
    3333   PUBLIC crs_dom_wri        ! routine called by crsini.F90 
    3434 
     35   !! $Id$ 
    3536CONTAINS 
    3637 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/CRS/crsini.F90

    r5312 r5313  
    2929#  include "domzgr_substitute.h90" 
    3030 
     31   !! $Id$ 
    3132CONTAINS 
    3233    

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/CRS/crslbclnk.F90

    r5312 r5313  
    2222   PUBLIC crs_lbc_lnk 
    2323    
     24   !! $Id$ 
    2425CONTAINS 
    2526 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/DIA/diaar5.F90

    r5312 r5313  
    2121   USE timing         ! preformance summary 
    2222   USE wrk_nemo       ! working arrays 
     23   USE fldread        ! type FLD_N 
     24   USE phycst         ! physical constant 
     25   USE in_out_manager  ! I/O manager 
    2326 
    2427   IMPLICIT NONE 
    … …  
    103106      END DO 
    104107      IF( .NOT.lk_vvl ) THEN 
    105          DO ji=1,jpi 
    106             DO jj=1,jpj 
    107                zbotpres(ji,jj) = zbotpres(ji,jj) + sshn(ji,jj) * zrhd(ji,jj,mikt(ji,jj)) + riceload(ji,jj) 
    108             END DO 
    109          END DO 
     108         IF ( ln_isfcav ) THEN 
     109            DO ji=1,jpi 
     110               DO jj=1,jpj 
     111                  zbotpres(ji,jj) = zbotpres(ji,jj) + sshn(ji,jj) * zrhd(ji,jj,mikt(ji,jj)) + riceload(ji,jj) 
     112               END DO 
     113            END DO 
     114         ELSE 
     115            zbotpres(:,:) = zbotpres(:,:) + sshn(:,:) * zrhd(:,:,1) 
     116         END IF 
    110117      END IF 
    111118      !                                          
    … …  
    125132      END DO 
    126133      IF( .NOT.lk_vvl ) THEN 
    127          DO ji=1,jpi 
    128             DO jj=1,jpj 
    129                zbotpres(ji,jj) = zbotpres(ji,jj) + sshn(ji,jj) * zrhd(ji,jj,mikt(ji,jj)) + riceload(ji,jj) 
    130             END DO 
    131          END DO 
     134         IF ( ln_isfcav ) THEN 
     135            DO ji=1,jpi 
     136               DO jj=1,jpj 
     137                  zbotpres(ji,jj) = zbotpres(ji,jj) + sshn(ji,jj) * zrhd(ji,jj,mikt(ji,jj)) + riceload(ji,jj) 
     138               END DO 
     139            END DO 
     140         ELSE 
     141            zbotpres(:,:) = zbotpres(:,:) + sshn(:,:) * zrhd(:,:,1) 
     142         END IF 
    132143      END IF 
    133144      !     
    … …  
    155166      END DO 
    156167      IF( .NOT.lk_vvl ) THEN 
    157          DO ji=1,jpi 
    158             DO jj=1,jpj 
    159                ztemp = ztemp + zarea_ssh(ji,jj) * tsn(ji,jj,mikt(ji,jj),jp_tem)  
    160                zsal  = zsal  + zarea_ssh(ji,jj) * tsn(ji,jj,mikt(ji,jj),jp_sal)  
    161             END DO 
    162          END DO 
     168         IF ( ln_isfcav ) THEN 
     169            DO ji=1,jpi 
     170               DO jj=1,jpj 
     171                  ztemp = ztemp + zarea_ssh(ji,jj) * tsn(ji,jj,mikt(ji,jj),jp_tem)  
     172                  zsal  = zsal  + zarea_ssh(ji,jj) * tsn(ji,jj,mikt(ji,jj),jp_sal)  
     173               END DO 
     174            END DO 
     175         ELSE 
     176            ztemp = ztemp + SUM( zarea_ssh(:,:) * tsn(:,:,1,jp_tem) ) 
     177            zsal  = zsal  + SUM( zarea_ssh(:,:) * tsn(:,:,1,jp_sal) ) 
     178         END IF 
    163179      ENDIF 
    164180      IF( lk_mpp ) THEN   
    … …  
    195211      REAL(wp) ::   zztmp   
    196212      REAL(wp), POINTER, DIMENSION(:,:,:,:) ::   zsaldta   ! Jan/Dec levitus salinity 
     213      ! reading initial file 
     214      LOGICAL  ::   ln_tsd_init      !: T & S data flag 
     215      LOGICAL  ::   ln_tsd_tradmp    !: internal damping toward input data flag 
     216      CHARACTER(len=100)            ::   cn_dir 
     217      TYPE(FLD_N)                   ::  sn_tem,sn_sal 
     218      INTEGER  ::   ios=0 
     219 
     220      NAMELIST/namtsd/ ln_tsd_init,ln_tsd_tradmp,cn_dir,sn_tem,sn_sal 
     221      ! 
     222 
     223      REWIND( numnam_ref )              ! Namelist namtsd in reference namelist : 
     224      READ  ( numnam_ref, namtsd, IOSTAT = ios, ERR = 901) 
     225901   IF( ios /= 0 ) CALL ctl_nam ( ios , ' namtsd in reference namelist for dia_ar5', lwp ) 
     226      REWIND( numnam_cfg )              ! Namelist namtsd in configuration namelist : Parameters of the run 
     227      READ  ( numnam_cfg, namtsd, IOSTAT = ios, ERR = 902 ) 
     228902   IF( ios /= 0 ) CALL ctl_nam ( ios , ' namtsd in configuration namelist for dia_ar5', lwp ) 
     229      IF(lwm) WRITE ( numond, namtsd ) 
     230      ! 
    197231      !!---------------------------------------------------------------------- 
    198232      ! 
    … …  
    214248      END DO 
    215249      IF( lk_mpp )   CALL mpp_sum( vol0 ) 
    216        
    217       CALL iom_open ( 'data_1m_salinity_nomask', inum ) 
    218       CALL iom_get  ( inum, jpdom_data, 'vosaline', zsaldta(:,:,:,1), 1  ) 
    219       CALL iom_get  ( inum, jpdom_data, 'vosaline', zsaldta(:,:,:,2), 12 ) 
     250 
     251      CALL iom_open ( TRIM( cn_dir )//TRIM(sn_sal%clname), inum ) 
     252      CALL iom_get  ( inum, jpdom_data, TRIM(sn_sal%clvar), zsaldta(:,:,:,1), 1  ) 
     253      CALL iom_get  ( inum, jpdom_data, TRIM(sn_sal%clvar), zsaldta(:,:,:,2), 12 ) 
    220254      CALL iom_close( inum ) 
    221255      sn0(:,:,:) = 0.5_wp * ( zsaldta(:,:,:,1) + zsaldta(:,:,:,2) )         

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/DIA/diadct.F90

    r5312 r5313  
    4242#endif 
    4343#if defined key_lim3 
    44   USE par_ice 
    4544  USE ice 
    4645#endif 
    … …  
    113112  REAL(wp), ALLOCATABLE, DIMENSION(:,:,:)   ::  transports_2d   
    114113 
     114   !! $Id$ 
    115115CONTAINS 
    116116 
    … …  
    12981298   LOGICAL, PUBLIC, PARAMETER ::   lk_diadct = .FALSE.    !: diamht flag 
    12991299   PUBLIC  
     1300   !! $Id$ 
    13001301CONTAINS 
    13011302 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/DIA/diahsb.F90

    r5312 r5313  
    9696      z_frc_trd_t =           glob_sum( sbc_tsc(:,:,jp_tem) * surf(:,:) )                               ! heat fluxes 
    9797      z_frc_trd_s =           glob_sum( sbc_tsc(:,:,jp_sal) * surf(:,:) )                               ! salt fluxes 
    98       ! Add runoff heat & salt input 
     98      ! Add runoff    heat & salt input 
    9999      IF( ln_rnf    )   z_frc_trd_t = z_frc_trd_t + glob_sum( rnf_tsc(:,:,jp_tem) * surf(:,:) ) 
    100100      IF( ln_rnf_sal)   z_frc_trd_s = z_frc_trd_s + glob_sum( rnf_tsc(:,:,jp_sal) * surf(:,:) ) 
    101       ! Add geothermal ice shelf 
     101      ! Add ice shelf heat & salt input 
    102102      IF( nn_isf .GE. 1 )  THEN 
    103103          z_frc_trd_t = z_frc_trd_t & 
    … …  
    112112      ! 
    113113      IF( .NOT. lk_vvl ) THEN 
    114          z2d0=0.0_wp ; z2d1=0.0_wp 
    115          DO ji=1,jpi 
    116             DO jj=1,jpj 
    117               z2d0(ji,jj) = surf(ji,jj) * wn(ji,jj,mikt(ji,jj)) * tsb(ji,jj,mikt(ji,jj),jp_tem) 
    118               z2d1(ji,jj) = surf(ji,jj) * wn(ji,jj,mikt(ji,jj)) * tsb(ji,jj,mikt(ji,jj),jp_sal) 
     114         IF ( ln_isfcav ) THEN 
     115            DO ji=1,jpi 
     116               DO jj=1,jpj 
     117                  z2d0(ji,jj) = surf(ji,jj) * wn(ji,jj,mikt(ji,jj)) * tsb(ji,jj,mikt(ji,jj),jp_tem) 
     118                  z2d1(ji,jj) = surf(ji,jj) * wn(ji,jj,mikt(ji,jj)) * tsb(ji,jj,mikt(ji,jj),jp_sal) 
     119               ENDDO 
    119120            ENDDO 
    120          ENDDO 
     121         ELSE 
     122            z2d0(:,:) = surf(:,:) * wn(:,:,1) * tsb(:,:,1,jp_tem) 
     123            z2d1(:,:) = surf(:,:) * wn(:,:,1) * tsb(:,:,1,jp_sal) 
     124         END IF 
    121125         z_wn_trd_t = - glob_sum( z2d0 )  
    122126         z_wn_trd_s = - glob_sum( z2d1 ) 
    … …  
    144148      ! heat & salt content variation (associated with ssh) 
    145149      IF( .NOT. lk_vvl ) THEN 
    146          z2d0 = 0._wp   ;   z2d1 = 0._wp 
    147          DO ji = 1, jpi 
    148             DO jj = 1, jpj 
    149               z2d0(ji,jj) = surf(ji,jj) * ( tsn(ji,jj,mikt(ji,jj),jp_tem) * sshn(ji,jj) - ssh_hc_loc_ini(ji,jj) )  
    150               z2d1(ji,jj) = surf(ji,jj) * ( tsn(ji,jj,mikt(ji,jj),jp_sal) * sshn(ji,jj) - ssh_sc_loc_ini(ji,jj) )  
     150         IF ( ln_isfcav ) THEN 
     151            DO ji = 1, jpi 
     152               DO jj = 1, jpj 
     153                  z2d0(ji,jj) = surf(ji,jj) * ( tsn(ji,jj,mikt(ji,jj),jp_tem) * sshn(ji,jj) - ssh_hc_loc_ini(ji,jj) )  
     154                  z2d1(ji,jj) = surf(ji,jj) * ( tsn(ji,jj,mikt(ji,jj),jp_sal) * sshn(ji,jj) - ssh_sc_loc_ini(ji,jj) )  
     155               END DO 
    151156            END DO 
    152          END DO 
     157         ELSE 
     158            z2d0(:,:) = surf(:,:) * ( tsn(:,:,1,jp_tem) * sshn(:,:) - ssh_hc_loc_ini(:,:) )  
     159            z2d1(:,:) = surf(:,:) * ( tsn(:,:,1,jp_sal) * sshn(:,:) - ssh_sc_loc_ini(:,:) )  
     160         END IF 
    153161         z_ssh_hc = glob_sum( z2d0 )  
    154162         z_ssh_sc = glob_sum( z2d1 )  
    … …  
    277285          frc_s = 0._wp                                           ! salt content   -    -   -    -         
    278286          IF( .NOT. lk_vvl ) THEN 
    279              DO ji=1,jpi 
    280                 DO jj=1,jpj 
    281                    ssh_hc_loc_ini(ji,jj) = tsn(ji,jj,mikt(ji,jj),jp_tem) * sshn(ji,jj)   ! initial heat content in ssh 
    282                    ssh_sc_loc_ini(ji,jj) = tsn(ji,jj,mikt(ji,jj),jp_sal) * sshn(ji,jj)   ! initial salt content in ssh 
     287             IF ( ln_isfcav ) THEN 
     288                DO ji=1,jpi 
     289                   DO jj=1,jpj 
     290                      ssh_hc_loc_ini(ji,jj) = tsn(ji,jj,mikt(ji,jj),jp_tem) * sshn(ji,jj)   ! initial heat content in ssh 
     291                      ssh_sc_loc_ini(ji,jj) = tsn(ji,jj,mikt(ji,jj),jp_sal) * sshn(ji,jj)   ! initial salt content in ssh 
     292                   ENDDO 
    283293                ENDDO 
    284              ENDDO 
     294             ELSE 
     295                ssh_hc_loc_ini(:,:) = tsn(:,:,1,jp_tem) * sshn(:,:)   ! initial heat content in ssh 
     296                ssh_sc_loc_ini(:,:) = tsn(:,:,1,jp_sal) * sshn(:,:)   ! initial salt content in ssh 
     297             END IF 
    285298             frc_wn_t = 0._wp                                       ! initial heat content misfit due to free surface 
    286299             frc_wn_s = 0._wp                                       ! initial salt content misfit due to free surface 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/DIA/diaptr.F90

    r5312 r5313  
    88   !!            3.2  ! 2010-03  (O. Marti, S. Flavoni) Add fields 
    99   !!            3.3  ! 2010-10  (G. Madec)  dynamical allocation 
     10   !!            3.6  ! 2014-12  (C. Ethe) use of IOM 
    1011   !!---------------------------------------------------------------------- 
    1112 
    … …  
    1314   !!   dia_ptr      : Poleward Transport Diagnostics module 
    1415   !!   dia_ptr_init : Initialization, namelist read 
    15    !!   dia_ptr_wri  : Output of poleward fluxes 
    16    !!   ptr_vjk      : "zonal" sum computation of a "meridional" flux array 
    17    !!   ptr_tjk      : "zonal" mean computation of a tracer field 
    18    !!   ptr_vj       : "zonal" and vertical sum computation of a "meridional" flux array 
    19    !!                   (Generic interface to ptr_vj_3d, ptr_vj_2d) 
     16   !!   ptr_sjk      : "zonal" mean computation of a field - tracer or flux array 
     17   !!   ptr_sj       : "zonal" and vertical sum computation of a "meridional" flux array 
     18   !!                   (Generic interface to ptr_sj_3d, ptr_sj_2d) 
    2019   !!---------------------------------------------------------------------- 
    2120   USE oce              ! ocean dynamics and active tracers 
    2221   USE dom_oce          ! ocean space and time domain 
    2322   USE phycst           ! physical constants 
    24    USE ldftra_oce       ! ocean active tracers: lateral physics 
    25    USE dianam           ! 
     23   ! 
    2624   USE iom              ! IOM library 
    27    USE ioipsl           ! IO-IPSL library 
    2825   USE in_out_manager   ! I/O manager 
    2926   USE lib_mpp          ! MPP library 
    30    USE lbclnk           ! lateral boundary condition - processor exchanges 
    3127   USE timing           ! preformance summary 
    32    USE wrk_nemo         ! working arrays 
    3328 
    3429   IMPLICIT NONE 
    3530   PRIVATE 
    3631 
    37    INTERFACE ptr_vj 
    38       MODULE PROCEDURE ptr_vj_3d, ptr_vj_2d 
     32   INTERFACE ptr_sj 
     33      MODULE PROCEDURE ptr_sj_3d, ptr_sj_2d 
    3934   END INTERFACE 
    4035 
    41    PUBLIC   dia_ptr_init   ! call in opa module 
     36   PUBLIC   ptr_sj         ! call by tra_ldf & tra_adv routines 
     37   PUBLIC   ptr_sjk        !  
     38   PUBLIC   dia_ptr_init   ! call in step module 
    4239   PUBLIC   dia_ptr        ! call in step module 
    43    PUBLIC   ptr_vj         ! call by tra_ldf & tra_adv routines 
    44    PUBLIC   ptr_vjk        ! call by tra_ldf & tra_adv routines 
    4540 
    4641   !                                  !!** namelist  namptr  ** 
    47    LOGICAL , PUBLIC ::   ln_diaptr     !: Poleward transport flag (T) or not (F) 
    48    LOGICAL , PUBLIC ::   ln_subbas     !: Atlantic/Pacific/Indian basins calculation 
    49    LOGICAL , PUBLIC ::   ln_diaznl     !: Add zonal means and meridional stream functions 
    50    LOGICAL , PUBLIC ::   ln_ptrcomp    !: Add decomposition : overturning (and gyre, soon ...) 
    51    INTEGER , PUBLIC ::   nn_fptr       !: frequency of ptr computation  [time step] 
    52    INTEGER , PUBLIC ::   nn_fwri       !: frequency of ptr outputs      [time step] 
    53  
    54    REAL(wp), ALLOCATABLE, SAVE, PUBLIC, DIMENSION(:) ::   htr_adv, htr_ldf, htr_ove   !: Heat TRansports (adv, diff, overturn.) 
    55    REAL(wp), ALLOCATABLE, SAVE, PUBLIC, DIMENSION(:) ::   str_adv, str_ldf, str_ove   !: Salt TRansports (adv, diff, overturn.) 
     42   REAL(wp), ALLOCATABLE, SAVE, PUBLIC, DIMENSION(:) ::   htr_adv, htr_ldf   !: Heat TRansports (adv, diff, overturn.) 
     43   REAL(wp), ALLOCATABLE, SAVE, PUBLIC, DIMENSION(:) ::   str_adv, str_ldf   !: Salt TRansports (adv, diff, overturn.) 
    5644    
    57    REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   btmsk                  ! T-point basin interior masks 
    58    REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   btm30                  ! mask out Southern Ocean (=0 south of 30°S) 
    59    REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   htr  , str             ! adv heat and salt transports (approx) 
    60    REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   tn_jk, sn_jk , v_msf   ! i-mean T and S, j-Stream-Function 
    61    REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   sjk  , r1_sjk          ! i-mean i-k-surface and its inverse         
    62    REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   htr_eiv, str_eiv       ! bolus adv heat ans salt transports ('key_diaeiv') 
    63    REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   v_msf_eiv              ! bolus j-streamfuction              ('key_diaeiv') 
    64  
    65  
    66    INTEGER ::   niter       ! 
    67    INTEGER ::   nidom_ptr   ! 
    68    INTEGER ::   numptr      ! logical unit for Poleward TRansports 
    69    INTEGER ::   nptr        ! = 1 (ln_subbas=F) or = 5 (glo, atl, pac, ind, ipc) (ln_subbas=T)  
     45 
     46   LOGICAL, PUBLIC ::   ln_diaptr   !  Poleward transport flag (T) or not (F) 
     47   LOGICAL, PUBLIC ::   ln_subbas   !  Atlantic/Pacific/Indian basins calculation 
     48   INTEGER         ::   nptr        ! = 1 (l_subbas=F) or = 5 (glo, atl, pac, ind, ipc) (l_subbas=T)  
    7049 
    7150   REAL(wp) ::   rc_sv    = 1.e-6_wp   ! conversion from m3/s to Sverdrup 
    … …  
    7352   REAL(wp) ::   rc_ggram = 1.e-6_wp   ! conversion from g    to Pg 
    7453 
    75    REAL(wp), TARGET, DIMENSION(:),   ALLOCATABLE, SAVE :: p_fval1d 
    76    REAL(wp), TARGET, DIMENSION(:,:), ALLOCATABLE, SAVE :: p_fval2d 
    77  
    78    !! Integer, 1D workspace arrays. Not common enough to be implemented in  
    79    !! wrk_nemo module. 
    80    INTEGER, ALLOCATABLE, SAVE, DIMENSION(:) :: ndex  , ndex_atl     , ndex_pac     , ndex_ind     , ndex_ipc 
    81    INTEGER, ALLOCATABLE, SAVE, DIMENSION(:) ::         ndex_atl_30  , ndex_pac_30  , ndex_ind_30  , ndex_ipc_30 
    82    INTEGER, ALLOCATABLE, SAVE, DIMENSION(:) :: ndex_h, ndex_h_atl_30, ndex_h_pac_30, ndex_h_ind_30, ndex_h_ipc_30 
     54   CHARACTER(len=3), ALLOCATABLE, SAVE, DIMENSION(:)     :: clsubb 
     55   REAL(wp),         ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: btmsk   ! T-point basin interior masks 
     56   REAL(wp),         ALLOCATABLE, SAVE, DIMENSION(:,:)   :: btm30   ! mask out Southern Ocean (=0 south of 30°S) 
     57 
     58   REAL(wp), TARGET, ALLOCATABLE, SAVE, DIMENSION(:)     :: p_fval1d 
     59   REAL(wp), TARGET, ALLOCATABLE, SAVE, DIMENSION(:,:)   :: p_fval2d 
     60 
    8361 
    8462   !! * Substitutions 
    … …  
    9270CONTAINS 
    9371 
    94    FUNCTION dia_ptr_alloc() 
    95       !!---------------------------------------------------------------------- 
    96       !!                    ***  ROUTINE dia_ptr_alloc  *** 
    97       !!---------------------------------------------------------------------- 
    98       INTEGER               ::   dia_ptr_alloc   ! return value 
    99       INTEGER, DIMENSION(6) ::   ierr 
    100       !!---------------------------------------------------------------------- 
    101       ierr(:) = 0 
    102       ! 
    103       ALLOCATE( btmsk(jpi,jpj,nptr) ,           & 
    104          &      htr_adv(jpj) , str_adv(jpj) ,   & 
    105          &      htr_ldf(jpj) , str_ldf(jpj) ,   & 
    106          &      htr_ove(jpj) , str_ove(jpj),    & 
    107          &      htr(jpj,nptr) , str(jpj,nptr) , & 
    108          &      tn_jk(jpj,jpk,nptr) , sn_jk (jpj,jpk,nptr) , v_msf(jpj,jpk,nptr) , & 
    109          &      sjk  (jpj,jpk,nptr) , r1_sjk(jpj,jpk,nptr) , STAT=ierr(1)  ) 
    110          ! 
    111 #if defined key_diaeiv 
    112       ALLOCATE( htr_eiv(jpj,nptr) , str_eiv(jpj,nptr) , & 
    113          &      v_msf_eiv(jpj,jpk,nptr) , STAT=ierr(2) ) 
    114 #endif 
    115       ALLOCATE( p_fval1d(jpj), p_fval2d(jpj,jpk), Stat=ierr(3)) 
    116       ! 
    117       ALLOCATE(ndex(jpj*jpk),        ndex_atl(jpj*jpk), ndex_pac(jpj*jpk), & 
    118          &     ndex_ind(jpj*jpk),    ndex_ipc(jpj*jpk),                    & 
    119          &     ndex_atl_30(jpj*jpk), ndex_pac_30(jpj*jpk), Stat=ierr(4)) 
    120  
    121       ALLOCATE(ndex_ind_30(jpj*jpk), ndex_ipc_30(jpj*jpk),                   & 
    122          &     ndex_h(jpj),          ndex_h_atl_30(jpj), ndex_h_pac_30(jpj), & 
    123          &     ndex_h_ind_30(jpj),   ndex_h_ipc_30(jpj), Stat=ierr(5) ) 
    124          ! 
    125      ALLOCATE( btm30(jpi,jpj) , STAT=ierr(6)  ) 
    126          ! 
    127       dia_ptr_alloc = MAXVAL( ierr ) 
    128       IF(lk_mpp)   CALL mpp_sum( dia_ptr_alloc ) 
    129       ! 
    130    END FUNCTION dia_ptr_alloc 
    131  
    132  
    133    FUNCTION ptr_vj_3d( pva )   RESULT ( p_fval ) 
    134       !!---------------------------------------------------------------------- 
    135       !!                    ***  ROUTINE ptr_vj_3d  *** 
    136       !! 
    137       !! ** Purpose :   i-k sum computation of a j-flux array 
    138       !! 
    139       !! ** Method  : - i-k sum of pva using the interior 2D vmask (vmask_i). 
    140       !!              pva is supposed to be a masked flux (i.e. * vmask*e1v*e3v) 
    141       !! 
    142       !! ** Action  : - p_fval: i-k-mean poleward flux of pva 
    143       !!---------------------------------------------------------------------- 
    144       REAL(wp) , INTENT(in), DIMENSION(jpi,jpj,jpk) ::   pva   ! mask flux array at V-point 
    145       !! 
    146       INTEGER                  ::   ji, jj, jk   ! dummy loop arguments 
    147       INTEGER                  ::   ijpj         ! ??? 
    148       REAL(wp), POINTER, DIMENSION(:) :: p_fval  ! function value 
    149       !!-------------------------------------------------------------------- 
    150       ! 
    151       p_fval => p_fval1d 
    152  
    153       ijpj = jpj 
    154       p_fval(:) = 0._wp 
    155       DO jk = 1, jpkm1 
    156          DO jj = 2, jpjm1 
    157             DO ji = fs_2, fs_jpim1   ! Vector opt. 
    158                p_fval(jj) = p_fval(jj) + pva(ji,jj,jk) * tmask_i(ji,jj)  
    159             END DO 
    160          END DO 
    161       END DO 
    162 #if defined key_mpp_mpi 
    163       IF(lk_mpp)   CALL mpp_sum( p_fval, ijpj, ncomm_znl) 
    164 #endif 
    165       ! 
    166    END FUNCTION ptr_vj_3d 
    167  
    168  
    169    FUNCTION ptr_vj_2d( pva )   RESULT ( p_fval ) 
    170       !!---------------------------------------------------------------------- 
    171       !!                    ***  ROUTINE ptr_vj_2d  *** 
    172       !! 
    173       !! ** Purpose :   "zonal" and vertical sum computation of a i-flux array 
    174       !! 
    175       !! ** Method  : - i-k sum of pva using the interior 2D vmask (vmask_i). 
    176       !!      pva is supposed to be a masked flux (i.e. * vmask*e1v*e3v) 
    177       !! 
    178       !! ** Action  : - p_fval: i-k-mean poleward flux of pva 
    179       !!---------------------------------------------------------------------- 
    180       IMPLICIT none 
    181       REAL(wp) , INTENT(in), DIMENSION(jpi,jpj) ::   pva   ! mask flux array at V-point 
    182       !! 
    183       INTEGER                  ::   ji,jj       ! dummy loop arguments 
    184       INTEGER                  ::   ijpj        ! ??? 
    185       REAL(wp), POINTER, DIMENSION(:) :: p_fval ! function value 
    186       !!-------------------------------------------------------------------- 
    187       !  
    188       p_fval => p_fval1d 
    189  
    190       ijpj = jpj 
    191       p_fval(:) = 0._wp 
    192       DO jj = 2, jpjm1 
    193          DO ji = nldi, nlei   ! No vector optimisation here. Better use a mask ? 
    194             p_fval(jj) = p_fval(jj) + pva(ji,jj) * tmask_i(ji,jj) 
    195          END DO 
    196       END DO 
    197 #if defined key_mpp_mpi 
    198       CALL mpp_sum( p_fval, ijpj, ncomm_znl ) 
    199 #endif 
    200       !  
    201    END FUNCTION ptr_vj_2d 
    202  
    203  
    204    FUNCTION ptr_vjk( pva, pmsk )   RESULT ( p_fval ) 
    205       !!---------------------------------------------------------------------- 
    206       !!                    ***  ROUTINE ptr_vjk  *** 
    207       !! 
    208       !! ** Purpose :   i-sum computation of a j-velocity array 
    209       !! 
    210       !! ** Method  : - i-sum of pva using the interior 2D vmask (vmask_i). 
    211       !!              pva is supposed to be a masked flux (i.e. * vmask) 
    212       !! 
    213       !! ** Action  : - p_fval: i-mean poleward flux of pva 
    214       !!---------------------------------------------------------------------- 
    215       !! 
    216       IMPLICIT none 
    217       REAL(wp) , INTENT(in), DIMENSION(jpi,jpj,jpk)           ::   pva    ! mask flux array at V-point 
    218       REAL(wp) , INTENT(in), DIMENSION(jpi,jpj)    , OPTIONAL ::   pmsk   ! Optional 2D basin mask 
    219       !! 
    220       INTEGER                           :: ji, jj, jk ! dummy loop arguments 
    221       REAL(wp), POINTER, DIMENSION(:,:) :: p_fval     ! return function value 
    222 #if defined key_mpp_mpi 
    223       INTEGER, DIMENSION(1) ::   ish 
    224       INTEGER, DIMENSION(2) ::   ish2 
    225       INTEGER               ::   ijpjjpk 
    226 #endif 
    227 #if defined key_mpp_mpi 
    228       REAL(wp), POINTER, DIMENSION(:) ::   zwork    ! mask flux array at V-point 
    229 #endif 
    230       !!-------------------------------------------------------------------- 
    231       ! 
    232 #if defined key_mpp_mpi 
    233       ijpjjpk = jpj*jpk 
    234       CALL wrk_alloc( jpj*jpk, zwork ) 
    235 #endif 
    236  
    237       p_fval => p_fval2d 
    238  
    239       p_fval(:,:) = 0._wp 
    240       ! 
    241       IF( PRESENT( pmsk ) ) THEN  
    242          DO jk = 1, jpkm1 
    243             DO jj = 2, jpjm1 
    244 !!gm here, use of tmask_i  ==> no need of loop over nldi, nlei.... 
    245                DO ji =  nldi, nlei   ! No vector optimisation here. Better use a mask ? 
    246                   p_fval(jj,jk) = p_fval(jj,jk) + pva(ji,jj,jk) * e1v(ji,jj) * fse3v(ji,jj,jk) * pmsk(ji,jj) 
     72   SUBROUTINE dia_ptr( pvtr ) 
     73      !!---------------------------------------------------------------------- 
     74      !!                  ***  ROUTINE dia_ptr  *** 
     75      !!---------------------------------------------------------------------- 
     76      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in), OPTIONAL ::   pvtr   ! j-effective transport 
     77      ! 
     78      INTEGER  ::   ji, jj, jk, jn   ! dummy loop indices 
     79      REAL(wp) ::   zv, zsfc               ! local scalar 
     80      REAL(wp), DIMENSION(jpi,jpj)     ::  z2d   ! 2D workspace 
     81      REAL(wp), DIMENSION(jpi,jpj,jpk) ::  z3d   ! 3D workspace 
     82      REAL(wp), DIMENSION(jpi,jpj,jpk) ::  zmask   ! 3D workspace 
     83      REAL(wp), DIMENSION(jpi,jpj,jpk,jpts) ::  zts   ! 3D workspace 
     84      CHARACTER( len = 10 )  :: cl1 
     85      !!---------------------------------------------------------------------- 
     86      ! 
     87      IF( nn_timing == 1 )   CALL timing_start('dia_ptr') 
     88 
     89      ! 
     90      IF( PRESENT( pvtr ) ) THEN 
     91         IF( iom_use("zomsfglo") ) THEN    ! effective MSF 
     92            z3d(1,:,:) = ptr_sjk( pvtr(:,:,:) )  ! zonal cumulative effective transport 
     93            DO jk = 2, jpkm1  
     94              z3d(1,:,jk) = z3d(1,:,jk-1) + z3d(1,:,jk)   ! effective j-Stream-Function (MSF) 
     95            END DO 
     96            DO ji = 1, jpi 
     97               z3d(ji,:,:) = z3d(1,:,:) 
     98            ENDDO 
     99            cl1 = TRIM('zomsf'//clsubb(1) ) 
     100            CALL iom_put( cl1, z3d * rc_sv ) 
     101            DO jn = 2, nptr                                    ! by sub-basins 
     102               z3d(1,:,:) =  ptr_sjk( pvtr(:,:,:), btmsk(:,:,jn)*btm30(:,:) )  
     103               DO jk = 2, jpkm1  
     104                  z3d(1,:,jk) = z3d(1,:,jk-1) + z3d(1,:,jk)    ! effective j-Stream-Function (MSF) 
    247105               END DO 
    248             END DO 
    249          END DO 
    250       ELSE  
    251          DO jk = 1, jpkm1 
    252             DO jj = 2, jpjm1 
    253                DO ji =  nldi, nlei   ! No vector optimisation here. Better use a mask ? 
    254                   p_fval(jj,jk) = p_fval(jj,jk) + pva(ji,jj,jk) * e1v(ji,jj) * fse3v(ji,jj,jk) * tmask_i(ji,jj) 
    255                END DO 
    256             END DO 
    257          END DO 
    258       END IF 
    259       ! 
    260 #if defined key_mpp_mpi 
    261       ijpjjpk = jpj*jpk 
    262       ish(1) = ijpjjpk  ;   ish2(1) = jpj   ;   ish2(2) = jpk 
    263       zwork(1:ijpjjpk) = RESHAPE( p_fval, ish ) 
    264       CALL mpp_sum( zwork, ijpjjpk, ncomm_znl ) 
    265       p_fval(:,:) = RESHAPE( zwork, ish2 ) 
    266 #endif 
    267       ! 
    268 #if defined key_mpp_mpi 
    269       CALL wrk_dealloc( jpj*jpk, zwork ) 
    270 #endif 
    271       ! 
    272    END FUNCTION ptr_vjk 
    273  
    274  
    275    FUNCTION ptr_tjk( pta, pmsk )   RESULT ( p_fval ) 
    276       !!---------------------------------------------------------------------- 
    277       !!                    ***  ROUTINE ptr_tjk  *** 
    278       !! 
    279       !! ** Purpose :   i-sum computation of e1t*e3t * a tracer field 
    280       !! 
    281       !! ** Method  : - i-sum of mj(pta) using tmask 
    282       !! 
    283       !! ** Action  : - p_fval: i-sum of e1t*e3t*pta 
    284       !!---------------------------------------------------------------------- 
    285       !! 
    286       REAL(wp) , INTENT(in), DIMENSION(jpi,jpj,jpk) ::   pta    ! tracer flux array at T-point 
    287       REAL(wp) , INTENT(in), DIMENSION(jpi,jpj)     ::   pmsk   ! Optional 2D basin mask 
    288       !! 
    289       INTEGER                           :: ji, jj, jk   ! dummy loop arguments 
    290       REAL(wp), POINTER, DIMENSION(:,:) :: p_fval       ! return function value 
    291 #if defined key_mpp_mpi 
    292       INTEGER, DIMENSION(1) ::   ish 
    293       INTEGER, DIMENSION(2) ::   ish2 
    294       INTEGER               ::   ijpjjpk 
    295 #endif 
    296 #if defined key_mpp_mpi 
    297       REAL(wp), POINTER, DIMENSION(:) ::   zwork    ! mask flux array at V-point 
    298 #endif 
    299       !!--------------------------------------------------------------------  
    300       ! 
    301 #if defined key_mpp_mpi 
    302       ijpjjpk = jpj*jpk 
    303       CALL wrk_alloc( jpj*jpk, zwork ) 
    304 #endif 
    305  
    306       p_fval => p_fval2d 
    307  
    308       p_fval(:,:) = 0._wp 
    309       DO jk = 1, jpkm1 
    310          DO jj = 2, jpjm1 
    311             DO ji =  nldi, nlei   ! No vector optimisation here. Better use a mask ? 
    312                p_fval(jj,jk) = p_fval(jj,jk) + pta(ji,jj,jk) * e1t(ji,jj) * fse3t(ji,jj,jk) * pmsk(ji,jj) 
    313             END DO 
    314          END DO 
    315       END DO 
    316 #if defined key_mpp_mpi 
    317       ijpjjpk = jpj*jpk 
    318       ish(1) = jpj*jpk   ;   ish2(1) = jpj   ;   ish2(2) = jpk 
    319       zwork(1:ijpjjpk)= RESHAPE( p_fval, ish ) 
    320       CALL mpp_sum( zwork, ijpjjpk, ncomm_znl ) 
    321       p_fval(:,:)= RESHAPE( zwork, ish2 ) 
    322 #endif 
    323       ! 
    324 #if defined key_mpp_mpi 
    325       CALL wrk_dealloc( jpj*jpk, zwork ) 
    326 #endif 
    327       !     
    328    END FUNCTION ptr_tjk 
    329  
    330  
    331    SUBROUTINE dia_ptr( kt ) 
    332       !!---------------------------------------------------------------------- 
    333       !!                  ***  ROUTINE dia_ptr  *** 
    334       !!---------------------------------------------------------------------- 
    335       USE oce,     vt  =>   ua   ! use ua as workspace 
    336       USE oce,     vs  =>   va   ! use va as workspace 
    337       IMPLICIT none 
    338       !! 
    339       INTEGER, INTENT(in) ::   kt   ! ocean time step index 
    340       ! 
    341       INTEGER  ::   ji, jj, jk, jn   ! dummy loop indices 
    342       REAL(wp) ::   zv               ! local scalar 
    343       !!---------------------------------------------------------------------- 
    344       ! 
    345       IF( nn_timing == 1 )   CALL timing_start('dia_ptr') 
    346       ! 
    347       IF( kt == nit000 .OR. MOD( kt, nn_fptr ) == 0 )   THEN 
    348          ! 
    349          IF( MOD( kt, nn_fptr ) == 0 ) THEN  
    350             ! 
    351             IF( ln_diaznl ) THEN               ! i-mean temperature and salinity 
    352                DO jn = 1, nptr 
    353                   tn_jk(:,:,jn) = ptr_tjk( tsn(:,:,:,jp_tem), btmsk(:,:,jn) ) * r1_sjk(:,:,jn) 
    354                   sn_jk(:,:,jn) = ptr_tjk( tsn(:,:,:,jp_sal), btmsk(:,:,jn) ) * r1_sjk(:,:,jn) 
    355                END DO 
    356             ENDIF 
    357             ! 
    358             !                          ! horizontal integral and vertical dz  
    359             !                                ! eulerian velocity 
    360             v_msf(:,:,1) = ptr_vjk( vn(:,:,:) )  
    361             DO jn = 2, nptr 
    362                v_msf(:,:,jn) = ptr_vjk( vn(:,:,:), btmsk(:,:,jn)*btm30(:,:) )  
    363             END DO 
    364 #if defined key_diaeiv 
    365             DO jn = 1, nptr                  ! bolus velocity 
    366                v_msf_eiv(:,:,jn) = ptr_vjk( v_eiv(:,:,:), btmsk(:,:,jn) )   ! here no btm30 for MSFeiv 
    367             END DO 
    368             !                                ! add bolus stream-function to the eulerian one 
    369             v_msf(:,:,:) = v_msf(:,:,:) + v_msf_eiv(:,:,:) 
    370 #endif 
    371             ! 
    372             !                          ! Transports 
    373             !                                ! local heat & salt transports at T-points  ( tsn*mj[vn+v_eiv] ) 
    374             vt(:,:,jpk) = 0._wp   ;   vs(:,:,jpk) = 0._wp 
    375             DO jk= 1, jpkm1 
    376                DO jj = 2, jpj 
     106               DO ji = 1, jpi 
     107                  z3d(ji,:,:) = z3d(1,:,:) 
     108               ENDDO 
     109               cl1 = TRIM('zomsf'//clsubb(jn) ) 
     110               CALL iom_put( cl1, z3d * rc_sv ) 
     111            END DO 
     112         ENDIF 
     113         ! 
     114      ELSE 
     115         ! 
     116         IF( iom_use("zotemglo") ) THEN    ! i-mean i-k-surface  
     117            DO jk = 1, jpkm1 
     118               DO jj = 1, jpj 
    377119                  DO ji = 1, jpi 
    378 #if defined key_diaeiv  
    379                      zv = ( vn(ji,jj,jk) + vn(ji,jj-1,jk) + v_eiv(ji,jj,jk) + v_eiv(ji,jj-1,jk) ) * 0.5_wp 
    380 #else 
    381                      zv = ( vn(ji,jj,jk) + vn(ji,jj-1,jk) ) * 0.5_wp 
    382 #endif  
    383                      vt(ji,jj,jk) = zv * tsn(ji,jj,jk,jp_tem) 
    384                      vs(ji,jj,jk) = zv * tsn(ji,jj,jk,jp_sal) 
    385                   END DO 
    386                END DO 
    387             END DO 
    388 !!gm useless as overlap areas are not used in ptr_vjk 
    389             CALL lbc_lnk( vs, 'V', -1. )   ;   CALL lbc_lnk( vt, 'V', -1. ) 
    390 !!gm 
    391             !                                ! heat & salt advective transports (approximation) 
    392             htr(:,1) = SUM( ptr_vjk( vt(:,:,:) ) , 2 ) * rc_pwatt   ! SUM over jk + conversion 
    393             str(:,1) = SUM( ptr_vjk( vs(:,:,:) ) , 2 ) * rc_ggram 
    394             DO jn = 2, nptr  
    395                htr(:,jn) = SUM( ptr_vjk( vt(:,:,:), btmsk(:,:,jn)*btm30(:,:) ) , 2 ) * rc_pwatt   ! mask Southern Ocean 
    396                str(:,jn) = SUM( ptr_vjk( vs(:,:,:), btmsk(:,:,jn)*btm30(:,:) ) , 2 ) * rc_ggram   ! mask Southern Ocean 
    397             END DO 
    398  
    399             IF( ln_ptrcomp ) THEN            ! overturning transport 
    400                htr_ove(:) = SUM( v_msf(:,:,1) * tn_jk(:,:,1), 2 ) * rc_pwatt   ! SUM over jk + conversion 
    401                str_ove(:) = SUM( v_msf(:,:,1) * sn_jk(:,:,1), 2 ) * rc_ggram 
    402             END IF 
    403             !                                ! Advective and diffusive transport 
    404             htr_adv(:) = htr_adv(:) * rc_pwatt        ! these are computed in tra_adv... and tra_ldf... routines  
    405             htr_ldf(:) = htr_ldf(:) * rc_pwatt        ! here just the conversion in PW and Gg 
    406             str_adv(:) = str_adv(:) * rc_ggram 
    407             str_ldf(:) = str_ldf(:) * rc_ggram 
    408  
    409 #if defined key_diaeiv 
    410             DO jn = 1, nptr                  ! Bolus component 
    411                htr_eiv(:,jn) = SUM( v_msf_eiv(:,:,jn) * tn_jk(:,:,jn), 2 ) * rc_pwatt   ! SUM over jk 
    412                str_eiv(:,jn) = SUM( v_msf_eiv(:,:,jn) * sn_jk(:,:,jn), 2 ) * rc_ggram   ! SUM over jk 
    413             END DO 
    414 #endif 
    415             !                                ! "Meridional" Stream-Function 
     120                     zsfc = e1t(ji,jj) * fse3t(ji,jj,jk) 
     121                     zmask(ji,jj,jk)      = tmask(ji,jj,jk)      * zsfc 
     122                     zts(ji,jj,jk,jp_tem) = tsn(ji,jj,jk,jp_tem) * zsfc 
     123                     zts(ji,jj,jk,jp_sal) = tsn(ji,jj,jk,jp_sal) * zsfc 
     124                  ENDDO 
     125               ENDDO 
     126            ENDDO 
    416127            DO jn = 1, nptr 
    417                DO jk = 2, jpk  
    418                   v_msf    (:,jk,jn) = v_msf    (:,jk-1,jn) + v_msf    (:,jk,jn)       ! Eulerian j-Stream-Function 
    419 #if defined key_diaeiv 
    420                   v_msf_eiv(:,jk,jn) = v_msf_eiv(:,jk-1,jn) + v_msf_eiv(:,jk,jn)       ! Bolus    j-Stream-Function 
    421  
    422 #endif 
    423                END DO 
    424             END DO 
    425             v_msf    (:,:,:) = v_msf    (:,:,:) * rc_sv       ! converte in Sverdrups 
    426 #if defined key_diaeiv 
    427             v_msf_eiv(:,:,:) = v_msf_eiv(:,:,:) * rc_sv 
    428 #endif 
    429          ENDIF 
    430          ! 
    431          CALL dia_ptr_wri( kt )                        ! outputs 
     128               zmask(1,:,:) = ptr_sjk( zmask(:,:,:), btmsk(:,:,jn) ) 
     129               cl1 = TRIM('zosrf'//clsubb(jn) ) 
     130               CALL iom_put( cl1, zmask ) 
     131               ! 
     132               z3d(1,:,:) = ptr_sjk( zts(:,:,:,jp_tem), btmsk(:,:,jn) ) & 
     133                  &            / MAX( zmask(1,:,:), 10.e-15 ) 
     134               DO ji = 1, jpi 
     135                  z3d(ji,:,:) = z3d(1,:,:) 
     136               ENDDO 
     137               cl1 = TRIM('zotem'//clsubb(jn) ) 
     138               CALL iom_put( cl1, z3d ) 
     139               ! 
     140               z3d(1,:,:) = ptr_sjk( zts(:,:,:,jp_sal), btmsk(:,:,jn) ) & 
     141                  &            / MAX( zmask(1,:,:), 10.e-15 ) 
     142               DO ji = 1, jpi 
     143                  z3d(ji,:,:) = z3d(1,:,:) 
     144               ENDDO 
     145               cl1 = TRIM('zosal'//clsubb(jn) ) 
     146               CALL iom_put( cl1, z3d ) 
     147            END DO 
     148         ENDIF 
     149         ! 
     150         !                                ! Advective and diffusive heat and salt transport 
     151         IF( iom_use("sophtadv") .OR. iom_use("sopstadv") ) THEN    
     152            z2d(1,:) = htr_adv(:) * rc_pwatt        !  (conversion in PW) 
     153            DO ji = 1, jpi 
     154               z2d(ji,:) = z2d(1,:) 
     155            ENDDO 
     156            cl1 = 'sophtadv'                  
     157            CALL iom_put( TRIM(cl1), z2d ) 
     158            z2d(1,:) = str_adv(:) * rc_ggram        ! (conversion in Gg) 
     159            DO ji = 1, jpi 
     160               z2d(ji,:) = z2d(1,:) 
     161            ENDDO 
     162            cl1 = 'sopstadv' 
     163            CALL iom_put( TRIM(cl1), z2d ) 
     164         ENDIF 
     165         ! 
     166         IF( iom_use("sophtldf") .OR. iom_use("sopstldf") ) THEN    
     167            z2d(1,:) = htr_ldf(:) * rc_pwatt        !  (conversion in PW)  
     168            DO ji = 1, jpi 
     169               z2d(ji,:) = z2d(1,:) 
     170            ENDDO 
     171            cl1 = 'sophtldf' 
     172            CALL iom_put( TRIM(cl1), z2d ) 
     173            z2d(1,:) = str_ldf(:) * rc_ggram        !  (conversion in Gg) 
     174            DO ji = 1, jpi 
     175               z2d(ji,:) = z2d(1,:) 
     176            ENDDO 
     177            cl1 = 'sopstldf' 
     178            CALL iom_put( TRIM(cl1), z2d ) 
     179         ENDIF 
    432180         ! 
    433181      ENDIF 
    434       ! 
    435 #if defined key_mpp_mpi 
    436       IF( kt == nitend .AND. l_znl_root )   CALL histclo( numptr )      ! Close the file 
    437 #else 
    438       IF( kt == nitend )                    CALL histclo( numptr )      ! Close the file 
    439 #endif 
    440182      ! 
    441183      IF( nn_timing == 1 )   CALL timing_stop('dia_ptr') 
    … …  
    450192      !! ** Purpose :   Initialization, namelist read 
    451193      !!---------------------------------------------------------------------- 
    452       INTEGER ::   jn           ! dummy loop indices  
    453       INTEGER ::   inum, ierr   ! local integers 
    454       INTEGER ::   ios          ! Local integer output status for namelist read 
    455 #if defined key_mpp_mpi 
    456       INTEGER, DIMENSION(1) :: iglo, iloc, iabsf, iabsl, ihals, ihale, idid 
    457 #endif 
    458       !! 
    459       NAMELIST/namptr/ ln_diaptr, ln_diaznl, ln_subbas, ln_ptrcomp, nn_fptr, nn_fwri 
     194      INTEGER ::  jn           ! local integers 
     195      INTEGER ::  inum, ierr   ! local integers 
     196      INTEGER ::  ios          ! Local integer output status for namelist read 
     197      !! 
     198      NAMELIST/namptr/ ln_diaptr, ln_subbas 
    460199      !!---------------------------------------------------------------------- 
    461200 
    … …  
    475214         WRITE(numout,*) '   Namelist namptr : set ptr parameters' 
    476215         WRITE(numout,*) '      Poleward heat & salt transport (T) or not (F)      ln_diaptr  = ', ln_diaptr 
    477          WRITE(numout,*) '      Overturning heat & salt transport                  ln_ptrcomp = ', ln_ptrcomp 
    478          WRITE(numout,*) '      T & S zonal mean and meridional stream function    ln_diaznl  = ', ln_diaznl  
    479216         WRITE(numout,*) '      Global (F) or glo/Atl/Pac/Ind/Indo-Pac basins      ln_subbas  = ', ln_subbas 
    480          WRITE(numout,*) '      Frequency of computation                           nn_fptr    = ', nn_fptr 
    481          WRITE(numout,*) '      Frequency of outputs                               nn_fwri    = ', nn_fwri 
    482217      ENDIF 
    483        
    484       IF( ln_diaptr) THEN   
    485       
    486          IF( nn_timing == 1 )   CALL timing_start('dia_ptr_init') 
    487        
    488          IF( ln_subbas ) THEN   ;   nptr = 5       ! Global, Atlantic, Pacific, Indian, Indo-Pacific 
    489          ELSE                   ;   nptr = 1       ! Global only 
     218 
     219      IF( ln_diaptr ) THEN   
     220         ! 
     221         IF( ln_subbas ) THEN  
     222            nptr = 5            ! Global, Atlantic, Pacific, Indian, Indo-Pacific 
     223            ALLOCATE( clsubb(nptr) ) 
     224            clsubb(1) = 'glo' ;  clsubb(2) = 'atl'  ;  clsubb(3) = 'pac'  ;  clsubb(4) = 'ind'  ;  clsubb(5) = 'ipc' 
     225         ELSE                
     226            nptr = 1       ! Global only 
     227            ALLOCATE( clsubb(nptr) ) 
     228            clsubb(1) = 'glo'  
    490229         ENDIF 
    491230 
    … …  
    493232         IF( dia_ptr_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'dia_ptr_init : unable to allocate arrays' ) 
    494233 
    495          rc_pwatt = rc_pwatt * rau0 * rcp          ! conversion from K.s-1 to PetaWatt 
     234         rc_pwatt = rc_pwatt * rau0_rcp          ! conversion from K.s-1 to PetaWatt 
    496235 
    497236         IF( lk_mpp )   CALL mpp_ini_znl( numout )     ! Define MPI communicator for zonal sum 
    498237 
    499238         IF( ln_subbas ) THEN                ! load sub-basin mask 
    500             CALL iom_open( 'subbasins', inum ) 
     239            CALL iom_open( 'subbasins', inum,  ldstop = .FALSE. ) 
    501240            CALL iom_get( inum, jpdom_data, 'atlmsk', btmsk(:,:,2) )   ! Atlantic basin 
    502241            CALL iom_get( inum, jpdom_data, 'pacmsk', btmsk(:,:,3) )   ! Pacific  basin 
    … …  
    508247            END WHERE 
    509248         ENDIF 
     249    
    510250         btmsk(:,:,1) = tmask_i(:,:)                                   ! global ocean 
    511251       
    … …  
    513253            btmsk(:,:,jn) = btmsk(:,:,jn) * tmask_i(:,:)               ! interior domain only 
    514254         END DO 
    515        
    516          IF( lk_vvl )   CALL ctl_stop( 'diaptr: error in vvl case as constant i-mean surface is used' ) 
    517  
    518          !                                   ! i-sum of e1v*e3v surface and its inverse 
    519          DO jn = 1, nptr 
    520             sjk(:,:,jn) = ptr_tjk( tmask(:,:,:), btmsk(:,:,jn) ) 
    521             r1_sjk(:,:,jn) = 0._wp 
    522             WHERE( sjk(:,:,jn) /= 0._wp )   r1_sjk(:,:,jn) = 1._wp / sjk(:,:,jn) 
    523          END DO 
    524  
    525       ! Initialise arrays to zero because diatpr is called before they are first calculated 
    526       ! Note that this means diagnostics will not be exactly correct when model run is restarted. 
    527       htr_adv(:) = 0._wp ; str_adv(:) =  0._wp ;  htr_ldf(:) = 0._wp ; str_ldf(:) =  0._wp 
    528  
    529 #if defined key_mpp_mpi  
    530          iglo (1) = jpjglo                   ! MPP case using MPI  ('key_mpp_mpi') 
    531          iloc (1) = nlcj 
    532          iabsf(1) = njmppt(narea) 
    533          iabsl(:) = iabsf(:) + iloc(:) - 1 
    534          ihals(1) = nldj - 1 
    535          ihale(1) = nlcj - nlej 
    536          idid (1) = 2 
    537          CALL flio_dom_set( jpnj, nproc/jpni, idid, iglo, iloc, iabsf, iabsl, ihals, ihale, 'BOX', nidom_ptr ) 
    538 #else 
    539          nidom_ptr = FLIO_DOM_NONE 
    540 #endif 
    541       IF( nn_timing == 1 )   CALL timing_stop('dia_ptr_init') 
    542       ! 
     255 
     256         ! Initialise arrays to zero because diatpr is called before they are first calculated 
     257         ! Note that this means diagnostics will not be exactly correct when model run is restarted. 
     258         htr_adv(:) = 0._wp  ;  str_adv(:) =  0._wp   
     259         htr_ldf(:) = 0._wp  ;  str_ldf(:) =  0._wp  
     260         ! 
    543261      ENDIF  
    544262      !  
    … …  
    546264 
    547265 
    548    SUBROUTINE dia_ptr_wri( kt ) 
    549       !!--------------------------------------------------------------------- 
    550       !!                ***  ROUTINE dia_ptr_wri  *** 
    551       !! 
    552       !! ** Purpose :   output of poleward fluxes 
    553       !! 
    554       !! ** Method  :   NetCDF file 
    555       !!---------------------------------------------------------------------- 
    556       !! 
    557       INTEGER, INTENT(in) ::   kt   ! ocean time-step index 
    558       !! 
    559       INTEGER, SAVE ::   nhoridz, ndepidzt, ndepidzw 
    560       INTEGER, SAVE ::   ndim  , ndim_atl     , ndim_pac     , ndim_ind     , ndim_ipc 
    561       INTEGER, SAVE ::           ndim_atl_30  , ndim_pac_30  , ndim_ind_30  , ndim_ipc_30 
    562       INTEGER, SAVE ::   ndim_h, ndim_h_atl_30, ndim_h_pac_30, ndim_h_ind_30, ndim_h_ipc_30 
    563       !! 
    564       CHARACTER (len=40) ::   clhstnam, clop, clop_once, cl_comment   ! temporary names 
    565       INTEGER            ::   iline, it, itmod, ji, jj, jk            ! 
    566 #if defined key_iomput 
    567       INTEGER            ::   inum                                    ! temporary logical unit 
     266   FUNCTION dia_ptr_alloc() 
     267      !!---------------------------------------------------------------------- 
     268      !!                    ***  ROUTINE dia_ptr_alloc  *** 
     269      !!---------------------------------------------------------------------- 
     270      INTEGER               ::   dia_ptr_alloc   ! return value 
     271      INTEGER, DIMENSION(3) ::   ierr 
     272      !!---------------------------------------------------------------------- 
     273      ierr(:) = 0 
     274      ! 
     275      ALLOCATE( btmsk(jpi,jpj,nptr) ,           & 
     276         &      htr_adv(jpj) , str_adv(jpj) ,   & 
     277         &      htr_ldf(jpj) , str_ldf(jpj) , STAT=ierr(1)  ) 
     278         ! 
     279      ALLOCATE( p_fval1d(jpj), p_fval2d(jpj,jpk), Stat=ierr(2)) 
     280      ! 
     281      ALLOCATE( btm30(jpi,jpj), STAT=ierr(3)  ) 
     282 
     283         ! 
     284      dia_ptr_alloc = MAXVAL( ierr ) 
     285      IF(lk_mpp)   CALL mpp_sum( dia_ptr_alloc ) 
     286      ! 
     287   END FUNCTION dia_ptr_alloc 
     288 
     289 
     290   FUNCTION ptr_sj_3d( pva, pmsk )   RESULT ( p_fval ) 
     291      !!---------------------------------------------------------------------- 
     292      !!                    ***  ROUTINE ptr_sj_3d  *** 
     293      !! 
     294      !! ** Purpose :   i-k sum computation of a j-flux array 
     295      !! 
     296      !! ** Method  : - i-k sum of pva using the interior 2D vmask (vmask_i). 
     297      !!              pva is supposed to be a masked flux (i.e. * vmask*e1v*e3v) 
     298      !! 
     299      !! ** Action  : - p_fval: i-k-mean poleward flux of pva 
     300      !!---------------------------------------------------------------------- 
     301      REAL(wp), INTENT(in), DIMENSION(jpi,jpj,jpk)       ::   pva   ! mask flux array at V-point 
     302      REAL(wp), INTENT(in), DIMENSION(jpi,jpj), OPTIONAL ::   pmsk   ! Optional 2D basin mask 
     303      ! 
     304      INTEGER                  ::   ji, jj, jk   ! dummy loop arguments 
     305      INTEGER                  ::   ijpj         ! ??? 
     306      REAL(wp), POINTER, DIMENSION(:) :: p_fval  ! function value 
     307      !!-------------------------------------------------------------------- 
     308      ! 
     309      p_fval => p_fval1d 
     310 
     311      ijpj = jpj 
     312      p_fval(:) = 0._wp 
     313      IF( PRESENT( pmsk ) ) THEN  
     314         DO jk = 1, jpkm1 
     315            DO jj = 2, jpjm1 
     316               DO ji = fs_2, fs_jpim1   ! Vector opt. 
     317                  p_fval(jj) = p_fval(jj) + pva(ji,jj,jk) * tmask_i(ji,jj) * pmsk(ji,jj) 
     318               END DO 
     319            END DO 
     320         END DO 
     321      ELSE 
     322         DO jk = 1, jpkm1 
     323            DO jj = 2, jpjm1 
     324               DO ji = fs_2, fs_jpim1   ! Vector opt. 
     325                  p_fval(jj) = p_fval(jj) + pva(ji,jj,jk) * tmask_i(ji,jj)  
     326               END DO 
     327            END DO 
     328         END DO 
     329      ENDIF 
     330#if defined key_mpp_mpi 
     331      IF(lk_mpp)   CALL mpp_sum( p_fval, ijpj, ncomm_znl) 
    568332#endif 
    569       REAL(wp)           ::   zsto, zout, zdt, zjulian                ! temporary scalars 
    570       !! 
    571       REAL(wp), POINTER, DIMENSION(:)   ::   zphi, zfoo    ! 1D workspace 
    572       REAL(wp), POINTER, DIMENSION(:,:) ::   z_1           ! 2D workspace 
    573       !!--------------------------------------------------------------------  
    574       ! 
    575       CALL wrk_alloc( jpj       , zphi , zfoo ) 
    576       CALL wrk_alloc( jpj , jpk , z_1  ) 
    577  
    578       ! define time axis 
    579       it    = kt / nn_fptr 
    580       itmod = kt - nit000 + 1 
    581        
    582       ! Initialization 
    583       ! -------------- 
    584       IF( kt == nit000 ) THEN 
    585          niter = ( nit000 - 1 ) / nn_fptr 
    586          zdt = rdt 
    587          IF( nacc == 1 )   zdt = rdtmin 
    588          ! 
    589          IF(lwp) THEN 
    590             WRITE(numout,*) 
    591             WRITE(numout,*) 'dia_ptr_wri : poleward transport and msf writing: initialization , niter = ', niter 
    592             WRITE(numout,*) '~~~~~~~~~~~~' 
    593          ENDIF 
    594  
    595          ! Reference latitude (used in plots) 
    596          ! ------------------ 
    597          !                                           ! ======================= 
    598          IF( cp_cfg == "orca" ) THEN                 !   ORCA configurations 
    599             !                                        ! ======================= 
    600             IF( jp_cfg == 05  )   iline = 192   ! i-line that passes near the North Pole 
    601             IF( jp_cfg == 025 )   iline = 384   ! i-line that passes near the North Pole 
    602             IF( jp_cfg == 1   )   iline =  96   ! i-line that passes near the North Pole 
    603             IF( jp_cfg == 2   )   iline =  48   ! i-line that passes near the North Pole 
    604             IF( jp_cfg == 4   )   iline =  24   ! i-line that passes near the North Pole 
    605             zphi(1:jpj) = 0._wp 
    606             DO ji = mi0(iline), mi1(iline)  
    607                zphi(1:jpj) = gphiv(ji,:)         ! if iline is in the local domain 
    608                ! Correct highest latitude for some configurations - will work if domain is parallelized in J ? 
    609                IF( jp_cfg == 05 ) THEN 
    610                   DO jj = mj0(jpjdta), mj1(jpjdta)  
    611                      zphi( jj ) = zphi(mj0(jpjdta-1)) + ( zphi(mj0(jpjdta-1))-zphi(mj0(jpjdta-2)) ) * 0.5_wp 
    612                      zphi( jj ) = MIN( zphi(jj), 90._wp ) 
    613                   END DO 
    614                END IF 
    615                IF( jp_cfg == 1 .OR. jp_cfg == 2 .OR. jp_cfg == 4 ) THEN 
    616                   DO jj = mj0(jpjdta-1), mj1(jpjdta-1)  
    617                      zphi( jj ) = 88.5_wp 
    618                   END DO 
    619                   DO jj = mj0(jpjdta  ), mj1(jpjdta  )  
    620                      zphi( jj ) = 89.5_wp 
    621                   END DO 
    622                END IF 
    623             END DO 
    624             ! provide the correct zphi to all local domains 
     333      ! 
     334   END FUNCTION ptr_sj_3d 
     335 
     336 
     337   FUNCTION ptr_sj_2d( pva, pmsk )   RESULT ( p_fval ) 
     338      !!---------------------------------------------------------------------- 
     339      !!                    ***  ROUTINE ptr_sj_2d  *** 
     340      !! 
     341      !! ** Purpose :   "zonal" and vertical sum computation of a i-flux array 
     342      !! 
     343      !! ** Method  : - i-k sum of pva using the interior 2D vmask (vmask_i). 
     344      !!      pva is supposed to be a masked flux (i.e. * vmask*e1v*e3v) 
     345      !! 
     346      !! ** Action  : - p_fval: i-k-mean poleward flux of pva 
     347      !!---------------------------------------------------------------------- 
     348      REAL(wp) , INTENT(in), DIMENSION(jpi,jpj)           ::   pva   ! mask flux array at V-point 
     349      REAL(wp) , INTENT(in), DIMENSION(jpi,jpj), OPTIONAL ::   pmsk   ! Optional 2D basin mask 
     350      ! 
     351      INTEGER                  ::   ji,jj       ! dummy loop arguments 
     352      INTEGER                  ::   ijpj        ! ??? 
     353      REAL(wp), POINTER, DIMENSION(:) :: p_fval ! function value 
     354      !!-------------------------------------------------------------------- 
     355      !  
     356      p_fval => p_fval1d 
     357 
     358      ijpj = jpj 
     359      p_fval(:) = 0._wp 
     360      IF( PRESENT( pmsk ) ) THEN  
     361         DO jj = 2, jpjm1 
     362            DO ji = nldi, nlei   ! No vector optimisation here. Better use a mask ? 
     363               p_fval(jj) = p_fval(jj) + pva(ji,jj) * tmask_i(ji,jj) * pmsk(ji,jj) 
     364            END DO 
     365         END DO 
     366      ELSE 
     367         DO jj = 2, jpjm1 
     368            DO ji = nldi, nlei   ! No vector optimisation here. Better use a mask ? 
     369               p_fval(jj) = p_fval(jj) + pva(ji,jj) * tmask_i(ji,jj) 
     370            END DO 
     371         END DO 
     372      ENDIF 
    625373#if defined key_mpp_mpi 
    626             CALL mpp_sum( zphi, jpj, ncomm_znl )         
     374      CALL mpp_sum( p_fval, ijpj, ncomm_znl ) 
    627375#endif 
    628             !                                        ! ======================= 
    629          ELSE                                        !   OTHER configurations  
    630             !                                        ! ======================= 
    631             zphi(1:jpj) = gphiv(1,:)             ! assume lat/lon coordinate, select the first i-line 
    632             ! 
    633          ENDIF 
    634          ! 
    635          ! Work only on westmost processor (will not work if mppini2 is used) 
     376      !  
     377   END FUNCTION ptr_sj_2d 
     378 
     379 
     380   FUNCTION ptr_sjk( pta, pmsk )   RESULT ( p_fval ) 
     381      !!---------------------------------------------------------------------- 
     382      !!                    ***  ROUTINE ptr_sjk  *** 
     383      !! 
     384      !! ** Purpose :   i-sum computation of an array 
     385      !! 
     386      !! ** Method  : - i-sum of pva using the interior 2D vmask (vmask_i). 
     387      !! 
     388      !! ** Action  : - p_fval: i-mean poleward flux of pva 
     389      !!---------------------------------------------------------------------- 
     390      !! 
     391      IMPLICIT none 
     392      REAL(wp) , INTENT(in), DIMENSION(jpi,jpj,jpk)           ::   pta    ! mask flux array at V-point 
     393      REAL(wp) , INTENT(in), DIMENSION(jpi,jpj)    , OPTIONAL ::   pmsk   ! Optional 2D basin mask 
     394      !! 
     395      INTEGER                           :: ji, jj, jk ! dummy loop arguments 
     396      REAL(wp), POINTER, DIMENSION(:,:) :: p_fval     ! return function value 
    636397#if defined key_mpp_mpi 
    637          IF( l_znl_root ) THEN  
     398      INTEGER, DIMENSION(1) ::   ish 
     399      INTEGER, DIMENSION(2) ::   ish2 
     400      INTEGER               ::   ijpjjpk 
     401      REAL(wp), DIMENSION(jpj*jpk) ::   zwork    ! mask flux array at V-point 
    638402#endif 
    639             ! 
    640             ! OPEN netcdf file  
    641             ! ---------------- 
    642             ! Define frequency of output and means 
    643             zsto = nn_fptr * zdt 
    644             IF( ln_mskland )   THEN    ! put 1.e+20 on land (very expensive!!) 
    645                clop      = "ave(only(x))" 
    646                clop_once = "once(only(x))" 
    647             ELSE                       ! no use of the mask value (require less cpu time) 
    648                clop      = "ave(x)"        
    649                clop_once = "once" 
    650             ENDIF 
    651  
    652             zout = nn_fwri * zdt 
    653             zfoo(1:jpj) = 0._wp 
    654  
    655             CALL ymds2ju( nyear, nmonth, nday, rdt, zjulian )  ! Compute julian date from starting date of the run 
    656             zjulian = zjulian - adatrj                         ! set calendar origin to the beginning of the experiment 
    657  
    658 #if defined key_iomput 
    659             ! Requested by IPSL people, use by their postpro... 
    660             IF(lwp) THEN 
    661                CALL dia_nam( clhstnam, nn_fwri,' ' ) 
    662                CALL ctl_opn( inum, 'date.file', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp, narea ) 
    663                WRITE(inum,*) clhstnam 
    664                CLOSE(inum) 
    665             ENDIF 
     403      !!-------------------------------------------------------------------- 
     404      ! 
     405      p_fval => p_fval2d 
     406 
     407      p_fval(:,:) = 0._wp 
     408      ! 
     409      IF( PRESENT( pmsk ) ) THEN  
     410         DO jk = 1, jpkm1 
     411            DO jj = 2, jpjm1 
     412!!gm here, use of tmask_i  ==> no need of loop over nldi, nlei.... 
     413               DO ji =  nldi, nlei   ! No vector optimisation here. Better use a mask ? 
     414                  p_fval(jj,jk) = p_fval(jj,jk) + pta(ji,jj,jk) * pmsk(ji,jj) 
     415               END DO 
     416            END DO 
     417         END DO 
     418      ELSE  
     419         DO jk = 1, jpkm1 
     420            DO jj = 2, jpjm1 
     421               DO ji =  nldi, nlei   ! No vector optimisation here. Better use a mask ? 
     422                  p_fval(jj,jk) = p_fval(jj,jk) + pta(ji,jj,jk) * tmask_i(ji,jj) 
     423               END DO 
     424            END DO 
     425         END DO 
     426      END IF 
     427      ! 
     428#if defined key_mpp_mpi 
     429      ijpjjpk = jpj*jpk 
     430      ish(1) = ijpjjpk  ;   ish2(1) = jpj   ;   ish2(2) = jpk 
     431      zwork(1:ijpjjpk) = RESHAPE( p_fval, ish ) 
     432      CALL mpp_sum( zwork, ijpjjpk, ncomm_znl ) 
     433      p_fval(:,:) = RESHAPE( zwork, ish2 ) 
    666434#endif 
    667  
    668             CALL dia_nam( clhstnam, nn_fwri, 'diaptr' ) 
    669             IF(lwp)WRITE( numout,*)" Name of diaptr NETCDF file : ", clhstnam 
    670  
    671             ! Horizontal grid : zphi() 
    672             CALL histbeg(clhstnam, 1, zfoo, jpj, zphi,   & 
    673                1, 1, 1, jpj, niter, zjulian, zdt*nn_fptr, nhoridz, numptr, domain_id=nidom_ptr) 
    674             ! Vertical grids : gdept_1d, gdepw_1d 
    675             CALL histvert( numptr, "deptht", "Vertical T levels",   & 
    676                &                   "m", jpk, gdept_1d, ndepidzt, "down" ) 
    677             CALL histvert( numptr, "depthw", "Vertical W levels",   & 
    678                &                   "m", jpk, gdepw_1d, ndepidzw, "down" ) 
    679             ! 
    680             CALL wheneq ( jpj*jpk, MIN(sjk(:,:,1), 1._wp), 1, 1., ndex  , ndim  )      ! Lat-Depth 
    681             CALL wheneq ( jpj    , MIN(sjk(:,1,1), 1._wp), 1, 1., ndex_h, ndim_h )     ! Lat 
    682  
    683             IF( ln_subbas ) THEN 
    684                z_1(:,1) = 1._wp 
    685                WHERE ( gphit(jpi/2,:) < -30._wp )   z_1(:,1) = 0._wp 
    686                DO jk = 2, jpk 
    687                   z_1(:,jk) = z_1(:,1) 
    688                END DO 
    689                !                       ! Atlantic (jn=2) 
    690                CALL wheneq ( jpj*jpk, MIN(sjk(:,:,2)         , 1._wp), 1, 1., ndex_atl     , ndim_atl      ) ! Lat-Depth 
    691                CALL wheneq ( jpj*jpk, MIN(sjk(:,:,2)*z_1(:,:), 1._wp), 1, 1., ndex_atl_30  , ndim_atl_30   ) ! Lat-Depth 
    692                CALL wheneq ( jpj    , MIN(sjk(:,1,2)*z_1(:,1), 1._wp), 1, 1., ndex_h_atl_30, ndim_h_atl_30 ) ! Lat 
    693                !                       ! Pacific (jn=3) 
    694                CALL wheneq ( jpj*jpk, MIN(sjk(:,:,3)         , 1._wp), 1, 1., ndex_pac     , ndim_pac      ) ! Lat-Depth 
    695                CALL wheneq ( jpj*jpk, MIN(sjk(:,:,3)*z_1(:,:), 1._wp), 1, 1., ndex_pac_30  , ndim_pac_30   ) ! Lat-Depth 
    696                CALL wheneq ( jpj    , MIN(sjk(:,1,3)*z_1(:,1), 1._wp), 1, 1., ndex_h_pac_30, ndim_h_pac_30 ) ! Lat 
    697                !                       ! Indian (jn=4) 
    698                CALL wheneq ( jpj*jpk, MIN(sjk(:,:,4)         , 1._wp), 1, 1., ndex_ind     , ndim_ind      ) ! Lat-Depth 
    699                CALL wheneq ( jpj*jpk, MIN(sjk(:,:,4)*z_1(:,:), 1._wp), 1, 1., ndex_ind_30  , ndim_ind_30   ) ! Lat-Depth 
    700                CALL wheneq ( jpj    , MIN(sjk(:,1,4)*z_1(:,1), 1._wp), 1, 1., ndex_h_ind_30, ndim_h_ind_30 ) ! Lat 
    701                !                       ! Indo-Pacific (jn=5) 
    702                CALL wheneq ( jpj*jpk, MIN(sjk(:,:,5)         , 1._wp), 1, 1., ndex_ipc     , ndim_ipc      ) ! Lat-Depth 
    703                CALL wheneq ( jpj*jpk, MIN(sjk(:,:,5)*z_1(:,:), 1._wp), 1, 1., ndex_ipc_30  , ndim_ipc_30   ) ! Lat-Depth 
    704                CALL wheneq ( jpj    , MIN(sjk(:,1,5)*z_1(:,1), 1._wp), 1, 1., ndex_h_ipc_30, ndim_h_ipc_30 ) ! Lat 
    705             ENDIF 
    706             !  
    707 #if defined key_diaeiv 
    708             cl_comment = ' (Bolus part included)' 
    709 #else 
    710             cl_comment = '                      ' 
    711 #endif 
    712             IF( ln_diaznl ) THEN             !  Zonal mean T and S 
    713                CALL histdef( numptr, "zotemglo", "Zonal Mean Temperature","C" ,   & 
    714                   1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop, zsto, zout ) 
    715                CALL histdef( numptr, "zosalglo", "Zonal Mean Salinity","PSU"  ,   & 
    716                   1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop, zsto, zout ) 
    717  
    718                CALL histdef( numptr, "zosrfglo", "Zonal Mean Surface","m^2"   ,   & 
    719                   1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop_once, zsto, zout ) 
    720                ! 
    721                IF (ln_subbas) THEN  
    722                   CALL histdef( numptr, "zotematl", "Zonal Mean Temperature: Atlantic","C" ,   & 
    723                      1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop, zsto, zout ) 
    724                   CALL histdef( numptr, "zosalatl", "Zonal Mean Salinity: Atlantic","PSU"  ,   & 
    725                      1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop, zsto, zout ) 
    726                   CALL histdef( numptr, "zosrfatl", "Zonal Mean Surface: Atlantic","m^2"   ,   & 
    727                      1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop_once, zsto, zout ) 
    728  
    729                   CALL histdef( numptr, "zotempac", "Zonal Mean Temperature: Pacific","C"  ,   & 
    730                      1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop, zsto, zout ) 
    731                   CALL histdef( numptr, "zosalpac", "Zonal Mean Salinity: Pacific","PSU"   ,   & 
    732                      1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop, zsto, zout ) 
    733                   CALL histdef( numptr, "zosrfpac", "Zonal Mean Surface: Pacific","m^2"    ,   & 
    734                      1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop_once, zsto, zout ) 
    735  
    736                   CALL histdef( numptr, "zotemind", "Zonal Mean Temperature: Indian","C"   ,   & 
    737                      1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop, zsto, zout ) 
    738                   CALL histdef( numptr, "zosalind", "Zonal Mean Salinity: Indian","PSU"    ,   & 
    739                      1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop, zsto, zout ) 
    740                   CALL histdef( numptr, "zosrfind", "Zonal Mean Surface: Indian","m^2"     ,   & 
    741                      1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop_once, zsto, zout ) 
    742  
    743                   CALL histdef( numptr, "zotemipc", "Zonal Mean Temperature: Pacific+Indian","C" ,   & 
    744                      1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop, zsto, zout ) 
    745                   CALL histdef( numptr, "zosalipc", "Zonal Mean Salinity: Pacific+Indian","PSU"  ,   & 
    746                      1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop, zsto, zout ) 
    747                   CALL histdef( numptr, "zosrfipc", "Zonal Mean Surface: Pacific+Indian","m^2"   ,   & 
    748                      1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop_once, zsto, zout ) 
    749                ENDIF 
    750             ENDIF 
    751             ! 
    752             !  Meridional Stream-Function (Eulerian and Bolus) 
    753             CALL histdef( numptr, "zomsfglo", "Meridional Stream-Function: Global"//TRIM(cl_comment),"Sv" ,   & 
    754                1, jpj, nhoridz, jpk, 1, jpk, ndepidzw, 32, clop, zsto, zout ) 
    755             IF( ln_subbas .AND. ln_diaznl ) THEN 
    756                CALL histdef( numptr, "zomsfatl", "Meridional Stream-Function: Atlantic"//TRIM(cl_comment),"Sv" ,   & 
    757                   1, jpj, nhoridz, jpk, 1, jpk, ndepidzw, 32, clop, zsto, zout ) 
    758                CALL histdef( numptr, "zomsfpac", "Meridional Stream-Function: Pacific"//TRIM(cl_comment),"Sv"  ,   & 
    759                   1, jpj, nhoridz, jpk, 1, jpk, ndepidzw, 32, clop, zsto, zout ) 
    760                CALL histdef( numptr, "zomsfind", "Meridional Stream-Function: Indian"//TRIM(cl_comment),"Sv"   ,   & 
    761                   1, jpj, nhoridz, jpk, 1, jpk, ndepidzw, 32, clop, zsto, zout ) 
    762                CALL histdef( numptr, "zomsfipc", "Meridional Stream-Function: Indo-Pacific"//TRIM(cl_comment),"Sv" ,& 
    763                   1, jpj, nhoridz, jpk, 1, jpk, ndepidzw, 32, clop, zsto, zout ) 
    764             ENDIF 
    765             ! 
    766             !  Heat transport  
    767             CALL histdef( numptr, "sophtadv", "Advective Heat Transport"      ,   & 
    768                "PW", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout ) 
    769             CALL histdef( numptr, "sophtldf", "Diffusive Heat Transport"      ,   & 
    770                "PW",1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout ) 
    771             IF ( ln_ptrcomp ) THEN  
    772                CALL histdef( numptr, "sophtove", "Overturning Heat Transport"    ,   & 
    773                   "PW",1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout ) 
    774             END IF 
    775             IF( ln_subbas ) THEN 
    776                CALL histdef( numptr, "sohtatl", "Heat Transport Atlantic"//TRIM(cl_comment),  & 
    777                   "PW", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout ) 
    778                CALL histdef( numptr, "sohtpac", "Heat Transport Pacific"//TRIM(cl_comment) ,  & 
    779                   "PW", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout ) 
    780                CALL histdef( numptr, "sohtind", "Heat Transport Indian"//TRIM(cl_comment)  ,  & 
    781                   "PW", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout ) 
    782                CALL histdef( numptr, "sohtipc", "Heat Transport Pacific+Indian"//TRIM(cl_comment), & 
    783                   "PW", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout ) 
    784             ENDIF 
    785             ! 
    786             !  Salt transport  
    787             CALL histdef( numptr, "sopstadv", "Advective Salt Transport"      ,   & 
    788                "Giga g/s", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout ) 
    789             CALL histdef( numptr, "sopstldf", "Diffusive Salt Transport"      ,   & 
    790                "Giga g/s", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout ) 
    791             IF ( ln_ptrcomp ) THEN  
    792                CALL histdef( numptr, "sopstove", "Overturning Salt Transport"    ,   & 
    793                   "Giga g/s", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout ) 
    794             END IF 
    795 #if defined key_diaeiv 
    796             ! Eddy induced velocity 
    797             CALL histdef( numptr, "zomsfeiv", "Bolus Meridional Stream-Function: global",   & 
    798                "Sv"      , 1, jpj, nhoridz, jpk, 1, jpk, ndepidzw, 32, clop, zsto, zout ) 
    799             CALL histdef( numptr, "sophteiv", "Bolus Advective Heat Transport",   & 
    800                "PW"      , 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout ) 
    801             CALL histdef( numptr, "sopsteiv", "Bolus Advective Salt Transport",   & 
    802                "Giga g/s", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout ) 
    803 #endif 
    804             IF( ln_subbas ) THEN 
    805                CALL histdef( numptr, "sostatl", "Salt Transport Atlantic"//TRIM(cl_comment)      ,  & 
    806                   "Giga g/s", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout ) 
    807                CALL histdef( numptr, "sostpac", "Salt Transport Pacific"//TRIM(cl_comment)      ,   & 
    808                   "Giga g/s", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout ) 
    809                CALL histdef( numptr, "sostind", "Salt Transport Indian"//TRIM(cl_comment)      ,    & 
    810                   "Giga g/s", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout ) 
    811                CALL histdef( numptr, "sostipc", "Salt Transport Pacific+Indian"//TRIM(cl_comment),  & 
    812                   "Giga g/s", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout ) 
    813             ENDIF 
    814             ! 
    815             CALL histend( numptr ) 
    816             ! 
    817          END IF 
    818 #if defined key_mpp_mpi 
    819       END IF 
    820 #endif 
    821  
    822 #if defined key_mpp_mpi 
    823       IF( MOD( itmod, nn_fptr ) == 0 .AND. l_znl_root ) THEN 
    824 #else 
    825       IF( MOD( itmod, nn_fptr ) == 0  ) THEN 
    826 #endif 
    827          niter = niter + 1 
    828  
    829          IF( ln_diaznl ) THEN  
    830             CALL histwrite( numptr, "zosrfglo", niter, sjk  (:,:,1) , ndim, ndex ) 
    831             CALL histwrite( numptr, "zotemglo", niter, tn_jk(:,:,1)  , ndim, ndex ) 
    832             CALL histwrite( numptr, "zosalglo", niter, sn_jk(:,:,1)  , ndim, ndex ) 
    833  
    834             IF (ln_subbas) THEN  
    835                CALL histwrite( numptr, "zosrfatl", niter, sjk(:,:,2), ndim_atl, ndex_atl ) 
    836                CALL histwrite( numptr, "zosrfpac", niter, sjk(:,:,3), ndim_pac, ndex_pac ) 
    837                CALL histwrite( numptr, "zosrfind", niter, sjk(:,:,4), ndim_ind, ndex_ind ) 
    838                CALL histwrite( numptr, "zosrfipc", niter, sjk(:,:,5), ndim_ipc, ndex_ipc ) 
    839  
    840                CALL histwrite( numptr, "zotematl", niter, tn_jk(:,:,2)  , ndim_atl, ndex_atl ) 
    841                CALL histwrite( numptr, "zosalatl", niter, sn_jk(:,:,2)  , ndim_atl, ndex_atl ) 
    842                CALL histwrite( numptr, "zotempac", niter, tn_jk(:,:,3)  , ndim_pac, ndex_pac ) 
    843                CALL histwrite( numptr, "zosalpac", niter, sn_jk(:,:,3)  , ndim_pac, ndex_pac ) 
    844                CALL histwrite( numptr, "zotemind", niter, tn_jk(:,:,4)  , ndim_ind, ndex_ind ) 
    845                CALL histwrite( numptr, "zosalind", niter, sn_jk(:,:,4)  , ndim_ind, ndex_ind ) 
    846                CALL histwrite( numptr, "zotemipc", niter, tn_jk(:,:,5)  , ndim_ipc, ndex_ipc ) 
    847                CALL histwrite( numptr, "zosalipc", niter, sn_jk(:,:,5)  , ndim_ipc, ndex_ipc ) 
    848             END IF 
    849          ENDIF 
    850  
    851          ! overturning outputs: 
    852          CALL histwrite( numptr, "zomsfglo", niter, v_msf(:,:,1), ndim, ndex ) 
    853          IF( ln_subbas .AND. ln_diaznl ) THEN 
    854             CALL histwrite( numptr, "zomsfatl", niter, v_msf(:,:,2) , ndim_atl_30, ndex_atl_30 ) 
    855             CALL histwrite( numptr, "zomsfpac", niter, v_msf(:,:,3) , ndim_pac_30, ndex_pac_30 ) 
    856             CALL histwrite( numptr, "zomsfind", niter, v_msf(:,:,4) , ndim_ind_30, ndex_ind_30 ) 
    857             CALL histwrite( numptr, "zomsfipc", niter, v_msf(:,:,5) , ndim_ipc_30, ndex_ipc_30 ) 
    858          ENDIF 
    859 #if defined key_diaeiv 
    860          CALL histwrite( numptr, "zomsfeiv", niter, v_msf_eiv(:,:,1), ndim  , ndex   ) 
    861 #endif 
    862  
    863          ! heat transport outputs: 
    864          IF( ln_subbas ) THEN 
    865             CALL histwrite( numptr, "sohtatl", niter, htr(:,2)  , ndim_h_atl_30, ndex_h_atl_30 ) 
    866             CALL histwrite( numptr, "sohtpac", niter, htr(:,3)  , ndim_h_pac_30, ndex_h_pac_30 ) 
    867             CALL histwrite( numptr, "sohtind", niter, htr(:,4)  , ndim_h_ind_30, ndex_h_ind_30 ) 
    868             CALL histwrite( numptr, "sohtipc", niter, htr(:,5)  , ndim_h_ipc_30, ndex_h_ipc_30 ) 
    869             CALL histwrite( numptr, "sostatl", niter, str(:,2)  , ndim_h_atl_30, ndex_h_atl_30 ) 
    870             CALL histwrite( numptr, "sostpac", niter, str(:,3)  , ndim_h_pac_30, ndex_h_pac_30 ) 
    871             CALL histwrite( numptr, "sostind", niter, str(:,4)  , ndim_h_ind_30, ndex_h_ind_30 ) 
    872             CALL histwrite( numptr, "sostipc", niter, str(:,5)  , ndim_h_ipc_30, ndex_h_ipc_30 ) 
    873          ENDIF 
    874  
    875          CALL histwrite( numptr, "sophtadv", niter, htr_adv     , ndim_h, ndex_h ) 
    876          CALL histwrite( numptr, "sophtldf", niter, htr_ldf     , ndim_h, ndex_h ) 
    877          CALL histwrite( numptr, "sopstadv", niter, str_adv     , ndim_h, ndex_h ) 
    878          CALL histwrite( numptr, "sopstldf", niter, str_ldf     , ndim_h, ndex_h ) 
    879          IF( ln_ptrcomp ) THEN  
    880             CALL histwrite( numptr, "sopstove", niter, str_ove(:) , ndim_h, ndex_h ) 
    881             CALL histwrite( numptr, "sophtove", niter, htr_ove(:) , ndim_h, ndex_h ) 
    882          ENDIF 
    883 #if defined key_diaeiv 
    884          CALL histwrite( numptr, "sophteiv", niter, htr_eiv(:,1)  , ndim_h, ndex_h ) 
    885          CALL histwrite( numptr, "sopsteiv", niter, str_eiv(:,1)  , ndim_h, ndex_h ) 
    886 #endif 
    887          ! 
    888       ENDIF 
    889       ! 
    890       CALL wrk_dealloc( jpj      , zphi , zfoo ) 
    891       CALL wrk_dealloc( jpj , jpk, z_1 ) 
    892       ! 
    893   END SUBROUTINE dia_ptr_wri 
     435      ! 
     436   END FUNCTION ptr_sjk 
     437 
    894438 
    895439   !!====================================================================== 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/DOM/dom_oce.F90

    r5312 r5313  
    162162   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::  gphit, gphiu   !: latitude  of t-, u-, v- and f-points (degre) 
    163163   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::  gphiv, gphif   !: 
    164    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, TARGET, DIMENSION(:,:) ::  e1t, e2t       !: horizontal scale factors at t-point (m) 
    165    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, TARGET, DIMENSION(:,:) ::  e1u, e2u       !: horizontal scale factors at u-point (m) 
    166    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, TARGET, DIMENSION(:,:) ::  e1v, e2v       !: horizontal scale factors at v-point (m) 
    167    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, TARGET, DIMENSION(:,:) ::  e1f, e2f       !: horizontal scale factors at f-point (m) 
     164   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, TARGET, DIMENSION(:,:) ::  e1t, e2t, r1_e1t, r1_e2t   !: horizontal scale factors and inverse at t-point (m) 
     165   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, TARGET, DIMENSION(:,:) ::  e1u, e2u, r1_e1u, r1_e2u   !: horizontal scale factors and inverse at u-point (m) 
     166   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, TARGET, DIMENSION(:,:) ::  e1v, e2v, r1_e1v, r1_e2v   !: horizontal scale factors and inverse at v-point (m) 
     167   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, TARGET, DIMENSION(:,:) ::  e1f, e2f, r1_e1f, r1_e2f   !: horizontal scale factors and inverse at f-point (m) 
    168168   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::  e1e2t          !: surface at t-point (m2) 
    169169   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::  ff             !: coriolis factor (2.*omega*sin(yphi) ) (s-1) 
    … …  
    262262 
    263263   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:), TARGET :: tmask, umask, vmask, fmask   !: land/ocean mask at T-, U-, V- and F-pts 
     264   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:), TARGET :: wmask, wumask, wvmask        !: land/ocean mask at WT-, WU- and WV-pts 
    264265 
    265266   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   tpol, fpol          !: north fold mask (jperio= 3 or 4) 
    … …  
    332333   INTEGER FUNCTION dom_oce_alloc() 
    333334      !!---------------------------------------------------------------------- 
    334       INTEGER, DIMENSION(11) :: ierr 
     335      INTEGER, DIMENSION(12) :: ierr 
    335336      !!---------------------------------------------------------------------- 
    336337      ierr(:) = 0 
    … …  
    345346         &      tpol(jpiglo)  , fpol(jpiglo)                               , STAT=ierr(2) ) 
    346347         ! 
    347       ALLOCATE( glamt(jpi,jpj) , gphit(jpi,jpj) , e1t(jpi,jpj) , e2t(jpi,jpj) ,                      &  
    348          &      glamu(jpi,jpj) , gphiu(jpi,jpj) , e1u(jpi,jpj) , e2u(jpi,jpj) ,                      &   
    349          &      glamv(jpi,jpj) , gphiv(jpi,jpj) , e1v(jpi,jpj) , e2v(jpi,jpj) , e1e2t(jpi,jpj) ,     &   
    350          &      glamf(jpi,jpj) , gphif(jpi,jpj) , e1f(jpi,jpj) , e2f(jpi,jpj) , ff   (jpi,jpj) , STAT=ierr(3) )      
     348      ALLOCATE( glamt(jpi,jpj) , gphit(jpi,jpj) , e1t(jpi,jpj) , e2t(jpi,jpj) , r1_e1t(jpi,jpj) , r1_e2t(jpi,jpj) ,   &  
     349         &      glamu(jpi,jpj) , gphiu(jpi,jpj) , e1u(jpi,jpj) , e2u(jpi,jpj) , r1_e1u(jpi,jpj) , r1_e2u(jpi,jpj) ,   &   
     350         &      glamv(jpi,jpj) , gphiv(jpi,jpj) , e1v(jpi,jpj) , e2v(jpi,jpj) , r1_e1v(jpi,jpj) , r1_e2v(jpi,jpj) ,   &   
     351         &      glamf(jpi,jpj) , gphif(jpi,jpj) , e1f(jpi,jpj) , e2f(jpi,jpj) , r1_e1f(jpi,jpj) , r1_e2f(jpi,jpj) ,   & 
     352         &      e1e2t(jpi,jpj) , ff   (jpi,jpj) , STAT=ierr(3) )      
    351353         ! 
    352354      ALLOCATE( gdep3w_0(jpi,jpj,jpk) , e3v_0(jpi,jpj,jpk) , e3f_0 (jpi,jpj,jpk) ,                         & 
    … …  
    400402         &      vmask(jpi,jpj,jpk) , fmask(jpi,jpj,jpk), STAT=ierr(11) ) 
    401403 
     404      ALLOCATE( wmask(jpi,jpj,jpk) , wumask(jpi,jpj,jpk), wvmask(jpi,jpj,jpk) , STAT=ierr(12) ) 
     405 
    402406#if defined key_noslip_accurate 
    403       ALLOCATE( npcoa(4,jpk), nicoa(2*(jpi+jpj),4,jpk), njcoa(2*(jpi+jpj),4,jpk), STAT=ierr(11) ) 
     407      ALLOCATE( npcoa(4,jpk), nicoa(2*(jpi+jpj),4,jpk), njcoa(2*(jpi+jpj),4,jpk), STAT=ierr(12) ) 
    404408#endif 
    405409      ! 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/DOM/domhgr.F90

    r5312 r5313  
    471471      re2u_e1u(:,:) = e2u(:,:) / e1u(:,:) 
    472472      re1v_e2v(:,:) = e1v(:,:) / e2v(:,:) 
     473      r1_e1t  (:,:) = 1._wp    / e1t(:,:) 
     474      r1_e1u  (:,:) = 1._wp    / e1u(:,:) 
     475      r1_e1v  (:,:) = 1._wp    / e1v(:,:) 
     476      r1_e1f  (:,:) = 1._wp    / e1f(:,:) 
     477      r1_e2t  (:,:) = 1._wp    / e2t(:,:) 
     478      r1_e2u  (:,:) = 1._wp    / e2u(:,:) 
     479      r1_e2v  (:,:) = 1._wp    / e2v(:,:) 
     480      r1_e2f  (:,:) = 1._wp    / e2f(:,:) 
    473481 
    474482      ! Control printing : Grid informations (if not restart) 
    … …  
    616624      CALL iom_open( 'coordinates', inum ) 
    617625       
    618       CALL iom_get( inum, jpdom_data, 'glamt', glamt ) 
    619       CALL iom_get( inum, jpdom_data, 'glamu', glamu ) 
    620       CALL iom_get( inum, jpdom_data, 'glamv', glamv ) 
    621       CALL iom_get( inum, jpdom_data, 'glamf', glamf ) 
    622        
    623       CALL iom_get( inum, jpdom_data, 'gphit', gphit ) 
    624       CALL iom_get( inum, jpdom_data, 'gphiu', gphiu ) 
    625       CALL iom_get( inum, jpdom_data, 'gphiv', gphiv ) 
    626       CALL iom_get( inum, jpdom_data, 'gphif', gphif ) 
    627        
    628       CALL iom_get( inum, jpdom_data, 'e1t', e1t ) 
    629       CALL iom_get( inum, jpdom_data, 'e1u', e1u ) 
    630       CALL iom_get( inum, jpdom_data, 'e1v', e1v ) 
    631       CALL iom_get( inum, jpdom_data, 'e1f', e1f ) 
    632        
    633       CALL iom_get( inum, jpdom_data, 'e2t', e2t ) 
    634       CALL iom_get( inum, jpdom_data, 'e2u', e2u ) 
    635       CALL iom_get( inum, jpdom_data, 'e2v', e2v ) 
    636       CALL iom_get( inum, jpdom_data, 'e2f', e2f ) 
     626      CALL iom_get( inum, jpdom_data, 'glamt', glamt, lrowattr=ln_use_jattr ) 
     627      CALL iom_get( inum, jpdom_data, 'glamu', glamu, lrowattr=ln_use_jattr ) 
     628      CALL iom_get( inum, jpdom_data, 'glamv', glamv, lrowattr=ln_use_jattr ) 
     629      CALL iom_get( inum, jpdom_data, 'glamf', glamf, lrowattr=ln_use_jattr ) 
     630       
     631      CALL iom_get( inum, jpdom_data, 'gphit', gphit, lrowattr=ln_use_jattr ) 
     632      CALL iom_get( inum, jpdom_data, 'gphiu', gphiu, lrowattr=ln_use_jattr ) 
     633      CALL iom_get( inum, jpdom_data, 'gphiv', gphiv, lrowattr=ln_use_jattr ) 
     634      CALL iom_get( inum, jpdom_data, 'gphif', gphif, lrowattr=ln_use_jattr ) 
     635       
     636      CALL iom_get( inum, jpdom_data, 'e1t', e1t, lrowattr=ln_use_jattr ) 
     637      CALL iom_get( inum, jpdom_data, 'e1u', e1u, lrowattr=ln_use_jattr ) 
     638      CALL iom_get( inum, jpdom_data, 'e1v', e1v, lrowattr=ln_use_jattr ) 
     639      CALL iom_get( inum, jpdom_data, 'e1f', e1f, lrowattr=ln_use_jattr ) 
     640       
     641      CALL iom_get( inum, jpdom_data, 'e2t', e2t, lrowattr=ln_use_jattr ) 
     642      CALL iom_get( inum, jpdom_data, 'e2u', e2u, lrowattr=ln_use_jattr ) 
     643      CALL iom_get( inum, jpdom_data, 'e2v', e2v, lrowattr=ln_use_jattr ) 
     644      CALL iom_get( inum, jpdom_data, 'e2f', e2f, lrowattr=ln_use_jattr ) 
    637645       
    638646      CALL iom_close( inum ) 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/DOM/dommsk.F90

    r5312 r5313  
    281281      CALL lbc_lnk( fmask_i, 'F', 1._wp ) 
    282282 
     283      ! 3. Ocean/land mask at wu-, wv- and w points  
     284      !---------------------------------------------- 
     285      wmask (:,:,1) = tmask(:,:,1) ! ???????? 
     286      wumask(:,:,1) = umask(:,:,1) ! ???????? 
     287      wvmask(:,:,1) = vmask(:,:,1) ! ???????? 
     288      DO jk=2,jpk 
     289         wmask (:,:,jk)=tmask(:,:,jk) * tmask(:,:,jk-1) 
     290         wumask(:,:,jk)=umask(:,:,jk) * umask(:,:,jk-1)    
     291         wvmask(:,:,jk)=vmask(:,:,jk) * vmask(:,:,jk-1) 
     292      END DO 
    283293 
    284294      ! 4. ocean/land mask for the elliptic equation 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/DOM/domvvl.F90

    r5312 r5313  
    88   !!            3.3  !  2011-10  (M. Leclair) totally rewrote domvvl: 
    99   !!                                          vvl option includes z_star and z_tilde coordinates 
     10   !!            3.6  !  2014-11  (P. Mathiot) add ice shelf capability 
    1011   !!---------------------------------------------------------------------- 
    1112   !!   'key_vvl'                              variable volume 
    … …  
    125126      INTEGER ::   ji,jj,jk 
    126127      INTEGER ::   ii0, ii1, ij0, ij1 
     128      REAL(wp)::   zcoef 
    127129      !!---------------------------------------------------------------------- 
    128130      IF( nn_timing == 1 )  CALL timing_start('dom_vvl_init') 
    … …  
    164166      ! t- and w- points depth 
    165167      ! ---------------------- 
     168      ! set the isf depth as it is in the initial step 
    166169      fsdept_n(:,:,1) = 0.5_wp * fse3w_n(:,:,1) 
    167170      fsdepw_n(:,:,1) = 0.0_wp 
    … …  
    169172      fsdept_b(:,:,1) = 0.5_wp * fse3w_b(:,:,1) 
    170173      fsdepw_b(:,:,1) = 0.0_wp 
    171       DO jj = 1,jpj 
    172          DO ji = 1,jpi 
    173             DO jk = 2,mikt(ji,jj)-1 
    174                fsdept_n(ji,jj,jk) = gdept_0(ji,jj,jk) 
    175                fsdepw_n(ji,jj,jk) = gdepw_0(ji,jj,jk) 
    176                fsde3w_n(ji,jj,jk) = gdept_0(ji,jj,jk) - sshn(ji,jj) 
    177                fsdept_b(ji,jj,jk) = gdept_0(ji,jj,jk) 
    178                fsdepw_b(ji,jj,jk) = gdepw_0(ji,jj,jk) 
    179             END DO 
    180             IF (mikt(ji,jj) .GT. 1) THEN 
    181                jk = mikt(ji,jj) 
    182                fsdept_n(ji,jj,jk) = gdepw_0(ji,jj,jk) + 0.5_wp * fse3w_n(ji,jj,jk) 
    183                fsdepw_n(ji,jj,jk) = gdepw_0(ji,jj,jk) 
    184                fsde3w_n(ji,jj,jk) = fsdept_n(ji,jj,jk  ) - sshn   (ji,jj) 
    185                fsdept_b(ji,jj,jk) = gdepw_0(ji,jj,jk) + 0.5_wp * fse3w_b(ji,jj,jk) 
    186                fsdepw_b(ji,jj,jk) = gdepw_0(ji,jj,jk) 
    187             END IF 
    188             DO jk = mikt(ji,jj)+1, jpk 
    189                fsdept_n(ji,jj,jk) = fsdept_n(ji,jj,jk-1) + fse3w_n(ji,jj,jk) 
     174 
     175      DO jk = 2, jpk 
     176         DO jj = 1,jpj 
     177            DO ji = 1,jpi 
     178              !    zcoef = (tmask(ji,jj,jk) - wmask(ji,jj,jk))   ! 0 everywhere tmask = wmask, ie everywhere expect at jk = mikt 
     179                                                     ! 1 everywhere from mbkt to mikt + 1 or 1 (if no isf) 
     180                                                     ! 0.5 where jk = mikt   
     181               zcoef = (tmask(ji,jj,jk) - wmask(ji,jj,jk)) 
    190182               fsdepw_n(ji,jj,jk) = fsdepw_n(ji,jj,jk-1) + fse3t_n(ji,jj,jk-1) 
    191                fsde3w_n(ji,jj,jk) = fsdept_n(ji,jj,jk  ) - sshn   (ji,jj) 
    192                fsdept_b(ji,jj,jk) = fsdept_b(ji,jj,jk-1) + fse3w_b(ji,jj,jk) 
     183               fsdept_n(ji,jj,jk) =      zcoef  * ( fsdepw_n(ji,jj,jk  ) + 0.5 * fse3w_n(ji,jj,jk))  & 
     184                   &                + (1-zcoef) * ( fsdept_n(ji,jj,jk-1) +       fse3w_n(ji,jj,jk))  
     185               fsde3w_n(ji,jj,jk) = fsdept_n(ji,jj,jk) - sshn(ji,jj) 
    193186               fsdepw_b(ji,jj,jk) = fsdepw_b(ji,jj,jk-1) + fse3t_b(ji,jj,jk-1) 
     187               fsdept_b(ji,jj,jk) =      zcoef  * ( fsdepw_b(ji,jj,jk  ) + 0.5 * fse3w_b(ji,jj,jk))  & 
     188                   &                + (1-zcoef) * ( fsdept_b(ji,jj,jk-1) +       fse3w_b(ji,jj,jk))  
    194189            END DO 
    195190         END DO 
    … …  
    589584      !! * Local declarations 
    590585      INTEGER                             :: ji,jj,jk       ! dummy loop indices 
     586      REAL(wp)                            :: zcoef 
    591587      !!---------------------------------------------------------------------- 
    592588 
    … …  
    635631      ! t- and w- points depth 
    636632      ! ---------------------- 
     633      ! set the isf depth as it is in the initial step 
    637634      fsdept_n(:,:,1) = 0.5_wp * fse3w_n(:,:,1) 
    638635      fsdepw_n(:,:,1) = 0.0_wp 
    639636      fsde3w_n(:,:,1) = fsdept_n(:,:,1) - sshn(:,:) 
    640       DO jj = 1,jpj 
    641          DO ji = 1,jpi 
    642             DO jk = 2,mikt(ji,jj)-1 
    643                fsdept_n(ji,jj,jk) = gdept_0(ji,jj,jk) 
    644                fsdepw_n(ji,jj,jk) = gdepw_0(ji,jj,jk) 
    645                fsde3w_n(ji,jj,jk) = gdept_0(ji,jj,jk) - sshn(ji,jj) 
    646             END DO 
    647             IF (mikt(ji,jj) .GT. 1) THEN 
    648                jk = mikt(ji,jj) 
    649                fsdept_n(ji,jj,jk) = gdepw_0(ji,jj,jk) + 0.5_wp * fse3w_n(ji,jj,jk) 
    650                fsdepw_n(ji,jj,jk) = gdepw_0(ji,jj,jk) 
    651                fsde3w_n(ji,jj,jk) = fsdept_n(ji,jj,jk  ) - sshn   (ji,jj) 
    652             END IF 
    653             DO jk = mikt(ji,jj)+1, jpk 
    654                fsdept_n(ji,jj,jk) = fsdept_n(ji,jj,jk-1) + fse3w_n(ji,jj,jk) 
     637 
     638      DO jk = 2, jpk 
     639         DO jj = 1,jpj 
     640            DO ji = 1,jpi 
     641              !    zcoef = (tmask(ji,jj,jk) - wmask(ji,jj,jk))   ! 0 everywhere tmask = wmask, ie everywhere expect at jk = mikt 
     642                                                                 ! 1 for jk = mikt 
     643               zcoef = (tmask(ji,jj,jk) - wmask(ji,jj,jk)) 
    655644               fsdepw_n(ji,jj,jk) = fsdepw_n(ji,jj,jk-1) + fse3t_n(ji,jj,jk-1) 
    656                fsde3w_n(ji,jj,jk) = fsdept_n(ji,jj,jk  ) - sshn   (ji,jj) 
     645               fsdept_n(ji,jj,jk) =      zcoef  * ( fsdepw_n(ji,jj,jk  ) + 0.5 * fse3w_n(ji,jj,jk))  & 
     646                   &                + (1-zcoef) * ( fsdept_n(ji,jj,jk-1) +       fse3w_n(ji,jj,jk))  
     647               fsde3w_n(ji,jj,jk) = fsdept_n(ji,jj,jk) - sshn(ji,jj) 
    657648            END DO 
    658649         END DO 
    659650      END DO 
     651 
    660652      ! Local depth and Inverse of the local depth of the water column at u- and v- points 
    661653      ! ---------------------------------------------------------------------------------- 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/DOM/domzgr.F90

    r5312 r5313  
    1717   !!            3.4  ! 2012-08  (J. Siddorn) added Siddorn and Furner stretching function 
    1818   !!            3.4  ! 2012-12  (R. Bourdalle-Badie and G. Reffray)  modify C1D case   
     19   !!            3.6  ! 2014-11  (P. Mathiot and C. Harris) add ice shelf capabilitye   
    1920   !!---------------------------------------------------------------------- 
    2021 
    … …  
    3536   USE oce               ! ocean variables 
    3637   USE dom_oce           ! ocean domain 
    37    USE sbc_oce           ! surface variable (isf) 
    3838   USE closea            ! closed seas 
    3939   USE c1d               ! 1D vertical configuration 
    … …  
    298298      ENDIF 
    299299 
     300      IF ( ln_isfcav ) THEN 
    300301! need to be like this to compute the pressure gradient with ISF. If not, level beneath the ISF are not aligned (sum(e3t) /= depth) 
    301302! define e3t_0 and e3w_0 as the differences between gdept and gdepw respectively 
    302       DO jk = 1, jpkm1 
    303          e3t_1d(jk) = gdepw_1d(jk+1)-gdepw_1d(jk)  
    304       END DO 
    305       e3t_1d(jpk) = e3t_1d(jpk-1)   ! we don't care because this level is masked in NEMO 
    306  
    307       DO jk = 2, jpk 
    308          e3w_1d(jk) = gdept_1d(jk) - gdept_1d(jk-1)  
    309       END DO 
    310       e3w_1d(1  ) = 2._wp * (gdept_1d(1) - gdepw_1d(1))  
     303         DO jk = 1, jpkm1 
     304            e3t_1d(jk) = gdepw_1d(jk+1)-gdepw_1d(jk)  
     305         END DO 
     306         e3t_1d(jpk) = e3t_1d(jpk-1)   ! we don't care because this level is masked in NEMO 
     307 
     308         DO jk = 2, jpk 
     309            e3w_1d(jk) = gdept_1d(jk) - gdept_1d(jk-1)  
     310         END DO 
     311         e3w_1d(1  ) = 2._wp * (gdept_1d(1) - gdepw_1d(1))  
     312      END IF 
    311313 
    312314!!gm BUG in s-coordinate this does not work! 
    … …  
    472474         ! 
    473475         ! (ISF) TODO build ice draft netcdf file for isomip and build the corresponding part of code 
    474          IF( cp_cfg == "isomip" ) THEN  
    475            !  
    476            risfdep(:,:)=200.e0  
    477            misfdep(:,:)=1  
    478            ij0 = 1 ; ij1 = 40  
    479            DO jj = mj0(ij0), mj1(ij1)  
    480               risfdep(:,jj)=700.0_wp-(gphit(:,jj)+80.0_wp)*125.0_wp  
    481                 END DO  
     476         IF( cp_cfg == "isomip" .AND. ln_isfcav ) THEN  
     477            risfdep(:,:)=200.e0  
     478            misfdep(:,:)=1  
     479            ij0 = 1 ; ij1 = 40  
     480            DO jj = mj0(ij0), mj1(ij1)  
     481               risfdep(:,jj)=700.0_wp-(gphit(:,jj)+80.0_wp)*125.0_wp  
     482            END DO  
    482483            WHERE( bathy(:,:) <= 0._wp )  risfdep(:,:) = 0._wp  
    483            !  
    484          ELSEIF ( cp_cfg == "isomip2" ) THEN 
     484         !  
     485         ELSEIF ( cp_cfg == "isomip2" .AND. ln_isfcav ) THEN 
    485486         !  
    486487            risfdep(:,:)=0.e0 
    … …  
    534535         IF( ln_zps .OR. ln_sco )   THEN              ! zps or sco : read meter bathymetry 
    535536            CALL iom_open ( 'bathy_meter.nc', inum )  
    536             CALL iom_get  ( inum, jpdom_data, 'Bathymetry', bathy ) 
     537            IF ( ln_isfcav ) THEN 
     538               CALL iom_get  ( inum, jpdom_data, 'Bathymetry_isf', bathy, lrowattr=.false. ) 
     539            ELSE 
     540               CALL iom_get  ( inum, jpdom_data, 'Bathymetry'    , bathy, lrowattr=ln_use_jattr  ) 
     541            END IF 
    537542            CALL iom_close( inum ) 
    538             !   
     543            !                                                 
    539544            risfdep(:,:)=0._wp          
    540545            misfdep(:,:)=1              
    … …  
    584589      IF ( .not. ln_sco ) THEN                                !==  set a minimum depth  ==! 
    585590         ! patch to avoid case bathy = ice shelf draft and bathy between 0 and zhmin 
    586          WHERE (bathy == risfdep) 
    587             bathy   = 0.0_wp ; risfdep = 0.0_wp 
    588          END WHERE 
     591         IF ( ln_isfcav ) THEN 
     592            WHERE (bathy == risfdep) 
     593               bathy   = 0.0_wp ; risfdep = 0.0_wp 
     594            END WHERE 
     595         END IF 
    589596         ! end patch 
    590597         IF( rn_hmin < 0._wp ) THEN    ;   ik = - INT( rn_hmin )                                      ! from a nb of level 
    … …  
    961968      !!---------------------------------------------------------------------- 
    962969      !! 
     970      INTEGER  ::   ji, jj, jk       ! dummy loop indices 
     971      INTEGER  ::   ik, it           ! temporary integers 
     972      LOGICAL  ::   ll_print         ! Allow  control print for debugging 
     973      REAL(wp) ::   ze3tp , ze3wp    ! Last ocean level thickness at T- and W-points 
     974      REAL(wp) ::   zdepwp, zdepth   ! Ajusted ocean depth to avoid too small e3t 
     975      REAL(wp) ::   zmax             ! Maximum depth 
     976      REAL(wp) ::   zdiff            ! temporary scalar 
     977      REAL(wp) ::   zrefdep          ! temporary scalar 
     978      REAL(wp), POINTER, DIMENSION(:,:,:) ::  zprt 
     979      !!--------------------------------------------------------------------- 
     980      ! 
     981      IF( nn_timing == 1 )  CALL timing_start('zgr_zps') 
     982      ! 
     983      CALL wrk_alloc( jpi, jpj, jpk, zprt ) 
     984      ! 
     985      IF(lwp) WRITE(numout,*) 
     986      IF(lwp) WRITE(numout,*) '    zgr_zps : z-coordinate with partial steps' 
     987      IF(lwp) WRITE(numout,*) '    ~~~~~~~ ' 
     988      IF(lwp) WRITE(numout,*) '              mbathy is recomputed : bathy_level file is NOT used' 
     989 
     990      ll_print = .FALSE.                   ! Local variable for debugging 
     991       
     992      IF(lwp .AND. ll_print) THEN          ! control print of the ocean depth 
     993         WRITE(numout,*) 
     994         WRITE(numout,*) 'dom_zgr_zps:  bathy (in hundred of meters)' 
     995         CALL prihre( bathy, jpi, jpj, 1,jpi, 1, 1, jpj, 1, 1.e-2, numout ) 
     996      ENDIF 
     997 
     998 
     999      ! bathymetry in level (from bathy_meter) 
     1000      ! =================== 
     1001      zmax = gdepw_1d(jpk) + e3t_1d(jpk)        ! maximum depth (i.e. the last ocean level thickness <= 2*e3t_1d(jpkm1) ) 
     1002      bathy(:,:) = MIN( zmax ,  bathy(:,:) )    ! bounded value of bathy (min already set at the end of zgr_bat) 
     1003      WHERE( bathy(:,:) == 0._wp )   ;   mbathy(:,:) = 0       ! land  : set mbathy to 0 
     1004      ELSE WHERE                     ;   mbathy(:,:) = jpkm1   ! ocean : initialize mbathy to the max ocean level 
     1005      END WHERE 
     1006 
     1007      ! Compute mbathy for ocean points (i.e. the number of ocean levels) 
     1008      ! find the number of ocean levels such that the last level thickness 
     1009      ! is larger than the minimum of e3zps_min and e3zps_rat * e3t_1d (where 
     1010      ! e3t_1d is the reference level thickness 
     1011      DO jk = jpkm1, 1, -1 
     1012         zdepth = gdepw_1d(jk) + MIN( e3zps_min, e3t_1d(jk)*e3zps_rat ) 
     1013         WHERE( 0._wp < bathy(:,:) .AND. bathy(:,:) <= zdepth )   mbathy(:,:) = jk-1 
     1014      END DO 
     1015 
     1016      IF ( ln_isfcav ) CALL zgr_isf 
     1017 
     1018      ! Scale factors and depth at T- and W-points 
     1019      DO jk = 1, jpk                        ! intitialization to the reference z-coordinate 
     1020         gdept_0(:,:,jk) = gdept_1d(jk) 
     1021         gdepw_0(:,:,jk) = gdepw_1d(jk) 
     1022         e3t_0  (:,:,jk) = e3t_1d  (jk) 
     1023         e3w_0  (:,:,jk) = e3w_1d  (jk) 
     1024      END DO 
     1025      !  
     1026      DO jj = 1, jpj 
     1027         DO ji = 1, jpi 
     1028            ik = mbathy(ji,jj) 
     1029            IF( ik > 0 ) THEN               ! ocean point only 
     1030               ! max ocean level case 
     1031               IF( ik == jpkm1 ) THEN 
     1032                  zdepwp = bathy(ji,jj) 
     1033                  ze3tp  = bathy(ji,jj) - gdepw_1d(ik) 
     1034                  ze3wp = 0.5_wp * e3w_1d(ik) * ( 1._wp + ( ze3tp/e3t_1d(ik) ) ) 
     1035                  e3t_0(ji,jj,ik  ) = ze3tp 
     1036                  e3t_0(ji,jj,ik+1) = ze3tp 
     1037                  e3w_0(ji,jj,ik  ) = ze3wp 
     1038                  e3w_0(ji,jj,ik+1) = ze3tp 
     1039                  gdepw_0(ji,jj,ik+1) = zdepwp 
     1040                  gdept_0(ji,jj,ik  ) = gdept_1d(ik-1) + ze3wp 
     1041                  gdept_0(ji,jj,ik+1) = gdept_0(ji,jj,ik) + ze3tp 
     1042                  ! 
     1043               ELSE                         ! standard case 
     1044                  IF( bathy(ji,jj) <= gdepw_1d(ik+1) ) THEN  ;   gdepw_0(ji,jj,ik+1) = bathy(ji,jj) 
     1045                  ELSE                                       ;   gdepw_0(ji,jj,ik+1) = gdepw_1d(ik+1) 
     1046                  ENDIF 
     1047!gm Bug?  check the gdepw_1d 
     1048                  !       ... on ik 
     1049                  gdept_0(ji,jj,ik) = gdepw_1d(ik) + ( gdepw_0(ji,jj,ik+1) - gdepw_1d(ik) )   & 
     1050                     &                             * ((gdept_1d(     ik  ) - gdepw_1d(ik) )   & 
     1051                     &                             / ( gdepw_1d(     ik+1) - gdepw_1d(ik) )) 
     1052                  e3t_0  (ji,jj,ik) = e3t_1d  (ik) * ( gdepw_0 (ji,jj,ik+1) - gdepw_1d(ik) )   &  
     1053                     &                             / ( gdepw_1d(      ik+1) - gdepw_1d(ik) )  
     1054                  e3w_0(ji,jj,ik) = 0.5_wp * ( gdepw_0(ji,jj,ik+1) + gdepw_1d(ik+1) - 2._wp * gdepw_1d(ik) )   & 
     1055                     &                     * ( e3w_1d(ik) / ( gdepw_1d(ik+1) - gdepw_1d(ik) ) ) 
     1056                  !       ... on ik+1 
     1057                  e3w_0  (ji,jj,ik+1) = e3t_0  (ji,jj,ik) 
     1058                  e3t_0  (ji,jj,ik+1) = e3t_0  (ji,jj,ik) 
     1059                  gdept_0(ji,jj,ik+1) = gdept_0(ji,jj,ik) + e3t_0(ji,jj,ik) 
     1060               ENDIF 
     1061            ENDIF 
     1062         END DO 
     1063      END DO 
     1064      ! 
     1065      it = 0 
     1066      DO jj = 1, jpj 
     1067         DO ji = 1, jpi 
     1068            ik = mbathy(ji,jj) 
     1069            IF( ik > 0 ) THEN               ! ocean point only 
     1070               e3tp (ji,jj) = e3t_0(ji,jj,ik) 
     1071               e3wp (ji,jj) = e3w_0(ji,jj,ik) 
     1072               ! test 
     1073               zdiff= gdepw_0(ji,jj,ik+1) - gdept_0(ji,jj,ik  ) 
     1074               IF( zdiff <= 0._wp .AND. lwp ) THEN  
     1075                  it = it + 1 
     1076                  WRITE(numout,*) ' it      = ', it, ' ik      = ', ik, ' (i,j) = ', ji, jj 
     1077                  WRITE(numout,*) ' bathy = ', bathy(ji,jj) 
     1078                  WRITE(numout,*) ' gdept_0 = ', gdept_0(ji,jj,ik), ' gdepw_0 = ', gdepw_0(ji,jj,ik+1), ' zdiff = ', zdiff 
     1079                  WRITE(numout,*) ' e3tp    = ', e3t_0  (ji,jj,ik), ' e3wp    = ', e3w_0  (ji,jj,ik  ) 
     1080               ENDIF 
     1081            ENDIF 
     1082         END DO 
     1083      END DO 
     1084      ! 
     1085      IF ( ln_isfcav ) THEN 
     1086      ! (ISF) Definition of e3t, u, v, w for ISF case 
     1087         DO jj = 1, jpj  
     1088            DO ji = 1, jpi  
     1089               ik = misfdep(ji,jj)  
     1090               IF( ik > 1 ) THEN               ! ice shelf point only  
     1091                  IF( risfdep(ji,jj) < gdepw_1d(ik) )  risfdep(ji,jj)= gdepw_1d(ik)  
     1092                  gdepw_0(ji,jj,ik) = risfdep(ji,jj)  
     1093!gm Bug?  check the gdepw_0  
     1094               !       ... on ik  
     1095                  gdept_0(ji,jj,ik) = gdepw_1d(ik+1) - ( gdepw_1d(ik+1) - gdepw_0(ji,jj,ik) )   &  
     1096                     &                               * ( gdepw_1d(ik+1) - gdept_1d(ik)      )   &  
     1097                     &                               / ( gdepw_1d(ik+1) - gdepw_1d(ik)      )  
     1098                  e3t_0  (ji,jj,ik  ) = gdepw_1d(ik+1) - gdepw_0(ji,jj,ik)  
     1099                  e3w_0  (ji,jj,ik+1) = gdept_1d(ik+1) - gdept_0(ji,jj,ik) 
     1100 
     1101                  IF( ik + 1 == mbathy(ji,jj) ) THEN               ! ice shelf point only (2 cell water column)  
     1102                     e3w_0  (ji,jj,ik+1) = gdept_0(ji,jj,ik+1) - gdept_0(ji,jj,ik)  
     1103                  ENDIF  
     1104               !       ... on ik / ik-1  
     1105                  e3w_0  (ji,jj,ik  ) = 2._wp * (gdept_0(ji,jj,ik) - gdepw_0(ji,jj,ik))  
     1106                  e3t_0  (ji,jj,ik-1) = gdepw_0(ji,jj,ik) - gdepw_1d(ik-1) 
     1107! The next line isn't required and doesn't affect results - included for consistency with bathymetry code  
     1108                  gdept_0(ji,jj,ik-1) = gdept_1d(ik-1) 
     1109               ENDIF  
     1110            END DO  
     1111         END DO  
     1112      !  
     1113         it = 0  
     1114         DO jj = 1, jpj  
     1115            DO ji = 1, jpi  
     1116               ik = misfdep(ji,jj)  
     1117               IF( ik > 1 ) THEN               ! ice shelf point only  
     1118                  e3tp (ji,jj) = e3t_0(ji,jj,ik  )  
     1119                  e3wp (ji,jj) = e3w_0(ji,jj,ik+1 )  
     1120               ! test  
     1121                  zdiff= gdept_0(ji,jj,ik) - gdepw_0(ji,jj,ik  )  
     1122                  IF( zdiff <= 0. .AND. lwp ) THEN   
     1123                     it = it + 1  
     1124                     WRITE(numout,*) ' it      = ', it, ' ik      = ', ik, ' (i,j) = ', ji, jj  
     1125                     WRITE(numout,*) ' risfdep = ', risfdep(ji,jj)  
     1126                     WRITE(numout,*) ' gdept = ', gdept_0(ji,jj,ik), ' gdepw = ', gdepw_0(ji,jj,ik+1), ' zdiff = ', zdiff  
     1127                     WRITE(numout,*) ' e3tp  = ', e3tp(ji,jj), ' e3wp  = ', e3wp(ji,jj)  
     1128                  ENDIF  
     1129               ENDIF  
     1130            END DO  
     1131         END DO  
     1132      END IF 
     1133      ! END (ISF) 
     1134 
     1135      ! Scale factors and depth at U-, V-, UW and VW-points 
     1136      DO jk = 1, jpk                        ! initialisation to z-scale factors 
     1137         e3u_0 (:,:,jk) = e3t_1d(jk) 
     1138         e3v_0 (:,:,jk) = e3t_1d(jk) 
     1139         e3uw_0(:,:,jk) = e3w_1d(jk) 
     1140         e3vw_0(:,:,jk) = e3w_1d(jk) 
     1141      END DO 
     1142      DO jk = 1,jpk                         ! Computed as the minimum of neighbooring scale factors 
     1143         DO jj = 1, jpjm1 
     1144            DO ji = 1, fs_jpim1   ! vector opt. 
     1145               e3u_0 (ji,jj,jk) = MIN( e3t_0(ji,jj,jk), e3t_0(ji+1,jj,jk) ) 
     1146               e3v_0 (ji,jj,jk) = MIN( e3t_0(ji,jj,jk), e3t_0(ji,jj+1,jk) ) 
     1147               e3uw_0(ji,jj,jk) = MIN( e3w_0(ji,jj,jk), e3w_0(ji+1,jj,jk) ) 
     1148               e3vw_0(ji,jj,jk) = MIN( e3w_0(ji,jj,jk), e3w_0(ji,jj+1,jk) ) 
     1149            END DO 
     1150         END DO 
     1151      END DO 
     1152      IF ( ln_isfcav ) THEN 
     1153      ! (ISF) define e3uw (adapted for 2 cells in the water column) 
     1154      ! Need to test if the modification of only mikt and mbkt levels is enough 
     1155         DO jk = 2,jpk                           
     1156            DO jj = 1, jpjm1  
     1157               DO ji = 1, fs_jpim1   ! vector opt.  
     1158                  e3uw_0(ji,jj,jk) = MIN( gdept_0(ji,jj,jk), gdept_0(ji+1,jj  ,jk) ) & 
     1159                    &   - MAX( gdept_0(ji,jj,jk-1), gdept_0(ji+1,jj  ,jk-1) ) 
     1160                  e3vw_0(ji,jj,jk) = MIN( gdept_0(ji,jj,jk), gdept_0(ji  ,jj+1,jk) ) & 
     1161                    &   - MAX( gdept_0(ji,jj,jk-1), gdept_0(ji  ,jj+1,jk-1) ) 
     1162               END DO  
     1163            END DO  
     1164         END DO 
     1165      END IF 
     1166       
     1167      CALL lbc_lnk( e3u_0 , 'U', 1._wp )   ;   CALL lbc_lnk( e3uw_0, 'U', 1._wp )   ! lateral boundary conditions 
     1168      CALL lbc_lnk( e3v_0 , 'V', 1._wp )   ;   CALL lbc_lnk( e3vw_0, 'V', 1._wp ) 
     1169      ! 
     1170      DO jk = 1, jpk                        ! set to z-scale factor if zero (i.e. along closed boundaries) 
     1171         WHERE( e3u_0 (:,:,jk) == 0._wp )   e3u_0 (:,:,jk) = e3t_1d(jk) 
     1172         WHERE( e3v_0 (:,:,jk) == 0._wp )   e3v_0 (:,:,jk) = e3t_1d(jk) 
     1173         WHERE( e3uw_0(:,:,jk) == 0._wp )   e3uw_0(:,:,jk) = e3w_1d(jk) 
     1174         WHERE( e3vw_0(:,:,jk) == 0._wp )   e3vw_0(:,:,jk) = e3w_1d(jk) 
     1175      END DO 
     1176       
     1177      ! Scale factor at F-point 
     1178      DO jk = 1, jpk                        ! initialisation to z-scale factors 
     1179         e3f_0(:,:,jk) = e3t_1d(jk) 
     1180      END DO 
     1181      DO jk = 1, jpk                        ! Computed as the minimum of neighbooring V-scale factors 
     1182         DO jj = 1, jpjm1 
     1183            DO ji = 1, fs_jpim1   ! vector opt. 
     1184               e3f_0(ji,jj,jk) = MIN( e3v_0(ji,jj,jk), e3v_0(ji+1,jj,jk) ) 
     1185            END DO 
     1186         END DO 
     1187      END DO 
     1188      CALL lbc_lnk( e3f_0, 'F', 1._wp )       ! Lateral boundary conditions 
     1189      ! 
     1190      DO jk = 1, jpk                        ! set to z-scale factor if zero (i.e. along closed boundaries) 
     1191         WHERE( e3f_0(:,:,jk) == 0._wp )   e3f_0(:,:,jk) = e3t_1d(jk) 
     1192      END DO 
     1193!!gm  bug ? :  must be a do loop with mj0,mj1 
     1194      !  
     1195      e3t_0(:,mj0(1),:) = e3t_0(:,mj0(2),:)     ! we duplicate factor scales for jj = 1 and jj = 2 
     1196      e3w_0(:,mj0(1),:) = e3w_0(:,mj0(2),:)  
     1197      e3u_0(:,mj0(1),:) = e3u_0(:,mj0(2),:)  
     1198      e3v_0(:,mj0(1),:) = e3v_0(:,mj0(2),:)  
     1199      e3f_0(:,mj0(1),:) = e3f_0(:,mj0(2),:)  
     1200 
     1201      ! Control of the sign 
     1202      IF( MINVAL( e3t_0  (:,:,:) ) <= 0._wp )   CALL ctl_stop( '    zgr_zps :   e r r o r   e3t_0 <= 0' ) 
     1203      IF( MINVAL( e3w_0  (:,:,:) ) <= 0._wp )   CALL ctl_stop( '    zgr_zps :   e r r o r   e3w_0 <= 0' ) 
     1204      IF( MINVAL( gdept_0(:,:,:) ) <  0._wp )   CALL ctl_stop( '    zgr_zps :   e r r o r   gdept_0 <  0' ) 
     1205      IF( MINVAL( gdepw_0(:,:,:) ) <  0._wp )   CALL ctl_stop( '    zgr_zps :   e r r o r   gdepw_0 <  0' ) 
     1206      
     1207      ! Compute gdep3w_0 (vertical sum of e3w) 
     1208      IF ( ln_isfcav ) THEN ! if cavity 
     1209         WHERE (misfdep == 0) misfdep = 1 
     1210         DO jj = 1,jpj 
     1211            DO ji = 1,jpi 
     1212               gdep3w_0(ji,jj,1) = 0.5_wp * e3w_0(ji,jj,1) 
     1213               DO jk = 2, misfdep(ji,jj) 
     1214                  gdep3w_0(ji,jj,jk) = gdep3w_0(ji,jj,jk-1) + e3w_0(ji,jj,jk)  
     1215               END DO 
     1216               IF (misfdep(ji,jj) .GE. 2) gdep3w_0(ji,jj,misfdep(ji,jj)) = risfdep(ji,jj) + 0.5_wp * e3w_0(ji,jj,misfdep(ji,jj)) 
     1217               DO jk = misfdep(ji,jj) + 1, jpk 
     1218                  gdep3w_0(ji,jj,jk) = gdep3w_0(ji,jj,jk-1) + e3w_0(ji,jj,jk)  
     1219               END DO 
     1220            END DO 
     1221         END DO 
     1222      ELSE ! no cavity 
     1223         gdep3w_0(:,:,1) = 0.5_wp * e3w_0(:,:,1) 
     1224         DO jk = 2, jpk 
     1225            gdep3w_0(:,:,jk) = gdep3w_0(:,:,jk-1) + e3w_0(:,:,jk) 
     1226         END DO 
     1227      END IF 
     1228      !                                               ! ================= ! 
     1229      IF(lwp .AND. ll_print) THEN                     !   Control print   ! 
     1230         !                                            ! ================= ! 
     1231         DO jj = 1,jpj 
     1232            DO ji = 1, jpi 
     1233               ik = MAX( mbathy(ji,jj), 1 ) 
     1234               zprt(ji,jj,1) = e3t_0   (ji,jj,ik) 
     1235               zprt(ji,jj,2) = e3w_0   (ji,jj,ik) 
     1236               zprt(ji,jj,3) = e3u_0   (ji,jj,ik) 
     1237               zprt(ji,jj,4) = e3v_0   (ji,jj,ik) 
     1238               zprt(ji,jj,5) = e3f_0   (ji,jj,ik) 
     1239               zprt(ji,jj,6) = gdep3w_0(ji,jj,ik) 
     1240            END DO 
     1241         END DO 
     1242         WRITE(numout,*) 
     1243         WRITE(numout,*) 'domzgr e3t(mbathy)'      ;   CALL prihre(zprt(:,:,1),jpi,jpj,1,jpi,1,1,jpj,1,1.e-3,numout) 
     1244         WRITE(numout,*) 
     1245         WRITE(numout,*) 'domzgr e3w(mbathy)'      ;   CALL prihre(zprt(:,:,2),jpi,jpj,1,jpi,1,1,jpj,1,1.e-3,numout) 
     1246         WRITE(numout,*) 
     1247         WRITE(numout,*) 'domzgr e3u(mbathy)'      ;   CALL prihre(zprt(:,:,3),jpi,jpj,1,jpi,1,1,jpj,1,1.e-3,numout) 
     1248         WRITE(numout,*) 
     1249         WRITE(numout,*) 'domzgr e3v(mbathy)'      ;   CALL prihre(zprt(:,:,4),jpi,jpj,1,jpi,1,1,jpj,1,1.e-3,numout) 
     1250         WRITE(numout,*) 
     1251         WRITE(numout,*) 'domzgr e3f(mbathy)'      ;   CALL prihre(zprt(:,:,5),jpi,jpj,1,jpi,1,1,jpj,1,1.e-3,numout) 
     1252         WRITE(numout,*) 
     1253         WRITE(numout,*) 'domzgr gdep3w(mbathy)'   ;   CALL prihre(zprt(:,:,6),jpi,jpj,1,jpi,1,1,jpj,1,1.e-3,numout) 
     1254      ENDIF   
     1255      ! 
     1256      CALL wrk_dealloc( jpi, jpj, jpk, zprt ) 
     1257      ! 
     1258      IF( nn_timing == 1 )  CALL timing_stop('zgr_zps') 
     1259      ! 
     1260   END SUBROUTINE zgr_zps 
     1261 
     1262   SUBROUTINE zgr_isf 
     1263      !!---------------------------------------------------------------------- 
     1264      !!                    ***  ROUTINE zgr_isf  *** 
     1265      !!    
     1266      !! ** Purpose :   check the bathymetry in levels 
     1267      !!    
     1268      !! ** Method  :   THe water column have to contained at least 2 cells 
     1269      !!                Bathymetry and isfdraft are modified (dig/close) to respect 
     1270      !!                this criterion. 
     1271      !!                  
     1272      !!    
     1273      !! ** Action  : - test compatibility between isfdraft and bathy  
     1274      !!              - bathy and isfdraft are modified 
     1275      !!---------------------------------------------------------------------- 
     1276      !!    
    9631277      INTEGER  ::   ji, jj, jk, jl   ! dummy loop indices 
    9641278      INTEGER  ::   ik, it           ! temporary integers 
    … …  
    9711285      REAL(wp) ::   zdiff            ! temporary scalar 
    9721286      REAL(wp) ::   zrefdep          ! temporary scalar 
    973       REAL(wp) ::   zbathydiff, zrisfdepdiff  
    974       REAL(wp), POINTER, DIMENSION(:,:)   ::   zrisfdep, zbathy, zmask   ! 3D workspace (ISH) 
    975       INTEGER , POINTER, DIMENSION(:,:)   ::   zmbathy, zmisfdep   ! 3D workspace (ISH) 
    976       REAL(wp), POINTER, DIMENSION(:,:,:) ::  zprt 
     1287      REAL(wp) ::   zbathydiff, zrisfdepdiff  ! isf temporary scalar 
     1288      REAL(wp), POINTER, DIMENSION(:,:)   ::   zrisfdep, zbathy, zmask   ! 2D workspace (ISH) 
     1289      INTEGER , POINTER, DIMENSION(:,:)   ::   zmbathy, zmisfdep         ! 2D workspace (ISH) 
    9771290      !!--------------------------------------------------------------------- 
    9781291      ! 
    979       IF( nn_timing == 1 )  CALL timing_start('zgr_zps') 
    980       ! 
    981       CALL wrk_alloc( jpi, jpj, jpk, zprt ) 
     1292      IF( nn_timing == 1 )  CALL timing_start('zgr_isf') 
     1293      ! 
    9821294      CALL wrk_alloc( jpi, jpj, zbathy, zmask, zrisfdep) 
    983       CALL wrk_alloc( jpi, jpj, zmbathy, zmisfdep) 
    984       ! 
    985       IF(lwp) WRITE(numout,*) 
    986       IF(lwp) WRITE(numout,*) '    zgr_zps : z-coordinate with partial steps' 
    987       IF(lwp) WRITE(numout,*) '    ~~~~~~~ ' 
    988       IF(lwp) WRITE(numout,*) '              mbathy is recomputed : bathy_level file is NOT used' 
    989  
    990       ll_print = .FALSE.                   ! Local variable for debugging 
    991        
    992       IF(lwp .AND. ll_print) THEN          ! control print of the ocean depth 
    993          WRITE(numout,*) 
    994          WRITE(numout,*) 'dom_zgr_zps:  bathy (in hundred of meters)' 
    995          CALL prihre( bathy, jpi, jpj, 1,jpi, 1, 1, jpj, 1, 1.e-2, numout ) 
    996       ENDIF 
    997  
    998       ! bathymetry in level (from bathy_meter) 
    999       ! =================== 
    1000       zmax = gdepw_1d(jpk) + e3t_1d(jpk)        ! maximum depth (i.e. the last ocean level thickness <= 2*e3t_1d(jpkm1) ) 
    1001       bathy(:,:) = MIN( zmax ,  bathy(:,:) )    ! bounded value of bathy (min already set at the end of zgr_bat) 
    1002       WHERE( bathy(:,:) == 0._wp )   ;   mbathy(:,:) = 0       ! land  : set mbathy to 0 
    1003       ELSE WHERE                     ;   mbathy(:,:) = jpkm1   ! ocean : initialize mbathy to the max ocean level 
    1004       END WHERE 
    1005  
    1006       ! Compute mbathy for ocean points (i.e. the number of ocean levels) 
    1007       ! find the number of ocean levels such that the last level thickness 
    1008       ! is larger than the minimum of e3zps_min and e3zps_rat * e3t_1d (where 
    1009       ! e3t_1d is the reference level thickness 
    1010       DO jk = jpkm1, 1, -1 
    1011          zdepth = gdepw_1d(jk) + MIN( e3zps_min, e3t_1d(jk)*e3zps_rat ) 
    1012          WHERE( 0._wp < bathy(:,:) .AND. bathy(:,:) <= zdepth )   mbathy(:,:) = jk-1 
    1013       END DO 
     1295      CALL wrk_alloc( jpi, jpj, zmisfdep, zmbathy ) 
     1296 
     1297 
    10141298      ! (ISF) compute misfdep 
    10151299      WHERE( risfdep(:,:) == 0._wp .AND. bathy(:,:) .NE. 0) ;   misfdep(:,:) = 1   ! open water : set misfdep to 1   
    … …  
    10551339            misfdep(jpi,:) = misfdep(  2  ,:)  
    10561340         ENDIF 
    1057   
     1341 
    10581342         IF( nperio == 1 .OR. nperio  ==  4 .OR. nperio  ==  6 ) THEN 
    10591343            mbathy( 1 ,:) = mbathy(jpim1,:)             ! local domain is cyclic east-west 
    10601344            mbathy(jpi,:) = mbathy(  2  ,:) 
    10611345         ENDIF 
    1062   
     1346 
    10631347         ! split last cell if possible (only where water column is 2 cell or less) 
    10641348         DO jk = jpkm1, 1, -1 
    … …  
    10781362            END WHERE 
    10791363         END DO 
    1080   
     1364 
    10811365  
    10821366 ! Case where bathy and risfdep compatible but not the level variable mbathy/misfdep because of partial cell condition 
    … …  
    13591643               IF( zmbathy(ji,jj) .LT. misfdep(ji  ,jj+1) ) ibtestjp1 = 0 
    13601644               ibtest=MAX(ibtestim1, ibtestip1, ibtestjm1, ibtestjp1) 
    1361                IF( ibtest == 0 ) THEN 
     1645               IF( ibtest == 0 .AND. misfdep(ji,jj) .GE. 2) THEN 
    13621646                  mbathy(ji,jj) = 0 ; bathy(ji,jj) = 0.0_wp ; misfdep(ji,jj) = 0 ; risfdep(ji,jj) = 0.0_wp ; 
    13631647               END IF 
    … …  
    14751759      ENDIF  
    14761760 
    1477       ! Scale factors and depth at T- and W-points 
    1478       DO jk = 1, jpk                        ! intitialization to the reference z-coordinate 
    1479          gdept_0(:,:,jk) = gdept_1d(jk) 
    1480          gdepw_0(:,:,jk) = gdepw_1d(jk) 
    1481          e3t_0  (:,:,jk) = e3t_1d  (jk) 
    1482          e3w_0  (:,:,jk) = e3w_1d  (jk) 
    1483       END DO 
    1484       !  
    1485       DO jj = 1, jpj 
    1486          DO ji = 1, jpi 
    1487             ik = mbathy(ji,jj) 
    1488             IF( ik > 0 ) THEN               ! ocean point only 
    1489                ! max ocean level case 
    1490                IF( ik == jpkm1 ) THEN 
    1491                   zdepwp = bathy(ji,jj) 
    1492                   ze3tp  = bathy(ji,jj) - gdepw_1d(ik) 
    1493                   ze3wp = 0.5_wp * e3w_1d(ik) * ( 1._wp + ( ze3tp/e3t_1d(ik) ) ) 
    1494                   e3t_0(ji,jj,ik  ) = ze3tp 
    1495                   e3t_0(ji,jj,ik+1) = ze3tp 
    1496                   e3w_0(ji,jj,ik  ) = ze3wp 
    1497                   e3w_0(ji,jj,ik+1) = ze3tp 
    1498                   gdepw_0(ji,jj,ik+1) = zdepwp 
    1499                   gdept_0(ji,jj,ik  ) = gdept_1d(ik-1) + ze3wp 
    1500                   gdept_0(ji,jj,ik+1) = gdept_0(ji,jj,ik) + ze3tp 
    1501                   ! 
    1502                ELSE                         ! standard case 
    1503                   IF( bathy(ji,jj) <= gdepw_1d(ik+1) ) THEN  ;   gdepw_0(ji,jj,ik+1) = bathy(ji,jj) 
    1504                   ELSE                                       ;   gdepw_0(ji,jj,ik+1) = gdepw_1d(ik+1) 
    1505                   ENDIF 
    1506 !gm Bug?  check the gdepw_1d 
    1507                   !       ... on ik 
    1508                   gdept_0(ji,jj,ik) = gdepw_1d(ik) + ( gdepw_0(ji,jj,ik+1) - gdepw_1d(ik) )   & 
    1509                      &                             * ((gdept_1d(     ik  ) - gdepw_1d(ik) )   & 
    1510                      &                             / ( gdepw_1d(     ik+1) - gdepw_1d(ik) )) 
    1511                   e3t_0(ji,jj,ik) = e3t_1d (ik) * ( gdepw_0 (ji,jj,ik+1) - gdepw_1d(ik) )   &  
    1512                      &                          / ( gdepw_1d(      ik+1) - gdepw_1d(ik) )  
    1513                   e3w_0(ji,jj,ik) = 0.5_wp * ( gdepw_0(ji,jj,ik+1) + gdepw_1d(ik+1) - 2._wp * gdepw_1d(ik) )   & 
    1514                      &                     * ( e3w_1d(ik) / ( gdepw_1d(ik+1) - gdepw_1d(ik) ) ) 
    1515                   !       ... on ik+1 
    1516                   e3w_0  (ji,jj,ik+1) = e3t_0  (ji,jj,ik) 
    1517                   e3t_0  (ji,jj,ik+1) = e3t_0  (ji,jj,ik) 
    1518                   gdept_0(ji,jj,ik+1) = gdept_0(ji,jj,ik) + e3t_0(ji,jj,ik) 
    1519                ENDIF 
    1520             ENDIF 
    1521          END DO 
    1522       END DO 
    1523       ! 
    1524       it = 0 
    1525       DO jj = 1, jpj 
    1526          DO ji = 1, jpi 
    1527             ik = mbathy(ji,jj) 
    1528             IF( ik > 0 ) THEN               ! ocean point only 
    1529                e3tp (ji,jj) = e3t_0(ji,jj,ik) 
    1530                e3wp (ji,jj) = e3w_0(ji,jj,ik) 
    1531                ! test 
    1532                zdiff= gdepw_0(ji,jj,ik+1) - gdept_0(ji,jj,ik  ) 
    1533                IF( zdiff <= 0._wp .AND. lwp ) THEN  
    1534                   it = it + 1 
    1535                   WRITE(numout,*) ' it      = ', it, ' ik      = ', ik, ' (i,j) = ', ji, jj 
    1536                   WRITE(numout,*) ' bathy = ', bathy(ji,jj) 
    1537                   WRITE(numout,*) ' gdept_0 = ', gdept_0(ji,jj,ik), ' gdepw_0 = ', gdepw_0(ji,jj,ik+1), ' zdiff = ', zdiff 
    1538                   WRITE(numout,*) ' e3tp    = ', e3t_0  (ji,jj,ik), ' e3wp    = ', e3w_0  (ji,jj,ik  ) 
    1539                ENDIF 
    1540             ENDIF 
    1541          END DO 
    1542       END DO 
    1543       ! 
    1544       ! (ISF) Definition of e3t, u, v, w for ISF case 
    1545       DO jj = 1, jpj  
    1546          DO ji = 1, jpi  
    1547             ik = misfdep(ji,jj)  
    1548             IF( ik > 1 ) THEN               ! ice shelf point only  
    1549                IF( risfdep(ji,jj) < gdepw_1d(ik) )  risfdep(ji,jj)= gdepw_1d(ik)  
    1550                gdepw_0(ji,jj,ik) = risfdep(ji,jj)  
    1551 !gm Bug?  check the gdepw_0  
    1552                !       ... on ik  
    1553                gdept_0(ji,jj,ik) = gdepw_1d(ik+1) - ( gdepw_1d(ik+1) - gdepw_0(ji,jj,ik) )   &  
    1554                   &                               * ( gdepw_1d(ik+1) - gdept_1d(ik)      )   &  
    1555                   &                               / ( gdepw_1d(ik+1) - gdepw_1d(ik)      )  
    1556                e3t_0  (ji,jj,ik  ) = gdepw_1d(ik+1) - gdepw_0(ji,jj,ik)  
    1557                e3w_0  (ji,jj,ik+1) = gdept_1d(ik+1) - gdept_0(ji,jj,ik) 
    1558  
    1559                IF( ik + 1 == mbathy(ji,jj) ) THEN               ! ice shelf point only (2 cell water column)  
    1560                   e3w_0  (ji,jj,ik+1) = gdept_0(ji,jj,ik+1) - gdept_0(ji,jj,ik)  
    1561                 ENDIF  
    1562                !       ... on ik / ik-1  
    1563                e3w_0  (ji,jj,ik  ) = 2._wp * (gdept_0(ji,jj,ik) - gdepw_0(ji,jj,ik))  
    1564                e3t_0  (ji,jj,ik-1) = gdepw_0(ji,jj,ik) - gdepw_1d(ik-1) 
    1565 ! The next line isn't required and doesn't affect results - included for consistency with bathymetry code  
    1566                gdept_0(ji,jj,ik-1) = gdept_1d(ik-1) 
    1567             ENDIF  
    1568          END DO  
    1569       END DO  
    1570       !  
    1571       it = 0  
    1572       DO jj = 1, jpj  
    1573          DO ji = 1, jpi  
    1574             ik = misfdep(ji,jj)  
    1575             IF( ik > 1 ) THEN               ! ice shelf point only  
    1576                e3tp (ji,jj) = e3t_0(ji,jj,ik  )  
    1577                e3wp (ji,jj) = e3w_0(ji,jj,ik+1 )  
    1578                ! test  
    1579                zdiff= gdept_0(ji,jj,ik) - gdepw_0(ji,jj,ik  )  
    1580                IF( zdiff <= 0. .AND. lwp ) THEN   
    1581                   it = it + 1  
    1582                   WRITE(numout,*) ' it      = ', it, ' ik      = ', ik, ' (i,j) = ', ji, jj  
    1583                   WRITE(numout,*) ' risfdep = ', risfdep(ji,jj)  
    1584                   WRITE(numout,*) ' gdept = ', gdept_0(ji,jj,ik), ' gdepw = ', gdepw_0(ji,jj,ik+1), ' zdiff = ', zdiff  
    1585                   WRITE(numout,*) ' e3tp  = ', e3tp(ji,jj), ' e3wp  = ', e3wp(ji,jj)  
    1586                ENDIF  
    1587             ENDIF  
    1588          END DO  
    1589       END DO  
    1590       ! END (ISF) 
    1591  
    1592       ! Scale factors and depth at U-, V-, UW and VW-points 
    1593       DO jk = 1, jpk                        ! initialisation to z-scale factors 
    1594          e3u_0 (:,:,jk) = e3t_1d(jk) 
    1595          e3v_0 (:,:,jk) = e3t_1d(jk) 
    1596          e3uw_0(:,:,jk) = e3w_1d(jk) 
    1597          e3vw_0(:,:,jk) = e3w_1d(jk) 
    1598       END DO 
    1599       DO jk = 1,jpk                         ! Computed as the minimum of neighbooring scale factors 
    1600          DO jj = 1, jpjm1 
    1601             DO ji = 1, fs_jpim1   ! vector opt. 
    1602                e3u_0 (ji,jj,jk) = MIN( e3t_0(ji,jj,jk), e3t_0(ji+1,jj,jk) ) 
    1603                e3v_0 (ji,jj,jk) = MIN( e3t_0(ji,jj,jk), e3t_0(ji,jj+1,jk) ) 
    1604                e3uw_0(ji,jj,jk) = MIN( e3w_0(ji,jj,jk), e3w_0(ji+1,jj,jk) ) 
    1605                e3vw_0(ji,jj,jk) = MIN( e3w_0(ji,jj,jk), e3w_0(ji,jj+1,jk) ) 
    1606             END DO 
    1607          END DO 
    1608       END DO 
    1609       ! (ISF) define e3uw 
    1610       DO jk = 2,jpk                           
    1611          DO jj = 1, jpjm1  
    1612             DO ji = 1, fs_jpim1   ! vector opt.  
    1613                e3uw_0(ji,jj,jk) = MIN( gdept_0(ji,jj,jk), gdept_0(ji+1,jj  ,jk) ) & 
    1614                  &   - MAX( gdept_0(ji,jj,jk-1), gdept_0(ji+1,jj  ,jk-1) ) 
    1615                e3vw_0(ji,jj,jk) = MIN( gdept_0(ji,jj,jk), gdept_0(ji  ,jj+1,jk) ) & 
    1616                  &   - MAX( gdept_0(ji,jj,jk-1), gdept_0(ji  ,jj+1,jk-1) ) 
    1617             END DO  
    1618          END DO  
    1619       END DO 
    1620       !End (ISF) 
    1621        
    1622       CALL lbc_lnk( e3u_0 , 'U', 1._wp )   ;   CALL lbc_lnk( e3uw_0, 'U', 1._wp )   ! lateral boundary conditions 
    1623       CALL lbc_lnk( e3v_0 , 'V', 1._wp )   ;   CALL lbc_lnk( e3vw_0, 'V', 1._wp ) 
    1624       ! 
    1625       DO jk = 1, jpk                        ! set to z-scale factor if zero (i.e. along closed boundaries) 
    1626          WHERE( e3u_0 (:,:,jk) == 0._wp )   e3u_0 (:,:,jk) = e3t_1d(jk) 
    1627          WHERE( e3v_0 (:,:,jk) == 0._wp )   e3v_0 (:,:,jk) = e3t_1d(jk) 
    1628          WHERE( e3uw_0(:,:,jk) == 0._wp )   e3uw_0(:,:,jk) = e3w_1d(jk) 
    1629          WHERE( e3vw_0(:,:,jk) == 0._wp )   e3vw_0(:,:,jk) = e3w_1d(jk) 
    1630       END DO 
    1631        
    1632       ! Scale factor at F-point 
    1633       DO jk = 1, jpk                        ! initialisation to z-scale factors 
    1634          e3f_0(:,:,jk) = e3t_1d(jk) 
    1635       END DO 
    1636       DO jk = 1, jpk                        ! Computed as the minimum of neighbooring V-scale factors 
    1637          DO jj = 1, jpjm1 
    1638             DO ji = 1, fs_jpim1   ! vector opt. 
    1639                e3f_0(ji,jj,jk) = MIN( e3v_0(ji,jj,jk), e3v_0(ji+1,jj,jk) ) 
    1640             END DO 
    1641          END DO 
    1642       END DO 
    1643       CALL lbc_lnk( e3f_0, 'F', 1._wp )       ! Lateral boundary conditions 
    1644       ! 
    1645       DO jk = 1, jpk                        ! set to z-scale factor if zero (i.e. along closed boundaries) 
    1646          WHERE( e3f_0(:,:,jk) == 0._wp )   e3f_0(:,:,jk) = e3t_1d(jk) 
    1647       END DO 
    1648 !!gm  bug ? :  must be a do loop with mj0,mj1 
    1649       !  
    1650       e3t_0(:,mj0(1),:) = e3t_0(:,mj0(2),:)     ! we duplicate factor scales for jj = 1 and jj = 2 
    1651       e3w_0(:,mj0(1),:) = e3w_0(:,mj0(2),:)  
    1652       e3u_0(:,mj0(1),:) = e3u_0(:,mj0(2),:)  
    1653       e3v_0(:,mj0(1),:) = e3v_0(:,mj0(2),:)  
    1654       e3f_0(:,mj0(1),:) = e3f_0(:,mj0(2),:)  
    1655  
    1656       ! Control of the sign 
    1657       IF( MINVAL( e3t_0  (:,:,:) ) <= 0._wp )   CALL ctl_stop( '    zgr_zps :   e r r o r   e3t_0 <= 0' ) 
    1658       IF( MINVAL( e3w_0  (:,:,:) ) <= 0._wp )   CALL ctl_stop( '    zgr_zps :   e r r o r   e3w_0 <= 0' ) 
    1659       IF( MINVAL( gdept_0(:,:,:) ) <  0._wp )   CALL ctl_stop( '    zgr_zps :   e r r o r   gdept_0 <  0' ) 
    1660       IF( MINVAL( gdepw_0(:,:,:) ) <  0._wp )   CALL ctl_stop( '    zgr_zps :   e r r o r   gdepw_0 <  0' ) 
    1661       
    1662       ! Compute gdep3w_0 (vertical sum of e3w) 
    1663       WHERE (misfdep == 0) misfdep = 1 
    1664       DO jj = 1,jpj 
    1665          DO ji = 1,jpi 
    1666             gdep3w_0(ji,jj,1) = 0.5_wp * e3w_0(ji,jj,1) 
    1667             DO jk = 2, misfdep(ji,jj) 
    1668                gdep3w_0(ji,jj,jk) = gdep3w_0(ji,jj,jk-1) + e3w_0(ji,jj,jk)  
    1669             END DO 
    1670             IF (misfdep(ji,jj) .GE. 2) gdep3w_0(ji,jj,misfdep(ji,jj)) = risfdep(ji,jj) + 0.5_wp * e3w_0(ji,jj,misfdep(ji,jj)) 
    1671             DO jk = misfdep(ji,jj) + 1, jpk 
    1672                gdep3w_0(ji,jj,jk) = gdep3w_0(ji,jj,jk-1) + e3w_0(ji,jj,jk)  
    1673             END DO 
    1674         END DO 
    1675       END DO 
    1676       !                                               ! ================= ! 
    1677       IF(lwp .AND. ll_print) THEN                     !   Control print   ! 
    1678          !                                            ! ================= ! 
    1679          DO jj = 1,jpj 
    1680             DO ji = 1, jpi 
    1681                ik = MAX( mbathy(ji,jj), 1 ) 
    1682                zprt(ji,jj,1) = e3t_0   (ji,jj,ik) 
    1683                zprt(ji,jj,2) = e3w_0   (ji,jj,ik) 
    1684                zprt(ji,jj,3) = e3u_0   (ji,jj,ik) 
    1685                zprt(ji,jj,4) = e3v_0   (ji,jj,ik) 
    1686                zprt(ji,jj,5) = e3f_0   (ji,jj,ik) 
    1687                zprt(ji,jj,6) = gdep3w_0(ji,jj,ik) 
    1688             END DO 
    1689          END DO 
    1690          WRITE(numout,*) 
    1691          WRITE(numout,*) 'domzgr e3t(mbathy)'      ;   CALL prihre(zprt(:,:,1),jpi,jpj,1,jpi,1,1,jpj,1,1.e-3,numout) 
    1692          WRITE(numout,*) 
    1693          WRITE(numout,*) 'domzgr e3w(mbathy)'      ;   CALL prihre(zprt(:,:,2),jpi,jpj,1,jpi,1,1,jpj,1,1.e-3,numout) 
    1694          WRITE(numout,*) 
    1695          WRITE(numout,*) 'domzgr e3u(mbathy)'      ;   CALL prihre(zprt(:,:,3),jpi,jpj,1,jpi,1,1,jpj,1,1.e-3,numout) 
    1696          WRITE(numout,*) 
    1697          WRITE(numout,*) 'domzgr e3v(mbathy)'      ;   CALL prihre(zprt(:,:,4),jpi,jpj,1,jpi,1,1,jpj,1,1.e-3,numout) 
    1698          WRITE(numout,*) 
    1699          WRITE(numout,*) 'domzgr e3f(mbathy)'      ;   CALL prihre(zprt(:,:,5),jpi,jpj,1,jpi,1,1,jpj,1,1.e-3,numout) 
    1700          WRITE(numout,*) 
    1701          WRITE(numout,*) 'domzgr gdep3w(mbathy)'   ;   CALL prihre(zprt(:,:,6),jpi,jpj,1,jpi,1,1,jpj,1,1.e-3,numout) 
    1702       ENDIF   
    1703       ! 
    1704       CALL wrk_dealloc( jpi, jpj, jpk, zprt ) 
    17051761      CALL wrk_dealloc( jpi, jpj, zmask, zbathy, zrisfdep ) 
    17061762      CALL wrk_dealloc( jpi, jpj, zmisfdep, zmbathy ) 
    1707       ! 
    1708       IF( nn_timing == 1 )  CALL timing_stop('zgr_zps') 
    1709       ! 
    1710    END SUBROUTINE zgr_zps 
     1763 
     1764      IF( nn_timing == 1 )  CALL timing_stop('zgr_isf') 
     1765       
     1766   END SUBROUTINE 
    17111767 
    17121768   SUBROUTINE zgr_sco 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/DOM/istate.F90

    r5312 r5313  
    6969      !! ** Purpose :   Initialization of the dynamics and tracer fields. 
    7070      !!---------------------------------------------------------------------- 
    71       ! - ML - needed for initialization of e3t_b 
    72       INTEGER  ::  ji,jj,jk     ! dummy loop indices 
    73       REAL(wp), POINTER, DIMENSION(:,:,:,:)  ::  zuvd    ! U & V data workspace 
     71      INTEGER ::   ji, jj, jk   ! dummy loop indices 
     72      REAL(wp), POINTER, DIMENSION(:,:,:,:) ::   zuvd    ! U & V data workspace 
    7473      !!---------------------------------------------------------------------- 
    7574      ! 
    … …  
    8483      IF( lk_c1d ) CALL dta_uvd_init          ! Initialization of U & V input data 
    8584 
    86       rhd  (:,:,:  ) = 0._wp 
    87       rhop (:,:,:  ) = 0._wp 
    88       rn2  (:,:,:  ) = 0._wp 
    89       tsa  (:,:,:,:) = 0._wp    
    90       rab_b(:,:,:,:) = 0._wp 
    91       rab_n(:,:,:,:) = 0._wp 
     85      rhd  (:,:,:  ) = 0._wp   ;   rhop (:,:,:  ) = 0._wp      ! set one for all to 0 at level jpk 
     86      rn2b (:,:,:  ) = 0._wp   ;   rn2  (:,:,:  ) = 0._wp      ! set one for all to 0 at levels 1 and jpk 
     87      tsa  (:,:,:,:) = 0._wp                                   ! set one for all to 0 at level jpk 
     88      rab_b(:,:,:,:) = 0._wp   ;   rab_n(:,:,:,:) = 0._wp      ! set one for all to 0 at level jpk 
    9289 
    9390      IF( ln_rstart ) THEN                    ! Restart from a file 
    … …  
    137134         CALL eos( tsb, rhd, rhop, gdept_0(:,:,:) )        ! before potential and in situ densities 
    138135#if ! defined key_c1d 
    139          IF( ln_zps )    CALL zps_hde( nit000, jpts, tsb, gtsu, gtsv,  &        ! Partial steps: before horizontal gradient 
    140             &                                      rhd, gru , grv, aru, arv, gzu, gzv, ge3ru, ge3rv,  &             ! 
    141             &                                      gtui, gtvi, grui, grvi, arui, arvi, gzui, gzvi, ge3rui, ge3rvi  )  ! of t, s, rd at the last ocean level 
     136         IF( ln_zps .AND. .NOT. ln_isfcav)                                 & 
     137            &            CALL zps_hde    ( nit000, jpts, tsb, gtsu, gtsv,  &    ! Partial steps: before horizontal gradient 
     138            &                                            rhd, gru , grv    )  ! of t, s, rd at the last ocean level 
     139         IF( ln_zps .AND.       ln_isfcav)                                 & 
     140            &            CALL zps_hde_isf( nit000, jpts, tsb, gtsu, gtsv,  &    ! Partial steps for top cell (ISF) 
     141            &                                            rhd, gru , grv , aru , arv , gzu , gzv , ge3ru , ge3rv ,   & 
     142            &                                     gtui, gtvi, grui, grvi, arui, arvi, gzui, gzvi, ge3rui, ge3rvi    ) ! of t, s, rd at the last ocean level 
    142143#endif 
    143144         !    

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/DOM/phycst.F90

    r5312 r5313  
    4141   REAL(wp), PUBLIC ::   rt0      = 273.15_wp        !: freezing point of fresh water [Kelvin] 
    4242#if defined key_lim3 
    43    REAL(wp), PUBLIC ::   rt0_snow = 273.16_wp        !: melting point of snow         [Kelvin] 
    44    REAL(wp), PUBLIC ::   rt0_ice  = 273.16_wp        !: melting point of ice          [Kelvin] 
     43   REAL(wp), PUBLIC ::   rt0_snow = 273.15_wp        !: melting point of snow         [Kelvin] 
     44   REAL(wp), PUBLIC ::   rt0_ice  = 273.15_wp        !: melting point of ice          [Kelvin] 
    4545#else 
    4646   REAL(wp), PUBLIC ::   rt0_snow = 273.15_wp        !: melting point of snow         [Kelvin] 
    … …  
    5151   REAL(wp), PUBLIC ::   rcp                         !: ocean specific heat           [J/Kelvin] 
    5252   REAL(wp), PUBLIC ::   r1_rcp                      !: = 1. / rcp                    [Kelvin/J] 
     53   REAL(wp), PUBLIC ::   rau0_rcp                    !: = rau0 * rcp  
    5354   REAL(wp), PUBLIC ::   r1_rau0_rcp                 !: = 1. / ( rau0 * rcp ) 
    5455 
    … …  
    8283   REAL(wp), PUBLIC ::   xlic     =  300.33e+6_wp    !: volumetric latent heat fusion of ice                  [J/m3] 
    8384   REAL(wp), PUBLIC ::   xsn      =    2.8e+6_wp     !: volumetric latent heat of sublimation of snow         [J/m3] 
     85#endif 
     86#if defined key_lim3 
     87   REAL(wp), PUBLIC ::   r1_rhoic                    !: 1 / rhoic 
     88   REAL(wp), PUBLIC ::   r1_rhosn                    !: 1 / rhosn 
    8489#endif 
    8590   !!---------------------------------------------------------------------- 
    … …  
    166171      lfus = xlsn / rhosn        ! latent heat of fusion of fresh ice 
    167172#endif 
    168  
     173#if defined key_lim3 
     174      r1_rhoic = 1._wp / rhoic 
     175      r1_rhosn = 1._wp / rhosn 
     176#endif 
    169177      IF(lwp) THEN 
    170178         WRITE(numout,*) 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/DYN/divcur.F90

    r5312 r5313  
    1717   !!            3.3  ! 2010-09  (D.Storkey and E.O'Dea) bug fixes for BDY module 
    1818   !!             -   ! 2010-10  (R. Furner, G. Madec) runoff and cla added directly here 
     19   !!            3.6  ! 2014-11  (P. Mathiot)          isf            added directly here 
    1920   !!---------------------------------------------------------------------- 
    2021 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/DYN/dynadv.F90

    r5312 r5313  
    127127      IF( ln_dynzad_zts .AND. .NOT. ln_dynadv_vec )   & 
    128128          CALL ctl_stop( 'Sub timestepping of vertical advection requires vector form; set ln_dynadv_vec = .TRUE.' ) 
     129      IF( ln_dynzad_zts .AND. ln_isfcav )   & 
     130          CALL ctl_stop( 'Sub timestepping of vertical advection does not work with ln_isfcav = .TRUE.' ) 
    129131 
    130132      !                               ! Set nadv 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/DYN/dynbfr.F90

    r5312 r5313  
    8080              ua(ji,jj,ikbu) = ua(ji,jj,ikbu) + MAX(  bfrua(ji,jj) / fse3u(ji,jj,ikbu) , zm1_2dt  ) * ub(ji,jj,ikbu) 
    8181              va(ji,jj,ikbv) = va(ji,jj,ikbv) + MAX(  bfrva(ji,jj) / fse3v(ji,jj,ikbv) , zm1_2dt  ) * vb(ji,jj,ikbv) 
    82                
    83               ! (ISF) stability criteria for top friction 
    84               ikbu = miku(ji,jj)          ! first wet ocean u- & v-levels 
    85               ikbv = mikv(ji,jj) 
    86               ! 
    87               ! Apply stability criteria on absolute value  : abs(bfr/e3) < 1/(2dt) => bfr/e3 > -1/(2dt) 
    88               ua(ji,jj,ikbu) = ua(ji,jj,ikbu) + MAX(  tfrua(ji,jj) / fse3u(ji,jj,ikbu) , zm1_2dt  ) * ub(ji,jj,ikbu) & 
    89                  &             * (1.-umask(ji,jj,1)) 
    90               va(ji,jj,ikbv) = va(ji,jj,ikbv) + MAX(  tfrva(ji,jj) / fse3v(ji,jj,ikbv) , zm1_2dt  ) * vb(ji,jj,ikbv) & 
    91                  &             * (1.-vmask(ji,jj,1)) 
    92               ! (ISF) 
    93                
    9482           END DO 
    9583        END DO 
     84         
     85        IF ( ln_isfcav ) THEN 
     86           DO jj = 2, jpjm1 
     87              DO ji = 2, jpim1 
     88                 ! (ISF) stability criteria for top friction 
     89                 ikbu = miku(ji,jj)          ! first wet ocean u- & v-levels 
     90                 ikbv = mikv(ji,jj) 
     91                 ! 
     92                 ! Apply stability criteria on absolute value  : abs(bfr/e3) < 1/(2dt) => bfr/e3 > -1/(2dt) 
     93                 ua(ji,jj,ikbu) = ua(ji,jj,ikbu) + MAX(  tfrua(ji,jj) / fse3u(ji,jj,ikbu) , zm1_2dt  ) * ub(ji,jj,ikbu) & 
     94                    &             * (1.-umask(ji,jj,1)) 
     95                 va(ji,jj,ikbv) = va(ji,jj,ikbv) + MAX(  tfrva(ji,jj) / fse3v(ji,jj,ikbv) , zm1_2dt  ) * vb(ji,jj,ikbv) & 
     96                    &             * (1.-vmask(ji,jj,1)) 
     97                 ! (ISF) 
     98              END DO 
     99           END DO 
     100        END IF 
    96101 
    97102        ! 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/DYN/dynhpg.F90

    r5312 r5313  
    1616   !!            3.4  !  2011-11  (H. Liu) hpg_prj: Original code for s-coordinates 
    1717   !!                 !           (A. Coward) suppression of hel, wdj and rot options 
     18   !!            3.6  !  2014-11  (P. Mathiot) hpg_isf: original code for ice shelf cavity 
    1819   !!---------------------------------------------------------------------- 
    1920 
    … …  
    2526   !!       hpg_zps  : z-coordinate plus partial steps (interpolation) 
    2627   !!       hpg_sco  : s-coordinate (standard jacobian formulation) 
     28   !!       hpg_isf  : s-coordinate (sco formulation) adapted to ice shelf 
    2729   !!       hpg_djc  : s-coordinate (Density Jacobian with Cubic polynomial) 
    2830   !!       hpg_prj  : s-coordinate (Pressure Jacobian with Cubic polynomial) 
    … …  
    5557   LOGICAL , PUBLIC ::   ln_hpg_djc      !: s-coordinate (Density Jacobian with Cubic polynomial) 
    5658   LOGICAL , PUBLIC ::   ln_hpg_prj      !: s-coordinate (Pressure Jacobian scheme) 
     59   LOGICAL , PUBLIC ::   ln_hpg_isf      !: s-coordinate similar to sco modify for isf 
    5760   LOGICAL , PUBLIC ::   ln_dynhpg_imp   !: semi-implicite hpg flag 
    5861 
    … …  
    97100      CASE (  3 )   ;   CALL hpg_djc    ( kt )      ! s-coordinate (Density Jacobian with Cubic polynomial) 
    98101      CASE (  4 )   ;   CALL hpg_prj    ( kt )      ! s-coordinate (Pressure Jacobian scheme) 
     102      CASE (  5 )   ;   CALL hpg_isf    ( kt )      ! s-coordinate similar to sco modify for ice shelf 
    99103      END SELECT 
    100104      ! 
    … …  
    128132      !! 
    129133      NAMELIST/namdyn_hpg/ ln_hpg_zco, ln_hpg_zps, ln_hpg_sco,     & 
    130          &                 ln_hpg_djc, ln_hpg_prj, ln_dynhpg_imp 
     134         &                 ln_hpg_djc, ln_hpg_prj, ln_hpg_isf, ln_dynhpg_imp 
    131135      !!---------------------------------------------------------------------- 
    132136      ! 
    … …  
    148152         WRITE(numout,*) '      z-coord. - partial steps (interpolation)          ln_hpg_zps    = ', ln_hpg_zps 
    149153         WRITE(numout,*) '      s-coord. (standard jacobian formulation)          ln_hpg_sco    = ', ln_hpg_sco 
     154         WRITE(numout,*) '      s-coord. (standard jacobian formulation) for isf  ln_hpg_isf    = ', ln_hpg_isf 
    150155         WRITE(numout,*) '      s-coord. (Density Jacobian: Cubic polynomial)     ln_hpg_djc    = ', ln_hpg_djc 
    151156         WRITE(numout,*) '      s-coord. (Pressure Jacobian: Cubic polynomial)    ln_hpg_prj    = ', ln_hpg_prj 
    … …  
    158163                           & either  ln_hpg_sco or  ln_hpg_prj instead') 
    159164      ! 
    160       IF( lk_vvl .AND. .NOT. (ln_hpg_sco.OR.ln_hpg_prj) )   & 
     165      IF( lk_vvl .AND. .NOT. (ln_hpg_sco.OR.ln_hpg_prj.OR.ln_hpg_isf) )   & 
    161166         &   CALL ctl_stop('dyn_hpg_init : variable volume key_vvl requires:& 
    162167                           & the standard jacobian formulation hpg_sco or & 
    163168                           & the pressure jacobian formulation hpg_prj') 
     169 
     170      IF(       ln_hpg_isf .AND. .NOT. ln_isfcav )   & 
     171         &   CALL ctl_stop( ' hpg_isf not available if ln_isfcav = false ' ) 
     172      IF( .NOT. ln_hpg_isf .AND.       ln_isfcav )   & 
     173         &   CALL ctl_stop( 'Only hpg_isf has been corrected to work with ice shelf cavity.' ) 
    164174      ! 
    165175      !                               ! Set nhpg from ln_hpg_... flags 
    … …  
    169179      IF( ln_hpg_djc )   nhpg = 3 
    170180      IF( ln_hpg_prj )   nhpg = 4 
     181      IF( ln_hpg_isf )   nhpg = 5 
    171182      ! 
    172183      !                               ! Consistency check 
    … …  
    177188      IF( ln_hpg_djc )   ioptio = ioptio + 1 
    178189      IF( ln_hpg_prj )   ioptio = ioptio + 1 
     190      IF( ln_hpg_isf )   ioptio = ioptio + 1 
    179191      IF( ioptio /= 1 )   CALL ctl_stop( 'NO or several hydrostatic pressure gradient options used' ) 
    180       IF( (ln_hpg_zco .OR. ln_hpg_zps .OR. ln_hpg_djc .OR. ln_hpg_prj ) .AND. nn_isf .NE. 0 )   & 
    181           &  CALL ctl_stop( 'Only hpg_sco has been corrected to work with ice shelf cavity.' ) 
     192      !  
     193      ! initialisation of ice load 
     194      riceload(:,:)=0.0 
    182195      ! 
    183196   END SUBROUTINE dyn_hpg_init 
    … …  
    345358   END SUBROUTINE hpg_zps 
    346359 
    347  
    348360   SUBROUTINE hpg_sco( kt ) 
    349361      !!--------------------------------------------------------------------- 
    … …  
    366378      INTEGER, INTENT(in) ::   kt    ! ocean time-step index 
    367379      !! 
     380      INTEGER  ::   ji, jj, jk                 ! dummy loop indices 
     381      REAL(wp) ::   zcoef0, zuap, zvap, znad   ! temporary scalars 
     382      REAL(wp), POINTER, DIMENSION(:,:,:) ::  zhpi, zhpj 
     383      !!---------------------------------------------------------------------- 
     384      ! 
     385      CALL wrk_alloc( jpi,jpj,jpk, zhpi, zhpj ) 
     386      ! 
     387      IF( kt == nit000 ) THEN 
     388         IF(lwp) WRITE(numout,*) 
     389         IF(lwp) WRITE(numout,*) 'dyn:hpg_sco : hydrostatic pressure gradient trend' 
     390         IF(lwp) WRITE(numout,*) '~~~~~~~~~~~   s-coordinate case, OPA original scheme used' 
     391      ENDIF 
     392 
     393      ! Local constant initialization 
     394      zcoef0 = - grav * 0.5_wp 
     395      ! To use density and not density anomaly 
     396      IF ( lk_vvl ) THEN   ;     znad = 1._wp          ! Variable volume 
     397      ELSE                 ;     znad = 0._wp         ! Fixed volume 
     398      ENDIF 
     399 
     400      ! Surface value 
     401      DO jj = 2, jpjm1 
     402         DO ji = fs_2, fs_jpim1   ! vector opt. 
     403            ! hydrostatic pressure gradient along s-surfaces 
     404            zhpi(ji,jj,1) = zcoef0 / e1u(ji,jj) * ( fse3w(ji+1,jj  ,1) * ( znad + rhd(ji+1,jj  ,1) )   & 
     405               &                                  - fse3w(ji  ,jj  ,1) * ( znad + rhd(ji  ,jj  ,1) ) ) 
     406            zhpj(ji,jj,1) = zcoef0 / e2v(ji,jj) * ( fse3w(ji  ,jj+1,1) * ( znad + rhd(ji  ,jj+1,1) )   & 
     407               &                                  - fse3w(ji  ,jj  ,1) * ( znad + rhd(ji  ,jj  ,1) ) ) 
     408            ! s-coordinate pressure gradient correction 
     409            zuap = -zcoef0 * ( rhd   (ji+1,jj,1) + rhd   (ji,jj,1) + 2._wp * znad )   & 
     410               &           * ( fsde3w(ji+1,jj,1) - fsde3w(ji,jj,1) ) / e1u(ji,jj) 
     411            zvap = -zcoef0 * ( rhd   (ji,jj+1,1) + rhd   (ji,jj,1) + 2._wp * znad )   & 
     412               &           * ( fsde3w(ji,jj+1,1) - fsde3w(ji,jj,1) ) / e2v(ji,jj) 
     413            ! add to the general momentum trend 
     414            ua(ji,jj,1) = ua(ji,jj,1) + zhpi(ji,jj,1) + zuap 
     415            va(ji,jj,1) = va(ji,jj,1) + zhpj(ji,jj,1) + zvap 
     416         END DO 
     417      END DO 
     418 
     419      ! interior value (2=<jk=<jpkm1) 
     420      DO jk = 2, jpkm1 
     421         DO jj = 2, jpjm1 
     422            DO ji = fs_2, fs_jpim1   ! vector opt. 
     423               ! hydrostatic pressure gradient along s-surfaces 
     424               zhpi(ji,jj,jk) = zhpi(ji,jj,jk-1) + zcoef0 / e1u(ji,jj)   & 
     425                  &           * (  fse3w(ji+1,jj,jk) * ( rhd(ji+1,jj,jk) + rhd(ji+1,jj,jk-1) + 2*znad )   & 
     426                  &              - fse3w(ji  ,jj,jk) * ( rhd(ji  ,jj,jk) + rhd(ji  ,jj,jk-1) + 2*znad )  ) 
     427               zhpj(ji,jj,jk) = zhpj(ji,jj,jk-1) + zcoef0 / e2v(ji,jj)   & 
     428                  &           * (  fse3w(ji,jj+1,jk) * ( rhd(ji,jj+1,jk) + rhd(ji,jj+1,jk-1) + 2*znad )   & 
     429                  &              - fse3w(ji,jj  ,jk) * ( rhd(ji,jj,  jk) + rhd(ji,jj  ,jk-1) + 2*znad )  ) 
     430               ! s-coordinate pressure gradient correction 
     431               zuap = -zcoef0 * ( rhd   (ji+1,jj  ,jk) + rhd   (ji,jj,jk) + 2._wp * znad )   & 
     432                  &           * ( fsde3w(ji+1,jj  ,jk) - fsde3w(ji,jj,jk) ) / e1u(ji,jj) 
     433               zvap = -zcoef0 * ( rhd   (ji  ,jj+1,jk) + rhd   (ji,jj,jk) + 2._wp * znad )   & 
     434                  &           * ( fsde3w(ji  ,jj+1,jk) - fsde3w(ji,jj,jk) ) / e2v(ji,jj) 
     435               ! add to the general momentum trend 
     436               ua(ji,jj,jk) = ua(ji,jj,jk) + zhpi(ji,jj,jk) + zuap 
     437               va(ji,jj,jk) = va(ji,jj,jk) + zhpj(ji,jj,jk) + zvap 
     438            END DO 
     439         END DO 
     440      END DO 
     441      ! 
     442      CALL wrk_dealloc( jpi,jpj,jpk, zhpi, zhpj ) 
     443      ! 
     444   END SUBROUTINE hpg_sco 
     445 
     446   SUBROUTINE hpg_isf( kt ) 
     447      !!--------------------------------------------------------------------- 
     448      !!                  ***  ROUTINE hpg_sco  *** 
     449      !! 
     450      !! ** Method  :   s-coordinate case. Jacobian scheme. 
     451      !!      The now hydrostatic pressure gradient at a given level, jk, 
     452      !!      is computed by taking the vertical integral of the in-situ 
     453      !!      density gradient along the model level from the suface to that 
     454      !!      level. s-coordinates (ln_sco): a corrective term is added 
     455      !!      to the horizontal pressure gradient : 
     456      !!         zhpi = grav .....  + 1/e1u mi(rhd) di[ grav dep3w ] 
     457      !!         zhpj = grav .....  + 1/e2v mj(rhd) dj[ grav dep3w ] 
     458      !!      add it to the general momentum trend (ua,va). 
     459      !!         ua = ua - 1/e1u * zhpi 
     460      !!         va = va - 1/e2v * zhpj 
     461      !!      iceload is added and partial cell case are added to the top and bottom 
     462      !!       
     463      !! ** Action : - Update (ua,va) with the now hydrastatic pressure trend 
     464      !!---------------------------------------------------------------------- 
     465      INTEGER, INTENT(in) ::   kt    ! ocean time-step index 
     466      !! 
    368467      INTEGER  ::   ji, jj, jk, iku, ikv, ikt, iktp1i, iktp1j                 ! dummy loop indices 
    369468      REAL(wp) ::   zcoef0, zuap, zvap, znad, ze3wu, ze3wv, zuapint, zvapint, zhpjint, zhpiint, zdzwt, zdzwtjp1, zdzwtip1             ! temporary scalars 
    … …  
    379478     IF( kt == nit000 ) THEN 
    380479         IF(lwp) WRITE(numout,*) 
    381          IF(lwp) WRITE(numout,*) 'dyn:hpg_sco : hydrostatic pressure gradient trend' 
     480         IF(lwp) WRITE(numout,*) 'dyn:hpg_isf : hydrostatic pressure gradient trend for ice shelf' 
    382481         IF(lwp) WRITE(numout,*) '~~~~~~~~~~~   s-coordinate case, OPA original scheme used' 
    383482      ENDIF 
    … …  
    565664!================================================================================== 
    566665 
    567 # if defined key_vectopt_loop 
    568          jj = 1 
    569          DO ji = jpi+2, jpij-jpi-1   ! vector opt. (forced unrolling) 
    570 # else 
    571666      DO jj = 2, jpjm1 
    572667         DO ji = 2, jpim1 
    573 # endif 
    574668            iku = mbku(ji,jj) 
    575669            ikv = mbkv(ji,jj) 
    … …  
    598692               va(ji,jj,ikv)   =  va(ji,jj,ikv) + zhpj(ji,jj,ikv) + zvap 
    599693            END IF 
    600 # if ! defined key_vectopt_loop 
    601          END DO 
    602 # endif 
     694         END DO 
    603695      END DO 
    604696      
    … …  
    610702      CALL wrk_dealloc( jpi,jpj, ze3w, zp, zrhdtop_isf, zrhdtop_oce, ziceload, zdept, zpshpi, zpshpj) 
    611703      ! 
    612    END SUBROUTINE hpg_sco 
     704   END SUBROUTINE hpg_isf 
    613705 
    614706 
    … …  
    864956      REAL(wp), POINTER, DIMENSION(:,:,:) ::   zdept, zrhh 
    865957      REAL(wp), POINTER, DIMENSION(:,:,:) ::   zhpi, zu, zv, fsp, xsp, asp, bsp, csp, dsp 
     958      REAL(wp), POINTER, DIMENSION(:,:)   ::   zsshu_n, zsshv_n 
    866959      !!---------------------------------------------------------------------- 
    867960      ! 
    868961      CALL wrk_alloc( jpi,jpj,jpk, zhpi, zu, zv, fsp, xsp, asp, bsp, csp, dsp ) 
    869962      CALL wrk_alloc( jpi,jpj,jpk, zdept, zrhh ) 
     963      CALL wrk_alloc( jpi,jpj, zsshu_n, zsshv_n ) 
    870964      ! 
    871965      IF( kt == nit000 ) THEN 
    … …  
    9481042 
    9491043      ! Z coordinate of U(ji,jj,1:jpkm1) and V(ji,jj,1:jpkm1) 
     1044 
     1045      ! Prepare zsshu_n and zsshv_n 
    9501046      DO jj = 2, jpjm1 
    9511047        DO ji = 2, jpim1 
    952           zu(ji,jj,1) = - ( fse3u(ji,jj,1) - sshn(ji,jj) * znad)    ! probable bug: changed from sshu_n for ztilde compilation 
    953           zv(ji,jj,1) = - ( fse3v(ji,jj,1) - sshn(ji,jj) * znad)    ! probable bug: changed from sshv_n for ztilde compilation 
     1048          zsshu_n(ji,jj) = (e12u(ji,jj) * sshn(ji,jj) + e12u(ji+1, jj) * sshn(ji+1,jj)) * & 
     1049                         & r1_e12u(ji,jj) * umask(ji,jj,1) * 0.5_wp  
     1050          zsshv_n(ji,jj) = (e12v(ji,jj) * sshn(ji,jj) + e12v(ji+1, jj) * sshn(ji,jj+1)) * & 
     1051                         & r1_e12v(ji,jj) * vmask(ji,jj,1) * 0.5_wp  
     1052        END DO 
     1053      END DO 
     1054 
     1055      DO jj = 2, jpjm1 
     1056        DO ji = 2, jpim1 
     1057          zu(ji,jj,1) = - ( fse3u(ji,jj,1) - zsshu_n(ji,jj) * znad)  
     1058          zv(ji,jj,1) = - ( fse3v(ji,jj,1) - zsshv_n(ji,jj) * znad) 
    9541059        END DO 
    9551060      END DO 
    … …  
    11131218      CALL wrk_dealloc( jpi,jpj,jpk, zhpi, zu, zv, fsp, xsp, asp, bsp, csp, dsp ) 
    11141219      CALL wrk_dealloc( jpi,jpj,jpk, zdept, zrhh ) 
     1220      CALL wrk_dealloc( jpi,jpj, zsshu_n, zsshv_n ) 
    11151221      ! 
    11161222   END SUBROUTINE hpg_prj 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/DYN/dynnept.F90

    r5312 r5313  
    6969   !!---------------------------------------------------------------------- 
    7070 
     71   !! $Id$ 
    7172 CONTAINS 
    7273 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/DYN/dynspg.F90

    r5312 r5313  
    250250      IF( ( ioptio > 1 .AND. .NOT. lk_esopa ) .OR. ( ioptio == 0 .AND. .NOT. lk_c1d ) )   & 
    251251           &   CALL ctl_stop( ' Choose only one surface pressure gradient scheme with a key cpp' ) 
    252       IF( ( lk_dynspg_ts .OR. lk_dynspg_exp ) .AND. nn_isf .NE. 0 )   & 
     252      IF( ( lk_dynspg_ts .OR. lk_dynspg_exp ) .AND. ln_isfcav )   & 
    253253           &   CALL ctl_stop( ' dynspg_ts and dynspg_exp not tested with ice shelf cavity ' ) 
    254254      ! 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/DYN/dynspg_ts.F90

    r5312 r5313  
    2222   USE dom_oce         ! ocean space and time domain 
    2323   USE sbc_oce         ! surface boundary condition: ocean 
     24   USE sbcisf          ! ice shelf variable (fwfisf) 
    2425   USE dynspg_oce      ! surface pressure gradient variables 
    2526   USE phycst          ! physical constants 
    … …  
    453454      !                                         ! Surface net water flux and rivers 
    454455      IF (ln_bt_fw) THEN 
    455          zssh_frc(:,:) = zraur * ( emp(:,:) - rnf(:,:) ) 
     456         zssh_frc(:,:) = zraur * ( emp(:,:) - rnf(:,:) + rdivisf * fwfisf(:,:) ) 
    456457      ELSE 
    457          zssh_frc(:,:) = zraur * z1_2 * (emp(:,:) + emp_b(:,:) - rnf(:,:) - rnf_b(:,:)) 
     458         zssh_frc(:,:) = zraur * z1_2 * (  emp(:,:) + emp_b(:,:) - rnf(:,:) - rnf_b(:,:)   & 
     459                &                        + rdivisf * ( fwfisf(:,:) + fwfisf_b(:,:) )       ) 
    458460      ENDIF 
    459461#if defined key_asminc 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/DYN/dynzad.F90

    r5312 r5313  
    9595         END DO    
    9696      END DO 
    97       DO jj = 2, jpjm1              ! Surface and bottom values set to zero 
    98          DO ji = fs_2, fs_jpim1           ! vector opt. 
    99             zwuw(ji,jj, 1:miku(ji,jj) ) = 0._wp 
    100             zwvw(ji,jj, 1:mikv(ji,jj) ) = 0._wp 
    101             zwuw(ji,jj,jpk) = 0._wp 
    102             zwvw(ji,jj,jpk) = 0._wp 
    103          END DO   
    104       END DO 
     97      ! 
     98      ! Surface and bottom advective fluxes set to zero 
     99      IF ( ln_isfcav ) THEN 
     100         DO jj = 2, jpjm1 
     101            DO ji = fs_2, fs_jpim1           ! vector opt. 
     102               zwuw(ji,jj, 1:miku(ji,jj) ) = 0._wp 
     103               zwvw(ji,jj, 1:mikv(ji,jj) ) = 0._wp 
     104               zwuw(ji,jj,jpk) = 0._wp 
     105               zwvw(ji,jj,jpk) = 0._wp 
     106            END DO 
     107         END DO 
     108      ELSE 
     109         DO jj = 2, jpjm1         
     110            DO ji = fs_2, fs_jpim1           ! vector opt. 
     111               zwuw(ji,jj, 1 ) = 0._wp 
     112               zwvw(ji,jj, 1 ) = 0._wp 
     113               zwuw(ji,jj,jpk) = 0._wp 
     114               zwvw(ji,jj,jpk) = 0._wp 
     115            END DO   
     116         END DO 
     117      END IF 
    105118 
    106119      DO jk = 1, jpkm1              ! Vertical momentum advection at u- and v-points 
    … …  
    196209         END DO 
    197210      END DO 
    198  
    199       DO jj = 2, jpjm1                    ! Surface and bottom advective fluxes set to zero 
     211      ! 
     212      ! Surface and bottom advective fluxes set to zero 
     213      DO jj = 2, jpjm1         
    200214         DO ji = fs_2, fs_jpim1           ! vector opt. 
    201             zwuw(ji,jj, 1:miku(ji,jj) ) = 0._wp 
    202             zwvw(ji,jj, 1:mikv(ji,jj) ) = 0._wp 
     215            zwuw(ji,jj, 1 ) = 0._wp 
     216            zwvw(ji,jj, 1 ) = 0._wp 
    203217            zwuw(ji,jj,jpk) = 0._wp 
    204218            zwvw(ji,jj,jpk) = 0._wp 
    … …  
    228242            DO jj = 2, jpjm1                 ! vertical momentum advection at w-point 
    229243               DO ji = fs_2, fs_jpim1        ! vector opt. 
    230                   zwuw(ji,jj,jk) = ( zww(ji+1,jj  ,jk) + zww(ji,jj,jk) ) * ( zus(ji,jj,jk-1,jtn)-zus(ji,jj,jk,jtn) ) 
    231                   zwvw(ji,jj,jk) = ( zww(ji  ,jj+1,jk) + zww(ji,jj,jk) ) * ( zvs(ji,jj,jk-1,jtn)-zvs(ji,jj,jk,jtn) ) 
     244                  zwuw(ji,jj,jk) = ( zww(ji+1,jj  ,jk) + zww(ji,jj,jk) ) * ( zus(ji,jj,jk-1,jtn)-zus(ji,jj,jk,jtn) ) !* wumask(ji,jj,jk) 
     245                  zwvw(ji,jj,jk) = ( zww(ji  ,jj+1,jk) + zww(ji,jj,jk) ) * ( zvs(ji,jj,jk-1,jtn)-zvs(ji,jj,jk,jtn) ) !* wvmask(ji,jj,jk) 
    232246               END DO   
    233247            END DO    

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/DYN/dynzdf_imp.F90

    r5312 r5313  
    105105               avmu(ji,jj,ikbu+1) = -bfrua(ji,jj) * fse3uw(ji,jj,ikbu+1) 
    106106               avmv(ji,jj,ikbv+1) = -bfrva(ji,jj) * fse3vw(ji,jj,ikbv+1) 
    107                ikbu = miku(ji,jj)       ! ocean top level at u- and v-points  
    108                ikbv = mikv(ji,jj)       ! (first wet ocean u- and v-points) 
    109                IF (ikbu .GE. 2) avmu(ji,jj,ikbu) = -tfrua(ji,jj) * fse3uw(ji,jj,ikbu) 
    110                IF (ikbv .GE. 2) avmv(ji,jj,ikbv) = -tfrva(ji,jj) * fse3vw(ji,jj,ikbv) 
    111             END DO 
    112          END DO 
     107            END DO 
     108         END DO 
     109         IF ( ln_isfcav ) THEN 
     110            DO jj = 2, jpjm1 
     111               DO ji = 2, jpim1 
     112                  ikbu = miku(ji,jj)       ! ocean top level at u- and v-points  
     113                  ikbv = mikv(ji,jj)       ! (first wet ocean u- and v-points) 
     114                  IF (ikbu .GE. 2) avmu(ji,jj,ikbu) = -tfrua(ji,jj) * fse3uw(ji,jj,ikbu) 
     115                  IF (ikbv .GE. 2) avmv(ji,jj,ikbv) = -tfrva(ji,jj) * fse3vw(ji,jj,ikbv) 
     116               END DO 
     117            END DO 
     118         END IF 
    113119      ENDIF 
    114120 
    … …  
    145151               ua(ji,jj,ikbu) = ua(ji,jj,ikbu) + p2dt * bfrua(ji,jj) * ua_b(ji,jj) / ze3ua 
    146152               va(ji,jj,ikbv) = va(ji,jj,ikbv) + p2dt * bfrva(ji,jj) * va_b(ji,jj) / ze3va 
    147                ikbu = miku(ji,jj)         ! top ocean level at u- and v-points  
    148                ikbv = mikv(ji,jj)         ! (first wet ocean u- and v-points) 
    149                ze3ua =  ( 1._wp - r_vvl ) * fse3u_n(ji,jj,ikbu) + r_vvl   * fse3u_a(ji,jj,ikbu) 
    150                ze3va =  ( 1._wp - r_vvl ) * fse3v_n(ji,jj,ikbv) + r_vvl   * fse3v_a(ji,jj,ikbv) 
    151                ua(ji,jj,ikbu) = ua(ji,jj,ikbu) + p2dt * tfrua(ji,jj) * ua_b(ji,jj) / ze3ua 
    152                va(ji,jj,ikbv) = va(ji,jj,ikbv) + p2dt * tfrva(ji,jj) * va_b(ji,jj) / ze3va 
    153             END DO 
    154          END DO 
     153            END DO 
     154         END DO 
     155         IF ( ln_isfcav ) THEN 
     156            DO jj = 2, jpjm1         
     157               DO ji = fs_2, fs_jpim1   ! vector opt. 
     158                  ikbu = miku(ji,jj)         ! top ocean level at u- and v-points  
     159                  ikbv = mikv(ji,jj)         ! (first wet ocean u- and v-points) 
     160                  ze3ua =  ( 1._wp - r_vvl ) * fse3u_n(ji,jj,ikbu) + r_vvl   * fse3u_a(ji,jj,ikbu) 
     161                  ze3va =  ( 1._wp - r_vvl ) * fse3v_n(ji,jj,ikbv) + r_vvl   * fse3v_a(ji,jj,ikbv) 
     162                  ua(ji,jj,ikbu) = ua(ji,jj,ikbu) + p2dt * tfrua(ji,jj) * ua_b(ji,jj) / ze3ua 
     163                  va(ji,jj,ikbv) = va(ji,jj,ikbv) + p2dt * tfrva(ji,jj) * va_b(ji,jj) / ze3va 
     164               END DO 
     165            END DO 
     166         END IF 
    155167      ENDIF 
    156168#endif 
    … …  
    167179               ze3ua =  ( 1._wp - r_vvl ) * fse3u_n(ji,jj,jk) + r_vvl   * fse3u_a(ji,jj,jk)   ! after scale factor at T-point 
    168180               zcoef = - p2dt / ze3ua       
    169                zzwi          = zcoef * avmu (ji,jj,jk  ) / fse3uw(ji,jj,jk  ) 
    170                zwi(ji,jj,jk) = zzwi  * umask(ji,jj,jk) 
    171                zzws          = zcoef * avmu (ji,jj,jk+1) / fse3uw(ji,jj,jk+1)  
    172                zws(ji,jj,jk) = zzws  * umask(ji,jj,jk+1) 
    173                zwd(ji,jj,jk) = 1._wp - zwi(ji,jj,jk) - zzws 
     181               zzwi          = zcoef * avmu  (ji,jj,jk  ) / fse3uw(ji,jj,jk  ) 
     182               zwi(ji,jj,jk) = zzwi  * wumask(ji,jj,jk  ) 
     183               zzws          = zcoef * avmu  (ji,jj,jk+1) / fse3uw(ji,jj,jk+1)  
     184               zws(ji,jj,jk) = zzws  * wumask(ji,jj,jk+1) 
     185               zwd(ji,jj,jk) = 1._wp - zzwi - zzws 
    174186            END DO 
    175187         END DO 
    … …  
    198210      ! 
    199211      !==  First recurrence : Dk = Dk - Lk * Uk-1 / Dk-1   (increasing k)  == 
    200       DO jj = 2, jpjm1    
    201          DO ji = fs_2, fs_jpim1   ! vector opt. 
    202             DO jk = miku(ji,jj)+1, jpkm1 
     212      DO jk = 2, jpkm1 
     213         DO jj = 2, jpjm1    
     214            DO ji = fs_2, fs_jpim1   ! vector opt. 
    203215               zwd(ji,jj,jk) = zwd(ji,jj,jk) - zwi(ji,jj,jk) * zws(ji,jj,jk-1) / zwd(ji,jj,jk-1) 
    204216            END DO 
    … …  
    208220      DO jj = 2, jpjm1        !==  second recurrence:    SOLk = RHSk - Lk / Dk-1  Lk-1  == 
    209221         DO ji = fs_2, fs_jpim1   ! vector opt. 
    210             ze3ua =  ( 1._wp - r_vvl ) * fse3u_n(ji,jj,miku(ji,jj)) + r_vvl   * fse3u_a(ji,jj,miku(ji,jj))  
    211222#if defined key_dynspg_ts 
    212             ua(ji,jj,miku(ji,jj)) = ua(ji,jj,miku(ji,jj)) + p2dt * 0.5_wp * ( utau_b(ji,jj) + utau(ji,jj) )   & 
    213                &                                      / ( ze3ua * rau0 )  
     223            ze3ua =  ( 1._wp - r_vvl ) * fse3u_n(ji,jj,1) + r_vvl   * fse3u_a(ji,jj,1)  
     224            ua(ji,jj,1) = ua(ji,jj,1) + p2dt * 0.5_wp * ( utau_b(ji,jj) + utau(ji,jj) )   & 
     225               &                                      / ( ze3ua * rau0 ) * umask(ji,jj,1)  
    214226#else 
    215             ua(ji,jj,miku(ji,jj)) = ub(ji,jj,miku(ji,jj)) & 
    216                &                   + p2dt *(ua(ji,jj,miku(ji,jj)) +  0.5_wp * ( utau_b(ji,jj) + utau(ji,jj) )   & 
    217                &                                  / ( fse3u(ji,jj,miku(ji,jj)) * rau0     ) )  
    218 #endif 
    219             DO jk = miku(ji,jj)+1, jpkm1 
     227            ua(ji,jj,1) = ub(ji,jj,1) & 
     228               &                   + p2dt *(ua(ji,jj,1) +  0.5_wp * ( utau_b(ji,jj) + utau(ji,jj) )   & 
     229               &                                      / ( fse3u(ji,jj,1) * rau0     ) * umask(ji,jj,1) )  
     230#endif 
     231         END DO 
     232      END DO 
     233      DO jk = 2, jpkm1 
     234         DO jj = 2, jpjm1 
     235            DO ji = fs_2, fs_jpim1 
    220236#if defined key_dynspg_ts 
    221237               zrhs = ua(ji,jj,jk)   ! zrhs=right hand side 
    … …  
    231247         DO ji = fs_2, fs_jpim1   ! vector opt. 
    232248            ua(ji,jj,jpkm1) = ua(ji,jj,jpkm1) / zwd(ji,jj,jpkm1) 
    233             DO jk = jpk-2, miku(ji,jj), -1 
     249         END DO 
     250      END DO 
     251      DO jk = jpk-2, 1, -1 
     252         DO jj = 2, jpjm1 
     253            DO ji = fs_2, fs_jpim1 
    234254               ua(ji,jj,jk) = ( ua(ji,jj,jk) - zws(ji,jj,jk) * ua(ji,jj,jk+1) ) / zwd(ji,jj,jk) 
    235255            END DO 
    … …  
    260280               zcoef = - p2dt / ze3va 
    261281               zzwi          = zcoef * avmv (ji,jj,jk  ) / fse3vw(ji,jj,jk  ) 
    262                zwi(ji,jj,jk) =  zzwi * vmask(ji,jj,jk) 
     282               zwi(ji,jj,jk) =  zzwi * wvmask(ji,jj,jk) 
    263283               zzws          = zcoef * avmv (ji,jj,jk+1) / fse3vw(ji,jj,jk+1) 
    264                zws(ji,jj,jk) =  zzws * vmask(ji,jj,jk+1) 
    265                zwd(ji,jj,jk) = 1._wp - zwi(ji,jj,jk) - zzws 
     284               zws(ji,jj,jk) =  zzws * wvmask(ji,jj,jk+1) 
     285               zwd(ji,jj,jk) = 1._wp - zzwi - zzws 
    266286            END DO 
    267287         END DO 
    … …  
    290310      ! 
    291311      !==  First recurrence : Dk = Dk - Lk * Uk-1 / Dk-1   (increasing k)  == 
    292       DO jj = 2, jpjm1    
    293          DO ji = fs_2, fs_jpim1   ! vector opt. 
    294             DO jk = mikv(ji,jj)+1, jpkm1         
     312      DO jk = 2, jpkm1         
     313         DO jj = 2, jpjm1    
     314            DO ji = fs_2, fs_jpim1   ! vector opt. 
    295315               zwd(ji,jj,jk) = zwd(ji,jj,jk) - zwi(ji,jj,jk) * zws(ji,jj,jk-1) / zwd(ji,jj,jk-1) 
    296316            END DO 
    … …  
    300320      DO jj = 2, jpjm1        !==  second recurrence:    SOLk = RHSk - Lk / Dk-1  Lk-1  == 
    301321         DO ji = fs_2, fs_jpim1   ! vector opt. 
    302             ze3va =  ( 1._wp - r_vvl ) * fse3v_n(ji,jj,mikv(ji,jj)) + r_vvl   * fse3v_a(ji,jj,mikv(ji,jj))  
    303322#if defined key_dynspg_ts             
    304             va(ji,jj,mikv(ji,jj)) = va(ji,jj,mikv(ji,jj)) + p2dt * 0.5_wp * ( vtau_b(ji,jj) + vtau(ji,jj) )   & 
     323            ze3va =  ( 1._wp - r_vvl ) * fse3v_n(ji,jj,1) + r_vvl   * fse3v_a(ji,jj,1)  
     324            va(ji,jj,1) = va(ji,jj,1) + p2dt * 0.5_wp * ( vtau_b(ji,jj) + vtau(ji,jj) )   & 
    305325               &                                      / ( ze3va * rau0 )  
    306326#else 
    307             va(ji,jj,mikv(ji,jj)) = vb(ji,jj,mikv(ji,jj)) & 
    308                &                   + p2dt *(va(ji,jj,mikv(ji,jj)) +  0.5_wp * ( vtau_b(ji,jj) + vtau(ji,jj) )   & 
    309                &                                                       / ( fse3v(ji,jj,mikv(ji,jj)) * rau0     )  ) 
    310 #endif 
    311             DO jk = mikv(ji,jj)+1, jpkm1 
     327            va(ji,jj,1) = vb(ji,jj,1) & 
     328               &                   + p2dt *(va(ji,jj,1) +  0.5_wp * ( vtau_b(ji,jj) + vtau(ji,jj) )   & 
     329               &                                                       / ( fse3v(ji,jj,1) * rau0     )  ) 
     330#endif 
     331         END DO 
     332      END DO 
     333      DO jk = 2, jpkm1 
     334         DO jj = 2, jpjm1 
     335            DO ji = fs_2, fs_jpim1   ! vector opt. 
    312336#if defined key_dynspg_ts 
    313337               zrhs = va(ji,jj,jk)   ! zrhs=right hand side 
    … …  
    323347         DO ji = fs_2, fs_jpim1   ! vector opt. 
    324348            va(ji,jj,jpkm1) = va(ji,jj,jpkm1) / zwd(ji,jj,jpkm1) 
    325             DO jk = jpk-2, mikv(ji,jj), -1 
     349         END DO 
     350      END DO 
     351      DO jk = jpk-2, 1, -1 
     352         DO jj = 2, jpjm1 
     353            DO ji = fs_2, fs_jpim1 
    326354               va(ji,jj,jk) = ( va(ji,jj,jk) - zws(ji,jj,jk) * va(ji,jj,jk+1) ) / zwd(ji,jj,jk) 
    327355            END DO 
    … …  
    349377              avmu(ji,jj,ikbu+1) = 0.e0 
    350378              avmv(ji,jj,ikbv+1) = 0.e0 
    351               ikbu = miku(ji,jj)         ! ocean top level at u- and v-points  
    352               ikbv = mikv(ji,jj)         ! (first wet ocean u- and v-points) 
    353               IF (ikbu > 1) avmu(ji,jj,ikbu) = 0.e0 
    354               IF (ikbv > 1) avmv(ji,jj,ikbv) = 0.e0 
    355379           END DO 
    356380        END DO 
     381        IF (ln_isfcav) THEN 
     382           DO jj = 2, jpjm1 
     383              DO ji = 2, jpim1 
     384                 ikbu = miku(ji,jj)         ! ocean top level at u- and v-points  
     385                 ikbv = mikv(ji,jj)         ! (first wet ocean u- and v-points) 
     386                 IF (ikbu > 1) avmu(ji,jj,ikbu) = 0.e0 
     387                 IF (ikbv > 1) avmv(ji,jj,ikbv) = 0.e0 
     388              END DO 
     389           END DO 
     390        END IF 
    357391      ENDIF 
    358392      ! 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/FLO/florst.F90

    r5312 r5313  
    3636   !!---------------------------------------------------------------------- 
    3737   !! NEMO/OPA 3.2 , LODYC-IPSL  (2009) 
    38    !! $Header: 
     38   !! $Id$ 
    3939   !! This software is governed by the CeCILL licence see modipsl/doc/NEMO_CeCILL.txt  
    4040   !!---------------------------------------------------------------------- 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/FLO/flowri.F90

    r5312 r5313  
    5050   !!---------------------------------------------------------------------- 
    5151   !! NEMO/OPA 3.2 , LODYC-IPSL  (2009) 
    52    !! $Header: 
     52   !! $Id$ 
    5353   !! This software is governed by the CeCILL licence see modipsl/doc/NEMO_CeCILL.txt  
    5454   !!---------------------------------------------------------------------- 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/ICB/icbthm.F90

    r5312 r5313  
    3131   PUBLIC   icb_thm ! routine called in icbstp.F90 module 
    3232 
     33   !! $Id$ 
    3334CONTAINS 
    3435 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/IOM/iom.F90

    r5312 r5313  
    3333   USE icb_oce, ONLY :   nclasses, class_num       !  !: iceberg classes 
    3434#if defined key_lim3 
    35    USE par_ice 
     35   USE ice    , ONLY :   jpl 
    3636#elif defined key_lim2 
    3737   USE par_ice_2 
    … …  
    543543   END SUBROUTINE iom_g1d 
    544544 
    545    SUBROUTINE iom_g2d( kiomid, kdom, cdvar, pvar, ktime, kstart, kcount ) 
     545   SUBROUTINE iom_g2d( kiomid, kdom, cdvar, pvar, ktime, kstart, kcount, lrowattr ) 
    546546      INTEGER         , INTENT(in   )                           ::   kiomid    ! Identifier of the file 
    547547      INTEGER         , INTENT(in   )                           ::   kdom      ! Type of domain to be read 
    … …  
    551551      INTEGER         , INTENT(in   ), DIMENSION(2)  , OPTIONAL ::   kstart    ! start axis position of the reading  
    552552      INTEGER         , INTENT(in   ), DIMENSION(2)  , OPTIONAL ::   kcount    ! number of points in each axis 
     553      LOGICAL         , INTENT(in   )                , OPTIONAL ::   lrowattr  ! logical flag telling iom_get to 
     554                                                                               ! look for and use a file attribute 
     555                                                                               ! called open_ocean_jstart to set the start 
     556                                                                               ! value for the 2nd dimension (netcdf only) 
    553557      ! 
    554558      IF( kiomid > 0 ) THEN 
    555559         IF( iom_file(kiomid)%nfid > 0 ) CALL iom_get_123d( kiomid, kdom       , cdvar        , pv_r2d=pvar,   & 
    556               &                                                     ktime=ktime, kstart=kstart, kcount=kcount ) 
     560              &                                                     ktime=ktime, kstart=kstart, kcount=kcount, & 
     561              &                                                     lrowattr=lrowattr ) 
    557562      ENDIF 
    558563   END SUBROUTINE iom_g2d 
    559564 
    560    SUBROUTINE iom_g3d( kiomid, kdom, cdvar, pvar, ktime, kstart, kcount ) 
     565   SUBROUTINE iom_g3d( kiomid, kdom, cdvar, pvar, ktime, kstart, kcount, lrowattr ) 
    561566      INTEGER         , INTENT(in   )                             ::   kiomid    ! Identifier of the file 
    562567      INTEGER         , INTENT(in   )                             ::   kdom      ! Type of domain to be read 
    … …  
    566571      INTEGER         , INTENT(in   ), DIMENSION(3)    , OPTIONAL ::   kstart    ! start axis position of the reading  
    567572      INTEGER         , INTENT(in   ), DIMENSION(3)    , OPTIONAL ::   kcount    ! number of points in each axis 
     573      LOGICAL         , INTENT(in   )                  , OPTIONAL ::   lrowattr  ! logical flag telling iom_get to 
     574                                                                                 ! look for and use a file attribute 
     575                                                                                 ! called open_ocean_jstart to set the start 
     576                                                                                 ! value for the 2nd dimension (netcdf only) 
    568577      ! 
    569578      IF( kiomid > 0 ) THEN 
    570579         IF( iom_file(kiomid)%nfid > 0 ) CALL iom_get_123d( kiomid, kdom       , cdvar        , pv_r3d=pvar,   & 
    571               &                                                     ktime=ktime, kstart=kstart, kcount=kcount ) 
     580              &                                                     ktime=ktime, kstart=kstart, kcount=kcount, & 
     581              &                                                     lrowattr=lrowattr ) 
    572582      ENDIF 
    573583   END SUBROUTINE iom_g3d 
    … …  
    576586   SUBROUTINE iom_get_123d( kiomid, kdom  , cdvar ,   & 
    577587         &                  pv_r1d, pv_r2d, pv_r3d,   & 
    578          &                  ktime , kstart, kcount  ) 
     588         &                  ktime , kstart, kcount,   & 
     589         &                  lrowattr                ) 
    579590      !!----------------------------------------------------------------------- 
    580591      !!                  ***  ROUTINE  iom_get_123d  *** 
    … …  
    593604      INTEGER , DIMENSION(:)     , INTENT(in   ), OPTIONAL ::   kstart     ! start position of the reading in each axis  
    594605      INTEGER , DIMENSION(:)     , INTENT(in   ), OPTIONAL ::   kcount     ! number of points to be read in each axis 
     606      LOGICAL                    , INTENT(in   ), OPTIONAL ::   lrowattr   ! logical flag telling iom_get to 
     607                                                                           ! look for and use a file attribute 
     608                                                                           ! called open_ocean_jstart to set the start 
     609                                                                           ! value for the 2nd dimension (netcdf only) 
    595610      ! 
    596611      LOGICAL                        ::   llnoov      ! local definition to read overlap 
     612      LOGICAL                        ::   luse_jattr  ! local definition to read open_ocean_jstart file attribute 
     613      INTEGER                        ::   jstartrow   ! start point for 2nd dimension optionally set by file attribute 
    597614      INTEGER                        ::   jl          ! loop on number of dimension  
    598615      INTEGER                        ::   idom        ! type of domain 
    … …  
    604621      INTEGER                        ::   ix1, ix2, iy1, iy2   ! subdomain indexes 
    605622      INTEGER                        ::   ji, jj      ! loop counters 
    606       INTEGER                        ::   irankpv       !  
     623      INTEGER                        ::   irankpv     !  
    607624      INTEGER                        ::   ind1, ind2  ! substring index 
    608625      INTEGER, DIMENSION(jpmax_dims) ::   istart      ! starting point to read for each axis 
    … …  
    628645      IF( PRESENT(kstart) .AND. (.NOT. PRESENT(kcount)) ) CALL ctl_stop(trim(clinfo), 'kstart present needs kcount present') 
    629646      IF( PRESENT(kstart) .AND. idom /= jpdom_unknown   ) CALL ctl_stop(trim(clinfo), 'kstart present needs kdom = jpdom_unknown') 
     647 
     648      luse_jattr = .false. 
     649      IF( PRESENT(lrowattr) ) THEN 
     650         IF( lrowattr .AND. idom /= jpdom_data   ) CALL ctl_stop(trim(clinfo), 'lrowattr present and true needs kdom = jpdom_data') 
     651         IF( lrowattr .AND. idom == jpdom_data   ) luse_jattr = .true. 
     652      ENDIF 
     653      IF( luse_jattr ) THEN 
     654         SELECT CASE (iom_file(kiomid)%iolib) 
     655         CASE (jpioipsl, jprstdimg ) 
     656             CALL ctl_warn(trim(clinfo), 'lrowattr present and true but this only works with netcdf (jpnf90)') 
     657             luse_jattr = .false. 
     658         CASE (jpnf90   )    
     659             ! Ok 
     660         CASE DEFAULT     
     661            CALL ctl_stop( TRIM(clinfo)//' accepted IO library are only jpioipsl, jpnf90 and jprstdimg' ) 
     662         END SELECT 
     663      ENDIF 
    630664 
    631665      ! Search for the variable in the data base (eventually actualize data) 
    … …  
    701735            ELSE  
    702736               IF( .NOT. PRESENT(pv_r1d) ) THEN   !   not a 1D array 
    703                   IF(     idom == jpdom_data    ) THEN ; istart(1:2) = (/ mig(1), mjg(1) /)  ! icnt(1:2) done bellow 
    704                   ELSEIF( idom == jpdom_global  ) THEN ; istart(1:2) = (/ nimpp , njmpp  /)  ! icnt(1:2) done bellow 
     737                  IF(     idom == jpdom_data    ) THEN 
     738                     jstartrow = 1 
     739                     IF( luse_jattr ) THEN 
     740                        CALL iom_getatt(kiomid, 'open_ocean_jstart', jstartrow ) ! -999 is returned if the attribute is not found 
     741                        jstartrow = MAX(1,jstartrow) 
     742                     ENDIF 
     743                     istart(1:2) = (/ mig(1), mjg(1) + jstartrow - 1 /)  ! icnt(1:2) done below 
     744                  ELSEIF( idom == jpdom_global  ) THEN ; istart(1:2) = (/ nimpp , njmpp  /)  ! icnt(1:2) done below 
    705745                  ENDIF 
    706746                  ! we do not read the overlap                     -> we start to read at nldi, nldj 
    … …  
    12961336      zlatpira = (/ -19.0, -14.0,  -8.0, 0.0, 4.0, 8.0, 12.0, 15.0, 20.0 /) 
    12971337      CALL set_mooring( zlonpira, zlatpira ) 
     1338 
     1339      ! diaptr : zonal mean  
     1340      CALL dom_ngb( 180., 90., ix, iy, 'T' ) !  i-line that passes near the North Pole : Reference latitude (used in plots) 
     1341      CALL iom_set_domain_attr ('ptr', zoom_ibegin=ix, zoom_nj=jpjglo) 
     1342      CALL iom_update_file_name('ptr') 
     1343      ! 
    12981344       
    12991345   END SUBROUTINE set_xmlatt 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/LBC/mppini_2.h90

    r5312 r5313  
    4545      INTEGER ::  inum                        ! temporary logical unit 
    4646      INTEGER ::  idir                        ! temporary integers 
     47      INTEGER ::  jstartrow                   ! temporary integers 
    4748      INTEGER ::   ios                        ! Local integer output status for namelist read 
    4849      INTEGER ::   & 
    … …  
    100101      ! open the file 
    101102      ! Remember that at this level in the code, mpp is not yet initialized, so 
    102       ! the file must be open with jpdom_unknown, and kstart amd kcount forced  
     103      ! the file must be open with jpdom_unknown, and kstart and kcount forced  
     104      jstartrow = 1 
    103105      IF ( ln_zco ) THEN  
    104106         CALL iom_open ( 'bathy_level.nc', inum )   ! Level bathymetry 
    105          CALL iom_get ( inum, jpdom_unknown, 'Bathy_level', zdta, kstart=(/jpizoom,jpjzoom/), kcount=(/jpiglo,jpjglo/) ) 
     107          ! Optionally use a file attribute (open_ocean_jstart) to set a start row for reading from the global file 
     108          ! This allows the unextended grid bathymetry to be stored in the same file as the under ice-shelf extended bathymetry 
     109         CALL iom_getatt(inum, 'open_ocean_jstart', jstartrow ) ! -999 is returned if the attribute is not found 
     110         jstartrow = MAX(1,jstartrow) 
     111         CALL iom_get ( inum, jpdom_unknown, 'Bathy_level', zdta, kstart=(/jpizoom,jpjzoom+jstartrow-1/), kcount=(/jpiglo,jpjglo/) ) 
    106112      ELSE 
    107113         CALL iom_open ( 'bathy_meter.nc', inum )   ! Meter bathy in case of partial steps 
    108          CALL iom_get ( inum, jpdom_unknown, 'Bathymetry' , zdta, kstart=(/jpizoom,jpjzoom/), kcount=(/jpiglo,jpjglo/) ) 
     114         IF ( ln_isfcav ) THEN 
     115             CALL iom_get ( inum, jpdom_unknown, 'Bathymetry_isf' , zdta, kstart=(/jpizoom,jpjzoom/), kcount=(/jpiglo,jpjglo/) ) 
     116         ELSE 
     117             ! Optionally use a file attribute (open_ocean_jstart) to set a start row for reading from the global file 
     118             ! This allows the unextended grid bathymetry to be stored in the same file as the under ice-shelf extended bathymetry 
     119             CALL iom_getatt(inum, 'open_ocean_jstart', jstartrow ) ! -999 is returned if the attribute is not found 
     120             jstartrow = MAX(1,jstartrow) 
     121             CALL iom_get ( inum, jpdom_unknown, 'Bathymetry' , zdta, kstart=(/jpizoom,jpjzoom+jstartrow-1/)   & 
     122                &                                                   , kcount=(/jpiglo,jpjglo/) ) 
     123         ENDIF 
    109124      ENDIF 
    110125      CALL iom_close (inum) 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/LDF/ldfslp.F90

    r5312 r5313  
    142142            DO jj = 1, jpjm1 
    143143               DO ji = 1, jpim1 
    144 ! IF should be useless check zpshde (PM) 
    145                IF ( mbku(ji,jj) > 1 ) zgru(ji,jj,mbku(ji,jj)) = gru(ji,jj) 
    146                IF ( mbkv(ji,jj) > 1 ) zgrv(ji,jj,mbkv(ji,jj)) = grv(ji,jj) 
     144                  zgru(ji,jj,mbku(ji,jj)) = gru(ji,jj) 
     145                  zgrv(ji,jj,mbkv(ji,jj)) = grv(ji,jj) 
     146               END DO 
     147            END DO 
     148         ENDIF 
     149         IF( ln_zps .AND. ln_isfcav ) THEN           ! partial steps correction at the bottom ocean level 
     150            DO jj = 1, jpjm1 
     151               DO ji = 1, jpim1 
    147152               IF ( miku(ji,jj) > 1 ) zgru(ji,jj,miku(ji,jj)) = grui(ji,jj)  
    148153               IF ( mikv(ji,jj) > 1 ) zgrv(ji,jj,mikv(ji,jj)) = grvi(ji,jj) 
    … …  
    151156         ENDIF 
    152157         ! 
    153          zdzr(:,:,1) = 0._wp        !==   Local vertical density gradient at T-point   == !   (evaluated from N^2) 
    154          DO jk = 1, jpkm1 
     158         !==   Local vertical density gradient at T-point   == !   (evaluated from N^2) 
     159         ! interior value 
     160         DO jk = 2, jpkm1 
    155161            !                                ! zdzr = d/dz(prd)= - ( prd ) / grav * mk(pn2) -- at t point 
    156162            !                                !   trick: tmask(ik  )  = 0   =>   all pn2   = 0   =>   zdzr = 0 
    … …  
    162168         END DO 
    163169         ! surface initialisation  
    164          DO jj = 1, jpjm1 
    165             DO ji = 1, jpim1 
    166               zdzr(ji,jj,1:mikt(ji,jj)) = 0._wp 
    167             END DO 
    168          END DO 
     170         zdzr(:,:,1) = 0._wp  
     171         IF ( ln_isfcav ) THEN 
     172            ! if isf need to overwrite the interior value at at the first ocean point 
     173            DO jj = 1, jpjm1 
     174               DO ji = 1, jpim1 
     175                  zdzr(ji,jj,1:mikt(ji,jj)) = 0._wp 
     176               END DO 
     177            END DO 
     178         END IF 
    169179         ! 
    170180         !                          !==   Slopes just below the mixed layer   ==! 
    … …  
    175185         ! ===========================      | vslp = d/dj( prd ) / d/dz( prd ) 
    176186         ! 
    177          DO jj = 2, jpjm1 
    178             DO ji = fs_2, fs_jpim1   ! vector opt. 
    179                IF (miku(ji,jj) .GT. miku(ji+1,jj)) zhmlpu(ji,jj) = hmlpt(ji  ,jj) 
    180                IF (miku(ji,jj) .LT. miku(ji+1,jj)) zhmlpu(ji,jj) = hmlpt(ji+1,jj) 
    181                IF (miku(ji,jj) .EQ. miku(ji+1,jj)) zhmlpu(ji,jj) = MAX(hmlpt(ji  ,jj), hmlpt(ji+1,jj)) 
    182                IF (mikv(ji,jj) .GT. miku(ji,jj+1)) zhmlpv(ji,jj) = hmlpt(ji  ,jj) 
    183                IF (mikv(ji,jj) .LT. miku(ji,jj+1)) zhmlpv(ji,jj) = hmlpt(ji,jj+1) 
    184                IF (mikv(ji,jj) .EQ. miku(ji,jj+1)) zhmlpv(ji,jj) = MAX(hmlpt(ji,jj), hmlpt(ji,jj+1)) 
     187         IF ( ln_isfcav ) THEN 
     188            DO jj = 2, jpjm1 
     189               DO ji = fs_2, fs_jpim1   ! vector opt. 
     190                  IF (miku(ji,jj) .GT. miku(ji+1,jj)) zhmlpu(ji,jj) = MAX(hmlpt(ji  ,jj  ),                   5._wp) 
     191                  IF (miku(ji,jj) .LT. miku(ji+1,jj)) zhmlpu(ji,jj) = MAX(hmlpt(ji+1,jj  ),                   5._wp) 
     192                  IF (miku(ji,jj) .EQ. miku(ji+1,jj)) zhmlpu(ji,jj) = MAX(hmlpt(ji  ,jj  ), hmlpt(ji+1,jj  ), 5._wp) 
     193                  IF (mikv(ji,jj) .GT. miku(ji,jj+1)) zhmlpv(ji,jj) = MAX(hmlpt(ji  ,jj  ),                   5._wp) 
     194                  IF (mikv(ji,jj) .LT. miku(ji,jj+1)) zhmlpv(ji,jj) = MAX(hmlpt(ji  ,jj+1),                   5._wp) 
     195                  IF (mikv(ji,jj) .EQ. miku(ji,jj+1)) zhmlpv(ji,jj) = MAX(hmlpt(ji  ,jj  ), hmlpt(ji  ,jj+1), 5._wp) 
     196               ENDDO 
    185197            ENDDO 
    186          ENDDO 
     198         ELSE 
     199            DO jj = 2, jpjm1 
     200               DO ji = fs_2, fs_jpim1   ! vector opt. 
     201                  zhmlpu(ji,jj) = MAX(hmlpt(ji,jj), hmlpt(ji+1,jj  ), 5._wp) 
     202                  zhmlpv(ji,jj) = MAX(hmlpt(ji,jj), hmlpt(ji  ,jj+1), 5._wp) 
     203               ENDDO 
     204            ENDDO 
     205         END IF 
    187206         DO jk = 2, jpkm1                            !* Slopes at u and v points 
    188207            DO jj = 2, jpjm1 
    … …  
    198217                  zbv = MIN(  zbv, -100._wp* ABS( zav ) , -7.e+3_wp/fse3v(ji,jj,jk)* ABS( zav )  ) 
    199218                  !                                      ! uslp and vslp output in zwz and zww, resp. 
    200                   zfi = MAX( omlmask(ji,jj,jk), omlmask(ji+1,jj,jk) )  
    201                   zfj = MAX( omlmask(ji,jj,jk), omlmask(ji,jj+1,jk) )  
     219                  zfi = MAX( omlmask(ji,jj,jk), omlmask(ji+1,jj  ,jk) ) 
     220                  zfj = MAX( omlmask(ji,jj,jk), omlmask(ji  ,jj+1,jk) ) 
    202221                  ! thickness of water column between surface and level k at u/v point 
    203                   zdepu = 0.5_wp * (( fsdept(ji,jj,jk) + fsdept(ji+1,jj  ,jk) )                   & 
    204                              - 2 * MAX( risfdep(ji,jj), risfdep(ji+1,jj  ) )  & 
    205                              - fse3u(ji,jj,miku(ji,jj))                                         ) 
    206                   zdepv = 0.5_wp * (( fsdept(ji,jj,jk) + fsdept(ji  ,jj+1,jk) )                   & 
    207                              - 2 * MAX( risfdep(ji,jj), risfdep(ji,jj+1) ) & 
    208                              - fse3v(ji,jj,mikv(ji,jj))                                         ) 
    209                   zwz(ji,jj,jk) = ( 1. - zfi) * zau / ( zbu - zeps )                                              & 
    210                      &                 + zfi  * uslpml(ji,jj)                                                     & 
    211                      &                        * zdepu / MAX( zhmlpu(ji,jj), 5._wp ) 
    212                   zwz(ji,jj,jk) = zwz(ji,jj,jk) * umask(ji,jj,jk) * umask(ji,jj,jk-1) 
    213                   zww(ji,jj,jk) = ( 1. - zfj) * zav / ( zbv - zeps )                                              & 
    214                      &                 + zfj  * vslpml(ji,jj)                                                     & 
    215                      &                        * zdepv / MAX( zhmlpv(ji,jj), 5._wp )  
    216                   zww(ji,jj,jk) = zww(ji,jj,jk) * vmask(ji,jj,jk) * vmask(ji,jj,jk-1) 
     222                  zdepu = 0.5_wp * ( ( fsdept(ji,jj,jk) + fsdept(ji+1,jj  ,jk) )                              & 
     223                                   - 2 * MAX( risfdep(ji,jj), risfdep(ji+1,jj  ) ) - fse3u(ji,jj,miku(ji,jj)) ) 
     224                  zdepv = 0.5_wp * ( ( fsdept(ji,jj,jk) + fsdept(ji  ,jj+1,jk) )                              & 
     225                                   - 2 * MAX( risfdep(ji,jj), risfdep(ji  ,jj+1) ) - fse3v(ji,jj,mikv(ji,jj)) ) 
     226                  ! 
     227                  zwz(ji,jj,jk) = ( 1. - zfi) * zau / ( zbu - zeps )                                          & 
     228                     &                 + zfi  * uslpml(ji,jj) * zdepu / zhmlpu(ji,jj) 
     229                  zwz(ji,jj,jk) = zwz(ji,jj,jk) * wumask(ji,jj,jk) 
     230                  zww(ji,jj,jk) = ( 1. - zfj) * zav / ( zbv - zeps )                                          & 
     231                     &                 + zfj  * vslpml(ji,jj) * zdepv / zhmlpv(ji,jj)  
     232                  zww(ji,jj,jk) = zww(ji,jj,jk) * wvmask(ji,jj,jk) 
    217233                   
    218234                  
    … …  
    266282                  uslp(ji,jj,jk) = uslp(ji,jj,jk) * ( umask(ji,jj+1,jk) + umask(ji,jj-1,jk  ) ) * 0.5_wp   & 
    267283                     &                            * ( umask(ji,jj  ,jk) + umask(ji,jj  ,jk+1) ) * 0.5_wp   & 
    268                      &                            *   umask(ji,jj,jk-1) !* umask(ji,jj,jk) * umask(ji,jj,jk+1) 
     284                     &                            *   umask(ji,jj,jk-1) 
    269285                  vslp(ji,jj,jk) = vslp(ji,jj,jk) * ( vmask(ji+1,jj,jk) + vmask(ji-1,jj,jk  ) ) * 0.5_wp   & 
    270286                     &                            * ( vmask(ji  ,jj,jk) + vmask(ji  ,jj,jk+1) ) * 0.5_wp   & 
    271                      &                            *   vmask(ji,jj,jk-1) !* vmask(ji,jj,jk) * vmask(ji,jj,jk+1) 
     287                     &                            *   vmask(ji,jj,jk-1) 
    272288               END DO 
    273289            END DO 
    … …  
    282298               DO ji = fs_2, fs_jpim1   ! vector opt. 
    283299                  !                                  !* Local vertical density gradient evaluated from N^2 
    284                   zbw = zm1_2g * pn2 (ji,jj,jk) * ( prd (ji,jj,jk) + prd (ji,jj,jk-1) + 2. ) * tmask(ji,jj,jk) * tmask(ji,jj,jk-1) 
     300                  zbw = zm1_2g * pn2 (ji,jj,jk) * ( prd (ji,jj,jk) + prd (ji,jj,jk-1) + 2. ) * wmask(ji,jj,jk) 
    285301                  !                                  !* Slopes at w point 
    286302                  !                                        ! i- & j-gradient of density at w-points 
    … …  
    298314                  zbj = MIN( zbw , -100._wp* ABS( zaj ) , -7.e+3_wp/fse3w(ji,jj,jk)* ABS( zaj )  ) 
    299315                  !                                        ! wslpi and wslpj with ML flattening (output in zwz and zww, resp.) 
    300                   zfk = MAX( omlmask(ji,jj,jk), omlmask(ji,jj,jk-1) )    ! zfk=1 in the ML otherwise zfk=0 
     316                  zfk = MAX( omlmask(ji,jj,jk), omlmask(ji,jj,jk-1) )   ! zfk=1 in the ML otherwise zfk=0 
    301317                  zck = ( fsdepw(ji,jj,jk) - fsdepw(ji,jj,mikt(ji,jj) ) ) / MAX( hmlp(ji,jj), 10._wp ) 
    302318                  zwz(ji,jj,jk) = (  zai / ( zbi - zeps ) * ( 1._wp - zfk ) & 
    303                      &            + zck * wslpiml(ji,jj) * zfk  ) * tmask(ji,jj,jk) * tmask(ji,jj,jk-1) 
     319                     &            + zck * wslpiml(ji,jj) * zfk  ) * wmask(ji,jj,jk) 
    304320                  zww(ji,jj,jk) = (  zaj / ( zbj - zeps ) * ( 1._wp - zfk ) & 
    305                      &            + zck * wslpjml(ji,jj) * zfk  ) * tmask(ji,jj,jk) * tmask(ji,jj,jk-1) 
     321                     &            + zck * wslpjml(ji,jj) * zfk  ) * wmask(ji,jj,jk) 
    306322 
    307323!!gm  modif to suppress omlmask....  (as in Griffies operator) 
    … …  
    356372                  zck =   ( umask(ji,jj,jk) + umask(ji-1,jj,jk) )   & 
    357373                     &  * ( vmask(ji,jj,jk) + vmask(ji,jj-1,jk) ) * 0.25 
    358                   wslpi(ji,jj,jk) = wslpi(ji,jj,jk) * zck * tmask(ji,jj,jk-1) * tmask(ji,jj,jk) 
    359                   wslpj(ji,jj,jk) = wslpj(ji,jj,jk) * zck * tmask(ji,jj,jk-1) * tmask(ji,jj,jk) 
     374                  wslpi(ji,jj,jk) = wslpi(ji,jj,jk) * zck * wmask(ji,jj,jk) 
     375                  wslpj(ji,jj,jk) = wslpj(ji,jj,jk) * zck * wmask(ji,jj,jk) 
    360376               END DO 
    361377            END DO 
    … …  
    423439                  vslp(ji,jj,jk) = -1./e2v(ji,jj) * ( fsdept_b(ji,jj+1,jk) - fsdept_b(ji ,jj ,jk) ) * vmask(ji,jj,jk)  
    424440                  wslpi(ji,jj,jk) = -1./e1t(ji,jj) * ( fsdepw_b(ji+1,jj,jk) - fsdepw_b(ji-1,jj,jk) ) & 
    425                     &                              * tmask(ji,jj,jk) * tmask(ji,jj,jk-1) * 0.5  
     441                    &                              * wmask(ji,jj,jk) * 0.5  
    426442                  wslpj(ji,jj,jk) = -1./e2t(ji,jj) * ( fsdepw_b(ji,jj+1,jk) - fsdepw_b(ji,jj-1,jk) ) & 
    427                     &                              * tmask(ji,jj,jk) * tmask(ji,jj,jk-1) * 0.5  
     443                    &                              * wmask(ji,jj,jk) * 0.5  
    428444               END DO  
    429445            END DO  
    … …  
    736752            DO ji = 1, jpi 
    737753               ik = nmln(ji,jj) - 1 
    738                IF( jk <= ik .AND. jk >= mikt(ji,jj) ) THEN   ;   omlmask(ji,jj,jk) = 1._wp 
    739                ELSE                  ;   omlmask(ji,jj,jk) = 0._wp 
     754               IF( jk <= ik .AND. jk >= mikt(ji,jj) ) THEN 
     755                  omlmask(ji,jj,jk) = 1._wp 
     756               ELSE 
     757                  omlmask(ji,jj,jk) = 0._wp 
    740758               ENDIF 
    741759            END DO 
    … …  
    794812            zbj = MIN(  zbw , -100._wp* ABS( zaj ) , -7.e+3_wp/fse3w(ji,jj,ik)* ABS( zaj )  ) 
    795813            !                        !- i- & j-slope at w-points (wslpiml, wslpjml) 
    796             wslpiml(ji,jj) = zai / ( zbi - zeps ) * tmask (ji,jj,ik) 
    797             wslpjml(ji,jj) = zaj / ( zbj - zeps ) * tmask (ji,jj,ik) 
     814            wslpiml(ji,jj) = zai / ( zbi - zeps ) * wmask (ji,jj,ik) 
     815            wslpjml(ji,jj) = zaj / ( zbj - zeps ) * wmask (ji,jj,ik) 
    798816         END DO 
    799817      END DO 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/OBS/julian.F90

    r5312 r5313  
    2424      &   greg2jul            ! Convert date to relative time  
    2525   
     26   !! $Id$ 
    2627CONTAINS 
    2728  

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/SBC/fldread.F90

    r5312 r5313  
    6969   END TYPE FLD 
    7070 
    71    TYPE, PUBLIC ::   MAP_POINTER      !: Array of integer pointers to 1D arrays 
    72       INTEGER, POINTER   ::  ptr(:) 
     71   TYPE, PUBLIC ::   MAP_POINTER      !: Map from input data file to local domain 
     72      INTEGER, POINTER, DIMENSION(:)  ::  ptr           ! Array of integer pointers to 1D arrays 
     73      LOGICAL                         ::  ll_unstruc    ! Unstructured (T) or structured (F) boundary data file 
    7374   END TYPE MAP_POINTER 
    7475 
    … …  
    601602      ! 
    602603      IF( ASSOCIATED(map%ptr) ) THEN 
    603          IF( sdjf%ln_tint ) THEN   ;   CALL fld_map( sdjf%num, sdjf%clvar, sdjf%fdta(:,:,:,2), sdjf%nrec_a(1), map%ptr ) 
    604          ELSE                      ;   CALL fld_map( sdjf%num, sdjf%clvar, sdjf%fnow(:,:,:  ), sdjf%nrec_a(1), map%ptr ) 
     604         IF( sdjf%ln_tint ) THEN   ;   CALL fld_map( sdjf%num, sdjf%clvar, sdjf%fdta(:,:,:,2), sdjf%nrec_a(1), map ) 
     605         ELSE                      ;   CALL fld_map( sdjf%num, sdjf%clvar, sdjf%fnow(:,:,:  ), sdjf%nrec_a(1), map ) 
    605606         ENDIF 
    606607      ELSE IF( LEN(TRIM(sdjf%wgtname)) > 0 ) THEN 
    … …  
    672673      REAL(wp), DIMENSION(:,:,:), INTENT(out) ::   dta   ! output field on model grid (2 dimensional) 
    673674      INTEGER                   , INTENT(in ) ::   nrec    ! record number to read (ie time slice) 
    674       INTEGER,  DIMENSION(:)    , INTENT(in ) ::   map     ! global-to-local mapping indices 
     675      TYPE(MAP_POINTER)         , INTENT(in ) ::   map     ! global-to-local mapping indices 
    675676      !! 
    676677      INTEGER                                 ::   ipi      ! length of boundary data on local process 
    … …  
    693694#if defined key_bdy 
    694695      ipj = iom_file(num)%dimsz(2,idvar) 
    695       IF (ipj == 1) THEN ! we assume that this is a structured open boundary file 
     696      IF ( map%ll_unstruc) THEN ! unstructured open boundary data file 
    696697         dta_read => dta_global 
    697       ELSE 
     698      ELSE                      ! structured open boundary data file 
    698699         dta_read => dta_global2 
    699700      ENDIF 
    … …  
    708709      END SELECT 
    709710      ! 
    710       IF (ipj==1) THEN 
     711      IF ( map%ll_unstruc ) THEN ! unstructured open boundary data file 
    711712         DO ib = 1, ipi 
    712713            DO ik = 1, ipk 
    713                dta(ib,1,ik) =  dta_read(map(ib),1,ik) 
     714               dta(ib,1,ik) =  dta_read(map%ptr(ib),1,ik) 
    714715            END DO 
    715716         END DO 
    716       ELSE ! we assume that this is a structured open boundary file 
     717      ELSE                       ! structured open boundary data file 
    717718         DO ib = 1, ipi 
    718             jj=1+floor(REAL(map(ib)-1)/REAL(ilendta)) 
    719             ji=map(ib)-(jj-1)*ilendta 
     719            jj=1+floor(REAL(map%ptr(ib)-1)/REAL(ilendta)) 
     720            ji=map%ptr(ib)-(jj-1)*ilendta 
    720721            DO ik = 1, ipk 
    721722               dta(ib,1,ik) =  dta_read(ji,jj,ik) 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/SBC/sbc_ice.F90

    r5312 r5313  
    1616   USE sbc_oce          ! surface boundary condition: ocean 
    1717# if defined key_lim3 
    18    USE par_ice          ! LIM-3 parameters 
     18   USE ice              ! LIM-3 parameters 
    1919# endif 
    2020# if defined key_lim2 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/SBC/sbc_oce.F90

    r5312 r5313  
    9898   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   emp_tot           !: total E-P over ocean and ice                 [Kg/m2/s] 
    9999   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   fmmflx            !: freshwater budget: freezing/melting          [Kg/m2/s] 
    100    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   rnf    , rnf_b    !: river runoff   [Kg/m2/s]   
     100   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   rnf    , rnf_b    !: river runoff        [Kg/m2/s]   
     101   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   fwfisf , fwfisf_b !: ice shelf melting   [Kg/m2/s]   
    101102   !! 
    102103   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::  sbc_tsc, sbc_tsc_b  !: sbc content trend                      [K.m/s] jpi,jpj,jpts 
    … …  
    147148         &      sfx    (jpi,jpj) , sfx_b(jpi,jpj) , emp_tot(jpi,jpj), fmmflx(jpi,jpj), STAT=ierr(2) ) 
    148149         ! 
    149       ALLOCATE( rnf  (jpi,jpj) , sbc_tsc  (jpi,jpj,jpts) , qsr_hc  (jpi,jpj,jpk) ,     & 
    150          &      rnf_b(jpi,jpj) , sbc_tsc_b(jpi,jpj,jpts) , qsr_hc_b(jpi,jpj,jpk) , STAT=ierr(3) ) 
     150      ALLOCATE( fwfisf  (jpi,jpj), rnf  (jpi,jpj) , sbc_tsc  (jpi,jpj,jpts) , qsr_hc  (jpi,jpj,jpk) ,     & 
     151         &      fwfisf_b(jpi,jpj), rnf_b(jpi,jpj) , sbc_tsc_b(jpi,jpj,jpts) , qsr_hc_b(jpi,jpj,jpk) , STAT=ierr(3) ) 
    151152         ! 
    152153      ALLOCATE( tprecip(jpi,jpj) , sprecip(jpi,jpj) , fr_i(jpi,jpj) ,     & 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/SBC/sbcblk_clio.F90

    r5312 r5313  
    6262   LOGICAL ::   lbulk_init = .TRUE.               ! flag, bulk initialization done or not) 
    6363 
    64 #if ! defined key_lim3                           
    65    ! in namicerun with LIM3 
    6664   REAL(wp) ::   cai = 1.40e-3 ! best estimate of atm drag in order to get correct FS export in ORCA2-LIM 
    6765   REAL(wp) ::   cao = 1.00e-3 ! chosen by default  ==> should depends on many things...  !!gmto be updated 
    68 #endif 
    6966 
    7067   REAL(wp) ::   rdtbs2      !:    

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/SBC/sbccpl.F90

    r5312 r5313  
    2424   USE phycst          ! physical constants 
    2525#if defined key_lim3 
    26    USE par_ice         ! ice parameters 
    2726   USE ice             ! ice variables 
    2827#endif 
    … …  
    12001199            ENDDO 
    12011200         ELSE 
     1201            qns_tot(:,:   ) = qns_tot(:,:) + zicefr(:,:) * frcv(jpr_qnsice)%z3(:,:,1) 
    12021202            DO jl=1,jpl 
    1203                qns_tot(:,:   ) = qns_tot(:,:) + zicefr(:,:) * frcv(jpr_qnsice)%z3(:,:,1) 
    12041203               qns_ice(:,:,jl) = frcv(jpr_qnsice)%z3(:,:,1) 
    12051204            ENDDO 
    … …  
    12591258            ENDDO 
    12601259         ELSE 
     1260            qsr_tot(:,:   ) = qsr_tot(:,:) + zicefr(:,:) * frcv(jpr_qsrice)%z3(:,:,1) 
    12611261            DO jl=1,jpl 
    1262                qsr_tot(:,:   ) = qsr_tot(:,:) + zicefr(:,:) * frcv(jpr_qsrice)%z3(:,:,1) 
    12631262               qsr_ice(:,:,jl) = frcv(jpr_qsrice)%z3(:,:,1) 
    12641263            ENDDO 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/SBC/sbcfwb.F90

    r5312 r5313  
    88   !!            3.0  ! 2006-08  (G. Madec)  Surface module 
    99   !!            3.2  ! 2009-07  (C. Talandier) emp mean s spread over erp area  
     10   !!            3.6  ! 2014-11  (P. Mathiot  ) add ice shelf melting 
    1011   !!---------------------------------------------------------------------- 
    1112 
    … …  
    8889         ! 
    8990         IF( kn_fwb == 3 .AND. nn_sssr /= 2 )   CALL ctl_stop( 'sbc_fwb: nn_fwb = 3 requires nn_sssr = 2, we stop ' ) 
    90          ! 
    91          area = glob_sum( e1e2t(:,:) )           ! interior global domain surface 
     91         IF( kn_fwb == 3 .AND. ln_isfcav    )   CALL ctl_stop( 'sbc_fwb: nn_fwb = 3 with ln_isfcav = .TRUE. not working, we stop ' ) 
     92         ! 
     93         area = glob_sum( e1e2t(:,:) * tmask(:,:,1))           ! interior global domain surface 
     94         ! isf cavities are excluded because it can feedback to the melting with generation of inhibition of plumes 
     95         ! and in case of no melt, it can generate HSSW. 
    9296         ! 
    9397#if ! defined key_lim2 &&  ! defined key_lim3 && ! defined key_cice 
    … …  
    106110            z_fwf = glob_sum( e1e2t(:,:) * ( emp(:,:) - rnf(:,:) + rdivisf * fwfisf(:,:) -  snwice_fmass(:,:) ) ) / area   ! sum over the global domain 
    107111            zcoef = z_fwf * rcp 
    108             emp(:,:) = emp(:,:) - z_fwf  
    109             qns(:,:) = qns(:,:) + zcoef * sst_m(:,:) ! account for change to the heat budget due to fw correction 
     112            emp(:,:) = emp(:,:) - z_fwf              * tmask(:,:,1) 
     113            qns(:,:) = qns(:,:) + zcoef * sst_m(:,:) * tmask(:,:,1) ! account for change to the heat budget due to fw correction 
    110114         ENDIF 
    111115         ! 
    … …  
    138142         IF( MOD( kt-1, kn_fsbc ) == 0 ) THEN         ! correct the freshwater fluxes 
    139143            zcoef = fwfold * rcp 
    140             emp(:,:) = emp(:,:) + fwfold 
    141             qns(:,:) = qns(:,:) - zcoef * sst_m(:,:) ! account for change to the heat budget due to fw correction 
     144            emp(:,:) = emp(:,:) + fwfold             * tmask(:,:,1) 
     145            qns(:,:) = qns(:,:) - zcoef * sst_m(:,:) * tmask(:,:,1) ! account for change to the heat budget due to fw correction 
    142146         ENDIF 
    143147         ! 
    … …  
    158162            zsurf_pos = glob_sum( e1e2t(:,:)*ztmsk_pos(:,:) ) 
    159163            !                                                  ! fwf global mean (excluding ocean to ice/snow exchanges)  
    160             z_fwf     = glob_sum( e1e2t(:,:) * ( emp(:,:) - rnf(:,:) - snwice_fmass(:,:) ) ) / area 
     164            z_fwf     = glob_sum( e1e2t(:,:) * ( emp(:,:) - rnf(:,:) + rdivisf * fwfisf(:,:) - snwice_fmass(:,:) ) ) / area 
    161165            !             
    162166            IF( z_fwf < 0._wp ) THEN         ! spread out over >0 erp area to increase evaporation 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/SBC/sbcice_cice.F90

    r5312 r5313  
    4040# if defined key_cice4 
    4141   USE ice_flux, only: strax,stray,strocnx,strocny,frain,fsnow,  & 
     42                strocnxT,strocnyT,                               &  
    4243                sst,sss,uocn,vocn,ss_tltx,ss_tlty,fsalt_gbm,     & 
    4344                fresh_gbm,fhocn_gbm,fswthru_gbm,frzmlt,          & 
    … …  
    4849#else 
    4950   USE ice_flux, only: strax,stray,strocnx,strocny,frain,fsnow,  & 
     51                strocnxT,strocnyT,                               &  
    5052                sst,sss,uocn,vocn,ss_tltx,ss_tlty,fsalt_ai,     & 
    5153                fresh_ai,fhocn_ai,fswthru_ai,frzmlt,          & 
    … …  
    9496#  include "domzgr_substitute.h90" 
    9597 
     98   !! $Id$ 
    9699CONTAINS 
    97100 
    … …  
    560563! Combine wind stress and ocean-ice stress 
    561564! [Note that fr_iu hasn't yet been updated, so still from start of CICE timestep] 
     565! strocnx and strocny already weighted by ice fraction in CICE so not done here  
    562566 
    563567      utau(:,:)=(1.0-fr_iu(:,:))*utau(:,:)-ss_iou(:,:) 
    564568      vtau(:,:)=(1.0-fr_iv(:,:))*vtau(:,:)-ss_iov(:,:)      
     569  
     570! Also need ice/ocean stress on T points so that taum can be updated  
     571! This interpolation is already done in CICE so best to use those values  
     572      CALL cice2nemo(strocnxT,ztmp1,'T',-1.)  
     573      CALL cice2nemo(strocnyT,ztmp2,'T',-1.)  
     574  
     575! Update taum with modulus of ice-ocean stress  
     576! strocnxT and strocnyT are not weighted by ice fraction in CICE so must be done here  
     577taum(:,:)=(1.0-fr_i(:,:))*taum(:,:)+fr_i(:,:)*SQRT(ztmp1**2. + ztmp2**2.)  
    565578 
    566579! Freshwater fluxes  
    … …  
    10831096   !!   Default option           Dummy module         NO CICE sea-ice model 
    10841097   !!---------------------------------------------------------------------- 
     1098   !! $Id$ 
    10851099CONTAINS 
    10861100 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/SBC/sbcice_lim.F90

    r5312 r5313  
    1919   !!---------------------------------------------------------------------- 
    2020   !!   sbc_ice_lim  : sea-ice model time-stepping and update ocean sbc over ice-covered area 
    21    !!   lim_ctl       : alerts in case of ice model crash 
    22    !!   lim_prt_state : ice control print at a given grid point 
    2321   !!---------------------------------------------------------------------- 
    2422   USE oce             ! ocean dynamics and tracers 
    2523   USE dom_oce         ! ocean space and time domain 
    26    USE par_ice         ! sea-ice parameters 
    2724   USE ice             ! LIM-3: ice variables 
    28    USE iceini          ! LIM-3: ice initialisation 
     25   USE thd_ice         ! LIM-3: thermodynamical variables 
    2926   USE dom_ice         ! LIM-3: ice domain 
    3027 
    … …  
    4138   USE limtrp          ! Ice transport 
    4239   USE limthd          ! Ice thermodynamics 
    43    USE limitd_th       ! Thermodynamics on ice thickness distribution  
    4440   USE limitd_me       ! Mechanics on ice thickness distribution 
    4541   USE limsbc          ! sea surface boundary condition 
    … …  
    4743   USE limwri          ! Ice outputs 
    4844   USE limrst          ! Ice restarts 
    49    USE limupdate1       ! update of global variables 
    50    USE limupdate2       ! update of global variables 
     45   USE limupdate1      ! update of global variables 
     46   USE limupdate2      ! update of global variables 
    5147   USE limvar          ! Ice variables switch 
     48 
     49   USE limmsh          ! LIM mesh 
     50   USE limistate       ! LIM initial state 
     51   USE limthd_sal      ! LIM ice thermodynamics: salinity 
    5252 
    5353   USE c1d             ! 1D vertical configuration 
    … …  
    6060   USE prtctl          ! Print control 
    6161   USE lib_fortran     !  
     62   USE limctl 
    6263 
    6364#if defined key_bdy  
    … …  
    6970 
    7071   PUBLIC sbc_ice_lim  ! routine called by sbcmod.F90 
    71    PUBLIC lim_prt_state 
     72   PUBLIC sbc_lim_init ! routine called by sbcmod.F90 
    7273    
    7374   !! * Substitutions 
    … …  
    106107      INTEGER, INTENT(in) ::   kblk    ! type of bulk (=3 CLIO, =4 CORE, =5 COUPLED) 
    107108      !! 
    108       INTEGER  ::   jl      ! dummy loop index 
    109       REAL(wp) ::   zcoef   ! local scalar 
     109      INTEGER  ::   jl                 ! dummy loop index 
    110110      REAL(wp), POINTER, DIMENSION(:,:,:)   ::   zalb_os, zalb_cs  ! ice albedo under overcast/clear sky 
    111111      REAL(wp), POINTER, DIMENSION(:,:,:)   ::   zalb_ice          ! mean ice albedo (for coupled) 
    … …  
    114114      IF( nn_timing == 1 )  CALL timing_start('sbc_ice_lim') 
    115115 
    116       IF( kt == nit000 ) THEN 
    117          IF(lwp) WRITE(numout,*) 
    118          IF(lwp) WRITE(numout,*) 'sbc_ice_lim : update ocean surface boudary condition'  
    119          IF(lwp) WRITE(numout,*) '~~~~~~~~~~~   via Louvain la Neuve Ice Model (LIM-3) time stepping' 
    120          ! 
    121          CALL ice_init 
    122          ! 
    123          IF( ln_nicep ) THEN      ! control print at a given point 
    124             jiindx = 15    ;   jjindx =  44 
    125             IF(lwp) WRITE(numout,*) ' The debugging point is : jiindx : ',jiindx, ' jjindx : ',jjindx 
    126          ENDIF 
    127       ENDIF 
    128  
    129       !                                        !----------------------! 
    130       IF( MOD( kt-1, nn_fsbc ) == 0 ) THEN     !  Ice time-step only  ! 
    131          !                                     !----------------------! 
    132          !                                           !  Bulk Formulae ! 
    133          !                                           !----------------! 
    134          ! 
    135          u_oce(:,:) = ssu_m(:,:) * umask(:,:,1)                     ! mean surface ocean current at ice velocity point 
    136          v_oce(:,:) = ssv_m(:,:) * vmask(:,:,1)                    ! (C-grid dynamics :  U- & V-points as the ocean) 
    137          ! 
    138          t_bo(:,:) = ( eos_fzp( sss_m ) +  rt0 ) * tmask(:,:,1) + rt0 * ( 1. - tmask(:,:,1) )  ! masked sea surface freezing temperature [Kelvin] 
    139          !                                                                                  ! (set to rt0 over land) 
    140          !                                           ! Ice albedo 
    141          CALL wrk_alloc( jpi,jpj,jpl, zalb_os, zalb_cs, zalb_ice )       
    142  
     116      IF( MOD( kt-1, nn_fsbc ) == 0 ) THEN     !  Ice time-step only 
     117         !-----------------------!                                            
     118         ! --- Bulk Formulae --- !                                            
     119         !-----------------------! 
     120         u_oce(:,:) = ssu_m(:,:) * umask(:,:,1)      ! mean surface ocean current at ice velocity point 
     121         v_oce(:,:) = ssv_m(:,:) * vmask(:,:,1)      ! (C-grid dynamics :  U- & V-points as the ocean) 
     122          
     123         ! masked sea surface freezing temperature [Kelvin] (set to rt0 over land) 
     124         t_bo(:,:) = ( eos_fzp( sss_m ) + rt0 ) * tmask(:,:,1) + rt0 * ( 1._wp - tmask(:,:,1) )   
     125         !                                                                                       
     126         ! Ice albedo 
     127         CALL wrk_alloc( jpi,jpj,jpl, zalb_os, zalb_cs, zalb_ice ) 
    143128         CALL albedo_ice( t_su, ht_i, ht_s, zalb_cs, zalb_os )  ! cloud-sky and overcast-sky ice albedos 
    144129 
     130         ! CORE and COUPLED bulk formulations 
    145131         SELECT CASE( kblk ) 
    146          CASE( jp_core , jp_cpl )   ! CORE and COUPLED bulk formulations 
     132         CASE( jp_core , jp_cpl ) 
    147133 
    148134            ! albedo depends on cloud fraction because of non-linear spectral effects 
    … …  
    153139         END SELECT 
    154140          
    155          !                                           ! Mask sea ice surface temperature 
     141         ! Mask sea ice surface temperature (set to rt0 over land) 
    156142         DO jl = 1, jpl 
    157             t_su(:,:,jl) = t_su(:,:,jl) +  rt0 * ( 1. - tmask(:,:,1) ) 
     143            t_su(:,:,jl) = t_su(:,:,jl) * tmask(:,:,1) + rt0 * ( 1._wp - tmask(:,:,1) ) 
    158144         END DO 
    159145      
    … …  
    191177            CALL sbc_cpl_ice_tau( utau_ice , vtau_ice ) 
    192178 
    193             ! MV -> seb  
    194 !           CALL sbc_cpl_ice_flx( p_frld=ato_i, palbi=zalb_ice, psst=sst_m, pist=t_su    ) 
    195  
    196 !           IF( nn_limflx == 2 )   CALL ice_lim_flx( t_su, zalb_ice, qns_ice, qsr_ice ,   & 
    197 !              &                                           dqns_ice, qla_ice, dqla_ice, nn_limflx ) 
    198 !           ! Latent heat flux is forced to 0 in coupled : 
    199 !           !  it is included in qns (non-solar heat flux) 
    200 !           qla_ice  (:,:,:) = 0._wp 
    201 !           dqla_ice (:,:,:) = 0._wp 
    202             ! END MV -> seb 
    203             ! 
    204179         END SELECT 
    205180          
    206          !                                           !----------------------! 
    207          !                                           ! LIM-3  time-stepping ! 
    208          !                                           !----------------------! 
    209          !  
     181         !------------------------------! 
     182         ! --- LIM-3 main time-step --- ! 
     183         !------------------------------! 
    210184         numit = numit + nn_fsbc                     ! Ice model time step 
    211          ! 
    212          !                                           ! Store previous ice values 
    213          a_i_b  (:,:,:)   = a_i  (:,:,:)     ! ice area 
    214          e_i_b  (:,:,:,:) = e_i  (:,:,:,:)   ! ice thermal energy 
    215          v_i_b  (:,:,:)   = v_i  (:,:,:)     ! ice volume 
    216          v_s_b  (:,:,:)   = v_s  (:,:,:)     ! snow volume  
    217          e_s_b  (:,:,:,:) = e_s  (:,:,:,:)   ! snow thermal energy 
    218          smv_i_b(:,:,:)   = smv_i(:,:,:)     ! salt content 
    219          oa_i_b (:,:,:)   = oa_i (:,:,:)     ! areal age content 
    220          u_ice_b(:,:)     = u_ice(:,:) 
    221          v_ice_b(:,:)     = v_ice(:,:) 
    222  
    223          ! salt, heat and mass fluxes 
    224          sfx    (:,:) = 0._wp   ; 
    225          sfx_bri(:,:) = 0._wp   ;  
    226          sfx_sni(:,:) = 0._wp   ;   sfx_opw(:,:) = 0._wp 
    227          sfx_bog(:,:) = 0._wp   ;   sfx_dyn(:,:) = 0._wp 
    228          sfx_bom(:,:) = 0._wp   ;   sfx_sum(:,:) = 0._wp 
    229          sfx_res(:,:) = 0._wp 
    230  
    231          wfx_snw(:,:) = 0._wp   ;   wfx_ice(:,:) = 0._wp 
    232          wfx_sni(:,:) = 0._wp   ;   wfx_opw(:,:) = 0._wp 
    233          wfx_bog(:,:) = 0._wp   ;   wfx_dyn(:,:) = 0._wp 
    234          wfx_bom(:,:) = 0._wp   ;   wfx_sum(:,:) = 0._wp 
    235          wfx_res(:,:) = 0._wp   ;   wfx_sub(:,:) = 0._wp 
    236          wfx_spr(:,:) = 0._wp   ;    
    237  
    238          hfx_in (:,:) = 0._wp   ;   hfx_out(:,:) = 0._wp 
    239          hfx_thd(:,:) = 0._wp   ;    
    240          hfx_snw(:,:) = 0._wp   ;   hfx_opw(:,:) = 0._wp 
    241          hfx_bog(:,:) = 0._wp   ;   hfx_dyn(:,:) = 0._wp 
    242          hfx_bom(:,:) = 0._wp   ;   hfx_sum(:,:) = 0._wp 
    243          hfx_res(:,:) = 0._wp   ;   hfx_sub(:,:) = 0._wp 
    244          hfx_spr(:,:) = 0._wp   ;   hfx_dif(:,:) = 0._wp  
    245          hfx_err(:,:) = 0._wp   ;   hfx_err_rem(:,:) = 0._wp 
    246  
    247                           CALL lim_rst_opn( kt )     ! Open Ice restart file 
    248          ! 
    249          IF( ln_nicep )   CALL lim_prt_state( kt, jiindx, jjindx, 1, ' - Beginning the time step - ' )   ! control print 
     185         !                                                    
     186         CALL sbc_lim_bef                   ! Store previous ice values 
     187 
     188         CALL sbc_lim_diag0                 ! set diag of mass, heat and salt fluxes to 0 
     189          
     190         CALL lim_rst_opn( kt )             ! Open Ice restart file 
     191         ! 
    250192         ! ---------------------------------------------- 
    251193         ! ice dynamics and transport (except in 1D case) 
    252194         ! ---------------------------------------------- 
    253195         IF( .NOT. lk_c1d ) THEN 
    254                           CALL lim_dyn( kt )              ! Ice dynamics    ( rheology/dynamics ) 
    255                           CALL lim_trp( kt )              ! Ice transport   ( Advection/diffusion ) 
    256                           CALL lim_var_glo2eqv            ! equivalent variables, requested for rafting 
    257          IF( ln_nicep )   CALL lim_prt_state( kt, jiindx, jjindx,-1, ' - ice dyn & trp - ' )   ! control print 
    258                           CALL lim_itd_me                 ! Mechanical redistribution ! (ridging/rafting) 
    259                           CALL lim_var_agg( 1 )  
     196             
     197            CALL lim_dyn( kt )              ! Ice dynamics    ( rheology/dynamics ) 
     198             
     199            CALL lim_trp( kt )              ! Ice transport   ( Advection/diffusion ) 
     200             
     201            IF( nn_monocat /= 2 ) CALL lim_itd_me  ! Mechanical redistribution ! (ridging/rafting) 
     202 
    260203#if defined key_bdy 
    261                           ! bdy ice thermo  
    262                           CALL lim_var_glo2eqv            ! equivalent variables 
    263                           CALL bdy_ice_lim( kt ) 
    264                           CALL lim_itd_me_zapsmall 
    265                           CALL lim_var_agg(1) 
    266          IF( ln_nicep )   CALL lim_prt_state( kt, jiindx, jjindx, 1, ' - ice thermo bdy - ' )   ! control print 
     204            CALL bdy_ice_lim( kt )         ! bdy ice thermo  
     205            IF( ln_icectl )   CALL lim_prt( kt, iiceprt, jiceprt, 1, ' - ice thermo bdy - ' ) 
    267206#endif 
    268                           CALL lim_update1 
     207            CALL lim_update1( kt ) 
     208             
    269209         ENDIF 
    270 !                         !- Change old values for new values 
    271                           u_ice_b(:,:)     = u_ice(:,:) 
    272                           v_ice_b(:,:)     = v_ice(:,:) 
    273                           a_i_b  (:,:,:)   = a_i  (:,:,:) 
    274                           v_s_b  (:,:,:)   = v_s  (:,:,:) 
    275                           v_i_b  (:,:,:)   = v_i  (:,:,:) 
    276                           e_s_b  (:,:,:,:) = e_s  (:,:,:,:) 
    277                           e_i_b  (:,:,:,:) = e_i  (:,:,:,:) 
    278                           oa_i_b (:,:,:)   = oa_i (:,:,:) 
    279                           smv_i_b(:,:,:)   = smv_i(:,:,:) 
     210          
     211         CALL sbc_lim_bef                  ! Store previous ice values 
    280212  
    281213         ! ---------------------------------------------- 
    282          ! ice thermodynamic 
     214         ! ice thermodynamics 
    283215         ! ---------------------------------------------- 
    284                           CALL lim_var_glo2eqv            ! equivalent variables 
    285                           CALL lim_var_agg(1)             ! aggregate ice categories 
    286                           ! previous lead fraction and ice volume for flux calculations 
    287                           pfrld(:,:)   = 1._wp - at_i(:,:) 
    288                           phicif(:,:)  = vt_i(:,:) 
    289  
    290                           ! MV -> seb 
    291                           SELECT CASE( kblk ) 
    292                              CASE ( jp_cpl ) 
    293                              CALL sbc_cpl_ice_flx( p_frld=pfrld, palbi=zalb_ice, psst=sst_m, pist=t_su    ) 
    294                              IF( nn_limflx == 2 )   CALL ice_lim_flx( t_su, zalb_ice, qns_ice, qsr_ice ,   & 
    295                           &                                           dqns_ice, qla_ice, dqla_ice, nn_limflx ) 
    296                            ! Latent heat flux is forced to 0 in coupled : 
    297                            !  it is included in qns (non-solar heat flux) 
    298                              qla_ice  (:,:,:) = 0._wp 
    299                              dqla_ice (:,:,:) = 0._wp 
    300                           END SELECT 
    301                           ! END MV -> seb 
    302                           ! 
    303                           CALL lim_var_bv                 ! bulk brine volume (diag) 
    304                           CALL lim_thd( kt )              ! Ice thermodynamics  
    305                           zcoef = rdt_ice /rday           !  Ice natural aging 
    306                           oa_i(:,:,:) = oa_i(:,:,:) + a_i(:,:,:) * zcoef 
    307          IF( ln_nicep )   CALL lim_prt_state( kt, jiindx, jjindx, 1, ' - ice thermodyn. - ' )   ! control print 
    308                           CALL lim_itd_th( kt )           !  Remap ice categories, lateral accretion  ! 
    309                           CALL lim_var_agg( 1 )           ! requested by limupdate 
    310                           CALL lim_update2                ! Global variables update 
    311  
    312                           CALL lim_var_glo2eqv            ! equivalent variables (outputs) 
    313                           CALL lim_var_agg(2)             ! aggregate ice thickness categories 
    314          IF( ln_nicep )   CALL lim_prt_state( kt, jiindx, jjindx, 2, ' - Final state - ' )   ! control print 
    315          ! 
    316                           CALL lim_sbc_flx( kt )     ! Update surface ocean mass, heat and salt fluxes 
    317          ! 
    318          IF( ln_nicep )   CALL lim_prt_state( kt, jiindx, jjindx, 3, ' - Final state lim_sbc - ' )   ! control print 
    319          ! 
    320          !                                           ! Diagnostics and outputs  
    321          IF (ln_limdiaout) CALL lim_diahsb 
    322  
    323                           CALL lim_wri( 1  )              ! Ice outputs  
    324  
     216         CALL lim_var_agg(1) 
     217          
     218         ! previous lead fraction and ice volume for flux calculations 
     219         pfrld(:,:)   = 1._wp - at_i(:,:) 
     220         phicif(:,:)  = vt_i(:,:) 
     221          
     222         SELECT CASE( kblk ) 
     223         CASE ( jp_cpl ) 
     224            CALL sbc_cpl_ice_flx( p_frld=pfrld, palbi=zalb_ice, psst=sst_m, pist=t_su    ) 
     225            IF( nn_limflx == 2 )   CALL ice_lim_flx( t_su, zalb_ice, qns_ice, qsr_ice ,   & 
     226               &                                           dqns_ice, qla_ice, dqla_ice, nn_limflx ) 
     227            ! Latent heat flux is forced to 0 in coupled: it is included in qns (non-solar heat flux) 
     228            qla_ice  (:,:,:) = 0._wp 
     229            dqla_ice (:,:,:) = 0._wp 
     230         END SELECT 
     231         ! 
     232         CALL lim_thd( kt )                         ! Ice thermodynamics  
     233          
     234         CALL lim_update2( kt )                     ! Corrections 
     235         ! 
     236         CALL lim_sbc_flx( kt )                     ! Update surface ocean mass, heat and salt fluxes 
     237         ! 
     238         IF(ln_limdiaout) CALL lim_diahsb           ! Diagnostics and outputs  
     239          
     240         CALL lim_wri( 1 )                          ! Ice outputs  
     241          
    325242         IF( kt == nit000 .AND. ln_rstart )   & 
    326             &             CALL iom_close( numrir )        ! clem: close input ice restart file 
    327          ! 
    328          IF( lrst_ice )   CALL lim_rst_write( kt )        ! Ice restart file  
    329                           CALL lim_var_glo2eqv            ! ??? 
    330          ! 
    331          IF( ln_nicep )   CALL lim_ctl( kt )              ! alerts in case of model crash 
     243            &             CALL iom_close( numrir )  ! close input ice restart file 
     244         ! 
     245         IF( lrst_ice )   CALL lim_rst_write( kt )  ! Ice restart file  
     246         ! 
     247         IF( ln_icectl )  CALL lim_ctl( kt )        ! alerts in case of model crash 
    332248         ! 
    333249         CALL wrk_dealloc( jpi,jpj,jpl, zalb_os, zalb_cs, zalb_ice ) 
    334250         ! 
    335       ENDIF                                    ! End sea-ice time step only 
    336  
    337       !                                        !--------------------------! 
    338       !                                        !  at all ocean time step  ! 
    339       !                                        !--------------------------! 
    340       !                                                
    341       !                                              ! Update surface ocean stresses (only in ice-dynamic case) 
    342       !                                                   ! otherwise the atm.-ocean stresses are used everywhere 
     251      ENDIF   ! End sea-ice time step only 
     252 
     253      !--------------------------------! 
     254      ! --- at all ocean time step --- ! 
     255      !--------------------------------! 
     256      ! Update surface ocean stresses (only in ice-dynamic case) 
     257      !    otherwise the atm.-ocean stresses are used everywhere 
    343258      IF( ln_limdyn )     CALL lim_sbc_tau( kt, ub(:,:,1), vb(:,:,1) )  ! using before instantaneous surf. currents 
    344259!!gm   remark, the ocean-ice stress is not saved in ice diag call above .....  find a solution!!! 
    345  
    346260      ! 
    347261      IF( nn_timing == 1 )  CALL timing_stop('sbc_ice_lim') 
    … …  
    349263   END SUBROUTINE sbc_ice_lim 
    350264    
     265 
     266   SUBROUTINE sbc_lim_init 
     267      !!---------------------------------------------------------------------- 
     268      !!                  ***  ROUTINE sbc_lim_init  *** 
     269      !! 
     270      !! ** purpose :   Allocate all the dynamic arrays of the LIM-3 modules 
     271      !!---------------------------------------------------------------------- 
     272      INTEGER :: ierr 
     273      !!---------------------------------------------------------------------- 
     274      IF(lwp) WRITE(numout,*) 
     275      IF(lwp) WRITE(numout,*) 'sbc_ice_lim : update ocean surface boudary condition'  
     276      IF(lwp) WRITE(numout,*) '~~~~~~~~~~~   via Louvain la Neuve Ice Model (LIM-3) time stepping' 
     277      ! 
     278                                       ! Open the reference and configuration namelist files and namelist output file  
     279      CALL ctl_opn( numnam_ice_ref, 'namelist_ice_ref',    'OLD',     'FORMATTED', 'SEQUENTIAL', -1, numout, lwp )  
     280      CALL ctl_opn( numnam_ice_cfg, 'namelist_ice_cfg',    'OLD',     'FORMATTED', 'SEQUENTIAL', -1, numout, lwp ) 
     281      IF(lwm) CALL ctl_opn( numoni, 'output.namelist.ice', 'UNKNOWN', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp, 1 ) 
     282 
     283      CALL ice_run                     ! set some ice run parameters 
     284      ! 
     285      !                                ! Allocate the ice arrays 
     286      ierr =        ice_alloc        ()      ! ice variables 
     287      ierr = ierr + dom_ice_alloc    ()      ! domain 
     288      ierr = ierr + sbc_ice_alloc    ()      ! surface forcing 
     289      ierr = ierr + thd_ice_alloc    ()      ! thermodynamics 
     290      ierr = ierr + lim_itd_me_alloc ()      ! ice thickness distribution - mechanics 
     291      ! 
     292      IF( lk_mpp    )   CALL mpp_sum( ierr ) 
     293      IF( ierr /= 0 )   CALL ctl_stop('STOP', 'sbc_lim_init : unable to allocate ice arrays') 
     294      ! 
     295      !                                ! adequation jpk versus ice/snow layers/categories 
     296      IF( jpl > jpk .OR. (nlay_i+1) > jpk .OR. nlay_s > jpk )   & 
     297         &      CALL ctl_stop( 'STOP',                          & 
     298         &     'sbc_lim_init: the 3rd dimension of workspace arrays is too small.',   & 
     299         &     'use more ocean levels or less ice/snow layers/categories.' ) 
     300      ! 
     301      CALL lim_itd_init                ! ice thickness distribution initialization 
     302      ! 
     303      CALL lim_thd_init                ! set ice thermodynics parameters 
     304      ! 
     305      CALL lim_thd_sal_init            ! set ice salinity parameters 
     306      ! 
     307      CALL lim_msh                     ! ice mesh initialization 
     308      ! 
     309      CALL lim_itd_me_init             ! ice thickness distribution initialization for mecanical deformation 
     310      !                                ! Initial sea-ice state 
     311      IF( .NOT. ln_rstart ) THEN              ! start from rest: sea-ice deduced from sst 
     312         numit = 0 
     313         numit = nit000 - 1 
     314         CALL lim_istate 
     315      ELSE                                    ! start from a restart file 
     316         CALL lim_rst_read 
     317         numit = nit000 - 1 
     318      ENDIF 
     319      CALL lim_var_agg(1) 
     320      CALL lim_var_glo2eqv 
     321      ! 
     322      CALL lim_sbc_init                 ! ice surface boundary condition    
     323      ! 
     324      fr_i(:,:)     = at_i(:,:)         ! initialisation of sea-ice fraction 
     325      tn_ice(:,:,:) = t_su(:,:,:)       ! initialisation of surface temp for coupled simu 
     326      ! 
     327      nstart = numit  + nn_fsbc       
     328      nitrun = nitend - nit000 + 1  
     329      nlast  = numit  + nitrun  
     330      ! 
     331      IF( nstock == 0 )   nstock = nlast + 1 
     332      ! 
     333   END SUBROUTINE sbc_lim_init 
     334 
     335 
     336   SUBROUTINE ice_run 
     337      !!------------------------------------------------------------------- 
     338      !!                  ***  ROUTINE ice_run *** 
     339      !!                  
     340      !! ** Purpose :   Definition some run parameter for ice model 
     341      !! 
     342      !! ** Method  :   Read the namicerun namelist and check the parameter  
     343      !!              values called at the first timestep (nit000) 
     344      !! 
     345      !! ** input   :   Namelist namicerun 
     346      !!------------------------------------------------------------------- 
     347      INTEGER  ::   ios                 ! Local integer output status for namelist read 
     348      NAMELIST/namicerun/ jpl, nlay_i, nlay_s, cn_icerst_in, cn_icerst_out,   & 
     349         &                ln_limdyn, rn_amax, ln_limdiahsb, ln_limdiaout, ln_icectl, iiceprt, jiceprt   
     350      !!------------------------------------------------------------------- 
     351      !                     
     352      REWIND( numnam_ice_ref )              ! Namelist namicerun in reference namelist : Parameters for ice 
     353      READ  ( numnam_ice_ref, namicerun, IOSTAT = ios, ERR = 901) 
     354901   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namicerun in reference namelist', lwp ) 
     355 
     356      REWIND( numnam_ice_cfg )              ! Namelist namicerun in configuration namelist : Parameters for ice 
     357      READ  ( numnam_ice_cfg, namicerun, IOSTAT = ios, ERR = 902 ) 
     358902   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namicerun in configuration namelist', lwp ) 
     359      IF(lwm) WRITE ( numoni, namicerun ) 
     360      ! 
     361      ! 
     362      IF(lwp) THEN                        ! control print 
     363         WRITE(numout,*) 
     364         WRITE(numout,*) 'ice_run : ice share parameters for dynamics/advection/thermo of sea-ice' 
     365         WRITE(numout,*) ' ~~~~~~' 
     366         WRITE(numout,*) '   number of ice  categories                               = ', jpl 
     367         WRITE(numout,*) '   number of ice  layers                                   = ', nlay_i 
     368         WRITE(numout,*) '   number of snow layers                                   = ', nlay_s 
     369         WRITE(numout,*) '   switch for ice dynamics (1) or not (0)      ln_limdyn   = ', ln_limdyn 
     370         WRITE(numout,*) '   maximum ice concentration                               = ', rn_amax  
     371         WRITE(numout,*) '   Diagnose heat/salt budget or not          ln_limdiahsb  = ', ln_limdiahsb 
     372         WRITE(numout,*) '   Output   heat/salt budget or not          ln_limdiaout  = ', ln_limdiaout 
     373         WRITE(numout,*) '   control prints in ocean.out for (i,j)=(iiceprt,jiceprt) = ', ln_icectl 
     374         WRITE(numout,*) '   i-index for control prints (ln_icectl=true)             = ', iiceprt 
     375         WRITE(numout,*) '   j-index for control prints (ln_icectl=true)             = ', jiceprt 
     376      ENDIF 
     377      ! 
     378      ! sea-ice timestep and inverse 
     379      rdt_ice   = nn_fsbc * rdttra(1)   
     380      r1_rdtice = 1._wp / rdt_ice  
     381 
     382      ! inverse of nlay_i and nlay_s 
     383      r1_nlay_i = 1._wp / REAL( nlay_i, wp ) 
     384      r1_nlay_s = 1._wp / REAL( nlay_s, wp ) 
     385      ! 
     386#if defined key_bdy 
     387      IF( lwp .AND. ln_limdiahsb )  CALL ctl_warn('online conservation check activated but it does not work with BDY') 
     388#endif 
     389      ! 
     390   END SUBROUTINE ice_run 
     391 
     392 
     393   SUBROUTINE lim_itd_init 
     394      !!------------------------------------------------------------------ 
     395      !!                ***  ROUTINE lim_itd_init *** 
     396      !! 
     397      !! ** Purpose :   Initializes the ice thickness distribution 
     398      !! ** Method  :   ... 
     399      !! ** input   :   Namelist namiceitd 
     400      !!------------------------------------------------------------------- 
     401      INTEGER  ::   ios                 ! Local integer output status for namelist read 
     402      NAMELIST/namiceitd/ nn_catbnd, rn_himean 
     403      ! 
     404      INTEGER  ::   jl                   ! dummy loop index 
     405      REAL(wp) ::   zc1, zc2, zc3, zx1   ! local scalars 
     406      REAL(wp) ::   zhmax, znum, zden, zalpha ! 
     407      !!------------------------------------------------------------------ 
     408      ! 
     409      REWIND( numnam_ice_ref )              ! Namelist namiceitd in reference namelist : Parameters for ice 
     410      READ  ( numnam_ice_ref, namiceitd, IOSTAT = ios, ERR = 903) 
     411903   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namiceitd in reference namelist', lwp ) 
     412 
     413      REWIND( numnam_ice_cfg )              ! Namelist namiceitd in configuration namelist : Parameters for ice 
     414      READ  ( numnam_ice_cfg, namiceitd, IOSTAT = ios, ERR = 904 ) 
     415904   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namiceitd in configuration namelist', lwp ) 
     416      IF(lwm) WRITE ( numoni, namiceitd ) 
     417      ! 
     418      ! 
     419      IF(lwp) THEN                        ! control print 
     420         WRITE(numout,*) 
     421         WRITE(numout,*) 'ice_itd : ice cat distribution' 
     422         WRITE(numout,*) ' ~~~~~~' 
     423         WRITE(numout,*) '   shape of ice categories distribution                          nn_catbnd = ', nn_catbnd 
     424         WRITE(numout,*) '   mean ice thickness in the domain (only active if nn_catbnd=2) rn_himean = ', rn_himean 
     425      ENDIF 
     426 
     427      !---------------------------------- 
     428      !- Thickness categories boundaries  
     429      !---------------------------------- 
     430      IF(lwp) WRITE(numout,*) 
     431      IF(lwp) WRITE(numout,*) 'lim_itd_init : Initialization of ice cat distribution ' 
     432      IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~' 
     433 
     434      hi_max(:) = 0._wp 
     435 
     436      SELECT CASE ( nn_catbnd  )        
     437                                   !---------------------- 
     438         CASE (1)                  ! tanh function (CICE) 
     439                                   !---------------------- 
     440         zc1 =  3._wp / REAL( jpl, wp ) 
     441         zc2 = 10._wp * zc1 
     442         zc3 =  3._wp 
     443 
     444         DO jl = 1, jpl 
     445            zx1 = REAL( jl-1, wp ) / REAL( jpl, wp ) 
     446            hi_max(jl) = hi_max(jl-1) + zc1 + zc2 * (1._wp + TANH( zc3 * (zx1 - 1._wp ) ) ) 
     447         END DO 
     448 
     449                                   !---------------------- 
     450         CASE (2)                  ! h^(-alpha) function 
     451                                   !---------------------- 
     452         zalpha = 0.05             ! exponent of the transform function 
     453 
     454         zhmax  = 3.*rn_himean 
     455 
     456         DO jl = 1, jpl  
     457            znum = jpl * ( zhmax+1 )**zalpha 
     458            zden = ( jpl - jl ) * ( zhmax+1 )**zalpha + jl 
     459            hi_max(jl) = ( znum / zden )**(1./zalpha) - 1 
     460         END DO 
     461 
     462      END SELECT 
     463 
     464      DO jl = 1, jpl 
     465         hi_mean(jl) = ( hi_max(jl) + hi_max(jl-1) ) * 0.5_wp 
     466      END DO 
     467 
     468      ! Set hi_max(jpl) to a big value to ensure that all ice is thinner than hi_max(jpl) 
     469      hi_max(jpl) = 99._wp 
     470 
     471      IF(lwp) WRITE(numout,*) ' Thickness category boundaries ' 
     472      IF(lwp) WRITE(numout,*) ' hi_max ', hi_max(0:jpl) 
     473      ! 
     474   END SUBROUTINE lim_itd_init 
     475 
    351476    
    352       SUBROUTINE ice_lim_flx( ptn_ice, palb_ice, pqns_ice, pqsr_ice,   & 
     477   SUBROUTINE ice_lim_flx( ptn_ice, palb_ice, pqns_ice, pqsr_ice,   & 
    353478         &                          pdqn_ice, pqla_ice, pdql_ice, k_limflx ) 
    354479      !!--------------------------------------------------------------------- 
    355       !!                  ***  ROUTINE sbc_ice_lim  *** 
     480      !!                  ***  ROUTINE ice_lim_flx  *** 
    356481      !!                    
    357482      !! ** Purpose :   update the ice surface boundary condition by averaging and / or 
    … …  
    428553      ! 
    429554   END SUBROUTINE ice_lim_flx 
    430     
    431     
    432    SUBROUTINE lim_ctl( kt ) 
    433       !!----------------------------------------------------------------------- 
    434       !!                   ***  ROUTINE lim_ctl ***  
    435       !!                  
    436       !! ** Purpose :   Alerts in case of model crash 
    437       !!------------------------------------------------------------------- 
    438       INTEGER, INTENT(in) ::   kt      ! ocean time step 
    439       INTEGER  ::   ji, jj, jk,  jl   ! dummy loop indices 
    440       INTEGER  ::   inb_altests       ! number of alert tests (max 20) 
    441       INTEGER  ::   ialert_id         ! number of the current alert 
    442       REAL(wp) ::   ztmelts           ! ice layer melting point 
    443       CHARACTER (len=30), DIMENSION(20)      ::   cl_alname   ! name of alert 
    444       INTEGER           , DIMENSION(20)      ::   inb_alp     ! number of alerts positive 
    445       !!------------------------------------------------------------------- 
    446  
    447       inb_altests = 10 
    448       inb_alp(:)  =  0 
    449  
    450       ! Alert if incompatible volume and concentration 
    451       ialert_id = 2 ! reference number of this alert 
    452       cl_alname(ialert_id) = ' Incompat vol and con         '    ! name of the alert 
    453  
    454       DO jl = 1, jpl 
    455          DO jj = 1, jpj 
    456             DO ji = 1, jpi 
    457                IF(  v_i(ji,jj,jl) /= 0._wp   .AND.   a_i(ji,jj,jl) == 0._wp   ) THEN 
    458                   !WRITE(numout,*) ' ALERTE 2 :   Incompatible volume and concentration ' 
    459                   !WRITE(numout,*) ' at_i     ', at_i(ji,jj) 
    460                   !WRITE(numout,*) ' Point - category', ji, jj, jl 
    461                   !WRITE(numout,*) ' a_i *** a_i_b   ', a_i      (ji,jj,jl), a_i_b  (ji,jj,jl) 
    462                   !WRITE(numout,*) ' v_i *** v_i_b   ', v_i      (ji,jj,jl), v_i_b  (ji,jj,jl) 
    463                   !WRITE(numout,*) ' d_a_i_thd/trp   ', d_a_i_thd(ji,jj,jl), d_a_i_trp(ji,jj,jl) 
    464                   !WRITE(numout,*) ' d_v_i_thd/trp   ', d_v_i_thd(ji,jj,jl), d_v_i_trp(ji,jj,jl) 
    465                   inb_alp(ialert_id) = inb_alp(ialert_id) + 1 
    466                ENDIF 
    467             END DO 
    468          END DO 
    469       END DO 
    470  
    471       ! Alerte if very thick ice 
    472       ialert_id = 3 ! reference number of this alert 
    473       cl_alname(ialert_id) = ' Very thick ice               ' ! name of the alert 
    474       jl = jpl  
    475       DO jj = 1, jpj 
    476          DO ji = 1, jpi 
    477             IF(   ht_i(ji,jj,jl)  >  50._wp   ) THEN 
    478                !CALL lim_prt_state( kt, ji, jj, 2, ' ALERTE 3 :   Very thick ice ' ) 
    479                inb_alp(ialert_id) = inb_alp(ialert_id) + 1 
    480             ENDIF 
    481          END DO 
    482       END DO 
    483  
    484       ! Alert if very fast ice 
    485       ialert_id = 4 ! reference number of this alert 
    486       cl_alname(ialert_id) = ' Very fast ice               ' ! name of the alert 
    487       DO jj = 1, jpj 
    488          DO ji = 1, jpi 
    489             IF(   MAX( ABS( u_ice(ji,jj) ), ABS( v_ice(ji,jj) ) ) > 1.5  .AND.  & 
    490                &  at_i(ji,jj) > 0._wp   ) THEN 
    491                !CALL lim_prt_state( kt, ji, jj, 1, ' ALERTE 4 :   Very fast ice ' ) 
    492                !WRITE(numout,*) ' ice strength             : ', strength(ji,jj) 
    493                !WRITE(numout,*) ' oceanic stress utau      : ', utau(ji,jj)  
    494                !WRITE(numout,*) ' oceanic stress vtau      : ', vtau(ji,jj) 
    495                !WRITE(numout,*) ' sea-ice stress utau_ice  : ', utau_ice(ji,jj)  
    496                !WRITE(numout,*) ' sea-ice stress vtau_ice  : ', vtau_ice(ji,jj) 
    497                !WRITE(numout,*) ' oceanic speed u          : ', u_oce(ji,jj) 
    498                !WRITE(numout,*) ' oceanic speed v          : ', v_oce(ji,jj) 
    499                !WRITE(numout,*) ' sst                      : ', sst_m(ji,jj) 
    500                !WRITE(numout,*) ' sss                      : ', sss_m(ji,jj) 
    501                !WRITE(numout,*)  
    502                inb_alp(ialert_id) = inb_alp(ialert_id) + 1 
    503             ENDIF 
    504          END DO 
    505       END DO 
    506  
    507       ! Alert if there is ice on continents 
    508       ialert_id = 6 ! reference number of this alert 
    509       cl_alname(ialert_id) = ' Ice on continents           ' ! name of the alert 
    510       DO jj = 1, jpj 
    511          DO ji = 1, jpi 
    512             IF(   tms(ji,jj) <= 0._wp   .AND.   at_i(ji,jj) > 0._wp   ) THEN  
    513                !CALL lim_prt_state( kt, ji, jj, 1, ' ALERTE 6 :   Ice on continents ' ) 
    514                !WRITE(numout,*) ' masks s, u, v        : ', tms(ji,jj), tmu(ji,jj), tmv(ji,jj)  
    515                !WRITE(numout,*) ' sst                  : ', sst_m(ji,jj) 
    516                !WRITE(numout,*) ' sss                  : ', sss_m(ji,jj) 
    517                !WRITE(numout,*) ' at_i(ji,jj)          : ', at_i(ji,jj) 
    518                !WRITE(numout,*) ' v_ice(ji,jj)         : ', v_ice(ji,jj) 
    519                !WRITE(numout,*) ' v_ice(ji,jj-1)       : ', v_ice(ji,jj-1) 
    520                !WRITE(numout,*) ' u_ice(ji-1,jj)       : ', u_ice(ji-1,jj) 
    521                !WRITE(numout,*) ' u_ice(ji,jj)         : ', v_ice(ji,jj) 
    522                ! 
    523                inb_alp(ialert_id) = inb_alp(ialert_id) + 1 
    524             ENDIF 
    525          END DO 
    526       END DO 
    527  
    528 ! 
    529 !     ! Alert if very fresh ice 
    530       ialert_id = 7 ! reference number of this alert 
    531       cl_alname(ialert_id) = ' Very fresh ice               ' ! name of the alert 
    532       DO jl = 1, jpl 
    533          DO jj = 1, jpj 
    534             DO ji = 1, jpi 
    535                IF( sm_i(ji,jj,jl) < 0.1 .AND. a_i(ji,jj,jl) > 0._wp ) THEN 
    536 !                 CALL lim_prt_state(kt,ji,jj,1, ' ALERTE 7 :   Very fresh ice ' ) 
    537 !                 WRITE(numout,*) ' sst                  : ', sst_m(ji,jj) 
    538 !                 WRITE(numout,*) ' sss                  : ', sss_m(ji,jj) 
    539 !                 WRITE(numout,*)  
    540                   inb_alp(ialert_id) = inb_alp(ialert_id) + 1 
    541                ENDIF 
    542             END DO 
    543          END DO 
    544       END DO 
    545 ! 
    546  
    547 !     ! Alert if too old ice 
    548       ialert_id = 9 ! reference number of this alert 
    549       cl_alname(ialert_id) = ' Very old   ice               ' ! name of the alert 
    550       DO jl = 1, jpl 
    551          DO jj = 1, jpj 
    552             DO ji = 1, jpi 
    553                IF ( ( ( ABS( o_i(ji,jj,jl) ) > rdt_ice ) .OR. & 
    554                       ( ABS( o_i(ji,jj,jl) ) < 0._wp) ) .AND. & 
    555                              ( a_i(ji,jj,jl) > 0._wp ) ) THEN 
    556                   !CALL lim_prt_state( kt, ji, jj, 1, ' ALERTE 9 :   Wrong ice age ') 
    557                   inb_alp(ialert_id) = inb_alp(ialert_id) + 1 
    558                ENDIF 
    559             END DO 
    560          END DO 
    561       END DO 
    562   
    563       ! Alert on salt flux 
    564       ialert_id = 5 ! reference number of this alert 
    565       cl_alname(ialert_id) = ' High salt flux               ' ! name of the alert 
    566       DO jj = 1, jpj 
    567          DO ji = 1, jpi 
    568             IF( ABS( sfx (ji,jj) ) .GT. 1.0e-2 ) THEN  ! = 1 psu/day for 1m ocean depth 
    569                !CALL lim_prt_state( kt, ji, jj, 3, ' ALERTE 5 :   High salt flux ' ) 
    570                !DO jl = 1, jpl 
    571                   !WRITE(numout,*) ' Category no: ', jl 
    572                   !WRITE(numout,*) ' a_i        : ', a_i      (ji,jj,jl) , ' a_i_b      : ', a_i_b  (ji,jj,jl)    
    573                   !WRITE(numout,*) ' d_a_i_trp  : ', d_a_i_trp(ji,jj,jl) , ' d_a_i_thd  : ', d_a_i_thd(ji,jj,jl)  
    574                   !WRITE(numout,*) ' v_i        : ', v_i      (ji,jj,jl) , ' v_i_b      : ', v_i_b  (ji,jj,jl)    
    575                   !WRITE(numout,*) ' d_v_i_trp  : ', d_v_i_trp(ji,jj,jl) , ' d_v_i_thd  : ', d_v_i_thd(ji,jj,jl)  
    576                   !WRITE(numout,*) ' ' 
    577                !END DO 
    578                inb_alp(ialert_id) = inb_alp(ialert_id) + 1 
    579             ENDIF 
    580          END DO 
    581       END DO 
    582  
    583       ! Alert if qns very big 
    584       ialert_id = 8 ! reference number of this alert 
    585       cl_alname(ialert_id) = ' fnsolar very big             ' ! name of the alert 
    586       DO jj = 1, jpj 
    587          DO ji = 1, jpi 
    588             IF( ABS( qns(ji,jj) ) > 1500._wp .AND. at_i(ji,jj) > 0._wp ) THEN 
    589                ! 
    590                !WRITE(numout,*) ' ALERTE 8 :   Very high non-solar heat flux' 
    591                !WRITE(numout,*) ' ji, jj    : ', ji, jj 
    592                !WRITE(numout,*) ' qns       : ', qns(ji,jj) 
    593                !WRITE(numout,*) ' sst       : ', sst_m(ji,jj) 
    594                !WRITE(numout,*) ' sss       : ', sss_m(ji,jj) 
    595                ! 
    596                !CALL lim_prt_state( kt, ji, jj, 2, '   ') 
    597                inb_alp(ialert_id) = inb_alp(ialert_id) + 1 
    598                ! 
    599             ENDIF 
    600          END DO 
    601       END DO 
    602       !+++++ 
    603   
    604       ! Alert if very warm ice 
    605       ialert_id = 10 ! reference number of this alert 
    606       cl_alname(ialert_id) = ' Very warm ice                ' ! name of the alert 
    607       inb_alp(ialert_id) = 0 
    608       DO jl = 1, jpl 
    609          DO jk = 1, nlay_i 
    610             DO jj = 1, jpj 
    611                DO ji = 1, jpi 
    612                   ztmelts    =  -tmut * s_i(ji,jj,jk,jl) + rtt 
    613                   IF( t_i(ji,jj,jk,jl) >= ztmelts  .AND.  v_i(ji,jj,jl) > 1.e-10   & 
    614                      &                             .AND.  a_i(ji,jj,jl) > 0._wp   ) THEN 
    615                      !WRITE(numout,*) ' ALERTE 10 :   Very warm ice' 
    616                      !WRITE(numout,*) ' ji, jj, jk, jl : ', ji, jj, jk, jl 
    617                      !WRITE(numout,*) ' t_i : ', t_i(ji,jj,jk,jl) 
    618                      !WRITE(numout,*) ' e_i : ', e_i(ji,jj,jk,jl) 
    619                      !WRITE(numout,*) ' s_i : ', s_i(ji,jj,jk,jl) 
    620                      !WRITE(numout,*) ' ztmelts : ', ztmelts 
    621                      inb_alp(ialert_id) = inb_alp(ialert_id) + 1 
    622                   ENDIF 
    623                END DO 
    624             END DO 
    625          END DO 
    626       END DO 
    627  
    628       ! sum of the alerts on all processors 
    629       IF( lk_mpp ) THEN 
    630          DO ialert_id = 1, inb_altests 
    631             CALL mpp_sum(inb_alp(ialert_id)) 
    632          END DO 
    633       ENDIF 
    634  
    635       ! print alerts 
    636       IF( lwp ) THEN 
    637          ialert_id = 1                                 ! reference number of this alert 
    638          cl_alname(ialert_id) = ' NO alerte 1      '   ! name of the alert 
    639          WRITE(numout,*) ' time step ',kt 
    640          WRITE(numout,*) ' All alerts at the end of ice model ' 
    641          DO ialert_id = 1, inb_altests 
    642             WRITE(numout,*) ialert_id, cl_alname(ialert_id)//' : ', inb_alp(ialert_id), ' times ! ' 
    643          END DO 
    644       ENDIF 
    645      ! 
    646    END SUBROUTINE lim_ctl 
    647   
    648     
    649    SUBROUTINE lim_prt_state( kt, ki, kj, kn, cd1 ) 
    650       !!----------------------------------------------------------------------- 
    651       !!                   ***  ROUTINE lim_prt_state ***  
    652       !!                  
    653       !! ** Purpose :   Writes global ice state on the (i,j) point  
    654       !!                in ocean.ouput  
    655       !!                3 possibilities exist  
    656       !!                n = 1/-1 -> simple ice state (plus Mechanical Check if -1) 
    657       !!                n = 2    -> exhaustive state 
    658       !!                n = 3    -> ice/ocean salt fluxes 
    659       !! 
    660       !! ** input   :   point coordinates (i,j)  
    661       !!                n : number of the option 
    662       !!------------------------------------------------------------------- 
    663       INTEGER         , INTENT(in) ::   kt            ! ocean time step 
    664       INTEGER         , INTENT(in) ::   ki, kj, kn    ! ocean gridpoint indices 
    665       CHARACTER(len=*), INTENT(in) ::   cd1           ! 
    666       !! 
    667       INTEGER :: jl, ji, jj 
    668       !!------------------------------------------------------------------- 
    669  
    670       DO ji = mi0(ki), mi1(ki) 
    671          DO jj = mj0(kj), mj1(kj) 
    672  
    673             WRITE(numout,*) ' time step ',kt,' ',cd1             ! print title 
    674  
    675             !---------------- 
    676             !  Simple state 
    677             !---------------- 
    678              
    679             IF ( kn == 1 .OR. kn == -1 ) THEN 
    680                WRITE(numout,*) ' lim_prt_state - Point : ',ji,jj 
    681                WRITE(numout,*) ' ~~~~~~~~~~~~~~ ' 
    682                WRITE(numout,*) ' Simple state ' 
    683                WRITE(numout,*) ' masks s,u,v   : ', tms(ji,jj), tmu(ji,jj), tmv(ji,jj) 
    684                WRITE(numout,*) ' lat - long    : ', gphit(ji,jj), glamt(ji,jj) 
    685                WRITE(numout,*) ' Time step     : ', numit 
    686                WRITE(numout,*) ' - Ice drift   ' 
    687                WRITE(numout,*) '   ~~~~~~~~~~~ ' 
    688                WRITE(numout,*) ' u_ice(i-1,j)  : ', u_ice(ji-1,jj) 
    689                WRITE(numout,*) ' u_ice(i  ,j)  : ', u_ice(ji,jj) 
    690                WRITE(numout,*) ' v_ice(i  ,j-1): ', v_ice(ji,jj-1) 
    691                WRITE(numout,*) ' v_ice(i  ,j)  : ', v_ice(ji,jj) 
    692                WRITE(numout,*) ' strength      : ', strength(ji,jj) 
    693                WRITE(numout,*) 
    694                WRITE(numout,*) ' - Cell values ' 
    695                WRITE(numout,*) '   ~~~~~~~~~~~ ' 
    696                WRITE(numout,*) ' cell area     : ', area(ji,jj) 
    697                WRITE(numout,*) ' at_i          : ', at_i(ji,jj)        
    698                WRITE(numout,*) ' vt_i          : ', vt_i(ji,jj)        
    699                WRITE(numout,*) ' vt_s          : ', vt_s(ji,jj)        
    700                DO jl = 1, jpl 
    701                   WRITE(numout,*) ' - Category (', jl,')' 
    702                   WRITE(numout,*) ' a_i           : ', a_i(ji,jj,jl) 
    703                   WRITE(numout,*) ' ht_i          : ', ht_i(ji,jj,jl) 
    704                   WRITE(numout,*) ' ht_s          : ', ht_s(ji,jj,jl) 
    705                   WRITE(numout,*) ' v_i           : ', v_i(ji,jj,jl) 
    706                   WRITE(numout,*) ' v_s           : ', v_s(ji,jj,jl) 
    707                   WRITE(numout,*) ' e_s           : ', e_s(ji,jj,1,jl)/1.0e9 
    708                   WRITE(numout,*) ' e_i           : ', e_i(ji,jj,1:nlay_i,jl)/1.0e9 
    709                   WRITE(numout,*) ' t_su          : ', t_su(ji,jj,jl) 
    710                   WRITE(numout,*) ' t_snow        : ', t_s(ji,jj,1,jl) 
    711                   WRITE(numout,*) ' t_i           : ', t_i(ji,jj,1:nlay_i,jl) 
    712                   WRITE(numout,*) ' sm_i          : ', sm_i(ji,jj,jl) 
    713                   WRITE(numout,*) ' smv_i         : ', smv_i(ji,jj,jl) 
    714                   WRITE(numout,*) 
    715                END DO 
    716             ENDIF 
    717             IF( kn == -1 ) THEN 
    718                WRITE(numout,*) ' Mechanical Check ************** ' 
    719                WRITE(numout,*) ' Check what means ice divergence ' 
    720                WRITE(numout,*) ' Total ice concentration ', at_i (ji,jj) 
    721                WRITE(numout,*) ' Total lead fraction     ', ato_i(ji,jj) 
    722                WRITE(numout,*) ' Sum of both             ', ato_i(ji,jj) + at_i(ji,jj) 
    723                WRITE(numout,*) ' Sum of both minus 1     ', ato_i(ji,jj) + at_i(ji,jj) - 1.00 
    724             ENDIF 
    725              
    726  
    727             !-------------------- 
    728             !  Exhaustive state 
    729             !-------------------- 
    730              
    731             IF ( kn .EQ. 2 ) THEN 
    732                WRITE(numout,*) ' lim_prt_state - Point : ',ji,jj 
    733                WRITE(numout,*) ' ~~~~~~~~~~~~~~ ' 
    734                WRITE(numout,*) ' Exhaustive state ' 
    735                WRITE(numout,*) ' lat - long ', gphit(ji,jj), glamt(ji,jj) 
    736                WRITE(numout,*) ' Time step ', numit 
    737                WRITE(numout,*)  
    738                WRITE(numout,*) ' - Cell values ' 
    739                WRITE(numout,*) '   ~~~~~~~~~~~ ' 
    740                WRITE(numout,*) ' cell area     : ', area(ji,jj) 
    741                WRITE(numout,*) ' at_i          : ', at_i(ji,jj)        
    742                WRITE(numout,*) ' vt_i          : ', vt_i(ji,jj)        
    743                WRITE(numout,*) ' vt_s          : ', vt_s(ji,jj)        
    744                WRITE(numout,*) ' u_ice(i-1,j)  : ', u_ice(ji-1,jj) 
    745                WRITE(numout,*) ' u_ice(i  ,j)  : ', u_ice(ji,jj) 
    746                WRITE(numout,*) ' v_ice(i  ,j-1): ', v_ice(ji,jj-1) 
    747                WRITE(numout,*) ' v_ice(i  ,j)  : ', v_ice(ji,jj) 
    748                WRITE(numout,*) ' strength      : ', strength(ji,jj) 
    749                WRITE(numout,*) ' d_u_ice_dyn   : ', d_u_ice_dyn(ji,jj), ' d_v_ice_dyn   : ', d_v_ice_dyn(ji,jj) 
    750                WRITE(numout,*) ' u_ice_b       : ', u_ice_b(ji,jj)    , ' v_ice_b       : ', v_ice_b(ji,jj)   
    751                WRITE(numout,*) 
    752                 
    753                DO jl = 1, jpl 
    754                   WRITE(numout,*) ' - Category (',jl,')' 
    755                   WRITE(numout,*) '   ~~~~~~~~         '  
    756                   WRITE(numout,*) ' ht_i       : ', ht_i(ji,jj,jl)             , ' ht_s       : ', ht_s(ji,jj,jl) 
    757                   WRITE(numout,*) ' t_i        : ', t_i(ji,jj,1:nlay_i,jl) 
    758                   WRITE(numout,*) ' t_su       : ', t_su(ji,jj,jl)             , ' t_s        : ', t_s(ji,jj,1,jl) 
    759                   WRITE(numout,*) ' sm_i       : ', sm_i(ji,jj,jl)             , ' o_i        : ', o_i(ji,jj,jl) 
    760                   WRITE(numout,*) ' a_i        : ', a_i(ji,jj,jl)              , ' a_i_b      : ', a_i_b(ji,jj,jl)    
    761                   WRITE(numout,*) ' d_a_i_trp  : ', d_a_i_trp(ji,jj,jl)        , ' d_a_i_thd  : ', d_a_i_thd(ji,jj,jl)  
    762                   WRITE(numout,*) ' v_i        : ', v_i(ji,jj,jl)              , ' v_i_b      : ', v_i_b(ji,jj,jl)    
    763                   WRITE(numout,*) ' d_v_i_trp  : ', d_v_i_trp(ji,jj,jl)        , ' d_v_i_thd  : ', d_v_i_thd(ji,jj,jl)  
    764                   WRITE(numout,*) ' v_s        : ', v_s(ji,jj,jl)              , ' v_s_b      : ', v_s_b(ji,jj,jl)   
    765                   WRITE(numout,*) ' d_v_s_trp  : ', d_v_s_trp(ji,jj,jl)        , ' d_v_s_thd  : ', d_v_s_thd(ji,jj,jl) 
    766                   WRITE(numout,*) ' e_i1       : ', e_i(ji,jj,1,jl)/1.0e9      , ' ei1        : ', e_i_b(ji,jj,1,jl)/1.0e9  
    767                   WRITE(numout,*) ' de_i1_trp  : ', d_e_i_trp(ji,jj,1,jl)/1.0e9, ' de_i1_thd  : ', d_e_i_thd(ji,jj,1,jl)/1.0e9 
    768                   WRITE(numout,*) ' e_i2       : ', e_i(ji,jj,2,jl)/1.0e9      , ' ei2_b      : ', e_i_b(ji,jj,2,jl)/1.0e9   
    769                   WRITE(numout,*) ' de_i2_trp  : ', d_e_i_trp(ji,jj,2,jl)/1.0e9, ' de_i2_thd  : ', d_e_i_thd(ji,jj,2,jl)/1.0e9 
    770                   WRITE(numout,*) ' e_snow     : ', e_s(ji,jj,1,jl)            , ' e_snow_b   : ', e_s_b(ji,jj,1,jl)  
    771                   WRITE(numout,*) ' d_e_s_trp  : ', d_e_s_trp(ji,jj,1,jl)      , ' d_e_s_thd  : ', d_e_s_thd(ji,jj,1,jl) 
    772                   WRITE(numout,*) ' smv_i      : ', smv_i(ji,jj,jl)            , ' smv_i_b    : ', smv_i_b(ji,jj,jl)    
    773                   WRITE(numout,*) ' d_smv_i_trp: ', d_smv_i_trp(ji,jj,jl)      , ' d_smv_i_thd: ', d_smv_i_thd(ji,jj,jl)  
    774                   WRITE(numout,*) ' oa_i       : ', oa_i(ji,jj,jl)             , ' oa_i_b     : ', oa_i_b(ji,jj,jl) 
    775                   WRITE(numout,*) ' d_oa_i_trp : ', d_oa_i_trp(ji,jj,jl)       , ' d_oa_i_thd : ', d_oa_i_thd(ji,jj,jl) 
    776                END DO !jl 
    777                 
    778                WRITE(numout,*) 
    779                WRITE(numout,*) ' - Heat / FW fluxes ' 
    780                WRITE(numout,*) '   ~~~~~~~~~~~~~~~~ ' 
    781                WRITE(numout,*) ' - Heat fluxes in and out the ice ***' 
    782                WRITE(numout,*) ' qsr_ini       : ', pfrld(ji,jj) * qsr(ji,jj) + SUM( a_i_b(ji,jj,:) * qsr_ice(ji,jj,:) ) 
    783                WRITE(numout,*) ' qns_ini       : ', pfrld(ji,jj) * qns(ji,jj) + SUM( a_i_b(ji,jj,:) * qns_ice(ji,jj,:) ) 
    784                WRITE(numout,*) 
    785                WRITE(numout,*)  
    786                WRITE(numout,*) ' sst        : ', sst_m(ji,jj)   
    787                WRITE(numout,*) ' sss        : ', sss_m(ji,jj)   
    788                WRITE(numout,*)  
    789                WRITE(numout,*) ' - Stresses ' 
    790                WRITE(numout,*) '   ~~~~~~~~ ' 
    791                WRITE(numout,*) ' utau_ice   : ', utau_ice(ji,jj)  
    792                WRITE(numout,*) ' vtau_ice   : ', vtau_ice(ji,jj) 
    793                WRITE(numout,*) ' utau       : ', utau    (ji,jj)  
    794                WRITE(numout,*) ' vtau       : ', vtau    (ji,jj) 
    795                WRITE(numout,*) ' oc. vel. u : ', u_oce   (ji,jj) 
    796                WRITE(numout,*) ' oc. vel. v : ', v_oce   (ji,jj) 
    797             ENDIF 
    798              
    799             !--------------------- 
    800             ! Salt / heat fluxes 
    801             !--------------------- 
    802              
    803             IF ( kn .EQ. 3 ) THEN 
    804                WRITE(numout,*) ' lim_prt_state - Point : ',ji,jj 
    805                WRITE(numout,*) ' ~~~~~~~~~~~~~~ ' 
    806                WRITE(numout,*) ' - Salt / Heat Fluxes ' 
    807                WRITE(numout,*) '   ~~~~~~~~~~~~~~~~ ' 
    808                WRITE(numout,*) ' lat - long ', gphit(ji,jj), glamt(ji,jj) 
    809                WRITE(numout,*) ' Time step ', numit 
    810                WRITE(numout,*) 
    811                WRITE(numout,*) ' - Heat fluxes at bottom interface ***' 
    812                WRITE(numout,*) ' qsr       : ', qsr(ji,jj) 
    813                WRITE(numout,*) ' qns       : ', qns(ji,jj) 
    814                WRITE(numout,*) 
    815                WRITE(numout,*) ' hfx_mass     : ', hfx_thd(ji,jj) + hfx_dyn(ji,jj) + hfx_snw(ji,jj) + hfx_res(ji,jj) 
    816                WRITE(numout,*) ' hfx_in       : ', hfx_in(ji,jj) 
    817                WRITE(numout,*) ' hfx_out      : ', hfx_out(ji,jj) 
    818                WRITE(numout,*) ' dhc          : ', diag_heat_dhc(ji,jj)               
    819                WRITE(numout,*) 
    820                WRITE(numout,*) ' hfx_dyn      : ', hfx_dyn(ji,jj) 
    821                WRITE(numout,*) ' hfx_thd      : ', hfx_thd(ji,jj) 
    822                WRITE(numout,*) ' hfx_res      : ', hfx_res(ji,jj) 
    823                WRITE(numout,*) ' fhtur        : ', fhtur(ji,jj)  
    824                WRITE(numout,*) ' qlead        : ', qlead(ji,jj) * r1_rdtice 
    825                WRITE(numout,*) 
    826                WRITE(numout,*) ' - Salt fluxes at bottom interface ***' 
    827                WRITE(numout,*) ' emp       : ', emp    (ji,jj) 
    828                WRITE(numout,*) ' sfx       : ', sfx    (ji,jj) 
    829                WRITE(numout,*) ' sfx_res   : ', sfx_res(ji,jj) 
    830                WRITE(numout,*) ' sfx_bri   : ', sfx_bri(ji,jj) 
    831                WRITE(numout,*) ' sfx_dyn   : ', sfx_dyn(ji,jj) 
    832                WRITE(numout,*) 
    833                WRITE(numout,*) ' - Momentum fluxes ' 
    834                WRITE(numout,*) ' utau      : ', utau(ji,jj)  
    835                WRITE(numout,*) ' vtau      : ', vtau(ji,jj) 
    836             ENDIF  
    837             WRITE(numout,*) ' ' 
    838             ! 
    839          END DO 
    840       END DO 
    841       ! 
    842    END SUBROUTINE lim_prt_state 
    843     
    844       
     555 
     556   SUBROUTINE sbc_lim_bef 
     557      !!---------------------------------------------------------------------- 
     558      !!                  ***  ROUTINE sbc_lim_bef  *** 
     559      !! 
     560      !! ** purpose :  store ice variables at "before" time step  
     561      !!---------------------------------------------------------------------- 
     562      a_i_b  (:,:,:)   = a_i  (:,:,:)     ! ice area 
     563      e_i_b  (:,:,:,:) = e_i  (:,:,:,:)   ! ice thermal energy 
     564      v_i_b  (:,:,:)   = v_i  (:,:,:)     ! ice volume 
     565      v_s_b  (:,:,:)   = v_s  (:,:,:)     ! snow volume  
     566      e_s_b  (:,:,:,:) = e_s  (:,:,:,:)   ! snow thermal energy 
     567      smv_i_b(:,:,:)   = smv_i(:,:,:)     ! salt content 
     568      oa_i_b (:,:,:)   = oa_i (:,:,:)     ! areal age content 
     569      u_ice_b(:,:)     = u_ice(:,:) 
     570      v_ice_b(:,:)     = v_ice(:,:) 
     571       
     572   END SUBROUTINE sbc_lim_bef 
     573 
     574   SUBROUTINE sbc_lim_diag0 
     575      !!---------------------------------------------------------------------- 
     576      !!                  ***  ROUTINE sbc_lim_diag0  *** 
     577      !! 
     578      !! ** purpose :  set ice-ocean and ice-atm. fluxes to zeros at the beggining 
     579      !!               of the time step 
     580      !!---------------------------------------------------------------------- 
     581      sfx    (:,:) = 0._wp   ; 
     582      sfx_bri(:,:) = 0._wp   ;  
     583      sfx_sni(:,:) = 0._wp   ;   sfx_opw(:,:) = 0._wp 
     584      sfx_bog(:,:) = 0._wp   ;   sfx_dyn(:,:) = 0._wp 
     585      sfx_bom(:,:) = 0._wp   ;   sfx_sum(:,:) = 0._wp 
     586      sfx_res(:,:) = 0._wp 
     587       
     588      wfx_snw(:,:) = 0._wp   ;   wfx_ice(:,:) = 0._wp 
     589      wfx_sni(:,:) = 0._wp   ;   wfx_opw(:,:) = 0._wp 
     590      wfx_bog(:,:) = 0._wp   ;   wfx_dyn(:,:) = 0._wp 
     591      wfx_bom(:,:) = 0._wp   ;   wfx_sum(:,:) = 0._wp 
     592      wfx_res(:,:) = 0._wp   ;   wfx_sub(:,:) = 0._wp 
     593      wfx_spr(:,:) = 0._wp   ;    
     594       
     595      hfx_in (:,:) = 0._wp   ;   hfx_out(:,:) = 0._wp 
     596      hfx_thd(:,:) = 0._wp   ;    
     597      hfx_snw(:,:) = 0._wp   ;   hfx_opw(:,:) = 0._wp 
     598      hfx_bog(:,:) = 0._wp   ;   hfx_dyn(:,:) = 0._wp 
     599      hfx_bom(:,:) = 0._wp   ;   hfx_sum(:,:) = 0._wp 
     600      hfx_res(:,:) = 0._wp   ;   hfx_sub(:,:) = 0._wp 
     601      hfx_spr(:,:) = 0._wp   ;   hfx_dif(:,:) = 0._wp  
     602      hfx_err(:,:) = 0._wp   ;   hfx_err_rem(:,:) = 0._wp 
     603      hfx_err_dif(:,:) = 0._wp   ; 
     604 
     605      afx_tot(:,:) = 0._wp   ; 
     606      afx_dyn(:,:) = 0._wp   ;   afx_thd(:,:) = 0._wp 
     607 
     608      diag_heat(:,:) = 0._wp ;   diag_smvi(:,:) = 0._wp ; 
     609      diag_vice(:,:) = 0._wp ;   diag_vsnw(:,:) = 0._wp ; 
     610       
     611   END SUBROUTINE sbc_lim_diag0 
     612       
    845613   FUNCTION fice_cell_ave ( ptab ) 
    846614      !!-------------------------------------------------------------------------- 
    … …  
    854622       
    855623      DO jl = 1, jpl 
    856          fice_cell_ave (:,:) = fice_cell_ave (:,:) & 
    857             &                  + a_i (:,:,jl) * ptab (:,:,jl) 
     624         fice_cell_ave (:,:) = fice_cell_ave (:,:) + a_i (:,:,jl) * ptab (:,:,jl) 
    858625      END DO 
    859626       
    … …  
    869636 
    870637      fice_ice_ave (:,:) = 0.0_wp 
    871       WHERE ( at_i (:,:) .GT. 0.0_wp ) fice_ice_ave (:,:) = fice_cell_ave ( ptab (:,:,:)) / at_i (:,:) 
     638      WHERE ( at_i (:,:) > 0.0_wp ) fice_ice_ave (:,:) = fice_cell_ave ( ptab (:,:,:)) / at_i (:,:) 
    872639 
    873640   END FUNCTION fice_ice_ave 
    … …  
    882649      WRITE(*,*) 'sbc_ice_lim: You should not have seen this print! error?', kt, kblk 
    883650   END SUBROUTINE sbc_ice_lim 
     651   SUBROUTINE sbc_lim_init                 ! Dummy routine 
     652   END SUBROUTINE sbc_lim_init 
    884653#endif 
    885654 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/SBC/sbcisf.F90

    r5312 r5313  
    77   !! History :  3.2   !  2011-02  (C.Harris  ) Original code isf cav 
    88   !!            X.X   !  2006-02  (C. Wang   ) Original code bg03 
    9    !!            3.4   !  2013-03  (P. Mathiot) Merging 
     9   !!            3.4   !  2013-03  (P. Mathiot) Merging + parametrization 
    1010   !!---------------------------------------------------------------------- 
    1111 
    … …  
    3737 
    3838   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   risf_tsc_b, risf_tsc    
    39    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   fwfisf_b, fwfisf  !: evaporation damping   [kg/m2/s] 
    40    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   qisf            !: net heat flux from ice shelf 
     39   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   qisf              !: net heat flux from ice shelf 
    4140   REAL(wp), PUBLIC ::   rn_hisf_tbl                 !: thickness of top boundary layer [m] 
    4241   LOGICAL , PUBLIC ::   ln_divisf                   !: flag to correct divergence  
    … …  
    309308      sbc_isf_alloc = 0       ! set to zero if no array to be allocated 
    310309      IF( .NOT. ALLOCATED( qisf ) ) THEN 
    311          ALLOCATE(  risf_tsc(jpi,jpj,jpts), risf_tsc_b(jpi,jpj,jpts)              , & 
    312                &    qisf(jpi,jpj)     , fwfisf(jpi,jpj)     , fwfisf_b(jpi,jpj)   , & 
    313                &    rhisf_tbl(jpi,jpj), r1_hisf_tbl(jpi,jpj), rzisf_tbl(jpi,jpj)  , & 
    314                &    ttbl(jpi,jpj)     , stbl(jpi,jpj)       , utbl(jpi,jpj)       , & 
    315                &    vtbl(jpi, jpj)    , risfLeff(jpi,jpj)   , rhisf_tbl_0(jpi,jpj), & 
    316                &    ralpha(jpi,jpj)   , misfkt(jpi,jpj)     , misfkb(jpi,jpj)     , & 
     310         ALLOCATE(  risf_tsc(jpi,jpj,jpts), risf_tsc_b(jpi,jpj,jpts), qisf(jpi,jpj)   , & 
     311               &    rhisf_tbl(jpi,jpj)    , r1_hisf_tbl(jpi,jpj), rzisf_tbl(jpi,jpj)  , & 
     312               &    ttbl(jpi,jpj)         , stbl(jpi,jpj)       , utbl(jpi,jpj)       , & 
     313               &    vtbl(jpi, jpj)        , risfLeff(jpi,jpj)   , rhisf_tbl_0(jpi,jpj), & 
     314               &    ralpha(jpi,jpj)       , misfkt(jpi,jpj)     , misfkb(jpi,jpj)     , & 
    317315               &    STAT= sbc_isf_alloc ) 
    318316         ! 
    … …  
    563561      CALL iom_put('isfgammat', zgammat2d) 
    564562      CALL iom_put('isfgammas', zgammas2d) 
    565          ! 
    566       !CALL wrk_dealloc( jpi,jpj, zfrz,zpress,zti, zqisf, zfwfisf  ) 
     563      ! 
    567564      CALL wrk_dealloc( jpi,jpj, zfrz,zpress,zti, zgammat2d, zgammas2d ) 
    568565      ! 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/SBC/sbcmod.F90

    r5312 r5313  
    1313   !!            3.4  ! 2011-11  (C. Harris) CICE added as an option 
    1414   !!            3.5  ! 2012-11  (A. Coward, G. Madec) Rethink of heat, mass and salt surface fluxes 
     15   !!            3.6  ! 2014-11  (P. Mathiot, C. Harris) add ice shelves melting                     
    1516   !!---------------------------------------------------------------------- 
    1617 
    … …  
    179180         IF( sbc_isf_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'sbc_init : unable to allocate sbc_isf arrays' ) 
    180181         fwfisf  (:,:) = 0.0_wp 
     182         fwfisf_b(:,:) = 0.0_wp 
    181183      END IF 
    182184      IF( nn_ice == 0  )   fr_i(:,:) = 0.e0        ! no ice in the domain, ice fraction is always zero 
    … …  
    271273      IF( ln_ssr           )   CALL sbc_ssr_init               ! Sea-Surface Restoring initialisation 
    272274      ! 
     275      IF( nn_ice == 3      )   CALL sbc_lim_init               ! LIM3 initialisation 
     276 
    273277      IF( nn_ice == 4      )   CALL cice_sbc_init( nsbc )      ! CICE initialisation 
    274278      ! 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/SBC/sbcssm.F90

    r5312 r5313  
    6161      !!--------------------------------------------------------------------- 
    6262       
    63       !                                        !* first wet T-, U-, V- ocean level (ISF) variables (T, S, depth, velocity) 
     63      !                                        !* surface T-, U-, V- ocean level variables (T, S, depth, velocity) 
    6464      DO jj = 1, jpj 
    6565         DO ji = 1, jpi 
    66             zub(ji,jj)        = ub (ji,jj,miku(ji,jj)) 
    67             zvb(ji,jj)        = vb (ji,jj,mikv(ji,jj)) 
    6866            zts(ji,jj,jp_tem) = tsn(ji,jj,mikt(ji,jj),jp_tem) 
    6967            zts(ji,jj,jp_sal) = tsn(ji,jj,mikt(ji,jj),jp_sal) 
    7068         END DO 
    7169      END DO 
     70      zub(:,:)        = ub (:,:,1       ) 
     71      zvb(:,:)        = vb (:,:,1       ) 
    7272      ! 
    7373      IF( lk_vvl ) THEN 
    74          DO jj = 1, jpj 
    75             DO ji = 1, jpi 
    76                zdep(ji,jj) = fse3t_n(ji,jj,mikt(ji,jj)) 
    77             END DO 
    78          END DO 
     74         zdep(:,:) = fse3t_n(:,:,1) 
    7975      ENDIF 
    8076      !                                                   ! ---------------------------------------- ! 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/SBC/tideini.F90

    r5312 r5313  
    8080          END DO 
    8181       END DO 
     82       !        
     83       ! Ensure that tidal components have been set in namelist_cfg 
     84       IF( nb_harmo .EQ. 0 ) CALL ctl_stop( 'tide_init : No tidal components set in nam_tide' ) 
    8285       ! 
    8386       IF(lwp) THEN 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/TRA/eosbn2.F90

    r5312 r5313  
    15891589      END SELECT 
    15901590      ! 
     1591      rau0_rcp    = rau0 * rcp  
    15911592      r1_rau0     = 1._wp / rau0 
    15921593      r1_rcp      = 1._wp / rcp 
    1593       r1_rau0_rcp = 1._wp / ( rau0 * rcp ) 
     1594      r1_rau0_rcp = 1._wp / rau0_rcp  
    15941595      ! 
    15951596      IF(lwp) WRITE(numout,*) 
    … …  
    15971598      IF(lwp) WRITE(numout,*) '          1. / rau0                        r1_rau0  = ', r1_rau0, ' m^3/kg' 
    15981599      IF(lwp) WRITE(numout,*) '          ocean specific heat                 rcp   = ', rcp    , ' J/Kelvin' 
     1600      IF(lwp) WRITE(numout,*) '          rau0 * rcp                       rau0_rcp = ', rau0_rcp 
    15991601      IF(lwp) WRITE(numout,*) '          1. / ( rau0 * rcp )           r1_rau0_rcp = ', r1_rau0_rcp 
    16001602      ! 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/TRA/traadv.F90

    r5312 r5313  
    2626   USE cla             ! cross land advection      (cla_traadv     routine) 
    2727   USE ldftra_oce      ! lateral diffusion coefficient on tracers 
     28   ! 
    2829   USE in_out_manager  ! I/O manager 
    2930   USE iom             ! I/O module 
    … …  
    3334   USE timing          ! Timing 
    3435   USE sbc_oce 
     36   USE diaptr          ! Poleward heat transport  
    3537 
    3638 
    … …  
    111113      ! 
    112114      IF( ln_mle    )   CALL tra_adv_mle( kt, nit000, zun, zvn, zwn, 'TRA' )    ! add the mle transport (if necessary) 
     115      ! 
    113116      CALL iom_put( "uocetr_eff", zun )                                         ! output effective transport       
    114117      CALL iom_put( "vocetr_eff", zvn ) 
    115118      CALL iom_put( "wocetr_eff", zwn ) 
    116  
     119      ! 
     120      IF( ln_diaptr )   CALL dia_ptr( zvn )                                     ! diagnose the effective MSF  
     121      ! 
     122    
    117123      SELECT CASE ( nadv )                            !==  compute advection trend and add it to general trend  ==! 
    118       CASE ( 1 )   ;    CALL tra_adv_cen2  ( kt, nit000, 'TRA',         zun, zvn, zwn, tsb, tsn, tsa, jpts )   !  2nd order centered 
    119       CASE ( 2 )   ;    CALL tra_adv_tvd   ( kt, nit000, 'TRA', r2dtra, zun, zvn, zwn, tsb, tsn, tsa, jpts )   !  TVD  
    120       CASE ( 3 )   ;    CALL tra_adv_muscl ( kt, nit000, 'TRA', r2dtra, zun, zvn, zwn, tsb,      tsa, jpts, ln_traadv_msc_ups )   !  MUSCL  
    121       CASE ( 4 )   ;    CALL tra_adv_muscl2( kt, nit000, 'TRA', r2dtra, zun, zvn, zwn, tsb, tsn, tsa, jpts )   !  MUSCL2  
    122       CASE ( 5 )   ;    CALL tra_adv_ubs   ( kt, nit000, 'TRA', r2dtra, zun, zvn, zwn, tsb, tsn, tsa, jpts )   !  UBS  
    123       CASE ( 6 )   ;    CALL tra_adv_qck   ( kt, nit000, 'TRA', r2dtra, zun, zvn, zwn, tsb, tsn, tsa, jpts )   !  QUICKEST  
    124       CASE ( 7 )   ;   CALL tra_adv_tvd_zts( kt, nit000, 'TRA', r2dtra, zun, zvn, zwn, tsb, tsn, tsa, jpts )   !  TVD ZTS 
     124      CASE ( 1 )   ;    CALL tra_adv_cen2   ( kt, nit000, 'TRA',         zun, zvn, zwn, tsb, tsn, tsa, jpts )   !  2nd order centered 
     125      CASE ( 2 )   ;    CALL tra_adv_tvd    ( kt, nit000, 'TRA', r2dtra, zun, zvn, zwn, tsb, tsn, tsa, jpts )   !  TVD  
     126      CASE ( 3 )   ;    CALL tra_adv_muscl  ( kt, nit000, 'TRA', r2dtra, zun, zvn, zwn, tsb,      tsa, jpts, ln_traadv_msc_ups )   !  MUSCL  
     127      CASE ( 4 )   ;    CALL tra_adv_muscl2 ( kt, nit000, 'TRA', r2dtra, zun, zvn, zwn, tsb, tsn, tsa, jpts )   !  MUSCL2  
     128      CASE ( 5 )   ;    CALL tra_adv_ubs    ( kt, nit000, 'TRA', r2dtra, zun, zvn, zwn, tsb, tsn, tsa, jpts )   !  UBS  
     129      CASE ( 6 )   ;    CALL tra_adv_qck    ( kt, nit000, 'TRA', r2dtra, zun, zvn, zwn, tsb, tsn, tsa, jpts )   !  QUICKEST  
     130      CASE ( 7 )   ;    CALL tra_adv_tvd_zts( kt, nit000, 'TRA', r2dtra, zun, zvn, zwn, tsb, tsn, tsa, jpts )   !  TVD ZTS 
    125131      ! 
    126132      CASE (-1 )                                      !==  esopa: test all possibility with control print  ==! 
    … …  
    206212      IF( lk_esopa         )   ioptio =          1 
    207213 
    208       IF( ( ln_traadv_muscl .OR. ln_traadv_muscl2 .OR. ln_traadv_ubs .OR. ln_traadv_qck ) .AND. nn_isf .NE. 0 )  & 
    209       &   CALL ctl_stop( 'Only traadv_cen2 and traadv_tvd is compatible with ice shelf cavity') 
     214      IF( ( ln_traadv_muscl .OR. ln_traadv_muscl2 .OR. ln_traadv_ubs .OR. ln_traadv_qck .OR. ln_traadv_tvd_zts )   & 
     215         .AND. ln_isfcav )   CALL ctl_stop( 'Only traadv_cen2 and traadv_tvd is compatible with ice shelf cavity') 
    210216 
    211217      IF( ioptio /= 1 )   CALL ctl_stop( 'Choose ONE advection scheme in namelist namtra_adv' ) 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/TRA/traadv_cen2.F90

    r5312 r5313  
    279279         END IF 
    280280         !                                 ! "Poleward" heat and salt transports (contribution of upstream fluxes) 
    281          IF( cdtype == 'TRA' .AND. ln_diaptr .AND. ( MOD( kt, nn_fptr ) == 0 ) ) THEN   
    282            IF( jn == jp_tem )   htr_adv(:) = ptr_vj( zwy(:,:,:) ) 
    283            IF( jn == jp_sal )   str_adv(:) = ptr_vj( zwy(:,:,:) ) 
     281         IF( cdtype == 'TRA' .AND. ln_diaptr ) THEN   
     282           IF( jn == jp_tem )   htr_adv(:) = ptr_sj( zwy(:,:,:) ) 
     283           IF( jn == jp_sal )   str_adv(:) = ptr_sj( zwy(:,:,:) ) 
    284284         ENDIF 
    285285         ! 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/TRA/traadv_muscl.F90

    r5312 r5313  
    2121   USE trdtra         ! tracers trends manager 
    2222   USE dynspg_oce     ! choice/control of key cpp for surface pressure gradient 
    23    USE sbcrnf          ! river runoffs 
     23   USE sbcrnf         ! river runoffs 
    2424   USE diaptr         ! poleward transport diagnostics 
    2525   ! 
    … …  
    219219         END IF 
    220220         !                                 ! "Poleward" heat and salt transports (contribution of upstream fluxes) 
    221          IF( cdtype == 'TRA' .AND. ln_diaptr .AND. ( MOD( kt, nn_fptr ) == 0 ) ) THEN   
    222             IF( jn == jp_tem )  htr_adv(:) = ptr_vj( zwy(:,:,:) ) 
    223             IF( jn == jp_sal )  str_adv(:) = ptr_vj( zwy(:,:,:) ) 
     221         IF( cdtype == 'TRA' .AND. ln_diaptr ) THEN   
     222            IF( jn == jp_tem )  htr_adv(:) = ptr_sj( zwy(:,:,:) ) 
     223            IF( jn == jp_sal )  str_adv(:) = ptr_sj( zwy(:,:,:) ) 
    224224         ENDIF 
    225225 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/TRA/traadv_muscl2.F90

    r5312 r5313  
    200200 
    201201         !                                 ! "Poleward" heat and salt transports (contribution of upstream fluxes) 
    202          IF( cdtype == 'TRA' .AND. ln_diaptr .AND. ( MOD( kt, nn_fptr ) == 0 ) ) THEN 
    203             IF( jn == jp_tem )  htr_adv(:) = ptr_vj( zwy(:,:,:) ) 
    204             IF( jn == jp_sal )  str_adv(:) = ptr_vj( zwy(:,:,:) ) 
     202         IF( cdtype == 'TRA' .AND. ln_diaptr ) THEN 
     203            IF( jn == jp_tem )  htr_adv(:) = ptr_sj( zwy(:,:,:) ) 
     204            IF( jn == jp_sal )  str_adv(:) = ptr_sj( zwy(:,:,:) ) 
    205205         ENDIF 
    206206 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/TRA/traadv_qck.F90

    r5312 r5313  
    355355         IF( l_trd )   CALL trd_tra( kt, cdtype, jn, jptra_yad, zwy, pvn, ptn(:,:,:,jn) ) 
    356356         !                                 ! "Poleward" heat and salt transports (contribution of upstream fluxes) 
    357          IF( cdtype == 'TRA' .AND. ln_diaptr .AND. ( MOD( kt, nn_fptr ) == 0 ) ) THEN   
    358            IF( jn == jp_tem )  htr_adv(:) = ptr_vj( zwy(:,:,:) ) 
    359            IF( jn == jp_sal )  str_adv(:) = ptr_vj( zwy(:,:,:) ) 
     357         IF( cdtype == 'TRA' .AND. ln_diaptr ) THEN   
     358           IF( jn == jp_tem )  htr_adv(:) = ptr_sj( zwy(:,:,:) ) 
     359           IF( jn == jp_sal )  str_adv(:) = ptr_sj( zwy(:,:,:) ) 
    360360         ENDIF 
    361361         ! 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/TRA/traadv_tvd.F90

    r5312 r5313  
    106106      ENDIF 
    107107      ! 
    108       zwi(:,:,:) = 0.e0 ; zwz(:,:,:) = 0.e0 
     108      zwi(:,:,:) = 0.e0 ;  
    109109      ! 
    110110      !                                                          ! =========== 
    111111      DO jn = 1, kjpt                                            ! tracer loop 
    112112         !                                                       ! =========== 
    113          ! 1. Bottom value : flux set to zero 
     113         ! 1. Bottom and k=1 value : flux set to zero 
    114114         ! ---------------------------------- 
    115115         zwx(:,:,jpk) = 0.e0    ;    zwz(:,:,jpk) = 0.e0 
    116116         zwy(:,:,jpk) = 0.e0    ;    zwi(:,:,jpk) = 0.e0 
    117  
     117           
     118         zwz(:,:,1  ) = 0._wp 
    118119         ! 2. upstream advection with initial mass fluxes & intermediate update 
    119120         ! -------------------------------------------------------------------- 
    … …  
    134135 
    135136         ! upstream tracer flux in the k direction 
     137         ! Interior value 
     138         DO jk = 2, jpkm1 
     139            DO jj = 1, jpj 
     140               DO ji = 1, jpi 
     141                  zfp_wk = pwn(ji,jj,jk) + ABS( pwn(ji,jj,jk) ) 
     142                  zfm_wk = pwn(ji,jj,jk) - ABS( pwn(ji,jj,jk) ) 
     143                  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) 
     144               END DO 
     145            END DO 
     146         END DO 
    136147         ! Surface value 
    137148         IF( lk_vvl ) THEN    
    138             DO jj = 1, jpj 
    139                DO ji = 1, jpi 
    140                   zwz(ji,jj, mikt(ji,jj) ) = 0.e0                         ! volume variable 
    141                END DO 
    142             END DO 
     149            IF ( ln_isfcav ) THEN 
     150               DO jj = 1, jpj 
     151                  DO ji = 1, jpi 
     152                     zwz(ji,jj, mikt(ji,jj) ) = 0.e0          ! volume variable 
     153                  END DO 
     154               END DO 
     155            ELSE 
     156               zwz(:,:,1) = 0.e0          ! volume variable 
     157            END IF 
    143158         ELSE                 
    144             DO jj = 1, jpj 
    145                DO ji = 1, jpi 
    146                   zwz(ji,jj, mikt(ji,jj) ) = pwn(ji,jj,mikt(ji,jj)) * ptb(ji,jj,mikt(ji,jj),jn)   ! linear free surface  
    147                END DO 
    148             END DO    
     159            IF ( ln_isfcav ) THEN 
     160               DO jj = 1, jpj 
     161                  DO ji = 1, jpi 
     162                     zwz(ji,jj, mikt(ji,jj) ) = pwn(ji,jj,mikt(ji,jj)) * ptb(ji,jj,mikt(ji,jj),jn)   ! linear free surface  
     163                  END DO 
     164               END DO    
     165            ELSE 
     166               zwz(:,:,1) = pwn(:,:,1) * ptb(:,:,1,jn)   ! linear free surface 
     167            END IF 
    149168         ENDIF 
    150          ! Interior value 
    151          DO jj = 1, jpj 
    152             DO ji = 1, jpi 
    153                DO jk = mikt(ji,jj)+1, jpkm1 
    154                   zfp_wk = pwn(ji,jj,jk) + ABS( pwn(ji,jj,jk) ) 
    155                   zfm_wk = pwn(ji,jj,jk) - ABS( pwn(ji,jj,jk) ) 
    156                   zwz(ji,jj,jk) = 0.5 * ( zfp_wk * ptb(ji,jj,jk,jn) + zfm_wk * ptb(ji,jj,jk-1,jn) ) 
    157                END DO 
    158             END DO 
    159          END DO 
    160169 
    161170         ! total advective trend 
    … …  
    184193         END IF 
    185194         !                                 ! "Poleward" heat and salt transports (contribution of upstream fluxes) 
    186          IF( cdtype == 'TRA' .AND. ln_diaptr .AND. ( MOD( kt, nn_fptr ) == 0 ) ) THEN   
    187            IF( jn == jp_tem )  htr_adv(:) = ptr_vj( zwy(:,:,:) ) 
    188            IF( jn == jp_sal )  str_adv(:) = ptr_vj( zwy(:,:,:) ) 
     195         IF( cdtype == 'TRA' .AND. ln_diaptr ) THEN   
     196           IF( jn == jp_tem )  htr_adv(:) = ptr_sj( zwy(:,:,:) ) 
     197           IF( jn == jp_sal )  str_adv(:) = ptr_sj( zwy(:,:,:) ) 
    189198         ENDIF 
    190199 
    … …  
    202211       
    203212         ! antidiffusive flux on k 
    204          zwz(:,:,1) = 0.e0         ! Surface value 
    205          ! 
    206          DO jj = 1, jpj 
    207             DO ji = 1, jpi 
    208                ik=mikt(ji,jj) 
    209                ! surface value 
    210                zwz(ji,jj,1:ik) = 0.e0 
    211                ! Interior value 
    212                DO jk = mikt(ji,jj)+1, jpkm1                     
     213         ! Interior value 
     214         DO jk = 2, jpkm1                     
     215            DO jj = 1, jpj 
     216               DO ji = 1, jpi 
    213217                  zwz(ji,jj,jk) = 0.5 * pwn(ji,jj,jk) * ( ptn(ji,jj,jk,jn) + ptn(ji,jj,jk-1,jn) ) - zwz(ji,jj,jk) 
    214218               END DO 
    215219            END DO 
    216220         END DO 
     221         ! surface value 
     222         IF ( ln_isfcav ) THEN 
     223            DO jj = 1, jpj 
     224               DO ji = 1, jpi 
     225                  zwz(ji,jj,mikt(ji,jj)) = 0.e0 
     226               END DO 
     227            END DO 
     228         ELSE 
     229            zwz(:,:,1) = 0.e0 
     230         END IF 
    217231         CALL lbc_lnk( zwx, 'U', -1. )   ;   CALL lbc_lnk( zwy, 'V', -1. )         ! Lateral bondary conditions 
    218232         CALL lbc_lnk( zwz, 'W',  1. ) 
    … …  
    250264         END IF 
    251265         !                                 ! "Poleward" heat and salt transports (contribution of upstream fluxes) 
    252          IF( cdtype == 'TRA' .AND. ln_diaptr .AND. ( MOD( kt, nn_fptr ) == 0 ) ) THEN   
    253            IF( jn == jp_tem )  htr_adv(:) = ptr_vj( zwy(:,:,:) ) + htr_adv(:) 
    254            IF( jn == jp_sal )  str_adv(:) = ptr_vj( zwy(:,:,:) ) + str_adv(:) 
     266         IF( cdtype == 'TRA' .AND. ln_diaptr ) THEN   
     267           IF( jn == jp_tem )  htr_adv(:) = ptr_sj( zwy(:,:,:) ) + htr_adv(:) 
     268           IF( jn == jp_sal )  str_adv(:) = ptr_sj( zwy(:,:,:) ) + str_adv(:) 
    255269         ENDIF 
    256270         ! 
    … …  
    358372 
    359373         ! upstream tracer flux in the k direction 
    360          ! Surface value 
    361          IF( lk_vvl ) THEN   ;   zwz(:,:, 1 ) = 0._wp                        ! volume variable 
    362          ELSE                ;   zwz(:,:, 1 ) = pwn(:,:,1) * ptb(:,:,1,jn)   ! linear free surface  
    363          ENDIF 
    364374         ! Interior value 
    365375         DO jk = 2, jpkm1 
    … …  
    372382            END DO 
    373383         END DO 
     384         ! Surface value 
     385         IF( lk_vvl ) THEN 
     386            IF ( ln_isfcav ) THEN 
     387               DO jj = 1, jpj 
     388                  DO ji = 1, jpi 
     389                     zwz(ji,jj, mikt(ji,jj) ) = 0.e0          ! volume variable +    isf 
     390                  END DO 
     391               END DO 
     392            ELSE 
     393               zwz(:,:,1) = 0.e0                              ! volume variable + no isf 
     394            END IF 
     395         ELSE 
     396            IF ( ln_isfcav ) THEN 
     397               DO jj = 1, jpj 
     398                  DO ji = 1, jpi 
     399                     zwz(ji,jj, mikt(ji,jj) ) = pwn(ji,jj,mikt(ji,jj)) * ptb(ji,jj,mikt(ji,jj),jn)   ! linear free surface +    isf 
     400                  END DO 
     401               END DO 
     402            ELSE 
     403               zwz(:,:,1) = pwn(:,:,1) * ptb(:,:,1,jn)                                               ! linear free surface + no isf 
     404            END IF 
     405         ENDIF 
    374406 
    375407         ! total advective trend 
    … …  
    398430         END IF 
    399431         !                                 ! "Poleward" heat and salt transports (contribution of upstream fluxes) 
    400          IF( cdtype == 'TRA' .AND. ln_diaptr .AND. ( MOD( kt, nn_fptr ) == 0 ) ) THEN   
    401            IF( jn == jp_tem )  htr_adv(:) = ptr_vj( zwy(:,:,:) ) 
    402            IF( jn == jp_sal )  str_adv(:) = ptr_vj( zwy(:,:,:) ) 
     432         IF( cdtype == 'TRA' .AND. ln_diaptr ) THEN   
     433           IF( jn == jp_tem )  htr_adv(:) = ptr_sj( zwy(:,:,:) ) 
     434           IF( jn == jp_sal )  str_adv(:) = ptr_sj( zwy(:,:,:) ) 
    403435         ENDIF 
    404436 
    … …  
    524556         END IF 
    525557         !                                 ! "Poleward" heat and salt transports (contribution of upstream fluxes) 
    526          IF( cdtype == 'TRA' .AND. ln_diaptr .AND. ( MOD( kt, nn_fptr ) == 0 ) ) THEN   
    527            IF( jn == jp_tem )  htr_adv(:) = ptr_vj( zwy(:,:,:) ) + htr_adv(:) 
    528            IF( jn == jp_sal )  str_adv(:) = ptr_vj( zwy(:,:,:) ) + str_adv(:) 
     558         IF( cdtype == 'TRA' .AND. ln_diaptr ) THEN   
     559           IF( jn == jp_tem )  htr_adv(:) = ptr_sj( zwy(:,:,:) ) + htr_adv(:) 
     560           IF( jn == jp_sal )  str_adv(:) = ptr_sj( zwy(:,:,:) ) + str_adv(:) 
    529561         ENDIF 
    530562         ! 
    … …  
    580612         &        paft * tmask + zbig * ( 1._wp - tmask )  ) 
    581613 
    582       DO jj = 2, jpjm1 
    583          DO ji = fs_2, fs_jpim1   ! vector opt. 
    584             DO jk = mikt(ji,jj), jpkm1 
    585                ikm1 = MAX(jk-1,mikt(ji,jj)) 
    586                z2dtt = p2dt(jk) 
    587                 
     614      DO jk = 1, jpkm1 
     615         ikm1 = MAX(jk-1,1) 
     616         z2dtt = p2dt(jk) 
     617         DO jj = 2, jpjm1 
     618            DO ji = fs_2, fs_jpim1   ! vector opt. 
     619 
    588620               ! search maximum in neighbourhood 
    589621               zup = MAX(  zbup(ji  ,jj  ,jk  ),   & 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/TRA/traadv_ubs.F90

    r5312 r5313  
    177177         END IF 
    178178         !                                 ! "Poleward" heat and salt transports (contribution of upstream fluxes) 
    179          IF( cdtype == 'TRA' .AND. ln_diaptr .AND. ( MOD( kt, nn_fptr ) == 0 ) ) THEN   
    180             IF( jn == jp_tem )  htr_adv(:) = ptr_vj( ztv(:,:,:) ) 
    181             IF( jn == jp_sal )  str_adv(:) = ptr_vj( ztv(:,:,:) ) 
     179         IF( cdtype == 'TRA' .AND. ln_diaptr ) THEN   
     180            IF( jn == jp_tem )  htr_adv(:) = ptr_sj( ztv(:,:,:) ) 
     181            IF( jn == jp_sal )  str_adv(:) = ptr_sj( ztv(:,:,:) ) 
    182182         ENDIF 
    183183          

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/TRA/traldf.F90

    r5312 r5313  
    290290      IF(lwp) WRITE(numout,*) '              homogeneous ocean T = ', zt0, ' S = ',zs0 
    291291 
     292      ! Initialisation of gtui/gtvi in case of no cavity 
     293      IF ( .NOT. ln_isfcav ) THEN 
     294         gtui(:,:,:) = 0.0_wp 
     295         gtvi(:,:,:) = 0.0_wp 
     296      END IF 
    292297      !                                        ! T & S profile (to be coded +namelist parameter 
    293298 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/TRA/traldf_bilap.F90

    r5312 r5313  
    116116               END DO 
    117117            END DO 
    118  
    119118            !                          !==  Laplacian  ==! 
    120119            ! 
    … …  
    125124               END DO 
    126125            END DO 
     126            ! 
    127127            IF( ln_zps ) THEN                ! set gradient at partial step level (last ocean level) 
    128128               DO jj = 1, jpjm1 
    … …  
    130130                     IF( mbku(ji,jj) == jk )  ztu(ji,jj,jk) = zeeu(ji,jj) * pgu(ji,jj,jn) 
    131131                     IF( mbkv(ji,jj) == jk )  ztv(ji,jj,jk) = zeev(ji,jj) * pgv(ji,jj,jn) 
    132                      ! (ISH) 
    133                      IF( miku(ji,jj) == jk )  ztu(ji,jj,jk) = zeeu(ji,jj) * pgui(ji,jj,jn) 
    134                      IF( mikv(ji,jj) == jk )  ztu(ji,jj,jk) = zeev(ji,jj) * pgvi(ji,jj,jn) 
    135132                  END DO 
    136133               END DO 
    137134            ENDIF 
     135            ! (ISH) 
     136            IF( ln_zps .AND. ln_isfcav ) THEN ! set gradient at partial step level (first ocean level in a cavity) 
     137               DO jj = 1, jpjm1 
     138                  DO ji = 1, jpim1 
     139                     IF( miku(ji,jj) == MAX(jk,2) )  ztu(ji,jj,jk) = zeeu(ji,jj) * pgui(ji,jj,jn) 
     140                     IF( mikv(ji,jj) == MAX(jk,2) )  ztu(ji,jj,jk) = zeev(ji,jj) * pgvi(ji,jj,jn) 
     141                  END DO 
     142               END DO 
     143            ENDIF 
     144            ! 
    138145            DO jj = 2, jpjm1                 ! Second derivative (divergence) time the eddy diffusivity coefficient 
    139146               DO ji = fs_2, fs_jpim1   ! vector opt. 
    … …  
    166173         !                                                 
    167174         ! "zonal" mean lateral diffusive heat and salt transport 
    168          IF( cdtype == 'TRA' .AND. ln_diaptr .AND. ( MOD( kt, nn_fptr ) == 0 ) ) THEN   
    169            IF( jn == jp_tem )  htr_ldf(:) = ptr_vj( ztv(:,:,:) ) 
    170            IF( jn == jp_sal )  str_ldf(:) = ptr_vj( ztv(:,:,:) ) 
     175         IF( cdtype == 'TRA' .AND. ln_diaptr ) THEN   
     176           IF( jn == jp_tem )  htr_ldf(:) = ptr_sj( ztv(:,:,:) ) 
     177           IF( jn == jp_sal )  str_ldf(:) = ptr_sj( ztv(:,:,:) ) 
    171178         ENDIF 
    172179         !                                                ! =========== 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/TRA/traldf_bilapg.F90

    r5312 r5313  
    247247         !                                                ! =============== 
    248248         ! "Poleward" diffusive heat or salt transport 
    249          IF( cdtype == 'TRA' .AND. ln_diaptr .AND. ( kaht == 2 ) .AND. ( MOD( kt, nn_fptr ) == 0 ) ) THEN 
     249         IF( cdtype == 'TRA' .AND. ln_diaptr .AND. ( kaht == 2 ) ) THEN 
    250250            ! note sign is reversed to give down-gradient diffusive transports (#1043) 
    251             IF( jn == jp_tem)   htr_ldf(:) = ptr_vj( -zftv(:,:,:) ) 
    252             IF( jn == jp_sal)   str_ldf(:) = ptr_vj( -zftv(:,:,:) ) 
     251            IF( jn == jp_tem)   htr_ldf(:) = ptr_sj( -zftv(:,:,:) ) 
     252            IF( jn == jp_sal)   str_ldf(:) = ptr_sj( -zftv(:,:,:) ) 
    253253         ENDIF 
    254254 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/TRA/traldf_iso.F90

    r5312 r5313  
    2828   USE in_out_manager  ! I/O manager 
    2929   USE iom             ! I/O library 
    30 #if defined key_diaar5 
    3130   USE phycst          ! physical constants 
    3231   USE lbclnk          ! ocean lateral boundary conditions (or mpp link) 
    33 #endif 
    3432   USE wrk_nemo        ! Memory Allocation 
    3533   USE timing          ! Timing 
    … …  
    106104      ! 
    107105      INTEGER  ::  ji, jj, jk, jn   ! dummy loop indices 
     106      INTEGER  ::  ikt 
    108107      REAL(wp) ::  zmsku, zabe1, zcof1, zcoef3   ! local scalars 
    109108      REAL(wp) ::  zmskv, zabe2, zcof2, zcoef4   !   -      - 
    110109      REAL(wp) ::  zcoef0, zbtr, ztra            !   -      - 
    111 #if defined key_diaar5 
    112       REAL(wp)                         ::   zztmp               ! local scalar 
    113 #endif 
    114110      REAL(wp), POINTER, DIMENSION(:,:  ) ::  z2d 
    115111      REAL(wp), POINTER, DIMENSION(:,:,:) ::  zdkt, zdk1t, zdit, zdjt, ztfw  
    … …  
    149145            END DO 
    150146         END DO 
     147 
     148         ! partial cell correction 
    151149         IF( ln_zps ) THEN      ! partial steps correction at the last ocean level  
    152150            DO jj = 1, jpjm1 
    153151               DO ji = 1, fs_jpim1   ! vector opt. 
    154152! IF useless if zpshde defines pgu everywhere 
    155                   IF (mbku(ji,jj) > 1) zdit(ji,jj,mbku(ji,jj)) = pgu(ji,jj,jn)           
    156                   IF (mbkv(ji,jj) > 1) zdjt(ji,jj,mbkv(ji,jj)) = pgv(ji,jj,jn) 
    157                   ! (ISF) 
     153                  zdit(ji,jj,mbku(ji,jj)) = pgu(ji,jj,jn)           
     154                  zdjt(ji,jj,mbkv(ji,jj)) = pgv(ji,jj,jn) 
     155               END DO 
     156            END DO 
     157         ENDIF 
     158         IF( ln_zps .AND. ln_isfcav ) THEN      ! partial steps correction at the first wet level beneath a cavity 
     159            DO jj = 1, jpjm1 
     160               DO ji = 1, fs_jpim1   ! vector opt. 
    158161                  IF (miku(ji,jj) > 1) zdit(ji,jj,miku(ji,jj)) = pgui(ji,jj,jn)           
    159162                  IF (mikv(ji,jj) > 1) zdjt(ji,jj,mikv(ji,jj)) = pgvi(ji,jj,jn)      
    160163               END DO 
    161164            END DO 
    162          ENDIF 
     165         END IF 
    163166 
    164167         !!---------------------------------------------------------------------- 
    165168         !!   II - horizontal trend  (full) 
    166169         !!---------------------------------------------------------------------- 
    167 !CDIR PARALLEL DO PRIVATE( zdk1t )  
    168          !                                                ! =============== 
    169          DO jj = 1, jpj                                 ! Horizontal slab 
    170             !                                             ! =============== 
    171             DO ji = 1, jpi   ! vector opt. 
    172                DO jk = mikt(ji,jj), jpkm1 
    173                ! 1. Vertical tracer gradient at level jk and jk+1 
    174                ! ------------------------------------------------ 
    175                ! surface boundary condition: zdkt(jk=1)=zdkt(jk=2) 
    176                   zdk1t(ji,jj,jk) = ( ptb(ji,jj,jk,jn) - ptb(ji,jj,jk+1,jn) ) * tmask(ji,jj,jk+1) 
    177                ! 
    178                   IF( jk == mikt(ji,jj) ) THEN  ;   zdkt(ji,jj,jk) = zdk1t(ji,jj,jk) 
    179                   ELSE                          ;   zdkt(ji,jj,jk) = ( ptb(ji,jj,jk-1,jn) - ptb(ji,jj,jk,jn) ) * tmask(ji,jj,jk) 
    180                   ENDIF 
     170!!!!!!!!!!CDIR PARALLEL DO PRIVATE( zdk1t )  
     171            ! 1. Vertical tracer gradient at level jk and jk+1 
     172            ! ------------------------------------------------ 
     173         !  
     174         ! interior value  
     175         DO jk = 2, jpkm1                
     176            DO jj = 1, jpj 
     177               DO ji = 1, jpi   ! vector opt. 
     178                  zdk1t(ji,jj,jk) = ( ptb(ji,jj,jk,jn  ) - ptb(ji,jj,jk+1,jn) ) * wmask(ji,jj,jk+1) 
     179                  ! 
     180                  zdkt(ji,jj,jk)  = ( ptb(ji,jj,jk-1,jn) - ptb(ji,jj,jk,jn  ) ) * wmask(ji,jj,jk) 
    181181               END DO 
    182182            END DO 
    183183         END DO 
    184  
    185             ! 2. Horizontal fluxes 
    186             ! --------------------    
    187          DO jj = 1 , jpjm1 
    188             DO ji = 1, fs_jpim1   ! vector opt. 
    189                DO jk = mikt(ji,jj), jpkm1 
     184         ! surface boundary condition: zdkt(jk=1)=zdkt(jk=2) 
     185         zdk1t(:,:,1) = ( ptb(:,:,1,jn  ) - ptb(:,:,2,jn) ) * wmask(:,:,2) 
     186         zdkt (:,:,1) = zdk1t(:,:,1) 
     187         IF ( ln_isfcav ) THEN 
     188            DO jj = 1, jpj 
     189               DO ji = 1, jpi   ! vector opt. 
     190                  ikt = mikt(ji,jj) ! surface level 
     191                  zdk1t(ji,jj,ikt) = ( ptb(ji,jj,ikt,jn  ) - ptb(ji,jj,ikt+1,jn) ) * wmask(ji,jj,ikt+1) 
     192                  zdkt (ji,jj,ikt) = zdk1t(ji,jj,ikt) 
     193               END DO 
     194            END DO 
     195         END IF 
     196 
     197         ! 2. Horizontal fluxes 
     198         ! --------------------    
     199         DO jk = 1, jpkm1 
     200            DO jj = 1 , jpjm1 
     201               DO ji = 1, fs_jpim1   ! vector opt. 
    190202                  zabe1 = ( fsahtu(ji,jj,jk) + pahtb0 ) * re2u_e1u(ji,jj) * fse3u_n(ji,jj,jk) 
    191203                  zabe2 = ( fsahtv(ji,jj,jk) + pahtb0 ) * re1v_e2v(ji,jj) * fse3v_n(ji,jj,jk) 
    … …  
    208220               END DO 
    209221            END DO 
    210          END DO 
    211222 
    212223            ! II.4 Second derivative (divergence) and add to the general trend 
    213224            ! ---------------------------------------------------------------- 
    214          DO jj = 2 , jpjm1 
    215             DO ji = fs_2, fs_jpim1   ! vector opt. 
    216                DO jk = mikt(ji,jj), jpkm1 
    217                   zbtr = 1.0 / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 
     225            DO jj = 2 , jpjm1 
     226               DO ji = fs_2, fs_jpim1   ! vector opt. 
     227                  zbtr = 1.0 / ( e12t(ji,jj) * fse3t_n(ji,jj,jk) ) 
    218228                  ztra = zbtr * ( zftu(ji,jj,jk) - zftu(ji-1,jj,jk) + zftv(ji,jj,jk) - zftv(ji,jj-1,jk)  ) 
    219229                  pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) + ztra 
    … …  
    225235         ! 
    226236         ! "Poleward" diffusive heat or salt transports (T-S case only) 
    227          IF( cdtype == 'TRA' .AND. ln_diaptr .AND. ( MOD( kt, nn_fptr ) == 0 ) ) THEN 
     237         IF( cdtype == 'TRA' .AND. ln_diaptr ) THEN 
    228238            ! note sign is reversed to give down-gradient diffusive transports (#1043) 
    229             IF( jn == jp_tem)   htr_ldf(:) = ptr_vj( -zftv(:,:,:) ) 
    230             IF( jn == jp_sal)   str_ldf(:) = ptr_vj( -zftv(:,:,:) ) 
     239            IF( jn == jp_tem)   htr_ldf(:) = ptr_sj( -zftv(:,:,:) ) 
     240            IF( jn == jp_sal)   str_ldf(:) = ptr_sj( -zftv(:,:,:) ) 
    231241         ENDIF 
    232242  
    233 #if defined key_diaar5 
    234          IF( cdtype == 'TRA' .AND. jn == jp_tem  ) THEN 
    235             z2d(:,:) = 0._wp  
    236             ! note sign is reversed to give down-gradient diffusive transports (#1043) 
    237             zztmp = -1.0_wp * rau0 * rcp 
    238             DO jk = 1, jpkm1 
    239                DO jj = 2, jpjm1 
    240                   DO ji = fs_2, fs_jpim1   ! vector opt. 
    241                      z2d(ji,jj) = z2d(ji,jj) + zftu(ji,jj,jk)  
     243         IF( iom_use("udiff_heattr") .OR. iom_use("vdiff_heattr") ) THEN 
     244           ! 
     245           IF( cdtype == 'TRA' .AND. jn == jp_tem  ) THEN 
     246               z2d(:,:) = 0._wp  
     247               DO jk = 1, jpkm1 
     248                  DO jj = 2, jpjm1 
     249                     DO ji = fs_2, fs_jpim1   ! vector opt. 
     250                        z2d(ji,jj) = z2d(ji,jj) + zftu(ji,jj,jk)  
     251                     END DO 
    242252                  END DO 
    243253               END DO 
    244             END DO 
    245             z2d(:,:) = zztmp * z2d(:,:) 
    246             CALL lbc_lnk( z2d, 'U', -1. ) 
    247             CALL iom_put( "udiff_heattr", z2d )                  ! heat transport in i-direction 
    248             z2d(:,:) = 0._wp  
    249             DO jk = 1, jpkm1 
    250                DO jj = 2, jpjm1 
    251                   DO ji = fs_2, fs_jpim1   ! vector opt. 
    252                      z2d(ji,jj) = z2d(ji,jj) + zftv(ji,jj,jk)  
     254               z2d(:,:) = - rau0_rcp * z2d(:,:)     ! note sign is reversed to give down-gradient diffusive transports (#1043) 
     255               CALL lbc_lnk( z2d, 'U', -1. ) 
     256               CALL iom_put( "udiff_heattr", z2d )                  ! heat transport in i-direction 
     257               ! 
     258               z2d(:,:) = 0._wp  
     259               DO jk = 1, jpkm1 
     260                  DO jj = 2, jpjm1 
     261                     DO ji = fs_2, fs_jpim1   ! vector opt. 
     262                        z2d(ji,jj) = z2d(ji,jj) + zftv(ji,jj,jk)  
     263                     END DO 
    253264                  END DO 
    254265               END DO 
    255             END DO 
    256             z2d(:,:) = zztmp * z2d(:,:) 
    257             CALL lbc_lnk( z2d, 'V', -1. ) 
    258             CALL iom_put( "vdiff_heattr", z2d )                  !  heat transport in i-direction 
    259          END IF 
    260 #endif 
     266               z2d(:,:) = - rau0_rcp * z2d(:,:)     ! note sign is reversed to give down-gradient diffusive transports (#1043) 
     267               CALL lbc_lnk( z2d, 'V', -1. ) 
     268               CALL iom_put( "vdiff_heattr", z2d )                  !  heat transport in i-direction 
     269            END IF 
     270            ! 
     271         ENDIF 
    261272 
    262273         !!---------------------------------------------------------------------- 
    … …  
    278289            DO jj = 2, jpjm1 
    279290               DO ji = fs_2, fs_jpim1   ! vector opt. 
    280                   zcoef0 = - fsahtw(ji,jj,jk) * tmask(ji,jj,jk) * tmask(ji,jj,jk-1) 
     291                  zcoef0 = - fsahtw(ji,jj,jk) * wmask(ji,jj,jk) 
    281292                  ! 
    282293                  zmsku = 1./MAX(   umask(ji  ,jj,jk-1) + umask(ji-1,jj,jk)      & 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/TRA/traldf_iso_grif.F90

    r5312 r5313  
    113113      REAL(wp) ::   ze1ur, zdxt, ze2vr, ze3wr, zdyt, zdzt 
    114114      REAL(wp) ::   zah, zah_slp, zaei_slp 
    115 #if defined key_diaar5 
    116       REAL(wp) ::   zztmp              ! local scalar 
    117 #endif 
    118115      REAL(wp), POINTER, DIMENSION(:,:  ) :: z2d 
    119116      REAL(wp), POINTER, DIMENSION(:,:,:) :: zdit, zdjt, ztfw  
    … …  
    207204      END DO 
    208205      ! 
    209 #if defined key_iomput 
    210       IF( ln_traldf_gdia .AND. cdtype == 'TRA' ) THEN 
    211          CALL wrk_alloc( jpi , jpj , jpk  , zw3d ) 
    212          DO jk=1,jpkm1 
    213             zw3d(:,:,jk) = (psix_eiv(:,:,jk+1) - psix_eiv(:,:,jk))/fse3u(:,:,jk)  ! u_eiv = -dpsix/dz 
    214          END DO 
    215          zw3d(:,:,jpk) = 0._wp 
    216          CALL iom_put( "uoce_eiv", zw3d )    ! i-eiv current 
    217  
    218          DO jk=1,jpk-1 
    219             zw3d(:,:,jk) = (psiy_eiv(:,:,jk+1) - psiy_eiv(:,:,jk))/fse3v(:,:,jk)  ! v_eiv = -dpsiy/dz 
    220          END DO 
    221          zw3d(:,:,jpk) = 0._wp 
    222          CALL iom_put( "voce_eiv", zw3d )    ! j-eiv current 
    223  
    224          DO jk=1,jpk-1 
    225             DO jj = 2, jpjm1 
    226                DO ji = fs_2, fs_jpim1  ! vector opt. 
    227                   zw3d(ji,jj,jk) = (psiy_eiv(ji,jj,jk) - psiy_eiv(ji,jj-1,jk))/e2t(ji,jj) + & 
    228                        &    (psix_eiv(ji,jj,jk) - psix_eiv(ji-1,jj,jk))/e1t(ji,jj) ! w_eiv = dpsiy/dy + dpsiy/dx 
    229                END DO 
    230             END DO 
    231          END DO 
    232          zw3d(:,:,jpk) = 0._wp 
    233          CALL iom_put( "woce_eiv", zw3d )    ! vert. eiv current 
    234          CALL wrk_dealloc( jpi , jpj , jpk  , zw3d ) 
     206      IF( iom_use("uoce_eiv") .OR. iom_use("voce_eiv") .OR. iom_use("woce_eiv") )  THEN 
     207         ! 
     208         IF( ln_traldf_gdia .AND. cdtype == 'TRA' ) THEN 
     209            CALL wrk_alloc( jpi , jpj , jpk  , zw3d ) 
     210            DO jk=1,jpkm1 
     211               zw3d(:,:,jk) = (psix_eiv(:,:,jk+1) - psix_eiv(:,:,jk))/fse3u(:,:,jk)  ! u_eiv = -dpsix/dz 
     212            END DO 
     213            zw3d(:,:,jpk) = 0._wp 
     214            CALL iom_put( "uoce_eiv", zw3d )    ! i-eiv current 
     215 
     216            DO jk=1,jpk-1 
     217               zw3d(:,:,jk) = (psiy_eiv(:,:,jk+1) - psiy_eiv(:,:,jk))/fse3v(:,:,jk)  ! v_eiv = -dpsiy/dz 
     218            END DO 
     219            zw3d(:,:,jpk) = 0._wp 
     220            CALL iom_put( "voce_eiv", zw3d )    ! j-eiv current 
     221 
     222            DO jk=1,jpk-1 
     223               DO jj = 2, jpjm1 
     224                  DO ji = fs_2, fs_jpim1  ! vector opt. 
     225                     zw3d(ji,jj,jk) = (psiy_eiv(ji,jj,jk) - psiy_eiv(ji,jj-1,jk))/e2t(ji,jj) + & 
     226                          &    (psix_eiv(ji,jj,jk) - psix_eiv(ji-1,jj,jk))/e1t(ji,jj) ! w_eiv = dpsiy/dy + dpsiy/dx 
     227                  END DO 
     228               END DO 
     229            END DO 
     230            zw3d(:,:,jpk) = 0._wp 
     231            CALL iom_put( "woce_eiv", zw3d )    ! vert. eiv current 
     232            CALL wrk_dealloc( jpi , jpj , jpk  , zw3d ) 
     233         ENDIF 
     234         ! 
    235235      ENDIF 
    236 #endif 
    237236      !                                                          ! =========== 
    238237      DO jn = 1, kjpt                                            ! tracer loop 
    … …  
    387386         ! 
    388387         !                             ! "Poleward" diffusive heat or salt transports (T-S case only) 
    389          IF( cdtype == 'TRA' .AND. ln_diaptr .AND. ( MOD( kt, nn_fptr ) == 0 ) ) THEN 
    390             IF( jn == jp_tem)   htr_ldf(:) = ptr_vj( zftv(:,:,:) )        ! 3.3  names 
    391             IF( jn == jp_sal)   str_ldf(:) = ptr_vj( zftv(:,:,:) ) 
     388         IF( cdtype == 'TRA' .AND. ln_diaptr ) THEN 
     389            IF( jn == jp_tem)   htr_ldf(:) = ptr_sj( zftv(:,:,:) )        ! 3.3  names 
     390            IF( jn == jp_sal)   str_ldf(:) = ptr_sj( zftv(:,:,:) ) 
    392391         ENDIF 
    393392 
    394 #if defined key_diaar5 
    395          IF( cdtype == 'TRA' .AND. jn == jp_tem  ) THEN 
    396             z2d(:,:) = 0._wp 
    397             zztmp = rau0 * rcp 
    398             DO jk = 1, jpkm1 
    399                DO jj = 2, jpjm1 
    400                   DO ji = fs_2, fs_jpim1   ! vector opt. 
    401                      z2d(ji,jj) = z2d(ji,jj) + zftu(ji,jj,jk) 
    402                   END DO 
    403                END DO 
    404             END DO 
    405             z2d(:,:) = zztmp * z2d(:,:) 
    406             CALL lbc_lnk( z2d, 'U', -1. ) 
    407             CALL iom_put( "udiff_heattr", z2d )                  ! heat transport in i-direction 
    408             z2d(:,:) = 0._wp 
    409             DO jk = 1, jpkm1 
    410                DO jj = 2, jpjm1 
    411                   DO ji = fs_2, fs_jpim1   ! vector opt. 
    412                      z2d(ji,jj) = z2d(ji,jj) + zftv(ji,jj,jk) 
    413                   END DO 
    414                END DO 
    415             END DO 
    416             z2d(:,:) = zztmp * z2d(:,:) 
    417             CALL lbc_lnk( z2d, 'V', -1. ) 
    418             CALL iom_put( "vdiff_heattr", z2d )                  !  heat transport in j-direction 
    419          END IF 
    420 #endif 
     393         IF( iom_use("udiff_heattr") .OR. iom_use("vdiff_heattr") ) THEN 
     394           ! 
     395           IF( cdtype == 'TRA' .AND. jn == jp_tem  ) THEN 
     396               z2d(:,:) = 0._wp  
     397               DO jk = 1, jpkm1 
     398                  DO jj = 2, jpjm1 
     399                     DO ji = fs_2, fs_jpim1   ! vector opt. 
     400                        z2d(ji,jj) = z2d(ji,jj) + zftu(ji,jj,jk)  
     401                     END DO 
     402                  END DO 
     403               END DO 
     404               z2d(:,:) = rau0_rcp * z2d(:,:)  
     405               CALL lbc_lnk( z2d, 'U', -1. ) 
     406               CALL iom_put( "udiff_heattr", z2d )                  ! heat transport in i-direction 
     407               ! 
     408               z2d(:,:) = 0._wp  
     409               DO jk = 1, jpkm1 
     410                  DO jj = 2, jpjm1 
     411                     DO ji = fs_2, fs_jpim1   ! vector opt. 
     412                        z2d(ji,jj) = z2d(ji,jj) + zftv(ji,jj,jk)  
     413                     END DO 
     414                  END DO 
     415               END DO 
     416               z2d(:,:) = rau0_rcp * z2d(:,:)      
     417               CALL lbc_lnk( z2d, 'V', -1. ) 
     418               CALL iom_put( "vdiff_heattr", z2d )                  !  heat transport in i-direction 
     419            END IF 
     420            ! 
     421         ENDIF 
    421422         ! 
    422423      END DO 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/TRA/traldf_lap.F90

    r5312 r5313  
    102102               END DO 
    103103            END DO 
    104             IF( ln_zps ) THEN      ! set gradient at partial step level 
     104            IF( ln_zps ) THEN      ! set gradient at partial step level for the last ocean cell 
    105105               DO jj = 1, jpjm1 
    106106                  DO ji = 1, fs_jpim1   ! vector opt. 
    … …  
    116116                        ztv(ji,jj,jk) = zabe2 * pgv(ji,jj,jn) 
    117117                     ENDIF 
    118                       
    119                      ! (ISH) 
     118                  END DO 
     119               END DO 
     120            ENDIF 
     121            ! (ISH) 
     122            IF( ln_zps .AND. ln_isfcav ) THEN      ! set gradient at partial step level for the first ocean cell 
     123                                                   ! into a cavity 
     124               DO jj = 1, jpjm1 
     125                  DO ji = 1, fs_jpim1   ! vector opt. 
    120126                     ! ice shelf level level MAX(2,jk) => only where ice shelf 
    121127                     iku = miku(ji,jj)  
    … …  
    148154         ! 
    149155         ! "Poleward" diffusive heat or salt transports 
    150          IF( cdtype == 'TRA' .AND. ln_diaptr .AND. ( MOD( kt, nn_fptr ) == 0 ) ) THEN 
    151             IF( jn  == jp_tem)   htr_ldf(:) = ptr_vj( ztv(:,:,:) ) 
    152             IF( jn  == jp_sal)   str_ldf(:) = ptr_vj( ztv(:,:,:) ) 
     156         IF( cdtype == 'TRA' .AND. ln_diaptr ) THEN 
     157            IF( jn  == jp_tem)   htr_ldf(:) = ptr_sj( ztv(:,:,:) ) 
     158            IF( jn  == jp_sal)   str_ldf(:) = ptr_sj( ztv(:,:,:) ) 
    153159         ENDIF 
    154160         !                                                  ! ================== 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/TRA/trasbc.F90

    r5312 r5313  
    99   !!            3.3  !  2010-04  (M. Leclair, G. Madec)  Forcing averaged over 2 time steps 
    1010   !!             -   !  2010-09  (C. Ethe, G. Madec) Merge TRA-TRC 
     11   !!            3.6  !  2014-11  (P. Mathiot) isf melting forcing  
    1112   !!---------------------------------------------------------------------- 
    1213 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/TRA/trazdf_imp.F90

    r5312 r5313  
    122122            DO jj=1, jpj 
    123123               DO ji=1, jpi 
    124                   zwt(ji,jj,1:mikt(ji,jj)) = 0._wp 
     124                  zwt(ji,jj,1) = 0._wp 
    125125               END DO 
    126126            END DO 
    … …  
    184184            DO jj = 2, jpjm1 
    185185               DO ji = fs_2, fs_jpim1 
    186                   zwt(ji,jj,1:mikt(ji,jj)) = zwd(ji,jj,1:mikt(ji,jj)) 
    187                   DO jk = mikt(ji,jj)+1, jpkm1 
     186                  zwt(ji,jj,1) = zwd(ji,jj,1) 
     187               END DO 
     188            END DO 
     189            DO jk = 2, jpkm1 
     190               DO jj = 2, jpjm1 
     191                  DO ji = fs_2, fs_jpim1 
    188192                     zwt(ji,jj,jk) = zwd(ji,jj,jk) - zwi(ji,jj,jk) * zws(ji,jj,jk-1) / zwt(ji,jj,jk-1) 
    189193                  END DO 
    … …  
    196200         DO jj = 2, jpjm1 
    197201            DO ji = fs_2, fs_jpim1 
    198                ze3tb = ( 1. - r_vvl ) + r_vvl * fse3t_b(ji,jj,mikt(ji,jj)) 
    199                ze3tn = ( 1. - r_vvl ) + r_vvl * fse3t(ji,jj,mikt(ji,jj)) 
    200                pta(ji,jj,mikt(ji,jj),jn) = ze3tb * ptb(ji,jj,mikt(ji,jj),jn)                     & 
    201                   &                      + p2dt(mikt(ji,jj)) * ze3tn * pta(ji,jj,mikt(ji,jj),jn) 
    202                DO jk = mikt(ji,jj)+1, jpkm1 
     202               ze3tb = ( 1. - r_vvl ) + r_vvl * fse3t_b(ji,jj,1) 
     203               ze3tn = ( 1. - r_vvl ) + r_vvl * fse3t(ji,jj,1) 
     204               pta(ji,jj,1,jn) = ze3tb * ptb(ji,jj,1,jn)                     & 
     205                  &                      + p2dt(1) * ze3tn * pta(ji,jj,1,jn) 
     206            END DO 
     207         END DO 
     208         DO jk = 2, jpkm1 
     209            DO jj = 2, jpjm1 
     210               DO ji = fs_2, fs_jpim1 
    203211                  ze3tb = ( 1. - r_vvl ) + r_vvl * fse3t_b(ji,jj,jk) 
    204212                  ze3tn = ( 1. - r_vvl ) + r_vvl * fse3t  (ji,jj,jk) 
    … …  
    213221            DO ji = fs_2, fs_jpim1 
    214222               pta(ji,jj,jpkm1,jn) = pta(ji,jj,jpkm1,jn) / zwt(ji,jj,jpkm1) * tmask(ji,jj,jpkm1) 
    215                DO jk = jpk-2, mikt(ji,jj), -1 
     223            END DO 
     224         END DO 
     225         DO jk = jpk-2, 1, -1 
     226            DO jj = 2, jpjm1 
     227               DO ji = fs_2, fs_jpim1 
    216228                  pta(ji,jj,jk,jn) = ( pta(ji,jj,jk,jn) - zws(ji,jj,jk) * pta(ji,jj,jk+1,jn) )   & 
    217229                     &             / zwt(ji,jj,jk) * tmask(ji,jj,jk) 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/TRA/zpshde.F90

    r5312 r5313  
    88   !!             -   !  2004-03  (C. Ethe)  adapted for passive tracers 
    99   !!            3.3  !  2010-05  (C. Ethe, G. Madec)  merge TRC-TRA  
     10   !!            3.6  !  2014-11  (P. Mathiot) Add zps_hde_isf (needed to open a cavity) 
    1011   !!====================================================================== 
    1112    
    … …  
    2728   PRIVATE 
    2829 
    29    PUBLIC   zps_hde    ! routine called by step.F90 
     30   PUBLIC   zps_hde     ! routine called by step.F90 
     31   PUBLIC   zps_hde_isf ! routine called by step.F90 
    3032 
    3133   !! * Substitutions 
    … …  
    4042 
    4143   SUBROUTINE zps_hde( kt, kjpt, pta, pgtu, pgtv,   & 
     44      &                          prd, pgru, pgrv    ) 
     45      !!---------------------------------------------------------------------- 
     46      !!                     ***  ROUTINE zps_hde  *** 
     47      !!                     
     48      !! ** Purpose :   Compute the horizontal derivative of T, S and rho 
     49      !!      at u- and v-points with a linear interpolation for z-coordinate 
     50      !!      with partial steps. 
     51      !! 
     52      !! ** Method  :   In z-coord with partial steps, scale factors on last  
     53      !!      levels are different for each grid point, so that T, S and rd  
     54      !!      points are not at the same depth as in z-coord. To have horizontal 
     55      !!      gradients again, we interpolate T and S at the good depth :  
     56      !!      Linear interpolation of T, S    
     57      !!         Computation of di(tb) and dj(tb) by vertical interpolation: 
     58      !!          di(t) = t~ - t(i,j,k) or t(i+1,j,k) - t~ 
     59      !!          dj(t) = t~ - t(i,j,k) or t(i,j+1,k) - t~ 
     60      !!         This formulation computes the two cases: 
     61      !!                 CASE 1                   CASE 2   
     62      !!         k-1  ___ ___________   k-1   ___ ___________ 
     63      !!                    Ti  T~                  T~  Ti+1 
     64      !!                  _____                        _____ 
     65      !!         k        |   |Ti+1     k           Ti |   | 
     66      !!                  |   |____                ____|   | 
     67      !!              ___ |   |   |           ___  |   |   | 
     68      !!                   
     69      !!      case 1->   e3w(i+1) >= e3w(i) ( and e3w(j+1) >= e3w(j) ) then 
     70      !!          t~ = t(i+1,j  ,k) + (e3w(i+1) - e3w(i)) * dk(Ti+1)/e3w(i+1) 
     71      !!        ( t~ = t(i  ,j+1,k) + (e3w(j+1) - e3w(j)) * dk(Tj+1)/e3w(j+1)  ) 
     72      !!          or 
     73      !!      case 2->   e3w(i+1) <= e3w(i) ( and e3w(j+1) <= e3w(j) ) then 
     74      !!          t~ = t(i,j,k) + (e3w(i) - e3w(i+1)) * dk(Ti)/e3w(i ) 
     75      !!        ( t~ = t(i,j,k) + (e3w(j) - e3w(j+1)) * dk(Tj)/e3w(j ) ) 
     76      !!          Idem for di(s) and dj(s)           
     77      !! 
     78      !!      For rho, we call eos which will compute rd~(t~,s~) at the right 
     79      !!      depth zh from interpolated T and S for the different formulations 
     80      !!      of the equation of state (eos). 
     81      !!      Gradient formulation for rho : 
     82      !!          di(rho) = rd~ - rd(i,j,k)   or   rd(i+1,j,k) - rd~ 
     83      !! 
     84      !! ** Action  : compute for top interfaces 
     85      !!              - pgtu, pgtv: horizontal gradient of tracer at u- & v-points 
     86      !!              - pgru, pgrv: horizontal gradient of rho (if present) at u- & v-points 
     87      !!---------------------------------------------------------------------- 
     88      INTEGER                              , INTENT(in   )           ::  kt          ! ocean time-step index 
     89      INTEGER                              , INTENT(in   )           ::  kjpt        ! number of tracers 
     90      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   )           ::  pta         ! 4D tracers fields 
     91      REAL(wp), DIMENSION(jpi,jpj,    kjpt), INTENT(  out)           ::  pgtu, pgtv  ! hor. grad. of ptra at u- & v-pts  
     92      REAL(wp), DIMENSION(jpi,jpj,jpk     ), INTENT(in   ), OPTIONAL ::  prd         ! 3D density anomaly fields 
     93      REAL(wp), DIMENSION(jpi,jpj         ), INTENT(  out), OPTIONAL ::  pgru, pgrv  ! hor. grad of prd at u- & v-pts (bottom) 
     94      ! 
     95      INTEGER  ::   ji, jj, jn      ! Dummy loop indices 
     96      INTEGER  ::   iku, ikv, ikum1, ikvm1   ! partial step level (ocean bottom level) at u- and v-points 
     97      REAL(wp) ::  ze3wu, ze3wv, zmaxu, zmaxv  ! temporary scalars 
     98      REAL(wp), DIMENSION(jpi,jpj)      ::  zri, zrj, zhi, zhj   ! NB: 3rd dim=1 to use eos 
     99      REAL(wp), DIMENSION(jpi,jpj,kjpt) ::  zti, ztj             !  
     100      !!---------------------------------------------------------------------- 
     101      ! 
     102      IF( nn_timing == 1 )  CALL timing_start( 'zps_hde') 
     103      ! 
     104      pgtu(:,:,:)=0.0_wp ; pgtv(:,:,:)=0.0_wp ; 
     105      zti (:,:,:)=0.0_wp ; ztj (:,:,:)=0.0_wp ; 
     106      zhi (:,:  )=0.0_wp ; zhj (:,:  )=0.0_wp ; 
     107      ! 
     108      DO jn = 1, kjpt      !==   Interpolation of tracers at the last ocean level   ==! 
     109         ! 
     110         DO jj = 1, jpjm1 
     111            DO ji = 1, jpim1 
     112               iku = mbku(ji,jj)   ;   ikum1 = MAX( iku - 1 , 1 )    ! last and before last ocean level at u- & v-points 
     113               ikv = mbkv(ji,jj)   ;   ikvm1 = MAX( ikv - 1 , 1 )    ! if level first is a p-step, ik.m1=1 
     114               ze3wu = fse3w(ji+1,jj  ,iku) - fse3w(ji,jj,iku) 
     115               ze3wv = fse3w(ji  ,jj+1,ikv) - fse3w(ji,jj,ikv) 
     116               ! 
     117               ! i- direction 
     118               IF( ze3wu >= 0._wp ) THEN      ! case 1 
     119                  zmaxu =  ze3wu / fse3w(ji+1,jj,iku) 
     120                  ! interpolated values of tracers 
     121                  zti (ji,jj,jn) = pta(ji+1,jj,iku,jn) + zmaxu * ( pta(ji+1,jj,ikum1,jn) - pta(ji+1,jj,iku,jn) ) 
     122                  ! gradient of  tracers 
     123                  pgtu(ji,jj,jn) = umask(ji,jj,1) * ( zti(ji,jj,jn) - pta(ji,jj,iku,jn) ) 
     124               ELSE                           ! case 2 
     125                  zmaxu = -ze3wu / fse3w(ji,jj,iku) 
     126                  ! interpolated values of tracers 
     127                  zti (ji,jj,jn) = pta(ji,jj,iku,jn) + zmaxu * ( pta(ji,jj,ikum1,jn) - pta(ji,jj,iku,jn) ) 
     128                  ! gradient of tracers 
     129                  pgtu(ji,jj,jn) = umask(ji,jj,1) * ( pta(ji+1,jj,iku,jn) - zti(ji,jj,jn) ) 
     130               ENDIF 
     131               ! 
     132               ! j- direction 
     133               IF( ze3wv >= 0._wp ) THEN      ! case 1 
     134                  zmaxv =  ze3wv / fse3w(ji,jj+1,ikv) 
     135                  ! interpolated values of tracers 
     136                  ztj (ji,jj,jn) = pta(ji,jj+1,ikv,jn) + zmaxv * ( pta(ji,jj+1,ikvm1,jn) - pta(ji,jj+1,ikv,jn) ) 
     137                  ! gradient of tracers 
     138                  pgtv(ji,jj,jn) = vmask(ji,jj,1) * ( ztj(ji,jj,jn) - pta(ji,jj,ikv,jn) ) 
     139               ELSE                           ! case 2 
     140                  zmaxv =  -ze3wv / fse3w(ji,jj,ikv) 
     141                  ! interpolated values of tracers 
     142                  ztj (ji,jj,jn) = pta(ji,jj,ikv,jn) + zmaxv * ( pta(ji,jj,ikvm1,jn) - pta(ji,jj,ikv,jn) ) 
     143                  ! gradient of tracers 
     144                  pgtv(ji,jj,jn) = vmask(ji,jj,1) * ( pta(ji,jj+1,ikv,jn) - ztj(ji,jj,jn) ) 
     145               ENDIF 
     146            END DO 
     147         END DO 
     148         CALL lbc_lnk( pgtu(:,:,jn), 'U', -1. )   ;   CALL lbc_lnk( pgtv(:,:,jn), 'V', -1. )   ! Lateral boundary cond. 
     149         ! 
     150      END DO 
     151 
     152      ! horizontal derivative of density anomalies (rd) 
     153      IF( PRESENT( prd ) ) THEN         ! depth of the partial step level 
     154         pgru(:,:)=0.0_wp   ; pgrv(:,:)=0.0_wp ;  
     155         DO jj = 1, jpjm1 
     156            DO ji = 1, jpim1 
     157               iku = mbku(ji,jj) 
     158               ikv = mbkv(ji,jj) 
     159               ze3wu  = fse3w(ji+1,jj  ,iku) - fse3w(ji,jj,iku) 
     160               ze3wv  = fse3w(ji  ,jj+1,ikv) - fse3w(ji,jj,ikv) 
     161               IF( ze3wu >= 0._wp ) THEN   ;   zhi(ji,jj) = fsdept(ji  ,jj,iku)     ! i-direction: case 1 
     162               ELSE                        ;   zhi(ji,jj) = fsdept(ji+1,jj,iku)     ! -     -      case 2 
     163               ENDIF 
     164               IF( ze3wv >= 0._wp ) THEN   ;   zhj(ji,jj) = fsdept(ji,jj  ,ikv)     ! j-direction: case 1 
     165               ELSE                        ;   zhj(ji,jj) = fsdept(ji,jj+1,ikv)     ! -     -      case 2 
     166               ENDIF 
     167            END DO 
     168         END DO 
     169 
     170         ! Compute interpolated rd from zti, ztj for the 2 cases at the depth of the partial 
     171         ! step and store it in  zri, zrj for each  case 
     172         CALL eos( zti, zhi, zri )   
     173         CALL eos( ztj, zhj, zrj ) 
     174 
     175         ! Gradient of density at the last level  
     176         DO jj = 1, jpjm1 
     177            DO ji = 1, jpim1 
     178               iku = mbku(ji,jj) 
     179               ikv = mbkv(ji,jj) 
     180               ze3wu  = fse3w(ji+1,jj  ,iku) - fse3w(ji,jj,iku) 
     181               ze3wv  = fse3w(ji  ,jj+1,ikv) - fse3w(ji,jj,ikv) 
     182               IF( ze3wu >= 0._wp ) THEN   ;   pgru(ji,jj) = umask(ji,jj,1) * ( zri(ji  ,jj    ) - prd(ji,jj,iku) )   ! i: 1 
     183               ELSE                        ;   pgru(ji,jj) = umask(ji,jj,1) * ( prd(ji+1,jj,iku) - zri(ji,jj    ) )   ! i: 2 
     184               ENDIF 
     185               IF( ze3wv >= 0._wp ) THEN   ;   pgrv(ji,jj) = vmask(ji,jj,1) * ( zrj(ji,jj      ) - prd(ji,jj,ikv) )   ! j: 1 
     186               ELSE                        ;   pgrv(ji,jj) = vmask(ji,jj,1) * ( prd(ji,jj+1,ikv) - zrj(ji,jj    ) )   ! j: 2 
     187               ENDIF 
     188            END DO 
     189         END DO 
     190         CALL lbc_lnk( pgru , 'U', -1. )   ;   CALL lbc_lnk( pgrv , 'V', -1. )   ! Lateral boundary conditions 
     191         ! 
     192      END IF 
     193      ! 
     194      IF( nn_timing == 1 )  CALL timing_stop( 'zps_hde') 
     195      ! 
     196   END SUBROUTINE zps_hde 
     197   ! 
     198   SUBROUTINE zps_hde_isf( kt, kjpt, pta, pgtu, pgtv,   & 
    42199      &                          prd, pgru, pgrv, pmru, pmrv, pgzu, pgzv, pge3ru, pge3rv,  & 
    43       &                   sgtu, sgtv, sgru, sgrv, smru, smrv, sgzu, sgzv, sge3ru, sge3rv ) 
     200      &                   pgtui, pgtvi, pgrui, pgrvi, pmrui, pmrvi, pgzui, pgzvi, pge3rui, pge3rvi ) 
    44201      !!---------------------------------------------------------------------- 
    45202      !!                     ***  ROUTINE zps_hde  *** 
    … …  
    82239      !! 
    83240      !! ** Action  : compute for top and bottom interfaces 
    84       !!              - pgtu, pgtv, sgtu, sgtv: horizontal gradient of tracer at u- & v-points 
    85       !!              - pgru, pgrv, sgru, sgtv: horizontal gradient of rho (if present) at u- & v-points 
    86       !!              - pmru, pmrv, smru, smrv: horizontal sum of rho at u- & v- point (used in dynhpg with vvl) 
    87       !!              - pgzu, pgzv, sgzu, sgzv: horizontal gradient of z at u- and v- point (used in dynhpg with vvl) 
    88       !!              - pge3ru, pge3rv, sge3ru, sge3rv: horizontal gradient of rho weighted by local e3w at u- & v-points  
     241      !!              - pgtu, pgtv, pgtui, pgtvi: horizontal gradient of tracer at u- & v-points 
     242      !!              - pgru, pgrv, pgrui, pgtvi: horizontal gradient of rho (if present) at u- & v-points 
     243      !!              - pmru, pmrv, pmrui, pmrvi: horizontal sum of rho at u- & v- point (used in dynhpg with vvl) 
     244      !!              - pgzu, pgzv, pgzui, pgzvi: horizontal gradient of z at u- and v- point (used in dynhpg with vvl) 
     245      !!              - pge3ru, pge3rv, pge3rui, pge3rvi: horizontal gradient of rho weighted by local e3w at u- & v-points  
    89246      !!---------------------------------------------------------------------- 
    90247      INTEGER                              , INTENT(in   )           ::  kt          ! ocean time-step index 
    … …  
    92249      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   )           ::  pta         ! 4D tracers fields 
    93250      REAL(wp), DIMENSION(jpi,jpj,    kjpt), INTENT(  out)           ::  pgtu, pgtv  ! hor. grad. of ptra at u- & v-pts  
    94       REAL(wp), DIMENSION(jpi,jpj,    kjpt), INTENT(  out)           ::  sgtu, sgtv  ! hor. grad. of stra at u- & v-pts (ISF) 
     251      REAL(wp), DIMENSION(jpi,jpj,    kjpt), INTENT(  out)           ::  pgtui, pgtvi  ! hor. grad. of stra at u- & v-pts (ISF) 
    95252      REAL(wp), DIMENSION(jpi,jpj,jpk     ), INTENT(in   ), OPTIONAL ::  prd         ! 3D density anomaly fields 
    96253      REAL(wp), DIMENSION(jpi,jpj         ), INTENT(  out), OPTIONAL ::  pgru, pgrv      ! hor. grad of prd at u- & v-pts (bottom) 
    … …  
    98255      REAL(wp), DIMENSION(jpi,jpj         ), INTENT(  out), OPTIONAL ::  pgzu, pgzv      ! hor. grad of z   at u- & v-pts (bottom) 
    99256      REAL(wp), DIMENSION(jpi,jpj         ), INTENT(  out), OPTIONAL ::  pge3ru, pge3rv  ! hor. grad of prd weighted by local e3w at u- & v-pts (bottom) 
    100       REAL(wp), DIMENSION(jpi,jpj         ), INTENT(  out), OPTIONAL ::  sgru, sgrv      ! hor. grad of prd at u- & v-pts (top) 
    101       REAL(wp), DIMENSION(jpi,jpj         ), INTENT(  out), OPTIONAL ::  smru, smrv      ! hor. sum  of prd at u- & v-pts (top) 
    102       REAL(wp), DIMENSION(jpi,jpj         ), INTENT(  out), OPTIONAL ::  sgzu, sgzv      ! hor. grad of z   at u- & v-pts (top) 
    103       REAL(wp), DIMENSION(jpi,jpj         ), INTENT(  out), OPTIONAL ::  sge3ru, sge3rv  ! hor. grad of prd weighted by local e3w at u- & v-pts (top) 
     257      REAL(wp), DIMENSION(jpi,jpj         ), INTENT(  out), OPTIONAL ::  pgrui, pgrvi      ! hor. grad of prd at u- & v-pts (top) 
     258      REAL(wp), DIMENSION(jpi,jpj         ), INTENT(  out), OPTIONAL ::  pmrui, pmrvi      ! hor. sum  of prd at u- & v-pts (top) 
     259      REAL(wp), DIMENSION(jpi,jpj         ), INTENT(  out), OPTIONAL ::  pgzui, pgzvi      ! hor. grad of z   at u- & v-pts (top) 
     260      REAL(wp), DIMENSION(jpi,jpj         ), INTENT(  out), OPTIONAL ::  pge3rui, pge3rvi  ! hor. grad of prd weighted by local e3w at u- & v-pts (top) 
    104261      ! 
    105262      INTEGER  ::   ji, jj, jn      ! Dummy loop indices 
    … …  
    110267      !!---------------------------------------------------------------------- 
    111268      ! 
    112       IF( nn_timing == 1 )  CALL timing_start( 'zps_hde') 
     269      IF( nn_timing == 1 )  CALL timing_start( 'zps_hde_isf') 
    113270      ! 
    114271      pgtu(:,:,:)=0.0_wp ; pgtv(:,:,:)=0.0_wp ; 
    115       sgtu(:,:,:)=0.0_wp ; sgtv(:,:,:)=0.0_wp ; 
     272      pgtui(:,:,:)=0.0_wp ; pgtvi(:,:,:)=0.0_wp ; 
    116273      zti (:,:,:)=0.0_wp ; ztj (:,:,:)=0.0_wp ; 
    117274      zhi (:,:  )=0.0_wp ; zhj (:,:  )=0.0_wp ; 
    … …  
    256413                  zti(ji,jj,jn) = pta(ji+1,jj,iku,jn) + zmaxu * ( pta(ji+1,jj,iku+1,jn) - pta(ji+1,jj,iku,jn) ) 
    257414                  ! gradient of tracers 
    258                   sgtu(ji,jj,jn) = umask(ji,jj,iku) * ( zti(ji,jj,jn) - pta(ji,jj,iku,jn) ) 
     415                  pgtui(ji,jj,jn) = umask(ji,jj,iku) * ( zti(ji,jj,jn) - pta(ji,jj,iku,jn) ) 
    259416               ELSE                           ! case 2 
    260417                  zmaxu = - ze3wu / fse3w(ji,jj,iku+1) 
    … …  
    262419                  zti(ji,jj,jn) = pta(ji,jj,iku,jn) + zmaxu * ( pta(ji,jj,iku+1,jn) - pta(ji,jj,iku,jn) ) 
    263420                  ! gradient of  tracers 
    264                   sgtu(ji,jj,jn) = umask(ji,jj,iku) * ( pta(ji+1,jj,iku,jn) - zti(ji,jj,jn) ) 
     421                  pgtui(ji,jj,jn) = umask(ji,jj,iku) * ( pta(ji+1,jj,iku,jn) - zti(ji,jj,jn) ) 
    265422               ENDIF 
    266423               ! 
    … …  
    271428                  ztj(ji,jj,jn) = pta(ji,jj+1,ikv,jn) + zmaxv * ( pta(ji,jj+1,ikv+1,jn) - pta(ji,jj+1,ikv,jn) ) 
    272429                  ! gradient of tracers 
    273                   sgtv(ji,jj,jn) = vmask(ji,jj,ikv) * ( ztj(ji,jj,jn) - pta(ji,jj,ikv,jn) ) 
     430                  pgtvi(ji,jj,jn) = vmask(ji,jj,ikv) * ( ztj(ji,jj,jn) - pta(ji,jj,ikv,jn) ) 
    274431               ELSE                           ! case 2 
    275432                  zmaxv =  - ze3wv / fse3w(ji,jj,ikv+1) 
    … …  
    277434                  ztj(ji,jj,jn) = pta(ji,jj,ikv,jn) + zmaxv * ( pta(ji,jj,ikv+1,jn) - pta(ji,jj,ikv,jn) ) 
    278435                  ! gradient of tracers 
    279                   sgtv(ji,jj,jn) = vmask(ji,jj,ikv) * ( pta(ji,jj+1,ikv,jn) - ztj(ji,jj,jn) ) 
     436                  pgtvi(ji,jj,jn) = vmask(ji,jj,ikv) * ( pta(ji,jj+1,ikv,jn) - ztj(ji,jj,jn) ) 
    280437               ENDIF 
    281438            END DO!! 
    282439         END DO!! 
    283          CALL lbc_lnk( sgtu(:,:,jn), 'U', -1. )   ;   CALL lbc_lnk( sgtv(:,:,jn), 'V', -1. )   ! Lateral boundary cond. 
     440         CALL lbc_lnk( pgtui(:,:,jn), 'U', -1. )   ;   CALL lbc_lnk( pgtvi(:,:,jn), 'V', -1. )   ! Lateral boundary cond. 
    284441         ! 
    285442      END DO 
    … …  
    287444      ! horizontal derivative of density anomalies (rd) 
    288445      IF( PRESENT( prd ) ) THEN         ! depth of the partial step level 
    289          sgru(:,:)  =0.0_wp ; sgrv(:,:)  =0.0_wp ; 
    290          sgzu(:,:)  =0.0_wp ; sgzv(:,:)  =0.0_wp ; 
    291          smru(:,:)  =0.0_wp ; smru(:,:)  =0.0_wp ; 
    292          sge3ru(:,:)=0.0_wp ; sge3rv(:,:)=0.0_wp ; 
     446         pgrui(:,:)  =0.0_wp ; pgrvi(:,:)  =0.0_wp ; 
     447         pgzui(:,:)  =0.0_wp ; pgzvi(:,:)  =0.0_wp ; 
     448         pmrui(:,:)  =0.0_wp ; pmrui(:,:)  =0.0_wp ; 
     449         pge3rui(:,:)=0.0_wp ; pge3rvi(:,:)=0.0_wp ; 
    293450 
    294451         DO jj = 1, jpjm1 
    … …  
    321478               ze3wv  = (gdepw_0(ji,jj+1,ikv+1) - gdept_0(ji,jj+1,ikv)) - (gdepw_0(ji,jj,ikv+1) - gdept_0(ji,jj,ikv)) 
    322479               IF( ze3wu >= 0._wp ) THEN 
    323                  sgzu  (ji,jj) = (fsde3w(ji+1,jj,iku) + ze3wu) - fsde3w(ji,jj,iku) 
    324                  sgru  (ji,jj) = umask(ji,jj,iku)   * ( zri(ji,jj) - prd(ji,jj,iku) )          ! i: 1 
    325                  smru  (ji,jj) = umask(ji,jj,iku)   * ( zri(ji,jj) + prd(ji,jj,iku) )          ! i: 1  
    326                  sge3ru(ji,jj) = umask(ji,jj,iku+1)                                                                  & 
     480                 pgzui  (ji,jj) = (fsde3w(ji+1,jj,iku) + ze3wu) - fsde3w(ji,jj,iku) 
     481                 pgrui  (ji,jj) = umask(ji,jj,iku)   * ( zri(ji,jj) - prd(ji,jj,iku) )          ! i: 1 
     482                 pmrui  (ji,jj) = umask(ji,jj,iku)   * ( zri(ji,jj) + prd(ji,jj,iku) )          ! i: 1  
     483                 pge3rui(ji,jj) = umask(ji,jj,iku+1)                                                                  & 
    327484                                * ( (fse3w(ji+1,jj,iku+1) - ze3wu) * (zri(ji,jj    ) + prd(ji+1,jj,iku+1) + 2._wp)   & 
    328485                                   - fse3w(ji  ,jj,iku+1)          * (prd(ji,jj,iku) + prd(ji  ,jj,iku+1) + 2._wp)   ) ! i: 1 
    329486               ELSE 
    330                  sgzu  (ji,jj) = fsde3w(ji+1,jj,iku) - (fsde3w(ji,jj,iku) - ze3wu) 
    331                  sgru  (ji,jj) = umask(ji,jj,iku)   * ( prd(ji+1,jj,iku) - zri(ji,jj) )      ! i: 2 
    332                  smru  (ji,jj) = umask(ji,jj,iku)   * ( prd(ji+1,jj,iku) + zri(ji,jj) )      ! i: 2 
    333                  sge3ru(ji,jj) = umask(ji,jj,iku+1)                                                                   & 
     487                 pgzui  (ji,jj) = fsde3w(ji+1,jj,iku) - (fsde3w(ji,jj,iku) - ze3wu) 
     488                 pgrui  (ji,jj) = umask(ji,jj,iku)   * ( prd(ji+1,jj,iku) - zri(ji,jj) )      ! i: 2 
     489                 pmrui  (ji,jj) = umask(ji,jj,iku)   * ( prd(ji+1,jj,iku) + zri(ji,jj) )      ! i: 2 
     490                 pge3rui(ji,jj) = umask(ji,jj,iku+1)                                                                   & 
    334491                                * (  fse3w(ji+1,jj,iku+1)          * (prd(ji+1,jj,iku) + prd(ji+1,jj,iku+1) + 2._wp)  & 
    335492                                   -(fse3w(ji  ,jj,iku+1) + ze3wu) * (zri(ji,jj      ) + prd(ji  ,jj,iku+1) + 2._wp)  )     ! i: 2 
    336493               ENDIF 
    337494               IF( ze3wv >= 0._wp ) THEN 
    338                  sgzv  (ji,jj) = (fsde3w(ji,jj+1,ikv) + ze3wv) - fsde3w(ji,jj,ikv)  
    339                  sgrv  (ji,jj) = vmask(ji,jj,ikv)   * ( zrj(ji,jj  ) - prd(ji,jj,ikv) )        ! j: 1 
    340                  smrv  (ji,jj) = vmask(ji,jj,ikv)   * ( zrj(ji,jj  ) + prd(ji,jj,ikv) )        ! j: 1 
    341                  sge3rv(ji,jj) = vmask(ji,jj,ikv+1)                                                                  &  
     495                 pgzvi  (ji,jj) = (fsde3w(ji,jj+1,ikv) + ze3wv) - fsde3w(ji,jj,ikv)  
     496                 pgrvi  (ji,jj) = vmask(ji,jj,ikv)   * ( zrj(ji,jj  ) - prd(ji,jj,ikv) )        ! j: 1 
     497                 pmrvi  (ji,jj) = vmask(ji,jj,ikv)   * ( zrj(ji,jj  ) + prd(ji,jj,ikv) )        ! j: 1 
     498                 pge3rvi(ji,jj) = vmask(ji,jj,ikv+1)                                                                  &  
    342499                                * ( (fse3w(ji,jj+1,ikv+1) - ze3wv) * ( zrj(ji,jj    ) + prd(ji,jj+1,ikv+1) + 2._wp)  & 
    343500                                   - fse3w(ji,jj  ,ikv+1)          * ( prd(ji,jj,ikv) + prd(ji,jj  ,ikv+1) + 2._wp)  ) ! j: 1 
    344501                                  ! + 2 due to the formulation in density and not in anomalie in hpg sco 
    345502               ELSE 
    346                  sgzv  (ji,jj) = fsde3w(ji,jj+1,ikv) - (fsde3w(ji,jj,ikv) - ze3wv) 
    347                  sgrv  (ji,jj) = vmask(ji,jj,ikv)   * ( prd(ji,jj+1,ikv) - zrj(ji,jj) )     ! j: 2 
    348                  smrv  (ji,jj) = vmask(ji,jj,ikv)   * ( prd(ji,jj+1,ikv) + zrj(ji,jj) )     ! j: 2 
    349                  sge3rv(ji,jj) = vmask(ji,jj,ikv+1)                                                                   & 
     503                 pgzvi  (ji,jj) = fsde3w(ji,jj+1,ikv) - (fsde3w(ji,jj,ikv) - ze3wv) 
     504                 pgrvi  (ji,jj) = vmask(ji,jj,ikv)   * ( prd(ji,jj+1,ikv) - zrj(ji,jj) )     ! j: 2 
     505                 pmrvi  (ji,jj) = vmask(ji,jj,ikv)   * ( prd(ji,jj+1,ikv) + zrj(ji,jj) )     ! j: 2 
     506                 pge3rvi(ji,jj) = vmask(ji,jj,ikv+1)                                                                   & 
    350507                                * (  fse3w(ji,jj+1,ikv+1)          * ( prd(ji,jj+1,ikv) + prd(ji,jj+1,ikv+1) + 2._wp) & 
    351508                                   -(fse3w(ji,jj  ,ikv+1) + ze3wv) * ( zrj(ji,jj      ) + prd(ji,jj  ,ikv+1) + 2._wp) )  ! j: 2 
    … …  
    353510            END DO 
    354511         END DO 
    355          CALL lbc_lnk( sgru   , 'U', -1. )   ;   CALL lbc_lnk( sgrv   , 'V', -1. )   ! Lateral boundary conditions 
    356          CALL lbc_lnk( smru   , 'U',  1. )   ;   CALL lbc_lnk( smrv   , 'V',  1. )   ! Lateral boundary conditions 
    357          CALL lbc_lnk( sgzu   , 'U', -1. )   ;   CALL lbc_lnk( sgzv   , 'V', -1. )   ! Lateral boundary conditions 
    358          CALL lbc_lnk( sge3ru , 'U', -1. )   ;   CALL lbc_lnk( sge3rv , 'V', -1. )   ! Lateral boundary conditions 
     512         CALL lbc_lnk( pgrui   , 'U', -1. )   ;   CALL lbc_lnk( pgrvi   , 'V', -1. )   ! Lateral boundary conditions 
     513         CALL lbc_lnk( pmrui   , 'U',  1. )   ;   CALL lbc_lnk( pmrvi   , 'V',  1. )   ! Lateral boundary conditions 
     514         CALL lbc_lnk( pgzui   , 'U', -1. )   ;   CALL lbc_lnk( pgzvi   , 'V', -1. )   ! Lateral boundary conditions 
     515         CALL lbc_lnk( pge3rui , 'U', -1. )   ;   CALL lbc_lnk( pge3rvi , 'V', -1. )   ! Lateral boundary conditions 
    359516         ! 
    360517      END IF   
    361518      ! 
    362       IF( nn_timing == 1 )  CALL timing_stop( 'zps_hde') 
    363       ! 
    364    END SUBROUTINE zps_hde 
    365  
     519      IF( nn_timing == 1 )  CALL timing_stop( 'zps_hde_isf') 
     520      ! 
     521   END SUBROUTINE zps_hde_isf 
    366522   !!====================================================================== 
    367523END MODULE zpshde 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/ZDF/zdfbfr.F90

    r5312 r5313  
    120120                  zbfrt(ji,jj) = MAX(bfrcoef2d(ji,jj), ztmp) 
    121121                  zbfrt(ji,jj) = MIN(zbfrt(ji,jj), rn_bfri2_max) 
    122 ! (ISF) 
    123                   ikbt = mikt(ji,jj) 
    124 ! JC: possible WAD implementation should modify line below if layers vanish 
    125                   ztmp = tmask(ji,jj,ikbt) * ( vkarmn / LOG( 0.5_wp * fse3t_n(ji,jj,ikbt) / rn_bfrz0 ))**2._wp 
    126                   ztfrt(ji,jj) = MAX(tfrcoef2d(ji,jj), ztmp) 
    127                   ztfrt(ji,jj) = MIN(ztfrt(ji,jj), rn_tfri2_max) 
    128  
    129122               END DO 
    130123            END DO 
     124! (ISF) 
     125            IF ( ln_isfcav ) THEN 
     126               DO jj = 1, jpj 
     127                  DO ji = 1, jpi 
     128                     ikbt = mikt(ji,jj) 
     129! JC: possible WAD implementation should modify line below if layers vanish 
     130                     ztmp = (1-tmask(ji,jj,1)) * ( vkarmn / LOG( 0.5_wp * fse3t_n(ji,jj,ikbt) / rn_bfrz0 ))**2._wp 
     131                     ztfrt(ji,jj) = MAX(tfrcoef2d(ji,jj), ztmp) 
     132                     ztfrt(ji,jj) = MIN(ztfrt(ji,jj), rn_tfri2_max) 
     133                  END DO 
     134               END DO 
     135            END IF 
    131136         !    
    132137         ELSE 
    … …  
    152157               ! 
    153158               ! in case of 2 cell water column, we assume each cell feels the top and bottom friction 
    154                IF ( miku(ji,jj) + 2 .GE. mbku(ji,jj) ) THEN 
    155                   bfrua(ji,jj) = - 0.5_wp * ( ( zbfrt(ji,jj) + zbfrt(ji+1,jj  ) )   & 
    156                                &            + ( ztfrt(ji,jj) + ztfrt(ji+1,jj  ) ) ) & 
    157                                &          * zecu * (1._wp - umask(ji,jj,1)) 
    158                END IF 
    159                IF ( mikv(ji,jj) + 2 .GE. mbkv(ji,jj) ) THEN 
    160                   bfrva(ji,jj) = - 0.5_wp * ( ( zbfrt(ji,jj) + zbfrt(ji  ,jj+1) )   & 
    161                                &            + ( ztfrt(ji,jj) + ztfrt(ji  ,jj+1) ) ) & 
    162                                &          * zecv * (1._wp - vmask(ji,jj,1)) 
    163                END IF 
    164                ! (ISF) ======================================================================== 
    165                ikbu = miku(ji,jj)         ! ocean bottom level at u- and v-points  
    166                ikbv = mikv(ji,jj)         ! (deepest ocean u- and v-points) 
    167                ! 
    168                zvu  = 0.25 * (  vn(ji,jj  ,ikbu) + vn(ji+1,jj  ,ikbu)     & 
    169                   &           + vn(ji,jj-1,ikbu) + vn(ji+1,jj-1,ikbu)  ) 
    170                zuv  = 0.25 * (  un(ji,jj  ,ikbv) + un(ji-1,jj  ,ikbv)     & 
    171                   &           + un(ji,jj+1,ikbv) + un(ji-1,jj+1,ikbv)  ) 
    172                ! 
    173                zecu = SQRT(  un(ji,jj,ikbu) * un(ji,jj,ikbu) + zvu*zvu + rn_bfeb2 ) 
    174                zecv = SQRT(  vn(ji,jj,ikbv) * vn(ji,jj,ikbv) + zuv*zuv + rn_bfeb2 ) 
    175                ! 
    176                tfrua(ji,jj) = - 0.5_wp * ( ztfrt(ji,jj) + ztfrt(ji+1,jj  ) ) * zecu * (1._wp - umask(ji,jj,1)) 
    177                tfrva(ji,jj) = - 0.5_wp * ( ztfrt(ji,jj) + ztfrt(ji  ,jj+1) ) * zecv * (1._wp - vmask(ji,jj,1)) 
    178                ! (ISF) END ==================================================================== 
    179                ! in case of 2 cell water column, we assume each cell feels the top and bottom friction 
    180                IF ( miku(ji,jj) + 2 .GE. mbku(ji,jj) ) THEN 
    181                   tfrua(ji,jj) = - 0.5_wp * ( ( ztfrt(ji,jj) + ztfrt(ji+1,jj  ) )   & 
    182                                &            + ( zbfrt(ji,jj) + zbfrt(ji+1,jj  ) ) ) & 
    183                                &          * zecu * (1._wp - umask(ji,jj,1)) 
    184                END IF 
    185                IF ( mikv(ji,jj) + 2 .GE. mbkv(ji,jj) ) THEN 
    186                   tfrva(ji,jj) = - 0.5_wp * ( ( ztfrt(ji,jj) + ztfrt(ji  ,jj+1) )   & 
    187                                &            + ( zbfrt(ji,jj) + zbfrt(ji  ,jj+1) ) ) & 
    188                                &          * zecv * (1._wp - vmask(ji,jj,1)) 
     159               IF ( ln_isfcav ) THEN 
     160                  IF ( miku(ji,jj) + 1 .GE. mbku(ji,jj) ) THEN 
     161                     bfrua(ji,jj) = - 0.5_wp * ( ( zbfrt(ji,jj) + zbfrt(ji+1,jj  ) )   & 
     162                                  &            + ( ztfrt(ji,jj) + ztfrt(ji+1,jj  ) ) ) & 
     163                                  &          * zecu * (1._wp - umask(ji,jj,1)) 
     164                  END IF 
     165                  IF ( mikv(ji,jj) + 1 .GE. mbkv(ji,jj) ) THEN 
     166                     bfrva(ji,jj) = - 0.5_wp * ( ( zbfrt(ji,jj) + zbfrt(ji  ,jj+1) )   & 
     167                                  &            + ( ztfrt(ji,jj) + ztfrt(ji  ,jj+1) ) ) & 
     168                                  &          * zecv * (1._wp - vmask(ji,jj,1)) 
     169                  END IF 
    189170               END IF 
    190171            END DO 
    191172         END DO 
     173         IF ( ln_isfcav ) THEN 
     174            DO jj = 2, jpjm1 
     175               DO ji = 2, jpim1 
     176                  ! (ISF) ======================================================================== 
     177                  ikbu = miku(ji,jj)         ! ocean bottom level at u- and v-points  
     178                  ikbv = mikv(ji,jj)         ! (deepest ocean u- and v-points) 
     179                  ! 
     180                  zvu  = 0.25 * (  vn(ji,jj  ,ikbu) + vn(ji+1,jj  ,ikbu)     & 
     181                     &           + vn(ji,jj-1,ikbu) + vn(ji+1,jj-1,ikbu)  ) 
     182                  zuv  = 0.25 * (  un(ji,jj  ,ikbv) + un(ji-1,jj  ,ikbv)     & 
     183                     &           + un(ji,jj+1,ikbv) + un(ji-1,jj+1,ikbv)  ) 
     184              ! 
     185                  zecu = SQRT(  un(ji,jj,ikbu) * un(ji,jj,ikbu) + zvu*zvu + rn_bfeb2 ) 
     186                  zecv = SQRT(  vn(ji,jj,ikbv) * vn(ji,jj,ikbv) + zuv*zuv + rn_bfeb2 ) 
     187              ! 
     188                  tfrua(ji,jj) = - 0.5_wp * ( ztfrt(ji,jj) + ztfrt(ji+1,jj  ) ) * zecu * (1._wp - umask(ji,jj,1)) 
     189                  tfrva(ji,jj) = - 0.5_wp * ( ztfrt(ji,jj) + ztfrt(ji  ,jj+1) ) * zecv * (1._wp - vmask(ji,jj,1)) 
     190              ! (ISF) END ==================================================================== 
     191              ! in case of 2 cell water column, we assume each cell feels the top and bottom friction 
     192                  IF ( miku(ji,jj) + 1 .GE. mbku(ji,jj) ) THEN 
     193                     tfrua(ji,jj) = - 0.5_wp * ( ( ztfrt(ji,jj) + ztfrt(ji+1,jj  ) )   & 
     194                                  &            + ( zbfrt(ji,jj) + zbfrt(ji+1,jj  ) ) ) & 
     195                                  &          * zecu * (1._wp - umask(ji,jj,1)) 
     196                  END IF 
     197                  IF ( mikv(ji,jj) + 1 .GE. mbkv(ji,jj) ) THEN 
     198                     tfrva(ji,jj) = - 0.5_wp * ( ( ztfrt(ji,jj) + ztfrt(ji  ,jj+1) )   & 
     199                                  &            + ( zbfrt(ji,jj) + zbfrt(ji  ,jj+1) ) ) & 
     200                                  &          * zecv * (1._wp - vmask(ji,jj,1)) 
     201                  END IF 
     202               END DO 
     203            END DO 
     204         END IF 
    192205         ! 
    193206         CALL lbc_lnk( bfrua, 'U', 1. )   ;   CALL lbc_lnk( bfrva, 'V', 1. )      ! Lateral boundary condition 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/ZDF/zdfddm.F90

    r5312 r5313  
    156156         END DO 
    157157         ! mask zmsk in order to have avt and avs masked 
    158          zmsks(:,:) = zmsks(:,:) * tmask(:,:,jk) 
     158         zmsks(:,:) = zmsks(:,:) * wmask(:,:,jk) 
    159159 
    160160 
    … …  
    191191               avmu(ji,jj,jk) = MAX( avmu(ji,jj,jk),    & 
    192192                  &                  avt(ji,jj,jk), avt(ji+1,jj,jk),   & 
    193                   &                  avs(ji,jj,jk), avs(ji+1,jj,jk) )  * umask(ji,jj,jk) 
     193                  &                  avs(ji,jj,jk), avs(ji+1,jj,jk) )  * wumask(ji,jj,jk) 
    194194               avmv(ji,jj,jk) = MAX( avmv(ji,jj,jk),    & 
    195195                  &                  avt(ji,jj,jk), avt(ji,jj+1,jk),   & 
    196                   &                  avs(ji,jj,jk), avs(ji,jj+1,jk) )  * vmask(ji,jj,jk) 
     196                  &                  avs(ji,jj,jk), avs(ji,jj+1,jk) )  * wvmask(ji,jj,jk) 
    197197            END DO 
    198198         END DO 
    … …  
    255255      IF( zdf_ddm_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'zdf_ddm_init : unable to allocate arrays' ) 
    256256      !                               ! initialization to masked Kz 
    257       avs(:,:,:) = rn_avt0 * tmask(:,:,:)  
     257      avs(:,:,:) = rn_avt0 * wmask(:,:,:)  
    258258      ! 
    259259   END SUBROUTINE zdf_ddm_init 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/ZDF/zdfgls.F90

    r5312 r5313  
    2020   USE domvvl         ! ocean space and time domain : variable volume layer 
    2121   USE zdf_oce        ! ocean vertical physics 
     22   USE zdfbfr         ! bottom friction (only for rn_bfrz0) 
    2223   USE sbc_oce        ! surface boundary condition: ocean 
    2324   USE phycst         ! physical constants 
    … …  
    5253 
    5354   !                              !! ** Namelist  namzdf_gls  ** 
    54    LOGICAL  ::   ln_crban          ! =T use Craig and Banner scheme 
    5555   LOGICAL  ::   ln_length_lim     ! use limit on the dissipation rate under stable stratification (Galperin et al. 1988) 
    5656   LOGICAL  ::   ln_sigpsi         ! Activate Burchard (2003) modification for k-eps closure & wave breaking mixing 
    57    INTEGER  ::   nn_tkebc_surf     ! TKE surface boundary condition (=0/1) 
    58    INTEGER  ::   nn_tkebc_bot      ! TKE bottom boundary condition (=0/1) 
    59    INTEGER  ::   nn_psibc_surf     ! PSI surface boundary condition (=0/1) 
    60    INTEGER  ::   nn_psibc_bot      ! PSI bottom boundary condition (=0/1) 
     57   INTEGER  ::   nn_bc_surf        ! surface boundary condition (=0/1) 
     58   INTEGER  ::   nn_bc_bot         ! bottom boundary condition (=0/1) 
     59   INTEGER  ::   nn_z0_met         ! Method for surface roughness computation 
    6160   INTEGER  ::   nn_stab_func      ! stability functions G88, KC or Canuto (=0/1/2) 
    6261   INTEGER  ::   nn_clos           ! closure 0/1/2/3 MY82/k-eps/k-w/gen 
    … …  
    6665   REAL(wp) ::   rn_charn          ! Charnock constant for surface breaking waves mixing : 1400. (standard) or 2.e5 (Stacey value) 
    6766   REAL(wp) ::   rn_crban          ! Craig and Banner constant for surface breaking waves mixing 
    68  
    69    REAL(wp) ::   hsro          =  0.003_wp    ! Minimum surface roughness 
    70    REAL(wp) ::   hbro          =  0.003_wp    ! Bottom roughness (m) 
     67   REAL(wp) ::   rn_hsro           ! Minimum surface roughness 
     68   REAL(wp) ::   rn_frac_hs        ! Fraction of wave height as surface roughness (if nn_z0_met > 1)  
     69 
    7170   REAL(wp) ::   rcm_sf        =  0.73_wp     ! Shear free turbulence parameters 
    7271   REAL(wp) ::   ra_sf         = -2.0_wp      ! Must be negative -2 < ra_sf < -1  
    … …  
    9695   REAL(wp) ::   rm7           =  0.0_wp 
    9796   REAL(wp) ::   rm8           =  0.318_wp 
    98     
     97   REAL(wp) ::   rtrans        =  0.1_wp 
    9998   REAL(wp) ::   rc02, rc02r, rc03, rc04                          ! coefficients deduced from above parameters 
    100    REAL(wp) ::   rc03_sqrt2_galp                                  !     -           -           -        - 
    101    REAL(wp) ::   rsbc_tke1, rsbc_tke2, rsbc_tke3, rfact_tke       !     -           -           -        - 
    102    REAL(wp) ::   rsbc_psi1, rsbc_psi2, rsbc_psi3, rfact_psi       !     -           -           -        - 
    103    REAL(wp) ::   rsbc_mb  , rsbc_std , rsbc_zs                    !     -           -           -        - 
     99   REAL(wp) ::   rsbc_tke1, rsbc_tke2, rfact_tke                  !     -           -           -        - 
     100   REAL(wp) ::   rsbc_psi1, rsbc_psi2, rfact_psi                  !     -           -           -        - 
     101   REAL(wp) ::   rsbc_zs1, rsbc_zs2                               !     -           -           -        - 
    104102   REAL(wp) ::   rc0, rc2, rc3, rf6, rcff, rc_diff                !     -           -           -        - 
    105103   REAL(wp) ::   rs0, rs1, rs2, rs4, rs5, rs6                     !     -           -           -        - 
    … …  
    147145      REAL(wp) ::   gh, gm, shr, dif, zsqen, zav        !   -      - 
    148146      REAL(wp), POINTER, DIMENSION(:,:  ) ::   zdep 
     147      REAL(wp), POINTER, DIMENSION(:,:  ) ::   zkar 
    149148      REAL(wp), POINTER, DIMENSION(:,:  ) ::   zflxs       ! Turbulence fluxed induced by internal waves  
    150149      REAL(wp), POINTER, DIMENSION(:,:  ) ::   zhsro       ! Surface roughness (surface waves) 
    … …  
    153152      REAL(wp), POINTER, DIMENSION(:,:,:) ::   shear       ! vertical shear 
    154153      REAL(wp), POINTER, DIMENSION(:,:,:) ::   eps         ! dissipation rate 
    155       REAL(wp), POINTER, DIMENSION(:,:,:) ::   zwall_psi   ! Wall function use in the wb case (ln_sigpsi.AND.ln_crban=T) 
    156       REAL(wp), POINTER, DIMENSION(:,:,:) ::   z_elem_a, z_elem_b, z_elem_c, psi 
     154      REAL(wp), POINTER, DIMENSION(:,:,:) ::   zwall_psi   ! Wall function use in the wb case (ln_sigpsi) 
     155      REAL(wp), POINTER, DIMENSION(:,:,:) ::   psi         ! psi at time now 
     156      REAL(wp), POINTER, DIMENSION(:,:,:) ::   z_elem_a    ! element of the first  matrix diagonal 
     157      REAL(wp), POINTER, DIMENSION(:,:,:) ::   z_elem_b    ! element of the second matrix diagonal 
     158      REAL(wp), POINTER, DIMENSION(:,:,:) ::   z_elem_c    ! element of the third  matrix diagonal 
    157159      !!-------------------------------------------------------------------- 
    158160      ! 
    159161      IF( nn_timing == 1 )  CALL timing_start('zdf_gls') 
    160162      ! 
    161       CALL wrk_alloc( jpi,jpj, zdep, zflxs, zhsro ) 
    162       CALL wrk_alloc( jpi,jpj,jpk, eb, mxlb, shear, eps, zwall_psi, z_elem_a, z_elem_b, z_elem_c, psi ) 
    163  
     163      CALL wrk_alloc( jpi,jpj, zdep, zkar, zflxs, zhsro ) 
     164      CALL wrk_alloc( jpi,jpj,jpk, eb, mxlb, shear, eps, zwall_psi, z_elem_a, z_elem_b, z_elem_c, psi  ) 
     165       
    164166      ! Preliminary computing 
    165167 
    … …  
    174176 
    175177      ! Compute surface and bottom friction at T-points 
    176 !CDIR NOVERRCHK 
    177       DO jj = 2, jpjm1 
    178 !CDIR NOVERRCHK 
    179          DO ji = fs_2, fs_jpim1   ! vector opt. 
    180             !  
    181             ! surface friction  
     178!CDIR NOVERRCHK           
     179      DO jj = 2, jpjm1           
     180!CDIR NOVERRCHK          
     181         DO ji = fs_2, fs_jpim1   ! vector opt.          
     182            ! 
     183            ! surface friction 
    182184            ustars2(ji,jj) = r1_rau0 * taum(ji,jj) * tmask(ji,jj,1) 
    183             ! 
    184             ! bottom friction (explicit before friction) 
    185             ! Note that we chose here not to bound the friction as in dynbfr) 
    186             ztx2 = (  bfrua(ji,jj)  * ub(ji,jj,mbku(ji,jj)) + bfrua(ji-1,jj) * ub(ji-1,jj,mbku(ji-1,jj))  )   & 
    187                & * ( 1._wp - 0.5_wp * umask(ji,jj,1) * umask(ji-1,jj,1)  ) 
    188             zty2 = (  bfrva(ji,jj)  * vb(ji,jj,mbkv(ji,jj)) + bfrva(ji,jj-1) * vb(ji,jj-1,mbkv(ji,jj-1))  )   & 
    189                & * ( 1._wp - 0.5_wp * vmask(ji,jj,1) * vmask(ji,jj-1,1)  ) 
    190             ustarb2(ji,jj) = SQRT( ztx2 * ztx2 + zty2 * zty2 ) * tmask(ji,jj,1) 
    191          END DO 
    192       END DO   
    193  
    194       ! In case of breaking surface waves mixing, 
    195       ! Compute surface roughness length according to Charnock formula: 
    196       IF( ln_crban ) THEN   ;   zhsro(:,:) = MAX(rsbc_zs * ustars2(:,:), hsro) 
    197       ELSE                  ;   zhsro(:,:) = hsro 
    198       ENDIF 
     185            !    
     186            ! bottom friction (explicit before friction)         
     187            ! Note that we chose here not to bound the friction as in dynbfr)    
     188            ztx2 = (  bfrua(ji,jj)  * ub(ji,jj,mbku(ji,jj)) + bfrua(ji-1,jj) * ub(ji-1,jj,mbku(ji-1,jj))  )   &          
     189               & * ( 1._wp - 0.5_wp * umask(ji,jj,1) * umask(ji-1,jj,1)  )       
     190            zty2 = (  bfrva(ji,jj)  * vb(ji,jj,mbkv(ji,jj)) + bfrva(ji,jj-1) * vb(ji,jj-1,mbkv(ji,jj-1))  )   &          
     191               & * ( 1._wp - 0.5_wp * vmask(ji,jj,1) * vmask(ji,jj-1,1)  )       
     192            ustarb2(ji,jj) = SQRT( ztx2 * ztx2 + zty2 * zty2 ) * tmask(ji,jj,1)          
     193         END DO          
     194      END DO     
     195 
     196      ! Set surface roughness length 
     197      SELECT CASE ( nn_z0_met ) 
     198      ! 
     199      CASE ( 0 )             ! Constant roughness           
     200         zhsro(:,:) = rn_hsro 
     201      CASE ( 1 )             ! Standard Charnock formula 
     202         zhsro(:,:) = MAX(rsbc_zs1 * ustars2(:,:), rn_hsro) 
     203      CASE ( 2 )             ! Roughness formulae according to Rascle et al., Ocean Modelling (2008) 
     204         zdep(:,:)  = 30.*TANH(2.*0.3/(28.*SQRT(MAX(ustars2(:,:),rsmall))))             ! Wave age (eq. 10) 
     205         zhsro(:,:) = MAX(rsbc_zs2 * ustars2(:,:) * zdep(:,:)**1.5, rn_hsro) ! zhsro = rn_frac_hs * Hsw (eq. 11) 
     206      ! 
     207      END SELECT 
    199208 
    200209      ! Compute shear and dissipation rate 
    … …  
    303312      ! 
    304313      ! Set surface condition on zwall_psi (1 at the bottom) 
    305       IF( ln_sigpsi ) THEN 
    306          zcoef = rsc_psi / rsc_psi0 
    307          DO jj = 2, jpjm1 
    308             DO ji = fs_2, fs_jpim1   ! vector opt. 
    309                zwall_psi(ji,jj,1) = zcoef 
    310             END DO 
    311          END DO 
    312       ENDIF 
    313  
     314      zwall_psi(:,:,1) = zwall_psi(:,:,2) 
     315      zwall_psi(:,:,jpk) = 1. 
     316      ! 
    314317      ! Surface boundary condition on tke 
    315318      ! --------------------------------- 
    316319      ! 
    317       SELECT CASE ( nn_tkebc_surf ) 
     320      SELECT CASE ( nn_bc_surf ) 
    318321      ! 
    319322      CASE ( 0 )             ! Dirichlet case 
    320          ! 
    321          IF (ln_crban) THEN     ! Wave induced mixing case 
    322             !                      ! en(1) = q2(1) = 0.5 * (15.8 * Ccb)^(2/3) * u*^2 
    323             !                      ! balance between the production and the dissipation terms including the wave effect 
    324             en(:,:,1) = MAX( rsbc_tke1 * ustars2(:,:), rn_emin ) 
    325             z_elem_a(:,:,1) = en(:,:,1) 
    326             z_elem_c(:,:,1) = 0._wp 
    327             z_elem_b(:,:,1) = 1._wp 
    328             !  
    329             ! one level below 
    330             en(:,:,2) = MAX( rsbc_tke1 * ustars2(:,:) * ( (zhsro(:,:)+fsdepw(:,:,2))/zhsro(:,:) )**ra_sf, rn_emin ) 
    331             z_elem_a(:,:,2) = 0._wp 
    332             z_elem_c(:,:,2) = 0._wp 
    333             z_elem_b(:,:,2) = 1._wp 
    334             ! 
    335          ELSE                   ! No wave induced mixing case 
    336             !                      ! en(1) = u*^2/C0^2  &  l(1)  = K*zs 
    337             !                      ! balance between the production and the dissipation terms 
    338             en(:,:,1) = MAX( rc02r * ustars2(:,:), rn_emin ) 
    339             z_elem_a(:,:,1) = en(:,:,1)  
    340             z_elem_c(:,:,1) = 0._wp 
    341             z_elem_b(:,:,1) = 1._wp 
    342             ! 
    343             ! one level below 
    344             en(:,:,2) = MAX( rc02r * ustars2(:,:), rn_emin ) 
    345             z_elem_a(:,:,2) = 0._wp 
    346             z_elem_c(:,:,2) = 0._wp 
    347             z_elem_b(:,:,2) = 1._wp 
    348             ! 
    349          ENDIF 
    350          ! 
     323      ! First level 
     324      en(:,:,1) = rc02r * ustars2(:,:) * (1._wp + rsbc_tke1)**(2._wp/3._wp) 
     325      en(:,:,1) = MAX(en(:,:,1), rn_emin)  
     326      z_elem_a(:,:,1) = en(:,:,1) 
     327      z_elem_c(:,:,1) = 0._wp 
     328      z_elem_b(:,:,1) = 1._wp 
     329      !  
     330      ! One level below 
     331      en(:,:,2) = rc02r * ustars2(:,:) * (1._wp + rsbc_tke1 * ((zhsro(:,:)+fsdepw(:,:,2))/zhsro(:,:) )**(1.5_wp*ra_sf))**(2._wp/3._wp) 
     332      en(:,:,2) = MAX(en(:,:,2), rn_emin ) 
     333      z_elem_a(:,:,2) = 0._wp  
     334      z_elem_c(:,:,2) = 0._wp 
     335      z_elem_b(:,:,2) = 1._wp 
     336      ! 
     337      ! 
    351338      CASE ( 1 )             ! Neumann boundary condition on d(e)/dz 
    352          ! 
    353          IF (ln_crban) THEN ! Shear free case: d(e)/dz= Fw 
    354             ! 
    355             ! Dirichlet conditions at k=1 (Cosmetic) 
    356             en(:,:,1) = MAX( rsbc_tke1 * ustars2(:,:), rn_emin ) 
    357             z_elem_a(:,:,1) = en(:,:,1) 
    358             z_elem_c(:,:,1) = 0._wp 
    359             z_elem_b(:,:,1) = 1._wp 
    360             ! at k=2, set de/dz=Fw 
    361             z_elem_b(:,:,2) = z_elem_b(:,:,2) +  z_elem_a(:,:,2) ! Remove z_elem_a from z_elem_b 
    362             z_elem_a(:,:,2) = 0._wp         
    363             zflxs(:,:) = rsbc_tke3 * ustars2(:,:)**1.5_wp * ( (zhsro(:,:)+fsdept(:,:,1) ) / zhsro(:,:) )**(1.5*ra_sf) 
    364             en(:,:,2) = en(:,:,2) + zflxs(:,:) / fse3w(:,:,2) 
    365             ! 
    366          ELSE                   ! No wave induced mixing case: d(e)/dz=0. 
    367             ! 
    368             ! Dirichlet conditions at k=1 (Cosmetic) 
    369             en(:,:,1) = MAX( rc02r * ustars2(:,:), rn_emin ) 
    370             z_elem_a(:,:,1) = en(:,:,1) 
    371             z_elem_c(:,:,1) = 0._wp 
    372             z_elem_b(:,:,1) = 1._wp 
    373             ! at k=2 set de/dz=0.: 
    374             z_elem_b(:,:,2) = z_elem_b(:,:,2) +  z_elem_a(:,:,2)  ! Remove z_elem_a from z_elem_b 
    375             z_elem_a(:,:,2) = 0._wp 
    376             ! 
    377          ENDIF 
    378          ! 
     339      ! 
     340      ! Dirichlet conditions at k=1 
     341      en(:,:,1)       = rc02r * ustars2(:,:) * (1._wp + rsbc_tke1)**(2._wp/3._wp) 
     342      en(:,:,1)       = MAX(en(:,:,1), rn_emin)       
     343      z_elem_a(:,:,1) = en(:,:,1) 
     344      z_elem_c(:,:,1) = 0._wp 
     345      z_elem_b(:,:,1) = 1._wp 
     346      ! 
     347      ! at k=2, set de/dz=Fw 
     348      !cbr 
     349      z_elem_b(:,:,2) = z_elem_b(:,:,2) +  z_elem_a(:,:,2) ! Remove z_elem_a from z_elem_b 
     350      z_elem_a(:,:,2) = 0._wp 
     351      zkar(:,:)       = (rl_sf + (vkarmn-rl_sf)*(1.-exp(-rtrans*fsdept(:,:,1)/zhsro(:,:)) )) 
     352      zflxs(:,:)      = rsbc_tke2 * ustars2(:,:)**1.5_wp * zkar(:,:) * ((zhsro(:,:)+fsdept(:,:,1))/zhsro(:,:) )**(1.5_wp*ra_sf) 
     353 
     354      en(:,:,2) = en(:,:,2) + zflxs(:,:)/fse3w(:,:,2) 
     355      ! 
     356      ! 
    379357      END SELECT 
    380358 
    … …  
    382360      ! -------------------------------- 
    383361      ! 
    384       SELECT CASE ( nn_tkebc_bot ) 
     362      SELECT CASE ( nn_bc_bot ) 
    385363      ! 
    386364      CASE ( 0 )             ! Dirichlet  
    … …  
    457435      !                                            ! set the minimum value of tke  
    458436      en(:,:,:) = MAX( en(:,:,:), rn_emin ) 
    459        
     437 
    460438      !!----------------------------------------!! 
    461439      !!   Solve prognostic equation for psi    !! 
    … …  
    560538      ! --------------------------------- 
    561539      ! 
    562       SELECT CASE ( nn_psibc_surf ) 
     540      SELECT CASE ( nn_bc_surf ) 
    563541      ! 
    564542      CASE ( 0 )             ! Dirichlet boundary conditions 
    565          ! 
    566          IF( ln_crban ) THEN       ! Wave induced mixing case 
    567             !                      ! en(1) = q2(1) = 0.5 * (15.8 * Ccb)^(2/3) * u*^2 
    568             !                      ! balance between the production and the dissipation terms including the wave effect 
    569             zdep(:,:) = rl_sf * zhsro(:,:) 
    570             psi (:,:,1) = rc0**rpp * en(:,:,1)**rmm * zdep(:,:)**rnn * tmask(:,:,1) 
    571             z_elem_a(:,:,1) = psi(:,:,1) 
    572             z_elem_c(:,:,1) = 0._wp 
    573             z_elem_b(:,:,1) = 1._wp 
    574             ! 
    575             ! one level below 
    576             zex1 = (rmm*ra_sf+rnn) 
    577             zex2 = (rmm*ra_sf) 
    578             zdep(:,:) = ( (zhsro(:,:) + fsdepw(:,:,2))**zex1 ) / zhsro(:,:)**zex2 
    579             psi (:,:,2) = rsbc_psi1 * ustars2(:,:)**rmm * zdep(:,:) * tmask(:,:,1) 
    580             z_elem_a(:,:,2) = 0._wp 
    581             z_elem_c(:,:,2) = 0._wp 
    582             z_elem_b(:,:,2) = 1._wp 
    583             !  
    584          ELSE                   ! No wave induced mixing case 
    585             !                      ! en(1) = u*^2/C0^2  &  l(1)  = K*zs 
    586             !                      ! balance between the production and the dissipation terms 
    587             ! 
    588             zdep(:,:) = vkarmn * zhsro(:,:) 
    589             psi (:,:,1) = rc0**rpp * en(:,:,1)**rmm * zdep(:,:)**rnn * tmask(:,:,1) 
    590             z_elem_a(:,:,1) = psi(:,:,1) 
    591             z_elem_c(:,:,1) = 0._wp 
    592             z_elem_b(:,:,1) = 1._wp 
    593             ! 
    594             ! one level below 
    595             zdep(:,:) = vkarmn * ( zhsro(:,:) + fsdepw(:,:,2) ) 
    596             psi (:,:,2) = rc0**rpp * en(:,:,1)**rmm * zdep(:,:)**rnn * tmask(:,:,1) 
    597             z_elem_a(:,:,2) = 0._wp 
    598             z_elem_c(:,:,2) = 0._wp 
    599             z_elem_b(:,:,2) = 1. 
    600             ! 
    601          ENDIF 
    602          ! 
     543      ! 
     544      ! Surface value 
     545      zdep(:,:)       = zhsro(:,:) * rl_sf ! Cosmetic 
     546      psi (:,:,1)     = rc0**rpp * en(:,:,1)**rmm * zdep(:,:)**rnn * tmask(:,:,1) 
     547      z_elem_a(:,:,1) = psi(:,:,1) 
     548      z_elem_c(:,:,1) = 0._wp 
     549      z_elem_b(:,:,1) = 1._wp 
     550      ! 
     551      ! One level below 
     552      zkar(:,:)       = (rl_sf + (vkarmn-rl_sf)*(1._wp-exp(-rtrans*fsdepw(:,:,2)/zhsro(:,:) ))) 
     553      zdep(:,:)       = (zhsro(:,:) + fsdepw(:,:,2)) * zkar(:,:) 
     554      psi (:,:,2)     = rc0**rpp * en(:,:,2)**rmm * zdep(:,:)**rnn * tmask(:,:,1) 
     555      z_elem_a(:,:,2) = 0._wp 
     556      z_elem_c(:,:,2) = 0._wp 
     557      z_elem_b(:,:,2) = 1._wp 
     558      !  
     559      ! 
    603560      CASE ( 1 )             ! Neumann boundary condition on d(psi)/dz 
    604          ! 
    605          IF( ln_crban ) THEN     ! Wave induced mixing case 
    606             ! 
    607             zdep(:,:) = rl_sf * zhsro(:,:) 
    608             psi (:,:,1) = rc0**rpp * en(:,:,1)**rmm * zdep(:,:)**rnn * tmask(:,:,1) 
    609             z_elem_a(:,:,1) = psi(:,:,1) 
    610             z_elem_c(:,:,1) = 0._wp 
    611             z_elem_b(:,:,1) = 1._wp 
    612             ! 
    613             ! Neumann condition at k=2 
    614             z_elem_b(:,:,2) = z_elem_b(:,:,2) +  z_elem_a(:,:,2) ! Remove z_elem_a from z_elem_b 
    615             z_elem_a(:,:,2) = 0._wp 
    616             ! 
    617             ! Set psi vertical flux at the surface: 
    618             zdep(:,:) = (zhsro(:,:) + fsdept(:,:,1))**(rmm*ra_sf+rnn-1._wp) / zhsro(:,:)**(rmm*ra_sf) 
    619             zflxs(:,:) = rsbc_psi3 * ( zwall_psi(:,:,1)*avm(:,:,1) + zwall_psi(:,:,2)*avm(:,:,2) ) &  
    620                &                   * en(:,:,1)**rmm * zdep          
    621             psi(:,:,2) = psi(:,:,2) + zflxs(:,:) / fse3w(:,:,2) 
    622             ! 
    623       ELSE                   ! No wave induced mixing 
    624             ! 
    625             zdep(:,:) = vkarmn * zhsro(:,:) 
    626             psi (:,:,1) = rc0**rpp * en(:,:,1)**rmm * zdep(:,:)**rnn * tmask(:,:,1) 
    627             z_elem_a(:,:,1) = psi(:,:,1) 
    628             z_elem_c(:,:,1) = 0._wp 
    629             z_elem_b(:,:,1) = 1._wp 
    630             ! 
    631             ! Neumann condition at k=2 
    632             z_elem_b(:,:,2) = z_elem_b(:,:,2) +  z_elem_a(:,:,2) ! Remove z_elem_a from z_elem_b 
    633             z_elem_a(ji,jj,2) = 0._wp 
    634             ! 
    635             ! Set psi vertical flux at the surface: 
    636             zdep(:,:)  = zhsro(:,:) + fsdept(:,:,1) 
    637             zflxs(:,:) = rsbc_psi2 * ( avm(:,:,1) + avm(:,:,2) ) * en(:,:,1)**rmm * zdep**(rnn-1._wp) 
    638             psi(:,:,2) = psi(:,:,2) + zflxs(:,:) / fse3w(:,:,2) 
    639             !      
    640          ENDIF 
    641          ! 
     561      ! 
     562      ! Surface value: Dirichlet 
     563      zdep(:,:)       = zhsro(:,:) * rl_sf 
     564      psi (:,:,1)     = rc0**rpp * en(:,:,1)**rmm * zdep(:,:)**rnn * tmask(:,:,1) 
     565      z_elem_a(:,:,1) = psi(:,:,1) 
     566      z_elem_c(:,:,1) = 0._wp 
     567      z_elem_b(:,:,1) = 1._wp 
     568      ! 
     569      ! Neumann condition at k=2 
     570      z_elem_b(:,:,2) = z_elem_b(:,:,2) +  z_elem_a(:,:,2) ! Remove z_elem_a from z_elem_b 
     571      z_elem_a(:,:,2) = 0._wp 
     572      ! 
     573      ! Set psi vertical flux at the surface: 
     574      zkar(:,:) = rl_sf + (vkarmn-rl_sf)*(1._wp-exp(-rtrans*fsdept(:,:,1)/zhsro(:,:) )) ! Lengh scale slope 
     575      zdep(:,:) = ((zhsro(:,:) + fsdept(:,:,1)) / zhsro(:,:))**(rmm*ra_sf) 
     576      zflxs(:,:) = (rnn + rsbc_tke1 * (rnn + rmm*ra_sf) * zdep(:,:))*(1._wp + rsbc_tke1*zdep(:,:))**(2._wp*rmm/3._wp-1_wp) 
     577      zdep(:,:) =  rsbc_psi1 * (zwall_psi(:,:,1)*avm(:,:,1)+zwall_psi(:,:,2)*avm(:,:,2)) * & 
     578             & ustars2(:,:)**rmm * zkar(:,:)**rnn * (zhsro(:,:) + fsdept(:,:,1))**(rnn-1.) 
     579      zflxs(:,:) = zdep(:,:) * zflxs(:,:) 
     580      psi(:,:,2) = psi(:,:,2) + zflxs(:,:) / fse3w(:,:,2) 
     581 
     582      !    
     583      ! 
    642584      END SELECT 
    643585 
    … …  
    645587      ! -------------------------------- 
    646588      ! 
    647       SELECT CASE ( nn_psibc_bot ) 
     589      SELECT CASE ( nn_bc_bot ) 
     590      ! 
    648591      ! 
    649592      CASE ( 0 )             ! Dirichlet  
    650          !                      ! en(ibot) = u*^2 / Co2 and mxln(ibot) = vkarmn * hbro 
     593         !                      ! en(ibot) = u*^2 / Co2 and mxln(ibot) = vkarmn * rn_bfrz0 
    651594         !                      ! Balance between the production and the dissipation terms 
    652595!CDIR NOVERRCHK 
    … …  
    656599               ibot   = mbkt(ji,jj) + 1      ! k   bottom level of w-point 
    657600               ibotm1 = mbkt(ji,jj)          ! k-1 bottom level of w-point but >=1 
    658                zdep(ji,jj) = vkarmn * hbro 
     601               zdep(ji,jj) = vkarmn * rn_bfrz0 
    659602               psi (ji,jj,ibot) = rc0**rpp * en(ji,jj,ibot)**rmm * zdep(ji,jj)**rnn 
    660603               z_elem_a(ji,jj,ibot) = 0._wp 
    … …  
    663606               ! 
    664607               ! Just above last level, Dirichlet condition again (GOTM like) 
    665                zdep(ji,jj) = vkarmn * ( hbro + fse3t(ji,jj,ibotm1) ) 
     608               zdep(ji,jj) = vkarmn * ( rn_bfrz0 + fse3t(ji,jj,ibotm1) ) 
    666609               psi (ji,jj,ibotm1) = rc0**rpp * en(ji,jj,ibot  )**rmm * zdep(ji,jj)**rnn 
    667610               z_elem_a(ji,jj,ibotm1) = 0._wp 
    … …  
    681624               ! 
    682625               ! Bottom level Dirichlet condition: 
    683                zdep(ji,jj) = vkarmn * hbro 
     626               zdep(ji,jj) = vkarmn * rn_bfrz0 
    684627               psi (ji,jj,ibot) = rc0**rpp * en(ji,jj,ibot)**rmm * zdep(ji,jj)**rnn 
    685628               ! 
    … …  
    693636               ! 
    694637               ! Set psi vertical flux at the bottom: 
    695                zdep(ji,jj) = hbro + 0.5_wp*fse3t(ji,jj,ibotm1) 
     638               zdep(ji,jj) = rn_bfrz0 + 0.5_wp*fse3t(ji,jj,ibotm1) 
    696639               zflxb = rsbc_psi2 * ( avm(ji,jj,ibot) + avm(ji,jj,ibotm1) )   & 
    697640                  &  * (0.5_wp*(en(ji,jj,ibot)+en(ji,jj,ibotm1)))**rmm * zdep(ji,jj)**(rnn-1._wp) 
    … …  
    736679            DO jj = 2, jpjm1 
    737680               DO ji = fs_2, fs_jpim1   ! vector opt. 
    738                   eps(ji,jj,jk) = rc03 * en(ji,jj,jk) * en(ji,jj,jk) * SQRT( en(ji,jj,jk) ) / psi(ji,jj,jk) 
     681                  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) 
    739682               END DO 
    740683            END DO 
    … …  
    783726               ! Galperin criterium (NOTE : Not required if the proper value of C3 in stable cases is calculated)  
    784727               zrn2 = MAX( rn2(ji,jj,jk), rsmall ) 
    785                mxln(ji,jj,jk) = MIN(  rn_clim_galp * SQRT( 2._wp * en(ji,jj,jk) / zrn2 ), mxln(ji,jj,jk) ) 
     728               IF (ln_length_lim) mxln(ji,jj,jk) = MIN(  rn_clim_galp * SQRT( 2._wp * en(ji,jj,jk) / zrn2 ), mxln(ji,jj,jk) ) 
    786729            END DO 
    787730         END DO 
    … …  
    847790      ! Boundary conditions on stability functions for momentum (Neumann): 
    848791      ! Lines below are useless if GOTM style Dirichlet conditions are used 
    849       zcoef = rcm_sf / SQRT( 2._wp ) 
     792 
     793      avmv(:,:,1) = avmv(:,:,2) 
     794 
    850795      DO jj = 2, jpjm1 
    851796         DO ji = fs_2, fs_jpim1   ! vector opt. 
    852             avmv(ji,jj,1) = zcoef 
    853          END DO 
    854       END DO 
    855       zcoef = rc0 / SQRT( 2._wp ) 
    856       DO jj = 2, jpjm1 
    857          DO ji = fs_2, fs_jpim1   ! vector opt. 
    858             avmv(ji,jj,mbkt(ji,jj)+1) = zcoef 
     797            avmv(ji,jj,mbkt(ji,jj)+1) = avmv(ji,jj,mbkt(ji,jj)) 
    859798         END DO 
    860799      END DO 
    … …  
    900839      avmv_k(:,:,:) = avmv(:,:,:) 
    901840      ! 
    902       CALL wrk_dealloc( jpi,jpj, zdep, zflxs, zhsro ) 
     841      CALL wrk_dealloc( jpi,jpj, zdep, zkar, zflxs, zhsro ) 
    903842      CALL wrk_dealloc( jpi,jpj,jpk, eb, mxlb, shear, eps, zwall_psi, z_elem_a, z_elem_b, z_elem_c, psi ) 
    904843      ! 
    … …  
    932871      !! 
    933872      NAMELIST/namzdf_gls/rn_emin, rn_epsmin, ln_length_lim, & 
    934          &            rn_clim_galp, ln_crban, ln_sigpsi,     & 
    935          &            rn_crban, rn_charn,                    & 
    936          &            nn_tkebc_surf, nn_tkebc_bot,           & 
    937          &            nn_psibc_surf, nn_psibc_bot,           & 
     873         &            rn_clim_galp, ln_sigpsi, rn_hsro,      & 
     874         &            rn_crban, rn_charn, rn_frac_hs,        & 
     875         &            nn_bc_surf, nn_bc_bot, nn_z0_met,      & 
    938876         &            nn_stab_func, nn_clos 
    939877      !!---------------------------------------------------------- 
    … …  
    955893         WRITE(numout,*) '~~~~~~~~~~~~' 
    956894         WRITE(numout,*) '   Namelist namzdf_gls : set gls mixing parameters' 
    957          WRITE(numout,*) '      minimum value of en                           rn_emin       = ', rn_emin 
    958          WRITE(numout,*) '      minimum value of eps                          rn_epsmin     = ', rn_epsmin 
    959          WRITE(numout,*) '      Limit dissipation rate under stable stratif.  ln_length_lim = ', ln_length_lim 
    960          WRITE(numout,*) '      Galperin limit (Standard: 0.53, Holt: 0.26)   rn_clim_galp  = ', rn_clim_galp 
    961          WRITE(numout,*) '      TKE Surface boundary condition                nn_tkebc_surf = ', nn_tkebc_surf 
    962          WRITE(numout,*) '      TKE Bottom boundary condition                 nn_tkebc_bot  = ', nn_tkebc_bot 
    963          WRITE(numout,*) '      PSI Surface boundary condition                nn_psibc_surf = ', nn_psibc_surf 
    964          WRITE(numout,*) '      PSI Bottom boundary condition                 nn_psibc_bot  = ', nn_psibc_bot 
    965          WRITE(numout,*) '      Craig and Banner scheme                       ln_crban      = ', ln_crban 
    966          WRITE(numout,*) '      Modify psi Schmidt number (wb case)           ln_sigpsi     = ', ln_sigpsi 
     895         WRITE(numout,*) '      minimum value of en                           rn_emin        = ', rn_emin 
     896         WRITE(numout,*) '      minimum value of eps                          rn_epsmin      = ', rn_epsmin 
     897         WRITE(numout,*) '      Limit dissipation rate under stable stratif.  ln_length_lim  = ', ln_length_lim 
     898         WRITE(numout,*) '      Galperin limit (Standard: 0.53, Holt: 0.26)   rn_clim_galp   = ', rn_clim_galp 
     899         WRITE(numout,*) '      TKE Surface boundary condition                nn_bc_surf     = ', nn_bc_surf 
     900         WRITE(numout,*) '      TKE Bottom boundary condition                 nn_bc_bot      = ', nn_bc_bot 
     901         WRITE(numout,*) '      Modify psi Schmidt number (wb case)           ln_sigpsi      = ', ln_sigpsi 
    967902         WRITE(numout,*) '      Craig and Banner coefficient                  rn_crban       = ', rn_crban 
    968903         WRITE(numout,*) '      Charnock coefficient                          rn_charn       = ', rn_charn 
     904         WRITE(numout,*) '      Surface roughness formula                     nn_z0_met      = ', nn_z0_met 
     905         WRITE(numout,*) '      Wave height frac. (used if nn_z0_met=2)       rn_frac_hs     = ', rn_frac_hs 
    969906         WRITE(numout,*) '      Stability functions                           nn_stab_func   = ', nn_stab_func 
    970907         WRITE(numout,*) '      Type of closure                               nn_clos        = ', nn_clos 
    971          WRITE(numout,*) '   Hard coded parameters' 
    972          WRITE(numout,*) '      Surface roughness (m)                         hsro          = ', hsro 
    973          WRITE(numout,*) '      Bottom roughness (m)                          hbro          = ', hbro 
     908         WRITE(numout,*) '      Surface roughness (m)                         rn_hsro        = ', rn_hsro 
     909         WRITE(numout,*) '      Bottom roughness (m) (nambfr namelist)        rn_bfrz0       = ', rn_bfrz0 
    974910      ENDIF 
    975911 
    … …  
    978914 
    979915      !                                !* Check of some namelist values 
    980       IF( nn_tkebc_surf < 0 .OR. nn_tkebc_surf > 1 ) CALL ctl_stop( 'bad flag: nn_tkebc_surf is 0 or 1' ) 
    981       IF( nn_psibc_surf < 0 .OR. nn_psibc_surf > 1 ) CALL ctl_stop( 'bad flag: nn_psibc_surf is 0 or 1' ) 
    982       IF( nn_tkebc_bot  < 0 .OR. nn_tkebc_bot  > 1 ) CALL ctl_stop( 'bad flag: nn_tkebc_bot is 0 or 1' ) 
    983       IF( nn_psibc_bot  < 0 .OR. nn_psibc_bot  > 1 ) CALL ctl_stop( 'bad flag: nn_psibc_bot is 0 or 1' ) 
     916      IF( nn_bc_surf < 0 .OR. nn_bc_surf > 1 ) CALL ctl_stop( 'bad flag: nn_bc_surf is 0 or 1' ) 
     917      IF( nn_bc_surf < 0 .OR. nn_bc_surf > 1 ) CALL ctl_stop( 'bad flag: nn_bc_surf is 0 or 1' ) 
     918      IF( nn_z0_met < 0 .OR. nn_z0_met > 2 ) CALL ctl_stop( 'bad flag: nn_z0_met is 0, 1 or 2' ) 
    984919      IF( nn_stab_func  < 0 .OR. nn_stab_func  > 3 ) CALL ctl_stop( 'bad flag: nn_stab_func is 0, 1, 2 and 3' ) 
    985920      IF( nn_clos       < 0 .OR. nn_clos       > 3 ) CALL ctl_stop( 'bad flag: nn_clos is 0, 1, 2 or 3' ) 
    … …  
    1001936         SELECT CASE ( nn_stab_func ) 
    1002937         CASE( 0, 1 )   ;   rpsi3m = 2.53_wp       ! G88 or KC stability functions 
    1003          CASE( 2 )      ;   rpsi3m = 2.38_wp       ! Canuto A stability functions 
     938         CASE( 2 )      ;   rpsi3m = 2.62_wp       ! Canuto A stability functions 
    1004939         CASE( 3 )      ;   rpsi3m = 2.38          ! Canuto B stability functions (caution : constant not identified) 
    1005940         END SELECT 
    … …  
    1012947         rnn     = -1._wp 
    1013948         rsc_tke =  1._wp 
    1014          rsc_psi =  1.3_wp  ! Schmidt number for psi 
     949         rsc_psi =  1.2_wp  ! Schmidt number for psi 
    1015950         rpsi1   =  1.44_wp 
    1016951         rpsi3p  =  1._wp 
    … …  
    11401075      !                                     ! See Eq. (13) of Carniel et al, OM, 30, 225-239, 2009 
    11411076      !                                     !  or Eq. (17) of Burchard, JPO, 31, 3133-3145, 2001 
    1142       IF( ln_sigpsi .AND. ln_crban ) THEN 
    1143          zcr = SQRT( 1.5_wp*rsc_tke ) * rcm_sf / vkarmn 
    1144          rsc_psi0 = vkarmn*vkarmn / ( rpsi2 * rcm_sf*rcm_sf )                       &  
    1145         &         * ( rnn*rnn - 4._wp/3._wp * zcr*rnn*rmm - 1._wp/3._wp * zcr*rnn   & 
    1146         &           + 2._wp/9._wp * rmm * zcr*zcr + 4._wp/9._wp * zcr*zcr * rmm*rmm )                                  
     1077      IF( ln_sigpsi ) THEN 
     1078         ra_sf = -1.5 ! Set kinetic energy slope, then deduce rsc_psi and rl_sf  
     1079         ! Verification: retrieve Burchard (2001) results by uncomenting the line below: 
     1080         ! Note that the results depend on the value of rn_cm_sf which is constant (=rc0) in his work 
     1081         ! ra_sf = -SQRT(2./3.*rc0**3./rn_cm_sf*rn_sc_tke)/vkarmn 
     1082         rsc_psi0 = rsc_tke/(24.*rpsi2)*(-1.+(4.*rnn + ra_sf*(1.+4.*rmm))**2./(ra_sf**2.)) 
    11471083      ELSE 
    11481084         rsc_psi0 = rsc_psi 
    … …  
    11511087      !                                !* Shear free turbulence parameters 
    11521088      ! 
    1153       ra_sf  = -4._wp * rnn * SQRT( rsc_tke ) / ( (1._wp+4._wp*rmm) * SQRT( rsc_tke )   & 
    1154          &                                      - SQRT(rsc_tke + 24._wp*rsc_psi0*rpsi2 ) ) 
    1155       rl_sf  = rc0 * SQRT( rc0 / rcm_sf )                                                                   & 
    1156          &         * SQRT(  (  (1._wp + 4._wp*rmm + 8._wp*rmm*rmm) * rsc_tke                                & 
    1157          &                   + 12._wp * rsc_psi0 * rpsi2                                                    & 
    1158          &                   - (1._wp + 4._wp*rmm) * SQRT( rsc_tke*(rsc_tke+ 24._wp*rsc_psi0*rpsi2) )  )    & 
    1159          &                / ( 12._wp*rnn*rnn )                                                              ) 
     1089      ra_sf  = -4._wp*rnn*SQRT(rsc_tke) / ( (1._wp+4._wp*rmm)*SQRT(rsc_tke) & 
     1090               &                              - SQRT(rsc_tke + 24._wp*rsc_psi0*rpsi2 ) ) 
     1091 
     1092      IF ( rn_crban==0._wp ) THEN 
     1093         rl_sf = vkarmn 
     1094      ELSE 
     1095         rl_sf = rc0 * SQRT(rc0/rcm_sf) * SQRT( ( (1._wp + 4._wp*rmm + 8._wp*rmm**2_wp)*rsc_tke          & 
     1096                 &                                       + 12._wp * rsc_psi0*rpsi2 - (1._wp + 4._wp*rmm) & 
     1097                 &                                                *SQRT(rsc_tke*(rsc_tke                 & 
     1098                 &                                                   + 24._wp*rsc_psi0*rpsi2)) )         & 
     1099                 &                                         /(12._wp*rnn**2.)                             & 
     1100                 &                                       ) 
     1101      ENDIF 
    11601102 
    11611103      ! 
    … …  
    11871129      rc03  = rc02 * rc0 
    11881130      rc04  = rc03 * rc0 
    1189       rc03_sqrt2_galp = rc03 / SQRT(2._wp) / rn_clim_galp 
    1190       rsbc_mb   = 0.5_wp * (15.8_wp*rn_crban)**(2._wp/3._wp)               ! Surf. bound. cond. from Mellor and Blumberg 
    1191       rsbc_std  = 3.75_wp                                                  ! Surf. bound. cond. standard (prod=diss) 
    1192       rsbc_tke1 = (-rsc_tke*rn_crban/(rcm_sf*ra_sf*rl_sf))**(2._wp/3._wp)  ! k_eps = 53.  Dirichlet + Wave breaking  
    1193       rsbc_tke2 = 0.5_wp / rau0 
    1194       rsbc_tke3 = rdt * rn_crban                                                         ! Neumann + Wave breaking 
    1195       rsbc_zs   = rn_charn / grav                                                        ! Charnock formula 
    1196       rsbc_psi1 = rc0**rpp * rsbc_tke1**rmm * rl_sf**rnn                           ! Dirichlet + Wave breaking 
    1197       rsbc_psi2 = -0.5_wp * rdt * rc0**rpp * rnn * vkarmn**rnn / rsc_psi                   ! Neumann + NO Wave breaking  
    1198       rsbc_psi3 = -0.5_wp * rdt * rc0**rpp * rl_sf**rnn / rsc_psi  * (rnn + rmm*ra_sf) ! Neumann + Wave breaking 
    1199       rfact_tke = -0.5_wp / rsc_tke * rdt               ! Cst used for the Diffusion term of tke 
    1200       rfact_psi = -0.5_wp / rsc_psi * rdt               ! Cst used for the Diffusion term of tke 
     1131      rsbc_tke1 = -3._wp/2._wp*rn_crban*ra_sf*rl_sf                      ! Dirichlet + Wave breaking 
     1132      rsbc_tke2 = rdt * rn_crban / rl_sf                                 ! Neumann + Wave breaking  
     1133      zcr = MAX(rsmall, rsbc_tke1**(1./(-ra_sf*3._wp/2._wp))-1._wp ) 
     1134      rtrans = 0.2_wp / zcr                                              ! Ad. inverse transition length between log and wave layer  
     1135      rsbc_zs1  = rn_charn/grav                                          ! Charnock formula for surface roughness 
     1136      rsbc_zs2  = rn_frac_hs / 0.85_wp / grav * 665._wp                  ! Rascle formula for surface roughness  
     1137      rsbc_psi1 = -0.5_wp * rdt * rc0**(rpp-2._wp*rmm) / rsc_psi 
     1138      rsbc_psi2 = -0.5_wp * rdt * rc0**rpp * rnn * vkarmn**rnn / rsc_psi ! Neumann + NO Wave breaking  
     1139 
     1140      rfact_tke = -0.5_wp / rsc_tke * rdt                                ! Cst used for the Diffusion term of tke 
     1141      rfact_psi = -0.5_wp / rsc_psi * rdt                                ! Cst used for the Diffusion term of tke 
    12011142 
    12021143      !                                !* Wall proximity function 
    … …  
    12571198               IF(lwp) WRITE(numout,*) ' ===>>>> : previous run without gls scheme, en and mxln computed by iterative loop' 
    12581199               en  (:,:,:) = rn_emin 
    1259                mxln(:,:,:) = 0.001         
     1200               mxln(:,:,:) = 0.05         
    12601201               avt_k (:,:,:) = avt (:,:,:) 
    12611202               avm_k (:,:,:) = avm (:,:,:) 
    … …  
    12671208            IF(lwp) WRITE(numout,*) ' ===>>>> : Initialisation of en and mxln by background values' 
    12681209            en  (:,:,:) = rn_emin 
    1269             mxln(:,:,:) = 0.001        
     1210            mxln(:,:,:) = 0.05        
    12701211         ENDIF 
    12711212         ! 
    … …  
    12731214         !                                   ! ------------------- 
    12741215         IF(lwp) WRITE(numout,*) '---- gls-rst ----' 
    1275          CALL iom_rstput( kt, nitrst, numrow, 'en'   , en     ) 
     1216         CALL iom_rstput( kt, nitrst, numrow, 'en'   , en     )  
    12761217         CALL iom_rstput( kt, nitrst, numrow, 'avt'  , avt_k  ) 
    12771218         CALL iom_rstput( kt, nitrst, numrow, 'avm'  , avm_k  ) 
    1278          CALL iom_rstput( kt, nitrst, numrow, 'avmu' , avmu_k ) 
     1219         CALL iom_rstput( kt, nitrst, numrow, 'avmu' , avmu_k )  
    12791220         CALL iom_rstput( kt, nitrst, numrow, 'avmv' , avmv_k ) 
    12801221         CALL iom_rstput( kt, nitrst, numrow, 'mxln' , mxln   ) 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/ZDF/zdfini.F90

    r5312 r5313  
    1414   !!---------------------------------------------------------------------- 
    1515   USE par_oce         ! mesh and scale factors 
    16    USE sbc_oce         ! surface module (only for nn_isf in the option compatibility test) 
    1716   USE ldftra_oce      ! ocean active tracers: lateral physics 
    1817   USE ldfdyn_oce      ! ocean dynamics lateral physics 
    … …  
    118117      IF( ioptio == 0 .OR. ioptio > 1 .AND. .NOT. lk_esopa )   & 
    119118         &   CALL ctl_stop( ' one and only one vertical diffusion option has to be defined ' ) 
    120       IF( ( lk_zdfric .OR. lk_zdfgls .OR. lk_zdfkpp ) .AND. nn_isf .NE. 0 )   & 
     119      IF( ( lk_zdfric .OR. lk_zdfgls .OR. lk_zdfkpp ) .AND. ln_isfcav )   & 
    121120         &   CALL ctl_stop( ' only zdfcst and zdftke were tested with ice shelves cavities ' ) 
    122121      ! 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/ZDF/zdftke.F90

    r5312 r5313  
    2626   !!                 !                                + cleaning of the parameters + bugs correction 
    2727   !!            3.3  !  2010-10  (C. Ethe, G. Madec) reorganisation of initialisation phase 
     28   !!            3.6  !  2014-11  (P. Mathiot) add ice shelf capability 
    2829   !!---------------------------------------------------------------------- 
    2930#if defined key_zdftke   ||   defined key_esopa 
    … …  
    236237      zfact3 = 0.5_wp       * rn_ediss 
    237238      ! 
     239      ! 
    238240      !                     !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 
    239241      !                     !  Surface boundary condition on tke 
    240242      !                     !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 
     243      IF ( ln_isfcav ) THEN 
     244         DO jj = 2, jpjm1            ! en(mikt(ji,jj))   = rn_emin 
     245            DO ji = fs_2, fs_jpim1   ! vector opt. 
     246               en(ji,jj,mikt(ji,jj))=rn_emin * tmask(ji,jj,1) 
     247            END DO 
     248         END DO 
     249      END IF 
    241250      DO jj = 2, jpjm1            ! en(1)   = rn_ebb taum / rau0  (min value rn_emin0) 
    242251         DO ji = fs_2, fs_jpim1   ! vector opt. 
    243             IF (mikt(ji,jj) .GT. 1) THEN 
    244                en(ji,jj,mikt(ji,jj))=rn_emin 
    245             ELSE 
    246                en(ji,jj,1) = MAX( rn_emin0, zbbrau * taum(ji,jj) ) * tmask(ji,jj,1) 
    247             END IF 
     252            en(ji,jj,1) = MAX( rn_emin0, zbbrau * taum(ji,jj) ) * tmask(ji,jj,1) 
    248253         END DO 
    249254      END DO 
    … …  
    301306         END DO 
    302307         zcof = 0.016 / SQRT( zrhoa * zcdrag ) 
     308!CDIR NOVERRCHK 
    303309         DO jk = 2, jpkm1         !* TKE Langmuir circulation source term added to en 
    304             DO jj = 2, jpjm1 
     310!CDIR NOVERRCHK 
     311            DO jj = 2, jpjm1 
     312!CDIR NOVERRCHK 
    305313               DO ji = fs_2, fs_jpim1   ! vector opt. 
    306314                  zus  = zcof * SQRT( taum(ji,jj) )           ! Stokes drift 
    … …  
    309317                  zwlc = zind * rn_lc * zus * SIN( rpi * fsdepw(ji,jj,jk) / zhlc(ji,jj) ) 
    310318                  !                                           ! TKE Langmuir circulation source term 
    311                   en(ji,jj,jk) = en(ji,jj,jk) + rdt * ( zwlc * zwlc * zwlc ) / zhlc(ji,jj) * tmask(ji,jj,jk) 
     319                  en(ji,jj,jk) = en(ji,jj,jk) + rdt * ( zwlc * zwlc * zwlc ) / zhlc(ji,jj) * wmask(ji,jj,jk) * tmask(ji,jj,1) 
    312320               END DO 
    313321            END DO 
    … …  
    328336               avmu(ji,jj,jk) = avmu(ji,jj,jk) * ( un(ji,jj,jk-1) - un(ji,jj,jk) )   & 
    329337                  &                            * ( ub(ji,jj,jk-1) - ub(ji,jj,jk) )   &  
    330                   &           / (  fse3uw_n(ji,jj,jk)         & 
    331                   &              * fse3uw_b(ji,jj,jk) ) 
     338                  &                            / (  fse3uw_n(ji,jj,jk)               & 
     339                  &                              *  fse3uw_b(ji,jj,jk) ) 
    332340               avmv(ji,jj,jk) = avmv(ji,jj,jk) * ( vn(ji,jj,jk-1) - vn(ji,jj,jk) )   & 
    333341                  &                            * ( vb(ji,jj,jk-1) - vb(ji,jj,jk) )   & 
    … …  
    338346      END DO 
    339347      ! 
    340       DO jj = 2, jpjm1 
    341          DO ji = fs_2, fs_jpim1   ! vector opt. 
    342             DO jk = mikt(ji,jj)+1, jpkm1           !* Matrix and right hand side in en 
     348      DO jk = 2, jpkm1           !* Matrix and right hand side in en 
     349         DO jj = 2, jpjm1 
     350            DO ji = fs_2, fs_jpim1   ! vector opt. 
    343351               zcof   = zfact1 * tmask(ji,jj,jk) 
    344352               zzd_up = zcof * ( avm  (ji,jj,jk+1) + avm  (ji,jj,jk  ) )   &  ! upper diagonal 
    … …  
    357365               en(ji,jj,jk) = en(ji,jj,jk) + rdt * (  zesh2  -   avt(ji,jj,jk) * rn2(ji,jj,jk)    & 
    358366                  &                                 + zfact3 * dissl(ji,jj,jk) * en (ji,jj,jk)  ) & 
    359                   &                                 * tmask(ji,jj,jk) * tmask(ji,jj,jk-1) 
    360             END DO 
    361             !                          !* Matrix inversion from level 2 (tke prescribed at level 1) 
    362             DO jk = mikt(ji,jj)+2, jpkm1                             ! First recurrence : Dk = Dk - Lk * Uk-1 / Dk-1 
     367                  &                                 * wmask(ji,jj,jk) 
     368            END DO 
     369         END DO 
     370      END DO 
     371      !                          !* Matrix inversion from level 2 (tke prescribed at level 1) 
     372      DO jk = 3, jpkm1                             ! First recurrence : Dk = Dk - Lk * Uk-1 / Dk-1 
     373         DO jj = 2, jpjm1 
     374            DO ji = fs_2, fs_jpim1    ! vector opt. 
    363375               zdiag(ji,jj,jk) = zdiag(ji,jj,jk) - zd_lw(ji,jj,jk) * zd_up(ji,jj,jk-1) / zdiag(ji,jj,jk-1) 
    364376            END DO 
    365             ! Second recurrence : Lk = RHSk - Lk / Dk-1 * Lk-1 
    366             zd_lw(ji,jj,mikt(ji,jj)+1) = en(ji,jj,mikt(ji,jj)+1) - zd_lw(ji,jj,mikt(ji,jj)+1) * en(ji,jj,mikt(ji,jj))    ! Surface boudary conditions on tke 
    367             ! 
    368             DO jk = mikt(ji,jj)+2, jpkm1 
     377         END DO 
     378      END DO 
     379      ! 
     380      ! Second recurrence : Lk = RHSk - Lk / Dk-1 * Lk-1 
     381      DO jj = 2, jpjm1 
     382         DO ji = fs_2, fs_jpim1   ! vector opt. 
     383            zd_lw(ji,jj,2) = en(ji,jj,2) - zd_lw(ji,jj,2) * en(ji,jj,1)    ! Surface boudary conditions on tke 
     384         END DO 
     385      END DO 
     386      DO jk = 3, jpkm1 
     387         DO jj = 2, jpjm1 
     388            DO ji = fs_2, fs_jpim1    ! vector opt. 
    369389               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) 
    370390            END DO 
    371             ! 
    372             ! thrid recurrence : Ek = ( Lk - Uk * Ek+1 ) / Dk 
     391         END DO 
     392      END DO 
     393      ! 
     394      ! thrid recurrence : Ek = ( Lk - Uk * Ek+1 ) / Dk 
     395      DO jj = 2, jpjm1 
     396         DO ji = fs_2, fs_jpim1   ! vector opt. 
    373397            en(ji,jj,jpkm1) = zd_lw(ji,jj,jpkm1) / zdiag(ji,jj,jpkm1) 
    374             ! 
    375             DO jk = jpk-2, mikt(ji,jj)+1, -1 
     398         END DO 
     399      END DO 
     400      DO jk = jpk-2, 2, -1 
     401         DO jj = 2, jpjm1 
     402            DO ji = fs_2, fs_jpim1    ! vector opt. 
    376403               en(ji,jj,jk) = ( zd_lw(ji,jj,jk) - zd_up(ji,jj,jk) * en(ji,jj,jk+1) ) / zdiag(ji,jj,jk) 
    377404            END DO 
    378             ! 
    379             DO jk = mikt(ji,jj), jpkm1                             ! set the minimum value of tke 
    380                en(ji,jj,jk) = MAX( en(ji,jj,jk), rn_emin ) * tmask(ji,jj,jk) 
     405         END DO 
     406      END DO 
     407      DO jk = 2, jpkm1                             ! set the minimum value of tke 
     408         DO jj = 2, jpjm1 
     409            DO ji = fs_2, fs_jpim1   ! vector opt. 
     410               en(ji,jj,jk) = MAX( en(ji,jj,jk), rn_emin ) * wmask(ji,jj,jk) 
    381411            END DO 
    382412         END DO 
    … …  
    391421               DO ji = fs_2, fs_jpim1   ! vector opt. 
    392422                  en(ji,jj,jk) = en(ji,jj,jk) + rn_efr * en(ji,jj,1) * EXP( -fsdepw(ji,jj,jk) / htau(ji,jj) )   & 
    393                      &                                 * ( 1._wp - fr_i(ji,jj) )  * tmask(ji,jj,jk) * tmask(ji,jj,1) 
     423                     &                                 * ( 1._wp - fr_i(ji,jj) )  * wmask(ji,jj,jk) * tmask(ji,jj,1) 
    394424               END DO 
    395425            END DO 
    … …  
    400430               jk = nmln(ji,jj) 
    401431               en(ji,jj,jk) = en(ji,jj,jk) + rn_efr * en(ji,jj,1) * EXP( -fsdepw(ji,jj,jk) / htau(ji,jj) )   & 
    402                   &                                 * ( 1._wp - fr_i(ji,jj) )  * tmask(ji,jj,jk) * tmask(ji,jj,1) 
     432                  &                                 * ( 1._wp - fr_i(ji,jj) )  * wmask(ji,jj,jk) * tmask(ji,jj,1) 
    403433            END DO 
    404434         END DO 
    … …  
    416446                  zdif = rhftau_scl * MAX( 0._wp, zdif + rhftau_add )  ! apply some modifications... 
    417447                  en(ji,jj,jk) = en(ji,jj,jk) + zbbrau * zdif * EXP( -fsdepw(ji,jj,jk) / htau(ji,jj) )   & 
    418                      &                        * ( 1._wp - fr_i(ji,jj) ) * tmask(ji,jj,jk) * tmask(ji,jj,jk-1) * tmask(ji,jj,1) 
     448                     &                        * ( 1._wp - fr_i(ji,jj) ) * wmask(ji,jj,jk) * tmask(ji,jj,1) 
    419449               END DO 
    420450            END DO 
    … …  
    484514      !                     !* Buoyancy length scale: l=sqrt(2*e/n**2) 
    485515      ! 
     516      ! initialisation of interior minimum value (avoid a 2d loop with mikt) 
     517      zmxlm(:,:,:)  = rmxl_min     
     518      zmxld(:,:,:)  = rmxl_min 
     519      ! 
    486520      IF( ln_mxl0 ) THEN            ! surface mixing length = F(stress) : l=vkarmn*2.e5*taum/(rau0*g) 
    487521         DO jj = 2, jpjm1 
    488522            DO ji = fs_2, fs_jpim1 
    489                IF (mikt(ji,jj) .GT. 1) THEN 
    490                   zmxlm(ji,jj,mikt(ji,jj)) = rmxl_min 
    491                ELSE 
    492                   zraug = vkarmn * 2.e5_wp / ( rau0 * grav ) 
    493                   zmxlm(ji,jj,mikt(ji,jj)) = MAX( rn_mxl0, zraug * taum(ji,jj) ) 
    494                END IF 
     523               zraug = vkarmn * 2.e5_wp / ( rau0 * grav ) 
     524               zmxlm(ji,jj,1) = MAX( rn_mxl0, zraug * taum(ji,jj) * tmask(ji,jj,1) ) 
    495525            END DO 
    496526         END DO 
    497527      ELSE  
    498          DO jj = 2, jpjm1 
    499             DO ji = fs_2, fs_jpim1                         ! surface set to the minimum value 
    500                zmxlm(ji,jj,mikt(ji,jj)) = MAX( tmask(ji,jj,1) * rn_mxl0, rmxl_min) 
    501             END DO 
    502          END DO 
     528         zmxlm(:,:,1) = rn_mxl0 
    503529      ENDIF 
    504       zmxlm(:,:,jpk)  = rmxl_min     ! last level set to the interior minium value 
    505       ! 
    506 !CDIR NOVERRCHK 
    507       DO jj = 2, jpjm1 
    508 !CDIR NOVERRCHK 
    509          DO ji = fs_2, fs_jpim1   ! vector opt. 
    510             !CDIR NOVERRCHK 
    511             DO jk = mikt(ji,jj)+1, jpkm1              ! interior value : l=sqrt(2*e/n^2) 
     530      ! 
     531!CDIR NOVERRCHK 
     532      DO jk = 2, jpkm1              ! interior value : l=sqrt(2*e/n^2) 
     533!CDIR NOVERRCHK 
     534         DO jj = 2, jpjm1 
     535!CDIR NOVERRCHK 
     536            DO ji = fs_2, fs_jpim1   ! vector opt. 
    512537               zrn2 = MAX( rn2(ji,jj,jk), rsmall ) 
    513                zmxlm(ji,jj,jk) = MAX(  rmxl_min,  SQRT( 2._wp * en(ji,jj,jk) / zrn2 )  ) 
    514             END DO 
    515             zmxld(ji,jj,mikt(ji,jj)) = zmxlm(ji,jj,mikt(ji,jj))   ! surface set to the minimum value  
     538               zmxlm(ji,jj,jk) = MAX(  rmxl_min,  SQRT( 2._wp * en(ji,jj,jk) / zrn2 ) ) 
     539            END DO 
    516540         END DO 
    517541      END DO 
    … …  
    519543      !                     !* Physical limits for the mixing length 
    520544      ! 
    521       zmxld(:,:, 1 ) = zmxlm(:,:,1)   ! surface set to the zmxlm   value 
     545      zmxld(:,:,1  ) = zmxlm(:,:,1)   ! surface set to the minimum value  
    522546      zmxld(:,:,jpk) = rmxl_min       ! last level  set to the minimum value 
    523547      ! 
    524548      SELECT CASE ( nn_mxl ) 
    525549      ! 
     550      ! where wmask = 0 set zmxlm == fse3w 
    526551      CASE ( 0 )           ! bounded by the distance to surface and bottom 
    527          DO jj = 2, jpjm1 
    528             DO ji = fs_2, fs_jpim1   ! vector opt. 
    529                DO jk = mikt(ji,jj)+1, jpkm1 
     552         DO jk = 2, jpkm1 
     553            DO jj = 2, jpjm1 
     554               DO ji = fs_2, fs_jpim1   ! vector opt. 
    530555                  zemxl = MIN( fsdepw(ji,jj,jk) - fsdepw(ji,jj,mikt(ji,jj)), zmxlm(ji,jj,jk),   & 
    531556                  &            fsdepw(ji,jj,mbkt(ji,jj)+1) - fsdepw(ji,jj,jk) ) 
    532                   zmxlm(ji,jj,jk) = zemxl 
    533                   zmxld(ji,jj,jk) = zemxl 
     557                  ! wmask prevent zmxlm = 0 if jk = mikt(ji,jj) 
     558                  zmxlm(ji,jj,jk) = zemxl * wmask(ji,jj,jk) + MIN(zmxlm(ji,jj,jk),fse3w(ji,jj,jk)) * (1 - wmask(ji,jj,jk)) 
     559                  zmxld(ji,jj,jk) = zemxl * wmask(ji,jj,jk) + MIN(zmxlm(ji,jj,jk),fse3w(ji,jj,jk)) * (1 - wmask(ji,jj,jk)) 
    534560               END DO 
    535561            END DO 
    … …  
    537563         ! 
    538564      CASE ( 1 )           ! bounded by the vertical scale factor 
    539          DO jj = 2, jpjm1 
    540             DO ji = fs_2, fs_jpim1   ! vector opt. 
    541                DO jk = mikt(ji,jj)+1, jpkm1 
     565         DO jk = 2, jpkm1 
     566            DO jj = 2, jpjm1 
     567               DO ji = fs_2, fs_jpim1   ! vector opt. 
    542568                  zemxl = MIN( fse3w(ji,jj,jk), zmxlm(ji,jj,jk) ) 
    543569                  zmxlm(ji,jj,jk) = zemxl 
    … …  
    548574         ! 
    549575      CASE ( 2 )           ! |dk[xml]| bounded by e3t : 
    550          DO jj = 2, jpjm1 
    551             DO ji = fs_2, fs_jpim1   ! vector opt. 
    552                DO jk = mikt(ji,jj)+1, jpkm1         ! from the surface to the bottom : 
     576         DO jk = 2, jpkm1         ! from the surface to the bottom : 
     577            DO jj = 2, jpjm1 
     578               DO ji = fs_2, fs_jpim1   ! vector opt. 
    553579                  zmxlm(ji,jj,jk) = MIN( zmxlm(ji,jj,jk-1) + fse3t(ji,jj,jk-1), zmxlm(ji,jj,jk) ) 
    554580               END DO 
    555                DO jk = jpkm1, mikt(ji,jj)+1, -1     ! from the bottom to the surface : 
     581            END DO 
     582         END DO 
     583         DO jk = jpkm1, 2, -1     ! from the bottom to the surface : 
     584            DO jj = 2, jpjm1 
     585               DO ji = fs_2, fs_jpim1   ! vector opt. 
    556586                  zemxl = MIN( zmxlm(ji,jj,jk+1) + fse3t(ji,jj,jk+1), zmxlm(ji,jj,jk) ) 
    557587                  zmxlm(ji,jj,jk) = zemxl 
    … …  
    562592         ! 
    563593      CASE ( 3 )           ! lup and ldown, |dk[xml]| bounded by e3t : 
    564          DO jj = 2, jpjm1 
    565             DO ji = fs_2, fs_jpim1   ! vector opt. 
    566                DO jk = mikt(ji,jj)+1, jpkm1         ! from the surface to the bottom : lup 
     594         DO jk = 2, jpkm1         ! from the surface to the bottom : lup 
     595            DO jj = 2, jpjm1 
     596               DO ji = fs_2, fs_jpim1   ! vector opt. 
    567597                  zmxld(ji,jj,jk) = MIN( zmxld(ji,jj,jk-1) + fse3t(ji,jj,jk-1), zmxlm(ji,jj,jk) ) 
    568598               END DO 
    569                DO jk = jpkm1, mikt(ji,jj)+1, -1     ! from the bottom to the surface : ldown 
     599            END DO 
     600         END DO 
     601         DO jk = jpkm1, 2, -1     ! from the bottom to the surface : ldown 
     602            DO jj = 2, jpjm1 
     603               DO ji = fs_2, fs_jpim1   ! vector opt. 
    570604                  zmxlm(ji,jj,jk) = MIN( zmxlm(ji,jj,jk+1) + fse3t(ji,jj,jk+1), zmxlm(ji,jj,jk) ) 
    571605               END DO 
    … …  
    604638               zsqen = SQRT( en(ji,jj,jk) ) 
    605639               zav   = rn_ediff * zmxlm(ji,jj,jk) * zsqen 
    606                avm  (ji,jj,jk) = MAX( zav,                  avmb(jk) ) * tmask(ji,jj,jk) 
    607                avt  (ji,jj,jk) = MAX( zav, avtb_2d(ji,jj) * avtb(jk) ) * tmask(ji,jj,jk) 
     640               avm  (ji,jj,jk) = MAX( zav,                  avmb(jk) ) * wmask(ji,jj,jk) 
     641               avt  (ji,jj,jk) = MAX( zav, avtb_2d(ji,jj) * avtb(jk) ) * wmask(ji,jj,jk) 
    608642               dissl(ji,jj,jk) = zsqen / zmxld(ji,jj,jk) 
    609643            END DO 
    … …  
    612646      CALL lbc_lnk( avm, 'W', 1. )      ! Lateral boundary conditions (sign unchanged) 
    613647      ! 
    614       DO jj = 2, jpjm1 
    615          DO ji = fs_2, fs_jpim1   ! vector opt. 
    616             DO jk = miku(ji,jj)+1, jpkm1            !* vertical eddy viscosity at u- and v-points 
    617                avmu(ji,jj,jk) = 0.5 * ( avm(ji,jj,jk) + avm(ji+1,jj  ,jk) ) * umask(ji,jj,jk) 
    618             END DO 
    619             DO jk = mikv(ji,jj)+1, jpkm1 
    620                avmv(ji,jj,jk) = 0.5 * ( avm(ji,jj,jk) + avm(ji  ,jj+1,jk) ) * vmask(ji,jj,jk) 
     648      DO jk = 2, jpkm1            !* vertical eddy viscosity at wu- and wv-points 
     649         DO jj = 2, jpjm1 
     650            DO ji = fs_2, fs_jpim1   ! vector opt. 
     651               avmu(ji,jj,jk) = 0.5 * ( avm(ji,jj,jk) + avm(ji+1,jj  ,jk) ) * wumask(ji,jj,jk) 
     652               avmv(ji,jj,jk) = 0.5 * ( avm(ji,jj,jk) + avm(ji  ,jj+1,jk) ) * wvmask(ji,jj,jk) 
    621653            END DO 
    622654         END DO 
    … …  
    625657      ! 
    626658      IF( nn_pdl == 1 ) THEN      !* Prandtl number case: update avt 
    627          DO jj = 2, jpjm1 
    628             DO ji = fs_2, fs_jpim1   ! vector opt. 
    629                DO jk = mikt(ji,jj)+1, jpkm1 
     659         DO jk = 2, jpkm1 
     660            DO jj = 2, jpjm1 
     661               DO ji = fs_2, fs_jpim1   ! vector opt. 
    630662                  zcoef = avm(ji,jj,jk) * 2._wp * fse3w(ji,jj,jk) * fse3w(ji,jj,jk) 
    631663                  !                                          ! shear 
    … …  
    639671!!gm and even better with the use of the "true" ri_crit=0.22222...  (this change the results!) 
    640672!!gm              zpdlr = MAX(  0.1_wp,  ri_crit / MAX( ri_crit , zri )  ) 
    641                   avt(ji,jj,jk)   = MAX( zpdlr * avt(ji,jj,jk), avtb_2d(ji,jj) * avtb(jk) ) * tmask(ji,jj,jk) 
     673                  avt(ji,jj,jk)   = MAX( zpdlr * avt(ji,jj,jk), avtb_2d(ji,jj) * avtb(jk) ) * wmask(ji,jj,jk) 
    642674# if defined key_c1d 
    643                   e_pdl(ji,jj,jk) = zpdlr * tmask(ji,jj,jk)  ! c1d configuration : save masked Prandlt number 
    644                   e_ric(ji,jj,jk) = zri   * tmask(ji,jj,jk)  ! c1d config. : save Ri 
     675                  e_pdl(ji,jj,jk) = zpdlr * wmask(ji,jj,jk)  ! c1d configuration : save masked Prandlt number 
     676                  e_ric(ji,jj,jk) = zri   * wmask(ji,jj,jk)  ! c1d config. : save Ri 
    645677# endif 
    646678              END DO 
    … …  
    749781      !                               !* set vertical eddy coef. to the background value 
    750782      DO jk = 1, jpk 
    751          avt (:,:,jk) = avtb(jk) * tmask(:,:,jk) 
    752          avm (:,:,jk) = avmb(jk) * tmask(:,:,jk) 
    753          avmu(:,:,jk) = avmb(jk) * umask(:,:,jk) 
    754          avmv(:,:,jk) = avmb(jk) * vmask(:,:,jk) 
     783         avt (:,:,jk) = avtb(jk) * wmask (:,:,jk) 
     784         avm (:,:,jk) = avmb(jk) * wmask (:,:,jk) 
     785         avmu(:,:,jk) = avmb(jk) * wumask(:,:,jk) 
     786         avmv(:,:,jk) = avmb(jk) * wvmask(:,:,jk) 
    755787      END DO 
    756788      dissl(:,:,:) = 1.e-12_wp 
    … …  
    803835              en (:,:,:) = rn_emin * tmask(:,:,:) 
    804836              CALL tke_avn                               ! recompute avt, avm, avmu, avmv and dissl (approximation) 
     837              ! 
     838              avt_k (:,:,:) = avt (:,:,:) 
     839              avm_k (:,:,:) = avm (:,:,:) 
     840              avmu_k(:,:,:) = avmu(:,:,:) 
     841              avmv_k(:,:,:) = avmv(:,:,:) 
     842              ! 
    805843              DO jit = nit000 + 1, nit000 + 10   ;   CALL zdf_tke( jit )   ;   END DO 
    806844           ENDIF 
    … …  
    808846           en(:,:,:) = rn_emin * tmask(:,:,:) 
    809847           DO jk = 1, jpk                           ! set the Kz to the background value 
    810               avt (:,:,jk) = avtb(jk) * tmask(:,:,jk) 
    811               avm (:,:,jk) = avmb(jk) * tmask(:,:,jk) 
    812               avmu(:,:,jk) = avmb(jk) * umask(:,:,jk) 
    813               avmv(:,:,jk) = avmb(jk) * vmask(:,:,jk) 
     848              avt (:,:,jk) = avtb(jk) * wmask (:,:,jk) 
     849              avm (:,:,jk) = avmb(jk) * wmask (:,:,jk) 
     850              avmu(:,:,jk) = avmb(jk) * wumask(:,:,jk) 
     851              avmv(:,:,jk) = avmb(jk) * wvmask(:,:,jk) 
    814852           END DO 
    815853        ENDIF 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/ZDF/zdftmx.F90

    r5312 r5313  
    126126      zkz(:,:) = 0.e0               !* Associated potential energy consummed over the whole water column 
    127127      DO jk = 2, jpkm1 
    128          zkz(:,:) = zkz(:,:) + fse3w(:,:,jk) * MAX( 0.e0, rn2(:,:,jk) ) * rau0 * zav_tide(:,:,jk)* tmask(:,:,jk) * tmask(:,:,jk-1) 
     128         zkz(:,:) = zkz(:,:) + fse3w(:,:,jk) * MAX( 0.e0, rn2(:,:,jk) ) * rau0 * zav_tide(:,:,jk) * wmask(:,:,jk) 
    129129      END DO 
    130130 
    … …  
    135135      END DO 
    136136 
    137       DO jj = 1, jpj                !* Here zkz should be equal to en_tmx ==> multiply by en_tmx/zkz to recover en_tmx 
    138          DO ji = 1, jpi 
    139             DO jk = mikt(ji,jj)+1, jpkm1     !* Mutiply by zkz to recover en_tmx, BUT bound by 30/6 ==> zav_tide bound by 300 cm2/s 
    140                zav_tide(ji,jj,jk) = zav_tide(ji,jj,jk) * MIN( zkz(ji,jj), 30./6. )   !kz max = 300 cm2/s 
     137      DO jk = 2, jpkm1     !* Mutiply by zkz to recover en_tmx, BUT bound by 30/6 ==> zav_tide bound by 300 cm2/s 
     138         DO jj = 1, jpj                !* Here zkz should be equal to en_tmx ==> multiply by en_tmx/zkz to recover en_tmx 
     139            DO ji = 1, jpi 
     140               zav_tide(ji,jj,jk) = zav_tide(ji,jj,jk) * MIN( zkz(ji,jj), 30./6. ) * wmask(ji,jj,jk)  !kz max = 300 cm2/s 
    141141            END DO 
    142142         END DO 
    … …  
    166166      !                          !   Update  mixing coefs  !                           
    167167      !                          ! ----------------------- ! 
    168       DO jj = 1, jpj                !* Here zkz should be equal to en_tmx ==> multiply by en_tmx/zkz to recover en_tmx 
    169          DO ji = 1, jpi 
    170             DO jk = mikt(ji,jj)+1, jpkm1              !* update momentum & tracer diffusivity with tidal mixing 
    171                avt(ji,jj,jk) = avt(ji,jj,jk) + zav_tide(ji,jj,jk) 
    172                avm(ji,jj,jk) = avm(ji,jj,jk) + zav_tide(ji,jj,jk) 
     168      DO jk = 2, jpkm1              !* update momentum & tracer diffusivity with tidal mixing 
     169         DO jj = 1, jpj                !* Here zkz should be equal to en_tmx ==> multiply by en_tmx/zkz to recover en_tmx 
     170            DO ji = 1, jpi 
     171               avt(ji,jj,jk) = avt(ji,jj,jk) + zav_tide(ji,jj,jk) * wmask(ji,jj,jk) 
     172               avm(ji,jj,jk) = avm(ji,jj,jk) + zav_tide(ji,jj,jk) * wmask(ji,jj,jk) 
    173173            END DO 
    174174         END DO 
    175175      END DO 
    176176       
    177       DO jj = 2, jpjm1 
    178          DO ji = fs_2, fs_jpim1  ! vector opt. 
    179             DO jk = mikt(ji,jj)+1, jpkm1              !* update momentum & tracer diffusivity with tidal mixing 
    180                avmu(ji,jj,jk) = avmu(ji,jj,jk) + 0.5 * ( zav_tide(ji,jj,jk) + zav_tide(ji+1,jj  ,jk) ) * umask(ji,jj,jk) 
    181                avmv(ji,jj,jk) = avmv(ji,jj,jk) + 0.5 * ( zav_tide(ji,jj,jk) + zav_tide(ji  ,jj+1,jk) ) * vmask(ji,jj,jk) 
     177      DO jk = 2, jpkm1              !* update momentum & tracer diffusivity with tidal mixing 
     178         DO jj = 2, jpjm1 
     179            DO ji = fs_2, fs_jpim1  ! vector opt. 
     180               avmu(ji,jj,jk) = avmu(ji,jj,jk) + 0.5 * ( zav_tide(ji,jj,jk) + zav_tide(ji+1,jj  ,jk) ) * wumask(ji,jj,jk) 
     181               avmv(ji,jj,jk) = avmv(ji,jj,jk) + 0.5 * ( zav_tide(ji,jj,jk) + zav_tide(ji  ,jj+1,jk) ) * wvmask(ji,jj,jk) 
    182182            END DO 
    183183         END DO 
    … …  
    457457         ztpc = 0.e0 
    458458         zpc(:,:,:) = MAX(rn_n2min,rn2(:,:,:)) * zav_tide(:,:,:) 
    459          DO jj = 1, jpj 
    460             DO ji = 1, jpi 
    461                DO jk= mikt(ji,jj)+1, jpkm1 
    462                   ztpc = ztpc + fse3w(ji,jj,jk) * e1t(ji,jj) * e2t(ji,jj) * zpc(ji,jj,jk) * tmask(ji,jj,jk) * tmask_i(ji,jj) 
     459         DO jk= 2, jpkm1 
     460            DO jj = 1, jpj 
     461               DO ji = 1, jpi 
     462                  ztpc = ztpc + fse3w(ji,jj,jk) * e1t(ji,jj) * e2t(ji,jj) * zpc(ji,jj,jk) * wmask(ji,jj,jk) * tmask_i(ji,jj) 
    463463               END DO 
    464464            END DO 
    … …  
    473473         zav_tide(:,:,:) = MIN( zav_tide(:,:,:), 60.e-4 )    
    474474         zkz(:,:) = 0.e0 
    475          DO jj = 1, jpj 
    476             DO ji = 1, jpi 
    477                DO jk = mikt(ji,jj)+1, jpkm1 
    478                zkz(ji,jj) = zkz(ji,jj) + fse3w(ji,jj,jk) * MAX( 0.e0, rn2(ji,jj,jk) ) * rau0 * zav_tide(ji,jj,jk)* tmask(ji,jj,jk) 
     475         DO jk = 2, jpkm1 
     476            DO jj = 1, jpj 
     477               DO ji = 1, jpi 
     478                  zkz(ji,jj) = zkz(ji,jj) + fse3w(ji,jj,jk) * MAX(0.e0, rn2(ji,jj,jk)) * rau0 * zav_tide(ji,jj,jk) * wmask(ji,jj,jk) 
    479479               END DO 
    480480            END DO 
    … …  
    498498         WRITE(numout,*) '          Min de zkz ', ztpc, ' Max = ', maxval(zkz(:,:) ) 
    499499 
    500          DO jj = 1, jpj 
    501             DO ji = 1, jpi 
    502                DO jk = mikt(ji,jj)+1, jpkm1 
    503                   zav_tide(ji,jj,jk) = zav_tide(ji,jj,jk) * MIN( zkz(ji,jj), 30./6. )   !kz max = 300 cm2/s 
     500         DO jk = 2, jpkm1 
     501            DO jj = 1, jpj 
     502               DO ji = 1, jpi 
     503                  zav_tide(ji,jj,jk) = zav_tide(ji,jj,jk) * MIN( zkz(ji,jj), 30./6. ) * wmask(ji,jj,jk)  !kz max = 300 cm2/s 
    504504               END DO 
    505505            END DO 
    … …  
    510510            DO jj = 1, jpj 
    511511               DO ji = 1, jpi 
    512                   ztpc = ztpc + fse3w(ji,jj,jk) * e1t(ji,jj) * e2t(ji,jj) * zpc(ji,jj,jk) * tmask(ji,jj,jk) * tmask_i(ji,jj) 
     512                  ztpc = ztpc + fse3w(ji,jj,jk) * e1t(ji,jj) * e2t(ji,jj) * zpc(ji,jj,jk) * wmask(ji,jj,jk) * tmask_i(ji,jj) 
    513513               END DO 
    514514            END DO 
    … …  
    519519         DO jk = 1, jpk 
    520520            ze_z =                  SUM( e1t(:,:) * e2t(:,:) * zav_tide(:,:,jk)     * tmask_i(:,:) )   & 
    521                &     / MAX( 1.e-20, SUM( e1t(:,:) * e2t(:,:) * tmask (:,:,jk) * tmask_i(:,:) ) ) 
     521               &     / MAX( 1.e-20, SUM( e1t(:,:) * e2t(:,:) * wmask (:,:,jk) * tmask_i(:,:) ) ) 
    522522            ztpc = 1.E50 
    523523            DO jj = 1, jpj 
    … …  
    540540            END DO 
    541541            ze_z =                  SUM( e1t(:,:) * e2t(:,:) * zkz(:,:)     * tmask_i(:,:) )   & 
    542                &     / MAX( 1.e-20, SUM( e1t(:,:) * e2t(:,:) * tmask (:,:,jk) * tmask_i(:,:) ) ) 
     542               &     / MAX( 1.e-20, SUM( e1t(:,:) * e2t(:,:) * wmask (:,:,jk) * tmask_i(:,:) ) ) 
    543543            WRITE(numout,*) '                jk= ', jk,'   ', ze_z * 1.e4,' cm2/s' 
    544544         END DO 
    … …  
    546546            zkz(:,:) = az_tmx(:,:,jk) /rn_n2min 
    547547            ze_z =                  SUM( e1t(:,:) * e2t(:,:) * zkz(:,:)     * tmask_i(:,:) )   & 
    548                &     / MAX( 1.e-20, SUM( e1t(:,:) * e2t(:,:) * tmask (:,:,jk) * tmask_i(:,:) ) ) 
     548               &     / MAX( 1.e-20, SUM( e1t(:,:) * e2t(:,:) * wmask (:,:,jk) * tmask_i(:,:) ) ) 
    549549            WRITE(numout,*)  
    550550            WRITE(numout,*) '          N2 min - jk= ', jk,'   ', ze_z * 1.e4,' cm2/s min= ',MINVAL(zkz)*1.e4,   & 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/nemogcm.F90

    r5312 r5313  
    222222         &             nn_bench, nn_timing 
    223223      NAMELIST/namcfg/ cp_cfg, cp_cfz, jp_cfg, jpidta, jpjdta, jpkdta, jpiglo, jpjglo, & 
    224          &             jpizoom, jpjzoom, jperio 
     224         &             jpizoom, jpjzoom, jperio, ln_use_jattr 
    225225      !!---------------------------------------------------------------------- 
    226226      ! 
    … …  
    261261      nperio  = 0 
    262262      jperio  = 0 
     263      ln_use_jattr = .false. 
    263264   ENDIF 
    264265#endif 
    … …  
    341342         WRITE(numout,*) '                       NEMO team' 
    342343         WRITE(numout,*) '            Ocean General Circulation Model' 
    343          WRITE(numout,*) '                  version 3.4  (2011) ' 
     344         WRITE(numout,*) '                  version 3.6  (2015) ' 
    344345         WRITE(numout,*) 
    345346         WRITE(numout,*) 
    … …  
    383384      IF( lk_tide       )   CALL    tide_init( nit000 )    ! Initialisation of the tidal harmonics 
    384385 
     386                            CALL     sbc_init   ! Forcings : surface module (clem: moved here for bdy purpose) 
     387 
    385388      IF( lk_bdy        )   CALL     bdy_init   ! Open boundaries initialisation 
    386389      IF( lk_bdy        )   CALL bdy_dta_init   ! Open boundaries initialisation of external data arrays 
    … …  
    389392 
    390393                            CALL dyn_nept_init  ! simplified form of Neptune effect 
    391  
    392394      !      
    393395      IF( ln_crs        )   CALL     crs_init   ! Domain initialization of coarsened grid 
    394396      ! 
    395397                                ! Ocean physics 
    396                             CALL     sbc_init   ! Forcings : surface module 
    397398      !                                         ! Vertical physics 
    398399                            CALL     zdf_init      ! namelist read 
    … …  
    506507         WRITE(numout,*) '      left bottom j index of the zoom (in data domain) jpizoom = ', jpjzoom 
    507508         WRITE(numout,*) '      lateral cond. type (between 0 and 6) jperio = ', jperio    
     509         WRITE(numout,*) '      use file attribute if exists as i/p j-start ln_use_jattr = ', ln_use_jattr 
    508510      ENDIF 
    509511      !                             ! Parameter control 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/par_oce.F90

    r5312 r5313  
    5353   !                                       !  = 6 cyclic East-West AND North fold F-point pivot 
    5454 
     55   ! Input file read offset 
     56   LOGICAL       ::   ln_use_jattr     !: Use file global attribute: open_ocean_jstart to determine start j-row  
     57                                           ! when reading input from those netcdf files that have the  
     58                                           ! attribute defined. This is designed to enable input files associated  
     59                                           ! with the extended grids used in the under ice shelf configurations to  
     60                                           ! be used without redundant rows when the ice shelves are not in use. 
     61 
    5562   !!  Values set to pp_not_used indicates that this parameter is not used in THIS config. 
    5663   !!  Values set to pp_to_be_computed  indicates that variables will be computed in domzgr 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/step.F90

    r5312 r5313  
    122122      IF( lk_zdfkpp  )   CALL zdf_kpp( kstp )            ! KPP closure scheme for Kz 
    123123      IF( lk_zdfcst  ) THEN                              ! Constant Kz (reset avt, avm[uv] to the background value) 
    124          avt (:,:,:) = rn_avt0 * tmask(:,:,:) 
    125          avmu(:,:,:) = rn_avm0 * umask(:,:,:) 
    126          avmv(:,:,:) = rn_avm0 * vmask(:,:,:) 
     124         avt (:,:,:) = rn_avt0 * wmask (:,:,:) 
     125         avmu(:,:,:) = rn_avm0 * wumask(:,:,:) 
     126         avmv(:,:,:) = rn_avm0 * wvmask(:,:,:) 
    127127      ENDIF 
    128128      IF( ln_rnf_mouth ) THEN                         ! increase diffusivity at rivers mouths 
    … …  
    145145      ! 
    146146      IF( lk_ldfslp ) THEN                            ! slope of lateral mixing 
    147                          CALL eos( tsb, rhd, gdept_0(:,:,:) )             ! before in situ density 
    148          IF( ln_zps )    CALL zps_hde( kstp, jpts, tsb, gtsu, gtsv,  &        ! Partial steps: before horizontal gradient 
    149             &                                      rhd, gru , grv , aru , arv , gzu , gzv , ge3ru , ge3rv ,   &             ! 
    150             &                               gtui, gtvi, grui, grvi, arui, arvi, gzui, gzvi, ge3rui, ge3rvi  )  ! of t, s, rd at the last ocean level 
     147                         CALL eos( tsb, rhd, gdept_0(:,:,:) )               ! before in situ density 
     148         IF( ln_zps .AND. .NOT. ln_isfcav)                               & 
     149            &            CALL zps_hde    ( kstp, jpts, tsb, gtsu, gtsv,  &  ! Partial steps: before horizontal gradient 
     150            &                                          rhd, gru , grv    )  ! of t, s, rd at the last ocean level 
     151         IF( ln_zps .AND.       ln_isfcav)                               & 
     152            &            CALL zps_hde_isf( kstp, jpts, tsb, gtsu, gtsv,  &    ! Partial steps for top cell (ISF) 
     153            &                                          rhd, gru , grv , aru , arv , gzu , gzv , ge3ru , ge3rv ,   & 
     154            &                                   gtui, gtvi, grui, grvi, arui, arvi, gzui, gzvi, ge3rui, ge3rvi    ) ! of t, s, rd at the first ocean level 
    151155         IF( ln_traldf_grif ) THEN                           ! before slope for Griffies operator 
    152156                         CALL ldf_slp_grif( kstp ) 
    … …  
    177181          ! is necessary to compute momentum advection for the rhs of barotropic loop: 
    178182                            CALL eos    ( tsn, rhd, rhop, fsdept_n(:,:,:) ) ! now in situ density for hpg computation 
    179             IF( ln_zps )    CALL zps_hde( kstp, jpts, tsn, gtsu, gtsv,  &        ! Partial steps: before horizontal gradient 
    180                &                                      rhd, gru , grv , aru , arv , gzu , gzv , ge3ru , ge3rv ,   &             ! 
    181                &                               gtui, gtvi, grui, grvi, arui, arvi, gzui, gzvi, ge3rui, ge3rvi  )  ! of t, s, rd at the last ocean level 
     183            IF( ln_zps .AND. .NOT. ln_isfcav)                               & 
     184               &            CALL zps_hde    ( kstp, jpts, tsn, gtsu, gtsv,  &    ! Partial steps: before horizontal gradient 
     185               &                                          rhd, gru , grv    )  ! of t, s, rd at the last ocean level 
     186            IF( ln_zps .AND.       ln_isfcav)                               & 
     187               &            CALL zps_hde_isf( kstp, jpts, tsn, gtsu, gtsv,  &    ! Partial steps for top cell (ISF) 
     188               &                                          rhd, gru , grv , aru , arv , gzu , gzv , ge3ru , ge3rv ,   & 
     189               &                                   gtui, gtvi, grui, grvi, arui, arvi, gzui, gzvi, ge3rui, ge3rvi    ) ! of t, s, rd at the last ocean level 
    182190 
    183191                                  ua(:,:,:) = 0.e0             ! set dynamics trends to zero 
    … …  
    208216      ! diagnostics and outputs             (ua, va, tsa used as workspace) 
    209217      !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 
    210       IF( lk_floats  )   CALL flo_stp( kstp )         ! drifting Floats 
    211       IF( lk_diahth  )   CALL dia_hth( kstp )         ! Thermocline depth (20 degres isotherm depth) 
    212       IF( .NOT. lk_cpl ) CALL dia_fwb( kstp )         ! Fresh water budget diagnostics 
    213       IF( ln_diaptr  )   CALL dia_ptr( kstp )         ! Poleward TRansports diagnostics 
    214       IF( lk_diadct  )   CALL dia_dct( kstp )         ! Transports 
    215       IF( lk_diaar5  )   CALL dia_ar5( kstp )         ! ar5 diag 
    216       IF( lk_diaharm )   CALL dia_harm( kstp )        ! Tidal harmonic analysis 
    217                          CALL dia_wri( kstp )         ! ocean model: outputs 
    218       ! 
    219       IF( ln_crs     )   CALL crs_fld( kstp )         ! ocean model: online field coarsening & output 
    220  
     218      IF( lk_floats  )      CALL flo_stp( kstp )         ! drifting Floats 
     219      IF( lk_diahth  )      CALL dia_hth( kstp )         ! Thermocline depth (20 degres isotherm depth) 
     220      IF( .NOT. lk_cpl )    CALL dia_fwb( kstp )         ! Fresh water budget diagnostics 
     221      IF( lk_diadct  )      CALL dia_dct( kstp )         ! Transports 
     222      IF( lk_diaar5  )      CALL dia_ar5( kstp )         ! ar5 diag 
     223      IF( lk_diaharm )      CALL dia_harm( kstp )        ! Tidal harmonic analysis 
     224                            CALL dia_wri( kstp )         ! ocean model: outputs 
     225      ! 
     226      IF( ln_crs     )      CALL crs_fld( kstp )         ! ocean model: online field coarsening & output 
    221227 
    222228#if defined key_top 
    … …  
    244250      IF( lk_zdfkpp      )   CALL tra_kpp    ( kstp )       ! KPP non-local tracer fluxes 
    245251                             CALL tra_ldf    ( kstp )       ! lateral mixing 
     252 
     253      IF( ln_diaptr      )   CALL dia_ptr                   ! Poleward adv/ldf TRansports diagnostics 
     254 
    246255#if defined key_agrif 
    247256      IF(.NOT. Agrif_Root()) CALL Agrif_Sponge_tra          ! tracers sponge 
    … …  
    253262                             CALL tra_nxt( kstp )                ! tracer fields at next time step 
    254263                             CALL eos    ( tsa, rhd, rhop, fsdept_n(:,:,:) )  ! Time-filtered in situ density for hpg computation 
    255          IF( ln_zps      )   CALL zps_hde( kstp, jpts, tsa, gtsu, gtsv,  &        ! Partial steps: before horizontal gradient 
    256             &                                      rhd, gru , grv , aru , arv , gzu , gzv , ge3ru , ge3rv ,   &             ! 
    257             &                               gtui, gtvi, grui, grvi, arui, arvi, gzui, gzvi, ge3rui, ge3rvi  )  ! of t, s, rd at the last ocean level 
     264            IF( ln_zps .AND. .NOT. ln_isfcav)                                & 
     265               &             CALL zps_hde    ( kstp, jpts, tsa, gtsu, gtsv,  &    ! Partial steps: before horizontal gradient 
     266               &                                           rhd, gru , grv    )  ! of t, s, rd at the last ocean level 
     267            IF( ln_zps .AND.       ln_isfcav)                                & 
     268               &             CALL zps_hde_isf( kstp, jpts, tsa, gtsu, gtsv,  &    ! Partial steps for top cell (ISF) 
     269               &                                           rhd, gru , grv , aru , arv , gzu , gzv , ge3ru , ge3rv ,   & 
     270               &                                    gtui, gtvi, grui, grvi, arui, arvi, gzui, gzvi, ge3rui, ge3rvi    ) ! of t, s, rd at the last ocean level 
    258271      ELSE                                                  ! centered hpg  (eos then time stepping) 
    259272         IF ( .NOT. lk_dynspg_ts ) THEN                     ! eos already called in time-split case 
    260273                             CALL eos    ( tsn, rhd, rhop, fsdept_n(:,:,:) )  ! now in situ density for hpg computation 
    261          IF( ln_zps      )   CALL zps_hde( kstp, jpts, tsn, gtsu, gtsv,  &        ! Partial steps: before horizontal gradient 
    262          &                                      rhd, gru , grv , aru , arv , gzu , gzv , ge3ru , ge3rv ,   &             ! 
    263          &                               gtui, gtvi, grui, grvi, arui, arvi, gzui, gzvi, ge3rui, ge3rvi  )  ! of t, s, rd at the last ocean level 
     274         IF( ln_zps .AND. .NOT. ln_isfcav)                                   & 
     275               &             CALL zps_hde    ( kstp, jpts, tsn, gtsu, gtsv,  &    ! Partial steps: before horizontal gradient 
     276               &                                           rhd, gru , grv    )  ! of t, s, rd at the last ocean level 
     277         IF( ln_zps .AND.       ln_isfcav)                                   &  
     278               &             CALL zps_hde_isf( kstp, jpts, tsn, gtsu, gtsv,  &    ! Partial steps for top cell (ISF) 
     279               &                                           rhd, gru , grv , aru , arv , gzu , gzv , ge3ru , ge3rv ,   & 
     280               &                                    gtui, gtvi, grui, grvi, arui, arvi, gzui, gzvi, ge3rui, ge3rvi    ) ! of t, s, rd at the last ocean level 
    264281         ENDIF 
    265282         IF( ln_zdfnpc   )   CALL tra_npc( kstp )                ! update after fields by non-penetrative convection 
    … …  
    322339                 CALL iom_close( numror )     ! close input  ocean restart file 
    323340         IF(lwm) CALL FLUSH    ( numond )     ! flush output namelist oce 
    324          IF( lwm.AND.numoni /= -1 ) CALL FLUSH    ( numoni )     ! flush output namelist ice     
     341         IF( lwm.AND.numoni /= -1 ) CALL FLUSH    ( numoni )     ! flush output namelist ice 
    325342      ENDIF 
    326343      IF( lrst_oce         )   CALL rst_write    ( kstp )   ! write output ocean restart file 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/timing.F90

    r5312 r5313  
    211211         WRITE(numtime,*) '                             NEMO team' 
    212212         WRITE(numtime,*) '                  Ocean General Circulation Model' 
    213          WRITE(numtime,*) '                        version 3.3  (2010) ' 
     213         WRITE(numtime,*) '                        version 3.6  (2015) ' 
    214214         WRITE(numtime,*) 
    215215         WRITE(numtime,*) '                        Timing Informations ' 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/SAS_SRC/nemogcm.F90

    r5312 r5313  
    161161         &             nn_bench, nn_timing 
    162162      NAMELIST/namcfg/ cp_cfg, cp_cfz, jp_cfg, jpidta, jpjdta, jpkdta, jpiglo, jpjglo, & 
    163          &             jpizoom, jpjzoom, jperio 
     163         &             jpizoom, jpjzoom, jperio, ln_use_jattr 
    164164      !!---------------------------------------------------------------------- 
    165165      cltxt = '' 
    … …  
    250250         WRITE(numout,*) '                       NEMO team' 
    251251         WRITE(numout,*) '            Ocean General Circulation Model' 
    252          WRITE(numout,*) '                  version 3.4  (2011) ' 
     252         WRITE(numout,*) '                  version 3.6  (2015) ' 
    253253         WRITE(numout,*) '             StandAlone Surface version (SAS) ' 
    254254         WRITE(numout,*) 
    … …  
    348348         WRITE(numout,*) '      left bottom j index of the zoom (in data domain) jpizoom = ', jpjzoom 
    349349         WRITE(numout,*) '      lateral cond. type (between 0 and 6) jperio = ', jperio    
     350         WRITE(numout,*) '      use file attribute if exists as i/p j-start ln_use_jattr = ', ln_use_jattr 
    350351      ENDIF 
    351352      !                             ! Parameter control 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/TOP_SRC/C14b/trcsms_c14b.F90

    r5312 r5313  
    5454   !!---------------------------------------------------------------------- 
    5555   !! NEMO/TOP 3.3 , NEMO Consortium (2010) 
    56    !! $Header: /home/opalod/NEMOCVSROOT/NEMO/TOP_SRC/SMS/trcc14bomb.F90,v 1.2 2005/11/14 16:42:43 opalod Exp $  
     56   !! $Id$  
    5757   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
    5858   !!---------------------------------------------------------------------- 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zsbc.F90

    r5312 r5313  
    8585   !!---------------------------------------------------------------------- 
    8686   !! NEMO/TOP 3.3 , NEMO Consortium (2010) 
    87    !! $Header:$  
     87   !! $Id$  
    8888   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 
    8989   !!---------------------------------------------------------------------- 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zsed.F90

    r5312 r5313  
    4242   !!---------------------------------------------------------------------- 
    4343   !! NEMO/TOP 3.3 , NEMO Consortium (2010) 
    44    !! $Header:$  
     44   !! $Id$  
    4545   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 
    4646   !!---------------------------------------------------------------------- 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/TOP_SRC/PISCES/SED/par_sed.F90

    r5312 r5313  
    77   !!        !  06-12  (C. Ethe)  Orignal 
    88   !!---------------------------------------------------------------------- 
     9   !! $Id$ 
    910#if defined key_sed 
    1011   !! Domain characteristics 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/TOP_SRC/PISCES/SED/sed.F90

    r5312 r5313  
    160160   INTEGER, PUBLIC ::  numsed = 27    ! units 
    161161 
     162   !! $Id$ 
    162163CONTAINS 
    163164 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/TOP_SRC/PISCES/SED/sedadv.F90

    r5312 r5313  
    2323   REAL(wp) :: eps = 1.e-13 
    2424 
     25   !! $Id$ 
    2526CONTAINS 
    2627 
    … …  
    438439   !! MODULE sedbtb  :   Dummy module  
    439440   !!====================================================================== 
     441   !! $Id$ 
    440442CONTAINS 
    441443   SUBROUTINE sed_adv( kt )         ! Empty routine 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/TOP_SRC/PISCES/SED/sedarr.F90

    r5312 r5313  
    2929   !!---------------------------------------------------------------------- 
    3030   !! NEMO/TOP 3.3 , NEMO Consortium (2010) 
    31    !! $Header: /home/opalod/NEMOCVSROOT/NEMO/LIM_SRC/limtab.F90,v 1.2 2005/03/27 18:34:42 opalod Exp $  
     31   !! $Id$  
    3232   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 
    3333   !!---------------------------------------------------------------------- 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/TOP_SRC/PISCES/SED/sedbtb.F90

    r5312 r5313  
    1212 
    1313 
     14   !! $Id$ 
    1415CONTAINS 
    1516    
    … …  
    7778   !! MODULE sedbtb  :   Dummy module  
    7879   !!====================================================================== 
     80   !! $Id$ 
    7981CONTAINS 
    8082   SUBROUTINE sed_btb( kt )         ! Empty routine 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/TOP_SRC/PISCES/SED/sedchem.F90

    r5312 r5313  
    163163   DATA Ddsw / 999.842594 , 6.793952E-2 , -9.095290E-3, 1.001685E-4, -1.120083E-6, 6.536332E-9/ 
    164164 
     165   !! $Id$ 
    165166CONTAINS 
    166167 
    … …  
    559560   !! MODULE sedchem  :   Dummy module  
    560561   !!====================================================================== 
     562   !! $Id$ 
    561563CONTAINS 
    562564   SUBROUTINE sed_chem( kt )         ! Empty routine 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/TOP_SRC/PISCES/SED/sedco3.F90

    r5312 r5313  
    2323   !!---------------------------------------------------------------------- 
    2424 
     25   !! $Id$ 
    2526CONTAINS 
    2627 
    … …  
    188189   !! MODULE sedco3  :   Dummy module  
    189190   !!====================================================================== 
     191   !! $Id$ 
    190192CONTAINS 
    191193   SUBROUTINE sed_co3( kt )         ! Empty routine 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/TOP_SRC/PISCES/SED/seddsr.F90

    r5312 r5313  
    2020   REAL(wp), DIMENSION(:), ALLOCATABLE, PUBLIC ::  dens_mol_wgt  ! molecular density  
    2121 
     22   !! $Id$ 
    2223CONTAINS 
    2324    
    … …  
    530531   !! MODULE seddsr  :   Dummy module  
    531532   !!====================================================================== 
     533   !! $Id$ 
    532534CONTAINS 
    533535   SUBROUTINE sed_dsr ( kt ) 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/TOP_SRC/PISCES/SED/seddta.F90

    r5312 r5313  
    2828#endif 
    2929 
     30   !! $Id$ 
    3031CONTAINS 
    3132 
    … …  
    268269   !! MODULE seddta  :   Dummy module  
    269270   !!====================================================================== 
     271   !! $Id$ 
    270272CONTAINS 
    271273   SUBROUTINE sed_dta ( kt ) 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/TOP_SRC/PISCES/SED/sedini.F90

    r5312 r5313  
    5555   PUBLIC sed_init          ! routine called by opa.F90 
    5656 
     57   !! $Id$ 
    5758CONTAINS 
    5859 
    … …  
    856857   !!   Dummy module :                      NO Sediment model 
    857858   !!---------------------------------------------------------------------- 
     859   !! $Id$ 
    858860CONTAINS 
    859861   SUBROUTINE sed_ini              ! Empty routine 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/TOP_SRC/PISCES/SED/sedmat.F90

    r5312 r5313  
    2222 
    2323 
     24   !! $Id$ 
    2425 CONTAINS 
    2526 
    … …  
    257258   !! MODULE sedmat  :   Dummy module  
    258259   !!====================================================================== 
     260   !! $Id$ 
    259261CONTAINS 
    260262   SUBROUTINE sed_mat         ! Empty routine 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/TOP_SRC/PISCES/SED/sedmbc.F90

    r5312 r5313  
    3636   REAL(wp)  :: src13ca   
    3737 
     38   !! $Id$ 
    3839CONTAINS 
    3940 
    … …  
    311312   !! MODULE sedmbc :   Dummy module  
    312313   !!====================================================================== 
     314   !! $Id$ 
    313315CONTAINS 
    314316   SUBROUTINE sed_mbc( kt )         ! Empty routine 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/TOP_SRC/PISCES/SED/sedmodel.F90

    r5312 r5313  
    1717   LOGICAL, PUBLIC, PARAMETER ::   lk_sed = .TRUE.     !: sediment flag 
    1818 
     19   !! $Id$ 
    1920CONTAINS 
    2021 
    … …  
    4748   !!====================================================================== 
    4849   LOGICAL, PUBLIC, PARAMETER ::   lk_sed = .FALSE.     !: sediment flag 
     50   !! $Id$ 
    4951CONTAINS 
    5052   SUBROUTINE sed_model( kt )         ! Empty routine 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/TOP_SRC/PISCES/SED/sedrst.F90

    r5312 r5313  
    2525    
    2626    
     27   !! $Id$ 
    2728CONTAINS 
    2829 
    … …  
    270271   !! MODULE sedrst :   Dummy module  
    271272   !!====================================================================== 
     273   !! $Id$ 
    272274CONTAINS 
    273275   SUBROUTINE sed_rst_read                      ! Empty routines 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/TOP_SRC/PISCES/SED/sedsfc.F90

    r5312 r5313  
    1212   PUBLIC sed_sfc 
    1313 
     14   !! $Id$ 
    1415CONTAINS 
    1516 
    … …  
    6768   !! MODULE sedsfc  :   Dummy module  
    6869   !!====================================================================== 
     70   !! $Id$ 
    6971CONTAINS 
    7072   SUBROUTINE sed_sfc ( kt ) 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/TOP_SRC/PISCES/SED/sedstp.F90

    r5312 r5313  
    2323   PUBLIC sed_stp  ! called by step.F90 
    2424 
     25   !! $Id$ 
    2526CONTAINS 
    2627 
    … …  
    6970   !! MODULE sedstp  :   Dummy module  
    7071   !!====================================================================== 
     72   !! $Id$ 
    7173CONTAINS 
    7274   SUBROUTINE sed_stp( kt )         ! Empty routine 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/TOP_SRC/PISCES/SED/sedwri.F90

    r5312 r5313  
    2525   INTEGER, ALLOCATABLE, SAVE, DIMENSION(:) :: ndext51 
    2626 
     27   !! $Id$ 
    2728CONTAINS 
    2829 
    … …  
    264265   !! MODULE sedwri  :   Dummy module 
    265266   !!====================================================================== 
     267   !! $Id$ 
    266268CONTAINS 
    267269   SUBROUTINE sed_wri( kt )         ! Empty routine 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/TOP_SRC/TRP/trcdmp.F90

    r5312 r5313  
    4343   !!---------------------------------------------------------------------- 
    4444   !! NEMO/TOP 3.3 , NEMO Consortium (2010) 
    45    !! $Header: /home/opalod/NEMOCVSROOT/NEMO/TOP_SRC/TRP/trcdmp.F90,v 1.11 2006/09/01 14:03:49 opalod Exp $  
     45   !! $Id$  
    4646   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
    4747   !!---------------------------------------------------------------------- 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/TOP_SRC/TRP/trctrp.F90

    r5312 r5313  
    8282      IF( .NOT. Agrif_Root())   CALL Agrif_Update_Trc( kstp )   ! Update tracer at AGRIF zoom boundaries : children only 
    8383#endif 
    84          IF( ln_zps    )        CALL zps_hde( kstp, jptra, trn, pgtu=gtru, pgtv=gtrv, sgtu=gtrui, sgtv=gtrvi )  ! Partial steps: now horizontal gradient of passive 
     84 
     85         IF( ln_zps  .AND. .NOT. ln_isfcav)        & 
     86            &            CALL zps_hde    ( kstp, jptra, trn, gtru, gtrv )   ! Partial steps: now horizontal gradient of passive 
     87         IF( ln_zps .AND.        ln_isfcav)        & 
     88            &            CALL zps_hde_isf( kstp, jptra, trn, pgtu=gtru, pgtv=gtrv, pgtui=gtrui, pgtvi=gtrvi )  ! Partial steps: now horizontal gradient of passive 
    8589                                                                ! tracers at the bottom ocean level 
    8690         ! 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/TOP_SRC/TRP/trdmxl_trc.F90

    r5312 r5313  
    7171   !!---------------------------------------------------------------------- 
    7272   !! NEMO/TOP 3.3 , NEMO Consortium (2010) 
    73    !! $Header:  $  
     73   !! $Id$  
    7474   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
    7575   !!---------------------------------------------------------------------- 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/TOP_SRC/TRP/trdmxl_trc_rst.F90

    r5312 r5313  
    2323   !!--------------------------------------------------------------------------------- 
    2424   !! NEMO/TOP 3.3 , NEMO Consortium (2010) 
    25    !! $Header: /home/opalod/NEMOCVSROOT/NEMO/OPA_SRC/TRD/trdmxl_rst.F90,v 1.6 2006/11/14 09:46:13 opalod Exp $  
     25   !! $Id$  
    2626   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 
    2727   !!--------------------------------------------------------------------------------- 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/TOP_SRC/TRP/trdtrc.F90

    r5312 r5313  
    3333   !!---------------------------------------------------------------------- 
    3434   !! NEMO/TOP 3.3 , NEMO Consortium (2010) 
    35    !! $Header:  $  
     35   !! $Id$  
    3636   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 
    3737   !!---------------------------------------------------------------------- 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/TOP_SRC/TRP/trdtrc_oce.F90

    r5312 r5313  
    118118   !!---------------------------------------------------------------------- 
    119119   !! NEMO/TOP 3.3 , NEMO Consortium (2010) 
    120    !! $Header: /home/opalod/NEMOCVSROOT/NEMO/OPA_SRC/TRD/trdmxl_oce.F90,v 1.2 2005/03/27 18:35:23 opalod Exp $  
     120   !! $Id$  
    121121   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
    122122   !!---------------------------------------------------------------------- 

  • branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/TOP_SRC/trcini.F90

    r5312 r5313  
    143143  
    144144      tra(:,:,:,:) = 0._wp 
    145       IF( ln_zps .AND. .NOT. lk_c1d )   &              ! Partial steps: before horizontal gradient of passive 
    146         &    CALL zps_hde( nit000, jptra, trn, pgtu=gtru, pgtv=gtrv, sgtu=gtrui, sgtv=gtrvi )       ! tracers at the bottom ocean level 
     145      IF( ln_zps .AND. .NOT. lk_c1d .AND. .NOT. ln_isfcav )   &              ! Partial steps: before horizontal gradient of passive 
     146        &    CALL zps_hde    ( nit000, jptra, trn, gtru, gtrv  )  ! Partial steps: before horizontal gradient 
     147      IF( ln_zps .AND. .NOT. lk_c1d .AND.       ln_isfcav )   & 
     148        &    CALL zps_hde_isf( nit000, jptra, trn, pgtu=gtru, pgtv=gtrv, pgtui=gtrui, pgtvi=gtrvi )       ! tracers at the bottom ocean level 
     149 
    147150 
    148151      ! 
Note: See TracChangeset for help on using the changeset viewer.