- Timestamp:
- 2015-01-15T14:48:42+01:00 (9 years ago)
- Location:
- branches/2014/dev_r4650_UKMO14.12_STAND_ALONE_OBSOPER/NEMOGCM/NEMO/LIM_SRC_3
- Files:
-
- 27 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/2014/dev_r4650_UKMO14.12_STAND_ALONE_OBSOPER/NEMOGCM/NEMO/LIM_SRC_3/ice.F90
r4333 r5034 105 105 !! ** Global variables | 106 106 !!-------------|-------------|---------------------------------|-------| 107 !! a_i | a_i_ b| Ice concentration | |107 !! a_i | a_i_1d | Ice concentration | | 108 108 !! v_i | - | Ice volume per unit area | m | 109 109 !! v_s | - | Snow volume per unit area | m | … … 111 111 !! oa_i ! - ! Sea ice areal age content | day | 112 112 !! e_i ! - ! Ice enthalpy | 10^9 J| 113 !! - ! q_i_ b! Ice enthalpy per unit vol. | J/m3 |113 !! - ! q_i_1d ! Ice enthalpy per unit vol. | J/m3 | 114 114 !! e_s ! - ! Snow enthalpy | 10^9 J| 115 !! - ! q_s_ b! Snow enthalpy per unit vol. | J/m3 |115 !! - ! q_s_1d ! Snow enthalpy per unit vol. | J/m3 | 116 116 !! | 117 117 !!-------------|-------------|---------------------------------|-------| … … 120 120 !!-------------|-------------|---------------------------------|-------| 121 121 !! | 122 !! ht_i | ht_i_ b| Ice thickness | m |123 !! ht_s ! ht_s_ b| Snow depth | m |124 !! sm_i ! sm_i_ b| Sea ice bulk salinity ! ppt |125 !! s_i ! s_i_ b| Sea ice salinity profile ! ppt |122 !! ht_i | ht_i_1d | Ice thickness | m | 123 !! ht_s ! ht_s_1d | Snow depth | m | 124 !! sm_i ! sm_i_1d | Sea ice bulk salinity ! ppt | 125 !! s_i ! s_i_1d | Sea ice salinity profile ! ppt | 126 126 !! o_i ! - | Sea ice Age ! days | 127 !! t_i ! t_i_ b| Sea ice temperature ! K |128 !! t_s ! t_s_ b| Snow temperature ! K |129 !! t_su ! t_su_ b| Sea ice surface temperature ! K |127 !! t_i ! t_i_1d | Sea ice temperature ! K | 128 !! t_s ! t_s_1d | Snow temperature ! K | 129 !! t_su ! t_su_1d | Sea ice surface temperature ! K | 130 130 !! | 131 131 !! notes: the ice model only sees a bulk (i.e., vertically averaged) | … … 142 142 !! *** Category-summed state variables (diagnostic) *** | 143 143 !! ******************************************************************* | 144 !! at_i | at_i_ b| Total ice concentration | |144 !! at_i | at_i_1d | Total ice concentration | | 145 145 !! vt_i | - | Total ice vol. per unit area | m | 146 146 !! vt_s | - | Total snow vol. per unit ar. | m | … … 166 166 167 167 ! !!** ice-dynamic namelist (namicedyn) ** 168 INTEGER , PUBLIC :: nbiter !: number of sub-time steps for relaxation169 INTEGER , PUBLIC :: nbitdr !: maximum number of iterations for relaxation170 168 INTEGER , PUBLIC :: nevp !: number of iterations for subcycling 171 INTEGER , PUBLIC :: nlay_i = 5 !: number of layers in the ice172 173 ! !!** ice-dynamic namelist (namicedyn) **174 169 REAL(wp), PUBLIC :: epsd !: tolerance parameter for dynamic 175 REAL(wp), PUBLIC :: alpha !: coefficient for semi-implicit coriolis176 REAL(wp), PUBLIC :: dm !: diffusion constant for dynamics177 170 REAL(wp), PUBLIC :: om !: relaxation constant 178 REAL(wp), PUBLIC :: resl !: maximum value for the residual of relaxation179 171 REAL(wp), PUBLIC :: cw !: drag coefficient for oceanic stress 180 REAL(wp), PUBLIC :: angvg !: turning angle for oceanic stress181 172 REAL(wp), PUBLIC :: pstar !: determines ice strength (N/M), Hibler JPO79 182 173 REAL(wp), PUBLIC :: c_rhg !: determines changes in ice strength 183 REAL(wp), PUBLIC :: etamn !: minimun value for viscosity : has to be 0184 174 REAL(wp), PUBLIC :: creepl !: creep limit : has to be under 1.0e-9 185 175 REAL(wp), PUBLIC :: ecc !: eccentricity of the elliptical yield curve 186 176 REAL(wp), PUBLIC :: ahi0 !: sea-ice hor. eddy diffusivity coeff. (m2/s) 187 REAL(wp), PUBLIC :: telast !: timescale for elastic waves (s) !SB188 REAL(wp), PUBLIC :: alphaevp !: coeficient of the internal stresses !SB189 REAL(wp), PUBLIC :: unit_fac = 1.e+09_wp !: conversion factor for ice / snow enthalpy190 REAL(wp), PUBLIC :: hminrhg = 0.001_wp !: clem: ice volume (a*h, in m) below which ice velocity is set to ocean velocity177 REAL(wp), PUBLIC :: telast !: timescale for elastic waves (s) 178 REAL(wp), PUBLIC :: relast !: ratio => telast/rdt_ice (1/3 or 1/9 depending on nb of subcycling nevp) 179 REAL(wp), PUBLIC :: alphaevp !: coeficient of the internal stresses 180 REAL(wp), PUBLIC :: hminrhg !: ice volume (a*h, in m) below which ice velocity is set to ocean velocity 191 181 192 182 ! !!** ice-salinity namelist (namicesal) ** … … 202 192 203 193 ! !!** ice-salinity namelist (namicesal) ** 204 INTEGER , PUBLIC :: num_sal !: salinity configuration used in the model194 INTEGER , PUBLIC :: num_sal !: salinity configuration used in the model 205 195 ! ! 1 - constant salinity in both space and time 206 196 ! ! 2 - prognostic salinity (s(z,t)) 207 197 ! ! 3 - salinity profile, constant in time 208 INTEGER , PUBLIC :: sal_prof = 1 !: salinity profile or not 209 INTEGER , PUBLIC :: thcon_i_swi !: thermal conductivity: =1 Untersteiner (1964) ; =2 Pringle et al (2007) 198 INTEGER , PUBLIC :: thcon_i_swi !: thermal conductivity: =0 Untersteiner (1964) ; =1 Pringle et al (2007) 210 199 211 200 ! !!** ice-mechanical redistribution namelist (namiceitdme) … … 220 209 REAL(wp), PUBLIC :: Craft !: coefficient for smoothness of the hyperbolic tangent in rafting 221 210 REAL(wp), PUBLIC :: ridge_por !: initial porosity of ridges (0.3 regular value) 222 REAL(wp), PUBLIC :: sal_max_ridge !: maximum ridged ice salinity (ppt)223 211 REAL(wp), PUBLIC :: betas !: coef. for partitioning of snowfall between leads and sea ice 224 212 REAL(wp), PUBLIC :: kappa_i !: coef. for the extinction of radiation Grenfell et al. (2006) [1/m] … … 228 216 ! !!** ice-mechanical redistribution namelist (namiceitdme) 229 217 INTEGER , PUBLIC :: ridge_scheme_swi !: scheme used for ice ridging 230 INTEGER , PUBLIC :: raft swi!: rafting of ice or not218 INTEGER , PUBLIC :: raft_swi !: rafting of ice or not 231 219 INTEGER , PUBLIC :: partfun_swi !: participation function: =0 Thorndike et al. (1975), =1 Lipscomb et al. (2007) 232 INTEGER , PUBLIC :: transfun_swi !: transfer function: =0 Hibler 1980, =1 Lipscomb et al. 2007233 220 INTEGER , PUBLIC :: brinstren_swi !: use brine volume to diminish ice strength 234 221 235 222 REAL(wp), PUBLIC :: usecc2 !: = 1.0 / ( ecc * ecc ) 236 223 REAL(wp), PUBLIC :: rhoco !: = rau0 * cw 237 REAL(wp), PUBLIC :: sangvg, cangvg !: sin and cos of the turning angle for ocean stress 238 REAL(wp), PUBLIC :: pstarh !: pstar / 2.0 224 225 ! !!** switch for presence of ice or not 226 REAL(wp), PUBLIC :: rswitch 227 228 ! !!** define some parameters 229 REAL(wp), PUBLIC, PARAMETER :: unit_fac = 1.e+09_wp !: conversion factor for ice / snow enthalpy 230 REAL(wp), PUBLIC, PARAMETER :: epsi06 = 1.e-06_wp !: small number 231 REAL(wp), PUBLIC, PARAMETER :: epsi10 = 1.e-10_wp !: small number 232 REAL(wp), PUBLIC, PARAMETER :: epsi20 = 1.e-20_wp !: small number 239 233 240 234 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: u_oce, v_oce !: surface ocean velocity used in ice dynamics … … 249 243 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: shear_i !: Shear of the velocity field [s-1] 250 244 ! 251 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: firic !: IR flux over the ice (diag only)252 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fcsic !: Sensible heat flux over the ice (diag only)253 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fleic !: Latent heat flux over the ice (diag only)254 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: qlatic !: latent flux255 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: rdvosif !: Variation of volume at surface (diag only)256 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: rdvobif !: Variation of ice volume at the bottom ice (diag only)257 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fdvolif !: Total variation of ice volume (diag only)258 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: rdvonif !: Lateral Variation of ice volume (diag only)259 245 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sist !: Average Sea-Ice Surface Temperature [Kelvin] 260 246 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: icethi !: total ice thickness (for all categories) (diag only) 261 247 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: t_bo !: Sea-Ice bottom temperature [Kelvin] 262 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hicifp !: Ice production/melting==>!obsolete... can be removed263 248 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: frld !: Leads fraction = 1 - ice fraction 264 249 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: pfrld !: Leads fraction at previous time 265 250 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: phicif !: Old ice thickness 266 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fbif !: Heat flux at the ice base 267 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: rdm_snw !: Variation of snow mass over 1 time step [Kg/m2] 268 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: rdq_snw !: Heat content associated with rdm_snw [J/m2] 269 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: rdm_ice !: Variation of ice mass over 1 time step [Kg/m2] 270 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: rdq_ice !: Heat content associated with rdm_ice [J/m2] 271 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: qldif !: heat balance of the lead (or of the open ocean) 272 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: qcmif !: Energy needed to bring the ocean to freezing 273 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fdtcn !: net downward heat flux from the ice to the ocean 274 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: qdtcn !: energy from the ice to the ocean 275 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fstric !: transmitted solar radiation under ice 276 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fscmbq !: associated with lead chipotage with solar flux 277 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ffltbif !: related to max heat contained in brine pockets (?) 278 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fsbbq !: Also linked with the solar flux below the ice (?) 279 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: qfvbq !: store energy in case of total lateral ablation (?) 280 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: dmgwi !: Variation of the mass of snow ice 281 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sfx_thd !: salt flux due to ice growth/melt [PSU/m2/s] 251 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: qlead !: heat balance of the lead (or of the open ocean) 252 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fhtur !: net downward heat flux from the ice to the ocean 253 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fhld !: heat flux from the lead used for bottom melting 254 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(:,:) :: sfx_bog !: salt flux due to ice growth/melt [PSU/m2/s] 269 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sfx_bom !: salt flux due to ice growth/melt [PSU/m2/s] 270 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sfx_sum !: salt flux due to ice growth/melt [PSU/m2/s] 271 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sfx_sni !: salt flux due to ice growth/melt [PSU/m2/s] 272 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sfx_opw !: salt flux due to ice growth/melt [PSU/m2/s] 282 273 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sfx_bri !: salt flux due to brine rejection [PSU/m2/s] 283 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sfx_ mec!: salt flux due to porous ridged ice formation [PSU/m2/s]274 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sfx_dyn !: salt flux due to porous ridged ice formation [PSU/m2/s] 284 275 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sfx_res !: residual salt flux due to correction of ice thickness [PSU/m2/s] 285 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fhbri !: heat flux due to brine rejection 286 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fheat_mec !: heat flux associated with porous ridged ice formation [???] 287 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fheat_res !: residual heat flux due to correction of ice thickness 288 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fmmec !: mass flux due to snow loss during compression [Kg/m2/s] 289 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fhmec !: heat flux due to snow loss during compression 276 277 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_bog !: total heat flux causing bottom ice growth 278 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_bom !: total heat flux causing bottom ice melt 279 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_sum !: total heat flux causing surface ice melt 280 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_opw !: total heat flux causing open water ice formation 281 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_dif !: total heat flux causing Temp change in the ice 282 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_snw !: heat flux for snow melt 283 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_err !: heat flux error after heat diffusion 284 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_err_rem !: heat flux error after heat remapping 285 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_in !: heat flux available for thermo transformations 286 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_out !: heat flux remaining at the end of thermo transformations 287 288 ! heat flux associated with ice-atmosphere mass exchange 289 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_sub !: heat flux for sublimation 290 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_spr !: heat flux of the snow precipitation 291 292 ! heat flux associated with ice-ocean mass exchange 293 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_thd !: ice-ocean heat flux from thermo processes (limthd_dh) 294 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_dyn !: ice-ocean heat flux from mecanical processes (limitd_me) 295 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_res !: residual heat flux due to correction of ice thickness 296 297 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: ftr_ice !: transmitted solar radiation under ice 290 298 291 299 ! temporary arrays for dummy version of the code 292 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: dh_i_surf2D, dh_i_bott2D, fstbif, fsup2D, focea2D,q_s300 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: dh_i_surf2D, dh_i_bott2D, q_s 293 301 294 302 !!-------------------------------------------------------------------------- … … 321 329 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: smt_i !: mean sea ice salinity averaged over all categories [PSU] 322 330 323 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: at_i_typ !: total area contained in each ice type [m^2]324 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: vt_i_typ !: total volume contained in each ice type [m^3]325 326 331 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: t_s !: Snow temperatures [K] 327 332 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: e_s !: Snow ... 328 329 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: e_i_cat !: ! go to trash330 333 331 334 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: t_i !: ice temperatures [K] … … 348 351 !! * Old values of global variables 349 352 !!-------------------------------------------------------------------------- 350 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: old_v_s, old_v_i!: snow and ice volumes351 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: old_a_i, old_smv_i, old_oa_i !: ???352 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: old_e_s!: snow heat content353 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: old_e_i!: ice temperatures354 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: old_u_ice, old_v_ice !: ice velocity (gv6 and gv7)353 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: v_s_b, v_i_b !: snow and ice volumes 354 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: a_i_b, smv_i_b, oa_i_b !: 355 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: e_s_b !: snow heat content 356 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: e_i_b !: ice temperatures 357 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: u_ice_b, v_ice_b !: ice velocity 355 358 356 359 … … 366 369 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: d_sm_i_fl , d_sm_i_gd !: 367 370 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: d_sm_i_se , d_sm_i_si , d_sm_i_la !: 368 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: d_oa_i_thd , d_oa_i_trp , s_i_newice!:371 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: d_oa_i_thd , d_oa_i_trp !: 369 372 370 373 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: d_e_s_thd , d_e_s_trp !: … … 375 378 !! * Ice thickness distribution variables 376 379 !!-------------------------------------------------------------------------- 377 ! REMOVE378 INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: ice_types !: Vector connecting types and categories379 INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ice_cat_bounds !: Matrix containing the integer upper and380 ! ! lower boundaries of ice thickness categories381 ! REMOVE382 INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: ice_ncat_types !: nb of thickness categories in each ice type383 380 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: hi_max !: Boundary of ice thickness categories in thickness space 384 381 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: hi_mean !: Mean ice thickness in catgories 385 ! REMOVE386 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hi_max_typ !: Boundary of ice thickness categories in thickness space387 382 388 383 !!-------------------------------------------------------------------------- … … 404 399 LOGICAL , PUBLIC :: ln_limdiahsb !: flag for ice diag (T) or not (F) 405 400 LOGICAL , PUBLIC :: ln_limdiaout !: flag for ice diag (T) or not (F) 406 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: v_newice !: volume of ice formed in the leads 407 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: dv_dt_thd !: thermodynamic growth rates 408 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: izero, fstroc, fhbricat 409 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_sni_gr ! snow ice growth 410 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_lat_gr ! lateral ice growth 411 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_bot_gr ! bottom ice growth 412 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_dyn_gr ! dynamical ice growth 413 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_bot_me ! vertical bottom melt 414 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_sur_me ! vertical surface melt 415 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_res_pr ! production (growth+melt) due to limupdate 416 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_trp_vi ! transport of ice volume 401 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: dv_dt_thd !: thermodynamic growth rates 402 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_trp_vi !: transport of ice volume 403 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_trp_vs !: transport of snw volume 404 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_trp_ei !: transport of ice enthalpy (W/m2) 405 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_trp_es !: transport of snw enthalpy (W/m2) 406 ! 407 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_heat_dhc !: snw/ice heat content variation [W/m2] 408 ! 417 409 INTEGER , PUBLIC :: jiindx, jjindx !: indexes of the debugging point 418 410 … … 430 422 INTEGER :: ice_alloc 431 423 ! 432 INTEGER :: ierr( 20), ii424 INTEGER :: ierr(19), ii 433 425 !!----------------------------------------------------------------- 434 426 … … 447 439 448 440 ii = ii + 1 449 ALLOCATE( firic (jpi,jpj) , fcsic (jpi,jpj) , fleic (jpi,jpj) , qlatic (jpi,jpj) , & 450 & rdvosif (jpi,jpj) , rdvobif(jpi,jpj) , fdvolif(jpi,jpj) , rdvonif (jpi,jpj) , & 451 & sist (jpi,jpj) , icethi (jpi,jpj) , t_bo (jpi,jpj) , hicifp (jpi,jpj) , & 452 & frld (jpi,jpj) , pfrld (jpi,jpj) , phicif (jpi,jpj) , fbif (jpi,jpj) , & 453 & rdm_snw (jpi,jpj) , rdq_snw(jpi,jpj) , rdm_ice(jpi,jpj) , rdq_ice (jpi,jpj) , & 454 & qldif (jpi,jpj) , qcmif (jpi,jpj) , & 455 & fdtcn (jpi,jpj) , qdtcn (jpi,jpj) , fstric (jpi,jpj) , fscmbq (jpi,jpj) , & 456 & ffltbif (jpi,jpj) , fsbbq (jpi,jpj) , qfvbq (jpi,jpj) , dmgwi (jpi,jpj) , & 457 & sfx_res (jpi,jpj) , sfx_bri(jpi,jpj) , sfx_mec(jpi,jpj) , fheat_mec(jpi,jpj) , & 458 & fhbri (jpi,jpj) , fmmec (jpi,jpj) , sfx_thd(jpi,jpj) , fhmec (jpi,jpj) , & 459 & fheat_res(jpi,jpj) , STAT=ierr(ii) ) 460 461 ii = ii + 1 462 ALLOCATE( dh_i_surf2D(jpi,jpj) , dh_i_bott2D(jpi,jpj) , fstbif(jpi,jpj) , & 463 & fsup2D (jpi,jpj) , focea2D (jpi,jpj) , q_s (jpi,jpj) , STAT=ierr(ii) ) 441 ALLOCATE( sist (jpi,jpj) , icethi (jpi,jpj) , t_bo (jpi,jpj) , & 442 & frld (jpi,jpj) , pfrld (jpi,jpj) , phicif (jpi,jpj) , & 443 & wfx_snw(jpi,jpj) , wfx_ice(jpi,jpj) , wfx_sub(jpi,jpj) , & 444 & wfx_bog(jpi,jpj) , wfx_dyn(jpi,jpj) , wfx_bom(jpi,jpj) , wfx_sum(jpi,jpj) , & 445 & wfx_res(jpi,jpj) , wfx_sni(jpi,jpj) , wfx_opw(jpi,jpj) , wfx_spr(jpi,jpj) , qlead (jpi,jpj) , & 446 & fhtur (jpi,jpj) , ftr_ice(jpi,jpj,jpl) , & 447 & sfx_res(jpi,jpj) , sfx_bri(jpi,jpj) , sfx_dyn(jpi,jpj) , & 448 & sfx_bog(jpi,jpj) , sfx_bom(jpi,jpj) , sfx_sum(jpi,jpj) , sfx_sni(jpi,jpj) , sfx_opw(jpi,jpj) , & 449 & hfx_res(jpi,jpj) , hfx_snw(jpi,jpj) , hfx_sub(jpi,jpj) , hfx_err(jpi,jpj) , hfx_err_rem(jpi,jpj), & 450 & hfx_in (jpi,jpj) , hfx_out(jpi,jpj) , fhld(jpi,jpj) , & 451 & hfx_sum(jpi,jpj) , hfx_bom(jpi,jpj) , hfx_bog(jpi,jpj) , hfx_dif(jpi,jpj) , hfx_opw(jpi,jpj) , & 452 & hfx_thd(jpi,jpj) , hfx_dyn(jpi,jpj) , hfx_spr(jpi,jpj) , STAT=ierr(ii) ) 464 453 465 454 ! * Ice global state variables … … 475 464 & bv_i (jpi,jpj) , smt_i(jpi,jpj) , STAT=ierr(ii) ) 476 465 ii = ii + 1 477 ALLOCATE( t_s(jpi,jpj,nlay_s,jpl) , at_i_typ(jpi,jpj,jpm) ,&478 & e_s(jpi,jpj,nlay_s,jpl) , vt_i_typ(jpi,jpj,jpm) , e_i_cat(jpi,jpj,jpl) ,STAT=ierr(ii) )479 ii = ii + 1 480 ALLOCATE( t_i(jpi,jpj, jkmax,jpl) , e_i(jpi,jpj,jkmax,jpl) , s_i(jpi,jpj,jkmax,jpl) , STAT=ierr(ii) )466 ALLOCATE( t_s(jpi,jpj,nlay_s,jpl) , & 467 & e_s(jpi,jpj,nlay_s,jpl) , STAT=ierr(ii) ) 468 ii = ii + 1 469 ALLOCATE( t_i(jpi,jpj,nlay_i+1,jpl) , e_i(jpi,jpj,nlay_i+1,jpl) , s_i(jpi,jpj,nlay_i+1,jpl) , STAT=ierr(ii) ) 481 470 482 471 ! * Moments for advection … … 494 483 & STAT=ierr(ii) ) 495 484 ii = ii + 1 496 ALLOCATE( sxe (jpi,jpj, jkmax,jpl) , sye (jpi,jpj,jkmax,jpl) , sxxe(jpi,jpj,jkmax,jpl) , &497 & syye(jpi,jpj, jkmax,jpl) , sxye(jpi,jpj,jkmax,jpl) , STAT=ierr(ii) )485 ALLOCATE( sxe (jpi,jpj,nlay_i+1,jpl) , sye (jpi,jpj,nlay_i+1,jpl) , sxxe(jpi,jpj,nlay_i+1,jpl) , & 486 & syye(jpi,jpj,nlay_i+1,jpl) , sxye(jpi,jpj,nlay_i+1,jpl) , STAT=ierr(ii) ) 498 487 499 488 ! * Old values of global variables 500 489 ii = ii + 1 501 ALLOCATE( old_v_s (jpi,jpj,jpl) , old_v_i (jpi,jpj,jpl) , old_e_s(jpi,jpj,nlay_s,jpl) , &502 & old_a_i (jpi,jpj,jpl) , old_smv_i(jpi,jpj,jpl) , old_e_i(jpi,jpj,jkmax,jpl) , &503 & o ld_oa_i(jpi,jpj,jpl) , &504 & old_u_ice(jpi,jpj) , old_v_ice(jpi,jpj) , STAT=ierr(ii) )490 ALLOCATE( v_s_b (jpi,jpj,jpl) , v_i_b (jpi,jpj,jpl) , e_s_b(jpi,jpj,nlay_s,jpl) , & 491 & a_i_b (jpi,jpj,jpl) , smv_i_b(jpi,jpj,jpl) , e_i_b(jpi,jpj,nlay_i+1 ,jpl) , & 492 & oa_i_b (jpi,jpj,jpl) , & 493 & u_ice_b(jpi,jpj) , v_ice_b(jpi,jpj) , STAT=ierr(ii) ) 505 494 506 495 ! * Increment of global variables … … 509 498 & d_v_i_thd(jpi,jpj,jpl) , d_v_i_trp (jpi,jpj,jpl) , d_smv_i_thd(jpi,jpj,jpl) , d_smv_i_trp(jpi,jpj,jpl) , & 510 499 & d_sm_i_fl(jpi,jpj,jpl) , d_sm_i_gd (jpi,jpj,jpl) , d_sm_i_se (jpi,jpj,jpl) , d_sm_i_si (jpi,jpj,jpl) , & 511 & d_sm_i_la(jpi,jpj,jpl) , d_oa_i_thd(jpi,jpj,jpl) , d_oa_i_trp (jpi,jpj,jpl) , s_i_newice (jpi,jpj,jpl) ,&500 & d_sm_i_la(jpi,jpj,jpl) , d_oa_i_thd(jpi,jpj,jpl) , d_oa_i_trp (jpi,jpj,jpl) , & 512 501 & STAT=ierr(ii) ) 513 502 ii = ii + 1 514 ALLOCATE( d_e_s_thd(jpi,jpj,nlay_s,jpl) , d_e_i_thd(jpi,jpj, jkmax,jpl) , d_u_ice_dyn(jpi,jpj) , &515 & d_e_s_trp(jpi,jpj,nlay_s,jpl) , d_e_i_trp(jpi,jpj, jkmax,jpl) , d_v_ice_dyn(jpi,jpj) , STAT=ierr(ii) )503 ALLOCATE( d_e_s_thd(jpi,jpj,nlay_s,jpl) , d_e_i_thd(jpi,jpj,nlay_i,jpl) , d_u_ice_dyn(jpi,jpj) , & 504 & d_e_s_trp(jpi,jpj,nlay_s,jpl) , d_e_i_trp(jpi,jpj,nlay_i,jpl) , d_v_ice_dyn(jpi,jpj) , STAT=ierr(ii) ) 516 505 517 506 ! * Ice thickness distribution variables 518 507 ii = ii + 1 519 ALLOCATE( ice_types(jpl) , ice_cat_bounds(jpm,2) , ice_ncat_types (jpm) , & 520 & hi_max (0:jpl) , hi_mean(jpl) , hi_max_typ(0:jpl,jpm) , STAT=ierr(ii) ) 508 ALLOCATE( hi_max(0:jpl), hi_mean(jpl), STAT=ierr(ii) ) 521 509 522 510 ! * Ice diagnostics 523 511 ii = ii + 1 524 ALLOCATE( dv_dt_thd(jpi,jpj,jpl) , diag_sni_gr(jpi,jpj) , diag_lat_gr(jpi,jpj) , & 525 & izero (jpi,jpj,jpl) , diag_bot_gr(jpi,jpj) , diag_dyn_gr(jpi,jpj) , & 526 & fstroc (jpi,jpj,jpl) , diag_bot_me(jpi,jpj) , diag_sur_me(jpi,jpj) , & 527 & fhbricat (jpi,jpj,jpl) , diag_res_pr(jpi,jpj) , diag_trp_vi(jpi,jpj) , v_newice(jpi,jpj) , STAT=ierr(ii) ) 512 ALLOCATE( dv_dt_thd(jpi,jpj,jpl), & 513 & diag_trp_vi(jpi,jpj), diag_trp_vs (jpi,jpj), diag_trp_ei(jpi,jpj), & 514 & diag_trp_es(jpi,jpj), diag_heat_dhc(jpi,jpj), STAT=ierr(ii) ) 528 515 529 516 ice_alloc = MAXVAL( ierr(:) ) -
branches/2014/dev_r4650_UKMO14.12_STAND_ALONE_OBSOPER/NEMOGCM/NEMO/LIM_SRC_3/iceini.F90
r4624 r5034 66 66 ! 67 67 ! ! adequation jpk versus ice/snow layers/categories 68 IF( jpl > jpk .OR. jpm > jpk .OR.&69 jkmax > jpk .OR. nlay_s > jpk ) CALL ctl_stop( 'STOP',&68 IF( jpl > jpk .OR. (nlay_i+1) > jpk .OR. nlay_s > jpk ) & 69 & CALL ctl_stop( 'STOP', & 70 70 & 'ice_init: the 3rd dimension of workspace arrays is too small.', & 71 71 & 'use more ocean levels or less ice/snow layers/categories.' ) … … 89 89 CALL lim_itd_ini ! ice thickness distribution initialization 90 90 ! 91 CALL lim_itd_me_init ! ice thickness distribution initialization 91 92 ! ! Initial sea-ice state 92 93 IF( .NOT. ln_rstart ) THEN ! start from rest … … 173 174 !! limistate (only) and is changed to 99 m in ice_init 174 175 !!------------------------------------------------------------------ 175 INTEGER :: jl , jm! dummy loop index176 INTEGER :: jl ! dummy loop index 176 177 REAL(wp) :: zc1, zc2, zc3, zx1 ! local scalars 177 178 !!------------------------------------------------------------------ … … 184 185 ! 1) Ice thickness distribution parameters initialization 185 186 !------------------------------------------------------------------------------! 186 187 !- Types boundaries (integer)188 !----------------------------189 ice_cat_bounds(1,1) = 1190 ice_cat_bounds(1,2) = jpl191 192 !- Number of ice thickness categories in each ice type193 DO jm = 1, jpm194 ice_ncat_types(jm) = ice_cat_bounds(jm,2) - ice_cat_bounds(jm,1) + 1195 END DO196 197 !- Make the correspondence between thickness categories and ice types198 !---------------------------------------------------------------------199 DO jm = 1, jpm !over types200 DO jl = ice_cat_bounds(jm,1), ice_cat_bounds(jm,2) !over thickness categories201 ice_types(jl) = jm202 END DO203 END DO204 205 187 IF(lwp) THEN 206 WRITE(numout,*) ' Number of ice types jpm = ', jpm207 188 WRITE(numout,*) ' Number of ice categories jpl = ', jpl 208 DO jm = 1, jpm209 WRITE(numout,*) ' Ice type ', jm210 WRITE(numout,*) ' Number of thickness categories ', ice_ncat_types(jm)211 WRITE(numout,*) ' Thickness category boundaries ', ice_cat_bounds(jm,1:2)212 END DO213 WRITE(numout,*) 'Ice type vector', ice_types(1:jpl)214 WRITE(numout,*)215 189 ENDIF 216 190 … … 218 192 !---------------------------------- 219 193 hi_max(:) = 0._wp 220 hi_max_typ(:,:) = 0._wp 221 222 !- Type 1 - undeformed ice 223 zc1 = 3._wp / REAL( ice_cat_bounds(1,2) - ice_cat_bounds(1,1) + 1 , wp ) 194 195 zc1 = 3._wp / REAL( jpl, wp ) 224 196 zc2 = 10._wp * zc1 225 197 zc3 = 3._wp 226 198 227 DO jl = ice_cat_bounds(1,1), ice_cat_bounds(1,2)228 zx1 = REAL( jl-1 , wp ) / REAL( ice_cat_bounds(1,2) - ice_cat_bounds(1,1) + 1, wp )199 DO jl = 1, jpl 200 zx1 = REAL( jl-1, wp ) / REAL( jpl, wp ) 229 201 hi_max(jl) = hi_max(jl-1) + zc1 + zc2 * (1._wp + TANH( zc3 * (zx1 - 1._wp ) ) ) 230 202 END DO 231 203 232 !- Fill in the hi_max_typ vector, useful in other circumstances 233 ! Tricky trick: hi_max_typ is actually not used in the code and will be removed in a 234 ! next flyspray at this time, the tricky trick will also be removed (Martin, march 08) 235 DO jl = ice_cat_bounds(1,1), ice_cat_bounds(1,2) 236 hi_max_typ(jl,1) = hi_max(jl) 237 END DO 238 239 IF(lwp) WRITE(numout,*) ' Thickness category boundaries independently of ice type ' 204 IF(lwp) WRITE(numout,*) ' Thickness category boundaries ' 240 205 IF(lwp) WRITE(numout,*) ' hi_max ', hi_max(0:jpl) 241 206 242 IF(lwp) WRITE(numout,*) ' Thickness category boundaries inside ice types '243 IF(lwp) THEN244 DO jm = 1, jpm245 WRITE(numout,*) ' Type number ', jm246 WRITE(numout,*) ' hi_max_typ : ', hi_max_typ(0:ice_ncat_types(jm),jm)247 END DO248 ENDIF249 207 ! 250 208 DO jl = 1, jpl -
branches/2014/dev_r4650_UKMO14.12_STAND_ALONE_OBSOPER/NEMOGCM/NEMO/LIM_SRC_3/limadv.F90
r4161 r5034 30 30 PUBLIC lim_adv_x ! called by lim_trp 31 31 PUBLIC lim_adv_y ! called by lim_trp 32 33 REAL(wp) :: epsi20 = 1.e-20_wp ! constant values34 REAL(wp) :: rzero = 0._wp ! - -35 REAL(wp) :: rone = 1._wp ! - -36 32 37 33 !! * Substitutions … … 84 80 DO jj = 1, jpj 85 81 DO ji = 1, jpi 86 zslpmax = MAX( rzero, ps0(ji,jj) )82 zslpmax = MAX( 0._wp, ps0(ji,jj) ) 87 83 zs1max = 1.5 * zslpmax 88 84 zs1new = MIN( zs1max, MAX( -zs1max, psx(ji,jj) ) ) 89 85 zs2new = MIN( 2.0 * zslpmax - 0.3334 * ABS( zs1new ), & 90 86 & MAX( ABS( zs1new ) - zslpmax, psxx(ji,jj) ) ) 91 zin0 = ( 1.0 - MAX( rzero, SIGN( rone, -zslpmax) ) ) * tms(ji,jj) ! Case of empty boxes & Apply mask87 zin0 = ( 1.0 - MAX( 0._wp, SIGN( 1._wp, -zslpmax) ) ) * tms(ji,jj) ! Case of empty boxes & Apply mask 92 88 93 89 ps0 (ji,jj) = zslpmax … … 106 102 DO jj = 1, jpj ! Flux from i to i+1 WHEN u GT 0 107 103 DO ji = 1, jpi 108 zbet(ji,jj) = MAX( rzero, SIGN( rone, put(ji,jj) ) )109 zalf = MAX( rzero, put(ji,jj) ) * zrdt * e2u(ji,jj) / psm(ji,jj)104 zbet(ji,jj) = MAX( 0._wp, SIGN( 1._wp, put(ji,jj) ) ) 105 zalf = MAX( 0._wp, put(ji,jj) ) * zrdt * e2u(ji,jj) / psm(ji,jj) 110 106 zalfq = zalf * zalf 111 107 zalf1 = 1.0 - zalf … … 133 129 DO jj = 1, jpjm1 ! Flux from i+1 to i when u LT 0. 134 130 DO ji = 1, fs_jpim1 135 zalf = MAX( rzero, -put(ji,jj) ) * zrdt * e2u(ji,jj) / psm(ji+1,jj)131 zalf = MAX( 0._wp, -put(ji,jj) ) * zrdt * e2u(ji,jj) / psm(ji+1,jj) 136 132 zalg (ji,jj) = zalf 137 133 zalfq = zalf * zalf … … 269 265 DO jj = 1, jpj 270 266 DO ji = 1, jpi 271 zslpmax = MAX( rzero, ps0(ji,jj) )267 zslpmax = MAX( 0._wp, ps0(ji,jj) ) 272 268 zs1max = 1.5 * zslpmax 273 269 zs1new = MIN( zs1max, MAX( -zs1max, psy(ji,jj) ) ) 274 270 zs2new = MIN( ( 2.0 * zslpmax - 0.3334 * ABS( zs1new ) ), & 275 271 & MAX( ABS( zs1new )-zslpmax, psyy(ji,jj) ) ) 276 zin0 = ( 1.0 - MAX( rzero, SIGN( rone, -zslpmax) ) ) * tms(ji,jj) ! Case of empty boxes & Apply mask272 zin0 = ( 1.0 - MAX( 0._wp, SIGN( 1._wp, -zslpmax) ) ) * tms(ji,jj) ! Case of empty boxes & Apply mask 277 273 ! 278 274 ps0 (ji,jj) = zslpmax … … 291 287 DO jj = 1, jpj ! Flux from j to j+1 WHEN v GT 0 292 288 DO ji = 1, jpi 293 zbet(ji,jj) = MAX( rzero, SIGN( rone, pvt(ji,jj) ) )294 zalf = MAX( rzero, pvt(ji,jj) ) * zrdt * e1v(ji,jj) / psm(ji,jj)289 zbet(ji,jj) = MAX( 0._wp, SIGN( 1._wp, pvt(ji,jj) ) ) 290 zalf = MAX( 0._wp, pvt(ji,jj) ) * zrdt * e1v(ji,jj) / psm(ji,jj) 295 291 zalfq = zalf * zalf 296 292 zalf1 = 1.0 - zalf … … 318 314 DO jj = 1, jpjm1 ! Flux from j+1 to j when v LT 0. 319 315 DO ji = 1, jpi 320 zalf = ( MAX( rzero, -pvt(ji,jj) ) * zrdt * e1v(ji,jj) ) / psm(ji,jj+1)316 zalf = ( MAX(0._wp, -pvt(ji,jj) ) * zrdt * e1v(ji,jj) ) / psm(ji,jj+1) 321 317 zalg (ji,jj) = zalf 322 318 zalfq = zalf * zalf -
branches/2014/dev_r4650_UKMO14.12_STAND_ALONE_OBSOPER/NEMOGCM/NEMO/LIM_SRC_3/limcons.F90
r4161 r5034 7 7 !! 3.0 ! 2004-06 (M. Vancoppenolle) Energy Conservation 8 8 !! 4.0 ! 2011-02 (G. Madec) add mpp considerations 9 !! - ! 2014-05 (C. Rousset) add lim_cons_hsm 9 10 !!---------------------------------------------------------------------- 10 11 #if defined key_lim3 … … 14 15 !! lim_cons : checks whether energy, mass and salt are conserved 15 16 !!---------------------------------------------------------------------- 17 USE phycst ! physical constants 16 18 USE par_ice ! LIM-3 parameter 17 19 USE ice ! LIM-3 variables … … 28 30 PUBLIC lim_column_sum_energy 29 31 PUBLIC lim_cons_check 32 PUBLIC lim_cons_hsm 30 33 31 34 !!---------------------------------------------------------------------- … … 70 73 !! ** Method : Arithmetics 71 74 !!--------------------------------------------------------------------- 72 INTEGER , INTENT(in ) :: ksum !: number of categories73 INTEGER , INTENT(in ) :: klay !: number of vertical layers74 REAL(wp), DIMENSION(jpi,jpj, jkmax,jpl), INTENT(in ) :: pin !: input field75 REAL(wp), DIMENSION(jpi,jpj) , INTENT( out) :: pout !: output field75 INTEGER , INTENT(in ) :: ksum !: number of categories 76 INTEGER , INTENT(in ) :: klay !: number of vertical layers 77 REAL(wp), DIMENSION(jpi,jpj,nlay_i+1,jpl), INTENT(in ) :: pin !: input field 78 REAL(wp), DIMENSION(jpi,jpj) , INTENT( out) :: pout !: output field 76 79 ! 77 80 INTEGER :: jk, jl ! dummy loop indices … … 151 154 END SUBROUTINE lim_cons_check 152 155 156 157 SUBROUTINE lim_cons_hsm( icount, cd_routine, zvi_b, zsmv_b, zei_b, zfw_b, zfs_b, zft_b ) 158 !!------------------------------------------------------------------- 159 !! *** ROUTINE lim_cons_hsm *** 160 !! 161 !! ** Purpose : Test the conservation of heat, salt and mass for each routine 162 !! 163 !! ** Method : 164 !!--------------------------------------------------------------------- 165 INTEGER , INTENT(in) :: icount ! determine wether this is the beggining of the routine (0) or the end (1) 166 CHARACTER(len=*), INTENT(in) :: cd_routine ! name of the routine 167 REAL(wp) , INTENT(inout) :: zvi_b, zsmv_b, zei_b, zfs_b, zfw_b, zft_b 168 REAL(wp) :: zvi, zsmv, zei, zfs, zfw, zft 169 REAL(wp) :: zvmin, zamin, zamax 170 171 IF( icount == 0 ) THEN 172 173 zvi_b = glob_sum( SUM( v_i(:,:,:)*rhoic + v_s(:,:,:)*rhosn, dim=3 ) * area(:,:) * tms(:,:) ) 174 zsmv_b = glob_sum( SUM( smv_i(:,:,:), dim=3 ) * area(:,:) * tms(:,:) ) 175 zei_b = glob_sum( SUM( e_i(:,:,1:nlay_i,:), dim=3 ) + SUM( e_s(:,:,1:nlay_s,:), dim=3 ) ) 176 zfw_b = glob_sum( - ( wfx_bog(:,:) + wfx_bom(:,:) + wfx_sum(:,:) + wfx_sni(:,:) + wfx_opw(:,:) + & 177 & wfx_res(:,:) + wfx_dyn(:,:) + wfx_snw(:,:) + wfx_sub(:,:) + wfx_spr(:,:) & 178 & ) * area(:,:) * tms(:,:) ) 179 zfs_b = glob_sum( ( sfx_bri(:,:) + sfx_bog(:,:) + sfx_bom(:,:) + sfx_sum(:,:) + sfx_sni(:,:) + & 180 & sfx_opw(:,:) + sfx_res(:,:) + sfx_dyn(:,:) & 181 & ) * area(:,:) * tms(:,:) ) 182 zft_b = glob_sum( ( hfx_sum(:,:) + hfx_bom(:,:) + hfx_bog(:,:) + hfx_dif(:,:) + hfx_opw(:,:) + hfx_snw(:,:) & 183 & - hfx_thd(:,:) - hfx_dyn(:,:) - hfx_res(:,:) - hfx_sub(:,:) - hfx_spr(:,:) & 184 & ) * area(:,:) / unit_fac * tms(:,:) ) 185 186 ELSEIF( icount == 1 ) THEN 187 188 zfs = glob_sum( ( sfx_bri(:,:) + sfx_bog(:,:) + sfx_bom(:,:) + sfx_sum(:,:) + sfx_sni(:,:) + & 189 & sfx_opw(:,:) + sfx_res(:,:) + sfx_dyn(:,:) & 190 & ) * area(:,:) * tms(:,:) ) - zfs_b 191 zfw = glob_sum( - ( wfx_bog(:,:) + wfx_bom(:,:) + wfx_sum(:,:) + wfx_sni(:,:) + wfx_opw(:,:) + & 192 & wfx_res(:,:) + wfx_dyn(:,:) + wfx_snw(:,:) + wfx_sub(:,:) + wfx_spr(:,:) & 193 & ) * area(:,:) * tms(:,:) ) - zfw_b 194 zft = glob_sum( ( hfx_sum(:,:) + hfx_bom(:,:) + hfx_bog(:,:) + hfx_dif(:,:) + hfx_opw(:,:) + hfx_snw(:,:) & 195 & - hfx_thd(:,:) - hfx_dyn(:,:) - hfx_res(:,:) - hfx_sub(:,:) - hfx_spr(:,:) & 196 & ) * area(:,:) / unit_fac * tms(:,:) ) - zft_b 197 198 zvi = ( glob_sum( SUM( v_i(:,:,:)*rhoic + v_s(:,:,:)*rhosn, dim=3 ) * area(:,:) * tms(:,:) ) - zvi_b ) * r1_rdtice - zfw 199 zsmv = ( glob_sum( SUM( smv_i(:,:,:), dim=3 ) * area(:,:) * tms(:,:) ) - zsmv_b ) * r1_rdtice + ( zfs / rhoic ) 200 zei = glob_sum( SUM( e_i(:,:,1:nlay_i,:), dim=3 ) + SUM( e_s(:,:,1:nlay_s,:), dim=3 ) ) * r1_rdtice - zei_b * r1_rdtice + zft 201 202 zvmin = glob_min(v_i) 203 zamax = glob_max(SUM(a_i,dim=3)) 204 zamin = glob_min(a_i) 205 206 IF(lwp) THEN 207 IF ( ABS( zvi ) > 1.e-4 ) WRITE(numout,*) 'violation volume [kg/day] (',cd_routine,') = ',(zvi * rday) 208 IF ( ABS( zsmv ) > 1.e-4 ) WRITE(numout,*) 'violation saline [psu*m3/day] (',cd_routine,') = ',(zsmv * rday) 209 IF ( ABS( zei ) > 1. ) WRITE(numout,*) 'violation enthalpy [1e9 J] (',cd_routine,') = ',(zei) 210 IF ( zvmin < 0. ) WRITE(numout,*) 'violation v_i<0 [m] (',cd_routine,') = ',(zvmin) 211 IF( cd_routine /= 'limtrp' .AND. cd_routine /= 'limitd_me' .AND. zamax > amax+1.e-10 ) THEN 212 WRITE(numout,*) 'violation a_i>amax (',cd_routine,') = ',zamax 213 ENDIF 214 IF ( zamin < 0. ) WRITE(numout,*) 'violation a_i<0 (',cd_routine,') = ',zamin 215 ENDIF 216 217 ENDIF 218 219 END SUBROUTINE lim_cons_hsm 220 153 221 #else 154 222 !!---------------------------------------------------------------------- -
branches/2014/dev_r4650_UKMO14.12_STAND_ALONE_OBSOPER/NEMOGCM/NEMO/LIM_SRC_3/limdiahsb.F90
r4346 r5034 18 18 USE dom_oce ! ocean domain 19 19 USE sbc_oce ! surface boundary condition: ocean fields 20 USE sbc_ice ! Surface boundary condition: sea-ice fields 20 21 USE daymod ! model calendar 21 22 USE phycst ! physical constant … … 34 35 !!PUBLIC lim_diahsb_rst ! routine called by ice_init.F90 35 36 36 REAL(dp) :: frc_sal, frc_vol ! global forcing trends 37 REAL(dp) :: bg_grme ! global ice growth+melt trends 38 REAL(wp) :: epsi06 = 1.e-6_wp ! small number 39 REAL(wp) :: epsi03 = 1.e-3_wp ! small number 40 37 real(wp) :: frc_sal, frc_vol ! global forcing trends 38 real(wp) :: bg_grme ! global ice growth+melt trends 41 39 42 40 !! * Substitutions … … 59 57 !!--------------------------------------------------------------------------- 60 58 !! 61 REAL(dp) :: zbg_ivo, zbg_svo, zbg_are, zbg_sal ,zbg_tem ,zbg_ihc ,zbg_shc 62 REAL(dp) :: zbg_sfx, zbg_sfx_bri, zbg_sfx_thd, zbg_sfx_res, zbg_sfx_mec 63 REAL(dp) :: zbg_emp, zbg_emp_bog, zbg_emp_lag, zbg_emp_sig, zbg_emp_dyg, zbg_emp_bom, zbg_emp_sum, zbg_emp_res 64 REAL(dp) :: z_frc_vol, z_frc_sal, z_bg_grme 65 REAL(dp) :: z1_area ! - - 66 REAL(dp) :: zinda, zindb 59 real(wp) :: zbg_ivo, zbg_svo, zbg_are, zbg_sal ,zbg_tem ,zbg_ihc ,zbg_shc 60 real(wp) :: zbg_sfx, zbg_sfx_bri, zbg_sfx_bog, zbg_sfx_bom, zbg_sfx_sum, zbg_sfx_sni, & 61 & zbg_sfx_opw, zbg_sfx_res, zbg_sfx_dyn 62 real(wp) :: zbg_vfx, zbg_vfx_bog, zbg_vfx_opw, zbg_vfx_sni, zbg_vfx_dyn 63 real(wp) :: zbg_vfx_bom, zbg_vfx_sum, zbg_vfx_res, zbg_vfx_spr, zbg_vfx_snw, zbg_vfx_sub 64 real(wp) :: zbg_hfx_dhc, zbg_hfx_spr 65 real(wp) :: zbg_hfx_res, zbg_hfx_sub, zbg_hfx_dyn, zbg_hfx_thd, zbg_hfx_snw, zbg_hfx_out, zbg_hfx_in 66 real(wp) :: zbg_hfx_sum, zbg_hfx_bom, zbg_hfx_bog, zbg_hfx_dif, zbg_hfx_opw 67 real(wp) :: z_frc_vol, z_frc_sal, z_bg_grme 68 real(wp) :: z1_area ! - - 69 REAL(wp) :: ztmp 67 70 !!--------------------------------------------------------------------------- 68 71 IF( nn_timing == 1 ) CALL timing_start('lim_diahsb') … … 71 74 72 75 ! 1/area 73 z1_area = 1. d0/ MAX( glob_sum( area(:,:) * tms(:,:) ), epsi06 )74 75 zinda = MAX( 0.d0 , SIGN( 1.d0, glob_sum( area(:,:) * tms(:,:) ) - epsi06 ) )76 z1_area = 1._wp / MAX( glob_sum( area(:,:) * tms(:,:) ), epsi06 ) 77 78 rswitch = MAX( 0._wp , SIGN( 1._wp , glob_sum( area(:,:) * tms(:,:) ) - epsi06 ) ) 76 79 ! ----------------------- ! 77 80 ! 1 - Content variations ! … … 86 89 !zbg_shc = glob_sum( et_s(:,:) * area(:,:) * tms(:,:) ) / MAX( zbg_svo,epsi06 ) ! snow heat content 87 90 88 zbg_ihc = glob_sum( et_i(:,:) * 1.e-11 ) ! ice heat content [10^9*1.e-11 J] 89 zbg_shc = glob_sum( et_s(:,:) * 1.e-11 ) ! snow heat content [10^9*1.e-11 J] 90 91 zbg_emp = zinda * glob_sum( emp(:,:) * area(:,:) * tms(:,:) ) * z1_area * r1_rau0 * rday 92 zbg_emp_bog = zinda * glob_sum( diag_bot_gr(:,:) * area(:,:) * tms(:,:) ) * z1_area * rhoic * r1_rau0 * rday 93 zbg_emp_lag = zinda * glob_sum( diag_lat_gr(:,:) * area(:,:) * tms(:,:) ) * z1_area * rhoic * r1_rau0 * rday 94 zbg_emp_sig = zinda * glob_sum( diag_sni_gr(:,:) * area(:,:) * tms(:,:) ) * z1_area * rhoic * r1_rau0 * rday 95 zbg_emp_dyg = zinda * glob_sum( diag_dyn_gr(:,:) * area(:,:) * tms(:,:) ) * z1_area * rhoic * r1_rau0 * rday 96 zbg_emp_bom = zinda * glob_sum( diag_bot_me(:,:) * area(:,:) * tms(:,:) ) * z1_area * rhoic * r1_rau0 * rday 97 zbg_emp_sum = zinda * glob_sum( diag_sur_me(:,:) * area(:,:) * tms(:,:) ) * z1_area * rhoic * r1_rau0 * rday 98 zbg_emp_res = zinda * glob_sum( diag_res_pr(:,:) * area(:,:) * tms(:,:) ) * z1_area * rhoic * r1_rau0 * rday 99 100 zbg_sfx = zinda * glob_sum( sfx(:,:) * area(:,:) * tms(:,:) ) * z1_area * r1_rau0 * rday 101 zbg_sfx_bri = zinda * glob_sum( sfx_bri(:,:) * area(:,:) * tms(:,:) ) * z1_area * r1_rau0 * rday 102 zbg_sfx_thd = zinda * glob_sum( sfx_thd(:,:) * area(:,:) * tms(:,:) ) * z1_area * r1_rau0 * rday 103 zbg_sfx_res = zinda * glob_sum( sfx_res(:,:) * area(:,:) * tms(:,:) ) * z1_area * r1_rau0 * rday 104 zbg_sfx_mec = zinda * glob_sum( sfx_mec(:,:) * area(:,:) * tms(:,:) ) * z1_area * r1_rau0 * rday 105 91 ! Volume 92 ztmp = rswitch * z1_area * r1_rau0 * rday 93 zbg_vfx = ztmp * glob_sum( emp(:,:) * area(:,:) * tms(:,:) ) 94 zbg_vfx_bog = ztmp * glob_sum( wfx_bog(:,:) * area(:,:) * tms(:,:) ) 95 zbg_vfx_opw = ztmp * glob_sum( wfx_opw(:,:) * area(:,:) * tms(:,:) ) 96 zbg_vfx_sni = ztmp * glob_sum( wfx_sni(:,:) * area(:,:) * tms(:,:) ) 97 zbg_vfx_dyn = ztmp * glob_sum( wfx_dyn(:,:) * area(:,:) * tms(:,:) ) 98 zbg_vfx_bom = ztmp * glob_sum( wfx_bom(:,:) * area(:,:) * tms(:,:) ) 99 zbg_vfx_sum = ztmp * glob_sum( wfx_sum(:,:) * area(:,:) * tms(:,:) ) 100 zbg_vfx_res = ztmp * glob_sum( wfx_res(:,:) * area(:,:) * tms(:,:) ) 101 zbg_vfx_spr = ztmp * glob_sum( wfx_spr(:,:) * area(:,:) * tms(:,:) ) 102 zbg_vfx_snw = ztmp * glob_sum( wfx_snw(:,:) * area(:,:) * tms(:,:) ) 103 zbg_vfx_sub = ztmp * glob_sum( wfx_sub(:,:) * area(:,:) * tms(:,:) ) 104 105 ! Salt 106 zbg_sfx = ztmp * glob_sum( sfx(:,:) * area(:,:) * tms(:,:) ) 107 zbg_sfx_bri = ztmp * glob_sum( sfx_bri(:,:) * area(:,:) * tms(:,:) ) 108 zbg_sfx_res = ztmp * glob_sum( sfx_res(:,:) * area(:,:) * tms(:,:) ) 109 zbg_sfx_dyn = ztmp * glob_sum( sfx_dyn(:,:) * area(:,:) * tms(:,:) ) 110 111 zbg_sfx_bog = ztmp * glob_sum( sfx_bog(:,:) * area(:,:) * tms(:,:) ) 112 zbg_sfx_opw = ztmp * glob_sum( sfx_opw(:,:) * area(:,:) * tms(:,:) ) 113 zbg_sfx_sni = ztmp * glob_sum( sfx_sni(:,:) * area(:,:) * tms(:,:) ) 114 zbg_sfx_bom = ztmp * glob_sum( sfx_bom(:,:) * area(:,:) * tms(:,:) ) 115 zbg_sfx_sum = ztmp * glob_sum( sfx_sum(:,:) * area(:,:) * tms(:,:) ) 116 117 ! Heat budget 118 zbg_ihc = glob_sum( et_i(:,:) * 1.e-20 ) ! ice heat content [1.e-20 J] 119 zbg_shc = glob_sum( et_s(:,:) * 1.e-20 ) ! snow heat content [1.e-20 J] 120 zbg_hfx_dhc = glob_sum( diag_heat_dhc(:,:) * area(:,:) * tms(:,:) ) ! [in W] 121 zbg_hfx_spr = glob_sum( hfx_spr(:,:) * area(:,:) * tms(:,:) ) ! [in W] 122 123 zbg_hfx_thd = glob_sum( hfx_thd(:,:) * area(:,:) * tms(:,:) ) ! [in W] 124 zbg_hfx_dyn = glob_sum( hfx_dyn(:,:) * area(:,:) * tms(:,:) ) ! [in W] 125 zbg_hfx_res = glob_sum( hfx_res(:,:) * area(:,:) * tms(:,:) ) ! [in W] 126 zbg_hfx_sub = glob_sum( hfx_sub(:,:) * area(:,:) * tms(:,:) ) ! [in W] 127 zbg_hfx_snw = glob_sum( hfx_snw(:,:) * area(:,:) * tms(:,:) ) ! [in W] 128 zbg_hfx_sum = glob_sum( hfx_sum(:,:) * area(:,:) * tms(:,:) ) ! [in W] 129 zbg_hfx_bom = glob_sum( hfx_bom(:,:) * area(:,:) * tms(:,:) ) ! [in W] 130 zbg_hfx_bog = glob_sum( hfx_bog(:,:) * area(:,:) * tms(:,:) ) ! [in W] 131 zbg_hfx_dif = glob_sum( hfx_dif(:,:) * area(:,:) * tms(:,:) ) ! [in W] 132 zbg_hfx_opw = glob_sum( hfx_opw(:,:) * area(:,:) * tms(:,:) ) ! [in W] 133 zbg_hfx_out = glob_sum( hfx_out(:,:) * area(:,:) * tms(:,:) ) ! [in W] 134 zbg_hfx_in = glob_sum( hfx_in(:,:) * area(:,:) * tms(:,:) ) ! [in W] 135 106 136 ! --------------------------------------------- ! 107 137 ! 2 - Trends due to forcing and ice growth/melt ! … … 109 139 z_frc_vol = r1_rau0 * glob_sum( - emp(:,:) * area(:,:) * tms(:,:) ) ! volume fluxes 110 140 z_frc_sal = r1_rau0 * glob_sum( sfx(:,:) * area(:,:) * tms(:,:) ) ! salt fluxes 111 z_bg_grme = glob_sum( ( diag_bot_gr(:,:) + diag_lat_gr(:,:) + diag_sni_gr(:,:) + diag_dyn_gr(:,:) + &112 & diag_bot_me(:,:) + diag_sur_me(:,:) + diag_res_pr(:,:) ) * area(:,:) * tms(:,:) ) ! volume fluxes141 z_bg_grme = glob_sum( - ( wfx_bog(:,:) + wfx_opw(:,:) + wfx_sni(:,:) + wfx_dyn(:,:) + & 142 & wfx_bom(:,:) + wfx_sum(:,:) + wfx_res(:,:) + wfx_snw(:,:) + wfx_sub(:,:) ) * area(:,:) * tms(:,:) ) ! volume fluxes 113 143 ! 114 144 frc_vol = frc_vol + z_frc_vol * rdt_ice … … 123 153 ! 3 - Diagnostics writing ! 124 154 ! ----------------------- ! 125 zindb = MAX( 0.d0 , SIGN( 1.d0 , zbg_ivo - epsi06 ) ) 126 ! 155 rswitch = MAX( 0._wp , SIGN( 1._wp , zbg_ivo - epsi06 ) ) 156 ! 157 IF( iom_use('ibgvoltot') ) & 127 158 CALL iom_put( 'ibgvoltot' , zbg_ivo * rhoic * r1_rau0 * 1.e-9 ) ! ice volume (km3 equivalent liquid) 159 IF( iom_use('sbgvoltot') ) & 128 160 CALL iom_put( 'sbgvoltot' , zbg_svo * rhosn * r1_rau0 * 1.e-9 ) ! snw volume (km3 equivalent liquid) 161 IF( iom_use('ibgarea') ) & 129 162 CALL iom_put( 'ibgarea' , zbg_are * 1.e-6 ) ! ice area (km2) 130 CALL iom_put( 'ibgsaline' , zindb * zbg_sal / MAX( zbg_ivo, epsi06 ) ) ! ice saline (psu) 131 CALL iom_put( 'ibgtemper' , zindb * zbg_tem / MAX( zbg_ivo, epsi06 ) ) ! ice temper (C) 163 IF( iom_use('ibgsaline') ) & 164 CALL iom_put( 'ibgsaline' , rswitch * zbg_sal / MAX( zbg_ivo, epsi06 ) ) ! ice saline (psu) 165 IF( iom_use('ibgtemper') ) & 166 CALL iom_put( 'ibgtemper' , rswitch * zbg_tem / MAX( zbg_ivo, epsi06 ) ) ! ice temper (C) 132 167 CALL iom_put( 'ibgheatco' , zbg_ihc ) ! ice heat content (1.e20 J) 133 168 CALL iom_put( 'sbgheatco' , zbg_shc ) ! snw heat content (1.e20 J) 169 IF( iom_use('ibgsaltco') ) & 134 170 CALL iom_put( 'ibgsaltco' , zbg_sal * rhoic * r1_rau0 * 1.e-9 ) ! ice salt content (psu*km3 equivalent liquid) 135 171 136 CALL iom_put( 'ibgemp' , zbg_emp ) ! volume flux emp (m/day liquid) 137 CALL iom_put( 'ibgempbog' , zbg_emp_bog ) ! volume flux bottom growth -(m/day equivalent liquid) 138 CALL iom_put( 'ibgemplag' , zbg_emp_lag ) ! volume flux open water growth - 139 CALL iom_put( 'ibgempsig' , zbg_emp_sig ) ! volume flux snow ice growth - 140 CALL iom_put( 'ibgempdyg' , zbg_emp_dyg ) ! volume flux dynamic growth - 141 CALL iom_put( 'ibgempbom' , zbg_emp_bom ) ! volume flux bottom melt - 142 CALL iom_put( 'ibgempsum' , zbg_emp_sum ) ! volume flux surface melt - 143 CALL iom_put( 'ibgempres' , zbg_emp_res ) ! volume flux resultant - 172 CALL iom_put( 'ibgvfx' , zbg_vfx ) ! volume flux emp (m/day liquid) 173 CALL iom_put( 'ibgvfxbog' , zbg_vfx_bog ) ! volume flux bottom growth -(m/day equivalent liquid) 174 CALL iom_put( 'ibgvfxopw' , zbg_vfx_opw ) ! volume flux open water growth - 175 CALL iom_put( 'ibgvfxsni' , zbg_vfx_sni ) ! volume flux snow ice growth - 176 CALL iom_put( 'ibgvfxdyn' , zbg_vfx_dyn ) ! volume flux dynamic growth - 177 CALL iom_put( 'ibgvfxbom' , zbg_vfx_bom ) ! volume flux bottom melt - 178 CALL iom_put( 'ibgvfxsum' , zbg_vfx_sum ) ! volume flux surface melt - 179 CALL iom_put( 'ibgvfxres' , zbg_vfx_res ) ! volume flux resultant - 180 CALL iom_put( 'ibgvfxspr' , zbg_vfx_spr ) ! volume flux from snow precip - 181 CALL iom_put( 'ibgvfxsnw' , zbg_vfx_snw ) ! volume flux from snow melt - 182 CALL iom_put( 'ibgvfxsub' , zbg_vfx_sub ) ! volume flux from sublimation - 144 183 145 184 CALL iom_put( 'ibgsfx' , zbg_sfx ) ! salt flux -(psu*m/day equivalent liquid) 146 185 CALL iom_put( 'ibgsfxbri' , zbg_sfx_bri ) ! salt flux brines - 147 CALL iom_put( 'ibgsfxthd' , zbg_sfx_thd ) ! salt flux thermo - 148 CALL iom_put( 'ibgsfxmec' , zbg_sfx_mec ) ! salt flux dynamic - 186 CALL iom_put( 'ibgsfxdyn' , zbg_sfx_dyn ) ! salt flux dynamic - 149 187 CALL iom_put( 'ibgsfxres' , zbg_sfx_res ) ! salt flux result - 188 CALL iom_put( 'ibgsfxbog' , zbg_sfx_bog ) ! salt flux bottom growth 189 CALL iom_put( 'ibgsfxopw' , zbg_sfx_opw ) ! salt flux open water growth - 190 CALL iom_put( 'ibgsfxsni' , zbg_sfx_sni ) ! salt flux snow ice growth - 191 CALL iom_put( 'ibgsfxbom' , zbg_sfx_bom ) ! salt flux bottom melt - 192 CALL iom_put( 'ibgsfxsum' , zbg_sfx_sum ) ! salt flux surface melt - 193 194 CALL iom_put( 'ibghfxdhc' , zbg_hfx_dhc ) ! Heat content variation in snow and ice [W] 195 CALL iom_put( 'ibghfxspr' , zbg_hfx_spr ) ! Heat content of snow precip [W] 196 197 CALL iom_put( 'ibghfxres' , zbg_hfx_res ) ! 198 CALL iom_put( 'ibghfxsub' , zbg_hfx_sub ) ! 199 CALL iom_put( 'ibghfxdyn' , zbg_hfx_dyn ) ! 200 CALL iom_put( 'ibghfxthd' , zbg_hfx_thd ) ! 201 CALL iom_put( 'ibghfxsnw' , zbg_hfx_snw ) ! 202 CALL iom_put( 'ibghfxsum' , zbg_hfx_sum ) ! 203 CALL iom_put( 'ibghfxbom' , zbg_hfx_bom ) ! 204 CALL iom_put( 'ibghfxbog' , zbg_hfx_bog ) ! 205 CALL iom_put( 'ibghfxdif' , zbg_hfx_dif ) ! 206 CALL iom_put( 'ibghfxopw' , zbg_hfx_opw ) ! 207 CALL iom_put( 'ibghfxout' , zbg_hfx_out ) ! 208 CALL iom_put( 'ibghfxin' , zbg_hfx_in ) ! 150 209 151 210 CALL iom_put( 'ibgfrcvol' , frc_vol * 1.e-9 ) ! vol - forcing (km3 equivalent liquid) 152 211 CALL iom_put( 'ibgfrcsfx' , frc_sal * 1.e-9 ) ! sal - forcing (psu*km3 equivalent liquid) 153 CALL iom_put( 'ibggrme' , bg_grme * rhoic * r1_rau0 * 1.e-9 ) ! vol growth + melt (km3 equivalent liquid) 212 IF( iom_use('ibgvolgrm') ) & 213 CALL iom_put( 'ibgvolgrm' , bg_grme * r1_rau0 * 1.e-9 ) ! vol growth + melt (km3 equivalent liquid) 214 154 215 ! 155 216 IF( lrst_ice ) CALL lim_diahsb_rst( numit, 'WRITE' ) … … 190 251 ! 2 - initial conservation variables ! 191 252 ! ---------------------------------- ! 192 !frc_vol = 0. d0! volume trend due to forcing193 !frc_sal = 0. d0! salt content - - - -194 !bg_grme = 0. d0! ice growth + melt volume trend253 !frc_vol = 0._wp ! volume trend due to forcing 254 !frc_sal = 0._wp ! salt content - - - - 255 !bg_grme = 0._wp ! ice growth + melt volume trend 195 256 ! 196 257 CALL lim_diahsb_rst( nstart, 'READ' ) !* read or initialize all required files … … 226 287 IF(lwp) WRITE(numout,*) ' lim_diahsb at initial state ' 227 288 IF(lwp) WRITE(numout,*) '~~~~~~~' 228 frc_vol = 0. d0229 frc_sal = 0. d0230 bg_grme = 0. d0231 ENDIF 289 frc_vol = 0._wp 290 frc_sal = 0._wp 291 bg_grme = 0._wp 292 ENDIF 232 293 233 294 ELSEIF( TRIM(cdrw) == 'WRITE' ) THEN ! Create restart file -
branches/2014/dev_r4650_UKMO14.12_STAND_ALONE_OBSOPER/NEMOGCM/NEMO/LIM_SRC_3/limdyn.F90
r4624 r5034 30 30 USE lib_fortran ! glob_sum 31 31 USE timing ! Timing 32 USE limcons ! conservation tests 32 33 33 34 IMPLICIT NONE … … 63 64 INTEGER :: i_j1, i_jpj ! Starting/ending j-indices for rheology 64 65 REAL(wp) :: zcoef ! local scalar 65 REAL(wp), POINTER, DIMENSION(:) :: z ind! i-averaged indicator of sea-ice66 REAL(wp), POINTER, DIMENSION(:) :: zswitch ! i-averaged indicator of sea-ice 66 67 REAL(wp), POINTER, DIMENSION(:) :: zmsk ! i-averaged of tmask 67 68 REAL(wp), POINTER, DIMENSION(:,:) :: zu_io, zv_io ! ice-ocean velocity 68 REAL(wp) :: zchk_v_i, zchk_smv, zchk_fs, zchk_fw, zchk_v_i_b, zchk_smv_b, zchk_fs_b, zchk_fw_b ! Check conservation (C Rousset)69 REAL(wp) :: z chk_vmin, zchk_amin, zchk_amax ! Check errors (C Rousset)69 ! 70 REAL(wp) :: zvi_b, zsmv_b, zei_b, zfs_b, zfw_b, zft_b 70 71 !!--------------------------------------------------------------------- 71 72 … … 73 74 74 75 CALL wrk_alloc( jpi, jpj, zu_io, zv_io ) 75 CALL wrk_alloc( jpj, zind, zmsk ) 76 77 ! ------------------------------- 78 !- check conservation (C Rousset) 79 IF (ln_limdiahsb) THEN 80 zchk_v_i_b = glob_sum( SUM( v_i(:,:,:), dim=3 ) * area(:,:) * tms(:,:) ) 81 zchk_smv_b = glob_sum( SUM( smv_i(:,:,:), dim=3 ) * area(:,:) * tms(:,:) ) 82 zchk_fw_b = glob_sum( rdm_ice(:,:) * area(:,:) * tms(:,:) ) 83 zchk_fs_b = glob_sum( ( sfx_bri(:,:) + sfx_thd(:,:) + sfx_res(:,:) + sfx_mec(:,:) ) * area(:,:) * tms(:,:) ) 84 ENDIF 85 !- check conservation (C Rousset) 86 ! ------------------------------- 76 CALL wrk_alloc( jpj, zswitch, zmsk ) 87 77 88 78 IF( kt == nit000 ) CALL lim_dyn_init ! Initialization (first time-step only) … … 90 80 IF( ln_limdyn ) THEN 91 81 ! 92 old_u_ice(:,:) = u_ice(:,:) * tmu(:,:) 93 old_v_ice(:,:) = v_ice(:,:) * tmv(:,:) 82 ! conservation test 83 IF( ln_limdiahsb ) CALL lim_cons_hsm(0, 'limdyn', zvi_b, zsmv_b, zei_b, zfw_b, zfs_b, zft_b) 84 85 u_ice_b(:,:) = u_ice(:,:) * tmu(:,:) 86 v_ice_b(:,:) = v_ice(:,:) * tmv(:,:) 94 87 95 88 ! Rheology (ice dynamics) … … 107 100 ! 108 101 DO jj = 1, jpj 109 z ind(jj) = SUM( 1.0 - at_i(:,jj) ) ! = REAL(jpj) if ocean everywhere on a j-line102 zswitch(jj) = SUM( 1.0 - at_i(:,jj) ) ! = REAL(jpj) if ocean everywhere on a j-line 110 103 zmsk(jj) = SUM( tmask(:,jj,1) ) ! = 0 if land everywhere on a j-line 111 104 END DO … … 117 110 i_j1 = njeq 118 111 i_jpj = jpj 119 DO WHILE ( i_j1 <= jpj .AND. z ind(i_j1) == FLOAT(jpi) .AND. zmsk(i_j1) /=0 )112 DO WHILE ( i_j1 <= jpj .AND. zswitch(i_j1) == FLOAT(jpi) .AND. zmsk(i_j1) /=0 ) 120 113 i_j1 = i_j1 + 1 121 114 END DO … … 127 120 i_j1 = 1 128 121 i_jpj = njeq 129 DO WHILE ( i_jpj >= 1 .AND. z ind(i_jpj) == FLOAT(jpi) .AND. zmsk(i_jpj) /=0 )122 DO WHILE ( i_jpj >= 1 .AND. zswitch(i_jpj) == FLOAT(jpi) .AND. zmsk(i_jpj) /=0 ) 130 123 i_jpj = i_jpj - 1 131 124 END DO … … 139 132 ! ! latitude strip 140 133 i_j1 = 1 141 DO WHILE ( i_j1 <= jpj .AND. z ind(i_j1) == FLOAT(jpi) .AND. zmsk(i_j1) /=0 )134 DO WHILE ( i_j1 <= jpj .AND. zswitch(i_j1) == FLOAT(jpi) .AND. zmsk(i_j1) /=0 ) 142 135 i_j1 = i_j1 + 1 143 136 END DO … … 145 138 146 139 i_jpj = jpj 147 DO WHILE ( i_jpj >= 1 .AND. z ind(i_jpj) == FLOAT(jpi) .AND. zmsk(i_jpj) /=0 )140 DO WHILE ( i_jpj >= 1 .AND. zswitch(i_jpj) == FLOAT(jpi) .AND. zmsk(i_jpj) /=0 ) 148 141 i_jpj = i_jpj - 1 149 142 END DO … … 171 164 END DO 172 165 END DO 166 ! 167 ! conservation test 168 IF( ln_limdiahsb ) CALL lim_cons_hsm(1, 'limdyn', zvi_b, zsmv_b, zei_b, zfw_b, zfs_b, zft_b) 173 169 ! 174 170 ELSE ! no ice dynamics : transmit directly the atmospheric stress to the ocean … … 224 220 ENDIF 225 221 ! 226 ! -------------------------------227 !- check conservation (C Rousset)228 IF (ln_limdiahsb) THEN229 zchk_fs = glob_sum( ( sfx_bri(:,:) + sfx_thd(:,:) + sfx_res(:,:) + sfx_mec(:,:) ) * area(:,:) * tms(:,:) ) - zchk_fs_b230 zchk_fw = glob_sum( rdm_ice(:,:) * area(:,:) * tms(:,:) ) - zchk_fw_b231 232 zchk_v_i = ( glob_sum( SUM( v_i(:,:,:), dim=3 ) * area(:,:) * tms(:,:) ) - zchk_v_i_b - ( zchk_fw / rhoic ) ) / rdt_ice233 zchk_smv = ( glob_sum( SUM( smv_i(:,:,:), dim=3 ) * area(:,:) * tms(:,:) ) - zchk_smv_b ) / rdt_ice + ( zchk_fs / rhoic )234 235 zchk_vmin = glob_min(v_i)236 zchk_amax = glob_max(SUM(a_i,dim=3))237 zchk_amin = glob_min(a_i)238 239 IF(lwp) THEN240 IF ( ABS( zchk_v_i ) > 1.e-5 ) WRITE(numout,*) 'violation volume [m3/day] (limdyn) = ',(zchk_v_i * rday)241 IF ( ABS( zchk_smv ) > 1.e-4 ) WRITE(numout,*) 'violation saline [psu*m3/day] (limdyn) = ',(zchk_smv * rday)242 IF ( zchk_vmin < 0. ) WRITE(numout,*) 'violation v_i<0 [mm] (limdyn) = ',(zchk_vmin * 1.e-3)243 !IF ( zchk_amax > amax+1.e-10 ) WRITE(numout,*) 'violation a_i>amax (limdyn) = ',zchk_amax244 IF ( zchk_amin < 0. ) WRITE(numout,*) 'violation a_i<0 (limdyn) = ',zchk_amin245 ENDIF246 ENDIF247 !- check conservation (C Rousset)248 ! -------------------------------249 250 222 CALL wrk_dealloc( jpi, jpj, zu_io, zv_io ) 251 CALL wrk_dealloc( jpj, z ind, zmsk )223 CALL wrk_dealloc( jpj, zswitch, zmsk ) 252 224 ! 253 225 IF( nn_timing == 1 ) CALL timing_stop('limdyn') … … 269 241 !!------------------------------------------------------------------- 270 242 INTEGER :: ios ! Local integer output status for namelist read 271 NAMELIST/namicedyn/ epsd, alpha, & 272 & dm, nbiter, nbitdr, om, resl, cw, angvg, pstar, & 273 & c_rhg, etamn, creepl, ecc, ahi0, & 274 & nevp, telast, alphaevp, hminrhg 243 NAMELIST/namicedyn/ epsd, om, cw, pstar, & 244 & c_rhg, creepl, ecc, ahi0, & 245 & nevp, relast, alphaevp, hminrhg 275 246 !!------------------------------------------------------------------- 276 247 … … 289 260 WRITE(numout,*) '~~~~~~~~~~~~' 290 261 WRITE(numout,*) ' tolerance parameter epsd = ', epsd 291 WRITE(numout,*) ' coefficient for semi-implicit coriolis alpha = ', alpha292 WRITE(numout,*) ' diffusion constant for dynamics dm = ', dm293 WRITE(numout,*) ' number of sub-time steps for relaxation nbiter = ', nbiter294 WRITE(numout,*) ' maximum number of iterations for relaxation nbitdr = ', nbitdr295 262 WRITE(numout,*) ' relaxation constant om = ', om 296 WRITE(numout,*) ' maximum value for the residual of relaxation resl = ', resl297 263 WRITE(numout,*) ' drag coefficient for oceanic stress cw = ', cw 298 WRITE(numout,*) ' turning angle for oceanic stress angvg = ', angvg299 264 WRITE(numout,*) ' first bulk-rheology parameter pstar = ', pstar 300 265 WRITE(numout,*) ' second bulk-rhelogy parameter c_rhg = ', c_rhg 301 WRITE(numout,*) ' minimun value for viscosity etamn = ', etamn302 266 WRITE(numout,*) ' creep limit creepl = ', creepl 303 267 WRITE(numout,*) ' eccentricity of the elliptical yield curve ecc = ', ecc 304 268 WRITE(numout,*) ' horizontal diffusivity coeff. for sea-ice ahi0 = ', ahi0 305 269 WRITE(numout,*) ' number of iterations for subcycling nevp = ', nevp 306 WRITE(numout,*) ' timescale for elastic waves telast = ', telast270 WRITE(numout,*) ' ratio of elastic timescale over ice time step relast = ', relast 307 271 WRITE(numout,*) ' coefficient for the solution of int. stresses alphaevp = ', alphaevp 308 272 WRITE(numout,*) ' min ice thickness for rheology calculations hminrhg = ', hminrhg 309 273 ENDIF 310 274 ! 311 IF( angvg /= 0._wp ) THEN312 CALL ctl_warn( 'lim_dyn_init: turning angle for oceanic stress not properly coded for EVP ', &313 & '(see limsbc module). We force angvg = 0._wp' )314 angvg = 0._wp315 ENDIF316 317 275 usecc2 = 1._wp / ( ecc * ecc ) 318 276 rhoco = rau0 * cw 319 angvg = angvg * rad 320 sangvg = SIN( angvg ) 321 cangvg = COS( angvg ) 322 pstarh = pstar * 0.5_wp 277 278 ! elastic damping 279 telast = relast * rdt_ice 323 280 324 281 ! Diffusion coefficients. -
branches/2014/dev_r4650_UKMO14.12_STAND_ALONE_OBSOPER/NEMOGCM/NEMO/LIM_SRC_3/limhdf.F90
r4333 r5034 83 83 zdiv0(:, 1 ) = 0._wp 84 84 zdiv0(:,jpj) = 0._wp 85 IF( .NOT.lk_vopt_loop ) THEN 86 zflu (jpi,:) = 0._wp 87 zflv (jpi,:) = 0._wp 88 zdiv0(1, :) = 0._wp 89 zdiv0(jpi,:) = 0._wp 90 ENDIF 85 zflu (jpi,:) = 0._wp 86 zflv (jpi,:) = 0._wp 87 zdiv0(1, :) = 0._wp 88 zdiv0(jpi,:) = 0._wp 91 89 92 90 zconv = 1._wp !== horizontal diffusion using a Crant-Nicholson scheme ==! -
branches/2014/dev_r4650_UKMO14.12_STAND_ALONE_OBSOPER/NEMOGCM/NEMO/LIM_SRC_3/limistate.F90
r4624 r5034 6 6 !! History : 2.0 ! 2004-01 (C. Ethe, G. Madec) Original code 7 7 !! 4.0 ! 2011-02 (G. Madec) dynamical allocation 8 !! - ! 201 2 (C. Rousset) add par_oce (for jp_sal)...bug?8 !! - ! 2014 (C. Rousset) add N/S initializations 9 9 !!---------------------------------------------------------------------- 10 10 #if defined key_lim3 … … 26 26 USE dom_ice ! sea-ice domain 27 27 USE in_out_manager ! I/O manager 28 USE lbclnk ! lateral boundary condition - MPP exchanges29 28 USE lib_mpp ! MPP library 30 29 USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) … … 36 35 PUBLIC lim_istate ! routine called by lim_init.F90 37 36 38 !! * Module variables39 37 ! !!** init namelist (namiceini) ** 40 REAL(wp) :: ttest ! threshold water temperature for initial sea ice 41 REAL(wp) :: hninn ! initial snow thickness in the north 42 REAL(wp) :: hnins ! initial snow thickness in the south 43 REAL(wp) :: hginn ! initial ice thickness in the north 44 REAL(wp) :: hgins ! initial ice thickness in the south 45 REAL(wp) :: aginn ! initial leads area in the north 46 REAL(wp) :: agins ! initial leads area in the south 47 REAL(wp) :: sinn ! initial salinity 48 REAL(wp) :: sins 49 38 REAL(wp) :: thres_sst ! threshold water temperature for initial sea ice 39 REAL(wp) :: hts_ini_n ! initial snow thickness in the north 40 REAL(wp) :: hts_ini_s ! initial snow thickness in the south 41 REAL(wp) :: hti_ini_n ! initial ice thickness in the north 42 REAL(wp) :: hti_ini_s ! initial ice thickness in the south 43 REAL(wp) :: ati_ini_n ! initial leads area in the north 44 REAL(wp) :: ati_ini_s ! initial leads area in the south 45 REAL(wp) :: smi_ini_n ! initial salinity 46 REAL(wp) :: smi_ini_s ! initial salinity 47 REAL(wp) :: tmi_ini_n ! initial temperature 48 REAL(wp) :: tmi_ini_s ! initial temperature 49 50 LOGICAL :: ln_limini ! initialization or not 50 51 !!---------------------------------------------------------------------- 51 52 !! LIM 3.0, UCL-LOCEAN-IPSL (2008) … … 53 54 !! Software governed by the CeCILL licence (modipsl/doc/NEMO_CeCILL.txt) 54 55 !!---------------------------------------------------------------------- 55 56 56 CONTAINS 57 57 … … 77 77 !! 78 78 !! ** Notes : o_i, t_su, t_s, t_i, s_i must be filled everywhere, even 79 !! where there is no ice (clem: I do not know why but it is mandatory)79 !! where there is no ice (clem: I do not know why, is it mandatory?) 80 80 !! 81 81 !! History : … … 90 90 INTEGER :: i_hemis, i_fill, jl0 91 91 REAL(wp) :: ztest_1, ztest_2, ztest_3, ztest_4, ztests, zsigma, zarg, zA, zV, zA_cons, zV_cons, zconv 92 REAL(wp), POINTER, DIMENSION(:) :: zh m_i_ini, zat_i_ini, zvt_i_ini, zhm_s_ini, zsm_i_ini93 REAL(wp), POINTER, DIMENSION(:,:) :: zh t_i_ini, za_i_ini, zv_i_ini94 REAL(wp), POINTER, DIMENSION(:,:) :: z idto! ice indicator92 REAL(wp), POINTER, DIMENSION(:) :: zht_i_ini, zat_i_ini, zvt_i_ini, zht_s_ini, zsm_i_ini, ztm_i_ini 93 REAL(wp), POINTER, DIMENSION(:,:) :: zh_i_ini, za_i_ini, zv_i_ini 94 REAL(wp), POINTER, DIMENSION(:,:) :: zswitch ! ice indicator 95 95 INTEGER, POINTER, DIMENSION(:,:) :: zhemis ! hemispheric index 96 96 !-------------------------------------------------------------------- 97 97 98 CALL wrk_alloc( jpi, jpj, z idto)98 CALL wrk_alloc( jpi, jpj, zswitch ) 99 99 CALL wrk_alloc( jpi, jpj, zhemis ) 100 CALL wrk_alloc( jpl, 2, zht_i_ini, za_i_ini, zv_i_ini ) 101 CALL wrk_alloc( 2, zhm_i_ini, zat_i_ini, zvt_i_ini, zhm_s_ini, zsm_i_ini ) 102 103 epsi20 = 1.0e-20 100 CALL wrk_alloc( jpl, 2, zh_i_ini, za_i_ini, zv_i_ini ) 101 CALL wrk_alloc( 2, zht_i_ini, zat_i_ini, zvt_i_ini, zht_s_ini, zsm_i_ini, ztm_i_ini ) 102 103 epsi20 = 1.e-20_wp 104 104 105 IF(lwp) WRITE(numout,*) 105 106 IF(lwp) WRITE(numout,*) 'lim_istate : Ice initialization ' … … 112 113 CALL lim_istate_init ! reading the initials parameters of the ice 113 114 114 !!gm in lim2 the initialisation if only done if required in the namelist : 115 !!gm IF( .NOT. ln_limini ) THEN 116 !!gm this should be added in lim3 namelist... 115 ! surface temperature 116 DO jl = 1, jpl ! loop over categories 117 t_su (:,:,jl) = rtt * tms(:,:) 118 tn_ice(:,:,jl) = rtt * tms(:,:) 119 END DO 120 121 ! basal temperature (considered at freezing point) 122 t_bo(:,:) = ( eos_fzp( tsn(:,:,1,jp_sal) ) + rt0 ) * tms(:,:) 123 124 IF( ln_limini ) THEN 117 125 118 126 !-------------------------------------------------------------------- 119 127 ! 2) Basal temperature, ice mask and hemispheric index 120 128 !-------------------------------------------------------------------- 121 122 ! Basal temperature is set to the freezing point of seawater in Celsius123 t_bo(:,:) = tfreez( tsn(:,:,1,jp_sal) ) * tmask(:,:,1) ! freezing/melting point of sea water [Celcius]124 129 125 130 DO jj = 1, jpj ! ice if sst <= t-freez + ttest 126 131 DO ji = 1, jpi 127 IF( tsn(ji,jj,1,jp_tem) - t_bo(ji,jj) >= ttest ) THEN ; zidto(ji,jj) = 0._wp ! no ice 128 ELSE ; zidto(ji,jj) = 1._wp ! ice 132 IF( ( tsn(ji,jj,1,jp_tem) - ( t_bo(ji,jj) - rt0 ) ) * tms(ji,jj) >= thres_sst ) THEN 133 zswitch(ji,jj) = 0._wp * tms(ji,jj) ! no ice 134 ELSE 135 zswitch(ji,jj) = 1._wp * tms(ji,jj) ! ice 129 136 ENDIF 130 137 END DO 131 138 END DO 132 139 133 t_bo(:,:) = t_bo(:,:) + rt0 ! conversion to Kelvin134 140 135 141 ! Hemispheric index 136 ! MV 2011 new initialization137 142 DO jj = 1, jpj 138 143 DO ji = 1, jpi … … 144 149 END DO 145 150 END DO 146 ! END MV 2011 new initialization147 151 148 152 !-------------------------------------------------------------------- … … 153 157 ! 3.1) Hemisphere-dependent arrays 154 158 !----------------------------- 155 ! assign initial thickness, concentration, snow depth and salinity to 156 ! an hemisphere-dependent array 157 zhm_i_ini(1) = hginn ; zhm_i_ini(2) = hgins ! ice thickness 158 zat_i_ini(1) = aginn ; zat_i_ini(2) = agins ! ice concentration 159 zvt_i_ini(:) = zhm_i_ini(:) * zat_i_ini(:) ! ice volume 160 zhm_s_ini(1) = hninn ; zhm_s_ini(2) = hnins ! snow depth 161 zsm_i_ini(1) = sinn ; zsm_i_ini(2) = sins ! bulk ice salinity 159 ! assign initial thickness, concentration, snow depth and salinity to an hemisphere-dependent array 160 zht_i_ini(1) = hti_ini_n ; zht_i_ini(2) = hti_ini_s ! ice thickness 161 zht_s_ini(1) = hts_ini_n ; zht_s_ini(2) = hts_ini_s ! snow depth 162 zat_i_ini(1) = ati_ini_n ; zat_i_ini(2) = ati_ini_s ! ice concentration 163 zsm_i_ini(1) = smi_ini_n ; zsm_i_ini(2) = smi_ini_s ! bulk ice salinity 164 ztm_i_ini(1) = tmi_ini_n ; ztm_i_ini(2) = tmi_ini_s ! temperature (ice and snow) 165 166 zvt_i_ini(:) = zht_i_ini(:) * zat_i_ini(:) ! ice volume 162 167 163 168 !--------------------------------------------------------------------- … … 183 188 ! *** 1 category to fill 184 189 IF ( i_fill .EQ. 1 ) THEN 185 zh t_i_ini(1,i_hemis) = zhm_i_ini(i_hemis)186 za_i_ini(1,i_hemis) 187 zh t_i_ini(2:jpl,i_hemis) = 0._wp188 za_i_ini(2:jpl,i_hemis) 190 zh_i_ini(1,i_hemis) = zht_i_ini(i_hemis) 191 za_i_ini(1,i_hemis) = zat_i_ini(i_hemis) 192 zh_i_ini(2:jpl,i_hemis) = 0._wp 193 za_i_ini(2:jpl,i_hemis) = 0._wp 189 194 ELSE 190 195 191 ! *** >1 categores to fill192 !--- Ice thicknesses in the i_fill - 1 first categories196 ! *** >1 categores to fill 197 !--- Ice thicknesses in the i_fill - 1 first categories 193 198 DO jl = 1, i_fill - 1 194 zh t_i_ini(jl,i_hemis) = 0.5 * ( hi_max(jl) + hi_max(jl-1) )199 zh_i_ini(jl,i_hemis) = 0.5 * ( hi_max(jl) + hi_max(jl-1) ) 195 200 END DO 196 197 !--- jl0: most likely index where cc will be maximum201 202 !--- jl0: most likely index where cc will be maximum 198 203 DO jl = 1, jpl 199 IF ( ( zh m_i_ini(i_hemis) .GT. hi_max(jl-1) ) .AND. &200 ( zhm_i_ini(i_hemis) .LE. hi_max(jl) ) ) THEN204 IF ( ( zht_i_ini(i_hemis) .GT. hi_max(jl-1) ) .AND. & 205 ( zht_i_ini(i_hemis) .LE. hi_max(jl) ) ) THEN 201 206 jl0 = jl 202 207 ENDIF 203 208 END DO 204 209 jl0 = MIN(jl0, i_fill) 205 206 !--- Concentrations210 211 !--- Concentrations 207 212 za_i_ini(jl0,i_hemis) = zat_i_ini(i_hemis) / SQRT(REAL(jpl)) 208 213 DO jl = 1, i_fill - 1 209 214 IF ( jl .NE. jl0 ) THEN 210 zsigma = 0.5 * zh m_i_ini(i_hemis)211 zarg = ( zh t_i_ini(jl,i_hemis) - zhm_i_ini(i_hemis) ) / zsigma215 zsigma = 0.5 * zht_i_ini(i_hemis) 216 zarg = ( zh_i_ini(jl,i_hemis) - zht_i_ini(i_hemis) ) / zsigma 212 217 za_i_ini(jl,i_hemis) = za_i_ini(jl0,i_hemis) * EXP(-zarg**2) 213 218 ENDIF 214 END DO 215 219 END DO 220 216 221 zA = 0. ! sum of the areas in the jpl categories 217 222 DO jl = 1, i_fill - 1 … … 221 226 IF ( i_fill .LT. jpl ) za_i_ini(i_fill+1:jpl, i_hemis) = 0._wp 222 227 223 !--- Ice thickness in the last category228 !--- Ice thickness in the last category 224 229 zV = 0. ! sum of the volumes of the N-1 categories 225 230 DO jl = 1, i_fill - 1 226 zV = zV + za_i_ini(jl,i_hemis)*zh t_i_ini(jl,i_hemis)231 zV = zV + za_i_ini(jl,i_hemis)*zh_i_ini(jl,i_hemis) 227 232 END DO 228 zh t_i_ini(i_fill,i_hemis) = ( zvt_i_ini(i_hemis) - zV ) / za_i_ini(i_fill,i_hemis)229 IF ( i_fill .LT. jpl ) zh t_i_ini(i_fill+1:jpl, i_hemis) = 0._wp230 231 !--- volumes232 zv_i_ini(:,i_hemis) = za_i_ini(:,i_hemis) * zh t_i_ini(:,i_hemis)233 zh_i_ini(i_fill,i_hemis) = ( zvt_i_ini(i_hemis) - zV ) / za_i_ini(i_fill,i_hemis) 234 IF ( i_fill .LT. jpl ) zh_i_ini(i_fill+1:jpl, i_hemis) = 0._wp 235 236 !--- volumes 237 zv_i_ini(:,i_hemis) = za_i_ini(:,i_hemis) * zh_i_ini(:,i_hemis) 233 238 IF ( i_fill .LT. jpl ) zv_i_ini(i_fill+1:jpl, i_hemis) = 0._wp 234 239 … … 262 267 263 268 ! Test 3: thickness of the last category is in-bounds ? 264 IF ( zh t_i_ini(i_fill, i_hemis) .GT. hi_max(i_fill-1) ) THEN269 IF ( zh_i_ini(i_fill, i_hemis) .GT. hi_max(i_fill-1) ) THEN 265 270 ztest_3 = 1 266 271 ELSE 267 272 ! this write is useful 268 IF(lwp) WRITE(numout,*) ' * TEST 3 THICKNESS OF THE LAST CATEGORY OUT OF BOUNDS *** zh t_i_ini(i_fill,i_hemis) = ', &269 zh t_i_ini(i_fill,i_hemis), ' hi_max(jpl-1) = ', hi_max(i_fill-1)273 IF(lwp) WRITE(numout,*) ' * TEST 3 THICKNESS OF THE LAST CATEGORY OUT OF BOUNDS *** zh_i_ini(i_fill,i_hemis) = ', & 274 zh_i_ini(i_fill,i_hemis), ' hi_max(jpl-1) = ', hi_max(i_fill-1) 270 275 ztest_3 = 0 271 276 ENDIF … … 288 293 289 294 IF(lwp) THEN 290 WRITE(numout,*) ,' ztests : ', ztests295 WRITE(numout,*) ' ztests : ', ztests 291 296 IF ( ztests .NE. 4 ) THEN 292 297 WRITE(numout,*) 293 WRITE(numout,*), ' !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ' 294 WRITE(numout,*), ' !!!! RED ALERT !!! ' 295 WRITE(numout,*), ' !!!! BIIIIP BIIIP BIIIIP BIIIIP !!!' 296 WRITE(numout,*), ' !!!! Something is wrong in the LIM3 initialization procedure ' 297 WRITE(numout,*), ' !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ' 298 WRITE(numout,*) ' !!!! ALERT !!! ' 299 WRITE(numout,*) ' !!!! Something is wrong in the LIM3 initialization procedure ' 298 300 WRITE(numout,*) 299 WRITE(numout,*) ,' *** ztests is not equal to 4 '300 WRITE(numout,*) ,' *** ztest_i (i=1,4) = ', ztest_1, ztest_2, ztest_3, ztest_4301 WRITE(numout,*) ,' zat_i_ini : ', zat_i_ini(i_hemis)302 WRITE(numout,*) , ' zhm_i_ini : ', zhm_i_ini(i_hemis)301 WRITE(numout,*) ' *** ztests is not equal to 4 ' 302 WRITE(numout,*) ' *** ztest_i (i=1,4) = ', ztest_1, ztest_2, ztest_3, ztest_4 303 WRITE(numout,*) ' zat_i_ini : ', zat_i_ini(i_hemis) 304 WRITE(numout,*) ' zht_i_ini : ', zht_i_ini(i_hemis) 303 305 ENDIF ! ztests .NE. 4 304 306 ENDIF … … 314 316 DO jj = 1, jpj 315 317 DO ji = 1, jpi 316 a_i(ji,jj,jl) = z idto(ji,jj) * za_i_ini (jl,zhemis(ji,jj)) ! concentration317 ht_i(ji,jj,jl) = z idto(ji,jj) * zht_i_ini(jl,zhemis(ji,jj)) ! ice thickness318 ht_s(ji,jj,jl) = ht_i(ji,jj,jl) * ( zh m_s_ini( zhemis(ji,jj) ) / zhm_i_ini( zhemis(ji,jj) ) ) ! snow depth319 sm_i(ji,jj,jl) = z idto(ji,jj) * zsm_i_ini(zhemis(ji,jj)) + ( 1._wp - zidto(ji,jj) ) * s_i_min ! salinity320 o_i(ji,jj,jl) = z idto(ji,jj) * 1._wp + ( 1._wp - zidto(ji,jj) ) ! age321 t_su(ji,jj,jl) = z idto(ji,jj) * 270.0 + ( 1._wp - zidto(ji,jj) ) * 270.0! surf temp318 a_i(ji,jj,jl) = zswitch(ji,jj) * za_i_ini (jl,zhemis(ji,jj)) ! concentration 319 ht_i(ji,jj,jl) = zswitch(ji,jj) * zh_i_ini(jl,zhemis(ji,jj)) ! ice thickness 320 ht_s(ji,jj,jl) = ht_i(ji,jj,jl) * ( zht_s_ini( zhemis(ji,jj) ) / zht_i_ini( zhemis(ji,jj) ) ) ! snow depth 321 sm_i(ji,jj,jl) = zswitch(ji,jj) * zsm_i_ini(zhemis(ji,jj)) !+ ( 1._wp - zswitch(ji,jj) ) * s_i_min ! salinity 322 o_i(ji,jj,jl) = zswitch(ji,jj) * 1._wp + ( 1._wp - zswitch(ji,jj) ) ! age 323 t_su(ji,jj,jl) = zswitch(ji,jj) * ztm_i_ini(zhemis(ji,jj)) + ( 1._wp - zswitch(ji,jj) ) * rtt ! surf temp 322 324 323 325 ! This case below should not be used if (ht_s/ht_i) is ok in namelist … … 343 345 DO jj = 1, jpj 344 346 DO ji = 1, jpi 345 t_s(ji,jj,jk,jl) = z idto(ji,jj) * 270.0 + ( 1._wp - zidto(ji,jj) ) * rtt347 t_s(ji,jj,jk,jl) = zswitch(ji,jj) * ztm_i_ini(zhemis(ji,jj)) + ( 1._wp - zswitch(ji,jj) ) * rtt 346 348 ! Snow energy of melting 347 e_s(ji,jj,jk,jl) = z idto(ji,jj) * rhosn * ( cpic * ( rtt - t_s(ji,jj,jk,jl) ) + lfus )349 e_s(ji,jj,jk,jl) = zswitch(ji,jj) * rhosn * ( cpic * ( rtt - t_s(ji,jj,jk,jl) ) + lfus ) 348 350 ! Change dimensions 349 351 e_s(ji,jj,jk,jl) = e_s(ji,jj,jk,jl) / unit_fac 350 ! Multiply by volume, so that heat content in 10^9Joules352 ! Multiply by volume, so that heat content in Joules 351 353 e_s(ji,jj,jk,jl) = e_s(ji,jj,jk,jl) * area(ji,jj) * v_s(ji,jj,jl) / nlay_s 352 354 END DO ! ji … … 360 362 DO jj = 1, jpj 361 363 DO ji = 1, jpi 362 t_i(ji,jj,jk,jl) = z idto(ji,jj) * 270.00 + ( 1._wp - zidto(ji,jj) ) * rtt363 s_i(ji,jj,jk,jl) = z idto(ji,jj) * zsm_i_ini(zhemis(ji,jj)) + ( 1._wp - zidto(ji,jj) ) * s_i_min364 t_i(ji,jj,jk,jl) = zswitch(ji,jj) * ztm_i_ini(zhemis(ji,jj)) + ( 1._wp - zswitch(ji,jj) ) * rtt 365 s_i(ji,jj,jk,jl) = zswitch(ji,jj) * zsm_i_ini(zhemis(ji,jj)) !+ ( 1._wp - zswitch(ji,jj) ) * s_i_min 364 366 ztmelts = - tmut * s_i(ji,jj,jk,jl) + rtt !Melting temperature in K 365 367 366 368 ! heat content per unit volume 367 e_i(ji,jj,jk,jl) = z idto(ji,jj) * rhoic * ( cpic * ( ztmelts - t_i(ji,jj,jk,jl) ) &369 e_i(ji,jj,jk,jl) = zswitch(ji,jj) * rhoic * ( cpic * ( ztmelts - t_i(ji,jj,jk,jl) ) & 368 370 + lfus * ( 1._wp - (ztmelts-rtt) / MIN((t_i(ji,jj,jk,jl)-rtt),-epsi20) ) & 369 371 - rcp * ( ztmelts - rtt ) ) … … 372 374 e_i(ji,jj,jk,jl) = e_i(ji,jj,jk,jl) / unit_fac 373 375 374 ! Mutliply by ice volume, and divide by number of layers 375 ! to get heat content in 10^9 J 376 ! Mutliply by ice volume, and divide by number of layers to get heat content in J 376 377 e_i(ji,jj,jk,jl) = e_i(ji,jj,jk,jl) * area(ji,jj) * v_i(ji,jj,jl) / nlay_i 377 378 END DO ! ji … … 380 381 END DO ! jk 381 382 383 tn_ice (:,:,:) = t_su (:,:,:) 384 385 ELSE 386 ! if ln_limini=false 387 a_i (:,:,:) = 0._wp 388 v_i (:,:,:) = 0._wp 389 v_s (:,:,:) = 0._wp 390 smv_i(:,:,:) = 0._wp 391 oa_i (:,:,:) = 0._wp 392 ht_i (:,:,:) = 0._wp 393 ht_s (:,:,:) = 0._wp 394 sm_i (:,:,:) = 0._wp 395 o_i (:,:,:) = 0._wp 396 397 e_i(:,:,:,:) = 0._wp 398 e_s(:,:,:,:) = 0._wp 399 400 DO jl = 1, jpl 401 DO jk = 1, nlay_i 402 t_i(:,:,jk,jl) = rtt * tms(:,:) 403 END DO 404 DO jk = 1, nlay_s 405 t_s(:,:,jk,jl) = rtt * tms(:,:) 406 END DO 407 END DO 408 409 ENDIF ! ln_limini 410 411 at_i (:,:) = 0.0_wp 412 DO jl = 1, jpl 413 at_i (:,:) = at_i (:,:) + a_i (:,:,jl) 414 END DO 415 ! 382 416 !-------------------------------------------------------------------- 383 417 ! 4) Global ice variables for output diagnostics | 384 418 !-------------------------------------------------------------------- 385 fsbbq (:,:) = 0._wp386 419 u_ice (:,:) = 0._wp 387 420 v_ice (:,:) = 0._wp … … 390 423 stress12_i(:,:) = 0._wp 391 424 392 # if defined key_coupled393 albege(:,:) = 0.8 * tms(:,:)394 # endif395 396 425 !-------------------------------------------------------------------- 397 426 ! 5) Moments for advection … … 428 457 sxyage (:,:,:) = 0._wp 429 458 430 !-------------------------------------------------------------------- 431 ! 6) Lateral boundary conditions | 432 !-------------------------------------------------------------------- 433 434 DO jl = 1, jpl 435 436 CALL lbc_lnk( a_i(:,:,jl) , 'T', 1. ) 437 CALL lbc_lnk( v_i(:,:,jl) , 'T', 1. ) 438 CALL lbc_lnk( v_s(:,:,jl) , 'T', 1. ) 439 CALL lbc_lnk( smv_i(:,:,jl), 'T', 1. ) 440 CALL lbc_lnk( oa_i(:,:,jl) , 'T', 1. ) 441 442 CALL lbc_lnk( ht_i(:,:,jl) , 'T', 1. ) 443 CALL lbc_lnk( ht_s(:,:,jl) , 'T', 1. ) 444 CALL lbc_lnk( sm_i(:,:,jl) , 'T', 1. ) 445 CALL lbc_lnk( o_i(:,:,jl) , 'T', 1. ) 446 CALL lbc_lnk( t_su(:,:,jl) , 'T', 1. ) 447 DO jk = 1, nlay_s 448 CALL lbc_lnk(t_s(:,:,jk,jl), 'T', 1. ) 449 CALL lbc_lnk(e_s(:,:,jk,jl), 'T', 1. ) 450 END DO 451 DO jk = 1, nlay_i 452 CALL lbc_lnk(t_i(:,:,jk,jl), 'T', 1. ) 453 CALL lbc_lnk(e_i(:,:,jk,jl), 'T', 1. ) 454 END DO 455 ! 456 a_i(:,:,jl) = tms(:,:) * a_i(:,:,jl) 457 END DO 458 459 at_i (:,:) = 0.0_wp 460 DO jl = 1, jpl 461 at_i (:,:) = at_i (:,:) + a_i (:,:,jl) 462 END DO 463 464 CALL lbc_lnk( at_i , 'T', 1. ) 465 at_i(:,:) = tms(:,:) * at_i(:,:) ! put 0 over land 466 ! 467 CALL lbc_lnk( fsbbq , 'T', 1. ) 468 ! 469 !-------------------------------------------------------------------- 470 ! 6) ???? | 471 !-------------------------------------------------------------------- 472 tn_ice (:,:,:) = t_su (:,:,:) 473 474 CALL wrk_dealloc( jpi, jpj, zidto ) 459 460 CALL wrk_dealloc( jpi, jpj, zswitch ) 475 461 CALL wrk_dealloc( jpi, jpj, zhemis ) 476 CALL wrk_dealloc( jpl, 2, zh t_i_ini, za_i_ini, zv_i_ini )477 CALL wrk_dealloc( 2, zh m_i_ini, zat_i_ini, zvt_i_ini, zhm_s_ini, zsm_i_ini )462 CALL wrk_dealloc( jpl, 2, zh_i_ini, za_i_ini, zv_i_ini ) 463 CALL wrk_dealloc( 2, zht_i_ini, zat_i_ini, zvt_i_ini, zht_s_ini, zsm_i_ini, ztm_i_ini ) 478 464 479 465 END SUBROUTINE lim_istate … … 495 481 !! 8.5 ! 07-11 (M. Vancoppenolle) rewritten initialization 496 482 !!----------------------------------------------------------------------------- 497 NAMELIST/namiceini/ ttest, hninn, hnins, hginn, hgins, aginn, agins, sinn, sins498 !483 NAMELIST/namiceini/ ln_limini, thres_sst, hts_ini_n, hts_ini_s, hti_ini_n, hti_ini_s, & 484 & ati_ini_n, ati_ini_s, smi_ini_n, smi_ini_s, tmi_ini_n, tmi_ini_s 499 485 INTEGER :: ios ! Local integer output status for namelist read 500 486 !!----------------------------------------------------------------------------- … … 516 502 WRITE(numout,*) 'lim_istate_init : ice parameters inititialisation ' 517 503 WRITE(numout,*) '~~~~~~~~~~~~~~~' 518 WRITE(numout,*) ' threshold water temp. for initial sea-ice ttest = ', ttest 519 WRITE(numout,*) ' initial snow thickness in the north hninn = ', hninn 520 WRITE(numout,*) ' initial snow thickness in the south hnins = ', hnins 521 WRITE(numout,*) ' initial ice thickness in the north hginn = ', hginn 522 WRITE(numout,*) ' initial ice thickness in the south hgins = ', hgins 523 WRITE(numout,*) ' initial ice concentr. in the north aginn = ', aginn 524 WRITE(numout,*) ' initial ice concentr. in the north agins = ', agins 525 WRITE(numout,*) ' initial ice salinity in the north sinn = ', sinn 526 WRITE(numout,*) ' initial ice salinity in the south sins = ', sins 504 WRITE(numout,*) ' initialization with ice (T) or not (F) ln_limini = ', ln_limini 505 WRITE(numout,*) ' threshold water temp. for initial sea-ice thres_sst = ', thres_sst 506 WRITE(numout,*) ' initial snow thickness in the north hts_ini_n = ', hts_ini_n 507 WRITE(numout,*) ' initial snow thickness in the south hts_ini_s = ', hts_ini_s 508 WRITE(numout,*) ' initial ice thickness in the north hti_ini_n = ', hti_ini_n 509 WRITE(numout,*) ' initial ice thickness in the south hti_ini_s = ', hti_ini_s 510 WRITE(numout,*) ' initial ice concentr. in the north ati_ini_n = ', ati_ini_n 511 WRITE(numout,*) ' initial ice concentr. in the north ati_ini_s = ', ati_ini_s 512 WRITE(numout,*) ' initial ice salinity in the north smi_ini_n = ', smi_ini_n 513 WRITE(numout,*) ' initial ice salinity in the south smi_ini_s = ', smi_ini_s 514 WRITE(numout,*) ' initial ice/snw temp in the north tmi_ini_n = ', tmi_ini_n 515 WRITE(numout,*) ' initial ice/snw temp in the south tmi_ini_s = ', tmi_ini_s 527 516 ENDIF 528 517 -
branches/2014/dev_r4650_UKMO14.12_STAND_ALONE_OBSOPER/NEMOGCM/NEMO/LIM_SRC_3/limitd_me.F90
r4624 r5034 5 5 !!====================================================================== 6 6 !! History : LIM ! 2006-02 (M. Vancoppenolle) Original code 7 !! 3.2 ! 2009-07 (M. Vancoppenolle, Y. Aksenov, G. Madec) bug correction in smsw & sfx_ mec7 !! 3.2 ! 2009-07 (M. Vancoppenolle, Y. Aksenov, G. Madec) bug correction in smsw & sfx_dyn 8 8 !! 4.0 ! 2011-02 (G. Madec) dynamical allocation 9 9 !!---------------------------------------------------------------------- … … 22 22 USE limthd_lac ! LIM 23 23 USE limvar ! LIM 24 USE limcons ! LIM25 24 USE in_out_manager ! I/O manager 26 25 USE lbclnk ! lateral boundary condition - MPP exchanges … … 30 29 ! Check budget (Rousset) 31 30 USE iom ! I/O manager 32 USE lib_fortran ! glob_sum31 USE lib_fortran ! glob_sum 33 32 USE limdiahsb 34 USE timing ! Timing 33 USE timing ! Timing 34 USE limcons ! conservation tests 35 35 36 36 IMPLICIT NONE … … 42 42 PUBLIC lim_itd_me_zapsmall 43 43 PUBLIC lim_itd_me_alloc ! called by iceini.F90 44 45 REAL(wp) :: epsi20 = 1.e-20_wp ! constant values46 REAL(wp) :: epsi10 = 1.e-10_wp ! constant values47 REAL(wp) :: epsi06 = 1.e-06_wp ! constant values48 44 49 45 !----------------------------------------------------------------------- … … 143 139 REAL(wp), POINTER, DIMENSION(:,:) :: esnow_mlt ! energy needed to melt snow in ocean (J m-2) 144 140 REAL(wp), POINTER, DIMENSION(:,:) :: vt_i_init, vt_i_final ! ice volume summed over categories 145 REAL(wp) :: zchk_v_i, zchk_smv, zchk_fs, zchk_fw, zchk_v_i_b, zchk_smv_b, zchk_fs_b, zchk_fw_b ! Check conservation (C Rousset) 146 REAL(wp) :: zchk_vmin, zchk_amin, zchk_amax ! Check errors (C Rousset) 147 ! mass and salt flux (clem) 148 REAL(wp), POINTER, DIMENSION(:,:,:) :: zviold, zvsold, zsmvold ! old ice volume... 141 ! 142 REAL(wp) :: zvi_b, zsmv_b, zei_b, zfs_b, zfw_b, zft_b 149 143 !!----------------------------------------------------------------------------- 150 144 IF( nn_timing == 1 ) CALL timing_start('limitd_me') 151 145 152 146 CALL wrk_alloc( jpi, jpj, closing_net, divu_adv, opning, closing_gross, msnow_mlt, esnow_mlt, vt_i_init, vt_i_final ) 153 154 CALL wrk_alloc( jpi, jpj, jpl, zviold, zvsold, zsmvold ) ! clem155 156 IF( numit == nstart ) CALL lim_itd_me_init ! Initialization (first time-step only)157 147 158 148 IF(ln_ctl) THEN … … 162 152 163 153 IF( ln_limdyn ) THEN ! Start ridging and rafting ! 164 ! ------------------------------- 165 !- check conservation (C Rousset) 166 IF (ln_limdiahsb) THEN 167 zchk_v_i_b = glob_sum( SUM( v_i(:,:,:), dim=3 ) * area(:,:) * tms(:,:) ) 168 zchk_smv_b = glob_sum( SUM( smv_i(:,:,:), dim=3 ) * area(:,:) * tms(:,:) ) 169 zchk_fw_b = glob_sum( rdm_ice(:,:) * area(:,:) * tms(:,:) ) 170 zchk_fs_b = glob_sum( ( sfx_bri(:,:) + sfx_thd(:,:) + sfx_res(:,:) + sfx_mec(:,:) ) * area(:,:) * tms(:,:) ) 171 ENDIF 172 !- check conservation (C Rousset) 173 ! ------------------------------- 174 175 ! mass and salt flux init (clem) 176 zviold(:,:,:) = v_i(:,:,:) 177 zvsold(:,:,:) = v_s(:,:,:) 178 zsmvold(:,:,:) = smv_i(:,:,:) 154 155 ! conservation test 156 IF( ln_limdiahsb ) CALL lim_cons_hsm(0, 'limitd_me', zvi_b, zsmv_b, zei_b, zfw_b, zfs_b, zft_b) 179 157 180 158 !-----------------------------------------------------------------------------! … … 362 340 ! 5) Heat, salt and freshwater fluxes 363 341 !-----------------------------------------------------------------------------! 364 fmmec(ji,jj) = fmmec(ji,jj) + msnow_mlt(ji,jj) * r1_rdtice ! fresh water source for ocean365 fhmec(ji,jj) = fhmec(ji,jj) + esnow_mlt(ji,jj) * r1_rdtice ! heat sink for ocean342 wfx_snw(ji,jj) = wfx_snw(ji,jj) + msnow_mlt(ji,jj) * r1_rdtice ! fresh water source for ocean 343 hfx_dyn(ji,jj) = hfx_dyn(ji,jj) + esnow_mlt(ji,jj) * unit_fac / area(ji,jj) * r1_rdtice ! heat sink for ocean (<0, W.m-2) 366 344 367 345 END DO … … 399 377 CALL lim_itd_me_zapsmall 400 378 401 !--------------------------------402 ! Update mass/salt fluxes (clem)403 !--------------------------------404 DO jl = 1, jpl405 DO jj = 1, jpj406 DO ji = 1, jpi407 diag_dyn_gr(ji,jj) = diag_dyn_gr(ji,jj) + ( v_i(ji,jj,jl) - zviold(ji,jj,jl) ) * r1_rdtice408 rdm_ice(ji,jj) = rdm_ice(ji,jj) + ( v_i(ji,jj,jl) - zviold(ji,jj,jl) ) * rhoic409 rdm_snw(ji,jj) = rdm_snw(ji,jj) + ( v_s(ji,jj,jl) - zvsold(ji,jj,jl) ) * rhosn410 sfx_mec(ji,jj) = sfx_mec(ji,jj) - ( smv_i(ji,jj,jl) - zsmvold(ji,jj,jl) ) * rhoic * r1_rdtice411 END DO412 END DO413 END DO414 379 415 380 IF(ln_ctl) THEN ! Control print … … 445 410 ENDIF 446 411 447 ! ------------------------------- 448 !- check conservation (C Rousset) 449 IF (ln_limdiahsb) THEN 450 zchk_fs = glob_sum( ( sfx_bri(:,:) + sfx_thd(:,:) + sfx_res(:,:) + sfx_mec(:,:) ) * area(:,:) * tms(:,:) ) - zchk_fs_b 451 zchk_fw = glob_sum( rdm_ice(:,:) * area(:,:) * tms(:,:) ) - zchk_fw_b 452 453 zchk_v_i = ( glob_sum( SUM( v_i(:,:,:), dim=3 ) * area(:,:) * tms(:,:) ) - zchk_v_i_b - ( zchk_fw / rhoic ) ) * r1_rdtice 454 zchk_smv = ( glob_sum( SUM( smv_i(:,:,:), dim=3 ) * area(:,:) * tms(:,:) ) - zchk_smv_b ) * r1_rdtice + ( zchk_fs / rhoic ) 455 456 zchk_vmin = glob_min(v_i) 457 zchk_amax = glob_max(SUM(a_i,dim=3)) 458 zchk_amin = glob_min(a_i) 459 460 IF(lwp) THEN 461 IF ( ABS( zchk_v_i ) > 1.e-5 ) WRITE(numout,*) 'violation volume [m3/day] (limitd_me) = ',(zchk_v_i * rday) 462 IF ( ABS( zchk_smv ) > 1.e-4 ) WRITE(numout,*) 'violation saline [psu*m3/day] (limitd_me) = ',(zchk_smv * rday) 463 IF ( zchk_vmin < 0. ) WRITE(numout,*) 'violation v_i<0 [mm] (limitd_me) = ',(zchk_vmin * 1.e-3) 464 IF ( zchk_amax > kamax+epsi10 ) WRITE(numout,*) 'violation a_i>amax (limitd_me) = ',zchk_amax 465 IF ( zchk_amin < 0. ) WRITE(numout,*) 'violation a_i<0 (limitd_me) = ',zchk_amin 466 ENDIF 467 ENDIF 468 !- check conservation (C Rousset) 469 ! ------------------------------- 412 ! conservation test 413 IF( ln_limdiahsb ) CALL lim_cons_hsm(1, 'limitd_me', zvi_b, zsmv_b, zei_b, zfw_b, zfs_b, zft_b) 470 414 471 415 ENDIF ! ln_limdyn=.true. 472 416 ! 473 417 CALL wrk_dealloc( jpi, jpj, closing_net, divu_adv, opning, closing_gross, msnow_mlt, esnow_mlt, vt_i_init, vt_i_final ) 474 !475 CALL wrk_dealloc( jpi, jpj, jpl, zviold, zvsold, zsmvold ) ! clem476 418 ! 477 419 IF( nn_timing == 1 ) CALL timing_stop('limitd_me') … … 670 612 !!---------------------------------------------------------------------! 671 613 INTEGER :: ji,jj, jl ! dummy loop indices 672 INTEGER :: krdg_index !673 614 REAL(wp) :: Gstari, astari, hi, hrmean, zdummy ! local scalar 674 615 REAL(wp), POINTER, DIMENSION(:,:) :: zworka ! temporary array used here … … 746 687 !----------------------------------------------------------------- 747 688 748 krdg_index = 1 749 750 IF( krdg_index == 0 ) THEN !--- Linear formulation (Thorndike et al., 1975) 751 DO jl = 0, ice_cat_bounds(1,2) ! only undeformed ice participates 689 IF( partfun_swi == 0 ) THEN !--- Linear formulation (Thorndike et al., 1975) 690 DO jl = 0, jpl 752 691 DO jj = 1, jpj 753 692 DO ji = 1, jpi … … 772 711 Gsum(:,:,jl) = EXP( -Gsum(:,:,jl) * astari ) * zdummy 773 712 END DO !jl 774 DO jl = 0, ice_cat_bounds(1,2)713 DO jl = 0, jpl 775 714 athorn(:,:,jl) = Gsum(:,:,jl-1) - Gsum(:,:,jl) 776 715 END DO 777 716 ! 778 ENDIF ! krdg_index779 780 IF( raft swi == 1 ) THEN ! Ridging and rafting ice participation functions717 ENDIF ! partfun_swi 718 719 IF( raft_swi == 1 ) THEN ! Ridging and rafting ice participation functions 781 720 ! 782 721 DO jl = 1, jpl … … 794 733 END DO ! jl 795 734 796 ELSE ! raft swi = 0735 ELSE ! raft_swi = 0 797 736 ! 798 737 DO jl = 1, jpl … … 802 741 ENDIF 803 742 804 IF ( raft swi == 1 ) THEN743 IF ( raft_swi == 1 ) THEN 805 744 806 745 IF( MAXVAL(aridge + araft - athorn(:,:,1:jpl)) .GT. epsi10 ) THEN … … 908 847 INTEGER :: ij ! horizontal index, combines i and j loops 909 848 INTEGER :: icells ! number of cells with aicen > puny 910 REAL(wp) :: zindb, zsrdg2 ! local scalar911 849 REAL(wp) :: hL, hR, farea, zdummy, zdummy0, ztmelts ! left and right limits of integration 850 REAL(wp) :: zsstK ! SST in Kelvin 912 851 913 852 INTEGER , POINTER, DIMENSION(:) :: indxi, indxj ! compressed indices … … 917 856 918 857 REAL(wp), POINTER, DIMENSION(:,:,:) :: aicen_init, vicen_init ! ice area & volume before ridging 919 REAL(wp), POINTER, DIMENSION(:,:,:) :: vsn on_init, esnon_init ! snow volume & energy before ridging858 REAL(wp), POINTER, DIMENSION(:,:,:) :: vsnwn_init, esnwn_init ! snow volume & energy before ridging 920 859 REAL(wp), POINTER, DIMENSION(:,:,:) :: smv_i_init, oa_i_init ! ice salinity & age before ridging 921 860 … … 952 891 CALL wrk_alloc( jpi, jpj, vrdg1, vrdg2, vsw , srdg1, srdg2, smsw ) 953 892 CALL wrk_alloc( jpi, jpj, afrft, arft1, arft2, virft, vsrft, esrft, smrft, oirft1, oirft2 ) 954 CALL wrk_alloc( jpi, jpj, jpl, aicen_init, vicen_init, vsn on_init, esnon_init, smv_i_init, oa_i_init )955 CALL wrk_alloc( jpi, jpj, jkmax, eirft, erdg1, erdg2, ersw )956 CALL wrk_alloc( jpi, jpj, jkmax, jpl, eicen_init )893 CALL wrk_alloc( jpi, jpj, jpl, aicen_init, vicen_init, vsnwn_init, esnwn_init, smv_i_init, oa_i_init ) 894 CALL wrk_alloc( jpi, jpj, nlay_i+1, eirft, erdg1, erdg2, ersw ) 895 CALL wrk_alloc( jpi, jpj, nlay_i+1, jpl, eicen_init ) 957 896 958 897 ! Conservation check … … 1008 947 aicen_init(:,:,jl) = a_i(:,:,jl) 1009 948 vicen_init(:,:,jl) = v_i(:,:,jl) 1010 vsn on_init(:,:,jl) = v_s(:,:,jl)949 vsnwn_init(:,:,jl) = v_s(:,:,jl) 1011 950 ! 1012 951 smv_i_init(:,:,jl) = smv_i(:,:,jl) … … 1014 953 END DO !jl 1015 954 1016 esn on_init(:,:,:) = e_s(:,:,1,:)955 esnwn_init(:,:,:) = e_s(:,:,1,:) 1017 956 1018 957 DO jl = 1, jpl … … 1091 1030 ! / rafting category n1. 1092 1031 !-------------------------------------------------------------------------- 1093 vrdg1(ji,jj) = vicen_init(ji,jj,jl1) * afrac(ji,jj) / ( 1._wp + ridge_por )1032 vrdg1(ji,jj) = vicen_init(ji,jj,jl1) * afrac(ji,jj) 1094 1033 vrdg2(ji,jj) = vrdg1(ji,jj) * ( 1. + ridge_por ) 1095 1034 vsw (ji,jj) = vrdg1(ji,jj) * ridge_por 1096 1035 1097 vsrdg(ji,jj) = vsn on_init(ji,jj,jl1) * afrac(ji,jj)1098 esrdg(ji,jj) = esn on_init(ji,jj,jl1) * afrac(ji,jj)1099 srdg1(ji,jj) = smv_i_init(ji,jj,jl1) * afrac(ji,jj) / ( 1._wp + ridge_por )1100 srdg2(ji,jj) = smv_i_init(ji,jj,jl1) * afrac(ji,jj) 1036 vsrdg(ji,jj) = vsnwn_init(ji,jj,jl1) * afrac(ji,jj) 1037 esrdg(ji,jj) = esnwn_init(ji,jj,jl1) * afrac(ji,jj) 1038 srdg1(ji,jj) = smv_i_init(ji,jj,jl1) * afrac(ji,jj) 1039 srdg2(ji,jj) = smv_i_init(ji,jj,jl1) * afrac(ji,jj) !! MV HC 2014 this line seems useless 1101 1040 1102 1041 ! rafting volumes, heat contents ... 1103 1042 virft(ji,jj) = vicen_init(ji,jj,jl1) * afrft(ji,jj) 1104 vsrft(ji,jj) = vsn on_init(ji,jj,jl1) * afrft(ji,jj)1105 esrft(ji,jj) = esn on_init(ji,jj,jl1) * afrft(ji,jj)1043 vsrft(ji,jj) = vsnwn_init(ji,jj,jl1) * afrft(ji,jj) 1044 esrft(ji,jj) = esnwn_init(ji,jj,jl1) * afrft(ji,jj) 1106 1045 smrft(ji,jj) = smv_i_init(ji,jj,jl1) * afrft(ji,jj) 1107 1046 … … 1120 1059 ! Salinity 1121 1060 !------------- 1122 smsw(ji,jj) = sss_m(ji,jj) * vsw(ji,jj) * rhoic / rau0 ! salt content of seawater frozen in voids 1123 1124 zsrdg2 = srdg1(ji,jj) + smsw(ji,jj) ! salt content of new ridge 1125 1126 srdg2(ji,jj) = MIN( s_i_max * vrdg2(ji,jj) , zsrdg2 ) ! impose a maximum salinity 1061 smsw(ji,jj) = vsw(ji,jj) * sss_m(ji,jj) ! salt content of seawater frozen in voids !! MV HC2014 1062 srdg2(ji,jj) = srdg1(ji,jj) + smsw(ji,jj) ! salt content of new ridge 1063 1064 !srdg2(ji,jj) = MIN( s_i_max * vrdg2(ji,jj) , zsrdg2 ) ! impose a maximum salinity 1127 1065 1128 ! ! excess of salt is flushed into the ocean 1129 !sfx_mec(ji,jj) = sfx_mec(ji,jj) + ( zsrdg2 - srdg2(ji,jj) ) * rhoic * r1_rdtice 1130 1131 !rdm_ice(ji,jj) = rdm_ice(ji,jj) + vsw(ji,jj) * rhoic ! gurvan: increase in ice volume du to seawater frozen in voids 1066 sfx_dyn(ji,jj) = sfx_dyn(ji,jj) - smsw(ji,jj) * rhoic * r1_rdtice 1067 wfx_dyn(ji,jj) = wfx_dyn(ji,jj) - vsw (ji,jj) * rhoic * r1_rdtice ! gurvan: increase in ice volume du to seawater frozen in voids 1132 1068 1133 1069 !------------------------------------ … … 1158 1094 & + rhosn*vsrft(ji,jj)*(1.0-fsnowrft) 1159 1095 1160 esnow_mlt(ji,jj) = esnow_mlt(ji,jj) + esrdg(ji,jj)*(1.0-fsnowrdg) & !rafting included 1161 & + esrft(ji,jj)*(1.0-fsnowrft) 1096 ! in 1e-9 Joules (same as e_s) 1097 esnow_mlt(ji,jj) = esnow_mlt(ji,jj) - esrdg(ji,jj)*(1.0-fsnowrdg) & !rafting included 1098 & - esrft(ji,jj)*(1.0-fsnowrft) 1162 1099 1163 1100 !----------------------------------------------------------------- … … 1184 1121 jj = indxj(ij) 1185 1122 ! heat content of ridged ice 1186 erdg1(ji,jj,jk) = eicen_init(ji,jj,jk,jl1) * afrac(ji,jj) / ( 1._wp + ridge_por )1123 erdg1(ji,jj,jk) = eicen_init(ji,jj,jk,jl1) * afrac(ji,jj) 1187 1124 eirft(ji,jj,jk) = eicen_init(ji,jj,jk,jl1) * afrft(ji,jj) 1188 1125 e_i (ji,jj,jk,jl1) = e_i(ji,jj,jk,jl1) - erdg1(ji,jj,jk) - eirft(ji,jj,jk) 1189 ! sea water heat content 1190 ztmelts = - tmut * sss_m(ji,jj) + rtt 1191 ! heat content per unit volume 1192 zdummy0 = - rcp * ( sst_m(ji,jj) + rt0 - rtt ) * vsw(ji,jj) 1193 1194 ! corrected sea water salinity 1195 zindb = MAX( 0._wp , SIGN( 1._wp , vsw(ji,jj) - epsi20 ) ) 1196 zdummy = zindb * ( srdg1(ji,jj) - srdg2(ji,jj) ) / MAX( ridge_por * vsw(ji,jj), epsi20 ) 1197 1198 ztmelts = - tmut * zdummy + rtt 1199 ersw(ji,jj,jk) = - rcp * ( ztmelts - rtt ) * vsw(ji,jj) 1200 1201 ! heat flux 1202 fheat_mec(ji,jj) = fheat_mec(ji,jj) + ( ersw(ji,jj,jk) - zdummy0 ) * r1_rdtice 1126 1127 1128 ! enthalpy of the trapped seawater (J/m2, >0) 1129 ! clem: if sst>0, then ersw <0 (is that possible?) 1130 zsstK = sst_m(ji,jj) + rt0 1131 ersw(ji,jj,jk) = - rhoic * vsw(ji,jj) * rcp * ( zsstK - rt0 ) / REAL( nlay_i ) 1132 1133 ! heat flux to the ocean 1134 hfx_dyn(ji,jj) = hfx_dyn(ji,jj) + ersw(ji,jj,jk) * r1_rdtice ! > 0 [W.m-2] ocean->ice flux 1203 1135 1204 1136 ! Correct dimensions to avoid big values 1205 ersw(ji,jj,jk) = ersw(ji,jj,jk) * 1.e-09 1206 1207 ! Mutliply by ice volume, and divide by number of layers to get heat content in 10^9 J 1208 ersw (ji,jj,jk) = ersw(ji,jj,jk) * area(ji,jj) * vsw(ji,jj) / REAL( nlay_i ) 1137 ersw(ji,jj,jk) = ersw(ji,jj,jk) / unit_fac 1138 1139 ! Mutliply by ice volume, and divide by number of layers to get heat content in 1.e9 J 1140 ! it is added to sea ice because the sign convention is the opposite of the sign convention for the ocean 1141 !! MV HC 2014 1142 ersw (ji,jj,jk) = ersw(ji,jj,jk) * area(ji,jj) 1209 1143 1210 1144 erdg2(ji,jj,jk) = erdg1(ji,jj,jk) + ersw(ji,jj,jk) 1145 1211 1146 END DO ! ij 1212 1147 END DO !jk … … 1253 1188 !------------------------------------------------------------------------------- 1254 1189 ! jl1 looping 1-jpl 1255 DO jl2 = ice_cat_bounds(1,1), ice_cat_bounds(1,2)1190 DO jl2 = 1, jpl 1256 1191 ! over categories to which ridged ice is transferred 1257 1192 !CDIR NODEP … … 1298 1233 END DO ! jl2 (new ridges) 1299 1234 1300 DO jl2 = ice_cat_bounds(1,1), ice_cat_bounds(1,2)1235 DO jl2 = 1, jpl 1301 1236 1302 1237 !CDIR NODEP … … 1361 1296 CALL wrk_dealloc( jpi, jpj, vrdg1, vrdg2, vsw , srdg1, srdg2, smsw ) 1362 1297 CALL wrk_dealloc( jpi, jpj, afrft, arft1, arft2, virft, vsrft, esrft, smrft, oirft1, oirft2 ) 1363 CALL wrk_dealloc( jpi, jpj, jpl, aicen_init, vicen_init, vsn on_init, esnon_init, smv_i_init, oa_i_init )1364 CALL wrk_dealloc( jpi, jpj, jkmax, eirft, erdg1, erdg2, ersw )1365 CALL wrk_dealloc( jpi, jpj, jkmax, jpl, eicen_init )1298 CALL wrk_dealloc( jpi, jpj, jpl, aicen_init, vicen_init, vsnwn_init, esnwn_init, smv_i_init, oa_i_init ) 1299 CALL wrk_dealloc( jpi, jpj, nlay_i+1, eirft, erdg1, erdg2, ersw ) 1300 CALL wrk_dealloc( jpi, jpj, nlay_i+1, jpl, eicen_init ) 1366 1301 ! 1367 1302 END SUBROUTINE lim_itd_me_ridgeshift … … 1404 1339 !!------------------------------------------------------------------- 1405 1340 INTEGER :: ios ! Local integer output status for namelist read 1406 NAMELIST/namiceitdme/ ridge_scheme_swi, Cs, Cf, fsnowrdg, fsnowrft,& 1407 Gstar, astar, & 1408 Hstar, raftswi, hparmeter, Craft, ridge_por, & 1409 sal_max_ridge, partfun_swi, transfun_swi, & 1410 brinstren_swi 1341 NAMELIST/namiceitdme/ ridge_scheme_swi, Cs, Cf, fsnowrdg, fsnowrft, & 1342 & Gstar, astar, Hstar, raft_swi, hparmeter, Craft, ridge_por, & 1343 & partfun_swi, brinstren_swi 1411 1344 !!------------------------------------------------------------------- 1412 1345 ! … … 1432 1365 WRITE(numout,*)' Equivalent to G* for an exponential part function astar ', astar 1433 1366 WRITE(numout,*)' Quantity playing a role in max ridged ice thickness Hstar ', Hstar 1434 WRITE(numout,*)' Rafting of ice sheets or not raft swi ', raftswi1367 WRITE(numout,*)' Rafting of ice sheets or not raft_swi ', raft_swi 1435 1368 WRITE(numout,*)' Parmeter thickness (threshold between ridge-raft) hparmeter ', hparmeter 1436 1369 WRITE(numout,*)' Rafting hyperbolic tangent coefficient Craft ', Craft 1437 1370 WRITE(numout,*)' Initial porosity of ridges ridge_por ', ridge_por 1438 WRITE(numout,*)' Maximum salinity of ridging ice sal_max_ridge ', sal_max_ridge1439 1371 WRITE(numout,*)' Switch for part. function (0) linear (1) exponential partfun_swi ', partfun_swi 1440 WRITE(numout,*)' Switch for tran. function (0) linear (1) exponential transfun_swi ', transfun_swi1441 1372 WRITE(numout,*)' Switch for including brine volume in ice strength comp. brinstren_swi ', brinstren_swi 1442 1373 ENDIF … … 1462 1393 1463 1394 REAL(wp), POINTER, DIMENSION(:,:) :: zmask ! 2D workspace 1464 REAL(wp) :: zmask_glo 1395 REAL(wp) :: zmask_glo, zsal, zvi, zvs, zei, zes 1465 1396 !!gm REAL(wp) :: xtmp ! temporary variable 1466 1397 !!------------------------------------------------------------------- … … 1468 1399 CALL wrk_alloc( jpi, jpj, zmask ) 1469 1400 1401 ! to be sure that at_i is the sum of a_i(jl) 1402 at_i(:,:) = SUM( a_i(:,:,:), dim=3 ) 1403 1470 1404 DO jl = 1, jpl 1471 1472 1405 !----------------------------------------------------------------- 1473 1406 ! Count categories to be zapped. 1474 ! Abort model in case of negative area.1475 1407 !----------------------------------------------------------------- 1476 1408 icells = 0 … … 1478 1410 DO jj = 1, jpj 1479 1411 DO ji = 1, jpi 1480 IF( ( a_i(ji,jj,jl) >= -epsi10 .AND. a_i(ji,jj,jl) < 0._wp ) .OR. & 1481 & ( a_i(ji,jj,jl) > 0._wp .AND. a_i(ji,jj,jl) <= epsi10 ) .OR. & 1482 & ( v_i(ji,jj,jl) == 0._wp .AND. a_i(ji,jj,jl) > 0._wp ) .OR. & 1483 & ( v_i(ji,jj,jl) > 0._wp .AND. v_i(ji,jj,jl) <= epsi10 ) ) zmask(ji,jj) = 1._wp 1412 IF( a_i(ji,jj,jl) <= epsi10 .OR. v_i(ji,jj,jl) <= epsi10 .OR. at_i(ji,jj) <= epsi10 ) THEN 1413 zmask(ji,jj) = 1._wp 1414 ENDIF 1484 1415 END DO 1485 1416 END DO … … 1494 1425 DO jj = 1 , jpj 1495 1426 DO ji = 1 , jpi 1496 !!gm xtmp = e_i(ji,jj,jk,jl) / area(ji,jj) * r1_rdtice 1497 !!gm xtmp = xtmp * unit_fac 1498 ! fheat_res(ji,jj) = fheat_res(ji,jj) - xtmp 1427 zei = e_i(ji,jj,jk,jl) 1499 1428 e_i(ji,jj,jk,jl) = e_i(ji,jj,jk,jl) * ( 1._wp - zmask(ji,jj) ) 1429 t_i(ji,jj,jk,jl) = t_i(ji,jj,jk,jl) * ( 1._wp - zmask(ji,jj) ) + rtt * zmask(ji,jj) 1430 ! update exchanges with ocean 1431 hfx_res(ji,jj) = hfx_res(ji,jj) + ( e_i(ji,jj,jk,jl) - zei ) * unit_fac / area(ji,jj) * r1_rdtice ! W.m-2 <0 1500 1432 END DO 1501 1433 END DO … … 1504 1436 DO jj = 1 , jpj 1505 1437 DO ji = 1 , jpi 1506 1438 1439 zsal = smv_i(ji,jj,jl) 1440 zvi = v_i(ji,jj,jl) 1441 zvs = v_s(ji,jj,jl) 1442 zes = e_s(ji,jj,1,jl) 1507 1443 !----------------------------------------------------------------- 1508 1444 ! Zap snow energy and use ocean heat to melt snow … … 1514 1450 ! fluxes are positive to the ocean 1515 1451 ! here the flux has to be negative for the ocean 1516 !!gm xtmp = ( rhosn*cpic*( rtt-t_s(ji,jj,1,jl) ) + rhosn*lfus ) * r1_rdtice1517 ! fheat_res(ji,jj) = fheat_res(ji,jj) - xtmp1518 1519 !!gm xtmp = ( rhosn*cpic*( rtt-t_s(ji,jj,1,jl) ) + rhosn*lfus ) * r1_rdtice !RB ???????1520 1521 1452 t_s(ji,jj,1,jl) = rtt * zmask(ji,jj) + t_s(ji,jj,1,jl) * ( 1._wp - zmask(ji,jj) ) 1522 1453 … … 1524 1455 ! zap ice and snow volume, add water and salt to ocean 1525 1456 !----------------------------------------------------------------- 1526 1527 ! xtmp = (rhoi*vicen(i,j,n) + rhos*vsnon(i,j,n)) / dt 1528 ! sfx_res(ji,jj) = sfx_res(ji,jj) + ( sss_m(ji,jj) ) & 1529 ! * rhosn * v_s(ji,jj,jl) * r1_rdtice 1530 ! sfx_res(ji,jj) = sfx_res(ji,jj) + ( sss_m(ji,jj) - sm_i(ji,jj,jl) ) & 1531 ! * rhoic * v_i(ji,jj,jl) * r1_rdtice 1532 ! sfx (i,j) = sfx (i,j) + xtmp 1533 1534 ato_i(ji,jj) = a_i (ji,jj,jl) * zmask(ji,jj) + ato_i(ji,jj) 1457 ato_i(ji,jj) = a_i (ji,jj,jl) * zmask(ji,jj) + ato_i(ji,jj) 1535 1458 a_i (ji,jj,jl) = a_i (ji,jj,jl) * ( 1._wp - zmask(ji,jj) ) 1536 1459 v_i (ji,jj,jl) = v_i (ji,jj,jl) * ( 1._wp - zmask(ji,jj) ) … … 1539 1462 oa_i (ji,jj,jl) = oa_i (ji,jj,jl) * ( 1._wp - zmask(ji,jj) ) 1540 1463 smv_i(ji,jj,jl) = smv_i(ji,jj,jl) * ( 1._wp - zmask(ji,jj) ) 1541 ! 1464 e_s(ji,jj,1,jl) = e_s(ji,jj,1,jl) * ( 1._wp - zmask(ji,jj) ) 1465 ! additional condition 1466 IF( v_s(ji,jj,jl) <= epsi10 ) THEN 1467 v_s(ji,jj,jl) = 0._wp 1468 e_s(ji,jj,1,jl) = 0._wp 1469 ENDIF 1470 ! update exchanges with ocean 1471 sfx_res(ji,jj) = sfx_res(ji,jj) - ( smv_i(ji,jj,jl) - zsal ) * rhoic * r1_rdtice 1472 wfx_res(ji,jj) = wfx_res(ji,jj) - ( v_i(ji,jj,jl) - zvi ) * rhoic * r1_rdtice 1473 wfx_snw(ji,jj) = wfx_snw(ji,jj) - ( v_s(ji,jj,jl) - zvs ) * rhosn * r1_rdtice 1474 hfx_res(ji,jj) = hfx_res(ji,jj) + ( e_s(ji,jj,1,jl) - zes ) * unit_fac / area(ji,jj) * r1_rdtice ! W.m-2 <0 1542 1475 END DO 1543 1476 END DO 1544 ! 1545 END DO ! jl 1477 END DO ! jl 1478 1479 ! to be sure that at_i is the sum of a_i(jl) 1480 at_i(:,:) = SUM( a_i(:,:,:), dim=3 ) 1546 1481 ! 1547 1482 CALL wrk_dealloc( jpi, jpj, zmask ) -
branches/2014/dev_r4650_UKMO14.12_STAND_ALONE_OBSOPER/NEMOGCM/NEMO/LIM_SRC_3/limitd_th.F90
r4333 r5034 6 6 !! History : - ! (W. H. Lipscomb and E.C. Hunke) CICE (c) original code 7 7 !! 3.0 ! 2005-12 (M. Vancoppenolle) adaptation to LIM-3 8 !! - ! 2006-06 (M. Vancoppenolle) adaptation to include salt, age and types8 !! - ! 2006-06 (M. Vancoppenolle) adaptation to include salt, age 9 9 !! - ! 2007-04 (M. Vancoppenolle) Mass conservation checked 10 10 !!---------------------------------------------------------------------- … … 35 35 USE lib_fortran ! to use key_nosignedzero 36 36 USE timing ! Timing 37 USE limcons ! conservation tests 37 38 38 39 IMPLICIT NONE … … 44 45 PUBLIC lim_itd_fitline 45 46 PUBLIC lim_itd_shiftice 46 47 REAL(wp) :: epsi10 = 1.e-10_wp !48 REAL(wp) :: epsi06 = 1.e-6_wp !49 47 50 48 !!---------------------------------------------------------------------- … … 65 63 INTEGER, INTENT(in) :: kt ! time step index 66 64 ! 67 INTEGER :: j l, ja, jm, jbnd1, jbnd2 ! ice typesdummy loop index68 REAL(wp) :: zchk_v_i, zchk_smv, zchk_fs, zchk_fw, zchk_v_i_b, zchk_smv_b, zchk_fs_b, zchk_fw_b ! Check conservation (C Rousset)69 REAL(wp) :: z chk_vmin, zchk_amin, zchk_amax ! Check errors (C Rousset)65 INTEGER :: ji, jj, jk, jl ! dummy loop index 66 ! 67 REAL(wp) :: zvi_b, zsmv_b, zei_b, zfs_b, zfw_b, zft_b 70 68 !!------------------------------------------------------------------ 71 69 IF( nn_timing == 1 ) CALL timing_start('limitd_th') 72 70 73 ! ------------------------------- 74 !- check conservation (C Rousset) 75 IF (ln_limdiahsb) THEN 76 zchk_v_i_b = glob_sum( SUM( v_i(:,:,:), dim=3 ) * area(:,:) * tms(:,:) ) 77 zchk_smv_b = glob_sum( SUM( smv_i(:,:,:), dim=3 ) * area(:,:) * tms(:,:) ) 78 zchk_fw_b = glob_sum( rdm_ice(:,:) * area(:,:) * tms(:,:) ) 79 zchk_fs_b = glob_sum( ( sfx_bri(:,:) + sfx_thd(:,:) + sfx_res(:,:) + sfx_mec(:,:) ) * area(:,:) * tms(:,:) ) 80 ENDIF 81 !- check conservation (C Rousset) 82 ! ------------------------------- 71 ! conservation test 72 IF( ln_limdiahsb ) CALL lim_cons_hsm(0, 'limitd_th', zvi_b, zsmv_b, zei_b, zfw_b, zfs_b, zft_b) 83 73 84 74 IF( kt == nit000 .AND. lwp ) THEN … … 93 83 ! Given thermodynamic growth rates, transport ice between 94 84 ! thickness categories. 95 DO jm = 1, jpm 96 jbnd1 = ice_cat_bounds(jm,1) 97 jbnd2 = ice_cat_bounds(jm,2) 98 IF( ice_ncat_types(jm) > 1 ) CALL lim_itd_th_rem( jbnd1, jbnd2, jm, kt ) 99 END DO 85 IF( jpl > 1 ) CALL lim_itd_th_rem( 1, jpl, kt ) 100 86 ! 101 87 CALL lim_var_glo2eqv ! only for info … … 105 91 ! 3) Add frazil ice growing in leads. 106 92 !------------------------------------------------------------------------------| 107 108 93 CALL lim_thd_lac 109 94 CALL lim_var_glo2eqv ! only for info 110 111 IF(ln_ctl) THEN ! Control print95 96 IF(ln_ctl) THEN ! Control print 112 97 CALL prt_ctl_info(' ') 113 98 CALL prt_ctl_info(' - Cell values : ') … … 131 116 CALL prt_ctl(tab2d_1=sm_i (:,:,jl) , clinfo1= ' lim_itd_th : sm_i : ') 132 117 CALL prt_ctl(tab2d_1=smv_i (:,:,jl) , clinfo1= ' lim_itd_th : smv_i : ') 133 DO j a= 1, nlay_i118 DO jk = 1, nlay_i 134 119 CALL prt_ctl_info(' ') 135 CALL prt_ctl_info(' - Layer : ', ivar1=j a)120 CALL prt_ctl_info(' - Layer : ', ivar1=jk) 136 121 CALL prt_ctl_info(' ~~~~~~~') 137 CALL prt_ctl(tab2d_1=t_i(:,:,j a,jl) , clinfo1= ' lim_itd_th : t_i : ')138 CALL prt_ctl(tab2d_1=e_i(:,:,j a,jl) , clinfo1= ' lim_itd_th : e_i : ')122 CALL prt_ctl(tab2d_1=t_i(:,:,jk,jl) , clinfo1= ' lim_itd_th : t_i : ') 123 CALL prt_ctl(tab2d_1=e_i(:,:,jk,jl) , clinfo1= ' lim_itd_th : e_i : ') 139 124 END DO 140 125 END DO 141 126 ENDIF 142 127 ! 143 ! ------------------------------- 144 !- check conservation (C Rousset) 145 IF( ln_limdiahsb ) THEN 146 zchk_fs = glob_sum( ( sfx_bri(:,:) + sfx_thd(:,:) + sfx_res(:,:) + sfx_mec(:,:) ) * area(:,:) * tms(:,:) ) - zchk_fs_b 147 zchk_fw = glob_sum( rdm_ice(:,:) * area(:,:) * tms(:,:) ) - zchk_fw_b 148 149 zchk_v_i = ( glob_sum( SUM( v_i(:,:,:), dim=3 ) * area(:,:) * tms(:,:) ) - zchk_v_i_b - ( zchk_fw / rhoic ) ) * r1_rdtice 150 zchk_smv = ( glob_sum( SUM( smv_i(:,:,:), dim=3 ) * area(:,:) * tms(:,:) ) - zchk_smv_b ) * r1_rdtice + ( zchk_fs / rhoic ) 151 152 zchk_vmin = glob_min(v_i) 153 zchk_amax = glob_max(SUM(a_i,dim=3)) 154 zchk_amin = glob_min(a_i) 155 156 IF(lwp) THEN 157 IF ( ABS( zchk_v_i ) > 1.e-5 ) WRITE(numout,*) 'violation volume [m3/day] (limitd_th) = ',(zchk_v_i * rday) 158 IF ( ABS( zchk_smv ) > 1.e-4 ) WRITE(numout,*) 'violation saline [psu*m3/day] (limitd_th) = ',(zchk_smv * rday) 159 IF ( zchk_vmin < 0. ) WRITE(numout,*) 'violation v_i<0 [mm] (limitd_th) = ',(zchk_vmin * 1.e-3) 160 IF ( zchk_amax > amax+epsi10 ) WRITE(numout,*) 'violation a_i>amax (limitd_th) = ',zchk_amax 161 IF ( zchk_amin < 0. ) WRITE(numout,*) 'violation a_i<0 (limitd_th) = ',zchk_amin 162 ENDIF 163 ENDIF 164 !- check conservation (C Rousset) 165 ! ------------------------------- 128 ! conservation test 129 IF( ln_limdiahsb ) CALL lim_cons_hsm(1, 'limitd_th', zvi_b, zsmv_b, zei_b, zfw_b, zfs_b, zft_b) 166 130 ! 167 131 IF( nn_timing == 1 ) CALL timing_stop('limitd_th') … … 169 133 ! 170 134 171 SUBROUTINE lim_itd_th_rem( klbnd, kubnd, ntyp,kt )135 SUBROUTINE lim_itd_th_rem( klbnd, kubnd, kt ) 172 136 !!------------------------------------------------------------------ 173 137 !! *** ROUTINE lim_itd_th_rem *** … … 182 146 INTEGER , INTENT (in) :: klbnd ! Start thickness category index point 183 147 INTEGER , INTENT (in) :: kubnd ! End point on which the the computation is applied 184 INTEGER , INTENT (in) :: ntyp ! Number of the type used185 148 INTEGER , INTENT (in) :: kt ! Ocean time step 186 149 ! … … 190 153 REAL(wp) :: zx1, zwk1, zdh0, zetamin, zdamax ! local scalars 191 154 REAL(wp) :: zx2, zwk2, zda0, zetamax ! - - 192 REAL(wp) :: zx3, zareamin , zindb! - -155 REAL(wp) :: zx3, zareamin ! - - 193 156 CHARACTER (len = 15) :: fieldid 194 157 … … 200 163 REAL(wp), POINTER, DIMENSION(:,:,:) :: hL ! left boundary for the ITD for each thickness 201 164 REAL(wp), POINTER, DIMENSION(:,:,:) :: hR ! left boundary for the ITD for each thickness 202 REAL(wp), POINTER, DIMENSION(:,:,:) :: zht_i_ o! old ice thickness165 REAL(wp), POINTER, DIMENSION(:,:,:) :: zht_i_b ! old ice thickness 203 166 REAL(wp), POINTER, DIMENSION(:,:,:) :: dummy_es 204 167 REAL(wp), POINTER, DIMENSION(:,:,:) :: zdaice, zdvice ! local increment of ice area and volume … … 218 181 CALL wrk_alloc( jpi,jpj, zremap_flag ) ! integer 219 182 CALL wrk_alloc( jpi,jpj,jpl-1, zdonor ) ! integer 220 CALL wrk_alloc( jpi,jpj,jpl, zdhice, g0, g1, hL, hR, zht_i_ o, dummy_es )183 CALL wrk_alloc( jpi,jpj,jpl, zdhice, g0, g1, hL, hR, zht_i_b, dummy_es ) 221 184 CALL wrk_alloc( jpi,jpj,jpl-1, zdaice, zdvice ) 222 185 CALL wrk_alloc( jpi,jpj,jpl+1, zhbnew, kkstart = 0 ) … … 247 210 WRITE(numout,*) ' klbnd : ', klbnd 248 211 WRITE(numout,*) ' kubnd : ', kubnd 249 WRITE(numout,*) ' ntyp : ', ntyp250 212 ENDIF 251 213 … … 254 216 DO jj = 1, jpj 255 217 DO ji = 1, jpi 256 zindb= 1.0 - MAX( 0.0, SIGN( 1.0, - a_i(ji,jj,jl) + epsi10 ) ) !0 if no ice and 1 if yes257 ht_i(ji,jj,jl) = v_i(ji,jj,jl) / MAX( a_i(ji,jj,jl), epsi10 ) * zindb258 zindb = 1.0 - MAX( 0.0, SIGN( 1.0, - old_a_i(ji,jj,jl) + epsi10) ) !0 if no ice and 1 if yes259 zht_i_ o(ji,jj,jl) = old_v_i(ji,jj,jl) / MAX( old_a_i(ji,jj,jl), epsi10 ) * zindb260 IF( a_i(ji,jj,jl) > epsi 06 ) zdhice(ji,jj,jl) = ht_i(ji,jj,jl) - zht_i_o(ji,jj,jl)218 rswitch = 1.0 - MAX( 0.0, SIGN( 1.0, - a_i(ji,jj,jl) + epsi10 ) ) !0 if no ice and 1 if yes 219 ht_i(ji,jj,jl) = v_i(ji,jj,jl) / MAX( a_i(ji,jj,jl), epsi10 ) * rswitch 220 rswitch = 1.0 - MAX( 0.0, SIGN( 1.0, - a_i_b(ji,jj,jl) + epsi10) ) !0 if no ice and 1 if yes 221 zht_i_b(ji,jj,jl) = v_i_b(ji,jj,jl) / MAX( a_i_b(ji,jj,jl), epsi10 ) * rswitch 222 IF( a_i(ji,jj,jl) > epsi10 ) zdhice(ji,jj,jl) = ht_i(ji,jj,jl) - zht_i_b(ji,jj,jl) 261 223 END DO 262 224 END DO … … 302 264 ij = nind_j(ji) 303 265 ! 304 IF ( ( zht_i_o(ii,ij,jl) .GT. epsi10 ) .AND. &305 ( zht_i_o(ii,ij,jl+1) .GT. epsi10 )) THEN266 zhbnew(ii,ij,jl) = hi_max(jl) 267 IF ( a_i_b(ii,ij,jl) > epsi10 .AND. a_i_b(ii,ij,jl+1) > epsi10 ) THEN 306 268 !interpolate between adjacent category growth rates 307 zslope = ( zdhice(ii,ij,jl+1) - zdhice(ii,ij,jl) ) / & 308 ( zht_i_o (ii,ij,jl+1) - zht_i_o (ii,ij,jl) ) 309 zhbnew(ii,ij,jl) = hi_max(jl) + zdhice(ii,ij,jl) + & 310 zslope * ( hi_max(jl) - zht_i_o(ii,ij,jl) ) 311 ELSEIF (zht_i_o(ii,ij,jl).gt.epsi10) THEN 269 zslope = ( zdhice(ii,ij,jl+1) - zdhice(ii,ij,jl) ) / ( zht_i_b(ii,ij,jl+1) - zht_i_b(ii,ij,jl) ) 270 zhbnew(ii,ij,jl) = hi_max(jl) + zdhice(ii,ij,jl) + zslope * ( hi_max(jl) - zht_i_b(ii,ij,jl) ) 271 ELSEIF ( a_i_b(ii,ij,jl) > epsi10) THEN 312 272 zhbnew(ii,ij,jl) = hi_max(jl) + zdhice(ii,ij,jl) 313 ELSEIF ( zht_i_o(ii,ij,jl+1).gt.epsi10) THEN273 ELSEIF ( a_i_b(ii,ij,jl+1) > epsi10) THEN 314 274 zhbnew(ii,ij,jl) = hi_max(jl) + zdhice(ii,ij,jl+1) 315 ELSE316 zhbnew(ii,ij,jl) = hi_max(jl)317 275 ENDIF 318 276 END DO … … 320 278 !- 4.2 Check that each zhbnew lies between adjacent values of ice thickness 321 279 DO ji = 1, nbrem 322 ! jl, ji323 280 ii = nind_i(ji) 324 281 ij = nind_j(ji) 325 ! jl, ji 326 IF ( ( a_i(ii,ij,jl) .GT.epsi10) .AND. & 327 ( ht_i(ii,ij,jl).GE. zhbnew(ii,ij,jl) ) & 328 ) THEN 282 IF( a_i(ii,ij,jl) > epsi10 .AND. ht_i(ii,ij,jl) >= zhbnew(ii,ij,jl) ) THEN 329 283 zremap_flag(ii,ij) = 0 330 ELSEIF ( ( a_i(ii,ij,jl+1) .GT. epsi10 ) .AND. & 331 ( ht_i(ii,ij,jl+1).LE. zhbnew(ii,ij,jl) ) & 332 ) THEN 284 ELSEIF( a_i(ii,ij,jl+1) > epsi10 .AND. ht_i(ii,ij,jl+1) <= zhbnew(ii,ij,jl) ) THEN 333 285 zremap_flag(ii,ij) = 0 334 286 ENDIF 335 287 336 288 !- 4.3 Check that each zhbnew does not exceed maximal values hi_max 337 ! jl, ji 338 IF (zhbnew(ii,ij,jl).gt.hi_max(jl+1)) THEN 339 zremap_flag(ii,ij) = 0 340 ENDIF 341 ! jl, ji 342 IF (zhbnew(ii,ij,jl).lt.hi_max(jl-1)) THEN 343 zremap_flag(ii,ij) = 0 344 ENDIF 345 ! jl, ji 346 END DO !ji 347 ! ji 289 IF( zhbnew(ii,ij,jl) > hi_max(jl+1) ) zremap_flag(ii,ij) = 0 290 IF( zhbnew(ii,ij,jl) < hi_max(jl-1) ) zremap_flag(ii,ij) = 0 291 END DO 292 348 293 END DO !jl 349 294 … … 354 299 DO jj = 1, jpj 355 300 DO ji = 1, jpi 356 IF 301 IF( zremap_flag(ji,jj) == 1 ) THEN 357 302 nbrem = nbrem + 1 358 303 nind_i(nbrem) = ji 359 304 nind_j(nbrem) = jj 360 305 ENDIF 361 END DO !ji362 END DO !jj306 END DO 307 END DO 363 308 364 309 !----------------------------------------------------------------------------------------------- … … 367 312 DO jj = 1, jpj 368 313 DO ji = 1, jpi 369 zhb0(ji,jj) = hi_max _typ(0,ntyp) ! 0eme370 zhb1(ji,jj) = hi_max _typ(1,ntyp) ! 1er314 zhb0(ji,jj) = hi_max(0) ! 0eme 315 zhb1(ji,jj) = hi_max(1) ! 1er 371 316 372 317 zhbnew(ji,jj,klbnd-1) = 0._wp … … 380 325 ENDIF 381 326 382 IF( zhbnew(ji,jj,kubnd) < hi_max(kubnd-1) ) 327 IF( zhbnew(ji,jj,kubnd) < hi_max(kubnd-1) ) zhbnew(ji,jj,kubnd) = hi_max(kubnd-1) 383 328 384 329 END DO !jj … … 389 334 !----------------------------------------------------------------------------------------------- 390 335 !- 7.1 g(h) for category 1 at start of time step 391 CALL lim_itd_fitline( klbnd, zhb0, zhb1, zht_i_ o(:,:,klbnd), &336 CALL lim_itd_fitline( klbnd, zhb0, zhb1, zht_i_b(:,:,klbnd), & 392 337 & g0(:,:,klbnd), g1(:,:,klbnd), hL(:,:,klbnd), & 393 338 & hR(:,:,klbnd), zremap_flag ) … … 414 359 ! Constrain new thickness <= ht_i 415 360 zdamax = a_i(ii,ij,klbnd) * & 416 (1.0 - ht_i(ii,ij,klbnd)/zht_i_ o(ii,ij,klbnd)) ! zdamax > 0361 (1.0 - ht_i(ii,ij,klbnd)/zht_i_b(ii,ij,klbnd)) ! zdamax > 0 417 362 !ice area lost due to melting of thin ice 418 363 zda0 = MIN(zda0, zdamax) … … 428 373 ELSE ! if ice accretion 429 374 ! ji, a_i > epsi10; zdh0 > 0 430 IF ( ntyp .EQ. 1 )zhbnew(ii,ij,klbnd-1) = MIN(zdh0,hi_max(klbnd))375 zhbnew(ii,ij,klbnd-1) = MIN(zdh0,hi_max(klbnd)) 431 376 ! zhbnew was 0, and is shifted to the right to account for thin ice 432 377 ! growth in openwater (F0 = f1) 433 IF ( ntyp .NE. 1 ) zhbnew(ii,ij,0) = 0434 ! in other types there is435 ! no open water growth (F0 = 0)436 378 ENDIF ! zdh0 437 379 … … 444 386 DO jl = klbnd, kubnd 445 387 CALL lim_itd_fitline(jl, zhbnew(:,:,jl-1), zhbnew(:,:,jl), ht_i(:,:,jl), & 446 g0(:,:,jl), g1(:,:,jl), hL(:,:,jl), hR(:,:,jl), & 447 zremap_flag) 388 g0(:,:,jl), g1(:,:,jl), hL(:,:,jl), hR(:,:,jl), zremap_flag) 448 389 END DO 449 390 … … 493 434 nd = zdonor(ii,ij,jl) 494 435 zdaice(ii,ij,jl) = g1(ii,ij,nd)*zx2 + g0(ii,ij,nd)*zx1 495 zdvice(ii,ij,jl) = g1(ii,ij,nd)*zx3 + g0(ii,ij,nd)*zx2 + & 496 zdaice(ii,ij,jl)*hL(ii,ij,nd) 436 zdvice(ii,ij,jl) = g1(ii,ij,nd)*zx3 + g0(ii,ij,nd)*zx2 + zdaice(ii,ij,jl)*hL(ii,ij,nd) 497 437 498 438 END DO ! ji … … 511 451 ii = nind_i(ji) 512 452 ij = nind_j(ji) 513 IF ( ( a_i(ii,ij,1) > epsi10 ) .AND. ( ht_i(ii,ij,1) < hiclim )) THEN453 IF ( a_i(ii,ij,1) > epsi10 .AND. ht_i(ii,ij,1) < hiclim ) THEN 514 454 a_i(ii,ij,1) = a_i(ii,ij,1) * ht_i(ii,ij,1) / hiclim 515 455 ht_i(ii,ij,1) = hiclim 516 v_i(ii,ij,1) = a_i(ii,ij,1) * ht_i(ii,ij,1) !clem-useless517 456 ENDIF 518 457 END DO !ji … … 542 481 CALL wrk_dealloc( jpi,jpj, zremap_flag ) ! integer 543 482 CALL wrk_dealloc( jpi,jpj,jpl-1, zdonor ) ! integer 544 CALL wrk_dealloc( jpi,jpj,jpl, zdhice, g0, g1, hL, hR, zht_i_ o, dummy_es )483 CALL wrk_dealloc( jpi,jpj,jpl, zdhice, g0, g1, hL, hR, zht_i_b, dummy_es ) 545 484 CALL wrk_dealloc( jpi,jpj,jpl-1, zdaice, zdvice ) 546 485 CALL wrk_dealloc( jpi,jpj,jpl+1, zhbnew, kkstart = 0 ) … … 647 586 REAL(wp) :: zdo_aice ! ice age times volume transferred 648 587 REAL(wp) :: zdaTsf ! aicen*Tsfcn transferred 649 REAL(wp) :: zindsn ! snow or not650 REAL(wp) :: zindb ! ice or not651 588 652 589 INTEGER, POINTER, DIMENSION(:) :: nind_i, nind_j ! compressed indices for i/j directions … … 775 712 776 713 jl1 = zdonor(ii,ij,jl) 777 zindb= MAX( 0.0 , SIGN( 1.0 , v_i(ii,ij,jl1) - epsi10 ) )778 zworka(ii,ij) = zdvice(ii,ij,jl) / MAX(v_i(ii,ij,jl1),epsi10) * zindb714 rswitch = MAX( 0.0 , SIGN( 1.0 , v_i(ii,ij,jl1) - epsi10 ) ) 715 zworka(ii,ij) = zdvice(ii,ij,jl) / MAX(v_i(ii,ij,jl1),epsi10) * rswitch 779 716 IF( jl1 == jl) THEN ; jl2 = jl1+1 780 717 ELSE ; jl2 = jl … … 799 736 !-------------- 800 737 801 zdvsnow 738 zdvsnow = v_s(ii,ij,jl1) * zworka(ii,ij) 802 739 v_s(ii,ij,jl1) = v_s(ii,ij,jl1) - zdvsnow 803 740 v_s(ii,ij,jl2) = v_s(ii,ij,jl2) + zdvsnow … … 807 744 !-------------------- 808 745 809 zdesnow 746 zdesnow = e_s(ii,ij,1,jl1) * zworka(ii,ij) 810 747 e_s(ii,ij,1,jl1) = e_s(ii,ij,1,jl1) - zdesnow 811 748 e_s(ii,ij,1,jl2) = e_s(ii,ij,1,jl2) + zdesnow … … 815 752 !-------------- 816 753 817 zdo_aice 754 zdo_aice = oa_i(ii,ij,jl1) * zdaice(ii,ij,jl) 818 755 oa_i(ii,ij,jl1) = oa_i(ii,ij,jl1) - zdo_aice 819 756 oa_i(ii,ij,jl2) = oa_i(ii,ij,jl2) + zdo_aice … … 823 760 !-------------- 824 761 825 zdsm_vice 762 zdsm_vice = smv_i(ii,ij,jl1) * zworka(ii,ij) 826 763 smv_i(ii,ij,jl1) = smv_i(ii,ij,jl1) - zdsm_vice 827 764 smv_i(ii,ij,jl2) = smv_i(ii,ij,jl2) + zdsm_vice … … 831 768 !--------------------- 832 769 833 zdaTsf 770 zdaTsf = t_su(ii,ij,jl1) * zdaice(ii,ij,jl) 834 771 zaTsfn(ii,ij,jl1) = zaTsfn(ii,ij,jl1) - zdaTsf 835 772 zaTsfn(ii,ij,jl2) = zaTsfn(ii,ij,jl2) + zdaTsf … … 872 809 ht_i(ji,jj,jl) = v_i (ji,jj,jl) / a_i(ji,jj,jl) 873 810 t_su(ji,jj,jl) = zaTsfn(ji,jj,jl) / a_i(ji,jj,jl) 874 zindsn= 1.0 - MAX(0.0,SIGN(1.0,-v_s(ji,jj,jl)+epsi10)) !0 if no ice and 1 if yes811 rswitch = 1.0 - MAX(0.0,SIGN(1.0,-v_s(ji,jj,jl)+epsi10)) !0 if no ice and 1 if yes 875 812 ELSE 876 813 ht_i(ji,jj,jl) = 0._wp … … 888 825 889 826 890 SUBROUTINE lim_itd_th_reb( klbnd, kubnd , ntyp)827 SUBROUTINE lim_itd_th_reb( klbnd, kubnd ) 891 828 !!------------------------------------------------------------------ 892 829 !! *** ROUTINE lim_itd_th_reb *** … … 898 835 INTEGER , INTENT (in) :: klbnd ! Start thickness category index point 899 836 INTEGER , INTENT (in) :: kubnd ! End point on which the the computation is applied 900 INTEGER , INTENT (in) :: ntyp ! number of the ice type involved in the rebinning process901 837 ! 902 838 INTEGER :: ji,jj, jl ! dummy loop indices … … 910 846 REAL(wp), POINTER, DIMENSION(:,:) :: vt_s_init, vt_s_final ! snow volume summed over categories 911 847 !!------------------------------------------------------------------ 848 !! clem 2014/04: be carefull, rebining does not conserve salt(maybe?) => the difference is taken into account in limupdate 912 849 913 850 CALL wrk_alloc( jpi,jpj,jpl, zdonor ) ! interger … … 937 874 938 875 !------------------------------------------------------------------------------ 939 ! 2) Make sure thickness of cat klbnd is at least hi_max _typ(klbnd)876 ! 2) Make sure thickness of cat klbnd is at least hi_max(klbnd) 940 877 !------------------------------------------------------------------------------ 941 878 DO jj = 1, jpj 942 879 DO ji = 1, jpi 943 880 IF( a_i(ji,jj,klbnd) > epsi10 ) THEN 944 IF( ht_i(ji,jj,klbnd) <= hi_max _typ(0,ntyp) .AND. hi_max_typ(0,ntyp) > 0._wp ) THEN945 a_i(ji,jj,klbnd) = v_i(ji,jj,klbnd) / hi_max _typ(0,ntyp)946 ht_i(ji,jj,klbnd) = hi_max _typ(0,ntyp)881 IF( ht_i(ji,jj,klbnd) <= hi_max(0) .AND. hi_max(0) > 0._wp ) THEN 882 a_i(ji,jj,klbnd) = v_i(ji,jj,klbnd) / hi_max(0) 883 ht_i(ji,jj,klbnd) = hi_max(0) 947 884 ENDIF 948 885 ENDIF … … 1015 952 1016 953 !clem-change 954 DO jj = 1, jpj 955 DO ji = 1, jpi 956 IF( a_i(ji,jj,jl+1) > epsi10 .AND. ht_i(ji,jj,jl+1) <= hi_max(jl) ) THEN 957 ! 958 zshiftflag = 1 959 zdonor(ji,jj,jl) = jl + 1 960 zdaice(ji,jj,jl) = a_i(ji,jj,jl+1) 961 zdvice(ji,jj,jl) = v_i(ji,jj,jl+1) 962 ENDIF 963 END DO ! ji 964 END DO ! jj 965 966 IF(lk_mpp) CALL mpp_max( zshiftflag ) 967 968 IF( zshiftflag == 1 ) THEN ! Shift ice between categories 969 CALL lim_itd_shiftice( klbnd, kubnd, zdonor, zdaice, zdvice ) 970 ! Reset shift parameters 971 zdonor(:,:,jl) = 0 972 zdaice(:,:,jl) = 0._wp 973 zdvice(:,:,jl) = 0._wp 974 ENDIF 975 !clem-change 976 977 ! ! clem-change begin: why not doing that? 1017 978 ! DO jj = 1, jpj 1018 979 ! DO ji = 1, jpi 1019 ! IF( a_i(ji,jj,jl+1) > epsi10 .AND. & 1020 ! ht_i(ji,jj,jl+1) <= hi_max(jl) ) THEN 1021 ! ! 1022 ! zshiftflag = 1 1023 ! zdonor(ji,jj,jl) = jl + 1 1024 ! zdaice(ji,jj,jl) = a_i(ji,jj,jl+1) 1025 ! zdvice(ji,jj,jl) = v_i(ji,jj,jl+1) 980 ! IF( a_i(ji,jj,jl+1) > epsi10 .AND. ht_i(ji,jj,jl+1) <= hi_max(jl) ) THEN 981 ! ht_i(ji,jj,jl+1) = hi_max(jl) + epsi10 982 ! a_i (ji,jj,jl+1) = v_i(ji,jj,jl+1) / ht_i(ji,jj,jl+1) 1026 983 ! ENDIF 1027 984 ! END DO ! ji 1028 985 ! END DO ! jj 1029 !1030 ! IF(lk_mpp) CALL mpp_max( zshiftflag )1031 !1032 ! IF( zshiftflag == 1 ) THEN ! Shift ice between categories1033 ! CALL lim_itd_shiftice( klbnd, kubnd, zdonor, zdaice, zdvice )1034 ! ! Reset shift parameters1035 ! zdonor(:,:,jl) = 01036 ! zdaice(:,:,jl) = 0._wp1037 ! zdvice(:,:,jl) = 0._wp1038 ! ENDIF1039 !clem-change1040 1041 ! clem-change begin: why not doing that?1042 DO jj = 1, jpj1043 DO ji = 1, jpi1044 IF( a_i(ji,jj,jl+1) > epsi10 .AND. &1045 ht_i(ji,jj,jl+1) <= hi_max(jl) ) THEN1046 ht_i(ji,jj,jl+1) = hi_max(jl) + epsi101047 a_i (ji,jj,jl+1) = v_i(ji,jj,jl+1) / ht_i(ji,jj,jl+1)1048 ENDIF1049 END DO ! ji1050 END DO ! jj1051 986 ! clem-change end 1052 987 -
branches/2014/dev_r4650_UKMO14.12_STAND_ALONE_OBSOPER/NEMOGCM/NEMO/LIM_SRC_3/limrhg.F90
r4346 r5034 50 50 PUBLIC lim_rhg ! routine called by lim_dyn (or lim_dyn_2) 51 51 52 REAL(wp) :: epsi10 = 1.e-10_wp !53 REAL(wp) :: rzero = 0._wp ! constant values54 REAL(wp) :: rone = 1._wp ! constant values55 56 52 !! * Substitutions 57 53 # include "vectopt_loop_substitute.h90" … … 121 117 CHARACTER (len=50) :: charout 122 118 REAL(wp) :: zt11, zt12, zt21, zt22, ztagnx, ztagny, delta ! 123 REAL(wp) :: za, zstms, zsang, zmask ! local scalars 119 REAL(wp) :: za, zstms, zmask ! local scalars 120 REAL(wp) :: zc1, zc2, zc3 ! ice mass 124 121 125 122 REAL(wp) :: dtevp ! time step for subcycling … … 127 124 REAL(wp) :: z0, zr, zcca, zccb ! temporary scalars 128 125 REAL(wp) :: zu_ice2, zv_ice1 ! 129 REAL(wp) :: zddc, zdtc, zzdst ! delta on corners and on centre 126 REAL(wp) :: zddc, zdtc ! delta on corners and on centre 127 REAL(wp) :: zdst ! shear at the center of the grid point 130 128 REAL(wp) :: zdsshx, zdsshy ! term for the gradient of ocean surface 131 129 REAL(wp) :: sigma1, sigma2 ! internal ice stress 132 130 133 131 REAL(wp) :: zresm ! Maximal error on ice velocity 134 REAL(wp) :: zindb ! ice (1) or not (0)135 132 REAL(wp) :: zdummy ! dummy argument 136 133 REAL(wp) :: zintb, zintn ! dummy argument … … 142 139 REAL(wp), POINTER, DIMENSION(:,:) :: zcorl1, zcorl2 ! coriolis parameter on U/V points 143 140 REAL(wp), POINTER, DIMENSION(:,:) :: za1ct , za2ct ! temporary arrays 144 REAL(wp), POINTER, DIMENSION(:,:) :: zc1 ! ice mass145 REAL(wp), POINTER, DIMENSION(:,:) :: zusw ! temporary weight for ice strength computation146 141 REAL(wp), POINTER, DIMENSION(:,:) :: u_oce1, v_oce1 ! ocean u/v component on U points 147 142 REAL(wp), POINTER, DIMENSION(:,:) :: u_oce2, v_oce2 ! ocean u/v component on V points … … 149 144 REAL(wp), POINTER, DIMENSION(:,:) :: zf1 , zf2 ! arrays for internal stresses 150 145 151 REAL(wp), POINTER, DIMENSION(:,:) :: zd d , zdt ! Divergence andtension at centre of grid cells146 REAL(wp), POINTER, DIMENSION(:,:) :: zdt ! tension at centre of grid cells 152 147 REAL(wp), POINTER, DIMENSION(:,:) :: zds ! Shear on northeast corner of grid cells 153 REAL(wp), POINTER, DIMENSION(:,:) :: zdst ! Shear on centre of grid cells154 REAL(wp), POINTER, DIMENSION(:,:) :: deltat, deltac ! Delta at centre and corners of grid cells155 148 REAL(wp), POINTER, DIMENSION(:,:) :: zs1 , zs2 ! Diagonal stress tensor components zs1 and zs2 156 149 REAL(wp), POINTER, DIMENSION(:,:) :: zs12 ! Non-diagonal stress tensor component zs12 … … 162 155 163 156 CALL wrk_alloc( jpi,jpj, zpresh, zfrld1, zmass1, zcorl1, za1ct , zpreshc, zfrld2, zmass2, zcorl2, za2ct ) 164 CALL wrk_alloc( jpi,jpj, zc1 , u_oce1, u_oce2, u_ice2, zusw, v_oce1 , v_oce2, v_ice1 )165 CALL wrk_alloc( jpi,jpj, zf1 , deltat, zu_ice, zf2 , deltac, zv_ice , zdd , zdt , zds , zdst)166 CALL wrk_alloc( jpi,jpj, zd d , zdt , zds , zs1 , zs2 , zs12 , zresr , zpice )157 CALL wrk_alloc( jpi,jpj, u_oce1, u_oce2, u_ice2, v_oce1 , v_oce2, v_ice1 ) 158 CALL wrk_alloc( jpi,jpj, zf1 , zu_ice, zf2 , zv_ice , zdt , zds ) 159 CALL wrk_alloc( jpi,jpj, zdt , zds , zs1 , zs2 , zs12 , zresr , zpice ) 167 160 168 161 #if defined key_lim2 && ! defined key_lim2_vp … … 181 174 ! 182 175 !------------------------------------------------------------------------------! 183 ! 1) Ice -Snow mass (zc1), icestrength (zpresh) !176 ! 1) Ice strength (zpresh) ! 184 177 !------------------------------------------------------------------------------! 185 178 ! 186 179 ! Put every vector to 0 187 zpresh (:,:) = 0._wp ; zc1 (:,:) = 0._wp 180 delta_i(:,:) = 0._wp ; 181 zpresh (:,:) = 0._wp ; 188 182 zpreshc(:,:) = 0._wp 189 183 u_ice2 (:,:) = 0._wp ; v_ice1(:,:) = 0._wp 190 zdd (:,:) = 0._wp ; zdt (:,:) = 0._wp ; zds(:,:) = 0._wp 184 divu_i (:,:) = 0._wp ; zdt (:,:) = 0._wp ; zds(:,:) = 0._wp 185 shear_i(:,:) = 0._wp 191 186 192 187 #if defined key_lim3 … … 198 193 !CDIR NOVERRCHK 199 194 DO ji = 1 , jpi 200 zc1(ji,jj) = tms(ji,jj) * ( rhosn * vt_s(ji,jj) + rhoic * vt_i(ji,jj) )201 195 #if defined key_lim3 202 196 zpresh(ji,jj) = tms(ji,jj) * strength(ji,jj) … … 220 214 & tms(ji+1,jj) * wght(ji+1,jj+1,2,1) + & 221 215 & tms(ji,jj) * wght(ji+1,jj+1,1,1) 222 zusw(ji,jj) = 1.0 / MAX( zstms, epsd )223 216 zpreshc(ji,jj) = ( zpresh(ji+1,jj+1) * wght(ji+1,jj+1,2,2) + & 224 217 & zpresh(ji,jj+1) * wght(ji+1,jj+1,1,2) + & 225 218 & zpresh(ji+1,jj) * wght(ji+1,jj+1,2,1) + & 226 219 & zpresh(ji,jj) * wght(ji+1,jj+1,1,1) & 227 & ) * zusw(ji,jj)220 & ) / MAX( zstms, epsd ) 228 221 END DO 229 222 END DO … … 267 260 DO ji = fs_2, fs_jpim1 268 261 262 zc1 = tms(ji ,jj ) * ( rhosn * vt_s(ji ,jj ) + rhoic * vt_i(ji ,jj ) ) 263 zc2 = tms(ji+1,jj ) * ( rhosn * vt_s(ji+1,jj ) + rhoic * vt_i(ji+1,jj ) ) 264 zc3 = tms(ji ,jj+1) * ( rhosn * vt_s(ji ,jj+1) + rhoic * vt_i(ji ,jj+1) ) 265 269 266 zt11 = tms(ji ,jj) * e1t(ji ,jj) 270 267 zt12 = tms(ji+1,jj) * e1t(ji+1,jj) … … 277 274 278 275 ! Mass, coriolis coeff. and currents 279 zmass1(ji,jj) = ( zt12*zc1 (ji,jj) + zt11*zc1(ji+1,jj)) / (zt11+zt12+epsd)280 zmass2(ji,jj) = ( zt22*zc1 (ji,jj) + zt21*zc1(ji,jj+1)) / (zt21+zt22+epsd)276 zmass1(ji,jj) = ( zt12*zc1 + zt11*zc2 ) / (zt11+zt12+epsd) 277 zmass2(ji,jj) = ( zt22*zc1 + zt21*zc3 ) / (zt21+zt22+epsd) 281 278 zcorl1(ji,jj) = zmass1(ji,jj) * ( e1t(ji+1,jj)*fcor(ji,jj) + e1t(ji,jj)*fcor(ji+1,jj) ) & 282 279 & / ( e1t(ji,jj) + e1t(ji+1,jj) + epsd ) … … 346 343 ! 347 344 !- Divergence, tension and shear (Section a. Appendix B of Hunke & Dukowicz, 2002) 348 !- zdd(:,:), zdt(:,:): divergence and tension at centre of grid cells345 !- divu_i(:,:), zdt(:,:): divergence and tension at centre of grid cells 349 346 !- zds(:,:): shear on northeast corner of grid cells 350 347 ! … … 355 352 ! bugs (Martin, for Miguel). 356 353 ! 357 !- ALSO: arrays zd d, zdt, zds and delta could354 !- ALSO: arrays zdt, zds and delta could 358 355 ! be removed in the future to minimise memory demand. 359 356 ! … … 363 360 ! 364 361 ! 365 zdd(ji,jj) = ( e2u(ji,jj)*u_ice(ji,jj) &366 & -e2u(ji-1,jj)*u_ice(ji-1,jj) &367 & +e1v(ji,jj)*v_ice(ji,jj) &368 & -e1v(ji,jj-1)*v_ice(ji,jj-1) &369 & ) &370 & / area(ji,jj)362 divu_i(ji,jj) = ( e2u(ji,jj)*u_ice(ji,jj) & 363 & -e2u(ji-1,jj)*u_ice(ji-1,jj) & 364 & +e1v(ji,jj)*v_ice(ji,jj) & 365 & -e1v(ji,jj-1)*v_ice(ji,jj-1) & 366 & ) & 367 & / area(ji,jj) 371 368 372 369 zdt(ji,jj) = ( ( u_ice(ji,jj)/e2u(ji,jj) & … … 410 407 411 408 !- Calculate Delta at centre of grid cells 412 z zdst = ( e2u(ji , jj) * v_ice1(ji ,jj) &409 zdst = ( e2u(ji , jj) * v_ice1(ji ,jj) & 413 410 & - e2u(ji-1, jj) * v_ice1(ji-1,jj) & 414 411 & + e1v(ji, jj ) * u_ice2(ji,jj ) & … … 417 414 & / area(ji,jj) 418 415 419 delta = SQRT( zdd(ji,jj)*zdd(ji,jj) + ( zdt(ji,jj)*zdt(ji,jj) + zzdst*zzdst ) * usecc2 ) 420 ! MV rewriting 421 ! deltat(ji,jj) = MAX( SQRT(zdd(ji,jj)**2 + (zdt(ji,jj)**2 + zzdst**2)*usecc2), creepl ) 422 !!gm faster to replace the line above with simply: 423 !! deltat(ji,jj) = MAX( delta, creepl ) 424 !!gm end 425 deltat(ji,jj) = delta + creepl 426 ! END MV 416 delta = SQRT( divu_i(ji,jj)*divu_i(ji,jj) + ( zdt(ji,jj)*zdt(ji,jj) + zdst*zdst ) * usecc2 ) 417 delta_i(ji,jj) = delta + creepl 427 418 !-Calculate stress tensor components zs1 and zs2 428 419 !-at centre of grid cells (see section 3.5 of CICE user's guide). 429 !zs1(ji,jj) = ( zs1(ji,jj) - dtotel*( ( 1._wp - alphaevp) * zs1(ji,jj) + & 430 ! & ( delta / deltat(ji,jj) - zdd(ji,jj) / deltat(ji,jj) ) * zpresh(ji,jj) ) ) & 431 ! & / ( 1._wp + alphaevp * dtotel ) 432 433 !zs2(ji,jj) = ( zs2(ji,jj) - dtotel * ( ( 1._wp - alphaevp ) * ecc2 * zs2(ji,jj) - & 434 ! zdt(ji,jj) / deltat(ji,jj) * zpresh(ji,jj) ) ) & 435 ! & / ( 1._wp + alphaevp * ecc2 * dtotel ) 436 437 ! new formulation from S. Bouillon to help stabilizing the code (no need of alphaevp) 438 zs1(ji,jj) = ( zs1(ji,jj) + dtotel * ( ( zdd(ji,jj) / deltat(ji,jj) - delta / deltat(ji,jj) ) & 420 zs1(ji,jj) = ( zs1(ji,jj) + dtotel * ( ( divu_i(ji,jj) / delta_i(ji,jj) - delta / delta_i(ji,jj) ) & 439 421 & * zpresh(ji,jj) ) ) / ( 1._wp + dtotel ) 440 zs2(ji,jj) = ( zs2(ji,jj) + dtotel * ( ecci * zdt(ji,jj) / delta t(ji,jj) * zpresh(ji,jj) ) ) &422 zs2(ji,jj) = ( zs2(ji,jj) + dtotel * ( ecci * zdt(ji,jj) / delta_i(ji,jj) * zpresh(ji,jj) ) ) & 441 423 & / ( 1._wp + dtotel ) 442 424 … … 470 452 & / ( e1f(ji,jj) * e2f(ji,jj) ) 471 453 472 deltac(ji,jj)= SQRT(zddc**2+(zdtc**2+zds(ji,jj)**2)*usecc2) + creepl454 zddc = SQRT(zddc**2+(zdtc**2+zds(ji,jj)**2)*usecc2) + creepl 473 455 474 456 !-Calculate stress tensor component zs12 at corners (see section 3.5 of CICE user's guide). 475 !zs12(ji,jj) = ( zs12(ji,jj) - dtotel * ( (1.0-alphaevp) * ecc2 * zs12(ji,jj) - zds(ji,jj) / &476 ! & ( 2._wp * deltac(ji,jj) ) * zpreshc(ji,jj) ) ) &477 ! & / ( 1._wp + alphaevp * ecc2 * dtotel )478 479 ! new formulation from S. Bouillon to help stabilizing the code (no need of alphaevp)480 457 zs12(ji,jj) = ( zs12(ji,jj) + dtotel * & 481 & ( ecci * zds(ji,jj) / ( 2._wp * deltac(ji,jj)) * zpreshc(ji,jj) ) ) &458 & ( ecci * zds(ji,jj) / ( 2._wp * zddc ) * zpreshc(ji,jj) ) ) & 482 459 & / ( 1.0 + dtotel ) 483 460 … … 514 491 !CDIR NOVERRCHK 515 492 DO ji = fs_2, fs_jpim1 516 zmask = (1.0-MAX(rzero,SIGN(rone,-zmass1(ji,jj))))*tmu(ji,jj) 517 zsang = SIGN ( 1.0 , fcor(ji,jj) ) * sangvg 493 zmask = (1.0-MAX(0._wp,SIGN(1._wp,-zmass1(ji,jj))))*tmu(ji,jj) 518 494 z0 = zmass1(ji,jj)/dtevp 519 495 … … 525 501 (zv_ice1-v_oce1(ji,jj))**2) * (1.0-zfrld1(ji,jj)) 526 502 zr = z0*u_ice(ji,jj) + zf1(ji,jj) + za1ct(ji,jj) + & 527 za*( cangvg*u_oce1(ji,jj)-zsang*v_oce1(ji,jj))528 zcca = z0+za *cangvg529 zccb = zcorl1(ji,jj) +za*zsang503 za*(u_oce1(ji,jj)) 504 zcca = z0+za 505 zccb = zcorl1(ji,jj) 530 506 u_ice(ji,jj) = (zr+zccb*zv_ice1)/(zcca+epsd)*zmask 531 507 … … 538 514 #endif 539 515 #if defined key_bdy 540 ! clem: change u_ice and v_ice at the boundary for each iteration541 516 CALL bdy_ice_lim_dyn( 'U' ) 542 517 #endif … … 547 522 DO ji = fs_2, fs_jpim1 548 523 549 zmask = (1.0-MAX(rzero,SIGN(rone,-zmass2(ji,jj))))*tmv(ji,jj) 550 zsang = SIGN(1.0,fcor(ji,jj))*sangvg 524 zmask = (1.0-MAX(0._wp,SIGN(1._wp,-zmass2(ji,jj))))*tmv(ji,jj) 551 525 z0 = zmass2(ji,jj)/dtevp 552 526 ! SB modif because ocean has no slip boundary condition … … 557 531 (v_ice(ji,jj)-v_oce2(ji,jj))**2)*(1.0-zfrld2(ji,jj)) 558 532 zr = z0*v_ice(ji,jj) + zf2(ji,jj) + & 559 za2ct(ji,jj) + za*( cangvg*v_oce2(ji,jj)+zsang*u_oce2(ji,jj))560 zcca = z0+za *cangvg561 zccb = zcorl2(ji,jj) +za*zsang533 za2ct(ji,jj) + za*(v_oce2(ji,jj)) 534 zcca = z0+za 535 zccb = zcorl2(ji,jj) 562 536 v_ice(ji,jj) = (zr-zccb*zu_ice2)/(zcca+epsd)*zmask 563 537 … … 570 544 #endif 571 545 #if defined key_bdy 572 ! clem: change u_ice and v_ice at the boundary for each iteration573 546 CALL bdy_ice_lim_dyn( 'V' ) 574 547 #endif … … 579 552 !CDIR NOVERRCHK 580 553 DO ji = fs_2, fs_jpim1 581 zmask = (1.0-MAX(rzero,SIGN(rone,-zmass2(ji,jj))))*tmv(ji,jj) 582 zsang = SIGN(1.0,fcor(ji,jj))*sangvg 554 zmask = (1.0-MAX(0._wp,SIGN(1._wp,-zmass2(ji,jj))))*tmv(ji,jj) 583 555 z0 = zmass2(ji,jj)/dtevp 584 556 ! SB modif because ocean has no slip boundary condition … … 590 562 (v_ice(ji,jj)-v_oce2(ji,jj))**2)*(1.0-zfrld2(ji,jj)) 591 563 zr = z0*v_ice(ji,jj) + zf2(ji,jj) + & 592 za2ct(ji,jj) + za*( cangvg*v_oce2(ji,jj)+zsang*u_oce2(ji,jj))593 zcca = z0+za *cangvg594 zccb = zcorl2(ji,jj) +za*zsang564 za2ct(ji,jj) + za*(v_oce2(ji,jj)) 565 zcca = z0+za 566 zccb = zcorl2(ji,jj) 595 567 v_ice(ji,jj) = (zr-zccb*zu_ice2)/(zcca+epsd)*zmask 596 568 … … 603 575 #endif 604 576 #if defined key_bdy 605 ! clem: change u_ice and v_ice at the boundary for each iteration606 577 CALL bdy_ice_lim_dyn( 'V' ) 607 578 #endif … … 611 582 !CDIR NOVERRCHK 612 583 DO ji = fs_2, fs_jpim1 613 zmask = (1.0-MAX(rzero,SIGN(rone,-zmass1(ji,jj))))*tmu(ji,jj) 614 zsang = SIGN(1.0,fcor(ji,jj))*sangvg 584 zmask = (1.0-MAX(0._wp,SIGN(1._wp,-zmass1(ji,jj))))*tmu(ji,jj) 615 585 z0 = zmass1(ji,jj)/dtevp 616 ! SB modif because ocean has no slip boundary condition617 ! GG Bug618 ! zv_ice1 = 0.5*( (v_ice(ji,jj)+v_ice(ji,jj-1))*e1t(ji+1,jj) &619 ! & +(v_ice(ji+1,jj)+v_ice(ji+1,jj-1))*e1t(ji,jj)) &620 ! & /(e1t(ji+1,jj)+e1t(ji,jj)) * tmu(ji,jj)621 586 zv_ice1 = 0.5*( (v_ice(ji,jj)+v_ice(ji,jj-1))*e1t(ji,jj) & 622 587 & +(v_ice(ji+1,jj)+v_ice(ji+1,jj-1))*e1t(ji+1,jj)) & … … 626 591 (zv_ice1-v_oce1(ji,jj))**2)*(1.0-zfrld1(ji,jj)) 627 592 zr = z0*u_ice(ji,jj) + zf1(ji,jj) + za1ct(ji,jj) + & 628 za*( cangvg*u_oce1(ji,jj)-zsang*v_oce1(ji,jj))629 zcca = z0+za *cangvg630 zccb = zcorl1(ji,jj) +za*zsang593 za*(u_oce1(ji,jj)) 594 zcca = z0+za 595 zccb = zcorl1(ji,jj) 631 596 u_ice(ji,jj) = (zr+zccb*zv_ice1)/(zcca+epsd)*zmask 632 597 END DO ! ji … … 638 603 #endif 639 604 #if defined key_bdy 640 ! clem: change u_ice and v_ice at the boundary for each iteration641 605 CALL bdy_ice_lim_dyn( 'U' ) 642 606 #endif … … 661 625 ! 4) Prevent ice velocities when the ice is thin 662 626 !------------------------------------------------------------------------------! 663 !clem : add hminrhg in the namelist664 !665 627 ! If the ice thickness is below hminrhg (5cm) then ice velocity should equal the 666 628 ! ocean velocity, … … 670 632 !CDIR NOVERRCHK 671 633 DO ji = fs_2, fs_jpim1 672 zindb = MAX( 0.0, SIGN( 1.0, at_i(ji,jj) - epsi10 ) )673 !zdummy = zindb * vt_i(ji,jj) / MAX(at_i(ji,jj) , epsi10 )674 634 zdummy = vt_i(ji,jj) 675 635 IF ( zdummy .LE. hminrhg ) THEN … … 687 647 #endif 688 648 #if defined key_bdy 689 ! clem: change u_ice and v_ice at the boundary690 649 CALL bdy_ice_lim_dyn( 'U' ) 691 650 CALL bdy_ice_lim_dyn( 'V' ) … … 694 653 DO jj = k_j1+1, k_jpj-1 695 654 DO ji = fs_2, fs_jpim1 696 zindb = MAX( 0.0, SIGN( 1.0, at_i(ji,jj) - epsi10 ) )697 !zdummy = zindb * vt_i(ji,jj) / MAX(at_i(ji,jj) , epsi10 )698 655 zdummy = vt_i(ji,jj) 699 656 IF ( zdummy .LE. hminrhg ) THEN … … 717 674 !CDIR NOVERRCHK 718 675 DO ji = fs_2, jpim1 !RB bug no vect opt due to tmi 719 !- zdd(:,:), zdt(:,:): divergence and tension at centre676 !- divu_i(:,:), zdt(:,:): divergence and tension at centre 720 677 !- zds(:,:): shear on northeast corner of grid cells 721 zindb = MAX( 0.0, SIGN( 1.0, at_i(ji,jj) - epsi10 ) )722 !zdummy = zindb * vt_i(ji,jj) / MAX(at_i(ji,jj) , epsi10 )723 678 zdummy = vt_i(ji,jj) 724 679 IF ( zdummy .LE. hminrhg ) THEN 725 680 726 zdd(ji,jj) = ( e2u(ji,jj)*u_ice(ji,jj) &727 & -e2u(ji-1,jj)*u_ice(ji-1,jj) &728 & +e1v(ji,jj)*v_ice(ji,jj) &729 & -e1v(ji,jj-1)*v_ice(ji,jj-1) &730 & ) &731 & / area(ji,jj)681 divu_i(ji,jj) = ( e2u(ji,jj)*u_ice(ji,jj) & 682 & -e2u(ji-1,jj)*u_ice(ji-1,jj) & 683 & +e1v(ji,jj)*v_ice(ji,jj) & 684 & -e1v(ji,jj-1)*v_ice(ji,jj-1) & 685 & ) & 686 & / area(ji,jj) 732 687 733 688 zdt(ji,jj) = ( ( u_ice(ji,jj)/e2u(ji,jj) & … … 751 706 & * tmi(ji+1,jj) * tmi(ji+1,jj+1) 752 707 753 zdst (ji,jj)= ( e2u( ji , jj ) * v_ice1(ji ,jj ) &708 zdst = ( e2u( ji , jj ) * v_ice1(ji ,jj ) & 754 709 & - e2u( ji-1, jj ) * v_ice1(ji-1,jj ) & 755 710 & + e1v( ji , jj ) * u_ice2(ji ,jj ) & 756 711 & - e1v( ji , jj-1 ) * u_ice2(ji ,jj-1) ) / area(ji,jj) 757 712 758 ! deltat(ji,jj) = SQRT( zdd(ji,jj)*zdd(ji,jj) & 759 ! & + ( zdt(ji,jj)*zdt(ji,jj) + zdst(ji,jj)*zdst(ji,jj) ) * usecc2 & 760 ! & ) + creepl 761 ! MV rewriting 762 delta = SQRT( zdd(ji,jj)*zdd(ji,jj) + ( zdt(ji,jj)*zdt(ji,jj) + zdst(ji,jj)*zdst(ji,jj) ) * usecc2 ) 763 deltat(ji,jj) = delta + creepl 764 ! END MV 713 delta = SQRT( divu_i(ji,jj)*divu_i(ji,jj) + ( zdt(ji,jj)*zdt(ji,jj) + zdst*zdst ) * usecc2 ) 714 delta_i(ji,jj) = delta + creepl 765 715 766 716 ENDIF ! zdummy … … 777 727 DO jj = k_j1+1, k_jpj-1 778 728 DO ji = fs_2, fs_jpim1 779 divu_i (ji,jj) = zdd (ji,jj)780 delta_i(ji,jj) = deltat(ji,jj)781 729 ! begin TECLIM change 782 zdst (ji,jj)= ( e2u( ji , jj ) * v_ice1(ji,jj) &730 zdst= ( e2u( ji , jj ) * v_ice1(ji,jj) & 783 731 & - e2u( ji-1, jj ) * v_ice1(ji-1,jj) & 784 732 & + e1v( ji , jj ) * u_ice2(ji,jj) & 785 733 & - e1v( ji , jj-1 ) * u_ice2(ji,jj-1) ) / area(ji,jj) 786 shear_i(ji,jj) = SQRT( zdt(ji,jj) * zdt(ji,jj) + zdst (ji,jj) * zdst(ji,jj))734 shear_i(ji,jj) = SQRT( zdt(ji,jj) * zdt(ji,jj) + zdst * zdst ) 787 735 ! end TECLIM change 788 736 END DO … … 838 786 ! 839 787 CALL wrk_dealloc( jpi,jpj, zpresh, zfrld1, zmass1, zcorl1, za1ct , zpreshc, zfrld2, zmass2, zcorl2, za2ct ) 840 CALL wrk_dealloc( jpi,jpj, zc1 , u_oce1, u_oce2, u_ice2, zusw, v_oce1 , v_oce2, v_ice1 )841 CALL wrk_dealloc( jpi,jpj, zf1 , deltat, zu_ice, zf2 , deltac, zv_ice , zdd , zdt , zds , zdst)842 CALL wrk_dealloc( jpi,jpj, zd d , zdt , zds , zs1 , zs2 , zs12 , zresr , zpice )788 CALL wrk_dealloc( jpi,jpj, u_oce1, u_oce2, u_ice2, v_oce1 , v_oce2, v_ice1 ) 789 CALL wrk_dealloc( jpi,jpj, zf1 , zu_ice, zf2 , zv_ice , zdt , zds ) 790 CALL wrk_dealloc( jpi,jpj, zdt , zds , zs1 , zs2 , zs12 , zresr , zpice ) 843 791 844 792 END SUBROUTINE lim_rhg -
branches/2014/dev_r4650_UKMO14.12_STAND_ALONE_OBSOPER/NEMOGCM/NEMO/LIM_SRC_3/limrst.F90
r4205 r5034 142 142 CALL iom_rstput( iter, nitrst, numriw, znam , z2d ) 143 143 END DO 144 144 145 145 DO jl = 1, jpl 146 146 WRITE(zchar,'(I1)') jl … … 162 162 CALL iom_rstput( iter, nitrst, numriw, 'u_ice' , u_ice ) 163 163 CALL iom_rstput( iter, nitrst, numriw, 'v_ice' , v_ice ) 164 CALL iom_rstput( iter, nitrst, numriw, 'fsbbq' , fsbbq )165 164 CALL iom_rstput( iter, nitrst, numriw, 'stress1_i' , stress1_i ) 166 165 CALL iom_rstput( iter, nitrst, numriw, 'stress2_i' , stress2_i ) … … 309 308 INTEGER :: ji, jj, jk, jl, indx 310 309 REAL(wp) :: zfice, ziter 311 REAL(wp) :: zs_inf, z_slope_s, zsmax, zsmin, zalpha , zindb! local scalars used for the salinity profile312 REAL(wp), POINTER, DIMENSION(:) :: zs_zero310 REAL(wp) :: zs_inf, z_slope_s, zsmax, zsmin, zalpha ! local scalars used for the salinity profile 311 REAL(wp), POINTER, DIMENSION(:) :: zs_zero 313 312 REAL(wp), POINTER, DIMENSION(:,:) :: z2d 314 313 CHARACTER(len=15) :: znam … … 393 392 CALL iom_get( numrir, jpdom_autoglo, 'u_ice' , u_ice ) 394 393 CALL iom_get( numrir, jpdom_autoglo, 'v_ice' , v_ice ) 395 CALL iom_get( numrir, jpdom_autoglo, 'fsbbq' , fsbbq )396 394 CALL iom_get( numrir, jpdom_autoglo, 'stress1_i' , stress1_i ) 397 395 CALL iom_get( numrir, jpdom_autoglo, 'stress2_i' , stress2_i ) … … 522 520 END DO 523 521 ! 522 ! clem: I do not understand why the following IF is needed 523 ! I suspect something inconsistent in the main code with option num_sal=1 524 IF( num_sal == 1 ) THEN 525 DO jl = 1, jpl 526 sm_i(:,:,jl) = bulk_sal 527 DO jk = 1, nlay_i 528 s_i(:,:,jk,jl) = bulk_sal 529 END DO 530 END DO 531 ENDIF 532 ! 524 533 !CALL iom_close( numrir ) !clem: closed in sbcice_lim.F90 525 534 ! -
branches/2014/dev_r4650_UKMO14.12_STAND_ALONE_OBSOPER/NEMOGCM/NEMO/LIM_SRC_3/limsbc.F90
r4614 r5034 27 27 USE par_ice ! ice parameters 28 28 USE dom_oce ! ocean domain 29 USE domvvl ! ocean vertical scale factors 30 USE dom_ice, ONLY : tms 29 USE dom_ice, ONLY : tms, area 31 30 USE ice ! LIM sea-ice variables 32 31 USE sbc_ice ! Surface boundary condition: sea-ice fields 33 32 USE sbc_oce ! Surface boundary condition: ocean fields 34 33 USE sbccpl 35 USE cpl_oasis3, ONLY : lk_cpl 36 USE oce , ONLY : iatte, oatte, sshn, sshb, snwice_mass, snwice_mass_b, snwice_fmass 34 USE oce , ONLY : fraqsr_1lev, sshn, sshb, snwice_mass, snwice_mass_b, snwice_fmass 37 35 USE albedo ! albedo parameters 38 36 USE lbclnk ! ocean lateral boundary condition - MPP exchanges … … 43 41 USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) 44 42 USE traqsr ! clem: add penetration of solar flux into the calculation of heat budget 43 USE iom 44 USE domvvl ! Variable volume 45 45 46 46 IMPLICIT NONE … … 50 50 PUBLIC lim_sbc_flx ! called by sbc_ice_lim 51 51 PUBLIC lim_sbc_tau ! called by sbc_ice_lim 52 53 REAL(wp) :: rzero = 0._wp54 REAL(wp) :: rone = 1._wp55 52 56 53 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: utau_oce, vtau_oce ! air-ocean surface i- & j-stress [N/m2] … … 97 94 !! - fr_i : ice fraction 98 95 !! - tn_ice : sea-ice surface temperature 99 !! - alb_ice : sea-ice albe rdo (lk_cpl=T)96 !! - alb_ice : sea-ice albedo (lk_cpl=T) 100 97 !! 101 98 !! References : Goosse, H. et al. 1996, Bul. Soc. Roy. Sc. Liege, 65, 87-90. 102 99 !! Tartinville et al. 2001 Ocean Modelling, 3, 95-108. 100 !! These refs are now obsolete since everything has been revised 101 !! The ref should be Rousset et al., 2015? 103 102 !!--------------------------------------------------------------------- 104 INTEGER, INTENT(in) :: kt ! number of iteration 105 ! 106 INTEGER :: ji, jj, jl ! dummy loop indices 107 INTEGER :: ierr, ifvt, i1mfr, idfr ! local integer 108 INTEGER :: iflt, ial , iadv , ifral, ifrdv ! - - 109 REAL(wp) :: zinda, zemp, zemp_snow, zfmm ! local scalars 110 REAL(wp) :: zemp_snw ! - - 111 REAL(wp) :: zfcm1 , zfcm2 ! - - 112 REAL(wp), POINTER, DIMENSION(:,:,:) :: zalb, zalbp ! 2D/3D workspace 113 REAL(wp) :: zzfcm1, zfscmbq ! clem: for light penetration 103 INTEGER, INTENT(in) :: kt ! number of iteration 104 ! 105 INTEGER :: ji, jj, jl, jk ! dummy loop indices 106 ! 107 REAL(wp) :: zemp ! local scalars 108 REAL(wp) :: zf_mass ! Heat flux associated with mass exchange ice->ocean (W.m-2) 109 REAL(wp) :: zfcm1 ! New solar flux received by the ocean 110 ! 111 REAL(wp), POINTER, DIMENSION(:,:,:) :: zalb_cs, zalb_os ! 2D/3D workspace 114 112 !!--------------------------------------------------------------------- 115 116 IF( lk_cpl ) CALL wrk_alloc( jpi, jpj, jpl, zalb, zalbp ) 117 118 !------------------------------------------! 119 ! heat flux at the ocean surface ! 120 !------------------------------------------! 113 114 ! make calls for heat fluxes before it is modified 115 IF( iom_use('qsr_oce') ) CALL iom_put( "qsr_oce" , qsr(:,:) * pfrld(:,:) ) ! solar flux at ocean surface 116 IF( iom_use('qns_oce') ) CALL iom_put( "qns_oce" , qns(:,:) * pfrld(:,:) ) ! non-solar flux at ocean surface 117 IF( iom_use('qsr_ice') ) CALL iom_put( "qsr_ice" , SUM( qsr_ice(:,:,:) * a_i_b(:,:,:), dim=3 ) ) ! solar flux at ice surface 118 IF( iom_use('qns_ice') ) CALL iom_put( "qns_ice" , SUM( qns_ice(:,:,:) * a_i_b(:,:,:), dim=3 ) ) ! non-solar flux at ice surface 119 IF( iom_use('qtr_ice') ) CALL iom_put( "qtr_ice" , SUM( ftr_ice(:,:,:) * a_i_b(:,:,:), dim=3 ) ) ! solar flux transmitted thru ice 120 IF( iom_use('qt_oce' ) ) CALL iom_put( "qt_oce" , ( qsr(:,:) + qns(:,:) ) * pfrld(:,:) ) 121 IF( iom_use('qt_ice' ) ) CALL iom_put( "qt_ice" , SUM( ( qns_ice(:,:,:) + qsr_ice(:,:,:) ) * a_i_b(:,:,:), dim=3 ) ) 122 121 123 ! pfrld is the lead fraction at the previous time step (actually between TRP and THD) 122 ! changed to old_frld and old ht_i123 124 124 DO jj = 1, jpj 125 125 DO ji = 1, jpi 126 zinda = 1.0 - MAX( rzero , SIGN( rone , - ( 1.0 - pfrld(ji,jj) ) ) ) 127 ifvt = zinda * MAX( rzero , SIGN( rone, - phicif(ji,jj) ) ) !subscripts are bad here 128 i1mfr = 1.0 - MAX( rzero , SIGN( rone , - at_i(ji,jj) ) ) 129 idfr = 1.0 - MAX( rzero , SIGN( rone , ( 1.0 - at_i(ji,jj) ) - pfrld(ji,jj) ) ) 130 iflt = zinda * (1 - i1mfr) * (1 - ifvt ) 131 ial = ifvt * i1mfr + ( 1 - ifvt ) * idfr 132 iadv = ( 1 - i1mfr ) * zinda 133 ifral = ( 1 - i1mfr * ( 1 - ial ) ) 134 ifrdv = ( 1 - ifral * ( 1 - ial ) ) * iadv 135 136 ! switch --- 1.0 ---------------- 0.0 -------------------- 137 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 138 ! zinda | if pfrld = 1 | if pfrld < 1 | 139 ! -> ifvt| if pfrld old_ht_i 140 ! i1mfr | if frld = 1 | if frld < 1 | 141 ! idfr | if frld <= pfrld | if frld > pfrld | 142 ! iflt | 143 ! ial | 144 ! iadv | 145 ! ifral 146 ! ifrdv 147 148 ! computation the solar flux at ocean surface 149 IF (lk_cpl) THEN ! be carfeful: not been tested yet 150 ! original line 151 !zfcm1 = qsr_tot(ji,jj) + fstric(ji,jj) * at_i(ji,jj) 152 ! new line to include solar penetration (not tested) 153 zfcm1 = qsr_tot(ji,jj) + fstric(ji,jj) * at_i(ji,jj) / ( 1.0 - zinda + zinda * iatte(ji,jj) ) 126 127 !------------------------------------------! 128 ! heat flux at the ocean surface ! 129 !------------------------------------------! 130 ! Solar heat flux reaching the ocean = zfcm1 (W.m-2) 131 !--------------------------------------------------- 132 IF( lk_cpl ) THEN 133 !!! LIM2 version zqsr = qsr_tot(ji,jj) + ( fstric(ji,jj) - qsr_ice(ji,jj,1) ) * ( 1.0 - pfrld(ji,jj) ) 134 zfcm1 = qsr_tot(ji,jj) 154 135 DO jl = 1, jpl 155 zfcm1 = zfcm1 - qsr_ice(ji,jj,jl) * a_i(ji,jj,jl)136 zfcm1 = zfcm1 + ( ftr_ice(ji,jj,jl) - qsr_ice(ji,jj,jl) ) * a_i_b(ji,jj,jl) 156 137 END DO 157 138 ELSE 158 zfcm1 = pfrld(ji,jj) * qsr(ji,jj) + & 159 & ( 1._wp - pfrld(ji,jj) ) * fstric(ji,jj) / ( 1.0 - zinda + zinda * iatte(ji,jj) ) 139 !!! LIM2 version zqsr = pfrld(ji,jj) * qsr(ji,jj) + ( 1. - pfrld(ji,jj) ) * fstric(ji,jj) 140 zfcm1 = pfrld(ji,jj) * qsr(ji,jj) 141 DO jl = 1, jpl 142 zfcm1 = zfcm1 + a_i_b(ji,jj,jl) * ftr_ice(ji,jj,jl) 143 END DO 160 144 ENDIF 161 ! fstric Solar flux transmitted trough the ice 162 ! qsr Net short wave heat flux on free ocean 163 ! new line 164 fscmbq(ji,jj) = ( 1.0 - pfrld(ji,jj) ) * fstric(ji,jj) / ( 1.0 - zinda + zinda * iatte(ji,jj) ) 165 166 ! solar flux and fscmbq with light penetration (clem) 167 zzfcm1 = pfrld(ji,jj) * qsr(ji,jj) * oatte(ji,jj) + ( 1. - pfrld(ji,jj) ) * fstric(ji,jj) 168 zfscmbq = ( 1.0 - pfrld(ji,jj) ) * fstric(ji,jj) 169 170 ! computation the non solar heat flux at ocean surface 171 zfcm2 = - zzfcm1 & ! 172 & + iflt * zfscmbq & ! total ablation: heat given to the ocean 173 & + ifral * ( ial * qcmif(ji,jj) + (1 - ial) * qldif(ji,jj) ) * r1_rdtice & 174 & + ifrdv * ( qfvbq(ji,jj) + qdtcn(ji,jj) ) * r1_rdtice & 175 & + fhmec(ji,jj) & ! snow melt when ridging 176 & + fheat_mec(ji,jj) & ! ridge formation 177 & + fheat_res(ji,jj) ! residual heat flux 178 ! qcmif Energy needed to bring the ocean surface layer until its freezing (ok) 179 ! qldif heat balance of the lead (or of the open ocean) 180 ! qfvbq latent heat uptake/release after accretion/ablation 181 ! qdtcn Energy from the turbulent oceanic heat flux heat flux coming in the lead 182 183 IF( num_sal == 2 ) zfcm2 = zfcm2 + fhbri(ji,jj) ! add contribution due to brine drainage 184 185 ! bottom radiative component is sent to the computation of the oceanic heat flux 186 fsbbq(ji,jj) = ( 1._wp - ( ifvt + iflt ) ) * fscmbq(ji,jj) 187 188 ! used to compute the oceanic heat flux at the next time step 189 qsr(ji,jj) = zfcm1 ! solar heat flux 190 qns(ji,jj) = zfcm2 - fdtcn(ji,jj) ! non solar heat flux 191 ! ! fdtcn : turbulent oceanic heat flux 192 END DO 193 END DO 194 195 !------------------------------------------! 196 ! mass flux at the ocean surface ! 197 !------------------------------------------! 198 199 !!gm optimisation: this loop have to be merged with the previous one 200 DO jj = 1, jpj 201 DO ji = 1, jpi 145 146 ! Total heat flux reaching the ocean = hfx_out (W.m-2) 147 !--------------------------------------------------- 148 zf_mass = hfx_thd(ji,jj) + hfx_dyn(ji,jj) + hfx_res(ji,jj) ! heat flux from snow is 0 (T=0 degC) 149 hfx_out(ji,jj) = hfx_out(ji,jj) + zf_mass + zfcm1 150 151 ! New qsr and qns used to compute the oceanic heat flux at the next time step 152 !--------------------------------------------------- 153 qsr(ji,jj) = zfcm1 154 qns(ji,jj) = hfx_out(ji,jj) - zfcm1 155 156 !------------------------------------------! 157 ! mass flux at the ocean surface ! 158 !------------------------------------------! 202 159 ! case of realistic freshwater flux (Tartinville et al., 2001) (presently ACTIVATED) 203 160 ! ------------------------------------------------------------------------------------- … … 208 165 ! Even if i see Ice melting as a FW and SALT flux 209 166 ! 210 211 167 ! computing freshwater exchanges at the ice/ocean interface 212 IF (lk_cpl) THEN168 IF( lk_cpl ) THEN 213 169 zemp = - emp_tot(ji,jj) + emp_ice(ji,jj) * ( 1. - pfrld(ji,jj) ) & ! 214 & - rdm_snw(ji,jj) / rdt_ice170 & + wfx_snw(ji,jj) 215 171 ELSE 216 zemp = emp(ji,jj) * ( 1.0 - at_i(ji,jj) ) & ! evaporation over oceanic fraction 217 & - tprecip(ji,jj) * at_i(ji,jj) & ! all precipitation reach the ocean 218 & + sprecip(ji,jj) * ( 1. - (pfrld(ji,jj)**betas) ) & ! except solid precip intercepted by sea-ice 219 & - fmmec(ji,jj) ! snow falling when ridging 172 zemp = emp(ji,jj) * pfrld(ji,jj) & ! evaporation over oceanic fraction 173 & - tprecip(ji,jj) * ( 1._wp - pfrld(ji,jj) ) & ! all precipitation reach the ocean 174 & + sprecip(ji,jj) * ( 1._wp - pfrld(ji,jj)**betas ) ! except solid precip intercepted by sea-ice 220 175 ENDIF 221 176 222 ! mass flux at the ocean/ice interface (sea ice fraction)223 zemp_snw = rdm_snw(ji,jj) * r1_rdtice ! snow melting = pure water that enters the ocean224 zfmm = rdm_ice(ji,jj) * r1_rdtice ! Freezing minus melting225 226 fmmflx(ji,jj) = zfmm ! F/M mass flux save at least for biogeochemical model227 228 emp(ji,jj) = zemp + zemp_snw + zfmm! mass flux + F/M mass flux (always ice/ocean mass exchange)177 ! mass flux from ice/ocean 178 wfx_ice(ji,jj) = wfx_bog(ji,jj) + wfx_bom(ji,jj) + wfx_sum(ji,jj) + wfx_sni(ji,jj) & 179 + wfx_opw(ji,jj) + wfx_dyn(ji,jj) + wfx_res(ji,jj) 180 181 ! mass flux at the ocean/ice interface 182 fmmflx(ji,jj) = - wfx_ice(ji,jj) * r1_rdtice ! F/M mass flux save at least for biogeochemical model 183 emp(ji,jj) = zemp - wfx_ice(ji,jj) - wfx_snw(ji,jj) ! mass flux + F/M mass flux (always ice/ocean mass exchange) 229 184 230 ! correcting brine salt fluxes (zinda = 1 if pfrld=1 , =0 otherwise)231 zinda = 1.0 - MAX( rzero , SIGN( rone , - ( 1.0 - pfrld(ji,jj) ) ) )232 sfx_bri(ji,jj) = zinda * sfx_bri(ji,jj)233 185 END DO 234 186 END DO … … 237 189 ! salt flux at the ocean surface ! 238 190 !------------------------------------------! 239 240 IF( num_sal == 2 ) THEN ! variable ice salinity: brine drainage included in the salt flux 241 sfx(:,:) = sfx_thd(:,:) + sfx_res(:,:) + sfx_mec(:,:) + sfx_bri(:,:) 242 ELSE ! constant ice salinity: 243 sfx(:,:) = sfx_thd(:,:) + sfx_res(:,:) + sfx_mec(:,:) 244 ENDIF 245 !-----------------------------------------------! 246 ! mass of snow and ice per unit area ! 247 !-----------------------------------------------! 248 IF( nn_ice_embd /= 0 ) THEN ! embedded sea-ice (mass required) 249 snwice_mass_b(:,:) = snwice_mass(:,:) ! save mass from the previous ice time step 250 ! ! new mass per unit area 191 sfx(:,:) = sfx_bog(:,:) + sfx_bom(:,:) + sfx_sum(:,:) + sfx_sni(:,:) + sfx_opw(:,:) & 192 & + sfx_res(:,:) + sfx_dyn(:,:) + sfx_bri(:,:) 193 194 !-------------------------------------------------------------! 195 ! mass of snow and ice per unit area for embedded sea-ice ! 196 !-------------------------------------------------------------! 197 IF( nn_ice_embd /= 0 ) THEN 198 ! save mass from the previous ice time step 199 snwice_mass_b(:,:) = snwice_mass(:,:) 200 ! new mass per unit area 251 201 snwice_mass (:,:) = tms(:,:) * ( rhosn * vt_s(:,:) + rhoic * vt_i(:,:) ) 252 ! !time evolution of snow+ice mass202 ! time evolution of snow+ice mass 253 203 snwice_fmass (:,:) = ( snwice_mass(:,:) - snwice_mass_b(:,:) ) * r1_rdtice 254 204 ENDIF … … 261 211 262 212 !------------------------------------------------! 263 ! Computation of snow/ice and ocean albedo!213 ! Snow/ice albedo (only if sent to coupler) ! 264 214 !------------------------------------------------! 265 215 IF( lk_cpl ) THEN ! coupled case 266 CALL albedo_ice( t_su, ht_i, ht_s, zalbp, zalb ) ! snow/ice albedo 267 ! 268 alb_ice(:,:,:) = 0.5_wp * zalbp(:,:,:) + 0.5_wp * zalb (:,:,:) ! Ice albedo (mean clear and overcast skys) 269 ENDIF 216 217 CALL wrk_alloc( jpi, jpj, jpl, zalb_cs, zalb_os ) 218 219 CALL albedo_ice( t_su, ht_i, ht_s, zalb_cs, zalb_os ) ! cloud-sky and overcast-sky ice albedos 220 221 alb_ice(:,:,:) = ( 1. - cldf_ice ) * zalb_cs(:,:,:) + cldf_ice * zalb_os(:,:,:) 222 223 CALL wrk_dealloc( jpi, jpj, jpl, zalb_cs, zalb_os ) 224 225 ENDIF 226 270 227 271 228 IF(ln_ctl) THEN … … 275 232 CALL prt_ctl( tab3d_1=tn_ice, clinfo1=' lim_sbc: tn_ice : ', kdim=jpl ) 276 233 ENDIF 277 ! 278 IF( lk_cpl ) CALL wrk_dealloc( jpi, jpj, jpl, zalb, zalbp ) 279 ! 234 280 235 END SUBROUTINE lim_sbc_flx 281 236 … … 390 345 ! clem modif 391 346 IF( .NOT. ln_rstart ) THEN 392 iatte(:,:) = 1._wp 393 oatte(:,:) = 1._wp 347 fraqsr_1lev(:,:) = 1._wp 394 348 ENDIF 395 349 ! -
branches/2014/dev_r4650_UKMO14.12_STAND_ALONE_OBSOPER/NEMOGCM/NEMO/LIM_SRC_3/limthd.F90
r4624 r5034 8 8 !! 3.0 ! 2005-11 (M. Vancoppenolle) LIM-3 : Multi-layer thermodynamics + salinity variations 9 9 !! - ! 2007-04 (M. Vancoppenolle) add lim_thd_glohec, lim_thd_con_dh and lim_thd_con_dif 10 !! 3.2 ! 2009-07 (M. Vancoppenolle, Y. Aksenov, G. Madec) bug correction in rdm_snw10 !! 3.2 ! 2009-07 (M. Vancoppenolle, Y. Aksenov, G. Madec) bug correction in wfx_snw 11 11 !! 3.3 ! 2010-11 (G. Madec) corrected snow melting heat (due to factor betas) 12 12 !! 4.0 ! 2011-02 (G. Madec) dynamical allocation … … 22 22 USE phycst ! physical constants 23 23 USE dom_oce ! ocean space and time domain variables 24 USE oce , ONLY : iatte, oatte24 USE oce , ONLY : fraqsr_1lev 25 25 USE ice ! LIM: sea-ice variables 26 26 USE par_ice ! LIM: sea-ice parameters … … 43 43 USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) 44 44 USE timing ! Timing 45 USE limcons ! conservation tests 45 46 46 47 IMPLICIT NONE … … 49 50 PUBLIC lim_thd ! called by limstp module 50 51 PUBLIC lim_thd_init ! called by iceini module 51 52 REAL(wp) :: epsi10 = 1.e-10_wp !53 REAL(wp) :: zzero = 0._wp !54 REAL(wp) :: zone = 1._wp !55 52 56 53 !! * Substitutions … … 68 65 !! *** ROUTINE lim_thd *** 69 66 !! 70 !! ** Purpose : This routine manages the ice thermodynamic.67 !! ** Purpose : This routine manages ice thermodynamics 71 68 !! 72 69 !! ** Action : - Initialisation of some variables … … 74 71 !! at the ice base, snow acc.,heat budget of the leads) 75 72 !! - selection of the icy points and put them in an array 76 !! - call lim_vert_ther for vert ice thermodynamic 77 !! - back to the geographic grid 78 !! - selection of points for lateral accretion 79 !! - call lim_lat_acc for the ice accretion 73 !! - call lim_thd_dif for vertical heat diffusion 74 !! - call lim_thd_dh for vertical ice growth and melt 75 !! - call lim_thd_ent for enthalpy remapping 76 !! - call lim_thd_sal for ice desalination 77 !! - call lim_thd_temp to retrieve temperature from ice enthalpy 80 78 !! - back to the geographic grid 81 79 !! 82 !! ** References : H. Goosse et al. 1996, Bul. Soc. Roy. Sc. Liege, 65, 87-9080 !! ** References : 83 81 !!--------------------------------------------------------------------- 84 82 INTEGER, INTENT(in) :: kt ! number of iteration 85 83 !! 86 INTEGER :: ji, jj, jk, jl ! dummy loop indices 87 INTEGER :: nbpb ! nb of icy pts for thermo. cal. 88 REAL(wp) :: zfric_umin = 5e-03_wp ! lower bound for the friction velocity 89 REAL(wp) :: zfric_umax = 2e-02_wp ! upper bound for the friction velocity 90 REAL(wp) :: zinda, zindb, zthsnice, zfric_u ! local scalar 91 REAL(wp) :: zfntlat, zpareff, zareamin, zcoef ! - - 92 REAL(wp), POINTER, DIMENSION(:,:) :: zqlbsbq ! link with lead energy budget qldif 93 REAL(wp) :: zchk_v_i, zchk_smv, zchk_fs, zchk_fw, zchk_v_i_b, zchk_smv_b, zchk_fs_b, zchk_fw_b ! Check conservation (C Rousset) 94 REAL(wp) :: zchk_vmin, zchk_amin, zchk_amax ! Check errors (C Rousset) 84 INTEGER :: ji, jj, jk, jl ! dummy loop indices 85 INTEGER :: nbpb ! nb of icy pts for thermo. cal. 86 INTEGER :: ii, ij ! temporary dummy loop index 87 REAL(wp) :: zfric_umin = 0._wp ! lower bound for the friction velocity (cice value=5.e-04) 88 REAL(wp) :: zch = 0.0057_wp ! heat transfer coefficient 89 REAL(wp) :: zareamin 90 REAL(wp) :: zfric_u, zqld, zqfr 91 ! 92 REAL(wp) :: zvi_b, zsmv_b, zei_b, zfs_b, zfw_b, zft_b 93 ! 94 REAL(wp), POINTER, DIMENSION(:,:) :: zqsr, zqns 95 95 !!------------------------------------------------------------------- 96 CALL wrk_alloc( jpi, jpj, zqsr, zqns ) 97 96 98 IF( nn_timing == 1 ) CALL timing_start('limthd') 97 99 98 CALL wrk_alloc( jpi, jpj, zqlbsbq ) 99 100 ! ------------------------------- 101 !- check conservation (C Rousset) 102 IF (ln_limdiahsb) THEN 103 zchk_v_i_b = glob_sum( SUM( v_i(:,:,:), dim=3 ) * area(:,:) * tms(:,:) ) 104 zchk_smv_b = glob_sum( SUM( smv_i(:,:,:), dim=3 ) * area(:,:) * tms(:,:) ) 105 zchk_fw_b = glob_sum( rdm_ice(:,:) * area(:,:) * tms(:,:) ) 106 zchk_fs_b = glob_sum( ( sfx_bri(:,:) + sfx_thd(:,:) + sfx_res(:,:) + sfx_mec(:,:) ) * area(:,:) * tms(:,:) ) 107 ENDIF 108 !- check conservation (C Rousset) 109 ! ------------------------------- 110 111 !------------------------------------------------------------------------------! 112 ! 1) Initialization of diagnostic variables ! 113 !------------------------------------------------------------------------------! 100 ! conservation test 101 IF( ln_limdiahsb ) CALL lim_cons_hsm(0, 'limthd', zvi_b, zsmv_b, zei_b, zfw_b, zfs_b, zft_b) 102 103 !------------------------------------------------------------------------! 104 ! 1) Initialization of some variables ! 105 !------------------------------------------------------------------------! 106 ftr_ice(:,:,:) = 0._wp ! part of solar radiation transmitted through the ice 107 114 108 115 109 !-------------------- … … 121 115 DO jj = 1, jpj 122 116 DO ji = 1, jpi 117 !0 if no ice and 1 if yes 118 rswitch = 1.0 - MAX( 0.0 , SIGN( 1.0 , - v_i(ji,jj,jl) + epsi10 ) ) 123 119 !Energy of melting q(S,T) [J.m-3] 124 e_i(ji,jj,jk,jl) = e_i(ji,jj,jk,jl) / ( area(ji,jj) * MAX( v_i(ji,jj,jl) , epsi10 ) ) * REAL( nlay_i ) 125 !0 if no ice and 1 if yes 126 zindb = 1.0 - MAX( 0.0 , SIGN( 1.0 , - v_i(ji,jj,jl) + epsi10 ) ) 127 !convert units ! very important that this line is here 128 e_i(ji,jj,jk,jl) = e_i(ji,jj,jk,jl) * unit_fac * zindb 120 e_i(ji,jj,jk,jl) = rswitch * e_i(ji,jj,jk,jl) / ( area(ji,jj) * MAX( v_i(ji,jj,jl) , epsi10 ) ) * REAL( nlay_i ) 121 !convert units ! very important that this line is here 122 e_i(ji,jj,jk,jl) = e_i(ji,jj,jk,jl) * unit_fac 129 123 END DO 130 124 END DO … … 133 127 DO jj = 1, jpj 134 128 DO ji = 1, jpi 129 !0 if no ice and 1 if yes 130 rswitch = 1.0 - MAX( 0.0 , SIGN( 1.0 , - v_s(ji,jj,jl) + epsi10 ) ) 135 131 !Energy of melting q(S,T) [J.m-3] 136 e_s(ji,jj,jk,jl) = e_s(ji,jj,jk,jl) / ( area(ji,jj) * MAX( v_s(ji,jj,jl) , epsi10 ) ) * REAL( nlay_s ) 137 !0 if no ice and 1 if yes 138 zindb = 1.0 - MAX( 0.0 , SIGN( 1.0 , - v_s(ji,jj,jl) + epsi10 ) ) 132 e_s(ji,jj,jk,jl) = rswitch * e_s(ji,jj,jk,jl) / ( area(ji,jj) * MAX( v_s(ji,jj,jl) , epsi10 ) ) * REAL( nlay_s ) 139 133 !convert units ! very important that this line is here 140 e_s(ji,jj,jk,jl) = e_s(ji,jj,jk,jl) * unit_fac * zindb134 e_s(ji,jj,jk,jl) = e_s(ji,jj,jk,jl) * unit_fac 141 135 END DO 142 136 END DO 143 137 END DO 144 138 END DO 145 146 !-----------------------------------147 ! 1.4) Compute global heat content148 !-----------------------------------149 qt_i_in (:,:) = 0.e0150 qt_s_in (:,:) = 0.e0151 qt_i_fin (:,:) = 0.e0152 qt_s_fin (:,:) = 0.e0153 sum_fluxq(:,:) = 0.e0154 fatm (:,:) = 0.e0155 139 156 140 ! 2) Partial computation of forcing for the thermodynamic sea ice model. ! 157 141 !-----------------------------------------------------------------------------! 142 143 !--- Ocean solar and non solar fluxes to be used in zqld 144 IF ( .NOT. lk_cpl ) THEN ! --- forced case, fluxes to the lead are the same as over the ocean 145 ! 146 zqsr(:,:) = qsr(:,:) ; zqns(:,:) = qns(:,:) 147 ! 148 ELSE ! --- coupled case, fluxes to the lead are total - intercepted 149 ! 150 zqsr(:,:) = qsr_tot(:,:) ; zqns(:,:) = qns_tot(:,:) 151 ! 152 DO jl = 1, jpl 153 DO jj = 1, jpj 154 DO ji = 1, jpi 155 zqsr(ji,jj) = zqsr(ji,jj) - qsr_ice(ji,jj,jl) * a_i_b(ji,jj,jl) 156 zqns(ji,jj) = zqns(ji,jj) - qns_ice(ji,jj,jl) * a_i_b(ji,jj,jl) 157 END DO 158 END DO 159 END DO 160 ! 161 ENDIF 158 162 159 163 !CDIR NOVERRCHK … … 161 165 !CDIR NOVERRCHK 162 166 DO ji = 1, jpi 163 zinda = tms(ji,jj) * ( 1.0 - MAX( zzero , SIGN( zone , - at_i(ji,jj) + epsi10 ) ) )167 rswitch = tms(ji,jj) * ( 1._wp - MAX( 0._wp , SIGN( 1._wp , - at_i(ji,jj) + epsi10 ) ) ) ! 0 if no ice 164 168 ! 165 169 ! ! solar irradiance transmission at the mixed layer bottom and used in the lead heat budget … … 168 172 ! ! net downward heat flux from the ice to the ocean, expressed as a function of ocean 169 173 ! ! temperature and turbulent mixing (McPhee, 1992) 170 ! friction velocity171 zfric_u = MAX ( MIN( SQRT( ust2s(ji,jj) ) , zfric_umax ) , zfric_umin )172 173 ! here the drag will depend on ice thickness and type (0.006)174 fdtcn(ji,jj) = zinda * rau0 * rcp * 0.006 * zfric_u * ( ( sst_m(ji,jj) + rt0 ) - t_bo(ji,jj) )175 ! also category dependent176 ! !-- Energy from the turbulent oceanic heat flux heat flux coming in the lead177 qdtcn(ji,jj) = zinda * fdtcn(ji,jj) * ( 1.0 - at_i(ji,jj) ) * rdt_ice178 !179 ! !-- Lead heat budget, qldif (part 1, next one is in limthd_dh)180 ! ! caution: exponent betas used as more snow can fallinto leads181 qldif(ji,jj) = tms(ji,jj) * rdt_ice * ( &182 & pfrld(ji,jj) * ( qsr(ji,jj) * oatte(ji,jj) & ! solar heat + clem modif183 & + qns(ji,jj) & ! non solar heat184 & + fdtcn(ji,jj) & ! turbulent ice-ocean heat185 & + fsbbq(ji,jj) * ( 1.0 - zinda ) ) & ! residual heat from previous step186 & - pfrld(ji,jj)**betas * sprecip(ji,jj) * lfus ) ! latent heat of sprecip melting187 174 ! 188 ! Positive heat budget is used for bottom ablation 189 zfntlat = 1.0 - MAX( zzero , SIGN( zone , - qldif(ji,jj) ) ) 190 != 1 if positive heat budget 191 zpareff = 1.0 - zinda * zfntlat 192 != 0 if ice and positive heat budget and 1 if one of those two is false 193 zqlbsbq(ji,jj) = qldif(ji,jj) * ( 1.0 - zpareff ) / ( rdt_ice * MAX( at_i(ji,jj), epsi10 ) ) 175 176 ! --- Energy received in the lead, zqld is defined everywhere (J.m-2) --- ! 177 ! REMARK valid at least in forced mode from clem 178 ! precip is included in qns but not in qns_ice 179 IF ( lk_cpl ) THEN 180 zqld = tms(ji,jj) * rdt_ice * & 181 & ( zqsr(ji,jj) * fraqsr_1lev(ji,jj) + zqns(ji,jj) & ! pfrld already included in coupled mode 182 & + ( pfrld(ji,jj)**betas - pfrld(ji,jj) ) * sprecip(ji,jj) * & ! heat content of precip 183 & ( cpic * ( MIN( tatm_ice(ji,jj), rt0_snow ) - rtt ) - lfus ) & 184 & + ( 1._wp - pfrld(ji,jj) ) * ( tprecip(ji,jj) - sprecip(ji,jj) ) * rcp * ( tatm_ice(ji,jj) - rtt ) ) 185 ELSE 186 zqld = tms(ji,jj) * rdt_ice * & 187 & ( pfrld(ji,jj) * ( zqsr(ji,jj) * fraqsr_1lev(ji,jj) + zqns(ji,jj) ) & 188 & + ( pfrld(ji,jj)**betas - pfrld(ji,jj) ) * sprecip(ji,jj) * & ! heat content of precip 189 & ( cpic * ( MIN( tatm_ice(ji,jj), rt0_snow ) - rtt ) - lfus ) & 190 & + ( 1._wp - pfrld(ji,jj) ) * ( tprecip(ji,jj) - sprecip(ji,jj) ) * rcp * ( tatm_ice(ji,jj) - rtt ) ) 191 ENDIF 192 193 !-- Energy needed to bring ocean surface layer until its freezing (<0, J.m-2) --- ! 194 zqfr = tms(ji,jj) * rau0 * rcp * fse3t_m(ji,jj) * ( t_bo(ji,jj) - ( sst_m(ji,jj) + rt0 ) ) 195 196 !-- Energy Budget of the leads (J.m-2). Must be < 0 to form ice 197 qlead(ji,jj) = MIN( 0._wp , zqld - zqfr ) 198 199 ! If there is ice and leads are warming, then transfer energy from the lead budget and use it for bottom melting 200 IF( at_i(ji,jj) > epsi10 .AND. zqld > 0._wp ) THEN 201 fhld (ji,jj) = zqld * r1_rdtice / at_i(ji,jj) ! divided by at_i since this is (re)multiplied by a_i in limthd_dh.F90 202 qlead(ji,jj) = 0._wp 203 ELSE 204 fhld (ji,jj) = 0._wp 205 ENDIF 194 206 ! 195 ! Heat budget of the lead, energy transferred from ice to ocean 196 qldif (ji,jj) = zpareff * qldif(ji,jj) 197 qdtcn (ji,jj) = zpareff * qdtcn(ji,jj) 198 ! 199 ! Energy needed to bring ocean surface layer until its freezing (qcmif, limflx) 200 qcmif (ji,jj) = rau0 * rcp * fse3t_m(ji,jj) * ( t_bo(ji,jj) - ( sst_m(ji,jj) + rt0 ) ) 201 ! 202 ! oceanic heat flux (limthd_dh) 203 fbif (ji,jj) = zinda * ( fsbbq(ji,jj) / MAX( at_i(ji,jj) , epsi10 ) + fdtcn(ji,jj) ) 204 ! 207 !-- Energy from the turbulent oceanic heat flux --- ! 208 !clem zfric_u = MAX ( MIN( SQRT( ust2s(ji,jj) ) , zfric_umax ) , zfric_umin ) 209 zfric_u = MAX( SQRT( ust2s(ji,jj) ), zfric_umin ) 210 fhtur(ji,jj) = MAX( 0._wp, rswitch * rau0 * rcp * zch * zfric_u * ( ( sst_m(ji,jj) + rt0 ) - t_bo(ji,jj) ) ) ! W.m-2 211 ! upper bound for fhtur: we do not want SST to drop below Tfreeze. 212 ! So we say that the heat retrieved from the ocean (fhtur+fhld) must be < to the heat necessary to reach Tfreeze (zqfr) 213 ! This is not a clean budget, so that should be corrected at some point 214 fhtur(ji,jj) = rswitch * MIN( fhtur(ji,jj), - fhld(ji,jj) - zqfr * r1_rdtice / MAX( at_i(ji,jj), epsi10 ) ) 215 216 ! ----------------------------------------- 217 ! Net heat flux on top of ice-ocean [W.m-2] 218 ! ----------------------------------------- 219 ! First step here : heat flux at the ocean surface + precip 220 ! Second step below : heat flux at the ice surface (after limthd_dif) 221 hfx_in(ji,jj) = hfx_in(ji,jj) & 222 ! heat flux above the ocean 223 & + pfrld(ji,jj) * ( zqns(ji,jj) + zqsr(ji,jj) ) & 224 ! latent heat of precip (note that precip is included in qns but not in qns_ice) 225 & + ( 1._wp - pfrld(ji,jj) ) * sprecip(ji,jj) * ( cpic * ( MIN( tatm_ice(ji,jj), rt0_snow ) - rtt ) - lfus ) & 226 & + ( 1._wp - pfrld(ji,jj) ) * ( tprecip(ji,jj) - sprecip(ji,jj) ) * rcp * ( tatm_ice(ji,jj) - rtt ) 227 228 ! ----------------------------------------------------------------------------- 229 ! Net heat flux that is retroceded to the ocean or taken from the ocean [W.m-2] 230 ! ----------------------------------------------------------------------------- 231 ! First step here : non solar + precip - qlead - qturb 232 ! Second step in limthd_dh : heat remaining if total melt (zq_rema) 233 ! Third step in limsbc : heat from ice-ocean mass exchange (zf_mass) + solar 234 hfx_out(ji,jj) = hfx_out(ji,jj) & 235 ! Non solar heat flux received by the ocean 236 & + pfrld(ji,jj) * qns(ji,jj) & 237 ! latent heat of precip (note that precip is included in qns but not in qns_ice) 238 & + ( pfrld(ji,jj)**betas - pfrld(ji,jj) ) * sprecip(ji,jj) & 239 & * ( cpic * ( MIN( tatm_ice(ji,jj), rt0_snow ) - rtt ) - lfus ) & 240 & + ( 1._wp - pfrld(ji,jj) ) * ( tprecip(ji,jj) - sprecip(ji,jj) ) * rcp * ( tatm_ice(ji,jj) - rtt ) & 241 ! heat flux taken from the ocean where there is open water ice formation 242 & - qlead(ji,jj) * r1_rdtice & 243 ! heat flux taken from the ocean during bottom growth/melt (fhld should be 0 while bott growth) 244 & - at_i(ji,jj) * fhtur(ji,jj) & 245 & - at_i(ji,jj) * fhld(ji,jj) 246 205 247 END DO 206 248 END DO … … 234 276 DO jj = mj0(jjindx), mj1(jjindx) 235 277 jiindex_1d = (jj - 1) * jpi + ji 278 WRITE(numout,*) ' lim_thd : Category no : ', jl 236 279 END DO 237 280 END DO … … 250 293 !------------------------- 251 294 252 CALL tab_2d_1d( nbpb, at_i_ b(1:nbpb), at_i , jpi, jpj, npb(1:nbpb) )253 CALL tab_2d_1d( nbpb, a_i_ b(1:nbpb), a_i(:,:,jl) , jpi, jpj, npb(1:nbpb) )254 CALL tab_2d_1d( nbpb, ht_i_ b(1:nbpb), ht_i(:,:,jl) , jpi, jpj, npb(1:nbpb) )255 CALL tab_2d_1d( nbpb, ht_s_ b(1:nbpb), ht_s(:,:,jl) , jpi, jpj, npb(1:nbpb) )256 257 CALL tab_2d_1d( nbpb, t_su_ b(1:nbpb), t_su(:,:,jl) , jpi, jpj, npb(1:nbpb) )258 CALL tab_2d_1d( nbpb, sm_i_ b(1:nbpb), sm_i(:,:,jl) , jpi, jpj, npb(1:nbpb) )295 CALL tab_2d_1d( nbpb, at_i_1d (1:nbpb), at_i , jpi, jpj, npb(1:nbpb) ) 296 CALL tab_2d_1d( nbpb, a_i_1d (1:nbpb), a_i(:,:,jl) , jpi, jpj, npb(1:nbpb) ) 297 CALL tab_2d_1d( nbpb, ht_i_1d (1:nbpb), ht_i(:,:,jl) , jpi, jpj, npb(1:nbpb) ) 298 CALL tab_2d_1d( nbpb, ht_s_1d (1:nbpb), ht_s(:,:,jl) , jpi, jpj, npb(1:nbpb) ) 299 300 CALL tab_2d_1d( nbpb, t_su_1d (1:nbpb), t_su(:,:,jl) , jpi, jpj, npb(1:nbpb) ) 301 CALL tab_2d_1d( nbpb, sm_i_1d (1:nbpb), sm_i(:,:,jl) , jpi, jpj, npb(1:nbpb) ) 259 302 DO jk = 1, nlay_s 260 CALL tab_2d_1d( nbpb, t_s_ b(1:nbpb,jk), t_s(:,:,jk,jl) , jpi, jpj, npb(1:nbpb) )261 CALL tab_2d_1d( nbpb, q_s_ b(1:nbpb,jk), e_s(:,:,jk,jl) , jpi, jpj, npb(1:nbpb) )303 CALL tab_2d_1d( nbpb, t_s_1d(1:nbpb,jk), t_s(:,:,jk,jl) , jpi, jpj, npb(1:nbpb) ) 304 CALL tab_2d_1d( nbpb, q_s_1d(1:nbpb,jk), e_s(:,:,jk,jl) , jpi, jpj, npb(1:nbpb) ) 262 305 END DO 263 306 DO jk = 1, nlay_i 264 CALL tab_2d_1d( nbpb, t_i_ b(1:nbpb,jk), t_i(:,:,jk,jl) , jpi, jpj, npb(1:nbpb) )265 CALL tab_2d_1d( nbpb, q_i_ b(1:nbpb,jk), e_i(:,:,jk,jl) , jpi, jpj, npb(1:nbpb) )266 CALL tab_2d_1d( nbpb, s_i_ b(1:nbpb,jk), s_i(:,:,jk,jl) , jpi, jpj, npb(1:nbpb) )307 CALL tab_2d_1d( nbpb, t_i_1d(1:nbpb,jk), t_i(:,:,jk,jl) , jpi, jpj, npb(1:nbpb) ) 308 CALL tab_2d_1d( nbpb, q_i_1d(1:nbpb,jk), e_i(:,:,jk,jl) , jpi, jpj, npb(1:nbpb) ) 309 CALL tab_2d_1d( nbpb, s_i_1d(1:nbpb,jk), s_i(:,:,jk,jl) , jpi, jpj, npb(1:nbpb) ) 267 310 END DO 268 311 … … 271 314 CALL tab_2d_1d( nbpb, fr1_i0_1d (1:nbpb), fr1_i0 , jpi, jpj, npb(1:nbpb) ) 272 315 CALL tab_2d_1d( nbpb, fr2_i0_1d (1:nbpb), fr2_i0 , jpi, jpj, npb(1:nbpb) ) 273 CALL tab_2d_1d( nbpb, qnsr_ice_1d(1:nbpb), qns_ice(:,:,jl) , jpi, jpj, npb(1:nbpb) ) 274 #if ! defined key_coupled 275 CALL tab_2d_1d( nbpb, qla_ice_1d (1:nbpb), qla_ice(:,:,jl) , jpi, jpj, npb(1:nbpb) ) 276 CALL tab_2d_1d( nbpb, dqla_ice_1d(1:nbpb), dqla_ice(:,:,jl), jpi, jpj, npb(1:nbpb) ) 277 #endif 316 CALL tab_2d_1d( nbpb, qns_ice_1d (1:nbpb), qns_ice(:,:,jl) , jpi, jpj, npb(1:nbpb) ) 317 CALL tab_2d_1d( nbpb, ftr_ice_1d (1:nbpb), ftr_ice(:,:,jl) , jpi, jpj, npb(1:nbpb) ) 318 IF( .NOT. lk_cpl ) THEN 319 CALL tab_2d_1d( nbpb, qla_ice_1d (1:nbpb), qla_ice(:,:,jl) , jpi, jpj, npb(1:nbpb) ) 320 CALL tab_2d_1d( nbpb, dqla_ice_1d(1:nbpb), dqla_ice(:,:,jl), jpi, jpj, npb(1:nbpb) ) 321 ENDIF 278 322 CALL tab_2d_1d( nbpb, dqns_ice_1d(1:nbpb), dqns_ice(:,:,jl), jpi, jpj, npb(1:nbpb) ) 279 CALL tab_2d_1d( nbpb, t_bo_ b(1:nbpb), t_bo , jpi, jpj, npb(1:nbpb) )323 CALL tab_2d_1d( nbpb, t_bo_1d (1:nbpb), t_bo , jpi, jpj, npb(1:nbpb) ) 280 324 CALL tab_2d_1d( nbpb, sprecip_1d (1:nbpb), sprecip , jpi, jpj, npb(1:nbpb) ) 281 CALL tab_2d_1d( nbpb, fbif_1d (1:nbpb), fbif , jpi, jpj, npb(1:nbpb) ) 282 CALL tab_2d_1d( nbpb, qldif_1d (1:nbpb), qldif , jpi, jpj, npb(1:nbpb) ) 283 CALL tab_2d_1d( nbpb, rdm_ice_1d (1:nbpb), rdm_ice , jpi, jpj, npb(1:nbpb) ) 284 CALL tab_2d_1d( nbpb, rdm_snw_1d (1:nbpb), rdm_snw , jpi, jpj, npb(1:nbpb) ) 285 CALL tab_2d_1d( nbpb, dmgwi_1d (1:nbpb), dmgwi , jpi, jpj, npb(1:nbpb) ) 286 CALL tab_2d_1d( nbpb, qlbbq_1d (1:nbpb), zqlbsbq , jpi, jpj, npb(1:nbpb) ) 287 288 CALL tab_2d_1d( nbpb, sfx_thd_1d (1:nbpb), sfx_thd , jpi, jpj, npb(1:nbpb) ) 325 CALL tab_2d_1d( nbpb, fhtur_1d (1:nbpb), fhtur , jpi, jpj, npb(1:nbpb) ) 326 CALL tab_2d_1d( nbpb, qlead_1d (1:nbpb), qlead , jpi, jpj, npb(1:nbpb) ) 327 CALL tab_2d_1d( nbpb, fhld_1d (1:nbpb), fhld , jpi, jpj, npb(1:nbpb) ) 328 329 CALL tab_2d_1d( nbpb, wfx_snw_1d (1:nbpb), wfx_snw , jpi, jpj, npb(1:nbpb) ) 330 CALL tab_2d_1d( nbpb, wfx_sub_1d (1:nbpb), wfx_sub , jpi, jpj, npb(1:nbpb) ) 331 332 CALL tab_2d_1d( nbpb, wfx_bog_1d (1:nbpb), wfx_bog , jpi, jpj, npb(1:nbpb) ) 333 CALL tab_2d_1d( nbpb, wfx_bom_1d (1:nbpb), wfx_bom , jpi, jpj, npb(1:nbpb) ) 334 CALL tab_2d_1d( nbpb, wfx_sum_1d (1:nbpb), wfx_sum , jpi, jpj, npb(1:nbpb) ) 335 CALL tab_2d_1d( nbpb, wfx_sni_1d (1:nbpb), wfx_sni , jpi, jpj, npb(1:nbpb) ) 336 CALL tab_2d_1d( nbpb, wfx_res_1d (1:nbpb), wfx_res , jpi, jpj, npb(1:nbpb) ) 337 CALL tab_2d_1d( nbpb, wfx_spr_1d (1:nbpb), wfx_spr , jpi, jpj, npb(1:nbpb) ) 338 339 CALL tab_2d_1d( nbpb, sfx_bog_1d (1:nbpb), sfx_bog , jpi, jpj, npb(1:nbpb) ) 340 CALL tab_2d_1d( nbpb, sfx_bom_1d (1:nbpb), sfx_bom , jpi, jpj, npb(1:nbpb) ) 341 CALL tab_2d_1d( nbpb, sfx_sum_1d (1:nbpb), sfx_sum , jpi, jpj, npb(1:nbpb) ) 342 CALL tab_2d_1d( nbpb, sfx_sni_1d (1:nbpb), sfx_sni , jpi, jpj, npb(1:nbpb) ) 289 343 CALL tab_2d_1d( nbpb, sfx_bri_1d (1:nbpb), sfx_bri , jpi, jpj, npb(1:nbpb) ) 290 CALL tab_2d_1d( nbpb, fhbri_1d (1:nbpb), fhbri , jpi, jpj, npb(1:nbpb) ) 291 CALL tab_2d_1d( nbpb, fstbif_1d (1:nbpb), fstric , jpi, jpj, npb(1:nbpb) ) 292 CALL tab_2d_1d( nbpb, qfvbq_1d (1:nbpb), qfvbq , jpi, jpj, npb(1:nbpb) ) 293 294 CALL tab_2d_1d( nbpb, iatte_1d (1:nbpb), iatte , jpi, jpj, npb(1:nbpb) ) ! clem modif 295 CALL tab_2d_1d( nbpb, oatte_1d (1:nbpb), oatte , jpi, jpj, npb(1:nbpb) ) ! clem modif 344 CALL tab_2d_1d( nbpb, sfx_res_1d (1:nbpb), sfx_res , jpi, jpj, npb(1:nbpb) ) 345 346 CALL tab_2d_1d( nbpb, hfx_thd_1d (1:nbpb), hfx_thd , jpi, jpj, npb(1:nbpb) ) 347 CALL tab_2d_1d( nbpb, hfx_spr_1d (1:nbpb), hfx_spr , jpi, jpj, npb(1:nbpb) ) 348 CALL tab_2d_1d( nbpb, hfx_sum_1d (1:nbpb), hfx_sum , jpi, jpj, npb(1:nbpb) ) 349 CALL tab_2d_1d( nbpb, hfx_bom_1d (1:nbpb), hfx_bom , jpi, jpj, npb(1:nbpb) ) 350 CALL tab_2d_1d( nbpb, hfx_bog_1d (1:nbpb), hfx_bog , jpi, jpj, npb(1:nbpb) ) 351 CALL tab_2d_1d( nbpb, hfx_dif_1d (1:nbpb), hfx_dif , jpi, jpj, npb(1:nbpb) ) 352 CALL tab_2d_1d( nbpb, hfx_opw_1d (1:nbpb), hfx_opw , jpi, jpj, npb(1:nbpb) ) 353 CALL tab_2d_1d( nbpb, hfx_snw_1d (1:nbpb), hfx_snw , jpi, jpj, npb(1:nbpb) ) 354 CALL tab_2d_1d( nbpb, hfx_sub_1d (1:nbpb), hfx_sub , jpi, jpj, npb(1:nbpb) ) 355 CALL tab_2d_1d( nbpb, hfx_err_1d (1:nbpb), hfx_err , jpi, jpj, npb(1:nbpb) ) 356 CALL tab_2d_1d( nbpb, hfx_res_1d (1:nbpb), hfx_res , jpi, jpj, npb(1:nbpb) ) 357 CALL tab_2d_1d( nbpb, hfx_err_rem_1d (1:nbpb), hfx_err_rem , jpi, jpj, npb(1:nbpb) ) 358 296 359 !-------------------------------- 297 360 ! 4.3) Thermodynamic processes 298 361 !-------------------------------- 299 362 300 IF( con_i .AND. jiindex_1d > 0 ) CALL lim_thd_enmelt( 1, nbpb ) ! computes sea ice energy of melting 301 IF( con_i .AND. jiindex_1d > 0 ) CALL lim_thd_glohec( qt_i_in, qt_s_in, q_i_layer_in, 1, nbpb, jl ) 302 303 ! !---------------------------------! 304 CALL lim_thd_dif( 1, nbpb, jl ) ! Ice/Snow Temperature profile ! 305 ! !---------------------------------! 306 307 CALL lim_thd_enmelt( 1, nbpb ) ! computes sea ice energy of melting compulsory for limthd_dh 308 309 IF( con_i .AND. jiindex_1d > 0 ) CALL lim_thd_glohec ( qt_i_fin, qt_s_fin, q_i_layer_fin, 1, nbpb, jl ) 310 IF( con_i .AND. jiindex_1d > 0 ) CALL lim_thd_con_dif( 1 , nbpb , jl ) 311 312 ! !---------------------------------! 313 CALL lim_thd_dh( 1, nbpb, jl ) ! Ice/Snow thickness ! 314 ! !---------------------------------! 315 316 ! !---------------------------------! 317 CALL lim_thd_ent( 1, nbpb, jl ) ! Ice/Snow enthalpy remapping ! 318 ! !---------------------------------! 319 320 ! !---------------------------------! 321 CALL lim_thd_sal( 1, nbpb ) ! Ice salinity computation ! 322 ! !---------------------------------! 323 324 ! CALL lim_thd_enmelt(1,nbpb) ! computes sea ice energy of melting 325 IF( con_i .AND. jiindex_1d > 0 ) CALL lim_thd_glohec( qt_i_fin, qt_s_fin, q_i_layer_fin, 1, nbpb, jl ) 326 IF( con_i .AND. jiindex_1d > 0 ) CALL lim_thd_con_dh ( 1 , nbpb , jl ) 363 !---------------------------------! 364 ! Ice/Snow Temperature profile ! 365 !---------------------------------! 366 CALL lim_thd_dif( 1, nbpb ) 367 368 !---------------------------------! 369 ! Ice/Snow thicnkess ! 370 !---------------------------------! 371 CALL lim_thd_dh( 1, nbpb ) 372 373 ! --- Ice enthalpy remapping --- ! 374 CALL lim_thd_ent( 1, nbpb, q_i_1d(1:nbpb,:) ) 375 376 !---------------------------------! 377 ! --- Ice salinity --- ! 378 !---------------------------------! 379 CALL lim_thd_sal( 1, nbpb ) 380 381 !---------------------------------! 382 ! --- temperature update --- ! 383 !---------------------------------! 384 CALL lim_thd_temp( 1, nbpb ) 327 385 328 386 !-------------------------------- … … 330 388 !-------------------------------- 331 389 332 CALL tab_1d_2d( nbpb, at_i , npb, at_i_ b(1:nbpb) , jpi, jpj )333 CALL tab_1d_2d( nbpb, ht_i(:,:,jl) , npb, ht_i_ b(1:nbpb) , jpi, jpj )334 CALL tab_1d_2d( nbpb, ht_s(:,:,jl) , npb, ht_s_ b(1:nbpb) , jpi, jpj )335 CALL tab_1d_2d( nbpb, a_i (:,:,jl) , npb, a_i_ b(1:nbpb) , jpi, jpj )336 CALL tab_1d_2d( nbpb, t_su(:,:,jl) , npb, t_su_ b(1:nbpb) , jpi, jpj )337 CALL tab_1d_2d( nbpb, sm_i(:,:,jl) , npb, sm_i_ b(1:nbpb) , jpi, jpj )390 CALL tab_1d_2d( nbpb, at_i , npb, at_i_1d (1:nbpb) , jpi, jpj ) 391 CALL tab_1d_2d( nbpb, ht_i(:,:,jl) , npb, ht_i_1d (1:nbpb) , jpi, jpj ) 392 CALL tab_1d_2d( nbpb, ht_s(:,:,jl) , npb, ht_s_1d (1:nbpb) , jpi, jpj ) 393 CALL tab_1d_2d( nbpb, a_i (:,:,jl) , npb, a_i_1d (1:nbpb) , jpi, jpj ) 394 CALL tab_1d_2d( nbpb, t_su(:,:,jl) , npb, t_su_1d (1:nbpb) , jpi, jpj ) 395 CALL tab_1d_2d( nbpb, sm_i(:,:,jl) , npb, sm_i_1d (1:nbpb) , jpi, jpj ) 338 396 DO jk = 1, nlay_s 339 CALL tab_1d_2d( nbpb, t_s(:,:,jk,jl), npb, t_s_ b(1:nbpb,jk), jpi, jpj)340 CALL tab_1d_2d( nbpb, e_s(:,:,jk,jl), npb, q_s_ b(1:nbpb,jk), jpi, jpj)397 CALL tab_1d_2d( nbpb, t_s(:,:,jk,jl), npb, t_s_1d (1:nbpb,jk), jpi, jpj) 398 CALL tab_1d_2d( nbpb, e_s(:,:,jk,jl), npb, q_s_1d (1:nbpb,jk), jpi, jpj) 341 399 END DO 342 400 DO jk = 1, nlay_i 343 CALL tab_1d_2d( nbpb, t_i(:,:,jk,jl), npb, t_i_b (1:nbpb,jk), jpi, jpj) 344 CALL tab_1d_2d( nbpb, e_i(:,:,jk,jl), npb, q_i_b (1:nbpb,jk), jpi, jpj) 345 CALL tab_1d_2d( nbpb, s_i(:,:,jk,jl), npb, s_i_b (1:nbpb,jk), jpi, jpj) 346 END DO 347 CALL tab_1d_2d( nbpb, fstric , npb, fstbif_1d (1:nbpb) , jpi, jpj ) 348 CALL tab_1d_2d( nbpb, qldif , npb, qldif_1d (1:nbpb) , jpi, jpj ) 349 CALL tab_1d_2d( nbpb, qfvbq , npb, qfvbq_1d (1:nbpb) , jpi, jpj ) 350 CALL tab_1d_2d( nbpb, rdm_ice , npb, rdm_ice_1d(1:nbpb) , jpi, jpj ) 351 CALL tab_1d_2d( nbpb, rdm_snw , npb, rdm_snw_1d(1:nbpb) , jpi, jpj ) 352 CALL tab_1d_2d( nbpb, dmgwi , npb, dmgwi_1d (1:nbpb) , jpi, jpj ) 353 CALL tab_1d_2d( nbpb, rdvosif , npb, dvsbq_1d (1:nbpb) , jpi, jpj ) 354 CALL tab_1d_2d( nbpb, rdvobif , npb, dvbbq_1d (1:nbpb) , jpi, jpj ) 355 CALL tab_1d_2d( nbpb, fdvolif , npb, dvlbq_1d (1:nbpb) , jpi, jpj ) 356 CALL tab_1d_2d( nbpb, rdvonif , npb, dvnbq_1d (1:nbpb) , jpi, jpj ) 357 CALL tab_1d_2d( nbpb, sfx_thd , npb, sfx_thd_1d(1:nbpb) , jpi, jpj ) 401 CALL tab_1d_2d( nbpb, t_i(:,:,jk,jl), npb, t_i_1d (1:nbpb,jk), jpi, jpj) 402 CALL tab_1d_2d( nbpb, e_i(:,:,jk,jl), npb, q_i_1d (1:nbpb,jk), jpi, jpj) 403 CALL tab_1d_2d( nbpb, s_i(:,:,jk,jl), npb, s_i_1d (1:nbpb,jk), jpi, jpj) 404 END DO 405 CALL tab_1d_2d( nbpb, qlead , npb, qlead_1d (1:nbpb) , jpi, jpj ) 406 407 CALL tab_1d_2d( nbpb, wfx_snw , npb, wfx_snw_1d(1:nbpb) , jpi, jpj ) 408 CALL tab_1d_2d( nbpb, wfx_sub , npb, wfx_sub_1d(1:nbpb) , jpi, jpj ) 409 410 CALL tab_1d_2d( nbpb, wfx_bog , npb, wfx_bog_1d(1:nbpb) , jpi, jpj ) 411 CALL tab_1d_2d( nbpb, wfx_bom , npb, wfx_bom_1d(1:nbpb) , jpi, jpj ) 412 CALL tab_1d_2d( nbpb, wfx_sum , npb, wfx_sum_1d(1:nbpb) , jpi, jpj ) 413 CALL tab_1d_2d( nbpb, wfx_sni , npb, wfx_sni_1d(1:nbpb) , jpi, jpj ) 414 CALL tab_1d_2d( nbpb, wfx_res , npb, wfx_res_1d(1:nbpb) , jpi, jpj ) 415 CALL tab_1d_2d( nbpb, wfx_spr , npb, wfx_spr_1d(1:nbpb) , jpi, jpj ) 416 417 CALL tab_1d_2d( nbpb, sfx_bog , npb, sfx_bog_1d(1:nbpb) , jpi, jpj ) 418 CALL tab_1d_2d( nbpb, sfx_bom , npb, sfx_bom_1d(1:nbpb) , jpi, jpj ) 419 CALL tab_1d_2d( nbpb, sfx_sum , npb, sfx_sum_1d(1:nbpb) , jpi, jpj ) 420 CALL tab_1d_2d( nbpb, sfx_sni , npb, sfx_sni_1d(1:nbpb) , jpi, jpj ) 421 CALL tab_1d_2d( nbpb, sfx_res , npb, sfx_res_1d(1:nbpb) , jpi, jpj ) 422 CALL tab_1d_2d( nbpb, sfx_bri , npb, sfx_bri_1d(1:nbpb) , jpi, jpj ) 423 424 CALL tab_1d_2d( nbpb, hfx_thd , npb, hfx_thd_1d(1:nbpb) , jpi, jpj ) 425 CALL tab_1d_2d( nbpb, hfx_spr , npb, hfx_spr_1d(1:nbpb) , jpi, jpj ) 426 CALL tab_1d_2d( nbpb, hfx_sum , npb, hfx_sum_1d(1:nbpb) , jpi, jpj ) 427 CALL tab_1d_2d( nbpb, hfx_bom , npb, hfx_bom_1d(1:nbpb) , jpi, jpj ) 428 CALL tab_1d_2d( nbpb, hfx_bog , npb, hfx_bog_1d(1:nbpb) , jpi, jpj ) 429 CALL tab_1d_2d( nbpb, hfx_dif , npb, hfx_dif_1d(1:nbpb) , jpi, jpj ) 430 CALL tab_1d_2d( nbpb, hfx_opw , npb, hfx_opw_1d(1:nbpb) , jpi, jpj ) 431 CALL tab_1d_2d( nbpb, hfx_snw , npb, hfx_snw_1d(1:nbpb) , jpi, jpj ) 432 CALL tab_1d_2d( nbpb, hfx_sub , npb, hfx_sub_1d(1:nbpb) , jpi, jpj ) 433 CALL tab_1d_2d( nbpb, hfx_err , npb, hfx_err_1d(1:nbpb) , jpi, jpj ) 434 CALL tab_1d_2d( nbpb, hfx_res , npb, hfx_res_1d(1:nbpb) , jpi, jpj ) 435 CALL tab_1d_2d( nbpb, hfx_err_rem , npb, hfx_err_rem_1d(1:nbpb) , jpi, jpj ) 358 436 ! 359 IF( num_sal == 2 ) THEN 360 CALL tab_1d_2d( nbpb, sfx_bri , npb, sfx_bri_1d(1:nbpb) , jpi, jpj ) 361 CALL tab_1d_2d( nbpb, fhbri , npb, fhbri_1d (1:nbpb) , jpi, jpj ) 362 ENDIF 363 ! 364 !+++++ temporary stuff for a dummy version 365 CALL tab_1d_2d( nbpb, dh_i_surf2D, npb, dh_i_surf(1:nbpb) , jpi, jpj ) 366 CALL tab_1d_2d( nbpb, dh_i_bott2D, npb, dh_i_bott(1:nbpb) , jpi, jpj ) 367 CALL tab_1d_2d( nbpb, fsup2D , npb, fsup (1:nbpb) , jpi, jpj ) 368 CALL tab_1d_2d( nbpb, focea2D , npb, focea (1:nbpb) , jpi, jpj ) 369 CALL tab_1d_2d( nbpb, s_i_newice , npb, s_i_new (1:nbpb) , jpi, jpj ) 370 CALL tab_1d_2d( nbpb, izero(:,:,jl) , npb, i0 (1:nbpb) , jpi, jpj ) 371 CALL tab_1d_2d( nbpb, qns_ice(:,:,jl), npb, qnsr_ice_1d(1:nbpb), jpi, jpj) 372 !+++++ 437 CALL tab_1d_2d( nbpb, qns_ice(:,:,jl), npb, qns_ice_1d(1:nbpb) , jpi, jpj) 438 CALL tab_1d_2d( nbpb, ftr_ice(:,:,jl), npb, ftr_ice_1d(1:nbpb) , jpi, jpj ) 373 439 ! 374 440 IF( lk_mpp ) CALL mpp_comm_free( ncomm_ice ) !RB necessary ?? … … 384 450 ! 5.1) Ice heat content 385 451 !------------------------ 386 ! Enthalpies are global variables we have to readjust the units (heat content in 10^9 Joules) 387 zcoef = 1._wp / ( unit_fac * REAL( nlay_i ) ) 452 ! Enthalpies are global variables we have to readjust the units (heat content in Joules) 388 453 DO jl = 1, jpl 389 454 DO jk = 1, nlay_i 390 e_i(:,:,jk,jl) = e_i(:,:,jk,jl) * area(:,:) * a_i(:,:,jl) * ht_i(:,:,jl) * zcoef455 e_i(:,:,jk,jl) = e_i(:,:,jk,jl) * area(:,:) * a_i(:,:,jl) * ht_i(:,:,jl) / ( unit_fac * REAL( nlay_i ) ) 391 456 END DO 392 457 END DO … … 395 460 ! 5.2) Snow heat content 396 461 !------------------------ 397 ! Enthalpies are global variables we have to readjust the units (heat content in 10^9 Joules) 398 zcoef = 1._wp / ( unit_fac * REAL( nlay_s ) ) 462 ! Enthalpies are global variables we have to readjust the units (heat content in Joules) 399 463 DO jl = 1, jpl 400 464 DO jk = 1, nlay_s 401 e_s(:,:,jk,jl) = e_s(:,:,jk,jl) * area(:,:) * a_i(:,:,jl) * ht_s(:,:,jl) * zcoef465 e_s(:,:,jk,jl) = e_s(:,:,jk,jl) * area(:,:) * a_i(:,:,jl) * ht_s(:,:,jl) / ( unit_fac * REAL( nlay_s ) ) 402 466 END DO 403 467 END DO … … 411 475 ! 5.4) Diagnostic thermodynamic growth rates 412 476 !-------------------------------------------- 413 !clem@useless d_v_i_thd(:,:,:) = v_i (:,:,:) - old_v_i(:,:,:) ! ice volumes414 !clem@mv-to-itd dv_dt_thd(:,:,:) = d_v_i_thd(:,:,:) * r1_rdtice * rday415 416 IF( con_i .AND. jiindex_1d > 0 ) fbif(:,:) = fbif(:,:) + zqlbsbq(:,:)417 418 477 IF(ln_ctl) THEN ! Control print 419 478 CALL prt_ctl_info(' ') … … 448 507 ENDIF 449 508 ! 450 ! ------------------------------- 451 !- check conservation (C Rousset) 452 IF (ln_limdiahsb) THEN 453 zchk_fs = glob_sum( ( sfx_bri(:,:) + sfx_thd(:,:) + sfx_res(:,:) + sfx_mec(:,:) ) * area(:,:) * tms(:,:) ) - zchk_fs_b 454 zchk_fw = glob_sum( rdm_ice(:,:) * area(:,:) * tms(:,:) ) - zchk_fw_b 455 456 zchk_v_i = ( glob_sum( SUM( v_i(:,:,:), dim=3 ) * area(:,:) * tms(:,:) ) - zchk_v_i_b - ( zchk_fw / rhoic ) ) * r1_rdtice 457 zchk_smv = ( glob_sum( SUM( smv_i(:,:,:), dim=3 ) * area(:,:) * tms(:,:) ) - zchk_smv_b ) * r1_rdtice + ( zchk_fs / rhoic ) 458 459 zchk_vmin = glob_min(v_i) 460 zchk_amax = glob_max(SUM(a_i,dim=3)) 461 zchk_amin = glob_min(a_i) 462 463 IF(lwp) THEN 464 IF ( ABS( zchk_v_i ) > 1.e-5 ) WRITE(numout,*) 'violation volume [m3/day] (limthd) = ',(zchk_v_i * rday) 465 IF ( ABS( zchk_smv ) > 1.e-4 ) WRITE(numout,*) 'violation saline [psu*m3/day] (limthd) = ',(zchk_smv * rday) 466 IF ( zchk_vmin < 0. ) WRITE(numout,*) 'violation v_i<0 [mm] (limthd) = ',(zchk_vmin * 1.e-3) 467 IF ( zchk_amax > amax+epsi10 ) WRITE(numout,*) 'violation a_i>amax (limthd) = ',zchk_amax 468 IF ( zchk_amin < 0. ) WRITE(numout,*) 'violation a_i<0 (limthd) = ',zchk_amin 469 ENDIF 470 ENDIF 471 !- check conservation (C Rousset) 472 ! ------------------------------- 473 ! 474 CALL wrk_dealloc( jpi, jpj, zqlbsbq ) 509 ! 510 CALL wrk_dealloc( jpi, jpj, zqsr, zqns ) 511 512 ! 513 ! conservation test 514 IF( ln_limdiahsb ) CALL lim_cons_hsm(1, 'limthd', zvi_b, zsmv_b, zei_b, zfw_b, zfs_b, zft_b) 475 515 ! 476 516 IF( nn_timing == 1 ) CALL timing_stop('limthd') 477 END SUBROUTINE lim_thd 478 479 480 SUBROUTINE lim_thd_ glohec( eti, ets, etilayer, kideb, kiut, jl)517 518 END SUBROUTINE lim_thd 519 520 SUBROUTINE lim_thd_temp( kideb, kiut ) 481 521 !!----------------------------------------------------------------------- 482 !! *** ROUTINE lim_thd_ glohec***522 !! *** ROUTINE lim_thd_temp *** 483 523 !! 484 !! ** Purpose : Compute total heat content for each category 485 !! Works with 1d vectors only 486 !!----------------------------------------------------------------------- 487 INTEGER , INTENT(in ) :: kideb, kiut ! bounds for the spatial loop 488 INTEGER , INTENT(in ) :: jl ! category number 489 REAL(wp), INTENT( out), DIMENSION (jpij,jpl ) :: eti, ets ! vertically-summed heat content for ice & snow 490 REAL(wp), INTENT( out), DIMENSION (jpij,jkmax) :: etilayer ! heat content for ice layers 491 !! 492 INTEGER :: ji,jk ! loop indices 493 !!----------------------------------------------------------------------- 494 eti(:,:) = 0._wp 495 ets(:,:) = 0._wp 496 ! 497 DO jk = 1, nlay_i ! total q over all layers, ice [J.m-2] 498 DO ji = kideb, kiut 499 etilayer(ji,jk) = q_i_b(ji,jk) * ht_i_b(ji) / REAL( nlay_i ) 500 eti (ji,jl) = eti(ji,jl) + etilayer(ji,jk) 501 END DO 502 END DO 503 DO ji = kideb, kiut ! total q over all layers, snow [J.m-2] 504 ets(ji,jl) = ets(ji,jl) + q_s_b(ji,1) * ht_s_b(ji) / REAL( nlay_s ) 505 END DO 506 ! 507 WRITE(numout,*) ' lim_thd_glohec ' 508 WRITE(numout,*) ' qt_i_in : ', eti(jiindex_1d,jl) * r1_rdtice 509 WRITE(numout,*) ' qt_s_in : ', ets(jiindex_1d,jl) * r1_rdtice 510 WRITE(numout,*) ' qt_in : ', ( eti(jiindex_1d,jl) + ets(jiindex_1d,jl) ) * r1_rdtice 511 ! 512 END SUBROUTINE lim_thd_glohec 513 514 515 SUBROUTINE lim_thd_con_dif( kideb, kiut, jl ) 516 !!----------------------------------------------------------------------- 517 !! *** ROUTINE lim_thd_con_dif *** 518 !! 519 !! ** Purpose : Test energy conservation after heat diffusion 520 !!------------------------------------------------------------------- 521 INTEGER , INTENT(in ) :: kideb, kiut ! bounds for the spatial loop 522 INTEGER , INTENT(in ) :: jl ! category number 523 524 INTEGER :: ji, jk ! loop indices 525 INTEGER :: ii, ij 526 INTEGER :: numce ! number of points for which conservation is violated 527 REAL(wp) :: meance ! mean conservation error 528 REAL(wp) :: max_cons_err, max_surf_err 529 !!--------------------------------------------------------------------- 530 531 max_cons_err = 1.0_wp ! maximum tolerated conservation error 532 max_surf_err = 0.001_wp ! maximum tolerated surface error 533 534 !-------------------------- 535 ! Increment of energy 536 !-------------------------- 537 ! global 538 DO ji = kideb, kiut 539 dq_i(ji,jl) = qt_i_fin(ji,jl) - qt_i_in(ji,jl) + qt_s_fin(ji,jl) - qt_s_in(ji,jl) 540 END DO 541 ! layer by layer 542 dq_i_layer(:,:) = q_i_layer_fin(:,:) - q_i_layer_in(:,:) 543 544 !---------------------------------------- 545 ! Atmospheric heat flux, ice heat budget 546 !---------------------------------------- 547 DO ji = kideb, kiut 548 ii = MOD( npb(ji) - 1 , jpi ) + 1 549 ij = ( npb(ji) - 1 ) / jpi + 1 550 fatm (ji,jl) = qnsr_ice_1d(ji) + ( 1._wp - i0(ji) ) * qsr_ice_1d(ji) 551 sum_fluxq(ji,jl) = fc_su(ji) - fc_bo_i(ji) + qsr_ice_1d(ji) * i0(ji) - fstroc(ii,ij,jl) 552 END DO 553 554 !-------------------- 555 ! Conservation error 556 !-------------------- 557 DO ji = kideb, kiut 558 cons_error(ji,jl) = ABS( dq_i(ji,jl) * r1_rdtice + sum_fluxq(ji,jl) ) 559 END DO 560 561 numce = 0 562 meance = 0._wp 563 DO ji = kideb, kiut 564 IF ( cons_error(ji,jl) .GT. max_cons_err ) THEN 565 numce = numce + 1 566 meance = meance + cons_error(ji,jl) 567 ENDIF 568 END DO 569 IF( numce > 0 ) meance = meance / numce 570 571 WRITE(numout,*) ' Maximum tolerated conservation error : ', max_cons_err 572 WRITE(numout,*) ' After lim_thd_dif, category : ', jl 573 WRITE(numout,*) ' Mean conservation error on big error points ', meance, numit 574 WRITE(numout,*) ' Number of points where there is a cons err gt than c.e. : ', numce, numit 575 576 !------------------------------------------------------- 577 ! Surface error due to imbalance between Fatm and Fcsu 578 !------------------------------------------------------- 579 numce = 0 580 meance = 0._wp 581 582 DO ji = kideb, kiut 583 surf_error(ji,jl) = ABS ( fatm(ji,jl) - fc_su(ji) ) 584 IF( ( t_su_b(ji) .LT. rtt ) .AND. ( surf_error(ji,jl) .GT. max_surf_err ) ) THEN 585 numce = numce + 1 586 meance = meance + surf_error(ji,jl) 587 ENDIF 588 ENDDO 589 IF( numce > 0 ) meance = meance / numce 590 591 WRITE(numout,*) ' Maximum tolerated surface error : ', max_surf_err 592 WRITE(numout,*) ' After lim_thd_dif, category : ', jl 593 WRITE(numout,*) ' Mean surface error on big error points ', meance, numit 594 WRITE(numout,*) ' Number of points where there is a surf err gt than surf_err : ', numce, numit 595 596 WRITE(numout,*) ' fc_su : ', fc_su(jiindex_1d) 597 WRITE(numout,*) ' fatm : ', fatm(jiindex_1d,jl) 598 WRITE(numout,*) ' t_su : ', t_su_b(jiindex_1d) 599 600 !--------------------------------------- 601 ! Write ice state in case of big errors 602 !--------------------------------------- 603 DO ji = kideb, kiut 604 IF ( ( ( t_su_b(ji) .LT. rtt ) .AND. ( surf_error(ji,jl) .GT. max_surf_err ) ) .OR. & 605 ( cons_error(ji,jl) .GT. max_cons_err ) ) THEN 606 ii = MOD( npb(ji) - 1, jpi ) + 1 607 ij = ( npb(ji) - 1 ) / jpi + 1 608 ! 609 WRITE(numout,*) ' alerte 1 ' 610 WRITE(numout,*) ' Untolerated conservation / surface error after ' 611 WRITE(numout,*) ' heat diffusion in the ice ' 612 WRITE(numout,*) ' Category : ', jl 613 WRITE(numout,*) ' ii , ij : ', ii, ij 614 WRITE(numout,*) ' lat, lon : ', gphit(ii,ij), glamt(ii,ij) 615 WRITE(numout,*) ' cons_error : ', cons_error(ji,jl) 616 WRITE(numout,*) ' surf_error : ', surf_error(ji,jl) 617 WRITE(numout,*) ' dq_i : ', - dq_i(ji,jl) * r1_rdtice 618 WRITE(numout,*) ' Fdt : ', sum_fluxq(ji,jl) 619 WRITE(numout,*) 620 ! WRITE(numout,*) ' qt_i_in : ', qt_i_in(ji,jl) 621 ! WRITE(numout,*) ' qt_s_in : ', qt_s_in(ji,jl) 622 ! WRITE(numout,*) ' qt_i_fin : ', qt_i_fin(ji,jl) 623 ! WRITE(numout,*) ' qt_s_fin : ', qt_s_fin(ji,jl) 624 ! WRITE(numout,*) ' qt : ', qt_i_fin(ji,jl) + qt_s_fin(ji,jl) 625 WRITE(numout,*) ' ht_i : ', ht_i_b(ji) 626 WRITE(numout,*) ' ht_s : ', ht_s_b(ji) 627 WRITE(numout,*) ' t_su : ', t_su_b(ji) 628 WRITE(numout,*) ' t_s : ', t_s_b(ji,1) 629 WRITE(numout,*) ' t_i : ', t_i_b(ji,1:nlay_i) 630 WRITE(numout,*) ' t_bo : ', t_bo_b(ji) 631 WRITE(numout,*) ' q_i : ', q_i_b(ji,1:nlay_i) 632 WRITE(numout,*) ' s_i : ', s_i_b(ji,1:nlay_i) 633 WRITE(numout,*) ' tmelts : ', rtt - tmut*s_i_b(ji,1:nlay_i) 634 WRITE(numout,*) 635 WRITE(numout,*) ' Fluxes ' 636 WRITE(numout,*) ' ~~~~~~ ' 637 WRITE(numout,*) ' fatm : ', fatm(ji,jl) 638 WRITE(numout,*) ' fc_su : ', fc_su (ji) 639 WRITE(numout,*) ' fstr_inice : ', qsr_ice_1d(ji)*i0(ji) 640 WRITE(numout,*) ' fc_bo : ', - fc_bo_i (ji) 641 WRITE(numout,*) ' foc : ', fbif_1d(ji) 642 WRITE(numout,*) ' fstroc : ', fstroc (ii,ij,jl) 643 WRITE(numout,*) ' i0 : ', i0(ji) 644 WRITE(numout,*) ' qsr_ice : ', (1.0-i0(ji))*qsr_ice_1d(ji) 645 WRITE(numout,*) ' qns_ice : ', qnsr_ice_1d(ji) 646 WRITE(numout,*) ' Conduction fluxes : ' 647 WRITE(numout,*) ' fc_s : ', fc_s(ji,0:nlay_s) 648 WRITE(numout,*) ' fc_i : ', fc_i(ji,0:nlay_i) 649 WRITE(numout,*) 650 WRITE(numout,*) ' Layer by layer ... ' 651 WRITE(numout,*) ' dq_snow : ', ( qt_s_fin(ji,jl) - qt_s_in(ji,jl) ) * r1_rdtice 652 WRITE(numout,*) ' dfc_snow : ', fc_s(ji,1) - fc_s(ji,0) 653 DO jk = 1, nlay_i 654 WRITE(numout,*) ' layer : ', jk 655 WRITE(numout,*) ' dq_ice : ', dq_i_layer(ji,jk) * r1_rdtice 656 WRITE(numout,*) ' radab : ', radab(ji,jk) 657 WRITE(numout,*) ' dfc_i : ', fc_i(ji,jk) - fc_i(ji,jk-1) 658 WRITE(numout,*) ' tot f : ', fc_i(ji,jk) - fc_i(ji,jk-1) - radab(ji,jk) 659 END DO 660 661 ENDIF 662 ! 663 END DO 664 ! 665 END SUBROUTINE lim_thd_con_dif 666 667 668 SUBROUTINE lim_thd_con_dh( kideb, kiut, jl ) 669 !!----------------------------------------------------------------------- 670 !! *** ROUTINE lim_thd_con_dh *** 671 !! 672 !! ** Purpose : Test energy conservation after enthalpy redistr. 673 !!----------------------------------------------------------------------- 674 INTEGER, INTENT(in) :: kideb, kiut ! bounds for the spatial loop 675 INTEGER, INTENT(in) :: jl ! category number 676 ! 677 INTEGER :: ji ! loop indices 678 INTEGER :: ii, ij, numce ! local integers 679 REAL(wp) :: meance, max_cons_err !local scalar 680 !!--------------------------------------------------------------------- 681 682 max_cons_err = 1._wp 683 684 !-------------------------- 685 ! Increment of energy 686 !-------------------------- 687 DO ji = kideb, kiut 688 dq_i(ji,jl) = qt_i_fin(ji,jl) - qt_i_in(ji,jl) + qt_s_fin(ji,jl) - qt_s_in(ji,jl) ! global 689 END DO 690 dq_i_layer(:,:) = q_i_layer_fin(:,:) - q_i_layer_in(:,:) ! layer by layer 691 692 !---------------------------------------- 693 ! Atmospheric heat flux, ice heat budget 694 !---------------------------------------- 695 DO ji = kideb, kiut 696 ii = MOD( npb(ji) - 1 , jpi ) + 1 697 ij = ( npb(ji) - 1 ) / jpi + 1 698 699 fatm (ji,jl) = qnsr_ice_1d(ji) + qsr_ice_1d(ji) ! total heat flux 700 sum_fluxq (ji,jl) = fatm(ji,jl) + fbif_1d(ji) - ftotal_fin(ji) - fstroc(ii,ij,jl) 701 cons_error(ji,jl) = ABS( dq_i(ji,jl) * r1_rdtice + sum_fluxq(ji,jl) ) 702 END DO 703 704 !-------------------- 705 ! Conservation error 706 !-------------------- 707 DO ji = kideb, kiut 708 cons_error(ji,jl) = ABS( dq_i(ji,jl) * r1_rdtice + sum_fluxq(ji,jl) ) 709 END DO 710 711 numce = 0 712 meance = 0._wp 713 DO ji = kideb, kiut 714 IF( cons_error(ji,jl) .GT. max_cons_err ) THEN 715 numce = numce + 1 716 meance = meance + cons_error(ji,jl) 717 ENDIF 718 ENDDO 719 IF(numce > 0 ) meance = meance / numce 720 721 WRITE(numout,*) ' Error report - Category : ', jl 722 WRITE(numout,*) ' ~~~~~~~~~~~~ ' 723 WRITE(numout,*) ' Maximum tolerated conservation error : ', max_cons_err 724 WRITE(numout,*) ' After lim_thd_ent, category : ', jl 725 WRITE(numout,*) ' Mean conservation error on big error points ', meance, numit 726 WRITE(numout,*) ' Number of points where there is a cons err gt than 0.1 W/m2 : ', numce, numit 727 728 !--------------------------------------- 729 ! Write ice state in case of big errors 730 !--------------------------------------- 731 DO ji = kideb, kiut 732 IF ( cons_error(ji,jl) .GT. max_cons_err ) THEN 733 ii = MOD( npb(ji) - 1, jpi ) + 1 734 ij = ( npb(ji) - 1 ) / jpi + 1 735 ! 736 WRITE(numout,*) ' alerte 1 - category : ', jl 737 WRITE(numout,*) ' Untolerated conservation error after limthd_ent ' 738 WRITE(numout,*) ' ii , ij : ', ii, ij 739 WRITE(numout,*) ' lat, lon : ', gphit(ii,ij), glamt(ii,ij) 740 WRITE(numout,*) ' * ' 741 WRITE(numout,*) ' Ftotal : ', sum_fluxq(ji,jl) 742 WRITE(numout,*) ' dq_t : ', - dq_i(ji,jl) * r1_rdtice 743 WRITE(numout,*) ' dq_i : ', - ( qt_i_fin(ji,jl) - qt_i_in(ji,jl) ) * r1_rdtice 744 WRITE(numout,*) ' dq_s : ', - ( qt_s_fin(ji,jl) - qt_s_in(ji,jl) ) * r1_rdtice 745 WRITE(numout,*) ' cons_error : ', cons_error(ji,jl) 746 WRITE(numout,*) ' * ' 747 WRITE(numout,*) ' Fluxes --- : ' 748 WRITE(numout,*) ' fatm : ', fatm(ji,jl) 749 WRITE(numout,*) ' foce : ', fbif_1d(ji) 750 WRITE(numout,*) ' fres : ', ftotal_fin(ji) 751 WRITE(numout,*) ' fhbri : ', fhbricat(ii,ij,jl) 752 WRITE(numout,*) ' * ' 753 WRITE(numout,*) ' Heat contents --- : ' 754 WRITE(numout,*) ' qt_s_in : ', qt_s_in(ji,jl) * r1_rdtice 755 WRITE(numout,*) ' qt_i_in : ', qt_i_in(ji,jl) * r1_rdtice 756 WRITE(numout,*) ' qt_in : ', ( qt_i_in(ji,jl) + qt_s_in(ji,jl) ) * r1_rdtice 757 WRITE(numout,*) ' qt_s_fin : ', qt_s_fin(ji,jl) * r1_rdtice 758 WRITE(numout,*) ' qt_i_fin : ', qt_i_fin(ji,jl) * r1_rdtice 759 WRITE(numout,*) ' qt_fin : ', ( qt_i_fin(ji,jl) + qt_s_fin(ji,jl) ) * r1_rdtice 760 WRITE(numout,*) ' * ' 761 WRITE(numout,*) ' Ice variables --- : ' 762 WRITE(numout,*) ' ht_i : ', ht_i_b(ji) 763 WRITE(numout,*) ' ht_s : ', ht_s_b(ji) 764 WRITE(numout,*) ' dh_s_tot : ', dh_s_tot(ji) 765 WRITE(numout,*) ' dh_snowice: ', dh_snowice(ji) 766 WRITE(numout,*) ' dh_i_surf : ', dh_i_surf(ji) 767 WRITE(numout,*) ' dh_i_bott : ', dh_i_bott(ji) 768 ENDIF 769 ! 770 END DO 771 ! 772 END SUBROUTINE lim_thd_con_dh 773 774 775 SUBROUTINE lim_thd_enmelt( kideb, kiut ) 776 !!----------------------------------------------------------------------- 777 !! *** ROUTINE lim_thd_enmelt *** 778 !! 779 !! ** Purpose : Computes sea ice energy of melting q_i (J.m-3) 524 !! ** Purpose : Computes sea ice temperature (Kelvin) from enthalpy 780 525 !! 781 526 !! ** Method : Formula (Bitz and Lipscomb, 1999) … … 784 529 !! 785 530 INTEGER :: ji, jk ! dummy loop indices 786 REAL(wp) :: ztmelts ! local scalar531 REAL(wp) :: ztmelts, zaaa, zbbb, zccc, zdiscrim ! local scalar 787 532 !!------------------------------------------------------------------- 788 ! 789 DO jk = 1, nlay_i ! Sea ice energy of melting533 ! Recover ice temperature 534 DO jk = 1, nlay_i 790 535 DO ji = kideb, kiut 791 ztmelts = - tmut * s_i_b(ji,jk) + rtt 792 q_i_b(ji,jk) = rhoic * ( cpic * ( ztmelts - t_i_b(ji,jk) ) & 793 & + lfus * ( 1.0 - (ztmelts-rtt) / MIN( t_i_b(ji,jk)-rtt, -epsi10 ) ) & 794 & - rcp * ( ztmelts-rtt ) ) 795 END DO 796 END DO 797 DO jk = 1, nlay_s ! Snow energy of melting 798 DO ji = kideb, kiut 799 q_s_b(ji,jk) = rhosn * ( cpic * ( rtt - t_s_b(ji,jk) ) + lfus ) 800 END DO 801 END DO 802 ! 803 END SUBROUTINE lim_thd_enmelt 804 536 ztmelts = -tmut * s_i_1d(ji,jk) + rtt 537 ! Conversion q(S,T) -> T (second order equation) 538 zaaa = cpic 539 zbbb = ( rcp - cpic ) * ( ztmelts - rtt ) + q_i_1d(ji,jk) / rhoic - lfus 540 zccc = lfus * ( ztmelts - rtt ) 541 zdiscrim = SQRT( MAX( zbbb * zbbb - 4._wp * zaaa * zccc, 0._wp ) ) 542 t_i_1d(ji,jk) = rtt - ( zbbb + zdiscrim ) / ( 2._wp * zaaa ) 543 544 ! mask temperature 545 rswitch = 1._wp - MAX( 0._wp , SIGN( 1._wp , - ht_i_1d(ji) ) ) 546 t_i_1d(ji,jk) = rswitch * t_i_1d(ji,jk) + ( 1._wp - rswitch ) * rtt 547 END DO 548 END DO 549 550 END SUBROUTINE lim_thd_temp 805 551 806 552 SUBROUTINE lim_thd_init … … 818 564 INTEGER :: ios ! Local integer output status for namelist read 819 565 NAMELIST/namicethd/ hmelt , hiccrit, fraz_swi, maxfrazb, vfrazb, Cfrazb, & 820 & hicmin, hiclim, & 821 & sbeta , parlat, hakspl, hibspl, exld, & 822 & hakdif, hnzst , thth , parsub, alphs, betas, & 566 & hiclim, hnzst, parsub, betas, & 823 567 & kappa_i, nconv_i_thd, maxer_i_thd, thcon_i_swi 824 568 !!------------------------------------------------------------------- … … 838 582 902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namicethd in configuration namelist', lwp ) 839 583 IF(lwm) WRITE ( numoni, namicethd ) 584 585 IF( lk_cpl .AND. parsub /= 0.0 ) CALL ctl_stop( 'In coupled mode, use parsub = 0. or send dqla' ) 840 586 ! 841 587 IF(lwp) THEN ! control print … … 843 589 WRITE(numout,*)' Namelist of ice parameters for ice thermodynamic computation ' 844 590 WRITE(numout,*)' maximum melting at the bottom hmelt = ', hmelt 845 WRITE(numout,*)' ice thick. for lateral accretion in NH (SH) hiccrit(1/2)= ', hiccrit591 WRITE(numout,*)' ice thick. for lateral accretion hiccrit = ', hiccrit 846 592 WRITE(numout,*)' Frazil ice thickness as a function of wind or not fraz_swi = ', fraz_swi 847 593 WRITE(numout,*)' Maximum proportion of frazil ice collecting at bottom maxfrazb = ', maxfrazb 848 594 WRITE(numout,*)' Thresold relative drift speed for collection of frazil vfrazb = ', vfrazb 849 595 WRITE(numout,*)' Squeezing coefficient for collection of frazil Cfrazb = ', Cfrazb 850 WRITE(numout,*)' ice thick. corr. to max. energy stored in brine pocket hicmin = ', hicmin851 596 WRITE(numout,*)' minimum ice thickness hiclim = ', hiclim 852 597 WRITE(numout,*)' numerical carac. of the scheme for diffusion in ice ' 853 WRITE(numout,*)' Cranck-Nicholson (=0.5), implicit (=1), explicit (=0) sbeta = ', sbeta854 WRITE(numout,*)' percentage of energy used for lateral ablation parlat = ', parlat855 WRITE(numout,*)' slope of distr. for Hakkinen-Mellor lateral melting hakspl = ', hakspl856 WRITE(numout,*)' slope of distribution for Hibler lateral melting hibspl = ', hibspl857 WRITE(numout,*)' exponent for leads-closure rate exld = ', exld858 WRITE(numout,*)' coefficient for diffusions of ice and snow hakdif = ', hakdif859 WRITE(numout,*)' threshold thick. for comp. of eq. thermal conductivity zhth = ', thth860 598 WRITE(numout,*)' thickness of the surf. layer in temp. computation hnzst = ', hnzst 861 599 WRITE(numout,*)' switch for snow sublimation (=1) or not (=0) parsub = ', parsub 862 WRITE(numout,*)' coefficient for snow density when snow ice formation alphs = ', alphs863 600 WRITE(numout,*)' coefficient for ice-lead partition of snowfall betas = ', betas 864 601 WRITE(numout,*)' extinction radiation parameter in sea ice (1.0) kappa_i = ', kappa_i … … 866 603 WRITE(numout,*)' maximal err. on T for heat diffusion computation maxer_i_thd = ', maxer_i_thd 867 604 WRITE(numout,*)' switch for comp. of thermal conductivity in the ice thcon_i_swi = ', thcon_i_swi 605 WRITE(numout,*)' check heat conservation in the ice/snow con_i = ', con_i 868 606 ENDIF 869 !870 rcdsn = hakdif * rcdsn871 rcdic = hakdif * rcdic872 607 ! 873 608 END SUBROUTINE lim_thd_init -
branches/2014/dev_r4650_UKMO14.12_STAND_ALONE_OBSOPER/NEMOGCM/NEMO/LIM_SRC_3/limthd_dh.F90
r4333 r5034 6 6 !! History : LIM ! 2003-05 (M. Vancoppenolle) Original code in 1D 7 7 !! ! 2005-06 (M. Vancoppenolle) 3D version 8 !! 3.2 ! 2009-07 (M. Vancoppenolle, Y. Aksenov, G. Madec) bug correction in rdm_snw & rdm_ice8 !! 3.2 ! 2009-07 (M. Vancoppenolle, Y. Aksenov, G. Madec) bug correction in wfx_snw & wfx_ice 9 9 !! 3.4 ! 2011-02 (G. Madec) dynamical allocation 10 10 !! 3.5 ! 2012-10 (G. Madec & co) salt flux + bug fixes … … 26 26 USE wrk_nemo ! work arrays 27 27 USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) 28 28 29 29 IMPLICIT NONE 30 30 PRIVATE 31 31 32 32 PUBLIC lim_thd_dh ! called by lim_thd 33 34 REAL(wp) :: epsi20 = 1.e-20 ! constant values35 REAL(wp) :: epsi10 = 1.e-10 !36 REAL(wp) :: epsi13 = 1.e-13 !37 REAL(wp) :: zzero = 0._wp !38 REAL(wp) :: zone = 1._wp !39 33 40 34 !!---------------------------------------------------------------------- … … 45 39 CONTAINS 46 40 47 SUBROUTINE lim_thd_dh( kideb, kiut , jl)41 SUBROUTINE lim_thd_dh( kideb, kiut ) 48 42 !!------------------------------------------------------------------ 49 43 !! *** ROUTINE lim_thd_dh *** … … 70 64 !!------------------------------------------------------------------ 71 65 INTEGER , INTENT(in) :: kideb, kiut ! Start/End point on which the the computation is applied 72 INTEGER , INTENT(in) :: jl ! Thickness cateogry number73 66 !! 74 67 INTEGER :: ji , jk ! dummy loop indices 75 68 INTEGER :: ii, ij ! 2D corresponding indices to ji 76 INTEGER :: isnow ! switch for presence (1) or absence (0) of snow77 INTEGER :: isnowic ! snow ice formation not78 INTEGER :: i_ice_switch ! ice thickness above a certain treshold or not79 69 INTEGER :: iter 80 70 81 REAL(wp) :: zzfmass_i, zihgnew ! local scalar 82 REAL(wp) :: zzfmass_s, zhsnew, ztmelts ! local scalar 83 REAL(wp) :: zhn, zdhcf, zdhbf, zhni, zhnfi, zihg ! 84 REAL(wp) :: zdhnm, zhnnew, zhisn, zihic, zzc ! 71 REAL(wp) :: ztmelts ! local scalar 72 REAL(wp) :: zdh, zfdum ! 85 73 REAL(wp) :: zfracs ! fractionation coefficient for bottom salt entrapment 86 74 REAL(wp) :: zcoeff ! dummy argument for snowfall partitioning over ice and leads 87 REAL(wp) :: zs m_snowice! snow-ice salinity75 REAL(wp) :: zs_snic ! snow-ice salinity 88 76 REAL(wp) :: zswi1 ! switch for computation of bottom salinity 89 77 REAL(wp) :: zswi12 ! switch for computation of bottom salinity 90 78 REAL(wp) :: zswi2 ! switch for computation of bottom salinity 91 79 REAL(wp) :: zgrr ! bottom growth rate 92 REAL(wp) :: ztform ! bottom formation temperature 93 ! 94 REAL(wp), POINTER, DIMENSION(:) :: zh_i ! ice layer thickness 80 REAL(wp) :: zt_i_new ! bottom formation temperature 81 82 REAL(wp) :: zQm ! enthalpy exchanged with the ocean (J/m2), >0 towards the ocean 83 REAL(wp) :: zEi ! specific enthalpy of sea ice (J/kg) 84 REAL(wp) :: zEw ! specific enthalpy of exchanged water (J/kg) 85 REAL(wp) :: zdE ! specific enthalpy difference (J/kg) 86 REAL(wp) :: zfmdt ! exchange mass flux x time step (J/m2), >0 towards the ocean 87 REAL(wp) :: zsstK ! SST in Kelvin 88 95 89 REAL(wp), POINTER, DIMENSION(:) :: zh_s ! snow layer thickness 96 REAL(wp), POINTER, DIMENSION(:) :: ztfs ! melting point 97 REAL(wp), POINTER, DIMENSION(:) :: zhsold ! old snow thickness 98 REAL(wp), POINTER, DIMENSION(:) :: zqprec ! energy of fallen snow 99 REAL(wp), POINTER, DIMENSION(:) :: zqfont_su ! incoming, remaining surface energy 100 REAL(wp), POINTER, DIMENSION(:) :: zqfont_bo ! incoming, bottom energy 101 REAL(wp), POINTER, DIMENSION(:) :: z_f_surf ! surface heat for ablation 102 REAL(wp), POINTER, DIMENSION(:) :: zhgnew ! new ice thickness 103 REAL(wp), POINTER, DIMENSION(:) :: zfmass_i ! 90 REAL(wp), POINTER, DIMENSION(:) :: zqprec ! energy of fallen snow (J.m-3) 91 REAL(wp), POINTER, DIMENSION(:) :: zq_su ! heat for surface ablation (J.m-2) 92 REAL(wp), POINTER, DIMENSION(:) :: zq_bo ! heat for bottom ablation (J.m-2) 93 REAL(wp), POINTER, DIMENSION(:) :: zq_1cat ! corrected heat in case 1-cat and hmelt>15cm (J.m-2) 94 REAL(wp), POINTER, DIMENSION(:) :: zq_rema ! remaining heat at the end of the routine (J.m-2) 95 REAL(wp), POINTER, DIMENSION(:) :: zf_tt ! Heat budget to determine melting or freezing(W.m-2) 96 INTEGER , POINTER, DIMENSION(:) :: icount ! number of layers vanished by melting 104 97 105 98 REAL(wp), POINTER, DIMENSION(:) :: zdh_s_mel ! snow melt … … 108 101 109 102 REAL(wp), POINTER, DIMENSION(:,:) :: zdeltah 110 111 ! Pathological cases 112 REAL(wp), POINTER, DIMENSION(:) :: zfdt_init ! total incoming heat for ice melt 113 REAL(wp), POINTER, DIMENSION(:) :: zfdt_final ! total remaing heat for ice melt 114 REAL(wp), POINTER, DIMENSION(:) :: zqt_i ! total ice heat content 115 REAL(wp), POINTER, DIMENSION(:) :: zqt_s ! total snow heat content 116 REAL(wp), POINTER, DIMENSION(:) :: zqt_dummy ! dummy heat content 117 118 REAL(wp), POINTER, DIMENSION(:,:) :: zqt_i_lay ! total ice heat content 103 REAL(wp), POINTER, DIMENSION(:,:) :: zh_i ! ice layer thickness 104 105 REAL(wp), POINTER, DIMENSION(:) :: zqh_i ! total ice heat content (J.m-2) 106 REAL(wp), POINTER, DIMENSION(:) :: zqh_s ! total snow heat content (J.m-2) 107 REAL(wp), POINTER, DIMENSION(:) :: zq_s ! total snow enthalpy (J.m-3) 119 108 120 109 ! mass and salt flux (clem) 121 REAL(wp) :: zdvres, zdvsur, zdvbot 122 REAL(wp), POINTER, DIMENSION(:) :: zviold, zvsold ! old ice volume... 110 REAL(wp) :: zdvres, zswitch_sal 123 111 124 112 ! Heat conservation 125 INTEGER :: num_iter_max, numce_dh 126 REAL(wp) :: meance_dh 127 REAL(wp) :: zinda 128 REAL(wp), POINTER, DIMENSION(:) :: zinnermelt 129 REAL(wp), POINTER, DIMENSION(:) :: zfbase, zdq_i 113 INTEGER :: num_iter_max 114 130 115 !!------------------------------------------------------------------ 131 116 132 CALL wrk_alloc( jpij, zh_i, zh_s, ztfs, zhsold, zqprec, zqfont_su, zqfont_bo, z_f_surf, zhgnew, zfmass_i ) 133 CALL wrk_alloc( jpij, zdh_s_mel, zdh_s_pre, zdh_s_sub, zfdt_init, zfdt_final, zqt_i, zqt_s, zqt_dummy ) 134 CALL wrk_alloc( jpij, zinnermelt, zfbase, zdq_i ) 135 CALL wrk_alloc( jpij, jkmax, zdeltah, zqt_i_lay ) 136 137 CALL wrk_alloc( jpij, zviold, zvsold ) ! clem 117 ! Discriminate between varying salinity (num_sal=2) and prescribed cases (other values) 118 SELECT CASE( num_sal ) ! varying salinity or not 119 CASE( 1, 3, 4 ) ; zswitch_sal = 0 ! prescribed salinity profile 120 CASE( 2 ) ; zswitch_sal = 1 ! varying salinity profile 121 END SELECT 122 123 CALL wrk_alloc( jpij, zh_s, zqprec, zq_su, zq_bo, zf_tt, zq_1cat, zq_rema ) 124 CALL wrk_alloc( jpij, zdh_s_mel, zdh_s_pre, zdh_s_sub, zqh_i, zqh_s, zq_s ) 125 CALL wrk_alloc( jpij, nlay_i+1, zdeltah, zh_i ) 126 CALL wrk_alloc( jpij, icount ) 138 127 139 ftotal_fin(:) = 0._wp 140 zfdt_init (:) = 0._wp 141 zfdt_final(:) = 0._wp 142 143 dh_i_surf (:) = 0._wp 144 dh_i_bott (:) = 0._wp 145 dh_snowice(:) = 0._wp 146 147 DO ji = kideb, kiut 148 old_ht_i_b(ji) = ht_i_b(ji) 149 old_ht_s_b(ji) = ht_s_b(ji) 150 zviold(ji) = a_i_b(ji) * ht_i_b(ji) ! clem 151 zvsold(ji) = a_i_b(ji) * ht_s_b(ji) ! clem 152 END DO 128 dh_i_surf (:) = 0._wp ; dh_i_bott (:) = 0._wp ; dh_snowice(:) = 0._wp 129 dsm_i_se_1d(:) = 0._wp ; dsm_i_si_1d(:) = 0._wp 130 131 zqprec (:) = 0._wp ; zq_su (:) = 0._wp ; zq_bo (:) = 0._wp ; zf_tt (:) = 0._wp 132 zq_1cat(:) = 0._wp ; zq_rema(:) = 0._wp 133 134 zh_s (:) = 0._wp 135 zdh_s_pre(:) = 0._wp 136 zdh_s_mel(:) = 0._wp 137 zdh_s_sub(:) = 0._wp 138 zqh_s (:) = 0._wp 139 zqh_i (:) = 0._wp 140 141 zh_i (:,:) = 0._wp 142 zdeltah (:,:) = 0._wp 143 icount (:) = 0 144 145 ! initialize layer thicknesses and enthalpies 146 h_i_old (:,0:nlay_i+1) = 0._wp 147 qh_i_old(:,0:nlay_i+1) = 0._wp 148 DO jk = 1, nlay_i 149 DO ji = kideb, kiut 150 h_i_old (ji,jk) = ht_i_1d(ji) / REAL( nlay_i ) 151 qh_i_old(ji,jk) = q_i_1d(ji,jk) * h_i_old(ji,jk) 152 ENDDO 153 ENDDO 153 154 ! 154 155 !------------------------------------------------------------------------------! 155 ! 1) Calculate available heat for surface a blation!156 ! 1) Calculate available heat for surface and bottom ablation ! 156 157 !------------------------------------------------------------------------------! 157 158 ! 158 159 DO ji = kideb, kiut 159 isnow = INT( 1.0 - MAX( 0.0 , SIGN( 1.0 , - ht_s_b(ji) ) ) ) 160 ztfs (ji) = isnow * rtt + ( 1.0 - isnow ) * rtt 161 z_f_surf (ji) = qnsr_ice_1d(ji) + ( 1.0 - i0(ji) ) * qsr_ice_1d(ji) - fc_su(ji) 162 z_f_surf (ji) = MAX( zzero , z_f_surf(ji) ) * MAX( zzero , SIGN( zone , t_su_b(ji) - ztfs(ji) ) ) 163 zfdt_init(ji) = ( z_f_surf(ji) + MAX( fbif_1d(ji) + qlbbq_1d(ji) + fc_bo_i(ji),0.0 ) ) * rdt_ice 164 END DO ! ji 165 166 zqfont_su (:) = 0._wp 167 zqfont_bo (:) = 0._wp 168 dsm_i_se_1d(:) = 0._wp 169 dsm_i_si_1d(:) = 0._wp 160 rswitch = 1._wp - MAX( 0._wp , SIGN( 1._wp , - ht_s_1d(ji) ) ) 161 ztmelts = rswitch * rtt + ( 1._wp - rswitch ) * rtt 162 163 zfdum = qns_ice_1d(ji) + ( 1._wp - i0(ji) ) * qsr_ice_1d(ji) - fc_su(ji) 164 zf_tt(ji) = fc_bo_i(ji) + fhtur_1d(ji) + fhld_1d(ji) 165 166 zq_su (ji) = MAX( 0._wp, zfdum * rdt_ice ) * MAX( 0._wp , SIGN( 1._wp, t_su_1d(ji) - ztmelts ) ) 167 zq_bo (ji) = MAX( 0._wp, zf_tt(ji) * rdt_ice ) 168 END DO 169 170 170 ! 171 171 !------------------------------------------------------------------------------! 172 ! 2) Computing layer thicknesses and snow and sea-ice enthalpies. ! 172 ! If snow temperature is above freezing point, then snow melts 173 ! (should not happen but sometimes it does) 173 174 !------------------------------------------------------------------------------! 174 ! 175 DO ji = kideb, kiut ! Layer thickness 176 zh_i(ji) = ht_i_b(ji) / REAL( nlay_i ) 177 zh_s(ji) = ht_s_b(ji) / REAL( nlay_s ) 178 END DO 179 ! 180 zqt_s(:) = 0._wp ! Total enthalpy of the snow 175 DO ji = kideb, kiut 176 IF( t_s_1d(ji,1) > rtt ) THEN !!! Internal melting 177 ! Contribution to heat flux to the ocean [W.m-2], < 0 178 hfx_res_1d(ji) = hfx_res_1d(ji) + q_s_1d(ji,1) * ht_s_1d(ji) * a_i_1d(ji) * r1_rdtice 179 ! Contribution to mass flux 180 wfx_snw_1d(ji) = wfx_snw_1d(ji) + rhosn * ht_s_1d(ji) * a_i_1d(ji) * r1_rdtice 181 ! updates 182 ht_s_1d(ji) = 0._wp 183 q_s_1d (ji,1) = 0._wp 184 t_s_1d (ji,1) = rtt 185 END IF 186 END DO 187 188 !------------------------------------------------------------! 189 ! 2) Computing layer thicknesses and enthalpies. ! 190 !------------------------------------------------------------! 191 ! 192 DO ji = kideb, kiut 193 zh_s(ji) = ht_s_1d(ji) / REAL( nlay_s ) 194 END DO 195 ! 181 196 DO jk = 1, nlay_s 182 197 DO ji = kideb, kiut 183 zq t_s(ji) = zqt_s(ji) + q_s_b(ji,jk) * ht_s_b(ji) / REAL( nlay_s)198 zqh_s(ji) = zqh_s(ji) + q_s_1d(ji,jk) * zh_s(ji) 184 199 END DO 185 200 END DO 186 201 ! 187 zqt_i(:) = 0._wp ! Total enthalpy of the ice188 202 DO jk = 1, nlay_i 189 203 DO ji = kideb, kiut 190 zzc = q_i_b(ji,jk) * ht_i_b(ji) / REAL( nlay_i ) 191 zqt_i(ji) = zqt_i(ji) + zzc 192 zqt_i_lay(ji,jk) = zzc 204 zh_i(ji,jk) = ht_i_1d(ji) / REAL( nlay_i ) 205 zqh_i(ji) = zqh_i(ji) + q_i_1d(ji,jk) * zh_i(ji,jk) 193 206 END DO 194 207 END DO … … 212 225 ! Martin Vancoppenolle, December 2006 213 226 214 ! Snow fall 215 DO ji = kideb, kiut 216 zcoeff = ( 1.0 - ( 1.0 - at_i_b(ji) )**betas ) / at_i_b(ji) 227 DO ji = kideb, kiut 228 !----------- 229 ! Snow fall 230 !----------- 231 ! thickness change 232 zcoeff = ( 1._wp - ( 1._wp - at_i_1d(ji) )**betas ) / at_i_1d(ji) 217 233 zdh_s_pre(ji) = zcoeff * sprecip_1d(ji) * rdt_ice / rhosn 218 END DO 219 zdh_s_mel(:) = 0._wp 220 221 ! Melt of fallen snow 222 DO ji = kideb, kiut 223 ! tatm_ice is now in K 224 zqprec (ji) = rhosn * ( cpic * ( rtt - tatm_ice_1d(ji) ) + lfus ) 225 zqfont_su(ji) = z_f_surf(ji) * rdt_ice 226 zdeltah (ji,1) = MIN( 0.e0 , - zqfont_su(ji) / MAX( zqprec(ji) , epsi13 ) ) 227 zqfont_su(ji) = MAX( 0.e0 , - zdh_s_pre(ji) - zdeltah(ji,1) ) * zqprec(ji) 228 zdeltah (ji,1) = MAX( - zdh_s_pre(ji) , zdeltah(ji,1) ) 229 zdh_s_mel(ji) = zdh_s_mel(ji) + zdeltah(ji,1) 230 ! heat conservation 231 qt_s_in(ji,jl) = qt_s_in(ji,jl) + zqprec(ji) * zdh_s_pre(ji) 232 zqt_s (ji) = zqt_s (ji) + zqprec(ji) * zdh_s_pre(ji) 233 zqt_s (ji) = MAX( zqt_s(ji) - zqfont_su(ji) , 0.e0 ) 234 END DO 235 236 237 ! Snow melt due to surface heat imbalance 234 ! enthalpy of the precip (>0, J.m-3) (tatm_ice is now in K) 235 zqprec (ji) = rhosn * ( cpic * ( rtt - MIN( tatm_ice_1d(ji), rt0_snow) ) + lfus ) 236 IF( sprecip_1d(ji) == 0._wp ) zqprec(ji) = 0._wp 237 ! heat flux from snow precip (>0, W.m-2) 238 hfx_spr_1d(ji) = hfx_spr_1d(ji) + zdh_s_pre(ji) * a_i_1d(ji) * zqprec(ji) * r1_rdtice 239 ! mass flux, <0 240 wfx_spr_1d(ji) = wfx_spr_1d(ji) - rhosn * a_i_1d(ji) * zdh_s_pre(ji) * r1_rdtice 241 ! update thickness 242 ht_s_1d (ji) = MAX( 0._wp , ht_s_1d(ji) + zdh_s_pre(ji) ) 243 244 !--------------------- 245 ! Melt of falling snow 246 !--------------------- 247 ! thickness change 248 IF( zdh_s_pre(ji) > 0._wp ) THEN 249 rswitch = 1._wp - MAX( 0._wp , SIGN( 1._wp , - zqprec(ji) + epsi20 ) ) 250 zdh_s_mel (ji) = - rswitch * zq_su(ji) / MAX( zqprec(ji) , epsi20 ) 251 zdh_s_mel (ji) = MAX( - zdh_s_pre(ji), zdh_s_mel(ji) ) ! bound melting 252 ! heat used to melt snow (W.m-2, >0) 253 hfx_snw_1d(ji) = hfx_snw_1d(ji) - zdh_s_mel(ji) * a_i_1d(ji) * zqprec(ji) * r1_rdtice 254 ! snow melting only = water into the ocean (then without snow precip), >0 255 wfx_snw_1d(ji) = wfx_snw_1d(ji) - rhosn * a_i_1d(ji) * zdh_s_mel(ji) * r1_rdtice 256 257 ! updates available heat + thickness 258 zq_su (ji) = MAX( 0._wp , zq_su (ji) + zdh_s_mel(ji) * zqprec(ji) ) 259 ht_s_1d(ji) = MAX( 0._wp , ht_s_1d(ji) + zdh_s_mel(ji) ) 260 zh_s (ji) = ht_s_1d(ji) / REAL( nlay_s ) 261 262 ENDIF 263 END DO 264 265 ! If heat still available, then melt more snow 266 zdeltah(:,:) = 0._wp ! important 238 267 DO jk = 1, nlay_s 239 268 DO ji = kideb, kiut 240 zdeltah (ji,jk) = - zqfont_su(ji) / q_s_b(ji,jk) 241 zqfont_su(ji) = MAX( 0.0 , - zh_s(ji) - zdeltah(ji,jk) ) * q_s_b(ji,jk) 242 zdeltah (ji,jk) = MAX( zdeltah(ji,jk) , - zh_s(ji) ) 243 zdh_s_mel(ji) = zdh_s_mel(ji) + zdeltah(ji,jk) ! resulting melt of snow 269 ! thickness change 270 rswitch = 1._wp - MAX( 0._wp, SIGN( 1._wp, - ht_s_1d(ji) ) ) 271 rswitch = rswitch * ( 1._wp - MAX( 0._wp, SIGN( 1._wp, - q_s_1d(ji,jk) + epsi20 ) ) ) 272 zdeltah (ji,jk) = - rswitch * zq_su(ji) / MAX( q_s_1d(ji,jk), epsi20 ) 273 zdeltah (ji,jk) = MAX( zdeltah(ji,jk) , - zh_s(ji) ) ! bound melting 274 zdh_s_mel(ji) = zdh_s_mel(ji) + zdeltah(ji,jk) 275 ! heat used to melt snow(W.m-2, >0) 276 hfx_snw_1d(ji) = hfx_snw_1d(ji) - zdeltah(ji,jk) * a_i_1d(ji) * q_s_1d(ji,jk) * r1_rdtice 277 ! snow melting only = water into the ocean (then without snow precip) 278 wfx_snw_1d(ji) = wfx_snw_1d(ji) - rhosn * a_i_1d(ji) * zdeltah(ji,jk) * r1_rdtice 279 280 ! updates available heat + thickness 281 zq_su (ji) = MAX( 0._wp , zq_su (ji) + zdeltah(ji,jk) * q_s_1d(ji,jk) ) 282 ht_s_1d(ji) = MAX( 0._wp , ht_s_1d(ji) + zdeltah(ji,jk) ) 283 244 284 END DO 245 285 END DO 246 286 247 ! Apply snow melt to snow depth 248 DO ji = kideb, kiut 249 dh_s_tot(ji) = zdh_s_mel(ji) + zdh_s_pre(ji) 250 ! Old and new snow depths 251 zhsold(ji) = ht_s_b(ji) 252 zhsnew = ht_s_b(ji) + dh_s_tot(ji) 253 ! If snow is still present zhn = 1, else zhn = 0 254 zhn = 1.0 - MAX( zzero , SIGN( zone , - zhsnew ) ) 255 ht_s_b(ji) = MAX( zzero , zhsnew ) 256 ! we recompute dh_s_tot (clem) 257 dh_s_tot (ji) = ht_s_b(ji) - zhsold(ji) 258 ! Volume and mass variations of snow 259 dvsbq_1d (ji) = a_i_b(ji) * ( ht_s_b(ji) - zhsold(ji) - zdh_s_pre(ji) ) 260 dvsbq_1d (ji) = MIN( zzero, dvsbq_1d(ji) ) 261 !clem rdm_snw_1d(ji) = rdm_snw_1d(ji) + rhosn * dvsbq_1d(ji) 287 !---------------------- 288 ! 3.2 Snow sublimation 289 !---------------------- 290 ! qla_ice is always >=0 (upwards), heat goes to the atmosphere, therefore snow sublimates 291 ! clem comment: not counted in mass exchange in limsbc since this is an exchange with atm. (not ocean) 292 ! clem comment: ice should also sublimate 293 IF( lk_cpl ) THEN 294 ! coupled mode: sublimation already included in emp_ice (to do in limsbc_ice) 295 zdh_s_sub(:) = 0._wp 296 ELSE 297 ! forced mode: snow thickness change due to sublimation 298 DO ji = kideb, kiut 299 zdh_s_sub(ji) = MAX( - ht_s_1d(ji) , - parsub * qla_ice_1d(ji) / ( rhosn * lsub ) * rdt_ice ) 300 ! Heat flux by sublimation [W.m-2], < 0 301 ! sublimate first snow that had fallen, then pre-existing snow 302 zcoeff = ( MAX( zdh_s_sub(ji), - MAX( 0._wp, zdh_s_pre(ji) + zdh_s_mel(ji) ) ) * zqprec(ji) + & 303 & ( zdh_s_sub(ji) - MAX( zdh_s_sub(ji), - MAX( 0._wp, zdh_s_pre(ji) + zdh_s_mel(ji) ) ) ) * q_s_1d(ji,1) ) & 304 & * a_i_1d(ji) * r1_rdtice 305 hfx_sub_1d(ji) = hfx_sub_1d(ji) + zcoeff 306 ! Mass flux by sublimation 307 wfx_sub_1d(ji) = wfx_sub_1d(ji) - rhosn * a_i_1d(ji) * zdh_s_sub(ji) * r1_rdtice 308 ! new snow thickness 309 ht_s_1d(ji) = MAX( 0._wp , ht_s_1d(ji) + zdh_s_sub(ji) ) 310 END DO 311 ENDIF 312 313 ! --- Update snow diags --- ! 314 DO ji = kideb, kiut 315 dh_s_tot(ji) = zdh_s_mel(ji) + zdh_s_pre(ji) + zdh_s_sub(ji) 316 zh_s(ji) = ht_s_1d(ji) / REAL( nlay_s ) 262 317 END DO ! ji 263 318 319 !------------------------------------------- 320 ! 3.3 Update temperature, energy 321 !------------------------------------------- 322 ! new temp and enthalpy of the snow (remaining snow precip + remaining pre-existing snow) 323 zq_s(:) = 0._wp 324 DO jk = 1, nlay_s 325 DO ji = kideb,kiut 326 rswitch = MAX( 0._wp , SIGN( 1._wp, - ht_s_1d(ji) + epsi20 ) ) 327 q_s_1d(ji,jk) = ( 1._wp - rswitch ) / MAX( ht_s_1d(ji), epsi20 ) * & 328 & ( ( MAX( 0._wp, dh_s_tot(ji) ) ) * zqprec(ji) + & 329 & ( - MAX( 0._wp, dh_s_tot(ji) ) + ht_s_1d(ji) ) * rhosn * ( cpic * ( rtt - t_s_1d(ji,jk) ) + lfus ) ) 330 zq_s(ji) = zq_s(ji) + q_s_1d(ji,jk) 331 END DO 332 END DO 333 264 334 !-------------------------- 265 ! 3. 2Surface ice ablation335 ! 3.4 Surface ice ablation 266 336 !-------------------------- 267 DO ji = kideb, kiut 268 z_f_surf (ji) = zqfont_su(ji) * r1_rdtice ! heat conservation test 269 zdq_i (ji) = 0._wp 270 END DO ! ji 271 337 zdeltah(:,:) = 0._wp ! important 272 338 DO jk = 1, nlay_i 273 339 DO ji = kideb, kiut 274 ! ! melt of layer jk 275 zdeltah (ji,jk) = - zqfont_su(ji) / q_i_b(ji,jk) 276 ! ! recompute heat available 277 zqfont_su(ji ) = MAX( 0.0 , - zh_i(ji) - zdeltah(ji,jk) ) * q_i_b(ji,jk) 278 ! ! melt of layer jk cannot be higher than its thickness 279 zdeltah (ji,jk) = MAX( zdeltah(ji,jk) , - zh_i(ji) ) 280 ! ! update surface melt 281 dh_i_surf(ji ) = dh_i_surf(ji) + zdeltah(ji,jk) 282 ! ! for energy conservation 283 zdq_i (ji ) = zdq_i(ji) + zdeltah(ji,jk) * q_i_b(ji,jk) * r1_rdtice 284 ! 285 ! clem 286 sfx_thd_1d(ji) = sfx_thd_1d(ji) - sm_i_b(ji) * a_i_b(ji) & 287 & * MIN( zdeltah(ji,jk) , 0._wp ) * rhoic / rdt_ice 340 zEi = - q_i_1d(ji,jk) / rhoic ! Specific enthalpy of layer k [J/kg, <0] 341 342 ztmelts = - tmut * s_i_1d(ji,jk) + rtt ! Melting point of layer k [K] 343 344 zEw = rcp * ( ztmelts - rt0 ) ! Specific enthalpy of resulting meltwater [J/kg, <0] 345 346 zdE = zEi - zEw ! Specific enthalpy difference < 0 347 348 zfmdt = - zq_su(ji) / zdE ! Mass flux to the ocean [kg/m2, >0] 349 350 zdeltah(ji,jk) = - zfmdt / rhoic ! Melt of layer jk [m, <0] 351 352 zdeltah(ji,jk) = MIN( 0._wp , MAX( zdeltah(ji,jk) , - zh_i(ji,jk) ) ) ! Melt of layer jk cannot exceed the layer thickness [m, <0] 353 354 zq_su(ji) = MAX( 0._wp , zq_su(ji) - zdeltah(ji,jk) * rhoic * zdE ) ! update available heat 355 356 dh_i_surf(ji) = dh_i_surf(ji) + zdeltah(ji,jk) ! Cumulate surface melt 357 358 zfmdt = - rhoic * zdeltah(ji,jk) ! Recompute mass flux [kg/m2, >0] 359 360 zQm = zfmdt * zEw ! Energy of the melt water sent to the ocean [J/m2, <0] 361 362 ! Contribution to salt flux (clem: using sm_i_1d and not s_i_1d(jk) is ok) 363 sfx_sum_1d(ji) = sfx_sum_1d(ji) - sm_i_1d(ji) * a_i_1d(ji) * zdeltah(ji,jk) * rhoic * r1_rdtice 364 365 ! Contribution to heat flux [W.m-2], < 0 366 hfx_thd_1d(ji) = hfx_thd_1d(ji) + zfmdt * a_i_1d(ji) * zEw * r1_rdtice 367 368 ! Total heat flux used in this process [W.m-2], > 0 369 hfx_sum_1d(ji) = hfx_sum_1d(ji) - zfmdt * a_i_1d(ji) * zdE * r1_rdtice 370 371 ! Contribution to mass flux 372 wfx_sum_1d(ji) = wfx_sum_1d(ji) - rhoic * a_i_1d(ji) * zdeltah(ji,jk) * r1_rdtice 373 374 ! record which layers have disappeared (for bottom melting) 375 ! => icount=0 : no layer has vanished 376 ! => icount=5 : 5 layers have vanished 377 rswitch = MAX( 0._wp , SIGN( 1._wp , - ( zh_i(ji,jk) + zdeltah(ji,jk) ) ) ) 378 icount(ji) = icount(ji) + NINT( rswitch ) 379 zh_i(ji,jk) = MAX( 0._wp , zh_i(ji,jk) + zdeltah(ji,jk) ) 380 381 ! update heat content (J.m-2) and layer thickness 382 qh_i_old(ji,jk) = qh_i_old(ji,jk) + zdeltah(ji,jk) * q_i_1d(ji,jk) 383 h_i_old (ji,jk) = h_i_old (ji,jk) + zdeltah(ji,jk) 288 384 END DO 289 385 END DO 290 291 ! !------------------- 292 IF( con_i .AND. jiindex_1d > 0 ) THEN ! Conservation test 293 ! !------------------- 294 numce_dh = 0 295 meance_dh = 0._wp 296 DO ji = kideb, kiut 297 IF ( ( z_f_surf(ji) + zdq_i(ji) ) .GE. 1.0e-3 ) THEN 298 numce_dh = numce_dh + 1 299 meance_dh = meance_dh + z_f_surf(ji) + zdq_i(ji) 300 ENDIF 301 IF( z_f_surf(ji) + zdq_i(ji) .GE. 1.0e-3 ) THEN! 302 WRITE(numout,*) ' ALERTE heat loss for surface melt ' 303 WRITE(numout,*) ' ii, ij, jl :', ii, ij, jl 304 WRITE(numout,*) ' ht_i_b : ', ht_i_b(ji) 305 WRITE(numout,*) ' z_f_surf : ', z_f_surf(ji) 306 WRITE(numout,*) ' zdq_i : ', zdq_i(ji) 307 WRITE(numout,*) ' ht_i_b : ', ht_i_b(ji) 308 WRITE(numout,*) ' fc_bo_i : ', fc_bo_i(ji) 309 WRITE(numout,*) ' fbif_1d : ', fbif_1d(ji) 310 WRITE(numout,*) ' qlbbq_1d : ', qlbbq_1d(ji) 311 WRITE(numout,*) ' s_i_new : ', s_i_new(ji) 312 WRITE(numout,*) ' sss_m : ', sss_m(ii,ij) 313 ENDIF 314 END DO 315 ! 316 IF( numce_dh > 0 ) meance_dh = meance_dh / numce_dh 317 WRITE(numout,*) ' Error report - Category : ', jl 318 WRITE(numout,*) ' ~~~~~~~~~~~~ ' 319 WRITE(numout,*) ' Number of points where there is sur. me. error : ', numce_dh 320 WRITE(numout,*) ' Mean basal growth error on error points : ', meance_dh 321 ! 322 ENDIF 323 324 !---------------------- 325 ! 3.3 Snow sublimation 326 !---------------------- 327 328 DO ji = kideb, kiut 329 ! qla_ice is always >=0 (upwards), heat goes to the atmosphere, therefore snow sublimates 330 #if defined key_coupled 331 zdh_s_sub(ji) = 0._wp ! coupled mode: sublimation already included in emp_ice (to do in limsbc_ice) 332 #else 333 ! ! forced mode: snow thickness change due to sublimation 334 zdh_s_sub(ji) = - parsub * qla_ice_1d(ji) / ( rhosn * lsub ) * rdt_ice 335 #endif 336 dh_s_tot (ji) = dh_s_tot(ji) + zdh_s_sub(ji) 337 zdhcf = ht_s_b(ji) + zdh_s_sub(ji) 338 ht_s_b (ji) = MAX( zzero , zdhcf ) 339 ! we recompute dh_s_tot 340 dh_s_tot (ji) = ht_s_b(ji) - zhsold(ji) 341 qt_s_in (ji,jl) = qt_s_in(ji,jl) + zdh_s_sub(ji)*q_s_b(ji,1) 342 END DO 343 344 zqt_dummy(:) = 0.e0 345 DO jk = 1, nlay_s 346 DO ji = kideb,kiut 347 q_s_b (ji,jk) = rhosn * ( cpic * ( rtt - t_s_b(ji,jk) ) + lfus ) 348 zqt_dummy(ji) = zqt_dummy(ji) + q_s_b(ji,jk) * ht_s_b(ji) / REAL( nlay_s ) ! heat conservation 349 END DO 350 END DO 351 352 DO jk = 1, nlay_s 353 DO ji = kideb, kiut 354 ! In case of disparition of the snow, we have to update the snow temperatures 355 zhisn = MAX( zzero , SIGN( zone, - ht_s_b(ji) ) ) 356 t_s_b(ji,jk) = ( 1.0 - zhisn ) * t_s_b(ji,jk) + zhisn * rtt 357 q_s_b(ji,jk) = ( 1.0 - zhisn ) * q_s_b(ji,jk) 358 END DO 386 ! update ice thickness 387 DO ji = kideb, kiut 388 ht_i_1d(ji) = MAX( 0._wp , ht_i_1d(ji) + dh_i_surf(ji) ) 359 389 END DO 360 390 … … 364 394 !------------------------------------------------------------------------------! 365 395 ! 366 ! Ice basal growth / melt is given by the ratio of heat budget over basal 367 ! ice heat content. Basal heat budget is given by the difference between 368 ! the inner conductive flux (fc_bo_i), from the open water heat flux 369 ! (qlbbqb) and the turbulent ocean flux (fbif). 370 ! fc_bo_i is positive downwards. fbif and qlbbq are positive to the ice 371 372 !----------------------------------------------------- 373 ! 4.1 Basal growth - (a) salinity not varying in time 374 !----------------------------------------------------- 375 IF( num_sal /= 2 ) THEN ! ice salinity constant in time 396 !------------------ 397 ! 4.1 Basal growth 398 !------------------ 399 ! Basal growth is driven by heat imbalance at the ice-ocean interface, 400 ! between the inner conductive flux (fc_bo_i), from the open water heat flux 401 ! (fhld) and the turbulent ocean flux (fhtur). 402 ! fc_bo_i is positive downwards. fhtur and fhld are positive to the ice 403 404 ! If salinity varies in time, an iterative procedure is required, because 405 ! the involved quantities are inter-dependent. 406 ! Basal growth (dh_i_bott) depends upon new ice specific enthalpy (zEi), 407 ! which depends on forming ice salinity (s_i_new), which depends on dh/dt (dh_i_bott) 408 ! -> need for an iterative procedure, which converges quickly 409 410 IF ( num_sal == 2 ) THEN 411 num_iter_max = 5 412 ELSE 413 num_iter_max = 1 414 ENDIF 415 416 !clem debug. Just to be sure that enthalpy at nlay_i+1 is null 417 DO ji = kideb, kiut 418 q_i_1d(ji,nlay_i+1) = 0._wp 419 END DO 420 421 ! Iterative procedure 422 DO iter = 1, num_iter_max 376 423 DO ji = kideb, kiut 377 IF( ( fc_bo_i(ji) + fbif_1d(ji) + qlbbq_1d(ji) ) < 0._wp ) THEN 378 s_i_new(ji) = sm_i_b(ji) 379 ! Melting point in K 380 ztmelts = - tmut * s_i_new(ji) + rtt 381 ! New ice heat content (Bitz and Lipscomb, 1999) 382 ztform = t_i_b(ji,nlay_i) ! t_bo_b crashes in the 383 ! Baltic 384 q_i_b(ji,nlay_i+1) = rhoic * ( cpic * ( ztmelts - ztform ) & 385 & + lfus * ( 1.0 - ( ztmelts - rtt ) / ( ztform - rtt ) ) & 386 & - rcp * ( ztmelts - rtt ) ) 387 ! Basal growth rate = - F*dt / q 388 dh_i_bott(ji) = - rdt_ice * ( fc_bo_i(ji) + fbif_1d(ji) + qlbbq_1d(ji) ) / q_i_b(ji,nlay_i+1) 389 sfx_thd_1d(ji) = sfx_thd_1d(ji) - s_i_new(ji) * a_i_b(ji) * dh_i_bott(ji) * rhoic * r1_rdtice 390 ENDIF 391 END DO 392 ENDIF 393 394 !------------------------------------------------- 395 ! 4.1 Basal growth - (b) salinity varying in time 396 !------------------------------------------------- 397 IF( num_sal == 2 ) THEN 398 ! the growth rate (dh_i_bott) is function of the new ice heat content (q_i_b(nlay_i+1)). 399 ! q_i_b depends on the new ice salinity (snewice). 400 ! snewice depends on dh_i_bott ; it converges quickly, so, no problem 401 ! See Vancoppenolle et al., OM08 for more info on this 402 403 ! Initial value (tested 1D, can be anything between 1 and 20) 404 num_iter_max = 4 405 s_i_new(:) = 4.0 406 407 ! Iterative procedure 408 DO iter = 1, num_iter_max 409 DO ji = kideb, kiut 410 IF( fc_bo_i(ji) + fbif_1d(ji) + qlbbq_1d(ji) < 0.e0 ) THEN 411 ii = MOD( npb(ji) - 1, jpi ) + 1 412 ij = ( npb(ji) - 1 ) / jpi + 1 413 ! Melting point in K 414 ztmelts = - tmut * s_i_new(ji) + rtt 415 ! New ice heat content (Bitz and Lipscomb, 1999) 416 q_i_b(ji,nlay_i+1) = rhoic * ( cpic * ( ztmelts - t_bo_b(ji) ) & 417 & + lfus * ( 1.0 - ( ztmelts - rtt ) / ( t_bo_b(ji) - rtt ) ) & 418 & - rcp * ( ztmelts-rtt ) ) 419 ! Bottom growth rate = - F*dt / q 420 dh_i_bott(ji) = - rdt_ice * ( fc_bo_i(ji) + fbif_1d(ji) + qlbbq_1d(ji) ) / q_i_b(ji,nlay_i+1) 421 ! New ice salinity ( Cox and Weeks, JGR, 1988 ) 422 ! zswi2 (1) if dh_i_bott/rdt .GT. 3.6e-7 423 ! zswi12 (1) if dh_i_bott/rdt .LT. 3.6e-7 and .GT. 2.0e-8 424 ! zswi1 (1) if dh_i_bott/rdt .LT. 2.0e-8 425 zgrr = MIN( 1.0e-3, MAX ( dh_i_bott(ji) * r1_rdtice , epsi13 ) ) 426 zswi2 = MAX( zzero , SIGN( zone , zgrr - 3.6e-7 ) ) 427 zswi12 = MAX( zzero , SIGN( zone , zgrr - 2.0e-8 ) ) * ( 1.0 - zswi2 ) 428 zswi1 = 1. - zswi2 * zswi12 429 zfracs = zswi1 * 0.12 + zswi12 * ( 0.8925 + 0.0568 * LOG( 100.0 * zgrr ) ) & 430 & + zswi2 * 0.26 / ( 0.26 + 0.74 * EXP ( - 724300.0 * zgrr ) ) 431 zfracs = MIN( 0.5 , zfracs ) 432 s_i_new(ji) = zfracs * sss_m(ii,ij) 433 ENDIF ! fc_bo_i 434 END DO ! ji 435 END DO ! iter 436 437 ! Final values 438 DO ji = kideb, kiut 439 IF( ( fc_bo_i(ji) + fbif_1d(ji) + qlbbq_1d(ji) ) .LT. 0.0 ) THEN 440 ! New ice salinity must not exceed 20 psu 441 s_i_new(ji) = MIN( s_i_new(ji), s_i_max ) 442 ! Metling point in K 443 ztmelts = - tmut * s_i_new(ji) + rtt 444 ! New ice heat content (Bitz and Lipscomb, 1999) 445 q_i_b(ji,nlay_i+1) = rhoic * ( cpic * ( ztmelts - t_bo_b(ji) ) & 446 & + lfus * ( 1.0 - ( ztmelts - rtt ) / ( t_bo_b(ji) - rtt ) ) & 447 & - rcp * ( ztmelts - rtt ) ) 448 ! Basal growth rate = - F*dt / q 449 dh_i_bott(ji) = - rdt_ice * ( fc_bo_i(ji) + fbif_1d(ji) + qlbbq_1d(ji) ) / q_i_b(ji,nlay_i+1) 450 ! Salinity update 451 ! entrapment during bottom growth 452 sfx_thd_1d(ji) = sfx_thd_1d(ji) - s_i_new(ji) * a_i_b(ji) * dh_i_bott(ji) * rhoic * r1_rdtice 453 ENDIF ! heat budget 454 END DO 455 ENDIF 424 IF( zf_tt(ji) < 0._wp ) THEN 425 426 ! New bottom ice salinity (Cox & Weeks, JGR88 ) 427 !--- zswi1 if dh/dt < 2.0e-8 428 !--- zswi12 if 2.0e-8 < dh/dt < 3.6e-7 429 !--- zswi2 if dh/dt > 3.6e-7 430 zgrr = MIN( 1.0e-3, MAX ( dh_i_bott(ji) * r1_rdtice , epsi10 ) ) 431 zswi2 = MAX( 0._wp , SIGN( 1._wp , zgrr - 3.6e-7 ) ) 432 zswi12 = MAX( 0._wp , SIGN( 1._wp , zgrr - 2.0e-8 ) ) * ( 1.0 - zswi2 ) 433 zswi1 = 1. - zswi2 * zswi12 434 zfracs = MIN ( zswi1 * 0.12 + zswi12 * ( 0.8925 + 0.0568 * LOG( 100.0 * zgrr ) ) & 435 & + zswi2 * 0.26 / ( 0.26 + 0.74 * EXP ( - 724300.0 * zgrr ) ) , 0.5 ) 436 437 ii = MOD( npb(ji) - 1, jpi ) + 1 ; ij = ( npb(ji) - 1 ) / jpi + 1 438 439 s_i_new(ji) = zswitch_sal * zfracs * sss_m(ii,ij) & ! New ice salinity 440 + ( 1. - zswitch_sal ) * sm_i_1d(ji) 441 ! New ice growth 442 ztmelts = - tmut * s_i_new(ji) + rtt ! New ice melting point (K) 443 444 zt_i_new = zswitch_sal * t_bo_1d(ji) + ( 1. - zswitch_sal) * t_i_1d(ji, nlay_i) 445 446 zEi = cpic * ( zt_i_new - ztmelts ) & ! Specific enthalpy of forming ice (J/kg, <0) 447 & - lfus * ( 1.0 - ( ztmelts - rtt ) / ( zt_i_new - rtt ) ) & 448 & + rcp * ( ztmelts-rtt ) 449 450 zEw = rcp * ( t_bo_1d(ji) - rt0 ) ! Specific enthalpy of seawater (J/kg, < 0) 451 452 zdE = zEi - zEw ! Specific enthalpy difference (J/kg, <0) 453 454 dh_i_bott(ji) = rdt_ice * MAX( 0._wp , zf_tt(ji) / ( zdE * rhoic ) ) 455 456 q_i_1d(ji,nlay_i+1) = -zEi * rhoic ! New ice energy of melting (J/m3, >0) 457 458 ENDIF ! fc_bo_i 459 END DO ! ji 460 END DO ! iter 461 462 ! Contribution to Energy and Salt Fluxes 463 DO ji = kideb, kiut 464 IF( zf_tt(ji) < 0._wp ) THEN 465 ! New ice growth 466 467 zfmdt = - rhoic * dh_i_bott(ji) ! Mass flux x time step (kg/m2, < 0) 468 469 ztmelts = - tmut * s_i_new(ji) + rtt ! New ice melting point (K) 470 471 zt_i_new = zswitch_sal * t_bo_1d(ji) + ( 1. - zswitch_sal) * t_i_1d(ji, nlay_i) 472 473 zEi = cpic * ( zt_i_new - ztmelts ) & ! Specific enthalpy of forming ice (J/kg, <0) 474 & - lfus * ( 1.0 - ( ztmelts - rtt ) / ( zt_i_new - rtt ) ) & 475 & + rcp * ( ztmelts-rtt ) 476 477 zEw = rcp * ( t_bo_1d(ji) - rt0 ) ! Specific enthalpy of seawater (J/kg, < 0) 478 479 zdE = zEi - zEw ! Specific enthalpy difference (J/kg, <0) 480 481 ! Contribution to heat flux to the ocean [W.m-2], >0 482 hfx_thd_1d(ji) = hfx_thd_1d(ji) + zfmdt * a_i_1d(ji) * zEw * r1_rdtice 483 484 ! Total heat flux used in this process [W.m-2], <0 485 hfx_bog_1d(ji) = hfx_bog_1d(ji) - zfmdt * a_i_1d(ji) * zdE * r1_rdtice 486 487 ! Contribution to salt flux, <0 488 sfx_bog_1d(ji) = sfx_bog_1d(ji) + s_i_new(ji) * a_i_1d(ji) * zfmdt * r1_rdtice 489 490 ! Contribution to mass flux, <0 491 wfx_bog_1d(ji) = wfx_bog_1d(ji) - rhoic * a_i_1d(ji) * dh_i_bott(ji) * r1_rdtice 492 493 ! update heat content (J.m-2) and layer thickness 494 qh_i_old(ji,nlay_i+1) = qh_i_old(ji,nlay_i+1) + dh_i_bott(ji) * q_i_1d(ji,nlay_i+1) 495 h_i_old (ji,nlay_i+1) = h_i_old (ji,nlay_i+1) + dh_i_bott(ji) 496 ENDIF 497 END DO 456 498 457 499 !---------------- 458 500 ! 4.2 Basal melt 459 501 !---------------- 460 meance_dh = 0._wp 461 numce_dh = 0 462 zinnermelt(:) = 0._wp 463 464 DO ji = kideb, kiut 465 ! heat convergence at the surface > 0 466 IF( ( fc_bo_i(ji) + fbif_1d(ji) + qlbbq_1d(ji) ) >= 0._wp ) THEN 467 s_i_new(ji) = s_i_b(ji,nlay_i) 468 zqfont_bo(ji) = rdt_ice * ( fc_bo_i(ji) + fbif_1d(ji) + qlbbq_1d(ji) ) 469 zfbase(ji) = zqfont_bo(ji) * r1_rdtice ! heat conservation test 470 zdq_i(ji) = 0._wp 471 dh_i_bott(ji) = 0._wp 472 ENDIF 473 END DO 474 502 zdeltah(:,:) = 0._wp ! important 475 503 DO jk = nlay_i, 1, -1 476 504 DO ji = kideb, kiut 477 IF( fc_bo_i(ji) + fbif_1d(ji) + qlbbq_1d(ji) >= 0._wp ) THEN 478 ztmelts = - tmut * s_i_b(ji,jk) + rtt 479 IF( t_i_b(ji,jk) >= ztmelts ) THEN !!gm : a comment is needed 480 zdeltah (ji,jk) = - zh_i(ji) 481 dh_i_bott (ji ) = dh_i_bott(ji) + zdeltah(ji,jk) 482 zinnermelt(ji ) = 1._wp 483 ELSE ! normal ablation 484 zdeltah (ji,jk) = - zqfont_bo(ji) / q_i_b(ji,jk) 485 zqfont_bo(ji ) = MAX( 0.0 , - zh_i(ji) - zdeltah(ji,jk) ) * q_i_b(ji,jk) 486 zdeltah (ji,jk) = MAX(zdeltah(ji,jk), - zh_i(ji) ) 487 dh_i_bott(ji ) = dh_i_bott(ji) + zdeltah(ji,jk) 488 zdq_i (ji ) = zdq_i(ji) + zdeltah(ji,jk) * q_i_b(ji,jk) * r1_rdtice 505 IF( zf_tt(ji) >= 0._wp .AND. jk > icount(ji) ) THEN ! do not calculate where layer has already disappeared from surface melting 506 507 ztmelts = - tmut * s_i_1d(ji,jk) + rtt ! Melting point of layer jk (K) 508 509 IF( t_i_1d(ji,jk) >= ztmelts ) THEN !!! Internal melting 510 511 zEi = - q_i_1d(ji,jk) / rhoic ! Specific enthalpy of melting ice (J/kg, <0) 512 513 !!zEw = rcp * ( t_i_1d(ji,jk) - rtt ) ! Specific enthalpy of meltwater at T = t_i_1d (J/kg, <0) 514 515 zdE = 0._wp ! Specific enthalpy difference (J/kg, <0) 516 ! set up at 0 since no energy is needed to melt water...(it is already melted) 517 518 zdeltah (ji,jk) = MIN( 0._wp , - zh_i(ji,jk) ) ! internal melting occurs when the internal temperature is above freezing 519 ! this should normally not happen, but sometimes, heat diffusion leads to this 520 521 dh_i_bott (ji) = dh_i_bott(ji) + zdeltah(ji,jk) 522 523 zfmdt = - zdeltah(ji,jk) * rhoic ! Mass flux x time step > 0 524 525 ! Contribution to heat flux to the ocean [W.m-2], <0 (ice enthalpy zEi is "sent" to the ocean) 526 hfx_res_1d(ji) = hfx_res_1d(ji) + zfmdt * a_i_1d(ji) * zEi * r1_rdtice 527 528 ! Contribution to salt flux (clem: using sm_i_1d and not s_i_1d(jk) is ok) 529 sfx_res_1d(ji) = sfx_res_1d(ji) - sm_i_1d(ji) * a_i_1d(ji) * zdeltah(ji,jk) * rhoic * r1_rdtice 530 531 ! Contribution to mass flux 532 wfx_res_1d(ji) = wfx_res_1d(ji) - rhoic * a_i_1d(ji) * zdeltah(ji,jk) * r1_rdtice 533 534 ! update heat content (J.m-2) and layer thickness 535 qh_i_old(ji,jk) = qh_i_old(ji,jk) + zdeltah(ji,jk) * q_i_1d(ji,jk) 536 h_i_old (ji,jk) = h_i_old (ji,jk) + zdeltah(ji,jk) 537 538 ELSE !!! Basal melting 539 540 zEi = - q_i_1d(ji,jk) / rhoic ! Specific enthalpy of melting ice (J/kg, <0) 541 542 zEw = rcp * ( ztmelts - rtt )! Specific enthalpy of meltwater (J/kg, <0) 543 544 zdE = zEi - zEw ! Specific enthalpy difference (J/kg, <0) 545 546 zfmdt = - zq_bo(ji) / zdE ! Mass flux x time step (kg/m2, >0) 547 548 zdeltah(ji,jk) = - zfmdt / rhoic ! Gross thickness change 549 550 zdeltah(ji,jk) = MIN( 0._wp , MAX( zdeltah(ji,jk), - zh_i(ji,jk) ) ) ! bound thickness change 551 552 zq_bo(ji) = MAX( 0._wp , zq_bo(ji) - zdeltah(ji,jk) * rhoic * zdE ) ! update available heat. MAX is necessary for roundup errors 553 554 dh_i_bott(ji) = dh_i_bott(ji) + zdeltah(ji,jk) ! Update basal melt 555 556 zfmdt = - zdeltah(ji,jk) * rhoic ! Mass flux x time step > 0 557 558 zQm = zfmdt * zEw ! Heat exchanged with ocean 559 560 ! Contribution to heat flux to the ocean [W.m-2], <0 561 hfx_thd_1d(ji) = hfx_thd_1d(ji) + zfmdt * a_i_1d(ji) * zEw * r1_rdtice 562 563 ! Contribution to salt flux (clem: using sm_i_1d and not s_i_1d(jk) is ok) 564 sfx_bom_1d(ji) = sfx_bom_1d(ji) - sm_i_1d(ji) * a_i_1d(ji) * zdeltah(ji,jk) * rhoic * r1_rdtice 565 566 ! Total heat flux used in this process [W.m-2], >0 567 hfx_bom_1d(ji) = hfx_bom_1d(ji) - zfmdt * a_i_1d(ji) * zdE * r1_rdtice 568 569 ! Contribution to mass flux 570 wfx_bom_1d(ji) = wfx_bom_1d(ji) - rhoic * a_i_1d(ji) * zdeltah(ji,jk) * r1_rdtice 571 572 ! update heat content (J.m-2) and layer thickness 573 qh_i_old(ji,jk) = qh_i_old(ji,jk) + zdeltah(ji,jk) * q_i_1d(ji,jk) 574 h_i_old (ji,jk) = h_i_old (ji,jk) + zdeltah(ji,jk) 489 575 ENDIF 490 ! clem: contribution to salt flux 491 sfx_thd_1d(ji) = sfx_thd_1d(ji) - sm_i_b(ji) * a_i_b(ji) & 492 & * MIN( zdeltah(ji,jk) , 0._wp ) * rhoic * r1_rdtice 576 493 577 ENDIF 494 578 END DO ! ji 495 579 END DO ! jk 496 580 497 ! !-------------------498 IF( con_i .AND. jiindex_1d > 0 ) THEN ! Conservation test499 ! !-------------------500 DO ji = kideb, kiut501 IF( ( fc_bo_i(ji) + fbif_1d(ji) + qlbbq_1d(ji) ) >= 0.e0 ) THEN502 IF( ( zfbase(ji) + zdq_i(ji) ) >= 1.e-3 ) THEN503 numce_dh = numce_dh + 1504 meance_dh = meance_dh + zfbase(ji) + zdq_i(ji)505 ENDIF506 IF ( zfbase(ji) + zdq_i(ji) .GE. 1.0e-3 ) THEN507 WRITE(numout,*) ' ALERTE heat loss for basal melt : ii, ij, jl :', ii, ij, jl508 WRITE(numout,*) ' ht_i_b : ', ht_i_b(ji)509 WRITE(numout,*) ' zfbase : ', zfbase(ji)510 WRITE(numout,*) ' zdq_i : ', zdq_i(ji)511 WRITE(numout,*) ' ht_i_b : ', ht_i_b(ji)512 WRITE(numout,*) ' fc_bo_i : ', fc_bo_i(ji)513 WRITE(numout,*) ' fbif_1d : ', fbif_1d(ji)514 WRITE(numout,*) ' qlbbq_1d : ', qlbbq_1d(ji)515 WRITE(numout,*) ' s_i_new : ', s_i_new(ji)516 WRITE(numout,*) ' sss_m : ', sss_m(ii,ij)517 WRITE(numout,*) ' dh_i_bott : ', dh_i_bott(ji)518 WRITE(numout,*) ' innermelt : ', INT( zinnermelt(ji) )519 ENDIF520 ENDIF521 END DO522 IF( numce_dh > 0 ) meance_dh = meance_dh / numce_dh523 WRITE(numout,*) ' Number of points where there is bas. me. error : ', numce_dh524 WRITE(numout,*) ' Mean basal melt error on error points : ', meance_dh525 WRITE(numout,*) ' Remaining bottom heat : ', zqfont_bo(jiindex_1d)526 !527 ENDIF528 529 !530 581 !------------------------------------------------------------------------------! 531 ! 5) Pathological cases ! 582 ! Excessive ablation in a 1-category model 583 ! in a 1-category sea ice model, bottom ablation must not exceed hmelt (-0.15) 532 584 !------------------------------------------------------------------------------! 533 ! 534 !---------------------------------------------- 535 ! 5.1 Excessive ablation in a 1-category model 536 !---------------------------------------------- 537 538 DO ji = kideb, kiut 539 ! ! in a 1-category sea ice model, bottom ablation must not exceed hmelt (-0.15) 540 IF( jpl == 1 ) THEN ; zdhbf = MAX( hmelt , dh_i_bott(ji) ) 541 ELSE ; zdhbf = dh_i_bott(ji) 542 ENDIF 543 zdvres = zdhbf - dh_i_bott(ji) 544 dh_i_bott(ji) = zdhbf 545 sfx_thd_1d(ji) = sfx_thd_1d(ji) - sm_i_b(ji) * a_i_b(ji) * zdvres * rhoic * r1_rdtice 546 ! ! excessive energy is sent to lateral ablation 547 zinda = MAX( 0._wp, SIGN( 1._wp , 1.0 - at_i_b(ji) - epsi10 ) ) 548 fsup(ji) = zinda * rhoic * lfus * at_i_b(ji) / MAX( 1.0 - at_i_b(ji) , epsi10 ) * zdvres * r1_rdtice 549 END DO 550 551 !----------------------------------- 552 ! 5.2 More than available ice melts 553 !----------------------------------- 554 ! then heat applied minus heat content at previous time step should equal heat remaining 555 ! 556 DO ji = kideb, kiut 557 ! Adapt the remaining energy if too much ice melts 558 !-------------------------------------------------- 559 zdvres = MAX( 0._wp, - ht_i_b(ji) - dh_i_surf(ji) - dh_i_bott(ji) ) 560 zdvsur = MIN( 0._wp, dh_i_surf(ji) + zdvres ) - dh_i_surf(ji) ! fill the surface first 561 zdvbot = MAX( 0._wp, zdvres - zdvsur ) ! then the bottom 562 dh_i_surf (ji) = dh_i_surf(ji) + zdvsur ! clem 563 dh_i_bott (ji) = dh_i_bott(ji) + zdvbot ! clem 564 565 ! new ice thickness (clem) 566 zhgnew(ji) = ht_i_b(ji) + dh_i_surf(ji) + dh_i_bott(ji) 567 zihgnew = 1.0 - MAX( zzero , SIGN( zone , - zhgnew(ji) ) ) !1 if ice 568 zhgnew(ji) = zihgnew * zhgnew(ji) ! ice thickness is put to 0 569 570 ! !since ice volume is only used for outputs, we keep it global for all categories 571 dvbbq_1d (ji) = a_i_b(ji) * dh_i_bott(ji) 572 573 ! remaining heat 574 zfdt_final(ji) = ( 1.0 - zihgnew ) * ( zqfont_su(ji) + zqfont_bo(ji) ) 575 576 ! If snow remains, energy is used to melt snow 577 zhni = ht_s_b(ji) ! snow depth at previous time step 578 zihg = MAX( zzero , SIGN ( zone , - ht_s_b(ji) ) ) ! =0 if snow 579 580 ! energy of melting of remaining snow 581 zinda = MAX( 0._wp, SIGN( 1._wp , zhni - epsi10 ) ) 582 zqt_s(ji) = ( 1. - zihg ) * zqt_s(ji) / MAX( zhni, epsi10 ) * zinda 583 zdhnm = - ( 1. - zihg ) * ( 1. - zihgnew ) * zfdt_final(ji) / MAX( zqt_s(ji) , epsi13 ) 584 zhnfi = zhni + zdhnm 585 zfdt_final(ji) = MAX( zfdt_final(ji) + zqt_s(ji) * zdhnm , 0.0 ) 586 ht_s_b(ji) = MAX( zzero , zhnfi ) 587 zqt_s(ji) = zqt_s(ji) * ht_s_b(ji) 588 ! we recompute dh_s_tot (clem) 589 dh_s_tot (ji) = ht_s_b(ji) - zhsold(ji) 590 591 ! Mass variations of ice and snow 592 !--------------------------------- 593 ! ! mass variation of the jl category 594 zzfmass_s = - a_i_b(ji) * ( zhni - ht_s_b(ji) ) * rhosn ! snow 595 zzfmass_i = a_i_b(ji) * ( zhgnew(ji) - ht_i_b(ji) ) * rhoic ! ice 596 ! 597 zfmass_i(ji) = zzfmass_i ! ice variation saved to compute salt flux (see below) 598 ! 599 ! ! mass variation cumulated over category 600 !clem rdm_snw_1d(ji) = rdm_snw_1d(ji) + zzfmass_s ! snow 601 !clem rdm_ice_1d(ji) = rdm_ice_1d(ji) + zzfmass_i ! ice 602 603 ! Remaining heat to the ocean 604 !--------------------------------- 605 focea(ji) = - zfdt_final(ji) * r1_rdtice ! focea is in W.m-2 * dt 606 607 ! residual salt flux (clem) 608 !-------------------------- 609 ! surface 610 sfx_thd_1d(ji) = sfx_thd_1d(ji) - sm_i_b(ji) * a_i_b(ji) * zdvsur * rhoic * r1_rdtice 611 ! bottom 612 IF ( fc_bo_i(ji) + fbif_1d(ji) + qlbbq_1d(ji) >= 0._wp ) THEN ! melting 613 sfx_thd_1d(ji) = sfx_thd_1d(ji) - sm_i_b(ji) * a_i_b(ji) * zdvbot * rhoic * r1_rdtice 614 ELSE ! growth 615 sfx_thd_1d(ji) = sfx_thd_1d(ji) - s_i_new(ji) * a_i_b(ji) * zdvbot * rhoic * r1_rdtice 616 ENDIF 617 ! 618 ! diagnostic 619 ii = MOD( npb(ji) - 1, jpi ) + 1 620 ij = ( npb(ji) - 1 ) / jpi + 1 621 diag_bot_gr(ii,ij) = diag_bot_gr(ii,ij) + MAX(dh_i_bott(ji),0.0)*a_i_b(ji) * r1_rdtice 622 diag_sur_me(ii,ij) = diag_sur_me(ii,ij) + MIN(dh_i_surf(ji),0.0)*a_i_b(ji) * r1_rdtice 623 diag_bot_me(ii,ij) = diag_bot_me(ii,ij) + MIN(dh_i_bott(ji),0.0)*a_i_b(ji) * r1_rdtice 624 END DO 625 626 ftotal_fin (:) = zfdt_final(:) * r1_rdtice 627 628 !--------------------------- 629 ! heat fluxes 630 !--------------------------- 631 DO ji = kideb, kiut 632 zihgnew = 1.0 - MAX( zzero , SIGN( zone , - zhgnew(ji) ) ) ! =1 if ice 633 ! 634 ! Heat flux 635 ! excessive bottom ablation energy (fsup) - 0 except if jpl = 1 636 ! excessive total ablation energy (focea) sent to the ocean 637 qfvbq_1d(ji) = qfvbq_1d(ji) + fsup(ji) + ( 1.0 - zihgnew ) * focea(ji) * a_i_b(ji) * rdt_ice 638 639 zihic = 1.0 - MAX( zzero , SIGN( zone , -ht_i_b(ji) ) ) ! equals 0 if ht_i = 0, 1 if ht_i gt 0 640 fscbq_1d(ji) = a_i_b(ji) * fstbif_1d(ji) 641 qldif_1d(ji) = qldif_1d(ji) + fsup(ji) + ( 1.0 - zihgnew ) * focea (ji) * a_i_b(ji) * rdt_ice & 642 & + ( 1.0 - zihic ) * fscbq_1d(ji) * rdt_ice 643 END DO ! ji 644 645 !------------------------------------------- 646 ! Correct temperature, energy and thickness 647 !------------------------------------------- 648 DO ji = kideb, kiut 649 zihgnew = 1.0 - MAX( zzero , SIGN( zone , - zhgnew(ji) ) ) 650 t_su_b(ji) = zihgnew * t_su_b(ji) + ( 1.0 - zihgnew ) * rtt 651 END DO ! ji 652 653 DO jk = 1, nlay_i 654 DO ji = kideb, kiut 655 zihgnew = 1.0 - MAX( zzero , SIGN( zone , - zhgnew(ji) ) ) 656 t_i_b(ji,jk) = zihgnew * t_i_b(ji,jk) + ( 1.0 - zihgnew ) * rtt 657 q_i_b(ji,jk) = zihgnew * q_i_b(ji,jk) 658 END DO 659 END DO ! ji 660 661 DO ji = kideb, kiut 662 ht_i_b(ji) = zhgnew(ji) 663 END DO ! ji 585 ! ??? keep ??? 586 ! clem bug: I think this should be included above, so we would not have to 587 ! track heat/salt/mass fluxes backwards 588 ! IF( jpl == 1 ) THEN 589 ! DO ji = kideb, kiut 590 ! IF( zf_tt(ji) >= 0._wp ) THEN 591 ! zdh = MAX( hmelt , dh_i_bott(ji) ) 592 ! zdvres = zdh - dh_i_bott(ji) ! >=0 593 ! dh_i_bott(ji) = zdh 594 ! 595 ! ! excessive energy is sent to lateral ablation 596 ! rswitch = MAX( 0._wp, SIGN( 1._wp , 1._wp - at_i_1d(ji) - epsi20 ) ) 597 ! zq_1cat(ji) = rswitch * rhoic * lfus * at_i_1d(ji) / MAX( 1._wp - at_i_1d(ji) , epsi20 ) * zdvres ! J.m-2 >=0 598 ! 599 ! ! correct salt and mass fluxes 600 ! sfx_bom_1d(ji) = sfx_bom_1d(ji) - sm_i_1d(ji) * a_i_1d(ji) * zdvres * rhoic * r1_rdtice ! this is only a raw approximation 601 ! wfx_bom_1d(ji) = wfx_bom_1d(ji) - rhoic * a_i_1d(ji) * zdvres * r1_rdtice 602 ! ENDIF 603 ! END DO 604 ! ENDIF 605 606 !------------------------------------------- 607 ! Update temperature, energy 608 !------------------------------------------- 609 DO ji = kideb, kiut 610 ht_i_1d(ji) = MAX( 0._wp , ht_i_1d(ji) + dh_i_bott(ji) ) 611 END DO 612 613 !------------------------------------------- 614 ! 5. What to do with remaining energy 615 !------------------------------------------- 616 ! If heat still available for melting and snow remains, then melt more snow 617 !------------------------------------------- 618 zdeltah(:,:) = 0._wp ! important 619 DO ji = kideb, kiut 620 zq_rema(ji) = zq_su(ji) + zq_bo(ji) 621 ! zindh = 1._wp - MAX( 0._wp, SIGN( 1._wp, - ht_s_1d(ji) ) ) ! =1 if snow 622 ! zindq = 1._wp - MAX( 0._wp, SIGN( 1._wp, - zq_s(ji) + epsi20 ) ) 623 ! zdeltah (ji,1) = - zindh * zindq * zq_rema(ji) / MAX( zq_s(ji), epsi20 ) 624 ! zdeltah (ji,1) = MIN( 0._wp , MAX( zdeltah(ji,1) , - ht_s_1d(ji) ) ) ! bound melting 625 ! zdh_s_mel(ji) = zdh_s_mel(ji) + zdeltah(ji,1) 626 ! dh_s_tot (ji) = dh_s_tot(ji) + zdeltah(ji,1) 627 ! ht_s_1d (ji) = ht_s_1d(ji) + zdeltah(ji,1) 628 ! 629 ! zq_rema(ji) = zq_rema(ji) + zdeltah(ji,1) * zq_s(ji) ! update available heat (J.m-2) 630 ! ! heat used to melt snow 631 ! hfx_snw_1d(ji) = hfx_snw_1d(ji) - zdeltah(ji,1) * a_i_1d(ji) * zq_s(ji) * r1_rdtice ! W.m-2 (>0) 632 ! ! Contribution to mass flux 633 ! wfx_snw_1d(ji) = wfx_snw_1d(ji) - rhosn * a_i_1d(ji) * zdeltah(ji,1) * r1_rdtice 634 ! 635 ii = MOD( npb(ji) - 1, jpi ) + 1 ; ij = ( npb(ji) - 1 ) / jpi + 1 636 ! Remaining heat flux (W.m-2) is sent to the ocean heat budget 637 hfx_out(ii,ij) = hfx_out(ii,ij) + ( zq_1cat(ji) + zq_rema(ji) * a_i_1d(ji) ) * r1_rdtice 638 639 IF( ln_nicep .AND. zq_rema(ji) < 0. .AND. lwp ) WRITE(numout,*) 'ALERTE zq_rema <0 = ', zq_rema(ji) 640 END DO 641 664 642 ! 665 643 !------------------------------------------------------------------------------| … … 670 648 DO ji = kideb, kiut 671 649 ! 672 dh_snowice(ji) = MAX( zzero , ( rhosn * ht_s_b(ji) + (rhoic-rau0) * ht_i_b(ji) ) / ( rhosn+rau0-rhoic ) ) 673 zhgnew(ji) = MAX( zhgnew(ji) , zhgnew(ji) + dh_snowice(ji) ) 674 zhnnew = MIN( ht_s_b(ji) , ht_s_b(ji) - dh_snowice(ji) ) 675 676 ! Changes in ice volume and ice mass. 677 dvnbq_1d (ji) = a_i_b(ji) * ( zhgnew(ji)-ht_i_b(ji) ) 678 dmgwi_1d (ji) = dmgwi_1d(ji) + a_i_b(ji) * ( ht_s_b(ji) - zhnnew ) * rhosn 679 680 !clem rdm_ice_1d(ji) = rdm_ice_1d(ji) + a_i_b(ji) * ( zhgnew(ji) - ht_i_b(ji) ) * rhoic 681 !clem rdm_snw_1d(ji) = rdm_snw_1d(ji) + a_i_b(ji) * ( zhnnew - ht_s_b(ji) ) * rhosn 682 683 ! Equivalent salt flux (1) Snow-ice formation component 684 ! ----------------------------------------------------- 685 ii = MOD( npb(ji) - 1, jpi ) + 1 686 ij = ( npb(ji) - 1 ) / jpi + 1 687 688 IF( num_sal == 2 ) THEN ; zsm_snowice = sss_m(ii,ij) * ( rhoic - rhosn ) / rhoic 689 ELSE ; zsm_snowice = sm_i_b(ji) 690 ENDIF 650 dh_snowice(ji) = MAX( 0._wp , ( rhosn * ht_s_1d(ji) + (rhoic-rau0) * ht_i_1d(ji) ) / ( rhosn+rau0-rhoic ) ) 651 652 ht_i_1d(ji) = ht_i_1d(ji) + dh_snowice(ji) 653 ht_s_1d(ji) = ht_s_1d(ji) - dh_snowice(ji) 654 655 ! Salinity of snow ice 656 ii = MOD( npb(ji) - 1, jpi ) + 1 ; ij = ( npb(ji) - 1 ) / jpi + 1 657 zs_snic = zswitch_sal * sss_m(ii,ij) * ( rhoic - rhosn ) / rhoic + ( 1. - zswitch_sal ) * sm_i_1d(ji) 658 691 659 ! entrapment during snow ice formation 692 ! clem:new salinity difference stored (to be used in limthd_ent.F90)660 ! new salinity difference stored (to be used in limthd_ent.F90) 693 661 IF ( num_sal == 2 ) THEN 694 i_ice_switch = MAX( 0._wp , SIGN( 1._wp , zhgnew(ji) - epsi10 ) )662 rswitch = MAX( 0._wp , SIGN( 1._wp , ht_i_1d(ji) - epsi10 ) ) 695 663 ! salinity dif due to snow-ice formation 696 dsm_i_si_1d(ji) = ( zs m_snowice - sm_i_b(ji) ) * dh_snowice(ji) / MAX( zhgnew(ji), epsi10 ) * i_ice_switch664 dsm_i_si_1d(ji) = ( zs_snic - sm_i_1d(ji) ) * dh_snowice(ji) / MAX( ht_i_1d(ji), epsi10 ) * rswitch 697 665 ! salinity dif due to bottom growth 698 IF ( fc_bo_i(ji) + fbif_1d(ji) + qlbbq_1d(ji) < 0._wp ) THEN699 dsm_i_se_1d(ji) = ( s_i_new(ji) - sm_i_ b(ji) ) * dh_i_bott(ji) / MAX( zhgnew(ji), epsi10 ) * i_ice_switch666 IF ( zf_tt(ji) < 0._wp ) THEN 667 dsm_i_se_1d(ji) = ( s_i_new(ji) - sm_i_1d(ji) ) * dh_i_bott(ji) / MAX( ht_i_1d(ji), epsi10 ) * rswitch 700 668 ENDIF 701 669 ENDIF 702 670 703 ! Actualize new snow and ice thickness. 704 ht_s_b(ji) = zhnnew 705 ht_i_b(ji) = zhgnew(ji) 706 707 ! Total ablation ! new lines added to debug 708 IF( ht_i_b(ji) <= 0._wp ) a_i_b(ji) = 0._wp 709 710 ! diagnostic ( snow ice growth ) 711 ii = MOD( npb(ji) - 1, jpi ) + 1 712 ij = ( npb(ji) - 1 ) / jpi + 1 713 diag_sni_gr(ii,ij) = diag_sni_gr(ii,ij) + dh_snowice(ji)*a_i_b(ji) * r1_rdtice 714 ! 715 ! salt flux 716 sfx_thd_1d(ji) = sfx_thd_1d(ji) - zsm_snowice * a_i_b(ji) * dh_snowice(ji) * rhoic * r1_rdtice 717 !-------------------------------- 718 ! Update mass fluxes (clem) 719 !-------------------------------- 720 rdm_ice_1d(ji) = rdm_ice_1d(ji) + ( a_i_b(ji) * ht_i_b(ji) - zviold(ji) ) * rhoic 721 rdm_snw_1d(ji) = rdm_snw_1d(ji) + ( a_i_b(ji) * ht_s_b(ji) - zvsold(ji) ) * rhosn 671 ! Contribution to energy flux to the ocean [J/m2], >0 (if sst<0) 672 ii = MOD( npb(ji) - 1, jpi ) + 1 ; ij = ( npb(ji) - 1 ) / jpi + 1 673 zfmdt = ( rhosn - rhoic ) * MAX( dh_snowice(ji), 0._wp ) ! <0 674 zsstK = sst_m(ii,ij) + rt0 675 zEw = rcp * ( zsstK - rt0 ) 676 zQm = zfmdt * zEw 677 678 ! Contribution to heat flux 679 hfx_thd_1d(ji) = hfx_thd_1d(ji) + zfmdt * a_i_1d(ji) * zEw * r1_rdtice 680 681 ! Contribution to salt flux 682 sfx_sni_1d(ji) = sfx_sni_1d(ji) + sss_m(ii,ij) * a_i_1d(ji) * zfmdt * r1_rdtice 683 684 ! Contribution to mass flux 685 ! All snow is thrown in the ocean, and seawater is taken to replace the volume 686 wfx_sni_1d(ji) = wfx_sni_1d(ji) - a_i_1d(ji) * dh_snowice(ji) * rhoic * r1_rdtice 687 wfx_snw_1d(ji) = wfx_snw_1d(ji) + a_i_1d(ji) * dh_snowice(ji) * rhosn * r1_rdtice 688 689 ! update heat content (J.m-2) and layer thickness 690 qh_i_old(ji,0) = qh_i_old(ji,0) + dh_snowice(ji) * q_s_1d(ji,1) + zfmdt * zEw 691 h_i_old (ji,0) = h_i_old (ji,0) + dh_snowice(ji) 692 693 ! Total ablation (to debug) 694 IF( ht_i_1d(ji) <= 0._wp ) a_i_1d(ji) = 0._wp 722 695 723 696 END DO !ji 724 ! 725 CALL wrk_dealloc( jpij, zh_i, zh_s, ztfs, zhsold, zqprec, zqfont_su, zqfont_bo, z_f_surf, zhgnew, zfmass_i ) 726 CALL wrk_dealloc( jpij, zdh_s_mel, zdh_s_pre, zdh_s_sub, zfdt_init, zfdt_final, zqt_i, zqt_s, zqt_dummy ) 727 CALL wrk_dealloc( jpij, zinnermelt, zfbase, zdq_i ) 728 CALL wrk_dealloc( jpij, jkmax, zdeltah, zqt_i_lay ) 729 ! 730 CALL wrk_dealloc( jpij, zviold, zvsold ) ! clem 697 698 ! 699 !------------------------------------------- 700 ! Update temperature, energy 701 !------------------------------------------- 702 !clem bug: we should take snow into account here 703 DO ji = kideb, kiut 704 rswitch = 1.0 - MAX( 0._wp , SIGN( 1._wp , - ht_i_1d(ji) ) ) 705 t_su_1d(ji) = rswitch * t_su_1d(ji) + ( 1.0 - rswitch ) * rtt 706 END DO ! ji 707 708 DO jk = 1, nlay_s 709 DO ji = kideb,kiut 710 ! mask enthalpy 711 rswitch = MAX( 0._wp , SIGN( 1._wp, - ht_s_1d(ji) ) ) 712 q_s_1d(ji,jk) = ( 1.0 - rswitch ) * q_s_1d(ji,jk) 713 ! recalculate t_s_1d from q_s_1d 714 t_s_1d(ji,jk) = rtt + ( 1._wp - rswitch ) * ( - q_s_1d(ji,jk) / ( rhosn * cpic ) + lfus / cpic ) 715 END DO 716 END DO 717 718 CALL wrk_dealloc( jpij, zh_s, zqprec, zq_su, zq_bo, zf_tt, zq_1cat, zq_rema ) 719 CALL wrk_dealloc( jpij, zdh_s_mel, zdh_s_pre, zdh_s_sub, zqh_i, zqh_s, zq_s ) 720 CALL wrk_dealloc( jpij, nlay_i+1, zdeltah, zh_i ) 721 CALL wrk_dealloc( jpij, icount ) 722 ! 731 723 ! 732 724 END SUBROUTINE lim_thd_dh -
branches/2014/dev_r4650_UKMO14.12_STAND_ALONE_OBSOPER/NEMOGCM/NEMO/LIM_SRC_3/limthd_dif.F90
r4333 r5034 25 25 USE wrk_nemo ! work arrays 26 26 USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) 27 USE sbc_oce, ONLY : lk_cpl 27 28 28 29 IMPLICIT NONE … … 31 32 PUBLIC lim_thd_dif ! called by lim_thd 32 33 33 REAL(wp) :: epsi10 = 1.e-10_wp !34 34 !!---------------------------------------------------------------------- 35 35 !! NEMO/LIM3 4.0 , UCL - NEMO Consortium (2011) … … 39 39 CONTAINS 40 40 41 SUBROUTINE lim_thd_dif( kideb , kiut , jl)41 SUBROUTINE lim_thd_dif( kideb , kiut ) 42 42 !!------------------------------------------------------------------ 43 43 !! *** ROUTINE lim_thd_dif *** … … 74 74 !! 75 75 !! ** Inputs / Ouputs : (global commons) 76 !! surface temperature : t_su_ b77 !! ice/snow temperatures : t_i_ b, t_s_b78 !! ice salinities : s_i_ b76 !! surface temperature : t_su_1d 77 !! ice/snow temperatures : t_i_1d, t_s_1d 78 !! ice salinities : s_i_1d 79 79 !! number of layers in the ice/snow: nlay_i, nlay_s 80 80 !! profile of the ice/snow layers : z_i, z_s 81 !! total ice/snow thickness : ht_i_ b, ht_s_b81 !! total ice/snow thickness : ht_i_1d, ht_s_1d 82 82 !! 83 83 !! ** External : … … 91 91 !! (04-2007) Energy conservation tested by M. Vancoppenolle 92 92 !!------------------------------------------------------------------ 93 INTEGER , INTENT (in) :: kideb ! Start point on which the the computation is applied 94 INTEGER , INTENT (in) :: kiut ! End point on which the the computation is applied 95 INTEGER , INTENT (in) :: jl ! Category number 93 INTEGER , INTENT(in) :: kideb, kiut ! Start/End point on which the the computation is applied 96 94 97 95 !! * Local variables … … 99 97 INTEGER :: ii, ij ! temporary dummy loop index 100 98 INTEGER :: numeq ! current reference number of equation 101 INTEGER :: layer! vertical dummy loop index99 INTEGER :: jk ! vertical dummy loop index 102 100 INTEGER :: nconv ! number of iterations in iterative procedure 103 101 INTEGER :: minnumeqmin, maxnumeqmax 104 INTEGER, DIMENSION(kiut) :: numeqmin ! reference number of top equation105 INTEGER, DIMENSION(kiut) :: numeqmax ! reference number of bottom equation106 INTEGER, DIMENSION(kiut) :: isnow ! switch for presence (1) or absence (0) of snow102 INTEGER, POINTER, DIMENSION(:) :: numeqmin ! reference number of top equation 103 INTEGER, POINTER, DIMENSION(:) :: numeqmax ! reference number of bottom equation 104 INTEGER, POINTER, DIMENSION(:) :: isnow ! switch for presence (1) or absence (0) of snow 107 105 REAL(wp) :: zg1s = 2._wp ! for the tridiagonal system 108 106 REAL(wp) :: zg1 = 2._wp ! 109 107 REAL(wp) :: zgamma = 18009._wp ! for specific heat 110 108 REAL(wp) :: zbeta = 0.117_wp ! for thermal conductivity (could be 0.13) 111 REAL(wp) :: zraext_s = 1 .e+8_wp! extinction coefficient of radiation in the snow109 REAL(wp) :: zraext_s = 10._wp ! extinction coefficient of radiation in the snow 112 110 REAL(wp) :: zkimin = 0.10_wp ! minimum ice thermal conductivity 111 REAL(wp) :: ztsu_err = 1.e-5_wp ! range around which t_su is considered as 0°C 113 112 REAL(wp) :: ztmelt_i ! ice melting temperature 114 113 REAL(wp) :: zerritmax ! current maximal error on temperature 115 REAL(wp), DIMENSION(kiut) :: ztfs ! ice melting point 116 REAL(wp), DIMENSION(kiut) :: ztsuold ! old surface temperature (before the iterative procedure ) 117 REAL(wp), DIMENSION(kiut) :: ztsuoldit ! surface temperature at previous iteration 118 REAL(wp), DIMENSION(kiut) :: zh_i ! ice layer thickness 119 REAL(wp), DIMENSION(kiut) :: zh_s ! snow layer thickness 120 REAL(wp), DIMENSION(kiut) :: zfsw ! solar radiation absorbed at the surface 121 REAL(wp), DIMENSION(kiut) :: zf ! surface flux function 122 REAL(wp), DIMENSION(kiut) :: dzf ! derivative of the surface flux function 123 REAL(wp), DIMENSION(kiut) :: zerrit ! current error on temperature 124 REAL(wp), DIMENSION(kiut) :: zdifcase ! case of the equation resolution (1->4) 125 REAL(wp), DIMENSION(kiut) :: zftrice ! solar radiation transmitted through the ice 126 REAL(wp), DIMENSION(kiut) :: zihic, zhsu 127 REAL(wp), DIMENSION(kiut,0:nlay_i) :: ztcond_i ! Ice thermal conductivity 128 REAL(wp), DIMENSION(kiut,0:nlay_i) :: zradtr_i ! Radiation transmitted through the ice 129 REAL(wp), DIMENSION(kiut,0:nlay_i) :: zradab_i ! Radiation absorbed in the ice 130 REAL(wp), DIMENSION(kiut,0:nlay_i) :: zkappa_i ! Kappa factor in the ice 131 REAL(wp), DIMENSION(kiut,0:nlay_i) :: ztiold ! Old temperature in the ice 132 REAL(wp), DIMENSION(kiut,0:nlay_i) :: zeta_i ! Eta factor in the ice 133 REAL(wp), DIMENSION(kiut,0:nlay_i) :: ztitemp ! Temporary temperature in the ice to check the convergence 134 REAL(wp), DIMENSION(kiut,0:nlay_i) :: zspeche_i ! Ice specific heat 135 REAL(wp), DIMENSION(kiut,0:nlay_i) :: z_i ! Vertical cotes of the layers in the ice 136 REAL(wp), DIMENSION(kiut,0:nlay_s) :: zradtr_s ! Radiation transmited through the snow 137 REAL(wp), DIMENSION(kiut,0:nlay_s) :: zradab_s ! Radiation absorbed in the snow 138 REAL(wp), DIMENSION(kiut,0:nlay_s) :: zkappa_s ! Kappa factor in the snow 139 REAL(wp), DIMENSION(kiut,0:nlay_s) :: zeta_s ! Eta factor in the snow 140 REAL(wp), DIMENSION(kiut,0:nlay_s) :: ztstemp ! Temporary temperature in the snow to check the convergence 141 REAL(wp), DIMENSION(kiut,0:nlay_s) :: ztsold ! Temporary temperature in the snow 142 REAL(wp), DIMENSION(kiut,0:nlay_s) :: z_s ! Vertical cotes of the layers in the snow 143 REAL(wp), DIMENSION(kiut,jkmax+2) :: zindterm ! Independent term 144 REAL(wp), DIMENSION(kiut,jkmax+2) :: zindtbis ! temporary independent term 145 REAL(wp), DIMENSION(kiut,jkmax+2) :: zdiagbis 146 REAL(wp), DIMENSION(kiut,jkmax+2,3) :: ztrid ! tridiagonal system terms 114 REAL(wp), POINTER, DIMENSION(:) :: ztfs ! ice melting point 115 REAL(wp), POINTER, DIMENSION(:) :: ztsub ! old surface temperature (before the iterative procedure ) 116 REAL(wp), POINTER, DIMENSION(:) :: ztsubit ! surface temperature at previous iteration 117 REAL(wp), POINTER, DIMENSION(:) :: zh_i ! ice layer thickness 118 REAL(wp), POINTER, DIMENSION(:) :: zh_s ! snow layer thickness 119 REAL(wp), POINTER, DIMENSION(:) :: zfsw ! solar radiation absorbed at the surface 120 REAL(wp), POINTER, DIMENSION(:) :: zf ! surface flux function 121 REAL(wp), POINTER, DIMENSION(:) :: dzf ! derivative of the surface flux function 122 REAL(wp), POINTER, DIMENSION(:) :: zerrit ! current error on temperature 123 REAL(wp), POINTER, DIMENSION(:) :: zdifcase ! case of the equation resolution (1->4) 124 REAL(wp), POINTER, DIMENSION(:) :: zftrice ! solar radiation transmitted through the ice 125 REAL(wp), POINTER, DIMENSION(:) :: zihic, zhsu 126 REAL(wp), POINTER, DIMENSION(:,:) :: ztcond_i ! Ice thermal conductivity 127 REAL(wp), POINTER, DIMENSION(:,:) :: zradtr_i ! Radiation transmitted through the ice 128 REAL(wp), POINTER, DIMENSION(:,:) :: zradab_i ! Radiation absorbed in the ice 129 REAL(wp), POINTER, DIMENSION(:,:) :: zkappa_i ! Kappa factor in the ice 130 REAL(wp), POINTER, DIMENSION(:,:) :: ztib ! Old temperature in the ice 131 REAL(wp), POINTER, DIMENSION(:,:) :: zeta_i ! Eta factor in the ice 132 REAL(wp), POINTER, DIMENSION(:,:) :: ztitemp ! Temporary temperature in the ice to check the convergence 133 REAL(wp), POINTER, DIMENSION(:,:) :: zspeche_i ! Ice specific heat 134 REAL(wp), POINTER, DIMENSION(:,:) :: z_i ! Vertical cotes of the layers in the ice 135 REAL(wp), POINTER, DIMENSION(:,:) :: zradtr_s ! Radiation transmited through the snow 136 REAL(wp), POINTER, DIMENSION(:,:) :: zradab_s ! Radiation absorbed in the snow 137 REAL(wp), POINTER, DIMENSION(:,:) :: zkappa_s ! Kappa factor in the snow 138 REAL(wp), POINTER, DIMENSION(:,:) :: zeta_s ! Eta factor in the snow 139 REAL(wp), POINTER, DIMENSION(:,:) :: ztstemp ! Temporary temperature in the snow to check the convergence 140 REAL(wp), POINTER, DIMENSION(:,:) :: ztsb ! Temporary temperature in the snow 141 REAL(wp), POINTER, DIMENSION(:,:) :: z_s ! Vertical cotes of the layers in the snow 142 REAL(wp), POINTER, DIMENSION(:,:) :: zswiterm ! Independent term 143 REAL(wp), POINTER, DIMENSION(:,:) :: zswitbis ! temporary independent term 144 REAL(wp), POINTER, DIMENSION(:,:) :: zdiagbis 145 REAL(wp), POINTER, DIMENSION(:,:,:) :: ztrid ! tridiagonal system terms 146 ! diag errors on heat 147 REAL(wp), POINTER, DIMENSION(:) :: zdq, zq_ini, zhfx_err 147 148 !!------------------------------------------------------------------ 148 149 ! 150 CALL wrk_alloc( jpij, numeqmin, numeqmax, isnow ) 151 CALL wrk_alloc( jpij, ztfs, ztsub, ztsubit, zh_i, zh_s, zfsw ) 152 CALL wrk_alloc( jpij, zf, dzf, zerrit, zdifcase, zftrice, zihic, zhsu ) 153 CALL wrk_alloc( jpij, nlay_i+1, ztcond_i, zradtr_i, zradab_i, zkappa_i, ztib, zeta_i, ztitemp, z_i, zspeche_i, kjstart=0) 154 CALL wrk_alloc( jpij, nlay_s+1, zradtr_s, zradab_s, zkappa_s, ztsb, zeta_s, ztstemp, z_s, kjstart=0) 155 CALL wrk_alloc( jpij, nlay_i+3, zswiterm, zswitbis, zdiagbis ) 156 CALL wrk_alloc( jpij, nlay_i+3, 3, ztrid ) 157 158 CALL wrk_alloc( jpij, zdq, zq_ini, zhfx_err ) 159 160 ! --- diag error on heat diffusion - PART 1 --- ! 161 zdq(:) = 0._wp ; zq_ini(:) = 0._wp 162 DO ji = kideb, kiut 163 zq_ini(ji) = ( SUM( q_i_1d(ji,1:nlay_i) ) * ht_i_1d(ji) / REAL( nlay_i ) + & 164 & SUM( q_s_1d(ji,1:nlay_s) ) * ht_s_1d(ji) / REAL( nlay_s ) ) 165 END DO 166 149 167 !------------------------------------------------------------------------------! 150 168 ! 1) Initialization ! 151 169 !------------------------------------------------------------------------------! 152 ! 170 ! clem clean: replace just ztfs by rtt 153 171 DO ji = kideb , kiut 154 172 ! is there snow or not 155 isnow(ji)= NINT( 1._wp - MAX( 0._wp , SIGN(1._wp, - ht_s_ b(ji) ) ) )173 isnow(ji)= NINT( 1._wp - MAX( 0._wp , SIGN(1._wp, - ht_s_1d(ji) ) ) ) 156 174 ! surface temperature of fusion 157 !!gm ??? ztfs(ji) = rtt !!!????158 175 ztfs(ji) = REAL( isnow(ji) ) * rtt + REAL( 1 - isnow(ji) ) * rtt 159 176 ! layer thickness 160 zh_i(ji) = ht_i_ b(ji) / REAL( nlay_i )161 zh_s(ji) = ht_s_ b(ji) / REAL( nlay_s )177 zh_i(ji) = ht_i_1d(ji) / REAL( nlay_i ) 178 zh_s(ji) = ht_s_1d(ji) / REAL( nlay_s ) 162 179 END DO 163 180 … … 169 186 z_i(:,0) = 0._wp ! vert. coord. of the up. lim. of the 1st ice layer 170 187 171 DO layer= 1, nlay_s ! vert. coord of the up. lim. of the layer-th snow layer172 DO ji = kideb , kiut 173 z_s(ji, layer) = z_s(ji,layer-1) + ht_s_b(ji) / REAL( nlay_s )174 END DO 175 END DO 176 177 DO layer= 1, nlay_i ! vert. coord of the up. lim. of the layer-th ice layer178 DO ji = kideb , kiut 179 z_i(ji, layer) = z_i(ji,layer-1) + ht_i_b(ji) / REAL( nlay_i )188 DO jk = 1, nlay_s ! vert. coord of the up. lim. of the layer-th snow layer 189 DO ji = kideb , kiut 190 z_s(ji,jk) = z_s(ji,jk-1) + ht_s_1d(ji) / REAL( nlay_s ) 191 END DO 192 END DO 193 194 DO jk = 1, nlay_i ! vert. coord of the up. lim. of the layer-th ice layer 195 DO ji = kideb , kiut 196 z_i(ji,jk) = z_i(ji,jk-1) + ht_i_1d(ji) / REAL( nlay_i ) 180 197 END DO 181 198 END DO … … 194 211 ! zfsw = (1-i0).qsr_ice is absorbed at the surface 195 212 ! zftrice = io.qsr_ice is below the surface 196 ! f stbif= io.qsr_ice.exp(-k(h_i)) transmitted below the ice213 ! ftr_ice = io.qsr_ice.exp(-k(h_i)) transmitted below the ice 197 214 198 215 DO ji = kideb , kiut 199 216 ! switches 200 isnow(ji) = NINT( 1._wp - MAX( 0._wp , SIGN( 1._wp , - ht_s_ b(ji) ) ) )217 isnow(ji) = NINT( 1._wp - MAX( 0._wp , SIGN( 1._wp , - ht_s_1d(ji) ) ) ) 201 218 ! hs > 0, isnow = 1 202 219 zhsu (ji) = hnzst ! threshold for the computation of i0 203 zihic(ji) = MAX( 0._wp , 1._wp - ( ht_i_ b(ji) / zhsu(ji) ) )220 zihic(ji) = MAX( 0._wp , 1._wp - ( ht_i_1d(ji) / zhsu(ji) ) ) 204 221 205 222 i0(ji) = REAL( 1 - isnow(ji) ) * ( fr1_i0_1d(ji) + zihic(ji) * fr2_i0_1d(ji) ) … … 208 225 ! a function of the cloud cover 209 226 ! 210 !i0(ji) = (1.0-FLOAT(isnow(ji)))*3.0/(100*ht_s_ b(ji)+10.0)227 !i0(ji) = (1.0-FLOAT(isnow(ji)))*3.0/(100*ht_s_1d(ji)+10.0) 211 228 !formula used in Cice 212 229 END DO … … 230 247 END DO 231 248 232 DO layer= 1, nlay_s ! Radiation through snow249 DO jk = 1, nlay_s ! Radiation through snow 233 250 DO ji = kideb, kiut 234 251 ! ! radiation transmitted below the layer-th snow layer 235 zradtr_s(ji, layer) = zradtr_s(ji,0) * EXP( - zraext_s * ( MAX ( 0._wp , z_s(ji,layer) ) ) )252 zradtr_s(ji,jk) = zradtr_s(ji,0) * EXP( - zraext_s * ( MAX ( 0._wp , z_s(ji,jk) ) ) ) 236 253 ! ! radiation absorbed by the layer-th snow layer 237 zradab_s(ji, layer) = zradtr_s(ji,layer-1) - zradtr_s(ji,layer)254 zradab_s(ji,jk) = zradtr_s(ji,jk-1) - zradtr_s(ji,jk) 238 255 END DO 239 256 END DO … … 243 260 END DO 244 261 245 DO layer= 1, nlay_i ! Radiation through ice262 DO jk = 1, nlay_i ! Radiation through ice 246 263 DO ji = kideb, kiut 247 264 ! ! radiation transmitted below the layer-th ice layer 248 zradtr_i(ji, layer) = zradtr_i(ji,0) * EXP( - kappa_i * ( MAX ( 0._wp , z_i(ji,layer) ) ) )265 zradtr_i(ji,jk) = zradtr_i(ji,0) * EXP( - kappa_i * ( MAX ( 0._wp , z_i(ji,jk) ) ) ) 249 266 ! ! radiation absorbed by the layer-th ice layer 250 zradab_i(ji, layer) = zradtr_i(ji,layer-1) - zradtr_i(ji,layer)267 zradab_i(ji,jk) = zradtr_i(ji,jk-1) - zradtr_i(ji,jk) 251 268 END DO 252 269 END DO 253 270 254 271 DO ji = kideb, kiut ! Radiation transmitted below the ice 255 fstbif_1d(ji) = fstbif_1d(ji) + iatte_1d(ji) * zradtr_i(ji,nlay_i) * a_i_b(ji) / at_i_b(ji) ! clem modif 256 END DO 257 258 ! +++++ 259 ! just to check energy conservation 260 DO ji = kideb, kiut 261 ii = MOD( npb(ji) - 1 , jpi ) + 1 262 ij = ( npb(ji) - 1 ) / jpi + 1 263 fstroc(ii,ij,jl) = iatte_1d(ji) * zradtr_i(ji,nlay_i) ! clem modif 264 END DO 265 ! +++++ 266 267 DO layer = 1, nlay_i 268 DO ji = kideb, kiut 269 radab(ji,layer) = zradab_i(ji,layer) 270 END DO 272 ftr_ice_1d(ji) = zradtr_i(ji,nlay_i) 271 273 END DO 272 274 … … 277 279 ! 278 280 DO ji = kideb, kiut ! Old surface temperature 279 ztsu old (ji) = t_su_b(ji) ! temperature at the beg of iter pr.280 ztsu oldit(ji) = t_su_b(ji) ! temperature at the previous iter281 t_su_ b (ji) = MIN( t_su_b(ji), ztfs(ji)-0.00001 )! necessary281 ztsub (ji) = t_su_1d(ji) ! temperature at the beg of iter pr. 282 ztsubit(ji) = t_su_1d(ji) ! temperature at the previous iter 283 t_su_1d (ji) = MIN( t_su_1d(ji), ztfs(ji) - ztsu_err ) ! necessary 282 284 zerrit (ji) = 1000._wp ! initial value of error 283 285 END DO 284 286 285 DO layer= 1, nlay_s ! Old snow temperature286 DO ji = kideb , kiut 287 zts old(ji,layer) = t_s_b(ji,layer)288 END DO 289 END DO 290 291 DO layer= 1, nlay_i ! Old ice temperature292 DO ji = kideb , kiut 293 zti old(ji,layer) = t_i_b(ji,layer)287 DO jk = 1, nlay_s ! Old snow temperature 288 DO ji = kideb , kiut 289 ztsb(ji,jk) = t_s_1d(ji,jk) 290 END DO 291 END DO 292 293 DO jk = 1, nlay_i ! Old ice temperature 294 DO ji = kideb , kiut 295 ztib(ji,jk) = t_i_1d(ji,jk) 294 296 END DO 295 297 END DO … … 308 310 IF( thcon_i_swi == 0 ) THEN ! Untersteiner (1964) formula 309 311 DO ji = kideb , kiut 310 ztcond_i(ji,0) = rcdic + zbeta*s_i_ b(ji,1) / MIN(-epsi10,t_i_b(ji,1)-rtt)312 ztcond_i(ji,0) = rcdic + zbeta*s_i_1d(ji,1) / MIN(-epsi10,t_i_1d(ji,1)-rtt) 311 313 ztcond_i(ji,0) = MAX(ztcond_i(ji,0),zkimin) 312 314 END DO 313 DO layer= 1, nlay_i-1315 DO jk = 1, nlay_i-1 314 316 DO ji = kideb , kiut 315 ztcond_i(ji, layer) = rcdic + zbeta*( s_i_b(ji,layer) + s_i_b(ji,layer+1) ) / &316 MIN(-2.0_wp * epsi10, t_i_ b(ji,layer)+t_i_b(ji,layer+1) - 2.0_wp * rtt)317 ztcond_i(ji, layer) = MAX(ztcond_i(ji,layer),zkimin)317 ztcond_i(ji,jk) = rcdic + zbeta*( s_i_1d(ji,jk) + s_i_1d(ji,jk+1) ) / & 318 MIN(-2.0_wp * epsi10, t_i_1d(ji,jk)+t_i_1d(ji,jk+1) - 2.0_wp * rtt) 319 ztcond_i(ji,jk) = MAX(ztcond_i(ji,jk),zkimin) 318 320 END DO 319 321 END DO … … 322 324 IF( thcon_i_swi == 1 ) THEN ! Pringle et al formula included: 2.11 + 0.09 S/T - 0.011.T 323 325 DO ji = kideb , kiut 324 ztcond_i(ji,0) = rcdic + 0.090_wp * s_i_ b(ji,1) / MIN( -epsi10, t_i_b(ji,1)-rtt ) &325 & - 0.011_wp * ( t_i_ b(ji,1) - rtt )326 ztcond_i(ji,0) = rcdic + 0.090_wp * s_i_1d(ji,1) / MIN( -epsi10, t_i_1d(ji,1)-rtt ) & 327 & - 0.011_wp * ( t_i_1d(ji,1) - rtt ) 326 328 ztcond_i(ji,0) = MAX( ztcond_i(ji,0), zkimin ) 327 329 END DO 328 DO layer= 1, nlay_i-1330 DO jk = 1, nlay_i-1 329 331 DO ji = kideb , kiut 330 ztcond_i(ji,layer) = rcdic + 0.090_wp * ( s_i_b(ji,layer) + s_i_b(ji,layer+1) ) & 331 & / MIN(-2.0_wp * epsi10, t_i_b(ji,layer)+t_i_b(ji,layer+1) - 2.0_wp * rtt) & 332 & - 0.0055_wp* ( t_i_b(ji,layer) + t_i_b(ji,layer+1) - 2.0*rtt ) 333 ztcond_i(ji,layer) = MAX( ztcond_i(ji,layer), zkimin ) 332 ztcond_i(ji,jk) = rcdic + & 333 & 0.090_wp * ( s_i_1d(ji,jk) + s_i_1d(ji,jk+1) ) & 334 & / MIN(-2.0_wp * epsi10, t_i_1d(ji,jk)+t_i_1d(ji,jk+1) - 2.0_wp * rtt) & 335 & - 0.0055_wp* ( t_i_1d(ji,jk) + t_i_1d(ji,jk+1) - 2.0*rtt ) 336 ztcond_i(ji,jk) = MAX( ztcond_i(ji,jk), zkimin ) 334 337 END DO 335 338 END DO 336 339 DO ji = kideb , kiut 337 ztcond_i(ji,nlay_i) = rcdic + 0.090_wp * s_i_ b(ji,nlay_i) / MIN(-epsi10,t_bo_b(ji)-rtt) &338 & - 0.011_wp * ( t_bo_ b(ji) - rtt )340 ztcond_i(ji,nlay_i) = rcdic + 0.090_wp * s_i_1d(ji,nlay_i) / MIN(-epsi10,t_bo_1d(ji)-rtt) & 341 & - 0.011_wp * ( t_bo_1d(ji) - rtt ) 339 342 ztcond_i(ji,nlay_i) = MAX( ztcond_i(ji,nlay_i), zkimin ) 340 343 END DO … … 352 355 END DO 353 356 354 DO layer= 1, nlay_s-1355 DO ji = kideb , kiut 356 zkappa_s(ji, layer) = 2.0 * rcdsn / &357 DO jk = 1, nlay_s-1 358 DO ji = kideb , kiut 359 zkappa_s(ji,jk) = 2.0 * rcdsn / & 357 360 MAX(epsi10,2.0*zh_s(ji)) 358 361 END DO 359 362 END DO 360 363 361 DO layer= 1, nlay_i-1364 DO jk = 1, nlay_i-1 362 365 DO ji = kideb , kiut 363 366 !-- Ice kappa factors 364 zkappa_i(ji, layer) = 2.0*ztcond_i(ji,layer)/ &367 zkappa_i(ji,jk) = 2.0*ztcond_i(ji,jk)/ & 365 368 MAX(epsi10,2.0*zh_i(ji)) 366 369 END DO … … 381 384 !------------------------------------------------------------------------------| 382 385 ! 383 DO layer= 1, nlay_i384 DO ji = kideb , kiut 385 ztitemp(ji, layer) = t_i_b(ji,layer)386 zspeche_i(ji, layer) = cpic + zgamma*s_i_b(ji,layer)/ &387 MAX((t_i_ b(ji,layer)-rtt)*(ztiold(ji,layer)-rtt),epsi10)388 zeta_i(ji, layer) = rdt_ice / MAX(rhoic*zspeche_i(ji,layer)*zh_i(ji), &386 DO jk = 1, nlay_i 387 DO ji = kideb , kiut 388 ztitemp(ji,jk) = t_i_1d(ji,jk) 389 zspeche_i(ji,jk) = cpic + zgamma*s_i_1d(ji,jk)/ & 390 MAX((t_i_1d(ji,jk)-rtt)*(ztib(ji,jk)-rtt),epsi10) 391 zeta_i(ji,jk) = rdt_ice / MAX(rhoic*zspeche_i(ji,jk)*zh_i(ji), & 389 392 epsi10) 390 393 END DO 391 394 END DO 392 395 393 DO layer= 1, nlay_s394 DO ji = kideb , kiut 395 ztstemp(ji, layer) = t_s_b(ji,layer)396 zeta_s(ji, layer) = rdt_ice / MAX(rhosn*cpic*zh_s(ji),epsi10)396 DO jk = 1, nlay_s 397 DO ji = kideb , kiut 398 ztstemp(ji,jk) = t_s_1d(ji,jk) 399 zeta_s(ji,jk) = rdt_ice / MAX(rhosn*cpic*zh_s(ji),epsi10) 397 400 END DO 398 401 END DO … … 402 405 !------------------------------------------------------------------------------| 403 406 ! 404 DO ji = kideb , kiut 405 406 ! update of the non solar flux according to the update in T_su 407 qnsr_ice_1d(ji) = qnsr_ice_1d(ji) + dqns_ice_1d(ji) * & 408 ( t_su_b(ji) - ztsuoldit(ji) ) 409 407 IF( .NOT. lk_cpl ) THEN !--- forced atmosphere case 408 DO ji = kideb , kiut 409 ! update of the non solar flux according to the update in T_su 410 qns_ice_1d(ji) = qns_ice_1d(ji) + dqns_ice_1d(ji) * ( t_su_1d(ji) - ztsubit(ji) ) 411 END DO 412 ENDIF 413 414 ! Update incoming flux 415 DO ji = kideb , kiut 410 416 ! update incoming flux 411 417 zf(ji) = zfsw(ji) & ! net absorbed solar radiation 412 + qns r_ice_1d(ji)! non solar total flux418 + qns_ice_1d(ji) ! non solar total flux 413 419 ! (LWup, LWdw, SH, LH) 414 415 420 END DO 416 421 … … 427 432 !!ice interior terms (top equation has the same form as the others) 428 433 429 DO numeq=1, jkmax+2434 DO numeq=1,nlay_i+3 430 435 DO ji = kideb , kiut 431 436 ztrid(ji,numeq,1) = 0. 432 437 ztrid(ji,numeq,2) = 0. 433 438 ztrid(ji,numeq,3) = 0. 434 z indterm(ji,numeq)= 0.435 z indtbis(ji,numeq)= 0.439 zswiterm(ji,numeq)= 0. 440 zswitbis(ji,numeq)= 0. 436 441 zdiagbis(ji,numeq)= 0. 437 442 ENDDO … … 440 445 DO numeq = nlay_s + 2, nlay_s + nlay_i 441 446 DO ji = kideb , kiut 442 layer= numeq - nlay_s - 1443 ztrid(ji,numeq,1) = - zeta_i(ji, layer)*zkappa_i(ji,layer-1)444 ztrid(ji,numeq,2) = 1.0 + zeta_i(ji, layer)*(zkappa_i(ji,layer-1) + &445 zkappa_i(ji, layer))446 ztrid(ji,numeq,3) = - zeta_i(ji, layer)*zkappa_i(ji,layer)447 z indterm(ji,numeq) = ztiold(ji,layer) + zeta_i(ji,layer)* &448 zradab_i(ji, layer)447 jk = numeq - nlay_s - 1 448 ztrid(ji,numeq,1) = - zeta_i(ji,jk)*zkappa_i(ji,jk-1) 449 ztrid(ji,numeq,2) = 1.0 + zeta_i(ji,jk)*(zkappa_i(ji,jk-1) + & 450 zkappa_i(ji,jk)) 451 ztrid(ji,numeq,3) = - zeta_i(ji,jk)*zkappa_i(ji,jk) 452 zswiterm(ji,numeq) = ztib(ji,jk) + zeta_i(ji,jk)* & 453 zradab_i(ji,jk) 449 454 END DO 450 455 ENDDO … … 457 462 + zkappa_i(ji,nlay_i-1) ) 458 463 ztrid(ji,numeq,3) = 0.0 459 z indterm(ji,numeq) = ztiold(ji,nlay_i) + zeta_i(ji,nlay_i)* &464 zswiterm(ji,numeq) = ztib(ji,nlay_i) + zeta_i(ji,nlay_i)* & 460 465 ( zradab_i(ji,nlay_i) + zkappa_i(ji,nlay_i)*zg1 & 461 * t_bo_ b(ji) )466 * t_bo_1d(ji) ) 462 467 ENDDO 463 468 464 469 465 470 DO ji = kideb , kiut 466 IF ( ht_s_ b(ji).gt.0.0 ) THEN471 IF ( ht_s_1d(ji).gt.0.0 ) THEN 467 472 ! 468 473 !------------------------------------------------------------------------------| … … 472 477 !!snow interior terms (bottom equation has the same form as the others) 473 478 DO numeq = 3, nlay_s + 1 474 layer= numeq - 1475 ztrid(ji,numeq,1) = - zeta_s(ji, layer)*zkappa_s(ji,layer-1)476 ztrid(ji,numeq,2) = 1.0 + zeta_s(ji, layer)*( zkappa_s(ji,layer-1) + &477 zkappa_s(ji, layer) )478 ztrid(ji,numeq,3) = - zeta_s(ji, layer)*zkappa_s(ji,layer)479 z indterm(ji,numeq) = ztsold(ji,layer) + zeta_s(ji,layer)* &480 zradab_s(ji, layer)479 jk = numeq - 1 480 ztrid(ji,numeq,1) = - zeta_s(ji,jk)*zkappa_s(ji,jk-1) 481 ztrid(ji,numeq,2) = 1.0 + zeta_s(ji,jk)*( zkappa_s(ji,jk-1) + & 482 zkappa_s(ji,jk) ) 483 ztrid(ji,numeq,3) = - zeta_s(ji,jk)*zkappa_s(ji,jk) 484 zswiterm(ji,numeq) = ztsb(ji,jk) + zeta_s(ji,jk)* & 485 zradab_s(ji,jk) 481 486 END DO 482 487 … … 484 489 IF ( nlay_i.eq.1 ) THEN 485 490 ztrid(ji,nlay_s+2,3) = 0.0 486 z indterm(ji,nlay_s+2) = zindterm(ji,nlay_s+2) + zkappa_i(ji,1)* &487 t_bo_ b(ji)491 zswiterm(ji,nlay_s+2) = zswiterm(ji,nlay_s+2) + zkappa_i(ji,1)* & 492 t_bo_1d(ji) 488 493 ENDIF 489 494 490 IF ( t_su_ b(ji) .LT. rtt ) THEN495 IF ( t_su_1d(ji) .LT. rtt ) THEN 491 496 492 497 !------------------------------------------------------------------------------| … … 501 506 ztrid(ji,1,2) = dzf(ji) - zg1s*zkappa_s(ji,0) 502 507 ztrid(ji,1,3) = zg1s*zkappa_s(ji,0) 503 z indterm(ji,1) = dzf(ji)*t_su_b(ji) - zf(ji)508 zswiterm(ji,1) = dzf(ji)*t_su_1d(ji) - zf(ji) 504 509 505 510 !!first layer of snow equation … … 507 512 ztrid(ji,2,2) = 1.0 + zeta_s(ji,1)*(zkappa_s(ji,1) + zkappa_s(ji,0)*zg1s) 508 513 ztrid(ji,2,3) = - zeta_s(ji,1)* zkappa_s(ji,1) 509 z indterm(ji,2) = ztsold(ji,1) + zeta_s(ji,1)*zradab_s(ji,1)514 zswiterm(ji,2) = ztsb(ji,1) + zeta_s(ji,1)*zradab_s(ji,1) 510 515 511 516 ELSE … … 524 529 zkappa_s(ji,0) * zg1s ) 525 530 ztrid(ji,2,3) = - zeta_s(ji,1)*zkappa_s(ji,1) 526 z indterm(ji,2) = ztsold(ji,1) + zeta_s(ji,1) * &531 zswiterm(ji,2) = ztsb(ji,1) + zeta_s(ji,1) * & 527 532 ( zradab_s(ji,1) + & 528 zkappa_s(ji,0) * zg1s * t_su_ b(ji) )533 zkappa_s(ji,0) * zg1s * t_su_1d(ji) ) 529 534 ENDIF 530 535 ELSE … … 534 539 !------------------------------------------------------------------------------| 535 540 ! 536 IF (t_su_ b(ji) .LT. rtt) THEN541 IF (t_su_1d(ji) .LT. rtt) THEN 537 542 ! 538 543 !------------------------------------------------------------------------------| … … 548 553 ztrid(ji,numeqmin(ji),2) = dzf(ji) - zkappa_i(ji,0)*zg1 549 554 ztrid(ji,numeqmin(ji),3) = zkappa_i(ji,0)*zg1 550 z indterm(ji,numeqmin(ji)) = dzf(ji)*t_su_b(ji) - zf(ji)555 zswiterm(ji,numeqmin(ji)) = dzf(ji)*t_su_1d(ji) - zf(ji) 551 556 552 557 !!first layer of ice equation … … 555 560 + zkappa_i(ji,0) * zg1 ) 556 561 ztrid(ji,numeqmin(ji)+1,3) = - zeta_i(ji,1)*zkappa_i(ji,1) 557 z indterm(ji,numeqmin(ji)+1)= ztiold(ji,1) + zeta_i(ji,1)*zradab_i(ji,1)562 zswiterm(ji,numeqmin(ji)+1)= ztib(ji,1) + zeta_i(ji,1)*zradab_i(ji,1) 558 563 559 564 !!case of only one layer in the ice (surface & ice equations are altered) … … 568 573 ztrid(ji,numeqmin(ji)+1,3) = 0.0 569 574 570 z indterm(ji,numeqmin(ji)+1) = ztiold(ji,1) + zeta_i(ji,1)* &571 ( zradab_i(ji,1) + zkappa_i(ji,1)*t_bo_ b(ji) )575 zswiterm(ji,numeqmin(ji)+1) = ztib(ji,1) + zeta_i(ji,1)* & 576 ( zradab_i(ji,1) + zkappa_i(ji,1)*t_bo_1d(ji) ) 572 577 ENDIF 573 578 … … 588 593 zg1) 589 594 ztrid(ji,numeqmin(ji),3) = - zeta_i(ji,1) * zkappa_i(ji,1) 590 z indterm(ji,numeqmin(ji)) = ztiold(ji,1) + zeta_i(ji,1)*( zradab_i(ji,1) + &591 zkappa_i(ji,0) * zg1 * t_su_ b(ji) )595 zswiterm(ji,numeqmin(ji)) = ztib(ji,1) + zeta_i(ji,1)*( zradab_i(ji,1) + & 596 zkappa_i(ji,0) * zg1 * t_su_1d(ji) ) 592 597 593 598 !!case of only one layer in the ice (surface & ice equations are altered) … … 597 602 zkappa_i(ji,1)) 598 603 ztrid(ji,numeqmin(ji),3) = 0.0 599 z indterm(ji,numeqmin(ji)) = ztiold(ji,1) + zeta_i(ji,1)* &600 (zradab_i(ji,1) + zkappa_i(ji,1)*t_bo_ b(ji)) &601 + t_su_ b(ji)*zeta_i(ji,1)*zkappa_i(ji,0)*2.0604 zswiterm(ji,numeqmin(ji)) = ztib(ji,1) + zeta_i(ji,1)* & 605 (zradab_i(ji,1) + zkappa_i(ji,1)*t_bo_1d(ji)) & 606 + t_su_1d(ji)*zeta_i(ji,1)*zkappa_i(ji,0)*2.0 602 607 ENDIF 603 608 … … 618 623 619 624 maxnumeqmax = 0 620 minnumeqmin = jkmax+4621 622 DO ji = kideb , kiut 623 z indtbis(ji,numeqmin(ji)) = zindterm(ji,numeqmin(ji))625 minnumeqmin = nlay_i+5 626 627 DO ji = kideb , kiut 628 zswitbis(ji,numeqmin(ji)) = zswiterm(ji,numeqmin(ji)) 624 629 zdiagbis(ji,numeqmin(ji)) = ztrid(ji,numeqmin(ji),2) 625 630 minnumeqmin = MIN(numeqmin(ji),minnumeqmin) … … 627 632 END DO 628 633 629 DO layer= minnumeqmin+1, maxnumeqmax630 DO ji = kideb , kiut 631 numeq = min(max(numeqmin(ji)+1, layer),numeqmax(ji))634 DO jk = minnumeqmin+1, maxnumeqmax 635 DO ji = kideb , kiut 636 numeq = min(max(numeqmin(ji)+1,jk),numeqmax(ji)) 632 637 zdiagbis(ji,numeq) = ztrid(ji,numeq,2) - ztrid(ji,numeq,1)* & 633 638 ztrid(ji,numeq-1,3)/zdiagbis(ji,numeq-1) 634 z indtbis(ji,numeq) = zindterm(ji,numeq) - ztrid(ji,numeq,1)* &635 z indtbis(ji,numeq-1)/zdiagbis(ji,numeq-1)639 zswitbis(ji,numeq) = zswiterm(ji,numeq) - ztrid(ji,numeq,1)* & 640 zswitbis(ji,numeq-1)/zdiagbis(ji,numeq-1) 636 641 END DO 637 642 END DO … … 639 644 DO ji = kideb , kiut 640 645 ! ice temperatures 641 t_i_ b(ji,nlay_i) = zindtbis(ji,numeqmax(ji))/zdiagbis(ji,numeqmax(ji))646 t_i_1d(ji,nlay_i) = zswitbis(ji,numeqmax(ji))/zdiagbis(ji,numeqmax(ji)) 642 647 END DO 643 648 644 649 DO numeq = nlay_i + nlay_s + 1, nlay_s + 2, -1 645 650 DO ji = kideb , kiut 646 layer= numeq - nlay_s - 1647 t_i_ b(ji,layer) = (zindtbis(ji,numeq) - ztrid(ji,numeq,3)* &648 t_i_ b(ji,layer+1))/zdiagbis(ji,numeq)651 jk = numeq - nlay_s - 1 652 t_i_1d(ji,jk) = (zswitbis(ji,numeq) - ztrid(ji,numeq,3)* & 653 t_i_1d(ji,jk+1))/zdiagbis(ji,numeq) 649 654 END DO 650 655 END DO … … 652 657 DO ji = kideb , kiut 653 658 ! snow temperatures 654 IF (ht_s_ b(ji).GT.0._wp) &655 t_s_ b(ji,nlay_s) = (zindtbis(ji,nlay_s+1) - ztrid(ji,nlay_s+1,3) &656 * t_i_ b(ji,1))/zdiagbis(ji,nlay_s+1) &657 * MAX(0.0,SIGN(1.0,ht_s_ b(ji)))659 IF (ht_s_1d(ji).GT.0._wp) & 660 t_s_1d(ji,nlay_s) = (zswitbis(ji,nlay_s+1) - ztrid(ji,nlay_s+1,3) & 661 * t_i_1d(ji,1))/zdiagbis(ji,nlay_s+1) & 662 * MAX(0.0,SIGN(1.0,ht_s_1d(ji))) 658 663 659 664 ! surface temperature 660 isnow(ji) = NINT( 1.0 - MAX( 0.0 , SIGN( 1.0 , -ht_s_ b(ji) ) ) )661 ztsu oldit(ji) = t_su_b(ji)662 IF( t_su_ b(ji) < ztfs(ji) ) &663 t_su_ b(ji) = ( zindtbis(ji,numeqmin(ji)) - ztrid(ji,numeqmin(ji),3)* ( REAL( isnow(ji) )*t_s_b(ji,1) &664 & + REAL( 1 - isnow(ji) )*t_i_ b(ji,1) ) ) / zdiagbis(ji,numeqmin(ji))665 isnow(ji) = NINT( 1.0 - MAX( 0.0 , SIGN( 1.0 , -ht_s_1d(ji) ) ) ) 666 ztsubit(ji) = t_su_1d(ji) 667 IF( t_su_1d(ji) < ztfs(ji) ) & 668 t_su_1d(ji) = ( zswitbis(ji,numeqmin(ji)) - ztrid(ji,numeqmin(ji),3)* ( REAL( isnow(ji) )*t_s_1d(ji,1) & 669 & + REAL( 1 - isnow(ji) )*t_i_1d(ji,1) ) ) / zdiagbis(ji,numeqmin(ji)) 665 670 END DO 666 671 ! … … 672 677 ! zerrit(ji) is a measure of error, it has to be under maxer_i_thd 673 678 DO ji = kideb , kiut 674 t_su_b(ji) = MAX( MIN( t_su_b(ji) , ztfs(ji) ) , 190._wp ) 675 zerrit(ji) = ABS( t_su_b(ji) - ztsuoldit(ji) ) 676 END DO 677 678 DO layer = 1, nlay_s 679 DO ji = kideb , kiut 680 ii = MOD( npb(ji) - 1, jpi ) + 1 681 ij = ( npb(ji) - 1 ) / jpi + 1 682 t_s_b(ji,layer) = MAX( MIN( t_s_b(ji,layer), rtt ), 190._wp ) 683 zerrit(ji) = MAX(zerrit(ji),ABS(t_s_b(ji,layer) - ztstemp(ji,layer))) 684 END DO 685 END DO 686 687 DO layer = 1, nlay_i 688 DO ji = kideb , kiut 689 ztmelt_i = -tmut * s_i_b(ji,layer) + rtt 690 t_i_b(ji,layer) = MAX(MIN(t_i_b(ji,layer),ztmelt_i), 190._wp) 691 zerrit(ji) = MAX(zerrit(ji),ABS(t_i_b(ji,layer) - ztitemp(ji,layer))) 679 t_su_1d(ji) = MAX( MIN( t_su_1d(ji) , ztfs(ji) ) , 190._wp ) 680 zerrit(ji) = ABS( t_su_1d(ji) - ztsubit(ji) ) 681 END DO 682 683 DO jk = 1, nlay_s 684 DO ji = kideb , kiut 685 t_s_1d(ji,jk) = MAX( MIN( t_s_1d(ji,jk), rtt ), 190._wp ) 686 zerrit(ji) = MAX(zerrit(ji),ABS(t_s_1d(ji,jk) - ztstemp(ji,jk))) 687 END DO 688 END DO 689 690 DO jk = 1, nlay_i 691 DO ji = kideb , kiut 692 ztmelt_i = -tmut * s_i_1d(ji,jk) + rtt 693 t_i_1d(ji,jk) = MAX(MIN(t_i_1d(ji,jk),ztmelt_i), 190._wp) 694 zerrit(ji) = MAX(zerrit(ji),ABS(t_i_1d(ji,jk) - ztitemp(ji,jk))) 692 695 END DO 693 696 END DO … … 713 716 !-------------------------------------------------------------------------! 714 717 DO ji = kideb, kiut 715 #if ! defined key_coupled716 718 ! forced mode only : update of latent heat fluxes (sublimation) (always >=0, upward flux) 717 qla_ice_1d (ji) = MAX( 0._wp, qla_ice_1d (ji) + dqla_ice_1d(ji) * ( t_su_b(ji) - ztsuold(ji) ) ) 718 #endif 719 IF( .NOT. lk_cpl) qla_ice_1d (ji) = MAX( 0._wp, qla_ice_1d (ji) + dqla_ice_1d(ji) * ( t_su_1d(ji) - ztsub(ji) ) ) 719 720 ! ! surface ice conduction flux 720 isnow(ji) = NINT( 1._wp - MAX( 0._wp, SIGN( 1._wp, -ht_s_ b(ji) ) ) )721 fc_su(ji) = - REAL( isnow(ji) ) * zkappa_s(ji,0) * zg1s * (t_s_ b(ji,1) - t_su_b(ji)) &722 & - REAL( 1 - isnow(ji) ) * zkappa_i(ji,0) * zg1 * (t_i_ b(ji,1) - t_su_b(ji))721 isnow(ji) = NINT( 1._wp - MAX( 0._wp, SIGN( 1._wp, -ht_s_1d(ji) ) ) ) 722 fc_su(ji) = - REAL( isnow(ji) ) * zkappa_s(ji,0) * zg1s * (t_s_1d(ji,1) - t_su_1d(ji)) & 723 & - REAL( 1 - isnow(ji) ) * zkappa_i(ji,0) * zg1 * (t_i_1d(ji,1) - t_su_1d(ji)) 723 724 ! ! bottom ice conduction flux 724 fc_bo_i(ji) = - zkappa_i(ji,nlay_i) * ( zg1*(t_bo_b(ji) - t_i_b(ji,nlay_i)) ) 725 END DO 726 727 !-------------------------! 728 ! Heat conservation ! 729 !-------------------------! 730 IF( con_i .AND. jiindex_1d > 0 ) THEN 725 fc_bo_i(ji) = - zkappa_i(ji,nlay_i) * ( zg1*(t_bo_1d(ji) - t_i_1d(ji,nlay_i)) ) 726 END DO 727 728 !----------------------------------------- 729 ! Heat flux used to warm/cool ice in W.m-2 730 !----------------------------------------- 731 DO ji = kideb, kiut 732 IF( t_su_1d(ji) < rtt ) THEN ! case T_su < 0degC 733 hfx_dif_1d(ji) = hfx_dif_1d(ji) + & 734 & ( qns_ice_1d(ji) + qsr_ice_1d(ji) - zradtr_i(ji,nlay_i) - fc_bo_i(ji) ) * a_i_1d(ji) 735 ELSE ! case T_su = 0degC 736 hfx_dif_1d(ji) = hfx_dif_1d(ji) + & 737 & ( fc_su(ji) + i0(ji) * qsr_ice_1d(ji) - zradtr_i(ji,nlay_i) - fc_bo_i(ji) ) * a_i_1d(ji) 738 ENDIF 739 END DO 740 741 ! --- computes sea ice energy of melting compulsory for limthd_dh --- ! 742 CALL lim_thd_enmelt( kideb, kiut ) 743 744 ! --- diag conservation imbalance on heat diffusion - PART 2 --- ! 745 DO ji = kideb, kiut 746 zdq(ji) = - zq_ini(ji) + ( SUM( q_i_1d(ji,1:nlay_i) ) * ht_i_1d(ji) / REAL( nlay_i ) + & 747 & SUM( q_s_1d(ji,1:nlay_s) ) * ht_s_1d(ji) / REAL( nlay_s ) ) 748 zhfx_err(ji) = ( fc_su(ji) + i0(ji) * qsr_ice_1d(ji) - zradtr_i(ji,nlay_i) - fc_bo_i(ji) + zdq(ji) * r1_rdtice ) 749 hfx_err_1d(ji) = hfx_err_1d(ji) + zhfx_err(ji) * a_i_1d(ji) 750 END DO 751 752 ! diagnose external surface (forced case) or bottom (forced case) from heat conservation 753 IF( .NOT. lk_cpl ) THEN ! --- forced case: qns_ice and fc_su are diagnosed 754 ! 731 755 DO ji = kideb, kiut 732 ! Upper snow value 733 fc_s(ji,0) = - REAL( isnow(ji) ) * zkappa_s(ji,0) * zg1s * ( t_s_b(ji,1) - t_su_b(ji) ) 734 ! Bott. snow value 735 fc_s(ji,1) = - REAL( isnow(ji) ) * zkappa_s(ji,1) * ( t_i_b(ji,1) - t_s_b(ji,1) ) 736 END DO 737 DO ji = kideb, kiut ! Upper ice layer 738 fc_i(ji,0) = - REAL( isnow(ji) ) * & ! interface flux if there is snow 739 ( zkappa_i(ji,0) * ( t_i_b(ji,1) - t_s_b(ji,nlay_s ) ) ) & 740 - REAL( 1 - isnow(ji) ) * ( zkappa_i(ji,0) * & 741 zg1 * ( t_i_b(ji,1) - t_su_b(ji) ) ) ! upper flux if not 742 END DO 743 DO layer = 1, nlay_i - 1 ! Internal ice layers 744 DO ji = kideb, kiut 745 fc_i(ji,layer) = - zkappa_i(ji,layer) * ( t_i_b(ji,layer+1) - t_i_b(ji,layer) ) 746 ii = MOD( npb(ji) - 1, jpi ) + 1 747 ij = ( npb(ji) - 1 ) / jpi + 1 748 END DO 749 END DO 750 DO ji = kideb, kiut ! Bottom ice layers 751 fc_i(ji,nlay_i) = - zkappa_i(ji,nlay_i) * ( zg1*(t_bo_b(ji) - t_i_b(ji,nlay_i)) ) 752 END DO 756 qns_ice_1d(ji) = qns_ice_1d(ji) - zhfx_err(ji) 757 fc_su (ji) = fc_su(ji) - zhfx_err(ji) 758 END DO 759 ! 760 ELSE ! --- coupled case: ocean turbulent heat flux is diagnosed 761 ! 762 DO ji = kideb, kiut 763 fhtur_1d (ji) = fhtur_1d(ji) - zhfx_err(ji) 764 END DO 765 ! 753 766 ENDIF 767 768 ! --- compute diagnostic net heat flux at the surface of the snow-ice system (W.m2) 769 DO ji = kideb, kiut 770 ii = MOD( npb(ji) - 1, jpi ) + 1 ; ij = ( npb(ji) - 1 ) / jpi + 1 771 hfx_in (ii,ij) = hfx_in (ii,ij) + a_i_1d(ji) * ( qsr_ice_1d(ji) + qns_ice_1d(ji) ) 772 END DO 773 754 774 ! 775 CALL wrk_dealloc( jpij, numeqmin, numeqmax, isnow ) 776 CALL wrk_dealloc( jpij, ztfs, ztsub, ztsubit, zh_i, zh_s, zfsw ) 777 CALL wrk_dealloc( jpij, zf, dzf, zerrit, zdifcase, zftrice, zihic, zhsu ) 778 CALL wrk_dealloc( jpij, nlay_i+1, ztcond_i, zradtr_i, zradab_i, zkappa_i, & 779 & ztib, zeta_i, ztitemp, z_i, zspeche_i, kjstart = 0 ) 780 CALL wrk_dealloc( jpij, nlay_s+1, zradtr_s, zradab_s, zkappa_s, ztsb, zeta_s, ztstemp, z_s, kjstart = 0 ) 781 CALL wrk_dealloc( jpij, nlay_i+3, zswiterm, zswitbis, zdiagbis ) 782 CALL wrk_dealloc( jpij, nlay_i+3, 3, ztrid ) 783 CALL wrk_dealloc( jpij, zdq, zq_ini, zhfx_err ) 784 755 785 END SUBROUTINE lim_thd_dif 786 787 SUBROUTINE lim_thd_enmelt( kideb, kiut ) 788 !!----------------------------------------------------------------------- 789 !! *** ROUTINE lim_thd_enmelt *** 790 !! 791 !! ** Purpose : Computes sea ice energy of melting q_i (J.m-3) from temperature 792 !! 793 !! ** Method : Formula (Bitz and Lipscomb, 1999) 794 !!------------------------------------------------------------------- 795 INTEGER, INTENT(in) :: kideb, kiut ! bounds for the spatial loop 796 ! 797 INTEGER :: ji, jk ! dummy loop indices 798 REAL(wp) :: ztmelts ! local scalar 799 !!------------------------------------------------------------------- 800 ! 801 DO jk = 1, nlay_i ! Sea ice energy of melting 802 DO ji = kideb, kiut 803 ztmelts = - tmut * s_i_1d(ji,jk) + rtt 804 rswitch = MAX( 0._wp , SIGN( 1._wp , -(t_i_1d(ji,jk) - rtt) - epsi10 ) ) 805 q_i_1d(ji,jk) = rhoic * ( cpic * ( ztmelts - t_i_1d(ji,jk) ) & 806 & + lfus * ( 1.0 - rswitch * ( ztmelts-rtt ) / MIN( t_i_1d(ji,jk)-rtt, -epsi10 ) ) & 807 & - rcp * ( ztmelts-rtt ) ) 808 END DO 809 END DO 810 DO jk = 1, nlay_s ! Snow energy of melting 811 DO ji = kideb, kiut 812 q_s_1d(ji,jk) = rhosn * ( cpic * ( rtt - t_s_1d(ji,jk) ) + lfus ) 813 END DO 814 END DO 815 ! 816 END SUBROUTINE lim_thd_enmelt 756 817 757 818 #else -
branches/2014/dev_r4650_UKMO14.12_STAND_ALONE_OBSOPER/NEMOGCM/NEMO/LIM_SRC_3/limthd_ent.F90
r4333 r5034 10 10 !! ! 2006-11 (X. Fettweis) Vectorized 11 11 !! 3.0 ! 2008-03 (M. Vancoppenolle) Energy conservation and clean code 12 !! 4.0 ! 2011-02 (G. Madec) dynamical allocation 12 !! 3.4 ! 2011-02 (G. Madec) dynamical allocation 13 !! - ! 2014-05 (C. Rousset) complete rewriting 13 14 !!---------------------------------------------------------------------- 14 15 #if defined key_lim3 … … 22 23 USE domain ! 23 24 USE phycst ! physical constants 25 USE sbc_oce ! Surface boundary condition: ocean fields 24 26 USE ice ! LIM variables 25 27 USE par_ice ! LIM parameters … … 34 36 PRIVATE 35 37 36 PUBLIC lim_thd_ent ! called by lim_thd 37 38 REAL(wp) :: epsi20 = 1.e-20_wp ! constant values 39 REAL(wp) :: epsi10 = 1.e-10_wp ! 40 REAL(wp) :: zzero = 0._wp ! 41 REAL(wp) :: zone = 1._wp ! 38 PUBLIC lim_thd_ent ! called by limthd and limthd_lac 42 39 43 40 !!---------------------------------------------------------------------- … … 48 45 CONTAINS 49 46 50 SUBROUTINE lim_thd_ent( kideb, kiut, jl)47 SUBROUTINE lim_thd_ent( kideb, kiut, qnew ) 51 48 !!------------------------------------------------------------------- 52 49 !! *** ROUTINE lim_thd_ent *** 53 50 !! 54 51 !! ** Purpose : 55 !! This routine computes new vertical grids 56 !! in the ice and in the snow, and consistently redistributes 57 !! temperatures in the snow / ice. 52 !! This routine computes new vertical grids in the ice, 53 !! and consistently redistributes temperatures. 58 54 !! Redistribution is made so as to ensure to energy conservation 59 55 !! … … 61 57 !! ** Method : linear conservative remapping 62 58 !! 63 !! ** Steps : 1) Grid 64 !! 2) Switches 65 !! 3) Snow redistribution 66 !! 4) Ice enthalpy redistribution 67 !! 5) Ice salinity, recover temperature 59 !! ** Steps : 1) cumulative integrals of old enthalpies/thicknesses 60 !! 2) linear remapping on the new layers 61 !! 62 !! ------------ cum0(0) ------------- cum1(0) 63 !! NEW ------------- 64 !! ------------ cum0(1) ==> ------------- 65 !! ... ------------- 66 !! ------------ ------------- 67 !! ------------ cum0(nlay_i+2) ------------- cum1(nlay_i) 68 !! 68 69 !! 69 70 !! References : Bitz & Lipscomb, JGR 99; Vancoppenolle et al., GRL, 2005 70 71 !!------------------------------------------------------------------- 71 72 INTEGER , INTENT(in) :: kideb, kiut ! Start/End point on which the the computation is applied 72 INTEGER , INTENT(in) :: jl ! Thickness cateogry number73 73 74 INTEGER :: ji,jk ! dummy loop indices 75 INTEGER :: ii, ij , & ! dummy indices 76 ntop0 , & ! old layer top index 77 nbot1 , & ! new layer bottom index 78 ntop1 , & ! new layer top index 79 limsum , & ! temporary loop index 80 nlayi0,nlays0 , & ! old number of layers 81 maxnbot0 , & ! old layer bottom index 82 layer0, layer1 ! old/new layer indexes 74 REAL(wp), INTENT(inout), DIMENSION(:,:) :: qnew ! new enthlapies (J.m-3, remapped) 83 75 84 85 REAL(wp) :: & 86 ztmelts , & ! ice melting point 87 zqsnic , & ! enthalpy of snow ice layer 88 zhsnow , & ! temporary snow thickness variable 89 zswitch , & ! dummy switch argument 90 zfac1 , & ! dummy factor 91 zfac2 , & ! dummy factor 92 ztform , & !: bottom formation temperature 93 zaaa , & !: dummy factor 94 zbbb , & !: dummy factor 95 zccc , & !: dummy factor 96 zdiscrim !: dummy factor 97 98 INTEGER, POINTER, DIMENSION(:) :: snswi ! snow switch 99 INTEGER, POINTER, DIMENSION(:) :: nbot0 ! old layer bottom index 100 INTEGER, POINTER, DIMENSION(:) :: icsuind ! ice surface index 101 INTEGER, POINTER, DIMENSION(:) :: icsuswi ! ice surface switch 102 INTEGER, POINTER, DIMENSION(:) :: icboind ! ice bottom index 103 INTEGER, POINTER, DIMENSION(:) :: icboswi ! ice bottom switch 104 INTEGER, POINTER, DIMENSION(:) :: snicind ! snow ice index 105 INTEGER, POINTER, DIMENSION(:) :: snicswi ! snow ice switch 106 INTEGER, POINTER, DIMENSION(:) :: snind ! snow index 76 INTEGER :: ji ! dummy loop indices 77 INTEGER :: jk0, jk1 ! old/new layer indices 107 78 ! 108 REAL(wp), POINTER, DIMENSION(:) :: zh_i ! thickness of an ice layer 109 REAL(wp), POINTER, DIMENSION(:) :: zh_s ! thickness of a snow layer 110 REAL(wp), POINTER, DIMENSION(:) :: zqsnow ! enthalpy of the snow put in snow ice 111 REAL(wp), POINTER, DIMENSION(:) :: zdeltah ! temporary variable 112 REAL(wp), POINTER, DIMENSION(:) :: zqti_in, zqts_in 113 REAL(wp), POINTER, DIMENSION(:) :: zqti_fin, zqts_fin 114 115 REAL(wp), POINTER, DIMENSION(:,:) :: zm0 ! old layer-system vertical cotes 116 REAL(wp), POINTER, DIMENSION(:,:) :: qm0 ! old layer-system heat content 117 REAL(wp), POINTER, DIMENSION(:,:) :: z_s ! new snow system vertical cotes 118 REAL(wp), POINTER, DIMENSION(:,:) :: z_i ! new ice system vertical cotes 119 REAL(wp), POINTER, DIMENSION(:,:) :: zthick0 ! old ice thickness 120 REAL(wp), POINTER, DIMENSION(:,:) :: zhl0 ! old and new layer thicknesses 121 REAL(wp), POINTER, DIMENSION(:,:) :: zrl01 122 123 REAL(wp) :: zinda 79 REAL(wp), POINTER, DIMENSION(:,:) :: zqh_cum0, zh_cum0 ! old cumulative enthlapies and layers interfaces 80 REAL(wp), POINTER, DIMENSION(:,:) :: zqh_cum1, zh_cum1 ! new cumulative enthlapies and layers interfaces 81 REAL(wp), POINTER, DIMENSION(:) :: zhnew ! new layers thicknesses 124 82 !!------------------------------------------------------------------- 125 83 126 CALL wrk_alloc( jpij, snswi, nbot0, icsuind, icsuswi, icboind, icboswi, snicind, snicswi, snind ) ! integer 127 CALL wrk_alloc( jpij, zh_i, zh_s, zqsnow, zdeltah, zqti_in, zqts_in, zqti_fin, zqts_fin ) ! real 128 CALL wrk_alloc( jpij,jkmax+4, zm0, qm0, z_s, z_i, zthick0, zhl0, kjstart = 0 ) 129 CALL wrk_alloc( jkmax+4,jkmax+4, zrl01, kistart = 0, kjstart = 0 ) 84 CALL wrk_alloc( jpij, nlay_i+3, zqh_cum0, zh_cum0, kjstart = 0 ) 85 CALL wrk_alloc( jpij, nlay_i+1, zqh_cum1, zh_cum1, kjstart = 0 ) 86 CALL wrk_alloc( jpij, zhnew ) 130 87 131 zthick0(:,:) = 0._wp 132 zm0 (:,:) = 0._wp 133 qm0 (:,:) = 0._wp 134 zrl01 (:,:) = 0._wp 135 zhl0 (:,:) = 0._wp 136 z_i (:,:) = 0._wp 137 z_s (:,:) = 0._wp 138 139 ! 140 !------------------------------------------------------------------------------| 141 ! 1) Grid | 142 !------------------------------------------------------------------------------| 143 nlays0 = nlay_s 144 nlayi0 = nlay_i 145 146 DO ji = kideb, kiut 147 zh_i(ji) = old_ht_i_b(ji) / REAL( nlay_i ) 148 zh_s(ji) = old_ht_s_b(ji) / REAL( nlay_s ) 149 END DO 150 151 ! 152 !------------------------------------------------------------------------------| 153 ! 2) Switches | 154 !------------------------------------------------------------------------------| 155 ! 2.1 snind(ji), snswi(ji) 156 ! snow surface behaviour : computation of snind(ji)-snswi(ji) 157 ! snind(ji) : index which equals 158 ! 0 if snow is accumulating 159 ! 1 if 1st layer is melting 160 ! 2 if 2nd layer is melting ... 161 DO ji = kideb, kiut 162 snind (ji) = 0 163 zdeltah(ji) = 0._wp 164 ENDDO !ji 165 166 DO jk = 1, nlays0 88 !-------------------------------------------------------------------------- 89 ! 1) Cumulative integral of old enthalpy * thicnkess and layers interfaces 90 !-------------------------------------------------------------------------- 91 zqh_cum0(:,0:nlay_i+2) = 0._wp 92 zh_cum0 (:,0:nlay_i+2) = 0._wp 93 DO jk0 = 1, nlay_i+2 167 94 DO ji = kideb, kiut 168 snind(ji) = jk * NINT(MAX(0.0,SIGN(1.0,-dh_s_tot(ji)-zdeltah(ji)))) & 169 + snind(ji) * (1 - NINT(MAX(0.0,SIGN(1.0,-dh_s_tot(ji)-zdeltah(ji))))) 170 zdeltah(ji)= zdeltah(ji) + zh_s(ji) 171 END DO ! ji 172 END DO ! jk 173 174 ! snswi(ji) : switch which value equals 1 if snow melts 175 ! 0 if not 176 DO ji = kideb, kiut 177 snswi(ji) = MAX(0,NINT(-dh_s_tot(ji)/MAX(epsi20,ABS(dh_s_tot(ji))))) 178 END DO ! ji 179 180 ! 2.2 icsuind(ji), icsuswi(ji) 181 ! ice surface behaviour : computation of icsuind(ji)-icsuswi(ji) 182 ! icsuind(ji) : index which equals 183 ! 0 if nothing happens at the surface 184 ! 1 if first layer is melting 185 ! 2 if 2nd layer is reached by melt ... 186 DO ji = kideb, kiut 187 icsuind(ji) = 0 188 zdeltah(ji) = 0._wp 189 END DO !ji 190 DO jk = 1, nlayi0 191 DO ji = kideb, kiut 192 icsuind(ji) = jk * NINT(MAX(0.0,SIGN(1.0,-dh_i_surf(ji)-zdeltah(ji)))) & 193 + icsuind(ji) * (1 - NINT(MAX(0.0,SIGN(1.0,-dh_i_surf(ji)-zdeltah(ji))))) 194 zdeltah(ji) = zdeltah(ji) + zh_i(ji) 195 END DO ! ji 196 ENDDO !jk 197 198 ! icsuswi(ji) : switch which equals 199 ! 1 if ice melts at the surface 200 ! 0 if not 201 DO ji = kideb, kiut 202 icsuswi(ji) = MAX(0,NINT(-dh_i_surf(ji)/MAX(epsi20 , ABS(dh_i_surf(ji)) ) ) ) 95 zqh_cum0(ji,jk0) = zqh_cum0(ji,jk0-1) + qh_i_old(ji,jk0-1) 96 zh_cum0 (ji,jk0) = zh_cum0 (ji,jk0-1) + h_i_old (ji,jk0-1) 97 ENDDO 203 98 ENDDO 204 99 205 ! 2.3 icboind(ji), icboswi(ji) 206 ! ice bottom behaviour : computation of icboind(ji)-icboswi(ji) 207 ! icboind(ji) : index which equals 208 ! 0 if accretion is on the way 209 ! 1 if last layer has started to melt 210 ! 2 if penultiem layer is melting ... and so on 211 ! N+1 if all layers melt and that snow transforms into ice 212 DO ji = kideb, kiut 213 icboind(ji) = 0 214 zdeltah(ji) = 0._wp 215 END DO 216 DO jk = nlayi0, 1, -1 217 DO ji = kideb, kiut 218 icboind(ji) = (nlayi0+1-jk) * NINT(MAX(0.0,SIGN(1.0,-dh_i_bott(ji)-zdeltah(ji)))) & 219 & + icboind(ji) * (1 - NINT(MAX(0.0,SIGN(1.0,-dh_i_bott(ji)-zdeltah(ji))))) 220 zdeltah(ji) = zdeltah(ji) + zh_i(ji) 221 END DO 222 END DO 223 100 !------------------------------------ 101 ! 2) Interpolation on the new layers 102 !------------------------------------ 103 ! new layer thickesses 224 104 DO ji = kideb, kiut 225 ! case of total ablation with remaining snow 226 IF ( ( ht_i_b(ji) .GT. epsi20 ) .AND. & 227 ( ht_i_b(ji) - dh_snowice(ji) .LT. epsi20 ) ) icboind(ji) = nlay_i + 1 228 END DO 229 230 ! icboswi(ji) : switch which equals 231 ! 1 if ice accretion is on the way 232 ! 0 if ablation is on the way 233 DO ji = kideb, kiut 234 icboswi(ji) = MAX(0,NINT(dh_i_bott(ji) / MAX(epsi20,ABS(dh_i_bott(ji))))) 235 END DO 236 237 ! 2.4 snicind(ji), snicswi(ji) 238 ! snow ice formation : calcul de snicind(ji)-snicswi(ji) 239 ! snicind(ji) : index which equals 240 ! 0 if no snow-ice forms 241 ! 1 if last layer of snow has started to melt 242 ! 2 if penultiem layer ... 243 DO ji = kideb, kiut 244 snicind(ji) = 0 245 zdeltah(ji) = 0._wp 246 END DO 247 DO jk = nlays0, 1, -1 248 DO ji = kideb, kiut 249 snicind(ji) = (nlays0+1-jk) & 250 * NINT(MAX(0.0,SIGN(1.0,dh_snowice(ji)-zdeltah(ji)))) + snicind(ji) & 251 * (1 - NINT(MAX(0.0,SIGN(1.0,dh_snowice(ji)-zdeltah(ji))))) 252 zdeltah(ji) = zdeltah(ji) + zh_s(ji) 253 END DO 254 END DO 255 256 ! snicswi(ji) : switch which equals 257 ! 1 if snow-ice forms 258 ! 0 if not 259 DO ji = kideb, kiut 260 snicswi(ji) = MAX(0,NINT(dh_snowice(ji)/MAX(epsi20,ABS(dh_snowice(ji))))) 105 zhnew(ji) = SUM( h_i_old(ji,0:nlay_i+1) ) / REAL( nlay_i ) 261 106 ENDDO 262 107 263 ! 264 !------------------------------------------------------------------------------| 265 ! 3) Snow redistribution | 266 !------------------------------------------------------------------------------| 267 ! 268 !------------- 269 ! Old profile 270 !------------- 271 272 ! by 'old', it is meant that layers coming from accretion are included, 273 ! and that interfacial layers which were partly melted are reduced 274 275 ! indexes of the vectors 276 !------------------------ 277 ntop0 = 1 278 maxnbot0 = 0 279 280 DO ji = kideb, kiut 281 nbot0(ji) = nlays0 + 1 - snind(ji) + ( 1 - snicind(ji) ) * snicswi(ji) 282 ! cotes of the top of the layers 283 zm0(ji,0) = 0._wp 284 maxnbot0 = MAX ( maxnbot0 , nbot0(ji) ) 285 END DO 286 IF( lk_mpp ) CALL mpp_max( maxnbot0, kcom=ncomm_ice ) 287 288 DO jk = 1, maxnbot0 108 ! new layers interfaces 109 zh_cum1(:,0:nlay_i) = 0._wp 110 DO jk1 = 1, nlay_i 289 111 DO ji = kideb, kiut 290 !change 291 limsum = ( 1 - snswi(ji) ) * ( jk - 1 ) + snswi(ji) * ( jk + snind(ji) - 1 ) 292 limsum = MIN( limsum , nlay_s ) 293 zm0(ji,jk) = dh_s_tot(ji) + zh_s(ji) * REAL( limsum ) 294 END DO 295 END DO 296 297 DO ji = kideb, kiut 298 zm0(ji,nbot0(ji)) = dh_s_tot(ji) - REAL( snicswi(ji) ) * dh_snowice(ji) + zh_s(ji) * REAL( nlays0 ) 299 zm0(ji,1) = dh_s_tot(ji) * REAL( 1 - snswi(ji) ) + REAL( snswi(ji) ) * zm0(ji,1) 300 END DO 301 302 DO jk = ntop0, maxnbot0 303 DO ji = kideb, kiut 304 zthick0(ji,jk) = zm0(ji,jk) - zm0(ji,jk-1) ! layer thickness 305 END DO 306 END DO 307 308 zqts_in(:) = 0._wp 309 310 DO ji = kideb, kiut ! layer heat content 311 qm0 (ji,1) = rhosn * ( cpic * ( rtt - REAL( 1 - snswi(ji) ) * tatm_ice_1d(ji) & 312 & - REAL( snswi(ji) ) * t_s_b (ji,1) ) & 313 & + lfus ) * zthick0(ji,1) 314 zqts_in(ji) = zqts_in(ji) + qm0(ji,1) 315 END DO 316 317 DO jk = 2, maxnbot0 318 DO ji = kideb, kiut 319 limsum = ( 1 - snswi(ji) ) * ( jk - 1 ) + snswi(ji) * ( jk + snind(ji) - 1 ) 320 limsum = MIN( limsum , nlay_s ) 321 qm0(ji,jk) = rhosn * ( cpic * ( rtt - t_s_b(ji,limsum) ) + lfus ) * zthick0(ji,jk) 322 zswitch = 1.0 - MAX (0.0, SIGN ( 1.0, - ht_s_b(ji) ) ) 323 zqts_in(ji) = zqts_in(ji) + REAL( 1 - snswi(ji) ) * qm0(ji,jk) * zswitch 324 END DO ! jk 325 END DO ! ji 326 327 !------------------------------------------------ 328 ! Energy given by the snow in snow-ice formation 329 !------------------------------------------------ 330 ! zqsnow, enthalpy of the flooded snow 331 DO ji = kideb, kiut 332 zqsnow (ji) = rhosn * lfus 333 zdeltah(ji) = 0._wp 334 END DO 335 336 DO jk = nlays0, 1, -1 337 DO ji = kideb, kiut 338 zhsnow = MAX( 0._wp , dh_snowice(ji)-zdeltah(ji) ) 339 zqsnow (ji) = zqsnow (ji) + rhosn*cpic*(rtt-t_s_b(ji,jk)) 340 zdeltah(ji) = zdeltah(ji) + zh_s(ji) 341 END DO 342 END DO 343 344 DO ji = kideb, kiut 345 zqsnow(ji) = zqsnow(ji) * dh_snowice(ji) 346 END DO 347 348 !------------------ 349 ! new snow profile 350 !------------------ 351 352 !-------------- 353 ! Vector index 354 !-------------- 355 ntop1 = 1 356 nbot1 = nlay_s 357 358 !------------------- 359 ! Layer coordinates 360 !------------------- 361 DO ji = kideb, kiut 362 zh_s(ji) = ht_s_b(ji) / REAL( nlay_s ) 363 z_s(ji,0) = 0._wp 112 zh_cum1(ji,jk1) = zh_cum1(ji,jk1-1) + zhnew(ji) 113 ENDDO 364 114 ENDDO 365 115 366 DO jk = 1, nlay_s 116 zqh_cum1(:,0:nlay_i) = 0._wp 117 ! new cumulative q*h => linear interpolation 118 DO jk0 = 1, nlay_i+1 119 DO jk1 = 1, nlay_i-1 120 DO ji = kideb, kiut 121 IF( zh_cum1(ji,jk1) <= zh_cum0(ji,jk0) .AND. zh_cum1(ji,jk1) > zh_cum0(ji,jk0-1) ) THEN 122 zqh_cum1(ji,jk1) = ( zqh_cum0(ji,jk0-1) * ( zh_cum0(ji,jk0) - zh_cum1(ji,jk1 ) ) + & 123 & zqh_cum0(ji,jk0 ) * ( zh_cum1(ji,jk1) - zh_cum0(ji,jk0-1) ) ) & 124 & / ( zh_cum0(ji,jk0) - zh_cum0(ji,jk0-1) ) 125 ENDIF 126 ENDDO 127 ENDDO 128 ENDDO 129 ! to ensure that total heat content is strictly conserved, set: 130 zqh_cum1(:,nlay_i) = zqh_cum0(:,nlay_i+2) 131 132 ! new enthalpies 133 DO jk1 = 1, nlay_i 367 134 DO ji = kideb, kiut 368 z_s(ji,jk) = zh_s(ji) * REAL( jk ) 369 END DO 370 END DO 371 372 !----------------- 373 ! Layer thickness 374 !----------------- 375 DO layer0 = ntop0, maxnbot0 376 DO ji = kideb, kiut 377 zhl0(ji,layer0) = zm0(ji,layer0) - zm0(ji,layer0-1) 378 END DO 379 END DO 380 381 DO layer1 = ntop1, nbot1 382 DO ji = kideb, kiut 383 q_s_b(ji,layer1) = 0._wp 384 END DO 385 END DO 386 387 !---------------- 388 ! Weight factors 389 !---------------- 390 DO layer0 = ntop0, maxnbot0 391 DO layer1 = ntop1, nbot1 392 DO ji = kideb, kiut 393 zinda = MAX( 0._wp, SIGN( 1._wp , zhl0(ji,layer0) - epsi10 ) ) 394 zrl01(layer1,layer0) = zinda * MAX(0.0,( MIN(zm0(ji,layer0),z_s(ji,layer1)) & 395 & - MAX(zm0(ji,layer0-1), z_s(ji,layer1-1))) / MAX(zhl0(ji,layer0),epsi10)) 396 q_s_b(ji,layer1) = q_s_b(ji,layer1) + zrl01(layer1,layer0)*qm0(ji,layer0) & 397 & * MAX(0.0,SIGN(1.0,REAL(nbot0(ji)-layer0))) 398 END DO 399 END DO 400 END DO 401 402 ! Heat conservation 403 zqts_fin(:) = 0._wp 404 DO jk = 1, nlay_s 405 DO ji = kideb, kiut 406 zqts_fin(ji) = zqts_fin(ji) + q_s_b(ji,jk) 407 END DO 408 END DO 409 410 IF ( con_i .AND. jiindex_1d > 0 ) THEN 411 DO ji = kideb, kiut 412 IF ( ABS ( zqts_in(ji) - zqts_fin(ji) ) * r1_rdtice > 1.0e-6 ) THEN 413 ii = MOD( npb(ji) - 1, jpi ) + 1 414 ij = ( npb(ji) - 1 ) / jpi + 1 415 WRITE(numout,*) ' violation of heat conservation : ', ABS ( zqts_in(ji) - zqts_fin(ji) ) * r1_rdtice 416 WRITE(numout,*) ' ji, jj : ', ii, ij 417 WRITE(numout,*) ' ht_s_b : ', ht_s_b(ji) 418 WRITE(numout,*) ' zqts_in : ', zqts_in (ji) * r1_rdtice 419 WRITE(numout,*) ' zqts_fin : ', zqts_fin(ji) * r1_rdtice 420 WRITE(numout,*) ' dh_snowice : ', dh_snowice(ji) 421 WRITE(numout,*) ' dh_s_tot : ', dh_s_tot(ji) 422 WRITE(numout,*) ' snswi : ', snswi(ji) 423 ENDIF 424 END DO 425 ENDIF 426 427 !--------------------- 428 ! Recover heat content 429 !--------------------- 430 DO jk = 1, nlay_s 431 DO ji = kideb, kiut 432 zinda = MAX( 0._wp, SIGN( 1._wp , zh_s(ji) - epsi10 ) ) 433 q_s_b(ji,jk) = zinda * q_s_b(ji,jk) / MAX( zh_s(ji) , epsi10 ) 434 END DO !ji 435 END DO !jk 436 437 !--------------------- 438 ! Recover temperature 439 !--------------------- 440 zfac1 = 1. / ( rhosn * cpic ) 441 zfac2 = lfus / cpic 442 DO jk = 1, nlay_s 443 DO ji = kideb, kiut 444 zswitch = MAX ( 0.0 , SIGN ( 1.0, - ht_s_b(ji) ) ) 445 t_s_b(ji,jk) = rtt + ( 1.0 - zswitch ) * ( - zfac1 * q_s_b(ji,jk) + zfac2 ) 446 END DO 447 END DO 448 ! 449 !------------------------------------------------------------------------------| 450 ! 4) Ice redistribution | 451 !------------------------------------------------------------------------------| 452 ! 453 !------------- 454 ! OLD PROFILE 455 !------------- 456 457 !---------------- 458 ! Vector indexes 459 !---------------- 460 ntop0 = 1 461 maxnbot0 = 0 462 463 DO ji = kideb, kiut 464 ! reference number of the bottommost layer 465 nbot0(ji) = MAX( 1 , MIN( nlayi0 + ( 1 - icboind(ji) ) + & 466 & ( 1 - icsuind(ji) ) * icsuswi(ji) + snicswi(ji) , nlay_i + 2 ) ) 467 ! maximum reference number of the bottommost layer over all domain 468 maxnbot0 = MAX( maxnbot0 , nbot0(ji) ) 469 END DO 470 471 !------------------------- 472 ! Cotes of old ice layers 473 !------------------------- 474 zm0(:,0) = 0._wp 475 476 DO jk = 1, maxnbot0 477 DO ji = kideb, kiut 478 ! jk goes from 1 to nbot0 479 ! the ice layer number goes from 1 to nlay_i 480 ! limsum is the real ice layer number corresponding to present jk 481 limsum = ( (icsuswi(ji)*(icsuind(ji)+jk-1) + & 482 (1-icsuswi(ji))*jk))*(1-snicswi(ji)) + (jk-1)*snicswi(ji) 483 zm0(ji,jk)= REAL(icsuswi(ji))*dh_i_surf(ji) + REAL(snicswi(ji))*dh_snowice(ji) & 484 + REAL(limsum) * zh_i(ji) 485 END DO 486 END DO 487 488 DO ji = kideb, kiut 489 zm0(ji,nbot0(ji)) = REAL(icsuswi(ji))*dh_i_surf(ji) + REAL(snicswi(ji))*dh_snowice(ji) + dh_i_bott(ji) & 490 + zh_i(ji) * REAL(nlayi0) 491 zm0(ji,1) = REAL(snicswi(ji))*dh_snowice(ji) + REAL(1-snicswi(ji))*zm0(ji,1) 492 END DO 493 494 !----------------------------- 495 ! Thickness of old ice layers 496 !----------------------------- 497 DO jk = ntop0, maxnbot0 498 DO ji = kideb, kiut 499 zthick0(ji,jk) = zm0(ji,jk) - zm0(ji,jk-1) 500 END DO 501 END DO 502 503 !--------------------------- 504 ! Inner layers heat content 505 !--------------------------- 506 qm0(:,:) = 0.0 507 zqti_in(:) = 0.0 508 509 DO jk = ntop0, maxnbot0 510 DO ji = kideb, kiut 511 limsum = MAX(1,MIN(snicswi(ji)*(jk-1) + icsuswi(ji)*(jk-1+icsuind(ji)) + & 512 (1-icsuswi(ji))*(1-snicswi(ji))*jk,nlay_i)) 513 ztmelts = -tmut * s_i_b(ji,limsum) + rtt 514 qm0(ji,jk) = rhoic * ( cpic * (ztmelts-t_i_b(ji,limsum)) + lfus * ( 1.0-(ztmelts-rtt)/ & 515 MIN((t_i_b(ji,limsum)-rtt),-epsi20) ) - rcp*(ztmelts-rtt) ) & 516 * zthick0(ji,jk) 517 END DO 518 END DO 519 520 !---------------------------- 521 ! Bottom layers heat content 522 !---------------------------- 523 DO ji = kideb, kiut 524 ztmelts = REAL( 1 - icboswi(ji) ) * (-tmut * s_i_b (ji,nlayi0) ) & ! case of melting ice 525 & + REAL( icboswi(ji) ) * (-tmut * s_i_new(ji) ) & ! case of forming ice 526 & + rtt ! in Kelvin 527 528 ! bottom formation temperature 529 ztform = t_i_b(ji,nlay_i) 530 IF( num_sal == 2 ) ztform = t_bo_b(ji) 531 qm0(ji,nbot0(ji)) = REAL( 1 - icboswi(ji) )*qm0(ji,nbot0(ji)) & ! case of melting ice 532 & + REAL( icboswi(ji) ) * rhoic * ( cpic*(ztmelts-ztform) & ! case of forming ice 533 + lfus *( 1.0-(ztmelts-rtt) / MIN ( (ztform-rtt) , - epsi10 ) ) & 534 - rcp*(ztmelts-rtt) ) * zthick0(ji,nbot0(ji) ) 535 END DO 536 537 !----------------------------- 538 ! Snow ice layer heat content 539 !----------------------------- 540 DO ji = kideb, kiut 541 ! energy of the flooding seawater 542 zqsnic = rau0 * rcp * ( rtt - t_bo_b(ji) ) * dh_snowice(ji) * & 543 (rhoic - rhosn) / rhoic * REAL(snicswi(ji)) ! generally positive 544 ! Heat conservation diagnostic 545 qt_i_in(ji,jl) = qt_i_in(ji,jl) + zqsnic 546 547 qldif_1d(ji) = qldif_1d(ji) + zqsnic * a_i_b(ji) 548 549 ! enthalpy of the newly formed snow-ice layer 550 ! = enthalpy of snow + enthalpy of frozen water 551 zqsnic = zqsnow(ji) + zqsnic 552 qm0(ji,1) = REAL(snicswi(ji)) * zqsnic + REAL( 1 - snicswi(ji) ) * qm0(ji,1) 553 554 END DO ! ji 555 556 DO jk = ntop0, maxnbot0 557 DO ji = kideb, kiut 558 ! Heat conservation 559 zqti_in(ji) = zqti_in(ji) + qm0(ji,jk) * MAX( 0.0 , SIGN(1.0,ht_i_b(ji)-epsi10) ) & 560 & * MAX( 0.0 , SIGN( 1. , REAL(nbot0(ji) - jk) ) ) 561 END DO 562 END DO 563 564 !------------- 565 ! NEW PROFILE 566 !------------- 567 568 !--------------- 569 ! Vectors index 570 !--------------- 571 ntop1 = 1 572 nbot1 = nlay_i 573 574 !------------------ 575 ! Layers thickness 576 !------------------ 577 DO ji = kideb, kiut 578 zh_i(ji) = ht_i_b(ji) / REAL( nlay_i ) 135 rswitch = 1._wp - MAX( 0._wp , SIGN( 1._wp , - zhnew(ji) + epsi10 ) ) 136 qnew(ji,jk1) = rswitch * ( zqh_cum1(ji,jk1) - zqh_cum1(ji,jk1-1) ) / MAX( zhnew(ji), epsi10 ) 137 ENDDO 579 138 ENDDO 580 139 581 !------------- 582 ! Layer cotes 583 !------------- 584 z_i(:,0) = 0._wp 585 DO jk = 1, nlay_i 586 DO ji = kideb, kiut 587 z_i(ji,jk) = zh_i(ji) * jk 588 END DO 140 ! --- diag error on heat remapping --- ! 141 ! comment: if input h_i_old and qh_i_old are already multiplied by a_i (as in limthd_lac), 142 ! then we should not (* a_i) again but not important since this is just to check that remap error is ~0 143 DO ji = kideb, kiut 144 hfx_err_rem_1d(ji) = hfx_err_rem_1d(ji) + a_i_1d(ji) * r1_rdtice * & 145 & ( SUM( qnew(ji,1:nlay_i) ) * zhnew(ji) - SUM( qh_i_old(ji,0:nlay_i+1) ) ) 589 146 END DO 590 591 !--thicknesses of the layers 592 DO layer0 = ntop0, maxnbot0 593 DO ji = kideb, kiut 594 zhl0(ji,layer0) = zm0(ji,layer0) - zm0(ji,layer0-1) ! thicknesses of the layers 595 END DO 596 END DO 597 598 !------------------------ 599 ! Weights for relayering 600 !------------------------ 601 q_i_b(:,:) = 0._wp 602 DO layer0 = ntop0, maxnbot0 603 DO layer1 = ntop1, nbot1 604 DO ji = kideb, kiut 605 zinda = MAX( 0._wp, SIGN( 1._wp , zhl0(ji,layer0) - epsi10 ) ) 606 zrl01(layer1,layer0) = zinda * MAX(0.0,( MIN(zm0(ji,layer0),z_i(ji,layer1)) & 607 - MAX(zm0(ji,layer0-1), z_i(ji,layer1-1)))/MAX(zhl0(ji,layer0),epsi10)) 608 q_i_b(ji,layer1) = q_i_b(ji,layer1) & 609 + zrl01(layer1,layer0)*qm0(ji,layer0) & 610 * MAX(0.0,SIGN(1.0,ht_i_b(ji)-epsi10)) & 611 * MAX(0.0,SIGN(1.0,REAL(nbot0(ji)-layer0))) 612 END DO 613 END DO 614 END DO 615 616 !------------------------- 617 ! Heat conservation check 618 !------------------------- 619 zqti_fin(:) = 0._wp 620 DO jk = 1, nlay_i 621 DO ji = kideb, kiut 622 zqti_fin(ji) = zqti_fin(ji) + q_i_b(ji,jk) 623 END DO 624 END DO 147 625 148 ! 626 IF ( con_i .AND. jiindex_1d > 0 ) THEN 627 DO ji = kideb, kiut 628 IF ( ABS ( zqti_in(ji) - zqti_fin(ji) ) * r1_rdtice > 1.0e-6 ) THEN 629 ii = MOD( npb(ji) - 1, jpi ) + 1 630 ij = ( npb(ji) - 1 ) / jpi + 1 631 WRITE(numout,*) ' violation of heat conservation : ', ABS ( zqti_in(ji) - zqti_fin(ji) ) * r1_rdtice 632 WRITE(numout,*) ' ji, jj : ', ii, ij 633 WRITE(numout,*) ' ht_i_b : ', ht_i_b(ji) 634 WRITE(numout,*) ' zqti_in : ', zqti_in (ji) * r1_rdtice 635 WRITE(numout,*) ' zqti_fin : ', zqti_fin(ji) * r1_rdtice 636 WRITE(numout,*) ' dh_i_bott: ', dh_i_bott(ji) 637 WRITE(numout,*) ' dh_i_surf: ', dh_i_surf(ji) 638 WRITE(numout,*) ' dh_snowice:', dh_snowice(ji) 639 WRITE(numout,*) ' icsuswi : ', icsuswi(ji) 640 WRITE(numout,*) ' icboswi : ', icboswi(ji) 641 WRITE(numout,*) ' snicswi : ', snicswi(ji) 642 ENDIF 643 END DO 644 ENDIF 645 646 !---------------------- 647 ! Recover heat content 648 !---------------------- 649 DO jk = 1, nlay_i 650 DO ji = kideb, kiut 651 zinda = MAX( 0._wp, SIGN( 1._wp , zh_i(ji) - epsi10 ) ) 652 q_i_b(ji,jk) = zinda * q_i_b(ji,jk) / MAX( zh_i(ji) , epsi10 ) 653 END DO !ji 654 END DO !jk 655 656 ! Heat conservation 657 zqti_fin(:) = 0.0 658 DO jk = 1, nlay_i 659 DO ji = kideb, kiut 660 zqti_fin(ji) = zqti_fin(ji) + q_i_b(ji,jk) * zh_i(ji) 661 END DO 662 END DO 663 664 ! 665 !------------------------------------------------------------------------------| 666 ! 5) Update salinity and recover temperature | 667 !------------------------------------------------------------------------------| 668 ! 669 ! Update salinity (basal entrapment, snow ice formation) 670 DO ji = kideb, kiut 671 sm_i_b(ji) = sm_i_b(ji) + dsm_i_se_1d(ji) + dsm_i_si_1d(ji) 672 END DO !ji 673 674 ! Recover temperature 675 DO jk = 1, nlay_i 676 DO ji = kideb, kiut 677 ztmelts = -tmut*s_i_b(ji,jk) + rtt 678 !Conversion q(S,T) -> T (second order equation) 679 zaaa = cpic 680 zbbb = ( rcp - cpic ) * ( ztmelts - rtt ) + q_i_b(ji,jk) / rhoic - lfus 681 zccc = lfus * ( ztmelts - rtt ) 682 zdiscrim = SQRT( MAX(zbbb*zbbb - 4.0*zaaa*zccc,0.0) ) 683 t_i_b(ji,jk) = rtt - ( zbbb + zdiscrim ) / ( 2.0 *zaaa ) 684 END DO !ji 685 686 END DO !jk 687 ! 688 CALL wrk_dealloc( jpij, snswi, nbot0, icsuind, icsuswi, icboind, icboswi, snicind, snicswi, snind ) ! integer 689 CALL wrk_dealloc( jpij, zh_i, zh_s, zqsnow, zdeltah, zqti_in, zqts_in, zqti_fin, zqts_fin ) ! real 690 CALL wrk_dealloc( jpij,jkmax+4, zm0, qm0, z_s, z_i, zthick0, zhl0, kjstart = 0 ) 691 CALL wrk_dealloc( jkmax+4,jkmax+4, zrl01, kistart = 0, kjstart = 0 ) 149 CALL wrk_dealloc( jpij, nlay_i+3, zqh_cum0, zh_cum0, kjstart = 0 ) 150 CALL wrk_dealloc( jpij, nlay_i+1, zqh_cum1, zh_cum1, kjstart = 0 ) 151 CALL wrk_dealloc( jpij, zhnew ) 692 152 ! 693 153 END SUBROUTINE lim_thd_ent -
branches/2014/dev_r4650_UKMO14.12_STAND_ALONE_OBSOPER/NEMOGCM/NEMO/LIM_SRC_3/limthd_lac.F90
r4333 r5034 29 29 USE lib_mpp ! MPP library 30 30 USE wrk_nemo ! work arrays 31 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 31 32 USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) 33 USE limthd_ent 32 34 33 35 IMPLICIT NONE … … 35 37 36 38 PUBLIC lim_thd_lac ! called by lim_thd 37 38 REAL(wp) :: epsi10 = 1.e-10_wp !39 REAL(wp) :: zzero = 0._wp !40 REAL(wp) :: zone = 1._wp !41 39 42 40 !!---------------------------------------------------------------------- … … 71 69 !! - Computation of variation of ice volume and mass 72 70 !! - Computation of frldb after lateral accretion and 73 !! update ht_s_ b, ht_i_band tbif_1d(:,:)71 !! update ht_s_1d, ht_i_1d and tbif_1d(:,:) 74 72 !!------------------------------------------------------------------------ 75 INTEGER :: ji,jj,jk,jl ,jm! dummy loop indices76 INTEGER :: layer, nbpac! local integers77 INTEGER :: ii, ij, iter ! - -78 REAL(wp) :: ztmelts, zdv, z qold, zfrazb, zweight, zalphai, zindb, zinda, zde! local scalars73 INTEGER :: ji,jj,jk,jl ! dummy loop indices 74 INTEGER :: nbpac ! local integers 75 INTEGER :: ii, ij, iter ! - - 76 REAL(wp) :: ztmelts, zdv, zfrazb, zweight, zde ! local scalars 79 77 REAL(wp) :: zgamafr, zvfrx, zvgx, ztaux, ztwogp, zf , zhicol_new ! - - 80 78 REAL(wp) :: ztenagm, zvfry, zvgy, ztauy, zvrel2, zfp, zsqcd , zhicrit ! - - 81 79 LOGICAL :: iterate_frazil ! iterate frazil ice collection thickness 82 80 CHARACTER (len = 15) :: fieldid 83 ! 84 INTEGER , POINTER, DIMENSION(:) :: zcatac ! indexes of categories where new ice grows 81 82 REAL(wp) :: zQm ! enthalpy exchanged with the ocean (J/m2, >0 towards ocean) 83 REAL(wp) :: zEi ! sea ice specific enthalpy (J/kg) 84 REAL(wp) :: zEw ! seawater specific enthalpy (J/kg) 85 REAL(wp) :: zfmdt ! mass flux x time step (kg/m2, >0 towards ocean) 86 87 REAL(wp) :: zv_newfra 88 89 INTEGER , POINTER, DIMENSION(:) :: jcat ! indexes of categories where new ice grows 85 90 REAL(wp), POINTER, DIMENSION(:) :: zswinew ! switch for new ice or not 86 91 … … 93 98 REAL(wp), POINTER, DIMENSION(:) :: zdv_res ! residual volume in case of excessive heat budget 94 99 REAL(wp), POINTER, DIMENSION(:) :: zda_res ! residual area in case of excessive heat budget 95 REAL(wp), POINTER, DIMENSION(:) :: zat_i_ac ! total ice fraction 96 REAL(wp), POINTER, DIMENSION(:) :: zat_i_lev ! total ice fraction for level ice only (type 1) 97 REAL(wp), POINTER, DIMENSION(:) :: zdh_frazb ! accretion of frazil ice at the ice bottom 98 REAL(wp), POINTER, DIMENSION(:) :: zvrel_ac ! relative ice / frazil velocity (1D vector) 99 100 REAL(wp), POINTER, DIMENSION(:,:) :: zhice_old ! previous ice thickness 101 REAL(wp), POINTER, DIMENSION(:,:) :: zdummy ! dummy thickness of new ice 102 REAL(wp), POINTER, DIMENSION(:,:) :: zdhicbot ! thickness of new ice which is accreted vertically 103 REAL(wp), POINTER, DIMENSION(:,:) :: zv_old ! old volume of ice in category jl 104 REAL(wp), POINTER, DIMENSION(:,:) :: za_old ! old area of ice in category jl 105 REAL(wp), POINTER, DIMENSION(:,:) :: za_i_ac ! 1-D version of a_i 106 REAL(wp), POINTER, DIMENSION(:,:) :: zv_i_ac ! 1-D version of v_i 107 REAL(wp), POINTER, DIMENSION(:,:) :: zoa_i_ac ! 1-D version of oa_i 108 REAL(wp), POINTER, DIMENSION(:,:) :: zsmv_i_ac ! 1-D version of smv_i 109 110 REAL(wp), POINTER, DIMENSION(:,:,:) :: ze_i_ac !: 1-D version of e_i 111 112 REAL(wp), POINTER, DIMENSION(:) :: zqbgow ! heat budget of the open water (negative) 113 REAL(wp), POINTER, DIMENSION(:) :: zdhex ! excessively thick accreted sea ice (hlead-hice) 114 115 REAL(wp), POINTER, DIMENSION(:,:,:) :: zqm0 ! old layer-system heat content 116 REAL(wp), POINTER, DIMENSION(:,:,:) :: zthick0 ! old ice thickness 117 118 REAL(wp), POINTER, DIMENSION(:,:) :: vt_i_init, vt_i_final ! ice volume summed over categories 119 REAL(wp), POINTER, DIMENSION(:,:) :: vt_s_init, vt_s_final ! snow volume summed over categories 120 REAL(wp), POINTER, DIMENSION(:,:) :: et_i_init, et_i_final ! ice energy summed over categories 121 REAL(wp), POINTER, DIMENSION(:,:) :: et_s_init ! snow energy summed over categories 100 REAL(wp), POINTER, DIMENSION(:) :: zat_i_1d ! total ice fraction 101 REAL(wp), POINTER, DIMENSION(:) :: zv_frazb ! accretion of frazil ice at the ice bottom 102 REAL(wp), POINTER, DIMENSION(:) :: zvrel_1d ! relative ice / frazil velocity (1D vector) 103 104 REAL(wp), POINTER, DIMENSION(:,:) :: zv_b ! old volume of ice in category jl 105 REAL(wp), POINTER, DIMENSION(:,:) :: za_b ! old area of ice in category jl 106 REAL(wp), POINTER, DIMENSION(:,:) :: za_i_1d ! 1-D version of a_i 107 REAL(wp), POINTER, DIMENSION(:,:) :: zv_i_1d ! 1-D version of v_i 108 REAL(wp), POINTER, DIMENSION(:,:) :: zoa_i_1d ! 1-D version of oa_i 109 REAL(wp), POINTER, DIMENSION(:,:) :: zsmv_i_1d ! 1-D version of smv_i 110 111 REAL(wp), POINTER, DIMENSION(:,:,:) :: ze_i_1d !: 1-D version of e_i 112 122 113 REAL(wp), POINTER, DIMENSION(:,:) :: zvrel ! relative ice / frazil velocity 123 114 !!-----------------------------------------------------------------------! 124 115 125 CALL wrk_alloc( jpij, zcatac) ! integer116 CALL wrk_alloc( jpij, jcat ) ! integer 126 117 CALL wrk_alloc( jpij, zswinew, zv_newice, za_newice, zh_newice, ze_newice, zs_newice, zo_newice ) 127 CALL wrk_alloc( jpij, zdv_res, zda_res, zat_i_ac, zat_i_lev, zdh_frazb, zvrel_ac, zqbgow, zdhex ) 128 CALL wrk_alloc( jpij,jpl, zhice_old, zdummy, zdhicbot, zv_old, za_old, za_i_ac, zv_i_ac, zoa_i_ac, zsmv_i_ac ) 129 CALL wrk_alloc( jpij,jkmax,jpl, ze_i_ac ) 130 CALL wrk_alloc( jpij,jkmax+1,jpl, zqm0, zthick0 ) 131 CALL wrk_alloc( jpi,jpj, vt_i_init, vt_i_final, vt_s_init, vt_s_final, et_i_init, et_i_final, et_s_init, zvrel ) 132 133 et_i_init(:,:) = 0._wp 134 et_s_init(:,:) = 0._wp 135 vt_i_init(:,:) = 0._wp 136 vt_s_init(:,:) = 0._wp 137 138 !------------------------------------------------------------------------------! 139 ! 1) Conservation check and changes in each ice category 140 !------------------------------------------------------------------------------! 141 IF( con_i ) THEN 142 CALL lim_column_sum ( jpl, v_i , vt_i_init) 143 CALL lim_column_sum ( jpl, v_s , vt_s_init) 144 CALL lim_column_sum_energy ( jpl, nlay_i , e_i , et_i_init) 145 CALL lim_column_sum ( jpl, e_s(:,:,1,:) , et_s_init) 146 ENDIF 118 CALL wrk_alloc( jpij, zdv_res, zda_res, zat_i_1d, zv_frazb, zvrel_1d ) 119 CALL wrk_alloc( jpij,jpl, zv_b, za_b, za_i_1d, zv_i_1d, zoa_i_1d, zsmv_i_1d ) 120 CALL wrk_alloc( jpij,nlay_i+1,jpl, ze_i_1d ) 121 CALL wrk_alloc( jpi,jpj, zvrel ) 147 122 148 123 !------------------------------------------------------------------------------| … … 154 129 DO ji = 1, jpi 155 130 !Energy of melting q(S,T) [J.m-3] 156 e_i(ji,jj,jk,jl) = e_i(ji,jj,jk,jl) / MAX( area(ji,jj) * v_i(ji,jj,jl) , epsi10 ) * REAL( nlay_i ) 157 zindb = 1._wp - MAX( 0._wp , SIGN( 1._wp , -v_i(ji,jj,jl) + epsi10 ) ) !0 if no ice and 1 if yes 158 e_i(ji,jj,jk,jl) = e_i(ji,jj,jk,jl) * unit_fac * zindb 131 rswitch = 1._wp - MAX( 0._wp , SIGN( 1._wp , -v_i(ji,jj,jl) + epsi10 ) ) !0 if no ice and 1 if yes 132 e_i(ji,jj,jk,jl) = rswitch * e_i(ji,jj,jk,jl) & 133 & / ( area(ji,jj) * MAX( v_i(ji,jj,jl) , epsi10 ) ) * REAL( nlay_i, wp ) 134 e_i(ji,jj,jk,jl) = e_i(ji,jj,jk,jl) * unit_fac 159 135 END DO 160 136 END DO … … 179 155 180 156 ! Default new ice thickness 181 hicol(:,:) = hiccrit (1)182 183 IF( fraz_swi == 1 ._wp) THEN157 hicol(:,:) = hiccrit 158 159 IF( fraz_swi == 1 ) THEN 184 160 185 161 !-------------------- … … 193 169 zgamafr = 0.03 194 170 195 DO jj = 1, jpj 196 DO ji = 1, jpi 197 198 IF ( tms(ji,jj) * ( qcmif(ji,jj) - qldif(ji,jj) ) > 0.e0 ) THEN 171 DO jj = 2, jpj 172 DO ji = 2, jpi 173 IF ( qlead(ji,jj) < 0._wp ) THEN 199 174 !------------- 200 175 ! Wind stress … … 206 181 & + vtau_ice(ji ,jj ) * tmv(ji ,jj ) ) * 0.5_wp 207 182 ! Square root of wind stress 208 ztenagm = SQRT( SQRT( ztaux * ztaux + ztauy * ztauy) )183 ztenagm = SQRT( SQRT( ztaux**2 + ztauy**2 ) ) 209 184 210 185 !--------------------- 211 186 ! Frazil ice velocity 212 187 !--------------------- 213 zvfrx = zgamafr * zsqcd * ztaux / MAX(ztenagm,epsi10) 214 zvfry = zgamafr * zsqcd * ztauy / MAX(ztenagm,epsi10) 188 rswitch = MAX( 0._wp, SIGN( 1._wp , ztenagm - epsi10 ) ) 189 zvfrx = rswitch * zgamafr * zsqcd * ztaux / MAX( ztenagm, epsi10 ) 190 zvfry = rswitch * zgamafr * zsqcd * ztauy / MAX( ztenagm, epsi10 ) 215 191 216 192 !------------------- … … 218 194 !------------------- 219 195 ! C-grid ice velocity 220 zindb = MAX( 0._wp, SIGN( 1._wp , at_i(ji,jj) ) ) 221 zvgx = zindb * ( u_ice(ji-1,jj ) * tmu(ji-1,jj ) & 222 & + u_ice(ji,jj ) * tmu(ji ,jj ) ) * 0.5_wp 223 zvgy = zindb * ( v_ice(ji ,jj-1) * tmv(ji ,jj-1) & 224 & + v_ice(ji,jj ) * tmv(ji ,jj ) ) * 0.5_wp 196 rswitch = MAX( 0._wp, SIGN( 1._wp , at_i(ji,jj) ) ) 197 zvgx = rswitch * ( u_ice(ji-1,jj ) * tmu(ji-1,jj ) + u_ice(ji,jj) * tmu(ji,jj) ) * 0.5_wp 198 zvgy = rswitch * ( v_ice(ji ,jj-1) * tmv(ji ,jj-1) + v_ice(ji,jj) * tmv(ji,jj) ) * 0.5_wp 225 199 226 200 !----------------------------------- … … 264 238 END DO ! loop on ji ends 265 239 END DO ! loop on jj ends 240 ! 241 CALL lbc_lnk( zvrel(:,:), 'T', 1. ) 242 CALL lbc_lnk( hicol(:,:), 'T', 1. ) 266 243 267 244 ENDIF ! End of computation of frazil ice collection thickness … … 276 253 ! This occurs if open water energy budget is negative 277 254 nbpac = 0 255 npac(:) = 0 256 ! 278 257 DO jj = 1, jpj 279 258 DO ji = 1, jpi 280 IF ( tms(ji,jj) * ( qcmif(ji,jj) - qldif(ji,jj) ) >0._wp ) THEN259 IF ( qlead(ji,jj) < 0._wp ) THEN 281 260 nbpac = nbpac + 1 282 261 npac( nbpac ) = (jj - 1) * jpi + ji … … 290 269 DO ji = mi0(jiindx), mi1(jiindx) 291 270 DO jj = mj0(jjindx), mj1(jjindx) 292 IF ( tms(ji,jj) * ( qcmif(ji,jj) - qldif(ji,jj) ) >0._wp ) THEN271 IF ( qlead(ji,jj) < 0._wp ) THEN 293 272 jiindex_1d = (jj - 1) * jpi + ji 294 273 ENDIF … … 307 286 IF ( nbpac > 0 ) THEN 308 287 309 CALL tab_2d_1d( nbpac, zat_i_ ac(1:nbpac) , at_i , jpi, jpj, npac(1:nbpac) )288 CALL tab_2d_1d( nbpac, zat_i_1d (1:nbpac) , at_i , jpi, jpj, npac(1:nbpac) ) 310 289 DO jl = 1, jpl 311 CALL tab_2d_1d( nbpac, za_i_ ac(1:nbpac,jl), a_i (:,:,jl), jpi, jpj, npac(1:nbpac) )312 CALL tab_2d_1d( nbpac, zv_i_ ac(1:nbpac,jl), v_i (:,:,jl), jpi, jpj, npac(1:nbpac) )313 CALL tab_2d_1d( nbpac, zoa_i_ ac(1:nbpac,jl), oa_i (:,:,jl), jpi, jpj, npac(1:nbpac) )314 CALL tab_2d_1d( nbpac, zsmv_i_ ac(1:nbpac,jl), smv_i(:,:,jl), jpi, jpj, npac(1:nbpac) )290 CALL tab_2d_1d( nbpac, za_i_1d (1:nbpac,jl), a_i (:,:,jl), jpi, jpj, npac(1:nbpac) ) 291 CALL tab_2d_1d( nbpac, zv_i_1d (1:nbpac,jl), v_i (:,:,jl), jpi, jpj, npac(1:nbpac) ) 292 CALL tab_2d_1d( nbpac, zoa_i_1d (1:nbpac,jl), oa_i (:,:,jl), jpi, jpj, npac(1:nbpac) ) 293 CALL tab_2d_1d( nbpac, zsmv_i_1d(1:nbpac,jl), smv_i(:,:,jl), jpi, jpj, npac(1:nbpac) ) 315 294 DO jk = 1, nlay_i 316 CALL tab_2d_1d( nbpac, ze_i_ ac(1:nbpac,jk,jl), e_i(:,:,jk,jl) , jpi, jpj, npac(1:nbpac) )295 CALL tab_2d_1d( nbpac, ze_i_1d(1:nbpac,jk,jl), e_i(:,:,jk,jl) , jpi, jpj, npac(1:nbpac) ) 317 296 END DO ! jk 318 297 END DO ! jl 319 298 320 CALL tab_2d_1d( nbpac, qldif_1d (1:nbpac) , qldif , jpi, jpj, npac(1:nbpac) ) 321 CALL tab_2d_1d( nbpac, qcmif_1d (1:nbpac) , qcmif , jpi, jpj, npac(1:nbpac) ) 322 CALL tab_2d_1d( nbpac, t_bo_b (1:nbpac) , t_bo , jpi, jpj, npac(1:nbpac) ) 323 CALL tab_2d_1d( nbpac, sfx_thd_1d(1:nbpac) , sfx_thd, jpi, jpj, npac(1:nbpac) ) 324 CALL tab_2d_1d( nbpac, rdm_ice_1d(1:nbpac) , rdm_ice, jpi, jpj, npac(1:nbpac) ) 325 CALL tab_2d_1d( nbpac, hicol_b (1:nbpac) , hicol , jpi, jpj, npac(1:nbpac) ) 326 CALL tab_2d_1d( nbpac, zvrel_ac (1:nbpac) , zvrel , jpi, jpj, npac(1:nbpac) ) 299 CALL tab_2d_1d( nbpac, qlead_1d (1:nbpac) , qlead , jpi, jpj, npac(1:nbpac) ) 300 CALL tab_2d_1d( nbpac, t_bo_1d (1:nbpac) , t_bo , jpi, jpj, npac(1:nbpac) ) 301 CALL tab_2d_1d( nbpac, sfx_opw_1d(1:nbpac) , sfx_opw, jpi, jpj, npac(1:nbpac) ) 302 CALL tab_2d_1d( nbpac, wfx_opw_1d(1:nbpac) , wfx_opw, jpi, jpj, npac(1:nbpac) ) 303 CALL tab_2d_1d( nbpac, hicol_1d (1:nbpac) , hicol , jpi, jpj, npac(1:nbpac) ) 304 CALL tab_2d_1d( nbpac, zvrel_1d (1:nbpac) , zvrel , jpi, jpj, npac(1:nbpac) ) 305 306 CALL tab_2d_1d( nbpac, hfx_thd_1d(1:nbpac) , hfx_thd, jpi, jpj, npac(1:nbpac) ) 307 CALL tab_2d_1d( nbpac, hfx_opw_1d(1:nbpac) , hfx_opw, jpi, jpj, npac(1:nbpac) ) 327 308 328 309 !------------------------------------------------------------------------------! … … 330 311 !------------------------------------------------------------------------------! 331 312 313 !----------------------------------------- 314 ! Keep old ice areas and volume in memory 315 !----------------------------------------- 316 zv_b(1:nbpac,:) = zv_i_1d(1:nbpac,:) 317 za_b(1:nbpac,:) = za_i_1d(1:nbpac,:) 332 318 !---------------------- 333 319 ! Thickness of new ice 334 320 !---------------------- 335 321 DO ji = 1, nbpac 336 zh_newice(ji) = hiccrit (1)337 END DO 338 IF( fraz_swi == 1 .0 ) zh_newice(:) = hicol_b(:)322 zh_newice(ji) = hiccrit 323 END DO 324 IF( fraz_swi == 1 ) zh_newice(1:nbpac) = hicol_1d(1:nbpac) 339 325 340 326 !---------------------- 341 327 ! Salinity of new ice 342 328 !---------------------- 343 344 329 SELECT CASE ( num_sal ) 345 330 CASE ( 1 ) ! Sice = constant 346 zs_newice( :) = bulk_sal331 zs_newice(1:nbpac) = bulk_sal 347 332 CASE ( 2 ) ! Sice = F(z,t) [Vancoppenolle et al (2005)] 348 333 DO ji = 1, nbpac … … 352 337 END DO 353 338 CASE ( 3 ) ! Sice = F(z) [multiyear ice] 354 zs_newice( :) = 2.3339 zs_newice(1:nbpac) = 2.3 355 340 END SELECT 356 357 341 358 342 !------------------------- … … 362 346 DO ji = 1, nbpac 363 347 ztmelts = - tmut * zs_newice(ji) + rtt ! Melting point (K) 364 ze_newice(ji) = rhoic * ( cpic * ( ztmelts - t_bo_ b(ji) ) &365 & + lfus * ( 1.0 - ( ztmelts - rtt ) / ( t_bo_b(ji) - rtt) ) &348 ze_newice(ji) = rhoic * ( cpic * ( ztmelts - t_bo_1d(ji) ) & 349 & + lfus * ( 1.0 - ( ztmelts - rtt ) / MIN( t_bo_1d(ji) - rtt, -epsi10 ) ) & 366 350 & - rcp * ( ztmelts - rtt ) ) 367 ze_newice(ji) = MAX( ze_newice(ji) , 0._wp ) &368 & + MAX( 0.0 , SIGN( 1.0 , - ze_newice(ji) ) ) * rhoic * lfus369 351 END DO ! ji 352 370 353 !---------------- 371 354 ! Age of new ice … … 375 358 END DO ! ji 376 359 377 !--------------------------378 ! Open water energy budget379 !--------------------------380 DO ji = 1, nbpac381 zqbgow(ji) = qldif_1d(ji) - qcmif_1d(ji) !<0382 END DO ! ji383 384 360 !------------------- 385 361 ! Volume of new ice 386 362 !------------------- 387 363 DO ji = 1, nbpac 388 zv_newice(ji) = - zqbgow(ji) / ze_newice(ji) 364 365 zEi = - ze_newice(ji) / rhoic ! specific enthalpy of forming ice [J/kg] 366 367 zEw = rcp * ( t_bo_1d(ji) - rt0 ) ! specific enthalpy of seawater at t_bo_1d [J/kg] 368 ! clem: we suppose we are already at the freezing point (condition qlead<0 is satisfyied) 369 370 zdE = zEi - zEw ! specific enthalpy difference [J/kg] 371 372 zfmdt = - qlead_1d(ji) / zdE ! Fm.dt [kg/m2] (<0) 373 ! clem: we use qlead instead of zqld (limthd) because we suppose we are at the freezing point 374 zv_newice(ji) = - zfmdt / rhoic 375 376 zQm = zfmdt * zEw ! heat to the ocean >0 associated with mass flux 377 378 ! Contribution to heat flux to the ocean [W.m-2], >0 379 hfx_thd_1d(ji) = hfx_thd_1d(ji) + zfmdt * zEw * r1_rdtice 380 ! Total heat flux used in this process [W.m-2] 381 hfx_opw_1d(ji) = hfx_opw_1d(ji) - zfmdt * zdE * r1_rdtice 382 ! mass flux 383 wfx_opw_1d(ji) = wfx_opw_1d(ji) - zv_newice(ji) * rhoic * r1_rdtice 384 ! salt flux 385 sfx_opw_1d(ji) = sfx_opw_1d(ji) - zv_newice(ji) * rhoic * zs_newice(ji) * r1_rdtice 389 386 390 387 ! A fraction zfrazb of frazil ice is accreted at the ice bottom 391 zfrazb = ( TANH ( Cfrazb * ( zvrel_ac(ji) - vfrazb ) ) + 1.0 ) * 0.5 * maxfrazb 392 zdh_frazb(ji) = zfrazb * zv_newice(ji) 388 rswitch = 1._wp - MAX( 0._wp, SIGN( 1._wp , - zat_i_1d(ji) ) ) 389 zfrazb = rswitch * ( TANH ( Cfrazb * ( zvrel_1d(ji) - vfrazb ) ) + 1.0 ) * 0.5 * maxfrazb 390 zv_frazb(ji) = zfrazb * zv_newice(ji) 393 391 zv_newice(ji) = ( 1.0 - zfrazb ) * zv_newice(ji) 394 392 END DO 395 396 !------------------------------------397 ! Diags for energy conservation test398 !------------------------------------399 DO ji = 1, nbpac400 ii = MOD( npac(ji) - 1 , jpi ) + 1401 ij = ( npac(ji) - 1 ) / jpi + 1402 !403 zde = ze_newice(ji) / unit_fac * area(ii,ij) * zv_newice(ji)404 !405 vt_i_init(ii,ij) = vt_i_init(ii,ij) + zv_newice(ji) ! volume406 et_i_init(ii,ij) = et_i_init(ii,ij) + zde ! Energy407 408 END DO409 410 ! keep new ice volume in memory411 CALL tab_1d_2d( nbpac, v_newice , npac(1:nbpac), zv_newice(1:nbpac) , jpi, jpj )412 393 413 394 !----------------- … … 415 396 !----------------- 416 397 DO ji = 1, nbpac 417 ii = MOD( npac(ji) - 1 , jpi ) + 1418 ij = ( npac(ji) - 1 ) / jpi + 1419 398 za_newice(ji) = zv_newice(ji) / zh_newice(ji) 420 diag_lat_gr(ii,ij) = diag_lat_gr(ii,ij) + zv_newice(ji) * r1_rdtice ! clem 421 END DO !ji 399 END DO 422 400 423 401 !------------------------------------------------------------------------------! … … 425 403 !------------------------------------------------------------------------------! 426 404 427 !----------------------------------------- 428 ! Keep old ice areas and volume in memory 429 !----------------------------------------- 430 zv_old(:,:) = zv_i_ac(:,:) 431 za_old(:,:) = za_i_ac(:,:) 432 433 !------------------------------------------- 434 ! Compute excessive new ice area and volume 435 !------------------------------------------- 405 !------------------------ 406 ! 6.1) lateral ice growth 407 !------------------------ 436 408 ! If lateral ice growth gives an ice concentration gt 1, then 437 409 ! we keep the excessive volume in memory and attribute it later to bottom accretion 438 410 DO ji = 1, nbpac 439 IF ( za_newice(ji) > ( amax - zat_i_ ac(ji) ) ) THEN440 zda_res(ji) = za_newice(ji) - ( amax - zat_i_ ac(ji) )411 IF ( za_newice(ji) > ( amax - zat_i_1d(ji) ) ) THEN 412 zda_res(ji) = za_newice(ji) - ( amax - zat_i_1d(ji) ) 441 413 zdv_res(ji) = zda_res (ji) * zh_newice(ji) 442 414 za_newice(ji) = za_newice(ji) - zda_res (ji) … … 446 418 zdv_res(ji) = 0._wp 447 419 ENDIF 448 END DO ! ji 449 450 !------------------------------------------------ 451 ! Laterally redistribute new ice volume and area 452 !------------------------------------------------ 453 zat_i_ac(:) = 0._wp 420 END DO 421 422 ! find which category to fill 423 zat_i_1d(:) = 0._wp 454 424 DO jl = 1, jpl 455 425 DO ji = 1, nbpac 456 IF( hi_max (jl-1) < zh_newice(ji) .AND. & 457 & zh_newice(ji) <= hi_max (jl) ) THEN 458 za_i_ac (ji,jl) = za_i_ac (ji,jl) + za_newice(ji) 459 zv_i_ac (ji,jl) = zv_i_ac (ji,jl) + zv_newice(ji) 460 zat_i_ac(ji) = zat_i_ac(ji) + za_i_ac (ji,jl) 461 zcatac (ji) = jl 426 IF( zh_newice(ji) > hi_max(jl-1) .AND. zh_newice(ji) <= hi_max(jl) ) THEN 427 za_i_1d (ji,jl) = za_i_1d (ji,jl) + za_newice(ji) 428 zv_i_1d (ji,jl) = zv_i_1d (ji,jl) + zv_newice(ji) 429 jcat (ji) = jl 462 430 ENDIF 463 END DO 464 END DO 465 466 !---------------------------------- 467 ! Heat content - lateral accretion 468 !---------------------------------- 469 DO ji = 1, nbpac 470 jl = zcatac(ji) ! categroy in which new ice is put 471 zindb = 1._wp - MAX( 0._wp , SIGN( 1._wp , -za_old(ji,jl) + epsi10 ) ) ! zindb=1 if ice =0 otherwise 472 zhice_old(ji,jl) = zv_old(ji,jl) / MAX( za_old(ji,jl) , epsi10 ) * zindb ! old ice thickness 473 zdhex (ji) = MAX( 0._wp , zh_newice(ji) - zhice_old(ji,jl) ) ! difference in thickness 474 zswinew (ji) = MAX( 0._wp , SIGN( 1._wp , - za_old(ji,jl) + epsi10 ) ) ! ice totally new in jl category 431 zat_i_1d(ji) = zat_i_1d(ji) + za_i_1d (ji,jl) 432 END DO 433 END DO 434 435 ! Heat content 436 DO ji = 1, nbpac 437 jl = jcat(ji) ! categroy in which new ice is put 438 zswinew (ji) = MAX( 0._wp , SIGN( 1._wp , - za_b(ji,jl) ) ) ! 0 if old ice 475 439 END DO 476 440 477 441 DO jk = 1, nlay_i 478 442 DO ji = 1, nbpac 479 jl = zcatac(ji) 480 zqold = ze_i_ac(ji,jk,jl) ! [ J.m-3 ] 481 zalphai = MIN( zhice_old(ji,jl) * REAL( jk ) / REAL( nlay_i ), zh_newice(ji) ) & 482 & - MIN( zhice_old(ji,jl) * REAL( jk - 1 ) / REAL( nlay_i ), zh_newice(ji) ) 483 ze_i_ac(ji,jk,jl) = zswinew(ji) * ze_newice(ji) & 484 + ( 1.0 - zswinew(ji) ) * ( za_old(ji,jl) * zqold * zhice_old(ji,jl) / REAL( nlay_i ) & 485 + za_newice(ji) * ze_newice(ji) * zalphai & 486 + za_newice(ji) * ze_newice(ji) * zdhex(ji) / REAL( nlay_i ) ) / ( ( zv_i_ac(ji,jl) ) / REAL( nlay_i ) ) 487 END DO 488 END DO 489 490 !----------------------------------------------- 491 ! Add excessive volume of new ice at the bottom 492 !----------------------------------------------- 493 ! If the ice concentration exceeds 1, the remaining volume of new ice 494 ! is equally redistributed among all ice categories in which there is 495 ! ice 496 497 ! Fraction of level ice 498 jm = 1 499 zat_i_lev(:) = 0._wp 500 501 DO jl = ice_cat_bounds(jm,1), ice_cat_bounds(jm,2) 502 DO ji = 1, nbpac 503 zat_i_lev(ji) = zat_i_lev(ji) + za_i_ac(ji,jl) 504 END DO 505 END DO 506 507 IF( ln_nicep .AND. jiindex_1d > 0 ) WRITE(numout,*) ' zv_i_ac : ', zv_i_ac(jiindex_1d, 1:jpl) 508 DO jl = ice_cat_bounds(jm,1), ice_cat_bounds(jm,2) 509 DO ji = 1, nbpac 510 zindb = MAX( 0._wp, SIGN( 1._wp , zdv_res(ji) ) ) 511 zinda = MAX( 0._wp, SIGN( 1._wp , zat_i_lev(ji) - epsi10 ) ) ! clem 512 zv_i_ac(ji,jl) = zv_i_ac(ji,jl) + zindb * zinda * zdv_res(ji) * za_i_ac(ji,jl) / MAX( zat_i_lev(ji) , epsi10 ) 513 END DO 514 END DO 515 IF( ln_nicep .AND. jiindex_1d > 0 ) WRITE(numout,*) ' zv_i_ac : ', zv_i_ac(jiindex_1d, 1:jpl) 516 517 !--------------------------------- 518 ! Heat content - bottom accretion 519 !--------------------------------- 520 jm = 1 521 DO jl = ice_cat_bounds(jm,1), ice_cat_bounds(jm,2) 522 DO ji = 1, nbpac 523 zindb = 1._wp - MAX( 0._wp , SIGN( 1._wp , - za_i_ac(ji,jl ) + epsi10 ) ) ! zindb=1 if ice =0 otherwise 524 zhice_old(ji,jl) = zv_i_ac(ji,jl) / MAX( za_i_ac(ji,jl) , epsi10 ) * zindb 525 zdhicbot (ji,jl) = zdv_res(ji) / MAX( za_i_ac(ji,jl) , epsi10 ) * zindb & 526 & + zindb * zdh_frazb(ji) ! frazil ice may coalesce 527 zdummy(ji,jl) = zv_i_ac(ji,jl) / MAX( za_i_ac(ji,jl) , epsi10 ) * zindb ! thickness of residual ice 528 END DO 529 END DO 530 531 ! old layers thicknesses and enthalpies 532 DO jl = ice_cat_bounds(jm,1), ice_cat_bounds(jm,2) 443 jl = jcat(ji) 444 rswitch = MAX( 0._wp, SIGN( 1._wp , zv_i_1d(ji,jl) - epsi20 ) ) 445 ze_i_1d(ji,jk,jl) = zswinew(ji) * ze_newice(ji) + & 446 & ( 1.0 - zswinew(ji) ) * ( ze_newice(ji) * zv_newice(ji) + ze_i_1d(ji,jk,jl) * zv_b(ji,jl) ) & 447 & * rswitch / MAX( zv_i_1d(ji,jl), epsi20 ) 448 END DO 449 END DO 450 451 !------------------------------------------------ 452 ! 6.2) bottom ice growth + ice enthalpy remapping 453 !------------------------------------------------ 454 DO jl = 1, jpl 455 456 ! for remapping 457 h_i_old (1:nbpac,0:nlay_i+1) = 0._wp 458 qh_i_old(1:nbpac,0:nlay_i+1) = 0._wp 533 459 DO jk = 1, nlay_i 534 460 DO ji = 1, nbpac 535 zthick0(ji,jk,jl) = zhice_old(ji,jl) / REAL( nlay_i )536 zqm0 (ji,jk,jl) = ze_i_ac(ji,jk,jl) * zthick0(ji,jk,jl)461 h_i_old (ji,jk) = zv_i_1d(ji,jl) / REAL( nlay_i ) 462 qh_i_old(ji,jk) = ze_i_1d(ji,jk,jl) * h_i_old(ji,jk) 537 463 END DO 538 464 END DO 539 END DO 540 !!gm ??? why the previous do loop if ocerwriten by the following one ? 541 DO jl = ice_cat_bounds(jm,1), ice_cat_bounds(jm,2) 465 466 ! new volumes including lateral/bottom accretion + residual 542 467 DO ji = 1, nbpac 543 zthick0(ji,nlay_i+1,jl) = zdhicbot(ji,jl) 544 zqm0 (ji,nlay_i+1,jl) = ze_newice(ji) * zdhicbot(ji,jl) 545 END DO ! ji 546 END DO ! jl 547 548 ! Redistributing energy on the new grid 549 ze_i_ac(:,:,:) = 0._wp 550 DO jl = ice_cat_bounds(jm,1), ice_cat_bounds(jm,2) 551 DO jk = 1, nlay_i 552 DO layer = 1, nlay_i + 1 553 DO ji = 1, nbpac 554 zindb = 1._wp - MAX( 0._wp , SIGN( 1._wp , - za_i_ac(ji,jl) + epsi10 ) ) 555 ! Redistributing energy on the new grid 556 zweight = MAX ( MIN( zhice_old(ji,jl) * REAL( layer ), zdummy(ji,jl) * REAL( jk ) ) & 557 & - MAX( zhice_old(ji,jl) * REAL( layer - 1 ) , zdummy(ji,jl) * REAL( jk - 1 ) ) , 0._wp ) & 558 & /( MAX(REAL(nlay_i) * zthick0(ji,layer,jl),epsi10) ) * zindb 559 ze_i_ac(ji,jk,jl) = ze_i_ac(ji,jk,jl) + zweight * zqm0(ji,layer,jl) 560 END DO ! ji 561 END DO ! layer 562 END DO ! jk 563 END DO ! jl 564 565 DO jl = ice_cat_bounds(jm,1), ice_cat_bounds(jm,2) 566 DO jk = 1, nlay_i 567 DO ji = 1, nbpac 568 zindb = 1._wp - MAX( 0._wp , SIGN( 1._wp , - zv_i_ac(ji,jl) + epsi10 ) ) 569 ze_i_ac(ji,jk,jl) = ze_i_ac(ji,jk,jl) & 570 & / MAX( zv_i_ac(ji,jl) , epsi10) * za_i_ac(ji,jl) * REAL( nlay_i ) * zindb 571 END DO 572 END DO 573 END DO 468 rswitch = MAX( 0._wp, SIGN( 1._wp , zat_i_1d(ji) - epsi20 ) ) 469 zv_newfra = rswitch * ( zdv_res(ji) + zv_frazb(ji) ) * za_i_1d(ji,jl) / MAX( zat_i_1d(ji) , epsi20 ) 470 za_i_1d(ji,jl) = rswitch * za_i_1d(ji,jl) 471 zv_i_1d(ji,jl) = zv_i_1d(ji,jl) + zv_newfra 472 ! for remapping 473 h_i_old (ji,nlay_i+1) = zv_newfra 474 qh_i_old(ji,nlay_i+1) = ze_newice(ji) * zv_newfra 475 ENDDO 476 ! --- Ice enthalpy remapping --- ! 477 CALL lim_thd_ent( 1, nbpac, ze_i_1d(1:nbpac,:,jl) ) 478 ENDDO 574 479 575 480 !------------ … … 578 483 DO jl = 1, jpl 579 484 DO ji = 1, nbpac 580 zindb = 1._wp - MAX( 0._wp , SIGN( 1._wp , - za_i_ac(ji,jl) + epsi10 ) ) ! 0 if no ice and 1 if yes581 zoa_i_ ac(ji,jl) = za_old(ji,jl) * zoa_i_ac(ji,jl) / MAX( za_i_ac(ji,jl) , epsi10 ) * zindb485 rswitch = 1._wp - MAX( 0._wp , SIGN( 1._wp , - za_i_1d(ji,jl) + epsi20 ) ) ! 0 if no ice and 1 if yes 486 zoa_i_1d(ji,jl) = za_b(ji,jl) * zoa_i_1d(ji,jl) / MAX( za_i_1d(ji,jl) , epsi20 ) * rswitch 582 487 END DO 583 488 END DO … … 586 491 ! Update salinity 587 492 !----------------- 588 !clem IF( num_sal == 2 ) THEN589 DO jl = 1, jpl590 DO ji = 1, nbpac591 zindb = 1._wp - MAX( 0._wp , SIGN( 1._wp , - zv_i_ac(ji,jl) + epsi10 ) ) ! 0 if no ice and 1 if yes592 zdv = zv_i_ac(ji,jl) - zv_old(ji,jl)593 zsmv_i_ac(ji,jl) = zsmv_i_ac(ji,jl) + zdv * zs_newice(ji) * zindb ! clem modif594 END DO595 END DO596 !clem ENDIF597 598 !--------------------------------599 ! Update mass/salt fluxes (clem)600 !--------------------------------601 493 DO jl = 1, jpl 602 494 DO ji = 1, nbpac 603 zindb = 1._wp - MAX( 0._wp , SIGN( 1._wp , - zv_i_ac(ji,jl) + epsi10 ) ) ! 0 if no ice and 1 if yes 604 zdv = zv_i_ac(ji,jl) - zv_old(ji,jl) 605 rdm_ice_1d(ji) = rdm_ice_1d(ji) + zdv * rhoic * zindb 606 sfx_thd_1d(ji) = sfx_thd_1d(ji) - zdv * rhoic * zs_newice(ji) * r1_rdtice * zindb 607 END DO 495 zdv = zv_i_1d(ji,jl) - zv_b(ji,jl) 496 zsmv_i_1d(ji,jl) = zsmv_i_1d(ji,jl) + zdv * zs_newice(ji) 497 END DO 608 498 END DO 609 499 610 500 !------------------------------------------------------------------------------! 611 ! 8) Change 2D vectors to 1D vectors501 ! 7) Change 2D vectors to 1D vectors 612 502 !------------------------------------------------------------------------------! 613 503 DO jl = 1, jpl 614 CALL tab_1d_2d( nbpac, a_i (:,:,jl), npac(1:nbpac), za_i_ac (1:nbpac,jl), jpi, jpj ) 615 CALL tab_1d_2d( nbpac, v_i (:,:,jl), npac(1:nbpac), zv_i_ac (1:nbpac,jl), jpi, jpj ) 616 CALL tab_1d_2d( nbpac, oa_i(:,:,jl), npac(1:nbpac), zoa_i_ac(1:nbpac,jl), jpi, jpj ) 617 !clem IF ( num_sal == 2 ) & 618 CALL tab_1d_2d( nbpac, smv_i (:,:,jl), npac(1:nbpac), zsmv_i_ac(1:nbpac,jl) , jpi, jpj ) 504 CALL tab_1d_2d( nbpac, a_i (:,:,jl), npac(1:nbpac), za_i_1d (1:nbpac,jl), jpi, jpj ) 505 CALL tab_1d_2d( nbpac, v_i (:,:,jl), npac(1:nbpac), zv_i_1d (1:nbpac,jl), jpi, jpj ) 506 CALL tab_1d_2d( nbpac, oa_i(:,:,jl), npac(1:nbpac), zoa_i_1d(1:nbpac,jl), jpi, jpj ) 507 CALL tab_1d_2d( nbpac, smv_i (:,:,jl), npac(1:nbpac), zsmv_i_1d(1:nbpac,jl) , jpi, jpj ) 619 508 DO jk = 1, nlay_i 620 CALL tab_1d_2d( nbpac, e_i(:,:,jk,jl), npac(1:nbpac), ze_i_ac(1:nbpac,jk,jl), jpi, jpj ) 621 END DO 622 END DO 623 CALL tab_1d_2d( nbpac, sfx_thd, npac(1:nbpac), sfx_thd_1d(1:nbpac), jpi, jpj ) 624 CALL tab_1d_2d( nbpac, rdm_ice, npac(1:nbpac), rdm_ice_1d(1:nbpac), jpi, jpj ) 509 CALL tab_1d_2d( nbpac, e_i(:,:,jk,jl), npac(1:nbpac), ze_i_1d(1:nbpac,jk,jl), jpi, jpj ) 510 END DO 511 END DO 512 CALL tab_1d_2d( nbpac, sfx_opw, npac(1:nbpac), sfx_opw_1d(1:nbpac), jpi, jpj ) 513 CALL tab_1d_2d( nbpac, wfx_opw, npac(1:nbpac), wfx_opw_1d(1:nbpac), jpi, jpj ) 514 515 CALL tab_1d_2d( nbpac, hfx_thd, npac(1:nbpac), hfx_thd_1d(1:nbpac), jpi, jpj ) 516 CALL tab_1d_2d( nbpac, hfx_opw, npac(1:nbpac), hfx_opw_1d(1:nbpac), jpi, jpj ) 625 517 ! 626 518 ENDIF ! nbpac > 0 627 519 628 520 !------------------------------------------------------------------------------! 629 ! 9) Change units for e_i521 ! 8) Change units for e_i 630 522 !------------------------------------------------------------------------------! 631 523 DO jl = 1, jpl 632 DO jk = 1, nlay_i ! heat content in 10^9 Joules 633 e_i(:,:,jk,jl) = e_i(:,:,jk,jl) * area(:,:) * v_i(:,:,jl) / REAL( nlay_i ) / unit_fac 524 DO jk = 1, nlay_i 525 DO jj = 1, jpj 526 DO ji = 1, jpi 527 ! heat content in Joules 528 e_i(ji,jj,jk,jl) = e_i(ji,jj,jk,jl) * area(ji,jj) * v_i(ji,jj,jl) / ( REAL( nlay_i ,wp ) * unit_fac ) 529 END DO 530 END DO 634 531 END DO 635 532 END DO 636 533 637 !------------------------------------------------------------------------------|638 ! 10) Conservation check and changes in each ice category639 !------------------------------------------------------------------------------|640 IF( con_i ) THEN641 CALL lim_column_sum (jpl, v_i, vt_i_final)642 fieldid = 'v_i, limthd_lac'643 CALL lim_cons_check (vt_i_init, vt_i_final, 1.0e-6, fieldid)644 !645 CALL lim_column_sum_energy(jpl, nlay_i, e_i, et_i_final)646 fieldid = 'e_i, limthd_lac'647 CALL lim_cons_check (et_i_final, et_i_final, 1.0e-3, fieldid)648 !649 CALL lim_column_sum (jpl, v_s, vt_s_final)650 fieldid = 'v_s, limthd_lac'651 CALL lim_cons_check (vt_s_init, vt_s_final, 1.0e-6, fieldid)652 !653 ! CALL lim_column_sum (jpl, e_s(:,:,1,:) , et_s_init)654 ! fieldid = 'e_s, limthd_lac'655 ! CALL lim_cons_check (et_s_init, et_s_final, 1.0e-3, fieldid)656 IF( ln_nicep ) THEN657 DO ji = mi0(jiindx), mi1(jiindx)658 DO jj = mj0(jjindx), mj1(jjindx)659 WRITE(numout,*) ' vt_i_init : ', vt_i_init (ji,jj)660 WRITE(numout,*) ' vt_i_final: ', vt_i_final(ji,jj)661 WRITE(numout,*) ' et_i_init : ', et_i_init (ji,jj)662 WRITE(numout,*) ' et_i_final: ', et_i_final(ji,jj)663 END DO664 END DO665 ENDIF666 !667 ENDIF668 534 ! 669 CALL wrk_dealloc( jpij, zcatac) ! integer535 CALL wrk_dealloc( jpij, jcat ) ! integer 670 536 CALL wrk_dealloc( jpij, zswinew, zv_newice, za_newice, zh_newice, ze_newice, zs_newice, zo_newice ) 671 CALL wrk_dealloc( jpij, zdv_res, zda_res, zat_i_ac, zat_i_lev, zdh_frazb, zvrel_ac, zqbgow, zdhex ) 672 CALL wrk_dealloc( jpij,jpl, zhice_old, zdummy, zdhicbot, zv_old, za_old, za_i_ac, zv_i_ac, zoa_i_ac, zsmv_i_ac ) 673 CALL wrk_dealloc( jpij,jkmax,jpl, ze_i_ac ) 674 CALL wrk_dealloc( jpij,jkmax+1,jpl, zqm0, zthick0 ) 675 CALL wrk_dealloc( jpi,jpj, vt_i_init, vt_i_final, vt_s_init, vt_s_final, et_i_init, et_i_final, et_s_init, zvrel ) 537 CALL wrk_dealloc( jpij, zdv_res, zda_res, zat_i_1d, zv_frazb, zvrel_1d ) 538 CALL wrk_dealloc( jpij,jpl, zv_b, za_b, za_i_1d, zv_i_1d, zoa_i_1d, zsmv_i_1d ) 539 CALL wrk_dealloc( jpij,nlay_i+1,jpl, ze_i_1d ) 540 CALL wrk_dealloc( jpi,jpj, zvrel ) 676 541 ! 677 542 END SUBROUTINE lim_thd_lac -
branches/2014/dev_r4650_UKMO14.12_STAND_ALONE_OBSOPER/NEMOGCM/NEMO/LIM_SRC_3/limthd_sal.F90
r4624 r5034 53 53 ! 54 54 INTEGER :: ji, jk ! dummy loop indices 55 REAL(wp) :: zsold, iflush, iaccrbo, igravdr, isnowic, i_ice_switch, ztmelts ! local scalars 56 REAL(wp) :: zaaa, zbbb, zccc, zdiscrim ! local scalars 57 REAL(wp), POINTER, DIMENSION(:) :: ze_init, zhiold, zsiold 55 REAL(wp) :: iflush, igravdr ! local scalars 58 56 !!--------------------------------------------------------------------- 59 57 60 CALL wrk_alloc( jpij, ze_init, zhiold, zsiold ) 61 58 !--------------------------------------------------------- 59 ! 0) Update ice salinity from snow-ice and bottom growth 60 !--------------------------------------------------------- 61 DO ji = kideb, kiut 62 sm_i_1d(ji) = sm_i_1d(ji) + dsm_i_se_1d(ji) + dsm_i_si_1d(ji) 63 END DO 64 62 65 !------------------------------------------------------------------------------| 63 66 ! 1) Constant salinity, constant in time | 64 67 !------------------------------------------------------------------------------| 65 !!gm comment: if num_sal = 1 s_i_new, s_i_ b and sm_i_bcan be set to bulk_sal one for all in the initialisation phase !!68 !!gm comment: if num_sal = 1 s_i_new, s_i_1d and sm_i_1d can be set to bulk_sal one for all in the initialisation phase !! 66 69 !!gm ===>>> simplification of almost all test on num_sal value 67 70 IF( num_sal == 1 ) THEN 68 s_i_ b(kideb:kiut,1:nlay_i) = bulk_sal69 sm_i_ b(kideb:kiut) = bulk_sal71 s_i_1d (kideb:kiut,1:nlay_i) = bulk_sal 72 sm_i_1d(kideb:kiut) = bulk_sal 70 73 s_i_new(kideb:kiut) = bulk_sal 71 74 ENDIF … … 74 77 ! Module 2 : Constant salinity varying in time | 75 78 !------------------------------------------------------------------------------| 76 77 79 IF( num_sal == 2 ) THEN 78 79 !---------------------------------80 ! Thickness at previous time step81 !---------------------------------82 DO ji = kideb, kiut83 zhiold(ji) = ht_i_b(ji) - dh_i_bott(ji) - dh_snowice(ji) - dh_i_surf(ji)84 zsiold(ji) = sm_i_b(ji)85 END DO86 87 !---------------------88 ! Global heat content89 !---------------------90 ze_init(:) = 0._wp91 DO jk = 1, nlay_i92 DO ji = kideb, kiut93 ze_init(ji) = ze_init(ji) + q_i_b(ji,jk) * ht_i_b(ji) / REAL (nlay_i )94 END DO95 END DO96 80 97 81 DO ji = kideb, kiut … … 99 83 ! Switches 100 84 !---------- 101 iflush = MAX( 0._wp , SIGN( 1.0 , t_su_b(ji) - rtt ) ) ! =1 if summer 102 igravdr = MAX( 0._wp , SIGN( 1.0 , t_bo_b(ji) - t_su_b(ji) ) ) ! =1 if t_su < t_bo 103 iaccrbo = MAX( 0._wp , SIGN( 1.0 , dh_i_bott(ji) ) ) ! =1 if bottom accretion 104 i_ice_switch = 1._wp - MAX ( 0._wp , SIGN( 1._wp , - ht_i_b(ji) + 1.e-2 ) ) 105 isnowic = 1._wp - MAX ( 0._wp , SIGN( 1._wp , - dh_snowice(ji) ) ) * i_ice_switch ! =1 if snow ice formation 85 iflush = MAX( 0._wp , SIGN( 1._wp , t_su_1d(ji) - rtt ) ) ! =1 if summer 86 igravdr = MAX( 0._wp , SIGN( 1._wp , t_bo_1d(ji) - t_su_1d(ji) ) ) ! =1 if t_su < t_bo 106 87 107 88 !--------------------- 108 89 ! Salinity tendencies 109 90 !--------------------- 110 ! !drainage by gravity drainage111 dsm_i_gd_1d(ji) = - igravdr * MAX( sm_i_ b(ji) - sal_G , 0._wp ) / time_G * rdt_ice112 ! !drainage by flushing113 dsm_i_fl_1d(ji) = - iflush * MAX( sm_i_ b(ji) - sal_F , 0._wp ) / time_F * rdt_ice91 ! drainage by gravity drainage 92 dsm_i_gd_1d(ji) = - igravdr * MAX( sm_i_1d(ji) - sal_G , 0._wp ) / time_G * rdt_ice 93 ! drainage by flushing 94 dsm_i_fl_1d(ji) = - iflush * MAX( sm_i_1d(ji) - sal_F , 0._wp ) / time_F * rdt_ice 114 95 115 96 !----------------- … … 118 99 ! only drainage terms ( gravity drainage and flushing ) 119 100 ! snow ice / bottom sources are added in lim_thd_ent to conserve energy 120 sm_i_b(ji) = sm_i_b(ji) + dsm_i_fl_1d(ji) + dsm_i_gd_1d(ji) 121 122 ! if no ice, salinity = 0.1 123 i_ice_switch = 1._wp - MAX ( 0._wp, SIGN( 1._wp , - ht_i_b(ji) ) ) 124 sm_i_b(ji) = i_ice_switch * sm_i_b(ji) + s_i_min * ( 1._wp - i_ice_switch ) 125 126 !---------------------------- 127 ! Heat flux - brine drainage 128 !---------------------------- 129 fhbri_1d(ji) = 0._wp 101 sm_i_1d(ji) = sm_i_1d(ji) + dsm_i_fl_1d(ji) + dsm_i_gd_1d(ji) 130 102 131 103 !---------------------------- 132 104 ! Salt flux - brine drainage 133 105 !---------------------------- 134 sfx_bri_1d(ji) = sfx_bri_1d(ji) - i_ice_switch * rhoic * a_i_b(ji) * ht_i_b(ji) * ( sm_i_b(ji) - zsiold(ji) ) * r1_rdtice106 sfx_bri_1d(ji) = sfx_bri_1d(ji) - rhoic * a_i_1d(ji) * ht_i_1d(ji) * ( dsm_i_fl_1d(ji) + dsm_i_gd_1d(ji) ) * r1_rdtice 135 107 136 108 END DO … … 138 110 ! Salinity profile 139 111 CALL lim_var_salprof1d( kideb, kiut ) 140 141 142 ! Only necessary for conservation check since salinity is modified143 !--------------------144 ! Temperature update145 !--------------------146 DO jk = 1, nlay_i147 DO ji = kideb, kiut148 ztmelts = -tmut*s_i_b(ji,jk) + rtt149 !Conversion q(S,T) -> T (second order equation)150 zaaa = cpic151 zbbb = ( rcp - cpic ) * ( ztmelts - rtt ) + q_i_b(ji,jk) / rhoic - lfus152 zccc = lfus * ( ztmelts - rtt )153 zdiscrim = SQRT( MAX( zbbb*zbbb - 4.0*zaaa*zccc, 0._wp ) )154 t_i_b(ji,jk) = rtt - ( zbbb + zdiscrim ) / ( 2.0 *zaaa )155 END DO156 END DO157 112 ! 158 113 ENDIF … … 161 116 ! Module 3 : Profile of salinity, constant in time | 162 117 !------------------------------------------------------------------------------| 163 164 118 IF( num_sal == 3 ) CALL lim_var_salprof1d( kideb, kiut ) 165 119 166 !167 CALL wrk_dealloc( jpij, ze_init, zhiold, zsiold )168 120 ! 169 121 END SUBROUTINE lim_thd_sal -
branches/2014/dev_r4650_UKMO14.12_STAND_ALONE_OBSOPER/NEMOGCM/NEMO/LIM_SRC_3/limtrp.F90
r4333 r5034 30 30 USE limvar ! clem for ice thickness correction 31 31 USE timing ! Timing 32 USE limcons ! conservation tests 32 33 33 34 IMPLICIT NONE … … 35 36 36 37 PUBLIC lim_trp ! called by ice_step 37 38 REAL(wp) :: epsi10 = 1.e-10_wp39 REAL(wp) :: rzero = 0._wp40 REAL(wp) :: rone = 1._wp41 38 42 39 !! * Substitution … … 63 60 INTEGER, INTENT(in) :: kt ! number of iteration 64 61 ! 65 INTEGER :: ji, jj, jk, jl, layer! dummy loop indices62 INTEGER :: ji, jj, jk, jl, jn ! dummy loop indices 66 63 INTEGER :: initad ! number of sub-timestep for the advection 67 INTEGER :: ierr ! error status 68 REAL(wp) :: zindb , zindsn , zindic, zindh, zinda ! local scalar 69 REAL(wp) :: zusvosn, zusvoic, zbigval ! - - 70 REAL(wp) :: zcfl , zusnit ! - - 71 REAL(wp) :: ze , zsal , zage ! - - 64 REAL(wp) :: zcfl , zusnit ! - - 72 65 ! 73 66 REAL(wp), POINTER, DIMENSION(:,:) :: zui_u, zvi_v, zsm, zs0at, zs0ow 74 67 REAL(wp), POINTER, DIMENSION(:,:,:) :: zs0ice, zs0sn, zs0a, zs0c0 , zs0sm , zs0oi 75 68 REAL(wp), POINTER, DIMENSION(:,:,:,:) :: zs0e 76 REAL(wp) :: zchk_v_i, zchk_smv, zchk_fs, zchk_fw, zchk_v_i_b, zchk_smv_b, zchk_fs_b, zchk_fw_b ! Check conservation (C Rousset) 77 REAL(wp) :: zchk_vmin, zchk_amin, zchk_amax, zchk_umax ! Check errors (C Rousset) 78 ! mass and salt flux (clem) 79 REAL(wp), POINTER, DIMENSION(:,:,:) :: zviold ! old ice volume... 80 ! correct ice thickness (clem) 81 REAL(wp), POINTER, DIMENSION(:,:,:) :: zaiold, zhimax ! old ice concentration and thickness 82 REAL(wp) :: zdv, zda, zvi, zvs, zsmv 69 REAL(wp), POINTER, DIMENSION(:,:,:) :: zviold, zvsold ! old ice volume... 70 REAL(wp), POINTER, DIMENSION(:,:,:) :: zaiold, zhimax ! old ice concentration and thickness 71 REAL(wp), POINTER, DIMENSION(:,:) :: zeiold, zesold ! old enthalpies 72 REAL(wp) :: zdv, zda, zvi, zvs, zsmv, zes, zei 73 ! 74 REAL(wp) :: zvi_b, zsmv_b, zei_b, zfs_b, zfw_b, zft_b 83 75 !!--------------------------------------------------------------------- 84 76 IF( nn_timing == 1 ) CALL timing_start('limtrp') 85 77 86 CALL wrk_alloc( jpi, jpj, zui_u, zvi_v, zsm, zs0at, zs0ow )78 CALL wrk_alloc( jpi, jpj, zui_u, zvi_v, zsm, zs0at, zs0ow, zeiold, zesold ) 87 79 CALL wrk_alloc( jpi, jpj, jpl, zs0ice, zs0sn, zs0a, zs0c0 , zs0sm , zs0oi ) 88 CALL wrk_alloc( jpi, jpj, jkmax, jpl, zs0e ) 89 90 CALL wrk_alloc( jpi,jpj,jpl,zviold ) ! clem 91 CALL wrk_alloc( jpi,jpj,jpl,zaiold, zhimax ) ! clem 92 93 ! ------------------------------- 94 !- check conservation (C Rousset) 95 IF( ln_limdiahsb ) THEN 96 zchk_v_i_b = glob_sum( SUM( v_i(:,:,:), dim=3 ) * area(:,:) * tms(:,:) ) 97 zchk_smv_b = glob_sum( SUM( smv_i(:,:,:), dim=3 ) * area(:,:) * tms(:,:) ) 98 zchk_fw_b = glob_sum( rdm_ice(:,:) * area(:,:) * tms(:,:) ) 99 zchk_fs_b = glob_sum( ( sfx_bri(:,:) + sfx_thd(:,:) + sfx_res(:,:) + sfx_mec(:,:) ) * area(:,:) * tms(:,:) ) 100 ENDIF 101 !- check conservation (C Rousset) 102 ! ------------------------------- 80 CALL wrk_alloc( jpi, jpj, nlay_i+1, jpl, zs0e ) 81 82 CALL wrk_alloc( jpi, jpj, jpl, zaiold, zhimax, zviold, zvsold ) ! clem 103 83 104 84 IF( numit == nstart .AND. lwp ) THEN … … 115 95 IF( ln_limdyn ) THEN ! Advection of sea ice properties ! 116 96 ! !-------------------------------------! 97 98 ! conservation test 99 IF( ln_limdiahsb ) CALL lim_cons_hsm(0, 'limtrp', zvi_b, zsmv_b, zei_b, zfw_b, zfs_b, zft_b) 100 117 101 ! mass and salt flux init (clem) 118 102 zviold(:,:,:) = v_i(:,:,:) 103 zeiold(:,:) = SUM( SUM( e_i(:,:,1:nlay_i,:), dim=4 ), dim=3 ) 104 zesold(:,:) = SUM( SUM( e_s(:,:,1:nlay_s,:), dim=4 ), dim=3 ) 119 105 120 106 !--- Thickness correction init. (clem) ------------------------------- … … 167 153 ! ENDIF 168 154 !!gm end 169 initad = 1 + NINT( MAX( rzero, SIGN( rone, zcfl-0.5 ) ) )155 initad = 1 + NINT( MAX( 0._wp, SIGN( 1._wp, zcfl-0.5 ) ) ) 170 156 zusnit = 1.0 / REAL( initad ) 171 157 IF( zcfl > 0.5 .AND. lwp ) & … … 174 160 175 161 IF( MOD( ( kt - 1) / nn_fsbc , 2 ) == 0 ) THEN !== odd ice time step: adv_x then adv_y ==! 176 DO j k= 1,initad177 CALL lim_adv_x( zusnit, u_ice, rone, zsm, zs0ow (:,:), sxopw(:,:), & !--- ice open water area162 DO jn = 1,initad 163 CALL lim_adv_x( zusnit, u_ice, 1._wp , zsm, zs0ow (:,:), sxopw(:,:), & !--- ice open water area 178 164 & sxxopw(:,:), syopw(:,:), syyopw(:,:), sxyopw(:,:) ) 179 CALL lim_adv_y( zusnit, v_ice, rzero, zsm, zs0ow (:,:), sxopw(:,:), &165 CALL lim_adv_y( zusnit, v_ice, 0._wp, zsm, zs0ow (:,:), sxopw(:,:), & 180 166 & sxxopw(:,:), syopw(:,:), syyopw(:,:), sxyopw(:,:) ) 181 167 DO jl = 1, jpl 182 CALL lim_adv_x( zusnit, u_ice, rone, zsm, zs0ice(:,:,jl), sxice(:,:,jl), & !--- ice volume ---168 CALL lim_adv_x( zusnit, u_ice, 1._wp , zsm, zs0ice(:,:,jl), sxice(:,:,jl), & !--- ice volume --- 183 169 & sxxice(:,:,jl), syice(:,:,jl), syyice(:,:,jl), sxyice(:,:,jl) ) 184 CALL lim_adv_y( zusnit, v_ice, rzero, zsm, zs0ice(:,:,jl), sxice(:,:,jl), &170 CALL lim_adv_y( zusnit, v_ice, 0._wp, zsm, zs0ice(:,:,jl), sxice(:,:,jl), & 185 171 & sxxice(:,:,jl), syice(:,:,jl), syyice(:,:,jl), sxyice(:,:,jl) ) 186 CALL lim_adv_x( zusnit, u_ice, rone, zsm, zs0sn (:,:,jl), sxsn (:,:,jl), & !--- snow volume ---172 CALL lim_adv_x( zusnit, u_ice, 1._wp , zsm, zs0sn (:,:,jl), sxsn (:,:,jl), & !--- snow volume --- 187 173 & sxxsn (:,:,jl), sysn (:,:,jl), syysn (:,:,jl), sxysn (:,:,jl) ) 188 CALL lim_adv_y( zusnit, v_ice, rzero, zsm, zs0sn (:,:,jl), sxsn (:,:,jl), &174 CALL lim_adv_y( zusnit, v_ice, 0._wp, zsm, zs0sn (:,:,jl), sxsn (:,:,jl), & 189 175 & sxxsn (:,:,jl), sysn (:,:,jl), syysn (:,:,jl), sxysn (:,:,jl) ) 190 CALL lim_adv_x( zusnit, u_ice, rone, zsm, zs0sm (:,:,jl), sxsal(:,:,jl), & !--- ice salinity ---176 CALL lim_adv_x( zusnit, u_ice, 1._wp , zsm, zs0sm (:,:,jl), sxsal(:,:,jl), & !--- ice salinity --- 191 177 & sxxsal(:,:,jl), sysal(:,:,jl), syysal(:,:,jl), sxysal(:,:,jl) ) 192 CALL lim_adv_y( zusnit, v_ice, rzero, zsm, zs0sm (:,:,jl), sxsal(:,:,jl), &178 CALL lim_adv_y( zusnit, v_ice, 0._wp, zsm, zs0sm (:,:,jl), sxsal(:,:,jl), & 193 179 & sxxsal(:,:,jl), sysal(:,:,jl), syysal(:,:,jl), sxysal(:,:,jl) ) 194 CALL lim_adv_x( zusnit, u_ice, rone, zsm, zs0oi (:,:,jl), sxage(:,:,jl), & !--- ice age ---180 CALL lim_adv_x( zusnit, u_ice, 1._wp , zsm, zs0oi (:,:,jl), sxage(:,:,jl), & !--- ice age --- 195 181 & sxxage(:,:,jl), syage(:,:,jl), syyage(:,:,jl), sxyage(:,:,jl) ) 196 CALL lim_adv_y( zusnit, v_ice, rzero, zsm, zs0oi (:,:,jl), sxage(:,:,jl), &182 CALL lim_adv_y( zusnit, v_ice, 0._wp, zsm, zs0oi (:,:,jl), sxage(:,:,jl), & 197 183 & sxxage(:,:,jl), syage(:,:,jl), syyage(:,:,jl), sxyage(:,:,jl) ) 198 CALL lim_adv_x( zusnit, u_ice, rone, zsm, zs0a (:,:,jl), sxa (:,:,jl), & !--- ice concentrations ---184 CALL lim_adv_x( zusnit, u_ice, 1._wp , zsm, zs0a (:,:,jl), sxa (:,:,jl), & !--- ice concentrations --- 199 185 & sxxa (:,:,jl), sya (:,:,jl), syya (:,:,jl), sxya (:,:,jl) ) 200 CALL lim_adv_y( zusnit, v_ice, rzero, zsm, zs0a (:,:,jl), sxa (:,:,jl), &186 CALL lim_adv_y( zusnit, v_ice, 0._wp, zsm, zs0a (:,:,jl), sxa (:,:,jl), & 201 187 & sxxa (:,:,jl), sya (:,:,jl), syya (:,:,jl), sxya (:,:,jl) ) 202 CALL lim_adv_x( zusnit, u_ice, rone, zsm, zs0c0 (:,:,jl), sxc0 (:,:,jl), & !--- snow heat contents ---188 CALL lim_adv_x( zusnit, u_ice, 1._wp , zsm, zs0c0 (:,:,jl), sxc0 (:,:,jl), & !--- snow heat contents --- 203 189 & sxxc0 (:,:,jl), syc0 (:,:,jl), syyc0 (:,:,jl), sxyc0 (:,:,jl) ) 204 CALL lim_adv_y( zusnit, v_ice, rzero, zsm, zs0c0 (:,:,jl), sxc0 (:,:,jl), &190 CALL lim_adv_y( zusnit, v_ice, 0._wp, zsm, zs0c0 (:,:,jl), sxc0 (:,:,jl), & 205 191 & sxxc0 (:,:,jl), syc0 (:,:,jl), syyc0 (:,:,jl), sxyc0 (:,:,jl) ) 206 DO layer= 1, nlay_i !--- ice heat contents ---207 CALL lim_adv_x( zusnit, u_ice, rone , zsm, zs0e(:,:,layer,jl), sxe (:,:,layer,jl), &208 & sxxe(:,:, layer,jl), sye (:,:,layer,jl), &209 & syye(:,:, layer,jl), sxye(:,:,layer,jl) )210 CALL lim_adv_y( zusnit, v_ice, rzero, zsm, zs0e(:,:,layer,jl), sxe (:,:,layer,jl), &211 & sxxe(:,:, layer,jl), sye (:,:,layer,jl), &212 & syye(:,:, layer,jl), sxye(:,:,layer,jl) )192 DO jk = 1, nlay_i !--- ice heat contents --- 193 CALL lim_adv_x( zusnit, u_ice, 1._wp , zsm, zs0e(:,:,jk,jl), sxe (:,:,jk,jl), & 194 & sxxe(:,:,jk,jl), sye (:,:,jk,jl), & 195 & syye(:,:,jk,jl), sxye(:,:,jk,jl) ) 196 CALL lim_adv_y( zusnit, v_ice, 0._wp, zsm, zs0e(:,:,jk,jl), sxe (:,:,jk,jl), & 197 & sxxe(:,:,jk,jl), sye (:,:,jk,jl), & 198 & syye(:,:,jk,jl), sxye(:,:,jk,jl) ) 213 199 END DO 214 200 END DO 215 201 END DO 216 202 ELSE 217 DO j k= 1, initad218 CALL lim_adv_y( zusnit, v_ice, rone, zsm, zs0ow (:,:), sxopw(:,:), & !--- ice open water area203 DO jn = 1, initad 204 CALL lim_adv_y( zusnit, v_ice, 1._wp , zsm, zs0ow (:,:), sxopw(:,:), & !--- ice open water area 219 205 & sxxopw(:,:), syopw(:,:), syyopw(:,:), sxyopw(:,:) ) 220 CALL lim_adv_x( zusnit, u_ice, rzero, zsm, zs0ow (:,:), sxopw(:,:), &206 CALL lim_adv_x( zusnit, u_ice, 0._wp, zsm, zs0ow (:,:), sxopw(:,:), & 221 207 & sxxopw(:,:), syopw(:,:), syyopw(:,:), sxyopw(:,:) ) 222 208 DO jl = 1, jpl 223 CALL lim_adv_y( zusnit, v_ice, rone, zsm, zs0ice(:,:,jl), sxice(:,:,jl), & !--- ice volume ---209 CALL lim_adv_y( zusnit, v_ice, 1._wp , zsm, zs0ice(:,:,jl), sxice(:,:,jl), & !--- ice volume --- 224 210 & sxxice(:,:,jl), syice(:,:,jl), syyice(:,:,jl), sxyice(:,:,jl) ) 225 CALL lim_adv_x( zusnit, u_ice, rzero, zsm, zs0ice(:,:,jl), sxice(:,:,jl), &211 CALL lim_adv_x( zusnit, u_ice, 0._wp, zsm, zs0ice(:,:,jl), sxice(:,:,jl), & 226 212 & sxxice(:,:,jl), syice(:,:,jl), syyice(:,:,jl), sxyice(:,:,jl) ) 227 CALL lim_adv_y( zusnit, v_ice, rone, zsm, zs0sn (:,:,jl), sxsn (:,:,jl), & !--- snow volume ---213 CALL lim_adv_y( zusnit, v_ice, 1._wp , zsm, zs0sn (:,:,jl), sxsn (:,:,jl), & !--- snow volume --- 228 214 & sxxsn (:,:,jl), sysn (:,:,jl), syysn (:,:,jl), sxysn (:,:,jl) ) 229 CALL lim_adv_x( zusnit, u_ice, rzero, zsm, zs0sn (:,:,jl), sxsn (:,:,jl), &215 CALL lim_adv_x( zusnit, u_ice, 0._wp, zsm, zs0sn (:,:,jl), sxsn (:,:,jl), & 230 216 & sxxsn (:,:,jl), sysn (:,:,jl), syysn (:,:,jl), sxysn (:,:,jl) ) 231 CALL lim_adv_y( zusnit, v_ice, rone, zsm, zs0sm (:,:,jl), sxsal(:,:,jl), & !--- ice salinity ---217 CALL lim_adv_y( zusnit, v_ice, 1._wp , zsm, zs0sm (:,:,jl), sxsal(:,:,jl), & !--- ice salinity --- 232 218 & sxxsal(:,:,jl), sysal(:,:,jl), syysal(:,:,jl), sxysal(:,:,jl) ) 233 CALL lim_adv_x( zusnit, u_ice, rzero, zsm, zs0sm (:,:,jl), sxsal(:,:,jl), &219 CALL lim_adv_x( zusnit, u_ice, 0._wp, zsm, zs0sm (:,:,jl), sxsal(:,:,jl), & 234 220 & sxxsal(:,:,jl), sysal(:,:,jl), syysal(:,:,jl), sxysal(:,:,jl) ) 235 221 236 CALL lim_adv_y( zusnit, v_ice, rone, zsm, zs0oi (:,:,jl), sxage(:,:,jl), & !--- ice age ---222 CALL lim_adv_y( zusnit, v_ice, 1._wp , zsm, zs0oi (:,:,jl), sxage(:,:,jl), & !--- ice age --- 237 223 & sxxage(:,:,jl), syage(:,:,jl), syyage(:,:,jl), sxyage(:,:,jl) ) 238 CALL lim_adv_x( zusnit, u_ice, rzero, zsm, zs0oi (:,:,jl), sxage(:,:,jl), &224 CALL lim_adv_x( zusnit, u_ice, 0._wp, zsm, zs0oi (:,:,jl), sxage(:,:,jl), & 239 225 & sxxage(:,:,jl), syage(:,:,jl), syyage(:,:,jl), sxyage(:,:,jl) ) 240 CALL lim_adv_y( zusnit, v_ice, rone, zsm, zs0a (:,:,jl), sxa (:,:,jl), & !--- ice concentrations ---226 CALL lim_adv_y( zusnit, v_ice, 1._wp , zsm, zs0a (:,:,jl), sxa (:,:,jl), & !--- ice concentrations --- 241 227 & sxxa (:,:,jl), sya (:,:,jl), syya (:,:,jl), sxya (:,:,jl) ) 242 CALL lim_adv_x( zusnit, u_ice, rzero, zsm, zs0a (:,:,jl), sxa (:,:,jl), &228 CALL lim_adv_x( zusnit, u_ice, 0._wp, zsm, zs0a (:,:,jl), sxa (:,:,jl), & 243 229 & sxxa (:,:,jl), sya (:,:,jl), syya (:,:,jl), sxya (:,:,jl) ) 244 CALL lim_adv_y( zusnit, v_ice, rone, zsm, zs0c0 (:,:,jl), sxc0 (:,:,jl), & !--- snow heat contents ---230 CALL lim_adv_y( zusnit, v_ice, 1._wp , zsm, zs0c0 (:,:,jl), sxc0 (:,:,jl), & !--- snow heat contents --- 245 231 & sxxc0 (:,:,jl), syc0 (:,:,jl), syyc0 (:,:,jl), sxyc0 (:,:,jl) ) 246 CALL lim_adv_x( zusnit, u_ice, rzero, zsm, zs0c0 (:,:,jl), sxc0 (:,:,jl), &232 CALL lim_adv_x( zusnit, u_ice, 0._wp, zsm, zs0c0 (:,:,jl), sxc0 (:,:,jl), & 247 233 & sxxc0 (:,:,jl), syc0 (:,:,jl), syyc0 (:,:,jl), sxyc0 (:,:,jl) ) 248 DO layer= 1, nlay_i !--- ice heat contents ---249 CALL lim_adv_y( zusnit, v_ice, rone , zsm, zs0e(:,:,layer,jl), sxe (:,:,layer,jl), &250 & sxxe(:,:, layer,jl), sye (:,:,layer,jl), &251 & syye(:,:, layer,jl), sxye(:,:,layer,jl) )252 CALL lim_adv_x( zusnit, u_ice, rzero, zsm, zs0e(:,:,layer,jl), sxe (:,:,layer,jl), &253 & sxxe(:,:, layer,jl), sye (:,:,layer,jl), &254 & syye(:,:, layer,jl), sxye(:,:,layer,jl) )234 DO jk = 1, nlay_i !--- ice heat contents --- 235 CALL lim_adv_y( zusnit, v_ice, 1._wp , zsm, zs0e(:,:,jk,jl), sxe (:,:,jk,jl), & 236 & sxxe(:,:,jk,jl), sye (:,:,jk,jl), & 237 & syye(:,:,jk,jl), sxye(:,:,jk,jl) ) 238 CALL lim_adv_x( zusnit, u_ice, 0._wp, zsm, zs0e(:,:,jk,jl), sxe (:,:,jk,jl), & 239 & sxxe(:,:,jk,jl), sye (:,:,jk,jl), & 240 & syye(:,:,jk,jl), sxye(:,:,jk,jl) ) 255 241 END DO 256 242 END DO … … 268 254 zs0oi (:,:,jl) = zs0oi (:,:,jl) / area(:,:) 269 255 zs0a (:,:,jl) = zs0a (:,:,jl) / area(:,:) 270 zs0c0 (:,:,jl) = zs0c0 (:,:,jl) / area(:,:) 271 DO jk = 1, nlay_i 272 zs0e(:,:,jk,jl) = zs0e(:,:,jk,jl) / area(:,:) 273 END DO 256 ! 274 257 END DO 275 258 … … 289 272 DO jj = 1, jpjm1 ! NB: has not to be defined on jpj line and jpi row 290 273 DO ji = 1 , fs_jpim1 ! vector opt. 291 pahu(ji,jj) = ( 1._wp - MAX( rzero, SIGN( rone, -zs0at(ji ,jj) ) ) ) &292 & * ( 1._wp - MAX( rzero, SIGN( rone, -zs0at(ji+1,jj) ) ) ) * ahiu(ji,jj)293 pahv(ji,jj) = ( 1._wp - MAX( rzero, SIGN( rone, -zs0at(ji,jj ) ) ) ) &294 & * ( 1._wp - MAX( rzero, SIGN( rone,- zs0at(ji,jj+1) ) ) ) * ahiv(ji,jj)274 pahu(ji,jj) = ( 1._wp - MAX( 0._wp, SIGN( 1._wp, -zs0at(ji ,jj) ) ) ) & 275 & * ( 1._wp - MAX( 0._wp, SIGN( 1._wp, -zs0at(ji+1,jj) ) ) ) * ahiu(ji,jj) 276 pahv(ji,jj) = ( 1._wp - MAX( 0._wp, SIGN( 1._wp, -zs0at(ji,jj ) ) ) ) & 277 & * ( 1._wp - MAX( 0._wp, SIGN( 1._wp,- zs0at(ji,jj+1) ) ) ) * ahiv(ji,jj) 295 278 END DO 296 279 END DO … … 305 288 DO jj = 1, jpjm1 ! NB: has not to be defined on jpj line and jpi row 306 289 DO ji = 1 , fs_jpim1 ! vector opt. 307 pahu(ji,jj) = ( 1._wp - MAX( rzero, SIGN( rone, -zs0a(ji ,jj,jl) ) ) ) &308 & * ( 1._wp - MAX( rzero, SIGN( rone, -zs0a(ji+1,jj,jl) ) ) ) * ahiu(ji,jj)309 pahv(ji,jj) = ( 1._wp - MAX( rzero, SIGN( rone, -zs0a(ji,jj ,jl) ) ) ) &310 & * ( 1._wp - MAX( rzero, SIGN( rone,- zs0a(ji,jj+1,jl) ) ) ) * ahiv(ji,jj)290 pahu(ji,jj) = ( 1._wp - MAX( 0._wp, SIGN( 1._wp, -zs0a(ji ,jj,jl) ) ) ) & 291 & * ( 1._wp - MAX( 0._wp, SIGN( 1._wp, -zs0a(ji+1,jj,jl) ) ) ) * ahiu(ji,jj) 292 pahv(ji,jj) = ( 1._wp - MAX( 0._wp, SIGN( 1._wp, -zs0a(ji,jj ,jl) ) ) ) & 293 & * ( 1._wp - MAX( 0._wp, SIGN( 1._wp,- zs0a(ji,jj+1,jl) ) ) ) * ahiv(ji,jj) 311 294 END DO 312 295 END DO … … 334 317 DO jj = 1, jpj 335 318 DO ji = 1, jpi 336 zs0sn (ji,jj,jl) = MAX( rzero, zs0sn (ji,jj,jl) )337 zs0ice(ji,jj,jl) = MAX( rzero, zs0ice(ji,jj,jl) )338 zs0sm (ji,jj,jl) = MAX( rzero, zs0sm (ji,jj,jl) )339 zs0oi (ji,jj,jl) = MAX( rzero, zs0oi (ji,jj,jl) )340 zs0a (ji,jj,jl) = MAX( rzero, zs0a (ji,jj,jl) )341 zs0c0 (ji,jj,jl) = MAX( rzero, zs0c0 (ji,jj,jl) )319 zs0sn (ji,jj,jl) = MAX( 0._wp, zs0sn (ji,jj,jl) ) 320 zs0ice(ji,jj,jl) = MAX( 0._wp, zs0ice(ji,jj,jl) ) 321 zs0sm (ji,jj,jl) = MAX( 0._wp, zs0sm (ji,jj,jl) ) 322 zs0oi (ji,jj,jl) = MAX( 0._wp, zs0oi (ji,jj,jl) ) 323 zs0a (ji,jj,jl) = MAX( 0._wp, zs0a (ji,jj,jl) ) 324 zs0c0 (ji,jj,jl) = MAX( 0._wp, zs0c0 (ji,jj,jl) ) 342 325 zs0at (ji,jj) = zs0at(ji,jj) + zs0a(ji,jj,jl) 343 326 END DO … … 346 329 347 330 !--------------------------------------------------------- 348 ! 5.2) Snow thickness, Ice thickness, Ice concentrations331 ! 5.2) Update and mask variables 349 332 !--------------------------------------------------------- 350 DO jj = 1, jpj 351 DO ji = 1, jpi 352 zindb = MAX( 0._wp , SIGN( 1.0, zs0at(ji,jj) - epsi10) ) 353 zs0ow(ji,jj) = ( 1._wp - zindb ) + zindb * MAX( zs0ow(ji,jj), 0._wp ) 354 ato_i(ji,jj) = zs0ow(ji,jj) 355 END DO 356 END DO 357 358 DO jl = 1, jpl ! Remove very small areas 333 DO jl = 1, jpl 359 334 DO jj = 1, jpj 360 335 DO ji = 1, jpi 361 zvi = zs0ice(ji,jj,jl) 362 zvs = zs0sn(ji,jj,jl) 336 rswitch = MAX( 0._wp , SIGN( 1._wp, zs0a(ji,jj,jl) - epsi10 ) ) 337 338 zvi = zs0ice(ji,jj,jl) 339 zvs = zs0sn (ji,jj,jl) 340 zes = zs0c0 (ji,jj,jl) 341 zsmv = zs0sm (ji,jj,jl) 363 342 ! 364 zindb = MAX( 0.0 , SIGN( 1.0, zs0a(ji,jj,jl) - epsi10) ) 365 ! 366 v_s(ji,jj,jl) = zindb * zs0sn (ji,jj,jl) 367 v_i(ji,jj,jl) = zindb * zs0ice(ji,jj,jl) 368 ! 369 zindsn = MAX( rzero, SIGN( rone, v_s(ji,jj,jl) - epsi10 ) ) 370 zindic = MAX( rzero, SIGN( rone, v_i(ji,jj,jl) - epsi10 ) ) 371 zindb = MAX( zindsn, zindic ) 372 ! 373 zs0a(ji,jj,jl) = zindb * zs0a(ji,jj,jl) !ice concentration 374 a_i (ji,jj,jl) = zs0a(ji,jj,jl) 375 v_s (ji,jj,jl) = zindsn * v_s(ji,jj,jl) 376 v_i (ji,jj,jl) = zindic * v_i(ji,jj,jl) 377 ! 378 ! Update mass fluxes (clem) 379 rdm_ice(ji,jj) = rdm_ice(ji,jj) + ( v_i(ji,jj,jl) - zvi ) * rhoic 380 rdm_snw(ji,jj) = rdm_snw(ji,jj) + ( v_s(ji,jj,jl) - zvs ) * rhosn 381 END DO 382 END DO 383 END DO 384 385 !--- Thickness correction in case too high (clem) -------------------------------------------------------- 386 CALL lim_var_glo2eqv 387 DO jl = 1, jpl 388 DO jj = 1, jpj 389 DO ji = 1, jpi 390 391 IF ( v_i(ji,jj,jl) > 0._wp ) THEN 392 zvi = v_i(ji,jj,jl) 393 zvs = v_s(ji,jj,jl) 394 zdv = v_i(ji,jj,jl) - zviold(ji,jj,jl) 395 !zda = a_i(ji,jj,jl) - zaiold(ji,jj,jl) 396 397 zindh = 1._wp 398 IF ( ( zdv > 0.0 .AND. ht_i(ji,jj,jl) > zhimax(ji,jj,jl) .AND. SUM( zaiold(ji,jj,1:jpl) ) < 0.80 ) .OR. & 399 & ( zdv < 0.0 .AND. ht_i(ji,jj,jl) > zhimax(ji,jj,jl) ) ) THEN 400 ht_i(ji,jj,jl) = MIN( zhimax(ji,jj,jl), hi_max(jl) ) 401 zindh = MAX( rzero, SIGN( rone, ht_i(ji,jj,jl) - epsi10 ) ) 402 a_i(ji,jj,jl) = zindh * v_i(ji,jj,jl) / MAX( ht_i(ji,jj,jl), epsi10 ) 403 ELSE 404 ht_i(ji,jj,jl) = MAX( MIN( ht_i(ji,jj,jl), hi_max(jl) ), hi_max(jl-1) ) 405 zindh = MAX( rzero, SIGN( rone, ht_i(ji,jj,jl) - epsi10 ) ) 406 a_i(ji,jj,jl) = zindh * v_i(ji,jj,jl) / MAX( ht_i(ji,jj,jl), epsi10 ) 407 ENDIF 408 409 ! small correction due to *zindh for a_i 410 v_i(ji,jj,jl) = zindh * v_i(ji,jj,jl) 411 v_s(ji,jj,jl) = zindh * v_s(ji,jj,jl) 412 413 ! Update mass fluxes 414 rdm_ice(ji,jj) = rdm_ice(ji,jj) + ( v_i(ji,jj,jl) - zvi ) * rhoic 415 rdm_snw(ji,jj) = rdm_snw(ji,jj) + ( v_s(ji,jj,jl) - zvs ) * rhosn 416 417 ENDIF 418 419 diag_trp_vi(ji,jj) = diag_trp_vi(ji,jj) + ( v_i(ji,jj,jl) - zviold(ji,jj,jl) ) * r1_rdtice 420 421 END DO 422 END DO 423 END DO 424 425 ! --- 426 DO jj = 1, jpj 427 DO ji = 1, jpi 428 zs0at(ji,jj) = SUM( zs0a(ji,jj,1:jpl) ) ! clem@useless?? 429 END DO 430 END DO 431 432 !---------------------- 433 ! 5.3) Ice properties 434 !---------------------- 435 436 zbigval = 1.e+13 437 438 DO jl = 1, jpl 439 DO jj = 1, jpj 440 DO ji = 1, jpi 441 zsmv = zs0sm(ji,jj,jl) 442 443 ! Switches and dummy variables 444 zusvosn = 1.0/MAX( v_s(ji,jj,jl) , epsi10 ) 445 zusvoic = 1.0/MAX( v_i(ji,jj,jl) , epsi10 ) 446 zindsn = MAX( rzero, SIGN( rone, v_s(ji,jj,jl) - epsi10 ) ) 447 zindic = MAX( rzero, SIGN( rone, v_i(ji,jj,jl) - epsi10 ) ) 448 zindb = MAX( zindsn, zindic ) 449 343 ! Remove very small areas 344 v_s(ji,jj,jl) = rswitch * zs0sn (ji,jj,jl) 345 v_i(ji,jj,jl) = rswitch * zs0ice(ji,jj,jl) 346 a_i(ji,jj,jl) = rswitch * zs0a (ji,jj,jl) 347 e_s(ji,jj,1,jl) = rswitch * zs0c0 (ji,jj,jl) 450 348 ! Ice salinity and age 451 !clem zsal = MAX( MIN( (rhoic-rhosn)/rhoic*sss_m(ji,jj), zusvoic * zs0sm(ji,jj,jl) ), s_i_min ) * v_i(ji,jj,jl)452 349 IF( num_sal == 2 ) THEN 453 350 smv_i(ji,jj,jl) = MAX( MIN( s_i_max * v_i(ji,jj,jl), zsmv ), s_i_min * v_i(ji,jj,jl) ) 454 351 ENDIF 455 456 zage = MAX( MIN( zbigval, zs0oi(ji,jj,jl) / MAX( a_i(ji,jj,jl), epsi10 ) ), 0._wp ) * a_i(ji,jj,jl) 457 oa_i (ji,jj,jl) = zindic * zage 458 459 ! Snow heat content 460 ze = MIN( MAX( 0.0, zs0c0(ji,jj,jl)*area(ji,jj) ), zbigval ) 461 e_s(ji,jj,1,jl) = zindsn * ze 462 463 ! Update salt fluxes (clem) 352 oa_i(ji,jj,jl) = MAX( rswitch * zs0oi(ji,jj,jl) / MAX( a_i(ji,jj,jl), epsi10 ), 0._wp ) * a_i(ji,jj,jl) 353 354 ! Update fluxes 355 wfx_res(ji,jj) = wfx_res(ji,jj) - ( v_i(ji,jj,jl) - zvi ) * rhoic * r1_rdtice 356 wfx_snw(ji,jj) = wfx_snw(ji,jj) - ( v_s(ji,jj,jl) - zvs ) * rhosn * r1_rdtice 464 357 sfx_res(ji,jj) = sfx_res(ji,jj) - ( smv_i(ji,jj,jl) - zsmv ) * rhoic * r1_rdtice 465 END DO !ji 466 END DO !jj 467 END DO ! jl 358 hfx_res(ji,jj) = hfx_res(ji,jj) + ( e_s(ji,jj,1,jl) - zes ) * unit_fac / area(ji,jj) * r1_rdtice ! W.m-2 <0 359 END DO 360 END DO 361 END DO 468 362 469 363 DO jl = 1, jpl … … 471 365 DO jj = 1, jpj 472 366 DO ji = 1, jpi 473 ! Ice heat content 474 zindic = MAX( rzero, SIGN( rone, v_i(ji,jj,jl) - epsi10 ) ) 475 ze = MIN( MAX( 0.0, zs0e(ji,jj,jk,jl)*area(ji,jj) ), zbigval ) 476 e_i(ji,jj,jk,jl) = zindic * ze 367 rswitch = MAX( 0._wp , SIGN( 1._wp, zs0a(ji,jj,jl) - epsi10 ) ) 368 zei = zs0e(ji,jj,jk,jl) 369 e_i(ji,jj,jk,jl) = rswitch * MAX( 0._wp, zs0e(ji,jj,jk,jl) ) 370 ! Update fluxes 371 hfx_res(ji,jj) = hfx_res(ji,jj) + ( e_i(ji,jj,jk,jl) - zei ) * unit_fac / area(ji,jj) * r1_rdtice ! W.m-2 <0 477 372 END DO !ji 478 373 END DO ! jj … … 480 375 END DO ! jl 481 376 482 483 ! --- agglomerate variables (clem) ----------------- 484 vt_i (:,:) = 0._wp 485 vt_s (:,:) = 0._wp 486 at_i (:,:) = 0._wp 487 ! 488 DO jl = 1, jpl 377 !--- Thickness correction in case too high (clem) -------------------------------------------------------- 378 CALL lim_var_glo2eqv 379 DO jl = 1, jpl 380 DO jj = 1, jpj 381 DO ji = 1, jpi 382 383 IF ( v_i(ji,jj,jl) > 0._wp ) THEN 384 zvi = v_i (ji,jj,jl) 385 zvs = v_s (ji,jj,jl) 386 zsmv = smv_i(ji,jj,jl) 387 zes = e_s (ji,jj,1,jl) 388 zei = SUM( e_i(ji,jj,1:nlay_i,jl) ) 389 zdv = v_i(ji,jj,jl) - zviold(ji,jj,jl) 390 !zda = a_i(ji,jj,jl) - zaiold(ji,jj,jl) 391 392 rswitch = 1._wp 393 IF ( ( zdv > 0.0 .AND. ht_i(ji,jj,jl) > zhimax(ji,jj,jl) .AND. SUM( zaiold(ji,jj,1:jpl) ) < 0.80 ) .OR. & 394 & ( zdv < 0.0 .AND. ht_i(ji,jj,jl) > zhimax(ji,jj,jl) ) ) THEN 395 ht_i(ji,jj,jl) = MIN( zhimax(ji,jj,jl), hi_max(jl) ) 396 rswitch = MAX( 0._wp, SIGN( 1._wp, ht_i(ji,jj,jl) - epsi20 ) ) 397 a_i(ji,jj,jl) = rswitch * v_i(ji,jj,jl) / MAX( ht_i(ji,jj,jl), epsi20 ) 398 ELSE 399 ht_i(ji,jj,jl) = MAX( MIN( ht_i(ji,jj,jl), hi_max(jl) ), hi_max(jl-1) ) 400 rswitch = MAX( 0._wp, SIGN( 1._wp, ht_i(ji,jj,jl) - epsi20 ) ) 401 a_i(ji,jj,jl) = rswitch * v_i(ji,jj,jl) / MAX( ht_i(ji,jj,jl), epsi20 ) 402 ENDIF 403 404 ! small correction due to *rswitch for a_i 405 v_i (ji,jj,jl) = rswitch * v_i (ji,jj,jl) 406 v_s (ji,jj,jl) = rswitch * v_s (ji,jj,jl) 407 smv_i(ji,jj,jl) = rswitch * smv_i(ji,jj,jl) 408 e_s(ji,jj,1,jl) = rswitch * e_s(ji,jj,1,jl) 409 e_i(ji,jj,1:nlay_i,jl) = rswitch * e_i(ji,jj,1:nlay_i,jl) 410 411 ! Update mass fluxes 412 wfx_res(ji,jj) = wfx_res(ji,jj) - ( v_i(ji,jj,jl) - zvi ) * rhoic * r1_rdtice 413 wfx_snw(ji,jj) = wfx_snw(ji,jj) - ( v_s(ji,jj,jl) - zvs ) * rhosn * r1_rdtice 414 sfx_res(ji,jj) = sfx_res(ji,jj) - ( smv_i(ji,jj,jl) - zsmv ) * rhoic * r1_rdtice 415 hfx_res(ji,jj) = hfx_res(ji,jj) + ( e_s(ji,jj,1,jl) - zes ) * unit_fac / area(ji,jj) * r1_rdtice ! W.m-2 <0 416 hfx_res(ji,jj) = hfx_res(ji,jj) + ( SUM( e_i(ji,jj,1:nlay_i,jl) ) - zei ) * unit_fac / area(ji,jj) * r1_rdtice ! W.m-2 <0 417 ENDIF 418 END DO 419 END DO 420 END DO 421 ! ------------------------------------------------- 422 423 ! --- diags --- 489 424 DO jj = 1, jpj 490 425 DO ji = 1, jpi 491 ! 492 vt_i(ji,jj) = vt_i(ji,jj) + v_i(ji,jj,jl) ! ice volume 493 vt_s(ji,jj) = vt_s(ji,jj) + v_s(ji,jj,jl) ! snow volume 494 at_i(ji,jj) = at_i(ji,jj) + a_i(ji,jj,jl) ! ice concentration 495 ! 496 zinda = MAX( rzero , SIGN( rone , at_i(ji,jj) - epsi10 ) ) 497 icethi(ji,jj) = vt_i(ji,jj) / MAX( at_i(ji,jj) , epsi10 ) * zinda ! ice thickness 498 END DO 499 END DO 500 END DO 501 ! ------------------------------------------------- 502 503 426 diag_trp_ei(ji,jj) = ( SUM( e_i(ji,jj,1:nlay_i,:) ) - zeiold(ji,jj) ) / area(ji,jj) * unit_fac * r1_rdtice 427 diag_trp_es(ji,jj) = ( SUM( e_s(ji,jj,1:nlay_s,:) ) - zesold(ji,jj) ) / area(ji,jj) * unit_fac * r1_rdtice 428 429 diag_trp_vi(ji,jj) = SUM( v_i(ji,jj,:) - zviold(ji,jj,:) ) * r1_rdtice 430 diag_trp_vs(ji,jj) = SUM( v_s(ji,jj,:) - zvsold(ji,jj,:) ) * r1_rdtice 431 END DO 432 END DO 433 434 ! --- agglomerate variables ----------------- 435 vt_i (:,:) = 0._wp 436 vt_s (:,:) = 0._wp 437 at_i (:,:) = 0._wp 438 ! 439 DO jl = 1, jpl 440 DO jj = 1, jpj 441 DO ji = 1, jpi 442 ! 443 vt_i(ji,jj) = vt_i(ji,jj) + v_i(ji,jj,jl) ! ice volume 444 vt_s(ji,jj) = vt_s(ji,jj) + v_s(ji,jj,jl) ! snow volume 445 at_i(ji,jj) = at_i(ji,jj) + a_i(ji,jj,jl) ! ice concentration 446 END DO 447 END DO 448 END DO 449 ! ------------------------------------------------- 450 451 ! open water 452 DO jj = 1, jpj 453 DO ji = 1, jpi 454 ! open water = 1 if at_i=0 455 rswitch = MAX( 0._wp , SIGN( 1._wp, - at_i(ji,jj) ) ) 456 ato_i(ji,jj) = rswitch + (1._wp - rswitch ) * zs0ow(ji,jj) 457 END DO 458 END DO 459 460 ! conservation test 461 IF( ln_limdiahsb ) CALL lim_cons_hsm(1, 'limtrp', zvi_b, zsmv_b, zei_b, zfw_b, zfs_b, zft_b) 504 462 505 463 ENDIF … … 536 494 END DO 537 495 ENDIF 538 ! -------------------------------539 !- check conservation (C Rousset)540 IF( ln_limdiahsb ) THEN541 zchk_fs = glob_sum( ( sfx_bri(:,:) + sfx_thd(:,:) + sfx_res(:,:) + sfx_mec(:,:) ) * area(:,:) * tms(:,:) ) - zchk_fs_b542 zchk_fw = glob_sum( rdm_ice(:,:) * area(:,:) * tms(:,:) ) - zchk_fw_b543 544 zchk_v_i = ( glob_sum( SUM( v_i(:,:,:), dim=3 ) * area(:,:) * tms(:,:) ) - zchk_v_i_b - ( zchk_fw / rhoic ) ) / rdt_ice545 zchk_smv = ( glob_sum( SUM( smv_i(:,:,:), dim=3 ) * area(:,:) * tms(:,:) ) - zchk_smv_b ) / rdt_ice + ( zchk_fs / rhoic )546 547 zchk_vmin = glob_min(v_i)548 zchk_amax = glob_max(SUM(a_i,dim=3))549 zchk_amin = glob_min(a_i)550 zchk_umax = glob_max(SQRT(u_ice**2 + v_ice**2))551 552 IF(lwp) THEN553 IF ( ABS( zchk_v_i ) > 1.e-5 ) THEN554 WRITE(numout,*) 'violation volume [m3/day] (limtrp) = ',(zchk_v_i * rday)555 WRITE(numout,*) 'u_ice max [m/s] (limtrp) = ',zchk_umax556 WRITE(numout,*) 'number of time steps (limtrp) =',kt557 ENDIF558 IF ( ABS( zchk_smv ) > 1.e-4 ) WRITE(numout,*) 'violation saline [psu*m3/day] (limtrp) = ',(zchk_smv * rday)559 IF ( zchk_vmin < 0. ) WRITE(numout,*) 'violation v_i<0 [mm] (limtrp) = ',(zchk_vmin * 1.e-3)560 IF ( zchk_amin < 0. ) WRITE(numout,*) 'violation a_i<0 (limtrp) = ',zchk_amin561 ENDIF562 ENDIF563 !- check conservation (C Rousset)564 ! -------------------------------565 496 ! 566 CALL wrk_dealloc( jpi, jpj, zui_u, zvi_v, zsm, zs0at, zs0ow )497 CALL wrk_dealloc( jpi, jpj, zui_u, zvi_v, zsm, zs0at, zs0ow, zeiold, zesold ) 567 498 CALL wrk_dealloc( jpi, jpj, jpl, zs0ice, zs0sn, zs0a, zs0c0 , zs0sm , zs0oi ) 568 CALL wrk_dealloc( jpi, jpj, jkmax, jpl, zs0e )569 570 CALL wrk_dealloc( jpi, jpj,jpl,zaiold, zhimax ) ! clem499 CALL wrk_dealloc( jpi, jpj, nlay_i+1, jpl, zs0e ) 500 501 CALL wrk_dealloc( jpi, jpj, jpl, zviold, zvsold, zaiold, zhimax ) ! clem 571 502 ! 572 503 IF( nn_timing == 1 ) CALL timing_stop('limtrp') -
branches/2014/dev_r4650_UKMO14.12_STAND_ALONE_OBSOPER/NEMOGCM/NEMO/LIM_SRC_3/limupdate1.F90
r4333 r5034 5 5 !!====================================================================== 6 6 !! History : 3.0 ! 2006-04 (M. Vancoppenolle) Original code 7 !! 3.6 ! 2014-06 (C. Rousset) Complete rewriting/cleaning 7 8 !!---------------------------------------------------------------------- 8 9 #if defined key_lim3 … … 32 33 USE par_ice 33 34 USE limitd_th 35 USE limitd_me 34 36 USE limvar 35 37 USE prtctl ! Print control … … 37 39 USE wrk_nemo ! work arrays 38 40 USE lib_fortran ! glob_sum 39 ! Check budget (Rousset)40 41 USE in_out_manager ! I/O manager 41 42 USE iom ! I/O manager 42 43 USE lib_mpp ! MPP library 43 44 USE timing ! Timing 45 USE limcons ! conservation tests 44 46 45 47 IMPLICIT NONE … … 48 50 PUBLIC lim_update1 ! routine called by ice_step 49 51 50 REAL(wp) :: epsi10 = 1.e-10_wp ! - -51 REAL(wp) :: rzero = 0._wp ! - -52 REAL(wp) :: rone = 1._wp ! - -53 54 52 !! * Substitutions 55 53 # include "vectopt_loop_substitute.h90" … … 66 64 !! 67 65 !! ** Purpose : Computes update of sea-ice global variables at 68 !! the end of the time step. 69 !! Address pathological cases 70 !! This place is very important 66 !! the end of the dynamics. 71 67 !! 72 !! ** Method :73 !! Ice speed from ice dynamics74 !! Ice thickness, Snow thickness, Temperatures, Lead fraction75 !! from advection and ice thermodynamics76 !!77 !! ** Action : -78 68 !!--------------------------------------------------------------------- 79 INTEGER :: ji, jj, jk, jl, jm ! dummy loop indices 80 INTEGER :: jbnd1, jbnd2 81 INTEGER :: i_ice_switch 82 INTEGER :: ind_im, layer ! indices for internal melt 83 REAL(wp) :: zweight, zesum, z_da_i, zhimax 84 REAL(wp) :: zinda, zindb, zindsn, zindic 85 REAL(wp) :: zindg, zh, zdvres, zviold2 86 REAL(wp) :: zbigvalue, zvsold2, z_da_ex 87 REAL(wp) :: z_prescr_hi, zat_i_old, ztmelts, ze_s 88 89 REAL(wp), POINTER, DIMENSION(:) :: zthick0, zqm0 ! thickness of the layers and heat contents for 90 REAL(wp) :: zchk_v_i, zchk_smv, zchk_fs, zchk_fw, zchk_v_i_b, zchk_smv_b, zchk_fs_b, zchk_fw_b ! Check conservation (C Rousset) 91 REAL(wp) :: zchk_vmin, zchk_amin, zchk_amax ! Check errors (C Rousset) 92 ! mass and salt flux (clem) 93 REAL(wp), POINTER, DIMENSION(:,:,:) :: zviold, zvsold, zsmvold ! old ice volume... 69 INTEGER :: ji, jj, jk, jl ! dummy loop indices 70 INTEGER :: i_ice_switch 71 REAL(wp) :: zsal 72 ! 73 REAL(wp) :: zvi_b, zsmv_b, zei_b, zfs_b, zfw_b, zft_b 94 74 !!------------------------------------------------------------------- 95 75 IF( nn_timing == 1 ) CALL timing_start('limupdate1') 96 76 97 CALL wrk_alloc( jkmax, zthick0, zqm0 ) 98 99 CALL wrk_alloc( jpi,jpj,jpl,zviold, zvsold, zsmvold ) ! clem 100 101 !------------------------------------------------------------------------------ 102 ! 1. Update of Global variables | 103 !------------------------------------------------------------------------------ 104 105 !----------------- 106 ! Trend terms 107 !----------------- 108 d_u_ice_dyn(:,:) = u_ice(:,:) - old_u_ice(:,:) 109 d_v_ice_dyn(:,:) = v_ice(:,:) - old_v_ice(:,:) 110 d_a_i_trp (:,:,:) = a_i (:,:,:) - old_a_i (:,:,:) 111 d_v_s_trp (:,:,:) = v_s (:,:,:) - old_v_s (:,:,:) 112 d_v_i_trp (:,:,:) = v_i (:,:,:) - old_v_i (:,:,:) 113 d_e_s_trp (:,:,:,:) = e_s (:,:,:,:) - old_e_s (:,:,:,:) 114 d_e_i_trp (:,:,:,:) = e_i (:,:,:,:) - old_e_i (:,:,:,:) 115 d_oa_i_trp (:,:,:) = oa_i (:,:,:) - old_oa_i (:,:,:) 116 d_smv_i_trp(:,:,:) = 0._wp 117 IF( num_sal == 2 ) d_smv_i_trp(:,:,:) = smv_i(:,:,:) - old_smv_i(:,:,:) 118 119 ! mass and salt flux init (clem) 120 zviold(:,:,:) = v_i(:,:,:) 121 zvsold(:,:,:) = v_s(:,:,:) 122 zsmvold(:,:,:) = smv_i(:,:,:) 123 124 ! ------------------------------- 125 !- check conservation (C Rousset) 126 IF (ln_limdiahsb) THEN 127 zchk_v_i_b = glob_sum( SUM( v_i(:,:,:), dim=3 ) * area(:,:) * tms(:,:) ) 128 zchk_smv_b = glob_sum( SUM( smv_i(:,:,:), dim=3 ) * area(:,:) * tms(:,:) ) 129 zchk_fw_b = glob_sum( rdm_ice(:,:) * area(:,:) * tms(:,:) ) 130 zchk_fs_b = glob_sum( ( sfx_bri(:,:) + sfx_thd(:,:) + sfx_res(:,:) + sfx_mec(:,:) ) * area(:,:) * tms(:,:) ) 131 ENDIF 132 !- check conservation (C Rousset) 133 ! ------------------------------- 77 IF( ln_limdyn ) THEN 78 79 ! conservation test 80 IF( ln_limdiahsb ) CALL lim_cons_hsm(0, 'limupdate1', zvi_b, zsmv_b, zei_b, zfw_b, zfs_b, zft_b) 81 82 !----------------- 83 ! zap small values 84 !----------------- 85 CALL lim_itd_me_zapsmall 134 86 135 87 CALL lim_var_glo2eqv 136 137 !--------------------------------------138 ! 2. Review of all pathological cases139 !--------------------------------------140 141 ! clem: useless now142 !-------------------------------------------143 ! 2.1) Advection of ice in an ice-free cell144 !-------------------------------------------145 ! should be removed since it is treated after dynamics now146 ! zhimax = 5._wp147 ! ! first category148 ! DO jj = 1, jpj149 ! DO ji = 1, jpi150 ! !--- the thickness of such an ice is often out of bounds151 ! !--- thus we recompute a new area while conserving ice volume152 ! zat_i_old = SUM( old_a_i(ji,jj,:) )153 ! zindb = MAX( 0._wp, SIGN( 1._wp, ABS( d_a_i_trp(ji,jj,1) ) - epsi10 ) )154 ! IF( ( ABS( d_v_i_trp(ji,jj,1) ) / MAX( ABS( d_a_i_trp(ji,jj,1) ), epsi10 ) * zindb .GT. zhimax ) &155 ! & .AND.( ( v_i(ji,jj,1) / MAX( a_i(ji,jj,1), epsi10 ) * zindb ) .GT. zhimax ) &156 ! & .AND.( zat_i_old .LT. 1.e-6 ) ) THEN ! new line157 ! ht_i(ji,jj,1) = hi_max(1) * 0.5_wp158 ! a_i (ji,jj,1) = v_i(ji,jj,1) / ht_i(ji,jj,1)159 ! ENDIF160 ! END DO161 ! END DO162 !163 ! zhimax = 20._wp164 ! ! other categories165 ! DO jl = 2, jpl166 ! jm = ice_types(jl)167 ! DO jj = 1, jpj168 ! DO ji = 1, jpi169 ! zindb = MAX( rzero, SIGN( rone, ABS( d_a_i_trp(ji,jj,jl) ) - epsi10 ) )170 ! ! this correction is very tricky... sometimes, advection gets wrong i don't know why171 ! ! it makes problems when the advected volume and concentration do not seem to be172 ! ! related with each other173 ! ! the new thickness is sometimes very big!174 ! ! and sometimes d_a_i_trp and d_v_i_trp have different sign175 ! ! which of course is plausible176 ! ! but fuck! it fucks everything up :)177 ! IF ( ( ABS( d_v_i_trp(ji,jj,jl) ) / MAX( ABS( d_a_i_trp(ji,jj,jl) ), epsi10 ) * zindb .GT. zhimax ) &178 ! & .AND. ( v_i(ji,jj,jl) / MAX( a_i(ji,jj,jl), epsi10 ) * zindb ) .GT. zhimax ) THEN179 ! ht_i(ji,jj,jl) = ( hi_max_typ(jl-ice_cat_bounds(jm,1),jm) + hi_max_typ(jl-ice_cat_bounds(jm,1)+1,jm) ) * 0.5_wp180 ! a_i (ji,jj,jl) = v_i(ji,jj,jl) / ht_i(ji,jj,jl)181 ! ENDIF182 ! END DO ! ji183 ! END DO !jj184 ! END DO !jl185 88 89 !---------------------------------------------------- 90 ! Rebin categories with thickness out of bounds 91 !---------------------------------------------------- 92 IF ( jpl > 1 ) CALL lim_itd_th_reb(1, jpl) 93 186 94 at_i(:,:) = 0._wp 187 95 DO jl = 1, jpl … … 190 98 191 99 !---------------------------------------------------- 192 ! 2.2) Rebin categories with thickness out of bounds 193 !---------------------------------------------------- 194 DO jm = 1, jpm 195 jbnd1 = ice_cat_bounds(jm,1) 196 jbnd2 = ice_cat_bounds(jm,2) 197 IF (ice_ncat_types(jm) .GT. 1 ) CALL lim_itd_th_reb(jbnd1, jbnd2, jm) 100 ! ice concentration should not exceed amax 101 !----------------------------------------------------- 102 DO jl = 1, jpl 103 DO jj = 1, jpj 104 DO ji = 1, jpi 105 IF( at_i(ji,jj) > amax .AND. a_i(ji,jj,jl) > 0._wp ) THEN 106 a_i(ji,jj,jl) = a_i(ji,jj,jl) * ( 1._wp - ( 1._wp - amax / at_i(ji,jj) ) ) 107 ht_i(ji,jj,jl) = v_i(ji,jj,jl) / a_i(ji,jj,jl) 108 ENDIF 109 END DO 110 END DO 198 111 END DO 199 112 … … 202 115 at_i(:,:) = a_i(:,:,jl) + at_i(:,:) 203 116 END DO 204 205 zbigvalue = 1.0e+20 206 207 DO jl = 1, jpl 208 DO jj = 1, jpj 209 DO ji = 1, jpi 210 211 !switches 212 zindb = MAX( rzero, SIGN( rone, a_i(ji,jj,jl) - epsi10 ) ) 213 !switch = 1 if a_i > 1e-06 and 0 if not 214 zindsn = MAX( rzero, SIGN( rone, v_s(ji,jj,jl) - epsi10 ) ) !=1 if hs > 1e-10 and 0 if not 215 zindic = MAX( rzero, SIGN( rone, v_i(ji,jj,jl) - epsi10 ) ) !=1 if hi > 1e-10 and 0 if not 216 ! bug fix 25 avril 2007 217 zindb = zindb*zindic 218 219 !--- 2.3 Correction to ice age 220 !------------------------------ 221 ! IF ((o_i(ji,jj,jl)-1.0)*rday.gt.(rdt_ice*float(numit))) THEN 222 ! o_i(ji,jj,jl) = rdt_ice*FLOAT(numit)/rday 223 ! ENDIF 224 IF ((oa_i(ji,jj,jl)-1.0)*rday.gt.(rdt_ice*numit*a_i(ji,jj,jl))) THEN 225 oa_i(ji,jj,jl) = rdt_ice*numit/rday*a_i(ji,jj,jl) 226 ENDIF 227 oa_i(ji,jj,jl) = zindb*zindic*oa_i(ji,jj,jl) 228 229 !--- 2.4 Correction to snow thickness 230 !------------------------------------- 231 ! ! snow thickness has to be greater than 0, and if ice concentration smaller than 1e-6 then hs = 0 232 ! v_s(ji,jj,jl) = MAX( zindb * v_s(ji,jj,jl), 0.0) 233 ! snow thickness cannot be smaller than 1e-6 234 zdvres = (zindsn * zindb - 1._wp) * v_s(ji,jj,jl) 235 v_s(ji,jj,jl) = v_s(ji,jj,jl) + zdvres 236 237 !rdm_snw(ji,jj) = rdm_snw(ji,jj) + zdvres * rhosn 238 239 !--- 2.5 Correction to ice thickness 240 !------------------------------------- 241 zdvres = (zindb - 1._wp) * v_i(ji,jj,jl) 242 v_i(ji,jj,jl) = v_i(ji,jj,jl) + zdvres 243 244 !rdm_ice(ji,jj) = rdm_ice(ji,jj) + zdvres * rhoic 245 !sfx_res(ji,jj) = sfx_res(ji,jj) - sm_i(ji,jj,jl) * ( rhoic * zdvres / rdt_ice ) 246 247 !--- 2.6 Snow is transformed into ice if the original ice cover disappears 248 !---------------------------------------------------------------------------- 249 zindg = tms(ji,jj) * MAX( 0._wp, SIGN( 1._wp, -v_i(ji,jj,jl) ) ) 250 zdvres = zindg * rhosn * v_s(ji,jj,jl) / rau0 251 v_i(ji,jj,jl) = v_i(ji,jj,jl) + zdvres 252 253 zdvres = zindsn*zindb * ( - zindg * v_s(ji,jj,jl) + zindg * v_i(ji,jj,jl) * ( rau0 - rhoic ) / rhosn ) 254 v_s(ji,jj,jl) = v_s(ji,jj,jl) + zdvres 255 256 !--- 2.7 Correction to ice concentrations 257 !-------------------------------------------- 258 ! if greater than 0, ice concentration cannot be smaller than 1e-10 259 a_i(ji,jj,jl) = zindb * a_i(ji,jj,jl) 260 261 !------------------------- 262 ! 2.8) Snow heat content 263 !------------------------- 264 e_s(ji,jj,1,jl) = zindsn * ( MIN ( MAX ( 0._wp, e_s(ji,jj,1,jl) ), zbigvalue ) ) 265 266 END DO ! ji 267 END DO ! jj 268 END DO ! jl 269 270 !------------------------ 271 ! 2.9) Ice heat content 272 !------------------------ 273 274 DO jl = 1, jpl 275 DO jk = 1, nlay_i 117 118 ! -------------------------------------- 119 ! Final thickness distribution rebinning 120 ! -------------------------------------- 121 IF ( jpl > 1 ) CALL lim_itd_th_reb(1, jpl) 122 123 !----------------- 124 ! zap small values 125 !----------------- 126 CALL lim_itd_me_zapsmall 127 128 !--------------------- 129 ! Ice salinity bounds 130 !--------------------- 131 IF ( num_sal == 2 ) THEN 132 DO jl = 1, jpl 276 133 DO jj = 1, jpj 277 134 DO ji = 1, jpi 278 zindic = MAX( rzero, SIGN( rone, v_i(ji,jj,jl) - epsi10 ) ) 279 e_i(ji,jj,jk,jl)= zindic * ( MIN ( MAX ( 0.0, e_i(ji,jj,jk,jl) ), zbigvalue ) ) 280 END DO ! ji 281 END DO ! jj 282 END DO !jk 283 END DO !jl 284 285 at_i(:,:) = 0._wp 286 DO jl = 1, jpl 287 at_i(:,:) = a_i(:,:,jl) + at_i(:,:) 288 END DO 289 290 !--- 2.13 ice concentration should not exceed amax 291 ! (it should not be the case) 292 !----------------------------------------------------- 293 DO jj = 1, jpj 294 DO ji = 1, jpi 295 z_da_ex = MAX( at_i(ji,jj) - amax , 0.0 ) 296 zindb = MAX( rzero, SIGN( rone, at_i(ji,jj) - epsi10 ) ) 297 DO jl = 1, jpl 298 z_da_i = a_i(ji,jj,jl) * z_da_ex / MAX( at_i(ji,jj), epsi10 ) * zindb 299 a_i(ji,jj,jl) = MAX( 0._wp, a_i(ji,jj,jl) - z_da_i ) 300 ! 301 zinda = MAX( rzero, SIGN( rone, a_i(ji,jj,jl) - epsi10 ) ) 302 ht_i(ji,jj,jl) = v_i(ji,jj,jl) / MAX( a_i(ji,jj,jl), epsi10 ) * zinda 303 !v_i(ji,jj,jl) = ht_i(ji,jj,jl) * a_i(ji,jj,jl) ! makes ice shrinken but should not be used 135 zsal = smv_i(ji,jj,jl) 136 smv_i(ji,jj,jl) = sm_i(ji,jj,jl) * v_i(ji,jj,jl) 137 ! salinity stays in bounds 138 i_ice_switch = 1._wp - MAX( 0._wp, SIGN( 1._wp, - v_i(ji,jj,jl) ) ) 139 smv_i(ji,jj,jl) = i_ice_switch * MAX( MIN( s_i_max * v_i(ji,jj,jl), smv_i(ji,jj,jl) ), s_i_min * v_i(ji,jj,jl) ) 140 ! associated salt flux 141 sfx_res(ji,jj) = sfx_res(ji,jj) - ( smv_i(ji,jj,jl) - zsal ) * rhoic * r1_rdtice 142 END DO 304 143 END DO 305 144 END DO 306 END DO307 at_i(:,:) = a_i(:,:,1)308 DO jl = 2, jpl309 at_i(:,:) = a_i(:,:,jl) + at_i(:,:)310 END DO311 312 313 ! Final thickness distribution rebinning314 ! --------------------------------------315 DO jm = 1, jpm316 jbnd1 = ice_cat_bounds(jm,1)317 jbnd2 = ice_cat_bounds(jm,2)318 IF (ice_ncat_types(jm) .GT. 1 ) CALL lim_itd_th_reb(jbnd1, jbnd2, jm)319 IF (ice_ncat_types(jm) .EQ. 1 ) THEN320 ENDIF321 END DO322 323 324 !---------------------325 ! 2.11) Ice salinity326 !---------------------327 ! clem correct bug on smv_i328 smv_i(:,:,:) = sm_i(:,:,:) * v_i(:,:,:)329 330 IF ( num_sal == 2 ) THEN ! general case331 DO jl = 1, jpl332 !DO jk = 1, nlay_i333 DO jj = 1, jpj334 DO ji = 1, jpi335 ! salinity stays in bounds336 !clem smv_i(ji,jj,jl) = MAX(MIN((rhoic-rhosn)/rhoic*sss_m(ji,jj),smv_i(ji,jj,jl)),0.1 * v_i(ji,jj,jl) )337 smv_i(ji,jj,jl) = MAX( MIN( s_i_max * v_i(ji,jj,jl), smv_i(ji,jj,jl) ), s_i_min * v_i(ji,jj,jl) )338 i_ice_switch = 1._wp - MAX( 0._wp, SIGN( 1._wp, -v_i(ji,jj,jl) ) )339 smv_i(ji,jj,jl) = i_ice_switch * smv_i(ji,jj,jl) !+ s_i_min * ( 1._wp - i_ice_switch ) * v_i(ji,jj,jl)340 END DO ! ji341 END DO ! jj342 !END DO !jk343 END DO !jl344 145 ENDIF 345 146 346 at_i(:,:) = a_i(:,:,1) 347 DO jl = 2, jpl 348 at_i(:,:) = a_i(:,:,jl) + at_i(:,:) 349 END DO 350 351 352 !-------------------------------- 353 ! Update mass/salt fluxes (clem) 354 !-------------------------------- 355 DO jl = 1, jpl 356 DO jj = 1, jpj 357 DO ji = 1, jpi 358 diag_res_pr(ji,jj) = diag_res_pr(ji,jj) + ( v_i(ji,jj,jl) - zviold(ji,jj,jl) ) / rdt_ice 359 rdm_ice(ji,jj) = rdm_ice(ji,jj) + ( v_i(ji,jj,jl) - zviold(ji,jj,jl) ) * rhoic 360 rdm_snw(ji,jj) = rdm_snw(ji,jj) + ( v_s(ji,jj,jl) - zvsold(ji,jj,jl) ) * rhosn 361 sfx_res(ji,jj) = sfx_res(ji,jj) - ( smv_i(ji,jj,jl) - zsmvold(ji,jj,jl) ) * rhoic / rdt_ice 362 END DO 363 END DO 364 END DO 365 366 ! ------------------------------- 367 !- check conservation (C Rousset) 368 IF (ln_limdiahsb) THEN 369 370 zchk_fs = glob_sum( ( sfx_bri(:,:) + sfx_thd(:,:) + sfx_res(:,:) + sfx_mec(:,:) ) * area(:,:) * tms(:,:) ) - zchk_fs_b 371 zchk_fw = glob_sum( rdm_ice(:,:) * area(:,:) * tms(:,:) ) - zchk_fw_b 372 373 zchk_v_i = ( glob_sum( SUM( v_i(:,:,:), dim=3 ) * area(:,:) * tms(:,:) ) - zchk_v_i_b - ( zchk_fw / rhoic ) ) * r1_rdtice 374 zchk_smv = ( glob_sum( SUM( smv_i(:,:,:), dim=3 ) * area(:,:) * tms(:,:) ) - zchk_smv_b ) * r1_rdtice + ( zchk_fs / rhoic ) 375 376 zchk_vmin = glob_min(v_i) 377 zchk_amax = glob_max(SUM(a_i,dim=3)) 378 zchk_amin = glob_min(a_i) 379 380 IF(lwp) THEN 381 IF ( ABS( zchk_v_i ) > 1.e-5 ) WRITE(numout,*) 'violation volume [m3/day] (limupdate1) = ',(zchk_v_i * rday) 382 IF ( ABS( zchk_smv ) > 1.e-4 ) WRITE(numout,*) 'violation saline [psu*m3/day] (limupdate1) = ',(zchk_smv * rday) 383 IF ( zchk_vmin < 0. ) WRITE(numout,*) 'violation v_i<0 [mm] (limupdate1) = ',(zchk_vmin * 1.e-3) 384 IF ( zchk_amax > amax+epsi10 ) WRITE(numout,*) 'violation a_i>amax (limupdate1) = ',zchk_amax 385 IF ( zchk_amin < 0. ) WRITE(numout,*) 'violation a_i<0 (limupdate1) = ',zchk_amin 386 ENDIF 387 ENDIF 388 !- check conservation (C Rousset) 389 ! ------------------------------- 147 ! ------------------------------------------------- 148 ! Diagnostics 149 ! ------------------------------------------------- 150 d_u_ice_dyn(:,:) = u_ice(:,:) - u_ice_b(:,:) 151 d_v_ice_dyn(:,:) = v_ice(:,:) - v_ice_b(:,:) 152 d_a_i_trp (:,:,:) = a_i (:,:,:) - a_i_b (:,:,:) 153 d_v_s_trp (:,:,:) = v_s (:,:,:) - v_s_b (:,:,:) 154 d_v_i_trp (:,:,:) = v_i (:,:,:) - v_i_b (:,:,:) 155 d_e_s_trp (:,:,:,:) = e_s (:,:,:,:) - e_s_b (:,:,:,:) 156 d_e_i_trp (:,:,1:nlay_i,:) = e_i (:,:,1:nlay_i,:) - e_i_b(:,:,1:nlay_i,:) 157 d_oa_i_trp (:,:,:) = oa_i (:,:,:) - oa_i_b (:,:,:) 158 d_smv_i_trp(:,:,:) = 0._wp 159 IF( num_sal == 2 ) d_smv_i_trp(:,:,:) = smv_i(:,:,:) - smv_i_b(:,:,:) 160 161 ! conservation test 162 IF( ln_limdiahsb ) CALL lim_cons_hsm(1, 'limupdate1', zvi_b, zsmv_b, zei_b, zfw_b, zfs_b, zft_b) 390 163 391 164 IF(ln_ctl) THEN ! Control print … … 400 173 CALL prt_ctl(tab2d_1=u_ice , clinfo1=' lim_update1 : u_ice :', tab2d_2=v_ice , clinfo2=' v_ice :') 401 174 CALL prt_ctl(tab2d_1=d_u_ice_dyn, clinfo1=' lim_update1 : d_u_ice_dyn :', tab2d_2=d_v_ice_dyn, clinfo2=' d_v_ice_dyn :') 402 CALL prt_ctl(tab2d_1= old_u_ice , clinfo1=' lim_update1 : old_u_ice :', tab2d_2=old_v_ice , clinfo2=' old_v_ice:')175 CALL prt_ctl(tab2d_1=u_ice_b , clinfo1=' lim_update1 : u_ice_b :', tab2d_2=v_ice_b , clinfo2=' v_ice_b :') 403 176 404 177 DO jl = 1, jpl … … 413 186 CALL prt_ctl(tab2d_1=o_i (:,:,jl) , clinfo1= ' lim_update1 : o_i : ') 414 187 CALL prt_ctl(tab2d_1=a_i (:,:,jl) , clinfo1= ' lim_update1 : a_i : ') 415 CALL prt_ctl(tab2d_1= old_a_i (:,:,jl) , clinfo1= ' lim_update1 : old_a_i: ')188 CALL prt_ctl(tab2d_1=a_i_b (:,:,jl) , clinfo1= ' lim_update1 : a_i_b : ') 416 189 CALL prt_ctl(tab2d_1=d_a_i_trp (:,:,jl) , clinfo1= ' lim_update1 : d_a_i_trp : ') 417 190 CALL prt_ctl(tab2d_1=v_i (:,:,jl) , clinfo1= ' lim_update1 : v_i : ') 418 CALL prt_ctl(tab2d_1= old_v_i (:,:,jl) , clinfo1= ' lim_update1 : old_v_i: ')191 CALL prt_ctl(tab2d_1=v_i_b (:,:,jl) , clinfo1= ' lim_update1 : v_i_b : ') 419 192 CALL prt_ctl(tab2d_1=d_v_i_trp (:,:,jl) , clinfo1= ' lim_update1 : d_v_i_trp : ') 420 193 CALL prt_ctl(tab2d_1=v_s (:,:,jl) , clinfo1= ' lim_update1 : v_s : ') 421 CALL prt_ctl(tab2d_1= old_v_s (:,:,jl) , clinfo1= ' lim_update1 : old_v_s: ')194 CALL prt_ctl(tab2d_1=v_s_b (:,:,jl) , clinfo1= ' lim_update1 : v_s_b : ') 422 195 CALL prt_ctl(tab2d_1=d_v_s_trp (:,:,jl) , clinfo1= ' lim_update1 : d_v_s_trp : ') 423 196 CALL prt_ctl(tab2d_1=e_i (:,:,1,jl)/1.0e9, clinfo1= ' lim_update1 : e_i1 : ') 424 CALL prt_ctl(tab2d_1= old_e_i (:,:,1,jl)/1.0e9, clinfo1= ' lim_update1 : old_e_i1: ')197 CALL prt_ctl(tab2d_1=e_i_b (:,:,1,jl)/1.0e9, clinfo1= ' lim_update1 : e_i1_b : ') 425 198 CALL prt_ctl(tab2d_1=d_e_i_trp (:,:,1,jl)/1.0e9, clinfo1= ' lim_update1 : de_i1_trp : ') 426 199 CALL prt_ctl(tab2d_1=e_i (:,:,2,jl)/1.0e9, clinfo1= ' lim_update1 : e_i2 : ') 427 CALL prt_ctl(tab2d_1= old_e_i (:,:,2,jl)/1.0e9, clinfo1= ' lim_update1 : old_e_i2: ')200 CALL prt_ctl(tab2d_1=e_i_b (:,:,2,jl)/1.0e9, clinfo1= ' lim_update1 : e_i2_b : ') 428 201 CALL prt_ctl(tab2d_1=d_e_i_trp (:,:,2,jl)/1.0e9, clinfo1= ' lim_update1 : de_i2_trp : ') 429 202 CALL prt_ctl(tab2d_1=e_s (:,:,1,jl) , clinfo1= ' lim_update1 : e_snow : ') 430 CALL prt_ctl(tab2d_1= old_e_s (:,:,1,jl) , clinfo1= ' lim_update1 : old_e_snow: ')203 CALL prt_ctl(tab2d_1=e_s_b (:,:,1,jl) , clinfo1= ' lim_update1 : e_snow_b : ') 431 204 CALL prt_ctl(tab2d_1=d_e_s_trp (:,:,1,jl)/1.0e9, clinfo1= ' lim_update1 : d_e_s_trp : ') 432 205 CALL prt_ctl(tab2d_1=smv_i (:,:,jl) , clinfo1= ' lim_update1 : smv_i : ') 433 CALL prt_ctl(tab2d_1= old_smv_i (:,:,jl) , clinfo1= ' lim_update1 : old_smv_i: ')206 CALL prt_ctl(tab2d_1=smv_i_b (:,:,jl) , clinfo1= ' lim_update1 : smv_i_b : ') 434 207 CALL prt_ctl(tab2d_1=d_smv_i_trp(:,:,jl) , clinfo1= ' lim_update1 : d_smv_i_trp : ') 435 208 CALL prt_ctl(tab2d_1=oa_i (:,:,jl) , clinfo1= ' lim_update1 : oa_i : ') 436 CALL prt_ctl(tab2d_1=o ld_oa_i (:,:,jl) , clinfo1= ' lim_update1 : old_oa_i: ')209 CALL prt_ctl(tab2d_1=oa_i_b (:,:,jl) , clinfo1= ' lim_update1 : oa_i_b : ') 437 210 CALL prt_ctl(tab2d_1=d_oa_i_trp (:,:,jl) , clinfo1= ' lim_update1 : d_oa_i_trp : ') 438 211 … … 446 219 CALL prt_ctl_info(' - Heat / FW fluxes : ') 447 220 CALL prt_ctl_info(' ~~~~~~~~~~~~~~~~~~ ') 448 CALL prt_ctl(tab2d_1=fmmec , clinfo1= ' lim_update1 : fmmec : ', tab2d_2=fhmec , clinfo2= ' fhmec : ')449 221 CALL prt_ctl(tab2d_1=sst_m , clinfo1= ' lim_update1 : sst : ', tab2d_2=sss_m , clinfo2= ' sss : ') 450 CALL prt_ctl(tab2d_1=fhbri , clinfo1= ' lim_update1 : fhbri : ', tab2d_2=fheat_mec , clinfo2= ' fheat_mec : ')451 222 452 223 CALL prt_ctl_info(' ') … … 458 229 ENDIF 459 230 460 461 CALL wrk_dealloc( jkmax, zthick0, zqm0 ) 462 463 CALL wrk_dealloc( jpi,jpj,jpl,zviold, zvsold, zsmvold ) ! clem 231 ENDIF ! ln_limdyn 464 232 465 233 IF( nn_timing == 1 ) CALL timing_stop('limupdate1') -
branches/2014/dev_r4650_UKMO14.12_STAND_ALONE_OBSOPER/NEMOGCM/NEMO/LIM_SRC_3/limupdate2.F90
r4333 r5034 5 5 !!====================================================================== 6 6 !! History : 3.0 ! 2006-04 (M. Vancoppenolle) Original code 7 !! 3.6 ! 2014-06 (C. Rousset) Complete rewriting/cleaning 7 8 !!---------------------------------------------------------------------- 8 9 #if defined key_lim3 … … 39 40 USE lib_fortran ! glob_sum 40 41 USE timing ! Timing 42 USE limcons ! conservation tests 41 43 42 44 IMPLICIT NONE … … 45 47 PUBLIC lim_update2 ! routine called by ice_step 46 48 47 REAL(wp) :: epsi10 = 1.e-10_wp ! - -48 REAL(wp) :: rzero = 0._wp ! - -49 REAL(wp) :: rone = 1._wp ! - -50 51 49 !! * Substitutions 52 50 # include "vectopt_loop_substitute.h90" … … 64 62 !! ** Purpose : Computes update of sea-ice global variables at 65 63 !! the end of the time step. 66 !! Address pathological cases67 !! This place is very important68 !!69 !! ** Method :70 !! Ice speed from ice dynamics71 !! Ice thickness, Snow thickness, Temperatures, Lead fraction72 !! from advection and ice thermodynamics73 64 !! 74 !! ** Action : -75 65 !!--------------------------------------------------------------------- 76 INTEGER :: ji, jj, jk, jl, jm ! dummy loop indices 77 INTEGER :: jbnd1, jbnd2 78 INTEGER :: i_ice_switch 79 INTEGER :: ind_im, layer ! indices for internal melt 80 REAL(wp) :: zweight, zesum, zhimax, z_da_i 81 REAL(wp) :: zinda, zindb, zindsn, zindic 82 REAL(wp) :: zindg, zh, zdvres, zviold2 83 REAL(wp) :: zbigvalue, zvsold2, z_da_ex 84 REAL(wp) :: z_prescr_hi, zat_i_old, ztmelts, ze_s 85 86 INTEGER , POINTER, DIMENSION(:,:,:) :: internal_melt 87 REAL(wp), POINTER, DIMENSION(:) :: zthick0, zqm0 ! thickness of the layers and heat contents for 88 REAL(wp) :: zchk_v_i, zchk_smv, zchk_fs, zchk_fw, zchk_v_i_b, zchk_smv_b, zchk_fs_b, zchk_fw_b ! Check conservation (C Rousset) 89 REAL(wp) :: zchk_vmin, zchk_amin, zchk_amax ! Check errors (C Rousset) 90 ! mass and salt flux (clem) 91 REAL(wp), POINTER, DIMENSION(:,:,:) :: zviold, zvsold, zsmvold ! old ice volume... 66 INTEGER :: ji, jj, jk, jl ! dummy loop indices 67 INTEGER :: i_ice_switch 68 REAL(wp) :: zh, zsal 69 ! 70 REAL(wp) :: zvi_b, zsmv_b, zei_b, zfs_b, zfw_b, zft_b 92 71 !!------------------------------------------------------------------- 93 72 IF( nn_timing == 1 ) CALL timing_start('limupdate2') 94 73 95 CALL wrk_alloc( jpi,jpj,jpl, internal_melt ) ! integer 96 CALL wrk_alloc( jkmax, zthick0, zqm0 ) 97 98 CALL wrk_alloc( jpi,jpj,jpl,zviold, zvsold, zsmvold ) ! clem 99 100 !---------------------------------------------------------------------------------------- 101 ! 1. Computation of trend terms 102 !---------------------------------------------------------------------------------------- 103 !- Trend terms 104 d_a_i_thd(:,:,:) = a_i(:,:,:) - old_a_i(:,:,:) 105 d_v_s_thd(:,:,:) = v_s(:,:,:) - old_v_s(:,:,:) 106 d_v_i_thd(:,:,:) = v_i(:,:,:) - old_v_i(:,:,:) 107 d_e_s_thd(:,:,:,:) = e_s(:,:,:,:) - old_e_s(:,:,:,:) 108 d_e_i_thd(:,:,:,:) = e_i(:,:,:,:) - old_e_i(:,:,:,:) 109 !?? d_oa_i_thd(:,:,:) = oa_i (:,:,:) - old_oa_i (:,:,:) 110 d_smv_i_thd(:,:,:) = 0._wp 111 IF( num_sal == 2 ) d_smv_i_thd(:,:,:) = smv_i(:,:,:) - old_smv_i(:,:,:) 112 ! diag only (clem) 113 dv_dt_thd(:,:,:) = d_v_i_thd(:,:,:) * r1_rdtice * rday 114 115 ! mass and salt flux init (clem) 116 zviold(:,:,:) = v_i(:,:,:) 117 zvsold(:,:,:) = v_s(:,:,:) 118 zsmvold(:,:,:) = smv_i(:,:,:) 119 120 ! ------------------------------- 121 !- check conservation (C Rousset) 122 IF (ln_limdiahsb) THEN 123 zchk_v_i_b = glob_sum( SUM( v_i(:,:,:), dim=3 ) * area(:,:) * tms(:,:) ) 124 zchk_smv_b = glob_sum( SUM( smv_i(:,:,:), dim=3 ) * area(:,:) * tms(:,:) ) 125 zchk_fw_b = glob_sum( rdm_ice(:,:) * area(:,:) * tms(:,:) ) 126 zchk_fs_b = glob_sum( ( sfx_bri(:,:) + sfx_thd(:,:) + sfx_res(:,:) + sfx_mec(:,:) ) * area(:,:) * tms(:,:) ) 127 ENDIF 128 !- check conservation (C Rousset) 129 ! ------------------------------- 74 ! conservation test 75 IF( ln_limdiahsb ) CALL lim_cons_hsm(0, 'limupdate2', zvi_b, zsmv_b, zei_b, zfw_b, zfs_b, zft_b) 76 77 !----------------- 78 ! zap small values 79 !----------------- 80 CALL lim_itd_me_zapsmall 130 81 131 82 CALL lim_var_glo2eqv 132 83 133 !-------------------------------------- 134 ! 2. Review of all pathological cases 135 !-------------------------------------- 136 137 ! clem: useless now 138 !------------------------------------------- 139 ! 2.1) Advection of ice in an ice-free cell 140 !------------------------------------------- 141 ! should be removed since it is treated after dynamics now 142 ! zhimax = 5._wp 143 ! ! first category 144 ! DO jj = 1, jpj 145 ! DO ji = 1, jpi 146 ! !--- the thickness of such an ice is often out of bounds 147 ! !--- thus we recompute a new area while conserving ice volume 148 ! zat_i_old = SUM( old_a_i(ji,jj,:) ) 149 ! zindb = MAX( 0._wp, SIGN( 1._wp, ABS( d_a_i_thd(ji,jj,1) ) - epsi10 ) ) 150 ! IF ( ( ABS( d_v_i_thd(ji,jj,1) ) / MAX( ABS( d_a_i_thd(ji,jj,1) ),epsi10 ) * zindb .GT. zhimax ) & 151 ! & .AND. ( ( v_i(ji,jj,1) / MAX( a_i(ji,jj,1), epsi10 ) * zindb ) .GT. zhimax ) & 152 ! & .AND. ( zat_i_old .LT. 1.e-6 ) ) THEN ! new line 153 ! ht_i(ji,jj,1) = hi_max(1) * 0.5_wp 154 ! a_i (ji,jj,1) = v_i(ji,jj,1) / ht_i(ji,jj,1) 155 ! ENDIF 156 ! END DO 157 ! END DO 158 159 ! zhimax = 20._wp 160 ! ! other categories 161 ! DO jl = 2, jpl 162 ! jm = ice_types(jl) 163 ! DO jj = 1, jpj 164 ! DO ji = 1, jpi 165 ! zindb = MAX( rzero, SIGN( rone, ABS( d_a_i_thd(ji,jj,jl)) - epsi10 ) ) 166 ! ! this correction is very tricky... sometimes, advection gets wrong i don't know why 167 ! ! it makes problems when the advected volume and concentration do not seem to be 168 ! ! related with each other 169 ! ! the new thickness is sometimes very big! 170 ! ! and sometimes d_a_i_trp and d_v_i_trp have different sign 171 ! ! which of course is plausible 172 ! ! but fuck! it fucks everything up :) 173 ! IF ( ( ABS( d_v_i_thd(ji,jj,jl) ) / MAX( ABS( d_a_i_thd(ji,jj,jl) ), epsi10 ) * zindb .GT. zhimax ) & 174 ! & .AND. ( v_i(ji,jj,jl) / MAX( a_i(ji,jj,jl), epsi10 ) * zindb ) .GT. zhimax ) THEN 175 ! ht_i(ji,jj,jl) = ( hi_max_typ(jl-ice_cat_bounds(jm,1),jm) + hi_max_typ(jl-ice_cat_bounds(jm,1)+1,jm) ) * 0.5_wp 176 ! a_i (ji,jj,jl) = v_i(ji,jj,jl) / ht_i(ji,jj,jl) 177 ! ENDIF 178 ! END DO ! ji 179 ! END DO !jj 180 ! END DO !jl 181 84 !---------------------------------------------------- 85 ! Rebin categories with thickness out of bounds 86 !---------------------------------------------------- 87 IF ( jpl > 1 ) CALL lim_itd_th_reb(1, jpl) 88 89 !---------------------------------------------------------------------- 90 ! Constrain the thickness of the smallest category above hiclim 91 !---------------------------------------------------------------------- 92 DO jj = 1, jpj 93 DO ji = 1, jpi 94 IF( v_i(ji,jj,1) > 0._wp .AND. ht_i(ji,jj,1) < hiclim ) THEN 95 zh = hiclim / ht_i(ji,jj,1) 96 ht_s(ji,jj,1) = ht_s(ji,jj,1) * zh 97 ht_i(ji,jj,1) = ht_i(ji,jj,1) * zh 98 a_i (ji,jj,1) = a_i(ji,jj,1) / zh 99 ENDIF 100 END DO 101 END DO 102 103 !----------------------------------------------------- 104 ! ice concentration should not exceed amax 105 !----------------------------------------------------- 182 106 at_i(:,:) = 0._wp 183 107 DO jl = 1, jpl … … 185 109 END DO 186 110 187 !---------------------------------------------------- 188 ! 2.2) Rebin categories with thickness out of bounds 189 !---------------------------------------------------- 190 DO jm = 1, jpm 191 jbnd1 = ice_cat_bounds(jm,1) 192 jbnd2 = ice_cat_bounds(jm,2) 193 IF (ice_ncat_types(jm) .GT. 1 ) CALL lim_itd_th_reb(jbnd1, jbnd2, jm) 194 END DO 195 196 !--------------------------------- 197 ! 2.3) Melt of an internal layer 198 !--------------------------------- 199 internal_melt(:,:,:) = 0 200 201 DO jl = 1, jpl 202 DO jk = 1, nlay_i 203 DO jj = 1, jpj 204 DO ji = 1, jpi 205 ztmelts = - tmut * s_i(ji,jj,jk,jl) + rtt 206 IF ( ( ( e_i(ji,jj,jk,jl) .LE. 0.0 ) .OR. ( t_i(ji,jj,jk,jl) .GE. ztmelts ) ) & 207 & .AND. ( v_i(ji,jj,jl) .GT. 0.0 ) .AND. ( a_i(ji,jj,jl) .GT. 0.0 ) ) THEN 208 internal_melt(ji,jj,jl) = 1 209 ENDIF 210 END DO ! ji 211 END DO ! jj 212 END DO !jk 213 END DO !jl 214 215 DO jl = 1, jpl 216 DO jj = 1, jpj 111 DO jl = 1, jpl 112 DO jj = 1, jpj 217 113 DO ji = 1, jpi 218 IF( internal_melt(ji,jj,jl) == 1 ) THEN 219 ! initial ice thickness 220 !----------------------- 114 IF( at_i(ji,jj) > amax .AND. a_i(ji,jj,jl) > 0._wp ) THEN 115 a_i(ji,jj,jl) = a_i(ji,jj,jl) * ( 1._wp - ( 1._wp - amax / at_i(ji,jj) ) ) 221 116 ht_i(ji,jj,jl) = v_i(ji,jj,jl) / a_i(ji,jj,jl) 222 223 ! reduce ice thickness 224 !----------------------- 225 ind_im = 0 226 zesum = 0.0 227 DO jk = 1, nlay_i 228 ztmelts = - tmut * s_i(ji,jj,jk,jl) + rtt 229 IF ( ( e_i(ji,jj,jk,jl) .LE. 0.0 ) .OR. ( t_i(ji,jj,jk,jl) .GE. ztmelts ) ) ind_im = ind_im + 1 230 zesum = zesum + e_i(ji,jj,jk,jl) 231 END DO 232 ht_i(ji,jj,jl) = ht_i(ji,jj,jl) - REAL(ind_im)*ht_i(ji,jj,jl) / REAL(nlay_i) 233 v_i(ji,jj,jl) = ht_i(ji,jj,jl) * a_i(ji,jj,jl) 234 235 !CLEM 236 zdvres = REAL(ind_im)*ht_i(ji,jj,jl) / REAL(nlay_i) * a_i(ji,jj,jl) 237 !rdm_ice(ji,jj) = rdm_ice(ji,jj) - zdvres * rhoic 238 !sfx_res(ji,jj) = sfx_res(ji,jj) + sm_i(ji,jj,jl) * ( rhoic * zdvres / rdt_ice ) 239 240 ! redistribute heat 241 !----------------------- 242 ! old thicknesses and enthalpies 243 ind_im = 0 244 DO jk = 1, nlay_i 245 ztmelts = - tmut * s_i(ji,jj,jk,jl) + rtt 246 IF ( ( e_i(ji,jj,jk,jl) .GT. 0.0 ) .AND. & 247 ( t_i(ji,jj,jk,jl) .LT. ztmelts ) ) THEN 248 ind_im = ind_im + 1 249 zthick0(ind_im) = ht_i(ji,jj,jl) * REAL(ind_im / nlay_i) 250 zqm0 (ind_im) = MAX( e_i(ji,jj,jk,jl) , 0.0 ) 251 ENDIF 252 END DO 253 254 ! Redistributing energy on the new grid 255 IF ( ind_im .GT. 0 ) THEN 256 257 DO jk = 1, nlay_i 258 e_i(ji,jj,jk,jl) = 0.0 259 DO layer = 1, ind_im 260 zweight = MAX ( & 261 MIN( ht_i(ji,jj,jl) * REAL(layer/ind_im) , ht_i(ji,jj,jl) * REAL(jk / nlay_i) ) - & 262 MAX( ht_i(ji,jj,jl) * REAL((layer-1)/ind_im) , ht_i(ji,jj,jl) * REAL((jk-1) / nlay_i) ) , 0.0 ) & 263 / ( ht_i(ji,jj,jl) / REAL(ind_im) ) 264 265 e_i(ji,jj,jk,jl) = e_i(ji,jj,jk,jl) + zweight*zqm0(layer) 266 END DO !layer 267 END DO ! jk 268 269 zesum = 0.0 270 DO jk = 1, nlay_i 271 zesum = zesum + e_i(ji,jj,jk,jl) 272 END DO 273 274 ELSE ! ind_im .EQ. 0, total melt 275 e_i(ji,jj,jk,jl) = 0.0 276 ENDIF 277 278 ENDIF ! internal_melt 279 280 END DO ! ji 281 END DO !jj 282 END DO !jl 283 284 internal_melt(:,:,:) = 0 285 286 287 ! Melt of snow 288 !-------------- 289 DO jl = 1, jpl 290 DO jj = 1, jpj 291 DO ji = 1, jpi 292 ! snow energy of melting 293 zinda = MAX( 0._wp, SIGN( 1._wp, v_s(ji,jj,jl) - epsi10 ) ) 294 ze_s = zinda * e_s(ji,jj,1,jl) * unit_fac / area(ji,jj) / MAX( v_s(ji,jj,jl), epsi10 ) ! snow energy of melting 295 296 ! If snow energy of melting smaller then Lf 297 ! Then all snow melts and meltwater, heat go to the ocean 298 IF ( ze_s .LE. rhosn * lfus ) internal_melt(ji,jj,jl) = 1 299 117 ENDIF 300 118 END DO 301 119 END DO 302 120 END DO 303 304 DO jl = 1, jpl305 DO jj = 1, jpj306 DO ji = 1, jpi307 IF ( internal_melt(ji,jj,jl) == 1 ) THEN308 zdvres = v_s(ji,jj,jl)309 ! release heat310 fheat_res(ji,jj) = fheat_res(ji,jj) + ze_s * zdvres / rdt_ice311 ! release mass312 !rdm_snw(ji,jj) = rdm_snw(ji,jj) - zdvres * rhosn313 !314 v_s(ji,jj,jl) = 0.0315 e_s(ji,jj,1,jl) = 0.0316 ENDIF317 END DO318 END DO319 END DO320 321 zbigvalue = 1.0e+20322 DO jl = 1, jpl323 DO jj = 1, jpj324 DO ji = 1, jpi325 326 !switches327 zindb = MAX( rzero, SIGN( rone, a_i(ji,jj,jl) - epsi10 ) )328 !switch = 1 if a_i > 1e-06 and 0 if not329 zindsn = MAX( rzero, SIGN( rone, v_s(ji,jj,jl) - epsi10 ) ) !=1 if hs > 1e-10 and 0 if not330 zindic = MAX( rzero, SIGN( rone, v_i(ji,jj,jl) - epsi10 ) ) !=1 if hi > 1e-10 and 0 if not331 ! bug fix 25 avril 2007332 zindb = zindb*zindic333 334 !--- 2.3 Correction to ice age335 !------------------------------336 ! IF ((o_i(ji,jj,jl)-1.0)*rday.gt.(rdt_ice*float(numit))) THEN337 ! o_i(ji,jj,jl) = rdt_ice*FLOAT(numit)/rday338 ! ENDIF339 IF ((oa_i(ji,jj,jl)-1.0)*rday.gt.(rdt_ice*numit*a_i(ji,jj,jl))) THEN340 oa_i(ji,jj,jl) = rdt_ice*numit/rday*a_i(ji,jj,jl)341 ENDIF342 oa_i(ji,jj,jl) = zindb*zindic*oa_i(ji,jj,jl)343 344 !--- 2.4 Correction to snow thickness345 !-------------------------------------346 zdvres = (zindsn * zindb - 1._wp) * v_s(ji,jj,jl)347 v_s(ji,jj,jl) = v_s(ji,jj,jl) + zdvres348 349 !rdm_snw(ji,jj) = rdm_snw(ji,jj) + zdvres * rhosn350 351 !--- 2.5 Correction to ice thickness352 !-------------------------------------353 zdvres = (zindb - 1._wp) * v_i(ji,jj,jl)354 v_i(ji,jj,jl) = v_i(ji,jj,jl) + zdvres355 356 !rdm_ice(ji,jj) = rdm_ice(ji,jj) + zdvres * rhoic357 !sfx_res(ji,jj) = sfx_res(ji,jj) - sm_i(ji,jj,jl) * ( rhoic * zdvres / rdt_ice )358 359 !--- 2.6 Snow is transformed into ice if the original ice cover disappears360 !----------------------------------------------------------------------------361 zindg = tms(ji,jj) * MAX( 0._wp, SIGN( 1._wp, -v_i(ji,jj,jl) ) )362 zdvres = zindg * rhosn * v_s(ji,jj,jl) / rau0363 v_i(ji,jj,jl) = v_i(ji,jj,jl) + zdvres364 365 zdvres = zindsn*zindb * ( - zindg * v_s(ji,jj,jl) + zindg * v_i(ji,jj,jl) * ( rau0 - rhoic ) / rhosn )366 v_s(ji,jj,jl) = v_s(ji,jj,jl) + zdvres367 368 !--- 2.7 Correction to ice concentrations369 !--------------------------------------------370 a_i(ji,jj,jl) = zindb * a_i(ji,jj,jl)371 372 !-------------------------373 ! 2.8) Snow heat content374 !-------------------------375 e_s(ji,jj,1,jl) = zindsn * ( MIN ( MAX ( 0.0, e_s(ji,jj,1,jl) ), zbigvalue ) )376 377 END DO ! ji378 END DO ! jj379 END DO ! jl380 381 !------------------------382 ! 2.9) Ice heat content383 !------------------------384 385 DO jl = 1, jpl386 DO jk = 1, nlay_i387 DO jj = 1, jpj388 DO ji = 1, jpi389 zindic = MAX( rzero, SIGN( rone, v_i(ji,jj,jl) - epsi10 ) )390 e_i(ji,jj,jk,jl)= zindic * ( MIN ( MAX ( 0.0, e_i(ji,jj,jk,jl) ), zbigvalue ) )391 END DO ! ji392 END DO ! jj393 END DO !jk394 END DO !jl395 396 397 DO jm = 1, jpm398 DO jj = 1, jpj399 DO ji = 1, jpi400 jl = ice_cat_bounds(jm,1)401 !--- 2.12 Constrain the thickness of the smallest category above 5 cm402 !----------------------------------------------------------------------403 zindb = MAX( rzero, SIGN( rone, a_i(ji,jj,jl) - epsi10 ) )404 ht_i(ji,jj,jl) = zindb*v_i(ji,jj,jl)/MAX(a_i(ji,jj,jl), epsi10)405 zh = MAX( rone , zindb * hiclim / MAX( ht_i(ji,jj,jl) , epsi10 ) )406 ht_s(ji,jj,jl) = ht_s(ji,jj,jl)* zh407 ht_i(ji,jj,jl) = ht_i(ji,jj,jl)* zh408 a_i (ji,jj,jl) = a_i(ji,jj,jl) / zh409 !CLEM410 v_i (ji,jj,jl) = a_i(ji,jj,jl) * ht_i(ji,jj,jl)411 v_s (ji,jj,jl) = a_i(ji,jj,jl) * ht_s(ji,jj,jl)412 END DO !ji413 END DO !jj414 END DO !jm415 121 416 122 at_i(:,:) = 0.0 … … 418 124 at_i(:,:) = a_i(:,:,jl) + at_i(:,:) 419 125 END DO 420 421 !--- 2.13 ice concentration should not exceed amax 422 ! (it should not be the case) 423 !----------------------------------------------------- 424 DO jj = 1, jpj 425 DO ji = 1, jpi 426 z_da_ex = MAX( at_i(ji,jj) - amax , 0.0 ) 427 zindb = MAX( rzero, SIGN( rone, at_i(ji,jj) - epsi10 ) ) 428 DO jl = 1, jpl 429 z_da_i = a_i(ji,jj,jl) * z_da_ex / MAX( at_i(ji,jj), epsi10 ) * zindb 430 a_i(ji,jj,jl) = MAX( 0._wp, a_i(ji,jj,jl) - z_da_i ) 431 ! 432 zinda = MAX( rzero, SIGN( rone, a_i(ji,jj,jl) - epsi10 ) ) 433 ht_i(ji,jj,jl) = v_i(ji,jj,jl) / MAX( a_i(ji,jj,jl), epsi10 ) * zinda 434 !v_i(ji,jj,jl) = ht_i(ji,jj,jl) * a_i(ji,jj,jl) ! makes ice shrinken but should not be used 435 END DO 436 END DO 437 END DO 438 at_i(:,:) = 0.0 439 DO jl = 1, jpl 440 at_i(:,:) = a_i(:,:,jl) + at_i(:,:) 441 END DO 442 126 127 ! -------------------------------------- 443 128 ! Final thickness distribution rebinning 444 129 ! -------------------------------------- 445 DO jm = 1, jpm 446 jbnd1 = ice_cat_bounds(jm,1) 447 jbnd2 = ice_cat_bounds(jm,2) 448 IF (ice_ncat_types(jm) .GT. 1 ) CALL lim_itd_th_reb(jbnd1, jbnd2, jm) 449 IF (ice_ncat_types(jm) .EQ. 1 ) THEN 450 ENDIF 451 END DO 130 IF ( jpl > 1 ) CALL lim_itd_th_reb( 1, jpl ) 131 132 !----------------- 133 ! zap small values 134 !----------------- 135 CALL lim_itd_me_zapsmall 452 136 453 137 !--------------------- 454 138 ! 2.11) Ice salinity 455 139 !--------------------- 456 ! clem correct bug on smv_i 457 smv_i(:,:,:) = sm_i(:,:,:) * v_i(:,:,:) 458 459 IF ( num_sal == 2 ) THEN ! general case 140 IF ( num_sal == 2 ) THEN 460 141 DO jl = 1, jpl 461 !DO jk = 1, nlay_i462 DO j j = 1, jpj463 DO ji = 1, jpi464 ! salinity stays in bounds465 !clem smv_i(ji,jj,jl) = MAX(MIN((rhoic-rhosn)/rhoic*sss_m(ji,jj),smv_i(ji,jj,jl)),0.1 * v_i(ji,jj,jl) )466 smv_i(ji,jj,jl) = MAX( MIN( s_i_max * v_i(ji,jj,jl), smv_i(ji,jj,jl) ), s_i_min * v_i(ji,jj,jl) )467 i_ice_switch = 1._wp - MAX( 0._wp, SIGN( 1._wp, -v_i(ji,jj,jl) ))468 smv_i(ji,jj,jl) = i_ice_switch * smv_i(ji,jj,jl) !+ s_i_min * ( 1._wp - i_ice_switch ) * v_i(ji,jj,jl)469 END DO ! ji470 END DO ! j j471 !END DO !jk142 DO jj = 1, jpj 143 DO ji = 1, jpi 144 zsal = smv_i(ji,jj,jl) 145 smv_i(ji,jj,jl) = sm_i(ji,jj,jl) * v_i(ji,jj,jl) 146 ! salinity stays in bounds 147 i_ice_switch = 1._wp - MAX( 0._wp, SIGN( 1._wp, - v_i(ji,jj,jl) ) ) 148 smv_i(ji,jj,jl) = i_ice_switch * MAX( MIN( s_i_max * v_i(ji,jj,jl), smv_i(ji,jj,jl) ), s_i_min * v_i(ji,jj,jl) ) !+ s_i_min * ( 1._wp - i_ice_switch ) * v_i(ji,jj,jl) 149 ! associated salt flux 150 sfx_res(ji,jj) = sfx_res(ji,jj) - ( smv_i(ji,jj,jl) - zsal ) * rhoic * r1_rdtice 151 END DO ! ji 152 END DO ! jj 472 153 END DO !jl 473 154 ENDIF 474 475 ! -------------------476 at_i(:,:) = a_i(:,:,1)477 DO jl = 2, jpl478 at_i(:,:) = a_i(:,:,jl) + at_i(:,:)479 END DO480 155 481 156 !------------------------------------------------------------------------------ … … 486 161 DO jj = 2, jpjm1 487 162 DO ji = 2, jpim1 488 IF ( at_i(ji,jj) .EQ. 0.0) THEN ! what to do if there is no ice489 IF ( at_i(ji+1,jj) .EQ. 0.0 ) u_ice(ji,jj) = 0.0! right side490 IF ( at_i(ji-1,jj) .EQ. 0.0 ) u_ice(ji-1,jj) = 0.0! left side491 IF ( at_i(ji,jj+1) .EQ. 0.0 ) v_ice(ji,jj) = 0.0! upper side492 IF ( at_i(ji,jj-1) .EQ. 0.0 ) v_ice(ji,jj-1) = 0.0! bottom side163 IF ( at_i(ji,jj) == 0._wp ) THEN ! what to do if there is no ice 164 IF ( at_i(ji+1,jj) == 0._wp ) u_ice(ji,jj) = 0._wp ! right side 165 IF ( at_i(ji-1,jj) == 0._wp ) u_ice(ji-1,jj) = 0._wp ! left side 166 IF ( at_i(ji,jj+1) == 0._wp ) v_ice(ji,jj) = 0._wp ! upper side 167 IF ( at_i(ji,jj-1) == 0._wp ) v_ice(ji,jj-1) = 0._wp ! bottom side 493 168 ENDIF 494 169 END DO … … 501 176 v_ice(:,:) = v_ice(:,:) * tmv(:,:) 502 177 503 !-------------------------------- 504 ! Update mass/salt fluxes (clem) 505 !-------------------------------- 506 DO jl = 1, jpl 507 DO jj = 1, jpj 508 DO ji = 1, jpi 509 diag_res_pr(ji,jj) = diag_res_pr(ji,jj) + ( v_i(ji,jj,jl) - zviold(ji,jj,jl) ) / rdt_ice 510 rdm_ice(ji,jj) = rdm_ice(ji,jj) + ( v_i(ji,jj,jl) - zviold(ji,jj,jl) ) * rhoic 511 rdm_snw(ji,jj) = rdm_snw(ji,jj) + ( v_s(ji,jj,jl) - zvsold(ji,jj,jl) ) * rhosn 512 sfx_res(ji,jj) = sfx_res(ji,jj) - ( smv_i(ji,jj,jl) - zsmvold(ji,jj,jl) ) * rhoic / rdt_ice 513 END DO 514 END DO 515 END DO 516 517 ! ------------------------------- 518 !- check conservation (C Rousset) 519 IF (ln_limdiahsb) THEN 520 521 zchk_fs = glob_sum( ( sfx_bri(:,:) + sfx_thd(:,:) + sfx_res(:,:) + sfx_mec(:,:) ) * area(:,:) * tms(:,:) ) - zchk_fs_b 522 zchk_fw = glob_sum( rdm_ice(:,:) * area(:,:) * tms(:,:) ) - zchk_fw_b 523 524 zchk_v_i = ( glob_sum( SUM( v_i(:,:,:), dim=3 ) * area(:,:) * tms(:,:) ) - zchk_v_i_b - ( zchk_fw / rhoic ) ) * r1_rdtice 525 zchk_smv = ( glob_sum( SUM( smv_i(:,:,:), dim=3 ) * area(:,:) * tms(:,:) ) - zchk_smv_b ) * r1_rdtice + ( zchk_fs / rhoic ) 526 527 zchk_vmin = glob_min(v_i) 528 zchk_amax = glob_max(SUM(a_i,dim=3)) 529 zchk_amin = glob_min(a_i) 530 531 IF(lwp) THEN 532 IF ( ABS( zchk_v_i ) > 1.e-5 ) WRITE(numout,*) 'violation volume [m3/day] (limupdate2) = ',(zchk_v_i * rday) 533 IF ( ABS( zchk_smv ) > 1.e-4 ) WRITE(numout,*) 'violation saline [psu*m3/day] (limupdate2) = ',(zchk_smv * rday) 534 IF ( zchk_vmin < 0. ) WRITE(numout,*) 'violation v_i<0 [mm] (limupdate2) = ',(zchk_vmin * 1.e-3) 535 IF ( zchk_amax > amax+epsi10 ) WRITE(numout,*) 'violation a_i>amax (limupdate2) = ',zchk_amax 536 IF ( zchk_amin < 0. ) WRITE(numout,*) 'violation a_i<0 (limupdate2) = ',zchk_amin 537 ENDIF 538 ENDIF 539 !- check conservation (C Rousset) 540 ! ------------------------------- 178 ! ------------------------------------------------- 179 ! Diagnostics 180 ! ------------------------------------------------- 181 d_a_i_thd(:,:,:) = a_i(:,:,:) - a_i_b(:,:,:) 182 d_v_s_thd(:,:,:) = v_s(:,:,:) - v_s_b(:,:,:) 183 d_v_i_thd(:,:,:) = v_i(:,:,:) - v_i_b(:,:,:) 184 d_e_s_thd(:,:,:,:) = e_s(:,:,:,:) - e_s_b(:,:,:,:) 185 d_e_i_thd(:,:,1:nlay_i,:) = e_i(:,:,1:nlay_i,:) - e_i_b(:,:,1:nlay_i,:) 186 !?? d_oa_i_thd(:,:,:) = oa_i (:,:,:) - oa_i_b (:,:,:) 187 d_smv_i_thd(:,:,:) = 0._wp 188 IF( num_sal == 2 ) d_smv_i_thd(:,:,:) = smv_i(:,:,:) - smv_i_b(:,:,:) 189 ! diag only (clem) 190 dv_dt_thd(:,:,:) = d_v_i_thd(:,:,:) * r1_rdtice * rday 191 192 ! heat content variation (W.m-2) 193 DO jj = 1, jpj 194 DO ji = 1, jpi 195 diag_heat_dhc(ji,jj) = ( SUM( d_e_i_trp(ji,jj,1:nlay_i,:) + d_e_i_thd(ji,jj,1:nlay_i,:) ) + & 196 & SUM( d_e_s_trp(ji,jj,1:nlay_s,:) + d_e_s_thd(ji,jj,1:nlay_s,:) ) & 197 & ) * unit_fac * r1_rdtice / area(ji,jj) 198 END DO 199 END DO 200 201 ! conservation test 202 IF( ln_limdiahsb ) CALL lim_cons_hsm(0, 'limupdate2', zvi_b, zsmv_b, zei_b, zfw_b, zfs_b, zft_b) 541 203 542 204 IF(ln_ctl) THEN ! Control print … … 550 212 CALL prt_ctl(tab2d_1=strength , clinfo1=' lim_update2 : strength :') 551 213 CALL prt_ctl(tab2d_1=u_ice , clinfo1=' lim_update2 : u_ice :', tab2d_2=v_ice , clinfo2=' v_ice :') 552 CALL prt_ctl(tab2d_1= old_u_ice , clinfo1=' lim_update2 : old_u_ice :', tab2d_2=old_v_ice , clinfo2=' old_v_ice:')214 CALL prt_ctl(tab2d_1=u_ice_b , clinfo1=' lim_update2 : u_ice_b :', tab2d_2=v_ice_b , clinfo2=' v_ice_b :') 553 215 554 216 DO jl = 1, jpl … … 563 225 CALL prt_ctl(tab2d_1=o_i (:,:,jl) , clinfo1= ' lim_update2 : o_i : ') 564 226 CALL prt_ctl(tab2d_1=a_i (:,:,jl) , clinfo1= ' lim_update2 : a_i : ') 565 CALL prt_ctl(tab2d_1= old_a_i (:,:,jl) , clinfo1= ' lim_update2 : old_a_i: ')227 CALL prt_ctl(tab2d_1=a_i_b (:,:,jl) , clinfo1= ' lim_update2 : a_i_b : ') 566 228 CALL prt_ctl(tab2d_1=d_a_i_thd (:,:,jl) , clinfo1= ' lim_update2 : d_a_i_thd : ') 567 229 CALL prt_ctl(tab2d_1=v_i (:,:,jl) , clinfo1= ' lim_update2 : v_i : ') 568 CALL prt_ctl(tab2d_1= old_v_i (:,:,jl) , clinfo1= ' lim_update2 : old_v_i: ')230 CALL prt_ctl(tab2d_1=v_i_b (:,:,jl) , clinfo1= ' lim_update2 : v_i_b : ') 569 231 CALL prt_ctl(tab2d_1=d_v_i_thd (:,:,jl) , clinfo1= ' lim_update2 : d_v_i_thd : ') 570 232 CALL prt_ctl(tab2d_1=v_s (:,:,jl) , clinfo1= ' lim_update2 : v_s : ') 571 CALL prt_ctl(tab2d_1= old_v_s (:,:,jl) , clinfo1= ' lim_update2 : old_v_s: ')233 CALL prt_ctl(tab2d_1=v_s_b (:,:,jl) , clinfo1= ' lim_update2 : v_s_b : ') 572 234 CALL prt_ctl(tab2d_1=d_v_s_thd (:,:,jl) , clinfo1= ' lim_update2 : d_v_s_thd : ') 573 235 CALL prt_ctl(tab2d_1=e_i (:,:,1,jl)/1.0e9, clinfo1= ' lim_update2 : e_i1 : ') 574 CALL prt_ctl(tab2d_1= old_e_i (:,:,1,jl)/1.0e9, clinfo1= ' lim_update2 : old_e_i1: ')236 CALL prt_ctl(tab2d_1=e_i_b (:,:,1,jl)/1.0e9, clinfo1= ' lim_update2 : e_i1_b : ') 575 237 CALL prt_ctl(tab2d_1=d_e_i_thd (:,:,1,jl)/1.0e9, clinfo1= ' lim_update2 : de_i1_thd : ') 576 238 CALL prt_ctl(tab2d_1=e_i (:,:,2,jl)/1.0e9, clinfo1= ' lim_update2 : e_i2 : ') 577 CALL prt_ctl(tab2d_1= old_e_i (:,:,2,jl)/1.0e9, clinfo1= ' lim_update2 : old_e_i2: ')239 CALL prt_ctl(tab2d_1=e_i_b (:,:,2,jl)/1.0e9, clinfo1= ' lim_update2 : e_i2_b : ') 578 240 CALL prt_ctl(tab2d_1=d_e_i_thd (:,:,2,jl)/1.0e9, clinfo1= ' lim_update2 : de_i2_thd : ') 579 241 CALL prt_ctl(tab2d_1=e_s (:,:,1,jl) , clinfo1= ' lim_update2 : e_snow : ') 580 CALL prt_ctl(tab2d_1= old_e_s (:,:,1,jl) , clinfo1= ' lim_update2 : old_e_snow: ')242 CALL prt_ctl(tab2d_1=e_s_b (:,:,1,jl) , clinfo1= ' lim_update2 : e_snow_b : ') 581 243 CALL prt_ctl(tab2d_1=d_e_s_thd (:,:,1,jl)/1.0e9, clinfo1= ' lim_update2 : d_e_s_thd : ') 582 244 CALL prt_ctl(tab2d_1=smv_i (:,:,jl) , clinfo1= ' lim_update2 : smv_i : ') 583 CALL prt_ctl(tab2d_1= old_smv_i (:,:,jl) , clinfo1= ' lim_update2 : old_smv_i: ')245 CALL prt_ctl(tab2d_1=smv_i_b (:,:,jl) , clinfo1= ' lim_update2 : smv_i_b : ') 584 246 CALL prt_ctl(tab2d_1=d_smv_i_thd(:,:,jl) , clinfo1= ' lim_update2 : d_smv_i_thd : ') 585 247 CALL prt_ctl(tab2d_1=oa_i (:,:,jl) , clinfo1= ' lim_update2 : oa_i : ') 586 CALL prt_ctl(tab2d_1=o ld_oa_i (:,:,jl) , clinfo1= ' lim_update2 : old_oa_i: ')248 CALL prt_ctl(tab2d_1=oa_i_b (:,:,jl) , clinfo1= ' lim_update2 : oa_i_b : ') 587 249 CALL prt_ctl(tab2d_1=d_oa_i_thd (:,:,jl) , clinfo1= ' lim_update2 : d_oa_i_thd : ') 588 250 … … 596 258 CALL prt_ctl_info(' - Heat / FW fluxes : ') 597 259 CALL prt_ctl_info(' ~~~~~~~~~~~~~~~~~~ ') 598 CALL prt_ctl(tab2d_1=fmmec , clinfo1= ' lim_update2 : fmmec : ', tab2d_2=fhmec , clinfo2= ' fhmec : ')599 260 CALL prt_ctl(tab2d_1=sst_m , clinfo1= ' lim_update2 : sst : ', tab2d_2=sss_m , clinfo2= ' sss : ') 600 CALL prt_ctl(tab2d_1=fhbri , clinfo1= ' lim_update2 : fhbri : ', tab2d_2=fheat_mec , clinfo2= ' fheat_mec : ')601 261 602 262 CALL prt_ctl_info(' ') … … 608 268 ENDIF 609 269 610 CALL wrk_dealloc( jpi,jpj,jpl, internal_melt ) ! integer611 CALL wrk_dealloc( jkmax, zthick0, zqm0 )612 613 CALL wrk_dealloc( jpi,jpj,jpl,zviold, zvsold, zsmvold ) ! clem614 615 270 IF( nn_timing == 1 ) CALL timing_stop('limupdate2') 271 616 272 END SUBROUTINE lim_update2 617 273 #else -
branches/2014/dev_r4650_UKMO14.12_STAND_ALONE_OBSOPER/NEMOGCM/NEMO/LIM_SRC_3/limvar.F90
r4333 r5034 66 66 PUBLIC lim_var_salprof1d ! 67 67 68 REAL(wp) :: epsi10 = 1.e-10_wp ! - -69 REAL(wp) :: zzero = 0.e0 ! - -70 REAL(wp) :: zone = 1.e0 ! - -71 72 68 !!---------------------------------------------------------------------- 73 69 !! NEMO/LIM3 4.0 , UCL - NEMO Consortium (2011) … … 94 90 ! 95 91 INTEGER :: ji, jj, jk, jl ! dummy loop indices 96 REAL(wp) :: zinda, zindb97 92 !!------------------------------------------------------------------ 98 93 … … 113 108 at_i(ji,jj) = at_i(ji,jj) + a_i(ji,jj,jl) ! ice concentration 114 109 ! 115 zinda = MAX( zzero , SIGN( zone, at_i(ji,jj) - epsi10 ) )116 icethi(ji,jj) = vt_i(ji,jj) / MAX( at_i(ji,jj) , epsi10 ) * zinda! ice thickness110 rswitch = MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) - epsi10 ) ) 111 icethi(ji,jj) = vt_i(ji,jj) / MAX( at_i(ji,jj) , epsi10 ) * rswitch ! ice thickness 117 112 END DO 118 113 END DO … … 134 129 DO jj = 1, jpj 135 130 DO ji = 1, jpi 136 zinda = MAX( zzero , SIGN( zone , vt_i(ji,jj) - epsi10 ) )137 zindb = MAX( zzero , SIGN( zone , at_i(ji,jj) - epsi10 ) )138 131 et_s(ji,jj) = et_s(ji,jj) + e_s(ji,jj,1,jl) ! snow heat content 139 smt_i(ji,jj) = smt_i(ji,jj) + smv_i(ji,jj,jl) / MAX( vt_i(ji,jj) , epsi10 ) * zinda ! ice salinity 140 ot_i(ji,jj) = ot_i(ji,jj) + oa_i(ji,jj,jl) / MAX( at_i(ji,jj) , epsi10 ) * zindb ! ice age 132 rswitch = MAX( 0._wp , SIGN( 1._wp , vt_i(ji,jj) - epsi10 ) ) 133 smt_i(ji,jj) = smt_i(ji,jj) + smv_i(ji,jj,jl) / MAX( vt_i(ji,jj) , epsi10 ) * rswitch ! ice salinity 134 rswitch = MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) - epsi10 ) ) 135 ot_i(ji,jj) = ot_i(ji,jj) + oa_i(ji,jj,jl) / MAX( at_i(ji,jj) , epsi10 ) * rswitch ! ice age 141 136 END DO 142 137 END DO … … 163 158 INTEGER :: ji, jj, jk, jl ! dummy loop indices 164 159 REAL(wp) :: zq_i, zaaa, zbbb, zccc, zdiscrim ! local scalars 165 REAL(wp) :: ztmelts, z indb, zq_s, zfac1, zfac2 ! - -160 REAL(wp) :: ztmelts, zq_s, zfac1, zfac2 ! - - 166 161 !!------------------------------------------------------------------ 167 162 … … 172 167 DO jj = 1, jpj 173 168 DO ji = 1, jpi 174 zindb= 1._wp - MAX( 0._wp , SIGN( 1._wp,- a_i(ji,jj,jl) + epsi10 ) ) !0 if no ice and 1 if yes175 ht_i(ji,jj,jl) = v_i (ji,jj,jl) / MAX( a_i(ji,jj,jl) , epsi10 ) * zindb176 ht_s(ji,jj,jl) = v_s (ji,jj,jl) / MAX( a_i(ji,jj,jl) , epsi10 ) * zindb177 o_i(ji,jj,jl) = oa_i(ji,jj,jl) / MAX( a_i(ji,jj,jl) , epsi10 ) * zindb169 rswitch = 1._wp - MAX( 0._wp , SIGN( 1._wp,- a_i(ji,jj,jl) + epsi10 ) ) !0 if no ice and 1 if yes 170 ht_i(ji,jj,jl) = v_i (ji,jj,jl) / MAX( a_i(ji,jj,jl) , epsi10 ) * rswitch 171 ht_s(ji,jj,jl) = v_s (ji,jj,jl) / MAX( a_i(ji,jj,jl) , epsi10 ) * rswitch 172 o_i(ji,jj,jl) = oa_i(ji,jj,jl) / MAX( a_i(ji,jj,jl) , epsi10 ) * rswitch 178 173 END DO 179 174 END DO … … 184 179 DO jj = 1, jpj 185 180 DO ji = 1, jpi 186 zindb= 1._wp - MAX( 0._wp , SIGN( 1._wp,- a_i(ji,jj,jl) + epsi10 ) ) !0 if no ice and 1 if yes187 sm_i(ji,jj,jl) = smv_i(ji,jj,jl) / MAX( v_i(ji,jj,jl) , epsi10 ) * zindb181 rswitch = 1._wp - MAX( 0._wp , SIGN( 1._wp,- a_i(ji,jj,jl) + epsi10 ) ) !0 if no ice and 1 if yes 182 sm_i(ji,jj,jl) = smv_i(ji,jj,jl) / MAX( v_i(ji,jj,jl) , epsi10 ) * rswitch 188 183 END DO 189 184 END DO … … 205 200 DO ji = 1, jpi 206 201 ! ! Energy of melting q(S,T) [J.m-3] 207 zq_i = e_i(ji,jj,jk,jl) / area(ji,jj) / MAX( v_i(ji,jj,jl) , epsi10 ) * REAL(nlay_i,wp)208 z indb = 1.0 - MAX( 0.0 , SIGN( 1.0 , - v_i(ji,jj,jl) + epsi10 ) ) ! zindb = 0 if no ice and 1 if yes209 zq_i = zq_i * unit_fac * zindb!convert units202 rswitch = 1.0 - MAX( 0.0 , SIGN( 1.0 , - v_i(ji,jj,jl) + epsi10 ) ) ! rswitch = 0 if no ice and 1 if yes 203 zq_i = rswitch * e_i(ji,jj,jk,jl) / area(ji,jj) / MAX( v_i(ji,jj,jl) , epsi10 ) * REAL(nlay_i,wp) 204 zq_i = zq_i * unit_fac !convert units 210 205 ztmelts = -tmut * s_i(ji,jj,jk,jl) + rtt ! Ice layer melt temperature 211 206 ! … … 214 209 zccc = lfus * (ztmelts-rtt) 215 210 zdiscrim = SQRT( MAX(zbbb*zbbb - 4._wp*zaaa*zccc , 0._wp) ) 216 t_i(ji,jj,jk,jl) = rtt + zindb*( - zbbb - zdiscrim ) / ( 2.0 *zaaa )211 t_i(ji,jj,jk,jl) = rtt + rswitch *( - zbbb - zdiscrim ) / ( 2.0 *zaaa ) 217 212 t_i(ji,jj,jk,jl) = MIN( rtt, MAX( 173.15_wp, t_i(ji,jj,jk,jl) ) ) ! 100-rtt < t_i < rtt 218 213 END DO … … 231 226 DO ji = 1, jpi 232 227 !Energy of melting q(S,T) [J.m-3] 233 zq_s = e_s(ji,jj,jk,jl) / ( area(ji,jj) * MAX( v_s(ji,jj,jl) , epsi10 ) ) * REAL(nlay_s,wp)234 z indb = 1._wp - MAX( 0._wp , SIGN( 1._wp , - v_s(ji,jj,jl) + epsi10 ) ) ! zindb = 0 if no ice and 1 if yes235 zq_s = zq_s * unit_fac * zindb! convert units228 rswitch = 1._wp - MAX( 0._wp , SIGN( 1._wp , - v_s(ji,jj,jl) + epsi10 ) ) ! rswitch = 0 if no ice and 1 if yes 229 zq_s = rswitch * e_s(ji,jj,jk,jl) / ( area(ji,jj) * MAX( v_s(ji,jj,jl) , epsi10 ) ) * REAL(nlay_s,wp) 230 zq_s = zq_s * unit_fac ! convert units 236 231 ! 237 t_s(ji,jj,jk,jl) = rtt + zindb* ( - zfac1 * zq_s + zfac2 )232 t_s(ji,jj,jk,jl) = rtt + rswitch * ( - zfac1 * zq_s + zfac2 ) 238 233 t_s(ji,jj,jk,jl) = MIN( rtt, MAX( 173.15, t_s(ji,jj,jk,jl) ) ) ! 100-rtt < t_i < rtt 239 234 END DO … … 250 245 DO jj = 1, jpj 251 246 DO ji = 1, jpi 252 zindb= ( 1._wp - MAX( 0._wp , SIGN( 1._wp , - vt_i(ji,jj) + epsi10 ) ) )253 tm_i(ji,jj) = tm_i(ji,jj) + zindb* t_i(ji,jj,jk,jl) * v_i(ji,jj,jl) &247 rswitch = ( 1._wp - MAX( 0._wp , SIGN( 1._wp , - vt_i(ji,jj) + epsi10 ) ) ) 248 tm_i(ji,jj) = tm_i(ji,jj) + rswitch * t_i(ji,jj,jk,jl) * v_i(ji,jj,jl) & 254 249 & / ( REAL(nlay_i,wp) * MAX( vt_i(ji,jj) , epsi10 ) ) 255 250 END DO … … 297 292 INTEGER :: ji, jj, jk, jl ! dummy loop index 298 293 REAL(wp) :: dummy_fac0, dummy_fac1, dummy_fac, zsal ! local scalar 299 REAL(wp) :: z ind0, zind01, zindbal, zargtemp , zs_zero ! - -294 REAL(wp) :: zswi0, zswi01, zswibal, zargtemp , zs_zero ! - - 300 295 REAL(wp), POINTER, DIMENSION(:,:,:) :: z_slope_s, zalpha ! 3D pointer 301 296 !!------------------------------------------------------------------ … … 320 315 DO jj = 1, jpj 321 316 DO ji = 1, jpi 322 z_slope_s(ji,jj,jl) = 2._wp * sm_i(ji,jj,jl) / MAX( 0.01, ht_i(ji,jj,jl) )317 z_slope_s(ji,jj,jl) = 2._wp * sm_i(ji,jj,jl) / MAX( epsi10 , ht_i(ji,jj,jl) ) 323 318 END DO 324 319 END DO … … 332 327 DO jj = 1, jpj 333 328 DO ji = 1, jpi 334 ! z ind0 = 1 if sm_i le s_i_0 and 0 otherwise335 z ind0 = MAX( 0._wp , SIGN( 1._wp , s_i_0 - sm_i(ji,jj,jl) ) )336 ! z ind01 = 1 if sm_i is between s_i_0 and s_i_1 and 0 othws337 z ind01 = ( 1._wp - zind0 ) * MAX( 0._wp , SIGN( 1._wp , s_i_1 - sm_i(ji,jj,jl) ) )338 ! If 2.sm_i GE sss_m then z indbal = 1329 ! zswi0 = 1 if sm_i le s_i_0 and 0 otherwise 330 zswi0 = MAX( 0._wp , SIGN( 1._wp , s_i_0 - sm_i(ji,jj,jl) ) ) 331 ! zswi01 = 1 if sm_i is between s_i_0 and s_i_1 and 0 othws 332 zswi01 = ( 1._wp - zswi0 ) * MAX( 0._wp , SIGN( 1._wp , s_i_1 - sm_i(ji,jj,jl) ) ) 333 ! If 2.sm_i GE sss_m then zswibal = 1 339 334 ! this is to force a constant salinity profile in the Baltic Sea 340 z indbal = MAX( 0._wp , SIGN( 1._wp , 2._wp * sm_i(ji,jj,jl) - sss_m(ji,jj) ) )341 zalpha(ji,jj,jl) = z ind0 + zind01 * ( sm_i(ji,jj,jl) * dummy_fac0 + dummy_fac1 )342 zalpha(ji,jj,jl) = zalpha(ji,jj,jl) * ( 1._wp - z indbal )335 zswibal = MAX( 0._wp , SIGN( 1._wp , 2._wp * sm_i(ji,jj,jl) - sss_m(ji,jj) ) ) 336 zalpha(ji,jj,jl) = zswi0 + zswi01 * ( sm_i(ji,jj,jl) * dummy_fac0 + dummy_fac1 ) 337 zalpha(ji,jj,jl) = zalpha(ji,jj,jl) * ( 1._wp - zswibal ) 343 338 END DO 344 339 END DO … … 392 387 !!------------------------------------------------------------------ 393 388 INTEGER :: ji, jj, jk, jl ! dummy loop indices 394 REAL(wp) :: zindb ! - -395 389 !!------------------------------------------------------------------ 396 390 … … 401 395 DO jj = 1, jpj 402 396 DO ji = 1, jpi 403 zindb= ( 1._wp - MAX( 0._wp , SIGN( 1._wp , - vt_i(ji,jj) + epsi10 ) ) )404 tm_i(ji,jj) = tm_i(ji,jj) + zindb* t_i(ji,jj,jk,jl) * v_i(ji,jj,jl) &397 rswitch = ( 1._wp - MAX( 0._wp , SIGN( 1._wp , - vt_i(ji,jj) + epsi10 ) ) ) 398 tm_i(ji,jj) = tm_i(ji,jj) + rswitch * t_i(ji,jj,jk,jl) * v_i(ji,jj,jl) & 405 399 & / ( REAL(nlay_i,wp) * MAX( vt_i(ji,jj) , epsi10 ) ) 406 400 END DO … … 423 417 !!------------------------------------------------------------------ 424 418 INTEGER :: ji, jj, jk, jl ! dummy loop indices 425 REAL(wp) :: zbvi , zinda, zindb! local scalars419 REAL(wp) :: zbvi ! local scalars 426 420 !!------------------------------------------------------------------ 427 421 ! … … 431 425 DO jj = 1, jpj 432 426 DO ji = 1, jpi 433 zinda = ( 1._wp - MAX( 0._wp , SIGN( 1._wp , (t_i(ji,jj,jk,jl) - rtt) + epsi10 ) ) ) 434 zindb = ( 1._wp - MAX( 0._wp , SIGN( 1._wp , - vt_i(ji,jj) + epsi10 ) ) ) 435 zbvi = - zinda * tmut * s_i(ji,jj,jk,jl) / MIN( t_i(ji,jj,jk,jl) - rtt, - epsi10 ) & 427 rswitch = ( 1._wp - MAX( 0._wp , SIGN( 1._wp , (t_i(ji,jj,jk,jl) - rtt) + epsi10 ) ) ) 428 zbvi = - rswitch * tmut * s_i(ji,jj,jk,jl) / MIN( t_i(ji,jj,jk,jl) - rtt, - epsi10 ) & 436 429 & * v_i(ji,jj,jl) / REAL(nlay_i,wp) 437 bv_i(ji,jj) = bv_i(ji,jj) + zindb * zbvi / MAX( vt_i(ji,jj) , epsi10 ) 430 rswitch = ( 1._wp - MAX( 0._wp , SIGN( 1._wp , - vt_i(ji,jj) + epsi10 ) ) ) 431 bv_i(ji,jj) = bv_i(ji,jj) + rswitch * zbvi / MAX( vt_i(ji,jj) , epsi10 ) 438 432 END DO 439 433 END DO … … 456 450 INTEGER :: ii, ij ! local integers 457 451 REAL(wp) :: dummy_fac0, dummy_fac1, dummy_fac2, zargtemp, zsal ! local scalars 458 REAL(wp) :: zalpha, z ind0, zind01, zindbal, zs_zero ! - -452 REAL(wp) :: zalpha, zswi0, zswi01, zswibal, zs_zero ! - - 459 453 ! 460 454 REAL(wp), POINTER, DIMENSION(:) :: z_slope_s … … 466 460 ! Vertically constant, constant in time 467 461 !--------------------------------------- 468 IF( num_sal == 1 ) s_i_ b(:,:) = bulk_sal462 IF( num_sal == 1 ) s_i_1d(:,:) = bulk_sal 469 463 470 464 !------------------------------------------------------ … … 475 469 ! 476 470 DO ji = kideb, kiut ! Slope of the linear profile zs_zero 477 z_slope_s(ji) = 2._wp * sm_i_ b(ji) / MAX( 0.01 , ht_i_b(ji) )471 z_slope_s(ji) = 2._wp * sm_i_1d(ji) / MAX( epsi10 , ht_i_1d(ji) ) 478 472 END DO 479 473 … … 490 484 ii = MOD( npb(ji) - 1 , jpi ) + 1 491 485 ij = ( npb(ji) - 1 ) / jpi + 1 492 ! z ind0 = 1 if sm_i le s_i_0 and 0 otherwise493 z ind0 = MAX( 0._wp , SIGN( 1._wp , s_i_0 - sm_i_b(ji) ) )494 ! z ind01 = 1 if sm_i is between s_i_0 and s_i_1 and 0 othws495 z ind01 = ( 1._wp - zind0 ) * MAX( 0._wp , SIGN( 1._wp , s_i_1 - sm_i_b(ji) ) )496 ! if 2.sm_i GE sss_m then z indbal = 1486 ! zswi0 = 1 if sm_i le s_i_0 and 0 otherwise 487 zswi0 = MAX( 0._wp , SIGN( 1._wp , s_i_0 - sm_i_1d(ji) ) ) 488 ! zswi01 = 1 if sm_i is between s_i_0 and s_i_1 and 0 othws 489 zswi01 = ( 1._wp - zswi0 ) * MAX( 0._wp , SIGN( 1._wp , s_i_1 - sm_i_1d(ji) ) ) 490 ! if 2.sm_i GE sss_m then zswibal = 1 497 491 ! this is to force a constant salinity profile in the Baltic Sea 498 z indbal = MAX( 0._wp , SIGN( 1._wp , 2._wp * sm_i_b(ji) - sss_m(ii,ij) ) )492 zswibal = MAX( 0._wp , SIGN( 1._wp , 2._wp * sm_i_1d(ji) - sss_m(ii,ij) ) ) 499 493 ! 500 zalpha = ( z ind0 + zind01 * ( sm_i_b(ji) * dummy_fac0 + dummy_fac1 ) ) * ( 1.0 - zindbal )494 zalpha = ( zswi0 + zswi01 * ( sm_i_1d(ji) * dummy_fac0 + dummy_fac1 ) ) * ( 1.0 - zswibal ) 501 495 ! 502 zs_zero = z_slope_s(ji) * ( REAL(jk,wp) - 0.5_wp ) * ht_i_ b(ji) * dummy_fac2496 zs_zero = z_slope_s(ji) * ( REAL(jk,wp) - 0.5_wp ) * ht_i_1d(ji) * dummy_fac2 503 497 ! weighting the profile 504 s_i_ b(ji,jk) = zalpha * zs_zero + ( 1._wp - zalpha ) * sm_i_b(ji)498 s_i_1d(ji,jk) = zalpha * zs_zero + ( 1._wp - zalpha ) * sm_i_1d(ji) 505 499 END DO ! ji 506 500 END DO ! jk … … 514 508 IF( num_sal == 3 ) THEN ! Schwarzacher (1959) multiyear salinity profile (mean = 2.30) 515 509 ! 516 sm_i_ b(:) = 2.30_wp510 sm_i_1d(:) = 2.30_wp 517 511 ! 518 512 !CDIR NOVERRCHK … … 521 515 zsal = 1.6_wp * ( 1._wp - COS( rpi * zargtemp**(0.407_wp/(0.573_wp+zargtemp)) ) ) 522 516 DO ji = kideb, kiut 523 s_i_ b(ji,jk) = zsal517 s_i_1d(ji,jk) = zsal 524 518 END DO 525 519 END DO -
branches/2014/dev_r4650_UKMO14.12_STAND_ALONE_OBSOPER/NEMOGCM/NEMO/LIM_SRC_3/limwri.F90
r4624 r5034 9 9 !!---------------------------------------------------------------------- 10 10 !! lim_wri : write of the diagnostics variables in ouput file 11 !! lim_wri_init : initialization and namelist read12 11 !! lim_wri_state : write for initial state or/and abandon 13 12 !!---------------------------------------------------------------------- … … 36 35 PUBLIC lim_wri_state ! called by dia_wri_state 37 36 38 INTEGER, PARAMETER :: jpnoumax = 43 !: maximum number of variable for ice output39 40 INTEGER :: noumef ! number of fields41 INTEGER :: noumefa ! number of additional fields42 INTEGER :: add_diag_swi ! additional diagnostics43 INTEGER :: nz ! dimension for the itd field44 45 REAL(wp) , DIMENSION(jpnoumax) :: cmulti ! multiplicative constant46 REAL(wp) , DIMENSION(jpnoumax) :: cadd ! additive constant47 REAL(wp) , DIMENSION(jpnoumax) :: cmultia ! multiplicative constant48 REAL(wp) , DIMENSION(jpnoumax) :: cadda ! additive constant49 CHARACTER(len = 35), DIMENSION(jpnoumax) :: titn, titna ! title of the field50 CHARACTER(len = 8 ), DIMENSION(jpnoumax) :: nam , nama ! name of the field51 CHARACTER(len = 8 ), DIMENSION(jpnoumax) :: uni , unia ! unit of the field52 INTEGER , DIMENSION(jpnoumax) :: nc , nca ! switch for saving field ( = 1 ) or not ( = 0 )53 54 REAL(wp) :: epsi06 = 1.e-6_wp55 REAL(wp) :: zzero = 0._wp56 REAL(wp) :: zone = 1._wp57 37 !!---------------------------------------------------------------------- 58 38 !! NEMO/LIM3 4.0 , UCL - NEMO Consortium (2011) … … 78 58 INTEGER, INTENT(in) :: kindic ! if kindic < 0 there has been an error somewhere 79 59 ! 80 INTEGER :: ji, jj, jk, jl, jf, ipl ! dummy loop indices 81 INTEGER :: ierr 82 REAL(wp),DIMENSION(1) :: zdept 83 REAL(wp) :: zsto, zjulian, zout, zindh, zinda, zindb, zindc 84 REAL(wp), POINTER, DIMENSION(:,:,:) :: zcmo, zcmoa 85 REAL(wp), POINTER, DIMENSION(:,: ) :: zfield 86 REAL(wp), POINTER, DIMENSION(:,:,:) :: zmaskitd, zoi, zei 87 88 CHARACTER(len = 60) :: clhstnam, clop, clhstnama 89 90 INTEGER , SAVE :: nice, nhorid, ndim, niter, ndepid 91 INTEGER , SAVE :: nicea, nhorida, ndimitd 92 INTEGER , ALLOCATABLE, DIMENSION(:), SAVE :: ndex51 93 INTEGER , ALLOCATABLE, DIMENSION(:), SAVE :: ndexitd 60 INTEGER :: ji, jj, jk, jl ! dummy loop indices 61 REAL(wp) :: z1_365 62 REAL(wp) :: ztmp 63 REAL(wp), POINTER, DIMENSION(:,:,:) :: zoi, zei 64 REAL(wp), POINTER, DIMENSION(:,:) :: z2d, z2da, z2db, zswi ! 2D workspace 94 65 !!------------------------------------------------------------------- 95 66 96 67 IF( nn_timing == 1 ) CALL timing_start('limwri') 97 68 98 CALL wrk_alloc( jpi, jpj, zfield ) 99 CALL wrk_alloc( jpi, jpj, jpnoumax, zcmo, zcmoa ) 100 CALL wrk_alloc( jpi, jpj, jpl, zmaskitd, zoi, zei ) 101 102 ipl = jpl 103 104 IF( numit == nstart ) THEN 105 106 ALLOCATE( ndex51(jpij), ndexitd(jpij*jpl), STAT=ierr ) 107 IF( lk_mpp ) CALL mpp_sum ( ierr ) 108 IF( ierr /= 0 ) THEN 109 CALL ctl_stop( 'lim_wri : unable to allocate standard arrays' ) ; RETURN 110 ENDIF 111 112 CALL lim_wri_init 113 114 IF(lwp) WRITE(numout,*) ' lim_wri, first time step ' 115 IF(lwp) WRITE(numout,*) ' add_diag_swi ', add_diag_swi 116 117 !-------------------- 118 ! 1) Initialization 119 !-------------------- 120 121 !------------- 122 ! Normal file 123 !------------- 124 niter = ( nit000 - 1 ) / nn_fsbc 125 CALL ymds2ju ( nyear, nmonth, nday, rdt, zjulian ) 126 zjulian = zjulian - adatrj ! set calendar origin to the beginning of the experiment 127 !clem 128 ! zsto = rdt_ice 129 ! IF( ln_mskland ) THEN ; clop = "ave(only(x))" ! put 1.e+20 on land (very expensive!!) 130 ! ELSE ; clop = "ave(x)" ! no use of the mask value (require less cpu time) 131 ! ENDIF 132 ! zout = nwrite * rdt_ice / nn_fsbc 133 ! zdept(1) = 0. 134 ! 135 ! CALL dia_nam ( clhstnam, nwrite, 'icemod_old' ) 136 ! CALL histbeg ( clhstnam, jpi, glamt, jpj, gphit, 1, jpi, 1, jpj, niter, zjulian, rdt_ice, & 137 ! & nhorid, nice, domain_id=nidom, snc4chunks=snc4set ) 138 ! CALL histvert( nice, "deptht", "Vertical T levels", "m", 1, zdept, ndepid, "down") 139 ! CALL wheneq ( jpij , tmask(:,:,1), 1, 1., ndex51, ndim) 140 ! 141 ! DO jf = 1 , noumef 142 ! IF(lwp) WRITE(numout,*) 'jf', jf 143 ! IF ( nc(jf) == 1 ) THEN 144 ! CALL histdef( nice, nam(jf), titn(jf), uni(jf), jpi, jpj & 145 ! , nhorid, 1, 1, 1, -99, 32, clop, zsto, zout ) 146 ! IF(lwp) WRITE(numout,*) 'nice, nam(jf), titn(jf), uni(jf), nhorid, clop, zsto, zout' 147 ! IF(lwp) WRITE(numout,*) nice, nam(jf), titn(jf), uni(jf), nhorid, clop, zsto, zout 148 ! ENDIF 149 ! END DO 150 ! 151 ! CALL histend(nice, snc4set) 152 !clem 153 ! 154 !----------------- 155 ! ITD file output 156 !----------------- 157 zsto = rdt_ice 158 clop = "ave(x)" 159 zout = nwrite * rdt_ice / nn_fsbc 160 zdept(1) = 0. 161 162 CALL dia_nam ( clhstnama, nwrite, 'icemoa' ) 163 CALL histbeg ( clhstnama, jpi, glamt, jpj, gphit, & 164 1, jpi, 1, jpj, & ! zoom 165 niter, zjulian, rdt_ice, & ! time 166 nhorida, & ! ? linked with horizontal ... 167 nicea , domain_id=nidom, snc4chunks=snc4set) ! file 168 CALL histvert( nicea, "icethi", "L levels","m", ipl , hi_mean , nz ) 69 CALL wrk_alloc( jpi, jpj, jpl, zoi, zei ) 70 CALL wrk_alloc( jpi, jpj , z2d, z2da, z2db, zswi ) 71 72 !----------------------------- 73 ! Mean category values 74 !----------------------------- 75 76 CALL lim_var_icetm ! mean sea ice temperature 77 78 CALL lim_var_bv ! brine volume 79 80 DO jj = 1, jpj ! presence indicator of ice 81 DO ji = 1, jpi 82 zswi(ji,jj) = MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) - epsi06 ) ) 83 END DO 84 END DO 85 ! 86 ! 87 ! 88 IF ( iom_use( "icethic_cea" ) ) THEN ! mean ice thickness 89 DO jj = 1, jpj 90 DO ji = 1, jpi 91 z2d(ji,jj) = vt_i(ji,jj) / MAX( at_i(ji,jj), epsi06 ) * zswi(ji,jj) 92 END DO 93 END DO 94 CALL iom_put( "icethic_cea" , z2d ) 95 ENDIF 96 97 IF ( iom_use( "snowthic_cea" ) ) THEN ! snow thickness = mean snow thickness over the cell 98 DO jj = 1, jpj 99 DO ji = 1, jpi 100 z2d(ji,jj) = vt_s(ji,jj) / MAX( at_i(ji,jj), epsi06 ) * zswi(ji,jj) 101 END DO 102 END DO 103 CALL iom_put( "snowthic_cea" , z2d ) 104 ENDIF 105 ! 106 IF ( iom_use( "uice_ipa" ) .OR. iom_use( "vice_ipa" ) .OR. iom_use( "icevel" ) ) THEN 107 DO jj = 2 , jpjm1 108 DO ji = 2 , jpim1 109 z2da(ji,jj) = ( u_ice(ji,jj) * tmu(ji,jj) + u_ice(ji-1,jj) * tmu(ji-1,jj) ) * 0.5_wp 110 z2db(ji,jj) = ( v_ice(ji,jj) * tmv(ji,jj) + v_ice(ji,jj-1) * tmv(ji,jj-1) ) * 0.5_wp 111 END DO 112 END DO 113 CALL lbc_lnk( z2da, 'T', -1. ) 114 CALL lbc_lnk( z2db, 'T', -1. ) 115 CALL iom_put( "uice_ipa" , z2da ) ! ice velocity u component 116 CALL iom_put( "vice_ipa" , z2db ) ! ice velocity v component 117 DO jj = 1, jpj 118 DO ji = 1, jpi 119 z2d(ji,jj) = SQRT( z2da(ji,jj) * z2da(ji,jj) + z2db(ji,jj) * z2db(ji,jj) ) 120 END DO 121 END DO 122 CALL iom_put( "icevel" , z2d ) ! ice velocity module 123 ENDIF 124 ! 125 IF ( iom_use( "miceage" ) ) THEN 126 z2d(:,:) = 0.e0 169 127 DO jl = 1, jpl 170 zmaskitd(:,:,jl) = tmask(:,:,1) 171 END DO 172 CALL wheneq ( jpij , tmask(:,:,1), 1, 1., ndex51, ndim) 173 CALL wheneq( jpi*jpj*jpl, zmaskitd, 1, 1., ndexitd, ndimitd ) 174 CALL histdef( nicea, "iice_itd", "Ice area in categories" , "-" , & 175 jpi, jpj, nhorida, jpl, 1, jpl, nz, 15, clop, zsto, zout ) 176 CALL histdef( nicea, "iice_hid", "Ice thickness in categories" , "m" , & 177 jpi, jpj, nhorida, jpl, 1, jpl, nz, 15, clop, zsto, zout ) 178 CALL histdef( nicea, "iice_hsd", "Snow depth in in categories" , "m" , & 179 jpi, jpj, nhorida, jpl, 1, jpl, nz, 15, clop, zsto, zout ) 180 CALL histdef( nicea, "iice_std", "Ice salinity distribution" , "ppt" , & 181 jpi, jpj, nhorida, jpl, 1, jpl, nz, 15, clop, zsto, zout ) 182 CALL histdef( nicea, "iice_otd", "Ice age distribution" , "days", & 183 jpi, jpj, nhorida, jpl, 1, jpl, nz, 15, clop, zsto, zout ) 184 CALL histdef( nicea, "iice_etd", "Brine volume distr. " , "%" , & 185 jpi, jpj, nhorida, jpl, 1, jpl, nz, 15, clop, zsto, zout ) 186 CALL histend(nicea, snc4set) 187 ENDIF 188 189 ! !-----------------------------------------------------------------------! 190 ! !--2. Computation of instantaneous values ! 191 ! !-----------------------------------------------------------------------! 192 193 !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 194 !IF( ln_nicep ) THEN 195 ! WRITE(numout,*) 196 ! WRITE(numout,*) 'lim_wri : write ice outputs in NetCDF files at time : ', nyear, nmonth, nday, numit 197 ! WRITE(numout,*) '~~~~~~~ ' 198 ! WRITE(numout,*) ' kindic = ', kindic 199 !ENDIF 200 !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 201 202 !-- calculs des valeurs instantanees 203 zcmo ( 1:jpi, 1:jpj, 1:jpnoumax ) = 0._wp 204 zcmoa( 1:jpi, 1:jpj, 1:jpnoumax ) = 0._wp 205 206 ! Ice surface temperature and some fluxes 207 DO jl = 1, jpl 128 DO jj = 1, jpj 129 DO ji = 1, jpi 130 z2d(ji,jj) = z2d(ji,jj) + zswi(ji,jj) * oa_i(ji,jj,jl) 131 END DO 132 END DO 133 END DO 134 z1_365 = 1._wp / 365._wp 135 CALL iom_put( "miceage" , z2d * z1_365 ) ! mean ice age 136 ENDIF 137 138 IF ( iom_use( "micet" ) ) THEN 208 139 DO jj = 1, jpj 209 140 DO ji = 1, jpi 210 zinda = MAX( zzero , SIGN( zone , at_i(ji,jj) - epsi06 ) ) 211 zcmo(ji,jj,17) = zcmo(ji,jj,17) + a_i(ji,jj,jl)*qsr_ice (ji,jj,jl) 212 zcmo(ji,jj,18) = zcmo(ji,jj,18) + a_i(ji,jj,jl)*qns_ice(ji,jj,jl) 213 zcmo(ji,jj,27) = zcmo(ji,jj,27) + zinda*(t_su(ji,jj,jl)-rtt)*a_i(ji,jj,jl)/MAX(at_i(ji,jj),epsi06) 214 zcmo(ji,jj,21) = zcmo(ji,jj,21) + zinda*oa_i(ji,jj,jl)/MAX(at_i(ji,jj),epsi06) 215 END DO 216 END DO 217 END DO 218 219 ! Mean sea ice temperature 220 CALL lim_var_icetm 221 222 ! Brine volume 223 CALL lim_var_bv 224 225 DO jj = 2 , jpjm1 226 DO ji = 2 , jpim1 227 zinda = MAX( zzero , SIGN( zone , at_i(ji,jj) - epsi06 ) ) 228 zindb = MAX( zzero , SIGN( zone , at_i(ji,jj) ) ) 229 230 zcmo(ji,jj,1) = at_i(ji,jj) 231 zcmo(ji,jj,2) = vt_i(ji,jj) / MAX( at_i(ji,jj), epsi06 ) * zinda 232 zcmo(ji,jj,3) = vt_s(ji,jj) / MAX( at_i(ji,jj), epsi06 ) * zinda 233 zcmo(ji,jj,4) = diag_bot_gr(ji,jj) * rday ! Bottom thermodynamic ice production 234 zcmo(ji,jj,5) = diag_dyn_gr(ji,jj) * rday ! Dynamic ice production (rid/raft) 235 zcmo(ji,jj,22) = diag_lat_gr(ji,jj) * rday ! Lateral thermodynamic ice production 236 zcmo(ji,jj,23) = diag_sni_gr(ji,jj) * rday ! Snow ice production ice production 237 zcmo(ji,jj,24) = (tm_i(ji,jj) - rtt) * zinda 238 239 zcmo(ji,jj,6) = fbif(ji,jj)*at_i(ji,jj) 240 zcmo(ji,jj,7) = ( u_ice(ji,jj) * tmu(ji,jj) + u_ice(ji-1,jj) * tmu(ji-1,jj) ) * 0.5_wp 241 zcmo(ji,jj,8) = ( v_ice(ji,jj) * tmv(ji,jj) + v_ice(ji,jj-1) * tmv(ji,jj-1) ) * 0.5_wp 242 zcmo(ji,jj,9) = sst_m(ji,jj) 243 zcmo(ji,jj,10) = sss_m(ji,jj) 244 245 zcmo(ji,jj,11) = qns(ji,jj) + qsr(ji,jj) 246 zcmo(ji,jj,12) = qsr(ji,jj) 247 zcmo(ji,jj,13) = qns(ji,jj) 248 zcmo(ji,jj,14) = fhbri(ji,jj) 249 zcmo(ji,jj,15) = utau_ice(ji,jj) 250 zcmo(ji,jj,16) = vtau_ice(ji,jj) 251 zcmo(ji,jj,17) = zcmo(ji,jj,17) + ( 1._wp - at_i(ji,jj) ) * qsr(ji,jj) 252 zcmo(ji,jj,18) = zcmo(ji,jj,18) + ( 1._wp - at_i(ji,jj) ) * qns(ji,jj) 253 zcmo(ji,jj,19) = sprecip(ji,jj) 254 zcmo(ji,jj,20) = smt_i(ji,jj) 255 zcmo(ji,jj,25) = et_i(ji,jj) 256 zcmo(ji,jj,26) = et_s(ji,jj) 257 zcmo(ji,jj,28) = sfx_bri(ji,jj) 258 zcmo(ji,jj,29) = sfx_thd(ji,jj) 259 260 zcmo(ji,jj,30) = bv_i(ji,jj) 261 zcmo(ji,jj,31) = hicol(ji,jj) * zindb 262 zcmo(ji,jj,32) = strength(ji,jj) 263 zcmo(ji,jj,33) = SQRT( zcmo(ji,jj,7)*zcmo(ji,jj,7) + zcmo(ji,jj,8)*zcmo(ji,jj,8) ) 264 zcmo(ji,jj,34) = diag_sur_me(ji,jj) * rday ! Surface melt 265 zcmo(ji,jj,35) = diag_bot_me(ji,jj) * rday ! Bottom melt 266 zcmo(ji,jj,36) = divu_i(ji,jj) 267 zcmo(ji,jj,37) = shear_i(ji,jj) 268 zcmo(ji,jj,38) = diag_res_pr(ji,jj) * rday ! Bottom melt 269 zcmo(ji,jj,39) = vt_i(ji,jj) ! ice volume 270 zcmo(ji,jj,40) = vt_s(ji,jj) ! snow volume 271 272 zcmo(ji,jj,41) = sfx_mec(ji,jj) 273 zcmo(ji,jj,42) = sfx_res(ji,jj) 274 275 zcmo(ji,jj,43) = diag_trp_vi(ji,jj) * rday ! transport of ice volume 276 277 END DO 278 END DO 279 280 ! 281 ! ecriture d'un fichier netcdf 282 ! 283 niter = niter + 1 284 !clem 285 ! DO jf = 1 , noumef 286 ! ! 287 ! zfield(:,:) = zcmo(:,:,jf) * cmulti(jf) + cadd(jf) 288 ! ! 289 ! IF( jf == 7 .OR. jf == 8 .OR. jf == 15 .OR. jf == 16 ) THEN ; CALL lbc_lnk( zfield, 'T', -1. ) 290 ! ELSE ; CALL lbc_lnk( zfield, 'T', 1. ) 291 ! ENDIF 292 ! ! 293 ! IF( ln_nicep ) THEN 294 ! WRITE(numout,*) 295 ! WRITE(numout,*) 'nc(jf), nice, nam(jf), niter, ndim' 296 ! WRITE(numout,*) nc(jf), nice, nam(jf), niter, ndim 297 ! ENDIF 298 ! IF( nc(jf) == 1 ) CALL histwrite( nice, nam(jf), niter, zfield, ndim, ndex51 ) 299 ! ! 300 ! END DO 301 ! 302 ! IF( ( nn_fsbc * niter ) >= nitend .OR. kindic < 0 ) THEN 303 ! IF( lwp) WRITE(numout,*) ' Closing the icemod file ' 304 ! CALL histclo( nice ) 305 ! ENDIF 306 !clem 307 ! 308 CALL iom_put ('iceconc', zcmo(:,:,1) ) ! field1: ice concentration 309 CALL iom_put ('icethic_cea', zcmo(:,:,2) ) ! field2: ice thickness (i.e. icethi(:,:)) 310 CALL iom_put ('snowthic_cea', zcmo(:,:,3)) ! field3: snow thickness 311 CALL iom_put ('icebopr', zcmo(:,:,4) ) ! field4: daily bottom thermo ice production 312 CALL iom_put ('icedypr', zcmo(:,:,5) ) ! field5: daily dynamic ice production 313 CALL iom_put ('ioceflxb', zcmo(:,:,6) ) ! field6: Oceanic flux at the ice base 314 CALL iom_put ('uice_ipa', zcmo(:,:,7) ) ! field7: ice velocity u component 315 CALL iom_put ('vice_ipa', zcmo(:,:,8) ) ! field8: ice velocity v component 316 CALL iom_put ('isst', zcmo(:,:,9) ) ! field 9: sea surface temperature 317 CALL iom_put ('isss', zcmo(:,:,10) ) ! field 10: sea surface salinity 318 CALL iom_put ('qt_oce', zcmo(:,:,11) ) ! field 11: total flux at ocean surface 319 CALL iom_put ('qsr_oce', zcmo(:,:,12) ) ! field 12: solar flux at ocean surface 320 CALL iom_put ('qns_oce', zcmo(:,:,13) ) ! field 13: non-solar flux at ocean surface 321 !CALL iom_put ('hfbri', fhbri ) ! field 14: heat flux due to brine release 322 CALL iom_put( 'utau_ice', zcmo(:,:,15) ) ! Wind stress over ice along i-axis at I-point 323 CALL iom_put( 'vtau_ice', zcmo(:,:,16) ) ! Wind stress over ice along j-axis at I-point 324 CALL iom_put ('qsr_io', zcmo(:,:,17) ) ! field 17: solar flux at ice/ocean surface 325 CALL iom_put ('qns_io', zcmo(:,:,18) ) ! field 18: non-solar flux at ice/ocean surface 326 !CALL iom_put ('snowpre', zcmo(:,:,19) * rday ! field 19 :snow precip 327 CALL iom_put ('micesalt', zcmo(:,:,20) ) ! field 20 :mean ice salinity 328 CALL iom_put ('miceage', zcmo(:,:,21) / 365) ! field 21: mean ice age 329 CALL iom_put ('icelapr',zcmo(:,:,22) ) ! field 22: daily lateral thermo ice prod. 330 CALL iom_put ('icesipr',zcmo(:,:,23) ) ! field 23: daily snowice ice prod. 331 CALL iom_put ('micet', zcmo(:,:,24) ) ! field 24: mean ice temperature 332 CALL iom_put ('icehc', zcmo(:,:,25) ) ! field 25: ice total heat content 333 CALL iom_put ('isnowhc', zcmo(:,:,26) ) ! field 26: snow total heat content 334 CALL iom_put ('icest', zcmo(:,:,27) ) ! field 27: ice surface temperature 335 CALL iom_put ('sfxbri', zcmo(:,:,28) * rday ) ! field 28: brine salt flux 336 CALL iom_put ('sfxthd', zcmo(:,:,29) * rday ) ! field 29: equivalent FW salt flux 337 CALL iom_put ('ibrinv', zcmo(:,:,30) *100 ) ! field 30: brine volume 338 CALL iom_put ('icecolf', zcmo(:,:,31) ) ! field 31: frazil ice collection thickness 339 CALL iom_put ('icestr', zcmo(:,:,32) * 0.001 ) ! field 32: ice strength 340 CALL iom_put ('icevel', zcmo(:,:,33) ) ! field 33: ice velocity 341 CALL iom_put ('isume', zcmo(:,:,34) ) ! field 34: surface melt 342 CALL iom_put ('ibome', zcmo(:,:,35) ) ! field 35: bottom melt 343 CALL iom_put ('idive', zcmo(:,:,36) * 1.0e8) ! field 36: divergence 344 CALL iom_put ('ishear', zcmo(:,:,37) * 1.0e8 ) ! field 37: shear 345 CALL iom_put ('icerepr', zcmo(:,:,38) ) ! field 38: daily prod./melting due to limupdate 346 CALL iom_put ('icevolu', zcmo(:,:,39) ) ! field 39: ice volume 347 CALL iom_put ('snowvol', zcmo(:,:,40) ) ! field 40: snow volume 348 CALL iom_put ('sfxmec', zcmo(:,:,41) * rday ) ! field 41: salt flux from ridging rafting 349 CALL iom_put ('sfxres', zcmo(:,:,42) * rday ) ! field 42: salt flux from limupdate (resultant) 350 CALL iom_put ('icetrp', zcmo(:,:,43) ) ! field 43: ice volume transport 351 352 !----------------------------- 353 ! Thickness distribution file 354 !----------------------------- 355 IF( add_diag_swi == 1 ) THEN 356 357 DO jl = 1, jpl 358 CALL lbc_lnk( a_i(:,:,jl) , 'T' , 1. ) 359 CALL lbc_lnk( sm_i(:,:,jl) , 'T' , 1. ) 360 CALL lbc_lnk( oa_i(:,:,jl) , 'T' , 1. ) 361 CALL lbc_lnk( ht_i(:,:,jl) , 'T' , 1. ) 362 CALL lbc_lnk( ht_s(:,:,jl) , 'T' , 1. ) 363 END DO 364 365 ! Compute ice age 141 z2d(ji,jj) = ( tm_i(ji,jj) - rtt ) * zswi(ji,jj) 142 END DO 143 END DO 144 CALL iom_put( "micet" , z2d ) ! mean ice temperature 145 ENDIF 146 ! 147 IF ( iom_use( "icest" ) ) THEN 148 z2d(:,:) = 0.e0 149 DO jl = 1, jpl 150 DO jj = 1, jpj 151 DO ji = 1, jpi 152 z2d(ji,jj) = z2d(ji,jj) + zswi(ji,jj) * ( t_su(ji,jj,jl) - rtt ) * a_i(ji,jj,jl) / MAX( at_i(ji,jj) , epsi06 ) 153 END DO 154 END DO 155 END DO 156 CALL iom_put( "icest" , z2d ) ! ice surface temperature 157 ENDIF 158 159 IF ( iom_use( "icecolf" ) ) THEN 160 DO jj = 1, jpj 161 DO ji = 1, jpi 162 rswitch = MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) ) ) 163 z2d(ji,jj) = hicol(ji,jj) * rswitch 164 END DO 165 END DO 166 CALL iom_put( "icecolf" , z2d ) ! frazil ice collection thickness 167 ENDIF 168 169 CALL iom_put( "isst" , sst_m ) ! sea surface temperature 170 CALL iom_put( "isss" , sss_m ) ! sea surface salinity 171 CALL iom_put( "iceconc" , at_i ) ! ice concentration 172 CALL iom_put( "icevolu" , vt_i ) ! ice volume = mean ice thickness over the cell 173 CALL iom_put( "icehc" , et_i ) ! ice total heat content 174 CALL iom_put( "isnowhc" , et_s ) ! snow total heat content 175 CALL iom_put( "ibrinv" , bv_i * 100._wp ) ! brine volume 176 CALL iom_put( "utau_ice" , utau_ice ) ! wind stress over ice along i-axis at I-point 177 CALL iom_put( "vtau_ice" , vtau_ice ) ! wind stress over ice along j-axis at I-point 178 CALL iom_put( "snowpre" , sprecip ) ! snow precipitation 179 CALL iom_put( "micesalt" , smt_i ) ! mean ice salinity 180 181 CALL iom_put( "icestr" , strength * 0.001 ) ! ice strength 182 CALL iom_put( "idive" , divu_i * 1.0e8 ) ! divergence 183 CALL iom_put( "ishear" , shear_i * 1.0e8 ) ! shear 184 CALL iom_put( "snowvol" , vt_s ) ! snow volume 185 186 CALL iom_put( "icetrp" , diag_trp_vi * rday ) ! ice volume transport 187 CALL iom_put( "snwtrp" , diag_trp_vs * rday ) ! snw volume transport 188 CALL iom_put( "deitrp" , diag_trp_ei ) ! advected ice enthalpy (W/m2) 189 CALL iom_put( "destrp" , diag_trp_es ) ! advected snw enthalpy (W/m2) 190 191 CALL iom_put( "sfxbog" , sfx_bog * rday ) ! salt flux from brines 192 CALL iom_put( "sfxbom" , sfx_bom * rday ) ! salt flux from brines 193 CALL iom_put( "sfxsum" , sfx_sum * rday ) ! salt flux from brines 194 CALL iom_put( "sfxsni" , sfx_sni * rday ) ! salt flux from brines 195 CALL iom_put( "sfxopw" , sfx_opw * rday ) ! salt flux from brines 196 CALL iom_put( "sfxdyn" , sfx_dyn * rday ) ! salt flux from ridging rafting 197 CALL iom_put( "sfxres" , sfx_res * rday ) ! salt flux from limupdate (resultant) 198 CALL iom_put( "sfxbri" , sfx_bri * rday ) ! salt flux from brines 199 CALL iom_put( "sfx" , sfx * rday ) ! total salt flux 200 201 ztmp = rday / rhoic 202 CALL iom_put( "vfxres" , wfx_res * ztmp ) ! daily prod./melting due to limupdate 203 CALL iom_put( "vfxopw" , wfx_opw * ztmp ) ! daily lateral thermodynamic ice production 204 CALL iom_put( "vfxsni" , wfx_sni * ztmp ) ! daily snowice ice production 205 CALL iom_put( "vfxbog" , wfx_bog * ztmp ) ! daily bottom thermodynamic ice production 206 CALL iom_put( "vfxdyn" , wfx_dyn * ztmp ) ! daily dynamic ice production (rid/raft) 207 CALL iom_put( "vfxsum" , wfx_sum * ztmp ) ! surface melt 208 CALL iom_put( "vfxbom" , wfx_bom * ztmp ) ! bottom melt 209 CALL iom_put( "vfxice" , wfx_ice * ztmp ) ! total ice growth/melt 210 CALL iom_put( "vfxsnw" , wfx_snw * ztmp ) ! total snw growth/melt 211 CALL iom_put( "vfxsub" , wfx_sub * ztmp ) ! sublimation (snow) 212 CALL iom_put( "vfxspr" , wfx_spr * ztmp ) ! precip (snow) 213 214 CALL iom_put ('hfxthd', hfx_thd(:,:) ) ! 215 CALL iom_put ('hfxdyn', hfx_dyn(:,:) ) ! 216 CALL iom_put ('hfxres', hfx_res(:,:) ) ! 217 CALL iom_put ('hfxout', hfx_out(:,:) ) ! 218 CALL iom_put ('hfxin' , hfx_in(:,:) ) ! 219 CALL iom_put ('hfxsnw', hfx_snw(:,:) ) ! 220 CALL iom_put ('hfxsub', hfx_sub(:,:) ) ! 221 CALL iom_put ('hfxerr', hfx_err(:,:) ) ! 222 CALL iom_put ('hfxerr_rem', hfx_err_rem(:,:) ) ! 223 224 CALL iom_put ('hfxsum', hfx_sum(:,:) ) ! 225 CALL iom_put ('hfxbom', hfx_bom(:,:) ) ! 226 CALL iom_put ('hfxbog', hfx_bog(:,:) ) ! 227 CALL iom_put ('hfxdif', hfx_dif(:,:) ) ! 228 CALL iom_put ('hfxopw', hfx_opw(:,:) ) ! 229 CALL iom_put ('hfxtur', fhtur(:,:) * at_i(:,:) ) ! turbulent heat flux at ice base 230 CALL iom_put ('hfxdhc', diag_heat_dhc(:,:) ) ! Heat content variation in snow and ice 231 CALL iom_put ('hfxspr', hfx_spr(:,:) ) ! Heat content of snow precip 232 233 !-------------------------------- 234 ! Output values for each category 235 !-------------------------------- 236 CALL iom_put( "iceconc_cat" , a_i ) ! area for categories 237 CALL iom_put( "icethic_cat" , ht_i ) ! thickness for categories 238 CALL iom_put( "snowthic_cat" , ht_s ) ! snow depth for categories 239 CALL iom_put( "salinity_cat" , sm_i ) ! salinity for categories 240 241 ! Compute ice age 242 IF ( iom_use( "iceage_cat" ) ) THEN 366 243 DO jl = 1, jpl 367 244 DO jj = 1, jpj 368 245 DO ji = 1, jpi 369 zinda = MAX( zzero , SIGN( zone, a_i(ji,jj,jl) - epsi06 ) )370 zoi(ji,jj,jl) = oa_i(ji,jj,jl) / MAX( a_i(ji,jj,jl) , epsi06 ) * zinda246 rswitch = MAX( 0._wp , SIGN( 1._wp , a_i(ji,jj,jl) - epsi06 ) ) 247 zoi(ji,jj,jl) = oa_i(ji,jj,jl) / MAX( a_i(ji,jj,jl) , epsi06 ) * rswitch 371 248 END DO 372 249 END DO 373 250 END DO 374 375 ! Compute brine volume 251 CALL iom_put( "iceage_cat" , zoi ) ! ice age for categories 252 ENDIF 253 254 ! Compute brine volume 255 IF ( iom_use( "brinevol_cat" ) ) THEN 376 256 zei(:,:,:) = 0._wp 377 257 DO jl = 1, jpl … … 379 259 DO jj = 1, jpj 380 260 DO ji = 1, jpi 381 zinda = MAX( zzero , SIGN( zone, a_i(ji,jj,jl) - epsi06 ) )261 rswitch = MAX( 0._wp , SIGN( 1._wp , a_i(ji,jj,jl) - epsi06 ) ) 382 262 zei(ji,jj,jl) = zei(ji,jj,jl) + 100.0* & 383 263 ( - tmut * s_i(ji,jj,jk,jl) / MIN( ( t_i(ji,jj,jk,jl) - rtt ), - epsi06 ) ) * & 384 zinda/ nlay_i264 rswitch / nlay_i 385 265 END DO 386 266 END DO 387 267 END DO 388 268 END DO 389 390 DO jl = 1, jpl 391 CALL lbc_lnk( zei(:,:,jl) , 'T' , 1. ) 392 END DO 393 394 CALL histwrite( nicea, "iice_itd", niter, a_i , ndimitd , ndexitd ) ! area 395 CALL histwrite( nicea, "iice_hid", niter, ht_i , ndimitd , ndexitd ) ! thickness 396 CALL histwrite( nicea, "iice_hsd", niter, ht_s , ndimitd , ndexitd ) ! snow depth 397 CALL histwrite( nicea, "iice_std", niter, sm_i , ndimitd , ndexitd ) ! salinity 398 CALL histwrite( nicea, "iice_otd", niter, zoi , ndimitd , ndexitd ) ! age 399 CALL histwrite( nicea, "iice_etd", niter, zei , ndimitd , ndexitd ) ! brine volume 400 401 ! ! Create an output files (output.lim.abort.nc) if S < 0 or u > 20 m/s 402 ! IF( kindic < 0 ) CALL lim_wri_state( 'output.abort' ) 403 ! not yet implemented 404 405 IF( ( nn_fsbc * niter ) >= nitend .OR. kindic < 0 ) THEN 406 IF(lwp) WRITE(numout,*) ' Closing the icemod file ' 407 CALL histclo( nicea ) 408 ENDIF 409 ! 410 ENDIF 411 412 CALL wrk_dealloc( jpi, jpj, zfield ) 413 CALL wrk_dealloc( jpi, jpj, jpnoumax, zcmo, zcmoa ) 414 CALL wrk_dealloc( jpi, jpj, jpl, zmaskitd, zoi, zei ) 269 CALL iom_put( "brinevol_cat" , zei ) ! brine volume for categories 270 ENDIF 271 272 ! ! Create an output files (output.lim.abort.nc) if S < 0 or u > 20 m/s 273 ! IF( kindic < 0 ) CALL lim_wri_state( 'output.abort' ) 274 ! not yet implemented 275 276 CALL wrk_dealloc( jpi, jpj, jpl, zoi, zei ) 277 CALL wrk_dealloc( jpi, jpj , z2d, zswi, z2da, z2db ) 415 278 416 279 IF( nn_timing == 1 ) CALL timing_stop('limwri') … … 419 282 #endif 420 283 421 SUBROUTINE lim_wri_init422 !!-------------------------------------------------------------------423 !! *** ROUTINE lim_wri_init ***424 !!425 !! ** Purpose : ???426 !!427 !! ** Method : Read the namicewri namelist and check the parameter428 !! values called at the first timestep (nit000)429 !!430 !! ** input : Namelist namicewri431 !!-------------------------------------------------------------------432 INTEGER :: nf ! ???433 INTEGER :: ios ! Local integer output status for namelist read434 435 TYPE FIELD436 CHARACTER(len = 35) :: ztitle437 CHARACTER(len = 8 ) :: zname438 CHARACTER(len = 8 ) :: zunit439 INTEGER :: znc440 REAL :: zcmulti441 REAL :: zcadd442 END TYPE FIELD443 444 TYPE(FIELD) :: &445 field_1 , field_2 , field_3 , field_4 , field_5 , field_6 , &446 field_7 , field_8 , field_9 , field_10, field_11, field_12, &447 field_13, field_14, field_15, field_16, field_17, field_18, &448 field_19, field_20, field_21, field_22, field_23, field_24, &449 field_25, field_26, field_27, field_28, field_29, field_30, &450 field_31, field_32, field_33, field_34, field_35, field_36, &451 field_37, field_38, field_39, field_40, field_41, field_42, field_43452 453 TYPE(FIELD) , DIMENSION(jpnoumax) :: zfield454 !455 NAMELIST/namiceout/ noumef, &456 field_1 , field_2 , field_3 , field_4 , field_5 , field_6 , &457 field_7 , field_8 , field_9 , field_10, field_11, field_12, &458 field_13, field_14, field_15, field_16, field_17, field_18, &459 field_19, field_20, field_21, field_22, field_23, field_24, &460 field_25, field_26, field_27, field_28, field_29, field_30, &461 field_31, field_32, field_33, field_34, field_35, field_36, &462 field_37, field_38, field_39, field_40, field_41, field_42, field_43, add_diag_swi463 !!-------------------------------------------------------------------464 REWIND( numnam_ice_ref ) ! Namelist namiceout in reference namelist : Ice outputs465 READ ( numnam_ice_ref, namiceout, IOSTAT = ios, ERR = 901)466 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namiceout in reference namelist', lwp )467 468 REWIND( numnam_ice_cfg ) ! Namelist namiceout in configuration namelist : Ice outputs469 READ ( numnam_ice_cfg, namiceout, IOSTAT = ios, ERR = 902 )470 902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namiceout in configuration namelist', lwp )471 IF(lwm) WRITE ( numoni, namiceout )472 473 zfield(1) = field_1474 zfield(2) = field_2475 zfield(3) = field_3476 zfield(4) = field_4477 zfield(5) = field_5478 zfield(6) = field_6479 zfield(7) = field_7480 zfield(8) = field_8481 zfield(9) = field_9482 zfield(10) = field_10483 zfield(11) = field_11484 zfield(12) = field_12485 zfield(13) = field_13486 zfield(14) = field_14487 zfield(15) = field_15488 zfield(16) = field_16489 zfield(17) = field_17490 zfield(18) = field_18491 zfield(19) = field_19492 zfield(20) = field_20493 zfield(21) = field_21494 zfield(22) = field_22495 zfield(23) = field_23496 zfield(24) = field_24497 zfield(25) = field_25498 zfield(26) = field_26499 zfield(27) = field_27500 zfield(28) = field_28501 zfield(29) = field_29502 zfield(30) = field_30503 zfield(31) = field_31504 zfield(32) = field_32505 zfield(33) = field_33506 zfield(34) = field_34507 zfield(35) = field_35508 zfield(36) = field_36509 zfield(37) = field_37510 zfield(38) = field_38511 zfield(39) = field_39512 zfield(40) = field_40513 zfield(41) = field_41514 zfield(42) = field_42515 zfield(43) = field_43516 517 DO nf = 1, noumef518 titn (nf) = zfield(nf)%ztitle519 nam (nf) = zfield(nf)%zname520 uni (nf) = zfield(nf)%zunit521 nc (nf) = zfield(nf)%znc522 cmulti(nf) = zfield(nf)%zcmulti523 cadd (nf) = zfield(nf)%zcadd524 END DO525 526 IF(lwp) THEN ! control print527 WRITE(numout,*)528 WRITE(numout,*) 'lim_wri_init : Ice parameters for outputs'529 WRITE(numout,*) '~~~~~~~~~~~~'530 WRITE(numout,*) ' number of fields to be stored noumef = ', noumef531 WRITE(numout,*) ' title name unit Saving (1/0) ', &532 & ' multiplicative constant additive constant '533 DO nf = 1 , noumef534 WRITE(numout,*) ' ', titn(nf), ' ' , nam (nf), ' ' , uni (nf), &535 & ' ' , nc (nf),' ', cmulti(nf), ' ', cadd(nf)536 END DO537 WRITE(numout,*) ' add_diag_swi ', add_diag_swi538 ENDIF539 !540 END SUBROUTINE lim_wri_init541 284 542 285 SUBROUTINE lim_wri_state( kt, kid, kh_i ) … … 555 298 INTEGER, INTENT( in ) :: kid , kh_i 556 299 !!---------------------------------------------------------------------- 557 !CALL histvert( kid, "icethi", "L levels","m", jpl , hi_mean , nz ) 558 559 CALL histdef( kid, "iicethic", "Ice thickness" , "m" , jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt ) 560 CALL histdef( kid, "iiceconc", "Ice concentration" , "%" , jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt ) 561 CALL histdef( kid, "iicetemp", "Ice temperature" , "C" , jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt ) 562 CALL histdef( kid, "iicevelu", "i-Ice speed (I-point)" , "m/s" , jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt ) 563 CALL histdef( kid, "iicevelv", "j-Ice speed (I-point)" , "m/s" , jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt ) 564 CALL histdef( kid, "iicestru", "i-Wind stress over ice (I-pt)", "Pa", jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt ) 565 CALL histdef( kid, "iicestrv", "j-Wind stress over ice (I-pt)", "Pa", jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt ) 566 CALL histdef( kid, "iicesflx", "Solar flux over ocean" , "w/m2" , jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt ) 567 CALL histdef( kid, "iicenflx", "Non-solar flux over ocean" , "w/m2" , jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt ) 568 CALL histdef( kid, "isnowpre", "Snow precipitation" , "kg/m2/s", jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt ) 569 CALL histdef( kid, "iicesali", "Ice salinity" , "PSU" , jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt ) 570 CALL histdef( kid, "iicevolu", "Ice volume" , "m" , jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt ) 571 CALL histdef( kid, "iicedive", "Ice divergence" , "10-8s-1", jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt ) 572 CALL histdef( kid, "iicebopr", "Ice bottom production" , "m/s" , jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt ) 573 CALL histdef( kid, "iicedypr", "Ice dynamic production" , "m/s" , jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt ) 574 CALL histdef( kid, "iicelapr", "Ice open water prod" , "m/s" , jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt ) 575 CALL histdef( kid, "iicesipr", "Snow ice production " , "m/s" , jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt ) 576 CALL histdef( kid, "iicerepr", "Ice prod from limupdate" , "m/s" , jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt ) 577 CALL histdef( kid, "iicebome", "Ice bottom melt" , "m/s" , jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt ) 578 CALL histdef( kid, "iicesume", "Ice surface melt" , "m/s" , jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt ) 579 CALL histdef( kid, "iisfxthd", "Salt flux from thermo" , "" , jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt ) 580 CALL histdef( kid, "iisfxmec", "Salt flux from dynmics" , "" , jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt ) 581 CALL histdef( kid, "iisfxres", "Salt flux from limupdate", "" , jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt ) 582 583 584 !CALL histdef( kid, "iice_itd", "Ice concentration by cat", "%" , jpi, jpj, kh_i, jpl, 1, jpl, -99, 32, "inst(x)", rdt, rdt ) 585 !CALL histdef( kid, "iice_hid", "Ice thickness by cat" , "m" , jpi, jpj, kh_i, jpl, 1, jpl, -99, 32, "inst(x)", rdt, rdt ) 586 !CALL histdef( kid, "iice_hsd", "Snow thickness by cat" , "m" , jpi, jpj, kh_i, jpl, 1, jpl, -99, 32, "inst(x)", rdt, rdt ) 587 !CALL histdef( kid, "iice_std", "Ice salinity by cat" , "PSU" , jpi, jpj, kh_i, jpl, 1, jpl, -99, 32, "inst(x)", rdt, rdt ) 300 301 CALL histdef( kid, "iicethic", "Ice thickness" , "m" , & 302 & jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt ) 303 CALL histdef( kid, "iiceconc", "Ice concentration" , "%" , & 304 & jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt ) 305 CALL histdef( kid, "iicetemp", "Ice temperature" , "C" , & 306 & jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt ) 307 CALL histdef( kid, "iicevelu", "i-Ice speed (I-point)" , "m/s" , & 308 & jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt ) 309 CALL histdef( kid, "iicevelv", "j-Ice speed (I-point)" , "m/s" , & 310 & jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt ) 311 CALL histdef( kid, "iicestru", "i-Wind stress over ice (I-pt)", "Pa", & 312 & jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt ) 313 CALL histdef( kid, "iicestrv", "j-Wind stress over ice (I-pt)", "Pa", & 314 & jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt ) 315 CALL histdef( kid, "iicesflx", "Solar flux over ocean" , "w/m2" , & 316 & jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt ) 317 CALL histdef( kid, "iicenflx", "Non-solar flux over ocean" , "w/m2" , & 318 & jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt ) 319 CALL histdef( kid, "isnowpre", "Snow precipitation" , "kg/m2/s", & 320 & jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt ) 321 CALL histdef( kid, "iicesali", "Ice salinity" , "PSU" , & 322 & jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt ) 323 CALL histdef( kid, "iicevolu", "Ice volume" , "m" , & 324 & jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt ) 325 CALL histdef( kid, "iicedive", "Ice divergence" , "10-8s-1", & 326 & jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt ) 327 CALL histdef( kid, "iicebopr", "Ice bottom production" , "m/s" , & 328 & jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt ) 329 CALL histdef( kid, "iicedypr", "Ice dynamic production" , "m/s" , & 330 & jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt ) 331 CALL histdef( kid, "iicelapr", "Ice open water prod" , "m/s" , & 332 & jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt ) 333 CALL histdef( kid, "iicesipr", "Snow ice production " , "m/s" , & 334 & jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt ) 335 CALL histdef( kid, "iicerepr", "Ice prod from limupdate" , "m/s" , & 336 & jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt ) 337 CALL histdef( kid, "iicebome", "Ice bottom melt" , "m/s" , & 338 & jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt ) 339 CALL histdef( kid, "iicesume", "Ice surface melt" , "m/s" , & 340 & jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt ) 341 CALL histdef( kid, "iisfxdyn", "Salt flux from dynmics" , "" , & 342 & jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt ) 343 CALL histdef( kid, "iisfxres", "Salt flux from limupdate", "" , & 344 & jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt ) 588 345 589 346 CALL histend( kid, snc4set ) ! end of the file definition … … 603 360 CALL histwrite( kid, "iicedive", kt, divu_i*1.0e8 , jpi*jpj, (/1/) ) 604 361 605 CALL histwrite( kid, "iicebopr", kt, diag_bot_gr , jpi*jpj, (/1/) ) 606 CALL histwrite( kid, "iicedypr", kt, diag_dyn_gr , jpi*jpj, (/1/) ) 607 CALL histwrite( kid, "iicelapr", kt, diag_lat_gr , jpi*jpj, (/1/) ) 608 CALL histwrite( kid, "iicesipr", kt, diag_sni_gr , jpi*jpj, (/1/) ) 609 CALL histwrite( kid, "iicerepr", kt, diag_res_pr , jpi*jpj, (/1/) ) 610 CALL histwrite( kid, "iicebome", kt, diag_bot_me , jpi*jpj, (/1/) ) 611 CALL histwrite( kid, "iicesume", kt, diag_sur_me , jpi*jpj, (/1/) ) 612 CALL histwrite( kid, "iisfxthd", kt, sfx_thd , jpi*jpj, (/1/) ) 613 CALL histwrite( kid, "iisfxmec", kt, sfx_mec , jpi*jpj, (/1/) ) 362 CALL histwrite( kid, "iicebopr", kt, wfx_bog , jpi*jpj, (/1/) ) 363 CALL histwrite( kid, "iicedypr", kt, wfx_dyn , jpi*jpj, (/1/) ) 364 CALL histwrite( kid, "iicelapr", kt, wfx_opw , jpi*jpj, (/1/) ) 365 CALL histwrite( kid, "iicesipr", kt, wfx_sni , jpi*jpj, (/1/) ) 366 CALL histwrite( kid, "iicerepr", kt, wfx_res , jpi*jpj, (/1/) ) 367 CALL histwrite( kid, "iicebome", kt, wfx_bom , jpi*jpj, (/1/) ) 368 CALL histwrite( kid, "iicesume", kt, wfx_sum , jpi*jpj, (/1/) ) 369 CALL histwrite( kid, "iisfxdyn", kt, sfx_dyn , jpi*jpj, (/1/) ) 614 370 CALL histwrite( kid, "iisfxres", kt, sfx_res , jpi*jpj, (/1/) ) 615 371 616 !CALL histwrite( kid, "iice_itd", kt, a_i , jpi*jpj*jpl, (/1/) ) ! area 617 !CALL histwrite( kid, "iice_hid", kt, ht_i , jpi*jpj*jpl, (/1/) ) ! thickness 618 !CALL histwrite( kid, "iice_hsd", kt, ht_s , jpi*jpj*jpl, (/1/) ) ! snow depth 619 !CALL histwrite( kid, "iice_std", kt, sm_i , jpi*jpj*jpl, (/1/) ) ! salinity 372 ! Close the file 373 ! ----------------- 374 !CALL histclo( kid ) 620 375 621 376 END SUBROUTINE lim_wri_state -
branches/2014/dev_r4650_UKMO14.12_STAND_ALONE_OBSOPER/NEMOGCM/NEMO/LIM_SRC_3/limwri_dimg.h90
r3764 r5034 89 89 DO jj = 2 , jpjm1 90 90 DO ji = 2 , jpim1 ! NO vector opt. 91 zindh = MAX( zzero , SIGN( zone, ht_i(ji,jj,1) * (1.0 - frld(ji,jj) ) - 0.10 ) )92 zinda = MAX( zzero , SIGN( zone, ( 1.0 - frld(ji,jj) ) - 0.10 ) )91 zindh = MAX( 0._wp , SIGN( 1._wp , ht_i(ji,jj,1) * (1.0 - frld(ji,jj) ) - 0.10 ) ) 92 zinda = MAX( 0._wp , SIGN( 1._wp , ( 1.0 - frld(ji,jj) ) - 0.10 ) ) 93 93 zindb = zindh * zinda 94 ztmu = MAX( 0.5 * zone, ( tmu(ji,jj) + tmu(ji+1,jj) + tmu(ji,jj+1) + tmu(ji+1,jj+1) ) )94 ztmu = MAX( 0.5 * 1._wp , ( tmu(ji,jj) + tmu(ji+1,jj) + tmu(ji,jj+1) + tmu(ji+1,jj+1) ) ) 95 95 zcmo(ji,jj,1) = ht_s (ji,jj,1) 96 96 zcmo(ji,jj,2) = ht_i (ji,jj,1) 97 zcmo(ji,jj,3) = hicifp(ji,jj)97 zcmo(ji,jj,3) = 0. 98 98 zcmo(ji,jj,4) = frld (ji,jj) 99 99 zcmo(ji,jj,5) = sist (ji,jj) 100 zcmo(ji,jj,6) = f bif(ji,jj)100 zcmo(ji,jj,6) = fhtur (ji,jj) 101 101 zcmo(ji,jj,7) = zindb * ( u_ice(ji,jj ) * tmu(ji,jj ) + u_ice(ji+1,jj ) * tmu(ji+1,jj ) & 102 102 + u_ice(ji,jj+1) * tmu(ji,jj+1) + u_ice(ji+1,jj+1) * tmu(ji+1,jj+1) ) & … … 132 132 DO jj = 2 , jpjm1 133 133 DO ji = 2 , jpim1 ! NO vector opt. 134 zindh = MAX( zzero , SIGN( zone, ht_i(ji,jj,1) * (1.0 - frld(ji,jj) ) - 0.10 ) )135 zinda = MAX( zzero , SIGN( zone, ( 1.0 - frld(ji,jj) ) - 0.10 ) )134 zindh = MAX( 0._wp , SIGN( 1._wp , ht_i(ji,jj,1) * (1.0 - frld(ji,jj) ) - 0.10 ) ) 135 zinda = MAX( 0._wp , SIGN( 1._wp , ( 1.0 - frld(ji,jj) ) - 0.10 ) ) 136 136 zindb = zindh * zinda 137 ztmu = MAX( 0.5 * zone, ( tmu(ji,jj) + tmu(ji+1,jj) + tmu(ji,jj+1) + tmu(ji+1,jj+1) ) )137 ztmu = MAX( 0.5 * 1._wp , ( tmu(ji,jj) + tmu(ji+1,jj) + tmu(ji,jj+1) + tmu(ji+1,jj+1) ) ) 138 138 rcmoy(ji,jj,1) = ht_s (ji,jj,1) 139 139 rcmoy(ji,jj,2) = ht_i (ji,jj,1) 140 rcmoy(ji,jj,3) = hicifp(ji,jj)140 rcmoy(ji,jj,3) = 0. 141 141 rcmoy(ji,jj,4) = frld (ji,jj) 142 142 rcmoy(ji,jj,5) = sist (ji,jj) 143 rcmoy(ji,jj,6) = f bif(ji,jj)143 rcmoy(ji,jj,6) = fhtur (ji,jj) 144 144 rcmoy(ji,jj,7) = zindb * ( u_ice(ji,jj ) * tmu(ji,jj ) + u_ice(ji+1,jj ) * tmu(ji+1,jj ) & 145 145 + u_ice(ji,jj+1) * tmu(ji,jj+1) + u_ice(ji+1,jj+1) * tmu(ji+1,jj+1) ) & -
branches/2014/dev_r4650_UKMO14.12_STAND_ALONE_OBSOPER/NEMOGCM/NEMO/LIM_SRC_3/par_ice.F90
r2528 r5034 12 12 13 13 ! !!! ice thermodynamics 14 INTEGER, PUBLIC, PARAMETER :: jkmax = 6 !: maximumnumber of ice layers14 INTEGER, PUBLIC, PARAMETER :: nlay_i = 5 !: number of ice layers 15 15 INTEGER, PUBLIC, PARAMETER :: nlay_s = 1 !: number of snow layers 16 16 17 17 ! !!! ice mechanical redistribution 18 18 INTEGER, PUBLIC, PARAMETER :: jpl = 5 !: number of ice categories 19 INTEGER, PUBLIC, PARAMETER :: jpm = 1 !: number of ice types20 19 21 20 !!---------------------------------------------------------------------- -
branches/2014/dev_r4650_UKMO14.12_STAND_ALONE_OBSOPER/NEMOGCM/NEMO/LIM_SRC_3/thd_ice.F90
r4205 r5034 20 20 ! !!! ** ice-thermo namelist (namicethd) ** 21 21 REAL(wp), PUBLIC :: hmelt !: maximum melting at the bottom; active only for one category 22 REAL(wp), PUBLIC :: hicmin !: (REMOVE)23 22 REAL(wp), PUBLIC :: hiclim !: minimum ice thickness 24 REAL(wp), PUBLIC :: sbeta !: numerical scheme for diffusion in ice (REMOVE)25 REAL(wp), PUBLIC :: parlat !: (REMOVE)26 REAL(wp), PUBLIC :: hakspl !: (REMOVE)27 REAL(wp), PUBLIC :: hibspl !: (REMOVE)28 REAL(wp), PUBLIC :: exld !: (REMOVE)29 REAL(wp), PUBLIC :: hakdif !: (REMOVE)30 REAL(wp), PUBLIC :: thth !: (REMOVE)31 23 REAL(wp), PUBLIC :: hnzst !: thick. of the surf. layer in temp. comp. 32 24 REAL(wp), PUBLIC :: parsub !: switch for snow sublimation or not 33 REAL(wp), PUBLIC :: alphs !: coef. for snow density when snow-ice formation34 REAL(wp), PUBLIC :: fraz_swi !: use of frazil ice collection in function of wind (1.0) or not (0.0)35 25 REAL(wp), PUBLIC :: maxfrazb !: maximum portion of frazil ice collecting at the ice bottom 36 26 REAL(wp), PUBLIC :: vfrazb !: threshold drift speed for collection of bottom frazil ice 37 27 REAL(wp), PUBLIC :: Cfrazb !: squeezing coefficient for collection of bottom frazil ice 28 REAL(wp), PUBLIC :: hiccrit !: ice th. for lateral accretion in the NH (SH) (m) 38 29 39 REAL(wp), PUBLIC, DIMENSION(2) :: hiccrit !: ice th. for lateral accretion in the NH (SH) (m)30 INTEGER , PUBLIC :: fraz_swi !: use of frazil ice collection in function of wind (1) or not (0) 40 31 41 32 !!----------------------------- … … 43 34 !!----------------------------- 44 35 !: In ice thermodynamics, to spare memory, the vectors are folded 45 !: from 1D to 2D vectors. The following variables, with ending _1d (or _b)36 !: from 1D to 2D vectors. The following variables, with ending _1d 46 37 !: are the variables corresponding to 2d vectors 47 38 … … 49 40 INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: npac !: correspondance between points (lateral accretion) 50 41 51 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: qldif_1d !: <==> the 2D qldif 52 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: qcmif_1d !: <==> the 2D qcmif 53 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: fstbif_1d !: <==> the 2D fstric 54 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: fltbif_1d !: <==> the 2D ffltbif 55 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: fscbq_1d !: <==> the 2D fscmcbq 56 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: qsr_ice_1d !: <==> the 2D qsr_ice 57 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: fr1_i0_1d !: <==> the 2D fr1_i0 58 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: fr2_i0_1d !: <==> the 2D fr2_i0 59 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: qnsr_ice_1d !: <==> the 2D qns_ice 60 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: qfvbq_1d !: <==> the 2D qfvbq 61 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: t_bo_b !: <==> the 2D t_bo 42 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: qlead_1d 43 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: ftr_ice_1d 44 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: qsr_ice_1d 45 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: fr1_i0_1d 46 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: fr2_i0_1d 47 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: qns_ice_1d 48 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: t_bo_1d 49 50 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: hfx_sum_1d 51 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: hfx_bom_1d 52 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: hfx_bog_1d 53 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: hfx_dif_1d 54 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: hfx_opw_1d 55 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: hfx_snw_1d 56 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: hfx_err_1d 57 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: hfx_err_rem_1d 58 59 ! heat flux associated with ice-atmosphere mass exchange 60 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: hfx_sub_1d 61 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: hfx_spr_1d 62 63 ! heat flux associated with ice-ocean mass exchange 64 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: hfx_thd_1d 65 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: hfx_res_1d 66 67 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: wfx_snw_1d 68 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: wfx_sub_1d 69 70 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: wfx_bog_1d 71 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: wfx_bom_1d 72 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: wfx_sum_1d 73 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: wfx_sni_1d 74 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: wfx_opw_1d 75 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: wfx_res_1d 76 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: wfx_spr_1d 77 78 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: sfx_bri_1d 79 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: sfx_bog_1d 80 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: sfx_bom_1d 81 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: sfx_sum_1d 82 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: sfx_sni_1d 83 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: sfx_opw_1d 84 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: sfx_res_1d 62 85 63 86 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: sprecip_1d !: <==> the 2D sprecip 64 87 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: frld_1d !: <==> the 2D frld 65 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: at_i_b !: <==> the 2D frld 66 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: fbif_1d !: <==> the 2D fbif 67 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: rdm_ice_1d !: <==> the 2D rdm_ice 68 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: rdm_snw_1d !: <==> the 2D rdm_snw 69 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: qlbbq_1d !: <==> the 2D qlbsbq 70 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: dmgwi_1d !: <==> the 2D dmgwi 71 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: dvsbq_1d !: <==> the 2D rdvosif 72 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: dvbbq_1d !: <==> the 2D rdvobif 73 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: dvlbq_1d !: <==> the 2D rdvolif 74 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: dvnbq_1d !: <==> the 2D rdvolif 88 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: at_i_1d !: <==> the 2D at_i 89 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: fhtur_1d !: <==> the 2D fhtur 90 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: fhld_1d !: <==> the 2D fhld 75 91 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: dqns_ice_1d !: <==> the 2D dqns_ice 76 92 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: qla_ice_1d !: <==> the 2D qla_ice … … 78 94 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: tatm_ice_1d !: <==> the 2D tatm_ice 79 95 ! ! to reintegrate longwave flux inside the ice thermodynamics 80 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: fsup !: Energy flux sent from bottom to lateral ablation if |dhb|> 0.15 m81 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: focea !: Remaining energy in case of total ablation82 96 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: i0 !: fraction of radiation transmitted to the ice 83 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: old_ht_i_b !: Ice thickness at the beginnning of the time step [m]84 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: old_ht_s_b !: Snow thickness at the beginning of the time step [m]85 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: sfx_bri_1d !: <==> the 2D sfx_bri86 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: fhbri_1d !: Heat flux due to brine drainage87 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: sfx_thd_1d !: <==> the 2D sfx_thd88 97 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: dsm_i_fl_1d !: Ice salinity variations due to flushing 89 98 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: dsm_i_gd_1d !: Ice salinity variations due to gravity drainage 90 99 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: dsm_i_se_1d !: Ice salinity variations due to basal salt entrapment 91 100 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: dsm_i_si_1d !: Ice salinity variations due to lateral accretion 92 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: hicol_ b !: Ice collection thickness accumulated in fleads101 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: hicol_1d !: Ice collection thickness accumulated in leads 93 102 94 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: t_su_b !: <==> the 2D t_su 95 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: a_i_b !: <==> the 2D a_i 96 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: ht_i_b !: <==> the 2D ht_s 97 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: ht_s_b !: <==> the 2D ht_i 98 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: fc_su !: Surface Conduction flux 99 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: fc_bo_i !: Bottom Conduction flux 100 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: dh_s_tot !: Snow accretion/ablation [m] 101 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: dh_i_surf !: Ice surface accretion/ablation [m] 102 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: dh_i_bott !: Ice bottom accretion/ablation [m] 103 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: dh_snowice !: Snow ice formation [m of ice] 104 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: sm_i_b !: Ice bulk salinity [ppt] 105 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: s_i_new !: Salinity of new ice at the bottom 106 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: s_snowice !: Salinity of new snow ice on top of the ice 107 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: o_i_b !: Ice age [days] 103 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: t_su_1d !: <==> the 2D t_su 104 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: a_i_1d !: <==> the 2D a_i 105 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: ht_i_1d !: <==> the 2D ht_s 106 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: ht_s_1d !: <==> the 2D ht_i 107 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: fc_su !: Surface Conduction flux 108 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: fc_bo_i !: Bottom Conduction flux 109 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: dh_s_tot !: Snow accretion/ablation [m] 110 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: dh_i_surf !: Ice surface accretion/ablation [m] 111 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: dh_i_bott !: Ice bottom accretion/ablation [m] 112 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: dh_snowice !: Snow ice formation [m of ice] 113 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: sm_i_1d !: Ice bulk salinity [ppt] 114 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: s_i_new !: Salinity of new ice at the bottom 108 115 109 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: iatte_1d !: clem attenuation coef of the input solar flux (unitless) 110 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: oatte_1d !: clem attenuation coef of the input solar flux (unitless) 116 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: t_s_1d !: corresponding to the 2D var t_s 117 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: t_i_1d !: corresponding to the 2D var t_i 118 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: s_i_1d !: profiled ice salinity 119 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: q_i_1d !: Ice enthalpy per unit volume 120 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: q_s_1d !: Snow enthalpy per unit volume 111 121 112 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: t_s_b !: corresponding to the 2D var t_s 113 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: t_i_b !: corresponding to the 2D var t_i 114 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: s_i_b !: profiled ice salinity 115 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: q_i_b !: Ice enthalpy per unit volume 116 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: q_s_b !: Snow enthalpy per unit volume 122 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: qh_i_old !: ice heat content (q*h, J.m-2) 123 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: h_i_old !: ice thickness layer (m) 117 124 118 ! Clean the following ...119 ! These variables are coded for conservation checks120 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: qt_i_in !: ice energy summed over categories (initial)121 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: qt_i_fin !: ice energy summed over categories (final)122 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: qt_s_in, qt_s_fin !: snow energy summed over categories123 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: dq_i, sum_fluxq !: increment of energy, sum of fluxes124 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fatm, foce !: atmospheric, oceanic, heat flux125 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: cons_error, surf_error !: conservation, surface error126 127 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: q_i_layer_in !: goes to trash128 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: q_i_layer_fin !: goes to trash129 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: dq_i_layer, radab !: goes to trash130 131 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: ftotal_in !: initial total heat flux132 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: ftotal_fin !: final total heat flux133 134 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fc_s135 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fc_i136 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: de_s_lay137 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: de_i_lay138 139 125 INTEGER , PUBLIC :: jiindex_1d ! 1D index of debugging point 140 126 … … 151 137 !!---------------------------------------------------------------------! 152 138 INTEGER :: thd_ice_alloc ! return value 153 INTEGER :: ierr( 4)139 INTEGER :: ierr(3) 154 140 !!---------------------------------------------------------------------! 155 141 156 142 ALLOCATE( npb (jpij) , npac (jpij), & 157 143 ! ! 158 & qldif_1d (jpij) , qcmif_1d (jpij) , fstbif_1d (jpij) , & 159 & fltbif_1d(jpij) , fscbq_1d (jpij) , qsr_ice_1d (jpij) , & 160 & fr1_i0_1d(jpij) , fr2_i0_1d(jpij) , qnsr_ice_1d(jpij) , & 161 & qfvbq_1d (jpij) , t_bo_b (jpij) , iatte_1d (jpij) , & 162 & oatte_1d (jpij) , STAT=ierr(1) ) 144 & qlead_1d (jpij) , ftr_ice_1d (jpij) , & 145 & qsr_ice_1d (jpij) , & 146 & fr1_i0_1d(jpij) , fr2_i0_1d(jpij) , qns_ice_1d(jpij) , & 147 & t_bo_1d (jpij) , & 148 & hfx_sum_1d(jpij) , hfx_bom_1d(jpij) ,hfx_bog_1d(jpij) , & 149 & hfx_dif_1d(jpij) ,hfx_opw_1d(jpij) , & 150 & hfx_thd_1d(jpij) , hfx_spr_1d(jpij) , & 151 & hfx_snw_1d(jpij) , hfx_sub_1d(jpij) , hfx_err_1d(jpij) , & 152 & hfx_res_1d(jpij) , hfx_err_rem_1d(jpij), STAT=ierr(1) ) 163 153 ! 164 ALLOCATE( sprecip_1d (jpij) , frld_1d (jpij) , at_i_ b(jpij) , &165 & f bif_1d (jpij) , rdm_ice_1d (jpij) , rdm_snw_1d (jpij) , &166 & qlbbq_1d (jpij) , dmgwi_1d (jpij) , dvsbq_1d (jpij) ,&167 & dvbbq_1d (jpij) , dvlbq_1d (jpij) , dvnbq_1d (jpij) ,&154 ALLOCATE( sprecip_1d (jpij) , frld_1d (jpij) , at_i_1d (jpij) , & 155 & fhtur_1d (jpij) , wfx_snw_1d (jpij) , wfx_spr_1d (jpij) , & 156 & fhld_1d (jpij) , wfx_sub_1d (jpij) , wfx_bog_1d(jpij) , wfx_bom_1d(jpij) , & 157 & wfx_sum_1d(jpij) , wfx_sni_1d (jpij) , wfx_opw_1d (jpij) , wfx_res_1d (jpij) , & 168 158 & dqns_ice_1d(jpij) , qla_ice_1d (jpij) , dqla_ice_1d(jpij) , & 169 & tatm_ice_1d(jpij) , fsup (jpij) , focea (jpij) , & 170 & i0 (jpij) , old_ht_i_b (jpij) , old_ht_s_b (jpij) , & 171 & sfx_bri_1d (jpij) , fhbri_1d (jpij) , sfx_thd_1d (jpij) , & 159 & tatm_ice_1d(jpij) , & 160 & i0 (jpij) , & 161 & sfx_bri_1d (jpij) , sfx_bog_1d (jpij) , sfx_bom_1d (jpij) ,sfx_sum_1d (jpij) , & 162 & sfx_sni_1d (jpij) , sfx_opw_1d (jpij) , sfx_res_1d (jpij) , & 172 163 & dsm_i_fl_1d(jpij) , dsm_i_gd_1d(jpij) , dsm_i_se_1d(jpij) , & 173 & dsm_i_si_1d(jpij) , hicol_ b(jpij) , STAT=ierr(2) )164 & dsm_i_si_1d(jpij) , hicol_1d (jpij) , STAT=ierr(2) ) 174 165 ! 175 ALLOCATE( t_su_ b (jpij) , a_i_b (jpij) , ht_i_b(jpij) , &176 & ht_s_ b(jpij) , fc_su (jpij) , fc_bo_i (jpij) , &166 ALLOCATE( t_su_1d (jpij) , a_i_1d (jpij) , ht_i_1d (jpij) , & 167 & ht_s_1d (jpij) , fc_su (jpij) , fc_bo_i (jpij) , & 177 168 & dh_s_tot (jpij) , dh_i_surf(jpij) , dh_i_bott(jpij) , & 178 & dh_snowice(jpij) , sm_i_b (jpij) , s_i_new (jpij) , & 179 & s_snowice (jpij) , o_i_b (jpij) , & 180 ! ! 181 & t_s_b(jpij,nlay_s), & 182 ! ! 183 & t_i_b(jpij,jkmax), s_i_b(jpij,jkmax) , & 184 & q_i_b(jpij,jkmax), q_s_b(jpij,jkmax) , STAT=ierr(3)) 169 & dh_snowice(jpij) , sm_i_1d (jpij) , s_i_new (jpij) , & 170 & t_s_1d(jpij,nlay_s), & 171 & t_i_1d(jpij,nlay_i+1), s_i_1d(jpij,nlay_i+1) , & 172 & q_i_1d(jpij,nlay_i+1), q_s_1d(jpij,nlay_i+1) , & 173 & qh_i_old(jpij,0:nlay_i+1), h_i_old(jpij,0:nlay_i+1) , STAT=ierr(3)) 185 174 ! 186 ALLOCATE( qt_i_in (jpij,jpl) , qt_i_fin(jpij,jpl) , qt_s_in (jpij,jpl) , &187 & qt_s_fin (jpij,jpl) , dq_i (jpij,jpl) , sum_fluxq (jpij,jpl) , &188 & fatm (jpij,jpl) , foce (jpij,jpl) , cons_error(jpij,jpl) , &189 & surf_error(jpij,jpl) , &190 ! !191 & q_i_layer_in(jpij,jkmax) , q_i_layer_fin(jpij,jkmax) , &192 & dq_i_layer (jpij,jkmax) , radab (jpij,jkmax) , &193 ! !194 & ftotal_in(jpij), ftotal_fin(jpij) , &195 ! !196 & fc_s(jpij,0:nlay_s) , de_s_lay(jpij,nlay_s) , &197 & fc_i(jpij,0:jkmax) , de_i_lay(jpij,jkmax) , STAT=ierr(4) )198 199 175 thd_ice_alloc = MAXVAL( ierr ) 200 176
Note: See TracChangeset
for help on using the changeset viewer.