- Timestamp:
- 2020-12-02T14:55:21+01:00 (4 years ago)
- Location:
- NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3
- Files:
-
- 162 edited
Legend:
- Unmodified
- Added
- Removed
-
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3
- Property svn:externals
-
old new 8 8 9 9 # SETTE 10 ^/utils/CI/sette@13 292sette10 ^/utils/CI/sette@13559 sette
-
- Property svn:externals
-
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/ICE/ice.F90
r12489 r13998 70 70 !! a_ip | - | Ice pond concentration | | 71 71 !! v_ip | - | Ice pond volume per unit area| m | 72 !! v_il | v_il_1d | Ice pond lid volume per area | m | 72 73 !! | 73 74 !!-------------|-------------|---------------------------------|-------| … … 85 86 !! t_su ! t_su_1d | Sea ice surface temperature ! K | 86 87 !! h_ip | h_ip_1d | Ice pond thickness | m | 88 !! h_il | h_il_1d | Ice pond lid thickness | m | 87 89 !! | 88 90 !! notes: the ice model only sees a bulk (i.e., vertically averaged) | … … 112 114 !! hm_ip | - | Mean ice pond depth | m | 113 115 !! vt_ip | - | Total ice pond vol. per unit area| m | 116 !! hm_il | - | Mean ice pond lid depth | m | 117 !! vt_il | - | Total ice pond lid vol. per area | m | 114 118 !!===================================================================== 115 119 … … 137 141 REAL(wp), PUBLIC :: rn_ishlat !: lateral boundary condition for sea-ice 138 142 LOGICAL , PUBLIC :: ln_landfast_L16 !: landfast ice parameterizationfrom lemieux2016 139 REAL(wp), PUBLIC :: rn_ depfra!: fraction of ocean depth that ice must reach to initiate landfast ice140 REAL(wp), PUBLIC :: rn_ icebfr !: maximum bottom stress per unit area of contact (lemieux2016) or per unit volume (home)141 REAL(wp), PUBLIC :: rn_lf relax!: relaxation time scale (s-1) to reach static friction142 REAL(wp), PUBLIC :: rn_ tensile!: isotropic tensile strength143 REAL(wp), PUBLIC :: rn_lf_depfra !: fraction of ocean depth that ice must reach to initiate landfast ice 144 REAL(wp), PUBLIC :: rn_lf_bfr !: maximum bottom stress per unit area of contact (lemieux2016) or per unit volume (home) 145 REAL(wp), PUBLIC :: rn_lf_relax !: relaxation time scale (s-1) to reach static friction 146 REAL(wp), PUBLIC :: rn_lf_tensile !: isotropic tensile strength 143 147 ! 144 148 ! !!** ice-ridging/rafting namelist (namdyn_rdgrft) ** … … 151 155 INTEGER , PUBLIC :: nn_nevp !: number of iterations for subcycling 152 156 REAL(wp), PUBLIC :: rn_relast !: ratio => telast/rDt_ice (1/3 or 1/9 depending on nb of subcycling nevp) 157 INTEGER , PUBLIC :: nn_rhg_chkcvg !: check ice rheology convergence 153 158 ! 154 159 ! !!** ice-advection namelist (namdyn_adv) ** … … 158 163 ! !!** ice-surface boundary conditions namelist (namsbc) ** 159 164 ! -- icethd_dh -- ! 160 REAL(wp), PUBLIC :: rn_blow_s !: coef. for partitioning of snowfall between leads and sea ice 165 REAL(wp), PUBLIC :: rn_snwblow !: coef. for partitioning of snowfall between leads and sea ice 166 ! -- icethd_zdf and icealb -- ! 167 INTEGER , PUBLIC :: nn_snwfra !: calculate the fraction of ice covered by snow 168 ! ! = 0 fraction = 1 (if snow) or 0 (if no snow) 169 ! ! = 1 fraction = 1-exp(-0.2*rhos*hsnw) [MetO formulation] 170 ! ! = 2 fraction = hsnw / (hsnw+0.02) [CICE formulation] 161 171 ! -- icethd -- ! 162 172 REAL(wp), PUBLIC :: rn_cio !: drag coefficient for oceanic stress … … 166 176 ! ! = 1 Average N(cat) fluxes then redistribute over the N(cat) ice using T-ice and albedo sensitivity 167 177 ! ! = 2 Redistribute a single flux over categories 178 ! -- icethd_zdf -- ! 168 179 LOGICAL , PUBLIC :: ln_cndflx !: use conduction flux as surface boundary condition (instead of qsr and qns) 169 180 LOGICAL , PUBLIC :: ln_cndemulate !: emulate conduction flux (if not provided) … … 172 183 INTEGER, PUBLIC, PARAMETER :: np_cnd_ON = 1 !: forcing from conduction flux (SM0L) (compute qcn and qsr_tr via sbcblk.F90 or sbccpl.F90) 173 184 INTEGER, PUBLIC, PARAMETER :: np_cnd_EMU = 2 !: emulate conduction flux via icethd_zdf.F90 (BL99) (1st round compute qcn and qsr_tr, 2nd round use it) 174 185 INTEGER, PUBLIC :: nn_qtrice !: Solar flux transmitted thru the surface scattering layer: 186 ! ! = 0 Grenfell and Maykut 1977 (depends on cloudiness and is 0 when there is snow) 187 ! ! = 1 Lebrun 2019 (equals 0.3 anytime with different melting/dry snw conductivities) 188 ! 175 189 ! !!** ice-vertical diffusion namelist (namthd_zdf) ** 176 190 LOGICAL , PUBLIC :: ln_cndi_U64 !: thermal conductivity: Untersteiner (1964) 177 191 LOGICAL , PUBLIC :: ln_cndi_P07 !: thermal conductivity: Pringle et al (2007) 178 REAL(wp), PUBLIC :: rn_kappa_i !: coef. for the extinction of radiation Grenfell et al. (2006) [1/m]179 192 REAL(wp), PUBLIC :: rn_cnd_s !: thermal conductivity of the snow [W/m/K] 193 REAL(wp), PUBLIC :: rn_kappa_i !: coef. for the extinction of radiation in sea ice, Grenfell et al. (2006) [1/m] 194 REAL(wp), PUBLIC :: rn_kappa_s !: coef. for the extinction of radiation in snw (nn_qtrice=0) [1/m] 195 REAL(wp), PUBLIC :: rn_kappa_smlt !: coef. for the extinction of radiation in melt snw (nn_qtrice=1) [1/m] 196 REAL(wp), PUBLIC :: rn_kappa_sdry !: coef. for the extinction of radiation in dry snw (nn_qtrice=1) [1/m] 197 LOGICAL , PUBLIC :: ln_zdf_chkcvg !: check convergence of heat diffusion scheme 180 198 181 199 ! !!** ice-salinity namelist (namthd_sal) ** … … 190 208 ! !!** ice-ponds namelist (namthd_pnd) 191 209 LOGICAL , PUBLIC :: ln_pnd !: Melt ponds (T) or not (F) 192 LOGICAL , PUBLIC :: ln_pnd_H12 !: Melt ponds scheme from Holland et al 2012 210 LOGICAL , PUBLIC :: ln_pnd_LEV !: Melt ponds scheme from Holland et al (2012), Flocco et al (2007, 2010) 211 REAL(wp), PUBLIC :: rn_apnd_min !: Minimum ice fraction that contributes to melt ponds 212 REAL(wp), PUBLIC :: rn_apnd_max !: Maximum ice fraction that contributes to melt ponds 193 213 LOGICAL , PUBLIC :: ln_pnd_CST !: Melt ponds scheme with constant fraction and depth 194 214 REAL(wp), PUBLIC :: rn_apnd !: prescribed pond fraction (0<rn_apnd<1) 195 215 REAL(wp), PUBLIC :: rn_hpnd !: prescribed pond depth (0<rn_hpnd<1) 216 LOGICAL, PUBLIC :: ln_pnd_lids !: Allow ponds to have frozen lids 196 217 LOGICAL , PUBLIC :: ln_pnd_alb !: melt ponds affect albedo 197 218 … … 218 239 219 240 ! !!** define arrays 220 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: u_oce,v_oce !: surface ocean velocity used in ice dynamics 221 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ht_i_new !: ice collection thickness accreted in leads 222 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: strength !: ice strength 223 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: stress1_i, stress2_i, stress12_i !: 1st, 2nd & diagonal stress tensor element 224 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: delta_i !: ice rheology elta factor (Flato & Hibler 95) [s-1] 225 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: divu_i !: Divergence of the velocity field [s-1] 226 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: shear_i !: Shear of the velocity field [s-1] 227 ! 228 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: t_bo !: Sea-Ice bottom temperature [Kelvin] 229 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: qlead !: heat balance of the lead (or of the open ocean) 230 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: qsb_ice_bot !: net downward heat flux from the ice to the ocean 231 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fhld !: heat flux from the lead used for bottom melting 232 233 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_snw !: mass flux from snow-ocean mass exchange [kg.m-2.s-1] 234 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_snw_sni !: mass flux from snow ice growth component of wfx_snw [kg.m-2.s-1] 235 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_snw_sum !: mass flux from surface melt component of wfx_snw [kg.m-2.s-1] 236 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_pnd !: mass flux from melt pond-ocean mass exchange [kg.m-2.s-1] 237 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_spr !: mass flux from snow precipitation on ice [kg.m-2.s-1] 238 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_sub !: mass flux from sublimation of snow/ice [kg.m-2.s-1] 239 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_snw_sub !: mass flux from snow sublimation [kg.m-2.s-1] 240 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_ice_sub !: mass flux from ice sublimation [kg.m-2.s-1] 241 242 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_snw_dyn !: mass flux from dynamical component of wfx_snw [kg.m-2.s-1] 243 244 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_ice !: mass flux from ice-ocean mass exchange [kg.m-2.s-1] 245 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_sni !: mass flux from snow ice growth component of wfx_ice [kg.m-2.s-1] 246 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_opw !: mass flux from lateral ice growth component of wfx_ice [kg.m-2.s-1] 247 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_bog !: mass flux from bottom ice growth component of wfx_ice [kg.m-2.s-1] 248 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_dyn !: mass flux from dynamical ice growth component of wfx_ice [kg.m-2.s-1] 249 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_bom !: mass flux from bottom melt component of wfx_ice [kg.m-2.s-1] 250 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_sum !: mass flux from surface melt component of wfx_ice [kg.m-2.s-1] 251 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_lam !: mass flux from lateral melt component of wfx_ice [kg.m-2.s-1] 252 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_res !: mass flux from residual component of wfx_ice [kg.m-2.s-1] 253 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_err_sub !: mass flux error after sublimation [kg.m-2.s-1] 254 255 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sfx_bog !: salt flux due to ice bottom growth [pss.kg.m-2.s-1 => g.m-2.s-1] 256 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sfx_bom !: salt flux due to ice bottom melt [pss.kg.m-2.s-1 => g.m-2.s-1] 257 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sfx_lam !: salt flux due to ice lateral melt [pss.kg.m-2.s-1 => g.m-2.s-1] 258 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sfx_sum !: salt flux due to ice surface melt [pss.kg.m-2.s-1 => g.m-2.s-1] 259 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sfx_sni !: salt flux due to snow-ice growth [pss.kg.m-2.s-1 => g.m-2.s-1] 260 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sfx_opw !: salt flux due to growth in open water [pss.kg.m-2.s-1 => g.m-2.s-1] 261 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sfx_bri !: salt flux due to brine rejection [pss.kg.m-2.s-1 => g.m-2.s-1] 262 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sfx_dyn !: salt flux due to porous ridged ice formation [pss.kg.m-2.s-1 => g.m-2.s-1] 263 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sfx_res !: salt flux due to correction on ice thick. (residual) [pss.kg.m-2.s-1 => g.m-2.s-1] 264 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sfx_sub !: salt flux due to ice sublimation [pss.kg.m-2.s-1 => g.m-2.s-1] 265 266 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_bog !: total heat flux causing bottom ice growth [W.m-2] 267 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_bom !: total heat flux causing bottom ice melt [W.m-2] 268 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_sum !: total heat flux causing surface ice melt [W.m-2] 269 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_opw !: total heat flux causing open water ice formation [W.m-2] 270 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_dif !: total heat flux causing Temp change in the ice [W.m-2] 271 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_snw !: heat flux for snow melt [W.m-2] 272 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_err_dif !: heat flux remaining due to change in non-solar flux [W.m-2] 273 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_err_rem !: heat flux error after heat remapping => must be 0 [W.m-2] 274 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: qt_atm_oi !: heat flux at the interface atm-[oce+ice] [W.m-2] 275 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: qt_oce_ai !: heat flux at the interface oce-[atm+ice] [W.m-2] 241 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: u_oce,v_oce !: surface ocean velocity used in ice dynamics 242 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ht_i_new !: ice collection thickness accreted in leads 243 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: strength !: ice strength 244 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: stress1_i, stress2_i, stress12_i !: 1st, 2nd & diagonal stress tensor element 245 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: delta_i !: ice rheology elta factor (Flato & Hibler 95) [s-1] 246 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: divu_i !: Divergence of the velocity field [s-1] 247 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: shear_i !: Shear of the velocity field [s-1] 248 ! 249 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: t_bo !: Sea-Ice bottom temperature [Kelvin] 250 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: qlead !: heat balance of the lead (or of the open ocean) 251 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: qsb_ice_bot !: net downward heat flux from the ice to the ocean 252 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fhld !: heat flux from the lead used for bottom melting 253 254 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_snw !: mass flux from snow-ocean mass exchange [kg.m-2.s-1] 255 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_snw_sni !: mass flux from snow ice growth component of wfx_snw [kg.m-2.s-1] 256 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_snw_sum !: mass flux from surface melt component of wfx_snw [kg.m-2.s-1] 257 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_pnd !: mass flux from melt pond-ocean mass exchange [kg.m-2.s-1] 258 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_spr !: mass flux from snow precipitation on ice [kg.m-2.s-1] 259 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_sub !: mass flux from sublimation of snow/ice [kg.m-2.s-1] 260 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_snw_sub !: mass flux from snow sublimation [kg.m-2.s-1] 261 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_ice_sub !: mass flux from ice sublimation [kg.m-2.s-1] 262 263 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_snw_dyn !: mass flux from dynamical component of wfx_snw [kg.m-2.s-1] 264 265 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_ice !: mass flux from ice-ocean mass exchange [kg.m-2.s-1] 266 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_sni !: mass flux from snow ice growth component of wfx_ice [kg.m-2.s-1] 267 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_opw !: mass flux from lateral ice growth component of wfx_ice [kg.m-2.s-1] 268 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_bog !: mass flux from bottom ice growth component of wfx_ice [kg.m-2.s-1] 269 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_dyn !: mass flux from dynamical ice growth component of wfx_ice [kg.m-2.s-1] 270 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_bom !: mass flux from bottom melt component of wfx_ice [kg.m-2.s-1] 271 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_sum !: mass flux from surface melt component of wfx_ice [kg.m-2.s-1] 272 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_lam !: mass flux from lateral melt component of wfx_ice [kg.m-2.s-1] 273 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_res !: mass flux from residual component of wfx_ice [kg.m-2.s-1] 274 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_err_sub !: mass flux error after sublimation [kg.m-2.s-1] 275 276 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sfx_bog !: salt flux due to ice bottom growth [pss.kg.m-2.s-1 => g.m-2.s-1] 277 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sfx_bom !: salt flux due to ice bottom melt [pss.kg.m-2.s-1 => g.m-2.s-1] 278 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sfx_lam !: salt flux due to ice lateral melt [pss.kg.m-2.s-1 => g.m-2.s-1] 279 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sfx_sum !: salt flux due to ice surface melt [pss.kg.m-2.s-1 => g.m-2.s-1] 280 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sfx_sni !: salt flux due to snow-ice growth [pss.kg.m-2.s-1 => g.m-2.s-1] 281 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sfx_opw !: salt flux due to growth in open water [pss.kg.m-2.s-1 => g.m-2.s-1] 282 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sfx_bri !: salt flux due to brine rejection [pss.kg.m-2.s-1 => g.m-2.s-1] 283 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sfx_dyn !: salt flux due to porous ridged ice formation [pss.kg.m-2.s-1 => g.m-2.s-1] 284 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sfx_res !: salt flux due to correction on ice thick. (residual) [pss.kg.m-2.s-1 => g.m-2.s-1] 285 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sfx_sub !: salt flux due to ice sublimation [pss.kg.m-2.s-1 => g.m-2.s-1] 286 287 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_bog !: total heat flux causing bottom ice growth [W.m-2] 288 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_bom !: total heat flux causing bottom ice melt [W.m-2] 289 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_sum !: total heat flux causing surface ice melt [W.m-2] 290 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_opw !: total heat flux causing open water ice formation [W.m-2] 291 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_dif !: total heat flux causing Temp change in the ice [W.m-2] 292 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_snw !: heat flux for snow melt [W.m-2] 293 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_err_dif !: heat flux remaining due to change in non-solar flux [W.m-2] 294 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: qt_atm_oi !: heat flux at the interface atm-[oce+ice] [W.m-2] 295 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: qt_oce_ai !: heat flux at the interface oce-[atm+ice] [W.m-2] 276 296 277 297 ! heat flux associated with ice-atmosphere mass exchange 278 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_sub!: heat flux for sublimation [W.m-2]279 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_spr!: heat flux of the snow precipitation [W.m-2]298 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_sub !: heat flux for sublimation [W.m-2] 299 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_spr !: heat flux of the snow precipitation [W.m-2] 280 300 281 301 ! heat flux associated with ice-ocean mass exchange 282 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_thd!: ice-ocean heat flux from thermo processes (icethd_dh) [W.m-2]283 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_dyn!: ice-ocean heat flux from ridging [W.m-2]284 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_res!: heat flux due to correction on ice thick. (residual) [W.m-2]285 286 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: rn_amax_2d !: maximum ice concentration 2d array287 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: qtr_ice_bot !: transmitted solar radiation under ice288 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: t1_ice !: temperature of the first layer(ln_cndflx=T) [K]289 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: cnd_ice !: effective conductivity at the top of ice/snow(ln_cndflx=T) [W.m-2.K-1]302 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_thd !: ice-ocean heat flux from thermo processes (icethd_dh) [W.m-2] 303 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_dyn !: ice-ocean heat flux from ridging [W.m-2] 304 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_res !: heat flux due to correction on ice thick. (residual) [W.m-2] 305 306 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: rn_amax_2d !: maximum ice concentration 2d array 307 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: qtr_ice_bot !: transmitted solar radiation under ice 308 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: t1_ice !: temperature of the first layer (ln_cndflx=T) [K] 309 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: cnd_ice !: effective conductivity of the 1st layer (ln_cndflx=T) [W.m-2.K-1] 290 310 291 311 !!---------------------------------------------------------------------- … … 293 313 !!---------------------------------------------------------------------- 294 314 !! Variables defined for each ice category 295 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: h_i!: Ice thickness (m)296 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: a_i!: Ice fractional areas (concentration)297 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: v_i!: Ice volume per unit area (m)298 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: v_s!: Snow volume per unit area (m)299 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: h_s!: Snow thickness (m)300 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: t_su!: Sea-Ice Surface Temperature (K)301 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: s_i!: Sea-Ice Bulk salinity (pss)302 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: sv_i!: Sea-Ice Bulk salinity * volume per area (pss.m)303 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: o_i!: Sea-Ice Age (s)304 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: oa_i!: Sea-Ice Age times ice area (s)305 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: bv_i!: brine volume315 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: h_i !: Ice thickness (m) 316 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: a_i !: Ice fractional areas (concentration) 317 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: v_i !: Ice volume per unit area (m) 318 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: v_s !: Snow volume per unit area (m) 319 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: h_s !: Snow thickness (m) 320 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: t_su !: Sea-Ice Surface Temperature (K) 321 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: s_i !: Sea-Ice Bulk salinity (pss) 322 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: sv_i !: Sea-Ice Bulk salinity * volume per area (pss.m) 323 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: o_i !: Sea-Ice Age (s) 324 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: oa_i !: Sea-Ice Age times ice area (s) 325 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: bv_i !: brine volume 306 326 307 327 !! Variables summed over all categories, or associated to all the ice in a single grid cell 308 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: u_ice, v_ice !: components of the ice velocity (m/s) 309 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: vt_i , vt_s !: ice and snow total volume per unit area (m) 310 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: st_i !: Total ice salinity content (pss.m) 311 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: at_i !: ice total fractional area (ice concentration) 312 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ato_i !: =1-at_i ; total open water fractional area 313 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: et_i , et_s !: ice and snow total heat content (J/m2) 314 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tm_i !: mean ice temperature over all categories (K) 315 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tm_s !: mean snw temperature over all categories (K) 316 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: bvm_i !: brine volume averaged over all categories 317 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sm_i !: mean sea ice salinity averaged over all categories (pss) 318 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tm_su !: mean surface temperature over all categories (K) 319 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hm_i !: mean ice thickness over all categories (m) 320 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hm_s !: mean snow thickness over all categories (m) 321 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: om_i !: mean ice age over all categories (s) 322 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tau_icebfr !: ice friction on ocean bottom (landfast param activated) 323 324 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: t_s !: Snow temperatures [K] 325 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: e_s !: Snow enthalpy [J/m2] 326 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: t_i !: ice temperatures [K] 327 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: e_i !: ice enthalpy [J/m2] 328 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: sz_i !: ice salinity [PSS] 329 330 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: a_ip !: melt pond concentration 331 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: v_ip !: melt pond volume per grid cell area [m] 332 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: a_ip_frac !: melt pond fraction (a_ip/a_i) 333 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: h_ip !: melt pond depth [m] 334 335 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: at_ip !: total melt pond concentration 336 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hm_ip !: mean melt pond depth [m] 337 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: vt_ip !: total melt pond volume per gridcell area [m] 338 339 !!---------------------------------------------------------------------- 340 !! * Old values of global variables 341 !!---------------------------------------------------------------------- 342 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: v_s_b, v_i_b, h_s_b, h_i_b, h_ip_b !: snow and ice volumes/thickness 343 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: a_i_b, sv_i_b, oa_i_b !: 344 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: e_s_b !: snow heat content 345 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: e_i_b !: ice temperatures 346 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: u_ice_b, v_ice_b !: ice velocity 347 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: at_i_b !: ice concentration (total) 328 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: u_ice, v_ice !: components of the ice velocity (m/s) 329 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: vt_i , vt_s !: ice and snow total volume per unit area (m) 330 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: st_i !: Total ice salinity content (pss.m) 331 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: at_i !: ice total fractional area (ice concentration) 332 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ato_i !: =1-at_i ; total open water fractional area 333 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: et_i , et_s !: ice and snow total heat content (J/m2) 334 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tm_i !: mean ice temperature over all categories (K) 335 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tm_s !: mean snw temperature over all categories (K) 336 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: bvm_i !: brine volume averaged over all categories 337 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sm_i !: mean sea ice salinity averaged over all categories (pss) 338 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tm_su !: mean surface temperature over all categories (K) 339 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hm_i !: mean ice thickness over all categories (m) 340 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hm_s !: mean snow thickness over all categories (m) 341 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: om_i !: mean ice age over all categories (s) 342 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tau_icebfr !: ice friction on ocean bottom (landfast param activated) 343 344 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: t_s !: Snow temperatures [K] 345 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: e_s !: Snow enthalpy [J/m2] 346 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: t_i !: ice temperatures [K] 347 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: e_i !: ice enthalpy [J/m2] 348 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: sz_i !: ice salinity [PSS] 349 350 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: a_ip !: melt pond concentration 351 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: v_ip !: melt pond volume per grid cell area [m] 352 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: a_ip_frac !: melt pond fraction (a_ip/a_i) 353 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: a_ip_eff !: melt pond effective fraction (not covered up by lid) (a_ip/a_i) 354 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: h_ip !: melt pond depth [m] 355 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: v_il !: melt pond lid volume [m] 356 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: h_il !: melt pond lid thickness [m] 357 358 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: at_ip !: total melt pond concentration 359 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hm_ip !: mean melt pond depth [m] 360 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: vt_ip !: total melt pond volume per gridcell area [m] 361 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hm_il !: mean melt pond lid depth [m] 362 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: vt_il !: total melt pond lid volume per gridcell area [m] 363 364 !!---------------------------------------------------------------------- 365 !! * Global variables at before time step 366 !!---------------------------------------------------------------------- 367 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: v_s_b, v_i_b, h_s_b, h_i_b !: snow and ice volumes/thickness 368 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: a_i_b, sv_i_b !: 369 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: e_s_b !: snow heat content 370 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: e_i_b !: ice temperatures 371 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: u_ice_b, v_ice_b !: ice velocity 372 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: at_i_b !: ice concentration (total) 348 373 349 374 !!---------------------------------------------------------------------- 350 375 !! * Ice thickness distribution variables 351 376 !!---------------------------------------------------------------------- 352 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: hi_max!: Boundary of ice thickness categories in thickness space353 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: hi_mean!: Mean ice thickness in catgories377 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: hi_max !: Boundary of ice thickness categories in thickness space 378 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: hi_mean !: Mean ice thickness in catgories 354 379 ! 355 380 !!---------------------------------------------------------------------- 356 381 !! * Ice diagnostics 357 382 !!---------------------------------------------------------------------- 358 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_trp_vi !: transport of ice volume 359 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_trp_vs !: transport of snw volume 360 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_trp_ei !: transport of ice enthalpy [W/m2] 361 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_trp_es !: transport of snw enthalpy [W/m2] 362 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_trp_sv !: transport of salt content 363 ! 364 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_heat !: snw/ice heat content variation [W/m2] 365 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_sice !: ice salt content variation [] 366 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_vice !: ice volume variation [m/s] 367 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_vsnw !: snw volume variation [m/s] 368 383 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_trp_vi !: transport of ice volume 384 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_trp_vs !: transport of snw volume 385 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_trp_ei !: transport of ice enthalpy [W/m2] 386 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_trp_es !: transport of snw enthalpy [W/m2] 387 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_trp_sv !: transport of salt content 388 ! 389 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_heat !: snw/ice heat content variation [W/m2] 390 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_sice !: ice salt content variation [] 391 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_vice !: ice volume variation [m/s] 392 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_vsnw !: snw volume variation [m/s] 393 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_aice !: ice conc. variation [s-1] 394 ! 395 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_adv_mass !: advection of mass (kg/m2/s) 396 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_adv_salt !: advection of salt (g/m2/s) 397 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_adv_heat !: advection of heat (W/m2) 398 ! 369 399 !!---------------------------------------------------------------------- 370 400 !! * Ice conservation 371 401 !!---------------------------------------------------------------------- 372 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_v !: conservation of ice volume373 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_s !: conservation of ice salt374 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_t !: conservation of ice heat375 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_fv !: conservation of ice volume376 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_fs !: conservation of ice salt377 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_ft !: conservation of ice heat402 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_v !: conservation of ice volume 403 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_s !: conservation of ice salt 404 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_t !: conservation of ice heat 405 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_fv !: conservation of ice volume 406 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_fs !: conservation of ice salt 407 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_ft !: conservation of ice heat 378 408 ! 379 409 !!---------------------------------------------------------------------- … … 381 411 !!---------------------------------------------------------------------- 382 412 ! Extra sea ice diagnostics to address the data request 383 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: t_si !: Temperature at Snow-ice interface (K) 384 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tm_si !: mean temperature at the snow-ice interface (K) 385 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: qcn_ice_bot !: Bottom conduction flux (W/m2) 386 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: qcn_ice_top !: Surface conduction flux (W/m2) 387 413 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: t_si !: Temperature at Snow-ice interface (K) 414 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tm_si !: mean temperature at the snow-ice interface (K) 415 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: qcn_ice_bot !: Bottom conduction flux (W/m2) 416 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: qcn_ice_top !: Surface conduction flux (W/m2) 388 417 ! 389 418 !!---------------------------------------------------------------------- … … 424 453 & hfx_sum (jpi,jpj) , hfx_bom (jpi,jpj) , hfx_bog(jpi,jpj) , hfx_dif(jpi,jpj) , & 425 454 & hfx_opw (jpi,jpj) , hfx_thd (jpi,jpj) , hfx_dyn(jpi,jpj) , hfx_spr(jpi,jpj) , & 426 & hfx_err_dif(jpi,jpj) , hfx_err_rem(jpi,jpj) , wfx_err_sub(jpi,jpj) ,STAT=ierr(ii) )455 & hfx_err_dif(jpi,jpj) , wfx_err_sub(jpi,jpj) , STAT=ierr(ii) ) 427 456 428 457 ! * Ice global state variables … … 448 477 449 478 ii = ii + 1 450 ALLOCATE( a_ip(jpi,jpj,jpl) , v_ip(jpi,jpj,jpl) , a_ip_frac(jpi,jpj,jpl) , h_ip(jpi,jpj,jpl) , STAT = ierr(ii) ) 451 452 ii = ii + 1 453 ALLOCATE( at_ip(jpi,jpj) , hm_ip(jpi,jpj) , vt_ip(jpi,jpj) , STAT = ierr(ii) ) 479 ALLOCATE( a_ip(jpi,jpj,jpl) , v_ip(jpi,jpj,jpl) , a_ip_frac(jpi,jpj,jpl) , h_ip(jpi,jpj,jpl), & 480 & v_il(jpi,jpj,jpl) , h_il(jpi,jpj,jpl) , a_ip_eff (jpi,jpj,jpl) , STAT = ierr(ii) ) 481 482 ii = ii + 1 483 ALLOCATE( at_ip(jpi,jpj) , hm_ip(jpi,jpj) , vt_ip(jpi,jpj) , hm_il(jpi,jpj) , vt_il(jpi,jpj) , STAT = ierr(ii) ) 454 484 455 485 ! * Old values of global variables 456 486 ii = ii + 1 457 ALLOCATE( v_s_b (jpi,jpj,jpl) , v_i_b (jpi,jpj,jpl) , h_s_b(jpi,jpj,jpl) , h_i_b(jpi,jpj,jpl), h_ip_b(jpi,jpj,jpl),&458 & a_i_b (jpi,jpj,jpl) , sv_i_b(jpi,jpj,jpl) , e_i_b(jpi,jpj,nlay_i,jpl) , e_s_b(jpi,jpj,nlay_s,jpl) , 459 & oa_i_b(jpi,jpj,jpl) ,STAT=ierr(ii) )487 ALLOCATE( v_s_b (jpi,jpj,jpl) , v_i_b (jpi,jpj,jpl) , h_s_b(jpi,jpj,jpl) , h_i_b(jpi,jpj,jpl), & 488 & a_i_b (jpi,jpj,jpl) , sv_i_b(jpi,jpj,jpl) , e_i_b(jpi,jpj,nlay_i,jpl) , e_s_b(jpi,jpj,nlay_s,jpl) , & 489 & STAT=ierr(ii) ) 460 490 461 491 ii = ii + 1 … … 468 498 ! * Ice diagnostics 469 499 ii = ii + 1 470 ALLOCATE( diag_trp_vi(jpi,jpj) , diag_trp_vs (jpi,jpj) , diag_trp_ei(jpi,jpj), & 471 & diag_trp_es(jpi,jpj) , diag_trp_sv (jpi,jpj) , diag_heat (jpi,jpj), & 472 & diag_sice (jpi,jpj) , diag_vice (jpi,jpj) , diag_vsnw (jpi,jpj), STAT=ierr(ii) ) 500 ALLOCATE( diag_trp_vi(jpi,jpj) , diag_trp_vs (jpi,jpj) , diag_trp_ei(jpi,jpj), & 501 & diag_trp_es(jpi,jpj) , diag_trp_sv (jpi,jpj) , diag_heat (jpi,jpj), & 502 & diag_sice (jpi,jpj) , diag_vice (jpi,jpj) , diag_vsnw (jpi,jpj), diag_aice(jpi,jpj), & 503 & diag_adv_mass(jpi,jpj), diag_adv_salt(jpi,jpj), diag_adv_heat(jpi,jpj), STAT=ierr(ii) ) 473 504 474 505 ! * Ice conservation … … 484 515 IF( ice_alloc /= 0 ) CALL ctl_stop( 'STOP', 'ice_alloc: failed to allocate arrays.' ) 485 516 ! 517 486 518 END FUNCTION ice_alloc 487 519 -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/ICE/ice1d.F90
r10786 r13998 51 51 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: hfx_snw_1d 52 52 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: hfx_dyn_1d 53 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: hfx_err_rem_1d54 53 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: hfx_err_dif_1d 55 54 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: qt_oce_ai_1d … … 124 123 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: oa_i_1d !: 125 124 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: o_i_1d !: 126 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: a_ip_1d !: 125 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: a_ip_1d !: ice ponds 127 126 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: v_ip_1d !: 128 127 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: h_ip_1d !: 129 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: a_ip_frac_1d !: 128 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: v_il_1d !: Ice pond lid 129 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: h_il_1d !: 130 130 131 131 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: t_s_1d !: corresponding to the 2D var t_s … … 145 145 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: sst_1d 146 146 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: sss_1d 147 147 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: frq_m_1d 148 149 ! convergence check 150 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: tice_cvgerr_1d !: convergence of ice/snow temp (dT) [K] 151 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: tice_cvgstp_1d !: convergence of ice/snow temp (subtimestep) [-] 148 152 ! 149 153 !!---------------------- … … 157 161 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: a_ip_2d 158 162 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: v_ip_2d 163 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: v_il_2d 159 164 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: t_su_2d 160 165 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: h_i_2d … … 175 180 !!---------------------------------------------------------------------! 176 181 INTEGER :: ice1D_alloc ! return value 177 INTEGER :: ierr( 7), ii182 INTEGER :: ierr(8), ii 178 183 !!---------------------------------------------------------------------! 179 184 ierr(:) = 0 … … 189 194 & hfx_thd_1d(jpij) , hfx_spr_1d (jpij) , & 190 195 & hfx_snw_1d(jpij) , hfx_sub_1d (jpij) , & 191 & hfx_res_1d(jpij) , hfx_err_ rem_1d(jpij) , hfx_err_dif_1d(jpij) , qt_oce_ai_1d(jpij), STAT=ierr(ii) )196 & hfx_res_1d(jpij) , hfx_err_dif_1d(jpij) , qt_oce_ai_1d(jpij), STAT=ierr(ii) ) 192 197 ! 193 198 ii = ii + 1 … … 208 213 & dh_s_tot(jpij) , dh_i_sum(jpij) , dh_i_itm (jpij) , dh_i_bom(jpij) , dh_i_bog(jpij) , & 209 214 & dh_i_sub(jpij) , dh_s_mlt(jpij) , dh_snowice(jpij) , s_i_1d (jpij) , s_i_new (jpij) , & 210 & a_ip_1d (jpij) , v_ip_1d (jpij) , v_i_1d (jpij) , v_s_1d (jpij) , 211 & h_i p_1d (jpij) , a_ip_frac_1d(jpij) ,&215 & a_ip_1d (jpij) , v_ip_1d (jpij) , v_i_1d (jpij) , v_s_1d (jpij) , v_il_1d (jpij) , & 216 & h_il_1d (jpij) , h_ip_1d (jpij) , & 212 217 & sv_i_1d (jpij) , oa_i_1d (jpij) , o_i_1d (jpij) , STAT=ierr(ii) ) 213 218 ! … … 221 226 ! 222 227 ii = ii + 1 223 ALLOCATE( sst_1d(jpij) , sss_1d(jpij) , STAT=ierr(ii) ) 228 ALLOCATE( sst_1d(jpij) , sss_1d(jpij) , frq_m_1d(jpij) , STAT=ierr(ii) ) 229 ! 230 ii = ii + 1 231 ALLOCATE( tice_cvgerr_1d(jpij) , tice_cvgstp_1d(jpij) , STAT=ierr(ii) ) 224 232 ! 225 233 ii = ii + 1 226 234 ALLOCATE( a_i_2d (jpij,jpl) , a_ib_2d(jpij,jpl) , h_i_2d (jpij,jpl) , h_ib_2d(jpij,jpl) , & 227 235 & v_i_2d (jpij,jpl) , v_s_2d (jpij,jpl) , oa_i_2d(jpij,jpl) , sv_i_2d(jpij,jpl) , & 228 & a_ip_2d(jpij,jpl) , v_ip_2d(jpij,jpl) , t_su_2d(jpij,jpl) , 236 & a_ip_2d(jpij,jpl) , v_ip_2d(jpij,jpl) , t_su_2d(jpij,jpl) , v_il_2d(jpij,jpl) , & 229 237 & STAT=ierr(ii) ) 230 238 -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/ICE/icealb.F90
r13295 r13998 14 14 !! ice_alb_init : initialisation of albedo computation 15 15 !!---------------------------------------------------------------------- 16 USE ice, ONLY: jpl ! sea-ice: number of categories17 16 USE phycst ! physical constants 18 17 USE dom_oce ! domain: ocean 18 USE ice, ONLY: jpl ! sea-ice: number of categories 19 USE icevar ! sea-ice: operations 19 20 ! 20 21 USE in_out_manager ! I/O manager … … 47 48 CONTAINS 48 49 49 SUBROUTINE ice_alb( pt_su, ph_ice, ph_snw, ld_pnd_alb, pafrac_pnd, ph_pnd, p alb_cs, palb_os)50 SUBROUTINE ice_alb( pt_su, ph_ice, ph_snw, ld_pnd_alb, pafrac_pnd, ph_pnd, pcloud_fra, palb_ice ) 50 51 !!---------------------------------------------------------------------- 51 52 !! *** ROUTINE ice_alb *** … … 99 100 REAL(wp), INTENT(in ), DIMENSION(:,:,:) :: pafrac_pnd ! melt pond relative fraction (per unit ice area) 100 101 REAL(wp), INTENT(in ), DIMENSION(:,:,:) :: ph_pnd ! melt pond depth 101 REAL(wp), INTENT( out), DIMENSION(:,:,:) :: palb_cs ! albedo of ice under clear sky 102 REAL(wp), INTENT( out), DIMENSION(:,:,:) :: palb_os ! albedo of ice under overcast sky 103 ! 102 REAL(wp), INTENT(in ), DIMENSION(:,:) :: pcloud_fra ! cloud fraction 103 REAL(wp), INTENT( out), DIMENSION(:,:,:) :: palb_ice ! albedo of ice 104 ! 105 REAL(wp), DIMENSION(jpi,jpj,jpl) :: za_s_fra ! ice fraction covered by snow 104 106 INTEGER :: ji, jj, jl ! dummy loop indices 105 107 REAL(wp) :: z1_c1, z1_c2,z1_c3, z1_c4 ! local scalar … … 108 110 REAL(wp) :: zalb_ice, zafrac_ice ! bare sea ice albedo & relative ice fraction 109 111 REAL(wp) :: zalb_snw, zafrac_snw ! snow-covered sea ice albedo & relative snow fraction 112 REAL(wp) :: zalb_cs, zalb_os ! albedo of ice under clear/overcast sky 110 113 !!--------------------------------------------------------------------- 111 114 ! … … 118 121 z1_c4 = 1. / 0.03 119 122 ! 123 CALL ice_var_snwfra( ph_snw, za_s_fra ) ! calculate ice fraction covered by snow 124 ! 120 125 DO jl = 1, jpl 121 126 DO_2D( 1, 1, 1, 1 ) 122 ! !--- Specific snow, ice and pond fractions (for now, we prevent melt ponds and snow at the same time) 123 IF( ph_snw(ji,jj,jl) == 0._wp ) THEN 124 zafrac_snw = 0._wp 125 IF( ld_pnd_alb ) THEN 126 zafrac_pnd = pafrac_pnd(ji,jj,jl) 127 ELSE 128 zafrac_pnd = 0._wp 129 ENDIF 130 zafrac_ice = 1._wp - zafrac_pnd 127 ! 128 !---------------------------------------------! 129 !--- Specific snow, ice and pond fractions ---! 130 !---------------------------------------------! 131 zafrac_snw = za_s_fra(ji,jj,jl) 132 IF( ld_pnd_alb ) THEN 133 zafrac_pnd = MIN( pafrac_pnd(ji,jj,jl), 1._wp - zafrac_snw ) ! make sure (a_ip_eff + a_s_fra) <= 1 131 134 ELSE 132 zafrac_snw = 1._wp ! Snow fully "shades" melt ponds and ice133 135 zafrac_pnd = 0._wp 134 zafrac_ice = 0._wp 135 ENDIF 136 ! 136 ENDIF 137 zafrac_ice = MAX( 0._wp, 1._wp - zafrac_pnd - zafrac_snw ) ! max for roundoff errors 138 ! 139 !---------------! 140 !--- Albedos ---! 141 !---------------! 137 142 ! !--- Bare ice albedo (for hi > 150cm) 138 143 IF( ld_pnd_alb ) THEN 139 144 zalb_ice = rn_alb_idry 140 145 ELSE 141 IF( ph_snw(ji,jj,jl) == 0._wp .AND. pt_su(ji,jj,jl) >= rt0 ) THEN ; zalb_ice = rn_alb_imlt142 ELSE ; zalb_ice = rn_alb_idry ; ENDIF146 IF( ph_snw(ji,jj,jl) == 0._wp .AND. pt_su(ji,jj,jl) >= rt0 ) THEN ; zalb_ice = rn_alb_imlt 147 ELSE ; zalb_ice = rn_alb_idry ; ENDIF 143 148 ENDIF 144 149 ! !--- Bare ice albedo (for hi < 150cm) … … 156 161 ENDIF 157 162 ! !--- Ponded ice albedo 158 IF( ld_pnd_alb ) THEN 159 zalb_pnd = rn_alb_dpnd - ( rn_alb_dpnd - zalb_ice ) * EXP( - ph_pnd(ji,jj,jl) * z1_href_pnd ) 160 ELSE 161 zalb_pnd = rn_alb_dpnd 162 ENDIF 163 zalb_pnd = rn_alb_dpnd - ( rn_alb_dpnd - zalb_ice ) * EXP( - ph_pnd(ji,jj,jl) * z1_href_pnd ) 164 ! 163 165 ! !--- Surface albedo is weighted mean of snow, ponds and bare ice contributions 164 palb_os(ji,jj,jl) = ( zafrac_snw * zalb_snw + zafrac_pnd * zalb_pnd + zafrac_ice * zalb_ice ) * tmask(ji,jj,1) 165 ! 166 palb_cs(ji,jj,jl) = palb_os(ji,jj,jl) & 167 & - ( - 0.1010 * palb_os(ji,jj,jl) * palb_os(ji,jj,jl) & 168 & + 0.1933 * palb_os(ji,jj,jl) - 0.0148 ) * tmask(ji,jj,1) 169 ! 166 zalb_os = ( zafrac_snw * zalb_snw + zafrac_pnd * zalb_pnd + zafrac_ice * zalb_ice ) * tmask(ji,jj,1) 167 ! 168 zalb_cs = zalb_os - ( - 0.1010 * zalb_os * zalb_os & 169 & + 0.1933 * zalb_os - 0.0148 ) * tmask(ji,jj,1) 170 ! 171 ! albedo depends on cloud fraction because of non-linear spectral effects 172 palb_ice(ji,jj,jl) = ( 1._wp - pcloud_fra(ji,jj) ) * zalb_cs + pcloud_fra(ji,jj) * zalb_os 173 170 174 END_2D 171 175 END DO -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/ICE/icecor.F90
r13295 r13998 55 55 INTEGER :: ji, jj, jk, jl ! dummy loop indices 56 56 REAL(wp) :: zsal, zzc 57 REAL(wp), DIMENSION(jpi,jpj) :: zafx ! concentration trends diag58 57 !!---------------------------------------------------------------------- 59 58 ! controls … … 81 80 DO jl = 1, jpl 82 81 WHERE( at_i(:,:) > rn_amax_2d(:,:) ) a_i(:,:,jl) = a_i(:,:,jl) * rn_amax_2d(:,:) / at_i(:,:) 83 END DO 84 82 END DO 83 ! !----------------------------------------------------- 84 ! ! Rebin categories with thickness out of bounds ! 85 ! !----------------------------------------------------- 86 IF ( jpl > 1 ) CALL ice_itd_reb( kt ) 87 ! 85 88 ! !----------------------------------------------------- 86 89 IF ( nn_icesal == 2 ) THEN ! salinity must stay in bounds [Simin,Simax] ! … … 91 94 zsal = sv_i(ji,jj,jl) 92 95 sv_i(ji,jj,jl) = MIN( MAX( rn_simin*v_i(ji,jj,jl) , sv_i(ji,jj,jl) ) , rn_simax*v_i(ji,jj,jl) ) 93 sfx_res(ji,jj) = sfx_res(ji,jj) - ( sv_i(ji,jj,jl) - zsal ) * zzc ! associated salt flux 96 IF( kn /= 0 ) & ! no ice-ocean exchanges if kn=0 (for bdy for instance) otherwise conservation diags will fail 97 & sfx_res(ji,jj) = sfx_res(ji,jj) - ( sv_i(ji,jj,jl) - zsal ) * zzc ! associated salt flux 94 98 END_2D 95 99 END DO 96 100 ENDIF 97 ! !-----------------------------------------------------98 ! ! Rebin categories with thickness out of bounds !99 ! !-----------------------------------------------------100 IF ( jpl > 1 ) CALL ice_itd_reb( kt )101 101 102 ! !----------------------------------------------------- 103 CALL ice_var_zapsmall ! Zap small values ! 104 ! !----------------------------------------------------- 105 102 IF( kn /= 0 ) THEN ! no zapsmall if kn=0 (for bdy for instance) because we do not want ice-ocean exchanges (wfx,sfx,hfx) 103 ! otherwise conservation diags will fail 104 ! !----------------------------------------------------- 105 CALL ice_var_zapsmall ! Zap small values ! 106 ! !----------------------------------------------------- 107 ENDIF 106 108 ! !----------------------------------------------------- 107 109 IF( kn == 2 ) THEN ! Ice drift case: Corrections to avoid wrong values ! 108 DO_2D( 0, 0, 0, 0 ) 110 DO_2D( 0, 0, 0, 0 ) !----------------------------------------------------- 109 111 IF ( at_i(ji,jj) == 0._wp ) THEN ! what to do if there is no ice 110 112 IF ( at_i(ji+1,jj) == 0._wp ) u_ice(ji ,jj) = 0._wp ! right side … … 116 118 CALL lbc_lnk_multi( 'icecor', u_ice, 'U', -1.0_wp, v_ice, 'V', -1.0_wp ) 117 119 ENDIF 118 119 ! !-----------------------------------------------------120 SELECT CASE( kn ) ! Diagnostics !121 ! !-----------------------------------------------------122 CASE( 1 ) !--- dyn trend diagnostics123 !124 IF( ln_icediachk .OR. iom_use('hfxdhc') ) THEN125 diag_heat(:,:) = - SUM(SUM( e_i (:,:,1:nlay_i,:) - e_i_b (:,:,1:nlay_i,:), dim=4 ), dim=3 ) * r1_Dt_ice & ! W.m-2126 & - SUM(SUM( e_s (:,:,1:nlay_s,:) - e_s_b (:,:,1:nlay_s,:), dim=4 ), dim=3 ) * r1_Dt_ice127 diag_sice(:,:) = SUM( sv_i(:,:,:) - sv_i_b(:,:,:) , dim=3 ) * r1_Dt_ice * rhoi128 diag_vice(:,:) = SUM( v_i (:,:,:) - v_i_b (:,:,:) , dim=3 ) * r1_Dt_ice * rhoi129 diag_vsnw(:,:) = SUM( v_s (:,:,:) - v_s_b (:,:,:) , dim=3 ) * r1_Dt_ice * rhos130 ENDIF131 ! ! concentration tendency (dynamics)132 IF( iom_use('afxdyn') .OR. iom_use('afxthd') .OR. iom_use('afxtot') ) THEN133 zafx(:,:) = SUM( a_i(:,:,:) - a_i_b(:,:,:), dim=3 ) * r1_Dt_ice134 CALL iom_put( 'afxdyn' , zafx )135 ENDIF136 !137 CASE( 2 ) !--- thermo trend diagnostics & ice aging138 !139 oa_i(:,:,:) = oa_i(:,:,:) + a_i(:,:,:) * rDt_ice ! ice natural aging incrementation140 !141 IF( ln_icediachk .OR. iom_use('hfxdhc') ) THEN142 diag_heat(:,:) = diag_heat(:,:) &143 & - SUM(SUM( e_i (:,:,1:nlay_i,:) - e_i_b (:,:,1:nlay_i,:), dim=4 ), dim=3 ) * r1_Dt_ice &144 & - SUM(SUM( e_s (:,:,1:nlay_s,:) - e_s_b (:,:,1:nlay_s,:), dim=4 ), dim=3 ) * r1_Dt_ice145 diag_sice(:,:) = diag_sice(:,:) &146 & + SUM( sv_i(:,:,:) - sv_i_b(:,:,:) , dim=3 ) * r1_Dt_ice * rhoi147 diag_vice(:,:) = diag_vice(:,:) &148 & + SUM( v_i (:,:,:) - v_i_b (:,:,:) , dim=3 ) * r1_Dt_ice * rhoi149 diag_vsnw(:,:) = diag_vsnw(:,:) &150 & + SUM( v_s (:,:,:) - v_s_b (:,:,:) , dim=3 ) * r1_Dt_ice * rhos151 CALL iom_put ( 'hfxdhc' , diag_heat )152 ENDIF153 ! ! concentration tendency (total + thermo)154 IF( iom_use('afxdyn') .OR. iom_use('afxthd') .OR. iom_use('afxtot') ) THEN155 zafx(:,:) = zafx(:,:) + SUM( a_i(:,:,:) - a_i_b(:,:,:), dim=3 ) * r1_Dt_ice156 CALL iom_put( 'afxthd' , SUM( a_i(:,:,:) - a_i_b(:,:,:), dim=3 ) * r1_Dt_ice )157 CALL iom_put( 'afxtot' , zafx )158 ENDIF159 !160 END SELECT161 120 ! 162 121 ! controls -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/ICE/icectl.F90
r13295 r13998 43 43 PUBLIC ice_prt 44 44 PUBLIC ice_prt3D 45 PUBLIC ice_drift_wri 46 PUBLIC ice_drift_init 45 47 46 48 ! thresold rates for conservation … … 49 51 REAL(wp), PARAMETER :: zchk_s = 2.5e-6 ! g/m2/s <=> 1e-6 m of ice per hour spuriously gained/lost (considering s=10g/kg) 50 52 REAL(wp), PARAMETER :: zchk_t = 7.5e-2 ! W/m2 <=> 1e-6 m of ice per hour spuriously gained/lost (considering Lf=3e5J/kg) 53 54 ! for drift outputs 55 CHARACTER(LEN=50) :: clname="icedrift_diagnostics.ascii" ! ascii filename 56 INTEGER :: numicedrift ! outfile unit 57 REAL(wp) :: rdiag_icemass, rdiag_icesalt, rdiag_iceheat 58 REAL(wp) :: rdiag_adv_icemass, rdiag_adv_icesalt, rdiag_adv_iceheat 51 59 52 60 !! * Substitutions … … 132 140 133 141 ! -- advection scheme is conservative? -- ! 134 zvtrp = glob_sum( 'icectl', ( diag_trp_vi * rhoi + diag_trp_vs * rhos ) * e1e2t ) ! must be close to 0 (only for Prather)135 zetrp = glob_sum( 'icectl', ( diag_trp_ei + diag_trp_es ) * e1e2t ) ! must be close to 0 (only for Prather)142 zvtrp = glob_sum( 'icectl', diag_adv_mass * e1e2t ) 143 zetrp = glob_sum( 'icectl', diag_adv_heat * e1e2t ) 136 144 137 145 ! ice area (+epsi10 to set a threshold > 0 when there is no ice) … … 156 164 & WRITE(numout,*) cd_routine,' : violation a_i > amax = ',zdiag_amax 157 165 ! check if advection scheme is conservative 158 ! only check for Prather because Ultimate-Macho uses corrective fluxes (wfx etc) 159 ! so the formulation for conservation is different (and not coded) 160 ! it does not mean UM is not conservative (it is checked with above prints) => update (09/2019): same for Prather now 161 !IF( ln_adv_Pra .AND. ABS(zvtrp) > zchk_m * rn_icechk_glo * zarea .AND. cd_routine == 'icedyn_adv' ) & 162 ! & WRITE(numout,*) cd_routine,' : violation adv scheme [kg] = ',zvtrp * rDt_ice 166 IF( ABS(zvtrp) > zchk_m * rn_icechk_glo * zarea .AND. cd_routine == 'icedyn_adv' ) & 167 & WRITE(numout,*) cd_routine,' : violation adv scheme [kg] = ',zvtrp * rdt_ice 168 IF( ABS(zetrp) > zchk_t * rn_icechk_glo * zarea .AND. cd_routine == 'icedyn_adv' ) & 169 & WRITE(numout,*) cd_routine,' : violation adv scheme [J] = ',zetrp * rdt_ice 163 170 ENDIF 164 171 ! … … 186 193 ! water flux 187 194 ! -- mass diag -- ! 188 zdiag_mass = glob_sum( 'icectl', ( wfx_ice + wfx_snw + wfx_spr + wfx_sub + diag_vice + diag_vsnw ) * e1e2t ) 195 zdiag_mass = glob_sum( 'icectl', ( wfx_ice + wfx_snw + wfx_spr + wfx_sub & 196 & + diag_vice + diag_vsnw - diag_adv_mass ) * e1e2t ) 189 197 190 198 ! -- salt diag -- ! 191 zdiag_salt = glob_sum( 'icectl', ( sfx + diag_sice ) * e1e2t )199 zdiag_salt = glob_sum( 'icectl', ( sfx + diag_sice - diag_adv_salt ) * e1e2t ) 192 200 193 201 ! -- heat diag -- ! 194 ! clem: not the good formulation 195 !!zdiag_heat = glob_sum( 'icectl', ( qt_oce_ai - qt_atm_oi + diag_heat + hfx_thd + hfx_dyn + hfx_res + hfx_sub + hfx_spr & 196 !! & ) * e1e2t ) 202 zdiag_heat = glob_sum( 'icectl', ( qt_oce_ai - qt_atm_oi + diag_heat - diag_adv_heat ) * e1e2t ) 203 ! equivalent to this: 204 !!zdiag_heat = glob_sum( 'icectl', ( -diag_heat + hfx_sum + hfx_bom + hfx_bog + hfx_dif + hfx_opw + hfx_snw & 205 !! & - hfx_thd - hfx_dyn - hfx_res - hfx_sub - hfx_spr & 206 !! & ) * e1e2t ) 197 207 198 208 ! ice area (+epsi10 to set a threshold > 0 when there is no ice) … … 204 214 IF( ABS(zdiag_salt) > zchk_s * rn_icechk_glo * zarea ) & 205 215 & WRITE(numout,*) cd_routine,' : violation salt cons. [g] = ',zdiag_salt * rDt_ice 206 !!IF( ABS(zdiag_heat) > zchk_t * rn_icechk_glo * zarea ) WRITE(numout,*) cd_routine,' : violation heat cons. [J] = ',zdiag_heat * rDt_ice 216 IF( ABS(zdiag_heat) > zchk_t * rn_icechk_glo * zarea ) & 217 & WRITE(numout,*) cd_routine,' : violation heat cons. [J] = ',zdiag_heat * rDt_ice 207 218 ENDIF 208 219 ! … … 350 361 !! *** ROUTINE ice_ctl *** 351 362 !! 352 !! ** Purpose : Alerts in case of model crash363 !! ** Purpose : control checks 353 364 !!------------------------------------------------------------------- 354 365 INTEGER, INTENT(in) :: kt ! ocean time step 355 INTEGER :: ji, jj, jk, jl ! dummy loop indices 356 INTEGER :: inb_altests ! number of alert tests (max 20) 357 INTEGER :: ialert_id ! number of the current alert 358 REAL(wp) :: ztmelts ! ice layer melting point 366 INTEGER :: ja, ji, jj, jk, jl ! dummy loop indices 367 INTEGER :: ialert_id ! number of the current alert 368 REAL(wp) :: ztmelts ! ice layer melting point 359 369 CHARACTER (len=30), DIMENSION(20) :: cl_alname ! name of alert 360 370 INTEGER , DIMENSION(20) :: inb_alp ! number of alerts positive 361 371 !!------------------------------------------------------------------- 362 363 inb_altests = 10 364 inb_alp(:) = 0 365 366 ! Alert if incompatible volume and concentration 367 ialert_id = 2 ! reference number of this alert 368 cl_alname(ialert_id) = ' Incompat vol and con ' ! name of the alert 372 inb_alp(:) = 0 373 ialert_id = 0 374 375 ! Alert if very high salinity 376 ialert_id = ialert_id + 1 ! reference number of this alert 377 cl_alname(ialert_id) = ' Very high salinity ' ! name of the alert 369 378 DO jl = 1, jpl 370 379 DO_2D( 1, 1, 1, 1 ) 371 IF( v_i(ji,jj,jl) /= 0._wp .AND. a_i(ji,jj,jl) == 0._wp ) THEN 372 WRITE(numout,*) ' ALERTE 2 : Incompatible volume and concentration ' 373 inb_alp(ialert_id) = inb_alp(ialert_id) + 1 380 IF( v_i(ji,jj,jl) > epsi10 ) THEN 381 IF( sv_i(ji,jj,jl) / v_i(ji,jj,jl) > rn_simax ) THEN 382 WRITE(numout,*) ' ALERTE : Very high salinity ',sv_i(ji,jj,jl)/v_i(ji,jj,jl) 383 WRITE(numout,*) ' at i,j,l = ',ji,jj,jl 384 inb_alp(ialert_id) = inb_alp(ialert_id) + 1 385 ENDIF 374 386 ENDIF 375 387 END_2D 376 388 END DO 377 389 378 ! Alerte if very thick ice 379 ialert_id = 3 ! reference number of this alert 380 cl_alname(ialert_id) = ' Very thick ice ' ! name of the alert 381 jl = jpl 382 DO_2D( 1, 1, 1, 1 ) 383 IF( h_i(ji,jj,jl) > 50._wp ) THEN 384 WRITE(numout,*) ' ALERTE 3 : Very thick ice' 385 !CALL ice_prt( kt, ji, jj, 2, ' ALERTE 3 : Very thick ice ' ) 386 inb_alp(ialert_id) = inb_alp(ialert_id) + 1 387 ENDIF 388 END_2D 389 390 ! Alert if very fast ice 391 ialert_id = 4 ! reference number of this alert 392 cl_alname(ialert_id) = ' Very fast ice ' ! name of the alert 393 DO_2D( 1, 1, 1, 1 ) 394 IF( MAX( ABS( u_ice(ji,jj) ), ABS( v_ice(ji,jj) ) ) > 2. .AND. & 395 & at_i(ji,jj) > 0._wp ) THEN 396 WRITE(numout,*) ' ALERTE 4 : Very fast ice' 397 !CALL ice_prt( kt, ji, jj, 1, ' ALERTE 4 : Very fast ice ' ) 398 inb_alp(ialert_id) = inb_alp(ialert_id) + 1 399 ENDIF 400 END_2D 401 402 ! Alert on salt flux 403 ialert_id = 5 ! reference number of this alert 404 cl_alname(ialert_id) = ' High salt flux ' ! name of the alert 405 DO_2D( 1, 1, 1, 1 ) 406 IF( ABS( sfx (ji,jj) ) > 1.0e-2 ) THEN ! = 1 psu/day for 1m ocean depth 407 WRITE(numout,*) ' ALERTE 5 : High salt flux' 408 !CALL ice_prt( kt, ji, jj, 3, ' ALERTE 5 : High salt flux ' ) 409 inb_alp(ialert_id) = inb_alp(ialert_id) + 1 410 ENDIF 411 END_2D 412 413 ! Alert if there is ice on continents 414 ialert_id = 6 ! reference number of this alert 415 cl_alname(ialert_id) = ' Ice on continents ' ! name of the alert 416 DO_2D( 1, 1, 1, 1 ) 417 IF( tmask(ji,jj,1) <= 0._wp .AND. at_i(ji,jj) > 0._wp ) THEN 418 WRITE(numout,*) ' ALERTE 6 : Ice on continents' 419 !CALL ice_prt( kt, ji, jj, 1, ' ALERTE 6 : Ice on continents ' ) 420 inb_alp(ialert_id) = inb_alp(ialert_id) + 1 421 ENDIF 422 END_2D 423 424 ! 425 ! ! Alert if very fresh ice 426 ialert_id = 7 ! reference number of this alert 427 cl_alname(ialert_id) = ' Very fresh ice ' ! name of the alert 390 ! Alert if very low salinity 391 ialert_id = ialert_id + 1 ! reference number of this alert 392 cl_alname(ialert_id) = ' Very low salinity ' ! name of the alert 428 393 DO jl = 1, jpl 429 394 DO_2D( 1, 1, 1, 1 ) 430 IF( s_i(ji,jj,jl) < 0.1 .AND. a_i(ji,jj,jl) > 0._wp ) THEN 431 WRITE(numout,*) ' ALERTE 7 : Very fresh ice' 432 ! CALL ice_prt(kt,ji,jj,1, ' ALERTE 7 : Very fresh ice ' ) 433 inb_alp(ialert_id) = inb_alp(ialert_id) + 1 395 IF( v_i(ji,jj,jl) > epsi10 ) THEN 396 IF( sv_i(ji,jj,jl) / v_i(ji,jj,jl) < rn_simin ) THEN 397 WRITE(numout,*) ' ALERTE : Very low salinity ',sv_i(ji,jj,jl),v_i(ji,jj,jl) 398 WRITE(numout,*) ' at i,j,l = ',ji,jj,jl 399 inb_alp(ialert_id) = inb_alp(ialert_id) + 1 400 ENDIF 434 401 ENDIF 435 402 END_2D 436 403 END DO 437 ! 438 ! Alert if qns very big 439 ialert_id = 8 ! reference number of this alert 440 cl_alname(ialert_id) = ' fnsolar very big ' ! name of the alert 441 DO_2D( 1, 1, 1, 1 ) 442 IF( ABS( qns(ji,jj) ) > 1500._wp .AND. at_i(ji,jj) > 0._wp ) THEN 443 ! 444 WRITE(numout,*) ' ALERTE 8 : Very high non-solar heat flux' 445 !CALL ice_prt( kt, ji, jj, 2, ' ') 446 inb_alp(ialert_id) = inb_alp(ialert_id) + 1 447 ! 448 ENDIF 449 END_2D 450 !+++++ 451 452 ! ! Alert if too old ice 453 ialert_id = 9 ! reference number of this alert 454 cl_alname(ialert_id) = ' Very old ice ' ! name of the alert 455 DO jl = 1, jpl 456 DO_2D( 1, 1, 1, 1 ) 457 IF ( ( ( ABS( o_i(ji,jj,jl) ) > rDt_ice ) .OR. & 458 ( ABS( o_i(ji,jj,jl) ) < 0._wp) ) .AND. & 459 ( a_i(ji,jj,jl) > 0._wp ) ) THEN 460 WRITE(numout,*) ' ALERTE 9 : Wrong ice age' 461 !CALL ice_prt( kt, ji, jj, 1, ' ALERTE 9 : Wrong ice age ') 462 inb_alp(ialert_id) = inb_alp(ialert_id) + 1 463 ENDIF 464 END_2D 465 END DO 466 467 ! Alert if very warm ice 468 ialert_id = 10 ! reference number of this alert 469 cl_alname(ialert_id) = ' Very warm ice ' ! name of the alert 470 inb_alp(ialert_id) = 0 404 405 ! Alert if very cold ice 406 ialert_id = ialert_id + 1 ! reference number of this alert 407 cl_alname(ialert_id) = ' Very cold ice ' ! name of the alert 471 408 DO jl = 1, jpl 472 409 DO_3D( 1, 1, 1, 1, 1, nlay_i ) 473 410 ztmelts = -rTmlt * sz_i(ji,jj,jk,jl) + rt0 474 IF( t_i(ji,jj,jk,jl) > ztmelts .AND. v_i(ji,jj,jl) > 1.e-10 &475 & .AND. a_i(ji,jj,jl) > 0._wp ) THEN476 WRITE(numout,*) ' ALERTE 10 : Very warm ice'411 IF( t_i(ji,jj,jk,jl) < -50.+rt0 .AND. v_i(ji,jj,jl) > epsi10 ) THEN 412 WRITE(numout,*) ' ALERTE : Very cold ice ',(t_i(ji,jj,jk,jl)-rt0) 413 WRITE(numout,*) ' at i,j,k,l = ',ji,jj,jk,jl 477 414 inb_alp(ialert_id) = inb_alp(ialert_id) + 1 478 415 ENDIF 479 416 END_3D 480 417 END DO 418 419 ! Alert if very warm ice 420 ialert_id = ialert_id + 1 ! reference number of this alert 421 cl_alname(ialert_id) = ' Very warm ice ' ! name of the alert 422 DO jl = 1, jpl 423 DO_3D( 1, 1, 1, 1, 1, nlay_i ) 424 ztmelts = -rTmlt * sz_i(ji,jj,jk,jl) + rt0 425 IF( t_i(ji,jj,jk,jl) > ztmelts .AND. v_i(ji,jj,jl) > epsi10 ) THEN 426 WRITE(numout,*) ' ALERTE : Very warm ice',(t_i(ji,jj,jk,jl)-rt0) 427 WRITE(numout,*) ' at i,j,k,l = ',ji,jj,jk,jl 428 inb_alp(ialert_id) = inb_alp(ialert_id) + 1 429 ENDIF 430 END_3D 431 END DO 432 433 ! Alerte if very thick ice 434 ialert_id = ialert_id + 1 ! reference number of this alert 435 cl_alname(ialert_id) = ' Very thick ice ' ! name of the alert 436 jl = jpl 437 DO_2D( 1, 1, 1, 1 ) 438 IF( h_i(ji,jj,jl) > 50._wp ) THEN 439 WRITE(numout,*) ' ALERTE : Very thick ice ',h_i(ji,jj,jl) 440 WRITE(numout,*) ' at i,j,l = ',ji,jj,jl 441 inb_alp(ialert_id) = inb_alp(ialert_id) + 1 442 ENDIF 443 END_2D 444 445 ! Alerte if very thin ice 446 ialert_id = ialert_id + 1 ! reference number of this alert 447 cl_alname(ialert_id) = ' Very thin ice ' ! name of the alert 448 jl = 1 449 DO_2D( 1, 1, 1, 1 ) 450 IF( h_i(ji,jj,jl) < rn_himin ) THEN 451 WRITE(numout,*) ' ALERTE : Very thin ice ',h_i(ji,jj,jl) 452 WRITE(numout,*) ' at i,j,l = ',ji,jj,jl 453 inb_alp(ialert_id) = inb_alp(ialert_id) + 1 454 ENDIF 455 END_2D 456 457 ! Alert if very fast ice 458 ialert_id = ialert_id + 1 ! reference number of this alert 459 cl_alname(ialert_id) = ' Very fast ice ' ! name of the alert 460 DO_2D( 1, 1, 1, 1 ) 461 IF( MAX( ABS( u_ice(ji,jj) ), ABS( v_ice(ji,jj) ) ) > 2. ) THEN 462 WRITE(numout,*) ' ALERTE : Very fast ice ',MAX( ABS( u_ice(ji,jj) ), ABS( v_ice(ji,jj) ) ) 463 WRITE(numout,*) ' at i,j = ',ji,jj 464 inb_alp(ialert_id) = inb_alp(ialert_id) + 1 465 ENDIF 466 END_2D 467 468 ! Alert if there is ice on continents 469 ialert_id = ialert_id + 1 ! reference number of this alert 470 cl_alname(ialert_id) = ' Ice on continents ' ! name of the alert 471 DO_2D( 1, 1, 1, 1 ) 472 IF( tmask(ji,jj,1) == 0._wp .AND. ( at_i(ji,jj) > 0._wp .OR. vt_i(ji,jj) > 0._wp ) ) THEN 473 WRITE(numout,*) ' ALERTE : Ice on continents ',at_i(ji,jj),vt_i(ji,jj) 474 WRITE(numout,*) ' at i,j = ',ji,jj 475 inb_alp(ialert_id) = inb_alp(ialert_id) + 1 476 ENDIF 477 END_2D 478 479 ! Alert if incompatible ice concentration and volume 480 ialert_id = ialert_id + 1 ! reference number of this alert 481 cl_alname(ialert_id) = ' Incompatible ice conc and vol ' ! name of the alert 482 DO_2D( 1, 1, 1, 1 ) 483 IF( ( vt_i(ji,jj) == 0._wp .AND. at_i(ji,jj) > 0._wp ) .OR. & 484 & ( vt_i(ji,jj) > 0._wp .AND. at_i(ji,jj) == 0._wp ) ) THEN 485 WRITE(numout,*) ' ALERTE : Incompatible ice conc and vol ',at_i(ji,jj),vt_i(ji,jj) 486 WRITE(numout,*) ' at i,j = ',ji,jj 487 inb_alp(ialert_id) = inb_alp(ialert_id) + 1 488 ENDIF 489 END_2D 481 490 482 491 ! sum of the alerts on all processors 483 492 IF( lk_mpp ) THEN 484 DO ialert_id = 1, inb_altests485 CALL mpp_sum('icectl', inb_alp( ialert_id))493 DO ja = 1, ialert_id 494 CALL mpp_sum('icectl', inb_alp(ja)) 486 495 END DO 487 496 ENDIF … … 489 498 ! print alerts 490 499 IF( lwp ) THEN 491 ialert_id = 1 ! reference number of this alert492 cl_alname(ialert_id) = ' NO alerte 1 ' ! name of the alert493 500 WRITE(numout,*) ' time step ',kt 494 501 WRITE(numout,*) ' All alerts at the end of ice model ' 495 DO ialert_id = 1, inb_altests496 WRITE(numout,*) ialert_id, cl_alname(ialert_id)//' : ', inb_alp(ialert_id), ' times ! '502 DO ja = 1, ialert_id 503 WRITE(numout,*) ja, cl_alname(ja)//' : ', inb_alp(ja), ' times ! ' 497 504 END DO 498 505 ENDIF … … 543 550 WRITE(numout,*) ' v_ice(i ,j) : ', v_ice(ji,jj) 544 551 WRITE(numout,*) ' strength : ', strength(ji,jj) 545 WRITE(numout,*)546 552 WRITE(numout,*) ' - Cell values ' 547 553 WRITE(numout,*) ' ~~~~~~~~~~~ ' … … 552 558 DO jl = 1, jpl 553 559 WRITE(numout,*) ' - Category (', jl,')' 560 WRITE(numout,*) ' ~~~~~~~~~~~ ' 554 561 WRITE(numout,*) ' a_i : ', a_i(ji,jj,jl) 555 562 WRITE(numout,*) ' h_i : ', h_i(ji,jj,jl) … … 588 595 WRITE(numout,*) ' v_ice(i ,j) : ', v_ice(ji,jj) 589 596 WRITE(numout,*) ' strength : ', strength(ji,jj) 590 WRITE(numout,*) ' u_ice_b : ', u_ice_b(ji,jj) , ' v_ice_b : ', v_ice_b(ji,jj)591 597 WRITE(numout,*) 592 598 … … 605 611 WRITE(numout,*) ' e_snow : ', e_s(ji,jj,1,jl) , ' e_snow_b : ', e_s_b(ji,jj,1,jl) 606 612 WRITE(numout,*) ' sv_i : ', sv_i(ji,jj,jl) , ' sv_i_b : ', sv_i_b(ji,jj,jl) 607 WRITE(numout,*) ' oa_i : ', oa_i(ji,jj,jl) , ' oa_i_b : ', oa_i_b(ji,jj,jl)608 613 END DO !jl 609 614 … … 713 718 CALL prt_ctl(tab2d_1=v_i (:,:,jl) , clinfo1= ' v_i : ') 714 719 CALL prt_ctl(tab2d_1=v_s (:,:,jl) , clinfo1= ' v_s : ') 715 CALL prt_ctl(tab2d_1=e_i (:,:,1,jl) , clinfo1= ' e_i1 : ')716 720 CALL prt_ctl(tab2d_1=e_s (:,:,1,jl) , clinfo1= ' e_snow : ') 717 721 CALL prt_ctl(tab2d_1=sv_i (:,:,jl) , clinfo1= ' sv_i : ') … … 721 725 CALL prt_ctl_info(' - Layer : ', ivar=jk) 722 726 CALL prt_ctl(tab2d_1=t_i(:,:,jk,jl) , clinfo1= ' t_i : ') 727 CALL prt_ctl(tab2d_1=e_i(:,:,jk,jl) , clinfo1= ' e_i : ') 723 728 END DO 724 729 END DO … … 731 736 732 737 END SUBROUTINE ice_prt3D 738 739 740 SUBROUTINE ice_drift_wri( kt ) 741 !!------------------------------------------------------------------- 742 !! *** ROUTINE ice_drift_wri *** 743 !! 744 !! ** Purpose : conservation of mass, salt and heat 745 !! write the drift in a ascii file at each time step 746 !! and the total run drifts 747 !!------------------------------------------------------------------- 748 INTEGER, INTENT(in) :: kt ! ice time-step index 749 ! 750 INTEGER :: ji, jj 751 REAL(wp) :: zdiag_mass, zdiag_salt, zdiag_heat, zdiag_adv_mass, zdiag_adv_salt, zdiag_adv_heat 752 REAL(wp), DIMENSION(jpi,jpj) :: zdiag_mass2D, zdiag_salt2D, zdiag_heat2D 753 !!------------------------------------------------------------------- 754 ! 755 IF( kt == nit000 .AND. lwp ) THEN 756 WRITE(numout,*) 757 WRITE(numout,*) 'ice_drift_wri: sea-ice drifts' 758 WRITE(numout,*) '~~~~~~~~~~~~~' 759 ENDIF 760 ! 761 ! 2D budgets (must be close to 0) 762 IF( iom_use('icedrift_mass') .OR. iom_use('icedrift_salt') .OR. iom_use('icedrift_heat') ) THEN 763 DO_2D( 1, 1, 1, 1 ) 764 zdiag_mass2D(ji,jj) = wfx_ice(ji,jj) + wfx_snw(ji,jj) + wfx_spr(ji,jj) + wfx_sub(ji,jj) & 765 & + diag_vice(ji,jj) + diag_vsnw(ji,jj) - diag_adv_mass(ji,jj) 766 zdiag_salt2D(ji,jj) = sfx(ji,jj) + diag_sice(ji,jj) - diag_adv_salt(ji,jj) 767 zdiag_heat2D(ji,jj) = qt_oce_ai(ji,jj) - qt_atm_oi(ji,jj) + diag_heat(ji,jj) - diag_adv_heat(ji,jj) 768 END_2D 769 ! 770 ! write outputs 771 CALL iom_put( 'icedrift_mass', zdiag_mass2D ) 772 CALL iom_put( 'icedrift_salt', zdiag_salt2D ) 773 CALL iom_put( 'icedrift_heat', zdiag_heat2D ) 774 ENDIF 775 776 ! -- mass diag -- ! 777 zdiag_mass = glob_sum( 'icectl', ( wfx_ice + wfx_snw + wfx_spr + wfx_sub & 778 & + diag_vice + diag_vsnw - diag_adv_mass ) * e1e2t ) * rdt_ice 779 zdiag_adv_mass = glob_sum( 'icectl', diag_adv_mass * e1e2t ) * rDt_ice 780 781 ! -- salt diag -- ! 782 zdiag_salt = glob_sum( 'icectl', ( sfx + diag_sice - diag_adv_salt ) * e1e2t ) * rdt_ice * 1.e-3 783 zdiag_adv_salt = glob_sum( 'icectl', diag_adv_salt * e1e2t ) * rDt_ice * 1.e-3 784 785 ! -- heat diag -- ! 786 zdiag_heat = glob_sum( 'icectl', ( qt_oce_ai - qt_atm_oi + diag_heat - diag_adv_heat ) * e1e2t ) 787 zdiag_adv_heat = glob_sum( 'icectl', diag_adv_heat * e1e2t ) 788 789 ! ! write out to file 790 IF( lwp ) THEN 791 ! check global drift (must be close to 0) 792 WRITE(numicedrift,FMT='(2x,i6,3x,a19,4x,f25.5)') kt, 'mass drift [kg]', zdiag_mass 793 WRITE(numicedrift,FMT='(11x, a19,4x,f25.5)') 'salt drift [kg]', zdiag_salt 794 WRITE(numicedrift,FMT='(11x, a19,4x,f25.5)') 'heat drift [W] ', zdiag_heat 795 ! check drift from advection scheme (can be /=0 with bdy but not sure why) 796 WRITE(numicedrift,FMT='(11x, a19,4x,f25.5)') 'mass drift adv [kg]', zdiag_adv_mass 797 WRITE(numicedrift,FMT='(11x, a19,4x,f25.5)') 'salt drift adv [kg]', zdiag_adv_salt 798 WRITE(numicedrift,FMT='(11x, a19,4x,f25.5)') 'heat drift adv [W] ', zdiag_adv_heat 799 ENDIF 800 ! ! drifts 801 rdiag_icemass = rdiag_icemass + zdiag_mass 802 rdiag_icesalt = rdiag_icesalt + zdiag_salt 803 rdiag_iceheat = rdiag_iceheat + zdiag_heat 804 rdiag_adv_icemass = rdiag_adv_icemass + zdiag_adv_mass 805 rdiag_adv_icesalt = rdiag_adv_icesalt + zdiag_adv_salt 806 rdiag_adv_iceheat = rdiag_adv_iceheat + zdiag_adv_heat 807 ! 808 ! ! output drifts and close ascii file 809 IF( kt == nitend - nn_fsbc + 1 .AND. lwp ) THEN 810 ! to ascii file 811 WRITE(numicedrift,*) '******************************************' 812 WRITE(numicedrift,FMT='(3x,a23,6x,E10.2)') 'Run mass drift [kg]', rdiag_icemass 813 WRITE(numicedrift,FMT='(3x,a23,6x,E10.2)') 'Run mass drift adv [kg]', rdiag_adv_icemass 814 WRITE(numicedrift,*) '******************************************' 815 WRITE(numicedrift,FMT='(3x,a23,6x,E10.2)') 'Run salt drift [kg]', rdiag_icesalt 816 WRITE(numicedrift,FMT='(3x,a23,6x,E10.2)') 'Run salt drift adv [kg]', rdiag_adv_icesalt 817 WRITE(numicedrift,*) '******************************************' 818 WRITE(numicedrift,FMT='(3x,a23,6x,E10.2)') 'Run heat drift [W] ', rdiag_iceheat 819 WRITE(numicedrift,FMT='(3x,a23,6x,E10.2)') 'Run heat drift adv [W] ', rdiag_adv_iceheat 820 CLOSE( numicedrift ) 821 ! 822 ! to ocean output 823 WRITE(numout,*) 824 WRITE(numout,*) 'ice_drift_wri: ice drifts information for the run ' 825 WRITE(numout,*) '~~~~~~~~~~~~~' 826 ! check global drift (must be close to 0) 827 WRITE(numout,*) ' sea-ice mass drift [kg] = ', rdiag_icemass 828 WRITE(numout,*) ' sea-ice salt drift [kg] = ', rdiag_icesalt 829 WRITE(numout,*) ' sea-ice heat drift [W] = ', rdiag_iceheat 830 ! check drift from advection scheme (can be /=0 with bdy but not sure why) 831 WRITE(numout,*) ' sea-ice mass drift adv [kg] = ', rdiag_adv_icemass 832 WRITE(numout,*) ' sea-ice salt drift adv [kg] = ', rdiag_adv_icesalt 833 WRITE(numout,*) ' sea-ice heat drift adv [W] = ', rdiag_adv_iceheat 834 ENDIF 835 ! 836 END SUBROUTINE ice_drift_wri 837 838 SUBROUTINE ice_drift_init 839 !!---------------------------------------------------------------------- 840 !! *** ROUTINE ice_drift_init *** 841 !! 842 !! ** Purpose : create output file, initialise arrays 843 !!---------------------------------------------------------------------- 844 ! 845 IF( .NOT.ln_icediachk ) RETURN ! exit 846 ! 847 IF(lwp) THEN 848 WRITE(numout,*) 849 WRITE(numout,*) 'ice_drift_init: Output ice drifts to ',TRIM(clname), ' file' 850 WRITE(numout,*) '~~~~~~~~~~~~~' 851 WRITE(numout,*) 852 ! 853 ! create output ascii file 854 CALL ctl_opn( numicedrift, clname, 'UNKNOWN', 'FORMATTED', 'SEQUENTIAL', 1, numout, lwp, narea ) 855 WRITE(numicedrift,*) 'Timestep Drifts' 856 WRITE(numicedrift,*) '******************************************' 857 ENDIF 858 ! 859 rdiag_icemass = 0._wp 860 rdiag_icesalt = 0._wp 861 rdiag_iceheat = 0._wp 862 rdiag_adv_icemass = 0._wp 863 rdiag_adv_icesalt = 0._wp 864 rdiag_adv_iceheat = 0._wp 865 ! 866 END SUBROUTINE ice_drift_init 733 867 734 868 #else -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/ICE/icedyn.F90
r13295 r13998 100 100 WHERE( a_ip(:,:,:) >= epsi20 ) 101 101 h_ip(:,:,:) = v_ip(:,:,:) / a_ip(:,:,:) 102 h_il(:,:,:) = v_il(:,:,:) / a_ip(:,:,:) 102 103 ELSEWHERE 103 104 h_ip(:,:,:) = 0._wp 105 h_il(:,:,:) = 0._wp 104 106 END WHERE 105 107 ! … … 127 129 ! Then for dx = 2m and dt = 1s => rn_uice = u (1/6th) = 1m/s 128 130 DO_2D( 1, 1, 1, 1 ) 129 zcoefu = ( REAL(jpiglo+1)*0.5 - REAL(ji+nimpp-1) ) / ( REAL(jpiglo+1)*0.5 - 1.)130 zcoefv = ( REAL(jpjglo+1)*0.5 - REAL(jj+njmpp-1) ) / ( REAL(jpjglo+1)*0.5 - 1.)131 u_ice(ji,jj) = rn_uice * 1.5 * SIGN( 1.0_wp, zcoefu ) * ABS( zcoefu ) * umask(ji,jj,1)132 v_ice(ji,jj) = rn_vice * 1.5 * SIGN( 1.0_wp, zcoefv ) * ABS( zcoefv ) * vmask(ji,jj,1)131 zcoefu = ( REAL(jpiglo+1)*0.5_wp - REAL(ji+nimpp-1) ) / ( REAL(jpiglo+1)*0.5_wp - 1._wp ) 132 zcoefv = ( REAL(jpjglo+1)*0.5_wp - REAL(jj+njmpp-1) ) / ( REAL(jpjglo+1)*0.5_wp - 1._wp ) 133 u_ice(ji,jj) = rn_uice * 1.5_wp * SIGN( 1.0_wp, zcoefu ) * ABS( zcoefu ) * umask(ji,jj,1) 134 v_ice(ji,jj) = rn_vice * 1.5_wp * SIGN( 1.0_wp, zcoefv ) * ABS( zcoefv ) * vmask(ji,jj,1) 133 135 END_2D 134 136 ! --- … … 218 220 NAMELIST/namdyn/ ln_dynALL, ln_dynRHGADV, ln_dynADV1D, ln_dynADV2D, rn_uice, rn_vice, & 219 221 & rn_ishlat , & 220 & ln_landfast_L16, rn_ depfra, rn_icebfr, rn_lfrelax, rn_tensile222 & ln_landfast_L16, rn_lf_depfra, rn_lf_bfr, rn_lf_relax, rn_lf_tensile 221 223 !!------------------------------------------------------------------- 222 224 ! … … 239 241 WRITE(numout,*) ' lateral boundary condition for sea ice dynamics rn_ishlat = ', rn_ishlat 240 242 WRITE(numout,*) ' Landfast: param from Lemieux 2016 ln_landfast_L16 = ', ln_landfast_L16 241 WRITE(numout,*) ' fraction of ocean depth that ice must reach rn_ depfra = ', rn_depfra242 WRITE(numout,*) ' maximum bottom stress per unit area of contact rn_ icebfr = ', rn_icebfr243 WRITE(numout,*) ' relax time scale (s-1) to reach static friction rn_lf relax = ', rn_lfrelax244 WRITE(numout,*) ' isotropic tensile strength rn_ tensile = ', rn_tensile243 WRITE(numout,*) ' fraction of ocean depth that ice must reach rn_lf_depfra = ', rn_lf_depfra 244 WRITE(numout,*) ' maximum bottom stress per unit area of contact rn_lf_bfr = ', rn_lf_bfr 245 WRITE(numout,*) ' relax time scale (s-1) to reach static friction rn_lf_relax = ', rn_lf_relax 246 WRITE(numout,*) ' isotropic tensile strength rn_lf_tensile = ', rn_lf_tensile 245 247 WRITE(numout,*) 246 248 ENDIF -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/ICE/icedyn_adv.F90
r12489 r13998 82 82 ! !-----------------------! 83 83 CALL ice_dyn_adv_umx( nn_UMx, kt, u_ice, v_ice, h_i, h_s, h_ip, & 84 & ato_i, v_i, v_s, sv_i, oa_i, a_i, a_ip, v_ip, e_s, e_i )84 & ato_i, v_i, v_s, sv_i, oa_i, a_i, a_ip, v_ip, v_il, e_s, e_i ) 85 85 ! !-----------------------! 86 86 CASE( np_advPRA ) ! PRATHER scheme ! 87 87 ! !-----------------------! 88 88 CALL ice_dyn_adv_pra( kt, u_ice, v_ice, h_i, h_s, h_ip, & 89 & ato_i, v_i, v_s, sv_i, oa_i, a_i, a_ip, v_ip, e_s, e_i )89 & ato_i, v_i, v_s, sv_i, oa_i, a_i, a_ip, v_ip, v_il, e_s, e_i ) 90 90 END SELECT 91 91 -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/ICE/icedyn_adv_pra.F90
r13295 r13998 44 44 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: sxap , syap , sxxap , syyap , sxyap ! melt pond fraction 45 45 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: sxvp , syvp , sxxvp , syyvp , sxyvp ! melt pond volume 46 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: sxvl , syvl , sxxvl , syyvl , sxyvl ! melt pond lid volume 46 47 47 48 !! * Substitutions … … 55 56 56 57 SUBROUTINE ice_dyn_adv_pra( kt, pu_ice, pv_ice, ph_i, ph_s, ph_ip, & 57 & pato_i, pv_i, pv_s, psv_i, poa_i, pa_i, pa_ip, pv_ip, p e_s, pe_i )58 & pato_i, pv_i, pv_s, psv_i, poa_i, pa_i, pa_ip, pv_ip, pv_il, pe_s, pe_i ) 58 59 !!---------------------------------------------------------------------- 59 60 !! ** routine ice_dyn_adv_pra ** … … 81 82 REAL(wp), DIMENSION(:,:,:) , INTENT(inout) :: pa_ip ! melt pond fraction 82 83 REAL(wp), DIMENSION(:,:,:) , INTENT(inout) :: pv_ip ! melt pond volume 84 REAL(wp), DIMENSION(:,:,:) , INTENT(inout) :: pv_il ! melt pond lid thickness 83 85 REAL(wp), DIMENSION(:,:,:,:), INTENT(inout) :: pe_s ! snw heat content 84 86 REAL(wp), DIMENSION(:,:,:,:), INTENT(inout) :: pe_i ! ice heat content 85 87 ! 86 INTEGER :: ji, jj, jk, jl, jt! dummy loop indices88 INTEGER :: ji, jj, jk, jl, jt ! dummy loop indices 87 89 INTEGER :: icycle ! number of sub-timestep for the advection 88 REAL(wp) :: zdt 90 REAL(wp) :: zdt, z1_dt ! - - 89 91 REAL(wp), DIMENSION(1) :: zcflprv, zcflnow ! for global communication 90 92 REAL(wp), DIMENSION(jpi,jpj) :: zati1, zati2 91 93 REAL(wp), DIMENSION(jpi,jpj) :: zudy, zvdx 92 REAL(wp), DIMENSION(jpi,jpj,jpl) :: zhi_max, zhs_max, zhip_max 94 REAL(wp), DIMENSION(jpi,jpj,jpl) :: zhi_max, zhs_max, zhip_max, zs_i, zsi_max 95 REAL(wp), DIMENSION(jpi,jpj,nlay_i,jpl) :: ze_i, zei_max 96 REAL(wp), DIMENSION(jpi,jpj,nlay_s,jpl) :: ze_s, zes_max 93 97 REAL(wp), DIMENSION(jpi,jpj,jpl) :: zarea 94 98 REAL(wp), DIMENSION(jpi,jpj,jpl) :: z0ice, z0snw, z0ai, z0smi, z0oi 95 REAL(wp), DIMENSION(jpi,jpj,jpl) :: z0ap , z0vp 99 REAL(wp), DIMENSION(jpi,jpj,jpl) :: z0ap , z0vp, z0vl 96 100 REAL(wp), DIMENSION(jpi,jpj,nlay_s,jpl) :: z0es 97 101 REAL(wp), DIMENSION(jpi,jpj,nlay_i,jpl) :: z0ei 102 !! diagnostics 103 REAL(wp), DIMENSION(jpi,jpj) :: zdiag_adv_mass, zdiag_adv_salt, zdiag_adv_heat 98 104 !!---------------------------------------------------------------------- 99 105 ! 100 106 IF( kt == nit000 .AND. lwp ) WRITE(numout,*) '-- ice_dyn_adv_pra: Prather advection scheme' 101 107 ! 102 ! --- Record max of the surrounding 9-pts ice thick.(for call Hbig) --- !103 DO jl = 1, jpl104 DO_2D( 0, 0, 0, 0)105 zhip_max(ji,jj,jl) = MAX( epsi20, ph_ip(ji,jj,jl), ph_ip(ji+1,jj ,jl), ph_ip(ji ,jj+1,jl), &106 & ph_ip(ji-1,jj ,jl), ph_ip(ji ,jj-1,jl), &107 & ph_ip(ji+1,jj+1,jl), ph_ip(ji-1,jj-1,jl), &108 & ph_ip(ji+1,jj-1,jl), ph_ip(ji-1,jj+1,jl))109 zhi_max (ji,jj,jl) = MAX( epsi20, ph_i (ji,jj,jl), ph_i (ji+1,jj ,jl), ph_i (ji ,jj+1,jl), &110 & ph_i (ji-1,jj ,jl), ph_i (ji ,jj-1,jl), &111 & ph_i (ji+1,jj+1,jl), ph_i (ji-1,jj-1,jl), &112 & ph_i (ji+1,jj-1,jl), ph_i (ji-1,jj+1,jl) )113 zhs_max (ji,jj,jl) = MAX( epsi20, ph_s (ji,jj,jl), ph_s (ji+1,jj ,jl), ph_s (ji ,jj+1,jl), &114 & ph_s (ji-1,jj ,jl), ph_s (ji ,jj-1,jl), &115 & ph_s (ji+1,jj+1,jl), ph_s (ji-1,jj-1,jl), &116 & ph_s (ji+1,jj-1,jl), ph_s (ji-1,jj+1,jl) )117 END _2D108 ! --- Record max of the surrounding 9-pts (for call Hbig) --- ! 109 ! thickness and salinity 110 WHERE( pv_i(:,:,:) >= epsi10 ) ; zs_i(:,:,:) = psv_i(:,:,:) / pv_i(:,:,:) 111 ELSEWHERE ; zs_i(:,:,:) = 0._wp 112 END WHERE 113 CALL icemax3D( ph_i , zhi_max ) 114 CALL icemax3D( ph_s , zhs_max ) 115 CALL icemax3D( ph_ip, zhip_max) 116 CALL icemax3D( zs_i , zsi_max ) 117 CALL lbc_lnk_multi( 'icedyn_adv_pra', zhi_max, 'T', 1._wp, zhs_max, 'T', 1._wp, zhip_max, 'T', 1._wp, zsi_max, 'T', 1._wp ) 118 ! 119 ! enthalpies 120 DO jk = 1, nlay_i 121 WHERE( pv_i(:,:,:) >= epsi10 ) ; ze_i(:,:,jk,:) = pe_i(:,:,jk,:) / pv_i(:,:,:) 122 ELSEWHERE ; ze_i(:,:,jk,:) = 0._wp 123 END WHERE 118 124 END DO 119 CALL lbc_lnk_multi( 'icedyn_adv_pra', zhi_max, 'T', 1.0_wp, zhs_max, 'T', 1.0_wp, zhip_max, 'T', 1.0_wp ) 125 DO jk = 1, nlay_s 126 WHERE( pv_s(:,:,:) >= epsi10 ) ; ze_s(:,:,jk,:) = pe_s(:,:,jk,:) / pv_s(:,:,:) 127 ELSEWHERE ; ze_s(:,:,jk,:) = 0._wp 128 END WHERE 129 END DO 130 CALL icemax4D( ze_i , zei_max ) 131 CALL icemax4D( ze_s , zes_max ) 132 CALL lbc_lnk( 'icedyn_adv_pra', zei_max, 'T', 1._wp ) 133 CALL lbc_lnk( 'icedyn_adv_pra', zes_max, 'T', 1._wp ) 134 ! 120 135 ! 121 136 ! --- If ice drift is too fast, use subtime steps for advection (CFL test for stability) --- ! … … 132 147 ENDIF 133 148 zdt = rDt_ice / REAL(icycle) 149 z1_dt = 1._wp / zdt 134 150 135 151 ! --- transport --- ! … … 138 154 139 155 DO jt = 1, icycle 156 157 ! diagnostics 158 zdiag_adv_mass(:,:) = SUM( pv_i(:,:,:) , dim=3 ) * rhoi + SUM( pv_s(:,:,:) , dim=3 ) * rhos 159 zdiag_adv_salt(:,:) = SUM( psv_i(:,:,:) , dim=3 ) * rhoi 160 zdiag_adv_heat(:,:) = - SUM(SUM( pe_i(:,:,1:nlay_i,:) , dim=4 ), dim=3 ) & 161 & - SUM(SUM( pe_s(:,:,1:nlay_s,:) , dim=4 ), dim=3 ) 140 162 141 163 ! record at_i before advection (for open water) … … 156 178 z0ei(:,:,jk,jl) = pe_i(:,:,jk,jl) * e1e2t(:,:) ! Ice heat content 157 179 END DO 158 IF ( ln_pnd_H12 ) THEN 159 z0ap(:,:,jl) = pa_ip(:,:,jl) * e1e2t(:,:) ! Melt pond fraction 160 z0vp(:,:,jl) = pv_ip(:,:,jl) * e1e2t(:,:) ! Melt pond volume 180 IF ( ln_pnd_LEV ) THEN 181 z0ap(:,:,jl) = pa_ip(:,:,jl) * e1e2t(:,:) ! Melt pond fraction 182 z0vp(:,:,jl) = pv_ip(:,:,jl) * e1e2t(:,:) ! Melt pond volume 183 IF ( ln_pnd_lids ) THEN 184 z0vl(:,:,jl) = pv_il(:,:,jl) * e1e2t(:,:) ! Melt pond lid volume 185 ENDIF 161 186 ENDIF 162 187 END DO … … 189 214 END DO 190 215 ! 191 IF ( ln_pnd_ H12) THEN216 IF ( ln_pnd_LEV ) THEN 192 217 CALL adv_x( zdt , zudy , 1._wp , zarea , z0ap , sxap , sxxap , syap , syyap , sxyap ) !--- melt pond fraction 193 218 CALL adv_y( zdt , zvdx , 0._wp , zarea , z0ap , sxap , sxxap , syap , syyap , sxyap ) 194 219 CALL adv_x( zdt , zudy , 1._wp , zarea , z0vp , sxvp , sxxvp , syvp , syyvp , sxyvp ) !--- melt pond volume 195 220 CALL adv_y( zdt , zvdx , 0._wp , zarea , z0vp , sxvp , sxxvp , syvp , syyvp , sxyvp ) 221 IF ( ln_pnd_lids ) THEN 222 CALL adv_x( zdt , zudy , 1._wp , zarea , z0vl , sxvl , sxxvl , syvl , syyvl , sxyvl ) !--- melt pond lid volume 223 CALL adv_y( zdt , zvdx , 0._wp , zarea , z0vl , sxvl , sxxvl , syvl , syyvl , sxyvl ) 224 ENDIF 196 225 ENDIF 197 226 ! !--------------------------------------------! … … 220 249 & sxxe(:,:,jk,:), sye(:,:,jk,:), syye(:,:,jk,:), sxye(:,:,jk,:) ) 221 250 END DO 222 IF ( ln_pnd_ H12) THEN251 IF ( ln_pnd_LEV ) THEN 223 252 CALL adv_y( zdt , zvdx , 1._wp , zarea , z0ap , sxap , sxxap , syap , syyap , sxyap ) !--- melt pond fraction 224 253 CALL adv_x( zdt , zudy , 0._wp , zarea , z0ap , sxap , sxxap , syap , syyap , sxyap ) 225 254 CALL adv_y( zdt , zvdx , 1._wp , zarea , z0vp , sxvp , sxxvp , syvp , syyvp , sxyvp ) !--- melt pond volume 226 255 CALL adv_x( zdt , zudy , 0._wp , zarea , z0vp , sxvp , sxxvp , syvp , syyvp , sxyvp ) 256 IF ( ln_pnd_lids ) THEN 257 CALL adv_y( zdt , zvdx , 1._wp , zarea , z0vl , sxvl , sxxvl , syvl , syyvl , sxyvl ) !--- melt pond lid volume 258 CALL adv_x( zdt , zudy , 0._wp , zarea , z0vl , sxvl , sxxvl , syvl , syyvl , sxyvl ) 259 ENDIF 227 260 ENDIF 228 261 ! 262 ENDIF 263 264 ! --- Lateral boundary conditions --- ! 265 ! caution: for gradients (sx and sy) the sign changes 266 CALL lbc_lnk_multi( 'icedyn_adv_pra', z0ice , 'T', 1._wp, sxice , 'T', -1._wp, syice , 'T', -1._wp & ! ice volume 267 & , sxxice, 'T', 1._wp, syyice, 'T', 1._wp, sxyice, 'T', 1._wp & 268 & , z0snw , 'T', 1._wp, sxsn , 'T', -1._wp, sysn , 'T', -1._wp & ! snw volume 269 & , sxxsn , 'T', 1._wp, syysn , 'T', 1._wp, sxysn , 'T', 1._wp ) 270 CALL lbc_lnk_multi( 'icedyn_adv_pra', z0smi , 'T', 1._wp, sxsal , 'T', -1._wp, sysal , 'T', -1._wp & ! ice salinity 271 & , sxxsal, 'T', 1._wp, syysal, 'T', 1._wp, sxysal, 'T', 1._wp & 272 & , z0ai , 'T', 1._wp, sxa , 'T', -1._wp, sya , 'T', -1._wp & ! ice concentration 273 & , sxxa , 'T', 1._wp, syya , 'T', 1._wp, sxya , 'T', 1._wp ) 274 CALL lbc_lnk_multi( 'icedyn_adv_pra', z0oi , 'T', 1._wp, sxage , 'T', -1._wp, syage , 'T', -1._wp & ! ice age 275 & , sxxage, 'T', 1._wp, syyage, 'T', 1._wp, sxyage, 'T', 1._wp ) 276 CALL lbc_lnk_multi( 'icedyn_adv_pra', z0es , 'T', 1._wp, sxc0 , 'T', -1._wp, syc0 , 'T', -1._wp & ! snw enthalpy 277 & , sxxc0 , 'T', 1._wp, syyc0 , 'T', 1._wp, sxyc0 , 'T', 1._wp ) 278 CALL lbc_lnk_multi( 'icedyn_adv_pra', z0ei , 'T', 1._wp, sxe , 'T', -1._wp, sye , 'T', -1._wp & ! ice enthalpy 279 & , sxxe , 'T', 1._wp, syye , 'T', 1._wp, sxye , 'T', 1._wp ) 280 IF ( ln_pnd_LEV ) THEN 281 CALL lbc_lnk_multi( 'icedyn_adv_pra', z0ap , 'T', 1._wp, sxap , 'T', -1._wp, syap , 'T', -1._wp & ! melt pond fraction 282 & , sxxap, 'T', 1._wp, syyap, 'T', 1._wp, sxyap, 'T', 1._wp & 283 & , z0vp , 'T', 1._wp, sxvp , 'T', -1._wp, syvp , 'T', -1._wp & ! melt pond volume 284 & , sxxvp, 'T', 1._wp, syyvp, 'T', 1._wp, sxyvp, 'T', 1._wp ) 285 IF ( ln_pnd_lids ) THEN 286 CALL lbc_lnk_multi( 'icedyn_adv_pra', z0vl ,'T', 1._wp, sxvl ,'T', -1._wp, syvl ,'T', -1._wp & ! melt pond lid volume 287 & , sxxvl,'T', 1._wp, syyvl,'T', 1._wp, sxyvl,'T', 1._wp ) 288 ENDIF 229 289 ENDIF 230 290 … … 242 302 pe_i(:,:,jk,jl) = z0ei(:,:,jk,jl) * r1_e1e2t(:,:) * tmask(:,:,1) 243 303 END DO 244 IF ( ln_pnd_ H12) THEN304 IF ( ln_pnd_LEV ) THEN 245 305 pa_ip(:,:,jl) = z0ap(:,:,jl) * r1_e1e2t(:,:) * tmask(:,:,1) 246 306 pv_ip(:,:,jl) = z0vp(:,:,jl) * r1_e1e2t(:,:) * tmask(:,:,1) 307 IF ( ln_pnd_lids ) THEN 308 pv_il(:,:,jl) = z0vl(:,:,jl) * r1_e1e2t(:,:) * tmask(:,:,1) 309 ENDIF 247 310 ENDIF 248 311 END DO … … 256 319 CALL lbc_lnk( 'icedyn_adv_pra', pato_i, 'T', 1.0_wp ) 257 320 ! 321 ! --- diagnostics --- ! 322 diag_adv_mass(:,:) = diag_adv_mass(:,:) + ( SUM( pv_i(:,:,:) , dim=3 ) * rhoi + SUM( pv_s(:,:,:) , dim=3 ) * rhos & 323 & - zdiag_adv_mass(:,:) ) * z1_dt 324 diag_adv_salt(:,:) = diag_adv_salt(:,:) + ( SUM( psv_i(:,:,:) , dim=3 ) * rhoi & 325 & - zdiag_adv_salt(:,:) ) * z1_dt 326 diag_adv_heat(:,:) = diag_adv_heat(:,:) + ( - SUM(SUM( pe_i(:,:,1:nlay_i,:) , dim=4 ), dim=3 ) & 327 & - SUM(SUM( pe_s(:,:,1:nlay_s,:) , dim=4 ), dim=3 ) & 328 & - zdiag_adv_heat(:,:) ) * z1_dt 329 ! 258 330 ! --- Ensure non-negative fields --- ! 259 331 ! Remove negative values (conservation is ensured) 260 332 ! (because advected fields are not perfectly bounded and tiny negative values can occur, e.g. -1.e-20) 261 CALL ice_var_zapneg( zdt, pato_i, pv_i, pv_s, psv_i, poa_i, pa_i, pa_ip, pv_ip, p e_s, pe_i )333 CALL ice_var_zapneg( zdt, pato_i, pv_i, pv_s, psv_i, poa_i, pa_i, pa_ip, pv_ip, pv_il, pe_s, pe_i ) 262 334 ! 263 335 ! --- Make sure ice thickness is not too big --- ! 264 336 ! (because ice thickness can be too large where ice concentration is very small) 265 CALL Hbig( zdt, zhi_max, zhs_max, zhip_max, pv_i, pv_s, pa_i, pa_ip, pv_ip, pe_s ) 337 CALL Hbig( zdt, zhi_max, zhs_max, zhip_max, zsi_max, zes_max, zei_max, & 338 & pv_i, pv_s, pa_i, pa_ip, pv_ip, psv_i, pe_s, pe_i ) 266 339 ! 267 340 ! --- Ensure snow load is not too big --- ! … … 292 365 !! 293 366 INTEGER :: ji, jj, jl, jcat ! dummy loop indices 367 INTEGER :: jj0 ! dummy loop indices 294 368 REAL(wp) :: zs1max, zslpmax, ztemp ! local scalars 295 369 REAL(wp) :: zs1new, zalf , zalfq , zbt ! - - 296 370 REAL(wp) :: zs2new, zalf1, zalf1q, zbt1 ! - - 371 REAL(wp) :: zpsm, zps0 372 REAL(wp) :: zpsx, zpsy, zpsxx, zpsyy, zpsxy 297 373 REAL(wp), DIMENSION(jpi,jpj) :: zf0 , zfx , zfy , zbet ! 2D workspace 298 374 REAL(wp), DIMENSION(jpi,jpj) :: zfm , zfxx , zfyy , zfxy ! - - 299 375 REAL(wp), DIMENSION(jpi,jpj) :: zalg, zalg1, zalg1q ! - - 300 376 !----------------------------------------------------------------------- 377 ! in order to avoid lbc_lnk (communications): 378 ! jj loop must be 1:jpj if adv_x is called first 379 ! and 2:jpj-1 if adv_x is called second 380 jj0 = NINT(pcrh) 301 381 ! 302 382 jcat = SIZE( ps0 , 3 ) ! size of input arrays … … 305 385 ! 306 386 ! Limitation of moments. 307 DO_2D( 0, 0, 1, 1 ) 308 ! Initialize volumes of boxes (=area if adv_x first called, =psm otherwise) 309 psm (ji,jj,jl) = MAX( pcrh * e1e2t(ji,jj) + ( 1.0 - pcrh ) * psm(ji,jj,jl) , epsi20 ) 310 ! 311 zslpmax = MAX( 0._wp, ps0(ji,jj,jl) ) 312 zs1max = 1.5 * zslpmax 313 zs1new = MIN( zs1max, MAX( -zs1max, psx(ji,jj,jl) ) ) 314 zs2new = MIN( 2.0 * zslpmax - 0.3334 * ABS( zs1new ), & 315 & MAX( ABS( zs1new ) - zslpmax, psxx(ji,jj,jl) ) ) 316 rswitch = ( 1.0 - MAX( 0._wp, SIGN( 1._wp, -zslpmax) ) ) * tmask(ji,jj,1) ! Case of empty boxes & Apply mask 317 318 ps0 (ji,jj,jl) = zslpmax 319 psx (ji,jj,jl) = zs1new * rswitch 320 psxx(ji,jj,jl) = zs2new * rswitch 321 psy (ji,jj,jl) = psy (ji,jj,jl) * rswitch 322 psyy(ji,jj,jl) = psyy(ji,jj,jl) * rswitch 323 psxy(ji,jj,jl) = MIN( zslpmax, MAX( -zslpmax, psxy(ji,jj,jl) ) ) * rswitch 324 END_2D 325 326 ! Calculate fluxes and moments between boxes i<-->i+1 327 DO_2D( 0, 0, 1, 1 ) 328 zbet(ji,jj) = MAX( 0._wp, SIGN( 1._wp, put(ji,jj) ) ) 329 zalf = MAX( 0._wp, put(ji,jj) ) * pdt / psm(ji,jj,jl) 330 zalfq = zalf * zalf 331 zalf1 = 1.0 - zalf 332 zalf1q = zalf1 * zalf1 333 ! 334 zfm (ji,jj) = zalf * psm (ji,jj,jl) 335 zf0 (ji,jj) = zalf * ( ps0 (ji,jj,jl) + zalf1 * ( psx(ji,jj,jl) + (zalf1 - zalf) * psxx(ji,jj,jl) ) ) 336 zfx (ji,jj) = zalfq * ( psx (ji,jj,jl) + 3.0 * zalf1 * psxx(ji,jj,jl) ) 337 zfxx(ji,jj) = zalf * psxx(ji,jj,jl) * zalfq 338 zfy (ji,jj) = zalf * ( psy (ji,jj,jl) + zalf1 * psxy(ji,jj,jl) ) 339 zfxy(ji,jj) = zalfq * psxy(ji,jj,jl) 340 zfyy(ji,jj) = zalf * psyy(ji,jj,jl) 341 342 ! Readjust moments remaining in the box. 343 psm (ji,jj,jl) = psm (ji,jj,jl) - zfm(ji,jj) 344 ps0 (ji,jj,jl) = ps0 (ji,jj,jl) - zf0(ji,jj) 345 psx (ji,jj,jl) = zalf1q * ( psx(ji,jj,jl) - 3.0 * zalf * psxx(ji,jj,jl) ) 346 psxx(ji,jj,jl) = zalf1 * zalf1q * psxx(ji,jj,jl) 347 psy (ji,jj,jl) = psy (ji,jj,jl) - zfy(ji,jj) 348 psyy(ji,jj,jl) = psyy(ji,jj,jl) - zfyy(ji,jj) 349 psxy(ji,jj,jl) = zalf1q * psxy(ji,jj,jl) 350 END_2D 351 352 DO_2D( 0, 0, 1, 0 ) 353 zalf = MAX( 0._wp, -put(ji,jj) ) * pdt / psm(ji+1,jj,jl) 354 zalg (ji,jj) = zalf 355 zalfq = zalf * zalf 356 zalf1 = 1.0 - zalf 357 zalg1 (ji,jj) = zalf1 358 zalf1q = zalf1 * zalf1 359 zalg1q(ji,jj) = zalf1q 360 ! 361 zfm (ji,jj) = zfm (ji,jj) + zalf * psm (ji+1,jj,jl) 362 zf0 (ji,jj) = zf0 (ji,jj) + zalf * ( ps0 (ji+1,jj,jl) & 363 & - zalf1 * ( psx(ji+1,jj,jl) - (zalf1 - zalf ) * psxx(ji+1,jj,jl) ) ) 364 zfx (ji,jj) = zfx (ji,jj) + zalfq * ( psx (ji+1,jj,jl) - 3.0 * zalf1 * psxx(ji+1,jj,jl) ) 365 zfxx (ji,jj) = zfxx(ji,jj) + zalf * psxx(ji+1,jj,jl) * zalfq 366 zfy (ji,jj) = zfy (ji,jj) + zalf * ( psy (ji+1,jj,jl) - zalf1 * psxy(ji+1,jj,jl) ) 367 zfxy (ji,jj) = zfxy(ji,jj) + zalfq * psxy(ji+1,jj,jl) 368 zfyy (ji,jj) = zfyy(ji,jj) + zalf * psyy(ji+1,jj,jl) 369 END_2D 370 371 DO_2D( 0, 0, 0, 0 ) 372 zbt = zbet(ji-1,jj) 373 zbt1 = 1.0 - zbet(ji-1,jj) 374 ! 375 psm (ji,jj,jl) = zbt * psm(ji,jj,jl) + zbt1 * ( psm(ji,jj,jl) - zfm(ji-1,jj) ) 376 ps0 (ji,jj,jl) = zbt * ps0(ji,jj,jl) + zbt1 * ( ps0(ji,jj,jl) - zf0(ji-1,jj) ) 377 psx (ji,jj,jl) = zalg1q(ji-1,jj) * ( psx(ji,jj,jl) + 3.0 * zalg(ji-1,jj) * psxx(ji,jj,jl) ) 378 psxx(ji,jj,jl) = zalg1 (ji-1,jj) * zalg1q(ji-1,jj) * psxx(ji,jj,jl) 379 psy (ji,jj,jl) = zbt * psy (ji,jj,jl) + zbt1 * ( psy (ji,jj,jl) - zfy (ji-1,jj) ) 380 psyy(ji,jj,jl) = zbt * psyy(ji,jj,jl) + zbt1 * ( psyy(ji,jj,jl) - zfyy(ji-1,jj) ) 381 psxy(ji,jj,jl) = zalg1q(ji-1,jj) * psxy(ji,jj,jl) 382 END_2D 383 384 ! Put the temporary moments into appropriate neighboring boxes. 385 DO_2D( 0, 0, 0, 0 ) 386 zbt = zbet(ji-1,jj) 387 zbt1 = 1.0 - zbet(ji-1,jj) 388 psm(ji,jj,jl) = zbt * ( psm(ji,jj,jl) + zfm(ji-1,jj) ) + zbt1 * psm(ji,jj,jl) 389 zalf = zbt * zfm(ji-1,jj) / psm(ji,jj,jl) 390 zalf1 = 1.0 - zalf 391 ztemp = zalf * ps0(ji,jj,jl) - zalf1 * zf0(ji-1,jj) 392 ! 393 ps0 (ji,jj,jl) = zbt * ( ps0(ji,jj,jl) + zf0(ji-1,jj) ) + zbt1 * ps0(ji,jj,jl) 394 psx (ji,jj,jl) = zbt * ( zalf * zfx(ji-1,jj) + zalf1 * psx(ji,jj,jl) + 3.0 * ztemp ) + zbt1 * psx(ji,jj,jl) 395 psxx(ji,jj,jl) = zbt * ( zalf * zalf * zfxx(ji-1,jj) + zalf1 * zalf1 * psxx(ji,jj,jl) & 396 & + 5.0 * ( zalf * zalf1 * ( psx (ji,jj,jl) - zfx(ji-1,jj) ) - ( zalf1 - zalf ) * ztemp ) ) & 397 & + zbt1 * psxx(ji,jj,jl) 398 psxy(ji,jj,jl) = zbt * ( zalf * zfxy(ji-1,jj) + zalf1 * psxy(ji,jj,jl) & 399 & + 3.0 * (- zalf1*zfy(ji-1,jj) + zalf * psy(ji,jj,jl) ) ) & 400 & + zbt1 * psxy(ji,jj,jl) 401 psy (ji,jj,jl) = zbt * ( psy (ji,jj,jl) + zfy (ji-1,jj) ) + zbt1 * psy (ji,jj,jl) 402 psyy(ji,jj,jl) = zbt * ( psyy(ji,jj,jl) + zfyy(ji-1,jj) ) + zbt1 * psyy(ji,jj,jl) 403 END_2D 404 405 DO_2D( 0, 0, 0, 0 ) 406 zbt = zbet(ji,jj) 407 zbt1 = 1.0 - zbet(ji,jj) 408 psm(ji,jj,jl) = zbt * psm(ji,jj,jl) + zbt1 * ( psm(ji,jj,jl) + zfm(ji,jj) ) 409 zalf = zbt1 * zfm(ji,jj) / psm(ji,jj,jl) 410 zalf1 = 1.0 - zalf 411 ztemp = - zalf * ps0(ji,jj,jl) + zalf1 * zf0(ji,jj) 412 ! 413 ps0 (ji,jj,jl) = zbt * ps0 (ji,jj,jl) + zbt1 * ( ps0(ji,jj,jl) + zf0(ji,jj) ) 414 psx (ji,jj,jl) = zbt * psx (ji,jj,jl) + zbt1 * ( zalf * zfx(ji,jj) + zalf1 * psx(ji,jj,jl) + 3.0 * ztemp ) 415 psxx(ji,jj,jl) = zbt * psxx(ji,jj,jl) + zbt1 * ( zalf * zalf * zfxx(ji,jj) + zalf1 * zalf1 * psxx(ji,jj,jl) & 416 & + 5.0 * ( zalf * zalf1 * ( - psx(ji,jj,jl) + zfx(ji,jj) ) & 417 & + ( zalf1 - zalf ) * ztemp ) ) 418 psxy(ji,jj,jl) = zbt * psxy(ji,jj,jl) + zbt1 * ( zalf * zfxy(ji,jj) + zalf1 * psxy(ji,jj,jl) & 419 & + 3.0 * ( zalf1 * zfy(ji,jj) - zalf * psy(ji,jj,jl) ) ) 420 psy (ji,jj,jl) = zbt * psy (ji,jj,jl) + zbt1 * ( psy (ji,jj,jl) + zfy (ji,jj) ) 421 psyy(ji,jj,jl) = zbt * psyy(ji,jj,jl) + zbt1 * ( psyy(ji,jj,jl) + zfyy(ji,jj) ) 422 END_2D 423 387 DO jj = Njs0 - jj0, Nje0 + jj0 388 389 DO ji = Nis0 - 1, Nie0 + 1 390 391 zpsm = psm (ji,jj,jl) ! optimization 392 zps0 = ps0 (ji,jj,jl) 393 zpsx = psx (ji,jj,jl) 394 zpsxx = psxx(ji,jj,jl) 395 zpsy = psy (ji,jj,jl) 396 zpsyy = psyy(ji,jj,jl) 397 zpsxy = psxy(ji,jj,jl) 398 399 ! Initialize volumes of boxes (=area if adv_x first called, =psm otherwise) 400 zpsm = MAX( pcrh * e1e2t(ji,jj) + ( 1.0 - pcrh ) * zpsm , epsi20 ) 401 ! 402 zslpmax = MAX( 0._wp, zps0 ) 403 zs1max = 1.5 * zslpmax 404 zs1new = MIN( zs1max, MAX( -zs1max, zpsx ) ) 405 zs2new = MIN( 2.0 * zslpmax - 0.3334 * ABS( zs1new ), MAX( ABS( zs1new ) - zslpmax, zpsxx ) ) 406 rswitch = ( 1.0 - MAX( 0._wp, SIGN( 1._wp, -zslpmax) ) ) * tmask(ji,jj,1) ! Case of empty boxes & Apply mask 407 408 zps0 = zslpmax 409 zpsx = zs1new * rswitch 410 zpsxx = zs2new * rswitch 411 zpsy = zpsy * rswitch 412 zpsyy = zpsyy * rswitch 413 zpsxy = MIN( zslpmax, MAX( -zslpmax, zpsxy ) ) * rswitch 414 415 ! Calculate fluxes and moments between boxes i<-->i+1 416 ! ! Flux from i to i+1 WHEN u GT 0 417 zbet(ji,jj) = MAX( 0._wp, SIGN( 1._wp, put(ji,jj) ) ) 418 zalf = MAX( 0._wp, put(ji,jj) ) * pdt / zpsm 419 zalfq = zalf * zalf 420 zalf1 = 1.0 - zalf 421 zalf1q = zalf1 * zalf1 422 ! 423 zfm (ji,jj) = zalf * zpsm 424 zf0 (ji,jj) = zalf * ( zps0 + zalf1 * ( zpsx + (zalf1 - zalf) * zpsxx ) ) 425 zfx (ji,jj) = zalfq * ( zpsx + 3.0 * zalf1 * zpsxx ) 426 zfxx(ji,jj) = zalf * zpsxx * zalfq 427 zfy (ji,jj) = zalf * ( zpsy + zalf1 * zpsxy ) 428 zfxy(ji,jj) = zalfq * zpsxy 429 zfyy(ji,jj) = zalf * zpsyy 430 431 ! ! Readjust moments remaining in the box. 432 zpsm = zpsm - zfm(ji,jj) 433 zps0 = zps0 - zf0(ji,jj) 434 zpsx = zalf1q * ( zpsx - 3.0 * zalf * zpsxx ) 435 zpsxx = zalf1 * zalf1q * zpsxx 436 zpsy = zpsy - zfy (ji,jj) 437 zpsyy = zpsyy - zfyy(ji,jj) 438 zpsxy = zalf1q * zpsxy 439 ! 440 psm (ji,jj,jl) = zpsm ! optimization 441 ps0 (ji,jj,jl) = zps0 442 psx (ji,jj,jl) = zpsx 443 psxx(ji,jj,jl) = zpsxx 444 psy (ji,jj,jl) = zpsy 445 psyy(ji,jj,jl) = zpsyy 446 psxy(ji,jj,jl) = zpsxy 447 ! 448 END DO 449 450 DO ji = Nis0 - 1, Nie0 451 ! ! Flux from i+1 to i when u LT 0. 452 zalf = MAX( 0._wp, -put(ji,jj) ) * pdt / psm(ji+1,jj,jl) 453 zalg (ji,jj) = zalf 454 zalfq = zalf * zalf 455 zalf1 = 1.0 - zalf 456 zalg1 (ji,jj) = zalf1 457 zalf1q = zalf1 * zalf1 458 zalg1q(ji,jj) = zalf1q 459 ! 460 zfm (ji,jj) = zfm (ji,jj) + zalf * psm (ji+1,jj,jl) 461 zf0 (ji,jj) = zf0 (ji,jj) + zalf * ( ps0 (ji+1,jj,jl) & 462 & - zalf1 * ( psx(ji+1,jj,jl) - (zalf1 - zalf ) * psxx(ji+1,jj,jl) ) ) 463 zfx (ji,jj) = zfx (ji,jj) + zalfq * ( psx (ji+1,jj,jl) - 3.0 * zalf1 * psxx(ji+1,jj,jl) ) 464 zfxx (ji,jj) = zfxx(ji,jj) + zalf * psxx(ji+1,jj,jl) * zalfq 465 zfy (ji,jj) = zfy (ji,jj) + zalf * ( psy (ji+1,jj,jl) - zalf1 * psxy(ji+1,jj,jl) ) 466 zfxy (ji,jj) = zfxy(ji,jj) + zalfq * psxy(ji+1,jj,jl) 467 zfyy (ji,jj) = zfyy(ji,jj) + zalf * psyy(ji+1,jj,jl) 468 END DO 469 470 DO ji = Nis0, Nie0 471 ! 472 zpsm = psm (ji,jj,jl) ! optimization 473 zps0 = ps0 (ji,jj,jl) 474 zpsx = psx (ji,jj,jl) 475 zpsxx = psxx(ji,jj,jl) 476 zpsy = psy (ji,jj,jl) 477 zpsyy = psyy(ji,jj,jl) 478 zpsxy = psxy(ji,jj,jl) 479 ! ! Readjust moments remaining in the box. 480 zbt = zbet(ji-1,jj) 481 zbt1 = 1.0 - zbet(ji-1,jj) 482 ! 483 zpsm = zbt * zpsm + zbt1 * ( zpsm - zfm(ji-1,jj) ) 484 zps0 = zbt * zps0 + zbt1 * ( zps0 - zf0(ji-1,jj) ) 485 zpsx = zalg1q(ji-1,jj) * ( zpsx + 3.0 * zalg(ji-1,jj) * zpsxx ) 486 zpsxx = zalg1 (ji-1,jj) * zalg1q(ji-1,jj) * zpsxx 487 zpsy = zbt * zpsy + zbt1 * ( zpsy - zfy (ji-1,jj) ) 488 zpsyy = zbt * zpsyy + zbt1 * ( zpsyy - zfyy(ji-1,jj) ) 489 zpsxy = zalg1q(ji-1,jj) * zpsxy 490 491 ! Put the temporary moments into appropriate neighboring boxes. 492 ! ! Flux from i to i+1 IF u GT 0. 493 zbt = zbet(ji-1,jj) 494 zbt1 = 1.0 - zbet(ji-1,jj) 495 zpsm = zbt * ( zpsm + zfm(ji-1,jj) ) + zbt1 * zpsm 496 zalf = zbt * zfm(ji-1,jj) / zpsm 497 zalf1 = 1.0 - zalf 498 ztemp = zalf * zps0 - zalf1 * zf0(ji-1,jj) 499 ! 500 zps0 = zbt * ( zps0 + zf0(ji-1,jj) ) + zbt1 * zps0 501 zpsx = zbt * ( zalf * zfx(ji-1,jj) + zalf1 * zpsx + 3.0 * ztemp ) + zbt1 * zpsx 502 zpsxx = zbt * ( zalf * zalf * zfxx(ji-1,jj) + zalf1 * zalf1 * zpsxx & 503 & + 5.0 * ( zalf * zalf1 * ( zpsx - zfx(ji-1,jj) ) - ( zalf1 - zalf ) * ztemp ) ) & 504 & + zbt1 * zpsxx 505 zpsxy = zbt * ( zalf * zfxy(ji-1,jj) + zalf1 * zpsxy & 506 & + 3.0 * (- zalf1*zfy(ji-1,jj) + zalf * zpsy ) ) & 507 & + zbt1 * zpsxy 508 zpsy = zbt * ( zpsy + zfy (ji-1,jj) ) + zbt1 * zpsy 509 zpsyy = zbt * ( zpsyy + zfyy(ji-1,jj) ) + zbt1 * zpsyy 510 511 ! ! Flux from i+1 to i IF u LT 0. 512 zbt = zbet(ji,jj) 513 zbt1 = 1.0 - zbet(ji,jj) 514 zpsm = zbt * zpsm + zbt1 * ( zpsm + zfm(ji,jj) ) 515 zalf = zbt1 * zfm(ji,jj) / zpsm 516 zalf1 = 1.0 - zalf 517 ztemp = - zalf * zps0 + zalf1 * zf0(ji,jj) 518 ! 519 zps0 = zbt * zps0 + zbt1 * ( zps0 + zf0(ji,jj) ) 520 zpsx = zbt * zpsx + zbt1 * ( zalf * zfx(ji,jj) + zalf1 * zpsx + 3.0 * ztemp ) 521 zpsxx = zbt * zpsxx + zbt1 * ( zalf * zalf * zfxx(ji,jj) + zalf1 * zalf1 * zpsxx & 522 & + 5.0 * ( zalf * zalf1 * ( - zpsx + zfx(ji,jj) ) & 523 & + ( zalf1 - zalf ) * ztemp ) ) 524 zpsxy = zbt * zpsxy + zbt1 * ( zalf * zfxy(ji,jj) + zalf1 * zpsxy & 525 & + 3.0 * ( zalf1 * zfy(ji,jj) - zalf * zpsy ) ) 526 zpsy = zbt * zpsy + zbt1 * ( zpsy + zfy (ji,jj) ) 527 zpsyy = zbt * zpsyy + zbt1 * ( zpsyy + zfyy(ji,jj) ) 528 ! 529 psm (ji,jj,jl) = zpsm ! optimization 530 ps0 (ji,jj,jl) = zps0 531 psx (ji,jj,jl) = zpsx 532 psxx(ji,jj,jl) = zpsxx 533 psy (ji,jj,jl) = zpsy 534 psyy(ji,jj,jl) = zpsyy 535 psxy(ji,jj,jl) = zpsxy 536 END DO 537 ! 538 END DO 539 ! 424 540 END DO 425 426 !-- Lateral boundary conditions 427 CALL lbc_lnk_multi( 'icedyn_adv_pra', psm(:,:,1:jcat) , 'T', 1.0_wp, ps0 , 'T', 1.0_wp & 428 & , psx , 'T', -1.0_wp, psy , 'T', -1.0_wp & ! caution gradient ==> the sign changes 429 & , psxx , 'T', 1.0_wp, psyy, 'T', 1.0_wp , psxy, 'T', 1.0_wp ) 430 ! 541 ! 431 542 END SUBROUTINE adv_x 432 543 … … 449 560 !! 450 561 INTEGER :: ji, jj, jl, jcat ! dummy loop indices 562 INTEGER :: ji0 ! dummy loop indices 451 563 REAL(wp) :: zs1max, zslpmax, ztemp ! temporary scalars 452 564 REAL(wp) :: zs1new, zalf , zalfq , zbt ! - - 453 565 REAL(wp) :: zs2new, zalf1, zalf1q, zbt1 ! - - 566 REAL(wp) :: zpsm, zps0 567 REAL(wp) :: zpsx, zpsy, zpsxx, zpsyy, zpsxy 454 568 REAL(wp), DIMENSION(jpi,jpj) :: zf0, zfx , zfy , zbet ! 2D workspace 455 569 REAL(wp), DIMENSION(jpi,jpj) :: zfm, zfxx, zfyy, zfxy ! - - 456 570 REAL(wp), DIMENSION(jpi,jpj) :: zalg, zalg1, zalg1q ! - - 457 571 !--------------------------------------------------------------------- 572 ! in order to avoid lbc_lnk (communications): 573 ! ji loop must be 1:jpi if adv_y is called first 574 ! and 2:jpi-1 if adv_y is called second 575 ji0 = NINT(pcrh) 458 576 ! 459 577 jcat = SIZE( ps0 , 3 ) ! size of input arrays … … 462 580 ! 463 581 ! Limitation of moments. 464 DO_2D( 1, 1, 0, 0 ) 465 ! Initialize volumes of boxes (=area if adv_x first called, =psm otherwise) 466 psm(ji,jj,jl) = MAX( pcrh * e1e2t(ji,jj) + ( 1.0 - pcrh ) * psm(ji,jj,jl) , epsi20 ) 467 ! 468 zslpmax = MAX( 0._wp, ps0(ji,jj,jl) ) 582 DO_2D( 1, 1, ji0, ji0 ) 583 ! 584 zpsm = psm (ji,jj,jl) ! optimization 585 zps0 = ps0 (ji,jj,jl) 586 zpsx = psx (ji,jj,jl) 587 zpsxx = psxx(ji,jj,jl) 588 zpsy = psy (ji,jj,jl) 589 zpsyy = psyy(ji,jj,jl) 590 zpsxy = psxy(ji,jj,jl) 591 ! 592 ! Initialize volumes of boxes (=area if adv_y first called, =psm otherwise) 593 zpsm = MAX( pcrh * e1e2t(ji,jj) + ( 1.0 - pcrh ) * zpsm , epsi20 ) 594 ! 595 zslpmax = MAX( 0._wp, zps0 ) 469 596 zs1max = 1.5 * zslpmax 470 zs1new = MIN( zs1max, MAX( -zs1max, psy(ji,jj,jl) ) ) 471 zs2new = MIN( ( 2.0 * zslpmax - 0.3334 * ABS( zs1new ) ), & 472 & MAX( ABS( zs1new )-zslpmax, psyy(ji,jj,jl) ) ) 597 zs1new = MIN( zs1max, MAX( -zs1max, zpsy ) ) 598 zs2new = MIN( ( 2.0 * zslpmax - 0.3334 * ABS( zs1new ) ), MAX( ABS( zs1new )-zslpmax, zpsyy ) ) 473 599 rswitch = ( 1.0 - MAX( 0._wp, SIGN( 1._wp, -zslpmax) ) ) * tmask(ji,jj,1) ! Case of empty boxes & Apply mask 474 600 ! 475 ps0 (ji,jj,jl) = zslpmax 476 psx (ji,jj,jl) = psx (ji,jj,jl) * rswitch 477 psxx(ji,jj,jl) = psxx(ji,jj,jl) * rswitch 478 psy (ji,jj,jl) = zs1new * rswitch 479 psyy(ji,jj,jl) = zs2new * rswitch 480 psxy(ji,jj,jl) = MIN( zslpmax, MAX( -zslpmax, psxy(ji,jj,jl) ) ) * rswitch 481 END_2D 482 483 ! Calculate fluxes and moments between boxes j<-->j+1 484 DO_2D( 1, 1, 0, 0 ) 601 zps0 = zslpmax 602 zpsx = zpsx * rswitch 603 zpsxx = zpsxx * rswitch 604 zpsy = zs1new * rswitch 605 zpsyy = zs2new * rswitch 606 zpsxy = MIN( zslpmax, MAX( -zslpmax, zpsxy ) ) * rswitch 607 608 ! Calculate fluxes and moments between boxes j<-->j+1 609 ! ! Flux from j to j+1 WHEN v GT 0 485 610 zbet(ji,jj) = MAX( 0._wp, SIGN( 1._wp, pvt(ji,jj) ) ) 486 zalf = MAX( 0._wp, pvt(ji,jj) ) * pdt / psm(ji,jj,jl)611 zalf = MAX( 0._wp, pvt(ji,jj) ) * pdt / zpsm 487 612 zalfq = zalf * zalf 488 613 zalf1 = 1.0 - zalf 489 614 zalf1q = zalf1 * zalf1 490 615 ! 491 zfm (ji,jj) = zalf * psm(ji,jj,jl) 492 zf0 (ji,jj) = zalf * ( ps0(ji,jj,jl) + zalf1 * ( psy(ji,jj,jl) + (zalf1-zalf) * psyy(ji,jj,jl) ) ) 493 zfy (ji,jj) = zalfq *( psy(ji,jj,jl) + 3.0*zalf1*psyy(ji,jj,jl) ) 494 zfyy(ji,jj) = zalf * zalfq * psyy(ji,jj,jl) 495 zfx (ji,jj) = zalf * ( psx(ji,jj,jl) + zalf1 * psxy(ji,jj,jl) ) 496 zfxy(ji,jj) = zalfq * psxy(ji,jj,jl) 497 zfxx(ji,jj) = zalf * psxx(ji,jj,jl) 498 ! 499 ! Readjust moments remaining in the box. 500 psm (ji,jj,jl) = psm (ji,jj,jl) - zfm(ji,jj) 501 ps0 (ji,jj,jl) = ps0 (ji,jj,jl) - zf0(ji,jj) 502 psy (ji,jj,jl) = zalf1q * ( psy(ji,jj,jl) -3.0 * zalf * psyy(ji,jj,jl) ) 503 psyy(ji,jj,jl) = zalf1 * zalf1q * psyy(ji,jj,jl) 504 psx (ji,jj,jl) = psx (ji,jj,jl) - zfx(ji,jj) 505 psxx(ji,jj,jl) = psxx(ji,jj,jl) - zfxx(ji,jj) 506 psxy(ji,jj,jl) = zalf1q * psxy(ji,jj,jl) 616 zfm (ji,jj) = zalf * zpsm 617 zf0 (ji,jj) = zalf * ( zps0 + zalf1 * ( zpsy + (zalf1-zalf) * zpsyy ) ) 618 zfy (ji,jj) = zalfq *( zpsy + 3.0*zalf1*zpsyy ) 619 zfyy(ji,jj) = zalf * zalfq * zpsyy 620 zfx (ji,jj) = zalf * ( zpsx + zalf1 * zpsxy ) 621 zfxy(ji,jj) = zalfq * zpsxy 622 zfxx(ji,jj) = zalf * zpsxx 623 ! 624 ! ! Readjust moments remaining in the box. 625 zpsm = zpsm - zfm(ji,jj) 626 zps0 = zps0 - zf0(ji,jj) 627 zpsy = zalf1q * ( zpsy -3.0 * zalf * zpsyy ) 628 zpsyy = zalf1 * zalf1q * zpsyy 629 zpsx = zpsx - zfx(ji,jj) 630 zpsxx = zpsxx - zfxx(ji,jj) 631 zpsxy = zalf1q * zpsxy 632 ! 633 psm (ji,jj,jl) = zpsm ! optimization 634 ps0 (ji,jj,jl) = zps0 635 psx (ji,jj,jl) = zpsx 636 psxx(ji,jj,jl) = zpsxx 637 psy (ji,jj,jl) = zpsy 638 psyy(ji,jj,jl) = zpsyy 639 psxy(ji,jj,jl) = zpsxy 507 640 END_2D 508 641 ! 509 DO_2D( 1, 0, 0, 0 ) 642 DO_2D( 1, 0, ji0, ji0 ) 643 ! ! Flux from j+1 to j when v LT 0. 510 644 zalf = MAX( 0._wp, -pvt(ji,jj) ) * pdt / psm(ji,jj+1,jl) 511 645 zalg (ji,jj) = zalf … … 526 660 END_2D 527 661 528 ! Readjust moments remaining in the box.529 DO_2D( 0, 0, 0, 0 )662 DO_2D( 0, 0, ji0, ji0 ) 663 ! ! Readjust moments remaining in the box. 530 664 zbt = zbet(ji,jj-1) 531 665 zbt1 = ( 1.0 - zbet(ji,jj-1) ) 532 666 ! 533 psm (ji,jj,jl) = zbt * psm(ji,jj,jl) + zbt1 * ( psm(ji,jj,jl) - zfm(ji,jj-1) ) 534 ps0 (ji,jj,jl) = zbt * ps0(ji,jj,jl) + zbt1 * ( ps0(ji,jj,jl) - zf0(ji,jj-1) ) 535 psy (ji,jj,jl) = zalg1q(ji,jj-1) * ( psy(ji,jj,jl) + 3.0 * zalg(ji,jj-1) * psyy(ji,jj,jl) ) 536 psyy(ji,jj,jl) = zalg1 (ji,jj-1) * zalg1q(ji,jj-1) * psyy(ji,jj,jl) 537 psx (ji,jj,jl) = zbt * psx (ji,jj,jl) + zbt1 * ( psx (ji,jj,jl) - zfx (ji,jj-1) ) 538 psxx(ji,jj,jl) = zbt * psxx(ji,jj,jl) + zbt1 * ( psxx(ji,jj,jl) - zfxx(ji,jj-1) ) 539 psxy(ji,jj,jl) = zalg1q(ji,jj-1) * psxy(ji,jj,jl) 667 zpsm = psm (ji,jj,jl) ! optimization 668 zps0 = ps0 (ji,jj,jl) 669 zpsx = psx (ji,jj,jl) 670 zpsxx = psxx(ji,jj,jl) 671 zpsy = psy (ji,jj,jl) 672 zpsyy = psyy(ji,jj,jl) 673 zpsxy = psxy(ji,jj,jl) 674 ! 675 zpsm = zbt * zpsm + zbt1 * ( zpsm - zfm(ji,jj-1) ) 676 zps0 = zbt * zps0 + zbt1 * ( zps0 - zf0(ji,jj-1) ) 677 zpsy = zalg1q(ji,jj-1) * ( zpsy + 3.0 * zalg(ji,jj-1) * zpsyy ) 678 zpsyy = zalg1 (ji,jj-1) * zalg1q(ji,jj-1) * zpsyy 679 zpsx = zbt * zpsx + zbt1 * ( zpsx - zfx (ji,jj-1) ) 680 zpsxx = zbt * zpsxx + zbt1 * ( zpsxx - zfxx(ji,jj-1) ) 681 zpsxy = zalg1q(ji,jj-1) * zpsxy 682 683 ! Put the temporary moments into appropriate neighboring boxes. 684 ! ! Flux from j to j+1 IF v GT 0. 685 zbt = zbet(ji,jj-1) 686 zbt1 = 1.0 - zbet(ji,jj-1) 687 zpsm = zbt * ( zpsm + zfm(ji,jj-1) ) + zbt1 * zpsm 688 zalf = zbt * zfm(ji,jj-1) / zpsm 689 zalf1 = 1.0 - zalf 690 ztemp = zalf * zps0 - zalf1 * zf0(ji,jj-1) 691 ! 692 zps0 = zbt * ( zps0 + zf0(ji,jj-1) ) + zbt1 * zps0 693 zpsy = zbt * ( zalf * zfy(ji,jj-1) + zalf1 * zpsy + 3.0 * ztemp ) & 694 & + zbt1 * zpsy 695 zpsyy = zbt * ( zalf * zalf * zfyy(ji,jj-1) + zalf1 * zalf1 * zpsyy & 696 & + 5.0 * ( zalf * zalf1 * ( zpsy - zfy(ji,jj-1) ) - ( zalf1 - zalf ) * ztemp ) ) & 697 & + zbt1 * zpsyy 698 zpsxy = zbt * ( zalf * zfxy(ji,jj-1) + zalf1 * zpsxy & 699 & + 3.0 * (- zalf1 * zfx(ji,jj-1) + zalf * zpsx ) ) & 700 & + zbt1 * zpsxy 701 zpsx = zbt * ( zpsx + zfx (ji,jj-1) ) + zbt1 * zpsx 702 zpsxx = zbt * ( zpsxx + zfxx(ji,jj-1) ) + zbt1 * zpsxx 703 704 ! ! Flux from j+1 to j IF v LT 0. 705 zbt = zbet(ji,jj) 706 zbt1 = 1.0 - zbet(ji,jj) 707 zpsm = zbt * zpsm + zbt1 * ( zpsm + zfm(ji,jj) ) 708 zalf = zbt1 * zfm(ji,jj) / zpsm 709 zalf1 = 1.0 - zalf 710 ztemp = - zalf * zps0 + zalf1 * zf0(ji,jj) 711 ! 712 zps0 = zbt * zps0 + zbt1 * ( zps0 + zf0(ji,jj) ) 713 zpsy = zbt * zpsy + zbt1 * ( zalf * zfy(ji,jj) + zalf1 * zpsy + 3.0 * ztemp ) 714 zpsyy = zbt * zpsyy + zbt1 * ( zalf * zalf * zfyy(ji,jj) + zalf1 * zalf1 * zpsyy & 715 & + 5.0 * ( zalf * zalf1 * ( - zpsy + zfy(ji,jj) ) & 716 & + ( zalf1 - zalf ) * ztemp ) ) 717 zpsxy = zbt * zpsxy + zbt1 * ( zalf * zfxy(ji,jj) + zalf1 * zpsxy & 718 & + 3.0 * ( zalf1 * zfx(ji,jj) - zalf * zpsx ) ) 719 zpsx = zbt * zpsx + zbt1 * ( zpsx + zfx (ji,jj) ) 720 zpsxx = zbt * zpsxx + zbt1 * ( zpsxx + zfxx(ji,jj) ) 721 ! 722 psm (ji,jj,jl) = zpsm ! optimization 723 ps0 (ji,jj,jl) = zps0 724 psx (ji,jj,jl) = zpsx 725 psxx(ji,jj,jl) = zpsxx 726 psy (ji,jj,jl) = zpsy 727 psyy(ji,jj,jl) = zpsyy 728 psxy(ji,jj,jl) = zpsxy 540 729 END_2D 541 542 ! Put the temporary moments into appropriate neighboring boxes. 543 DO_2D( 0, 0, 0, 0 ) 544 zbt = zbet(ji,jj-1) 545 zbt1 = 1.0 - zbet(ji,jj-1) 546 psm(ji,jj,jl) = zbt * ( psm(ji,jj,jl) + zfm(ji,jj-1) ) + zbt1 * psm(ji,jj,jl) 547 zalf = zbt * zfm(ji,jj-1) / psm(ji,jj,jl) 548 zalf1 = 1.0 - zalf 549 ztemp = zalf * ps0(ji,jj,jl) - zalf1 * zf0(ji,jj-1) 550 ! 551 ps0(ji,jj,jl) = zbt * ( ps0(ji,jj,jl) + zf0(ji,jj-1) ) + zbt1 * ps0(ji,jj,jl) 552 psy(ji,jj,jl) = zbt * ( zalf * zfy(ji,jj-1) + zalf1 * psy(ji,jj,jl) + 3.0 * ztemp ) & 553 & + zbt1 * psy(ji,jj,jl) 554 psyy(ji,jj,jl) = zbt * ( zalf * zalf * zfyy(ji,jj-1) + zalf1 * zalf1 * psyy(ji,jj,jl) & 555 & + 5.0 * ( zalf * zalf1 * ( psy(ji,jj,jl) - zfy(ji,jj-1) ) - ( zalf1 - zalf ) * ztemp ) ) & 556 & + zbt1 * psyy(ji,jj,jl) 557 psxy(ji,jj,jl) = zbt * ( zalf * zfxy(ji,jj-1) + zalf1 * psxy(ji,jj,jl) & 558 & + 3.0 * (- zalf1 * zfx(ji,jj-1) + zalf * psx(ji,jj,jl) ) ) & 559 & + zbt1 * psxy(ji,jj,jl) 560 psx (ji,jj,jl) = zbt * ( psx (ji,jj,jl) + zfx (ji,jj-1) ) + zbt1 * psx (ji,jj,jl) 561 psxx(ji,jj,jl) = zbt * ( psxx(ji,jj,jl) + zfxx(ji,jj-1) ) + zbt1 * psxx(ji,jj,jl) 562 END_2D 563 564 DO_2D( 0, 0, 0, 0 ) 565 zbt = zbet(ji,jj) 566 zbt1 = 1.0 - zbet(ji,jj) 567 psm(ji,jj,jl) = zbt * psm(ji,jj,jl) + zbt1 * ( psm(ji,jj,jl) + zfm(ji,jj) ) 568 zalf = zbt1 * zfm(ji,jj) / psm(ji,jj,jl) 569 zalf1 = 1.0 - zalf 570 ztemp = - zalf * ps0(ji,jj,jl) + zalf1 * zf0(ji,jj) 571 ! 572 ps0 (ji,jj,jl) = zbt * ps0 (ji,jj,jl) + zbt1 * ( ps0(ji,jj,jl) + zf0(ji,jj) ) 573 psy (ji,jj,jl) = zbt * psy (ji,jj,jl) + zbt1 * ( zalf * zfy(ji,jj) + zalf1 * psy(ji,jj,jl) + 3.0 * ztemp ) 574 psyy(ji,jj,jl) = zbt * psyy(ji,jj,jl) + zbt1 * ( zalf * zalf * zfyy(ji,jj) + zalf1 * zalf1 * psyy(ji,jj,jl) & 575 & + 5.0 * ( zalf * zalf1 * ( - psy(ji,jj,jl) + zfy(ji,jj) ) & 576 & + ( zalf1 - zalf ) * ztemp ) ) 577 psxy(ji,jj,jl) = zbt * psxy(ji,jj,jl) + zbt1 * ( zalf * zfxy(ji,jj) + zalf1 * psxy(ji,jj,jl) & 578 & + 3.0 * ( zalf1 * zfx(ji,jj) - zalf * psx(ji,jj,jl) ) ) 579 psx (ji,jj,jl) = zbt * psx (ji,jj,jl) + zbt1 * ( psx (ji,jj,jl) + zfx (ji,jj) ) 580 psxx(ji,jj,jl) = zbt * psxx(ji,jj,jl) + zbt1 * ( psxx(ji,jj,jl) + zfxx(ji,jj) ) 581 END_2D 582 730 ! 583 731 END DO 584 585 !-- Lateral boundary conditions586 CALL lbc_lnk_multi( 'icedyn_adv_pra', psm(:,:,1:jcat) , 'T', 1.0_wp, ps0 , 'T', 1.0_wp &587 & , psx , 'T', -1.0_wp, psy , 'T', -1.0_wp & ! caution gradient ==> the sign changes588 & , psxx , 'T', 1.0_wp, psyy, 'T', 1.0_wp , psxy, 'T', 1.0_wp )589 732 ! 590 733 END SUBROUTINE adv_y 591 734 592 735 593 SUBROUTINE Hbig( pdt, phi_max, phs_max, phip_max, pv_i, pv_s, pa_i, pa_ip, pv_ip, pe_s ) 736 SUBROUTINE Hbig( pdt, phi_max, phs_max, phip_max, psi_max, pes_max, pei_max, & 737 & pv_i, pv_s, pa_i, pa_ip, pv_ip, psv_i, pe_s, pe_i ) 594 738 !!------------------------------------------------------------------- 595 739 !! *** ROUTINE Hbig *** … … 605 749 !! ** input : Max thickness of the surrounding 9-points 606 750 !!------------------------------------------------------------------- 607 REAL(wp) , INTENT(in ) :: pdt ! tracer time-step 608 REAL(wp), DIMENSION(:,:,:) , INTENT(in ) :: phi_max, phs_max, phip_max ! max ice thick from surrounding 9-pts 609 REAL(wp), DIMENSION(:,:,:) , INTENT(inout) :: pv_i, pv_s, pa_i, pa_ip, pv_ip 751 REAL(wp) , INTENT(in ) :: pdt ! tracer time-step 752 REAL(wp), DIMENSION(:,:,:) , INTENT(in ) :: phi_max, phs_max, phip_max, psi_max ! max ice thick from surrounding 9-pts 753 REAL(wp), DIMENSION(:,:,:,:), INTENT(in ) :: pes_max 754 REAL(wp), DIMENSION(:,:,:,:), INTENT(in ) :: pei_max 755 REAL(wp), DIMENSION(:,:,:) , INTENT(inout) :: pv_i, pv_s, pa_i, pa_ip, pv_ip, psv_i 610 756 REAL(wp), DIMENSION(:,:,:,:), INTENT(inout) :: pe_s 611 ! 612 INTEGER :: ji, jj, jl ! dummy loop indices 613 REAL(wp) :: z1_dt, zhip, zhi, zhs, zfra 757 REAL(wp), DIMENSION(:,:,:,:), INTENT(inout) :: pe_i 758 ! 759 INTEGER :: ji, jj, jk, jl ! dummy loop indices 760 REAL(wp) :: z1_dt, zhip, zhi, zhs, zsi, zes, zei, zfra 614 761 !!------------------------------------------------------------------- 615 762 ! … … 617 764 ! 618 765 DO jl = 1, jpl 619 620 766 DO_2D( 1, 1, 1, 1 ) 621 767 IF ( pv_i(ji,jj,jl) > 0._wp ) THEN … … 623 769 ! ! -- check h_ip -- ! 624 770 ! if h_ip is larger than the surrounding 9 pts => reduce h_ip and increase a_ip 625 IF( ln_pnd_ H12.AND. pv_ip(ji,jj,jl) > 0._wp ) THEN771 IF( ln_pnd_LEV .AND. pv_ip(ji,jj,jl) > 0._wp ) THEN 626 772 zhip = pv_ip(ji,jj,jl) / MAX( epsi20, pa_ip(ji,jj,jl) ) 627 773 IF( zhip > phip_max(ji,jj,jl) .AND. pa_ip(ji,jj,jl) < 0.15 ) THEN … … 650 796 ENDIF 651 797 ! 798 ! ! -- check s_i -- ! 799 ! if s_i is larger than the surrounding 9 pts => put salt excess in the ocean 800 zsi = psv_i(ji,jj,jl) / pv_i(ji,jj,jl) 801 IF( zsi > psi_max(ji,jj,jl) .AND. pa_i(ji,jj,jl) < 0.15 ) THEN 802 zfra = psi_max(ji,jj,jl) / zsi 803 sfx_res(ji,jj) = sfx_res(ji,jj) + psv_i(ji,jj,jl) * ( 1._wp - zfra ) * rhoi * z1_dt 804 psv_i(ji,jj,jl) = psv_i(ji,jj,jl) * zfra 805 ENDIF 806 ! 652 807 ENDIF 653 808 END_2D 654 809 END DO 810 ! 811 ! ! -- check e_i/v_i -- ! 812 DO jl = 1, jpl 813 DO_3D( 1, 1, 1, 1, 1, nlay_i ) 814 IF ( pv_i(ji,jj,jl) > 0._wp ) THEN 815 ! if e_i/v_i is larger than the surrounding 9 pts => put the heat excess in the ocean 816 zei = pe_i(ji,jj,jk,jl) / pv_i(ji,jj,jl) 817 IF( zei > pei_max(ji,jj,jk,jl) .AND. pa_i(ji,jj,jl) < 0.15 ) THEN 818 zfra = pei_max(ji,jj,jk,jl) / zei 819 hfx_res(ji,jj) = hfx_res(ji,jj) - pe_i(ji,jj,jk,jl) * ( 1._wp - zfra ) * z1_dt ! W.m-2 <0 820 pe_i(ji,jj,jk,jl) = pe_i(ji,jj,jk,jl) * zfra 821 ENDIF 822 ENDIF 823 END_3D 824 END DO 825 ! ! -- check e_s/v_s -- ! 826 DO jl = 1, jpl 827 DO_3D( 1, 1, 1, 1, 1, nlay_s ) 828 IF ( pv_s(ji,jj,jl) > 0._wp ) THEN 829 ! if e_s/v_s is larger than the surrounding 9 pts => put the heat excess in the ocean 830 zes = pe_s(ji,jj,jk,jl) / pv_s(ji,jj,jl) 831 IF( zes > pes_max(ji,jj,jk,jl) .AND. pa_i(ji,jj,jl) < 0.15 ) THEN 832 zfra = pes_max(ji,jj,jk,jl) / zes 833 hfx_res(ji,jj) = hfx_res(ji,jj) - pe_s(ji,jj,jk,jl) * ( 1._wp - zfra ) * z1_dt ! W.m-2 <0 834 pe_s(ji,jj,jk,jl) = pe_s(ji,jj,jk,jl) * zfra 835 ENDIF 836 ENDIF 837 END_3D 838 END DO 655 839 ! 656 840 END SUBROUTINE Hbig … … 724 908 & sxsal(jpi,jpj,jpl) , sysal(jpi,jpj,jpl) , sxxsal(jpi,jpj,jpl) , syysal(jpi,jpj,jpl) , sxysal(jpi,jpj,jpl) , & 725 909 & sxage(jpi,jpj,jpl) , syage(jpi,jpj,jpl) , sxxage(jpi,jpj,jpl) , syyage(jpi,jpj,jpl) , sxyage(jpi,jpj,jpl) , & 726 & sxap(jpi,jpj,jpl) , syap (jpi,jpj,jpl) , sxxap (jpi,jpj,jpl) , syyap (jpi,jpj,jpl) , sxyap (jpi,jpj,jpl) , & 727 & sxvp(jpi,jpj,jpl) , syvp (jpi,jpj,jpl) , sxxvp (jpi,jpj,jpl) , syyvp (jpi,jpj,jpl) , sxyvp (jpi,jpj,jpl) , & 910 & sxap (jpi,jpj,jpl) , syap (jpi,jpj,jpl) , sxxap (jpi,jpj,jpl) , syyap (jpi,jpj,jpl) , sxyap (jpi,jpj,jpl) , & 911 & sxvp (jpi,jpj,jpl) , syvp (jpi,jpj,jpl) , sxxvp (jpi,jpj,jpl) , syyvp (jpi,jpj,jpl) , sxyvp (jpi,jpj,jpl) , & 912 & sxvl (jpi,jpj,jpl) , syvl (jpi,jpj,jpl) , sxxvl (jpi,jpj,jpl) , syyvl (jpi,jpj,jpl) , sxyvl (jpi,jpj,jpl) , & 728 913 ! 729 914 & sxc0 (jpi,jpj,nlay_s,jpl) , syc0 (jpi,jpj,nlay_s,jpl) , sxxc0(jpi,jpj,nlay_s,jpl) , & … … 772 957 ! 773 958 ! ! ice thickness 774 CALL iom_get( numrir, jpdom_auto, 'sxice' , sxice )775 CALL iom_get( numrir, jpdom_auto, 'syice' , syice )959 CALL iom_get( numrir, jpdom_auto, 'sxice' , sxice , psgn = -1._wp ) 960 CALL iom_get( numrir, jpdom_auto, 'syice' , syice , psgn = -1._wp ) 776 961 CALL iom_get( numrir, jpdom_auto, 'sxxice', sxxice ) 777 962 CALL iom_get( numrir, jpdom_auto, 'syyice', syyice ) 778 963 CALL iom_get( numrir, jpdom_auto, 'sxyice', sxyice ) 779 964 ! ! snow thickness 780 CALL iom_get( numrir, jpdom_auto, 'sxsn' , sxsn )781 CALL iom_get( numrir, jpdom_auto, 'sysn' , sysn )965 CALL iom_get( numrir, jpdom_auto, 'sxsn' , sxsn , psgn = -1._wp ) 966 CALL iom_get( numrir, jpdom_auto, 'sysn' , sysn , psgn = -1._wp ) 782 967 CALL iom_get( numrir, jpdom_auto, 'sxxsn' , sxxsn ) 783 968 CALL iom_get( numrir, jpdom_auto, 'syysn' , syysn ) 784 969 CALL iom_get( numrir, jpdom_auto, 'sxysn' , sxysn ) 785 970 ! ! ice concentration 786 CALL iom_get( numrir, jpdom_auto, 'sxa' , sxa )787 CALL iom_get( numrir, jpdom_auto, 'sya' , sya )971 CALL iom_get( numrir, jpdom_auto, 'sxa' , sxa , psgn = -1._wp ) 972 CALL iom_get( numrir, jpdom_auto, 'sya' , sya , psgn = -1._wp ) 788 973 CALL iom_get( numrir, jpdom_auto, 'sxxa' , sxxa ) 789 974 CALL iom_get( numrir, jpdom_auto, 'syya' , syya ) 790 975 CALL iom_get( numrir, jpdom_auto, 'sxya' , sxya ) 791 976 ! ! ice salinity 792 CALL iom_get( numrir, jpdom_auto, 'sxsal' , sxsal )793 CALL iom_get( numrir, jpdom_auto, 'sysal' , sysal )977 CALL iom_get( numrir, jpdom_auto, 'sxsal' , sxsal , psgn = -1._wp ) 978 CALL iom_get( numrir, jpdom_auto, 'sysal' , sysal , psgn = -1._wp ) 794 979 CALL iom_get( numrir, jpdom_auto, 'sxxsal', sxxsal ) 795 980 CALL iom_get( numrir, jpdom_auto, 'syysal', syysal ) 796 981 CALL iom_get( numrir, jpdom_auto, 'sxysal', sxysal ) 797 982 ! ! ice age 798 CALL iom_get( numrir, jpdom_auto, 'sxage' , sxage )799 CALL iom_get( numrir, jpdom_auto, 'syage' , syage )983 CALL iom_get( numrir, jpdom_auto, 'sxage' , sxage , psgn = -1._wp ) 984 CALL iom_get( numrir, jpdom_auto, 'syage' , syage , psgn = -1._wp ) 800 985 CALL iom_get( numrir, jpdom_auto, 'sxxage', sxxage ) 801 986 CALL iom_get( numrir, jpdom_auto, 'syyage', syyage ) … … 804 989 DO jk = 1, nlay_s 805 990 WRITE(zchar1,'(I2.2)') jk 806 znam = 'sxc0'//'_l'//zchar1 ; CALL iom_get( numrir, jpdom_auto, znam , z3d ) ; sxc0 (:,:,jk,:) = z3d(:,:,:)807 znam = 'syc0'//'_l'//zchar1 ; CALL iom_get( numrir, jpdom_auto, znam , z3d ) ; syc0 (:,:,jk,:) = z3d(:,:,:)991 znam = 'sxc0'//'_l'//zchar1 ; CALL iom_get( numrir, jpdom_auto, znam , z3d, psgn = -1._wp ) ; sxc0 (:,:,jk,:) = z3d(:,:,:) 992 znam = 'syc0'//'_l'//zchar1 ; CALL iom_get( numrir, jpdom_auto, znam , z3d, psgn = -1._wp ) ; syc0 (:,:,jk,:) = z3d(:,:,:) 808 993 znam = 'sxxc0'//'_l'//zchar1 ; CALL iom_get( numrir, jpdom_auto, znam , z3d ) ; sxxc0(:,:,jk,:) = z3d(:,:,:) 809 994 znam = 'syyc0'//'_l'//zchar1 ; CALL iom_get( numrir, jpdom_auto, znam , z3d ) ; syyc0(:,:,jk,:) = z3d(:,:,:) … … 813 998 DO jk = 1, nlay_i 814 999 WRITE(zchar1,'(I2.2)') jk 815 znam = 'sxe'//'_l'//zchar1 ; CALL iom_get( numrir, jpdom_auto, znam , z3d ) ; sxe (:,:,jk,:) = z3d(:,:,:)816 znam = 'sye'//'_l'//zchar1 ; CALL iom_get( numrir, jpdom_auto, znam , z3d ) ; sye (:,:,jk,:) = z3d(:,:,:)1000 znam = 'sxe'//'_l'//zchar1 ; CALL iom_get( numrir, jpdom_auto, znam , z3d, psgn = -1._wp ) ; sxe (:,:,jk,:) = z3d(:,:,:) 1001 znam = 'sye'//'_l'//zchar1 ; CALL iom_get( numrir, jpdom_auto, znam , z3d, psgn = -1._wp ) ; sye (:,:,jk,:) = z3d(:,:,:) 817 1002 znam = 'sxxe'//'_l'//zchar1 ; CALL iom_get( numrir, jpdom_auto, znam , z3d ) ; sxxe(:,:,jk,:) = z3d(:,:,:) 818 1003 znam = 'syye'//'_l'//zchar1 ; CALL iom_get( numrir, jpdom_auto, znam , z3d ) ; syye(:,:,jk,:) = z3d(:,:,:) … … 820 1005 END DO 821 1006 ! 822 IF( ln_pnd_H12 ) THEN ! melt pond fraction 823 CALL iom_get( numrir, jpdom_auto, 'sxap' , sxap ) 824 CALL iom_get( numrir, jpdom_auto, 'syap' , syap ) 825 CALL iom_get( numrir, jpdom_auto, 'sxxap', sxxap ) 826 CALL iom_get( numrir, jpdom_auto, 'syyap', syyap ) 827 CALL iom_get( numrir, jpdom_auto, 'sxyap', sxyap ) 828 ! ! melt pond volume 829 CALL iom_get( numrir, jpdom_auto, 'sxvp' , sxvp ) 830 CALL iom_get( numrir, jpdom_auto, 'syvp' , syvp ) 831 CALL iom_get( numrir, jpdom_auto, 'sxxvp', sxxvp ) 832 CALL iom_get( numrir, jpdom_auto, 'syyvp', syyvp ) 833 CALL iom_get( numrir, jpdom_auto, 'sxyvp', sxyvp ) 1007 IF( ln_pnd_LEV ) THEN ! melt pond fraction 1008 IF( iom_varid( numrir, 'sxap', ldstop = .FALSE. ) > 0 ) THEN 1009 CALL iom_get( numrir, jpdom_auto, 'sxap' , sxap , psgn = -1._wp ) 1010 CALL iom_get( numrir, jpdom_auto, 'syap' , syap , psgn = -1._wp ) 1011 CALL iom_get( numrir, jpdom_auto, 'sxxap', sxxap ) 1012 CALL iom_get( numrir, jpdom_auto, 'syyap', syyap ) 1013 CALL iom_get( numrir, jpdom_auto, 'sxyap', sxyap ) 1014 ! ! melt pond volume 1015 CALL iom_get( numrir, jpdom_auto, 'sxvp' , sxvp , psgn = -1._wp ) 1016 CALL iom_get( numrir, jpdom_auto, 'syvp' , syvp , psgn = -1._wp ) 1017 CALL iom_get( numrir, jpdom_auto, 'sxxvp', sxxvp ) 1018 CALL iom_get( numrir, jpdom_auto, 'syyvp', syyvp ) 1019 CALL iom_get( numrir, jpdom_auto, 'sxyvp', sxyvp ) 1020 ELSE 1021 sxap = 0._wp ; syap = 0._wp ; sxxap = 0._wp ; syyap = 0._wp ; sxyap = 0._wp ! melt pond fraction 1022 sxvp = 0._wp ; syvp = 0._wp ; sxxvp = 0._wp ; syyvp = 0._wp ; sxyvp = 0._wp ! melt pond volume 1023 ENDIF 1024 ! 1025 IF ( ln_pnd_lids ) THEN ! melt pond lid volume 1026 IF( iom_varid( numrir, 'sxvl', ldstop = .FALSE. ) > 0 ) THEN 1027 CALL iom_get( numrir, jpdom_auto, 'sxvl' , sxvl , psgn = -1._wp ) 1028 CALL iom_get( numrir, jpdom_auto, 'syvl' , syvl , psgn = -1._wp ) 1029 CALL iom_get( numrir, jpdom_auto, 'sxxvl', sxxvl ) 1030 CALL iom_get( numrir, jpdom_auto, 'syyvl', syyvl ) 1031 CALL iom_get( numrir, jpdom_auto, 'sxyvl', sxyvl ) 1032 ELSE 1033 sxvl = 0._wp; syvl = 0._wp ; sxxvl = 0._wp ; syyvl = 0._wp ; sxyvl = 0._wp ! melt pond lid volume 1034 ENDIF 1035 ENDIF 834 1036 ENDIF 835 1037 ! … … 845 1047 sxc0 = 0._wp ; syc0 = 0._wp ; sxxc0 = 0._wp ; syyc0 = 0._wp ; sxyc0 = 0._wp ! snow layers heat content 846 1048 sxe = 0._wp ; sye = 0._wp ; sxxe = 0._wp ; syye = 0._wp ; sxye = 0._wp ! ice layers heat content 847 IF( ln_pnd_H12 ) THEN 848 sxap = 0._wp ; syap = 0._wp ; sxxap = 0._wp ; syyap = 0._wp ; sxyap = 0._wp ! melt pond fraction 849 sxvp = 0._wp ; syvp = 0._wp ; sxxvp = 0._wp ; syyvp = 0._wp ; sxyvp = 0._wp ! melt pond volume 1049 IF( ln_pnd_LEV ) THEN 1050 sxap = 0._wp ; syap = 0._wp ; sxxap = 0._wp ; syyap = 0._wp ; sxyap = 0._wp ! melt pond fraction 1051 sxvp = 0._wp ; syvp = 0._wp ; sxxvp = 0._wp ; syyvp = 0._wp ; sxyvp = 0._wp ! melt pond volume 1052 IF ( ln_pnd_lids ) THEN 1053 sxvl = 0._wp; syvl = 0._wp ; sxxvl = 0._wp ; syyvl = 0._wp ; sxyvl = 0._wp ! melt pond lid volume 1054 ENDIF 850 1055 ENDIF 851 1056 ENDIF … … 910 1115 END DO 911 1116 ! 912 IF( ln_pnd_ H12) THEN ! melt pond fraction1117 IF( ln_pnd_LEV ) THEN ! melt pond fraction 913 1118 CALL iom_rstput( iter, nitrst, numriw, 'sxap' , sxap ) 914 1119 CALL iom_rstput( iter, nitrst, numriw, 'syap' , syap ) … … 922 1127 CALL iom_rstput( iter, nitrst, numriw, 'syyvp', syyvp ) 923 1128 CALL iom_rstput( iter, nitrst, numriw, 'sxyvp', sxyvp ) 1129 ! 1130 IF ( ln_pnd_lids ) THEN ! melt pond lid volume 1131 CALL iom_rstput( iter, nitrst, numriw, 'sxvl' , sxvl ) 1132 CALL iom_rstput( iter, nitrst, numriw, 'syvl' , syvl ) 1133 CALL iom_rstput( iter, nitrst, numriw, 'sxxvl', sxxvl ) 1134 CALL iom_rstput( iter, nitrst, numriw, 'syyvl', syyvl ) 1135 CALL iom_rstput( iter, nitrst, numriw, 'sxyvl', sxyvl ) 1136 ENDIF 924 1137 ENDIF 925 1138 ! … … 927 1140 ! 928 1141 END SUBROUTINE adv_pra_rst 1142 1143 SUBROUTINE icemax3D( pice , pmax ) 1144 !!--------------------------------------------------------------------- 1145 !! *** ROUTINE icemax3D *** 1146 !! ** Purpose : compute the max of the 9 points around 1147 !!---------------------------------------------------------------------- 1148 REAL(wp), DIMENSION(:,:,:) , INTENT(in ) :: pice ! input 1149 REAL(wp), DIMENSION(:,:,:) , INTENT(out) :: pmax ! output 1150 REAL(wp), DIMENSION(2:jpim1,jpj) :: zmax ! temporary array 1151 INTEGER :: ji, jj, jl ! dummy loop indices 1152 !!---------------------------------------------------------------------- 1153 DO jl = 1, jpl 1154 DO jj = Njs0-1, Nje0+1 1155 DO ji = Nis0, Nie0 1156 zmax(ji,jj) = MAX( epsi20, pice(ji,jj,jl), pice(ji-1,jj,jl), pice(ji+1,jj,jl) ) 1157 END DO 1158 END DO 1159 DO jj = Njs0, Nje0 1160 DO ji = Nis0, Nie0 1161 pmax(ji,jj,jl) = MAX( epsi20, zmax(ji,jj), zmax(ji,jj-1), zmax(ji,jj+1) ) 1162 END DO 1163 END DO 1164 END DO 1165 END SUBROUTINE icemax3D 1166 1167 SUBROUTINE icemax4D( pice , pmax ) 1168 !!--------------------------------------------------------------------- 1169 !! *** ROUTINE icemax4D *** 1170 !! ** Purpose : compute the max of the 9 points around 1171 !!---------------------------------------------------------------------- 1172 REAL(wp), DIMENSION(:,:,:,:) , INTENT(in ) :: pice ! input 1173 REAL(wp), DIMENSION(:,:,:,:) , INTENT(out) :: pmax ! output 1174 REAL(wp), DIMENSION(2:jpim1,jpj) :: zmax ! temporary array 1175 INTEGER :: jlay, ji, jj, jk, jl ! dummy loop indices 1176 !!---------------------------------------------------------------------- 1177 jlay = SIZE( pice , 3 ) ! size of input arrays 1178 DO jl = 1, jpl 1179 DO jk = 1, jlay 1180 DO jj = Njs0-1, Nje0+1 1181 DO ji = Nis0, Nie0 1182 zmax(ji,jj) = MAX( epsi20, pice(ji,jj,jk,jl), pice(ji-1,jj,jk,jl), pice(ji+1,jj,jk,jl) ) 1183 END DO 1184 END DO 1185 DO jj = Njs0, Nje0 1186 DO ji = Nis0, Nie0 1187 pmax(ji,jj,jk,jl) = MAX( epsi20, zmax(ji,jj), zmax(ji,jj-1), zmax(ji,jj+1) ) 1188 END DO 1189 END DO 1190 END DO 1191 END DO 1192 END SUBROUTINE icemax4D 929 1193 930 1194 #else -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/ICE/icedyn_adv_umx.F90
r13295 r13998 60 60 61 61 SUBROUTINE ice_dyn_adv_umx( kn_umx, kt, pu_ice, pv_ice, ph_i, ph_s, ph_ip, & 62 & pato_i, pv_i, pv_s, psv_i, poa_i, pa_i, pa_ip, pv_ip, p e_s, pe_i )62 & pato_i, pv_i, pv_s, psv_i, poa_i, pa_i, pa_ip, pv_ip, pv_il, pe_s, pe_i ) 63 63 !!---------------------------------------------------------------------- 64 64 !! *** ROUTINE ice_dyn_adv_umx *** … … 85 85 REAL(wp), DIMENSION(:,:,:) , INTENT(inout) :: pa_ip ! melt pond concentration 86 86 REAL(wp), DIMENSION(:,:,:) , INTENT(inout) :: pv_ip ! melt pond volume 87 REAL(wp), DIMENSION(:,:,:) , INTENT(inout) :: pv_il ! melt pond lid volume 87 88 REAL(wp), DIMENSION(:,:,:,:), INTENT(inout) :: pe_s ! snw heat content 88 89 REAL(wp), DIMENSION(:,:,:,:), INTENT(inout) :: pe_i ! ice heat content … … 91 92 INTEGER :: icycle ! number of sub-timestep for the advection 92 93 REAL(wp) :: zamsk ! 1 if advection of concentration, 0 if advection of other tracers 93 REAL(wp) :: zdt, zvi_cen 94 REAL(wp), DIMENSION(1) :: zcflprv, zcflnow ! for global communication 95 REAL(wp), DIMENSION(jpi,jpj) :: zudy, zvdx, zcu_box, zcv_box 96 REAL(wp), DIMENSION(jpi,jpj) :: zati1, zati2 97 REAL(wp), DIMENSION(jpi,jpj,jpl) :: zu_cat, zv_cat 98 REAL(wp), DIMENSION(jpi,jpj,jpl) :: zua_ho, zva_ho, zua_ups, zva_ups 99 REAL(wp), DIMENSION(jpi,jpj,jpl) :: z1_ai , z1_aip, zhvar 100 REAL(wp), DIMENSION(jpi,jpj,jpl) :: zhi_max, zhs_max, zhip_max 94 REAL(wp) :: zdt, z1_dt, zvi_cen 95 REAL(wp), DIMENSION(1) :: zcflprv, zcflnow ! for global communication 96 REAL(wp), DIMENSION(jpi,jpj) :: zudy, zvdx, zcu_box, zcv_box 97 REAL(wp), DIMENSION(jpi,jpj) :: zati1, zati2 98 REAL(wp), DIMENSION(jpi,jpj,jpl) :: zu_cat, zv_cat 99 REAL(wp), DIMENSION(jpi,jpj,jpl) :: zua_ho, zva_ho, zua_ups, zva_ups 100 REAL(wp), DIMENSION(jpi,jpj,jpl) :: z1_ai , z1_aip, zhvar 101 REAL(wp), DIMENSION(jpi,jpj,jpl) :: zhi_max, zhs_max, zhip_max, zs_i, zsi_max 102 REAL(wp), DIMENSION(jpi,jpj,nlay_i,jpl) :: ze_i, zei_max 103 REAL(wp), DIMENSION(jpi,jpj,nlay_s,jpl) :: ze_s, zes_max 101 104 ! 102 105 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zuv_ho, zvv_ho, zuv_ups, zvv_ups, z1_vi, z1_vs 106 !! diagnostics 107 REAL(wp), DIMENSION(jpi,jpj) :: zdiag_adv_mass, zdiag_adv_salt, zdiag_adv_heat 103 108 !!---------------------------------------------------------------------- 104 109 ! 105 110 IF( kt == nit000 .AND. lwp ) WRITE(numout,*) '-- ice_dyn_adv_umx: Ultimate-Macho advection scheme' 106 111 ! 107 ! --- Record max of the surrounding 9-pts ice thick. (for call Hbig) --- ! 108 DO jl = 1, jpl 109 DO_2D( 0, 0, 0, 0 ) 110 zhip_max(ji,jj,jl) = MAX( epsi20, ph_ip(ji,jj,jl), ph_ip(ji+1,jj ,jl), ph_ip(ji ,jj+1,jl), & 111 & ph_ip(ji-1,jj ,jl), ph_ip(ji ,jj-1,jl), & 112 & ph_ip(ji+1,jj+1,jl), ph_ip(ji-1,jj-1,jl), & 113 & ph_ip(ji+1,jj-1,jl), ph_ip(ji-1,jj+1,jl) ) 114 zhi_max (ji,jj,jl) = MAX( epsi20, ph_i (ji,jj,jl), ph_i (ji+1,jj ,jl), ph_i (ji ,jj+1,jl), & 115 & ph_i (ji-1,jj ,jl), ph_i (ji ,jj-1,jl), & 116 & ph_i (ji+1,jj+1,jl), ph_i (ji-1,jj-1,jl), & 117 & ph_i (ji+1,jj-1,jl), ph_i (ji-1,jj+1,jl) ) 118 zhs_max (ji,jj,jl) = MAX( epsi20, ph_s (ji,jj,jl), ph_s (ji+1,jj ,jl), ph_s (ji ,jj+1,jl), & 119 & ph_s (ji-1,jj ,jl), ph_s (ji ,jj-1,jl), & 120 & ph_s (ji+1,jj+1,jl), ph_s (ji-1,jj-1,jl), & 121 & ph_s (ji+1,jj-1,jl), ph_s (ji-1,jj+1,jl) ) 122 END_2D 123 END DO 124 CALL lbc_lnk_multi( 'icedyn_adv_umx', zhi_max, 'T', 1.0_wp, zhs_max, 'T', 1.0_wp, zhip_max, 'T', 1.0_wp ) 112 ! --- Record max of the surrounding 9-pts (for call Hbig) --- ! 113 ! thickness and salinity 114 WHERE( pv_i(:,:,:) >= epsi10 ) ; zs_i(:,:,:) = psv_i(:,:,:) / pv_i(:,:,:) 115 ELSEWHERE ; zs_i(:,:,:) = 0._wp 116 END WHERE 117 CALL icemax3D( ph_i , zhi_max ) 118 CALL icemax3D( ph_s , zhs_max ) 119 CALL icemax3D( ph_ip, zhip_max) 120 CALL icemax3D( zs_i , zsi_max ) 121 CALL lbc_lnk_multi( 'icedyn_adv_umx', zhi_max, 'T', 1._wp, zhs_max, 'T', 1._wp, zhip_max, 'T', 1._wp, zsi_max, 'T', 1._wp ) 122 ! 123 ! enthalpies 124 DO jk = 1, nlay_i 125 WHERE( pv_i(:,:,:) >= epsi10 ) ; ze_i(:,:,jk,:) = pe_i(:,:,jk,:) / pv_i(:,:,:) 126 ELSEWHERE ; ze_i(:,:,jk,:) = 0._wp 127 END WHERE 128 END DO 129 DO jk = 1, nlay_s 130 WHERE( pv_s(:,:,:) >= epsi10 ) ; ze_s(:,:,jk,:) = pe_s(:,:,jk,:) / pv_s(:,:,:) 131 ELSEWHERE ; ze_s(:,:,jk,:) = 0._wp 132 END WHERE 133 END DO 134 CALL icemax4D( ze_i , zei_max ) 135 CALL icemax4D( ze_s , zes_max ) 136 CALL lbc_lnk( 'icedyn_adv_umx', zei_max, 'T', 1._wp ) 137 CALL lbc_lnk( 'icedyn_adv_umx', zes_max, 'T', 1._wp ) 125 138 ! 126 139 ! … … 138 151 ENDIF 139 152 zdt = rDt_ice / REAL(icycle) 153 z1_dt = 1._wp / zdt 140 154 141 155 ! --- transport --- ! … … 166 180 !---------------! 167 181 DO jt = 1, icycle 182 183 ! diagnostics 184 zdiag_adv_mass(:,:) = SUM( pv_i(:,:,:) , dim=3 ) * rhoi + SUM( pv_s(:,:,:) , dim=3 ) * rhos 185 zdiag_adv_salt(:,:) = SUM( psv_i(:,:,:) , dim=3 ) * rhoi 186 zdiag_adv_heat(:,:) = - SUM(SUM( pe_i(:,:,1:nlay_i,:) , dim=4 ), dim=3 ) & 187 & - SUM(SUM( pe_s(:,:,1:nlay_s,:) , dim=4 ), dim=3 ) 168 188 169 189 ! record at_i before advection (for open water) … … 318 338 ! 319 339 !== melt ponds ==! 320 IF ( ln_pnd_ H12) THEN340 IF ( ln_pnd_LEV ) THEN 321 341 ! concentration 322 342 zamsk = 1._wp … … 328 348 CALL adv_umx( zamsk, kn_umx, jt, kt, zdt, zudy , zvdx , zua_ho , zva_ho , zcu_box, zcv_box, & 329 349 & zhvar, pv_ip, zua_ups, zva_ups ) 350 ! lid 351 IF ( ln_pnd_lids ) THEN 352 zamsk = 0._wp 353 zhvar(:,:,:) = pv_il(:,:,:) * z1_aip(:,:,:) 354 CALL adv_umx( zamsk, kn_umx, jt, kt, zdt, zudy , zvdx , zua_ho , zva_ho , zcu_box, zcv_box, & 355 & zhvar, pv_il, zua_ups, zva_ups ) 356 ENDIF 330 357 ENDIF 358 359 ! --- Lateral boundary conditions --- ! 360 IF ( ln_pnd_LEV .AND. ln_pnd_lids ) THEN 361 CALL lbc_lnk_multi( 'icedyn_adv_umx', pa_i,'T',1._wp, pv_i,'T',1._wp, pv_s,'T',1._wp, psv_i,'T',1._wp, poa_i,'T',1._wp & 362 & , pa_ip,'T',1._wp, pv_ip,'T',1._wp, pv_il,'T',1._wp ) 363 ELSEIF( ln_pnd_LEV .AND. .NOT.ln_pnd_lids ) THEN 364 CALL lbc_lnk_multi( 'icedyn_adv_umx', pa_i,'T',1._wp, pv_i,'T',1._wp, pv_s,'T',1._wp, psv_i,'T',1._wp, poa_i,'T',1._wp & 365 & , pa_ip,'T',1._wp, pv_ip,'T',1._wp ) 366 ELSE 367 CALL lbc_lnk_multi( 'icedyn_adv_umx', pa_i,'T',1._wp, pv_i,'T',1._wp, pv_s,'T',1._wp, psv_i,'T',1._wp, poa_i,'T',1._wp ) 368 ENDIF 369 CALL lbc_lnk( 'icedyn_adv_umx', pe_i, 'T', 1._wp ) 370 CALL lbc_lnk( 'icedyn_adv_umx', pe_s, 'T', 1._wp ) 331 371 ! 332 372 !== Open water area ==! … … 336 376 & - ( zudy(ji,jj) - zudy(ji-1,jj) + zvdx(ji,jj) - zvdx(ji,jj-1) ) * r1_e1e2t(ji,jj) * zdt 337 377 END_2D 338 CALL lbc_lnk( 'icedyn_adv_umx', pato_i, 'T', 1.0_wp ) 339 ! 378 CALL lbc_lnk( 'icedyn_adv_umx', pato_i, 'T', 1._wp ) 379 ! 380 ! --- diagnostics --- ! 381 diag_adv_mass(:,:) = diag_adv_mass(:,:) + ( SUM( pv_i(:,:,:) , dim=3 ) * rhoi + SUM( pv_s(:,:,:) , dim=3 ) * rhos & 382 & - zdiag_adv_mass(:,:) ) * z1_dt 383 diag_adv_salt(:,:) = diag_adv_salt(:,:) + ( SUM( psv_i(:,:,:) , dim=3 ) * rhoi & 384 & - zdiag_adv_salt(:,:) ) * z1_dt 385 diag_adv_heat(:,:) = diag_adv_heat(:,:) + ( - SUM(SUM( pe_i(:,:,1:nlay_i,:) , dim=4 ), dim=3 ) & 386 & - SUM(SUM( pe_s(:,:,1:nlay_s,:) , dim=4 ), dim=3 ) & 387 & - zdiag_adv_heat(:,:) ) * z1_dt 340 388 ! 341 389 ! --- Ensure non-negative fields and in-bound thicknesses --- ! 342 390 ! Remove negative values (conservation is ensured) 343 391 ! (because advected fields are not perfectly bounded and tiny negative values can occur, e.g. -1.e-20) 344 CALL ice_var_zapneg( zdt, pato_i, pv_i, pv_s, psv_i, poa_i, pa_i, pa_ip, pv_ip, p e_s, pe_i )392 CALL ice_var_zapneg( zdt, pato_i, pv_i, pv_s, psv_i, poa_i, pa_i, pa_ip, pv_ip, pv_il, pe_s, pe_i ) 345 393 ! 346 394 ! --- Make sure ice thickness is not too big --- ! 347 395 ! (because ice thickness can be too large where ice concentration is very small) 348 CALL Hbig( zdt, zhi_max, zhs_max, zhip_max, pv_i, pv_s, pa_i, pa_ip, pv_ip, pe_s ) 396 CALL Hbig( zdt, zhi_max, zhs_max, zhip_max, zsi_max, zes_max, zei_max, & 397 & pv_i, pv_s, pa_i, pa_ip, pv_ip, psv_i, pe_s, pe_i ) 349 398 ! 350 399 ! --- Ensure snow load is not too big --- ! … … 396 445 !! work on H (and not V). It is partly related to the multi-category approach 397 446 !! Therefore, after advection we limit the thickness to the largest value of the 9-points around (only if ice 398 !! concentration is small). Since we do not limit S and T, large values can occur at the edge but it does not really matter 399 !! since sv_i and e_i are still good. 447 !! concentration is small). We also limit S and T. 400 448 !!---------------------------------------------------------------------- 401 449 REAL(wp) , INTENT(in ) :: pamsk ! advection of concentration (1) or other tracers (0) … … 441 489 IF( pamsk == 0._wp ) THEN 442 490 DO jl = 1, jpl 443 DO_2D( 1, 0, 1, 0 )491 DO_2D( 0, 0, 1, 0 ) 444 492 IF( ABS( pu(ji,jj) ) > epsi10 ) THEN 445 493 zfu_ho (ji,jj,jl) = zfu_ho (ji,jj,jl) * puc (ji,jj,jl) / pu(ji,jj) … … 450 498 ENDIF 451 499 ! 500 END_2D 501 DO_2D( 1, 0, 0, 0 ) 452 502 IF( ABS( pv(ji,jj) ) > epsi10 ) THEN 453 503 zfv_ho (ji,jj,jl) = zfv_ho (ji,jj,jl) * pvc (ji,jj,jl) / pv(ji,jj) … … 484 534 IF( PRESENT( pua_ho ) ) THEN 485 535 DO jl = 1, jpl 486 DO_2D( 1, 0, 1, 0 ) 487 pua_ho (ji,jj,jl) = zfu_ho (ji,jj,jl) ; pva_ho (ji,jj,jl) = zfv_ho (ji,jj,jl) 488 pua_ups(ji,jj,jl) = zfu_ups(ji,jj,jl) ; pva_ups(ji,jj,jl) = zfv_ups(ji,jj,jl) 536 DO_2D( 0, 0, 1, 0 ) 537 pua_ho (ji,jj,jl) = zfu_ho (ji,jj,jl) 538 pua_ups(ji,jj,jl) = zfu_ups(ji,jj,jl) 539 END_2D 540 DO_2D( 1, 0, 0, 0 ) 541 pva_ho (ji,jj,jl) = zfv_ho (ji,jj,jl) 542 pva_ups(ji,jj,jl) = zfv_ups(ji,jj,jl) 489 543 END_2D 490 544 END DO … … 500 554 END_2D 501 555 END DO 502 CALL lbc_lnk( 'icedyn_adv_umx', ptc, 'T', 1.0_wp )503 556 ! 504 557 END SUBROUTINE adv_umx … … 539 592 ! 540 593 DO jl = 1, jpl !-- flux in x-direction 541 DO_2D( 1, 0, 1, 0 )594 DO_2D( 1, 1, 1, 0 ) 542 595 pfu_ups(ji,jj,jl) = MAX( pu(ji,jj), 0._wp ) * pt(ji,jj,jl) + MIN( pu(ji,jj), 0._wp ) * pt(ji+1,jj,jl) 543 596 END_2D … … 545 598 ! 546 599 DO jl = 1, jpl !-- first guess of tracer from u-flux 547 DO_2D( 0, 0, 0, 0 )600 DO_2D( 1, 1, 0, 0 ) 548 601 ztra = - ( pfu_ups(ji,jj,jl) - pfu_ups(ji-1,jj,jl) ) & 549 602 & + ( pu (ji,jj ) - pu (ji-1,jj ) ) * pt(ji,jj,jl) * (1.-pamsk) … … 552 605 END_2D 553 606 END DO 554 CALL lbc_lnk( 'icedyn_adv_umx', zpt, 'T', 1.0_wp )555 607 ! 556 608 DO jl = 1, jpl !-- flux in y-direction 557 DO_2D( 1, 0, 1, 0 )609 DO_2D( 1, 0, 0, 0 ) 558 610 pfv_ups(ji,jj,jl) = MAX( pv(ji,jj), 0._wp ) * zpt(ji,jj,jl) + MIN( pv(ji,jj), 0._wp ) * zpt(ji,jj+1,jl) 559 611 END_2D … … 563 615 ! 564 616 DO jl = 1, jpl !-- flux in y-direction 565 DO_2D( 1, 0, 1, 0)617 DO_2D( 1, 0, 1, 1 ) 566 618 pfv_ups(ji,jj,jl) = MAX( pv(ji,jj), 0._wp ) * pt(ji,jj,jl) + MIN( pv(ji,jj), 0._wp ) * pt(ji,jj+1,jl) 567 619 END_2D … … 569 621 ! 570 622 DO jl = 1, jpl !-- first guess of tracer from v-flux 571 DO_2D( 0, 0, 0, 0)623 DO_2D( 0, 0, 1, 1 ) 572 624 ztra = - ( pfv_ups(ji,jj,jl) - pfv_ups(ji,jj-1,jl) ) & 573 625 & + ( pv (ji,jj ) - pv (ji,jj-1 ) ) * pt(ji,jj,jl) * (1.-pamsk) … … 576 628 END_2D 577 629 END DO 578 CALL lbc_lnk( 'icedyn_adv_umx', zpt, 'T', 1.0_wp )579 630 ! 580 631 DO jl = 1, jpl !-- flux in x-direction 581 DO_2D( 1, 0, 1, 0 )632 DO_2D( 0, 0, 1, 0 ) 582 633 pfu_ups(ji,jj,jl) = MAX( pu(ji,jj), 0._wp ) * zpt(ji,jj,jl) + MIN( pu(ji,jj), 0._wp ) * zpt(ji+1,jj,jl) 583 634 END_2D … … 628 679 ! 629 680 DO jl = 1, jpl 630 DO_2D( 1, 0, 1, 0 )681 DO_2D( 1, 1, 1, 0 ) 631 682 pfu_ho(ji,jj,jl) = 0.5_wp * pu(ji,jj) * ( pt(ji,jj,jl) + pt(ji+1,jj ,jl) ) 683 END_2D 684 DO_2D( 1, 0, 1, 1 ) 632 685 pfv_ho(ji,jj,jl) = 0.5_wp * pv(ji,jj) * ( pt(ji,jj,jl) + pt(ji ,jj+1,jl) ) 633 686 END_2D … … 646 699 ! 647 700 DO jl = 1, jpl !-- flux in x-direction 648 DO_2D( 1, 0, 1, 0 )701 DO_2D( 1, 1, 1, 0 ) 649 702 pfu_ho(ji,jj,jl) = 0.5_wp * pu(ji,jj) * ( pt(ji,jj,jl) + pt(ji+1,jj,jl) ) 650 703 END_2D … … 653 706 654 707 DO jl = 1, jpl !-- first guess of tracer from u-flux 655 DO_2D( 0, 0, 0, 0 )708 DO_2D( 1, 1, 0, 0 ) 656 709 ztra = - ( pfu_ho(ji,jj,jl) - pfu_ho(ji-1,jj,jl) ) & 657 710 & + ( pu (ji,jj ) - pu (ji-1,jj ) ) * pt(ji,jj,jl) * (1.-pamsk) … … 660 713 END_2D 661 714 END DO 662 CALL lbc_lnk( 'icedyn_adv_umx', zpt, 'T', 1.0_wp )663 715 664 716 DO jl = 1, jpl !-- flux in y-direction 665 DO_2D( 1, 0, 1, 0 )717 DO_2D( 1, 0, 0, 0 ) 666 718 pfv_ho(ji,jj,jl) = 0.5_wp * pv(ji,jj) * ( zpt(ji,jj,jl) + zpt(ji,jj+1,jl) ) 667 719 END_2D … … 672 724 ! 673 725 DO jl = 1, jpl !-- flux in y-direction 674 DO_2D( 1, 0, 1, 0)726 DO_2D( 1, 0, 1, 1 ) 675 727 pfv_ho(ji,jj,jl) = 0.5_wp * pv(ji,jj) * ( pt(ji,jj,jl) + pt(ji,jj+1,jl) ) 676 728 END_2D … … 679 731 ! 680 732 DO jl = 1, jpl !-- first guess of tracer from v-flux 681 DO_2D( 0, 0, 0, 0)733 DO_2D( 0, 0, 1, 1 ) 682 734 ztra = - ( pfv_ho(ji,jj,jl) - pfv_ho(ji,jj-1,jl) ) & 683 735 & + ( pv (ji,jj ) - pv (ji,jj-1 ) ) * pt(ji,jj,jl) * (1.-pamsk) … … 686 738 END_2D 687 739 END DO 688 CALL lbc_lnk( 'icedyn_adv_umx', zpt, 'T', 1.0_wp )689 740 ! 690 741 DO jl = 1, jpl !-- flux in x-direction 691 DO_2D( 1, 0, 1, 0 )742 DO_2D( 0, 0, 1, 0 ) 692 743 pfu_ho(ji,jj,jl) = 0.5_wp * pu(ji,jj) * ( zpt(ji,jj,jl) + zpt(ji+1,jj,jl) ) 693 744 END_2D … … 846 897 ! 847 898 DO jl = 1, jpl 848 DO_2D( 1, 0, 1, 0 )899 DO_2D( 0, 0, 1, 0 ) 849 900 pt_u(ji,jj,jl) = 0.5_wp * umask(ji,jj,1) * ( pt(ji+1,jj,jl) + pt(ji,jj,jl) & 850 901 & - SIGN( 1._wp, pu(ji,jj) ) * ( pt(ji+1,jj,jl) - pt(ji,jj,jl) ) ) … … 855 906 ! 856 907 DO jl = 1, jpl 857 DO_2D( 1, 0, 1, 0 )908 DO_2D( 0, 0, 1, 0 ) 858 909 zcu = pu(ji,jj) * r1_e2u(ji,jj) * pdt * r1_e1u(ji,jj) 859 910 pt_u(ji,jj,jl) = 0.5_wp * umask(ji,jj,1) * ( pt(ji+1,jj,jl) + pt(ji,jj,jl) & … … 865 916 ! 866 917 DO jl = 1, jpl 867 DO_2D( 1, 0, 1, 0 )918 DO_2D( 0, 0, 1, 0 ) 868 919 zcu = pu(ji,jj) * r1_e2u(ji,jj) * pdt * r1_e1u(ji,jj) 869 920 zdx2 = e1u(ji,jj) * e1u(ji,jj) … … 879 930 ! 880 931 DO jl = 1, jpl 881 DO_2D( 1, 0, 1, 0 )932 DO_2D( 0, 0, 1, 0 ) 882 933 zcu = pu(ji,jj) * r1_e2u(ji,jj) * pdt * r1_e1u(ji,jj) 883 934 zdx2 = e1u(ji,jj) * e1u(ji,jj) … … 893 944 ! 894 945 DO jl = 1, jpl 895 DO_2D( 1, 0, 1, 0 )946 DO_2D( 0, 0, 1, 0 ) 896 947 zcu = pu(ji,jj) * r1_e2u(ji,jj) * pdt * r1_e1u(ji,jj) 897 948 zdx2 = e1u(ji,jj) * e1u(ji,jj) … … 914 965 IF( ll_neg ) THEN 915 966 DO jl = 1, jpl 916 DO_2D( 1, 0, 1, 0 )967 DO_2D( 0, 0, 1, 0 ) 917 968 IF( pt_u(ji,jj,jl) < 0._wp .OR. ( imsk_small(ji,jj,jl) == 0 .AND. pamsk == 0. ) ) THEN 918 969 pt_u(ji,jj,jl) = 0.5_wp * umask(ji,jj,1) * ( pt(ji+1,jj,jl) + pt(ji,jj,jl) & … … 924 975 ! !-- High order flux in i-direction --! 925 976 DO jl = 1, jpl 926 DO_2D( 1, 0, 1, 0 )977 DO_2D( 0, 0, 1, 0 ) 927 978 pfu_ho(ji,jj,jl) = pu(ji,jj) * pt_u(ji,jj,jl) 928 979 END_2D … … 957 1008 ! !-- Laplacian in j-direction --! 958 1009 DO jl = 1, jpl 959 DO_2D( 1, 0, 0, 0 ) 1010 DO_2D( 1, 0, 0, 0 ) ! First derivative (gradient) 960 1011 ztv1(ji,jj,jl) = ( pt(ji,jj+1,jl) - pt(ji,jj,jl) ) * r1_e2v(ji,jj) * vmask(ji,jj,1) 961 1012 END_2D 962 DO_2D( 0, 0, 0, 0 ) 1013 DO_2D( 0, 0, 0, 0 ) ! Second derivative (Laplacian) 963 1014 ztv2(ji,jj,jl) = ( ztv1(ji,jj,jl) - ztv1(ji,jj-1,jl) ) * r1_e2t(ji,jj) 964 1015 END_2D … … 968 1019 ! !-- BiLaplacian in j-direction --! 969 1020 DO jl = 1, jpl 970 DO_2D( 1, 0, 0, 0 ) 1021 DO_2D( 1, 0, 0, 0 ) ! First derivative 971 1022 ztv3(ji,jj,jl) = ( ztv2(ji,jj+1,jl) - ztv2(ji,jj,jl) ) * r1_e2v(ji,jj) * vmask(ji,jj,1) 972 1023 END_2D 973 DO_2D( 0, 0, 0, 0 ) 1024 DO_2D( 0, 0, 0, 0 ) ! Second derivative 974 1025 ztv4(ji,jj,jl) = ( ztv3(ji,jj,jl) - ztv3(ji,jj-1,jl) ) * r1_e2t(ji,jj) 975 1026 END_2D … … 982 1033 CASE( 1 ) !== 1st order central TIM ==! (Eq. 21) 983 1034 DO jl = 1, jpl 984 DO_2D( 1, 0, 1, 0 )1035 DO_2D( 1, 0, 0, 0 ) 985 1036 pt_v(ji,jj,jl) = 0.5_wp * vmask(ji,jj,1) * ( pt(ji,jj+1,jl) + pt(ji,jj,jl) & 986 1037 & - SIGN( 1._wp, pv(ji,jj) ) * ( pt(ji,jj+1,jl) - pt(ji,jj,jl) ) ) … … 990 1041 CASE( 2 ) !== 2nd order central TIM ==! (Eq. 23) 991 1042 DO jl = 1, jpl 992 DO_2D( 1, 0, 1, 0 )1043 DO_2D( 1, 0, 0, 0 ) 993 1044 zcv = pv(ji,jj) * r1_e1v(ji,jj) * pdt * r1_e2v(ji,jj) 994 1045 pt_v(ji,jj,jl) = 0.5_wp * vmask(ji,jj,1) * ( pt(ji,jj+1,jl) + pt(ji,jj,jl) & … … 999 1050 CASE( 3 ) !== 3rd order central TIM ==! (Eq. 24) 1000 1051 DO jl = 1, jpl 1001 DO_2D( 1, 0, 1, 0 )1052 DO_2D( 1, 0, 0, 0 ) 1002 1053 zcv = pv(ji,jj) * r1_e1v(ji,jj) * pdt * r1_e2v(ji,jj) 1003 1054 zdy2 = e2v(ji,jj) * e2v(ji,jj) … … 1012 1063 CASE( 4 ) !== 4th order central TIM ==! (Eq. 27) 1013 1064 DO jl = 1, jpl 1014 DO_2D( 1, 0, 1, 0 )1065 DO_2D( 1, 0, 0, 0 ) 1015 1066 zcv = pv(ji,jj) * r1_e1v(ji,jj) * pdt * r1_e2v(ji,jj) 1016 1067 zdy2 = e2v(ji,jj) * e2v(ji,jj) … … 1025 1076 CASE( 5 ) !== 5th order central TIM ==! (Eq. 29) 1026 1077 DO jl = 1, jpl 1027 DO_2D( 1, 0, 1, 0 )1078 DO_2D( 1, 0, 0, 0 ) 1028 1079 zcv = pv(ji,jj) * r1_e1v(ji,jj) * pdt * r1_e2v(ji,jj) 1029 1080 zdy2 = e2v(ji,jj) * e2v(ji,jj) … … 1046 1097 IF( ll_neg ) THEN 1047 1098 DO jl = 1, jpl 1048 DO_2D( 1, 0, 1, 0 )1099 DO_2D( 1, 0, 0, 0 ) 1049 1100 IF( pt_v(ji,jj,jl) < 0._wp .OR. ( jmsk_small(ji,jj,jl) == 0 .AND. pamsk == 0. ) ) THEN 1050 1101 pt_v(ji,jj,jl) = 0.5_wp * vmask(ji,jj,1) * ( ( pt(ji,jj+1,jl) + pt(ji,jj,jl) ) & … … 1056 1107 ! !-- High order flux in j-direction --! 1057 1108 DO jl = 1, jpl 1058 DO_2D( 1, 0, 1, 0 )1109 DO_2D( 1, 0, 0, 0 ) 1059 1110 pfv_ho(ji,jj,jl) = pv(ji,jj) * pt_v(ji,jj,jl) 1060 1111 END_2D … … 1092 1143 ! -------------------------------------------------- 1093 1144 DO jl = 1, jpl 1094 DO_2D( 1, 0, 1, 0 )1145 DO_2D( 0, 0, 1, 0 ) 1095 1146 pfu_ho(ji,jj,jl) = pfu_ho(ji,jj,jl) - pfu_ups(ji,jj,jl) 1147 END_2D 1148 DO_2D( 1, 0, 0, 0 ) 1096 1149 pfv_ho(ji,jj,jl) = pfv_ho(ji,jj,jl) - pfv_ups(ji,jj,jl) 1097 1150 END_2D … … 1199 1252 ! --------------------------------- 1200 1253 DO jl = 1, jpl 1201 DO_2D( 1, 0, 1, 0 )1254 DO_2D( 0, 0, 1, 0 ) 1202 1255 zau = MIN( 1._wp , zbetdo(ji,jj,jl) , zbetup(ji+1,jj,jl) ) 1203 1256 zbu = MIN( 1._wp , zbetup(ji,jj,jl) , zbetdo(ji+1,jj,jl) ) … … 1210 1263 END_2D 1211 1264 1212 DO_2D( 1, 0, 1, 0 )1265 DO_2D( 1, 0, 0, 0 ) 1213 1266 zav = MIN( 1._wp , zbetdo(ji,jj,jl) , zbetup(ji,jj+1,jl) ) 1214 1267 zbv = MIN( 1._wp , zbetup(ji,jj,jl) , zbetdo(ji,jj+1,jl) ) … … 1409 1462 1410 1463 1411 SUBROUTINE Hbig( pdt, phi_max, phs_max, phip_max, pv_i, pv_s, pa_i, pa_ip, pv_ip, pe_s ) 1464 SUBROUTINE Hbig( pdt, phi_max, phs_max, phip_max, psi_max, pes_max, pei_max, & 1465 & pv_i, pv_s, pa_i, pa_ip, pv_ip, psv_i, pe_s, pe_i ) 1412 1466 !!------------------------------------------------------------------- 1413 1467 !! *** ROUTINE Hbig *** … … 1423 1477 !! ** input : Max thickness of the surrounding 9-points 1424 1478 !!------------------------------------------------------------------- 1425 REAL(wp) , INTENT(in ) :: pdt ! tracer time-step 1426 REAL(wp), DIMENSION(:,:,:) , INTENT(in ) :: phi_max, phs_max, phip_max ! max ice thick from surrounding 9-pts 1427 REAL(wp), DIMENSION(:,:,:) , INTENT(inout) :: pv_i, pv_s, pa_i, pa_ip, pv_ip 1479 REAL(wp) , INTENT(in ) :: pdt ! tracer time-step 1480 REAL(wp), DIMENSION(:,:,:) , INTENT(in ) :: phi_max, phs_max, phip_max, psi_max ! max ice thick from surrounding 9-pts 1481 REAL(wp), DIMENSION(:,:,:,:), INTENT(in ) :: pes_max 1482 REAL(wp), DIMENSION(:,:,:,:), INTENT(in ) :: pei_max 1483 REAL(wp), DIMENSION(:,:,:) , INTENT(inout) :: pv_i, pv_s, pa_i, pa_ip, pv_ip, psv_i 1428 1484 REAL(wp), DIMENSION(:,:,:,:), INTENT(inout) :: pe_s 1429 ! 1430 INTEGER :: ji, jj, jl ! dummy loop indices 1431 REAL(wp) :: z1_dt, zhip, zhi, zhs, zfra 1485 REAL(wp), DIMENSION(:,:,:,:), INTENT(inout) :: pe_i 1486 ! 1487 INTEGER :: ji, jj, jk, jl ! dummy loop indices 1488 REAL(wp) :: z1_dt, zhip, zhi, zhs, zsi, zes, zei, zfra 1432 1489 !!------------------------------------------------------------------- 1433 1490 ! … … 1435 1492 ! 1436 1493 DO jl = 1, jpl 1437 1438 1494 DO_2D( 1, 1, 1, 1 ) 1439 1495 IF ( pv_i(ji,jj,jl) > 0._wp ) THEN … … 1441 1497 ! ! -- check h_ip -- ! 1442 1498 ! if h_ip is larger than the surrounding 9 pts => reduce h_ip and increase a_ip 1443 IF( ln_pnd_ H12.AND. pv_ip(ji,jj,jl) > 0._wp ) THEN1499 IF( ln_pnd_LEV .AND. pv_ip(ji,jj,jl) > 0._wp ) THEN 1444 1500 zhip = pv_ip(ji,jj,jl) / MAX( epsi20, pa_ip(ji,jj,jl) ) 1445 1501 IF( zhip > phip_max(ji,jj,jl) .AND. pa_ip(ji,jj,jl) < 0.15 ) THEN … … 1468 1524 ENDIF 1469 1525 ! 1526 ! ! -- check s_i -- ! 1527 ! if s_i is larger than the surrounding 9 pts => put salt excess in the ocean 1528 zsi = psv_i(ji,jj,jl) / pv_i(ji,jj,jl) 1529 IF( zsi > psi_max(ji,jj,jl) .AND. pa_i(ji,jj,jl) < 0.15 ) THEN 1530 zfra = psi_max(ji,jj,jl) / zsi 1531 sfx_res(ji,jj) = sfx_res(ji,jj) + psv_i(ji,jj,jl) * ( 1._wp - zfra ) * rhoi * z1_dt 1532 psv_i(ji,jj,jl) = psv_i(ji,jj,jl) * zfra 1533 ENDIF 1534 ! 1470 1535 ENDIF 1471 1536 END_2D 1472 1537 END DO 1538 ! 1539 ! ! -- check e_i/v_i -- ! 1540 DO jl = 1, jpl 1541 DO_3D( 1, 1, 1, 1, 1, nlay_i ) 1542 IF ( pv_i(ji,jj,jl) > 0._wp ) THEN 1543 ! if e_i/v_i is larger than the surrounding 9 pts => put the heat excess in the ocean 1544 zei = pe_i(ji,jj,jk,jl) / pv_i(ji,jj,jl) 1545 IF( zei > pei_max(ji,jj,jk,jl) .AND. pa_i(ji,jj,jl) < 0.15 ) THEN 1546 zfra = pei_max(ji,jj,jk,jl) / zei 1547 hfx_res(ji,jj) = hfx_res(ji,jj) - pe_i(ji,jj,jk,jl) * ( 1._wp - zfra ) * z1_dt ! W.m-2 <0 1548 pe_i(ji,jj,jk,jl) = pe_i(ji,jj,jk,jl) * zfra 1549 ENDIF 1550 ENDIF 1551 END_3D 1552 END DO 1553 ! ! -- check e_s/v_s -- ! 1554 DO jl = 1, jpl 1555 DO_3D( 1, 1, 1, 1, 1, nlay_s ) 1556 IF ( pv_s(ji,jj,jl) > 0._wp ) THEN 1557 ! if e_s/v_s is larger than the surrounding 9 pts => put the heat excess in the ocean 1558 zes = pe_s(ji,jj,jk,jl) / pv_s(ji,jj,jl) 1559 IF( zes > pes_max(ji,jj,jk,jl) .AND. pa_i(ji,jj,jl) < 0.15 ) THEN 1560 zfra = pes_max(ji,jj,jk,jl) / zes 1561 hfx_res(ji,jj) = hfx_res(ji,jj) - pe_s(ji,jj,jk,jl) * ( 1._wp - zfra ) * z1_dt ! W.m-2 <0 1562 pe_s(ji,jj,jk,jl) = pe_s(ji,jj,jk,jl) * zfra 1563 ENDIF 1564 ENDIF 1565 END_3D 1566 END DO 1473 1567 ! 1474 1568 END SUBROUTINE Hbig … … 1526 1620 END SUBROUTINE Hsnow 1527 1621 1622 SUBROUTINE icemax3D( pice , pmax ) 1623 !!--------------------------------------------------------------------- 1624 !! *** ROUTINE icemax3D *** 1625 !! ** Purpose : compute the max of the 9 points around 1626 !!---------------------------------------------------------------------- 1627 REAL(wp), DIMENSION(:,:,:) , INTENT(in ) :: pice ! input 1628 REAL(wp), DIMENSION(:,:,:) , INTENT(out) :: pmax ! output 1629 REAL(wp), DIMENSION(2:jpim1,jpj) :: zmax ! temporary array 1630 INTEGER :: ji, jj, jl ! dummy loop indices 1631 !!---------------------------------------------------------------------- 1632 DO jl = 1, jpl 1633 DO jj = Njs0-1, Nje0+1 1634 DO ji = Nis0, Nie0 1635 zmax(ji,jj) = MAX( epsi20, pice(ji,jj,jl), pice(ji-1,jj,jl), pice(ji+1,jj,jl) ) 1636 END DO 1637 END DO 1638 DO jj = Njs0, Nje0 1639 DO ji = Nis0, Nie0 1640 pmax(ji,jj,jl) = MAX( epsi20, zmax(ji,jj), zmax(ji,jj-1), zmax(ji,jj+1) ) 1641 END DO 1642 END DO 1643 END DO 1644 END SUBROUTINE icemax3D 1645 1646 SUBROUTINE icemax4D( pice , pmax ) 1647 !!--------------------------------------------------------------------- 1648 !! *** ROUTINE icemax4D *** 1649 !! ** Purpose : compute the max of the 9 points around 1650 !!---------------------------------------------------------------------- 1651 REAL(wp), DIMENSION(:,:,:,:) , INTENT(in ) :: pice ! input 1652 REAL(wp), DIMENSION(:,:,:,:) , INTENT(out) :: pmax ! output 1653 REAL(wp), DIMENSION(2:jpim1,jpj) :: zmax ! temporary array 1654 INTEGER :: jlay, ji, jj, jk, jl ! dummy loop indices 1655 !!---------------------------------------------------------------------- 1656 jlay = SIZE( pice , 3 ) ! size of input arrays 1657 DO jl = 1, jpl 1658 DO jk = 1, jlay 1659 DO jj = Njs0-1, Nje0+1 1660 DO ji = Nis0, Nie0 1661 zmax(ji,jj) = MAX( epsi20, pice(ji,jj,jk,jl), pice(ji-1,jj,jk,jl), pice(ji+1,jj,jk,jl) ) 1662 END DO 1663 END DO 1664 DO jj = Njs0, Nje0 1665 DO ji = Nis0, Nie0 1666 pmax(ji,jj,jk,jl) = MAX( epsi20, zmax(ji,jj), zmax(ji,jj-1), zmax(ji,jj+1) ) 1667 END DO 1668 END DO 1669 END DO 1670 END DO 1671 END SUBROUTINE icemax4D 1528 1672 1529 1673 #else -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/ICE/icedyn_rdgrft.F90
r13295 r13998 349 349 ELSEIF( zGsum(ji,jl-1) < rn_gstar ) THEN 350 350 apartf(ji,jl) = z1_gstar * ( rn_gstar - zGsum(ji,jl-1) ) * & 351 & ( 2._wp - ( zGsum(ji,jl-1) + rn_gstar 351 & ( 2._wp - ( zGsum(ji,jl-1) + rn_gstar ) * z1_gstar ) 352 352 ELSE 353 353 apartf(ji,jl) = 0._wp … … 502 502 REAL(wp) :: airdg1, oirdg1, aprdg1, virdg1, sirdg1 503 503 REAL(wp) :: airft1, oirft1, aprft1 504 REAL(wp), DIMENSION(jpij) :: airdg2, oirdg2, aprdg2, virdg2, sirdg2, vsrdg, vprdg ! area etc of new ridges505 REAL(wp), DIMENSION(jpij) :: airft2, oirft2, aprft2, virft , sirft , vsrft, vprft ! area etc of rafted ice504 REAL(wp), DIMENSION(jpij) :: airdg2, oirdg2, aprdg2, virdg2, sirdg2, vsrdg, vprdg, vlrdg ! area etc of new ridges 505 REAL(wp), DIMENSION(jpij) :: airft2, oirft2, aprft2, virft , sirft , vsrft, vprft, vlrft ! area etc of rafted ice 506 506 ! 507 507 REAL(wp), DIMENSION(jpij) :: ersw ! enth of water trapped into ridges … … 530 530 DO jl1 = 1, jpl 531 531 532 CALL tab_2d_1d( npti, nptidx(1:npti), s_i_1d(1:npti), s_i(:,:,jl1) ) 532 IF( nn_icesal /= 2 ) THEN 533 CALL tab_2d_1d( npti, nptidx(1:npti), s_i_1d(1:npti), s_i(:,:,jl1) ) 534 ENDIF 533 535 534 536 DO ji = 1, npti … … 573 575 oirft2(ji) = oa_i_2d(ji,jl1) * afrft * hi_hrft 574 576 575 IF ( ln_pnd_ H12) THEN577 IF ( ln_pnd_LEV ) THEN 576 578 aprdg1 = a_ip_2d(ji,jl1) * afrdg 577 579 aprdg2(ji) = a_ip_2d(ji,jl1) * afrdg * hi_hrdg(ji,jl1) … … 580 582 aprft2(ji) = a_ip_2d(ji,jl1) * afrft * hi_hrft 581 583 vprft (ji) = v_ip_2d(ji,jl1) * afrft 584 IF ( ln_pnd_lids ) THEN 585 vlrdg (ji) = v_il_2d(ji,jl1) * afrdg 586 vlrft (ji) = v_il_2d(ji,jl1) * afrft 587 ENDIF 582 588 ENDIF 583 589 … … 606 612 sv_i_2d(ji,jl1) = sv_i_2d(ji,jl1) - sirdg1 - sirft(ji) 607 613 oa_i_2d(ji,jl1) = oa_i_2d(ji,jl1) - oirdg1 - oirft1 608 IF ( ln_pnd_ H12) THEN614 IF ( ln_pnd_LEV ) THEN 609 615 a_ip_2d(ji,jl1) = a_ip_2d(ji,jl1) - aprdg1 - aprft1 610 616 v_ip_2d(ji,jl1) = v_ip_2d(ji,jl1) - vprdg(ji) - vprft(ji) 617 IF ( ln_pnd_lids ) THEN 618 v_il_2d(ji,jl1) = v_il_2d(ji,jl1) - vlrdg(ji) - vlrft(ji) 619 ENDIF 611 620 ENDIF 612 621 ENDIF … … 700 709 v_s_2d (ji,jl2) = v_s_2d (ji,jl2) + ( vsrdg (ji) * rn_fsnwrdg * fvol(ji) + & 701 710 & vsrft (ji) * rn_fsnwrft * zswitch(ji) ) 702 IF ( ln_pnd_ H12) THEN711 IF ( ln_pnd_LEV ) THEN 703 712 v_ip_2d (ji,jl2) = v_ip_2d(ji,jl2) + ( vprdg (ji) * rn_fpndrdg * fvol (ji) & 704 713 & + vprft (ji) * rn_fpndrft * zswitch(ji) ) 705 714 a_ip_2d (ji,jl2) = a_ip_2d(ji,jl2) + ( aprdg2(ji) * rn_fpndrdg * farea & 706 715 & + aprft2(ji) * rn_fpndrft * zswitch(ji) ) 716 IF ( ln_pnd_lids ) THEN 717 v_il_2d (ji,jl2) = v_il_2d(ji,jl2) + ( vlrdg(ji) * rn_fpndrdg * fvol (ji) & 718 & + vlrft(ji) * rn_fpndrft * zswitch(ji) ) 719 ENDIF 707 720 ENDIF 708 721 … … 735 748 !---------------- 736 749 ! In case ridging/rafting lead to very small negative values (sometimes it happens) 737 CALL ice_var_roundoff( a_i_2d, v_i_2d, v_s_2d, sv_i_2d, oa_i_2d, a_ip_2d, v_ip_2d, ze_s_2d, ze_i_2d )750 CALL ice_var_roundoff( a_i_2d, v_i_2d, v_s_2d, sv_i_2d, oa_i_2d, a_ip_2d, v_ip_2d, v_il_2d, ze_s_2d, ze_i_2d ) 738 751 ! 739 752 END SUBROUTINE rdgrft_shift … … 841 854 CALL tab_3d_2d( npti, nptidx(1:npti), a_ip_2d(1:npti,1:jpl), a_ip(:,:,:) ) 842 855 CALL tab_3d_2d( npti, nptidx(1:npti), v_ip_2d(1:npti,1:jpl), v_ip(:,:,:) ) 856 CALL tab_3d_2d( npti, nptidx(1:npti), v_il_2d(1:npti,1:jpl), v_il(:,:,:) ) 843 857 DO jl = 1, jpl 844 858 DO jk = 1, nlay_s … … 867 881 CALL tab_2d_3d( npti, nptidx(1:npti), a_ip_2d(1:npti,1:jpl), a_ip(:,:,:) ) 868 882 CALL tab_2d_3d( npti, nptidx(1:npti), v_ip_2d(1:npti,1:jpl), v_ip(:,:,:) ) 883 CALL tab_2d_3d( npti, nptidx(1:npti), v_il_2d(1:npti,1:jpl), v_il(:,:,:) ) 869 884 DO jl = 1, jpl 870 885 DO jk = 1, nlay_s -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/ICE/icedyn_rhg.F90
r12377 r13998 108 108 INTEGER :: ios, ioptio ! Local integer output status for namelist read 109 109 !! 110 NAMELIST/namdyn_rhg/ ln_rhg_EVP, ln_aEVP, rn_creepl, rn_ecc , nn_nevp, rn_relast 110 NAMELIST/namdyn_rhg/ ln_rhg_EVP, ln_aEVP, rn_creepl, rn_ecc , nn_nevp, rn_relast, nn_rhg_chkcvg 111 111 !!------------------------------------------------------------------- 112 112 ! … … 122 122 WRITE(numout,*) '~~~~~~~~~~~~~~~' 123 123 WRITE(numout,*) ' Namelist : namdyn_rhg:' 124 WRITE(numout,*) ' rheology EVP (icedyn_rhg_evp) ln_rhg_EVP = ', ln_rhg_EVP 125 WRITE(numout,*) ' use adaptive EVP (aEVP) ln_aEVP = ', ln_aEVP 126 WRITE(numout,*) ' creep limit rn_creepl = ', rn_creepl 127 WRITE(numout,*) ' eccentricity of the elliptical yield curve rn_ecc = ', rn_ecc 128 WRITE(numout,*) ' number of iterations for subcycling nn_nevp = ', nn_nevp 129 WRITE(numout,*) ' ratio of elastic timescale over ice time step rn_relast = ', rn_relast 124 WRITE(numout,*) ' rheology EVP (icedyn_rhg_evp) ln_rhg_EVP = ', ln_rhg_EVP 125 WRITE(numout,*) ' use adaptive EVP (aEVP) ln_aEVP = ', ln_aEVP 126 WRITE(numout,*) ' creep limit rn_creepl = ', rn_creepl 127 WRITE(numout,*) ' eccentricity of the elliptical yield curve rn_ecc = ', rn_ecc 128 WRITE(numout,*) ' number of iterations for subcycling nn_nevp = ', nn_nevp 129 WRITE(numout,*) ' ratio of elastic timescale over ice time step rn_relast = ', rn_relast 130 WRITE(numout,*) ' check convergence of rheology nn_rhg_chkcvg = ', nn_rhg_chkcvg 131 IF ( nn_rhg_chkcvg == 0 ) THEN ; WRITE(numout,*) ' no check' 132 ELSEIF( nn_rhg_chkcvg == 1 ) THEN ; WRITE(numout,*) ' check cvg at the main time step' 133 ELSEIF( nn_rhg_chkcvg == 2 ) THEN ; WRITE(numout,*) ' check cvg at both main and rheology time steps' 134 ENDIF 130 135 ENDIF 131 136 ! -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/ICE/icedyn_rhg_evp.F90
r13295 r13998 41 41 USE prtctl ! Print control 42 42 43 USE netcdf ! NetCDF library for convergence test 43 44 IMPLICIT NONE 44 45 PRIVATE … … 50 51 # include "do_loop_substitute.h90" 51 52 # include "domzgr_substitute.h90" 53 54 !! for convergence tests 55 INTEGER :: ncvgid ! netcdf file id 56 INTEGER :: nvarid ! netcdf variable id 57 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zmsk00, zmsk15 52 58 !!---------------------------------------------------------------------- 53 59 !! NEMO/ICE 4.0 , NEMO Consortium (2018) … … 121 127 REAL(wp) :: ecc2, z1_ecc2 ! square of yield ellipse eccenticity 122 128 REAL(wp) :: zalph1, z1_alph1, zalph2, z1_alph2 ! alpha coef from Bouillon 2009 or Kimmritz 2017 129 REAl(wp) :: zbetau, zbetav 123 130 REAL(wp) :: zm1, zm2, zm3, zmassU, zmassV, zvU, zvV ! ice/snow mass and volume 124 REAL(wp) :: z delta, zp_delf, zds2, zdt, zdt2, zdiv, zdiv2! temporary scalars131 REAL(wp) :: zp_delf, zds2, zdt, zdt2, zdiv, zdiv2 ! temporary scalars 125 132 REAL(wp) :: zTauO, zTauB, zRHS, zvel ! temporary scalars 126 133 REAL(wp) :: zkt ! isotropic tensile strength for landfast ice 127 134 REAL(wp) :: zvCr ! critical ice volume above which ice is landfast 128 135 ! 129 REAL(wp) :: zresm ! Maximal error on ice velocity130 136 REAL(wp) :: zintb, zintn ! dummy argument 131 137 REAL(wp) :: zfac_x, zfac_y 132 138 REAL(wp) :: zshear, zdum1, zdum2 133 139 ! 134 REAL(wp), DIMENSION(jpi,jpj) :: z p_delt !P/delta at T points140 REAL(wp), DIMENSION(jpi,jpj) :: zdelta, zp_delt ! delta and P/delta at T points 135 141 REAL(wp), DIMENSION(jpi,jpj) :: zbeta ! beta coef from Kimmritz 2017 136 142 ! … … 139 145 REAL(wp), DIMENSION(jpi,jpj) :: zmU_t, zmV_t ! (ice-snow_mass / dt) on U/V points 140 146 REAL(wp), DIMENSION(jpi,jpj) :: zmf ! coriolis parameter at T points 141 REAL(wp), DIMENSION(jpi,jpj) :: v_oceU, u_oceV, v_iceU, u_iceV ! ocean/ice u/v component on V/U points 147 REAL(wp), DIMENSION(jpi,jpj) :: v_oceU, u_oceV, v_iceU, u_iceV ! ocean/ice u/v component on V/U points 142 148 ! 143 149 REAL(wp), DIMENSION(jpi,jpj) :: zds ! shear 150 REAL(wp), DIMENSION(jpi,jpj) :: zten_i ! tension 144 151 REAL(wp), DIMENSION(jpi,jpj) :: zs1, zs2, zs12 ! stress tensor components 145 !!$ REAL(wp), DIMENSION(jpi,jpj) :: zu_ice, zv_ice, zresr ! check convergence146 152 REAL(wp), DIMENSION(jpi,jpj) :: zsshdyn ! array used for the calculation of ice surface slope: 147 153 ! ! ocean surface (ssh_m) if ice is not embedded … … 157 163 REAL(wp), DIMENSION(jpi,jpj) :: zmsk01x, zmsk01y ! dummy arrays 158 164 REAL(wp), DIMENSION(jpi,jpj) :: zmsk00x, zmsk00y ! mask for ice presence 159 REAL(wp), DIMENSION(jpi,jpj) :: zfmask , zwf! mask at F points for the ice165 REAL(wp), DIMENSION(jpi,jpj) :: zfmask ! mask at F points for the ice 160 166 161 167 REAL(wp), PARAMETER :: zepsi = 1.0e-20_wp ! tolerance parameter 162 168 REAL(wp), PARAMETER :: zmmin = 1._wp ! ice mass (kg/m2) below which ice velocity becomes very small 163 169 REAL(wp), PARAMETER :: zamin = 0.001_wp ! ice concentration below which ice velocity becomes very small 170 !! --- check convergence 171 REAL(wp), DIMENSION(jpi,jpj) :: zu_ice, zv_ice 164 172 !! --- diags 165 REAL(wp) , DIMENSION(jpi,jpj) :: zmsk00166 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zsig 1, zsig2, zsig3173 REAL(wp) :: zsig1, zsig2, zsig12, zfac, z1_strength 174 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zsig_I, zsig_II, zsig1_p, zsig2_p 167 175 !! --- SIMIP diags 168 176 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zdiag_xmtrp_ice ! X-component of ice mass transport (kg/s) … … 176 184 IF( kt == nit000 .AND. lwp ) WRITE(numout,*) '-- ice_dyn_rhg_evp: EVP sea-ice rheology' 177 185 ! 178 !!gm for Clem: OPTIMIZATION: I think zfmask can be computed one for all at the initialization.... 186 ! for diagnostics and convergence tests 187 ALLOCATE( zmsk00(jpi,jpj), zmsk15(jpi,jpj) ) 188 DO_2D( 1, 1, 1, 1 ) 189 zmsk00(ji,jj) = MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) - epsi06 ) ) ! 1 if ice , 0 if no ice 190 zmsk15(ji,jj) = MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) - 0.15_wp ) ) ! 1 if 15% ice, 0 if less 191 END_2D 192 ! 193 !!gm for Clem: OPTIMIZATION: I think zfmask can be computed one for all at the initialization.... 179 194 !------------------------------------------------------------------------------! 180 195 ! 0) mask at F points for the ice … … 187 202 188 203 ! Lateral boundary conditions on velocity (modify zfmask) 189 zwf(:,:) = zfmask(:,:)190 204 DO_2D( 0, 0, 0, 0 ) 191 205 IF( zfmask(ji,jj) == 0._wp ) THEN 192 zfmask(ji,jj) = rn_ishlat * MIN( 1._wp , MAX( zwf(ji+1,jj), zwf(ji,jj+1), zwf(ji-1,jj), zwf(ji,jj-1) ) ) 206 zfmask(ji,jj) = rn_ishlat * MIN( 1._wp , MAX( umask(ji,jj,1), umask(ji,jj+1,1), & 207 & vmask(ji,jj,1), vmask(ji+1,jj,1) ) ) 193 208 ENDIF 194 209 END_2D 195 210 DO jj = 2, jpjm1 196 211 IF( zfmask(1,jj) == 0._wp ) THEN 197 zfmask(1 ,jj) = rn_ishlat * MIN( 1._wp , MAX( zwf(2,jj), zwf(1,jj+1), zwf(1,jj-1) ) )212 zfmask(1 ,jj) = rn_ishlat * MIN( 1._wp , MAX( vmask(2,jj,1), umask(1,jj+1,1), umask(1,jj,1) ) ) 198 213 ENDIF 199 214 IF( zfmask(jpi,jj) == 0._wp ) THEN 200 zfmask(jpi,jj) = rn_ishlat * MIN( 1._wp , MAX( zwf(jpi,jj+1), zwf(jpim1,jj), zwf(jpi,jj-1) ) )201 215 zfmask(jpi,jj) = rn_ishlat * MIN( 1._wp , MAX( umask(jpi,jj+1,1), vmask(jpim1,jj,1), umask(jpi,jj-1,1) ) ) 216 ENDIF 202 217 END DO 203 218 DO ji = 2, jpim1 204 219 IF( zfmask(ji,1) == 0._wp ) THEN 205 zfmask(ji, 1 ) = rn_ishlat * MIN( 1._wp , MAX( zwf(ji+1,1), zwf(ji,2), zwf(ji-1,1) ) )220 zfmask(ji, 1 ) = rn_ishlat * MIN( 1._wp , MAX( vmask(ji+1,1,1), umask(ji,2,1), vmask(ji,1,1) ) ) 206 221 ENDIF 207 222 IF( zfmask(ji,jpj) == 0._wp ) THEN 208 zfmask(ji,jpj) = rn_ishlat * MIN( 1._wp , MAX( zwf(ji+1,jpj), zwf(ji-1,jpj), zwf(ji,jpjm1) ) )223 zfmask(ji,jpj) = rn_ishlat * MIN( 1._wp , MAX( vmask(ji+1,jpj,1), vmask(ji-1,jpj,1), umask(ji,jpjm1,1) ) ) 209 224 ENDIF 210 225 END DO … … 220 235 z1_ecc2 = 1._wp / ecc2 221 236 222 ! Time step for subcycling223 zdtevp = rDt_ice / REAL( nn_nevp )224 z1_dtevp = 1._wp / zdtevp225 226 237 ! alpha parameters (Bouillon 2009) 227 238 IF( .NOT. ln_aEVP ) THEN 228 zalph1 = ( 2._wp * rn_relast * rDt_ice ) * z1_dtevp 239 zdtevp = rDt_ice / REAL( nn_nevp ) 240 zalph1 = 2._wp * rn_relast * REAL( nn_nevp ) 229 241 zalph2 = zalph1 * z1_ecc2 230 242 231 243 z1_alph1 = 1._wp / ( zalph1 + 1._wp ) 232 244 z1_alph2 = 1._wp / ( zalph2 + 1._wp ) 233 ENDIF 245 ELSE 246 zdtevp = rdt_ice 247 ! zalpha parameters set later on adaptatively 248 ENDIF 249 z1_dtevp = 1._wp / zdtevp 234 250 235 251 ! Initialise stress tensor … … 242 258 243 259 ! landfast param from Lemieux(2016): add isotropic tensile strength (following Konig Beatty and Holland, 2010) 244 IF( ln_landfast_L16 ) THEN ; zkt = rn_ tensile260 IF( ln_landfast_L16 ) THEN ; zkt = rn_lf_tensile 245 261 ELSE ; zkt = 0._wp 246 262 ENDIF … … 310 326 zvV = 0.5_wp * ( vt_i(ji,jj) * e1e2t(ji,jj) + vt_i(ji,jj+1) * e1e2t(ji,jj+1) ) * r1_e1e2v(ji,jj) * vmask(ji,jj,1) 311 327 ! ice-bottom stress at U points 312 zvCr = zaU(ji,jj) * rn_ depfra * hu(ji,jj,Kmm)313 ztaux_base(ji,jj) = - rn_ icebfr * MAX( 0._wp, zvU - zvCr ) * EXP( -rn_crhg * ( 1._wp - zaU(ji,jj) ) )328 zvCr = zaU(ji,jj) * rn_lf_depfra * hu(ji,jj,Kmm) 329 ztaux_base(ji,jj) = - rn_lf_bfr * MAX( 0._wp, zvU - zvCr ) * EXP( -rn_crhg * ( 1._wp - zaU(ji,jj) ) ) 314 330 ! ice-bottom stress at V points 315 zvCr = zaV(ji,jj) * rn_ depfra * hv(ji,jj,Kmm)316 ztauy_base(ji,jj) = - rn_ icebfr * MAX( 0._wp, zvV - zvCr ) * EXP( -rn_crhg * ( 1._wp - zaV(ji,jj) ) )331 zvCr = zaV(ji,jj) * rn_lf_depfra * hv(ji,jj,Kmm) 332 ztauy_base(ji,jj) = - rn_lf_bfr * MAX( 0._wp, zvV - zvCr ) * EXP( -rn_crhg * ( 1._wp - zaV(ji,jj) ) ) 317 333 ! ice_bottom stress at T points 318 zvCr = at_i(ji,jj) * rn_ depfra * ht(ji,jj)319 tau_icebfr(ji,jj) = - rn_ icebfr * MAX( 0._wp, vt_i(ji,jj) - zvCr ) * EXP( -rn_crhg * ( 1._wp - at_i(ji,jj) ) )334 zvCr = at_i(ji,jj) * rn_lf_depfra * ht(ji,jj) 335 tau_icebfr(ji,jj) = - rn_lf_bfr * MAX( 0._wp, vt_i(ji,jj) - zvCr ) * EXP( -rn_crhg * ( 1._wp - at_i(ji,jj) ) ) 320 336 END_2D 321 337 CALL lbc_lnk( 'icedyn_rhg_evp', tau_icebfr(:,:), 'T', 1.0_wp ) … … 337 353 l_full_nf_update = jter == nn_nevp ! false: disable full North fold update (performances) for iter = 1 to nn_nevp-1 338 354 ! 339 !!$ IF(sn_cfctl%l_prtctl) THEN ! Convergence test 340 !!$ DO jj = 1, jpjm1 341 !!$ zu_ice(:,jj) = u_ice(:,jj) ! velocity at previous time step 342 !!$ zv_ice(:,jj) = v_ice(:,jj) 343 !!$ END DO 344 !!$ ENDIF 355 ! convergence test 356 IF( nn_rhg_chkcvg == 1 .OR. nn_rhg_chkcvg == 2 ) THEN 357 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 358 zu_ice(ji,jj) = u_ice(ji,jj) * umask(ji,jj,1) ! velocity at previous time step 359 zv_ice(ji,jj) = v_ice(ji,jj) * vmask(ji,jj,1) 360 END_2D 361 ENDIF 345 362 346 363 ! --- divergence, tension & shear (Appendix B of Hunke & Dukowicz, 2002) --- ! … … 353 370 354 371 END_2D 355 CALL lbc_lnk( 'icedyn_rhg_evp', zds, 'F', 1.0_wp ) 356 357 DO_2D( 0, 1, 0, 1 ) 372 373 DO_2D( 0, 0, 0, 0 ) 358 374 359 375 ! shear**2 at T points (doc eq. A16) … … 375 391 376 392 ! delta at T points 377 zdelta = SQRT( zdiv2 + ( zdt2 + zds2 ) * z1_ecc2 ) 378 379 ! P/delta at T points 380 zp_delt(ji,jj) = strength(ji,jj) / ( zdelta + rn_creepl ) 381 382 ! alpha & beta for aEVP 393 zdelta(ji,jj) = SQRT( zdiv2 + ( zdt2 + zds2 ) * z1_ecc2 ) 394 395 END_2D 396 CALL lbc_lnk( 'icedyn_rhg_evp', zdelta, 'T', 1.0_wp ) 397 398 ! P/delta at T points 399 DO_2D( 1, 1, 1, 1 ) 400 zp_delt(ji,jj) = strength(ji,jj) / ( zdelta(ji,jj) + rn_creepl ) 401 END_2D 402 403 DO_2D( 0, 1, 0, 1 ) ! loop ends at jpi,jpj so that no lbc_lnk are needed for zs1 and zs2 404 405 ! divergence at T points (duplication to avoid communications) 406 zdiv = ( e2u(ji,jj) * u_ice(ji,jj) - e2u(ji-1,jj) * u_ice(ji-1,jj) & 407 & + e1v(ji,jj) * v_ice(ji,jj) - e1v(ji,jj-1) * v_ice(ji,jj-1) & 408 & ) * r1_e1e2t(ji,jj) 409 410 ! tension at T points (duplication to avoid communications) 411 zdt = ( ( u_ice(ji,jj) * r1_e2u(ji,jj) - u_ice(ji-1,jj) * r1_e2u(ji-1,jj) ) * e2t(ji,jj) * e2t(ji,jj) & 412 & - ( v_ice(ji,jj) * r1_e1v(ji,jj) - v_ice(ji,jj-1) * r1_e1v(ji,jj-1) ) * e1t(ji,jj) * e1t(ji,jj) & 413 & ) * r1_e1e2t(ji,jj) 414 415 ! alpha for aEVP 383 416 ! gamma = 0.5*P/(delta+creepl) * (c*pi)**2/Area * dt/m 384 417 ! alpha = beta = sqrt(4*gamma) … … 388 421 zalph2 = zalph1 389 422 z1_alph2 = z1_alph1 423 ! explicit: 424 ! z1_alph1 = 1._wp / zalph1 425 ! z1_alph2 = 1._wp / zalph1 426 ! zalph1 = zalph1 - 1._wp 427 ! zalph2 = zalph1 390 428 ENDIF 391 429 392 430 ! stress at T points (zkt/=0 if landfast) 393 zs1(ji,jj) = ( zs1(ji,jj) * zalph1 + zp_delt(ji,jj) * ( zdiv * (1._wp + zkt) - zdelta *(1._wp - zkt) ) ) * z1_alph1394 zs2(ji,jj) = ( zs2(ji,jj) *zalph2 + zp_delt(ji,jj) * ( zdt * z1_ecc2 * (1._wp + zkt) ) ) * z1_alph2431 zs1(ji,jj) = ( zs1(ji,jj)*zalph1 + zp_delt(ji,jj) * ( zdiv*(1._wp + zkt) - zdelta(ji,jj)*(1._wp - zkt) ) ) * z1_alph1 432 zs2(ji,jj) = ( zs2(ji,jj)*zalph2 + zp_delt(ji,jj) * ( zdt * z1_ecc2 * (1._wp + zkt) ) ) * z1_alph2 395 433 396 434 END_2D 397 CALL lbc_lnk( 'icedyn_rhg_evp', zp_delt, 'T', 1.0_wp ) 398 435 436 ! Save beta at T-points for further computations 437 IF( ln_aEVP ) THEN 438 DO_2D( 1, 1, 1, 1 ) 439 zbeta(ji,jj) = MAX( 50._wp, rpi * SQRT( 0.5_wp * zp_delt(ji,jj) * r1_e1e2t(ji,jj) * zdt_m(ji,jj) ) ) 440 END_2D 441 ENDIF 442 399 443 DO_2D( 1, 0, 1, 0 ) 400 444 401 ! alpha & betafor aEVP445 ! alpha for aEVP 402 446 IF( ln_aEVP ) THEN 403 zalph2 = MAX( 50._wp, rpi * SQRT( 0.5_wp * zp_delt(ji,jj) * r1_e1e2t(ji,jj) * zdt_m(ji,jj)) )447 zalph2 = MAX( zbeta(ji,jj), zbeta(ji+1,jj), zbeta(ji,jj+1), zbeta(ji+1,jj+1) ) 404 448 z1_alph2 = 1._wp / ( zalph2 + 1._wp ) 405 zbeta(ji,jj) = zalph2 449 ! explicit: 450 ! z1_alph2 = 1._wp / zalph2 451 ! zalph2 = zalph2 - 1._wp 406 452 ENDIF 407 453 … … 469 515 ! 470 516 IF( ln_aEVP ) THEN !--- ice velocity using aEVP (Kimmritz et al 2016 & 2017) 471 v_ice(ji,jj) = ( ( rswitch * ( zmV_t(ji,jj) * ( zbeta(ji,jj) * v_ice(ji,jj) + v_ice_b(ji,jj) ) & ! previous velocity 472 & + zRHS + zTauO * v_ice(ji,jj) ) & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part) 473 & / MAX( zepsi, zmV_t(ji,jj) * ( zbeta(ji,jj) + 1._wp ) + zTauO - zTauB ) & ! m/dt + tau_io(only ice part) + landfast 474 & + ( 1._wp - rswitch ) * v_ice(ji,jj) * MAX( 0._wp, 1._wp - zdtevp * rn_lfrelax ) & ! static friction => slow decrease to v=0 475 & ) * zmsk01y(ji,jj) + v_oce(ji,jj) * 0.01_wp * ( 1._wp - zmsk01y(ji,jj) ) & ! v_ice = v_oce/100 if mass < zmmin & conc < zamin 517 zbetav = MAX( zbeta(ji,jj), zbeta(ji,jj+1) ) 518 v_ice(ji,jj) = ( ( rswitch * ( zmV_t(ji,jj) * ( zbetav * v_ice(ji,jj) + v_ice_b(ji,jj) ) & ! previous velocity 519 & + zRHS + zTauO * v_ice(ji,jj) & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part) 520 & ) / MAX( zepsi, zmV_t(ji,jj) * ( zbetav + 1._wp ) + zTauO - zTauB ) & ! m/dt + tau_io(only ice part) + landfast 521 & + ( 1._wp - rswitch ) * ( v_ice_b(ji,jj) & 522 & + v_ice (ji,jj) * MAX( 0._wp, zbetav - zdtevp * rn_lf_relax ) & ! static friction => slow decrease to v=0 523 & ) / ( zbetav + 1._wp ) & 524 & ) * zmsk01y(ji,jj) + v_oce(ji,jj) * 0.01_wp * ( 1._wp - zmsk01y(ji,jj) ) & ! v_ice = v_oce/100 if mass < zmmin & conc < zamin 476 525 & ) * zmsk00y(ji,jj) 477 526 ELSE !--- ice velocity using EVP implicit formulation (cf Madec doc & Bouillon 2009) 478 v_ice(ji,jj) = ( ( rswitch * ( zmV_t(ji,jj)* v_ice(ji,jj) & ! previous velocity479 & + zRHS + zTauO * v_ice(ji,jj) )& ! F + tau_ia + Coriolis + spg + tau_io(only ocean part)480 & / MAX( zepsi, zmV_t(ji,jj) + zTauO - zTauB )& ! m/dt + tau_io(only ice part) + landfast481 & + ( 1._wp - rswitch ) * v_ice(ji,jj) * MAX( 0._wp, 1._wp - zdtevp * rn_lfrelax )& ! static friction => slow decrease to v=0482 & ) * zmsk01y(ji,jj) + v_oce(ji,jj) * 0.01_wp * ( 1._wp - zmsk01y(ji,jj) )& ! v_ice = v_oce/100 if mass < zmmin & conc < zamin483 & ) 527 v_ice(ji,jj) = ( ( rswitch * ( zmV_t(ji,jj) * v_ice(ji,jj) & ! previous velocity 528 & + zRHS + zTauO * v_ice(ji,jj) & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part) 529 & ) / MAX( zepsi, zmV_t(ji,jj) + zTauO - zTauB ) & ! m/dt + tau_io(only ice part) + landfast 530 & + ( 1._wp - rswitch ) * v_ice(ji,jj) * MAX( 0._wp, 1._wp - zdtevp * rn_lf_relax ) & ! static friction => slow decrease to v=0 531 & ) * zmsk01y(ji,jj) + v_oce(ji,jj) * 0.01_wp * ( 1._wp - zmsk01y(ji,jj) ) & ! v_ice = v_oce/100 if mass < zmmin & conc < zamin 532 & ) * zmsk00y(ji,jj) 484 533 ENDIF 485 534 END_2D … … 518 567 ! 519 568 IF( ln_aEVP ) THEN !--- ice velocity using aEVP (Kimmritz et al 2016 & 2017) 520 u_ice(ji,jj) = ( ( rswitch * ( zmU_t(ji,jj) * ( zbeta(ji,jj) * u_ice(ji,jj) + u_ice_b(ji,jj) ) & ! previous velocity 521 & + zRHS + zTauO * u_ice(ji,jj) ) & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part) 522 & / MAX( zepsi, zmU_t(ji,jj) * ( zbeta(ji,jj) + 1._wp ) + zTauO - zTauB ) & ! m/dt + tau_io(only ice part) + landfast 523 & + ( 1._wp - rswitch ) * u_ice(ji,jj) * MAX( 0._wp, 1._wp - zdtevp * rn_lfrelax ) & ! static friction => slow decrease to v=0 524 & ) * zmsk01x(ji,jj) + u_oce(ji,jj) * 0.01_wp * ( 1._wp - zmsk01x(ji,jj) ) & ! v_ice = v_oce/100 if mass < zmmin & conc < zamin 569 zbetau = MAX( zbeta(ji,jj), zbeta(ji+1,jj) ) 570 u_ice(ji,jj) = ( ( rswitch * ( zmU_t(ji,jj) * ( zbetau * u_ice(ji,jj) + u_ice_b(ji,jj) ) & ! previous velocity 571 & + zRHS + zTauO * u_ice(ji,jj) & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part) 572 & ) / MAX( zepsi, zmU_t(ji,jj) * ( zbetau + 1._wp ) + zTauO - zTauB ) & ! m/dt + tau_io(only ice part) + landfast 573 & + ( 1._wp - rswitch ) * ( u_ice_b(ji,jj) & 574 & + u_ice (ji,jj) * MAX( 0._wp, zbetau - zdtevp * rn_lf_relax ) & ! static friction => slow decrease to v=0 575 & ) / ( zbetau + 1._wp ) & 576 & ) * zmsk01x(ji,jj) + u_oce(ji,jj) * 0.01_wp * ( 1._wp - zmsk01x(ji,jj) ) & ! v_ice = v_oce/100 if mass < zmmin & conc < zamin 525 577 & ) * zmsk00x(ji,jj) 526 578 ELSE !--- ice velocity using EVP implicit formulation (cf Madec doc & Bouillon 2009) 527 u_ice(ji,jj) = ( ( rswitch * ( zmU_t(ji,jj)* u_ice(ji,jj) & ! previous velocity528 & + zRHS + zTauO * u_ice(ji,jj) )& ! F + tau_ia + Coriolis + spg + tau_io(only ocean part)529 & / MAX( zepsi, zmU_t(ji,jj) + zTauO - zTauB )& ! m/dt + tau_io(only ice part) + landfast530 & + ( 1._wp - rswitch ) * u_ice(ji,jj) * MAX( 0._wp, 1._wp - zdtevp * rn_lfrelax )& ! static friction => slow decrease to v=0531 & ) * zmsk01x(ji,jj) + u_oce(ji,jj) * 0.01_wp * ( 1._wp - zmsk01x(ji,jj) )& ! v_ice = v_oce/100 if mass < zmmin & conc < zamin532 & 579 u_ice(ji,jj) = ( ( rswitch * ( zmU_t(ji,jj) * u_ice(ji,jj) & ! previous velocity 580 & + zRHS + zTauO * u_ice(ji,jj) & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part) 581 & ) / MAX( zepsi, zmU_t(ji,jj) + zTauO - zTauB ) & ! m/dt + tau_io(only ice part) + landfast 582 & + ( 1._wp - rswitch ) * u_ice(ji,jj) * MAX( 0._wp, 1._wp - zdtevp * rn_lf_relax ) & ! static friction => slow decrease to v=0 583 & ) * zmsk01x(ji,jj) + u_oce(ji,jj) * 0.01_wp * ( 1._wp - zmsk01x(ji,jj) ) & ! v_ice = v_oce/100 if mass < zmmin & conc < zamin 584 & ) * zmsk00x(ji,jj) 533 585 ENDIF 534 586 END_2D … … 569 621 ! 570 622 IF( ln_aEVP ) THEN !--- ice velocity using aEVP (Kimmritz et al 2016 & 2017) 571 u_ice(ji,jj) = ( ( rswitch * ( zmU_t(ji,jj) * ( zbeta(ji,jj) * u_ice(ji,jj) + u_ice_b(ji,jj) ) & ! previous velocity 572 & + zRHS + zTauO * u_ice(ji,jj) ) & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part) 573 & / MAX( zepsi, zmU_t(ji,jj) * ( zbeta(ji,jj) + 1._wp ) + zTauO - zTauB ) & ! m/dt + tau_io(only ice part) + landfast 574 & + ( 1._wp - rswitch ) * u_ice(ji,jj) * MAX( 0._wp, 1._wp - zdtevp * rn_lfrelax ) & ! static friction => slow decrease to v=0 575 & ) * zmsk01x(ji,jj) + u_oce(ji,jj) * 0.01_wp * ( 1._wp - zmsk01x(ji,jj) ) & ! v_ice = v_oce/100 if mass < zmmin & conc < zamin 623 zbetau = MAX( zbeta(ji,jj), zbeta(ji+1,jj) ) 624 u_ice(ji,jj) = ( ( rswitch * ( zmU_t(ji,jj) * ( zbetau * u_ice(ji,jj) + u_ice_b(ji,jj) ) & ! previous velocity 625 & + zRHS + zTauO * u_ice(ji,jj) & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part) 626 & ) / MAX( zepsi, zmU_t(ji,jj) * ( zbetau + 1._wp ) + zTauO - zTauB ) & ! m/dt + tau_io(only ice part) + landfast 627 & + ( 1._wp - rswitch ) * ( u_ice_b(ji,jj) & 628 & + u_ice (ji,jj) * MAX( 0._wp, zbetau - zdtevp * rn_lf_relax ) & ! static friction => slow decrease to v=0 629 & ) / ( zbetau + 1._wp ) & 630 & ) * zmsk01x(ji,jj) + u_oce(ji,jj) * 0.01_wp * ( 1._wp - zmsk01x(ji,jj) ) & ! v_ice = v_oce/100 if mass < zmmin & conc < zamin 576 631 & ) * zmsk00x(ji,jj) 577 632 ELSE !--- ice velocity using EVP implicit formulation (cf Madec doc & Bouillon 2009) 578 u_ice(ji,jj) = ( ( rswitch * ( zmU_t(ji,jj)* u_ice(ji,jj) & ! previous velocity579 & + zRHS + zTauO * u_ice(ji,jj) )& ! F + tau_ia + Coriolis + spg + tau_io(only ocean part)580 & / MAX( zepsi, zmU_t(ji,jj) + zTauO - zTauB )& ! m/dt + tau_io(only ice part) + landfast581 & + ( 1._wp - rswitch ) * u_ice(ji,jj) * MAX( 0._wp, 1._wp - zdtevp * rn_lfrelax )& ! static friction => slow decrease to v=0582 & ) * zmsk01x(ji,jj) + u_oce(ji,jj) * 0.01_wp * ( 1._wp - zmsk01x(ji,jj) )& ! v_ice = v_oce/100 if mass < zmmin & conc < zamin583 & 633 u_ice(ji,jj) = ( ( rswitch * ( zmU_t(ji,jj) * u_ice(ji,jj) & ! previous velocity 634 & + zRHS + zTauO * u_ice(ji,jj) & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part) 635 & ) / MAX( zepsi, zmU_t(ji,jj) + zTauO - zTauB ) & ! m/dt + tau_io(only ice part) + landfast 636 & + ( 1._wp - rswitch ) * u_ice(ji,jj) * MAX( 0._wp, 1._wp - zdtevp * rn_lf_relax ) & ! static friction => slow decrease to v=0 637 & ) * zmsk01x(ji,jj) + u_oce(ji,jj) * 0.01_wp * ( 1._wp - zmsk01x(ji,jj) ) & ! v_ice = v_oce/100 if mass < zmmin & conc < zamin 638 & ) * zmsk00x(ji,jj) 584 639 ENDIF 585 640 END_2D … … 618 673 ! 619 674 IF( ln_aEVP ) THEN !--- ice velocity using aEVP (Kimmritz et al 2016 & 2017) 620 v_ice(ji,jj) = ( ( rswitch * ( zmV_t(ji,jj) * ( zbeta(ji,jj) * v_ice(ji,jj) + v_ice_b(ji,jj) ) & ! previous velocity 621 & + zRHS + zTauO * v_ice(ji,jj) ) & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part) 622 & / MAX( zepsi, zmV_t(ji,jj) * ( zbeta(ji,jj) + 1._wp ) + zTauO - zTauB ) & ! m/dt + tau_io(only ice part) + landfast 623 & + ( 1._wp - rswitch ) * v_ice(ji,jj) * MAX( 0._wp, 1._wp - zdtevp * rn_lfrelax ) & ! static friction => slow decrease to v=0 624 & ) * zmsk01y(ji,jj) + v_oce(ji,jj) * 0.01_wp * ( 1._wp - zmsk01y(ji,jj) ) & ! v_ice = v_oce/100 if mass < zmmin & conc < zamin 675 zbetav = MAX( zbeta(ji,jj), zbeta(ji,jj+1) ) 676 v_ice(ji,jj) = ( ( rswitch * ( zmV_t(ji,jj) * ( zbetav * v_ice(ji,jj) + v_ice_b(ji,jj) ) & ! previous velocity 677 & + zRHS + zTauO * v_ice(ji,jj) & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part) 678 & ) / MAX( zepsi, zmV_t(ji,jj) * ( zbetav + 1._wp ) + zTauO - zTauB ) & ! m/dt + tau_io(only ice part) + landfast 679 & + ( 1._wp - rswitch ) * ( v_ice_b(ji,jj) & 680 & + v_ice (ji,jj) * MAX( 0._wp, zbetav - zdtevp * rn_lf_relax ) & ! static friction => slow decrease to v=0 681 & ) / ( zbetav + 1._wp ) & 682 & ) * zmsk01y(ji,jj) + v_oce(ji,jj) * 0.01_wp * ( 1._wp - zmsk01y(ji,jj) ) & ! v_ice = v_oce/100 if mass < zmmin & conc < zamin 625 683 & ) * zmsk00y(ji,jj) 626 684 ELSE !--- ice velocity using EVP implicit formulation (cf Madec doc & Bouillon 2009) 627 v_ice(ji,jj) = ( ( rswitch * ( zmV_t(ji,jj)* v_ice(ji,jj) & ! previous velocity628 & + zRHS + zTauO * v_ice(ji,jj) )& ! F + tau_ia + Coriolis + spg + tau_io(only ocean part)629 & / MAX( zepsi, zmV_t(ji,jj) + zTauO - zTauB )& ! m/dt + tau_io(only ice part) + landfast630 & + ( 1._wp - rswitch ) * v_ice(ji,jj) * MAX( 0._wp, 1._wp - zdtevp * rn_lfrelax )& ! static friction => slow decrease to v=0631 & ) * zmsk01y(ji,jj) + v_oce(ji,jj) * 0.01_wp * ( 1._wp - zmsk01y(ji,jj) )& ! v_ice = v_oce/100 if mass < zmmin & conc < zamin632 & 685 v_ice(ji,jj) = ( ( rswitch * ( zmV_t(ji,jj) * v_ice(ji,jj) & ! previous velocity 686 & + zRHS + zTauO * v_ice(ji,jj) & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part) 687 & ) / MAX( zepsi, zmV_t(ji,jj) + zTauO - zTauB ) & ! m/dt + tau_io(only ice part) + landfast 688 & + ( 1._wp - rswitch ) * v_ice(ji,jj) * MAX( 0._wp, 1._wp - zdtevp * rn_lf_relax ) & ! static friction => slow decrease to v=0 689 & ) * zmsk01y(ji,jj) + v_oce(ji,jj) * 0.01_wp * ( 1._wp - zmsk01y(ji,jj) ) & ! v_ice = v_oce/100 if mass < zmmin & conc < zamin 690 & ) * zmsk00y(ji,jj) 633 691 ENDIF 634 692 END_2D … … 643 701 ENDIF 644 702 645 !!$ IF(sn_cfctl%l_prtctl) THEN ! Convergence test 646 !!$ DO jj = 2 , jpjm1 647 !!$ zresr(:,jj) = MAX( ABS( u_ice(:,jj) - zu_ice(:,jj) ), ABS( v_ice(:,jj) - zv_ice(:,jj) ) ) 648 !!$ END DO 649 !!$ zresm = MAXVAL( zresr( 1:jpi, 2:jpjm1 ) ) 650 !!$ CALL mpp_max( 'icedyn_rhg_evp', zresm ) ! max over the global domain 651 !!$ ENDIF 703 ! convergence test 704 IF( nn_rhg_chkcvg == 2 ) CALL rhg_cvg( kt, jter, nn_nevp, u_ice, v_ice, zu_ice, zv_ice ) 652 705 ! 653 706 ! ! ==================== ! 654 707 END DO ! end loop over jter ! 655 708 ! ! ==================== ! 709 IF( ln_aEVP ) CALL iom_put( 'beta_evp' , zbeta ) 656 710 ! 657 711 !------------------------------------------------------------------------------! … … 667 721 END_2D 668 722 669 DO_2D( 0, 0, 0, 0 ) 723 DO_2D( 0, 0, 0, 0 ) ! no vector loop 670 724 671 725 ! tension**2 at T points … … 674 728 & ) * r1_e1e2t(ji,jj) 675 729 zdt2 = zdt * zdt 730 731 zten_i(ji,jj) = zdt 676 732 677 733 ! shear**2 at T points (doc eq. A16) … … 689 745 690 746 ! delta at T points 691 z delta = SQRT( pdivu_i(ji,jj) * pdivu_i(ji,jj) + ( zdt2 + zds2 ) * z1_ecc2 )692 rswitch = 1._wp - MAX( 0._wp, SIGN( 1._wp, -zdelta) ) ! 0 if delta=0693 pdelta_i(ji,jj) = z delta + rn_creepl * rswitch747 zfac = SQRT( pdivu_i(ji,jj) * pdivu_i(ji,jj) + ( zdt2 + zds2 ) * z1_ecc2 ) ! delta 748 rswitch = 1._wp - MAX( 0._wp, SIGN( 1._wp, -zfac ) ) ! 0 if delta=0 749 pdelta_i(ji,jj) = zfac + rn_creepl * rswitch ! delta+creepl 694 750 695 751 END_2D 696 CALL lbc_lnk_multi( 'icedyn_rhg_evp', pshear_i, 'T', 1.0_wp, pdivu_i, 'T', 1.0_wp, pdelta_i, 'T', 1.0_wp ) 752 CALL lbc_lnk_multi( 'icedyn_rhg_evp', pshear_i, 'T', 1._wp, pdivu_i, 'T', 1._wp, pdelta_i, 'T', 1._wp, zten_i, 'T', 1._wp, & 753 & zs1 , 'T', 1._wp, zs2 , 'T', 1._wp, zs12 , 'F', 1._wp ) 697 754 698 755 ! --- Store the stress tensor for the next time step --- ! 699 CALL lbc_lnk_multi( 'icedyn_rhg_evp', zs1, 'T', 1.0_wp, zs2, 'T', 1.0_wp, zs12, 'F', 1.0_wp )700 756 pstress1_i (:,:) = zs1 (:,:) 701 757 pstress2_i (:,:) = zs2 (:,:) … … 706 762 ! 5) diagnostics 707 763 !------------------------------------------------------------------------------! 708 DO_2D( 1, 1, 1, 1 )709 zmsk00(ji,jj) = MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) - epsi06 ) ) ! 1 if ice, 0 if no ice710 END_2D711 712 764 ! --- ice-ocean, ice-atm. & ice-oceanbottom(landfast) stresses --- ! 713 765 IF( iom_use('utau_oi') .OR. iom_use('vtau_oi') .OR. iom_use('utau_ai') .OR. iom_use('vtau_ai') .OR. & … … 730 782 IF( iom_use('icestr') ) CALL iom_put( 'icestr' , strength * zmsk00 ) ! strength 731 783 732 ! --- stress tensor--- !733 IF( iom_use(' isig1') .OR. iom_use('isig2') .OR. iom_use('isig3') .OR. iom_use('normstr') .OR. iom_use('sheastr') ) THEN734 ! 735 ALLOCATE( zsig 1(jpi,jpj) , zsig2(jpi,jpj) , zsig3(jpi,jpj) )784 ! --- Stress tensor invariants (SIMIP diags) --- ! 785 IF( iom_use('normstr') .OR. iom_use('sheastr') ) THEN 786 ! 787 ALLOCATE( zsig_I(jpi,jpj) , zsig_II(jpi,jpj) ) 736 788 ! 737 DO_2D( 0, 0, 0, 0 ) 738 zdum1 = ( zmsk00(ji-1,jj) * pstress12_i(ji-1,jj) + zmsk00(ji ,jj-1) * pstress12_i(ji ,jj-1) + & ! stress12_i at T-point 739 & zmsk00(ji ,jj) * pstress12_i(ji ,jj) + zmsk00(ji-1,jj-1) * pstress12_i(ji-1,jj-1) ) & 740 & / MAX( 1._wp, zmsk00(ji-1,jj) + zmsk00(ji,jj-1) + zmsk00(ji,jj) + zmsk00(ji-1,jj-1) ) 741 742 zshear = SQRT( pstress2_i(ji,jj) * pstress2_i(ji,jj) + 4._wp * zdum1 * zdum1 ) ! shear stress 743 744 zdum2 = zmsk00(ji,jj) / MAX( 1._wp, strength(ji,jj) ) 745 746 !! zsig1(ji,jj) = 0.5_wp * zdum2 * ( pstress1_i(ji,jj) + zshear ) ! principal stress (y-direction, see Hunke & Dukowicz 2002) 747 !! zsig2(ji,jj) = 0.5_wp * zdum2 * ( pstress1_i(ji,jj) - zshear ) ! principal stress (x-direction, see Hunke & Dukowicz 2002) 748 !! zsig3(ji,jj) = zdum2**2 * ( ( pstress1_i(ji,jj) + strength(ji,jj) )**2 + ( rn_ecc * zshear )**2 ) ! quadratic relation linking compressive stress to shear stress 749 !! ! (scheme converges if this value is ~1, see Bouillon et al 2009 (eq. 11)) 750 zsig1(ji,jj) = 0.5_wp * zdum2 * ( pstress1_i(ji,jj) ) ! compressive stress, see Bouillon et al. 2015 751 zsig2(ji,jj) = 0.5_wp * zdum2 * ( zshear ) ! shear stress 752 zsig3(ji,jj) = zdum2**2 * ( ( pstress1_i(ji,jj) + strength(ji,jj) )**2 + ( rn_ecc * zshear )**2 ) 753 END_2D 754 CALL lbc_lnk_multi( 'icedyn_rhg_evp', zsig1, 'T', 1.0_wp, zsig2, 'T', 1.0_wp, zsig3, 'T', 1.0_wp ) 755 ! 756 CALL iom_put( 'isig1' , zsig1 ) 757 CALL iom_put( 'isig2' , zsig2 ) 758 CALL iom_put( 'isig3' , zsig3 ) 759 ! 760 ! Stress tensor invariants (normal and shear stress N/m) 761 IF( iom_use('normstr') ) CALL iom_put( 'normstr' , ( zs1(:,:) + zs2(:,:) ) * zmsk00(:,:) ) ! Normal stress 762 IF( iom_use('sheastr') ) CALL iom_put( 'sheastr' , SQRT( ( zs1(:,:) - zs2(:,:) )**2 + 4*zs12(:,:)**2 ) * zmsk00(:,:) ) ! Shear stress 763 764 DEALLOCATE( zsig1 , zsig2 , zsig3 ) 765 ENDIF 766 789 DO_2D( 1, 1, 1, 1 ) 790 791 ! Ice stresses 792 ! sigma1, sigma2, sigma12 are some useful recombination of the stresses (Hunke and Dukowicz MWR 2002, Bouillon et al., OM2013) 793 ! These are NOT stress tensor components, neither stress invariants, neither stress principal components 794 ! I know, this can be confusing... 795 zfac = strength(ji,jj) / ( pdelta_i(ji,jj) + rn_creepl ) 796 zsig1 = zfac * ( pdivu_i(ji,jj) - pdelta_i(ji,jj) ) 797 zsig2 = zfac * z1_ecc2 * zten_i(ji,jj) 798 zsig12 = zfac * z1_ecc2 * pshear_i(ji,jj) 799 800 ! Stress invariants (sigma_I, sigma_II, Coon 1974, Feltham 2008) 801 zsig_I (ji,jj) = zsig1 * 0.5_wp ! 1st stress invariant, aka average normal stress, aka negative pressure 802 zsig_II(ji,jj) = SQRT ( MAX( 0._wp, zsig2 * zsig2 * 0.25_wp + zsig12 ) ) ! 2nd '' '', aka maximum shear stress 803 804 END_2D 805 ! 806 ! Stress tensor invariants (normal and shear stress N/m) - SIMIP diags - definitions following Coon (1974) and Feltham (2008) 807 IF( iom_use('normstr') ) CALL iom_put( 'normstr', zsig_I (:,:) * zmsk00(:,:) ) ! Normal stress 808 IF( iom_use('sheastr') ) CALL iom_put( 'sheastr', zsig_II(:,:) * zmsk00(:,:) ) ! Maximum shear stress 809 810 DEALLOCATE ( zsig_I, zsig_II ) 811 812 ENDIF 813 814 ! --- Normalized stress tensor principal components --- ! 815 ! This are used to plot the normalized yield curve, see Lemieux & Dupont, 2020 816 ! Recommendation 1 : we use ice strength, not replacement pressure 817 ! Recommendation 2 : need to use deformations at PREVIOUS iterate for viscosities 818 IF( iom_use('sig1_pnorm') .OR. iom_use('sig2_pnorm') ) THEN 819 ! 820 ALLOCATE( zsig1_p(jpi,jpj) , zsig2_p(jpi,jpj) , zsig_I(jpi,jpj) , zsig_II(jpi,jpj) ) 821 ! 822 DO_2D( 1, 1, 1, 1 ) 823 824 ! Ice stresses computed with **viscosities** (delta, p/delta) at **previous** iterates 825 ! and **deformations** at current iterates 826 ! following Lemieux & Dupont (2020) 827 zfac = zp_delt(ji,jj) 828 zsig1 = zfac * ( pdivu_i(ji,jj) - ( zdelta(ji,jj) + rn_creepl ) ) 829 zsig2 = zfac * z1_ecc2 * zten_i(ji,jj) 830 zsig12 = zfac * z1_ecc2 * pshear_i(ji,jj) 831 832 ! Stress invariants (sigma_I, sigma_II, Coon 1974, Feltham 2008), T-point 833 zsig_I(ji,jj) = zsig1 * 0.5_wp ! 1st stress invariant, aka average normal stress, aka negative pressure 834 zsig_II(ji,jj) = SQRT ( MAX( 0._wp, zsig2 * zsig2 * 0.25_wp + zsig12 ) ) ! 2nd '' '', aka maximum shear stress 835 836 ! Normalized principal stresses (used to display the ellipse) 837 z1_strength = 1._wp / MAX( 1._wp, strength(ji,jj) ) 838 zsig1_p(ji,jj) = ( zsig_I(ji,jj) + zsig_II(ji,jj) ) * z1_strength 839 zsig2_p(ji,jj) = ( zsig_I(ji,jj) - zsig_II(ji,jj) ) * z1_strength 840 END_2D 841 ! 842 CALL iom_put( 'sig1_pnorm' , zsig1_p ) 843 CALL iom_put( 'sig2_pnorm' , zsig2_p ) 844 845 DEALLOCATE( zsig1_p , zsig2_p , zsig_I, zsig_II ) 846 847 ENDIF 848 767 849 ! --- SIMIP --- ! 768 850 IF( iom_use('dssh_dx') .OR. iom_use('dssh_dy') .OR. & … … 818 900 ENDIF 819 901 ! 902 ! --- convergence tests --- ! 903 IF( nn_rhg_chkcvg == 1 .OR. nn_rhg_chkcvg == 2 ) THEN 904 IF( iom_use('uice_cvg') ) THEN 905 IF( ln_aEVP ) THEN ! output: beta * ( u(t=nn_nevp) - u(t=nn_nevp-1) ) 906 CALL iom_put( 'uice_cvg', MAX( ABS( u_ice(:,:) - zu_ice(:,:) ) * zbeta(:,:) * umask(:,:,1) , & 907 & ABS( v_ice(:,:) - zv_ice(:,:) ) * zbeta(:,:) * vmask(:,:,1) ) * zmsk15(:,:) ) 908 ELSE ! output: nn_nevp * ( u(t=nn_nevp) - u(t=nn_nevp-1) ) 909 CALL iom_put( 'uice_cvg', REAL( nn_nevp ) * MAX( ABS( u_ice(:,:) - zu_ice(:,:) ) * umask(:,:,1) , & 910 & ABS( v_ice(:,:) - zv_ice(:,:) ) * vmask(:,:,1) ) * zmsk15(:,:) ) 911 ENDIF 912 ENDIF 913 ENDIF 914 ! 915 DEALLOCATE( zmsk00, zmsk15 ) 916 ! 820 917 END SUBROUTINE ice_dyn_rhg_evp 918 919 920 SUBROUTINE rhg_cvg( kt, kiter, kitermax, pu, pv, pub, pvb ) 921 !!---------------------------------------------------------------------- 922 !! *** ROUTINE rhg_cvg *** 923 !! 924 !! ** Purpose : check convergence of oce rheology 925 !! 926 !! ** Method : create a file ice_cvg.nc containing the convergence of ice velocity 927 !! during the sub timestepping of rheology so as: 928 !! uice_cvg = MAX( u(t+1) - u(t) , v(t+1) - v(t) ) 929 !! This routine is called every sub-iteration, so it is cpu expensive 930 !! 931 !! ** Note : for the first sub-iteration, uice_cvg is set to 0 (too large otherwise) 932 !!---------------------------------------------------------------------- 933 INTEGER , INTENT(in) :: kt, kiter, kitermax ! ocean time-step index 934 REAL(wp), DIMENSION(:,:), INTENT(in) :: pu, pv, pub, pvb ! now and before velocities 935 !! 936 INTEGER :: it, idtime, istatus 937 INTEGER :: ji, jj ! dummy loop indices 938 REAL(wp) :: zresm ! local real 939 CHARACTER(len=20) :: clname 940 REAL(wp), DIMENSION(jpi,jpj) :: zres ! check convergence 941 !!---------------------------------------------------------------------- 942 943 ! create file 944 IF( kt == nit000 .AND. kiter == 1 ) THEN 945 ! 946 IF( lwp ) THEN 947 WRITE(numout,*) 948 WRITE(numout,*) 'rhg_cvg : ice rheology convergence control' 949 WRITE(numout,*) '~~~~~~~' 950 ENDIF 951 ! 952 IF( lwm ) THEN 953 clname = 'ice_cvg.nc' 954 IF( .NOT. Agrif_Root() ) clname = TRIM(Agrif_CFixed())//"_"//TRIM(clname) 955 istatus = NF90_CREATE( TRIM(clname), NF90_CLOBBER, ncvgid ) 956 istatus = NF90_DEF_DIM( ncvgid, 'time' , NF90_UNLIMITED, idtime ) 957 istatus = NF90_DEF_VAR( ncvgid, 'uice_cvg', NF90_DOUBLE , (/ idtime /), nvarid ) 958 istatus = NF90_ENDDEF(ncvgid) 959 ENDIF 960 ! 961 ENDIF 962 963 ! time 964 it = ( kt - 1 ) * kitermax + kiter 965 966 ! convergence 967 IF( kiter == 1 ) THEN ! remove the first iteration for calculations of convergence (always very large) 968 zresm = 0._wp 969 ELSE 970 DO_2D( 1, 1, 1, 1 ) 971 zres(ji,jj) = MAX( ABS( pu(ji,jj) - pub(ji,jj) ) * umask(ji,jj,1), & 972 & ABS( pv(ji,jj) - pvb(ji,jj) ) * vmask(ji,jj,1) ) * zmsk15(ji,jj) 973 END_2D 974 zresm = MAXVAL( zres ) 975 CALL mpp_max( 'icedyn_rhg_evp', zresm ) ! max over the global domain 976 ENDIF 977 978 IF( lwm ) THEN 979 ! write variables 980 istatus = NF90_PUT_VAR( ncvgid, nvarid, (/zresm/), (/it/), (/1/) ) 981 ! close file 982 IF( kt == nitend - nn_fsbc + 1 ) istatus = NF90_CLOSE(ncvgid) 983 ENDIF 984 985 END SUBROUTINE rhg_cvg 821 986 822 987 … … 876 1041 END SUBROUTINE rhg_evp_rst 877 1042 1043 878 1044 #else 879 1045 !!---------------------------------------------------------------------- -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/ICE/iceistate.F90
r13732 r13998 51 51 ! !! ** namelist (namini) ** 52 52 LOGICAL, PUBLIC :: ln_iceini !: Ice initialization or not 53 LOGICAL, PUBLIC :: ln_iceini_file !: Ice initialization from 2D netcdf file 53 INTEGER, PUBLIC :: nn_iceini_file !: Ice initialization: 54 ! 0 = Initialise sea ice based on SSTs 55 ! 1 = Initialise sea ice from single category netcdf file 56 ! 2 = Initialise sea ice from multi category restart file 54 57 REAL(wp) :: rn_thres_sst 55 58 REAL(wp) :: rn_hti_ini_n, rn_hts_ini_n, rn_ati_ini_n, rn_smi_ini_n, rn_tmi_ini_n, rn_tsu_ini_n, rn_tms_ini_n 56 59 REAL(wp) :: rn_hti_ini_s, rn_hts_ini_s, rn_ati_ini_s, rn_smi_ini_s, rn_tmi_ini_s, rn_tsu_ini_s, rn_tms_ini_s 57 REAL(wp) :: rn_apd_ini_n, rn_hpd_ini_n 58 REAL(wp) :: rn_apd_ini_s, rn_hpd_ini_s 60 REAL(wp) :: rn_apd_ini_n, rn_hpd_ini_n, rn_hld_ini_n 61 REAL(wp) :: rn_apd_ini_s, rn_hpd_ini_s, rn_hld_ini_s 59 62 ! 60 ! ! if ln_iceini_file = T61 INTEGER , PARAMETER :: jpfldi = 9! maximum number of files to read63 ! ! if nn_iceini_file = 1 64 INTEGER , PARAMETER :: jpfldi = 10 ! maximum number of files to read 62 65 INTEGER , PARAMETER :: jp_hti = 1 ! index of ice thickness (m) 63 66 INTEGER , PARAMETER :: jp_hts = 2 ! index of snw thickness (m) … … 69 72 INTEGER , PARAMETER :: jp_apd = 8 ! index of pnd fraction (-) 70 73 INTEGER , PARAMETER :: jp_hpd = 9 ! index of pnd depth (m) 74 INTEGER , PARAMETER :: jp_hld = 10 ! index of pnd lid depth (m) 71 75 TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: si ! structure of input fields (file informations, fields read) 72 76 … … 93 97 !! ** Steps : 1) Set initial surface and basal temperatures 94 98 !! 2) Recompute or read sea ice state variables 95 !! 3) Fill in the ice thickness distribution using gaussian 96 !! 4) Fill in space-dependent arrays for state variables 97 !! 5) snow-ice mass computation 98 !! 6) store before fields 99 !! 3) Fill in space-dependent arrays for state variables 100 !! 4) snow-ice mass computation 99 101 !! 100 102 !! ** Notes : o_i, t_su, t_s, t_i, sz_i must be filled everywhere, even … … 111 113 REAL(wp), DIMENSION(jpi,jpj) :: zht_i_ini, zat_i_ini, ztm_s_ini !data from namelist or nc file 112 114 REAL(wp), DIMENSION(jpi,jpj) :: zt_su_ini, zht_s_ini, zsm_i_ini, ztm_i_ini !data from namelist or nc file 113 REAL(wp), DIMENSION(jpi,jpj) :: zapnd_ini, zhpnd_ini 114 REAL(wp), DIMENSION(jpi,jpj,jpl) :: zti_3d , zts_3d ! locakarrays115 !! 116 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: zhi_2d, zhs_2d, zai_2d, zti_2d, zts_2d, ztsu_2d, zsi_2d, zaip_2d, zhip_2d 115 REAL(wp), DIMENSION(jpi,jpj) :: zapnd_ini, zhpnd_ini, zhlid_ini !data from namelist or nc file 116 REAL(wp), DIMENSION(jpi,jpj,jpl) :: zti_3d , zts_3d !temporary arrays 117 !! 118 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: zhi_2d, zhs_2d, zai_2d, zti_2d, zts_2d, ztsu_2d, zsi_2d, zaip_2d, zhip_2d, zhil_2d 117 119 !-------------------------------------------------------------------- 118 120 … … 168 170 a_ip (:,:,:) = 0._wp 169 171 v_ip (:,:,:) = 0._wp 170 a_ip_frac(:,:,:) = 0._wp 172 v_il (:,:,:) = 0._wp 173 a_ip_eff (:,:,:) = 0._wp 171 174 h_ip (:,:,:) = 0._wp 175 h_il (:,:,:) = 0._wp 172 176 ! 173 177 ! ice velocities … … 178 182 ! 2) overwrite some of the fields with namelist parameters or netcdf file 179 183 !------------------------------------------------------------------------ 180 181 182 184 IF( ln_iceini ) THEN 183 ! !---------------! 184 185 ! 185 186 IF( Agrif_Root() ) THEN 186 187 IF( ln_iceini_file )THEN! Read a file !187 ! !---------------! 188 IF( nn_iceini_file == 1 )THEN ! Read a file ! 188 189 ! !---------------! 189 190 WHERE( ff_t(:,:) >= 0._wp ) ; zswitch(:,:) = 1._wp … … 199 200 200 201 ! -- optional fields -- ! 201 ! if fields do not exist then set them to the values present in the namelist (except for snow and surface temperature)202 ! if fields do not exist then set them to the values present in the namelist (except for temperatures) 202 203 ! 203 204 ! ice salinity … … 211 212 si(jp_tsu)%fnow(:,:,1) = ( rn_tsu_ini_n * zswitch + rn_tsu_ini_s * (1._wp - zswitch) ) * tmask(:,:,1) 212 213 si(jp_tms)%fnow(:,:,1) = ( rn_tms_ini_n * zswitch + rn_tms_ini_s * (1._wp - zswitch) ) * tmask(:,:,1) 213 ELSEIF( TRIM(si(jp_tmi)%clrootname) == 'NOT USED' .AND. TRIM(si(jp_tms)%clrootname) /= 'NOT USED' ) THEN ! if T_s is read and not T_i, set T_i = (T_s + T_freeze)/2214 si(jp_tmi)%fnow(:,:,1) = 0.5_wp * ( si(jp_tms)%fnow(:,:,1) + 271.15 )215 ELSEIF( TRIM(si(jp_tmi)%clrootname) == 'NOT USED' .AND. TRIM(si(jp_tsu)%clrootname) /= 'NOT USED' ) THEN ! if T_su is read and not T_i, set T_i = (T_su + T_freeze)/2216 si(jp_tmi)%fnow(:,:,1) = 0.5_wp * ( si(jp_tsu)%fnow(:,:,1) + 271.15 )217 ELSEIF( TRIM(si(jp_tsu)%clrootname) == 'NOT USED' .AND. TRIM(si(jp_tms)%clrootname) /= 'NOT USED' ) THEN ! if T_s is read and not T_su, set T_su = T_s218 si(jp_tsu)%fnow(:,:,1) = si(jp_tms)%fnow(:,:,1)219 ELSEIF( TRIM(si(jp_tsu)%clrootname) == 'NOT USED' .AND. TRIM(si(jp_tmi)%clrootname) /= 'NOT USED' ) THEN ! if T_i is read and not T_su, set T_su = T_i220 si(jp_tsu)%fnow(:,:,1) = si(jp_tmi)%fnow(:,:,1)221 ELSEIF( TRIM(si(jp_tms)%clrootname) == 'NOT USED' .AND. TRIM(si(jp_tsu)%clrootname) /= 'NOT USED' ) THEN ! if T_su is read and not T_s, set T_s = T_su222 si(jp_tms)%fnow(:,:,1) = si(jp_tsu)%fnow(:,:,1)223 ELSEIF( TRIM(si(jp_tms)%clrootname) == 'NOT USED' .AND. TRIM(si(jp_tmi)%clrootname) /= 'NOT USED' ) THEN ! if T_i is read and not T_s, set T_s = T_i224 si(jp_tms)%fnow(:,:,1) = si(jp_tmi)%fnow(:,:,1)225 214 ENDIF 215 IF( TRIM(si(jp_tmi)%clrootname) == 'NOT USED' .AND. TRIM(si(jp_tms)%clrootname) /= 'NOT USED' ) & ! if T_s is read and not T_i, set T_i = (T_s + T_freeze)/2 216 & si(jp_tmi)%fnow(:,:,1) = 0.5_wp * ( si(jp_tms)%fnow(:,:,1) + 271.15 ) 217 IF( TRIM(si(jp_tmi)%clrootname) == 'NOT USED' .AND. TRIM(si(jp_tsu)%clrootname) /= 'NOT USED' ) & ! if T_su is read and not T_i, set T_i = (T_su + T_freeze)/2 218 & si(jp_tmi)%fnow(:,:,1) = 0.5_wp * ( si(jp_tsu)%fnow(:,:,1) + 271.15 ) 219 IF( TRIM(si(jp_tsu)%clrootname) == 'NOT USED' .AND. TRIM(si(jp_tms)%clrootname) /= 'NOT USED' ) & ! if T_s is read and not T_su, set T_su = T_s 220 & si(jp_tsu)%fnow(:,:,1) = si(jp_tms)%fnow(:,:,1) 221 IF( TRIM(si(jp_tsu)%clrootname) == 'NOT USED' .AND. TRIM(si(jp_tmi)%clrootname) /= 'NOT USED' ) & ! if T_i is read and not T_su, set T_su = T_i 222 & si(jp_tsu)%fnow(:,:,1) = si(jp_tmi)%fnow(:,:,1) 223 IF( TRIM(si(jp_tms)%clrootname) == 'NOT USED' .AND. TRIM(si(jp_tsu)%clrootname) /= 'NOT USED' ) & ! if T_su is read and not T_s, set T_s = T_su 224 & si(jp_tms)%fnow(:,:,1) = si(jp_tsu)%fnow(:,:,1) 225 IF( TRIM(si(jp_tms)%clrootname) == 'NOT USED' .AND. TRIM(si(jp_tmi)%clrootname) /= 'NOT USED' ) & ! if T_i is read and not T_s, set T_s = T_i 226 & si(jp_tms)%fnow(:,:,1) = si(jp_tmi)%fnow(:,:,1) 226 227 ! 227 228 ! pond concentration … … 233 234 IF( TRIM(si(jp_hpd)%clrootname) == 'NOT USED' ) & 234 235 & si(jp_hpd)%fnow(:,:,1) = ( rn_hpd_ini_n * zswitch + rn_hpd_ini_s * (1._wp - zswitch) ) * tmask(:,:,1) 236 ! 237 ! pond lid depth 238 IF( TRIM(si(jp_hld)%clrootname) == 'NOT USED' ) & 239 & si(jp_hld)%fnow(:,:,1) = ( rn_hld_ini_n * zswitch + rn_hld_ini_s * (1._wp - zswitch) ) * tmask(:,:,1) 235 240 ! 236 241 zsm_i_ini(:,:) = si(jp_smi)%fnow(:,:,1) * tmask(:,:,1) … … 240 245 zapnd_ini(:,:) = si(jp_apd)%fnow(:,:,1) * tmask(:,:,1) 241 246 zhpnd_ini(:,:) = si(jp_hpd)%fnow(:,:,1) * tmask(:,:,1) 247 zhlid_ini(:,:) = si(jp_hld)%fnow(:,:,1) * tmask(:,:,1) 242 248 ! 243 249 ! change the switch for the following … … 265 271 zapnd_ini(:,:) = rn_apd_ini_n * zswitch(:,:) * zat_i_ini(:,:) ! rn_apd = pond fraction => rn_apd * a_i = pond conc. 266 272 zhpnd_ini(:,:) = rn_hpd_ini_n * zswitch(:,:) 273 zhlid_ini(:,:) = rn_hld_ini_n * zswitch(:,:) 267 274 ELSEWHERE 268 275 zht_i_ini(:,:) = rn_hti_ini_s * zswitch(:,:) … … 275 282 zapnd_ini(:,:) = rn_apd_ini_s * zswitch(:,:) * zat_i_ini(:,:) ! rn_apd = pond fraction => rn_apd * a_i = pond conc. 276 283 zhpnd_ini(:,:) = rn_hpd_ini_s * zswitch(:,:) 284 zhlid_ini(:,:) = rn_hld_ini_s * zswitch(:,:) 277 285 END WHERE 278 286 ! … … 285 293 zapnd_ini(:,:) = 0._wp 286 294 zhpnd_ini(:,:) = 0._wp 295 zhlid_ini(:,:) = 0._wp 287 296 ENDIF 288 297 289 !-------------! 290 ! fill fields ! 291 !-------------! 298 IF ( .NOT.ln_pnd_lids ) THEN 299 zhlid_ini(:,:) = 0._wp 300 ENDIF 301 302 !----------------! 303 ! 3) fill fields ! 304 !----------------! 292 305 ! select ice covered grid points 293 306 npti = 0 ; nptidx(:) = 0 … … 309 322 CALL tab_2d_1d( npti, nptidx(1:npti), a_ip_1d(1:npti) , zapnd_ini ) 310 323 CALL tab_2d_1d( npti, nptidx(1:npti), h_ip_1d(1:npti) , zhpnd_ini ) 311 324 CALL tab_2d_1d( npti, nptidx(1:npti), h_il_1d(1:npti) , zhlid_ini ) 325 312 326 ! allocate temporary arrays 313 ALLOCATE( zhi_2d(npti,jpl), zhs_2d(npti,jpl), zai_2d (npti,jpl), & 314 & zti_2d(npti,jpl), zts_2d(npti,jpl), ztsu_2d(npti,jpl), zsi_2d(npti,jpl), zaip_2d(npti,jpl), zhip_2d(npti,jpl) ) 315 327 ALLOCATE( zhi_2d (npti,jpl), zhs_2d (npti,jpl), zai_2d (npti,jpl), & 328 & zti_2d (npti,jpl), zts_2d (npti,jpl), ztsu_2d(npti,jpl), zsi_2d(npti,jpl), & 329 & zaip_2d(npti,jpl), zhip_2d(npti,jpl), zhil_2d(npti,jpl) ) 330 316 331 ! distribute 1-cat into jpl-cat: (jpi*jpj) -> (jpi*jpj,jpl) 317 CALL ice_var_itd( h_i_1d(1:npti) , h_s_1d(1:npti) , at_i_1d(1:npti), & 318 & zhi_2d , zhs_2d , zai_2d , & 319 & t_i_1d(1:npti,1), t_s_1d(1:npti,1), t_su_1d(1:npti), s_i_1d(1:npti), a_ip_1d(1:npti), h_ip_1d(1:npti), & 320 & zti_2d , zts_2d , ztsu_2d , zsi_2d , zaip_2d , zhip_2d ) 332 CALL ice_var_itd( h_i_1d(1:npti) , h_s_1d(1:npti) , at_i_1d(1:npti), & 333 & zhi_2d , zhs_2d , zai_2d , & 334 & t_i_1d(1:npti,1), t_s_1d(1:npti,1), t_su_1d(1:npti), & 335 & s_i_1d(1:npti) , a_ip_1d(1:npti) , h_ip_1d(1:npti), h_il_1d(1:npti), & 336 & zti_2d , zts_2d , ztsu_2d , & 337 & zsi_2d , zaip_2d , zhip_2d , zhil_2d ) 321 338 322 339 ! move to 3D arrays: (jpi*jpj,jpl) -> (jpi,jpj,jpl) … … 334 351 CALL tab_2d_3d( npti, nptidx(1:npti), zaip_2d , a_ip ) 335 352 CALL tab_2d_3d( npti, nptidx(1:npti), zhip_2d , h_ip ) 353 CALL tab_2d_3d( npti, nptidx(1:npti), zhil_2d , h_il ) 336 354 337 355 ! deallocate temporary arrays 338 356 DEALLOCATE( zhi_2d, zhs_2d, zai_2d , & 339 & zti_2d, zts_2d, ztsu_2d, zsi_2d, zaip_2d, zhip_2d )357 & zti_2d, zts_2d, ztsu_2d, zsi_2d, zaip_2d, zhip_2d, zhil_2d ) 340 358 341 359 ! calculate extensive and intensive variables … … 367 385 END_3D 368 386 END DO 369 370 ! Melt ponds 371 WHERE( a_i > epsi10 ) 372 a_ip_frac(:,:,:) = a_ip(:,:,:) / a_i(:,:,:) 373 ELSEWHERE 374 a_ip_frac(:,:,:) = 0._wp 375 END WHERE 376 v_ip(:,:,:) = h_ip(:,:,:) * a_ip(:,:,:) 377 378 ! specific temperatures for coupled runs 379 tn_ice(:,:,:) = t_su(:,:,:) 380 t1_ice(:,:,:) = t_i (:,:,1,:) 381 ! 382 387 383 388 #if defined key_agrif 384 389 ELSE … … 395 400 Agrif_UseSpecialValue = .FALSE. 396 401 ! lbc ???? 397 ! Here we know : a_i, v_i, v_s, sv_i, oa_i, a_ip, v_ip, t_su, e_s, e_i402 ! Here we know : a_i, v_i, v_s, sv_i, oa_i, a_ip, v_ip, v_il, t_su, e_s, e_i 398 403 CALL ice_var_glo2eqv 399 404 CALL ice_var_zapsmall 400 405 CALL ice_var_agg(2) 401 402 ! Melt ponds403 WHERE( a_i > epsi10 )404 a_ip_frac(:,:,:) = a_ip(:,:,:) / a_i(:,:,:)405 ELSEWHERE406 a_ip_frac(:,:,:) = 0._wp407 END WHERE408 WHERE( a_ip > 0._wp ) ! ???????409 h_ip(:,:,:) = v_ip(:,:,:) / a_ip(:,:,:)410 ELSEWHERE411 h_ip(:,:,:) = 0._wp412 END WHERE413 414 tn_ice(:,:,:) = t_su(:,:,:)415 t1_ice(:,:,:) = t_i (:,:,1,:)416 406 #endif 417 ENDIF ! Agrif_Root 407 ENDIF ! Agrif_Root 408 ! 409 ! Melt ponds 410 WHERE( a_i > epsi10 ) ; a_ip_eff(:,:,:) = a_ip(:,:,:) / a_i(:,:,:) 411 ELSEWHERE ; a_ip_eff(:,:,:) = 0._wp 412 END WHERE 413 v_ip(:,:,:) = h_ip(:,:,:) * a_ip(:,:,:) 414 v_il(:,:,:) = h_il(:,:,:) * a_ip(:,:,:) 415 416 ! specific temperatures for coupled runs 417 tn_ice(:,:,:) = t_su(:,:,:) 418 t1_ice(:,:,:) = t_i (:,:,1,:) 419 ! 420 ! ice concentration should not exceed amax 421 at_i(:,:) = SUM( a_i, dim=3 ) 422 DO jl = 1, jpl 423 WHERE( at_i(:,:) > rn_amax_2d(:,:) ) a_i(:,:,jl) = a_i(:,:,jl) * rn_amax_2d(:,:) / at_i(:,:) 424 END DO 425 at_i(:,:) = SUM( a_i, dim=3 ) 426 ! 418 427 ENDIF ! ln_iceini 419 428 ! 420 at_i(:,:) = SUM( a_i, dim=3 )421 !422 429 !---------------------------------------------- 423 ! 3) Snow-ice mass (case ice is fully embedded)430 ! 4) Snow-ice mass (case ice is fully embedded) 424 431 !---------------------------------------------- 425 432 snwice_mass (:,:) = tmask(:,:,1) * SUM( rhos * v_s(:,:,:) + rhoi * v_i(:,:,:), dim=3 ) ! snow+ice mass … … 438 445 439 446 ENDIF 440 441 !------------------------------------ 442 ! 4) store fields at before time-step 443 !------------------------------------ 444 ! it is only necessary for the 1st interpolation by Agrif 445 a_i_b (:,:,:) = a_i (:,:,:) 446 e_i_b (:,:,:,:) = e_i (:,:,:,:) 447 v_i_b (:,:,:) = v_i (:,:,:) 448 v_s_b (:,:,:) = v_s (:,:,:) 449 e_s_b (:,:,:,:) = e_s (:,:,:,:) 450 sv_i_b (:,:,:) = sv_i (:,:,:) 451 oa_i_b (:,:,:) = oa_i (:,:,:) 452 u_ice_b(:,:) = u_ice(:,:) 453 v_ice_b(:,:) = v_ice(:,:) 454 ! total concentration is needed for Lupkes parameterizations 455 at_i_b (:,:) = at_i (:,:) 456 457 !!clem: output of initial state should be written here but it is impossible because 458 !! the ocean and ice are in the same file 459 !! CALL dia_wri_state( Kmm, 'output.init' ) 447 448 !!clem: output of initial state should be written here but it is impossible because 449 !! the ocean and ice are in the same file 450 !! CALL dia_wri_state( 'output.init' ) 460 451 ! 461 452 END SUBROUTINE ice_istate … … 474 465 !! 475 466 !!----------------------------------------------------------------------------- 476 INTEGER :: ios , ifpr, ierror ! Local integers477 467 INTEGER :: ios ! Local integer output status for namelist read 468 INTEGER :: ifpr, ierror 478 469 ! 479 470 CHARACTER(len=256) :: cn_dir ! Root directory for location of ice files 480 TYPE(FLD_N) :: sn_hti, sn_hts, sn_ati, sn_smi, sn_tmi, sn_tsu, sn_tms, sn_apd, sn_hpd 471 TYPE(FLD_N) :: sn_hti, sn_hts, sn_ati, sn_smi, sn_tmi, sn_tsu, sn_tms, sn_apd, sn_hpd, sn_hld 481 472 TYPE(FLD_N), DIMENSION(jpfldi) :: slf_i ! array of namelist informations on the fields to read 482 473 ! 483 NAMELIST/namini/ ln_iceini, ln_iceini_file, rn_thres_sst, &474 NAMELIST/namini/ ln_iceini, nn_iceini_file, rn_thres_sst, & 484 475 & rn_hti_ini_n, rn_hti_ini_s, rn_hts_ini_n, rn_hts_ini_s, & 485 476 & rn_ati_ini_n, rn_ati_ini_s, rn_smi_ini_n, rn_smi_ini_s, & 486 477 & rn_tmi_ini_n, rn_tmi_ini_s, rn_tsu_ini_n, rn_tsu_ini_s, rn_tms_ini_n, rn_tms_ini_s, & 487 & rn_apd_ini_n, rn_apd_ini_s, rn_hpd_ini_n, rn_hpd_ini_s, &488 & sn_hti, sn_hts, sn_ati, sn_tsu, sn_tmi, sn_smi, sn_tms, sn_apd, sn_hpd, cn_dir478 & rn_apd_ini_n, rn_apd_ini_s, rn_hpd_ini_n, rn_hpd_ini_s, rn_hld_ini_n, rn_hld_ini_s, & 479 & sn_hti, sn_hts, sn_ati, sn_tsu, sn_tmi, sn_smi, sn_tms, sn_apd, sn_hpd, sn_hld, cn_dir 489 480 !!----------------------------------------------------------------------------- 490 481 ! … … 498 489 slf_i(jp_ati) = sn_ati ; slf_i(jp_smi) = sn_smi 499 490 slf_i(jp_tmi) = sn_tmi ; slf_i(jp_tsu) = sn_tsu ; slf_i(jp_tms) = sn_tms 500 slf_i(jp_apd) = sn_apd ; slf_i(jp_hpd) = sn_hpd 491 slf_i(jp_apd) = sn_apd ; slf_i(jp_hpd) = sn_hpd ; slf_i(jp_hld) = sn_hld 501 492 ! 502 493 IF(lwp) THEN ! control print … … 506 497 WRITE(numout,*) ' Namelist namini:' 507 498 WRITE(numout,*) ' ice initialization (T) or not (F) ln_iceini = ', ln_iceini 508 WRITE(numout,*) ' ice initialization from a netcdf file ln_iceini_file = ', ln_iceini_file499 WRITE(numout,*) ' ice initialization from a netcdf file nn_iceini_file = ', nn_iceini_file 509 500 WRITE(numout,*) ' max ocean temp. above Tfreeze with initial ice rn_thres_sst = ', rn_thres_sst 510 IF( ln_iceini .AND. .NOT.ln_iceini_file) THEN501 IF( ln_iceini .AND. nn_iceini_file == 0 ) THEN 511 502 WRITE(numout,*) ' initial snw thickness in the north-south rn_hts_ini = ', rn_hts_ini_n,rn_hts_ini_s 512 503 WRITE(numout,*) ' initial ice thickness in the north-south rn_hti_ini = ', rn_hti_ini_n,rn_hti_ini_s … … 518 509 WRITE(numout,*) ' initial pnd fraction in the north-south rn_apd_ini = ', rn_apd_ini_n,rn_apd_ini_s 519 510 WRITE(numout,*) ' initial pnd depth in the north-south rn_hpd_ini = ', rn_hpd_ini_n,rn_hpd_ini_s 511 WRITE(numout,*) ' initial pnd lid depth in the north-south rn_hld_ini = ', rn_hld_ini_n,rn_hld_ini_s 520 512 ENDIF 521 513 ENDIF 522 514 ! 523 IF( ln_iceini_file) THEN ! Ice initialization using input file515 IF( nn_iceini_file == 1 ) THEN ! Ice initialization using input file 524 516 ! 525 517 ! set si structure … … 542 534 rn_apd_ini_n = 0. ; rn_apd_ini_s = 0. 543 535 rn_hpd_ini_n = 0. ; rn_hpd_ini_s = 0. 544 CALL ctl_warn( 'rn_apd_ini & rn_hpd_ini = 0 when no ponds' ) 536 rn_hld_ini_n = 0. ; rn_hld_ini_s = 0. 537 CALL ctl_warn( 'rn_apd_ini & rn_hpd_ini = 0 & rn_hld_ini = 0 when no ponds' ) 538 ENDIF 539 ! 540 IF( .NOT.ln_pnd_lids ) THEN 541 rn_hld_ini_n = 0. ; rn_hld_ini_s = 0. 545 542 ENDIF 546 543 ! -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/ICE/iceitd.F90
r13295 r13998 47 47 LOGICAL :: ln_cat_usr ! ice categories are defined by rn_catbnd 48 48 REAL(wp), DIMENSION(0:100) :: rn_catbnd ! ice categories bounds 49 REAL(wp) :: rn_himax ! maximum ice thickness allowed 49 50 ! 50 51 !! * Substitutions … … 314 315 IF ( a_i_1d(ji) > epsi10 .AND. h_i_1d(ji) < rn_himin ) THEN 315 316 a_i_1d(ji) = a_i_1d(ji) * h_i_1d(ji) / rn_himin 316 IF( ln_pnd_ H12) a_ip_1d(ji) = a_ip_1d(ji) * h_i_1d(ji) / rn_himin317 IF( ln_pnd_LEV ) a_ip_1d(ji) = a_ip_1d(ji) * h_i_1d(ji) / rn_himin 317 318 h_i_1d(ji) = rn_himin 318 319 ENDIF … … 420 421 CALL tab_3d_2d( npti, nptidx(1:npti), a_ip_2d(1:npti,1:jpl), a_ip ) 421 422 CALL tab_3d_2d( npti, nptidx(1:npti), v_ip_2d(1:npti,1:jpl), v_ip ) 423 CALL tab_3d_2d( npti, nptidx(1:npti), v_il_2d(1:npti,1:jpl), v_il ) 422 424 CALL tab_3d_2d( npti, nptidx(1:npti), t_su_2d(1:npti,1:jpl), t_su ) 423 425 DO jl = 1, jpl … … 484 486 zaTsfn(ji,jl2) = zaTsfn(ji,jl2) + ztrans 485 487 ! 486 IF ( ln_pnd_ H12) THEN488 IF ( ln_pnd_LEV ) THEN 487 489 ztrans = a_ip_2d(ji,jl1) * zworka(ji) ! Pond fraction 488 490 a_ip_2d(ji,jl1) = a_ip_2d(ji,jl1) - ztrans … … 492 494 v_ip_2d(ji,jl1) = v_ip_2d(ji,jl1) - ztrans 493 495 v_ip_2d(ji,jl2) = v_ip_2d(ji,jl2) + ztrans 496 ! 497 IF ( ln_pnd_lids ) THEN ! Pond lid volume 498 ztrans = v_il_2d(ji,jl1) * zworka(ji) 499 v_il_2d(ji,jl1) = v_il_2d(ji,jl1) - ztrans 500 v_il_2d(ji,jl2) = v_il_2d(ji,jl2) + ztrans 501 ENDIF 494 502 ENDIF 495 503 ! … … 536 544 ! clem: The transfer between one category to another can lead to very small negative values (-1.e-20) 537 545 ! because of truncation error ( i.e. 1. - 1. /= 0 ) 538 CALL ice_var_roundoff( a_i_2d, v_i_2d, v_s_2d, sv_i_2d, oa_i_2d, a_ip_2d, v_ip_2d, ze_s_2d, ze_i_2d )546 CALL ice_var_roundoff( a_i_2d, v_i_2d, v_s_2d, sv_i_2d, oa_i_2d, a_ip_2d, v_ip_2d, v_il_2d, ze_s_2d, ze_i_2d ) 539 547 540 548 ! at_i must be <= rn_amax … … 568 576 CALL tab_2d_3d( npti, nptidx(1:npti), a_ip_2d(1:npti,1:jpl), a_ip ) 569 577 CALL tab_2d_3d( npti, nptidx(1:npti), v_ip_2d(1:npti,1:jpl), v_ip ) 578 CALL tab_2d_3d( npti, nptidx(1:npti), v_il_2d(1:npti,1:jpl), v_il ) 570 579 CALL tab_2d_3d( npti, nptidx(1:npti), t_su_2d(1:npti,1:jpl), t_su ) 571 580 DO jl = 1, jpl … … 618 627 END_2D 619 628 ! 620 !!clem CALL tab_2d_1d( npti, nptidx(1:npti), h_i_1d(1:npti), h_i(:,:,jl) ) 621 CALL tab_2d_1d( npti, nptidx(1:npti), a_i_1d(1:npti), a_i(:,:,jl) )622 CALL tab_2d_1d( npti, nptidx(1:npti), v_i_1d(1:npti), v_i(:,:,jl) )623 !624 DO ji = 1, npti625 jdonor(ji,jl) = jl626 ! how much of a_i you send in cat sup is somewhat arbitrary627 !!clem: these do not work properly after a restart (I do not know why) => not sure it is still true 628 !! zdaice(ji,jl) = a_i_1d(ji) * ( h_i_1d(ji) - hi_max(jl) + epsi10 ) / h_i_1d(ji) 629 !! zdvice(ji,jl) = v_i_1d(ji) - ( a_i_1d(ji) - zdaice(ji,jl) ) * ( hi_max(jl) - epsi10 ) 630 !!clem: these do not work properly after a restart (I do not know why) => not sure it is still true 631 !! zdaice(ji,jl) = a_i_1d(ji) 632 !! zdvice(ji,jl) = v_i_1d(ji)633 !!clem: these are from UCL and work ok 634 zdaice(ji,jl) = a_i_1d(ji) * 0.5_wp635 zdvice(ji,jl) = v_i_1d(ji) - zdaice(ji,jl) * ( hi_max(jl) + hi_max(jl-1)) * 0.5_wp636 END DO637 !638 IF( npti > 0 ) THEN629 IF( npti > 0 ) THEN 630 !!clem CALL tab_2d_1d( npti, nptidx(1:npti), h_i_1d(1:npti), h_i(:,:,jl) ) 631 CALL tab_2d_1d( npti, nptidx(1:npti), a_i_1d(1:npti), a_i(:,:,jl) ) 632 CALL tab_2d_1d( npti, nptidx(1:npti), v_i_1d(1:npti), v_i(:,:,jl) ) 633 ! 634 DO ji = 1, npti 635 jdonor(ji,jl) = jl 636 ! how much of a_i you send in cat sup is somewhat arbitrary 637 !!clem: these do not work properly after a restart (I do not know why) => not sure it is still true 638 !! zdaice(ji,jl) = a_i_1d(ji) * ( h_i_1d(ji) - hi_max(jl) + epsi10 ) / h_i_1d(ji) 639 !! zdvice(ji,jl) = v_i_1d(ji) - ( a_i_1d(ji) - zdaice(ji,jl) ) * ( hi_max(jl) - epsi10 ) 640 !!clem: these do not work properly after a restart (I do not know why) => not sure it is still true 641 !! zdaice(ji,jl) = a_i_1d(ji) 642 !! zdvice(ji,jl) = v_i_1d(ji) 643 !!clem: these are from UCL and work ok 644 zdaice(ji,jl) = a_i_1d(ji) * 0.5_wp 645 zdvice(ji,jl) = v_i_1d(ji) - zdaice(ji,jl) * ( hi_max(jl) + hi_max(jl-1) ) * 0.5_wp 646 END DO 647 ! 639 648 CALL itd_shiftice( jdonor(1:npti,:), zdaice(1:npti,:), zdvice(1:npti,:) ) ! Shift jl=>jl+1 640 649 ! Reset shift parameters … … 657 666 END_2D 658 667 ! 659 CALL tab_2d_1d( npti, nptidx(1:npti), a_i_1d(1:npti), a_i(:,:,jl+1) ) ! jl+1 is ok660 CALL tab_2d_1d( npti, nptidx(1:npti), v_i_1d(1:npti), v_i(:,:,jl+1) ) ! jl+1 is ok661 DO ji = 1, npti662 jdonor(ji,jl) = jl + 1663 zdaice(ji,jl) = a_i_1d(ji)664 zdvice(ji,jl) = v_i_1d(ji)665 END DO666 !667 668 IF( npti > 0 ) THEN 669 CALL tab_2d_1d( npti, nptidx(1:npti), a_i_1d(1:npti), a_i(:,:,jl+1) ) ! jl+1 is ok 670 CALL tab_2d_1d( npti, nptidx(1:npti), v_i_1d(1:npti), v_i(:,:,jl+1) ) ! jl+1 is ok 671 DO ji = 1, npti 672 jdonor(ji,jl) = jl + 1 673 zdaice(ji,jl) = a_i_1d(ji) 674 zdvice(ji,jl) = v_i_1d(ji) 675 END DO 676 ! 668 677 CALL itd_shiftice( jdonor(1:npti,:), zdaice(1:npti,:), zdvice(1:npti,:) ) ! Shift jl+1=>jl 669 678 ! Reset shift parameters … … 693 702 REAL(wp) :: zhmax, znum, zden, zalpha ! - - 694 703 ! 695 NAMELIST/namitd/ ln_cat_hfn, rn_himean, ln_cat_usr, rn_catbnd, rn_himin 704 NAMELIST/namitd/ ln_cat_hfn, rn_himean, ln_cat_usr, rn_catbnd, rn_himin, rn_himax 696 705 !!------------------------------------------------------------------ 697 706 ! … … 710 719 WRITE(numout,*) ' mean ice thickness in the domain rn_himean = ', rn_himean 711 720 WRITE(numout,*) ' Ice categories are defined by rn_catbnd ln_cat_usr = ', ln_cat_usr 712 WRITE(numout,*) ' minimum ice thickness rn_himin = ', rn_himin 721 WRITE(numout,*) ' minimum ice thickness allowed rn_himin = ', rn_himin 722 WRITE(numout,*) ' maximum ice thickness allowed rn_himax = ', rn_himax 713 723 ENDIF 714 724 ! … … 747 757 END DO 748 758 ! 749 hi_max(jpl) = 99._wp! set to a big value to ensure that all ice is thinner than hi_max(jpl)759 hi_max(jpl) = rn_himax ! set to a big value to ensure that all ice is thinner than hi_max(jpl) 750 760 ! 751 761 IF(lwp) WRITE(numout,*) -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/ICE/icerst.F90
r13286 r13998 18 18 USE phycst , ONLY : rt0 19 19 USE sbc_oce , ONLY : nn_fsbc, ln_cpl 20 USE sbc_oce , ONLY : nn_components, jp_iam_sas ! SAS ss[st]_m init 21 USE sbc_oce , ONLY : sst_m, sss_m ! SAS ss[st]_m init 22 USE oce , ONLY : ts ! SAS ss[st]_m init 23 USE eosbn2 , ONLY : l_useCT, eos_pt_from_ct ! SAS ss[st]_m init 20 24 USE iceistate ! sea-ice: initial state 21 25 USE icectl ! sea-ice: control … … 132 136 CALL iom_rstput( iter, nitrst, numriw, 'a_ip' , a_ip ) 133 137 CALL iom_rstput( iter, nitrst, numriw, 'v_ip' , v_ip ) 138 CALL iom_rstput( iter, nitrst, numriw, 'v_il' , v_il ) 134 139 ! Snow enthalpy 135 140 DO jk = 1, nlay_s … … 172 177 INTEGER :: jk 173 178 LOGICAL :: llok 174 INTEGER :: id0, id1, id2, id3, id4 ! local integer179 INTEGER :: id0, id1, id2, id3, id4, id5 ! local integer 175 180 CHARACTER(len=25) :: znam 176 181 CHARACTER(len=2) :: zchar, zchar1 … … 251 256 v_ip(:,:,:) = 0._wp 252 257 ENDIF 258 ! melt pond lids 259 id3 = iom_varid( numrir, 'v_il' , ldstop = .FALSE. ) 260 IF( id3 > 0 ) THEN 261 CALL iom_get( numrir, jpdom_auto, 'v_il', v_il) 262 ELSE 263 IF(lwp) WRITE(numout,*) ' ==>> previous run without melt ponds lids output then set it to zero' 264 v_il(:,:,:) = 0._wp 265 ENDIF 253 266 ! fields needed for Met Office (Jules) coupling 254 267 IF( ln_cpl ) THEN 255 id 3= iom_varid( numrir, 'cnd_ice' , ldstop = .FALSE. )256 id 4= iom_varid( numrir, 't1_ice' , ldstop = .FALSE. )257 IF( id 3 > 0 .AND. id4> 0 ) THEN ! fields exist268 id4 = iom_varid( numrir, 'cnd_ice' , ldstop = .FALSE. ) 269 id5 = iom_varid( numrir, 't1_ice' , ldstop = .FALSE. ) 270 IF( id4 > 0 .AND. id5 > 0 ) THEN ! fields exist 258 271 CALL iom_get( numrir, jpdom_auto, 'cnd_ice', cnd_ice ) 259 272 CALL iom_get( numrir, jpdom_auto, 't1_ice' , t1_ice ) … … 270 283 ELSE ! == case of a simplified restart == ! 271 284 ! ! ---------------------------------- ! 272 CALL ctl_warn('ice_rst_read: you are using a simplifiedice restart')285 CALL ctl_warn('ice_rst_read: you are attempting to use an unsuitable ice restart') 273 286 ! 274 CALL ice_istate_init 287 IF( .NOT. ln_iceini .OR. nn_iceini_file == 2 ) THEN 288 CALL ctl_stop('STOP', 'ice_rst_read: you need ln_ice_ini=T and nn_iceini_file=0 or 1') 289 ELSE 290 CALL ctl_warn('ice_rst_read: using ice_istate to set initial conditions instead') 291 ENDIF 292 ! 293 IF( nn_components == jp_iam_sas ) THEN ! SAS case: ss[st]_m were not initialized by sbc_ssm_init 294 ! 295 IF(lwp) WRITE(numout,*) ' SAS: default initialisation of ss[st]_m arrays used in ice_istate' 296 IF( l_useCT ) THEN ; sst_m(:,:) = eos_pt_from_ct( ts(:,:,1,jp_tem, Kmm), ts(:,:,1,jp_sal, Kmm) ) 297 ELSE ; sst_m(:,:) = ts(:,:,1,jp_tem, Kmm) 298 ENDIF 299 sss_m(:,:) = ts(:,:,1,jp_sal, Kmm) 300 ENDIF 301 ! 275 302 CALL ice_istate( nit000, Kbb, Kmm, Kaa ) 276 303 ! 277 IF( .NOT.ln_iceini .OR. .NOT.ln_iceini_file ) &278 & CALL ctl_stop('STOP', 'ice_rst_read: you need ln_ice_ini=T and ln_iceini_file=T')279 !280 304 ENDIF 281 305 -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/ICE/icesbc.F90
r13295 r13998 119 119 INTEGER :: ji, jj, jl ! dummy loop index 120 120 REAL(wp) :: zmiss_val ! missing value retrieved from xios 121 REAL(wp), DIMENSION(jpi,jpj,jpl) :: zalb_os, zalb_cs ! ice albedo under overcast/clear sky 122 REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: zalb, zmsk00 ! 2D workspace 121 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: zalb, zmsk00 ! 2D workspace 123 122 !!-------------------------------------------------------------------- 124 123 ! … … 134 133 CALL iom_miss_val( "icetemp", zmiss_val ) 135 134 136 ! --- cloud-sky and overcast-sky ice albedos --- ! 137 CALL ice_alb( t_su, h_i, h_s, ln_pnd_alb, a_ip_frac, h_ip, zalb_cs, zalb_os ) 138 139 ! albedo depends on cloud fraction because of non-linear spectral effects 140 !!gm cldf_ice is a real, DOCTOR naming rule: start with cd means CHARACTER passed in argument ! 141 alb_ice(:,:,:) = ( 1. - cldf_ice ) * zalb_cs(:,:,:) + cldf_ice * zalb_os(:,:,:) 142 ! 135 ! --- ice albedo --- ! 136 CALL ice_alb( t_su, h_i, h_s, ln_pnd_alb, a_ip_eff, h_ip, cloud_fra, alb_ice ) 137 143 138 ! 144 139 SELECT CASE( ksbc ) !== fluxes over sea ice ==! … … 285 280 INTEGER :: ios, ioptio ! Local integer 286 281 !! 287 NAMELIST/namsbc/ rn_cio, rn_blow_s, nn_flxdist, ln_cndflx, ln_cndemulate282 NAMELIST/namsbc/ rn_cio, nn_snwfra, rn_snwblow, nn_flxdist, ln_cndflx, ln_cndemulate, nn_qtrice 288 283 !!------------------------------------------------------------------- 289 284 ! … … 299 294 WRITE(numout,*) '~~~~~~~~~~~~~~~~' 300 295 WRITE(numout,*) ' Namelist namsbc:' 301 WRITE(numout,*) ' drag coefficient for oceanic stress rn_cio = ', rn_cio 302 WRITE(numout,*) ' coefficient for ice-lead partition of snowfall rn_blow_s = ', rn_blow_s 303 WRITE(numout,*) ' Multicategory heat flux formulation nn_flxdist = ', nn_flxdist 304 WRITE(numout,*) ' Use conduction flux as surface condition ln_cndflx = ', ln_cndflx 305 WRITE(numout,*) ' emulate conduction flux ln_cndemulate = ', ln_cndemulate 296 WRITE(numout,*) ' drag coefficient for oceanic stress rn_cio = ', rn_cio 297 WRITE(numout,*) ' fraction of ice covered by snow (options 0,1,2) nn_snwfra = ', nn_snwfra 298 WRITE(numout,*) ' coefficient for ice-lead partition of snowfall rn_snwblow = ', rn_snwblow 299 WRITE(numout,*) ' Multicategory heat flux formulation nn_flxdist = ', nn_flxdist 300 WRITE(numout,*) ' Use conduction flux as surface condition ln_cndflx = ', ln_cndflx 301 WRITE(numout,*) ' emulate conduction flux ln_cndemulate = ', ln_cndemulate 302 WRITE(numout,*) ' solar flux transmitted thru the surface scattering layer nn_qtrice = ', nn_qtrice 303 WRITE(numout,*) ' = 0 Grenfell and Maykut 1977' 304 WRITE(numout,*) ' = 1 Lebrun 2019' 306 305 ENDIF 307 306 ! -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/ICE/icestp.F90
r13216 r13998 55 55 USE icedyn ! sea-ice: dynamics 56 56 USE icethd ! sea-ice: thermodynamics 57 USE icecor ! sea-ice: corrections58 57 USE iceupdate ! sea-ice: sea surface boundary condition update 59 58 USE icedia ! sea-ice: budget diagnostics … … 86 85 PUBLIC ice_init ! called by sbcmod.F90 87 86 87 !! * Substitutions 88 # include "do_loop_substitute.h90" 88 89 !!---------------------------------------------------------------------- 89 90 !! NEMO/ICE 4.0 , NEMO Consortium (2018) … … 160 161 IF( ln_icedyn .AND. .NOT.lk_c1d ) & 161 162 & CALL ice_dyn( kt, Kmm ) ! -- Ice dynamics 163 ! 164 CALL diag_trends( 1 ) ! record dyn trends 162 165 ! 163 166 ! !== lateral boundary conditions ==! … … 188 191 IF( ln_icethd ) CALL ice_thd( kt ) ! -- Ice thermodynamics 189 192 ! 190 CALL ice_cor( kt , 2 ) ! -- Corrections 191 ! 193 CALL diag_trends( 2 ) ! record thermo trends 192 194 CALL ice_var_glo2eqv ! necessary calls (at least for coupling) 193 195 CALL ice_var_agg( 2 ) ! necessary calls (at least for coupling) … … 197 199 IF( ln_icediahsb ) CALL ice_dia( kt ) ! -- Diagnostics outputs 198 200 ! 201 IF( ln_icediachk ) CALL ice_drift_wri( kt ) ! -- Diagnostics outputs for conservation 202 ! 199 203 CALL ice_wri( kt ) ! -- Ice outputs 200 204 ! 201 205 IF( lrst_ice ) CALL ice_rst_write( kt ) ! -- Ice restart file 202 206 ! 203 IF( ln_icectl ) CALL ice_ctl( kt ) ! -- alerts in case of model crash207 IF( ln_icectl ) CALL ice_ctl( kt ) ! -- Control checks 204 208 ! 205 209 ENDIF ! End sea-ice time step only … … 208 212 ! --- Ocean time step --- ! 209 213 !-------------------------! 210 IF( ln_icedyn ) CALL ice_update_tau( kt, uu(:,:,1,Kbb), vv(:,:,1,Kbb) )! -- update surface ocean stresses214 CALL ice_update_tau( kt, uu(:,:,1,Kbb), vv(:,:,1,Kbb) ) ! -- update surface ocean stresses 211 215 !!gm remark, the ocean-ice stress is not saved in ice diag call above ..... find a solution!!! 212 216 ! … … 224 228 INTEGER, INTENT(in) :: Kbb, Kmm, Kaa 225 229 ! 226 INTEGER :: ji, jj,ierr230 INTEGER :: ierr 227 231 !!---------------------------------------------------------------------- 228 232 IF(lwp) WRITE(numout,*) … … 252 256 IF( ierr /= 0 ) CALL ctl_stop('STOP', 'ice_init : unable to allocate ice arrays') 253 257 ! 254 CALL ice_itd_init ! ice thickness distribution initialization255 !256 CALL ice_thd_init ! set ice thermodynics parameters (clem: important to call it first for melt ponds)257 !258 ! ! Initial sea-ice state259 IF( .NOT. ln_rstart ) THEN ! start from rest: sea-ice deduced from sst260 CALL ice_istate_init261 CALL ice_istate( nit000, Kbb, Kmm, Kaa )262 ELSE ! start from a restart file263 CALL ice_rst_read( Kbb, Kmm, Kaa )264 ENDIF265 CALL ice_var_glo2eqv266 CALL ice_var_agg(1)267 !268 CALL ice_sbc_init ! set ice-ocean and ice-atm. coupling parameters269 !270 CALL ice_dyn_init ! set ice dynamics parameters271 !272 CALL ice_update_init ! ice surface boundary condition273 !274 CALL ice_alb_init ! ice surface albedo275 !276 CALL ice_dia_init ! initialization for diags277 !278 fr_i (:,:) = at_i(:,:) ! initialisation of sea-ice fraction279 tn_ice(:,:,:) = t_su(:,:,:) ! initialisation of surface temp for coupled simu280 !281 258 ! ! set max concentration in both hemispheres 282 259 WHERE( gphit(:,:) > 0._wp ) ; rn_amax_2d(:,:) = rn_amax_n ! NH 283 260 ELSEWHERE ; rn_amax_2d(:,:) = rn_amax_s ! SH 284 261 END WHERE 285 262 ! 263 CALL diag_set0 ! set diag of mass, heat and salt fluxes to 0: needed for Agrif child grids 264 ! 265 CALL ice_itd_init ! ice thickness distribution initialization 266 ! 267 CALL ice_thd_init ! set ice thermodynics parameters (clem: important to call it first for melt ponds) 268 ! 269 CALL ice_sbc_init ! set ice-ocean and ice-atm. coupling parameters 270 ! 271 CALL ice_istate_init ! Initial sea-ice state 272 IF ( ln_rstart .OR. nn_iceini_file == 2 ) THEN 273 CALL ice_rst_read( Kbb, Kmm, Kaa ) ! start from a restart file 274 ELSE 275 CALL ice_istate( nit000, Kbb, Kmm, Kaa ) ! start from rest or read a file 276 ENDIF 277 CALL ice_var_glo2eqv 278 CALL ice_var_agg(1) 279 ! 280 CALL ice_dyn_init ! set ice dynamics parameters 281 ! 282 CALL ice_update_init ! ice surface boundary condition 283 ! 284 CALL ice_alb_init ! ice surface albedo 285 ! 286 CALL ice_dia_init ! initialization for diags 287 ! 288 CALL ice_drift_init ! initialization for diags of conservation 289 ! 290 fr_i (:,:) = at_i(:,:) ! initialisation of sea-ice fraction 291 tn_ice(:,:,:) = t_su(:,:,:) ! initialisation of surface temp for coupled simu 292 ! 286 293 IF( ln_rstart ) CALL iom_close( numrir ) ! close input ice restart file 287 294 ! … … 340 347 ENDIF 341 348 ! 342 IF( ln_bdy .AND. ln_icediachk ) CALL ctl_warn('par_init: online conservation check does not work with BDY')343 !344 349 rDt_ice = REAL(nn_fsbc) * rn_Dt !--- sea-ice timestep and its inverse 345 350 r1_Dt_ice = 1._wp / rDt_ice … … 366 371 v_s_b (:,:,:) = v_s (:,:,:) ! snow volume 367 372 sv_i_b(:,:,:) = sv_i(:,:,:) ! salt content 368 oa_i_b(:,:,:) = oa_i(:,:,:) ! areal age content369 373 e_s_b (:,:,:,:) = e_s (:,:,:,:) ! snow thermal energy 370 374 e_i_b (:,:,:,:) = e_i (:,:,:,:) ! ice thermal energy … … 376 380 h_s_b(:,:,:) = 0._wp 377 381 END WHERE 378 379 WHERE( a_ip(:,:,:) >= epsi20 )380 h_ip_b(:,:,:) = v_ip(:,:,:) / a_ip(:,:,:) ! ice pond thickness381 ELSEWHERE382 h_ip_b(:,:,:) = 0._wp383 END WHERE384 382 ! 385 383 ! ice velocities & total concentration … … 398 396 !! of the time step 399 397 !!---------------------------------------------------------------------- 400 INTEGER :: ji, jj ! dummy loop index 401 !!---------------------------------------------------------------------- 402 sfx (:,:) = 0._wp ; 403 sfx_bri(:,:) = 0._wp ; sfx_lam(:,:) = 0._wp 404 sfx_sni(:,:) = 0._wp ; sfx_opw(:,:) = 0._wp 405 sfx_bog(:,:) = 0._wp ; sfx_dyn(:,:) = 0._wp 406 sfx_bom(:,:) = 0._wp ; sfx_sum(:,:) = 0._wp 407 sfx_res(:,:) = 0._wp ; sfx_sub(:,:) = 0._wp 408 ! 409 wfx_snw(:,:) = 0._wp ; wfx_ice(:,:) = 0._wp 410 wfx_sni(:,:) = 0._wp ; wfx_opw(:,:) = 0._wp 411 wfx_bog(:,:) = 0._wp ; wfx_dyn(:,:) = 0._wp 412 wfx_bom(:,:) = 0._wp ; wfx_sum(:,:) = 0._wp 413 wfx_res(:,:) = 0._wp ; wfx_sub(:,:) = 0._wp 414 wfx_spr(:,:) = 0._wp ; wfx_lam(:,:) = 0._wp 415 wfx_snw_dyn(:,:) = 0._wp ; wfx_snw_sum(:,:) = 0._wp 416 wfx_snw_sub(:,:) = 0._wp ; wfx_ice_sub(:,:) = 0._wp 417 wfx_snw_sni(:,:) = 0._wp 418 wfx_pnd(:,:) = 0._wp 419 420 hfx_thd(:,:) = 0._wp ; 421 hfx_snw(:,:) = 0._wp ; hfx_opw(:,:) = 0._wp 422 hfx_bog(:,:) = 0._wp ; hfx_dyn(:,:) = 0._wp 423 hfx_bom(:,:) = 0._wp ; hfx_sum(:,:) = 0._wp 424 hfx_res(:,:) = 0._wp ; hfx_sub(:,:) = 0._wp 425 hfx_spr(:,:) = 0._wp ; hfx_dif(:,:) = 0._wp 426 hfx_err_rem(:,:) = 0._wp 427 hfx_err_dif(:,:) = 0._wp 428 wfx_err_sub(:,:) = 0._wp 429 ! 430 diag_heat(:,:) = 0._wp ; diag_sice(:,:) = 0._wp 431 diag_vice(:,:) = 0._wp ; diag_vsnw(:,:) = 0._wp 432 433 ! SIMIP diagnostics 434 qcn_ice_bot(:,:,:) = 0._wp ; qcn_ice_top(:,:,:) = 0._wp ! conductive fluxes 435 t_si (:,:,:) = rt0 ! temp at the ice-snow interface 436 437 tau_icebfr (:,:) = 0._wp ! landfast ice param only (clem: important to keep the init here) 438 cnd_ice (:,:,:) = 0._wp ! initialisation: effective conductivity at the top of ice/snow (ln_cndflx=T) 439 qcn_ice (:,:,:) = 0._wp ! initialisation: conductive flux (ln_cndflx=T & ln_cndemule=T) 440 qtr_ice_bot(:,:,:) = 0._wp ! initialization: part of solar radiation transmitted through the ice needed at least for outputs 441 qsb_ice_bot(:,:) = 0._wp ! (needed if ln_icethd=F) 442 ! 443 ! for control checks (ln_icediachk) 444 diag_trp_vi(:,:) = 0._wp ; diag_trp_vs(:,:) = 0._wp 445 diag_trp_ei(:,:) = 0._wp ; diag_trp_es(:,:) = 0._wp 446 diag_trp_sv(:,:) = 0._wp 398 INTEGER :: ji, jj, jl ! dummy loop index 399 !!---------------------------------------------------------------------- 400 401 DO_2D( 1, 1, 1, 1 ) 402 sfx (ji,jj) = 0._wp ; 403 sfx_bri(ji,jj) = 0._wp ; sfx_lam(ji,jj) = 0._wp 404 sfx_sni(ji,jj) = 0._wp ; sfx_opw(ji,jj) = 0._wp 405 sfx_bog(ji,jj) = 0._wp ; sfx_dyn(ji,jj) = 0._wp 406 sfx_bom(ji,jj) = 0._wp ; sfx_sum(ji,jj) = 0._wp 407 sfx_res(ji,jj) = 0._wp ; sfx_sub(ji,jj) = 0._wp 408 ! 409 wfx_snw(ji,jj) = 0._wp ; wfx_ice(ji,jj) = 0._wp 410 wfx_sni(ji,jj) = 0._wp ; wfx_opw(ji,jj) = 0._wp 411 wfx_bog(ji,jj) = 0._wp ; wfx_dyn(ji,jj) = 0._wp 412 wfx_bom(ji,jj) = 0._wp ; wfx_sum(ji,jj) = 0._wp 413 wfx_res(ji,jj) = 0._wp ; wfx_sub(ji,jj) = 0._wp 414 wfx_spr(ji,jj) = 0._wp ; wfx_lam(ji,jj) = 0._wp 415 wfx_snw_dyn(ji,jj) = 0._wp ; wfx_snw_sum(ji,jj) = 0._wp 416 wfx_snw_sub(ji,jj) = 0._wp ; wfx_ice_sub(ji,jj) = 0._wp 417 wfx_snw_sni(ji,jj) = 0._wp 418 wfx_pnd(ji,jj) = 0._wp 419 420 hfx_thd(ji,jj) = 0._wp ; 421 hfx_snw(ji,jj) = 0._wp ; hfx_opw(ji,jj) = 0._wp 422 hfx_bog(ji,jj) = 0._wp ; hfx_dyn(ji,jj) = 0._wp 423 hfx_bom(ji,jj) = 0._wp ; hfx_sum(ji,jj) = 0._wp 424 hfx_res(ji,jj) = 0._wp ; hfx_sub(ji,jj) = 0._wp 425 hfx_spr(ji,jj) = 0._wp ; hfx_dif(ji,jj) = 0._wp 426 hfx_err_dif(ji,jj) = 0._wp 427 wfx_err_sub(ji,jj) = 0._wp 428 ! 429 diag_heat(ji,jj) = 0._wp ; diag_sice(ji,jj) = 0._wp 430 diag_vice(ji,jj) = 0._wp ; diag_vsnw(ji,jj) = 0._wp 431 432 tau_icebfr (ji,jj) = 0._wp ! landfast ice param only (clem: important to keep the init here) 433 qsb_ice_bot(ji,jj) = 0._wp ! (needed if ln_icethd=F) 434 435 fhld(ji,jj) = 0._wp ! needed if ln_icethd=F 436 437 ! for control checks (ln_icediachk) 438 diag_trp_vi(ji,jj) = 0._wp ; diag_trp_vs(ji,jj) = 0._wp 439 diag_trp_ei(ji,jj) = 0._wp ; diag_trp_es(ji,jj) = 0._wp 440 diag_trp_sv(ji,jj) = 0._wp 441 ! 442 diag_adv_mass(ji,jj) = 0._wp 443 diag_adv_salt(ji,jj) = 0._wp 444 diag_adv_heat(ji,jj) = 0._wp 445 END_2D 446 447 DO jl = 1, jpl 448 DO_2D( 1, 1, 1, 1 ) 449 ! SIMIP diagnostics 450 t_si (ji,jj,jl) = rt0 ! temp at the ice-snow interface 451 qcn_ice_bot(ji,jj,jl) = 0._wp 452 qcn_ice_top(ji,jj,jl) = 0._wp ! conductive fluxes 453 cnd_ice (ji,jj,jl) = 0._wp ! effective conductivity at the top of ice/snow (ln_cndflx=T) 454 qcn_ice (ji,jj,jl) = 0._wp ! conductive flux (ln_cndflx=T & ln_cndemule=T) 455 qtr_ice_bot(ji,jj,jl) = 0._wp ! part of solar radiation transmitted through the ice needed at least for outputs 456 END_2D 457 ENDDO 447 458 448 459 END SUBROUTINE diag_set0 460 461 462 SUBROUTINE diag_trends( kn ) 463 !!---------------------------------------------------------------------- 464 !! *** ROUTINE diag_trends *** 465 !! 466 !! ** purpose : diagnostics of the trends. Used for conservation purposes 467 !! and outputs 468 !!---------------------------------------------------------------------- 469 INTEGER, INTENT(in) :: kn ! 1 = after dyn ; 2 = after thermo 470 !!---------------------------------------------------------------------- 471 ! 472 ! --- trends of heat, salt, mass (used for conservation controls) 473 IF( ln_icediachk .OR. iom_use('hfxdhc') ) THEN 474 ! 475 diag_heat(:,:) = diag_heat(:,:) & 476 & - SUM(SUM( e_i (:,:,1:nlay_i,:) - e_i_b (:,:,1:nlay_i,:), dim=4 ), dim=3 ) * r1_Dt_ice & 477 & - SUM(SUM( e_s (:,:,1:nlay_s,:) - e_s_b (:,:,1:nlay_s,:), dim=4 ), dim=3 ) * r1_Dt_ice 478 diag_sice(:,:) = diag_sice(:,:) & 479 & + SUM( sv_i(:,:,:) - sv_i_b(:,:,:) , dim=3 ) * r1_Dt_ice * rhoi 480 diag_vice(:,:) = diag_vice(:,:) & 481 & + SUM( v_i (:,:,:) - v_i_b (:,:,:) , dim=3 ) * r1_Dt_ice * rhoi 482 diag_vsnw(:,:) = diag_vsnw(:,:) & 483 & + SUM( v_s (:,:,:) - v_s_b (:,:,:) , dim=3 ) * r1_Dt_ice * rhos 484 ! 485 IF( kn == 2 ) CALL iom_put ( 'hfxdhc' , diag_heat ) ! output of heat trend 486 ! 487 ENDIF 488 ! 489 ! --- trends of concentration (used for simip outputs) 490 IF( iom_use('afxdyn') .OR. iom_use('afxthd') .OR. iom_use('afxtot') ) THEN 491 ! 492 diag_aice(:,:) = diag_aice(:,:) + SUM( a_i(:,:,:) - a_i_b(:,:,:), dim=3 ) * r1_Dt_ice 493 ! 494 IF( kn == 1 ) CALL iom_put( 'afxdyn' , diag_aice ) ! dyn trend 495 IF( kn == 2 ) CALL iom_put( 'afxthd' , SUM( a_i(:,:,:) - a_i_b(:,:,:), dim=3 ) * r1_Dt_ice ) ! thermo trend 496 IF( kn == 2 ) CALL iom_put( 'afxtot' , diag_aice ) ! total trend 497 ! 498 ENDIF 499 ! 500 END SUBROUTINE diag_trends 449 501 450 502 #else -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/ICE/icetab.F90
r10069 r13998 40 40 INTEGER , DIMENSION(ndim1d) , INTENT(in ) :: tab_ind ! input index 41 41 REAL(wp), DIMENSION(jpi,jpj,jpl), INTENT(in ) :: tab2d ! input 2D field 42 REAL(wp), DIMENSION(ndim1d,jpl) , INTENT( 42 REAL(wp), DIMENSION(ndim1d,jpl) , INTENT(inout) :: tab1d ! output 1D field 43 43 ! 44 44 INTEGER :: jl, jn, jid, jjd … … 61 61 INTEGER , DIMENSION(ndim1d) , INTENT(in ) :: tab_ind ! input index 62 62 REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: tab2d ! input 2D field 63 REAL(wp), DIMENSION(ndim1d) , INTENT( 63 REAL(wp), DIMENSION(ndim1d) , INTENT(inout) :: tab1d ! output 1D field 64 64 ! 65 65 INTEGER :: jn , jid, jjd … … 80 80 INTEGER , DIMENSION(ndim1d) , INTENT(in ) :: tab_ind ! input index 81 81 REAL(wp), DIMENSION(ndim1d,jpl) , INTENT(in ) :: tab1d ! input 1D field 82 REAL(wp), DIMENSION(jpi,jpj,jpl), INTENT( 82 REAL(wp), DIMENSION(jpi,jpj,jpl), INTENT(inout) :: tab2d ! output 2D field 83 83 ! 84 84 INTEGER :: jl, jn, jid, jjd … … 101 101 INTEGER , DIMENSION(ndim1d) , INTENT(in ) :: tab_ind ! input index 102 102 REAL(wp), DIMENSION(ndim1d) , INTENT(in ) :: tab1d ! input 1D field 103 REAL(wp), DIMENSION(jpi,jpj), INTENT( 103 REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: tab2d ! output 2D field 104 104 ! 105 105 INTEGER :: jn , jid, jjd -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/ICE/icethd.F90
r13295 r13998 18 18 USE ice ! sea-ice: variables 19 19 !!gm list trop longue ==>>> why not passage en argument d'appel ? 20 USE sbc_oce , ONLY : sss_m, sst_m, e3t_m, utau, vtau, ssu_m, ssv_m, frq_m, qns_tot, qsr_tot,sprecip, ln_cpl20 USE sbc_oce , ONLY : sss_m, sst_m, e3t_m, utau, vtau, ssu_m, ssv_m, frq_m, sprecip, ln_cpl 21 21 USE sbc_ice , ONLY : qsr_oce, qns_oce, qemp_oce, qsr_ice, qns_ice, dqns_ice, evap_ice, qprec_ice, qevap_ice, & 22 22 & qml_ice, qcn_ice, qtr_ice_top … … 30 30 USE icethd_pnd ! sea-ice: melt ponds 31 31 USE iceitd ! sea-ice: remapping thickness distribution 32 USE icecor ! sea-ice: corrections 32 33 USE icetab ! sea-ice: 1D <==> 2D transformation 33 34 USE icevar ! sea-ice: operations … … 35 36 ! 36 37 USE in_out_manager ! I/O manager 38 USE iom ! I/O manager library 37 39 USE lib_mpp ! MPP library 38 40 USE lib_fortran ! fortran utilities (glob_sum + no signed zero) … … 51 53 LOGICAL :: ln_icedO ! activate ice growth in open-water (T) or not (F) 52 54 LOGICAL :: ln_icedS ! activate gravity drainage and flushing (T) or not (F) 55 LOGICAL :: ln_leadhfx ! heat in the leads is used to melt sea-ice before warming the ocean 56 57 !! for convergence tests 58 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: ztice_cvgerr, ztice_cvgstp 53 59 54 60 !! * Substitutions … … 86 92 ! 87 93 INTEGER :: ji, jj, jk, jl ! dummy loop indices 88 REAL(wp) :: zfric_u, zqld, zqfr, zqfr_neg 89 REAL(wp), PARAMETER :: zfric_umin = 0._wp 90 REAL(wp), PARAMETER :: zch = 0.0057_wp 91 REAL(wp), DIMENSION(jpi,jpj) :: zu_io, zv_io, zfric ! ice-ocean velocity (m/s) and frictional velocity (m2/s2)94 REAL(wp) :: zfric_u, zqld, zqfr, zqfr_neg, zqfr_pos 95 REAL(wp), PARAMETER :: zfric_umin = 0._wp ! lower bound for the friction velocity (cice value=5.e-04) 96 REAL(wp), PARAMETER :: zch = 0.0057_wp ! heat transfer coefficient 97 REAL(wp), DIMENSION(jpi,jpj) :: zu_io, zv_io, zfric, zvel ! ice-ocean velocity (m/s) and frictional velocity (m2/s2) 92 98 ! 93 99 !!------------------------------------------------------------------- … … 101 107 WRITE(numout,*) 'ice_thd: sea-ice thermodynamics' 102 108 WRITE(numout,*) '~~~~~~~' 109 ENDIF 110 111 ! convergence tests 112 IF( ln_zdf_chkcvg ) THEN 113 ALLOCATE( ztice_cvgerr(jpi,jpj,jpl) , ztice_cvgstp(jpi,jpj,jpl) ) 114 ztice_cvgerr = 0._wp ; ztice_cvgstp = 0._wp 103 115 ENDIF 104 116 … … 113 125 & ( zu_io(ji,jj) * zu_io(ji,jj) + zu_io(ji-1,jj) * zu_io(ji-1,jj) & 114 126 & + zv_io(ji,jj) * zv_io(ji,jj) + zv_io(ji,jj-1) * zv_io(ji,jj-1) ) ) * tmask(ji,jj,1) 127 zvel(ji,jj) = 0.5_wp * SQRT( ( u_ice(ji-1,jj) + u_ice(ji,jj) ) * ( u_ice(ji-1,jj) + u_ice(ji,jj) ) + & 128 & ( v_ice(ji,jj-1) + v_ice(ji,jj) ) * ( v_ice(ji,jj-1) + v_ice(ji,jj) ) ) 115 129 END_2D 116 130 ELSE ! if no ice dynamics => transmit directly the atmospheric stress to the ocean … … 119 133 & ( utau(ji,jj) * utau(ji,jj) + utau(ji-1,jj) * utau(ji-1,jj) & 120 134 & + vtau(ji,jj) * vtau(ji,jj) + vtau(ji,jj-1) * vtau(ji,jj-1) ) ) * tmask(ji,jj,1) 135 zvel(ji,jj) = 0._wp 121 136 END_2D 122 137 ENDIF 123 CALL lbc_lnk ( 'icethd', zfric, 'T',1.0_wp )138 CALL lbc_lnk_multi( 'icethd', zfric, 'T', 1.0_wp, zvel, 'T', 1.0_wp ) 124 139 ! 125 140 !--------------------------------------------------------------------! … … 129 144 rswitch = tmask(ji,jj,1) * MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) - epsi10 ) ) ! 0 if no ice 130 145 ! 131 ! ! solar irradiance transmission at the mixed layer bottom and used in the lead heat budget132 ! ! practically no "direct lateral ablation"133 !134 ! ! net downward heat flux from the ice to the ocean, expressed as a function of ocean135 ! ! temperature and turbulent mixing (McPhee, 1992)136 !137 146 ! --- Energy received in the lead from atm-oce exchanges, zqld is defined everywhere (J.m-2) --- ! 138 147 zqld = tmask(ji,jj,1) * rDt_ice * & … … 140 149 & ( 1._wp - at_i_b(ji,jj) ) * qns_oce(ji,jj) + qemp_oce(ji,jj) ) 141 150 142 ! --- Energy needed to bring ocean surface layer until its freezing (mostly<0 but >0 if supercooling, J.m-2) --- ! 151 ! --- Energy needed to bring ocean surface layer until its freezing, zqfr is defined everywhere (J.m-2) --- ! 152 ! (mostly<0 but >0 if supercooling) 143 153 zqfr = rho0 * rcp * e3t_m(ji,jj) * ( t_bo(ji,jj) - ( sst_m(ji,jj) + rt0 ) ) * tmask(ji,jj,1) ! both < 0 (t_bo < sst) and > 0 (t_bo > sst) 144 154 zqfr_neg = MIN( zqfr , 0._wp ) ! only < 0 145 146 ! --- Sensible ocean-to-ice heat flux (mostly>0 but <0 if supercooling, W/m2) 155 zqfr_pos = MAX( zqfr , 0._wp ) ! only > 0 156 157 ! --- Sensible ocean-to-ice heat flux (W/m2) --- ! 158 ! (mostly>0 but <0 if supercooling) 147 159 zfric_u = MAX( SQRT( zfric(ji,jj) ), zfric_umin ) 148 qsb_ice_bot(ji,jj) = rswitch * rho0 * rcp * zch * zfric_u * ( ( sst_m(ji,jj) + rt0 ) - t_bo(ji,jj) ) ! W.m-2 149 150 qsb_ice_bot(ji,jj) = rswitch * MIN( qsb_ice_bot(ji,jj), - zqfr_neg * r1_Dt_ice / MAX( at_i(ji,jj), epsi10 ) ) 160 qsb_ice_bot(ji,jj) = rswitch * rho0 * rcp * zch * zfric_u * ( ( sst_m(ji,jj) + rt0 ) - t_bo(ji,jj) ) 161 151 162 ! upper bound for qsb_ice_bot: the heat retrieved from the ocean must be smaller than the heat necessary to reach 152 163 ! the freezing point, so that we do not have SST < T_freeze 153 ! This implies: - ( qsb_ice_bot(ji,jj) * at_i(ji,jj) * rtdice ) - zqfr >= 0 154 155 !-- Energy Budget of the leads (J.m-2), source of ice growth in open water. Must be < 0 to form ice 156 qlead(ji,jj) = MIN( 0._wp , zqld - ( qsb_ice_bot(ji,jj) * at_i(ji,jj) * rDt_ice ) - zqfr ) 157 158 ! If there is ice and leads are warming => transfer energy from the lead budget and use it for bottom melting 159 ! If the grid cell is fully covered by ice (no leads) => transfer energy from the lead budget to the ice bottom budget 160 IF( ( zqld >= 0._wp .AND. at_i(ji,jj) > 0._wp ) .OR. at_i(ji,jj) >= (1._wp - epsi10) ) THEN 161 fhld (ji,jj) = rswitch * zqld * r1_Dt_ice / MAX( at_i(ji,jj), epsi10 ) ! divided by at_i since this is (re)multiplied by a_i in icethd_dh.F90 164 ! This implies: qsb_ice_bot(ji,jj) * at_i(ji,jj) * rtdice <= - zqfr_neg 165 ! The following formulation is ok for both normal conditions and supercooling 166 qsb_ice_bot(ji,jj) = rswitch * MIN( qsb_ice_bot(ji,jj), - zqfr_neg * r1_Dt_ice / MAX( at_i(ji,jj), epsi10 ) ) 167 168 ! --- Energy Budget of the leads (qlead, J.m-2) --- ! 169 ! qlead is the energy received from the atm. in the leads. 170 ! If warming (zqld >= 0), then the energy in the leads is used to melt ice (bottom melting) => fhld (W/m2) 171 ! If cooling (zqld < 0), then the energy in the leads is used to grow ice in open water => qlead (J.m-2) 172 IF( zqld >= 0._wp .AND. at_i(ji,jj) > 0._wp ) THEN 173 ! upper bound for fhld: fhld should be equal to zqld 174 ! but we have to make sure that this heat will not make the sst drop below the freezing point 175 ! so the max heat that can be pulled out of the ocean is zqld - qsb - zqfr_pos 176 ! The following formulation is ok for both normal conditions and supercooling 177 fhld (ji,jj) = rswitch * MAX( 0._wp, ( zqld - zqfr_pos ) * r1_Dt_ice / MAX( at_i(ji,jj), epsi10 ) & ! divided by at_i since this is (re)multiplied by a_i in icethd_dh.F90 178 & - qsb_ice_bot(ji,jj) ) 162 179 qlead(ji,jj) = 0._wp 163 180 ELSE 164 181 fhld (ji,jj) = 0._wp 182 ! upper bound for qlead: qlead should be equal to zqld 183 ! but before using this heat for ice formation, we suppose that the ocean cools down till the freezing point. 184 ! The energy for this cooling down is zqfr. Also some heat will be removed from the ocean from turbulent fluxes (qsb) 185 ! and freezing point is reached if zqfr = zqld - qsb*a/dt 186 ! so the max heat that can be pulled out of the ocean is zqld - qsb - zqfr 187 ! The following formulation is ok for both normal conditions and supercooling 188 qlead(ji,jj) = MIN( 0._wp , zqld - ( qsb_ice_bot(ji,jj) * at_i(ji,jj) * rDt_ice ) - zqfr ) 165 189 ENDIF 166 190 ! 167 ! Net heat flux on top of the ice-ocean [W.m-2] 168 ! --------------------------------------------- 169 qt_atm_oi(ji,jj) = qns_tot(ji,jj) + qsr_tot(ji,jj) 191 ! If ice is landfast and ice concentration reaches its max 192 ! => stop ice formation in open water 193 IF( zvel(ji,jj) <= 5.e-04_wp .AND. at_i(ji,jj) >= rn_amax_2d(ji,jj)-epsi06 ) qlead(ji,jj) = 0._wp 194 ! 195 ! If the grid cell is almost fully covered by ice (no leads) 196 ! => stop ice formation in open water 197 IF( at_i(ji,jj) >= (1._wp - epsi10) ) qlead(ji,jj) = 0._wp 198 ! 199 ! If ln_leadhfx is false 200 ! => do not use energy of the leads to melt sea-ice 201 IF( .NOT.ln_leadhfx ) fhld(ji,jj) = 0._wp 202 ! 170 203 END_2D 171 204 … … 178 211 ENDIF 179 212 180 ! ---------------------------------------------------------------------181 ! Net heat flux on top of the ocean after ice thermo (1st step) [W.m-2]182 ! ---------------------------------------------------------------------183 ! First step here : non solar + precip - qlead - qsensible184 ! Second step in icethd_dh : heat remaining if total melt (zq_rema)185 ! Third step in iceupdate.F90 : heat from ice-ocean mass exchange (zf_mass) + solar186 qt_oce_ai(:,:) = ( 1._wp - at_i_b(:,:) ) * qns_oce(:,:) + qemp_oce(:,:) & ! Non solar heat flux received by the ocean187 & - qlead(:,:) * r1_Dt_ice & ! heat flux taken from the ocean where there is open water ice formation188 & - at_i (:,:) * qsb_ice_bot(:,:) & ! heat flux taken by sensible flux189 & - at_i (:,:) * fhld (:,:) ! heat flux taken during bottom growth/melt190 ! ! (fhld should be 0 while bott growth)191 213 !-------------------------------------------------------------------------------------------! 192 214 ! Thermodynamic computation (only on grid points covered by ice) => loop over ice categories … … 208 230 ! ! --- & Change units of e_i, e_s from J/m2 to J/m3 --- ! 209 231 ! 210 s_i_new (1:npti) = 0._wp ; dh_s_tot(1:npti) = 0._wp ! --- some init --- ! (important to have them here)232 s_i_new (1:npti) = 0._wp ; dh_s_tot(1:npti) = 0._wp ! --- some init --- ! (important to have them here) 211 233 dh_i_sum (1:npti) = 0._wp ; dh_i_bom(1:npti) = 0._wp ; dh_i_itm (1:npti) = 0._wp 212 234 dh_i_sub (1:npti) = 0._wp ; dh_i_bog(1:npti) = 0._wp … … 218 240 CALL ice_thd_dh ! Ice-Snow thickness 219 241 CALL ice_thd_pnd ! Melt ponds formation 220 CALL ice_thd_ent( e_i_1d(1:npti,:) , .true.) ! Ice enthalpy remapping242 CALL ice_thd_ent( e_i_1d(1:npti,:) ) ! Ice enthalpy remapping 221 243 ENDIF 222 244 CALL ice_thd_sal( ln_icedS ) ! --- Ice salinity --- ! … … 241 263 ! 242 264 IF( ln_icedO ) CALL ice_thd_do ! --- Frazil ice growth in leads --- ! 265 ! 266 CALL ice_cor( kt , 2 ) ! --- Corrections --- ! 267 ! 268 oa_i(:,:,:) = oa_i(:,:,:) + a_i(:,:,:) * rdt_ice ! ice natural aging incrementation 269 ! 270 ! convergence tests 271 IF( ln_zdf_chkcvg ) THEN 272 CALL iom_put( 'tice_cvgerr', ztice_cvgerr ) ; DEALLOCATE( ztice_cvgerr ) 273 CALL iom_put( 'tice_cvgstp', ztice_cvgstp ) ; DEALLOCATE( ztice_cvgstp ) 274 ENDIF 243 275 ! 244 276 ! controls … … 347 379 CALL tab_2d_1d( npti, nptidx(1:npti), a_ip_1d (1:npti), a_ip (:,:,kl) ) 348 380 CALL tab_2d_1d( npti, nptidx(1:npti), h_ip_1d (1:npti), h_ip (:,:,kl) ) 349 CALL tab_2d_1d( npti, nptidx(1:npti), a_ip_frac_1d(1:npti), a_ip_frac(:,:,kl) )381 CALL tab_2d_1d( npti, nptidx(1:npti), h_il_1d (1:npti), h_il (:,:,kl) ) 350 382 ! 351 383 CALL tab_2d_1d( npti, nptidx(1:npti), qprec_ice_1d (1:npti), qprec_ice ) … … 399 431 CALL tab_2d_1d( npti, nptidx(1:npti), hfx_res_1d (1:npti), hfx_res ) 400 432 CALL tab_2d_1d( npti, nptidx(1:npti), hfx_err_dif_1d(1:npti), hfx_err_dif ) 401 CALL tab_2d_1d( npti, nptidx(1:npti), hfx_err_rem_1d(1:npti), hfx_err_rem )402 CALL tab_2d_1d( npti, nptidx(1:npti), qt_oce_ai_1d (1:npti), qt_oce_ai )403 433 ! 404 434 ! ocean surface fields 405 435 CALL tab_2d_1d( npti, nptidx(1:npti), sst_1d(1:npti), sst_m ) 406 436 CALL tab_2d_1d( npti, nptidx(1:npti), sss_1d(1:npti), sss_m ) 437 CALL tab_2d_1d( npti, nptidx(1:npti), frq_m_1d(1:npti), frq_m ) 407 438 ! 408 439 ! to update ice age … … 434 465 sv_i_1d(1:npti) = s_i_1d (1:npti) * v_i_1d (1:npti) 435 466 v_ip_1d(1:npti) = h_ip_1d(1:npti) * a_ip_1d(1:npti) 467 v_il_1d(1:npti) = h_il_1d(1:npti) * a_ip_1d(1:npti) 436 468 oa_i_1d(1:npti) = o_i_1d (1:npti) * a_i_1d (1:npti) 437 469 … … 453 485 CALL tab_1d_2d( npti, nptidx(1:npti), a_ip_1d (1:npti), a_ip (:,:,kl) ) 454 486 CALL tab_1d_2d( npti, nptidx(1:npti), h_ip_1d (1:npti), h_ip (:,:,kl) ) 455 CALL tab_1d_2d( npti, nptidx(1:npti), a_ip_frac_1d(1:npti), a_ip_frac(:,:,kl) )487 CALL tab_1d_2d( npti, nptidx(1:npti), h_il_1d (1:npti), h_il (:,:,kl) ) 456 488 ! 457 489 CALL tab_1d_2d( npti, nptidx(1:npti), wfx_snw_sni_1d(1:npti), wfx_snw_sni ) … … 491 523 CALL tab_1d_2d( npti, nptidx(1:npti), hfx_res_1d (1:npti), hfx_res ) 492 524 CALL tab_1d_2d( npti, nptidx(1:npti), hfx_err_dif_1d(1:npti), hfx_err_dif ) 493 CALL tab_1d_2d( npti, nptidx(1:npti), hfx_err_rem_1d(1:npti), hfx_err_rem )494 CALL tab_1d_2d( npti, nptidx(1:npti), qt_oce_ai_1d (1:npti), qt_oce_ai )495 525 ! 496 526 CALL tab_1d_2d( npti, nptidx(1:npti), qns_ice_1d (1:npti), qns_ice (:,:,kl) ) … … 508 538 CALL tab_1d_2d( npti, nptidx(1:npti), sv_i_1d(1:npti), sv_i(:,:,kl) ) 509 539 CALL tab_1d_2d( npti, nptidx(1:npti), v_ip_1d(1:npti), v_ip(:,:,kl) ) 540 CALL tab_1d_2d( npti, nptidx(1:npti), v_il_1d(1:npti), v_il(:,:,kl) ) 510 541 CALL tab_1d_2d( npti, nptidx(1:npti), oa_i_1d(1:npti), oa_i(:,:,kl) ) 542 ! check convergence of heat diffusion scheme 543 IF( ln_zdf_chkcvg ) THEN 544 CALL tab_1d_2d( npti, nptidx(1:npti), tice_cvgerr_1d(1:npti), ztice_cvgerr(:,:,kl) ) 545 CALL tab_1d_2d( npti, nptidx(1:npti), tice_cvgstp_1d(1:npti), ztice_cvgstp(:,:,kl) ) 546 ENDIF 511 547 ! 512 548 END SELECT … … 529 565 INTEGER :: ios ! Local integer output status for namelist read 530 566 !! 531 NAMELIST/namthd/ ln_icedH, ln_icedA, ln_icedO, ln_icedS 567 NAMELIST/namthd/ ln_icedH, ln_icedA, ln_icedO, ln_icedS, ln_leadhfx 532 568 !!------------------------------------------------------------------- 533 569 ! … … 543 579 WRITE(numout,*) '~~~~~~~~~~~~' 544 580 WRITE(numout,*) ' Namelist namthd:' 545 WRITE(numout,*) ' activate ice thick change from top/bot (T) or not (F) ln_icedH = ', ln_icedH 546 WRITE(numout,*) ' activate lateral melting (T) or not (F) ln_icedA = ', ln_icedA 547 WRITE(numout,*) ' activate ice growth in open-water (T) or not (F) ln_icedO = ', ln_icedO 548 WRITE(numout,*) ' activate gravity drainage and flushing (T) or not (F) ln_icedS = ', ln_icedS 581 WRITE(numout,*) ' activate ice thick change from top/bot (T) or not (F) ln_icedH = ', ln_icedH 582 WRITE(numout,*) ' activate lateral melting (T) or not (F) ln_icedA = ', ln_icedA 583 WRITE(numout,*) ' activate ice growth in open-water (T) or not (F) ln_icedO = ', ln_icedO 584 WRITE(numout,*) ' activate gravity drainage and flushing (T) or not (F) ln_icedS = ', ln_icedS 585 WRITE(numout,*) ' heat in the leads is used to melt sea-ice before warming the ocean ln_leadhfx = ', ln_leadhfx 549 586 ENDIF 550 587 ! -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/ICE/icethd_dh.F90
r13226 r13998 13 13 !!---------------------------------------------------------------------- 14 14 !! ice_thd_dh : vertical sea-ice growth and melt 15 !! ice_thd_snwblow : distribute snow fall between ice and ocean 16 !!---------------------------------------------------------------------- 15 !!---------------------------------------------------------------------- 17 16 USE dom_oce ! ocean space and time domain 18 17 USE phycst ! physical constants … … 20 19 USE ice1D ! sea-ice: thermodynamics variables 21 20 USE icethd_sal ! sea-ice: salinity profiles 21 USE icevar ! for CALL ice_var_snwblow 22 22 ! 23 23 USE in_out_manager ! I/O manager … … 29 29 30 30 PUBLIC ice_thd_dh ! called by ice_thd 31 PUBLIC ice_thd_snwblow ! called in sbcblk/sbccpl and here32 33 INTERFACE ice_thd_snwblow34 MODULE PROCEDURE ice_thd_snwblow_1d, ice_thd_snwblow_2d35 END INTERFACE36 31 37 32 !!---------------------------------------------------------------------- … … 144 139 ! 145 140 DO ji = 1, npti 146 zf_tt(ji) = qcn_ice_bot_1d(ji) + qsb_ice_bot_1d(ji) + fhld_1d(ji) 141 zf_tt(ji) = qcn_ice_bot_1d(ji) + qsb_ice_bot_1d(ji) + fhld_1d(ji) + qtr_ice_bot_1d(ji) * frq_m_1d(ji) 147 142 zq_bot(ji) = MAX( 0._wp, zf_tt(ji) * rDt_ice ) 148 143 END DO … … 186 181 ! Snow precipitation 187 182 !------------------- 188 CALL ice_ thd_snwblow( 1.0_wp - at_i_1d(1:npti), zsnw(1:npti) ) ! snow distribution over ice after wind blowing183 CALL ice_var_snwblow( 1.0_wp - at_i_1d(1:npti), zsnw(1:npti) ) ! snow distribution over ice after wind blowing 189 184 190 185 zdeltah(1:npti,:) = 0._wp … … 561 556 ! 562 557 ! Remaining heat flux (W.m-2) is sent to the ocean heat budget 563 qt_oce_ai_1d(ji) = qt_oce_ai_1d(ji) + ( zq_rema(ji) * a_i_1d(ji) ) * r1_Dt_ice558 !!hfx_res_1d(ji) = hfx_res_1d(ji) + ( zq_rema(ji) * a_i_1d(ji) ) * r1_Dt_ice 564 559 565 560 IF( ln_icectl .AND. zq_rema(ji) < 0. .AND. lwp ) WRITE(numout,*) 'ALERTE zq_rema <0 = ', zq_rema(ji) … … 636 631 END SUBROUTINE ice_thd_dh 637 632 638 639 !!--------------------------------------------------------------------------640 !! INTERFACE ice_thd_snwblow641 !!642 !! ** Purpose : Compute distribution of precip over the ice643 !!644 !! Snow accumulation in one thermodynamic time step645 !! snowfall is partitionned between leads and ice.646 !! If snow fall was uniform, a fraction (1-at_i) would fall into leads647 !! but because of the winds, more snow falls on leads than on sea ice648 !! and a greater fraction (1-at_i)^beta of the total mass of snow649 !! (beta < 1) falls in leads.650 !! In reality, beta depends on wind speed,651 !! and should decrease with increasing wind speed but here, it is652 !! considered as a constant. an average value is 0.66653 !!--------------------------------------------------------------------------654 !!gm I think it can be usefull to set this as a FUNCTION, not a SUBROUTINE....655 SUBROUTINE ice_thd_snwblow_2d( pin, pout )656 REAL(wp), DIMENSION(:,:), INTENT(in ) :: pin ! previous fraction lead ( 1. - a_i_b )657 REAL(wp), DIMENSION(:,:), INTENT(inout) :: pout658 pout = ( 1._wp - ( pin )**rn_blow_s )659 END SUBROUTINE ice_thd_snwblow_2d660 661 SUBROUTINE ice_thd_snwblow_1d( pin, pout )662 REAL(wp), DIMENSION(:), INTENT(in ) :: pin663 REAL(wp), DIMENSION(:), INTENT(inout) :: pout664 pout = ( 1._wp - ( pin )**rn_blow_s )665 END SUBROUTINE ice_thd_snwblow_1d666 667 633 #else 668 634 !!---------------------------------------------------------------------- -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/ICE/icethd_do.F90
r13295 r13998 131 131 132 132 ! Default new ice thickness 133 WHERE( qlead(:,:) < 0._wp .AND. tau_icebfr(:,:) == 0._wp ) ; ht_i_new(:,:) = rn_hinew ! if cooling and no landfast 134 ELSEWHERE ; ht_i_new(:,:) = 0._wp 133 WHERE( qlead(:,:) < 0._wp ) ! cooling 134 ht_i_new(:,:) = rn_hinew 135 ELSEWHERE 136 ht_i_new(:,:) = 0._wp 135 137 END WHERE 136 138 … … 146 148 ! 147 149 DO_2D( 0, 0, 0, 0 ) 148 IF ( qlead(ji,jj) < 0._wp .AND. tau_icebfr(ji,jj) == 0._wp ) THEN ! activated if cooling and no landfast150 IF ( qlead(ji,jj) < 0._wp ) THEN ! cooling 149 151 ! -- Wind stress -- ! 150 152 ztaux = ( utau_ice(ji-1,jj ) * umask(ji-1,jj ,1) & … … 198 200 ! 2) Compute thickness, salinity, enthalpy, age, area and volume of new ice 199 201 !------------------------------------------------------------------------------! 200 ! This occurs if open water energy budget is negative (cooling) and there is no landfast ice202 ! it occurs if cooling 201 203 202 204 ! Identify grid points where new ice forms 203 205 npti = 0 ; nptidx(:) = 0 204 206 DO_2D( 1, 1, 1, 1 ) 205 IF ( qlead(ji,jj) < 0._wp .AND. tau_icebfr(ji,jj) == 0._wp) THEN207 IF ( qlead(ji,jj) < 0._wp ) THEN 206 208 npti = npti + 1 207 209 nptidx( npti ) = (jj - 1) * jpi + ji … … 385 387 END DO 386 388 ! --- Ice enthalpy remapping --- ! 387 CALL ice_thd_ent( ze_i_2d(1:npti,:,jl) , .false.)389 CALL ice_thd_ent( ze_i_2d(1:npti,:,jl) ) 388 390 END DO 389 391 -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/ICE/icethd_ent.F90
r13226 r13998 38 38 CONTAINS 39 39 40 SUBROUTINE ice_thd_ent( qnew , compute_hfx_err)40 SUBROUTINE ice_thd_ent( qnew ) 41 41 !!------------------------------------------------------------------- 42 42 !! *** ROUTINE ice_thd_ent *** … … 64 64 !!------------------------------------------------------------------- 65 65 REAL(wp), DIMENSION(:,:), INTENT(inout) :: qnew ! new enthlapies (J.m-3, remapped) 66 LOGICAL, INTENT(in) :: compute_hfx_err ! determines whether to compute diag.67 ! error or not68 66 ! 69 67 INTEGER :: ji ! dummy loop indices … … 130 128 ! comment: if input h_i_old and eh_i_old are already multiplied by a_i (as in icethd_do), 131 129 ! then we should not (* a_i) again but not important since this is just to check that remap error is ~0 132 IF( compute_hfx_err ) THEN 133 DO ji = 1, npti 134 hfx_err_rem_1d(ji) = hfx_err_rem_1d(ji) + a_i_1d(ji) * r1_Dt_ice * & 135 & ( SUM( qnew(ji,1:nlay_i) ) * zhnew(ji) - SUM( eh_i_old(ji,0:nlay_i+1) ) ) 136 END DO 137 END IF 138 130 !DO ji = 1, npti 131 ! hfx_err_rem_1d(ji) = hfx_err_rem_1d(ji) + a_i_1d(ji) * r1_Dt_ice * & 132 ! & ( SUM( qnew(ji,1:nlay_i) ) * zhnew(ji) - SUM( eh_i_old(ji,0:nlay_i+1) ) ) 133 !END DO 134 139 135 END SUBROUTINE ice_thd_ent 140 136 -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/ICE/icethd_pnd.F90
r12489 r13998 35 35 ! ! associated indices: 36 36 INTEGER, PARAMETER :: np_pndNO = 0 ! No pond scheme 37 INTEGER, PARAMETER :: np_pndCST = 1 ! Constant pond scheme38 INTEGER, PARAMETER :: np_pnd H12 = 2 ! Evolutive pond scheme (Holland et al. 2012)37 INTEGER, PARAMETER :: np_pndCST = 1 ! Constant ice pond scheme 38 INTEGER, PARAMETER :: np_pndLEV = 2 ! Level ice pond scheme 39 39 40 40 !!---------------------------------------------------------------------- … … 49 49 !! *** ROUTINE ice_thd_pnd *** 50 50 !! 51 !! ** Purpose : change melt pond fraction 51 !! ** Purpose : change melt pond fraction and thickness 52 52 !! 53 !! ** Method : brut force54 53 !!------------------------------------------------------------------- 55 54 ! … … 58 57 CASE (np_pndCST) ; CALL pnd_CST !== Constant melt ponds ==! 59 58 ! 60 CASE (np_pnd H12) ; CALL pnd_H12 !== Holland et al 2012melt ponds ==!59 CASE (np_pndLEV) ; CALL pnd_LEV !== Level ice melt ponds ==! 61 60 ! 62 61 END SELECT … … 86 85 ! 87 86 IF( a_i_1d(ji) > 0._wp .AND. t_su_1d(ji) >= rt0 ) THEN 88 a_ip_frac_1d(ji) = rn_apnd89 87 h_ip_1d(ji) = rn_hpnd 90 a_ip_1d(ji) = a_ip_frac_1d(ji) * a_i_1d(ji) 88 a_ip_1d(ji) = rn_apnd * a_i_1d(ji) 89 h_il_1d(ji) = 0._wp ! no pond lids whatsoever 91 90 ELSE 92 a_ip_frac_1d(ji) = 0._wp93 91 h_ip_1d(ji) = 0._wp 94 92 a_ip_1d(ji) = 0._wp 93 h_il_1d(ji) = 0._wp 95 94 ENDIF 96 95 ! … … 100 99 101 100 102 SUBROUTINE pnd_H12 103 !!------------------------------------------------------------------- 104 !! *** ROUTINE pnd_H12 *** 105 !! 106 !! ** Purpose : Compute melt pond evolution 107 !! 108 !! ** Method : Empirical method. A fraction of meltwater is accumulated in ponds 109 !! and sent to ocean when surface is freezing 110 !! 111 !! pond growth: Vp = Vp + dVmelt 112 !! with dVmelt = R/rhow * ( rhoi*dh_i + rhos*dh_s ) * a_i 113 !! pond contraction: Vp = Vp * exp(0.01*MAX(Tp-Tsu,0)/Tp) 114 !! with Tp = -2degC 115 !! 116 !! ** Tunable parameters : (no real expertise yet, ideas?) 101 SUBROUTINE pnd_LEV 102 !!------------------------------------------------------------------- 103 !! *** ROUTINE pnd_LEV *** 104 !! 105 !! ** Purpose : Compute melt pond evolution 106 !! 107 !! ** Method : A fraction of meltwater is accumulated in ponds and sent to ocean when surface is freezing 108 !! We work with volumes and then redistribute changes into thickness and concentration 109 !! assuming linear relationship between the two. 110 !! 111 !! ** Action : - pond growth: Vp = Vp + dVmelt --- from Holland et al 2012 --- 112 !! dVmelt = (1-r)/rhow * ( rhoi*dh_i + rhos*dh_s ) * a_i 113 !! dh_i = meltwater from ice surface melt 114 !! dh_s = meltwater from snow melt 115 !! (1-r) = fraction of melt water that is not flushed 116 !! 117 !! - limtations: a_ip must not exceed (1-r)*a_i 118 !! h_ip must not exceed 0.5*h_i 119 !! 120 !! - pond shrinking: 121 !! if lids: Vp = Vp -dH * a_ip 122 !! dH = lid thickness change. Retrieved from this eq.: --- from Flocco et al 2010 --- 123 !! 124 !! rhoi * Lf * dH/dt = ki * MAX(Tp-Tsu,0) / H 125 !! H = lid thickness 126 !! Lf = latent heat of fusion 127 !! Tp = -2C 128 !! 129 !! And solved implicitely as: 130 !! H(t+dt)**2 -H(t) * H(t+dt) -ki * (Tp-Tsu) * dt / (rhoi*Lf) = 0 131 !! 132 !! if no lids: Vp = Vp * exp(0.01*MAX(Tp-Tsu,0)/Tp) --- from Holland et al 2012 --- 133 !! 134 !! - Flushing: w = -perm/visc * rho_oce * grav * Hp / Hi --- from Flocco et al 2007 --- 135 !! perm = permability of sea-ice 136 !! visc = water viscosity 137 !! Hp = height of top of the pond above sea-level 138 !! Hi = ice thickness thru which there is flushing 139 !! 140 !! - Corrections: remove melt ponds when lid thickness is 10 times the pond thickness 141 !! 142 !! - pond thickness and area is retrieved from pond volume assuming a linear relationship between h_ip and a_ip: 143 !! a_ip/a_i = a_ip_frac = h_ip / zaspect 144 !! 145 !! ** Tunable parameters : ln_pnd_lids, rn_apnd_max, rn_apnd_min 117 146 !! 118 !! ** Note : Stolen from CICE for quick test of the melt pond 119 !! radiation and freshwater interfaces 120 !! Coupling can be radiative AND freshwater 121 !! Advection, ridging, rafting are called 122 !! 123 !! ** References : Holland, M. M. et al (J Clim 2012) 124 !!------------------------------------------------------------------- 125 REAL(wp), PARAMETER :: zrmin = 0.15_wp ! minimum fraction of available meltwater retained for melt ponding 126 REAL(wp), PARAMETER :: zrmax = 0.70_wp ! maximum - - - - - 127 REAL(wp), PARAMETER :: zpnd_aspect = 0.8_wp ! pond aspect ratio 128 REAL(wp), PARAMETER :: zTp = -2._wp ! reference temperature 129 ! 130 REAL(wp) :: zfr_mlt ! fraction of available meltwater retained for melt ponding 131 REAL(wp) :: zdv_mlt ! available meltwater for melt ponding 132 REAL(wp) :: z1_Tp ! inverse reference temperature 133 REAL(wp) :: z1_rhow ! inverse freshwater density 134 REAL(wp) :: z1_zpnd_aspect ! inverse pond aspect ratio 135 REAL(wp) :: zfac, zdum 136 ! 137 INTEGER :: ji ! loop indices 138 !!------------------------------------------------------------------- 139 z1_rhow = 1._wp / rhow 140 z1_zpnd_aspect = 1._wp / zpnd_aspect 141 z1_Tp = 1._wp / zTp 147 !! ** Note : mostly stolen from CICE 148 !! 149 !! ** References : Flocco and Feltham (JGR, 2007) 150 !! Flocco et al (JGR, 2010) 151 !! Holland et al (J. Clim, 2012) 152 !!------------------------------------------------------------------- 153 REAL(wp), DIMENSION(nlay_i) :: ztmp ! temporary array 154 !! 155 REAL(wp), PARAMETER :: zaspect = 0.8_wp ! pond aspect ratio 156 REAL(wp), PARAMETER :: zTp = -2._wp ! reference temperature 157 REAL(wp), PARAMETER :: zvisc = 1.79e-3_wp ! water viscosity 158 !! 159 REAL(wp) :: zfr_mlt, zdv_mlt ! fraction and volume of available meltwater retained for melt ponding 160 REAL(wp) :: zdv_frz, zdv_flush ! Amount of melt pond that freezes, flushes 161 REAL(wp) :: zhp ! heigh of top of pond lid wrt ssh 162 REAL(wp) :: zv_ip_max ! max pond volume allowed 163 REAL(wp) :: zdT ! zTp-t_su 164 REAL(wp) :: zsbr ! Brine salinity 165 REAL(wp) :: zperm ! permeability of sea ice 166 REAL(wp) :: zfac, zdum ! temporary arrays 167 REAL(wp) :: z1_rhow, z1_aspect, z1_Tp ! inverse 168 !! 169 INTEGER :: ji, jk ! loop indices 170 !!------------------------------------------------------------------- 171 z1_rhow = 1._wp / rhow 172 z1_aspect = 1._wp / zaspect 173 z1_Tp = 1._wp / zTp 142 174 143 175 DO ji = 1, npti 144 ! !--------------------------------!145 IF( h_i_1d(ji) < rn_himin ) THEN ! Case ice thickness < rn_himin!146 ! !--------------------------------!147 !--- Remove ponds on thin ice 176 ! !----------------------------------------------------! 177 IF( h_i_1d(ji) < rn_himin .OR. a_i_1d(ji) < epsi10 ) THEN ! Case ice thickness < rn_himin or tiny ice fraction ! 178 ! !----------------------------------------------------! 179 !--- Remove ponds on thin ice or tiny ice fractions 148 180 a_ip_1d(ji) = 0._wp 149 a_ip_frac_1d(ji) = 0._wp150 181 h_ip_1d(ji) = 0._wp 151 ! !--------------------------------! 152 ELSE ! Case ice thickness >= rn_himin ! 153 ! !--------------------------------! 154 v_ip_1d(ji) = h_ip_1d(ji) * a_ip_1d(ji) ! record pond volume at previous time step 155 ! 156 ! available meltwater for melt ponding [m, >0] and fraction 157 zdv_mlt = -( dh_i_sum(ji)*rhoi + dh_s_mlt(ji)*rhos ) * z1_rhow * a_i_1d(ji) 158 zfr_mlt = zrmin + ( zrmax - zrmin ) * a_i_1d(ji) ! from CICE doc 159 !zfr_mlt = zrmin + zrmax * a_i_1d(ji) ! from Holland paper 160 ! 161 !--- Pond gowth ---! 162 ! v_ip should never be negative, otherwise code crashes 163 v_ip_1d(ji) = MAX( 0._wp, v_ip_1d(ji) + zfr_mlt * zdv_mlt ) 164 ! 165 ! melt pond mass flux (<0) 182 h_il_1d(ji) = 0._wp 183 ! !--------------------------------! 184 ELSE ! Case ice thickness >= rn_himin ! 185 ! !--------------------------------! 186 v_ip_1d(ji) = h_ip_1d(ji) * a_ip_1d(ji) ! retrieve volume from thickness 187 v_il_1d(ji) = h_il_1d(ji) * a_ip_1d(ji) 188 ! 189 !------------------! 190 ! case ice melting ! 191 !------------------! 192 ! 193 !--- available meltwater for melt ponding ---! 194 zdum = -( dh_i_sum(ji)*rhoi + dh_s_mlt(ji)*rhos ) * z1_rhow * a_i_1d(ji) 195 zfr_mlt = rn_apnd_min + ( rn_apnd_max - rn_apnd_min ) * at_i_1d(ji) ! = ( 1 - r ) = fraction of melt water that is not flushed 196 zdv_mlt = MAX( 0._wp, zfr_mlt * zdum ) ! max for roundoff errors? 197 ! 198 !--- overflow ---! 199 ! If pond area exceeds zfr_mlt * a_i_1d(ji) then reduce the pond volume 200 ! a_ip_max = zfr_mlt * a_i 201 ! => from zaspect = h_ip / (a_ip / a_i), set v_ip_max as: 202 zv_ip_max = zfr_mlt**2 * a_i_1d(ji) * zaspect 203 zdv_mlt = MAX( 0._wp, MIN( zdv_mlt, zv_ip_max - v_ip_1d(ji) ) ) 204 205 ! If pond depth exceeds half the ice thickness then reduce the pond volume 206 ! h_ip_max = 0.5 * h_i 207 ! => from zaspect = h_ip / (a_ip / a_i), set v_ip_max as: 208 zv_ip_max = z1_aspect * a_i_1d(ji) * 0.25 * h_i_1d(ji) * h_i_1d(ji) 209 zdv_mlt = MAX( 0._wp, MIN( zdv_mlt, zv_ip_max - v_ip_1d(ji) ) ) 210 211 !--- Pond growing ---! 212 v_ip_1d(ji) = v_ip_1d(ji) + zdv_mlt 213 ! 214 !--- Lid melting ---! 215 IF( ln_pnd_lids ) v_il_1d(ji) = MAX( 0._wp, v_il_1d(ji) - zdv_mlt ) ! must be bounded by 0 216 ! 217 !--- mass flux ---! 166 218 IF( zdv_mlt > 0._wp ) THEN 167 zfac = z fr_mlt * zdv_mlt * rhow * r1_Dt_ice219 zfac = zdv_mlt * rhow * r1_Dt_ice ! melt pond mass flux < 0 [kg.m-2.s-1] 168 220 wfx_pnd_1d(ji) = wfx_pnd_1d(ji) - zfac 169 221 ! 170 ! adjust ice/snow melting flux to balance melt pond flux (>0) 171 zdum = zfac / ( wfx_snw_sum_1d(ji) + wfx_sum_1d(ji) ) 222 zdum = zfac / ( wfx_snw_sum_1d(ji) + wfx_sum_1d(ji) ) ! adjust ice/snow melting flux > 0 to balance melt pond flux 172 223 wfx_snw_sum_1d(ji) = wfx_snw_sum_1d(ji) * (1._wp + zdum) 173 224 wfx_sum_1d(ji) = wfx_sum_1d(ji) * (1._wp + zdum) 174 225 ENDIF 226 227 !-------------------! 228 ! case ice freezing ! i.e. t_su_1d(ji) < (zTp+rt0) 229 !-------------------! 230 ! 231 zdT = MAX( zTp+rt0 - t_su_1d(ji), 0._wp ) 175 232 ! 176 233 !--- Pond contraction (due to refreezing) ---! 177 v_ip_1d(ji) = v_ip_1d(ji) * EXP( 0.01_wp * MAX( zTp+rt0 - t_su_1d(ji), 0._wp ) * z1_Tp ) 178 ! 179 ! Set new pond area and depth assuming linear relation between h_ip and a_ip_frac 180 ! h_ip = zpnd_aspect * a_ip_frac = zpnd_aspect * a_ip/a_i 181 a_ip_1d(ji) = SQRT( v_ip_1d(ji) * z1_zpnd_aspect * a_i_1d(ji) ) 182 a_ip_frac_1d(ji) = a_ip_1d(ji) / a_i_1d(ji) 183 h_ip_1d(ji) = zpnd_aspect * a_ip_frac_1d(ji) 234 IF( ln_pnd_lids ) THEN 235 ! 236 !--- Lid growing and subsequent pond shrinking ---! 237 zdv_frz = 0.5_wp * MAX( 0._wp, -v_il_1d(ji) + & ! Flocco 2010 (eq. 5) solved implicitly as aH**2 + bH + c = 0 238 & SQRT( v_il_1d(ji)**2 + a_ip_1d(ji)**2 * 4._wp * rcnd_i * zdT * rdt_ice / (rLfus * rhow) ) ) ! max for roundoff errors 239 240 ! Lid growing 241 v_il_1d(ji) = MAX( 0._wp, v_il_1d(ji) + zdv_frz ) 242 243 ! Pond shrinking 244 v_ip_1d(ji) = MAX( 0._wp, v_ip_1d(ji) - zdv_frz ) 245 246 ELSE 247 ! Pond shrinking 248 v_ip_1d(ji) = v_ip_1d(ji) * EXP( 0.01_wp * zdT * z1_Tp ) ! Holland 2012 (eq. 6) 249 ENDIF 250 ! 251 !--- Set new pond area and depth ---! assuming linear relation between h_ip and a_ip_frac 252 ! v_ip = h_ip * a_ip 253 ! a_ip/a_i = a_ip_frac = h_ip / zaspect (cf Holland 2012, fitting SHEBA so that knowing v_ip we can distribute it to a_ip and h_ip) 254 a_ip_1d(ji) = MIN( a_i_1d(ji), SQRT( v_ip_1d(ji) * z1_aspect * a_i_1d(ji) ) ) ! make sure a_ip < a_i 255 h_ip_1d(ji) = zaspect * a_ip_1d(ji) / a_i_1d(ji) 256 257 !---------------! 258 ! Pond flushing ! 259 !---------------! 260 ! height of top of the pond above sea-level 261 zhp = ( h_i_1d(ji) * ( rho0 - rhoi ) + h_ip_1d(ji) * ( rho0 - rhow * a_ip_1d(ji) / a_i_1d(ji) ) ) * r1_rho0 262 263 ! Calculate the permeability of the ice (Assur 1958, see Flocco 2010) 264 DO jk = 1, nlay_i 265 zsbr = - 1.2_wp & 266 & - 21.8_wp * ( t_i_1d(ji,jk) - rt0 ) & 267 & - 0.919_wp * ( t_i_1d(ji,jk) - rt0 )**2 & 268 & - 0.0178_wp * ( t_i_1d(ji,jk) - rt0 )**3 269 ztmp(jk) = sz_i_1d(ji,jk) / zsbr 270 END DO 271 zperm = MAX( 0._wp, 3.e-08_wp * MINVAL(ztmp)**3 ) 272 273 ! Do the drainage using Darcy's law 274 zdv_flush = -zperm * rho0 * grav * zhp * rdt_ice / (zvisc * h_i_1d(ji)) * a_ip_1d(ji) 275 zdv_flush = MAX( zdv_flush, -v_ip_1d(ji) ) 276 v_ip_1d(ji) = v_ip_1d(ji) + zdv_flush 277 278 !--- Set new pond area and depth ---! assuming linear relation between h_ip and a_ip_frac 279 a_ip_1d(ji) = MIN( a_i_1d(ji), SQRT( v_ip_1d(ji) * z1_aspect * a_i_1d(ji) ) ) ! make sure a_ip < a_i 280 h_ip_1d(ji) = zaspect * a_ip_1d(ji) / a_i_1d(ji) 281 282 !--- Corrections and lid thickness ---! 283 IF( ln_pnd_lids ) THEN 284 !--- retrieve lid thickness from volume ---! 285 IF( a_ip_1d(ji) > epsi10 ) THEN ; h_il_1d(ji) = v_il_1d(ji) / a_ip_1d(ji) 286 ELSE ; h_il_1d(ji) = 0._wp 287 ENDIF 288 !--- remove ponds if lids are much larger than ponds ---! 289 IF ( h_il_1d(ji) > h_ip_1d(ji) * 10._wp ) THEN 290 a_ip_1d(ji) = 0._wp 291 h_ip_1d(ji) = 0._wp 292 h_il_1d(ji) = 0._wp 293 ENDIF 294 ENDIF 184 295 ! 185 296 ENDIF 297 186 298 END DO 187 299 ! 188 END SUBROUTINE pnd_ H12300 END SUBROUTINE pnd_LEV 189 301 190 302 … … 203 315 INTEGER :: ios, ioptio ! Local integer 204 316 !! 205 NAMELIST/namthd_pnd/ ln_pnd, ln_pnd_H12, ln_pnd_CST, rn_apnd, rn_hpnd, ln_pnd_alb 317 NAMELIST/namthd_pnd/ ln_pnd, ln_pnd_LEV , rn_apnd_min, rn_apnd_max, & 318 & ln_pnd_CST , rn_apnd, rn_hpnd, & 319 & ln_pnd_lids, ln_pnd_alb 206 320 !!------------------------------------------------------------------- 207 321 ! … … 217 331 WRITE(numout,*) '~~~~~~~~~~~~~~~~' 218 332 WRITE(numout,*) ' Namelist namicethd_pnd:' 219 WRITE(numout,*) ' Melt ponds activated or not ln_pnd = ', ln_pnd 220 WRITE(numout,*) ' Evolutive melt pond fraction and depth (Holland et al 2012) ln_pnd_H12 = ', ln_pnd_H12 221 WRITE(numout,*) ' Prescribed melt pond fraction and depth ln_pnd_CST = ', ln_pnd_CST 222 WRITE(numout,*) ' Prescribed pond fraction rn_apnd = ', rn_apnd 223 WRITE(numout,*) ' Prescribed pond depth rn_hpnd = ', rn_hpnd 224 WRITE(numout,*) ' Melt ponds affect albedo or not ln_pnd_alb = ', ln_pnd_alb 333 WRITE(numout,*) ' Melt ponds activated or not ln_pnd = ', ln_pnd 334 WRITE(numout,*) ' Level ice melt pond scheme ln_pnd_LEV = ', ln_pnd_LEV 335 WRITE(numout,*) ' Minimum ice fraction that contributes to melt ponds rn_apnd_min = ', rn_apnd_min 336 WRITE(numout,*) ' Maximum ice fraction that contributes to melt ponds rn_apnd_max = ', rn_apnd_max 337 WRITE(numout,*) ' Constant ice melt pond scheme ln_pnd_CST = ', ln_pnd_CST 338 WRITE(numout,*) ' Prescribed pond fraction rn_apnd = ', rn_apnd 339 WRITE(numout,*) ' Prescribed pond depth rn_hpnd = ', rn_hpnd 340 WRITE(numout,*) ' Frozen lids on top of melt ponds ln_pnd_lids = ', ln_pnd_lids 341 WRITE(numout,*) ' Melt ponds affect albedo or not ln_pnd_alb = ', ln_pnd_alb 225 342 ENDIF 226 343 ! … … 229 346 IF( .NOT.ln_pnd ) THEN ; ioptio = ioptio + 1 ; nice_pnd = np_pndNO ; ENDIF 230 347 IF( ln_pnd_CST ) THEN ; ioptio = ioptio + 1 ; nice_pnd = np_pndCST ; ENDIF 231 IF( ln_pnd_ H12 ) THEN ; ioptio = ioptio + 1 ; nice_pnd = np_pndH12; ENDIF348 IF( ln_pnd_LEV ) THEN ; ioptio = ioptio + 1 ; nice_pnd = np_pndLEV ; ENDIF 232 349 IF( ioptio /= 1 ) & 233 & CALL ctl_stop( 'ice_thd_pnd_init: choose either none (ln_pnd=F) or only one pond scheme (ln_pnd_ H12or ln_pnd_CST)' )350 & CALL ctl_stop( 'ice_thd_pnd_init: choose either none (ln_pnd=F) or only one pond scheme (ln_pnd_LEV or ln_pnd_CST)' ) 234 351 ! 235 352 SELECT CASE( nice_pnd ) 236 353 CASE( np_pndNO ) 237 IF( ln_pnd_alb ) THEN ; ln_pnd_alb = .FALSE. ; CALL ctl_warn( 'ln_pnd_alb=false when no ponds' ) ; ENDIF 354 IF( ln_pnd_alb ) THEN ; ln_pnd_alb = .FALSE. ; CALL ctl_warn( 'ln_pnd_alb=false when no ponds' ) ; ENDIF 355 IF( ln_pnd_lids ) THEN ; ln_pnd_lids = .FALSE. ; CALL ctl_warn( 'ln_pnd_lids=false when no ponds' ) ; ENDIF 356 CASE( np_pndCST ) 357 IF( ln_pnd_lids ) THEN ; ln_pnd_lids = .FALSE. ; CALL ctl_warn( 'ln_pnd_lids=false when constant ponds' ) ; ENDIF 238 358 END SELECT 239 359 ! -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/ICE/icethd_sal.F90
r12489 r13998 55 55 !! -> nn_icesal = 3 -> Sice = S(z) [multiyear ice] 56 56 !!--------------------------------------------------------------------- 57 LOGICAL, INTENT(in) :: ld_sal 57 LOGICAL, INTENT(in) :: ld_sal ! gravity drainage and flushing or not 58 58 ! 59 INTEGER :: ji, jk ! dummy loop indices 60 REAL(wp) :: iflush, igravdr ! local scalars 61 REAL(wp) :: zs_sni, zs_i_gd, zs_i_fl, zs_i_si, zs_i_bg ! local scalars 59 INTEGER :: ji ! dummy loop indices 60 REAL(wp) :: zs_sni, zds ! local scalars 62 61 REAL(wp) :: z1_time_gd, z1_time_fl 63 62 !!--------------------------------------------------------------------- … … 68 67 CASE( 2 ) ! time varying salinity with linear profile ! 69 68 ! !---------------------------------------------! 70 z1_time_gd = 1._wp / rn_time_gd * rDt_ice71 z1_time_fl = 1._wp / rn_time_fl * rDt_ice69 z1_time_gd = rDt_ice / rn_time_gd 70 z1_time_fl = rDt_ice / rn_time_fl 72 71 ! 73 72 DO ji = 1, npti 74 73 ! 75 !---------------------------------------------------------76 ! Update ice salinity from snow-ice and bottom growth77 !---------------------------------------------------------78 74 IF( h_i_1d(ji) > 0._wp ) THEN 79 zs_sni = sss_1d(ji) * ( rhoi - rhos ) * r1_rhoi ! Salinity of snow ice 80 zs_i_si = ( zs_sni - s_i_1d(ji) ) * dh_snowice(ji) / h_i_1d(ji) ! snow-ice 81 zs_i_bg = ( s_i_new(ji) - s_i_1d(ji) ) * dh_i_bog (ji) / h_i_1d(ji) ! bottom growth 82 ! Update salinity (nb: salt flux already included in icethd_dh) 83 s_i_1d(ji) = s_i_1d(ji) + zs_i_bg + zs_i_si 75 ! 76 ! --- Update ice salinity from snow-ice and bottom growth --- ! 77 zs_sni = sss_1d(ji) * ( rhoi - rhos ) * r1_rhoi ! salinity of snow ice 78 zds = ( zs_sni - s_i_1d(ji) ) * dh_snowice(ji) / h_i_1d(ji) ! snow-ice 79 zds = zds + ( s_i_new(ji) - s_i_1d(ji) ) * dh_i_bog (ji) / h_i_1d(ji) ! bottom growth 80 ! update salinity (nb: salt flux already included in icethd_dh) 81 s_i_1d(ji) = s_i_1d(ji) + zds 82 ! 83 ! --- Update ice salinity from brine drainage and flushing --- ! 84 IF( ld_sal ) THEN 85 IF( t_su_1d(ji) >= rt0 ) THEN ! flushing (summer time) 86 zds = - MAX( s_i_1d(ji) - rn_sal_fl , 0._wp ) * z1_time_fl 87 ELSEIF( t_su_1d(ji) <= t_bo_1d(ji) ) THEN ! gravity drainage 88 zds = - MAX( s_i_1d(ji) - rn_sal_gd , 0._wp ) * z1_time_gd 89 ELSE 90 zds = 0._wp 91 ENDIF 92 ! update salinity 93 s_i_1d(ji) = s_i_1d(ji) + zds 94 ! salt flux 95 sfx_bri_1d(ji) = sfx_bri_1d(ji) - rhoi * a_i_1d(ji) * h_i_1d(ji) * zds * r1_Dt_ice 96 ENDIF 97 ! 98 ! --- salinity must stay inbounds --- ! 99 zds = MAX( 0._wp, rn_simin - s_i_1d(ji) ) ! > 0 if s_i < simin 100 zds = zds + MIN( 0._wp, rn_simax - s_i_1d(ji) ) ! < 0 if s_i > simax 101 ! update salinity 102 s_i_1d(ji) = s_i_1d(ji) + zds 103 ! salt flux 104 sfx_res_1d(ji) = sfx_res_1d(ji) - rhoi * a_i_1d(ji) * h_i_1d(ji) * zds * r1_Dt_ice 105 ! 84 106 ENDIF 85 107 ! 86 IF( ld_sal ) THEN87 !---------------------------------------------------------88 ! Update ice salinity from brine drainage and flushing89 !---------------------------------------------------------90 iflush = MAX( 0._wp , SIGN( 1._wp , t_su_1d(ji) - rt0 ) ) ! =1 if summer91 igravdr = MAX( 0._wp , SIGN( 1._wp , t_bo_1d(ji) - t_su_1d(ji) ) ) ! =1 if t_su < t_bo92 93 zs_i_gd = - igravdr * MAX( s_i_1d(ji) - rn_sal_gd , 0._wp ) * z1_time_gd ! gravity drainage94 zs_i_fl = - iflush * MAX( s_i_1d(ji) - rn_sal_fl , 0._wp ) * z1_time_fl ! flushing95 96 ! Update salinity97 s_i_1d(ji) = s_i_1d(ji) + zs_i_fl + zs_i_gd98 99 ! Salt flux100 sfx_bri_1d(ji) = sfx_bri_1d(ji) - rhoi * a_i_1d(ji) * h_i_1d(ji) * ( zs_i_fl + zs_i_gd ) * r1_Dt_ice101 ENDIF102 108 END DO 103 109 ! -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/ICE/icethd_zdf.F90
r12377 r13998 85 85 INTEGER :: ios, ioptio ! Local integer 86 86 !! 87 NAMELIST/namthd_zdf/ ln_zdf_BL99, ln_cndi_U64, ln_cndi_P07, rn_cnd_s, rn_kappa_i 87 NAMELIST/namthd_zdf/ ln_zdf_BL99, ln_cndi_U64, ln_cndi_P07, rn_cnd_s, & 88 & rn_kappa_i, rn_kappa_s, rn_kappa_smlt, rn_kappa_sdry, ln_zdf_chkcvg 88 89 !!------------------------------------------------------------------- 89 90 ! … … 99 100 WRITE(numout,*) '~~~~~~~~~~~~~~~~' 100 101 WRITE(numout,*) ' Namelist namthd_zdf:' 101 WRITE(numout,*) ' Bitz and Lipscomb (1999) formulation ln_zdf_BL99 = ', ln_zdf_BL99 102 WRITE(numout,*) ' thermal conductivity in the ice (Untersteiner 1964) ln_cndi_U64 = ', ln_cndi_U64 103 WRITE(numout,*) ' thermal conductivity in the ice (Pringle et al 2007) ln_cndi_P07 = ', ln_cndi_P07 104 WRITE(numout,*) ' thermal conductivity in the snow rn_cnd_s = ', rn_cnd_s 105 WRITE(numout,*) ' extinction radiation parameter in sea ice rn_kappa_i = ', rn_kappa_i 102 WRITE(numout,*) ' Bitz and Lipscomb (1999) formulation ln_zdf_BL99 = ', ln_zdf_BL99 103 WRITE(numout,*) ' thermal conductivity in the ice (Untersteiner 1964) ln_cndi_U64 = ', ln_cndi_U64 104 WRITE(numout,*) ' thermal conductivity in the ice (Pringle et al 2007) ln_cndi_P07 = ', ln_cndi_P07 105 WRITE(numout,*) ' thermal conductivity in the snow rn_cnd_s = ', rn_cnd_s 106 WRITE(numout,*) ' extinction radiation parameter in sea ice rn_kappa_i = ', rn_kappa_i 107 WRITE(numout,*) ' extinction radiation parameter in snw (nn_qtrice=0) rn_kappa_s = ', rn_kappa_s 108 WRITE(numout,*) ' extinction radiation parameter in melt snw (nn_qtrice=1) rn_kappa_smlt = ', rn_kappa_smlt 109 WRITE(numout,*) ' extinction radiation parameter in dry snw (nn_qtrice=1) rn_kappa_sdry = ', rn_kappa_sdry 110 WRITE(numout,*) ' check convergence of heat diffusion scheme ln_zdf_chkcvg = ', ln_zdf_chkcvg 106 111 ENDIF 107 112 ! -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/ICE/icethd_zdf_bl99.F90
r12489 r13998 85 85 86 86 LOGICAL, DIMENSION(jpij) :: l_T_converged ! true when T converges (per grid point) 87 !87 ! 88 88 REAL(wp) :: zg1s = 2._wp ! for the tridiagonal system 89 89 REAL(wp) :: zg1 = 2._wp ! 90 90 REAL(wp) :: zgamma = 18009._wp ! for specific heat 91 91 REAL(wp) :: zbeta = 0.117_wp ! for thermal conductivity (could be 0.13) 92 REAL(wp) :: zraext_s = 10._wp ! extinction coefficient of radiation in the snow93 92 REAL(wp) :: zkimin = 0.10_wp ! minimum ice thermal conductivity 94 93 REAL(wp) :: ztsu_err = 1.e-5_wp ! range around which t_su is considered at 0C 95 94 REAL(wp) :: zdti_bnd = 1.e-4_wp ! maximal authorized error on temperature 96 REAL(wp) :: zhs_min = 0.01_wp ! minimum snow thickness for conductivity calculation 95 REAL(wp) :: zhs_ssl = 0.03_wp ! surface scattering layer in the snow 96 REAL(wp) :: zhi_ssl = 0.10_wp ! surface scattering layer in the ice 97 REAL(wp) :: zh_min = 1.e-3_wp ! minimum ice/snow thickness for conduction 97 98 REAL(wp) :: ztmelts ! ice melting temperature 98 99 REAL(wp) :: zdti_max ! current maximal error on temperature 99 100 REAL(wp) :: zcpi ! Ice specific heat 100 101 REAL(wp) :: zhfx_err, zdq ! diag errors on heat 101 REAL(wp) :: zfac ! dummy factor 102 ! 103 REAL(wp), DIMENSION(jpij) :: isnow ! switch for presence (1) or absence (0) of snow 102 ! 103 REAL(wp), DIMENSION(jpij) :: zraext_s ! extinction coefficient of radiation in the snow 104 104 REAL(wp), DIMENSION(jpij) :: ztsub ! surface temperature at previous iteration 105 105 REAL(wp), DIMENSION(jpij) :: zh_i, z1_h_i ! ice layer thickness … … 124 124 REAL(wp), DIMENSION(jpij,0:nlay_s) :: zkappa_s ! Kappa factor in the snow 125 125 REAL(wp), DIMENSION(jpij,0:nlay_s) :: zeta_s ! Eta factor in the snow 126 REAL(wp), DIMENSION(jpij) :: zkappa_comb ! Combined snow and ice surface conductivity 126 127 REAL(wp), DIMENSION(jpij,nlay_i+3) :: zindterm ! 'Ind'ependent term 127 128 REAL(wp), DIMENSION(jpij,nlay_i+3) :: zindtbis ! Temporary 'ind'ependent term … … 130 131 REAL(wp), DIMENSION(jpij) :: zq_ini ! diag errors on heat 131 132 REAL(wp), DIMENSION(jpij) :: zghe ! G(he), th. conduct enhancement factor, mono-cat 133 REAL(wp), DIMENSION(jpij) :: za_s_fra ! ice fraction covered by snow 134 REAL(wp), DIMENSION(jpij) :: isnow ! snow presence (1) or not (0) 135 REAL(wp), DIMENSION(jpij) :: isnow_comb ! snow presence for met-office 132 136 ! 133 137 ! Mono-category … … 143 147 END DO 144 148 149 ! calculate ice fraction covered by snow for radiation 150 CALL ice_var_snwfra( h_s_1d(1:npti), za_s_fra(1:npti) ) 151 145 152 !------------------ 146 153 ! 1) Initialization 147 154 !------------------ 155 ! 156 ! extinction radiation in the snow 157 IF ( nn_qtrice == 0 ) THEN ! constant 158 zraext_s(1:npti) = rn_kappa_s 159 ELSEIF( nn_qtrice == 1 ) THEN ! depends on melting/freezing conditions 160 WHERE( t_su_1d(1:npti) < rt0 ) ; zraext_s(1:npti) = rn_kappa_sdry ! no surface melting 161 ELSEWHERE ; zraext_s(1:npti) = rn_kappa_smlt ! surface melting 162 END WHERE 163 ENDIF 164 ! 165 ! thicknesses 148 166 DO ji = 1, npti 149 isnow(ji) = 1._wp - MAX( 0._wp , SIGN(1._wp, - h_s_1d(ji) ) ) ! is there snow or not 150 ! layer thickness 151 zh_i(ji) = h_i_1d(ji) * r1_nlay_i 152 zh_s(ji) = h_s_1d(ji) * r1_nlay_s 167 ! ice thickness 168 IF( h_i_1d(ji) > 0._wp ) THEN 169 zh_i (ji) = MAX( zh_min , h_i_1d(ji) ) * r1_nlay_i ! set a minimum thickness for conduction 170 z1_h_i(ji) = 1._wp / zh_i(ji) ! it must be very small 171 ELSE 172 zh_i (ji) = 0._wp 173 z1_h_i(ji) = 0._wp 174 ENDIF 175 ! snow thickness 176 IF( h_s_1d(ji) > 0._wp ) THEN 177 zh_s (ji) = MAX( zh_min , h_s_1d(ji) ) * r1_nlay_s ! set a minimum thickness for conduction 178 z1_h_s(ji) = 1._wp / zh_s(ji) ! it must be very small 179 isnow (ji) = 1._wp 180 ELSE 181 zh_s (ji) = 0._wp 182 z1_h_s(ji) = 0._wp 183 isnow (ji) = 0._wp 184 ENDIF 185 ! for Met-Office 186 IF( h_s_1d(ji) < zh_min ) THEN 187 isnow_comb(ji) = h_s_1d(ji) / zh_min 188 ELSE 189 isnow_comb(ji) = 1._wp 190 ENDIF 153 191 END DO 154 ! 155 WHERE( zh_i(1:npti) >= epsi10 ) ; z1_h_i(1:npti) = 1._wp / zh_i(1:npti) 156 ELSEWHERE ; z1_h_i(1:npti) = 0._wp 157 END WHERE 158 ! 159 WHERE( zh_s(1:npti) > 0._wp ) zh_s(1:npti) = MAX( zhs_min * r1_nlay_s, zh_s(1:npti) ) 160 ! 161 WHERE( zh_s(1:npti) > 0._wp ) ; z1_h_s(1:npti) = 1._wp / zh_s(1:npti) 162 ELSEWHERE ; z1_h_s(1:npti) = 0._wp 163 END WHERE 192 ! clem: we should apply correction on snow thickness to take into account snow fraction 193 ! it must be a distribution, so it is a bit complicated 164 194 ! 165 195 ! Store initial temperatures and non solar heat fluxes 166 196 IF( k_cnd == np_cnd_OFF .OR. k_cnd == np_cnd_EMU ) THEN 167 !168 197 ztsub (1:npti) = t_su_1d(1:npti) ! surface temperature at iteration n-1 169 198 ztsuold (1:npti) = t_su_1d(1:npti) ! surface temperature initial value … … 185 214 DO ji = 1, npti 186 215 ! ! radiation transmitted below the layer-th snow layer 187 zradtr_s(ji,jk) = zradtr_s(ji,0) * EXP( - zraext_s * h_s_1d(ji) * r1_nlay_s * REAL(jk) )216 zradtr_s(ji,jk) = zradtr_s(ji,0) * EXP( - zraext_s(ji) * MAX( 0._wp, zh_s(ji) * REAL(jk) - zhs_ssl ) ) 188 217 ! ! radiation absorbed by the layer-th snow layer 189 218 zradab_s(ji,jk) = zradtr_s(ji,jk-1) - zradtr_s(ji,jk) … … 191 220 END DO 192 221 ! 193 zradtr_i(1:npti,0) = zradtr_s(1:npti,nlay_s) * isnow(1:npti) + qtr_ice_top_1d(1:npti) * ( 1._wp - isnow(1:npti) )222 zradtr_i(1:npti,0) = zradtr_s(1:npti,nlay_s) * za_s_fra(1:npti) + qtr_ice_top_1d(1:npti) * ( 1._wp - za_s_fra(1:npti) ) 194 223 DO jk = 1, nlay_i 195 224 DO ji = 1, npti 196 225 ! ! radiation transmitted below the layer-th ice layer 197 zradtr_i(ji,jk) = zradtr_i(ji,0) * EXP( - rn_kappa_i * zh_i(ji) * REAL(jk) ) 226 zradtr_i(ji,jk) = za_s_fra(ji) * zradtr_s(ji,nlay_s) & ! part covered by snow 227 & * EXP( - rn_kappa_i * MAX( 0._wp, zh_i(ji) * REAL(jk) - zh_min ) ) & 228 & + ( 1._wp - za_s_fra(ji) ) * qtr_ice_top_1d(ji) & ! part snow free 229 & * EXP( - rn_kappa_i * MAX( 0._wp, zh_i(ji) * REAL(jk) - zhi_ssl ) ) 198 230 ! ! radiation absorbed by the layer-th ice layer 199 231 zradab_i(ji,jk) = zradtr_i(ji,jk-1) - zradtr_i(ji,jk) … … 203 235 qtr_ice_bot_1d(1:npti) = zradtr_i(1:npti,nlay_i) ! record radiation transmitted below the ice 204 236 ! 205 iconv 237 iconv = 0 ! number of iterations 206 238 ! 207 239 l_T_converged(:) = .FALSE. … … 230 262 DO ji = 1, npti 231 263 ztcond_i_cp(ji,jk) = rcnd_i + zbeta * 0.5_wp * ( sz_i_1d(ji,jk) + sz_i_1d(ji,jk+1) ) / & 232 & MIN( -epsi10, 0.5_wp * (t_i_1d(ji,jk) + t_i_1d(ji,jk+1)) - rt0 )264 & MIN( -epsi10, 0.5_wp * ( t_i_1d(ji,jk) + t_i_1d(ji,jk+1) ) - rt0 ) 233 265 END DO 234 266 END DO … … 238 270 DO ji = 1, npti 239 271 ztcond_i_cp(ji,0) = rcnd_i + 0.09_wp * sz_i_1d(ji,1) / MIN( -epsi10, t_i_1d(ji,1) - rt0 ) & 240 & - 0.011_wp * ( t_i_1d(ji,1) - rt0 )272 & - 0.011_wp * ( t_i_1d(ji,1) - rt0 ) 241 273 ztcond_i_cp(ji,nlay_i) = rcnd_i + 0.09_wp * sz_i_1d(ji,nlay_i) / MIN( -epsi10, t_bo_1d(ji) - rt0 ) & 242 & - 0.011_wp * ( t_bo_1d(ji) - rt0 )274 & - 0.011_wp * ( t_bo_1d(ji) - rt0 ) 243 275 END DO 244 276 DO jk = 1, nlay_i-1 245 277 DO ji = 1, npti 246 ztcond_i_cp(ji,jk) = rcnd_i + 0.09_wp * 0.5_wp * ( sz_i_1d(ji,jk) + sz_i_1d(ji,jk+1) ) / 247 & MIN( -epsi10, 0.5_wp * ( t_i_1d (ji,jk) + t_i_1d (ji,jk+1) ) - rt0 )&248 & - 0.011_wp * ( 0.5_wp * ( t_i_1d (ji,jk) + t_i_1d(ji,jk+1) ) - rt0 )278 ztcond_i_cp(ji,jk) = rcnd_i + 0.09_wp * 0.5_wp * ( sz_i_1d(ji,jk) + sz_i_1d(ji,jk+1) ) / & 279 & MIN( -epsi10, 0.5_wp * ( t_i_1d(ji,jk) + t_i_1d(ji,jk+1) ) - rt0 ) & 280 & - 0.011_wp * ( 0.5_wp * ( t_i_1d(ji,jk) + t_i_1d(ji,jk+1) ) - rt0 ) 249 281 END DO 250 282 END DO … … 290 322 END DO 291 323 DO ji = 1, npti ! Snow-ice interface 292 IF ( .NOT. l_T_converged(ji) ) THEN 293 zfac = 0.5_wp * ( ztcond_i(ji,0) * zh_s(ji) + rn_cnd_s * zh_i(ji) ) 294 IF( zfac > epsi10 ) THEN 295 zkappa_s(ji,nlay_s) = zghe(ji) * rn_cnd_s * ztcond_i(ji,0) / zfac 296 ELSE 297 zkappa_s(ji,nlay_s) = 0._wp 298 ENDIF 299 ENDIF 324 IF ( .NOT. l_T_converged(ji) ) & 325 zkappa_s(ji,nlay_s) = isnow(ji) * zghe(ji) * rn_cnd_s * ztcond_i(ji,0) & 326 & / ( 0.5_wp * ( ztcond_i(ji,0) * zh_s(ji) + rn_cnd_s * zh_i(ji) ) ) 300 327 END DO 301 328 … … 310 337 END DO 311 338 DO ji = 1, npti ! Snow-ice interface 312 IF ( .NOT. l_T_converged(ji) ) & 313 zkappa_i(ji,0) = zkappa_s(ji,nlay_s) * isnow(ji) + zkappa_i(ji,0) * ( 1._wp - isnow(ji) ) 339 IF ( .NOT. l_T_converged(ji) ) THEN 340 ! Calculate combined surface snow and ice conductivity to pass through the coupler (met-office) 341 zkappa_comb(ji) = isnow_comb(ji) * zkappa_s(ji,0) + ( 1._wp - isnow_comb(ji) ) * zkappa_i(ji,0) 342 ! If there is snow then use the same snow-ice interface conductivity for the top layer of ice 343 IF( h_s_1d(ji) > 0._wp ) zkappa_i(ji,0) = zkappa_s(ji,nlay_s) 344 ENDIF 314 345 END DO 315 346 ! … … 320 351 DO ji = 1, npti 321 352 zcpi = rcpi + zgamma * sz_i_1d(ji,jk) / MAX( ( t_i_1d(ji,jk) - rt0 ) * ( ztiold(ji,jk) - rt0 ), epsi10 ) 322 zeta_i(ji,jk) = rDt_ice * r1_rhoi * z1_h_i(ji) / MAX( epsi10, zcpi )353 zeta_i(ji,jk) = rDt_ice * r1_rhoi * z1_h_i(ji) / zcpi 323 354 END DO 324 355 END DO … … 544 575 ztsub(ji) = t_su_1d(ji) 545 576 IF( t_su_1d(ji) < rt0 ) THEN 546 t_su_1d(ji) = ( zindtbis(ji,jm_min(ji)) - ztrid(ji,jm_min(ji),3) * &547 & ( isnow(ji) * t_s_1d(ji,1) + ( 1._wp - isnow(ji) ) *t_i_1d(ji,1) ) ) / zdiagbis(ji,jm_min(ji))577 t_su_1d(ji) = ( zindtbis(ji,jm_min(ji)) - ztrid(ji,jm_min(ji),3) * & 578 & ( isnow(ji) * t_s_1d(ji,1) + ( 1._wp - isnow(ji) ) * t_i_1d(ji,1) ) ) / zdiagbis(ji,jm_min(ji)) 548 579 ENDIF 549 580 ENDIF 550 581 END DO 582 !clem: in order to have several layers of snow, there is a missing loop here for t_s_1d(1:nlay_s-1) 551 583 ! 552 584 !-------------------------------------------------------------- … … 561 593 562 594 IF ( .NOT. l_T_converged(ji) ) THEN 595 563 596 t_su_1d(ji) = MAX( MIN( t_su_1d(ji) , rt0 ) , rt0 - 100._wp ) 564 597 zdti_max = MAX( zdti_max, ABS( t_su_1d(ji) - ztsub(ji) ) ) 565 598 566 t_s_1d(ji,1:nlay_s) = MAX( MIN( t_s_1d(ji,1:nlay_s), rt0 ), rt0 - 100._wp ) 567 zdti_max = MAX ( zdti_max , MAXVAL( ABS( t_s_1d(ji,1:nlay_s) - ztsb(ji,1:nlay_s) ) ) ) 599 IF( h_s_1d(ji) > 0._wp ) THEN 600 DO jk = 1, nlay_s 601 t_s_1d(ji,jk) = MAX( MIN( t_s_1d(ji,jk), rt0 ), rt0 - 100._wp ) 602 zdti_max = MAX ( zdti_max , ABS( t_s_1d(ji,jk) - ztsb(ji,jk) ) ) 603 END DO 604 ENDIF 568 605 569 606 DO jk = 1, nlay_i … … 572 609 zdti_max = MAX( zdti_max, ABS( t_i_1d(ji,jk) - ztib(ji,jk) ) ) 573 610 END DO 574 575 IF ( zdti_max < zdti_bnd ) l_T_converged(ji) = .TRUE. 611 612 ! convergence test 613 IF( ln_zdf_chkcvg ) THEN 614 tice_cvgerr_1d(ji) = zdti_max 615 tice_cvgstp_1d(ji) = REAL(iconv) 616 ENDIF 617 618 IF( zdti_max < zdti_bnd ) l_T_converged(ji) = .TRUE. 576 619 577 620 ENDIF … … 726 769 ENDIF 727 770 END DO 771 !clem: in order to have several layers of snow, there is a missing loop here for t_s_1d(1:nlay_s-1) 728 772 ! 729 773 !-------------------------------------------------------------- … … 738 782 739 783 IF ( .NOT. l_T_converged(ji) ) THEN 740 ! t_s 741 t_s_1d(ji,1:nlay_s) = MAX( MIN( t_s_1d(ji,1:nlay_s), rt0 ), rt0 - 100._wp ) 742 zdti_max = MAX ( zdti_max , MAXVAL( ABS( t_s_1d(ji,1:nlay_s) - ztsb(ji,1:nlay_s) ) ) ) 743 ! t_i 784 785 IF( h_s_1d(ji) > 0._wp ) THEN 786 DO jk = 1, nlay_s 787 t_s_1d(ji,jk) = MAX( MIN( t_s_1d(ji,jk), rt0 ), rt0 - 100._wp ) 788 zdti_max = MAX ( zdti_max , ABS( t_s_1d(ji,jk) - ztsb(ji,jk) ) ) 789 END DO 790 ENDIF 791 744 792 DO jk = 1, nlay_i 745 793 ztmelts = -rTmlt * sz_i_1d(ji,jk) + rt0 … … 748 796 END DO 749 797 750 IF ( zdti_max < zdti_bnd ) l_T_converged(ji) = .TRUE. 798 ! convergence test 799 IF( ln_zdf_chkcvg ) THEN 800 tice_cvgerr_1d(ji) = zdti_max 801 tice_cvgstp_1d(ji) = REAL(iconv) 802 ENDIF 803 804 IF( zdti_max < zdti_bnd ) l_T_converged(ji) = .TRUE. 751 805 752 806 ENDIF … … 755 809 756 810 ENDIF ! k_cnd 757 811 758 812 END DO ! End of the do while iterative procedure 759 760 IF( ln_icectl .AND. lwp ) THEN761 WRITE(numout,*) ' zdti_max : ', zdti_max762 WRITE(numout,*) ' iconv : ', iconv763 ENDIF764 765 813 ! 766 814 !----------------------------- … … 771 819 ! bottom ice conduction flux 772 820 DO ji = 1, npti 773 qcn_ice_bot_1d(ji) = - zkappa_i(ji,nlay_i) * zg1 821 qcn_ice_bot_1d(ji) = - zkappa_i(ji,nlay_i) * zg1 * ( t_bo_1d(ji ) - t_i_1d (ji,nlay_i) ) 774 822 END DO 775 823 ! surface ice conduction flux … … 777 825 ! 778 826 DO ji = 1, npti 779 qcn_ice_top_1d(ji) = - isnow(ji) * zkappa_s(ji,0) * zg1s * ( t_s_1d(ji,1) - t_su_1d(ji) )&780 & 827 qcn_ice_top_1d(ji) = - isnow(ji) * zkappa_s(ji,0) * zg1s * ( t_s_1d(ji,1) - t_su_1d(ji) ) & 828 & - ( 1._wp - isnow(ji) ) * zkappa_i(ji,0) * zg1 * ( t_i_1d(ji,1) - t_su_1d(ji) ) 781 829 END DO 782 830 ! … … 792 840 ! 793 841 DO ji = 1, npti 794 t_su_1d(ji) = ( qcn_ice_top_1d(ji) & ! calculate surface temperature 795 & + isnow(ji) * zkappa_s(ji,0) * zg1s * t_s_1d(ji,1) & 796 & + ( 1._wp - isnow(ji) ) * zkappa_i(ji,0) * zg1 * t_i_1d(ji,1) & 797 & ) / MAX( epsi10, isnow(ji) * zkappa_s(ji,0) * zg1s + ( 1._wp - isnow(ji) ) * zkappa_i(ji,0) * zg1 ) 842 t_su_1d(ji) = ( qcn_ice_top_1d(ji) + isnow(ji) * zkappa_s(ji,0) * zg1s * t_s_1d(ji,1) + & 843 & ( 1._wp - isnow(ji) ) * zkappa_i(ji,0) * zg1 * t_i_1d(ji,1) ) & 844 & / MAX( epsi10, isnow(ji) * zkappa_s(ji,0) * zg1s + ( 1._wp - isnow(ji) ) * zkappa_i(ji,0) * zg1 ) 798 845 t_su_1d(ji) = MAX( MIN( t_su_1d(ji), rt0 ), rt0 - 100._wp ) ! cap t_su 799 846 END DO … … 853 900 !-------------------------------------------------------------------- 854 901 ! effective conductivity and 1st layer temperature (needed by Met Office) 902 ! this is a conductivity at mid-layer, hence the factor 2 855 903 DO ji = 1, npti 856 IF( h_s_1d(ji) > 0.1_wp ) THEN 857 cnd_ice_1d(ji) = 2._wp * zkappa_s(ji,0) 904 IF( h_i_1d(ji) >= zhi_ssl ) THEN 905 cnd_ice_1d(ji) = 2._wp * zkappa_comb(ji) 906 !!cnd_ice_1d(ji) = 2._wp * zkappa_i(ji,0) 858 907 ELSE 859 IF( h_i_1d(ji) > 0.1_wp ) THEN 860 cnd_ice_1d(ji) = 2._wp * zkappa_i(ji,0) 861 ELSE 862 cnd_ice_1d(ji) = 2._wp * ztcond_i(ji,0) * 10._wp 863 ENDIF 908 cnd_ice_1d(ji) = 2._wp * ztcond_i(ji,0) / zhi_ssl ! cnd_ice is capped by: cond_i/zhi_ssl 864 909 ENDIF 865 910 t1_ice_1d(ji) = isnow(ji) * t_s_1d(ji,1) + ( 1._wp - isnow(ji) ) * t_i_1d(ji,1) … … 877 922 DO ji = 1, npti 878 923 !--- Snow-ice interfacial temperature (diagnostic SIMIP) 879 zfac = rn_cnd_s * zh_i(ji) + ztcond_i(ji,1) * zh_s(ji) 880 IF( h_s_1d(ji) >= zhs_min ) THEN 881 t_si_1d(ji) = ( rn_cnd_s * zh_i(ji) * t_s_1d(ji,1) + & 882 & ztcond_i(ji,1) * zh_s(ji) * t_i_1d(ji,1) ) / MAX( epsi10, zfac ) 924 IF( h_s_1d(ji) >= zhs_ssl ) THEN 925 t_si_1d(ji) = ( rn_cnd_s * h_i_1d(ji) * r1_nlay_i * t_s_1d(ji,1) & 926 & + ztcond_i(ji,1) * h_s_1d(ji) * r1_nlay_s * t_i_1d(ji,1) ) & 927 & / ( rn_cnd_s * h_i_1d(ji) * r1_nlay_i & 928 & + ztcond_i(ji,1) * h_s_1d(ji) * r1_nlay_s ) 883 929 ELSE 884 930 t_si_1d(ji) = t_su_1d(ji) -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/ICE/iceupdate.F90
r13295 r13998 24 24 USE traqsr ! add penetration of solar flux in the calculation of heat budget 25 25 USE icectl ! sea-ice: control prints 26 USE bdy_oce , ONLY : ln_bdy26 USE zdfdrg , ONLY : ln_drgice_imp 27 27 ! 28 28 USE in_out_manager ! I/O manager … … 91 91 ! 92 92 INTEGER :: ji, jj, jl, jk ! dummy loop indices 93 REAL(wp) :: zqmass ! Heat flux associated with mass exchange ice->ocean (W.m-2)94 93 REAL(wp) :: zqsr ! New solar flux received by the ocean 95 REAL(wp), DIMENSION(jpi,jpj) :: z2d ! 2D workspace 96 REAL(wp), DIMENSION(jpi,jpj,jpl) :: zalb_cs, zalb_os ! 3D workspace 94 REAL(wp), DIMENSION(jpi,jpj) :: z2d ! 2D workspace 97 95 !!--------------------------------------------------------------------- 98 96 IF( ln_timing ) CALL timing_start('ice_update') … … 103 101 WRITE(numout,*)'~~~~~~~~~~~~~~' 104 102 ENDIF 103 104 ! Net heat flux on top of the ice-ocean (W.m-2) 105 !---------------------------------------------- 106 qt_atm_oi(:,:) = qns_tot(:,:) + qsr_tot(:,:) 105 107 106 108 ! --- case we bypass ice thermodynamics --- ! … … 115 117 DO_2D( 1, 1, 1, 1 ) 116 118 117 ! Solar heat flux reaching the ocean = zqsr (W.m-2)119 ! Solar heat flux reaching the ocean (max) = zqsr (W.m-2) 118 120 !--------------------------------------------------- 119 121 zqsr = qsr_tot(ji,jj) - SUM( a_i_b(ji,jj,:) * ( qsr_ice(ji,jj,:) - qtr_ice_bot(ji,jj,:) ) ) … … 121 123 ! Total heat flux reaching the ocean = qt_oce_ai (W.m-2) 122 124 !--------------------------------------------------- 123 zqmass = hfx_thd(ji,jj) + hfx_dyn(ji,jj) + hfx_res(ji,jj) ! heat flux from snow is 0 (T=0 degC) 124 qt_oce_ai(ji,jj) = qt_oce_ai(ji,jj) + zqmass + zqsr 125 126 ! Add the residual from heat diffusion equation and sublimation (W.m-2) 127 !---------------------------------------------------------------------- 128 qt_oce_ai(ji,jj) = qt_oce_ai(ji,jj) + hfx_err_dif(ji,jj) + & 129 & ( hfx_sub(ji,jj) - SUM( qevap_ice(ji,jj,:) * a_i_b(ji,jj,:) ) ) 130 125 qt_oce_ai(ji,jj) = qt_atm_oi(ji,jj) - hfx_sum(ji,jj) - hfx_bom(ji,jj) - hfx_bog(ji,jj) & 126 & - hfx_dif(ji,jj) - hfx_opw(ji,jj) - hfx_snw(ji,jj) & 127 & + hfx_thd(ji,jj) + hfx_dyn(ji,jj) + hfx_res(ji,jj) & 128 & + hfx_sub(ji,jj) - SUM( qevap_ice(ji,jj,:) * a_i_b(ji,jj,:) ) + hfx_spr(ji,jj) 129 131 130 ! New qsr and qns used to compute the oceanic heat flux at the next time step 132 131 !---------------------------------------------------------------------------- 133 qsr(ji,jj) = zqsr 132 ! if warming and some ice remains, then we suppose that the whole solar flux has been consumed to melt the ice 133 ! else ( cooling or no ice left ), then we suppose that no solar flux has been consumed 134 ! 135 IF( fhld(ji,jj) > 0._wp .AND. at_i(ji,jj) > 0._wp ) THEN !-- warming and some ice remains 136 ! solar flux transmitted thru the 1st level of the ocean (i.e. not used by sea-ice) 137 qsr(ji,jj) = ( 1._wp - at_i_b(ji,jj) ) * qsr_oce(ji,jj) * ( 1._wp - frq_m(ji,jj) ) & 138 ! + solar flux transmitted thru ice and the 1st ocean level (also not used by sea-ice) 139 & + SUM( a_i_b(ji,jj,:) * qtr_ice_bot(ji,jj,:) ) * ( 1._wp - frq_m(ji,jj) ) 140 ! 141 ELSE !-- cooling or no ice left 142 qsr(ji,jj) = zqsr 143 ENDIF 144 ! 145 ! the non-solar is simply derived from the solar flux 134 146 qns(ji,jj) = qt_oce_ai(ji,jj) - zqsr 135 147 136 148 ! Mass flux at the atm. surface 137 149 !----------------------------------- … … 140 152 ! Mass flux at the ocean surface 141 153 !------------------------------------ 142 ! case of realistic freshwater flux (Tartinville et al., 2001) (presently ACTIVATED) 143 ! ------------------------------------------------------------------------------------- 144 ! The idea of this approach is that the system that we consider is the ICE-OCEAN system 145 ! Thus FW flux = External ( E-P+snow melt) 146 ! Salt flux = Exchanges in the ice-ocean system then converted into FW 147 ! Associated to Ice formation AND Ice melting 148 ! Even if i see Ice melting as a FW and SALT flux 149 ! 150 ! mass flux from ice/ocean 154 ! ice-ocean mass flux 151 155 wfx_ice(ji,jj) = wfx_bog(ji,jj) + wfx_bom(ji,jj) + wfx_sum(ji,jj) + wfx_sni(ji,jj) & 152 156 & + wfx_opw(ji,jj) + wfx_dyn(ji,jj) + wfx_res(ji,jj) + wfx_lam(ji,jj) + wfx_pnd(ji,jj) 153 154 ! add the snow melt water to snow mass flux to the ocean157 158 ! snw-ocean mass flux 155 159 wfx_snw(ji,jj) = wfx_snw_sni(ji,jj) + wfx_snw_dyn(ji,jj) + wfx_snw_sum(ji,jj) 156 157 ! mass flux at the ocean/ice interface 158 fmmflx(ji,jj) = - ( wfx_ice(ji,jj) + wfx_snw(ji,jj) + wfx_err_sub(ji,jj) ) ! F/M mass flux save at least for biogeochemical model 159 emp(ji,jj) = emp_oce(ji,jj) - wfx_ice(ji,jj) - wfx_snw(ji,jj) - wfx_err_sub(ji,jj) ! mass flux + F/M mass flux (always ice/ocean mass exchange) 160 160 161 ! total mass flux at the ocean/ice interface 162 fmmflx(ji,jj) = - wfx_ice(ji,jj) - wfx_snw(ji,jj) - wfx_err_sub(ji,jj) ! ice-ocean mass flux saved at least for biogeochemical model 163 emp (ji,jj) = emp_oce(ji,jj) - wfx_ice(ji,jj) - wfx_snw(ji,jj) - wfx_err_sub(ji,jj) ! atm-ocean + ice-ocean mass flux 161 164 162 165 ! Salt flux at the ocean surface … … 182 185 ! Snow/ice albedo (only if sent to coupler, useless in forced mode) 183 186 !------------------------------------------------------------------ 184 CALL ice_alb( t_su, h_i, h_s, ln_pnd_alb, a_ip_frac, h_ip, zalb_cs, zalb_os ) ! cloud-sky and overcast-sky ice albedos 185 ! 186 alb_ice(:,:,:) = ( 1._wp - cldf_ice ) * zalb_cs(:,:,:) + cldf_ice * zalb_os(:,:,:) 187 CALL ice_alb( t_su, h_i, h_s, ln_pnd_alb, a_ip_eff, h_ip, cloud_fra, alb_ice ) ! ice albedo 188 187 189 ! 188 190 IF( lrst_ice ) THEN !* write snwice_mass fields in the restart file … … 263 265 CALL iom_put ('hfxdif' , hfx_dif ) ! heat flux used for ice temperature change 264 266 CALL iom_put ('hfxsnw' , hfx_snw ) ! heat flux used for snow melt 265 CALL iom_put ('hfxerr' , hfx_err_dif ) ! heat flux error after heat diffusion (included in qt_oce_ai)267 CALL iom_put ('hfxerr' , hfx_err_dif ) ! heat flux error after heat diffusion 266 268 267 269 ! heat fluxes associated with mass exchange (freeze/melt/precip...) … … 280 282 !--------- 281 283 #if ! defined key_agrif 282 IF( ln_icediachk .AND. .NOT. ln_bdy) CALL ice_cons_final('iceupdate') ! conservation284 IF( ln_icediachk ) CALL ice_cons_final('iceupdate') ! conservation 283 285 #endif 284 IF( ln_icectl 285 IF( sn_cfctl%l_prtctl 286 IF( ln_timing 286 IF( ln_icectl ) CALL ice_prt (kt, iiceprt, jiceprt, 3, 'Final state ice_update') ! prints 287 IF( sn_cfctl%l_prtctl ) CALL ice_prt3D ('iceupdate') ! prints 288 IF( ln_timing ) CALL timing_stop ('ice_update') ! timing 287 289 ! 288 290 END SUBROUTINE ice_update_flx … … 320 322 REAL(wp) :: zat_u, zutau_ice, zu_t, zmodt ! local scalar 321 323 REAL(wp) :: zat_v, zvtau_ice, zv_t, zrhoco ! - - 324 REAL(wp) :: zflagi ! - - 322 325 !!--------------------------------------------------------------------- 323 326 IF( ln_timing ) CALL timing_start('ice_update_tau') … … 332 335 ! 333 336 IF( MOD( kt-1, nn_fsbc ) == 0 ) THEN !== Ice time-step only ==! (i.e. surface module time-step) 334 DO_2D( 0, 0, 0, 0 ) 337 DO_2D( 0, 0, 0, 0 ) !* update the modulus of stress at ocean surface (T-point) 335 338 ! ! 2*(U_ice-U_oce) at T-point 336 339 zu_t = u_ice(ji,jj) + u_ice(ji-1,jj) - u_oce(ji,jj) - u_oce(ji-1,jj) … … 350 353 ! 351 354 ! !== every ocean time-step ==! 352 ! 353 DO_2D( 0, 0, 0, 0 ) 355 IF ( ln_drgice_imp ) THEN 356 ! Save drag with right sign to update top drag in the ocean implicit friction 357 rCdU_ice(:,:) = -r1_rho0 * tmod_io(:,:) * at_i(:,:) * tmask(:,:,1) 358 zflagi = 0._wp 359 ELSE 360 zflagi = 1._wp 361 ENDIF 362 ! 363 DO_2D( 0, 0, 0, 0 ) !* update the stress WITHOUT an ice-ocean rotation angle 354 364 ! ice area at u and v-points 355 365 zat_u = ( at_i(ji,jj) * tmask(ji,jj,1) + at_i (ji+1,jj ) * tmask(ji+1,jj ,1) ) & -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/ICE/icevar.F90
r13295 r13998 51 51 !! ice_var_sshdyn : compute equivalent ssh in lead 52 52 !! ice_var_itd : convert N-cat to M-cat 53 !! ice_var_snwfra : fraction of ice covered by snow 54 !! ice_var_snwblow : distribute snow fall between ice and ocean 53 55 !!---------------------------------------------------------------------- 54 56 USE dom_oce ! ocean space and time domain … … 77 79 PUBLIC ice_var_sshdyn 78 80 PUBLIC ice_var_itd 81 PUBLIC ice_var_snwfra 82 PUBLIC ice_var_snwblow 79 83 80 84 INTERFACE ice_var_itd … … 84 88 !! * Substitutions 85 89 # include "do_loop_substitute.h90" 90 91 INTERFACE ice_var_snwfra 92 MODULE PROCEDURE ice_var_snwfra_1d, ice_var_snwfra_2d, ice_var_snwfra_3d 93 END INTERFACE 94 95 INTERFACE ice_var_snwblow 96 MODULE PROCEDURE ice_var_snwblow_1d, ice_var_snwblow_2d 97 END INTERFACE 98 86 99 !!---------------------------------------------------------------------- 87 100 !! NEMO/ICE 4.0 , NEMO Consortium (2018) … … 115 128 at_ip(:,:) = SUM( a_ip(:,:,:), dim=3 ) ! melt ponds 116 129 vt_ip(:,:) = SUM( v_ip(:,:,:), dim=3 ) 130 vt_il(:,:) = SUM( v_il(:,:,:), dim=3 ) 117 131 ! 118 132 ato_i(:,:) = 1._wp - at_i(:,:) ! open water fraction … … 166 180 ! 167 181 ! ! mean melt pond depth 168 WHERE( at_ip(:,:) > epsi20 ) ; hm_ip(:,:) = vt_ip(:,:) / at_ip(:,:) 169 ELSEWHERE ; hm_ip(:,:) = 0._wp 182 WHERE( at_ip(:,:) > epsi20 ) ; hm_ip(:,:) = vt_ip(:,:) / at_ip(:,:) ; hm_il(:,:) = vt_il(:,:) / at_ip(:,:) 183 ELSEWHERE ; hm_ip(:,:) = 0._wp ; hm_il(:,:) = 0._wp 170 184 END WHERE 171 185 ! … … 191 205 REAL(wp) :: zhmax, z1_zhmax ! - - 192 206 REAL(wp) :: zlay_i, zlay_s ! - - 193 REAL(wp), DIMENSION(jpi,jpj,jpl) :: z1_a_i, z1_v_i 207 REAL(wp), PARAMETER :: zhl_max = 0.015_wp ! pond lid thickness above which the ponds disappear from the albedo calculation 208 REAL(wp), PARAMETER :: zhl_min = 0.005_wp ! pond lid thickness below which the full pond area is used in the albedo calculation 209 REAL(wp), DIMENSION(jpi,jpj,jpl) :: z1_a_i, z1_v_i, z1_a_ip, za_s_fra 194 210 !!------------------------------------------------------------------- 195 211 … … 210 226 ELSEWHERE ; z1_v_i(:,:,:) = 0._wp 211 227 END WHERE 228 ! 229 WHERE( a_ip(:,:,:) > epsi20 ) ; z1_a_ip(:,:,:) = 1._wp / a_ip(:,:,:) 230 ELSEWHERE ; z1_a_ip(:,:,:) = 0._wp 231 END WHERE 212 232 ! !--- ice thickness 213 233 h_i(:,:,:) = v_i (:,:,:) * z1_a_i(:,:,:) … … 224 244 ! !--- ice age 225 245 o_i(:,:,:) = oa_i(:,:,:) * z1_a_i(:,:,:) 226 ! !--- pond fraction and thickness 246 ! !--- pond and lid thickness 247 h_ip(:,:,:) = v_ip(:,:,:) * z1_a_ip(:,:,:) 248 h_il(:,:,:) = v_il(:,:,:) * z1_a_ip(:,:,:) 249 ! !--- melt pond effective area (used for albedo) 227 250 a_ip_frac(:,:,:) = a_ip(:,:,:) * z1_a_i(:,:,:) 228 WHERE( a_ip_frac(:,:,:) > epsi20 ) ; h_ip(:,:,:) = v_ip(:,:,:) * z1_a_i(:,:,:) / a_ip_frac(:,:,:) 229 ELSEWHERE ; h_ip(:,:,:) = 0._wp 230 END WHERE 251 WHERE ( h_il(:,:,:) <= zhl_min ) ; a_ip_eff(:,:,:) = a_ip_frac(:,:,:) ! lid is very thin. Expose all the pond 252 ELSEWHERE( h_il(:,:,:) >= zhl_max ) ; a_ip_eff(:,:,:) = 0._wp ! lid is very thick. Cover all the pond up with ice and snow 253 ELSEWHERE ; a_ip_eff(:,:,:) = a_ip_frac(:,:,:) * & ! lid is in between. Expose part of the pond 254 & ( h_il(:,:,:) - zhl_min ) / ( zhl_max - zhl_min ) 255 END WHERE 256 ! 257 CALL ice_var_snwfra( h_s, za_s_fra ) ! calculate ice fraction covered by snow 258 a_ip_eff = MIN( a_ip_eff, 1._wp - za_s_fra ) ! make sure (a_ip_eff + a_s_fra) <= 1 231 259 ! 232 260 ! !--- salinity (with a minimum value imposed everywhere) … … 292 320 sv_i(:,:,:) = s_i (:,:,:) * v_i (:,:,:) 293 321 v_ip(:,:,:) = h_ip(:,:,:) * a_ip(:,:,:) 322 v_il(:,:,:) = h_il(:,:,:) * a_ip(:,:,:) 294 323 ! 295 324 END SUBROUTINE ice_var_eqv2glo … … 521 550 a_ip (ji,jj,jl) = a_ip (ji,jj,jl) * zswitch(ji,jj) 522 551 v_ip (ji,jj,jl) = v_ip (ji,jj,jl) * zswitch(ji,jj) 552 v_il (ji,jj,jl) = v_il (ji,jj,jl) * zswitch(ji,jj) 523 553 ! 524 554 END_2D … … 542 572 543 573 544 SUBROUTINE ice_var_zapneg( pdt, pato_i, pv_i, pv_s, psv_i, poa_i, pa_i, pa_ip, pv_ip, p e_s, pe_i )574 SUBROUTINE ice_var_zapneg( pdt, pato_i, pv_i, pv_s, psv_i, poa_i, pa_i, pa_ip, pv_ip, pv_il, pe_s, pe_i ) 545 575 !!------------------------------------------------------------------- 546 576 !! *** ROUTINE ice_var_zapneg *** … … 557 587 REAL(wp), DIMENSION(:,:,:) , INTENT(inout) :: pa_ip ! melt pond fraction 558 588 REAL(wp), DIMENSION(:,:,:) , INTENT(inout) :: pv_ip ! melt pond volume 589 REAL(wp), DIMENSION(:,:,:) , INTENT(inout) :: pv_il ! melt pond lid volume 559 590 REAL(wp), DIMENSION(:,:,:,:), INTENT(inout) :: pe_s ! snw heat content 560 591 REAL(wp), DIMENSION(:,:,:,:), INTENT(inout) :: pe_i ! ice heat content … … 613 644 WHERE( pa_ip (:,:,:) < 0._wp ) pa_ip (:,:,:) = 0._wp 614 645 WHERE( pv_ip (:,:,:) < 0._wp ) pv_ip (:,:,:) = 0._wp ! in theory one should change wfx_pnd(-) and wfx_sum(+) 615 !but it does not change conservation, so keep it this way is ok646 WHERE( pv_il (:,:,:) < 0._wp ) pv_il (:,:,:) = 0._wp ! but it does not change conservation, so keep it this way is ok 616 647 ! 617 648 END SUBROUTINE ice_var_zapneg 618 649 619 650 620 SUBROUTINE ice_var_roundoff( pa_i, pv_i, pv_s, psv_i, poa_i, pa_ip, pv_ip, p e_s, pe_i )651 SUBROUTINE ice_var_roundoff( pa_i, pv_i, pv_s, psv_i, poa_i, pa_ip, pv_ip, pv_il, pe_s, pe_i ) 621 652 !!------------------------------------------------------------------- 622 653 !! *** ROUTINE ice_var_roundoff *** … … 631 662 REAL(wp), DIMENSION(:,:) , INTENT(inout) :: pa_ip ! melt pond fraction 632 663 REAL(wp), DIMENSION(:,:) , INTENT(inout) :: pv_ip ! melt pond volume 664 REAL(wp), DIMENSION(:,:) , INTENT(inout) :: pv_il ! melt pond lid volume 633 665 REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: pe_s ! snw heat content 634 666 REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: pe_i ! ice heat content … … 643 675 WHERE( pe_i (1:npti,:,:) < 0._wp ) pe_i (1:npti,:,:) = 0._wp ! e_i must be >= 0 644 676 WHERE( pe_s (1:npti,:,:) < 0._wp ) pe_s (1:npti,:,:) = 0._wp ! e_s must be >= 0 645 IF( ln_pnd_ H12) THEN677 IF( ln_pnd_LEV ) THEN 646 678 WHERE( pa_ip(1:npti,:) < 0._wp ) pa_ip(1:npti,:) = 0._wp ! a_ip must be >= 0 647 679 WHERE( pv_ip(1:npti,:) < 0._wp ) pv_ip(1:npti,:) = 0._wp ! v_ip must be >= 0 680 IF( ln_pnd_lids ) THEN 681 WHERE( pv_il(1:npti,:) < 0._wp .AND. pv_il(1:npti,:) > -epsi10 ) pv_il(1:npti,:) = 0._wp ! v_il must be >= 0 682 ENDIF 648 683 ENDIF 649 684 ! … … 764 799 !! ** Purpose : converting N-cat ice to jpl ice categories 765 800 !!------------------------------------------------------------------- 766 SUBROUTINE ice_var_itd_1c1c( phti, phts, pati , ph_i, ph_s, pa_i, &767 & ptmi, ptms, ptmsu, psmi, patip, phtip, pt_i, pt_s, pt_su, ps_i, pa_ip, ph_ip)801 SUBROUTINE ice_var_itd_1c1c( phti, phts, pati , ph_i, ph_s, pa_i, & 802 & ptmi, ptms, ptmsu, psmi, patip, phtip, phtil, pt_i, pt_s, pt_su, ps_i, pa_ip, ph_ip, ph_il ) 768 803 !!------------------------------------------------------------------- 769 804 !! ** Purpose : converting 1-cat ice to 1 ice category … … 771 806 REAL(wp), DIMENSION(:), INTENT(in) :: phti, phts, pati ! input ice/snow variables 772 807 REAL(wp), DIMENSION(:), INTENT(inout) :: ph_i, ph_s, pa_i ! output ice/snow variables 773 REAL(wp), DIMENSION(:), INTENT(in) :: ptmi, ptms, ptmsu, psmi, patip, phtip ! input ice/snow temp & sal & ponds774 REAL(wp), DIMENSION(:), INTENT(inout) :: pt_i, pt_s, pt_su, ps_i, pa_ip, ph_ip ! output ice/snow temp & sal & ponds808 REAL(wp), DIMENSION(:), INTENT(in) :: ptmi, ptms, ptmsu, psmi, patip, phtip, phtil ! input ice/snow temp & sal & ponds 809 REAL(wp), DIMENSION(:), INTENT(inout) :: pt_i, pt_s, pt_su, ps_i, pa_ip, ph_ip, ph_il ! output ice/snow temp & sal & ponds 775 810 !!------------------------------------------------------------------- 776 811 ! == thickness and concentration == ! … … 786 821 pa_ip(:) = patip(:) 787 822 ph_ip(:) = phtip(:) 823 ph_il(:) = phtil(:) 788 824 789 825 END SUBROUTINE ice_var_itd_1c1c 790 826 791 SUBROUTINE ice_var_itd_Nc1c( phti, phts, pati , ph_i, ph_s, pa_i, &792 & ptmi, ptms, ptmsu, psmi, patip, phtip, pt_i, pt_s, pt_su, ps_i, pa_ip, ph_ip)827 SUBROUTINE ice_var_itd_Nc1c( phti, phts, pati , ph_i, ph_s, pa_i, & 828 & ptmi, ptms, ptmsu, psmi, patip, phtip, phtil, pt_i, pt_s, pt_su, ps_i, pa_ip, ph_ip, ph_il ) 793 829 !!------------------------------------------------------------------- 794 830 !! ** Purpose : converting N-cat ice to 1 ice category … … 796 832 REAL(wp), DIMENSION(:,:), INTENT(in) :: phti, phts, pati ! input ice/snow variables 797 833 REAL(wp), DIMENSION(:) , INTENT(inout) :: ph_i, ph_s, pa_i ! output ice/snow variables 798 REAL(wp), DIMENSION(:,:), INTENT(in) :: ptmi, ptms, ptmsu, psmi, patip, phtip ! input ice/snow temp & sal & ponds799 REAL(wp), DIMENSION(:) , INTENT(inout) :: pt_i, pt_s, pt_su, ps_i, pa_ip, ph_ip ! output ice/snow temp & sal & ponds834 REAL(wp), DIMENSION(:,:), INTENT(in) :: ptmi, ptms, ptmsu, psmi, patip, phtip, phtil ! input ice/snow temp & sal & ponds 835 REAL(wp), DIMENSION(:) , INTENT(inout) :: pt_i, pt_s, pt_su, ps_i, pa_ip, ph_ip, ph_il ! output ice/snow temp & sal & ponds 800 836 ! 801 837 REAL(wp), ALLOCATABLE, DIMENSION(:) :: z1_ai, z1_vi, z1_vs … … 832 868 ! == ponds == ! 833 869 pa_ip(:) = SUM( patip(:,:), dim=2 ) 834 WHERE( pa_ip(:) /= 0._wp ) ; ph_ip(:) = SUM( phtip(:,:) * patip(:,:), dim=2 ) / pa_ip(:) 835 ELSEWHERE ; ph_ip(:) = 0._wp 870 WHERE( pa_ip(:) /= 0._wp ) 871 ph_ip(:) = SUM( phtip(:,:) * patip(:,:), dim=2 ) / pa_ip(:) 872 ph_il(:) = SUM( phtil(:,:) * patip(:,:), dim=2 ) / pa_ip(:) 873 ELSEWHERE 874 ph_ip(:) = 0._wp 875 ph_il(:) = 0._wp 836 876 END WHERE 837 877 ! … … 840 880 END SUBROUTINE ice_var_itd_Nc1c 841 881 842 SUBROUTINE ice_var_itd_1cMc( phti, phts, pati , ph_i, ph_s, pa_i, &843 & ptmi, ptms, ptmsu, psmi, patip, phtip, pt_i, pt_s, pt_su, ps_i, pa_ip, ph_ip)882 SUBROUTINE ice_var_itd_1cMc( phti, phts, pati , ph_i, ph_s, pa_i, & 883 & ptmi, ptms, ptmsu, psmi, patip, phtip, phtil, pt_i, pt_s, pt_su, ps_i, pa_ip, ph_ip, ph_il ) 844 884 !!------------------------------------------------------------------- 845 885 !! … … 863 903 REAL(wp), DIMENSION(:), INTENT(in) :: phti, phts, pati ! input ice/snow variables 864 904 REAL(wp), DIMENSION(:,:), INTENT(inout) :: ph_i, ph_s, pa_i ! output ice/snow variables 865 REAL(wp), DIMENSION(:) , INTENT(in) :: ptmi, ptms, ptmsu, psmi, patip, phtip ! input ice/snow temp & sal & ponds866 REAL(wp), DIMENSION(:,:), INTENT(inout) :: pt_i, pt_s, pt_su, ps_i, pa_ip, ph_ip ! output ice/snow temp & sal & ponds905 REAL(wp), DIMENSION(:) , INTENT(in) :: ptmi, ptms, ptmsu, psmi, patip, phtip, phtil ! input ice/snow temp & sal & ponds 906 REAL(wp), DIMENSION(:,:), INTENT(inout) :: pt_i, pt_s, pt_su, ps_i, pa_ip, ph_ip, ph_il ! output ice/snow temp & sal & ponds 867 907 ! 868 908 REAL(wp), ALLOCATABLE, DIMENSION(:) :: zfra, z1_hti … … 954 994 pt_su(:,jl) = ptmsu(:) 955 995 ps_i (:,jl) = psmi (:) 956 ps_i (:,jl) = psmi (:)957 996 END DO 958 997 ! … … 975 1014 END WHERE 976 1015 END DO 1016 ! keep the same v_il/v_i ratio for each category 1017 WHERE( ( phti(:) * pati(:) ) /= 0._wp ) ; zfra(:) = ( phtil(:) * patip(:) ) / ( phti(:) * pati(:) ) 1018 ELSEWHERE ; zfra(:) = 0._wp 1019 END WHERE 1020 DO jl = 1, jpl 1021 WHERE( pa_ip(:,jl) /= 0._wp ) ; ph_il(:,jl) = zfra(:) * ( ph_i(:,jl) * pa_i(:,jl) ) / pa_ip(:,jl) 1022 ELSEWHERE ; ph_il(:,jl) = 0._wp 1023 END WHERE 1024 END DO 977 1025 DEALLOCATE( zfra ) 978 1026 ! 979 1027 END SUBROUTINE ice_var_itd_1cMc 980 1028 981 SUBROUTINE ice_var_itd_NcMc( phti, phts, pati , ph_i, ph_s, pa_i, &982 & ptmi, ptms, ptmsu, psmi, patip, phtip, pt_i, pt_s, pt_su, ps_i, pa_ip, ph_ip)1029 SUBROUTINE ice_var_itd_NcMc( phti, phts, pati , ph_i, ph_s, pa_i, & 1030 & ptmi, ptms, ptmsu, psmi, patip, phtip, phtil, pt_i, pt_s, pt_su, ps_i, pa_ip, ph_ip, ph_il ) 983 1031 !!------------------------------------------------------------------- 984 1032 !! … … 995 1043 !! 996 1044 !! 2) Expand the filling to the cat jlmin-1 and jlmax+1 997 1045 !! by removing 25% ice area from jlmin and jlmax (resp.) 998 1046 !! 999 1047 !! 3) Expand the filling to the empty cat between jlmin and jlmax … … 1011 1059 REAL(wp), DIMENSION(:,:), INTENT(in) :: phti, phts, pati ! input ice/snow variables 1012 1060 REAL(wp), DIMENSION(:,:), INTENT(inout) :: ph_i, ph_s, pa_i ! output ice/snow variables 1013 REAL(wp), DIMENSION(:,:), INTENT(in) :: ptmi, ptms, ptmsu, psmi, patip, phtip ! input ice/snow temp & sal & ponds1014 REAL(wp), DIMENSION(:,:), INTENT(inout) :: pt_i, pt_s, pt_su, ps_i, pa_ip, ph_ip ! output ice/snow temp & sal & ponds1061 REAL(wp), DIMENSION(:,:), INTENT(in) :: ptmi, ptms, ptmsu, psmi, patip, phtip, phtil ! input ice/snow temp & sal & ponds 1062 REAL(wp), DIMENSION(:,:), INTENT(inout) :: pt_i, pt_s, pt_su, ps_i, pa_ip, ph_ip, ph_il ! output ice/snow temp & sal & ponds 1015 1063 ! 1016 1064 INTEGER , ALLOCATABLE, DIMENSION(:,:) :: jlfil, jlfil2 … … 1041 1089 pa_ip(:,:) = patip(:,:) 1042 1090 ph_ip(:,:) = phtip(:,:) 1091 ph_il(:,:) = phtil(:,:) 1043 1092 ! ! ---------------------- ! 1044 1093 ELSEIF( icat == 1 ) THEN ! input cat = 1 ! … … 1046 1095 CALL ice_var_itd_1cMc( phti(:,1), phts(:,1), pati (:,1), & 1047 1096 & ph_i(:,:), ph_s(:,:), pa_i (:,:), & 1048 & ptmi(:,1), ptms(:,1), ptmsu(:,1), psmi(:,1), patip(:,1), phtip(:,1), &1049 & pt_i(:,:), pt_s(:,:), pt_su(:,:), ps_i(:,:), pa_ip(:,:), ph_ip(:,:) )1097 & ptmi(:,1), ptms(:,1), ptmsu(:,1), psmi(:,1), patip(:,1), phtip(:,1), phtil(:,1), & 1098 & pt_i(:,:), pt_s(:,:), pt_su(:,:), ps_i(:,:), pa_ip(:,:), ph_ip(:,:), ph_il(:,:) ) 1050 1099 ! ! ---------------------- ! 1051 1100 ELSEIF( jpl == 1 ) THEN ! output cat = 1 ! … … 1053 1102 CALL ice_var_itd_Nc1c( phti(:,:), phts(:,:), pati (:,:), & 1054 1103 & ph_i(:,1), ph_s(:,1), pa_i (:,1), & 1055 & ptmi(:,:), ptms(:,:), ptmsu(:,:), psmi(:,:), patip(:,:), phtip(:,:), &1056 & pt_i(:,1), pt_s(:,1), pt_su(:,1), ps_i(:,1), pa_ip(:,1), ph_ip(:,1) )1104 & ptmi(:,:), ptms(:,:), ptmsu(:,:), psmi(:,:), patip(:,:), phtip(:,:), phtil(:,:), & 1105 & pt_i(:,1), pt_s(:,1), pt_su(:,1), ps_i(:,1), pa_ip(:,1), ph_ip(:,1), ph_il(:,1) ) 1057 1106 ! ! ----------------------- ! 1058 1107 ELSE ! input cat /= output cat ! … … 1196 1245 END WHERE 1197 1246 END DO 1247 ! keep the same v_il/v_i ratio for each category 1248 WHERE( SUM( phti(:,:) * pati(:,:), dim=2 ) /= 0._wp ) 1249 zfra(:) = SUM( phtil(:,:) * patip(:,:), dim=2 ) / SUM( phti(:,:) * pati(:,:), dim=2 ) 1250 ELSEWHERE 1251 zfra(:) = 0._wp 1252 END WHERE 1253 DO jl = 1, jpl 1254 WHERE( pa_ip(:,jl) /= 0._wp ) ; ph_il(:,jl) = zfra(:) * ( ph_i(:,jl) * pa_i(:,jl) ) / pa_ip(:,jl) 1255 ELSEWHERE ; ph_il(:,jl) = 0._wp 1256 END WHERE 1257 END DO 1198 1258 DEALLOCATE( zfra ) 1199 1259 ! … … 1201 1261 ! 1202 1262 END SUBROUTINE ice_var_itd_NcMc 1263 1264 !!------------------------------------------------------------------- 1265 !! INTERFACE ice_var_snwfra 1266 !! 1267 !! ** Purpose : fraction of ice covered by snow 1268 !! 1269 !! ** Method : In absence of proper snow model on top of sea ice, 1270 !! we argue that snow does not cover the whole ice because 1271 !! of wind blowing... 1272 !! 1273 !! ** Arguments : ph_s: snow thickness 1274 !! 1275 !! ** Output : pa_s_fra: fraction of ice covered by snow 1276 !! 1277 !!------------------------------------------------------------------- 1278 SUBROUTINE ice_var_snwfra_3d( ph_s, pa_s_fra ) 1279 REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: ph_s ! snow thickness 1280 REAL(wp), DIMENSION(:,:,:), INTENT( out) :: pa_s_fra ! ice fraction covered by snow 1281 IF ( nn_snwfra == 0 ) THEN ! basic 0 or 1 snow cover 1282 WHERE( ph_s > 0._wp ) ; pa_s_fra = 1._wp 1283 ELSEWHERE ; pa_s_fra = 0._wp 1284 END WHERE 1285 ELSEIF( nn_snwfra == 1 ) THEN ! snow cover depends on hsnow (met-office style) 1286 pa_s_fra = 1._wp - EXP( -0.2_wp * rhos * ph_s ) 1287 ELSEIF( nn_snwfra == 2 ) THEN ! snow cover depends on hsnow (cice style) 1288 pa_s_fra = ph_s / ( ph_s + 0.02_wp ) 1289 ENDIF 1290 END SUBROUTINE ice_var_snwfra_3d 1291 1292 SUBROUTINE ice_var_snwfra_2d( ph_s, pa_s_fra ) 1293 REAL(wp), DIMENSION(:,:), INTENT(in ) :: ph_s ! snow thickness 1294 REAL(wp), DIMENSION(:,:), INTENT( out) :: pa_s_fra ! ice fraction covered by snow 1295 IF ( nn_snwfra == 0 ) THEN ! basic 0 or 1 snow cover 1296 WHERE( ph_s > 0._wp ) ; pa_s_fra = 1._wp 1297 ELSEWHERE ; pa_s_fra = 0._wp 1298 END WHERE 1299 ELSEIF( nn_snwfra == 1 ) THEN ! snow cover depends on hsnow (met-office style) 1300 pa_s_fra = 1._wp - EXP( -0.2_wp * rhos * ph_s ) 1301 ELSEIF( nn_snwfra == 2 ) THEN ! snow cover depends on hsnow (cice style) 1302 pa_s_fra = ph_s / ( ph_s + 0.02_wp ) 1303 ENDIF 1304 END SUBROUTINE ice_var_snwfra_2d 1305 1306 SUBROUTINE ice_var_snwfra_1d( ph_s, pa_s_fra ) 1307 REAL(wp), DIMENSION(:), INTENT(in ) :: ph_s ! snow thickness 1308 REAL(wp), DIMENSION(:), INTENT( out) :: pa_s_fra ! ice fraction covered by snow 1309 IF ( nn_snwfra == 0 ) THEN ! basic 0 or 1 snow cover 1310 WHERE( ph_s > 0._wp ) ; pa_s_fra = 1._wp 1311 ELSEWHERE ; pa_s_fra = 0._wp 1312 END WHERE 1313 ELSEIF( nn_snwfra == 1 ) THEN ! snow cover depends on hsnow (met-office style) 1314 pa_s_fra = 1._wp - EXP( -0.2_wp * rhos * ph_s ) 1315 ELSEIF( nn_snwfra == 2 ) THEN ! snow cover depends on hsnow (cice style) 1316 pa_s_fra = ph_s / ( ph_s + 0.02_wp ) 1317 ENDIF 1318 END SUBROUTINE ice_var_snwfra_1d 1319 1320 !!-------------------------------------------------------------------------- 1321 !! INTERFACE ice_var_snwblow 1322 !! 1323 !! ** Purpose : Compute distribution of precip over the ice 1324 !! 1325 !! Snow accumulation in one thermodynamic time step 1326 !! snowfall is partitionned between leads and ice. 1327 !! If snow fall was uniform, a fraction (1-at_i) would fall into leads 1328 !! but because of the winds, more snow falls on leads than on sea ice 1329 !! and a greater fraction (1-at_i)^beta of the total mass of snow 1330 !! (beta < 1) falls in leads. 1331 !! In reality, beta depends on wind speed, 1332 !! and should decrease with increasing wind speed but here, it is 1333 !! considered as a constant. an average value is 0.66 1334 !!-------------------------------------------------------------------------- 1335 !!gm I think it can be usefull to set this as a FUNCTION, not a SUBROUTINE.... 1336 SUBROUTINE ice_var_snwblow_2d( pin, pout ) 1337 REAL(wp), DIMENSION(:,:), INTENT(in ) :: pin ! previous fraction lead ( 1. - a_i_b ) 1338 REAL(wp), DIMENSION(:,:), INTENT(inout) :: pout 1339 pout = ( 1._wp - ( pin )**rn_snwblow ) 1340 END SUBROUTINE ice_var_snwblow_2d 1341 1342 SUBROUTINE ice_var_snwblow_1d( pin, pout ) 1343 REAL(wp), DIMENSION(:), INTENT(in ) :: pin 1344 REAL(wp), DIMENSION(:), INTENT(inout) :: pout 1345 pout = ( 1._wp - ( pin )**rn_snwblow ) 1346 END SUBROUTINE ice_var_snwblow_1d 1203 1347 1204 1348 #else -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/ICE/icewri.F90
r13295 r13998 114 114 IF( iom_use('icehpnd' ) ) CALL iom_put( 'icehpnd', hm_ip * zmsk00 ) ! melt pond depth 115 115 IF( iom_use('icevpnd' ) ) CALL iom_put( 'icevpnd', vt_ip * zmsk00 ) ! melt pond total volume per unit area 116 IF( iom_use('icehlid' ) ) CALL iom_put( 'icehlid', hm_il * zmsk00 ) ! melt pond lid depth 117 IF( iom_use('icevlid' ) ) CALL iom_put( 'icevlid', vt_il * zmsk00 ) ! melt pond lid total volume per unit area 116 118 ! salt 117 119 IF( iom_use('icesalt' ) ) CALL iom_put( 'icesalt', sm_i * zmsk00 + zmiss_val * ( 1._wp - zmsk00 ) ) ! mean ice salinity … … 158 160 IF( iom_use('icebrv_cat' ) ) CALL iom_put( 'icebrv_cat' , bv_i * 100. * zmsk00l + zmiss_val * ( 1._wp - zmsk00l ) ) ! brine volume 159 161 IF( iom_use('iceapnd_cat' ) ) CALL iom_put( 'iceapnd_cat' , a_ip * zmsk00l ) ! melt pond frac for categories 160 IF( iom_use('icehpnd_cat' ) ) CALL iom_put( 'icehpnd_cat' , h_ip * zmsk00l + zmiss_val * ( 1._wp - zmsk00l ) ) ! melt pond frac for categories 162 IF( iom_use('icehpnd_cat' ) ) CALL iom_put( 'icehpnd_cat' , h_ip * zmsk00l + zmiss_val * ( 1._wp - zmsk00l ) ) ! melt pond thickness for categories 163 IF( iom_use('icehlid_cat' ) ) CALL iom_put( 'icehlid_cat' , h_il * zmsk00l + zmiss_val * ( 1._wp - zmsk00l ) ) ! melt pond lid thickness for categories 161 164 IF( iom_use('iceafpnd_cat') ) CALL iom_put( 'iceafpnd_cat', a_ip_frac * zmsk00l ) ! melt pond frac for categories 165 IF( iom_use('iceaepnd_cat') ) CALL iom_put( 'iceaepnd_cat', a_ip_eff * zmsk00l ) ! melt pond effective frac for categories 162 166 IF( iom_use('icealb_cat' ) ) CALL iom_put( 'icealb_cat' , alb_ice * zmsk00l + zmiss_val * ( 1._wp - zmsk00l ) ) ! ice albedo for categories 163 167 … … 173 177 IF( iom_use('dmisum') ) CALL iom_put( 'dmisum', - wfx_sum ) ! Sea-ice mass change through surface melting 174 178 IF( iom_use('dmibom') ) CALL iom_put( 'dmibom', - wfx_bom ) ! Sea-ice mass change through bottom melting 179 IF( iom_use('dmilam') ) CALL iom_put( 'dmilam', - wfx_lam ) ! Sea-ice mass change through lateral melting 175 180 IF( iom_use('dmtsub') ) CALL iom_put( 'dmtsub', - wfx_sub ) ! Sea-ice mass change through evaporation and sublimation 176 181 IF( iom_use('dmssub') ) CALL iom_put( 'dmssub', - wfx_snw_sub ) ! Snow mass change through sublimation -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/NST/agrif_ice_interp.F90
r13286 r13998 176 176 ptab(i1:i2,j1:j2,jm+5) = a_ip(i1:i2,j1:j2,jl) 177 177 ptab(i1:i2,j1:j2,jm+6) = v_ip(i1:i2,j1:j2,jl) 178 ptab(i1:i2,j1:j2,jm+7) = t_su(i1:i2,j1:j2,jl) 179 jm = jm + 8 178 ptab(i1:i2,j1:j2,jm+7) = v_il(i1:i2,j1:j2,jl) 179 ptab(i1:i2,j1:j2,jm+8) = t_su(i1:i2,j1:j2,jl) 180 jm = jm + 9 180 181 DO jk = 1, nlay_s 181 182 ptab(i1:i2,j1:j2,jm) = e_s(i1:i2,j1:j2,jk,jl) ; jm = jm + 1 … … 206 207 a_ip(ji,jj,jl) = ptab(ji,jj,jm+5) * tmask(ji,jj,1) 207 208 v_ip(ji,jj,jl) = ptab(ji,jj,jm+6) * tmask(ji,jj,1) 208 t_su(ji,jj,jl) = ptab(ji,jj,jm+7) * tmask(ji,jj,1) 209 v_il(ji,jj,jl) = ptab(ji,jj,jm+7) * tmask(ji,jj,1) 210 t_su(ji,jj,jl) = ptab(ji,jj,jm+8) * tmask(ji,jj,1) 209 211 END DO 210 212 END DO 211 jm = jm + 8213 jm = jm + 9 212 214 ! 213 215 DO jk = 1, nlay_s … … 239 241 ! ztab(:,:,jm+5) = a_ip(:,:,jl) 240 242 ! ztab(:,:,jm+6) = v_ip(:,:,jl) 241 ! ztab(:,:,jm+7) = t_su(:,:,jl) 242 ! jm = jm + 8 243 ! ztab(:,:,jm+7) = v_il(:,:,jl) 244 ! ztab(:,:,jm+8) = t_su(:,:,jl) 245 ! jm = jm + 9 243 246 ! DO jk = 1, nlay_s 244 247 ! ztab(:,:,jm) = e_s(:,:,jk,jl) … … 345 348 ! a_ip(ji,jj,jl) = ztab(ji,jj,jm+5) * tmask(ji,jj,1) 346 349 ! v_ip(ji,jj,jl) = ztab(ji,jj,jm+6) * tmask(ji,jj,1) 347 ! t_su(ji,jj,jl) = ztab(ji,jj,jm+7) * tmask(ji,jj,1) 350 ! v_il(ji,jj,jl) = ztab(ji,jj,jm+7) * tmask(ji,jj,1) 351 ! t_su(ji,jj,jl) = ztab(ji,jj,jm+8) * tmask(ji,jj,1) 348 352 ! END DO 349 353 ! END DO 350 ! jm = jm + 8354 ! jm = jm + 9 351 355 ! ! 352 356 ! DO jk = 1, nlay_s -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/NST/agrif_ice_update.F90
r13216 r13998 109 109 ptab(i1:i2,j1:j2,jm+5) = a_ip(i1:i2,j1:j2,jl) 110 110 ptab(i1:i2,j1:j2,jm+6) = v_ip(i1:i2,j1:j2,jl) 111 ptab(i1:i2,j1:j2,jm+7) = t_su(i1:i2,j1:j2,jl) 112 jm = jm + 8 111 ptab(i1:i2,j1:j2,jm+7) = v_il(i1:i2,j1:j2,jl) 112 ptab(i1:i2,j1:j2,jm+8) = t_su(i1:i2,j1:j2,jl) 113 jm = jm + 9 113 114 DO jk = 1, nlay_s 114 115 ptab(i1:i2,j1:j2,jm) = e_s(i1:i2,j1:j2,jk,jl) ; jm = jm + 1 … … 138 139 a_ip(ji,jj,jl) = ptab(ji,jj,jm+5) * tmask(ji,jj,1) 139 140 v_ip(ji,jj,jl) = ptab(ji,jj,jm+6) * tmask(ji,jj,1) 140 t_su(ji,jj,jl) = ptab(ji,jj,jm+7) * tmask(ji,jj,1) 141 v_il(ji,jj,jl) = ptab(ji,jj,jm+7) * tmask(ji,jj,1) 142 t_su(ji,jj,jl) = ptab(ji,jj,jm+8) * tmask(ji,jj,1) 141 143 ENDIF 142 144 END DO 143 145 END DO 144 jm = jm + 8146 jm = jm + 9 145 147 ! 146 148 DO jk = 1, nlay_s -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/NST/agrif_user.F90
r13678 r13998 407 407 use_sign_north = .TRUE. 408 408 sign_north = -1. 409 CALL Agrif_Bc_variable(ub2b_interp_id,calledweight=1.,procname=interpub2b) ! must be called before unb_id to define ubdy 410 CALL Agrif_Bc_variable(vb2b_interp_id,calledweight=1.,procname=interpvb2b) ! must be called before vnb_id to define vbdy 409 411 CALL Agrif_Bc_variable( unb_id,calledweight=1.,procname=interpunb ) 410 412 CALL Agrif_Bc_variable( vnb_id,calledweight=1.,procname=interpvnb ) 411 CALL Agrif_Bc_variable(ub2b_interp_id,calledweight=1.,procname=interpub2b)412 CALL Agrif_Bc_variable(vb2b_interp_id,calledweight=1.,procname=interpvb2b)413 413 use_sign_north = .FALSE. 414 414 ubdy(:,:) = 0._wp … … 665 665 ind2 = nn_hls + 2 + nbghostcells_x 666 666 ind3 = nn_hls + 2 + nbghostcells_y_s 667 ipl = jpl*( 8+nlay_s+nlay_i)667 ipl = jpl*(9+nlay_s+nlay_i) 668 668 CALL agrif_declare_variable((/2,2,0/),(/ind2,ind3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,ipl/),tra_ice_id) 669 669 CALL agrif_declare_variable((/1,2/) ,(/ind2-1,ind3/),(/'x','y' /),(/1,1 /),(/jpi,jpj /), u_ice_id) -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/BDY/bdy_oce.F90
r12377 r13998 63 63 REAL(wp), POINTER, DIMENSION(:,:) :: aip !: now ice pond concentration 64 64 REAL(wp), POINTER, DIMENSION(:,:) :: hip !: now ice pond depth 65 REAL(wp), POINTER, DIMENSION(:,:) :: hil !: now ice pond lid depth 65 66 #if defined key_top 66 67 CHARACTER(LEN=20) :: cn_obc !: type of boundary condition to apply … … 115 116 REAL(wp), DIMENSION(jp_bdy) :: rice_apnd !: pond conc. of incoming sea ice 116 117 REAL(wp), DIMENSION(jp_bdy) :: rice_hpnd !: pond thick. of incoming sea ice 118 REAL(wp), DIMENSION(jp_bdy) :: rice_hlid !: pond lid thick. of incoming sea ice 117 119 ! 118 120 !!---------------------------------------------------------------------- -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/BDY/bdydta.F90
r13237 r13998 43 43 PUBLIC bdy_dta_init ! routine called by nemogcm.F90 44 44 45 INTEGER , PARAMETER :: jpbdyfld = 1 6! maximum number of files to read45 INTEGER , PARAMETER :: jpbdyfld = 17 ! maximum number of files to read 46 46 INTEGER , PARAMETER :: jp_bdyssh = 1 ! 47 47 INTEGER , PARAMETER :: jp_bdyu2d = 2 ! … … 60 60 INTEGER , PARAMETER :: jp_bdyaip = 15 ! 61 61 INTEGER , PARAMETER :: jp_bdyhip = 16 ! 62 INTEGER , PARAMETER :: jp_bdyhil = 17 ! 62 63 #if ! defined key_si3 63 64 INTEGER , PARAMETER :: jpl = 1 … … 187 188 dta_bdy(jbdy)%aip(ib,jl) = a_ip(ii,ij,jl) * tmask(ii,ij,1) 188 189 dta_bdy(jbdy)%hip(ib,jl) = h_ip(ii,ij,jl) * tmask(ii,ij,1) 190 dta_bdy(jbdy)%hil(ib,jl) = h_il(ii,ij,jl) * tmask(ii,ij,1) 189 191 END DO 190 192 END DO … … 289 291 IF( TRIM(bf_alias(jp_bdytsu)%clrootname) == 'NOT USED' ) bf_alias(jp_bdytsu)%fnow(:,1,:) = rice_tem (jbdy) 290 292 IF( TRIM(bf_alias(jp_bdys_i)%clrootname) == 'NOT USED' ) bf_alias(jp_bdys_i)%fnow(:,1,:) = rice_sal (jbdy) 291 IF( TRIM(bf_alias(jp_bdyaip)%clrootname) == 'NOT USED' ) bf_alias(jp_bdyaip)%fnow(:,1,:) = rice_apnd(jbdy) * &! rice_apnd is the pond fraction292 & bf_alias(jp_bdya_i)%fnow(:,1,:) ! ( a_ip = rice_apnd *a_i )293 IF( TRIM(bf_alias(jp_bdyaip)%clrootname) == 'NOT USED' ) & ! rice_apnd is the pond fraction 294 & bf_alias(jp_bdyaip)%fnow(:,1,:) = rice_apnd(jbdy) * bf_alias(jp_bdya_i)%fnow(:,1,:) ! ( a_ip = rice_apnd*a_i ) 293 295 IF( TRIM(bf_alias(jp_bdyhip)%clrootname) == 'NOT USED' ) bf_alias(jp_bdyhip)%fnow(:,1,:) = rice_hpnd(jbdy) 294 296 IF( TRIM(bf_alias(jp_bdyhil)%clrootname) == 'NOT USED' ) bf_alias(jp_bdyhil)%fnow(:,1,:) = rice_hlid(jbdy) 297 295 298 ! if T_i is read and not T_su, set T_su = T_i 296 299 IF( TRIM(bf_alias(jp_bdyt_i)%clrootname) /= 'NOT USED' .AND. TRIM(bf_alias(jp_bdytsu)%clrootname) == 'NOT USED' ) & … … 316 319 bf_alias(jp_bdyaip)%fnow(:,1,:) = 0._wp 317 320 bf_alias(jp_bdyhip)%fnow(:,1,:) = 0._wp 321 bf_alias(jp_bdyhil)%fnow(:,1,:) = 0._wp 322 ENDIF 323 IF ( .NOT.ln_pnd_lids ) THEN 324 bf_alias(jp_bdyhil)%fnow(:,1,:) = 0._wp 318 325 ENDIF 319 326 … … 321 328 ipl = SIZE(bf_alias(jp_bdya_i)%fnow, 3) 322 329 IF( ipl /= jpl ) THEN ! ice: convert N-cat fields (input) into jpl-cat (output) 323 CALL ice_var_itd( bf_alias(jp_bdyh_i)%fnow(:,1,:), bf_alias(jp_bdyh_s)%fnow(:,1,:), bf_alias(jp_bdya_i)%fnow(:,1,:), & 324 & dta_alias%h_i , dta_alias%h_s , dta_alias%a_i , & 325 & bf_alias(jp_bdyt_i)%fnow(:,1,:), bf_alias(jp_bdyt_s)%fnow(:,1,:), & 326 & bf_alias(jp_bdytsu)%fnow(:,1,:), bf_alias(jp_bdys_i)%fnow(:,1,:), & 327 & bf_alias(jp_bdyaip)%fnow(:,1,:), bf_alias(jp_bdyhip)%fnow(:,1,:), &328 & dta_alias%t_i , dta_alias%t_s , & 329 & dta_alias%tsu , dta_alias%s_i , & 330 & dta_alias%aip , dta_alias%hip )330 CALL ice_var_itd( bf_alias(jp_bdyh_i)%fnow(:,1,:), bf_alias(jp_bdyh_s)%fnow(:,1,:), bf_alias(jp_bdya_i)%fnow(:,1,:), & ! in 331 & dta_alias%h_i , dta_alias%h_s , dta_alias%a_i , & ! out 332 & bf_alias(jp_bdyt_i)%fnow(:,1,:), bf_alias(jp_bdyt_s)%fnow(:,1,:), & ! in (optional) 333 & bf_alias(jp_bdytsu)%fnow(:,1,:), bf_alias(jp_bdys_i)%fnow(:,1,:), & ! in - 334 & bf_alias(jp_bdyaip)%fnow(:,1,:), bf_alias(jp_bdyhip)%fnow(:,1,:), bf_alias(jp_bdyhil)%fnow(:,1,:), & ! in - 335 & dta_alias%t_i , dta_alias%t_s , & ! out - 336 & dta_alias%tsu , dta_alias%s_i , & ! out - 337 & dta_alias%aip , dta_alias%hip , dta_alias%hil ) ! out - 331 338 ENDIF 332 339 ENDIF … … 374 381 ! ! =F => baroclinic velocities in 3D boundary data 375 382 LOGICAL :: ln_zinterp ! =T => requires a vertical interpolation of the bdydta 376 REAL(wp) :: rn_ice_tem, rn_ice_sal, rn_ice_age, rn_ice_apnd, rn_ice_hpnd 383 REAL(wp) :: rn_ice_tem, rn_ice_sal, rn_ice_age, rn_ice_apnd, rn_ice_hpnd, rn_ice_hlid 377 384 INTEGER :: ipk,ipl ! 378 385 INTEGER :: idvar ! variable ID … … 387 394 TYPE(FLD_N), DIMENSION(1), TARGET :: bn_tem, bn_sal, bn_u3d, bn_v3d ! must be an array to be used with fld_fill 388 395 TYPE(FLD_N), DIMENSION(1), TARGET :: bn_ssh, bn_u2d, bn_v2d ! informations about the fields to be read 389 TYPE(FLD_N), DIMENSION(1), TARGET :: bn_a_i, bn_h_i, bn_h_s, bn_t_i, bn_t_s, bn_tsu, bn_s_i, bn_aip, bn_hip 396 TYPE(FLD_N), DIMENSION(1), TARGET :: bn_a_i, bn_h_i, bn_h_s, bn_t_i, bn_t_s, bn_tsu, bn_s_i, bn_aip, bn_hip, bn_hil 390 397 TYPE(FLD_N), DIMENSION(:), POINTER :: bn_alias ! must be an array to be used with fld_fill 391 398 TYPE(FLD ), DIMENSION(:), POINTER :: bf_alias 392 399 ! 393 NAMELIST/nambdy_dta/ cn_dir, bn_tem, bn_sal, bn_u3d, bn_v3d, bn_ssh, bn_u2d, bn_v2d 394 NAMELIST/nambdy_dta/ bn_a_i, bn_h_i, bn_h_s, bn_t_i, bn_t_s, bn_tsu, bn_s_i, bn_aip, bn_hip395 NAMELIST/nambdy_dta/ rn_ice_tem, rn_ice_sal, rn_ice_age, rn_ice_apnd, rn_ice_hpnd396 NAMELIST/nambdy_dta/ln_full_vel, ln_zinterp400 NAMELIST/nambdy_dta/ cn_dir, bn_tem, bn_sal, bn_u3d, bn_v3d, bn_ssh, bn_u2d, bn_v2d, & 401 & bn_a_i, bn_h_i, bn_h_s, bn_t_i, bn_t_s, bn_tsu, bn_s_i, bn_aip, bn_hip, bn_hil, & 402 & rn_ice_tem, rn_ice_sal, rn_ice_age, rn_ice_apnd, rn_ice_hpnd, rn_ice_hlid, & 403 & ln_full_vel, ln_zinterp 397 404 !!--------------------------------------------------------------------------- 398 405 ! … … 464 471 #if defined key_si3 465 472 IF( .NOT.ln_pnd ) THEN 466 rn_ice_apnd = 0. ; rn_ice_hpnd = 0. 467 CALL ctl_warn( 'rn_ice_apnd & rn_ice_hpnd = 0 when no ponds' ) 473 rn_ice_apnd = 0. ; rn_ice_hpnd = 0. ; rn_ice_hlid = 0. 474 CALL ctl_warn( 'rn_ice_apnd & rn_ice_hpnd = 0 & rn_ice_hlid = 0 when no ponds' ) 475 ENDIF 476 IF( .NOT.ln_pnd_lids ) THEN 477 rn_ice_hlid = 0. 468 478 ENDIF 469 479 #endif … … 475 485 rice_apnd(jbdy) = rn_ice_apnd 476 486 rice_hpnd(jbdy) = rn_ice_hpnd 477 487 rice_hlid(jbdy) = rn_ice_hlid 488 478 489 479 490 DO jfld = 1, jpbdyfld … … 576 587 IF( jfld == jp_bdya_i .OR. jfld == jp_bdyh_i .OR. jfld == jp_bdyh_s .OR. & 577 588 & jfld == jp_bdyt_i .OR. jfld == jp_bdyt_s .OR. jfld == jp_bdytsu .OR. & 578 & jfld == jp_bdys_i .OR. jfld == jp_bdyaip .OR. jfld == jp_bdyhip 589 & jfld == jp_bdys_i .OR. jfld == jp_bdyaip .OR. jfld == jp_bdyhip .OR. jfld == jp_bdyhil ) THEN 579 590 igrd = 1 ! T point 580 591 ipk = ipl ! jpl-cat data … … 627 638 bf_alias => bf(jp_bdyhip,jbdy:jbdy) ! alias for hip structure of bdy number jbdy 628 639 bn_alias => bn_hip ! alias for hip structure of nambdy_dta 640 ENDIF 641 IF( jfld == jp_bdyhil ) THEN 642 cl3 = 'hil' 643 bf_alias => bf(jp_bdyhil,jbdy:jbdy) ! alias for hil structure of bdy number jbdy 644 bn_alias => bn_hil ! alias for hil structure of nambdy_dta 629 645 ENDIF 630 646 … … 696 712 ENDIF 697 713 ENDIF 714 IF( jfld == jp_bdyhil ) THEN 715 IF( ipk == jpl ) THEN ; dta_bdy(jbdy)%hil => bf_alias(1)%fnow(:,1,:) 716 ELSE ; ALLOCATE( dta_bdy(jbdy)%hil(iszdim,jpl) ) 717 ENDIF 718 ENDIF 698 719 ENDIF 699 720 -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/BDY/bdyice.F90
r13226 r13998 61 61 !!---------------------------------------------------------------------- 62 62 ! controls 63 IF( ln_timing ) CALL timing_start('bdy_ice_thd') ! timing 64 IF( ln_icediachk ) CALL ice_cons_hsm(0,'bdy_ice_thd', rdiag_v, rdiag_s, rdiag_t, rdiag_fv, rdiag_fs, rdiag_ft) ! conservation 65 IF( ln_icediachk ) CALL ice_cons2D (0,'bdy_ice_thd', diag_v, diag_s, diag_t, diag_fv, diag_fs, diag_ft) ! conservation 63 IF( ln_timing ) CALL timing_start('bdy_ice_thd') ! timing 66 64 ! 67 65 CALL ice_var_glo2eqv … … 94 92 IF( ANY(llsend1) .OR. ANY(llrecv1) ) THEN ! if need to send/recv in at least one direction 95 93 ! exchange 3d arrays 96 CALL lbc_lnk_multi( 'bdyice', a_i , 'T', 1.0_wp, h_i , 'T', 1.0_wp, h_s , 'T', 1.0_wp, oa_i, 'T', 1.0_wp&97 & , a_ip, 'T', 1.0_wp, v_ip, 'T', 1.0_wp, s_i , 'T', 1.0_wp, t_su, 'T', 1.0_wp &98 & , v_i , 'T', 1.0_wp, v_s , 'T', 1.0_wp, sv_i, 'T', 1.0_wp&99 & , kfillmode=jpfillnothing ,lsend=llsend1, lrecv=llrecv1)94 CALL lbc_lnk_multi('bdyice', a_i , 'T', 1._wp, h_i , 'T', 1._wp, h_s , 'T', 1._wp, oa_i, 'T', 1._wp & 95 & , s_i , 'T', 1._wp, t_su, 'T', 1._wp, v_i , 'T', 1._wp, v_s , 'T', 1._wp, sv_i, 'T', 1._wp & 96 & , a_ip, 'T', 1._wp, v_ip, 'T', 1._wp, v_il, 'T', 1._wp & 97 & , kfillmode=jpfillnothing ,lsend=llsend1, lrecv=llrecv1 ) 100 98 ! exchange 4d arrays : third dimension = 1 and then third dimension = jpk 101 CALL lbc_lnk_multi( 'bdyice', t_s , 'T', 1.0_wp, e_s , 'T', 1.0_wp, kfillmode=jpfillnothing ,lsend=llsend1, lrecv=llrecv1 )102 CALL lbc_lnk_multi( 'bdyice', t_i , 'T', 1.0_wp, e_i , 'T', 1.0_wp, kfillmode=jpfillnothing ,lsend=llsend1, lrecv=llrecv1 )99 CALL lbc_lnk_multi('bdyice', t_s , 'T', 1._wp, e_s , 'T', 1._wp, kfillmode=jpfillnothing ,lsend=llsend1, lrecv=llrecv1 ) 100 CALL lbc_lnk_multi('bdyice', t_i , 'T', 1._wp, e_i , 'T', 1._wp, kfillmode=jpfillnothing ,lsend=llsend1, lrecv=llrecv1 ) 103 101 END IF 104 102 END DO ! ir … … 110 108 ! 111 109 ! controls 112 IF( ln_icectl ) CALL ice_prt ( kt, iiceprt, jiceprt, 1, ' - ice thermo bdy - ' ) ! prints 113 IF( ln_icediachk ) CALL ice_cons_hsm(1,'bdy_ice_thd', rdiag_v, rdiag_s, rdiag_t, rdiag_fv, rdiag_fs, rdiag_ft) ! conservation 114 IF( ln_icediachk ) CALL ice_cons2D (1,'bdy_ice_thd', diag_v, diag_s, diag_t, diag_fv, diag_fs, diag_ft) ! conservation 115 IF( ln_timing ) CALL timing_stop ('bdy_ice_thd') ! timing 110 IF( ln_icectl ) CALL ice_prt ( kt, iiceprt, jiceprt, 1, ' - ice thermo bdy - ' ) ! prints 111 IF( ln_timing ) CALL timing_stop ('bdy_ice_thd') ! timing 116 112 ! 117 113 END SUBROUTINE bdy_ice … … 163 159 a_ip(ji,jj, jl) = ( a_ip(ji,jj, jl) * zwgt1 + dta%aip(i_bdy,jl) * zwgt ) * tmask(ji,jj,1) ! Ice pond concentration 164 160 h_ip(ji,jj, jl) = ( h_ip(ji,jj, jl) * zwgt1 + dta%hip(i_bdy,jl) * zwgt ) * tmask(ji,jj,1) ! Ice pond depth 161 h_il(ji,jj, jl) = ( h_il(ji,jj, jl) * zwgt1 + dta%hil(i_bdy,jl) * zwgt ) * tmask(ji,jj,1) ! Ice pond lid depth 165 162 ! 166 163 sz_i(ji,jj,:,jl) = s_i(ji,jj,jl) … … 170 167 a_ip(ji,jj,jl) = 0._wp 171 168 h_ip(ji,jj,jl) = 0._wp 169 h_il(ji,jj,jl) = 0._wp 170 ENDIF 171 172 IF( .NOT.ln_pnd_lids ) THEN 173 h_il(ji,jj,jl) = 0._wp 172 174 ENDIF 173 175 ! … … 231 233 a_ip(ji,jj, jl) = a_ip(ib,jb, jl) 232 234 h_ip(ji,jj, jl) = h_ip(ib,jb, jl) 235 h_il(ji,jj, jl) = h_il(ib,jb, jl) 233 236 ! 234 237 sz_i(ji,jj,:,jl) = sz_i(ib,jb,:,jl) … … 265 268 ! 266 269 ! melt ponds 267 IF( a_i(ji,jj,jl) > epsi10 ) THEN268 a_ip_frac(ji,jj,jl) = a_ip(ji,jj,jl) / a_i (ji,jj,jl)269 ELSE270 a_ip_frac(ji,jj,jl) = 0._wp271 ENDIF272 270 v_ip(ji,jj,jl) = h_ip(ji,jj,jl) * a_ip(ji,jj,jl) 271 v_il(ji,jj,jl) = h_il(ji,jj,jl) * a_ip(ji,jj,jl) 273 272 ! 274 273 ELSE ! no ice at the boundary … … 278 277 h_s (ji,jj, jl) = 0._wp 279 278 oa_i(ji,jj, jl) = 0._wp 280 a_ip(ji,jj, jl) = 0._wp281 v_ip(ji,jj, jl) = 0._wp282 279 t_su(ji,jj, jl) = rt0 283 280 t_s (ji,jj,:,jl) = rt0 284 281 t_i (ji,jj,:,jl) = rt0 285 282 286 a_ip_frac(ji,jj,jl) = 0._wp 287 h_ip (ji,jj,jl) = 0._wp 288 a_ip (ji,jj,jl) = 0._wp 289 v_ip (ji,jj,jl) = 0._wp 283 a_ip(ji,jj,jl) = 0._wp 284 h_ip(ji,jj,jl) = 0._wp 285 h_il(ji,jj,jl) = 0._wp 290 286 291 287 IF( nn_icesal == 1 ) THEN ! if constant salinity … … 303 299 e_s (ji,jj,:,jl) = 0._wp 304 300 e_i (ji,jj,:,jl) = 0._wp 301 v_ip(ji,jj, jl) = 0._wp 302 v_il(ji,jj, jl) = 0._wp 305 303 306 304 ENDIF -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/BDY/bdyini.F90
r13286 r13998 786 786 ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 787 787 ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 788 IF( mig (ii) > 2 .AND. mig(ii) < jpiglo-2 .AND. mjg(ij) > 2 .AND. mjg(ij) < jpjglo-2 ) THEN788 IF( mig0(ii) > 2 .AND. mig0(ii) < Ni0glo-2 .AND. mjg0(ij) > 2 .AND. mjg0(ij) < Nj0glo-2 ) THEN 789 789 WRITE(ctmp1,*) ' Orlanski is not safe when the open boundaries are on the interior of the computational domain' 790 790 CALL ctl_stop( ctmp1 ) … … 1071 1071 SUBROUTINE bdy_read_seg( kb_bdy, knblendta ) 1072 1072 !!---------------------------------------------------------------------- 1073 !! *** ROUTINE bdy_ coords_seg ***1073 !! *** ROUTINE bdy_read_seg *** 1074 1074 !! 1075 1075 !! ** Purpose : build bdy coordinates with segments defined in namelist … … 1111 1111 CASE( 'N' ) 1112 1112 IF( nbdyind == -1 ) THEN ! Automatic boundary definition: if nbdysegX = -1 1113 nbdyind = jpjglo - 2 ! set boundary to whole side of model domain.1113 nbdyind = Nj0glo - 2 ! set boundary to whole side of model domain. 1114 1114 nbdybeg = 2 1115 nbdyend = jpiglo - 11115 nbdyend = Ni0glo - 1 1116 1116 ENDIF 1117 1117 nbdysegn = nbdysegn + 1 1118 1118 npckgn(nbdysegn) = kb_bdy ! Save bdy package number 1119 jpjnob(nbdysegn) = nbdyind 1119 jpjnob(nbdysegn) = nbdyind 1120 1120 jpindt(nbdysegn) = nbdybeg 1121 1121 jpinft(nbdysegn) = nbdyend … … 1125 1125 nbdyind = 2 ! set boundary to whole side of model domain. 1126 1126 nbdybeg = 2 1127 nbdyend = jpiglo - 11127 nbdyend = Ni0glo - 1 1128 1128 ENDIF 1129 1129 nbdysegs = nbdysegs + 1 … … 1135 1135 CASE( 'E' ) 1136 1136 IF( nbdyind == -1 ) THEN ! Automatic boundary definition: if nbdysegX = -1 1137 nbdyind = jpiglo - 2 ! set boundary to whole side of model domain.1137 nbdyind = Ni0glo - 2 ! set boundary to whole side of model domain. 1138 1138 nbdybeg = 2 1139 nbdyend = jpjglo - 11139 nbdyend = Nj0glo - 1 1140 1140 ENDIF 1141 1141 nbdysege = nbdysege + 1 … … 1149 1149 nbdyind = 2 ! set boundary to whole side of model domain. 1150 1150 nbdybeg = 2 1151 nbdyend = jpjglo - 11151 nbdyend = Nj0glo - 1 1152 1152 ENDIF 1153 1153 nbdysegw = nbdysegw + 1 … … 1192 1192 IF(lwp) WRITE(numout,*) 'Number of north segments : ', nbdysegn 1193 1193 IF(lwp) WRITE(numout,*) 'Number of south segments : ', nbdysegs 1194 ! 1194 1195 ! 1. Check bounds 1195 1196 !---------------- 1196 1197 DO ib = 1, nbdysegn 1197 1198 IF (lwp) WRITE(numout,*) '**check north seg bounds pckg: ', npckgn(ib) 1198 IF ((jpjnob(ib).ge. jpjglo-1).or.&1199 IF ((jpjnob(ib).ge.Nj0glo-1).or.& 1199 1200 &(jpjnob(ib).le.1)) CALL ctl_stop( 'nbdyind out of domain' ) 1200 1201 IF (jpindt(ib).ge.jpinft(ib)) CALL ctl_stop( 'Bdy start index is greater than end index' ) 1201 1202 IF (jpindt(ib).lt.1 ) CALL ctl_stop( 'Start index out of domain' ) 1202 IF (jpinft(ib).gt. jpiglo) CALL ctl_stop( 'End index out of domain' )1203 IF (jpinft(ib).gt.Ni0glo) CALL ctl_stop( 'End index out of domain' ) 1203 1204 END DO 1204 1205 ! 1205 1206 DO ib = 1, nbdysegs 1206 1207 IF (lwp) WRITE(numout,*) '**check south seg bounds pckg: ', npckgs(ib) 1207 IF ((jpjsob(ib).ge. jpjglo-1).or.&1208 IF ((jpjsob(ib).ge.Nj0glo-1).or.& 1208 1209 &(jpjsob(ib).le.1)) CALL ctl_stop( 'nbdyind out of domain' ) 1209 1210 IF (jpisdt(ib).ge.jpisft(ib)) CALL ctl_stop( 'Bdy start index is greater than end index' ) 1210 1211 IF (jpisdt(ib).lt.1 ) CALL ctl_stop( 'Start index out of domain' ) 1211 IF (jpisft(ib).gt. jpiglo) CALL ctl_stop( 'End index out of domain' )1212 IF (jpisft(ib).gt.Ni0glo) CALL ctl_stop( 'End index out of domain' ) 1212 1213 END DO 1213 1214 ! 1214 1215 DO ib = 1, nbdysege 1215 1216 IF (lwp) WRITE(numout,*) '**check east seg bounds pckg: ', npckge(ib) 1216 IF ((jpieob(ib).ge. jpiglo-1).or.&1217 IF ((jpieob(ib).ge.Ni0glo-1).or.& 1217 1218 &(jpieob(ib).le.1)) CALL ctl_stop( 'nbdyind out of domain' ) 1218 1219 IF (jpjedt(ib).ge.jpjeft(ib)) CALL ctl_stop( 'Bdy start index is greater than end index' ) 1219 1220 IF (jpjedt(ib).lt.1 ) CALL ctl_stop( 'Start index out of domain' ) 1220 IF (jpjeft(ib).gt. jpjglo) CALL ctl_stop( 'End index out of domain' )1221 IF (jpjeft(ib).gt.Nj0glo) CALL ctl_stop( 'End index out of domain' ) 1221 1222 END DO 1222 1223 ! 1223 1224 DO ib = 1, nbdysegw 1224 1225 IF (lwp) WRITE(numout,*) '**check west seg bounds pckg: ', npckgw(ib) 1225 IF ((jpiwob(ib).ge. jpiglo-1).or.&1226 IF ((jpiwob(ib).ge.Ni0glo-1).or.& 1226 1227 &(jpiwob(ib).le.1)) CALL ctl_stop( 'nbdyind out of domain' ) 1227 1228 IF (jpjwdt(ib).ge.jpjwft(ib)) CALL ctl_stop( 'Bdy start index is greater than end index' ) 1228 1229 IF (jpjwdt(ib).lt.1 ) CALL ctl_stop( 'Start index out of domain' ) 1229 IF (jpjwft(ib).gt. jpjglo) CALL ctl_stop( 'End index out of domain' )1230 IF (jpjwft(ib).gt.Nj0glo) CALL ctl_stop( 'End index out of domain' ) 1230 1231 ENDDO 1231 !1232 1232 ! 1233 1233 ! 2. Look for segment crossings … … 1378 1378 DO ji = 1, jpi 1379 1379 DO jj = 1, jpj 1380 IF( mig (ji) == jpiwob(ib) .AND. mjg(jj) == jpjwdt(ib) ) ztestmask(1) = tmask(ji,jj,1)1381 IF( mig (ji) == jpiwob(ib) .AND. mjg(jj) == jpjwft(ib) ) ztestmask(2) = tmask(ji,jj,1)1380 IF( mig0(ji) == jpiwob(ib) .AND. mjg0(jj) == jpjwdt(ib) ) ztestmask(1) = tmask(ji,jj,1) 1381 IF( mig0(ji) == jpiwob(ib) .AND. mjg0(jj) == jpjwft(ib) ) ztestmask(2) = tmask(ji,jj,1) 1382 1382 END DO 1383 1383 END DO … … 1414 1414 DO ji = 1, jpi 1415 1415 DO jj = 1, jpj 1416 IF( mig (ji) == jpieob(ib)+1 .AND. mjg(jj) == jpjedt(ib) ) ztestmask(1) = tmask(ji,jj,1)1417 IF( mig (ji) == jpieob(ib)+1 .AND. mjg(jj) == jpjeft(ib) ) ztestmask(2) = tmask(ji,jj,1)1416 IF( mig0(ji) == jpieob(ib)+1 .AND. mjg0(jj) == jpjedt(ib) ) ztestmask(1) = tmask(ji,jj,1) 1417 IF( mig0(ji) == jpieob(ib)+1 .AND. mjg0(jj) == jpjeft(ib) ) ztestmask(2) = tmask(ji,jj,1) 1418 1418 END DO 1419 1419 END DO … … 1450 1450 DO ji = 1, jpi 1451 1451 DO jj = 1, jpj 1452 IF( mjg (jj) == jpjsob(ib) .AND. mig(ji) == jpisdt(ib) ) ztestmask(1) = tmask(ji,jj,1)1453 IF( mjg (jj) == jpjsob(ib) .AND. mig(ji) == jpisft(ib) ) ztestmask(2) = tmask(ji,jj,1)1452 IF( mjg0(jj) == jpjsob(ib) .AND. mig0(ji) == jpisdt(ib) ) ztestmask(1) = tmask(ji,jj,1) 1453 IF( mjg0(jj) == jpjsob(ib) .AND. mig0(ji) == jpisft(ib) ) ztestmask(2) = tmask(ji,jj,1) 1454 1454 END DO 1455 1455 END DO … … 1472 1472 DO ji = 1, jpi 1473 1473 DO jj = 1, jpj 1474 IF( mjg (jj) == jpjnob(ib)+1 .AND. mig(ji) == jpindt(ib) ) ztestmask(1) = tmask(ji,jj,1)1475 IF( mjg (jj) == jpjnob(ib)+1 .AND. mig(ji) == jpinft(ib) ) ztestmask(2) = tmask(ji,jj,1)1474 IF( mjg0(jj) == jpjnob(ib)+1 .AND. mig0(ji) == jpindt(ib) ) ztestmask(1) = tmask(ji,jj,1) 1475 IF( mjg0(jj) == jpjnob(ib)+1 .AND. mig0(ji) == jpinft(ib) ) ztestmask(2) = tmask(ji,jj,1) 1476 1476 END DO 1477 1477 END DO … … 1526 1526 DO ij = jpjedt(iseg), jpjeft(iseg) 1527 1527 icount = icount + 1 1528 nbidta(icount, igrd, ib_bdy) = jpieob(iseg) + 2 - ir 1529 nbjdta(icount, igrd, ib_bdy) = ij 1528 nbidta(icount, igrd, ib_bdy) = jpieob(iseg) + 2 - ir + nn_hls 1529 nbjdta(icount, igrd, ib_bdy) = ij + nn_hls 1530 1530 nbrdta(icount, igrd, ib_bdy) = ir 1531 1531 ENDDO … … 1538 1538 DO ij = jpjedt(iseg), jpjeft(iseg) 1539 1539 icount = icount + 1 1540 nbidta(icount, igrd, ib_bdy) = jpieob(iseg) + 1 - ir 1541 nbjdta(icount, igrd, ib_bdy) = ij 1540 nbidta(icount, igrd, ib_bdy) = jpieob(iseg) + 1 - ir + nn_hls 1541 nbjdta(icount, igrd, ib_bdy) = ij + nn_hls 1542 1542 nbrdta(icount, igrd, ib_bdy) = ir 1543 1543 ENDDO … … 1551 1551 DO ij = jpjedt(iseg), jpjeft(iseg) 1552 1552 icount = icount + 1 1553 nbidta(icount, igrd, ib_bdy) = jpieob(iseg) + 2 - ir 1554 nbjdta(icount, igrd, ib_bdy) = ij 1553 nbidta(icount, igrd, ib_bdy) = jpieob(iseg) + 2 - ir + nn_hls 1554 nbjdta(icount, igrd, ib_bdy) = ij + nn_hls 1555 1555 nbrdta(icount, igrd, ib_bdy) = ir 1556 1556 ENDDO … … 1571 1571 DO ij = jpjwdt(iseg), jpjwft(iseg) 1572 1572 icount = icount + 1 1573 nbidta(icount, igrd, ib_bdy) = jpiwob(iseg) + ir - 1 1574 nbjdta(icount, igrd, ib_bdy) = ij 1573 nbidta(icount, igrd, ib_bdy) = jpiwob(iseg) + ir - 1 + nn_hls 1574 nbjdta(icount, igrd, ib_bdy) = ij + nn_hls 1575 1575 nbrdta(icount, igrd, ib_bdy) = ir 1576 1576 ENDDO … … 1583 1583 DO ij = jpjwdt(iseg), jpjwft(iseg) 1584 1584 icount = icount + 1 1585 nbidta(icount, igrd, ib_bdy) = jpiwob(iseg) + ir - 1 1586 nbjdta(icount, igrd, ib_bdy) = ij 1585 nbidta(icount, igrd, ib_bdy) = jpiwob(iseg) + ir - 1 + nn_hls 1586 nbjdta(icount, igrd, ib_bdy) = ij + nn_hls 1587 1587 nbrdta(icount, igrd, ib_bdy) = ir 1588 1588 ENDDO … … 1596 1596 DO ij = jpjwdt(iseg), jpjwft(iseg) 1597 1597 icount = icount + 1 1598 nbidta(icount, igrd, ib_bdy) = jpiwob(iseg) + ir - 1 1599 nbjdta(icount, igrd, ib_bdy) = ij 1598 nbidta(icount, igrd, ib_bdy) = jpiwob(iseg) + ir - 1 + nn_hls 1599 nbjdta(icount, igrd, ib_bdy) = ij + nn_hls 1600 1600 nbrdta(icount, igrd, ib_bdy) = ir 1601 1601 ENDDO … … 1616 1616 DO ii = jpindt(iseg), jpinft(iseg) 1617 1617 icount = icount + 1 1618 nbidta(icount, igrd, ib_bdy) = ii 1619 nbjdta(icount, igrd, ib_bdy) = jpjnob(iseg) + 2 - ir 1618 nbidta(icount, igrd, ib_bdy) = ii + nn_hls 1619 nbjdta(icount, igrd, ib_bdy) = jpjnob(iseg) + 2 - ir + nn_hls 1620 1620 nbrdta(icount, igrd, ib_bdy) = ir 1621 1621 ENDDO … … 1629 1629 DO ii = jpindt(iseg), jpinft(iseg) 1630 1630 icount = icount + 1 1631 nbidta(icount, igrd, ib_bdy) = ii 1632 nbjdta(icount, igrd, ib_bdy) = jpjnob(iseg) + 2 - ir 1631 nbidta(icount, igrd, ib_bdy) = ii + nn_hls 1632 nbjdta(icount, igrd, ib_bdy) = jpjnob(iseg) + 2 - ir + nn_hls 1633 1633 nbrdta(icount, igrd, ib_bdy) = ir 1634 1634 ENDDO … … 1643 1643 DO ii = jpindt(iseg), jpinft(iseg) 1644 1644 icount = icount + 1 1645 nbidta(icount, igrd, ib_bdy) = ii 1646 nbjdta(icount, igrd, ib_bdy) = jpjnob(iseg) + 1 - ir 1645 nbidta(icount, igrd, ib_bdy) = ii + nn_hls 1646 nbjdta(icount, igrd, ib_bdy) = jpjnob(iseg) + 1 - ir + nn_hls 1647 1647 nbrdta(icount, igrd, ib_bdy) = ir 1648 1648 ENDDO … … 1661 1661 DO ii = jpisdt(iseg), jpisft(iseg) 1662 1662 icount = icount + 1 1663 nbidta(icount, igrd, ib_bdy) = ii 1664 nbjdta(icount, igrd, ib_bdy) = jpjsob(iseg) + ir - 1 1663 nbidta(icount, igrd, ib_bdy) = ii + nn_hls 1664 nbjdta(icount, igrd, ib_bdy) = jpjsob(iseg) + ir - 1 + nn_hls 1665 1665 nbrdta(icount, igrd, ib_bdy) = ir 1666 1666 ENDDO … … 1674 1674 DO ii = jpisdt(iseg), jpisft(iseg) 1675 1675 icount = icount + 1 1676 nbidta(icount, igrd, ib_bdy) = ii 1677 nbjdta(icount, igrd, ib_bdy) = jpjsob(iseg) + ir - 1 1676 nbidta(icount, igrd, ib_bdy) = ii + nn_hls 1677 nbjdta(icount, igrd, ib_bdy) = jpjsob(iseg) + ir - 1 + nn_hls 1678 1678 nbrdta(icount, igrd, ib_bdy) = ir 1679 1679 ENDDO … … 1688 1688 DO ii = jpisdt(iseg), jpisft(iseg) 1689 1689 icount = icount + 1 1690 nbidta(icount, igrd, ib_bdy) = ii 1691 nbjdta(icount, igrd, ib_bdy) = jpjsob(iseg) + ir - 1 1690 nbidta(icount, igrd, ib_bdy) = ii + nn_hls 1691 nbjdta(icount, igrd, ib_bdy) = jpjsob(iseg) + ir - 1 + nn_hls 1692 1692 nbrdta(icount, igrd, ib_bdy) = ir 1693 1693 ENDDO -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/BDY/bdylib.F90
r13226 r13998 44 44 !!---------------------------------------------------------------------- 45 45 TYPE(OBC_INDEX), INTENT(in) :: idx ! OBC indices 46 REAL(wp), DIMENSION(:,:), 46 REAL(wp), DIMENSION(:,:), POINTER, INTENT(in) :: dta ! OBC external data 47 47 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: phia ! tracer trend 48 48 !! … … 73 73 !!---------------------------------------------------------------------- 74 74 TYPE(OBC_INDEX), INTENT(in) :: idx ! OBC indices 75 REAL(wp), DIMENSION(:,:), 75 REAL(wp), DIMENSION(:,:), POINTER, INTENT(in) :: dta ! OBC external data 76 76 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: phia ! tracer trend 77 77 !! … … 100 100 !! 101 101 !!---------------------------------------------------------------------- 102 TYPE(OBC_INDEX), INTENT(in) :: idx ! OBC indices103 REAL(wp), DIMENSION(:,:), INTENT(in) :: dta ! OBC external data104 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: phib ! before tracer field105 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: phia ! tracer trend106 LOGICAL , OPTIONAL, INTENT(in) :: lrim0 ! indicate if rim 0 is treated107 LOGICAL , INTENT(in) :: ll_npo ! switch for NPO version102 TYPE(OBC_INDEX), INTENT(in ) :: idx ! OBC indices 103 REAL(wp), DIMENSION(:,:), POINTER, INTENT(in ) :: dta ! OBC external data 104 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: phib ! before tracer field 105 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: phia ! tracer trend 106 LOGICAL , INTENT(in ) :: lrim0 ! indicate if rim 0 is treated 107 LOGICAL , INTENT(in ) :: ll_npo ! switch for NPO version 108 108 !! 109 109 INTEGER :: igrd ! grid index … … 128 128 !! References: Marchesiello, McWilliams and Shchepetkin, Ocean Modelling vol. 3 (2001) 129 129 !!---------------------------------------------------------------------- 130 TYPE(OBC_INDEX), INTENT(in ) :: idx ! BDY indices131 INTEGER , INTENT(in ) :: igrd ! grid index132 REAL(wp), DIMENSION(:,:), INTENT(in ) :: phib ! model before 2D field133 REAL(wp), DIMENSION(:,:), INTENT(inout) :: phia ! model after 2D field (to be updated)134 REAL(wp), DIMENSION(: ), INTENT(in ) :: phi_ext ! external forcing data135 LOGICAL , OPTIONAL,INTENT(in ) :: lrim0 ! indicate if rim 0 is treated136 LOGICAL , INTENT(in ) :: ll_npo ! switch for NPO version130 TYPE(OBC_INDEX), INTENT(in ) :: idx ! BDY indices 131 INTEGER , INTENT(in ) :: igrd ! grid index 132 REAL(wp), DIMENSION(:,:), INTENT(in ) :: phib ! model before 2D field 133 REAL(wp), DIMENSION(:,:), INTENT(inout) :: phia ! model after 2D field (to be updated) 134 REAL(wp), DIMENSION(: ), POINTER, INTENT(in ) :: phi_ext ! external forcing data 135 LOGICAL , INTENT(in ) :: lrim0 ! indicate if rim 0 is treated 136 LOGICAL , INTENT(in ) :: ll_npo ! switch for NPO version 137 137 ! 138 138 INTEGER :: jb ! dummy loop indices … … 188 188 END SELECT 189 189 ! 190 IF( PRESENT(lrim0) ) THEN 191 IF( lrim0 ) THEN ; ibeg = 1 ; iend = idx%nblenrim0(igrd) ! rim 0 192 ELSE ; ibeg = idx%nblenrim0(igrd)+1 ; iend = idx%nblenrim(igrd) ! rim 1 193 END IF 194 ELSE ; ibeg = 1 ; iend = idx%nblenrim(igrd) ! both 195 END IF 190 IF( lrim0 ) THEN ; ibeg = 1 ; iend = idx%nblenrim0(igrd) ! rim 0 191 ELSE ; ibeg = idx%nblenrim0(igrd)+1 ; iend = idx%nblenrim(igrd) ! rim 1 192 ENDIF 196 193 ! 197 194 DO jb = ibeg, iend … … 275 272 & - (1.-zsign_ups) * zry * ( phib(iijp1,ijjp1) - phib(ii ,ij ) ) & 276 273 & + zwgt * ( phi_ext(jb) - phib(ii,ij) ) ) / ( 1. + zrx ) 277 end 274 endif 278 275 phia(ii,ij) = phia(ii,ij) * zmask(ii,ij) 279 276 END DO … … 293 290 !! References: Marchesiello, McWilliams and Shchepetkin, Ocean Modelling vol. 3 (2001) 294 291 !!---------------------------------------------------------------------- 295 TYPE(OBC_INDEX), INTENT(in ) :: idx ! BDY indices296 INTEGER , INTENT(in ) :: igrd ! grid index297 REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: phib ! model before 3D field298 REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: phia ! model after 3D field (to be updated)299 REAL(wp), DIMENSION(:,: ), INTENT(in ) :: phi_ext ! external forcing data300 LOGICAL , OPTIONAL,INTENT(in ) :: lrim0 ! indicate if rim 0 is treated301 LOGICAL , INTENT(in ) :: ll_npo ! switch for NPO version292 TYPE(OBC_INDEX), INTENT(in ) :: idx ! BDY indices 293 INTEGER , INTENT(in ) :: igrd ! grid index 294 REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: phib ! model before 3D field 295 REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: phia ! model after 3D field (to be updated) 296 REAL(wp), DIMENSION(:,: ), POINTER, INTENT(in ) :: phi_ext ! external forcing data 297 LOGICAL , INTENT(in ) :: lrim0 ! indicate if rim 0 is treated 298 LOGICAL , INTENT(in ) :: ll_npo ! switch for NPO version 302 299 ! 303 300 INTEGER :: jb, jk ! dummy loop indices … … 353 350 END SELECT 354 351 ! 355 IF( PRESENT(lrim0) ) THEN 356 IF( lrim0 ) THEN ; ibeg = 1 ; iend = idx%nblenrim0(igrd) ! rim 0 357 ELSE ; ibeg = idx%nblenrim0(igrd)+1 ; iend = idx%nblenrim(igrd) ! rim 1 358 END IF 359 ELSE ; ibeg = 1 ; iend = idx%nblenrim(igrd) ! both 360 END IF 352 IF( lrim0 ) THEN ; ibeg = 1 ; iend = idx%nblenrim0(igrd) ! rim 0 353 ELSE ; ibeg = idx%nblenrim0(igrd)+1 ; iend = idx%nblenrim(igrd) ! rim 1 354 ENDIF 361 355 ! 362 356 DO jk = 1, jpk … … 441 435 & - (1.-zsign_ups) * zry * ( phib(iijp1,ijjp1,jk) - phib(ii ,ij ,jk) ) & 442 436 & + zwgt * ( phi_ext(jb,jk) - phib(ii,ij,jk) ) ) / ( 1. + zrx ) 443 end 437 endif 444 438 phia(ii,ij,jk) = phia(ii,ij,jk) * zmask(ii,ij,jk) 445 439 END DO … … 466 460 REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: phia ! model after 3D field (to be updated), must be masked 467 461 TYPE(OBC_INDEX), INTENT(in ) :: idx ! OBC indices 468 LOGICAL , OPTIONAL,INTENT(in ) :: lrim0 ! indicate if rim 0 is treated462 LOGICAL , INTENT(in ) :: lrim0 ! indicate if rim 0 is treated 469 463 !! 470 464 REAL(wp) :: zweight … … 486 480 END SELECT 487 481 ! 488 IF( PRESENT(lrim0) ) THEN 489 IF( lrim0 ) THEN ; ibeg = 1 ; iend = idx%nblenrim0(igrd) ! rim 0 490 ELSE ; ibeg = idx%nblenrim0(igrd)+1 ; iend = idx%nblenrim(igrd) ! rim 1 491 END IF 492 ELSE ; ibeg = 1 ; iend = idx%nblenrim(igrd) ! both 493 END IF 482 IF( lrim0 ) THEN ; ibeg = 1 ; iend = idx%nblenrim0(igrd) ! rim 0 483 ELSE ; ibeg = idx%nblenrim0(igrd)+1 ; iend = idx%nblenrim(igrd) ! rim 1 484 ENDIF 494 485 ! 495 486 DO ib = ibeg, iend -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/BDY/bdytra.F90
r13226 r13998 61 61 IF( ir == 0 ) THEN ; llrim0 = .TRUE. 62 62 ELSE ; llrim0 = .FALSE. 63 END 63 ENDIF 64 64 DO ib_bdy=1, nb_bdy 65 65 ! … … 69 69 DO jn = 1, jpts 70 70 ! 71 SELECT CASE( TRIM(cn_tra(ib_bdy)) )71 SELECT CASE( cn_tra(ib_bdy) ) 72 72 CASE('none' ) ; CYCLE 73 73 CASE('frs' ) ! treat the whole boundary at once 74 IF( ir == 0 ) CALL bdy_frs ( idx_bdy(ib_bdy),pts(:,:,:,jn,Kaa), zdta(jn)%tra )74 IF( ir == 0 ) CALL bdy_frs ( idx_bdy(ib_bdy), pts(:,:,:,jn,Kaa), zdta(jn)%tra ) 75 75 CASE('specified' ) ! treat the whole rim at once 76 IF( ir == 0 ) CALL bdy_spe ( idx_bdy(ib_bdy),pts(:,:,:,jn,Kaa), zdta(jn)%tra )77 CASE('neumann' ) ; CALL bdy_nmn ( idx_bdy(ib_bdy), igrd , pts(:,:,:,jn,Kaa), llrim0 ) ! tsa masked78 CASE('orlanski' ) ; CALL bdy_orl ( idx_bdy(ib_bdy), pts(:,:,:,jn,Kbb), pts(:,:,:,jn,Kaa), &79 & zdta(jn)%tra, llrim0, ll_npo=.false. )80 CASE('orlanski_npo') ; CALL bdy_orl ( idx_bdy(ib_bdy), pts(:,:,:,jn,Kbb), pts(:,:,:,jn,Kaa), &81 & zdta(jn)%tra, llrim0, ll_npo=.true. )82 CASE('runoff' ) ; CALL bdy_rnf ( idx_bdy(ib_bdy), pts(:,:,:,jn,Kaa), jn, llrim0 )76 IF( ir == 0 ) CALL bdy_spe ( idx_bdy(ib_bdy), pts(:,:,:,jn,Kaa), zdta(jn)%tra ) 77 CASE('neumann' ) ; CALL bdy_nmn ( idx_bdy(ib_bdy), igrd , pts(:,:,:,jn,Kaa), llrim0 ) ! tsa masked 78 CASE('orlanski' ) ; CALL bdy_orl ( idx_bdy(ib_bdy), pts(:,:,:,jn,Kbb), pts(:,:,:,jn,Kaa), zdta(jn)%tra, & 79 & llrim0, ll_npo=.FALSE. ) 80 CASE('orlanski_npo') ; CALL bdy_orl ( idx_bdy(ib_bdy), pts(:,:,:,jn,Kbb), pts(:,:,:,jn,Kaa), zdta(jn)%tra, & 81 & llrim0, ll_npo=.TRUE. ) 82 CASE('runoff' ) ; CALL bdy_rnf ( idx_bdy(ib_bdy), pts(:,:,:,jn,Kaa), jn, llrim0 ) 83 83 CASE DEFAULT ; CALL ctl_stop( 'bdy_tra : unrecognised option for open boundaries for T and S' ) 84 84 END SELECT … … 88 88 ! 89 89 IF( nn_hls > 1 .AND. ir == 1 ) CYCLE ! at least 2 halos will be corrected -> no need to correct rim 1 before rim 0 90 IF( nn_hls == 1 ) THEN ; llsend1(:) = .false. ; llrecv1(:) = .false. ; END 90 IF( nn_hls == 1 ) THEN ; llsend1(:) = .false. ; llrecv1(:) = .false. ; ENDIF 91 91 DO ib_bdy=1, nb_bdy 92 SELECT CASE( TRIM(cn_tra(ib_bdy)) )92 SELECT CASE( cn_tra(ib_bdy) ) 93 93 CASE('neumann','runoff') 94 94 llsend1(:) = llsend1(:) .OR. lsend_bdyint(ib_bdy,1,:,ir) ! possibly every direction, T points … … 101 101 IF( ANY(llsend1) .OR. ANY(llrecv1) ) THEN ! if need to send/recv in at least one direction 102 102 CALL lbc_lnk( 'bdytra', pts(:,:,:,jn,Kaa), 'T', 1.0_wp, kfillmode=jpfillnothing ,lsend=llsend1, lrecv=llrecv1 ) 103 END 103 ENDIF 104 104 ! 105 105 END DO ! ir … … 135 135 pt(ii,ij,1:jpkm1) = 0.1 * tmask(ii,ij,1:jpkm1) 136 136 END DO 137 END 137 ENDIF 138 138 ! 139 139 END SUBROUTINE bdy_rnf -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/C1D/dtauvd.F90
r13295 r13998 158 158 ENDIF 159 159 ! 160 DO_2D( 1, 1, 1, 1 ) 160 DO_2D( 1, 1, 1, 1 ) ! vertical interpolation of U & V current: 161 161 DO jk = 1, jpk 162 162 zl = gdept(ji,jj,jk,Kmm) -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/CRS/crsfld.F90
r13295 r13998 146 146 CALL iom_put( "voces" , zs_crs ) ! vS 147 147 148 IF( iom_use( " eken") ) THEN ! kinetic energy148 IF( iom_use( "ke") ) THEN ! kinetic energy 149 149 z3d(:,:,jk) = 0._wp 150 150 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) … … 159 159 ! 160 160 CALL crs_dom_ope( z3d, 'VOL', 'T', tmask, zt_crs, p_e12=e1e2t, p_e3=ze3t, psgn=1.0_wp ) 161 CALL iom_put( " eken", zt_crs )161 CALL iom_put( "ke", zt_crs ) 162 162 ENDIF 163 163 ! Horizontal divergence ( following OCE/DYN/divhor.F90 ) -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/DIA/diaar5.F90
r13295 r13998 144 144 IF( ln_linssh ) THEN 145 145 IF( ln_isfcav ) THEN 146 DO ji = 1, jpi 147 DO jj = 1, jpj 148 iks = mikt(ji,jj) 149 zbotpres(ji,jj) = zbotpres(ji,jj) + ssh(ji,jj,Kmm) * zrhd(ji,jj,iks) + riceload(ji,jj) 150 END DO 151 END DO 146 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 147 iks = mikt(ji,jj) 148 zbotpres(ji,jj) = zbotpres(ji,jj) + ssh(ji,jj,Kmm) * zrhd(ji,jj,iks) + riceload(ji,jj) 149 END_2D 152 150 ELSE 153 151 zbotpres(:,:) = zbotpres(:,:) + ssh(:,:,Kmm) * zrhd(:,:,1) … … 385 383 zvol0 (:,:) = 0._wp 386 384 thick0(:,:) = 0._wp 387 DO_3D( 1, 1, 1, 1, 1, jpkm1 ) 385 DO_3D( 1, 1, 1, 1, 1, jpkm1 ) ! interpolation of salinity at the last ocean level (i.e. the partial step) 388 386 idep = tmask(ji,jj,jk) * e3t_0(ji,jj,jk) 389 387 zvol0 (ji,jj) = zvol0 (ji,jj) + idep * e1e2t(ji,jj) … … 403 401 sn0(:,:,:) = sn0(:,:,:) * tmask(:,:,:) 404 402 IF( ln_zps ) THEN ! z-coord. partial steps 405 DO_2D( 1, 1, 1, 1 ) 403 DO_2D( 1, 1, 1, 1 ) ! interpolation of salinity at the last ocean level (i.e. the partial step) 406 404 ik = mbkt(ji,jj) 407 405 IF( ik > 1 ) THEN -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/DIA/diacfl.F90
r13295 r13998 56 56 INTEGER , DIMENSION(3) :: iloc_u , iloc_v , iloc_w , iloc ! workspace 57 57 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zCu_cfl, zCv_cfl, zCw_cfl ! workspace 58 LOGICAL , DIMENSION(jpi,jpj,jpk) :: llmsk 58 59 !!---------------------------------------------------------------------- 59 60 ! 60 61 IF( ln_timing ) CALL timing_start('dia_cfl') 61 62 ! 62 DO_3D( 1, 1, 1, 1, 1, jpk ) 63 llmsk( 1:Nis1,:,:) = .FALSE. ! exclude halos from the checked region 64 llmsk(Nie1: jpi,:,:) = .FALSE. 65 llmsk(:, 1:Njs1,:) = .FALSE. 66 llmsk(:,Nje1: jpj,:) = .FALSE. 67 ! 68 DO_3D( 0, 0, 0, 0, 1, jpk ) ! calculate Courant numbers 63 69 zCu_cfl(ji,jj,jk) = ABS( uu(ji,jj,jk,Kmm) ) * rDt / e1u (ji,jj) ! for i-direction 64 70 zCv_cfl(ji,jj,jk) = ABS( vv(ji,jj,jk,Kmm) ) * rDt / e2v (ji,jj) ! for j-direction 65 zCw_cfl(ji,jj,jk) = ABS( ww(ji,jj,jk) ) * rDt / e3w(ji,jj,jk,Kmm) ! for k-direction71 zCw_cfl(ji,jj,jk) = ABS( ww(ji,jj,jk) ) * rDt / e3w(ji,jj,jk,Kmm) ! for k-direction 66 72 END_3D 67 73 ! 68 74 ! write outputs 69 IF( iom_use('cfl_cu') ) CALL iom_put( 'cfl_cu', MAXVAL( zCu_cfl, dim=3 ) ) 70 IF( iom_use('cfl_cv') ) CALL iom_put( 'cfl_cv', MAXVAL( zCv_cfl, dim=3 ) ) 71 IF( iom_use('cfl_cw') ) CALL iom_put( 'cfl_cw', MAXVAL( zCw_cfl, dim=3 ) ) 75 IF( iom_use('cfl_cu') ) THEN 76 llmsk(Nis0:Nie0,Njs0:Nje0,:) = umask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp ! define only the inner domain 77 CALL iom_put( 'cfl_cu', MAXVAL( zCu_cfl, mask = llmsk, dim=3 ) ) 78 ENDIF 79 IF( iom_use('cfl_cv') ) THEN 80 llmsk(Nis0:Nie0,Njs0:Nje0,:) = vmask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp ! define only the inner domain 81 CALL iom_put( 'cfl_cv', MAXVAL( zCv_cfl, mask = llmsk, dim=3 ) ) 82 ENDIF 83 IF( iom_use('cfl_cw') ) THEN 84 llmsk(Nis0:Nie0,Njs0:Nje0,:) = wmask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp ! define only the inner domain 85 CALL iom_put( 'cfl_cw', MAXVAL( zCw_cfl, mask = llmsk, dim=3 ) ) 86 ENDIF 72 87 73 88 ! ! calculate maximum values and locations 74 IF( lk_mpp ) THEN 75 CALL mpp_maxloc( 'diacfl', zCu_cfl, umask, zCu_max, iloc_u ) 76 CALL mpp_maxloc( 'diacfl', zCv_cfl, vmask, zCv_max, iloc_v ) 77 CALL mpp_maxloc( 'diacfl', zCw_cfl, wmask, zCw_max, iloc_w ) 78 ELSE 79 iloc = MAXLOC( ABS( zcu_cfl(:,:,:) ) ) 80 iloc_u(1) = iloc(1) + nimpp - 1 81 iloc_u(2) = iloc(2) + njmpp - 1 82 iloc_u(3) = iloc(3) 83 zCu_max = zCu_cfl(iloc(1),iloc(2),iloc(3)) 84 ! 85 iloc = MAXLOC( ABS( zcv_cfl(:,:,:) ) ) 86 iloc_v(1) = iloc(1) + nimpp - 1 87 iloc_v(2) = iloc(2) + njmpp - 1 88 iloc_v(3) = iloc(3) 89 zCv_max = zCv_cfl(iloc(1),iloc(2),iloc(3)) 90 ! 91 iloc = MAXLOC( ABS( zcw_cfl(:,:,:) ) ) 92 iloc_w(1) = iloc(1) + nimpp - 1 93 iloc_w(2) = iloc(2) + njmpp - 1 94 iloc_w(3) = iloc(3) 95 zCw_max = zCw_cfl(iloc(1),iloc(2),iloc(3)) 96 ENDIF 89 llmsk(Nis0:Nie0,Njs0:Nje0,:) = umask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp ! define only the inner domain 90 CALL mpp_maxloc( 'diacfl', zCu_cfl, llmsk, zCu_max, iloc_u ) 91 llmsk(Nis0:Nie0,Njs0:Nje0,:) = vmask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp ! define only the inner domain 92 CALL mpp_maxloc( 'diacfl', zCv_cfl, llmsk, zCv_max, iloc_v ) 93 llmsk(Nis0:Nie0,Njs0:Nje0,:) = wmask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp ! define only the inner domain 94 CALL mpp_maxloc( 'diacfl', zCw_cfl, llmsk, zCw_max, iloc_w ) 97 95 ! 98 ! ! write out to file 99 IF( lwp ) THEN 96 IF( lwp ) THEN ! write out to file 100 97 WRITE(numcfl,FMT='(2x,i6,3x,a6,4x,f7.4,1x,i4,1x,i4,1x,i4)') kt, 'Max Cu', zCu_max, iloc_u(1), iloc_u(2), iloc_u(3) 101 98 WRITE(numcfl,FMT='(11x, a6,4x,f7.4,1x,i4,1x,i4,1x,i4)') 'Max Cv', zCv_max, iloc_v(1), iloc_v(2), iloc_v(3) -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/DIA/diahth.F90
r13295 r13998 170 170 ! MLD: rho = rho(1) + zrho1 ! 171 171 ! ------------------------------------------------------------- ! 172 DO_3DS( 1, 1, 1, 1, jpkm1, 2, -1 ) 172 DO_3DS( 1, 1, 1, 1, jpkm1, 2, -1 ) ! loop from bottom to 2 173 173 ! 174 174 zzdep = gdepw(ji,jj,jk,Kmm) … … 207 207 ! depth of temperature inversion ! 208 208 ! ------------------------------------------------------------- ! 209 DO_3DS( 1, 1, 1, 1, jpkm1, nlb10, -1 ) 209 DO_3DS( 1, 1, 1, 1, jpkm1, nlb10, -1 ) ! loop from bottom to nlb10 210 210 ! 211 211 zzdep = gdepw(ji,jj,jk,Kmm) * tmask(ji,jj,1) … … 305 305 ! --------------------------------------- ! 306 306 iktem(:,:) = 1 307 DO_3D( 1, 1, 1, 1, 1, jpkm1 ) 307 DO_3D( 1, 1, 1, 1, 1, jpkm1 ) ! beware temperature is not always decreasing with depth => loop from top to bottom 308 308 zztmp = ts(ji,jj,jk,jp_tem,Kmm) 309 309 IF( zztmp >= ptem ) iktem(ji,jj) = jk -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/DIA/diaptr.F90
r13295 r13998 36 36 END INTERFACE 37 37 38 PUBLIC ptr_sj ! call by tra_ldf & tra_adv routines39 PUBLIC ptr_sjk !40 PUBLIC dia_ptr_init ! call in memogcm41 38 PUBLIC dia_ptr ! call in step module 42 39 PUBLIC dia_ptr_hst ! called from tra_ldf/tra_adv routines 43 40 44 ! !!** namelist namptr **45 41 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: hstr_adv, hstr_ldf, hstr_eiv !: Heat/Salt TRansports(adv, diff, Bolus.) 46 42 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: hstr_ove, hstr_btr, hstr_vtr !: heat Salt TRansports(overturn, baro, merional) 47 43 48 LOGICAL , PUBLIC :: l_diaptr !: tracers trend flag (set from namelist in trdini) 49 INTEGER, PARAMETER, PUBLIC :: nptr = 5 ! (glo, atl, pac, ind, ipc) 44 LOGICAL, PUBLIC :: l_diaptr !: tracers trend flag 50 45 51 46 REAL(wp) :: rc_sv = 1.e-6_wp ! conversion from m3/s to Sverdrup … … 59 54 REAL(wp), TARGET, ALLOCATABLE, SAVE, DIMENSION(:,:) :: p_fval2d 60 55 61 LOGICAL :: ll_init = .TRUE. !: tracers trend flag (set from namelist in trdini)56 LOGICAL :: ll_init = .TRUE. !: tracers trend flag 62 57 63 58 !! * Substitutions … … 88 83 ! 89 84 !overturning calculation 90 REAL(wp), DIMENSION( jpj,jpk,nptr) ::sjk, r1_sjk, v_msf ! i-mean i-k-surface and its inverse91 REAL(wp), DIMENSION( jpj,jpk,nptr) :: zt_jk, zs_jk! i-mean T and S, j-Stream-Function92 93 REAL(wp), DIMENSION( jpi,jpj,jpk,nptr) ::z4d1, z4d294 REAL(wp), DIMENSION( jpi,jpj,nptr) :: z3dtr ! i-mean T and S, j-Stream-Function85 REAL(wp), DIMENSION(:,:,: ), ALLOCATABLE :: sjk, r1_sjk, v_msf ! i-mean i-k-surface and its inverse 86 REAL(wp), DIMENSION(:,:,: ), ALLOCATABLE :: zt_jk, zs_jk ! i-mean T and S, j-Stream-Function 87 88 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: z4d1, z4d2 89 REAL(wp), DIMENSION(:,:,: ), ALLOCATABLE :: z3dtr 95 90 !!---------------------------------------------------------------------- 96 91 ! 97 92 IF( ln_timing ) CALL timing_start('dia_ptr') 98 93 99 IF( kt == nit000 .AND. ll_init ) CALL dia_ptr_init 100 ! 101 IF( .NOT. l_diaptr ) RETURN 102 94 IF( kt == nit000 .AND. ll_init ) CALL dia_ptr_init ! -> will define l_diaptr and nbasin 95 ! 96 IF( .NOT. l_diaptr ) THEN 97 IF( ln_timing ) CALL timing_stop('dia_ptr') 98 RETURN 99 ENDIF 100 ! 101 ALLOCATE( z3dtr(jpi,jpj,nbasin) ) 102 ! 103 103 IF( PRESENT( pvtr ) ) THEN 104 104 IF( iom_use( 'zomsf' ) ) THEN ! effective MSF 105 DO jn = 1, nptr ! by sub-basins 105 ALLOCATE( z4d1(jpi,jpj,jpk,nbasin) ) 106 DO jn = 1, nbasin ! by sub-basins 106 107 z4d1(1,:,:,jn) = ptr_sjk( pvtr(:,:,:), btmsk34(:,:,jn) ) ! zonal cumulative effective transport excluding closed seas 107 108 DO jk = jpkm1, 1, -1 … … 113 114 END DO 114 115 CALL iom_put( 'zomsf', z4d1 * rc_sv ) 116 DEALLOCATE( z4d1 ) 115 117 ENDIF 116 118 IF( iom_use( 'sopstove' ) .OR. iom_use( 'sophtove' ) .OR. & … … 127 129 ENDIF 128 130 IF( iom_use( 'sopstove' ) .OR. iom_use( 'sophtove' ) ) THEN 129 DO jn = 1, nptr 131 DO jn = 1, nbasin 132 ALLOCATE( sjk(jpj,jpk,nbasin), r1_sjk(jpj,jpk,nbasin), v_msf(jpj,jpk,nbasin), & 133 & zt_jk(jpj,jpk,nbasin), zs_jk(jpj,jpk,nbasin) ) 130 134 sjk(:,:,jn) = ptr_sjk( zmask(:,:,:), btmsk(:,:,jn) ) 131 135 r1_sjk(:,:,jn) = 0._wp … … 137 141 hstr_ove(:,jp_tem,jn) = SUM( v_msf(:,:,jn)*zt_jk(:,:,jn), 2 ) 138 142 hstr_ove(:,jp_sal,jn) = SUM( v_msf(:,:,jn)*zs_jk(:,:,jn), 2 ) 143 DEALLOCATE( sjk, r1_sjk, v_msf, zt_jk, zs_jk ) 139 144 ! 140 145 ENDDO 141 DO jn = 1, n ptr146 DO jn = 1, nbasin 142 147 z3dtr(1,:,jn) = hstr_ove(:,jp_tem,jn) * rc_pwatt ! (conversion in PW) 143 148 DO ji = 1, jpi … … 146 151 ENDDO 147 152 CALL iom_put( 'sophtove', z3dtr ) 148 DO jn = 1, n ptr153 DO jn = 1, nbasin 149 154 z3dtr(1,:,jn) = hstr_ove(:,jp_sal,jn) * rc_ggram ! (conversion in Gg) 150 155 DO ji = 1, jpi … … 157 162 IF( iom_use( 'sopstbtr' ) .OR. iom_use( 'sophtbtr' ) ) THEN 158 163 ! Calculate barotropic heat and salt transport here 159 DO jn = 1, nptr 164 DO jn = 1, nbasin 165 ALLOCATE( sjk(jpj,1,nbasin), r1_sjk(jpj,1,nbasin) ) 160 166 sjk(:,1,jn) = ptr_sj( zmask(:,:,:), btmsk(:,:,jn) ) 161 167 r1_sjk(:,1,jn) = 0._wp … … 167 173 hstr_btr(:,jp_tem,jn) = zvsum(:) * ztsum(:) * r1_sjk(:,1,jn) 168 174 hstr_btr(:,jp_sal,jn) = zvsum(:) * zssum(:) * r1_sjk(:,1,jn) 175 DEALLOCATE( sjk, r1_sjk ) 169 176 ! 170 177 ENDDO 171 DO jn = 1, n ptr178 DO jn = 1, nbasin 172 179 z3dtr(1,:,jn) = hstr_btr(:,jp_tem,jn) * rc_pwatt ! (conversion in PW) 173 180 DO ji = 1, jpi … … 176 183 ENDDO 177 184 CALL iom_put( 'sophtbtr', z3dtr ) 178 DO jn = 1, n ptr185 DO jn = 1, nbasin 179 186 z3dtr(1,:,jn) = hstr_btr(:,jp_sal,jn) * rc_ggram ! (conversion in Gg) 180 187 DO ji = 1, jpi … … 190 197 zts(:,:,:,:) = 0._wp 191 198 IF( iom_use( 'zotem' ) .OR. iom_use( 'zosal' ) .OR. iom_use( 'zosrf' ) ) THEN ! i-mean i-k-surface 199 ALLOCATE( z4d1(jpi,jpj,jpk,nbasin), z4d2(jpi,jpj,jpk,nbasin) ) 192 200 DO_3D( 1, 1, 1, 1, 1, jpkm1 ) 193 201 zsfc = e1t(ji,jj) * e3t(ji,jj,jk,Kmm) … … 197 205 END_3D 198 206 ! 199 DO jn = 1, n ptr207 DO jn = 1, nbasin 200 208 zmask(1,:,:) = ptr_sjk( zmask(:,:,:), btmsk(:,:,jn) ) 209 DO ji = 1, jpi 210 zmask(ji,:,:) = zmask(1,:,:) 211 ENDDO 201 212 z4d1(:,:,:,jn) = zmask(:,:,:) 202 213 ENDDO 203 214 CALL iom_put( 'zosrf', z4d1 ) 204 215 ! 205 DO jn = 1, n ptr216 DO jn = 1, nbasin 206 217 z4d2(1,:,:,jn) = ptr_sjk( zts(:,:,:,jp_tem), btmsk(:,:,jn) ) & 207 218 & / MAX( z4d1(1,:,:,jn), 10.e-15 ) … … 212 223 CALL iom_put( 'zotem', z4d2 ) 213 224 ! 214 DO jn = 1, n ptr225 DO jn = 1, nbasin 215 226 z4d2(1,:,:,jn) = ptr_sjk( zts(:,:,:,jp_sal), btmsk(:,:,jn) ) & 216 227 & / MAX( z4d1(1,:,:,jn), 10.e-15 ) … … 220 231 ENDDO 221 232 CALL iom_put( 'zosal', z4d2 ) 233 DEALLOCATE( z4d1, z4d2 ) 222 234 ! 223 235 ENDIF … … 226 238 IF( iom_use( 'sophtadv' ) .OR. iom_use( 'sopstadv' ) ) THEN 227 239 ! 228 DO jn = 1, n ptr240 DO jn = 1, nbasin 229 241 z3dtr(1,:,jn) = hstr_adv(:,jp_tem,jn) * rc_pwatt ! (conversion in PW) 230 242 DO ji = 1, jpi … … 233 245 ENDDO 234 246 CALL iom_put( 'sophtadv', z3dtr ) 235 DO jn = 1, n ptr247 DO jn = 1, nbasin 236 248 z3dtr(1,:,jn) = hstr_adv(:,jp_sal,jn) * rc_ggram ! (conversion in Gg) 237 249 DO ji = 1, jpi … … 244 256 IF( iom_use( 'sophtldf' ) .OR. iom_use( 'sopstldf' ) ) THEN 245 257 ! 246 DO jn = 1, n ptr258 DO jn = 1, nbasin 247 259 z3dtr(1,:,jn) = hstr_ldf(:,jp_tem,jn) * rc_pwatt ! (conversion in PW) 248 260 DO ji = 1, jpi … … 251 263 ENDDO 252 264 CALL iom_put( 'sophtldf', z3dtr ) 253 DO jn = 1, n ptr265 DO jn = 1, nbasin 254 266 z3dtr(1,:,jn) = hstr_ldf(:,jp_sal,jn) * rc_ggram ! (conversion in Gg) 255 267 DO ji = 1, jpi … … 262 274 IF( iom_use( 'sophteiv' ) .OR. iom_use( 'sopsteiv' ) ) THEN 263 275 ! 264 DO jn = 1, n ptr276 DO jn = 1, nbasin 265 277 z3dtr(1,:,jn) = hstr_eiv(:,jp_tem,jn) * rc_pwatt ! (conversion in PW) 266 278 DO ji = 1, jpi … … 269 281 ENDDO 270 282 CALL iom_put( 'sophteiv', z3dtr ) 271 DO jn = 1, n ptr283 DO jn = 1, nbasin 272 284 z3dtr(1,:,jn) = hstr_eiv(:,jp_sal,jn) * rc_ggram ! (conversion in Gg) 273 285 DO ji = 1, jpi … … 287 299 CALL dia_ptr_hst( jp_tem, 'vtr', zts(:,:,:,jp_tem) ) 288 300 CALL dia_ptr_hst( jp_sal, 'vtr', zts(:,:,:,jp_sal) ) 289 DO jn = 1, n ptr301 DO jn = 1, nbasin 290 302 z3dtr(1,:,jn) = hstr_vtr(:,jp_tem,jn) * rc_pwatt ! (conversion in PW) 291 303 DO ji = 1, jpi … … 294 306 ENDDO 295 307 CALL iom_put( 'sophtvtr', z3dtr ) 296 DO jn = 1, n ptr308 DO jn = 1, nbasin 297 309 z3dtr(1,:,jn) = hstr_vtr(:,jp_sal,jn) * rc_ggram ! (conversion in Gg) 298 310 DO ji = 1, jpi … … 311 323 ENDIF 312 324 ! 325 DEALLOCATE( z3dtr ) 326 ! 313 327 IF( ln_timing ) CALL timing_stop('dia_ptr') 314 328 ! … … 320 334 !! *** ROUTINE dia_ptr_init *** 321 335 !! 322 !! ** Purpose : Initialization , namelist read336 !! ** Purpose : Initialization 323 337 !!---------------------------------------------------------------------- 324 338 INTEGER :: inum, jn ! local integers … … 326 340 REAL(wp), DIMENSION(jpi,jpj) :: zmsk 327 341 !!---------------------------------------------------------------------- 328 329 l_diaptr = .FALSE. 330 IF( iom_use( 'zomsf' ) .OR. iom_use( 'zotem' ) .OR. iom_use( 'zosal' ) .OR. & 331 & iom_use( 'zosrf' ) .OR. iom_use( 'sopstove' ) .OR. iom_use( 'sophtove' ) .OR. & 332 & iom_use( 'sopstbtr' ) .OR. iom_use( 'sophtbtr' ) .OR. iom_use( 'sophtadv' ) .OR. & 333 & iom_use( 'sopstadv' ) .OR. iom_use( 'sophtldf' ) .OR. iom_use( 'sopstldf' ) .OR. & 334 & iom_use( 'sophteiv' ) .OR. iom_use( 'sopsteiv' ) .OR. iom_use( 'sopstvtr' ) .OR. & 335 & iom_use( 'sophtvtr' ) .OR. iom_use( 'uocetr_vsum_cumul' ) ) l_diaptr = .TRUE. 336 342 343 ! l_diaptr is defined with iom_use 344 ! --> dia_ptr_init must be done after the call to iom_init 345 ! --> cannot be .TRUE. without cpp key: key_iom --> nbasin define by iom_init is initialized 346 l_diaptr = iom_use( 'zomsf' ) .OR. iom_use( 'zotem' ) .OR. iom_use( 'zosal' ) .OR. & 347 & iom_use( 'zosrf' ) .OR. iom_use( 'sopstove' ) .OR. iom_use( 'sophtove' ) .OR. & 348 & iom_use( 'sopstbtr' ) .OR. iom_use( 'sophtbtr' ) .OR. iom_use( 'sophtadv' ) .OR. & 349 & iom_use( 'sopstadv' ) .OR. iom_use( 'sophtldf' ) .OR. iom_use( 'sopstldf' ) .OR. & 350 & iom_use( 'sophteiv' ) .OR. iom_use( 'sopsteiv' ) .OR. iom_use( 'sopstvtr' ) .OR. & 351 & iom_use( 'sophtvtr' ) .OR. iom_use( 'uocetr_vsum_cumul' ) 337 352 338 353 IF(lwp) THEN ! Control print … … 340 355 WRITE(numout,*) 'dia_ptr_init : poleward transport and msf initialization' 341 356 WRITE(numout,*) '~~~~~~~~~~~~' 342 WRITE(numout,*) ' Namelist namptr : set ptr parameters'343 357 WRITE(numout,*) ' Poleward heat & salt transport (T) or not (F) l_diaptr = ', l_diaptr 344 358 ENDIF … … 347 361 ! 348 362 IF( dia_ptr_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'dia_ptr_init : unable to allocate arrays' ) 349 363 ! 350 364 rc_pwatt = rc_pwatt * rho0_rcp ! conversion from K.s-1 to PetaWatt 351 365 rc_ggram = rc_ggram * rho0 ! conversion from m3/s to Gg/s … … 354 368 355 369 btmsk(:,:,1) = tmask_i(:,:) 356 CALL iom_open( 'subbasins', inum, ldstop = .FALSE. ) 357 CALL iom_get( inum, jpdom_global, 'atlmsk', btmsk(:,:,2) ) ! Atlantic basin 358 CALL iom_get( inum, jpdom_global, 'pacmsk', btmsk(:,:,3) ) ! Pacific basin 359 CALL iom_get( inum, jpdom_global, 'indmsk', btmsk(:,:,4) ) ! Indian basin 360 CALL iom_close( inum ) 361 btmsk(:,:,5) = MAX ( btmsk(:,:,3), btmsk(:,:,4) ) ! Indo-Pacific basin 362 DO jn = 2, nptr 363 btmsk(:,:,jn) = btmsk(:,:,jn) * tmask_i(:,:) ! interior domain only 370 IF( nbasin == 5 ) THEN ! nbasin has been initialized in iom_init to define the axis "basin" 371 CALL iom_open( 'subbasins', inum ) 372 CALL iom_get( inum, jpdom_global, 'atlmsk', btmsk(:,:,2) ) ! Atlantic basin 373 CALL iom_get( inum, jpdom_global, 'pacmsk', btmsk(:,:,3) ) ! Pacific basin 374 CALL iom_get( inum, jpdom_global, 'indmsk', btmsk(:,:,4) ) ! Indian basin 375 CALL iom_close( inum ) 376 btmsk(:,:,5) = MAX ( btmsk(:,:,3), btmsk(:,:,4) ) ! Indo-Pacific basin 377 ENDIF 378 DO jn = 2, nbasin 379 btmsk(:,:,jn) = btmsk(:,:,jn) * tmask_i(:,:) ! interior domain only 364 380 END DO 365 381 ! JD : modification so that overturning streamfunction is available in Atlantic at 34S to compare with observations … … 370 386 END WHERE 371 387 btmsk34(:,:,1) = btmsk(:,:,1) 372 DO jn = 2, n ptr373 btmsk34(:,:,jn) = btmsk(:,:,jn) * zmsk(:,:) ! interior domain only388 DO jn = 2, nbasin 389 btmsk34(:,:,jn) = btmsk(:,:,jn) * zmsk(:,:) ! interior domain only 374 390 ENDDO 375 391 … … 405 421 IF( cptr == 'adv' ) THEN 406 422 IF( ktra == jp_tem ) THEN 407 DO jn = 1, n ptr423 DO jn = 1, nbasin 408 424 hstr_adv(:,jp_tem,jn) = ptr_sj( pvflx(:,:,:), btmsk(:,:,jn) ) 409 425 ENDDO 410 426 ENDIF 411 427 IF( ktra == jp_sal ) THEN 412 DO jn = 1, n ptr428 DO jn = 1, nbasin 413 429 hstr_adv(:,jp_sal,jn) = ptr_sj( pvflx(:,:,:), btmsk(:,:,jn) ) 414 430 ENDDO … … 418 434 IF( cptr == 'ldf' ) THEN 419 435 IF( ktra == jp_tem ) THEN 420 DO jn = 1, n ptr436 DO jn = 1, nbasin 421 437 hstr_ldf(:,jp_tem,jn) = ptr_sj( pvflx(:,:,:), btmsk(:,:,jn) ) 422 438 ENDDO 423 439 ENDIF 424 440 IF( ktra == jp_sal ) THEN 425 DO jn = 1, n ptr441 DO jn = 1, nbasin 426 442 hstr_ldf(:,jp_sal,jn) = ptr_sj( pvflx(:,:,:), btmsk(:,:,jn) ) 427 443 ENDDO … … 431 447 IF( cptr == 'eiv' ) THEN 432 448 IF( ktra == jp_tem ) THEN 433 DO jn = 1, n ptr449 DO jn = 1, nbasin 434 450 hstr_eiv(:,jp_tem,jn) = ptr_sj( pvflx(:,:,:), btmsk(:,:,jn) ) 435 451 ENDDO 436 452 ENDIF 437 453 IF( ktra == jp_sal ) THEN 438 DO jn = 1, n ptr454 DO jn = 1, nbasin 439 455 hstr_eiv(:,jp_sal,jn) = ptr_sj( pvflx(:,:,:), btmsk(:,:,jn) ) 440 456 ENDDO … … 444 460 IF( cptr == 'vtr' ) THEN 445 461 IF( ktra == jp_tem ) THEN 446 DO jn = 1, n ptr462 DO jn = 1, nbasin 447 463 hstr_vtr(:,jp_tem,jn) = ptr_sj( pvflx(:,:,:), btmsk(:,:,jn) ) 448 464 ENDDO 449 465 ENDIF 450 466 IF( ktra == jp_sal ) THEN 451 DO jn = 1, n ptr467 DO jn = 1, nbasin 452 468 hstr_vtr(:,jp_sal,jn) = ptr_sj( pvflx(:,:,:), btmsk(:,:,jn) ) 453 469 ENDDO … … 467 483 ierr(:) = 0 468 484 ! 485 ! nbasin has been initialized in iom_init to define the axis "basin" 486 ! 469 487 IF( .NOT. ALLOCATED( btmsk ) ) THEN 470 ALLOCATE( btmsk(jpi,jpj,n ptr) , btmsk34(jpi,jpj,nptr), &471 & hstr_adv(jpj,jpts,n ptr), hstr_eiv(jpj,jpts,nptr), &472 & hstr_ove(jpj,jpts,n ptr), hstr_btr(jpj,jpts,nptr), &473 & hstr_ldf(jpj,jpts,n ptr), hstr_vtr(jpj,jpts,nptr), STAT=ierr(1) )488 ALLOCATE( btmsk(jpi,jpj,nbasin) , btmsk34(jpi,jpj,nbasin), & 489 & hstr_adv(jpj,jpts,nbasin), hstr_eiv(jpj,jpts,nbasin), & 490 & hstr_ove(jpj,jpts,nbasin), hstr_btr(jpj,jpts,nbasin), & 491 & hstr_ldf(jpj,jpts,nbasin), hstr_vtr(jpj,jpts,nbasin), STAT=ierr(1) ) 474 492 ! 475 493 ALLOCATE( p_fval1d(jpj), p_fval2d(jpj,jpk), Stat=ierr(2)) -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/DIA/diawri.F90
r13734 r13998 190 190 CALL iom_put( "sst", ts(:,:,1,jp_tem,Kmm) ) ! surface temperature 191 191 IF ( iom_use("sbt") ) THEN 192 DO_2D( 1, 1, 1, 1)192 DO_2D( 0, 0, 0, 0 ) 193 193 ikbot = mbkt(ji,jj) 194 194 z2d(ji,jj) = ts(ji,jj,ikbot,jp_tem,Kmm) … … 200 200 CALL iom_put( "sss", ts(:,:,1,jp_sal,Kmm) ) ! surface salinity 201 201 IF ( iom_use("sbs") ) THEN 202 DO_2D( 1, 1, 1, 1)202 DO_2D( 0, 0, 0, 0 ) 203 203 ikbot = mbkt(ji,jj) 204 204 z2d(ji,jj) = ts(ji,jj,ikbot,jp_sal,Kmm) … … 222 222 ! 223 223 END_2D 224 CALL lbc_lnk( 'diawri', z2d, 'T', 1.0_wp )225 224 CALL iom_put( "taubot", z2d ) 226 225 ENDIF … … 229 228 CALL iom_put( "ssu", uu(:,:,1,Kmm) ) ! surface i-current 230 229 IF ( iom_use("sbu") ) THEN 231 DO_2D( 1, 1, 1, 1)230 DO_2D( 0, 0, 0, 0 ) 232 231 ikbot = mbku(ji,jj) 233 232 z2d(ji,jj) = uu(ji,jj,ikbot,Kmm) … … 239 238 CALL iom_put( "ssv", vv(:,:,1,Kmm) ) ! surface j-current 240 239 IF ( iom_use("sbv") ) THEN 241 DO_2D( 1, 1, 1, 1)240 DO_2D( 0, 0, 0, 0 ) 242 241 ikbot = mbkv(ji,jj) 243 242 z2d(ji,jj) = vv(ji,jj,ikbot,Kmm) … … 268 267 IF( iom_use('logavs') ) CALL iom_put( "logavs", LOG( MAX( 1.e-20_wp, avs(:,:,:) ) ) ) 269 268 269 IF ( iom_use("socegrad") .OR. iom_use("socegrad2") ) THEN 270 z3d(:,:,jpk) = 0. 271 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 272 zztmp = ts(ji,jj,jk,jp_sal,Kmm) 273 zztmpx = (ts(ji+1,jj,jk,jp_sal,Kmm) - zztmp) * r1_e1u(ji,jj) + (zztmp - ts(ji-1,jj ,jk,jp_sal,Kmm)) * r1_e1u(ji-1,jj) 274 zztmpy = (ts(ji,jj+1,jk,jp_sal,Kmm) - zztmp) * r1_e2v(ji,jj) + (zztmp - ts(ji ,jj-1,jk,jp_sal,Kmm)) * r1_e2v(ji,jj-1) 275 z3d(ji,jj,jk) = 0.25 * ( zztmpx * zztmpx + zztmpy * zztmpy ) & 276 & * umask(ji,jj,jk) * umask(ji-1,jj,jk) * vmask(ji,jj,jk) * umask(ji,jj-1,jk) 277 END_3D 278 CALL iom_put( "socegrad2", z3d ) ! square of module of sal gradient 279 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 280 z3d(ji,jj,jk) = SQRT( z3d(ji,jj,jk) ) 281 END_3D 282 CALL iom_put( "socegrad" , z3d ) ! module of sal gradient 283 ENDIF 284 270 285 IF ( iom_use("sstgrad") .OR. iom_use("sstgrad2") ) THEN 271 DO_2D( 0, 0, 0, 0 ) 286 DO_2D( 0, 0, 0, 0 ) ! sst gradient 272 287 zztmp = ts(ji,jj,1,jp_tem,Kmm) 273 288 zztmpx = ( ts(ji+1,jj,1,jp_tem,Kmm) - zztmp ) * r1_e1u(ji,jj) + ( zztmp - ts(ji-1,jj ,1,jp_tem,Kmm) ) * r1_e1u(ji-1,jj) … … 276 291 & * umask(ji,jj,1) * umask(ji-1,jj,1) * vmask(ji,jj,1) * umask(ji,jj-1,1) 277 292 END_2D 278 CALL lbc_lnk( 'diawri', z2d, 'T', 1.0_wp )279 293 CALL iom_put( "sstgrad2", z2d ) ! square of module of sst gradient 280 z2d(:,:) = SQRT( z2d(:,:) ) 294 DO_2D( 0, 0, 0, 0 ) 295 z2d(ji,jj) = SQRT( z2d(ji,jj) ) 296 END_2D 281 297 CALL iom_put( "sstgrad" , z2d ) ! module of sst gradient 282 298 ENDIF … … 285 301 IF( iom_use("heatc") ) THEN 286 302 z2d(:,:) = 0._wp 287 DO_3D( 1, 1, 1, 1, 1, jpkm1 )303 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 288 304 z2d(ji,jj) = z2d(ji,jj) + e3t(ji,jj,jk,Kmm) * ts(ji,jj,jk,jp_tem,Kmm) * tmask(ji,jj,jk) 289 305 END_3D … … 293 309 IF( iom_use("saltc") ) THEN 294 310 z2d(:,:) = 0._wp 295 DO_3D( 1, 1, 1, 1, 1, jpkm1 )311 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 296 312 z2d(ji,jj) = z2d(ji,jj) + e3t(ji,jj,jk,Kmm) * ts(ji,jj,jk,jp_sal,Kmm) * tmask(ji,jj,jk) 297 313 END_3D … … 299 315 ENDIF 300 316 ! 301 IF ( iom_use("eken") ) THEN 317 IF( iom_use("salt2c") ) THEN 318 z2d(:,:) = 0._wp 319 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 320 z2d(ji,jj) = z2d(ji,jj) + e3t(ji,jj,jk,Kmm) * ts(ji,jj,jk,jp_sal,Kmm) * ts(ji,jj,jk,jp_sal,Kmm) * tmask(ji,jj,jk) 321 END_3D 322 CALL iom_put( "salt2c", rho0 * z2d ) ! vertically integrated salt content (PSU*kg/m2) 323 ENDIF 324 ! 325 IF ( iom_use("ke") .OR. iom_use("ke_int") ) THEN 302 326 z3d(:,:,jpk) = 0._wp 303 327 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 304 zztmp = 0.25_wp * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) 305 z3d(ji,jj,jk) = zztmp * ( uu(ji-1,jj,jk,Kmm)**2 * e2u(ji-1,jj) * e3u(ji-1,jj,jk,Kmm) & 306 & + uu(ji ,jj,jk,Kmm)**2 * e2u(ji ,jj) * e3u(ji ,jj,jk,Kmm) & 307 & + vv(ji,jj-1,jk,Kmm)**2 * e1v(ji,jj-1) * e3v(ji,jj-1,jk,Kmm) & 308 & + vv(ji,jj ,jk,Kmm)**2 * e1v(ji,jj ) * e3v(ji,jj ,jk,Kmm) ) 309 END_3D 310 CALL lbc_lnk( 'diawri', z3d, 'T', 1.0_wp ) 311 CALL iom_put( "eken", z3d ) ! kinetic energy 328 zztmpx = 0.5 * ( uu(ji-1,jj ,jk,Kmm) + uu(ji,jj,jk,Kmm) ) 329 zztmpy = 0.5 * ( vv(ji ,jj-1,jk,Kmm) + vv(ji,jj,jk,Kmm) ) 330 z3d(ji,jj,jk) = 0.5 * ( zztmpx*zztmpx + zztmpy*zztmpy ) 331 END_3D 332 CALL iom_put( "ke", z3d ) ! kinetic energy 333 334 z2d(:,:) = 0._wp 335 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 336 z2d(ji,jj) = z2d(ji,jj) + e3t(ji,jj,jk,Kmm) * z3d(ji,jj,jk) * e1e2t(ji,jj) * tmask(ji,jj,jk) 337 END_3D 338 CALL iom_put( "ke_int", z2d ) ! vertically integrated kinetic energy 312 339 ENDIF 313 340 ! … … 339 366 ! 340 367 CALL iom_put( "hdiv", hdiv ) ! Horizontal divergence 368 369 IF ( iom_use("relvor") .OR. iom_use("absvor") .OR. iom_use("potvor") ) THEN 370 371 z3d(:,:,jpk) = 0._wp 372 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 373 z3d(ji,jj,jk) = ( e2v(ji+1,jj ) * vv(ji+1,jj ,jk,Kmm) - e2v(ji,jj) * vv(ji,jj,jk,Kmm) & 374 & - e1u(ji ,jj+1) * uu(ji ,jj+1,jk,Kmm) + e1u(ji,jj) * uu(ji,jj,jk,Kmm) ) * r1_e1e2f(ji,jj) 375 END_3D 376 CALL iom_put( "relvor", z3d ) ! relative vorticity 377 378 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 379 z3d(ji,jj,jk) = ff_f(ji,jj) + z3d(ji,jj,jk) 380 END_3D 381 CALL iom_put( "absvor", z3d ) ! absolute vorticity 382 383 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 384 ze3 = ( e3t(ji,jj+1,jk,Kmm)*tmask(ji,jj+1,jk) + e3t(ji+1,jj+1,jk,Kmm)*tmask(ji+1,jj+1,jk) & 385 & + e3t(ji,jj ,jk,Kmm)*tmask(ji,jj ,jk) + e3t(ji+1,jj ,jk,Kmm)*tmask(ji+1,jj ,jk) ) 386 IF( ze3 /= 0._wp ) THEN ; ze3 = 4._wp / ze3 387 ELSE ; ze3 = 0._wp 388 ENDIF 389 z3d(ji,jj,jk) = ze3 * z3d(ji,jj,jk) 390 END_3D 391 CALL iom_put( "potvor", z3d ) ! potential vorticity 392 393 ENDIF 341 394 ! 342 395 IF( iom_use("u_masstr") .OR. iom_use("u_masstr_vint") .OR. iom_use("u_heattr") .OR. iom_use("u_salttr") ) THEN … … 356 409 z2d(ji,jj) = z2d(ji,jj) + z3d(ji,jj,jk) * ( ts(ji,jj,jk,jp_tem,Kmm) + ts(ji+1,jj,jk,jp_tem,Kmm) ) 357 410 END_3D 358 CALL lbc_lnk( 'diawri', z2d, 'U', -1.0_wp )359 411 CALL iom_put( "u_heattr", 0.5*rcp * z2d ) ! heat transport in i-direction 360 412 ENDIF … … 365 417 z2d(ji,jj) = z2d(ji,jj) + z3d(ji,jj,jk) * ( ts(ji,jj,jk,jp_sal,Kmm) + ts(ji+1,jj,jk,jp_sal,Kmm) ) 366 418 END_3D 367 CALL lbc_lnk( 'diawri', z2d, 'U', -1.0_wp )368 419 CALL iom_put( "u_salttr", 0.5 * z2d ) ! heat transport in i-direction 369 420 ENDIF … … 383 434 z2d(ji,jj) = z2d(ji,jj) + z3d(ji,jj,jk) * ( ts(ji,jj,jk,jp_tem,Kmm) + ts(ji,jj+1,jk,jp_tem,Kmm) ) 384 435 END_3D 385 CALL lbc_lnk( 'diawri', z2d, 'V', -1.0_wp )386 436 CALL iom_put( "v_heattr", 0.5*rcp * z2d ) ! heat transport in j-direction 387 437 ENDIF … … 392 442 z2d(ji,jj) = z2d(ji,jj) + z3d(ji,jj,jk) * ( ts(ji,jj,jk,jp_sal,Kmm) + ts(ji,jj+1,jk,jp_sal,Kmm) ) 393 443 END_3D 394 CALL lbc_lnk( 'diawri', z2d, 'V', -1.0_wp )395 444 CALL iom_put( "v_salttr", 0.5 * z2d ) ! heat transport in j-direction 396 445 ENDIF … … 401 450 z2d(ji,jj) = z2d(ji,jj) + e3t(ji,jj,jk,Kmm) * ts(ji,jj,jk,jp_tem,Kmm) 402 451 END_3D 403 CALL lbc_lnk( 'diawri', z2d, 'T', -1.0_wp )404 452 CALL iom_put( "tosmint", rho0 * z2d ) ! Vertical integral of temperature 405 453 ENDIF … … 409 457 z2d(ji,jj) = z2d(ji,jj) + e3t(ji,jj,jk,Kmm) * ts(ji,jj,jk,jp_sal,Kmm) 410 458 END_3D 411 CALL lbc_lnk( 'diawri', z2d, 'T', -1.0_wp )412 459 CALL iom_put( "somint", rho0 * z2d ) ! Vertical integral of salinity 413 460 ENDIF -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/DIU/diu_bulk.F90
r13295 r13998 22 22 23 23 ! Namelist parameters 24 LOGICAL, PUBLIC :: ln_diurnal 25 LOGICAL, PUBLIC :: ln_diurnal_only 24 LOGICAL, PUBLIC :: ln_diurnal = .false. ! force definition if diurnal_sst_bulk_init is not called 25 LOGICAL, PUBLIC :: ln_diurnal_only = .false. ! force definition if diurnal_sst_bulk_init is not called 26 26 27 27 ! Parameters -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/DIU/diu_coolskin.F90
r13295 r13998 95 95 !!---------------------------------------------------------------------- 96 96 ! 97 IF( .NOT. ln_blk) CALL ctl_stop("diu_coolskin.f90: diurnal flux processing only implemented for bulk forcing")97 IF( .NOT. (ln_blk .OR. ln_abl) ) CALL ctl_stop("diu_coolskin.f90: diurnal flux processing only implemented for bulk forcing") 98 98 ! 99 99 DO_2D( 1, 1, 1, 1 ) -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/DOM/closea.F90
r13286 r13998 38 38 LOGICAL, PUBLIC :: ln_clo_rnf !: closed sea treated as runoff (update rnf mask) 39 39 40 LOGICAL, PUBLIC :: l_sbc_clo !: T => net evap/precip over closed seas spread outover the globe/river mouth 41 LOGICAL, PUBLIC :: l_clo_rnf !: T => Some closed seas output freshwater (RNF) to specified runoff points. 42 43 INTEGER, PUBLIC :: ncsg !: number of closed seas global mappings (inferred from closea_mask_glo field) 44 INTEGER, PUBLIC :: ncsr !: number of closed seas rnf mappings (inferred from closea_mask_rnf field) 45 INTEGER, PUBLIC :: ncse !: number of closed seas empmr mappings (inferred from closea_mask_emp field) 40 ! WARNING: keep default definitions in the following lines as dom_clo is called only if ln_closea = .true. 41 LOGICAL, PUBLIC :: l_sbc_clo = .FALSE. !: T => net evap/precip over closed seas spread outover the globe/river mouth 42 LOGICAL, PUBLIC :: l_clo_rnf = .FALSE. !: T => Some closed seas output freshwater (RNF) to specified runoff points. 43 44 INTEGER, PUBLIC :: ncsg = 0 !: number of closed seas global mappings (inferred from closea_mask_glo field) 45 INTEGER, PUBLIC :: ncsr = 0 !: number of closed seas rnf mappings (inferred from closea_mask_rnf field) 46 INTEGER, PUBLIC :: ncse = 0 !: number of closed seas empmr mappings (inferred from closea_mask_emp field) 46 47 47 48 INTEGER, PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:,:) :: mask_opnsea, mask_csundef !: mask defining the open sea and the undefined closed sea -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/DOM/daymod.F90
r13286 r13998 82 82 ndt05 = NINT( 0.5 * rn_Dt ) 83 83 84 IF( .NOT. l_offline ) CALL day_rst( nit000, 'READ' ) 85 84 lrst_oce = .NOT. l_offline ! force definition of offline 85 IF( lrst_oce ) CALL day_rst( nit000, 'READ' ) 86 86 87 ! set the calandar from ndastp (read in restart file and namelist) 87 88 nyear = ndastp / 10000 -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/DOM/dom_oce.F90
r13736 r13998 222 222 223 223 !!---------------------------------------------------------------------- 224 !! variable defined here to avoid circular dependencies... 225 !! --------------------------------------------------------------------- 226 INTEGER, PUBLIC :: nbasin ! number of basin to be considered in diaprt (glo, atl, pac, ind, ipc) 227 228 !!---------------------------------------------------------------------- 224 229 !! agrif domain 225 230 !!---------------------------------------------------------------------- -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/DOM/domain.F90
r13914 r13998 257 257 !!---------------------------------------------------------------------- 258 258 ! 259 DO ji = 1, jpi ! local domain indices ==> global domain , including halos, indices259 DO ji = 1, jpi ! local domain indices ==> global domain indices, including halos 260 260 mig(ji) = ji + nimpp - 1 261 261 END DO … … 263 263 mjg(jj) = jj + njmpp - 1 264 264 END DO 265 ! ! local domain indices ==> global domain , excluding halos, indices265 ! ! local domain indices ==> global domain indices, excluding halos 266 266 ! 267 267 mig0(:) = mig(:) - nn_hls … … 568 568 !!---------------------------------------------------------------------- 569 569 ! 570 IF(lk_mpp) THEN 571 CALL mpp_minloc( 'domain', glamt(:,:), tmask_i(:,:), zglmin, imil ) 572 CALL mpp_minloc( 'domain', gphit(:,:), tmask_i(:,:), zgpmin, imip ) 573 CALL mpp_minloc( 'domain', e1t(:,:), tmask_i(:,:), ze1min, imi1 ) 574 CALL mpp_minloc( 'domain', e2t(:,:), tmask_i(:,:), ze2min, imi2 ) 575 CALL mpp_maxloc( 'domain', glamt(:,:), tmask_i(:,:), zglmax, imal ) 576 CALL mpp_maxloc( 'domain', gphit(:,:), tmask_i(:,:), zgpmax, imap ) 577 CALL mpp_maxloc( 'domain', e1t(:,:), tmask_i(:,:), ze1max, ima1 ) 578 CALL mpp_maxloc( 'domain', e2t(:,:), tmask_i(:,:), ze2max, ima2 ) 579 ELSE 580 llmsk = tmask_i(:,:) == 1._wp 581 zglmin = MINVAL( glamt(:,:), mask = llmsk ) 582 zgpmin = MINVAL( gphit(:,:), mask = llmsk ) 583 ze1min = MINVAL( e1t(:,:), mask = llmsk ) 584 ze2min = MINVAL( e2t(:,:), mask = llmsk ) 585 zglmin = MAXVAL( glamt(:,:), mask = llmsk ) 586 zgpmin = MAXVAL( gphit(:,:), mask = llmsk ) 587 ze1max = MAXVAL( e1t(:,:), mask = llmsk ) 588 ze2max = MAXVAL( e2t(:,:), mask = llmsk ) 589 ! 590 imil = MINLOC( glamt(:,:), mask = llmsk ) + (/ nimpp - 1, njmpp - 1 /) 591 imip = MINLOC( gphit(:,:), mask = llmsk ) + (/ nimpp - 1, njmpp - 1 /) 592 imi1 = MINLOC( e1t(:,:), mask = llmsk ) + (/ nimpp - 1, njmpp - 1 /) 593 imi2 = MINLOC( e2t(:,:), mask = llmsk ) + (/ nimpp - 1, njmpp - 1 /) 594 imal = MAXLOC( glamt(:,:), mask = llmsk ) + (/ nimpp - 1, njmpp - 1 /) 595 imap = MAXLOC( gphit(:,:), mask = llmsk ) + (/ nimpp - 1, njmpp - 1 /) 596 ima1 = MAXLOC( e1t(:,:), mask = llmsk ) + (/ nimpp - 1, njmpp - 1 /) 597 ima2 = MAXLOC( e2t(:,:), mask = llmsk ) + (/ nimpp - 1, njmpp - 1 /) 598 ENDIF 570 llmsk = tmask_h(:,:) == 1._wp 571 ! 572 CALL mpp_minloc( 'domain', glamt(:,:), llmsk, zglmin, imil ) 573 CALL mpp_minloc( 'domain', gphit(:,:), llmsk, zgpmin, imip ) 574 CALL mpp_minloc( 'domain', e1t(:,:), llmsk, ze1min, imi1 ) 575 CALL mpp_minloc( 'domain', e2t(:,:), llmsk, ze2min, imi2 ) 576 CALL mpp_maxloc( 'domain', glamt(:,:), llmsk, zglmax, imal ) 577 CALL mpp_maxloc( 'domain', gphit(:,:), llmsk, zgpmax, imap ) 578 CALL mpp_maxloc( 'domain', e1t(:,:), llmsk, ze1max, ima1 ) 579 CALL mpp_maxloc( 'domain', e2t(:,:), llmsk, ze2max, ima2 ) 599 580 ! 600 581 IF(lwp) THEN … … 718 699 ! 719 700 ! !== ORCA family specificities ==! 720 IF( cn_cfg== "ORCA" ) THEN701 IF( TRIM(cn_cfg) == "orca" .OR. TRIM(cn_cfg) == "ORCA" ) THEN 721 702 CALL iom_rstput( 0, 0, inum, 'ORCA' , 1._wp , ktype = jp_i4 ) 722 703 CALL iom_rstput( 0, 0, inum, 'ORCA_index', REAL( nn_cfg, wp), ktype = jp_i4 ) -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/DOM/dommsk.F90
r13736 r13998 92 92 INTEGER :: iktop, ikbot ! - - 93 93 INTEGER :: ios, inum 94 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zwf ! 2D workspace95 94 !! 96 95 NAMELIST/namlbc/ rn_shlat, ln_vorlat … … 205 204 IF( rn_shlat /= 0 ) THEN ! Not free-slip lateral boundary condition 206 205 ! 207 ALLOCATE( zwf(jpi,jpj) )208 !209 206 DO jk = 1, jpk 210 zwf(:,:) = fmask(:,:,jk)211 207 DO_2D( 0, 0, 0, 0 ) 212 208 IF( fmask(ji,jj,jk) == 0._wp ) THEN 213 fmask(ji,jj,jk) = rn_shlat * MIN( 1._wp , MAX( zwf(ji+1,jj), zwf(ji,jj+1),&214 & zwf(ji-1,jj), zwf(ji,jj-1) ))209 fmask(ji,jj,jk) = rn_shlat * MIN( 1._wp , MAX( umask(ji,jj,jk), umask(ji,jj+1,jk), & 210 & vmask(ji,jj,jk), vmask(ji+1,jj,jk) ) ) 215 211 ENDIF 216 212 END_2D 217 213 DO jj = 2, jpjm1 218 214 IF( fmask(1,jj,jk) == 0._wp ) THEN 219 fmask(1 ,jj,jk) = rn_shlat * MIN( 1._wp , MAX( zwf(2,jj), zwf(1,jj+1), zwf(1,jj-1) ) )215 fmask(1 ,jj,jk) = rn_shlat * MIN( 1._wp , MAX( vmask(2,jj,jk), umask(1,jj+1,jk), umask(1,jj,jk) ) ) 220 216 ENDIF 221 217 IF( fmask(jpi,jj,jk) == 0._wp ) THEN 222 fmask(jpi,jj,jk) = rn_shlat * MIN( 1._wp , MAX( zwf(jpi,jj+1), zwf(jpim1,jj), zwf(jpi,jj-1) ) )218 fmask(jpi,jj,jk) = rn_shlat * MIN( 1._wp , MAX( umask(jpi,jj+1,jk), vmask(jpim1,jj,jk), umask(jpi,jj-1,jk) ) ) 223 219 ENDIF 224 220 END DO 225 221 DO ji = 2, jpim1 226 222 IF( fmask(ji,1,jk) == 0._wp ) THEN 227 fmask(ji, 1 ,jk) = rn_shlat * MIN( 1._wp , MAX( zwf(ji+1,1), zwf(ji,2), zwf(ji-1,1) ) )223 fmask(ji, 1 ,jk) = rn_shlat * MIN( 1._wp , MAX( vmask(ji+1,1,jk), umask(ji,2,jk), vmask(ji,1,jk) ) ) 228 224 ENDIF 229 225 IF( fmask(ji,jpj,jk) == 0._wp ) THEN 230 fmask(ji,jpj,jk) = rn_shlat * MIN( 1._wp , MAX( zwf(ji+1,jpj), zwf(ji-1,jpj), zwf(ji,jpjm1) ) )226 fmask(ji,jpj,jk) = rn_shlat * MIN( 1._wp , MAX( vmask(ji+1,jpj,jk), vmask(ji-1,jpj,jk), umask(ji,jpjm1,jk) ) ) 231 227 ENDIF 232 228 END DO 233 229 END DO 234 !235 DEALLOCATE( zwf )236 230 ! 237 231 CALL lbc_lnk( 'dommsk', fmask, 'F', 1._wp ) ! Lateral boundary conditions on fmask -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/DOM/domutl.F90
r13286 r13998 48 48 INTEGER , DIMENSION(2) :: iloc 49 49 REAL(wp) :: zlon, zmini 50 REAL(wp), DIMENSION(jpi,jpj) :: zglam, zgphi, zmask, zdist 50 REAL(wp), DIMENSION(jpi,jpj) :: zglam, zgphi, zdist 51 LOGICAL , DIMENSION(jpi,jpj) :: llmsk 51 52 !!-------------------------------------------------------------------- 52 53 ! … … 54 55 IF ( PRESENT(kkk) ) ik=kkk 55 56 ! 56 CALL dom_uniq(zmask,cdgrid)57 !58 57 SELECT CASE( cdgrid ) 59 CASE( 'U' ) ; zglam(:,:) = glamu(:,:) ; zgphi(:,:) = gphiu(:,:) ; zmask(:,:) = zmask(:,:) * umask(:,:,ik)60 CASE( 'V' ) ; zglam(:,:) = glamv(:,:) ; zgphi(:,:) = gphiv(:,:) ; zmask(:,:) = zmask(:,:) * vmask(:,:,ik)61 CASE( 'F' ) ; zglam(:,:) = glamf(:,:) ; zgphi(:,:) = gphif(:,:) ; zmask(:,:) = zmask(:,:) * fmask(:,:,ik)62 CASE DEFAULT ; zglam(:,:) = glamt(:,:) ; zgphi(:,:) = gphit(:,:) ; zmask(:,:) = zmask(:,:) * tmask(:,:,ik)58 CASE( 'U' ) ; zglam(:,:) = glamu(:,:) ; zgphi(:,:) = gphiu(:,:) ; llmsk(:,:) = tmask_h(:,:) * umask(:,:,ik) == 1._wp 59 CASE( 'V' ) ; zglam(:,:) = glamv(:,:) ; zgphi(:,:) = gphiv(:,:) ; llmsk(:,:) = tmask_h(:,:) * vmask(:,:,ik) == 1._wp 60 CASE( 'F' ) ; zglam(:,:) = glamf(:,:) ; zgphi(:,:) = gphif(:,:) ; llmsk(:,:) = tmask_h(:,:) * fmask(:,:,ik) == 1._wp 61 CASE DEFAULT; zglam(:,:) = glamt(:,:) ; zgphi(:,:) = gphit(:,:) ; llmsk(:,:) = tmask_h(:,:) * tmask(:,:,ik) == 1._wp 63 62 END SELECT 64 63 ! … … 68 67 IF( zlon < 90. ) WHERE( zglam(:,:) > 180. ) zglam(:,:) = zglam(:,:) - 360. ! glam between -180 and 180 69 68 zglam(:,:) = zglam(:,:) - zlon 70 69 ! 71 70 zgphi(:,:) = zgphi(:,:) - plat 72 71 zdist(:,:) = zglam(:,:) * zglam(:,:) + zgphi(:,:) * zgphi(:,:) 73 74 IF( lk_mpp ) THEN 75 CALL mpp_minloc( 'domngb', zdist(:,:), zmask, zmini, iloc) 76 kii = iloc(1) ; kjj = iloc(2) 77 ELSE 78 iloc(:) = MINLOC( zdist(:,:), mask = zmask(:,:) == 1.e0 ) 79 kii = iloc(1) + nimpp - 1 80 kjj = iloc(2) + njmpp - 1 81 ENDIF 72 ! 73 CALL mpp_minloc( 'domngb', zdist(:,:), llmsk, zmini, iloc, ldhalo = .TRUE. ) 74 kii = iloc(1) 75 kjj = iloc(2) 82 76 ! 83 77 END SUBROUTINE dom_ngb -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/DOM/domvvl.F90
r13895 r13998 202 202 gdept(:,:,1,Kbb) = 0.5_wp * e3w(:,:,1,Kbb) 203 203 gdepw(:,:,1,Kbb) = 0.0_wp 204 DO_3D( 1, 1, 1, 1, 2, jpk ) 204 DO_3D( 1, 1, 1, 1, 2, jpk ) ! vertical sum 205 205 ! zcoef = tmask - wmask ! 0 everywhere tmask = wmask, ie everywhere expect at jk = mikt 206 206 ! ! 1 everywhere from mbkt to mikt + 1 or 1 (if no isf) … … 334 334 LOGICAL :: ll_do_bclinic ! local logical 335 335 REAL(wp), DIMENSION(jpi,jpj) :: zht, z_scale, zwu, zwv, zhdiv 336 REAL(wp), DIMENSION(jpi,jpj,jpk) :: ze3t 336 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: ze3t 337 LOGICAL , DIMENSION(:,:,:), ALLOCATABLE :: llmsk 337 338 !!---------------------------------------------------------------------- 338 339 ! … … 419 420 zwu(:,:) = 0._wp 420 421 zwv(:,:) = 0._wp 421 DO_3D( 1, 0, 1, 0, 1, jpkm1 ) 422 DO_3D( 1, 0, 1, 0, 1, jpkm1 ) ! a - first derivative: diffusive fluxes 422 423 un_td(ji,jj,jk) = rn_ahe3 * umask(ji,jj,jk) * e2_e1u(ji,jj) & 423 424 & * ( tilde_e3t_b(ji,jj,jk) - tilde_e3t_b(ji+1,jj ,jk) ) … … 427 428 zwv(ji,jj) = zwv(ji,jj) + vn_td(ji,jj,jk) 428 429 END_3D 429 DO_2D( 1, 1, 1, 1 ) 430 DO_2D( 1, 1, 1, 1 ) ! b - correction for last oceanic u-v points 430 431 un_td(ji,jj,mbku(ji,jj)) = un_td(ji,jj,mbku(ji,jj)) - zwu(ji,jj) 431 432 vn_td(ji,jj,mbkv(ji,jj)) = vn_td(ji,jj,mbkv(ji,jj)) - zwv(ji,jj) 432 433 END_2D 433 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 434 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) ! c - second derivative: divergence of diffusive fluxes 434 435 tilde_e3t_a(ji,jj,jk) = tilde_e3t_a(ji,jj,jk) + ( un_td(ji-1,jj ,jk) - un_td(ji,jj,jk) & 435 436 & + vn_td(ji ,jj-1,jk) - vn_td(ji,jj,jk) & 436 437 & ) * r1_e1e2t(ji,jj) 437 438 END_3D 438 ! ! d - thickness diffusion transport: boundary conditions439 ! ! d - thickness diffusion transport: boundary conditions 439 440 ! (stored for tracer advction and continuity equation) 440 441 CALL lbc_lnk_multi( 'domvvl', un_td , 'U' , -1._wp, vn_td , 'V' , -1._wp) … … 447 448 ! Maximum deformation control 448 449 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~ 449 ze3t(:,:,jpk) = 0._wp 450 DO jk = 1, jpkm1 451 ze3t(:,:,jk) = tilde_e3t_a(:,:,jk) / e3t_0(:,:,jk) * tmask(:,:,jk) * tmask_i(:,:) 452 END DO 453 z_tmax = MAXVAL( ze3t(:,:,:) ) 454 CALL mpp_max( 'domvvl', z_tmax ) ! max over the global domain 455 z_tmin = MINVAL( ze3t(:,:,:) ) 456 CALL mpp_min( 'domvvl', z_tmin ) ! min over the global domain 450 ALLOCATE( ze3t(jpi,jpj,jpk), llmsk(jpi,jpj,jpk) ) 451 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 452 ze3t(ji,jj,jk) = tilde_e3t_a(ji,jj,jk) / e3t_0(ji,jj,jk) * tmask(ji,jj,jk) * tmask_i(ji,jj) 453 END_3D 454 ! 455 llmsk( 1:Nis1,:,:) = .FALSE. ! exclude halos from the checked region 456 llmsk(Nie1: jpi,:,:) = .FALSE. 457 llmsk(:, 1:Njs1,:) = .FALSE. 458 llmsk(:,Nje1: jpj,:) = .FALSE. 459 ! 460 llmsk(Nis0:Nie0,Njs0:Nje0,:) = tmask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp ! define only the inner domain 461 z_tmax = MAXVAL( ze3t(:,:,:), mask = llmsk ) ; CALL mpp_max( 'domvvl', z_tmax ) ! max over the global domain 462 z_tmin = MINVAL( ze3t(:,:,:), mask = llmsk ) ; CALL mpp_min( 'domvvl', z_tmin ) ! min over the global domain 457 463 ! - ML - test: for the moment, stop simulation for too large e3_t variations 458 464 IF( ( z_tmax > rn_zdef_max ) .OR. ( z_tmin < - rn_zdef_max ) ) THEN 459 IF( lk_mpp ) THEN 460 CALL mpp_maxloc( 'domvvl', ze3t, tmask, z_tmax, ijk_max ) 461 CALL mpp_minloc( 'domvvl', ze3t, tmask, z_tmin, ijk_min ) 462 ELSE 463 ijk_max = MAXLOC( ze3t(:,:,:) ) 464 ijk_max(1) = ijk_max(1) + nimpp - 1 465 ijk_max(2) = ijk_max(2) + njmpp - 1 466 ijk_min = MINLOC( ze3t(:,:,:) ) 467 ijk_min(1) = ijk_min(1) + nimpp - 1 468 ijk_min(2) = ijk_min(2) + njmpp - 1 469 ENDIF 465 CALL mpp_maxloc( 'domvvl', ze3t, llmsk, z_tmax, ijk_max ) 466 CALL mpp_minloc( 'domvvl', ze3t, llmsk, z_tmin, ijk_min ) 470 467 IF (lwp) THEN 471 468 WRITE(numout, *) 'MAX( tilde_e3t_a(:,:,:) / e3t_0(:,:,:) ) =', z_tmax … … 476 473 ENDIF 477 474 ENDIF 475 DEALLOCATE( ze3t, llmsk ) 478 476 ! - ML - end test 479 477 ! - ML - Imposing these limits will cause a baroclinicity error which is corrected for below -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/DOM/dtatsd.F90
r13295 r13998 186 186 ENDIF 187 187 ! 188 DO_2D( 1, 1, 1, 1 ) 188 DO_2D( 1, 1, 1, 1 ) ! vertical interpolation of T & S 189 189 DO jk = 1, jpk ! determines the intepolated T-S profiles at each (i,j) points 190 190 zl = gdept_0(ji,jj,jk) -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/DYN/divhor.F90
r13295 r13998 77 77 ENDIF 78 78 ! 79 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 80 hdiv(ji,jj,jk) = ( e2u(ji ,jj) * e3u(ji ,jj,jk,Kmm) * uu(ji ,jj,jk,Kmm) &79 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) !== Horizontal divergence ==! 80 hdiv(ji,jj,jk) = ( e2u(ji ,jj) * e3u(ji ,jj,jk,Kmm) * uu(ji ,jj,jk,Kmm) & 81 81 & - e2u(ji-1,jj) * e3u(ji-1,jj,jk,Kmm) * uu(ji-1,jj,jk,Kmm) & 82 82 & + e1v(ji,jj ) * e3v(ji,jj ,jk,Kmm) * vv(ji,jj ,jk,Kmm) & -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/DYN/dynadv_cen2.F90
r13295 r13998 72 72 zfu(:,:,jk) = 0.25_wp * e2u(:,:) * e3u(:,:,jk,Kmm) * puu(:,:,jk,Kmm) 73 73 zfv(:,:,jk) = 0.25_wp * e1v(:,:) * e3v(:,:,jk,Kmm) * pvv(:,:,jk,Kmm) 74 DO_2D( 1, 0, 1, 0 ) 74 DO_2D( 1, 0, 1, 0 ) ! horizontal momentum fluxes (at T- and F-point) 75 75 zfu_t(ji+1,jj ,jk) = ( zfu(ji,jj,jk) + zfu(ji+1,jj,jk) ) * ( puu(ji,jj,jk,Kmm) + puu(ji+1,jj ,jk,Kmm) ) 76 76 zfv_f(ji ,jj ,jk) = ( zfv(ji,jj,jk) + zfv(ji+1,jj,jk) ) * ( puu(ji,jj,jk,Kmm) + puu(ji ,jj+1,jk,Kmm) ) … … 78 78 zfv_t(ji ,jj+1,jk) = ( zfv(ji,jj,jk) + zfv(ji,jj+1,jk) ) * ( pvv(ji,jj,jk,Kmm) + pvv(ji ,jj+1,jk,Kmm) ) 79 79 END_2D 80 DO_2D( 0, 0, 0, 0 ) 80 DO_2D( 0, 0, 0, 0 ) ! divergence of horizontal momentum fluxes 81 81 puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) - ( zfu_t(ji+1,jj,jk) - zfu_t(ji,jj ,jk) & 82 82 & + zfv_f(ji ,jj,jk) - zfv_f(ji,jj-1,jk) ) * r1_e1e2u(ji,jj) & … … 98 98 ! !== Vertical advection ==! 99 99 ! 100 DO_2D( 0, 0, 0, 0 ) 100 DO_2D( 0, 0, 0, 0 ) ! surface/bottom advective fluxes set to zero 101 101 zfu_uw(ji,jj,jpk) = 0._wp ; zfv_vw(ji,jj,jpk) = 0._wp 102 102 zfu_uw(ji,jj, 1 ) = 0._wp ; zfv_vw(ji,jj, 1 ) = 0._wp … … 109 109 ENDIF 110 110 DO jk = 2, jpkm1 ! interior advective fluxes 111 DO_2D( 0, 1, 0, 1 ) 111 DO_2D( 0, 1, 0, 1 ) ! 1/4 * Vertical transport 112 112 zfw(ji,jj,jk) = 0.25_wp * e1e2t(ji,jj) * ww(ji,jj,jk) 113 113 END_2D … … 117 117 END_2D 118 118 END DO 119 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 119 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) ! divergence of vertical momentum flux divergence 120 120 puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) - ( zfu_uw(ji,jj,jk) - zfu_uw(ji,jj,jk+1) ) * r1_e1e2u(ji,jj) & 121 121 & / e3u(ji,jj,jk,Kmm) -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/DYN/dynadv_ubs.F90
r13295 r13998 108 108 zfv(:,:,jk) = e1v(:,:) * e3v(:,:,jk,Kmm) * pvv(:,:,jk,Kmm) 109 109 ! 110 DO_2D( 0, 0, 0, 0 ) 110 DO_2D( 0, 0, 0, 0 ) ! laplacian 111 111 zlu_uu(ji,jj,jk,1) = ( puu (ji+1,jj ,jk,Kbb) - 2.*puu (ji,jj,jk,Kbb) + puu (ji-1,jj ,jk,Kbb) ) * umask(ji,jj,jk) 112 112 zlv_vv(ji,jj,jk,1) = ( pvv (ji ,jj+1,jk,Kbb) - 2.*pvv (ji,jj,jk,Kbb) + pvv (ji ,jj-1,jk,Kbb) ) * vmask(ji,jj,jk) … … 136 136 zfv(:,:,jk) = 0.25_wp * e1v(:,:) * e3v(:,:,jk,Kmm) * pvv(:,:,jk,Kmm) 137 137 ! 138 DO_2D( 1, 0, 1, 0 ) 138 DO_2D( 1, 0, 1, 0 ) ! horizontal momentum fluxes at T- and F-point 139 139 zui = ( puu(ji,jj,jk,Kmm) + puu(ji+1,jj ,jk,Kmm) ) 140 140 zvj = ( pvv(ji,jj,jk,Kmm) + pvv(ji ,jj+1,jk,Kmm) ) … … 168 168 & * ( pvv(ji,jj,jk,Kmm) + pvv(ji+1,jj ,jk,Kmm) - gamma1 * zl_v ) 169 169 END_2D 170 DO_2D( 0, 0, 0, 0 ) 170 DO_2D( 0, 0, 0, 0 ) ! divergence of horizontal momentum fluxes 171 171 puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) - ( zfu_t(ji+1,jj,jk) - zfu_t(ji,jj ,jk) & 172 172 & + zfv_f(ji ,jj,jk) - zfv_f(ji,jj-1,jk) ) * r1_e1e2u(ji,jj) & … … 187 187 ! ! Vertical advection ! 188 188 ! ! ==================== ! 189 DO_2D( 0, 0, 0, 0 ) 189 DO_2D( 0, 0, 0, 0 ) ! surface/bottom advective fluxes set to zero 190 190 zfu_uw(ji,jj,jpk) = 0._wp 191 191 zfv_vw(ji,jj,jpk) = 0._wp … … 208 208 END_2D 209 209 END DO 210 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 210 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) ! divergence of vertical momentum flux divergence 211 211 puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) - ( zfu_uw(ji,jj,jk) - zfu_uw(ji,jj,jk+1) ) * r1_e1e2u(ji,jj) & 212 212 & / e3u(ji,jj,jk,Kmm) -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/DYN/dynatf.F90
r13295 r13998 34 34 USE dynspg_ts ! surface pressure gradient: split-explicit scheme 35 35 USE domvvl ! variable volume 36 USE bdy_oce , ONLY: ln_bdy36 USE bdy_oce , ONLY : ln_bdy 37 37 USE bdydta ! ocean open boundary conditions 38 38 USE bdydyn ! ocean open boundary conditions … … 50 50 USE prtctl ! Print control 51 51 USE timing ! Timing 52 USE zdfdrg , ONLY : ln_drgice_imp, rCdU_top 52 53 #if defined key_agrif 53 54 USE agrif_oce_interp … … 120 121 REAL(wp) :: zve3a, zve3n, zve3b, z1_2dt ! - - 121 122 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zue, zve, zwfld 123 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zutau, zvtau 122 124 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: ze3t_f, ze3u_f, ze3v_f, zua, zva 123 125 !!---------------------------------------------------------------------- … … 321 323 ENDIF 322 324 ! 325 IF ( iom_use("utau") ) THEN 326 IF ( ln_drgice_imp.OR.ln_isfcav ) THEN 327 ALLOCATE(zutau(jpi,jpj)) 328 DO_2D( 0, 0, 0, 0 ) 329 jk = miku(ji,jj) 330 zutau(ji,jj) = utau(ji,jj) + 0.5_wp * rho0 * ( rCdU_top(ji+1,jj)+rCdU_top(ji,jj) ) * puu(ji,jj,jk,Kaa) 331 END_2D 332 CALL iom_put( "utau", zutau(:,:) ) 333 DEALLOCATE(zutau) 334 ELSE 335 CALL iom_put( "utau", utau(:,:) ) 336 ENDIF 337 ENDIF 338 ! 339 IF ( iom_use("vtau") ) THEN 340 IF ( ln_drgice_imp.OR.ln_isfcav ) THEN 341 ALLOCATE(zvtau(jpi,jpj)) 342 DO_2D( 0, 0, 0, 0 ) 343 jk = mikv(ji,jj) 344 zvtau(ji,jj) = vtau(ji,jj) + 0.5_wp * rho0 * ( rCdU_top(ji,jj+1)+rCdU_top(ji,jj) ) * pvv(ji,jj,jk,Kaa) 345 END_2D 346 CALL iom_put( "vtau", zvtau(:,:) ) 347 DEALLOCATE(zvtau) 348 ELSE 349 CALL iom_put( "vtau", vtau(:,:) ) 350 ENDIF 351 ENDIF 352 ! 323 353 IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=puu(:,:,:,Kaa), clinfo1=' nxt - puu(:,:,:,Kaa): ', mask1=umask, & 324 354 & tab3d_2=pvv(:,:,:,Kaa), clinfo2=' pvv(:,:,:,Kaa): ' , mask2=vmask ) -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/DYN/dynkeg.F90
r13295 r13998 125 125 END SELECT 126 126 ! 127 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 127 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) !== grad( KE ) added to the general momentum trends ==! 128 128 puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) - ( zhke(ji+1,jj ,jk) - zhke(ji,jj,jk) ) / e1u(ji,jj) 129 129 pvv(ji,jj,jk,Krhs) = pvv(ji,jj,jk,Krhs) - ( zhke(ji ,jj+1,jk) - zhke(ji,jj,jk) ) / e2v(ji,jj) -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/DYN/dynldf_iso.F90
r13295 r13998 128 128 IF( ln_dynldf_hor .AND. ln_traldf_iso ) THEN 129 129 ! 130 DO_3D( 0, 0, 0, 0, 1, jpk ) 130 DO_3D( 0, 0, 0, 0, 1, jpk ) ! set the slopes of iso-level 131 131 uslp (ji,jj,jk) = - ( gdept(ji+1,jj,jk,Kbb) - gdept(ji ,jj ,jk,Kbb) ) * r1_e1u(ji,jj) * umask(ji,jj,jk) 132 132 vslp (ji,jj,jk) = - ( gdept(ji,jj+1,jk,Kbb) - gdept(ji ,jj ,jk,Kbb) ) * r1_e2v(ji,jj) * vmask(ji,jj,jk) … … 268 268 ! Second derivative (divergence) and add to the general trend 269 269 ! ----------------------------------------------------------- 270 DO_2D( 0, 0, 0, 0 ) 270 DO_2D( 0, 0, 0, 0 ) !!gm Question vectop possible??? !!bug 271 271 puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) + ( ziut(ji+1,jj) - ziut(ji,jj ) & 272 272 & + zjuf(ji ,jj) - zjuf(ji,jj-1) ) * r1_e1e2u(ji,jj) & -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/DYN/dynldf_lap_blp.F90
r13513 r13998 94 94 END_2D 95 95 ! 96 DO_2D( 0, 0, 0, 0 ) 96 DO_2D( 0, 0, 0, 0 ) ! - curl( curl) + grad( div ) 97 97 pu_rhs(ji,jj,jk) = pu_rhs(ji,jj,jk) + zsign * umask(ji,jj,jk) * ( & ! * by umask is mandatory for dyn_ldf_blp use 98 98 & - ( zcur(ji ,jj) - zcur(ji,jj-1) ) * r1_e2u(ji,jj) / e3u(ji,jj,jk,Kmm) & -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/DYN/dynspg.F90
r13295 r13998 102 102 IF( ln_apr_dyn .AND. .NOT.ln_dynspg_ts ) THEN !== Atmospheric pressure gradient (added later in time-split case) ==! 103 103 zg_2 = grav * 0.5 104 DO_2D( 0, 0, 0, 0 ) 104 DO_2D( 0, 0, 0, 0 ) ! gradient of Patm using inverse barometer ssh 105 105 spgu(ji,jj) = spgu(ji,jj) + zg_2 * ( ssh_ib (ji+1,jj) - ssh_ib (ji,jj) & 106 106 & + ssh_ibb(ji+1,jj) - ssh_ibb(ji,jj) ) * r1_e1u(ji,jj) … … 117 117 CALL upd_tide(zt0step, Kmm) 118 118 ! 119 DO_2D( 0, 0, 0, 0 ) 119 DO_2D( 0, 0, 0, 0 ) ! add tide potential forcing 120 120 spgu(ji,jj) = spgu(ji,jj) + grav * ( pot_astro(ji+1,jj) - pot_astro(ji,jj) ) * r1_e1u(ji,jj) 121 121 spgv(ji,jj) = spgv(ji,jj) + grav * ( pot_astro(ji,jj+1) - pot_astro(ji,jj) ) * r1_e2v(ji,jj) … … 124 124 IF (ln_scal_load) THEN 125 125 zld = rn_scal_load * grav 126 DO_2D( 0, 0, 0, 0 ) 126 DO_2D( 0, 0, 0, 0 ) ! add scalar approximation for load potential 127 127 spgu(ji,jj) = spgu(ji,jj) + zld * ( pssh(ji+1,jj,Kmm) - pssh(ji,jj,Kmm) ) * r1_e1u(ji,jj) 128 128 spgv(ji,jj) = spgv(ji,jj) + zld * ( pssh(ji,jj+1,Kmm) - pssh(ji,jj,Kmm) ) * r1_e2v(ji,jj) … … 143 143 ENDIF 144 144 ! 145 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 145 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) !== Add all terms to the general trend 146 146 puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) + spgu(ji,jj) 147 147 pvv(ji,jj,jk,Krhs) = pvv(ji,jj,jk,Krhs) + spgv(ji,jj) -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/DYN/dynspg_exp.F90
r13295 r13998 74 74 IF( ln_linssh ) THEN !* linear free surface : add the surface pressure gradient trend 75 75 ! 76 DO_2D( 0, 0, 0, 0 ) 76 DO_2D( 0, 0, 0, 0 ) ! now surface pressure gradient 77 77 spgu(ji,jj) = - grav * ( ssh(ji+1,jj,Kmm) - ssh(ji,jj,Kmm) ) * r1_e1u(ji,jj) 78 78 spgv(ji,jj) = - grav * ( ssh(ji,jj+1,Kmm) - ssh(ji,jj,Kmm) ) * r1_e2v(ji,jj) 79 79 END_2D 80 80 ! 81 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 81 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) ! Add it to the general trend 82 82 puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) + spgu(ji,jj) 83 83 pvv(ji,jj,jk,Krhs) = pvv(ji,jj,jk,Krhs) + spgv(ji,jj) -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/DYN/dynspg_ts.F90
r13895 r13998 264 264 IF( ln_wd_il ) THEN ! W/D : limiter applied to spgspg 265 265 CALL wad_spg( pssh(:,:,Kmm), zcpx, zcpy ) ! Calculating W/D gravity filters, zcpx and zcpy 266 DO_2D( 0, 0, 0, 0 ) 266 DO_2D( 0, 0, 0, 0 ) ! SPG with the application of W/D gravity filters 267 267 zu_trd(ji,jj) = zu_trd(ji,jj) - grav * ( pssh(ji+1,jj ,Kmm) - pssh(ji ,jj ,Kmm) ) & 268 268 & * r1_e1u(ji,jj) * zcpx(ji,jj) * wdrampu(ji,jj) !jth … … 279 279 ENDIF 280 280 ! 281 DO_2D( 0, 0, 0, 0 ) 281 DO_2D( 0, 0, 0, 0 ) ! Remove coriolis term (and possibly spg) from barotropic trend 282 282 zu_frc(ji,jj) = zu_frc(ji,jj) - zu_trd(ji,jj) * ssumask(ji,jj) 283 283 zv_frc(ji,jj) = zv_frc(ji,jj) - zv_trd(ji,jj) * ssvmask(ji,jj) … … 477 477 #if defined key_qcoTest_FluxForm 478 478 ! ! 'key_qcoTest_FluxForm' : simple ssh average 479 DO_2D( 1, 1, 1, 0 ) 479 DO_2D( 1, 1, 1, 0 ) ! not jpi-column 480 480 zhup2_e(ji,jj) = hu_0(ji,jj) + r1_2 * ( zsshp2_e(ji,jj) + zsshp2_e(ji+1,jj ) ) * ssumask(ji,jj) 481 481 END_2D … … 485 485 #else 486 486 ! ! no 'key_qcoTest_FluxForm' : surface weighted ssh average 487 DO_2D( 1, 1, 1, 0 ) 487 DO_2D( 1, 1, 1, 0 ) ! not jpi-column 488 488 zhup2_e(ji,jj) = hu_0(ji,jj) + r1_2 * r1_e1e2u(ji,jj) & 489 489 & * ( e1e2t(ji ,jj) * zsshp2_e(ji ,jj) & 490 490 & + e1e2t(ji+1,jj) * zsshp2_e(ji+1,jj) ) * ssumask(ji,jj) 491 491 END_2D 492 DO_2D( 1, 0, 1, 1 ) 492 DO_2D( 1, 0, 1, 1 ) ! not jpj-row 493 493 zhvp2_e(ji,jj) = hv_0(ji,jj) + r1_2 * r1_e1e2v(ji,jj) & 494 494 & * ( e1e2t(ji,jj ) * zsshp2_e(ji,jj ) & … … 950 950 CALL iom_get( numror, jpdom_auto, 'ub2_i_b' , ub2_i_b(:,:), cd_type = 'U', psgn = -1._wp, ldxios = lrxios ) 951 951 CALL iom_get( numror, jpdom_auto, 'vb2_i_b' , vb2_i_b(:,:), cd_type = 'V', psgn = -1._wp, ldxios = lrxios ) 952 ELSE 953 ub2_i_b(:,:) = 0._wp ; vb2_i_b(:,:) = 0._wp ! used in the 1st update of agrif 952 954 ENDIF 953 955 #endif … … 955 957 IF(lwp) WRITE(numout,*) 956 958 IF(lwp) WRITE(numout,*) ' ==>>> start from rest: set barotropic values to 0' 957 ub2_b (:,:) = 0._wp ; vb2_b(:,:) = 0._wp ! used in the 1st interpol of agrif958 un_adv (:,:) = 0._wp ; vn_adv(:,:) = 0._wp ! used in the 1st interpol of agrif959 un_bf (:,:) = 0._wp ; vn_bf(:,:) = 0._wp ! used in the 1st update of agrif959 ub2_b (:,:) = 0._wp ; vb2_b (:,:) = 0._wp ! used in the 1st interpol of agrif 960 un_adv (:,:) = 0._wp ; vn_adv (:,:) = 0._wp ! used in the 1st interpol of agrif 961 un_bf (:,:) = 0._wp ; vn_bf (:,:) = 0._wp ! used in the 1st update of agrif 960 962 #if defined key_agrif 961 IF ( .NOT.Agrif_Root() ) THEN 962 ub2_i_b(:,:) = 0._wp ; vb2_i_b(:,:) = 0._wp ! used in the 1st update of agrif 963 ENDIF 963 ub2_i_b(:,:) = 0._wp ; vb2_i_b(:,:) = 0._wp ! used in the 1st update of agrif 964 964 #endif 965 965 ENDIF … … 1295 1295 !!---------------------------------------------------------------------- 1296 1296 ! 1297 DO_2D( 1, 1, 1, 0 ) 1297 DO_2D( 1, 1, 1, 0 ) ! not jpi-column 1298 1298 IF ( phU(ji,jj) > 0._wp ) THEN ; pUmsk(ji,jj) = pTmsk(ji ,jj) 1299 1299 ELSE ; pUmsk(ji,jj) = pTmsk(ji+1,jj) … … 1303 1303 END_2D 1304 1304 ! 1305 DO_2D( 1, 0, 1, 1 ) 1305 DO_2D( 1, 0, 1, 1 ) ! not jpj-row 1306 1306 IF ( phV(ji,jj) > 0._wp ) THEN ; pVmsk(ji,jj) = pTmsk(ji,jj ) 1307 1307 ELSE ; pVmsk(ji,jj) = pTmsk(ji,jj+1) … … 1391 1391 ! !== Set the barotropic drag coef. ==! 1392 1392 ! 1393 IF( ln_isfcav ) THEN ! top+bottom friction (ocean cavities)1393 IF( ln_isfcav.OR.ln_drgice_imp ) THEN ! top+bottom friction (ocean cavities) 1394 1394 1395 1395 DO_2D( 0, 0, 0, 0 ) … … 1442 1442 ! !== TOP stress contribution from baroclinic velocities ==! (no W/D case) 1443 1443 ! 1444 IF( ln_isfcav ) THEN1444 IF( ln_isfcav.OR.ln_drgice_imp ) THEN 1445 1445 ! 1446 1446 IF( ln_bt_fw ) THEN ! FORWARD integration: use NOW top baroclinic velocity -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/DYN/dynvor.F90
r13734 r13998 223 223 REAL(wp) :: zx1, zy1, zx2, zy2 ! local scalars 224 224 REAL(wp), DIMENSION(jpi,jpj) :: zwx, zwy, zwt ! 2D workspace 225 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zwz ! 3D workspace 225 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zwz ! 3D workspace, jpkm1 -> avoid lbc_lnk on jpk that is not defined 226 226 !!---------------------------------------------------------------------- 227 227 ! … … 248 248 ENDIF 249 249 END DO 250 CALL lbc_lnk( 'dynvor', zwz, 'F', 1. )250 CALL lbc_lnk( 'dynvor', zwz, 'F', 1.0_wp ) 251 251 ! 252 252 END SELECT … … 591 591 REAL(wp) :: zua, zva ! local scalars 592 592 REAL(wp) :: zmsk, ze3f ! local scalars 593 REAL(wp), DIMENSION(jpi,jpj) :: zwx , zwy , z1_e3f594 REAL(wp), DIMENSION(jpi,jpj) :: ztnw, ztne, ztsw, ztse595 REAL(wp), DIMENSION(jpi,jpj,jpk ) :: zwz593 REAL(wp), DIMENSION(jpi,jpj) :: zwx , zwy , z1_e3f 594 REAL(wp), DIMENSION(jpi,jpj) :: ztnw, ztne, ztsw, ztse 595 REAL(wp), DIMENSION(jpi,jpj,jpkm1) :: zwz ! 3D workspace, jpkm1 -> jpkm1 -> avoid lbc_lnk on jpk that is not defined 596 596 !!---------------------------------------------------------------------- 597 597 ! … … 740 740 REAL(wp) :: zua, zva ! local scalars 741 741 REAL(wp) :: zmsk, z1_e3t ! local scalars 742 REAL(wp), DIMENSION(jpi,jpj) :: zwx , zwy743 REAL(wp), DIMENSION(jpi,jpj) :: ztnw, ztne, ztsw, ztse744 REAL(wp), DIMENSION(jpi,jpj,jpk ) :: zwz742 REAL(wp), DIMENSION(jpi,jpj) :: zwx , zwy 743 REAL(wp), DIMENSION(jpi,jpj) :: ztnw, ztne, ztsw, ztse 744 REAL(wp), DIMENSION(jpi,jpj,jpkm1) :: zwz ! 3D workspace, avoid lbc_lnk on jpk that is not defined 745 745 !!---------------------------------------------------------------------- 746 746 ! -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/DYN/dynzad.F90
r13295 r13998 71 71 ENDIF 72 72 73 IF( l_trddyn ) THEN ! Save puu(:,:,:,Krhs) and pvv(:,:,:,Krhs) trends73 IF( l_trddyn ) THEN ! Save puu(:,:,:,Krhs) and pvv(:,:,:,Krhs) trends 74 74 ALLOCATE( ztrdu(jpi,jpj,jpk) , ztrdv(jpi,jpj,jpk) ) 75 75 ztrdu(:,:,:) = puu(:,:,:,Krhs) … … 77 77 ENDIF 78 78 79 DO jk = 2, jpkm1 ! Vertical momentum advection at level w and u- and v- vertical80 DO_2D( 0, 1, 0, 1 ) 79 DO jk = 2, jpkm1 ! Vertical momentum advection at level w and u- and v- vertical 80 DO_2D( 0, 1, 0, 1 ) ! vertical fluxes 81 81 zww(ji,jj) = 0.25_wp * e1e2t(ji,jj) * ww(ji,jj,jk) 82 82 END_2D 83 DO_2D( 0, 0, 0, 0 ) 83 DO_2D( 0, 0, 0, 0 ) ! vertical momentum advection at w-point 84 84 zwuw(ji,jj,jk) = ( zww(ji+1,jj ) + zww(ji,jj) ) * ( puu(ji,jj,jk-1,Kmm) - puu(ji,jj,jk,Kmm) ) 85 85 zwvw(ji,jj,jk) = ( zww(ji ,jj+1) + zww(ji,jj) ) * ( pvv(ji,jj,jk-1,Kmm) - pvv(ji,jj,jk,Kmm) ) … … 95 95 END_2D 96 96 ! 97 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 97 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) ! Vertical momentum advection at u- and v-points 98 98 puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) - ( zwuw(ji,jj,jk) + zwuw(ji,jj,jk+1) ) * r1_e1e2u(ji,jj) & 99 99 & / e3u(ji,jj,jk,Kmm) … … 102 102 END_3D 103 103 104 IF( l_trddyn ) THEN ! save the vertical advection trends for diagnostic104 IF( l_trddyn ) THEN ! save the vertical advection trends for diagnostic 105 105 ztrdu(:,:,:) = puu(:,:,:,Krhs) - ztrdu(:,:,:) 106 106 ztrdv(:,:,:) = pvv(:,:,:,Krhs) - ztrdv(:,:,:) … … 108 108 DEALLOCATE( ztrdu, ztrdv ) 109 109 ENDIF 110 ! ! Control print110 ! ! Control print 111 111 IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=puu(:,:,:,Krhs), clinfo1=' zad - Ua: ', mask1=umask, & 112 112 & tab3d_2=pvv(:,:,:,Krhs), clinfo2= ' Va: ', mask2=vmask, clinfo3='dyn' ) -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/DYN/dynzdf.F90
r13295 r13998 131 131 pvv(ji,jj,jk,Kaa) = ( pvv(ji,jj,jk,Kaa) - vv_b(ji,jj,Kaa) ) * vmask(ji,jj,jk) 132 132 END_3D 133 DO_2D( 0, 0, 0, 0 ) 133 DO_2D( 0, 0, 0, 0 ) ! Add bottom/top stress due to barotropic component only 134 134 iku = mbku(ji,jj) ! ocean bottom level at u- and v-points 135 135 ikv = mbkv(ji,jj) ! (deepest ocean u- and v-points) … … 141 141 pvv(ji,jj,ikv,Kaa) = pvv(ji,jj,ikv,Kaa) + rDt * 0.5*( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) ) * vv_b(ji,jj,Kaa) / ze3va 142 142 END_2D 143 IF( ln_isfcav ) THEN ! Ocean cavities (ISF)143 IF( ln_isfcav.OR.ln_drgice_imp ) THEN ! Ocean cavities (ISF) 144 144 DO_2D( 0, 0, 0, 0 ) 145 145 iku = miku(ji,jj) ! top ocean level at u- and v-points … … 190 190 END_3D 191 191 END SELECT 192 DO_2D( 0, 0, 0, 0 ) 192 DO_2D( 0, 0, 0, 0 ) !* Surface boundary conditions 193 193 zwi(ji,jj,1) = 0._wp 194 194 ze3ua = ( 1._wp - r_vvl ) * e3u(ji,jj,1,Kmm) & … … 227 227 END_3D 228 228 END SELECT 229 DO_2D( 0, 0, 0, 0 ) 229 DO_2D( 0, 0, 0, 0 ) !* Surface boundary conditions 230 230 zwi(ji,jj,1) = 0._wp 231 231 zwd(ji,jj,1) = 1._wp - zws(ji,jj,1) … … 247 247 zwd(ji,jj,iku) = zwd(ji,jj,iku) - rDt * 0.5*( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) ) / ze3ua 248 248 END_2D 249 IF ( ln_isfcav ) THEN ! top friction (always implicit)249 IF ( ln_isfcav.OR.ln_drgice_imp ) THEN ! top friction (always implicit) 250 250 DO_2D( 0, 0, 0, 0 ) 251 251 !!gm top Cd is masked (=0 outside cavities) no need of test on mik>=2 ==>> it has been suppressed … … 273 273 !----------------------------------------------------------------------- 274 274 ! 275 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) 275 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) !== First recurrence : Dk = Dk - Lk * Uk-1 / Dk-1 (increasing k) == 276 276 zwd(ji,jj,jk) = zwd(ji,jj,jk) - zwi(ji,jj,jk) * zws(ji,jj,jk-1) / zwd(ji,jj,jk-1) 277 277 END_3D 278 278 ! 279 DO_2D( 0, 0, 0, 0 ) 279 DO_2D( 0, 0, 0, 0 ) !== second recurrence: SOLk = RHSk - Lk / Dk-1 Lk-1 ==! 280 280 ze3ua = ( 1._wp - r_vvl ) * e3u(ji,jj,1,Kmm) & 281 281 & + r_vvl * e3u(ji,jj,1,Kaa) … … 287 287 END_3D 288 288 ! 289 DO_2D( 0, 0, 0, 0 ) 289 DO_2D( 0, 0, 0, 0 ) !== thrid recurrence : SOLk = ( Lk - Uk * Ek+1 ) / Dk ==! 290 290 puu(ji,jj,jpkm1,Kaa) = puu(ji,jj,jpkm1,Kaa) / zwd(ji,jj,jpkm1) 291 291 END_2D … … 329 329 END_3D 330 330 END SELECT 331 DO_2D( 0, 0, 0, 0 ) 331 DO_2D( 0, 0, 0, 0 ) !* Surface boundary conditions 332 332 zwi(ji,jj,1) = 0._wp 333 333 ze3va = ( 1._wp - r_vvl ) * e3v(ji,jj,1,Kmm) & … … 366 366 END_3D 367 367 END SELECT 368 DO_2D( 0, 0, 0, 0 ) 368 DO_2D( 0, 0, 0, 0 ) !* Surface boundary conditions 369 369 zwi(ji,jj,1) = 0._wp 370 370 zwd(ji,jj,1) = 1._wp - zws(ji,jj,1) … … 385 385 zwd(ji,jj,ikv) = zwd(ji,jj,ikv) - rDt * 0.5*( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) ) / ze3va 386 386 END_2D 387 IF ( ln_isfcav ) THEN387 IF ( ln_isfcav.OR.ln_drgice_imp ) THEN 388 388 DO_2D( 0, 0, 0, 0 ) 389 389 ikv = mikv(ji,jj) ! (first wet ocean u- and v-points) … … 410 410 !----------------------------------------------------------------------- 411 411 ! 412 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) 412 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) !== First recurrence : Dk = Dk - Lk * Uk-1 / Dk-1 (increasing k) == 413 413 zwd(ji,jj,jk) = zwd(ji,jj,jk) - zwi(ji,jj,jk) * zws(ji,jj,jk-1) / zwd(ji,jj,jk-1) 414 414 END_3D 415 415 ! 416 DO_2D( 0, 0, 0, 0 ) 416 DO_2D( 0, 0, 0, 0 ) !== second recurrence: SOLk = RHSk - Lk / Dk-1 Lk-1 ==! 417 417 ze3va = ( 1._wp - r_vvl ) * e3v(ji,jj,1,Kmm) & 418 418 & + r_vvl * e3v(ji,jj,1,Kaa) … … 424 424 END_3D 425 425 ! 426 DO_2D( 0, 0, 0, 0 ) 426 DO_2D( 0, 0, 0, 0 ) !== third recurrence : SOLk = ( Lk - Uk * SOLk+1 ) / Dk ==! 427 427 pvv(ji,jj,jpkm1,Kaa) = pvv(ji,jj,jpkm1,Kaa) / zwd(ji,jj,jpkm1) 428 428 END_2D -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/DYN/sshwzv.F90
r13915 r13998 206 206 ELSE !== Quasi-Eulerian vertical coordinate ==! ('key_qco') 207 207 ! !==========================================! 208 DO jk = jpkm1, 1, -1 ! integrate from the bottom the hor. divergence208 DO jk = jpkm1, 1, -1 ! integrate from the bottom the hor. divergence 209 209 pww(:,:,jk) = pww(:,:,jk+1) - ( e3t(:,:,jk,Kmm) * hdiv(:,:,jk) & 210 210 & + r1_Dt * ( e3t(:,:,jk,Kaa) & … … 398 398 ! 399 399 IF( MAXVAL( Cu_adv(:,:,:) ) > Cu_min ) THEN ! Quick check if any breaches anywhere 400 DO_3DS( 1, 1, 1, 1, jpkm1, 2, -1 ) 400 DO_3DS( 1, 1, 1, 1, jpkm1, 2, -1 ) ! or scan Courant criterion and partition ! w where necessary 401 401 ! 402 402 zCu = MAX( Cu_adv(ji,jj,jk) , Cu_adv(ji,jj,jk-1) ) -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/DYN/wet_dry.F90
r13295 r13998 57 57 REAL(wp), PUBLIC :: ssh_ref !: height of z=0 with respect to the geoid; 58 58 59 LOGICAL, PUBLIC :: ll_wd !: Wetting/drying activation switch if either ln_wd_il or ln_wd_dl59 LOGICAL, PUBLIC :: ll_wd = .FALSE. !: Wetting/drying activation switch (ln_wd_il or ln_wd_dl) <- default def if wad_init not called 60 60 61 61 PUBLIC wad_init ! initialisation routine called by step.F90 … … 111 111 112 112 r_rn_wdmin1 = 1 / rn_wdmin1 113 ll_wd = .FALSE.114 113 IF( ln_wd_il .OR. ln_wd_dl ) THEN 115 114 ll_wd = .TRUE. … … 307 306 zwdlmtv(:,:) = 1._wp 308 307 ! 309 DO_2D( 0, 1, 0, 1 ) 308 DO_2D( 0, 1, 0, 1 ) ! Horizontal Flux in u and v direction 310 309 ! 311 310 IF( tmask(ji, jj, 1 ) < 0.5_wp) CYCLE ! we don't care about land cells -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/FLO/flo_oce.F90
r11536 r13998 19 19 !! ---------------- 20 20 LOGICAL, PUBLIC :: ln_floats !: Activate floats or not 21 INTEGER, PUBLIC :: jpnfl 21 INTEGER, PUBLIC :: jpnfl = 0 !: total number of floats during the run 22 22 INTEGER, PUBLIC :: jpnnewflo !: number of floats added in a new run 23 23 INTEGER, PUBLIC :: jpnrstflo !: number of floats for the restart -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/ICB/icbtrj.F90
r13062 r13998 35 35 PUBLIC icb_trj_end ! routine called in icbstp.F90 module 36 36 37 INTEGER :: num_traj 37 INTEGER :: num_traj = 0 38 38 INTEGER :: n_dim, m_dim 39 39 INTEGER :: ntrajid -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/IOM/iom.F90
r13512 r13998 123 123 REAL(wp), DIMENSION(2,jpkam1) :: za_bnds ! ABL vertical boundaries 124 124 LOGICAL :: ll_closedef = .TRUE. 125 LOGICAL :: ll_exist 125 126 !!---------------------------------------------------------------------- 126 127 ! … … 235 236 CALL iom_set_axis_attr( "ghw_abl", bounds=za_bnds ) 236 237 237 CALL iom_set_axis_attr( "nfloat", (/ (REAL(ji,wp), ji=1,jpnfl) /) )238 CALL iom_set_axis_attr( "nfloat", (/ (REAL(ji,wp), ji=1,jpnfl) /) ) 238 239 # if defined key_si3 239 240 CALL iom_set_axis_attr( "ncatice", (/ (REAL(ji,wp), ji=1,jpl) /) ) … … 248 249 CALL iom_set_axis_attr( "iax_26C", (/ REAL(26,wp) /) ) ! strange syntaxe and idea... 249 250 CALL iom_set_axis_attr( "iax_28C", (/ REAL(28,wp) /) ) ! strange syntaxe and idea... 250 CALL iom_set_axis_attr( "basin" , (/ (REAL(ji,wp), ji=1,5) /) ) 251 ! for diaprt, we need to define an axis which size can be 1 (default) or 5 (if the file subbasins.nc exists) 252 INQUIRE( FILE = 'subbasins.nc', EXIST = ll_exist ) 253 nbasin = 1 + 4 * COUNT( (/ll_exist/) ) 254 CALL iom_set_axis_attr( "basin" , (/ (REAL(ji,wp), ji=1,nbasin) /) ) 251 255 ENDIF 252 256 ! … … 355 359 rst_file = TRIM(clpath)//TRIM(cn_ocerst_in) 356 360 ELSE 357 rst_file = TRIM(clpath)// '1_'//TRIM(cn_ocerst_in)361 rst_file = TRIM(clpath)//TRIM(Agrif_CFixed())//'_'//TRIM(cn_ocerst_in) 358 362 ENDIF 359 363 !set name of the restart file and enable available fields … … 1915 1919 IF( iom_use(cdname) ) THEN 1916 1920 #if defined key_iomput 1917 IF( SIZE(pfield2d, dim=1) == jpi .AND. SIZE(pfield2d, dim=2) == jpj ) THEN 1918 CALL xios_send_field( cdname, pfield2d(Nis0:Nie0, Njs0:Nje0) ) ! this extraction will create a copy of pfield2d 1919 ELSE 1920 CALL xios_send_field( cdname, pfield2d ) 1921 ENDIF 1921 CALL xios_send_field( cdname, pfield2d ) 1922 1922 #else 1923 1923 WRITE(numout,*) pfield2d ! iom_use(cdname) = .F. -> useless test to avoid compilation warnings … … 1931 1931 IF( iom_use(cdname) ) THEN 1932 1932 #if defined key_iomput 1933 IF( SIZE(pfield2d, dim=1) == jpi .AND. SIZE(pfield2d, dim=2) == jpj ) THEN 1934 CALL xios_send_field( cdname, pfield2d(Nis0:Nie0, Njs0:Nje0) ) ! this extraction will create a copy of pfield2d 1935 ELSE 1936 CALL xios_send_field( cdname, pfield2d ) 1937 ENDIF 1933 CALL xios_send_field( cdname, pfield2d ) 1938 1934 #else 1939 1935 WRITE(numout,*) pfield2d ! iom_use(cdname) = .F. -> useless test to avoid compilation warnings … … 1947 1943 IF( iom_use(cdname) ) THEN 1948 1944 #if defined key_iomput 1949 IF( SIZE(pfield3d, dim=1) == jpi .AND. SIZE(pfield3d, dim=2) == jpj ) THEN 1950 CALL xios_send_field( cdname, pfield3d(Nis0:Nie0, Njs0:Nje0,:) ) ! this extraction will create a copy of pfield3d 1951 ELSE 1952 CALL xios_send_field( cdname, pfield3d ) 1953 ENDIF 1945 CALL xios_send_field( cdname, pfield3d ) 1954 1946 #else 1955 1947 WRITE(numout,*) pfield3d ! iom_use(cdname) = .F. -> useless test to avoid compilation warnings … … 1963 1955 IF( iom_use(cdname) ) THEN 1964 1956 #if defined key_iomput 1965 IF( SIZE(pfield3d, dim=1) == jpi .AND. SIZE(pfield3d, dim=2) == jpj ) THEN 1966 CALL xios_send_field( cdname, pfield3d(Nis0:Nie0, Njs0:Nje0,:) ) ! this extraction will create a copy of pfield3d 1967 ELSE 1968 CALL xios_send_field( cdname, pfield3d ) 1969 ENDIF 1957 CALL xios_send_field( cdname, pfield3d ) 1970 1958 #else 1971 1959 WRITE(numout,*) pfield3d ! iom_use(cdname) = .F. -> useless test to avoid compilation warnings … … 1979 1967 IF( iom_use(cdname) ) THEN 1980 1968 #if defined key_iomput 1981 IF( SIZE(pfield4d, dim=1) == jpi .AND. SIZE(pfield4d, dim=2) == jpj ) THEN 1982 CALL xios_send_field( cdname, pfield4d(Nis0:Nie0, Njs0:Nje0,:,:) ) ! this extraction will create a copy of pfield4d 1983 ELSE 1984 CALL xios_send_field (cdname, pfield4d ) 1985 ENDIF 1969 CALL xios_send_field (cdname, pfield4d ) 1986 1970 #else 1987 1971 WRITE(numout,*) pfield4d ! iom_use(cdname) = .F. -> useless test to avoid compilation warnings … … 1995 1979 IF( iom_use(cdname) ) THEN 1996 1980 #if defined key_iomput 1997 IF( SIZE(pfield4d, dim=1) == jpi .AND. SIZE(pfield4d, dim=2) == jpj ) THEN 1998 CALL xios_send_field( cdname, pfield4d(Nis0:Nie0, Njs0:Nje0,:,:) ) ! this extraction will create a copy of pfield4d 1999 ELSE 2000 CALL xios_send_field (cdname, pfield4d ) 2001 ENDIF 1981 CALL xios_send_field (cdname, pfield4d ) 2002 1982 #else 2003 1983 WRITE(numout,*) pfield4d ! iom_use(cdname) = .F. -> useless test to avoid compilation warnings … … 2205 2185 ! 2206 2186 CALL iom_set_domain_attr("grid_"//cdgrd, ni_glo=Ni0glo,nj_glo=Nj0glo,ibegin=mig0(Nis0)-1,jbegin=mjg0(Njs0)-1,ni=Ni_0,nj=Nj_0) 2207 CALL iom_set_domain_attr("grid_"//cdgrd, data_dim=2, data_ibegin = 0, data_ni = Ni_0, data_jbegin = 0, data_nj = Nj_0)2187 CALL iom_set_domain_attr("grid_"//cdgrd, data_dim=2, data_ibegin = -nn_hls, data_ni = jpi, data_jbegin = -nn_hls, data_nj = jpj) 2208 2188 !don't define lon and lat for restart reading context. 2209 2189 IF ( .NOT.ldrxios ) & … … 2304 2284 CALL dom_ngb( 180.0_wp, 90.0_wp, ix, iy, 'T' ) ! i-line that passes near the North Pole : Reference latitude (used in plots) 2305 2285 CALL iom_set_domain_attr("gznl", ni_glo=Ni0glo, nj_glo=Nj0glo, ibegin=mig0(Nis0)-1, jbegin=mjg0(Njs0)-1, ni=Ni_0, nj=Nj_0) 2306 CALL iom_set_domain_attr("gznl", data_dim=2, data_ibegin = 0, data_ni = Ni_0, data_jbegin = 0, data_nj = Nj_0)2286 CALL iom_set_domain_attr("gznl", data_dim=2, data_ibegin = -nn_hls, data_ni = jpi, data_jbegin = -nn_hls, data_nj = jpj) 2307 2287 CALL iom_set_domain_attr("gznl", lonvalue = real(zlon, dp), & 2308 2288 & latvalue = real(RESHAPE(plat(Nis0:Nie0, Njs0:Nje0),(/ Ni_0*Nj_0 /)),dp)) 2309 CALL iom_set_zoom_domain_attr("ptr", ibegin=ix-1, jbegin=0, ni=1, nj=Nj _0)2289 CALL iom_set_zoom_domain_attr("ptr", ibegin=ix-1, jbegin=0, ni=1, nj=Nj0glo) 2310 2290 ! 2311 2291 CALL iom_update_file_name('ptr') -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/IOM/iom_def.F90
r13286 r13998 33 33 INTEGER, PUBLIC :: iom_open_init = 0 !: used to initialize iom_file(:)%nfid to 0 34 34 !XIOS write restart 35 LOGICAL, PUBLIC :: lwxios 36 INTEGER, PUBLIC :: nxioso !: type of restart file when writing using XIOS 1 - single, 2 - multiple35 LOGICAL, PUBLIC :: lwxios = .FALSE. !: write single file restart using XIOS 36 INTEGER, PUBLIC :: nxioso = 0 !: type of restart file when writing using XIOS 1 - single, 2 - multiple 37 37 !XIOS read restart 38 LOGICAL, PUBLIC :: lrxios 38 LOGICAL, PUBLIC :: lrxios = .FALSE. !: read single file restart using XIOS 39 39 LOGICAL, PUBLIC :: lxios_sini = .FALSE. ! is restart in a single file 40 40 LOGICAL, PUBLIC :: lxios_set = .FALSE. -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/ISF/isf_oce.F90
r12077 r13998 74 74 ! 75 75 ! 2.1 -------- ice shelf cavity parameter -------------- 76 LOGICAL , PUBLIC :: l_isfoasis 76 LOGICAL , PUBLIC :: l_isfoasis = .FALSE. 77 77 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: risfload !: ice shelf load 78 78 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fwfisf_oasis -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/ISF/isfcavmlt.F90
r13295 r13998 136 136 !! ** Method : The ice shelf melt latent heat is defined as being equal to the ocean/ice heat flux. 137 137 !! From this we can derived the fwf, ocean/ice heat flux and the heat content flux as being : 138 !! qfwf = Gammat * Rau0 * Cp * ( Tw - Tfrz ) / Lf138 !! qfwf = Gammat * rho0 * Cp * ( Tw - Tfrz ) / Lf 139 139 !! qhoce = qlat 140 140 !! qhc = qfwf * Cp * Tfrz -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/LBC/lbc_lnk_multi_generic.h90
r13286 r13998 35 35 #endif 36 36 37 SUBROUTINE ROUTINE_MULTI( cdname & 38 & , pt1, cdna1, psgn1, pt2 , cdna2 , psgn2 , pt3 , cdna3 , psgn3 , pt4, cdna4, psgn4 & 39 & , pt5, cdna5, psgn5, pt6 , cdna6 , psgn6 , pt7 , cdna7 , psgn7 , pt8, cdna8, psgn8 & 40 & , pt9, cdna9, psgn9, pt10, cdna10, psgn10, pt11, cdna11, psgn11 & 37 SUBROUTINE ROUTINE_MULTI( cdname & 38 & , pt1 , cdna1 , psgn1 , pt2 , cdna2 , psgn2 , pt3 , cdna3 , psgn3 , pt4 , cdna4 , psgn4 & 39 & , pt5 , cdna5 , psgn5 , pt6 , cdna6 , psgn6 , pt7 , cdna7 , psgn7 , pt8 , cdna8 , psgn8 & 40 & , pt9 , cdna9 , psgn9 , pt10, cdna10, psgn10, pt11, cdna11, psgn11, pt12, cdna12, psgn12 & 41 & , pt13, cdna13, psgn13, pt14, cdna14, psgn14, pt15, cdna15, psgn15, pt16, cdna16, psgn16 & 41 42 & , kfillmode, pfillval, lsend, lrecv ) 42 43 !!--------------------------------------------------------------------- 43 CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine 44 ARRAY_TYPE(:,:,:,:) , TARGET, INTENT(inout) :: pt1 ! arrays on which the lbc is applied 45 ARRAY_TYPE(:,:,:,:), OPTIONAL, TARGET, INTENT(inout) :: pt2 , pt3 , pt4 , pt5 , pt6 , pt7 , pt8 , pt9 , pt10 , pt11 46 CHARACTER(len=1) , INTENT(in ) :: cdna1 ! nature of pt2D. array grid-points 47 CHARACTER(len=1) , OPTIONAL , INTENT(in ) :: cdna2, cdna3, cdna4, cdna5, cdna6, cdna7, cdna8, cdna9, cdna10, cdna11 48 REAL(wp) , INTENT(in ) :: psgn1 ! sign used across the north fold 49 REAL(wp) , OPTIONAL , INTENT(in ) :: psgn2, psgn3, psgn4, psgn5, psgn6, psgn7, psgn8, psgn9, psgn10, psgn11 50 INTEGER , OPTIONAL , INTENT(in ) :: kfillmode ! filling method for halo over land (default = constant) 51 REAL(wp) , OPTIONAL , INTENT(in ) :: pfillval ! background value (used at closed boundaries) 52 LOGICAL, DIMENSION(4), OPTIONAL , INTENT(in ) :: lsend, lrecv ! indicate how communications are to be carried out 44 CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine 45 ARRAY_TYPE(:,:,:,:) , TARGET, INTENT(inout) :: pt1 ! arrays on which the lbc is applied 46 ARRAY_TYPE(:,:,:,:) , OPTIONAL, TARGET, INTENT(inout) :: pt2 , pt3 , pt4 , pt5 , pt6 , pt7 , pt8 , pt9 , & 47 & pt10 , pt11 , pt12 , pt13 , pt14 , pt15 , pt16 48 CHARACTER(len=1) , INTENT(in ) :: cdna1 ! nature of pt2D. array grid-points 49 CHARACTER(len=1) , OPTIONAL , INTENT(in ) :: cdna2 , cdna3 , cdna4 , cdna5 , cdna6 , cdna7 , cdna8 , cdna9, & 50 & cdna10, cdna11, cdna12, cdna13, cdna14, cdna15, cdna16 51 REAL(wp) , INTENT(in ) :: psgn1 ! sign used across the north fold 52 REAL(wp) , OPTIONAL , INTENT(in ) :: psgn2 , psgn3 , psgn4 , psgn5 , psgn6 , psgn7 , psgn8 , psgn9, & 53 & psgn10, psgn11, psgn12, psgn13, psgn14, psgn15, psgn16 54 INTEGER , OPTIONAL , INTENT(in ) :: kfillmode ! filling method for halo over land (default = constant) 55 REAL(wp) , OPTIONAL , INTENT(in ) :: pfillval ! background value (used at closed boundaries) 56 LOGICAL, DIMENSION(4), OPTIONAL , INTENT(in ) :: lsend, lrecv ! indicate how communications are to be carried out 53 57 !! 54 58 INTEGER :: kfld ! number of elements that will be attributed 55 PTR_TYPE , DIMENSION(1 1) :: ptab_ptr ! pointer array56 CHARACTER(len=1) , DIMENSION(1 1) :: cdna_ptr ! nature of ptab_ptr grid-points57 REAL(wp) , DIMENSION(1 1) :: psgn_ptr ! sign used across the north fold boundary59 PTR_TYPE , DIMENSION(16) :: ptab_ptr ! pointer array 60 CHARACTER(len=1) , DIMENSION(16) :: cdna_ptr ! nature of ptab_ptr grid-points 61 REAL(wp) , DIMENSION(16) :: psgn_ptr ! sign used across the north fold boundary 58 62 !!--------------------------------------------------------------------- 59 63 ! … … 74 78 IF( PRESENT(psgn10) ) CALL ROUTINE_LOAD( pt10, cdna10, psgn10, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 75 79 IF( PRESENT(psgn11) ) CALL ROUTINE_LOAD( pt11, cdna11, psgn11, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 80 IF( PRESENT(psgn12) ) CALL ROUTINE_LOAD( pt12, cdna12, psgn12, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 81 IF( PRESENT(psgn13) ) CALL ROUTINE_LOAD( pt13, cdna13, psgn13, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 82 IF( PRESENT(psgn14) ) CALL ROUTINE_LOAD( pt14, cdna14, psgn14, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 83 IF( PRESENT(psgn15) ) CALL ROUTINE_LOAD( pt15, cdna15, psgn15, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 84 IF( PRESENT(psgn16) ) CALL ROUTINE_LOAD( pt16, cdna16, psgn16, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 76 85 ! 77 CALL lbc_lnk_ptr ( cdname,ptab_ptr, cdna_ptr, psgn_ptr, kfld, kfillmode, pfillval, lsend, lrecv )86 CALL lbc_lnk_ptr( cdname, ptab_ptr, cdna_ptr, psgn_ptr, kfld, kfillmode, pfillval, lsend, lrecv ) 78 87 ! 79 88 END SUBROUTINE ROUTINE_MULTI -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/LBC/lib_mpp.F90
r13286 r13998 73 73 PUBLIC tic_tac 74 74 #if ! defined key_mpp_mpi 75 PUBLIC MPI_wait 75 76 PUBLIC MPI_Wtime 76 77 #endif … … 115 116 #else 116 117 INTEGER, PUBLIC, PARAMETER :: MPI_STATUS_SIZE = 1 118 INTEGER, PUBLIC, PARAMETER :: MPI_REAL = 4 117 119 INTEGER, PUBLIC, PARAMETER :: MPI_DOUBLE_PRECISION = 8 118 120 LOGICAL, PUBLIC, PARAMETER :: lk_mpp = .FALSE. !: mpp flag … … 509 511 ALLOCATE(todelay(idvar)%y1d(isz)) 510 512 todelay(idvar)%y1d(:) = CMPLX(todelay(idvar)%z1d(:), 0., wp) ! create %y1d, complex variable needed by mpi_sumdd 513 ndelayid(idvar) = MPI_REQUEST_NULL ! initialised request to a valid value 511 514 END IF 512 515 ENDIF … … 516 519 ALLOCATE(todelay(idvar)%z1d(isz), todelay(idvar)%y1d(isz)) ! allocate also %z1d as used for the restart 517 520 CALL mpi_allreduce( y_in(:), todelay(idvar)%y1d(:), isz, MPI_DOUBLE_COMPLEX, mpi_sumdd, ilocalcomm, ierr ) ! get %y1d 518 todelay(idvar)%z1d(:) = REAL(todelay(idvar)%y1d(:), wp) ! define %z1d from %y1d519 ENDIF 520 521 IF( ndelayid(idvar) > 0 )CALL mpp_delay_rcv( idvar ) ! make sure %z1d is received521 ndelayid(idvar) = MPI_REQUEST_NULL 522 ENDIF 523 524 CALL mpp_delay_rcv( idvar ) ! make sure %z1d is received 522 525 523 526 ! send back pout from todelay(idvar)%z1d defined at previous call … … 528 531 IF( ln_timing ) CALL tic_tac( .TRUE., ld_global = .TRUE.) 529 532 CALL mpi_allreduce( y_in(:), todelay(idvar)%y1d(:), isz, MPI_DOUBLE_COMPLEX, mpi_sumdd, ilocalcomm, ierr ) 530 ndelayid(idvar) = 1533 ndelayid(idvar) = MPI_REQUEST_NULL 531 534 IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.) 532 535 # else … … 589 592 DEALLOCATE(todelay(idvar)%z1d) 590 593 ndelayid(idvar) = -1 ! do as if we had no restart 594 ELSE 595 ndelayid(idvar) = MPI_REQUEST_NULL 591 596 END IF 592 597 ENDIF … … 596 601 ALLOCATE(todelay(idvar)%z1d(isz)) 597 602 CALL mpi_allreduce( p_in(:), todelay(idvar)%z1d(:), isz, MPI_DOUBLE_PRECISION, mpi_max, ilocalcomm, ierr ) ! get %z1d 598 ENDIF 599 600 IF( ndelayid(idvar) > 0 ) CALL mpp_delay_rcv( idvar ) ! make sure %z1d is received 603 ndelayid(idvar) = MPI_REQUEST_NULL 604 ENDIF 605 606 CALL mpp_delay_rcv( idvar ) ! make sure %z1d is received 601 607 602 608 ! send back pout from todelay(idvar)%z1d defined at previous call … … 604 610 605 611 ! send p_in into todelay(idvar)%z1d with a non-blocking communication 612 ! (PM) Should we get rid of MPI2 option ? MPI3 was release in 2013. Who is still using MPI2 ? 606 613 # if defined key_mpi2 607 614 IF( ln_timing ) CALL tic_tac( .TRUE., ld_global = .TRUE.) 608 CALL mpi_allreduce( p_in(:), todelay(idvar)%z1d(:), isz, MPI_TYPE, mpi_max, ilocalcomm, ndelayid(idvar),ierr )615 CALL mpi_allreduce( p_in(:), todelay(idvar)%z1d(:), isz, MPI_TYPE, mpi_max, ilocalcomm, ierr ) 609 616 IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.) 610 617 # else … … 629 636 !!---------------------------------------------------------------------- 630 637 #if defined key_mpp_mpi 631 IF( ndelayid(kid) /= -2 ) THEN 632 #if ! defined key_mpi2 633 IF( ln_timing ) CALL tic_tac( .TRUE., ld_global = .TRUE.) 634 CALL mpi_wait( ndelayid(kid), MPI_STATUS_IGNORE, ierr ) ! make sure todelay(kid) is received 635 IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.) 636 #endif 637 IF( ASSOCIATED(todelay(kid)%y1d) ) todelay(kid)%z1d(:) = REAL(todelay(kid)%y1d(:), wp) ! define %z1d from %y1d 638 ndelayid(kid) = -2 ! add flag to know that mpi_wait was already called on kid 639 ENDIF 638 IF( ln_timing ) CALL tic_tac( .TRUE., ld_global = .TRUE.) 639 ! test on ndelayid(kid) useless as mpi_wait return immediatly if the request handle is MPI_REQUEST_NULL 640 CALL mpi_wait( ndelayid(kid), MPI_STATUS_IGNORE, ierr ) ! after this ndelayid(kid) = MPI_REQUEST_NULL 641 IF( ln_timing ) CALL tic_tac( .FALSE., ld_global = .TRUE.) 642 IF( ASSOCIATED(todelay(kid)%y1d) ) todelay(kid)%z1d(:) = REAL(todelay(kid)%y1d(:), wp) ! define %z1d from %y1d 640 643 #endif 641 644 END SUBROUTINE mpp_delay_rcv -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/LBC/mpp_lbc_north_icb_generic.h90
r13286 r13998 67 67 ! 68 68 IF( ln_timing ) CALL tic_tac(.TRUE.) 69 #if defined key_mpp_mpi 69 70 CALL MPI_ALLGATHER( znorthloc_e(1,1-kextj) , itaille, MPI_TYPE, & 70 71 & znorthgloio_e(1,1-kextj,1), itaille, MPI_TYPE, & 71 72 & ncomm_north, ierr ) 73 #endif 72 74 ! 73 75 IF( ln_timing ) CALL tic_tac(.FALSE.) -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/LBC/mpp_loc_generic.h90
r13286 r13998 2 2 # if defined SINGLE_PRECISION 3 3 # define ARRAY_TYPE(i,j,k) REAL(sp) , INTENT(in ) :: ARRAY_IN(i,j,k) 4 # define MASK_TYPE(i,j,k) REAL(sp) , INTENT(in ) :: MASK_IN(i,j,k) 4 #if defined key_mpp_mpi 5 # define MPI_TYPE MPI_2REAL 6 #endif 5 7 # define PRECISION sp 6 8 # else 7 9 # define ARRAY_TYPE(i,j,k) REAL(dp) , INTENT(in ) :: ARRAY_IN(i,j,k) 8 # define MASK_TYPE(i,j,k) REAL(dp) , INTENT(in ) :: MASK_IN(i,j,k) 10 #if defined key_mpp_mpi 11 # define MPI_TYPE MPI_2DOUBLE_PRECISION 12 #endif 9 13 # define PRECISION dp 10 14 # endif … … 12 16 # if defined DIM_2d 13 17 # define ARRAY_IN(i,j,k) ptab(i,j) 14 # define MASK_IN(i,j,k) pmask(i,j)18 # define MASK_IN(i,j,k) ldmsk(i,j) 15 19 # define INDEX_TYPE(k) INTEGER , INTENT( out) :: kindex(2) 16 20 # define K_SIZE(ptab) 1 … … 18 22 # if defined DIM_3d 19 23 # define ARRAY_IN(i,j,k) ptab(i,j,k) 20 # define MASK_IN(i,j,k) pmask(i,j,k)24 # define MASK_IN(i,j,k) ldmsk(i,j,k) 21 25 # define INDEX_TYPE(k) INTEGER , INTENT( out) :: kindex(3) 22 26 # define K_SIZE(ptab) SIZE(ptab,3) 23 27 # endif 24 28 # if defined OPERATION_MAXLOC 25 # define MPI_OPERATION mpi_maxloc29 # define MPI_OPERATION MPI_MAXLOC 26 30 # define LOC_OPERATION MAXLOC 27 31 # define ERRVAL -HUGE 28 32 # endif 29 33 # if defined OPERATION_MINLOC 30 # define MPI_OPERATION mpi_minloc34 # define MPI_OPERATION MPI_MINLOC 31 35 # define LOC_OPERATION MINLOC 32 36 # define ERRVAL HUGE 33 37 # endif 34 38 35 SUBROUTINE ROUTINE_LOC( cdname, ptab, pmask, pmin, kindex)39 SUBROUTINE ROUTINE_LOC( cdname, ptab, ldmsk, pmin, kindex, ldhalo ) 36 40 !!---------------------------------------------------------------------- 37 CHARACTER(len=*), INTENT(in ) :: cdname ! name of the calling subroutine41 CHARACTER(len=*), INTENT(in ) :: cdname ! name of the calling subroutine 38 42 ARRAY_TYPE(:,:,:) ! array on which loctrans operation is applied 39 MASK_TYPE(:,:,:)! local mask40 REAL(PRECISION) 43 LOGICAL , INTENT(in ) :: MASK_IN(:,:,:) ! local mask 44 REAL(PRECISION) , INTENT( out) :: pmin ! Global minimum of ptab 41 45 INDEX_TYPE(:) ! index of minimum in global frame 46 LOGICAL, OPTIONAL, INTENT(in ) :: ldhalo ! If .false. (default) excludes halos in kindex 42 47 ! 43 48 INTEGER :: ierror, ii, idim 44 49 INTEGER :: index0 50 INTEGER , DIMENSION(:), ALLOCATABLE :: ilocs 45 51 REAL(PRECISION) :: zmin ! local minimum 46 INTEGER , DIMENSION(:), ALLOCATABLE :: ilocs47 REAL(dp), DIMENSION(2,1) :: zain, zaout52 REAL(PRECISION), DIMENSION(2,1) :: zain, zaout 53 LOGICAL :: llhalo 48 54 !!----------------------------------------------------------------------- 49 55 ! 50 56 IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, ld_glb = .TRUE. ) 51 57 ! 58 IF( PRESENT(ldhalo) ) THEN ; llhalo = ldhalo 59 ELSE ; llhalo = .FALSE. 60 ENDIF 61 ! 52 62 idim = SIZE(kindex) 53 63 ! 54 IF ( ALL(MASK_IN(:,:,:) /= 1._wp) ) THEN 55 ! special case for land processors 56 zmin = ERRVAL(zmin) 57 index0 = 0 58 ELSE 64 IF ( ANY( MASK_IN(:,:,:) ) ) THEN ! there is at least 1 valid point... 65 ! 59 66 ALLOCATE ( ilocs(idim) ) 60 67 ! 61 ilocs = LOC_OPERATION( ARRAY_IN(:,:,:) , mask= MASK_IN(:,:,:) == 1._wp)68 ilocs = LOC_OPERATION( ARRAY_IN(:,:,:) , mask= MASK_IN(:,:,:) ) 62 69 zmin = ARRAY_IN(ilocs(1),ilocs(2),ilocs(3)) 63 70 ! … … 79 86 index0 = index0 + jpiglo * jpjglo * (kindex(3)-1) 80 87 #endif 88 ELSE 89 ! special case for land processors 90 zmin = ERRVAL(zmin) 91 index0 = 0 81 92 END IF 93 ! 82 94 zain(1,:) = zmin 83 zain(2,:) = REAL(index0, wp)95 zain(2,:) = REAL(index0, PRECISION) 84 96 ! 97 #if defined key_mpp_mpi 85 98 IF( ln_timing ) CALL tic_tac(.TRUE., ld_global = .TRUE.) 86 #if defined key_mpp_mpi 87 CALL MPI_ALLREDUCE( zain, zaout, 1, MPI_2DOUBLE_PRECISION, MPI_OPERATION ,MPI_COMM_OCE, ierror)99 CALL MPI_ALLREDUCE( zain, zaout, 1, MPI_TYPE, MPI_OPERATION ,MPI_COMM_OCE, ierror) 100 IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.) 88 101 #else 89 102 zaout(:,:) = zain(:,:) 90 103 #endif 91 IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.)92 104 ! 93 105 pmin = zaout(1,1) … … 104 116 kindex(:) = kindex(:) + 1 ! start indices at 1 105 117 118 IF( .NOT. llhalo ) THEN 119 kindex(1) = kindex(1) - nn_hls 120 #if defined DIM_2d || defined DIM_3d /* avoid warning when kindex has 1 element */ 121 kindex(2) = kindex(2) - nn_hls 122 #endif 123 ENDIF 124 106 125 END SUBROUTINE ROUTINE_LOC 107 126 … … 109 128 #undef PRECISION 110 129 #undef ARRAY_TYPE 111 #undef MASK_TYPE112 130 #undef ARRAY_IN 113 131 #undef MASK_IN 114 132 #undef K_SIZE 133 #if defined key_mpp_mpi 134 # undef MPI_TYPE 135 #endif 115 136 #undef MPI_OPERATION 116 137 #undef LOC_OPERATION -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/LBC/mpp_nfd_generic.h90
r13290 r13998 317 317 ! start waiting time measurement 318 318 IF( ln_timing ) CALL tic_tac(.TRUE.) 319 #if defined key_mpp_mpi 319 320 CALL MPI_ALLGATHER( znorthloc, ibuffsize, MPI_TYPE, znorthglo, ibuffsize, MPI_TYPE, ncomm_north, ierr ) 321 #endif 320 322 ! stop waiting time measurement 321 323 IF( ln_timing ) CALL tic_tac(.FALSE.) -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/LBC/mppini.F90
r13915 r13998 62 62 !!---------------------------------------------------------------------- 63 63 ! 64 jpiglo = Ni0glo 65 jpjglo = Nj0glo 64 nn_hls = 1 65 jpiglo = Ni0glo + 2 * nn_hls 66 jpjglo = Nj0glo + 2 * nn_hls 66 67 jpimax = jpiglo 67 68 jpjmax = jpjglo … … 72 73 jpjm1 = jpj-1 ! " " 73 74 jpkm1 = MAX( 1, jpk-1 ) ! " " 74 !75 CALL init_doloop ! set start/end indices or do-loop depending on the halo width value (nn_hls)76 !77 75 jpij = jpi*jpj 78 76 jpni = 1 79 77 jpnj = 1 80 78 jpnij = jpni*jpnj 81 nn_hls = 182 79 nimpp = 1 83 80 njmpp = 1 … … 91 88 l_Jperio = jpnj == 1 .AND. (jperio == 2 .OR. jperio == 7) 92 89 ! 90 CALL init_doloop ! set start/end indices or do-loop depending on the halo width value (nn_hls) 91 ! 93 92 IF(lwp) THEN 94 93 WRITE(numout,*) … … 99 98 ENDIF 100 99 ! 101 IF( jpni /= 1 .OR. jpnj /= 1 .OR. jpnij /= 1 ) &102 CALL ctl_stop( 'mpp_init: equality jpni = jpnj = jpnij = 1 is not satisfied', &103 & 'the domain is lay out for distributed memory computing!' )104 !105 100 #if defined key_agrif 106 101 IF (.NOT.agrif_root()) THEN … … 676 671 END SUBROUTINE mpp_init 677 672 673 #endif 678 674 679 675 SUBROUTINE mpp_basesplit( kiglo, kjglo, khls, knbi, knbj, kimax, kjmax, kimppt, kjmppt, klci, klcj) … … 790 786 !! ** Method : 791 787 !!---------------------------------------------------------------------- 792 INTEGER, INTENT(in ) :: knbij ! total number if subdomains(knbi*knbj)788 INTEGER, INTENT(in ) :: knbij ! total number of subdomains (knbi*knbj) 793 789 INTEGER, OPTIONAL, INTENT( out) :: knbi, knbj ! number if subdomains along i and j (knbi and knbj) 794 790 INTEGER, OPTIONAL, INTENT( out) :: knbcnt ! number of land subdomains … … 798 794 INTEGER :: iszitst, iszjtst 799 795 INTEGER :: isziref, iszjref 796 INTEGER :: iszimin, iszjmin 800 797 INTEGER :: inbij, iszij 801 798 INTEGER :: inbimax, inbjmax, inbijmax, inbijold … … 826 823 inbimax = 0 827 824 inbjmax = 0 828 isziref = Ni0glo*Nj0glo+1 829 iszjref = Ni0glo*Nj0glo+1 825 isziref = jpiglo*jpjglo+1 ! define a value that is larger than the largest possible 826 iszjref = jpiglo*jpjglo+1 827 ! 828 iszimin = 4*nn_hls ! minimum size of the MPI subdomain so halos are always adressing neighbor inner domain 829 iszjmin = 4*nn_hls 830 IF( jperio == 3 .OR. jperio == 4 ) iszjmin = MAX(iszjmin, 2+3*nn_hls) ! V and F folding must be outside of southern halos 831 IF( jperio == 5 .OR. jperio == 6 ) iszjmin = MAX(iszjmin, 1+3*nn_hls) ! V and F folding must be outside of southern halos 830 832 ! 831 833 ! get the list of knbi that gives a smaller jpimax than knbi-1 … … 835 837 iszitst = ( nx_global+2-2*nn_hls + (ji-1) ) / ji + 2*nn_hls ! first dim. 836 838 #else 837 iszitst = ( Ni0glo + (ji-1) ) / ji 839 iszitst = ( Ni0glo + (ji-1) ) / ji + 2*nn_hls ! max subdomain i-size 838 840 #endif 839 IF( iszitst < isziref ) THEN841 IF( iszitst < isziref .AND. iszitst >= iszimin ) THEN 840 842 isziref = iszitst 841 843 inbimax = inbimax + 1 … … 846 848 iszjtst = ( ny_global+2-2*nn_hls + (ji-1) ) / ji + 2*nn_hls ! first dim. 847 849 #else 848 iszjtst = ( Nj0glo + (ji-1) ) / ji 850 iszjtst = ( Nj0glo + (ji-1) ) / ji + 2*nn_hls ! max subdomain j-size 849 851 #endif 850 IF( iszjtst < iszjref ) THEN852 IF( iszjtst < iszjref .AND. iszjtst >= iszjmin ) THEN 851 853 iszjref = iszjtst 852 854 inbjmax = inbjmax + 1 … … 901 903 isz0 = 0 ! number of best partitions 902 904 inbij = 1 ! start with the min value of inbij1 => 1 903 iszij = Ni0glo*Nj0glo+1 ! default: larger than global domain905 iszij = jpiglo*jpjglo+1 ! default: larger than global domain 904 906 DO WHILE( inbij <= inbijmax ) ! if we did not reach the max of inbij1 905 907 ii = MINLOC(iszij1, mask = inbij1 == inbij, dim = 1) ! warning: send back the first occurence if multiple results 906 908 IF ( iszij1(ii) < iszij ) THEN 909 ii = MINLOC( iszi1+iszj1, mask = iszij1 == iszij1(ii) .AND. inbij1 == inbij, dim = 1) ! select the smaller perimeter if multiple min 907 910 isz0 = isz0 + 1 908 911 indexok(isz0) = ii … … 1322 1325 END SUBROUTINE init_nfdcom 1323 1326 1324 #endif1325 1327 1326 1328 SUBROUTINE init_doloop -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/LDF/ldfc1d_c2d.F90
r13295 r13998 80 80 pah1(:,:,jk) = pahs1(:,:) * ( zratio + zc * ( 1._wp + TANH( - ( gdept_0(:,:,jk) - zh ) * zw) ) ) 81 81 END DO 82 DO_3DS( 1, 0, 1, 0, jpkm1, 1, -1 ) 82 DO_3DS( 1, 0, 1, 0, jpkm1, 1, -1 ) ! pah2 at F-point (zdep2 is an approximation in zps-coord.) 83 83 zdep2 = ( gdept_0(ji,jj+1,jk) + gdept_0(ji+1,jj+1,jk) & 84 84 & + gdept_0(ji,jj ,jk) + gdept_0(ji+1,jj ,jk) ) * r1_4 -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/LDF/ldfdyn.F90
r13769 r13998 325 325 IF( ierr /= 0 ) CALL ctl_stop( 'STOP', 'ldf_dyn_init: failed to allocate Smagorinsky arrays') 326 326 ! 327 DO_2D( 1, 1, 1, 1 ) 327 DO_2D( 1, 1, 1, 1 ) ! Set local gridscale values 328 328 esqt(ji,jj) = ( 2._wp * e1e2t(ji,jj) / ( e1t(ji,jj) + e2t(ji,jj) ) )**2 329 329 esqf(ji,jj) = ( 2._wp * e1e2f(ji,jj) / ( e1f(ji,jj) + e2f(ji,jj) ) )**2 … … 448 448 DO jk = 1, jpkm1 449 449 ! 450 DO_2D( 0, 0, 0, 0 ) 450 DO_2D( 0, 0, 0, 0 ) ! T-point value 451 451 ! 452 452 zu2pv2_ij = uu(ji ,jj ,jk,Kbb) * uu(ji ,jj ,jk,Kbb) + vv(ji ,jj ,jk,Kbb) * vv(ji ,jj ,jk,Kbb) … … 462 462 END_2D 463 463 ! 464 DO_2D( 1, 0, 1, 0 ) 464 DO_2D( 1, 0, 1, 0 ) ! F-point value 465 465 ! 466 466 zu2pv2_ij_p1 = uu(ji ,jj+1,jk, kbb) * uu(ji ,jj+1,jk, kbb) + vv(ji+1,jj ,jk, kbb) * vv(ji+1,jj ,jk, kbb) -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/LDF/ldfslp.F90
r13295 r13998 128 128 IF( ln_timing ) CALL timing_start('ldf_slp') 129 129 ! 130 zeps = 1.e-20_wp !== Local constant initialization ==!130 zeps = 1.e-20_wp !== Local constant initialization ==! 131 131 z1_16 = 1.0_wp / 16._wp 132 132 zm1_g = -1.0_wp / grav … … 137 137 zwz(:,:,:) = 0._wp 138 138 ! 139 DO_3D( 1, 0, 1, 0, 1, jpk ) 139 DO_3D( 1, 0, 1, 0, 1, jpk ) !== i- & j-gradient of density ==! 140 140 zgru(ji,jj,jk) = umask(ji,jj,jk) * ( prd(ji+1,jj ,jk) - prd(ji,jj,jk) ) 141 141 zgrv(ji,jj,jk) = vmask(ji,jj,jk) * ( prd(ji ,jj+1,jk) - prd(ji,jj,jk) ) … … 154 154 ENDIF 155 155 ! 156 zdzr(:,:,1) = 0._wp !== Local vertical density gradient at T-point == ! (evaluated from N^2)156 zdzr(:,:,1) = 0._wp !== Local vertical density gradient at T-point == ! (evaluated from N^2) 157 157 DO jk = 2, jpkm1 158 158 ! ! zdzr = d/dz(prd)= - ( prd ) / grav * mk(pn2) -- at t point … … 165 165 END DO 166 166 ! 167 ! !== Slopes just below the mixed layer ==!167 ! !== Slopes just below the mixed layer ==! 168 168 CALL ldf_slp_mxl( prd, pn2, zgru, zgrv, zdzr, Kmm ) ! output: uslpml, vslpml, wslpiml, wslpjml 169 169 … … 186 186 END IF 187 187 188 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) 188 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) !* Slopes at u and v points 189 189 ! ! horizontal and vertical density gradient at u- and v-points 190 190 zau = zgru(ji,jj,jk) * r1_e1u(ji,jj) … … 231 231 CALL lbc_lnk_multi( 'ldfslp', zwz, 'U', -1.0_wp, zww, 'V', -1.0_wp ) ! lateral boundary conditions 232 232 ! 233 ! 233 ! !* horizontal Shapiro filter 234 234 DO jk = 2, jpkm1 235 DO_2D( 0, 0, 0, 0 ) 235 DO_2D( 0, 0, 0, 0 ) ! rows jj=2 and =jpjm1 only 236 236 uslp(ji,jj,jk) = z1_16 * ( zwz(ji-1,jj-1,jk) + zwz(ji+1,jj-1,jk) & 237 237 & + zwz(ji-1,jj+1,jk) + zwz(ji+1,jj+1,jk) & … … 245 245 & + 4.* zww(ji,jj ,jk) ) 246 246 END_2D 247 DO jj = 3, jpj-2 ! other rows247 DO jj = 3, jpj-2 ! other rows 248 248 DO ji = 2, jpim1 ! vector opt. 249 249 uslp(ji,jj,jk) = z1_16 * ( zwz(ji-1,jj-1,jk) + zwz(ji+1,jj-1,jk) & … … 259 259 END DO 260 260 END DO 261 ! 261 ! !* decrease along coastal boundaries 262 262 DO_2D( 0, 0, 0, 0 ) 263 263 uslp(ji,jj,jk) = uslp(ji,jj,jk) * ( umask(ji,jj+1,jk) + umask(ji,jj-1,jk ) ) * 0.5_wp & … … 307 307 ! !* horizontal Shapiro filter 308 308 DO jk = 2, jpkm1 309 DO_2D( 0, 0, 0, 0 ) 309 DO_2D( 0, 0, 0, 0 ) ! rows jj=2 and =jpjm1 only 310 310 zcofw = wmask(ji,jj,jk) * z1_16 311 311 wslpi(ji,jj,jk) = ( zwz(ji-1,jj-1,jk) + zwz(ji+1,jj-1,jk) & … … 401 401 ! 402 402 ip = jl ; jp = jl ! guaranteed nonzero gradients ( absolute value larger than repsln) 403 DO_3D( 1, 0, 1, 0, 1, jpkm1 ) 403 DO_3D( 1, 0, 1, 0, 1, jpkm1 ) ! done each pair of triad ! NB: not masked ==> a minimum value is set 404 404 zdit = ( ts(ji+1,jj,jk,jp_tem,Kbb) - ts(ji,jj,jk,jp_tem,Kbb) ) ! i-gradient of T & S at u-point 405 405 zdis = ( ts(ji+1,jj,jk,jp_sal,Kbb) - ts(ji,jj,jk,jp_sal,Kbb) ) … … 427 427 428 428 DO kp = 0, 1 !== unmasked before density i- j-, k-gradients ==! 429 DO_3D( 1, 1, 1, 1, 1, jpkm1 ) 430 IF( jk+kp > 1 ) THEN ! k-gradient of T & S a jk+kp429 DO_3D( 1, 1, 1, 1, 1, jpkm1 ) ! done each pair of triad ! NB: not masked ==> a minimum value is set 430 IF( jk+kp > 1 ) THEN ! k-gradient of T & S a jk+kp 431 431 zdkt = ( ts(ji,jj,jk+kp-1,jp_tem,Kbb) - ts(ji,jj,jk+kp,jp_tem,Kbb) ) 432 432 zdks = ( ts(ji,jj,jk+kp-1,jp_sal,Kbb) - ts(ji,jj,jk+kp,jp_sal,Kbb) ) … … 442 442 END DO 443 443 ! 444 DO_2D( 1, 1, 1, 1 ) 444 DO_2D( 1, 1, 1, 1 ) !== Reciprocal depth of the w-point below ML base ==! 445 445 jk = MIN( nmln(ji,jj), mbkt(ji,jj) ) + 1 ! MIN in case ML depth is the ocean depth 446 446 z1_mlbw(ji,jj) = 1._wp / gdepw(ji,jj,jk,Kmm) … … 628 628 ! 629 629 ! !== surface mixed layer mask ! 630 DO_3D( 1, 1, 1, 1, 1, jpk ) 630 DO_3D( 1, 1, 1, 1, 1, jpk ) ! =1 inside the mixed layer, =0 otherwise 631 631 ik = nmln(ji,jj) - 1 632 632 IF( jk <= ik ) THEN ; omlmask(ji,jj,jk) = 1._wp -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/LDF/ldftra.F90
r13295 r13998 246 246 ENDIF 247 247 ! 248 IF( ln_ldfeiv .AND. .NOT.( ln_traldf_iso .OR. ln_traldf_triad ) ) & 249 & CALL ctl_stop( 'ln_ldfeiv=T requires iso-neutral laplacian diffusion' ) 250 IF( ln_isfcav .AND. ln_traldf_triad ) & 251 & CALL ctl_stop( ' ice shelf cavity and traldf_triad not tested' ) 248 IF( ln_isfcav .AND. ln_traldf_triad ) CALL ctl_stop( ' ice shelf cavity and traldf_triad not tested' ) 252 249 ! 253 250 IF( nldf_tra == np_lap_i .OR. nldf_tra == np_lap_it .OR. & … … 541 538 IF( ln_traldf_blp ) CALL ctl_stop( 'ldf_eiv_init: eddy induced velocity ONLY with laplacian diffusivity' ) 542 539 ! 540 IF( .NOT.( ln_traldf_iso .OR. ln_traldf_triad ) ) & 541 & CALL ctl_stop( 'ln_ldfeiv=T requires iso-neutral laplacian diffusion' ) 543 542 ! != allocate the aei arrays 544 543 ALLOCATE( aeiu(jpi,jpj,jpk), aeiv(jpi,jpj,jpk), STAT=ierr ) … … 694 693 CALL lbc_lnk( 'ldftra', zaeiw(:,:), 'W', 1.0_wp ) ! lateral boundary condition 695 694 ! 696 DO_2D( 0, 0, 0, 0 ) 695 DO_2D( 0, 0, 0, 0 ) !== aei at u- and v-points ==! 697 696 paeiu(ji,jj,1) = 0.5_wp * ( zaeiw(ji,jj) + zaeiw(ji+1,jj ) ) * umask(ji,jj,1) 698 697 paeiv(ji,jj,1) = 0.5_wp * ( zaeiw(ji,jj) + zaeiw(ji ,jj+1) ) * vmask(ji,jj,1) … … 813 812 CALL iom_put( "voce_eiv", zw3d ) 814 813 ! 815 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 814 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) ! e1 e2 w_eiv = dk[psix] + dk[psix] 816 815 zw3d(ji,jj,jk) = ( psi_vw(ji,jj,jk) - psi_vw(ji ,jj-1,jk) & 817 816 & + psi_uw(ji,jj,jk) - psi_uw(ji-1,jj ,jk) ) / e1e2t(ji,jj) -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/SBC/cpl_oasis3.F90
r13286 r13998 165 165 ENDIF 166 166 ! 167 ! ... Define the shape for the area that excludes the halo 168 ! For serial configuration (key_mpp_mpi not being active) 169 ! nl* is set to the global values 1 and jp*glo. 167 ! ... Define the shape for the area that excludes the halo as we don't want them to be "seen" by oasis 170 168 ! 171 169 ishape(1) = 1 … … 176 174 ! ... Allocate memory for data exchange 177 175 ! 178 ALLOCATE(exfld(Ni_0, Nj_0), stat = nerror) 176 ALLOCATE(exfld(Ni_0, Nj_0), stat = nerror) ! allocate only inner domain (without halos) 179 177 IF( nerror > 0 ) THEN 180 178 CALL oasis_abort ( ncomp_id, 'cpl_define', 'Failure in allocating exfld') ; RETURN … … 182 180 ! 183 181 ! ----------------------------------------------------------------- 184 ! ... Define the partition 182 ! ... Define the partition, excluding halos as we don't want them to be "seen" by oasis 185 183 ! ----------------------------------------------------------------- 186 184 187 paral(1) = 2 188 paral(2) = jpiglo * (Njs0-1+njmpp-1) + (Nis0-1+nimpp-1) ! NEMO lower left corner global offset189 paral(3) = Ni_0 ! local extent in i190 paral(4) = Nj_0 ! local extent in j191 paral(5) = jpiglo ! global extent in x185 paral(1) = 2 ! box partitioning 186 paral(2) = Ni0glo * mjg0(nn_hls) + mig0(nn_hls) ! NEMO lower left corner global offset, without halos 187 paral(3) = Ni_0 ! local extent in i, excluding halos 188 paral(4) = Nj_0 ! local extent in j, excluding halos 189 paral(5) = Ni0glo ! global extent in x, excluding halos 192 190 193 191 IF( sn_cfctl%l_oasout ) THEN 194 192 WRITE(numout,*) ' multiexchg: paral (1:5)', paral 195 WRITE(numout,*) ' multiexchg: jpi, jpj =', jpi, jpj193 WRITE(numout,*) ' multiexchg: Ni_0, Nj_0 =', Ni_0, Nj_0 196 194 WRITE(numout,*) ' multiexchg: Nis0, Nie0, nimpp =', Nis0, Nie0, nimpp 197 195 WRITE(numout,*) ' multiexchg: Njs0, Nje0, njmpp =', Njs0, Nje0, njmpp 198 196 ENDIF 199 197 200 CALL oasis_def_partition ( id_part, paral, nerror, jpiglo*jpjglo )198 CALL oasis_def_partition ( id_part, paral, nerror, Ni0glo*Nj0glo ) ! global number of points, excluding halos 201 199 ! 202 200 ! ... Announce send variables. … … 327 325 DO jm = 1, ssnd(kid)%ncplmodel 328 326 329 IF( ssnd(kid)%nid(jc,jm) /= -1 ) THEN 327 IF( ssnd(kid)%nid(jc,jm) /= -1 ) THEN ! exclude halos from data sent to oasis 330 328 CALL oasis_put ( ssnd(kid)%nid(jc,jm), kstep, pdata(Nis0:Nie0, Njs0:Nje0,jc), kinfo ) 331 329 … … 386 384 & kinfo == OASIS_RecvOut .OR. kinfo == OASIS_FromRestOut 387 385 388 IF ( sn_cfctl%l_oasout ) WRITE(numout,*) "llaction, kinfo, kstep, ivarid: " , llaction, kinfo, kstep, srcv(kid)%nid(jc,jm) 386 IF ( sn_cfctl%l_oasout ) & 387 & WRITE(numout,*) "llaction, kinfo, kstep, ivarid: " , llaction, kinfo, kstep, srcv(kid)%nid(jc,jm) 389 388 390 IF( llaction ) THEN 389 IF( llaction ) THEN ! data received from oasis do not include halos 391 390 392 391 kinfo = OASIS_Rcv … … 417 416 ENDDO 418 417 419 !--- Fill the overlap areas and extra hallows (mpp) 420 !--- check periodicity conditions (all cases) 418 !--- we must call lbc_lnk to fill the halos that where not received. 421 419 IF( .NOT. ll_1st ) THEN 422 420 CALL lbc_lnk( 'cpl_oasis3', pdata(:,:,jc), srcv(kid)%clgrid, srcv(kid)%nsgn ) -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/SBC/fldread.F90
r13295 r13998 216 216 WRITE(numout, clfmt) TRIM( sd(jf)%clvar ), kt, REAL(isecsbc,wp)/rday, nyear, nmonth, nday, & 217 217 & sd(jf)%nrec(1,ibb), sd(jf)%nrec(1,iaa), REAL(sd(jf)%nrec(2,ibb),wp)/rday, REAL(sd(jf)%nrec(2,iaa),wp)/rday 218 WRITE(numout, *) ' zt_offset is : ',zt_offset218 IF( zt_offset /= 0._wp ) WRITE(numout, *) ' zt_offset is : ', zt_offset 219 219 ENDIF 220 220 ! temporal interpolation weights -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/SBC/sbc_ice.F90
r12396 r13998 69 69 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: emp_oce !: evap - precip over ocean [kg/m2/s] 70 70 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wndm_ice !: wind speed module at T-point [m/s] 71 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sstfrz !: wind speed module at T-point [m/s] 71 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sstfrz !: sea surface freezing temperature [degC] 72 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: rCdU_ice !: ice-ocean drag at T-point (<0) [m/s] 72 73 #endif 73 74 … … 89 90 ! variables used in the coupled interface 90 91 INTEGER , PUBLIC, PARAMETER :: jpl = ncat 91 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: u_ice, v_ice ! jpi, jpj92 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: u_ice, v_ice 92 93 93 94 ! already defined in ice.F90 for SI3 … … 98 99 #endif 99 100 100 REAL(wp), PUBLIC, SAVE :: cldf_ice= 0.81 !: cloud fraction over sea ice, summer CLIO value [-]101 REAL(wp), PUBLIC, SAVE :: pp_cldf = 0.81 !: cloud fraction over sea ice, summer CLIO value [-] 101 102 102 103 !! arrays relating to embedding ice in the ocean … … 131 132 & qemp_ice(jpi,jpj) , qevap_ice(jpi,jpj,jpl) , qemp_oce (jpi,jpj) , & 132 133 & qns_oce (jpi,jpj) , qsr_oce (jpi,jpj) , emp_oce (jpi,jpj) , & 133 & emp_ice (jpi,jpj) , sstfrz (jpi,jpj) , STAT= ierr(2) )134 & emp_ice (jpi,jpj) , sstfrz (jpi,jpj) , rCdU_ice (jpi,jpj) , STAT= ierr(2) ) 134 135 #endif 135 136 … … 167 168 LOGICAL , PUBLIC, PARAMETER :: lk_si3 = .FALSE. !: no SI3 ice model 168 169 LOGICAL , PUBLIC, PARAMETER :: lk_cice = .FALSE. !: no CICE ice model 169 REAL(wp) , PUBLIC, PARAMETER :: cldf_ice = 0.81!: cloud fraction over sea ice, summer CLIO value [-]170 REAL(wp) , PUBLIC, PARAMETER :: pp_cldf = 0.81 !: cloud fraction over sea ice, summer CLIO value [-] 170 171 INTEGER , PUBLIC, PARAMETER :: jpl = 1 171 172 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: u_ice, v_ice ! jpi, jpj -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/SBC/sbc_oce.F90
r13295 r13998 136 136 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: atm_co2 !: atmospheric pCO2 [ppm] 137 137 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: xcplmask !: coupling mask for ln_mixcpl (warning: allocated in sbccpl) 138 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: cloud_fra !: cloud cover (fraction of cloud in a gridcell) [-] 138 139 139 140 !!--------------------------------------------------------------------- … … 188 189 ! 189 190 ALLOCATE( tprecip(jpi,jpj) , sprecip(jpi,jpj) , fr_i(jpi,jpj) , & 190 & atm_co2(jpi,jpj) , tsk_m(jpi,jpj) , 191 & atm_co2(jpi,jpj) , tsk_m(jpi,jpj) , cloud_fra(jpi,jpj), & 191 192 & ssu_m (jpi,jpj) , sst_m(jpi,jpj) , frq_m(jpi,jpj) , & 192 193 & ssv_m (jpi,jpj) , sss_m(jpi,jpj) , ssh_m(jpi,jpj) , STAT=ierr(4) ) -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/SBC/sbcblk.F90
r13305 r13998 44 44 USE lib_fortran ! to use key_nosignedzero 45 45 #if defined key_si3 46 USE ice , ONLY : jpl, a_i_b, at_i_b, rn_cnd_s, hfx_err_dif47 USE ice thd_dh ! for CALL ice_thd_snwblow46 USE ice , ONLY : u_ice, v_ice, jpl, a_i_b, at_i_b, t_su, rn_cnd_s, hfx_err_dif, nn_qtrice 47 USE icevar ! for CALL ice_var_snwblow 48 48 #endif 49 49 USE sbcblk_algo_ncar ! => turb_ncar : NCAR - CORE (Large & Yeager, 2009) … … 87 87 INTEGER , PUBLIC, PARAMETER :: jp_voatm = 11 ! index of surface current (j-component) 88 88 ! ! seen by the atmospheric forcing (m/s) at T-point 89 INTEGER , PUBLIC, PARAMETER :: jp_hpgi = 12 ! index of ABL geostrophic wind or hpg (i-component) (m/s) at T-point 90 INTEGER , PUBLIC, PARAMETER :: jp_hpgj = 13 ! index of ABL geostrophic wind or hpg (j-component) (m/s) at T-point 91 INTEGER , PUBLIC, PARAMETER :: jpfld = 13 ! maximum number of files to read 89 INTEGER , PUBLIC, PARAMETER :: jp_cc = 12 ! index of cloud cover (-) range:0-1 90 INTEGER , PUBLIC, PARAMETER :: jp_hpgi = 13 ! index of ABL geostrophic wind or hpg (i-component) (m/s) at T-point 91 INTEGER , PUBLIC, PARAMETER :: jp_hpgj = 14 ! index of ABL geostrophic wind or hpg (j-component) (m/s) at T-point 92 INTEGER , PUBLIC, PARAMETER :: jpfld = 14 ! maximum number of files to read 92 93 93 94 ! Warning: keep this structure allocatable for Agrif... … … 175 176 TYPE(FLD_N) :: sn_qlw , sn_tair , sn_prec, sn_snow ! " " 176 177 TYPE(FLD_N) :: sn_slp , sn_uoatm, sn_voatm ! " " 177 TYPE(FLD_N) :: sn_ hpgi, sn_hpgj! " "178 TYPE(FLD_N) :: sn_cc, sn_hpgi, sn_hpgj ! " " 178 179 INTEGER :: ipka ! number of levels in the atmospheric variable 179 180 NAMELIST/namsbc_blk/ sn_wndi, sn_wndj, sn_humi, sn_qsr, sn_qlw , & ! input fields 180 181 & sn_tair, sn_prec, sn_snow, sn_slp, sn_uoatm, sn_voatm, & 181 & sn_ hpgi, sn_hpgj,&182 & sn_cc, sn_hpgi, sn_hpgj, & 182 183 & ln_NCAR, ln_COARE_3p0, ln_COARE_3p6, ln_ECMWF, & ! bulk algorithm 183 184 & cn_dir , rn_zqt, rn_zu, & … … 260 261 slf_i(jp_tair ) = sn_tair ; slf_i(jp_humi ) = sn_humi 261 262 slf_i(jp_prec ) = sn_prec ; slf_i(jp_snow ) = sn_snow 262 slf_i(jp_slp ) = sn_slp 263 slf_i(jp_slp ) = sn_slp ; slf_i(jp_cc ) = sn_cc 263 264 slf_i(jp_uoatm) = sn_uoatm ; slf_i(jp_voatm) = sn_voatm 264 265 slf_i(jp_hpgi ) = sn_hpgi ; slf_i(jp_hpgj ) = sn_hpgj … … 289 290 ! 290 291 IF( TRIM(sf(jfpr)%clrootname) == 'NOT USED' ) THEN !-- not used field --! (only now allocated and set to default) 291 IF( jfpr == jp_slp 292 IF( jfpr == jp_slp ) THEN 292 293 sf(jfpr)%fnow(:,:,1:ipka) = 101325._wp ! use standard pressure in Pa 293 294 ELSEIF( jfpr == jp_prec .OR. jfpr == jp_snow .OR. jfpr == jp_uoatm .OR. jfpr == jp_voatm ) THEN 294 295 sf(jfpr)%fnow(:,:,1:ipka) = 0._wp ! no precip or no snow or no surface currents 295 ELSEIF( ( jfpr == jp_hpgi .OR. jfpr == jp_hpgj ) .AND. .NOT. ln_abl ) THEN 296 DEALLOCATE( sf(jfpr)%fnow ) ! deallocate as not used in this case 296 ELSEIF( jfpr == jp_hpgi .OR. jfpr == jp_hpgj ) THEN 297 IF( .NOT. ln_abl ) THEN 298 DEALLOCATE( sf(jfpr)%fnow ) ! deallocate as not used in this case 299 ELSE 300 sf(jfpr)%fnow(:,:,1:ipka) = 0._wp 301 ENDIF 302 ELSEIF( jfpr == jp_cc ) THEN 303 sf(jp_cc)%fnow(:,:,1:ipka) = pp_cldf 297 304 ELSE 298 305 WRITE(ctmp1,*) 'sbc_blk_init: no default value defined for field number', jfpr … … 303 310 ! 304 311 IF( sf(jfpr)%freqh > 0. .AND. MOD( NINT(3600. * sf(jfpr)%freqh), nn_fsbc * NINT(rn_Dt) ) /= 0 ) & 305 306 312 & CALL ctl_warn( 'sbc_blk_init: sbcmod timestep rn_Dt*nn_fsbc is NOT a submultiple of atmospheric forcing frequency.', & 313 & ' This is not ideal. You should consider changing either rn_Dt or nn_fsbc value...' ) 307 314 ENDIF 308 315 END DO … … 559 566 ptsk(:,:) = pst(:,:) + rt0 ! by default: skin temperature = "bulk SST" (will remain this way if NCAR algorithm used!) 560 567 568 ! --- cloud cover --- ! 569 cloud_fra(:,:) = sf(jp_cc)%fnow(:,:,1) 570 561 571 ! ----------------------------------------------------------------------------- ! 562 572 ! 0 Wind components and module at T-point relative to the moving ocean ! … … 1019 1029 REAL(wp) :: zcoef_dqlw, zcoef_dqla ! - - 1020 1030 REAL(wp) :: zztmp, zztmp2, z1_rLsub ! - - 1021 REAL(wp) :: zfr1, zfr2 ! local variables1022 1031 REAL(wp), DIMENSION(jpi,jpj,jpl) :: z1_st ! inverse of surface temperature 1023 1032 REAL(wp), DIMENSION(jpi,jpj,jpl) :: z_qlw ! long wave heat flux over ice … … 1028 1037 REAL(wp), DIMENSION(jpi,jpj) :: zqair ! specific humidity of air at z=rn_zqt [kg/kg] !LB 1029 1038 REAL(wp), DIMENSION(jpi,jpj) :: ztmp, ztmp2 1039 REAL(wp), DIMENSION(jpi,jpj) :: ztri 1030 1040 !!--------------------------------------------------------------------- 1031 1041 ! … … 1112 1122 ! --- evaporation minus precipitation --- ! 1113 1123 zsnw(:,:) = 0._wp 1114 CALL ice_ thd_snwblow( (1.-at_i_b(:,:)), zsnw ) ! snow distribution over ice after wind blowing1124 CALL ice_var_snwblow( (1.-at_i_b(:,:)), zsnw ) ! snow distribution over ice after wind blowing 1115 1125 emp_oce(:,:) = ( 1._wp - at_i_b(:,:) ) * zevap(:,:) - ( tprecip(:,:) - sprecip(:,:) ) - sprecip(:,:) * (1._wp - zsnw ) 1116 1126 emp_ice(:,:) = SUM( a_i_b(:,:,:) * evap_ice(:,:,:), dim=3 ) - sprecip(:,:) * zsnw … … 1139 1149 END DO 1140 1150 1141 ! --- shortwave radiation transmitted below the surface (W/m2, see Grenfell Maykut 77) --- ! 1142 zfr1 = ( 0.18 * ( 1.0 - cldf_ice ) + 0.35 * cldf_ice ) ! transmission when hi>10cm 1143 zfr2 = ( 0.82 * ( 1.0 - cldf_ice ) + 0.65 * cldf_ice ) ! zfr2 such that zfr1 + zfr2 to equal 1 1144 ! 1145 WHERE ( phs(:,:,:) <= 0._wp .AND. phi(:,:,:) < 0.1_wp ) ! linear decrease from hi=0 to 10cm 1146 qtr_ice_top(:,:,:) = qsr_ice(:,:,:) * ( zfr1 + zfr2 * ( 1._wp - phi(:,:,:) * 10._wp ) ) 1147 ELSEWHERE( phs(:,:,:) <= 0._wp .AND. phi(:,:,:) >= 0.1_wp ) ! constant (zfr1) when hi>10cm 1148 qtr_ice_top(:,:,:) = qsr_ice(:,:,:) * zfr1 1149 ELSEWHERE ! zero when hs>0 1150 qtr_ice_top(:,:,:) = 0._wp 1151 END WHERE 1152 ! 1153 1151 ! --- shortwave radiation transmitted thru the surface scattering layer (W/m2) --- ! 1152 IF( nn_qtrice == 0 ) THEN 1153 ! formulation derived from Grenfell and Maykut (1977), where transmission rate 1154 ! 1) depends on cloudiness 1155 ! 2) is 0 when there is any snow 1156 ! 3) tends to 1 for thin ice 1157 ztri(:,:) = 0.18 * ( 1.0 - cloud_fra(:,:) ) + 0.35 * cloud_fra(:,:) ! surface transmission when hi>10cm 1158 DO jl = 1, jpl 1159 WHERE ( phs(:,:,jl) <= 0._wp .AND. phi(:,:,jl) < 0.1_wp ) ! linear decrease from hi=0 to 10cm 1160 qtr_ice_top(:,:,jl) = qsr_ice(:,:,jl) * ( ztri(:,:) + ( 1._wp - ztri(:,:) ) * ( 1._wp - phi(:,:,jl) * 10._wp ) ) 1161 ELSEWHERE( phs(:,:,jl) <= 0._wp .AND. phi(:,:,jl) >= 0.1_wp ) ! constant (ztri) when hi>10cm 1162 qtr_ice_top(:,:,jl) = qsr_ice(:,:,jl) * ztri(:,:) 1163 ELSEWHERE ! zero when hs>0 1164 qtr_ice_top(:,:,jl) = 0._wp 1165 END WHERE 1166 ENDDO 1167 ELSEIF( nn_qtrice == 1 ) THEN 1168 ! formulation is derived from the thesis of M. Lebrun (2019). 1169 ! It represents the best fit using several sets of observations 1170 ! It comes with snow conductivities adapted to freezing/melting conditions (see icethd_zdf_bl99.F90) 1171 qtr_ice_top(:,:,:) = 0.3_wp * qsr_ice(:,:,:) 1172 ENDIF 1173 ! 1154 1174 IF( iom_use('evap_ao_cea') .OR. iom_use('hflx_evap_cea') ) THEN 1155 1175 ztmp(:,:) = zevap(:,:) * ( 1._wp - at_i_b(:,:) ) -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/SBC/sbcblk_algo_coare3p0.F90
r13295 r13998 394 394 !!------------------------------------------------------------------- 395 395 ! 396 DO_2D( 1, 1, 1, 1)396 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 397 397 ! 398 398 zw = pwnd(ji,jj) ! wind speed … … 430 430 !!---------------------------------------------------------------------------------- 431 431 ! 432 DO_2D( 1, 1, 1, 1)432 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 433 433 ! 434 434 zta = pzeta(ji,jj) … … 481 481 REAL(wp) :: zta, zphi_h, zphi_c, zpsi_k, zpsi_c, zf, zc, zstab 482 482 ! 483 DO_2D( 1, 1, 1, 1)483 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 484 484 ! 485 485 zta = pzeta(ji,jj) -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/SBC/sbcblk_algo_coare3p6.F90
r13295 r13998 430 430 !!---------------------------------------------------------------------------------- 431 431 ! 432 DO_2D( 1, 1, 1, 1)432 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 433 433 ! 434 434 zta = pzeta(ji,jj) … … 481 481 REAL(wp) :: zta, zphi_h, zphi_c, zpsi_k, zpsi_c, zf, zc, zstab 482 482 ! 483 DO_2D( 1, 1, 1, 1)483 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 484 484 ! 485 485 zta = pzeta(ji,jj) -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/SBC/sbcblk_algo_ecmwf.F90
r13295 r13998 410 410 REAL(wp) :: zzeta, zx, ztmp, psi_unst, psi_stab, stab 411 411 !!---------------------------------------------------------------------------------- 412 DO_2D( 1, 1, 1, 1)412 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 413 413 ! 414 414 zzeta = MIN( pzeta(ji,jj) , 5._wp ) !! Very stable conditions (L positif and big!): … … 455 455 !!---------------------------------------------------------------------------------- 456 456 ! 457 DO_2D( 1, 1, 1, 1)457 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 458 458 ! 459 459 zzeta = MIN(pzeta(ji,jj) , 5._wp) ! Very stable conditions (L positif and big!): -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/SBC/sbcblk_algo_ncar.F90
r13295 r13998 241 241 !!---------------------------------------------------------------------------------- 242 242 ! 243 DO_2D( 1, 1, 1, 1)243 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 244 244 ! 245 245 zw = pw10(ji,jj) … … 277 277 REAL(wp) :: zx2, zx, zstab ! local scalars 278 278 !!---------------------------------------------------------------------------------- 279 DO_2D( 1, 1, 1, 1)279 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 280 280 zx2 = SQRT( ABS( 1._wp - 16._wp*pzeta(ji,jj) ) ) 281 281 zx2 = MAX( zx2 , 1._wp ) … … 308 308 !!---------------------------------------------------------------------------------- 309 309 ! 310 DO_2D( 1, 1, 1, 1)310 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 311 311 zx2 = SQRT( ABS( 1._wp - 16._wp*pzeta(ji,jj) ) ) 312 312 zx2 = MAX( zx2 , 1._wp ) -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/SBC/sbcblk_skin_coare.F90
r13295 r13998 89 89 REAL(wp) :: zQabs, zdlt, zfr, zalfa, zqlat, zus 90 90 !!--------------------------------------------------------------------- 91 DO_2D( 1, 1, 1, 1)91 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 92 92 93 93 zQabs = pQnsol(ji,jj) ! first guess of heat flux absorbed within the viscous sublayer of thicknes delta, … … 156 156 ztime = REAL(nsec_day,wp)/(24._wp*3600._wp) ! time of current time step since 00:00 for current day (UTC) -> ztime = 0 -> 00:00 / ztime = 0.5 -> 12:00 ... 157 157 158 DO_2D( 1, 1, 1, 1)158 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 159 159 160 160 l_exit = .FALSE. -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/SBC/sbcblk_skin_ecmwf.F90
r13295 r13998 95 95 REAL(wp) :: zQabs, zdlt, zfr, zalfa, zus 96 96 !!--------------------------------------------------------------------- 97 DO_2D( 1, 1, 1, 1)97 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 98 98 99 99 zQabs = pQnsol(ji,jj) ! first guess of heat flux absorbed within the viscous sublayer of thicknes delta, … … 173 173 IF( PRESENT(pustk) ) l_pustk_known = .TRUE. 174 174 175 DO_2D( 1, 1, 1, 1)175 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 176 176 177 177 zHwl = Hz_wl(ji,jj) ! first guess for warm-layer depth (and unique..., less advanced than COARE3p6 !) -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/SBC/sbccpl.F90
r13295 r13998 41 41 #endif 42 42 #if defined key_si3 43 USE ice thd_dh ! for CALL ice_thd_snwblow43 USE icevar ! for CALL ice_var_snwblow 44 44 #endif 45 45 ! … … 48 48 USE lib_mpp ! distribued memory computing library 49 49 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 50 51 #if defined key_oasis3 52 USE mod_oasis, ONLY : OASIS_Sent, OASIS_ToRest, OASIS_SentOut, OASIS_ToRestOut 53 #endif 50 54 51 55 IMPLICIT NONE … … 152 156 INTEGER, PARAMETER :: jps_wlev = 32 ! water level 153 157 INTEGER, PARAMETER :: jps_fice1 = 33 ! first-order ice concentration (for semi-implicit coupling of atmos-ice fluxes) 154 INTEGER, PARAMETER :: jps_a_p = 34 ! meltpond area 158 INTEGER, PARAMETER :: jps_a_p = 34 ! meltpond area fraction 155 159 INTEGER, PARAMETER :: jps_ht_p = 35 ! meltpond thickness 156 160 INTEGER, PARAMETER :: jps_kice = 36 ! sea ice effective conductivity … … 159 163 160 164 INTEGER, PARAMETER :: jpsnd = 38 ! total number of fields sent 165 166 #if ! defined key_oasis3 167 ! Dummy variables to enable compilation when oasis3 is not being used 168 INTEGER :: OASIS_Sent = -1 169 INTEGER :: OASIS_SentOut = -1 170 INTEGER :: OASIS_ToRest = -1 171 INTEGER :: OASIS_ToRestOut = -1 172 #endif 161 173 162 174 ! !!** namelist namsbc_cpl ** … … 184 196 LOGICAL :: ln_usecplmask ! use a coupling mask file to merge data received from several models 185 197 ! -> file cplmask.nc with the float variable called cplmask (jpi,jpj,nn_cplmodel) 198 LOGICAL :: ln_scale_ice_flux ! use ice fluxes that are already "ice weighted" ( i.e. multiplied ice concentration) 199 186 200 TYPE :: DYNARR 187 201 REAL(wp), POINTER, DIMENSION(:,:,:) :: z3 … … 191 205 192 206 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: alb_oce_mix ! ocean albedo sent to atmosphere (mix clear/overcast sky) 207 #if defined key_si3 || defined key_cice 208 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: a_i_last_couple !: Ice fractional area at last coupling time 209 #endif 193 210 194 211 REAL(wp) :: rpref = 101000._wp ! reference atmospheric pressure[N/m2] … … 211 228 !! *** FUNCTION sbc_cpl_alloc *** 212 229 !!---------------------------------------------------------------------- 213 INTEGER :: ierr( 4)230 INTEGER :: ierr(5) 214 231 !!---------------------------------------------------------------------- 215 232 ierr(:) = 0 … … 221 238 #endif 222 239 ALLOCATE( xcplmask(jpi,jpj,0:nn_cplmodel) , STAT=ierr(3) ) 223 ! 224 IF( .NOT. ln_apr_dyn ) ALLOCATE( ssh_ib(jpi,jpj), ssh_ibb(jpi,jpj), apr(jpi, jpj), STAT=ierr(4) ) 240 #if defined key_si3 || defined key_cice 241 ALLOCATE( a_i_last_couple(jpi,jpj,jpl) , STAT=ierr(4) ) 242 #endif 243 ! 244 IF( .NOT. ln_apr_dyn ) ALLOCATE( ssh_ib(jpi,jpj), ssh_ibb(jpi,jpj), apr(jpi, jpj), STAT=ierr(5) ) 225 245 226 246 sbc_cpl_alloc = MAXVAL( ierr ) … … 249 269 REAL(wp), DIMENSION(jpi,jpj) :: zacs, zaos 250 270 !! 251 NAMELIST/namsbc_cpl/ sn_snd_temp , sn_snd_alb , sn_snd_thick, sn_snd_crt , sn_snd_co2 , & 271 NAMELIST/namsbc_cpl/ nn_cplmodel , ln_usecplmask, nn_cats_cpl , ln_scale_ice_flux, & 272 & sn_snd_temp , sn_snd_alb , sn_snd_thick, sn_snd_crt , sn_snd_co2 , & 252 273 & sn_snd_ttilyr, sn_snd_cond , sn_snd_mpnd , sn_snd_sstfrz, sn_snd_thick1, & 253 & sn_snd_ifrac , sn_snd_crtw , sn_snd_wlev , sn_rcv_hsig , sn_rcv_phioc ,&254 & sn_rcv_w10m , sn_rcv_taumod, sn_rcv_tau , sn_rcv_dqnsdt, sn_rcv_qsr ,&274 & sn_snd_ifrac , sn_snd_crtw , sn_snd_wlev , sn_rcv_hsig , sn_rcv_phioc , & 275 & sn_rcv_w10m , sn_rcv_taumod, sn_rcv_tau , sn_rcv_dqnsdt, sn_rcv_qsr , & 255 276 & sn_rcv_sdrfx , sn_rcv_sdrfy , sn_rcv_wper , sn_rcv_wnum , sn_rcv_tauwoc, & 256 & sn_rcv_wdrag , sn_rcv_qns , sn_rcv_emp , sn_rcv_rnf , sn_rcv_cal ,&257 & sn_rcv_iceflx, sn_rcv_co2 , nn_cplmodel , ln_usecplmask, sn_rcv_mslp ,&258 & sn_rcv_icb , sn_rcv_isf , sn_rcv_wfreq , sn_rcv_tauw, nn_cats_cpl ,&277 & sn_rcv_wdrag , sn_rcv_qns , sn_rcv_emp , sn_rcv_rnf , sn_rcv_cal , & 278 & sn_rcv_iceflx, sn_rcv_co2 , sn_rcv_mslp , & 279 & sn_rcv_icb , sn_rcv_isf , sn_rcv_wfreq, sn_rcv_tauw , & 259 280 & sn_rcv_ts_ice 260 261 281 !!--------------------------------------------------------------------- 262 282 ! … … 278 298 ENDIF 279 299 IF( lwp .AND. ln_cpl ) THEN ! control print 300 WRITE(numout,*)' nn_cplmodel = ', nn_cplmodel 301 WRITE(numout,*)' ln_usecplmask = ', ln_usecplmask 302 WRITE(numout,*)' ln_scale_ice_flux = ', ln_scale_ice_flux 303 WRITE(numout,*)' nn_cats_cpl = ', nn_cats_cpl 280 304 WRITE(numout,*)' received fields (mutiple ice categogies)' 281 305 WRITE(numout,*)' 10m wind module = ', TRIM(sn_rcv_w10m%cldes ), ' (', TRIM(sn_rcv_w10m%clcat ), ')' … … 326 350 WRITE(numout,*)' - orientation = ', sn_snd_crtw%clvor 327 351 WRITE(numout,*)' - mesh = ', sn_snd_crtw%clvgrd 328 WRITE(numout,*)' nn_cplmodel = ', nn_cplmodel329 WRITE(numout,*)' ln_usecplmask = ', ln_usecplmask330 WRITE(numout,*)' nn_cats_cpl = ', nn_cats_cpl331 352 ENDIF 332 353 … … 367 388 IF( TRIM( sn_rcv_tau%cldes ) == 'oce only' .OR. TRIM( sn_rcv_tau%cldes ) == 'oce and ice' & 368 389 .OR. TRIM( sn_rcv_tau%cldes ) == 'mixed oce-ice' ) THEN ! avoid working with the atmospheric fields if they are not coupled 369 390 ! 370 391 IF( TRIM( sn_rcv_tau%clvor ) == 'local grid' ) srcv(jpr_otx1:jpr_itz2)%nsgn = -1. 371 392 … … 698 719 ! Change first letter to couple with atmosphere if already coupled OPA 699 720 ! this is nedeed as each variable name used in the namcouple must be unique: 700 ! for example O_Runoff received by OPA from SAS and therefore O_Runoff received by SAS from the Atmosphere721 ! for example O_Runoff received by OPA from SAS and therefore S_Runoff received by SAS from the Atmosphere 701 722 DO jn = 1, jprcv 702 723 IF( srcv(jn)%clname(1:1) == "O" ) srcv(jn)%clname = "S"//srcv(jn)%clname(2:LEN(srcv(jn)%clname)) … … 822 843 END SELECT 823 844 845 ! Initialise ice fractions from last coupling time to zero (needed by Met-Office) 846 #if defined key_si3 || defined key_cice 847 a_i_last_couple(:,:,:) = 0._wp 848 #endif 824 849 ! ! ------------------------- ! 825 850 ! ! Ice Meltponds ! … … 1110 1135 REAL(wp) :: zcdrag = 1.5e-3 ! drag coefficient 1111 1136 REAL(wp) :: zzx, zzy ! temporary variables 1112 REAL(wp), DIMENSION(jpi,jpj) :: ztx, zty, zmsk, zemp, zqns, zqsr 1137 REAL(wp), DIMENSION(jpi,jpj) :: ztx, zty, zmsk, zemp, zqns, zqsr, zcloud_fra 1113 1138 !!---------------------------------------------------------------------- 1114 1139 ! … … 1170 1195 ! 1171 1196 IF( srcv(jpr_otx1)%clgrid == 'T' ) THEN 1172 DO_2D( 0, 0, 0, 0 ) 1197 DO_2D( 0, 0, 0, 0 ) ! T ==> (U,V) 1173 1198 frcv(jpr_otx1)%z3(ji,jj,1) = 0.5 * ( frcv(jpr_otx1)%z3(ji+1,jj ,1) + frcv(jpr_otx1)%z3(ji,jj,1) ) 1174 1199 frcv(jpr_oty1)%z3(ji,jj,1) = 0.5 * ( frcv(jpr_oty1)%z3(ji ,jj+1,1) + frcv(jpr_oty1)%z3(ji,jj,1) ) … … 1224 1249 ENDIF 1225 1250 ENDIF 1226 1251 !!$ ! ! ========================= ! 1252 !!$ SELECT CASE( TRIM( sn_rcv_clouds%cldes ) ) ! cloud fraction ! 1253 !!$ ! ! ========================= ! 1254 !!$ cloud_fra(:,:) = frcv(jpr_clfra)*z3(:,:,1) 1255 !!$ END SELECT 1256 !!$ 1257 zcloud_fra(:,:) = pp_cldf ! should be real cloud fraction instead (as in the bulk) but needs to be read from atm. 1258 IF( ln_mixcpl ) THEN 1259 cloud_fra(:,:) = cloud_fra(:,:) * xcplmask(:,:,0) + zcloud_fra(:,:)* zmsk(:,:) 1260 ELSE 1261 cloud_fra(:,:) = zcloud_fra(:,:) 1262 ENDIF 1263 ! ! ========================= ! 1227 1264 ! u(v)tau and taum will be modified by ice model 1228 1265 ! -> need to be reset before each call of the ice/fsbc … … 1549 1586 p_tauj(:,:) = frcv(jpr_ity1)%z3(:,:,1) 1550 1587 CASE( 'T' ) 1551 DO_2D( 0, 0, 0, 0 ) 1588 DO_2D( 0, 0, 0, 0 ) ! T ==> (U,V) 1552 1589 ! take care of the land-sea mask to avoid "pollution" of coastal stress. p[uv]taui used in frazil and rheology 1553 1590 zztmp1 = 0.5_wp * ( 2. - umask(ji,jj,1) ) * MAX( tmask(ji,jj,1),tmask(ji+1,jj ,1) ) … … 1623 1660 ! 1624 1661 INTEGER :: ji, jj, jl ! dummy loop index 1625 REAL(wp) :: ztri ! local scalar1626 1662 REAL(wp), DIMENSION(jpi,jpj) :: zcptn, zcptrain, zcptsnw, ziceld, zmsk, zsnw 1627 1663 REAL(wp), DIMENSION(jpi,jpj) :: zemp_tot, zemp_ice, zemp_oce, ztprecip, zsprecip , zevap_oce, zdevap_ice 1628 1664 REAL(wp), DIMENSION(jpi,jpj) :: zqns_tot, zqns_oce, zqsr_tot, zqsr_oce, zqprec_ice, zqemp_oce, zqemp_ice 1665 REAL(wp), DIMENSION(jpi,jpj) :: zevap_ice_total 1629 1666 REAL(wp), DIMENSION(jpi,jpj,jpl) :: zqns_ice, zqsr_ice, zdqns_ice, zqevap_ice, zevap_ice, zqtr_ice_top, ztsu 1667 REAL(wp), DIMENSION(jpi,jpj) :: ztri 1630 1668 !!---------------------------------------------------------------------- 1631 1669 ! … … 1647 1685 ztprecip(:,:) = frcv(jpr_rain)%z3(:,:,1) + zsprecip(:,:) ! May need to ensure positive here 1648 1686 zemp_tot(:,:) = frcv(jpr_tevp)%z3(:,:,1) - ztprecip(:,:) 1649 zemp_ice(:,:) = ( frcv(jpr_ievp)%z3(:,:,1) - frcv(jpr_snow)%z3(:,:,1) ) * picefr(:,:)1650 1687 CASE( 'oce and ice' ) ! received fields: jpr_sbpr, jpr_semp, jpr_oemp, jpr_ievp 1651 1688 zemp_tot(:,:) = ziceld(:,:) * frcv(jpr_oemp)%z3(:,:,1) + picefr(:,:) * frcv(jpr_sbpr)%z3(:,:,1) … … 1659 1696 1660 1697 #if defined key_si3 1698 1699 ! --- evaporation over ice (kg/m2/s) --- ! 1700 IF (ln_scale_ice_flux) THEN ! typically met-office requirements 1701 IF (sn_rcv_emp%clcat == 'yes') THEN 1702 WHERE( a_i(:,:,:) > 1.e-10 ) ; zevap_ice(:,:,:) = frcv(jpr_ievp)%z3(:,:,:) * a_i_last_couple(:,:,:) / a_i(:,:,:) 1703 ELSEWHERE ; zevap_ice(:,:,:) = 0._wp 1704 END WHERE 1705 WHERE( picefr(:,:) > 1.e-10 ) ; zevap_ice_total(:,:) = SUM( zevap_ice(:,:,:) * a_i(:,:,:), dim=3 ) / picefr(:,:) 1706 ELSEWHERE ; zevap_ice_total(:,:) = 0._wp 1707 END WHERE 1708 ELSE 1709 WHERE( picefr(:,:) > 1.e-10 ) ; zevap_ice(:,:,1) = frcv(jpr_ievp)%z3(:,:,1) * SUM( a_i_last_couple, dim=3 ) / picefr(:,:) 1710 ELSEWHERE ; zevap_ice(:,:,1) = 0._wp 1711 END WHERE 1712 zevap_ice_total(:,:) = zevap_ice(:,:,1) 1713 DO jl = 2, jpl 1714 zevap_ice(:,:,jl) = zevap_ice(:,:,1) 1715 ENDDO 1716 ENDIF 1717 ELSE 1718 IF (sn_rcv_emp%clcat == 'yes') THEN 1719 zevap_ice(:,:,1:jpl) = frcv(jpr_ievp)%z3(:,:,1:jpl) 1720 WHERE( picefr(:,:) > 1.e-10 ) ; zevap_ice_total(:,:) = SUM( zevap_ice(:,:,:) * a_i(:,:,:), dim=3 ) / picefr(:,:) 1721 ELSEWHERE ; zevap_ice_total(:,:) = 0._wp 1722 END WHERE 1723 ELSE 1724 zevap_ice(:,:,1) = frcv(jpr_ievp)%z3(:,:,1) 1725 zevap_ice_total(:,:) = zevap_ice(:,:,1) 1726 DO jl = 2, jpl 1727 zevap_ice(:,:,jl) = zevap_ice(:,:,1) 1728 ENDDO 1729 ENDIF 1730 ENDIF 1731 1732 IF ( TRIM( sn_rcv_emp%cldes ) == 'conservative' ) THEN 1733 ! For conservative case zemp_ice has not been defined yet. Do it now. 1734 zemp_ice(:,:) = zevap_ice_total(:,:) * picefr(:,:) - frcv(jpr_snow)%z3(:,:,1) * picefr(:,:) 1735 ENDIF 1736 1661 1737 ! zsnw = snow fraction over ice after wind blowing (=picefr if no blowing) 1662 zsnw(:,:) = 0._wp ; CALL ice_ thd_snwblow( ziceld, zsnw )1738 zsnw(:,:) = 0._wp ; CALL ice_var_snwblow( ziceld, zsnw ) 1663 1739 1664 1740 ! --- evaporation minus precipitation corrected (because of wind blowing on snow) --- ! … … 1667 1743 1668 1744 ! --- evaporation over ocean (used later for qemp) --- ! 1669 zevap_oce(:,:) = frcv(jpr_tevp)%z3(:,:,1) - frcv(jpr_ievp)%z3(:,:,1) * picefr(:,:) 1670 1671 ! --- evaporation over ice (kg/m2/s) --- ! 1672 DO jl=1,jpl 1673 IF(sn_rcv_emp%clcat == 'yes') THEN ; zevap_ice(:,:,jl) = frcv(jpr_ievp)%z3(:,:,jl) 1674 ELSE ; zevap_ice(:,:,jl) = frcv(jpr_ievp)%z3(:,:,1 ) ; ENDIF 1675 ENDDO 1745 zevap_oce(:,:) = frcv(jpr_tevp)%z3(:,:,1) - zevap_ice_total(:,:) * picefr(:,:) 1676 1746 1677 1747 ! since the sensitivity of evap to temperature (devap/dT) is not prescribed by the atmosphere, we set it to 0 … … 1751 1821 !! IF( srcv(jpr_rnf)%laction ) CALL iom_put( 'runoffs' , rnf(:,:) * tmask(:,:,1) ) ! runoff 1752 1822 !! IF( srcv(jpr_isf)%laction ) CALL iom_put( 'iceshelf_cea', -fwfisf(:,:) * tmask(:,:,1) ) ! iceshelf 1753 IF( srcv(jpr_cal)%laction ) CALL iom_put( 'calving_cea' , frcv(jpr_cal)%z3(:,:,1) * tmask(:,:,1) ) ! calving1754 IF( srcv(jpr_icb)%laction ) CALL iom_put( 'iceberg_cea' , frcv(jpr_icb)%z3(:,:,1) * tmask(:,:,1) ) ! icebergs1755 IF( iom_use('snowpre') ) CALL iom_put( 'snowpre' , sprecip(:,:) ) ! Snow1756 IF( iom_use('precip') ) CALL iom_put( 'precip' , tprecip(:,:) ) ! total precipitation1757 IF( iom_use('rain') ) CALL iom_put( 'rain' , tprecip(:,:) - sprecip(:,:) ) ! liquid precipitation1758 IF( iom_use('snow_ao_cea') ) CALL iom_put( 'snow_ao_cea' , sprecip(:,:) * ( 1._wp - zsnw(:,:) ) ) ! Snow over ice-free ocean (cell average)1759 IF( iom_use('snow_ai_cea') ) CALL iom_put( 'snow_ai_cea' , sprecip(:,:) * zsnw(:,:) ) ! Snow over sea-ice (cell average)1760 IF( iom_use('rain_ao_cea') ) CALL iom_put( 'rain_ao_cea' , ( tprecip(:,:) - sprecip(:,:) ) * picefr(:,:) ) ! liquid precipitation over ocean (cell average)1761 IF( iom_use('subl_ai_cea') ) CALL iom_put( 'subl_ai_cea' , frcv(jpr_ievp)%z3(:,:,1) * picefr(:,:) * tmask(:,:,1) )! Sublimation over sea-ice (cell average)1762 IF( iom_use('evap_ao_cea') ) CALL iom_put( 'evap_ao_cea' , ( frcv(jpr_tevp)%z3(:,:,1) &1763 & - frcv(jpr_ievp)%z3(:,:,1) * picefr(:,:) ) * tmask(:,:,1) )! ice-free oce evap (cell average)1823 IF( srcv(jpr_cal)%laction ) CALL iom_put( 'calving_cea' , frcv(jpr_cal)%z3(:,:,1) * tmask(:,:,1) ) ! calving 1824 IF( srcv(jpr_icb)%laction ) CALL iom_put( 'iceberg_cea' , frcv(jpr_icb)%z3(:,:,1) * tmask(:,:,1) ) ! icebergs 1825 IF( iom_use('snowpre') ) CALL iom_put( 'snowpre' , sprecip(:,:) ) ! Snow 1826 IF( iom_use('precip') ) CALL iom_put( 'precip' , tprecip(:,:) ) ! total precipitation 1827 IF( iom_use('rain') ) CALL iom_put( 'rain' , tprecip(:,:) - sprecip(:,:) ) ! liquid precipitation 1828 IF( iom_use('snow_ao_cea') ) CALL iom_put( 'snow_ao_cea' , sprecip(:,:) * ( 1._wp - zsnw(:,:) ) ) ! Snow over ice-free ocean (cell average) 1829 IF( iom_use('snow_ai_cea') ) CALL iom_put( 'snow_ai_cea' , sprecip(:,:) * zsnw(:,:) ) ! Snow over sea-ice (cell average) 1830 IF( iom_use('rain_ao_cea') ) CALL iom_put( 'rain_ao_cea' , ( tprecip(:,:) - sprecip(:,:) ) * picefr(:,:) ) ! liquid precipitation over ocean (cell average) 1831 IF( iom_use('subl_ai_cea') ) CALL iom_put( 'subl_ai_cea' , frcv(jpr_ievp)%z3(:,:,1) * picefr(:,:) * tmask(:,:,1) ) ! Sublimation over sea-ice (cell average) 1832 IF( iom_use('evap_ao_cea') ) CALL iom_put( 'evap_ao_cea' , ( frcv(jpr_tevp)%z3(:,:,1) & 1833 & - frcv(jpr_ievp)%z3(:,:,1) * picefr(:,:) ) * tmask(:,:,1) ) ! ice-free oce evap (cell average) 1764 1834 ! note: runoff output is done in sbcrnf (which includes icebergs too) and iceshelf output is done in sbcisf 1765 1835 ! … … 1769 1839 CASE( 'oce only' ) ! the required field is directly provided 1770 1840 zqns_tot(:,:) = frcv(jpr_qnsoce)%z3(:,:,1) 1841 ! For Met Office sea ice non-solar fluxes are already delt with by JULES so setting to zero 1842 ! here so the only flux is the ocean only one. 1843 zqns_ice(:,:,:) = 0._wp 1771 1844 CASE( 'conservative' ) ! the required fields are directly provided 1772 1845 zqns_tot(:,:) = frcv(jpr_qnsmix)%z3(:,:,1) … … 1798 1871 zqns_ice(:,:,jl) = frcv(jpr_qnsmix)%z3(:,:,jl) & 1799 1872 & + frcv(jpr_dqnsdt)%z3(:,:,jl) * ( pist(:,:,jl) - ( ( rt0 + psst(:,:) ) * ziceld(:,:) & 1800 & 1873 & + pist(:,:,jl) * picefr(:,:) ) ) 1801 1874 END DO 1802 1875 ELSE … … 1804 1877 zqns_ice(:,:,jl) = frcv(jpr_qnsmix)%z3(:,:, 1) & 1805 1878 & + frcv(jpr_dqnsdt)%z3(:,:, 1) * ( pist(:,:,jl) - ( ( rt0 + psst(:,:) ) * ziceld(:,:) & 1806 & 1879 & + pist(:,:,jl) * picefr(:,:) ) ) 1807 1880 END DO 1808 1881 ENDIF … … 1910 1983 CASE( 'oce only' ) 1911 1984 zqsr_tot(:,: ) = MAX( 0._wp , frcv(jpr_qsroce)%z3(:,:,1) ) 1985 ! For Met Office sea ice solar fluxes are already delt with by JULES so setting to zero 1986 ! here so the only flux is the ocean only one. 1987 zqsr_ice(:,:,:) = 0._wp 1912 1988 CASE( 'conservative' ) 1913 1989 zqsr_tot(:,: ) = frcv(jpr_qsrmix)%z3(:,:,1) … … 1995 2071 ENDDO 1996 2072 ENDIF 2073 CASE( 'none' ) 2074 zdqns_ice(:,:,:) = 0._wp 1997 2075 END SELECT 1998 2076 … … 2010 2088 ! ! ========================= ! 2011 2089 CASE ('coupled') 2012 IF( ln_mixcpl ) THEN 2013 DO jl=1,jpl 2014 qml_ice(:,:,jl) = qml_ice(:,:,jl) * xcplmask(:,:,0) + frcv(jpr_topm)%z3(:,:,jl) * zmsk(:,:) 2015 qcn_ice(:,:,jl) = qcn_ice(:,:,jl) * xcplmask(:,:,0) + frcv(jpr_botm)%z3(:,:,jl) * zmsk(:,:) 2016 ENDDO 2090 IF (ln_scale_ice_flux) THEN 2091 WHERE( a_i(:,:,:) > 1.e-10_wp ) 2092 qml_ice(:,:,:) = frcv(jpr_topm)%z3(:,:,:) * a_i_last_couple(:,:,:) / a_i(:,:,:) 2093 qcn_ice(:,:,:) = frcv(jpr_botm)%z3(:,:,:) * a_i_last_couple(:,:,:) / a_i(:,:,:) 2094 ELSEWHERE 2095 qml_ice(:,:,:) = 0.0_wp 2096 qcn_ice(:,:,:) = 0.0_wp 2097 END WHERE 2017 2098 ELSE 2018 2099 qml_ice(:,:,:) = frcv(jpr_topm)%z3(:,:,:) … … 2025 2106 IF( .NOT.ln_cndflx ) THEN !== No conduction flux as surface forcing ==! 2026 2107 ! 2027 ! ! ===> used prescribed cloud fraction representative for polar oceans in summer (0.81) 2028 ztri = 0.18 * ( 1.0 - cldf_ice ) + 0.35 * cldf_ice ! surface transmission when hi>10cm (Grenfell Maykut 77) 2029 ! 2030 WHERE ( phs(:,:,:) <= 0._wp .AND. phi(:,:,:) < 0.1_wp ) ! linear decrease from hi=0 to 10cm 2031 zqtr_ice_top(:,:,:) = qsr_ice(:,:,:) * ( ztri + ( 1._wp - ztri ) * ( 1._wp - phi(:,:,:) * 10._wp ) ) 2032 ELSEWHERE( phs(:,:,:) <= 0._wp .AND. phi(:,:,:) >= 0.1_wp ) ! constant (ztri) when hi>10cm 2033 zqtr_ice_top(:,:,:) = qsr_ice(:,:,:) * ztri 2034 ELSEWHERE ! zero when hs>0 2035 zqtr_ice_top(:,:,:) = 0._wp 2036 END WHERE 2108 IF( nn_qtrice == 0 ) THEN 2109 ! formulation derived from Grenfell and Maykut (1977), where transmission rate 2110 ! 1) depends on cloudiness 2111 ! ! ===> used prescribed cloud fraction representative for polar oceans in summer (0.81) 2112 ! ! should be real cloud fraction instead (as in the bulk) but needs to be read from atm. 2113 ! 2) is 0 when there is any snow 2114 ! 3) tends to 1 for thin ice 2115 ztri(:,:) = 0.18 * ( 1.0 - cloud_fra(:,:) ) + 0.35 * cloud_fra(:,:) ! surface transmission when hi>10cm 2116 DO jl = 1, jpl 2117 WHERE ( phs(:,:,jl) <= 0._wp .AND. phi(:,:,jl) < 0.1_wp ) ! linear decrease from hi=0 to 10cm 2118 zqtr_ice_top(:,:,jl) = zqsr_ice(:,:,jl) * ( ztri(:,:) + ( 1._wp - ztri(:,:) ) * ( 1._wp - phi(:,:,jl) * 10._wp ) ) 2119 ELSEWHERE( phs(:,:,jl) <= 0._wp .AND. phi(:,:,jl) >= 0.1_wp ) ! constant (ztri) when hi>10cm 2120 zqtr_ice_top(:,:,jl) = zqsr_ice(:,:,jl) * ztri(:,:) 2121 ELSEWHERE ! zero when hs>0 2122 zqtr_ice_top(:,:,jl) = 0._wp 2123 END WHERE 2124 ENDDO 2125 ELSEIF( nn_qtrice == 1 ) THEN 2126 ! formulation is derived from the thesis of M. Lebrun (2019). 2127 ! It represents the best fit using several sets of observations 2128 ! It comes with snow conductivities adapted to freezing/melting conditions (see icethd_zdf_bl99.F90) 2129 zqtr_ice_top(:,:,:) = 0.3_wp * zqsr_ice(:,:,:) 2130 ENDIF 2037 2131 ! 2038 2132 ELSEIF( ln_cndflx .AND. .NOT.ln_cndemulate ) THEN !== conduction flux as surface forcing ==! 2039 2133 ! 2040 ! 2041 ! 2134 ! ! ===> here we must receive the qtr_ice_top array from the coupler 2135 ! for now just assume zero (fully opaque ice) 2042 2136 zqtr_ice_top(:,:,:) = 0._wp 2043 2137 ! … … 2096 2190 ! 2097 2191 isec = ( kt - nit000 ) * NINT( rn_Dt ) ! date of exchanges 2192 info = OASIS_idle 2098 2193 2099 2194 zfr_l(:,:) = 1.- fr_i(:,:) … … 2234 2329 ENDIF 2235 2330 2331 #if defined key_si3 || defined key_cice 2332 ! If this coupling was successful then save ice fraction for use between coupling points. 2333 ! This is needed for some calculations where the ice fraction at the last coupling point 2334 ! is needed. 2335 IF( info == OASIS_Sent .OR. info == OASIS_ToRest .OR. & 2336 & info == OASIS_SentOut .OR. info == OASIS_ToRestOut ) THEN 2337 IF ( sn_snd_thick%clcat == 'yes' ) THEN 2338 a_i_last_couple(:,:,1:jpl) = a_i(:,:,1:jpl) 2339 ENDIF 2340 ENDIF 2341 #endif 2342 2236 2343 IF( ssnd(jps_fice1)%laction ) THEN 2237 2344 SELECT CASE( sn_snd_thick1%clcat ) … … 2297 2404 SELECT CASE( sn_snd_mpnd%clcat ) 2298 2405 CASE( 'yes' ) 2299 ztmp3(:,:,1:jpl) = a_ip_ frac(:,:,1:jpl)2406 ztmp3(:,:,1:jpl) = a_ip_eff(:,:,1:jpl) 2300 2407 ztmp4(:,:,1:jpl) = h_ip(:,:,1:jpl) 2301 2408 CASE( 'no' ) … … 2303 2410 ztmp4(:,:,:) = 0.0 2304 2411 DO jl=1,jpl 2305 ztmp3(:,:,1) = ztmp3(:,:,1) + a_ip_frac(:,:,jpl) 2306 ztmp4(:,:,1) = ztmp4(:,:,1) + h_ip(:,:,jpl) 2412 ztmp3(:,:,1) = ztmp3(:,:,1) + a_ip_frac(:,:,jpl) 2413 ztmp4(:,:,1) = ztmp4(:,:,1) + h_ip(:,:,jpl) 2307 2414 ENDDO 2308 2415 CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_mpnd%clcat' ) -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/SBC/sbcdcy.F90
r13295 r13998 110 110 111 111 imask_night(:,:) = 0 112 DO_2D( 1, 1, 1, 1)112 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 113 113 ztmpm = 0._wp 114 114 IF( ABS(rab(ji,jj)) < 1. ) THEN ! day duration is less than 24h … … 193 193 194 194 zsin = SIN( zdecrad ) ; zcos = COS( zdecrad ) 195 DO_2D( 1, 1, 1, 1)195 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 196 196 ztmp = rad * gphit(ji,jj) 197 197 raa(ji,jj) = SIN( ztmp ) * zsin … … 202 202 ! rab to test if the day time is equal to 0, less than 24h of full day 203 203 rab(:,:) = -raa(:,:) / rbb(:,:) 204 DO_2D( 1, 1, 1, 1)204 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 205 205 IF( ABS(rab(ji,jj)) < 1._wp ) THEN ! day duration is less than 24h 206 206 ! When is it night? … … 226 226 ! Avoid possible infinite scaling factor, associated with very short daylight 227 227 ! periods, by ignoring periods less than 1/1000th of a day (ticket #1040) 228 DO_2D( 1, 1, 1, 1)228 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 229 229 IF( ABS(rab(ji,jj)) < 1._wp ) THEN ! day duration is less than 24h 230 230 rscal(ji,jj) = 0.0_wp -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/SBC/sbcflx.F90
r13295 r13998 29 29 PUBLIC sbc_flx ! routine called by step.F90 30 30 31 INTEGER , PARAMETER :: jpfld = 5 ! maximum number of files to read32 31 INTEGER , PARAMETER :: jp_utau = 1 ! index of wind stress (i-component) file 33 32 INTEGER , PARAMETER :: jp_vtau = 2 ! index of wind stress (j-component) file … … 35 34 INTEGER , PARAMETER :: jp_qsr = 4 ! index of solar heat file 36 35 INTEGER , PARAMETER :: jp_emp = 5 ! index of evaporation-precipation file 36 !!INTEGER , PARAMETER :: jp_sfx = 6 ! index of salt flux flux 37 INTEGER , PARAMETER :: jpfld = 5 !! 6 ! maximum number of files to read 37 38 TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf ! structure of input fields (file informations, fields read) 38 39 … … 59 60 !! net downward radiative flux qsr (watt/m2) 60 61 !! net upward freshwater (evapo - precip) emp (kg/m2/s) 62 !! salt flux sfx (pss*dh*rho/dt => g/m2/s) 61 63 !! 62 64 !! CAUTION : - never mask the surface stress fields … … 71 73 !! - emp upward mass flux (evap. - precip.) 72 74 !! - sfx salt flux; set to zero at nit000 but possibly non-zero 73 !! if ice is present75 !! if ice 74 76 !!---------------------------------------------------------------------- 75 77 INTEGER, INTENT(in) :: kt ! ocean time step … … 85 87 CHARACTER(len=100) :: cn_dir ! Root directory for location of flx files 86 88 TYPE(FLD_N), DIMENSION(jpfld) :: slf_i ! array of namelist information structures 87 TYPE(FLD_N) :: sn_utau, sn_vtau, sn_qtot, sn_qsr, sn_emp ! informations about the fields to be read88 NAMELIST/namsbc_flx/ cn_dir, sn_utau, sn_vtau, sn_qtot, sn_qsr, sn_emp 89 TYPE(FLD_N) :: sn_utau, sn_vtau, sn_qtot, sn_qsr, sn_emp !!, sn_sfx ! informations about the fields to be read 90 NAMELIST/namsbc_flx/ cn_dir, sn_utau, sn_vtau, sn_qtot, sn_qsr, sn_emp !!, sn_sfx 89 91 !!--------------------------------------------------------------------- 90 92 ! … … 105 107 slf_i(jp_utau) = sn_utau ; slf_i(jp_vtau) = sn_vtau 106 108 slf_i(jp_qtot) = sn_qtot ; slf_i(jp_qsr ) = sn_qsr 107 slf_i(jp_emp ) = sn_emp 109 slf_i(jp_emp ) = sn_emp !! ; slf_i(jp_sfx ) = sn_sfx 108 110 ! 109 111 ALLOCATE( sf(jpfld), STAT=ierror ) ! set sf structure … … 118 120 CALL fld_fill( sf, slf_i, cn_dir, 'sbc_flx', 'flux formulation for ocean surface boundary condition', 'namsbc_flx' ) 119 121 ! 120 sfx(:,:) = 0.0_wp ! salt flux due to freezing/melting (non-zero only if ice is present)121 !122 122 ENDIF 123 123 … … 126 126 IF( MOD( kt-1, nn_fsbc ) == 0 ) THEN ! update ocean fluxes at each SBC frequency 127 127 128 IF( ln_dm2dc ) THEN ; qsr(:,:) = sbc_dcy( sf(jp_qsr)%fnow(:,:,1) ) ! modify now Qsr to include the diurnal cycle 129 ELSE ; qsr(:,:) = sf(jp_qsr)%fnow(:,:,1) 128 IF( ln_dm2dc ) THEN ! modify now Qsr to include the diurnal cycle 129 qsr(:,:) = sbc_dcy( sf(jp_qsr)%fnow(:,:,1) ) * tmask(ji,jj,1) 130 ELSE 131 DO_2D( 0, 0, 0, 0 ) 132 qsr(ji,jj) = sf(jp_qsr)%fnow(ji,jj,1) * tmask(ji,jj,1) 133 END_2D 130 134 ENDIF 131 DO_2D( 1, 1, 1, 1 ) 132 utau(ji,jj) = sf(jp_utau)%fnow(ji,jj,1) 133 vtau(ji,jj) = sf(jp_vtau)%fnow(ji,jj,1) 134 qns (ji,jj) = sf(jp_qtot)%fnow(ji,jj,1) - sf(jp_qsr)%fnow(ji,jj,1) 135 emp (ji,jj) = sf(jp_emp )%fnow(ji,jj,1) 135 DO_2D( 0, 0, 0, 0 ) ! set the ocean fluxes from read fields 136 utau(ji,jj) = sf(jp_utau)%fnow(ji,jj,1) * umask(ji,jj,1) 137 vtau(ji,jj) = sf(jp_vtau)%fnow(ji,jj,1) * vmask(ji,jj,1) 138 qns (ji,jj) = ( sf(jp_qtot)%fnow(ji,jj,1) - sf(jp_qsr)%fnow(ji,jj,1) ) * tmask(ji,jj,1) 139 emp (ji,jj) = sf(jp_emp )%fnow(ji,jj,1) * tmask(ji,jj,1) 140 !!sfx (ji,jj) = sf(jp_sfx )%fnow(ji,jj,1) * tmask(ji,jj,1) 136 141 END_2D 137 142 ! ! add to qns the heat due to e-p 138 qns(:,:) = qns(:,:) - emp(:,:) * sst_m(:,:) * rcp ! mass flux is at SST 143 !!clem: I do not think it is needed 144 !!qns(:,:) = qns(:,:) - emp(:,:) * sst_m(:,:) * rcp ! mass flux is at SST 139 145 ! 140 qns(:,:) = qns(:,:) * tmask(:,:,1) 141 emp(:,:) = emp(:,:) * tmask(:,:,1) 146 ! clem: without these lbc calls, it seems that the northfold is not ok (true in 3.6, not sure in 4.x) 147 CALL lbc_lnk_multi( 'sbcflx', utau, 'U', -1._wp, vtau, 'V', -1._wp, & 148 & qns, 'T', 1._wp, emp , 'T', 1._wp, qsr, 'T', 1._wp ) !! sfx, 'T', 1._wp ) 142 149 ! 143 ! ! module of wind stress and wind speed at T-point144 zcoef = 1. / ( zrhoa * zcdrag )145 DO_2D( 0, 0, 0, 0 )146 ztx = utau(ji-1,jj ) + utau(ji,jj)147 zty = vtau(ji ,jj-1) + vtau(ji,jj)148 zmod = 0.5 * SQRT( ztx * ztx + zty * zty )149 taum(ji,jj) = zmod150 wndm(ji,jj) = SQRT( zmod * zcoef )151 END_2D152 taum(:,:) = taum(:,:) * tmask(:,:,1) ; wndm(:,:) = wndm(:,:) * tmask(:,:,1)153 CALL lbc_lnk( 'sbcflx', taum(:,:), 'T', 1.0_wp ) ; CALL lbc_lnk( 'sbcflx', wndm(:,:), 'T', 1.0_wp )154 155 150 IF( nitend-nit000 <= 100 .AND. lwp ) THEN ! control print (if less than 100 time-step asked) 156 151 WRITE(numout,*) … … 166 161 ! 167 162 ENDIF 163 ! ! module of wind stress and wind speed at T-point 164 ! Note the use of 0.5*(2-umask) in order to unmask the stress along coastlines 165 zcoef = 1. / ( zrhoa * zcdrag ) 166 DO_2D( 0, 0, 0, 0 ) 167 ztx = ( utau(ji-1,jj ) + utau(ji,jj) ) * 0.5_wp * ( 2._wp - MIN( umask(ji-1,jj ,1), umask(ji,jj,1) ) ) 168 zty = ( vtau(ji ,jj-1) + vtau(ji,jj) ) * 0.5_wp * ( 2._wp - MIN( vmask(ji ,jj-1,1), vmask(ji,jj,1) ) ) 169 zmod = 0.5_wp * SQRT( ztx * ztx + zty * zty ) * tmask(ji,jj,1) 170 taum(ji,jj) = zmod 171 wndm(ji,jj) = SQRT( zmod * zcoef ) !!clem: not used? 172 END_2D 173 ! 174 CALL lbc_lnk_multi( 'sbcflx', taum, 'T', 1._wp, wndm, 'T', 1._wp ) 168 175 ! 169 176 END SUBROUTINE sbc_flx -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/SBC/sbcfwb.F90
r13286 r13998 94 94 snwice_mass_b(:,:) = 0.e0 ! no sea-ice model is being used : no snow+ice mass 95 95 snwice_mass (:,:) = 0.e0 96 snwice_fmass (:,:) = 0.e0 96 97 #endif 97 98 ! -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/SBC/sbcmod.F90
r13895 r13998 99 99 & nn_ice , ln_ice_embd, & 100 100 & ln_traqsr, ln_dm2dc , & 101 & ln_rnf , nn_fwb , ln_ssr , ln_apr_dyn,&102 & ln_wave , ln_cdgw , ln_sdw , ln_tauwoc , ln_stcor ,&101 & ln_rnf , nn_fwb , ln_ssr , ln_apr_dyn, & 102 & ln_wave , ln_cdgw , ln_sdw , ln_tauwoc , ln_stcor , & 103 103 & ln_tauw , nn_lsm, nn_sdrift 104 104 !!---------------------------------------------------------------------- … … 119 119 #if defined key_mpp_mpi 120 120 ncom_fsbc = nn_fsbc ! make nn_fsbc available for lib_mpp 121 #endif 122 #if ! defined key_si3 123 IF( nn_ice == 2 ) nn_ice = 0 ! without key key_si3 you cannot use si3... 121 124 #endif 122 125 ! … … 226 229 CASE DEFAULT !- not supported 227 230 END SELECT 228 IF( ln_diurnal .AND. .NOT. ln_blk) CALL ctl_stop( "sbc_init: diurnal flux processing only implemented for bulk forcing" )231 IF( ln_diurnal .AND. .NOT. (ln_blk.OR.ln_abl) ) CALL ctl_stop( "sbc_init: diurnal flux processing only implemented for bulk forcing" ) 229 232 ! 230 233 ! !** allocate and set required variables … … 243 246 ENDIF 244 247 ! 245 246 248 IF( nn_ice == 0 ) THEN !* No sea-ice in the domain : ice fraction is always zero 247 249 IF( nn_components /= jp_iam_opa ) fr_i(:,:) = 0._wp ! except for OPA in SAS-OPA coupled case … … 250 252 sfx (:,:) = 0._wp !* salt flux due to freezing/melting 251 253 fmmflx(:,:) = 0._wp !* freezing minus melting flux 254 cloud_fra(:,:) = pp_cldf !* cloud fraction over sea ice (used in si3) 252 255 253 256 taum(:,:) = 0._wp !* wind stress module (needed in GLS in case of reduced restart) … … 334 337 IF( l_sbc_clo ) CALL sbc_clo_init ! closed sea surface initialisation 335 338 ! 336 IF( ln_blk ) CALL sbc_blk_init ! bulk formulae initialization337 338 IF( ln_abl ) CALL sbc_abl_init ! Atmospheric Boundary Layer (ABL)339 340 IF( ln_ssr ) CALL sbc_ssr_init ! Sea-Surface Restoring initialization339 IF( ln_blk ) CALL sbc_blk_init ! bulk formulae initialization 340 341 IF( ln_abl ) CALL sbc_abl_init ! Atmospheric Boundary Layer (ABL) 342 343 IF( ln_ssr ) CALL sbc_ssr_init ! Sea-Surface Restoring initialization 341 344 ! 342 345 ! … … 561 564 ENDIF 562 565 ! 563 CALL iom_put( "utau", utau ) ! i-wind stress (stress can be updated at each time step in sea-ice)564 CALL iom_put( "vtau", vtau ) ! j-wind stress565 !566 566 IF(sn_cfctl%l_prtctl) THEN ! print mean trends (used for debugging) 567 567 CALL prt_ctl(tab2d_1=fr_i , clinfo1=' fr_i - : ', mask1=tmask ) -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/SBC/sbcrnf.F90
r13895 r13998 214 214 END_2D 215 215 ELSE !* variable volume case 216 DO_2D( 1, 1, 1, 1 ) 216 DO_2D( 1, 1, 1, 1 ) ! update the depth over which runoffs are distributed 217 217 h_rnf(ji,jj) = 0._wp 218 DO jk = 1, nk_rnf(ji,jj) ! recalculates h_rnf to be the depth in metres218 DO jk = 1, nk_rnf(ji,jj) ! recalculates h_rnf to be the depth in metres 219 219 h_rnf(ji,jj) = h_rnf(ji,jj) + e3t(ji,jj,jk,Kmm) ! to the bottom of the relevant grid box 220 220 END DO … … 373 373 ENDIF 374 374 END_2D 375 DO_2D( 1, 1, 1, 1 ) 375 DO_2D( 1, 1, 1, 1 ) ! set the associated depth 376 376 h_rnf(ji,jj) = 0._wp 377 377 DO jk = 1, nk_rnf(ji,jj) … … 403 403 WHERE( zrnfcl(:,:,1) > 0._wp ) h_rnf(:,:) = zacoef * zrnfcl(:,:,1) ! compute depth for all runoffs 404 404 ! 405 DO_2D( 1, 1, 1, 1 ) 405 DO_2D( 1, 1, 1, 1 ) ! take in account min depth of ocean rn_hmin 406 406 IF( zrnfcl(ji,jj,1) > 0._wp ) THEN 407 407 jk = mbkt(ji,jj) … … 422 422 END_2D 423 423 ! 424 DO_2D( 1, 1, 1, 1 ) 424 DO_2D( 1, 1, 1, 1 ) ! set the associated depth 425 425 h_rnf(ji,jj) = 0._wp 426 426 DO jk = 1, nk_rnf(ji,jj) -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/SBC/sbcwave.F90
r13295 r13998 106 106 !!--------------------------------------------------------------------- 107 107 ! 108 ALLOCATE( ze3divh(jpi,jpj,jpk ) )108 ALLOCATE( ze3divh(jpi,jpj,jpkm1) ) ! jpkm1 -> avoid lbc_lnk on jpk that is not defined 109 109 ALLOCATE( zk_t(jpi,jpj), zk_u(jpi,jpj), zk_v(jpi,jpj), zu0_sd(jpi,jpj), zv0_sd(jpi,jpj) ) 110 110 ! … … 121 121 zk_t(ji,jj) = ABS( tsd2d(ji,jj) ) / MAX( ABS( 5.97_wp*ztransp ), 0.0000001_wp ) 122 122 END_2D 123 DO_2D( 1, 0, 1, 0 ) 123 DO_2D( 1, 0, 1, 0 ) ! exp. wave number & Stokes drift velocity at u- & v-points 124 124 zk_u(ji,jj) = 0.5_wp * ( zk_t(ji,jj) + zk_t(ji+1,jj) ) 125 125 zk_v(ji,jj) = 0.5_wp * ( zk_t(ji,jj) + zk_t(ji,jj+1) ) … … 164 164 zsqrtpi = SQRT(rpi) 165 165 z_two_thirds = 2.0_wp / 3.0_wp 166 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 166 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) ! exp. wave number & Stokes drift velocity at u- & v-points 167 167 zbot_u = ( gdepw(ji,jj,jk+1,Kmm) + gdepw(ji+1,jj,jk+1,Kmm) ) ! 2 * bottom depth 168 168 zbot_v = ( gdepw(ji,jj,jk+1,Kmm) + gdepw(ji,jj+1,jk+1,Kmm) ) ! 2 * bottom depth … … 204 204 ! !== vertical Stokes Drift 3D velocity ==! 205 205 ! 206 DO_3D( 0, 1, 0, 1, 1, jpkm1 ) 206 DO_3D( 0, 1, 0, 1, 1, jpkm1 ) ! Horizontal e3*divergence 207 207 ze3divh(ji,jj,jk) = ( e2u(ji ,jj) * e3u(ji ,jj,jk,Kmm) * usd(ji ,jj,jk) & 208 208 & - e2u(ji-1,jj) * e3u(ji-1,jj,jk,Kmm) * usd(ji-1,jj,jk) & -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/TRA/eosbn2.F90
r13295 r13998 873 873 IF( ln_timing ) CALL timing_start('bn2') 874 874 ! 875 DO_3D( 1, 1, 1, 1, 2, jpkm1 ) 875 DO_3D( 1, 1, 1, 1, 2, jpkm1 ) ! interior points only (2=< jk =< jpkm1 ); surface and bottom value set to zero one for all in istate.F90 876 876 zrw = ( gdepw(ji,jj,jk ,Kmm) - gdept(ji,jj,jk,Kmm) ) & 877 877 & / ( gdept(ji,jj,jk-1,Kmm) - gdept(ji,jj,jk,Kmm) ) -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/TRA/traadv_cen.F90
r13295 r13998 112 112 ztu(:,:,jpk) = 0._wp ! Bottom value : flux set to zero 113 113 ztv(:,:,jpk) = 0._wp 114 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 114 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) ! masked gradient 115 115 ztu(ji,jj,jk) = ( pt(ji+1,jj ,jk,jn,Kmm) - pt(ji,jj,jk,jn,Kmm) ) * umask(ji,jj,jk) 116 116 ztv(ji,jj,jk) = ( pt(ji ,jj+1,jk,jn,Kmm) - pt(ji,jj,jk,jn,Kmm) ) * vmask(ji,jj,jk) … … 118 118 CALL lbc_lnk_multi( 'traadv_cen', ztu, 'U', -1.0_wp , ztv, 'V', -1.0_wp ) ! Lateral boundary cond. 119 119 ! 120 DO_3D( 0, 0, 1, 0, 1, jpkm1 )120 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) ! Horizontal advective fluxes 121 121 zC2t_u = pt(ji,jj,jk,jn,Kmm) + pt(ji+1,jj ,jk,jn,Kmm) ! C2 interpolation of T at u- & v-points (x2) 122 122 zC2t_v = pt(ji,jj,jk,jn,Kmm) + pt(ji ,jj+1,jk,jn,Kmm) … … 128 128 zwy(ji,jj,jk) = 0.5_wp * pV(ji,jj,jk) * zC4t_v 129 129 END_3D 130 CALL lbc_lnk_multi( 'traadv_cen', zwx, 'U', -1. , zwy, 'V', -1. ) 130 131 ! 131 132 CASE DEFAULT 132 CALL ctl_stop( 'traadv_ fct: wrong value for nn_fct' )133 CALL ctl_stop( 'traadv_cen: wrong value for nn_cen' ) 133 134 END SELECT 134 135 ! … … 158 159 ENDIF 159 160 ! 160 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 161 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) !-- Divergence of advective fluxes --! 161 162 pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) & 162 163 & - ( zwx(ji,jj,jk) - zwx(ji-1,jj ,jk ) & … … 165 166 & * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) 166 167 END_3D 167 ! ! trend diagnostics168 ! ! trend diagnostics 168 169 IF( l_trd ) THEN 169 170 CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_xad, zwx, pU, pt(:,:,:,jn,Kmm) ) -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/TRA/traadv_fct.F90
r13295 r13998 160 160 zwy(ji,jj,jk) = 0.5 * ( zfp_vj * pt(ji,jj,jk,jn,Kbb) + zfm_vj * pt(ji ,jj+1,jk,jn,Kbb) ) 161 161 END_3D 162 ! !* upstream tracer flux in the k direction *!163 DO_3D( 1, 1, 1, 1, 2, jpkm1 ) 162 ! !* upstream tracer flux in the k direction *! 163 DO_3D( 1, 1, 1, 1, 2, jpkm1 ) ! Interior value ( multiplied by wmask) 164 164 zfp_wk = pW(ji,jj,jk) + ABS( pW(ji,jj,jk) ) 165 165 zfm_wk = pW(ji,jj,jk) - ABS( pW(ji,jj,jk) ) 166 166 zwz(ji,jj,jk) = 0.5 * ( zfp_wk * pt(ji,jj,jk,jn,Kbb) + zfm_wk * pt(ji,jj,jk-1,jn,Kbb) ) * wmask(ji,jj,jk) 167 167 END_3D 168 IF( ln_linssh ) THEN ! top ocean value (only in linear free surface as zwz has been w-masked)169 IF( ln_isfcav ) THEN ! top of the ice-shelf cavities and at the ocean surface168 IF( ln_linssh ) THEN ! top ocean value (only in linear free surface as zwz has been w-masked) 169 IF( ln_isfcav ) THEN ! top of the ice-shelf cavities and at the ocean surface 170 170 DO_2D( 1, 1, 1, 1 ) 171 171 zwz(ji,jj, mikt(ji,jj) ) = pW(ji,jj,mikt(ji,jj)) * pt(ji,jj,mikt(ji,jj),jn,Kbb) ! linear free surface 172 172 END_2D 173 ELSE ! no cavities: only at the ocean surface173 ELSE ! no cavities: only at the ocean surface 174 174 DO_2D( 1, 1, 1, 1 ) 175 175 zwz(ji,jj,1) = pW(ji,jj,1) * pt(ji,jj,1,jn,Kbb) … … 178 178 ENDIF 179 179 ! 180 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 181 ! ! total intermediate advective trends180 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) !* trend and after field with monotonic scheme 181 ! ! total intermediate advective trends 182 182 ztra = - ( zwx(ji,jj,jk) - zwx(ji-1,jj ,jk ) & 183 183 & + zwy(ji,jj,jk) - zwy(ji ,jj-1,jk ) & 184 184 & + zwz(ji,jj,jk) - zwz(ji ,jj ,jk+1) ) * r1_e1e2t(ji,jj) 185 ! ! update and guess with monotonic sheme185 ! ! update and guess with monotonic sheme 186 186 pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) + ztra & 187 187 & / e3t(ji,jj,jk,Kmm ) * tmask(ji,jj,jk) … … 194 194 ! 195 195 ztw(:,:,1) = 0._wp ; ztw(:,:,jpk) = 0._wp ; 196 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) 196 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) ! Interior value ( multiplied by wmask) 197 197 zfp_wk = wi(ji,jj,jk) + ABS( wi(ji,jj,jk) ) 198 198 zfm_wk = wi(ji,jj,jk) - ABS( wi(ji,jj,jk) ) … … 227 227 zltv(:,:,jpk) = 0._wp 228 228 DO jk = 1, jpkm1 ! Laplacian 229 DO_2D( 1, 0, 1, 0 ) 229 DO_2D( 1, 0, 1, 0 ) ! 1st derivative (gradient) 230 230 ztu(ji,jj,jk) = ( pt(ji+1,jj ,jk,jn,Kmm) - pt(ji,jj,jk,jn,Kmm) ) * umask(ji,jj,jk) 231 231 ztv(ji,jj,jk) = ( pt(ji ,jj+1,jk,jn,Kmm) - pt(ji,jj,jk,jn,Kmm) ) * vmask(ji,jj,jk) 232 232 END_2D 233 DO_2D( 0, 0, 0, 0 ) 233 DO_2D( 0, 0, 0, 0 ) ! 2nd derivative * 1/ 6 234 234 zltu(ji,jj,jk) = ( ztu(ji,jj,jk) + ztu(ji-1,jj,jk) ) * r1_6 235 235 zltv(ji,jj,jk) = ( ztv(ji,jj,jk) + ztv(ji,jj-1,jk) ) * r1_6 … … 238 238 CALL lbc_lnk_multi( 'traadv_fct', zltu, 'T', 1.0_wp , zltv, 'T', 1.0_wp ) ! Lateral boundary cond. (unchanged sgn) 239 239 ! 240 DO_3D( 1, 0, 1, 0, 1, jpkm1 ) 240 DO_3D( 1, 0, 1, 0, 1, jpkm1 ) ! Horizontal advective fluxes 241 241 zC2t_u = pt(ji,jj,jk,jn,Kmm) + pt(ji+1,jj ,jk,jn,Kmm) ! 2 x C2 interpolation of T at u- & v-points 242 242 zC2t_v = pt(ji,jj,jk,jn,Kmm) + pt(ji ,jj+1,jk,jn,Kmm) 243 ! ! C4 minus upstream advective fluxes243 ! ! C4 minus upstream advective fluxes 244 244 zwx(ji,jj,jk) = 0.5_wp * pU(ji,jj,jk) * ( zC2t_u + zltu(ji,jj,jk) - zltu(ji+1,jj,jk) ) - zwx(ji,jj,jk) 245 245 zwy(ji,jj,jk) = 0.5_wp * pV(ji,jj,jk) * ( zC2t_v + zltv(ji,jj,jk) - zltv(ji,jj+1,jk) ) - zwy(ji,jj,jk) … … 249 249 ztu(:,:,jpk) = 0._wp ! Bottom value : flux set to zero 250 250 ztv(:,:,jpk) = 0._wp 251 DO_3D( 1, 0, 1, 0, 1, jpkm1 ) 251 DO_3D( 1, 0, 1, 0, 1, jpkm1 ) ! 1st derivative (gradient) 252 252 ztu(ji,jj,jk) = ( pt(ji+1,jj ,jk,jn,Kmm) - pt(ji,jj,jk,jn,Kmm) ) * umask(ji,jj,jk) 253 253 ztv(ji,jj,jk) = ( pt(ji ,jj+1,jk,jn,Kmm) - pt(ji,jj,jk,jn,Kmm) ) * vmask(ji,jj,jk) … … 255 255 CALL lbc_lnk_multi( 'traadv_fct', ztu, 'U', -1.0_wp , ztv, 'V', -1.0_wp ) ! Lateral boundary cond. (unchanged sgn) 256 256 ! 257 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 257 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) ! Horizontal advective fluxes 258 258 zC2t_u = pt(ji,jj,jk,jn,Kmm) + pt(ji+1,jj ,jk,jn,Kmm) ! 2 x C2 interpolation of T at u- & v-points (x2) 259 259 zC2t_v = pt(ji,jj,jk,jn,Kmm) + pt(ji ,jj+1,jk,jn,Kmm) … … 288 288 ! 289 289 IF ( ll_zAimp ) THEN 290 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 291 ! ! total intermediate advective trends290 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) !* trend and after field with monotonic scheme 291 ! ! total intermediate advective trends 292 292 ztra = - ( zwx(ji,jj,jk) - zwx(ji-1,jj ,jk ) & 293 293 & + zwy(ji,jj,jk) - zwy(ji ,jj-1,jk ) & … … 298 298 CALL tridia_solver( zwdia, zwsup, zwinf, ztw, ztw , 0 ) 299 299 ! 300 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) 300 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) ! Interior value ( multiplied by wmask) 301 301 zfp_wk = wi(ji,jj,jk) + ABS( wi(ji,jj,jk) ) 302 302 zfm_wk = wi(ji,jj,jk) - ABS( wi(ji,jj,jk) ) … … 324 324 ! 325 325 ztw(:,:,1) = 0._wp ; ztw(:,:,jpk) = 0._wp 326 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) 326 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) ! Interior value ( multiplied by wmask) 327 327 zfp_wk = wi(ji,jj,jk) + ABS( wi(ji,jj,jk) ) 328 328 zfm_wk = wi(ji,jj,jk) - ABS( wi(ji,jj,jk) ) … … 454 454 pbb(ji,jj,jk) = pbb(ji,jj,jk) * ( zcv * zav + ( 1._wp - zcv) * zbv ) 455 455 456 ! monotonic flux in the k direction, i.e. pcc457 ! -------------------------------------------456 ! monotonic flux in the k direction, i.e. pcc 457 ! ------------------------------------------- 458 458 za = MIN( 1., zbetdo(ji,jj,jk+1), zbetup(ji,jj,jk) ) 459 459 zb = MIN( 1., zbetup(ji,jj,jk+1), zbetdo(ji,jj,jk) ) … … 481 481 !!---------------------------------------------------------------------- 482 482 483 DO_3D( 1, 1, 1, 1, 3, jpkm1 ) 483 DO_3D( 1, 1, 1, 1, 3, jpkm1 ) !== build the three diagonal matrix ==! 484 484 zwd (ji,jj,jk) = 4._wp 485 485 zwi (ji,jj,jk) = 1._wp … … 495 495 END_3D 496 496 ! 497 jk = 2 497 jk = 2 ! Switch to second order centered at top 498 498 DO_2D( 1, 1, 1, 1 ) 499 499 zwd (ji,jj,jk) = 1._wp … … 504 504 ! 505 505 ! !== tridiagonal solve ==! 506 DO_2D( 1, 1, 1, 1 ) 506 DO_2D( 1, 1, 1, 1 ) ! first recurrence 507 507 zwt(ji,jj,2) = zwd(ji,jj,2) 508 508 END_2D … … 511 511 END_3D 512 512 ! 513 DO_2D( 1, 1, 1, 1 ) 513 DO_2D( 1, 1, 1, 1 ) ! second recurrence: Zk = Yk - Ik / Tk-1 Zk-1 514 514 pt_out(ji,jj,2) = zwrm(ji,jj,2) 515 515 END_2D … … 518 518 END_3D 519 519 520 DO_2D( 1, 1, 1, 1 ) 520 DO_2D( 1, 1, 1, 1 ) ! third recurrence: Xk = (Zk - Sk Xk+1 ) / Tk 521 521 pt_out(ji,jj,jpkm1) = pt_out(ji,jj,jpkm1) / zwt(ji,jj,jpkm1) 522 522 END_2D … … 546 546 ! !== build the three diagonal matrix & the RHS ==! 547 547 ! 548 DO_3D( 0, 0, 0, 0, 3, jpkm1 ) 548 DO_3D( 0, 0, 0, 0, 3, jpkm1 ) ! interior (from jk=3 to jpk-1) 549 549 zwd (ji,jj,jk) = 3._wp * wmask(ji,jj,jk) + 1._wp ! diagonal 550 550 zwi (ji,jj,jk) = wmask(ji,jj,jk) ! lower diagonal … … 565 565 END IF 566 566 ! 567 DO_2D( 0, 0, 0, 0 ) 567 DO_2D( 0, 0, 0, 0 ) ! 2nd order centered at top & bottom 568 568 ikt = mikt(ji,jj) + 1 ! w-point below the 1st wet point 569 569 ikb = MAX(mbkt(ji,jj), 2) ! - above the last wet point … … 582 582 ! !== tridiagonal solver ==! 583 583 ! 584 DO_2D( 0, 0, 0, 0 ) 584 DO_2D( 0, 0, 0, 0 ) !* 1st recurrence: Tk = Dk - Ik Sk-1 / Tk-1 585 585 zwt(ji,jj,2) = zwd(ji,jj,2) 586 586 END_2D … … 589 589 END_3D 590 590 ! 591 DO_2D( 0, 0, 0, 0 ) 591 DO_2D( 0, 0, 0, 0 ) !* 2nd recurrence: Zk = Yk - Ik / Tk-1 Zk-1 592 592 pt_out(ji,jj,2) = zwrm(ji,jj,2) 593 593 END_2D … … 596 596 END_3D 597 597 598 DO_2D( 0, 0, 0, 0 ) 598 DO_2D( 0, 0, 0, 0 ) !* 3d recurrence: Xk = (Zk - Sk Xk+1 ) / Tk 599 599 pt_out(ji,jj,jpkm1) = pt_out(ji,jj,jpkm1) / zwt(ji,jj,jpkm1) 600 600 END_2D … … 638 638 kstart = 1 + klev 639 639 ! 640 DO_2D( 0, 0, 0, 0 ) 640 DO_2D( 0, 0, 0, 0 ) !* 1st recurrence: Tk = Dk - Ik Sk-1 / Tk-1 641 641 zwt(ji,jj,kstart) = pD(ji,jj,kstart) 642 642 END_2D … … 645 645 END_3D 646 646 ! 647 DO_2D( 0, 0, 0, 0 ) 647 DO_2D( 0, 0, 0, 0 ) !* 2nd recurrence: Zk = Yk - Ik / Tk-1 Zk-1 648 648 pt_out(ji,jj,kstart) = pRHS(ji,jj,kstart) 649 649 END_2D … … 652 652 END_3D 653 653 654 DO_2D( 0, 0, 0, 0 ) 654 DO_2D( 0, 0, 0, 0 ) !* 3d recurrence: Xk = (Zk - Sk Xk+1 ) / Tk 655 655 pt_out(ji,jj,jpkm1) = pt_out(ji,jj,jpkm1) / zwt(ji,jj,jpkm1) 656 656 END_2D -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/TRA/traadv_mus.F90
r13295 r13998 148 148 END_3D 149 149 ! 150 DO_3D( 0, 1, 0, 1, 1, jpkm1 ) 150 DO_3D( 0, 1, 0, 1, 1, jpkm1 ) !-- Slopes limitation 151 151 zslpx(ji,jj,jk) = SIGN( 1.0_wp, zslpx(ji,jj,jk) ) * MIN( ABS( zslpx(ji ,jj,jk) ), & 152 152 & 2.*ABS( zwx (ji-1,jj,jk) ), & … … 157 157 END_3D 158 158 ! 159 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 159 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) !-- MUSCL horizontal advective fluxes 160 160 ! MUSCL fluxes 161 161 z0u = SIGN( 0.5_wp, pU(ji,jj,jk) ) … … 175 175 CALL lbc_lnk_multi( 'traadv_mus', zwx, 'U', -1.0_wp , zwy, 'V', -1.0_wp ) ! lateral boundary conditions (changed sign) 176 176 ! 177 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 177 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) !-- Tracer advective trend 178 178 pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) - ( zwx(ji,jj,jk) - zwx(ji-1,jj ,jk ) & 179 179 & + zwy(ji,jj,jk) - zwy(ji ,jj-1,jk ) ) & … … 204 204 & * ( 0.25 + SIGN( 0.25_wp, zwx(ji,jj,jk) * zwx(ji,jj,jk+1) ) ) 205 205 END_3D 206 DO_3D( 1, 1, 1, 1, 2, jpkm1 ) 206 DO_3D( 1, 1, 1, 1, 2, jpkm1 ) !-- Slopes limitation 207 207 zslpx(ji,jj,jk) = SIGN( 1.0_wp, zslpx(ji,jj,jk) ) * MIN( ABS( zslpx(ji,jj,jk ) ), & 208 208 & 2.*ABS( zwx (ji,jj,jk+1) ), & 209 209 & 2.*ABS( zwx (ji,jj,jk ) ) ) 210 210 END_3D 211 DO_3D( 0, 0, 0, 0, 1, jpk-2 ) 211 DO_3D( 0, 0, 0, 0, 1, jpk-2 ) !-- vertical advective flux 212 212 z0w = SIGN( 0.5_wp, pW(ji,jj,jk+1) ) 213 213 zalpha = 0.5 + z0w … … 227 227 ENDIF 228 228 ! 229 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 229 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) !-- vertical advective trend 230 230 pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) - ( zwx(ji,jj,jk) - zwx(ji,jj,jk+1) ) & 231 231 & * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/TRA/traadv_qck.F90
r13295 r13998 142 142 ! 143 143 !!gm why not using a SHIFT instruction... 144 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 144 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) !--- Computation of the ustream and downstream value of the tracer and the mask 145 145 zfc(ji,jj,jk) = pt(ji-1,jj,jk,jn,Kbb) ! Upstream in the x-direction for the tracer 146 146 zfd(ji,jj,jk) = pt(ji+1,jj,jk,jn,Kbb) ! Downstream in the x-direction for the tracer … … 327 327 ! ! =========== 328 328 ! 329 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) 329 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) !* Interior point (w-masked 2nd order centered flux) 330 330 zwz(ji,jj,jk) = 0.5 * pW(ji,jj,jk) * ( pt(ji,jj,jk-1,jn,Kmm) + pt(ji,jj,jk,jn,Kmm) ) * wmask(ji,jj,jk) 331 331 END_3D … … 340 340 ENDIF 341 341 ! 342 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 342 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) !== Tracer flux divergence added to the general trend ==! 343 343 pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) - ( zwz(ji,jj,jk) - zwz(ji,jj,jk+1) ) & 344 344 & * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/TRA/traadv_ubs.F90
r13295 r13998 124 124 ! ! =========== 125 125 ! 126 DO jk = 1, jpkm1 !== horizontal laplacian of before tracer ==!127 DO_2D( 1, 0, 1, 0 ) 126 DO jk = 1, jpkm1 !== horizontal laplacian of before tracer ==! 127 DO_2D( 1, 0, 1, 0 ) ! First derivative (masked gradient) 128 128 zeeu = e2_e1u(ji,jj) * e3u(ji,jj,jk,Kmm) * umask(ji,jj,jk) 129 129 zeev = e1_e2v(ji,jj) * e3v(ji,jj,jk,Kmm) * vmask(ji,jj,jk) … … 131 131 ztv(ji,jj,jk) = zeev * ( pt(ji ,jj+1,jk,jn,Kbb) - pt(ji,jj,jk,jn,Kbb) ) 132 132 END_2D 133 DO_2D( 0, 0, 0, 0 ) 133 DO_2D( 0, 0, 0, 0 ) ! Second derivative (divergence) 134 134 zcoef = 1._wp / ( 6._wp * e3t(ji,jj,jk,Kmm) ) 135 135 zltu(ji,jj,jk) = ( ztu(ji,jj,jk) - ztu(ji-1,jj,jk) ) * zcoef … … 140 140 CALL lbc_lnk( 'traadv_ubs', zltu, 'T', 1.0_wp ) ; CALL lbc_lnk( 'traadv_ubs', zltv, 'T', 1.0_wp ) ! Lateral boundary cond. (unchanged sgn) 141 141 ! 142 DO_3D( 1, 0, 1, 0, 1, jpkm1 ) 143 zfp_ui = pU(ji,jj,jk) + ABS( pU(ji,jj,jk) ) ! upstream transport (x2)142 DO_3D( 1, 0, 1, 0, 1, jpkm1 ) !== Horizontal advective fluxes ==! (UBS) 143 zfp_ui = pU(ji,jj,jk) + ABS( pU(ji,jj,jk) ) ! upstream transport (x2) 144 144 zfm_ui = pU(ji,jj,jk) - ABS( pU(ji,jj,jk) ) 145 145 zfp_vj = pV(ji,jj,jk) + ABS( pV(ji,jj,jk) ) … … 166 166 ! 167 167 zltu(:,:,:) = pt(:,:,:,jn,Krhs) - zltu(:,:,:) ! Horizontal advective trend used in vertical 2nd order FCT case 168 ! ! and/or in trend diagnostic (l_trd=T)168 ! ! and/or in trend diagnostic (l_trd=T) 169 169 ! 170 170 IF( l_trd ) THEN ! trend diagnostics … … 187 187 IF( l_trd ) zltv(:,:,:) = pt(:,:,:,jn,Krhs) ! store pt(:,:,:,:,Krhs) if trend diag. 188 188 ! 189 ! !* upstream advection with initial mass fluxes & intermediate update ==!189 ! !* upstream advection with initial mass fluxes & intermediate update ==! 190 190 DO_3D( 1, 1, 1, 1, 2, jpkm1 ) 191 191 zfp_wk = pW(ji,jj,jk) + ABS( pW(ji,jj,jk) ) … … 193 193 ztw(ji,jj,jk) = 0.5_wp * ( zfp_wk * pt(ji,jj,jk,jn,Kbb) + zfm_wk * pt(ji,jj,jk-1,jn,Kbb) ) * wmask(ji,jj,jk) 194 194 END_3D 195 IF( ln_linssh ) THEN ! top ocean value (only in linear free surface as ztw has been w-masked)196 IF( ln_isfcav ) THEN ! top of the ice-shelf cavities and at the ocean surface195 IF( ln_linssh ) THEN ! top ocean value (only in linear free surface as ztw has been w-masked) 196 IF( ln_isfcav ) THEN ! top of the ice-shelf cavities and at the ocean surface 197 197 DO_2D( 1, 1, 1, 1 ) 198 198 ztw(ji,jj, mikt(ji,jj) ) = pW(ji,jj,mikt(ji,jj)) * pt(ji,jj,mikt(ji,jj),jn,Kbb) ! linear free surface 199 199 END_2D 200 ELSE ! no cavities: only at the ocean surface200 ELSE ! no cavities: only at the ocean surface 201 201 ztw(:,:,1) = pW(:,:,1) * pt(:,:,1,jn,Kbb) 202 202 ENDIF 203 203 ENDIF 204 204 ! 205 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 205 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) !* trend and after field with monotonic scheme 206 206 ztak = - ( ztw(ji,jj,jk) - ztw(ji,jj,jk+1) ) & 207 207 & * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) … … 230 230 END SELECT 231 231 ! 232 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 232 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) ! final trend with corrected fluxes 233 233 pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) - ( ztw(ji,jj,jk) - ztw(ji,jj,jk+1) ) & 234 234 & * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) 235 235 END_3D 236 236 ! 237 IF( l_trd ) THEN ! vertical advective trend diagnostics238 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 237 IF( l_trd ) THEN ! vertical advective trend diagnostics 238 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) ! (compute -w.dk[ptn]= -dk[w.ptn] + ptn.dk[w]) 239 239 zltv(ji,jj,jk) = pt(ji,jj,jk,jn,Krhs) - zltv(ji,jj,jk) & 240 240 & + pt(ji,jj,jk,jn,Kmm) * ( pW(ji,jj,jk) - pW(ji,jj,jk+1) ) & -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/TRA/trabbl.F90
r13295 r13998 197 197 END_2D 198 198 ! 199 DO_2D( 0, 0, 0, 0 ) 199 DO_2D( 0, 0, 0, 0 ) ! Compute the trend 200 200 ik = mbkt(ji,jj) ! bottom T-level index 201 201 pt_rhs(ji,jj,ik,jn) = pt_rhs(ji,jj,ik,jn) & … … 358 358 IF( nn_bbl_ldf == 1 ) THEN ! diffusive bbl ! 359 359 ! !-------------------! 360 DO_2D( 1, 0, 1, 0 ) 360 DO_2D( 1, 0, 1, 0 ) ! (criteria for non zero flux: grad(rho).grad(h) < 0 ) 361 361 ! ! i-direction 362 362 za = zab(ji+1,jj,jp_tem) + zab(ji,jj,jp_tem) ! 2*(alpha,beta) at u-point … … 388 388 ! 389 389 CASE( 1 ) != use of upper velocity 390 DO_2D( 1, 0, 1, 0 ) 390 DO_2D( 1, 0, 1, 0 ) ! criteria: grad(rho).grad(h)<0 and grad(rho).grad(h)<0 391 391 ! ! i-direction 392 392 za = zab(ji+1,jj,jp_tem) + zab(ji,jj,jp_tem) ! 2*(alpha,beta) at u-point … … 417 417 CASE( 2 ) != bbl velocity = F( delta rho ) 418 418 zgbbl = grav * rn_gambbl 419 DO_2D( 1, 0, 1, 0 ) 419 DO_2D( 1, 0, 1, 0 ) ! criteria: rho_up > rho_down 420 420 ! ! i-direction 421 421 ! down-slope T-point i/k-index (deep) & up-slope T-point i/k-index (shelf) … … 505 505 IF( tra_bbl_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'tra_bbl_init : unable to allocate arrays' ) 506 506 ! 507 IF( nn_bbl_adv == 1 ) WRITE(numout,*) ' * Advective BBL using upper velocity' 508 IF( nn_bbl_adv == 2 ) WRITE(numout,*) ' * Advective BBL using velocity = F( delta rho)' 507 IF(lwp) THEN 508 IF( nn_bbl_adv == 1 ) WRITE(numout,*) ' * Advective BBL using upper velocity' 509 IF( nn_bbl_adv == 2 ) WRITE(numout,*) ' * Advective BBL using velocity = F( delta rho)' 510 ENDIF 509 511 ! 510 512 ! !* vertical index of "deep" bottom u- and v-points 511 DO_2D( 1, 0, 1, 0 ) 513 DO_2D( 1, 0, 1, 0 ) ! (the "shelf" bottom k-indices are mbku and mbkv) 512 514 mbku_d(ji,jj) = MAX( mbkt(ji+1,jj ) , mbkt(ji,jj) ) ! >= 1 as mbkt=1 over land 513 515 mbkv_d(ji,jj) = MAX( mbkt(ji ,jj+1) , mbkt(ji,jj) ) … … 530 532 END_2D 531 533 ! 532 DO_2D( 1, 0, 1, 0 ) 534 DO_2D( 1, 0, 1, 0 ) !* bbl thickness at u- (v-) point; minimum of top & bottom e3u_0 (e3v_0) 533 535 e3u_bbl_0(ji,jj) = MIN( e3u_0(ji,jj,mbkt(ji+1,jj )), e3u_0(ji,jj,mbkt(ji,jj)) ) 534 536 e3v_bbl_0(ji,jj) = MIN( e3v_0(ji,jj,mbkt(ji ,jj+1)), e3v_0(ji,jj,mbkt(ji,jj)) ) -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/TRA/traldf_iso.F90
r13295 r13998 205 205 END_3D 206 206 IF( ln_zps ) THEN ! botton and surface ocean correction of the horizontal gradient 207 DO_2D( 1, 0, 1, 0 ) 207 DO_2D( 1, 0, 1, 0 ) ! bottom correction (partial bottom cell) 208 208 zdit(ji,jj,mbku(ji,jj)) = pgu(ji,jj,jn) 209 209 zdjt(ji,jj,mbkv(ji,jj)) = pgv(ji,jj,jn) … … 229 229 ELSE ; zdkt(:,:) = ( pt(:,:,jk-1,jn) - pt(:,:,jk,jn) ) * wmask(:,:,jk) 230 230 ENDIF 231 DO_2D( 1, 0, 1, 0 ) 231 DO_2D( 1, 0, 1, 0 ) !== Horizontal fluxes 232 232 zabe1 = pahu(ji,jj,jk) * e2_e1u(ji,jj) * e3u(ji,jj,jk,Kmm) 233 233 zabe2 = pahv(ji,jj,jk) * e1_e2v(ji,jj) * e3v(ji,jj,jk,Kmm) … … 250 250 END_2D 251 251 ! 252 DO_2D( 0, 0, 0, 0 ) 252 DO_2D( 0, 0, 0, 0 ) !== horizontal divergence and add to pta 253 253 pt_rhs(ji,jj,jk,jn) = pt_rhs(ji,jj,jk,jn) & 254 254 & + zsign * ( zftu(ji,jj,jk) - zftu(ji-1,jj,jk) + zftv(ji,jj,jk) - zftv(ji,jj-1,jk) ) & … … 266 266 ztfw(:,:, 1 ) = 0._wp ; ztfw(:,:,jpk) = 0._wp 267 267 268 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) 268 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) ! interior (2=<jk=<jpk-1) 269 269 ! 270 270 zmsku = wmask(ji,jj,jk) / MAX( umask(ji ,jj,jk-1) + umask(ji-1,jj,jk) & … … 311 311 ENDIF 312 312 ! 313 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 313 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) !== Divergence of vertical fluxes added to pta ==! 314 314 pt_rhs(ji,jj,jk,jn) = pt_rhs(ji,jj,jk,jn) + zsign * ( ztfw (ji,jj,jk) - ztfw(ji,jj,jk+1) ) * r1_e1e2t(ji,jj) & 315 315 & / e3t(ji,jj,jk,Kmm) -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/TRA/traldf_lap_blp.F90
r13295 r13998 108 108 ! ! =========== ! 109 109 ! 110 DO_3D( 1, 0, 1, 0, 1, jpkm1 ) 110 DO_3D( 1, 0, 1, 0, 1, jpkm1 ) !== First derivative (gradient) ==! 111 111 ztu(ji,jj,jk) = zaheeu(ji,jj,jk) * ( pt(ji+1,jj ,jk,jn) - pt(ji,jj,jk,jn) ) 112 112 ztv(ji,jj,jk) = zaheev(ji,jj,jk) * ( pt(ji ,jj+1,jk,jn) - pt(ji,jj,jk,jn) ) 113 113 END_3D 114 IF( ln_zps ) THEN ! set gradient at bottom/top ocean level115 DO_2D( 1, 0, 1, 0 ) 114 IF( ln_zps ) THEN ! set gradient at bottom/top ocean level 115 DO_2D( 1, 0, 1, 0 ) ! bottom 116 116 ztu(ji,jj,mbku(ji,jj)) = zaheeu(ji,jj,mbku(ji,jj)) * pgu(ji,jj,jn) 117 117 ztv(ji,jj,mbkv(ji,jj)) = zaheev(ji,jj,mbkv(ji,jj)) * pgv(ji,jj,jn) 118 118 END_2D 119 IF( ln_isfcav ) THEN ! top in ocean cavities only119 IF( ln_isfcav ) THEN ! top in ocean cavities only 120 120 DO_2D( 1, 0, 1, 0 ) 121 121 IF( miku(ji,jj) > 1 ) ztu(ji,jj,miku(ji,jj)) = zaheeu(ji,jj,miku(ji,jj)) * pgui(ji,jj,jn) … … 125 125 ENDIF 126 126 ! 127 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 127 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) !== Second derivative (divergence) added to the general tracer trends ==! 128 128 pt_rhs(ji,jj,jk,jn) = pt_rhs(ji,jj,jk,jn) + ( ztu(ji,jj,jk) - ztu(ji-1,jj,jk) & 129 129 & + ztv(ji,jj,jk) - ztv(ji,jj-1,jk) ) & -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/TRA/traldf_triad.F90
r13295 r13998 211 211 zftv(:,:,:) = 0._wp 212 212 ! 213 DO_3D( 1, 0, 1, 0, 1, jpkm1 ) 213 DO_3D( 1, 0, 1, 0, 1, jpkm1 ) !== before lateral T & S gradients at T-level jk ==! 214 214 zdit(ji,jj,jk) = ( pt(ji+1,jj ,jk,jn) - pt(ji,jj,jk,jn) ) * umask(ji,jj,jk) 215 215 zdjt(ji,jj,jk) = ( pt(ji ,jj+1,jk,jn) - pt(ji,jj,jk,jn) ) * vmask(ji,jj,jk) 216 216 END_3D 217 217 IF( ln_zps .AND. l_grad_zps ) THEN ! partial steps: correction at top/bottom ocean level 218 DO_2D( 1, 0, 1, 0 ) 218 DO_2D( 1, 0, 1, 0 ) ! bottom level 219 219 zdit(ji,jj,mbku(ji,jj)) = pgu(ji,jj,jn) 220 220 zdjt(ji,jj,mbkv(ji,jj)) = pgv(ji,jj,jn) … … 361 361 ENDIF 362 362 ! 363 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 363 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) !== Divergence of vertical fluxes added to pta ==! 364 364 pt_rhs(ji,jj,jk,jn) = pt_rhs(ji,jj,jk,jn) & 365 365 & + zsign * ( ztfw(ji,jj,jk+1) - ztfw(ji,jj,jk) ) & -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/TRA/tramle.F90
r13295 r13998 100 100 inml_mle(:,:) = mbkt(:,:) + 1 ! init. to number of ocean w-level (T-level + 1) 101 101 IF ( nla10 > 0 ) THEN ! avoid case where first level is thicker than 10m 102 DO_3DS( 1, 1, 1, 1, jpkm1, nlb10, -1 ) 102 DO_3DS( 1, 1, 1, 1, jpkm1, nlb10, -1 ) ! from the bottom to nlb10 (10m) 103 103 IF( rhop(ji,jj,jk) > rhop(ji,jj,nla10) + rn_rho_c_mle ) inml_mle(ji,jj) = jk ! Mixed layer 104 104 END_3D … … 110 110 zbm (:,:) = 0._wp 111 111 zn2 (:,:) = 0._wp 112 DO_3D( 1, 1, 1, 1, 1, ikmax ) 112 DO_3D( 1, 1, 1, 1, 1, ikmax ) ! MLD and mean buoyancy and N2 over the mixed layer 113 113 zc = e3t(ji,jj,jk,Kmm) * REAL( MIN( MAX( 0, inml_mle(ji,jj)-jk ) , 1 ) ) ! zc being 0 outside the ML t-points 114 114 zmld(ji,jj) = zmld(ji,jj) + zc … … 182 182 zpsi_vw(:,:,:) = 0._wp 183 183 ! 184 DO_3D( 1, 0, 1, 0, 2, ikmax ) 184 DO_3D( 1, 0, 1, 0, 2, ikmax ) ! start from 2 : surface value = 0 185 185 zcuw = 1._wp - ( gdepw(ji+1,jj,jk,Kmm) + gdepw(ji,jj,jk,Kmm) ) * zhu(ji,jj) 186 186 zcvw = 1._wp - ( gdepw(ji,jj+1,jk,Kmm) + gdepw(ji,jj,jk,Kmm) ) * zhv(ji,jj) … … 196 196 ! !== transport increased by the MLE induced transport ==! 197 197 DO jk = 1, ikmax 198 DO_2D( 1, 0, 1, 0 ) 198 DO_2D( 1, 0, 1, 0 ) ! CAUTION pu,pv must be defined at row/column i=1 / j=1 199 199 pu(ji,jj,jk) = pu(ji,jj,jk) + ( zpsi_uw(ji,jj,jk) - zpsi_uw(ji,jj,jk+1) ) 200 200 pv(ji,jj,jk) = pv(ji,jj,jk) + ( zpsi_vw(ji,jj,jk) - zpsi_vw(ji,jj,jk+1) ) … … 283 283 IF( ierr /= 0 ) CALL ctl_stop( 'tra_adv_mle_init: failed to allocate arrays' ) 284 284 z1_t2 = 1._wp / ( rn_time * rn_time ) 285 DO_2D( 0, 1, 0, 1 ) 285 DO_2D( 0, 1, 0, 1 ) ! "coriolis+ time^-1" at u- & v-points 286 286 zfu = ( ff_f(ji,jj) + ff_f(ji,jj-1) ) * 0.5_wp 287 287 zfv = ( ff_f(ji,jj) + ff_f(ji-1,jj) ) * 0.5_wp -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/TRA/tranpc.F90
r13295 r13998 103 103 inpcc = 0 104 104 ! 105 DO_2D( 0, 0, 0, 0 ) 105 DO_2D( 0, 0, 0, 0 ) ! interior column only 106 106 ! 107 107 IF( tmask(ji,jj,2) == 1 ) THEN ! At least 2 ocean points -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/TRA/traqsr.F90
r13895 r13998 63 63 REAL(wp) :: xsi1r ! inverse of rn_si1 64 64 ! 65 REAL(wp) , DIMENSION(3,61):: rkrgb ! tabulated attenuation coefficients for RGB absorption65 REAL(wp) , PUBLIC, DIMENSION(3,61) :: rkrgb ! tabulated attenuation coefficients for RGB absorption 66 66 TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_chl ! structure of input Chl (file informations, fields read) 67 67 … … 231 231 END_2D 232 232 ! 233 ! * interior equi-partition in R-G-B depending on vertical profile of Chl233 ! !* interior equi-partition in R-G-B depending on vertical profile of Chl 234 234 DO_3D( 0, 0, 0, 0, 2, nksr + 1 ) 235 235 ze3t = e3t(ji,jj,jk-1,Kmm) … … 246 246 END_3D 247 247 ! 248 DO_3D( 0, 0, 0, 0, 1, nksr ) 248 DO_3D( 0, 0, 0, 0, 1, nksr ) !* now qsr induced heat content 249 249 qsr_hc(ji,jj,jk) = r1_rho0_rcp * ( ztmp3d(ji,jj,jk) - ztmp3d(ji,jj,jk+1) ) 250 250 END_3D … … 256 256 zz0 = rn_abs * r1_rho0_rcp ! surface equi-partition in 2-bands 257 257 zz1 = ( 1. - rn_abs ) * r1_rho0_rcp 258 DO_3D( 0, 0, 0, 0, 1, nksr ) 258 DO_3D( 0, 0, 0, 0, 1, nksr ) ! solar heat absorbed at T-point in the top 400m 259 259 zc0 = zz0 * EXP( -gdepw(ji,jj,jk ,Kmm)*xsi0r ) + zz1 * EXP( -gdepw(ji,jj,jk ,Kmm)*xsi1r ) 260 260 zc1 = zz0 * EXP( -gdepw(ji,jj,jk+1,Kmm)*xsi0r ) + zz1 * EXP( -gdepw(ji,jj,jk+1,Kmm)*xsi1r ) … … 264 264 END SELECT 265 265 ! 266 ! !-----------------------------! 267 ! ! update to the temp. trend ! 266 268 ! !-----------------------------! 267 269 DO_3D( 0, 0, 0, 0, 1, nksr ) … … 417 419 IF( .NOT.lk_top ) CALL ctl_stop( 'No bio model : ln_qsr_bio = true impossible ' ) 418 420 ! 421 CALL trc_oce_rgb( rkrgb ) ! tabulated attenuation coef. 422 ! 423 nksr = trc_oce_ext_lev( r_si2, 33._wp ) ! level of light extinction 424 ! 425 IF(lwp) WRITE(numout,*) ' level of light extinction = ', nksr, ' ref depth = ', gdepw_1d(nksr+1), ' m' 426 ! 419 427 END SELECT 420 428 ! -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/TRA/trasbc.F90
r13895 r13998 128 128 END_2D 129 129 IF( ln_linssh ) THEN !* linear free surface 130 DO_2D( 0, 0, 0, 0 )130 DO_2D( 0, 1, 0, 0 ) !==>> add concentration/dilution effect due to constant volume cell 131 131 sbc_tsc(ji,jj,jp_tem) = sbc_tsc(ji,jj,jp_tem) + r1_rho0 * emp(ji,jj) * pts(ji,jj,1,jp_tem,Kmm) 132 132 sbc_tsc(ji,jj,jp_sal) = sbc_tsc(ji,jj,jp_sal) + r1_rho0 * emp(ji,jj) * pts(ji,jj,1,jp_sal,Kmm) 133 END_2D 133 END_2D !==>> output c./d. term 134 134 IF( iom_use('emp_x_sst') ) CALL iom_put( "emp_x_sst", emp (:,:) * pts(:,:,1,jp_tem,Kmm) ) 135 135 IF( iom_use('emp_x_sss') ) CALL iom_put( "emp_x_sss", emp (:,:) * pts(:,:,1,jp_sal,Kmm) ) -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/TRA/trazdf.F90
r13295 r13998 208 208 ! used as a work space array: its value is modified. 209 209 ! 210 DO_2D( 0, 0, 0, 0 ) 210 DO_2D( 0, 0, 0, 0 ) !* 1st recurrence: Tk = Dk - Ik Sk-1 / Tk-1 (increasing k) ! done one for all passive tracers (so included in the IF instruction) 211 211 zwt(ji,jj,1) = zwd(ji,jj,1) 212 212 END_2D … … 217 217 ENDIF 218 218 ! 219 DO_2D( 0, 0, 0, 0 ) 219 DO_2D( 0, 0, 0, 0 ) !* 2nd recurrence: Zk = Yk - Ik / Tk-1 Zk-1 220 220 pt(ji,jj,1,jn,Kaa) = e3t(ji,jj,1,Kbb) * pt(ji,jj,1,jn,Kbb) & 221 221 & + p2dt * e3t(ji,jj,1,Kmm) * pt(ji,jj,1,jn,Krhs) … … 227 227 END_3D 228 228 ! 229 DO_2D( 0, 0, 0, 0 ) 229 DO_2D( 0, 0, 0, 0 ) !* 3d recurrence: Xk = (Zk - Sk Xk+1 ) / Tk (result is the after tracer) 230 230 pt(ji,jj,jpkm1,jn,Kaa) = pt(ji,jj,jpkm1,jn,Kaa) / zwt(ji,jj,jpkm1) * tmask(ji,jj,jpkm1) 231 231 END_2D -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/TRA/zpshde.F90
r13295 r13998 167 167 CALL eos( ztj, zhj, zrj ) ! at the partial step depth output in zri, zrj 168 168 ! 169 DO_2D( 1, 0, 1, 0 ) 169 DO_2D( 1, 0, 1, 0 ) ! Gradient of density at the last level 170 170 iku = mbku(ji,jj) 171 171 ikv = mbkv(ji,jj) … … 329 329 CALL eos( ztj, zhj, zrj ) 330 330 331 DO_2D( 1, 0, 1, 0 ) 331 DO_2D( 1, 0, 1, 0 ) ! Gradient of density at the last level 332 332 iku = mbku(ji,jj) 333 333 ikv = mbkv(ji,jj) … … 420 420 CALL eos( ztj, zhj, zrj ) ! at the partial step depth output in zri, zrj 421 421 ! 422 DO_2D( 1, 0, 1, 0 ) 422 DO_2D( 1, 0, 1, 0 ) ! Gradient of density at the last level 423 423 iku = miku(ji,jj) 424 424 ikv = mikv(ji,jj) -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/TRD/trddyn.F90
r13295 r13998 124 124 z3dx(:,:,:) = 0._wp ! U.dxU & V.dyV (approximation) 125 125 z3dy(:,:,:) = 0._wp 126 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 126 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) ! no mask as un,vn are masked 127 127 z3dx(ji,jj,jk) = uu(ji,jj,jk,Kmm) * ( uu(ji+1,jj,jk,Kmm) - uu(ji-1,jj,jk,Kmm) ) / ( 2._wp * e1u(ji,jj) ) 128 128 z3dy(ji,jj,jk) = vv(ji,jj,jk,Kmm) * ( vv(ji,jj+1,jk,Kmm) - vv(ji,jj-1,jk,Kmm) ) / ( 2._wp * e2v(ji,jj) ) -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/TRD/trdglo.F90
r13295 r13998 86 86 ! 87 87 CASE( 'TRA' ) !== Tracers (T & S) ==! 88 DO_3D( 1, 1, 1, 1, 1, jpkm1 ) 88 DO_3D( 1, 1, 1, 1, 1, jpkm1 ) ! global sum of mask volume trend and trend*T (including interior mask) 89 89 zvm = e1e2t(ji,jj) * e3t(ji,jj,jk,Kmm) * tmask(ji,jj,jk) * tmask_i(ji,jj) 90 90 zvt = ptrdx(ji,jj,jk) * zvm … … 218 218 END_3D 219 219 220 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 220 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) ! Density flux divergence at t-point 221 221 zkepe(ji,jj,jk) = - ( zkz(ji,jj,jk) - zkz(ji ,jj ,jk+1) & 222 222 & + zkx(ji,jj,jk) - zkx(ji-1,jj ,jk ) & -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/TRD/trdmxl.F90
r13295 r13998 120 120 ! 121 121 wkx(:,:,:) = 0._wp !== now ML weights for vertical averaging ==! 122 DO_3D( 1, 1, 1, 1, 1, jpktrd ) 122 DO_3D( 1, 1, 1, 1, 1, jpktrd ) ! initialize wkx with vertical scale factor in mixed-layer 123 123 IF( jk - kmxln(ji,jj) < 0 ) THEN 124 124 wkx(ji,jj,jk) = e3t(ji,jj,jk,Kmm) * tmask(ji,jj,jk) -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/TRD/trdtra.F90
r13295 r13998 210 210 !!---------------------------------------------------------------------- 211 211 ! 212 SELECT CASE( cdir ) ! shift depending on the direction212 SELECT CASE( cdir ) ! shift depending on the direction 213 213 CASE( 'X' ) ; ii = 1 ; ij = 0 ; ik = 0 ! i-trend 214 214 CASE( 'Y' ) ; ii = 0 ; ij = 1 ; ik = 0 ! j-trend … … 216 216 END SELECT 217 217 ! 218 ! ! set to zero uncomputed values218 ! ! set to zero uncomputed values 219 219 ptrd(jpi,:,:) = 0._wp ; ptrd(1,:,:) = 0._wp 220 220 ptrd(:,jpj,:) = 0._wp ; ptrd(:,1,:) = 0._wp 221 221 ptrd(:,:,jpk) = 0._wp 222 222 ! 223 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 223 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) ! advective trend 224 224 ptrd(ji,jj,jk) = - ( pf (ji,jj,jk) - pf (ji-ii,jj-ij,jk-ik) & 225 225 & - ( pu(ji,jj,jk) - pu(ji-ii,jj-ij,jk-ik) ) * pt(ji,jj,jk) ) & -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/TRD/trdvor.F90
r13295 r13998 103 103 CASE( jpdyn_zad ) ; CALL trd_vor_zint( putrd, pvtrd, jpvor_zad, Kmm ) ! Vertical Advection 104 104 CASE( jpdyn_spg ) ; CALL trd_vor_zint( putrd, pvtrd, jpvor_spg, Kmm ) ! Surface Pressure Grad. 105 CASE( jpdyn_zdf ) ! Vertical Diffusion105 CASE( jpdyn_zdf ) ! Vertical Diffusion 106 106 ztswu(:,:) = 0.e0 ; ztswv(:,:) = 0.e0 107 DO_2D( 0, 0, 0, 0 ) 107 DO_2D( 0, 0, 0, 0 ) ! wind stress trends 108 108 ztswu(ji,jj) = 0.5 * ( utau_b(ji,jj) + utau(ji,jj) ) / ( e3u(ji,jj,1,Kmm) * rho0 ) 109 109 ztswv(ji,jj) = 0.5 * ( vtau_b(ji,jj) + vtau(ji,jj) ) / ( e3v(ji,jj,1,Kmm) * rho0 ) -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/USR/usrdef_fmask.F90
r13286 r13998 58 58 !!---------------------------------------------------------------------- 59 59 ! 60 IF( TRIM( cd_cfg ) == "orca" ) THEN !== ORCA Configurations ==!60 IF( TRIM( cd_cfg ) == "orca" .OR. TRIM( cd_cfg ) == "ORCA" ) THEN !== ORCA Configurations ==! 61 61 ! 62 62 SELECT CASE ( kcfg ) -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/USR/usrdef_istate.F90
r13874 r13998 58 58 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~~ Ocean at rest, with an horizontally uniform T and S profiles' 59 59 ! 60 pu (:,:,:) = 0._wp ! ocean at rest60 pu (:,:,:) = 0._wp ! ocean at rest 61 61 pv (:,:,:) = 0._wp 62 62 ! 63 DO_3D( 1, 1, 1, 1, 1, jpk ) 63 DO_3D( 1, 1, 1, 1, 1, jpk ) ! horizontally uniform T & S profiles 64 64 pts(ji,jj,jk,jp_tem) = ( ( 16. - 12. * TANH( (pdept(ji,jj,jk) - 400) / 700 ) ) & 65 65 & * (-TANH( (500. - pdept(ji,jj,jk)) / 150. ) + 1.) / 2. & -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/ZDF/zdfddm.F90
r13427 r13998 95 95 !!gm and many acces in memory 96 96 97 DO_2D( 1, 1, 1, 1 ) 97 DO_2D( 1, 1, 1, 1 ) !== R=zrau = (alpha / beta) (dk[t] / dk[s]) ==! 98 98 zrw = ( gdepw(ji,jj,jk ,Kmm) - gdept(ji,jj,jk,Kmm) ) & 99 99 !!gm please, use e3w at Kmm below … … 111 111 END_2D 112 112 113 DO_2D( 1, 1, 1, 1 ) 113 DO_2D( 1, 1, 1, 1 ) !== indicators ==! 114 114 ! stability indicator: msks=1 if rn2>0; 0 elsewhere 115 115 IF( rn2(ji,jj,jk) + 1.e-12 <= 0. ) THEN ; zmsks(ji,jj) = 0._wp -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/ZDF/zdfdrg.F90
r13295 r13998 32 32 USE lib_mpp ! distributed memory computing 33 33 USE prtctl ! Print control 34 USE sbc_oce , ONLY : nn_ice 34 35 35 36 IMPLICIT NONE … … 41 42 42 43 ! !!* Namelist namdrg: nature of drag coefficient namelist * 43 LOGICAL :: ln_OFF! free-slip : Cd = 044 LOGICAL , PUBLIC :: ln_drg_OFF ! free-slip : Cd = 0 44 45 LOGICAL :: ln_lin ! linear drag: Cd = Cd0_lin 45 46 LOGICAL :: ln_non_lin ! non-linear drag: Cd = Cd0_nl |U| 46 47 LOGICAL :: ln_loglayer ! logarithmic drag: Cd = vkarmn/log(z/z0) 47 48 LOGICAL , PUBLIC :: ln_drgimp ! implicit top/bottom friction flag 48 49 LOGICAL , PUBLIC :: ln_drgice_imp ! implicit ice-ocean drag 49 50 ! !!* Namelist namdrg_top & _bot: TOP or BOTTOM coefficient namelist * 50 51 REAL(wp) :: rn_Cd0 !: drag coefficient [ - ] … … 226 227 INTEGER :: ios, ioptio ! local integers 227 228 !! 228 NAMELIST/namdrg/ ln_ OFF, ln_lin, ln_non_lin, ln_loglayer, ln_drgimp229 NAMELIST/namdrg/ ln_drg_OFF, ln_lin, ln_non_lin, ln_loglayer, ln_drgimp, ln_drgice_imp 229 230 !!---------------------------------------------------------------------- 230 231 ! … … 237 238 IF(lwm) WRITE ( numond, namdrg ) 238 239 ! 240 IF ( ln_drgice_imp .AND. nn_ice /= 2 ) ln_drgice_imp = .FALSE. 241 ! 239 242 IF(lwp) THEN 240 243 WRITE(numout,*) … … 242 245 WRITE(numout,*) '~~~~~~~~~~~~' 243 246 WRITE(numout,*) ' Namelist namdrg : top/bottom friction choices' 244 WRITE(numout,*) ' free-slip : Cd = 0 ln_ OFF = ', ln_OFF247 WRITE(numout,*) ' free-slip : Cd = 0 ln_drg_OFF = ', ln_drg_OFF 245 248 WRITE(numout,*) ' linear drag : Cd = Cd0 ln_lin = ', ln_lin 246 249 WRITE(numout,*) ' non-linear drag: Cd = Cd0_nl |U| ln_non_lin = ', ln_non_lin 247 250 WRITE(numout,*) ' logarithmic drag: Cd = vkarmn/log(z/z0) ln_loglayer = ', ln_loglayer 248 251 WRITE(numout,*) ' implicit friction ln_drgimp = ', ln_drgimp 252 WRITE(numout,*) ' implicit ice-ocean drag ln_drgice_imp =', ln_drgice_imp 249 253 ENDIF 250 254 ! 251 255 ioptio = 0 ! set ndrg and control check 252 IF( ln_ OFF) THEN ; ndrg = np_OFF ; ioptio = ioptio + 1 ; ENDIF256 IF( ln_drg_OFF ) THEN ; ndrg = np_OFF ; ioptio = ioptio + 1 ; ENDIF 253 257 IF( ln_lin ) THEN ; ndrg = np_lin ; ioptio = ioptio + 1 ; ENDIF 254 258 IF( ln_non_lin ) THEN ; ndrg = np_non_lin ; ioptio = ioptio + 1 ; ENDIF … … 257 261 IF( ioptio /= 1 ) CALL ctl_stop( 'zdf_drg_init: Choose ONE type of drag coef in namdrg' ) 258 262 ! 263 IF ( ln_drgice_imp.AND.(.NOT.ln_drgimp) ) & 264 & CALL ctl_stop( 'zdf_drg_init: ln_drgice_imp=T requires ln_drgimp=T' ) 259 265 ! 260 266 ! !== BOTTOM drag setting ==! (applied at seafloor) … … 263 269 CALL drg_init( 'BOTTOM' , mbkt , & ! <== in 264 270 & r_Cdmin_bot, r_Cdmax_bot, r_z0_bot, r_ke0_bot, rCd0_bot, rCdU_bot ) ! ==> out 265 266 271 ! 267 272 ! !== TOP drag setting ==! (applied at the top of ocean cavities) 268 273 ! 269 IF( ln_isfcav ) THEN ! Ocean cavities: top friction setting 270 ALLOCATE( rCd0_top(jpi,jpj), rCdU_top(jpi,jpj) ) 274 IF( ln_isfcav.OR.ln_drgice_imp ) THEN ! Ocean cavities: top friction setting 275 ALLOCATE( rCdU_top(jpi,jpj) ) 276 ENDIF 277 ! 278 IF( ln_isfcav ) THEN 279 ALLOCATE( rCd0_top(jpi,jpj)) 271 280 CALL drg_init( 'TOP ' , mikt , & ! <== in 272 281 & r_Cdmin_top, r_Cdmax_top, r_z0_top, r_ke0_top, rCd0_top, rCdU_top ) ! ==> out … … 374 383 IF(ll_bot) zmsk_boost(:,:) = zmsk_boost(:,:) * ssmask(:,:) ! x seafloor mask 375 384 ! 385 l_log_not_linssh = .FALSE. ! default definition 376 386 ! 377 387 SELECT CASE( ndrg ) … … 422 432 l_log_not_linssh = .FALSE. !- don't update Cd at each time step 423 433 ! 424 DO_2D( 1, 1, 1, 1 ) 434 DO_2D( 1, 1, 1, 1 ) ! pCd0 = mask (and boosted) logarithmic drag coef. 425 435 zzz = 0.5_wp * e3t_0(ji,jj,k_mk(ji,jj)) 426 436 zcd = ( vkarmn / LOG( zzz / rn_z0 ) )**2 -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/ZDF/zdfgls.F90
r13295 r13998 19 19 USE dom_oce ! ocean space and time domain 20 20 USE domvvl ! ocean space and time domain : variable volume layer 21 USE zdfdrg , ONLY : ln_drg_OFF ! top/bottom free-slip flag 21 22 USE zdfdrg , ONLY : r_z0_top , r_z0_bot ! top/bottom roughness 22 23 USE zdfdrg , ONLY : rCdU_top , rCdU_bot ! top/bottom friction … … 53 54 INTEGER :: nn_bc_bot ! bottom boundary condition (=0/1) 54 55 INTEGER :: nn_z0_met ! Method for surface roughness computation 56 INTEGER :: nn_z0_ice ! Roughness accounting for sea ice 55 57 INTEGER :: nn_stab_func ! stability functions G88, KC or Canuto (=0/1/2) 56 58 INTEGER :: nn_clos ! closure 0/1/2/3 MY82/k-eps/k-w/gen … … 61 63 REAL(wp) :: rn_crban ! Craig and Banner constant for surface breaking waves mixing 62 64 REAL(wp) :: rn_hsro ! Minimum surface roughness 65 REAL(wp) :: rn_hsri ! Ice ocean roughness 63 66 REAL(wp) :: rn_frac_hs ! Fraction of wave height as surface roughness (if nn_z0_met > 1) 64 67 … … 152 155 REAL(wp), DIMENSION(jpi,jpj) :: zflxs ! Turbulence fluxed induced by internal waves 153 156 REAL(wp), DIMENSION(jpi,jpj) :: zhsro ! Surface roughness (surface waves) 157 REAL(wp), DIMENSION(jpi,jpj) :: zice_fra ! Tapering of wave breaking under sea ice 154 158 REAL(wp), DIMENSION(jpi,jpj,jpk) :: eb ! tke at time before 155 159 REAL(wp), DIMENSION(jpi,jpj,jpk) :: hmxl_b ! mixing length at time before … … 167 171 ustar2_bot (:,:) = 0._wp 168 172 173 SELECT CASE ( nn_z0_ice ) 174 CASE( 0 ) ; zice_fra(:,:) = 0._wp 175 CASE( 1 ) ; zice_fra(:,:) = TANH( fr_i(:,:) * 10._wp ) 176 CASE( 2 ) ; zice_fra(:,:) = fr_i(:,:) 177 CASE( 3 ) ; zice_fra(:,:) = MIN( 4._wp * fr_i(:,:) , 1._wp ) 178 END SELECT 179 169 180 ! Compute surface, top and bottom friction at T-points 170 DO_2D( 0, 0, 0, 0 ) 171 ! 172 ! surface friction 173 ustar2_surf(ji,jj) = r1_rho0 * taum(ji,jj) * tmask(ji,jj,1) 174 ! 175 !!gm Rq we may add here r_ke0(_top/_bot) ? ==>> think about that... 176 ! bottom friction (explicit before friction) 177 zmsku = ( 2._wp - umask(ji-1,jj,mbkt(ji,jj)) * umask(ji,jj,mbkt(ji,jj)) ) 178 zmskv = ( 2._wp - vmask(ji,jj-1,mbkt(ji,jj)) * vmask(ji,jj,mbkt(ji,jj)) ) ! (CAUTION: CdU<0) 179 ustar2_bot(ji,jj) = - rCdU_bot(ji,jj) * SQRT( ( zmsku*( uu(ji,jj,mbkt(ji,jj),Kbb)+uu(ji-1,jj,mbkt(ji,jj),Kbb) ) )**2 & 180 & + ( zmskv*( vv(ji,jj,mbkt(ji,jj),Kbb)+vv(ji,jj-1,mbkt(ji,jj),Kbb) ) )**2 ) 181 DO_2D( 0, 0, 0, 0 ) !== surface ocean friction 182 ustar2_surf(ji,jj) = r1_rho0 * taum(ji,jj) * tmask(ji,jj,1) ! surface friction 181 183 END_2D 182 IF( ln_isfcav ) THEN !top friction 183 DO_2D( 0, 0, 0, 0 ) 184 zmsku = ( 2. - umask(ji-1,jj,mikt(ji,jj)) * umask(ji,jj,mikt(ji,jj)) ) 185 zmskv = ( 2. - vmask(ji,jj-1,mikt(ji,jj)) * vmask(ji,jj,mikt(ji,jj)) ) ! (CAUTION: CdU<0) 186 ustar2_top(ji,jj) = - rCdU_top(ji,jj) * SQRT( ( zmsku*( uu(ji,jj,mikt(ji,jj),Kbb)+uu(ji-1,jj,mikt(ji,jj),Kbb) ) )**2 & 187 & + ( zmskv*( vv(ji,jj,mikt(ji,jj),Kbb)+vv(ji,jj-1,mikt(ji,jj),Kbb) ) )**2 ) 184 ! 185 !!gm Rq we may add here r_ke0(_top/_bot) ? ==>> think about that... 186 ! 187 IF( .NOT.ln_drg_OFF ) THEN !== top/bottom friction (explicit before friction) 188 DO_2D( 0, 0, 0, 0 ) ! bottom friction (explicit before friction) 189 zmsku = ( 2._wp - umask(ji-1,jj,mbkt(ji,jj)) * umask(ji,jj,mbkt(ji,jj)) ) 190 zmskv = ( 2._wp - vmask(ji,jj-1,mbkt(ji,jj)) * vmask(ji,jj,mbkt(ji,jj)) ) ! (CAUTION: CdU<0) 191 ustar2_bot(ji,jj) = - rCdU_bot(ji,jj) * SQRT( ( zmsku*( uu(ji,jj,mbkt(ji,jj),Kbb)+uu(ji-1,jj,mbkt(ji,jj),Kbb) ) )**2 & 192 & + ( zmskv*( vv(ji,jj,mbkt(ji,jj),Kbb)+vv(ji,jj-1,mbkt(ji,jj),Kbb) ) )**2 ) 188 193 END_2D 194 IF( ln_isfcav ) THEN 195 DO_2D( 0, 0, 0, 0 ) ! top friction 196 zmsku = ( 2. - umask(ji-1,jj,mikt(ji,jj)) * umask(ji,jj,mikt(ji,jj)) ) 197 zmskv = ( 2. - vmask(ji,jj-1,mikt(ji,jj)) * vmask(ji,jj,mikt(ji,jj)) ) ! (CAUTION: CdU<0) 198 ustar2_top(ji,jj) = - rCdU_top(ji,jj) * SQRT( ( zmsku*( uu(ji,jj,mikt(ji,jj),Kbb)+uu(ji-1,jj,mikt(ji,jj),Kbb) ) )**2 & 199 & + ( zmskv*( vv(ji,jj,mikt(ji,jj),Kbb)+vv(ji,jj-1,mikt(ji,jj),Kbb) ) )**2 ) 200 END_2D 201 ENDIF 189 202 ENDIF 190 203 … … 204 217 END SELECT 205 218 ! 206 DO_3D( 1, 0, 1, 0, 2, jpkm1 ) 219 ! adapt roughness where there is sea ice 220 zhsro(:,:) = ( (1._wp-zice_fra(:,:)) * zhsro(:,:) + zice_fra(:,:) * rn_hsri )*tmask(:,:,1) + (1._wp - tmask(:,:,1))*rn_hsro 221 ! 222 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) !== Compute dissipation rate ==! 207 223 eps(ji,jj,jk) = rc03 * en(ji,jj,jk) * SQRT( en(ji,jj,jk) ) / hmxl_n(ji,jj,jk) 208 224 END_3D … … 288 304 CASE ( 0 ) ! Dirichlet boundary condition (set e at k=1 & 2) 289 305 ! First level 290 en (:,:,1) = MAX( rn_emin , rc02r * ustar2_surf(:,:) * (1._wp + rsbc_tke1)**r2_3 )306 en (:,:,1) = MAX( rn_emin , rc02r * ustar2_surf(:,:) * (1._wp + (1._wp-zice_fra(:,:))*rsbc_tke1)**r2_3 ) 291 307 zd_lw(:,:,1) = en(:,:,1) 292 308 zd_up(:,:,1) = 0._wp … … 294 310 ! 295 311 ! One level below 296 en (:,:,2) = MAX( rc02r * ustar2_surf(:,:) * ( 1._wp + rsbc_tke1 * ((zhsro(:,:)+gdepw(:,:,2,Kmm))&297 & / zhsro(:,:) )**(1.5_wp*ra_sf) )**(2._wp/3._wp) 312 en (:,:,2) = MAX( rc02r * ustar2_surf(:,:) * ( 1._wp + (1._wp-zice_fra(:,:))*rsbc_tke1 * ((zhsro(:,:)+gdepw(:,:,2,Kmm)) & 313 & / zhsro(:,:) )**(1.5_wp*ra_sf) )**(2._wp/3._wp) , rn_emin ) 298 314 zd_lw(:,:,2) = 0._wp 299 315 zd_up(:,:,2) = 0._wp … … 304 320 ! 305 321 ! Dirichlet conditions at k=1 306 en (:,:,1) = MAX( rc02r * ustar2_surf(:,:) * (1._wp + rsbc_tke1)**r2_3 , rn_emin )322 en (:,:,1) = MAX( rc02r * ustar2_surf(:,:) * (1._wp + (1._wp-zice_fra(:,:))*rsbc_tke1)**r2_3 , rn_emin ) 307 323 zd_lw(:,:,1) = en(:,:,1) 308 324 zd_up(:,:,1) = 0._wp … … 311 327 ! at k=2, set de/dz=Fw 312 328 !cbr 313 zdiag(:,:,2) = zdiag(:,:,2) + zd_lw(:,:,2) ! Remove zd_lw from zdiag 314 zd_lw(:,:,2) = 0._wp 329 DO_2D( 0, 0, 0, 0 ) ! zdiag zd_lw not defined/used on the halo 330 zdiag(ji,jj,2) = zdiag(ji,jj,2) + zd_lw(ji,jj,2) ! Remove zd_lw from zdiag 331 zd_lw(ji,jj,2) = 0._wp 332 END_2D 315 333 zkar (:,:) = (rl_sf + (vkarmn-rl_sf)*(1.-EXP(-rtrans*gdept(:,:,1,Kmm)/zhsro(:,:)) )) 316 zflxs(:,:) = rsbc_tke2 * ustar2_surf(:,:)**1.5_wp * zkar(:,:) &334 zflxs(:,:) = rsbc_tke2 * (1._wp-zice_fra(:,:)) * ustar2_surf(:,:)**1.5_wp * zkar(:,:) & 317 335 & * ( ( zhsro(:,:)+gdept(:,:,1,Kmm) ) / zhsro(:,:) )**(1.5_wp*ra_sf) 318 336 !!gm why not : * ( 1._wp + gdept(:,:,1,Kmm) / zhsro(:,:) )**(1.5_wp*ra_sf) … … 400 418 ! ---------------------------------------------------------- 401 419 ! 402 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) 420 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) ! First recurrence : Dk = Dk - Lk * Uk-1 / Dk-1 403 421 zdiag(ji,jj,jk) = zdiag(ji,jj,jk) - zd_lw(ji,jj,jk) * zd_up(ji,jj,jk-1) / zdiag(ji,jj,jk-1) 404 422 END_3D 405 DO_3D( 0, 0, 0, 0, 2, jpk )423 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) ! Second recurrence : Lk = RHSk - Lk / Dk-1 * Lk-1 406 424 zd_lw(ji,jj,jk) = en(ji,jj,jk) - zd_lw(ji,jj,jk) / zdiag(ji,jj,jk-1) * zd_lw(ji,jj,jk-1) 407 425 END_3D 408 DO_3DS( 0, 0, 0, 0, jpk -1, 2, -1 )426 DO_3DS( 0, 0, 0, 0, jpkm1, 2, -1 ) ! thrid recurrence : Ek = ( Lk - Uk * Ek+1 ) / Dk 409 427 en(ji,jj,jk) = ( zd_lw(ji,jj,jk) - zd_up(ji,jj,jk) * en(ji,jj,jk+1) ) / zdiag(ji,jj,jk) 410 428 END_3D … … 521 539 ! 522 540 ! Neumann condition at k=2 523 zdiag(:,:,2) = zdiag(:,:,2) + zd_lw(:,:,2) ! Remove zd_lw from zdiag 524 zd_lw(:,:,2) = 0._wp 541 DO_2D( 0, 0, 0, 0 ) ! zdiag zd_lw not defined/used on the halo 542 zdiag(ji,jj,2) = zdiag(ji,jj,2) + zd_lw(ji,jj,2) ! Remove zd_lw from zdiag 543 zd_lw(ji,jj,2) = 0._wp 544 END_2D 525 545 ! 526 546 ! Set psi vertical flux at the surface: 527 547 zkar (:,:) = rl_sf + (vkarmn-rl_sf)*(1._wp-EXP(-rtrans*gdept(:,:,1,Kmm)/zhsro(:,:) )) ! Lengh scale slope 528 548 zdep (:,:) = ((zhsro(:,:) + gdept(:,:,1,Kmm)) / zhsro(:,:))**(rmm*ra_sf) 529 zflxs(:,:) = (rnn + rsbc_tke1 * (rnn + rmm*ra_sf) * zdep(:,:))*(1._wp + rsbc_tke1*zdep(:,:))**(2._wp*rmm/3._wp-1_wp) 549 zflxs(:,:) = (rnn + (1._wp-zice_fra(:,:))*rsbc_tke1 * (rnn + rmm*ra_sf) * zdep(:,:)) & 550 & *(1._wp + (1._wp-zice_fra(:,:))*rsbc_tke1*zdep(:,:))**(2._wp*rmm/3._wp-1_wp) 530 551 zdep (:,:) = rsbc_psi1 * (zwall_psi(:,:,1)*p_avm(:,:,1)+zwall_psi(:,:,2)*p_avm(:,:,2)) * & 531 552 & ustar2_surf(:,:)**rmm * zkar(:,:)**rnn * (zhsro(:,:) + gdept(:,:,1,Kmm))**(rnn-1.) … … 593 614 ! ---------------- 594 615 ! 595 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) 616 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) ! First recurrence : Dk = Dk - Lk * Uk-1 / Dk-1 596 617 zdiag(ji,jj,jk) = zdiag(ji,jj,jk) - zd_lw(ji,jj,jk) * zd_up(ji,jj,jk-1) / zdiag(ji,jj,jk-1) 597 618 END_3D 598 DO_3D( 0, 0, 0, 0, 2, jpk )619 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) ! Second recurrence : Lk = RHSk - Lk / Dk-1 * Lk-1 599 620 zd_lw(ji,jj,jk) = psi(ji,jj,jk) - zd_lw(ji,jj,jk) / zdiag(ji,jj,jk-1) * zd_lw(ji,jj,jk-1) 600 621 END_3D 601 DO_3DS( 0, 0, 0, 0, jpk -1, 2, -1 )622 DO_3DS( 0, 0, 0, 0, jpkm1, 2, -1 ) ! Third recurrence : Ek = ( Lk - Uk * Ek+1 ) / Dk 602 623 psi(ji,jj,jk) = ( zd_lw(ji,jj,jk) - zd_up(ji,jj,jk) * psi(ji,jj,jk+1) ) / zdiag(ji,jj,jk) 603 624 END_3D … … 635 656 ! Limit dissipation rate under stable stratification 636 657 ! -------------------------------------------------- 637 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 658 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) ! Note that this set boundary conditions on hmxl_n at the same time 638 659 ! limitation 639 660 eps (ji,jj,jk) = MAX( eps(ji,jj,jk), rn_epsmin ) … … 700 721 ! default value, in case jpk > mbkt(ji,jj)+1. Not needed but avoid a bug when looking for undefined values (-fpe0) 701 722 zstm(:,:,jpk) = 0. 702 DO_2D( 0, 0, 0, 0 ) 723 DO_2D( 0, 0, 0, 0 ) ! update bottom with good values 703 724 zstm(ji,jj,mbkt(ji,jj)+1) = zstm(ji,jj,mbkt(ji,jj)) 704 725 END_2D … … 750 771 REAL(wp):: zcr ! local scalar 751 772 !! 752 NAMELIST/namzdf_gls/rn_emin, rn_epsmin, ln_length_lim, &753 & rn_clim_galp, ln_sigpsi, rn_hsro, 754 & rn_crban, rn_charn, rn_frac_hs, &755 & nn_bc_surf, nn_bc_bot, nn_z0_met, 773 NAMELIST/namzdf_gls/rn_emin, rn_epsmin, ln_length_lim, & 774 & rn_clim_galp, ln_sigpsi, rn_hsro, rn_hsri, & 775 & rn_crban, rn_charn, rn_frac_hs, & 776 & nn_bc_surf, nn_bc_bot, nn_z0_met, nn_z0_ice, & 756 777 & nn_stab_func, nn_clos 757 778 !!---------------------------------------------------------- … … 779 800 WRITE(numout,*) ' Charnock coefficient rn_charn = ', rn_charn 780 801 WRITE(numout,*) ' Surface roughness formula nn_z0_met = ', nn_z0_met 802 WRITE(numout,*) ' surface wave breaking under ice nn_z0_ice = ', nn_z0_ice 803 SELECT CASE( nn_z0_ice ) 804 CASE( 0 ) ; WRITE(numout,*) ' ==>>> no impact of ice cover on surface wave breaking' 805 CASE( 1 ) ; WRITE(numout,*) ' ==>>> roughness uses rn_hsri and is weigthed by 1-TANH( fr_i(:,:) * 10 )' 806 CASE( 2 ) ; WRITE(numout,*) ' ==>>> roughness uses rn_hsri and is weighted by 1-fr_i(:,:)' 807 CASE( 3 ) ; WRITE(numout,*) ' ==>>> roughness uses rn_hsri and is weighted by 1-MIN( 1, 4 * fr_i(:,:) )' 808 CASE DEFAULT 809 CALL ctl_stop( 'zdf_gls_init: wrong value for nn_z0_ice, should be 0,1,2, or 3') 810 END SELECT 781 811 WRITE(numout,*) ' Wave height frac. (used if nn_z0_met=2) rn_frac_hs = ', rn_frac_hs 782 812 WRITE(numout,*) ' Stability functions nn_stab_func = ', nn_stab_func 783 813 WRITE(numout,*) ' Type of closure nn_clos = ', nn_clos 784 814 WRITE(numout,*) ' Surface roughness (m) rn_hsro = ', rn_hsro 785 WRITE(numout,*) 786 WRITE(numout,*) ' Namelist namdrg_top/_bot: used values:' 787 WRITE(numout,*) ' top ocean cavity roughness (m) rn_z0(_top) = ', r_z0_top 788 WRITE(numout,*) ' Bottom seafloor roughness (m) rn_z0(_bot) = ', r_z0_bot 815 WRITE(numout,*) ' Ice-ocean roughness (used if nn_z0_ice/=0) rn_hsri = ', rn_hsri 789 816 WRITE(numout,*) 790 817 ENDIF -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/ZDF/zdfiwm.F90
r13295 r13998 146 146 zemx_iwm (ji,jj,1) = 0._wp ; zemx_iwm (ji,jj,jpk) = 0._wp 147 147 END_2D 148 zemx_iwm ( 1:nn_hls,:,:) = 0._wp ; zemx_iwm (:, 1:nn_hls,:) = 0._wp149 zemx_iwm (jpi-nn_hls+1:jpi ,:,:) = 0._wp ; zemx_iwm (:,jpj-nn_hls+1: jpj,:) = 0._wp150 148 ENDIF 151 149 IF( iom_use("av_ratio") ) THEN … … 153 151 zav_ratio(ji,jj,1) = 0._wp ; zav_ratio(ji,jj,jpk) = 0._wp 154 152 END_2D 155 zav_ratio( 1:nn_hls,:,:) = 0._wp ; zav_ratio(:, 1:nn_hls,:) = 0._wp 156 zav_ratio(jpi-nn_hls+1:jpi ,:,:) = 0._wp ; zav_ratio(:,jpj-nn_hls+1: jpj,:) = 0._wp 157 ENDIF 158 IF( iom_use("av_wave") ) THEN 153 ENDIF 154 IF( iom_use("av_wave") .OR. sn_cfctl%l_prtctl ) THEN 159 155 DO_2D( 0, 0, 0, 0 ) 160 156 zav_wave (ji,jj,1) = 0._wp ; zav_wave (ji,jj,jpk) = 0._wp 161 157 END_2D 162 zav_wave( 1:nn_hls,:,:) = 0._wp ; zav_wave(:, 1:nn_hls,:) = 0._wp163 zav_wave(jpi-nn_hls+1:jpi ,:,:) = 0._wp ; zav_wave(:,jpj-nn_hls+1: jpj,:) = 0._wp164 158 ENDIF 165 159 ! … … 170 164 ! !* Critical slope mixing: distribute energy over the time-varying ocean depth, 171 165 ! using an exponential decay from the seafloor. 172 DO_2D( 0, 0, 0, 0 ) 166 DO_2D( 0, 0, 0, 0 ) ! part independent of the level 173 167 zhdep(ji,jj) = gdepw_0(ji,jj,mbkt(ji,jj)+1) ! depth of the ocean 174 168 zfact(ji,jj) = rho0 * ( 1._wp - EXP( -zhdep(ji,jj) / hcri_iwm(ji,jj) ) ) … … 176 170 END_2D 177 171 !!gm gde3w ==>>> check for ssh taken into account.... seem OK gde3w_n=gdept(:,:,:,Kmm) - ssh(:,:,Kmm) 178 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) 172 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) ! complete with the level-dependent part 179 173 IF ( zfact(ji,jj) == 0._wp .OR. wmask(ji,jj,jk) == 0._wp ) THEN ! optimization 180 174 zemx_iwm(ji,jj,jk) = 0._wp … … 299 293 END_3D 300 294 ! 301 IF( ln_mevar ) THEN ! Variable mixing efficiency case : modify zav_wave in the302 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) 295 IF( ln_mevar ) THEN ! Variable mixing efficiency case : modify zav_wave in the 296 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) ! energetic (Reb > 480) and buoyancy-controlled (Reb <10.224 ) regimes 303 297 IF( zReb(ji,jj,jk) > 480.00_wp ) THEN 304 298 zav_wave(ji,jj,jk) = 3.6515_wp * znu_w(ji,jj,jk) * SQRT( zReb(ji,jj,jk) ) … … 309 303 ENDIF 310 304 ! 311 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) 305 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) ! Bound diffusivity by molecular value and 100 cm2/s 312 306 zav_wave(ji,jj,jk) = MIN( MAX( 1.4e-7_wp, zav_wave(ji,jj,jk) ), 1.e-2_wp ) * wmask(ji,jj,jk) 313 307 END_3D … … 336 330 ! ! ----------------------- ! 337 331 ! 338 IF( ln_tsdiff ) THEN !* Option for differential mixing of salinity and temperature332 IF( ln_tsdiff ) THEN !* Option for differential mixing of salinity and temperature 339 333 ztmp1 = 0.505_wp + 0.495_wp * TANH( 0.92_wp * ( LOG10( 1.e-20_wp ) - 0.60_wp ) ) 340 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) 334 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) ! Calculate S/T diffusivity ratio as a function of Reb 341 335 ztmp2 = zReb(ji,jj,jk) * 5._wp * r1_6 342 336 IF ( ztmp2 > 1.e-20_wp .AND. wmask(ji,jj,jk) == 1._wp ) THEN … … 353 347 END_3D 354 348 ! 355 ELSE !* update momentum & tracer diffusivity with wave-driven mixing349 ELSE !* update momentum & tracer diffusivity with wave-driven mixing 356 350 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) 357 351 p_avs(ji,jj,jk) = p_avs(ji,jj,jk) + zav_wave(ji,jj,jk) … … 361 355 ENDIF 362 356 363 ! !* output internal wave-driven mixing coefficient357 ! !* output internal wave-driven mixing coefficient 364 358 CALL iom_put( "av_wave", zav_wave ) 365 !* output useful diagnostics: Kz*N^2 ,359 !* output useful diagnostics: Kz*N^2 , 366 360 !!gm Kz*N2 should take into account the ratio avs/avt if it is used.... (see diaar5) 367 ! vertical integral of rho0 * Kz * N^2 , energy density (zemx_iwm)361 ! vertical integral of rho0 * Kz * N^2 , energy density (zemx_iwm) 368 362 IF( iom_use("bflx_iwm") .OR. iom_use("pcmap_iwm") ) THEN 369 363 ALLOCATE( z2d(jpi,jpj) , z3d(jpi,jpj,jpk) ) -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/ZDF/zdfmxl.F90
r13295 r13998 96 96 ! 97 97 ! w-level of the mixing and mixed layers 98 nmln(:,:) = nlb10 ! Initialization to the number of w ocean point99 hmlp(:,:) = 0._wp ! here hmlp used as a dummy variable, integrating vertically N^2100 zN2_c = grav * rho_c * r1_rho0 ! convert density criteria into N^2 criteria101 DO_3D( 1, 1, 1, 1, nlb10, jpkm1 ) 98 nmln(:,:) = nlb10 ! Initialization to the number of w ocean point 99 hmlp(:,:) = 0._wp ! here hmlp used as a dummy variable, integrating vertically N^2 100 zN2_c = grav * rho_c * r1_rho0 ! convert density criteria into N^2 criteria 101 DO_3D( 1, 1, 1, 1, nlb10, jpkm1 ) ! Mixed layer level: w-level 102 102 ikt = mbkt(ji,jj) 103 103 hmlp(ji,jj) = & … … 107 107 ! 108 108 ! w-level of the turbocline and mixing layer (iom_use) 109 imld(:,:) = mbkt(:,:) + 1 ! Initialization to the number of w ocean point110 DO_3DS( 1, 1, 1, 1, jpkm1, nlb10, -1 ) 109 imld(:,:) = mbkt(:,:) + 1 ! Initialization to the number of w ocean point 110 DO_3DS( 1, 1, 1, 1, jpkm1, nlb10, -1 ) ! from the bottom to nlb10 111 111 IF( avt (ji,jj,jk) < avt_c * wmask(ji,jj,jk) ) imld(ji,jj) = jk ! Turbocline 112 112 END_3D -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/ZDF/zdfosm.F90
r13295 r13998 1184 1184 ! KPP-style Ri# mixing 1185 1185 IF( ln_kpprimix) THEN 1186 DO_3D( 1, 0, 1, 0, 2, jpkm1 ) 1186 DO_3D( 1, 0, 1, 0, 2, jpkm1 ) !* Shear production at uw- and vw-points (energy conserving form) 1187 1187 z3du(ji,jj,jk) = 0.5 * ( uu(ji,jj,jk-1,Kmm) - uu(ji ,jj,jk,Kmm) ) & 1188 1188 & * ( uu(ji,jj,jk-1,Kbb) - uu(ji ,jj,jk,Kbb) ) * wumask(ji,jj,jk) & … … 1516 1516 ! 1517 1517 hbl(:,:) = 0._wp ! here hbl used as a dummy variable, integrating vertically N^2 1518 DO_3D( 1, 1, 1, 1, 1, jpkm1 ) 1518 DO_3D( 1, 1, 1, 1, 1, jpkm1 ) ! Mixed layer level: w-level 1519 1519 ikt = mbkt(ji,jj) 1520 1520 hbl(ji,jj) = hbl(ji,jj) + MAX( rn2(ji,jj,jk) , 0._wp ) * e3w(ji,jj,jk,Kmm) … … 1629 1629 !code saving tracer trends removed, replace with trdmxl_oce 1630 1630 1631 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 1631 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) ! add non-local u and v fluxes 1632 1632 puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) & 1633 1633 & - ( ghamu(ji,jj,jk ) & -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/ZDF/zdfphy.F90
r13226 r13998 28 28 USE sbc_oce ! surface module (only for nn_isf in the option compatibility test) 29 29 USE sbcrnf ! surface boundary condition: runoff variables 30 USE sbc_ice ! sea ice drag 30 31 #if defined key_agrif 31 32 USE agrif_oce_interp ! interpavm … … 253 254 ENDIF 254 255 ! 256 #if defined key_si3 257 IF ( ln_drgice_imp) THEN 258 IF ( ln_isfcav ) THEN 259 rCdU_top(:,:) = rCdU_top(:,:) + ssmask(:,:) * tmask(:,:,1) * rCdU_ice(:,:) 260 ELSE 261 rCdU_top(:,:) = rCdU_ice(:,:) 262 ENDIF 263 ENDIF 264 #endif 265 ! 255 266 ! !== Kz from chosen turbulent closure ==! (avm_k, avt_k) 256 267 ! … … 326 337 ! 327 338 END SUBROUTINE zdf_phy 339 340 328 341 INTEGER FUNCTION zdf_phy_alloc() 329 342 !!---------------------------------------------------------------------- -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/ZDF/zdfric.F90
r13295 r13998 160 160 ! 161 161 ! !== avm and avt = F(Richardson number) ==! 162 DO_3D( 1, 0, 1, 0, 2, jpkm1 ) 162 DO_3D( 1, 0, 1, 0, 2, jpkm1 ) ! coefficient = F(richardson number) (avm-weighted Ri) 163 163 zcfRi = 1._wp / ( 1._wp + rn_alp * MAX( 0._wp , avm(ji,jj,jk) * rn2(ji,jj,jk) / ( p_sh2(ji,jj,jk) + 1.e-20 ) ) ) 164 164 zav = rn_avmri * zcfRi**nn_ric … … 173 173 IF( ln_mldw ) THEN !== set a minimum value in the Ekman layer ==! 174 174 ! 175 DO_2D( 0, 0, 0, 0 ) 175 DO_2D( 0, 0, 0, 0 ) !* Ekman depth 176 176 zustar = SQRT( taum(ji,jj) * r1_rho0 ) 177 177 zhek = rn_ekmfc * zustar / ( ABS( ff_t(ji,jj) ) + rsmall ) ! Ekman depth 178 178 zh_ekm(ji,jj) = MAX( rn_mldmin , MIN( zhek , rn_mldmax ) ) ! set allowed range 179 179 END_2D 180 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) 180 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) !* minimum mixing coeff. within the Ekman layer 181 181 IF( gdept(ji,jj,jk,Kmm) < zh_ekm(ji,jj) ) THEN 182 182 p_avm(ji,jj,jk) = MAX( p_avm(ji,jj,jk), rn_wvmix ) * wmask(ji,jj,jk) -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/ZDF/zdfsh2.F90
r13295 r13998 60 60 ! 61 61 DO jk = 2, jpkm1 62 DO_2D( 1, 0, 1, 0 ) 62 DO_2D( 1, 0, 1, 0 ) !* 2 x shear production at uw- and vw-points (energy conserving form) 63 63 zsh2u(ji,jj) = ( p_avm(ji+1,jj,jk) + p_avm(ji,jj,jk) ) & 64 64 & * ( uu(ji,jj,jk-1,Kmm) - uu(ji,jj,jk,Kmm) ) & … … 72 72 & * wvmask(ji,jj,jk) 73 73 END_2D 74 DO_2D( 0, 0, 0, 0 ) 74 DO_2D( 0, 0, 0, 0 ) !* shear production at w-point ! coast mask: =2 at the coast ; =1 otherwise (NB: wmask useless as zsh2 are masked) 75 75 p_sh2(ji,jj,jk) = 0.25 * ( ( zsh2u(ji-1,jj) + zsh2u(ji,jj) ) * ( 2. - umask(ji-1,jj,jk) * umask(ji,jj,jk) ) & 76 76 & + ( zsh2v(ji,jj-1) + zsh2v(ji,jj) ) * ( 2. - vmask(ji,jj-1,jk) * vmask(ji,jj,jk) ) ) -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/ZDF/zdftke.F90
r13295 r13998 28 28 !! 3.6 ! 2014-11 (P. Mathiot) add ice shelf capability 29 29 !! 4.0 ! 2017-04 (G. Madec) remove CPP ddm key & avm at t-point only 30 !! - ! 2017-05 (G. Madec) add top/bottom friction as boundary condition (ln_drg)30 !! - ! 2017-05 (G. Madec) add top/bottom friction as boundary condition 31 31 !!---------------------------------------------------------------------- 32 32 … … 68 68 ! !!** Namelist namzdf_tke ** 69 69 LOGICAL :: ln_mxl0 ! mixing length scale surface value as function of wind stress or not 70 INTEGER :: nn_mxlice ! type of scaling under sea-ice (=0/1/2/3) 71 REAL(wp) :: rn_mxlice ! ice thickness value when scaling under sea-ice 70 72 INTEGER :: nn_mxl ! type of mixing length (=0/1/2/3) 71 73 REAL(wp) :: rn_mxl0 ! surface min value of mixing length (kappa*z_o=0.4*0.1 m) [m] 72 INTEGER :: nn_mxlice ! type of scaling under sea-ice73 REAL(wp) :: rn_mxlice ! max constant ice thickness value when scaling under sea-ice ( nn_mxlice=1)74 74 INTEGER :: nn_pdl ! Prandtl number or not (ratio avt/avm) (=0/1) 75 75 REAL(wp) :: rn_ediff ! coefficient for avt: avt=rn_ediff*mxl*sqrt(e) … … 79 79 REAL(wp) :: rn_emin0 ! surface minimum value of tke [m2/s2] 80 80 REAL(wp) :: rn_bshear ! background shear (>0) currently a numerical threshold (do not change it) 81 LOGICAL :: ln_drg ! top/bottom friction forcing flag82 81 INTEGER :: nn_etau ! type of depth penetration of surface tke (=0/1/2/3) 83 82 INTEGER :: nn_htau ! type of tke profile of penetration (=0/1) 84 83 REAL(wp) :: rn_efr ! fraction of TKE surface value which penetrates in the ocean 85 REAL(wp) :: rn_eice ! =0 ON below sea-ice, =4 OFF when ice fraction > 1/486 84 LOGICAL :: ln_lc ! Langmuir cells (LC) as a source term of TKE or not 87 85 REAL(wp) :: rn_lc ! coef to compute vertical velocity of Langmuir cells 86 INTEGER :: nn_eice ! attenutaion of langmuir & surface wave breaking under ice (=0/1/2/3) 88 87 89 88 REAL(wp) :: ri_cri ! critic Richardson number (deduced from rn_ediff and rn_ediss values) … … 200 199 REAL(wp), DIMENSION(:,:,:) , INTENT(in ) :: p_avm, p_avt ! vertical eddy viscosity & diffusivity (w-points) 201 200 ! 202 INTEGER :: ji, jj, jk ! dummy loop arguments201 INTEGER :: ji, jj, jk ! dummy loop arguments 203 202 REAL(wp) :: zetop, zebot, zmsku, zmskv ! local scalars 204 203 REAL(wp) :: zrhoa = 1.22 ! Air density kg/m3 205 204 REAL(wp) :: zcdrag = 1.5e-3 ! drag coefficient 206 REAL(wp) :: zbbrau, z ri! local scalars207 REAL(wp) :: zfact1, zfact2, zfact3 ! - 208 REAL(wp) :: ztx2 , zty2 , zcof ! - 209 REAL(wp) :: ztau , zdif ! - 210 REAL(wp) :: zus , zwlc , zind ! - 211 REAL(wp) :: zzd_up, zzd_lw ! - 205 REAL(wp) :: zbbrau, zbbirau, zri ! local scalars 206 REAL(wp) :: zfact1, zfact2, zfact3 ! - - 207 REAL(wp) :: ztx2 , zty2 , zcof ! - - 208 REAL(wp) :: ztau , zdif ! - - 209 REAL(wp) :: zus , zwlc , zind ! - - 210 REAL(wp) :: zzd_up, zzd_lw ! - - 212 211 INTEGER , DIMENSION(jpi,jpj) :: imlc 213 REAL(wp), DIMENSION(jpi,jpj) :: z hlc, zfr_i212 REAL(wp), DIMENSION(jpi,jpj) :: zice_fra, zhlc, zus3 214 213 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zpelc, zdiag, zd_up, zd_lw 215 214 !!-------------------------------------------------------------------- 216 215 ! 217 zbbrau = rn_ebb / rho0 ! Local constant initialisation 218 zfact1 = -.5_wp * rn_Dt 219 zfact2 = 1.5_wp * rn_Dt * rn_ediss 220 zfact3 = 0.5_wp * rn_ediss 216 zbbrau = rn_ebb / rho0 ! Local constant initialisation 217 zbbirau = 3.75_wp / rho0 218 zfact1 = -.5_wp * rn_Dt 219 zfact2 = 1.5_wp * rn_Dt * rn_ediss 220 zfact3 = 0.5_wp * rn_ediss 221 ! 222 ! ice fraction considered for attenuation of langmuir & wave breaking 223 SELECT CASE ( nn_eice ) 224 CASE( 0 ) ; zice_fra(:,:) = 0._wp 225 CASE( 1 ) ; zice_fra(:,:) = TANH( fr_i(:,:) * 10._wp ) 226 CASE( 2 ) ; zice_fra(:,:) = fr_i(:,:) 227 CASE( 3 ) ; zice_fra(:,:) = MIN( 4._wp * fr_i(:,:) , 1._wp ) 228 END SELECT 221 229 ! 222 230 ! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 223 231 ! ! Surface/top/bottom boundary condition on tke 224 232 ! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 225 ! 226 DO_2D( 0, 0, 0, 0 ) 233 ! 234 DO_2D( 0, 0, 0, 0 ) ! en(1) = rn_ebb taum / rau0 (min value rn_emin0) 235 !! clem: this should be the right formulation but it makes the model unstable unless drags are calculated implicitly 236 !! one way around would be to increase zbbirau 237 !! en(ji,jj,1) = MAX( rn_emin0, ( ( 1._wp - fr_i(ji,jj) ) * zbbrau + & 238 !! & fr_i(ji,jj) * zbbirau ) * taum(ji,jj) ) * tmask(ji,jj,1) 227 239 en(ji,jj,1) = MAX( rn_emin0, zbbrau * taum(ji,jj) ) * tmask(ji,jj,1) 228 240 END_2D … … 236 248 ! Note that stress averaged is done using an wet-only calculation of u and v at t-point like in zdfsh2 237 249 ! 238 IF( ln_drg ) THEN!== friction used as top/bottom boundary condition on TKE239 ! 240 DO_2D( 0, 0, 0, 0 ) 250 IF( .NOT.ln_drg_OFF ) THEN !== friction used as top/bottom boundary condition on TKE 251 ! 252 DO_2D( 0, 0, 0, 0 ) ! bottom friction 241 253 zmsku = ( 2. - umask(ji-1,jj,mbkt(ji,jj)) * umask(ji,jj,mbkt(ji,jj)) ) 242 254 zmskv = ( 2. - vmask(ji,jj-1,mbkt(ji,jj)) * vmask(ji,jj,mbkt(ji,jj)) ) … … 246 258 en(ji,jj,mbkt(ji,jj)+1) = MAX( zebot, rn_emin ) * ssmask(ji,jj) 247 259 END_2D 248 IF( ln_isfcav ) THEN ! top friction249 DO_2D( 0, 0, 0, 0 ) 260 IF( ln_isfcav ) THEN 261 DO_2D( 0, 0, 0, 0 ) ! top friction 250 262 zmsku = ( 2. - umask(ji-1,jj,mikt(ji,jj)) * umask(ji,jj,mikt(ji,jj)) ) 251 263 zmskv = ( 2. - vmask(ji,jj-1,mikt(ji,jj)) * vmask(ji,jj,mikt(ji,jj)) ) … … 274 286 zcof = 0.5 * 0.016 * 0.016 / ( zrhoa * zcdrag ) 275 287 imlc(:,:) = mbkt(:,:) + 1 ! Initialization to the number of w ocean point (=2 over land) 276 DO_3DS( 1, 1, 1, 1, jpkm1, 2, -1 ) 277 zus = zcof * taum(ji,jj)288 DO_3DS( 1, 1, 1, 1, jpkm1, 2, -1 ) ! Last w-level at which zpelc>=0.5*us*us 289 zus = zcof * taum(ji,jj) ! with us=0.016*wind(starting from jpk-1) 278 290 IF( zpelc(ji,jj,jk) > zus ) imlc(ji,jj) = jk 279 291 END_3D … … 285 297 DO_2D( 0, 0, 0, 0 ) 286 298 zus = zcof * SQRT( taum(ji,jj) ) ! Stokes drift 287 zfr_i(ji,jj) = ( 1._wp - 4._wp * fr_i(ji,jj) ) * zus * zus * zus * tmask(ji,jj,1) ! zus > 0. ok 288 IF (zfr_i(ji,jj) < 0. ) zfr_i(ji,jj) = 0. 299 zus3(ji,jj) = MAX( 0._wp, 1._wp - zice_fra(ji,jj) ) * zus * zus * zus * tmask(ji,jj,1) ! zus > 0. ok 289 300 END_2D 290 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) 291 IF ( zfr_i(ji,jj) /= 0. ) THEN 292 ! vertical velocity due to LC 301 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) !* TKE Langmuir circulation source term added to en 302 IF ( zus3(ji,jj) /= 0._wp ) THEN 293 303 IF ( gdepw(ji,jj,jk,Kmm) - zhlc(ji,jj) < 0 .AND. wmask(ji,jj,jk) /= 0. ) THEN 294 304 ! ! vertical velocity due to LC 295 zwlc = rn_lc * SIN( rpi * gdepw(ji,jj,jk,Kmm) / zhlc(ji,jj) ) ! warning: optimization: zus^3 is in zfr_i305 zwlc = rn_lc * SIN( rpi * gdepw(ji,jj,jk,Kmm) / zhlc(ji,jj) ) 296 306 ! ! TKE Langmuir circulation source term 297 en(ji,jj,jk) = en(ji,jj,jk) + rn_Dt * z fr_i(ji,jj) * ( zwlc * zwlc * zwlc ) / zhlc(ji,jj)307 en(ji,jj,jk) = en(ji,jj,jk) + rn_Dt * zus3(ji,jj) * ( zwlc * zwlc * zwlc ) / zhlc(ji,jj) 298 308 ENDIF 299 309 ENDIF … … 309 319 ! ! zdiag : diagonal zd_up : upper diagonal zd_lw : lower diagonal 310 320 ! 311 IF( nn_pdl == 1 ) THEN !* Prandtl number = F( Ri )321 IF( nn_pdl == 1 ) THEN !* Prandtl number = F( Ri ) 312 322 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) 313 323 ! ! local Richardson number … … 322 332 ENDIF 323 333 ! 324 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) 334 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) !* Matrix and right hand side in en 325 335 zcof = zfact1 * tmask(ji,jj,jk) 326 336 ! ! A minimum of 2.e-5 m2/s is imposed on TKE vertical 327 337 ! ! eddy coefficient (ensure numerical stability) 328 338 zzd_up = zcof * MAX( p_avm(ji,jj,jk+1) + p_avm(ji,jj,jk ) , 2.e-5_wp ) & ! upper diagonal 329 & / ( e3t(ji,jj,jk ,Kmm) & 330 & * e3w(ji,jj,jk ,Kmm) ) 339 & / ( e3t(ji,jj,jk ,Kmm) * e3w(ji,jj,jk ,Kmm) ) 331 340 zzd_lw = zcof * MAX( p_avm(ji,jj,jk ) + p_avm(ji,jj,jk-1) , 2.e-5_wp ) & ! lower diagonal 332 & / ( e3t(ji,jj,jk-1,Kmm) & 333 & * e3w(ji,jj,jk ,Kmm) ) 341 & / ( e3t(ji,jj,jk-1,Kmm) * e3w(ji,jj,jk ,Kmm) ) 334 342 ! 335 343 zd_up(ji,jj,jk) = zzd_up ! Matrix (zdiag, zd_up, zd_lw) … … 344 352 END_3D 345 353 ! !* Matrix inversion from level 2 (tke prescribed at level 1) 346 DO_3D( 0, 0, 0, 0, 3, jpkm1 ) 354 DO_3D( 0, 0, 0, 0, 3, jpkm1 ) ! First recurrence : Dk = Dk - Lk * Uk-1 / Dk-1 347 355 zdiag(ji,jj,jk) = zdiag(ji,jj,jk) - zd_lw(ji,jj,jk) * zd_up(ji,jj,jk-1) / zdiag(ji,jj,jk-1) 348 356 END_3D 349 DO_2D( 0, 0, 0, 0 ) 357 DO_2D( 0, 0, 0, 0 ) ! Second recurrence : Lk = RHSk - Lk / Dk-1 * Lk-1 350 358 zd_lw(ji,jj,2) = en(ji,jj,2) - zd_lw(ji,jj,2) * en(ji,jj,1) ! Surface boudary conditions on tke 351 359 END_2D … … 353 361 zd_lw(ji,jj,jk) = en(ji,jj,jk) - zd_lw(ji,jj,jk) / zdiag(ji,jj,jk-1) *zd_lw(ji,jj,jk-1) 354 362 END_3D 355 DO_2D( 0, 0, 0, 0 ) 363 DO_2D( 0, 0, 0, 0 ) ! thrid recurrence : Ek = ( Lk - Uk * Ek+1 ) / Dk 356 364 en(ji,jj,jpkm1) = zd_lw(ji,jj,jpkm1) / zdiag(ji,jj,jpkm1) 357 365 END_2D … … 359 367 en(ji,jj,jk) = ( zd_lw(ji,jj,jk) - zd_up(ji,jj,jk) * en(ji,jj,jk+1) ) / zdiag(ji,jj,jk) 360 368 END_3D 361 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) 369 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) ! set the minimum value of tke 362 370 en(ji,jj,jk) = MAX( en(ji,jj,jk), rn_emin ) * wmask(ji,jj,jk) 363 371 END_3D … … 368 376 !!gm BUG : in the exp remove the depth of ssh !!! 369 377 !!gm i.e. use gde3w in argument (gdepw(:,:,:,Kmm)) 370 371 378 ! 379 ! penetration is partly switched off below sea-ice if nn_eice/=0 380 ! 372 381 IF( nn_etau == 1 ) THEN !* penetration below the mixed layer (rn_efr fraction) 373 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) 382 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) 374 383 en(ji,jj,jk) = en(ji,jj,jk) + rn_efr * en(ji,jj,1) * EXP( -gdepw(ji,jj,jk,Kmm) / htau(ji,jj) ) & 375 & * MAX( 0.,1._wp - rn_eice *fr_i(ji,jj) )* wmask(ji,jj,jk) * tmask(ji,jj,1)384 & * MAX( 0._wp, 1._wp - zice_fra(ji,jj) ) * wmask(ji,jj,jk) * tmask(ji,jj,1) 376 385 END_3D 377 386 ELSEIF( nn_etau == 2 ) THEN !* act only at the base of the mixed layer (jk=nmln) (rn_efr fraction) … … 379 388 jk = nmln(ji,jj) 380 389 en(ji,jj,jk) = en(ji,jj,jk) + rn_efr * en(ji,jj,1) * EXP( -gdepw(ji,jj,jk,Kmm) / htau(ji,jj) ) & 381 & * MAX( 0.,1._wp - rn_eice *fr_i(ji,jj) )* wmask(ji,jj,jk) * tmask(ji,jj,1)390 & * MAX( 0._wp, 1._wp - zice_fra(ji,jj) ) * wmask(ji,jj,jk) * tmask(ji,jj,1) 382 391 END_2D 383 392 ELSEIF( nn_etau == 3 ) THEN !* penetration belox the mixed layer (HF variability) … … 389 398 zdif = rhftau_scl * MAX( 0._wp, zdif + rhftau_add ) ! apply some modifications... 390 399 en(ji,jj,jk) = en(ji,jj,jk) + zbbrau * zdif * EXP( -gdepw(ji,jj,jk,Kmm) / htau(ji,jj) ) & 391 & * MAX( 0.,1._wp - rn_eice *fr_i(ji,jj) ) * wmask(ji,jj,jk) * tmask(ji,jj,1)400 & * MAX( 0._wp, 1._wp - zice_fra(ji,jj) ) * wmask(ji,jj,jk) * tmask(ji,jj,1) 392 401 END_3D 393 402 ENDIF … … 451 460 zmxlm(:,:,:) = rmxl_min 452 461 zmxld(:,:,:) = rmxl_min 453 ! 462 ! 454 463 IF( ln_mxl0 ) THEN ! surface mixing length = F(stress) : l=vkarmn*2.e5*taum/(rho0*g) 455 464 ! 456 465 zraug = vkarmn * 2.e5_wp / ( rho0 * grav ) 457 466 #if ! defined key_si3 && ! defined key_cice 458 DO_2D( 0, 0, 0, 0 ) 467 DO_2D( 0, 0, 0, 0 ) ! No sea-ice 459 468 zmxlm(ji,jj,1) = zraug * taum(ji,jj) * tmask(ji,jj,1) 460 469 END_2D … … 467 476 END_2D 468 477 ! 469 CASE( 1 ) 478 CASE( 1 ) ! scaling with constant sea-ice thickness 470 479 DO_2D( 0, 0, 0, 0 ) 471 zmxlm(ji,jj,1) = ( ( 1. - fr_i(ji,jj) ) * zraug * taum(ji,jj) + fr_i(ji,jj) * rn_mxlice ) * tmask(ji,jj,1) 480 zmxlm(ji,jj,1) = ( ( 1._wp - fr_i(ji,jj) ) * zraug * taum(ji,jj) + & 481 & fr_i(ji,jj) * rn_mxlice ) * tmask(ji,jj,1) 472 482 END_2D 473 483 ! 474 CASE( 2 ) 484 CASE( 2 ) ! scaling with mean sea-ice thickness 475 485 DO_2D( 0, 0, 0, 0 ) 476 486 #if defined key_si3 477 zmxlm(ji,jj,1) = ( ( 1. - fr_i(ji,jj) ) * zraug * taum(ji,jj) + fr_i(ji,jj) * hm_i(ji,jj) * 2. ) * tmask(ji,jj,1) 487 zmxlm(ji,jj,1) = ( ( 1._wp - fr_i(ji,jj) ) * zraug * taum(ji,jj) + & 488 & fr_i(ji,jj) * hm_i(ji,jj) * 2._wp ) * tmask(ji,jj,1) 478 489 #elif defined key_cice 479 490 zmaxice = MAXVAL( h_i(ji,jj,:) ) 480 zmxlm(ji,jj,1) = ( ( 1. - fr_i(ji,jj) ) * zraug * taum(ji,jj) + fr_i(ji,jj) * zmaxice ) * tmask(ji,jj,1) 491 zmxlm(ji,jj,1) = ( ( 1._wp - fr_i(ji,jj) ) * zraug * taum(ji,jj) + & 492 & fr_i(ji,jj) * zmaxice ) * tmask(ji,jj,1) 481 493 #endif 482 494 END_2D 483 495 ! 484 CASE( 3 ) 496 CASE( 3 ) ! scaling with max sea-ice thickness 485 497 DO_2D( 0, 0, 0, 0 ) 486 498 zmaxice = MAXVAL( h_i(ji,jj,:) ) 487 zmxlm(ji,jj,1) = ( ( 1. - fr_i(ji,jj) ) * zraug * taum(ji,jj) + fr_i(ji,jj) * zmaxice ) * tmask(ji,jj,1) 499 zmxlm(ji,jj,1) = ( ( 1._wp - fr_i(ji,jj) ) * zraug * taum(ji,jj) + & 500 & fr_i(ji,jj) * zmaxice ) * tmask(ji,jj,1) 488 501 END_2D 489 502 ! … … 533 546 ! 534 547 CASE ( 2 ) ! |dk[xml]| bounded by e3t : 535 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) 548 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) ! from the surface to the bottom : 536 549 zmxlm(ji,jj,jk) = & 537 550 & MIN( zmxlm(ji,jj,jk-1) + e3t(ji,jj,jk-1,Kmm), zmxlm(ji,jj,jk) ) 538 551 END_3D 539 DO_3DS( 0, 0, 0, 0, jpkm1, 2, -1 ) 552 DO_3DS( 0, 0, 0, 0, jpkm1, 2, -1 ) ! from the bottom to the surface : 540 553 zemxl = MIN( zmxlm(ji,jj,jk+1) + e3t(ji,jj,jk+1,Kmm), zmxlm(ji,jj,jk) ) 541 554 zmxlm(ji,jj,jk) = zemxl … … 544 557 ! 545 558 CASE ( 3 ) ! lup and ldown, |dk[xml]| bounded by e3t : 546 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) 559 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) ! from the surface to the bottom : lup 547 560 zmxld(ji,jj,jk) = & 548 561 & MIN( zmxld(ji,jj,jk-1) + e3t(ji,jj,jk-1,Kmm), zmxlm(ji,jj,jk) ) 549 562 END_3D 550 DO_3DS( 0, 0, 0, 0, jpkm1, 2, -1 ) 563 DO_3DS( 0, 0, 0, 0, jpkm1, 2, -1 ) ! from the bottom to the surface : ldown 551 564 zmxlm(ji,jj,jk) = & 552 565 & MIN( zmxlm(ji,jj,jk+1) + e3t(ji,jj,jk+1,Kmm), zmxlm(ji,jj,jk) ) … … 564 577 ! ! Vertical eddy viscosity and diffusivity (avm and avt) 565 578 ! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 566 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 579 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) !* vertical eddy viscosity & diffivity at w-points 567 580 zsqen = SQRT( en(ji,jj,jk) ) 568 581 zav = rn_ediff * zmxlm(ji,jj,jk) * zsqen … … 573 586 ! 574 587 ! 575 IF( nn_pdl == 1 ) THEN !* Prandtl number case: update avt588 IF( nn_pdl == 1 ) THEN !* Prandtl number case: update avt 576 589 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) 577 590 p_avt(ji,jj,jk) = MAX( apdlr(ji,jj,jk) * p_avt(ji,jj,jk), avtb_2d(ji,jj) * avtb(jk) ) * wmask(ji,jj,jk) … … 610 623 & rn_emin0, rn_bshear, nn_mxl , ln_mxl0 , & 611 624 & rn_mxl0 , nn_mxlice, rn_mxlice, & 612 & nn_pdl , ln_ drg , ln_lc , rn_lc,&613 & nn_etau , nn_htau , rn_efr , rn_eice625 & nn_pdl , ln_lc , rn_lc , & 626 & nn_etau , nn_htau , rn_efr , nn_eice 614 627 !!---------------------------------------------------------------------- 615 628 ! … … 637 650 WRITE(numout,*) ' mixing length type nn_mxl = ', nn_mxl 638 651 WRITE(numout,*) ' surface mixing length = F(stress) or not ln_mxl0 = ', ln_mxl0 652 WRITE(numout,*) ' surface mixing length minimum value rn_mxl0 = ', rn_mxl0 639 653 IF( ln_mxl0 ) THEN 640 654 WRITE(numout,*) ' type of scaling under sea-ice nn_mxlice = ', nn_mxlice 641 655 IF( nn_mxlice == 1 ) & 642 656 WRITE(numout,*) ' ice thickness when scaling under sea-ice rn_mxlice = ', rn_mxlice 643 ENDIF 644 WRITE(numout,*) ' surface mixing length minimum value rn_mxl0 = ', rn_mxl0 645 WRITE(numout,*) ' top/bottom friction forcing flag ln_drg = ', ln_drg 657 SELECT CASE( nn_mxlice ) ! Type of scaling under sea-ice 658 CASE( 0 ) ; WRITE(numout,*) ' ==>>> No scaling under sea-ice' 659 CASE( 1 ) ; WRITE(numout,*) ' ==>>> scaling with constant sea-ice thickness' 660 CASE( 2 ) ; WRITE(numout,*) ' ==>>> scaling with mean sea-ice thickness' 661 CASE( 3 ) ; WRITE(numout,*) ' ==>>> scaling with max sea-ice thickness' 662 CASE DEFAULT 663 CALL ctl_stop( 'zdf_tke_init: wrong value for nn_mxlice, should be 0,1,2,3 or 4') 664 END SELECT 665 ENDIF 646 666 WRITE(numout,*) ' Langmuir cells parametrization ln_lc = ', ln_lc 647 667 WRITE(numout,*) ' coef to compute vertical velocity of LC rn_lc = ', rn_lc … … 649 669 WRITE(numout,*) ' type of tke penetration profile nn_htau = ', nn_htau 650 670 WRITE(numout,*) ' fraction of TKE that penetrates rn_efr = ', rn_efr 651 WRITE(numout,*) ' below sea-ice: =0 ON rn_eice = ', rn_eice 652 WRITE(numout,*) ' =4 OFF when ice fraction > 1/4 ' 653 IF( ln_drg ) THEN 654 WRITE(numout,*) 655 WRITE(numout,*) ' Namelist namdrg_top/_bot: used values:' 656 WRITE(numout,*) ' top ocean cavity roughness (m) rn_z0(_top)= ', r_z0_top 657 WRITE(numout,*) ' Bottom seafloor roughness (m) rn_z0(_bot)= ', r_z0_bot 658 ENDIF 671 WRITE(numout,*) ' langmuir & surface wave breaking under ice nn_eice = ', nn_eice 672 SELECT CASE( nn_eice ) 673 CASE( 0 ) ; WRITE(numout,*) ' ==>>> no impact of ice cover on langmuir & surface wave breaking' 674 CASE( 1 ) ; WRITE(numout,*) ' ==>>> weigthed by 1-TANH( fr_i(:,:) * 10 )' 675 CASE( 2 ) ; WRITE(numout,*) ' ==>>> weighted by 1-fr_i(:,:)' 676 CASE( 3 ) ; WRITE(numout,*) ' ==>>> weighted by 1-MIN( 1, 4 * fr_i(:,:) )' 677 CASE DEFAULT 678 CALL ctl_stop( 'zdf_tke_init: wrong value for nn_eice, should be 0,1,2, or 3') 679 END SELECT 659 680 WRITE(numout,*) 660 681 WRITE(numout,*) ' ==>>> critical Richardson nb with your parameters ri_cri = ', ri_cri -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/module_example
r11536 r13998 93 93 INTEGER :: ji, jj, jk ! dummy loop arguments (DOCTOR : start with j, but not jp) 94 94 INTEGER :: itoto, itata ! temporary integers (DOCTOR : start with i 95 REAL(wp) :: zmlmin, zbbr au! temporary scalars (DOCTOR : start with z)95 REAL(wp) :: zmlmin, zbbrho ! temporary scalars (DOCTOR : start with z) 96 96 REAL(wp) :: zfact1, zfact2 ! do not use continuation lines in declaration 97 97 REAL(wp), DIMENSION(jpi,jpj) :: zwrk_2d ! 2D workspace … … 101 101 102 102 zmlmin = 1.e-8 ! Local constant initialization 103 zbbr au = .5 * ebb / rau0103 zbbrho = .5 * ebb / rho0 104 104 zfact1 = -.5 * rdt * efave 105 105 zfact2 = 1.5 * rdt * ediss -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/nemogcm.F90
r13915 r13998 449 449 ! ! Lateral physics 450 450 CALL ldf_tra_init ! Lateral ocean tracer physics 451 CALL ldf_eiv_init ! eddy induced velocity param. 451 CALL ldf_eiv_init ! eddy induced velocity param. must be done after ldf_tra_init 452 452 CALL ldf_dyn_init ! Lateral ocean momentum physics 453 453 … … 487 487 CALL flo_init( Nnn ) ! drifting Floats 488 488 IF( ln_diacfl ) CALL dia_cfl_init ! Initialise CFL diagnostics 489 ! CALL dia_ptr_init ! Poleward TRansports initialization490 489 CALL dia_dct_init ! Sections tranports 491 490 CALL dia_hsb_init( Nnn ) ! heat content, salt content and volume budgets -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/stpctl.F90
r13608 r13998 49 49 !! 50 50 !! ** Method : - Save the time step in numstp 51 !! - Print it each 50 time steps52 51 !! - Stop the run IF problem encountered by setting nstop > 0 53 52 !! Problems checked: |ssh| maximum larger than 10 m … … 68 67 REAL(wp) :: zzz ! local real 69 68 REAL(wp), DIMENSION(9) :: zmax, zmaxlocal 70 LOGICAL :: ll_wrtstp, ll_colruns, ll_wrtruns 69 LOGICAL :: ll_wrtstp, ll_colruns, ll_wrtruns, ll_0oce 71 70 LOGICAL, DIMENSION(jpi,jpj,jpk) :: llmsk 72 71 CHARACTER(len=20) :: clname … … 120 119 ! !== test of local extrema ==! 121 120 ! !== done by all processes at every time step ==! 122 llmsk(:,:,1) = ssmask(:,:) == 1._wp 121 ! 122 llmsk( 1:Nis1,:,:) = .FALSE. ! exclude halos from the checked region 123 llmsk(Nie1: jpi,:,:) = .FALSE. 124 llmsk(:, 1:Njs1,:) = .FALSE. 125 llmsk(:,Nje1: jpj,:) = .FALSE. 126 ! 127 llmsk(Nis0:Nie0,Njs0:Nje0,1) = ssmask(Nis0:Nie0,Njs0:Nje0) == 1._wp ! define only the inner domain 128 ! 129 ll_0oce = .NOT. ANY( llmsk(:,:,1) ) ! no ocean point in the inner domain? 130 ! 123 131 IF( ll_wd ) THEN 124 132 zmax(1) = MAXVAL( ABS( ssh(:,:,Kmm) + ssh_ref ), mask = llmsk(:,:,1) ) ! ssh max … … 126 134 zmax(1) = MAXVAL( ABS( ssh(:,:,Kmm) ), mask = llmsk(:,:,1) ) ! ssh max 127 135 ENDIF 128 llmsk( :,:,:) = umask(:,:,:) == 1._wp136 llmsk(Nis0:Nie0,Njs0:Nje0,:) = umask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp ! define only the inner domain 129 137 zmax(2) = MAXVAL( ABS( uu(:,:,:,Kmm) ), mask = llmsk ) ! velocity max (zonal only) 130 llmsk( :,:,:) = tmask(:,:,:) == 1._wp138 llmsk(Nis0:Nie0,Njs0:Nje0,:) = tmask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp ! define only the inner domain 131 139 zmax(3) = MAXVAL( -ts(:,:,:,jp_sal,Kmm), mask = llmsk ) ! minus salinity max 132 140 zmax(4) = MAXVAL( ts(:,:,:,jp_sal,Kmm), mask = llmsk ) ! salinity max … … 144 152 zmax(5:8) = 0._wp 145 153 ENDIF 146 zmax(9) = REAL( nstop, wp ) ! stop indicator 154 zmax(9) = REAL( nstop, wp ) ! stop indicator 155 ! 147 156 ! !== get global extrema ==! 148 157 ! !== done by all processes if writting run.stat ==! 149 158 IF( ll_colruns ) THEN 150 159 zmaxlocal(:) = zmax(:) 151 CALL mpp_max( "stpctl", zmax ) ! max over the global domain 160 CALL mpp_max( "stpctl", zmax ) ! max over the global domain: ok even of ll_0oce = .true. 152 161 nstop = NINT( zmax(9) ) ! update nstop indicator (now sheared among all local domains) 153 ENDIF 162 ELSE 163 ! if no ocean point: MAXVAL returns -HUGE => we must overwrite this value to avoid error handling bellow. 164 IF( ll_0oce ) zmax(1:4) = (/ 0._wp, 0._wp, -1._wp, 1._wp /) ! default "valid" values... 165 ENDIF 166 ! 167 zmax(3) = -zmax(3) ! move back from max(-zz) to min(zz) : easier to manage! 168 zmax(5) = -zmax(5) ! move back from max(-zz) to min(zz) : easier to manage! 169 IF( ll_colruns ) THEN 170 zmaxlocal(3) = -zmaxlocal(3) ! move back from max(-zz) to min(zz) : easier to manage! 171 zmaxlocal(5) = -zmaxlocal(5) ! move back from max(-zz) to min(zz) : easier to manage! 172 ENDIF 173 ! 154 174 ! !== write "run.stat" files ==! 155 175 ! !== done only by 1st subdomain at writting timestep ==! 156 176 IF( ll_wrtruns ) THEN 157 WRITE(numrun,9500) kt, zmax(1), zmax(2), -zmax(3), zmax(4) 158 istatus = NF90_PUT_VAR( nrunid, nvarid(1), (/ zmax(1)/), (/kt/), (/1/) ) 159 istatus = NF90_PUT_VAR( nrunid, nvarid(2), (/ zmax(2)/), (/kt/), (/1/) ) 160 istatus = NF90_PUT_VAR( nrunid, nvarid(3), (/-zmax(3)/), (/kt/), (/1/) ) 161 istatus = NF90_PUT_VAR( nrunid, nvarid(4), (/ zmax(4)/), (/kt/), (/1/) ) 162 istatus = NF90_PUT_VAR( nrunid, nvarid(5), (/-zmax(5)/), (/kt/), (/1/) ) 163 istatus = NF90_PUT_VAR( nrunid, nvarid(6), (/ zmax(6)/), (/kt/), (/1/) ) 164 IF( ln_zad_Aimp ) THEN 165 istatus = NF90_PUT_VAR( nrunid, nvarid(7), (/ zmax(7)/), (/kt/), (/1/) ) 166 istatus = NF90_PUT_VAR( nrunid, nvarid(8), (/ zmax(8)/), (/kt/), (/1/) ) 167 ENDIF 177 WRITE(numrun,9500) kt, zmax(1), zmax(2), zmax(3), zmax(4) 178 DO ji = 1, 6 + 2 * COUNT( (/ln_zad_Aimp/) ) 179 istatus = NF90_PUT_VAR( nrunid, nvarid(ji), (/zmax(ji)/), (/kt/), (/1/) ) 180 END DO 168 181 IF( kt == nitend ) istatus = NF90_CLOSE(nrunid) 169 182 ENDIF … … 171 184 ! !== done by all processes at every time step ==! 172 185 ! 173 IF( 174 & 175 & zmax(3) >= 0._wp .OR. & ! negative or zero sea surface salinity176 & 177 & 178 & 179 & 186 IF( zmax(1) > 20._wp .OR. & ! too large sea surface height ( > 20 m ) 187 & zmax(2) > 10._wp .OR. & ! too large velocity ( > 10 m/s) 188 & zmax(3) <= 0._wp .OR. & ! negative or zero sea surface salinity 189 & zmax(4) >= 100._wp .OR. & ! too large sea surface salinity ( > 100 ) 190 & zmax(4) < 0._wp .OR. & ! too large sea surface salinity (keep this line for sea-ice) 191 & ISNAN( zmax(1) + zmax(2) + zmax(3) ) .OR. & ! NaN encounter in the tests 192 & ABS( zmax(1) + zmax(2) + zmax(3) ) > HUGE(1._wp) ) THEN ! Infinity encounter in the tests 180 193 ! 181 194 iloc(:,:) = 0 … … 184 197 IF( lwm .AND. kt /= nitend ) istatus = NF90_CLOSE(nrunid) 185 198 ! get global loc on the min/max 186 CALL mpp_maxloc( 'stpctl', ABS(ssh(:,:, Kmm)), ssmask(:,: ), zzz, iloc(1:2,1) ) ! mpp_maxloc ok if mask = F 187 CALL mpp_maxloc( 'stpctl', ABS( uu(:,:,:, Kmm)), umask(:,:,:), zzz, iloc(1:3,2) ) 188 CALL mpp_minloc( 'stpctl', ts(:,:,:,jp_sal,Kmm) , tmask(:,:,:), zzz, iloc(1:3,3) ) 189 CALL mpp_maxloc( 'stpctl', ts(:,:,:,jp_sal,Kmm) , tmask(:,:,:), zzz, iloc(1:3,4) ) 199 llmsk(Nis0:Nie0,Njs0:Nje0,1) = ssmask(Nis0:Nie0,Njs0:Nje0 ) == 1._wp ! define only the inner domain 200 CALL mpp_maxloc( 'stpctl', ABS(ssh(:,:, Kmm)), llmsk(:,:,1), zzz, iloc(1:2,1) ) ! mpp_maxloc ok if mask = F 201 llmsk(Nis0:Nie0,Njs0:Nje0,:) = umask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp ! define only the inner domain 202 CALL mpp_maxloc( 'stpctl', ABS( uu(:,:,:, Kmm)), llmsk(:,:,:), zzz, iloc(1:3,2) ) 203 llmsk(Nis0:Nie0,Njs0:Nje0,:) = tmask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp ! define only the inner domain 204 CALL mpp_minloc( 'stpctl', ts(:,:,:,jp_sal,Kmm) , llmsk(:,:,:), zzz, iloc(1:3,3) ) 205 CALL mpp_maxloc( 'stpctl', ts(:,:,:,jp_sal,Kmm) , llmsk(:,:,:), zzz, iloc(1:3,4) ) 190 206 ! find which subdomain has the max. 191 207 iareamin(:) = jpnij+1 ; iareamax(:) = 0 ; iareasum(:) = 0 … … 200 216 ELSE ! find local min and max locations: 201 217 ! if we are here, this means that the subdomain contains some oce points -> no need to test the mask used in maxloc 202 iloc(1:2,1) = MAXLOC( ABS( ssh(:,:, Kmm)), mask = ssmask(:,: ) == 1._wp ) + (/ nimpp - 1, njmpp - 1 /) 203 iloc(1:3,2) = MAXLOC( ABS( uu(:,:,:, Kmm)), mask = umask(:,:,:) == 1._wp ) + (/ nimpp - 1, njmpp - 1, 0 /) 204 iloc(1:3,3) = MINLOC( ts(:,:,:,jp_sal,Kmm) , mask = tmask(:,:,:) == 1._wp ) + (/ nimpp - 1, njmpp - 1, 0 /) 205 iloc(1:3,4) = MAXLOC( ts(:,:,:,jp_sal,Kmm) , mask = tmask(:,:,:) == 1._wp ) + (/ nimpp - 1, njmpp - 1, 0 /) 218 llmsk(Nis0:Nie0,Njs0:Nje0,1) = ssmask(Nis0:Nie0,Njs0:Nje0 ) == 1._wp ! define only the inner domain 219 iloc(1:2,1) = MAXLOC( ABS( ssh(:,:, Kmm)), mask = llmsk(:,:,1) ) 220 llmsk(Nis0:Nie0,Njs0:Nje0,:) = umask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp ! define only the inner domain 221 iloc(1:3,2) = MAXLOC( ABS( uu(:,:,:, Kmm)), mask = llmsk(:,:,:) ) 222 llmsk(Nis0:Nie0,Njs0:Nje0,:) = tmask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp ! define only the inner domain 223 iloc(1:3,3) = MINLOC( ts(:,:,:,jp_sal,Kmm) , mask = llmsk(:,:,:) ) 224 iloc(1:3,4) = MAXLOC( ts(:,:,:,jp_sal,Kmm) , mask = llmsk(:,:,:) ) 225 DO ji = 1, 4 ! local domain indices ==> global domain indices, excluding halos 226 iloc(1:2,ji) = (/ mig0(iloc(1,ji)), mjg0(iloc(2,ji)) /) 227 END DO 206 228 iareamin(:) = narea ; iareamax(:) = narea ; iareasum(:) = 1 ! this is local information 207 229 ENDIF 208 230 ! 209 231 WRITE(ctmp1,*) ' stp_ctl: |ssh| > 20 m or |U| > 10 m/s or S <= 0 or S >= 100 or NaN encounter in the tests' 210 CALL wrt_line( ctmp2, kt, '|ssh| max', 211 CALL wrt_line( ctmp3, kt, '|U| max', 212 CALL wrt_line( ctmp4, kt, 'Sal min', -zmax(3), iloc(:,3), iareasum(3), iareamin(3), iareamax(3) )213 CALL wrt_line( ctmp5, kt, 'Sal max', 232 CALL wrt_line( ctmp2, kt, '|ssh| max', zmax(1), iloc(:,1), iareasum(1), iareamin(1), iareamax(1) ) 233 CALL wrt_line( ctmp3, kt, '|U| max', zmax(2), iloc(:,2), iareasum(2), iareamin(2), iareamax(2) ) 234 CALL wrt_line( ctmp4, kt, 'Sal min', zmax(3), iloc(:,3), iareasum(3), iareamin(3), iareamax(3) ) 235 CALL wrt_line( ctmp5, kt, 'Sal max', zmax(4), iloc(:,4), iareasum(4), iareamin(4), iareamax(4) ) 214 236 IF( Agrif_Root() ) THEN 215 237 WRITE(ctmp6,*) ' ===> output of last computed fields in output.abort* files' -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/timing.F90
r12489 r13998 213 213 214 214 215 SUBROUTINE timing_init 215 SUBROUTINE timing_init( clname ) 216 216 !!---------------------------------------------------------------------- 217 217 !! *** ROUTINE timing_init *** … … 221 221 REAL(wp) :: zdum 222 222 LOGICAL :: ll_f 223 223 CHARACTER(len=*), INTENT(in), OPTIONAL :: clname 224 CHARACTER(len=20) :: cln 225 226 IF( PRESENT(clname) ) THEN ; cln = clname 227 ELSE ; cln = 'timing.output' 228 ENDIF 229 224 230 IF( ln_onefile ) THEN 225 IF( lwp) CALL ctl_opn( numtime, 'timing.output', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout,.TRUE., narea )231 IF( lwp) CALL ctl_opn( numtime, cln, 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout,.TRUE., narea ) 226 232 lwriter = lwp 227 233 ELSE 228 CALL ctl_opn( numtime, 'timing.output', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout,.FALSE., narea )234 CALL ctl_opn( numtime, cln, 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout,.FALSE., narea ) 229 235 lwriter = .TRUE. 230 236 ENDIF … … 418 424 s_timer => s_timer_root 419 425 DO WHILE ( ASSOCIATED( s_timer%next ) ) 420 IF (.NOT. ASSOCIATED(s_timer%next)) EXIT426 IF (.NOT. ASSOCIATED(s_timer%next)) EXIT 421 427 IF ( s_timer%tsum_clock < s_timer%next%tsum_clock ) THEN 422 428 ALLOCATE(s_wrk) … … 426 432 ll_ord = .FALSE. 427 433 CYCLE 428 ENDIF 429 IF( ASSOCIATED(s_timer%next) ) s_timer => s_timer%next430 END DO 434 ENDIF 435 IF( ASSOCIATED(s_timer%next) ) s_timer => s_timer%next 436 END DO 431 437 IF( ll_ord ) EXIT 432 438 END DO … … 441 447 clfmt = '(1x,a,4x,f12.3,6x,f12.3,x,f12.3,2x,f12.3,6x,f7.3,2x,i9)' 442 448 DO WHILE ( ASSOCIATED(s_timer) ) 443 WRITE(numtime,TRIM(clfmt)) s_timer%cname, & 444 & s_timer%tsum_clock,s_timer%tsum_clock*100./t_elaps(2), & 445 & s_timer%tsum_cpu ,s_timer%tsum_cpu*100./t_cpu(2) , & 446 & s_timer%tsum_cpu/s_timer%tsum_clock, s_timer%niter 449 IF( s_timer%tsum_clock > 0._wp ) & 450 WRITE(numtime,TRIM(clfmt)) s_timer%cname, & 451 & s_timer%tsum_clock,s_timer%tsum_clock*100./t_elaps(2), & 452 & s_timer%tsum_cpu ,s_timer%tsum_cpu*100./t_cpu(2) , & 453 & s_timer%tsum_cpu/s_timer%tsum_clock, s_timer%niter 447 454 s_timer => s_timer%next 448 455 END DO … … 607 614 clfmt = '((A),E15.7,2x,f6.2,5x,f12.2,5x,f6.2,5x,f7.2,2x,f12.2,4x,f6.2,2x,f9.2)' 608 615 DO WHILE ( ASSOCIATED(sl_timer_ave) ) 609 WRITE(numtime,TRIM(clfmt)) sl_timer_ave%cname(1:18), & 610 & sl_timer_ave%tsum_clock,sl_timer_ave%tsum_clock*100.*jpnij/tot_etime, & 611 & sl_timer_ave%tsum_cpu ,sl_timer_ave%tsum_cpu*100.*jpnij/tot_ctime , & 612 & sl_timer_ave%tsum_cpu/sl_timer_ave%tsum_clock, & 613 & sl_timer_ave%tmax_clock*100.*jpnij/tot_etime, & 614 & sl_timer_ave%tmin_clock*100.*jpnij/tot_etime, & 615 & sl_timer_ave%niter/REAL(jpnij) 616 IF( sl_timer_ave%tsum_clock > 0. ) & 617 WRITE(numtime,TRIM(clfmt)) sl_timer_ave%cname(1:18), & 618 & sl_timer_ave%tsum_clock,sl_timer_ave%tsum_clock*100.*jpnij/tot_etime, & 619 & sl_timer_ave%tsum_cpu ,sl_timer_ave%tsum_cpu*100.*jpnij/tot_ctime , & 620 & sl_timer_ave%tsum_cpu/sl_timer_ave%tsum_clock, & 621 & sl_timer_ave%tmax_clock*100.*jpnij/tot_etime, & 622 & sl_timer_ave%tmin_clock*100.*jpnij/tot_etime, & 623 & sl_timer_ave%niter/REAL(jpnij) 616 624 sl_timer_ave => sl_timer_ave%next 617 625 END DO -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OFF/dtadyn.F90
r13735 r13998 298 298 sf_dyn(jf_uwd)%cltype = 'U' ; sf_dyn(jf_uwd)%zsgn = -1._wp 299 299 sf_dyn(jf_vwd)%cltype = 'V' ; sf_dyn(jf_vwd)%zsgn = -1._wp 300 sf_dyn(jf_ubl)%cltype = 'U' ; sf_dyn(jf_ubl)%zsgn = 1._wp 301 sf_dyn(jf_vbl)%cltype = 'V' ; sf_dyn(jf_vbl)%zsgn = 1._wp 300 ! 301 IF( ln_trabbl ) THEN 302 sf_dyn(jf_ubl)%cltype = 'U' ; sf_dyn(jf_ubl)%zsgn = 1._wp 303 sf_dyn(jf_vbl)%cltype = 'V' ; sf_dyn(jf_vbl)%zsgn = 1._wp 304 END IF 302 305 ! 303 306 ! Open file for each variable to get his number of dimension … … 412 415 END_2D 413 416 ! 414 DO_2D( 1, 1, 1, 1 ) 417 DO_2D( 1, 1, 1, 1 ) ! set the associated depth 415 418 h_rnf(ji,jj) = 0._wp 416 419 DO jk = 1, nk_rnf(ji,jj) … … 687 690 !!---------------------------------------------------------------------- 688 691 ! 689 DO_2D( 1, 1, 1, 1 ) 692 DO_2D( 1, 1, 1, 1 ) ! update the depth over which runoffs are distributed 690 693 h_rnf(ji,jj) = 0._wp 691 694 DO jk = 1, nk_rnf(ji,jj) ! recalculates h_rnf to be the depth in metres -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OFF/nemogcm.F90
r13734 r13998 40 40 USE sbcmod ! surface boundary condition (sbc_init routine) 41 41 USE phycst ! physical constant (par_cst routine) 42 USE zdfphy ! vertical physics manager (zdf_phy_init routine) 42 43 USE dtadyn ! Lecture and Interpolation of the dynamical fields 43 44 USE trcini ! Initilization of the passive tracers … … 49 50 USE trcnam ! passive tracer : namelist 50 51 USE trcrst ! passive tracer restart 51 USE diaptr ! Need to initialise this as some variables are used in if statements later52 52 USE sbc_oce , ONLY : ln_rnf 53 53 USE sbcrnf ! surface boundary condition : runoffs … … 77 77 78 78 CHARACTER (len=64) :: cform_aaa="( /, 'AAAAAAAA', / ) " ! flag for output listing 79 #if defined key_mpp_mpi 80 ! need MPI_Wtime 81 INCLUDE 'mpif.h' 82 #endif 79 83 80 84 !!---------------------------------------------------------------------- … … 100 104 !!---------------------------------------------------------------------- 101 105 INTEGER :: istp ! time step index 106 REAL(wp):: zstptiming ! elapsed time for 1 time step 102 107 !!---------------------------------------------------------------------- 103 108 … … 118 123 ! 119 124 DO WHILE ( istp <= nitend .AND. nstop == 0 ) !== OFF time-stepping ==! 125 126 IF( ln_timing ) THEN 127 zstptiming = MPI_Wtime() 128 IF ( istp == ( nit000 + 1 ) ) elapsed_time = zstptiming 129 IF ( istp == nitend ) elapsed_time = zstptiming - elapsed_time 130 ENDIF 120 131 ! 121 132 IF( istp /= nit000 ) CALL day ( istp ) ! Calendar (day was already called at nit000 in day_init) … … 151 162 # endif 152 163 #endif 153 164 CALL stp_ctl ( istp ) ! Time loop: control and print 154 165 istp = istp + 1 166 167 IF( lwp .AND. ln_timing ) WRITE(numtime,*) 'timing step ', istp-1, ' : ', MPI_Wtime() - zstptiming 168 155 169 END DO 156 170 ! … … 337 351 338 352 CALL sbc_init( Nbb, Nnn, Naa ) ! Forcings : surface module 339 CALL bdy_init ! Open boundaries initialisation 353 CALL bdy_init ! Open boundaries initialisation 354 355 CALL zdf_phy_init( Nnn ) ! Vertical physics 340 356 341 357 ! ! Tracer physics 342 358 CALL ldf_tra_init ! Lateral ocean tracer physics 343 CALL ldf_eiv_init ! Eddy induced velocity param 359 CALL ldf_eiv_init ! Eddy induced velocity param. must be done after ldf_tra_init 344 360 CALL tra_ldf_init ! lateral mixing 345 361 IF( l_ldfslp ) CALL ldf_slp_init ! slope of lateral mixing … … 355 371 CALL dta_dyn_init( Nbb, Nnn, Naa ) ! Initialization for the dynamics 356 372 #endif 357 358 373 CALL trc_init( Nbb, Nnn, Naa ) ! Passive tracers initialization 359 CALL dia_ptr_init ! Poleward TRansports initialization360 374 361 375 IF(lwp) WRITE(numout,cform_aaa) ! Flag AAAAAAA -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/SAS/nemogcm.F90
r13286 r13998 2 2 !!====================================================================== 3 3 !! *** MODULE nemogcm *** 4 !! StandAlone Surface module : surface fluxes + sea-ice + iceberg floats 4 !! StandAlone Surface module : surface fluxes + sea-ice + iceberg floats + ABL 5 5 !!====================================================================== 6 6 !! History : 3.6 ! 2011-11 (S. Alderson, G. Madec) original code … … 58 58 59 59 #if defined key_mpp_mpi 60 ! need MPI_Wtime 60 61 INCLUDE 'mpif.h' 61 62 #endif … … 83 84 !!---------------------------------------------------------------------- 84 85 INTEGER :: istp ! time step index 86 REAL(wp):: zstptiming ! elapsed time for 1 time step 85 87 !!---------------------------------------------------------------------- 86 88 ! … … 93 95 #if defined key_agrif 94 96 Kbb_a = Nbb; Kmm_a = Nnn; Krhs_a = Nrhs ! agrif_oce module copies of time level indices 95 CALL Agrif_Declare_Var ! " " " " " DYN/TRA 97 CALL Agrif_Declare_Var ! " " " " " DYN/TRA 96 98 # if defined key_top 97 99 CALL Agrif_Declare_Var_top ! " " " " " TOP … … 107 109 ! !== time stepping ==! 108 110 ! !-----------------------! 111 ! 112 ! !== set the model time-step ==! 113 ! 109 114 istp = nit000 110 115 ! … … 124 129 END DO 125 130 ! 126 # else131 # else 127 132 ! 128 133 IF( .NOT.ln_diurnal_only ) THEN !== Standard time-stepping ==! 129 134 ! 130 135 DO WHILE( istp <= nitend .AND. nstop == 0 ) 131 #if defined key_mpp_mpi 136 132 137 ncom_stp = istp 133 IF ( istp == ( nit000 + 1 ) ) elapsed_time = MPI_Wtime() 134 IF ( istp == nitend ) elapsed_time = MPI_Wtime() - elapsed_time 135 #endif 138 IF( ln_timing ) THEN 139 zstptiming = MPI_Wtime() 140 IF ( istp == ( nit000 + 1 ) ) elapsed_time = zstptiming 141 IF ( istp == nitend ) elapsed_time = zstptiming - elapsed_time 142 ENDIF 143 136 144 CALL stp ( istp ) 137 145 istp = istp + 1 146 147 IF( lwp .AND. ln_timing ) WRITE(numtime,*) 'timing step ', istp-1, ' : ', MPI_Wtime() - zstptiming 148 138 149 END DO 139 150 ! … … 305 316 WRITE(numout,*) " ) ) \) |`\ \) '. \ ( ( " 306 317 WRITE(numout,*) " ( ( \_/ '-._\ ) ) " 307 WRITE(numout,*) " ) ) jgs `( ( "318 WRITE(numout,*) " ) ) jgs ` ( ( " 308 319 WRITE(numout,*) " ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ " 309 320 WRITE(numout,*) … … 355 366 ! 356 367 ! ! General initialization 357 IF( ln_timing ) CALL timing_init ! timing368 IF( ln_timing ) CALL timing_init ( 'timing_sas.output' ) 358 369 IF( ln_timing ) CALL timing_start( 'nemo_init') 359 370 … … 367 378 & CALL prt_ctl_init ! Print control 368 379 380 IF( ln_rstart ) CALL rst_read_open 369 381 CALL day_init ! model calendar (using both namelist and restart infos) 370 IF( ln_rstart ) CALL rst_read_open 371 382 383 #if defined key_agrif 384 uu(:,:,:,:) = 0.0_wp ; vv(:,:,:,:) = 0.0_wp ; ts(:,:,:,:,:) = 0.0_wp ! needed for interp done at initialization phase 385 #endif 372 386 ! ! external forcing 373 387 CALL sbc_init( Nbb, Nnn, Naa ) ! Forcings : surface module … … 480 494 ierr = dia_wri_alloc() 481 495 ierr = ierr + dom_oce_alloc() ! ocean domain 482 ierr = ierr + oce_alloc () ! (ts n...) needed for agrif and/or SI3 and bdy496 ierr = ierr + oce_alloc () ! (ts...) needed for agrif and/or SI3 and bdy 483 497 ierr = ierr + bdy_oce_alloc() ! bdy masks (incl. initialization) 484 498 ! -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/SAS/stpctl.F90
r13136 r13998 20 20 USE dom_oce ! ocean space and time domain variables 21 21 USE ice , ONLY : vt_i, u_ice, tm_i 22 USE phycst , ONLY : rt0 23 USE sbc_oce , ONLY : lk_oasis 22 24 ! 23 25 USE diawri ! Standard run outputs (dia_wri_state routine) … … 48 50 !! 49 51 !! ** Method : - Save the time step in numstp 50 !! - Print it each 50 time steps51 52 !! - Stop the run IF problem encountered by setting nstop > 0 52 53 !! Problems checked: ice thickness maximum > 100 m … … 67 68 REAL(wp) :: zzz ! local real 68 69 REAL(wp), DIMENSION(4) :: zmax, zmaxlocal 69 LOGICAL :: ll_wrtstp, ll_colruns, ll_wrtruns 70 LOGICAL :: ll_wrtstp, ll_colruns, ll_wrtruns, ll_0oce 70 71 LOGICAL, DIMENSION(jpi,jpj) :: llmsk 71 72 CHARACTER(len=20) :: clname … … 85 86 ENDIF 86 87 ! ! open time.step ascii file, done only by 1st subdomain 87 IF( lwm ) CALL ctl_opn( numstp, 'time.step', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp, narea ) 88 IF( lk_oasis ) THEN ; clname = 'time_sas.step' 89 ELSE ; clname = 'time.step' 90 ENDIF 91 IF( lwm ) CALL ctl_opn( numstp, clname, 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp, narea ) 88 92 ! 89 93 IF( ll_wrtruns ) THEN 94 IF( lk_oasis ) THEN ; clname = 'run_sas.stat' 95 ELSE ; clname = 'run.stat' 96 ENDIF 90 97 ! ! open run.stat ascii file, done only by 1st subdomain 91 CALL ctl_opn( numrun, 'run.stat', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp, narea )98 CALL ctl_opn( numrun, clname, 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp, narea ) 92 99 ! ! open run.stat.nc netcdf file, done only by 1st subdomain 93 clname = 'run.stat.nc'100 clname = TRIM(clname)//'.nc' 94 101 IF( .NOT. Agrif_Root() ) clname = TRIM(Agrif_CFixed())//"_"//TRIM(clname) 95 102 istatus = NF90_CREATE( TRIM(clname), NF90_CLOBBER, nrunid ) … … 111 118 ! !== test of local extrema ==! 112 119 ! !== done by all processes at every time step ==! 113 llmsk(:,:) = tmask(:,:,1) == 1._wp 114 IF( COUNT( llmsk(:,:) ) > 0 ) THEN ! avoid huge values sent back for land processors... 115 zmax(1) = MAXVAL( vt_i (:,:) , mask = llmsk ) ! max ice thickness 116 zmax(2) = MAXVAL( ABS( u_ice(:,:) ) , mask = llmsk ) ! max ice velocity (zonal only) 117 zmax(3) = MAXVAL( -tm_i (:,:) + 273.15_wp, mask = llmsk ) ! min ice temperature 118 ELSE 119 IF( ll_colruns ) THEN ! default value: must not be kept when calling mpp_max -> must be as small as possible 120 zmax(1:3) = -HUGE(1._wp) 121 ELSE ! default value: must not give true for any of the tests bellow (-> avoid manipulating HUGE...) 122 zmax(1:3) = 0._wp 123 ENDIF 124 ENDIF 125 zmax(4) = REAL( nstop, wp ) ! stop indicator 120 ! 121 llmsk( 1:Nis1,:) = .FALSE. ! exclude halos from the checked region 122 llmsk(Nie1: jpi,:) = .FALSE. 123 llmsk(:, 1:Njs1) = .FALSE. 124 llmsk(:,Nje1: jpj) = .FALSE. 125 ! 126 llmsk(Nis0:Nie0,Njs0:Nje0) = tmask(Nis0:Nie0,Njs0:Nje0,1) == 1._wp ! test only the inner domain 127 ! 128 ll_0oce = .NOT. ANY( llmsk(:,:) ) ! no ocean point in the inner domain? 129 ! 130 zmax(1) = MAXVAL( vt_i (:,:) , mask = llmsk ) ! max ice thickness 131 zmax(2) = MAXVAL( ABS( u_ice(:,:) ) , mask = llmsk ) ! max ice velocity (zonal only) 132 zmax(3) = MAXVAL( -tm_i (:,:) + rt0, mask = llmsk ) ! min ice temperature (in degC) 133 zmax(4) = REAL( nstop, wp ) ! stop indicator 134 ! 126 135 ! !== get global extrema ==! 127 136 ! !== done by all processes if writting run.stat ==! 128 137 IF( ll_colruns ) THEN 129 138 zmaxlocal(:) = zmax(:) 130 CALL mpp_max( "stpctl", zmax ) ! max over the global domain 139 CALL mpp_max( "stpctl", zmax ) ! max over the global domain: ok even of ll_0oce = .true. 131 140 nstop = NINT( zmax(4) ) ! update nstop indicator (now sheared among all local domains) 132 ENDIF 141 ELSE 142 ! if no ocean point: MAXVAL returns -HUGE => we must overwrite this value to avoid error handling bellow. 143 IF( ll_0oce ) zmax(1:3) = 0._wp ! default "valid" values... 144 ENDIF 145 ! 146 zmax(3) = -zmax(3) ! move back from max(-zz) to min(zz) : easier to manage! 147 IF( ll_colruns ) zmaxlocal(3) = -zmaxlocal(3) ! move back from max(-zz) to min(zz) : easier to manage! 148 ! 133 149 ! !== write "run.stat" files ==! 134 150 ! !== done only by 1st subdomain at writting timestep ==! 135 151 IF( ll_wrtruns ) THEN 136 WRITE(numrun,9500) kt, zmax(1), zmax(2), -zmax(3)137 istatus = NF90_PUT_VAR( nrunid, nvarid(1), (/ zmax(1)/), (/kt/), (/1/) )138 istatus = NF90_PUT_VAR( nrunid, nvarid(2), (/ zmax(2)/), (/kt/), (/1/) )139 istatus = NF90_PUT_VAR( nrunid, nvarid(3), (/-zmax(3)/), (/kt/), (/1/) )152 WRITE(numrun,9500) kt, zmax(1), zmax(2), zmax(3) 153 DO ji = 1, 3 154 istatus = NF90_PUT_VAR( nrunid, nvarid(ji), (/zmax(ji)/), (/kt/), (/1/) ) 155 END DO 140 156 IF( kt == nitend ) istatus = NF90_CLOSE(nrunid) 141 157 END IF … … 145 161 IF( zmax(1) > 100._wp .OR. & ! too large ice thickness maximum ( > 100 m) 146 162 & zmax(2) > 10._wp .OR. & ! too large ice velocity ( > 10 m/s) 147 & zmax(3) >101._wp .OR. & ! too cold ice temperature ( < -100 degC)163 & zmax(3) < -101._wp .OR. & ! too cold ice temperature ( < -100 degC) 148 164 & ISNAN( zmax(1) + zmax(2) + zmax(3) ) .OR. & ! NaN encounter in the tests 149 165 & ABS( zmax(1) + zmax(2) + zmax(3) ) > HUGE(1._wp) ) THEN ! Infinity encounter in the tests … … 154 170 IF( lwm .AND. kt /= nitend ) istatus = NF90_CLOSE(nrunid) 155 171 ! get global loc on the min/max 156 CALL mpp_maxloc( 'stpctl', vt_i(:,:) , tmask(:,:,1), zzz, iloc(1:2,1) ) ! mpp_maxloc ok if mask = F157 CALL mpp_maxloc( 'stpctl',ABS( u_ice(:,:) ) , tmask(:,:,1), zzz, iloc(1:2,2) )158 CALL mpp_minloc( 'stpctl', tm_i(:,:) - 273.15_wp, tmask(:,:,1), zzz, iloc(1:2,3) )172 CALL mpp_maxloc( 'stpctl', vt_i(:,:) , llmsk, zzz, iloc(1:2,1) ) ! mpp_maxloc ok if mask = F 173 CALL mpp_maxloc( 'stpctl',ABS( u_ice(:,:) ) , llmsk, zzz, iloc(1:2,2) ) 174 CALL mpp_minloc( 'stpctl', tm_i(:,:) - rt0, llmsk, zzz, iloc(1:2,3) ) 159 175 ! find which subdomain has the max. 160 176 iareamin(:) = jpnij+1 ; iareamax(:) = 0 ; iareasum(:) = 0 … … 169 185 ELSE ! find local min and max locations: 170 186 ! if we are here, this means that the subdomain contains some oce points -> no need to test the mask used in maxloc 171 iloc(1:2,1) = MAXLOC( vt_i(:,:) , mask = llmsk ) + (/ nimpp - 1, njmpp - 1/) 172 iloc(1:2,2) = MAXLOC( ABS( u_ice(:,:) ) , mask = llmsk ) + (/ nimpp - 1, njmpp - 1/) 173 iloc(1:2,3) = MINLOC( tm_i(:,:) - 273.15_wp, mask = llmsk ) + (/ nimpp - 1, njmpp - 1/) 187 iloc(1:2,1) = MAXLOC( vt_i(:,:) , mask = llmsk ) 188 iloc(1:2,2) = MAXLOC( ABS( u_ice(:,:) ) , mask = llmsk ) 189 iloc(1:2,3) = MINLOC( tm_i(:,:) - rt0, mask = llmsk ) 190 DO ji = 1, 3 ! local domain indices ==> global domain indices, excluding halos 191 iloc(1:2,ji) = (/ mig0(iloc(1,ji)), mjg0(iloc(2,ji)) /) 192 END DO 174 193 iareamin(:) = narea ; iareamax(:) = narea ; iareasum(:) = 1 ! this is local information 175 194 ENDIF 176 195 ! 177 196 WRITE(ctmp1,*) ' stp_ctl: ice_thick > 100 m or |ice_vel| > 10 m/s or ice_temp < -100 degC or NaN encounter in the tests' 178 CALL wrt_line( ctmp2, kt, 'ice_thick max', 179 CALL wrt_line( ctmp3, kt, '|ice_vel| max', 180 CALL wrt_line( ctmp4, kt, 'ice_temp min', -zmax(3), iloc(:,3), iareasum(3), iareamin(3), iareamax(3) )197 CALL wrt_line( ctmp2, kt, 'ice_thick max', zmax(1), iloc(:,1), iareasum(1), iareamin(1), iareamax(1) ) 198 CALL wrt_line( ctmp3, kt, '|ice_vel| max', zmax(2), iloc(:,2), iareasum(2), iareamin(2), iareamax(2) ) 199 CALL wrt_line( ctmp4, kt, 'ice_temp min', zmax(3), iloc(:,3), iareasum(3), iareamin(3), iareamax(3) ) 181 200 IF( Agrif_Root() ) THEN 182 201 WRITE(ctmp6,*) ' ===> output of last computed fields in output.abort* files' -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/SWE/stpctl.F90
r13604 r13998 31 31 INTEGER :: nrunid ! netcdf file id 32 32 INTEGER, DIMENSION(2) :: nvarid ! netcdf variable id 33 !!SWE INTEGER, DIMENSION(8) :: nvarid ! netcdf variable id34 33 35 34 # include "domzgr_substitute.h90" 36 35 !!---------------------------------------------------------------------- 37 36 !! NEMO/OCE 4.0 , NEMO Consortium (2018) 38 !! $Id: stpctl.F90 1 2614 2020-03-26 14:59:52Z gm$37 !! $Id: stpctl.F90 13216 2020-07-02 09:25:49Z rblod $ 39 38 !! Software governed by the CeCILL license (see ./LICENSE) 40 39 !!---------------------------------------------------------------------- … … 63 62 INTEGER :: ji ! dummy loop indices 64 63 INTEGER :: idtime, istatus 65 !!SWE INTEGER , DIMENSION(9) :: iareasum, iareamin, iareamax66 64 INTEGER , DIMENSION(3) :: iareasum, iareamin, iareamax 67 65 INTEGER , DIMENSION(3,4) :: iloc ! min/max loc indices 68 66 REAL(wp) :: zzz ! local real 69 !!SWE REAL(wp), DIMENSION(9) :: zmax, zmaxlocal70 67 REAL(wp), DIMENSION(3) :: zmax, zmaxlocal 71 68 LOGICAL :: ll_wrtstp, ll_colruns, ll_wrtruns … … 73 70 CHARACTER(len=20) :: clname 74 71 !!---------------------------------------------------------------------- 72 IF( nstop > 0 .AND. ngrdstop > -1 ) RETURN ! stpctl was already called by a child grid 75 73 ! 76 74 IF( nstop > 0 .AND. ngrdstop > -1 ) RETURN ! stpctl was already called by a child grid … … 100 98 istatus = NF90_DEF_VAR( nrunid, 'abs_ssh_max', NF90_DOUBLE, (/ idtime /), nvarid(1) ) 101 99 istatus = NF90_DEF_VAR( nrunid, 'abs_u_max', NF90_DOUBLE, (/ idtime /), nvarid(2) ) 102 !!SWE istatus = NF90_DEF_VAR( nrunid, 's_min', NF90_DOUBLE, (/ idtime /), nvarid(3) )103 !!SWE istatus = NF90_DEF_VAR( nrunid, 's_max', NF90_DOUBLE, (/ idtime /), nvarid(4) )104 !!SWE istatus = NF90_DEF_VAR( nrunid, 't_min', NF90_DOUBLE, (/ idtime /), nvarid(5) )105 !!SWE istatus = NF90_DEF_VAR( nrunid, 't_max', NF90_DOUBLE, (/ idtime /), nvarid(6) )106 !!SWE IF( ln_zad_Aimp ) THEN107 !!SWE istatus = NF90_DEF_VAR( nrunid, 'Cf_max', NF90_DOUBLE, (/ idtime /), nvarid(7) )108 !!SWE istatus = NF90_DEF_VAR( nrunid,'abs_wi_max',NF90_DOUBLE, (/ idtime /), nvarid(8) )109 !!SWE ENDIF110 100 istatus = NF90_ENDDEF(nrunid) 111 101 ENDIF … … 121 111 ! !== test of local extrema ==! 122 112 ! !== done by all processes at every time step ==! 123 !!SWE llmsk(:,:,1) = ssmask(:,:) == 1._wp124 !!SWE IF( ll_wd ) THEN125 !!SWE zmax(1) = MAXVAL( ABS( ssh(:,:,Kmm) + ssh_ref ), mask = llmsk(:,:,1) ) ! ssh max126 !!SWE ELSE127 !!SWE zmax(1) = MAXVAL( ABS( ssh(:,:,Kmm) ), mask = llmsk(:,:,1) ) ! ssh max128 !!SWE ENDIF129 113 zmax(1) = MINVAL( e3t_0(:,:,1)+ssh(:,:,Kmm) ) ! e3t_Kmm min 130 !!SWE131 114 llmsk(:,:,:) = umask(:,:,:) == 1._wp 132 115 zmax(2) = MAXVAL( ABS( uu(:,:,:,Kmm) ), mask = llmsk ) ! velocity max (zonal only) 133 !!SWE llmsk(:,:,:) = tmask(:,:,:) == 1._wp134 !!SWE zmax(3) = MAXVAL( -ts(:,:,:,jp_sal,Kmm), mask = llmsk ) ! minus salinity max135 !!SWE zmax(4) = MAXVAL( ts(:,:,:,jp_sal,Kmm), mask = llmsk ) ! salinity max136 !!SWE IF( ll_colruns .OR. jpnij == 1 ) THEN ! following variables are used only in the netcdf file137 !!SWE zmax(5) = MAXVAL( -ts(:,:,:,jp_tem,Kmm), mask = llmsk ) ! minus temperature max138 !!SWE zmax(6) = MAXVAL( ts(:,:,:,jp_tem,Kmm), mask = llmsk ) ! temperature max139 !!SWE IF( ln_zad_Aimp ) THEN140 !!SWE zmax(7) = MAXVAL( Cu_adv(:,:,:) , mask = llmsk ) ! partitioning coeff. max141 !!SWE llmsk(:,:,:) = wmask(:,:,:) == 1._wp142 !!SWE zmax(8) = MAXVAL( ABS( wi(:,:,:) ) , mask = llmsk ) ! implicit vertical vel. max143 !!SWE ELSE144 !!SWE zmax(7:8) = 0._wp145 !!SWE ENDIF146 !!SWE ELSE147 !!SWE zmax(5:8) = 0._wp148 !!SWE ENDIF149 !!SWE zmax(9) = REAL( nstop, wp ) ! stop indicator150 !!SWE151 116 zmax(3) = REAL( nstop , wp ) ! stop indicator 152 !!SWE 117 ! !== get global extrema ==! 118 ! !== done by all processes if writting run.stat ==! 119 llmsk(Nis0:Nie0,Njs0:Nje0,1) = tmask(Nis0:Nie0,Njs0:Nje0,1) == 1._wp ! define only the inner domain 120 zmax(1) = MAXVAL( -e3t(:,:,1,Kmm) ), mask = llmsk(:,:,1) ) ! ssh max 121 llmsk(Nis0:Nie0,Njs0:Nje0,:) = umask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp ! define only the inner domain 122 zmax(2) = MAXVAL( ABS( uu(:,:,:,Kmm) ), mask = llmsk(:,:,:) ) ! velocity max (zonal only) 123 zmax(3) = REAL( nstop, wp ) ! stop indicator 153 124 ! !== get global extrema ==! 154 125 ! !== done by all processes if writting run.stat ==! … … 156 127 zmaxlocal(:) = zmax(:) 157 128 CALL mpp_max( "stpctl", zmax ) ! max over the global domain 158 !!SWE nstop = NINT( zmax(9) ) ! update nstop indicator (now sheared among all local domains)159 129 nstop = NINT( zmax(3) ) ! update nstop indicator (now sheared among all local domains) 160 130 ENDIF … … 162 132 ! !== done only by 1st subdomain at writting timestep ==! 163 133 IF( ll_wrtruns ) THEN 164 !!SWE WRITE(numrun,9500) kt, zmax(1), zmax(2), -zmax(3), zmax(4)165 134 WRITE(numrun,9500) kt, zmax(1), zmax(2) 166 135 istatus = NF90_PUT_VAR( nrunid, nvarid(1), (/ zmax(1)/), (/kt/), (/1/) ) 167 136 istatus = NF90_PUT_VAR( nrunid, nvarid(2), (/ zmax(2)/), (/kt/), (/1/) ) 168 !!SWE istatus = NF90_PUT_VAR( nrunid, nvarid(3), (/-zmax(3)/), (/kt/), (/1/) )169 !!SWE istatus = NF90_PUT_VAR( nrunid, nvarid(4), (/ zmax(4)/), (/kt/), (/1/) )170 !!SWE istatus = NF90_PUT_VAR( nrunid, nvarid(5), (/-zmax(5)/), (/kt/), (/1/) )171 !!SWE istatus = NF90_PUT_VAR( nrunid, nvarid(6), (/ zmax(6)/), (/kt/), (/1/) )172 !!SWE IF( ln_zad_Aimp ) THEN173 !!SWE istatus = NF90_PUT_VAR( nrunid, nvarid(7), (/ zmax(7)/), (/kt/), (/1/) )174 !!SWE istatus = NF90_PUT_VAR( nrunid, nvarid(8), (/ zmax(8)/), (/kt/), (/1/) )175 !!SWE ENDIF176 137 IF( kt == nitend ) istatus = NF90_CLOSE(nrunid) 177 138 ENDIF … … 236 197 ENDIF 237 198 ! 238 !!SWE 9500 FORMAT(' it :', i8, ' |ssh|_max: ', D23.16, ' |U|_max: ', D23.16,' S_min: ', D23.16,' S_max: ', D23.16)239 199 9500 FORMAT(' it :', i8, ' e3t_min: ', D23.16, ' |U|_max: ', D23.16) 240 200 ! -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/TOP/C14/trcatm_c14.F90
r13295 r13998 120 120 IF( ierr3 /= 0 ) CALL ctl_stop( 'STOP', 'trc_atm_c14_ini: unable to allocate fareaz' ) 121 121 ! 122 DO_2D( 1, 1, 1, 1 ) 122 DO_2D( 1, 1, 1, 1 ) ! from C14b package 123 123 IF( gphit(ji,jj) >= yn40 ) THEN 124 124 fareaz(ji,jj,1) = 0. -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/TOP/CFC/trcsms_cfc.F90
r13295 r13998 126 126 127 127 ! !------------! 128 DO_2D( 1, 1, 1, 1 ) 129 128 DO_2D( 1, 1, 1, 1 ) ! i-j loop ! 129 ! !------------! 130 130 ! space interpolation 131 131 zpp_cfc = xphem(ji,jj) * zpatm(1,jl) & -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/TOP/PISCES/P2Z/p2zopt.F90
r13295 r13998 95 95 ! ! Photosynthetically Available Radiation (PAR) 96 96 zcoef = 12 * redf / rcchl / rpig ! -------------------------------------- 97 DO_3D( 1, 1, 1, 1, 2, jpk ) 97 DO_3D( 1, 1, 1, 1, 2, jpk ) ! local par at w-levels 98 98 zpig = LOG( MAX( TINY(0.), tr(ji,jj,jk-1,jpphy,Kmm) ) * zcoef ) 99 99 zkr = xkr0 + xkrp * EXP( xlr * zpig ) … … 102 102 zparg(ji,jj,jk) = zparg(ji,jj,jk-1) * EXP( -zkg * e3t(ji,jj,jk-1,Kmm) ) 103 103 END_3D 104 DO_3D( 1, 1, 1, 1, 1, jpkm1 ) 104 DO_3D( 1, 1, 1, 1, 1, jpkm1 ) ! mean par at t-levels 105 105 zpig = LOG( MAX( TINY(0.), tr(ji,jj,jk,jpphy,Kmm) ) * zcoef ) 106 106 zkr = xkr0 + xkrp * EXP( xlr * zpig ) … … 114 114 ! ! -------------- 115 115 neln(:,:) = 1 ! euphotic layer level 116 DO_3D( 1, 1, 1, 1, 1, jpkm1 ) 116 DO_3D( 1, 1, 1, 1, 1, jpkm1 ) ! (i.e. 1rst T-level strictly below EL bottom) 117 117 IF( etot(ji,jj,jk) >= zpar100(ji,jj) ) neln(ji,jj) = jk + 1 118 118 END_3D -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/TOP/PISCES/P4Z/p4zfechem.F90
r13295 r13998 118 118 ! 119 119 zfeequi = zFe3(ji,jj,jk) * 1E-9 120 zhplus = max( rtrn, hi(ji,jj,jk) )121 fe3sol = fesol(ji,jj,jk,1) * ( zhplus**3 + fesol(ji,jj,jk,2) * zhplus**2 &122 & + fesol(ji,jj,jk,3) * zhplus + fesol(ji,jj,jk,4) &123 & + fesol(ji,jj,jk,5) / zhplus )124 120 zfecoll = 0.5 * zFeL1(ji,jj,jk) * 1E-9 125 121 ! precipitation of Fe3+, creation of nanoparticles -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/TOP/PISCES/P4Z/p4zlim.F90
r13295 r13998 161 161 zlim1 = xdiatno3(ji,jj,jk) + xdiatnh4(ji,jj,jk) 162 162 zlim2 = tr(ji,jj,jk,jppo4,Kbb) / ( tr(ji,jj,jk,jppo4,Kbb) + zconc1dnh4 ) 163 zlim3 = tr(ji,jj,jk,jpsil,Kbb) / ( tr(ji,jj,jk,jpsil,Kbb) + xksi(ji,jj) )163 zlim3 = tr(ji,jj,jk,jpsil,Kbb) / ( tr(ji,jj,jk,jpsil,Kbb) + xksi(ji,jj) + rtrn ) 164 164 zratio = tr(ji,jj,jk,jpdfe,Kbb) * z1_trbdia 165 165 zironmin = xcoef1 * tr(ji,jj,jk,jpdch,Kbb) * z1_trbdia + xcoef2 * zlim1 + xcoef3 * xdiatno3(ji,jj,jk) -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/TOP/PISCES/P4Z/p4zopt.F90
r13295 r13998 37 37 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: par_varsw ! PAR fraction of shortwave 38 38 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: ekb, ekg, ekr ! wavelength (Red-Green-Blue) 39 40 INTEGER :: nksrp ! levels below which the light cannot penetrate ( depth larger than 391 m)41 42 REAL(wp), DIMENSION(3,61) :: xkrgb ! tabulated attenuation coefficients for RGB absorption43 39 44 40 !! * Substitutions … … 94 90 irgb = NINT( 41 + 20.* LOG10( zchl ) + rtrn ) 95 91 ! 96 ekb(ji,jj,jk) = xkrgb(1,irgb) * e3t(ji,jj,jk,Kmm)97 ekg(ji,jj,jk) = xkrgb(2,irgb) * e3t(ji,jj,jk,Kmm)98 ekr(ji,jj,jk) = xkrgb(3,irgb) * e3t(ji,jj,jk,Kmm)92 ekb(ji,jj,jk) = rkrgb(1,irgb) * e3t(ji,jj,jk,Kmm) 93 ekg(ji,jj,jk) = rkrgb(2,irgb) * e3t(ji,jj,jk,Kmm) 94 ekr(ji,jj,jk) = rkrgb(3,irgb) * e3t(ji,jj,jk,Kmm) 99 95 END_3D 100 96 ! !* Photosynthetically Available Radiation (PAR) … … 106 102 CALL p4z_opt_par( kt, Kmm, zqsr_corr, ze1, ze2, ze3, pqsr100 = zqsr100 ) 107 103 ! 108 DO jk = 1, nksr p104 DO jk = 1, nksr 109 105 etot_ndcy(:,:,jk) = ze1(:,:,jk) + ze2(:,:,jk) + ze3(:,:,jk) 110 106 enano (:,:,jk) = 1.85 * ze1(:,:,jk) + 0.69 * ze2(:,:,jk) + 0.46 * ze3(:,:,jk) … … 112 108 END DO 113 109 IF( ln_p5z ) THEN 114 DO jk = 1, nksr p110 DO jk = 1, nksr 115 111 epico (:,:,jk) = 1.94 * ze1(:,:,jk) + 0.66 * ze2(:,:,jk) + 0.4 * ze3(:,:,jk) 116 112 END DO … … 121 117 CALL p4z_opt_par( kt, Kmm, zqsr_corr, ze1, ze2, ze3 ) 122 118 ! 123 DO jk = 1, nksr p119 DO jk = 1, nksr 124 120 etot(:,:,jk) = ze1(:,:,jk) + ze2(:,:,jk) + ze3(:,:,jk) 125 121 END DO … … 131 127 CALL p4z_opt_par( kt, Kmm, zqsr_corr, ze1, ze2, ze3, pqsr100 = zqsr100 ) 132 128 ! 133 DO jk = 1, nksr p129 DO jk = 1, nksr 134 130 etot (:,:,jk) = ze1(:,:,jk) + ze2(:,:,jk) + ze3(:,:,jk) 135 131 enano(:,:,jk) = 1.85 * ze1(:,:,jk) + 0.69 * ze2(:,:,jk) + 0.46 * ze3(:,:,jk) … … 137 133 END DO 138 134 IF( ln_p5z ) THEN 139 DO jk = 1, nksr p135 DO jk = 1, nksr 140 136 epico(:,:,jk) = 1.94 * ze1(:,:,jk) + 0.66 * ze2(:,:,jk) + 0.4 * ze3(:,:,jk) 141 137 END DO … … 150 146 ! 151 147 etot3(:,:,1) = qsr(:,:) * tmask(:,:,1) 152 DO jk = 2, nksr p+ 1148 DO jk = 2, nksr + 1 153 149 etot3(:,:,jk) = ( ze0(:,:,jk) + ze1(:,:,jk) + ze2(:,:,jk) + ze3(:,:,jk) ) * tmask(:,:,jk) 154 150 END DO … … 160 156 heup_01(:,:) = gdepw(:,:,2,Kmm) 161 157 162 DO_3D( 1, 1, 1, 1, 2, nksr p)158 DO_3D( 1, 1, 1, 1, 2, nksr ) 163 159 IF( etot_ndcy(ji,jj,jk) * tmask(ji,jj,jk) >= zqsr100(ji,jj) ) THEN 164 160 neln(ji,jj) = jk+1 ! Euphotic level : 1rst T-level strictly below Euphotic layer … … 178 174 zetmp2 (:,:) = 0.e0 179 175 180 DO_3D( 1, 1, 1, 1, 1, nksr p)176 DO_3D( 1, 1, 1, 1, 1, nksr ) 181 177 IF( gdepw(ji,jj,jk+1,Kmm) <= hmld(ji,jj) ) THEN 182 178 zetmp1 (ji,jj) = zetmp1 (ji,jj) + etot (ji,jj,jk) * e3t(ji,jj,jk,Kmm) ! remineralisation … … 189 185 zpar(:,:,:) = etot_ndcy(:,:,:) ! diagnostic : PAR with no diurnal cycle 190 186 ! 191 DO_3D( 1, 1, 1, 1, 1, nksr p)187 DO_3D( 1, 1, 1, 1, 1, nksr ) 192 188 IF( gdepw(ji,jj,jk+1,Kmm) <= hmld(ji,jj) ) THEN 193 189 z1_dep = 1. / ( zdepmoy(ji,jj) + rtrn ) … … 201 197 zetmp4 (:,:) = 0.e0 202 198 ! 203 DO_3D( 1, 1, 1, 1, 1, nksr p)199 DO_3D( 1, 1, 1, 1, 1, nksr ) 204 200 IF( gdepw(ji,jj,jk+1,Kmm) <= MIN(hmld(ji,jj), heup_01(ji,jj)) ) THEN 205 201 zetmp3 (ji,jj) = zetmp3 (ji,jj) + enano (ji,jj,jk) * e3t(ji,jj,jk,Kmm) ! production … … 211 207 ediatm(:,:,:) = ediat(:,:,:) 212 208 ! 213 DO_3D( 1, 1, 1, 1, 1, nksr p)209 DO_3D( 1, 1, 1, 1, 1, nksr ) 214 210 IF( gdepw(ji,jj,jk+1,Kmm) <= hmld(ji,jj) ) THEN 215 211 z1_dep = 1. / ( zdepmoy(ji,jj) + rtrn ) … … 221 217 IF( ln_p5z ) THEN 222 218 ALLOCATE( zetmp5(jpi,jpj) ) ; zetmp5 (:,:) = 0.e0 223 DO_3D( 1, 1, 1, 1, 1, nksr p)219 DO_3D( 1, 1, 1, 1, 1, nksr ) 224 220 IF( gdepw(ji,jj,jk+1,Kmm) <= MIN(hmld(ji,jj), heup_01(ji,jj)) ) THEN 225 221 zetmp5(ji,jj) = zetmp5 (ji,jj) + epico(ji,jj,jk) * e3t(ji,jj,jk,Kmm) ! production … … 229 225 epicom(:,:,:) = epico(:,:,:) 230 226 ! 231 DO_3D( 1, 1, 1, 1, 1, nksr p)227 DO_3D( 1, 1, 1, 1, 1, nksr ) 232 228 IF( gdepw(ji,jj,jk+1,Kmm) <= hmld(ji,jj) ) THEN 233 229 z1_dep = 1. / ( zdepmoy(ji,jj) + rtrn ) … … 283 279 pe3(:,:,1) = zqsr(:,:) 284 280 ! 285 DO jk = 2, nksr p+ 1281 DO jk = 2, nksr + 1 286 282 DO jj = 1, jpj 287 283 DO ji = 1, jpi … … 302 298 pe3(:,:,1) = zqsr(:,:) * EXP( -0.5 * ekr(:,:,1) ) 303 299 ! 304 DO_3D( 1, 1, 1, 1, 2, nksr p)300 DO_3D( 1, 1, 1, 1, 2, nksr ) 305 301 pe1(ji,jj,jk) = pe1(ji,jj,jk-1) * EXP( -0.5 * ( ekb(ji,jj,jk-1) + ekb(ji,jj,jk) ) ) 306 302 pe2(ji,jj,jk) = pe2(ji,jj,jk-1) * EXP( -0.5 * ( ekg(ji,jj,jk-1) + ekg(ji,jj,jk) ) ) … … 400 396 ntimes_par = iom_getszuld( numpar ) ! get number of record in file 401 397 ENDIF 402 !403 CALL trc_oce_rgb( xkrgb ) ! tabulated attenuation coefficients404 nksrp = trc_oce_ext_lev( r_si2, 0.33e2_wp ) ! max level of light extinction (Blue Chl=0.01)405 !406 IF(lwp) WRITE(numout,*) ' level of light extinction = ', nksrp, ' ref depth = ', gdepw_1d(nksrp+1), ' m'407 398 ! 408 399 ekr (:,:,:) = 0._wp -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/TOP/PISCES/P4Z/p4zsed.F90
r13295 r13998 313 313 ENDIF 314 314 ! 315 IF(sn_cfctl%l_prttrc) THEN ! print mean tr ends (USEd for debugging)315 IF(sn_cfctl%l_prttrc) THEN ! print mean trneds (USEd for debugging) 316 316 WRITE(charout, fmt="('sed ')") 317 317 CALL prt_ctl_info( charout, cdcomp = 'top' ) … … 366 366 lk_sed = ln_sediment .AND. ln_sed_2way 367 367 ! 368 nitrpot(:,:,jpk) = 0._wp ! define last level for iom_put 369 ! 368 370 END SUBROUTINE p4z_sed_init 369 371 -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/TOP/PISCES/P4Z/p4zsms.F90
r13295 r13998 69 69 REAL(wp), ALLOCATABLE, DIMENSION(:,: ) :: zw2d 70 70 REAL(wp), ALLOCATABLE, DIMENSION(:,:,: ) :: zw3d 71 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:,:) :: ztrdt ! 4D workspace71 REAL(wp), DIMENSION(jpi,jpj,jpk,jp_pisces) :: ztrbbio 72 72 73 73 !!--------------------------------------------------------------------- … … 93 93 rfact = rDt_trc 94 94 ! 95 ! trends computation initialisation96 IF( l_trdtrc ) THEN97 ALLOCATE( ztrdt(jpi,jpj,jpk,jp_pisces) ) !* store now fields before applying the Asselin filter98 ztrdt(:,:,:,:) = tr(:,:,:,:,Kmm)99 ENDIF100 !101 102 95 IF( ( ln_top_euler .AND. kt == nittrc000 ) .OR. ( .NOT.ln_top_euler .AND. kt <= nittrc000 + 1 ) ) THEN 103 96 rfactr = 1. / rfact … … 117 110 END DO 118 111 ENDIF 112 113 DO jn = jp_pcs0, jp_pcs1 ! Store the tracer concentrations before entering PISCES 114 ztrbbio(:,:,:,jn) = tr(:,:,:,jn,Kbb) 115 END DO 116 119 117 ! 120 118 IF( ll_bc ) CALL p4z_bc( kt, Kbb, Kmm, Krhs ) ! external sources of nutrients … … 198 196 END DO 199 197 ! 200 IF( ln_top_euler ) THEN 201 DO jn = jp_pcs0, jp_pcs1 202 tr(:,:,:,jn,Kmm) = tr(:,:,:,jn,Kbb) 203 END DO 204 ENDIF 198 END DO 199 ! 200 #endif 201 ! 202 IF( ln_sediment ) THEN 203 ! 204 CALL sed_model( kt, Kbb, Kmm, Krhs ) ! Main program of Sediment model 205 ! 206 ENDIF 207 ! 208 DO jn = jp_pcs0, jp_pcs1 209 tr(:,:,:,jn,Krhs) = ( tr(:,:,:,jn,Kbb) - ztrbbio(:,:,:,jn) ) * rfactr 210 tr(:,:,:,jn,Kbb ) = ztrbbio(:,:,:,jn) 211 ztrbbio(:,:,:,jn) = 0._wp 205 212 END DO 206 213 ! 207 214 IF( l_trdtrc ) THEN 208 215 DO jn = jp_pcs0, jp_pcs1 209 ztrdt(:,:,:,jn) = ( tr(:,:,:,jn,Kbb) - ztrdt(:,:,:,jn) ) * rfactr210 216 CALL trd_trc( tr(:,:,:,jn,Krhs), jn, jptra_sms, kt, Kmm ) ! save trends 211 217 END DO 212 DEALLOCATE( ztrdt )213 218 END IF 214 #endif 215 ! 216 IF( ln_sediment ) THEN 217 ! 218 CALL sed_model( kt, Kbb, Kmm, Krhs ) ! Main program of Sediment model 219 ! 220 IF( ln_top_euler ) THEN 221 DO jn = jp_pcs0, jp_pcs1 222 tr(:,:,:,jn,Kmm) = tr(:,:,:,jn,Kbb) 223 END DO 224 ENDIF 225 ! 226 ENDIF 227 ! 219 ! 228 220 IF( lrst_trc ) CALL p4z_rst( kt, Kbb, Kmm, 'WRITE' ) !* Write PISCES informations in restart file 229 221 ! -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/TOP/PISCES/P4Z/p5zlim.F90
r13295 r13998 306 306 & / (xqndmax(ji,jj,jk) - 2. * xqndmin(ji,jj,jk) ) ) & 307 307 & * xqndmax(ji,jj,jk) / (zration + rtrn) 308 zlim3 = tr(ji,jj,jk,jpsil,Kbb) / ( tr(ji,jj,jk,jpsil,Kbb) + xksi(ji,jj) )308 zlim3 = tr(ji,jj,jk,jpsil,Kbb) / ( tr(ji,jj,jk,jpsil,Kbb) + xksi(ji,jj) + rtrn ) 309 309 zlim4 = MAX( 0., ( zratiof - zqfemd ) / qfdopt ) 310 310 xlimdfe(ji,jj,jk) = MIN( 1., zlim4 ) -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/TOP/TRP/trdmxl_trc.F90
r13295 r13998 148 148 ! ... Weights for vertical averaging 149 149 wkx_trc(:,:,:) = 0.e0 150 DO_3D( 1, 1, 1, 1, 1, jpktrd_trc ) 150 DO_3D( 1, 1, 1, 1, 1, jpktrd_trc ) ! initialize wkx_trc with vertical scale factor in mixed-layer 151 151 IF( jk - nmld_trc(ji,jj) < 0 ) wkx_trc(ji,jj,jk) = e3t(ji,jj,jk,Kmm) * tmask(ji,jj,jk) 152 152 END_3D -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/TOP/oce_trc.F90
r13286 r13998 85 85 USE traqsr , ONLY : rn_abs => rn_abs !: fraction absorbed in the very near surface 86 86 USE traqsr , ONLY : rn_si0 => rn_si0 !: very near surface depth of extinction 87 USE traqsr , ONLY : nksr => nksr !: levels below which the light cannot penetrate (depth larger than 391 m) 88 USE traqsr , ONLY : rkrgb => rkrgb !: tabulated attenuation coefficients for RGB absorption 87 89 USE traqsr , ONLY : ln_qsr_bio => ln_qsr_bio !: flag to use or not the biological fluxes for light 88 90 USE sbcrnf , ONLY : rnfmsk => rnfmsk !: mixed adv scheme in runoffs vicinity (hori.) -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/TOP/trc.F90
r12489 r13998 21 21 INTEGER, PUBLIC :: numonr = -1 !: reference passive tracer namelist output output.namelist.top 22 22 INTEGER, PUBLIC :: numstr !: tracer statistics 23 INTEGER, PUBLIC :: numrtr 23 INTEGER, PUBLIC :: numrtr = -1 !: trc restart (read ) 24 24 INTEGER, PUBLIC :: numrtw !: trc restart ( write ) 25 25 CHARACTER(:), ALLOCATABLE, PUBLIC :: numnat_ref !: character buffer for reference passive tracer namelist_top_ref -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/TOP/trcbdy.F90
r13226 r13998 49 49 INTEGER :: ib_bdy ,ir, jn ,igrd ! Loop indices 50 50 REAL(wp), POINTER, DIMENSION(:,:) :: ztrc 51 REAL(wp), POINTER :: zfac52 51 LOGICAL :: llrim0 ! indicate if rim 0 is treated 53 52 LOGICAL, DIMENSION(4) :: llsend1, llrecv1 ! indicate how communications are to be carried out … … 61 60 IF( ir == 0 ) THEN ; llrim0 = .TRUE. 62 61 ELSE ; llrim0 = .FALSE. 63 END 62 ENDIF 64 63 DO ib_bdy=1, nb_bdy 64 ! 65 65 DO jn = 1, jptra 66 66 ! 67 ztrc => trcdta_bdy(jn,ib_bdy)%trc 68 zfac => trcdta_bdy(jn,ib_bdy)%rn_fac 67 IF( ASSOCIATED(trcdta_bdy(jn,ib_bdy)%trc) .AND. trcdta_bdy(jn,ib_bdy)%cn_obc /= 'neumann' ) THEN 68 IF( .NOT. ASSOCIATED(ztrc) ) ALLOCATE( ztrc(idx_bdy(ib_bdy)%nblen(igrd),jpk) ) 69 ztrc(:,:) = trcdta_bdy(jn,ib_bdy)%trc(:,:) * trcdta_bdy(jn,ib_bdy)%rn_fac 70 ENDIF 69 71 ! 70 SELECT CASE( TRIM(trcdta_bdy(jn,ib_bdy)%cn_obc))72 SELECT CASE( trcdta_bdy(jn,ib_bdy)%cn_obc ) 71 73 CASE('none' ) ; CYCLE 72 74 CASE('frs' ) ! treat the whole boundary at once 73 IF( ir == 0 ) CALL bdy_frs( idx_bdy(ib_bdy), tr(:,:,:,jn,Krhs), ztrc*zfac )75 IF( ir == 0 ) CALL bdy_frs( idx_bdy(ib_bdy), tr(:,:,:,jn,Krhs), ztrc ) 74 76 CASE('specified' ) ! treat the whole rim at once 75 IF( ir == 0 ) CALL bdy_spe( idx_bdy(ib_bdy), tr(:,:,:,jn,Krhs), ztrc*zfac ) 76 CASE('neumann' ) ; CALL bdy_nmn( idx_bdy(ib_bdy), igrd , tr(:,:,:,jn,Krhs) ) ! tra masked 77 CASE('orlanski' ) ; CALL bdy_orl( idx_bdy(ib_bdy), tr(:,:,:,jn,Kbb), tr(:,:,:,jn,Krhs), ztrc*zfac, ll_npo=.false. ) 78 CASE('orlanski_npo') ; CALL bdy_orl( idx_bdy(ib_bdy), tr(:,:,:,jn,Kbb), tr(:,:,:,jn,Krhs), ztrc*zfac, ll_npo=.true. ) 77 IF( ir == 0 ) CALL bdy_spe( idx_bdy(ib_bdy), tr(:,:,:,jn,Krhs), ztrc ) 78 CASE('neumann' ) ; CALL bdy_nmn( idx_bdy(ib_bdy), igrd , tr(:,:,:,jn,Krhs), llrim0 ) ! tra masked 79 CASE('orlanski' ) ; CALL bdy_orl( idx_bdy(ib_bdy), tr(:,:,:,jn,Kbb), tr(:,:,:,jn,Krhs), ztrc, llrim0, & 80 & ll_npo=.FALSE. ) 81 CASE('orlanski_npo') ; CALL bdy_orl( idx_bdy(ib_bdy), tr(:,:,:,jn,Kbb), tr(:,:,:,jn,Krhs), ztrc, llrim0, & 82 & ll_npo=.TRUE. ) 79 83 CASE DEFAULT ; CALL ctl_stop( 'trc_bdy : unrecognised option for open boundaries for passive tracers' ) 80 84 END SELECT 81 85 ! 82 86 END DO 87 ! 88 IF( ASSOCIATED(ztrc) ) DEALLOCATE(ztrc) 89 ! 83 90 END DO 84 91 ! 85 92 IF( nn_hls > 1 .AND. ir == 1 ) CYCLE ! at least 2 halos will be corrected -> no need to correct rim 1 before rim 0 86 IF( nn_hls == 1 ) THEN ; llsend1(:) = .false. ; llrecv1(:) = .false. ; END 93 IF( nn_hls == 1 ) THEN ; llsend1(:) = .false. ; llrecv1(:) = .false. ; ENDIF 87 94 DO ib_bdy=1, nb_bdy 88 SELECT CASE( TRIM(cn_tra(ib_bdy)) )95 SELECT CASE( cn_tra(ib_bdy) ) 89 96 CASE('neumann') 90 97 llsend1(:) = llsend1(:) .OR. lsend_bdyint(ib_bdy,1,:,ir) ! possibly every direction, T points … … 97 104 IF( ANY(llsend1) .OR. ANY(llrecv1) ) THEN ! if need to send/recv in at least one direction 98 105 CALL lbc_lnk( 'trcbdy', tr(:,:,:,:,Krhs), 'T', 1.0_wp, kfillmode=jpfillnothing ,lsend=llsend1, lrecv=llrecv1 ) 99 END 106 ENDIF 100 107 ! 101 108 END DO ! ir -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/TOP/trcdta.F90
r13295 r13998 199 199 WRITE(numout,*) 'trc_dta: interpolates passive tracer data onto the s- or mixed s-z-coordinate mesh' 200 200 ENDIF 201 DO_2D( 1, 1, 1, 1 ) 201 DO_2D( 1, 1, 1, 1 ) ! vertical interpolation of T & S 202 202 DO jk = 1, jpk ! determines the intepolated T-S profiles at each (i,j) points 203 203 zl = gdept(ji,jj,jk,Kmm) -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/TOP/trcrst.F90
r13286 r13998 237 237 ! calculate start time in hours and minutes 238 238 zdayfrac=adatrj-INT(adatrj) 239 ksecs = NINT(zdayfrac*86400) ! Nearest second to catch rounding errors in adatrj 239 ksecs = NINT(zdayfrac*86400) ! Nearest second to catch rounding errors in adatrj 240 240 ihour = INT(ksecs/3600) 241 241 iminute = ksecs/60-ihour*60 … … 258 258 adatrj = INT(adatrj) ! adatrj set to integer as nn_time0 updated 259 259 ELSE 260 ndt05 = NINT( 0.5 * rn_Dt ) ! --- WARNING --- not defined yet are we did not go through day_init 260 261 ! parameters corresponding to nit000 - 1 (as we start the step 261 262 ! loop with a call to day) 262 ndastp = ndate0 - 1! ndate0 read in the namelist in dom_nam263 ndastp = ndate0 ! ndate0 read in the namelist in dom_nam 263 264 nhour = nn_time0 / 100 264 265 nminute = ( nn_time0 - nhour * 100 )
Note: See TracChangeset
for help on using the changeset viewer.