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 7278 – NEMO

Changeset 7278


Ignore:
Timestamp:
2016-11-21T10:38:43+01:00 (8 years ago)
Author:
flavoni
Message:

update branch CNRS-2016 to trunk 6720

Location:
branches/2016/dev_CNRS_2016/NEMOGCM
Files:
69 edited

Legend:

Unmodified
Added
Removed

  • branches/2016/dev_CNRS_2016/NEMOGCM/ARCH/CMCC/arch-ifort_athena_xios.fcm

    r6409 r7278  
    3434 
    3535# required modules 
    36 # module load  INTEL/intel_xe_2013 NETCDF/netcdf-4.3_parallel NETCDF/parallel-netcdf-1.3.1 HDF5/hdf5-1.8.11_parallel 
     36# module load  INTEL/intel_xe_2013 NETCDF/netcdf-4.3_parallel NETCDF/parallel-netcdf-1.7.0 HDF5/hdf5-1.8.11_parallel 
    3737 
    38 # Environment variables set by user. Others should automatically define when loading modules. 
     38# NETCDF and PNETCDF should be set automatically when loading modules. 
     39# The following environment variables must be set by the user. 
    3940#export XIOS=/users/home/models/nemo/xios 
    4041#export HDF5=/users/home/opt/hdf5/hdf5-1.8.11_parallel 
    41 #export NETCDF=/users/home/opt/netcdf/netcdf-4.3_parallel 
    4242 
    43 %NCDF_INC            -I${NETCDF}/include  
    44 %NCDF_LIB            -L${NETCDF}/lib -lnetcdff -lnetcdf 
     43%NCDF_INC            -I${NETCDF}/include -I${PNETCDF}/include 
     44%NCDF_LIB            -L${NETCDF}/lib -lnetcdff -lnetcdf -L${PNETCDF}/lib -lpnetcdf 
    4545%HDF5_INC            -I${HDF5}/include 
    4646%HDF5_LIB            -L${HDF5}/lib -lhdf5_hl -lhdf5 

  • branches/2016/dev_CNRS_2016/NEMOGCM/CONFIG/AMM12/EXP00/namelist_cfg

    r7277 r7278  
    216216&nameos        !   ocean physical parameters 
    217217!----------------------------------------------------------------------- 
     218   ln_teos10   = .true.         !  = Use TEOS-10 equation of state 
    218219/ 
    219220!----------------------------------------------------------------------- 

  • branches/2016/dev_CNRS_2016/NEMOGCM/CONFIG/C1D_PAPA/EXP00/namelist_cfg

    r7277 r7278  
    198198&nameos        !   ocean physical parameters 
    199199!----------------------------------------------------------------------- 
    200    nn_eos      =  0      !  type of equation of state and Brunt-Vaisala frequency 
    201                                  !  =-1, TEOS-10 
    202                                  !  = 0, EOS-80 
    203                                  !  = 1, S-EOS   (simplified eos) 
    204    ln_useCT    = .false. ! use of Conservative Temp. ==> surface CT converted in Pot. Temp. in sbcssm 
     200   ln_eos80    = .true.         !  = Use EOS80 equation of state 
    205201/ 
    206202!----------------------------------------------------------------------- 

  • branches/2016/dev_CNRS_2016/NEMOGCM/CONFIG/GYRE/EXP00/namelist_cfg

    r7277 r7278  
    162162&nameos        !   ocean physical parameters 
    163163!----------------------------------------------------------------------- 
    164    nn_eos      =  0       !  type of equation of state and Brunt-Vaisala frequency 
    165                                  !  =-1, TEOS-10  
    166                                  !  = 0, EOS-80  
    167                                  !  = 1, S-EOS   (simplified eos) 
    168    ln_useCT    = .false.  ! use of Conservative Temp. ==> surface CT converted in Pot. Temp. in sbcssm 
     164   ln_eos80    = .true.         !  = Use EOS80 equation of state 
    169165   !                             ! 
    170166   !                      ! S-EOS coefficients : 

  • branches/2016/dev_CNRS_2016/NEMOGCM/CONFIG/GYRE_BFM/EXP00/namelist_cfg

    r7277 r7278  
    152152&nameos        !   ocean physical parameters 
    153153!----------------------------------------------------------------------- 
    154    nn_eos      =  0       !  type of equation of state and Brunt-Vaisala frequency 
    155                                  !  =-1, TEOS-10 
    156                                  !  = 0, EOS-80 
    157                                  !  = 1, S-EOS   (simplified eos) 
    158    ln_useCT    = .false.  ! use of Conservative Temp. ==> surface CT converted in Pot. Temp. in sbcssm 
     154   ln_eos80    = .true.         !  = Use EOS80 equation of state 
    159155   !                             ! 
    160156   !                      ! S-EOS coefficients : 

  • branches/2016/dev_CNRS_2016/NEMOGCM/CONFIG/GYRE_PISCES/EXP00/namelist_cfg

    r7277 r7278  
    8080&nameos        !   ocean physical parameters 
    8181!----------------------------------------------------------------------- 
    82    nn_eos      =  0       !  type of equation of state and Brunt-Vaisala frequency 
    83                                  !  =-1, TEOS-10 
    84                                  !  = 0, EOS-80 
    85                                  !  = 1, S-EOS   (simplified eos) 
    86    ln_useCT    = .false.  ! use of Conservative Temp. ==> surface CT converted in Pot. Temp. in sbcssm 
     82   ln_eos80    = .true.         !  = Use EOS80 equation of state 
    8783   !                             ! 
    8884   !                      ! S-EOS coefficients : 

  • branches/2016/dev_CNRS_2016/NEMOGCM/CONFIG/GYRE_XIOS/EXP00/namelist_cfg

    r7277 r7278  
    149149&nameos        !   ocean physical parameters 
    150150!----------------------------------------------------------------------- 
    151    nn_eos      =   0       !  type of equation of state and Brunt-Vaisala frequency 
     151   ln_eos80    = .true.         !  = Use EOS80 equation of state 
    152152/ 
    153153!----------------------------------------------------------------------- 

  • branches/2016/dev_CNRS_2016/NEMOGCM/CONFIG/ORCA2_LIM/EXP00/1_namelist_cfg

    r7277 r7278  
    110110&nameos        !   ocean physical parameters 
    111111!----------------------------------------------------------------------- 
     112   ln_teos10    = .true.         !  = Use TEOS-10 equation of state 
    112113/ 
    113114!----------------------------------------------------------------------- 

  • branches/2016/dev_CNRS_2016/NEMOGCM/CONFIG/ORCA2_LIM/EXP00/namelist_cfg

    r7277 r7278  
    8989&nameos        !   ocean physical parameters 
    9090!----------------------------------------------------------------------- 
     91   ln_teos10    = .true.         !  = Use TEOS-10 equation of state 
    9192/ 
    9293!----------------------------------------------------------------------- 

  • branches/2016/dev_CNRS_2016/NEMOGCM/CONFIG/ORCA2_LIM3/EXP00/namelist_cfg

    r7277 r7278  
    119119&nameos        !   ocean physical parameters 
    120120!----------------------------------------------------------------------- 
     121   ln_teos10    = .true.         !  = Use TEOS-10 equation of state 
    121122/ 
    122123!----------------------------------------------------------------------- 

  • branches/2016/dev_CNRS_2016/NEMOGCM/CONFIG/ORCA2_LIM_CFC_C14b/EXP00/namelist_cfg

    r7277 r7278  
    152152&nameos        !   ocean physical parameters 
    153153!----------------------------------------------------------------------- 
     154   ln_teos10    = .true.         !  = Use TEOS-10 equation of state 
    154155/ 
    155156!----------------------------------------------------------------------- 

  • branches/2016/dev_CNRS_2016/NEMOGCM/CONFIG/ORCA2_LIM_PISCES/EXP00/namelist_cfg

    r7277 r7278  
    8989&nameos        !   ocean physical parameters 
    9090!----------------------------------------------------------------------- 
     91   ln_teos10    = .true.         !  = Use TEOS-10 equation of state 
    9192/ 
    9293!----------------------------------------------------------------------- 

  • branches/2016/dev_CNRS_2016/NEMOGCM/CONFIG/ORCA2_OFF_PISCES/EXP00/namelist_cfg

    r7277 r7278  
    6868&nameos        !   ocean physical parameters 
    6969!----------------------------------------------------------------------- 
     70   ln_teos10    = .true.         !  = Use TEOS-10 equation of state 
    7071/ 
    7172!---------------------------------------------------------------------------------- 

  • branches/2016/dev_CNRS_2016/NEMOGCM/CONFIG/ORCA2_SAS_LIM/EXP00/namelist_cfg

    r7277 r7278  
    8989&nameos        !   ocean physical parameters 
    9090!----------------------------------------------------------------------- 
     91   ln_teos10    = .true.         !  = Use TEOS-10 equation of state 
    9192/ 
    9293!----------------------------------------------------------------------- 

  • branches/2016/dev_CNRS_2016/NEMOGCM/CONFIG/SHARED/field_def.xml

    r6387 r7278  
    183183         <field id="empmr"        long_name="Net Upward Water Flux"                standard_name="water_flux_out_of_sea_ice_and_sea_water"                              unit="kg/m2/s"   /> 
    184184         <field id="empbmr"       long_name="Net Upward Water Flux at pre. tstep"  standard_name="water_flux_out_of_sea_ice_and_sea_water"                              unit="kg/m2/s"   /> 
     185         <field id="emp_oce"      long_name="Evap minus Precip over ocean"         standard_name="evap_minus_precip_over_sea_water"                                     unit="kg/m2/s"   /> 
     186         <field id="emp_ice"      long_name="Evap minus Precip over ice"           standard_name="evap_minus_precip_over_sea_ice"                                       unit="kg/m2/s"   /> 
    185187         <field id="saltflx"      long_name="Downward salt flux"                                                                                                        unit="1e-3/m2/s" /> 
    186188         <field id="fmmflx"       long_name="Water flux due to freezing/melting"                                                                                        unit="kg/m2/s"   /> 
    … …  
    275277         <field id="emp_x_sst"    long_name="Concentration/Dilution term on SST"                                                                                              unit="kg*degC/m2/s" /> 
    276278         <field id="emp_x_sss"    long_name="Concentration/Dilution term on SSS"                                                                                              unit="kg*1e-3/m2/s" />         
     279         <field id="rnf_x_sst"    long_name="Runoff term on SST"                                                                                                              unit="kg*degC/m2/s" /> 
     280         <field id="rnf_x_sss"    long_name="Runoff term on SSS"                                                                                                              unit="kg*1e-3/m2/s" /> 
    277281        
    278282         <field id="iceconc"      long_name="ice concentration"                                            standard_name="sea_ice_area_fraction"                              unit="%"            /> 
    … …  
    289293         <field id="micesalt"     long_name="Mean ice salinity"                                                                                                               unit="1e-3"         /> 
    290294         <field id="miceage"      long_name="Mean ice age"                                                                                                                    unit="years"        /> 
     295         <field id="alb_ice"      long_name="Mean albedo over sea ice"                                                                                                        unit=""             /> 
     296         <field id="albedo"       long_name="Mean albedo over sea ice and ocean"                                                                                              unit=""             /> 
    291297 
    292298         <field id="iceage_cat"   long_name="Ice age for categories"                                       unit="days"   axis_ref="ncatice" /> 
    … …  
    326332         <field id="sfxsni"       long_name="salt flux from snow-ice formation"                            unit="1e-3*kg/m2/day" /> 
    327333         <field id="sfxopw"       long_name="salt flux from open water ice formation"                      unit="1e-3*kg/m2/day" /> 
     334         <field id="sfxsub"       long_name="salt flux from sublimation"                                   unit="1e-3*kg/m2/day" /> 
    328335         <field id="sfx"          long_name="salt flux total"                                              unit="1e-3*kg/m2/day" /> 
    329336 
    … …  
    339346         <field id="vfxsub"       long_name="snw sublimation"                                              unit="m/day"   /> 
    340347         <field id="vfxspr"       long_name="snw precipitation on ice"                                     unit="m/day"   /> 
     348         <field id="vfxthin"      long_name="daily thermo ice prod. for thin ice(<20cm) + open water"      unit="m/day"   /> 
    341349 
    342350         <field id="afxtot"       long_name="area tendency (total)"                                        unit="day-1"   /> 
    … …  
    563571         <field id="ibgsfxbom"    long_name="global mean salt flux (thermo)"                         unit="1e-3*m/day" /> 
    564572         <field id="ibgsfxsum"    long_name="global mean salt flux (thermo)"                         unit="1e-3*m/day" /> 
     573         <field id="ibgsfxsub"    long_name="global mean salt flux (thermo)"                         unit="1e-3*m/day" /> 
    565574 
    566575         <field id="ibghfxdhc"    long_name="Heat content variation in snow and ice"                 unit="W"          /> 

  • branches/2016/dev_CNRS_2016/NEMOGCM/CONFIG/SHARED/namelist_ice_lim3_ref

    r6403 r7278  
    2121   cn_icerst_outdir = "."          !  directory in which to write output ice restarts 
    2222   ln_limdyn     = .true.          !  ice dynamics (T) or thermodynamics only (F) 
    23    rn_amax_n     = 0.999           !  maximum tolerated ice concentration (NH) 
    24    rn_amax_s     = 0.999           !  maximum tolerated ice concentration (SH) 
     23   rn_amax_n     = 0.999           !  maximum tolerated ice concentration NH 
     24   rn_amax_s     = 0.999           !  maximum tolerated ice concentration SH 
    2525   ln_limdiahsb  = .false.         !  check the heat and salt budgets (T) or not (F) 
    2626   ln_limdiaout  = .true.          !  output the heat and salt budgets (T) or not (F) 
    … …  
    8686   rn_hnewice  = 0.1               !  thickness for new ice formation in open water (m) 
    8787   ln_frazil   = .false.           !  use frazil ice collection thickness as a function of wind (T) or not (F) 
    88    rn_maxfrazb = 0.0               !  maximum fraction of frazil ice collecting at the ice base 
     88   rn_maxfrazb = 1.0               !  maximum fraction of frazil ice collecting at the ice base 
    8989   rn_vfrazb   = 0.417             !  thresold drift speed for frazil ice collecting at the ice bottom (m/s) 
    9090   rn_Cfrazb   = 5.0               !  squeezing coefficient for frazil ice collecting at the ice bottom 

  • branches/2016/dev_CNRS_2016/NEMOGCM/CONFIG/SHARED/namelist_ref

    r7277 r7278  
    33!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 
    44!! NEMO/OPA  :  1 - run manager      (namrun) 
    5 !! namelists    2 - Domain           (namcfg, namzgr, namdom, namtsd) 
     5!! namelists    2 - Domain           (namcfg, namzgr, namdom, namtsd, namcrs, namc1d, namc1d_uvd) 
    66!!              3 - Surface boundary (namsbc, namsbc_flx, namsbc_clio, namsbc_core, namsbc_sas 
    77!!                                    namsbc_cpl, namtra_qsr, namsbc_rnf, 
    … …  
    6161!!   namzgr       vertical coordinate 
    6262!!   namdom       space and time domain (bathymetry, mesh, timestep) 
     63!!   namwad       Wetting and drying                                    (default F) 
    6364!!   namcrs       coarsened grid (for outputs and/or TOP)               ("key_crs") 
    6465!!   namc1d       1D configuration options                              ("key_c1d") 
    … …  
    9495   ! 
    9596   ln_crs      = .false.   !  Logical switch for coarsening module 
     97/ 
     98!----------------------------------------------------------------------- 
     99&namwad        !   Wetting and drying                                   (default F) 
     100!----------------------------------------------------------------------- 
     101   ln_wd       = .false.   !  T/F activation of wetting and drying 
     102   rn_wdmin1   =  0.1      !  Minimum wet depth on dried cells 
     103   rn_wdmin2   =  0.01     !  Tolerance of min wet depth on dried cells 
     104   rn_wdld     =  20.0     !  Land elevation below which wetting/drying is allowed 
     105   nn_wdit     =  10       !  Max iterations for W/D limiter 
    96106/ 
    97107!----------------------------------------------------------------------- 
    … …  
    436446&namsbc_alb    !   albedo parameters 
    437447!----------------------------------------------------------------------- 
    438    rn_cloud    =    0.06   !  cloud correction to snow and ice albedo 
    439    rn_albice   =    0.53   !  albedo of melting ice in the arctic and antarctic 
    440    rn_alphd    =    0.80   !  coefficients for linear interpolation used to 
    441    rn_alphc    =    0.65   !  compute albedo between two extremes values 
    442    rn_alphdi   =    0.72   !  (Pyane, 1972) 
     448   nn_ice_alb  =    0      !  parameterization of ice/snow albedo 
     449                           !     0: Shine & Henderson-Sellers (JGR 1985) 
     450                           !     1: "home made" based on Brandt et al. (J. Climate 2005) 
     451                           !                         and Grenfell & Perovich (JGR 2004) 
     452   rn_albice   =  0.53     !  albedo of bare puddled ice (values from 0.49 to 0.58) 
     453                           !     0.53 (default) => if nn_ice_alb=0 
     454                           !     0.50 (default) => if nn_ice_alb=1 
    443455/ 
    444456!----------------------------------------------------------------------- 
    … …  
    495507!!====================================================================== 
    496508!!   namlbc        lateral momentum boundary condition 
    497 !!   namobc        open boundaries parameters                           ("key_obc") 
    498509!!   namagrif      agrif nested grid ( read by child model only )       ("key_agrif") 
     510!!   nam_tide      Tidal forcing 
    499511!!   nambdy        Unstructured open boundaries                         ("key_bdy") 
    500 !!   namtide       Tidal forcing at open boundaries                     ("key_bdy_tides") 
     512!!   nambdy_dta    Unstructured open boundaries - external data         ("key_bdy") 
     513!!   nambdy_tide   tidal forcing at open boundaries                     ("key_bdy_tides") 
    501514!!====================================================================== 
    502515! 
    … …  
    659672&nameos        !   ocean physical parameters 
    660673!----------------------------------------------------------------------- 
    661    nn_eos      =  -1     !  type of equation of state and Brunt-Vaisala frequency 
    662                                  !  =-1, TEOS-10 
    663                                  !  = 0, EOS-80 
    664                                  !  = 1, S-EOS   (simplified eos) 
    665    ln_useCT    = .true.  ! use of Conservative Temp. ==> surface CT converted in Pot. Temp. in sbcssm 
     674   ln_teos10   = .false.         !  = Use TEOS-10 equation of state 
     675   ln_eos80    = .false.         !  = Use EOS80 equation of state 
     676   ln_seos     = .false.         !  = Use simplified equation of state (S-EOS) 
    666677                                 ! 
    667    !                     ! S-EOS coefficients : 
    668                                  !  rd(T,S,Z)*rau0 = -a0*(1+.5*lambda*dT+mu*Z+nu*dS)*dT+b0*dS 
     678   !                     ! S-EOS coefficients (ln_seos=T): 
     679   !                             !  rd(T,S,Z)*rau0 = -a0*(1+.5*lambda*dT+mu*Z+nu*dS)*dT+b0*dS 
    669680   rn_a0       =  1.6550e-1      !  thermal expension coefficient (nn_eos= 1) 
    670681   rn_b0       =  7.6554e-1      !  saline  expension coefficient (nn_eos= 1) 
    … …  
    957968   rn_tfe_itf  = 1.        !  ITF tidal dissipation efficiency 
    958969/ 
    959  
     970!----------------------------------------------------------------------- 
     971&namzdf_tmx_new !   internal wave-driven mixing parameterization        ("key_zdftmx_new" & "key_zdfddm") 
     972!----------------------------------------------------------------------- 
     973   nn_zpyc     = 1         !  pycnocline-intensified dissipation scales as N (=1) or N^2 (=2) 
     974   ln_mevar    = .true.    !  variable (T) or constant (F) mixing efficiency 
     975   ln_tsdiff   = .true.    !  account for differential T/S mixing (T) or not (F) 
     976/ 
    960977!!====================================================================== 
    961978!!                  ***  Miscellaneous namelists  *** 
    … …  
    10141031!!   namptr       Poleward Transport Diagnostics 
    10151032!!   namhsb       Heat and salt budgets 
     1033!!   namdiu       Cool skin and warm layer models                       (default F) 
    10161034!!   namflo       float parameters                                      ("key_float") 
    1017 !!   nam_diaharm  Harmonic analysis of tidal constituents               ('key_diaharm') 
    1018 !!   namdct       transports through some sections 
     1035!!   nam_diaharm  Harmonic analysis of tidal constituents               ("key_diaharm") 
     1036!!   namdct       transports through some sections                      ("key_diadct") 
     1037!!   nam_diatmb   Top Middle Bottom Output                              (default F) 
     1038!!   nam_dia25h   25h Mean Output                                       (default F) 
    10191039!!   namnc4       netcdf4 chunking and compression settings             ("key_netcdf4") 
    10201040!!====================================================================== 
    … …  
    10511071!----------------------------------------------------------------------- 
    10521072   ln_diahsb  = .false.    !  check the heat and salt budgets (T) or not (F) 
     1073/ 
     1074!----------------------------------------------------------------------- 
     1075&namdiu        !   Cool skin and warm layer models                       (default F) 
     1076!----------------------------------------------------------------------- 
     1077   ln_diurnal      = .false.   ! 
     1078   ln_diurnal_only = .false.   ! 
    10531079/ 
    10541080!----------------------------------------------------------------------- 
    … …  
    10831109                           !     -1 : debug all section 
    10841110                           !  0 < n : debug section number n 
     1111/ 
     1112!----------------------------------------------------------------------- 
     1113&nam_diatmb    !  Top Middle Bottom Output                               (default F) 
     1114!----------------------------------------------------------------------- 
     1115   ln_diatmb   = .false.   !  Choose Top Middle and Bottom output or not 
     1116/ 
     1117!----------------------------------------------------------------------- 
     1118&nam_dia25h    !  25h Mean Output                                        (default F) 
     1119!----------------------------------------------------------------------- 
     1120   ln_dia25h   = .false.   ! Choose 25h mean output or not 
    10851121/ 
    10861122!----------------------------------------------------------------------- 
    … …  
    11581194    nn_divdmp = 0          !  Number of iterations of divergence damping operator 
    11591195/ 
    1160 !----------------------------------------------------------------------- 
    1161 &namdiu !   Cool skin and warm layer models 
    1162 !----------------------------------------------------------------------- 
    1163    ln_diurnal      = .false.   !  
    1164    ln_diurnal_only = .false.   ! 
    1165 / 
    1166 !----------------------------------------------------------------------- 
    1167 &nam_diatmb  !  Top Middle Bottom Output 
    1168 !----------------------------------------------------------------------- 
    1169    ln_diatmb  = .false.    !  Choose Top Middle and Bottom output or not 
    1170 / 
    1171 !----------------------------------------------------------------------- 
    1172 &namwad  !   Wetting and drying 
    1173 !----------------------------------------------------------------------- 
    1174    ln_wd             = .false.  ! T/F activation of wetting and drying 
    1175    rn_wdmin1         =  0.1     ! Minimum wet depth on dried cells 
    1176    rn_wdmin2         =  0.01    ! Tolerance of min wet depth on dried cells 
    1177    rn_wdld           =  20.0    ! Land elevation below which wetting/drying is allowed 
    1178    nn_wdit           =  10      ! Max iterations for W/D limiter 
    1179 / 
    1180 !----------------------------------------------------------------------- 
    1181 &nam_dia25h  !  25h Mean Output 
    1182 !----------------------------------------------------------------------- 
    1183    ln_dia25h  = .false.    ! Choose 25h mean output or not 
    1184 / 

  • branches/2016/dev_CNRS_2016/NEMOGCM/NEMO/LIM_SRC_3/ice.F90

    r6403 r7278  
    234234   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   u_oce, v_oce   !: surface ocean velocity used in ice dynamics 
    235235   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   ahiu , ahiv    !: hor. diffusivity coeff. at U- and V-points [m2/s] 
    236    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   pahu , pahv    !: ice hor. eddy diffusivity coef. at U- and V-points 
    237236   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   ust2s, hicol   !: friction velocity, ice collection thickness accreted in leads 
    238237   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   strp1, strp2   !: strength at previous time steps 
    … …  
    253252   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   fhld        !: heat flux from the lead used for bottom melting 
    254253 
    255    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_snw    !: snow-ocean mass exchange over 1 time step [kg/m2] 
    256    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_spr    !: snow precipitation on ice over 1 time step [kg/m2] 
    257    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_sub    !: snow sublimation over 1 time step [kg/m2] 
    258  
    259    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_ice    !: ice-ocean mass exchange over 1 time step [kg/m2] 
    260    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_sni    !: snow ice growth component of wfx_ice [kg/m2] 
    261    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_opw    !: lateral ice growth component of wfx_ice [kg/m2] 
    262    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_bog    !: bottom ice growth component of wfx_ice [kg/m2] 
    263    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_dyn    !: dynamical ice growth component of wfx_ice [kg/m2] 
    264    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_bom    !: bottom melt component of wfx_ice [kg/m2] 
    265    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_sum    !: surface melt component of wfx_ice [kg/m2] 
    266    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_res    !: residual component of wfx_ice [kg/m2] 
    267  
    268    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   afx_tot     !: ice concentration tendency (total) [s-1] 
     254   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_snw    !: snow-ocean mass exchange   [kg.m-2.s-1] 
     255   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_spr    !: snow precipitation on ice  [kg.m-2.s-1] 
     256   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_sub    !: snow/ice sublimation       [kg.m-2.s-1] 
     257 
     258   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_ice    !: ice-ocean mass exchange                   [kg.m-2.s-1] 
     259   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_sni    !: snow ice growth component of wfx_ice      [kg.m-2.s-1] 
     260   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_opw    !: lateral ice growth component of wfx_ice   [kg.m-2.s-1] 
     261   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_bog    !: bottom ice growth component of wfx_ice    [kg.m-2.s-1] 
     262   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_dyn    !: dynamical ice growth component of wfx_ice [kg.m-2.s-1] 
     263   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_bom    !: bottom melt component of wfx_ice          [kg.m-2.s-1] 
     264   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_sum    !: surface melt component of wfx_ice         [kg.m-2.s-1] 
     265   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_res    !: residual component of wfx_ice             [kg.m-2.s-1] 
     266 
     267   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   afx_tot     !: ice concentration tendency (total)          [s-1] 
    269268   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] 
     269   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   afx_dyn     !: ice concentration tendency (dynamics)       [s-1] 
    271270 
    272271   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   sfx_bog     !: salt flux due to ice growth/melt                      [PSU/m2/s] 
    … …  
    279278   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   sfx_res     !: residual salt flux due to correction of ice thickness [PSU/m2/s] 
    280279 
    281    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_bog     !: total heat flux causing bottom ice growth  
    282    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_bom     !: total heat flux causing bottom ice melt  
    283    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_sum     !: total heat flux causing surface ice melt  
    284    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_opw     !: total heat flux causing open water ice formation 
    285    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_dif     !: total heat flux causing Temp change in the ice  
    286    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_snw     !: heat flux for snow melt  
    287    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 
    289    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_err_rem !: heat flux error after heat remapping  
    290    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_in      !: heat flux available for thermo transformations  
    291    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_out     !: heat flux remaining at the end of thermo transformations  
    292  
     280   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   sfx_sub     !: salt flux due to ice sublimation 
     281 
     282   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_bog     !: total heat flux causing bottom ice growth        [W.m-2] 
     283   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_bom     !: total heat flux causing bottom ice melt          [W.m-2] 
     284   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_sum     !: total heat flux causing surface ice melt         [W.m-2] 
     285   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_opw     !: total heat flux causing open water ice formation [W.m-2] 
     286   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_dif     !: total heat flux causing Temp change in the ice   [W.m-2] 
     287   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_snw     !: heat flux for snow melt                          [W.m-2] 
     288   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_err     !: heat flux error after heat diffusion             [W.m-2] 
     289   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_err_dif !: heat flux remaining due to change in non-solar flux [W.m-2] 
     290   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_err_rem !: heat flux error after heat remapping             [W.m-2] 
     291   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_in      !: heat flux available for thermo transformations   [W.m-2] 
     292   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_out     !: heat flux remaining at the end of thermo transformations  [W.m-2] 
     293   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_err_sub !: mass flux error after sublimation [kg.m-2.s-1] 
     294    
    293295   ! heat flux associated with ice-atmosphere mass exchange 
    294    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_sub     !: heat flux for sublimation  
    295    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_spr     !: heat flux of the snow precipitation  
     296   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_sub     !: heat flux for sublimation  [W.m-2] 
     297   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_spr     !: heat flux of the snow precipitation  [W.m-2] 
    296298 
    297299   ! heat flux associated with ice-ocean mass exchange 
    298    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_thd     !: ice-ocean heat flux from thermo processes (limthd_dh)  
    299    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_dyn     !: ice-ocean heat flux from mecanical processes (limitd_me)  
    300    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_res     !: residual heat flux due to correction of ice thickness 
    301  
    302    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   ftr_ice   !: transmitted solar radiation under ice 
     300   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_thd     !: ice-ocean heat flux from thermo processes (limthd_dh)  [W.m-2] 
     301   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_dyn     !: ice-ocean heat flux from mecanical processes (limitd_me)  [W.m-2] 
     302   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_res     !: residual heat flux due to correction of ice thickness [W.m-2] 
     303 
     304   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   ftr_ice   !: transmitted solar radiation under ice    
     305   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   pahu3D , pahv3D 
    303306   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   rn_amax_2d  !: maximum ice concentration 2d array 
    304307 
    … …  
    370373   !!-------------------------------------------------------------------------- 
    371374   !                                                  !!: ** Namelist namicerun read in sbc_lim_init ** 
    372    INTEGER          , PUBLIC ::   jpl             !: number of ice  categories  
    373    INTEGER          , PUBLIC ::   nlay_i          !: number of ice  layers  
    374    INTEGER          , PUBLIC ::   nlay_s          !: number of snow layers  
    375    CHARACTER(len=32), PUBLIC ::   cn_icerst_in    !: suffix of ice restart name (input) 
     375   INTEGER           , PUBLIC ::   jpl             !: number of ice  categories  
     376   INTEGER           , PUBLIC ::   nlay_i          !: number of ice  layers  
     377   INTEGER           , PUBLIC ::   nlay_s          !: number of snow layers  
     378   CHARACTER(len=32) , PUBLIC ::   cn_icerst_in    !: suffix of ice restart name (input) 
    376379   CHARACTER(len=256), PUBLIC ::   cn_icerst_indir !: ice restart input directory 
    377    CHARACTER(len=32), PUBLIC ::   cn_icerst_out   !: suffix of ice restart name (output) 
     380   CHARACTER(len=32) , PUBLIC ::   cn_icerst_out   !: suffix of ice restart name (output) 
    378381   CHARACTER(len=256), PUBLIC ::   cn_icerst_outdir!: ice restart output directory 
    379    LOGICAL          , PUBLIC ::   ln_limdyn       !: flag for ice dynamics (T) or not (F) 
    380    LOGICAL          , PUBLIC ::   ln_icectl       !: flag for sea-ice points output (T) or not (F) 
    381    REAL(wp)         , PUBLIC ::   rn_amax_n       !: maximum ice concentration Northern hemisphere 
    382    REAL(wp)         , PUBLIC ::   rn_amax_s       !: maximum ice concentration Southern hemisphere 
    383    INTEGER          , PUBLIC ::   iiceprt         !: debug i-point 
    384    INTEGER          , PUBLIC ::   jiceprt         !: debug j-point 
     382   LOGICAL           , PUBLIC ::   ln_limdyn       !: flag for ice dynamics (T) or not (F) 
     383   LOGICAL           , PUBLIC ::   ln_icectl       !: flag for sea-ice points output (T) or not (F) 
     384   REAL(wp)          , PUBLIC ::   rn_amax_n       !: maximum ice concentration Northern hemisphere 
     385   REAL(wp)          , PUBLIC ::   rn_amax_s       !: maximum ice concentration Southern hemisphere 
     386   INTEGER           , PUBLIC ::   iiceprt         !: debug i-point 
     387   INTEGER           , PUBLIC ::   jiceprt         !: debug j-point 
    385388   ! 
    386389   !!-------------------------------------------------------------------------- 
    … …  
    426429      ALLOCATE( u_oce    (jpi,jpj) , v_oce    (jpi,jpj) ,                           & 
    427430         &      ahiu     (jpi,jpj) , ahiv     (jpi,jpj) ,                           & 
    428          &      pahu     (jpi,jpj) , pahv     (jpi,jpj) ,                           & 
    429431         &      ust2s    (jpi,jpj) , hicol    (jpi,jpj) ,                           & 
    430432         &      strp1    (jpi,jpj) , strp2    (jpi,jpj) , strength  (jpi,jpj) ,     & 
    … …  
    439441         &      wfx_res(jpi,jpj) , wfx_sni(jpi,jpj) , wfx_opw(jpi,jpj) , wfx_spr(jpi,jpj) ,     & 
    440442         &      afx_tot(jpi,jpj) , afx_thd(jpi,jpj),  afx_dyn(jpi,jpj) ,                        & 
    441          &      fhtur  (jpi,jpj) , ftr_ice(jpi,jpj,jpl), qlead  (jpi,jpj) ,                     & 
    442          &      rn_amax_2d(jpi,jpj),                                                            & 
    443          &      sfx_res(jpi,jpj) , sfx_bri(jpi,jpj) , sfx_dyn(jpi,jpj) ,                        & 
     443         &      fhtur  (jpi,jpj) , ftr_ice(jpi,jpj,jpl), pahu3D(jpi,jpj,jpl+1), pahv3D(jpi,jpj,jpl+1),            & 
     444         &      rn_amax_2d (jpi,jpj) , qlead  (jpi,jpj) ,                                                         & 
     445         &      sfx_res(jpi,jpj) , sfx_bri(jpi,jpj) , sfx_dyn(jpi,jpj) , sfx_sub(jpi,jpj),                        & 
    444446         &      sfx_bog(jpi,jpj) , sfx_bom(jpi,jpj) , sfx_sum(jpi,jpj) , sfx_sni(jpi,jpj) , sfx_opw(jpi,jpj) ,    & 
    445447         &      hfx_res(jpi,jpj) , hfx_snw(jpi,jpj) , hfx_sub(jpi,jpj) , hfx_err(jpi,jpj) ,     &  
    446          &      hfx_err_dif(jpi,jpj) , hfx_err_rem(jpi,jpj) ,                                   & 
     448         &      hfx_err_dif(jpi,jpj) , hfx_err_rem(jpi,jpj) , wfx_err_sub(jpi,jpj) ,       & 
    447449         &      hfx_in (jpi,jpj) , hfx_out(jpi,jpj) , fhld(jpi,jpj) ,                           & 
    448450         &      hfx_sum(jpi,jpj) , hfx_bom(jpi,jpj) , hfx_bog(jpi,jpj) , hfx_dif(jpi,jpj) , hfx_opw(jpi,jpj) ,    & 
    … …  
    511513   !!====================================================================== 
    512514END MODULE ice 
     515 

  • branches/2016/dev_CNRS_2016/NEMOGCM/NEMO/LIM_SRC_3/limcons.F90

    r6403 r7278  
    2424   USE lib_fortran    ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined)   
    2525   USE sbc_oce , ONLY : sfx  ! Surface boundary condition: ocean fields 
    26  
     26   USE sbc_ice , ONLY : qevap_ice 
     27    
    2728   IMPLICIT NONE 
    2829   PRIVATE 
    … …  
    184185         ! salt flux 
    185186         zfs_b  = glob_sum(  ( sfx_bri(:,:) + sfx_bog(:,:) + sfx_bom(:,:) + sfx_sum(:,:) + sfx_sni(:,:) +  & 
    186             &                  sfx_opw(:,:) + sfx_res(:,:) + sfx_dyn(:,:)                                  & 
     187            &                  sfx_opw(:,:) + sfx_res(:,:) + sfx_dyn(:,:) + sfx_sub(:,:)                   & 
    187188            &                ) *  e1e2t(:,:) * tmask(:,:,1) * zconv ) 
    188189 
    … …  
    209210         ! salt flux 
    210211         zfs  = glob_sum(  ( sfx_bri(:,:) + sfx_bog(:,:) + sfx_bom(:,:) + sfx_sum(:,:) + sfx_sni(:,:) +  & 
    211             &                sfx_opw(:,:) + sfx_res(:,:) + sfx_dyn(:,:)                                  &  
     212            &                sfx_opw(:,:) + sfx_res(:,:) + sfx_dyn(:,:) + sfx_sub(:,:)                   &  
    212213            &              ) * e1e2t(:,:) * tmask(:,:,1) * zconv ) - zfs_b 
    213214 
    … …  
    287288#if ! defined key_bdy 
    288289      ! heat flux 
    289       zhfx  = glob_sum( ( hfx_in - hfx_out - diag_heat - diag_trp_ei - diag_trp_es - hfx_sub ) * e1e2t * tmask(:,:,1) * zconv )  
     290      zhfx  = glob_sum( ( hfx_in - hfx_out - diag_heat - diag_trp_ei - diag_trp_es - SUM( qevap_ice * a_i_b, dim=3 ) )  & 
     291         &              * e1e2t * tmask(:,:,1) * zconv )  
    290292      ! salt flux 
    291293      zsfx  = glob_sum( ( sfx + diag_smvi ) * e1e2t * tmask(:,:,1) * zconv ) * rday 

  • branches/2016/dev_CNRS_2016/NEMOGCM/NEMO/LIM_SRC_3/limdiahsb.F90

    r5836 r7278  
    5656      real(wp)   ::   zbg_ivo, zbg_svo, zbg_are, zbg_sal ,zbg_tem ,zbg_ihc ,zbg_shc 
    5757      real(wp)   ::   zbg_sfx, zbg_sfx_bri, zbg_sfx_bog, zbg_sfx_bom, zbg_sfx_sum, zbg_sfx_sni,   & 
    58       &               zbg_sfx_opw, zbg_sfx_res, zbg_sfx_dyn  
     58      &               zbg_sfx_opw, zbg_sfx_res, zbg_sfx_dyn, zbg_sfx_sub  
    5959      real(wp)   ::   zbg_vfx, zbg_vfx_bog, zbg_vfx_opw, zbg_vfx_sni, zbg_vfx_dyn 
    6060      real(wp)   ::   zbg_vfx_bom, zbg_vfx_sum, zbg_vfx_res, zbg_vfx_spr, zbg_vfx_snw, zbg_vfx_sub   
    … …  
    111111      zbg_sfx_bom = ztmp * glob_sum( sfx_bom(:,:) * e1e2t(:,:) * tmask(:,:,1) ) 
    112112      zbg_sfx_sum = ztmp * glob_sum( sfx_sum(:,:) * e1e2t(:,:) * tmask(:,:,1) ) 
     113      zbg_sfx_sub = ztmp * glob_sum( sfx_sub(:,:) * e1e2t(:,:) * tmask(:,:,1) ) 
    113114 
    114115      ! Heat budget 
    115       zbg_ihc      = glob_sum( et_i(:,:) * e1e2t(:,:) ) * 1.e-20 ! ice heat content  [1.e20 J] 
    116       zbg_shc      = glob_sum( et_s(:,:) * e1e2t(:,:) ) * 1.e-20 ! snow heat content [1.e20 J] 
     116      zbg_ihc      = glob_sum( et_i(:,:) * e1e2t(:,:) * 1.e-20 ) ! ice heat content  [1.e20 J] 
     117      zbg_shc      = glob_sum( et_s(:,:) * e1e2t(:,:) * 1.e-20 ) ! snow heat content [1.e20 J] 
    117118      zbg_hfx_dhc  = glob_sum( diag_heat(:,:) * e1e2t(:,:) * tmask(:,:,1) ) ! [in W] 
    118119      zbg_hfx_spr  = glob_sum( hfx_spr(:,:) * e1e2t(:,:) * tmask(:,:,1) ) ! [in W] 
    … …  
    189190      CALL iom_put( 'ibgsfxbom' , zbg_sfx_bom                              )   ! salt flux bottom melt       - 
    190191      CALL iom_put( 'ibgsfxsum' , zbg_sfx_sum                              )   ! salt flux surface melt      - 
     192      CALL iom_put( 'ibgsfxsub' , zbg_sfx_sub                              )   ! salt flux sublimation      - 
    191193 
    192194      CALL iom_put( 'ibghfxdhc' , zbg_hfx_dhc                              )   ! Heat content variation in snow and ice [W] 

  • branches/2016/dev_CNRS_2016/NEMOGCM/NEMO/LIM_SRC_3/limhdf.F90

    r5836 r7278  
    77   !!             -   !  2001-05 (G. Madec, R. Hordoir) opa norm 
    88   !!            1.0  !  2002-08 (C. Ethe)  F90, free form 
     9   !!            3.0  !  2015-08 (O. Tintó and M. Castrillo)  added lim_hdf (multiple) 
    910   !!---------------------------------------------------------------------- 
    1011#if defined key_lim3 
    … …  
    2728   PRIVATE 
    2829 
    29    PUBLIC   lim_hdf         ! called by lim_trp 
     30   PUBLIC   lim_hdf ! called by lim_trp 
    3031   PUBLIC   lim_hdf_init    ! called by sbc_lim_init 
    3132 
    … …  
    4344CONTAINS 
    4445 
    45    SUBROUTINE lim_hdf( ptab ) 
     46   SUBROUTINE lim_hdf( ptab , ihdf_vars , jpl , nlay_i ) 
    4647      !!------------------------------------------------------------------- 
    4748      !!                  ***  ROUTINE lim_hdf  *** 
    … …  
    5455      !! ** Action  :    update ptab with the diffusive contribution 
    5556      !!------------------------------------------------------------------- 
    56       REAL(wp), DIMENSION(jpi,jpj), INTENT( inout ) ::   ptab    ! Field on which the diffusion is applied 
    57       ! 
    58       INTEGER                           ::  ji, jj                    ! dummy loop indices 
     57      INTEGER                           :: jpl, nlay_i, isize, ihdf_vars 
     58      REAL(wp),  DIMENSION(:,:,:), INTENT( inout ),TARGET ::   ptab    ! Field on which the diffusion is applied 
     59      ! 
     60      INTEGER                           ::  ji, jj, jk, jl , jm               ! dummy loop indices 
    5961      INTEGER                           ::  iter, ierr           ! local integers 
    60       REAL(wp)                          ::  zrlxint, zconv     ! local scalars 
    61       REAL(wp), POINTER, DIMENSION(:,:) ::  zrlx, zflu, zflv, zdiv0, zdiv, ztab0 
     62      REAL(wp)                          ::  zrlxint     ! local scalars 
     63      REAL(wp), POINTER , DIMENSION ( : )        :: zconv     ! local scalars 
     64      REAL(wp), POINTER , DIMENSION(:,:,:) ::  zrlx,zdiv0, ztab0 
     65      REAL(wp), POINTER , DIMENSION(:,:) ::  zflu, zflv, zdiv 
    6266      CHARACTER(lc)                     ::  charout                   ! local character 
    6367      REAL(wp), PARAMETER               ::  zrelax = 0.5_wp           ! relaxation constant for iterative procedure 
    … …  
    6569      INTEGER , PARAMETER               ::  its    = 100              ! Maximum number of iteration 
    6670      !!------------------------------------------------------------------- 
     71      TYPE(arrayptr)   , ALLOCATABLE, DIMENSION(:) ::   pt2d_array, zrlx_array 
     72      CHARACTER(len=1) , ALLOCATABLE, DIMENSION(:) ::   type_array ! define the nature of ptab array grid-points 
     73      !                                                            ! = T , U , V , F , W and I points 
     74      REAL(wp)        , ALLOCATABLE, DIMENSION(:)  ::   psgn_array    ! =-1 the sign change across the north fold boundary 
     75 
     76     !!---------------------------------------------------------------------  
     77 
     78      !                       !==  Initialisation  ==! 
     79      ! +1 open water diffusion 
     80      isize = jpl*(ihdf_vars+nlay_i)+1 
     81      ALLOCATE( zconv (isize) ) 
     82      ALLOCATE( pt2d_array(isize) , zrlx_array(isize) ) 
     83      ALLOCATE( type_array(isize) ) 
     84      ALLOCATE( psgn_array(isize) ) 
    6785       
    68       CALL wrk_alloc( jpi, jpj, zrlx, zflu, zflv, zdiv0, zdiv, ztab0 ) 
    69  
    70       !                       !==  Initialisation  ==! 
     86      CALL wrk_alloc( jpi, jpj, isize, zrlx, zdiv0, ztab0 ) 
     87      CALL wrk_alloc( jpi, jpj, zflu, zflv, zdiv ) 
     88 
     89      DO jk= 1 , isize 
     90         pt2d_array(jk)%pt2d=>ptab(:,:,jk) 
     91         zrlx_array(jk)%pt2d=>zrlx(:,:,jk) 
     92         type_array(jk)='T' 
     93         psgn_array(jk)=1. 
     94      END DO 
     95 
    7196      ! 
    7297      IF( linit ) THEN              ! Metric coefficient (compute at the first call and saved in efact) 
    … …  
    7499         IF( lk_mpp    )   CALL mpp_sum( ierr ) 
    75100         IF( ierr /= 0 )   CALL ctl_stop( 'STOP', 'lim_hdf : unable to allocate arrays' ) 
    76          DO jj = 2, jpjm1   
     101         DO jj = 2, jpjm1 
    77102            DO ji = fs_2 , fs_jpim1   ! vector opt. 
    78103               efact(ji,jj) = ( e2u(ji,jj) + e2u(ji-1,jj) + e1v(ji,jj) + e1v(ji,jj-1) ) * r1_e1e2t(ji,jj) 
    … …  
    83108      !                             ! Time integration parameters 
    84109      ! 
    85       ztab0(:, : ) = ptab(:,:)      ! Arrays initialization 
    86       zdiv0(:, 1 ) = 0._wp 
    87       zdiv0(:,jpj) = 0._wp 
    88       zflu (jpi,:) = 0._wp    
    89       zflv (jpi,:) = 0._wp 
    90       zdiv0(1,  :) = 0._wp 
    91       zdiv0(jpi,:) = 0._wp 
     110      zflu (jpi,: ) = 0._wp 
     111      zflv (jpi,: ) = 0._wp 
     112 
     113      DO jk=1 , isize 
     114         ztab0(:, : , jk ) = ptab(:,:,jk)      ! Arrays initialization 
     115         zdiv0(:, 1 , jk ) = 0._wp 
     116         zdiv0(:,jpj, jk ) = 0._wp 
     117         zdiv0(1,  :, jk ) = 0._wp 
     118         zdiv0(jpi,:, jk ) = 0._wp 
     119      END DO 
    92120 
    93121      zconv = 1._wp           !==  horizontal diffusion using a Crant-Nicholson scheme  ==! 
    94122      iter  = 0 
    95123      ! 
    96       DO WHILE( zconv > ( 2._wp * 1.e-04 ) .AND. iter <= its )   ! Sub-time step loop 
     124      DO WHILE( MAXVAL(zconv(:)) > ( 2._wp * 1.e-04 ) .AND. iter <= its )   ! Sub-time step loop 
    97125         ! 
    98126         iter = iter + 1                                 ! incrementation of the sub-time step number 
    99127         ! 
     128         DO jk = 1 , isize 
     129            jl = (jk-1) /( ihdf_vars+nlay_i)+1 
     130            IF (zconv(jk) > ( 2._wp * 1.e-04 )) THEN 
     131               DO jj = 1, jpjm1                                ! diffusive fluxes in U- and V- direction 
     132                  DO ji = 1 , fs_jpim1   ! vector opt. 
     133                     zflu(ji,jj) = pahu3D(ji,jj,jl) * e2u(ji,jj) * r1_e1u(ji,jj) * ( ptab(ji+1,jj,jk) - ptab(ji,jj,jk) ) 
     134                     zflv(ji,jj) = pahv3D(ji,jj,jl) * e1v(ji,jj) * r1_e2v(ji,jj) * ( ptab(ji,jj+1,jk) - ptab(ji,jj,jk) ) 
     135                  END DO 
     136               END DO 
     137               ! 
     138               DO jj= 2, jpjm1                                 ! diffusive trend : divergence of the fluxes 
     139                  DO ji = fs_2 , fs_jpim1   ! vector opt.  
     140                     zdiv(ji,jj) = ( zflu(ji,jj) - zflu(ji-1,jj) + zflv(ji,jj) - zflv(ji,jj-1) ) * r1_e1e2t(ji,jj) 
     141                  END DO 
     142               END DO 
     143               ! 
     144               IF( iter == 1 )   zdiv0(:,:,jk) = zdiv(:,:)        ! save the 1st evaluation of the diffusive trend in zdiv0 
     145               ! 
     146               DO jj = 2, jpjm1                                ! iterative evaluation 
     147                  DO ji = fs_2 , fs_jpim1   ! vector opt. 
     148                     zrlxint = (   ztab0(ji,jj,jk)    & 
     149                        &       +  rdt_ice * (           zalfa   * ( zdiv(ji,jj) + efact(ji,jj) * ptab(ji,jj,jk) )   & 
     150                        &                      + ( 1.0 - zalfa ) *   zdiv0(ji,jj,jk) )                               & 
     151                        &      ) / ( 1.0 + zalfa * rdt_ice * efact(ji,jj) ) 
     152                     zrlx(ji,jj,jk) = ptab(ji,jj,jk) + zrelax * ( zrlxint - ptab(ji,jj,jk) ) 
     153                  END DO 
     154               END DO 
     155            END IF 
     156 
     157         END DO 
     158 
     159         CALL lbc_lnk_multi( zrlx_array, type_array , psgn_array , isize ) ! Multiple interchange of all the variables 
     160         ! 
     161         IF ( MOD( iter-1 , nn_convfrq ) == 0 )  THEN   !Convergence test every nn_convfrq iterations (perf. optimization )  
     162            DO jk=1,isize 
     163               zconv(jk) = 0._wp                                   ! convergence test 
     164               DO jj = 2, jpjm1 
     165                  DO ji = fs_2, fs_jpim1 
     166                     zconv(jk) = MAX( zconv(jk), ABS( zrlx(ji,jj,jk) - ptab(ji,jj,jk) )  ) 
     167                  END DO 
     168               END DO 
     169            END DO 
     170            IF( lk_mpp ) CALL mpp_max_multiple( zconv , isize )            ! max over the global domain for all the variables 
     171         ENDIF 
     172         ! 
     173         DO jk=1,isize 
     174            ptab(:,:,jk) = zrlx(:,:,jk) 
     175         END DO 
     176         ! 
     177      END DO                                       ! end of sub-time step loop 
     178 
     179     ! ----------------------- 
     180      !!! final step (clem) !!! 
     181      DO jk = 1, isize 
     182         jl = (jk-1) /( ihdf_vars+nlay_i)+1 
    100183         DO jj = 1, jpjm1                                ! diffusive fluxes in U- and V- direction 
    101184            DO ji = 1 , fs_jpim1   ! vector opt. 
    102                zflu(ji,jj) = pahu(ji,jj) * e2u(ji,jj) * r1_e1u(ji,jj) * ( ptab(ji+1,jj) - ptab(ji,jj) ) 
    103                zflv(ji,jj) = pahv(ji,jj) * e1v(ji,jj) * r1_e2v(ji,jj) * ( ptab(ji,jj+1) - ptab(ji,jj) ) 
     185               zflu(ji,jj) = pahu3D(ji,jj,jl) * e2u(ji,jj) * r1_e1u(ji,jj) * ( ptab(ji+1,jj,jk) - ptab(ji,jj,jk) ) 
     186               zflv(ji,jj) = pahv3D(ji,jj,jl) * e1v(ji,jj) * r1_e2v(ji,jj) * ( ptab(ji,jj+1,jk) - ptab(ji,jj,jk) ) 
    104187            END DO 
    105188         END DO 
    … …  
    108191            DO ji = fs_2 , fs_jpim1   ! vector opt.  
    109192               zdiv(ji,jj) = ( zflu(ji,jj) - zflu(ji-1,jj) + zflv(ji,jj) - zflv(ji,jj-1) ) * r1_e1e2t(ji,jj) 
    110             END DO 
    111          END DO 
    112          ! 
    113          IF( iter == 1 )   zdiv0(:,:) = zdiv(:,:)        ! save the 1st evaluation of the diffusive trend in zdiv0 
    114          ! 
    115          DO jj = 2, jpjm1                                ! iterative evaluation 
    116             DO ji = fs_2 , fs_jpim1   ! vector opt. 
    117                zrlxint = (   ztab0(ji,jj)    & 
    118                   &       +  rdt_ice * (           zalfa   * ( zdiv(ji,jj) + efact(ji,jj) * ptab(ji,jj) )   & 
    119                   &                      + ( 1.0 - zalfa ) *   zdiv0(ji,jj) )                               &  
    120                   &      ) / ( 1.0 + zalfa * rdt_ice * efact(ji,jj) ) 
    121                zrlx(ji,jj) = ptab(ji,jj) + zrelax * ( zrlxint - ptab(ji,jj) ) 
    122             END DO 
    123          END DO 
    124          CALL lbc_lnk( zrlx, 'T', 1. )                   ! lateral boundary condition 
    125          ! 
    126          IF ( MOD( iter, nn_convfrq ) == 0 )  THEN    ! convergence test every nn_convfrq iterations (perf. optimization) 
    127             zconv = 0._wp 
    128             DO jj = 2, jpjm1 
    129                DO ji = fs_2, fs_jpim1 
    130                   zconv = MAX( zconv, ABS( zrlx(ji,jj) - ptab(ji,jj) )  ) 
    131                END DO 
    132             END DO 
    133             IF( lk_mpp )   CALL mpp_max( zconv )      ! max over the global domain 
    134          ENDIF 
    135          ! 
    136          ptab(:,:) = zrlx(:,:) 
    137          ! 
    138       END DO                                       ! end of sub-time step loop 
    139  
    140       ! ----------------------- 
    141       !!! final step (clem) !!! 
    142       DO jj = 1, jpjm1                                ! diffusive fluxes in U- and V- direction 
    143          DO ji = 1 , fs_jpim1   ! vector opt. 
    144             zflu(ji,jj) = pahu(ji,jj) * e2u(ji,jj) * r1_e1u(ji,jj) * ( ptab(ji+1,jj) - ptab(ji,jj) ) 
    145             zflv(ji,jj) = pahv(ji,jj) * e1v(ji,jj) * r1_e2v(ji,jj) * ( ptab(ji,jj+1) - ptab(ji,jj) ) 
     193               ptab(ji,jj,jk) = ztab0(ji,jj,jk) + 0.5 * ( zdiv(ji,jj) + zdiv0(ji,jj,jk) ) 
     194            END DO 
    146195         END DO 
    147196      END DO 
    148       ! 
    149       DO jj= 2, jpjm1                                 ! diffusive trend : divergence of the fluxes 
    150          DO ji = fs_2 , fs_jpim1   ! vector opt.  
    151             zdiv(ji,jj) = ( zflu(ji,jj) - zflu(ji-1,jj) + zflv(ji,jj) - zflv(ji,jj-1) ) * r1_e1e2t(ji,jj) 
    152             ptab(ji,jj) = ztab0(ji,jj) + 0.5 * ( zdiv(ji,jj) + zdiv0(ji,jj) ) 
    153          END DO 
    154       END DO 
    155       CALL lbc_lnk( ptab, 'T', 1. )                   ! lateral boundary condition 
     197 
     198      CALL lbc_lnk_multi( pt2d_array, type_array , psgn_array , isize ) ! Multiple interchange of all the variables 
     199 
    156200      !!! final step (clem) !!! 
    157201      ! ----------------------- 
    158202 
    159203      IF(ln_ctl)   THEN 
    160          zrlx(:,:) = ptab(:,:) - ztab0(:,:) 
    161          WRITE(charout,FMT="(' lim_hdf  : zconv =',D23.16, ' iter =',I4,2X)") zconv, iter 
    162          CALL prt_ctl( tab2d_1=zrlx, clinfo1=charout ) 
    163       ENDIF 
    164       ! 
    165       CALL wrk_dealloc( jpi, jpj, zrlx, zflu, zflv, zdiv0, zdiv, ztab0 ) 
     204         DO jk = 1 , isize 
     205            zrlx(:,:,jk) = ptab(:,:,jk) - ztab0(:,:,jk) 
     206            WRITE(charout,FMT="(' lim_hdf  : zconv =',D23.16, ' iter =',I4,2X)") zconv, iter 
     207            CALL prt_ctl( tab2d_1=zrlx(:,:,jk), clinfo1=charout ) 
     208         END DO 
     209      ENDIF 
     210      ! 
     211      CALL wrk_dealloc( jpi, jpj, isize, zrlx, zdiv0, ztab0 ) 
     212      CALL wrk_dealloc( jpi, jpj, zflu, zflv, zdiv ) 
     213 
     214      DEALLOCATE( zconv ) 
     215      DEALLOCATE( pt2d_array , zrlx_array ) 
     216      DEALLOCATE( type_array ) 
     217      DEALLOCATE( psgn_array ) 
    166218      ! 
    167219   END SUBROUTINE lim_hdf 
     220 
    168221 
    169222    
    … …  
    179232      !!------------------------------------------------------------------- 
    180233      INTEGER  ::   ios                 ! Local integer output status for namelist read 
    181       NAMELIST/namicehdf/ nn_convfrq 
     234      NAMELIST/namicehdf/ nn_convfrq  
    182235      !!------------------------------------------------------------------- 
    183236      ! 
    … …  
    212265   !!====================================================================== 
    213266END MODULE limhdf 
     267 

  • branches/2016/dev_CNRS_2016/NEMOGCM/NEMO/LIM_SRC_3/limistate.F90

    r7277 r7278  
    2424   USE par_oce          ! ocean parameters 
    2525   USE dom_ice          ! sea-ice domain 
     26   USE limvar           ! lim_var_salprof 
    2627   USE in_out_manager   ! I/O manager 
    2728   USE lib_mpp          ! MPP library 
    … …  
    277278                           ztest_1 = 1 
    278279                        ELSE  
    279                           !this write is useful 
    280                           IF(lwp)  WRITE(numout,*) ' * TEST1 AREA NOT CONSERVED *** zA_cons = ', zA_cons,' zat_i_ini = ',zat_i_ini(ji,jj)  
    281280                          ztest_1 = 0 
    282281                        ENDIF 
    … …  
    289288                           ztest_2 = 1 
    290289                        ELSE 
    291                            !this write is useful 
    292                            IF(lwp)  WRITE(numout,*) ' * TEST2 VOLUME NOT CONSERVED *** zV_cons = ', zV_cons, & 
    293                                                     ' zvt_i_ini = ', zvt_i_ini(ji,jj) 
    294290                           ztest_2 = 0 
    295291                        ENDIF 
    … …  
    299295                           ztest_3 = 1 
    300296                        ELSE 
    301                            ! this write is useful 
    302                            IF(lwp) WRITE(numout,*) ' * TEST 3 THICKNESS OF THE LAST CATEGORY OUT OF BOUNDS *** zh_i_ini(ji,jj,i_fill) = ', & 
    303                            zh_i_ini(ji,jj,i_fill), ' hi_max(jpl-1) = ', hi_max(i_fill-1) 
    304                            IF(lwp) WRITE(numout,*) ' ji,jj,i_fill ',ji,jj,i_fill 
    305                            IF(lwp) WRITE(numout,*) 'zht_i_ini ',zht_i_ini(ji,jj) 
    306297                           ztest_3 = 0 
    307298                        ENDIF 
    … …  
    311302                        DO jl = 1, jpl 
    312303                           IF ( za_i_ini(ji,jj,jl) .LT. 0._wp ) THEN  
    313                               ! this write is useful 
    314                               IF(lwp) WRITE(numout,*) ' * TEST 4 POSITIVITY NOT OK FOR CAT ', jl, ' WITH A = ', za_i_ini(ji,jj,jl) 
    315304                              ztest_4 = 0 
    316305                           ENDIF 
    … …  
    379368         END DO 
    380369 
     370         ! for constant salinity in time 
     371         IF( nn_icesal == 1 .OR. nn_icesal == 3 )  THEN 
     372            CALL lim_var_salprof 
     373            smv_i = sm_i * v_i 
     374         ENDIF 
     375          
    381376         ! Snow temperature and heat content 
    382377         DO jk = 1, nlay_s 

  • branches/2016/dev_CNRS_2016/NEMOGCM/NEMO/LIM_SRC_3/limitd_me.F90

    r5836 r7278  
    4545   REAL(wp), ALLOCATABLE, DIMENSION(:,:)   ::   asum     ! sum of total ice and open water area 
    4646   REAL(wp), ALLOCATABLE, DIMENSION(:,:)   ::   aksum    ! ratio of area removed to area ridged 
    47    REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) ::   athorn   ! participation function; fraction of ridging/ 
    48    !                                                     ! closing associated w/ category n 
     47   REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) ::   athorn   ! participation function; fraction of ridging/closing associated w/ category n 
    4948   REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) ::   hrmin    ! minimum ridge thickness 
    5049   REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) ::   hrmax    ! maximum ridge thickness 
    5150   REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) ::   hraft    ! thickness of rafted ice 
    52    REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) ::   krdg     ! mean ridge thickness/thickness of ridging ice  
     51   REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) ::   krdg     ! thickness of ridging ice / mean ridge thickness 
    5352   REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) ::   aridge   ! participating ice ridging 
    5453   REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) ::   araft    ! participating ice rafting 
    5554 
    5655   REAL(wp), PARAMETER ::   krdgmin = 1.1_wp    ! min ridge thickness multiplier 
    57    REAL(wp), PARAMETER ::   kraft   = 2.0_wp    ! rafting multipliyer 
    58    REAL(wp), PARAMETER ::   kamax   = 1.0_wp    ! max of ice area authorized (clem: scheme is not stable if kamax <= 0.99) 
     56   REAL(wp), PARAMETER ::   kraft   = 0.5_wp    ! rafting multipliyer 
    5957 
    6058   REAL(wp) ::   Cp                             !  
    6159   ! 
    62    !----------------------------------------------------------------------- 
    63    ! Ridging diagnostic arrays for history files 
    64    !----------------------------------------------------------------------- 
    65    REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   dardg1dt   ! rate of fractional area loss by ridging ice (1/s) 
    66    REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   dardg2dt   ! rate of fractional area gain by new ridges (1/s) 
    67    REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   dvirdgdt   ! rate of ice volume ridged (m/s) 
    68    REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   opening    ! rate of opening due to divergence/shear (1/s) 
    6960   ! 
    7061   !!---------------------------------------------------------------------- 
    … …  
    8374         &      asum (jpi,jpj)     , athorn(jpi,jpj,0:jpl)                    ,     & 
    8475         &      aksum(jpi,jpj)                                                ,     & 
    85          ! 
    8676         &      hrmin(jpi,jpj,jpl) , hraft(jpi,jpj,jpl) , aridge(jpi,jpj,jpl) ,     & 
    87          &      hrmax(jpi,jpj,jpl) , krdg (jpi,jpj,jpl) , araft (jpi,jpj,jpl) ,     & 
    88          ! 
    89          !* Ridging diagnostic arrays for history files 
    90          &      dardg1dt(jpi,jpj)  , dardg2dt(jpi,jpj)                        ,     &  
    91          &      dvirdgdt(jpi,jpj)  , opening(jpi,jpj)                         , STAT=lim_itd_me_alloc ) 
     77         &      hrmax(jpi,jpj,jpl) , krdg (jpi,jpj,jpl) , araft (jpi,jpj,jpl) , STAT=lim_itd_me_alloc ) 
    9278         ! 
    9379      IF( lim_itd_me_alloc /= 0 )   CALL ctl_warn( 'lim_itd_me_alloc: failed to allocate arrays' ) 
    … …  
    132118      REAL(wp), POINTER, DIMENSION(:,:)   ::   opning          ! rate of opening due to divergence/shear 
    133119      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 
    137120      ! 
    138121      INTEGER, PARAMETER ::   nitermax = 20     
    … …  
    142125      IF( nn_timing == 1 )  CALL timing_start('limitd_me') 
    143126 
    144       CALL wrk_alloc( jpi,jpj, closing_net, divu_adv, opning, closing_gross, msnow_mlt, esnow_mlt, vt_i_init, vt_i_final ) 
     127      CALL wrk_alloc( jpi,jpj, closing_net, divu_adv, opning, closing_gross ) 
    145128 
    146129      IF(ln_ctl) THEN 
    … …  
    154137      IF( ln_limdiahsb ) CALL lim_cons_hsm(0, 'limitd_me', zvi_b, zsmv_b, zei_b, zfw_b, zfs_b, zft_b) 
    155138 
    156       CALL lim_var_zapsmall 
    157       CALL lim_var_glo2eqv            ! equivalent variables, requested for rafting 
    158  
    159139      !-----------------------------------------------------------------------------! 
    160140      ! 1) Thickness categories boundaries, ice / o.w. concentrations, init_ons 
    … …  
    164144      CALL lim_itd_me_ridgeprep                                    ! prepare ridging 
    165145      ! 
    166       IF( con_i)   CALL lim_column_sum( jpl, v_i, vt_i_init )      ! conservation check 
    167146 
    168147      DO jj = 1, jpj                                     ! Initialize arrays. 
    169148         DO ji = 1, jpi 
    170             msnow_mlt(ji,jj) = 0._wp 
    171             esnow_mlt(ji,jj) = 0._wp 
    172             dardg1dt (ji,jj) = 0._wp 
    173             dardg2dt (ji,jj) = 0._wp 
    174             dvirdgdt (ji,jj) = 0._wp 
    175             opening  (ji,jj) = 0._wp 
    176149 
    177150            !-----------------------------------------------------------------------------! 
    … …  
    204177            ! If divu_adv < 0, make sure the closing rate is large enough 
    205178            ! to give asum = 1.0 after ridging. 
    206  
    207             divu_adv(ji,jj) = ( kamax - asum(ji,jj) ) * r1_rdtice  ! asum found in ridgeprep 
     179             
     180            divu_adv(ji,jj) = ( 1._wp - asum(ji,jj) ) * r1_rdtice  ! asum found in ridgeprep 
    208181 
    209182            IF( divu_adv(ji,jj) < 0._wp )   closing_net(ji,jj) = MAX( closing_net(ji,jj), -divu_adv(ji,jj) ) 
    … …  
    224197      DO WHILE ( iterate_ridging > 0 .AND. niter < nitermax ) 
    225198 
     199         ! 3.2 closing_gross 
     200         !-----------------------------------------------------------------------------! 
     201         ! Based on the ITD of ridging and ridged ice, convert the net 
     202         !  closing rate to a gross closing rate.   
     203         ! NOTE: 0 < aksum <= 1 
     204         closing_gross(:,:) = closing_net(:,:) / aksum(:,:) 
     205 
     206         ! correction to closing rate and opening if closing rate is excessive 
     207         !--------------------------------------------------------------------- 
     208         ! Reduce the closing rate if more than 100% of the open water  
     209         ! would be removed.  Reduce the opening rate proportionately. 
    226210         DO jj = 1, jpj 
    227211            DO ji = 1, jpi 
    228  
    229                ! 3.2 closing_gross 
    230                !-----------------------------------------------------------------------------! 
    231                ! Based on the ITD of ridging and ridged ice, convert the net 
    232                !  closing rate to a gross closing rate.   
    233                ! NOTE: 0 < aksum <= 1 
    234                closing_gross(ji,jj) = closing_net(ji,jj) / aksum(ji,jj) 
    235  
    236                ! correction to closing rate and opening if closing rate is excessive 
    237                !--------------------------------------------------------------------- 
    238                ! Reduce the closing rate if more than 100% of the open water  
    239                ! would be removed.  Reduce the opening rate proportionately. 
    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 
     212               za   = ( opning(ji,jj) - athorn(ji,jj,0) * closing_gross(ji,jj) ) * rdt_ice 
     213               IF( za < 0._wp .AND. za > - ato_i(ji,jj) ) THEN  ! would lead to negative ato_i 
     214                  zfac = - ato_i(ji,jj) / za 
     215                  opning(ji,jj) = athorn(ji,jj,0) * closing_gross(ji,jj) - ato_i(ji,jj) * r1_rdtice  
     216               ELSEIF( za > 0._wp .AND. za > ( asum(ji,jj) - ato_i(ji,jj) ) ) THEN  ! would lead to ato_i > asum 
     217                  zfac = ( asum(ji,jj) - ato_i(ji,jj) ) / za 
     218                  opning(ji,jj) = athorn(ji,jj,0) * closing_gross(ji,jj) + ( asum(ji,jj) - ato_i(ji,jj) ) * r1_rdtice  
    245219               ENDIF 
    246  
    247220            END DO 
    248221         END DO 
    … …  
    256229               DO ji = 1, jpi 
    257230                  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 ) 
     231                  IF( za  >  a_i(ji,jj,jl) ) THEN 
     232                     zfac = a_i(ji,jj,jl) / za 
    260233                     closing_gross(ji,jj) = closing_gross(ji,jj) * zfac 
    261                      opning       (ji,jj) = opning       (ji,jj) * zfac 
    262234                  ENDIF 
    263235               END DO 
    … …  
    268240         !-----------------------------------------------------------------------------! 
    269241 
    270          CALL lim_itd_me_ridgeshift( opning, closing_gross, msnow_mlt, esnow_mlt ) 
    271  
     242         CALL lim_itd_me_ridgeshift( opning, closing_gross ) 
     243 
     244          
    272245         ! 3.4 Compute total area of ice plus open water after ridging. 
    273246         !-----------------------------------------------------------------------------! 
    274247         ! 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 
     248         asum(:,:) = ato_i(:,:) + SUM( a_i, dim=3 ) 
    279249 
    280250         ! 3.5 Do we keep on iterating ??? 
    … …  
    284254 
    285255         iterate_ridging = 0 
    286  
    287256         DO jj = 1, jpj 
    288257            DO ji = 1, jpi 
    289                IF (ABS(asum(ji,jj) - kamax ) < epsi10) THEN 
     258               IF( ABS( asum(ji,jj) - 1._wp ) < epsi10 ) THEN 
    290259                  closing_net(ji,jj) = 0._wp 
    291260                  opning     (ji,jj) = 0._wp 
    292261               ELSE 
    293262                  iterate_ridging    = 1 
    294                   divu_adv   (ji,jj) = ( kamax - asum(ji,jj) ) * r1_rdtice 
     263                  divu_adv   (ji,jj) = ( 1._wp - asum(ji,jj) ) * r1_rdtice 
    295264                  closing_net(ji,jj) = MAX( 0._wp, -divu_adv(ji,jj) ) 
    296265                  opning     (ji,jj) = MAX( 0._wp,  divu_adv(ji,jj) ) 
    … …  
    309278 
    310279         IF( iterate_ridging == 1 ) THEN 
     280            CALL lim_itd_me_ridgeprep 
    311281            IF( niter  >  nitermax ) THEN 
    312282               WRITE(numout,*) ' ALERTE : non-converging ridging scheme ' 
    313283               WRITE(numout,*) ' niter, iterate_ridging ', niter, iterate_ridging 
    314284            ENDIF 
    315             CALL lim_itd_me_ridgeprep 
    316285         ENDIF 
    317286 
    318287      END DO !! on the do while over iter 
    319  
    320       !-----------------------------------------------------------------------------! 
    321       ! 4) Ridging diagnostics 
    322       !-----------------------------------------------------------------------------! 
    323       ! Convert ridging rate diagnostics to correct units. 
    324       ! Update fresh water and heat fluxes due to snow melt. 
    325       DO jj = 1, jpj 
    326          DO ji = 1, jpi 
    327  
    328             dardg1dt(ji,jj) = dardg1dt(ji,jj) * r1_rdtice 
    329             dardg2dt(ji,jj) = dardg2dt(ji,jj) * r1_rdtice 
    330             dvirdgdt(ji,jj) = dvirdgdt(ji,jj) * r1_rdtice 
    331             opening (ji,jj) = opening (ji,jj) * r1_rdtice 
    332  
    333             !-----------------------------------------------------------------------------! 
    334             ! 5) Heat, salt and freshwater fluxes 
    335             !-----------------------------------------------------------------------------! 
    336             wfx_snw(ji,jj) = wfx_snw(ji,jj) + msnow_mlt(ji,jj) * r1_rdtice     ! fresh water source for ocean 
    337             hfx_dyn(ji,jj) = hfx_dyn(ji,jj) + esnow_mlt(ji,jj) * r1_rdtice     ! heat sink for ocean (<0, W.m-2) 
    338  
    339          END DO 
    340       END DO 
    341  
    342       ! Check if there is a ridging error 
    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 
    360  
    361       ! Conservation check 
    362       IF ( con_i ) THEN 
    363          CALL lim_column_sum (jpl,   v_i, vt_i_final) 
    364          fieldid = ' v_i : limitd_me ' 
    365          CALL lim_cons_check (vt_i_init, vt_i_final, 1.0e-6, fieldid)  
    366       ENDIF 
    367288 
    368289      CALL lim_var_agg( 1 )  
    … …  
    377298         CALL prt_ctl_info(' - Cell values : ') 
    378299         CALL prt_ctl_info('   ~~~~~~~~~~~~~ ') 
    379          CALL prt_ctl(tab2d_1=e1e2t, clinfo1=' lim_itd_me  : cell area :') 
     300         CALL prt_ctl(tab2d_1=e1e2t , clinfo1=' lim_itd_me  : cell area :') 
    380301         CALL prt_ctl(tab2d_1=at_i , clinfo1=' lim_itd_me  : at_i      :') 
    381302         CALL prt_ctl(tab2d_1=vt_i , clinfo1=' lim_itd_me  : vt_i      :') 
    … …  
    410331      ENDIF  ! ln_limdyn=.true. 
    411332      ! 
    412       CALL wrk_dealloc( jpi, jpj, closing_net, divu_adv, opning, closing_gross, msnow_mlt, esnow_mlt, vt_i_init, vt_i_final ) 
     333      CALL wrk_dealloc( jpi, jpj, closing_net, divu_adv, opning, closing_gross ) 
    413334      ! 
    414335      IF( nn_timing == 1 )  CALL timing_stop('limitd_me') 
    415336   END SUBROUTINE lim_itd_me 
    416337 
     338   SUBROUTINE lim_itd_me_ridgeprep 
     339      !!---------------------------------------------------------------------! 
     340      !!                ***  ROUTINE lim_itd_me_ridgeprep *** 
     341      !! 
     342      !! ** Purpose :   preparation for ridging and strength calculations 
     343      !! 
     344      !! ** Method  :   Compute the thickness distribution of the ice and open water  
     345      !!              participating in ridging and of the resulting ridges. 
     346      !!---------------------------------------------------------------------! 
     347      INTEGER ::   ji,jj, jl    ! dummy loop indices 
     348      REAL(wp) ::   Gstari, astari, hrmean, zdummy   ! local scalar 
     349      REAL(wp), POINTER, DIMENSION(:,:,:) ::   Gsum      ! Gsum(n) = sum of areas in categories 0 to n 
     350      !------------------------------------------------------------------------------! 
     351 
     352      CALL wrk_alloc( jpi,jpj,jpl+2, Gsum, kkstart = -1 ) 
     353 
     354      Gstari     = 1.0/rn_gstar     
     355      astari     = 1.0/rn_astar     
     356      aksum(:,:)    = 0.0 
     357      athorn(:,:,:) = 0.0 
     358      aridge(:,:,:) = 0.0 
     359      araft (:,:,:) = 0.0 
     360 
     361      ! Zero out categories with very small areas 
     362      CALL lim_var_zapsmall 
     363 
     364      ! Ice thickness needed for rafting 
     365      DO jl = 1, jpl 
     366         DO jj = 1, jpj 
     367            DO ji = 1, jpi 
     368               rswitch = MAX( 0._wp , SIGN( 1._wp, a_i(ji,jj,jl) - epsi20 ) ) 
     369               ht_i(ji,jj,jl) = v_i (ji,jj,jl) / MAX( a_i(ji,jj,jl) , epsi20 ) * rswitch 
     370            END DO 
     371         END DO 
     372      END DO 
     373 
     374      !------------------------------------------------------------------------------! 
     375      ! 1) Participation function  
     376      !------------------------------------------------------------------------------! 
     377 
     378      ! Compute total area of ice plus open water. 
     379      ! This is in general not equal to one because of divergence during transport 
     380      asum(:,:) = ato_i(:,:) + SUM( a_i, dim=3 ) 
     381 
     382      ! Compute cumulative thickness distribution function 
     383      ! Compute the cumulative thickness distribution function Gsum, 
     384      ! where Gsum(n) is the fractional area in categories 0 to n. 
     385      ! initial value (in h = 0) equals open water area 
     386      Gsum(:,:,-1) = 0._wp 
     387      Gsum(:,:,0 ) = ato_i(:,:) 
     388      ! for each value of h, you have to add ice concentration then 
     389      DO jl = 1, jpl 
     390         Gsum(:,:,jl) = Gsum(:,:,jl-1) + a_i(:,:,jl) 
     391      END DO 
     392 
     393      ! Normalize the cumulative distribution to 1 
     394      DO jl = 0, jpl 
     395         Gsum(:,:,jl) = Gsum(:,:,jl) / asum(:,:) 
     396      END DO 
     397 
     398      ! 1.3 Compute participation function a(h) = b(h).g(h) (athorn) 
     399      !-------------------------------------------------------------------------------------------------- 
     400      ! Compute the participation function athorn; this is analogous to 
     401      ! a(h) = b(h)g(h) as defined in Thorndike et al. (1975). 
     402      ! area lost from category n due to ridging/closing 
     403      ! athorn(n)   = total area lost due to ridging/closing 
     404      ! assume b(h) = (2/Gstar) * (1 - G(h)/Gstar).  
     405      ! 
     406      ! The expressions for athorn are found by integrating b(h)g(h) between 
     407      ! the category boundaries. 
     408      ! athorn is always >= 0 and SUM(athorn(0:jpl))=1 
     409      !----------------------------------------------------------------- 
     410 
     411      IF( nn_partfun == 0 ) THEN       !--- Linear formulation (Thorndike et al., 1975) 
     412         DO jl = 0, jpl     
     413            DO jj = 1, jpj  
     414               DO ji = 1, jpi 
     415                  IF    ( Gsum(ji,jj,jl)   < rn_gstar ) THEN 
     416                     athorn(ji,jj,jl) = Gstari * ( Gsum(ji,jj,jl) - Gsum(ji,jj,jl-1) ) * & 
     417                        &                        ( 2._wp - ( Gsum(ji,jj,jl-1) + Gsum(ji,jj,jl) ) * Gstari ) 
     418                  ELSEIF( Gsum(ji,jj,jl-1) < rn_gstar ) THEN 
     419                     athorn(ji,jj,jl) = Gstari * ( rn_gstar       - Gsum(ji,jj,jl-1) ) *  & 
     420                        &                        ( 2._wp - ( Gsum(ji,jj,jl-1) + rn_gstar       ) * Gstari ) 
     421                  ELSE 
     422                     athorn(ji,jj,jl) = 0._wp 
     423                  ENDIF 
     424               END DO 
     425            END DO 
     426         END DO 
     427 
     428      ELSE                             !--- Exponential, more stable formulation (Lipscomb et al, 2007) 
     429         !                         
     430         zdummy = 1._wp / ( 1._wp - EXP(-astari) )        ! precompute exponential terms using Gsum as a work array 
     431         DO jl = -1, jpl 
     432            Gsum(:,:,jl) = EXP( -Gsum(:,:,jl) * astari ) * zdummy 
     433         END DO 
     434         DO jl = 0, jpl 
     435             athorn(:,:,jl) = Gsum(:,:,jl-1) - Gsum(:,:,jl) 
     436         END DO 
     437         ! 
     438      ENDIF 
     439 
     440      IF( ln_rafting ) THEN      ! Ridging and rafting ice participation functions 
     441         ! 
     442         DO jl = 1, jpl 
     443            DO jj = 1, jpj  
     444               DO ji = 1, jpi 
     445                  zdummy           = TANH ( rn_craft * ( ht_i(ji,jj,jl) - rn_hraft ) ) 
     446                  aridge(ji,jj,jl) = ( 1._wp + zdummy ) * 0.5_wp * athorn(ji,jj,jl) 
     447                  araft (ji,jj,jl) = ( 1._wp - zdummy ) * 0.5_wp * athorn(ji,jj,jl) 
     448               END DO 
     449            END DO 
     450         END DO 
     451 
     452      ELSE 
     453         ! 
     454         DO jl = 1, jpl 
     455            aridge(:,:,jl) = athorn(:,:,jl) 
     456         END DO 
     457         ! 
     458      ENDIF 
     459 
     460      !----------------------------------------------------------------- 
     461      ! 2) Transfer function 
     462      !----------------------------------------------------------------- 
     463      ! Compute max and min ridged ice thickness for each ridging category. 
     464      ! Assume ridged ice is uniformly distributed between hrmin and hrmax. 
     465      !  
     466      ! This parameterization is a modified version of Hibler (1980). 
     467      ! The mean ridging thickness, hrmean, is proportional to hi^(0.5) 
     468      !  and for very thick ridging ice must be >= krdgmin*hi 
     469      ! 
     470      ! The minimum ridging thickness, hrmin, is equal to 2*hi  
     471      !  (i.e., rafting) and for very thick ridging ice is 
     472      !  constrained by hrmin <= (hrmean + hi)/2. 
     473      !  
     474      ! The maximum ridging thickness, hrmax, is determined by 
     475      !  hrmean and hrmin. 
     476      ! 
     477      ! These modifications have the effect of reducing the ice strength 
     478      ! (relative to the Hibler formulation) when very thick ice is 
     479      ! ridging. 
     480      ! 
     481      ! aksum = net area removed/ total area removed 
     482      ! where total area removed = area of ice that ridges 
     483      !         net area removed = total area removed - area of new ridges 
     484      !----------------------------------------------------------------- 
     485 
     486      aksum(:,:) = athorn(:,:,0) 
     487      ! Transfer function 
     488      DO jl = 1, jpl !all categories have a specific transfer function 
     489         DO jj = 1, jpj 
     490            DO ji = 1, jpi 
     491                
     492               IF( athorn(ji,jj,jl) > 0._wp ) THEN 
     493                  hrmean          = MAX( SQRT( rn_hstar * ht_i(ji,jj,jl) ), ht_i(ji,jj,jl) * krdgmin ) 
     494                  hrmin(ji,jj,jl) = MIN( 2._wp * ht_i(ji,jj,jl), 0.5_wp * ( hrmean + ht_i(ji,jj,jl) ) ) 
     495                  hrmax(ji,jj,jl) = 2._wp * hrmean - hrmin(ji,jj,jl) 
     496                  hraft(ji,jj,jl) = ht_i(ji,jj,jl) / kraft 
     497                  krdg(ji,jj,jl)  = ht_i(ji,jj,jl) / MAX( hrmean, epsi20 ) 
     498 
     499                  ! Normalization factor : aksum, ensures mass conservation 
     500                  aksum(ji,jj) = aksum(ji,jj) + aridge(ji,jj,jl) * ( 1._wp - krdg(ji,jj,jl) )    & 
     501                     &                        + araft (ji,jj,jl) * ( 1._wp - kraft          ) 
     502 
     503               ELSE 
     504                  hrmin(ji,jj,jl)  = 0._wp  
     505                  hrmax(ji,jj,jl)  = 0._wp  
     506                  hraft(ji,jj,jl)  = 0._wp  
     507                  krdg (ji,jj,jl)  = 1._wp 
     508               ENDIF 
     509 
     510            END DO 
     511         END DO 
     512      END DO 
     513      ! 
     514      CALL wrk_dealloc( jpi,jpj,jpl+2, Gsum, kkstart = -1 ) 
     515      ! 
     516   END SUBROUTINE lim_itd_me_ridgeprep 
     517 
     518 
     519   SUBROUTINE lim_itd_me_ridgeshift( opning, closing_gross ) 
     520      !!---------------------------------------------------------------------- 
     521      !!                ***  ROUTINE lim_itd_me_icestrength *** 
     522      !! 
     523      !! ** Purpose :   shift ridging ice among thickness categories of ice thickness 
     524      !! 
     525      !! ** Method  :   Remove area, volume, and energy from each ridging category 
     526      !!              and add to thicker ice categories. 
     527      !!---------------------------------------------------------------------- 
     528      REAL(wp), DIMENSION(jpi,jpj), INTENT(in   ) ::   opning         ! rate of opening due to divergence/shear 
     529      REAL(wp), DIMENSION(jpi,jpj), INTENT(in   ) ::   closing_gross  ! rate at which area removed, excluding area of new ridges 
     530      ! 
     531      CHARACTER (len=80) ::   fieldid   ! field identifier 
     532      ! 
     533      INTEGER ::   ji, jj, jl, jl1, jl2, jk   ! dummy loop indices 
     534      INTEGER ::   ij                ! horizontal index, combines i and j loops 
     535      INTEGER ::   icells            ! number of cells with a_i > puny 
     536      REAL(wp) ::   hL, hR, farea    ! left and right limits of integration 
     537 
     538      INTEGER , POINTER, DIMENSION(:) ::   indxi, indxj   ! compressed indices 
     539      REAL(wp), POINTER, DIMENSION(:) ::   zswitch, fvol   ! new ridge volume going to n2 
     540 
     541      REAL(wp), POINTER, DIMENSION(:) ::   afrac            ! fraction of category area ridged  
     542      REAL(wp), POINTER, DIMENSION(:) ::   ardg1 , ardg2    ! area of ice ridged & new ridges 
     543      REAL(wp), POINTER, DIMENSION(:) ::   vsrdg , esrdg    ! snow volume & energy of ridging ice 
     544      REAL(wp), POINTER, DIMENSION(:) ::   dhr   , dhr2     ! hrmax - hrmin  &  hrmax^2 - hrmin^2 
     545 
     546      REAL(wp), POINTER, DIMENSION(:) ::   vrdg1   ! volume of ice ridged 
     547      REAL(wp), POINTER, DIMENSION(:) ::   vrdg2   ! volume of new ridges 
     548      REAL(wp), POINTER, DIMENSION(:) ::   vsw     ! volume of seawater trapped into ridges 
     549      REAL(wp), POINTER, DIMENSION(:) ::   srdg1   ! sal*volume of ice ridged 
     550      REAL(wp), POINTER, DIMENSION(:) ::   srdg2   ! sal*volume of new ridges 
     551      REAL(wp), POINTER, DIMENSION(:) ::   smsw    ! sal*volume of water trapped into ridges 
     552      REAL(wp), POINTER, DIMENSION(:) ::   oirdg1, oirdg2   ! ice age of ice ridged 
     553 
     554      REAL(wp), POINTER, DIMENSION(:) ::   afrft            ! fraction of category area rafted 
     555      REAL(wp), POINTER, DIMENSION(:) ::   arft1 , arft2    ! area of ice rafted and new rafted zone 
     556      REAL(wp), POINTER, DIMENSION(:) ::   virft , vsrft    ! ice & snow volume of rafting ice 
     557      REAL(wp), POINTER, DIMENSION(:) ::   esrft , smrft    ! snow energy & salinity of rafting ice 
     558      REAL(wp), POINTER, DIMENSION(:) ::   oirft1, oirft2   ! ice age of ice rafted 
     559 
     560      REAL(wp), POINTER, DIMENSION(:,:) ::   eirft      ! ice energy of rafting ice 
     561      REAL(wp), POINTER, DIMENSION(:,:) ::   erdg1      ! enth*volume of ice ridged 
     562      REAL(wp), POINTER, DIMENSION(:,:) ::   erdg2      ! enth*volume of new ridges 
     563      REAL(wp), POINTER, DIMENSION(:,:) ::   ersw       ! enth of water trapped into ridges 
     564      !!---------------------------------------------------------------------- 
     565 
     566      CALL wrk_alloc( jpij,        indxi, indxj ) 
     567      CALL wrk_alloc( jpij,        zswitch, fvol ) 
     568      CALL wrk_alloc( jpij,        afrac, ardg1, ardg2, vsrdg, esrdg, dhr, dhr2 ) 
     569      CALL wrk_alloc( jpij,        vrdg1, vrdg2, vsw  , srdg1, srdg2, smsw, oirdg1, oirdg2 ) 
     570      CALL wrk_alloc( jpij,        afrft, arft1, arft2, virft, vsrft, esrft, smrft, oirft1, oirft2 ) 
     571      CALL wrk_alloc( jpij,nlay_i, eirft, erdg1, erdg2, ersw ) 
     572 
     573      !------------------------------------------------------------------------------- 
     574      ! 1) Compute change in open water area due to closing and opening. 
     575      !------------------------------------------------------------------------------- 
     576      DO jj = 1, jpj 
     577         DO ji = 1, jpi 
     578            ato_i(ji,jj) = MAX( 0._wp, ato_i(ji,jj) +  & 
     579               &                     ( opning(ji,jj) - athorn(ji,jj,0) * closing_gross(ji,jj) ) * rdt_ice ) 
     580         END DO 
     581      END DO 
     582 
     583      !----------------------------------------------------------------- 
     584      ! 3) Pump everything from ice which is being ridged / rafted 
     585      !----------------------------------------------------------------- 
     586      ! Compute the area, volume, and energy of ice ridging in each 
     587      ! category, along with the area of the resulting ridge. 
     588 
     589      DO jl1 = 1, jpl !jl1 describes the ridging category 
     590 
     591         !------------------------------------------------ 
     592         ! 3.1) Identify grid cells with nonzero ridging 
     593         !------------------------------------------------ 
     594         icells = 0 
     595         DO jj = 1, jpj 
     596            DO ji = 1, jpi 
     597               IF( athorn(ji,jj,jl1) > 0._wp .AND. closing_gross(ji,jj) > 0._wp ) THEN 
     598                  icells = icells + 1 
     599                  indxi(icells) = ji 
     600                  indxj(icells) = jj 
     601               ENDIF 
     602            END DO 
     603         END DO 
     604 
     605         DO ij = 1, icells 
     606            ji = indxi(ij) ; jj = indxj(ij) 
     607 
     608            !-------------------------------------------------------------------- 
     609            ! 3.2) Compute area of ridging ice (ardg1) and of new ridge (ardg2) 
     610            !-------------------------------------------------------------------- 
     611            ardg1(ij) = aridge(ji,jj,jl1) * closing_gross(ji,jj) * rdt_ice 
     612            arft1(ij) = araft (ji,jj,jl1) * closing_gross(ji,jj) * rdt_ice 
     613 
     614            !--------------------------------------------------------------- 
     615            ! 3.3) Compute ridging /rafting fractions, make sure afrac <=1  
     616            !--------------------------------------------------------------- 
     617            afrac(ij) = ardg1(ij) / a_i(ji,jj,jl1) !ridging 
     618            afrft(ij) = arft1(ij) / a_i(ji,jj,jl1) !rafting 
     619            ardg2(ij) = ardg1(ij) * krdg(ji,jj,jl1) 
     620            arft2(ij) = arft1(ij) * kraft 
     621 
     622            !-------------------------------------------------------------------------- 
     623            ! 3.4) Subtract area, volume, and energy from ridging  
     624            !     / rafting category n1. 
     625            !-------------------------------------------------------------------------- 
     626            vrdg1(ij) = v_i(ji,jj,jl1) * afrac(ij) 
     627            vrdg2(ij) = vrdg1(ij) * ( 1. + rn_por_rdg ) 
     628            vsw  (ij) = vrdg1(ij) * rn_por_rdg 
     629 
     630            vsrdg (ij) = v_s  (ji,jj,  jl1) * afrac(ij) 
     631            esrdg (ij) = e_s  (ji,jj,1,jl1) * afrac(ij) 
     632            srdg1 (ij) = smv_i(ji,jj,  jl1) * afrac(ij) 
     633            oirdg1(ij) = oa_i (ji,jj,  jl1) * afrac(ij) 
     634            oirdg2(ij) = oa_i (ji,jj,  jl1) * afrac(ij) * krdg(ji,jj,jl1)  
     635 
     636            ! rafting volumes, heat contents ... 
     637            virft (ij) = v_i  (ji,jj,  jl1) * afrft(ij) 
     638            vsrft (ij) = v_s  (ji,jj,  jl1) * afrft(ij) 
     639            esrft (ij) = e_s  (ji,jj,1,jl1) * afrft(ij) 
     640            smrft (ij) = smv_i(ji,jj,  jl1) * afrft(ij)  
     641            oirft1(ij) = oa_i (ji,jj,  jl1) * afrft(ij)  
     642            oirft2(ij) = oa_i (ji,jj,  jl1) * afrft(ij) * kraft  
     643 
     644            !----------------------------------------------------------------- 
     645            ! 3.5) Compute properties of new ridges 
     646            !----------------------------------------------------------------- 
     647            smsw(ij)  = vsw(ij) * sss_m(ji,jj)                   ! salt content of seawater frozen in voids 
     648            srdg2(ij) = srdg1(ij) + smsw(ij)                     ! salt content of new ridge 
     649             
     650            sfx_dyn(ji,jj) = sfx_dyn(ji,jj) - smsw(ij) * rhoic * r1_rdtice 
     651            wfx_dyn(ji,jj) = wfx_dyn(ji,jj) - vsw (ij) * rhoic * r1_rdtice   ! increase in ice volume due to seawater frozen in voids 
     652 
     653            ! virtual salt flux to keep salinity constant 
     654            IF( nn_icesal == 1 .OR. nn_icesal == 3 )  THEN 
     655               srdg2(ij)      = srdg2(ij) - vsw(ij) * ( sss_m(ji,jj) - sm_i(ji,jj,jl1) )           ! ridge salinity = sm_i 
     656               sfx_bri(ji,jj) = sfx_bri(ji,jj) + sss_m(ji,jj)    * vsw(ij) * rhoic * r1_rdtice  &  ! put back sss_m into the ocean 
     657                  &                            - sm_i(ji,jj,jl1) * vsw(ij) * rhoic * r1_rdtice     ! and get  sm_i  from the ocean  
     658            ENDIF 
     659             
     660            !------------------------------------------             
     661            ! 3.7 Put the snow somewhere in the ocean 
     662            !------------------------------------------             
     663            !  Place part of the snow lost by ridging into the ocean.  
     664            !  Note that esrdg > 0; the ocean must cool to melt snow. 
     665            !  If the ocean temp = Tf already, new ice must grow. 
     666            !  During the next time step, thermo_rates will determine whether 
     667            !  the ocean cools or new ice grows. 
     668            wfx_snw(ji,jj) = wfx_snw(ji,jj) + ( rhosn * vsrdg(ij) * ( 1._wp - rn_fsnowrdg )   &  
     669               &                              + rhosn * vsrft(ij) * ( 1._wp - rn_fsnowrft ) ) * r1_rdtice  ! fresh water source for ocean 
     670 
     671            hfx_dyn(ji,jj) = hfx_dyn(ji,jj) + ( - esrdg(ij) * ( 1._wp - rn_fsnowrdg )         &  
     672               &                                - esrft(ij) * ( 1._wp - rn_fsnowrft ) ) * r1_rdtice        ! heat sink for ocean (<0, W.m-2) 
     673 
     674            !----------------------------------------------------------------- 
     675            ! 3.8 Compute quantities used to apportion ice among categories 
     676            ! in the n2 loop below 
     677            !----------------------------------------------------------------- 
     678            dhr (ij) = 1._wp / ( hrmax(ji,jj,jl1)                    - hrmin(ji,jj,jl1)                    ) 
     679            dhr2(ij) = 1._wp / ( hrmax(ji,jj,jl1) * hrmax(ji,jj,jl1) - hrmin(ji,jj,jl1) * hrmin(ji,jj,jl1) ) 
     680 
     681 
     682            ! update jl1 (removing ridged/rafted area) 
     683            a_i  (ji,jj,  jl1) = a_i  (ji,jj,  jl1) - ardg1 (ij) - arft1 (ij) 
     684            v_i  (ji,jj,  jl1) = v_i  (ji,jj,  jl1) - vrdg1 (ij) - virft (ij) 
     685            v_s  (ji,jj,  jl1) = v_s  (ji,jj,  jl1) - vsrdg (ij) - vsrft (ij) 
     686            e_s  (ji,jj,1,jl1) = e_s  (ji,jj,1,jl1) - esrdg (ij) - esrft (ij) 
     687            smv_i(ji,jj,  jl1) = smv_i(ji,jj,  jl1) - srdg1 (ij) - smrft (ij) 
     688            oa_i (ji,jj,  jl1) = oa_i (ji,jj,  jl1) - oirdg1(ij) - oirft1(ij) 
     689 
     690         END DO 
     691 
     692         !-------------------------------------------------------------------- 
     693         ! 3.9 Compute ridging ice enthalpy, remove it from ridging ice and 
     694         !      compute ridged ice enthalpy  
     695         !-------------------------------------------------------------------- 
     696         DO jk = 1, nlay_i 
     697            DO ij = 1, icells 
     698               ji = indxi(ij) ; jj = indxj(ij) 
     699               ! heat content of ridged ice 
     700               erdg1(ij,jk) = e_i(ji,jj,jk,jl1) * afrac(ij)  
     701               eirft(ij,jk) = e_i(ji,jj,jk,jl1) * afrft(ij)                
     702                
     703               ! enthalpy of the trapped seawater (J/m2, >0) 
     704               ! clem: if sst>0, then ersw <0 (is that possible?) 
     705               ersw(ij,jk)  = - rhoic * vsw(ij) * rcp * sst_m(ji,jj) * r1_nlay_i 
     706 
     707               ! heat flux to the ocean 
     708               hfx_dyn(ji,jj) = hfx_dyn(ji,jj) + ersw(ij,jk) * r1_rdtice  ! > 0 [W.m-2] ocean->ice flux  
     709 
     710               ! it is added to sea ice because the sign convention is the opposite of the sign convention for the ocean 
     711               erdg2(ij,jk) = erdg1(ij,jk) + ersw(ij,jk) 
     712 
     713               ! update jl1 
     714               e_i  (ji,jj,jk,jl1) = e_i(ji,jj,jk,jl1) - erdg1(ij,jk) - eirft(ij,jk) 
     715 
     716            END DO 
     717         END DO 
     718 
     719         !------------------------------------------------------------------------------- 
     720         ! 4) Add area, volume, and energy of new ridge to each category jl2 
     721         !------------------------------------------------------------------------------- 
     722         DO jl2  = 1, jpl  
     723            ! over categories to which ridged/rafted ice is transferred 
     724            DO ij = 1, icells 
     725               ji = indxi(ij) ; jj = indxj(ij) 
     726 
     727               ! Compute the fraction of ridged ice area and volume going to thickness category jl2. 
     728               IF( hrmin(ji,jj,jl1) <= hi_max(jl2) .AND. hrmax(ji,jj,jl1) > hi_max(jl2-1) ) THEN 
     729                  hL = MAX( hrmin(ji,jj,jl1), hi_max(jl2-1) ) 
     730                  hR = MIN( hrmax(ji,jj,jl1), hi_max(jl2)   ) 
     731                  farea    = ( hR      - hL      ) * dhr(ij)  
     732                  fvol(ij) = ( hR * hR - hL * hL ) * dhr2(ij) 
     733               ELSE 
     734                  farea    = 0._wp  
     735                  fvol(ij) = 0._wp                   
     736               ENDIF 
     737 
     738               ! Compute the fraction of rafted ice area and volume going to thickness category jl2 
     739               IF( hraft(ji,jj,jl1) <= hi_max(jl2) .AND. hraft(ji,jj,jl1) >  hi_max(jl2-1) ) THEN 
     740                  zswitch(ij) = 1._wp 
     741               ELSE 
     742                  zswitch(ij) = 0._wp                   
     743               ENDIF 
     744 
     745               a_i  (ji,jj  ,jl2) = a_i  (ji,jj  ,jl2) + ( ardg2 (ij) * farea    + arft2 (ij) * zswitch(ij) ) 
     746               oa_i (ji,jj  ,jl2) = oa_i (ji,jj  ,jl2) + ( oirdg2(ij) * farea    + oirft2(ij) * zswitch(ij) ) 
     747               v_i  (ji,jj  ,jl2) = v_i  (ji,jj  ,jl2) + ( vrdg2 (ij) * fvol(ij) + virft (ij) * zswitch(ij) ) 
     748               smv_i(ji,jj  ,jl2) = smv_i(ji,jj  ,jl2) + ( srdg2 (ij) * fvol(ij) + smrft (ij) * zswitch(ij) ) 
     749               v_s  (ji,jj  ,jl2) = v_s  (ji,jj  ,jl2) + ( vsrdg (ij) * rn_fsnowrdg * fvol(ij)  +  & 
     750                  &                                        vsrft (ij) * rn_fsnowrft * zswitch(ij) ) 
     751               e_s  (ji,jj,1,jl2) = e_s  (ji,jj,1,jl2) + ( esrdg (ij) * rn_fsnowrdg * fvol(ij)  +  & 
     752                  &                                        esrft (ij) * rn_fsnowrft * zswitch(ij) ) 
     753 
     754            END DO 
     755 
     756            ! Transfer ice energy to category jl2 by ridging 
     757            DO jk = 1, nlay_i 
     758               DO ij = 1, icells 
     759                  ji = indxi(ij) ; jj = indxj(ij) 
     760                  e_i(ji,jj,jk,jl2) = e_i(ji,jj,jk,jl2) + erdg2(ij,jk) * fvol(ij) + eirft(ij,jk) * zswitch(ij)                   
     761               END DO 
     762            END DO 
     763            ! 
     764         END DO ! jl2 
     765          
     766      END DO ! jl1 (deforming categories) 
     767 
     768      ! 
     769      CALL wrk_dealloc( jpij,        indxi, indxj ) 
     770      CALL wrk_dealloc( jpij,        zswitch, fvol ) 
     771      CALL wrk_dealloc( jpij,        afrac, ardg1, ardg2, vsrdg, esrdg, dhr, dhr2 ) 
     772      CALL wrk_dealloc( jpij,        vrdg1, vrdg2, vsw  , srdg1, srdg2, smsw, oirdg1, oirdg2 ) 
     773      CALL wrk_dealloc( jpij,        afrft, arft1, arft2, virft, vsrft, esrft, smrft, oirft1, oirft2 ) 
     774      CALL wrk_dealloc( jpij,nlay_i, eirft, erdg1, erdg2, ersw ) 
     775      ! 
     776   END SUBROUTINE lim_itd_me_ridgeshift 
    417777 
    418778   SUBROUTINE lim_itd_me_icestrength( kstrngth ) 
    … …  
    434794      INTEGER             ::   ksmooth     ! smoothing the resistance to deformation 
    435795      INTEGER             ::   numts_rm    ! number of time steps for the P smoothing 
    436       REAL(wp)            ::   zhi, zp, z1_3  ! local scalars 
     796      REAL(wp)            ::   zp, z1_3    ! local scalars 
    437797      REAL(wp), POINTER, DIMENSION(:,:) ::   zworka   ! temporary array used here 
    438798      !!---------------------------------------------------------------------- 
    … …  
    459819               DO ji = 1, jpi 
    460820                  ! 
    461                   IF( a_i(ji,jj,jl) > epsi10 .AND. athorn(ji,jj,jl) > 0._wp ) THEN 
    462                      zhi = v_i(ji,jj,jl) / a_i(ji,jj,jl) 
     821                  IF( athorn(ji,jj,jl) > 0._wp ) THEN 
    463822                     !---------------------------- 
    464823                     ! PE loss from deforming ice 
    465824                     !---------------------------- 
    466                      strength(ji,jj) = strength(ji,jj) - athorn(ji,jj,jl) * zhi * zhi 
     825                     strength(ji,jj) = strength(ji,jj) - athorn(ji,jj,jl) * ht_i(ji,jj,jl) * ht_i(ji,jj,jl) 
    467826 
    468827                     !-------------------------- 
    469828                     ! PE gain from rafting ice 
    470829                     !-------------------------- 
    471                      strength(ji,jj) = strength(ji,jj) + 2._wp * araft(ji,jj,jl) * zhi * zhi 
     830                     strength(ji,jj) = strength(ji,jj) + 2._wp * araft(ji,jj,jl) * ht_i(ji,jj,jl) * ht_i(ji,jj,jl) 
    472831 
    473832                     !---------------------------- 
    474833                     ! PE gain from ridging ice 
    475834                     !---------------------------- 
    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) )   
     835                     strength(ji,jj) = strength(ji,jj) + aridge(ji,jj,jl) * krdg(ji,jj,jl) * z1_3 *  & 
     836                        &                              ( hrmax(ji,jj,jl) * hrmax(ji,jj,jl) +         & 
     837                        &                                hrmin(ji,jj,jl) * hrmin(ji,jj,jl) +         & 
     838                        &                                hrmax(ji,jj,jl) * hrmin(ji,jj,jl) )   
    478839                        !!(a**3-b**3)/(a-b) = a*a+ab+b*b                       
    479840                  ENDIF 
    … …  
    497858         ! 
    498859      ENDIF                     ! kstrngth 
    499  
    500860      ! 
    501861      !------------------------------------------------------------------------------! 
    … …  
    503863      !------------------------------------------------------------------------------! 
    504864      ! CAN BE REMOVED 
    505       ! 
    506865      IF( ln_icestr_bvf ) THEN 
    507  
    508866         DO jj = 1, jpj 
    509867            DO ji = 1, jpi 
    … …  
    511869            END DO 
    512870         END DO 
    513  
    514871      ENDIF 
    515  
    516872      ! 
    517873      !------------------------------------------------------------------------------! 
    … …  
    558914      IF ( ksmooth == 2 ) THEN 
    559915 
    560  
    561916         CALL lbc_lnk( strength, 'T', 1. ) 
    562917 
    … …  
    565920               IF ( ( asum(ji,jj) - ato_i(ji,jj) ) > 0._wp) THEN  
    566921                  numts_rm = 1 ! number of time steps for the running mean 
    567                   IF ( strp1(ji,jj) > 0.0 ) numts_rm = numts_rm + 1 
    568                   IF ( strp2(ji,jj) > 0.0 ) numts_rm = numts_rm + 1 
     922                  IF ( strp1(ji,jj) > 0._wp ) numts_rm = numts_rm + 1 
     923                  IF ( strp2(ji,jj) > 0._wp ) numts_rm = numts_rm + 1 
    569924                  zp = ( strength(ji,jj) + strp1(ji,jj) + strp2(ji,jj) ) / numts_rm 
    570925                  strp2(ji,jj) = strp1(ji,jj) 
    … …  
    583938      ! 
    584939   END SUBROUTINE lim_itd_me_icestrength 
    585  
    586  
    587    SUBROUTINE lim_itd_me_ridgeprep 
    588       !!---------------------------------------------------------------------! 
    589       !!                ***  ROUTINE lim_itd_me_ridgeprep *** 
    590       !! 
    591       !! ** Purpose :   preparation for ridging and strength calculations 
    592       !! 
    593       !! ** Method  :   Compute the thickness distribution of the ice and open water  
    594       !!              participating in ridging and of the resulting ridges. 
    595       !!---------------------------------------------------------------------! 
    596       INTEGER ::   ji,jj, jl    ! dummy loop indices 
    597       REAL(wp) ::   Gstari, astari, zhi, hrmean, zdummy   ! local scalar 
    598       REAL(wp), POINTER, DIMENSION(:,:)   ::   zworka    ! temporary array used here 
    599       REAL(wp), POINTER, DIMENSION(:,:,:) ::   Gsum      ! Gsum(n) = sum of areas in categories 0 to n 
    600       !------------------------------------------------------------------------------! 
    601  
    602       CALL wrk_alloc( jpi,jpj, zworka ) 
    603       CALL wrk_alloc( jpi,jpj,jpl+2, Gsum, kkstart = -1 ) 
    604  
    605       Gstari     = 1.0/rn_gstar     
    606       astari     = 1.0/rn_astar     
    607       aksum(:,:)    = 0.0 
    608       athorn(:,:,:) = 0.0 
    609       aridge(:,:,:) = 0.0 
    610       araft (:,:,:) = 0.0 
    611       hrmin(:,:,:)  = 0.0  
    612       hrmax(:,:,:)  = 0.0  
    613       hraft(:,:,:)  = 0.0  
    614       krdg (:,:,:)  = 1.0 
    615  
    616       !     ! Zero out categories with very small areas 
    617       CALL lim_var_zapsmall 
    618  
    619       !------------------------------------------------------------------------------! 
    620       ! 1) Participation function  
    621       !------------------------------------------------------------------------------! 
    622  
    623       ! Compute total area of ice plus open water. 
    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 
    629  
    630       ! Compute cumulative thickness distribution function 
    631       ! Compute the cumulative thickness distribution function Gsum, 
    632       ! where Gsum(n) is the fractional area in categories 0 to n. 
    633       ! initial value (in h = 0) equals open water area 
    634  
    635       Gsum(:,:,-1) = 0._wp 
    636       Gsum(:,:,0 ) = ato_i(:,:) 
    637  
    638       ! for each value of h, you have to add ice concentration then 
    639       DO jl = 1, jpl 
    640          Gsum(:,:,jl) = Gsum(:,:,jl-1) + a_i(:,:,jl) 
    641       END DO 
    642  
    643       ! Normalize the cumulative distribution to 1 
    644       zworka(:,:) = 1._wp / Gsum(:,:,jpl) 
    645       DO jl = 0, jpl 
    646          Gsum(:,:,jl) = Gsum(:,:,jl) * zworka(:,:) 
    647       END DO 
    648  
    649       ! 1.3 Compute participation function a(h) = b(h).g(h) (athorn) 
    650       !-------------------------------------------------------------------------------------------------- 
    651       ! Compute the participation function athorn; this is analogous to 
    652       ! a(h) = b(h)g(h) as defined in Thorndike et al. (1975). 
    653       ! area lost from category n due to ridging/closing 
    654       ! athorn(n)   = total area lost due to ridging/closing 
    655       ! assume b(h) = (2/Gstar) * (1 - G(h)/Gstar).  
    656       ! 
    657       ! The expressions for athorn are found by integrating b(h)g(h) between 
    658       ! the category boundaries. 
    659       !----------------------------------------------------------------- 
    660  
    661       IF( nn_partfun == 0 ) THEN       !--- Linear formulation (Thorndike et al., 1975) 
    662          DO jl = 0, jpl     
    663             DO jj = 1, jpj  
    664                DO ji = 1, jpi 
    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 ) 
    671                   ELSE 
    672                      athorn(ji,jj,jl) = 0.0 
    673                   ENDIF 
    674                END DO 
    675             END DO 
    676          END DO 
    677  
    678       ELSE                             !--- Exponential, more stable formulation (Lipscomb et al, 2007) 
    679          !                         
    680          zdummy = 1._wp / ( 1._wp - EXP(-astari) )        ! precompute exponential terms using Gsum as a work array 
    681          DO jl = -1, jpl 
    682             Gsum(:,:,jl) = EXP( -Gsum(:,:,jl) * astari ) * zdummy 
    683          END DO 
    684          DO jl = 0, jpl 
    685              athorn(:,:,jl) = Gsum(:,:,jl-1) - Gsum(:,:,jl) 
    686          END DO 
    687          ! 
    688       ENDIF 
    689  
    690       IF( ln_rafting ) THEN      ! Ridging and rafting ice participation functions 
    691          ! 
    692          DO jl = 1, jpl 
    693             DO jj = 1, jpj  
    694                DO ji = 1, jpi 
    695                   IF ( athorn(ji,jj,jl) > 0._wp ) THEN 
    696 !!gm  TANH( -X ) = - TANH( X )  so can be computed only 1 time.... 
    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) 
    699                      IF ( araft(ji,jj,jl) < epsi06 )   araft(ji,jj,jl)  = 0._wp 
    700                      aridge(ji,jj,jl) = MAX( athorn(ji,jj,jl) - araft(ji,jj,jl), 0.0 ) 
    701                   ENDIF 
    702                END DO 
    703             END DO 
    704          END DO 
    705  
    706       ELSE 
    707          ! 
    708          DO jl = 1, jpl 
    709             aridge(:,:,jl) = athorn(:,:,jl) 
    710          END DO 
    711          ! 
    712       ENDIF 
    713  
    714       IF( ln_rafting ) THEN 
    715  
    716          IF( MAXVAL(aridge + araft - athorn(:,:,1:jpl)) > epsi10 .AND. lwp ) THEN 
    717             DO jl = 1, jpl 
    718                DO jj = 1, jpj 
    719                   DO ji = 1, jpi 
    720                      IF ( aridge(ji,jj,jl) + araft(ji,jj,jl) - athorn(ji,jj,jl) > epsi10 ) THEN 
    721                         WRITE(numout,*) ' ALERTE 96 : wrong participation function ... ' 
    722                         WRITE(numout,*) ' ji, jj, jl : ', ji, jj, jl 
    723                         WRITE(numout,*) ' lat, lon   : ', gphit(ji,jj), glamt(ji,jj) 
    724                         WRITE(numout,*) ' aridge     : ', aridge(ji,jj,1:jpl) 
    725                         WRITE(numout,*) ' araft      : ', araft(ji,jj,1:jpl) 
    726                         WRITE(numout,*) ' athorn     : ', athorn(ji,jj,1:jpl) 
    727                      ENDIF 
    728                   END DO 
    729                END DO 
    730             END DO 
    731          ENDIF 
    732  
    733       ENDIF 
    734  
    735       !----------------------------------------------------------------- 
    736       ! 2) Transfer function 
    737       !----------------------------------------------------------------- 
    738       ! Compute max and min ridged ice thickness for each ridging category. 
    739       ! Assume ridged ice is uniformly distributed between hrmin and hrmax. 
    740       !  
    741       ! This parameterization is a modified version of Hibler (1980). 
    742       ! The mean ridging thickness, hrmean, is proportional to hi^(0.5) 
    743       !  and for very thick ridging ice must be >= krdgmin*hi 
    744       ! 
    745       ! The minimum ridging thickness, hrmin, is equal to 2*hi  
    746       !  (i.e., rafting) and for very thick ridging ice is 
    747       !  constrained by hrmin <= (hrmean + hi)/2. 
    748       !  
    749       ! The maximum ridging thickness, hrmax, is determined by 
    750       !  hrmean and hrmin. 
    751       ! 
    752       ! These modifications have the effect of reducing the ice strength 
    753       ! (relative to the Hibler formulation) when very thick ice is 
    754       ! ridging. 
    755       ! 
    756       ! aksum = net area removed/ total area removed 
    757       ! where total area removed = area of ice that ridges 
    758       !         net area removed = total area removed - area of new ridges 
    759       !----------------------------------------------------------------- 
    760  
    761       ! Transfer function 
    762       DO jl = 1, jpl !all categories have a specific transfer function 
    763          DO jj = 1, jpj 
    764             DO ji = 1, jpi 
    765  
    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)) 
    770                   hrmax(ji,jj,jl) = 2.0*hrmean - hrmin(ji,jj,jl) 
    771                   hraft(ji,jj,jl) = kraft*zhi 
    772                   krdg(ji,jj,jl)  = hrmean / zhi 
    773                ELSE 
    774                   hraft(ji,jj,jl) = 0.0 
    775                   hrmin(ji,jj,jl) = 0.0  
    776                   hrmax(ji,jj,jl) = 0.0  
    777                   krdg (ji,jj,jl) = 1.0 
    778                ENDIF 
    779  
    780             END DO 
    781          END DO 
    782       END DO 
    783  
    784       ! Normalization factor : aksum, ensures mass conservation 
    785       aksum(:,:) = athorn(:,:,0) 
    786       DO jl = 1, jpl  
    787          aksum(:,:)    = aksum(:,:) + aridge(:,:,jl) * ( 1._wp - 1._wp / krdg(:,:,jl) )    & 
    788             &                       + araft (:,:,jl) * ( 1._wp - 1._wp / kraft        ) 
    789       END DO 
    790       ! 
    791       CALL wrk_dealloc( jpi,jpj, zworka ) 
    792       CALL wrk_dealloc( jpi,jpj,jpl+2, Gsum, kkstart = -1 ) 
    793       ! 
    794    END SUBROUTINE lim_itd_me_ridgeprep 
    795  
    796  
    797    SUBROUTINE lim_itd_me_ridgeshift( opning, closing_gross, msnow_mlt, esnow_mlt ) 
    798       !!---------------------------------------------------------------------- 
    799       !!                ***  ROUTINE lim_itd_me_icestrength *** 
    800       !! 
    801       !! ** Purpose :   shift ridging ice among thickness categories of ice thickness 
    802       !! 
    803       !! ** Method  :   Remove area, volume, and energy from each ridging category 
    804       !!              and add to thicker ice categories. 
    805       !!---------------------------------------------------------------------- 
    806       REAL(wp), DIMENSION(jpi,jpj), INTENT(in   ) ::   opning         ! rate of opening due to divergence/shear 
    807       REAL(wp), DIMENSION(jpi,jpj), INTENT(in   ) ::   closing_gross  ! rate at which area removed, excluding area of new ridges 
    808       REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) ::   msnow_mlt      ! mass of snow added to ocean (kg m-2) 
    809       REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) ::   esnow_mlt      ! energy needed to melt snow in ocean (J m-2) 
    810       ! 
    811       CHARACTER (len=80) ::   fieldid   ! field identifier 
    812       LOGICAL, PARAMETER ::   l_conservation_check = .true.  ! if true, check conservation (useful for debugging) 
    813       ! 
    814       INTEGER ::   ji, jj, jl, jl1, jl2, jk   ! dummy loop indices 
    815       INTEGER ::   ij                ! horizontal index, combines i and j loops 
    816       INTEGER ::   icells            ! number of cells with aicen > puny 
    817       REAL(wp) ::   hL, hR, farea, ztmelts    ! left and right limits of integration 
    818  
    819       INTEGER , POINTER, DIMENSION(:) ::   indxi, indxj   ! compressed indices 
    820  
    821       REAL(wp), POINTER, DIMENSION(:,:) ::   vice_init, vice_final   ! ice volume summed over categories 
    822       REAL(wp), POINTER, DIMENSION(:,:) ::   eice_init, eice_final   ! ice energy summed over layers 
    823  
    824       REAL(wp), POINTER, DIMENSION(:,:,:) ::   aicen_init, vicen_init   ! ice  area    & volume before ridging 
    825       REAL(wp), POINTER, DIMENSION(:,:,:) ::   vsnwn_init, esnwn_init   ! snow volume  & energy before ridging 
    826       REAL(wp), POINTER, DIMENSION(:,:,:) ::   smv_i_init, oa_i_init    ! ice salinity & age    before ridging 
    827  
    828       REAL(wp), POINTER, DIMENSION(:,:,:,:) ::   eicen_init        ! ice energy before ridging 
    829  
    830       REAL(wp), POINTER, DIMENSION(:,:) ::   afrac , fvol     ! fraction of category area ridged & new ridge volume going to n2 
    831       REAL(wp), POINTER, DIMENSION(:,:) ::   ardg1 , ardg2    ! area of ice ridged & new ridges 
    832       REAL(wp), POINTER, DIMENSION(:,:) ::   vsrdg , esrdg    ! snow volume & energy of ridging ice 
    833       REAL(wp), POINTER, DIMENSION(:,:) ::   dhr   , dhr2     ! hrmax - hrmin  &  hrmax^2 - hrmin^2 
    834  
    835       REAL(wp), POINTER, DIMENSION(:,:) ::   vrdg1   ! volume of ice ridged 
    836       REAL(wp), POINTER, DIMENSION(:,:) ::   vrdg2   ! volume of new ridges 
    837       REAL(wp), POINTER, DIMENSION(:,:) ::   vsw     ! volume of seawater trapped into ridges 
    838       REAL(wp), POINTER, DIMENSION(:,:) ::   srdg1   ! sal*volume of ice ridged 
    839       REAL(wp), POINTER, DIMENSION(:,:) ::   srdg2   ! sal*volume of new ridges 
    840       REAL(wp), POINTER, DIMENSION(:,:) ::   smsw    ! sal*volume of water trapped into ridges 
    841       REAL(wp), POINTER, DIMENSION(:,:) ::   oirdg1, oirdg2   ! ice age of ice ridged 
    842  
    843       REAL(wp), POINTER, DIMENSION(:,:) ::   afrft            ! fraction of category area rafted 
    844       REAL(wp), POINTER, DIMENSION(:,:) ::   arft1 , arft2    ! area of ice rafted and new rafted zone 
    845       REAL(wp), POINTER, DIMENSION(:,:) ::   virft , vsrft    ! ice & snow volume of rafting ice 
    846       REAL(wp), POINTER, DIMENSION(:,:) ::   esrft , smrft    ! snow energy & salinity of rafting ice 
    847       REAL(wp), POINTER, DIMENSION(:,:) ::   oirft1, oirft2   ! ice age of ice rafted 
    848  
    849       REAL(wp), POINTER, DIMENSION(:,:,:) ::   eirft      ! ice energy of rafting ice 
    850       REAL(wp), POINTER, DIMENSION(:,:,:) ::   erdg1      ! enth*volume of ice ridged 
    851       REAL(wp), POINTER, DIMENSION(:,:,:) ::   erdg2      ! enth*volume of new ridges 
    852       REAL(wp), POINTER, DIMENSION(:,:,:) ::   ersw       ! enth of water trapped into ridges 
    853       !!---------------------------------------------------------------------- 
    854  
    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 ) 
    863  
    864       ! Conservation check 
    865       eice_init(:,:) = 0._wp 
    866  
    867       IF( con_i ) THEN 
    868          CALL lim_column_sum        (jpl,    v_i,       vice_init ) 
    869          CALL lim_column_sum_energy (jpl, nlay_i,  e_i, eice_init ) 
    870          DO ji = mi0(iiceprt), mi1(iiceprt) 
    871             DO jj = mj0(jiceprt), mj1(jiceprt) 
    872                WRITE(numout,*) ' vice_init  : ', vice_init(ji,jj) 
    873                WRITE(numout,*) ' eice_init  : ', eice_init(ji,jj) 
    874             END DO 
    875          END DO 
    876       ENDIF 
    877  
    878       !------------------------------------------------------------------------------- 
    879       ! 1) Compute change in open water area due to closing and opening. 
    880       !------------------------------------------------------------------------------- 
    881       DO jj = 1, jpj 
    882          DO ji = 1, jpi 
    883             ato_i(ji,jj) = ato_i(ji,jj) - athorn(ji,jj,0) * closing_gross(ji,jj) * rdt_ice        & 
    884                &                        + opning(ji,jj)                          * rdt_ice 
    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 
    888                ato_i(ji,jj) = 0._wp 
    889             ENDIF 
    890          END DO 
    891       END DO 
    892  
    893       !----------------------------------------------------------------- 
    894       ! 2) Save initial state variables 
    895       !----------------------------------------------------------------- 
    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 (:,:,:) 
    903  
    904       ! 
    905       !----------------------------------------------------------------- 
    906       ! 3) Pump everything from ice which is being ridged / rafted 
    907       !----------------------------------------------------------------- 
    908       ! Compute the area, volume, and energy of ice ridging in each 
    909       ! category, along with the area of the resulting ridge. 
    910  
    911       DO jl1 = 1, jpl !jl1 describes the ridging category 
    912  
    913          !------------------------------------------------ 
    914          ! 3.1) Identify grid cells with nonzero ridging 
    915          !------------------------------------------------ 
    916  
    917          icells = 0 
    918          DO jj = 1, jpj 
    919             DO ji = 1, jpi 
    920                IF( aicen_init(ji,jj,jl1) > epsi10 .AND. athorn(ji,jj,jl1) > 0._wp  & 
    921                   &   .AND. closing_gross(ji,jj) > 0._wp ) THEN 
    922                   icells = icells + 1 
    923                   indxi(icells) = ji 
    924                   indxj(icells) = jj 
    925                ENDIF 
    926             END DO 
    927          END DO 
    928  
    929          DO ij = 1, icells 
    930             ji = indxi(ij) 
    931             jj = indxj(ij) 
    932  
    933             !-------------------------------------------------------------------- 
    934             ! 3.2) Compute area of ridging ice (ardg1) and of new ridge (ardg2) 
    935             !-------------------------------------------------------------------- 
    936  
    937             ardg1(ji,jj) = aridge(ji,jj,jl1)*closing_gross(ji,jj)*rdt_ice 
    938             arft1(ji,jj) = araft (ji,jj,jl1)*closing_gross(ji,jj)*rdt_ice 
    939             ardg2(ji,jj) = ardg1(ji,jj) / krdg(ji,jj,jl1) 
    940             arft2(ji,jj) = arft1(ji,jj) / kraft 
    941  
    942             !--------------------------------------------------------------- 
    943             ! 3.3) Compute ridging /rafting fractions, make sure afrac <=1  
    944             !--------------------------------------------------------------- 
    945  
    946             afrac(ji,jj) = ardg1(ji,jj) / aicen_init(ji,jj,jl1) !ridging 
    947             afrft(ji,jj) = arft1(ji,jj) / aicen_init(ji,jj,jl1) !rafting 
    948  
    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 
    952                afrac(ji,jj) = kamax 
    953             ENDIF 
    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 
    958                afrft(ji,jj) = kamax 
    959             ENDIF 
    960  
    961             !-------------------------------------------------------------------------- 
    962             ! 3.4) Subtract area, volume, and energy from ridging  
    963             !     / rafting category n1. 
    964             !-------------------------------------------------------------------------- 
    965             vrdg1(ji,jj) = vicen_init(ji,jj,jl1) * afrac(ji,jj) 
    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)  
    974  
    975             ! rafting volumes, heat contents ... 
    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  
    982  
    983             ! substract everything 
    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) 
    989             oa_i(ji,jj,jl1)  = oa_i(ji,jj,jl1)  - oirdg1(ji,jj) - oirft1(ji,jj) 
    990  
    991             !----------------------------------------------------------------- 
    992             ! 3.5) Compute properties of new ridges 
    993             !----------------------------------------------------------------- 
    994             !--------- 
    995             ! Salinity 
    996             !--------- 
    997             smsw(ji,jj)  = vsw(ji,jj) * sss_m(ji,jj)                      ! salt content of seawater frozen in voids !! MV HC2014 
    998             srdg2(ji,jj) = srdg1(ji,jj) + smsw(ji,jj)                     ! salt content of new ridge 
    999  
    1000             !srdg2(ji,jj) = MIN( rn_simax * vrdg2(ji,jj) , zsrdg2 )         ! impose a maximum salinity 
    1001              
    1002             sfx_dyn(ji,jj) = sfx_dyn(ji,jj) - smsw(ji,jj) * rhoic * r1_rdtice 
    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              
    1004  
    1005             !------------------------------------             
    1006             ! 3.6 Increment ridging diagnostics 
    1007             !------------------------------------             
    1008  
    1009             !        jl1 looping 1-jpl 
    1010             !           ij looping 1-icells 
    1011  
    1012             dardg1dt   (ji,jj) = dardg1dt(ji,jj) + ardg1(ji,jj) + arft1(ji,jj) 
    1013             dardg2dt   (ji,jj) = dardg2dt(ji,jj) + ardg2(ji,jj) + arft2(ji,jj) 
    1014             opening    (ji,jj) = opening (ji,jj) + opning(ji,jj) * rdt_ice 
    1015  
    1016             IF( con_i )   vice_init(ji,jj) = vice_init(ji,jj) + vrdg2(ji,jj) - vrdg1(ji,jj) 
    1017  
    1018             !------------------------------------------             
    1019             ! 3.7 Put the snow somewhere in the ocean 
    1020             !------------------------------------------             
    1021             !  Place part of the snow lost by ridging into the ocean.  
    1022             !  Note that esnow_mlt < 0; the ocean must cool to melt snow. 
    1023             !  If the ocean temp = Tf already, new ice must grow. 
    1024             !  During the next time step, thermo_rates will determine whether 
    1025             !  the ocean cools or new ice grows. 
    1026             !        jl1 looping 1-jpl 
    1027             !           ij looping 1-icells 
    1028  
    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)           
    1035  
    1036             !----------------------------------------------------------------- 
    1037             ! 3.8 Compute quantities used to apportion ice among categories 
    1038             ! in the n2 loop below 
    1039             !----------------------------------------------------------------- 
    1040  
    1041             !        jl1 looping 1-jpl 
    1042             !           ij looping 1-icells 
    1043  
    1044             dhr (ji,jj) = hrmax(ji,jj,jl1) - hrmin(ji,jj,jl1) 
    1045             dhr2(ji,jj) = hrmax(ji,jj,jl1) * hrmax(ji,jj,jl1) - hrmin(ji,jj,jl1) * hrmin(ji,jj,jl1) 
    1046  
    1047          END DO 
    1048  
    1049          !-------------------------------------------------------------------- 
    1050          ! 3.9 Compute ridging ice enthalpy, remove it from ridging ice and 
    1051          !      compute ridged ice enthalpy  
    1052          !-------------------------------------------------------------------- 
    1053          DO jk = 1, nlay_i 
    1054             DO ij = 1, icells 
    1055                ji = indxi(ij) 
    1056                jj = indxj(ij) 
    1057                ! heat content of ridged ice 
    1058                erdg1(ji,jj,jk)      = eicen_init(ji,jj,jk,jl1) * afrac(ji,jj)  
    1059                eirft(ji,jj,jk)      = eicen_init(ji,jj,jk,jl1) * afrft(ji,jj) 
    1060                e_i  (ji,jj,jk,jl1)  = e_i(ji,jj,jk,jl1) - erdg1(ji,jj,jk) - eirft(ji,jj,jk) 
    1061                 
    1062                 
    1063                ! enthalpy of the trapped seawater (J/m2, >0) 
    1064                ! clem: if sst>0, then ersw <0 (is that possible?) 
    1065                ersw(ji,jj,jk)   = - rhoic * vsw(ji,jj) * rcp * sst_m(ji,jj) * r1_nlay_i 
    1066  
    1067                ! heat flux to the ocean 
    1068                hfx_dyn(ji,jj) = hfx_dyn(ji,jj) + ersw(ji,jj,jk) * r1_rdtice  ! > 0 [W.m-2] ocean->ice flux  
    1069  
    1070                ! it is added to sea ice because the sign convention is the opposite of the sign convention for the ocean 
    1071                erdg2(ji,jj,jk)  = erdg1(ji,jj,jk) + ersw(ji,jj,jk) 
    1072  
    1073             END DO 
    1074          END DO 
    1075  
    1076  
    1077          IF( con_i ) THEN 
    1078             DO jk = 1, nlay_i 
    1079                DO ij = 1, icells 
    1080                   ji = indxi(ij) 
    1081                   jj = indxj(ij) 
    1082                   eice_init(ji,jj) = eice_init(ji,jj) + erdg2(ji,jj,jk) - erdg1(ji,jj,jk) 
    1083                END DO 
    1084             END DO 
    1085          ENDIF 
    1086  
    1087          !------------------------------------------------------------------------------- 
    1088          ! 4) Add area, volume, and energy of new ridge to each category jl2 
    1089          !------------------------------------------------------------------------------- 
    1090          !        jl1 looping 1-jpl 
    1091          DO jl2  = 1, jpl  
    1092             ! over categories to which ridged ice is transferred 
    1093             DO ij = 1, icells 
    1094                ji = indxi(ij) 
    1095                jj = indxj(ij) 
    1096  
    1097                ! Compute the fraction of ridged ice area and volume going to  
    1098                ! thickness category jl2. 
    1099                ! Transfer area, volume, and energy accordingly. 
    1100  
    1101                IF( hrmin(ji,jj,jl1) >= hi_max(jl2) .OR. hrmax(ji,jj,jl1) <= hi_max(jl2-1) ) THEN 
    1102                   hL = 0._wp 
    1103                   hR = 0._wp 
    1104                ELSE 
    1105                   hL = MAX( hrmin(ji,jj,jl1), hi_max(jl2-1) ) 
    1106                   hR = MIN( hrmax(ji,jj,jl1), hi_max(jl2)   ) 
    1107                ENDIF 
    1108  
    1109                ! fraction of ridged ice area and volume going to n2 
    1110                farea = ( hR - hL ) / dhr(ji,jj)  
    1111                fvol(ji,jj) = ( hR*hR - hL*hL ) / dhr2(ji,jj) 
    1112  
    1113                a_i  (ji,jj  ,jl2) = a_i  (ji,jj  ,jl2) + ardg2 (ji,jj) * farea 
    1114                v_i  (ji,jj  ,jl2) = v_i  (ji,jj  ,jl2) + vrdg2 (ji,jj) * fvol(ji,jj) 
    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 
    1117                smv_i(ji,jj  ,jl2) = smv_i(ji,jj  ,jl2) + srdg2 (ji,jj) * fvol(ji,jj) 
    1118                oa_i (ji,jj  ,jl2) = oa_i (ji,jj  ,jl2) + oirdg2(ji,jj) * farea 
    1119  
    1120             END DO 
    1121  
    1122             ! Transfer ice energy to category jl2 by ridging 
    1123             DO jk = 1, nlay_i 
    1124                DO ij = 1, icells 
    1125                   ji = indxi(ij) 
    1126                   jj = indxj(ij) 
    1127                   e_i(ji,jj,jk,jl2) = e_i(ji,jj,jk,jl2) + fvol(ji,jj) * erdg2(ji,jj,jk) 
    1128                END DO 
    1129             END DO 
    1130             ! 
    1131          END DO                 ! jl2 (new ridges)             
    1132  
    1133          DO jl2 = 1, jpl  
    1134  
    1135             DO ij = 1, icells 
    1136                ji = indxi(ij) 
    1137                jj = indxj(ij) 
    1138                ! Compute the fraction of rafted ice area and volume going to  
    1139                ! thickness category jl2, transfer area, volume, and energy accordingly. 
    1140                ! 
    1141                IF( hraft(ji,jj,jl1) <= hi_max(jl2) .AND. hraft(ji,jj,jl1) >  hi_max(jl2-1) ) THEN 
    1142                   a_i  (ji,jj  ,jl2) = a_i  (ji,jj  ,jl2) + arft2 (ji,jj) 
    1143                   v_i  (ji,jj  ,jl2) = v_i  (ji,jj  ,jl2) + virft (ji,jj) 
    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 
    1146                   smv_i(ji,jj  ,jl2) = smv_i(ji,jj  ,jl2) + smrft (ji,jj)     
    1147                   oa_i (ji,jj  ,jl2) = oa_i (ji,jj  ,jl2) + oirft2(ji,jj) 
    1148                ENDIF 
    1149                ! 
    1150             END DO 
    1151  
    1152             ! Transfer rafted ice energy to category jl2  
    1153             DO jk = 1, nlay_i 
    1154                DO ij = 1, icells 
    1155                   ji = indxi(ij) 
    1156                   jj = indxj(ij) 
    1157                   IF( hraft(ji,jj,jl1) <= hi_max(jl2) .AND. hraft(ji,jj,jl1) > hi_max(jl2-1)  ) THEN 
    1158                      e_i(ji,jj,jk,jl2) = e_i(ji,jj,jk,jl2) + eirft(ji,jj,jk) 
    1159                   ENDIF 
    1160                END DO 
    1161             END DO 
    1162  
    1163          END DO 
    1164  
    1165       END DO ! jl1 (deforming categories) 
    1166  
    1167       ! Conservation check 
    1168       IF ( con_i ) THEN 
    1169          CALL lim_column_sum (jpl,   v_i, vice_final) 
    1170          fieldid = ' v_i : limitd_me ' 
    1171          CALL lim_cons_check (vice_init, vice_final, 1.0e-6, fieldid)  
    1172  
    1173          CALL lim_column_sum_energy (jpl, nlay_i,  e_i, eice_final ) 
    1174          fieldid = ' e_i : limitd_me ' 
    1175          CALL lim_cons_check (eice_init, eice_final, 1.0e-2, fieldid)  
    1176  
    1177          DO ji = mi0(iiceprt), mi1(iiceprt) 
    1178             DO jj = mj0(jiceprt), mj1(jiceprt) 
    1179                WRITE(numout,*) ' vice_init  : ', vice_init (ji,jj) 
    1180                WRITE(numout,*) ' vice_final : ', vice_final(ji,jj) 
    1181                WRITE(numout,*) ' eice_init  : ', eice_init (ji,jj) 
    1182                WRITE(numout,*) ' eice_final : ', eice_final(ji,jj) 
    1183             END DO 
    1184          END DO 
    1185       ENDIF 
    1186       ! 
    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 ) 
    1195       ! 
    1196    END SUBROUTINE lim_itd_me_ridgeshift 
    1197940 
    1198941   SUBROUTINE lim_itd_me_init 

  • branches/2016/dev_CNRS_2016/NEMOGCM/NEMO/LIM_SRC_3/limrhg.F90

    r7277 r7278  
    159159      CALL wrk_alloc( jpi,jpj, u_oce2, u_ice2, v_oce1 , v_ice1 , zmask               ) 
    160160      CALL wrk_alloc( jpi,jpj, zf1   , zu_ice, zf2   , zv_ice , zdt    , zds  ) 
    161       CALL wrk_alloc( jpi,jpj, zdt   , zds   , zs1   , zs2   , zs12   , zresr , zpice                 ) 
     161      CALL wrk_alloc( jpi,jpj, zs1   , zs2   , zs12   , zresr , zpice                 ) 
    162162 
    163163#if  defined key_lim2 && ! defined key_lim2_vp 
    … …  
    690690      CALL wrk_dealloc( jpi,jpj, u_oce2, u_ice2, v_oce1 , v_ice1 , zmask               ) 
    691691      CALL wrk_dealloc( jpi,jpj, zf1   , zu_ice, zf2   , zv_ice , zdt    , zds  ) 
    692       CALL wrk_dealloc( jpi,jpj, zdt   , zds   , zs1   , zs2   , zs12   , zresr , zpice                 ) 
     692      CALL wrk_dealloc( jpi,jpj, zs1   , zs2   , zs12   , zresr , zpice                 ) 
    693693 
    694694   END SUBROUTINE lim_rhg 

  • branches/2016/dev_CNRS_2016/NEMOGCM/NEMO/LIM_SRC_3/limsbc.F90

    r7277 r7278  
    107107      REAL(wp) ::   zqsr             ! New solar flux received by the ocean 
    108108      REAL(wp), POINTER, DIMENSION(:,:,:) ::   zalb_cs, zalb_os     ! 3D workspace 
     109      REAL(wp), POINTER, DIMENSION(:,:)   ::   zalb                 ! 2D workspace 
    109110      !!--------------------------------------------------------------------- 
    110111      ! 
    111112      ! make calls for heat fluxes before it is modified 
     113      ! pfrld is the lead fraction at the previous time step (actually between TRP and THD) 
    112114      IF( iom_use('qsr_oce') )   CALL iom_put( "qsr_oce" , qsr_oce(:,:) * pfrld(:,:) )                                   !     solar flux at ocean surface 
    113115      IF( iom_use('qns_oce') )   CALL iom_put( "qns_oce" , qns_oce(:,:) * pfrld(:,:) + qemp_oce(:,:) )                   ! non-solar flux at ocean surface 
    … …  
    118120      IF( iom_use('qt_ice' ) )   CALL iom_put( "qt_ice"  , SUM( ( qns_ice(:,:,:) + qsr_ice(:,:,:) )   & 
    119121         &                                                      * a_i_b(:,:,:), dim=3 ) + qemp_ice(:,:) ) 
    120       IF( iom_use('qemp_oce' ) )   CALL iom_put( "qemp_oce"  , qemp_oce(:,:) )   
    121       IF( iom_use('qemp_ice' ) )   CALL iom_put( "qemp_ice"  , qemp_ice(:,:) )   
    122  
    123       ! pfrld is the lead fraction at the previous time step (actually between TRP and THD) 
     122      IF( iom_use('qemp_oce') )  CALL iom_put( "qemp_oce" , qemp_oce(:,:) )   
     123      IF( iom_use('qemp_ice') )  CALL iom_put( "qemp_ice" , qemp_ice(:,:) )   
     124      IF( iom_use('emp_oce' ) )  CALL iom_put( "emp_oce"  , emp_oce(:,:) )   ! emp over ocean (taking into account the snow blown away from the ice) 
     125      IF( iom_use('emp_ice' ) )  CALL iom_put( "emp_ice"  , emp_ice(:,:) )   ! emp over ice   (taking into account the snow blown away from the ice) 
     126 
     127      ! albedo output 
     128      CALL wrk_alloc( jpi,jpj, zalb )     
     129 
     130      zalb(:,:) = 0._wp 
     131      WHERE     ( SUM( a_i_b, dim=3 ) <= epsi06 )  ;  zalb(:,:) = 0.066_wp 
     132      ELSEWHERE                                    ;  zalb(:,:) = SUM( alb_ice * a_i_b, dim=3 ) / SUM( a_i_b, dim=3 ) 
     133      END WHERE 
     134      IF( iom_use('alb_ice' ) )  CALL iom_put( "alb_ice"  , zalb(:,:) )           ! ice albedo output 
     135 
     136      zalb(:,:) = SUM( alb_ice * a_i_b, dim=3 ) + 0.066_wp * ( 1._wp - SUM( a_i_b, dim=3 ) )       
     137      IF( iom_use('albedo'  ) )  CALL iom_put( "albedo"  , zalb(:,:) )           ! ice albedo output 
     138 
     139      CALL wrk_dealloc( jpi,jpj, zalb )     
     140 
    124141      DO jj = 1, jpj 
    125142         DO ji = 1, jpi 
    … …  
    140157            hfx_out(ji,jj) = hfx_out(ji,jj) + zqmass + zqsr 
    141158 
    142             ! Add the residual from heat diffusion equation (W.m-2) 
    143             !------------------------------------------------------- 
    144             hfx_out(ji,jj) = hfx_out(ji,jj) + hfx_err_dif(ji,jj) 
     159            ! Add the residual from heat diffusion equation and sublimation (W.m-2) 
     160            !---------------------------------------------------------------------- 
     161            hfx_out(ji,jj) = hfx_out(ji,jj) + hfx_err_dif(ji,jj) +   & 
     162               &           ( hfx_sub(ji,jj) - SUM( qevap_ice(ji,jj,:) * a_i_b(ji,jj,:) ) ) 
    145163 
    146164            ! New qsr and qns used to compute the oceanic heat flux at the next time step 
    147             !--------------------------------------------------- 
     165            !---------------------------------------------------------------------------- 
    148166            qsr(ji,jj) = zqsr                                       
    149167            qns(ji,jj) = hfx_out(ji,jj) - zqsr               
    … …  
    165183 
    166184            ! mass flux at the ocean/ice interface 
    167             fmmflx(ji,jj) = - ( wfx_ice(ji,jj) + wfx_snw(ji,jj) ) * r1_rdtice  ! F/M mass flux save at least for biogeochemical model 
    168             emp(ji,jj)    = emp_oce(ji,jj) - wfx_ice(ji,jj) - wfx_snw(ji,jj)   ! mass flux + F/M mass flux (always ice/ocean mass exchange) 
    169              
     185            fmmflx(ji,jj) = - ( wfx_ice(ji,jj) + wfx_snw(ji,jj) + wfx_err_sub(ji,jj) )              ! F/M mass flux save at least for biogeochemical model 
     186            emp(ji,jj)    = emp_oce(ji,jj) - wfx_ice(ji,jj) - wfx_snw(ji,jj) - wfx_err_sub(ji,jj)   ! mass flux + F/M mass flux (always ice/ocean mass exchange)             
    170187         END DO 
    171188      END DO 
    … …  
    175192      !------------------------------------------! 
    176193      sfx(:,:) = sfx_bog(:,:) + sfx_bom(:,:) + sfx_sum(:,:) + sfx_sni(:,:) + sfx_opw(:,:)   & 
    177          &     + sfx_res(:,:) + sfx_dyn(:,:) + sfx_bri(:,:) 
     194         &     + sfx_res(:,:) + sfx_dyn(:,:) + sfx_bri(:,:) + sfx_sub(:,:) 
    178195 
    179196      !-------------------------------------------------------------! 

  • branches/2016/dev_CNRS_2016/NEMOGCM/NEMO/LIM_SRC_3/limthd.F90

    r6140 r7278  
    440440      ! 
    441441      DO ji = kideb, kiut 
    442          zdh_mel = MIN( 0._wp, dh_i_surf(ji) + dh_i_bott(ji) + dh_snowice(ji) ) 
     442         zdh_mel = MIN( 0._wp, dh_i_surf(ji) + dh_i_bott(ji) + dh_snowice(ji) + dh_i_sub(ji) ) 
    443443         IF( zdh_mel < 0._wp .AND. a_i_1d(ji) > 0._wp )  THEN 
    444444            zvi          = a_i_1d(ji) * ht_i_1d(ji) 
    … …  
    495495         ! 
    496496         CALL tab_2d_1d( nbpb, qprec_ice_1d(1:nbpb), qprec_ice(:,:) , jpi, jpj, npb(1:nbpb) ) 
     497         CALL tab_2d_1d( nbpb, qevap_ice_1d(1:nbpb), qevap_ice(:,:,jl) , jpi, jpj, npb(1:nbpb) ) 
    497498         CALL tab_2d_1d( nbpb, qsr_ice_1d (1:nbpb), qsr_ice(:,:,jl) , jpi, jpj, npb(1:nbpb) ) 
    498499         CALL tab_2d_1d( nbpb, fr1_i0_1d  (1:nbpb), fr1_i0          , jpi, jpj, npb(1:nbpb) ) 
    … …  
    524525         CALL tab_2d_1d( nbpb, sfx_bri_1d (1:nbpb), sfx_bri         , jpi, jpj, npb(1:nbpb) ) 
    525526         CALL tab_2d_1d( nbpb, sfx_res_1d (1:nbpb), sfx_res         , jpi, jpj, npb(1:nbpb) ) 
     527         CALL tab_2d_1d( nbpb, sfx_sub_1d (1:nbpb), sfx_sub         , jpi, jpj,npb(1:nbpb) ) 
    526528         ! 
    527529         CALL tab_2d_1d( nbpb, hfx_thd_1d (1:nbpb), hfx_thd         , jpi, jpj, npb(1:nbpb) ) 
    … …  
    574576         CALL tab_1d_2d( nbpb, sfx_res       , npb, sfx_res_1d(1:nbpb)   , jpi, jpj ) 
    575577         CALL tab_1d_2d( nbpb, sfx_bri       , npb, sfx_bri_1d(1:nbpb)   , jpi, jpj ) 
     578         CALL tab_1d_2d( nbpb, sfx_sub       , npb, sfx_sub_1d(1:nbpb)   , jpi, jpj )         
    576579         ! 
    577580         CALL tab_1d_2d( nbpb, hfx_thd       , npb, hfx_thd_1d(1:nbpb)   , jpi, jpj ) 

  • branches/2016/dev_CNRS_2016/NEMOGCM/NEMO/LIM_SRC_3/limthd_dh.F90

    r5487 r7278  
    7474 
    7575      REAL(wp) ::   ztmelts             ! local scalar 
    76       REAL(wp) ::   zfdum        
     76      REAL(wp) ::   zdum        
    7777      REAL(wp) ::   zfracs       ! fractionation coefficient for bottom salt entrapment 
    7878      REAL(wp) ::   zs_snic      ! snow-ice salinity 
    … …  
    9595      REAL(wp), POINTER, DIMENSION(:) ::   zq_rema     ! remaining heat at the end of the routine    (J.m-2) 
    9696      REAL(wp), POINTER, DIMENSION(:) ::   zf_tt       ! Heat budget to determine melting or freezing(W.m-2) 
     97      REAL(wp), POINTER, DIMENSION(:) ::   zevap_rema  ! remaining mass flux from sublimation        (kg.m-2) 
    9798 
    9899      REAL(wp), POINTER, DIMENSION(:) ::   zdh_s_mel   ! snow melt  
    … …  
    105106 
    106107      REAL(wp), POINTER, DIMENSION(:) ::   zqh_i       ! total ice heat content  (J.m-2) 
    107       REAL(wp), POINTER, DIMENSION(:) ::   zqh_s       ! total snow heat content (J.m-2) 
    108       REAL(wp), POINTER, DIMENSION(:) ::   zq_s        ! total snow enthalpy     (J.m-3) 
    109108      REAL(wp), POINTER, DIMENSION(:) ::   zsnw        ! distribution of snow after wind blowing 
    110109 
    … …  
    118117      ! Discriminate between varying salinity (nn_icesal=2) and prescribed cases (other values) 
    119118      SELECT CASE( nn_icesal )                       ! varying salinity or not 
    120          CASE( 1, 3, 4 ) ;   zswitch_sal = 0       ! prescribed salinity profile 
    121          CASE( 2 )       ;   zswitch_sal = 1       ! varying salinity profile 
     119         CASE( 1, 3 ) ;   zswitch_sal = 0       ! prescribed salinity profile 
     120         CASE( 2 )    ;   zswitch_sal = 1       ! varying salinity profile 
    122121      END SELECT 
    123122 
    124       CALL wrk_alloc( jpij, zqprec, zq_su, zq_bo, zf_tt, zq_rema, zsnw ) 
    125       CALL wrk_alloc( jpij, zdh_s_mel, zdh_s_pre, zdh_s_sub, zqh_i, zqh_s, zq_s ) 
     123      CALL wrk_alloc( jpij, zqprec, zq_su, zq_bo, zf_tt, zq_rema, zsnw, zevap_rema ) 
     124      CALL wrk_alloc( jpij, zdh_s_mel, zdh_s_pre, zdh_s_sub, zqh_i ) 
    126125      CALL wrk_alloc( jpij, nlay_i, zdeltah, zh_i ) 
    127126      CALL wrk_alloc( jpij, nlay_i, icount ) 
    128127        
    129       dh_i_surf  (:) = 0._wp ; dh_i_bott  (:) = 0._wp ; dh_snowice(:) = 0._wp 
     128      dh_i_surf  (:) = 0._wp ; dh_i_bott  (:) = 0._wp ; dh_snowice(:) = 0._wp ; dh_i_sub(:) = 0._wp 
    130129      dsm_i_se_1d(:) = 0._wp ; dsm_i_si_1d(:) = 0._wp    
    131130 
    132131      zqprec   (:) = 0._wp ; zq_su    (:) = 0._wp ; zq_bo    (:) = 0._wp ; zf_tt(:) = 0._wp 
    133       zq_rema  (:) = 0._wp ; zsnw     (:) = 0._wp 
     132      zq_rema  (:) = 0._wp ; zsnw     (:) = 0._wp ; zevap_rema(:) = 0._wp ; 
    134133      zdh_s_mel(:) = 0._wp ; zdh_s_pre(:) = 0._wp ; zdh_s_sub(:) = 0._wp ; zqh_i(:) = 0._wp 
    135       zqh_s    (:) = 0._wp ; zq_s     (:) = 0._wp      
    136134 
    137135      zdeltah(:,:) = 0._wp ; zh_i(:,:) = 0._wp        
    … …  
    159157      ! 
    160158      DO ji = kideb, kiut 
    161          zfdum      = qns_ice_1d(ji) + ( 1._wp - i0(ji) ) * qsr_ice_1d(ji) - fc_su(ji)  
     159         zdum       = qns_ice_1d(ji) + ( 1._wp - i0(ji) ) * qsr_ice_1d(ji) - fc_su(ji)  
    162160         zf_tt(ji)  = fc_bo_i(ji) + fhtur_1d(ji) + fhld_1d(ji)  
    163161 
    164          zq_su (ji) = MAX( 0._wp, zfdum     * rdt_ice ) * MAX( 0._wp , SIGN( 1._wp, t_su_1d(ji) - rt0 ) ) 
     162         zq_su (ji) = MAX( 0._wp, zdum      * rdt_ice ) * MAX( 0._wp , SIGN( 1._wp, t_su_1d(ji) - rt0 ) ) 
    165163         zq_bo (ji) = MAX( 0._wp, zf_tt(ji) * rdt_ice ) 
    166164      END DO 
    … …  
    187185      !  2) Computing layer thicknesses and enthalpies.            ! 
    188186      !------------------------------------------------------------! 
    189       ! 
    190       DO jk = 1, nlay_s 
    191          DO ji = kideb, kiut 
    192             zqh_s(ji) =  zqh_s(ji) + q_s_1d(ji,jk) * ht_s_1d(ji) * r1_nlay_s 
    193          END DO 
    194       END DO 
    195187      ! 
    196188      DO jk = 1, nlay_i 
    … …  
    275267      END DO 
    276268 
    277       !---------------------- 
    278       ! 3.2 Snow sublimation  
    279       !---------------------- 
     269      !------------------------------ 
     270      ! 3.2 Sublimation (part1: snow)  
     271      !------------------------------ 
    280272      ! qla_ice is always >=0 (upwards), heat goes to the atmosphere, therefore snow sublimates 
    281273      ! clem comment: not counted in mass/heat exchange in limsbc since this is an exchange with atm. (not ocean) 
    282       ! clem comment: ice should also sublimate 
    283274      zdeltah(:,:) = 0._wp 
    284       ! coupled mode: sublimation is set to 0 (evap_ice = 0) until further notice 
    285       ! forced  mode: snow thickness change due to sublimation 
    286       DO ji = kideb, kiut 
    287          zdh_s_sub(ji)  =  MAX( - ht_s_1d(ji) , - evap_ice_1d(ji) * r1_rhosn * rdt_ice ) 
    288          ! Heat flux by sublimation [W.m-2], < 0 
    289          !      sublimate first snow that had fallen, then pre-existing snow 
     275      DO ji = kideb, kiut 
     276         zdh_s_sub(ji)  = MAX( - ht_s_1d(ji) , - evap_ice_1d(ji) * r1_rhosn * rdt_ice ) 
     277         ! remaining evap in kg.m-2 (used for ice melting later on) 
     278         zevap_rema(ji)  = evap_ice_1d(ji) * rdt_ice + zdh_s_sub(ji) * rhosn 
     279         ! Heat flux by sublimation [W.m-2], < 0 (sublimate first snow that had fallen, then pre-existing snow) 
    290280         zdeltah(ji,1)  = MAX( zdh_s_sub(ji), - zdh_s_pre(ji) ) 
    291281         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)  & 
    … …  
    309299      !------------------------------------------- 
    310300      ! new temp and enthalpy of the snow (remaining snow precip + remaining pre-existing snow) 
    311       zq_s(:) = 0._wp  
    312301      DO jk = 1, nlay_s 
    313302         DO ji = kideb,kiut 
    314             rswitch       = MAX(  0._wp , SIGN( 1._wp, ht_s_1d(ji) - epsi20 )  ) 
    315             q_s_1d(ji,jk) = rswitch / MAX( ht_s_1d(ji), epsi20 ) *                          & 
    316               &            ( (   zdh_s_pre(ji)             ) * zqprec(ji) +  & 
    317               &              (   ht_s_1d(ji) - zdh_s_pre(ji) ) * rhosn * ( cpic * ( rt0 - t_s_1d(ji,jk) ) + lfus ) ) 
    318             zq_s(ji)     =  zq_s(ji) + q_s_1d(ji,jk) 
     303            rswitch       = MAX( 0._wp , SIGN( 1._wp, ht_s_1d(ji) - epsi20 ) ) 
     304            q_s_1d(ji,jk) = rswitch / MAX( ht_s_1d(ji), epsi20 ) *           & 
     305              &            ( ( zdh_s_pre(ji)               ) * zqprec(ji) +  & 
     306              &              ( ht_s_1d(ji) - zdh_s_pre(ji) ) * rhosn * ( cpic * ( rt0 - t_s_1d(ji,jk) ) + lfus ) ) 
    319307         END DO 
    320308      END DO 
    … …  
    370358               zQm            = zfmdt * zEw                           ! Energy of the melt water sent to the ocean [J/m2, <0] 
    371359                
    372                ! Contribution to salt flux (clem: using sm_i_1d and not s_i_1d(jk) is ok) 
     360               ! Contribution to salt flux >0 (clem: using sm_i_1d and not s_i_1d(jk) is ok) 
    373361               sfx_sum_1d(ji) = sfx_sum_1d(ji) - rhoic * a_i_1d(ji) * zdeltah(ji,jk) * sm_i_1d(ji) * r1_rdtice 
    374362                
    … …  
    383371                
    384372            END IF 
     373            ! ---------------------- 
     374            ! Sublimation part2: ice 
     375            ! ---------------------- 
     376            zdum      = MAX( - ( zh_i(ji,jk) + zdeltah(ji,jk) ) , - zevap_rema(ji) * r1_rhoic ) 
     377            zdeltah(ji,jk) = zdeltah(ji,jk) + zdum 
     378            dh_i_sub(ji)  = dh_i_sub(ji) + zdum 
     379            ! Salt flux > 0 (clem2016: flux is sent to the ocean for simplicity but salt should remain in the ice except if all ice is melted. 
     380            !                          It must be corrected at some point) 
     381            sfx_sub_1d(ji) = sfx_sub_1d(ji) - rhoic * a_i_1d(ji) * zdum * sm_i_1d(ji) * r1_rdtice 
     382            ! Heat flux [W.m-2], < 0 
     383            hfx_sub_1d(ji) = hfx_sub_1d(ji) + zdum * q_i_1d(ji,jk) * a_i_1d(ji) * r1_rdtice 
     384            ! Mass flux > 0 
     385            wfx_sub_1d(ji) =  wfx_sub_1d(ji) - rhoic * a_i_1d(ji) * zdum * r1_rdtice 
     386            ! update remaining mass flux 
     387            zevap_rema(ji)  = zevap_rema(ji) + zdum * rhoic 
     388             
    385389            ! record which layers have disappeared (for bottom melting)  
    386390            !    => icount=0 : no layer has vanished 
    … …  
    389393            icount(ji,jk) = NINT( rswitch ) 
    390394            zh_i(ji,jk)   = MAX( 0._wp , zh_i(ji,jk) + zdeltah(ji,jk) ) 
    391  
     395                         
    392396            ! update heat content (J.m-2) and layer thickness 
    393397            qh_i_old(ji,jk) = qh_i_old(ji,jk) + zdeltah(ji,jk) * q_i_1d(ji,jk) 
    … …  
    397401      ! update ice thickness 
    398402      DO ji = kideb, kiut 
    399          ht_i_1d(ji) =  MAX( 0._wp , ht_i_1d(ji) + dh_i_surf(ji) ) 
     403         ht_i_1d(ji) =  MAX( 0._wp , ht_i_1d(ji) + dh_i_surf(ji) + dh_i_sub(ji) ) 
     404      END DO 
     405 
     406      ! remaining "potential" evap is sent to ocean 
     407      DO ji = kideb, kiut 
     408         ii = MOD( npb(ji) - 1, jpi ) + 1 ; ij = ( npb(ji) - 1 ) / jpi + 1 
     409         wfx_err_sub(ii,ij) = wfx_err_sub(ii,ij) - zevap_rema(ji) * a_i_1d(ji) * r1_rdtice  ! <=0 (net evap for the ocean in kg.m-2.s-1) 
    400410      END DO 
    401411 
    … …  
    653663         sfx_sni_1d(ji) = sfx_sni_1d(ji) + sss_m(ii,ij) * a_i_1d(ji) * zfmdt * r1_rdtice  
    654664           
     665         ! virtual salt flux to keep salinity constant 
     666         IF( nn_icesal == 1 .OR. nn_icesal == 3 )  THEN 
     667            sfx_bri_1d(ji) = sfx_bri_1d(ji) - sss_m(ii,ij) * a_i_1d(ji) * zfmdt                  * r1_rdtice  & ! put back sss_m into the ocean 
     668               &                            - sm_i_1d(ji)  * a_i_1d(ji) * dh_snowice(ji) * rhoic * r1_rdtice    ! and get  sm_i  from the ocean  
     669         ENDIF 
     670 
    655671         ! Contribution to mass flux 
    656672         ! All snow is thrown in the ocean, and seawater is taken to replace the volume 
    … …  
    686702      WHERE( ht_i_1d == 0._wp ) a_i_1d = 0._wp 
    687703       
    688       CALL wrk_dealloc( jpij, zqprec, zq_su, zq_bo, zf_tt, zq_rema, zsnw ) 
    689       CALL wrk_dealloc( jpij, zdh_s_mel, zdh_s_pre, zdh_s_sub, zqh_i, zqh_s, zq_s ) 
     704      CALL wrk_dealloc( jpij, zqprec, zq_su, zq_bo, zf_tt, zq_rema, zsnw, zevap_rema ) 
     705      CALL wrk_dealloc( jpij, zdh_s_mel, zdh_s_pre, zdh_s_sub, zqh_i ) 
    690706      CALL wrk_dealloc( jpij, nlay_i, zdeltah, zh_i ) 
    691707      CALL wrk_dealloc( jpij, nlay_i, icount ) 

  • branches/2016/dev_CNRS_2016/NEMOGCM/NEMO/LIM_SRC_3/limthd_lac.F90

    r6403 r7278  
    7575      INTEGER ::   ii, ij, iter     !   -       - 
    7676      REAL(wp)  ::   ztmelts, zdv, zfrazb, zweight, zde                         ! local scalars 
    77       REAL(wp) ::   zgamafr, zvfrx, zvgx, ztaux, ztwogp, zf , zhicol_new        !   -      - 
     77      REAL(wp) ::   zgamafr, zvfrx, zvgx, ztaux, ztwogp, zf                     !   -      - 
    7878      REAL(wp) ::   ztenagm, zvfry, zvgy, ztauy, zvrel2, zfp, zsqcd , zhicrit   !   -      - 
    79       LOGICAL  ::   iterate_frazil   ! iterate frazil ice collection thickness 
    8079      CHARACTER (len = 15) :: fieldid 
    8180 
    … …  
    108107      REAL(wp), POINTER, DIMENSION(:,:) ::   zsmv_i_1d ! 1-D version of smv_i 
    109108 
    110       REAL(wp), POINTER, DIMENSION(:,:,:) ::   ze_i_1d   !: 1-D version of e_i 
    111  
    112       REAL(wp), POINTER, DIMENSION(:,:) ::   zvrel                   ! relative ice / frazil velocity 
    113  
    114       REAL(wp) :: zcai = 1.4e-3_wp 
     109      REAL(wp), POINTER, DIMENSION(:,:,:) ::   ze_i_1d !: 1-D version of e_i 
     110 
     111      REAL(wp), POINTER, DIMENSION(:,:) ::   zvrel     ! relative ice / frazil velocity 
     112 
     113      REAL(wp) :: zcai = 1.4e-3_wp                     ! ice-air drag (clem: should be dependent on coupling/forcing used) 
    115114      !!-----------------------------------------------------------------------! 
    116115 
    … …  
    143142      !------------------------------------------------------------------------------!     
    144143      ! hicol is the thickness of new ice formed in open water 
    145       ! hicol can be either prescribed (frazswi = 0) 
    146       ! or computed (frazswi = 1) 
     144      ! hicol can be either prescribed (frazswi = 0) or computed (frazswi = 1) 
    147145      ! Frazil ice forms in open water, is transported by wind 
    148146      ! accumulates at the edge of the consolidated ice edge 
    … …  
    155153      zvrel(:,:) = 0._wp 
    156154 
    157       ! Default new ice thickness  
    158       hicol(:,:) = rn_hnewice 
     155      ! Default new ice thickness 
     156      WHERE( qlead(:,:) < 0._wp ) ; hicol = rn_hnewice 
     157      ELSEWHERE                   ; hicol = 0._wp 
     158      END WHERE 
    159159 
    160160      IF( ln_frazil ) THEN 
    … …  
    182182                     &          +   vtau_ice(ji  ,jj  ) * vmask(ji  ,jj  ,1) ) * 0.5_wp 
    183183                  ! Square root of wind stress 
    184                   ztenagm       =  SQRT( SQRT( ztaux**2 + ztauy**2 ) ) 
     184                  ztenagm       =  SQRT( SQRT( ztaux * ztaux + ztauy * ztauy ) ) 
    185185 
    186186                  !--------------------- 
    … …  
    205205                  zvrel2 = MAX(  ( zvfrx - zvgx ) * ( zvfrx - zvgx )   & 
    206206                     &         + ( zvfry - zvgy ) * ( zvfry - zvgy ) , 0.15 * 0.15 ) 
    207                   zvrel(ji,jj)  = SQRT( zvrel2 ) 
     207                  zvrel(ji,jj) = SQRT( zvrel2 ) 
    208208 
    209209                  !--------------------- 
    210210                  ! Iterative procedure 
    211211                  !--------------------- 
    212                   hicol(ji,jj) = zhicrit + 0.1  
    213                   hicol(ji,jj) = zhicrit +   hicol(ji,jj)    & 
    214                      &                   / ( hicol(ji,jj) * hicol(ji,jj) -  zhicrit * zhicrit ) * ztwogp * zvrel2 
    215  
    216 !!gm better coding: above: hicol(ji,jj) * hicol(ji,jj) = (zhicrit + 0.1)*(zhicrit + 0.1) 
    217 !!gm                                                   = zhicrit**2 + 0.2*zhicrit +0.01 
    218 !!gm                therefore the 2 lines with hicol can be replaced by 1 line: 
    219 !!gm              hicol(ji,jj) = zhicrit + (zhicrit + 0.1) / ( 0.2 * zhicrit + 0.01 ) * ztwogp * zvrel2 
    220 !!gm further more (zhicrit + 0.1)/(0.2 * zhicrit + 0.01 )*ztwogp can be computed one for all outside the DO loop 
     212                  hicol(ji,jj) = zhicrit +   ( zhicrit + 0.1 )    & 
     213                     &                   / ( ( zhicrit + 0.1 ) * ( zhicrit + 0.1 ) -  zhicrit * zhicrit ) * ztwogp * zvrel2 
    221214 
    222215                  iter = 1 
    223                   iterate_frazil = .true. 
    224  
    225                   DO WHILE ( iter < 100 .AND. iterate_frazil )  
    226                      zf = ( hicol(ji,jj) - zhicrit ) * ( hicol(ji,jj)**2 - zhicrit**2 ) & 
    227                         - hicol(ji,jj) * zhicrit * ztwogp * zvrel2 
    228                      zfp = ( hicol(ji,jj) - zhicrit ) * ( 3.0*hicol(ji,jj) + zhicrit ) & 
    229                         - zhicrit * ztwogp * zvrel2 
    230                      zhicol_new = hicol(ji,jj) - zf/zfp 
    231                      hicol(ji,jj)   = zhicol_new 
    232  
     216                  DO WHILE ( iter < 20 )  
     217                     zf  = ( hicol(ji,jj) - zhicrit ) * ( hicol(ji,jj) * hicol(ji,jj) - zhicrit * zhicrit ) -   & 
     218                        &    hicol(ji,jj) * zhicrit * ztwogp * zvrel2 
     219                     zfp = ( hicol(ji,jj) - zhicrit ) * ( 3.0 * hicol(ji,jj) + zhicrit ) - zhicrit * ztwogp * zvrel2 
     220 
     221                     hicol(ji,jj) = hicol(ji,jj) - zf/zfp 
    233222                     iter = iter + 1 
    234  
    235                   END DO ! do while 
     223                  END DO 
    236224 
    237225               ENDIF ! end of selection of pixels where ice forms 
    238226 
    239             END DO ! loop on ji ends 
    240          END DO ! loop on jj ends 
    241       !  
    242       CALL lbc_lnk( zvrel(:,:), 'T', 1. ) 
    243       CALL lbc_lnk( hicol(:,:), 'T', 1. ) 
     227            END DO  
     228         END DO  
     229         !  
     230         CALL lbc_lnk( zvrel(:,:), 'T', 1. ) 
     231         CALL lbc_lnk( hicol(:,:), 'T', 1. ) 
    244232 
    245233      ENDIF ! End of computation of frazil ice collection thickness 
    … …  
    282270      ! Move from 2-D to 1-D vectors 
    283271      !------------------------------ 
    284       ! If ocean gains heat do nothing  
    285       ! 0therwise compute new ice formation 
     272      ! If ocean gains heat do nothing. Otherwise compute new ice formation 
    286273 
    287274      IF ( nbpac > 0 ) THEN 
    … …  
    317304         zv_b(1:nbpac,:) = zv_i_1d(1:nbpac,:)  
    318305         za_b(1:nbpac,:) = za_i_1d(1:nbpac,:) 
     306 
    319307         !---------------------- 
    320308         ! Thickness of new ice 
    321309         !---------------------- 
    322          DO ji = 1, nbpac 
    323             zh_newice(ji) = rn_hnewice 
    324          END DO 
    325          IF( ln_frazil ) zh_newice(1:nbpac) = hicol_1d(1:nbpac) 
     310         zh_newice(1:nbpac) = hicol_1d(1:nbpac) 
    326311 
    327312         !---------------------- 
    … …  
    347332         DO ji = 1, nbpac 
    348333            ztmelts       = - tmut * zs_newice(ji) + rt0                  ! Melting point (K) 
    349             ze_newice(ji) =   rhoic * (  cpic * ( ztmelts - t_bo_1d(ji) )                             & 
     334            ze_newice(ji) =   rhoic * (  cpic * ( ztmelts - t_bo_1d(ji) )                                         & 
    350335               &                       + lfus * ( 1.0 - ( ztmelts - rt0 ) / MIN( t_bo_1d(ji) - rt0, -epsi10 ) )   & 
    351336               &                       - rcp  *         ( ztmelts - rt0 )  ) 
    … …  
    385370            ! salt flux 
    386371            sfx_opw_1d(ji) = sfx_opw_1d(ji) - zv_newice(ji) * rhoic * zs_newice(ji) * r1_rdtice 
    387  
     372         END DO 
     373          
     374         zv_frazb(:) = 0._wp 
     375         IF( ln_frazil ) THEN 
    388376            ! A fraction zfrazb of frazil ice is accreted at the ice bottom 
    389             rswitch       = 1._wp - MAX( 0._wp, SIGN( 1._wp , - zat_i_1d(ji) ) ) 
    390             zfrazb        = rswitch * ( TANH ( rn_Cfrazb * ( zvrel_1d(ji) - rn_vfrazb ) ) + 1.0 ) * 0.5 * rn_maxfrazb 
    391             zv_frazb(ji)  =         zfrazb   * zv_newice(ji) 
    392             zv_newice(ji) = ( 1.0 - zfrazb ) * zv_newice(ji) 
    393          END DO 
    394  
     377            DO ji = 1, nbpac 
     378               rswitch       = 1._wp - MAX( 0._wp, SIGN( 1._wp , - zat_i_1d(ji) ) ) 
     379               zfrazb        = rswitch * ( TANH( rn_Cfrazb * ( zvrel_1d(ji) - rn_vfrazb ) ) + 1.0 ) * 0.5 * rn_maxfrazb 
     380               zv_frazb(ji)  =         zfrazb   * zv_newice(ji) 
     381               zv_newice(ji) = ( 1.0 - zfrazb ) * zv_newice(ji) 
     382            END DO 
     383         END IF 
     384          
    395385         !----------------- 
    396386         ! Area of new ice 
    … …  
    444434               jl = jcat(ji) 
    445435               rswitch = MAX( 0._wp, SIGN( 1._wp , zv_i_1d(ji,jl) - epsi20 ) ) 
    446                ze_i_1d(ji,jk,jl) = zswinew(ji)   *   ze_newice(ji) +                                                      & 
     436               ze_i_1d(ji,jk,jl) = zswinew(ji)   *   ze_newice(ji) +                                                    & 
    447437                  &        ( 1.0 - zswinew(ji) ) * ( ze_newice(ji) * zv_newice(ji) + ze_i_1d(ji,jk,jl) * zv_b(ji,jl) )  & 
    448438                  &        * rswitch / MAX( zv_i_1d(ji,jl), epsi20 ) 

  • branches/2016/dev_CNRS_2016/NEMOGCM/NEMO/LIM_SRC_3/limthd_sal.F90

    r5123 r7278  
    6262      END DO 
    6363  
    64       !------------------------------------------------------------------------------| 
    65       ! 1) Constant salinity, constant in time                                       | 
    66       !------------------------------------------------------------------------------| 
    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 
    73       ENDIF 
     64      !--------------------------------------------------------------------| 
     65      ! 1) salinity constant in time                                       | 
     66      !--------------------------------------------------------------------| 
     67      ! do nothing 
    7468 
    75       !------------------------------------------------------------------------------| 
    76       !  Module 2 : Constant salinity varying in time                                | 
    77       !------------------------------------------------------------------------------| 
     69      !----------------------------------------------------------------------| 
     70      !  2) salinity varying in time                                         | 
     71      !----------------------------------------------------------------------| 
    7872      IF(  nn_icesal == 2  ) THEN 
    7973 
    … …  
    113107 
    114108      !------------------------------------------------------------------------------| 
    115       !  Module 3 : Profile of salinity, constant in time                            | 
     109      !  3) vertical profile of salinity, constant in time                           | 
    116110      !------------------------------------------------------------------------------| 
    117111      IF(  nn_icesal == 3  )   CALL lim_var_salprof1d( kideb, kiut ) 

  • branches/2016/dev_CNRS_2016/NEMOGCM/NEMO/LIM_SRC_3/limtrp.F90

    r6403 r7278  
    6363      INTEGER, INTENT(in) ::   kt           ! number of iteration 
    6464      ! 
    65       INTEGER  ::   ji, jj, jk, jl, jt      ! dummy loop indices 
     65      INTEGER  ::   ji, jj, jk, jm , jl, jt      ! dummy loop indices 
    6666      INTEGER  ::   initad                  ! number of sub-timestep for the advection 
    6767      REAL(wp) ::   zcfl , zusnit           !   -      - 
    … …  
    7575      REAL(wp), POINTER, DIMENSION(:,:,:)    ::   zhimax                   ! old ice thickness 
    7676      REAL(wp), POINTER, DIMENSION(:,:)      ::   zatold, zeiold, zesold   ! old concentration, enthalpies 
     77      REAL(wp), POINTER, DIMENSION(:,:,:)             ::   zhdfptab 
    7778      REAL(wp) ::    zdv, zvi, zvs, zsmv, zes, zei 
    7879      REAL(wp) ::    zvi_b, zsmv_b, zei_b, zfs_b, zfw_b, zft_b 
     80      !!--------------------------------------------------------------------- 
     81      INTEGER                                ::  ihdf_vars  = 6  !!Number of variables in which we apply horizontal diffusion 
     82                                                                   !!  inside limtrp for each ice category , not counting the  
     83                                                                   !!  variables corresponding to ice_layers  
    7984      !!--------------------------------------------------------------------- 
    8085      IF( nn_timing == 1 )  CALL timing_start('limtrp') 
    … …  
    8590      CALL wrk_alloc( jpi,jpj,nlay_i,jpl, z0ei ) 
    8691      CALL wrk_alloc( jpi,jpj,jpl,        zhimax, zviold, zvsold, zsmvold ) 
     92      CALL wrk_alloc( jpi,jpj,jpl*(ihdf_vars + nlay_i)+1,zhdfptab) 
    8793 
    8894      IF( numit == nstart .AND. lwp ) THEN 
    … …  
    170176            z0oi (:,:,jl)   = oa_i (:,:,  jl) * e1e2t(:,:)  ! Age content 
    171177            z0es (:,:,jl)   = e_s  (:,:,1,jl) * e1e2t(:,:)  ! Snow heat content 
    172             DO jk = 1, nlay_i 
     178           DO jk = 1, nlay_i 
    173179               z0ei  (:,:,jk,jl) = e_i  (:,:,jk,jl) * e1e2t(:,:) ! Ice  heat content 
    174180            END DO 
    … …  
    284290         ! Diffusion of Ice fields                   
    285291         !------------------------------------------------------------------------------! 
    286  
     292         !------------------------------------ 
     293         !  Diffusion of other ice variables 
     294         !------------------------------------ 
     295         jm=1 
     296         DO jl = 1, jpl 
     297         !                             ! Masked eddy diffusivity coefficient at ocean U- and V-points 
     298         !   DO jj = 1, jpjm1                 ! NB: has not to be defined on jpj line and jpi row 
     299         !      DO ji = 1 , fs_jpim1   ! vector opt. 
     300         !         pahu(ji,jj) = ( 1._wp - MAX( 0._wp, SIGN( 1._wp, -a_i(ji  ,jj,jl) ) ) )   & 
     301         !            &        * ( 1._wp - MAX( 0._wp, SIGN( 1._wp, -a_i(ji+1,jj,jl) ) ) ) * ahiu(ji,jj) 
     302         !         pahv(ji,jj) = ( 1._wp - MAX( 0._wp, SIGN( 1._wp, -a_i(ji,jj  ,jl) ) ) )   & 
     303         !            &        * ( 1._wp - MAX( 0._wp, SIGN( 1._wp,- a_i(ji,jj+1,jl) ) ) ) * ahiv(ji,jj) 
     304         !      END DO 
     305         !   END DO 
     306            DO jj = 1, jpjm1                 ! NB: has not to be defined on jpj line and jpi row 
     307               DO ji = 1 , fs_jpim1   ! vector opt. 
     308                  pahu3D(ji,jj,jl) = ( 1._wp - MAX( 0._wp, SIGN( 1._wp, -a_i(ji  ,jj,  jl ) ) ) )   & 
     309                  &                * ( 1._wp - MAX( 0._wp, SIGN( 1._wp, -a_i(ji+1,jj,  jl ) ) ) ) * ahiu(ji,jj) 
     310                  pahv3D(ji,jj,jl) = ( 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,  jj+1,jl ) ) ) ) * ahiv(ji,jj) 
     312               END DO 
     313            END DO 
     314 
     315            zhdfptab(:,:,jm)= a_i  (:,:,  jl); jm = jm + 1     
     316            zhdfptab(:,:,jm)= v_i  (:,:,  jl); jm = jm + 1 
     317            zhdfptab(:,:,jm)= v_s  (:,:,  jl); jm = jm + 1  
     318            zhdfptab(:,:,jm)= smv_i(:,:,  jl); jm = jm + 1 
     319            zhdfptab(:,:,jm)= oa_i (:,:,  jl); jm = jm + 1 
     320            zhdfptab(:,:,jm)= e_s  (:,:,1,jl); jm = jm + 1 
     321         ! Sample of adding more variables to apply lim_hdf using lim_hdf optimization--- 
     322         !   zhdfptab(:,:,jm) = variable_1 (:,:,1,jl); jm = jm + 1   
     323         !   zhdfptab(:,:,jm) = variable_2 (:,:,1,jl); jm = jm + 1  
     324         ! 
     325         ! and in this example the parameter ihdf_vars musb be changed to 8 (necessary for allocation) 
     326         !---------------------------------------------------------------------------------------- 
     327            DO jk = 1, nlay_i 
     328              zhdfptab(:,:,jm)=e_i(:,:,jk,jl); jm= jm+1 
     329            END DO 
     330         END DO 
    287331         ! 
    288332         !-------------------------------- 
    … …  
    290334         !-------------------------------- 
    291335         !                             ! Masked eddy diffusivity coefficient at ocean U- and V-points 
     336         !DO jj = 1, jpjm1                    ! NB: has not to be defined on jpj line and jpi row 
     337         !   DO ji = 1 , fs_jpim1   ! vector opt. 
     338         !      pahu(ji,jj) = ( 1._wp - MAX( 0._wp, SIGN( 1._wp, -at_i(ji  ,jj) ) ) )   & 
     339         !         &        * ( 1._wp - MAX( 0._wp, SIGN( 1._wp, -at_i(ji+1,jj) ) ) ) * ahiu(ji,jj) 
     340         !      pahv(ji,jj) = ( 1._wp - MAX( 0._wp, SIGN( 1._wp, -at_i(ji,jj  ) ) ) )   & 
     341         !         &        * ( 1._wp - MAX( 0._wp, SIGN( 1._wp,- at_i(ji,jj+1) ) ) ) * ahiv(ji,jj) 
     342         !   END DO 
     343         !END DO 
     344          
    292345         DO jj = 1, jpjm1                    ! NB: has not to be defined on jpj line and jpi row 
    293346            DO ji = 1 , fs_jpim1   ! vector opt. 
    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) 
     347               pahu3D(ji,jj,jpl+1) = ( 1._wp - MAX( 0._wp, SIGN( 1._wp, -at_i(ji  ,jj) ) ) )   & 
     348                  &                * ( 1._wp - MAX( 0._wp, SIGN( 1._wp, -at_i(ji+1,jj) ) ) ) * ahiu(ji,jj) 
     349               pahv3D(ji,jj,jpl+1) = ( 1._wp - MAX( 0._wp, SIGN( 1._wp, -at_i(ji,jj  ) ) ) )   & 
     350                  &                * ( 1._wp - MAX( 0._wp, SIGN( 1._wp,- at_i(ji,jj+1) ) ) ) * ahiv(ji,jj) 
    298351            END DO 
    299352         END DO 
    300353         ! 
    301          CALL lim_hdf( ato_i (:,:) ) 
    302  
    303          !------------------------------------ 
    304          !  Diffusion of other ice variables 
    305          !------------------------------------ 
    306          DO jl = 1, jpl 
    307          !                             ! Masked eddy diffusivity coefficient at ocean U- and V-points 
    308             DO jj = 1, jpjm1                 ! NB: has not to be defined on jpj line and jpi row 
    309                DO ji = 1 , fs_jpim1   ! vector opt. 
    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) ) 
     354         zhdfptab(:,:,jm)= ato_i  (:,:); 
     355         CALL lim_hdf( zhdfptab, ihdf_vars, jpl, nlay_i)  
     356 
     357         jm=1 
     358         DO jl = 1, jpl 
     359            a_i  (:,:,  jl) = zhdfptab(:,:,jm); jm = jm + 1       
     360            v_i  (:,:,  jl) = zhdfptab(:,:,jm); jm = jm + 1  
     361            v_s  (:,:,  jl) = zhdfptab(:,:,jm); jm = jm + 1  
     362            smv_i(:,:,  jl) = zhdfptab(:,:,jm); jm = jm + 1  
     363            oa_i (:,:,  jl) = zhdfptab(:,:,jm); jm = jm + 1  
     364            e_s  (:,:,1,jl) = zhdfptab(:,:,jm); jm = jm + 1  
     365         ! Sample of adding more variables to apply lim_hdf--------- 
     366         !   variable_1  (:,:,1,jl) = zhdfptab(:,:, jm  ) ; jm + 1  
     367         !   variable_2  (:,:,1,jl) = zhdfptab(:,:, jm  ) ; jm + 1 
     368         !----------------------------------------------------------- 
    323369            DO jk = 1, nlay_i 
    324                CALL lim_hdf( e_i(:,:,jk,jl) ) 
    325             END DO 
    326          END DO 
     370               e_i(:,:,jk,jl) = zhdfptab(:,:,jm);jm= jm + 1  
     371            END DO 
     372         END DO 
     373 
     374         ato_i  (:,:) = zhdfptab(:,:,jm) 
    327375 
    328376         !------------------------------------------------------------------------------! 
    … …  
    464512      CALL wrk_dealloc( jpi,jpj,nlay_i,jpl, z0ei ) 
    465513      CALL wrk_dealloc( jpi,jpj,jpl,        zviold, zvsold, zhimax, zsmvold ) 
     514      CALL wrk_dealloc( jpi,jpj,jpl*(ihdf_vars+nlay_i)+1,zhdfptab) 
    466515      ! 
    467516      IF( nn_timing == 1 )  CALL timing_stop('limtrp') 
    … …  
    479528   !!====================================================================== 
    480529END MODULE limtrp 
     530 

  • branches/2016/dev_CNRS_2016/NEMOGCM/NEMO/LIM_SRC_3/limvar.F90

    r5202 r7278  
    163163               rswitch = MAX( 0._wp , SIGN( 1._wp, a_i(ji,jj,jl) - epsi20 ) )   !0 if no ice and 1 if yes 
    164164               ht_i(ji,jj,jl) = v_i (ji,jj,jl) / MAX( a_i(ji,jj,jl) , epsi20 ) * rswitch 
     165            END DO 
     166         END DO 
     167      END DO 
     168      ! Force the upper limit of ht_i to always be < hi_max (99 m). 
     169      DO jj = 1, jpj 
     170         DO ji = 1, jpi 
     171            rswitch = MAX( 0._wp , SIGN( 1._wp, ht_i(ji,jj,jpl) - epsi20 ) ) 
     172            ht_i(ji,jj,jpl) = MIN( ht_i(ji,jj,jpl) , hi_max(jpl) ) 
     173            a_i (ji,jj,jpl) = v_i(ji,jj,jpl) / MAX( ht_i(ji,jj,jpl) , epsi20 ) * rswitch 
     174         END DO 
     175      END DO 
     176 
     177      DO jl = 1, jpl 
     178         DO jj = 1, jpj 
     179            DO ji = 1, jpi 
     180               rswitch = MAX( 0._wp , SIGN( 1._wp, a_i(ji,jj,jl) - epsi20 ) )   !0 if no ice and 1 if yes 
    165181               ht_s(ji,jj,jl) = v_s (ji,jj,jl) / MAX( a_i(ji,jj,jl) , epsi20 ) * rswitch 
    166182               o_i(ji,jj,jl)  = oa_i(ji,jj,jl) / MAX( a_i(ji,jj,jl) , epsi20 ) * rswitch 
    … …  
    168184         END DO 
    169185      END DO 
    170  
     186       
    171187      IF(  nn_icesal == 2  )THEN 
    172188         DO jl = 1, jpl 
    … …  
    298314      ! Vertically constant, constant in time 
    299315      !--------------------------------------- 
    300       IF(  nn_icesal == 1  )   s_i(:,:,:,:) = rn_icesal 
     316      IF(  nn_icesal == 1  )  THEN 
     317         s_i (:,:,:,:) = rn_icesal 
     318         sm_i(:,:,:)   = rn_icesal 
     319      ENDIF 
    301320 
    302321      !----------------------------------- 

  • branches/2016/dev_CNRS_2016/NEMOGCM/NEMO/LIM_SRC_3/limwri.F90

    r6140 r7278  
    154154      ENDIF 
    155155 
    156       IF ( iom_use( "icecolf" ) ) THEN  
    157          DO jj = 1, jpj 
    158             DO ji = 1, jpi 
    159                rswitch  = MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) ) ) 
    160                z2d(ji,jj) = hicol(ji,jj) * rswitch 
    161             END DO 
    162          END DO 
    163          CALL iom_put( "icecolf"     , z2d              )        ! frazil ice collection thickness 
    164       ENDIF 
    165  
     156      IF ( iom_use( "icecolf" ) )   CALL iom_put( "icecolf", hicol )  ! frazil ice collection thickness 
     157  
    166158      CALL iom_put( "isst"        , sst_m               )        ! sea surface temperature 
    167159      CALL iom_put( "isss"        , sss_m               )        ! sea surface salinity 
    … …  
    187179      CALL iom_put( "destrp"      , diag_trp_es         )        ! advected snw enthalpy (W/m2) 
    188180 
    189       CALL iom_put( "sfxbog"      , sfx_bog * rday      )        ! salt flux from brines 
    190       CALL iom_put( "sfxbom"      , sfx_bom * rday      )        ! salt flux from brines 
    191       CALL iom_put( "sfxsum"      , sfx_sum * rday      )        ! salt flux from brines 
    192       CALL iom_put( "sfxsni"      , sfx_sni * rday      )        ! salt flux from brines 
    193       CALL iom_put( "sfxopw"      , sfx_opw * rday      )        ! salt flux from brines 
     181      CALL iom_put( "sfxbog"      , sfx_bog * rday      )        ! salt flux from bottom growth 
     182      CALL iom_put( "sfxbom"      , sfx_bom * rday      )        ! salt flux from bottom melt 
     183      CALL iom_put( "sfxsum"      , sfx_sum * rday      )        ! salt flux from surface melt 
     184      CALL iom_put( "sfxsni"      , sfx_sni * rday      )        ! salt flux from snow ice formation 
     185      CALL iom_put( "sfxopw"      , sfx_opw * rday      )        ! salt flux from open water formation 
    194186      CALL iom_put( "sfxdyn"      , sfx_dyn * rday      )        ! salt flux from ridging rafting 
    195       CALL iom_put( "sfxres"      , sfx_res * rday      )        ! salt flux from limupdate (resultant) 
     187      CALL iom_put( "sfxres"      , sfx_res * rday      )        ! salt flux from residual 
    196188      CALL iom_put( "sfxbri"      , sfx_bri * rday      )        ! salt flux from brines 
     189      CALL iom_put( "sfxsub"      , sfx_sub * rday      )        ! salt flux from sublimation 
    197190      CALL iom_put( "sfx"         , sfx     * rday      )        ! total salt flux 
    198191 
    … …  
    233226      CALL iom_put ('hfxspr'     , hfx_spr(:,:)         )   ! Heat content of snow precip  
    234227       
     228      IF ( iom_use( "vfxthin" ) ) THEN   ! ice production for open water + thin ice (<20cm) => comparable to observations   
     229         DO jj = 1, jpj  
     230            DO ji = 1, jpi 
     231               z2d(ji,jj)  = vt_i(ji,jj) / MAX( at_i(ji,jj), epsi06 ) * zswi(ji,jj) ! mean ice thickness 
     232            END DO 
     233         END DO 
     234         WHERE( z2d(:,:) < 0.2 .AND. z2d(:,:) > 0. ) ; z2da = wfx_bog 
     235         ELSEWHERE                                   ; z2da = 0._wp 
     236         END WHERE 
     237         CALL iom_put( "vfxthin", ( wfx_opw + z2da ) * ztmp ) 
     238      ENDIF 
     239 
    235240      !-------------------------------- 
    236241      ! Output values for each category 

  • branches/2016/dev_CNRS_2016/NEMOGCM/NEMO/LIM_SRC_3/thd_ice.F90

    r7277 r7278  
    4949   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   qns_ice_1d   
    5050   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   t_bo_1d      
     51   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   rn_amax_1d 
    5152 
    5253   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   hfx_sum_1d 
    … …  
    5556   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   hfx_dif_1d 
    5657   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   hfx_opw_1d 
    57    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   rn_amax_1d 
    5858   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   hfx_snw_1d 
    5959   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   hfx_err_1d 
    … …  
    8888   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   sfx_res_1d   
    8989 
     90   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   sfx_sub_1d 
     91 
    9092   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   sprecip_1d    !: <==> the 2D  sprecip 
    9193   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   frld_1d       !: <==> the 2D  frld 
    … …  
    9698   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   evap_ice_1d   !: <==> the 2D  evap_ice 
    9799   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   qprec_ice_1d  !: <==> the 2D  qprec_ice 
     100   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   qevap_ice_1d  !: <==> the 3D  qevap_ice 
    98101   !                                                     ! to reintegrate longwave flux inside the ice thermodynamics 
    99102   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   i0            !: fraction of radiation transmitted to the ice 
    … …  
    112115   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   dh_s_tot      !: Snow accretion/ablation        [m] 
    113116   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   dh_i_surf     !: Ice surface accretion/ablation [m] 
     117   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   dh_i_sub      !: Ice surface sublimation [m] 
    114118   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   dh_i_bott     !: Ice bottom accretion/ablation  [m] 
    115119   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   dh_snowice    !: Snow ice formation             [m of ice] 
    … …  
    159163         &      wfx_sum_1d(jpij)  , wfx_sni_1d (jpij) , wfx_opw_1d (jpij) , wfx_res_1d(jpij) ,  & 
    160164         &      dqns_ice_1d(jpij) , evap_ice_1d (jpij),                                         & 
    161          &      qprec_ice_1d(jpij), i0         (jpij) ,                                         &   
     165         &      qprec_ice_1d(jpij), qevap_ice_1d(jpij), i0         (jpij) ,                     &   
    162166         &      sfx_bri_1d (jpij) , sfx_bog_1d (jpij) , sfx_bom_1d (jpij) , sfx_sum_1d (jpij),  & 
    163          &      sfx_sni_1d (jpij) , sfx_opw_1d (jpij) , sfx_res_1d (jpij) ,                     & 
     167         &      sfx_sni_1d (jpij) , sfx_opw_1d (jpij) , sfx_res_1d (jpij) , sfx_sub_1d (jpij),  & 
    164168         &      dsm_i_fl_1d(jpij) , dsm_i_gd_1d(jpij) , dsm_i_se_1d(jpij) ,                     &      
    165169         &      dsm_i_si_1d(jpij) , hicol_1d    (jpij)                     , STAT=ierr(2) ) 
    … …  
    167171      ALLOCATE( t_su_1d   (jpij) , a_i_1d   (jpij) , ht_i_1d  (jpij) ,    &    
    168172         &      ht_s_1d   (jpij) , fc_su    (jpij) , fc_bo_i  (jpij) ,    &     
    169          &      dh_s_tot  (jpij) , dh_i_surf(jpij) , dh_i_bott(jpij) ,    &     
    170          &      dh_snowice(jpij) , sm_i_1d  (jpij) , s_i_new  (jpij) ,    & 
    171          &      t_s_1d(jpij,nlay_s) , t_i_1d(jpij,nlay_i) , s_i_1d(jpij,nlay_i) ,  &             
    172          &      q_i_1d(jpij,nlay_i+1) , q_s_1d(jpij,nlay_s) ,                        & 
     173         &      dh_s_tot  (jpij) , dh_i_surf(jpij) , dh_i_sub (jpij) ,    &     
     174         &      dh_i_bott (jpij) ,dh_snowice(jpij) , sm_i_1d  (jpij) , s_i_new  (jpij) ,    & 
     175         &      t_s_1d(jpij,nlay_s) , t_i_1d(jpij,nlay_i) , s_i_1d(jpij,nlay_i) ,           &             
     176         &      q_i_1d(jpij,nlay_i+1) , q_s_1d(jpij,nlay_s) ,                               & 
    173177         &      qh_i_old(jpij,0:nlay_i+1), h_i_old(jpij,0:nlay_i+1) , STAT=ierr(3)) 
    174178      ! 

  • branches/2016/dev_CNRS_2016/NEMOGCM/NEMO/OPA_SRC/DIA/diaar5.F90

    r6140 r7278  
    212212      REAL(wp) ::   zztmp   
    213213      REAL(wp), POINTER, DIMENSION(:,:,:,:) ::   zsaldta   ! Jan/Dec levitus salinity 
    214       ! reading initial file 
    215       LOGICAL  ::   ln_tsd_init      !: T & S data flag 
    216       LOGICAL  ::   ln_tsd_tradmp    !: internal damping toward input data flag 
    217       CHARACTER(len=100)            ::   cn_dir 
    218       TYPE(FLD_N)                   ::  sn_tem,sn_sal 
    219       INTEGER  ::   ios=0 
    220  
    221       NAMELIST/namtsd/ ln_tsd_init,ln_tsd_tradmp,cn_dir,sn_tem,sn_sal 
    222       ! 
    223  
    224       REWIND( numnam_ref )              ! Namelist namtsd in reference namelist : 
    225       READ  ( numnam_ref, namtsd, IOSTAT = ios, ERR = 901) 
    226 901   IF( ios /= 0 ) CALL ctl_nam ( ios , ' namtsd in reference namelist for dia_ar5', lwp ) 
    227       REWIND( numnam_cfg )              ! Namelist namtsd in configuration namelist : Parameters of the run 
    228       READ  ( numnam_cfg, namtsd, IOSTAT = ios, ERR = 902 ) 
    229 902   IF( ios /= 0 ) CALL ctl_nam ( ios , ' namtsd in configuration namelist for dia_ar5', lwp ) 
    230       IF(lwm) WRITE ( numond, namtsd ) 
    231214      ! 
    232215      !!---------------------------------------------------------------------- 
    … …  
    250233      IF( lk_mpp )   CALL mpp_sum( vol0 ) 
    251234 
    252       CALL iom_open ( TRIM( cn_dir )//TRIM(sn_sal%clname), inum ) 
    253       CALL iom_get  ( inum, jpdom_data, TRIM(sn_sal%clvar), zsaldta(:,:,:,1), 1  ) 
    254       CALL iom_get  ( inum, jpdom_data, TRIM(sn_sal%clvar), zsaldta(:,:,:,2), 12 ) 
     235 
     236      CALL iom_open ( 'sali_ref_clim_monthly', inum ) 
     237      CALL iom_get  ( inum, jpdom_data, 'vosaline' , zsaldta(:,:,:,1), 1  ) 
     238      CALL iom_get  ( inum, jpdom_data, 'vosaline' , zsaldta(:,:,:,2), 12 ) 
    255239      CALL iom_close( inum ) 
     240 
    256241      sn0(:,:,:) = 0.5_wp * ( zsaldta(:,:,:,1) + zsaldta(:,:,:,2) )         
    257242      sn0(:,:,:) = sn0(:,:,:) * tmask(:,:,:) 

  • branches/2016/dev_CNRS_2016/NEMOGCM/NEMO/OPA_SRC/DIU/cool_skin.F90

    r6075 r7278  
    1717   USE in_out_manager 
    1818   USE sbc_oce 
     19   USE lib_mpp 
    1920   USE lbclnk          ! ocean lateral boundary conditions (or mpp link) 
    2021    

  • branches/2016/dev_CNRS_2016/NEMOGCM/NEMO/OPA_SRC/DOM/domwri.F90

    r7277 r7278  
    196196         CALL dom_stiff( zprt ) 
    197197         CALL iom_rstput( 0, 0, inum, 'stiffness', zprt )      !    ! Max. grid stiffness ratio 
    198       ENDIF 
     198      ENDIF 
    199199      ! 
    200200      !                                     ! ============================ 

  • branches/2016/dev_CNRS_2016/NEMOGCM/NEMO/OPA_SRC/IOM/iom.F90

    r7277 r7278  
    114114      CASE (30)   ;   CALL xios_set_context_attr(TRIM(clname), calendar_type= "D360") 
    115115      END SELECT 
    116       WRITE(cldate,"(i4.4,'-',i2.2,'-',i2.2,' 00:00:00')") nyear,nmonth,nday  
     116      WRITE(cldate,"(i4.4,'-',i2.2,'-',i2.2,' ',i2.2,':',i2.2,':00')") nyear,nmonth,nday,nhour,nminute 
    117117      CALL xios_set_context_attr(TRIM(clname), start_date=cldate ) 
    118118 

  • branches/2016/dev_CNRS_2016/NEMOGCM/NEMO/OPA_SRC/LBC/lbclnk.F90

    r6140 r7278  
    99   !!            3.5  ! 2012     (S.Mocavero, I. Epicoco) optimization of BDY comm. via lbc_bdy_lnk and lbc_obc_lnk 
    1010   !!            3.4  ! 2012-12  (R. Bourdalle-Badie, G. Reffray)  add a C1D case   
     11   !!            3.6  ! 2015-06  (O. Tintó and M. Castrillo)  add lbc_lnk_multi   
    1112   !!---------------------------------------------------------------------- 
    1213#if defined key_mpp_mpi 
    … …  
    2223 
    2324   INTERFACE lbc_lnk_multi 
    24       MODULE PROCEDURE mpp_lnk_2d_9 
     25      MODULE PROCEDURE mpp_lnk_2d_9, mpp_lnk_2d_multiple 
    2526   END INTERFACE 
    2627   ! 
    … …  
    2930   END INTERFACE 
    3031   ! 
    31 !JMM interface not defined if not key_mpp_mpi : likely do not compile without this CPP key !!!! 
    3232   INTERFACE lbc_sum 
    3333      MODULE PROCEDURE mpp_lnk_sum_3d, mpp_lnk_sum_2d 
    3434   END INTERFACE 
    35  
     35   ! 
    3636   INTERFACE lbc_bdy_lnk 
    3737      MODULE PROCEDURE mpp_lnk_bdy_2d, mpp_lnk_bdy_3d 
    … …  
    8383   ! 
    8484   INTERFACE lbc_sum 
    85       MODULE PROCEDURE mpp_lnk_sum_3d, mpp_lnk_sum_2d 
     85      MODULE PROCEDURE lbc_lnk_sum_3d, lbc_lnk_sum_2d 
    8686   END INTERFACE 
    8787 
    … …  
    9090   END INTERFACE 
    9191   ! 
     92   INTERFACE lbc_lnk_multi 
     93      MODULE PROCEDURE lbc_lnk_2d_9, lbc_lnk_2d_multiple 
     94   END INTERFACE 
     95 
    9296   INTERFACE lbc_bdy_lnk 
    9397      MODULE PROCEDURE lbc_bdy_lnk_2d, lbc_bdy_lnk_3d 
    … …  
    97101      MODULE PROCEDURE lbc_lnk_2d_e 
    98102   END INTERFACE 
     103    
     104   TYPE arrayptr 
     105      REAL , DIMENSION (:,:),  POINTER :: pt2d 
     106   END TYPE arrayptr 
     107   PUBLIC   arrayptr 
    99108 
    100109   PUBLIC   lbc_lnk       ! ocean/ice  lateral boundary conditions 
     110   PUBLIC   lbc_sum       ! ocean/ice  lateral boundary conditions (sum of the overlap region) 
    101111   PUBLIC   lbc_lnk_e     ! 
     112   PUBLIC   lbc_lnk_multi ! modified ocean lateral boundary conditions 
    102113   PUBLIC   lbc_bdy_lnk   ! ocean lateral BDY boundary conditions 
    103114   PUBLIC   lbc_lnk_icb   ! 
    … …  
    181192      ! 
    182193   END SUBROUTINE lbc_lnk_2d 
     194    
     195   SUBROUTINE lbc_lnk_2d_multiple( pt2d_array , type_array , psgn_array , num_fields ) 
     196      !! 
     197      INTEGER :: num_fields 
     198      TYPE( arrayptr ), DIMENSION(:) :: pt2d_array 
     199      CHARACTER(len=1), DIMENSION(:), INTENT(in   ) ::   type_array   ! define the nature of ptab array grid-points 
     200      !                                                               ! = T , U , V , F , W and I points 
     201      REAL(wp)        , DIMENSION(:), INTENT(in   ) ::   psgn_array   ! =-1 the sign change across the north fold boundary 
     202      !                                                               ! =  1. , the sign is kept 
     203      ! 
     204      INTEGER  ::   ii    !!MULTI SEND DUMMY LOOP INDICES 
     205      ! 
     206      DO ii = 1, num_fields 
     207        CALL lbc_lnk_2d( pt2d_array(ii)%pt2d, type_array(ii), psgn_array(ii) ) 
     208      END DO      
     209      ! 
     210   END SUBROUTINE lbc_lnk_2d_multiple 
     211 
     212   SUBROUTINE lbc_lnk_2d_9( pt2dA, cd_typeA, psgnA, pt2dB, cd_typeB, psgnB, pt2dC, cd_typeC, psgnC   & 
     213      &                   , pt2dD, cd_typeD, psgnD, pt2dE, cd_typeE, psgnE, pt2dF, cd_typeF, psgnF   & 
     214      &                   , pt2dG, cd_typeG, psgnG, pt2dH, cd_typeH, psgnH, pt2dI, cd_typeI, psgnI, cd_mpp, pval) 
     215      !!--------------------------------------------------------------------- 
     216      ! Second 2D array on which the boundary condition is applied 
     217      REAL(wp), DIMENSION(jpi,jpj), TARGET          , INTENT(inout) ::   pt2dA 
     218      REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) ::   pt2dB , pt2dC , pt2dD , pt2dE 
     219      REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) ::   pt2dF , pt2dG , pt2dH , pt2dI 
     220      ! define the nature of ptab array grid-points 
     221      CHARACTER(len=1)                              , INTENT(in   ) ::   cd_typeA 
     222      CHARACTER(len=1)                    , OPTIONAL, INTENT(in   ) ::   cd_typeB , cd_typeC , cd_typeD , cd_typeE 
     223      CHARACTER(len=1)                    , OPTIONAL, INTENT(in   ) ::   cd_typeF , cd_typeG , cd_typeH , cd_typeI 
     224      ! =-1 the sign change across the north fold boundary 
     225      REAL(wp)                                      , INTENT(in   ) ::   psgnA 
     226      REAL(wp)                            , OPTIONAL, INTENT(in   ) ::   psgnB , psgnC , psgnD , psgnE 
     227      REAL(wp)                            , OPTIONAL, INTENT(in   ) ::   psgnF , psgnG , psgnH , psgnI 
     228      CHARACTER(len=3)                    , OPTIONAL, INTENT(in   ) ::   cd_mpp   ! fill the overlap area only 
     229      REAL(wp)                            , OPTIONAL, INTENT(in   ) ::   pval     ! background value (used at closed boundaries) 
     230      !! 
     231      !!--------------------------------------------------------------------- 
     232 
     233      !!The first array 
     234      CALL lbc_lnk( pt2dA, cd_typeA, psgnA )  
     235 
     236      !! Look if more arrays to process 
     237      IF(PRESENT (psgnB) )CALL lbc_lnk( pt2dA, cd_typeA, psgnA )  
     238      IF(PRESENT (psgnC) )CALL lbc_lnk( pt2dC, cd_typeC, psgnC )  
     239      IF(PRESENT (psgnD) )CALL lbc_lnk( pt2dD, cd_typeD, psgnD )  
     240      IF(PRESENT (psgnE) )CALL lbc_lnk( pt2dE, cd_typeE, psgnE )  
     241      IF(PRESENT (psgnF) )CALL lbc_lnk( pt2dF, cd_typeF, psgnF )  
     242      IF(PRESENT (psgnG) )CALL lbc_lnk( pt2dG, cd_typeG, psgnG )  
     243      IF(PRESENT (psgnH) )CALL lbc_lnk( pt2dH, cd_typeH, psgnH )  
     244      IF(PRESENT (psgnI) )CALL lbc_lnk( pt2dI, cd_typeI, psgnI )  
     245 
     246   END SUBROUTINE lbc_lnk_2d_9 
     247 
     248 
     249 
     250 
    183251 
    184252#else 
    … …  
    379447      !     
    380448   END SUBROUTINE lbc_lnk_2d 
     449    
     450   SUBROUTINE lbc_lnk_2d_multiple( pt2d_array , type_array , psgn_array , num_fields ) 
     451      !! 
     452      INTEGER :: num_fields 
     453      TYPE( arrayptr ), DIMENSION(:) :: pt2d_array 
     454      CHARACTER(len=1), DIMENSION(:), INTENT(in   ) ::   type_array   ! define the nature of ptab array grid-points 
     455      !                                                               ! = T , U , V , F , W and I points 
     456      REAL(wp)        , DIMENSION(:), INTENT(in   ) ::   psgn_array   ! =-1 the sign change across the north fold boundary 
     457      !                                                               ! =  1. , the sign is kept 
     458      ! 
     459      INTEGER  ::   ii    !!MULTI SEND DUMMY LOOP INDICES 
     460      ! 
     461      DO ii = 1, num_fields 
     462        CALL lbc_lnk_2d( pt2d_array(ii)%pt2d, type_array(ii), psgn_array(ii) ) 
     463      END DO      
     464      ! 
     465   END SUBROUTINE lbc_lnk_2d_multiple 
     466 
     467   SUBROUTINE lbc_lnk_2d_9( pt2dA, cd_typeA, psgnA, pt2dB, cd_typeB, psgnB, pt2dC, cd_typeC, psgnC   & 
     468      &                   , pt2dD, cd_typeD, psgnD, pt2dE, cd_typeE, psgnE, pt2dF, cd_typeF, psgnF   & 
     469      &                   , pt2dG, cd_typeG, psgnG, pt2dH, cd_typeH, psgnH, pt2dI, cd_typeI, psgnI, cd_mpp, pval) 
     470      !!--------------------------------------------------------------------- 
     471      ! Second 2D array on which the boundary condition is applied 
     472      REAL(wp), DIMENSION(jpi,jpj), TARGET          , INTENT(inout) ::   pt2dA 
     473      REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) ::   pt2dB , pt2dC , pt2dD , pt2dE 
     474      REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) ::   pt2dF , pt2dG , pt2dH , pt2dI 
     475      ! define the nature of ptab array grid-points 
     476      CHARACTER(len=1)                              , INTENT(in   ) ::   cd_typeA 
     477      CHARACTER(len=1)                    , OPTIONAL, INTENT(in   ) ::   cd_typeB , cd_typeC , cd_typeD , cd_typeE 
     478      CHARACTER(len=1)                    , OPTIONAL, INTENT(in   ) ::   cd_typeF , cd_typeG , cd_typeH , cd_typeI 
     479      ! =-1 the sign change across the north fold boundary 
     480      REAL(wp)                                      , INTENT(in   ) ::   psgnA 
     481      REAL(wp)                            , OPTIONAL, INTENT(in   ) ::   psgnB , psgnC , psgnD , psgnE 
     482      REAL(wp)                            , OPTIONAL, INTENT(in   ) ::   psgnF , psgnG , psgnH , psgnI 
     483      CHARACTER(len=3)                    , OPTIONAL, INTENT(in   ) ::   cd_mpp   ! fill the overlap area only 
     484      REAL(wp)                            , OPTIONAL, INTENT(in   ) ::   pval     ! background value (used at closed boundaries) 
     485      !! 
     486      !!--------------------------------------------------------------------- 
     487 
     488      !!The first array 
     489      CALL lbc_lnk( pt2dA, cd_typeA, psgnA )  
     490 
     491      !! Look if more arrays to process 
     492      IF(PRESENT (psgnB) )CALL lbc_lnk( pt2dA, cd_typeA, psgnA )  
     493      IF(PRESENT (psgnC) )CALL lbc_lnk( pt2dC, cd_typeC, psgnC )  
     494      IF(PRESENT (psgnD) )CALL lbc_lnk( pt2dD, cd_typeD, psgnD )  
     495      IF(PRESENT (psgnE) )CALL lbc_lnk( pt2dE, cd_typeE, psgnE )  
     496      IF(PRESENT (psgnF) )CALL lbc_lnk( pt2dF, cd_typeF, psgnF )  
     497      IF(PRESENT (psgnG) )CALL lbc_lnk( pt2dG, cd_typeG, psgnG )  
     498      IF(PRESENT (psgnH) )CALL lbc_lnk( pt2dH, cd_typeH, psgnH )  
     499      IF(PRESENT (psgnI) )CALL lbc_lnk( pt2dI, cd_typeI, psgnI )  
     500 
     501   END SUBROUTINE lbc_lnk_2d_9 
     502 
     503   SUBROUTINE lbc_lnk_sum_2d( pt2d, cd_type, psgn, cd_mpp, pval ) 
     504      !!--------------------------------------------------------------------- 
     505      !!                 ***  ROUTINE lbc_lnk_sum_2d  *** 
     506      !! 
     507      !! ** Purpose :   set lateral boundary conditions on a 2D array (non mpp case) 
     508      !! 
     509      !! ** Comments:   compute the sum of the common cell (overlap region) for the ice sheet/ocean  
     510      !!                coupling if conservation option activated. As no ice shelf are present along 
     511      !!                this line, nothing is done along the north fold. 
     512      !!---------------------------------------------------------------------- 
     513      CHARACTER(len=1)            , INTENT(in   )           ::   cd_type   ! nature of pt3d grid-points 
     514      REAL(wp), DIMENSION(jpi,jpj), INTENT(inout)           ::   pt2d      ! 2D array on which the lbc is applied 
     515      REAL(wp)                    , INTENT(in   )           ::   psgn      ! control of the sign  
     516      CHARACTER(len=3)            , INTENT(in   ), OPTIONAL ::   cd_mpp    ! MPP only (here do nothing) 
     517      REAL(wp)                    , INTENT(in   ), OPTIONAL ::   pval      ! background value (for closed boundaries) 
     518      !! 
     519      REAL(wp) ::   zland 
     520      !!---------------------------------------------------------------------- 
     521 
     522      IF( PRESENT( pval ) ) THEN   ;   zland = pval      ! set land value (zero by default) 
     523      ELSE                         ;   zland = 0._wp 
     524      ENDIF 
     525 
     526      IF (PRESENT(cd_mpp)) THEN 
     527         ! only fill the overlap area and extra allows  
     528         ! this is in mpp case. In this module, just do nothing 
     529      ELSE 
     530         !                                     ! East-West boundaries 
     531         !                                     ! ==================== 
     532         SELECT CASE ( nperio ) 
     533         ! 
     534         CASE ( 1 , 4 , 6 )                       !** cyclic east-west 
     535            pt2d(jpim1,:) = pt2d(jpim1,:) + pt2d( 1 ,:) 
     536            pt2d(  2  ,:) = pt2d(  2  ,:) + pt2d(jpi,:) 
     537            pt2d( 1 ,:) = 0.0_wp               ! all points 
     538            pt2d(jpi,:) = 0.0_wp 
     539            ! 
     540         CASE DEFAULT                             !** East closed  --  West closed 
     541            SELECT CASE ( cd_type ) 
     542            CASE ( 'T' , 'U' , 'V' , 'W' )            ! T-, U-, V-, W-points 
     543               pt2d( 1 ,:) = zland 
     544               pt2d(jpi,:) = zland 
     545            CASE ( 'F' )                              ! F-point 
     546               pt2d(jpi,:) = zland 
     547            END SELECT 
     548            ! 
     549         END SELECT 
     550         !                                     ! North-South boundaries 
     551         !                                     ! ====================== 
     552         ! Nothing to do for the north fold, there is no ice shelf along this line. 
     553         ! 
     554      END IF 
     555 
     556   END SUBROUTINE 
     557 
     558   SUBROUTINE lbc_lnk_sum_3d( pt3d, cd_type, psgn, cd_mpp, pval ) 
     559      !!--------------------------------------------------------------------- 
     560      !!                 ***  ROUTINE lbc_lnk_sum_3d  *** 
     561      !! 
     562      !! ** Purpose :   set lateral boundary conditions on a 3D array (non mpp case) 
     563      !! 
     564      !! ** Comments:   compute the sum of the common cell (overlap region) for the ice sheet/ocean  
     565      !!                coupling if conservation option activated. As no ice shelf are present along 
     566      !!                this line, nothing is done along the north fold. 
     567      !!---------------------------------------------------------------------- 
     568      CHARACTER(len=1)                , INTENT(in   )           ::   cd_type   ! nature of pt3d grid-points 
     569      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout)           ::   pt3d      ! 3D array on which the lbc is applied 
     570      REAL(wp)                        , INTENT(in   )           ::   psgn      ! control of the sign  
     571      CHARACTER(len=3)                , INTENT(in   ), OPTIONAL ::   cd_mpp    ! MPP only (here do nothing) 
     572      REAL(wp)                        , INTENT(in   ), OPTIONAL ::   pval      ! background value (for closed boundaries) 
     573      !! 
     574      REAL(wp) ::   zland 
     575      !!---------------------------------------------------------------------- 
     576 
     577      IF( PRESENT( pval ) ) THEN   ;   zland = pval      ! set land value (zero by default) 
     578      ELSE                         ;   zland = 0._wp 
     579      ENDIF 
     580 
     581 
     582      IF( PRESENT( cd_mpp ) ) THEN 
     583         ! only fill the overlap area and extra allows  
     584         ! this is in mpp case. In this module, just do nothing 
     585      ELSE 
     586         !                                     !  East-West boundaries 
     587         !                                     ! ====================== 
     588         SELECT CASE ( nperio ) 
     589         ! 
     590         CASE ( 1 , 4 , 6 )                       !**  cyclic east-west 
     591            pt3d(jpim1,:,:) = pt3d(jpim1,:,:) + pt3d( 1 ,:,:) 
     592            pt3d(  2  ,:,:) = pt3d(  2  ,:,:) + pt3d(jpi,:,:)  
     593            pt3d( 1 ,:,:) = 0.0_wp            ! all points 
     594            pt3d(jpi,:,:) = 0.0_wp 
     595            ! 
     596         CASE DEFAULT                             !**  East closed  --  West closed 
     597            SELECT CASE ( cd_type ) 
     598            CASE ( 'T' , 'U' , 'V' , 'W' )             ! T-, U-, V-, W-points 
     599               pt3d( 1 ,:,:) = zland 
     600               pt3d(jpi,:,:) = zland 
     601            CASE ( 'F' )                               ! F-point 
     602               pt3d(jpi,:,:) = zland 
     603            END SELECT 
     604            ! 
     605         END SELECT 
     606         !                                     ! North-South boundaries 
     607         !                                     ! ====================== 
     608         ! Nothing to do for the north fold, there is no ice shelf along this line. 
     609         ! 
     610      END IF 
     611   END SUBROUTINE 
     612 
    381613 
    382614#endif 
    … …  
    448680   !!====================================================================== 
    449681END MODULE lbclnk 
     682 

  • branches/2016/dev_CNRS_2016/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90

    r6140 r7278  
    2424   !!            3.5  !  2013  ( C. Ethe, G. Madec ) message passing arrays as local variables  
    2525   !!            3.5  !  2013  (S.Mocavero, I.Epicoco - CMCC) north fold optimizations 
     26   !!            3.6  !  2015 (O. Tintó and M. Castrillo - BSC) Added 'mpp_lnk_2d_multiple', 'mpp_lbc_north_2d_multiple', 'mpp_max_multiple'  
    2627   !!---------------------------------------------------------------------- 
    2728 
    … …  
    6263   USE lbcnfd         ! north fold treatment 
    6364   USE in_out_manager ! I/O manager 
     65   USE wrk_nemo       ! work arrays 
    6466 
    6567   IMPLICIT NONE 
    … …  
    7072   PUBLIC   mpp_ini_north, mpp_lbc_north, mpp_lbc_north_e 
    7173   PUBLIC   mpp_min, mpp_max, mpp_sum, mpp_minloc, mpp_maxloc 
     74   PUBLIC   mpp_max_multiple 
    7275   PUBLIC   mpp_lnk_3d, mpp_lnk_3d_gather, mpp_lnk_2d, mpp_lnk_2d_e 
    73    PUBLIC   mpp_lnk_2d_9  
     76   PUBLIC   mpp_lnk_2d_9 , mpp_lnk_2d_multiple  
    7477   PUBLIC   mpp_lnk_sum_3d, mpp_lnk_sum_2d 
    7578   PUBLIC   mppscatter, mppgather 
    … …  
    7982   PUBLIC   mpp_lnk_bdy_2d, mpp_lnk_bdy_3d 
    8083   PUBLIC   mpp_lbc_north_icb, mpp_lnk_2d_icb 
     84   PUBLIC   mpprank 
    8185 
    8286   TYPE arrayptr 
    8387      REAL , DIMENSION (:,:),  POINTER :: pt2d 
    8488   END TYPE arrayptr 
     89   PUBLIC   arrayptr 
    8590    
    8691   !! * Interfaces 
    … …  
    106111   INTERFACE mpp_maxloc 
    107112      MODULE PROCEDURE mpp_maxloc2d ,mpp_maxloc3d 
     113   END INTERFACE 
     114 
     115   INTERFACE mpp_max_multiple 
     116      MODULE PROCEDURE mppmax_real_multiple 
    108117   END INTERFACE 
    109118 
    … …  
    726735      ! ----------------------- 
    727736      ! 
    728       DO ii = 1 , num_fields 
    729737         !First Array 
    730          IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN 
    731             ! 
    732             SELECT CASE ( jpni ) 
    733             CASE ( 1 )     ;   CALL lbc_nfd      ( pt2d_array(ii)%pt2d( : , : ), type_array(ii) , psgn_array(ii) )   ! only 1 northern proc, no mpp 
    734             CASE DEFAULT   ;   CALL mpp_lbc_north( pt2d_array(ii)%pt2d( : , : ), type_array(ii), psgn_array(ii) )   ! for all northern procs. 
    735             END SELECT 
    736             ! 
    737          ENDIF 
    738          ! 
    739       END DO 
     738      IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN 
     739         ! 
     740         SELECT CASE ( jpni ) 
     741         CASE ( 1 )     ;    
     742             DO ii = 1 , num_fields   
     743                       CALL lbc_nfd      ( pt2d_array(ii)%pt2d( : , : ), type_array(ii) , psgn_array(ii) )   ! only 1 northern proc, no mpp 
     744             END DO 
     745         CASE DEFAULT   ;   CALL mpp_lbc_north_2d_multiple( pt2d_array, type_array, psgn_array, num_fields )   ! for all northern procs. 
     746         END SELECT 
     747         ! 
     748      ENDIF 
     749        ! 
    740750      ! 
    741751      DEALLOCATE( zt2ns, zt2sn, zt2ew, zt2we ) 
    … …  
    20192029   END SUBROUTINE mppmax_real 
    20202030 
     2031   SUBROUTINE mppmax_real_multiple( ptab, NUM , kcom  ) 
     2032      !!---------------------------------------------------------------------- 
     2033      !!                  ***  routine mppmax_real  *** 
     2034      !! 
     2035      !! ** Purpose :   Maximum 
     2036      !! 
     2037      !!---------------------------------------------------------------------- 
     2038      REAL(wp), DIMENSION(:) ,  INTENT(inout)           ::   ptab   ! ??? 
     2039      INTEGER , INTENT(in   )           ::   NUM 
     2040      INTEGER , INTENT(in   ), OPTIONAL ::   kcom   ! ??? 
     2041      !! 
     2042      INTEGER  ::   ierror, localcomm 
     2043      REAL(wp) , POINTER , DIMENSION(:) ::   zwork 
     2044      !!---------------------------------------------------------------------- 
     2045      ! 
     2046      CALL wrk_alloc(NUM , zwork) 
     2047      localcomm = mpi_comm_opa 
     2048      IF( PRESENT(kcom) )   localcomm = kcom 
     2049      ! 
     2050      CALL mpi_allreduce( ptab, zwork, NUM, mpi_double_precision, mpi_max, localcomm, ierror ) 
     2051      ptab = zwork 
     2052      CALL wrk_dealloc(NUM , zwork) 
     2053      ! 
     2054   END SUBROUTINE mppmax_real_multiple 
     2055 
    20212056 
    20222057   SUBROUTINE mppmin_a_real( ptab, kdim, kcom ) 
    … …  
    29122947   END SUBROUTINE mpp_lbc_north_2d 
    29132948 
     2949   SUBROUTINE mpp_lbc_north_2d_multiple( pt2d_array, cd_type, psgn, num_fields) 
     2950      !!--------------------------------------------------------------------- 
     2951      !!                   ***  routine mpp_lbc_north_2d  *** 
     2952      !! 
     2953      !! ** Purpose :   Ensure proper north fold horizontal bondary condition 
     2954      !!              in mpp configuration in case of jpn1 > 1 
     2955      !!              (for multiple 2d arrays ) 
     2956      !! 
     2957      !! ** Method  :   North fold condition and mpp with more than one proc 
     2958      !!              in i-direction require a specific treatment. We gather 
     2959      !!              the 4 northern lines of the global domain on 1 processor 
     2960      !!              and apply lbc north-fold on this sub array. Then we 
     2961      !!              scatter the north fold array back to the processors. 
     2962      !! 
     2963      !!---------------------------------------------------------------------- 
     2964      INTEGER ,  INTENT (in   ) ::   num_fields  ! number of variables contained in pt2d 
     2965      TYPE( arrayptr ), DIMENSION(:) :: pt2d_array 
     2966      CHARACTER(len=1), DIMENSION(:), INTENT(in   ) ::   cd_type   ! nature of pt2d grid-points 
     2967      !                                                          !   = T ,  U , V , F or W  gridpoints 
     2968      REAL(wp), DIMENSION(:), INTENT(in   ) ::   psgn      ! = -1. the sign change across the north fold  
     2969      !!                                                             ! =  1. , the sign is kept 
     2970      INTEGER ::   ji, jj, jr, jk 
     2971      INTEGER ::   ierr, itaille, ildi, ilei, iilb 
     2972      INTEGER ::   ijpj, ijpjm1, ij, iproc 
     2973      INTEGER, DIMENSION (jpmaxngh)      ::   ml_req_nf          !for mpi_isend when avoiding mpi_allgather 
     2974      INTEGER                            ::   ml_err             ! for mpi_isend when avoiding mpi_allgather 
     2975      INTEGER, DIMENSION(MPI_STATUS_SIZE)::   ml_stat            ! for mpi_isend when avoiding mpi_allgather 
     2976      !                                                              ! Workspace for message transfers avoiding mpi_allgather 
     2977      REAL(wp), DIMENSION(:,:,:)  , ALLOCATABLE   :: ztab 
     2978      REAL(wp), DIMENSION(:,:,:)  , ALLOCATABLE   :: znorthloc, zfoldwk 
     2979      REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE   :: znorthgloio 
     2980      REAL(wp), DIMENSION(:,:,:)  , ALLOCATABLE   :: ztabl, ztabr 
     2981      INTEGER :: istatus(mpi_status_size) 
     2982      INTEGER :: iflag 
     2983      !!---------------------------------------------------------------------- 
     2984      ! 
     2985      ALLOCATE( ztab(jpiglo,4,num_fields), znorthloc(jpi,4,num_fields), zfoldwk(jpi,4,num_fields), znorthgloio(jpi,4,num_fields,jpni) )   ! expanded to 3 dimensions 
     2986      ALLOCATE( ztabl(jpi,4,num_fields), ztabr(jpi*jpmaxngh, 4,num_fields) ) 
     2987      ! 
     2988      ijpj   = 4 
     2989      ijpjm1 = 3 
     2990      ! 
     2991       
     2992      DO jk = 1, num_fields 
     2993         DO jj = nlcj-ijpj+1, nlcj             ! put in znorthloc the last 4 jlines of pt2d (for every variable) 
     2994            ij = jj - nlcj + ijpj 
     2995            znorthloc(:,ij,jk) = pt2d_array(jk)%pt2d(:,jj) 
     2996         END DO 
     2997      END DO 
     2998      !                                     ! Build in procs of ncomm_north the znorthgloio 
     2999      itaille = jpi * ijpj 
     3000                                                                   
     3001      IF ( l_north_nogather ) THEN 
     3002         ! 
     3003         ! Avoid the use of mpi_allgather by exchanging only with the processes already identified  
     3004         ! (in nemo_northcomms) as being  involved in this process' northern boundary exchange 
     3005         ! 
     3006         ztabr(:,:,:) = 0 
     3007         ztabl(:,:,:) = 0 
     3008 
     3009         DO jk = 1, num_fields 
     3010            DO jj = nlcj-ijpj+1, nlcj          ! First put local values into the global array 
     3011               ij = jj - nlcj + ijpj 
     3012               DO ji = nfsloop, nfeloop 
     3013                  ztabl(ji,ij,jk) = pt2d_array(jk)%pt2d(ji,jj) 
     3014               END DO 
     3015            END DO 
     3016         END DO 
     3017 
     3018         DO jr = 1,nsndto 
     3019            IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN 
     3020               CALL mppsend(5, znorthloc, itaille*num_fields, nfipproc(isendto(jr),jpnj), ml_req_nf(jr)) ! Buffer expanded "num_fields" times 
     3021            ENDIF 
     3022         END DO 
     3023         DO jr = 1,nsndto 
     3024            iproc = nfipproc(isendto(jr),jpnj) 
     3025            IF(iproc .ne. -1) THEN 
     3026               ilei = nleit (iproc+1) 
     3027               ildi = nldit (iproc+1) 
     3028               iilb = nfiimpp(isendto(jr),jpnj) - nfiimpp(isendto(1),jpnj) 
     3029            ENDIF 
     3030            IF((iproc .ne. (narea-1)) .and. (iproc .ne. -1)) THEN 
     3031              CALL mpprecv(5, zfoldwk, itaille*num_fields, iproc) ! Buffer expanded "num_fields" times 
     3032              DO jk = 1 , num_fields 
     3033                 DO jj = 1, ijpj 
     3034                    DO ji = ildi, ilei 
     3035                       ztabr(iilb+ji,jj,jk) = zfoldwk(ji,jj,jk)       ! Modified to 3D 
     3036                    END DO 
     3037                 END DO 
     3038              END DO 
     3039            ELSE IF (iproc .eq. (narea-1)) THEN 
     3040              DO jk = 1, num_fields 
     3041                 DO jj = 1, ijpj 
     3042                    DO ji = ildi, ilei 
     3043                          ztabr(iilb+ji,jj,jk) = pt2d_array(jk)%pt2d(ji,nlcj-ijpj+jj)       ! Modified to 3D 
     3044                    END DO 
     3045                 END DO 
     3046              END DO 
     3047            ENDIF 
     3048         END DO 
     3049         IF (l_isend) THEN 
     3050            DO jr = 1,nsndto 
     3051               IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN 
     3052                  CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err) 
     3053               ENDIF 
     3054            END DO 
     3055         ENDIF 
     3056         ! 
     3057         DO ji = 1, num_fields     ! Loop to manage 3D variables 
     3058            CALL mpp_lbc_nfd( ztabl(:,:,ji), ztabr(:,:,ji), cd_type(ji), psgn(ji) )  ! North fold boundary condition 
     3059         END DO 
     3060         ! 
     3061         DO jk = 1, num_fields 
     3062            DO jj = nlcj-ijpj+1, nlcj             ! Scatter back to pt2d 
     3063               ij = jj - nlcj + ijpj 
     3064               DO ji = 1, nlci 
     3065                  pt2d_array(jk)%pt2d(ji,jj) = ztabl(ji,ij,jk)       ! Modified to 3D 
     3066               END DO 
     3067            END DO 
     3068         END DO 
     3069          
     3070         ! 
     3071      ELSE 
     3072         ! 
     3073         CALL MPI_ALLGATHER( znorthloc  , itaille*num_fields, MPI_DOUBLE_PRECISION,        & 
     3074            &                znorthgloio, itaille*num_fields, MPI_DOUBLE_PRECISION, ncomm_north, ierr ) 
     3075         ! 
     3076         ztab(:,:,:) = 0.e0 
     3077         DO jk = 1, num_fields 
     3078            DO jr = 1, ndim_rank_north            ! recover the global north array 
     3079               iproc = nrank_north(jr) + 1 
     3080               ildi = nldit (iproc) 
     3081               ilei = nleit (iproc) 
     3082               iilb = nimppt(iproc) 
     3083               DO jj = 1, ijpj 
     3084                  DO ji = ildi, ilei 
     3085                     ztab(ji+iilb-1,jj,jk) = znorthgloio(ji,jj,jk,jr) 
     3086                  END DO 
     3087               END DO 
     3088            END DO 
     3089         END DO 
     3090          
     3091         DO ji = 1, num_fields 
     3092            CALL lbc_nfd( ztab(:,:,ji), cd_type(ji), psgn(ji) )   ! North fold boundary condition 
     3093         END DO 
     3094         ! 
     3095         DO jk = 1, num_fields 
     3096            DO jj = nlcj-ijpj+1, nlcj             ! Scatter back to pt2d 
     3097               ij = jj - nlcj + ijpj 
     3098               DO ji = 1, nlci 
     3099                  pt2d_array(jk)%pt2d(ji,jj) = ztab(ji+nimpp-1,ij,jk) 
     3100               END DO 
     3101            END DO 
     3102         END DO 
     3103         ! 
     3104         ! 
     3105      ENDIF 
     3106      DEALLOCATE( ztab, znorthloc, zfoldwk, znorthgloio ) 
     3107      DEALLOCATE( ztabl, ztabr ) 
     3108      ! 
     3109   END SUBROUTINE mpp_lbc_north_2d_multiple 
    29143110 
    29153111   SUBROUTINE mpp_lbc_north_e( pt2d, cd_type, psgn) 

  • branches/2016/dev_CNRS_2016/NEMOGCM/NEMO/OPA_SRC/LBC/mppini.F90

    r6140 r7278  
    198198       
    199199#endif 
    200       IF(lwp) THEN 
    201          WRITE(numout,*) 
    202          WRITE(numout,*) '           defines mpp subdomains' 
    203          WRITE(numout,*) '           ----------------------' 
    204          WRITE(numout,*) '           iresti=',iresti,' irestj=',irestj 
    205          WRITE(numout,*) '           jpni  =',jpni  ,' jpnj  =',jpnj 
    206          ifreq = 4 
    207          il1   = 1 
    208          DO jn = 1, (jpni-1)/ifreq+1 
    209             il2 = MIN( jpni, il1+ifreq-1 ) 
    210             WRITE(numout,*) 
    211             WRITE(numout,9200) ('***',ji = il1,il2-1) 
    212             DO jj = jpnj, 1, -1 
    213                WRITE(numout,9203) ('   ',ji = il1,il2-1) 
    214                WRITE(numout,9202) jj, ( ilcit(ji,jj),ilcjt(ji,jj),ji = il1,il2 ) 
    215                WRITE(numout,9203) ('   ',ji = il1,il2-1) 
    216                WRITE(numout,9200) ('***',ji = il1,il2-1) 
    217             END DO 
    218             WRITE(numout,9201) (ji,ji = il1,il2) 
    219             il1 = il1+ifreq 
    220          END DO 
    221  9200    FORMAT('     ***',20('*************',a3)) 
    222  9203    FORMAT('     *     ',20('         *   ',a3)) 
    223  9201    FORMAT('        ',20('   ',i3,'          ')) 
    224  9202    FORMAT(' ',i3,' *  ',20(i3,'  x',i3,'   *   ')) 
    225       ENDIF 
    226  
    227       zidom = nreci 
    228       DO ji = 1, jpni 
    229          zidom = zidom + ilcit(ji,1) - nreci 
    230       END DO 
    231       IF(lwp) WRITE(numout,*) 
    232       IF(lwp) WRITE(numout,*)' sum ilcit(i,1) = ', zidom, ' jpiglo = ', jpiglo 
    233        
    234       zjdom = nrecj 
    235       DO jj = 1, jpnj 
    236          zjdom = zjdom + ilcjt(1,jj) - nrecj 
    237       END DO 
    238       IF(lwp) WRITE(numout,*)' sum ilcit(1,j) = ', zjdom, ' jpjglo = ', jpjglo 
    239       IF(lwp) WRITE(numout,*) 
    240        
    241200 
    242201      !  2. Index arrays for subdomains 
    … …  
    301260         nlejt(jn) = nlej 
    302261      END DO 
    303        
    304  
    305       ! 4. From global to local 
     262 
     263      ! 4. Subdomain print 
     264      ! ------------------ 
     265       
     266      IF(lwp) WRITE(numout,*) 
     267      IF(lwp) WRITE(numout,*) ' mpp_init: defines mpp subdomains' 
     268      IF(lwp) WRITE(numout,*) ' ~~~~~~  ----------------------' 
     269      IF(lwp) WRITE(numout,*) 
     270      IF(lwp) WRITE(numout,*) 'iresti=',iresti,' irestj=',irestj 
     271      IF(lwp) WRITE(numout,*) 
     272      IF(lwp) WRITE(numout,*) 'jpni=',jpni,' jpnj=',jpnj 
     273      zidom = nreci 
     274      DO ji = 1, jpni 
     275         zidom = zidom + ilcit(ji,1) - nreci 
     276      END DO 
     277      IF(lwp) WRITE(numout,*) 
     278      IF(lwp) WRITE(numout,*)' sum ilcit(i,1)=', zidom, ' jpiglo=', jpiglo 
     279 
     280      zjdom = nrecj 
     281      DO jj = 1, jpnj 
     282         zjdom = zjdom + ilcjt(1,jj) - nrecj 
     283      END DO 
     284      IF(lwp) WRITE(numout,*)' sum ilcit(1,j)=', zjdom, ' jpjglo=', jpjglo 
     285      IF(lwp) WRITE(numout,*) 
     286 
     287      IF(lwp) THEN 
     288         ifreq = 4 
     289         il1   = 1 
     290         DO jn = 1, (jpni-1)/ifreq+1 
     291            il2 = MIN( jpni, il1+ifreq-1 ) 
     292            WRITE(numout,*) 
     293            WRITE(numout,9200) ('***',ji = il1,il2-1) 
     294            DO jj = jpnj, 1, -1 
     295               WRITE(numout,9203) ('   ',ji = il1,il2-1) 
     296               WRITE(numout,9202) jj, ( ilcit(ji,jj),ilcjt(ji,jj),ji = il1,il2 ) 
     297               WRITE(numout,9204) (nfipproc(ji,jj),ji=il1,il2) 
     298               WRITE(numout,9203) ('   ',ji = il1,il2-1) 
     299               WRITE(numout,9200) ('***',ji = il1,il2-1) 
     300            END DO 
     301            WRITE(numout,9201) (ji,ji = il1,il2) 
     302            il1 = il1+ifreq 
     303         END DO 
     304 9200     FORMAT('     ***',20('*************',a3)) 
     305 9203     FORMAT('     *     ',20('         *   ',a3)) 
     306 9201     FORMAT('        ',20('   ',i3,'          ')) 
     307 9202     FORMAT(' ',i3,' *  ',20(i3,'  x',i3,'   *   ')) 
     308 9204     FORMAT('     *  ',20('      ',i3,'   *   ')) 
     309      ENDIF 
     310 
     311      ! 5. From global to local 
    306312      ! ----------------------- 
    307313 
    … …  
    310316 
    311317 
    312       ! 5. Subdomain neighbours 
     318      ! 6. Subdomain neighbours 
    313319      ! ---------------------- 
    314320 
    … …  
    433439         WRITE(numout,*) ' nimpp  = ', nimpp 
    434440         WRITE(numout,*) ' njmpp  = ', njmpp 
    435          WRITE(numout,*) ' nbse   = ', nbse  , ' npse   = ', npse 
    436          WRITE(numout,*) ' nbsw   = ', nbsw  , ' npsw   = ', npsw 
    437          WRITE(numout,*) ' nbne   = ', nbne  , ' npne   = ', npne 
    438          WRITE(numout,*) ' nbnw   = ', nbnw  , ' npnw   = ', npnw 
     441         WRITE(numout,*) ' nreci  = ', nreci  , ' npse   = ', npse 
     442         WRITE(numout,*) ' nrecj  = ', nrecj  , ' npsw   = ', npsw 
     443         WRITE(numout,*) ' jpreci = ', jpreci , ' npne   = ', npne 
     444         WRITE(numout,*) ' jprecj = ', jprecj , ' npnw   = ', npnw 
     445         WRITE(numout,*) 
    439446      ENDIF 
    440447 
    … …  
    443450      ! Prepare mpp north fold 
    444451 
    445       IF (jperio >= 3 .AND. jperio <= 6 .AND. jpni > 1 ) THEN 
     452      IF( jperio >= 3 .AND. jperio <= 6 .AND. jpni > 1 ) THEN 
    446453         CALL mpp_ini_north 
    447       END IF 
     454         IF(lwp) WRITE(numout,*) ' mpp_init : North fold boundary prepared for jpni >1' 
     455      ENDIF 
    448456 
    449457      ! Prepare NetCDF output file (if necessary) 

  • branches/2016/dev_CNRS_2016/NEMOGCM/NEMO/OPA_SRC/LBC/mppini_2.h90

    r7277 r7278  
    276276         ENDIF 
    277277 
     278         ! Check wet points over the entire domain to preserve the MPI communication stencil 
    278279         isurf = 0 
    279          DO jj = 1+jprecj, ilj-jprecj 
    280             DO  ji = 1+jpreci, ili-jpreci 
     280         DO jj = 1, ilj 
     281            DO  ji = 1, ili 
    281282               IF( imask(ji+iimppt(ii,ij)-1, jj+ijmppt(ii,ij)-1) == 1)   isurf = isurf+1 
    282283            END DO 
    283284         END DO 
     285 
    284286         IF(isurf /= 0) THEN 
    285287            icont = icont + 1 
    … …  
    291293 
    292294      nfipproc(:,:) = ipproc(:,:) 
    293  
    294295 
    295296      ! Control 
    … …  
    399400      ii = iin(narea) 
    400401      ij = ijn(narea) 
     402 
     403      ! set default neighbours 
     404      noso = ioso(ii,ij) 
     405      nowe = iowe(ii,ij) 
     406      noea = ioea(ii,ij) 
     407      nono = iono(ii,ij)  
     408      npse = iose(ii,ij) 
     409      npsw = iosw(ii,ij) 
     410      npne = ione(ii,ij) 
     411      npnw = ionw(ii,ij) 
     412 
     413      ! check neighbours location 
    401414      IF( ioso(ii,ij) >= 0 .AND. ioso(ii,ij) <= (jpni*jpnj-1) ) THEN  
    402415         iiso = 1 + MOD(ioso(ii,ij),jpni) 
    … …  
    469482      IF (lwp) THEN 
    470483         CALL ctl_opn( inum, 'layout.dat', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE., narea ) 
     484         WRITE(inum,'(a)') '   jpnij     jpi     jpj     jpk  jpiglo  jpjglo' 
    471485         WRITE(inum,'(6i8)') jpnij,jpi,jpj,jpk,jpiglo,jpjglo 
    472486         WRITE(inum,'(a)') 'NAREA nlci nlcj nldi nldj nlei nlej nimpp njmpp' 
    … …  
    481495      END IF 
    482496 
    483       IF( nperio == 1 .AND.jpni /= 1 ) CALL ctl_stop( ' mpp_init2:  error on cyclicity' ) 
    484  
    485       ! Prepare mpp north fold 
    486  
    487       IF( jperio >= 3 .AND. jperio <= 6 .AND. jpni > 1 ) THEN 
    488          CALL mpp_ini_north 
    489          IF(lwp) WRITE(numout,*) ' mpp_init2 : North fold boundary prepared for jpni >1' 
    490       ENDIF 
    491  
    492497      ! Defined npolj, either 0, 3 , 4 , 5 , 6 
    493498      ! In this case the important thing is that npolj /= 0 
    … …  
    506511      ENDIF 
    507512 
     513      ! Periodicity : no corner if nbondi = 2 and nperio != 1 
     514 
     515      IF(lwp) THEN 
     516         WRITE(numout,*) ' nproc  = ', nproc 
     517         WRITE(numout,*) ' nowe   = ', nowe  , ' noea   =  ', noea 
     518         WRITE(numout,*) ' nono   = ', nono  , ' noso   =  ', noso 
     519         WRITE(numout,*) ' nbondi = ', nbondi 
     520         WRITE(numout,*) ' nbondj = ', nbondj 
     521         WRITE(numout,*) ' npolj  = ', npolj 
     522         WRITE(numout,*) ' nperio = ', nperio 
     523         WRITE(numout,*) ' nlci   = ', nlci 
     524         WRITE(numout,*) ' nlcj   = ', nlcj 
     525         WRITE(numout,*) ' nimpp  = ', nimpp 
     526         WRITE(numout,*) ' njmpp  = ', njmpp 
     527         WRITE(numout,*) ' nreci  = ', nreci  , ' npse   = ', npse 
     528         WRITE(numout,*) ' nrecj  = ', nrecj  , ' npsw   = ', npsw 
     529         WRITE(numout,*) ' jpreci = ', jpreci , ' npne   = ', npne 
     530         WRITE(numout,*) ' jprecj = ', jprecj , ' npnw   = ', npnw 
     531         WRITE(numout,*) 
     532      ENDIF 
     533 
     534      IF( nperio == 1 .AND. jpni /= 1 ) CALL ctl_stop( ' mpp_init2: error on cyclicity' ) 
     535 
     536      ! Prepare mpp north fold 
     537 
     538      IF( jperio >= 3 .AND. jperio <= 6 .AND. jpni > 1 ) THEN 
     539         CALL mpp_ini_north 
     540         IF(lwp) WRITE(numout,*) ' mpp_init2 : North fold boundary prepared for jpni >1' 
     541      ENDIF 
     542 
    508543      ! Prepare NetCDF output file (if necessary) 
    509544      CALL mpp_init_ioipsl 
    510545 
    511       ! Periodicity : no corner if nbondi = 2 and nperio != 1 
    512  
    513       IF(lwp) THEN 
    514          WRITE(numout,*) ' nproc=  ',nproc 
    515          WRITE(numout,*) ' nowe=   ',nowe 
    516          WRITE(numout,*) ' noea=   ',noea 
    517          WRITE(numout,*) ' nono=   ',nono 
    518          WRITE(numout,*) ' noso=   ',noso 
    519          WRITE(numout,*) ' nbondi= ',nbondi 
    520          WRITE(numout,*) ' nbondj= ',nbondj 
    521          WRITE(numout,*) ' npolj=  ',npolj 
    522          WRITE(numout,*) ' nperio= ',nperio 
    523          WRITE(numout,*) ' nlci=   ',nlci 
    524          WRITE(numout,*) ' nlcj=   ',nlcj 
    525          WRITE(numout,*) ' nimpp=  ',nimpp 
    526          WRITE(numout,*) ' njmpp=  ',njmpp 
    527          WRITE(numout,*) ' nbse=   ',nbse,' npse= ',npse 
    528          WRITE(numout,*) ' nbsw=   ',nbsw,' npsw= ',npsw 
    529          WRITE(numout,*) ' nbne=   ',nbne,' npne= ',npne 
    530          WRITE(numout,*) ' nbnw=   ',nbnw,' npnw= ',npnw 
    531       ENDIF 
    532546 
    533547   END SUBROUTINE mpp_init2 

  • branches/2016/dev_CNRS_2016/NEMOGCM/NEMO/OPA_SRC/SBC/albedo.F90

    r4624 r7278  
    99   !!             -   ! 2001-06  (M. Vancoppenolle) LIM 3.0 
    1010   !!             -   ! 2006-08  (G. Madec)  cleaning for surface module 
     11   !!            3.6  ! 2016-01  (C. Rousset) new parameterization for sea ice albedo 
    1112   !!---------------------------------------------------------------------- 
    1213 
    … …  
    2930 
    3031   INTEGER  ::   albd_init = 0      !: control flag for initialization 
    31    REAL(wp) ::   zzero     = 0.e0   ! constant values 
    32    REAL(wp) ::   zone      = 1.e0   !    "       " 
    33  
    34    REAL(wp) ::   c1     = 0.05    ! constants values 
    35    REAL(wp) ::   c2     = 0.10    !    "        " 
    36    REAL(wp) ::   rmue   = 0.40    !  cosine of local solar altitude 
    37  
     32   
     33   REAL(wp) ::   rmue     = 0.40    !  cosine of local solar altitude 
     34   REAL(wp) ::   ralb_oce = 0.066   ! ocean or lead albedo (Pegau and Paulson, Ann. Glac. 2001) 
     35   REAL(wp) ::   c1       = 0.05    ! snow thickness (only for nn_ice_alb=0) 
     36   REAL(wp) ::   c2       = 0.10    !  "        " 
     37   REAL(wp) ::   rcloud   = 0.06    ! cloud effect on albedo (only-for nn_ice_alb=0) 
     38  
    3839   !                             !!* namelist namsbc_alb 
    39    REAL(wp) ::   rn_cloud         !  cloudiness effect on snow or ice albedo (Grenfell & Perovich, 1984) 
    40 #if defined key_lim3 
    41    REAL(wp) ::   rn_albice        !  albedo of melting ice in the arctic and antarctic (Shine & Hendersson-Sellers) 
    42 #else 
    43    REAL(wp) ::   rn_albice        !  albedo of melting ice in the arctic and antarctic (Shine & Hendersson-Sellers) 
    44 #endif 
    45    REAL(wp) ::   rn_alphd         !  coefficients for linear interpolation used to compute 
    46    REAL(wp) ::   rn_alphdi        !  albedo between two extremes values (Pyane, 1972) 
    47    REAL(wp) ::   rn_alphc         !  
     40   INTEGER  ::   nn_ice_alb 
     41   REAL(wp) ::   rn_albice 
    4842 
    4943   !!---------------------------------------------------------------------- 
    … …  
    5953      !!           
    6054      !! ** Purpose :   Computation of the albedo of the snow/ice system  
    61       !!                as well as the ocean one 
    6255      !!        
    63       !! ** Method  : - Computation of the albedo of snow or ice (choose the  
    64       !!                rignt one by a large number of tests 
    65       !!              - Computation of the albedo of the ocean 
    66       !! 
    67       !! References :   Shine and Hendersson-Sellers 1985, JGR, 90(D1), 2243-2250. 
     56      !! ** Method  :   Two schemes are available (from namelist parameter nn_ice_alb) 
     57      !!                  0: the scheme is that of Shine & Henderson-Sellers (JGR 1985) for clear-skies 
     58      !!                  1: the scheme is "home made" (for cloudy skies) and based on Brandt et al. (J. Climate 2005) 
     59      !!                                                                           and Grenfell & Perovich (JGR 2004) 
     60      !!                Description of scheme 1: 
     61      !!                  1) Albedo dependency on ice thickness follows the findings from Brandt et al (2005) 
     62      !!                     which are an update of Allison et al. (JGR 1993) ; Brandt et al. 1999 
     63      !!                     0-5cm  : linear function of ice thickness 
     64      !!                     5-150cm: log    function of ice thickness 
     65      !!                     > 150cm: constant 
     66      !!                  2) Albedo dependency on snow thickness follows the findings from Grenfell & Perovich (2004) 
     67      !!                     i.e. it increases as -EXP(-snw_thick/0.02) during freezing and -EXP(-snw_thick/0.03) during melting 
     68      !!                  3) Albedo dependency on clouds is speculated from measurements of Grenfell and Perovich (2004) 
     69      !!                     i.e. cloudy-clear albedo depend on cloudy albedo following a 2d order polynomial law 
     70      !!                  4) The needed 4 parameters are: dry and melting snow, freezing ice and bare puddled ice 
     71      !! 
     72      !! ** Note    :   The parameterization from Shine & Henderson-Sellers presents several misconstructions: 
     73      !!                  1) ice albedo when ice thick. tends to 0 is different than ocean albedo 
     74      !!                  2) for small ice thick. covered with some snow (<3cm?), albedo is larger  
     75      !!                     under melting conditions than under freezing conditions 
     76      !!                  3) the evolution of ice albedo as a function of ice thickness shows   
     77      !!                     3 sharp inflexion points (at 5cm, 100cm and 150cm) that look highly unrealistic 
     78      !! 
     79      !! References :   Shine & Henderson-Sellers 1985, JGR, 90(D1), 2243-2250. 
     80      !!                Brandt et al. 2005, J. Climate, vol 18 
     81      !!                Grenfell & Perovich 2004, JGR, vol 109  
    6882      !!---------------------------------------------------------------------- 
    6983      REAL(wp), INTENT(in   ), DIMENSION(:,:,:) ::   pt_ice      !  ice surface temperature (Kelvin) 
    … …  
    7387      REAL(wp), INTENT(  out), DIMENSION(:,:,:) ::   pa_ice_os   !  albedo of ice under overcast sky 
    7488      !! 
    75       INTEGER  ::   ji, jj, jl    ! dummy loop indices 
    76       INTEGER  ::   ijpl          ! number of ice categories (3rd dim of ice input arrays) 
    77       REAL(wp) ::   zalbpsnm      ! albedo of ice under clear sky when snow is melting 
    78       REAL(wp) ::   zalbpsnf      ! albedo of ice under clear sky when snow is freezing 
    79       REAL(wp) ::   zalbpsn       ! albedo of snow/ice system when ice is coverd by snow 
    80       REAL(wp) ::   zalbpic       ! albedo of snow/ice system when ice is free of snow 
    81       REAL(wp) ::   zithsn        ! = 1 for hsn >= 0 ( ice is cov. by snow ) ; = 0 otherwise (ice is free of snow) 
    82       REAL(wp) ::   zitmlsn       ! = 1 freezinz snow (pt_ice >=rt0_snow) ; = 0 melting snow (pt_ice<rt0_snow) 
    83       REAL(wp) ::   zihsc1        ! = 1 hsn <= c1 ; = 0 hsn > c1 
    84       REAL(wp) ::   zihsc2        ! = 1 hsn >= c2 ; = 0 hsn < c2 
    85       !! 
    86       REAL(wp), POINTER, DIMENSION(:,:,:) ::   zalbfz    ! = rn_alphdi for freezing ice ; = rn_albice for melting ice 
    87       REAL(wp), POINTER, DIMENSION(:,:,:) ::   zficeth   !  function of ice thickness 
     89      INTEGER  ::   ji, jj, jl         ! dummy loop indices 
     90      INTEGER  ::   ijpl               ! number of ice categories (3rd dim of ice input arrays) 
     91      REAL(wp)            ::   ralb_im, ralb_sf, ralb_sm, ralb_if 
     92      REAL(wp)            ::   zswitch, z1_c1, z1_c2 
     93      REAL(wp)                            ::   zalb_sm, zalb_sf, zalb_st ! albedo of snow melting, freezing, total 
     94      REAL(wp), POINTER, DIMENSION(:,:,:) ::   zalb, zalb_it             ! intermediate variable & albedo of ice (snow free) 
    8895      !!--------------------------------------------------------------------- 
    89        
     96 
    9097      ijpl = SIZE( pt_ice, 3 )                     ! number of ice categories 
    91  
    92       CALL wrk_alloc( jpi,jpj,ijpl, zalbfz, zficeth ) 
     98       
     99      CALL wrk_alloc( jpi,jpj,ijpl, zalb, zalb_it ) 
    93100 
    94101      IF( albd_init == 0 )   CALL albedo_init      ! initialization  
    95102 
    96       !--------------------------- 
    97       !  Computation of  zficeth 
    98       !--------------------------- 
    99       ! ice free of snow and melts 
    100       WHERE     ( ph_snw == 0._wp .AND. pt_ice >= rt0_ice )   ;   zalbfz(:,:,:) = rn_albice 
    101       ELSE WHERE                                              ;   zalbfz(:,:,:) = rn_alphdi 
    102       END  WHERE 
    103  
    104       WHERE     ( 1.5  < ph_ice                     )  ;  zficeth = zalbfz 
    105       ELSE WHERE( 1.0  < ph_ice .AND. ph_ice <= 1.5 )  ;  zficeth = 0.472  + 2.0 * ( zalbfz - 0.472 ) * ( ph_ice - 1.0 ) 
    106       ELSE WHERE( 0.05 < ph_ice .AND. ph_ice <= 1.0 )  ;  zficeth = 0.2467 + 0.7049 * ph_ice              & 
    107          &                                                                 - 0.8608 * ph_ice * ph_ice     & 
    108          &                                                                 + 0.3812 * ph_ice * ph_ice * ph_ice 
    109       ELSE WHERE                                       ;  zficeth = 0.1    + 3.6    * ph_ice 
    110       END WHERE 
    111  
    112 !!gm old code 
    113 !      DO jl = 1, ijpl 
    114 !         DO jj = 1, jpj 
    115 !            DO ji = 1, jpi 
    116 !               IF( ph_ice(ji,jj,jl) > 1.5 ) THEN 
    117 !                  zficeth(ji,jj,jl) = zalbfz(ji,jj,jl) 
    118 !               ELSEIF( ph_ice(ji,jj,jl) > 1.0  .AND. ph_ice(ji,jj,jl) <= 1.5 ) THEN 
    119 !                  zficeth(ji,jj,jl) = 0.472 + 2.0 * ( zalbfz(ji,jj,jl) - 0.472 ) * ( ph_ice(ji,jj,jl) - 1.0 ) 
    120 !               ELSEIF( ph_ice(ji,jj,jl) > 0.05 .AND. ph_ice(ji,jj,jl) <= 1.0 ) THEN 
    121 !                  zficeth(ji,jj,jl) = 0.2467 + 0.7049 * ph_ice(ji,jj,jl)                               & 
    122 !                     &                    - 0.8608 * ph_ice(ji,jj,jl) * ph_ice(ji,jj,jl)                 & 
    123 !                     &                    + 0.3812 * ph_ice(ji,jj,jl) * ph_ice(ji,jj,jl) * ph_ice (ji,jj,jl) 
    124 !               ELSE 
    125 !                  zficeth(ji,jj,jl) = 0.1 + 3.6 * ph_ice(ji,jj,jl)  
    126 !               ENDIF 
    127 !            END DO 
    128 !         END DO 
    129 !      END DO 
    130 !!gm end old code 
    131        
    132       !-----------------------------------------------  
    133       !    Computation of the snow/ice albedo system  
    134       !-------------------------- --------------------- 
    135        
    136       !    Albedo of snow-ice for clear sky. 
    137       !-----------------------------------------------     
    138       DO jl = 1, ijpl 
    139          DO jj = 1, jpj 
    140             DO ji = 1, jpi 
    141                !  Case of ice covered by snow.              
    142                !                                        !  freezing snow         
    143                zihsc1   = 1.0 - MAX( zzero , SIGN( zone , - ( ph_snw(ji,jj,jl) - c1 ) ) ) 
    144                zalbpsnf = ( 1.0 - zihsc1 ) * (  zficeth(ji,jj,jl)                                             & 
    145                   &                           + ph_snw(ji,jj,jl) * ( rn_alphd - zficeth(ji,jj,jl) ) / c1  )   & 
    146                   &     +         zihsc1   * rn_alphd   
    147                !                                        !  melting snow                 
    148                zihsc2   = MAX( zzero , SIGN( zone , ph_snw(ji,jj,jl) - c2 ) ) 
    149                zalbpsnm = ( 1.0 - zihsc2 ) * ( rn_albice + ph_snw(ji,jj,jl) * ( rn_alphc - rn_albice ) / c2 )   & 
    150                   &     +         zihsc2   *   rn_alphc  
    151                ! 
    152                zitmlsn  =  MAX( zzero , SIGN( zone , pt_ice(ji,jj,jl) - rt0_snow ) )    
    153                zalbpsn  =  zitmlsn * zalbpsnm + ( 1.0 - zitmlsn ) * zalbpsnf 
    154              
    155                !  Case of ice free of snow. 
    156                zalbpic  = zficeth(ji,jj,jl)  
    157              
    158                ! albedo of the system    
    159                zithsn   = 1.0 - MAX( zzero , SIGN( zone , - ph_snw(ji,jj,jl) ) ) 
    160                pa_ice_cs(ji,jj,jl) =  zithsn * zalbpsn + ( 1.0 - zithsn ) *  zalbpic 
     103       
     104      SELECT CASE ( nn_ice_alb ) 
     105 
     106      !------------------------------------------ 
     107      !  Shine and Henderson-Sellers (1985) 
     108      !------------------------------------------ 
     109      CASE( 0 ) 
     110        
     111         ralb_sf = 0.80       ! dry snow 
     112         ralb_sm = 0.65       ! melting snow 
     113         ralb_if = 0.72       ! bare frozen ice 
     114         ralb_im = rn_albice  ! bare puddled ice  
     115          
     116         !  Computation of ice albedo (free of snow) 
     117         WHERE     ( ph_snw == 0._wp .AND. pt_ice >= rt0_ice )   ;   zalb(:,:,:) = ralb_im 
     118         ELSE WHERE                                              ;   zalb(:,:,:) = ralb_if 
     119         END  WHERE 
     120       
     121         WHERE     ( 1.5  < ph_ice                     )  ;  zalb_it = zalb 
     122         ELSE WHERE( 1.0  < ph_ice .AND. ph_ice <= 1.5 )  ;  zalb_it = 0.472  + 2.0 * ( zalb - 0.472 ) * ( ph_ice - 1.0 ) 
     123         ELSE WHERE( 0.05 < ph_ice .AND. ph_ice <= 1.0 )  ;  zalb_it = 0.2467 + 0.7049 * ph_ice              & 
     124            &                                                                 - 0.8608 * ph_ice * ph_ice     & 
     125            &                                                                 + 0.3812 * ph_ice * ph_ice * ph_ice 
     126         ELSE WHERE                                       ;  zalb_it = 0.1    + 3.6    * ph_ice 
     127         END WHERE 
     128      
     129         DO jl = 1, ijpl 
     130            DO jj = 1, jpj 
     131               DO ji = 1, jpi 
     132                  ! freezing snow 
     133                  ! no effect of underlying ice layer IF snow thickness > c1. Albedo does not depend on snow thick if > c2 
     134                  !                                        !  freezing snow         
     135                  zswitch   = 1._wp - MAX( 0._wp , SIGN( 1._wp , - ( ph_snw(ji,jj,jl) - c1 ) ) ) 
     136                  zalb_sf   = ( 1._wp - zswitch ) * (  zalb_it(ji,jj,jl)  & 
     137                     &                           + ph_snw(ji,jj,jl) * ( ralb_sf - zalb_it(ji,jj,jl) ) / c1  )   & 
     138                     &        +         zswitch   * ralb_sf   
     139 
     140                  ! melting snow 
     141                  ! no effect of underlying ice layer. Albedo does not depend on snow thick IF > c2 
     142                  zswitch   = MAX( 0._wp , SIGN( 1._wp , ph_snw(ji,jj,jl) - c2 ) ) 
     143                  zalb_sm = ( 1._wp - zswitch ) * ( ralb_im + ph_snw(ji,jj,jl) * ( ralb_sm - ralb_im ) / c2 )   & 
     144                      &     +         zswitch   *   ralb_sm  
     145                  ! 
     146                  ! snow albedo 
     147                  zswitch  =  MAX( 0._wp , SIGN( 1._wp , pt_ice(ji,jj,jl) - rt0_snow ) )    
     148                  zalb_st  =  zswitch * zalb_sm + ( 1._wp - zswitch ) * zalb_sf 
     149                
     150                  ! Ice/snow albedo 
     151                  zswitch   = 1._wp - MAX( 0._wp , SIGN( 1._wp , - ph_snw(ji,jj,jl) ) ) 
     152                  pa_ice_cs(ji,jj,jl) =  zswitch * zalb_st + ( 1._wp - zswitch ) * zalb_it(ji,jj,jl) 
     153                  ! 
     154               END DO 
    161155            END DO 
    162156         END DO 
    163       END DO 
    164        
    165       !    Albedo of snow-ice for overcast sky. 
    166       !----------------------------------------------   
    167       pa_ice_os(:,:,:) = pa_ice_cs(:,:,:) + rn_cloud       ! Oberhuber correction 
    168       ! 
    169       CALL wrk_dealloc( jpi,jpj,ijpl, zalbfz, zficeth ) 
     157 
     158         pa_ice_os(:,:,:) = pa_ice_cs(:,:,:) + rcloud       ! Oberhuber correction for overcast sky 
     159 
     160      !------------------------------------------ 
     161      !  New parameterization (2016) 
     162      !------------------------------------------ 
     163      CASE( 1 )  
     164 
     165         ralb_im = rn_albice  ! bare puddled ice 
     166! compilation of values from literature 
     167         ralb_sf = 0.85      ! dry snow 
     168         ralb_sm = 0.75      ! melting snow 
     169         ralb_if = 0.60      ! bare frozen ice 
     170! Perovich et al 2002 (Sheba) => the only dataset for which all types of ice/snow were retrieved 
     171!         ralb_sf = 0.85       ! dry snow 
     172!         ralb_sm = 0.72       ! melting snow 
     173!         ralb_if = 0.65       ! bare frozen ice 
     174! Brandt et al 2005 (East Antarctica) 
     175!         ralb_sf = 0.87      ! dry snow 
     176!         ralb_sm = 0.82      ! melting snow 
     177!         ralb_if = 0.54      ! bare frozen ice 
     178!  
     179         !  Computation of ice albedo (free of snow) 
     180         z1_c1 = 1. / ( LOG(1.5) - LOG(0.05) )  
     181         z1_c2 = 1. / 0.05 
     182         WHERE     ( ph_snw == 0._wp .AND. pt_ice >= rt0_ice )   ;   zalb = ralb_im 
     183         ELSE WHERE                                              ;   zalb = ralb_if 
     184         END  WHERE 
     185          
     186         WHERE     ( 1.5  < ph_ice                     )  ;  zalb_it = zalb 
     187         ELSE WHERE( 0.05 < ph_ice .AND. ph_ice <= 1.5 )  ;  zalb_it = zalb     + ( 0.18 - zalb     ) * z1_c1 *  & 
     188            &                                                                     ( LOG(1.5) - LOG(ph_ice) ) 
     189         ELSE WHERE                                       ;  zalb_it = ralb_oce + ( 0.18 - ralb_oce ) * z1_c2 * ph_ice 
     190         END WHERE 
     191 
     192         z1_c1 = 1. / 0.02 
     193         z1_c2 = 1. / 0.03 
     194         !  Computation of the snow/ice albedo 
     195         DO jl = 1, ijpl 
     196            DO jj = 1, jpj 
     197               DO ji = 1, jpi 
     198                  zalb_sf = ralb_sf - ( ralb_sf - zalb_it(ji,jj,jl)) * EXP( - ph_snw(ji,jj,jl) * z1_c1 ); 
     199                  zalb_sm = ralb_sm - ( ralb_sm - zalb_it(ji,jj,jl)) * EXP( - ph_snw(ji,jj,jl) * z1_c2 ); 
     200 
     201                   ! snow albedo 
     202                  zswitch = MAX( 0._wp , SIGN( 1._wp , pt_ice(ji,jj,jl) - rt0_snow ) )    
     203                  zalb_st = zswitch * zalb_sm + ( 1._wp - zswitch ) * zalb_sf 
     204 
     205                  ! Ice/snow albedo    
     206                  zswitch             = MAX( 0._wp , SIGN( 1._wp , - ph_snw(ji,jj,jl) ) ) 
     207                  pa_ice_os(ji,jj,jl) = ( 1._wp - zswitch ) * zalb_st + zswitch *  zalb_it(ji,jj,jl) 
     208 
     209              END DO 
     210            END DO 
     211         END DO 
     212         ! Effect of the clouds (2d order polynomial) 
     213         pa_ice_cs = pa_ice_os - ( - 0.1010 * pa_ice_os * pa_ice_os + 0.1933 * pa_ice_os - 0.0148 );  
     214 
     215      END SELECT 
     216       
     217      CALL wrk_dealloc( jpi,jpj,ijpl, zalb, zalb_it ) 
    170218      ! 
    171219   END SUBROUTINE albedo_ice 
    … …  
    181229      REAL(wp), DIMENSION(:,:), INTENT(out) ::   pa_oce_cs   !  albedo of ocean under clear sky 
    182230      !! 
    183       REAL(wp) ::   zcoef   ! local scalar 
    184       !!---------------------------------------------------------------------- 
    185       ! 
    186       zcoef = 0.05 / ( 1.1 * rmue**1.4 + 0.15 )      ! Parameterization of Briegled and Ramanathan, 1982  
    187       pa_oce_cs(:,:) = zcoef                
    188       pa_oce_os(:,:)  = 0.06                         ! Parameterization of Kondratyev, 1969 and Payne, 1972 
     231      REAL(wp) :: zcoef  
     232      !!---------------------------------------------------------------------- 
     233      ! 
     234      zcoef = 0.05 / ( 1.1 * rmue**1.4 + 0.15 )   ! Parameterization of Briegled and Ramanathan, 1982 
     235      pa_oce_cs(:,:) = zcoef  
     236      pa_oce_os(:,:) = 0.06                       ! Parameterization of Kondratyev, 1969 and Payne, 1972 
    189237      ! 
    190238   END SUBROUTINE albedo_oce 
    … …  
    200248      !!---------------------------------------------------------------------- 
    201249      INTEGER  ::   ios                 ! Local integer output status for namelist read 
    202       NAMELIST/namsbc_alb/ rn_cloud, rn_albice, rn_alphd, rn_alphdi, rn_alphc 
     250      NAMELIST/namsbc_alb/ nn_ice_alb, rn_albice  
    203251      !!---------------------------------------------------------------------- 
    204252      ! 
    … …  
    219267         WRITE(numout,*) '~~~~~~~' 
    220268         WRITE(numout,*) '   Namelist namsbc_alb : albedo ' 
    221          WRITE(numout,*) '      correction for snow and ice albedo                  rn_cloud  = ', rn_cloud 
    222          WRITE(numout,*) '      albedo of melting ice in the arctic and antarctic   rn_albice = ', rn_albice 
    223          WRITE(numout,*) '      coefficients for linear                             rn_alphd  = ', rn_alphd 
    224          WRITE(numout,*) '      interpolation used to compute albedo                rn_alphdi = ', rn_alphdi 
    225          WRITE(numout,*) '      between two extremes values (Pyane, 1972)           rn_alphc  = ', rn_alphc 
     269         WRITE(numout,*) '      choose the albedo parameterization                  nn_ice_alb = ', nn_ice_alb 
     270         WRITE(numout,*) '      albedo of bare puddled ice                          rn_albice  = ', rn_albice 
    226271      ENDIF 
    227272      ! 

  • branches/2016/dev_CNRS_2016/NEMOGCM/NEMO/OPA_SRC/SBC/sbc_ice.F90

    r5407 r7278  
    8080   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   qemp_oce       !: heat flux of precip and evap over ocean     [W/m2] 
    8181   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   qemp_ice       !: heat flux of precip and evap over ice       [W/m2] 
    82    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   qprec_ice      !: heat flux of precip over ice                [J/m3] 
     82   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   qevap_ice      !: heat flux of evap over ice                  [W/m2] 
     83   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   qprec_ice      !: enthalpy of precip over ice                 [J/m3] 
    8384   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   emp_oce        !: evap - precip over ocean                 [kg/m2/s] 
    8485#endif 
    … …  
    144145#endif 
    145146#if defined key_lim3 
    146          &      evap_ice(jpi,jpj,jpl) , devap_ice(jpi,jpj,jpl) , qprec_ice(jpi,jpj) ,  & 
    147          &      qemp_ice(jpi,jpj)     , qemp_oce(jpi,jpj)      ,                       & 
    148          &      qns_oce (jpi,jpj)     , qsr_oce (jpi,jpj)      , emp_oce (jpi,jpj)  ,  & 
     147         &      evap_ice(jpi,jpj,jpl) , devap_ice(jpi,jpj,jpl) , qprec_ice(jpi,jpj) ,   & 
     148         &      qemp_ice(jpi,jpj)     , qevap_ice(jpi,jpj,jpl) , qemp_oce (jpi,jpj) ,   & 
     149         &      qns_oce (jpi,jpj)     , qsr_oce  (jpi,jpj)     , emp_oce (jpi,jpj)  ,   & 
    149150#endif 
    150151         &      emp_ice(jpi,jpj)      ,  STAT= ierr(1) ) 

  • branches/2016/dev_CNRS_2016/NEMOGCM/NEMO/OPA_SRC/SBC/sbcblk_clio.F90

    r7277 r7278  
    668668      qprec_ice(:,:) = rhosn * ( ( MIN( sf(jp_tair)%fnow(:,:,1), rt0_snow ) - rt0 ) * cpic * tmask(:,:,1) - lfus ) 
    669669 
     670      ! --- heat content of evap over ice in W/m2 (to be used in 1D-thermo) --- ! 
     671      DO jl = 1, jpl 
     672         qevap_ice(:,:,jl) = 0._wp ! should be -evap_ice(:,:,jl)*( ( Tice - rt0 ) * cpic * tmask(:,:,1) - lfus ) 
     673                                   ! but then qemp_ice should also include sublimation  
     674      END DO 
     675 
    670676      CALL wrk_dealloc( jpi,jpj, zevap, zsnw )  
    671677#endif 

  • branches/2016/dev_CNRS_2016/NEMOGCM/NEMO/OPA_SRC/SBC/sbcblk_core.F90

    r7277 r7278  
    612612      ! --- evaporation --- ! 
    613613      z1_lsub = 1._wp / Lsub 
    614       evap_ice (:,:,:) = qla_ice (:,:,:) * z1_lsub ! sublimation 
    615       devap_ice(:,:,:) = dqla_ice(:,:,:) * z1_lsub 
    616       zevap    (:,:)   = emp(:,:) + tprecip(:,:)   ! evaporation over ocean 
     614      evap_ice (:,:,:) = rn_efac * qla_ice (:,:,:) * z1_lsub    ! sublimation 
     615      devap_ice(:,:,:) = rn_efac * dqla_ice(:,:,:) * z1_lsub    ! d(sublimation)/dT 
     616      zevap    (:,:)   = rn_efac * ( emp(:,:) + tprecip(:,:) )  ! evaporation over ocean 
    617617 
    618618      ! --- evaporation minus precipitation --- ! 
    … …  
    637637      ! --- heat content of precip over ice in J/m3 (to be used in 1D-thermo) --- ! 
    638638      qprec_ice(:,:) = rhosn * ( ( MIN( sf(jp_tair)%fnow(:,:,1), rt0_snow ) - rt0 ) * cpic * tmask(:,:,1) - lfus ) 
     639 
     640      ! --- heat content of evap over ice in W/m2 (to be used in 1D-thermo) --- ! 
     641      DO jl = 1, jpl 
     642         qevap_ice(:,:,jl) = 0._wp ! should be -evap_ice(:,:,jl)*( ( Tice - rt0 ) * cpic * tmask(:,:,1) ) 
     643                                   ! But we do not have Tice => consider it at 0°C => evap=0  
     644      END DO 
    639645 
    640646      CALL wrk_dealloc( jpi,jpj, zevap, zsnw )  

  • branches/2016/dev_CNRS_2016/NEMOGCM/NEMO/OPA_SRC/SBC/sbccpl.F90

    r7277 r7278  
    10061006      IF( srcv(jpr_toce)%laction ) THEN                      ! received by sas in case of opa <-> sas coupling 
    10071007         sst_m(:,:) = frcv(jpr_toce)%z3(:,:,1) 
    1008          IF( srcv(jpr_soce)%laction .AND. ln_useCT ) THEN    ! make sure that sst_m is the potential temperature 
     1008         IF( srcv(jpr_soce)%laction .AND. l_useCT ) THEN    ! make sure that sst_m is the potential temperature 
    10091009            sst_m(:,:) = eos_pt_from_ct( sst_m(:,:), sss_m(:,:) ) 
    10101010         ENDIF 
    … …  
    13701370      ! 
    13711371      INTEGER ::   jl   ! dummy loop index 
    1372       REAL(wp), POINTER, DIMENSION(:,:  ) ::   zcptn, ztmp, zicefr, zmsk 
    1373       REAL(wp), POINTER, DIMENSION(:,:  ) ::   zemp_tot, zemp_ice, zsprecip, ztprecip, zqns_tot, zqsr_tot 
    1374       REAL(wp), POINTER, DIMENSION(:,:,:) ::   zqns_ice, zqsr_ice, zdqns_ice 
    1375       REAL(wp), POINTER, DIMENSION(:,:  ) ::   zevap, zsnw, zqns_oce, zqsr_oce, zqprec_ice, zqemp_oce ! for LIM3 
     1372      REAL(wp), POINTER, DIMENSION(:,:  ) ::   zcptn, ztmp, zicefr, zmsk, zsnw 
     1373      REAL(wp), POINTER, DIMENSION(:,:  ) ::   zemp_tot, zemp_ice, zemp_oce, ztprecip, zsprecip, zevap, zevap_ice, zdevap_ice 
     1374      REAL(wp), POINTER, DIMENSION(:,:  ) ::   zqns_tot, zqns_oce, zqsr_tot, zqsr_oce, zqprec_ice, zqemp_oce, zqemp_ice 
     1375      REAL(wp), POINTER, DIMENSION(:,:,:) ::   zqns_ice, zqsr_ice, zdqns_ice, zqevap_ice 
    13761376      !!---------------------------------------------------------------------- 
    13771377      ! 
    13781378      IF( nn_timing == 1 )   CALL timing_start('sbc_cpl_ice_flx') 
    13791379      ! 
    1380       CALL wrk_alloc( jpi,jpj,       zcptn, ztmp, zicefr, zmsk, zemp_tot, zemp_ice, zsprecip, ztprecip, zqns_tot, zqsr_tot ) 
    1381       CALL wrk_alloc( jpi,jpj,jpl,   zqns_ice, zqsr_ice, zdqns_ice ) 
     1380      CALL wrk_alloc( jpi,jpj,     zcptn, ztmp, zicefr, zmsk, zsnw ) 
     1381      CALL wrk_alloc( jpi,jpj,     zemp_tot, zemp_ice, zemp_oce, ztprecip, zsprecip, zevap, zevap_ice, zdevap_ice ) 
     1382      CALL wrk_alloc( jpi,jpj,     zqns_tot, zqns_oce, zqsr_tot, zqsr_oce, zqprec_ice, zqemp_oce, zqemp_ice ) 
     1383      CALL wrk_alloc( jpi,jpj,jpl, zqns_ice, zqsr_ice, zdqns_ice, zqevap_ice ) 
    13821384 
    13831385      IF( ln_mixcpl )   zmsk(:,:) = 1. - xcplmask(:,:,0) 
    … …  
    14141416         ztprecip(:,:) = frcv(jpr_semp)%z3(:,:,1) - frcv(jpr_sbpr)%z3(:,:,1) + zsprecip(:,:) 
    14151417      END SELECT 
    1416  
    1417       IF( iom_use('subl_ai_cea') )   & 
    1418          CALL iom_put( 'subl_ai_cea', frcv(jpr_ievp)%z3(:,:,1) * zicefr(:,:) )   ! Sublimation over sea-ice         (cell average) 
    1419       !    
    1420       !                                                           ! runoffs and calving (put in emp_tot) 
     1418#if defined key_lim3 
     1419      ! zsnw = snow percentage over ice after wind blowing 
     1420      zsnw(:,:) = 0._wp 
     1421      CALL lim_thd_snwblow( p_frld, zsnw ) 
     1422       
     1423      ! --- evaporation (used later in sbccpl) --- ! 
     1424      zevap(:,:) = zemp_tot(:,:) + ztprecip(:,:) 
     1425 
     1426      ! --- evaporation over ice (kg/m2/s) --- ! 
     1427      zevap_ice(:,:) = frcv(jpr_ievp)%z3(:,:,1) 
     1428      ! since the sensitivity of evap to temperature (devap/dT) is not prescribed by the atmosphere, we set it to 0 
     1429      ! therefore, sublimation is not redistributed over the ice categories in case no subgrid scale fluxes are provided by atm. 
     1430      zdevap_ice(:,:) = 0._wp 
     1431       
     1432      ! --- evaporation minus precipitation corrected for the effect of wind blowing on snow --- ! 
     1433      zemp_oce(:,:) = zemp_tot(:,:) - zemp_ice(:,:) - zsprecip * (1._wp - zsnw) 
     1434      zemp_ice(:,:) = zemp_ice(:,:) + zsprecip * (1._wp - zsnw)     
     1435 
     1436      ! --- runoffs (included in emp later on) --- ! 
     1437      IF( srcv(jpr_rnf)%laction )   rnf(:,:) = frcv(jpr_rnf)%z3(:,:,1) 
     1438 
     1439      ! --- calving (put in emp_tot and emp_oce) --- ! 
     1440      IF( srcv(jpr_cal)%laction ) THEN  
     1441         zemp_tot(:,:) = zemp_tot(:,:) - frcv(jpr_cal)%z3(:,:,1) 
     1442         zemp_oce(:,:) = zemp_oce(:,:) - frcv(jpr_cal)%z3(:,:,1) 
     1443         CALL iom_put( 'calving_cea', frcv(jpr_cal)%z3(:,:,1) ) 
     1444      ENDIF 
     1445       
     1446      IF( ln_mixcpl ) THEN 
     1447         emp_tot(:,:) = emp_tot(:,:) * xcplmask(:,:,0) + zemp_tot(:,:) * zmsk(:,:) 
     1448         emp_ice(:,:) = emp_ice(:,:) * xcplmask(:,:,0) + zemp_ice(:,:) * zmsk(:,:) 
     1449         emp_oce(:,:) = emp_oce(:,:) * xcplmask(:,:,0) + zemp_oce(:,:) * zmsk(:,:) 
     1450         sprecip(:,:) = sprecip(:,:) * xcplmask(:,:,0) + zsprecip(:,:) * zmsk(:,:) 
     1451         tprecip(:,:) = tprecip(:,:) * xcplmask(:,:,0) + ztprecip(:,:) * zmsk(:,:) 
     1452      &nbs